Routine: LA7SMB

LA7SMB ;DALOI/JMC - Shipping Manifest Build ;11/16/11  13:08

 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64,74,95**;Sep 27, 1994;Build 7

EN ;

 D CLEANUP

 S LA7QUIT=0

 ; Select shipping configuration

 I '$D(^LAHM(62.9,"C",DUZ(2))) D  Q  ;

 . W !,$C(7),"No configurations for your current division."

 . H 2

 S LA7SCFG=$$SSCFG^LA7SUTL(1)

 I LA7SCFG<1 D CLEANUP Q

 ; Determine if there's an active manifest.

 S LA7SM=$$CHKSM^LA7SMU(+LA7SCFG)

 I LA7SM<0 D  Q

 . D EN^DDIOL($P(LA7SM,"^",2),"","!?5")

 . D CLEANUP

 I LA7SM=0 D

 . N DIR,DIRUT,DTOUT,X,Y,XD

 . S XD=$$GET^XPAR("USR^PKG","LR MANIFEST DEFLT CREATE","`"_+LA7SCFG,"Q")

 . S DIR("B")=$S(XD="":"NO",XD=1:"YES",1:"NO")

 . S DIR(0)="YO",DIR("A",1)="There's no open shipping manifest for "_$P(LA7SCFG,"^",2)

 . S DIR("A")="Do you want to start one"

 . S DIR("?",1)="Enter ""YES"" to create a new MANIFEST for this shipping configuration."

 . S DIR("?",2)=" "

 . S DIR("?")="Enter ""NO"" to abort this process."

 . D ^DIR

 . I Y'=1 S LA7QUIT=1 Q

 . S LA7SM=$$CSM^LA7SMU(+LA7SCFG)

 . I LA7SM<1 D EN^DDIOL($P(LA7SM,"^",2),"","!?5") S LA7QUIT=1

 ; Only starting a new manifest, no building

 I $G(LA7SMON) Q

 I LA7QUIT=1 D CLEANUP Q

 D ADATE^LA7SMU1

 I LA7QUIT=1 D CLEANUP Q

 ; Flag to exclude previously removed tests from building.

 S LA7EXPRV=$$ASKPREV^LA7SMU1(+LA7SCFG)

 I LA7EXPRV<0 S LA7QUIT=1

 I LA7QUIT=1 D CLEANUP Q

DQ ; Taskman entry point

 ; Build list of tests and criteria for manifest.

 S LA7SCFG(0)=$G(^LAHM(62.9,+LA7SCFG,0))

 I '$D(ZTQUEUED) D EN^DDIOL("Using shipping manifest# "_$P(LA7SM,"^",2),"","!?5")

 ; Lock this shipping manifest

 D LOCK^DILF("^LAHM(62.8,+LA7SM,0)")

 I '$T D  Q

 . I '$D(ZTQUEUED) D EN^DDIOL("Unable to obtain lock for shipping manifest "_$P(LA7SCFG,"^",2),"","!?5")

 . D CLEANUP

 ; Update status

 D SMSUP^LA7SMU(LA7SM,2,"SM03")

 S LA7SMCNT=0

 ; Build TMP global with test profiles

 D SCBLD^LA7SM1(+LA7SCFG)

 S LA7AA=""

 F  S LA7AA=$O(^TMP("LA7SMB",$J,LA7AA)) Q:LA7AA=""  D

 . N LA7END,LRSS

 . I '$D(ZTQUEUED) D EN^DDIOL("Searching accession area: "_$P($G(^LRO(68,LA7AA,0)),"^"),"","!?5")

 . ; Use selected accession date else get current accession day for this accession area

 . I $G(LA7AA(LA7AA)) S LA7AD=$P(LA7AA(LA7AA),"^")

 . E  S LA7AD=$$AD^LA7SUTL(LA7AA)

 . S LRSS=$P($G(^LRO(68,LA7AA,0)),"^",2)

 . S LA7AN=+$P($G(LA7AA(LA7AA)),"^",2),LA7LAN=+$P($G(LA7AA(LA7AA)),"^",3),LA7END=0

 . I LA7AN S LA7AN=LA7AN-1

 . F  S LA7AN=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN)) Q:'LA7AN!(LA7END)  D SCAN

 ; Update status

 D SMSUP^LA7SMU(LA7SM,1,"SM02")

 ; Release lock on this shipping manifest

 L -^LAHM(62.8,+LA7SM,0)

 I '$D(ZTQUEUED) D

 . N DIR,DIRUT,DIROUT,DTOUT,X,Y

 . D EN^DDIOL("There were "_$S(LA7SMCNT:LA7SMCNT,1:"NO")_" specimens added","","!?5")

 . D ASK^LA7SMP(LA7SM)

 D CLEANUP

