- 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 Jan 18, 2025@03:10:41 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