1 | ACKQSEL ;HIRMFO/BH-QUASAR Utility Routine ; 04/01/99
|
---|
2 | ;;3.0;QUASAR;;Feb 11, 2000
|
---|
3 | ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
---|
4 | ;
|
---|
5 | ;
|
---|
6 | SELECT(ACKTYP,ACKIN,ACKOUT,ACKFLD,ACKHLP,ACKDEF) ; generic prompt to select from a list
|
---|
7 | ; input: ACKTYP 1=one only, 2=many, 3=many or 'ALL'.
|
---|
8 | ; ACKIN array/global containing valid items
|
---|
9 | ; where @ACKIN@(name) exists
|
---|
10 | ; ACKOUT array/global specifying where to put selected items
|
---|
11 | ; where @ACKOUT@(name)="" and @ACKOUT=null or '^'
|
---|
12 | ; ACKFLD field name^max len
|
---|
13 | ; (used in prompt and list of items)
|
---|
14 | ; ACKHLP mumps execute for help (displayed for both ? and ??)
|
---|
15 | ; ACKDEF Default type^value
|
---|
16 | ; if type is 1,default displayed with prompt and //
|
---|
17 | ; if type is 2, default appears on spacebar return
|
---|
18 | ; ^TMP("ACKQSEL",$J,1) used during this program
|
---|
19 | ;
|
---|
20 | ; initialise variables
|
---|
21 | N DIR,ACKEXIT,ACKSEL,DIWL,DIWR,DIWF,ACKNUM,ACKNXT,ACKMTCH,ACKADD,X,ACKEOF
|
---|
22 | N ACKDONE,ACKLIST
|
---|
23 | S:$G(ACKDEF)="" ACKDEF=0
|
---|
24 | K @ACKOUT
|
---|
25 | K ^TMP("ACKQSEL",$J,1)
|
---|
26 | S DIWL=1,DIWR=80,DIWF=""
|
---|
27 | ; prompt for the field
|
---|
28 | S ACKNUM=0,ACKEXIT=0 ; number selected so far, exit flag
|
---|
29 | ; loop until user has finished selecting
|
---|
30 | ; (will exit after 1 if ACKTYP=1)
|
---|
31 | F D SELECT2 Q:ACKEXIT
|
---|
32 | ; kill temp list
|
---|
33 | K ^TMP("ACKQSEL",$J,1)
|
---|
34 | ;
|
---|
35 | SELECTX ; exit point
|
---|
36 | Q
|
---|
37 | ;
|
---|
38 | SELECT2 ; prompt the user
|
---|
39 | K DIR S DIR("A")="Select "_$P(ACKFLD,U,1),DIR(0)="FO^1:"_$P(ACKFLD,U,2)
|
---|
40 | ; change field to optional if one or more already selected
|
---|
41 | I $O(@ACKOUT@(""))'="" S DIR(0)="FO^1:"_$P(ACKFLD,U,2)
|
---|
42 | S DIR("?")="^"_ACKHLP
|
---|
43 | I ACKTYP>1 S DIR("?")=DIR("?")_" S ACKLIST=2 D SELHELP^ACKQSEL"
|
---|
44 | S DIR("??")="^"_ACKHLP_" S ACKLIST=1 D SELHELP^ACKQSEL"
|
---|
45 | I +ACKDEF=1 S DIR("B")=$$UP($P(ACKDEF,U,2))
|
---|
46 | D ^DIR
|
---|
47 | S X=$$UP(X) ; convert input to upper case
|
---|
48 | I X=" ",+ACKDEF=2 S X=$$UP($P(ACKDEF,U,2)) W " ",X
|
---|
49 | I X?1"^"1.E W !,"Jumping not allowed." K DUOUT Q
|
---|
50 | I $D(DTOUT) S @ACKOUT="T",ACKEXIT=1 Q ; timed out
|
---|
51 | I $D(DUOUT)!(X="^") S @ACKOUT="^",ACKEXIT=1 Q ; user quit
|
---|
52 | I X="" S @ACKOUT="",ACKEXIT=1 Q ; null entered (ie. done)
|
---|
53 | ;
|
---|
54 | ; validate the input
|
---|
55 | S ACKSEL=X,ACKMTCH=0,ACKNUM=0,ACKADD=1
|
---|
56 | I $E(ACKSEL)="-",$L(ACKSEL)>1 S ACKADD=2,ACKSEL=$E(ACKSEL,2,$L(ACKSEL))
|
---|
57 | S ACKNXT=ACKSEL
|
---|
58 | ;
|
---|
59 | ; if ALL selected then transfer all entries to selected list
|
---|
60 | I ACKTYP=3,ACKSEL="ALL" D Q
|
---|
61 | . I ACKADD=1 D S ACKEXIT=1 Q ;all selected
|
---|
62 | . . S ACKNXT="" F S ACKNXT=$O(@ACKIN@(ACKNXT)) Q:ACKNXT="" D
|
---|
63 | . . . S @ACKOUT@(ACKNXT)=""
|
---|
64 | . I ACKADD=2 K @ACKOUT ;all de-selected
|
---|
65 | ;
|
---|
66 | ; if no matches then quit
|
---|
67 | I ACKADD=1,'$D(@ACKIN@(ACKSEL)) S ACKNXT=$O(@ACKIN@(ACKSEL)) I ACKNXT="" W " ??" Q
|
---|
68 | I ACKADD=2,'$D(@ACKOUT@(ACKSEL)) S ACKNXT=$O(@ACKOUT@(ACKSEL)) I ACKNXT="" W " ??" Q
|
---|
69 | I $E(ACKNXT,1,$L(ACKSEL))'=ACKSEL W " ??" Q
|
---|
70 | ;
|
---|
71 | ; if only one match then quit
|
---|
72 | I ACKADD=1,$E($O(@ACKIN@(ACKNXT)),1,$L(ACKSEL))'=ACKSEL D Q
|
---|
73 | . S @ACKOUT@(ACKNXT)=""
|
---|
74 | . I ACKTYP=1 S ACKEXIT=1
|
---|
75 | . ;S X=ACKSEL D ^DIWP,^DIWW
|
---|
76 | . W $E(ACKNXT,$L(ACKSEL)+1,$L(ACKNXT)) W:ACKTYP'=1 " selected"
|
---|
77 | . S ACKSEL=ACKNXT
|
---|
78 | I ACKADD=2,$E($O(@ACKOUT@(ACKNXT)),1,$L(ACKSEL))'=ACKSEL D Q
|
---|
79 | . K @ACKOUT@(ACKNXT)
|
---|
80 | . ;S X=ACKSEL D ^DIWP,^DIWW
|
---|
81 | . W $E(ACKNXT,$L(ACKSEL)+1,$L(ACKNXT)) W:ACKTYP'=1 " de-selected"
|
---|
82 | . S ACKSEL=ACKNXT
|
---|
83 | ;
|
---|
84 | ; to get here, there must be 2 or more matches
|
---|
85 | I ACKADD=2 Q ;multiple de-selection not allowed
|
---|
86 | K ^TMP("ACKQSEL",$J,1)
|
---|
87 | S X="|SETTAB(5,10)|" D ^DIWP S X=" " D ^DIWP
|
---|
88 | I $D(@ACKIN@(ACKSEL)) D
|
---|
89 | . S ACKMTCH=1,X="|TAB|1|TAB|"_ACKSEL D ^DIWP
|
---|
90 | . S ^TMP("ACKQSEL",$J,1,ACKMTCH)=ACKSEL
|
---|
91 | S ACKEOF=0 ; indicates end of file reached
|
---|
92 | S ACKNUM="" ; number selected by user
|
---|
93 | ; loop to display all matching items
|
---|
94 | S ACKNXT=ACKSEL F D SELECT3 Q:ACKEOF Q:ACKNUM]""
|
---|
95 | ; if item selected then add to file
|
---|
96 | I ACKNUM?1.N D
|
---|
97 | . S ACKSEL=^TMP("ACKQSEL",$J,1,ACKNUM)
|
---|
98 | . S @ACKOUT@(ACKSEL)=""
|
---|
99 | . ; if only one selection required then exit
|
---|
100 | . I ACKTYP=1 S ACKEXIT=1 Q
|
---|
101 | Q
|
---|
102 | ;
|
---|
103 | SELECT3 ; choose from multiple matching entries
|
---|
104 | S ACKDONE=0 ; indicates next five have been displayed
|
---|
105 | F S ACKNXT=$O(@ACKIN@(ACKNXT)) D Q:ACKDONE
|
---|
106 | . I (ACKNXT="")!($E(ACKNXT,1,$L(ACKSEL))'=ACKSEL) S ACKDONE=1,ACKEOF=1 Q
|
---|
107 | . S ACKMTCH=ACKMTCH+1,X="|TAB|"_ACKMTCH_"|TAB|"_ACKNXT D ^DIWP
|
---|
108 | . S ^TMP("ACKQSEL",$J,1,ACKMTCH)=ACKNXT
|
---|
109 | . I ACKMTCH#5=0 S ACKDONE=1
|
---|
110 | ; if the next entry on the list is null or does not match
|
---|
111 | ; the user entry then we are at end of file
|
---|
112 | I ACKNXT'="" D
|
---|
113 | . I $O(@ACKIN@(ACKNXT))="" S ACKEOF=1
|
---|
114 | . I $E($O(@ACKIN@(ACKNXT)),1,$L(ACKSEL))'=ACKSEL S ACKEOF=1
|
---|
115 | D ^DIWW
|
---|
116 | K DIR
|
---|
117 | S DIR("A")="Select",DIR(0)="NO^1:"_ACKMTCH_":0"
|
---|
118 | D ^DIR
|
---|
119 | S ACKNUM=X
|
---|
120 | I ACKNUM'="^",ACKNUM'?1.N S ACKNUM=""
|
---|
121 | I 'ACKEOF,ACKNUM'="^" S X=" " D ^DIWP
|
---|
122 | Q
|
---|
123 | ;
|
---|
124 | SELHELP ; display help for the select prompt
|
---|
125 | ; called by Fileman as the Help routine for the item
|
---|
126 | ; being prompted in the SELECT function above.
|
---|
127 | ; not intended for use by other functions/routines.
|
---|
128 | ; requires the following
|
---|
129 | ; @ACKIN@(itm) list of available items
|
---|
130 | ; @ACKOUT@(itm) currently selected items
|
---|
131 | ; ACKLIST which list to display 1=IN 2=OUT
|
---|
132 | ; ACKFLD the name of the field
|
---|
133 | ;
|
---|
134 | N ACKITM,DIWL,DIWR,DIWF,X,ACKEXIT,ACK,DIR,ACKFILE
|
---|
135 | S ACKITM="",DIWL=1,DIWR=80,DIWF=""
|
---|
136 | S X="|SETTAB(10)|" D ^DIWP S X=" " D ^DIWP
|
---|
137 | I ACKLIST=2 D
|
---|
138 | . S X=" "_$S($O(@ACKOUT@(""))="":"No ",1:"The following ")
|
---|
139 | . S X=X_$P(ACKFLD,U,1)_"s have been selected so far..."
|
---|
140 | . D ^DIWP
|
---|
141 | I ACKLIST=1 D
|
---|
142 | . S X=" Choose from:"
|
---|
143 | . D ^DIWP
|
---|
144 | ; begin listing the items
|
---|
145 | S ACKITM="",ACKEXIT=0
|
---|
146 | F D SELHELP2 Q:ACKEXIT
|
---|
147 | ; end
|
---|
148 | Q
|
---|
149 | ;
|
---|
150 | SELHELP2 ; list the next 10
|
---|
151 | S ACKFILE=$S(ACKLIST=1:ACKIN,1:ACKOUT)
|
---|
152 | S X=" " D ^DIWP
|
---|
153 | F ACK=1:1:10 S ACKITM=$O(@ACKFILE@(ACKITM)) Q:ACKITM="" D
|
---|
154 | . S X="|TAB|"_ACKITM D ^DIWP
|
---|
155 | D ^DIWW
|
---|
156 | ; if end of list encountered then exit
|
---|
157 | I (ACKITM="")!($O(@ACKFILE@(ACKITM))="") S ACKEXIT=1 Q
|
---|
158 | ; prompt to continue
|
---|
159 | K DIR S DIR(0)="E"
|
---|
160 | D ^DIR
|
---|
161 | I X="^" S ACKEXIT=1
|
---|
162 | Q
|
---|
163 | UP(X) ; convert X to uppercase
|
---|
164 | Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
---|