LEXTRAN1 ;ISL/KER - Lexicon code and text wrapper API's ;05/23/2017
;;2.0;LEXICON UTILITY;**59,73,51,80,86,103**;Sep 23, 1996;Build 2
;
; 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,ID,INC) ; Get Synonyms for a Concept
;
; Local Variables
;
; Input
;
; SRC Coding Sys (required)
; CODE Code (required)
; CDT Effective date (default TODAY)
; LEXARY Output array (defaults to 'LEX')
; IENS Include expression IENs in output array (optional)
; 1 return IENS (2nd piece)
; 0 do not return IENS (default)
; ID Designation Identifiers (optional)
; 1 return Designation IDs (3rd piece)
; 0 do not return Designation IDs (default)
; INC Include Deactivated Terms (optional)
; 1 return Deactivated Terms
; 0 do not return Deactivated Terms (default)
;
; Output
;
; If call finds an active code for the source
; "1^LEXCODE"
; LEX An array containing code information
; LEX("F") Fully Specified Name^IEN^Designation ID
; LEX("P") Preferred Term^IEN^Designation ID
; LEX("S",n) Synonyms 4 Piece ^ Delimited string
; 1 Synonym (required)
; 2 IEN (optional)
; 3 Designation ID (optional)
; 4 Deactivation flag (optional)
; 1 = Deactivated Synonym
;
; n is the nth Synonym
;
; Errors:
;
; "-1^Code "_LEXCODE_" not yet active for "_LEXVDT
; where LEXCODE is the code
; LEXVDT is the versioning date
;
; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
; where LEXSCNM is the source name
; LEXCODE is the code
;
; "-4^"_LEXSNM_" code "_LEXCODE_" not active for "_LEXVDT
; where LEXSCNM is the source name
; LEXCODE is the code
; LEXVDT is the versioning date
;
; Otherwise
; "-1^error text"
;
N LEX2,LEX3,LEX4,LEXC,LEXCIEN,LEXCODE,LEXDEA,LEXDID,LEXEFD,LEXEX,LEXEXI,LEXFND,LEXIAD,LEXID
N LEXIENS,LEXINC,LEXMCI,LEXN1,LEXOUT,LEXSAB,LEXSNM,LEXSRC,LEXSRD,LEXSTAT,LEXTY,LEXVDT
; Get Input Parameters
S LEXSRC=$G(SRC),LEXCODE=$G(CODE),LEXVDT=$G(CDT),LEXIENS=$G(IENS),LEXDID=$G(ID),LEXINC=+($G(INC))
; Verify Input Parameters
S LEXSRD=$$CSYS^LEXU(LEXSRC),LEXSAB=$P(LEXSRD,"^",2),LEXSNM=$P(LEXSRD,"^",4),LEXSRC=+LEXSRD
Q:+LEXSRC'>0!($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")
S LEXOUT=0 S:'$L($G(LEXARY)) LEXARY="LEX"
S LEXIENS=+$G(LEXIENS) S:LEXIENS'=1 LEXIENS=0
S LEXDID=+$G(LEXDID) S:LEXDID'=1 LEXDID=0
S LEXINC=+$G(LEXINC) S:LEXINC'=1 LEXINC=0
; Get Code IEN, Status, Effective Date and Initial Activation Date
S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,LEXSAB)
S LEXCIEN=$P(LEXSTAT,"^",2),LEXEFD=$P(LEXSTAT,"^",3),LEXIAD=$P(LEXSTAT,"^",4),LEXSTAT=+LEXSTAT
; Quit Conditions
; Code not found
I +LEXCIEN<0 Q (-2_U_LEXSNM_" code "_LEXCODE_" not on file")
; No Effective Date (pending activation)
I +LEXCIEN>0,LEXSTAT'>0,LEXEFD'?7N,LEXIAD'?7N D Q:LEXINC'>0 LEXOUT
. S LEXOUT="-4^"_LEXSNM_" code "_LEXCODE_" not yet active for "_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
; Inactive Code
I +LEXCIEN>0,LEXSTAT'>0,LEXEFD?7N D Q:LEXINC'>0 LEXOUT
. S LEXOUT="-4^"_LEXSNM_" code "_LEXCODE_" not active for "_$S(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
; Get Terms for the Major Concept
S LEXMCI=$P(^LEX(757.02,+LEXCIEN,0),U,4),LEXEXI="",LEXFND=0
K LEX2 F S LEXEXI=$O(^LEX(757.01,"AMC",LEXMCI,LEXEXI)) Q:LEXEXI="" D
. S LEXFND=LEXFND+1,LEX2(LEXEXI)=""
; Get Info for Terms
K LEX3 S LEXEXI="" F S LEXEXI=$O(LEX2(LEXEXI)) Q:LEXEXI="" D
. N LEXN1,LEXID,LEXC,LEXDEA S LEXEX=^LEX(757.01,LEXEXI,0),LEXDEA=0
. S LEXN1=$G(^LEX(757.01,LEXEXI,1)) Q:+($G(LEXINC))'>0&($P(LEXN1,"^",5)>0)
. S:+($G(LEXINC))>0&($P(LEXN1,"^",5)>0) LEXDEA=1
. S LEXID="" I LEXDID>0 D
. . S LEXID=$O(^LEX(757.01,LEXEXI,7,"C",+LEXSRC,""))
. S LEXTY=$P(^LEX(757.01,LEXEXI,1),U,2)
. I LEXTY=1 D Q
. . S LEX3("P")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") S:$L(LEXID) $P(LEX3("P"),"^",3)=LEXID
. I LEXTY=8 D Q
. . S LEX3("F")=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"") S:$L(LEXID) $P(LEX3("F"),"^",3)=LEXID
. S LEXC=$O(LEX3("S"," "),-1)+1
. S LEX3("S",LEXC)=LEXEX_$S(+LEXEXI>0&(+($G(LEXIENS))>0):(U_LEXEXI),1:"")
. S:$L(LEXID) $P(LEX3("S",LEXC),"^",3)=LEXID
. S:LEXDEA>0 $P(LEX3("S",LEXC),"^",4)=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
;
GETDID(X,IEN) ; Get Designation ID based on Source and IEN
;
; Input
;
; X Coding Sys (required)
; IEN IEN in the Expressions file #757.01 (required)
;
; Output
;
; $$GETDID Designation ID
;
; Otherwise
;
; "-1^"_error message
;
S LEXSRC=$E($G(X),1,3),LEXIEN=$G(IEN) Q:+LEXIEN'>0 (-1_U_"IEN not specified")
Q:'$L(LEXSRC) (-1_U_"source not recognized") Q:'$D(^LEX(757.01,+LEXIEN,0)) (-1_U_"Expression entry not found")
Q:$O(^LEX(757.01,+LEXIEN,7,0))'>0 (-1_U_"No designation IDs found") S LEXSRD=$$CSYS^LEXU(LEXSRC)
Q:+LEXSRD'>0 (-1_U_"source not recognized") S LEXSAB=$P(LEXSRD,"^",2),LEXSRC=+LEXSRD
Q:($L(LEXSAB)'=3)!(+LEXSRC'>0) (-1_U_"Invalid source") Q:'$D(^LEX(757.03,"ASAB",LEXSAB)) (-1_U_"Invalid source")
Q:'$D(^LEX(757.03,LEXSRC,0)) (-1_U_"Invalid source") S LEXID="",LEXIDI=0
F S LEXIDI=$O(^LEX(757.01,+LEXIEN,7,LEXIDI)) Q:+LEXIDI'>0 D
. Q:$P($G(^LEX(757.01,+LEXIEN,7,+LEXIDI,0)),"^",2)'=LEXSRC S LEXID=$P($G(^LEX(757.01,+LEXIEN,7,+LEXIDI,0)),"^",1)
S X=LEXID
Q X
;
GETFSN(SRC,CODE,CDT) ; Get Fully Specified Name for a Concept
;
; Input
;
; SRC Coding Sys (required)
; CODE Code (required)
; CDT Effective date (default TODAY)
;
; Output
;
; if found
; "1^"_fully specified name
; if error or not found
; "-1^"_error message
; if not found
; "-8^"_error message
;
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 Coding System (required)
; CODE Code (required)
; CDT Effective date (optional, default TODAY)
;
; Output
;
; if found
; "1^"_preferred name
; if error or not not found
; "-1^"_error message
;
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 Coding Sys (required)
; TEXT Text (required)
; CDT Effective date (default TODAY)
;
; Output
;
; if found
; "1^"_designation code
; if error or not found
; "-1^"_error message
;
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"
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
. 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
. I '+$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,$E(LEXSRC,1,3)) K LEXA(LEXIEN) Q
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 ID (VUID) or mnemonic (required)
; CDT Effective date (default TODAY)
; LEXRAY Output array (defaults 'LEX')
;
; Output
;
; if found
; "1^"_number_of_mappings
;
; LEX is an array containing the target codes
; LEX = number of mappings
; LEX(order,code) mapped codes
; order - order of the mapping
; code - target code
;
; if not found "0^0"
; if error "-1^"_error_message
; if not on file "-2^"_source _" code "_code_" not on file"
;
; Caution
; -------
; S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,[DATE],[ARR])
;
; Make sure that ARR'="VAR"
; S ORY=$$GETASSN^LEXTRAN1(CODE,MAP,,"VAR") is OK
; S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,,"VAR") is not OK
;
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 valid mappings for date
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)
...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
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 K %DT
Q Y
;
GETCIEN(CODE,CDT,SRC) ; Get Code IEN for Code/Date/Source
;
; Input
;
; CODE Classification Code (required)
; CDT Code Set Versioning Date (optional,
; default TODAY)
; SRC Coding System pointer or Source
; Abbreviation (optional)
;
; Output
;
; $$GETCIEN 3 piece "^" delimited string
;
; Content
; Piece Normal On Error
; 1 IEN -1
; 2 Status Error Message
; 3 Comment null
;
N LEX,LEXCDT,LEXCIEN,LEXCO,LEXCODE,LEXEFF,LEXIDT,LEXON
N LEXOUT,LEXSAB,LEXSN,LEXSNM,LEXSRC,LEXSRD,LEXSTA
S LEXCODE=$G(CODE) Q:'$L(LEXCODE) "-1^No code provided^"
S LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXSRC=$G(SRC),(LEXSAB,LEXSRD,LEXSNM)=""
I $L(LEXSRC) D
. S LEXSRD=$$CSYS^LEXU(LEXSRC),LEXSAB=$P(LEXSRD,"^",2)
. S LEXSNM=$P(LEXSRD,"^",4),LEXSRC=+LEXSRD
S LEXSN=$S($L(LEXSNM):(LEXSNM_" "),1:"")
Q:'$D(^LEX(757.02,"CODE",(LEXCODE_" "))) ("-1^"_LEXSN_"Code "_LEXCODE_" is not on file^")
S:$L(LEXSAB) LEX=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT,,LEXSAB)
S:'$L(LEXSAB) LEX=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT)
S LEXSTA=$P(LEX,"^",1)
S LEXCIEN=$P(LEX,"^",2)
S LEXEFF=$P(LEX,"^",3)
S LEXIDT=$P(LEX,"^",4)
S LEXCO=$S('$L(LEXSNM):"Code ",1:"code ")
S LEXON=$S($G(LEXEFF)?7N:("on "_$$FMTE^XLFDT(LEXCDT,"5Z")),1:"")
I +LEXCIEN'>0 D Q LEXOUT
. S LEXOUT="-1^"_LEXSN_LEXCO_LEXCODE_" was not found^"
I +LEXEFF'>0 D Q LEXOUT
. S LEXOUT=LEXCIEN_"^0^"_LEXSN_LEXCO_LEXCODE_" is not yet active (future activation)"
I +LEXSTA'>0,LEXEFF>0 D Q LEXOUT
. S LEXOUT=LEXCIEN_"^0^"_LEXSN_LEXCO_LEXCODE_" is inactive "_LEXON
I +LEXSTA>0,LEXEFF>0,LEXIDT>0,LEXEFF>LEXIDT D Q LEXOUT
. S LEXOUT=LEXCIEN_"^1^"_LEXSN_LEXCO_LEXCODE_" is active "_LEXON_", but has been revised"
I +LEXSTA>0,LEXEFF>0,LEXIDT>0,LEXEFF'>LEXIDT D Q LEXOUT
. S LEXOUT=LEXCIEN_"^1^"_LEXSN_LEXCO_LEXCODE_" is active "_LEXON
S LEXOUT=LEXSN_LEXCO_LEXCODE_" "_$S(LEXSTA>0:"is active",1:"is inactive")_" "_LEXON
S LEXOUT=LEXCIEN_"^"_+($G(LEXSTA))_"^"_LEXOUT
Q LEXOUT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXTRAN1 15656 printed Apr 09, 2024@21:10:38 Page 2
+1 ;;2.0;LEXICON UTILITY;**59,73,51,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.32) N/A
+5 ; ^LEX(757.33) N/A
+6 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$DT^XLFDT ICR 10103
+10 ; $$FMTE^XLFDT ICR 10103
+11 ; $$GET1^DIQ ICR 2056
+12 ; $$UP^XLFSTR ICR 10103
+13 ; ^%DT ICR 10003
+14 ;
GETSYN(SRC,CODE,CDT,LEXARY,IENS,ID,INC) ; Get Synonyms for a Concept
+1 ;
+2 ; Local Variables
+3 ;
+4 ; Input
+5 ;
+6 ; SRC Coding Sys (required)
+7 ; CODE Code (required)
+8 ; CDT Effective date (default TODAY)
+9 ; LEXARY Output array (defaults to 'LEX')
+10 ; IENS Include expression IENs in output array (optional)
+11 ; 1 return IENS (2nd piece)
+12 ; 0 do not return IENS (default)
+13 ; ID Designation Identifiers (optional)
+14 ; 1 return Designation IDs (3rd piece)
+15 ; 0 do not return Designation IDs (default)
+16 ; INC Include Deactivated Terms (optional)
+17 ; 1 return Deactivated Terms
+18 ; 0 do not return Deactivated Terms (default)
+19 ;
+20 ; Output
+21 ;
+22 ; If call finds an active code for the source
+23 ; "1^LEXCODE"
+24 ; LEX An array containing code information
+25 ; LEX("F") Fully Specified Name^IEN^Designation ID
+26 ; LEX("P") Preferred Term^IEN^Designation ID
+27 ; LEX("S",n) Synonyms 4 Piece ^ Delimited string
+28 ; 1 Synonym (required)
+29 ; 2 IEN (optional)
+30 ; 3 Designation ID (optional)
+31 ; 4 Deactivation flag (optional)
+32 ; 1 = Deactivated Synonym
+33 ;
+34 ; n is the nth Synonym
+35 ;
+36 ; Errors:
+37 ;
+38 ; "-1^Code "_LEXCODE_" not yet active for "_LEXVDT
+39 ; where LEXCODE is the code
+40 ; LEXVDT is the versioning date
+41 ;
+42 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
+43 ; where LEXSCNM is the source name
+44 ; LEXCODE is the code
+45 ;
+46 ; "-4^"_LEXSNM_" code "_LEXCODE_" not active for "_LEXVDT
+47 ; where LEXSCNM is the source name
+48 ; LEXCODE is the code
+49 ; LEXVDT is the versioning date
+50 ;
+51 ; Otherwise
+52 ; "-1^error text"
+53 ;
+54 NEW LEX2,LEX3,LEX4,LEXC,LEXCIEN,LEXCODE,LEXDEA,LEXDID,LEXEFD,LEXEX,LEXEXI,LEXFND,LEXIAD,LEXID
+55 NEW LEXIENS,LEXINC,LEXMCI,LEXN1,LEXOUT,LEXSAB,LEXSNM,LEXSRC,LEXSRD,LEXSTAT,LEXTY,LEXVDT
+56 ; Get Input Parameters
+57 SET LEXSRC=$GET(SRC)
SET LEXCODE=$GET(CODE)
SET LEXVDT=$GET(CDT)
SET LEXIENS=$GET(IENS)
SET LEXDID=$GET(ID)
SET LEXINC=+($GET(INC))
+58 ; Verify Input Parameters
+59 SET LEXSRD=$$CSYS^LEXU(LEXSRC)
SET LEXSAB=$PIECE(LEXSRD,"^",2)
SET LEXSNM=$PIECE(LEXSRD,"^",4)
SET LEXSRC=+LEXSRD
+60 if +LEXSRC'>0!($LENGTH(LEXSAB)'=3)!('$LENGTH(LEXSNM))
QUIT (-1_U_"source not recognized")
+61 if '$LENGTH($GET(LEXCODE))
QUIT -1_U_"no code specified"
+62 DO VDT^LEXU
if $PIECE(LEXVDT,".",1)'?7N
QUIT (-1_U_"invalid date format")
+63 SET LEXOUT=0
if '$LENGTH($GET(LEXARY))
SET LEXARY="LEX"
+64 SET LEXIENS=+$GET(LEXIENS)
if LEXIENS'=1
SET LEXIENS=0
+65 SET LEXDID=+$GET(LEXDID)
if LEXDID'=1
SET LEXDID=0
+66 SET LEXINC=+$GET(LEXINC)
if LEXINC'=1
SET LEXINC=0
+67 ; Get Code IEN, Status, Effective Date and Initial Activation Date
+68 SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT,LEXSAB)
+69 SET LEXCIEN=$PIECE(LEXSTAT,"^",2)
SET LEXEFD=$PIECE(LEXSTAT,"^",3)
SET LEXIAD=$PIECE(LEXSTAT,"^",4)
SET LEXSTAT=+LEXSTAT
+70 ; Quit Conditions
+71 ; Code not found
+72 IF +LEXCIEN<0
QUIT (-2_U_LEXSNM_" code "_LEXCODE_" not on file")
+73 ; No Effective Date (pending activation)
+74 IF +LEXCIEN>0
IF LEXSTAT'>0
IF LEXEFD'?7N
IF LEXIAD'?7N
Begin DoDot:1
+75 SET LEXOUT="-4^"_LEXSNM_" code "_LEXCODE_" not yet active for "_$SELECT(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
End DoDot:1
if LEXINC'>0
QUIT LEXOUT
+76 ; Inactive Code
+77 IF +LEXCIEN>0
IF LEXSTAT'>0
IF LEXEFD?7N
Begin DoDot:1
+78 SET LEXOUT="-4^"_LEXSNM_" code "_LEXCODE_" not active for "_$SELECT(LEXVDT?7N:$$FMTE^XLFDT(LEXVDT,"5Z"),1:"")
End DoDot:1
if LEXINC'>0
QUIT LEXOUT
+79 ; Get Terms for the Major Concept
+80 SET LEXMCI=$PIECE(^LEX(757.02,+LEXCIEN,0),U,4)
SET LEXEXI=""
SET LEXFND=0
+81 KILL LEX2
FOR
SET LEXEXI=$ORDER(^LEX(757.01,"AMC",LEXMCI,LEXEXI))
if LEXEXI=""
QUIT
Begin DoDot:1
+82 SET LEXFND=LEXFND+1
SET LEX2(LEXEXI)=""
End DoDot:1
+83 ; Get Info for Terms
+84 KILL LEX3
SET LEXEXI=""
FOR
SET LEXEXI=$ORDER(LEX2(LEXEXI))
if LEXEXI=""
QUIT
Begin DoDot:1
+85 NEW LEXN1,LEXID,LEXC,LEXDEA
SET LEXEX=^LEX(757.01,LEXEXI,0)
SET LEXDEA=0
+86 SET LEXN1=$GET(^LEX(757.01,LEXEXI,1))
if +($GET(LEXINC))'>0&($PIECE(LEXN1,"^",5)>0)
QUIT
+87 if +($GET(LEXINC))>0&($PIECE(LEXN1,"^",5)>0)
SET LEXDEA=1
+88 SET LEXID=""
IF LEXDID>0
Begin DoDot:2
+89 SET LEXID=$ORDER(^LEX(757.01,LEXEXI,7,"C",+LEXSRC,""))
End DoDot:2
+90 SET LEXTY=$PIECE(^LEX(757.01,LEXEXI,1),U,2)
+91 IF LEXTY=1
Begin DoDot:2
+92 SET LEX3("P")=LEXEX_$SELECT(+LEXEXI>0&(+($GET(LEXIENS))>0):(U_LEXEXI),1:"")
if $LENGTH(LEXID)
SET $PIECE(LEX3("P"),"^",3)=LEXID
End DoDot:2
QUIT
+93 IF LEXTY=8
Begin DoDot:2
+94 SET LEX3("F")=LEXEX_$SELECT(+LEXEXI>0&(+($GET(LEXIENS))>0):(U_LEXEXI),1:"")
if $LENGTH(LEXID)
SET $PIECE(LEX3("F"),"^",3)=LEXID
End DoDot:2
QUIT
+95 SET LEXC=$ORDER(LEX3("S"," "),-1)+1
+96 SET LEX3("S",LEXC)=LEXEX_$SELECT(+LEXEXI>0&(+($GET(LEXIENS))>0):(U_LEXEXI),1:"")
+97 if $LENGTH(LEXID)
SET $PIECE(LEX3("S",LEXC),"^",3)=LEXID
+98 if LEXDEA>0
SET $PIECE(LEX3("S",LEXC),"^",4)=1
End DoDot:1
+99 KILL LEX4
MERGE LEX4=LEX3
+100 SET LEXFND=''$DATA(LEX4("F"))+''$DATA(LEX4("P"))+$ORDER(LEX4("S"," "),-1)
+101 IF $DATA(LEXARY)
IF LEXARY'="LEX4"
MERGE @LEXARY=LEX4
+102 KILL LEX4
IF LEXOUT=0
SET LEXOUT=''LEXFND_U_LEXFND
+103 QUIT LEXOUT
+104 ;
GETDID(X,IEN) ; Get Designation ID based on Source and IEN
+1 ;
+2 ; Input
+3 ;
+4 ; X Coding Sys (required)
+5 ; IEN IEN in the Expressions file #757.01 (required)
+6 ;
+7 ; Output
+8 ;
+9 ; $$GETDID Designation ID
+10 ;
+11 ; Otherwise
+12 ;
+13 ; "-1^"_error message
+14 ;
+15 SET LEXSRC=$EXTRACT($GET(X),1,3)
SET LEXIEN=$GET(IEN)
if +LEXIEN'>0
QUIT (-1_U_"IEN not specified")
+16 if '$LENGTH(LEXSRC)
QUIT (-1_U_"source not recognized")
if '$DATA(^LEX(757.01,+LEXIEN,0))
QUIT (-1_U_"Expression entry not found")
+17 if $ORDER(^LEX(757.01,+LEXIEN,7,0))'>0
QUIT (-1_U_"No designation IDs found")
SET LEXSRD=$$CSYS^LEXU(LEXSRC)
+18 if +LEXSRD'>0
QUIT (-1_U_"source not recognized")
SET LEXSAB=$PIECE(LEXSRD,"^",2)
SET LEXSRC=+LEXSRD
+19 if ($LENGTH(LEXSAB)'=3)!(+LEXSRC'>0)
QUIT (-1_U_"Invalid source")
if '$DATA(^LEX(757.03,"ASAB",LEXSAB))
QUIT (-1_U_"Invalid source")
+20 if '$DATA(^LEX(757.03,LEXSRC,0))
QUIT (-1_U_"Invalid source")
SET LEXID=""
SET LEXIDI=0
+21 FOR
SET LEXIDI=$ORDER(^LEX(757.01,+LEXIEN,7,LEXIDI))
if +LEXIDI'>0
QUIT
Begin DoDot:1
+22 if $PIECE($GET(^LEX(757.01,+LEXIEN,7,+LEXIDI,0)),"^",2)'=LEXSRC
QUIT
SET LEXID=$PIECE($GET(^LEX(757.01,+LEXIEN,7,+LEXIDI,0)),"^",1)
End DoDot:1
+23 SET X=LEXID
+24 QUIT X
+25 ;
GETFSN(SRC,CODE,CDT) ; Get Fully Specified Name for a Concept
+1 ;
+2 ; Input
+3 ;
+4 ; SRC Coding Sys (required)
+5 ; CODE Code (required)
+6 ; CDT Effective date (default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; if found
+11 ; "1^"_fully specified name
+12 ; if error or not found
+13 ; "-1^"_error message
+14 ; if not found
+15 ; "-8^"_error message
+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 Coding System (required)
+5 ; CODE Code (required)
+6 ; CDT Effective date (optional, default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; if found
+11 ; "1^"_preferred name
+12 ; if error or not not found
+13 ; "-1^"_error message
+14 ;
+15 NEW LEXSRC,LEXCODE,LEXVDT
SET LEXSRC=$GET(SRC)
SET LEXCODE=$GET(CODE)
SET LEXVDT=$GET(CDT)
+16 NEW SYNS,LEX
SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
+17 IF $GET(LEXCODE)=""
QUIT -1_U_"no code specified"
+18 IF $GET(LEXSRC)=""
QUIT -1_U_"no source specified"
+19 IF +($$CSYS^LEXU(LEXSRC))'>0
QUIT -1_U_"source not recognized"
+20 IF $LENGTH($GET(LEXVDT))
IF $PIECE($GET(LEXVDT),".",1)'?7N
SET LEXVDT=$$INTDAT(LEXVDT)
+21 DO VDT^LEXU
IF $PIECE($GET(LEXVDT),".",1)'?7N
QUIT -1_U_"invalid date format"
+22 IF $GET(LEXVDT)=-1
QUIT -1_U_"invalid date format"
+23 IF $GET(LEXVDT)=""
SET LEXVDT=$$DT^XLFDT
+24 SET SYNS=$$GETSYN(LEXSRC,LEXCODE,$GET(LEXVDT))
+25 IF +SYNS'>0
QUIT SYNS
+26 QUIT 1_U_LEX("P")
+27 ;
GETDES(SRC,TEXT,CDT) ; Get the Designation Code for a Concept/Synonym
+1 ;
+2 ; Input
+3 ;
+4 ; SRC Coding Sys (required)
+5 ; TEXT Text (required)
+6 ; CDT Effective date (default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; if found
+11 ; "1^"_designation code
+12 ; if error or not found
+13 ; "-1^"_error message
+14 ;
+15 NEW LEXSRC,LEXTEXT,LEXVDT
SET LEXSRC=$GET(SRC)
SET LEXTEXT=$GET(TEXT)
SET LEXVDT=$GET(CDT)
+16 NEW LEXA,LEXCIEN,LEXDSG,LEXIEN,LEXMC,LEXSAB,LEXSIEN,LEXSO
+17 NEW LEXSR,LEXSRD,LEXSRI,LEXSUB,LEXTMP
SET LEXSRC=$EXTRACT($GET(LEXSRC),1,3)
+18 SET LEXSRD=$$CSYS^LEXU(LEXSRC)
SET LEXSAB=$PIECE(LEXSRD,"^",2)
+19 SET LEXSRI=+LEXSRD
if $GET(LEXSRC)=""
QUIT -1_U_"no source specified"
+20 if +LEXSRI'>0
QUIT -1_U_"source not recognized"
+21 if '$LENGTH($GET(LEXTEXT))
QUIT -1_U_"no text specified"
+22 SET LEXTMP=$GET(^TMP("LEXSCH",$JOB,"VDT",0))
+23 if LEXTMP?7N
SET LEXVDT=LEXTMP
+24 IF $LENGTH($GET(LEXVDT))
IF $PIECE($GET(LEXVDT),".",1)'?7N
SET LEXVDT=$$INTDAT(LEXVDT)
+25 DO VDT^LEXU
IF $PIECE($GET(LEXVDT),".",1)'?7N
QUIT -1_U_"invalid date format"
+26 SET LEXSUB=$EXTRACT($$UP^XLFSTR(LEXTEXT),1,63)
+27 SET LEXIEN=""
+28 FOR
SET LEXIEN=$ORDER(^LEX(757.01,"B",LEXSUB,LEXIEN))
if LEXIEN=""
QUIT
Begin DoDot:1
+29 IF $$UP^XLFSTR(^LEX(757.01,LEXIEN,0))=$$UP^XLFSTR(LEXTEXT)
SET LEXA(LEXIEN)=$PIECE(^LEX(757.01,LEXIEN,1),U)
End DoDot:1
+30 SET LEXIEN=""
+31 FOR
SET LEXIEN=$ORDER(LEXA(LEXIEN))
if LEXIEN=""
QUIT
Begin DoDot:1
+32 NEW LEXSR
SET LEXMC=LEXA(LEXIEN)
+33 SET (LEXCIEN,LEXSIEN)=""
+34 FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSIEN))
if LEXSIEN=""
QUIT
Begin DoDot:2
+35 SET LEXSR=$PIECE(^LEX(757.02,LEXSIEN,0),U,3)
+36 IF +($$CSYS^LEXU(LEXSRC))'=LEXSR
QUIT
+37 IF $PIECE(^LEX(757.02,LEXSIEN,0),U,5)'=1
QUIT
+38 SET LEXCIEN=LEXSIEN
End DoDot:2
+39 IF LEXCIEN=""
KILL LEXA(LEXIEN)
QUIT
+40 SET LEXSO=$PIECE(^LEX(757.02,LEXCIEN,0),U,2)
+41 SET LEXSR=$PIECE(^LEX(757.02,LEXCIEN,0),U,3)
+42 IF +($$CSYS^LEXU(LEXSRC))'=LEXSR
KILL LEXA(LEXIEN)
QUIT
+43 IF '+$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,$EXTRACT(LEXSRC,1,3))
KILL LEXA(LEXIEN)
QUIT
End DoDot:1
+44 SET LEXIEN=$ORDER(LEXA(""))
+45 IF LEXIEN=""
QUIT -1_U_"text not recognized for source"
+46 SET LEXDSG=$ORDER(^LEX(757.01,LEXIEN,7,"C",+LEXSRI,""))
+47 IF LEXDSG=""
QUIT -1_U_"no designation code for text and source"
+48 QUIT 1_U_LEXDSG
+49 ;
GETASSN(CODE,MAP,CDT,LEXRAY) ; Get Mapped Associated Codes
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code (required)
+5 ; MAP Mapping ID (VUID) or mnemonic (required)
+6 ; CDT Effective date (default TODAY)
+7 ; LEXRAY Output array (defaults 'LEX')
+8 ;
+9 ; Output
+10 ;
+11 ; if found
+12 ; "1^"_number_of_mappings
+13 ;
+14 ; LEX is an array containing the target codes
+15 ; LEX = number of mappings
+16 ; LEX(order,code) mapped codes
+17 ; order - order of the mapping
+18 ; code - target code
+19 ;
+20 ; if not found "0^0"
+21 ; if error "-1^"_error_message
+22 ; if not on file "-2^"_source _" code "_code_" not on file"
+23 ;
+24 ; Caution
+25 ; -------
+26 ; S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,[DATE],[ARR])
+27 ;
+28 ; Make sure that ARR'="VAR"
+29 ; S ORY=$$GETASSN^LEXTRAN1(CODE,MAP,,"VAR") is OK
+30 ; S VAR=$$GETASSN^LEXTRAN1(CODE,MAP,,"VAR") is not OK
+31 ;
+32 NEW LEXCODE,LEXMAP,LEXVDT
SET LEXCODE=$GET(CODE)
SET LEXMAP=$GET(MAP)
SET LEXVDT=$GET(CDT)
+33 IF $GET(LEXCODE)=""
QUIT -1_U_"no code specified"
+34 IF $GET(LEXMAP)=""
QUIT -1_U_"no mapping specified"
+35 IF $LENGTH($GET(LEXVDT))
IF $PIECE($GET(LEXVDT),".",1)'?7N
SET LEXVDT=$$INTDAT(LEXVDT)
+36 DO VDT^LEXU
IF $PIECE($GET(LEXVDT),".",1)'?7N
QUIT -1_U_"invalid date format"
+37 SET LEXRAY=$GET(LEXRAY,"LEX")
+38 NEW MIDIEN,CSYS,CIEN,VALCD,MORD,MTAR,MIEN,EFDT,STAT,CT,VUID
+39 IF '$DATA(^LEX(757.32,"B",LEXMAP))
IF '$DATA(^LEX(757.32,"C",LEXMAP))
QUIT -1_U_"unrecognized mapping identifier"
+40 IF $DATA(^LEX(757.32,"C",LEXMAP))
Begin DoDot:1
+41 SET MIDIEN=$ORDER(^LEX(757.32,"C",LEXMAP,""))
End DoDot:1
+42 IF $DATA(^LEX(757.32,"B",LEXMAP))
Begin DoDot:1
+43 SET MIDIEN=$ORDER(^LEX(757.32,"B",LEXMAP,""))
End DoDot:1
+44 IF '$DATA(MIDIEN)
QUIT -1_U_"not a recognized mapping identifier"
+45 SET CSYS=$$GET1^DIQ(757.32,MIDIEN_",",3)
+46 ; Check that code exists for coding system
+47 SET CIEN=""
SET VALCD=0
+48 FOR
if VALCD=1
QUIT
Begin DoDot:1
+49 SET CIEN=$ORDER(^LEX(757.02,"CODE",LEXCODE_" ",CIEN))
if CIEN=""
QUIT
Begin DoDot:2
End DoDot:2
+50 SET VALCD=''$DATA(^LEX(757.02,"ASRC",$$LEXASAB(CSYS),CIEN))
End DoDot:1
if CIEN=""
QUIT
+51 IF 'VALCD
QUIT -2_U_$$LEXSCNM(CSYS)_" code "_LEXCODE_" not on file"
+52 ; Obtain valid mappings for date
+53 SET (MORD,MTAR,MIEN)=""
+54 KILL LEX
+55 SET LEX=0
+56 FOR
SET MORD=$ORDER(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD))
if MORD=""
QUIT
Begin DoDot:1
+57 FOR
SET MTAR=$ORDER(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR))
if MTAR=""
QUIT
Begin DoDot:2
+58 FOR
SET MIEN=$ORDER(^LEX(757.33,"C",MIDIEN,LEXCODE,MORD,MTAR,MIEN))
if MIEN=""
QUIT
Begin DoDot:3
+59 NEW MAT
SET MAT=$PIECE($GET(^LEX(757.33,+MIEN,0)),U,5)
+60 SET VUID=$PIECE(^LEX(757.33,MIEN,0),U)
+61 SET EFDT=+$ORDER(^LEX(757.33,"G",VUID,LEXVDT+.0001),-1)
+62 if EFDT=0
QUIT
+63 SET STAT=+$ORDER(^LEX(757.33,"G",VUID,EFDT,""))
+64 if STAT=0
QUIT
+65 SET LEX=LEX+1
+66 SET LEX(MORD,MTAR)=MAT
End DoDot:3
End DoDot:2
End DoDot:1
+67 IF LEXRAY'="LEX"
MERGE @LEXRAY=LEX
KILL LEX
+68 QUIT ''@LEXRAY_U_@LEXRAY
+69 ;
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
DO ^%DT
KILL %DT
+3 QUIT Y
+4 ;
GETCIEN(CODE,CDT,SRC) ; Get Code IEN for Code/Date/Source
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Classification Code (required)
+5 ; CDT Code Set Versioning Date (optional,
+6 ; default TODAY)
+7 ; SRC Coding System pointer or Source
+8 ; Abbreviation (optional)
+9 ;
+10 ; Output
+11 ;
+12 ; $$GETCIEN 3 piece "^" delimited string
+13 ;
+14 ; Content
+15 ; Piece Normal On Error
+16 ; 1 IEN -1
+17 ; 2 Status Error Message
+18 ; 3 Comment null
+19 ;
+20 NEW LEX,LEXCDT,LEXCIEN,LEXCO,LEXCODE,LEXEFF,LEXIDT,LEXON
+21 NEW LEXOUT,LEXSAB,LEXSN,LEXSNM,LEXSRC,LEXSRD,LEXSTA
+22 SET LEXCODE=$GET(CODE)
if '$LENGTH(LEXCODE)
QUIT "-1^No code provided^"
+23 SET LEXCDT=$GET(CDT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+24 SET LEXSRC=$GET(SRC)
SET (LEXSAB,LEXSRD,LEXSNM)=""
+25 IF $LENGTH(LEXSRC)
Begin DoDot:1
+26 SET LEXSRD=$$CSYS^LEXU(LEXSRC)
SET LEXSAB=$PIECE(LEXSRD,"^",2)
+27 SET LEXSNM=$PIECE(LEXSRD,"^",4)
SET LEXSRC=+LEXSRD
End DoDot:1
+28 SET LEXSN=$SELECT($LENGTH(LEXSNM):(LEXSNM_" "),1:"")
+29 if '$DATA(^LEX(757.02,"CODE",(LEXCODE_" ")))
QUIT ("-1^"_LEXSN_"Code "_LEXCODE_" is not on file^")
+30 if $LENGTH(LEXSAB)
SET LEX=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT,,LEXSAB)
+31 if '$LENGTH(LEXSAB)
SET LEX=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT)
+32 SET LEXSTA=$PIECE(LEX,"^",1)
+33 SET LEXCIEN=$PIECE(LEX,"^",2)
+34 SET LEXEFF=$PIECE(LEX,"^",3)
+35 SET LEXIDT=$PIECE(LEX,"^",4)
+36 SET LEXCO=$SELECT('$LENGTH(LEXSNM):"Code ",1:"code ")
+37 SET LEXON=$SELECT($GET(LEXEFF)?7N:("on "_$$FMTE^XLFDT(LEXCDT,"5Z")),1:"")
+38 IF +LEXCIEN'>0
Begin DoDot:1
+39 SET LEXOUT="-1^"_LEXSN_LEXCO_LEXCODE_" was not found^"
End DoDot:1
QUIT LEXOUT
+40 IF +LEXEFF'>0
Begin DoDot:1
+41 SET LEXOUT=LEXCIEN_"^0^"_LEXSN_LEXCO_LEXCODE_" is not yet active (future activation)"
End DoDot:1
QUIT LEXOUT
+42 IF +LEXSTA'>0
IF LEXEFF>0
Begin DoDot:1
+43 SET LEXOUT=LEXCIEN_"^0^"_LEXSN_LEXCO_LEXCODE_" is inactive "_LEXON
End DoDot:1
QUIT LEXOUT
+44 IF +LEXSTA>0
IF LEXEFF>0
IF LEXIDT>0
IF LEXEFF>LEXIDT
Begin DoDot:1
+45 SET LEXOUT=LEXCIEN_"^1^"_LEXSN_LEXCO_LEXCODE_" is active "_LEXON_", but has been revised"
End DoDot:1
QUIT LEXOUT
+46 IF +LEXSTA>0
IF LEXEFF>0
IF LEXIDT>0
IF LEXEFF'>LEXIDT
Begin DoDot:1
+47 SET LEXOUT=LEXCIEN_"^1^"_LEXSN_LEXCO_LEXCODE_" is active "_LEXON
End DoDot:1
QUIT LEXOUT
+48 SET LEXOUT=LEXSN_LEXCO_LEXCODE_" "_$SELECT(LEXSTA>0:"is active",1:"is inactive")_" "_LEXON
+49 SET LEXOUT=LEXCIEN_"^"_+($GET(LEXSTA))_"^"_LEXOUT
+50 QUIT LEXOUT
