LRARLMW1.m

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)=""

EXTRACT ;Call to extractor

 ;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 ---LRARLMW1   2209     printed  Apr 09, 2024@21:09:09                                                                                                                                                                                                    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)=""

EXTRACT   ;Call to extractor

 +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