DIAR ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS ;7/1/93 4:17 PM
;;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.
;
G NOKL
;
1 ;;SELECT ENTRIES TO ARCHIVE
S DIAR=1 D DIAR^DICRW G Q:Y<0 S %=$P(Y,U,2),(Y,DIARF,DIART)=+Y
;TEMPORARY CHANGE TO SKIP SUB-FILE OPTION--NOT COMPLETE
G O
G O:'$O(^DD(DIARF,"SB",0))
W !!,"IF YOU PLAN TO ARCHIVE DATA ONLY FROM ONE SUB-FILE"
W !,"PLEASE IDENTIFY IT HERE. OTHERWISE, JUST PRESS RETURN.",!
D SUB^DICRW G Q:$D(DTOUT)!$D(DUOUT),O:'$D(DIA) S DIARF=DIA
S DIARF0="D0," F D=1:1 Q:'$D(^DD(DIA,0,"UP")) S DIARF0=DIARF0_"D"_D_",",DIA=^("UP")
O S I="" D CHK
I '$D(DIARC) D NEW^DIARCALC G Q:'$D(DIARC) G T1
I $P(Y(0),U,7)>0 W !!,"There is already an outstanding "_$S(+$P(Y(0),U,17):"extract",1:"archiving")_" activity.",!,"Please finish it or CANCEL it.",$C(7),!! G Q
D MRK^DIARU
T1 S DIC=DIART,L="]" I $D(DIARF0) S DIARF1=$L(DIARF0,",")-1
D EN^DIS I '$P(^DIAR(1.11,DIARC,0),U,7) W $C(7),!!,"NO RECORDS WERE SELECTED TO BE "_$S($D(DIAX):"EXTRACTED",1:"ARCHIVED")_"!!",!,"I AM DELETING THIS ARCHIVING ACTIVITY RECORD!!" S DIK="^DIAR(1.11,",DA=DIARC D ^DIK
G Q
;
CHK ;IS THERE A VALID SEARCH ?
K DIARC,Y(0) S I=0,Y=$S($D(DIARF):DIARF,1:Y)
C S I=$O(^DIAR(1.11,"C",+Y,I)) Q:'I S Y(0)=""
G C:'$D(^DIAR(1.11,I,0)) G C:$P(^(0),U,8)>89 S Y(0)=^(0)
S DIC=$P(Y(0),U,2),DIARC=I,DIARU=$P(Y(0),U,3),DIARP=$P(Y(0),U,4)
Q
2 ;;ADD/DELETE SELECTED ENTRIES
S DIAR=2 G ENTE^DIARB
;
3 ;;PRINT SELECTED ENTRIES
S DIAR=3 G OUT^DIARA
;
4 ;;CREATE FILEGRAM ARCHIVING TEMPLATE
S DI=1,DIAR="" G EN^DIFGO
;
5 ;;WRITE ENTRIES TO TEMPORARY STORAGE
S DIAR=4 G OUT^DIARA
;
;
6 ;;MOVE ARCHIVED DATA TO PERMANENT STORAGE
S DIAR=5 D FILE^DIARU G Q:'$D(DIARC)
W !!,"NOTE: This option will 1) print an archive activity report to specified",!,"PRINTER DEVICE and 2) will move archive data to permanent storage to specified",!,"ARCHIVE STORAGE DEVICE."
W !!,"Select some type of SEQUENTIAL media, such as SDP, TAPE, or DISK FILE (HFS),",!,"for archival storage.",!
S %ZIS("A")="PRINTER DEVICE: ",%ZIS("B")="",%ZIS="NQ" D ^%ZIS G 65:POP S DIARPDEV=$S($D(ION)#2:ION,1:IO),DIARTRM=$S(IO=IO(0):1,1:0)
I $D(IOST)#2,IOST]"" S DIARPDEV=DIARPDEV_";"_IOST
F DIARX="IOM","IOSL" S:($D(@DIARX)#2&@DIARX) DIARPDEV=DIARPDEV_";"_@DIARX
I $D(IO("Q")) S DIARQUED=1
S %ZIS="Q",%ZIS("B")="",%ZIS("A")="ARCHIVE STORAGE DEVICE: " D ^%ZIS G 65:POP
I IOT'["HFS",IOT'["MT",IOT'["SDP" D 63 I $D(DIRUT)!('Y) D 64 G 65
I $D(IO("Q")),DIARTRM U IO(0) W !,$C(7),"SINCE YOU SELECTED QUEUEING, YOU SHOULD SELECT A PRINTER DEVICE",!,"OTHER THAN YOUR TERMINAL!",! G 65
D AL I $D(DTOUT)!$D(DIRUT) D 64 G 65
I $D(IO("Q")) D G Q
. I '$D(DIARQUED),'DIARTRM S DIARQUED=1 U IO(0) W !,$C(7),"SINCE YOU SELECTED QUEUEING, REPORT WILL BE QUEUED ALSO!",!
. S ZTRTN="62^DIAR",ZTSAVE("DIARC")="",ZTSAVE("DIAR")="",ZTDESC="Move archived data to permanent storage",ZTSAVE("DIARPDEV")="",ZTSAVE("DIARQUED")=""
. D ^%ZTLOAD,HOME^%ZIS Q
62 D ^DIARX
S DIARL="F Q:$A(DIARLINE)-32 S DIARLINE=$E(DIARLINE,2,999)"
U IO F I=0:0 S I=$O(^DIAR(1.11,DIARC,"D",I)) Q:I'>0 I $D(^(I,0)) S DIARLINE=^(0) X:$E(DIARLINE)[" " DIARL W DIARLINE,!
W "#$#",!
D 64,OUT^DIARX,UPDATE^DIARU
G Q
63 U IO(0) W !,$C(7),"The ARCHIVE STORAGE device selected does not look like a SEQUENTIAL",!,"storage medium.",!
K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to continue" D ^DIR
I Y U IO(0) W !,"OK.",!
Q
64 X $G(^%ZIS("C"))
Q
65 ;
G UNLK^DIARA
;
7 ;;PURGE STORED ENTRIES
D S DIAR=90 G ENTD^DIARA
;
8 ;;CANCEL ARCHIVAL SELECTION
S DIAR=99 G ENTC^DIARA
;
9 ;;FIND ARCHIVED ENTRIES
S DIC=9.4,DIC(0)="QM",DIC("S")="I $P(^(0),U,2)=""XU""",X="KERNEL" D ^DIC K X,DIC I Y'>0 W !,$C(7),"YOU NEED KERNEL TO RUN THIS OPTION" Q
I $G(^DIC(9.4,+Y,"VERSION"))'>7.0 W !,$C(7),"YOU NEED KERNEL V7.1 TO RUN THIS OPTION" Q
G ^DIARR
;
Q G Q^DIARB
;
AL ; archive device label
U IO(0) K DIR,DA
S DIARXXX=$S(IOT["MT":IO_"ARCHIVE"_";"_DT_";"_DIARC,1:IO)
S DIR(0)="1.11,18",DIR("B")=DIARXXX D ^DIR Q:$D(DTOUT)!$D(DUOUT)
S DIARXXX=X,DIE=1.11,DA=DIARC,DR="18////^S X=DIARXXX" D ^DIE
Q
NOKL S DIK="^DOPT(""DIAR""," G GO:$D(^DOPT("DIAR",9))
S ^(0)="ARCHIVE OPTION^1.01^" K ^("B")
F I=1:1:9 S ^DOPT("DIAR",I,0)=$P($T(@I),";;",2)
D IXALL^DIK
GO W ! S DIC=DIK,DIC(0)="AEQI" D ^DIC K DIC,DIK
I Y'<0 S X=+Y K Y D @X G NOKL
W ! G Q^DII
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAR 4659 printed Sep 23, 2025@20:20:53 Page 2
DIAR ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS ;7/1/93 4:17 PM
+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 ;
+7 GOTO NOKL
+8 ;
1 ;;SELECT ENTRIES TO ARCHIVE
+1 SET DIAR=1
DO DIAR^DICRW
if Y<0
GOTO Q
SET %=$PIECE(Y,U,2)
SET (Y,DIARF,DIART)=+Y
+2 ;TEMPORARY CHANGE TO SKIP SUB-FILE OPTION--NOT COMPLETE
+3 GOTO O
+4 if '$ORDER(^DD(DIARF,"SB",0))
GOTO O
+5 WRITE !!,"IF YOU PLAN TO ARCHIVE DATA ONLY FROM ONE SUB-FILE"
+6 WRITE !,"PLEASE IDENTIFY IT HERE. OTHERWISE, JUST PRESS RETURN.",!
+7 DO SUB^DICRW
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO Q
if '$DATA(DIA)
GOTO O
SET DIARF=DIA
+8 SET DIARF0="D0,"
FOR D=1:1
if '$DATA(^DD(DIA,0,"UP"))
QUIT
SET DIARF0=DIARF0_"D"_D_","
SET DIA=^("UP")
O SET I=""
DO CHK
+1 IF '$DATA(DIARC)
DO NEW^DIARCALC
if '$DATA(DIARC)
GOTO Q
GOTO T1
+2 IF $PIECE(Y(0),U,7)>0
WRITE !!,"There is already an outstanding "_$SELECT(+$PIECE(Y(0),U,17):"extract",1:"archiving")_" activity.",!,"Please finish it or CANCEL it.",$CHAR(7),!!
GOTO Q
+3 DO MRK^DIARU
T1 SET DIC=DIART
SET L="]"
IF $DATA(DIARF0)
SET DIARF1=$LENGTH(DIARF0,",")-1
+1 DO EN^DIS
IF '$PIECE(^DIAR(1.11,DIARC,0),U,7)
WRITE $CHAR(7),!!,"NO RECORDS WERE SELECTED TO BE "_$SELECT($DATA(DIAX):"EXTRACTED",1:"ARCHIVED")_"!!",!,"I AM DELETING THIS ARCHIVING ACTIVITY RECORD!!"
SET DIK="^DIAR(1.11,"
SET DA=DIARC
DO ^DIK
+2 GOTO Q
+3 ;
CHK ;IS THERE A VALID SEARCH ?
+1 KILL DIARC,Y(0)
SET I=0
SET Y=$SELECT($DATA(DIARF):DIARF,1:Y)
C SET I=$ORDER(^DIAR(1.11,"C",+Y,I))
if 'I
QUIT
SET Y(0)=""
+1 if '$DATA(^DIAR(1.11,I,0))
GOTO C
if $PIECE(^(0),U,8)>89
GOTO C
SET Y(0)=^(0)
+2 SET DIC=$PIECE(Y(0),U,2)
SET DIARC=I
SET DIARU=$PIECE(Y(0),U,3)
SET DIARP=$PIECE(Y(0),U,4)
+3 QUIT
2 ;;ADD/DELETE SELECTED ENTRIES
+1 SET DIAR=2
GOTO ENTE^DIARB
+2 ;
3 ;;PRINT SELECTED ENTRIES
+1 SET DIAR=3
GOTO OUT^DIARA
+2 ;
4 ;;CREATE FILEGRAM ARCHIVING TEMPLATE
+1 SET DI=1
SET DIAR=""
GOTO EN^DIFGO
+2 ;
5 ;;WRITE ENTRIES TO TEMPORARY STORAGE
+1 SET DIAR=4
GOTO OUT^DIARA
+2 ;
+3 ;
6 ;;MOVE ARCHIVED DATA TO PERMANENT STORAGE
+1 SET DIAR=5
DO FILE^DIARU
if '$DATA(DIARC)
GOTO Q
+2 WRITE !!,"NOTE: This option will 1) print an archive activity report to specified",!,"PRINTER DEVICE and 2) will move archive data to permanent storage to specified",!,"ARCHIVE STORAGE DEVICE."
+3 WRITE !!,"Select some type of SEQUENTIAL media, such as SDP, TAPE, or DISK FILE (HFS),",!,"for archival storage.",!
+4 SET %ZIS("A")="PRINTER DEVICE: "
SET %ZIS("B")=""
SET %ZIS="NQ"
DO ^%ZIS
if POP
GOTO 65
SET DIARPDEV=$SELECT($DATA(ION)#2:ION,1:IO)
SET DIARTRM=$SELECT(IO=IO(0):1,1:0)
+5 IF $DATA(IOST)#2
IF IOST]""
SET DIARPDEV=DIARPDEV_";"_IOST
+6 FOR DIARX="IOM","IOSL"
if ($DATA(@DIARX)#2&@DIARX)
SET DIARPDEV=DIARPDEV_";"_@DIARX
+7 IF $DATA(IO("Q"))
SET DIARQUED=1
+8 SET %ZIS="Q"
SET %ZIS("B")=""
SET %ZIS("A")="ARCHIVE STORAGE DEVICE: "
DO ^%ZIS
if POP
GOTO 65
+9 IF IOT'["HFS"
IF IOT'["MT"
IF IOT'["SDP"
DO 63
IF $DATA(DIRUT)!('Y)
DO 64
GOTO 65
+10 IF $DATA(IO("Q"))
IF DIARTRM
USE IO(0)
WRITE !,$CHAR(7),"SINCE YOU SELECTED QUEUEING, YOU SHOULD SELECT A PRINTER DEVICE",!,"OTHER THAN YOUR TERMINAL!",!
GOTO 65
+11 DO AL
IF $DATA(DTOUT)!$DATA(DIRUT)
DO 64
GOTO 65
+12 IF $DATA(IO("Q"))
Begin DoDot:1
+13 IF '$DATA(DIARQUED)
IF 'DIARTRM
SET DIARQUED=1
USE IO(0)
WRITE !,$CHAR(7),"SINCE YOU SELECTED QUEUEING, REPORT WILL BE QUEUED ALSO!",!
+14 SET ZTRTN="62^DIAR"
SET ZTSAVE("DIARC")=""
SET ZTSAVE("DIAR")=""
SET ZTDESC="Move archived data to permanent storage"
SET ZTSAVE("DIARPDEV")=""
SET ZTSAVE("DIARQUED")=""
+15 DO ^%ZTLOAD
DO HOME^%ZIS
QUIT
End DoDot:1
GOTO Q
62 DO ^DIARX
+1 SET DIARL="F Q:$A(DIARLINE)-32 S DIARLINE=$E(DIARLINE,2,999)"
+2 USE IO
FOR I=0:0
SET I=$ORDER(^DIAR(1.11,DIARC,"D",I))
if I'>0
QUIT
IF $DATA(^(I,0))
SET DIARLINE=^(0)
if $EXTRACT(DIARLINE)[" "
XECUTE DIARL
WRITE DIARLINE,!
+3 WRITE "#$#",!
+4 DO 64
DO OUT^DIARX
DO UPDATE^DIARU
+5 GOTO Q
63 USE IO(0)
WRITE !,$CHAR(7),"The ARCHIVE STORAGE device selected does not look like a SEQUENTIAL",!,"storage medium.",!
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Are you sure you want to continue"
DO ^DIR
+2 IF Y
USE IO(0)
WRITE !,"OK.",!
+3 QUIT
64 XECUTE $GET(^%ZIS("C"))
+1 QUIT
65 ;
+1 GOTO UNLK^DIARA
+2 ;
7 ;;PURGE STORED ENTRIES
D SET DIAR=90
GOTO ENTD^DIARA
+1 ;
8 ;;CANCEL ARCHIVAL SELECTION
+1 SET DIAR=99
GOTO ENTC^DIARA
+2 ;
9 ;;FIND ARCHIVED ENTRIES
+1 SET DIC=9.4
SET DIC(0)="QM"
SET DIC("S")="I $P(^(0),U,2)=""XU"""
SET X="KERNEL"
DO ^DIC
KILL X,DIC
IF Y'>0
WRITE !,$CHAR(7),"YOU NEED KERNEL TO RUN THIS OPTION"
QUIT
+2 IF $GET(^DIC(9.4,+Y,"VERSION"))'>7.0
WRITE !,$CHAR(7),"YOU NEED KERNEL V7.1 TO RUN THIS OPTION"
QUIT
+3 GOTO ^DIARR
+4 ;
Q GOTO Q^DIARB
+1 ;
AL ; archive device label
+1 USE IO(0)
KILL DIR,DA
+2 SET DIARXXX=$SELECT(IOT["MT":IO_"ARCHIVE"_";"_DT_";"_DIARC,1:IO)
+3 SET DIR(0)="1.11,18"
SET DIR("B")=DIARXXX
DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+4 SET DIARXXX=X
SET DIE=1.11
SET DA=DIARC
SET DR="18////^S X=DIARXXX"
DO ^DIE
+5 QUIT
NOKL SET DIK="^DOPT(""DIAR"","
if $DATA(^DOPT("DIAR",9))
GOTO GO
+1 SET ^(0)="ARCHIVE OPTION^1.01^"
KILL ^("B")
+2 FOR I=1:1:9
SET ^DOPT("DIAR",I,0)=$PIECE($TEXT(@I),";;",2)
+3 DO IXALL^DIK
GO WRITE !
SET DIC=DIK
SET DIC(0)="AEQI"
DO ^DIC
KILL DIC,DIK
+1 IF Y'<0
SET X=+Y
KILL Y
DO @X
GOTO NOKL
+2 WRITE !
GOTO Q^DII
