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 ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**41,59,73,80**;Sep 23, 1996;Build 10
  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) ; 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.  ;   
  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.  ;     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 S LEXCODE=$G(CODE),LEXSRC=$G(SRC),LEXVDT=$G(CDT)
  1.  I $G(LEXCODE)="" Q "-1^no code specified"
  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)
  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,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^LEXU3(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 LEXSUB=$G(LEXSUB) I LEXSUB="" S LEXSUB=LEXSRC
  1.  I $G(LEXRAY)="" K LEXRAY
  1.  N X,LEXPIEN,LEXCODE,LEXSTAT,LEXCIEN,Y
  1.  K ^TMP("LEXSCH",$J),LEX
  1.  S X=LEXTEXT
  1.  D CONFIG^LEXSET(LEXSRC,LEXSUB,LEXVDT)
  1.  D EN^LEXA1
  1.  I +Y=-1 Q "-1^search could not find term"
  1.  S LEXPIEN=+Y
  1.  D INFO^LEXA(LEXPIEN)
  1.  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