- 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 Feb 18, 2025@23:06:35 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