source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m@ 1755

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

initial load of FOIAVistA 6/30/08 version

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