LEXABC ;ISL/KER - Look-up by Code ;04/21/2014
;;2.0;LEXICON UTILITY;**4,25,26,29,38,73,51,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^ICPT("BA") ICR 5408
; ^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
;
; Local Variables NEWed or KILLed LEXA and LEXA1
; DIC,LEXFIL,LEXISCD
;
; INPUT
; LEXSO Code Preferred terms only
; Code+ All terms
; LEXVDT Version Date to screen against (default = today)
;
EN(LEXSO,LEXVDT) ; Entry from LEXA
S LEXSO=$$UP^XLFSTR($G(LEXSO)) Q:'$L(LEXSO) 0 Q:$L(LEXSO)>40 0 S:$D(LEXISCD) LEXISCD=$$IS(LEXSO)
D VDT^LEXU,BLD 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)
I $E(LEXSO,$L(LEXSO))'="+"&($L(LEXSO)'>1)!($E(LEXSO,$L(LEXSO))="+"&($L(LEXSO)'>3)) D CLR Q
S LEXSO2="" S:$E(LEXSO,$L(LEXSO))="+" LEXSO2=$E(LEXSO,$L(LEXSO)),LEXSO=$E(LEXSO,1,($L(LEXSO)-1)) I '(+($$IN(LEXSO))) D CLR Q
Q:$E(LEXSO,1,3)="U00" 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)
. . . . I LEXTYPE>3,LEXTYPE'=17 D NP Q
. . . . D PF
D:$D(^TMP("LEXL",$J)) REO^LEXABC2,ADD^LEXABC2
Q
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
S LEXICD=$$ICDONE^LEXU(LEXEIEN)
I '$L(LEXICD) S ^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM,^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN Q
I $L(LEXICD) D Q
. S:$L(LEXDSPL)&(LEXSO2["+") LEXDSPL=LEXDSPL_"/ICD-9-CM "_LEXICD
. I LEXSO2["+",$D(^TMP("LEXL",$J,LEXS,1)) S ^TMP("LEXL",$J,LEXS,1,4,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM,^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^1^3^"_LEXSIEN Q
. S LEXTP=1,^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM,^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
Q
F(LEX) ; Form
S LEX=+($G(LEX)),LEX=+($P($G(^LEX(757.01,LEX,1)),"^",2))
S LEX=$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 LEX
DE(LEX) ; Deactivated 757.01
S LEX=+($G(LEX)) 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(LEX,LEXT) ; Description
N LEXD,LEXM S LEXD="",LEX=+($G(LEX)),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 LEX=$G(LEXD) Q LEX
DP(LEXS,LEXT,LEXD) ; Display
N LEXA S LEXT=+($G(LEXT)),LEXD=$G(LEXD)
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,LEXVDT,LEXS,LEXD) ; Display Sources String
N LEXT,LEXIEN,LEXSAB S LEXIEN=+($G(X)) Q:+LEXIEN'>0 ""
S LEXT=$G(LEXS),LEXSAB=$G(LEXD)
F Q:$E(LEXT,1)'="/" S LEXT=$E(LEXT,2,$L(LEXT))
S X=$$SO^LEXASO(LEXIEN,LEXT,1,$G(LEXVDT)) Q:$L(X) X
S:$L(LEXSAB)=3&(LEXT'[LEXSAB) LEXT=LEXT_"/"_LEXSAB
F Q:$E(LEXT,1)'="/" S LEXT=$E(LEXT,2,$L(LEXT))
Q X
MDS(LEXD,LEXA) ; Merge Display Strings
S LEXA=$G(LEXA) F Q:LEXA'[") (" S LEXA=$P(LEXA,") (",1)_"/"_$P(LEXA,") (",2,299)
S LEXA=$TR(LEXA,"(",""),LEXA=$TR(LEXA,")","")
Q:'$L(LEXD) LEXA
S:LEXA'[LEXD LEXA=LEXD_"/"_LEXA
Q LEXA
CLR ; Clear
K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXL",$J),LEX S LEX=0 Q
CLR2 ; Clear 2
N LEXIGN
Q
IN(LEX) ; Flag in/not in file 757.02
Q:$O(^LEX(757.02,"AVA",(($$SCH($E(LEX,1,61)))_" ")))[LEX 1 Q 0
SCH(LEX) ; Search
S LEX=$E(LEX,1,($L(LEX)-1))_$C($A($E(LEX,$L(LEX)))-1)_"~" Q LEX
INSUB(EXIEN) ; Check if selected code in vocab
N LEXFLN,LEXVOC,SUBIEN
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(EXIEN,SUBIEN) 1
Q 0
INPSUB(PRF,SUB) ; Check if concept PRF is member of subset SUB
S PRF=$G(PRF) Q:'$L(PRF) 0 N IN,SIEN S SIEN="",IN=0
F S SIEN=$O(^LEX(757.21,"B",PRF,SIEN)) Q:SIEN="" D Q:IN=1
. I $P(^LEX(757.21,SIEN,0),U,2)=$G(SUB) S IN=1
Q IN
STATIEN(LEXCIEN) ; Determine status of code-expression pairing based
; on code IEN
N STATDAT,STATIEN,LEXH,LEXI,LEXT,LEXTD S LEXT="",LEXCIEN=+($G(LEXCIEN))
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
Q STATDAT
NONPLUS(STRING) ; Remove trialing plus from a string
S STRING=$G(STRING)
I $E($RE(STRING))="+" Q $RE($E($RE(STRING),2,$L(STRING)))
Q STRING
IS(X) ; Is a Code
N CODE,ISACODE S CODE=$G(X),ISACODE=0
; If the user intended to search for a key VA code then ISACODE =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 (active or inactive) ISACODE=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 intended to search for a code (pattern match) with a typo, then ISACODE =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
LEXABC ;ISL/KER - Look-up by Code ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**4,25,26,29,38,73,51,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^ICPT("BA") ICR 5408
+5 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+6 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+7 ; ^TMP("LEXL") SACC 2.3.2.5.1
+8 ; ^TMP("LEXLE") SACC 2.3.2.5.1
+9 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+10 ;
+11 ; External References
+12 ; $$CODEABA^ICDEX ICR 5747
+13 ;
+14 ; Local Variables NEWed or KILLed LEXA and LEXA1
+15 ; DIC,LEXFIL,LEXISCD
+16 ;
+17 ; INPUT
+18 ; LEXSO Code Preferred terms only
+19 ; Code+ All terms
+20 ; LEXVDT Version Date to screen against (default = today)
+21 ;
EN(LEXSO,LEXVDT) ; Entry from LEXA
+1 SET LEXSO=$$UP^XLFSTR($GET(LEXSO))
IF '$LENGTH(LEXSO)
QUIT 0
IF $LENGTH(LEXSO)>40
QUIT 0
IF $DATA(LEXISCD)
SET LEXISCD=$$IS(LEXSO)
+2 DO VDT^LEXU
DO BLD
IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0)))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
IF $DATA(^TMP("LEXHIT",$JOB))
QUIT 1
+3 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 IF $EXTRACT(LEXSO,$LENGTH(LEXSO))'="+"&($LENGTH(LEXSO)'>1)!($EXTRACT(LEXSO,$LENGTH(LEXSO))="+"&($LENGTH(LEXSO)'>3))
DO CLR
QUIT
+3 SET LEXSO2=""
IF $EXTRACT(LEXSO,$LENGTH(LEXSO))="+"
SET LEXSO2=$EXTRACT(LEXSO,$LENGTH(LEXSO))
SET LEXSO=$EXTRACT(LEXSO,1,($LENGTH(LEXSO)-1))
IF '(+($$IN(LEXSO)))
DO CLR
QUIT
+4 IF $EXTRACT(LEXSO,1,3)="U00"
QUIT
DO FND
IF $DATA(^TMP("LEXFND",$JOB))
DO BEG^LEXAL
IF $DATA(^TMP("LEXFND",$JOB))
QUIT
IF '$DATA(^TMP("LEXFND",$JOB))
DO CLR
+5 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 IF LEXTYPE>3
IF LEXTYPE'=17
DO NP
QUIT
+33 DO PF
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 IF $DATA(^TMP("LEXL",$JOB))
DO REO^LEXABC2
DO ADD^LEXABC2
+35 QUIT
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
SET LEX3=$PIECE(LEXD,"^",3)
IF '$LENGTH(LEX3)
QUIT
SET LEX4=$PIECE(LEXD,"^",4)
IF '$LENGTH(LEX4)
QUIT
+5 SET LEXD=$GET(^TMP("LEXL",$JOB,LEX1,LEX2,LEX3,LEX4))
IF '$LENGTH(LEXD)
QUIT
+6 SET LEXDP=$PIECE(LEXD,"^",4)
IF $LENGTH(LEXDP)
SET LEXDP=LEXDP_"/"_LEXDSPL
IF '$LENGTH(LEXDP)
SET LEXDP=LEXDSPL
+7 SET $PIECE(LEXD,"^",4)=LEXDP
SET ^TMP("LEXL",$JOB,LEX1,LEX2,LEX3,LEX4)=LEXD
End DoDot:1
QUIT
+8 SET LEXICD=$$ICDONE^LEXU(LEXEIEN)
+9 IF '$LENGTH(LEXICD)
SET ^TMP("LEXL",$JOB,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
SET ^TMP("LEXLE",$JOB,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
QUIT
+10 IF $LENGTH(LEXICD)
Begin DoDot:1
+11 IF $LENGTH(LEXDSPL)&(LEXSO2["+")
SET LEXDSPL=LEXDSPL_"/ICD-9-CM "_LEXICD
+12 IF LEXSO2["+"
IF $DATA(^TMP("LEXL",$JOB,LEXS,1))
SET ^TMP("LEXL",$JOB,LEXS,1,4,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
SET ^TMP("LEXLE",$JOB,LEXEIEN)=LEXS_"^1^3^"_LEXSIEN
QUIT
+13 SET LEXTP=1
SET ^TMP("LEXL",$JOB,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
SET ^TMP("LEXLE",$JOB,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
End DoDot:1
QUIT
+14 QUIT
F(LEX) ; Form
+1 SET LEX=+($GET(LEX))
SET LEX=+($PIECE($GET(^LEX(757.01,LEX,1)),"^",2))
+2 SET LEX=$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 LEX
DE(LEX) ; Deactivated 757.01
+1 SET LEX=+($GET(LEX))
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)))
+4 IF '$DATA(^LEX(757,LEX,0))
QUIT 1
SET LEX=+($GET(^LEX(757,LEX,0)))
+5 IF '$DATA(^LEX(757.01,LEX,1))
QUIT 1
+6 IF '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEX,1)),"^",5))=1)
QUIT 1
+7 QUIT 0
DC(LEX,LEXT) ; Description
+1 NEW LEXD,LEXM
SET LEXD=""
SET LEX=+($GET(LEX))
SET LEXM=$PIECE($GET(^LEX(757.01,+($GET(LEX)),1)),"^",1)
SET LEXM=+($GET(^LEX(757,+($GET(LEXM)),0)))
IF $DATA(^LEX(757.01,LEXM,3))&(+($GET(LEXT))'=2)
SET LEXD="*"
SET LEX=$GET(LEXD)
QUIT LEX
DP(LEXS,LEXT,LEXD) ; Display
+1 NEW LEXA
SET LEXT=+($GET(LEXT))
SET LEXD=$GET(LEXD)
+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
QUIT ""
DSO(X,LEXVDT,LEXS,LEXD) ; Display Sources String
+1 NEW LEXT,LEXIEN,LEXSAB
SET LEXIEN=+($GET(X))
IF +LEXIEN'>0
QUIT ""
+2 SET LEXT=$GET(LEXS)
SET LEXSAB=$GET(LEXD)
+3 FOR
IF $EXTRACT(LEXT,1)'="/"
QUIT
SET LEXT=$EXTRACT(LEXT,2,$LENGTH(LEXT))
+4 SET X=$$SO^LEXASO(LEXIEN,LEXT,1,$GET(LEXVDT))
IF $LENGTH(X)
QUIT X
+5 IF $LENGTH(LEXSAB)=3&(LEXT'[LEXSAB)
SET LEXT=LEXT_"/"_LEXSAB
+6 FOR
IF $EXTRACT(LEXT,1)'="/"
QUIT
SET LEXT=$EXTRACT(LEXT,2,$LENGTH(LEXT))
+7 QUIT X
MDS(LEXD,LEXA) ; Merge Display Strings
+1 SET LEXA=$GET(LEXA)
FOR
IF LEXA'[") ("
QUIT
SET LEXA=$PIECE(LEXA,") (",1)_"/"_$PIECE(LEXA,") (",2,299)
+2 SET LEXA=$TRANSLATE(LEXA,"(","")
SET LEXA=$TRANSLATE(LEXA,")","")
+3 IF '$LENGTH(LEXD)
QUIT LEXA
+4 IF LEXA'[LEXD
SET LEXA=LEXD_"/"_LEXA
+5 QUIT LEXA
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(LEX) ; Flag in/not in file 757.02
+1 IF $ORDER(^LEX(757.02,"AVA",(($$SCH($EXTRACT(LEX,1,61)))_" ")))[LEX
QUIT 1
QUIT 0
SCH(LEX) ; Search
+1 SET LEX=$EXTRACT(LEX,1,($LENGTH(LEX)-1))_$CHAR($ASCII($EXTRACT(LEX,$LENGTH(LEX)))-1)_"~"
QUIT LEX
INSUB(EXIEN) ; Check if selected code in vocab
+1 NEW LEXFLN,LEXVOC,SUBIEN
+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(EXIEN,SUBIEN)
QUIT 1
+7 QUIT 0
INPSUB(PRF,SUB) ; Check if concept PRF is member of subset SUB
+1 SET PRF=$GET(PRF)
IF '$LENGTH(PRF)
QUIT 0
NEW IN,SIEN
SET SIEN=""
SET IN=0
+2 FOR
SET SIEN=$ORDER(^LEX(757.21,"B",PRF,SIEN))
IF SIEN=""
QUIT
Begin DoDot:1
+3 IF $PIECE(^LEX(757.21,SIEN,0),U,2)=$GET(SUB)
SET IN=1
End DoDot:1
IF IN=1
QUIT
+4 QUIT IN
STATIEN(LEXCIEN) ; Determine status of code-expression pairing based
+1 ; on code IEN
+2 NEW STATDAT,STATIEN,LEXH,LEXI,LEXT,LEXTD
SET LEXT=""
SET LEXCIEN=+($GET(LEXCIEN))
+3 IF '$DATA(^LEX(757.02,LEXCIEN))
QUIT 0
+4 IF $DATA(LEXIGN)
Begin DoDot:1
+5 NEW LEXTD
SET LEXTD=$GET(DT)
IF LEXTD'?7N
SET LEXTD=$$DT^XLFDT
+6 SET LEXH=$ORDER(^LEX(757.02,LEXCIEN,4,"B",(LEXTD+.00001)),-1)
+7 IF LEXH'?7N
IF $ORDER(^LEX(757.02,LEXCIEN,4,"B",(LEXTD-.00001)))>0
SET LEXT="Pending"
QUIT
+8 SET LEXI=$ORDER(^LEX(757.02,LEXCIEN,4,"B",+LEXH," "),-1)
+9 SET LEXT=$PIECE($GET(^LEX(757.02,LEXCIEN,4,+LEXI,0)),"^",2)
+10 SET LEXT=$SELECT(LEXT="1":"",LEXT="0":"Inactive",1:"")
End DoDot:1
+11 IF $DATA(LEXIGN)
IF LEXT="Pending"
QUIT "0^Pending"
+12 SET STATDAT=$ORDER(^LEX(757.02,LEXCIEN,4,"B",$SELECT($GET(LEXVDT)'="":(LEXVDT+.001),1:"")),-1)
+13 SET STATIEN=$ORDER(^LEX(757.02,LEXCIEN,4,"B",+STATDAT,""),-1)
+14 SET STATDAT=+$PIECE($GET(^LEX(757.02,LEXCIEN,4,+STATIEN,0)),"^",2)
+15 IF $DATA(LEXIGN)&($LENGTH($GET(LEXT)))
SET STATDAT=STATDAT_"^"_LEXT
+16 QUIT STATDAT
NONPLUS(STRING) ; Remove trialing plus from a string
+1 SET STRING=$GET(STRING)
+2 IF $EXTRACT($REVERSE(STRING))="+"
QUIT $REVERSE($EXTRACT($REVERSE(STRING),2,$LENGTH(STRING)))
+3 QUIT STRING
IS(X) ; Is a Code
+1 NEW CODE,ISACODE
SET CODE=$GET(X)
SET ISACODE=0
+2 ; If the user intended to search for a key VA code then ISACODE =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 (active or inactive) ISACODE=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 intended to search for a code (pattern match) with a typo, then ISACODE =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
