source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY9.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1RMPRPIY9 ;HINCIO/ODJ - AE - Add/Edit Locations and Items ;3/8/01
2 ;;3.0;PROSTHETICS;**61,108**;Feb 09, 1996
3 Q
4 ;
5 ;***** AE - Add Inventory LOCATIONS and ITEMS
6 ; option RMPR INV ADD
7 ; Replaces AE option in old PIP (cf ^RMPR5NAE)
8 ; no inputs required
9 ; other than standard VISTA vars. (DUZ, etc)
10 ;
11AE N RMPRERR,RMPRSTN,RMPREXC,RMPR5,RMPR1,RMPR11,RMPRVEND,RMPRTVAL,RMPRDUP
12 N RMPRQTY,RMPRREO,RMPR61,RMPRUCST,RMPROVAL,RMPRI,RMPRUPDF
13 ;
14 ;***** STN - call prompt for Site/Station
15STN S RMPROVAL=$G(RMPRSTN("IEN"))
16 W @IOF S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
17 I RMPRERR G AEX
18 I RMPREXC'="" G AEX
19 I RMPROVAL'=RMPRSTN("IEN") K RMPR5
20 ;
21 ;***** LOCN - call prompt for Location
22LOCN W !!,"Adding Item to a Location.",!
23 S RMPROVAL=$G(RMPR5("IEN"))
24 S RMPRERR=$$LOCNM^RMPRPIY2(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
25 I RMPREXC="T"!(RMPREXC="^") G AEX
26 I RMPREXC="P" G STN
27 I RMPROVAL'=RMPR5("IEN") K RMPR1
28 I $P($G(^RMPR(661.5,RMPR5("IEN"),0)),U,4)="I" W !!,"LOCATION IS INACTIVE AND CANNOT BE EDITED, OR ASSOCIATED ITEMS!!" K RMPR5 G LOCN
29LOCN2 S RMPR5("STATION")=RMPRSTN("IEN")
30 S RMPR5("STATION IEN")=RMPRSTN("IEN")
31 ;
32 ;***** HCPCS - call prompt for HCPCS code
33HCPCS S RMPROVAL=$G(RMPR1("HCPCS"))
34 S RMPR1("HCPCS")=""
35 W ! S RMPRERR=$$HCPCS^RMPRPIY3(.RMPR5,.RMPR1,.RMPREXC)
36 I RMPREXC="T"!(RMPREXC="^") G AEX
37 I RMPREXC="P" G LOCN
38 I RMPROVAL'=RMPR1("HCPCS") D
39 . K RMPR11,RMPR61
40 . S RMPR11("HCPCS")=RMPR1("HCPCS")
41 . Q
42 S RMPR11("STATION")=RMPRSTN("IEN")
43 S RMPR11("STATION IEN")=RMPRSTN("IEN")
44 ;
45 ;***** MASIT - call prompt for master item (in 661->441)
46MASIT S RMPROVAL=$G(RMPR61("IEN"))
47 D MASIT^RMPRPIY1(.RMPR61,.RMPREXC)
48 I RMPREXC="T" G AEX
49 I RMPREXC="P" G HCPCS
50 I RMPREXC="^" G AEX
51 I RMPROVAL'=RMPR61("IEN") D
52 . S RMPRERR=$$GET^RMPRPIXD(.RMPR61)
53 . K RMPRSRC,RMPRREO,RMPR4
54 . S RMPR11("ITEM MASTER IEN")=RMPR61("IEN")
55 . S RMPR11("DESCRIPTION")=RMPR61("ITEM MASTER")
56 . S RMPR11("ITEM MASTER")=RMPR61("ITEM MASTER")
57 . Q
58 ;
59 ;***** IDESC - call prompt for Item Description edit
60IDESC S RMPROVAL=$G(RMPR11("DESCRIPTION"))
61 D ITED^RMPRPIY4(.RMPR11,.RMPREXC)
62 I RMPREXC="T" G AEX
63 I RMPREXC="P" G MASIT
64 I RMPREXC="^" G HCPCS
65 I $G(RMPR11("DESCRIPTION"))="" D
66 . S RMPR11("DESCRIPTION")=RMPR61("ITEM MASTER")
67 . S RMPR11("ITEM MASTER")=RMPR61("ITEM MASTER")
68 . Q
69 I RMPROVAL'=RMPR11("DESCRIPTION") D
70 . K RMPRSRC,RMPRREO
71 . Q
72 ;
73 ;***** SRC - call prompt for Source (Commercial or VA)
74SRC S RMPROVAL=$G(RMPRSRC)
75 D SRC^RMPRPIY5(.RMPRSRC,.RMPREXC)
76 I RMPREXC="P" G IDESC
77 I RMPREXC="^" G HCPCS
78 I RMPREXC="T" G AEX
79 I RMPROVAL'=RMPRSRC K RMPRREO
80 ;
81 ; Update the inventory file (661.11)
82 S RMPR11("SOURCE")=RMPRSRC
83 S RMPR11("UNIT")=""
84 S RMPRERR=0
85 S RMPRUPDF=1 ;update flag
86 ;
87 ; Only create new record if one doesn't already exist
88 I $D(^RMPR(661.11,"ASHMDI",RMPRSTN("IEN"),RMPR11("HCPCS"),RMPR61("IEN"),RMPR11("DESCRIPTION"))) D
89 . S RMPRI=""
90 . F S RMPRI=$O(^RMPR(661.11,"ASHMDI",RMPRSTN("IEN"),RMPR11("HCPCS"),RMPR61("IEN"),RMPR11("DESCRIPTION"),RMPRI)) Q:RMPRI="" D Q:'RMPRUPDF
91 .. S RMPR11("ITEM")=RMPRI
92 .. S RMPR11("IEN")=""
93 .. S RMPRERR=$$DUP^RMPRPIX1(.RMPR11,.RMPRDUP)
94 .. I RMPRERR S RMPRUPDF=0 Q
95 .. I 'RMPRDUP S RMPRUPDF=0 Q
96 .. Q
97 . Q
98 I RMPRUPDF D
99 . S RMPR11("ITEM")=""
100 . K RMPR11("IEN")
101 . S RMPRERR=$$CRE^RMPRPIX1(.RMPR11)
102 . S RMPR4("RE-ORDER QTY")=0
103 . S RMPRERR=$$CRE^RMPRPIX4(.RMPR4,.RMPR11,.RMPR5)
104 . Q
105 I RMPRERR D G AEX
106 . W !,"Problem updating inventory item file, please contact support."
107 . H 3
108 . Q
109 ;
110 ;***** REO - call prompt for Re-Order Quantity
111REO S RMPROVAL=$G(RMPRREO)
112 D REO^RMPRPIY5(.RMPRREO,.RMPREXC)
113 I RMPREXC="P" G SRC
114 I RMPREXC="^" G HCPCS
115 I RMPREXC="T" G AEX
116 ;
117 ; Update the reorder file (661.4)
118 I RMPROVAL=RMPRREO G QTY
119 S RMPR4("RE-ORDER QTY")=RMPRREO
120 S RMPRERR=$$UPD^RMPRPIX4(.RMPR4,,)
121 ;
122 ; At this point the item has been added to inventory (661.11) and
123 ; the re-order file (661.4)
124 ; The following prompts are for receipting in a quantity of the item
125 ;
126 ;***** QTY - call prompt for Quantity
127QTY D QTY^RMPRPIY5(.RMPRQTY,.RMPREXC)
128 I RMPREXC="P" G REO
129 I RMPREXC="^" G HCPCS
130 I RMPREXC="T" G AEX
131 S RMPRQTY=+$G(RMPRQTY)
132 I 'RMPRQTY G QTY
133 ;
134 ;***** UCST - call prompt for Unit Cost
135UCST D UCST^RMPRPIY5(.RMPRUCST,.RMPREXC)
136 I RMPREXC="P" G QTY
137 I RMPREXC="^" G HCPCS
138 I RMPREXC="T" G AEX
139 S RMPRUCST=+$G(RMPRUCST)
140 ;
141 ;***** TVAL - Total Value - use if Unit Cost not used
142TVAL I RMPRUCST D G VEND
143 . S RMPRTVAL=$J(RMPRQTY*RMPRUCST,0,2)
144 . W !,"TOTAL COST OF QUANTITY: "_RMPRTVAL
145 . Q
146 D TVAL^RMPRPIY5(.RMPRTVAL,.RMPREXC)
147 I RMPREXC="P" G UCST
148 I RMPREXC="^" G HCPCS
149 I RMPREXC="T" G AEX
150 ;
151 ;***** VEND - call prompt for Vendor
152VEND D VEND^RMPRPIY5(.RMPRVEND,.RMPREXC)
153 I RMPREXC="P" G UCST
154 I RMPREXC="^" G HCPCS
155 I RMPREXC="T" G AEX
156 ;
157 ;
158 ;***** UNIT - call prompt for UNIT OF ISSUE
159UNIT D UNIT^RMPRPIY5(.RMPRUNI,.RMPREXC)
160 I RMPREXC="P" G UCST
161 I RMPREXC="^" G HCPCS
162 I RMPREXC="T" G AEX
163 ;
164 ;***** TRANS - Create receipt record for adding an item
165TRANS S RMPR11("STATION")=RMPRSTN("IEN")
166 S RMPR11("STATION IEN")=RMPRSTN("IEN")
167 S RMPR6("QUANTITY")=RMPRQTY
168 S RMPR6("VALUE")=RMPRTVAL
169 S RMPR6("VENDOR")=RMPRVEND("IEN")
170 S RMPR6("UNIT")=RMPRUNI("IEN")
171 S RMPRERR=$$REC^RMPRPIU8(.RMPR6,.RMPR11,.RMPR5,1) ;receipt API
172TRANSX I RMPRERR D
173 . W !!,"** Inventory could not be updated, please contact support",!
174 . Q
175 E D
176 . W !!,"** Inventory updated.",!
177 .;ask for number of labels and print barcode.
178 . S RMPR11("HCPCS-ITEM")=RMPR11("HCPCS")_"-"_RMPR11("ITEM")
179 . D NLAB^RMPRPIYY
180 . Q
181 K RMPR6,RMPRTVAL,RMPRQTY,RMPRUCST
182 G HCPCS
183 ;
184 ;***** exit
185AEX D KILL^XUSCLEAN
186 Q
Note: See TracBrowser for help on using the repository browser.