LEXABC.m

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