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 ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**59,73,51,80**;Sep 23, 1996;Build 10
  1.  ; Per VHA Directive 2004-038, this routine should not be modified.
  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) ; Get Synonyms for a Concept
  1.  ;               
  1.  ; Local Variables
  1.  ;
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;   SRC     Code System source abbreviation (required)
  1.  ;   CODE    Code (required)
  1.  ;   CDT     Effective date (optoinal, default TODAY)
  1.  ;   LEXARY  Output array (optional, defaults to 'LEX')
  1.  ;   IENS    Include expression IENs in output array
  1.  ;            - optional
  1.  ;              1 include IENS
  1.  ;              0 exclude IENS (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("F")    fully specified name^IEN
  1.  ;     LEX("P")    preferred term^IEN
  1.  ;     LEX("S",n)  synonyms^IEN (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.  ;
  1.  N LEXSRC,LEXCODE,LEXVDT,LEXIENS S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT),LEXIENS=$G(IENS)
  1.  N LEX1,LEX2,LEX3,LEX4,LEXCIEN,LEXD,LEXDOW,LEXEX,LEXEXI,LEXFND,LEXI
  1.  N LEXMCI,LEXOUT,LEXS,LEXSAB,LEXSNM,LEXSRD,LEXSTAT,LEXTY
  1.  N LEXVAL S LEXSRC=$E($G(LEXSRC),1,3) S:'$L($G(LEXARY)) LEXARY="LEX"
  1.  Q:'$L($G(LEXSRC)) (-1_U_"source not recognized")
  1.  S LEXSRD=$$CSYS^LEXU(LEXSRC) Q:+LEXSRD'>0 (-1_U_"source not recognized")
  1.  S LEXSAB=$P(LEXSRD,"^",2),LEXSNM=$P(LEXSRD,"^",4)
  1.  Q:($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.  K:$G(LEXARY)="" LEXARY
  1.  S LEXIENS=+$G(LEXIENS) S:LEXIENS'=1 LEXIENS=0
  1.  S LEXCIEN="",LEXVAL=0
  1.  F  Q:LEXVAL=1  D  Q:LEXCIEN=""
  1.  .S LEXCIEN=$O(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN)) Q:LEXCIEN=""  D
  1.  .I $D(^LEX(757.02,"ASRC",LEXSAB,LEXCIEN)) S LEXVAL=1 Q
  1.  I 'LEXVAL Q -2_U_LEXSNM_" code "_LEXCODE_" not on file"
  1.  S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,LEXSAB)
  1.  S:+LEXSTAT>0&($P(LEXSTAT,"^",2)>0) LEXCIEN=$P(LEXSTAT,"^",2)
  1.  S LEXOUT=0 I +LEXSTAT=0 D
  1.  . S LEXOUT=-4_U_LEXSNM_" code "_LEXCODE_" not active for "
  1.  . S LEXOUT=LEXOUT_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
  1.  I +LEXSTAT=-1 D
  1.  . S LEXOUT=-8_U_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
  1.  . S LEXOUT=LEXOUT_" precedes earliest activation date for code"
  1.  I +($G(LEXCIEN))'>0 D
  1.  . N LEXS,LEXD,LEXI,LEX1 S LEXCIEN=-1,(LEXS,LEXD,LEXI)=""
  1.  . F  S LEXS=$O(^LEX(757.02,"ACT",LEXCODE_" ",LEXS)) Q:LEXS=""  D
  1.  . . Q:(LEXS+1)>2  S LEXD=""
  1.  . . F  S LEXD=$O(^LEX(757.02,"ACT",LEXCODE_" ",LEXS,LEXD)) Q:LEXD=""  S LEXI="" D
  1.  . . . F  S LEXI=$O(^LEX(757.02,"ACT",LEXCODE_" ",LEXS,LEXD,LEXI)) Q:LEXI=""  D
  1.  . . . . S LEX1(LEXD,LEXI)=""
  1.  . Q:'$D(LEX1)  S LEXI=$O(LEX1(LEXVDT+.001),-1) Q:'$L(LEXI)
  1.  . S LEXI=$O(LEX1(LEXI,""),-1) Q:'$D(^LEX(757.02,+LEXI,0))  S LEXCIEN=LEXI
  1.  I '$D(^LEX(757.02,+($G(LEXCIEN)),0)) D  Q LEXOUT
  1.  . S LEXOUT="-1^Code "_LEXCODE_" not yet active for "
  1.  . S LEXOUT=LEXOUT_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
  1.  S LEXMCI=$P(^LEX(757.02,+LEXCIEN,0),U,4)
  1.  S 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.  K LEX3 S LEXEXI="" F  S LEXEXI=$O(LEX2(LEXEXI)) Q:LEXEXI=""  D
  1.  .S LEXEX=^LEX(757.01,LEXEXI,0)
  1.  .S LEXTY=$P(^LEX(757.01,LEXEXI,1),U,2)
  1.  .I LEXTY=1 S LEX3("P")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") Q
  1.  .I LEXTY=8 S LEX3("F")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") Q
  1.  .S LEX3("S",($O(LEX3("S"," "),-1)+1))=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),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. GETFSN(SRC,CODE,CDT) ; Get Fully Specified Name for a Concept
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;   SRC   Code System source abbreviation (required)
  1.  ;   CODE  Code (required)
  1.  ;   CDT   Effective date (optional, default TODAY)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if call finds an active code for the source
  1.  ;     "1^LEXFSN"
  1.  ;     where LEXFSN is the fully specified name
  1.  ;   if call cannot find specified code on file
  1.  ;     "-8^"_LEXSCNM_" code "_LEXCODE_" has no FSN"
  1.  ;     where LEXSCNM is the source name
  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    Code System source abbreviation (required)
  1.  ;   CODE   Code (required)
  1.  ;   CDT    Effective date (optional, default TODAY)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if call finds an active code for the source
  1.  ;     "1^LEXPREF"
  1.  ;     where LEXPREF is the preferred name
  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.  ;
  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    Code System source abbreviation (required)
  1.  ;   TEXT   Text (required)
  1.  ;   CDT    Effective date (optional, default TODAY)
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if call finds an active code for the source
  1.  ;     "1^LEXDSG"
  1.  ;     where LEXDSG is the designation code
  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.  ;
  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.  ;
  1.  ; find candidate designations
  1.  ;
  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.  . ; eliminate if wrong source
  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.  . ; eliminate if inactive for LEXVDT
  1.  . I '+$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,$E(LEXSRC,1,3)) K LEXA(LEXIEN) Q
  1.  ; get the designation code
  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 Identifier (VUID) or mnemonic (required)
  1.  ;   CDT      Effective date (optional, default TODAY)
  1.  ;   LEXRAY   Output array (defaults to 'LEX') optional
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   if call finds active mappings for passed arguments
  1.  ;     "1^"_number_of_mappings
  1.  ;     LEX     -        an array containing the mapping target codes
  1.  ;     LEX = number of mappings
  1.  ;     LEX(order,code)  mapped codes (order is the order of the mapping)
  1.  ;                                   (code is the mapping target code)
  1.  ;
  1.  ;   if call finds no active mappings for passed arguments
  1.  ;     "0^0"
  1.  ;
  1.  ;   if a bad argument is passed for a parameter then the call returns
  1.  ;     "-1^"_error_message
  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.  ;   
  1.  ;   Caution
  1.  ;   -------
  1.  ;   When the API is invoked in the following way
  1.  ;   S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,[DATE],[ARR])
  1.  ;   make sure that ARR'="VAR"
  1.  ;   e.g. S ORY=$$GETASSN^LEXTRAN1(44452003,"SCT2ICD",,"VAR") is OK
  1.  ;   but  S VAR=$$GETASSN^LEXTRAN1(44452003,"SCT2ICD",,"VAR") is not OK
  1.  ;        this would be akin to using the same variable for two purposes. 
  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.  ;
  1.  N MIDIEN,CSYS,CIEN,VALCD,MORD,MTAR,MIEN,EFDT,STAT,CT,VUID
  1.  ;
  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.  ;
  1.  ; check that code exists for coding system
  1.  ;
  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.  ;
  1.  ; obtain mappings that are valid for date passed
  1.  ;
  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) ; Pch 73 adds variable MAT for match
  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 ; Pch 73 adds variable MAT for match
  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
  1.  D ^%DT
  1.  Q Y
  1.  ;
  1. GETCIEN(CODE) ; get correct code ien for code and date
  1.  ; CODE must be defined
  1.  ; LEXVDT must be defined
  1.  N STA,DAT,CIEN,ARR,CDT S CDT=$G(LEXVDT)
  1.  S (STA,DAT,CIEN)=""
  1.  F  S STA=$O(^LEX(757.02,"ACT",CODE_" ",STA)) Q:STA=""  D
  1.  .Q:(STA+1)>2
  1.  .F  S DAT=$O(^LEX(757.02,"ACT",CODE_" ",STA,DAT)) Q:DAT=""  D
  1.  ..F  S CIEN=$O(^LEX(757.02,"ACT",CODE_" ",STA,DAT,CIEN)) Q:CIEN=""  D
  1.  ...S ARR(DAT,CIEN)=""
  1.  Q:'$D(ARR) ("-1^No Code entry found for date "_$S(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
  1.  S CIEN=$O(ARR(CDT+.001),-1)
  1.  Q:'$L(CIEN) ("-1^No Code entry found for date "_$S(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
  1.  S CIEN=$O(ARR(CIEN,""),-1)
  1.  Q:'$D(^LEX(757.02,+CIEN,0)) ("-1^No Code entry found for date "_$S(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
  1.  Q CIEN