source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY2.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1RMPRPIY2 ;HINCIO/ODJ - PIP Data Entry - Location Prompt ;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ;***** LOCNM - Prompt for PIP Location by name (used by AE option)
6 ; Use only where location can be added
7 ;
8 ; Inputs:
9 ; RMPRSTN - Station number
10 ;
11 ; Outputs:
12 ; RMPREXC - exit condition
13 ; RMPR5 - Array of Location data fields
14 ; RMPRERR - returned error code (ignore for time being)
15 ;
16LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
17 N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
18 D NOW^%DTC S RMPRTDT=X ;today's date
19 S RMPREXC=""
20 S RMPRERR=0
21 S DIR(0)="FOA^1:30"
22 S DIR("A")="Enter Pros Location: "
23 I $G(RMPR5("NAME"))'="" S DIR("B")=RMPR5("NAME")
24 S DIR("?")="^D QM^RMPRPIY2"
25 S DIR("??")="^D QQM^RMPRPIY2"
26LOCNM1 D ^DIR
27 I $D(DTOUT) S RMPREXC="T" G LOCNMX
28 I $D(DIROUT) S RMPREXC="P" G LOCNMX
29 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G LOCNMX
30 K RMPR5
31 D LIKE(RMPRSTN,X,.RMPREXC,.RMPR5)
32 I RMPREXC'="" G LOCNM1
33 I +$G(RMPR5("IEN")) G LOCNMX
34 I $L(X)<3 D G LOCNM1
35 . W !,"Location name must be at least 3 characters long"
36 . Q
37 S RMPR5("STATION")=RMPRSTN
38 S RMPR5("STATION IEN")=RMPRSTN
39 S RMPR5("NAME")=X
40 ;
41 ; Add new Stock Location
42LOCNMA D ADDNM(.RMPR5,.RMPRYN,.RMPREXC)
43 I RMPREXC'="" G LOCNM1
44 I RMPRYN="N" G LOCNM1
45 D ADDR(.RMPR5,.RMPREXC) ; get address for new location
46 I RMPREXC'="" G LOCNM1
47 S RMPR5("STATUS")="A"
48 S RMPR5("STATUS DATE")=RMPRTDT
49 S RMPR5("USER")=$G(DUZ)
50 S RMPRERR=$$CRE^RMPRPIX5(.RMPR5) ; create new location
51LOCNMX Q RMPRERR
52 ;
53 ;***** ADDNM - Prompts for adding a new Stock Location
54 ;
55 ; Inputs:
56 ; RMPR5
57 ;
58 ; Outputs:
59 ; RMPRYN
60 ; RMPREXC
61 ; RMPRERR
62 ;
63ADDNM(RMPR5,RMPRYN,RMPREXC) ;
64 N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
65 S RMPREXC=""
66 S DIR(0)="Y"
67 S DIR("B")="N"
68 S DIR("A")="Are you adding '"_RMPR5("NAME")_"' as a new PROS ITEM LOCATION"
69 D ^DIR
70 I $D(DTOUT) S RMPREXC="T" G ADDNMX
71 I $D(DIROUT) S RMPREXC="P" G ADDNMX
72 I X=""!(X["^") S RMPREXC="^" G ADDNMX
73 S RMPRYN="N" S:Y RMPRYN="Y"
74 S RMPREXC=""
75ADDNMX Q
76 ;
77 ;***** ADDR - Prompt for Stock Location Address
78 ;
79 ; Inputs:
80 ; RMPR5
81 ;
82 ; Outputs:
83 ; RMPR5
84 ; RMPREXC
85 ;
86ADDR(RMPR5,RMPREXC) ;
87 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT
88 S RMPREXC=""
89 S DIR(0)="FOA"
90 S DIR("A")=" PROS ITEM LOCATION ADDRESS: "
91 S DIR("?")="Answer must be 3-30 characters in length."
92 D ^DIR
93 I $D(DTOUT) S RMPREXC="T" G ADDRX
94 I $D(DIROUT) S RMPREXC="P" G ADDRX
95 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ADDRX
96 S RMPR5("ADDRESS")=X
97ADDRX Q
98 ;
99 ;***** QM - Single ? Help (for use by Location prompt)
100QM D QM1 ;ask if want to list locns.
101 I RMPREXC'="" G QMX
102 I RMPRYN'="Y" G QMX
103 D QM2 ;list locns.
104 D QM2H
105QMX Q
106 ;
107 ; Double ? Help
108QQM D QM2 ;list locns.
109 D QQM1
110 Q
111 ;
112 ; QM1 - ask if want to list locns
113 ;
114 ; require RMPRSTN - Station number
115 ;
116 ; sets RMPREXC - exit condition
117 ; RMPRYN - Y - list, any other response - don't bother
118 ;
119QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,%A
120 S RMPRYN="N"
121 S DIR("A",1)=" Answer with PROS ITEM LOCATION"
122 S DIR("A")=" Do you want the entire PROS ITEM LOCATION List"
123 S DIR("?")="^D QM1H^RMPRPIY2"
124 S DIR(0)="YO"
125 D ^DIR
126 I $D(DTOUT) S RMPREXC="T" G QM1X
127 I $D(DIROUT) S RMPREXC="P" G QM1X
128 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G QM1X
129 S:Y RMPRYN="Y"
130 S RMPREXC=""
131QM1X I RMPRYN'="Y",RMPRYN'="?" D QM1H
132 Q
133QM1H W:$X'=0 !
134 W " You may enter a new PROS ITEM LOCATION, if you wish"
135 W !," Answer must be 3-30 characters in length."
136 S %A="V",X="^",RMPRYN="?"
137 Q
138QM2H W !," You may enter a new PROS ITEM LOCATION, if you wish"
139 W !," Answer must be 3-30 characters in length."
140 Q
141QQM1 W !," You may enter a new PROS ITEM LOCATION, if you wish"
142 W !," This is a location of an item or stock being tracked for inventory."
143 Q
144 ;
145 ;***** QM2 - List Location names; part of help for Location prompt
146 ;
147 ; require RMPRSTN - Station number
148 ;
149QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRGBL,RMPRLIN
150 S RMPRMAX=19,RMPRLIN=0
151 S RMPREXC=""
152 S DIR(0)="EA"
153 S DIR("A")="'^' TO STOP: "
154 W !?3,"Choose from:"
155 S RMPRGBL="^RMPR(661.5,"_"""XSL"","_RMPRSTN_")"
156QM2A S RMPRGBL=$Q(@RMPRGBL)
157 I RMPRGBL="" G QM2X
158 I $QS(RMPRGBL,1)'=661.5 G QM2X
159 I $QS(RMPRGBL,2)'="XSL" G QM2X
160 I $QS(RMPRGBL,3)'=RMPRSTN G QM2X
161 W !?3,$QS(RMPRGBL,4)
162 S RMPRLIN=RMPRLIN+1
163 I RMPRLIN'<RMPRMAX G QM2B
164 G QM2A
165QM2B D ^DIR
166 I $D(DTOUT) S RMPREXC="T" G QM2X
167 I $D(DIROUT) S RMPREXC="P" G QM2X
168 I (X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
169 S RMPRLIN=0
170 G QM2A
171QM2X W ! Q
172 ;
173 ;***** LIKE - List Locn names with matching chars.
174 ;
175 ; Inputs:
176 ; RMPRSTN - Station number
177 ; RMPRTXT - Text to be compared
178 ;
179 ; Outputs:
180 ; RMPREXC - exit condition
181 ; RMPR5 - array for Location data fields
182 ;
183LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR5) ;
184 N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
185 N RMPRI,RMPRERR,RMPRYN,RMPRJ
186 S RMPREXC=""
187 S RMPRMAX=5
188 S RMPRJ=RMPRTXT
189 I '$D(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ)) D
190 . S RMPRJ=$O(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ))
191 . Q
192 I RMPRJ=""!($E(RMPRJ,1,$L(RMPRTXT))'=RMPRTXT) S RMPR5("IEN")="" G LIKEX
193 S RMPRI=$O(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ))
194 I RMPRI=""!($E(RMPRI,1,$L(RMPRTXT))'=RMPRTXT) D
195 . S RMPR5("IEN")=$O(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ,""))
196 . W:RMPRJ'=RMPRTXT $E(RMPRJ,1+$L(RMPRTXT),$L(RMPRJ))
197 . S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
198 . D OK^RMPRPIYB(.RMPRYN,)
199 . Q
200 I $G(RMPR5("IEN"))'="" S:RMPRYN'="Y" RMPR5("IEN")="",RMPREXC="^" G LIKEX
201 S RMPRGBL="^RMPR(661.5,"_"""XSL"","_RMPRSTN_","""_RMPRTXT_""")"
202LIKEA1 K RMPRA S RMPRLIN=0
203LIKEA S RMPRGBL=$Q(@RMPRGBL)
204LIKEA2 I RMPRGBL="" G LIKEB
205 I $QS(RMPRGBL,1)'=661.5 G LIKEB
206 I $QS(RMPRGBL,2)'="XSL" G LIKEB
207 I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
208 I $E($QS(RMPRGBL,4),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
209 I RMPRLIN,'(RMPRLIN#RMPRMAX) D G LIKEB
210 . S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, OR"
211 . Q
212LIKEA3 S RMPRLIN=RMPRLIN+1
213 W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,4)
214 S RMPRA(RMPRLIN)=$QS(RMPRGBL,5)
215 G LIKEA
216LIKEB I RMPRLIN=0 G LIKEX
217 S DIR(0)="NAO^1:"_RMPRLIN_":0"
218 S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
219 D ^DIR
220 I $D(DTOUT) S RMPREXC="T" G LIKEX
221 I $D(DIROUT) S RMPREXC="P" G LIKEX
222 I X="",$D(DIR("A",1)) K DIR("A",1) G LIKEA3
223 I X="" S RMPREXC="^" G LIKEX
224 I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
225 K RMPR5
226 S RMPR5("IEN")=RMPRA(X)
227 S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
228 W " ",RMPR5("NAME")
229LIKEX Q
Note: See TracBrowser for help on using the repository browser.