LEXTRAN ;ISL/KER - Lexicon code and text wrapper API's ;12/19/2014
;;2.0;LEXICON UTILITY;**41,59,73,80,86**;Sep 23, 1996;Build 1
;
; 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,IENS,ID,INC) ; 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')
; IENS Include expression IENs in output array
; - optional
; 1 return IENS (2nd piece)
; 0 do not return IENS (default)
; ID Designation Identifiers
; - optional
; 1 return Designation IDs (3rd piece)
; 0 do not return Designation IDs (default)
; INC Include Deactivated Expressions
; - optional
; 1 return Deactivated Expressions
; 0 do not return Deactivated Expressions (default)
;
; 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
; where LEXSCNM is the source name
; LEXCODE is the code
; LEXVDT is the versioning date
;
; 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,LEXIENS,LEXDID,LEXINC
S LEXCODE=$G(CODE),LEXSRC=$G(SRC),LEXVDT=$G(CDT)
I $G(LEXCODE)="" Q "-1^no code specified"
S LEXIENS=$G(IENS),LEXDID=$G(ID),LEXINC=+($G(INC))
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,,$G(LEXIENS),$G(LEXDID),$G(LEXINC))
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,LEXDT,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^LEXU(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 LEXDT=LEXVDT,LEXSUB=$G(LEXSUB) I LEXSUB="" S LEXSUB=LEXSRC
K:$G(LEXRAY)="" LEXRAY
N X,LEXPIEN,LEXCODE,LEXSTAT,LEXCIEN,Y
K ^TMP("LEXSCH",$J),LEX S X=LEXTEXT
D CONFIG^LEXSET(LEXSRC,LEXSUB,LEXVDT)
S LEXVDT=LEXDT D EN^LEXA1 Q:+($G(Y))=-1 "-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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXTRAN 11314 printed Apr 09, 2024@21:11:06 Page 2
+1 ;;2.0;LEXICON UTILITY;**41,59,73,80,86**;Sep 23, 1996;Build 1
+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,IENS,ID,INC) ; 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 ; IENS Include expression IENs in output array
+9 ; - optional
+10 ; 1 return IENS (2nd piece)
+11 ; 0 do not return IENS (default)
+12 ; ID Designation Identifiers
+13 ; - optional
+14 ; 1 return Designation IDs (3rd piece)
+15 ; 0 do not return Designation IDs (default)
+16 ; INC Include Deactivated Expressions
+17 ; - optional
+18 ; 1 return Deactivated Expressions
+19 ; 0 do not return Deactivated Expressions (default)
+20 ;
+21 ; Output
+22 ;
+23 ; if call finds an active code for the source
+24 ; "1^LEXCODE"
+25 ; LEX - an array containing information about the code
+26 ; LEX(0) - a five piece string:
+27 ; 1. code
+28 ; 2. hierarchy
+29 ; 3. version
+30 ; 4. legacy code
+31 ; 5. code status
+32 ; LEX("F") fully specified name
+33 ; LEX("P") preferred term
+34 ; LEX("S",n) synonyms (n is the nth synonym)
+35 ;
+36 ; if call cannot find specified code on file
+37 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+38 ; where LEXSCNM is the source name
+39 ; LEXCODE is the code
+40 ;
+41 ; if call finds an inactive code for the source
+42 ; "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
+43 ; where LEXSCNM is the source name
+44 ; LEXCODE is the code
+45 ; LEXVDT is the versioning date
+46 ;
+47 ; LEX - an array containing information about the code
+48 ; LEX(0) - a five piece string:
+49 ; 1. code
+50 ; 2. hierarchy
+51 ; 3. version
+52 ; 4. legacy code
+53 ; 5. code status
+54 ;
+55 ; otherwise
+56 ; "-1^error text"
+57 ;
+58 ; example of LEX array:
+59 ; LEX(0)="67922002^Substance^20050701^T-C2500^1"
+60 ; LEX("F")="Serum (Substance)"
+61 ; LEX("P")="Serum"
+62 ;
+63 NEW LEXCODE,LEXSRC,LEXVDT,LEXIENS,LEXDID,LEXINC
+64 SET LEXCODE=$GET(CODE)
SET LEXSRC=$GET(SRC)
SET LEXVDT=$GET(CDT)
+65 IF $GET(LEXCODE)=""
QUIT "-1^no code specified"
+66 SET LEXIENS=$GET(IENS)
SET LEXDID=$GET(ID)
SET LEXINC=+($GET(INC))
+67 SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
IF $GET(LEXSRC)=""
QUIT "-1^no source specified"
+68 IF +($$CSYS^LEXU(LEXSRC))'>0
QUIT "-1^source not recognized"
+69 IF $DATA(^TMP("LEXSCH",$JOB,"VDT",0))
SET LEXVDT=^(0)
+70 if '$LENGTH($GET(LEXVDT))
DO VDT^LEXU
+71 IF $GET(LEXVDT)'=""
SET LEXVDT=$$INTDAT(LEXVDT)
+72 IF $GET(LEXVDT)=-1
QUIT "-1^invalid date format"
+73 IF $GET(LEXVDT)=""
SET LEXVDT=$$DT^XLFDT
+74 IF $GET(LEXRAY)=""
KILL LEXRAY
+75 NEW LEXSCNM,LEXSIEN,LEXASAB,LEXCIEN,VALCODE,LEXSTAT,LEXPIEN,LEXST
+76 SET LEXSIEN=+($$CSYS^LEXU(LEXSRC))
+77 SET LEXST=^LEX(757.03,LEXSIEN,0)
+78 SET LEXSCNM=$PIECE(LEXST,U,2)
+79 SET LEXASAB=$EXTRACT($PIECE(LEXST,U),1,3)
+80 SET LEXCIEN=""
SET VALCODE=0
+81 FOR
if VALCODE=1
QUIT
Begin DoDot:1
+82 SET LEXCIEN=$ORDER(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN))
if LEXCIEN=""
QUIT
Begin DoDot:2
End DoDot:2
+83 IF $DATA(^LEX(757.02,"ASRC",LEXASAB,LEXCIEN))
SET VALCODE=1
QUIT
End DoDot:1
if LEXCIEN=""
QUIT
+84 IF 'VALCODE
QUIT "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+85 KILL LEXSTAT,LEX
+86 KILL ^TMP("LEXSCH",$JOB)
+87 ; Pch 73 adds parameter LEXSRC
SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$EXTRACT($GET(LEXSRC),1,3))
+88 IF +LEXSTAT=0
Begin DoDot:1
+89 SET LEXPIEN=$PIECE(LEXSTAT(1),U)
+90 DO GETINFO
+91 IF $DATA(LEXRAY)
IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
End DoDot:1
QUIT "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
+92 SET LEXPIEN=$PIECE(LEXSTAT(1),U)
+93 DO GETINFO
+94 IF $DATA(LEXRAY)
IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
+95 QUIT "1^"_LEXCODE
+96 ;
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,,$GET(LEXIENS),$GET(LEXDID),$GET(LEXINC))
+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,LEXDT,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^LEXU(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 LEXDT=LEXVDT
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
SET X=LEXTEXT
+45 DO CONFIG^LEXSET(LEXSRC,LEXSUB,LEXVDT)
+46 SET LEXVDT=LEXDT
DO EN^LEXA1
if +($GET(Y))=-1
QUIT "-1^search could not find term"
+47 SET LEXPIEN=+Y
DO INFO^LEXA(LEXPIEN)
SET LEXCODE=""
SET LEXSTAT=-1
IF $LENGTH(LEXNOM)
Begin DoDot:1
+48 SET LEXID=$ORDER(LEX("SEL","SRC","B",LEXNOM,0))
+49 SET LEXCODE=$PIECE($GET(LEX("SEL","SRC",+LEXID)),"^",2)
End DoDot:1
+50 IF '$LENGTH(LEXCODE)
IF $DATA(LEX("SEL","SRC","C"))
Begin DoDot:1
+51 SET LEXCODE=$ORDER(LEX("SEL","SRC","C",""))
End DoDot:1
+52 SET LEXCIEN=0
IF $LENGTH(LEXCODE)
Begin DoDot:1
+53 SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$EXTRACT(LEXSRC,1,3))
+54 SET LEXCIEN=$PIECE(LEXSTAT,U,2)
SET LEXSRC=$EXTRACT($PIECE($GET(LEXSTAT(2)),U,2),1,3)
End DoDot:1
+55 DO GETINFO
+56 IF $DATA(LEXRAY)
IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
+57 QUIT "1^"_LEXPIEN
+58 ;
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
