LA7SMB ;VA/DALOI/JMC - Shipping Manifest Build ;JUL 06, 2010 3:14 PM
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64,1027**;NOV 01, 1997
EN ;
;
D CLEANUP
S LA7QUIT=0
;
; Select shipping configuration
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
. 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",DIR("B")="NO"
. 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
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
L +^LAHM(62.8,+LA7SM,0):5
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 acession 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 LA76805,LA7DIV,LA7END
;
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
;
; Get Specimen type - if no specimen then quit
; Anatomic path does not store specimen type in #68.
S LA76805=""
I "CY^EM^SP"[LRSS S LA76805=0
E D
. S X=+$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
. I 'X Q
. S LA76805=+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
I LA76805="" Q
;
; Accession's division
S LA7DIV=+$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.4)),"^")
;
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
. ; 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 $P(LA760(0),"^",10) D UNLOCK68 Q
. ; Previously removed - skip
. I LA7EXPRV,$$PREV^LA7SMU1($P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^"),$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
. . S LA7I=0
. . F S LA7I=$O(LA7X(LA7I)) Q:'LA7I D ADD
. ; Release lock.
. D UNLOCK68
Q
;
ADD ; Add test to shipping manifest
; Called from above, LA7SM
; Lock on ^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) should be set before entering here.
;
N FDA,IENS,LA7628,LA768,LA7DATA
;
S LRDFN=+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0))
S LA7UID=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^")
I LA7UID="" S LA7UID=$$LRUID^LRX(LA7AA,LA7AD,LA7AN)
S LA7SMCNT=$G(LA7SMCNT)+1
S ^TMP("LA7SMADD",$J,LA7SMCNT)=LRDFN_"^"_LA760_"^"_LA76805_"^"_LA76205_"^"_LA7UID
S LA7628(1)=+LA7SM,IENS="+2,"_LA7628(1)_","
S FDA(2,62.801,IENS,.01)=LRDFN
S FDA(2,62.801,IENS,.02)=LA760
I LA76805 S FDA(2,62.801,IENS,.03)=LA76805
S FDA(2,62.801,IENS,.04)=LA76205
S FDA(2,62.801,IENS,.05)=LA7UID
S FDA(2,62.801,IENS,.08)=1
I $D(LA7X(LA7I,0)) D
. I $P(LA7X(LA7I,0),"^",5) S FDA(2,62.801,IENS,.06)=$P(LA7X(LA7I,0),"^",5)
. I $P(LA7X(LA7I,0),"^",6) S FDA(2,62.801,IENS,.07)=$P(LA7X(LA7I,0),"^",6)
. I $P(LA7X(LA7I,0),"^",7) S FDA(2,62.801,IENS,.09)=$P(LA7X(LA7I,0),"^",7)
I $D(LA7X(LA7I,1)) D
. I $P(LA7X(LA7I,1),"^",1)]"" S FDA(2,62.801,IENS,1.1)=$P(LA7X(LA7I,1),"^",1)
. I $P(LA7X(LA7I,1),"^",2)]"" S FDA(2,62.801,IENS,1.13)=$P(LA7X(LA7I,1),"^",2)
. I $P(LA7X(LA7I,1),"^",5)]"" S FDA(2,62.801,IENS,1.14)=$P(LA7X(LA7I,1),"^",5)
. I $P(LA7X(LA7I,1),"^",3)]"" S FDA(2,62.801,IENS,1.2)=$P(LA7X(LA7I,1),"^",3)
. I $P(LA7X(LA7I,1),"^",4)]"" S FDA(2,62.801,IENS,1.23)=$P(LA7X(LA7I,1),"^",4)
. I $P(LA7X(LA7I,1),"^",6)]"" S FDA(2,62.801,IENS,1.24)=$P(LA7X(LA7I,1),"^",6)
I $D(LA7X(LA7I,2)) D
. I $P(LA7X(LA7I,2),"^",1)]"" S FDA(2,62.801,IENS,2.1)=$P(LA7X(LA7I,2),"^",1)
. I $P(LA7X(LA7I,2),"^",2)]"" S FDA(2,62.801,IENS,2.13)=$P(LA7X(LA7I,2),"^",2)
. I $P(LA7X(LA7I,2),"^",7)]"" S FDA(2,62.801,IENS,2.14)=$P(LA7X(LA7I,2),"^",7)
. I $P(LA7X(LA7I,2),"^",3)]"" S FDA(2,62.801,IENS,2.2)=$P(LA7X(LA7I,2),"^",3)
. I $P(LA7X(LA7I,2),"^",4)]"" S FDA(2,62.801,IENS,2.23)=$P(LA7X(LA7I,2),"^",4)
. I $P(LA7X(LA7I,2),"^",8)]"" S FDA(2,62.801,IENS,2.24)=$P(LA7X(LA7I,2),"^",8)
. I $P(LA7X(LA7I,2),"^",5)]"" S FDA(2,62.801,IENS,2.3)=$P(LA7X(LA7I,2),"^",5)
. I $P(LA7X(LA7I,2),"^",6)]"" S FDA(2,62.801,IENS,2.33)=$P(LA7X(LA7I,2),"^",6)
. I $P(LA7X(LA7I,2),"^",9)]"" S FDA(2,62.801,IENS,2.34)=$P(LA7X(LA7I,2),"^",9)
I $D(LA7X(LA7I,5)) D
. F I=1:1:9 I $P(LA7X(LA7I,5),"^",I)]"" S FDA(2,62.801,IENS,"5."_I)=$P(LA7X(LA7I,5),"^",I)
D UPDATE^DIE("","FDA(2)","LA7628","LA7DIE(2)")
;
; Update event file
S LA7DATA="SM50^"_$$NOW^XLFDT_"^"_LA760_"^"_$P(LA7SM,"^",2)
D SEUP^LA7SMU(LA7UID,2,LA7DATA)
;
; Update accession
D ACCSUP^LA7SMU(LA7UID,LA760,+LA7SM)
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 $L($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
;
L +^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760):9999 ; Set lock.
;
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="@"
;
K ^TMP("LA7SMB",$J),^TMP("LA7SMADD",$J),^TMP("LA7TREE",$J)
;
K LA760,LA76205,LA76805,LA7AA,LA7AD,LA7AN,LA7EXPRV,LA7FLAG,LA7LAN,LA7PCNT,LA7QUIT,LA7SCFG,LA7SM,LA7SMCNT,LA7UID,LA7X
K LRDFN
Q
LA7SMB ;VA/DALOI/JMC - Shipping Manifest Build ;JUL 06, 2010 3:14 PM
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64,1027**;NOV 01, 1997
EN ;
+1 ;
+2 DO CLEANUP
+3 SET LA7QUIT=0
+4 ;
+5 ; Select shipping configuration
+6 SET LA7SCFG=$$SSCFG^LA7SUTL(1)
+7 IF LA7SCFG<1
DO CLEANUP
QUIT
+8 ;
+9 ; Determine if there's an active manifest.
+10 SET LA7SM=$$CHKSM^LA7SMU(+LA7SCFG)
+11 IF LA7SM<0
Begin DoDot:1
+12 DO EN^DDIOL($PIECE(LA7SM,"^",2),"","!?5")
+13 DO CLEANUP
End DoDot:1
QUIT
+14 ;
+15 IF LA7SM=0
Begin DoDot:1
+16 NEW DIR,DIRUT,DTOUT,X,Y
+17 SET DIR(0)="YO"
SET DIR("A",1)="There's no open shipping manifest for "_$PIECE(LA7SCFG,"^",2)
+18 SET DIR("A")="Do you want to start one"
SET DIR("B")="NO"
+19 DO ^DIR
+20 IF Y'=1
SET LA7QUIT=1
QUIT
+21 SET LA7SM=$$CSM^LA7SMU(+LA7SCFG)
+22 IF LA7SM<1
DO EN^DDIOL($PIECE(LA7SM,"^",2),"","!?5")
SET LA7QUIT=1
End DoDot:1
+23 ;
+24 ; Only starting a new manifest, no building
+25 IF $GET(LA7SMON)
QUIT
+26 ;
+27 IF LA7QUIT=1
DO CLEANUP
QUIT
+28 ;
+29 DO ADATE^LA7SMU1
+30 IF LA7QUIT=1
DO CLEANUP
QUIT
+31 ;
+32 ; Flag to exclude previously removed tests from building.
+33 SET LA7EXPRV=$$ASKPREV^LA7SMU1
+34 IF LA7EXPRV<0
SET LA7QUIT=1
+35 ;
+36 IF LA7QUIT=1
DO CLEANUP
QUIT
+37 ;
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 LOCK +^LAHM(62.8,+LA7SM,0):5
+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 SET LA7AA=""
+18 FOR
SET LA7AA=$ORDER(^TMP("LA7SMB",$JOB,LA7AA))
IF LA7AA=""
QUIT
Begin DoDot:1
+19 NEW LA7END,LRSS
+20 IF '$DATA(ZTQUEUED)
DO EN^DDIOL("Searching accession area: "_$PIECE($GET(^LRO(68,LA7AA,0)),"^"),"","!?5")
+21 ; Use selected accession date else get current accession day for this acession area
+22 IF $GET(LA7AA(LA7AA))
SET LA7AD=$PIECE(LA7AA(LA7AA),"^")
+23 IF '$TEST
SET LA7AD=$$AD^LA7SUTL(LA7AA)
+24 SET LRSS=$PIECE($GET(^LRO(68,LA7AA,0)),"^",2)
+25 SET LA7AN=+$PIECE($GET(LA7AA(LA7AA)),"^",2)
SET LA7LAN=+$PIECE($GET(LA7AA(LA7AA)),"^",3)
SET LA7END=0
+26 IF LA7AN
SET LA7AN=LA7AN-1
+27 FOR
SET LA7AN=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN))
IF 'LA7AN!(LA7END)
QUIT
DO SCAN
End DoDot:1
+28 ;
+29 ; Update status
+30 DO SMSUP^LA7SMU(LA7SM,1,"SM02")
+31 ;
+32 ; Release lock on this shipping manifest
+33 LOCK -^LAHM(62.8,+LA7SM,0)
+34 ;
+35 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+36 NEW DIR,DIRUT,DIROUT,DTOUT,X,Y
+37 DO EN^DDIOL("There were "_$SELECT(LA7SMCNT:LA7SMCNT,1:"NO")_" specimens added","","!?5")
+38 DO ASK^LA7SMP(LA7SM)
End DoDot:1
+39 DO CLEANUP
+40 QUIT
+41 ;
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 LA76805,LA7DIV,LA7END
+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 ; Get Specimen type - if no specimen then quit
+13 ; Anatomic path does not store specimen type in #68.
+14 SET LA76805=""
+15 IF "CY^EM^SP"[LRSS
SET LA76805=0
+16 IF '$TEST
Begin DoDot:1
+17 SET X=+$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
+18 IF 'X
QUIT
+19 SET LA76805=+$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
End DoDot:1
+20 IF LA76805=""
QUIT
+21 ;
+22 ; Accession's division
+23 SET LA7DIV=+$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.4)),"^")
+24 ;
+25 SET LA760=0
+26 FOR
SET LA760=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760))
IF 'LA760
QUIT
Begin DoDot:1
+27 ; Not looking for this test.
+28 IF '$DATA(^TMP("LA7SMB",$JOB,LA7AA,LA760))
QUIT
+29 ; Set lock.
+30 DO LOCK68
+31 ; NOTE *** Do NOT add any "QUIT" after this point unless releasing LOCK set above ***.
+32 ; Test's zeroth node.
+33 SET LA760(0)=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760,0))
+34 ; Test completed - skip
+35 IF "CY^EM^SP"'[LRSS
IF $PIECE(LA760(0),"^",5)
DO UNLOCK68
QUIT
+36 ; Test already on shipping manifest - skip
+37 IF $PIECE(LA760(0),"^",10)
DO UNLOCK68
QUIT
+38 ; Previously removed - skip
+39 IF LA7EXPRV
IF $$PREV^LA7SMU1($PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^"),$PIECE(LA760(0),"^"))
DO UNLOCK68
QUIT
+40 ; Test urgency
+41 SET LA76205=+$PIECE(LA760(0),"^",2)
+42 IF LA76205>49
SET LA76205=$SELECT(LA76205=50:9,1:LA76205-50)
+43 ; Check if test is eligible for manifest
+44 DO SCHK^LA7SM1
+45 IF LA7FLAG
SET LA7FLAG=$$CKTEST(LA7AA,LA7AD,LA7AN,LA760)
+46 ; Add test to shipping manifest.
+47 IF LA7FLAG
Begin DoDot:2
+48 SET LA7I=0
+49 FOR
SET LA7I=$ORDER(LA7X(LA7I))
IF 'LA7I
QUIT
DO ADD
End DoDot:2
+50 ; Release lock.
+51 DO UNLOCK68
End DoDot:1
+52 QUIT
+53 ;
ADD ; Add test to shipping manifest
+1 ; Called from above, LA7SM
+2 ; Lock on ^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) should be set before entering here.
+3 ;
+4 NEW FDA,IENS,LA7628,LA768,LA7DATA
+5 ;
+6 SET LRDFN=+$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0))
+7 SET LA7UID=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^")
+8 IF LA7UID=""
SET LA7UID=$$LRUID^LRX(LA7AA,LA7AD,LA7AN)
+9 SET LA7SMCNT=$GET(LA7SMCNT)+1
+10 SET ^TMP("LA7SMADD",$JOB,LA7SMCNT)=LRDFN_"^"_LA760_"^"_LA76805_"^"_LA76205_"^"_LA7UID
+11 SET LA7628(1)=+LA7SM
SET IENS="+2,"_LA7628(1)_","
+12 SET FDA(2,62.801,IENS,.01)=LRDFN
+13 SET FDA(2,62.801,IENS,.02)=LA760
+14 IF LA76805
SET FDA(2,62.801,IENS,.03)=LA76805
+15 SET FDA(2,62.801,IENS,.04)=LA76205
+16 SET FDA(2,62.801,IENS,.05)=LA7UID
+17 SET FDA(2,62.801,IENS,.08)=1
+18 IF $DATA(LA7X(LA7I,0))
Begin DoDot:1
+19 IF $PIECE(LA7X(LA7I,0),"^",5)
SET FDA(2,62.801,IENS,.06)=$PIECE(LA7X(LA7I,0),"^",5)
+20 IF $PIECE(LA7X(LA7I,0),"^",6)
SET FDA(2,62.801,IENS,.07)=$PIECE(LA7X(LA7I,0),"^",6)
+21 IF $PIECE(LA7X(LA7I,0),"^",7)
SET FDA(2,62.801,IENS,.09)=$PIECE(LA7X(LA7I,0),"^",7)
End DoDot:1
+22 IF $DATA(LA7X(LA7I,1))
Begin DoDot:1
+23 IF $PIECE(LA7X(LA7I,1),"^",1)]""
SET FDA(2,62.801,IENS,1.1)=$PIECE(LA7X(LA7I,1),"^",1)
+24 IF $PIECE(LA7X(LA7I,1),"^",2)]""
SET FDA(2,62.801,IENS,1.13)=$PIECE(LA7X(LA7I,1),"^",2)
+25 IF $PIECE(LA7X(LA7I,1),"^",5)]""
SET FDA(2,62.801,IENS,1.14)=$PIECE(LA7X(LA7I,1),"^",5)
+26 IF $PIECE(LA7X(LA7I,1),"^",3)]""
SET FDA(2,62.801,IENS,1.2)=$PIECE(LA7X(LA7I,1),"^",3)
+27 IF $PIECE(LA7X(LA7I,1),"^",4)]""
SET FDA(2,62.801,IENS,1.23)=$PIECE(LA7X(LA7I,1),"^",4)
+28 IF $PIECE(LA7X(LA7I,1),"^",6)]""
SET FDA(2,62.801,IENS,1.24)=$PIECE(LA7X(LA7I,1),"^",6)
End DoDot:1
+29 IF $DATA(LA7X(LA7I,2))
Begin DoDot:1
+30 IF $PIECE(LA7X(LA7I,2),"^",1)]""
SET FDA(2,62.801,IENS,2.1)=$PIECE(LA7X(LA7I,2),"^",1)
+31 IF $PIECE(LA7X(LA7I,2),"^",2)]""
SET FDA(2,62.801,IENS,2.13)=$PIECE(LA7X(LA7I,2),"^",2)
+32 IF $PIECE(LA7X(LA7I,2),"^",7)]""
SET FDA(2,62.801,IENS,2.14)=$PIECE(LA7X(LA7I,2),"^",7)
+33 IF $PIECE(LA7X(LA7I,2),"^",3)]""
SET FDA(2,62.801,IENS,2.2)=$PIECE(LA7X(LA7I,2),"^",3)
+34 IF $PIECE(LA7X(LA7I,2),"^",4)]""
SET FDA(2,62.801,IENS,2.23)=$PIECE(LA7X(LA7I,2),"^",4)
+35 IF $PIECE(LA7X(LA7I,2),"^",8)]""
SET FDA(2,62.801,IENS,2.24)=$PIECE(LA7X(LA7I,2),"^",8)
+36 IF $PIECE(LA7X(LA7I,2),"^",5)]""
SET FDA(2,62.801,IENS,2.3)=$PIECE(LA7X(LA7I,2),"^",5)
+37 IF $PIECE(LA7X(LA7I,2),"^",6)]""
SET FDA(2,62.801,IENS,2.33)=$PIECE(LA7X(LA7I,2),"^",6)
+38 IF $PIECE(LA7X(LA7I,2),"^",9)]""
SET FDA(2,62.801,IENS,2.34)=$PIECE(LA7X(LA7I,2),"^",9)
End DoDot:1
+39 IF $DATA(LA7X(LA7I,5))
Begin DoDot:1
+40 FOR I=1:1:9
IF $PIECE(LA7X(LA7I,5),"^",I)]""
SET FDA(2,62.801,IENS,"5."_I)=$PIECE(LA7X(LA7I,5),"^",I)
End DoDot:1
+41 DO UPDATE^DIE("","FDA(2)","LA7628","LA7DIE(2)")
+42 ;
+43 ; Update event file
+44 SET LA7DATA="SM50^"_$$NOW^XLFDT_"^"_LA760_"^"_$P(LA7SM,"^",2)
+45 DO SEUP^LA7SMU(LA7UID,2,LA7DATA)
+46 ;
+47 ; Update accession
+48 DO ACCSUP^LA7SMU(LA7UID,LA760,+LA7SM)
+49 QUIT
+50 ;
+51 ;
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 $LENGTH($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 ; Set lock.
LOCK +^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760):9999
+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 KILL ^TMP("LA7SMB",$JOB),^TMP("LA7SMADD",$JOB),^TMP("LA7TREE",$JOB)
+5 ;
+6 KILL LA760,LA76205,LA76805,LA7AA,LA7AD,LA7AN,LA7EXPRV,LA7FLAG,LA7LAN,LA7PCNT,LA7QUIT,LA7SCFG,LA7SM,LA7SMCNT,LA7UID,LA7X
+7 KILL LRDFN
+8 QUIT