SMONLY ; Start a shipping manifest only, no building

 N LA7SMON

 S LA7SMON=1

 D EN

 I $G(LA7SCFG),$G(LA7SM)>0 D EN^DDIOL("Shipping manifest# "_$P(LA7SM,"^",2)_" is available","","!?5")

 D CLEANUP

SCAN ; Scan accession for tests to build

 N LA762,LA76805,LA7DIV,LA7END,X

 I LA7LAN,LA7AN>LA7LAN S LA7END=1 Q

 ; Don't build controls

 I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3 Q

 ; Don't build uncollected specimens

 I '$P(LA7SCFG(0),"^",14),'$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),"^",3) Q

 ; Don't build if configuration has specific ordering locations and accession's ordering location is not on list.

 I $$CHKOLOC^LA7SM1(LA7AA,LA7AD,LA7AN,+LA7SCFG)<1 Q

 ; Get Specimen type - if no specimen then quit

 S (LA762,LA76805)=0

 S X=+$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))

 I X D

 . S X=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))

 . S LA76805=+$P(X,"^"),LA762=+$P(X,"^",2)

 I LA76805<1 Q

 ; Accession's division

 S LA7DIV=+$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.4)),"^")

 S LA7UID=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^")

 I LA7UID="" S LA7UID=$$LRUID^LRX(LA7AA,LA7AD,LA7AN)

 S LA760=0

 F  S LA760=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)) Q:'LA760  D

 . ; Not looking for this test.

 . I '$D(^TMP("LA7SMB",$J,LA7AA,LA760)) Q

 . ; Set lock.

 . D LOCK68

 . I '$T D  Q

 . . I $D(ZTQUEUED) Q

 . . D EN^DDIOL("Unable to obtain lock for accession "_LA7UID_" test "_$$GET1^DIQ(60,LA760_",",.01),"","!?5")

 . ; NOTE *** Do NOT add any "QUIT" after this point unless releasing LOCK set above ***.

 . ; Test's zeroth node.

 . S LA760(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760,0))

 . ; Test completed - skip

 . I "CY^EM^SP"'[LRSS,$P(LA760(0),"^",5) D UNLOCK68 Q

 . ; Test already on shipping manifest - skip

 . I $$SHIPCK^LA7SMU1(LA7UID,LA7AA,LA760,$P(LA760(0),"^",10)) D UNLOCK68 Q

 . ; Previously removed - skip

 . I LA7EXPRV,$$PREV^LA7SMU1(LA7UID,$P(LA760(0),"^")) D UNLOCK68 Q

 . ; Test urgency

 . S LA76205=+$P(LA760(0),"^",2)

 . I LA76205>49 S LA76205=$S(LA76205=50:9,1:LA76205-50)

 . ; Check if test is eligible for manifest

 . D SCHK^LA7SM1

 . I LA7FLAG S LA7FLAG=$$CKTEST(LA7AA,LA7AD,LA7AN,LA760)

 . ; Add test to shipping manifest.

 . I LA7FLAG D ADD^LA7SMB1

 . ; Release lock.

 . D UNLOCK68

