LEX10PLS.m

LEX10PLS ;ISL/KER - ICD-10 Procedure Lookup Selection ;04/21/2014

 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10

 ;               

 ; Global Variables

 ;    ^LEX(757.033        N/A

 ;    ^UTILITY($J         ICR  10011

 ;               

 ; External References

 ;    ENDR^%ZISS          ICR  10088

 ;    KILL^%ZISS          ICR  10088

 ;    ^DIR                ICR  10026

 ;    ^DIWP               ICR  10011

 ;               

 ; Local Variables NEWed or KILLed Elsewhere

 ;     LEXPCDAT

 ;               

SEL(X) ; Select from List

 ;

 ; Input   

 ; 

 ;    X        Origninal Value

 ;    

 ;    Needs LEXPCDAT array

 ;                  

 ;             LEXPCDAT=1

 ;             LEXPCDAT("NEXLEV","6","DESC")="Cerebral Ventricle"

 ;             LEXPCDAT("NEXLEV","U","DESC")="Spinal Canal"

 ;             LEXPCDAT("LEXLEV",<character>,"DESC")=Description of Character

 ;             

 ; Output

 ;               

 ;    $$SEL  Next Character or -1

 ;               

 ; Creates Selection Array LEX

 ; 

 ;             LEX(0)=3

 ;             LEX(1)="6^   1.  ("_$c(27)_"[1m6"_$c(27)_"[m)  Cerebral Ventricle"

 ;             LEX(2)="U^   2.  ("_$c(27)_"[1mU"_$c(27)_"[m)  Spinal Canal"

 ;             LEX(2)=<character>^<menu text>

 ;             LEX("B",1)=1

 ;             LEX("B",2)=2

 ;             LEX("B",<menu item>)=<menu item>

 ;             LEX("B",6)=1

 ;             LEX("B","U")=2

 ;             LEX("B",<character>)=<menu item>

 ;

 N DIR,DIRB,LEX,LEXCUR,LEXE,LEXFI,LEXHLP,LEXI,LEXIT,LEXL,LEXLAST

 N LEXMAX,LEXOUT,LEXS,LEXSS,LEXTOT,LEXTXT,LEXX K DTOUT,DUOUT,DIROUT,DIRUT

 N LEXIT,LEXL,LEXTOT,LEX S LEXTXT=$G(X),LEXIT=0,LEXTOT=$$FND Q:+LEXTOT'>0 "^"

 K X S:+LEXTOT=1 X=$$ONE S:+LEXTOT>1 X=$$MUL(LEXTXT) N LEXTEST

 Q X

ONE(X) ; One Entry Found

 Q:+($G(LEXIT))>0 "^^"  S X=$$GETO

 Q X

MUL(X) ; Multiple Entries Found

 Q:+($G(LEXIT))>0 "^^"  N LEX,LEXE,LEXI,LEXL,LEXMAX,LEXP,LEXSS,LEXX

 S LEXTXT=$G(X) D BUILD

 S LEXMAX=$G(LEXTOT),(LEXSS,LEXIT)=0,U="^" G:LEXMAX'>1 MULQ

 D:$L($G(LEXTXT)) CUR^LEX10PL(LEXTXT) W !

 W:$D(LEXTEST) !," Next character:  ",!

 S LEXI=0 F  S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0  D

 . W !,?1,$G(LEX(+LEXI))

 W ! S LEXSS=$$MULS S:LEXSS["^" LEXIT=1

 S X=LEXSS

MULQ ;   Multiple Entries - Quit

 K LEX

 Q X

MULS(X) ;   Multiple Entries - Select

 K DTOUT,DUOUT,DIROUT,DIRUT

 N DIR,DIRB,LEXFI,LEXHLP,LEXLAST,LEXS S LEXMAX=+($G(LEXMAX)),LEXTXT=$G(LEXTXT)

 Q:+($G(LEXIT))>0 "^^" Q:LEXMAX'>1 ""

 S DIR("A")=" Select Next Character 1-"_LEXMAX_": "

 S LEXHLP=" Answer must be from 1 to "_LEXMAX_" or a character."

 S DIR("PRE")="S X=$$MULSP^LEX10PLS(X)"

 S (DIR("?"),DIR("??"))="^D MULSH^LEX10PLS"

 S DIR(0)="FAO^1:3" D ^DIR I X["^^"!($D(DTOUT))!($D(DIROUT)) S LEXIT=1,X="^^" Q X

 Q:X["^"!($D(DIRUT))!($D(DUOUT)) "^"  Q:'$L(X) ""

 I +Y>0,$L($G(LEX("E",+Y))) S X=$G(LEX("E",+Y)) Q X

 Q X

MULSH ;   Multiple Entries - Selection Help

 I $L($G(LEXHLP)) W !,$G(LEXHLP) Q

 Q

MULSP(X) ;   Multiple Entries - Pre-Process

 N LEXM,LEXP1,LEXP2,LEXO,LEXN,LEXA S (LEXM,X)=$$UP^XLFSTR($G(X)) Q:'$L(X) X

 S LEXP1=$E(LEXM,1),LEXP2=$E(LEXM,2,$L(LEXM)),LEXA="" S:$L(LEXP2) LEXA=$G(LEX("E",LEXP2))

 I $D(LEX("B",LEXM)) S X=LEXM Q X

 I $D(LEX("C",LEXM)) S X=$G(LEX("C",LEXM)) Q X

 S:$L(LEXM)=1 LEXO=$C($A(LEXM)-1)_"~"

 S:$L(LEXM)>1 LEXO=$E(LEXM,1,($L(LEXM)-1))_$C($A($E(LEXM,$L(LEXM)))-1)_"~"

 S LEXN="" S:$L(LEXO) LEXN=$O(LEX("D",LEXO)) S:$E(LEXN,1,$L(LEXM))'=LEXM LEXN=""

 I $L(LEXN) I $L($G(LEX("D",LEXN))) S X=$G(LEX("D",LEXN)) Q X

 I LEXP1="?",$L(LEXP2),$L(LEXA)=1 I $D(LEX("F",LEXA)) D MULSEH S X="??" Q X

 Q:LEXM["?" "??"  Q:'$L(LEXM) ""  Q:LEXM["^^" "^^"  Q:LEXM["^" "^"

 S:'$D(LEX("B",X)) X="??"

 Q X

MULSEH ; Extended Help

 N LEXT,LEXD,LEXE,LEXI,LEXP,LEXII,LEXIC S LEXA=$G(LEXA) Q:$L(LEXA)'=1  Q:'$D(LEX("F",LEXA))

 S LEXT=$G(LEX("F",LEXA,"DESC"))

 S LEXD=$G(LEX("F",LEXA,"META","Definition"))

 S LEXE=$G(LEX("F",LEXA,"META","Explanation"))

 S LEXY=$G(LEX("F",LEXA,"META","Includes/Examples",1))

 S LEXC=0 I $L(LEXT) S LEXC=LEXC+1 W:LEXC=1 ! W !," ",LEXT

 K LEXT S LEXT(1)=LEXD I $L(LEXT(1)) D

 . N LEXI D PR(.LEXT,(79-15)) Q:'$L($G(LEXT(1)))

 . W !!," Definition:",?15,$G(LEXT(1)) S LEXC=LEXC+1

 . S I=1 F  S I=$O(LEXT(I)) Q:+I'>0  W !,?15,$G(LEXT(I))

 K LEXT S LEXT(1)=LEXE I $L(LEXT(1)) D

 . N LEXI D PR(.LEXT,(79-15)) Q:'$L($G(LEXT(1)))

 . W !!," Explanation:",?15,$G(LEXT(1)) S LEXC=LEXC+1

 . S I=1 F  S I=$O(LEXT(I)) Q:+I'>0  W !,?15,$G(LEXT(I))

 S (LEXII,LEXIC)=0

 F  S LEXII=$O(LEX("F",LEXA,"META","Includes/Examples",LEXII)) Q:+LEXII'>0  D

 . N LEXY,LEXT,LEXI S LEXY=$G(LEX("F",LEXA,"META","Includes/Examples",LEXII))

 . S LEXT(1)=LEXY D PR(.LEXT,(79-15)) Q:'$L($G(LEXT(1)))

 . S LEXIC=LEXIC+1 W:LEXIC=1 !!," Include(s):" W:LEXIC'=1 ! W ?15,$G(LEXT(1))

 . S LEXI=1 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  W !,?15,$G(LEXT(LEXI))

 I LEXC>0 S LEXC=$$CONT W !

 W:$L($G(IOF)) @IOF

 D:$L($G(LEXTXT)) CUR^LEX10PL(LEXTXT) W !

 W:$D(LEXTEST) !," Next character:  ",!

 S LEXI=0 F  S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0  D

 . W !,?1,$G(LEX(+LEXI))

 Q

 ; 

 ; Miscellaneous

CUR(X) ;   Current Array

 K CUR N INP,PSN

 S INP=$G(X) Q:'$L(INP)  Q:'$D(^LEX(757.033,"AFRAG",31,(INP_" ")))

 S CUR=INP F PSN=1:1:$L(INP)  D

 . N SEC,CHR S SEC=$E(INP,1,PSN),CHR=$E(INP,PSN)

 Q

CL ;   Clear

 K LEXIT

 Q

BUILD ;   Build Selection Array

 D ATTR I LEXTOT'>15 D

 . K LEX N LEXI,LEXC S LEXC=0,LEXI=""

 . F  S LEXI=$O(LEXPCDAT("NEXLEV",LEXI)) Q:'$L(LEXI)  D

 . . N LEXT,LEXH S LEXT=$G(LEXPCDAT("NEXLEV",LEXI,"DESC"))

 . . Q:$L(LEXI)'=1  Q:'$L(LEXT)

 . . S LEXH=$S($D(LEXPCDAT("NEXLEV",LEXI,"META")):" *",1:"")

 . . S LEXC=LEXC+1 S LEX(LEXC)=$J(LEXC,4)_".  ("_BOLD_LEXI_NORM_")  "_LEXT_LEXH

 . . S:$L(LEXI) LEX("C",$$UP^XLFSTR(LEXI))=LEXC

 . . S:$L(LEXT) LEX("D",$$UP^XLFSTR(LEXT))=LEXC

 . . S LEX("B",LEXC)=LEXI

 . . S LEX("E",LEXC)=$$UP^XLFSTR(LEXI)

 . . S LEX(0)=LEXC

 . . I $D(LEXPCDAT("NEXLEV",LEXI,"META")) M LEX("F",LEXC)=LEXPCDAT("NEXLEV",LEXI)

 I LEXTOT>15 D

 . K LEX N LEXI,LEXN,LEXC,LEXD,LEXOFF,LEXXE,LEXXC S LEXOFF=(LEXTOT\2)+(LEXTOT#2) S LEXC=0,LEXI=""

 . S LEXXE=36+($L($G(BOLD)))+($L($G(NORM))),LEXXC=38+($L($G(BOLD)))+($L($G(NORM)))

 . F LEXN=1:1:LEXOFF D

 . . N LEXT,LEXN1,LEXN2,LEXC1,LEXC2,LEXT1,LEXT2,LEXP1,LEXP2,LEXH1,LEXH2

 . . S LEXN1=LEXN,LEXN2=LEXN+LEXOFF,(LEXP1,LEXP2)=""

 . . S LEXC1=$$CD(LEXN1),LEXC2=$$CD((LEXN2))

 . . S LEXT1=$P(LEXC1,"^",2),LEXT2=$P(LEXC2,"^",2)

 . . S:$L(LEXT1)>28 LEXT1=$$SH^LEX10PLA(LEXT1,28)

 . . S:$L(LEXT2)>28 LEXT2=$$SH^LEX10PLA(LEXT2,28)

 . . S LEXC1=$P(LEXC1,"^",1),LEXC2=$P(LEXC2,"^",1)

 . . S LEXP1="" I LEXN1>0,$L(LEXC1),$L(LEXT1) D

 . . . S LEXH1="" S:$D(LEXPCDAT("NEXLEV",LEXC1,"META")) LEXH1=" *"

 . . . S LEXP1=$J(LEXN1,2)_". ("_$G(BOLD)_LEXC1_$G(NORM)_") "_LEXT1_LEXH1

 . . S LEXP2="" I LEXN2>0,$L(LEXC2),$L(LEXT2) D

 . . . S LEXH2="" S:$D(LEXPCDAT("NEXLEV",LEXC2,"META")) LEXH2=" *"

 . . . S LEXP2=$J(LEXN2,2)_". ("_$G(BOLD)_LEXC2_$G(NORM)_") "_LEXT2_LEXH1

 . . S LEXT=$E(LEXP1,1,LEXXE),LEXT=LEXT_$J(" ",(LEXXC-$L(LEXT)))_$E(LEXP2,1,LEXXE)

 . . S LEXC=LEXC+1 S LEX(LEXC)=LEXT

 . . ; Column 1

 . . I +($G(LEXN1))>0,$L(LEXC1)=1 D

 . . . S LEX("B",LEXN1)=LEXN1

 . . . S:$L(LEXC1) LEX("C",$$UP^XLFSTR(LEXC1))=LEXN1,LEX("E",LEXN1)=$$UP^XLFSTR(LEXC1)

 . . . S:$L(LEXT1) LEX("D",$$UP^XLFSTR(LEXT1))=LEXN1

 . . I $L(LEXC1),LEXN1>0 I $D(LEXPCDAT("NEXLEV",LEXC1,"META")) M LEX("F",LEXC1)=LEXPCDAT("NEXLEV",LEXC1)

 . . ; Column 2

 . . I +($G(LEXN2))>0,$L(LEXC2)=1 D

 . . . S LEX("B",LEXN2)=LEXN2

 . . . S:$L(LEXC2) LEX("C",$$UP^XLFSTR(LEXC2))=LEXN2,LEX("E",LEXN2)=$$UP^XLFSTR(LEXC2)

 . . . S:$L(LEXT2) LEX("D",$$UP^XLFSTR(LEXT2))=LEXN2

 . . . ;S LEX("B",LEXN2)=LEXC2,LEX("B",LEXC2)=LEXC2

 . . I $L(LEXC2),LEXN2>0 I $D(LEXPCDAT("NEXLEV",LEXC2,"META")) M LEX("F",LEXC2)=LEXPCDAT("NEXLEV",LEXC2)

 . . S LEX(0)=LEXC

 D KATTR

 Q

CD(X) ;  Character/Description

 N LEXN,LEXI,LEXC,LEXC,LEXE S LEXN=$G(X) Q:+LEXN'>0  S LEXE=0,LEXC="",LEXD="",X=""

 F LEXI=1:1:LEXN Q:LEXE  D  Q:LEXE

 . S LEXC=$O(LEXPCDAT("NEXLEV",LEXC)) I '$L(LEXC) S LEXD="",LEXE=1 Q

 . S LEXD=$G(LEXPCDAT("NEXLEV",LEXC,"DESC"))

 S X=LEXC_"^"_LEXD

 Q X

SH(X) ;   Shorten Text

 S X=$G(X) N LEXR,LEXW

 S LEXR=" and ",LEXW=" & " S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)

 S LEXR=" Systems",LEXW=" Sys" S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)

 S LEXR=" System",LEXW=" Sys" S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)

 ;S LEXR=" Upper ",LEXW=" Up " S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)

 S LEXR="Anatomical ",LEXW="Anat. " S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)

 S LEXR="Subcutaneous",LEXW="Subcut." S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)

 S LEXR="Extremities",LEXW="Extrem." S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)

 Q X

