LA7VIN7B ;DALOI/JDB - Process ORU's OBX for Micro ;08/05/16 08:16
;;5.2;AUTOMATED LAB INSTRUMENTS;**74,90**;Sep 27, 1994;Build 17
;
; Continuation of LA7VIN7 and is only called from there.
; Process OBX segments for "MI" subscript tests.
Q
;
;
4 ;
; process Mycobaterium (Subscript 12)
N X,SUB,ISQN2
I DDS<0!(DDP<1) D DDERR^LA7VIN7A Q
I LA7612<1 D Q ;
. ; Unknown entity in OBX-5
. N LA7VOBX5
. S LA7VOBX5=OBX5 ;needed for log
. S LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
. D CREATE^LA7LOG(204)
. S LA7KILAH=1 S LA7QUIT=2
;
S ISQN2=0
I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,SUBID)
I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,PSUBID)
I 'ISQN2 D Q ;
. D SUBIDERR^LA7VIN71
;
S SUB="12,"_ISQN2_",0"
D LAH(SUB,DDP,LA7612) ; organism #61.2 IEN
S X=OBX5_$S(OBX6'="":" "_OBX6,1:"")
S SUB="12,"_ISQN2_",.1"
D LAH(SUB,1,SUBID) ; isolate id
S SUB="12,"_ISQN2_","_DDS_",.01"
D LAH(SUB,1,LA7RLNC) ; LOINC IEN
D LAH(SUB,2,LA7RNLT) ; NLT code
D LAH(SUB,3,LA7SCT) ; SCT Code
S SUB="12,"_ISQN2_","_DDS_",.01,0"
D LAH(SUB,1,OBX11) ;
S SUB="12,"_ISQN2_","_DDS_",.01,1"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X)
D NTE
Q
;
;
9 ;
; Process fungus (Subscript 9)
N X,SUB,ISQN2
I LA7612<1 D Q ;
. ; Unknown entity in OBX-5
. N LA7VOBX5
. S LA7VOBX5=OBX5 ;needed for log
. S LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
. D CREATE^LA7LOG(204)
. S LA7KILAH=1 S LA7QUIT=2
;
S ISQN2=0
I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,SUBID)
I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,PSUBID)
I 'ISQN2 D Q ;
. D SUBIDERR^LA7VIN71
;
S SUB="9,"_ISQN2_",0"
D LAH(SUB,1,LA7612) ; #61.2 IEN
S SUB="9,"_ISQN2_",.1"
D LAH(SUB,1,SUBID) ; isolate id
S SUB="9,"_ISQN2_",0,.01"
D LAH(SUB,1,LA7RLNC) ; LOINC IEN
D LAH(SUB,2,LA7RNLT) ; NLT code
D LAH(SUB,3,LA7SCT) ; SCT Code
S SUB="9,"_ISQN2_",0,.01,0"
D LAH(SUB,1,OBX11) ;
S SUB="9,"_ISQN2_",0,.01,1"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X)
D NTE
Q
;
;
11 ;
; Process Fungal Colony Count (Subscript 9)
N X,SUB,ISQN2,UNITS
S ISQN2=0
I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,SUBID)
I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,PSUBID)
I 'ISQN2 D Q ;
. D SUBIDERR^LA7VIN71
;
D LAH("9,0",-1,"")
S SUB="9,"_ISQN2_",0"
S X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
S UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
I UNITS'="" S X=X_" "_UNITS
D LAH(SUB,2,X) ;quantity
S SUB="9,"_ISQN2_",0,1"
D LAH(SUB,1,LA7RLNC) ; LOINC
S SUB="9,"_ISQN2_",0,1,0"
D LAH(SUB,1,OBX11) ; Obsv Results
S SUB="9,"_ISQN2_",0,1,1"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; Resp Obsv.
D NTE
Q
;
;
15(COM) ;
; Process Mycology Rpt Remark (Subscript 10)
; Input
; COM : <opt> The text to use for the remark (comment)
; : If empty OBX5 is used
;
N X,SUB,ISQN2,TEXT,TEXT2,MAXLEN
; dont initialize COM
S SUB="10,0"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; resp obsv
D LAH(SUB,3,LA7RLNC) ; LOINC
D LAH(SUB,4,OBX11) ;obsv status
S ISQN2=$O(^LAH(LWL,1,LA7ISQN,"MI",10,"A"),-1)+1
; pull comment from COM or OBX5
S TEXT="OBX5"
I $D(COM)=1 S TEXT="COM"
I TEXT="OBX5" S TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
I TEXT="COM" S TEXT2=$G(COM)
S MAXLEN=68 ; COMMENTS field size
S SUB="10,"_ISQN2_",0"
; insert separator line if needed
I ISQN2>1 D LAH(SUB,1," ") S ISQN2=ISQN2+1 S SUB="10,"_ISQN2_",0"
;
; if this an override insert Original Concept name
I $P(DSOBX3,"^",6) I $P(DSOBX3,"^",1)'=$P(DSOBX3,"^",6) D ;
. S X=$P(DSOBX3,"^",6) ;original concept
. S X=$G(^LAB(62.47,X,0))
. S X=$P(X,U,1)
. Q:X=""
. D LAH(SUB,1,"["_X_"]")
. S ISQN2=ISQN2+1 S SUB="13,"_ISQN2_",0"
;
; modify MAXLEN for prefixed Subid
I $L(TEXT2)'>MAXLEN D ;
. D LAH(SUB,1,TEXT2)
I $L(TEXT2)>MAXLEN D ;
. N I,Y,PASS
. S PASS=$L(TEXT2)\MAXLEN
. S:($L(TEXT2)#MAXLEN)>0 PASS=PASS+1
. F I=0:1:PASS-1 S Y=(I*MAXLEN)+1 D ;
. . D LAH(SUB,1,$E(TEXT2,Y,(Y+MAXLEN)-1))
. . S Y=Y+MAXLEN
. . S ISQN2=ISQN2+1
. . S SUB="10,"_ISQN2_",0"
. ;
D NTE^LA7VIN71(LA76247,ISQN)
Q
;
;
20 ;
; Process Mycobacterium Colony Count (Subscript 12)
N X,SUB,ISQN2,UNITS
S ISQN2=0
I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,SUBID)
I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,PSUBID)
I 'ISQN2 D Q ;
. D SUBIDERR^LA7VIN71
;
S SUB="12,"_ISQN2_",0"
S X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
S UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
I UNITS'="" S X=X_" "_UNITS
D LAH(SUB,2,X) ;quantity
S SUB="12,"_ISQN2_",0,1"
D LAH(SUB,1,LA7RLNC) ; LOINC
S SUB="12,"_ISQN2_",0,1,0"
D LAH(SUB,1,OBX11) ; Obsv Results
S SUB="12,"_ISQN2_",0,1,1"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; Resp Obsv.
D NTE
Q
;
;
21 ;
; Process mycobacteria susceptibilities (Subscript 12)
N LA76206,LA7X,X,X2,SUB,ISQN2,ASCRN
I DDS<0!(DDP'>0) D DDERR^LA7VIN7A Q
S ISQN2=0
I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,SUBID)
I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,PSUBID)
I 'ISQN2 D Q ;
. D SUBIDERR^LA7VIN71
;
S ASCRN=$$FIELD^LA7VHLU7(13)
I ASCRN'="" D ;
. N X,DATA
. S X=$P(DSOBX3,"^",4)
. S X=X+.2
. D CHK^DIE(63.3,X,"",ASCRN,.DATA)
. S ASCRN=$P(DATA,"^",1)
S SUB="12,"_ISQN2_","_DDS
S X=OBX5_$S(OBX6'="":" "_OBX6,1:"")
; convert SCT susc code to local code
I LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE") D
. N LA7I,VAR,VER,X2
. S X2="",VAR=OBX5 D FLD2ARR^LA7VHLU7(.VAR,LA7FS_LA7ECH)
. F LA7I=1,4 D Q:X2'=""
. . I $G(VAR(LA7I))="",$G(VAR(LA7I+1))="" Q ; Quit if no code or text for this tuple
. . S VER=$S(LA7I=1:7,1:8)
. . S X2=$$SCT2KB^LA7VHLU6($G(VAR(LA7I)),$G(VAR(LA7I+1)),$G(VAR(LA7I+2)),$G(VAR(VER)))
. . I X2'="" S X=X2 Q
. . S X2=$$SCT2PN^LA7VHLU6($G(VAR(LA7I)),$G(VAR(LA7I+1)),$G(VAR(LA7I+2)),$G(VAR(VER)))
. . I X2'="" S X=X2
;
S X=$TR(X,"^"," ")
D LAH(SUB,DDP,X) ; result
S SUB="12,"_ISQN2_","_DDS_",.01"
D LAH(SUB,1,LA7RLNC) ; LOINC
D LAH(SUB,2,LA7RNLT) ; NLT code
D LAH(SUB,3,LA7SCT) ; SCT
S SUB="12,"_ISQN2_","_DDS_",.01,0"
D LAH(SUB,1,OBX11) ;obsv status
S SUB="12,"_ISQN2_","_DDS_",.01,1"
D LAH(SUB,1,LA74) ; #4 IEN
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; resp observer
;
; Set prefix to antibiotic abbrevation or full name to annotate comments.
S LA7X=$$ABPREFIX^LA7VIN7A(2,LA7DD)
I LA7X="" S LA7X=LA7DD("LABEL")
D NTE^LA7VIN71(LA76247,ISQN2,LA7X)
Q
;
;
79 ;
; Process Acid Fast Stain (Subscript 11)
N X,SUB,ISQN2,UNITS,DATAOK
S SUB="11,0"
S X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
D ;
. N Z,LAMSG
. D CHK^DIE(63.05,24,"",X,.Z,"LAMSG")
. I $G(Z)'="^" S X=Z
S DATAOK=$$DATAOK^LA7VIN7(63.05,24,X)
S UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
; Workaround 01/10/2007 (store anything in Set of Codes)
D LAH(SUB,3,X)
I DATAOK D ;
. D LAH(SUB,3,X)
;
I 'DATAOK D ;
. I UNITS'="" S X=X_" "_UNITS
. D LAH(SUB,4,X) ;quantity
;
S SUB="11,0,.01"
D LAH(SUB,1,LA7RLNC) ; LOINC
S SUB="11,0,.01,0"
D LAH(SUB,1,OBX11) ; Obsv Results
S SUB="11,0,.01,1"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; Resp Obsv.
D NTE^LA7VIN71(LA76247,ISQN)
Q
;
;
85 ;
; Process Acid Fast Stain Quantity (Subscript 11)
N X,SUB,ISQN2,UNITS
S SUB="11,0"
S X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
S UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
I UNITS'="" S X=X_" "_UNITS
D LAH(SUB,4,X)
;
S SUB="11,0,.02"
D LAH(SUB,1,LA7RLNC) ; LOINC
S SUB="11,0,.02,0"
D LAH(SUB,1,OBX11) ; Obsv Results
S SUB="11,0,.02,1"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; Resp Obsv.
D NTE^LA7VIN71(LA76247,ISQN)
Q
;
;
LAH(LASUB,LAP,LAVAL) ;
; Convenience method
D LAH^LAGEN(+$G(LWL),+$G(LA7ISQN),"MI",LASUB,LAP,LAVAL)
Q
;
;
NTE ;
; Convenience method
D NTE^LA7VIN71(LA76247,ISQN2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN7B 8070 printed Jan 18, 2025@02:41:47 Page 2
LA7VIN7B ;DALOI/JDB - Process ORU's OBX for Micro ;08/05/16 08:16
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74,90**;Sep 27, 1994;Build 17
+2 ;
+3 ; Continuation of LA7VIN7 and is only called from there.
+4 ; Process OBX segments for "MI" subscript tests.
+5 QUIT
+6 ;
+7 ;
4 ;
+1 ; process Mycobaterium (Subscript 12)
+2 NEW X,SUB,ISQN2
+3 IF DDS<0!(DDP<1)
DO DDERR^LA7VIN7A
QUIT
+4 ;
IF LA7612<1
Begin DoDot:1
+5 ; Unknown entity in OBX-5
+6 NEW LA7VOBX5
+7 ;needed for log
SET LA7VOBX5=OBX5
+8 SET LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
+9 DO CREATE^LA7LOG(204)
+10 SET LA7KILAH=1
SET LA7QUIT=2
End DoDot:1
QUIT
+11 ;
+12 SET ISQN2=0
+13 IF SUBID'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,SUBID)
+14 IF SUBID=""
IF $GET(PSUBID)'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,PSUBID)
+15 ;
IF 'ISQN2
Begin DoDot:1
+16 DO SUBIDERR^LA7VIN71
End DoDot:1
QUIT
+17 ;
+18 SET SUB="12,"_ISQN2_",0"
+19 ; organism #61.2 IEN
DO LAH(SUB,DDP,LA7612)
+20 SET X=OBX5_$SELECT(OBX6'="":" "_OBX6,1:"")
+21 SET SUB="12,"_ISQN2_",.1"
+22 ; isolate id
DO LAH(SUB,1,SUBID)
+23 SET SUB="12,"_ISQN2_","_DDS_",.01"
+24 ; LOINC IEN
DO LAH(SUB,1,LA7RLNC)
+25 ; NLT code
DO LAH(SUB,2,LA7RNLT)
+26 ; SCT Code
DO LAH(SUB,3,LA7SCT)
+27 SET SUB="12,"_ISQN2_","_DDS_",.01,0"
+28 ;
DO LAH(SUB,1,OBX11)
+29 SET SUB="12,"_ISQN2_","_DDS_",.01,1"
+30 DO LAH(SUB,1,LA74)
+31 SET X=$PIECE(LA7RO,"^",3)
+32 DO LAH(SUB,2,X)
+33 DO NTE
+34 QUIT
+35 ;
+36 ;
9 ;
+1 ; Process fungus (Subscript 9)
+2 NEW X,SUB,ISQN2
+3 ;
IF LA7612<1
Begin DoDot:1
+4 ; Unknown entity in OBX-5
+5 NEW LA7VOBX5
+6 ;needed for log
SET LA7VOBX5=OBX5
+7 SET LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
+8 DO CREATE^LA7LOG(204)
+9 SET LA7KILAH=1
SET LA7QUIT=2
End DoDot:1
QUIT
+10 ;
+11 SET ISQN2=0
+12 IF SUBID'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,SUBID)
+13 IF SUBID=""
IF $GET(PSUBID)'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,PSUBID)
+14 ;
IF 'ISQN2
Begin DoDot:1
+15 DO SUBIDERR^LA7VIN71
End DoDot:1
QUIT
+16 ;
+17 SET SUB="9,"_ISQN2_",0"
+18 ; #61.2 IEN
DO LAH(SUB,1,LA7612)
+19 SET SUB="9,"_ISQN2_",.1"
+20 ; isolate id
DO LAH(SUB,1,SUBID)
+21 SET SUB="9,"_ISQN2_",0,.01"
+22 ; LOINC IEN
DO LAH(SUB,1,LA7RLNC)
+23 ; NLT code
DO LAH(SUB,2,LA7RNLT)
+24 ; SCT Code
DO LAH(SUB,3,LA7SCT)
+25 SET SUB="9,"_ISQN2_",0,.01,0"
+26 ;
DO LAH(SUB,1,OBX11)
+27 SET SUB="9,"_ISQN2_",0,.01,1"
+28 DO LAH(SUB,1,LA74)
+29 SET X=$PIECE(LA7RO,"^",3)
+30 DO LAH(SUB,2,X)
+31 DO NTE
+32 QUIT
+33 ;
+34 ;
11 ;
+1 ; Process Fungal Colony Count (Subscript 9)
+2 NEW X,SUB,ISQN2,UNITS
+3 SET ISQN2=0
+4 IF SUBID'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,SUBID)
+5 IF SUBID=""
IF $GET(PSUBID)'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",9,PSUBID)
+6 ;
IF 'ISQN2
Begin DoDot:1
+7 DO SUBIDERR^LA7VIN71
End DoDot:1
QUIT
+8 ;
+9 DO LAH("9,0",-1,"")
+10 SET SUB="9,"_ISQN2_",0"
+11 SET X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+12 SET UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
+13 IF UNITS'=""
SET X=X_" "_UNITS
+14 ;quantity
DO LAH(SUB,2,X)
+15 SET SUB="9,"_ISQN2_",0,1"
+16 ; LOINC
DO LAH(SUB,1,LA7RLNC)
+17 SET SUB="9,"_ISQN2_",0,1,0"
+18 ; Obsv Results
DO LAH(SUB,1,OBX11)
+19 SET SUB="9,"_ISQN2_",0,1,1"
+20 DO LAH(SUB,1,LA74)
+21 SET X=$PIECE(LA7RO,"^",3)
+22 ; Resp Obsv.
DO LAH(SUB,2,X)
+23 DO NTE
+24 QUIT
+25 ;
+26 ;
15(COM) ;
+1 ; Process Mycology Rpt Remark (Subscript 10)
+2 ; Input
+3 ; COM : <opt> The text to use for the remark (comment)
+4 ; : If empty OBX5 is used
+5 ;
+6 NEW X,SUB,ISQN2,TEXT,TEXT2,MAXLEN
+7 ; dont initialize COM
+8 SET SUB="10,0"
+9 DO LAH(SUB,1,LA74)
+10 SET X=$PIECE(LA7RO,"^",3)
+11 ; resp obsv
DO LAH(SUB,2,X)
+12 ; LOINC
DO LAH(SUB,3,LA7RLNC)
+13 ;obsv status
DO LAH(SUB,4,OBX11)
+14 SET ISQN2=$ORDER(^LAH(LWL,1,LA7ISQN,"MI",10,"A"),-1)+1
+15 ; pull comment from COM or OBX5
+16 SET TEXT="OBX5"
+17 IF $DATA(COM)=1
SET TEXT="COM"
+18 IF TEXT="OBX5"
SET TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+19 IF TEXT="COM"
SET TEXT2=$GET(COM)
+20 ; COMMENTS field size
SET MAXLEN=68
+21 SET SUB="10,"_ISQN2_",0"
+22 ; insert separator line if needed
+23 IF ISQN2>1
DO LAH(SUB,1," ")
SET ISQN2=ISQN2+1
SET SUB="10,"_ISQN2_",0"
+24 ;
+25 ; if this an override insert Original Concept name
+26 ;
IF $PIECE(DSOBX3,"^",6)
IF $PIECE(DSOBX3,"^",1)'=$PIECE(DSOBX3,"^",6)
Begin DoDot:1
+27 ;original concept
SET X=$PIECE(DSOBX3,"^",6)
+28 SET X=$GET(^LAB(62.47,X,0))
+29 SET X=$PIECE(X,U,1)
+30 if X=""
QUIT
+31 DO LAH(SUB,1,"["_X_"]")
+32 SET ISQN2=ISQN2+1
SET SUB="13,"_ISQN2_",0"
End DoDot:1
+33 ;
+34 ; modify MAXLEN for prefixed Subid
+35 ;
IF $LENGTH(TEXT2)'>MAXLEN
Begin DoDot:1
+36 DO LAH(SUB,1,TEXT2)
End DoDot:1
+37 ;
IF $LENGTH(TEXT2)>MAXLEN
Begin DoDot:1
+38 NEW I,Y,PASS
+39 SET PASS=$LENGTH(TEXT2)\MAXLEN
+40 if ($LENGTH(TEXT2)#MAXLEN)>0
SET PASS=PASS+1
+41 ;
FOR I=0:1:PASS-1
SET Y=(I*MAXLEN)+1
Begin DoDot:2
+42 DO LAH(SUB,1,$EXTRACT(TEXT2,Y,(Y+MAXLEN)-1))
+43 SET Y=Y+MAXLEN
+44 SET ISQN2=ISQN2+1
+45 SET SUB="10,"_ISQN2_",0"
End DoDot:2
+46 ;
End DoDot:1
+47 DO NTE^LA7VIN71(LA76247,ISQN)
+48 QUIT
+49 ;
+50 ;
20 ;
+1 ; Process Mycobacterium Colony Count (Subscript 12)
+2 NEW X,SUB,ISQN2,UNITS
+3 SET ISQN2=0
+4 IF SUBID'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,SUBID)
+5 IF SUBID=""
IF $GET(PSUBID)'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,PSUBID)
+6 ;
IF 'ISQN2
Begin DoDot:1
+7 DO SUBIDERR^LA7VIN71
End DoDot:1
QUIT
+8 ;
+9 SET SUB="12,"_ISQN2_",0"
+10 SET X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+11 SET UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
+12 IF UNITS'=""
SET X=X_" "_UNITS
+13 ;quantity
DO LAH(SUB,2,X)
+14 SET SUB="12,"_ISQN2_",0,1"
+15 ; LOINC
DO LAH(SUB,1,LA7RLNC)
+16 SET SUB="12,"_ISQN2_",0,1,0"
+17 ; Obsv Results
DO LAH(SUB,1,OBX11)
+18 SET SUB="12,"_ISQN2_",0,1,1"
+19 DO LAH(SUB,1,LA74)
+20 SET X=$PIECE(LA7RO,"^",3)
+21 ; Resp Obsv.
DO LAH(SUB,2,X)
+22 DO NTE
+23 QUIT
+24 ;
+25 ;
21 ;
+1 ; Process mycobacteria susceptibilities (Subscript 12)
+2 NEW LA76206,LA7X,X,X2,SUB,ISQN2,ASCRN
+3 IF DDS<0!(DDP'>0)
DO DDERR^LA7VIN7A
QUIT
+4 SET ISQN2=0
+5 IF SUBID'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,SUBID)
+6 IF SUBID=""
IF $GET(PSUBID)'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",12,PSUBID)
+7 ;
IF 'ISQN2
Begin DoDot:1
+8 DO SUBIDERR^LA7VIN71
End DoDot:1
QUIT
+9 ;
+10 SET ASCRN=$$FIELD^LA7VHLU7(13)
+11 ;
IF ASCRN'=""
Begin DoDot:1
+12 NEW X,DATA
+13 SET X=$PIECE(DSOBX3,"^",4)
+14 SET X=X+.2
+15 DO CHK^DIE(63.3,X,"",ASCRN,.DATA)
+16 SET ASCRN=$PIECE(DATA,"^",1)
End DoDot:1
+17 SET SUB="12,"_ISQN2_","_DDS
+18 SET X=OBX5_$SELECT(OBX6'="":" "_OBX6,1:"")
+19 ; convert SCT susc code to local code
+20 IF LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE")
Begin DoDot:1
+21 NEW LA7I,VAR,VER,X2
+22 SET X2=""
SET VAR=OBX5
DO FLD2ARR^LA7VHLU7(.VAR,LA7FS_LA7ECH)
+23 FOR LA7I=1,4
Begin DoDot:2
+24 ; Quit if no code or text for this tuple
IF $GET(VAR(LA7I))=""
IF $GET(VAR(LA7I+1))=""
QUIT
+25 SET VER=$SELECT(LA7I=1:7,1:8)
+26 SET X2=$$SCT2KB^LA7VHLU6($GET(VAR(LA7I)),$GET(VAR(LA7I+1)),$GET(VAR(LA7I+2)),$GET(VAR(VER)))
+27 IF X2'=""
SET X=X2
QUIT
+28 SET X2=$$SCT2PN^LA7VHLU6($GET(VAR(LA7I)),$GET(VAR(LA7I+1)),$GET(VAR(LA7I+2)),$GET(VAR(VER)))
+29 IF X2'=""
SET X=X2
End DoDot:2
if X2'=""
QUIT
End DoDot:1
+30 ;
+31 SET X=$TRANSLATE(X,"^"," ")
+32 ; result
DO LAH(SUB,DDP,X)
+33 SET SUB="12,"_ISQN2_","_DDS_",.01"
+34 ; LOINC
DO LAH(SUB,1,LA7RLNC)
+35 ; NLT code
DO LAH(SUB,2,LA7RNLT)
+36 ; SCT
DO LAH(SUB,3,LA7SCT)
+37 SET SUB="12,"_ISQN2_","_DDS_",.01,0"
+38 ;obsv status
DO LAH(SUB,1,OBX11)
+39 SET SUB="12,"_ISQN2_","_DDS_",.01,1"
+40 ; #4 IEN
DO LAH(SUB,1,LA74)
+41 SET X=$PIECE(LA7RO,"^",3)
+42 ; resp observer
DO LAH(SUB,2,X)
+43 ;
+44 ; Set prefix to antibiotic abbrevation or full name to annotate comments.
+45 SET LA7X=$$ABPREFIX^LA7VIN7A(2,LA7DD)
+46 IF LA7X=""
SET LA7X=LA7DD("LABEL")
+47 DO NTE^LA7VIN71(LA76247,ISQN2,LA7X)
+48 QUIT
+49 ;
+50 ;
79 ;
+1 ; Process Acid Fast Stain (Subscript 11)
+2 NEW X,SUB,ISQN2,UNITS,DATAOK
+3 SET SUB="11,0"
+4 SET X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+5 ;
Begin DoDot:1
+6 NEW Z,LAMSG
+7 DO CHK^DIE(63.05,24,"",X,.Z,"LAMSG")
+8 IF $GET(Z)'="^"
SET X=Z
End DoDot:1
+9 SET DATAOK=$$DATAOK^LA7VIN7(63.05,24,X)
+10 SET UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
+11 ; Workaround 01/10/2007 (store anything in Set of Codes)
+12 DO LAH(SUB,3,X)
+13 ;
IF DATAOK
Begin DoDot:1
+14 DO LAH(SUB,3,X)
End DoDot:1
+15 ;
+16 ;
IF 'DATAOK
Begin DoDot:1
+17 IF UNITS'=""
SET X=X_" "_UNITS
+18 ;quantity
DO LAH(SUB,4,X)
End DoDot:1
+19 ;
+20 SET SUB="11,0,.01"
+21 ; LOINC
DO LAH(SUB,1,LA7RLNC)
+22 SET SUB="11,0,.01,0"
+23 ; Obsv Results
DO LAH(SUB,1,OBX11)
+24 SET SUB="11,0,.01,1"
+25 DO LAH(SUB,1,LA74)
+26 SET X=$PIECE(LA7RO,"^",3)
+27 ; Resp Obsv.
DO LAH(SUB,2,X)
+28 DO NTE^LA7VIN71(LA76247,ISQN)
+29 QUIT
+30 ;
+31 ;
85 ;
+1 ; Process Acid Fast Stain Quantity (Subscript 11)
+2 NEW X,SUB,ISQN2,UNITS
+3 SET SUB="11,0"
+4 SET X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+5 SET UNITS=$$UNESC^LA7VHLU3(OBX6,LA7FS_LA7ECH)
+6 IF UNITS'=""
SET X=X_" "_UNITS
+7 DO LAH(SUB,4,X)
+8 ;
+9 SET SUB="11,0,.02"
+10 ; LOINC
DO LAH(SUB,1,LA7RLNC)
+11 SET SUB="11,0,.02,0"
+12 ; Obsv Results
DO LAH(SUB,1,OBX11)
+13 SET SUB="11,0,.02,1"
+14 DO LAH(SUB,1,LA74)
+15 SET X=$PIECE(LA7RO,"^",3)
+16 ; Resp Obsv.
DO LAH(SUB,2,X)
+17 DO NTE^LA7VIN71(LA76247,ISQN)
+18 QUIT
+19 ;
+20 ;
LAH(LASUB,LAP,LAVAL) ;
+1 ; Convenience method
+2 DO LAH^LAGEN(+$GET(LWL),+$GET(LA7ISQN),"MI",LASUB,LAP,LAVAL)
+3 QUIT
+4 ;
+5 ;
NTE ;
+1 ; Convenience method
+2 DO NTE^LA7VIN71(LA76247,ISQN2)
+3 QUIT
