LEXTRAN ;ISL/KER - Lexicon code and text wrapper API's ;04/21/2014
;;2.0;LEXICON UTILITY;**41,59,73,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX(757.011) N/A
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; ^%DT ICR 10003
; $$GET1^DIQ ICR 2056
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
CODE(CODE,SRC,CDT,LEXRAY) ; Get the Concept for a Code and Source
;
; Input
;
; CODE Code (required)
; SRC Code System source abbreviation (required)
; CDT Effective Date (optional, default TODAY)
; LEXRAY Output array (optional, defaults to 'LEX')
;
; Output
;
; if call finds an active code for the source
; "1^LEXCODE"
; LEX - an array containing information about the code
; LEX(0) - a five piece string:
; 1. code
; 2. hierarchy
; 3. version
; 4. legacy code
; 5. code status
; LEX("F") fully specified name
; LEX("P") preferred term
; LEX("S",n) synonyms (n is the nth synonym)
;
; if call cannot find specified code on file
; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
; where LEXSCNM is the source name
; LEXCODE is the code
;
; if call finds an inactive code for the source
; "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
; LEX - an array containing information about the code
; LEX(0) - a five piece string:
; 1. code
; 2. hierarchy
; 3. version
; 4. legacy code
; 5. code status
;
; otherwise
; "-1^error text"
;
; example of LEX array:
; LEX(0)="67922002^Substance^20050701^T-C2500^1"
; LEX("F")="Serum (Substance)"
; LEX("P")="Serum"
;
N LEXCODE,LEXSRC,LEXVDT S LEXCODE=$G(CODE),LEXSRC=$G(SRC),LEXVDT=$G(CDT)
I $G(LEXCODE)="" Q "-1^no code specified"
S LEXSRC=$E($G(LEXSRC),1,3) I $G(LEXSRC)="" Q "-1^no source specified"
I +($$CSYS^LEXU(LEXSRC))'>0 Q "-1^source not recognized"
I $D(^TMP("LEXSCH",$J,"VDT",0)) S LEXVDT=^(0)
D:'$L($G(LEXVDT)) VDT^LEXU
I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
I $G(LEXVDT)=-1 Q "-1^invalid date format"
I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
I $G(LEXRAY)="" K LEXRAY
N LEXSCNM,LEXSIEN,LEXASAB,LEXCIEN,VALCODE,LEXSTAT,LEXPIEN,LEXST
S LEXSIEN=+($$CSYS^LEXU(LEXSRC))
S LEXST=^LEX(757.03,LEXSIEN,0)
S LEXSCNM=$P(LEXST,U,2)
S LEXASAB=$E($P(LEXST,U),1,3)
S LEXCIEN="",VALCODE=0
F Q:VALCODE=1 D Q:LEXCIEN=""
.S LEXCIEN=$O(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN)) Q:LEXCIEN="" D
.I $D(^LEX(757.02,"ASRC",LEXASAB,LEXCIEN)) S VALCODE=1 Q
I 'VALCODE Q "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
K LEXSTAT,LEX
K ^TMP("LEXSCH",$J)
S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$E($G(LEXSRC),1,3)) ; Pch 73 adds parameter LEXSRC
I +LEXSTAT=0 D Q "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
.S LEXPIEN=$P(LEXSTAT(1),U)
.D GETINFO
.I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
S LEXPIEN=$P(LEXSTAT(1),U)
D GETINFO
I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
Q "1^"_LEXCODE
;
GETINFO ; Get Information for a Code
N LEXFSN,LEXHIER,LEXLGY,LEXVER,N,LEXSEP,I
S LEXSRC=$E($G(LEXSRC),1,3)
S LEX=$$GETSYN^LEXTRAN1(LEXSRC,LEXCODE,LEXVDT)
S LEXLGY=$$GET1^DIQ(757.02,LEXCIEN_",",13)
I $D(LEX("F")) S LEXHIER=$P($P(LEX("F"),"(",$L(LEX("F"),"(")),")")
S LEXVER=$$VERSION(LEXSRC,LEXCODE,LEXVDT)
S LEX(0)=LEXCODE_U_$G(LEXHIER)_U_$S(+LEXVER=-1:"",1:$P(LEXVER,U,3))
S LEX(0)=LEX(0)_U_LEXLGY_U_+LEXSTAT
I $D(LEX("F")) S LEXHIER=$P($P(LEX("F"),"(",$L(LEX("F"),"(")),")")
K LEX("SEL")
Q
;
TEXT(TEXT,CDT,SUB,SRC,LEXRAY) ; Get the Concept for a text and source
;
; Input
;
; TEXT The search string (required)
; CDT Effective date (optional, default is TODAY)
; SUB Subset or 'hierarchy' (optional)
; SRC Code System source abbreviation
; LEXRAY Output array (optional, defaults to 'LEX')
;
; Output
;
; LEX or passed array name - an array containing information
; about the code
; LEX(0) - a five piece string:
; 1. code
; 2. hierarchy
; 3. version
; 4. legacy code
; 5. code status
;
; LEX("F") fully specified name ^ internal entry number
; LEX("P") preferred term ^ internal entry number
; LEX("S",n) synonyms (n is the nth synonym) ^ internal entry number
;
; otherwise
; "-1^error text"
;
; example of LEX array:
; LEX(0)="67922002^Substance^20050701^T-C2500^1"
; LEX("F")="Serum (Substance)"
; LEX("P")="Serum"
;
N LEXTEXT,LEXVDT,LEXTD,LEXSUB,LEXSRC,LEXNOM,LEXID,DIC K LEX
S LEXTEXT=$G(TEXT),LEXVDT=$G(CDT),LEXSUB=$G(SUB),LEXSRC=$G(SRC)
I $G(LEXTEXT)="" Q "-1^no search string specified"
S LEXSRC=$P($$CSYS^LEXU3(LEXSRC),"^",2),LEXNOM=""
S:$L(LEXSRC) LEXNOM=$P($G(^LEX(757.03,+($O(^LEX(757.03,"ASAB",LEXSRC,0))),0)),"^",2)
I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
I $G(LEXVDT)=-1 Q "-1^invalid date format"
I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
S LEXSUB=$G(LEXSUB) I LEXSUB="" S LEXSUB=LEXSRC
I $G(LEXRAY)="" K LEXRAY
N X,LEXPIEN,LEXCODE,LEXSTAT,LEXCIEN,Y
K ^TMP("LEXSCH",$J),LEX
S X=LEXTEXT
D CONFIG^LEXSET(LEXSRC,LEXSUB,LEXVDT)
D EN^LEXA1
I +Y=-1 Q "-1^search could not find term"
S LEXPIEN=+Y
D INFO^LEXA(LEXPIEN)
S LEXCODE="",LEXSTAT=-1 I $L(LEXNOM) D
. S LEXID=$O(LEX("SEL","SRC","B",LEXNOM,0))
. S LEXCODE=$P($G(LEX("SEL","SRC",+LEXID)),"^",2)
I '$L(LEXCODE),$D(LEX("SEL","SRC","C")) D
. S LEXCODE=$O(LEX("SEL","SRC","C",""))
S LEXCIEN=0 I $L(LEXCODE) D
. S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$E(LEXSRC,1,3))
. S LEXCIEN=$P(LEXSTAT,U,2),LEXSRC=$E($P($G(LEXSTAT(2)),U,2),1,3)
D GETINFO
I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
Q "1^"_LEXPIEN
;
VERSION(SRC,CODE,VDT) ; Get the Code Version Number
;
; Input
;
; SRC Code System source abbreviation e.g. SCT (SNOMED CT)
; CODE Code - mandatory
; VDT Effective date (defaults to current date) - optional
; - optional
;
; Output
;
; 1^Version
; or
; -1^error message
;
N LEXSRC,LEXCODE,LEXVDT S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(VDT)
I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
I $G(LEXVDT)=-1 Q "-1^invalid date format"
I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
S LEXSRC=$E($G(LEXSRC),1,3) I $G(LEXSRC)="" Q "-1^invalid source"
N SIEN,VIEN,VDAT,LEXSTAT
S SIEN=+($$CSYS^LEXU(LEXSRC))
I '$D(^LEX(757.03,+SIEN,1)) Q "-1^No source version data available"
S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$E($G(LEXSRC),1,3)) ; Pch 73 adds parameter LEXSRC
I +LEXSTAT=0 Q "-1^Code not active for date specified"
S VDAT=$O(^LEX(757.03,SIEN,1,"B",LEXVDT+1),-1)
S VIEN=$O(^LEX(757.03,SIEN,1,"B",VDAT,""))
Q "1^"_^LEX(757.03,SIEN,1,VIEN,0)
;
TXT4CS(TEXT,SRC,LEXRAY,SUB) ; Is text valid for an SCT code
;
; Input
;
; TEXT Text to check
; SRC Coding System Mnemonic or IEN
; LEXRAY Output array (optional, defaults to 'LEX')
; SUB Subset or 'hierarchy' (optional)
;
; Output
;
; 1^no of finds
;
; plus
;
; LEX or passed array name - an array containing
;
; LEX(<code>,<seq>)= expression type ^ code IEN ^ expression IEN
;
; e.g. LEX(123.5,1)="MAJOR CONCEPT^119085^112525"
; LEX(123.5,2)="SYNONYM^119094^112526"
; or
;
; -1^error message
;
N LEXTEXT,LEXSRC,LEXSUB S LEXTEXT=$G(TEXT),LEXSRC=$G(SRC),LEXSUB=$G(SUB)
N CODEC,EXP,EXIEN,MCIEN,FOUND,CIEN,CODE,EXPTYP,FINDS,LAR,HIER,HIERNAM,LEXW ; Pch 73 adds variable CODEC
I $G(LEXTEXT)="" Q "-1^text not specified"
I $G(LEXSRC)="" Q "-1^code system not specified"
I $$CSYSIEN(LEXSRC)+$$CSYSMNEM(LEXSRC)=-2 Q "-1^code system unknown in Lexicon"
I $G(LEXRAY)="" K LEXRAY
S LEXSUB=$G(LEXSUB)
I LEXSUB'="",'$D(^LEXT(757.2,"AA",LEXSUB)) Q "-1^hierarchy unknown in Lexicon"
S:LEXSRC?.N LEXSRC=$P($$CSYSMNEM(LEXSRC),"^",2)
; text IEN's in 757.01
I '$D(^LEX(757.01,"B",$E($$UP^XLFSTR(LEXTEXT),1,63))) Q "-1^expression unknown in Lexicon"
; build an array of expression IENs for text
S EXIEN=""
F S EXIEN=$O(^LEX(757.01,"B",$E($$UP^XLFSTR(LEXTEXT),1,63),EXIEN)) Q:EXIEN="" D ; Pch 73 adds $Extract
.S:$$UP^XLFSTR($G(^LEX(757.01,+EXIEN,0)))=$$UP^XLFSTR(LEXTEXT) EXP(EXIEN)="" ; Pch 73 adds exact match check
; scan array to find code for expression (LEXTEXT) for code system (LEXSRC)
S EXIEN=""
K LEXW
S (FOUND,FINDS)=0
F S EXIEN=$O(EXP(EXIEN)) Q:EXIEN="" D
.S MCIEN=$P(^LEX(757.01,EXIEN,1),U)
.; Pch 73 moved EXPTYP into CIEN loop
.S CIEN="" F S CIEN=$O(^LEX(757.02,"AMC",MCIEN,CIEN)) Q:CIEN="" D
..I $P($$CSYSMNEM($P(^LEX(757.02,CIEN,0),U,3)),U,2)=LEXSRC D
...S CODE=$P(^LEX(757.02,CIEN,0),U,2)
...S (HIER,HIERNAM)=""
...I LEXSUB'="" D
....K LAR
....S LAR=$$CODE(CODE,"SCT",,"LAR")
....S HIER=$P($G(LAR(0)),U,2)
....S HIERNAM=$P(^LEXT(757.2,$O(^LEXT(757.2,"AA",LEXSUB,"")),0),U)
...I LEXSUB'="",HIER'=HIERNAM Q
...S FOUND=1
...S FINDS=FINDS+1
...S CODEC=$O(LEXW(CODE," "),-1)+1 ; Pch 73 adds counter for multiple entries for code
...S EXPTYP=$P(^LEX(757.011,$P(^LEX(757.01,+($G(^LEX(757.02,CIEN,0))),1),U,2),0),U) ; Pch 73 moved from EXIEN loop
...S LEXW(CODE,CODEC)=EXPTYP_"^"_CIEN_"^"_+($G(^LEX(757.02,CIEN,0))) ; Pch 73 adds code IEN and expression IEN to output
M LEX=LEXW
I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
Q FOUND_"^"_FINDS
;
CSYSIEN(MNEM) ; Return code system IEN for mnemonic
Q:'$L($G(MNEM)) "-1^invalid code system" N LEXIEN
S LEXIEN=+($$CSYS^LEXU(MNEM)) Q:LEXIEN>0 "1^"_LEXIEN
Q "-1^code system unknown in Lexicon"
;
CSYSMNEM(SIEN) ; Return code system mnemonic for IEN
S SIEN=+($$CSYS^LEXU($G(SIEN)))
I '$D(^LEX(757.03,+($G(SIEN)),0)) Q "-1^code system unknown in Lexicon"
Q "1^"_$E($P(^LEX(757.03,SIEN,0),"^"),1,3)
;
INTDAT(X) ; Convert date from external format to VA internal format
N Y,%DT
D ^%DT
Q Y
LEXTRAN ;ISL/KER - Lexicon code and text wrapper API's ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**41,59,73,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.011) N/A
+5 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; ^%DT ICR 10003
+9 ; $$GET1^DIQ ICR 2056
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$UP^XLFSTR ICR 10104
+12 ;
CODE(CODE,SRC,CDT,LEXRAY) ; Get the Concept for a Code and Source
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code (required)
+5 ; SRC Code System source abbreviation (required)
+6 ; CDT Effective Date (optional, default TODAY)
+7 ; LEXRAY Output array (optional, defaults to 'LEX')
+8 ;
+9 ; Output
+10 ;
+11 ; if call finds an active code for the source
+12 ; "1^LEXCODE"
+13 ; LEX - an array containing information about the code
+14 ; LEX(0) - a five piece string:
+15 ; 1. code
+16 ; 2. hierarchy
+17 ; 3. version
+18 ; 4. legacy code
+19 ; 5. code status
+20 ; LEX("F") fully specified name
+21 ; LEX("P") preferred term
+22 ; LEX("S",n) synonyms (n is the nth synonym)
+23 ;
+24 ; if call cannot find specified code on file
+25 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+26 ; where LEXSCNM is the source name
+27 ; LEXCODE is the code
+28 ;
+29 ; if call finds an inactive code for the source
+30 ; "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
+31 ; LEX - an array containing information about the code
+32 ; LEX(0) - a five piece string:
+33 ; 1. code
+34 ; 2. hierarchy
+35 ; 3. version
+36 ; 4. legacy code
+37 ; 5. code status
+38 ;
+39 ; otherwise
+40 ; "-1^error text"
+41 ;
+42 ; example of LEX array:
+43 ; LEX(0)="67922002^Substance^20050701^T-C2500^1"
+44 ; LEX("F")="Serum (Substance)"
+45 ; LEX("P")="Serum"
+46 ;
+47 NEW LEXCODE,LEXSRC,LEXVDT
SET LEXCODE=$GET(CODE)
SET LEXSRC=$GET(SRC)
SET LEXVDT=$GET(CDT)
+48 IF $GET(LEXCODE)=""
QUIT "-1^no code specified"
+49 SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
IF $GET(LEXSRC)=""
QUIT "-1^no source specified"
+50 IF +($$CSYS^LEXU(LEXSRC))'>0
QUIT "-1^source not recognized"
+51 IF $DATA(^TMP("LEXSCH",$JOB,"VDT",0))
SET LEXVDT=^(0)
+52 IF '$LENGTH($GET(LEXVDT))
DO VDT^LEXU
+53 IF $GET(LEXVDT)'=""
SET LEXVDT=$$INTDAT(LEXVDT)
+54 IF $GET(LEXVDT)=-1
QUIT "-1^invalid date format"
+55 IF $GET(LEXVDT)=""
SET LEXVDT=$$DT^XLFDT
+56 IF $GET(LEXRAY)=""
KILL LEXRAY
+57 NEW LEXSCNM,LEXSIEN,LEXASAB,LEXCIEN,VALCODE,LEXSTAT,LEXPIEN,LEXST
+58 SET LEXSIEN=+($$CSYS^LEXU(LEXSRC))
+59 SET LEXST=^LEX(757.03,LEXSIEN,0)
+60 SET LEXSCNM=$PIECE(LEXST,U,2)
+61 SET LEXASAB=$EXTRACT($PIECE(LEXST,U),1,3)
+62 SET LEXCIEN=""
SET VALCODE=0
+63 FOR
IF VALCODE=1
QUIT
Begin DoDot:1
+64 SET LEXCIEN=$ORDER(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN))
IF LEXCIEN=""
QUIT
Begin DoDot:2
End DoDot:2
+65 IF $DATA(^LEX(757.02,"ASRC",LEXASAB,LEXCIEN))
SET VALCODE=1
QUIT
End DoDot:1
IF LEXCIEN=""
QUIT
+66 IF 'VALCODE
QUIT "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+67 KILL LEXSTAT,LEX
+68 KILL ^TMP("LEXSCH",$JOB)
+69 ; Pch 73 adds parameter LEXSRC
SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$EXTRACT($GET(LEXSRC),1,3))
+70 IF +LEXSTAT=0
Begin DoDot:1
+71 SET LEXPIEN=$PIECE(LEXSTAT(1),U)
+72 DO GETINFO
+73 IF $DATA(LEXRAY)
IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
End DoDot:1
QUIT "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
+74 SET LEXPIEN=$PIECE(LEXSTAT(1),U)
+75 DO GETINFO
+76 IF $DATA(LEXRAY)
IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
+77 QUIT "1^"_LEXCODE
+78 ;
GETINFO ; Get Information for a Code
+1 NEW LEXFSN,LEXHIER,LEXLGY,LEXVER,N,LEXSEP,I
+2 SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
+3 SET LEX=$$GETSYN^LEXTRAN1(LEXSRC,LEXCODE,LEXVDT)
+4 SET LEXLGY=$$GET1^DIQ(757.02,LEXCIEN_",",13)
+5 IF $DATA(LEX("F"))
SET LEXHIER=$PIECE($PIECE(LEX("F"),"(",$LENGTH(LEX("F"),"(")),")")
+6 SET LEXVER=$$VERSION(LEXSRC,LEXCODE,LEXVDT)
+7 SET LEX(0)=LEXCODE_U_$GET(LEXHIER)_U_$SELECT(+LEXVER=-1:"",1:$PIECE(LEXVER,U,3))
+8 SET LEX(0)=LEX(0)_U_LEXLGY_U_+LEXSTAT
+9 IF $DATA(LEX("F"))
SET LEXHIER=$PIECE($PIECE(LEX("F"),"(",$LENGTH(LEX("F"),"(")),")")
+10 KILL LEX("SEL")
+11 QUIT
+12 ;
TEXT(TEXT,CDT,SUB,SRC,LEXRAY) ; Get the Concept for a text and source
+1 ;
+2 ; Input
+3 ;
+4 ; TEXT The search string (required)
+5 ; CDT Effective date (optional, default is TODAY)
+6 ; SUB Subset or 'hierarchy' (optional)
+7 ; SRC Code System source abbreviation
+8 ; LEXRAY Output array (optional, defaults to 'LEX')
+9 ;
+10 ; Output
+11 ;
+12 ; LEX or passed array name - an array containing information
+13 ; about the code
+14 ; LEX(0) - a five piece string:
+15 ; 1. code
+16 ; 2. hierarchy
+17 ; 3. version
+18 ; 4. legacy code
+19 ; 5. code status
+20 ;
+21 ; LEX("F") fully specified name ^ internal entry number
+22 ; LEX("P") preferred term ^ internal entry number
+23 ; LEX("S",n) synonyms (n is the nth synonym) ^ internal entry number
+24 ;
+25 ; otherwise
+26 ; "-1^error text"
+27 ;
+28 ; example of LEX array:
+29 ; LEX(0)="67922002^Substance^20050701^T-C2500^1"
+30 ; LEX("F")="Serum (Substance)"
+31 ; LEX("P")="Serum"
+32 ;
+33 NEW LEXTEXT,LEXVDT,LEXTD,LEXSUB,LEXSRC,LEXNOM,LEXID,DIC
KILL LEX
+34 SET LEXTEXT=$GET(TEXT)
SET LEXVDT=$GET(CDT)
SET LEXSUB=$GET(SUB)
SET LEXSRC=$GET(SRC)
+35 IF $GET(LEXTEXT)=""
QUIT "-1^no search string specified"
+36 SET LEXSRC=$PIECE($$CSYS^LEXU3(LEXSRC),"^",2)
SET LEXNOM=""
+37 IF $LENGTH(LEXSRC)
SET LEXNOM=$PIECE($GET(^LEX(757.03,+($ORDER(^LEX(757.03,"ASAB",LEXSRC,0))),0)),"^",2)
+38 IF $GET(LEXVDT)'=""
SET LEXVDT=$$INTDAT(LEXVDT)
+39 IF $GET(LEXVDT)=-1
QUIT "-1^invalid date format"
+40 IF $GET(LEXVDT)=""
SET LEXVDT=$$DT^XLFDT
+41 SET LEXSUB=$GET(LEXSUB)
IF LEXSUB=""
SET LEXSUB=LEXSRC
+42 IF $GET(LEXRAY)=""
KILL LEXRAY
+43 NEW X,LEXPIEN,LEXCODE,LEXSTAT,LEXCIEN,Y
+44 KILL ^TMP("LEXSCH",$JOB),LEX
+45 SET X=LEXTEXT
+46 DO CONFIG^LEXSET(LEXSRC,LEXSUB,LEXVDT)
+47 DO EN^LEXA1
+48 IF +Y=-1
QUIT "-1^search could not find term"
+49 SET LEXPIEN=+Y
+50 DO INFO^LEXA(LEXPIEN)
+51 SET LEXCODE=""
SET LEXSTAT=-1
IF $LENGTH(LEXNOM)
Begin DoDot:1
+52 SET LEXID=$ORDER(LEX("SEL","SRC","B",LEXNOM,0))
+53 SET LEXCODE=$PIECE($GET(LEX("SEL","SRC",+LEXID)),"^",2)
End DoDot:1
+54 IF '$LENGTH(LEXCODE)
IF $DATA(LEX("SEL","SRC","C"))
Begin DoDot:1
+55 SET LEXCODE=$ORDER(LEX("SEL","SRC","C",""))
End DoDot:1
+56 SET LEXCIEN=0
IF $LENGTH(LEXCODE)
Begin DoDot:1
+57 SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$EXTRACT(LEXSRC,1,3))
+58 SET LEXCIEN=$PIECE(LEXSTAT,U,2)
SET LEXSRC=$EXTRACT($PIECE($GET(LEXSTAT(2)),U,2),1,3)
End DoDot:1
+59 DO GETINFO
+60 IF $DATA(LEXRAY)
IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
+61 QUIT "1^"_LEXPIEN
+62 ;
VERSION(SRC,CODE,VDT) ; Get the Code Version Number
+1 ;
+2 ; Input
+3 ;
+4 ; SRC Code System source abbreviation e.g. SCT (SNOMED CT)
+5 ; CODE Code - mandatory
+6 ; VDT Effective date (defaults to current date) - optional
+7 ; - optional
+8 ;
+9 ; Output
+10 ;
+11 ; 1^Version
+12 ; or
+13 ; -1^error message
+14 ;
+15 NEW LEXSRC,LEXCODE,LEXVDT
SET LEXSRC=$GET(SRC)
SET LEXCODE=$GET(CODE)
SET LEXVDT=$GET(VDT)
+16 IF $GET(LEXVDT)'=""
SET LEXVDT=$$INTDAT(LEXVDT)
+17 IF $GET(LEXVDT)=-1
QUIT "-1^invalid date format"
+18 IF $GET(LEXVDT)=""
SET LEXVDT=$$DT^XLFDT
+19 SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
IF $GET(LEXSRC)=""
QUIT "-1^invalid source"
+20 NEW SIEN,VIEN,VDAT,LEXSTAT
+21 SET SIEN=+($$CSYS^LEXU(LEXSRC))
+22 IF '$DATA(^LEX(757.03,+SIEN,1))
QUIT "-1^No source version data available"
+23 ; Pch 73 adds parameter LEXSRC
SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$EXTRACT($GET(LEXSRC),1,3))
+24 IF +LEXSTAT=0
QUIT "-1^Code not active for date specified"
+25 SET VDAT=$ORDER(^LEX(757.03,SIEN,1,"B",LEXVDT+1),-1)
+26 SET VIEN=$ORDER(^LEX(757.03,SIEN,1,"B",VDAT,""))
+27 QUIT "1^"_^LEX(757.03,SIEN,1,VIEN,0)
+28 ;
TXT4CS(TEXT,SRC,LEXRAY,SUB) ; Is text valid for an SCT code
+1 ;
+2 ; Input
+3 ;
+4 ; TEXT Text to check
+5 ; SRC Coding System Mnemonic or IEN
+6 ; LEXRAY Output array (optional, defaults to 'LEX')
+7 ; SUB Subset or 'hierarchy' (optional)
+8 ;
+9 ; Output
+10 ;
+11 ; 1^no of finds
+12 ;
+13 ; plus
+14 ;
+15 ; LEX or passed array name - an array containing
+16 ;
+17 ; LEX(<code>,<seq>)= expression type ^ code IEN ^ expression IEN
+18 ;
+19 ; e.g. LEX(123.5,1)="MAJOR CONCEPT^119085^112525"
+20 ; LEX(123.5,2)="SYNONYM^119094^112526"
+21 ; or
+22 ;
+23 ; -1^error message
+24 ;
+25 NEW LEXTEXT,LEXSRC,LEXSUB
SET LEXTEXT=$GET(TEXT)
SET LEXSRC=$GET(SRC)
SET LEXSUB=$GET(SUB)
+26 ; Pch 73 adds variable CODEC
NEW CODEC,EXP,EXIEN,MCIEN,FOUND,CIEN,CODE,EXPTYP,FINDS,LAR,HIER,HIERNAM,LEXW
+27 IF $GET(LEXTEXT)=""
QUIT "-1^text not specified"
+28 IF $GET(LEXSRC)=""
QUIT "-1^code system not specified"
+29 IF $$CSYSIEN(LEXSRC)+$$CSYSMNEM(LEXSRC)=-2
QUIT "-1^code system unknown in Lexicon"
+30 IF $GET(LEXRAY)=""
KILL LEXRAY
+31 SET LEXSUB=$GET(LEXSUB)
+32 IF LEXSUB'=""
IF '$DATA(^LEXT(757.2,"AA",LEXSUB))
QUIT "-1^hierarchy unknown in Lexicon"
+33 IF LEXSRC?.N
SET LEXSRC=$PIECE($$CSYSMNEM(LEXSRC),"^",2)
+34 ; text IEN's in 757.01
+35 IF '$DATA(^LEX(757.01,"B",$EXTRACT($$UP^XLFSTR(LEXTEXT),1,63)))
QUIT "-1^expression unknown in Lexicon"
+36 ; build an array of expression IENs for text
+37 SET EXIEN=""
+38 ; Pch 73 adds $Extract
FOR
SET EXIEN=$ORDER(^LEX(757.01,"B",$EXTRACT($$UP^XLFSTR(LEXTEXT),1,63),EXIEN))
IF EXIEN=""
QUIT
Begin DoDot:1
+39 ; Pch 73 adds exact match check
IF $$UP^XLFSTR($GET(^LEX(757.01,+EXIEN,0)))=$$UP^XLFSTR(LEXTEXT)
SET EXP(EXIEN)=""
End DoDot:1
+40 ; scan array to find code for expression (LEXTEXT) for code system (LEXSRC)
+41 SET EXIEN=""
+42 KILL LEXW
+43 SET (FOUND,FINDS)=0
+44 FOR
SET EXIEN=$ORDER(EXP(EXIEN))
IF EXIEN=""
QUIT
Begin DoDot:1
+45 SET MCIEN=$PIECE(^LEX(757.01,EXIEN,1),U)
+46 ; Pch 73 moved EXPTYP into CIEN loop
+47 SET CIEN=""
FOR
SET CIEN=$ORDER(^LEX(757.02,"AMC",MCIEN,CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
+48 IF $PIECE($$CSYSMNEM($PIECE(^LEX(757.02,CIEN,0),U,3)),U,2)=LEXSRC
Begin DoDot:3
+49 SET CODE=$PIECE(^LEX(757.02,CIEN,0),U,2)
+50 SET (HIER,HIERNAM)=""
+51 IF LEXSUB'=""
Begin DoDot:4
+52 KILL LAR
+53 SET LAR=$$CODE(CODE,"SCT",,"LAR")
+54 SET HIER=$PIECE($GET(LAR(0)),U,2)
+55 SET HIERNAM=$PIECE(^LEXT(757.2,$ORDER(^LEXT(757.2,"AA",LEXSUB,"")),0),U)
End DoDot:4
+56 IF LEXSUB'=""
IF HIER'=HIERNAM
QUIT
+57 SET FOUND=1
+58 SET FINDS=FINDS+1
+59 ; Pch 73 adds counter for multiple entries for code
SET CODEC=$ORDER(LEXW(CODE," "),-1)+1
+60 ; Pch 73 moved from EXIEN loop
SET EXPTYP=$PIECE(^LEX(757.011,$PIECE(^LEX(757.01,+($GET(^LEX(757.02,CIEN,0))),1),U,2),0),U)
+61 ; Pch 73 adds code IEN and expression IEN to output
SET LEXW(CODE,CODEC)=EXPTYP_"^"_CIEN_"^"_+($GET(^LEX(757.02,CIEN,0)))
End DoDot:3
End DoDot:2
End DoDot:1
+62 MERGE LEX=LEXW
+63 IF $DATA(LEXRAY)
IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
+64 QUIT FOUND_"^"_FINDS
+65 ;
CSYSIEN(MNEM) ; Return code system IEN for mnemonic
+1 IF '$LENGTH($GET(MNEM))
QUIT "-1^invalid code system"
NEW LEXIEN
+2 SET LEXIEN=+($$CSYS^LEXU(MNEM))
IF LEXIEN>0
QUIT "1^"_LEXIEN
+3 QUIT "-1^code system unknown in Lexicon"
+4 ;
CSYSMNEM(SIEN) ; Return code system mnemonic for IEN
+1 SET SIEN=+($$CSYS^LEXU($GET(SIEN)))
+2 IF '$DATA(^LEX(757.03,+($GET(SIEN)),0))
QUIT "-1^code system unknown in Lexicon"
+3 QUIT "1^"_$EXTRACT($PIECE(^LEX(757.03,SIEN,0),"^"),1,3)
+4 ;
INTDAT(X) ; Convert date from external format to VA internal format
+1 NEW Y,%DT
+2 DO ^%DT
+3 QUIT Y
