- DIARU ;SFISC/TKW-ARCHIVING FUNCTIONS (CONT) ;2/18/93 5:21 AM
- ;;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.
- ;
- UPDATE ;UPDATE ARCHIVING FILE (DJ=#ITEMS SELECTED) called w/in DIO4
- N DIE D:DIAR=3 NOW^%DTC S DA=DIARC,DIE="^DIAR(1.11,",X=""
- S:DIAR&(DIAR'=3) X="7////"_DIAR_";"
- S X=X_"13////@;14////@;15////@"
- I DIAR=1 S X=X_";4////"_DT_$S($D(^VA(200)):";8////"_DUZ,1:"")_";6////"_DJ
- I DIAR=3 S X=X_";12////"_%
- I DIAR=4!(DIAR=5)!(DIAR=6) S X=X_$S($D(^VA(200)):";5////"_DUZ,1:"")_";10////"_DT
- ;I DIAR=3!(DIAR=4),U'[DIARP S %=$P(DIARP,U,2),X=X_";3////"_$S(%:%,1:+DIARP)
- I DIAR=90 S X=X_$S($D(^VA(200)):";9////"_DUZ,1:"")_";11////"_DT
- S DR=X,DA=DIARC D ^DIE S DV=""
- Q
- ;
- FILE ;LOOKUP ARCHIVING ACTIVITY
- K DIC S DIC(0)="AEQIMZ",DIC="^DIAR(1.11,",DIC("S")="I $P(^(0),U,8)<90"_$S($D(DIAX):",$P(^(0),U,17)",1:",'+$P(^(0),U,17)"),DIC("A")="Select "_$S($D(DIAX):"EXTRACT",1:"ARCHIVAL")_" ACTIVITY: "
- D ^DIC Q:Y<0!$D(DUOUT)!$D(DTOUT)
- I $P(Y(0),U,14) D ER1 Q
- S DIARC=+Y,DIARF=$P(Y(0),U,2),DIARU=$P(Y(0),U,3),DIARP=$P(Y(0),U,4),DIARST=$P(Y(0),U,8) S:$D(DIAX) DIAXFNO=+$P(Y(0),U,18)
- I DIAR'=99,'DIARU W !!,$C(7),"No selection template used for this ARCHIVING ACTIVITY--CANCEL it!" K DIARC Q
- I (DIAR=2!(DIAR=4)),DIARST>2 D ER2 K DIARC Q
- I DIAR=5 W:DIARST=5 $C(7),!!,"This data has already been moved to permanent storage once !!",! I DIARST<4 D ER3 K DIARC Q
- I DIAR=6,DIARST=6 W !!,$C(7),"This data has already been moved to the destination file!",!,"PURGE data or CANCEL this extract activity." K DIARC Q
- I DIAR=90,$S($D(DIAX):DIARST'=6,1:DIARST'=5) D ER4 K DIARC Q
- I DIAR=99 D:DIARST=5 MSG I DIARST>6 D ER5 K DIARC Q
- S DIARF2=$S($D(^DIAR(1.11,+Y,1)):^(1),1:DIARF)
- S DIARX=Y(0) D:DIAR'=3 MRK S Y(0)=DIARX,DIC=$G(^DIC(+DIARF,0,"GL")) I DIC="" D ER6 S DIK="^DIAR(1.11,",DA=DIARC D ^DIK K DIK,DIARC Q
- Q
- ;
- MRK ;SET FIELDS TO LOCK OUT OTHER USERS DURING ARCHIVING ACTIVITY
- D NOW^%DTC S DIE="^DIAR(1.11,",DA=DIARC,DR="13////"_DIAR_";14////"_%_";15////"_DUZ D ^DIE
- Q
- ;
- ER1 W $C(7),!!!,"The following Archival Activity is in progress--no access allowed!",!
- S DIARX=Y(0),Y=$P(Y(0),U,14),C=$P(^DD(1.11,13,0),U,2) D Y^DIQ W Y_" STARTED: " S Y=$P(DIARX,U,15) X:Y ^DD("DD") W Y_" BY: " W:$S($D(^VA(200,+$P(DIARX,U,16),0)):1,1:$D(^DIC(3,+$P(DIARX,U,16),0))) $P(^(0),U,1) W ! Q
- ER2 I $D(DIAX) W !!,$C(7),"Data has already been moved to the destination file.",!,"List cannot be edited." Q
- W !!,$C(7),"This data has already been archived to "_$S(DIARST=4:"temporary",1:"permanent")_" storage" W:DIARST>5 " and purged" W ".",! W:DIAR=2 "List cannot be edited after data has been archived!" Q
- ER3 W !!,$C(7),"Cannot write to permanent storage until data has been written",!,"to temporary storage!!" Q
- ER4 W !!,$C(7),$S(DIARST>6:"Data ALREADY purged",$D(DIAX):"Data has NOT YET been moved to the destination file",1:"Data has NOT YET been archived to PERMANENT storage"),"!",! Q
- ER5 W !!,$C(7),"Cannot cancel archiving record after archiving has been complete--this now",!,"acts as your history!!" Q
- ER6 W !!,$C(7),"Source File is missing!",!,"I AM DELETING THIS ",$S($D(DIAX):"EXTRACT",1:"ARCHIVING")," ACTIVITY!" Q
- MSG W !!,$C(7),"Just a reminder--you have already archived these records to permanent storage.",!,"You probably won't want to save the sequential storage media since you",!,"are cancelling this archiving activity!!",! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARU 3637 printed Feb 19, 2025@00:11:12 Page 2
- DIARU ;SFISC/TKW-ARCHIVING FUNCTIONS (CONT) ;2/18/93 5:21 AM
- +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 ;
- UPDATE ;UPDATE ARCHIVING FILE (DJ=#ITEMS SELECTED) called w/in DIO4
- +1 NEW DIE
- if DIAR=3
- DO NOW^%DTC
- SET DA=DIARC
- SET DIE="^DIAR(1.11,"
- SET X=""
- +2 if DIAR&(DIAR'=3)
- SET X="7////"_DIAR_";"
- +3 SET X=X_"13////@;14////@;15////@"
- +4 IF DIAR=1
- SET X=X_";4////"_DT_$SELECT($DATA(^VA(200)):";8////"_DUZ,1:"")_";6////"_DJ
- +5 IF DIAR=3
- SET X=X_";12////"_%
- +6 IF DIAR=4!(DIAR=5)!(DIAR=6)
- SET X=X_$SELECT($DATA(^VA(200)):";5////"_DUZ,1:"")_";10////"_DT
- +7 ;I DIAR=3!(DIAR=4),U'[DIARP S %=$P(DIARP,U,2),X=X_";3////"_$S(%:%,1:+DIARP)
- +8 IF DIAR=90
- SET X=X_$SELECT($DATA(^VA(200)):";9////"_DUZ,1:"")_";11////"_DT
- +9 SET DR=X
- SET DA=DIARC
- DO ^DIE
- SET DV=""
- +10 QUIT
- +11 ;
- FILE ;LOOKUP ARCHIVING ACTIVITY
- +1 KILL DIC
- SET DIC(0)="AEQIMZ"
- SET DIC="^DIAR(1.11,"
- SET DIC("S")="I $P(^(0),U,8)<90"_$SELECT($DATA(DIAX):",$P(^(0),U,17)",1:",'+$P(^(0),U,17)")
- SET DIC("A")="Select "_$SELECT($DATA(DIAX):"EXTRACT",1:"ARCHIVAL")_" ACTIVITY: "
- +2 DO ^DIC
- if Y<0!$DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +3 IF $PIECE(Y(0),U,14)
- DO ER1
- QUIT
- +4 SET DIARC=+Y
- SET DIARF=$PIECE(Y(0),U,2)
- SET DIARU=$PIECE(Y(0),U,3)
- SET DIARP=$PIECE(Y(0),U,4)
- SET DIARST=$PIECE(Y(0),U,8)
- if $DATA(DIAX)
- SET DIAXFNO=+$PIECE(Y(0),U,18)
- +5 IF DIAR'=99
- IF 'DIARU
- WRITE !!,$CHAR(7),"No selection template used for this ARCHIVING ACTIVITY--CANCEL it!"
- KILL DIARC
- QUIT
- +6 IF (DIAR=2!(DIAR=4))
- IF DIARST>2
- DO ER2
- KILL DIARC
- QUIT
- +7 IF DIAR=5
- if DIARST=5
- WRITE $CHAR(7),!!,"This data has already been moved to permanent storage once !!",!
- IF DIARST<4
- DO ER3
- KILL DIARC
- QUIT
- +8 IF DIAR=6
- IF DIARST=6
- WRITE !!,$CHAR(7),"This data has already been moved to the destination file!",!,"PURGE data or CANCEL this extract activity."
- KILL DIARC
- QUIT
- +9 IF DIAR=90
- IF $SELECT($DATA(DIAX):DIARST'=6,1:DIARST'=5)
- DO ER4
- KILL DIARC
- QUIT
- +10 IF DIAR=99
- if DIARST=5
- DO MSG
- IF DIARST>6
- DO ER5
- KILL DIARC
- QUIT
- +11 SET DIARF2=$SELECT($DATA(^DIAR(1.11,+Y,1)):^(1),1:DIARF)
- +12 SET DIARX=Y(0)
- if DIAR'=3
- DO MRK
- SET Y(0)=DIARX
- SET DIC=$GET(^DIC(+DIARF,0,"GL"))
- IF DIC=""
- DO ER6
- SET DIK="^DIAR(1.11,"
- SET DA=DIARC
- DO ^DIK
- KILL DIK,DIARC
- QUIT
- +13 QUIT
- +14 ;
- MRK ;SET FIELDS TO LOCK OUT OTHER USERS DURING ARCHIVING ACTIVITY
- +1 DO NOW^%DTC
- SET DIE="^DIAR(1.11,"
- SET DA=DIARC
- SET DR="13////"_DIAR_";14////"_%_";15////"_DUZ
- DO ^DIE
- +2 QUIT
- +3 ;
- ER1 WRITE $CHAR(7),!!!,"The following Archival Activity is in progress--no access allowed!",!
- +1 SET DIARX=Y(0)
- SET Y=$PIECE(Y(0),U,14)
- SET C=$PIECE(^DD(1.11,13,0),U,2)
- DO Y^DIQ
- WRITE Y_" STARTED: "
- SET Y=$PIECE(DIARX,U,15)
- if Y
- XECUTE ^DD("DD")
- WRITE Y_" BY: "
- if $SELECT($DATA(^VA(200,+$PIECE(DIARX,U,16),0))
- WRITE $PIECE(^(0),U,1)
- WRITE !
- QUIT
- ER2 IF $DATA(DIAX)
- WRITE !!,$CHAR(7),"Data has already been moved to the destination file.",!,"List cannot be edited."
- QUIT
- +1 WRITE !!,$CHAR(7),"This data has already been archived to "_$SELECT(DIARST=4:"temporary",1:"permanent")_" storage"
- if DIARST>5
- WRITE " and purged"
- WRITE ".",!
- if DIAR=2
- WRITE "List cannot be edited after data has been archived!"
- QUIT
- ER3 WRITE !!,$CHAR(7),"Cannot write to permanent storage until data has been written",!,"to temporary storage!!"
- QUIT
- ER4 WRITE !!,$CHAR(7),$SELECT(DIARST>6:"Data ALREADY purged",$DATA(DIAX):"Data has NOT YET been moved to the destination file",1:"Data has NOT YET been archived to PERMANENT storage"),"!",!
- QUIT
- ER5 WRITE !!,$CHAR(7),"Cannot cancel archiving record after archiving has been complete--this now",!,"acts as your history!!"
- QUIT
- ER6 WRITE !!,$CHAR(7),"Source File is missing!",!,"I AM DELETING THIS ",$SELECT($DATA(DIAX):"EXTRACT",1:"ARCHIVING")," ACTIVITY!"
- QUIT
- MSG WRITE !!,$CHAR(7),"Just a reminder--you have already archived these records to permanent storage.",!,"You probably won't want to save the sequential storage media since you",!,"are cancelling this archiving activity!!",!
- QUIT