ATTR ;   Screen Attributes

 N X,IOINHI,IOINORM S X="IOINHI;IOINORM" D ENDR^%ZISS S BOLD=$G(IOINHI),NORM=$G(IOINORM)

 Q

KATTR ;   Kill Screen Attributes

 D KILL^%ZISS K BOLD,NORM

 Q

TEST ; Test Array Building

 K LEX N LEXC,LEXDT,LEXHLP,LEXI,LEXIT,LEXM,LEXMAX,LEXP1,LEXP1,LEXPCDAT,LEXSS,LEXTOT,LEXTXT,LEXUP,LEXY,LEXCHR,LEXIT

 S LEXTXT="0CDXXZ",LEXDT=3141010

 S LEXTXT="0C",LEXDT=3141010

 D LOOK^LEX10PL

 Q

FND(X) ;   Found

 N LEXI S X=0,LEXI="" F  S LEXI=$O(LEXPCDAT("NEXLEV",LEXI)) Q:'$L(LEXI)  S X=X+1

 Q X

GETO(X) ;   Get One

 S X=$O(LEXPCDAT("NEXLEV",""))

 Q X

PR(LEX,X) ;   Parse Array

 N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,Z,LEXC,LEXI,LEXL

 K ^UTILITY($J,"W") Q:'$D(LEX)  S LEXL=+($G(X)) S:+LEXL'>0 LEXL=79

 S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0

 S DIWL=1,DIWF="C"_+LEXL S LEXI=0

 F  S LEXI=$O(LEX(LEXI)) Q:+LEXI=0  S X=$G(LEX(LEXI)) D ^DIWP

 K LEX S (LEXC,LEXI)=0

 F  S LEXI=$O(^UTILITY($J,"W",1,LEXI)) Q:+LEXI=0  D

 . S LEX(LEXI)=$$TM($G(^UTILITY($J,"W",1,LEXI,0))," "),LEXC=LEXC+1

 S:$L(LEXC) LEX=LEXC K ^UTILITY($J,"W")

 Q

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

