- 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 Feb 18, 2025@23:23:48 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