CKTEST(LA7AA,LA7AD,LA7AN,LA760) ; Check other tests on accession if test is part of another panel that

 ; has been flagged for shipping.

 ; Call with LA7AA = ien of accession area.

 ;           LA7AD = accession date

 ;           LA7AN = accession number

 ;           LA760 = ien of lab test

 ; Returns   LA7FLAG = 0 (part of another panel)

 ;                   = 1 (not part of another panel)

 N LA7FLAG,LA7PCNT,LA7K,LA7J,X

 K ^TMP("LA7TREE",$J)

 S LA7FLAG=1

 S LA7AD(LA7AD)=""

 S LA7K=+$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",3)

 I LA7K D

 . ; Check original accession date.

 . S LA7AD(LA7K)=""

 . ; Check rollover accession

 . I $P($G(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^") S LA7AD($P($G(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^"))=""

 S LA7AD=0

 F  S LA7AD=$O(LA7AD(LA7AD)) Q:'LA7AD  D

 . S LA7J=0

 . F  S LA7J=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J)) Q:'LA7J  D

 . . I LA7J=LA760 Q

 . . ; Not on manifest

 . . I '$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J,0)),"^",10) Q

 . . S LA7PCNT=0 D UNWIND(LA7J)

 ; Test is part of another test previously shipped.

 I $D(^TMP("LA7TREE",$J,LA760)) S LA7FLAG=0

 K ^TMP("LA7TREE",$J)

 Q LA7FLAG

UNWIND(LA760) ; Unwind profile - set tests into global ^TMP("LA7TREE",$J).

 ; Initialize variable LA7PCNT=0 before calling.

 ; Kill ^TMP("LA7TREE",$J) before calling.

 N I,II

 ; Recursive panel, caught in a loop.

 I $G(LA7PCNT)>50 Q

 ; Test does not exist in file 60.

 I '$D(^LAB(60,LA760,0)) Q

 ; Bypass "workload" type tests.

 I $P(^LAB(60,LA760,0),"^",4)="WK" Q

 ; Atomic test

 I $P(^LAB(60,LA760,0),"^",5)'="" S ^TMP("LA7TREE",$J,LA760)="" Q

 ; Check panels

 I $O(^LAB(60,LA760,2,0)) D

 . ; Increment panel counter.

 . S LA7PCNT=$G(LA7PCNT)+1

 . S I=0

 . ; Expand test on panel.

 . F  S I=$O(^LAB(60,LA760,2,I)) Q:'I  D

 . . ; IEN of test on panel.

 . . S II=+$G(^LAB(60,LA760,2,I,0))

 . . ; Recursive panel, panel calls itself.

 . . I II,II=LA760 Q

 . . I II S ^TMP("LA7TREE",$J,LA760)="" D UNWIND(II)

LOCK68 ; Lock entry in file 68

 ; Called from above, LA7SM

 D LOCK^DILF("^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)")

UNLOCK68 ; Unlock entry in file 68

 ; Called from above, LA7SM

 L -^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) ; Release lock.

CLEANUP ; Cleanup variables

 I $D(ZTQUEUED) S ZTREQ="@"

 F LA7I="LA7SMB","LA7SMB-R","LA7SMADD","LA7TREE" K ^TMP(LA7I,$J)

 K LA760,LA76205,LA76805,LA7AA,LA7AD,LA7AN,LA7DATA,LA7EXPRV,LA7FLAG,LA7I,LA7LAN,LA7PCNT,LA7QUIT,LA7SCFG,LA7SM,LA7SMCNT,LA7UID,LA7X

 K LRDFN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SMB   7825     printed  Mar 13, 2025@20:44:09                                                                                                                                                                                                      Page 2

LA7SMB    ;DALOI/JMC - Shipping Manifest Build ;11/16/11  13:08

 +1       ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64,74,95**;Sep 27, 1994;Build 7

 +2       ;

