source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQSEL.m@ 1305

Last change on this file since 1305 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.9 KB
RevLine 
[613]1ACKQSEL ;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 ;
6SELECT(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 ;
35SELECTX ; exit point
36 Q
37 ;
38SELECT2 ; 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 ;
103SELECT3 ; 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 ;
124SELHELP ; 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 ;
150SELHELP2 ; 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
163UP(X) ; convert X to uppercase
164 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.