LEXABC ;ISL/KER - Look-up by Code ;04/19/2020
;;2.0;LEXICON UTILITY;**4,25,26,29,38,73,51,80,103,127**;Sep 23, 1996;Build 1
;
; Global Variables
; ^ICPT("BA") ICR 5408
; ^LEX(757 SACC 1.3
; ^LEX(757.01 SACC 1.3
; ^LEX(757.02 SACC 1.3
; ^LEX(757.03 SACC 1.3
; ^LEX(757.21 SACC 1.3
; ^LEXT(757.2 SACC 1.3
; ^TMP("LEXFND") SACC 2.3.2.5.1
; ^TMP("LEXHIT") SACC 2.3.2.5.1
; ^TMP("LEXL") SACC 2.3.2.5.1
; ^TMP("LEXLE") SACC 2.3.2.5.1
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$CODEABA^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; DIC Global Root
; LEXAFMT Display Format
; LEXFIL Filter
; LEXISCD Input is a Code
;
EN(LEXSO,LEXVDT) ; Entry from LEXA
;
; Input
; LEXSO Code Preferred terms only
; Code+ All terms
; LEXVDT Version Date to screen against (default = today)
;
; Output
; $$EN 1 Code found
; 0 Code not found
;
S LEXSO=$$UP^XLFSTR($G(LEXSO)) Q:'$L(LEXSO) 0 Q:$L(LEXSO)>40 0
S:$D(LEXISCD) LEXISCD=$$IS(LEXSO) N LEXLL,LEXSOA
S:$G(^TMP("LEXSCH",$J,"LEN",0))>0 LEXLL=$G(^TMP("LEXSCH",$J,"LEN",0)) S:$G(LEXLL)'>0 LEXLL=5
I $D(^TMP("LEXSCH",$J,"FMT",0)) S:'$D(LEXAFMT)!($G(LEXAFMT)'?1N) LEXAFMT=$G(^TMP("LEXSCH",$J,"FMT",0))
D VDT^LEXU,BLD K ^TMP("LEXL",$J),^TMP("LEXLE",$J)
S:$L($G(^TMP("LEXSCH",$J,"NAR",0))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
Q:$D(^TMP("LEXHIT",$J)) 1
Q 0
BLD ; Build List
N LEXSO2 D CLR K ^TMP("LEXSCH",$J,"LST",0),^TMP("LEXSCH",$J,"TOL",0),LEX S ^TMP("LEXSCH",$J,"NUM",0)=0,LEXSO=$G(LEXSO)
S LEXSO2="" S:$E(LEXSO,$L(LEXSO))="+" LEXSO2=$E(LEXSO,$L(LEXSO)),LEXSO=$$TM(LEXSO,"+")
I (LEXSO2="+"&($L(LEXSO)'>2))!(LEXSO2=""&($L(LEXSO)'>1)) D CLR Q
I '(+($$IN(LEXSO))) D CLR Q
D FND D:$D(^TMP("LEXFND",$J)) BEG^LEXAL Q:$D(^TMP("LEXFND",$J)) D:'$D(^TMP("LEXFND",$J)) CLR
Q
FND ; Find expressions
K ^TMP("LEXL",$J),^TMP("LEXLE",$J)
N LEXSIEN,LEXMIEN,LEXEIEN,LEXDESF,LEXDSPL,LEXDSPLA,LEXFORM,LEXFMTY,LEXS,LEXSAB,LEXSRC,LEXSDATA
N LEXP,LEXTP,LEXTYPE,LEXFILR,LEXFORM,LEXC,LEXCSTAT,LEXDSAB,LEXSSAB,LEXLKT S LEXLKT="ABC"
S LEXSSAB=$G(^TMP("LEXSCH",$J,"DIS",0)),U="^",LEXS=$$SCH(LEXSO)_" "
S:'$L($G(LEXFIL))&($L($G(DIC("S")))) LEXFIL=DIC("S")
S:'$L($G(LEXFIL))&($L($G(^TMP("LEXSCH",$J,"LEXFIL",0)))) LEXFIL=$G(^TMP("LEXSCH",$J,"LEXFIL",0))
F S LEXS=$O(^LEX(757.02,"AVA",LEXS)) Q:$E(LEXS,1,$L(LEXSO))'=LEXSO D
. S LEXEIEN=0 F S LEXEIEN=$O(^LEX(757.02,"AVA",LEXS,LEXEIEN)) Q:+LEXEIEN=0 D
. . I $L($G(LEXFIL)) D Q:+($G(LEXFILR))=0
. . . I LEXFIL'["$$SO^LEXU(Y",LEXFIL'["ONE^LEXU" D Q
. . . . S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),+($G(^LEX(757,+($G(^LEX(757.01,LEXEIEN,1))),0))))
. . . S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),+LEXEIEN)
. . S LEXSAB="" F S LEXSAB=$O(^LEX(757.02,"AVA",LEXS,LEXEIEN,LEXSAB)) Q:LEXSAB="" D
. . . S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"AVA",LEXS,LEXEIEN,LEXSAB,LEXSIEN)) Q:+LEXSIEN=0 D
. . . . N LEXEXI,LEXSTAC,STATI,STATT S LEXSDATA=$G(^LEX(757.02,LEXSIEN,0))
. . . . S LEXC=$P(LEXSDATA,"^",2),LEXSRC=$P(LEXSDATA,"^",3),LEXEXI=$P(LEXSDATA,"^",1)
. . . . Q:$$INSUB(+LEXSDATA)=0
. . . . S LEXSTAC=+$$STATCHK^LEXSRC2(LEXC,$G(LEXVDT),,LEXSRC)
. . . . Q:'$D(LEXIGN)&(+LEXSTAC'=1)
. . . . S LEXTYPE=+$P(LEXSDATA,"^",3)
. . . . S LEXDSAB=$E($G(^LEX(757.03,+LEXTYPE,0)),1,3)
. . . . S LEXMIEN=+$P(LEXSDATA,"^",4),(LEXP,LEXTP)=+$P(LEXSDATA,"^",5)
. . . . S STATI=$$STATIEN(LEXSIEN)
. . . . S STATT=$P(STATI,"^",2),STATI=+($P(STATI,"^",1))
. . . . Q:'$D(LEXIGN)&(+STATI=0)
. . . . S LEXDESF=$$DC(LEXEIEN,LEXTP)
. . . . S LEXDSPL=$$DP(LEXS,LEXTYPE,LEXSSAB)
. . . . S LEXDSPLA=$$DSO(+LEXEIEN,$G(LEXVDT),$G(LEXSSAB),$G(LEXDSAB))
. . . . S LEXDSPL=$$TM($$MDS(LEXDSPL,LEXDSPLA),"/")
. . . . S:$D(LEXIGN)&("^Pending^Inactive^"[("^"_STATT_"^")) LEXDSPL=LEXDSPL_"/"_STATT
. . . . S LEXFORM=$$F(LEXEIEN),LEXFMTY=$P(LEXFORM,"^",1),LEXFORM=$P(LEXFORM,"^",2)
. . . . ; NEW
. . . . I "^1^2^3^4^17^30^31^"'[("^"_LEXTYPE_"^") D NP Q
. . . . ; OLD
. . . . ;I LEXTYPE>3,LEXTYPE'=17 D NP Q
. . . . D PF
D:$D(^TMP("LEXL",$J)) REO^LEXABC2,ADD^LEXABC2
Q
; ^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)
; ^TMP("LEXL",$J,(code_" "),+source,LEXTP,LEXSIEN)
PF ; Preferred
S:LEXP=0 LEXTP=2 Q:LEXTP=2&($G(LEXSO2)'["+")
S ^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
S ^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
Q
NP ; Not Preferred
N LEXICD S:LEXP=0 LEXTP=1
I $D(^TMP("LEXLE",$J,LEXEIEN)) D Q
. N LEX1,LEX2,LEX3,LEX4,LEXD,LEXDP
. S LEXD=^TMP("LEXLE",$J,LEXEIEN),LEX1=$P(LEXD,"^",1) Q:'$L(LEX1) S LEX2=$P(LEXD,"^",2) Q:'$L(LEX2)
. S LEX3=$P(LEXD,"^",3) Q:'$L(LEX3) S LEX4=$P(LEXD,"^",4) Q:'$L(LEX4)
. S LEXD=$G(^TMP("LEXL",$J,LEX1,LEX2,LEX3,LEX4)) Q:'$L(LEXD)
. S LEXDP=$P(LEXD,"^",4) S:$L(LEXDP) LEXDP=LEXDP_"/"_LEXDSPL S:'$L(LEXDP) LEXDP=LEXDSPL
. S $P(LEXD,"^",4)=LEXDP,^TMP("LEXL",$J,LEX1,LEX2,LEX3,LEX4)=LEXD
; NEW
S LEXICD=$$D10ONE^LEXU(LEXEIEN)
; OLD
;S LEXICD=$$ICDONE^LEXU(LEXEIEN)
I '$L(LEXICD) D Q
. S ^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
. S ^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
I $L(LEXICD) D Q
. ; NEW
. I $L(LEXDSPL),LEXSO2["+",LEXDSPL'[("ICD-10-CM "_LEXICD) D
. . S LEXDSPL=LEXDSPL_"/ICD-10-CM "_LEXICD S LEXDSPL=$$TM(LEXDSPL,"/")
. ; OLD
. ;S:$L(LEXDSPL)&(LEXSO2["+") LEXDSPL=LEXDSPL_"/ICD-9-CM "_LEXICD
. I LEXSO2["+",$D(^TMP("LEXL",$J,LEXS,1)) D Q
. . S ^TMP("LEXL",$J,LEXS,1,4,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
. . S ^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^1^3^"_LEXSIEN
. S LEXTP=1,^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
. S ^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
Q
;
; Miscellaneous
F(X) ; Form
N LEX S LEX=$G(X) S LEX=+($G(LEX)),LEX=+($P($G(^LEX(757.01,LEX,1)),"^",2))
S X=$S(LEX=1:"A^Concept: ",LEX=2:"B^Synonym: ",LEX=3:"C^Variant: ",LEX=4:"D^Related: ",LEX=5:"E^Modified: ",1:"F^Other: ")
Q X
DE(X) ; Deactivated 757.01
N LEX S LEX=+($G(X)) Q:'$D(^LEX(757.01,LEX,0)) 1
Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEX,1)),"^",5))=1) 1
S LEX=+($G(^LEX(757.01,LEX,1))) Q:'$D(^LEX(757,LEX,0)) 1
S LEX=+($G(^LEX(757,LEX,0))) Q:'$D(^LEX(757.01,LEX,1)) 1
Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEX,1)),"^",5))=1) 1
Q 0
DC(X,Y) ; Description Flag
N LEX,LEXT,LEXD,LEXM S LEX=$G(X),LEXT=$G(Y),LEXD="",LEX=+($G(LEX))
S LEXM=$P($G(^LEX(757.01,+($G(LEX)),1)),"^",1),LEXM=+($G(^LEX(757,+($G(LEXM)),0)))
S:$D(^LEX(757.01,LEXM,3))&(+($G(LEXT))'=2) LEXD="*" S X=$G(LEXD)
Q X
DP(X,Y,A) ; Display
N LEXA,LEXS,LEXT,LEXD S LEXS=$G(X),LEXT=+($G(Y)),LEXD=$G(A)
S LEXA=$E($P($G(^LEX(757.03,LEXT,0)),"^",1),1,3)
Q:'$L(LEXD) "" Q:'$L(LEXA) "" Q:LEXD'[LEXA ""
S LEXT=$P($G(^LEX(757.03,LEXT,0)),"^",2)
S LEXS=$G(LEXS) S:$E(LEXS,$L(LEXS))=" " LEXS=$E(LEXS,1,($L(LEXS)-1))
S:$L(LEXS)&($L(LEXT)) LEXS=LEXT_" "_LEXS Q:$L(LEXS)&($L(LEXT)) LEXS
Q ""
DSO(X,Y,A,B) ; Display Sources String
N LEXT,LEXS,LEXD,LEXIEN,LEXSAB,LEXVDT S LEXVDT=$G(Y),LEXS=$G(A),LEXD=$G(B),LEXIEN=+($G(X)) Q:+LEXIEN'>0 ""
S LEXT=$G(LEXS),LEXSAB=$G(LEXD) S LEXT=$$TM(LEXT,"/") S X=$$SO^LEXASO(LEXIEN,LEXT,1,$G(LEXVDT)) Q:$L(X) X
S:$L(LEXSAB)=3&(LEXT'[LEXSAB) LEXT=LEXT_"/"_LEXSAB S LEXT=$$TM(LEXT,"/")
Q X
MDS(X,Y) ; Merge Display Strings
N LEXD,LEXA S LEXD=$G(X),LEXA=$G(Y) F Q:LEXA'[") (" S LEXA=$P(LEXA,") (",1)_"/"_$P(LEXA,") (",2,4000)
S LEXA=$TR(LEXA,"(",""),LEXA=$TR(LEXA,")","")
Q:'$L($G(LEXD)) LEXA S:LEXA'[$G(LEXD) LEXA=LEXD_"/"_LEXA S X=$G(LEXA)
Q X
CLR ; Clear
K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXL",$J),LEX S LEX=0 Q
CLR2 ; Clear 2
N LEXIGN
Q
IN(X) ; Flag in/not in file 757.02
Q:$O(^LEX(757.02,"AVA",(($$SCH($E($G(X),1,61)))_" ")))[$G(X) 1
Q 0
SCH(X) ; Search
S X=$E($G(X),1,($L($G(X))-1))_$C($A($E($G(X),$L($G(X))))-1)_"~" Q X
INSUB(X) ; Check if selected code in vocab
N LEXFLN,LEXVOC,SUBIEN,LEXEIEN S LEXEIEN=$G(X)
S LEXFLN=$G(^TMP("LEXSCH",$J,"FLN",0)) Q:LEXFLN=""!(LEXFLN="757.01") 1
S LEXVOC=$G(^TMP("LEXSCH",$J,"VOC",0)) Q:LEXVOC=""!(LEXVOC="WRD") 1
Q:$D(^LEXT(757.2,"AA",LEXVOC))'=10 1
S SUBIEN=$O(^LEXT(757.2,"AA",LEXVOC,"")) Q:+SUBIEN'>0 1
Q:$$INPSUB(LEXEIEN,SUBIEN) 1
Q 0
INPSUB(X,Y) ; Check if concept X is member of subset Y
N LEXPRF,LEXSUB S LEXPRF=$G(X),LEXSUB=$G(Y) S LEXPRF=$G(X) Q:'$L(LEXPRF) 0
N LEXIN,LEXSIEN S LEXSIEN="",LEXIN=0
F S LEXSIEN=$O(^LEX(757.21,"B",LEXPRF,LEXSIEN)) Q:LEXSIEN="" D Q:LEXIN=1
. I $P(^LEX(757.21,LEXSIEN,0),U,2)=$G(LEXSUB) S LEXIN=1
S X=LEXIN
Q X
STATIEN(X) ; Status of code-expression pairing based on code IEN
N STATDAT,STATIEN,LEXH,LEXI,LEXT,LEXTD,LEXCIEN S LEXT="",LEXCIEN=+($G(X))
Q:'$D(^LEX(757.02,LEXCIEN)) 0 I $D(LEXIGN) D
. N LEXTD S LEXTD=$G(DT) S:LEXTD'?7N LEXTD=$$DT^XLFDT
. S LEXH=$O(^LEX(757.02,LEXCIEN,4,"B",(LEXTD+.00001)),-1)
. I LEXH'?7N,$O(^LEX(757.02,LEXCIEN,4,"B",(LEXTD-.00001)))>0 S LEXT="Pending" Q
. S LEXI=$O(^LEX(757.02,LEXCIEN,4,"B",+LEXH," "),-1)
. S LEXT=$P($G(^LEX(757.02,LEXCIEN,4,+LEXI,0)),"^",2)
. S LEXT=$S(LEXT="1":"",LEXT="0":"Inactive",1:"")
I $D(LEXIGN) Q:LEXT="Pending" "0^Pending"
S STATDAT=$O(^LEX(757.02,LEXCIEN,4,"B",$S($G(LEXVDT)'="":(LEXVDT+.001),1:"")),-1)
S STATIEN=$O(^LEX(757.02,LEXCIEN,4,"B",+STATDAT,""),-1)
S STATDAT=+$P($G(^LEX(757.02,LEXCIEN,4,+STATIEN,0)),"^",2)
S:$D(LEXIGN)&($L($G(LEXT))) STATDAT=STATDAT_"^"_LEXT S X=$G(STATDAT)
Q X
NONPLUS(X) ; Remove trialing plus (+)
Q $$TM($G(X),"+")
IS(X) ; Is X a Code
N CODE,ISACODE S CODE=$G(X),ISACODE=0
; If the user searched for a VA code then $$IS=1
Q:$O(^LEX(757.02,"ADX",(CODE_" ")))[CODE 1
Q:$O(^LEX(757.02,"APR",(CODE_" ")))[CODE 1
Q:$O(^LEX(757.02,"AVA",(CODE_" ")))[CODE 1
; If the user input is a valid code then $$IS=1
Q:$D(^ICPT("BA",(CODE_" "))) 1
Q:$$CODEABA^ICDEX(CODE,80,1)>0 1
Q:$$CODEABA^ICDEX(CODE,80,30)>0 1
Q:$$CODEABA^ICDEX(CODE,80.1,2)>0 1
Q:$$CODEABA^ICDEX(CODE,80.1,31)>0 1
; If the user input is a valid pattern match then $$IS=1
Q:(CODE?5N)!(CODE?1A4N)!(CODE?4N1"T")!(CODE?4N1"F") 1
Q:(CODE?3N1"."2N)!(CODE?3N1"."1N)!(CODE?3N1".") 1
Q:(CODE?1"E"3N1"."2N)!(CODE?1"E"3N1"."1N)!(CODE?1"E"3N1".") 1
Q:(CODE?1"V"2N1"."2N)!(CODE?1"V"2N1"."1N)!(CODE?1"V"2N1".") 1
Q:(CODE?2N1"."2N)!(CODE?2N1"."1N)!(CODE?2N1".") 1
S X=+ISACODE Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" " F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXABC 11131 printed Apr 09, 2024@21:12:30 Page 2
LEXABC ;ISL/KER - Look-up by Code ;04/19/2020
+1 ;;2.0;LEXICON UTILITY;**4,25,26,29,38,73,51,80,103,127**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^ICPT("BA") ICR 5408
+5 ; ^LEX(757 SACC 1.3
+6 ; ^LEX(757.01 SACC 1.3
+7 ; ^LEX(757.02 SACC 1.3
+8 ; ^LEX(757.03 SACC 1.3
+9 ; ^LEX(757.21 SACC 1.3
+10 ; ^LEXT(757.2 SACC 1.3
+11 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+12 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+13 ; ^TMP("LEXL") SACC 2.3.2.5.1
+14 ; ^TMP("LEXLE") SACC 2.3.2.5.1
+15 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+16 ;
+17 ; External References
+18 ; $$CODEABA^ICDEX ICR 5747
+19 ; $$DT^XLFDT ICR 10103
+20 ; $$UP^XLFSTR ICR 10104
+21 ;
+22 ; Local Variables NEWed or KILLed Elsewhere
+23 ; DIC Global Root
+24 ; LEXAFMT Display Format
+25 ; LEXFIL Filter
+26 ; LEXISCD Input is a Code
+27 ;
EN(LEXSO,LEXVDT) ; Entry from LEXA
+1 ;
+2 ; Input
+3 ; LEXSO Code Preferred terms only
+4 ; Code+ All terms
+5 ; LEXVDT Version Date to screen against (default = today)
+6 ;
+7 ; Output
+8 ; $$EN 1 Code found
+9 ; 0 Code not found
+10 ;
+11 SET LEXSO=$$UP^XLFSTR($GET(LEXSO))
if '$LENGTH(LEXSO)
QUIT 0
if $LENGTH(LEXSO)>40
QUIT 0
+12 if $DATA(LEXISCD)
SET LEXISCD=$$IS(LEXSO)
NEW LEXLL,LEXSOA
+13 if $GET(^TMP("LEXSCH",$JOB,"LEN",0))>0
SET LEXLL=$GET(^TMP("LEXSCH",$JOB,"LEN",0))
if $GET(LEXLL)'>0
SET LEXLL=5
+14 IF $DATA(^TMP("LEXSCH",$JOB,"FMT",0))
if '$DATA(LEXAFMT)!($GET(LEXAFMT)'?1N)
SET LEXAFMT=$GET(^TMP("LEXSCH",$JOB,"FMT",0))
+15 DO VDT^LEXU
DO BLD
KILL ^TMP("LEXL",$JOB),^TMP("LEXLE",$JOB)
+16 if $LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0)))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+17 if $DATA(^TMP("LEXHIT",$JOB))
QUIT 1
+18 QUIT 0
BLD ; Build List
+1 NEW LEXSO2
DO CLR
KILL ^TMP("LEXSCH",$JOB,"LST",0),^TMP("LEXSCH",$JOB,"TOL",0),LEX
SET ^TMP("LEXSCH",$JOB,"NUM",0)=0
SET LEXSO=$GET(LEXSO)
+2 SET LEXSO2=""
if $EXTRACT(LEXSO,$LENGTH(LEXSO))="+"
SET LEXSO2=$EXTRACT(LEXSO,$LENGTH(LEXSO))
SET LEXSO=$$TM(LEXSO,"+")
+3 IF (LEXSO2="+"&($LENGTH(LEXSO)'>2))!(LEXSO2=""&($LENGTH(LEXSO)'>1))
DO CLR
QUIT
+4 IF '(+($$IN(LEXSO)))
DO CLR
QUIT
+5 DO FND
if $DATA(^TMP("LEXFND",$JOB))
DO BEG^LEXAL
if $DATA(^TMP("LEXFND",$JOB))
QUIT
if '$DATA(^TMP("LEXFND",$JOB))
DO CLR
+6 QUIT
FND ; Find expressions
+1 KILL ^TMP("LEXL",$JOB),^TMP("LEXLE",$JOB)
+2 NEW LEXSIEN,LEXMIEN,LEXEIEN,LEXDESF,LEXDSPL,LEXDSPLA,LEXFORM,LEXFMTY,LEXS,LEXSAB,LEXSRC,LEXSDATA
+3 NEW LEXP,LEXTP,LEXTYPE,LEXFILR,LEXFORM,LEXC,LEXCSTAT,LEXDSAB,LEXSSAB,LEXLKT
SET LEXLKT="ABC"
+4 SET LEXSSAB=$GET(^TMP("LEXSCH",$JOB,"DIS",0))
SET U="^"
SET LEXS=$$SCH(LEXSO)_" "
+5 if '$LENGTH($GET(LEXFIL))&($LENGTH($GET(DIC("S"))))
SET LEXFIL=DIC("S")
+6 if '$LENGTH($GET(LEXFIL))&($LENGTH($GET(^TMP("LEXSCH",$JOB,"LEXFIL",0))))
SET LEXFIL=$GET(^TMP("LEXSCH",$JOB,"LEXFIL",0))
+7 FOR
SET LEXS=$ORDER(^LEX(757.02,"AVA",LEXS))
if $EXTRACT(LEXS,1,$LENGTH(LEXSO))'=LEXSO
QUIT
Begin DoDot:1
+8 SET LEXEIEN=0
FOR
SET LEXEIEN=$ORDER(^LEX(757.02,"AVA",LEXS,LEXEIEN))
if +LEXEIEN=0
QUIT
Begin DoDot:2
+9 IF $LENGTH($GET(LEXFIL))
Begin DoDot:3
+10 IF LEXFIL'["$$SO^LEXU(Y"
IF LEXFIL'["ONE^LEXU"
Begin DoDot:4
+11 SET LEXFILR=$$EN^LEXAFIL($GET(LEXFIL),+($GET(^LEX(757,+($GET(^LEX(757.01,LEXEIEN,1))),0))))
End DoDot:4
QUIT
+12 SET LEXFILR=$$EN^LEXAFIL($GET(LEXFIL),+LEXEIEN)
End DoDot:3
if +($GET(LEXFILR))=0
QUIT
+13 SET LEXSAB=""
FOR
SET LEXSAB=$ORDER(^LEX(757.02,"AVA",LEXS,LEXEIEN,LEXSAB))
if LEXSAB=""
QUIT
Begin DoDot:3
+14 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"AVA",LEXS,LEXEIEN,LEXSAB,LEXSIEN))
if +LEXSIEN=0
QUIT
Begin DoDot:4
+15 NEW LEXEXI,LEXSTAC,STATI,STATT
SET LEXSDATA=$GET(^LEX(757.02,LEXSIEN,0))
+16 SET LEXC=$PIECE(LEXSDATA,"^",2)
SET LEXSRC=$PIECE(LEXSDATA,"^",3)
SET LEXEXI=$PIECE(LEXSDATA,"^",1)
+17 if $$INSUB(+LEXSDATA)=0
QUIT
+18 SET LEXSTAC=+$$STATCHK^LEXSRC2(LEXC,$GET(LEXVDT),,LEXSRC)
+19 if '$DATA(LEXIGN)&(+LEXSTAC'=1)
QUIT
+20 SET LEXTYPE=+$PIECE(LEXSDATA,"^",3)
+21 SET LEXDSAB=$EXTRACT($GET(^LEX(757.03,+LEXTYPE,0)),1,3)
+22 SET LEXMIEN=+$PIECE(LEXSDATA,"^",4)
SET (LEXP,LEXTP)=+$PIECE(LEXSDATA,"^",5)
+23 SET STATI=$$STATIEN(LEXSIEN)
+24 SET STATT=$PIECE(STATI,"^",2)
SET STATI=+($PIECE(STATI,"^",1))
+25 if '$DATA(LEXIGN)&(+STATI=0)
QUIT
+26 SET LEXDESF=$$DC(LEXEIEN,LEXTP)
+27 SET LEXDSPL=$$DP(LEXS,LEXTYPE,LEXSSAB)
+28 SET LEXDSPLA=$$DSO(+LEXEIEN,$GET(LEXVDT),$GET(LEXSSAB),$GET(LEXDSAB))
+29 SET LEXDSPL=$$TM($$MDS(LEXDSPL,LEXDSPLA),"/")
+30 if $DATA(LEXIGN)&("^Pending^Inactive^"[("^"_STATT_"^"))
SET LEXDSPL=LEXDSPL_"/"_STATT
+31 SET LEXFORM=$$F(LEXEIEN)
SET LEXFMTY=$PIECE(LEXFORM,"^",1)
SET LEXFORM=$PIECE(LEXFORM,"^",2)
+32 ; NEW
+33 IF "^1^2^3^4^17^30^31^"'[("^"_LEXTYPE_"^")
DO NP
QUIT
+34 ; OLD
+35 ;I LEXTYPE>3,LEXTYPE'=17 D NP Q
+36 DO PF
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+37 if $DATA(^TMP("LEXL",$JOB))
DO REO^LEXABC2
DO ADD^LEXABC2
+38 QUIT
+39 ; ^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)
+40 ; ^TMP("LEXL",$J,(code_" "),+source,LEXTP,LEXSIEN)
PF ; Preferred
+1 if LEXP=0
SET LEXTP=2
if LEXTP=2&($GET(LEXSO2)'["+")
QUIT
+2 SET ^TMP("LEXL",$JOB,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
+3 SET ^TMP("LEXLE",$JOB,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
+4 QUIT
NP ; Not Preferred
+1 NEW LEXICD
if LEXP=0
SET LEXTP=1
+2 IF $DATA(^TMP("LEXLE",$JOB,LEXEIEN))
Begin DoDot:1
+3 NEW LEX1,LEX2,LEX3,LEX4,LEXD,LEXDP
+4 SET LEXD=^TMP("LEXLE",$JOB,LEXEIEN)
SET LEX1=$PIECE(LEXD,"^",1)
if '$LENGTH(LEX1)
QUIT
SET LEX2=$PIECE(LEXD,"^",2)
if '$LENGTH(LEX2)
QUIT
+5 SET LEX3=$PIECE(LEXD,"^",3)
if '$LENGTH(LEX3)
QUIT
SET LEX4=$PIECE(LEXD,"^",4)
if '$LENGTH(LEX4)
QUIT
+6 SET LEXD=$GET(^TMP("LEXL",$JOB,LEX1,LEX2,LEX3,LEX4))
if '$LENGTH(LEXD)
QUIT
+7 SET LEXDP=$PIECE(LEXD,"^",4)
if $LENGTH(LEXDP)
SET LEXDP=LEXDP_"/"_LEXDSPL
if '$LENGTH(LEXDP)
SET LEXDP=LEXDSPL
+8 SET $PIECE(LEXD,"^",4)=LEXDP
SET ^TMP("LEXL",$JOB,LEX1,LEX2,LEX3,LEX4)=LEXD
End DoDot:1
QUIT
+9 ; NEW
+10 SET LEXICD=$$D10ONE^LEXU(LEXEIEN)
+11 ; OLD
+12 ;S LEXICD=$$ICDONE^LEXU(LEXEIEN)
+13 IF '$LENGTH(LEXICD)
Begin DoDot:1
+14 SET ^TMP("LEXL",$JOB,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
+15 SET ^TMP("LEXLE",$JOB,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
End DoDot:1
QUIT
+16 IF $LENGTH(LEXICD)
Begin DoDot:1
+17 ; NEW
+18 IF $LENGTH(LEXDSPL)
IF LEXSO2["+"
IF LEXDSPL'[("ICD-10-CM "_LEXICD)
Begin DoDot:2
+19 SET LEXDSPL=LEXDSPL_"/ICD-10-CM "_LEXICD
SET LEXDSPL=$$TM(LEXDSPL,"/")
End DoDot:2
+20 ; OLD
+21 ;S:$L(LEXDSPL)&(LEXSO2["+") LEXDSPL=LEXDSPL_"/ICD-9-CM "_LEXICD
+22 IF LEXSO2["+"
IF $DATA(^TMP("LEXL",$JOB,LEXS,1))
Begin DoDot:2
+23 SET ^TMP("LEXL",$JOB,LEXS,1,4,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
+24 SET ^TMP("LEXLE",$JOB,LEXEIEN)=LEXS_"^1^3^"_LEXSIEN
End DoDot:2
QUIT
+25 SET LEXTP=1
SET ^TMP("LEXL",$JOB,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
+26 SET ^TMP("LEXLE",$JOB,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
End DoDot:1
QUIT
+27 QUIT
+28 ;
+29 ; Miscellaneous
F(X) ; Form
+1 NEW LEX
SET LEX=$GET(X)
SET LEX=+($GET(LEX))
SET LEX=+($PIECE($GET(^LEX(757.01,LEX,1)),"^",2))
+2 SET X=$SELECT(LEX=1:"A^Concept: ",LEX=2:"B^Synonym: ",LEX=3:"C^Variant: ",LEX=4:"D^Related: ",LEX=5:"E^Modified: ",1:"F^Other: ")
+3 QUIT X
DE(X) ; Deactivated 757.01
+1 NEW LEX
SET LEX=+($GET(X))
if '$DATA(^LEX(757.01,LEX,0))
QUIT 1
+2 if '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEX,1)),"^",5))=1)
QUIT 1
+3 SET LEX=+($GET(^LEX(757.01,LEX,1)))
if '$DATA(^LEX(757,LEX,0))
QUIT 1
+4 SET LEX=+($GET(^LEX(757,LEX,0)))
if '$DATA(^LEX(757.01,LEX,1))
QUIT 1
+5 if '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEX,1)),"^",5))=1)
QUIT 1
+6 QUIT 0
DC(X,Y) ; Description Flag
+1 NEW LEX,LEXT,LEXD,LEXM
SET LEX=$GET(X)
SET LEXT=$GET(Y)
SET LEXD=""
SET LEX=+($GET(LEX))
+2 SET LEXM=$PIECE($GET(^LEX(757.01,+($GET(LEX)),1)),"^",1)
SET LEXM=+($GET(^LEX(757,+($GET(LEXM)),0)))
+3 if $DATA(^LEX(757.01,LEXM,3))&(+($GET(LEXT))'=2)
SET LEXD="*"
SET X=$GET(LEXD)
+4 QUIT X
DP(X,Y,A) ; Display
+1 NEW LEXA,LEXS,LEXT,LEXD
SET LEXS=$GET(X)
SET LEXT=+($GET(Y))
SET LEXD=$GET(A)
+2 SET LEXA=$EXTRACT($PIECE($GET(^LEX(757.03,LEXT,0)),"^",1),1,3)
+3 if '$LENGTH(LEXD)
QUIT ""
if '$LENGTH(LEXA)
QUIT ""
if LEXD'[LEXA
QUIT ""
+4 SET LEXT=$PIECE($GET(^LEX(757.03,LEXT,0)),"^",2)
+5 SET LEXS=$GET(LEXS)
if $EXTRACT(LEXS,$LENGTH(LEXS))=" "
SET LEXS=$EXTRACT(LEXS,1,($LENGTH(LEXS)-1))
+6 if $LENGTH(LEXS)&($LENGTH(LEXT))
SET LEXS=LEXT_" "_LEXS
if $LENGTH(LEXS)&($LENGTH(LEXT))
QUIT LEXS
+7 QUIT ""
DSO(X,Y,A,B) ; Display Sources String
+1 NEW LEXT,LEXS,LEXD,LEXIEN,LEXSAB,LEXVDT
SET LEXVDT=$GET(Y)
SET LEXS=$GET(A)
SET LEXD=$GET(B)
SET LEXIEN=+($GET(X))
if +LEXIEN'>0
QUIT ""
+2 SET LEXT=$GET(LEXS)
SET LEXSAB=$GET(LEXD)
SET LEXT=$$TM(LEXT,"/")
SET X=$$SO^LEXASO(LEXIEN,LEXT,1,$GET(LEXVDT))
if $LENGTH(X)
QUIT X
+3 if $LENGTH(LEXSAB)=3&(LEXT'[LEXSAB)
SET LEXT=LEXT_"/"_LEXSAB
SET LEXT=$$TM(LEXT,"/")
+4 QUIT X
MDS(X,Y) ; Merge Display Strings
+1 NEW LEXD,LEXA
SET LEXD=$GET(X)
SET LEXA=$GET(Y)
FOR
if LEXA'[") ("
QUIT
SET LEXA=$PIECE(LEXA,") (",1)_"/"_$PIECE(LEXA,") (",2,4000)
+2 SET LEXA=$TRANSLATE(LEXA,"(","")
SET LEXA=$TRANSLATE(LEXA,")","")
+3 if '$LENGTH($GET(LEXD))
QUIT LEXA
if LEXA'[$GET(LEXD)
SET LEXA=LEXD_"/"_LEXA
SET X=$GET(LEXA)
+4 QUIT X
CLR ; Clear
+1 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXL",$JOB),LEX
SET LEX=0
QUIT
CLR2 ; Clear 2
+1 NEW LEXIGN
+2 QUIT
IN(X) ; Flag in/not in file 757.02
+1 if $ORDER(^LEX(757.02,"AVA",(($$SCH($EXTRACT($GET(X),1,61)))_" ")))[$GET(X)
QUIT 1
+2 QUIT 0
SCH(X) ; Search
+1 SET X=$EXTRACT($GET(X),1,($LENGTH($GET(X))-1))_$CHAR($ASCII($EXTRACT($GET(X),$LENGTH($GET(X))))-1)_"~"
QUIT X
INSUB(X) ; Check if selected code in vocab
+1 NEW LEXFLN,LEXVOC,SUBIEN,LEXEIEN
SET LEXEIEN=$GET(X)
+2 SET LEXFLN=$GET(^TMP("LEXSCH",$JOB,"FLN",0))
if LEXFLN=""!(LEXFLN="757.01")
QUIT 1
+3 SET LEXVOC=$GET(^TMP("LEXSCH",$JOB,"VOC",0))
if LEXVOC=""!(LEXVOC="WRD")
QUIT 1
+4 if $DATA(^LEXT(757.2,"AA",LEXVOC))'=10
QUIT 1
+5 SET SUBIEN=$ORDER(^LEXT(757.2,"AA",LEXVOC,""))
if +SUBIEN'>0
QUIT 1
+6 if $$INPSUB(LEXEIEN,SUBIEN)
QUIT 1
+7 QUIT 0
INPSUB(X,Y) ; Check if concept X is member of subset Y
+1 NEW LEXPRF,LEXSUB
SET LEXPRF=$GET(X)
SET LEXSUB=$GET(Y)
SET LEXPRF=$GET(X)
if '$LENGTH(LEXPRF)
QUIT 0
+2 NEW LEXIN,LEXSIEN
SET LEXSIEN=""
SET LEXIN=0
+3 FOR
SET LEXSIEN=$ORDER(^LEX(757.21,"B",LEXPRF,LEXSIEN))
if LEXSIEN=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^LEX(757.21,LEXSIEN,0),U,2)=$GET(LEXSUB)
SET LEXIN=1
End DoDot:1
if LEXIN=1
QUIT
+5 SET X=LEXIN
+6 QUIT X
STATIEN(X) ; Status of code-expression pairing based on code IEN
+1 NEW STATDAT,STATIEN,LEXH,LEXI,LEXT,LEXTD,LEXCIEN
SET LEXT=""
SET LEXCIEN=+($GET(X))
+2 if '$DATA(^LEX(757.02,LEXCIEN))
QUIT 0
IF $DATA(LEXIGN)
Begin DoDot:1
+3 NEW LEXTD
SET LEXTD=$GET(DT)
if LEXTD'?7N
SET LEXTD=$$DT^XLFDT
+4 SET LEXH=$ORDER(^LEX(757.02,LEXCIEN,4,"B",(LEXTD+.00001)),-1)
+5 IF LEXH'?7N
IF $ORDER(^LEX(757.02,LEXCIEN,4,"B",(LEXTD-.00001)))>0
SET LEXT="Pending"
QUIT
+6 SET LEXI=$ORDER(^LEX(757.02,LEXCIEN,4,"B",+LEXH," "),-1)
+7 SET LEXT=$PIECE($GET(^LEX(757.02,LEXCIEN,4,+LEXI,0)),"^",2)
+8 SET LEXT=$SELECT(LEXT="1":"",LEXT="0":"Inactive",1:"")
End DoDot:1
+9 IF $DATA(LEXIGN)
if LEXT="Pending"
QUIT "0^Pending"
+10 SET STATDAT=$ORDER(^LEX(757.02,LEXCIEN,4,"B",$SELECT($GET(LEXVDT)'="":(LEXVDT+.001),1:"")),-1)
+11 SET STATIEN=$ORDER(^LEX(757.02,LEXCIEN,4,"B",+STATDAT,""),-1)
+12 SET STATDAT=+$PIECE($GET(^LEX(757.02,LEXCIEN,4,+STATIEN,0)),"^",2)
+13 if $DATA(LEXIGN)&($LENGTH($GET(LEXT)))
SET STATDAT=STATDAT_"^"_LEXT
SET X=$GET(STATDAT)
+14 QUIT X
NONPLUS(X) ; Remove trialing plus (+)
+1 QUIT $$TM($GET(X),"+")
IS(X) ; Is X a Code
+1 NEW CODE,ISACODE
SET CODE=$GET(X)
SET ISACODE=0
+2 ; If the user searched for a VA code then $$IS=1
+3 if $ORDER(^LEX(757.02,"ADX",(CODE_" ")))[CODE
QUIT 1
+4 if $ORDER(^LEX(757.02,"APR",(CODE_" ")))[CODE
QUIT 1
+5 if $ORDER(^LEX(757.02,"AVA",(CODE_" ")))[CODE
QUIT 1
+6 ; If the user input is a valid code then $$IS=1
+7 if $DATA(^ICPT("BA",(CODE_" ")))
QUIT 1
+8 if $$CODEABA^ICDEX(CODE,80,1)>0
QUIT 1
+9 if $$CODEABA^ICDEX(CODE,80,30)>0
QUIT 1
+10 if $$CODEABA^ICDEX(CODE,80.1,2)>0
QUIT 1
+11 if $$CODEABA^ICDEX(CODE,80.1,31)>0
QUIT 1
+12 ; If the user input is a valid pattern match then $$IS=1
+13 if (CODE?5N)!(CODE?1A4N)!(CODE?4N1"T")!(CODE?4N1"F")
QUIT 1
+14 if (CODE?3N1"."2N)!(CODE?3N1"."1N)!(CODE?3N1".")
QUIT 1
+15 if (CODE?1"E"3N1"."2N)!(CODE?1"E"3N1"."1N)!(CODE?1"E"3N1".")
QUIT 1
+16 if (CODE?1"V"2N1"."2N)!(CODE?1"V"2N1"."1N)!(CODE?1"V"2N1".")
QUIT 1
+17 if (CODE?2N1"."2N)!(CODE?2N1"."1N)!(CODE?2N1".")
QUIT 1
+18 SET X=+ISACODE
QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