EN        ;

 +1       ;

 +2        DO CLEANUP

 +3        SET LA7QUIT=0

 +4       ;

 +5       ; Select shipping configuration

 +6       ;

           IF '$DATA(^LAHM(62.9,"C",DUZ(2)))

               Begin DoDot:1

 +7                WRITE !,$CHAR(7),"No configurations for your current division."

 +8                HANG 2

               End DoDot:1

               QUIT

 +9        SET LA7SCFG=$$SSCFG^LA7SUTL(1)

 +10       IF LA7SCFG<1

               DO CLEANUP

               QUIT

 +11      ;

 +12      ; Determine if there's an active manifest.

 +13       SET LA7SM=$$CHKSM^LA7SMU(+LA7SCFG)

 +14       IF LA7SM<0

               Begin DoDot:1

 +15               DO EN^DDIOL($PIECE(LA7SM,"^",2),"","!?5")

 +16               DO CLEANUP

               End DoDot:1

               QUIT

 +17      ;

 +18       IF LA7SM=0

               Begin DoDot:1

 +19               NEW DIR,DIRUT,DTOUT,X,Y,XD

 +20               SET XD=$$GET^XPAR("USR^PKG","LR MANIFEST DEFLT CREATE","`"_+LA7SCFG,"Q")

 +21               SET DIR("B")=$SELECT(XD="":"NO",XD=1:"YES",1:"NO")

 +22               SET DIR(0)="YO"

                   SET DIR("A",1)="There's no open shipping manifest for "_$PIECE(LA7SCFG,"^",2)

 +23               SET DIR("A")="Do you want to start one"

 +24               SET DIR("?",1)="Enter ""YES"" to create a new MANIFEST for this shipping configuration."

 +25               SET DIR("?",2)=" "

 +26               SET DIR("?")="Enter ""NO"" to abort this process."

 +27               DO ^DIR

 +28               IF Y'=1

                       SET LA7QUIT=1

                       QUIT

 +29               SET LA7SM=$$CSM^LA7SMU(+LA7SCFG)

 +30               IF LA7SM<1

                       DO EN^DDIOL($PIECE(LA7SM,"^",2),"","!?5")

                       SET LA7QUIT=1

               End DoDot:1

 +31      ;

 +32      ; Only starting a new manifest, no building

 +33       IF $GET(LA7SMON)

               QUIT

 +34      ;

 +35       IF LA7QUIT=1

               DO CLEANUP

               QUIT

 +36      ;

 +37       DO ADATE^LA7SMU1

 +38       IF LA7QUIT=1

               DO CLEANUP

               QUIT

 +39      ;

 +40      ; Flag to exclude previously removed tests from building.

 +41       SET LA7EXPRV=$$ASKPREV^LA7SMU1(+LA7SCFG)

 +42       IF LA7EXPRV<0

               SET LA7QUIT=1

 +43      ;

 +44       IF LA7QUIT=1

               DO CLEANUP

               QUIT

 +45      ;