CONT(X) ;   Ask to Continue

 N DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y S DIR(0)="EAO",DIR("A")="     Press Enter to continue"

 S DIR("PRE")="S:X[""?"" X=""??"" S:X[""^"" X=""^""",(DIR("?"),DIR("??"))="^D CONTH^LEX10PLS"

 W ! D ^DIR

 Q ""

CONTH ;      Ask to Continue Help

 W !,"       Press Enter to continue" Q

LEX10PLS  ;ISL/KER - ICD-10 Procedure Lookup Selection ;04/21/2014

 +1       ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10

 +2       ;               

 +3       ; Global Variables

 +4       ;    ^LEX(757.033        N/A

 +5       ;    ^UTILITY($J         ICR  10011

 +6       ;               

 +7       ; External References

 +8       ;    ENDR^%ZISS          ICR  10088

 +9       ;    KILL^%ZISS          ICR  10088

 +10      ;    ^DIR                ICR  10026

 +11      ;    ^DIWP               ICR  10011

 +12      ;               

 +13      ; Local Variables NEWed or KILLed Elsewhere

 +14      ;     LEXPCDAT

 +15      ;               

SEL(X)    ; Select from List

 +1       ;

 +2       ; Input   

 +3       ; 

 +4       ;    X        Origninal Value

 +5       ;    

 +6       ;    Needs LEXPCDAT array

 +7       ;                  

 +8       ;             LEXPCDAT=1

 +9       ;             LEXPCDAT("NEXLEV","6","DESC")="Cerebral Ventricle"

 +10      ;             LEXPCDAT("NEXLEV","U","DESC")="Spinal Canal"

 +11      ;             LEXPCDAT("LEXLEV",<character>,"DESC")=Description of Character

 +12      ;             

 +13      ; Output

 +14      ;               

 +15      ;    $$SEL  Next Character or -1

 +16      ;               

 +17      ; Creates Selection Array LEX

 +18      ; 

 +19      ;             LEX(0)=3

 +20      ;             LEX(1)="6^   1.  ("_$c(27)_"[1m6"_$c(27)_"[m)  Cerebral Ventricle"

 +21      ;             LEX(2)="U^   2.  ("_$c(27)_"[1mU"_$c(27)_"[m)  Spinal Canal"

 +22      ;             LEX(2)=<character>^<menu text>

 +23      ;             LEX("B",1)=1

 +24      ;             LEX("B",2)=2

 +25      ;             LEX("B",<menu item>)=<menu item>

 +26      ;             LEX("B",6)=1

 +27      ;             LEX("B","U")=2

 +28      ;             LEX("B",<character>)=<menu item>

 +29      ;

 +30       NEW DIR,DIRB,LEX,LEXCUR,LEXE,LEXFI,LEXHLP,LEXI,LEXIT,LEXL,LEXLAST

 +31       NEW LEXMAX,LEXOUT,LEXS,LEXSS,LEXTOT,LEXTXT,LEXX

           KILL DTOUT,DUOUT,DIROUT,DIRUT

 +32       NEW LEXIT,LEXL,LEXTOT,LEX

           SET LEXTXT=$GET(X)

           SET LEXIT=0

           SET LEXTOT=$$FND

           IF +LEXTOT'>0

               QUIT "^"

 +33       KILL X

           IF +LEXTOT=1

               SET X=$$ONE

           IF +LEXTOT>1

               SET X=$$MUL(LEXTXT)

           NEW LEXTEST

 +34       QUIT X

ONE(X)    ; One Entry Found

 +1        IF +($GET(LEXIT))>0

               QUIT "^^"

           SET X=$$GETO

 +2        QUIT X

MUL(X)    ; Multiple Entries Found

 +1        IF +($GET(LEXIT))>0

               QUIT "^^"

           NEW LEX,LEXE,LEXI,LEXL,LEXMAX,LEXP,LEXSS,LEXX

 +2        SET LEXTXT=$GET(X)

           DO BUILD

 +3        SET LEXMAX=$GET(LEXTOT)

           SET (LEXSS,LEXIT)=0

           SET U="^"

           IF LEXMAX'>1

               GOTO MULQ

 +4        IF $LENGTH($GET(LEXTXT))

               DO CUR^LEX10PL(LEXTXT)

           WRITE !

 +5        IF $DATA(LEXTEST)

               WRITE !," Next character:  ",!

 +6        SET LEXI=0

           FOR 

               SET LEXI=$ORDER(LEX(LEXI))

               IF +LEXI'>0

                   QUIT 

               Begin DoDot:1

 +7                WRITE !,?1,$GET(LEX(+LEXI))

               End DoDot:1

 +8        WRITE !

           SET LEXSS=$$MULS

           IF LEXSS["^"

               SET LEXIT=1

 +9        SET X=LEXSS

MULQ      ;   Multiple Entries - Quit

 +1        KILL LEX

 +2        QUIT X

MULS(X)   ;   Multiple Entries - Select

 +1        KILL DTOUT,DUOUT,DIROUT,DIRUT

 +2        NEW DIR,DIRB,LEXFI,LEXHLP,LEXLAST,LEXS

           SET LEXMAX=+($GET(LEXMAX))

           SET LEXTXT=$GET(LEXTXT)

 +3        IF +($GET(LEXIT))>0

               QUIT "^^"

           IF LEXMAX'>1

               QUIT ""

 +4        SET DIR("A")=" Select Next Character 1-"_LEXMAX_": "

 +5        SET LEXHLP=" Answer must be from 1 to "_LEXMAX_" or a character."

 +6        SET DIR("PRE")="S X=$$MULSP^LEX10PLS(X)"

 +7        SET (DIR("?"),DIR("??"))="^D MULSH^LEX10PLS"

 +8        SET DIR(0)="FAO^1:3"

           DO ^DIR

           IF X["^^"!($DATA(DTOUT))!($DATA(DIROUT))

               SET LEXIT=1

               SET X="^^"

               QUIT X

 +9        IF X["^"!($DATA(DIRUT))!($DATA(DUOUT))

               QUIT "^"

           IF '$LENGTH(X)

               QUIT ""

 +10       IF +Y>0

               IF $LENGTH($GET(LEX("E",+Y)))

                   SET X=$GET(LEX("E",+Y))

                   QUIT X

 +11       QUIT X

MULSH     ;   Multiple Entries - Selection Help

 +1        IF $LENGTH($GET(LEXHLP))

               WRITE !,$GET(LEXHLP)

               QUIT 

 +2        QUIT 

MULSP(X)  ;   Multiple Entries - Pre-Process

 +1        NEW LEXM,LEXP1,LEXP2,LEXO,LEXN,LEXA

           SET (LEXM,X)=$$UP^XLFSTR($GET(X))

           IF '$LENGTH(X)

               QUIT X

 +2        SET LEXP1=$EXTRACT(LEXM,1)

           SET LEXP2=$EXTRACT(LEXM,2,$LENGTH(LEXM))

           SET LEXA=""

           IF $LENGTH(LEXP2)

               SET LEXA=$GET(LEX("E",LEXP2))

 +3        IF $DATA(LEX("B",LEXM))

               SET X=LEXM

               QUIT X

 +4        IF $DATA(LEX("C",LEXM))

               SET X=$GET(LEX("C",LEXM))

               QUIT X

 +5        IF $LENGTH(LEXM)=1

               SET LEXO=$CHAR($ASCII(LEXM)-1)_"~"

 +6        IF $LENGTH(LEXM)>1

               SET LEXO=$EXTRACT(LEXM,1,($LENGTH(LEXM)-1))_$CHAR($ASCII($EXTRACT(LEXM,$LENGTH(LEXM)))-1)_"~"

 +7        SET LEXN=""

           IF $LENGTH(LEXO)

               SET LEXN=$ORDER(LEX("D",LEXO))

           IF $EXTRACT(LEXN,1,$LENGTH(LEXM))'=LEXM

               SET LEXN=""

 +8        IF $LENGTH(LEXN)

               IF $LENGTH($GET(LEX("D",LEXN)))

                   SET X=$GET(LEX("D",LEXN))

                   QUIT X

 +9        IF LEXP1="?"

               IF $LENGTH(LEXP2)

                   IF $LENGTH(LEXA)=1

                       IF $DATA(LEX("F",LEXA))

                           DO MULSEH

                           SET X="??"

                           QUIT X

 +10       IF LEXM["?"

               QUIT "??"

           IF '$LENGTH(LEXM)

               QUIT ""

           IF LEXM["^^"

               QUIT "^^"

           IF LEXM["^"

               QUIT "^"

 +11       IF '$DATA(LEX("B",X))

               SET X="??"

 +12       QUIT X

MULSEH    ; Extended Help

 +1        NEW LEXT,LEXD,LEXE,LEXI,LEXP,LEXII,LEXIC

           SET LEXA=$GET(LEXA)

           IF $LENGTH(LEXA)'=1

               QUIT 

           IF '$DATA(LEX("F",LEXA))

               QUIT 

 +2        SET LEXT=$GET(LEX("F",LEXA,"DESC"))

 +3        SET LEXD=$GET(LEX("F",LEXA,"META","Definition"))

 +4        SET LEXE=$GET(LEX("F",LEXA,"META","Explanation"))

 +5        SET LEXY=$GET(LEX("F",LEXA,"META","Includes/Examples",1))

 +6        SET LEXC=0

           IF $LENGTH(LEXT)

               SET LEXC=LEXC+1

               IF LEXC=1

                   WRITE !

               WRITE !," ",LEXT

 +7        KILL LEXT

           SET LEXT(1)=LEXD

           IF $LENGTH(LEXT(1))

               Begin DoDot:1

 +8                NEW LEXI

                   DO PR(.LEXT,(79-15))

                   IF '$LENGTH($GET(LEXT(1)))

                       QUIT 

 +9                WRITE !!," Definition:",?15,$GET(LEXT(1))

                   SET LEXC=LEXC+1

 +10               SET I=1

                   FOR 

                       SET I=$ORDER(LEXT(I))

                       IF +I'>0

                           QUIT 

                       WRITE !,?15,$GET(LEXT(I))

               End DoDot:1

 +11       KILL LEXT

           SET LEXT(1)=LEXE

           IF $LENGTH(LEXT(1))

               Begin DoDot:1

 +12               NEW LEXI

                   DO PR(.LEXT,(79-15))

                   IF '$LENGTH($GET(LEXT(1)))

                       QUIT 

 +13               WRITE !!," Explanation:",?15,$GET(LEXT(1))

                   SET LEXC=LEXC+1

 +14               SET I=1

                   FOR 

                       SET I=$ORDER(LEXT(I))

                       IF +I'>0

                           QUIT 

                       WRITE !,?15,$GET(LEXT(I))

               End DoDot:1

 +15       SET (LEXII,LEXIC)=0

 +16       FOR 

               SET LEXII=$ORDER(LEX("F",LEXA,"META","Includes/Examples",LEXII))

               IF +LEXII'>0

                   QUIT 

               Begin DoDot:1

 +17               NEW LEXY,LEXT,LEXI

                   SET LEXY=$GET(LEX("F",LEXA,"META","Includes/Examples",LEXII))

 +18               SET LEXT(1)=LEXY

                   DO PR(.LEXT,(79-15))

                   IF '$LENGTH($GET(LEXT(1)))

                       QUIT 

 +19               SET LEXIC=LEXIC+1

                   IF LEXIC=1

                       WRITE !!," Include(s):"

                   IF LEXIC'=1

                       WRITE !

                   WRITE ?15,$GET(LEXT(1))

 +20               SET LEXI=1

                   FOR 

                       SET LEXI=$ORDER(LEXT(LEXI))

                       IF +LEXI'>0

                           QUIT 

                       WRITE !,?15,$GET(LEXT(LEXI))

               End DoDot:1

 +21       IF LEXC>0

               SET LEXC=$$CONT

               WRITE !

 +22       IF $LENGTH($GET(IOF))

               WRITE @IOF

 +23       IF $LENGTH($GET(LEXTXT))

               DO CUR^LEX10PL(LEXTXT)

           WRITE !

 +24       IF $DATA(LEXTEST)

               WRITE !," Next character:  ",!

 +25       SET LEXI=0

           FOR 

               SET LEXI=$ORDER(LEX(LEXI))

               IF +LEXI'>0

                   QUIT 

               Begin DoDot:1

 +26               WRITE !,?1,$GET(LEX(+LEXI))

               End DoDot:1

 +27       QUIT 

 +28      ; 

 +29      ; Miscellaneous

CUR(X)    ;   Current Array

 +1        KILL CUR

           NEW INP,PSN

 +2        SET INP=$GET(X)

           IF '$LENGTH(INP)

               QUIT 

           IF '$DATA(^LEX(757.033,"AFRAG",31,(INP_" ")))

               QUIT 

 +3        SET CUR=INP

           FOR PSN=1:1:$LENGTH(INP)

               Begin DoDot:1

 +4                NEW SEC,CHR

                   SET SEC=$EXTRACT(INP,1,PSN)

                   SET CHR=$EXTRACT(INP,PSN)

               End DoDot:1

 +5        QUIT 

CL        ;   Clear

 +1        KILL LEXIT

 +2        QUIT 

BUILD     ;   Build Selection Array

 +1        DO ATTR

           IF LEXTOT'>15

               Begin DoDot:1

 +2                KILL LEX

                   NEW LEXI,LEXC

                   SET LEXC=0

                   SET LEXI=""

 +3                FOR 

                       SET LEXI=$ORDER(LEXPCDAT("NEXLEV",LEXI))

                       IF '$LENGTH(LEXI)

                           QUIT 

                       Begin DoDot:2

 +4                        NEW LEXT,LEXH

                           SET LEXT=$GET(LEXPCDAT("NEXLEV",LEXI,"DESC"))

 +5                        IF $LENGTH(LEXI)'=1

                               QUIT 

                           IF '$LENGTH(LEXT)

                               QUIT 

 +6                        SET LEXH=$SELECT($DATA(LEXPCDAT("NEXLEV",LEXI,"META")):" *",1:"")

 +7                        SET LEXC=LEXC+1

                           SET LEX(LEXC)=$JUSTIFY(LEXC,4)_".  ("_BOLD_LEXI_NORM_")  "_LEXT_LEXH

 +8                        IF $LENGTH(LEXI)

                               SET LEX("C",$$UP^XLFSTR(LEXI))=LEXC

 +9                        IF $LENGTH(LEXT)

                               SET LEX("D",$$UP^XLFSTR(LEXT))=LEXC

 +10                       SET LEX("B",LEXC)=LEXI

 +11                       SET LEX("E",LEXC)=$$UP^XLFSTR(LEXI)

 +12                       SET LEX(0)=LEXC

 +13                       IF $DATA(LEXPCDAT("NEXLEV",LEXI,"META"))

                               MERGE LEX("F",LEXC)=LEXPCDAT("NEXLEV",LEXI)

                       End DoDot:2

               End DoDot:1

 +14       IF LEXTOT>15

               Begin DoDot:1

 +15               KILL LEX

                   NEW LEXI,LEXN,LEXC,LEXD,LEXOFF,LEXXE,LEXXC

                   SET LEXOFF=(LEXTOT\2)+(LEXTOT#2)

                   SET LEXC=0

                   SET LEXI=""

 +16               SET LEXXE=36+($LENGTH($GET(BOLD)))+($LENGTH($GET(NORM)))

                   SET LEXXC=38+($LENGTH($GET(BOLD)))+($LENGTH($GET(NORM)))

 +17               FOR LEXN=1:1:LEXOFF

                       Begin DoDot:2