- LA7VIN7A ;DALOI/JDB - Process ORU's OBX for Micro ;08/05/16 07:32
- ;;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
- ;
- ;
- 1 ; Gram Stain (Subscript 2)
- ;
- N ISQN2,LA7X,SUB,X
- ;
- ; Store gram stain comment
- S ISQN2=$O(^LAH(LWL,1,LA7ISQN,"MI",2,"A"),-1)+1
- S SUB="2,"_ISQN2_",0"
- S X=OBX5_$S(OBX6'="":" "_OBX6,1:"")
- S X=$TR(X,"^"," ")
- D LAH(SUB,1,X) ;Value
- ;
- ; Store gram stain supporting info.
- S SUB="2,"_ISQN2_",0,0"
- D LAH(SUB,1,LA74) ; perf lab
- ;
- ; If LEDI interface then use LRLAB,HL as user.
- I LA7INTYP=10 S LA7X=^XTMP("LA7 PROXY","LRLAB,HL")
- E S LA7X=$P(LA7RO,"^",3)
- I LA7X D LAH(SUB,2,LA7X) ;resp observer
- ;
- D LAH(SUB,3,LA7RLNC) ; LOINC IEN
- D LAH(SUB,4,LA7RNLT) ; NLT code
- D LAH(SUB,5,OBX11) ; Observ result code
- ;
- D NTE
- Q
- ;
- ;
- 3 ; Process organism (Subscript 3)
- ;
- N X,SUB,ISQN2
- I DDS<0!(DDP<1) D DDERR 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",3,SUBID)
- I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,PSUBID)
- I 'ISQN2 D Q ;
- . D SUBIDERR^LA7VIN71
- ;
- D LAH("3,0",-1,"")
- S SUB="3,"_ISQN2_",0"
- D LAH(SUB,DDP,LA7612) ; organism #61.2 IEN
- S SUB="3,"_ISQN2_",.1"
- D LAH(SUB,1,SUBID) ; isolate id
- S SUB="3,"_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="3,"_ISQN2_","_DDS_",.01,0"
- D LAH(SUB,1,OBX11) ;
- S SUB="3,"_ISQN2_","_DDS_",.01,1"
- D LAH(SUB,1,LA74)
- S X=$P(LA7RO,"^",3)
- D LAH(SUB,2,X)
- D NTE
- Q
- ;
- ;
- 6(COM) ; Process bact rpt rmk (Subscript 4)
- ;
- ; Input
- ; COM : <opt> The text to use for the remark (comment)
- ; : If not defined, copy of sym table variable OBX5 is used.
- ; : If OBX5 used, TEXT2 will be HL7 unescaped. If COM
- ; : is used it's text is not HL7 unescaped.
- ;
- N X,SUB,ISQN2,TEXT,MAXLEN,TEXT2
- ; Dont initialize COM
- S SUB="4,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",4,"A"),-1)+1
- ; pull comment from COM or OBX5
- S TEXT="OBX5"
- I $D(COM)=1 S TEXT="COM"
- S MAXLEN=68 ; COMMENTS field size
- S SUB="4,"_ISQN2_",0"
- ; insert separator line if needed
- I ISQN2>1 D LAH(SUB,1," ") S ISQN2=ISQN2+1 S SUB="4,"_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 TEXT="OBX5" S TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
- I TEXT="COM" S TEXT2=$G(COM)
- 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="4,"_ISQN2_",0"
- . ;
- D NTE^LA7VIN71(LA76247,ISQN)
- Q
- ;
- ;
- 7 ; Process antimicrobial susceptibilities (Subscript 3)
- ;
- N ASCRN,ISQN2,LA7X,SUB,X,X2
- I DDS<0!(DDP'>0) D DDERR Q
- S ISQN2=0
- I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,SUBID)
- I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,PSUBID)
- I 'ISQN2 D Q ;
- . D SUBIDERR^LA7VIN71
- ;
- D LAH("3,0",-1,"")
- 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="3,"_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
- D LAH(SUB,2,OBX8) ; interpretation
- D LAH(SUB,3,ASCRN) ; screen
- S SUB="3,"_ISQN2_","_DDS_",.01"
- D LAH(SUB,1,LA7RLNC) ; LOINC
- D LAH(SUB,2,LA7RNLT) ; NLT code
- D LAH(SUB,3,LA7SCT) ; SCT
- S SUB="3,"_ISQN2_","_DDS_",.01,0"
- D LAH(SUB,1,OBX11) ;obsv status
- S SUB="3,"_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(1,LA7DD)
- I LA7X="" S LA7X=LA7DD("LABEL")
- D NTE^LA7VIN71(LA76247,ISQN2,LA7X)
- Q
- ;
- ;
- 10 ; Organism Colony Count (Subscript 3)
- ;
- N X,SUB,ISQN2,UNITS
- I DDS<0!(DDP'>0) D DDERR Q
- S ISQN2=0
- I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,SUBID)
- I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,PSUBID)
- I 'ISQN2 D Q ;
- . D SUBIDERR^LA7VIN71
- D LAH("3,0",-1,"")
- S SUB="3,"_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="3,"_ISQN2_","_DDS_",1"
- D LAH(SUB,1,LA7RLNC) ; LOINC
- S SUB="3,"_ISQN2_","_DDS_",1,0"
- D LAH(SUB,1,OBX11)
- S SUB="3,"_ISQN2_","_DDS_",1,1"
- D LAH(SUB,1,LA74) ; #4 IEN
- S X=$P(LA7RO,"^",3)
- D LAH(SUB,2,X) ; resp observer
- D NTE
- Q
- ;
- ;
- 16 ; Urine Screen (Subscript 1)
- ;
- N LAMSG,X,X2,Z
- ;
- S X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
- ;
- ; convert SCT positive/negative code to local code
- I LA7SCT D
- . S X2=$$SCT2PN^LA7VHLU6(LA7SCT,,"SCT",1)
- . I X2'="" S X=X2
- ;
- D ;
- . N Z,LAMSG,LRNOECHO
- . S LRNOECHO=1
- . D CHK^DIE(63.05,11.57,"",X,.Z,"LAMSG")
- . I $G(Z)'="^" S X=Z
- ;
- S DATAOK=$$DATAOK^LA7VIN7(63.05,11.57,X)
- ;
- S SUB="1,0"
- D LAH(SUB,6,X)
- ;
- S SUB="1,0,.02"
- D LAH(SUB,1,LA7RLNC) ; LOINC
- S SUB="1,0,.02,0"
- D LAH(SUB,1,OBX11) ; Obsv Results
- S SUB="1,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
- ;
- ;
- 17 ; Sputum Screen (Subscript 1)
- ;
- N X,SUB,ISQN2,UNITS,DATAOK
- ;
- S X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
- S DATAOK=$$DATAOK^LA7VIN7(63.05,11.58,X)
- ; Workaround 01/10/2007 (store anything in Set of Codes)
- S SUB="1,0"
- D LAH(SUB,5,X)
- I DATAOK D LAH(SUB,5,X)
- ;
- S SUB="1,0,.01"
- D LAH(SUB,1,LA7RLNC) ; LOINC
- S SUB="1,0,.01,0"
- D LAH(SUB,1,OBX11) ; Obsv Results
- S SUB="1,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
- ;
- ;
- DDERR ;
- ; If unknown storage location flag error
- ; No File #63 field mapping found for OBX-3
- N LA7OBX3
- S LA7OBX3=OBX3 ;needed for log
- D CREATE^LA7LOG(201)
- S LA7KILAH=1 S LA7QUIT=2
- Q
- ;
- ;
- LAH(LASUB,LAP,LAVAL) ;
- ; Convenience method
- I LAP'=-1 I LAVAL="" Q
- D LAH^LAGEN(+$G(LWL),+$G(LA7ISQN),"MI",LASUB,LAP,LAVAL)
- Q
- ;
- ;
- NTE ;
- ; Convenience method
- D NTE^LA7VIN71(LA76247,ISQN2)
- Q
- ;
- ;
- ABPREFIX(LA7TYPE,LA7DD) ; Get prefix of antibiotic full name to annotate comments.
- ; Call with LA7TYPE = type of antimicrobial (1=bacterial, 2=mycobacterial)
- ; LA7DD = drug node in file #63, MI subscript
- ;
- ; Returns LA7Y = drug abbreviation or full name from file #62.06
- ;
- N LA76206,LA7Y,LA7XREF
- S (LA76206,LA7Y)="",LA7TYPE=$G(LA7TYPE),LA7DD=$P($G(LA7DD),";")
- S LA7XREF=$S(LA7TYPE=1:"AD",LA7TYPE=2:"AD1",1:"")
- ;
- I LA7XREF'="",LA7DD S LA76206=$O(^LAB(62.06,LA7XREF,LA7DD,0))
- ;
- I LA76206 D
- . S LA76206(0)=$G(^LAB(62.06,LA76206,0))
- . S LA7Y="For "_$P(LA76206(0),"^")_": "
- ;
- Q LA7Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN7A 8190 printed Feb 18, 2025@23:06:55 Page 2
- LA7VIN7A ;DALOI/JDB - Process ORU's OBX for Micro ;08/05/16 07:32
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74,90**;Sep 27, 1994;Build 17
- +2 ;
- +3 ; Continuation of LA7VIN7 and is only called from there - process OBX segments for "MI" subscript tests.
- +4 QUIT
- +5 ;
- +6 ;
- 1 ; Gram Stain (Subscript 2)
- +1 ;
- +2 NEW ISQN2,LA7X,SUB,X
- +3 ;
- +4 ; Store gram stain comment
- +5 SET ISQN2=$ORDER(^LAH(LWL,1,LA7ISQN,"MI",2,"A"),-1)+1
- +6 SET SUB="2,"_ISQN2_",0"
- +7 SET X=OBX5_$SELECT(OBX6'="":" "_OBX6,1:"")
- +8 SET X=$TRANSLATE(X,"^"," ")
- +9 ;Value
- DO LAH(SUB,1,X)
- +10 ;
- +11 ; Store gram stain supporting info.
- +12 SET SUB="2,"_ISQN2_",0,0"
- +13 ; perf lab
- DO LAH(SUB,1,LA74)
- +14 ;
- +15 ; If LEDI interface then use LRLAB,HL as user.
- +16 IF LA7INTYP=10
- SET LA7X=^XTMP("LA7 PROXY","LRLAB,HL")
- +17 IF '$TEST
- SET LA7X=$PIECE(LA7RO,"^",3)
- +18 ;resp observer
- IF LA7X
- DO LAH(SUB,2,LA7X)
- +19 ;
- +20 ; LOINC IEN
- DO LAH(SUB,3,LA7RLNC)
- +21 ; NLT code
- DO LAH(SUB,4,LA7RNLT)
- +22 ; Observ result code
- DO LAH(SUB,5,OBX11)
- +23 ;
- +24 DO NTE
- +25 QUIT
- +26 ;
- +27 ;
- 3 ; Process organism (Subscript 3)
- +1 ;
- +2 NEW X,SUB,ISQN2
- +3 IF DDS<0!(DDP<1)
- DO DDERR
- 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",3,SUBID)
- +14 IF SUBID=""
- IF $GET(PSUBID)'=""
- SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,PSUBID)
- +15 ;
- IF 'ISQN2
- Begin DoDot:1
- +16 DO SUBIDERR^LA7VIN71
- End DoDot:1
- QUIT
- +17 ;
- +18 DO LAH("3,0",-1,"")
- +19 SET SUB="3,"_ISQN2_",0"
- +20 ; organism #61.2 IEN
- DO LAH(SUB,DDP,LA7612)
- +21 SET SUB="3,"_ISQN2_",.1"
- +22 ; isolate id
- DO LAH(SUB,1,SUBID)
- +23 SET SUB="3,"_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="3,"_ISQN2_","_DDS_",.01,0"
- +28 ;
- DO LAH(SUB,1,OBX11)
- +29 SET SUB="3,"_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 ;
- 6(COM) ; Process bact rpt rmk (Subscript 4)
- +1 ;
- +2 ; Input
- +3 ; COM : <opt> The text to use for the remark (comment)
- +4 ; : If not defined, copy of sym table variable OBX5 is used.
- +5 ; : If OBX5 used, TEXT2 will be HL7 unescaped. If COM
- +6 ; : is used it's text is not HL7 unescaped.
- +7 ;
- +8 NEW X,SUB,ISQN2,TEXT,MAXLEN,TEXT2
- +9 ; Dont initialize COM
- +10 SET SUB="4,0"
- +11 DO LAH(SUB,1,LA74)
- +12 SET X=$PIECE(LA7RO,"^",3)
- +13 ; resp obsv
- DO LAH(SUB,2,X)
- +14 ; LOINC
- DO LAH(SUB,3,LA7RLNC)
- +15 ;obsv status
- DO LAH(SUB,4,OBX11)
- +16 SET ISQN2=$ORDER(^LAH(LWL,1,LA7ISQN,"MI",4,"A"),-1)+1
- +17 ; pull comment from COM or OBX5
- +18 SET TEXT="OBX5"
- +19 IF $DATA(COM)=1
- SET TEXT="COM"
- +20 ; COMMENTS field size
- SET MAXLEN=68
- +21 SET SUB="4,"_ISQN2_",0"
- +22 ; insert separator line if needed
- +23 IF ISQN2>1
- DO LAH(SUB,1," ")
- SET ISQN2=ISQN2+1
- SET SUB="4,"_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 TEXT="OBX5"
- SET TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
- +36 IF TEXT="COM"
- SET TEXT2=$GET(COM)
- +37 ;
- IF $LENGTH(TEXT2)'>MAXLEN
- Begin DoDot:1
- +38 DO LAH(SUB,1,TEXT2)
- End DoDot:1
- +39 ;
- +40 ;
- IF $LENGTH(TEXT2)>MAXLEN
- Begin DoDot:1
- +41 NEW I,Y,PASS
- +42 SET PASS=$LENGTH(TEXT2)\MAXLEN
- +43 if ($LENGTH(TEXT2)#MAXLEN)>0
- SET PASS=PASS+1
- +44 ;
- FOR I=0:1:PASS-1
- SET Y=(I*MAXLEN)+1
- Begin DoDot:2
- +45 DO LAH(SUB,1,$EXTRACT(TEXT2,Y,(Y+MAXLEN)-1))
- +46 SET Y=Y+MAXLEN
- +47 SET ISQN2=ISQN2+1
- +48 SET SUB="4,"_ISQN2_",0"
- End DoDot:2
- +49 ;
- End DoDot:1
- +50 DO NTE^LA7VIN71(LA76247,ISQN)
- +51 QUIT
- +52 ;
- +53 ;
- 7 ; Process antimicrobial susceptibilities (Subscript 3)
- +1 ;
- +2 NEW ASCRN,ISQN2,LA7X,SUB,X,X2
- +3 IF DDS<0!(DDP'>0)
- DO DDERR
- QUIT
- +4 SET ISQN2=0
- +5 IF SUBID'=""
- SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,SUBID)
- +6 IF SUBID=""
- IF $GET(PSUBID)'=""
- SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,PSUBID)
- +7 ;
- IF 'ISQN2
- Begin DoDot:1
- +8 DO SUBIDERR^LA7VIN71
- End DoDot:1
- QUIT
- +9 ;
- +10 DO LAH("3,0",-1,"")
- +11 SET ASCRN=$$FIELD^LA7VHLU7(13)
- +12 ;
- IF ASCRN'=""
- Begin DoDot:1
- +13 NEW X,DATA
- +14 SET X=$PIECE(DSOBX3,"^",4)
- +15 SET X=X+.2
- +16 DO CHK^DIE(63.3,X,"",ASCRN,.DATA)
- +17 SET ASCRN=$PIECE(DATA,"^",1)
- End DoDot:1
- +18 SET SUB="3,"_ISQN2_","_DDS
- +19 SET X=OBX5_$SELECT(OBX6'="":" "_OBX6,1:"")
- +20 ;
- +21 ; convert SCT susc code to local code
- +22 IF LA7VTYP?1(1"CE",1"CM",1"CNE",1"CWE")
- Begin DoDot:1
- +23 NEW LA7I,VAR,VER,X2
- +24 SET X2=""
- SET VAR=OBX5
- DO FLD2ARR^LA7VHLU7(.VAR,LA7FS_LA7ECH)
- +25 FOR LA7I=1,4
- Begin DoDot:2
- +26 ; Quit if no code or text for this tuple
- IF $GET(VAR(LA7I))=""
- IF $GET(VAR(LA7I+1))=""
- QUIT
- +27 SET VER=$SELECT(LA7I=1:7,1:8)
- +28 SET X2=$$SCT2KB^LA7VHLU6($GET(VAR(LA7I)),$GET(VAR(LA7I+1)),$GET(VAR(LA7I+2)),$GET(VAR(VER)))
- +29 IF X2'=""
- SET X=X2
- QUIT
- +30 SET X2=$$SCT2PN^LA7VHLU6($GET(VAR(LA7I)),$GET(VAR(LA7I+1)),$GET(VAR(LA7I+2)),$GET(VAR(VER)))
- +31 IF X2'=""
- SET X=X2
- End DoDot:2
- if X2'=""
- QUIT
- End DoDot:1
- +32 ;
- +33 SET X=$TRANSLATE(X,"^"," ")
- +34 ;
- +35 ; result
- DO LAH(SUB,DDP,X)
- +36 ; interpretation
- DO LAH(SUB,2,OBX8)
- +37 ; screen
- DO LAH(SUB,3,ASCRN)
- +38 SET SUB="3,"_ISQN2_","_DDS_",.01"
- +39 ; LOINC
- DO LAH(SUB,1,LA7RLNC)
- +40 ; NLT code
- DO LAH(SUB,2,LA7RNLT)
- +41 ; SCT
- DO LAH(SUB,3,LA7SCT)
- +42 SET SUB="3,"_ISQN2_","_DDS_",.01,0"
- +43 ;obsv status
- DO LAH(SUB,1,OBX11)
- +44 SET SUB="3,"_ISQN2_","_DDS_",.01,1"
- +45 ; #4 IEN
- DO LAH(SUB,1,LA74)
- +46 SET X=$PIECE(LA7RO,"^",3)
- +47 ; resp observer
- DO LAH(SUB,2,X)
- +48 ;
- +49 ; Set prefix to antibiotic abbrevation or full name to annotate comments.
- +50 SET LA7X=$$ABPREFIX(1,LA7DD)
- +51 IF LA7X=""
- SET LA7X=LA7DD("LABEL")
- +52 DO NTE^LA7VIN71(LA76247,ISQN2,LA7X)
- +53 QUIT
- +54 ;
- +55 ;
- 10 ; Organism Colony Count (Subscript 3)
- +1 ;
- +2 NEW X,SUB,ISQN2,UNITS
- +3 IF DDS<0!(DDP'>0)
- DO DDERR
- QUIT
- +4 SET ISQN2=0
- +5 IF SUBID'=""
- SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,SUBID)
- +6 IF SUBID=""
- IF $GET(PSUBID)'=""
- SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",3,PSUBID)
- +7 ;
- IF 'ISQN2
- Begin DoDot:1
- +8 DO SUBIDERR^LA7VIN71
- End DoDot:1
- QUIT
- +9 DO LAH("3,0",-1,"")
- +10 SET SUB="3,"_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="3,"_ISQN2_","_DDS_",1"
- +16 ; LOINC
- DO LAH(SUB,1,LA7RLNC)
- +17 SET SUB="3,"_ISQN2_","_DDS_",1,0"
- +18 DO LAH(SUB,1,OBX11)
- +19 SET SUB="3,"_ISQN2_","_DDS_",1,1"
- +20 ; #4 IEN
- DO LAH(SUB,1,LA74)
- +21 SET X=$PIECE(LA7RO,"^",3)
- +22 ; resp observer
- DO LAH(SUB,2,X)
- +23 DO NTE
- +24 QUIT
- +25 ;
- +26 ;
- 16 ; Urine Screen (Subscript 1)
- +1 ;
- +2 NEW LAMSG,X,X2,Z
- +3 ;
- +4 SET X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
- +5 ;
- +6 ; convert SCT positive/negative code to local code
- +7 IF LA7SCT
- Begin DoDot:1
- +8 SET X2=$$SCT2PN^LA7VHLU6(LA7SCT,,"SCT",1)
- +9 IF X2'=""
- SET X=X2
- End DoDot:1
- +10 ;
- +11 ;
- Begin DoDot:1
- +12 NEW Z,LAMSG,LRNOECHO
- +13 SET LRNOECHO=1
- +14 DO CHK^DIE(63.05,11.57,"",X,.Z,"LAMSG")
- +15 IF $GET(Z)'="^"
- SET X=Z
- End DoDot:1
- +16 ;
- +17 SET DATAOK=$$DATAOK^LA7VIN7(63.05,11.57,X)
- +18 ;
- +19 SET SUB="1,0"
- +20 DO LAH(SUB,6,X)
- +21 ;
- +22 SET SUB="1,0,.02"
- +23 ; LOINC
- DO LAH(SUB,1,LA7RLNC)
- +24 SET SUB="1,0,.02,0"
- +25 ; Obsv Results
- DO LAH(SUB,1,OBX11)
- +26 SET SUB="1,0,.02,1"
- +27 DO LAH(SUB,1,LA74)
- +28 SET X=$PIECE(LA7RO,"^",3)
- +29 ; Resp Obsv.
- DO LAH(SUB,2,X)
- +30 DO NTE^LA7VIN71(LA76247,ISQN)
- +31 ;
- +32 QUIT
- +33 ;
- +34 ;
- 17 ; Sputum Screen (Subscript 1)
- +1 ;
- +2 NEW X,SUB,ISQN2,UNITS,DATAOK
- +3 ;
- +4 SET X=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
- +5 SET DATAOK=$$DATAOK^LA7VIN7(63.05,11.58,X)
- +6 ; Workaround 01/10/2007 (store anything in Set of Codes)
- +7 SET SUB="1,0"
- +8 DO LAH(SUB,5,X)
- +9 IF DATAOK
- DO LAH(SUB,5,X)
- +10 ;
- +11 SET SUB="1,0,.01"
- +12 ; LOINC
- DO LAH(SUB,1,LA7RLNC)
- +13 SET SUB="1,0,.01,0"
- +14 ; Obsv Results
- DO LAH(SUB,1,OBX11)
- +15 SET SUB="1,0,.01,1"
- +16 DO LAH(SUB,1,LA74)
- +17 SET X=$PIECE(LA7RO,"^",3)
- +18 ; Resp Obsv.
- DO LAH(SUB,2,X)
- +19 DO NTE^LA7VIN71(LA76247,ISQN)
- +20 ;
- +21 QUIT
- +22 ;
- +23 ;
- DDERR ;
- +1 ; If unknown storage location flag error
- +2 ; No File #63 field mapping found for OBX-3
- +3 NEW LA7OBX3
- +4 ;needed for log
- SET LA7OBX3=OBX3
- +5 DO CREATE^LA7LOG(201)
- +6 SET LA7KILAH=1
- SET LA7QUIT=2
- +7 QUIT
- +8 ;
- +9 ;
- LAH(LASUB,LAP,LAVAL) ;
- +1 ; Convenience method
- +2 IF LAP'=-1
- IF LAVAL=""
- QUIT
- +3 DO LAH^LAGEN(+$GET(LWL),+$GET(LA7ISQN),"MI",LASUB,LAP,LAVAL)
- +4 QUIT
- +5 ;
- +6 ;
- NTE ;
- +1 ; Convenience method
- +2 DO NTE^LA7VIN71(LA76247,ISQN2)
- +3 QUIT
- +4 ;
- +5 ;
- ABPREFIX(LA7TYPE,LA7DD) ; Get prefix of antibiotic full name to annotate comments.
- +1 ; Call with LA7TYPE = type of antimicrobial (1=bacterial, 2=mycobacterial)
- +2 ; LA7DD = drug node in file #63, MI subscript
- +3 ;
- +4 ; Returns LA7Y = drug abbreviation or full name from file #62.06
- +5 ;
- +6 NEW LA76206,LA7Y,LA7XREF
- +7 SET (LA76206,LA7Y)=""
- SET LA7TYPE=$GET(LA7TYPE)
- SET LA7DD=$PIECE($GET(LA7DD),";")
- +8 SET LA7XREF=$SELECT(LA7TYPE=1:"AD",LA7TYPE=2:"AD1",1:"")
- +9 ;
- +10 IF LA7XREF'=""
- IF LA7DD
- SET LA76206=$ORDER(^LAB(62.06,LA7XREF,LA7DD,0))
- +11 ;
- +12 IF LA76206
- Begin DoDot:1
- +13 SET LA76206(0)=$GET(^LAB(62.06,LA76206,0))
- +14 SET LA7Y="For "_$PIECE(LA76206(0),"^")_": "
- End DoDot:1
- +15 ;
- +16 QUIT LA7Y