FBASFL ;AISC/JLG - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;03/26/2012
;;3.5;FEE BASIS;**139**;JAN 30, 1995;Build 127
;;Per VA Directive 6402, this routine should not be modified.
;
; Input
;
; X Length of list to display (default 5)
; .FBSRL Local array passed by reference
;
; FBSRL() Input Array from ICDSRCH^LEX10CS
;
; FBSRL(0)=# found ^ Pruning Indicator
; FBSRL(1,0)=Code ^ Code IEN ^ date
; FBSRL(1,"IDL")=ICD-9/10 Description, Long
; FBSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; FBSRL(1,"IDS")=ICD-9/10 Description, Short
; FBSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; FBSRL(1,"LEX")=Lexicon Description
; FBSRL(1,"LEX",1)=Expression IEN ^ date
; FBSRL(1,"SYN",1)=Synonym #1
; FBSRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; FBSRL Local array passed by reference
;
; FBSRL(0)=Code ^ Code IEN ^ date
; FBSRL("IDL")=ICD-9/10 Description, Long
; FBSRL("IDL",1)=ICD-9/10 IEN ^ date
; FBSRL("IDS")=ICD-9/10 Description, Short
; FBSRL("IDS",1)=ICD-9/10 IEN ^ date
; FBSRL("LEX")=Lexicon Description
; FBSRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
; or -2 if "^" was entered
;
SEL(FBSRL,X) ; Select from List
N FBGOUP S FBGOUP=0
S X=+($G(X))
S:X'>0 X=5
S X=$$ASK(.FBSRL,X)
I FBGOUP=1 Q -2
Q X
;
ASK(FBSRL,X) ; Ask for Selection
N DTOUT,DUOUT,DIROUT
N FBLIT,FBLL,FBLTOT
S FBLL=+($G(X))
S:FBLL'>0 FBLL=5
S FBLIT=0,FBLTOT=$O(FBSRL(" "),-1)
Q:+FBLTOT'>0 "^"
K X
S:+FBLTOT=1 X=$$ONE(FBLL,.FBSRL)
S:+FBLTOT>1 X=$$MUL(.FBSRL,FBLL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,FBSRL) ; One Entry Found
Q:+($G(FBLIT))>0 "^^"
N DIR,FBLC,FBLEX,FBLFI,FBLIT,FBLSO,FBLNC,FBCNT1
N FBLSP,FBLTX,FBLC,Y
S FBLFI=$O(FBSRL(0)) Q:+FBLFI'>0 "^" S FBLSP=$J(" ",11)
S FBLSO=$P(FBSRL(1,0),"^",1),FBLNC=$P(FBSRL(1,0),"^",3)
S:+FBLNC>0 FBLNC=" ("_FBLNC_")" S FBLEX=$G(FBSRL(1,"MENU"))
S FBLC=$S($D(FBSRL(1,"CAT")):"-",1:"")
S FBLTX(1)=FBLSO_FBLC_$J(" ",(9-$L(FBLSO)))_" "_FBLEX_FBLNC
D PR(.FBLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(FBLTX(1))
S FBLC=3
F FBCNT1=2:1 Q:$G(FBLTX(FBCNT1))="" S FBLC=FBLC+1,DIR("A",FBLC)=FBLSP_$G(FBLTX(FBCNT1))
S FBLC=FBLC+1,DIR("A",FBLC)=" ",FBLC=FBLC+1
S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
S Y=1 ; DEFAULTS TO YES FOR PRECEDING PROMPT.
S:X["^^"!($D(DTOUT)) FBLIT=1
I X["^^"!(+($G(FBLIT))>0) K FBSRL Q "^^"
S X=$S(+Y>0:$$X(1,.FBSRL),1:-1)
Q X
MUL(FBSRL,Y) ; Multiple Entries Found
Q:+($G(FBLIT))>0 "^^"
N FBSRLE,FBLL,FBLMAX,FBLSS,FBLX,X
S (FBLMAX,FBLSS,FBLIT)=0,FBLL=+($G(Y)),U="^" S:+($G(FBLL))'>0 FBLL=5
S FBLX=$O(FBSRL(" "),-1),FBLSS=0
G:+FBLX=0 MULQ W ! W:+FBLX>1 !," ",FBLX," matches found"
F FBSRLE=1:1:FBLX Q:((FBLSS>0)&(FBLSS<(FBSRLE+1))) Q:FBLIT D Q:FBLIT
. W:FBSRLE#FBLL=1 ! D MULW
. S FBLMAX=FBSRLE W:FBSRLE#FBLL=0 !
. S:FBSRLE#FBLL=0 FBLSS=$$MULS(FBLMAX,FBSRLE,.FBSRL) S:FBLSS["^" FBLIT=1
I FBSRLE#FBLL'=0,+FBLSS<=0 D
. W ! S FBLSS=$$MULS(FBLMAX,FBSRLE,.FBSRL) S:FBLSS["^" FBLIT=1
G MULQ
Q X
MULW ; Write Multiple
N FBLEX,FBLI1,FBLSO,FBLNC,FBLT2,FBLTX S FBLSO=$P(FBSRL(+FBSRLE,0),"^",1)
S FBLNC=$P(FBSRL(+FBSRLE,0),"^",3) S:+FBLNC>0 FBLNC=" ("_FBLNC_")"
S FBLEX=$G(FBSRL(+FBSRLE,"MENU")),FBLTX(1)=FBLSO
S FBLTX(1)=FBLTX(1)_$S($D(FBSRL(+FBSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(FBLSO)))_" "_FBLEX_FBLNC
D PR(.FBLTX,60) W !,$J(FBSRLE,5),". ",$G(FBLTX(1))
F FBLI1=2:1:5 S FBLT2=$G(FBLTX(FBLI1)) W:$L(FBLT2) !,$J(" ",19),FBLT2
Q
MULS(X,Y,FBSRL) ; Select from Multiple Entries
N DIR,DIRB,FBLFI,FBLHLP,FBLLST,FBLMAX,FBLS1 ;@#$ not sure FBLS1 is neede here
Q:+($G(FBLIT))>0 "^^" S FBLMAX=+($G(X)),FBLLST=+($G(Y))
Q:FBLMAX=0 -1 S FBLFI=$O(FBSRL(0)) Q:+FBLFI'>0 -1
I +($O(FBSRL(+FBLLST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_FBLMAX_": "
I +($O(FBSRL(+FBLLST)))'>0 D
. S DIR("A")=" Select 1-"_FBLMAX_": "
S FBLHLP=" Answer must be from 1 to "
S FBLHLP=FBLHLP_FBLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^FBASFL"
S DIR(0)="NAO^1:"_FBLMAX_":0" D ^DIR
S:X="^" FBGOUP=1
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) FBLIT=1,X="^^" I X["^^"!(+($G(FBLIT))>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(FBLHLP)) W !,$G(FBLHLP) Q
Q
MULQ ; Quit Multiple
I +FBLSS'>0,$G(FBLSS)="^" Q "^"
S X=-1 S:+($G(FBLIT))'>0 X=$$X(+FBLSS,.FBSRL)
Q X
X(X,FBSRL) ; Set X and Output Array
N FBLEX,FBSRFI,FBLIEN,FBLN1,FBLNC,FBLNN,FBLRN,FBLS1,FBLSO
S FBLS1=+($G(X))
S FBSRFI=$O(FBSRL(0)) ;@#$ not used?
S FBLSO=$P($G(FBSRL(FBLS1,0)),"^",1),FBLEX=$G(FBSRL(FBLS1,"MENU"))
S FBLIEN=$S($D(FBSRL(FBLS1,"CAT")):"99:CAT;"_$P($G(FBSRL(FBLS1,0)),"^"),1:$P($G(FBSRL(FBLS1,"IDS",1)),"^")_";"_$P($G(FBSRL(FBLS1,0)),"^")_";"_$P($G(FBSRL(FBLS1,"LEX",1)),"^")) Q:'$L(FBLSO) "^"
Q:'$L(FBLEX) "^" Q:+FBLIEN'>0 "^" S X=FBLIEN_"^"_FBLEX
S FBLNN="FBSRL("_+FBLS1_")",FBLNC="FBSRL("_+FBLS1_","
F S FBLNN=$Q(@FBLNN) Q:'$L(FBLNN)!(FBLNN'[FBLNC) D
. S FBLRN="FBLN1("_$P(FBLNN,"(",2,299) S @FBLRN=@FBLNN
K FBSRL S FBLNN="FBLN1("_+FBLS1_")",FBLNC="FBLN1("_+FBLS1_","
F S FBLNN=$Q(@FBLNN) Q:'$L(FBLNN)!(FBLNN'[FBLNC) D
. S FBLRN="FBSRL("_$P(FBLNN,"(",2,299),@FBLRN=@FBLNN
Q X
;
; Miscellaneous
CL ; Clear
K FBLIT
Q
PR(FBSRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,FBLC,FBLI1,FBLL
K ^UTILITY($J,"W")
Q:'$D(FBSRL)
S FBLL=+($G(X))
S:+FBLL'>0 FBLL=79
S FBLC=+($G(FBSRL))
S:+($G(FBLC))'>0 FBLC=$O(FBSRL(" "),-1)
Q:+FBLC'>0
S DIWL=1,DIWF="C"_+FBLL
S FBLI1=0
F S FBLI1=$O(FBSRL(FBLI1)) Q:+FBLI1=0 S X=$G(FBSRL(FBLI1)) D ^DIWP
K FBSRL
S (FBLC,FBLI1)=0
F S FBLI1=$O(^UTILITY($J,"W",1,FBLI1)) Q:+FBLI1=0 D
. S FBSRL(FBLI1)=$$TM($G(^UTILITY($J,"W",1,FBLI1,0))," "),FBLC=FBLC+1
S:$L(FBLC) FBSRL=FBLC
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[HFBASFL 6785 printed Sep 23, 2025@19:33:27 Page 2
FBASFL ;AISC/JLG - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;03/26/2012
+1 ;;3.5;FEE BASIS;**139**;JAN 30, 1995;Build 127
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Input
+5 ;
+6 ; X Length of list to display (default 5)
+7 ; .FBSRL Local array passed by reference
+8 ;
+9 ; FBSRL() Input Array from ICDSRCH^LEX10CS
+10 ;
+11 ; FBSRL(0)=# found ^ Pruning Indicator
+12 ; FBSRL(1,0)=Code ^ Code IEN ^ date
+13 ; FBSRL(1,"IDL")=ICD-9/10 Description, Long
+14 ; FBSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+15 ; FBSRL(1,"IDS")=ICD-9/10 Description, Short
+16 ; FBSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+17 ; FBSRL(1,"LEX")=Lexicon Description
+18 ; FBSRL(1,"LEX",1)=Expression IEN ^ date
+19 ; FBSRL(1,"SYN",1)=Synonym #1
+20 ; FBSRL(1,"SYN",m)=Synonym #m
+21 ; ...
+22 ;
+23 ; Output
+24 ;
+25 ; $$SEL Two Piece "^" delimited string same as
+26 ; Fileman's Y output variable
+27 ;
+28 ; 1 Lexicon IEN
+29 ; 2 Lexicon Term
+30 ;
+31 ; FBSRL Local array passed by reference
+32 ;
+33 ; FBSRL(0)=Code ^ Code IEN ^ date
+34 ; FBSRL("IDL")=ICD-9/10 Description, Long
+35 ; FBSRL("IDL",1)=ICD-9/10 IEN ^ date
+36 ; FBSRL("IDS")=ICD-9/10 Description, Short
+37 ; FBSRL("IDS",1)=ICD-9/10 IEN ^ date
+38 ; FBSRL("LEX")=Lexicon Description
+39 ; FBSRL("LEX",1)=Expression IEN ^ date
+40 ;
+41 ; or ^ on error
+42 ; or -1 for non-selection
+43 ; or -2 if "^" was entered
+44 ;
SEL(FBSRL,X) ; Select from List
+1 NEW FBGOUP
SET FBGOUP=0
+2 SET X=+($GET(X))
+3 if X'>0
SET X=5
+4 SET X=$$ASK(.FBSRL,X)
+5 IF FBGOUP=1
QUIT -2
+6 QUIT X
+7 ;
ASK(FBSRL,X) ; Ask for Selection
+1 NEW DTOUT,DUOUT,DIROUT
+2 NEW FBLIT,FBLL,FBLTOT
+3 SET FBLL=+($GET(X))
+4 if FBLL'>0
SET FBLL=5
+5 SET FBLIT=0
SET FBLTOT=$ORDER(FBSRL(" "),-1)
+6 if +FBLTOT'>0
QUIT "^"
+7 KILL X
+8 if +FBLTOT=1
SET X=$$ONE(FBLL,.FBSRL)
+9 if +FBLTOT>1
SET X=$$MUL(.FBSRL,FBLL)
+10 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+11 QUIT X
ONE(X,FBSRL) ; One Entry Found
+1 if +($GET(FBLIT))>0
QUIT "^^"
+2 NEW DIR,FBLC,FBLEX,FBLFI,FBLIT,FBLSO,FBLNC,FBCNT1
+3 NEW FBLSP,FBLTX,FBLC,Y
+4 SET FBLFI=$ORDER(FBSRL(0))
if +FBLFI'>0
QUIT "^"
SET FBLSP=$JUSTIFY(" ",11)
+5 SET FBLSO=$PIECE(FBSRL(1,0),"^",1)
SET FBLNC=$PIECE(FBSRL(1,0),"^",3)
+6 if +FBLNC>0
SET FBLNC=" ("_FBLNC_")"
SET FBLEX=$GET(FBSRL(1,"MENU"))
+7 SET FBLC=$SELECT($DATA(FBSRL(1,"CAT")):"-",1:"")
+8 SET FBLTX(1)=FBLSO_FBLC_$JUSTIFY(" ",(9-$LENGTH(FBLSO)))_" "_FBLEX_FBLNC
+9 DO PR(.FBLTX,64)
SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+10 SET DIR("A",3)=" "_$GET(FBLTX(1))
+11 SET FBLC=3
+12 FOR FBCNT1=2:1
if $GET(FBLTX(FBCNT1))=""
QUIT
SET FBLC=FBLC+1
SET DIR("A",FBLC)=FBLSP_$GET(FBLTX(FBCNT1))
+13 SET FBLC=FBLC+1
SET DIR("A",FBLC)=" "
SET FBLC=FBLC+1
+14 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+15 ; DEFAULTS TO YES FOR PRECEDING PROMPT.
SET Y=1
+16 if X["^^"!($DATA(DTOUT))
SET FBLIT=1
+17 IF X["^^"!(+($GET(FBLIT))>0)
KILL FBSRL
QUIT "^^"
+18 SET X=$SELECT(+Y>0:$$X(1,.FBSRL),1:-1)
+19 QUIT X
MUL(FBSRL,Y) ; Multiple Entries Found
+1 if +($GET(FBLIT))>0
QUIT "^^"
+2 NEW FBSRLE,FBLL,FBLMAX,FBLSS,FBLX,X
+3 SET (FBLMAX,FBLSS,FBLIT)=0
SET FBLL=+($GET(Y))
SET U="^"
if +($GET(FBLL))'>0
SET FBLL=5
+4 SET FBLX=$ORDER(FBSRL(" "),-1)
SET FBLSS=0
+5 if +FBLX=0
GOTO MULQ
WRITE !
if +FBLX>1
WRITE !," ",FBLX," matches found"
+6 FOR FBSRLE=1:1:FBLX
if ((FBLSS>0)&(FBLSS<(FBSRLE+1)))
QUIT
if FBLIT
QUIT
Begin DoDot:1
+7 if FBSRLE#FBLL=1
WRITE !
DO MULW
+8 SET FBLMAX=FBSRLE
if FBSRLE#FBLL=0
WRITE !
+9 if FBSRLE#FBLL=0
SET FBLSS=$$MULS(FBLMAX,FBSRLE,.FBSRL)
if FBLSS["^"
SET FBLIT=1
End DoDot:1
if FBLIT
QUIT
+10 IF FBSRLE#FBLL'=0
IF +FBLSS<=0
Begin DoDot:1
+11 WRITE !
SET FBLSS=$$MULS(FBLMAX,FBSRLE,.FBSRL)
if FBLSS["^"
SET FBLIT=1
End DoDot:1
+12 GOTO MULQ
+13 QUIT X
MULW ; Write Multiple
+1 NEW FBLEX,FBLI1,FBLSO,FBLNC,FBLT2,FBLTX
SET FBLSO=$PIECE(FBSRL(+FBSRLE,0),"^",1)
+2 SET FBLNC=$PIECE(FBSRL(+FBSRLE,0),"^",3)
if +FBLNC>0
SET FBLNC=" ("_FBLNC_")"
+3 SET FBLEX=$GET(FBSRL(+FBSRLE,"MENU"))
SET FBLTX(1)=FBLSO
+4 SET FBLTX(1)=FBLTX(1)_$SELECT($DATA(FBSRL(+FBSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(FBLSO)))_" "_FBLEX_FBLNC
+5 DO PR(.FBLTX,60)
WRITE !,$JUSTIFY(FBSRLE,5),". ",$GET(FBLTX(1))
+6 FOR FBLI1=2:1:5
SET FBLT2=$GET(FBLTX(FBLI1))
if $LENGTH(FBLT2)
WRITE !,$JUSTIFY(" ",19),FBLT2
+7 QUIT
MULS(X,Y,FBSRL) ; Select from Multiple Entries
+1 ;@#$ not sure FBLS1 is neede here
NEW DIR,DIRB,FBLFI,FBLHLP,FBLLST,FBLMAX,FBLS1
+2 if +($GET(FBLIT))>0
QUIT "^^"
SET FBLMAX=+($GET(X))
SET FBLLST=+($GET(Y))
+3 if FBLMAX=0
QUIT -1
SET FBLFI=$ORDER(FBSRL(0))
if +FBLFI'>0
QUIT -1
+4 IF +($ORDER(FBSRL(+FBLLST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_FBLMAX_": "
End DoDot:1
+7 IF +($ORDER(FBSRL(+FBLLST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_FBLMAX_": "
End DoDot:1
+9 SET FBLHLP=" Answer must be from 1 to "
+10 SET FBLHLP=FBLHLP_FBLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^FBASFL"
+13 SET DIR(0)="NAO^1:"_FBLMAX_":0"
DO ^DIR
+14 if X="^"
SET FBGOUP=1
+15 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+16 if X["^^"!($DATA(DTOUT))
SET FBLIT=1
SET X="^^"
IF X["^^"!(+($GET(FBLIT))>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(FBLHLP))
WRITE !,$GET(FBLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +FBLSS'>0
IF $GET(FBLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(FBLIT))'>0
SET X=$$X(+FBLSS,.FBSRL)
+3 QUIT X
X(X,FBSRL) ; Set X and Output Array
+1 NEW FBLEX,FBSRFI,FBLIEN,FBLN1,FBLNC,FBLNN,FBLRN,FBLS1,FBLSO
+2 SET FBLS1=+($GET(X))
+3 ;@#$ not used?
SET FBSRFI=$ORDER(FBSRL(0))
+4 SET FBLSO=$PIECE($GET(FBSRL(FBLS1,0)),"^",1)
SET FBLEX=$GET(FBSRL(FBLS1,"MENU"))
+5 SET FBLIEN=$SELECT($DATA(FBSRL(FBLS1,"CAT")):"99:CAT;"_$PIECE($GET(FBSRL(FBLS1,0)),"^"),1:$PIECE($GET(FBSRL(FBLS1,"IDS",1)),"^")_";"_$PIECE($GET(FBSRL(FBLS1,0)),"^")_";"_$PIECE($GET(FBSRL(FBLS1,"LEX",1)),"^"))
if '$LENGTH(FBLSO)
QUIT "^"
+6 if '$LENGTH(FBLEX)
QUIT "^"
if +FBLIEN'>0
QUIT "^"
SET X=FBLIEN_"^"_FBLEX
+7 SET FBLNN="FBSRL("_+FBLS1_")"
SET FBLNC="FBSRL("_+FBLS1_","
+8 FOR
SET FBLNN=$QUERY(@FBLNN)
if '$LENGTH(FBLNN)!(FBLNN'[FBLNC)
QUIT
Begin DoDot:1
+9 SET FBLRN="FBLN1("_$PIECE(FBLNN,"(",2,299)
SET @FBLRN=@FBLNN
End DoDot:1
+10 KILL FBSRL
SET FBLNN="FBLN1("_+FBLS1_")"
SET FBLNC="FBLN1("_+FBLS1_","
+11 FOR
SET FBLNN=$QUERY(@FBLNN)
if '$LENGTH(FBLNN)!(FBLNN'[FBLNC)
QUIT
Begin DoDot:1
+12 SET FBLRN="FBSRL("_$PIECE(FBLNN,"(",2,299)
SET @FBLRN=@FBLNN
End DoDot:1
+13 QUIT X
+14 ;
+15 ; Miscellaneous
CL ; Clear
+1 KILL FBLIT
+2 QUIT
PR(FBSRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,FBLC,FBLI1,FBLL
+2 KILL ^UTILITY($JOB,"W")
+3 if '$DATA(FBSRL)
QUIT
+4 SET FBLL=+($GET(X))
+5 if +FBLL'>0
SET FBLL=79
+6 SET FBLC=+($GET(FBSRL))
+7 if +($GET(FBLC))'>0
SET FBLC=$ORDER(FBSRL(" "),-1)
+8 if +FBLC'>0
QUIT
+9 SET DIWL=1
SET DIWF="C"_+FBLL
+10 SET FBLI1=0
+11 FOR
SET FBLI1=$ORDER(FBSRL(FBLI1))
if +FBLI1=0
QUIT
SET X=$GET(FBSRL(FBLI1))
DO ^DIWP
+12 KILL FBSRL
+13 SET (FBLC,FBLI1)=0
+14 FOR
SET FBLI1=$ORDER(^UTILITY($JOB,"W",1,FBLI1))
if +FBLI1=0
QUIT
Begin DoDot:1
+15 SET FBSRL(FBLI1)=$$TM($GET(^UTILITY($JOB,"W",1,FBLI1,0))," ")
SET FBLC=FBLC+1
End DoDot:1
+16 if $LENGTH(FBLC)
SET FBSRL=FBLC
+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
