Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7SMB

LA7SMB.m

Go to the documentation of this file. 
  1. 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
  1. EN ;
  1.  ;
  1.  D CLEANUP
  1.  S LA7QUIT=0
  1.  ;
  1.  ; Select shipping configuration
  1.  S LA7SCFG=$$SSCFG^LA7SUTL(1)
  1.  I LA7SCFG<1 D CLEANUP Q
  1.  ;
  1.  ; Determine if there's an active manifest.
  1.  S LA7SM=$$CHKSM^LA7SMU(+LA7SCFG)
  1.  I LA7SM<0 D  Q
  1.  . D EN^DDIOL($P(LA7SM,"^",2),"","!?5")
  1.  . D CLEANUP
  1.  ;
  1.  I LA7SM=0 D
  1.  . N DIR,DIRUT,DTOUT,X,Y
  1.  . S DIR(0)="YO",DIR("A",1)="There's no open shipping manifest for "_$P(LA7SCFG,"^",2)
  1.  . S DIR("A")="Do you want to start one",DIR("B")="NO"
  1.  . D ^DIR
  1.  . I Y'=1 S LA7QUIT=1 Q
  1.  . S LA7SM=$$CSM^LA7SMU(+LA7SCFG)
  1.  . I LA7SM<1 D EN^DDIOL($P(LA7SM,"^",2),"","!?5") S LA7QUIT=1
  1.  ;
  1.  ; Only starting a new manifest, no building
  1.  I $G(LA7SMON) Q
  1.  ;
  1.  I LA7QUIT=1 D CLEANUP Q
  1.  ;
  1.  D ADATE^LA7SMU1
  1.  I LA7QUIT=1 D CLEANUP Q
  1.  ;
  1.  ; Flag to exclude previously removed tests from building.
  1.  S LA7EXPRV=$$ASKPREV^LA7SMU1
  1.  I LA7EXPRV<0 S LA7QUIT=1
  1.  ;
  1.  I LA7QUIT=1 D CLEANUP Q
  1.  ;
  1. DQ ; Taskman entry point
  1.  ; Build list of tests and criteria for manifest.
  1.  S LA7SCFG(0)=$G(^LAHM(62.9,+LA7SCFG,0))
  1.  I '$D(ZTQUEUED) D EN^DDIOL("Using shipping manifest# "_$P(LA7SM,"^",2),"","!?5")
  1.  ;
  1.  ; Lock this shipping manifest
  1.  L +^LAHM(62.8,+LA7SM,0):5
  1.  I '$T D  Q
  1.  . I '$D(ZTQUEUED) D EN^DDIOL("Unable to obtain lock for shipping manifest "_$P(LA7SCFG,"^",2),"","!?5")
  1.  . D CLEANUP
  1.  ;
  1.  ; Update status
  1.  D SMSUP^LA7SMU(LA7SM,2,"SM03")
  1.  S LA7SMCNT=0
  1.  ;
  1.  ; Build TMP global with test profiles
  1.  D SCBLD^LA7SM1(+LA7SCFG)
  1.  S LA7AA=""
  1.  F  S LA7AA=$O(^TMP("LA7SMB",$J,LA7AA)) Q:LA7AA=""  D
  1.  . N LA7END,LRSS
  1.  . I '$D(ZTQUEUED) D EN^DDIOL("Searching accession area: "_$P($G(^LRO(68,LA7AA,0)),"^"),"","!?5")
  1.  . ; Use selected accession date else get current accession day for this acession area
  1.  . I $G(LA7AA(LA7AA)) S LA7AD=$P(LA7AA(LA7AA),"^")
  1.  . E  S LA7AD=$$AD^LA7SUTL(LA7AA)
  1.  . S LRSS=$P($G(^LRO(68,LA7AA,0)),"^",2)
  1.  . S LA7AN=+$P($G(LA7AA(LA7AA)),"^",2),LA7LAN=+$P($G(LA7AA(LA7AA)),"^",3),LA7END=0
  1.  . I LA7AN S LA7AN=LA7AN-1
  1.  . F  S LA7AN=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN)) Q:'LA7AN!(LA7END)  D SCAN
  1.  ;
  1.  ; Update status
  1.  D SMSUP^LA7SMU(LA7SM,1,"SM02")
  1.  ;
  1.  ; Release lock on this shipping manifest
  1.  L -^LAHM(62.8,+LA7SM,0)
  1.  ;
  1.  I '$D(ZTQUEUED) D
  1.  . N DIR,DIRUT,DIROUT,DTOUT,X,Y
  1.  . D EN^DDIOL("There were "_$S(LA7SMCNT:LA7SMCNT,1:"NO")_" specimens added","","!?5")
  1.  . D ASK^LA7SMP(LA7SM)
  1.  D CLEANUP
  1.  Q
  1.  ;
  1. SMONLY ; Start a shipping manifest only, no building
  1.  ;
  1.  N LA7SMON
  1.  S LA7SMON=1
  1.  D EN
  1.  I $G(LA7SCFG),$G(LA7SM)>0 D EN^DDIOL("Shipping manifest# "_$P(LA7SM,"^",2)_" is available","","!?5")
  1.  D CLEANUP
  1.  Q
  1.  ;
  1.  ;
  1. SCAN ; Scan accession for tests to build
  1.  ;
  1.  N LA76805,LA7DIV,LA7END
  1.  ;
  1.  I LA7LAN,LA7AN>LA7LAN S LA7END=1 Q
  1.  ;
  1.  ; Don't build controls
  1.  I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3 Q
  1.  ;
  1.  ; Don't build uncollected specimens
  1.  I '$P(LA7SCFG(0),"^",14),'$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),"^",3) Q
  1.  ;
  1.  ; Get Specimen type - if no specimen then quit
  1.  ; Anatomic path does not store specimen type in #68.
  1.  S LA76805=""
  1.  I "CY^EM^SP"[LRSS S LA76805=0
  1.  E  D
  1.  . S X=+$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
  1.  . I 'X Q
  1.  . S LA76805=+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
  1.  I LA76805="" Q
  1.  ;
  1.  ; Accession's division
  1.  S LA7DIV=+$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.4)),"^")
  1.  ;
  1.  S LA760=0
  1.  F  S LA760=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)) Q:'LA760  D
  1.  . ; Not looking for this test.
  1.  . I '$D(^TMP("LA7SMB",$J,LA7AA,LA760)) Q
  1.  . ; Set lock.
  1.  . D LOCK68
  1.  . ; NOTE *** Do NOT add any "QUIT" after this point unless releasing LOCK set above ***.
  1.  . ; Test's zeroth node.
  1.  . S LA760(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760,0))
  1.  . ; Test completed - skip
  1.  . I "CY^EM^SP"'[LRSS,$P(LA760(0),"^",5) D UNLOCK68 Q
  1.  . ; Test already on shipping manifest - skip
  1.  . I $P(LA760(0),"^",10) D UNLOCK68 Q
  1.  . ; Previously removed - skip
  1.  . I LA7EXPRV,$$PREV^LA7SMU1($P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^"),$P(LA760(0),"^")) D UNLOCK68 Q
  1.  . ; Test urgency
  1.  . S LA76205=+$P(LA760(0),"^",2)
  1.  . I LA76205>49 S LA76205=$S(LA76205=50:9,1:LA76205-50)
  1.  . ; Check if test is eligible for manifest
  1.  . D SCHK^LA7SM1
  1.  . I LA7FLAG S LA7FLAG=$$CKTEST(LA7AA,LA7AD,LA7AN,LA760)
  1.  . ; Add test to shipping manifest.
  1.  . I LA7FLAG D
  1.  . . S LA7I=0
  1.  . . F  S LA7I=$O(LA7X(LA7I)) Q:'LA7I  D ADD
  1.  . ; Release lock.
  1.  . D UNLOCK68
  1.  Q
  1.  ;
  1. ADD ; Add test to shipping manifest
  1.  ; Called from above, LA7SM
  1.  ; Lock on ^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) should be set before entering here.
  1.  ;
  1.  N FDA,IENS,LA7628,LA768,LA7DATA
  1.  ;
  1.  S LRDFN=+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0))
  1.  S LA7UID=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^")
  1.  I LA7UID="" S LA7UID=$$LRUID^LRX(LA7AA,LA7AD,LA7AN)
  1.  S LA7SMCNT=$G(LA7SMCNT)+1
  1.  S ^TMP("LA7SMADD",$J,LA7SMCNT)=LRDFN_"^"_LA760_"^"_LA76805_"^"_LA76205_"^"_LA7UID
  1.  S LA7628(1)=+LA7SM,IENS="+2,"_LA7628(1)_","
  1.  S FDA(2,62.801,IENS,.01)=LRDFN
  1.  S FDA(2,62.801,IENS,.02)=LA760
  1.  I LA76805 S FDA(2,62.801,IENS,.03)=LA76805
  1.  S FDA(2,62.801,IENS,.04)=LA76205
  1.  S FDA(2,62.801,IENS,.05)=LA7UID
  1.  S FDA(2,62.801,IENS,.08)=1
  1.  I $D(LA7X(LA7I,0)) D
  1.  . I $P(LA7X(LA7I,0),"^",5) S FDA(2,62.801,IENS,.06)=$P(LA7X(LA7I,0),"^",5)
  1.  . I $P(LA7X(LA7I,0),"^",6) S FDA(2,62.801,IENS,.07)=$P(LA7X(LA7I,0),"^",6)
  1.  . I $P(LA7X(LA7I,0),"^",7) S FDA(2,62.801,IENS,.09)=$P(LA7X(LA7I,0),"^",7)
  1.  I $D(LA7X(LA7I,1)) D
  1.  . I $P(LA7X(LA7I,1),"^",1)]"" S FDA(2,62.801,IENS,1.1)=$P(LA7X(LA7I,1),"^",1)
  1.  . I $P(LA7X(LA7I,1),"^",2)]"" S FDA(2,62.801,IENS,1.13)=$P(LA7X(LA7I,1),"^",2)
  1.  . I $P(LA7X(LA7I,1),"^",5)]"" S FDA(2,62.801,IENS,1.14)=$P(LA7X(LA7I,1),"^",5)
  1.  . I $P(LA7X(LA7I,1),"^",3)]"" S FDA(2,62.801,IENS,1.2)=$P(LA7X(LA7I,1),"^",3)
  1.  . I $P(LA7X(LA7I,1),"^",4)]"" S FDA(2,62.801,IENS,1.23)=$P(LA7X(LA7I,1),"^",4)
  1.  . I $P(LA7X(LA7I,1),"^",6)]"" S FDA(2,62.801,IENS,1.24)=$P(LA7X(LA7I,1),"^",6)
  1.  I $D(LA7X(LA7I,2)) D
  1.  . I $P(LA7X(LA7I,2),"^",1)]"" S FDA(2,62.801,IENS,2.1)=$P(LA7X(LA7I,2),"^",1)
  1.  . I $P(LA7X(LA7I,2),"^",2)]"" S FDA(2,62.801,IENS,2.13)=$P(LA7X(LA7I,2),"^",2)
  1.  . I $P(LA7X(LA7I,2),"^",7)]"" S FDA(2,62.801,IENS,2.14)=$P(LA7X(LA7I,2),"^",7)
  1.  . I $P(LA7X(LA7I,2),"^",3)]"" S FDA(2,62.801,IENS,2.2)=$P(LA7X(LA7I,2),"^",3)
  1.  . I $P(LA7X(LA7I,2),"^",4)]"" S FDA(2,62.801,IENS,2.23)=$P(LA7X(LA7I,2),"^",4)
  1.  . I $P(LA7X(LA7I,2),"^",8)]"" S FDA(2,62.801,IENS,2.24)=$P(LA7X(LA7I,2),"^",8)
  1.  . I $P(LA7X(LA7I,2),"^",5)]"" S FDA(2,62.801,IENS,2.3)=$P(LA7X(LA7I,2),"^",5)
  1.  . I $P(LA7X(LA7I,2),"^",6)]"" S FDA(2,62.801,IENS,2.33)=$P(LA7X(LA7I,2),"^",6)
  1.  . I $P(LA7X(LA7I,2),"^",9)]"" S FDA(2,62.801,IENS,2.34)=$P(LA7X(LA7I,2),"^",9)
  1.  I $D(LA7X(LA7I,5)) D
  1.  . F I=1:1:9 I $P(LA7X(LA7I,5),"^",I)]"" S FDA(2,62.801,IENS,"5."_I)=$P(LA7X(LA7I,5),"^",I)
  1.  D UPDATE^DIE("","FDA(2)","LA7628","LA7DIE(2)")
  1.  ;
  1.  ; Update event file
  1.  S LA7DATA="SM50^"_$$NOW^XLFDT_"^"_LA760_"^"_$P(LA7SM,"^",2)
  1.  D SEUP^LA7SMU(LA7UID,2,LA7DATA)
  1.  ;
  1.  ; Update accession
  1.  D ACCSUP^LA7SMU(LA7UID,LA760,+LA7SM)
  1.  Q
  1.  ;
  1.  ;
  1. CKTEST(LA7AA,LA7AD,LA7AN,LA760) ; Check other tests on accession if test is part of another panel that
  1.  ; has been flagged for shipping.
  1.  ; Call with LA7AA = ien of accession area.
  1.  ;           LA7AD = accession date
  1.  ;           LA7AN = accession number
  1.  ;           LA760 = ien of lab test
  1.  ; Returns   LA7FLAG = 0 (part of another panel)
  1.  ;                   = 1 (not part of another panel)
  1.  ;
  1.  N LA7FLAG,LA7PCNT,LA7K,LA7J,X
  1.  ;
  1.  K ^TMP("LA7TREE",$J)
  1.  ;
  1.  S LA7FLAG=1
  1.  S LA7AD(LA7AD)=""
  1.  S LA7K=+$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",3)
  1.  ;
  1.  I LA7K D
  1.  . ; Check original accession date.
  1.  . S LA7AD(LA7K)=""
  1.  . ; Check rollover accession
  1.  . I $P($G(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^") S LA7AD($P($G(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^"))=""
  1.  S LA7AD=0
  1.  F  S LA7AD=$O(LA7AD(LA7AD)) Q:'LA7AD  D
  1.  . S LA7J=0
  1.  . F  S LA7J=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J)) Q:'LA7J  D
  1.  . . I LA7J=LA760 Q
  1.  . . ; Not on manifest
  1.  . . I '$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J,0)),"^",10) Q
  1.  . . S LA7PCNT=0 D UNWIND(LA7J)
  1.  ;
  1.  ; Test is part of another test previously shipped.
  1.  I $D(^TMP("LA7TREE",$J,LA760)) S LA7FLAG=0
  1.  ;
  1.  K ^TMP("LA7TREE",$J)
  1.  ;
  1.  Q LA7FLAG
  1.  ;
  1. UNWIND(LA760) ; Unwind profile - set tests into global ^TMP("LA7TREE",$J).
  1.  ; Initialize variable LA7PCNT=0 before calling.
  1.  ; Kill ^TMP("LA7TREE",$J) before calling.
  1.  ;
  1.  N I,II
  1.  ;
  1.  ; Recursive panel, caught in a loop.
  1.  I $G(LA7PCNT)>50 Q
  1.  ; Test does not exist in file 60.
  1.  I '$D(^LAB(60,LA760,0)) Q
  1.  ; Bypass "workload" type tests.
  1.  I $P(^LAB(60,LA760,0),"^",4)="WK" Q
  1.  ; Atomic test
  1.  I $L($P(^LAB(60,LA760,0),"^",5)) S ^TMP("LA7TREE",$J,LA760)="" Q
  1.  ; Check panels
  1.  I $O(^LAB(60,LA760,2,0)) D
  1.  . ; Increment panel counter.
  1.  . S LA7PCNT=$G(LA7PCNT)+1
  1.  . S I=0
  1.  . ; Expand test on panel.
  1.  . F  S I=$O(^LAB(60,LA760,2,I)) Q:'I  D
  1.  . . ; IEN of test on panel.
  1.  . . S II=+$G(^LAB(60,LA760,2,I,0))
  1.  . . ; Recursive panel, panel calls itself.
  1.  . . I II,II=LA760 Q
  1.  . . I II S ^TMP("LA7TREE",$J,LA760)="" D UNWIND(II)
  1.  Q
  1.  ;
  1. LOCK68 ; Lock entry in file 68
  1.  ; Called from above, LA7SM
  1.  ;
  1.  L +^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760):9999 ; Set lock.
  1.  ;
  1.  Q
  1.  ;
  1. UNLOCK68 ; Unlock entry in file 68
  1.  ; Called from above, LA7SM
  1.  ;
  1.  L -^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) ; Release lock.
  1.  ;
  1.  Q
  1.  ;
  1. CLEANUP ; Cleanup variables
  1.  ;
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  ;
  1.  K ^TMP("LA7SMB",$J),^TMP("LA7SMADD",$J),^TMP("LA7TREE",$J)
  1.  ;
  1.  K LA760,LA76205,LA76805,LA7AA,LA7AD,LA7AN,LA7EXPRV,LA7FLAG,LA7LAN,LA7PCNT,LA7QUIT,LA7SCFG,LA7SM,LA7SMCNT,LA7UID,LA7X
  1.  K LRDFN
  1.  Q