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

LEXTRAN1.m

Go to the documentation of this file. 
  1. LEXTRAN1 ;ISL/KER - Lexicon code and text wrapper API's ;05/23/2017
  1.  ;;2.0;LEXICON UTILITY;**59,73,51,80,86,103**;Sep 23, 1996;Build 2
  1.  ;
  1.  ; Global Variables
  1.  ;    ^LEX(757.32)        N/A
  1.  ;    ^LEX(757.33)        N/A
  1.  ;    ^TMP("LEXSCH")      SACC 2.3.2.5.1
  1.  ;
  1.  ; External References
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMTE^XLFDT        ICR  10103
  1.  ;    $$GET1^DIQ          ICR   2056
  1.  ;    $$UP^XLFSTR         ICR  10103
  1.  ;    ^%DT                ICR  10003
  1.  ;
  1. GETSYN(SRC,CODE,CDT,LEXARY,IENS,ID,INC) ; Get Synonyms for a Concept
  1.  ;
  1.  ; Local Variables
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;   SRC     Coding Sys (required)
  1.  ;   CODE    Code (required)
  1.  ;   CDT     Effective date (default TODAY)
  1.  ;   LEXARY  Output array (defaults to 'LEX')
  1.  ;   IENS    Include expression IENs in output array (optional)
  1.  ;              1 return IENS (2nd piece)
  1.  ;              0 do not return IENS (default)
  1.  ;   ID      Designation Identifiers (optional)
  1.  ;              1 return Designation IDs (3rd piece)
  1.  ;              0 do not return Designation IDs (default)
  1.  ;   INC     Include Deactivated Terms (optional)
  1.  ;              1 return Deactivated Terms
  1.  ;              0 do not return Deactivated Terms (default)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   If call finds an active code for the source
  1.  ;     "1^LEXCODE"
  1.  ;     LEX               An array containing code information
  1.  ;     LEX("F")          Fully Specified Name^IEN^Designation ID
  1.  ;     LEX("P")          Preferred Term^IEN^Designation ID
  1.  ;     LEX("S",n)        Synonyms 4 Piece ^ Delimited string
  1.  ;                          1  Synonym (required)
  1.  ;                          2  IEN (optional)
  1.  ;                          3  Designation ID (optional)
  1.  ;                          4  Deactivation flag (optional)
  1.  ;                               1 = Deactivated Synonym
  1.  ;                              
  1.  ;                       n is the nth Synonym
  1.  ;
  1.  ;   Errors:
  1.  ;   
  1.  ;     "-1^Code "_LEXCODE_" not yet active for "_LEXVDT
  1.  ;         where LEXCODE is the code
  1.  ;               LEXVDT is the versioning date
  1.  ;             
  1.  ;     "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
  1.  ;         where LEXSCNM is the source name
  1.  ;               LEXCODE is the code
  1.  ;
  1.  ;     "-4^"_LEXSNM_" 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.  ;   Otherwise
  1.  ;     "-1^error text"
  1.  ;
  1.  N LEX2,LEX3,LEX4,LEXC,LEXCIEN,LEXCODE,LEXDEA,LEXDID,LEXEFD,LEXEX,LEXEXI,LEXFND,LEXIAD,LEXID
  1.  N LEXIENS,LEXINC,LEXMCI,LEXN1,LEXOUT,LEXSAB,LEXSNM,LEXSRC,LEXSRD,LEXSTAT,LEXTY,LEXVDT
  1.  ; Get Input Parameters
  1.  S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT),LEXIENS=$G(IENS),LEXDID=$G(ID),LEXINC=+($G(INC))
  1.  ; Verify Input Parameters
  1.  S LEXSRD=$$CSYS^LEXU(LEXSRC),LEXSAB=$P(LEXSRD,"^",2),LEXSNM=$P(LEXSRD,"^",4),LEXSRC=+LEXSRD
  1.  Q:+LEXSRC'>0!($L(LEXSAB)'=3)!('$L(LEXSNM)) (-1_U_"source not recognized")
  1.  Q:'$L($G(LEXCODE)) -1_U_"no code specified"
  1.  D VDT^LEXU Q:$P(LEXVDT,".",1)'?7N (-1_U_"invalid date format")
  1.  S LEXOUT=0 S:'$L($G(LEXARY)) LEXARY="LEX"
  1.  S LEXIENS=+$G(LEXIENS) S:LEXIENS'=1 LEXIENS=0
  1.  S LEXDID=+$G(LEXDID) S:LEXDID'=1 LEXDID=0
  1.  S LEXINC=+$G(LEXINC) S:LEXINC'=1 LEXINC=0
  1.  ; Get Code IEN, Status, Effective Date and Initial Activation Date
  1.  S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,LEXSAB)
  1.  S LEXCIEN=$P(LEXSTAT,"^",2),LEXEFD=$P(LEXSTAT,"^",3),LEXIAD=$P(LEXSTAT,"^",4),LEXSTAT=+LEXSTAT
  1.  ; Quit Conditions
  1.  ;   Code not found
  1.  I +LEXCIEN<0 Q (-2_U_LEXSNM_" code "_LEXCODE_" not on file")
  1.  ;   No Effective Date (pending activation)
  1.  I +LEXCIEN>0,LEXSTAT'>0,LEXEFD'?7N,LEXIAD'?7N D  Q:LEXINC'>0 LEXOUT
  1.  . S LEXOUT="-4^"_LEXSNM_" code "_LEXCODE_" not yet active for "_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
  1.  ;   Inactive Code
  1.  I +LEXCIEN>0,LEXSTAT'>0,LEXEFD?7N D  Q:LEXINC'>0 LEXOUT
  1.  . S LEXOUT="-4^"_LEXSNM_" code "_LEXCODE_" not active for "_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
  1.  ; Get Terms for the Major Concept
  1.  S LEXMCI=$P(^LEX(757.02,+LEXCIEN,0),U,4),LEXEXI="",LEXFND=0
  1.  K LEX2 F  S LEXEXI=$O(^LEX(757.01,"AMC",LEXMCI,LEXEXI)) Q:LEXEXI=""  D
  1.  . S LEXFND=LEXFND+1,LEX2(LEXEXI)=""
  1.  ; Get Info for Terms
  1.  K LEX3 S LEXEXI="" F  S LEXEXI=$O(LEX2(LEXEXI)) Q:LEXEXI=""  D
  1.  . N LEXN1,LEXID,LEXC,LEXDEA S LEXEX=^LEX(757.01,LEXEXI,0),LEXDEA=0
  1.  . S LEXN1=$G(^LEX(757.01,LEXEXI,1)) Q:+($G(LEXINC))'>0&($P(LEXN1,"^",5)>0)
  1.  . S:+($G(LEXINC))>0&($P(LEXN1,"^",5)>0) LEXDEA=1
  1.  . S LEXID="" I LEXDID>0 D
  1.  . . S LEXID=$O(^LEX(757.01,LEXEXI,7,"C",+LEXSRC,""))
  1.  . S LEXTY=$P(^LEX(757.01,LEXEXI,1),U,2)
  1.  . I LEXTY=1 D  Q
  1.  . . S LEX3("P")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") S:$L(LEXID) $P(LEX3("P"),"^",3)=LEXID
  1.  . I LEXTY=8 D  Q
  1.  . . S LEX3("F")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") S:$L(LEXID) $P(LEX3("F"),"^",3)=LEXID
  1.  . S LEXC=$O(LEX3("S"," "),-1)+1
  1.  . S LEX3("S",LEXC)=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"")
  1.  . S:$L(LEXID) $P(LEX3("S",LEXC),"^",3)=LEXID
  1.  . S:LEXDEA>0 $P(LEX3("S",LEXC),"^",4)=1
  1.  K LEX4 M LEX4=LEX3
  1.  S LEXFND=''$D(LEX4("F"))+''$D(LEX4("P"))+$O(LEX4("S"," "),-1)
  1.  I $D(LEXARY),LEXARY'="LEX4" M @LEXARY=LEX4
  1.  K LEX4 I LEXOUT=0 S LEXOUT=''LEXFND_U_LEXFND
  1.  Q LEXOUT
  1.  ;
  1. GETDID(X,IEN) ; Get Designation ID based on Source and IEN
  1.  ; 
  1.  ; Input
  1.  ; 
  1.  ;   X         Coding Sys (required)
  1.  ;   IEN       IEN in the Expressions file #757.01 (required)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   $$GETDID  Designation ID
  1.  ;   
  1.  ;             Otherwise
  1.  ;             
  1.  ;             "-1^"_error message
  1.  ;             
  1.  S LEXSRC=$E($G(X),1,3),LEXIEN=$G(IEN) Q:+LEXIEN'>0 (-1_U_"IEN not specified")
  1.  Q:'$L(LEXSRC) (-1_U_"source not recognized")  Q:'$D(^LEX(757.01,+LEXIEN,0)) (-1_U_"Expression entry not found")
  1.  Q:$O(^LEX(757.01,+LEXIEN,7,0))'>0 (-1_U_"No designation IDs found")  S LEXSRD=$$CSYS^LEXU(LEXSRC)
  1.  Q:+LEXSRD'>0 (-1_U_"source not recognized")  S LEXSAB=$P(LEXSRD,"^",2),LEXSRC=+LEXSRD
  1.  Q:($L(LEXSAB)'=3)!(+LEXSRC'>0) (-1_U_"Invalid source")  Q:'$D(^LEX(757.03,"ASAB",LEXSAB)) (-1_U_"Invalid source")
  1.  Q:'$D(^LEX(757.03,LEXSRC,0)) (-1_U_"Invalid source")  S LEXID="",LEXIDI=0
  1.  F  S LEXIDI=$O(^LEX(757.01,+LEXIEN,7,LEXIDI)) Q:+LEXIDI'>0  D
  1.  . Q:$P($G(^LEX(757.01,+LEXIEN,7,+LEXIDI,0)),"^",2)'=LEXSRC  S LEXID=$P($G(^LEX(757.01,+LEXIEN,7,+LEXIDI,0)),"^",1)
  1.  S X=LEXID
  1.  Q X
  1.  ;
  1. GETFSN(SRC,CODE,CDT) ; Get Fully Specified Name for a Concept
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;   SRC   Coding Sys (required)
  1.  ;   CODE  Code (required)
  1.  ;   CDT   Effective date (default TODAY)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if found
  1.  ;     "1^"_fully specified name
  1.  ;   if error or not found
  1.  ;     "-1^"_error message
  1.  ;   if not found
  1.  ;     "-8^"_error message
  1.  ;       
  1.  N LEXSRC,LEXCODE,LEXVDT S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT)
  1.  N SYNS,LEX S LEXSRC=$E($G(LEXSRC),1,3)
  1.  I $G(LEXCODE)="" Q -1_U_"no code specified"
  1.  I $G(LEXSRC)="" Q -1_U_"no source specified"
  1.  I +($$CSYS^LEXU(LEXSRC))'>0 Q -1_U_"source not recognized"
  1.  I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
  1.  D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
  1.  I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
  1.  S SYNS=$$GETSYN(LEXSRC,LEXCODE,$G(LEXVDT))
  1.  I +SYNS'>0 Q SYNS
  1.  I $D(LEX("F")) Q 1_U_LEX("F")
  1.  Q -8_U_$$LEXSCNM(LEXSRC)_" code "_LEXCODE_" has no FSN"
  1.  ;
  1. GETPREF(SRC,CODE,CDT) ; Get the Preferred Term for a Code
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;   SRC    Coding System (required)
  1.  ;   CODE   Code (required)
  1.  ;   CDT    Effective date (optional, default TODAY)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if found
  1.  ;     "1^"_preferred name
  1.  ;   if error or not not found
  1.  ;     "-1^"_error message
  1.  ;
  1.  N LEXSRC,LEXCODE,LEXVDT S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT)
  1.  N SYNS,LEX S LEXSRC=$E($G(LEXSRC),1,3)
  1.  I $G(LEXCODE)="" Q -1_U_"no code specified"
  1.  I $G(LEXSRC)="" Q -1_U_"no source specified"
  1.  I +($$CSYS^LEXU(LEXSRC))'>0 Q -1_U_"source not recognized"
  1.  I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
  1.  D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
  1.  I $G(LEXVDT)=-1 Q -1_U_"invalid date format"
  1.  I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
  1.  S SYNS=$$GETSYN(LEXSRC,LEXCODE,$G(LEXVDT))
  1.  I +SYNS'>0 Q SYNS
  1.  Q 1_U_LEX("P")
  1.  ;
  1. GETDES(SRC,TEXT,CDT) ; Get the Designation Code for a Concept/Synonym
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;   SRC    Coding Sys (required)
  1.  ;   TEXT   Text (required)
  1.  ;   CDT    Effective date (default TODAY)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if found
  1.  ;     "1^"_designation code
  1.  ;   if error or not found
  1.  ;     "-1^"_error message
  1.  ;
  1.  N LEXSRC,LEXTEXT,LEXVDT S LEXSRC=$G(SRC),LEXTEXT=$G(TEXT),LEXVDT=$G(CDT)
  1.  N LEXA,LEXCIEN,LEXDSG,LEXIEN,LEXMC,LEXSAB,LEXSIEN,LEXSO
  1.  N LEXSR,LEXSRD,LEXSRI,LEXSUB,LEXTMP S LEXSRC=$E($G(LEXSRC),1,3)
  1.  S LEXSRD=$$CSYS^LEXU(LEXSRC),LEXSAB=$P(LEXSRD,"^",2)
  1.  S LEXSRI=+LEXSRD Q:$G(LEXSRC)="" -1_U_"no source specified"
  1.  Q:+LEXSRI'>0 -1_U_"source not recognized"
  1.  Q:'$L($G(LEXTEXT)) -1_U_"no text specified"
  1.  S LEXTMP=$G(^TMP("LEXSCH",$J,"VDT",0))
  1.  S:LEXTMP?7N LEXVDT=LEXTMP
  1.  I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
  1.  D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
  1.  S LEXSUB=$E($$UP^XLFSTR(LEXTEXT),1,63)
  1.  S LEXIEN=""
  1.  F  S LEXIEN=$O(^LEX(757.01,"B",LEXSUB,LEXIEN)) Q:LEXIEN=""  D
  1.  .I $$UP^XLFSTR(^LEX(757.01,LEXIEN,0))=$$UP^XLFSTR(LEXTEXT) S LEXA(LEXIEN)=$P(^LEX(757.01,LEXIEN,1),U)
  1.  S LEXIEN=""
  1.  F  S LEXIEN=$O(LEXA(LEXIEN)) Q:LEXIEN=""  D
  1.  . N LEXSR S LEXMC=LEXA(LEXIEN)
  1.  . S (LEXCIEN,LEXSIEN)=""
  1.  . F  S LEXSIEN=$O(^LEX(757.02,"AMC",LEXMC,LEXSIEN)) Q:LEXSIEN=""  D
  1.  . . S LEXSR=$P(^LEX(757.02,LEXSIEN,0),U,3)
  1.  . . I +($$CSYS^LEXU(LEXSRC))'=LEXSR Q
  1.  . . I $P(^LEX(757.02,LEXSIEN,0),U,5)'=1 Q
  1.  . . S LEXCIEN=LEXSIEN
  1.  . I LEXCIEN="" K LEXA(LEXIEN) Q
  1.  . S LEXSO=$P(^LEX(757.02,LEXCIEN,0),U,2)
  1.  . S LEXSR=$P(^LEX(757.02,LEXCIEN,0),U,3)
  1.  . I +($$CSYS^LEXU(LEXSRC))'=LEXSR K LEXA(LEXIEN) Q
  1.  . I '+$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,$E(LEXSRC,1,3)) K LEXA(LEXIEN) Q
  1.  S LEXIEN=$O(LEXA(""))
  1.  I LEXIEN="" Q -1_U_"text not recognized for source"
  1.  S LEXDSG=$O(^LEX(757.01,LEXIEN,7,"C",+LEXSRI,""))
  1.  I LEXDSG="" Q -1_U_"no designation code for text and source"
  1.  Q 1_U_LEXDSG
  1.  ;
  1. GETASSN(CODE,MAP,CDT,LEXRAY) ; Get Mapped Associated Codes
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;   CODE     Code (required)
  1.  ;   MAP      Mapping ID (VUID) or mnemonic (required)
  1.  ;   CDT      Effective date (default TODAY)
  1.  ;   LEXRAY   Output array (defaults 'LEX')
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if found
  1.  ;     "1^"_number_of_mappings
  1.  ;
  1.  ;     LEX is an array containing the target codes
  1.  ;     LEX = number of mappings
  1.  ;     LEX(order,code)  mapped codes
  1.  ;                      order - order of the mapping
  1.  ;                      code - target code
  1.  ;
  1.  ;   if not found     "0^0"
  1.  ;   if error        "-1^"_error_message
  1.  ;   if not on file  "-2^"_source _" code "_code_" not on file"
  1.  ;   
  1.  ;   Caution
  1.  ;   -------
  1.  ;   S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,[DATE],[ARR])
  1.  ;   
  1.  ;   Make sure that ARR'="VAR"
  1.  ;     S ORY=$$GETASSN^LEXTRAN1(CODE,MAP,,"VAR") is OK
  1.  ;     S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,,"VAR") is not OK
  1.  ; 
  1.  N LEXCODE,LEXMAP,LEXVDT S LEXCODE=$G(CODE),LEXMAP=$G(MAP),LEXVDT=$G(CDT)
  1.  I $G(LEXCODE)="" Q -1_U_"no code specified"
  1.  I $G(LEXMAP)="" Q -1_U_"no mapping specified"
  1.  I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
  1.  D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
  1.  S LEXRAY=$G(LEXRAY,"LEX")
  1.  N MIDIEN,CSYS,CIEN,VALCD,MORD,MTAR,MIEN,EFDT,STAT,CT,VUID
  1.  I '$D(^LEX(757.32,"B",LEXMAP)),'$D(^LEX(757.32,"C",LEXMAP)) Q -1_U_"unrecognized mapping identifier"
  1.  I $D(^LEX(757.32,"C",LEXMAP)) D
  1.  .S MIDIEN=$O(^LEX(757.32,"C",LEXMAP,""))
  1.  I $D(^LEX(757.32,"B",LEXMAP)) D
  1.  .S MIDIEN=$O(^LEX(757.32,"B",LEXMAP,""))
  1.  I '$D(MIDIEN) Q -1_U_"not a recognized mapping identifier"
  1.  S CSYS=$$GET1^DIQ(757.32,MIDIEN_",",3)
  1.  ;   Check that code exists for coding system
  1.  S CIEN="",VALCD=0
  1.  F  Q:VALCD=1  D  Q:CIEN=""
  1.  .S CIEN=$O(^LEX(757.02,"CODE",LEXCODE_" ",CIEN)) Q:CIEN=""  D
  1.  .S VALCD=''$D(^LEX(757.02,"ASRC",$$LEXASAB(CSYS),CIEN))
  1.  I 'VALCD Q -2_U_$$LEXSCNM(CSYS)_" code "_LEXCODE_" not on file"
  1.  ;   Obtain valid mappings for date
  1.  S (MORD,MTAR,MIEN)=""
  1.  K LEX
  1.  S LEX=0
  1.  F  S MORD=$O(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD)) Q:MORD=""  D
  1.  .F  S MTAR=$O(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR)) Q:MTAR=""  D
  1.  ..F  S MIEN=$O(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR,MIEN)) Q:MIEN=""  D
  1.  ...N MAT S MAT=$P($G(^LEX(757.33,+MIEN,0)),U,5)
  1.  ...S VUID=$P(^LEX(757.33,MIEN,0),U)
  1.  ...S EFDT=+$O(^LEX(757.33,"G",VUID,LEXVDT+.0001),-1)
  1.  ...Q:EFDT=0
  1.  ...S STAT=+$O(^LEX(757.33,"G",VUID,EFDT,""))
  1.  ...Q:STAT=0
  1.  ...S LEX=LEX+1
  1.  ...S LEX(MORD,MTAR)=MAT
  1.  I LEXRAY'="LEX" M @LEXRAY=LEX K LEX
  1.  Q ''@LEXRAY_U_@LEXRAY
  1.  ;
  1. LEXSCNM(LEXSRC) ; get source name
  1.  N LEXI Q:'$L(LEXSRC) ""  S LEXI=+($$CSYS^LEXU(LEXSRC))'>0 Q:LEXI'>0 ""
  1.  Q $P(^LEX(757.03,+LEXI,0),U,2)
  1.  ;
  1. LEXASAB(LEXSRC) ; get source abbreviation
  1.  N LEXI Q:'$L(LEXSRC) ""  S LEXI=+($$CSYS^LEXU(LEXSRC)) Q:LEXI'>0 ""
  1.  Q $E($P($G(^LEX(757.03,+LEXI,0)),U),1,3)
  1. CSI(LEXSRC) ; get source IEN
  1.  Q:'$L($E($G(LEXSRC),1,3)) -1  N LEXI S LEXI=+($$CSYS^LEXU(LEXSRC)) S:LEXI'>0 LEXI=-2
  1.  Q +LEXI
  1.  ;
  1. INTDAT(X) ; convert date from external format to VA internal format
  1.  S X=$G(X) Q:$P(X,".",1)?7N $P(X,".",1)
  1.  N Y,%DT D ^%DT K %DT
  1.  Q Y
  1.  ;
  1. GETCIEN(CODE,CDT,SRC) ; Get Code IEN for Code/Date/Source
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;   CODE         Classification Code (required)
  1.  ;   CDT          Code Set Versioning Date (optional, 
  1.  ;                default TODAY)
  1.  ;   SRC          Coding System pointer or Source 
  1.  ;                Abbreviation (optional)
  1.  ;   
  1.  ; Output
  1.  ; 
  1.  ;   $$GETCIEN    3 piece "^" delimited string
  1.  ;   
  1.  ;                              Content
  1.  ;                  Piece  Normal      On Error
  1.  ;                    1    IEN         -1
  1.  ;                    2    Status      Error Message
  1.  ;                    3    Comment     null
  1.  ;                 
  1.  N LEX,LEXCDT,LEXCIEN,LEXCO,LEXCODE,LEXEFF,LEXIDT,LEXON
  1.  N LEXOUT,LEXSAB,LEXSN,LEXSNM,LEXSRC,LEXSRD,LEXSTA
  1.  S LEXCODE=$G(CODE) Q:'$L(LEXCODE) "-1^No code provided^"
  1.  S LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
  1.  S LEXSRC=$G(SRC),(LEXSAB,LEXSRD,LEXSNM)=""
  1.  I $L(LEXSRC) D
  1.  . S LEXSRD=$$CSYS^LEXU(LEXSRC),LEXSAB=$P(LEXSRD,"^",2)
  1.  . S LEXSNM=$P(LEXSRD,"^",4),LEXSRC=+LEXSRD
  1.  S LEXSN=$S($L(LEXSNM):(LEXSNM_" "),1:"")
  1.  Q:'$D(^LEX(757.02,"CODE",(LEXCODE_" "))) ("-1^"_LEXSN_"Code "_LEXCODE_" is not on file^")
  1.  S:$L(LEXSAB) LEX=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT,,LEXSAB)
  1.  S:'$L(LEXSAB) LEX=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT)
  1.  S LEXSTA=$P(LEX,"^",1)
  1.  S LEXCIEN=$P(LEX,"^",2)
  1.  S LEXEFF=$P(LEX,"^",3)
  1.  S LEXIDT=$P(LEX,"^",4)
  1.  S LEXCO=$S('$L(LEXSNM):"Code ",1:"code ")
  1.  S LEXON=$S($G(LEXEFF)?7N:("on "_$$FMTE^XLFDT(LEXCDT,"5Z")),1:"")
  1.  I +LEXCIEN'>0 D  Q LEXOUT
  1.  . S LEXOUT="-1^"_LEXSN_LEXCO_LEXCODE_" was not found^"
  1.  I +LEXEFF'>0 D  Q LEXOUT
  1.  . S LEXOUT=LEXCIEN_"^0^"_LEXSN_LEXCO_LEXCODE_" is not yet active (future activation)"
  1.  I +LEXSTA'>0,LEXEFF>0 D  Q LEXOUT
  1.  . S LEXOUT=LEXCIEN_"^0^"_LEXSN_LEXCO_LEXCODE_" is inactive "_LEXON
  1.  I +LEXSTA>0,LEXEFF>0,LEXIDT>0,LEXEFF>LEXIDT D  Q LEXOUT
  1.  . S LEXOUT=LEXCIEN_"^1^"_LEXSN_LEXCO_LEXCODE_" is active "_LEXON_", but has been revised"
  1.  I +LEXSTA>0,LEXEFF>0,LEXIDT>0,LEXEFF'>LEXIDT D  Q LEXOUT
  1.  . S LEXOUT=LEXCIEN_"^1^"_LEXSN_LEXCO_LEXCODE_" is active "_LEXON
  1.  S LEXOUT=LEXSN_LEXCO_LEXCODE_" "_$S(LEXSTA>0:"is active",1:"is inactive")_" "_LEXON
  1.  S LEXOUT=LEXCIEN_"^"_+($G(LEXSTA))_"^"_LEXOUT
  1.  Q LEXOUT