LEX10DLS ;ISL/KER - ICD-10 Diagnosis Lookup Selection ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^UTILITY($J ICR 10011
;
; External References
; ^DIR ICR 10026
; ^DIWP ICR 10011
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed in LEX10DL
; DIROUT,DTOUT,DUOUT
;
SEL(LEX,X) ; Select from List
;
; Input
;
; X Length of list to display (default 5)
; .LEX Local array passed by reference
;
; LEX() Input Array from ICDSRCH^LEX10CS
;
; LEX(0)=# found ^ Pruning Indicator
; LEX(1,0)=Code ^ Code IEN ^ date
; LEX(1,"IDL")=ICD-9/10 Description, Long
; LEX(1,"IDL",1)=ICD-9/10 IEN ^ date
; LEX(1,"IDS")=ICD-9/10 Description, Short
; LEX(1,"IDS",1)=ICD-9/10 IEN ^ date
; LEX(1,"LEX")=Lexicon Description
; LEX(1,"LEX",1)=Expression IEN ^ date
; LEX(1,"SYN",1)=Synonym #1
; LEX(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; LEX Local array passed by reference
;
; LEX(0)=Code ^ Code IEN ^ date
; LEX("IDL")=ICD-9/10 Description, Long
; LEX("IDL",1)=ICD-9/10 IEN ^ date
; LEX("IDS")=ICD-9/10 Description, Short
; LEX("IDS",1)=ICD-9/10 IEN ^ date
; LEX("LEX")=Lexicon Description
; LEX("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
;
S X=+($G(X)) S:X'>0 X=5 S X=$$ASK(.LEX,X)
Q X
ASK(LEX,X) ; Ask for Selection
N LEXIT,LEXL,LEXTOT S LEXL=+($G(X)) S:LEXL'>0 LEXL=5
S LEXIT=0,LEXTOT=$O(LEX(" "),-1) Q:+LEXTOT'>0 "^"
K X S:+LEXTOT=1 X=$$ONE(LEXL,.LEX) S:+LEXTOT>1 X=$$MUL(.LEX,LEXL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,LEX) ; One Entry Found
Q:+($G(LEXIT))>0 "^^" N DIR,LEXC,LEXEX,LEXFI,LEXIT,LEXSO,LEXNC
N LEXSP,LEXTX,LEXC,Y S LEXFI=$O(LEX(0)) Q:+LEXFI'>0 "^" S LEXSP=$J(" ",25)
S LEXSO=$P(LEX(1,0),"^",1),LEXNC=$P(LEX(1,0),"^",3)
S:+LEXNC>0 LEXNC=" ("_LEXNC_")" S LEXEX=$G(LEX(1,"MENU"))
S LEXC=$S($D(LEX(1,"CAT")):"-",1:"")
S LEXTX(1)=LEXSO_LEXC_$J(" ",(9-$L(LEXSO)))_" "_LEXEX_LEXNC
D PR(.LEXTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(LEXTX(1)),LEXC=3 I $L($G(LEXTX(2))) D
. S LEXC=LEXC+1,DIR("A",LEXC)=LEXSP_$G(LEXTX(2))
S LEXC=LEXC+1,DIR("A",LEXC)=" ",LEXC=LEXC+1
S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
D ^DIR Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) LEXIT=1
I X["^^"!(+($G(LEXIT))>0) K LEX Q "^^"
S X=$S(+Y>0:$$X(1,.LEX),1:-1)
Q X
MUL(LEX,Y) ; Multiple Entries Found
Q:+($G(LEXIT))>0 "^^" N LEXE,LEXL,LEXMAX,LEXSS,LEXX,X
S (LEXMAX,LEXSS,LEXIT)=0,LEXL=+($G(Y)),U="^" S:+($G(LEXL))'>0 LEXL=5
S LEXX=$O(LEX(" "),-1),LEXSS=0
G:+LEXX=0 MULQ W ! W:+LEXX>1 !," ",LEXX," matches found"
F LEXE=1:1:LEXX Q:((LEXSS>0)&(LEXSS<(LEXE+1))) Q:LEXIT D Q:LEXIT
. W:LEXE#LEXL=1 ! D MULW
. S LEXMAX=LEXE W:LEXE#LEXL=0 !
. S:LEXE#LEXL=0 LEXSS=$$MULS(LEXMAX,LEXE,.LEX) S:LEXSS["^" LEXIT=1
I LEXE#LEXL'=0,+LEXSS<=0 D
. W ! S LEXSS=$$MULS(LEXMAX,LEXE,.LEX) S:LEXSS["^" LEXIT=1
G MULQ
Q X
MULW ; Write Multiple
N LEXEX,LEXI,LEXSO,LEXNC,LEXT,LEXTX S LEXSO=$P(LEX(+LEXE,0),"^",1)
S LEXNC=$P(LEX(+LEXE,0),"^",3) S:+LEXNC>0 LEXNC=" ("_LEXNC_")"
S LEXEX=$G(LEX(+LEXE,"MENU")),LEXTX(1)=LEXSO
S LEXTX(1)=LEXTX(1)_$S($D(LEX(+LEXE,"CAT")):"-",1:" ")_$J(" ",(9-$L(LEXSO)))_" "_LEXEX_LEXNC
D PR(.LEXTX,60) W !,$J(LEXE,5),". ",$G(LEXTX(1))
F LEXI=2:1:5 S LEXT=$G(LEXTX(LEXI)) W:$L(LEXT) !,$J(" ",19),LEXT
Q
MULS(X,Y,LEX) ; Select from Multiple Entries
N DIR,DIRB,LEXFI,LEXHLP,LEXLAST,LEXMAX,LEXS
Q:+($G(LEXIT))>0 "^^" S LEXMAX=+($G(X)),LEXLAST=+($G(Y))
Q:LEXMAX=0 -1 S LEXFI=$O(LEX(0)) Q:+LEXFI'>0 -1
I +($O(LEX(+LEXLAST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_LEXMAX_": "
I +($O(LEX(+LEXLAST)))'>0 D
. S DIR("A")=" Select 1-"_LEXMAX_": "
S LEXHLP=" Answer must be from 1 to "
S LEXHLP=LEXHLP_LEXMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^LEX10DLS"
S DIR(0)="NAO^1:"_LEXMAX_":0" D ^DIR
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) LEXIT=1,X="^^" I X["^^"!(+($G(LEXIT))>0) Q "^^"
K DIR Q:$D(DTOUT)!(X[U) "^^"
Q $S(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
I $L($G(LEXHLP)) W !,$G(LEXHLP) Q
Q
MULQ ; Quit Multiple
I +LEXSS'>0,$G(LEXSS)="^" Q "^"
S X=-1 S:+($G(LEXIT))'>0 X=$$X(+LEXSS,.LEX)
Q X
X(X,LEX) ; Set X and Outpot Array
N LEXEX,LEXFI,LEXIEN,LEXN,LEXNC,LEXNN,LEXRN,LEXS,LEXSO
S LEXS=+($G(X)) S LEXFI=$O(LEX(0))
S LEXSO=$P($G(LEX(LEXS,0)),"^",1),LEXEX=$G(LEX(LEXS,"MENU"))
S LEXIEN=$S($D(LEX(LEXS,"CAT")):"99:CAT;"_$P($G(LEX(LEXS,0)),"^"),1:$P($G(LEX(LEXS,"LEX",1)),"^")_";"_$P($G(LEX(LEXS,0)),"^")) Q:'$L(LEXSO) "^"
Q:'$L(LEXEX) "^" Q:+LEXIEN'>0 "^" S X=LEXIEN_"^"_LEXEX
S LEXNN="LEX("_+LEXS_")",LEXNC="LEX("_+LEXS_","
F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
. S LEXRN="LEXN("_$P(LEXNN,"(",2,299) S @LEXRN=@LEXNN
K LEX S LEXNN="LEXN("_+LEXS_")",LEXNC="LEXN("_+LEXS_","
F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
. S LEXRN="LEX("_$P(LEXNN,"(",2,299),@LEXRN=@LEXNN
Q X
CONT(X,Y) ; Ask to Continue
K DTOUT,DUOUT,DIRUT,DIROUT N LEXX,LEXFQ,LEXW,LEXI,LEXC,DIR
S LEXX=$$UP^XLFSTR($G(X)),LEXFQ=$G(Y) Q:'$L(LEXX) 1 Q:LEXFQ'>0 1
S LEXW(1)="Searching for """_LEXX_""" requires inspecting "
S LEXW(2)=LEXFQ_" records to determine if they match the "
S LEXW(3)="search criteria. This could take quite some time."
S LEXW(4)="Suggest refining the search by further specifying "
S LEXW(5)=""""_LEXX_"."""
D PR(.LEXW,60) S (LEXC,LEXI)=0 F S LEXI=$O(LEXW(LEXI)) Q:+LEXI'>0 D
. Q:'$L($G(LEXW(LEXI))) S LEXC=LEXC+1 S DIR("A",LEXC)=" "_$G(LEXW(LEXI))
I LEXC>0 S LEXC=LEXC+1,DIR("A",LEXC)=" "
S DIR("A")=" Do you wish to continue? (Y/N) ",DIR("B")="No"
S DIR(0)="YAO",(DIR("?"),DIR("??"))="^D COH^LEX10DLS"
S DIR("PRE")="S:X[""?"" X=""??""" W ! D ^DIR
S X=+Y S:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) X="^"
Q X
COH ; Continue Help
I $L($G(LEXX))>0 D
. W !," Enter To"
. W !," 'Yes' continue searching for """,LEXX,"""."
. W !," 'No' refine the search (further specify)"
. W !," '^' discontinue the search and exit"
I '$L($G(LEXX))>0 D
. W !," Enter To"
. W !," 'Yes' continue the search"
. W !," 'No' refine the search (further specify)"
. W !," '^' discontinue the search and exit"
Q
;
; Miscellaneous
CL ; Clear
K LEXIT
Q
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
LEX10DLS ;ISL/KER - ICD-10 Diagnosis Lookup Selection ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^UTILITY($J ICR 10011
+5 ;
+6 ; External References
+7 ; ^DIR ICR 10026
+8 ; ^DIWP ICR 10011
+9 ; $$UP^XLFSTR ICR 10104
+10 ;
+11 ; Local Variables NEWed or KILLed in LEX10DL
+12 ; DIROUT,DTOUT,DUOUT
+13 ;
SEL(LEX,X) ; Select from List
+1 ;
+2 ; Input
+3 ;
+4 ; X Length of list to display (default 5)
+5 ; .LEX Local array passed by reference
+6 ;
+7 ; LEX() Input Array from ICDSRCH^LEX10CS
+8 ;
+9 ; LEX(0)=# found ^ Pruning Indicator
+10 ; LEX(1,0)=Code ^ Code IEN ^ date
+11 ; LEX(1,"IDL")=ICD-9/10 Description, Long
+12 ; LEX(1,"IDL",1)=ICD-9/10 IEN ^ date
+13 ; LEX(1,"IDS")=ICD-9/10 Description, Short
+14 ; LEX(1,"IDS",1)=ICD-9/10 IEN ^ date
+15 ; LEX(1,"LEX")=Lexicon Description
+16 ; LEX(1,"LEX",1)=Expression IEN ^ date
+17 ; LEX(1,"SYN",1)=Synonym #1
+18 ; LEX(1,"SYN",m)=Synonym #m
+19 ; ...
+20 ;
+21 ; Output
+22 ;
+23 ; $$SEL Two Piece "^" delimited string same as
+24 ; Fileman's Y output variable
+25 ;
+26 ; 1 Lexicon IEN
+27 ; 2 Lexicon Term
+28 ;
+29 ; LEX Local array passed by reference
+30 ;
+31 ; LEX(0)=Code ^ Code IEN ^ date
+32 ; LEX("IDL")=ICD-9/10 Description, Long
+33 ; LEX("IDL",1)=ICD-9/10 IEN ^ date
+34 ; LEX("IDS")=ICD-9/10 Description, Short
+35 ; LEX("IDS",1)=ICD-9/10 IEN ^ date
+36 ; LEX("LEX")=Lexicon Description
+37 ; LEX("LEX",1)=Expression IEN ^ date
+38 ;
+39 ; or ^ on error
+40 ; or -1 for non-selection
+41 ;
+42 SET X=+($GET(X))
IF X'>0
SET X=5
SET X=$$ASK(.LEX,X)
+43 QUIT X
ASK(LEX,X) ; Ask for Selection
+1 NEW LEXIT,LEXL,LEXTOT
SET LEXL=+($GET(X))
IF LEXL'>0
SET LEXL=5
+2 SET LEXIT=0
SET LEXTOT=$ORDER(LEX(" "),-1)
IF +LEXTOT'>0
QUIT "^"
+3 KILL X
IF +LEXTOT=1
SET X=$$ONE(LEXL,.LEX)
IF +LEXTOT>1
SET X=$$MUL(.LEX,LEXL)
+4 IF '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+5 QUIT X
ONE(X,LEX) ; One Entry Found
+1 IF +($GET(LEXIT))>0
QUIT "^^"
NEW DIR,LEXC,LEXEX,LEXFI,LEXIT,LEXSO,LEXNC
+2 NEW LEXSP,LEXTX,LEXC,Y
SET LEXFI=$ORDER(LEX(0))
IF +LEXFI'>0
QUIT "^"
SET LEXSP=$JUSTIFY(" ",25)
+3 SET LEXSO=$PIECE(LEX(1,0),"^",1)
SET LEXNC=$PIECE(LEX(1,0),"^",3)
+4 IF +LEXNC>0
SET LEXNC=" ("_LEXNC_")"
SET LEXEX=$GET(LEX(1,"MENU"))
+5 SET LEXC=$SELECT($DATA(LEX(1,"CAT")):"-",1:"")
+6 SET LEXTX(1)=LEXSO_LEXC_$JUSTIFY(" ",(9-$LENGTH(LEXSO)))_" "_LEXEX_LEXNC
+7 DO PR(.LEXTX,64)
SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+8 SET DIR("A",3)=" "_$GET(LEXTX(1))
SET LEXC=3
IF $LENGTH($GET(LEXTX(2)))
Begin DoDot:1
+9 SET LEXC=LEXC+1
SET DIR("A",LEXC)=LEXSP_$GET(LEXTX(2))
End DoDot:1
+10 SET LEXC=LEXC+1
SET DIR("A",LEXC)=" "
SET LEXC=LEXC+1
+11 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+12 DO ^DIR
IF '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+13 IF X["^^"!($DATA(DTOUT))
SET LEXIT=1
+14 IF X["^^"!(+($GET(LEXIT))>0)
KILL LEX
QUIT "^^"
+15 SET X=$SELECT(+Y>0:$$X(1,.LEX),1:-1)
+16 QUIT X
MUL(LEX,Y) ; Multiple Entries Found
+1 IF +($GET(LEXIT))>0
QUIT "^^"
NEW LEXE,LEXL,LEXMAX,LEXSS,LEXX,X
+2 SET (LEXMAX,LEXSS,LEXIT)=0
SET LEXL=+($GET(Y))
SET U="^"
IF +($GET(LEXL))'>0
SET LEXL=5
+3 SET LEXX=$ORDER(LEX(" "),-1)
SET LEXSS=0
+4 IF +LEXX=0
GOTO MULQ
WRITE !
IF +LEXX>1
WRITE !," ",LEXX," matches found"
+5 FOR LEXE=1:1:LEXX
IF ((LEXSS>0)&(LEXSS<(LEXE+1)))
QUIT
IF LEXIT
QUIT
Begin DoDot:1
+6 IF LEXE#LEXL=1
WRITE !
DO MULW
+7 SET LEXMAX=LEXE
IF LEXE#LEXL=0
WRITE !
+8 IF LEXE#LEXL=0
SET LEXSS=$$MULS(LEXMAX,LEXE,.LEX)
IF LEXSS["^"
SET LEXIT=1
End DoDot:1
IF LEXIT
QUIT
+9 IF LEXE#LEXL'=0
IF +LEXSS<=0
Begin DoDot:1
+10 WRITE !
SET LEXSS=$$MULS(LEXMAX,LEXE,.LEX)
IF LEXSS["^"
SET LEXIT=1
End DoDot:1
+11 GOTO MULQ
+12 QUIT X
MULW ; Write Multiple
+1 NEW LEXEX,LEXI,LEXSO,LEXNC,LEXT,LEXTX
SET LEXSO=$PIECE(LEX(+LEXE,0),"^",1)
+2 SET LEXNC=$PIECE(LEX(+LEXE,0),"^",3)
IF +LEXNC>0
SET LEXNC=" ("_LEXNC_")"
+3 SET LEXEX=$GET(LEX(+LEXE,"MENU"))
SET LEXTX(1)=LEXSO
+4 SET LEXTX(1)=LEXTX(1)_$SELECT($DATA(LEX(+LEXE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(LEXSO)))_" "_LEXEX_LEXNC
+5 DO PR(.LEXTX,60)
WRITE !,$JUSTIFY(LEXE,5),". ",$GET(LEXTX(1))
+6 FOR LEXI=2:1:5
SET LEXT=$GET(LEXTX(LEXI))
IF $LENGTH(LEXT)
WRITE !,$JUSTIFY(" ",19),LEXT
+7 QUIT
MULS(X,Y,LEX) ; Select from Multiple Entries
+1 NEW DIR,DIRB,LEXFI,LEXHLP,LEXLAST,LEXMAX,LEXS
+2 IF +($GET(LEXIT))>0
QUIT "^^"
SET LEXMAX=+($GET(X))
SET LEXLAST=+($GET(Y))
+3 IF LEXMAX=0
QUIT -1
SET LEXFI=$ORDER(LEX(0))
IF +LEXFI'>0
QUIT -1
+4 IF +($ORDER(LEX(+LEXLAST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_LEXMAX_": "
End DoDot:1
+7 IF +($ORDER(LEX(+LEXLAST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_LEXMAX_": "
End DoDot:1
+9 SET LEXHLP=" Answer must be from 1 to "
+10 SET LEXHLP=LEXHLP_LEXMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^LEX10DLS"
+13 SET DIR(0)="NAO^1:"_LEXMAX_":0"
DO ^DIR
+14 IF '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+15 IF X["^^"!($DATA(DTOUT))
SET LEXIT=1
SET X="^^"
IF X["^^"!(+($GET(LEXIT))>0)
QUIT "^^"
+16 KILL DIR
IF $DATA(DTOUT)!(X[U)
QUIT "^^"
+17 QUIT $SELECT(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
+1 IF $LENGTH($GET(LEXHLP))
WRITE !,$GET(LEXHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +LEXSS'>0
IF $GET(LEXSS)="^"
QUIT "^"
+2 SET X=-1
IF +($GET(LEXIT))'>0
SET X=$$X(+LEXSS,.LEX)
+3 QUIT X
X(X,LEX) ; Set X and Outpot Array
+1 NEW LEXEX,LEXFI,LEXIEN,LEXN,LEXNC,LEXNN,LEXRN,LEXS,LEXSO
+2 SET LEXS=+($GET(X))
SET LEXFI=$ORDER(LEX(0))
+3 SET LEXSO=$PIECE($GET(LEX(LEXS,0)),"^",1)
SET LEXEX=$GET(LEX(LEXS,"MENU"))
+4 SET LEXIEN=$SELECT($DATA(LEX(LEXS,"CAT")):"99:CAT;"_$PIECE($GET(LEX(LEXS,0)),"^"),1:$PIECE($GET(LEX(LEXS,"LEX",1)),"^")_";"_$PIECE($GET(LEX(LEXS,0)),"^"))
IF '$LENGTH(LEXSO)
QUIT "^"
+5 IF '$LENGTH(LEXEX)
QUIT "^"
IF +LEXIEN'>0
QUIT "^"
SET X=LEXIEN_"^"_LEXEX
+6 SET LEXNN="LEX("_+LEXS_")"
SET LEXNC="LEX("_+LEXS_","
+7 FOR
SET LEXNN=$QUERY(@LEXNN)
IF '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:1
+8 SET LEXRN="LEXN("_$PIECE(LEXNN,"(",2,299)
SET @LEXRN=@LEXNN
End DoDot:1
+9 KILL LEX
SET LEXNN="LEXN("_+LEXS_")"
SET LEXNC="LEXN("_+LEXS_","
+10 FOR
SET LEXNN=$QUERY(@LEXNN)
IF '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:1
+11 SET LEXRN="LEX("_$PIECE(LEXNN,"(",2,299)
SET @LEXRN=@LEXNN
End DoDot:1
+12 QUIT X
CONT(X,Y) ; Ask to Continue
+1 KILL DTOUT,DUOUT,DIRUT,DIROUT
NEW LEXX,LEXFQ,LEXW,LEXI,LEXC,DIR
+2 SET LEXX=$$UP^XLFSTR($GET(X))
SET LEXFQ=$GET(Y)
IF '$LENGTH(LEXX)
QUIT 1
IF LEXFQ'>0
QUIT 1
+3 SET LEXW(1)="Searching for """_LEXX_""" requires inspecting "
+4 SET LEXW(2)=LEXFQ_" records to determine if they match the "
+5 SET LEXW(3)="search criteria. This could take quite some time."
+6 SET LEXW(4)="Suggest refining the search by further specifying "
+7 SET LEXW(5)=""""_LEXX_"."""
+8 DO PR(.LEXW,60)
SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEXW(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+9 IF '$LENGTH($GET(LEXW(LEXI)))
QUIT
SET LEXC=LEXC+1
SET DIR("A",LEXC)=" "_$GET(LEXW(LEXI))
End DoDot:1
+10 IF LEXC>0
SET LEXC=LEXC+1
SET DIR("A",LEXC)=" "
+11 SET DIR("A")=" Do you wish to continue? (Y/N) "
SET DIR("B")="No"
+12 SET DIR(0)="YAO"
SET (DIR("?"),DIR("??"))="^D COH^LEX10DLS"
+13 SET DIR("PRE")="S:X[""?"" X=""??"""
WRITE !
DO ^DIR
+14 SET X=+Y
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
SET X="^"
+15 QUIT X
COH ; Continue Help
+1 IF $LENGTH($GET(LEXX))>0
Begin DoDot:1
+2 WRITE !," Enter To"
+3 WRITE !," 'Yes' continue searching for """,LEXX,"""."
+4 WRITE !," 'No' refine the search (further specify)"
+5 WRITE !," '^' discontinue the search and exit"
End DoDot:1
+6 IF '$LENGTH($GET(LEXX))>0
Begin DoDot:1
+7 WRITE !," Enter To"
+8 WRITE !," 'Yes' continue the search"
+9 WRITE !," 'No' refine the search (further specify)"
+10 WRITE !," '^' discontinue the search and exit"
End DoDot:1
+11 QUIT
+12 ;
+13 ; Miscellaneous
CL ; Clear
+1 KILL LEXIT
+2 QUIT
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