DQ        ; Taskman entry point

 +1       ; Build list of tests and criteria for manifest.

 +2        SET LA7SCFG(0)=$GET(^LAHM(62.9,+LA7SCFG,0))

 +3        IF '$DATA(ZTQUEUED)

               DO EN^DDIOL("Using shipping manifest# "_$PIECE(LA7SM,"^",2),"","!?5")

 +4       ;

 +5       ; Lock this shipping manifest

 +6        DO LOCK^DILF("^LAHM(62.8,+LA7SM,0)")

 +7        IF '$TEST

               Begin DoDot:1

 +8                IF '$DATA(ZTQUEUED)

                       DO EN^DDIOL("Unable to obtain lock for shipping manifest "_$PIECE(LA7SCFG,"^",2),"","!?5")

 +9                DO CLEANUP

               End DoDot:1

               QUIT

 +10      ;

 +11      ; Update status

 +12       DO SMSUP^LA7SMU(LA7SM,2,"SM03")

 +13       SET LA7SMCNT=0

 +14      ;

 +15      ; Build TMP global with test profiles

 +16       DO SCBLD^LA7SM1(+LA7SCFG)

 +17      ;

 +18       SET LA7AA=""

 +19       FOR

               SET LA7AA=$ORDER(^TMP("LA7SMB",$JOB,LA7AA))

               if LA7AA=""

                   QUIT

               Begin DoDot:1

 +20               NEW LA7END,LRSS

 +21               IF '$DATA(ZTQUEUED)

                       DO EN^DDIOL("Searching accession area: "_$PIECE($GET(^LRO(68,LA7AA,0)),"^"),"","!?5")

 +22      ; Use selected accession date else get current accession day for this accession area

 +23               IF $GET(LA7AA(LA7AA))

                       SET LA7AD=$PIECE(LA7AA(LA7AA),"^")

 +24              IF '$TEST

                       SET LA7AD=$$AD^LA7SUTL(LA7AA)

 +25               SET LRSS=$PIECE($GET(^LRO(68,LA7AA,0)),"^",2)

 +26               SET LA7AN=+$PIECE($GET(LA7AA(LA7AA)),"^",2)

                   SET LA7LAN=+$PIECE($GET(LA7AA(LA7AA)),"^",3)

                   SET LA7END=0

 +27               IF LA7AN

                       SET LA7AN=LA7AN-1

 +28               FOR

                       SET LA7AN=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN))

                       if 'LA7AN!(LA7END)

                           QUIT

                       DO SCAN

               End DoDot:1

 +29      ;

 +30      ; Update status

 +31       DO SMSUP^LA7SMU(LA7SM,1,"SM02")

 +32      ;

 +33      ; Release lock on this shipping manifest

 +34       LOCK -^LAHM(62.8,+LA7SM,0)

 +35      ;

 +36       IF '$DATA(ZTQUEUED)

               Begin DoDot:1

 +37               NEW DIR,DIRUT,DIROUT,DTOUT,X,Y

 +38               DO EN^DDIOL("There were "_$SELECT(LA7SMCNT:LA7SMCNT,1:"NO")_" specimens added","","!?5")

 +39               DO ASK^LA7SMP(LA7SM)

               End DoDot:1

 +40       DO CLEANUP

 +41       QUIT

 +42      ;

SMONLY    ; Start a shipping manifest only, no building

 +1       ;

 +2        NEW LA7SMON

 +3        SET LA7SMON=1

 +4        DO EN

 +5        IF $GET(LA7SCFG)

               IF $GET(LA7SM)>0

                   DO EN^DDIOL("Shipping manifest# "_$PIECE(LA7SM,"^",2)_" is available","","!?5")

 +6        DO CLEANUP

 +7        QUIT

 +8       ;

 +9       ;

