288 lines
9.1 KiB
Mathematica
288 lines
9.1 KiB
Mathematica
LA7SMB ;DALOI/JMC - Shipping Manifest Build ;11/25/96 14:39
|
|
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, 1994
|
|
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
|