source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY6.m@ 1700

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1RMPRPIY6 ;HINES OIFO/ODJ - EI - Edit Locations and Items ;10/7/02 14:46
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ;***** EI - Edit Inventory ITEM
6 ; option RMPR INV EDIT
7 ; Replaces EI option in old PIP (cf ^RMPR5NEE)
8 ; no inputs required
9 ; other than standard VISTA vars. (DUZ, etc)
10 ;
11EI N RMPRERR,RMPRSTN,RMPREXC,RMPR5,RMPR1,RMPR11,RMPRVEND,RMPRTVAL,RMPR9M
12 N RMPRQTY,RMPRREO,RMPR4,RMPR6,RMPR7,RMPR7M,RMPR6M,RMPR4M,RMPRGLAM
13 N RMPR69,RMPR6I,RMPRGLQ,RMPRLCN,RMPRUCST,RMPROVAL,RMPRHCPC,RMPR5P
14 N RMPR11M,RMPR11I,RMPR441,RMPRUNI
15 ;
16 ;***** STN - call prompt for Site/Station
17STN S RMPROVAL=$G(RMPRSTN("IEN"))
18 W @IOF S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
19 I RMPRERR G EIX
20 I RMPREXC'="" G EIX
21 I RMPROVAL'=RMPRSTN("IEN") K RMPR1,RMPR11,RMPR5,RMPRLCN
22 ;
23 ;***** HCPCS - call prompts for selecting HCPCS and Item
24HCPCS W !!,"Editing Inventory Items.",!
25 S RMPROVAL=$G(RMPR1("IEN"))
26 K RMPR1,RMPR11,RMPR5,RMPRLCN,RMPREXC,RMPRERR,RMPRUNI
27 D HCPCS^RMPRPIY7(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
28 I RMPREXC="T" G EIX
29 I RMPREXC="P" G STN
30 I RMPREXC="^" D G EIX
31 . W !,"** No HCPCS selected." H 1
32 . Q
33 I $G(RMPR11("IEN"))'="" G HCPCS4
34HCPCS3 D ITEM^RMPRPIYP(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR11,.RMPREXC)
35 I RMPREXC="T" G EIX
36 I RMPREXC="P" G HCPCS
37 I RMPREXC="^" G HCPCS
38 ;
39 ; display selected HCPCS and item and continue
40HCPCS4 W !!,"HCPCS: "_RMPR1("HCPCS")_" "_RMPR1("SHORT DESC")
41 K RMPR11I S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
42HCPCS4A K RMPR441,RMHCC
43 S RMPR441("IEN")=RMPR11I("ITEM MASTER IEN")
44 S:RMPR11I("ITEM MASTER IEN")'="" RMPRERR=$$GET^RMPRPIXD(.RMPR441)
45 D MASIT^RMPRPIY1(.RMPR441,.RMPREXC)
46 I RMPREXC="T" G EIX
47 I RMPREXC="P" G HCPCS
48 I RMPREXC="^" G HCPCS
49 I RMPR441("IEN")'=RMPR11I("ITEM MASTER IEN") D
50 . K RMPR11M
51 . S RMPR11M("IEN")=RMPR11("IEN")
52 . S RMPR11M("ITEM MASTER IEN")=RMPR441("IEN")
53 . S RMPRERR=$$UPD^RMPRPIX1(.RMPR11M)
54 . K RMPR11
55 . S RMPR11("IEN")=RMPR11M("IEN")
56 . S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
57 . S RMPR11I("ITEM MASTER IEN")=RMPR441("IEN")
58 . K RMPR441,RMPR11M
59 . Q
60 ;
61 ; edit PIP Item desc.
62HCPCS5 D ITED^RMPRPIY1(.RMPR11,.RMPREXC)
63 I RMPREXC="T" G EIX
64 I RMPREXC="^" G HCPCS
65 I RMPREXC="P" G HCPCS4A
66 ;
67 ; Lock the current stock 661.7 file at HCPCS Item level as we may be
68 ; reducing or increasing the quantity on hand
69CURSTL L +^RMPR(661.7,"XSHIDS",RMPRSTN("IEN"),RMPR11("HCPCS"),RMPR11("ITEM"))
70 ;
71 ;***** CURST - call prompt for current stock record
72CURST S RMPRLCN="" K RMPR5
73 D PVEN^RMPRPIYR(RMPRSTN("IEN"),.RMPRLCN,RMPR11("HCPCS"),RMPR11("ITEM"),.RMPR6,.RMPR7,.RMPREXC)
74 I RMPREXC="T" G EIU
75 I RMPREXC="P" D UNLOCK G HCPCS5
76 I RMPREXC="^" K RMPR6,RMPR7 G RLOC
77 I $G(RMPR7("IEN"))="" G RLOC
78 S RMPRQTY=RMPR7("QUANTITY")
79 S RMPRTVAL=RMPR7("VALUE")
80 I RMPR7("QUANTITY")<1 S RMPRUCST=0
81 E S RMPRUCST=+$J(RMPR7("VALUE")/RMPR7("QUANTITY"),0,6)
82 S:$D(RMPR7("UNIT")) RMPRUNI("IEN")=RMPR7("UNIT")
83 S:$D(RMPR7("UNIT NAME")) RMPRUNI("NAME")=RMPR7("UNIT NAME")
84 S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
85 S RMPRVEND("IEN")=RMPR6("VENDOR IEN")
86 S RMPRVEND("NAME")=RMPR6("VENDOR")
87 S RMPR5("IEN")=RMPRLCN
88 S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
89 G LOCN
90 ;
91 ;***** RLOC - if no receipt selected get def. loc. from reorder file
92RLOC D LOCN^RMPRPIYQ(RMPRSTN("IEN"),.RMPR11,.RMPR5,.RMPREXC)
93 I RMPREXC="T" G EIU
94 G LOCN
95 ;
96 ;***** LOCN - call prompt for Location
97LOCN K RMPR5P M RMPR5P=RMPR5
98 S RMPRLCN=$$LOC1^RMPRPIYB(RMPRSTN("IEN"))
99 I RMPRLCN D G REO
100 . I $G(RMPR5("IEN"))="" D
101 .. S RMPR5("IEN")=RMPRLCN
102 .. S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
103 .. Q
104 . W !,"Location: "_RMPR5("NAME")
105 . Q
106LOCN1 W ! D LOCNM^RMPRPIY7(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
107 I RMPREXC="P" D UNLOCK G HCPCS5
108 I RMPREXC="^" G EIU
109 I RMPREXC="T" G EIU
110 S RMPRLCN=RMPR5("IEN")
111 ;
112 ;***** REO - call prompt for Re-Order Quantity (661.4)
113REO K RMPR4
114 S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPRSTN("IEN"),RMPRLCN,RMPR11("HCPCS"),RMPR11("ITEM"),""))
115 I RMPR4("IEN")="" D
116 . S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPRSTN("IEN"),RMPR5("IEN"),RMPR11("HCPCS"),RMPR11("ITEM"),""))
117 . Q
118 I RMPR4("IEN")="" D
119 . S RMPR4("RE-ORDER QTY")=0
120 . Q
121 E D
122 . S RMPRERR=$$GET^RMPRPIX4(.RMPR4)
123 . Q
124 S RMPRREO=RMPR4("RE-ORDER QTY")
125REO1 ;
126 I '$D(RMPR5P) K RMPR5P M RMPR5P=RMPR5
127 D REO^RMPRPIY5(.RMPRREO,.RMPREXC)
128 I RMPREXC="P" D UNLOCK G HCPCS5
129 I RMPREXC="^" G EIU
130 I RMPREXC="T" G EIU
131 I RMPRREO'=RMPR4("RE-ORDER QTY")!(RMPR4("IEN")="")!(RMPR5("IEN")'=RMPR5P("IEN")) D
132 . K RMPR4M
133 . S RMPR4M("RE-ORDER QTY")=RMPRREO
134 . I RMPR4("IEN")="" D
135 .. S RMPRERR=$$CRE^RMPRPIX4(.RMPR4M,.RMPR11,.RMPR5)
136 .. Q
137 . E D
138 .. S RMPR4M("IEN")=RMPR4("IEN")
139 .. S RMPRERR=$$UPD^RMPRPIX4(.RMPR4M,,)
140 .. Q
141 . Q
142 I '$D(RMPR6) G TRANSX ;only editing reorder level
143 ;
144 ;***** SRC - call prompt for SOURCE.
145SRC S (RMPRBCK,RMPRSRC)=$P(^RMPR(661.11,RMPR11("IEN"),0),U,5)
146 D SRC^RMPRPIY5(.RMPRSRC,.RMPREXC)
147 I RMPREXC="P" G SRC
148 I RMPREXC="^" D UNLOCK G HCPCS
149 I RMPREXC="T" G EIU
150 I RMPRSRC'=RMPRBCK S $P(^RMPR(661.11,RMPR11("IEN"),0),U,5)=RMPRSRC
151 ;***** QTY - call prompt for Quantity
152QTY D QTY^RMPRPIY5(.RMPRQTY,.RMPREXC)
153 I RMPREXC="P" G REO
154 I RMPREXC="^" D UNLOCK G HCPCS
155 I RMPREXC="T" G EIU
156 S RMPRQTY=+$G(RMPRQTY)
157 ;
158 ;***** UCST - call prompt for Unit Cost
159UCST D UCST^RMPRPIY5(.RMPRUCST,.RMPREXC)
160 I RMPREXC="P" G QTY
161 I RMPREXC="^" D UNLOCK G HCPCS
162 I RMPREXC="T" G EIU
163 S RMPRUCST=$J(RMPRUCST,0,2)
164 ;
165 ;***** TVAL - Total Value - use if Unit Cost not used
166TVAL I RMPRUCST D G VEND
167 . S RMPRTVAL=$J(RMPRQTY*RMPRUCST,0,2)
168 . W !,"TOTAL COST OF QUANTITY: "_RMPRTVAL
169 . Q
170 D TVAL^RMPRPIY5(.RMPRTVAL,.RMPREXC)
171 I RMPREXC="P" G UCST
172 I RMPREXC="^" D UNLOCK G HCPCS
173 I RMPREXC="T" G EIU
174 ;
175 ;***** VEND - call prompt for Vendor
176VEND D VEND^RMPRPIY5(.RMPRVEND,.RMPREXC)
177 I RMPREXC="P" G UCST
178 I RMPREXC="^" D UNLOCK G HCPCS
179 I RMPREXC="T" G EIU
180 ;
181 ;
182 ;***** UNIT - call prompt for UNIT OF ISSUE
183UNIT D UNIT^RMPRPIY5(.RMPRUNI,.RMPREXC)
184 I RMPREXC="P" G UCST
185 I RMPREXC="^" D UNLOCK G HCPCS
186 I RMPREXC="T" G EIU
187 S RMPRUNI("UNIT")=RMPRUNI("IEN")
188 ;
189 ;***** TRANS - Modify current stock record
190TRANS K RMPR7M,RMPR6M
191 ;
192 I $G(RMHCC) D TRANS^RMPRPIXF G HAL
193 ;
194 K RMPR6I
195 S RMPRERR=$$ETOI^RMPRPIX6(.RMPR6,.RMPR6I)
196 ;
197 ;if unit of issue changed
198 I RMPRUNI("UNIT")'=RMPR7("UNIT") S RMPR7M("UNIT")=RMPRUNI("UNIT") D
199 . S RMPR7M("IEN")=RMPR7("IEN")
200 . S RMPRERR=$$UPD^RMPRPIX7(.RMPR7M,)
201 ; Modify Location in 661.6 and 661.7 if changed
202 I RMPR6I("LOCATION")'=RMPR5("IEN") D
203 . S RMPR6M("LOCATION")=RMPR5("IEN")
204 . S RMPR6M("IEN")=RMPR6("IEN")
205 . S RMPRERR=$$UPD^RMPRPIX6(.RMPR6M,)
206 . S RMPR7M("LOCATION")=RMPR5("IEN")
207 . S RMPR7M("IEN")=RMPR7("IEN")
208 . S RMPRERR=$$UPD^RMPRPIX7(.RMPR7M,)
209 . K RMPR6M,RMPR7M
210 . Q
211 ;
212 ; Modify Quantity or Value in current stock 661.7 record, the
213 ; transaction record 661.6 and running balance 661.9, if changed
214 I +RMPRQTY'=+RMPR7("QUANTITY")!(+RMPRTVAL'=+RMPR7("VALUE")) D
215 . K RMPR69,RMPR9M
216 . I RMPR6I("TRAN TYPE")=9 D
217 .. S RMPR69("TRANS IEN")=RMPR6("IEN")
218 .. S RMPRERR=$$GET^RMPRPIXB(.RMPR69)
219 .. Q
220 . S (RMPR9M("TQTY"),RMPR9M("TCST"),RMPRGLQ,RMPRGLAM)=0
221 . I +RMPRQTY'=+RMPR7("QUANTITY") D Q:RMPR7M("QUANTITY")<0
222 .. S RMPR6M("QUANTITY")=RMPRQTY
223 .. S RMPRGLQ=RMPRQTY-RMPR7("QUANTITY")
224 ..; S RMPR7M("QUANTITY")=RMPR7("QUANTITY")+RMPRGLQ
225 .. S RMPR7M("QUANTITY")=RMPRQTY
226 .. S RMPR9M("TQTY")=RMPRGLQ
227 .. S:$D(RMPR69) RMPR69("GAIN/LOSS")=RMPR69("GAIN/LOSS")+RMPRGLQ
228 .. Q
229 . I +RMPRTVAL'=+RMPR7("VALUE") D
230 .. S RMPR6M("VALUE")=RMPRTVAL
231 .. S RMPRGLAM=RMPRTVAL-RMPR7("VALUE")
232 .. S RMPR7M("VALUE")=RMPR7("VALUE")+RMPRGLAM,RMPR7M("VALUE")=$J(RMPR7M("VALUE"),0,2)
233 .. S RMPR9M("TCST")=RMPRGLAM
234 .. S:$D(RMPR69) RMPR69("GAIN/LOSS VALUE")=RMPR69("GAIN/LOSS VALUE")+RMPRGLAM
235 .. Q
236 . S RMPR7M("IEN")=RMPR7("IEN")
237 . S RMPRERR=$$UPD^RMPRPIX7(.RMPR7M,)
238 . S RMPR6M("IEN")=RMPR6("IEN")
239 . S RMPRERR=$$UPD^RMPRPIX6(.RMPR6M,)
240 . I $D(RMPR69) S RMPRERR=$$UPD^RMPRPIXB(.RMPR69)
241 . S RMPR9M("STA")=RMPRSTN("IEN")
242 . S RMPR9M("HCP")=RMPR11("HCPCS")
243 . S RMPR9M("ITE")=RMPR11("ITEM")
244 . S RMPRERR=$$DTIEN^RMPRPIX6(.RMPR6)
245 . S RMPR9M("RDT")=$P(RMPR6("DATE&TIME"),".",1)
246 . S RMPRERR=$$UPCR^RMPRPIXJ(.RMPR9M)
247 . K RMPR7M,RMPR6M,RMPR9M
248 . Q
249 I $D(RMPR7M("QUANTITY")),RMPR7M("QUANTITY")<1 D G QTY
250 . W !,"The quantity cannot be allowed because it would cause a",!
251 . W "negative on hand quantity.",!
252 . W "Please check your inventory and use the reconciliation option",!
253 . W "as needed.",!
254 . Q
255TRANSX I 'RMPRERR D
256 . W !!,"** Item "
257 . W RMPR11("HCPCS-ITEM")
258 . W " was "
259 . W "Edited by "
260 . W $$GETUSR^RMPRPIU0(DUZ)
261 . W:$D(RMPRGLQ) ": ("_$S(RMPRGLQ>0:"+",1:"")_RMPRGLQ_")"
262 . W " @ Location ",RMPR5("NAME")
263 . Q
264 E D
265 . W !!,"** The Item could not be modified due to a problem - please contact support"
266 . Q
267 D UNLOCK
268HAL H 2
269 K RMPRTVAL,RMPRUCST,RMPR6,RMPR7,RMPRVEND,RMPRQTY,RMPRREO,RMPRGLQ,RMPRGLAM
270 G HCPCS
271 ;
272 ;***** exit points
273EIU D UNLOCK
274EIX D KILL^XUSCLEAN
275 Q
276UNLOCK L -^RMPR(661.7,"XSHIDS",RMPRSTN("IEN"),RMPR11("HCPCS"),RMPR11("ITEM"))
277 Q
Note: See TracBrowser for help on using the repository browser.