- DIARA ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS (CONT) ;22SEP2004
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- ENTD ; PURGE
- 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.",!
- 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)
- D FILE^DIARU G Q:'$D(DIARC)
- 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."
- 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"
- D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT)!($G(Y)'=1)
- 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
- W !!,"The entries will be deleted in INTERNAL NUMBER order."
- 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
- D0 S DA=$O(^DIBT(DIARU,1,0))
- I DA="" W !!,"<< ",$P(^DIAR(1.11,DIARC,0),U,7)," ENTRIES PURGED >>" K ^("D"),^("EX") D UPDATE^DIARU G Q
- S DIK=DIC,DIARS(0)=$S($D(@(DIC_"DA,0)")):^(0),1:"") K ^DIBT(DIARU,1,DA)
- I DIARS(0)="" S Y=$P(^DIAR(1.11,DIARC,0),U,7),$P(^(0),U,7)=Y-1 G D0
- D ^DIK G D0:DIARF'=DIARF2 S Y=DIARS(0),X=$P(Y,U)
- D F I=1:1 Q:$P($G(DIARS),U,I)="" S %=$P(DIARS,U,I),$P(X,U,%)=$P(Y,U,%)
- E G D0
- ;
- ENTC ;CANCEL
- S DIC("A")="CANCEL WHICH "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" SELECTION: " D FILE^DIARU G Q:'$D(DIARC)
- S DIR("A")="Are you sure you want to CANCEL this "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" ACTIVITY",DIR("B")="NO",DIR(0)="Y"
- S DIR("??")="^W !!?5,""Enter YES to stop this activity and start again from the beginning."""
- D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT),UNLK:'Y
- F I=0:0 S I=$O(^DIBT(+DIARU,1,I)) Q:'I K @(DIC_I_",-9)")
- 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
- S DIK="^DIAR(1.11,",DA=DIARC D ^DIK W !!,">>> DONE <<<"
- G Q
- ;
- OUT ;USED TO PRINT LISTING OR TO WRITE TO TEMP.STORAGE
- K DIARC,FLDS D FILE^DIARU G Q:'$D(DIARC)
- S DIARD=0 W !!
- D @DIAR
- 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_"]"
- 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
- K DIE,DR,DA S BY="[`"_DIARU_"]",DIARI=DIARU S:DIAR=3 BY=BY_",.01"
- S DHD=$P(^DIC(DIARF,0),U)_$S($D(DIAX):" EXTRACT",1:" ARCHIVING")_" ACTIVITY",DIC=^(0,"GL")
- F %=0:0 S %=$O(^DIAR(1.11,DIARC,"S",%)) Q:%'>0 S DIFG(+DIARF2,^(%,0))=^(1)
- S %=$O(DIFG(+DIARF2,"")) K:%="" DIFG
- I $D(DIFG) S DIFG(+DIARF2,"S")="X DIFG("_+DIARF2_","_%_")"
- D EN1^DIP
- I DIAR'=3,$G(POP) G UNLK
- G Q
- UNLK S DIAR="" D UPDATE^DIARU
- Q K POP G Q^DIARB
- ;
- 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
- 4 W "You MUST enter a FILEGRAM template name. This FILEGRAM template will be used",!,"to actually build the archive message." Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARA 3829 printed Feb 19, 2025@00:11:02 Page 2
- DIARA ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS (CONT) ;22SEP2004
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- ENTD ; PURGE
- +1 if '$DATA(DIAX)
- WRITE !!,$CHAR(7),$CHAR(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.",!
- +2 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to proceed"
- SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DUOUT)!$DATA(DTOUT)!($GET(Y)'=1)
- QUIT
- +3 DO FILE^DIARU
- if '$DATA(DIARC)
- GOTO Q
- +4 IF $DATA(^DD(DIARF,0,"PT"))
- WRITE !!,$CHAR(7),"The records about to be purged should not be 'pointed to' by other records to",!,"maintain database integrity."
- +5 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A",1)="This option will DELETE DATA from both "_$PIECE(^DIC(DIARF,0),U)
- SET DIR("A",2)="and from the ARCHIVAL ACTIVITY file."
- SET DIR("A")="Are you sure you want to continue"
- SET DIR("B")="NO"
- +6 DO ^DIR
- if $DATA(DUOUT)!$DATA(DTOUT)!($GET(Y)'=1)
- GOTO UNLK
- +7 SET DIFILE=DIARF
- SET DIAC="DEL"
- DO ^DIAC
- IF '%
- WRITE !,$CHAR(7),"Sorry, you cannot purge this archival activity!",!,"You do not have DELETE access to ",$PIECE(^DIC(DIARF,0),U),"."
- GOTO UNLK
- +8 WRITE !!,"The entries will be deleted in INTERNAL NUMBER order."
- +9 SET DIARS=""
- FOR K="ID","SP"
- FOR I=0:0
- SET I=$ORDER(^DD(DIARF,0,K,I))
- if +I'=I
- QUIT
- IF $DATA(^DD(DIARF,I,0))#2
- SET X=$PIECE(^(0),U,4)
- IF $PIECE(X,";")=0
- SET DIARS=DIARS_$PIECE(X,";",2)_U
- D0 SET DA=$ORDER(^DIBT(DIARU,1,0))
- +1 IF DA=""
- WRITE !!,"<< ",$PIECE(^DIAR(1.11,DIARC,0),U,7)," ENTRIES PURGED >>"
- KILL ^("D"),^("EX")
- DO UPDATE^DIARU
- GOTO Q
- +2 SET DIK=DIC
- SET DIARS(0)=$SELECT($DATA(@(DIC_"DA,0)")):^(0),1:"")
- KILL ^DIBT(DIARU,1,DA)
- +3 IF DIARS(0)=""
- SET Y=$PIECE(^DIAR(1.11,DIARC,0),U,7)
- SET $PIECE(^(0),U,7)=Y-1
- GOTO D0
- +4 DO ^DIK
- if DIARF'=DIARF2
- GOTO D0
- SET Y=DIARS(0)
- SET X=$PIECE(Y,U)
- D FOR I=1:1
- if $PIECE($GET(DIARS),U,I)=""
- QUIT
- SET %=$PIECE(DIARS,U,I)
- SET $PIECE(X,U,%)=$PIECE(Y,U,%)
- E GOTO D0
- +1 ;
- ENTC ;CANCEL
- +1 SET DIC("A")="CANCEL WHICH "_$SELECT($DATA(DIAX):"EXTRACT",1:"ARCHIVING")_" SELECTION: "
- DO FILE^DIARU
- if '$DATA(DIARC)
- GOTO Q
- +2 SET DIR("A")="Are you sure you want to CANCEL this "_$SELECT($DATA(DIAX):"EXTRACT",1:"ARCHIVING")_" ACTIVITY"
- SET DIR("B")="NO"
- SET DIR(0)="Y"
- +3 SET DIR("??")="^W !!?5,""Enter YES to stop this activity and start again from the beginning."""
- +4 DO ^DIR
- if $DATA(DUOUT)!$DATA(DTOUT)
- GOTO UNLK
- if 'Y
- GOTO UNLK
- +5 FOR I=0:0
- SET I=$ORDER(^DIBT(+DIARU,1,I))
- if 'I
- QUIT
- KILL @(DIC_I_",-9)")
- +6 IF $DATA(DIAX)
- SET DIAXNRB=0
- IF DIARST=6
- IF $DATA(^DIAR(1.11,DIARC,"EX"))
- DO ASK^DIARB
- if $DATA(DUOUT)!$DATA(DTOUT)
- GOTO UNLK
- IF 'DIAXNRB
- IF $DATA(^DIAR(1.11,DIARC,"EX"))
- SET DIK=^DIC(DIAXFNO,0,"GL")
- SET DA=0
- SET DIOVRD=1
- FOR
- SET DA=$ORDER(^DIAR(1.11,DIARC,"EX","B",DA))
- if DA'>0
- QUIT
- DO ^DIK
- +7 SET DIK="^DIAR(1.11,"
- SET DA=DIARC
- DO ^DIK
- WRITE !!,">>> DONE <<<"
- +8 GOTO Q
- +9 ;
- OUT ;USED TO PRINT LISTING OR TO WRITE TO TEMP.STORAGE
- +1 KILL DIARC,FLDS
- DO FILE^DIARU
- if '$DATA(DIARC)
- GOTO Q
- +2 SET DIARD=0
- WRITE !!
- +3 DO @DIAR
- +4 IF DIAR'=3
- KILL DIARP
- SET DIE="^DIAR(1.11,"
- SET DA=DIARC
- SET DR="3;S DIARP=X"
- DO ^DIE
- if $DATA(DTOUT)!'$DATA(DIARP)
- GOTO UNLK
- SET FLDS="[`"_DIARP_"]"
- +5 SET FR=""
- SET TO=""
- SET L=0
- KILL DIOEND
- if (DIAR'=3)
- SET DIOEND="W !,$P(^DIAR(1.11,DIARC,0),U,7)"_","""_" ITEMS HAVE BEEN "_$SELECT($DATA(DIAX):"EXTRACTED",1:"ARCHIVED")_""""
- SET DISTOP=0
- +6 KILL DIE,DR,DA
- SET BY="[`"_DIARU_"]"
- SET DIARI=DIARU
- if DIAR=3
- SET BY=BY_",.01"
- +7 SET DHD=$PIECE(^DIC(DIARF,0),U)_$SELECT($DATA(DIAX):" EXTRACT",1:" ARCHIVING")_" ACTIVITY"
- SET DIC=^(0,"GL")
- +8 FOR %=0:0
- SET %=$ORDER(^DIAR(1.11,DIARC,"S",%))
- if %'>0
- QUIT
- SET DIFG(+DIARF2,^(%,0))=^(1)
- +9 SET %=$ORDER(DIFG(+DIARF2,""))
- if %=""
- KILL DIFG
- +10 IF $DATA(DIFG)
- SET DIFG(+DIARF2,"S")="X DIFG("_+DIARF2_","_%_")"
- +11 DO EN1^DIP
- +12 IF DIAR'=3
- IF $GET(POP)
- GOTO UNLK
- +13 GOTO Q
- UNLK SET DIAR=""
- DO UPDATE^DIARU
- Q KILL POP
- GOTO Q^DIARB
- +1 ;
- 3 WRITE "Enter regular Print Template name or fields you wish to see printed on this",!,"report of entries to be "_$SELECT($DATA(DIAX):"extracted.",1:"archived.")
- QUIT
- 4 WRITE "You MUST enter a FILEGRAM template name. This FILEGRAM template will be used",!,"to actually build the archive message."
- QUIT