LEXDFLS ;ISL/KER - Default Filter - Select ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^LEX(757.41) N/A
;
; External References
; ^DIR ICR 10026
;
; Special Look-up in file 757.3 Screens
; Entry: S X=$$EN^LEXDFLS
;
; Function returns a multi piece string
;
; $Piece 1-X
;
; Executable MUMPS code to be used as
; a filter (screen DIC("S") during
; searches
;
; $Piece Last piece
;
; Name of the filter selected i.e.,
; "Problem List" This will be null only
; when user input is "^^"
;
; LEX Array containing pointers to 757.3
; LEXA Users answer to selection
; LEXC Counter
; LEXD Display
; LEXF Re-display starting from #LEXF
; LEXI Incremental Counter
; LEXL Last entry displayed
; LEXLN Line counter
; LEXR Internal Entry Number (Record) in #757.3
; LEXS Selection
; LEXT Re-display up through #LEXT
;
EN(LEXX) ; Select a predefined filter string
N X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXD D TOT
S LEXD="",(LEXA,LEXX,LEXC,LEXR)=0
F S LEXD=$O(^LEX(757.3,"B",LEXD)) Q:LEXD=""!(LEXA["^")!(+LEXX>0) D
. S LEXR=0
. F S LEXR=$O(^LEX(757.3,"B",LEXD,LEXR)) Q:+LEXR=0!(LEXA["^")!(+LEXX>0) D
. . Q:$P($G(^LEX(757.3,LEXR,0)),"^",2)'="U"
. . S LEXC=LEXC+1,LEXL=LEXC
. . S LEX(LEXC)=LEXR,LEX(0)=LEXC
. . D W(LEXC,LEXR)
. . D ASK
D ASK S LEXX=+LEXX K LEX
I +LEXX>0 S LEXX=$G(^LEX(757.3,+LEXX,1))_"^"_$P($G(^LEX(757.3,+LEXX,0)),"^",1) Q LEXX
S:LEXA'["^^" LEXX="^No filter selected" S:LEXA["^^" LEXX="^"
Q LEXX
ASK ;
;I LEXC#5=0,+LEXX=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
;I +LEXX=0,LEXA'["^",LEXC#5'=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
Q:+LEXX>0 Q:LEXA["^" Q:+LEXR>0&(LEXC#5'=0)
Q:+LEXR=0&(LEXC#5=0)
D SEL Q:+LEXA'>0 Q:LEXA>LEXC S LEXX=$G(LEX(+LEXA))
Q
SEL ; Select from list
W ! N X,Y,DIR,DIRUT,DTOUT,DUOUT,DIROUT
S DIR(0)="NAO^1:"_LEXC
S DIR("A")="Select FILTER 1-"_LEXC_": "
S (DIR("?"),DIR("??"))="^D SH^LEXDFLS"
D ^DIR S LEXA=Y
Q
UOUT ; Up Arrow detected
S:LEXA="^^" LEXX="^"
S:LEXA="^" LEXX="^No filter selected"
Q
VAL ; No Un Arrow (value)
I +LEXX>0 D Q
. I $D(^LEX(757.41,+LEXX)) D Q
. . S LEXX=LEXX_"^"_$P($G(^LEX(757.41,+LEXX,0)),"^",1)
. S LEXX="^No filter selected"
S LEXX="^No filter selected"
Q
SH ; Show help
N LEXR S LEXR=+($E(X,2,$L(X))) I $E(X,1)="?",LEXR>0,LEXR<(LEX(0)+1) D
. S LEXR=LEX(LEXR) D:'$D(^LEX(757.3,LEXR,2,1)) NODES,STD Q:'$D(^LEX(757.3,LEXR,2,1)) D DES
D:$E(X,1)="?"&(LEXR<1!(LEXR>LEX(0))) STD D:$E(X,1)'="?" STD D RD
Q
STD ; Standard Help
W !!,"Enter 1-",LEXC," to select a filter, or ""?"" for help, or ""?#"" for descriptive"
W !,"help on an entry flagged with an ""*"", or ""^"" to exit or <Return> for more."
Q
DES ; Description Help
N LEXLN,LEXI S (LEXLN,LEXI)=0 W !!,?2,$P(^LEX(757.3,LEXR,0),"^",1),!
F S LEXI=$O(^LEX(757.3,LEXR,2,LEXI)) Q:+LEXI=0 D
. W !,?4,^LEX(757.3,LEXR,2,LEXI,0) S LEXLN=LEXLN+1
D:LEXLN>4 EOP W ! Q
NODES ; No Description Help Available
W !!,?2,$P(^LEX(757.3,LEXR,0),"^",1)," does not have a description",! Q
RD ; Re-Display List
N LEXF,LEXT S LEXT=+($G(LEXL)),LEXF=(+(LEXT#5)-1)
S:LEXF<0 LEXF=4 S LEXF=LEXT-LEXF S LEXF=LEXF-1
F S LEXF=$O(LEX(LEXF)) Q:+LEXF=0!(LEXF'<(LEXT+1)) D
. W:LEXF=1 ! D W(LEXF,LEX(LEXF))
Q
TOT ; Total Filters
N LEXD,LEXR,LEXC S LEXD="",LEXC=0
F S LEXD=$O(^LEX(757.3,"B",LEXD)) Q:LEXD="" S LEXR=0 D
. F S LEXR=$O(^LEX(757.3,"B",LEXD,LEXR)) Q:+LEXR=0 D
. . Q:$P($G(^LEX(757.3,LEXR,0)),"^",2)'="U"
. . S LEXC=LEXC+1
W !!,LEXC," Filters found",! Q
W(LEXC,LEXR) ; Write entry
W !,$J(LEXC,4),". ",$P(^LEX(757.3,LEXR,0),"^",1)
W $S($D(^LEX(757.3,LEXR,2,1)):" *",1:"") Q
EOP ; End of Page
W ! N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT S DIR(0)="E" D ^DIR S:X[U LEXA="^" W ! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDFLS 3991 printed Oct 16, 2024@18:08:19 Page 2
LEXDFLS ;ISL/KER - Default Filter - Select ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.41) N/A
+5 ;
+6 ; External References
+7 ; ^DIR ICR 10026
+8 ;
+9 ; Special Look-up in file 757.3 Screens
+10 ; Entry: S X=$$EN^LEXDFLS
+11 ;
+12 ; Function returns a multi piece string
+13 ;
+14 ; $Piece 1-X
+15 ;
+16 ; Executable MUMPS code to be used as
+17 ; a filter (screen DIC("S") during
+18 ; searches
+19 ;
+20 ; $Piece Last piece
+21 ;
+22 ; Name of the filter selected i.e.,
+23 ; "Problem List" This will be null only
+24 ; when user input is "^^"
+25 ;
+26 ; LEX Array containing pointers to 757.3
+27 ; LEXA Users answer to selection
+28 ; LEXC Counter
+29 ; LEXD Display
+30 ; LEXF Re-display starting from #LEXF
+31 ; LEXI Incremental Counter
+32 ; LEXL Last entry displayed
+33 ; LEXLN Line counter
+34 ; LEXR Internal Entry Number (Record) in #757.3
+35 ; LEXS Selection
+36 ; LEXT Re-display up through #LEXT
+37 ;
EN(LEXX) ; Select a predefined filter string
+1 NEW X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXD
DO TOT
+2 SET LEXD=""
SET (LEXA,LEXX,LEXC,LEXR)=0
+3 FOR
SET LEXD=$ORDER(^LEX(757.3,"B",LEXD))
if LEXD=""!(LEXA["^")!(+LEXX>0)
QUIT
Begin DoDot:1
+4 SET LEXR=0
+5 FOR
SET LEXR=$ORDER(^LEX(757.3,"B",LEXD,LEXR))
if +LEXR=0!(LEXA["^")!(+LEXX>0)
QUIT
Begin DoDot:2
+6 if $PIECE($GET(^LEX(757.3,LEXR,0)),"^",2)'="U"
QUIT
+7 SET LEXC=LEXC+1
SET LEXL=LEXC
+8 SET LEX(LEXC)=LEXR
SET LEX(0)=LEXC
+9 DO W(LEXC,LEXR)
+10 DO ASK
End DoDot:2
End DoDot:1
+11 DO ASK
SET LEXX=+LEXX
KILL LEX
+12 IF +LEXX>0
SET LEXX=$GET(^LEX(757.3,+LEXX,1))_"^"_$PIECE($GET(^LEX(757.3,+LEXX,0)),"^",1)
QUIT LEXX
+13 if LEXA'["^^"
SET LEXX="^No filter selected"
if LEXA["^^"
SET LEXX="^"
+14 QUIT LEXX
ASK ;
+1 ;I LEXC#5=0,+LEXX=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
+2 ;I +LEXX=0,LEXA'["^",LEXC#5'=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
+3 if +LEXX>0
QUIT
if LEXA["^"
QUIT
if +LEXR>0&(LEXC#5'=0)
QUIT
+4 if +LEXR=0&(LEXC#5=0)
QUIT
+5 DO SEL
if +LEXA'>0
QUIT
if LEXA>LEXC
QUIT
SET LEXX=$GET(LEX(+LEXA))
+6 QUIT
SEL ; Select from list
+1 WRITE !
NEW X,Y,DIR,DIRUT,DTOUT,DUOUT,DIROUT
+2 SET DIR(0)="NAO^1:"_LEXC
+3 SET DIR("A")="Select FILTER 1-"_LEXC_": "
+4 SET (DIR("?"),DIR("??"))="^D SH^LEXDFLS"
+5 DO ^DIR
SET LEXA=Y
+6 QUIT
UOUT ; Up Arrow detected
+1 if LEXA="^^"
SET LEXX="^"
+2 if LEXA="^"
SET LEXX="^No filter selected"
+3 QUIT
VAL ; No Un Arrow (value)
+1 IF +LEXX>0
Begin DoDot:1
+2 IF $DATA(^LEX(757.41,+LEXX))
Begin DoDot:2
+3 SET LEXX=LEXX_"^"_$PIECE($GET(^LEX(757.41,+LEXX,0)),"^",1)
End DoDot:2
QUIT
+4 SET LEXX="^No filter selected"
End DoDot:1
QUIT
+5 SET LEXX="^No filter selected"
+6 QUIT
SH ; Show help
+1 NEW LEXR
SET LEXR=+($EXTRACT(X,2,$LENGTH(X)))
IF $EXTRACT(X,1)="?"
IF LEXR>0
IF LEXR<(LEX(0)+1)
Begin DoDot:1
+2 SET LEXR=LEX(LEXR)
if '$DATA(^LEX(757.3,LEXR,2,1))
DO NODES
DO STD
if '$DATA(^LEX(757.3,LEXR,2,1))
QUIT
DO DES
End DoDot:1
+3 if $EXTRACT(X,1)="?"&(LEXR<1!(LEXR>LEX(0)))
DO STD
if $EXTRACT(X,1)'="?"
DO STD
DO RD
+4 QUIT
STD ; Standard Help
+1 WRITE !!,"Enter 1-",LEXC," to select a filter, or ""?"" for help, or ""?#"" for descriptive"
+2 WRITE !,"help on an entry flagged with an ""*"", or ""^"" to exit or <Return> for more."
+3 QUIT
DES ; Description Help
+1 NEW LEXLN,LEXI
SET (LEXLN,LEXI)=0
WRITE !!,?2,$PIECE(^LEX(757.3,LEXR,0),"^",1),!
+2 FOR
SET LEXI=$ORDER(^LEX(757.3,LEXR,2,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+3 WRITE !,?4,^LEX(757.3,LEXR,2,LEXI,0)
SET LEXLN=LEXLN+1
End DoDot:1
+4 if LEXLN>4
DO EOP
WRITE !
QUIT
NODES ; No Description Help Available
+1 WRITE !!,?2,$PIECE(^LEX(757.3,LEXR,0),"^",1)," does not have a description",!
QUIT
RD ; Re-Display List
+1 NEW LEXF,LEXT
SET LEXT=+($GET(LEXL))
SET LEXF=(+(LEXT#5)-1)
+2 if LEXF<0
SET LEXF=4
SET LEXF=LEXT-LEXF
SET LEXF=LEXF-1
+3 FOR
SET LEXF=$ORDER(LEX(LEXF))
if +LEXF=0!(LEXF'<(LEXT+1))
QUIT
Begin DoDot:1
+4 if LEXF=1
WRITE !
DO W(LEXF,LEX(LEXF))
End DoDot:1
+5 QUIT
TOT ; Total Filters
+1 NEW LEXD,LEXR,LEXC
SET LEXD=""
SET LEXC=0
+2 FOR
SET LEXD=$ORDER(^LEX(757.3,"B",LEXD))
if LEXD=""
QUIT
SET LEXR=0
Begin DoDot:1
+3 FOR
SET LEXR=$ORDER(^LEX(757.3,"B",LEXD,LEXR))
if +LEXR=0
QUIT
Begin DoDot:2
+4 if $PIECE($GET(^LEX(757.3,LEXR,0)),"^",2)'="U"
QUIT
+5 SET LEXC=LEXC+1
End DoDot:2
End DoDot:1
+6 WRITE !!,LEXC," Filters found",!
QUIT
W(LEXC,LEXR) ; Write entry
+1 WRITE !,$JUSTIFY(LEXC,4),". ",$PIECE(^LEX(757.3,LEXR,0),"^",1)
+2 WRITE $SELECT($DATA(^LEX(757.3,LEXR,2,1)):" *",1:"")
QUIT
EOP ; End of Page
+1 WRITE !
NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
SET DIR(0)="E"
DO ^DIR
if X[U
SET LEXA="^"
WRITE !
QUIT
