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
+18 NEW LEXT,LEXN1,LEXN2,LEXC1,LEXC2,LEXT1,LEXT2,LEXP1,LEXP2,LEXH1,LEXH2
+19 SET LEXN1=LEXN
SET LEXN2=LEXN+LEXOFF
SET (LEXP1,LEXP2)=""
+20 SET LEXC1=$$CD(LEXN1)
SET LEXC2=$$CD((LEXN2))
+21 SET LEXT1=$PIECE(LEXC1,"^",2)
SET LEXT2=$PIECE(LEXC2,"^",2)
+22 IF $LENGTH(LEXT1)>28
SET LEXT1=$$SH^LEX10PLA(LEXT1,28)
+23 IF $LENGTH(LEXT2)>28
SET LEXT2=$$SH^LEX10PLA(LEXT2,28)
+24 SET LEXC1=$PIECE(LEXC1,"^",1)
SET LEXC2=$PIECE(LEXC2,"^",1)
+25 SET LEXP1=""
IF LEXN1>0
IF $LENGTH(LEXC1)
IF $LENGTH(LEXT1)
Begin DoDot:3
+26 SET LEXH1=""
IF $DATA(LEXPCDAT("NEXLEV",LEXC1,"META"))
SET LEXH1=" *"
+27 SET LEXP1=$JUSTIFY(LEXN1,2)_". ("_$GET(BOLD)_LEXC1_$GET(NORM)_") "_LEXT1_LEXH1
End DoDot:3
+28 SET LEXP2=""
IF LEXN2>0
IF $LENGTH(LEXC2)
IF $LENGTH(LEXT2)
Begin DoDot:3
+29 SET LEXH2=""
IF $DATA(LEXPCDAT("NEXLEV",LEXC2,"META"))
SET LEXH2=" *"
+30 SET LEXP2=$JUSTIFY(LEXN2,2)_". ("_$GET(BOLD)_LEXC2_$GET(NORM)_") "_LEXT2_LEXH1
End DoDot:3
+31 SET LEXT=$EXTRACT(LEXP1,1,LEXXE)
SET LEXT=LEXT_$JUSTIFY(" ",(LEXXC-$LENGTH(LEXT)))_$EXTRACT(LEXP2,1,LEXXE)
+32 SET LEXC=LEXC+1
SET LEX(LEXC)=LEXT
+33 ; Column 1
+34 IF +($GET(LEXN1))>0
IF $LENGTH(LEXC1)=1
Begin DoDot:3
+35 SET LEX("B",LEXN1)=LEXN1
+36 IF $LENGTH(LEXC1)
SET LEX("C",$$UP^XLFSTR(LEXC1))=LEXN1
SET LEX("E",LEXN1)=$$UP^XLFSTR(LEXC1)
+37 IF $LENGTH(LEXT1)
SET LEX("D",$$UP^XLFSTR(LEXT1))=LEXN1
End DoDot:3
+38 IF $LENGTH(LEXC1)
IF LEXN1>0
IF $DATA(LEXPCDAT("NEXLEV",LEXC1,"META"))
MERGE LEX("F",LEXC1)=LEXPCDAT("NEXLEV",LEXC1)
+39 ; Column 2
+40 IF +($GET(LEXN2))>0
IF $LENGTH(LEXC2)=1
Begin DoDot:3
+41 SET LEX("B",LEXN2)=LEXN2
+42 IF $LENGTH(LEXC2)
SET LEX("C",$$UP^XLFSTR(LEXC2))=LEXN2
SET LEX("E",LEXN2)=$$UP^XLFSTR(LEXC2)
+43 IF $LENGTH(LEXT2)
SET LEX("D",$$UP^XLFSTR(LEXT2))=LEXN2
+44 ;S LEX("B",LEXN2)=LEXC2,LEX("B",LEXC2)=LEXC2
End DoDot:3
+45 IF $LENGTH(LEXC2)
IF LEXN2>0
IF $DATA(LEXPCDAT("NEXLEV",LEXC2,"META"))
MERGE LEX("F",LEXC2)=LEXPCDAT("NEXLEV",LEXC2)
+46 SET LEX(0)=LEXC
End DoDot:2
End DoDot:1
+47 DO KATTR
+48 QUIT
CD(X) ; Character/Description
+1 NEW LEXN,LEXI,LEXC,LEXC,LEXE
SET LEXN=$GET(X)
IF +LEXN'>0
QUIT
SET LEXE=0
SET LEXC=""
SET LEXD=""
SET X=""
+2 FOR LEXI=1:1:LEXN
IF LEXE
QUIT
Begin DoDot:1
+3 SET LEXC=$ORDER(LEXPCDAT("NEXLEV",LEXC))
IF '$LENGTH(LEXC)
SET LEXD=""
SET LEXE=1
QUIT
+4 SET LEXD=$GET(LEXPCDAT("NEXLEV",LEXC,"DESC"))
End DoDot:1
IF LEXE
QUIT
+5 SET X=LEXC_"^"_LEXD
+6 QUIT X
SH(X) ; Shorten Text
+1 SET X=$GET(X)
NEW LEXR,LEXW
+2 SET LEXR=" and "
SET LEXW=" & "
IF X[LEXR
SET X=$PIECE(X,LEXR,1)_LEXW_$PIECE(X,LEXR,2,299)
+3 SET LEXR=" Systems"
SET LEXW=" Sys"
IF X[LEXR
SET X=$PIECE(X,LEXR,1)_LEXW_$PIECE(X,LEXR,2,299)
+4 SET LEXR=" System"
SET LEXW=" Sys"
IF X[LEXR
SET X=$PIECE(X,LEXR,1)_LEXW_$PIECE(X,LEXR,2,299)
+5 ;S LEXR=" Upper ",LEXW=" Up " S:X[LEXR X=$P(X,LEXR,1)_LEXW_$P(X,LEXR,2,299)
+6 SET LEXR="Anatomical "
SET LEXW="Anat. "
IF X[LEXR
SET X=$PIECE(X,LEXR,1)_LEXW_$PIECE(X,LEXR,2,299)
+7 SET LEXR="Subcutaneous"
SET LEXW="Subcut."
IF X[LEXR
SET X=$PIECE(X,LEXR,1)_LEXW_$PIECE(X,LEXR,2,299)
+8 SET LEXR="Extremities"
SET LEXW="Extrem."
IF X[LEXR
SET X=$PIECE(X,LEXR,1)_LEXW_$PIECE(X,LEXR,2,299)
+9 QUIT X
ATTR ; Screen Attributes
+1 NEW X,IOINHI,IOINORM
SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
SET BOLD=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+2 QUIT
KATTR ; Kill Screen Attributes
+1 DO KILL^%ZISS
KILL BOLD,NORM
+2 QUIT
TEST ; Test Array Building
+1 KILL LEX
NEW LEXC,LEXDT,LEXHLP,LEXI,LEXIT,LEXM,LEXMAX,LEXP1,LEXP1,LEXPCDAT,LEXSS,LEXTOT,LEXTXT,LEXUP,LEXY,LEXCHR,LEXIT
+2 SET LEXTXT="0CDXXZ"
SET LEXDT=3141010
+3 SET LEXTXT="0C"
SET LEXDT=3141010
+4 DO LOOK^LEX10PL
+5 QUIT
FND(X) ; Found
+1 NEW LEXI
SET X=0
SET LEXI=""
FOR
SET LEXI=$ORDER(LEXPCDAT("NEXLEV",LEXI))
IF '$LENGTH(LEXI)
QUIT
SET X=X+1
+2 QUIT X
GETO(X) ; Get One
+1 SET X=$ORDER(LEXPCDAT("NEXLEV",""))
+2 QUIT X
PR(LEX,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,Z,LEXC,LEXI,LEXL
+2 KILL ^UTILITY($JOB,"W")
IF '$DATA(LEX)
QUIT
SET LEXL=+($GET(X))
IF +LEXL'>0
SET LEXL=79
+3 SET LEXC=+($GET(LEX))
IF +($GET(LEXC))'>0
SET LEXC=$ORDER(LEX(" "),-1)
IF +LEXC'>0
QUIT
+4 SET DIWL=1
SET DIWF="C"_+LEXL
SET LEXI=0
+5 FOR
SET LEXI=$ORDER(LEX(LEXI))
IF +LEXI=0
QUIT
SET X=$GET(LEX(LEXI))
DO ^DIWP
+6 KILL LEX
SET (LEXC,LEXI)=0
+7 FOR
SET LEXI=$ORDER(^UTILITY($JOB,"W",1,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+8 SET LEX(LEXI)=$$TM($GET(^UTILITY($JOB,"W",1,LEXI,0))," ")
SET LEXC=LEXC+1
End DoDot:1
+9 IF $LENGTH(LEXC)
SET LEX=LEXC
KILL ^UTILITY($JOB,"W")
+10 QUIT
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=" "
+2 FOR
IF $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
CONT(X) ; Ask to Continue
+1 NEW DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y
SET DIR(0)="EAO"
SET DIR("A")=" Press Enter to continue"
+2 SET DIR("PRE")="S:X[""?"" X=""??"" S:X[""^"" X=""^"""
SET (DIR("?"),DIR("??"))="^D CONTH^LEX10PLS"
+3 WRITE !
DO ^DIR
+4 QUIT ""
CONTH ; Ask to Continue Help
+1 WRITE !," Press Enter to continue"
QUIT
