Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBASFL

FBASFL.m

Go to the documentation of this file.
  1. FBASFL ;AISC/JLG - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;03/26/2012
  1. ;;3.5;FEE BASIS;**139**;JAN 30, 1995;Build 127
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Input
  1. ;
  1. ; X Length of list to display (default 5)
  1. ; .FBSRL Local array passed by reference
  1. ;
  1. ; FBSRL() Input Array from ICDSRCH^LEX10CS
  1. ;
  1. ; FBSRL(0)=# found ^ Pruning Indicator
  1. ; FBSRL(1,0)=Code ^ Code IEN ^ date
  1. ; FBSRL(1,"IDL")=ICD-9/10 Description, Long
  1. ; FBSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
  1. ; FBSRL(1,"IDS")=ICD-9/10 Description, Short
  1. ; FBSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
  1. ; FBSRL(1,"LEX")=Lexicon Description
  1. ; FBSRL(1,"LEX",1)=Expression IEN ^ date
  1. ; FBSRL(1,"SYN",1)=Synonym #1
  1. ; FBSRL(1,"SYN",m)=Synonym #m
  1. ; ...
  1. ;
  1. ; Output
  1. ;
  1. ; $$SEL Two Piece "^" delimited string same as
  1. ; Fileman's Y output variable
  1. ;
  1. ; 1 Lexicon IEN
  1. ; 2 Lexicon Term
  1. ;
  1. ; FBSRL Local array passed by reference
  1. ;
  1. ; FBSRL(0)=Code ^ Code IEN ^ date
  1. ; FBSRL("IDL")=ICD-9/10 Description, Long
  1. ; FBSRL("IDL",1)=ICD-9/10 IEN ^ date
  1. ; FBSRL("IDS")=ICD-9/10 Description, Short
  1. ; FBSRL("IDS",1)=ICD-9/10 IEN ^ date
  1. ; FBSRL("LEX")=Lexicon Description
  1. ; FBSRL("LEX",1)=Expression IEN ^ date
  1. ;
  1. ; or ^ on error
  1. ; or -1 for non-selection
  1. ; or -2 if "^" was entered
  1. ;
  1. SEL(FBSRL,X) ; Select from List
  1. N FBGOUP S FBGOUP=0
  1. S X=+($G(X))
  1. S:X'>0 X=5
  1. S X=$$ASK(.FBSRL,X)
  1. I FBGOUP=1 Q -2
  1. Q X
  1. ;
  1. ASK(FBSRL,X) ; Ask for Selection
  1. N DTOUT,DUOUT,DIROUT
  1. N FBLIT,FBLL,FBLTOT
  1. S FBLL=+($G(X))
  1. S:FBLL'>0 FBLL=5
  1. S FBLIT=0,FBLTOT=$O(FBSRL(" "),-1)
  1. Q:+FBLTOT'>0 "^"
  1. K X
  1. S:+FBLTOT=1 X=$$ONE(FBLL,.FBSRL)
  1. S:+FBLTOT>1 X=$$MUL(.FBSRL,FBLL)
  1. S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
  1. Q X
  1. ONE(X,FBSRL) ; One Entry Found
  1. Q:+($G(FBLIT))>0 "^^"
  1. N DIR,FBLC,FBLEX,FBLFI,FBLIT,FBLSO,FBLNC,FBCNT1
  1. N FBLSP,FBLTX,FBLC,Y
  1. S FBLFI=$O(FBSRL(0)) Q:+FBLFI'>0 "^" S FBLSP=$J(" ",11)
  1. S FBLSO=$P(FBSRL(1,0),"^",1),FBLNC=$P(FBSRL(1,0),"^",3)
  1. S:+FBLNC>0 FBLNC=" ("_FBLNC_")" S FBLEX=$G(FBSRL(1,"MENU"))
  1. S FBLC=$S($D(FBSRL(1,"CAT")):"-",1:"")
  1. S FBLTX(1)=FBLSO_FBLC_$J(" ",(9-$L(FBLSO)))_" "_FBLEX_FBLNC
  1. D PR(.FBLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
  1. S DIR("A",3)=" "_$G(FBLTX(1))
  1. S FBLC=3
  1. F FBCNT1=2:1 Q:$G(FBLTX(FBCNT1))="" S FBLC=FBLC+1,DIR("A",FBLC)=FBLSP_$G(FBLTX(FBCNT1))
  1. S FBLC=FBLC+1,DIR("A",FBLC)=" ",FBLC=FBLC+1
  1. S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
  1. S Y=1 ; DEFAULTS TO YES FOR PRECEDING PROMPT.
  1. S:X["^^"!($D(DTOUT)) FBLIT=1
  1. I X["^^"!(+($G(FBLIT))>0) K FBSRL Q "^^"
  1. S X=$S(+Y>0:$$X(1,.FBSRL),1:-1)
  1. Q X
  1. MUL(FBSRL,Y) ; Multiple Entries Found
  1. Q:+($G(FBLIT))>0 "^^"
  1. N FBSRLE,FBLL,FBLMAX,FBLSS,FBLX,X
  1. S (FBLMAX,FBLSS,FBLIT)=0,FBLL=+($G(Y)),U="^" S:+($G(FBLL))'>0 FBLL=5
  1. S FBLX=$O(FBSRL(" "),-1),FBLSS=0
  1. G:+FBLX=0 MULQ W ! W:+FBLX>1 !," ",FBLX," matches found"
  1. F FBSRLE=1:1:FBLX Q:((FBLSS>0)&(FBLSS<(FBSRLE+1))) Q:FBLIT D Q:FBLIT
  1. . W:FBSRLE#FBLL=1 ! D MULW
  1. . S FBLMAX=FBSRLE W:FBSRLE#FBLL=0 !
  1. . S:FBSRLE#FBLL=0 FBLSS=$$MULS(FBLMAX,FBSRLE,.FBSRL) S:FBLSS["^" FBLIT=1
  1. I FBSRLE#FBLL'=0,+FBLSS<=0 D
  1. . W ! S FBLSS=$$MULS(FBLMAX,FBSRLE,.FBSRL) S:FBLSS["^" FBLIT=1
  1. G MULQ
  1. Q X
  1. MULW ; Write Multiple
  1. N FBLEX,FBLI1,FBLSO,FBLNC,FBLT2,FBLTX S FBLSO=$P(FBSRL(+FBSRLE,0),"^",1)
  1. S FBLNC=$P(FBSRL(+FBSRLE,0),"^",3) S:+FBLNC>0 FBLNC=" ("_FBLNC_")"
  1. S FBLEX=$G(FBSRL(+FBSRLE,"MENU")),FBLTX(1)=FBLSO
  1. S FBLTX(1)=FBLTX(1)_$S($D(FBSRL(+FBSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(FBLSO)))_" "_FBLEX_FBLNC
  1. D PR(.FBLTX,60) W !,$J(FBSRLE,5),". ",$G(FBLTX(1))
  1. F FBLI1=2:1:5 S FBLT2=$G(FBLTX(FBLI1)) W:$L(FBLT2) !,$J(" ",19),FBLT2
  1. Q
  1. MULS(X,Y,FBSRL) ; Select from Multiple Entries
  1. N DIR,DIRB,FBLFI,FBLHLP,FBLLST,FBLMAX,FBLS1 ;@#$ not sure FBLS1 is neede here
  1. Q:+($G(FBLIT))>0 "^^" S FBLMAX=+($G(X)),FBLLST=+($G(Y))
  1. Q:FBLMAX=0 -1 S FBLFI=$O(FBSRL(0)) Q:+FBLFI'>0 -1
  1. I +($O(FBSRL(+FBLLST)))>0 D
  1. . S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
  1. . S DIR("A")=DIR("A")_FBLMAX_": "
  1. I +($O(FBSRL(+FBLLST)))'>0 D
  1. . S DIR("A")=" Select 1-"_FBLMAX_": "
  1. S FBLHLP=" Answer must be from 1 to "
  1. S FBLHLP=FBLHLP_FBLMAX_", or <Return> to continue"
  1. S DIR("PRE")="S:X[""?"" X=""??"""
  1. S (DIR("?"),DIR("??"))="^D MULSH^FBASFL"
  1. S DIR(0)="NAO^1:"_FBLMAX_":0" D ^DIR
  1. S:X="^" FBGOUP=1
  1. Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
  1. S:X["^^"!($D(DTOUT)) FBLIT=1,X="^^" I X["^^"!(+($G(FBLIT))>0) Q "^^"
  1. K DIR Q:$D(DTOUT)!(X[U) "^^"
  1. Q $S(+Y>0:+Y,1:"-1")
  1. MULSH ; Select from Multiple Entries Help
  1. I $L($G(FBLHLP)) W !,$G(FBLHLP) Q
  1. Q
  1. MULQ ; Quit Multiple
  1. I +FBLSS'>0,$G(FBLSS)="^" Q "^"
  1. S X=-1 S:+($G(FBLIT))'>0 X=$$X(+FBLSS,.FBSRL)
  1. Q X
  1. X(X,FBSRL) ; Set X and Output Array
  1. N FBLEX,FBSRFI,FBLIEN,FBLN1,FBLNC,FBLNN,FBLRN,FBLS1,FBLSO
  1. S FBLS1=+($G(X))
  1. S FBSRFI=$O(FBSRL(0)) ;@#$ not used?
  1. S FBLSO=$P($G(FBSRL(FBLS1,0)),"^",1),FBLEX=$G(FBSRL(FBLS1,"MENU"))
  1. 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) "^"
  1. Q:'$L(FBLEX) "^" Q:+FBLIEN'>0 "^" S X=FBLIEN_"^"_FBLEX
  1. S FBLNN="FBSRL("_+FBLS1_")",FBLNC="FBSRL("_+FBLS1_","
  1. F S FBLNN=$Q(@FBLNN) Q:'$L(FBLNN)!(FBLNN'[FBLNC) D
  1. . S FBLRN="FBLN1("_$P(FBLNN,"(",2,299) S @FBLRN=@FBLNN
  1. K FBSRL S FBLNN="FBLN1("_+FBLS1_")",FBLNC="FBLN1("_+FBLS1_","
  1. F S FBLNN=$Q(@FBLNN) Q:'$L(FBLNN)!(FBLNN'[FBLNC) D
  1. . S FBLRN="FBSRL("_$P(FBLNN,"(",2,299),@FBLRN=@FBLNN
  1. Q X
  1. ;
  1. ; Miscellaneous
  1. CL ; Clear
  1. K FBLIT
  1. Q
  1. PR(FBSRL,X) ; Parse Array
  1. N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,FBLC,FBLI1,FBLL
  1. K ^UTILITY($J,"W")
  1. Q:'$D(FBSRL)
  1. S FBLL=+($G(X))
  1. S:+FBLL'>0 FBLL=79
  1. S FBLC=+($G(FBSRL))
  1. S:+($G(FBLC))'>0 FBLC=$O(FBSRL(" "),-1)
  1. Q:+FBLC'>0
  1. S DIWL=1,DIWF="C"_+FBLL
  1. S FBLI1=0
  1. F S FBLI1=$O(FBSRL(FBLI1)) Q:+FBLI1=0 S X=$G(FBSRL(FBLI1)) D ^DIWP
  1. K FBSRL
  1. S (FBLC,FBLI1)=0
  1. F S FBLI1=$O(^UTILITY($J,"W",1,FBLI1)) Q:+FBLI1=0 D
  1. . S FBSRL(FBLI1)=$$TM($G(^UTILITY($J,"W",1,FBLI1,0))," "),FBLC=FBLC+1
  1. S:$L(FBLC) FBSRL=FBLC
  1. K ^UTILITY($J,"W")
  1. Q
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
  1. F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X