IBDLXDG2 ;ALB/CFS - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;03/27/2012
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;Mar 27, 2012;Build 80
;
; Input
;
; X Length of list to display (default 5)
; .IBDSRL Local array passed by reference
;
; IBDSRL() Input Array from ICDSRCH^LEX10CS
;
; IBDSRL(0)=# found ^ Pruning Indicator
; IBDSRL(1,0)=Code ^ Code IEN ^ date
; IBDSRL(1,"IDL")=ICD-9/10 Description, Long
; IBDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; IBDSRL(1,"IDS")=ICD-9/10 Description, Short
; IBDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; IBDSRL(1,"LEX")=Lexicon Description
; IBDSRL(1,"LEX",1)=Expression IEN ^ date
; IBDSRL(1,"SYN",1)=Synonym #1
; IBDSRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; IBDSRL Local array passed by reference
;
; IBDSRL(0)=Code ^ Code IEN ^ date
; IBDSRL("IDL")=ICD-9/10 Description, Long
; IBDSRL("IDL",1)=ICD-9/10 IEN ^ date
; IBDSRL("IDS")=ICD-9/10 Description, Short
; IBDSRL("IDS",1)=ICD-9/10 IEN ^ date
; IBDSRL("LEX")=Lexicon Description
; IBDSRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
; or -2 if "^" was entered
;
SEL(IBDSRL,X) ; Select from List
N IBDGOUP S IBDGOUP=0
S X=+($G(X))
S:X'>0 X=5
S X=$$ASK(.IBDSRL,X)
I IBDGOUP=1 Q -2
Q X
;
ASK(IBDSRL,X) ; Ask for Selection
N DTOUT,DUOUT,DIROUT
N IBDLIT,IBDLL,IBDLTOT
S IBDLL=+($G(X))
S:IBDLL'>0 IBDLL=5
S IBDLIT=0,IBDLTOT=$O(IBDSRL(" "),-1)
Q:+IBDLTOT'>0 "^"
K X
S:+IBDLTOT=1 X=$$ONE(IBDLL,.IBDSRL)
S:+IBDLTOT>1 X=$$MUL(.IBDSRL,IBDLL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,IBDSRL) ; One Entry Found
Q:+($G(IBDLIT))>0 "^^"
N DIR,IBDLC,IBDLEX,IBDLFI,IBDLIT,IBDLSO,IBDLNC,IBDCNT1
N IBDLSP,IBDLTX,IBDLC,Y
S IBDLFI=$O(IBDSRL(0)) Q:+IBDLFI'>0 "^" S IBDLSP=$J(" ",11)
S IBDLSO=$P(IBDSRL(1,0),"^",1),IBDLNC=$P(IBDSRL(1,0),"^",3)
S:+IBDLNC>0 IBDLNC=" ("_IBDLNC_")" S IBDLEX=$G(IBDSRL(1,"MENU"))
S IBDLC=$S($D(IBDSRL(1,"CAT")):"-",1:"")
S IBDLTX(1)=IBDLSO_IBDLC_$J(" ",(9-$L(IBDLSO)))_" "_IBDLEX_IBDLNC
D PR(.IBDLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(IBDLTX(1))
S IBDLC=3
F IBDCNT1=2:1 Q:$G(IBDLTX(IBDCNT1))="" S IBDLC=IBDLC+1,DIR("A",IBDLC)=IBDLSP_$G(IBDLTX(IBDCNT1))
S IBDLC=IBDLC+1,DIR("A",IBDLC)=" ",IBDLC=IBDLC+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)) IBDLIT=1
I X["^^"!(+($G(IBDLIT))>0) K IBDSRL Q "^^"
S X=$S(+Y>0:$$X(1,.IBDSRL),1:-1)
Q X
MUL(IBDSRL,Y) ; Multiple Entries Found
Q:+($G(IBDLIT))>0 "^^"
N IBDSRLE,IBDLL,IBDLMAX,IBDLSS,IBDLX,X
S (IBDLMAX,IBDLSS,IBDLIT)=0,IBDLL=+($G(Y)),U="^" S:+($G(IBDLL))'>0 IBDLL=5
S IBDLX=$O(IBDSRL(" "),-1),IBDLSS=0
G:+IBDLX=0 MULQ W ! W:+IBDLX>1 !," ",IBDLX," matches found"
F IBDSRLE=1:1:IBDLX Q:((IBDLSS>0)&(IBDLSS<(IBDSRLE+1))) Q:IBDLIT D Q:IBDLIT
. W:IBDSRLE#IBDLL=1 ! D MULW
. S IBDLMAX=IBDSRLE W:IBDSRLE#IBDLL=0 !
. S:IBDSRLE#IBDLL=0 IBDLSS=$$MULS(IBDLMAX,IBDSRLE,.IBDSRL) S:IBDLSS["^" IBDLIT=1
I IBDSRLE#IBDLL'=0,+IBDLSS<=0 D
. W ! S IBDLSS=$$MULS(IBDLMAX,IBDSRLE,.IBDSRL) S:IBDLSS["^" IBDLIT=1
G MULQ
Q X
MULW ; Write Multiple
N IBDLEX,IBDLI1,IBDLSO,IBDLNC,IBDLT2,IBDLTX S IBDLSO=$P(IBDSRL(+IBDSRLE,0),"^",1)
S IBDLNC=$P(IBDSRL(+IBDSRLE,0),"^",3) S:+IBDLNC>0 IBDLNC=" ("_IBDLNC_")"
S IBDLEX=$G(IBDSRL(+IBDSRLE,"MENU")),IBDLTX(1)=IBDLSO
S IBDLTX(1)=IBDLTX(1)_$S($D(IBDSRL(+IBDSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(IBDLSO)))_" "_IBDLEX_IBDLNC
D PR(.IBDLTX,60) W !,$J(IBDSRLE,5),". ",$G(IBDLTX(1))
F IBDLI1=2:1:5 S IBDLT2=$G(IBDLTX(IBDLI1)) W:$L(IBDLT2) !,$J(" ",19),IBDLT2
Q
MULS(X,Y,IBDSRL) ; Select from Multiple Entries
N DIR,DIRB,IBDLFI,IBDLHLP,IBDLLST,IBDLMAX,IBDLS1
Q:+($G(IBDLIT))>0 "^^" S IBDLMAX=+($G(X)),IBDLLST=+($G(Y))
Q:IBDLMAX=0 -1 S IBDLFI=$O(IBDSRL(0)) Q:+IBDLFI'>0 -1
I +($O(IBDSRL(+IBDLLST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_IBDLMAX_": "
I +($O(IBDSRL(+IBDLLST)))'>0 D
. S DIR("A")=" Select 1-"_IBDLMAX_": "
S IBDLHLP=" Answer must be from 1 to "
S IBDLHLP=IBDLHLP_IBDLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^IBDLXDG2"
S DIR(0)="NAO^1:"_IBDLMAX_":0" D ^DIR
S:X="^" IBDGOUP=1
W:X="" @IOF ;clear the screen if the next page
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) IBDLIT=1,X="^^" I X["^^"!(+($G(IBDLIT))>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(IBDLHLP)) W !,$G(IBDLHLP) Q
Q
MULQ ; Quit Multiple
I +IBDLSS'>0,$G(IBDLSS)="^" Q "^"
S X=-1 S:+($G(IBDLIT))'>0 X=$$X(+IBDLSS,.IBDSRL)
Q X
X(X,IBDSRL) ; Set X and Output Array
N IBDLEX,IBDSRFI,IBDLIEN,IBDLN1,IBDLNC,IBDLNN,IBDLRN,IBDLS1,IBDLSO
S IBDLS1=+($G(X))
S IBDSRFI=$O(IBDSRL(0)) ;
S IBDLSO=$P($G(IBDSRL(IBDLS1,0)),"^",1),IBDLEX=$G(IBDSRL(IBDLS1,"MENU"))
;S IBDLIEN=$S($D(IBDSRL(IBDLS1,"CAT")):"99:CAT;"_$P($G(IBDSRL(IBDLS1,0)),"^"),1:$P($G(IBDSRL(IBDLS1,"LEX",1)),"^")_";"_$P($G(IBDSRL(IBDLS1,0)),"^")) Q:'$L(IBDLSO) "^"
S IBDLIEN=$S($D(IBDSRL(IBDLS1,"CAT")):"99:CAT;"_$P($G(IBDSRL(IBDLS1,0)),"^"),1:$P($G(IBDSRL(IBDLS1,"IDS",1)),"^")_";"_$P($G(IBDSRL(IBDLS1,0)),"^")_";"_$P($G(IBDSRL(IBDLS1,"LEX",1)),"^")) Q:'$L(IBDLSO) "^"
Q:'$L(IBDLEX) "^" Q:+IBDLIEN'>0 "^" S X=IBDLIEN_"^"_IBDLEX
S IBDLNN="IBDSRL("_+IBDLS1_")",IBDLNC="IBDSRL("_+IBDLS1_","
F S IBDLNN=$Q(@IBDLNN) Q:'$L(IBDLNN)!(IBDLNN'[IBDLNC) D
. S IBDLRN="IBDLN1("_$P(IBDLNN,"(",2,299) S @IBDLRN=@IBDLNN
K IBDSRL S IBDLNN="IBDLN1("_+IBDLS1_")",IBDLNC="IBDLN1("_+IBDLS1_","
F S IBDLNN=$Q(@IBDLNN) Q:'$L(IBDLNN)!(IBDLNN'[IBDLNC) D
. S IBDLRN="IBDSRL("_$P(IBDLNN,"(",2,299),@IBDLRN=@IBDLNN
Q X
;
; Miscellaneous
CL ; Clear
K IBDLIT
Q
PR(IBDSRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,IBDLC,IBDLI1,IBDLL
K ^UTILITY($J,"W")
Q:'$D(IBDSRL)
S IBDLL=+($G(X))
S:+IBDLL'>0 IBDLL=79
S IBDLC=+($G(IBDSRL))
S:+($G(IBDLC))'>0 IBDLC=$O(IBDSRL(" "),-1)
Q:+IBDLC'>0
S DIWL=1,DIWF="C"_+IBDLL
S IBDLI1=0
F S IBDLI1=$O(IBDSRL(IBDLI1)) Q:+IBDLI1=0 S X=$G(IBDSRL(IBDLI1)) D ^DIWP
K IBDSRL
S (IBDLC,IBDLI1)=0
F S IBDLI1=$O(^UTILITY($J,"W",1,IBDLI1)) Q:+IBDLI1=0 D
. S IBDSRL(IBDLI1)=$$TM($G(^UTILITY($J,"W",1,IBDLI1,0))," "),IBDLC=IBDLC+1
S:$L(IBDLC) IBDSRL=IBDLC
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[HIBDLXDG2 7250 printed Sep 23, 2025@20:30:03 Page 2
IBDLXDG2 ;ALB/CFS - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;03/27/2012
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;Mar 27, 2012;Build 80
+2 ;
+3 ; Input
+4 ;
+5 ; X Length of list to display (default 5)
+6 ; .IBDSRL Local array passed by reference
+7 ;
+8 ; IBDSRL() Input Array from ICDSRCH^LEX10CS
+9 ;
+10 ; IBDSRL(0)=# found ^ Pruning Indicator
+11 ; IBDSRL(1,0)=Code ^ Code IEN ^ date
+12 ; IBDSRL(1,"IDL")=ICD-9/10 Description, Long
+13 ; IBDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+14 ; IBDSRL(1,"IDS")=ICD-9/10 Description, Short
+15 ; IBDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+16 ; IBDSRL(1,"LEX")=Lexicon Description
+17 ; IBDSRL(1,"LEX",1)=Expression IEN ^ date
+18 ; IBDSRL(1,"SYN",1)=Synonym #1
+19 ; IBDSRL(1,"SYN",m)=Synonym #m
+20 ; ...
+21 ;
+22 ; Output
+23 ;
+24 ; $$SEL Two Piece "^" delimited string same as
+25 ; Fileman's Y output variable
+26 ;
+27 ; 1 Lexicon IEN
+28 ; 2 Lexicon Term
+29 ;
+30 ; IBDSRL Local array passed by reference
+31 ;
+32 ; IBDSRL(0)=Code ^ Code IEN ^ date
+33 ; IBDSRL("IDL")=ICD-9/10 Description, Long
+34 ; IBDSRL("IDL",1)=ICD-9/10 IEN ^ date
+35 ; IBDSRL("IDS")=ICD-9/10 Description, Short
+36 ; IBDSRL("IDS",1)=ICD-9/10 IEN ^ date
+37 ; IBDSRL("LEX")=Lexicon Description
+38 ; IBDSRL("LEX",1)=Expression IEN ^ date
+39 ;
+40 ; or ^ on error
+41 ; or -1 for non-selection
+42 ; or -2 if "^" was entered
+43 ;
SEL(IBDSRL,X) ; Select from List
+1 NEW IBDGOUP
SET IBDGOUP=0
+2 SET X=+($GET(X))
+3 if X'>0
SET X=5
+4 SET X=$$ASK(.IBDSRL,X)
+5 IF IBDGOUP=1
QUIT -2
+6 QUIT X
+7 ;
ASK(IBDSRL,X) ; Ask for Selection
+1 NEW DTOUT,DUOUT,DIROUT
+2 NEW IBDLIT,IBDLL,IBDLTOT
+3 SET IBDLL=+($GET(X))
+4 if IBDLL'>0
SET IBDLL=5
+5 SET IBDLIT=0
SET IBDLTOT=$ORDER(IBDSRL(" "),-1)
+6 if +IBDLTOT'>0
QUIT "^"
+7 KILL X
+8 if +IBDLTOT=1
SET X=$$ONE(IBDLL,.IBDSRL)
+9 if +IBDLTOT>1
SET X=$$MUL(.IBDSRL,IBDLL)
+10 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+11 QUIT X
ONE(X,IBDSRL) ; One Entry Found
+1 if +($GET(IBDLIT))>0
QUIT "^^"
+2 NEW DIR,IBDLC,IBDLEX,IBDLFI,IBDLIT,IBDLSO,IBDLNC,IBDCNT1
+3 NEW IBDLSP,IBDLTX,IBDLC,Y
+4 SET IBDLFI=$ORDER(IBDSRL(0))
if +IBDLFI'>0
QUIT "^"
SET IBDLSP=$JUSTIFY(" ",11)
+5 SET IBDLSO=$PIECE(IBDSRL(1,0),"^",1)
SET IBDLNC=$PIECE(IBDSRL(1,0),"^",3)
+6 if +IBDLNC>0
SET IBDLNC=" ("_IBDLNC_")"
SET IBDLEX=$GET(IBDSRL(1,"MENU"))
+7 SET IBDLC=$SELECT($DATA(IBDSRL(1,"CAT")):"-",1:"")
+8 SET IBDLTX(1)=IBDLSO_IBDLC_$JUSTIFY(" ",(9-$LENGTH(IBDLSO)))_" "_IBDLEX_IBDLNC
+9 DO PR(.IBDLTX,64)
SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+10 SET DIR("A",3)=" "_$GET(IBDLTX(1))
+11 SET IBDLC=3
+12 FOR IBDCNT1=2:1
if $GET(IBDLTX(IBDCNT1))=""
QUIT
SET IBDLC=IBDLC+1
SET DIR("A",IBDLC)=IBDLSP_$GET(IBDLTX(IBDCNT1))
+13 SET IBDLC=IBDLC+1
SET DIR("A",IBDLC)=" "
SET IBDLC=IBDLC+1
+14 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+15 DO ^DIR
if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+16 if X["^^"!($DATA(DTOUT))
SET IBDLIT=1
+17 IF X["^^"!(+($GET(IBDLIT))>0)
KILL IBDSRL
QUIT "^^"
+18 SET X=$SELECT(+Y>0:$$X(1,.IBDSRL),1:-1)
+19 QUIT X
MUL(IBDSRL,Y) ; Multiple Entries Found
+1 if +($GET(IBDLIT))>0
QUIT "^^"
+2 NEW IBDSRLE,IBDLL,IBDLMAX,IBDLSS,IBDLX,X
+3 SET (IBDLMAX,IBDLSS,IBDLIT)=0
SET IBDLL=+($GET(Y))
SET U="^"
if +($GET(IBDLL))'>0
SET IBDLL=5
+4 SET IBDLX=$ORDER(IBDSRL(" "),-1)
SET IBDLSS=0
+5 if +IBDLX=0
GOTO MULQ
WRITE !
if +IBDLX>1
WRITE !," ",IBDLX," matches found"
+6 FOR IBDSRLE=1:1:IBDLX
if ((IBDLSS>0)&(IBDLSS<(IBDSRLE+1)))
QUIT
if IBDLIT
QUIT
Begin DoDot:1
+7 if IBDSRLE#IBDLL=1
WRITE !
DO MULW
+8 SET IBDLMAX=IBDSRLE
if IBDSRLE#IBDLL=0
WRITE !
+9 if IBDSRLE#IBDLL=0
SET IBDLSS=$$MULS(IBDLMAX,IBDSRLE,.IBDSRL)
if IBDLSS["^"
SET IBDLIT=1
End DoDot:1
if IBDLIT
QUIT
+10 IF IBDSRLE#IBDLL'=0
IF +IBDLSS<=0
Begin DoDot:1
+11 WRITE !
SET IBDLSS=$$MULS(IBDLMAX,IBDSRLE,.IBDSRL)
if IBDLSS["^"
SET IBDLIT=1
End DoDot:1
+12 GOTO MULQ
+13 QUIT X
MULW ; Write Multiple
+1 NEW IBDLEX,IBDLI1,IBDLSO,IBDLNC,IBDLT2,IBDLTX
SET IBDLSO=$PIECE(IBDSRL(+IBDSRLE,0),"^",1)
+2 SET IBDLNC=$PIECE(IBDSRL(+IBDSRLE,0),"^",3)
if +IBDLNC>0
SET IBDLNC=" ("_IBDLNC_")"
+3 SET IBDLEX=$GET(IBDSRL(+IBDSRLE,"MENU"))
SET IBDLTX(1)=IBDLSO
+4 SET IBDLTX(1)=IBDLTX(1)_$SELECT($DATA(IBDSRL(+IBDSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(IBDLSO)))_" "_IBDLEX_IBDLNC
+5 DO PR(.IBDLTX,60)
WRITE !,$JUSTIFY(IBDSRLE,5),". ",$GET(IBDLTX(1))
+6 FOR IBDLI1=2:1:5
SET IBDLT2=$GET(IBDLTX(IBDLI1))
if $LENGTH(IBDLT2)
WRITE !,$JUSTIFY(" ",19),IBDLT2
+7 QUIT
MULS(X,Y,IBDSRL) ; Select from Multiple Entries
+1 NEW DIR,DIRB,IBDLFI,IBDLHLP,IBDLLST,IBDLMAX,IBDLS1
+2 if +($GET(IBDLIT))>0
QUIT "^^"
SET IBDLMAX=+($GET(X))
SET IBDLLST=+($GET(Y))
+3 if IBDLMAX=0
QUIT -1
SET IBDLFI=$ORDER(IBDSRL(0))
if +IBDLFI'>0
QUIT -1
+4 IF +($ORDER(IBDSRL(+IBDLLST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_IBDLMAX_": "
End DoDot:1
+7 IF +($ORDER(IBDSRL(+IBDLLST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_IBDLMAX_": "
End DoDot:1
+9 SET IBDLHLP=" Answer must be from 1 to "
+10 SET IBDLHLP=IBDLHLP_IBDLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^IBDLXDG2"
+13 SET DIR(0)="NAO^1:"_IBDLMAX_":0"
DO ^DIR
+14 if X="^"
SET IBDGOUP=1
+15 ;clear the screen if the next page
if X=""
WRITE @IOF
+16 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+17 if X["^^"!($DATA(DTOUT))
SET IBDLIT=1
SET X="^^"
IF X["^^"!(+($GET(IBDLIT))>0)
QUIT "^^"
+18 KILL DIR
if $DATA(DTOUT)!(X[U)
QUIT "^^"
+19 QUIT $SELECT(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
+1 IF $LENGTH($GET(IBDLHLP))
WRITE !,$GET(IBDLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +IBDLSS'>0
IF $GET(IBDLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(IBDLIT))'>0
SET X=$$X(+IBDLSS,.IBDSRL)
+3 QUIT X
X(X,IBDSRL) ; Set X and Output Array
+1 NEW IBDLEX,IBDSRFI,IBDLIEN,IBDLN1,IBDLNC,IBDLNN,IBDLRN,IBDLS1,IBDLSO
+2 SET IBDLS1=+($GET(X))
+3 ;
SET IBDSRFI=$ORDER(IBDSRL(0))
+4 SET IBDLSO=$PIECE($GET(IBDSRL(IBDLS1,0)),"^",1)
SET IBDLEX=$GET(IBDSRL(IBDLS1,"MENU"))
+5 ;S IBDLIEN=$S($D(IBDSRL(IBDLS1,"CAT")):"99:CAT;"_$P($G(IBDSRL(IBDLS1,0)),"^"),1:$P($G(IBDSRL(IBDLS1,"LEX",1)),"^")_";"_$P($G(IBDSRL(IBDLS1,0)),"^")) Q:'$L(IBDLSO) "^"
+6 SET IBDLIEN=$SELECT($DATA(IBDSRL(IBDLS1,"CAT")):"99:CAT;"_$PIECE($GET(IBDSRL(IBDLS1,0)),"^"),1:$PIECE($GET(IBDSRL(IBDLS1,"IDS",1)),"^")_";"_$PIECE($GET(IBDSRL(IBDLS1,0)),"^")_";"_$PIECE($GET(IBDSRL(IBDLS1,"LEX",1)),"^"))
if '$LENGTH(IBDLSO)
QUIT "^"
+7 if '$LENGTH(IBDLEX)
QUIT "^"
if +IBDLIEN'>0
QUIT "^"
SET X=IBDLIEN_"^"_IBDLEX
+8 SET IBDLNN="IBDSRL("_+IBDLS1_")"
SET IBDLNC="IBDSRL("_+IBDLS1_","
+9 FOR
SET IBDLNN=$QUERY(@IBDLNN)
if '$LENGTH(IBDLNN)!(IBDLNN'[IBDLNC)
QUIT
Begin DoDot:1
+10 SET IBDLRN="IBDLN1("_$PIECE(IBDLNN,"(",2,299)
SET @IBDLRN=@IBDLNN
End DoDot:1
+11 KILL IBDSRL
SET IBDLNN="IBDLN1("_+IBDLS1_")"
SET IBDLNC="IBDLN1("_+IBDLS1_","
+12 FOR
SET IBDLNN=$QUERY(@IBDLNN)
if '$LENGTH(IBDLNN)!(IBDLNN'[IBDLNC)
QUIT
Begin DoDot:1
+13 SET IBDLRN="IBDSRL("_$PIECE(IBDLNN,"(",2,299)
SET @IBDLRN=@IBDLNN
End DoDot:1
+14 QUIT X
+15 ;
+16 ; Miscellaneous
CL ; Clear
+1 KILL IBDLIT
+2 QUIT
PR(IBDSRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,IBDLC,IBDLI1,IBDLL
+2 KILL ^UTILITY($JOB,"W")
+3 if '$DATA(IBDSRL)
QUIT
+4 SET IBDLL=+($GET(X))
+5 if +IBDLL'>0
SET IBDLL=79
+6 SET IBDLC=+($GET(IBDSRL))
+7 if +($GET(IBDLC))'>0
SET IBDLC=$ORDER(IBDSRL(" "),-1)
+8 if +IBDLC'>0
QUIT
+9 SET DIWL=1
SET DIWF="C"_+IBDLL
+10 SET IBDLI1=0
+11 FOR
SET IBDLI1=$ORDER(IBDSRL(IBDLI1))
if +IBDLI1=0
QUIT
SET X=$GET(IBDSRL(IBDLI1))
DO ^DIWP
+12 KILL IBDSRL
+13 SET (IBDLC,IBDLI1)=0
+14 FOR
SET IBDLI1=$ORDER(^UTILITY($JOB,"W",1,IBDLI1))
if +IBDLI1=0
QUIT
Begin DoDot:1
+15 SET IBDSRL(IBDLI1)=$$TM($GET(^UTILITY($JOB,"W",1,IBDLI1,0))," ")
SET IBDLC=IBDLC+1
End DoDot:1
+16 if $LENGTH(IBDLC)
SET IBDSRL=IBDLC
+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
