Return to DIARA.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Annotation of freem_fileman/USER/DIARA.m, revision 1.1

1.1     ! snw         1: DIARA  ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS (CONT) ;9/2/94  10:11
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4: ENTD   ; PURGE
        !             5:        W:'$D(DIAX) !!,$C(7),$C(7),"BEFORE YOU PURGE, MAKE SURE THAT YOUR ARCHIVE MEDIUM IS READABLE!",!,"YOU MAY USE THE FIND ARCHIVED ENTRIES OPTION TO FIND THE LAST",!,"ARCHIVED RECORD APPEARING ON THE INDEX.",!
        !             6:        K DIR S DIR(0)="Y",DIR("A")="Do you want to proceed",DIR("B")="NO" D ^DIR Q:$D(DUOUT)!$D(DTOUT)!($G(Y)'=1)
        !             7:        D FILE^DIARU G Q:'$D(DIARC)
        !             8:        I $D(^DD(DIARF,0,"PT")) W !!,$C(7),"The records about to be purged should not be 'pointed to' by other records to",!,"maintain database integrity."
        !             9:        W ! K DIR S DIR(0)="Y",DIR("A",1)="This option will DELETE DATA from both "_$P(^DIC(DIARF,0),U),DIR("A",2)="and from the ARCHIVAL ACTIVITY file.",DIR("A")="Are you sure you want to continue",DIR("B")="NO"
        !            10:        D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT)!($G(Y)'=1)
        !            11:        S DIFILE=DIARF,DIAC="DEL" D ^DIAC I '% W !,$C(7),"Sorry, you cannot purge this archival activity!",!,"You do not have DELETE access to ",$P(^DIC(DIARF,0),U),"." G UNLK
        !            12:        W !!,"The entries will be deleted in INTERNAL NUMBER order."
        !            13:        S DIARS="" F K="ID","SP" F I=0:0 S I=$O(^DD(DIARF,0,K,I)) Q:+I'=I  I $D(^DD(DIARF,I,0))#2 S X=$P(^(0),U,4) I $P(X,";")=0 S DIARS=DIARS_$P(X,";",2)_U
        !            14: D0     S DA=$O(^DIBT(DIARU,1,0))
        !            15:        I DA="" W !!,"<< ",$P(^DIAR(1.11,DIARC,0),U,7)," ENTRIES PURGED >>" K ^("D"),^("EX") D UPDATE^DIARU G Q
        !            16:        S DIK=DIC,DIARS(0)=$S($D(@(DIC_"DA,0)")):^(0),1:"") K ^DIBT(DIARU,1,DA)
        !            17:        I DIARS(0)="" S Y=$P(^DIAR(1.11,DIARC,0),U,7),$P(^(0),U,7)=Y-1 G D0
        !            18:        D ^DIK G D0:DIARF'=DIARF2 S Y=DIARS(0),X=$P(Y,U) G E:'$D(DIARS)#2
        !            19: D      F I=1:1 Q:$P(DIARS,U,I)=""  S %=$P(DIARS,U,I),$P(X,U,%)=$P(Y,U,%)
        !            20: E      ;SETS -9 NODE & STUB IN ORIGINAL FILE.  NOT DONE FOR V18
        !            21:        ;S @(DIC_"DA,-9)")=DIARC,^(0)=X
        !            22:        G D0
        !            23:        ;
        !            24: ENTC   ;CANCEL
        !            25:        S DIC("A")="CANCEL WHICH "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" SELECTION: " D FILE^DIARU G Q:'$D(DIARC)
        !            26:        S DIR("A")="Are you sure you want to CANCEL this "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" ACTIVITY",DIR("B")="NO",DIR(0)="Y"
        !            27:        S DIR("??")="^W !!?5,""Enter YES to stop this activity and start again from the beginning."""
        !            28:        D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT),UNLK:'Y
        !            29:        F I=0:0 S I=$O(^DIBT(+DIARU,1,I)) Q:'I  K @(DIC_I_",-9)")
        !            30:        I $D(DIAX) S DIAXNRB=0 I DIARST=6,$D(^DIAR(1.11,DIARC,"EX")) D ASK^DIARB G UNLK:$D(DUOUT)!$D(DTOUT) I 'DIAXNRB,$D(^DIAR(1.11,DIARC,"EX")) S DIK=^DIC(DIAXFNO,0,"GL"),DA=0,DIOVRD=1 F  S DA=$O(^DIAR(1.11,DIARC,"EX","B",DA)) Q:DA'>0  D ^DIK
        !            31:        S DIK="^DIAR(1.11,",DA=DIARC D ^DIK W !!,">>> DONE <<<"
        !            32:        G Q
        !            33:        ;
        !            34: OUT    ;USED TO PRINT LISTING OR TO WRITE TO TEMP.STORAGE
        !            35:        K DIARC,FLDS D FILE^DIARU G Q:'$D(DIARC)
        !            36:        S DIARD=0 W !!
        !            37:        D @DIAR
        !            38:        I DIAR'=3 K DIARP S DIE="^DIAR(1.11,",DA=DIARC,DR="3;S DIARP=X" D ^DIE G UNLK:$D(DTOUT)!'$D(DIARP) S FLDS="[`"_DIARP_"]"
        !            39:        I DIAR=6 D 61^DIARB I $G(DIERR) K DIARP G UNLK
        !            40:        S FR="",TO="",L=0 K DIOEND S:(DIAR'=3) DIOEND="W !,$P(^DIAR(1.11,DIARC,0),U,7)"_","""_" ITEMS HAVE BEEN "_$S($D(DIAX):"EXTRACTED",1:"ARCHIVED")_"""",DISTOP=0
        !            41:        K DIE,DR,DA S BY="[`"_DIARU_"]",DIARI=DIARU S:DIAR=3 BY=BY_",.01"
        !            42:        S DHD=$P(^DIC(DIARF,0),U)_$S($D(DIAX):" EXTRACT",1:" ARCHIVING")_" ACTIVITY",DIC=^(0,"GL")
        !            43:        F %=0:0 S %=$O(^DIAR(1.11,DIARC,"S",%)) Q:%'>0  S DIFG(+DIARF2,^(%,0))=^(1)
        !            44:        S %=$O(DIFG(+DIARF2,"")) K:%="" DIFG
        !            45:        I $D(DIFG) S DIFG(+DIARF2,"S")="X DIFG("_+DIARF2_","_%_")"
        !            46:        D EN1^DIP I DIAR'=3,$G(POP) G UNLK
        !            47:        K POP G Q
        !            48: UNLK   S DIAR="" D UPDATE^DIARU
        !            49: Q      K POP G Q^DIARB
        !            50:        ;
        !            51: 3      W "Enter regular Print Template name or fields you wish to see printed on this",!,"report of entries to be "_$S($D(DIAX):"extracted.",1:"archived.") Q
        !            52: 4      W "You MUST enter a FILEGRAM template name.  This FILEGRAM template will be used",!,"to actually build the archive message." Q
        !            53: 6      W "You MUST enter an EXTRACT template name.  This EXTRACT template will be used",!,"to populate your destination file." Q