SCAN      ; Scan accession for tests to build

 +1       ;

 +2        NEW LA762,LA76805,LA7DIV,LA7END,X

 +3       ;

 +4        IF LA7LAN

               IF LA7AN>LA7LAN

                   SET LA7END=1

                   QUIT

 +5       ;

 +6       ; Don't build controls

 +7        IF $PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3

               QUIT

 +8       ;

 +9       ; Don't build uncollected specimens

 +10       IF '$PIECE(LA7SCFG(0),"^",14)

               IF '$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),"^",3)

                   QUIT

 +11      ;

 +12      ; Don't build if configuration has specific ordering locations and accession's ordering location is not on list.

 +13       IF $$CHKOLOC^LA7SM1(LA7AA,LA7AD,LA7AN,+LA7SCFG)<1

               QUIT

 +14      ;

 +15      ; Get Specimen type - if no specimen then quit

 +16       SET (LA762,LA76805)=0

 +17       SET X=+$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))

 +18       IF X

               Begin DoDot:1

 +19               SET X=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))

 +20               SET LA76805=+$PIECE(X,"^")

                   SET LA762=+$PIECE(X,"^",2)

               End DoDot:1

 +21       IF LA76805<1

               QUIT

 +22      ;

 +23      ; Accession's division

 +24       SET LA7DIV=+$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.4)),"^")

 +25      ;

 +26       SET LA7UID=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^")

 +27       IF LA7UID=""

               SET LA7UID=$$LRUID^LRX(LA7AA,LA7AD,LA7AN)

 +28       SET LA760=0

 +29       FOR

               SET LA760=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760))

               if 'LA760

                   QUIT

               Begin DoDot:1

 +30      ; Not looking for this test.

 +31               IF '$DATA(^TMP("LA7SMB",$JOB,LA7AA,LA760))

                       QUIT

 +32      ; Set lock.

 +33               DO LOCK68

 +34               IF '$TEST

                       Begin DoDot:2

 +35                       IF $DATA(ZTQUEUED)

                               QUIT

 +36                       DO EN^DDIOL("Unable to obtain lock for accession "_LA7UID_" test "_$$GET1^DIQ(60,LA760_",",.01),"","!?5")

                       End DoDot:2

                       QUIT

 +37      ; NOTE *** Do NOT add any "QUIT" after this point unless releasing LOCK set above ***.

 +38      ; Test's zeroth node.

 +39               SET LA760(0)=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760,0))

 +40      ; Test completed - skip

 +41               IF "CY^EM^SP"'[LRSS

                       IF $PIECE(LA760(0),"^",5)

                           DO UNLOCK68

                           QUIT

 +42      ; Test already on shipping manifest - skip

 +43               IF $$SHIPCK^LA7SMU1(LA7UID,LA7AA,LA760,$PIECE(LA760(0),"^",10))

                       DO UNLOCK68

                       QUIT

 +44      ; Previously removed - skip

 +45               IF LA7EXPRV

                       IF $$PREV^LA7SMU1(LA7UID,$PIECE(LA760(0),"^"))

                           DO UNLOCK68

                           QUIT

 +46      ; Test urgency

 +47               SET LA76205=+$PIECE(LA760(0),"^",2)

 +48               IF LA76205>49

                       SET LA76205=$SELECT(LA76205=50:9,1:LA76205-50)

 +49      ; Check if test is eligible for manifest

 +50               DO SCHK^LA7SM1

 +51               IF LA7FLAG

                       SET LA7FLAG=$$CKTEST(LA7AA,LA7AD,LA7AN,LA760)

 +52      ; Add test to shipping manifest.

 +53               IF LA7FLAG

                       DO ADD^LA7SMB1

 +54      ; Release lock.

 +55               DO UNLOCK68

               End DoDot:1

 +56       QUIT

 +57      ;

 +58      ;

