LEXTRAN1 ;ISL/KER - Lexicon code and text wrapper API's ;04/21/2014
;;2.0;LEXICON UTILITY;**59,73,51,80**;Sep 23, 1996;Build 10
; Per VHA Directive 2004-038, this routine should not be modified.
;
; Global Variables
; ^LEX(757.32) N/A
; ^LEX(757.33) N/A
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$GET1^DIQ ICR 2056
; $$UP^XLFSTR ICR 10103
; ^%DT ICR 10003
;
GETSYN(SRC,CODE,CDT,LEXARY,IENS) ; Get Synonyms for a Concept
;
; Local Variables
;
;
; Input
;
; SRC Code System source abbreviation (required)
; CODE Code (required)
; CDT Effective date (optoinal, default TODAY)
; LEXARY Output array (optional, defaults to 'LEX')
; IENS Include expression IENs in output array
; - optional
; 1 include IENS
; 0 exclude IENS (default)
;
; Output
;
; if call finds an active code for the source
; "1^LEXCODE"
; LEX - an array containing information about the code
; LEX("F") fully specified name^IEN
; LEX("P") preferred term^IEN
; LEX("S",n) synonyms^IEN (n is the nth synonym)
;
; if call cannot find specified code on file
; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
; where LEXSCNM is the source name
;
N LEXSRC,LEXCODE,LEXVDT,LEXIENS S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT),LEXIENS=$G(IENS)
N LEX1,LEX2,LEX3,LEX4,LEXCIEN,LEXD,LEXDOW,LEXEX,LEXEXI,LEXFND,LEXI
N LEXMCI,LEXOUT,LEXS,LEXSAB,LEXSNM,LEXSRD,LEXSTAT,LEXTY
N LEXVAL S LEXSRC=$E($G(LEXSRC),1,3) S:'$L($G(LEXARY)) LEXARY="LEX"
Q:'$L($G(LEXSRC)) (-1_U_"source not recognized")
S LEXSRD=$$CSYS^LEXU(LEXSRC) Q:+LEXSRD'>0 (-1_U_"source not recognized")
S LEXSAB=$P(LEXSRD,"^",2),LEXSNM=$P(LEXSRD,"^",4)
Q:($L(LEXSAB)'=3)!('$L(LEXSNM)) (-1_U_"source not recognized")
Q:'$L($G(LEXCODE)) -1_U_"no code specified"
D VDT^LEXU Q:$P(LEXVDT,".",1)'?7N (-1_U_"invalid date format")
K:$G(LEXARY)="" LEXARY
S LEXIENS=+$G(LEXIENS) S:LEXIENS'=1 LEXIENS=0
S LEXCIEN="",LEXVAL=0
F Q:LEXVAL=1 D Q:LEXCIEN=""
.S LEXCIEN=$O(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN)) Q:LEXCIEN="" D
.I $D(^LEX(757.02,"ASRC",LEXSAB,LEXCIEN)) S LEXVAL=1 Q
I 'LEXVAL Q -2_U_LEXSNM_" code "_LEXCODE_" not on file"
S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,LEXSAB)
S:+LEXSTAT>0&($P(LEXSTAT,"^",2)>0) LEXCIEN=$P(LEXSTAT,"^",2)
S LEXOUT=0 I +LEXSTAT=0 D
. S LEXOUT=-4_U_LEXSNM_" code "_LEXCODE_" not active for "
. S LEXOUT=LEXOUT_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
I +LEXSTAT=-1 D
. S LEXOUT=-8_U_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
. S LEXOUT=LEXOUT_" precedes earliest activation date for code"
I +($G(LEXCIEN))'>0 D
. N LEXS,LEXD,LEXI,LEX1 S LEXCIEN=-1,(LEXS,LEXD,LEXI)=""
. F S LEXS=$O(^LEX(757.02,"ACT",LEXCODE_" ",LEXS)) Q:LEXS="" D
. . Q:(LEXS+1)>2 S LEXD=""
. . F S LEXD=$O(^LEX(757.02,"ACT",LEXCODE_" ",LEXS,LEXD)) Q:LEXD="" S LEXI="" D
. . . F S LEXI=$O(^LEX(757.02,"ACT",LEXCODE_" ",LEXS,LEXD,LEXI)) Q:LEXI="" D
. . . . S LEX1(LEXD,LEXI)=""
. Q:'$D(LEX1) S LEXI=$O(LEX1(LEXVDT+.001),-1) Q:'$L(LEXI)
. S LEXI=$O(LEX1(LEXI,""),-1) Q:'$D(^LEX(757.02,+LEXI,0)) S LEXCIEN=LEXI
I '$D(^LEX(757.02,+($G(LEXCIEN)),0)) D Q LEXOUT
. S LEXOUT="-1^Code "_LEXCODE_" not yet active for "
. S LEXOUT=LEXOUT_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
S LEXMCI=$P(^LEX(757.02,+LEXCIEN,0),U,4)
S LEXEXI="",LEXFND=0
K LEX2 F S LEXEXI=$O(^LEX(757.01,"AMC",LEXMCI,LEXEXI)) Q:LEXEXI="" D
.S LEXFND=LEXFND+1,LEX2(LEXEXI)=""
K LEX3 S LEXEXI="" F S LEXEXI=$O(LEX2(LEXEXI)) Q:LEXEXI="" D
.S LEXEX=^LEX(757.01,LEXEXI,0)
.S LEXTY=$P(^LEX(757.01,LEXEXI,1),U,2)
.I LEXTY=1 S LEX3("P")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") Q
.I LEXTY=8 S LEX3("F")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") Q
.S LEX3("S",($O(LEX3("S"," "),-1)+1))=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"")
K LEX4 M LEX4=LEX3
S LEXFND=''$D(LEX4("F"))+''$D(LEX4("P"))+$O(LEX4("S"," "),-1)
I $D(LEXARY),LEXARY'="LEX4" M @LEXARY=LEX4
K LEX4 I LEXOUT=0 S LEXOUT=''LEXFND_U_LEXFND
Q LEXOUT
;
GETFSN(SRC,CODE,CDT) ; Get Fully Specified Name for a Concept
;
; Input
;
; SRC Code System source abbreviation (required)
; CODE Code (required)
; CDT Effective date (optional, default TODAY)
;
; Output
;
; if call finds an active code for the source
; "1^LEXFSN"
; where LEXFSN is the fully specified name
; if call cannot find specified code on file
; "-8^"_LEXSCNM_" code "_LEXCODE_" has no FSN"
; where LEXSCNM is the source name
;
N LEXSRC,LEXCODE,LEXVDT S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT)
N SYNS,LEX S LEXSRC=$E($G(LEXSRC),1,3)
I $G(LEXCODE)="" Q -1_U_"no code specified"
I $G(LEXSRC)="" Q -1_U_"no source specified"
I +($$CSYS^LEXU(LEXSRC))'>0 Q -1_U_"source not recognized"
I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
S SYNS=$$GETSYN(LEXSRC,LEXCODE,$G(LEXVDT))
I +SYNS'>0 Q SYNS
I $D(LEX("F")) Q 1_U_LEX("F")
Q -8_U_$$LEXSCNM(LEXSRC)_" code "_LEXCODE_" has no FSN"
;
GETPREF(SRC,CODE,CDT) ; Get the Preferred Term for a Code
;
; Input
;
; SRC Code System source abbreviation (required)
; CODE Code (required)
; CDT Effective date (optional, default TODAY)
;
; Output
;
; if call finds an active code for the source
; "1^LEXPREF"
; where LEXPREF is the preferred name
; if call cannot find specified code on file
; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
; where LEXSCNM is the source name
;
N LEXSRC,LEXCODE,LEXVDT S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT)
N SYNS,LEX S LEXSRC=$E($G(LEXSRC),1,3)
I $G(LEXCODE)="" Q -1_U_"no code specified"
I $G(LEXSRC)="" Q -1_U_"no source specified"
I +($$CSYS^LEXU(LEXSRC))'>0 Q -1_U_"source not recognized"
I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
I $G(LEXVDT)=-1 Q -1_U_"invalid date format"
I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
S SYNS=$$GETSYN(LEXSRC,LEXCODE,$G(LEXVDT))
I +SYNS'>0 Q SYNS
Q 1_U_LEX("P")
;
GETDES(SRC,TEXT,CDT) ; Get the Designation Code for a Concept/Synonym
;
; Input
;
; SRC Code System source abbreviation (required)
; TEXT Text (required)
; CDT Effective date (optional, default TODAY)
;
; Output
;
; if call finds an active code for the source
; "1^LEXDSG"
; where LEXDSG is the designation code
; if call cannot find specified code on file
; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
; where LEXSCNM is the source name
;
N LEXSRC,LEXTEXT,LEXVDT S LEXSRC=$G(SRC),LEXTEXT=$G(TEXT),LEXVDT=$G(CDT)
N LEXA,LEXCIEN,LEXDSG,LEXIEN,LEXMC,LEXSAB,LEXSIEN,LEXSO
N LEXSR,LEXSRD,LEXSRI,LEXSUB,LEXTMP S LEXSRC=$E($G(LEXSRC),1,3)
S LEXSRD=$$CSYS^LEXU(LEXSRC),LEXSAB=$P(LEXSRD,"^",2)
S LEXSRI=+LEXSRD Q:$G(LEXSRC)="" -1_U_"no source specified"
Q:+LEXSRI'>0 -1_U_"source not recognized"
Q:'$L($G(LEXTEXT)) -1_U_"no text specified"
S LEXTMP=$G(^TMP("LEXSCH",$J,"VDT",0))
S:LEXTMP?7N LEXVDT=LEXTMP
I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
;
; find candidate designations
;
S LEXSUB=$E($$UP^XLFSTR(LEXTEXT),1,63)
S LEXIEN=""
F S LEXIEN=$O(^LEX(757.01,"B",LEXSUB,LEXIEN)) Q:LEXIEN="" D
.I $$UP^XLFSTR(^LEX(757.01,LEXIEN,0))=$$UP^XLFSTR(LEXTEXT) S LEXA(LEXIEN)=$P(^LEX(757.01,LEXIEN,1),U)
S LEXIEN=""
F S LEXIEN=$O(LEXA(LEXIEN)) Q:LEXIEN="" D
. N LEXSR S LEXMC=LEXA(LEXIEN)
. S (LEXCIEN,LEXSIEN)=""
. F S LEXSIEN=$O(^LEX(757.02,"AMC",LEXMC,LEXSIEN)) Q:LEXSIEN="" D
. . S LEXSR=$P(^LEX(757.02,LEXSIEN,0),U,3)
. . I +($$CSYS^LEXU(LEXSRC))'=LEXSR Q
. . I $P(^LEX(757.02,LEXSIEN,0),U,5)'=1 Q
. . S LEXCIEN=LEXSIEN
. I LEXCIEN="" K LEXA(LEXIEN) Q
. ; eliminate if wrong source
. S LEXSO=$P(^LEX(757.02,LEXCIEN,0),U,2)
. S LEXSR=$P(^LEX(757.02,LEXCIEN,0),U,3)
. I +($$CSYS^LEXU(LEXSRC))'=LEXSR K LEXA(LEXIEN) Q
. ; eliminate if inactive for LEXVDT
. I '+$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,$E(LEXSRC,1,3)) K LEXA(LEXIEN) Q
; get the designation code
S LEXIEN=$O(LEXA(""))
I LEXIEN="" Q -1_U_"text not recognized for source"
S LEXDSG=$O(^LEX(757.01,LEXIEN,7,"C",+LEXSRI,""))
I LEXDSG="" Q -1_U_"no designation code for text and source"
Q 1_U_LEXDSG
;
GETASSN(CODE,MAP,CDT,LEXRAY) ; Get Mapped Associated Codes
;
; Input
;
; CODE Code (required)
; MAP Mapping Identifier (VUID) or mnemonic (required)
; CDT Effective date (optional, default TODAY)
; LEXRAY Output array (defaults to 'LEX') optional
;
; Output
;
; if call finds active mappings for passed arguments
; "1^"_number_of_mappings
; LEX - an array containing the mapping target codes
; LEX = number of mappings
; LEX(order,code) mapped codes (order is the order of the mapping)
; (code is the mapping target code)
;
; if call finds no active mappings for passed arguments
; "0^0"
;
; if a bad argument is passed for a parameter then the call returns
; "-1^"_error_message
;
; if call cannot find specified code on file
; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
; where LEXSCNM is the source name
;
; Caution
; -------
; When the API is invoked in the following way
; S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,[DATE],[ARR])
; make sure that ARR'="VAR"
; e.g. S ORY=$$GETASSN^LEXTRAN1(44452003,"SCT2ICD",,"VAR") is OK
; but S VAR=$$GETASSN^LEXTRAN1(44452003,"SCT2ICD",,"VAR") is not OK
; this would be akin to using the same variable for two purposes.
;
N LEXCODE,LEXMAP,LEXVDT S LEXCODE=$G(CODE),LEXMAP=$G(MAP),LEXVDT=$G(CDT)
I $G(LEXCODE)="" Q -1_U_"no code specified"
I $G(LEXMAP)="" Q -1_U_"no mapping specified"
I $L($G(LEXVDT)),$P($G(LEXVDT),".",1)'?7N S LEXVDT=$$INTDAT(LEXVDT)
D VDT^LEXU I $P($G(LEXVDT),".",1)'?7N Q -1_U_"invalid date format"
S LEXRAY=$G(LEXRAY,"LEX")
;
N MIDIEN,CSYS,CIEN,VALCD,MORD,MTAR,MIEN,EFDT,STAT,CT,VUID
;
I '$D(^LEX(757.32,"B",LEXMAP)),'$D(^LEX(757.32,"C",LEXMAP)) Q -1_U_"unrecognized mapping identifier"
I $D(^LEX(757.32,"C",LEXMAP)) D
.S MIDIEN=$O(^LEX(757.32,"C",LEXMAP,""))
I $D(^LEX(757.32,"B",LEXMAP)) D
.S MIDIEN=$O(^LEX(757.32,"B",LEXMAP,""))
I '$D(MIDIEN) Q -1_U_"not a recognized mapping identifier"
S CSYS=$$GET1^DIQ(757.32,MIDIEN_",",3)
;
; check that code exists for coding system
;
S CIEN="",VALCD=0
F Q:VALCD=1 D Q:CIEN=""
.S CIEN=$O(^LEX(757.02,"CODE",LEXCODE_" ",CIEN)) Q:CIEN="" D
.S VALCD=''$D(^LEX(757.02,"ASRC",$$LEXASAB(CSYS),CIEN))
I 'VALCD Q -2_U_$$LEXSCNM(CSYS)_" code "_LEXCODE_" not on file"
;
; obtain mappings that are valid for date passed
;
S (MORD,MTAR,MIEN)=""
K LEX
S LEX=0
F S MORD=$O(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD)) Q:MORD="" D
.F S MTAR=$O(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR)) Q:MTAR="" D
..F S MIEN=$O(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR,MIEN)) Q:MIEN="" D
...N MAT S MAT=$P($G(^LEX(757.33,+MIEN,0)),U,5) ; Pch 73 adds variable MAT for match
...S VUID=$P(^LEX(757.33,MIEN,0),U)
...S EFDT=+$O(^LEX(757.33,"G",VUID,LEXVDT+.0001),-1)
...Q:EFDT=0
...S STAT=+$O(^LEX(757.33,"G",VUID,EFDT,""))
...Q:STAT=0
...S LEX=LEX+1
...S LEX(MORD,MTAR)=MAT ; Pch 73 adds variable MAT for match
I LEXRAY'="LEX" M @LEXRAY=LEX K LEX
Q ''@LEXRAY_U_@LEXRAY
;
LEXSCNM(LEXSRC) ; get source name
N LEXI Q:'$L(LEXSRC) "" S LEXI=+($$CSYS^LEXU(LEXSRC))'>0 Q:LEXI'>0 ""
Q $P(^LEX(757.03,+LEXI,0),U,2)
;
LEXASAB(LEXSRC) ; get source abbreviation
N LEXI Q:'$L(LEXSRC) "" S LEXI=+($$CSYS^LEXU(LEXSRC)) Q:LEXI'>0 ""
Q $E($P($G(^LEX(757.03,+LEXI,0)),U),1,3)
CSI(LEXSRC) ; get source IEN
Q:'$L($E($G(LEXSRC),1,3)) -1 N LEXI S LEXI=+($$CSYS^LEXU(LEXSRC)) S:LEXI'>0 LEXI=-2
Q +LEXI
;
INTDAT(X) ; convert date from external format to VA internal format
S X=$G(X) Q:$P(X,".",1)?7N $P(X,".",1)
N Y,%DT
D ^%DT
Q Y
;
GETCIEN(CODE) ; get correct code ien for code and date
; CODE must be defined
; LEXVDT must be defined
N STA,DAT,CIEN,ARR,CDT S CDT=$G(LEXVDT)
S (STA,DAT,CIEN)=""
F S STA=$O(^LEX(757.02,"ACT",CODE_" ",STA)) Q:STA="" D
.Q:(STA+1)>2
.F S DAT=$O(^LEX(757.02,"ACT",CODE_" ",STA,DAT)) Q:DAT="" D
..F S CIEN=$O(^LEX(757.02,"ACT",CODE_" ",STA,DAT,CIEN)) Q:CIEN="" D
...S ARR(DAT,CIEN)=""
Q:'$D(ARR) ("-1^No Code entry found for date "_$S(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
S CIEN=$O(ARR(CDT+.001),-1)
Q:'$L(CIEN) ("-1^No Code entry found for date "_$S(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
S CIEN=$O(ARR(CIEN,""),-1)
Q:'$D(^LEX(757.02,+CIEN,0)) ("-1^No Code entry found for date "_$S(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
Q CIEN
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
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Global Variables
+5 ; ^LEX(757.32) N/A
+6 ; ^LEX(757.33) N/A
+7 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMTE^XLFDT ICR 10103
+12 ; $$GET1^DIQ ICR 2056
+13 ; $$UP^XLFSTR ICR 10103
+14 ; ^%DT ICR 10003
+15 ;
GETSYN(SRC,CODE,CDT,LEXARY,IENS) ; Get Synonyms for a Concept
+1 ;
+2 ; Local Variables
+3 ;
+4 ;
+5 ; Input
+6 ;
+7 ; SRC Code System source abbreviation (required)
+8 ; CODE Code (required)
+9 ; CDT Effective date (optoinal, default TODAY)
+10 ; LEXARY Output array (optional, defaults to 'LEX')
+11 ; IENS Include expression IENs in output array
+12 ; - optional
+13 ; 1 include IENS
+14 ; 0 exclude IENS (default)
+15 ;
+16 ; Output
+17 ;
+18 ; if call finds an active code for the source
+19 ; "1^LEXCODE"
+20 ; LEX - an array containing information about the code
+21 ; LEX("F") fully specified name^IEN
+22 ; LEX("P") preferred term^IEN
+23 ; LEX("S",n) synonyms^IEN (n is the nth synonym)
+24 ;
+25 ; if call cannot find specified code on file
+26 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+27 ; where LEXSCNM is the source name
+28 ;
+29 NEW LEXSRC,LEXCODE,LEXVDT,LEXIENS
SET LEXSRC=$GET(SRC)
SET LEXCODE=$GET(CODE)
SET LEXVDT=$GET(CDT)
SET LEXIENS=$GET(IENS)
+30 NEW LEX1,LEX2,LEX3,LEX4,LEXCIEN,LEXD,LEXDOW,LEXEX,LEXEXI,LEXFND,LEXI
+31 NEW LEXMCI,LEXOUT,LEXS,LEXSAB,LEXSNM,LEXSRD,LEXSTAT,LEXTY
+32 NEW LEXVAL
SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
IF '$LENGTH($GET(LEXARY))
SET LEXARY="LEX"
+33 IF '$LENGTH($GET(LEXSRC))
QUIT (-1_U_"source not recognized")
+34 SET LEXSRD=$$CSYS^LEXU(LEXSRC)
IF +LEXSRD'>0
QUIT (-1_U_"source not recognized")
+35 SET LEXSAB=$PIECE(LEXSRD,"^",2)
SET LEXSNM=$PIECE(LEXSRD,"^",4)
+36 IF ($LENGTH(LEXSAB)'=3)!('$LENGTH(LEXSNM))
QUIT (-1_U_"source not recognized")
+37 IF '$LENGTH($GET(LEXCODE))
QUIT -1_U_"no code specified"
+38 DO VDT^LEXU
IF $PIECE(LEXVDT,".",1)'?7N
QUIT (-1_U_"invalid date format")
+39 IF $GET(LEXARY)=""
KILL LEXARY
+40 SET LEXIENS=+$GET(LEXIENS)
IF LEXIENS'=1
SET LEXIENS=0
+41 SET LEXCIEN=""
SET LEXVAL=0
+42 FOR
IF LEXVAL=1
QUIT
Begin DoDot:1
+43 SET LEXCIEN=$ORDER(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN))
IF LEXCIEN=""
QUIT
Begin DoDot:2
End DoDot:2
+44 IF $DATA(^LEX(757.02,"ASRC",LEXSAB,LEXCIEN))
SET LEXVAL=1
QUIT
End DoDot:1
IF LEXCIEN=""
QUIT
+45 IF 'LEXVAL
QUIT -2_U_LEXSNM_" code "_LEXCODE_" not on file"
+46 SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,LEXSAB)
+47 IF +LEXSTAT>0&($PIECE(LEXSTAT,"^",2)>0)
SET LEXCIEN=$PIECE(LEXSTAT,"^",2)
+48 SET LEXOUT=0
IF +LEXSTAT=0
Begin DoDot:1
+49 SET LEXOUT=-4_U_LEXSNM_" code "_LEXCODE_" not active for "
+50 SET LEXOUT=LEXOUT_$SELECT(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
End DoDot:1
+51 IF +LEXSTAT=-1
Begin DoDot:1
+52 SET LEXOUT=-8_U_$SELECT(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
+53 SET LEXOUT=LEXOUT_" precedes earliest activation date for code"
End DoDot:1
+54 IF +($GET(LEXCIEN))'>0
Begin DoDot:1
+55 NEW LEXS,LEXD,LEXI,LEX1
SET LEXCIEN=-1
SET (LEXS,LEXD,LEXI)=""
+56 FOR
SET LEXS=$ORDER(^LEX(757.02,"ACT",LEXCODE_" ",LEXS))
IF LEXS=""
QUIT
Begin DoDot:2
+57 IF (LEXS+1)>2
QUIT
SET LEXD=""
+58 FOR
SET LEXD=$ORDER(^LEX(757.02,"ACT",LEXCODE_" ",LEXS,LEXD))
IF LEXD=""
QUIT
SET LEXI=""
Begin DoDot:3
+59 FOR
SET LEXI=$ORDER(^LEX(757.02,"ACT",LEXCODE_" ",LEXS,LEXD,LEXI))
IF LEXI=""
QUIT
Begin DoDot:4
+60 SET LEX1(LEXD,LEXI)=""
End DoDot:4
End DoDot:3
End DoDot:2
+61 IF '$DATA(LEX1)
QUIT
SET LEXI=$ORDER(LEX1(LEXVDT+.001),-1)
IF '$LENGTH(LEXI)
QUIT
+62 SET LEXI=$ORDER(LEX1(LEXI,""),-1)
IF '$DATA(^LEX(757.02,+LEXI,0))
QUIT
SET LEXCIEN=LEXI
End DoDot:1
+63 IF '$DATA(^LEX(757.02,+($GET(LEXCIEN)),0))
Begin DoDot:1
+64 SET LEXOUT="-1^Code "_LEXCODE_" not yet active for "
+65 SET LEXOUT=LEXOUT_$SELECT(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
End DoDot:1
QUIT LEXOUT
+66 SET LEXMCI=$PIECE(^LEX(757.02,+LEXCIEN,0),U,4)
+67 SET LEXEXI=""
SET LEXFND=0
+68 KILL LEX2
FOR
SET LEXEXI=$ORDER(^LEX(757.01,"AMC",LEXMCI,LEXEXI))
IF LEXEXI=""
QUIT
Begin DoDot:1
+69 SET LEXFND=LEXFND+1
SET LEX2(LEXEXI)=""
End DoDot:1
+70 KILL LEX3
SET LEXEXI=""
FOR
SET LEXEXI=$ORDER(LEX2(LEXEXI))
IF LEXEXI=""
QUIT
Begin DoDot:1
+71 SET LEXEX=^LEX(757.01,LEXEXI,0)
+72 SET LEXTY=$PIECE(^LEX(757.01,LEXEXI,1),U,2)
+73 IF LEXTY=1
SET LEX3("P")=LEXEX_$SELECT(+LEXEXI>0&(+($GET(LEXIENS))>0):(U_LEXEXI),1:"")
QUIT
+74 IF LEXTY=8
SET LEX3("F")=LEXEX_$SELECT(+LEXEXI>0&(+($GET(LEXIENS))>0):(U_LEXEXI),1:"")
QUIT
+75 SET LEX3("S",($ORDER(LEX3("S"," "),-1)+1))=LEXEX_$SELECT(+LEXEXI>0&(+($GET(LEXIENS))>0):(U_LEXEXI),1:"")
End DoDot:1
+76 KILL LEX4
MERGE LEX4=LEX3
+77 SET LEXFND=''$DATA(LEX4("F"))+''$DATA(LEX4("P"))+$ORDER(LEX4("S"," "),-1)
+78 IF $DATA(LEXARY)
IF LEXARY'="LEX4"
MERGE @LEXARY=LEX4
+79 KILL LEX4
IF LEXOUT=0
SET LEXOUT=''LEXFND_U_LEXFND
+80 QUIT LEXOUT
+81 ;
GETFSN(SRC,CODE,CDT) ; Get Fully Specified Name for a Concept
+1 ;
+2 ; Input
+3 ;
+4 ; SRC Code System source abbreviation (required)
+5 ; CODE Code (required)
+6 ; CDT Effective date (optional, default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; if call finds an active code for the source
+11 ; "1^LEXFSN"
+12 ; where LEXFSN is the fully specified name
+13 ; if call cannot find specified code on file
+14 ; "-8^"_LEXSCNM_" code "_LEXCODE_" has no FSN"
+15 ; where LEXSCNM is the source name
+16 ;
+17 NEW LEXSRC,LEXCODE,LEXVDT
SET LEXSRC=$GET(SRC)
SET LEXCODE=$GET(CODE)
SET LEXVDT=$GET(CDT)
+18 NEW SYNS,LEX
SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
+19 IF $GET(LEXCODE)=""
QUIT -1_U_"no code specified"
+20 IF $GET(LEXSRC)=""
QUIT -1_U_"no source specified"
+21 IF +($$CSYS^LEXU(LEXSRC))'>0
QUIT -1_U_"source not recognized"
+22 IF $LENGTH($GET(LEXVDT))
IF $PIECE($GET(LEXVDT),".",1)'?7N
SET LEXVDT=$$INTDAT(LEXVDT)
+23 DO VDT^LEXU
IF $PIECE($GET(LEXVDT),".",1)'?7N
QUIT -1_U_"invalid date format"
+24 IF $GET(LEXVDT)=""
SET LEXVDT=$$DT^XLFDT
+25 SET SYNS=$$GETSYN(LEXSRC,LEXCODE,$GET(LEXVDT))
+26 IF +SYNS'>0
QUIT SYNS
+27 IF $DATA(LEX("F"))
QUIT 1_U_LEX("F")
+28 QUIT -8_U_$$LEXSCNM(LEXSRC)_" code "_LEXCODE_" has no FSN"
+29 ;
GETPREF(SRC,CODE,CDT) ; Get the Preferred Term for a Code
+1 ;
+2 ; Input
+3 ;
+4 ; SRC Code System source abbreviation (required)
+5 ; CODE Code (required)
+6 ; CDT Effective date (optional, default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; if call finds an active code for the source
+11 ; "1^LEXPREF"
+12 ; where LEXPREF is the preferred name
+13 ; if call cannot find specified code on file
+14 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+15 ; where LEXSCNM is the source name
+16 ;
+17 NEW LEXSRC,LEXCODE,LEXVDT
SET LEXSRC=$GET(SRC)
SET LEXCODE=$GET(CODE)
SET LEXVDT=$GET(CDT)
+18 NEW SYNS,LEX
SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
+19 IF $GET(LEXCODE)=""
QUIT -1_U_"no code specified"
+20 IF $GET(LEXSRC)=""
QUIT -1_U_"no source specified"
+21 IF +($$CSYS^LEXU(LEXSRC))'>0
QUIT -1_U_"source not recognized"
+22 IF $LENGTH($GET(LEXVDT))
IF $PIECE($GET(LEXVDT),".",1)'?7N
SET LEXVDT=$$INTDAT(LEXVDT)
+23 DO VDT^LEXU
IF $PIECE($GET(LEXVDT),".",1)'?7N
QUIT -1_U_"invalid date format"
+24 IF $GET(LEXVDT)=-1
QUIT -1_U_"invalid date format"
+25 IF $GET(LEXVDT)=""
SET LEXVDT=$$DT^XLFDT
+26 SET SYNS=$$GETSYN(LEXSRC,LEXCODE,$GET(LEXVDT))
+27 IF +SYNS'>0
QUIT SYNS
+28 QUIT 1_U_LEX("P")
+29 ;
GETDES(SRC,TEXT,CDT) ; Get the Designation Code for a Concept/Synonym
+1 ;
+2 ; Input
+3 ;
+4 ; SRC Code System source abbreviation (required)
+5 ; TEXT Text (required)
+6 ; CDT Effective date (optional, default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; if call finds an active code for the source
+11 ; "1^LEXDSG"
+12 ; where LEXDSG is the designation code
+13 ; if call cannot find specified code on file
+14 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+15 ; where LEXSCNM is the source name
+16 ;
+17 NEW LEXSRC,LEXTEXT,LEXVDT
SET LEXSRC=$GET(SRC)
SET LEXTEXT=$GET(TEXT)
SET LEXVDT=$GET(CDT)
+18 NEW LEXA,LEXCIEN,LEXDSG,LEXIEN,LEXMC,LEXSAB,LEXSIEN,LEXSO
+19 NEW LEXSR,LEXSRD,LEXSRI,LEXSUB,LEXTMP
SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
+20 SET LEXSRD=$$CSYS^LEXU(LEXSRC)
SET LEXSAB=$PIECE(LEXSRD,"^",2)
+21 SET LEXSRI=+LEXSRD
IF $GET(LEXSRC)=""
QUIT -1_U_"no source specified"
+22 IF +LEXSRI'>0
QUIT -1_U_"source not recognized"
+23 IF '$LENGTH($GET(LEXTEXT))
QUIT -1_U_"no text specified"
+24 SET LEXTMP=$GET(^TMP("LEXSCH",$JOB,"VDT",0))
+25 IF LEXTMP?7N
SET LEXVDT=LEXTMP
+26 IF $LENGTH($GET(LEXVDT))
IF $PIECE($GET(LEXVDT),".",1)'?7N
SET LEXVDT=$$INTDAT(LEXVDT)
+27 DO VDT^LEXU
IF $PIECE($GET(LEXVDT),".",1)'?7N
QUIT -1_U_"invalid date format"
+28 ;
+29 ; find candidate designations
+30 ;
+31 SET LEXSUB=$EXTRACT($$UP^XLFSTR(LEXTEXT),1,63)
+32 SET LEXIEN=""
+33 FOR
SET LEXIEN=$ORDER(^LEX(757.01,"B",LEXSUB,LEXIEN))
IF LEXIEN=""
QUIT
Begin DoDot:1
+34 IF $$UP^XLFSTR(^LEX(757.01,LEXIEN,0))=$$UP^XLFSTR(LEXTEXT)
SET LEXA(LEXIEN)=$PIECE(^LEX(757.01,LEXIEN,1),U)
End DoDot:1
+35 SET LEXIEN=""
+36 FOR
SET LEXIEN=$ORDER(LEXA(LEXIEN))
IF LEXIEN=""
QUIT
Begin DoDot:1
+37 NEW LEXSR
SET LEXMC=LEXA(LEXIEN)
+38 SET (LEXCIEN,LEXSIEN)=""
+39 FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSIEN))
IF LEXSIEN=""
QUIT
Begin DoDot:2
+40 SET LEXSR=$PIECE(^LEX(757.02,LEXSIEN,0),U,3)
+41 IF +($$CSYS^LEXU(LEXSRC))'=LEXSR
QUIT
+42 IF $PIECE(^LEX(757.02,LEXSIEN,0),U,5)'=1
QUIT
+43 SET LEXCIEN=LEXSIEN
End DoDot:2
+44 IF LEXCIEN=""
KILL LEXA(LEXIEN)
QUIT
+45 ; eliminate if wrong source
+46 SET LEXSO=$PIECE(^LEX(757.02,LEXCIEN,0),U,2)
+47 SET LEXSR=$PIECE(^LEX(757.02,LEXCIEN,0),U,3)
+48 IF +($$CSYS^LEXU(LEXSRC))'=LEXSR
KILL LEXA(LEXIEN)
QUIT
+49 ; eliminate if inactive for LEXVDT
+50 IF '+$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,$EXTRACT(LEXSRC,1,3))
KILL LEXA(LEXIEN)
QUIT
End DoDot:1
+51 ; get the designation code
+52 SET LEXIEN=$ORDER(LEXA(""))
+53 IF LEXIEN=""
QUIT -1_U_"text not recognized for source"
+54 SET LEXDSG=$ORDER(^LEX(757.01,LEXIEN,7,"C",+LEXSRI,""))
+55 IF LEXDSG=""
QUIT -1_U_"no designation code for text and source"
+56 QUIT 1_U_LEXDSG
+57 ;
GETASSN(CODE,MAP,CDT,LEXRAY) ; Get Mapped Associated Codes
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code (required)
+5 ; MAP Mapping Identifier (VUID) or mnemonic (required)
+6 ; CDT Effective date (optional, default TODAY)
+7 ; LEXRAY Output array (defaults to 'LEX') optional
+8 ;
+9 ; Output
+10 ;
+11 ; if call finds active mappings for passed arguments
+12 ; "1^"_number_of_mappings
+13 ; LEX - an array containing the mapping target codes
+14 ; LEX = number of mappings
+15 ; LEX(order,code) mapped codes (order is the order of the mapping)
+16 ; (code is the mapping target code)
+17 ;
+18 ; if call finds no active mappings for passed arguments
+19 ; "0^0"
+20 ;
+21 ; if a bad argument is passed for a parameter then the call returns
+22 ; "-1^"_error_message
+23 ;
+24 ; if call cannot find specified code on file
+25 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+26 ; where LEXSCNM is the source name
+27 ;
+28 ; Caution
+29 ; -------
+30 ; When the API is invoked in the following way
+31 ; S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,[DATE],[ARR])
+32 ; make sure that ARR'="VAR"
+33 ; e.g. S ORY=$$GETASSN^LEXTRAN1(44452003,"SCT2ICD",,"VAR") is OK
+34 ; but S VAR=$$GETASSN^LEXTRAN1(44452003,"SCT2ICD",,"VAR") is not OK
+35 ; this would be akin to using the same variable for two purposes.
+36 ;
+37 NEW LEXCODE,LEXMAP,LEXVDT
SET LEXCODE=$GET(CODE)
SET LEXMAP=$GET(MAP)
SET LEXVDT=$GET(CDT)
+38 IF $GET(LEXCODE)=""
QUIT -1_U_"no code specified"
+39 IF $GET(LEXMAP)=""
QUIT -1_U_"no mapping specified"
+40 IF $LENGTH($GET(LEXVDT))
IF $PIECE($GET(LEXVDT),".",1)'?7N
SET LEXVDT=$$INTDAT(LEXVDT)
+41 DO VDT^LEXU
IF $PIECE($GET(LEXVDT),".",1)'?7N
QUIT -1_U_"invalid date format"
+42 SET LEXRAY=$GET(LEXRAY,"LEX")
+43 ;
+44 NEW MIDIEN,CSYS,CIEN,VALCD,MORD,MTAR,MIEN,EFDT,STAT,CT,VUID
+45 ;
+46 IF '$DATA(^LEX(757.32,"B",LEXMAP))
IF '$DATA(^LEX(757.32,"C",LEXMAP))
QUIT -1_U_"unrecognized mapping identifier"
+47 IF $DATA(^LEX(757.32,"C",LEXMAP))
Begin DoDot:1
+48 SET MIDIEN=$ORDER(^LEX(757.32,"C",LEXMAP,""))
End DoDot:1
+49 IF $DATA(^LEX(757.32,"B",LEXMAP))
Begin DoDot:1
+50 SET MIDIEN=$ORDER(^LEX(757.32,"B",LEXMAP,""))
End DoDot:1
+51 IF '$DATA(MIDIEN)
QUIT -1_U_"not a recognized mapping identifier"
+52 SET CSYS=$$GET1^DIQ(757.32,MIDIEN_",",3)
+53 ;
+54 ; check that code exists for coding system
+55 ;
+56 SET CIEN=""
SET VALCD=0
+57 FOR
IF VALCD=1
QUIT
Begin DoDot:1
+58 SET CIEN=$ORDER(^LEX(757.02,"CODE",LEXCODE_" ",CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
End DoDot:2
+59 SET VALCD=''$DATA(^LEX(757.02,"ASRC",$$LEXASAB(CSYS),CIEN))
End DoDot:1
IF CIEN=""
QUIT
+60 IF 'VALCD
QUIT -2_U_$$LEXSCNM(CSYS)_" code "_LEXCODE_" not on file"
+61 ;
+62 ; obtain mappings that are valid for date passed
+63 ;
+64 SET (MORD,MTAR,MIEN)=""
+65 KILL LEX
+66 SET LEX=0
+67 FOR
SET MORD=$ORDER(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD))
IF MORD=""
QUIT
Begin DoDot:1
+68 FOR
SET MTAR=$ORDER(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR))
IF MTAR=""
QUIT
Begin DoDot:2
+69 FOR
SET MIEN=$ORDER(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR,MIEN))
IF MIEN=""
QUIT
Begin DoDot:3
+70 ; Pch 73 adds variable MAT for match
NEW MAT
SET MAT=$PIECE($GET(^LEX(757.33,+MIEN,0)),U,5)
+71 SET VUID=$PIECE(^LEX(757.33,MIEN,0),U)
+72 SET EFDT=+$ORDER(^LEX(757.33,"G",VUID,LEXVDT+.0001),-1)
+73 IF EFDT=0
QUIT
+74 SET STAT=+$ORDER(^LEX(757.33,"G",VUID,EFDT,""))
+75 IF STAT=0
QUIT
+76 SET LEX=LEX+1
+77 ; Pch 73 adds variable MAT for match
SET LEX(MORD,MTAR)=MAT
End DoDot:3
End DoDot:2
End DoDot:1
+78 IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
+79 QUIT ''@LEXRAY_U_@LEXRAY
+80 ;
LEXSCNM(LEXSRC) ; get source name
+1 NEW LEXI
IF '$LENGTH(LEXSRC)
QUIT ""
SET LEXI=+($$CSYS^LEXU(LEXSRC))'>0
IF LEXI'>0
QUIT ""
+2 QUIT $PIECE(^LEX(757.03,+LEXI,0),U,2)
+3 ;
LEXASAB(LEXSRC) ; get source abbreviation
+1 NEW LEXI
IF '$LENGTH(LEXSRC)
QUIT ""
SET LEXI=+($$CSYS^LEXU(LEXSRC))
IF LEXI'>0
QUIT ""
+2 QUIT $EXTRACT($PIECE($GET(^LEX(757.03,+LEXI,0)),U),1,3)
CSI(LEXSRC) ; get source IEN
+1 IF '$LENGTH($EXTRACT($GET(LEXSRC),1,3))
QUIT -1
NEW LEXI
SET LEXI=+($$CSYS^LEXU(LEXSRC))
IF LEXI'>0
SET LEXI=-2
+2 QUIT +LEXI
+3 ;
INTDAT(X) ; convert date from external format to VA internal format
+1 SET X=$GET(X)
IF $PIECE(X,".",1)?7N
QUIT $PIECE(X,".",1)
+2 NEW Y,%DT
+3 DO ^%DT
+4 QUIT Y
+5 ;
GETCIEN(CODE) ; get correct code ien for code and date
+1 ; CODE must be defined
+2 ; LEXVDT must be defined
+3 NEW STA,DAT,CIEN,ARR,CDT
SET CDT=$GET(LEXVDT)
+4 SET (STA,DAT,CIEN)=""
+5 FOR
SET STA=$ORDER(^LEX(757.02,"ACT",CODE_" ",STA))
IF STA=""
QUIT
Begin DoDot:1
+6 IF (STA+1)>2
QUIT
+7 FOR
SET DAT=$ORDER(^LEX(757.02,"ACT",CODE_" ",STA,DAT))
IF DAT=""
QUIT
Begin DoDot:2
+8 FOR
SET CIEN=$ORDER(^LEX(757.02,"ACT",CODE_" ",STA,DAT,CIEN))
IF CIEN=""
QUIT
Begin DoDot:3
+9 SET ARR(DAT,CIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF '$DATA(ARR)
QUIT ("-1^No Code entry found for date "_$SELECT(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
+11 SET CIEN=$ORDER(ARR(CDT+.001),-1)
+12 IF '$LENGTH(CIEN)
QUIT ("-1^No Code entry found for date "_$SELECT(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
+13 SET CIEN=$ORDER(ARR(CIEN,""),-1)
+14 IF '$DATA(^LEX(757.02,+CIEN,0))
QUIT ("-1^No Code entry found for date "_$SELECT(CDT?7N:$$FMTE^XLFDT(CDT,"5Z"),1:""))
+15 QUIT CIEN
