source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYS.m@ 1796

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

initial load of FOIAVistA 6/30/08 version

File size: 9.3 KB
Line 
1RMPRPIYS ;HINCIO/ODJ - RC - PIP Receive Stock ;10/8/02 13:11
2 ;;3.0;PROSTHETICS;**61,108,128**;Feb 09, 1996
3 Q
4 ;
5 ;***** PB - Print Bar Code labels
6 ; RMPR INV BAR CODE
7 ; Callable from VISTA menu, no vars required other than
8 ; global VISTA vars (DUZ, etc)
9 ;
10PB N RMPRERR,RMPRSTN,RMPRLCN,RMPREXC,RMPR1,RMPR11,RMPROVAL,RMPRNLAB
11 N RMPR6,RMPR7,RMPR7I,RMPRBARC,RMPRITXT,RMPRBCP,RMPRQ,RMPRIOP
12 ;
13 ;***** STN - prompt for Site/Station
14STN S RMPROVAL=$G(RMPRSTN("IEN"))
15 W @IOF S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
16 I RMPRERR G PBX
17 I RMPREXC'="" G PBX
18 I RMPROVAL'=RMPRSTN("IEN") K RMPR1,RMPR11
19 ;
20 ;***** HCPCS - prompt for HCPCS and Item
21HCPCS W !!,"Print Bar code Labels for current inventory...",!
22HCPCS2 D HCPCS^RMPRPIY7(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
23 I RMPREXC="T" G PBX
24 I RMPREXC="P" G STN
25 I RMPREXC="^" D G PBX
26 . W !,"** No HCPCS selected..." H 1
27 . Q
28 I $G(RMPR11("IEN"))'="" G HCPCS3A
29HCPCS3 D ITEM^RMPRPIYP(RMPRSTN("IEN"),RMPR1("HCPCS"),.RMPR11,.RMPREXC)
30 I RMPREXC="T" G PBX
31 I RMPREXC="P"!(RMPREXC="^") G HCPCS
32HCPCS3A S RMPR11("STATION")=RMPRSTN("IEN")
33 S RMPR11("STATION IEN")=RMPRSTN("IEN")
34 ;
35 ; display selected HCPCS and item and continue
36HCPCS4 W !!,"HCPCS: "_RMPR1("HCPCS")_" "_RMPR1("SHORT DESC")
37 W !!,"IFCAP Item: ",RMPR11("ITEM MASTER")
38 W !!,"PIP Item desc.: ",RMPR11("DESCRIPTION")
39 ;
40 ;***** CURST - call prompt for current stock record
41CURST S RMPRLCN=""
42 D PVEN^RMPRPIYR(RMPRSTN("IEN"),.RMPRLCN,RMPR11("HCPCS"),RMPR11("ITEM"),.RMPR6,.RMPR7,.RMPREXC)
43 I RMPREXC="T" G PBX
44 I RMPREXC="P" G HCPCS3
45 I RMPREXC="^" G HCPCS
46 I '+$G(RMPR7("QUANTITY")) D G HCPCS2
47 . W !,"This item is not currently in stock.",!!
48 . Q
49 K RMPR7I
50 S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
51 S RMPRBARC=RMPR11("HCPCS")_"-"_$P(RMPR7I("DATE&TIME"),".",1)_$P(RMPR7I("DATE&TIME"),".",2)
52 S RMPRITXT("DATE")=$E(RMPR7I("DATE&TIME"),4,5)_"/"_$E(RMPR7I("DATE&TIME"),6,7)_"/"_(1700+$E(RMPR7I("DATE&TIME"),1,3))
53 S RMPRITXT("ITEM")=RMPR11("HCPCS-ITEM")
54 S RMPRITXT("MASTER DESC")=RMPR11("ITEM MASTER")
55 S RMPRITXT("ITEM DESC")=RMPR11("DESCRIPTION")
56 S RMPRITXT("UNIT PRICE")=+$J(RMPR7("VALUE")/RMPR7("QUANTITY"),0,2)
57 S RMPRITXT("VENDOR")=RMPR6("VENDOR")
58 S RMPRITXT("LOCATION")=RMPR7("LOCATION")
59 ;
60 ;***** NLAB - call prompt for number of labels to print
61NLAB S RMPRNLAB=RMPR7("QUANTITY")
62 W ! D NLABP(.RMPRNLAB,RMPR7("QUANTITY"),.RMPREXC)
63 I RMPREXC="T" G PBX
64 I RMPREXC="P" G HCPCS
65 I RMPREXC="^" G HCPCS
66 ;
67 ;***** SELP - call prompt for bar code print device
68SELP D PRINT G HCPCS
69 G HCPCS
70PBX D KILL^XUSCLEAN
71 Q
72 ;
73 ;***** PRINT - print bar code labels
74 ; requires RMPRNLAB (number of labels) and
75 ; RMPRBCP (bar code printer name) to be set
76 ; RMPRBARC (bar code to print)
77 ; RMPRIOP (the device to open)
78PRINT I '$D(RMPRNLAB) S RMPRNLAB=1
79 ;allows queing of bar code labels
80SELD S %ZIS("A")="Select Bar Code Printer: "
81 S %ZIS="QM" K IOP W ! D ^%ZIS G:POP PRINTX
82 I $G(IOST)'["P-ZEBRA" D
83 . W !!,"** WARNING - This is NOT a Zebra Bar Code Printer!!",!!
84 I '$D(IO("Q")) U IO G PNOW
85 K IO("Q") S ZTDESC="PRINT BAR CODE LABELS",ZTRTN="PNOW^RMPRPIYS"
86 S ZTIO=ION,ZTSAVE("RMPRBARC")="",ZTSAVE("RMPRITXT(")=""
87 S ZTSAVE("RMPRNLAB")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPRSTN(")=""
88 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 2 G PRINTC
89 ;
90PNOW ;jump here if not queued.
91 D ZPLII^RMPRPI11(RMPRBARC,.RMPRITXT,RMPRNLAB)
92 S IONOFF=1
93PRINTC D ^%ZISC K IONOFF
94PRINTX Q
95 ;
96 ;***** NLABP - Number of labels prompt
97NLABP(RMPRNLAB,RMPRMAX,RMPREXC) ;
98 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
99 S RMPRNLAB=$G(RMPRNLAB)
100 S RMPRERR=0
101 S DIR(0)="NAO^1:"_RMPRMAX_":0"
102 S DIR("A")="Number of Labels to print: "
103 S:RMPRNLAB'="" DIR("B")=RMPRNLAB
104 S DIR("??")="^D NLABPH2^RMPRPIYS"
105 D ^DIR
106 I $D(DTOUT) S RMPREXC="T" G NLABPX
107 I $D(DIROUT) S RMPREXC="P" G NLABPX
108 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G NLABPX
109 S RMPREXC=""
110 S RMPRNLAB=+Y
111NLABPX Q
112NLABPH2 W "Type in the number of bar code labels you want to print for the",!
113 W "inventory item you have selected.",!
114 Q
115 ;
116 ;***** BARC - bar code prompt
117BARC(RMPRBARC,RMPREXC) ;
118 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
119 S RMPRBARC=""
120 S RMPREXC=""
121 S RMPRERR=0
122 S DIR(0)="FAO"
123 S DIR("A")="Scan in item bar code: "
124 S DIR("?")="^D BARCH^RMPRPIYS"
125BARC1 D ^DIR
126 I $D(DTOUT) S RMPREXC="T" G BARCX
127 I $D(DIROUT) S RMPREXC="P" G BARCX
128 I X["^"!($D(DUOUT)) S RMPREXC="^" G BARCX
129 I X="",$G(REDIT) G BARCX
130 I X="" G BARC1
131 S RMPRBARC=X
132BARCX Q
133BARCH W "If you have access to a bar code scanner, use it to scan the item bar code now.",!
134 W "Don't press the [Enter] key as the scanner should do this automatically.",!
135 W "If the scanner cannot read the bar code, type in the character sequence",!
136 W "immediately below the bar code.",!
137 ;W "If there is no bar code or you prefer to enter the transaction manually",!
138 ;W "leave this prompt blank.",!
139 Q
140 ;
141 ;***** SCAN - scan bar code and set up stock issue vars.
142 ; (to be called by RMPRPIYI (too big))
143SCAN K RMPR7,RMPR7I,RMPR1,RMPR1I,RMPR11,RMPR11I,RMPR6,RMDAHC,RMITQTY
144SCAN1 D BARC(.RMPRBARC,.RMPREXC)
145 I RMPREXC'="" S RMPRBARC="" G SCANX
146 I RMPRBARC="" G SCANX
147 S RMPRBARC=$$UPCASE(RMPRBARC)
148 ;
149 ; If we get a good bar code then populate all the fields and go
150 ; straight to the Post/Edit prompt
151 K RMPR7
152 S (RMPR7("STATION"),RMPRSTN)=RMPR("STA")
153 S RMPR7("HCPCS")=$P(RMPRBARC,"-",1)
154 S RMDAHC=$O(^RMPR(661.1,"B",RMPR7("HCPCS"),0))
155 I $G(RMDAHC),$D(^RMPR(661.1,RMDAHC,0)),($P(^RMPR(661.1,RMDAHC,0),U,5)'=1) S RMDAHC=$P(^RMPR(661.1,RMDAHC,0),U,3)
156 I '$G(RMDAHC) W !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..." G SCAN
157 S RMPR7("DATE&TIME")=$E($P(RMPRBARC,"-",2),1,7)_"."_$E($P(RMPRBARC,"-",2),8,$L(RMPRBARC))
158 ;
159 ; look up current stock record with bar coded key fields
160 S RMPRERR=$$SCAN^RMPRPIUA(.RMPR7,.RMPREXC)
161 I $G(RMPR7("IEN"))="" W !,"*** The Item scanned is not available, please update your inventory !!!" G SCAN1
162 I RMPRERR D SCANE G SCAN1
163 S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
164 I RMPRERR D SCANE G SCAN1
165 S R1("DATE&TIME")=$G(RMPR7I("DATE&TIME"))
166 S $P(R1(0),U,8)=$G(RMPR7I("UNIT"))
167 ;
168 ; set vars. for HCPCS
169 K RMPR1,RMPR1I
170 S RMPR1("HCPCS")=RMPR7("HCPCS")
171 S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
172 I RMPRERR D SCANE G SCAN1
173 S RMPRERR=$$HPETOI^RMPRPIX1(.RMPR1,.RMPR1I)
174 I RMPRERR D SCANE G SCAN1
175 ;
176 ; set vars. for Item
177 K RMPR11,RMPR11I
178 S RMPR11("STATION")=RMPR("STA")
179 S RMPR11("HCPCS")=RMPR7("HCPCS")
180 S RMPR11("ITEM")=RMPR7("ITEM")
181 S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
182 I RMPRERR D SCANE G SCAN1
183 S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11,.RMPR11I)
184 I RMPRERR D SCANE G SCAN1
185 I RMPR11I("ITEM MASTER IEN")="" D G SCAN1
186 . W !,"This item is not associated with an IFCAP Item.",!
187 . W "Please use the Edit Inventory option before trying to issue this item."
188 . W !
189 . Q
190 ;S RMDAHC=RMPR1("IEN")
191 D CPT(RMDAHC_"^"_$P(R1(0),U,4)_"^"_RMPR11I("SOURCE")_"^660")
192 I RMPREXC="T" G SCANX
193 I RMPREXC'="" G SCAN1
194 ;
195 ; get Vendor
196 S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
197 S RMPR6("HCPCS")=RMPR7("HCPCS")
198 S RMPR6("SEQUENCE")=RMPR7("SEQUENCE")
199 S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
200 I RMPRERR D SCANE G SCAN1
201 S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
202 I RMPRERR D SCANE G SCAN1
203 S $P(R1(0),U,9)=RMPR6("VENDOR IEN")
204 S $P(R3("D"),U,9)=RMPR6("VENDOR")
205 ;
206 ; set vars for issue
207 S RMCPTC=""
208 I $G(RMDAHC),$D(^RMPR(661.1,RMDAHC,0)) S RMCPTC=$P(^RMPR(661.1,RMDAHC,0),U,4)
209 S $P(R1(1),U,4)=RMDAHC
210 S $P(R1(0),U,22)=$G(RMCPTC)
211 S $P(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
212 S (RMHCNEW,RMHCDA)=RMDAHC
213 S RMITDA=RMPR11("IEN")
214 S RMHCPC=RMPR11("HCPCS")
215 S RMIT=RMPR11("HCPCS-ITEM")
216 S RDESC=RMPR1("SHORT DESC")
217 S $P(R3("D"),U,14)=RMPR11("SOURCE")
218 S RMSO=RMPR11I("SOURCE")
219 S $P(R1(0),U,14)=RMSO
220 S $P(R3("D"),U,6)=RMPR11("ITEM MASTER")
221 S $P(R1(0),U,6)=RMPR11I("ITEM MASTER IEN")
222 S $P(R1(2),U,1)=RMIT
223 S $P(R1(2),U,2)=RMPR11("DESCRIPTION")
224 S RMLOC=RMPR7I("LOCATION"),RMUBA=0,RMPR11("ITEM")=$P(RMIT,"-",2)
225 S RMPR11("LOCATION")=RMLOC,RMPR11("STATION")=RMPRSTN
226 I '$G(RMPR11("LOCATION")) S RMUBA=RMPR7("QUANTITY")
227 S:'$G(RMUBA) RMUBA=$$BAL^RMPRPIX7(.RMPR11)
228 S RMITQTY=RMPR7("QUANTITY")
229 K RMPR5
230 S RMPR5("IEN")=RMLOC
231 S RMPRUCST=RMPR7("VALUE")/RMPR7("QUANTITY")
232 S $P(R1(0),U,16)=$J(RMPRUCST,0,2)
233 S $P(R3("D"),U,16)=$J(RMPRUCST,0,2)
234 S $P(R1(0),U,7)=1 ;qty.
235 S $P(R1(0),U,11)="" ;serial num
236 S $P(R1(0),U,24)="" ;lot num
237 S $P(R1(0),U,18)="" ;remarks
238SCANX Q
239SCANE W !,"A problem has occurred with the scan, please try again.",!
240 Q
241 ;
242 ;***** CPT - prompt for CPT modifier
243 ; (extension of RMPRPIYI and to be used only by that routine)
244CPT(RDA) ;
245 N DIC,Y,RQUIT,X,DA,DIR,DUOUT,DTOUT
246 N RMPR1,RMPR11,RMPR11I,RMPR7,RMPR7I
247 S RMPREXC=""
248 D:$D(RMCPT) CHK^RMPRED5
249 W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6)
250 I RMHCOLD'=RMDAHC D CPT^RMPRCPTU(RDA)
251 I $D(DUOUT) S RMPREXC="^" G CPTX
252 I $D(DTOUT) S RMPREXC="T" G CPTX
253 S $P(R1(1),U,6)=$G(RMCPT)
254 W:$G(REDIT) !,"NEW CPT MODIFIER: ",$G(RMCPT)
255 I RMHCOLD'="",(RMHCOLD=RMDAHC),$G(REDIT) D
256 .S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
257 .I $G(Y) D
258 ..D CPT^RMPRCPTU(RDA)
259 ..I $D(DUOUT) S RMPREXC="^"
260 ..I $D(DTOUT) S RMPREXC="T"
261 ..W:RMCPT=$P(R1(1),U,6) !!,"***Based on the information given above, CPT modifier string has not changed!!!",!
262 ..W:RMCPT'=$P(R1(1),U,6) !,"NEW CPT MODIFIER: ",$G(RMCPT)
263 ..S $P(R1(1),U,6)=$G(RMCPT)
264CPTX Q
265UPCASE(RMPRSTR) ;
266 Q $TR(RMPRSTR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.