LA7SMU2A ;DALOI/JMC - Shipping Manifest Utility (Cont'd) ;10/23/12 11:08
;;5.2;AUTOMATED LAB INSTRUMENTS;**74,80**;Sep 27, 1994;Build 19
;
Q
;
;
BINDX ; Build index of tests for a shipping configuration.
; Called from LA7SMU2.
;
N I,J,K,LA760,LA761,LA762,LA76205,LA764,LA7HL,LA7NLT,LA7NLTN,LA7TC,LA7X,LA7Y,LA7Z,LRSS
S LA7X=0
F S LA7X=$O(^LAHM(62.9,LA7SCFG,60,LA7X)) Q:'LA7X D BLD
Q
;
;
BLD ; Build TMP global for a test
; Called from above
;
K LA761,LA762,LA76205,LA764,LA7NLT,LA7NLTN,LA7TC,LA7Y,LA7Z
;
S LA7X(0)=$G(^LAHM(62.9,LA7SCFG,60,LA7X,0))
S LA7X(5)=$G(^LAHM(62.9,LA7SCFG,60,LA7X,5))
;
; Laboratory test/collection sample.
S LA760=$P(LA7X(0),"^"),LA761=+$P(LA7X(0),"^",3),LA762=+$P(LA7X(0),"^",9),LRSS=$P(^LAB(60,LA760,0),"^",4)
I 'LA761 S LA761=$$GET1^DIQ(62,LA762_",",2,"I")
I LA761,'LA762 S LA762=+$$GET1^DIQ(61,LA761_",",4.1,"I")
; Incomplete entry if in CH or BB subscript.
I 'LA762,"BBCH"[LRSS Q
I 'LA761,"BBCH"[LRSS Q
;
; Test urgency/HL7 priority code.
S LA76205=$P(LA7X(0),"^",4),LA76205("HL")=""
I LA76205 S LA76205("HL")=$$GET1^DIQ(62.05,LA76205_",","LEDI HL7:HL7 ABBR")
;
; Use HL7 specimen code if using table 0070, SNOMED if SCT and mapping in 62.9 for local.
S LA761("HL70070")=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
S LA761("SCT")=$P($$IEN2SCT^LA7VHLU6(61,LA761,DT),"^")
I $P(LA7X(5),"^",3)'="" D
. I $P(LA7X(5),"^",6)="" S $P(LA7X(5),"^",6)="L"
. S LA761($P(LA7X(5),"^",6))=$P(LA7X(5),"^",3)
;
; Use SNOMED CT and local mapping in 62.9 for collection sample.
S LA762("SCT")=$P($$IEN2SCT^LA7VHLU6(62,LA762,DT),"^")
I $P(LA7X(5),"^",7)'="" D
. I $P(LA7X(5),"^",9)="" S $P(LA7X(5),"^",9)="L"
. S LA762($P(LA7X(5),"^",9))=$P(LA7X(5),"^",7)
;
; File #64 ien/NLT code/NLT code test name.
; Use NLT code if using VA coding else use non-VA test order code.
S LA764=+$$GET1^DIQ(60,LA760_",",64,"I")
I 'LA764 Q
S LA7TC("99VA64")=$$GET1^DIQ(64,LA764_",",1,"I")
S LA7NLTN=$$GET1^DIQ(64,LA764_",",.01)
I $P(LA7X(5),"^")'="" D
. I $P(LA7X(5),"^",5)="" S $P(LA7X(5),"^",5)="L"
. S LA7TC($P(LA7X(5),"^",5))=$P(LA7X(5),"^")
;
; Set TMP global with information
S LA7Y=LA760_"^"_LA761_"^"_LA762_"^"_LA76205_"^"_LA7TC("99VA64")_"^"_LA7NLTN
S I=""
F S I=$O(LA7TC(I)) Q:I="" D
. S K=""
. F S K=$O(LA762(K)) Q:K="" I LA762(K)'="" D
. . S J=""
. . F S J=$O(LA761(J)) Q:J="" I LA761(J)'="" D
. . . S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),J,LA761(J),0,K,LA762(K))=LA7Y
. . . I LA76205("HL")'="" S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),J,LA761(J),LA76205("HL"),K,LA762(K))=LA7Y
. . I 'LA761,LRSS="MI" D Q
. . . S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),0,0,0,K,LA762(K))=LA7Y
. . . I LA76205("HL")'="" S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),0,0,LA76205("HL"),K,LA762(K))=LA7Y
. . I 'LA761,"SPCYEM"[LRSS D
. . . S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),"HL70070","XXX",0,K,LA762(K))=LA7Y
. . . I LA76205("HL")'="" S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),"HL70070","XXX",LA76205("HL"),K,LA762(K))=LA7Y
. I LRSS="MI" S LA7Z=LA7Y,$P(LA7Z,"^",2,4)="^^",^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),0,0,0,0,0)=LA7Z
. S J=""
. F S J=$O(LA761(J)) Q:J="" I LA761(J)'="",LRSS?1(1"CH",1"MI") D
. . I LA76205("HL")'="" S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),J,LA761(J),LA76205("HL"))=LA7Y
. . E S ^TMP("LA7TC",$J,LA7SCFG,I,LA7TC(I),J,LA761(J))=LA7Y
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SMU2A 3385 printed Apr 09, 2024@20:47:33 Page 2
LA7SMU2A ;DALOI/JMC - Shipping Manifest Utility (Cont'd) ;10/23/12 11:08
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74,80**;Sep 27, 1994;Build 19
+2 ;
+3 QUIT
+4 ;
+5 ;
BINDX ; Build index of tests for a shipping configuration.
+1 ; Called from LA7SMU2.
+2 ;
+3 NEW I,J,K,LA760,LA761,LA762,LA76205,LA764,LA7HL,LA7NLT,LA7NLTN,LA7TC,LA7X,LA7Y,LA7Z,LRSS
+4 SET LA7X=0
+5 FOR
SET LA7X=$ORDER(^LAHM(62.9,LA7SCFG,60,LA7X))
if 'LA7X
QUIT
DO BLD
+6 QUIT
+7 ;
+8 ;
BLD ; Build TMP global for a test
+1 ; Called from above
+2 ;
+3 KILL LA761,LA762,LA76205,LA764,LA7NLT,LA7NLTN,LA7TC,LA7Y,LA7Z
+4 ;
+5 SET LA7X(0)=$GET(^LAHM(62.9,LA7SCFG,60,LA7X,0))
+6 SET LA7X(5)=$GET(^LAHM(62.9,LA7SCFG,60,LA7X,5))
+7 ;
+8 ; Laboratory test/collection sample.
+9 SET LA760=$PIECE(LA7X(0),"^")
SET LA761=+$PIECE(LA7X(0),"^",3)
SET LA762=+$PIECE(LA7X(0),"^",9)
SET LRSS=$PIECE(^LAB(60,LA760,0),"^",4)
+10 IF 'LA761
SET LA761=$$GET1^DIQ(62,LA762_",",2,"I")
+11 IF LA761
IF 'LA762
SET LA762=+$$GET1^DIQ(61,LA761_",",4.1,"I")
+12 ; Incomplete entry if in CH or BB subscript.
+13 IF 'LA762
IF "BBCH"[LRSS
QUIT
+14 IF 'LA761
IF "BBCH"[LRSS
QUIT
+15 ;
+16 ; Test urgency/HL7 priority code.
+17 SET LA76205=$PIECE(LA7X(0),"^",4)
SET LA76205("HL")=""
+18 IF LA76205
SET LA76205("HL")=$$GET1^DIQ(62.05,LA76205_",","LEDI HL7:HL7 ABBR")
+19 ;
+20 ; Use HL7 specimen code if using table 0070, SNOMED if SCT and mapping in 62.9 for local.
+21 SET LA761("HL70070")=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
+22 SET LA761("SCT")=$PIECE($$IEN2SCT^LA7VHLU6(61,LA761,DT),"^")
+23 IF $PIECE(LA7X(5),"^",3)'=""
Begin DoDot:1
+24 IF $PIECE(LA7X(5),"^",6)=""
SET $PIECE(LA7X(5),"^",6)="L"
+25 SET LA761($PIECE(LA7X(5),"^",6))=$PIECE(LA7X(5),"^",3)
End DoDot:1
+26 ;
+27 ; Use SNOMED CT and local mapping in 62.9 for collection sample.
+28 SET LA762("SCT")=$PIECE($$IEN2SCT^LA7VHLU6(62,LA762,DT),"^")
+29 IF $PIECE(LA7X(5),"^",7)'=""
Begin DoDot:1
+30 IF $PIECE(LA7X(5),"^",9)=""
SET $PIECE(LA7X(5),"^",9)="L"
+31 SET LA762($PIECE(LA7X(5),"^",9))=$PIECE(LA7X(5),"^",7)
End DoDot:1
+32 ;
+33 ; File #64 ien/NLT code/NLT code test name.
+34 ; Use NLT code if using VA coding else use non-VA test order code.
+35 SET LA764=+$$GET1^DIQ(60,LA760_",",64,"I")
+36 IF 'LA764
QUIT
+37 SET LA7TC("99VA64")=$$GET1^DIQ(64,LA764_",",1,"I")
+38 SET LA7NLTN=$$GET1^DIQ(64,LA764_",",.01)
+39 IF $PIECE(LA7X(5),"^")'=""
Begin DoDot:1
+40 IF $PIECE(LA7X(5),"^",5)=""
SET $PIECE(LA7X(5),"^",5)="L"
+41 SET LA7TC($PIECE(LA7X(5),"^",5))=$PIECE(LA7X(5),"^")
End DoDot:1
+42 ;
+43 ; Set TMP global with information
+44 SET LA7Y=LA760_"^"_LA761_"^"_LA762_"^"_LA76205_"^"_LA7TC("99VA64")_"^"_LA7NLTN
+45 SET I=""
+46 FOR
SET I=$ORDER(LA7TC(I))
if I=""
QUIT
Begin DoDot:1
+47 SET K=""
+48 FOR
SET K=$ORDER(LA762(K))
if K=""
QUIT
IF LA762(K)'=""
Begin DoDot:2
+49 SET J=""
+50 FOR
SET J=$ORDER(LA761(J))
if J=""
QUIT
IF LA761(J)'=""
Begin DoDot:3
+51 SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),J,LA761(J),0,K,LA762(K))=LA7Y
+52 IF LA76205("HL")'=""
SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),J,LA761(J),LA76205("HL"),K,LA762(K))=LA7Y
End DoDot:3
+53 IF 'LA761
IF LRSS="MI"
Begin DoDot:3
+54 SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),0,0,0,K,LA762(K))=LA7Y
+55 IF LA76205("HL")'=""
SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),0,0,LA76205("HL"),K,LA762(K))=LA7Y
End DoDot:3
QUIT
+56 IF 'LA761
IF "SPCYEM"[LRSS
Begin DoDot:3
+57 SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),"HL70070","XXX",0,K,LA762(K))=LA7Y
+58 IF LA76205("HL")'=""
SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),"HL70070","XXX",LA76205("HL"),K,LA762(K))=LA7Y
End DoDot:3
End DoDot:2
+59 IF LRSS="MI"
SET LA7Z=LA7Y
SET $PIECE(LA7Z,"^",2,4)="^^"
SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),0,0,0,0,0)=LA7Z
+60 SET J=""
+61 FOR
SET J=$ORDER(LA761(J))
if J=""
QUIT
IF LA761(J)'=""
IF LRSS?1(1"CH",1"MI")
Begin DoDot:2
+62 IF LA76205("HL")'=""
SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),J,LA761(J),LA76205("HL"))=LA7Y
+63 IF '$TEST
SET ^TMP("LA7TC",$JOB,LA7SCFG,I,LA7TC(I),J,LA761(J))=LA7Y
End DoDot:2
End DoDot:1
+64 ;
+65 QUIT
