Routine: LA7VIN71

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.

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

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)

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN71   5753     printed  Mar 13, 2025@20:45:11                                                                                                                                                                                                    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

LA7VIN71.m