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

LEXCODE.m

Go to the documentation of this file. 
  1. LEXCODE ;ISL/KER - Retrieval of IEN^Term based on Code ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**25,73,80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    None
  1.  ;               
  1.  ; External References
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMTE^XLFDT        ICR  10103
  1.  ;    $$UP^XLFSTR         ICR  10104
  1.  ;               
  1.  Q
  1.  ; Source Abbreviatioin (SAB) is 3 character mnemonics for a 
  1.  ; classification/coding system.  They can be found on the
  1.  ; "ASAB" Cross-Reference of the Coding Systems file 757.03.
  1.  ; Here are some of the more commonly used SABs:
  1.  ;                   
  1.  ;     SAB   Nomenclature  Source
  1.  ;     -----------------------------------------------------------
  1.  ;     ICD   ICD-9-CM      Int'l Class of Diseases, Diagnosis
  1.  ;     ICP   ICD-9 Proc    Int'l Class of Diseases, Procedures
  1.  ;     10D   ICD-10-CM     Int'l Class of Diseases, Diagnosis
  1.  ;     10P   ICD-10-PCS    Int'l Class of Diseases, Procedures
  1.  ;     CPT   CPT=4         Current Procedural Terminology
  1.  ;     CPC   HCPCS         Healthcare Common Procedure Codes
  1.  ;     SSC   Title 38      Service Connected Codes
  1.  ;     DS4   DSM-IV        Diag Manual of Mental Disorder
  1.  ;     SCT   SNOMED CT     SNOMED Clinical Terms
  1.  ;                   
  1.  Q
  1. EN(LEX,LEXVDT) ; Get terms associated with a Code
  1.  ;
  1.  ;   Input
  1.  ;                   
  1.  ;     LEX      (Required) Code
  1.  ;                        
  1.  ;     LEXVDT   (Optional) The date against which the codes 
  1.  ;              found by the search will be compared in order
  1.  ;              to determine whether the code is active or 
  1.  ;              inactive. If not passed, TODAY's date will 
  1.  ;              be used.
  1.  ;                   
  1.  ;    Output    Local Array LEXS 
  1.  ;
  1.  ;              LEXS(0)=Code
  1.  ;              LEXS(SAB,0)=Number of Terms found for SAB
  1.  ;              LEXS(SAB,0,"SAB")=Source Nomenclature ^ Name
  1.  ;              LEXS(SAB,#)=IEN file 757.01^Display Text (term)
  1.  ;              
  1.  ;              Example of returned array LEXS using code V62.4
  1.  ;                
  1.  ;              LEXS(0)="V62.4"
  1.  ;              LEXS("DS4",0)=1
  1.  ;              LEXS("DS4",0,"SAB")="DSM-IV^Diagnostic & 
  1.  ;                                  Statistical Manual of Mental
  1.  ;                                  Disorders"
  1.  ;              LEXS("DS4",1)="303722^Acculturation Problem"
  1.  ;              LEXS("ICD",0)=5
  1.  ;              LEXS("ICD",0,"SAB")="ICD-9-CM^International 
  1.  ;                                  Classification of Diseases,
  1.  ;                                  Diagnosis"
  1.  ;              LEXS("ICD",1)="111638^Social maladjustment"
  1.  ;              LEXS("ICD",2)="29696^Cultural Deprivation"
  1.  ;              LEXS("ICD",3)="100676^Psychosocial Deprivation"
  1.  ;              LEXS("ICD",4)="303722^Acculturation Problem"
  1.  ;              LEXS("ICD",5)="111507^Social Behavior
  1.  ;                   
  1.  K LEXS S LEX=$$UP^XLFSTR($G(LEX)) Q:'$L(LEX)
  1.  N LEXSRC,LEXSO,LEXO,LEXEXI,LEXEXP,LEXSAB,LEXDA,LEXPF,LEXINA,LEXSTA
  1.  N LEXND D VDT^LEXU S LEXVDT=$G(LEXVDT)
  1.  S LEXS(0)=LEX,LEXO=LEX_" ",LEXDA=0 Q:'$D(^LEX(757.02,"CODE",LEXO))
  1.  F  S LEXDA=$O(^LEX(757.02,"CODE",LEXO,LEXDA)) Q:+LEXDA=0  D CHK
  1.  D ASEM Q
  1. CHK ;   Check if Valid
  1.  N LEXPD,LEXPI,LEXPH,LEXEX
  1.  S LEXND=$G(^LEX(757.02,LEXDA,0)),LEXSO=$P(LEXND,"^",2) Q:LEXSO'=LEX
  1.  S LEXSRC=+($P(LEXND,"^",3)) Q:LEXSRC'>0
  1.  S LEXPD=$O(^LEX(757.02,+LEXDA,4,"B",(LEXVDT+.0001)),-1) Q:LEXPD'?7N
  1.  S LEXPI=$O(^LEX(757.02,+LEXDA,4,"B",LEXPD," "),-1) Q:+LEXPI'>0
  1.  S LEXPH=$G(^LEX(757.02,+LEXDA,4,+LEXPI,0)) Q:+($P(LEXPH,"^",2))'>0
  1.  S LEXEX=+LEXND Q:+LEXEX'>0  Q:'$D(^LEX(757.01,+LEXEX,0))
  1.  S LEXSAB=$E($G(^LEX(757.03,+LEXSRC,0)),1,3) Q:$L(LEXSAB)'=3
  1.  S LEXPF=+($P($G(^LEX(757.02,LEXDA,0)),"^",5))
  1.  S:LEXPF=1 LEXS(LEXSAB,"PRE")=LEXDA
  1.  S:LEXPF'=1 LEXS(LEXSAB,"OTH",LEXDA)=""
  1.  Q
  1. ASEM ;   Assemble List
  1.  Q:'$D(LEXS)  N LEXSAB,LEXCT,LEXDA,LEXEX,LEXEXP,LEXY S LEXSAB=""
  1.  F  S LEXSAB=$O(LEXS(LEXSAB)) Q:LEXSAB=""  S LEXCT=0 D
  1.  . N LEXSABT S LEXSABT=$O(^LEX(757.03,"ASAB",LEXSAB,0))
  1.  . S LEXSABT=$P($G(^LEX(757.03,+LEXSABT,0)),"^",2,3)
  1.  . I $D(LEXS(LEXSAB,"PRE")) D
  1.  . . S LEXDA=LEXS(LEXSAB,"PRE") D LEXY
  1.  . S LEXDA=0
  1.  . F  S LEXDA=$O(LEXS(LEXSAB,"OTH",LEXDA)) Q:+LEXDA=0  D LEXY
  1.  . I $L(LEXSAB) S:$D(^LEX(757.03,"ASAB",LEXSAB)) LEXS(LEXSAB,0)=LEXCT
  1.  . I $L($P($G(LEXSABT),"^",1)),$L($P($G(LEXSABT),"^",1)) D
  1.  . . S LEXS(LEXSAB,0,"SAB")=LEXSABT
  1.  Q
  1. LEXY ;   Get IEN^TERM for Code X
  1.  Q:+($G(LEXDA))'>0  Q:'$D(^LEX(757.02,+LEXDA,0))
  1.  K LEXS(LEXSAB,"OTH",LEXDA) K LEXS(LEXSAB,"PRE")
  1.  S LEXY="" N LEXEXI,LEXEXP
  1.  S LEXEXI=+($P($G(^LEX(757.02,+LEXDA,0)),"^",1)) Q:+LEXEXI'>0
  1.  Q:'$L($G(^LEX(757.01,+LEXEXI,0)))
  1.  S LEXEXP=$G(^LEX(757.01,+LEXEXI,0)),LEXCT=LEXCT+1
  1.  S LEXY=LEXEXI_"^"_LEXEXP,LEXS(LEXSAB,LEXCT)=LEXY
  1.  Q
  1.  ;          
  1. CODE(X,LEXVDT,LEXSAB) ; Code for an Expression and Source
  1.  ; 
  1.  ; Similar to $$ICDDX^ICDEX
  1.  ;            $$ICDOP^ICDEX
  1.  ;            $$CPT^ICPTCOD
  1.  ;            $$DX^ICDXCD
  1.  ;            $$PR^ICDXCD
  1.  ;            
  1.  ;            Except the data comes from the Lexicon and
  1.  ;            can be used for any source in file 757.03 and
  1.  ;            is not limited to ICD-9, ICD-10 and CPT.
  1.  ;            
  1.  ; Input
  1.  ; 
  1.  ;    X       Pointer to an Expression in file 757.01
  1.  ;    LEXVDT  Versioning Date
  1.  ;    LEXSAB  Source Abbreviation
  1.  ;   
  1.  ; Output     A 11 piece "^" delimited string
  1.  ; 
  1.  ;    1  IEN of Code          File ^LEX(757.02)
  1.  ;    2  Code                 File ^LEX(757.02) Field #1
  1.  ;    3  Expression           Pointer to ^LEX(757.01)
  1.  ;    4  Concept Expression   Pointer to ^LEX(757.01)
  1.  ;    5  Source               Pointer ^LEX(757.03)
  1.  ;    6  Preference           File ^LEX(757.02) Field #4
  1.  ;    7  Primary              File ^LEX(757.02) Field #6
  1.  ;    8  Status on date       4 multiple
  1.  ;    9  Inactive Date        4 multiple
  1.  ;   10  Active Date          4 multiple
  1.  ;   11  Source Nomenclature  File ^LEX(757.03) Field #1
  1.  ;    
  1.  N LEXAC,LEXE,LEXEF,LEXEX,LEXEXI,LEXH,LEXHE,LEXHI,LEXHS,LEXI
  1.  N LEXIEN,LEXIENS,LEXIN,LEXMC,LEXMCE,LEXN,LEXNAM,LEXND,LEXO
  1.  N LEXS,LEXSO,LEXSOI,LEXSRC,LEXST,LEXTY S LEXO="",LEXEX=+($G(X))
  1.  Q:'$D(^LEX(757.01,+LEXEX,0)) "-1^Expression not found"
  1.  Q:$P($G(^LEX(757.01,+LEXEX,1)),"^",5)>0 "-1^Expression deactivated"
  1.  S LEXIENS(LEXEX)=""
  1.  S LEXMC=+($G(^LEX(757.01,+LEXEX,1))),LEXMCE=+($G(^LEX(757,+LEXMC,0)))
  1.  S LEXTY=$P($G(^LEX(757.01,+LEXEX,1)),"^",2)  I LEXTY=1 D
  1.  . N LEXMC,LEXI
  1.  . S LEXMC=+($G(^LEX(757.01,+LEXEX,1))),LEXI=0
  1.  . F  S LEXI=$O(^LEX(757.01,"AMC",+LEXMC,LEXI)) Q:+LEXI'>0  D
  1.  . . Q:$P($G(^LEX(757.01,+LEXI,1)),"^",5)>0
  1.  . . S:+LEXI>0 LEXIENS(+LEXI)=""
  1.  Q:$O(LEXIENS(0))'>0 "-1^Expression not found"
  1.  S LEXVDT=$G(LEXVDT) D VDT^LEXU
  1.  S LEXSAB=$G(LEXSAB),LEXSRC=$$SAB^LEXSRC2(LEXSAB)
  1.  Q:+LEXSRC'>0 "-1^Invalid Source specified"
  1.  S LEXNAM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2)
  1.  Q:'$L(LEXNAM) "-1^Invalid Source specified"
  1.  S LEXS=0,LEXO=""
  1.  S LEXIEN=0 F  S LEXIEN=$O(LEXIENS(LEXIEN)) Q:+LEXIEN'>0  D  Q:$L(LEXO)
  1.  . F  S LEXS=$O(^LEX(757.02,"B",+LEXEX,LEXS)) Q:+LEXS'>0  D  Q:$L(LEXO)
  1.  . . N LEXAC,LEXEF,LEXEXI,LEXHE,LEXHI,LEXHS,LEXIN,LEXND,LEXSOI,LEXST
  1.  . . S LEXND=$G(^LEX(757.02,+LEXS,0))
  1.  . . Q:$P(LEXND,"^",3)'=LEXSRC  S LEXEXI=+LEXND
  1.  . . S LEXHE=$O(^LEX(757.02,+LEXS,4,"B",(LEXVDT+.00001)),-1) Q:+LEXHE'>0
  1.  . . S LEXHI=$O(^LEX(757.02,+LEXS,4,"B",LEXHE," "),-1) Q:+LEXHI'>0
  1.  . . S LEXHS=$G(^LEX(757.02,+LEXS,4,+LEXHI,0)) S LEXST=+$P(LEXHS,"^",2)
  1.  . . S LEXEF=LEXHE,LEXSO=$P(LEXND,"^",2)
  1.  . . S LEXSOI=+LEXS S:LEXST>0 LEXAC=LEXEF S:LEXST'>0 LEXIN=LEXEF
  1.  . . I LEXST'>0,LEXIN?7N S LEXAC=$$PA(LEXS,LEXIN)
  1.  . . I LEXST'>0,LEXIN?7N,$G(LEXAC)'?7N Q
  1.  . . S LEXO=$G(LEXS)_"^"_$G(LEXSO)_"^"_$G(LEXEXI)_"^"_$G(LEXMCE)_"^"
  1.  . . S LEXO=LEXO_$G(LEXSRC)_"^"_$P(LEXND,"^",5)_"^"_$P(LEXND,"^",7)
  1.  . . S LEXO=LEXO_"^"_$G(LEXST)_"^"_$G(LEXIN)_"^"_$G(LEXAC)_"^"_LEXNAM
  1.  S X=LEXO S:+X'>0 X="-1^"_LEXNAM_" Code not found"
  1.  Q X
  1.  ;
  1. EXP(LEX,LEXS,LEXVDT) ; Get Preferred Expression for an Active Code
  1.  ;
  1.  ;   Input
  1.  ;
  1.  ;     LEX      (Required) Code
  1.  ;
  1.  ;     LEXS     (Required) This is either the three character
  1.  ;              Source Abbreviation (see list above) or a pointer
  1.  ;              to the Coding Systems file 757.03.
  1.  ;
  1.  ;     LEXVDT   (Optional) The date against which the codes 
  1.  ;              found by the search will be compared in order
  1.  ;              to determine whether the code is active or 
  1.  ;              inactive. If not passed, TODAY's date will 
  1.  ;              be used.
  1.  ;
  1.  ;   Output
  1.  ;
  1.  ;     $$EXP    2 Piece "^" delimited string containing
  1.  ;
  1.  ;              Either:
  1.  ;
  1.  ;                 1  Pointer to Expression file #757.01
  1.  ;                 2  Display Text (Expression)
  1.  ;
  1.  ;              or:
  1.  ;
  1.  ;                 1  -1
  1.  ;                 2  Error Message
  1.  ;
  1.  N LEXARY,LEXCDT,LEXCND,LEXEXP,LEXHI,LEXHND,LEXIN,LEXNOM,LEXORD,LEXPD
  1.  N LEXPF,LEXSB,LEXSI,LEXSR S (LEX,LEXIN)=$G(LEX)
  1.  Q:'$L(LEXIN) "-1^Code not passed"  S LEXS=$G(LEXS)
  1.  Q:'$L(LEXS) "-1^Source not passed"
  1.  S LEXSR=+($O(^LEX(757.03,"ASAB",LEXS,0)))
  1.  S LEXSB=$E($G(^LEX(757.03,+LEXSR,0)),1,3)
  1.  I +LEXSR'>0!($L(LEXSB)'=3) D
  1.  . S LEXSR=0,LEXSB=$E($G(^LEX(757.03,+LEXS,0)),1,3)
  1.  . S:$L(LEXSB) LEXSR=+($O(^LEX(757.03,"ASAB",LEXSB,0)))
  1.  Q:+LEXSR'>0!($L(LEXSB)'=3) "-1^Invalid source passed"
  1.  I '$D(^LEX(757.03,+LEXSR,0))!('$D(^LEX(757.03,"ASAB",LEXSB))) D  Q LEX
  1.  . S LEX="-1^Invalid source passed"
  1.  S LEXNOM=$P($G(^LEX(757.03,+LEXSR,0)),"^",2)
  1.  Q:'$L(LEXNOM) "-1^Invalid source on file"
  1.  S LEXORD=(LEXIN_" ") D VDT^LEXU S LEXCDT=$G(LEXVDT)
  1.  K LEXARY S LEXSI=" "
  1.  F  S LEXSI=$O(^LEX(757.02,"CODE",LEXORD,LEXSI),-1) Q:+LEXSI'>0  D
  1.  . N LEXCND,LEXHND,LEXPD,LEXHI,LEXPF
  1.  . S LEXCND=$G(^LEX(757.02,+LEXSI,0)) Q:$P(LEXCND,"^",3)'=LEXSR
  1.  . S LEXPD=$O(^LEX(757.02,+LEXSI,4,"B",(LEXCDT+.0009)),-1) Q:LEXPD'?7N
  1.  . S LEXHI=$O(^LEX(757.02,+LEXSI,4,"B",LEXPD," "),-1) Q:+LEXHI'>0
  1.  . S LEXHND=$G(^LEX(757.02,+LEXSI,4,+LEXHI,0)) Q:$P(LEXHND,"^",2)'>0
  1.  . S LEXPF=+($P($G(^LEX(757.02,+LEXSI,0)),"^",5)) Q:LEXPF'>0
  1.  . S LEXARY(LEXSI,0)=LEXCND,LEXARY(LEXSI,4)=LEXHND
  1.  I $O(LEXARY(0))'>0 D  Q LEX
  1.  . N LEXC S LEXC=LEX
  1.  . S LEX="-1^Active code/expression not found for "_LEXNOM_" code "
  1.  . S LEX=LEX_LEXC_" on "_$$FMTE^XLFDT(LEXCDT,"5Z")
  1.  I $O(LEXARY(0))'=$O(LEXARY(" "),-1) D  Q LEX
  1.  . N LEXC S LEXC=LEX
  1.  . S LEX="-1^Multiple active preferred expressions for "_LEXNOM
  1.  . S LEX=LEX_" code "_LEXC_" on "_$$FMTE^XLFDT(LEXCDT,"5Z")
  1.  S LEXEXP=$O(LEXARY(0)),LEXEXP=+($G(LEXARY(+LEXEXP,0)))
  1.  Q:'$D(^LEX(757.01,+LEXEXP)) ("-1^Expression not found in file 757.01")
  1.  S LEX=LEXEXP_"^"_$P($G(^LEX(757.01,+LEXEXP,0)),"^",1)
  1.  Q LEX
  1.  ;
  1.  ; Miscellaneous
  1. PA(X,Y) ;   Previous Activation Date
  1.  N LEX,LEXA,LEXE,LEXI,LEXN S LEX=+($G(X)),LEXI=$G(Y)
  1.  Q:'$D(^LEX(757.02,LEXS,4))  Q:LEXI'?7N ""
  1.  S LEXA="",LEXE=LEXI+.000001
  1.  F  S LEXE=$O(^LEX(757.02,+LEX,4,"B",LEXE),-1) Q:+LEXE'>0  D
  1.  . Q:LEXA?7N  S LEXH=" "
  1.  . F  S LEXH=$O(^LEX(757.02,+LEX,4,"B",LEXE,LEXH),-1) Q:+LEXH'>0  D
  1.  . . Q:LEXA?7N  N LEXN S LEXN=$G(^LEX(757.02,+LEX,4,+LEXH,0))
  1.  . . S:$P(LEXN,"^",2)>0 LEXA=LEXE
  1.  S X="" S:LEXA?7N X=LEXA
  1.  Q X