ACKQSEL ;HIRMFO/BH-QUASAR Utility Routine ; 04/01/99
;;3.0;QUASAR;;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
;
SELECT(ACKTYP,ACKIN,ACKOUT,ACKFLD,ACKHLP,ACKDEF) ; generic prompt to select from a list
; input: ACKTYP 1=one only, 2=many, 3=many or 'ALL'.
; ACKIN array/global containing valid items
; where @ACKIN@(name) exists
; ACKOUT array/global specifying where to put selected items
; where @ACKOUT@(name)="" and @ACKOUT=null or '^'
; ACKFLD field name^max len
; (used in prompt and list of items)
; ACKHLP mumps execute for help (displayed for both ? and ??)
; ACKDEF Default type^value
; if type is 1,default displayed with prompt and //
; if type is 2, default appears on spacebar return
; ^TMP("ACKQSEL",$J,1) used during this program
;
; initialise variables
N DIR,ACKEXIT,ACKSEL,DIWL,DIWR,DIWF,ACKNUM,ACKNXT,ACKMTCH,ACKADD,X,ACKEOF
N ACKDONE,ACKLIST
S:$G(ACKDEF)="" ACKDEF=0
K @ACKOUT
K ^TMP("ACKQSEL",$J,1)
S DIWL=1,DIWR=80,DIWF=""
; prompt for the field
S ACKNUM=0,ACKEXIT=0 ; number selected so far, exit flag
; loop until user has finished selecting
; (will exit after 1 if ACKTYP=1)
F D SELECT2 Q:ACKEXIT
; kill temp list
K ^TMP("ACKQSEL",$J,1)
;
SELECTX ; exit point
Q
;
SELECT2 ; prompt the user
K DIR S DIR("A")="Select "_$P(ACKFLD,U,1),DIR(0)="FO^1:"_$P(ACKFLD,U,2)
; change field to optional if one or more already selected
I $O(@ACKOUT@(""))'="" S DIR(0)="FO^1:"_$P(ACKFLD,U,2)
S DIR("?")="^"_ACKHLP
I ACKTYP>1 S DIR("?")=DIR("?")_" S ACKLIST=2 D SELHELP^ACKQSEL"
S DIR("??")="^"_ACKHLP_" S ACKLIST=1 D SELHELP^ACKQSEL"
I +ACKDEF=1 S DIR("B")=$$UP($P(ACKDEF,U,2))
D ^DIR
S X=$$UP(X) ; convert input to upper case
I X=" ",+ACKDEF=2 S X=$$UP($P(ACKDEF,U,2)) W " ",X
I X?1"^"1.E W !,"Jumping not allowed." K DUOUT Q
I $D(DTOUT) S @ACKOUT="T",ACKEXIT=1 Q ; timed out
I $D(DUOUT)!(X="^") S @ACKOUT="^",ACKEXIT=1 Q ; user quit
I X="" S @ACKOUT="",ACKEXIT=1 Q ; null entered (ie. done)
;
; validate the input
S ACKSEL=X,ACKMTCH=0,ACKNUM=0,ACKADD=1
I $E(ACKSEL)="-",$L(ACKSEL)>1 S ACKADD=2,ACKSEL=$E(ACKSEL,2,$L(ACKSEL))
S ACKNXT=ACKSEL
;
; if ALL selected then transfer all entries to selected list
I ACKTYP=3,ACKSEL="ALL" D Q
. I ACKADD=1 D S ACKEXIT=1 Q ;all selected
. . S ACKNXT="" F S ACKNXT=$O(@ACKIN@(ACKNXT)) Q:ACKNXT="" D
. . . S @ACKOUT@(ACKNXT)=""
. I ACKADD=2 K @ACKOUT ;all de-selected
;
; if no matches then quit
I ACKADD=1,'$D(@ACKIN@(ACKSEL)) S ACKNXT=$O(@ACKIN@(ACKSEL)) I ACKNXT="" W " ??" Q
I ACKADD=2,'$D(@ACKOUT@(ACKSEL)) S ACKNXT=$O(@ACKOUT@(ACKSEL)) I ACKNXT="" W " ??" Q
I $E(ACKNXT,1,$L(ACKSEL))'=ACKSEL W " ??" Q
;
; if only one match then quit
I ACKADD=1,$E($O(@ACKIN@(ACKNXT)),1,$L(ACKSEL))'=ACKSEL D Q
. S @ACKOUT@(ACKNXT)=""
. I ACKTYP=1 S ACKEXIT=1
. ;S X=ACKSEL D ^DIWP,^DIWW
. W $E(ACKNXT,$L(ACKSEL)+1,$L(ACKNXT)) W:ACKTYP'=1 " selected"
. S ACKSEL=ACKNXT
I ACKADD=2,$E($O(@ACKOUT@(ACKNXT)),1,$L(ACKSEL))'=ACKSEL D Q
. K @ACKOUT@(ACKNXT)
. ;S X=ACKSEL D ^DIWP,^DIWW
. W $E(ACKNXT,$L(ACKSEL)+1,$L(ACKNXT)) W:ACKTYP'=1 " de-selected"
. S ACKSEL=ACKNXT
;
; to get here, there must be 2 or more matches
I ACKADD=2 Q ;multiple de-selection not allowed
K ^TMP("ACKQSEL",$J,1)
S X="|SETTAB(5,10)|" D ^DIWP S X=" " D ^DIWP
I $D(@ACKIN@(ACKSEL)) D
. S ACKMTCH=1,X="|TAB|1|TAB|"_ACKSEL D ^DIWP
. S ^TMP("ACKQSEL",$J,1,ACKMTCH)=ACKSEL
S ACKEOF=0 ; indicates end of file reached
S ACKNUM="" ; number selected by user
; loop to display all matching items
S ACKNXT=ACKSEL F D SELECT3 Q:ACKEOF Q:ACKNUM]""
; if item selected then add to file
I ACKNUM?1.N D
. S ACKSEL=^TMP("ACKQSEL",$J,1,ACKNUM)
. S @ACKOUT@(ACKSEL)=""
. ; if only one selection required then exit
. I ACKTYP=1 S ACKEXIT=1 Q
Q
;
SELECT3 ; choose from multiple matching entries
S ACKDONE=0 ; indicates next five have been displayed
F S ACKNXT=$O(@ACKIN@(ACKNXT)) D Q:ACKDONE
. I (ACKNXT="")!($E(ACKNXT,1,$L(ACKSEL))'=ACKSEL) S ACKDONE=1,ACKEOF=1 Q
. S ACKMTCH=ACKMTCH+1,X="|TAB|"_ACKMTCH_"|TAB|"_ACKNXT D ^DIWP
. S ^TMP("ACKQSEL",$J,1,ACKMTCH)=ACKNXT
. I ACKMTCH#5=0 S ACKDONE=1
; if the next entry on the list is null or does not match
; the user entry then we are at end of file
I ACKNXT'="" D
. I $O(@ACKIN@(ACKNXT))="" S ACKEOF=1
. I $E($O(@ACKIN@(ACKNXT)),1,$L(ACKSEL))'=ACKSEL S ACKEOF=1
D ^DIWW
K DIR
S DIR("A")="Select",DIR(0)="NO^1:"_ACKMTCH_":0"
D ^DIR
S ACKNUM=X
I ACKNUM'="^",ACKNUM'?1.N S ACKNUM=""
I 'ACKEOF,ACKNUM'="^" S X=" " D ^DIWP
Q
;
SELHELP ; display help for the select prompt
; called by Fileman as the Help routine for the item
; being prompted in the SELECT function above.
; not intended for use by other functions/routines.
; requires the following
; @ACKIN@(itm) list of available items
; @ACKOUT@(itm) currently selected items
; ACKLIST which list to display 1=IN 2=OUT
; ACKFLD the name of the field
;
N ACKITM,DIWL,DIWR,DIWF,X,ACKEXIT,ACK,DIR,ACKFILE
S ACKITM="",DIWL=1,DIWR=80,DIWF=""
S X="|SETTAB(10)|" D ^DIWP S X=" " D ^DIWP
I ACKLIST=2 D
. S X=" "_$S($O(@ACKOUT@(""))="":"No ",1:"The following ")
. S X=X_$P(ACKFLD,U,1)_"s have been selected so far..."
. D ^DIWP
I ACKLIST=1 D
. S X=" Choose from:"
. D ^DIWP
; begin listing the items
S ACKITM="",ACKEXIT=0
F D SELHELP2 Q:ACKEXIT
; end
Q
;
SELHELP2 ; list the next 10
S ACKFILE=$S(ACKLIST=1:ACKIN,1:ACKOUT)
S X=" " D ^DIWP
F ACK=1:1:10 S ACKITM=$O(@ACKFILE@(ACKITM)) Q:ACKITM="" D
. S X="|TAB|"_ACKITM D ^DIWP
D ^DIWW
; if end of list encountered then exit
I (ACKITM="")!($O(@ACKFILE@(ACKITM))="") S ACKEXIT=1 Q
; prompt to continue
K DIR S DIR(0)="E"
D ^DIR
I X="^" S ACKEXIT=1
Q
UP(X) ; convert X to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQSEL 6173 printed Dec 13, 2024@02:32:34 Page 2
ACKQSEL ;HIRMFO/BH-QUASAR Utility Routine ; 04/01/99
+1 ;;3.0;QUASAR;;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;
+4 ;
SELECT(ACKTYP,ACKIN,ACKOUT,ACKFLD,ACKHLP,ACKDEF) ; generic prompt to select from a list
+1 ; input: ACKTYP 1=one only, 2=many, 3=many or 'ALL'.
+2 ; ACKIN array/global containing valid items
+3 ; where @ACKIN@(name) exists
+4 ; ACKOUT array/global specifying where to put selected items
+5 ; where @ACKOUT@(name)="" and @ACKOUT=null or '^'
+6 ; ACKFLD field name^max len
+7 ; (used in prompt and list of items)
+8 ; ACKHLP mumps execute for help (displayed for both ? and ??)
+9 ; ACKDEF Default type^value
+10 ; if type is 1,default displayed with prompt and //
+11 ; if type is 2, default appears on spacebar return
+12 ; ^TMP("ACKQSEL",$J,1) used during this program
+13 ;
+14 ; initialise variables
+15 NEW DIR,ACKEXIT,ACKSEL,DIWL,DIWR,DIWF,ACKNUM,ACKNXT,ACKMTCH,ACKADD,X,ACKEOF
+16 NEW ACKDONE,ACKLIST
+17 if $GET(ACKDEF)=""
SET ACKDEF=0
+18 KILL @ACKOUT
+19 KILL ^TMP("ACKQSEL",$JOB,1)
+20 SET DIWL=1
SET DIWR=80
SET DIWF=""
+21 ; prompt for the field
+22 ; number selected so far, exit flag
SET ACKNUM=0
SET ACKEXIT=0
+23 ; loop until user has finished selecting
+24 ; (will exit after 1 if ACKTYP=1)
+25 FOR
DO SELECT2
if ACKEXIT
QUIT
+26 ; kill temp list
+27 KILL ^TMP("ACKQSEL",$JOB,1)
+28 ;
SELECTX ; exit point
+1 QUIT
+2 ;
SELECT2 ; prompt the user
+1 KILL DIR
SET DIR("A")="Select "_$PIECE(ACKFLD,U,1)
SET DIR(0)="FO^1:"_$PIECE(ACKFLD,U,2)
+2 ; change field to optional if one or more already selected
+3 IF $ORDER(@ACKOUT@(""))'=""
SET DIR(0)="FO^1:"_$PIECE(ACKFLD,U,2)
+4 SET DIR("?")="^"_ACKHLP
+5 IF ACKTYP>1
SET DIR("?")=DIR("?")_" S ACKLIST=2 D SELHELP^ACKQSEL"
+6 SET DIR("??")="^"_ACKHLP_" S ACKLIST=1 D SELHELP^ACKQSEL"
+7 IF +ACKDEF=1
SET DIR("B")=$$UP($PIECE(ACKDEF,U,2))
+8 DO ^DIR
+9 ; convert input to upper case
SET X=$$UP(X)
+10 IF X=" "
IF +ACKDEF=2
SET X=$$UP($PIECE(ACKDEF,U,2))
WRITE " ",X
+11 IF X?1"^"1.E
WRITE !,"Jumping not allowed."
KILL DUOUT
QUIT
+12 ; timed out
IF $DATA(DTOUT)
SET @ACKOUT="T"
SET ACKEXIT=1
QUIT
+13 ; user quit
IF $DATA(DUOUT)!(X="^")
SET @ACKOUT="^"
SET ACKEXIT=1
QUIT
+14 ; null entered (ie. done)
IF X=""
SET @ACKOUT=""
SET ACKEXIT=1
QUIT
+15 ;
+16 ; validate the input
+17 SET ACKSEL=X
SET ACKMTCH=0
SET ACKNUM=0
SET ACKADD=1
+18 IF $EXTRACT(ACKSEL)="-"
IF $LENGTH(ACKSEL)>1
SET ACKADD=2
SET ACKSEL=$EXTRACT(ACKSEL,2,$LENGTH(ACKSEL))
+19 SET ACKNXT=ACKSEL
+20 ;
+21 ; if ALL selected then transfer all entries to selected list
+22 IF ACKTYP=3
IF ACKSEL="ALL"
Begin DoDot:1
+23 ;all selected
IF ACKADD=1
Begin DoDot:2
+24 SET ACKNXT=""
FOR
SET ACKNXT=$ORDER(@ACKIN@(ACKNXT))
if ACKNXT=""
QUIT
Begin DoDot:3
+25 SET @ACKOUT@(ACKNXT)=""
End DoDot:3
End DoDot:2
SET ACKEXIT=1
QUIT
+26 ;all de-selected
IF ACKADD=2
KILL @ACKOUT
End DoDot:1
QUIT
+27 ;
+28 ; if no matches then quit
+29 IF ACKADD=1
IF '$DATA(@ACKIN@(ACKSEL))
SET ACKNXT=$ORDER(@ACKIN@(ACKSEL))
IF ACKNXT=""
WRITE " ??"
QUIT
+30 IF ACKADD=2
IF '$DATA(@ACKOUT@(ACKSEL))
SET ACKNXT=$ORDER(@ACKOUT@(ACKSEL))
IF ACKNXT=""
WRITE " ??"
QUIT
+31 IF $EXTRACT(ACKNXT,1,$LENGTH(ACKSEL))'=ACKSEL
WRITE " ??"
QUIT
+32 ;
+33 ; if only one match then quit
+34 IF ACKADD=1
IF $EXTRACT($ORDER(@ACKIN@(ACKNXT)),1,$LENGTH(ACKSEL))'=ACKSEL
Begin DoDot:1
+35 SET @ACKOUT@(ACKNXT)=""
+36 IF ACKTYP=1
SET ACKEXIT=1
+37 ;S X=ACKSEL D ^DIWP,^DIWW
+38 WRITE $EXTRACT(ACKNXT,$LENGTH(ACKSEL)+1,$LENGTH(ACKNXT))
if ACKTYP'=1
WRITE " selected"
+39 SET ACKSEL=ACKNXT
End DoDot:1
QUIT
+40 IF ACKADD=2
IF $EXTRACT($ORDER(@ACKOUT@(ACKNXT)),1,$LENGTH(ACKSEL))'=ACKSEL
Begin DoDot:1
+41 KILL @ACKOUT@(ACKNXT)
+42 ;S X=ACKSEL D ^DIWP,^DIWW
+43 WRITE $EXTRACT(ACKNXT,$LENGTH(ACKSEL)+1,$LENGTH(ACKNXT))
if ACKTYP'=1
WRITE " de-selected"
+44 SET ACKSEL=ACKNXT
End DoDot:1
QUIT
+45 ;
+46 ; to get here, there must be 2 or more matches
+47 ;multiple de-selection not allowed
IF ACKADD=2
QUIT
+48 KILL ^TMP("ACKQSEL",$JOB,1)
+49 SET X="|SETTAB(5,10)|"
DO ^DIWP
SET X=" "
DO ^DIWP
+50 IF $DATA(@ACKIN@(ACKSEL))
Begin DoDot:1
+51 SET ACKMTCH=1
SET X="|TAB|1|TAB|"_ACKSEL
DO ^DIWP
+52 SET ^TMP("ACKQSEL",$JOB,1,ACKMTCH)=ACKSEL
End DoDot:1
+53 ; indicates end of file reached
SET ACKEOF=0
+54 ; number selected by user
SET ACKNUM=""
+55 ; loop to display all matching items
+56 SET ACKNXT=ACKSEL
FOR
DO SELECT3
if ACKEOF
QUIT
if ACKNUM]""
QUIT
+57 ; if item selected then add to file
+58 IF ACKNUM?1.N
Begin DoDot:1
+59 SET ACKSEL=^TMP("ACKQSEL",$JOB,1,ACKNUM)
+60 SET @ACKOUT@(ACKSEL)=""
+61 ; if only one selection required then exit
+62 IF ACKTYP=1
SET ACKEXIT=1
QUIT
End DoDot:1
+63 QUIT
+64 ;
SELECT3 ; choose from multiple matching entries
+1 ; indicates next five have been displayed
SET ACKDONE=0
+2 FOR
SET ACKNXT=$ORDER(@ACKIN@(ACKNXT))
Begin DoDot:1
+3 IF (ACKNXT="")!($EXTRACT(ACKNXT,1,$LENGTH(ACKSEL))'=ACKSEL)
SET ACKDONE=1
SET ACKEOF=1
QUIT
+4 SET ACKMTCH=ACKMTCH+1
SET X="|TAB|"_ACKMTCH_"|TAB|"_ACKNXT
DO ^DIWP
+5 SET ^TMP("ACKQSEL",$JOB,1,ACKMTCH)=ACKNXT
+6 IF ACKMTCH#5=0
SET ACKDONE=1
End DoDot:1
if ACKDONE
QUIT
+7 ; if the next entry on the list is null or does not match
+8 ; the user entry then we are at end of file
+9 IF ACKNXT'=""
Begin DoDot:1
+10 IF $ORDER(@ACKIN@(ACKNXT))=""
SET ACKEOF=1
+11 IF $EXTRACT($ORDER(@ACKIN@(ACKNXT)),1,$LENGTH(ACKSEL))'=ACKSEL
SET ACKEOF=1
End DoDot:1
+12 DO ^DIWW
+13 KILL DIR
+14 SET DIR("A")="Select"
SET DIR(0)="NO^1:"_ACKMTCH_":0"
+15 DO ^DIR
+16 SET ACKNUM=X
+17 IF ACKNUM'="^"
IF ACKNUM'?1.N
SET ACKNUM=""
+18 IF 'ACKEOF
IF ACKNUM'="^"
SET X=" "
DO ^DIWP
+19 QUIT
+20 ;
SELHELP ; display help for the select prompt
+1 ; called by Fileman as the Help routine for the item
+2 ; being prompted in the SELECT function above.
+3 ; not intended for use by other functions/routines.
+4 ; requires the following
+5 ; @ACKIN@(itm) list of available items
+6 ; @ACKOUT@(itm) currently selected items
+7 ; ACKLIST which list to display 1=IN 2=OUT
+8 ; ACKFLD the name of the field
+9 ;
+10 NEW ACKITM,DIWL,DIWR,DIWF,X,ACKEXIT,ACK,DIR,ACKFILE
+11 SET ACKITM=""
SET DIWL=1
SET DIWR=80
SET DIWF=""
+12 SET X="|SETTAB(10)|"
DO ^DIWP
SET X=" "
DO ^DIWP
+13 IF ACKLIST=2
Begin DoDot:1
+14 SET X=" "_$SELECT($ORDER(@ACKOUT@(""))="":"No ",1:"The following ")
+15 SET X=X_$PIECE(ACKFLD,U,1)_"s have been selected so far..."
+16 DO ^DIWP
End DoDot:1
+17 IF ACKLIST=1
Begin DoDot:1
+18 SET X=" Choose from:"
+19 DO ^DIWP
End DoDot:1
+20 ; begin listing the items
+21 SET ACKITM=""
SET ACKEXIT=0
+22 FOR
DO SELHELP2
if ACKEXIT
QUIT
+23 ; end
+24 QUIT
+25 ;
SELHELP2 ; list the next 10
+1 SET ACKFILE=$SELECT(ACKLIST=1:ACKIN,1:ACKOUT)
+2 SET X=" "
DO ^DIWP
+3 FOR ACK=1:1:10
SET ACKITM=$ORDER(@ACKFILE@(ACKITM))
if ACKITM=""
QUIT
Begin DoDot:1
+4 SET X="|TAB|"_ACKITM
DO ^DIWP
End DoDot:1
+5 DO ^DIWW
+6 ; if end of list encountered then exit
+7 IF (ACKITM="")!($ORDER(@ACKFILE@(ACKITM))="")
SET ACKEXIT=1
QUIT
+8 ; prompt to continue
+9 KILL DIR
SET DIR(0)="E"
+10 DO ^DIR
+11 IF X="^"
SET ACKEXIT=1
+12 QUIT
UP(X) ; convert X to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
