DIAR.m

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 ---DIAR   4659     printed  Feb 19, 2025@00:11:01                                                                                                                                                                                                        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