source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m@ 1454

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

revised back to 6/30/08 version

File size: 6.7 KB
Line 
1RMPRPIY7 ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/18/02 15:17
2 ;;3.0;PROSTHETICS;**61,118**;Feb 09, 1996
3 ;
4 ;DBIA # 800 - FILEMAN read of file #440.
5 Q
6 ; The following subroutines are a series of prompts called
7 ; by Edit LOCATION/HCPCS/ITEM option (EI^RMPRPIY6)
8 ;
9 ;***** LOCNM - Prompt for location
10 ; must be in 661.5 and active
11LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
12 N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
13 D NOW^%DTC S RMPRTDT=X ;today's date
14 S RMPREXC=""
15 S RMPRERR=0
16 S DIR(0)="FOA"
17 S DIR("A")="Enter Pros Location: "
18 I $G(RMPR5("NAME"))'="" S DIR("B")=RMPR5("NAME")
19 S DIR("?")="^D QM^RMPRPIYB"
20 S DIR("??")="^D QM2^RMPRPIYB"
21 S RMPR5("IEN")=""
22LOCNM1 D ^DIR
23 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
24 I $G(RMPR5("IEN"))'="" S RMPREXC="" G LOCNMX
25 I $D(DTOUT) S RMPREXC="T" G LOCNMX
26 I $D(DIROUT) S RMPREXC="P" G LOCNMX
27 I X=""!(X["^") S RMPREXC="^" G LOCNMX
28 K RMPR5
29 S RMPR5("STATION")=RMPRSTN
30 S RMPR5("STATION IEN")=RMPRSTN
31 D LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)
32 I RMPREXC'="" G LOCNM1
33 I $G(RMPR5("IEN"))="" D G LOCNM1
34 . W !,"Please enter a valid Location"
35 . Q
36 ;
37 ; exit
38LOCNMX Q
39 ;
40 ;***** OK - Prompt for an OK
41OK(RMPRYN,RMPREXC) ;
42 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
43 S RMPREXC=""
44 S RMPRYN="N"
45 S DIR("A")=" ...OK"
46 S DIR("B")="Yes"
47 S DIR(0)="Y"
48 D ^DIR
49 I $D(DTOUT) S RMPREXC="T" G OKX
50 I $D(DIROUT) S RMPREXC="P" G OKX
51 I X=""!(X["^") S RMPREXC="^" G OKX
52 S RMPRYN="N" S:Y RMPRYN="Y"
53OKX Q
54 ;
55 ;***** HCPCS - Prompt for HCPCS
56HCPCS(RMPRSTN,RMPRHPTX,RMPR1,RMPR11,RMPREXC) ;
57 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPR1N,RMSTN
58 N RM6610
59 S DIR("A")="Select HCPCS: ",RMSTN=RMPRSTN
60 S DIR("S")="I $P(^RMPR(661.11,+Y,0),U,4)=RMSTN"
61 S RMPRERR=0
62 S RMPREXC=""
63 S RMPRHPTX=$G(RMPRHPTX)
64 I RMPRHPTX'="" S DIR("B")=RMPRHPTX
65 S DIR(0)="FOA"
66 S DIR("?")="^D QM2^RMPRPIYC"
67 S DIR("??")="^D QM2^RMPRPIYC"
68 S DIR("???")="^D QM2^RMPRPIYC"
69HCPCS1 K RMPR1N D ^DIR
70 I $G(RMPR1N("IEN"))'="" S RMPRHPTX=RMPR1N("HCPCS") G CHECK
71 I $D(DTOUT) S RMPREXC="T" G HCPCSX
72 I $D(DIROUT) S RMPREXC="P" G HCPCSX
73 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
74 D LIKE^RMPRPIYC(RMPRSTN,X,.RMPREXC,.RMPR1N,.RMPR11)
75 I RMPREXC'="" G HCPCS1
76 I $G(RMPR1N("IEN"))'="",$G(RMPR1("REMOVE")) G HCPCSU
77CHECK I $G(RMPR1N("IEN")),$D(^RMPR(661.1,$G(RMPR1N("IEN")),0)),'($P(^RMPR(661.1,RMPR1N("IEN"),0),U,5)) W !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..." G HCPCS1
78 I $G(RMPR1N("IEN"))'="" G HCPCSU
79 G HCPCS1
80HCPCSU K RMPR1 M RMPR1=RMPR1N
81HCPCSX Q
82 ;
83 ;***** ITEM - Prompt for Item - restrict choice to Location and HCPC
84ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ;
85 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN
86 S RMPRERR=0
87 S RMPREXC=""
88 I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
89 I $G(RMPRLCN)="" S RMPRERR=2 G ITEMX
90 I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX
91 K RMPR11,RMPR4
92 S DIR(0)="FOA^1:50"
93 S DIR("A")="Enter PSAS Item to Edit: "
94 S DIR("?")="^D QM^RMPRPIY8"
95 S DIR("??")="^D QQM^RMPRPIY8"
96ITEMA1 D ^DIR
97 I $D(DTOUT) S RMPREXC="T" G ITEMX
98 I $D(DIROUT) S RMPREXC="P" G ITEMX
99 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ITEMX
100 D LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4)
101 I RMPREXC="T" G ITEMX
102 I RMPREXC="P" G ITEMX
103 I RMPREXC="^" G ITEMA1
104 I RMPR4("IEN")="" D G ITEMA1
105 . W !,"Cannot locate ITEM with this sequence NUMBER"
106 . Q
107 W " ",RMPR11("HCPCS-ITEM")," ",RMPR11("DESCRIPTION")
108 D OK(.RMPRYN,.RMPREXC)
109 I RMPRYN'="Y" G ITEMA1
110 G ITEMX
111ITEMX Q RMPRERR
112 ;
113 ;***** QTY - Prompt for Quantity
114QTY(RMPRQTY,RMPREXC) ;
115 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
116 S RMPRQTY=$G(RMPRQTY)
117 S RMPRERR=0
118 S DIR(0)="NA^1:99999:0"
119 S DIR("A")="QUANTITY: "
120 S:RMPRQTY'="" DIR("B")=RMPRQTY
121 D ^DIR
122 I $D(DTOUT) S RMPREXC="T" G QTYX
123 I $D(DIROUT) S RMPREXC="P" G QTYX
124 I X=""!(X["^") S RMPREXC="^" G QTYX
125 S RMPRQTY=Y
126QTYX Q RMPRERR
127 ;
128 ;***** TVAL - Prompt for total $ value
129TVAL(RMPRTVAL,RMPREXC) ;
130 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
131 S RMPRTVAL=$G(RMPRTVAL)
132 S RMPRERR=0
133 S DIR(0)="NOA^0:999999:2"
134 S DIR("A")="TOTAL COST OF QUANTITY: "
135 S:RMPRTVAL'="" DIR("B")=RMPRTVAL
136 D ^DIR
137 I $D(DTOUT) S RMPREXC="T" G TVALX
138 I $D(DIROUT) S RMPREXC="P" G TVALX
139 I X["^" S RMPREXC="^" G TVALX
140 I X="" G TVALX
141 S RMPRTVAL=Y
142TVALX Q RMPRERR
143 ;
144 ;***** REO - Prompt for Re-Order Level
145REO(RMPRREO,RMPREXC) ;
146 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
147 S RMPRREO=$G(RMPRREO)
148 S RMPRERR=0
149 S DIR(0)="NOA^0::0"
150 S DIR("A")="RE-ORDER LEVEL: "
151 S:RMPRREO'="" DIR("B")=RMPRREO
152 D ^DIR
153 I $D(DTOUT) S RMPREXC="T" G REOX
154 I $D(DIROUT) S RMPREXC="P" G REOX
155 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G REOX
156 S RMPRREO=Y
157REOX Q RMPRERR
158 ;
159 ;***** VEND - Prompt for Vendor
160VEND(RMPRVEND,RMPREXC) ;
161 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
162 S RMPRVEND=$G(RMPRVEND("IEN"))
163 S RMPRERR=0
164 S DIR(0)="P^440:EMZ"
165 S DIR("A")="VENDOR"
166 S:RMPRVEND'="" DIR("B")=RMPRVEND("NAME")
167 D ^DIR
168 I $D(DTOUT) S RMPREXC="T" G VENDX
169 I $D(DIROUT) S RMPREXC="P" G VENDX
170 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G VENDX
171 S RMPRVEND("IEN")=$P(Y,"^",1)
172 S RMPRVEND("NAME")=$P(Y,"^",2)
173VENDX Q RMPRERR
174 ;
175 ;***** PVEN - Pick the current stock record to edit
176PVEN(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM,RMPR6,RMPR7,RMPREXC) ;
177 N DIR,X,Y,DA,RMPRGBL,RMPRLIN,RMPRA,RMPRERR,RMPRX,RMPRY,RMPRB
178 N RMPR7I
179 S RMPREXC=""
180 S RMPRX="",RMPRY=0
181 S RMPRLIN=0
182 S RMPRGBL=$Q(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM))
183 G PVEN1A
184PVEN1 S RMPRGBL=$Q(@RMPRGBL)
185PVEN1A I $QS(RMPRGBL,1)'=661.7 G PVEN2
186 I $QS(RMPRGBL,2)'="XSLHIDS" G PVEN2
187 I $QS(RMPRGBL,3)'=RMPRSTN G PVEN2
188 I $QS(RMPRGBL,4)'=RMPRLCN G PVEN2
189 I $QS(RMPRGBL,5)'=RMPRHCPC G PVEN2
190 I $QS(RMPRGBL,6)'=RMPRITM G PVEN2
191 S RMPRLIN=RMPRLIN+1
192 S RMPRA(RMPRLIN)=$QS(RMPRGBL,9)
193 G PVEN1
194PVEN2 I RMPRLIN=0 G PVENX
195 I RMPRLIN=1 S X=1 G PVEN3
196 W !,"Select a current Stock Record to edit...",!
197 W !,?7,"Date",?21,"Quantity",?35,"Value",?42,"Vendor"
198 S RMPRX="",RMPRLIN=0
199 F S RMPRX=$O(RMPRA(RMPRX)) Q:RMPRX="" D
200 . S RMPRLIN=RMPRLIN+1
201 . K RMPR7
202 . S RMPR7("IEN")=RMPRA(RMPRX)
203 . S RMPRERR=$$GET^RMPRPIX7(.RMPR7)
204 . W !,?2,$J(RMPRLIN,2)
205 . W ?7,$P(RMPR7("DATE&TIME"),"@",1)
206 . W ?21,$J(RMPR7("QUANTITY"),8,0)
207 . W ?30,$J(RMPR7("VALUE"),10,2)
208 . K RMPR7I
209 . S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
210 . K RMPR6
211 . S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
212 . S RMPR6("HCPCS")=RMPRHCPC
213 . S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
214 . W ?42,RMPR6("VENDOR")
215 . Q
216 K RMPR7,RMPR6
217 S DIR(0)="NAO^1:"_RMPRLIN_": "
218 S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
219 D ^DIR
220 I $D(DTOUT) S RMPREXC="T" G PVENX
221 I $D(DIROUT) S RMPREXC="P" G PVENX
222 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G PVENX
223PVEN3 S RMPR7("IEN")=RMPRA(X)
224 S RMPRERR=$$GET^RMPRPIX7(.RMPR7)
225 K RMPR7I
226 S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
227 S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
228 S RMPR6("HCPCS")=RMPRHCPC
229 S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
230PVENX Q
Note: See TracBrowser for help on using the repository browser.