LA7VHLU6 ;DALOI/JMC - HL7 Code Sets utility ;08/10/16 13:30
;;5.2;AUTOMATED LAB INSTRUMENTS;**74,90**;Sep 27, 1994;Build 17
;
; Utility to resolve SNOMED CT, LOINC and local codes.
;
Q
;
IEN2SCT(FILE,IEN,DATE,LA7ALT) ; Return SCT code for a given file entry
; Call with FILE = file #
; IEN = internal entry number in FILE
; DATE = as of date
; LA7ALT = SNOMED CT ID to use as alternate
;
; Returns LA7Y = SNOMED CT code (Code^Code Text^Code System^Version^Error Code^Error Text)
;
N LA7FIELD,LA7SCT,LA7X,LA7Y,LA7Z,X,Y
S LA7Y="",FILE=+$G(FILE),IEN=+$G(IEN),LA7ALT=$G(LA7ALT)
;
; If entry mapped to SNOMED CT then retrieve code info from Lexicon.
S LA7FIELD=$S(FILE=61:20,FILE=61.2:20,FILE=62:20,1:20)
I LA7ALT'="" S LA7X=LA7ALT
E S LA7X=$$GET1^DIQ(FILE,IEN_",",LA7FIELD)
I LA7X D
. S LA7Z=$$CODE^LEXTRAN(LA7X,"SCT",DATE,"LA7SCT")
. I LA7Z>0 S LA7Y=$P(LA7SCT(0),"^")_"^"_LA7SCT("F")_"^SCT^"_$P(LA7SCT(0),"^",3) Q
. S $P(LA7Y,"^",5,6)=$P(LA7Z,"^",1,2) ; return error code/text in 5th/6th pieces
. I $P(LA7Z,"^")=-1 Q
. I $P(LA7Z,"^")=-2 Q
. I $P(LA7Z,"^")=-4 D Q
. . S $P(LA7Y,"^",1,4)=$P(LA7SCT(0),"^")_"^"_$G(LA7SCT("F"))_"^SCT^"_$P(LA7SCT(0),"^",3)
. . S X=$P(LA7Z,"not active for ",2)
. . I X?1(7N,7N1"."1.N) S $P(LA7Y,"not active for ",2)=$$FMTE^XLFDT(X,"MZ")
. I $P(LA7Z,"^")=-8 D Q
. . S X=+$P(LA7Z," ",2)
. . I X?1(7N,7N1"."1.N) S $P(LA7Y," ",2)=$$FMTE^XLFDT(X,"MZ")
. . I DATE=DT Q
. . N LA7Z,LA7SCT
. . S LA7Z=$$CODE^LEXTRAN(LA7X,"SCT",DT,"LA7SCT")
. . I LA7Z>0 S $P(LA7Y,"^",1,4)=$P(LA7SCT(0),"^")_"^"_LA7SCT("F")_"^SCT^"_$P(LA7SCT(0),"^",3)
;
Q LA7Y
;
;
SCT2IEN(CODE,TEXT,VERSION,FILE,LA76247,LA76248) ; Return file ien for a given SNOMED CT code
; Call with CODE = SNOMED CT code
; TEXT = code text
; VERSION = code system version
; FILE = destination VistA file # (file where the SCT term resides)
; LA76247 = ien of concept to screen on
; LA76248 = related Lab Messaging configuration for non-standard code lookup (optional)
; used when code is only for a specific interface
;
; Returns LA7IEN = file internal entry number
;
N LA7CNT,LA7IEN,LA7X,LA7Y
S (LA7CNT,LA7X)=0,LA7IEN=""
F S LA7X=$O(^LAB(FILE,"F",CODE,LA7X)) Q:'LA7X S LA7CNT=LA7CNT+1,LA7IEN=LA7X,LA7Y(LA7X)=^LAB(FILE,LA7X,"SCT")
;
; If multiple entries mapped then check for closest match
; - try P if no P then try S or L for text match
; - if none then select S
; - if none then select L
I LA7CNT>1 D
. N LA7QUIT
. S TEXT=$$UP^XLFSTR(TEXT)
. S (LA7QUIT,LA7X)=0
. F S LA7X=$O(LA7Y(LA7X)) Q:'LA7X D Q:LA7QUIT
. . S LA7IEN=LA7X
. . I $P(LA7Y(LA7X),"^",2)="P" S LA7QUIT=1 Q
. . I $P(LA7Y(LA7X),"^",2)?1(1"S",1"L"),TEXT=$$UP^XLFSTR($P(^LAB(FILE,LA7X,0),"^")) S LA7QUIT=1
. I LA7QUIT Q
. S (LA7IEN,LA7X)=0
. F S LA7X=$O(LA7Y(LA7X)) Q:'LA7X D
. . I $P(LA7Y(LA7X),"^",2)="S" S LA7IEN=LA7X
. . I 'LA7IEN,$P(LA7Y(LA7X),"^",2)="L" S LA7IEN=LA7X
;
;
Q LA7IEN
;
;
HL2LAH(CODE,TEXT,NCS,VERSION,LA76248,LA7SS) ; Determine storage location for a code system sent in OBX-3
; Call with CODE = code id
; TEXT = code text
; NCS = name of coding system (LOINC, NLT, SCT, 99xxx, L)
; VERSION = code system version id
; LA76248 = related Lab Messaging configuration for non-standard code lookup (optional)
; used when code is only for a specific interface
; LA7SS = specific lab subscript to screen standard codes - used when same code used in multiple areas
;
; Returns LA7Y = CONCEPT^SUBSCRIPT^FILE/SUBFILE^FIELD NUMBER^SCT HIERARCHY
;
N DA,LA76247,LA764,LA764061,LA7ROOT,LA7X,LA7Y,LOCAL,X,Y
S (DA,DA(1),LA7Y,LA76247)="",LA7SS=$G(LA7SS),LA764061=0
S LOCAL=$S(NCS="99VA64":0,NCS="L":1,$E(NCS,1,2)="99":1,1:0)
;
; Check for subscript specific code first.
; If VA NLT suffixed code and not in x-ref then try non-suffixed version of code.
I LA7SS'="" D
. S LA7ROOT=$Q(^LAB(62.47,"AC2",LA7SS,NCS,CODE))
. I LA7ROOT="",NCS="99VA64",CODE#1 S CODE=$P(CODE,".")_".0000",LA7ROOT=$Q(^LAB(62.47,"AC2",LA7SS,NCS,CODE))
. I LA7ROOT'="",$QS(LA7ROOT,2)="AC2",$QS(LA7ROOT,3)=LA7SS,$QS(LA7ROOT,4)=NCS,$QS(LA7ROOT,5)=CODE D
. . S LA764061=$QS(LA7ROOT,6),(DA(1),LA7Y)=$QS(LA7ROOT,7)
. . I LA764061 S LA7Y=LA7Y_"^"_$P($G(^LAB(64.061,LA764061,63)),"^",1,4)
. . S DA=$QS(LA7ROOT,8)
. . I $P(^LAB(62.47,DA(1),1,DA,0),"^",4) D LAHOVR S $P(LA7Y,"^",6)=$QS(LA7ROOT,7)
;
; Check for non-subscript specific code
; If VA NLT suffixed code and not in x-ref then try non-suffixed version of code.
I LA7Y="" D
. S LA7ROOT=$Q(^LAB(62.47,"AC",NCS,CODE))
. I LA7ROOT="",NCS="99VA64",CODE#1 S CODE=$P(CODE,".")_".0000",LA7ROOT=$Q(^LAB(62.47,"AC",NCS,CODE))
. I LA7ROOT'="",$QS(LA7ROOT,2)="AC",$QS(LA7ROOT,3)=NCS,$QS(LA7ROOT,4)=CODE D
. . S LA764061=$QS(LA7ROOT,5),(DA(1),LA7Y)=$QS(LA7ROOT,6)
. . I LA764061 S LA7Y=LA7Y_"^"_$P($G(^LAB(64.061,LA764061,63)),"^",1,4)
. . S DA=$QS(LA7ROOT,7)
. . I $P(^LAB(62.47,DA(1),1,DA,0),"^",4) D LAHOVR S $P(LA7Y,"^",6)=$QS(LA7ROOT,6)
;
; If for a specific interface
I LA76248 D
. S LA7ROOT=$Q(^LAB(62.47,"AC1",LA76248,NCS,CODE))
. I LA7ROOT'="",$QS(LA7ROOT,2)="AC1",$QS(LA7ROOT,3)=LA76248,$QS(LA7ROOT,4)=NCS,$QS(LA7ROOT,5)=CODE D
. . S LA764061=$QS(LA7ROOT,6),(DA(1),LA7Y)=$QS(LA7ROOT,7)
. . I LA764061 S LA7Y=LA7Y_"^"_$P($G(^LAB(64.061,LA764061,63)),"^",1,4)
. . S DA=$QS(LA7ROOT,8)
. . I $P(^LAB(62.47,DA(1),1,DA,0),"^",4) D LAHOVR S $P(LA7Y,"^",6)=$QS(LA7ROOT,7)
;
; Set bacterial/mycobacteria susceptibility field
I LA764061=9332!(LA764061=9333) D
. S LA7X=$G(^LAB(62.47,DA(1),1,DA,2))
. I $P($P(LA7X,"^"),";",2)'="LAB(62.06," Q
. S X=$G(^LAB(62.06,+LA7X,0))
. I LA764061=9332,$P(X,"^",4) S $P(LA7Y,"^",4)=$P(X,"^",4) Q
. I LA764061=9333,$P(X,"^",8) S $P(LA7Y,"^",4)=$P(X,"^",8)
;
; If code system is SNOMED CT
; Currently VistA should not receive a SNOMED CT code in an OBX-3 field.
I NCS="SCT" D
. Q
;
Q LA7Y
;
;
LAHOVR ; Override HL2LAH concept code mapping.
;ZEXCEPT: DA,LA76247,LA764061,LA7Y
;
S LA76247=$P(^LAB(62.47,DA(1),1,DA,0),"^",4)
S LA764061=$P(^LAB(62.47,LA76247,0),"^",3)
S LA7Y=LA76247_"^"_$G(^LAB(64.061,LA764061,63))
Q
;
;
ALCONCPT(LA76247) ; Determine alternate concept for a concept
; Call with LA76247 = ien of concept
;
; Returns LACONPT = alternate concept
;
N LACONCPT
S LACONCPT=""
I $G(LA76247)>0 S LACONCPT=+$P($G(^LAB(62.47,LA76247,0)),"^",4)
Q LACONCPT
;
;
PRID(CODE,NCS,LA764061) ; Determine if a code represents the presence/absence or the identity of a concept in OBX-5
; Used to determine if identity of organism or presence/absence
; Call with CODE = code id
; NCS = name of coding system
; LA64061 = related Lab database code
;
; Returns LA7Y = hierarchy of the code ^ related VistA file
;
N LA7Y,LA7X
S LA7Y=""
;
; If code system is SNOMED CT
I NCS="SCT" D
. S LA7Y=$$GET1^DIQ(64.061,LA764061_",",63.3)
. S LA7X=$$GET1^DIQ(64.061,LA764061_",",63.3,"I")
. I LA7X S $P(LA7Y,"^",2)=$P($G(^LAB(64.061,LA7X,63)),"^",5)
;
Q LA7Y
;
;
HL2VA(CODE,TEXT,NCS,VERSION,LA76247,LA76248) ; Resolve code to internal VA file entry, used to resolve value of OBX-5 coded entry
; Call with CODE = code id
; NCS = name of coding system (SCT, 99xxx, L)
; TEXT = code text
; VERSION = code system version id
; LA76247 = ien of concept to screen on
; LA76248 = related Lab Messaging configuration for non-standard code lookup (optional)
; used when code is only for a specific interface
;
; Returns LA7Y = variable pointer format^database storage location
; OR
; -1^^^^ien of override concept (if override concept)
;
N DA,LA764061,LA7FILE,LA7HIER,LA7ROOT,LA7X,LA7Y,LOCAL,X,Y
S LA76247=$G(LA76247)
I 'LA76247 Q 0
S LA7FILE=""
S LOCAL=$S(NCS="L":1,$E(NCS,1,2)="99":1,1:0)
S LA764061=$P($G(^LAB(62.47,LA76247,0)),"^",3),LA7Y="^"_$P($G(^LAB(64.061,LA764061,63)),"^",1,3)
;
; If code system is SNOMED CT
I NCS="SCT" D
. S LA7ROOT=$Q(^LAB(62.47,"AD",LA76247,NCS,CODE))
. I LA7ROOT'="",$QS(LA7ROOT,2)="AD",$QS(LA7ROOT,3)=LA76247,$QS(LA7ROOT,4)=NCS,$QS(LA7ROOT,5)=CODE D Q
. . S X=$QS(LA7ROOT,6)
. . I X S LA7Y="-1^^^^"_X
. I $S(LA76247=7:1,LA76247=21:1,1:0) S LA7Y=$$SCT2KB(CODE,TEXT,NCS,VERSION) D Q
. . I LA7Y="" S LA7Y=$$SCT2PN(CODE,TEXT,NCS,VERSION)
. S LA7HIER=$$PRID(CODE,NCS,LA764061)
. S LA7FILE=$P(LA7HIER,"^",2)
. I LA7FILE S LA7Y=$$SCT2IEN(CODE,TEXT,VERSION,LA7FILE,LA76247,LA76248)_";"_$P($$ROOT^DILFD(LA7FILE),"^",2)_LA7Y
;
; If code system is LOCAL (HL7 "L" OR "99XXX") and for a specific interface
I LOCAL,LA76248 D
. S LA7ROOT=$Q(^LAB(62.47,"AD1",LA76247,LA76248,NCS,CODE)),LA764061=0
. I LA7ROOT="" Q
. I $QS(LA7ROOT,2)="AD1",$QS(LA7ROOT,3)=LA76247,$QS(LA7ROOT,4)=LA76248,$QS(LA7ROOT,5)=NCS,$QS(LA7ROOT,6)=CODE D
. . S LA764061=$QS(LA7ROOT,7),DA=$QS(LA7ROOT,8)
. . S X=$P(^LAB(62.47,LA76247,1,DA,0),"^",4)
. . I X S LA7Y="-1^^^^"_X Q
. . S LA7FILE=$P($G(^LAB(62.47,LA76247,1,DA,2)),"^")
. . I LA7FILE S LA7Y=LA7FILE
. . I LA764061 S LA7Y=LA7Y_"^"_$P($G(^LAB(64.061,LA764061,63)),"^",1,3)
;
Q LA7Y
;
;
SCT2KB(CODE,TEXT,NCS,VERSION) ; Convert Susceptibility codes to local codes.
; Call with CODE = susceptibility code
; TEXT = code text
; NCS = name of coding system (SCT, 99xxx, L)
; VERSION = code system version id
;
; Returns LA7Y = local susceptibility code
;
N LA7Y
S LA7Y=""
I NCS="SCT" S LA7Y=$S(CODE=131196009:"S",CODE=260357007:"MS",CODE=30714006:"R",CODE=264841006:"I",1:"")
;
; Convert local codes
I $S(NCS="L":1,$E(NCS,1,2)="99":1,1:0) S LA7Y=TEXT
;
Q LA7Y
;
;
SCT2PSTG(CODE,TEXT,NCS,VERSION) ; Convert Parasite Stage codes to local codes.
; Call with CODE = parasite stage code
; TEXT = code text
; NCS = name of coding system (SCT, 99xxx, L)
; VERSION = code system version id
;
; Returns LA7Y = local parasite stage code
;
N LA7Y
S LA7Y=""
I NCS="SCT" S LA7Y=$S(CODE=103551003:"T",CODE=103552005:"C",CODE=116990009:"E",CODE=48458007:"L",CODE=284701003:"S",CODE=103537003:"G",CODE=2105009:"M",CODE=103568004:"R",CODE=2105009:"F",1:"")
Q LA7Y
;
;
SCT2PN(CODE,TEXT,NCS,VERSION) ; Convert Positive/Negative to local codes.
; Call with CODE = positive/negative
; TEXT = code text
; NCS = name of coding system (SCT, 99xxx, L)
; VERSION = code system version id
;
; Returns LA7Y = local positive/negative code
;
N LA7Y
S LA7Y=""
I NCS="SCT" S LA7Y=$S(CODE=10828004:"P",CODE=260385009:"N",1:"")
;
; Convert local codes
I $S(NCS="L":1,$E(NCS,1,2)="99":1,1:0) S LA7Y=TEXT
;
Q LA7Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VHLU6 10998 printed Dec 13, 2024@01:40:12 Page 2
LA7VHLU6 ;DALOI/JMC - HL7 Code Sets utility ;08/10/16 13:30
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74,90**;Sep 27, 1994;Build 17
+2 ;
+3 ; Utility to resolve SNOMED CT, LOINC and local codes.
+4 ;
+5 QUIT
+6 ;
IEN2SCT(FILE,IEN,DATE,LA7ALT) ; Return SCT code for a given file entry
+1 ; Call with FILE = file #
+2 ; IEN = internal entry number in FILE
+3 ; DATE = as of date
+4 ; LA7ALT = SNOMED CT ID to use as alternate
+5 ;
+6 ; Returns LA7Y = SNOMED CT code (Code^Code Text^Code System^Version^Error Code^Error Text)
+7 ;
+8 NEW LA7FIELD,LA7SCT,LA7X,LA7Y,LA7Z,X,Y
+9 SET LA7Y=""
SET FILE=+$GET(FILE)
SET IEN=+$GET(IEN)
SET LA7ALT=$GET(LA7ALT)
+10 ;
+11 ; If entry mapped to SNOMED CT then retrieve code info from Lexicon.
+12 SET LA7FIELD=$SELECT(FILE=61:20,FILE=61.2:20,FILE=62:20,1:20)
+13 IF LA7ALT'=""
SET LA7X=LA7ALT
+14 IF '$TEST
SET LA7X=$$GET1^DIQ(FILE,IEN_",",LA7FIELD)
+15 IF LA7X
Begin DoDot:1
+16 SET LA7Z=$$CODE^LEXTRAN(LA7X,"SCT",DATE,"LA7SCT")
+17 IF LA7Z>0
SET LA7Y=$PIECE(LA7SCT(0),"^")_"^"_LA7SCT("F")_"^SCT^"_$PIECE(LA7SCT(0),"^",3)
QUIT
+18 ; return error code/text in 5th/6th pieces
SET $PIECE(LA7Y,"^",5,6)=$PIECE(LA7Z,"^",1,2)
+19 IF $PIECE(LA7Z,"^")=-1
QUIT
+20 IF $PIECE(LA7Z,"^")=-2
QUIT
+21 IF $PIECE(LA7Z,"^")=-4
Begin DoDot:2
+22 SET $PIECE(LA7Y,"^",1,4)=$PIECE(LA7SCT(0),"^")_"^"_$GET(LA7SCT("F"))_"^SCT^"_$PIECE(LA7SCT(0),"^",3)
+23 SET X=$PIECE(LA7Z,"not active for ",2)
+24 IF X?1(7N,7N1"."1.N)
SET $PIECE(LA7Y,"not active for ",2)=$$FMTE^XLFDT(X,"MZ")
End DoDot:2
QUIT
+25 IF $PIECE(LA7Z,"^")=-8
Begin DoDot:2
+26 SET X=+$PIECE(LA7Z," ",2)
+27 IF X?1(7N,7N1"."1.N)
SET $PIECE(LA7Y," ",2)=$$FMTE^XLFDT(X,"MZ")
+28 IF DATE=DT
QUIT
+29 NEW LA7Z,LA7SCT
+30 SET LA7Z=$$CODE^LEXTRAN(LA7X,"SCT",DT,"LA7SCT")
+31 IF LA7Z>0
SET $PIECE(LA7Y,"^",1,4)=$PIECE(LA7SCT(0),"^")_"^"_LA7SCT("F")_"^SCT^"_$PIECE(LA7SCT(0),"^",3)
End DoDot:2
QUIT
End DoDot:1
+32 ;
+33 QUIT LA7Y
+34 ;
+35 ;
SCT2IEN(CODE,TEXT,VERSION,FILE,LA76247,LA76248) ; Return file ien for a given SNOMED CT code
+1 ; Call with CODE = SNOMED CT code
+2 ; TEXT = code text
+3 ; VERSION = code system version
+4 ; FILE = destination VistA file # (file where the SCT term resides)
+5 ; LA76247 = ien of concept to screen on
+6 ; LA76248 = related Lab Messaging configuration for non-standard code lookup (optional)
+7 ; used when code is only for a specific interface
+8 ;
+9 ; Returns LA7IEN = file internal entry number
+10 ;
+11 NEW LA7CNT,LA7IEN,LA7X,LA7Y
+12 SET (LA7CNT,LA7X)=0
SET LA7IEN=""
+13 FOR
SET LA7X=$ORDER(^LAB(FILE,"F",CODE,LA7X))
if 'LA7X
QUIT
SET LA7CNT=LA7CNT+1
SET LA7IEN=LA7X
SET LA7Y(LA7X)=^LAB(FILE,LA7X,"SCT")
+14 ;
+15 ; If multiple entries mapped then check for closest match
+16 ; - try P if no P then try S or L for text match
+17 ; - if none then select S
+18 ; - if none then select L
+19 IF LA7CNT>1
Begin DoDot:1
+20 NEW LA7QUIT
+21 SET TEXT=$$UP^XLFSTR(TEXT)
+22 SET (LA7QUIT,LA7X)=0
+23 FOR
SET LA7X=$ORDER(LA7Y(LA7X))
if 'LA7X
QUIT
Begin DoDot:2
+24 SET LA7IEN=LA7X
+25 IF $PIECE(LA7Y(LA7X),"^",2)="P"
SET LA7QUIT=1
QUIT
+26 IF $PIECE(LA7Y(LA7X),"^",2)?1(1"S",1"L")
IF TEXT=$$UP^XLFSTR($PIECE(^LAB(FILE,LA7X,0),"^"))
SET LA7QUIT=1
End DoDot:2
if LA7QUIT
QUIT
+27 IF LA7QUIT
QUIT
+28 SET (LA7IEN,LA7X)=0
+29 FOR
SET LA7X=$ORDER(LA7Y(LA7X))
if 'LA7X
QUIT
Begin DoDot:2
+30 IF $PIECE(LA7Y(LA7X),"^",2)="S"
SET LA7IEN=LA7X
+31 IF 'LA7IEN
IF $PIECE(LA7Y(LA7X),"^",2)="L"
SET LA7IEN=LA7X
End DoDot:2
End DoDot:1
+32 ;
+33 ;
+34 QUIT LA7IEN
+35 ;
+36 ;
HL2LAH(CODE,TEXT,NCS,VERSION,LA76248,LA7SS) ; Determine storage location for a code system sent in OBX-3
+1 ; Call with CODE = code id
+2 ; TEXT = code text
+3 ; NCS = name of coding system (LOINC, NLT, SCT, 99xxx, L)
+4 ; VERSION = code system version id
+5 ; LA76248 = related Lab Messaging configuration for non-standard code lookup (optional)
+6 ; used when code is only for a specific interface
+7 ; LA7SS = specific lab subscript to screen standard codes - used when same code used in multiple areas
+8 ;
+9 ; Returns LA7Y = CONCEPT^SUBSCRIPT^FILE/SUBFILE^FIELD NUMBER^SCT HIERARCHY
+10 ;
+11 NEW DA,LA76247,LA764,LA764061,LA7ROOT,LA7X,LA7Y,LOCAL,X,Y
+12 SET (DA,DA(1),LA7Y,LA76247)=""
SET LA7SS=$GET(LA7SS)
SET LA764061=0
+13 SET LOCAL=$SELECT(NCS="99VA64":0,NCS="L":1,$EXTRACT(NCS,1,2)="99":1,1:0)
+14 ;
+15 ; Check for subscript specific code first.
+16 ; If VA NLT suffixed code and not in x-ref then try non-suffixed version of code.
+17 IF LA7SS'=""
Begin DoDot:1
+18 SET LA7ROOT=$QUERY(^LAB(62.47,"AC2",LA7SS,NCS,CODE))
+19 IF LA7ROOT=""
IF NCS="99VA64"
IF CODE#1
SET CODE=$PIECE(CODE,".")_".0000"
SET LA7ROOT=$QUERY(^LAB(62.47,"AC2",LA7SS,NCS,CODE))
+20 IF LA7ROOT'=""
IF $QSUBSCRIPT(LA7ROOT,2)="AC2"
IF $QSUBSCRIPT(LA7ROOT,3)=LA7SS
IF $QSUBSCRIPT(LA7ROOT,4)=NCS
IF $QSUBSCRIPT(LA7ROOT,5)=CODE
Begin DoDot:2
+21 SET LA764061=$QSUBSCRIPT(LA7ROOT,6)
SET (DA(1),LA7Y)=$QSUBSCRIPT(LA7ROOT,7)
+22 IF LA764061
SET LA7Y=LA7Y_"^"_$PIECE($GET(^LAB(64.061,LA764061,63)),"^",1,4)
+23 SET DA=$QSUBSCRIPT(LA7ROOT,8)
+24 IF $PIECE(^LAB(62.47,DA(1),1,DA,0),"^",4)
DO LAHOVR
SET $PIECE(LA7Y,"^",6)=$QSUBSCRIPT(LA7ROOT,7)
End DoDot:2
End DoDot:1
+25 ;
+26 ; Check for non-subscript specific code
+27 ; If VA NLT suffixed code and not in x-ref then try non-suffixed version of code.
+28 IF LA7Y=""
Begin DoDot:1
+29 SET LA7ROOT=$QUERY(^LAB(62.47,"AC",NCS,CODE))
+30 IF LA7ROOT=""
IF NCS="99VA64"
IF CODE#1
SET CODE=$PIECE(CODE,".")_".0000"
SET LA7ROOT=$QUERY(^LAB(62.47,"AC",NCS,CODE))
+31 IF LA7ROOT'=""
IF $QSUBSCRIPT(LA7ROOT,2)="AC"
IF $QSUBSCRIPT(LA7ROOT,3)=NCS
IF $QSUBSCRIPT(LA7ROOT,4)=CODE
Begin DoDot:2
+32 SET LA764061=$QSUBSCRIPT(LA7ROOT,5)
SET (DA(1),LA7Y)=$QSUBSCRIPT(LA7ROOT,6)
+33 IF LA764061
SET LA7Y=LA7Y_"^"_$PIECE($GET(^LAB(64.061,LA764061,63)),"^",1,4)
+34 SET DA=$QSUBSCRIPT(LA7ROOT,7)
+35 IF $PIECE(^LAB(62.47,DA(1),1,DA,0),"^",4)
DO LAHOVR
SET $PIECE(LA7Y,"^",6)=$QSUBSCRIPT(LA7ROOT,6)
End DoDot:2
End DoDot:1
+36 ;
+37 ; If for a specific interface
+38 IF LA76248
Begin DoDot:1
+39 SET LA7ROOT=$QUERY(^LAB(62.47,"AC1",LA76248,NCS,CODE))
+40 IF LA7ROOT'=""
IF $QSUBSCRIPT(LA7ROOT,2)="AC1"
IF $QSUBSCRIPT(LA7ROOT,3)=LA76248
IF $QSUBSCRIPT(LA7ROOT,4)=NCS
IF $QSUBSCRIPT(LA7ROOT,5)=CODE
Begin DoDot:2
+41 SET LA764061=$QSUBSCRIPT(LA7ROOT,6)
SET (DA(1),LA7Y)=$QSUBSCRIPT(LA7ROOT,7)
+42 IF LA764061
SET LA7Y=LA7Y_"^"_$PIECE($GET(^LAB(64.061,LA764061,63)),"^",1,4)
+43 SET DA=$QSUBSCRIPT(LA7ROOT,8)
+44 IF $PIECE(^LAB(62.47,DA(1),1,DA,0),"^",4)
DO LAHOVR
SET $PIECE(LA7Y,"^",6)=$QSUBSCRIPT(LA7ROOT,7)
End DoDot:2
End DoDot:1
+45 ;
+46 ; Set bacterial/mycobacteria susceptibility field
+47 IF LA764061=9332!(LA764061=9333)
Begin DoDot:1
+48 SET LA7X=$GET(^LAB(62.47,DA(1),1,DA,2))
+49 IF $PIECE($PIECE(LA7X,"^"),";",2)'="LAB(62.06,"
QUIT
+50 SET X=$GET(^LAB(62.06,+LA7X,0))
+51 IF LA764061=9332
IF $PIECE(X,"^",4)
SET $PIECE(LA7Y,"^",4)=$PIECE(X,"^",4)
QUIT
+52 IF LA764061=9333
IF $PIECE(X,"^",8)
SET $PIECE(LA7Y,"^",4)=$PIECE(X,"^",8)
End DoDot:1
+53 ;
+54 ; If code system is SNOMED CT
+55 ; Currently VistA should not receive a SNOMED CT code in an OBX-3 field.
+56 IF NCS="SCT"
Begin DoDot:1
+57 QUIT
End DoDot:1
+58 ;
+59 QUIT LA7Y
+60 ;
+61 ;
LAHOVR ; Override HL2LAH concept code mapping.
+1 ;ZEXCEPT: DA,LA76247,LA764061,LA7Y
+2 ;
+3 SET LA76247=$PIECE(^LAB(62.47,DA(1),1,DA,0),"^",4)
+4 SET LA764061=$PIECE(^LAB(62.47,LA76247,0),"^",3)
+5 SET LA7Y=LA76247_"^"_$GET(^LAB(64.061,LA764061,63))
+6 QUIT
+7 ;
+8 ;
ALCONCPT(LA76247) ; Determine alternate concept for a concept
+1 ; Call with LA76247 = ien of concept
+2 ;
+3 ; Returns LACONPT = alternate concept
+4 ;
+5 NEW LACONCPT
+6 SET LACONCPT=""
+7 IF $GET(LA76247)>0
SET LACONCPT=+$PIECE($GET(^LAB(62.47,LA76247,0)),"^",4)
+8 QUIT LACONCPT
+9 ;
+10 ;
PRID(CODE,NCS,LA764061) ; Determine if a code represents the presence/absence or the identity of a concept in OBX-5
+1 ; Used to determine if identity of organism or presence/absence
+2 ; Call with CODE = code id
+3 ; NCS = name of coding system
+4 ; LA64061 = related Lab database code
+5 ;
+6 ; Returns LA7Y = hierarchy of the code ^ related VistA file
+7 ;
+8 NEW LA7Y,LA7X
+9 SET LA7Y=""
+10 ;
+11 ; If code system is SNOMED CT
+12 IF NCS="SCT"
Begin DoDot:1
+13 SET LA7Y=$$GET1^DIQ(64.061,LA764061_",",63.3)
+14 SET LA7X=$$GET1^DIQ(64.061,LA764061_",",63.3,"I")
+15 IF LA7X
SET $PIECE(LA7Y,"^",2)=$PIECE($GET(^LAB(64.061,LA7X,63)),"^",5)
End DoDot:1
+16 ;
+17 QUIT LA7Y
+18 ;
+19 ;
HL2VA(CODE,TEXT,NCS,VERSION,LA76247,LA76248) ; Resolve code to internal VA file entry, used to resolve value of OBX-5 coded entry
+1 ; Call with CODE = code id
+2 ; NCS = name of coding system (SCT, 99xxx, L)
+3 ; TEXT = code text
+4 ; VERSION = code system version id
+5 ; LA76247 = ien of concept to screen on
+6 ; LA76248 = related Lab Messaging configuration for non-standard code lookup (optional)
+7 ; used when code is only for a specific interface
+8 ;
+9 ; Returns LA7Y = variable pointer format^database storage location
+10 ; OR
+11 ; -1^^^^ien of override concept (if override concept)
+12 ;
+13 NEW DA,LA764061,LA7FILE,LA7HIER,LA7ROOT,LA7X,LA7Y,LOCAL,X,Y
+14 SET LA76247=$GET(LA76247)
+15 IF 'LA76247
QUIT 0
+16 SET LA7FILE=""
+17 SET LOCAL=$SELECT(NCS="L":1,$EXTRACT(NCS,1,2)="99":1,1:0)
+18 SET LA764061=$PIECE($GET(^LAB(62.47,LA76247,0)),"^",3)
SET LA7Y="^"_$PIECE($GET(^LAB(64.061,LA764061,63)),"^",1,3)
+19 ;
+20 ; If code system is SNOMED CT
+21 IF NCS="SCT"
Begin DoDot:1
+22 SET LA7ROOT=$QUERY(^LAB(62.47,"AD",LA76247,NCS,CODE))
+23 IF LA7ROOT'=""
IF $QSUBSCRIPT(LA7ROOT,2)="AD"
IF $QSUBSCRIPT(LA7ROOT,3)=LA76247
IF $QSUBSCRIPT(LA7ROOT,4)=NCS
IF $QSUBSCRIPT(LA7ROOT,5)=CODE
Begin DoDot:2
+24 SET X=$QSUBSCRIPT(LA7ROOT,6)
+25 IF X
SET LA7Y="-1^^^^"_X
End DoDot:2
QUIT
+26 IF $SELECT(LA76247=7:1,LA76247=21:1,1:0)
SET LA7Y=$$SCT2KB(CODE,TEXT,NCS,VERSION)
Begin DoDot:2
+27 IF LA7Y=""
SET LA7Y=$$SCT2PN(CODE,TEXT,NCS,VERSION)
End DoDot:2
QUIT
+28 SET LA7HIER=$$PRID(CODE,NCS,LA764061)
+29 SET LA7FILE=$PIECE(LA7HIER,"^",2)
+30 IF LA7FILE
SET LA7Y=$$SCT2IEN(CODE,TEXT,VERSION,LA7FILE,LA76247,LA76248)_";"_$PIECE($$ROOT^DILFD(LA7FILE),"^",2)_LA7Y
End DoDot:1
+31 ;
+32 ; If code system is LOCAL (HL7 "L" OR "99XXX") and for a specific interface
+33 IF LOCAL
IF LA76248
Begin DoDot:1
+34 SET LA7ROOT=$QUERY(^LAB(62.47,"AD1",LA76247,LA76248,NCS,CODE))
SET LA764061=0
+35 IF LA7ROOT=""
QUIT
+36 IF $QSUBSCRIPT(LA7ROOT,2)="AD1"
IF $QSUBSCRIPT(LA7ROOT,3)=LA76247
IF $QSUBSCRIPT(LA7ROOT,4)=LA76248
IF $QSUBSCRIPT(LA7ROOT,5)=NCS
IF $QSUBSCRIPT(LA7ROOT,6)=CODE
Begin DoDot:2
+37 SET LA764061=$QSUBSCRIPT(LA7ROOT,7)
SET DA=$QSUBSCRIPT(LA7ROOT,8)
+38 SET X=$PIECE(^LAB(62.47,LA76247,1,DA,0),"^",4)
+39 IF X
SET LA7Y="-1^^^^"_X
QUIT
+40 SET LA7FILE=$PIECE($GET(^LAB(62.47,LA76247,1,DA,2)),"^")
+41 IF LA7FILE
SET LA7Y=LA7FILE
+42 IF LA764061
SET LA7Y=LA7Y_"^"_$PIECE($GET(^LAB(64.061,LA764061,63)),"^",1,3)
End DoDot:2
End DoDot:1
+43 ;
+44 QUIT LA7Y
+45 ;
+46 ;
SCT2KB(CODE,TEXT,NCS,VERSION) ; Convert Susceptibility codes to local codes.
+1 ; Call with CODE = susceptibility code
+2 ; TEXT = code text
+3 ; NCS = name of coding system (SCT, 99xxx, L)
+4 ; VERSION = code system version id
+5 ;
+6 ; Returns LA7Y = local susceptibility code
+7 ;
+8 NEW LA7Y
+9 SET LA7Y=""
+10 IF NCS="SCT"
SET LA7Y=$SELECT(CODE=131196009:"S",CODE=260357007:"MS",CODE=30714006:"R",CODE=264841006:"I",1:"")
+11 ;
+12 ; Convert local codes
+13 IF $SELECT(NCS="L":1,$EXTRACT(NCS,1,2)="99":1,1:0)
SET LA7Y=TEXT
+14 ;
+15 QUIT LA7Y
+16 ;
+17 ;
SCT2PSTG(CODE,TEXT,NCS,VERSION) ; Convert Parasite Stage codes to local codes.
+1 ; Call with CODE = parasite stage code
+2 ; TEXT = code text
+3 ; NCS = name of coding system (SCT, 99xxx, L)
+4 ; VERSION = code system version id
+5 ;
+6 ; Returns LA7Y = local parasite stage code
+7 ;
+8 NEW LA7Y
+9 SET LA7Y=""
+10 IF NCS="SCT"
SET LA7Y=$SELECT(CODE=103551003:"T",CODE=103552005:"C",CODE=116990009:"E",CODE=48458007:"L",CODE=284701003:"S",CODE=103537003:"G",CODE=2105009:"M",CODE=103568004:"R",CODE=2105009:"F",1:"")
+11 QUIT LA7Y
+12 ;
+13 ;
SCT2PN(CODE,TEXT,NCS,VERSION) ; Convert Positive/Negative to local codes.
+1 ; Call with CODE = positive/negative
+2 ; TEXT = code text
+3 ; NCS = name of coding system (SCT, 99xxx, L)
+4 ; VERSION = code system version id
+5 ;
+6 ; Returns LA7Y = local positive/negative code
+7 ;
+8 NEW LA7Y
+9 SET LA7Y=""
+10 IF NCS="SCT"
SET LA7Y=$SELECT(CODE=10828004:"P",CODE=260385009:"N",1:"")
+11 ;
+12 ; Convert local codes
+13 IF $SELECT(NCS="L":1,$EXTRACT(NCS,1,2)="99":1,1:0)
SET LA7Y=TEXT
+14 ;
+15 QUIT LA7Y
