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
Q
;
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
Q
;
;
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
Q
;
;
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)
Q
;
LOCK68 ; Lock entry in file 68
; Called from above, LA7SM
;
D LOCK^DILF("^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)")
;
Q
;
UNLOCK68 ; Unlock entry in file 68
; Called from above, LA7SM
;
L -^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) ; Release lock.
;
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SMB 7825 printed Oct 16, 2024@17:40:21 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
