HBHCLKU2 ;ALB/KG - DIAGNOSIS LOOK UP ;5/15/12
;;1.0;HOSPITAL BASED HOME CARE;**25**;NOV 01, 1993;Build 45
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;HBH*1.0*25 FEB 2012 K GUPTA Support for ICD-10 Coding System
;******************************************************************************
;******************************************************************************
;
; Input
;
; X Length of list to display (default 5)
; .HBHCSRL Local array passed by reference
;
; HBHCSRL() Input Array from ICDSRCH^LEX10CS
;
; HBHCSRL(0)=# found ^ Pruning Indicator
; HBHCSRL(1,0)=Code ^ Code IEN ^ date
; HBHCSRL(1,"IDL")=ICD-9/10 Description, Long
; HBHCSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; HBHCSRL(1,"IDS")=ICD-9/10 Description, Short
; HBHCSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; HBHCSRL(1,"LEX")=Lexicon Description
; HBHCSRL(1,"LEX",1)=Expression IEN ^ date
; HBHCSRL(1,"SYN",1)=Synonym #1
; HBHCSRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; HBHCSRL Local array passed by reference
;
; HBHCSRL(0)=Code ^ Code IEN ^ date
; HBHCSRL("IDL")=ICD-9/10 Description, Long
; HBHCSRL("IDL",1)=ICD-9/10 IEN ^ date
; HBHCSRL("IDS")=ICD-9/10 Description, Short
; HBHCSRL("IDS",1)=ICD-9/10 IEN ^ date
; HBHCSRL("LEX")=Lexicon Description
; HBHCSRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
; or -2 if "^" was entered
; or -3 if time out
;
SEL(HBHCSRL,X) ; Select from List
N HBHCGOUP S HBHCGOUP=0
S X=+($G(X))
S:X'>0 X=5
S X=$$ASK(.HBHCSRL,X)
I HBHCGOUP=1 Q -2
Q X
;
ASK(HBHCSRL,X) ; Ask for Selection
N DTOUT,DUOUT,DIROUT
N HBHCLIT,HBHCLL,HBHCLTOT
S HBHCLL=+($G(X))
S:HBHCLL'>0 HBHCLL=5
S HBHCLIT=0,HBHCLTOT=$O(HBHCSRL(" "),-1)
Q:+HBHCLTOT'>0 "^"
K X
S:+HBHCLTOT=1 X=$$ONE(HBHCLL,.HBHCSRL)
S:+HBHCLTOT>1 X=$$MUL(.HBHCSRL,HBHCLL)
Q:$D(DTOUT) -3 ;time out
Q:$D(DIROUT) -5 ;^^
Q:$D(DUOUT) -2 ;^
Q:+($G(X))'>0 -1 ;non-selection
Q X
ONE(X,HBHCSRL) ; One Entry Found
Q:+($G(HBHCLIT))>0 "^^"
N DIR,HBHCLC,HBHCLEX,HBHCLFI,HBHCLIT,HBHCLSO,HBHCLNC
N HBHCLSP,HBHCLTX,HBHCLC,Y
S HBHCLFI=$O(HBHCSRL(0)) Q:+HBHCLFI'>0 "^" S HBHCLSP=$J(" ",25)
S HBHCLSO=$P(HBHCSRL(1,0),"^",1),HBHCLNC=$P(HBHCSRL(1,0),"^",3)
S:+HBHCLNC>0 HBHCLNC=" ("_HBHCLNC_")" S HBHCLEX=$G(HBHCSRL(1,"MENU"))
S HBHCLC=$S($D(HBHCSRL(1,"CAT")):"-",1:"")
S HBHCLTX(1)=HBHCLSO_HBHCLC_$J(" ",(9-$L(HBHCLSO)))_" "_HBHCLEX_HBHCLNC
D PR(.HBHCLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(HBHCLTX(1)),HBHCLC=3 I $L($G(HBHCLTX(2))) D
. S HBHCLC=HBHCLC+1,DIR("A",HBHCLC)=HBHCLSP_$G(HBHCLTX(2))
S HBHCLC=HBHCLC+1,DIR("A",HBHCLC)=" ",HBHCLC=HBHCLC+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)) HBHCLIT=1
I X["^^"!(+($G(HBHCLIT))>0) K HBHCSRL Q "^^"
S X=$S(+Y>0:$$X(1,.HBHCSRL),1:-1)
Q X
MUL(HBHCSRL,Y) ; Multiple Entries Found
Q:+($G(HBHCLIT))>0 "^^"
N HBHCSRLE,HBHCLL,HBHCLMAX,HBHCLSS,HBHCLX,X
S (HBHCLMAX,HBHCLSS,HBHCLIT)=0,HBHCLL=+($G(Y)),U="^" S:+($G(HBHCLL))'>0 HBHCLL=5
S HBHCLX=$O(HBHCSRL(" "),-1),HBHCLSS=0
G:+HBHCLX=0 MULQ W ! W:+HBHCLX>1 !," ",HBHCLX," matches found"
F HBHCSRLE=1:1:HBHCLX Q:((HBHCLSS>0)&(HBHCLSS<(HBHCSRLE+1))) Q:HBHCLIT D Q:HBHCLIT
. W:HBHCSRLE#HBHCLL=1 ! D MULW
. S HBHCLMAX=HBHCSRLE W:HBHCSRLE#HBHCLL=0 !
. S:HBHCSRLE#HBHCLL=0 HBHCLSS=$$MULS(HBHCLMAX,HBHCSRLE,.HBHCSRL) S:HBHCLSS["^" HBHCLIT=1
I HBHCSRLE#HBHCLL'=0,+HBHCLSS<=0 D
. W ! S HBHCLSS=$$MULS(HBHCLMAX,HBHCSRLE,.HBHCSRL) S:HBHCLSS["^" HBHCLIT=1
G MULQ
Q X
MULW ; Write Multiple
N HBHCLEX,HBHCLI1,HBHCLSO,HBHCLNC,HBHCLT2,HBHCLTX S HBHCLSO=$P(HBHCSRL(+HBHCSRLE,0),"^",1)
S HBHCLNC=$P(HBHCSRL(+HBHCSRLE,0),"^",3) S:+HBHCLNC>0 HBHCLNC=" ("_HBHCLNC_")"
S HBHCLEX=$G(HBHCSRL(+HBHCSRLE,"MENU")),HBHCLTX(1)=HBHCLSO
S HBHCLTX(1)=HBHCLTX(1)_$S($D(HBHCSRL(+HBHCSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(HBHCLSO)))_" "_HBHCLEX_HBHCLNC
D PR(.HBHCLTX,60) W !,$J(HBHCSRLE,5),". ",$G(HBHCLTX(1))
F HBHCLI1=2:1:5 S HBHCLT2=$G(HBHCLTX(HBHCLI1)) W:$L(HBHCLT2) !,$J(" ",19),HBHCLT2
Q
MULS(X,Y,HBHCSRL) ; Select from Multiple Entries
N DIR,DIRB,HBHCLFI,HBHCLHLP,HBHCLLST,HBHCLMAX,HBHCLS1 ;@#$ not sure HBHCLS1 is neede here
Q:+($G(HBHCLIT))>0 "^^" S HBHCLMAX=+($G(X)),HBHCLLST=+($G(Y))
Q:HBHCLMAX=0 -1 S HBHCLFI=$O(HBHCSRL(0)) Q:+HBHCLFI'>0 -1
I +($O(HBHCSRL(+HBHCLLST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_HBHCLMAX_": "
I +($O(HBHCSRL(+HBHCLLST)))'>0 D
. S DIR("A")=" Select 1-"_HBHCLMAX_": "
S HBHCLHLP=" Answer must be from 1 to "
S HBHCLHLP=HBHCLHLP_HBHCLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^HBHCLKU2"
S DIR(0)="NAO^1:"_HBHCLMAX_":0" D ^DIR
S:X="^" HBHCGOUP=1
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) HBHCLIT=1,X="^^" I X["^^"!(+($G(HBHCLIT))>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(HBHCLHLP)) W !,$G(HBHCLHLP) Q
Q
MULQ ; Quit Multiple
I +HBHCLSS'>0,$G(HBHCLSS)="^" Q "^"
S X=-1 S:+($G(HBHCLIT))'>0 X=$$X(+HBHCLSS,.HBHCSRL)
Q X
X(X,HBHCSRL) ; Set X and Output Array
N HBHCLEX,HBHCSRFI,HBHCLIEN,HBHCLN1,HBHCLNC,HBHCLNN,HBHCLRN,HBHCLS1,HBHCLSO
S HBHCLS1=+($G(X))
S HBHCSRFI=$O(HBHCSRL(0)) ;@#$ not used?
S HBHCLSO=$P($G(HBHCSRL(HBHCLS1,0)),"^",1),HBHCLEX=$G(HBHCSRL(HBHCLS1,"MENU"))
S HBHCLIEN=$S($D(HBHCSRL(HBHCLS1,"CAT")):"99:CAT;"_$P($G(HBHCSRL(HBHCLS1,0)),"^"),1:$P($G(HBHCSRL(HBHCLS1,"IDS",1)),"^")_";"_$P($G(HBHCSRL(HBHCLS1,0)),"^")_";"_$P($G(HBHCSRL(HBHCLS1,"LEX",1)),"^")) Q:'$L(HBHCLSO) "^"
Q:'$L(HBHCLEX) "^" Q:+HBHCLIEN'>0 "^" S X=HBHCLIEN_"^"_HBHCLEX
S HBHCLNN="HBHCSRL("_+HBHCLS1_")",HBHCLNC="HBHCSRL("_+HBHCLS1_","
F S HBHCLNN=$Q(@HBHCLNN) Q:'$L(HBHCLNN)!(HBHCLNN'[HBHCLNC) D
. S HBHCLRN="HBHCLN1("_$P(HBHCLNN,"(",2,299) S @HBHCLRN=@HBHCLNN
K HBHCSRL S HBHCLNN="HBHCLN1("_+HBHCLS1_")",HBHCLNC="HBHCLN1("_+HBHCLS1_","
F S HBHCLNN=$Q(@HBHCLNN) Q:'$L(HBHCLNN)!(HBHCLNN'[HBHCLNC) D
. S HBHCLRN="HBHCSRL("_$P(HBHCLNN,"(",2,299),@HBHCLRN=@HBHCLNN
Q X
;
; Miscellaneous
CL ; Clear
K HBHCLIT
Q
PR(HBHCSRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,HBHCLC,HBHCLI1,HBHCLL
K ^UTILITY($J,"W")
Q:'$D(HBHCSRL)
S HBHCLL=+($G(X))
S:+HBHCLL'>0 HBHCLL=79
S HBHCLC=+($G(HBHCSRL))
S:+($G(HBHCLC))'>0 HBHCLC=$O(HBHCSRL(" "),-1)
Q:+HBHCLC'>0
S DIWL=1,DIWF="C"_+HBHCLL
S HBHCLI1=0
F S HBHCLI1=$O(HBHCSRL(HBHCLI1)) Q:+HBHCLI1=0 S X=$G(HBHCSRL(HBHCLI1)) D ^DIWP
K HBHCSRL
S (HBHCLC,HBHCLI1)=0
F S HBHCLI1=$O(^UTILITY($J,"W",1,HBHCLI1)) Q:+HBHCLI1=0 D
. S HBHCSRL(HBHCLI1)=$$TM($G(^UTILITY($J,"W",1,HBHCLI1,0))," "),HBHCLC=HBHCLC+1
S:$L(HBHCLC) HBHCSRL=HBHCLC
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCLKU2 8014 printed Dec 13, 2024@01:58:04 Page 2
HBHCLKU2 ;ALB/KG - DIAGNOSIS LOOK UP ;5/15/12
+1 ;;1.0;HOSPITAL BASED HOME CARE;**25**;NOV 01, 1993;Build 45
+2 ;******************************************************************************
+3 ;******************************************************************************
+4 ; --- ROUTINE MODIFICATION LOG ---
+5 ;
+6 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+7 ;----------- ---------- ----------- ----------------------------------------
+8 ;HBH*1.0*25 FEB 2012 K GUPTA Support for ICD-10 Coding System
+9 ;******************************************************************************
+10 ;******************************************************************************
+11 ;
+12 ; Input
+13 ;
+14 ; X Length of list to display (default 5)
+15 ; .HBHCSRL Local array passed by reference
+16 ;
+17 ; HBHCSRL() Input Array from ICDSRCH^LEX10CS
+18 ;
+19 ; HBHCSRL(0)=# found ^ Pruning Indicator
+20 ; HBHCSRL(1,0)=Code ^ Code IEN ^ date
+21 ; HBHCSRL(1,"IDL")=ICD-9/10 Description, Long
+22 ; HBHCSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+23 ; HBHCSRL(1,"IDS")=ICD-9/10 Description, Short
+24 ; HBHCSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+25 ; HBHCSRL(1,"LEX")=Lexicon Description
+26 ; HBHCSRL(1,"LEX",1)=Expression IEN ^ date
+27 ; HBHCSRL(1,"SYN",1)=Synonym #1
+28 ; HBHCSRL(1,"SYN",m)=Synonym #m
+29 ; ...
+30 ;
+31 ; Output
+32 ;
+33 ; $$SEL Two Piece "^" delimited string same as
+34 ; Fileman's Y output variable
+35 ;
+36 ; 1 Lexicon IEN
+37 ; 2 Lexicon Term
+38 ;
+39 ; HBHCSRL Local array passed by reference
+40 ;
+41 ; HBHCSRL(0)=Code ^ Code IEN ^ date
+42 ; HBHCSRL("IDL")=ICD-9/10 Description, Long
+43 ; HBHCSRL("IDL",1)=ICD-9/10 IEN ^ date
+44 ; HBHCSRL("IDS")=ICD-9/10 Description, Short
+45 ; HBHCSRL("IDS",1)=ICD-9/10 IEN ^ date
+46 ; HBHCSRL("LEX")=Lexicon Description
+47 ; HBHCSRL("LEX",1)=Expression IEN ^ date
+48 ;
+49 ; or ^ on error
+50 ; or -1 for non-selection
+51 ; or -2 if "^" was entered
+52 ; or -3 if time out
+53 ;
SEL(HBHCSRL,X) ; Select from List
+1 NEW HBHCGOUP
SET HBHCGOUP=0
+2 SET X=+($GET(X))
+3 if X'>0
SET X=5
+4 SET X=$$ASK(.HBHCSRL,X)
+5 IF HBHCGOUP=1
QUIT -2
+6 QUIT X
+7 ;
ASK(HBHCSRL,X) ; Ask for Selection
+1 NEW DTOUT,DUOUT,DIROUT
+2 NEW HBHCLIT,HBHCLL,HBHCLTOT
+3 SET HBHCLL=+($GET(X))
+4 if HBHCLL'>0
SET HBHCLL=5
+5 SET HBHCLIT=0
SET HBHCLTOT=$ORDER(HBHCSRL(" "),-1)
+6 if +HBHCLTOT'>0
QUIT "^"
+7 KILL X
+8 if +HBHCLTOT=1
SET X=$$ONE(HBHCLL,.HBHCSRL)
+9 if +HBHCLTOT>1
SET X=$$MUL(.HBHCSRL,HBHCLL)
+10 ;time out
if $DATA(DTOUT)
QUIT -3
+11 ;^^
if $DATA(DIROUT)
QUIT -5
+12 ;^
if $DATA(DUOUT)
QUIT -2
+13 ;non-selection
if +($GET(X))'>0
QUIT -1
+14 QUIT X
ONE(X,HBHCSRL) ; One Entry Found
+1 if +($GET(HBHCLIT))>0
QUIT "^^"
+2 NEW DIR,HBHCLC,HBHCLEX,HBHCLFI,HBHCLIT,HBHCLSO,HBHCLNC
+3 NEW HBHCLSP,HBHCLTX,HBHCLC,Y
+4 SET HBHCLFI=$ORDER(HBHCSRL(0))
if +HBHCLFI'>0
QUIT "^"
SET HBHCLSP=$JUSTIFY(" ",25)
+5 SET HBHCLSO=$PIECE(HBHCSRL(1,0),"^",1)
SET HBHCLNC=$PIECE(HBHCSRL(1,0),"^",3)
+6 if +HBHCLNC>0
SET HBHCLNC=" ("_HBHCLNC_")"
SET HBHCLEX=$GET(HBHCSRL(1,"MENU"))
+7 SET HBHCLC=$SELECT($DATA(HBHCSRL(1,"CAT")):"-",1:"")
+8 SET HBHCLTX(1)=HBHCLSO_HBHCLC_$JUSTIFY(" ",(9-$LENGTH(HBHCLSO)))_" "_HBHCLEX_HBHCLNC
+9 DO PR(.HBHCLTX,64)
SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+10 SET DIR("A",3)=" "_$GET(HBHCLTX(1))
SET HBHCLC=3
IF $LENGTH($GET(HBHCLTX(2)))
Begin DoDot:1
+11 SET HBHCLC=HBHCLC+1
SET DIR("A",HBHCLC)=HBHCLSP_$GET(HBHCLTX(2))
End DoDot:1
+12 SET HBHCLC=HBHCLC+1
SET DIR("A",HBHCLC)=" "
SET HBHCLC=HBHCLC+1
+13 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+14 DO ^DIR
if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+15 if X["^^"!($DATA(DTOUT))
SET HBHCLIT=1
+16 IF X["^^"!(+($GET(HBHCLIT))>0)
KILL HBHCSRL
QUIT "^^"
+17 SET X=$SELECT(+Y>0:$$X(1,.HBHCSRL),1:-1)
+18 QUIT X
MUL(HBHCSRL,Y) ; Multiple Entries Found
+1 if +($GET(HBHCLIT))>0
QUIT "^^"
+2 NEW HBHCSRLE,HBHCLL,HBHCLMAX,HBHCLSS,HBHCLX,X
+3 SET (HBHCLMAX,HBHCLSS,HBHCLIT)=0
SET HBHCLL=+($GET(Y))
SET U="^"
if +($GET(HBHCLL))'>0
SET HBHCLL=5
+4 SET HBHCLX=$ORDER(HBHCSRL(" "),-1)
SET HBHCLSS=0
+5 if +HBHCLX=0
GOTO MULQ
WRITE !
if +HBHCLX>1
WRITE !," ",HBHCLX," matches found"
+6 FOR HBHCSRLE=1:1:HBHCLX
if ((HBHCLSS>0)&(HBHCLSS<(HBHCSRLE+1)))
QUIT
if HBHCLIT
QUIT
Begin DoDot:1
+7 if HBHCSRLE#HBHCLL=1
WRITE !
DO MULW
+8 SET HBHCLMAX=HBHCSRLE
if HBHCSRLE#HBHCLL=0
WRITE !
+9 if HBHCSRLE#HBHCLL=0
SET HBHCLSS=$$MULS(HBHCLMAX,HBHCSRLE,.HBHCSRL)
if HBHCLSS["^"
SET HBHCLIT=1
End DoDot:1
if HBHCLIT
QUIT
+10 IF HBHCSRLE#HBHCLL'=0
IF +HBHCLSS<=0
Begin DoDot:1
+11 WRITE !
SET HBHCLSS=$$MULS(HBHCLMAX,HBHCSRLE,.HBHCSRL)
if HBHCLSS["^"
SET HBHCLIT=1
End DoDot:1
+12 GOTO MULQ
+13 QUIT X
MULW ; Write Multiple
+1 NEW HBHCLEX,HBHCLI1,HBHCLSO,HBHCLNC,HBHCLT2,HBHCLTX
SET HBHCLSO=$PIECE(HBHCSRL(+HBHCSRLE,0),"^",1)
+2 SET HBHCLNC=$PIECE(HBHCSRL(+HBHCSRLE,0),"^",3)
if +HBHCLNC>0
SET HBHCLNC=" ("_HBHCLNC_")"
+3 SET HBHCLEX=$GET(HBHCSRL(+HBHCSRLE,"MENU"))
SET HBHCLTX(1)=HBHCLSO
+4 SET HBHCLTX(1)=HBHCLTX(1)_$SELECT($DATA(HBHCSRL(+HBHCSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(HBHCLSO)))_" "_HBHCLEX_HBHCLNC
+5 DO PR(.HBHCLTX,60)
WRITE !,$JUSTIFY(HBHCSRLE,5),". ",$GET(HBHCLTX(1))
+6 FOR HBHCLI1=2:1:5
SET HBHCLT2=$GET(HBHCLTX(HBHCLI1))
if $LENGTH(HBHCLT2)
WRITE !,$JUSTIFY(" ",19),HBHCLT2
+7 QUIT
MULS(X,Y,HBHCSRL) ; Select from Multiple Entries
+1 ;@#$ not sure HBHCLS1 is neede here
NEW DIR,DIRB,HBHCLFI,HBHCLHLP,HBHCLLST,HBHCLMAX,HBHCLS1
+2 if +($GET(HBHCLIT))>0
QUIT "^^"
SET HBHCLMAX=+($GET(X))
SET HBHCLLST=+($GET(Y))
+3 if HBHCLMAX=0
QUIT -1
SET HBHCLFI=$ORDER(HBHCSRL(0))
if +HBHCLFI'>0
QUIT -1
+4 IF +($ORDER(HBHCSRL(+HBHCLLST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_HBHCLMAX_": "
End DoDot:1
+7 IF +($ORDER(HBHCSRL(+HBHCLLST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_HBHCLMAX_": "
End DoDot:1
+9 SET HBHCLHLP=" Answer must be from 1 to "
+10 SET HBHCLHLP=HBHCLHLP_HBHCLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^HBHCLKU2"
+13 SET DIR(0)="NAO^1:"_HBHCLMAX_":0"
DO ^DIR
+14 if X="^"
SET HBHCGOUP=1
+15 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+16 if X["^^"!($DATA(DTOUT))
SET HBHCLIT=1
SET X="^^"
IF X["^^"!(+($GET(HBHCLIT))>0)
QUIT "^^"
+17 KILL DIR
if $DATA(DTOUT)!(X[U)
QUIT "^^"
+18 QUIT $SELECT(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
+1 IF $LENGTH($GET(HBHCLHLP))
WRITE !,$GET(HBHCLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +HBHCLSS'>0
IF $GET(HBHCLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(HBHCLIT))'>0
SET X=$$X(+HBHCLSS,.HBHCSRL)
+3 QUIT X
X(X,HBHCSRL) ; Set X and Output Array
+1 NEW HBHCLEX,HBHCSRFI,HBHCLIEN,HBHCLN1,HBHCLNC,HBHCLNN,HBHCLRN,HBHCLS1,HBHCLSO
+2 SET HBHCLS1=+($GET(X))
+3 ;@#$ not used?
SET HBHCSRFI=$ORDER(HBHCSRL(0))
+4 SET HBHCLSO=$PIECE($GET(HBHCSRL(HBHCLS1,0)),"^",1)
SET HBHCLEX=$GET(HBHCSRL(HBHCLS1,"MENU"))
+5 SET HBHCLIEN=$SELECT($DATA(HBHCSRL(HBHCLS1,"CAT")):"99:CAT;"_$PIECE($GET(HBHCSRL(HBHCLS1,0)),"^"),1:$PIECE($GET(HBHCSRL(HBHCLS1,"IDS",1)),"^")_";"_$PIECE($GET(HBHCSRL(HBHCLS1,0)),"^")_";"_$PIECE($GET(HBHCSRL(HBHCLS1,"LEX",1)),"^"))
if '$LENGTH(HBHCLSO)
QUIT "^"
+6 if '$LENGTH(HBHCLEX)
QUIT "^"
if +HBHCLIEN'>0
QUIT "^"
SET X=HBHCLIEN_"^"_HBHCLEX
+7 SET HBHCLNN="HBHCSRL("_+HBHCLS1_")"
SET HBHCLNC="HBHCSRL("_+HBHCLS1_","
+8 FOR
SET HBHCLNN=$QUERY(@HBHCLNN)
if '$LENGTH(HBHCLNN)!(HBHCLNN'[HBHCLNC)
QUIT
Begin DoDot:1
+9 SET HBHCLRN="HBHCLN1("_$PIECE(HBHCLNN,"(",2,299)
SET @HBHCLRN=@HBHCLNN
End DoDot:1
+10 KILL HBHCSRL
SET HBHCLNN="HBHCLN1("_+HBHCLS1_")"
SET HBHCLNC="HBHCLN1("_+HBHCLS1_","
+11 FOR
SET HBHCLNN=$QUERY(@HBHCLNN)
if '$LENGTH(HBHCLNN)!(HBHCLNN'[HBHCLNC)
QUIT
Begin DoDot:1
+12 SET HBHCLRN="HBHCSRL("_$PIECE(HBHCLNN,"(",2,299)
SET @HBHCLRN=@HBHCLNN
End DoDot:1
+13 QUIT X
+14 ;
+15 ; Miscellaneous
CL ; Clear
+1 KILL HBHCLIT
+2 QUIT
PR(HBHCSRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,HBHCLC,HBHCLI1,HBHCLL
+2 KILL ^UTILITY($JOB,"W")
+3 if '$DATA(HBHCSRL)
QUIT
+4 SET HBHCLL=+($GET(X))
+5 if +HBHCLL'>0
SET HBHCLL=79
+6 SET HBHCLC=+($GET(HBHCSRL))
+7 if +($GET(HBHCLC))'>0
SET HBHCLC=$ORDER(HBHCSRL(" "),-1)
+8 if +HBHCLC'>0
QUIT
+9 SET DIWL=1
SET DIWF="C"_+HBHCLL
+10 SET HBHCLI1=0
+11 FOR
SET HBHCLI1=$ORDER(HBHCSRL(HBHCLI1))
if +HBHCLI1=0
QUIT
SET X=$GET(HBHCSRL(HBHCLI1))
DO ^DIWP
+12 KILL HBHCSRL
+13 SET (HBHCLC,HBHCLI1)=0
+14 FOR
SET HBHCLI1=$ORDER(^UTILITY($JOB,"W",1,HBHCLI1))
if +HBHCLI1=0
QUIT
Begin DoDot:1
+15 SET HBHCSRL(HBHCLI1)=$$TM($GET(^UTILITY($JOB,"W",1,HBHCLI1,0))," ")
SET HBHCLC=HBHCLC+1
End DoDot:1
+16 if $LENGTH(HBHCLC)
SET HBHCSRL=HBHCLC
+17 KILL ^UTILITY($JOB,"W")
+18 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
