- 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 Mar 13, 2025@21:14 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
