source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYG.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1RMPRPIYG ;HINCIO/ODJ - RC - PIP Receive Stock ;3/8/01
2 ;;3.0;PROSTHETICS;**61,132**;Feb 09, 1996;Build 13
3 Q
4 ;
5 ;***** RC - Replaces RC option in old PIP
6 ; RMPR INV RECEIVE
7 ; cf. REC^RMPR5NOR
8 ; Callable from VISTA menu, no vars required other than
9 ; global VISTA vars (DUZ, etc)
10 ;
11RC N RMPRERR,RMPRSTN,RMPRLCN,RMPREXC,RMPR5,RMPR1,RMPR11,RMPROVAL
12 N RMPRVEND,RMPRQTY,RMPRTVAL,RMPR4,RMPRUCST,RMPRQ,RMPRIOP,RMPRNLAB
13 N RMPRBARC,RMPRITXT,RMPRBCP,RMPR41,RMPR41N,RMPRYN
14 ;
15 ;***** STN - prompt for Site/Station
16STN S RMPROVAL=$G(RMPRSTN("IEN"))
17 W @IOF S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
18 I RMPRERR G RCX
19 I RMPREXC'="" G RCX
20 I RMPROVAL'=RMPRSTN("IEN") K RMPR1,RMPR11
21 S RMPR("NAME")=RMPRSTN("SITE NAME")
22 ;
23 ;***** HCPCS - prompt for HCPCS
24HCPCS W !!,"Receive an Item from Supply, Vendor or Veteran.",!
25 K RMPR6,RMPRTVAL,RMPRQTY,RMPRUCST,RMPRBCP,RMPRQ,RMPRIOP,RMPRNLAB
26 K RMPRBARC,RMPRITXT,RMPR41N,RMPR41,RMPRVEND,RMPR1,RMPR11,RMPRUNI
27HCPCS2 D HCPCS^RMPRPIY7(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
28 I RMPREXC="T" G RCX
29 I RMPREXC="P"!(RMPREXC="^") D G RCX
30 . W !,"** No HCPCS selected." H 1
31 . Q
32 I $G(RMPR11("IEN"))'="" G HCPCS4
33HCPCS3 D ITEM^RMPRPIYP(RMPRSTN("IEN"),RMPR1("HCPCS"),.RMPR11,.RMPREXC)
34 I RMPREXC="T" G RCX
35 I RMPREXC="P"!(RMPREXC="^") G HCPCS
36 S RMPR11("STATION")=RMPRSTN("IEN")
37 S RMPR11("STATION IEN")=RMPRSTN("IEN")
38 ;
39 ; display selected HCPCS and item and continue
40HCPCS4 W !!,"HCPCS: "_$G(RMPR1("HCPCS"))_" "_$G(RMPR1("SHORT DESC"))
41 W !!,"IFCAP Item: ",$G(RMPR11("ITEM MASTER"))
42 W !!,"PIP Item desc.: ",$G(RMPR11("DESCRIPTION"))
43 ;
44 ; call module to display and select orders
45PORD D PORD^RMPRPIYY(RMPRSTN("IEN"),RMPR1("HCPCS"),RMPR11("ITEM"),.RMPR41,.RMPREXC)
46 I RMPREXC="P" G HCPCS
47 I RMPREXC="T" G RCX
48 I RMPREXC="",+$G(RMPR41("IEN")) D
49 . S RMPRQTY=RMPR41("BALANCE QTY")
50 . K RMPRVEND
51 . S RMPRVEND("IEN")=RMPR41("VENDOR IEN")
52 . Q
53 ;
54 ;***** QTY - call prompt for Quantity
55QTY K RMPR41N("ORDER QTY")
56 W ! D QTY^RMPRPIY5(.RMPRQTY,.RMPREXC)
57 I RMPREXC="T" G RCX
58 I RMPREXC="^" D MESS G HCPCS
59 I RMPREXC="P" G HCPCS
60 S RMPRQTY=+$G(RMPRQTY)
61 I 'RMPRQTY D G HCPCS
62 . W !,"No quantity entered!"
63 . H 3
64 . Q
65 I +$G(RMPR41("IEN")),RMPRQTY>RMPR41("BALANCE QTY") G QTYA
66 G UCST
67 ;
68 ; If receive quantity is greater than o/s order balance ask if
69 ; changing the order qty
70QTYA D YNQTY(.RMPRYN,.RMPREXC)
71 I RMPREXC="T" G RCX
72 I RMPREXC="^" D MESS G HCPCS
73 I RMPREXC="P" G QTY
74 I RMPRYN="N" G QTY
75 S RMPR41N("ORDER QTY")=RMPR41("ORDER QTY")+(RMPRQTY-RMPR41("BALANCE QTY"))
76 ;
77 ;***** UCST - call prompt for Unit Cost
78UCST D UCST^RMPRPIY5(.RMPRUCST,.RMPREXC)
79 I RMPREXC="P" G QTY
80 I RMPREXC="^" D MESS G HCPCS
81 I RMPREXC="T" G RCX
82 S RMPRUCST=+$G(RMPRUCST)
83 ;
84 ;***** TVAL - Total Value - use if Unit Cost not used
85TVAL I RMPRUCST D G VEND
86 . S RMPRTVAL=$J(RMPRQTY*RMPRUCST,0,2)
87 . W !,"TOTAL COST OF QUANTITY: "_RMPRTVAL
88 . Q
89 D TVAL^RMPRPIY5(.RMPRTVAL,.RMPREXC)
90 I RMPREXC="P" G UCST
91 I RMPREXC="^" D MESS G HCPCS
92 I RMPREXC="T" G RCX
93 ;
94 ;***** VEND - prompt for Vendor
95VEND K RMPR41N("VENDOR IEN")
96 D VEND^RMPRPIY5(.RMPRVEND,.RMPREXC)
97 I RMPREXC="T" G RCX
98 I RMPREXC="^" D MESS G HCPCS
99 I RMPREXC="P" G UCST
100 I RMPRVEND("IEN")=$G(RMPR41("VENDOR IEN")) G UNIT
101 ;
102 ;***** VENDA - vendor not same as order vendor so asK if changing
103 D YNVND(.RMPRYN,.RMPREXC)
104 I RMPREXC="T" G RCX
105 I RMPREXC="^" D MESS G HCPCS
106 I RMPREXC="P" G VEND
107 I RMPRYN="N" G UNIT
108 S RMPR41N("VENDOR IEN")=RMPRVEND("IEN")
109 ;
110 ;***** UNIT - call prompt for UNIT OF ISSUE
111UNIT D UNIT^RMPRPIY5(.RMPRUNI,.RMPREXC)
112 I RMPREXC="P" G UCST
113 I RMPREXC="^" D MESS G HCPCS
114 I RMPREXC="T" G RCX
115 S RMPRUNI("UNIT")=RMPRUNI("IEN")
116 ;
117 ;***** LOCN - prompt for location (if more than 1)
118LOCN S RMPRLCN=$$LOC1^RMPRPIYB(RMPRSTN("IEN"))
119 I RMPRLCN D G TRANS
120 . K RMPR5
121 . S RMPR5("IEN")=RMPRLCN
122 . S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
123 . W !,"Location: "_RMPR5("NAME")
124 . Q
125 D LOCNM^RMPRPIY7(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
126 I RMPREXC="T" G RCX
127 I RMPREXC="^" D MESS G HCPCS
128 I RMPREXC="P" G UCST
129 ;
130 ;***** TRANS - Now create receipt transaction
131TRANS S RMPR11("STATION")=RMPRSTN("IEN")
132 S RMPR11("STATION IEN")=RMPRSTN("IEN")
133 I '$D(^RMPR(661.4,"ASLHI",RMPRSTN("IEN"),RMPR5("IEN"),RMPR11("HCPCS"),RMPR11("ITEM"))) D
134 . S RMPR4("RE-ORDER QTY")=0
135 . S RMPRERR=$$CRE^RMPRPIX4(.RMPR4,.RMPR11,.RMPR5)
136 . Q
137 S RMPR11("STATION")=RMPRSTN("IEN")
138 S RMPR11("STATION IEN")=RMPRSTN("IEN")
139 S RMPR6("QUANTITY")=RMPRQTY
140 S RMPR6("VALUE")=RMPRTVAL
141 S RMPR6("VENDOR")=RMPRVEND("IEN")
142 S RMPR6("UNIT")=RMPRUNI("UNIT")
143 I $D(RMPR41N("ORDER QTY")) S RMPR41("ORDER QTY")=RMPR41N("ORDER QTY")
144 I $D(RMPR41N("VENDOR IEN")) S RMPR41("VENDOR IEN")=RMPR41N("VENDOR IEN")
145 S RMPRERR=$$REC^RMPRPIU8(.RMPR6,.RMPR11,.RMPR5,1,.RMPR41) ;receipt API
146 I RMPRERR D G RCX
147 . W !!,"** Item could not be received, please contact support."
148 . H 3
149 . Q
150 E D
151 . W !!,"** Item has been received and inventory updated."
152 . W !," If you are using barcoding you should now print labels"
153 . W !," for the items received.",!
154 . Q
155 ;
156 ;***** NLAB - call prompt for number of labels to print
157NLAB S RMPRNLAB=RMPR6("QUANTITY")
158 W ! D NLABP^RMPRPIYS(.RMPRNLAB,RMPR6("QUANTITY"),.RMPREXC)
159 I RMPREXC="T" G RCX
160 I RMPREXC="P" G RCNX
161 I RMPREXC="^" G RCNX
162 I RMPRNLAB=0 G RCNX
163 ;
164 ;***** SELP - call prompt for barcode print device
165SELP ;W ! D SELP^RMPRPI11(.RMPRBCP,.RMPREXC,.RMPRQ,.RMPRIOP)
166 ;I RMPREXC'="" G NLAB
167 S RMPRBARC=RMPR11("HCPCS")_"-"_$P(RMPR6("DATE&TIME"),".",1)_$P(RMPR6("DATE&TIME"),".",2)
168 S RMPRITXT("DATE")=$E(RMPR6("DATE&TIME"),4,5)_"/"_$E(RMPR6("DATE&TIME"),6,7)_"/"_(1700+$E(RMPR6("DATE&TIME"),1,3))
169 S RMPRITXT("ITEM")=RMPR11("HCPCS-ITEM")
170 S RMPRITXT("ITEM DESC")=RMPR11("DESCRIPTION")
171 S RMPRITXT("MASTER DESC")=RMPR11("ITEM MASTER")
172 S RMPRITXT("UNIT PRICE")=RMPRUCST
173 S RMPRITXT("VENDOR")=RMPRVEND("NAME")
174 S RMPRITXT("LOCATION")=RMPR5("NAME")
175 D PRINT^RMPRPIYS
176RCNX K RMPR6,RMPRTVAL,RMPRQTY,RMPRUCST,RMPRBCP,RMPRQ,RMPRIOP,RMPRNLAB
177 K RMPRBARC,RMPRITXT,RMPR41N,RMPR41,RMPRVEND
178 G HCPCS
179RCX D KILL^XUSCLEAN
180 Q
181 ;
182MESS W !!,"*** NOTHING RECEIVE !!!",!
183 Q
184 ;
185 ; Y/N Prompt to confirm change of order qty
186YNQTY(RMPRYN,RMPREXC) ;
187 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
188 S RMPRYN="N"
189 S RMPREXC=""
190 S DIR(0)="Y"
191 S DIR("A",1)="The entered quantity is greater than the outstanding balance ("_RMPR41("BALANCE QTY")_")"
192 S DIR("A",2)="still on order."
193 S DIR("A")="Do you want to increase the original order quantity"
194 D ^DIR
195 I $D(DTOUT) S RMPREXC="T" G YNQTYX
196 I $D(DIROUT) S RMPREXC="P" G YNQTYX
197 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G YNQTYX
198 S:Y RMPRYN="Y"
199YNQTYX Q
200 ;
201 ; Y/N Prompt to confirm change of order Vendor
202YNVND(RMPRYN,RMPREXC) ;
203 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
204 S RMPRYN="N"
205 S RMPREXC=""
206 S DIR(0)="Y"
207 S DIR("A",1)="The entered Vendor is not the same as on the original order"
208 S DIR("A")="Do you want to change the Vendor on the order"
209 D ^DIR
210 I $D(DTOUT) S RMPREXC="T" G YNVNDX
211 I $D(DIROUT) S RMPREXC="P" G YNVNDX
212 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G YNVNDX
213 S:Y RMPRYN="Y"
214YNVNDX Q
Note: See TracBrowser for help on using the repository browser.