LA7VIN71 ;DALOI/JDB - HANDLE ORU OBX FOR MICRO ;08/16/13 16:05
;;5.2;AUTOMATED LAB INSTRUMENTS;**74,80**;Sep 27, 1994;Build 19
;
; Continuation of LA7VIN7 and is only called from there.
; Process OBX segments for "MI" subscript tests.
Q
;
;
PROCESS ;
; File MI ^LAH for a given concept (LA76247)
; Called from OBX^LA7VIN7 for Micro data
; Major variables from LA7VIN7:
; DSOBX3,DSOBX5,LA76247,LA7SCT,OBX5,LA7612
;
N SUBID,PSUBID,DDS,DDP,LA7DD,LAX,RMK,CNCPTOR
S LA7DD=$$GET1^DID($P(DSOBX3,"^",3),$P($P(DSOBX3,"^",4),";"),"","GLOBAL SUBSCRIPT LOCATION")
S LA7DD("LABEL")=$$GET1^DID($P(DSOBX3,"^",3),$P($P(DSOBX3,"^",4),";"),"","LABEL")
S DDS=$P(LA7DD,";",1) ;DD Subscript
S DDP=$P(LA7DD,";",2) ;DD Piece
S:DDS="" DDS=-1
S:DDP="" DDP=-1
;
S SUBID=$G(OBX4)
S SUBID=$$UNESC^LA7VHLU3(SUBID,LA7FS_LA7ECH)
S SUBID=$$TRIM^XLFSTR(SUBID)
S SUBID=$$MAKEISO^LRVRMI1(LA74,SUBID)
S PSUBID=$$TRIM^XLFSTR($G(LAPSUBID))
S PSUBID=$$MAKEISO^LRVRMI1(LA74,PSUBID)
I SUBID="" S SUBID=PSUBID
;
I 'LA7612 D ; S LA7612=0 ;#61.2 IEN
. S LAX=$P(DSOBX5,"^",1)
. I $P(LAX,";",2)="LAB(61.2," S LA7612=$P(LAX,";",1)
;
; Need to override the concept?
S CNCPTOR=0
I OBX5[LA7CS,+DSOBX5=-1 D
. S LAX=$P(DSOBX5,"^",5)
. I LAX,LAX'=LA76247 S CNCPTOR=1,LA76247=LAX
;
;
; Override LOINC codes to handle fact that some generic codes can be applied to more than one storage location.
;
; Check if URINE or SPUTUM SCREEN and use VA NLT to find concept
; - URINE and SPUTUM SCREEN uses same LOINC code for organsimn identified (positive/negative culture)
I LA76247=3,$G(OBX3(6))="99VA64",$P(OBX3(4),".")?1(1"93948",1"93949") D
. N X
. S X=$$HL2LAH^LA7VHLU6(OBX3(4),OBX3(5),OBX3(6),OBX3(8),LA76248,"MI")
. I X>0 S LA76247=+X
;
; COLONY COUNT used for ORGANISM(sub=3,6247=10), FUNGUS/YEAST(sub=9,6247=11) and MYCOBACTERIUM(sub=12,6247=20)
; Get previous ^LAH node used by using the whole record subid C xref
I LA7RLNC="564-5" D
. N SUB
. S SUB=$O(^LAH(LWL,1,ISQN,"MI","C",SUBID,0))
. I SUB>0 S LA76247=$S(SUB=3:10,SUB=9:11,SUB=12:20,1:LA76247)
;
; Check if VA AFB quantity and use VA NLT to find concept - AFB Stain and AFB Quantity use same LOINC code.
I LA76247=79,$G(OBX3(6))="99VA64",$P(OBX3(4),".")="87583" D
. N X
. S X=$$HL2LAH^LA7VHLU6(OBX3(4),OBX3(5),OBX3(6),OBX3(8),LA76248,"MI")
. I X>0 S LA76247=+X
;
; Check if Organism should be stored under Bacteriology section instead of MI section determined by OBX-3 mapping.
; Used in cases where a Parasite, Fungus, Mycobacterium, or Virus was reported on a Bacterial culture.
S LA76247=$$BACTCHK^LA7VHLUB(LA7ONLT,LA7AA,LA7AD,LA7AN,LA76247)
;
;
I LA76247=1 D 1^LA7VIN7A Q ;subscr 2
I LA76247=3 D 3^LA7VIN7A Q ;subscr 3
I LA76247=4 D 4^LA7VIN7B Q ;subscr 12
I LA76247=5 D 5^LA7VIN7C Q ;subscr 17
I LA76247=6 D Q ; subscr 4
. I 'CNCPTOR D 6^LA7VIN7A()
. I CNCPTOR D 6^LA7VIN7A($$BLDRMK())
I LA76247=7 D 7^LA7VIN7A Q ;subscr 3
I LA76247=8 D 8^LA7VIN7D Q ;subscr 6
I LA76247=9 D 9^LA7VIN7B Q ;subscr 9
I LA76247=10 D 10^LA7VIN7A Q ;subscr 3
I LA76247=11 D 11^LA7VIN7B Q ;subscr 9
I LA76247=12 D 12^LA7VIN7D() Q ;subscr 7
I LA76247=13 D 13^LA7VIN7D Q ;subscr 6
I LA76247=14 D 14^LA7VIN7D Q ;subscr 6
I LA76247=15 D 15^LA7VIN7B() Q ;subscr 10
I LA76247=16 D 16^LA7VIN7A Q ; subscr 1
I LA76247=17 D 17^LA7VIN7A Q ; subscr 1
I LA76247=20 D 20^LA7VIN7B Q ;subscr 12
I LA76247=21 D 21^LA7VIN7B Q ;subscr 12
I LA76247=22 D 22^LA7VIN7C() Q ;subscr 13
I LA76247=30 D 30^LA7VIN7C() Q ;subscr 18
;
I LA76247>39,LA76247<48 D NODE^LA7VIN7C(LA76247,"") Q
;
I LA76247=48 D 48^LA7VIN7C Q ;subscr 31
I LA76247=79 D 79^LA7VIN7B Q ;subscr 11
I LA76247=85 D 85^LA7VIN7B Q ;subscr 11
;
I LA76247>85,LA76247<91 D NODE^LA7VIN7C(LA76247,"") Q
;
;
; If we get this far then something went wrong
; Error: No filing method found for OBX
D ;
. N LA7VOBX3
. S LA7VOBX3=OBX3
. D CREATE^LA7LOG(202)
. S LA7KILAH=1 S LA7QUIT=2
;
Q
;
;
BLDRMK() ;
; Constructs comment/remarks for special situations like
; processing an OBX5 with flora normal (which gets filed as a
; Bact RPT REMARK).
;
; If there's an SCT code:
; [SUBID]SCT Text
;
; If no SCT code:
; If OBX5 contains HL7 component sep, 2nd piece of first tuplet
; else its the full OBX5 text
; [SUBID]OBX5 text
;
N X,TXT,SID
S X=SUBID
S:X="" X=$G(PSUBID)
S:X'="" X="["_X_"]"
S SID=X
S TXT=""
I LA7SCT'="" D ;
. N SCT
. S X=$$CODE^LRSCT(LA7SCT,"SCT",,"SCT")
. S TXT=$G(SCT("P"))
. S:TXT="" TXT=$G(SCT("F"))
. I TXT="" D ;
. . N DATA,CODSYS
. . S DATA=OBX5
. . D FLD2ARR^LA7VHLU7(.DATA)
. . D CODSYS^LA7VHLU7(.DATA,.CODSYS,"SCT")
. . S TXT=$G(CODSYS(2))
. . K DATA,CODSYS
. S:TXT="" TXT="SCT:"_LA7SCT
I LA7SCT="" D ;
. I OBX5[LA7CS S TXT=$P(OBX5,LA7CS,2)
. I TXT="" S TXT=OBX5
. S TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
Q SID_TXT
;
;
STRSPLIT(STR,MAXLEN,OUT) ;
; Splits a string into substrings no more than MAXLEN long
; Useful when storing things such as COMMENT fields
N I,Y,SUBS
S SUBS=$L(STR)\MAXLEN
S:($L(STR)#MAXLEN)>0 SUBS=SUBS+1
F I=0:1:SUBS-1 S Y=(I*MAXLEN)+1 D ;
. S OUT(I+1)=$E(STR,Y,(Y+MAXLEN)-1)
. S Y=Y+MAXLEN
Q SUBS
;
;
NTE(R6247,I,PREFIX) ;
; Set variable for HL7 NTE processing
; Inputs
; R6247 : #62.47 IEN (Concept)
; I : Usually either ISQN or ISQN2
; PREFIX : text of prefix (optional)
S LA7RMK(0,0)=R6247_"^"_I_"^"_$G(PREFIX)
Q
;
;
SUBIDERR ;
; Error handler when subid (OBX4) is null or unknown
N LA7VOBX3,LA7VOBX4
S LA7VOBX3=OBX3
S LA7VOBX4=OBX4
D CREATE^LA7LOG(205)
S LA7KILAH=1 S LA7QUIT=2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN71 5753 printed Apr 09, 2024@20:43:52 Page 2
LA7VIN71 ;DALOI/JDB - HANDLE ORU OBX FOR MICRO ;08/16/13 16:05
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74,80**;Sep 27, 1994;Build 19
+2 ;
+3 ; Continuation of LA7VIN7 and is only called from there.
+4 ; Process OBX segments for "MI" subscript tests.
+5 QUIT
+6 ;
+7 ;
PROCESS ;
+1 ; File MI ^LAH for a given concept (LA76247)
+2 ; Called from OBX^LA7VIN7 for Micro data
+3 ; Major variables from LA7VIN7:
+4 ; DSOBX3,DSOBX5,LA76247,LA7SCT,OBX5,LA7612
+5 ;
+6 NEW SUBID,PSUBID,DDS,DDP,LA7DD,LAX,RMK,CNCPTOR
+7 SET LA7DD=$$GET1^DID($PIECE(DSOBX3,"^",3),$PIECE($PIECE(DSOBX3,"^",4),";"),"","GLOBAL SUBSCRIPT LOCATION")
+8 SET LA7DD("LABEL")=$$GET1^DID($PIECE(DSOBX3,"^",3),$PIECE($PIECE(DSOBX3,"^",4),";"),"","LABEL")
+9 ;DD Subscript
SET DDS=$PIECE(LA7DD,";",1)
+10 ;DD Piece
SET DDP=$PIECE(LA7DD,";",2)
+11 if DDS=""
SET DDS=-1
+12 if DDP=""
SET DDP=-1
+13 ;
+14 SET SUBID=$GET(OBX4)
+15 SET SUBID=$$UNESC^LA7VHLU3(SUBID,LA7FS_LA7ECH)
+16 SET SUBID=$$TRIM^XLFSTR(SUBID)
+17 SET SUBID=$$MAKEISO^LRVRMI1(LA74,SUBID)
+18 SET PSUBID=$$TRIM^XLFSTR($GET(LAPSUBID))
+19 SET PSUBID=$$MAKEISO^LRVRMI1(LA74,PSUBID)
+20 IF SUBID=""
SET SUBID=PSUBID
+21 ;
+22 ; S LA7612=0 ;#61.2 IEN
IF 'LA7612
Begin DoDot:1
+23 SET LAX=$PIECE(DSOBX5,"^",1)
+24 IF $PIECE(LAX,";",2)="LAB(61.2,"
SET LA7612=$PIECE(LAX,";",1)
End DoDot:1
+25 ;
+26 ; Need to override the concept?
+27 SET CNCPTOR=0
+28 IF OBX5[LA7CS
IF +DSOBX5=-1
Begin DoDot:1
+29 SET LAX=$PIECE(DSOBX5,"^",5)
+30 IF LAX
IF LAX'=LA76247
SET CNCPTOR=1
SET LA76247=LAX
End DoDot:1
+31 ;
+32 ;
+33 ; Override LOINC codes to handle fact that some generic codes can be applied to more than one storage location.
+34 ;
+35 ; Check if URINE or SPUTUM SCREEN and use VA NLT to find concept
+36 ; - URINE and SPUTUM SCREEN uses same LOINC code for organsimn identified (positive/negative culture)
+37 IF LA76247=3
IF $GET(OBX3(6))="99VA64"
IF $PIECE(OBX3(4),".")?1(1"93948",1"93949")
Begin DoDot:1
+38 NEW X
+39 SET X=$$HL2LAH^LA7VHLU6(OBX3(4),OBX3(5),OBX3(6),OBX3(8),LA76248,"MI")
+40 IF X>0
SET LA76247=+X
End DoDot:1
+41 ;
+42 ; COLONY COUNT used for ORGANISM(sub=3,6247=10), FUNGUS/YEAST(sub=9,6247=11) and MYCOBACTERIUM(sub=12,6247=20)
+43 ; Get previous ^LAH node used by using the whole record subid C xref
+44 IF LA7RLNC="564-5"
Begin DoDot:1
+45 NEW SUB
+46 SET SUB=$ORDER(^LAH(LWL,1,ISQN,"MI","C",SUBID,0))
+47 IF SUB>0
SET LA76247=$SELECT(SUB=3:10,SUB=9:11,SUB=12:20,1:LA76247)
End DoDot:1
+48 ;
+49 ; Check if VA AFB quantity and use VA NLT to find concept - AFB Stain and AFB Quantity use same LOINC code.
+50 IF LA76247=79
IF $GET(OBX3(6))="99VA64"
IF $PIECE(OBX3(4),".")="87583"
Begin DoDot:1
+51 NEW X
+52 SET X=$$HL2LAH^LA7VHLU6(OBX3(4),OBX3(5),OBX3(6),OBX3(8),LA76248,"MI")
+53 IF X>0
SET LA76247=+X
End DoDot:1
+54 ;
+55 ; Check if Organism should be stored under Bacteriology section instead of MI section determined by OBX-3 mapping.
+56 ; Used in cases where a Parasite, Fungus, Mycobacterium, or Virus was reported on a Bacterial culture.
+57 SET LA76247=$$BACTCHK^LA7VHLUB(LA7ONLT,LA7AA,LA7AD,LA7AN,LA76247)
+58 ;
+59 ;
+60 ;subscr 2
IF LA76247=1
DO 1^LA7VIN7A
QUIT
+61 ;subscr 3
IF LA76247=3
DO 3^LA7VIN7A
QUIT
+62 ;subscr 12
IF LA76247=4
DO 4^LA7VIN7B
QUIT
+63 ;subscr 17
IF LA76247=5
DO 5^LA7VIN7C
QUIT
+64 ; subscr 4
IF LA76247=6
Begin DoDot:1
+65 IF 'CNCPTOR
DO 6^LA7VIN7A()
+66 IF CNCPTOR
DO 6^LA7VIN7A($$BLDRMK())
End DoDot:1
QUIT
+67 ;subscr 3
IF LA76247=7
DO 7^LA7VIN7A
QUIT
+68 ;subscr 6
IF LA76247=8
DO 8^LA7VIN7D
QUIT
+69 ;subscr 9
IF LA76247=9
DO 9^LA7VIN7B
QUIT
+70 ;subscr 3
IF LA76247=10
DO 10^LA7VIN7A
QUIT
+71 ;subscr 9
IF LA76247=11
DO 11^LA7VIN7B
QUIT
+72 ;subscr 7
IF LA76247=12
DO 12^LA7VIN7D()
QUIT
+73 ;subscr 6
IF LA76247=13
DO 13^LA7VIN7D
QUIT
+74 ;subscr 6
IF LA76247=14
DO 14^LA7VIN7D
QUIT
+75 ;subscr 10
IF LA76247=15
DO 15^LA7VIN7B()
QUIT
+76 ; subscr 1
IF LA76247=16
DO 16^LA7VIN7A
QUIT
+77 ; subscr 1
IF LA76247=17
DO 17^LA7VIN7A
QUIT
+78 ;subscr 12
IF LA76247=20
DO 20^LA7VIN7B
QUIT
+79 ;subscr 12
IF LA76247=21
DO 21^LA7VIN7B
QUIT
+80 ;subscr 13
IF LA76247=22
DO 22^LA7VIN7C()
QUIT
+81 ;subscr 18
IF LA76247=30
DO 30^LA7VIN7C()
QUIT
+82 ;
+83 IF LA76247>39
IF LA76247<48
DO NODE^LA7VIN7C(LA76247,"")
QUIT
+84 ;
+85 ;subscr 31
IF LA76247=48
DO 48^LA7VIN7C
QUIT
+86 ;subscr 11
IF LA76247=79
DO 79^LA7VIN7B
QUIT
+87 ;subscr 11
IF LA76247=85
DO 85^LA7VIN7B
QUIT
+88 ;
+89 IF LA76247>85
IF LA76247<91
DO NODE^LA7VIN7C(LA76247,"")
QUIT
+90 ;
+91 ;
+92 ; If we get this far then something went wrong
+93 ; Error: No filing method found for OBX
+94 ;
Begin DoDot:1
+95 NEW LA7VOBX3
+96 SET LA7VOBX3=OBX3
+97 DO CREATE^LA7LOG(202)
+98 SET LA7KILAH=1
SET LA7QUIT=2
End DoDot:1
+99 ;
+100 QUIT
+101 ;
+102 ;
BLDRMK() ;
+1 ; Constructs comment/remarks for special situations like
+2 ; processing an OBX5 with flora normal (which gets filed as a
+3 ; Bact RPT REMARK).
+4 ;
+5 ; If there's an SCT code:
+6 ; [SUBID]SCT Text
+7 ;
+8 ; If no SCT code:
+9 ; If OBX5 contains HL7 component sep, 2nd piece of first tuplet
+10 ; else its the full OBX5 text
+11 ; [SUBID]OBX5 text
+12 ;
+13 NEW X,TXT,SID
+14 SET X=SUBID
+15 if X=""
SET X=$GET(PSUBID)
+16 if X'=""
SET X="["_X_"]"
+17 SET SID=X
+18 SET TXT=""
+19 ;
IF LA7SCT'=""
Begin DoDot:1
+20 NEW SCT
+21 SET X=$$CODE^LRSCT(LA7SCT,"SCT",,"SCT")
+22 SET TXT=$GET(SCT("P"))
+23 if TXT=""
SET TXT=$GET(SCT("F"))
+24 ;
IF TXT=""
Begin DoDot:2
+25 NEW DATA,CODSYS
+26 SET DATA=OBX5
+27 DO FLD2ARR^LA7VHLU7(.DATA)
+28 DO CODSYS^LA7VHLU7(.DATA,.CODSYS,"SCT")
+29 SET TXT=$GET(CODSYS(2))
+30 KILL DATA,CODSYS
End DoDot:2
+31 if TXT=""
SET TXT="SCT:"_LA7SCT
End DoDot:1
+32 ;
IF LA7SCT=""
Begin DoDot:1
+33 IF OBX5[LA7CS
SET TXT=$PIECE(OBX5,LA7CS,2)
+34 IF TXT=""
SET TXT=OBX5
+35 SET TXT=$$UNESC^LA7VHLU3(TXT,LA7FS_LA7ECH)
End DoDot:1
+36 QUIT SID_TXT
+37 ;
+38 ;
STRSPLIT(STR,MAXLEN,OUT) ;
+1 ; Splits a string into substrings no more than MAXLEN long
+2 ; Useful when storing things such as COMMENT fields
+3 NEW I,Y,SUBS
+4 SET SUBS=$LENGTH(STR)\MAXLEN
+5 if ($LENGTH(STR)#MAXLEN)>0
SET SUBS=SUBS+1
+6 ;
FOR I=0:1:SUBS-1
SET Y=(I*MAXLEN)+1
Begin DoDot:1
+7 SET OUT(I+1)=$EXTRACT(STR,Y,(Y+MAXLEN)-1)
+8 SET Y=Y+MAXLEN
End DoDot:1
+9 QUIT SUBS
+10 ;
+11 ;
NTE(R6247,I,PREFIX) ;
+1 ; Set variable for HL7 NTE processing
+2 ; Inputs
+3 ; R6247 : #62.47 IEN (Concept)
+4 ; I : Usually either ISQN or ISQN2
+5 ; PREFIX : text of prefix (optional)
+6 SET LA7RMK(0,0)=R6247_"^"_I_"^"_$GET(PREFIX)
+7 QUIT
+8 ;
+9 ;
SUBIDERR ;
+1 ; Error handler when subid (OBX4) is null or unknown
+2 NEW LA7VOBX3,LA7VOBX4
+3 SET LA7VOBX3=OBX3
+4 SET LA7VOBX4=OBX4
+5 DO CREATE^LA7LOG(205)
+6 SET LA7KILAH=1
SET LA7QUIT=2
+7 QUIT