CKTEST(LA7AA,LA7AD,LA7AN,LA760) ; Check other tests on accession if test is part of another panel that

 +1       ; has been flagged for shipping.

 +2       ; Call with LA7AA = ien of accession area.

 +3       ;           LA7AD = accession date

 +4       ;           LA7AN = accession number

 +5       ;           LA760 = ien of lab test

 +6       ; Returns   LA7FLAG = 0 (part of another panel)

 +7       ;                   = 1 (not part of another panel)

 +8       ;

 +9        NEW LA7FLAG,LA7PCNT,LA7K,LA7J,X

 +10      ;

 +11       KILL ^TMP("LA7TREE",$JOB)

 +12      ;

 +13       SET LA7FLAG=1

 +14       SET LA7AD(LA7AD)=""

 +15       SET LA7K=+$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",3)

 +16      ;

 +17       IF LA7K

               Begin DoDot:1

 +18      ; Check original accession date.

 +19               SET LA7AD(LA7K)=""

 +20      ; Check rollover accession

 +21               IF $PIECE($GET(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^")

                       SET LA7AD($PIECE($GET(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^"))=""

               End DoDot:1

 +22       SET LA7AD=0

 +23       FOR

               SET LA7AD=$ORDER(LA7AD(LA7AD))

               if 'LA7AD

                   QUIT

               Begin DoDot:1

 +24               SET LA7J=0

 +25               FOR

                       SET LA7J=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J))

                       if 'LA7J

                           QUIT

                       Begin DoDot:2

 +26                       IF LA7J=LA760

                               QUIT

 +27      ; Not on manifest

 +28                       IF '$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J,0)),"^",10)

                               QUIT

 +29                       SET LA7PCNT=0

                           DO UNWIND(LA7J)

                       End DoDot:2

               End DoDot:1

 +30      ;

 +31      ; Test is part of another test previously shipped.

 +32       IF $DATA(^TMP("LA7TREE",$JOB,LA760))

               SET LA7FLAG=0

 +33      ;

 +34       KILL ^TMP("LA7TREE",$JOB)

 +35      ;

 +36       QUIT LA7FLAG

 +37      ;

UNWIND(LA760) ; Unwind profile - set tests into global ^TMP("LA7TREE",$J).

 +1       ; Initialize variable LA7PCNT=0 before calling.

 +2       ; Kill ^TMP("LA7TREE",$J) before calling.

 +3       ;

 +4        NEW I,II

 +5       ;

 +6       ; Recursive panel, caught in a loop.

 +7        IF $GET(LA7PCNT)>50

               QUIT

 +8       ; Test does not exist in file 60.

 +9        IF '$DATA(^LAB(60,LA760,0))

               QUIT

 +10      ; Bypass "workload" type tests.

 +11       IF $PIECE(^LAB(60,LA760,0),"^",4)="WK"

               QUIT

 +12      ; Atomic test

 +13       IF $PIECE(^LAB(60,LA760,0),"^",5)'=""

               SET ^TMP("LA7TREE",$JOB,LA760)=""

               QUIT

 +14      ; Check panels

 +15       IF $ORDER(^LAB(60,LA760,2,0))

               Begin DoDot:1

 +16      ; Increment panel counter.

 +17               SET LA7PCNT=$GET(LA7PCNT)+1

 +18               SET I=0

 +19      ; Expand test on panel.

 +20               FOR

                       SET I=$ORDER(^LAB(60,LA760,2,I))

                       if 'I

                           QUIT

                       Begin DoDot:2

 +21      ; IEN of test on panel.

 +22                       SET II=+$GET(^LAB(60,LA760,2,I,0))

 +23      ; Recursive panel, panel calls itself.

 +24                       IF II

                               IF II=LA760

                                   QUIT

 +25                       IF II

                               SET ^TMP("LA7TREE",$JOB,LA760)=""

                               DO UNWIND(II)

                       End DoDot:2

               End DoDot:1

 +26       QUIT

 +27      ;

LOCK68    ; Lock entry in file 68

 +1       ; Called from above, LA7SM

 +2       ;

 +3        DO LOCK^DILF("^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)")

 +4       ;

 +5        QUIT

 +6       ;

UNLOCK68  ; Unlock entry in file 68

 +1       ; Called from above, LA7SM

 +2       ;

 +3       ; Release lock.

           LOCK -^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)

 +4       ;

 +5        QUIT

 +6       ;

CLEANUP   ; Cleanup variables

 +1       ;

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3       ;

 +4        FOR LA7I="LA7SMB","LA7SMB-R","LA7SMADD","LA7TREE"

               KILL ^TMP(LA7I,$JOB)

 +5       ;

 +6        KILL LA760,LA76205,LA76805,LA7AA,LA7AD,LA7AN,LA7DATA,LA7EXPRV,LA7FLAG,LA7I,LA7LAN,LA7PCNT,LA7QUIT,LA7SCFG,LA7SM,LA7SMCNT,LA7UID,LA7X

 +7        KILL LRDFN

 +8        QUIT

LA7SMB.m