Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXTRAN

LEXTRAN.m

Go to the documentation of this file.
  1. LEXTRAN ;ISL/KER - Lexicon code and text wrapper API's ;12/19/2014
  1. ;;2.0;LEXICON UTILITY;**41,59,73,80,86**;Sep 23, 1996;Build 1
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.011) N/A
  1. ; ^TMP("LEXSCH") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; ^%DT ICR 10003
  1. ; $$GET1^DIQ ICR 2056
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$UP^XLFSTR ICR 10104
  1. ;
  1. CODE(CODE,SRC,CDT,LEXRAY,IENS,ID,INC) ; Get the Concept for a Code and Source
  1. ;
  1. ; Input
  1. ;
  1. ; CODE Code (required)
  1. ; SRC Code System source abbreviation (required)
  1. ; CDT Effective Date (optional, default TODAY)
  1. ; LEXRAY Output array (optional, defaults to 'LEX')
  1. ; IENS Include expression IENs in output array
  1. ; - optional
  1. ; 1 return IENS (2nd piece)
  1. ; 0 do not return IENS (default)
  1. ; ID Designation Identifiers
  1. ; - optional
  1. ; 1 return Designation IDs (3rd piece)
  1. ; 0 do not return Designation IDs (default)
  1. ; INC Include Deactivated Expressions
  1. ; - optional
  1. ; 1 return Deactivated Expressions
  1. ; 0 do not return Deactivated Expressions (default)
  1. ;
  1. ; Output
  1. ;
  1. ; if call finds an active code for the source
  1. ; "1^LEXCODE"
  1. ; LEX - an array containing information about the code
  1. ; LEX(0) - a five piece string:
  1. ; 1. code
  1. ; 2. hierarchy
  1. ; 3. version
  1. ; 4. legacy code
  1. ; 5. code status
  1. ; LEX("F") fully specified name
  1. ; LEX("P") preferred term
  1. ; LEX("S",n) synonyms (n is the nth synonym)
  1. ;
  1. ; if call cannot find specified code on file
  1. ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
  1. ; where LEXSCNM is the source name
  1. ; LEXCODE is the code
  1. ;
  1. ; if call finds an inactive code for the source
  1. ; "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
  1. ; where LEXSCNM is the source name
  1. ; LEXCODE is the code
  1. ; LEXVDT is the versioning date
  1. ;
  1. ; LEX - an array containing information about the code
  1. ; LEX(0) - a five piece string:
  1. ; 1. code
  1. ; 2. hierarchy
  1. ; 3. version
  1. ; 4. legacy code
  1. ; 5. code status
  1. ;
  1. ; otherwise
  1. ; "-1^error text"
  1. ;
  1. ; example of LEX array:
  1. ; LEX(0)="67922002^Substance^20050701^T-C2500^1"
  1. ; LEX("F")="Serum (Substance)"
  1. ; LEX("P")="Serum"
  1. ;
  1. N LEXCODE,LEXSRC,LEXVDT,LEXIENS,LEXDID,LEXINC
  1. S LEXCODE=$G(CODE),LEXSRC=$G(SRC),LEXVDT=$G(CDT)
  1. I $G(LEXCODE)="" Q "-1^no code specified"
  1. S LEXIENS=$G(IENS),LEXDID=$G(ID),LEXINC=+($G(INC))
  1. S LEXSRC=$E($G(LEXSRC),1,3) I $G(LEXSRC)="" Q "-1^no source specified"
  1. I +($$CSYS^LEXU(LEXSRC))'>0 Q "-1^source not recognized"
  1. I $D(^TMP("LEXSCH",$J,"VDT",0)) S LEXVDT=^(0)
  1. D:'$L($G(LEXVDT)) VDT^LEXU
  1. I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
  1. I $G(LEXVDT)=-1 Q "-1^invalid date format"
  1. I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
  1. I $G(LEXRAY)="" K LEXRAY
  1. N LEXSCNM,LEXSIEN,LEXASAB,LEXCIEN,VALCODE,LEXSTAT,LEXPIEN,LEXST
  1. S LEXSIEN=+($$CSYS^LEXU(LEXSRC))
  1. S LEXST=^LEX(757.03,LEXSIEN,0)
  1. S LEXSCNM=$P(LEXST,U,2)
  1. S LEXASAB=$E($P(LEXST,U),1,3)
  1. S LEXCIEN="",VALCODE=0
  1. F Q:VALCODE=1 D Q:LEXCIEN=""
  1. .S LEXCIEN=$O(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN)) Q:LEXCIEN="" D
  1. .I $D(^LEX(757.02,"ASRC",LEXASAB,LEXCIEN)) S VALCODE=1 Q
  1. I 'VALCODE Q "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
  1. K LEXSTAT,LEX
  1. K ^TMP("LEXSCH",$J)
  1. S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$E($G(LEXSRC),1,3)) ; Pch 73 adds parameter LEXSRC
  1. I +LEXSTAT=0 D Q "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
  1. .S LEXPIEN=$P(LEXSTAT(1),U)
  1. .D GETINFO
  1. .I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
  1. S LEXPIEN=$P(LEXSTAT(1),U)
  1. D GETINFO
  1. I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
  1. Q "1^"_LEXCODE
  1. ;
  1. GETINFO ; Get Information for a Code
  1. N LEXFSN,LEXHIER,LEXLGY,LEXVER,N,LEXSEP,I
  1. S LEXSRC=$E($G(LEXSRC),1,3)
  1. S LEX=$$GETSYN^LEXTRAN1(LEXSRC,LEXCODE,LEXVDT,,$G(LEXIENS),$G(LEXDID),$G(LEXINC))
  1. S LEXLGY=$$GET1^DIQ(757.02,LEXCIEN_",",13)
  1. I $D(LEX("F")) S LEXHIER=$P($P(LEX("F"),"(",$L(LEX("F"),"(")),")")
  1. S LEXVER=$$VERSION(LEXSRC,LEXCODE,LEXVDT)
  1. S LEX(0)=LEXCODE_U_$G(LEXHIER)_U_$S(+LEXVER=-1:"",1:$P(LEXVER,U,3))
  1. S LEX(0)=LEX(0)_U_LEXLGY_U_+LEXSTAT
  1. I $D(LEX("F")) S LEXHIER=$P($P(LEX("F"),"(",$L(LEX("F"),"(")),")")
  1. K LEX("SEL")
  1. Q
  1. ;
  1. TEXT(TEXT,CDT,SUB,SRC,LEXRAY) ; Get the Concept for a text and source
  1. ;
  1. ; Input
  1. ;
  1. ; TEXT The search string (required)
  1. ; CDT Effective date (optional, default is TODAY)
  1. ; SUB Subset or 'hierarchy' (optional)
  1. ; SRC Code System source abbreviation
  1. ; LEXRAY Output array (optional, defaults to 'LEX')
  1. ;
  1. ; Output
  1. ;
  1. ; LEX or passed array name - an array containing information
  1. ; about the code
  1. ; LEX(0) - a five piece string:
  1. ; 1. code
  1. ; 2. hierarchy
  1. ; 3. version
  1. ; 4. legacy code
  1. ; 5. code status
  1. ;
  1. ; LEX("F") fully specified name ^ internal entry number
  1. ; LEX("P") preferred term ^ internal entry number
  1. ; LEX("S",n) synonyms (n is the nth synonym) ^ internal entry number
  1. ;
  1. ; otherwise
  1. ; "-1^error text"
  1. ;
  1. ; example of LEX array:
  1. ; LEX(0)="67922002^Substance^20050701^T-C2500^1"
  1. ; LEX("F")="Serum (Substance)"
  1. ; LEX("P")="Serum"
  1. ;
  1. N LEXTEXT,LEXVDT,LEXDT,LEXTD,LEXSUB,LEXSRC,LEXNOM,LEXID,DIC K LEX
  1. S LEXTEXT=$G(TEXT),LEXVDT=$G(CDT),LEXSUB=$G(SUB),LEXSRC=$G(SRC)
  1. I $G(LEXTEXT)="" Q "-1^no search string specified"
  1. S LEXSRC=$P($$CSYS^LEXU(LEXSRC),"^",2),LEXNOM=""
  1. S:$L(LEXSRC) LEXNOM=$P($G(^LEX(757.03,+($O(^LEX(757.03,"ASAB",LEXSRC,0))),0)),"^",2)
  1. I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
  1. I $G(LEXVDT)=-1 Q "-1^invalid date format"
  1. I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
  1. S LEXDT=LEXVDT,LEXSUB=$G(LEXSUB) I LEXSUB="" S LEXSUB=LEXSRC
  1. K:$G(LEXRAY)="" LEXRAY
  1. N X,LEXPIEN,LEXCODE,LEXSTAT,LEXCIEN,Y
  1. K ^TMP("LEXSCH",$J),LEX S X=LEXTEXT
  1. D CONFIG^LEXSET(LEXSRC,LEXSUB,LEXVDT)
  1. S LEXVDT=LEXDT D EN^LEXA1 Q:+($G(Y))=-1 "-1^search could not find term"
  1. S LEXPIEN=+Y D INFO^LEXA(LEXPIEN) S LEXCODE="",LEXSTAT=-1 I $L(LEXNOM) D
  1. . S LEXID=$O(LEX("SEL","SRC","B",LEXNOM,0))
  1. . S LEXCODE=$P($G(LEX("SEL","SRC",+LEXID)),"^",2)
  1. I '$L(LEXCODE),$D(LEX("SEL","SRC","C")) D
  1. . S LEXCODE=$O(LEX("SEL","SRC","C",""))
  1. S LEXCIEN=0 I $L(LEXCODE) D
  1. . S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$E(LEXSRC,1,3))
  1. . S LEXCIEN=$P(LEXSTAT,U,2),LEXSRC=$E($P($G(LEXSTAT(2)),U,2),1,3)
  1. D GETINFO
  1. I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
  1. Q "1^"_LEXPIEN
  1. ;
  1. VERSION(SRC,CODE,VDT) ; Get the Code Version Number
  1. ;
  1. ; Input
  1. ;
  1. ; SRC Code System source abbreviation e.g. SCT (SNOMED CT)
  1. ; CODE Code - mandatory
  1. ; VDT Effective date (defaults to current date) - optional
  1. ; - optional
  1. ;
  1. ; Output
  1. ;
  1. ; 1^Version
  1. ; or
  1. ; -1^error message
  1. ;
  1. N LEXSRC,LEXCODE,LEXVDT S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(VDT)
  1. I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
  1. I $G(LEXVDT)=-1 Q "-1^invalid date format"
  1. I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
  1. S LEXSRC=$E($G(LEXSRC),1,3) I $G(LEXSRC)="" Q "-1^invalid source"
  1. N SIEN,VIEN,VDAT,LEXSTAT
  1. S SIEN=+($$CSYS^LEXU(LEXSRC))
  1. I '$D(^LEX(757.03,+SIEN,1)) Q "-1^No source version data available"
  1. S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,$E($G(LEXSRC),1,3)) ; Pch 73 adds parameter LEXSRC
  1. I +LEXSTAT=0 Q "-1^Code not active for date specified"
  1. S VDAT=$O(^LEX(757.03,SIEN,1,"B",LEXVDT+1),-1)
  1. S VIEN=$O(^LEX(757.03,SIEN,1,"B",VDAT,""))
  1. Q "1^"_^LEX(757.03,SIEN,1,VIEN,0)
  1. ;
  1. TXT4CS(TEXT,SRC,LEXRAY,SUB) ; Is text valid for an SCT code
  1. ;
  1. ; Input
  1. ;
  1. ; TEXT Text to check
  1. ; SRC Coding System Mnemonic or IEN
  1. ; LEXRAY Output array (optional, defaults to 'LEX')
  1. ; SUB Subset or 'hierarchy' (optional)
  1. ;
  1. ; Output
  1. ;
  1. ; 1^no of finds
  1. ;
  1. ; plus
  1. ;
  1. ; LEX or passed array name - an array containing
  1. ;
  1. ; LEX(<code>,<seq>)= expression type ^ code IEN ^ expression IEN
  1. ;
  1. ; e.g. LEX(123.5,1)="MAJOR CONCEPT^119085^112525"
  1. ; LEX(123.5,2)="SYNONYM^119094^112526"
  1. ; or
  1. ;
  1. ; -1^error message
  1. ;
  1. N LEXTEXT,LEXSRC,LEXSUB S LEXTEXT=$G(TEXT),LEXSRC=$G(SRC),LEXSUB=$G(SUB)
  1. N CODEC,EXP,EXIEN,MCIEN,FOUND,CIEN,CODE,EXPTYP,FINDS,LAR,HIER,HIERNAM,LEXW ; Pch 73 adds variable CODEC
  1. I $G(LEXTEXT)="" Q "-1^text not specified"
  1. I $G(LEXSRC)="" Q "-1^code system not specified"
  1. I $$CSYSIEN(LEXSRC)+$$CSYSMNEM(LEXSRC)=-2 Q "-1^code system unknown in Lexicon"
  1. I $G(LEXRAY)="" K LEXRAY
  1. S LEXSUB=$G(LEXSUB)
  1. I LEXSUB'="",'$D(^LEXT(757.2,"AA",LEXSUB)) Q "-1^hierarchy unknown in Lexicon"
  1. S:LEXSRC?.N LEXSRC=$P($$CSYSMNEM(LEXSRC),"^",2)
  1. ; text IEN's in 757.01
  1. I '$D(^LEX(757.01,"B",$E($$UP^XLFSTR(LEXTEXT),1,63))) Q "-1^expression unknown in Lexicon"
  1. ; build an array of expression IENs for text
  1. S EXIEN=""
  1. F S EXIEN=$O(^LEX(757.01,"B",$E($$UP^XLFSTR(LEXTEXT),1,63),EXIEN)) Q:EXIEN="" D ; Pch 73 adds $Extract
  1. .S:$$UP^XLFSTR($G(^LEX(757.01,+EXIEN,0)))=$$UP^XLFSTR(LEXTEXT) EXP(EXIEN)="" ; Pch 73 adds exact match check
  1. ; scan array to find code for expression (LEXTEXT) for code system (LEXSRC)
  1. S EXIEN=""
  1. K LEXW
  1. S (FOUND,FINDS)=0
  1. F S EXIEN=$O(EXP(EXIEN)) Q:EXIEN="" D
  1. .S MCIEN=$P(^LEX(757.01,EXIEN,1),U)
  1. .; Pch 73 moved EXPTYP into CIEN loop
  1. .S CIEN="" F S CIEN=$O(^LEX(757.02,"AMC",MCIEN,CIEN)) Q:CIEN="" D
  1. ..I $P($$CSYSMNEM($P(^LEX(757.02,CIEN,0),U,3)),U,2)=LEXSRC D
  1. ...S CODE=$P(^LEX(757.02,CIEN,0),U,2)
  1. ...S (HIER,HIERNAM)=""
  1. ...I LEXSUB'="" D
  1. ....K LAR
  1. ....S LAR=$$CODE(CODE,"SCT",,"LAR")
  1. ....S HIER=$P($G(LAR(0)),U,2)
  1. ....S HIERNAM=$P(^LEXT(757.2,$O(^LEXT(757.2,"AA",LEXSUB,"")),0),U)
  1. ...I LEXSUB'="",HIER'=HIERNAM Q
  1. ...S FOUND=1
  1. ...S FINDS=FINDS+1
  1. ...S CODEC=$O(LEXW(CODE," "),-1)+1 ; Pch 73 adds counter for multiple entries for code
  1. ...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
  1. ...S LEXW(CODE,CODEC)=EXPTYP_"^"_CIEN_"^"_+($G(^LEX(757.02,CIEN,0))) ; Pch 73 adds code IEN and expression IEN to output
  1. M LEX=LEXW
  1. I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
  1. Q FOUND_"^"_FINDS
  1. ;
  1. CSYSIEN(MNEM) ; Return code system IEN for mnemonic
  1. Q:'$L($G(MNEM)) "-1^invalid code system" N LEXIEN
  1. S LEXIEN=+($$CSYS^LEXU(MNEM)) Q:LEXIEN>0 "1^"_LEXIEN
  1. Q "-1^code system unknown in Lexicon"
  1. ;
  1. CSYSMNEM(SIEN) ; Return code system mnemonic for IEN
  1. S SIEN=+($$CSYS^LEXU($G(SIEN)))
  1. I '$D(^LEX(757.03,+($G(SIEN)),0)) Q "-1^code system unknown in Lexicon"
  1. Q "1^"_$E($P(^LEX(757.03,SIEN,0),"^"),1,3)
  1. ;
  1. INTDAT(X) ; Convert date from external format to VA internal format
  1. N Y,%DT
  1. D ^%DT
  1. Q Y