LRARLMW1 ;DALISC/CKA - ARCHIVE LAB MONTHLY WORKLOADS (67.9);2/1/95
;;5.2;LAB SERVICE;**59**;July 31, 1995
;FIND ACTIVE LAB ARCHIVAL ACTIVITY
S LRART=67.9,LRAR=2,LRARC=0 S LRARC=$O(^LAB(95.11,"O",1,LRART,LRARC)) G:LRARC="" ERROR D FILE^LRARU G:'$D(LRARC) EXIT
;UPDATE ACTION IN PROGRESS FIELDS IN LAB ARCHIVAL ACTIVITY FILE
S LRAR=2 D MRK^LRARU1
;CREATE OR REBUILD SORT TEMPLATE CONTAINING ALL INSTITUTIONS
I $D(^DIBT("B","LR ARCHIVE 67.9")) S LRANUM=$O(^DIBT("B","LR ARCHIVE 67.9",0)) K ^DIBT(LRANUM,1)
E S DIC="^DIBT(",DIC(0)="L",X="LR ARCHIVE 67.9",DIC("DR")="2///TODAY;4///67.9" D FILE^DICN S LRANUM=$P(Y,U,1)
S LRAINST=0
F LRAI=0:0 S LRAINST=$O(^LRO(67.9,"B",LRAINST)) Q:LRAINST="" S ^DIBT(LRANUM,1,LRAINST)=""
;Message to user archiving data began
S LRPED=$P(^LAB(95.11,LRARC,1),U,2),LRPBD=$P(^(1),U)
W !!?5,"Archiving LAB MONTHLY WORKLOADS file"
W !?5,"Beginning date: " S Y=LRPBD D DT^DIO2
W !?5,"Ending date: " S Y=LRPED D DT^DIO2
RDY S DIR(0)="Y",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE",DIR("B")="NO" D ^DIR K DIR
I $D(DIRUT)!('Y) D COMP^LRARU1 G EXIT
QUEUE ;QUEUE MOVING OF DATA TO DESTINATION FILE
S %ZIS="Q",%ZIS("B")="",%ZIS("A")="Start archiving and PRINT error report on device: " D ^%ZIS
I POP D COMP^LRARU1 G EXIT
I $D(IO("Q")) S ZTRTN="START^LRARLMW1",ZTSAVE("LR*")="",ZTDESC="ARCHIVE LAB MONTHLY WORKLOAD",ZTIO=IO D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK D TASK^LRARU1 G EXIT
START ;ARCHIVING BEGINS
U IO
S LRED=LRPED+.99,LRBD=LRPBD-100
S LRIND(67.911)=1
DIAXU S LRSCR(67.911)="I $P(^(0),U)<"_LRED_",$P(^(0),U)>"_LRBD
D EXTRACT^DIAXU(67.9,"[LR ARCHIVE 67.9]","[LRAR ARCHIVE 67.9]","",.LRSCR,.LRIND,"^LAB(95.11,"_LRARC_")","^LAB(95.11,"_LRARC_",""RESULT"")")
LAAF ;UPDATE ENTRY TO LAB ARCHIVAL ACTIVITY FILE
S LRAR=2 D UPDATE^LRARU1
;ARCHIVING ACTION COMPLETED
D COMP^LRARU1
S LRARID=LRARC
D RESULT^LRARREP
EXIT K DIAXF,DIAXGR,DIAXSCR,DIAXST,DIAXT,DIC,DIR,DIRUT,DTOUT,DUOUT,LRAI,LRAINST,LRANUM,LRAR,LRARC,LRART,LRBD,LRDAT,LRED,LRINST,LRPBD,LRPED,LRSCR,X,X1,X2,Y
D CLN^LRARU1
Q
ERROR W !,$C(7),"I cannot find an archival activity for file 67.9 with the correct archival status."
G EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARLMW1 2209 printed Nov 22, 2024@17:19:33 Page 2
LRARLMW1 ;DALISC/CKA - ARCHIVE LAB MONTHLY WORKLOADS (67.9);2/1/95
+1 ;;5.2;LAB SERVICE;**59**;July 31, 1995
+2 ;FIND ACTIVE LAB ARCHIVAL ACTIVITY
+3 SET LRART=67.9
SET LRAR=2
SET LRARC=0
SET LRARC=$ORDER(^LAB(95.11,"O",1,LRART,LRARC))
if LRARC=""
GOTO ERROR
DO FILE^LRARU
if '$DATA(LRARC)
GOTO EXIT
+4 ;UPDATE ACTION IN PROGRESS FIELDS IN LAB ARCHIVAL ACTIVITY FILE
+5 SET LRAR=2
DO MRK^LRARU1
+6 ;CREATE OR REBUILD SORT TEMPLATE CONTAINING ALL INSTITUTIONS
+7 IF $DATA(^DIBT("B","LR ARCHIVE 67.9"))
SET LRANUM=$ORDER(^DIBT("B","LR ARCHIVE 67.9",0))
KILL ^DIBT(LRANUM,1)
+8 IF '$TEST
SET DIC="^DIBT("
SET DIC(0)="L"
SET X="LR ARCHIVE 67.9"
SET DIC("DR")="2///TODAY;4///67.9"
DO FILE^DICN
SET LRANUM=$PIECE(Y,U,1)
+9 SET LRAINST=0
+10 FOR LRAI=0:0
SET LRAINST=$ORDER(^LRO(67.9,"B",LRAINST))
if LRAINST=""
QUIT
SET ^DIBT(LRANUM,1,LRAINST)=""
+1 ;Message to user archiving data began
+2 SET LRPED=$PIECE(^LAB(95.11,LRARC,1),U,2)
SET LRPBD=$PIECE(^(1),U)
+3 WRITE !!?5,"Archiving LAB MONTHLY WORKLOADS file"
+4 WRITE !?5,"Beginning date: "
SET Y=LRPBD
DO DT^DIO2
+5 WRITE !?5,"Ending date: "
SET Y=LRPED
DO DT^DIO2
RDY SET DIR(0)="Y"
SET DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+1 IF $DATA(DIRUT)!('Y)
DO COMP^LRARU1
GOTO EXIT
QUEUE ;QUEUE MOVING OF DATA TO DESTINATION FILE
+1 SET %ZIS="Q"
SET %ZIS("B")=""
SET %ZIS("A")="Start archiving and PRINT error report on device: "
DO ^%ZIS
+2 IF POP
DO COMP^LRARU1
GOTO EXIT
+3 IF $DATA(IO("Q"))
SET ZTRTN="START^LRARLMW1"
SET ZTSAVE("LR*")=""
SET ZTDESC="ARCHIVE LAB MONTHLY WORKLOAD"
SET ZTIO=IO
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"TASK #",ZTSK
DO TASK^LRARU1
GOTO EXIT
START ;ARCHIVING BEGINS
+1 USE IO
+2 SET LRED=LRPED+.99
SET LRBD=LRPBD-100
+3 SET LRIND(67.911)=1
DIAXU SET LRSCR(67.911)="I $P(^(0),U)<"_LRED_",$P(^(0),U)>"_LRBD
+1 DO EXTRACT^DIAXU(67.9,"[LR ARCHIVE 67.9]","[LRAR ARCHIVE 67.9]","",.LRSCR,.LRIND,"^LAB(95.11,"_LRARC_")","^LAB(95.11,"_LRARC_",""RESULT"")")
LAAF ;UPDATE ENTRY TO LAB ARCHIVAL ACTIVITY FILE
+1 SET LRAR=2
DO UPDATE^LRARU1
+2 ;ARCHIVING ACTION COMPLETED
+3 DO COMP^LRARU1
+4 SET LRARID=LRARC
+5 DO RESULT^LRARREP
EXIT KILL DIAXF,DIAXGR,DIAXSCR,DIAXST,DIAXT,DIC,DIR,DIRUT,DTOUT,DUOUT,LRAI,LRAINST,LRANUM,LRAR,LRARC,LRART,LRBD,LRDAT,LRED,LRINST,LRPBD,LRPED,LRSCR,X,X1,X2,Y
+1 DO CLN^LRARU1
+2 QUIT
ERROR WRITE !,$CHAR(7),"I cannot find an archival activity for file 67.9 with the correct archival status."
+1 GOTO EXIT
+2 QUIT
