LRARWKD1 ;DALISC/CKA - ARCHIVE WKLD DATA (64.1);2/1/95
;;5.2;LAB SERVICE;**59**;July 31, 1995
;FIND ACTIVE LAB ARCHIVAL ACTIVITY
S LRART=64.1,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 WKLD DATA 64.1")) S LRANUM=$O(^DIBT("B","LR ARCHIVE WKLD DATA 64.1",0)) K ^DIBT(LRANUM,1)
E S DIC="^DIBT(",DIC(0)="L",X="LR ARCHIVE WKLD DATA 64.1",DIC("DR")="2///TODAY;4///64.1" D FILE^DICN S LRANUM=$P(Y,U,1)
S LRAINST=0
F LRAI=0:0 S LRAINST=$O(^LRO(64.1,"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 WKLD DATA 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 IN BACKGROUND
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^LRARWKD1",ZTSAVE("LR*")="",ZTDESC="ARCHIVE WKLD DATA",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-.0001
S LRIND(64.111)=1
DIAXU S LRSCR(64.11)="I $P(^(0),U)<"_LRED_",$P(^(0),U)>"_LRBD
D EXTRACT^DIAXU(64.1,"[LR ARCHIVE WKLD DATA 64.1]","[LRAR ARCHIVE WKLD DATA 64.1]","",.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 DIC,DIR,DIRUT,DTOUT,DUOUT,LRAI,LRAINST,LRANUM,LRAR,LRARC,LRART,LRDAT,LRIND,LRPBD,LRPED,LRSCR,X,Y
D CLN^LRARU1
Q
ERROR W !!,$C(7),"I cannot find an archival activity for file 64.1 with the correct archival status."
G EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARWKD1 2190 printed Nov 22, 2024@17:19:44 Page 2
LRARWKD1 ;DALISC/CKA - ARCHIVE WKLD DATA (64.1);2/1/95
+1 ;;5.2;LAB SERVICE;**59**;July 31, 1995
+2 ;FIND ACTIVE LAB ARCHIVAL ACTIVITY
+3 SET LRART=64.1
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 WKLD DATA 64.1"))
SET LRANUM=$ORDER(^DIBT("B","LR ARCHIVE WKLD DATA 64.1",0))
KILL ^DIBT(LRANUM,1)
+8 IF '$TEST
SET DIC="^DIBT("
SET DIC(0)="L"
SET X="LR ARCHIVE WKLD DATA 64.1"
SET DIC("DR")="2///TODAY;4///64.1"
DO FILE^DICN
SET LRANUM=$PIECE(Y,U,1)
+9 SET LRAINST=0
+10 FOR LRAI=0:0
SET LRAINST=$ORDER(^LRO(64.1,"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 WKLD DATA 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 IN BACKGROUND
+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^LRARWKD1"
SET ZTSAVE("LR*")=""
SET ZTDESC="ARCHIVE WKLD DATA"
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-.0001
+3 SET LRIND(64.111)=1
DIAXU SET LRSCR(64.11)="I $P(^(0),U)<"_LRED_",$P(^(0),U)>"_LRBD
+1 DO EXTRACT^DIAXU(64.1,"[LR ARCHIVE WKLD DATA 64.1]","[LRAR ARCHIVE WKLD DATA 64.1]","",.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 DIC,DIR,DIRUT,DTOUT,DUOUT,LRAI,LRAINST,LRANUM,LRAR,LRARC,LRART,LRDAT,LRIND,LRPBD,LRPED,LRSCR,X,Y
+1 DO CLN^LRARU1
+2 QUIT
ERROR WRITE !!,$CHAR(7),"I cannot find an archival activity for file 64.1 with the correct archival status."
+1 GOTO EXIT
+2 QUIT
