source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1RMPRPIYF ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/2/02 07:27
2 ;;3.0;PROSTHETICS;**61,117,139**;Feb 09, 1996;Build 4
3 ; RVD #61 - phase III of PIP enhancement.
4 ;
5 ;Per VHA Directive 10-93-142, this routine should not be modified.
6COST ;
7 S RMACNT=RMPRCOST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMACNT,$P(R1(0),U,16)=RMACNT
8 ;
9DATE S:$P(R1(1),U,8) DIR("B")=$P(R1("D"),U,8) S DIR("A")="DATE OF SERVICE",DIR(0)="660,39" D ^DIR K DIR
10 G:X["^" CO^RMPRPIYE G:$D(DTOUT) EXIT I $P(R1(1),U,8)&(X="@") W !,"This field is mandatory!!!",! G DATE
11 I X="" W !,"This field is mandatory!!!",! G DATE
12 S $P(R1(1),U,8)=Y,Y=$P(R1(1),U,8) D DD^%DT S $P(R1("D"),U,8)=Y
13 ;
14REQ S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT
15 I X["^" W !,"Jumping not allowed!" G REQ
16 I $P(R1(0),U,11)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,11)="" G LOT
17 S $P(R1(0),U,11)=X
18 ;
19LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR G:$D(DUOUT) CO^RMPRPIYE
20 I X["^" W !,"Jumping not allowed!" G LOT
21 I $P(R1(0),U,24)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,24)="" G REMA
22 S $P(R1(0),U,24)=X
23 ;
24REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT
25 I X["^" W !,"Jumping not allowed!" G REMA
26 I $P(R1(0),U,18)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,18)="" G CC
27 S $P(R1(0),U,18)=X
28CC G CO^RMPRPIYE
29 ;
30POST ;POSTS EDITED TRANSACTION TO 660
31 W !,"Posting...."
32 K RMPR60,RMDTTIM,RMPR63
33 S RMPR60("IEN")=RMPRIEN,RMFLG=0
34 ;RMPR60 -array of data fields for 660 file record.
35 D SET60^RMPRPIYE
36 ;get 661.6 & 661.63 patient issue
37 S (RMPR6("IEN"),RMIEN6)=$P(R1(1),U,5)
38 I $G(RMIEN6),$D(^RMPR(661.6,RMIEN6,0)) D
39 .S RMDAT6=$G(^RMPR(661.6,RMIEN6,0))
40 .S RMIEN63=$O(^RMPR(661.63,"B",RMIEN6,0))
41 .I $G(RMIEN63),$D(^RMPR(661.63,RMIEN63,0)) D
42 ..S RMDAT63=$G(^RMPR(661.63,RMIEN63,0)),RMPR63("IEN")=RMIEN63
43 ..S (RMPRRET("DATE&TIME"),RMDTTIM)=$P(RMDAT63,U,6)
44 ..S RMPRRET("QUANTITY")=$P(RMDAT63,U,12)
45 ..S RMPRRET("HCPCS")=$P(RMDAT63,U,4)
46 ..S RMPRRET("STATION")=$P(RMDAT63,U,7)
47 ..S RMPRRET("ITEM")=$P(RMDAT63,U,5)
48 ..S RMPRRET("VALUE")=$P(RMDAT63,U,10)
49 ..S RMPRRET("UNIT")=$P(RMDAT63,U,11)
50 ..S RMPRRET("VENDOR")=$P(RMDAT63,U,9)
51 ..S RMPRRET("LOCATION")=$P(RMDAT63,U,8)
52 ;only update 660 if no label scan and quantity the same.
53 I '$D(RMPR7I),($P(R1BCK(0),U,7)=RMPR60("QUANTITY")) D UP660 G PCE
54 ;set update flags: 1=new item/diff barcode 2=only quantity changed.
55 I $G(RMDTTIM),$D(RMPR7I("DATE&TIME")),RMDTTIM'=RMPR7I("DATE&TIME") S RMFLG=1
56 I '$G(RMDTTIM),$D(RMPR7I("DATE&TIME")) S RMFLG=1
57 I $P(R1BCK(0),U,7)'=RMPR60("QUANTITY"),'$G(RMFLG) S RMFLG=2
58 ;
59API ;call API for 660, 661.7, 661.6, 661.63, 661.9
60 ;
61 ;file #660, 661.6, 661.7, 661.63, 661.9
62 I RMFLG=1 D UPDATE
63 I RMFLG=2 D QUAN
64 D UP660
65 I $G(RMPRERR) W !!,"*** ERROR in 2319 UPDATE, Please notify your IRM..IEN = ",$G(RMPR60("IEN")),!! H 3
66 ;
67PCE ;update PCE data
68 I $D(^RMPR(660,RMPR60("IEN"),10)),$P(^RMPR(660,RMPR60("IEN"),10),U,12) D
69 .S RMCHK=0
70 .S RMCHK=$$SENDPCE^RMPRPCEA(RMPR60("IEN"))
71 .I RMCHK'=1 W !!,"*** ERROR in PCE UPDATE, Please notify your IRM..IEN = ",RMPR60("IEN"),!! H 3
72 ;
73 ;end posting (edit 2319)
74 G EXIT
75 ;
76DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK
77 ;** MOVED TO RMPRPIFD DUE TO SIZE CONSTRAINTS
78 G DEL1^RMPRPIFD
79EXIT ;KILL VARIABLES AND EXIT ROUTINE
80 I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN)
81 K ^TMP($J) N RMPRSITE,RMPR D KILL^XUSCLEAN
82 Q
83 ;
84UP660 ;update 660
85 S RMPR60("IEN")=RMPRIEN
86 S RMPRERR=0
87 S RMPRERR=$$UPD^RMPRPIX2(.RMPR60,.RMPR11I)
88 I $G(RMPRERR) W !,"*** Error in API RMPRPIX2, ERROR = ",RMPRERR,!,"*** Please inform your IRM !!",!
89 Q
90 ;
91UPDATE ;update the new entries AND delete old data
92 S RMNEWHC=RMPR11I("HCPCS")
93 S RMNEWIT=RMPR11I("ITEM")
94 I $G(RMPR6("IEN")) S RMPR60("IEN")=RMPR6("IEN") D
95 .S RMPRERR=$$UPD^RMPRPIX6(.RMPR60,.RMPR11I)
96 .I $G(RMPR63("IEN")) S RMPRERR=$$UPALL^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I)
97 .I '$G(RMPR63("IEN")) S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I)
98 I '$G(RMPR6("IEN")) D
99 .S RMPRERR=$$CRE^RMPRPIX6(.RMPR60,.RMPR11I)
100 .S (RMPR60("IEN6"),RMPR6("IEN"))=$G(RMPR60("IEN"))
101 .S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I)
102 ;create a return stock record
103 S RMPR11I("HCPCS")=$G(RMPRRET("HCPCS"))
104 S RMPR11I("ITEM")=$G(RMPRRET("ITEM"))
105 S RMPRRET("SEQUENCE")=1
106 S RMPRRET("TRAN TYPE")=8
107 S RMPRRET("COMMENT")="STOCK ISSUE EDIT"
108 S RMPRRET("USER")=$G(DUZ)
109 I '$D(RMPRRET("QUANTITY")) S RMPRRET("QUANTITY")=RMPR60("QUANTITY")
110 I '$D(RMPRRET("VALUE")) S RMPRRET("VALUE")=RMPR60("COST")
111 I '$D(RMPRRET("UNIT")) S RMPRRET("UNIT")=RMPR60("UNIT")
112 I '$D(RMPRRET("VENDOR")) S RMPRRET("VENDOR")=RMPR60("VENDOR IEN")
113 I '$D(RMPRRET("LOCATION")) S RMPRRET("LOCATION")=$G(RMLO1)
114 I $D(RMPR11I) D I $G(RMPRERR) Q
115 .S RMPRERR=$$CRE^RMPRPIX6(.RMPRRET,.RMPR11I)
116 ;return/update 661.7
117 D BACK Q:$G(RMPRERR)
118 S RMPR11I("HCPCS")=$G(RMNEWHC)
119 S RMPR11I("ITEM")=$G(RMNEWIT)
120 S RMPR7I("QUANTITY")=RMPR60("QUANTITY")
121 S RMPR7I("VALUE")=RMPR60("COST")
122 ;update or create 661.7 entry
123 D UP7
124 S RMPR9("QUANTITY")=RMPR60("QUANTITY")
125 S RMPR9("VALUE")=RMPR60("COST")
126 ;return 661.9 entry
127 I $D(RMDTTIM) D D UP9
128 .S RMPR11I("HCPCS")=RMPRRET("HCPCS")
129 .S RMPR11I("ITEM")=RMPRRET("ITEM")
130 .S RMPR9("QUANTITY")=$P(R1BCK(0),U,7)
131 .S RMPR9("VALUE")=$P(R1BCK(0),U,16)
132 ;deduct the new HCPCS in 661.9
133 S RMPR11I("HCPCS")=RMNEWHC
134 S RMPR11I("ITEM")=RMPR60("ITEM")
135 S RMPR9("QUANTITY")=0-RMPR60("QUANTITY")
136 S RMPR9("VALUE")=0-RMPR60("COST")
137 D UP9
138 Q
139 ;
140BACK ; Bring back ITEM into current stock.
141 D NOW^%DTC
142 S (RMPR7R("STATION"),RMST1)=RMPR11I("STATION")
143 S (RMPR7R("HCPCS"),RMHC1)=RMPR11I("HCPCS")
144 S (RMPR7R("ITEM"),RMIT1)=RMPR11I("ITEM")
145 S (RMPR7R("LOCATION"),RMLO1)=RMPRRET("LOCATION")
146 S RMPR7R("VENDOR")=RMPRRET("VENDOR")
147 S RMPR7R("DATE&TIME")=% S:$G(RMPRRET("DATE&TIME"))'="" RMPR7R("DATE&TIME")=RMPRRET("DATE&TIME")
148 S RMPR7R("SEQUENCE")=1
149 S RMPR7R("QUANTITY")=RMPRRET("QUANTITY")
150 S RMPR7R("VALUE")=RMPRRET("VALUE")
151 S RMPR7R("UNIT")=$G(RMPRRET("UNIT"))
152 I $G(RMDTTIM),$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D I RMPRERR S RMPRERR=71 Q
153 .S RMPR7R("IEN")=$O(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM,1,0))
154 .I '$G(RMPR7R("IEN")) S RMPRERR=1 Q
155 .S RMDA7=$G(^RMPR(661.7,RMPR7R("IEN"),0))
156 .S RMDAVAL=$P(RMDA7,U,8),RMDAQUA=$P(RMDA7,U,7)
157 .S RMPR7R("QUANTITY")=RMPR7R("QUANTITY")+RMDAQUA
158 .S RMPR7R("VALUE")=RMPR7R("VALUE")+RMDAVAL
159 .S RMPR7R("DATE&TIME")=RMDTTIM
160 .S RMPRERR=$$UPD^RMPRPIX7(.RMPR7R,.RMPR11I)
161 I $G(RMDTTIM),'$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D
162 .S RMPR7R("DATE&TIME")=RMDTTIM
163 .S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I)
164 I '$G(RMDTTIM) S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I)
165 Q
166 ;
167UP6 ;now update file 661.6
168 S RMPR6("IEN")=$G(RMIEN6)
169 S RMPR6("QUANTITY")=$G(RMPR60("QUANTITY"))
170 S RMPR6("VALUE")=$G(RMPR60("COST"))
171 S RMPRERR=$$UPD^RMPRPIX6(.RMPR6,.RMPR11I)
172 Q
173 ;
174 ;
175UP63 ;update file 661.63
176 S RMPR6("IEN")=$G(RMIEN6)
177 S RMPR6("LOCATION")=$G(RMPR5("IEN"))
178 S RMPR6("VENDOR")=$G(RMPR60("VENDOR IEN"))
179 S RMPR63("IEN")=$G(RMIEN63)
180 S RMPRERR=$$UPD^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I)
181 Q
182 ;
183UP7 ;file #661.7,deduct quantity
184 Q:'$G(RMPR11I("STATION"))
185 S RMPR7I("STATION IEN")=RMPR11I("STATION")
186 S RMPR7I("LOCATION IEN")=$G(RMPR5("IEN"))
187 S RMPR7I("HCPCS")=RMPR11I("HCPCS")
188 S RMPR7I("ITEM")=RMPR11I("ITEM")
189 S:$G(RMPRRET("DATE&TIME")) RMPR7I("DATE&TIME")=RMPRRET("DATE&TIME")
190 S RMPR7I("ISSUED QTY")=$G(RMPR7I("QUANTITY"))
191 S RMPR7I("ISSUED VALUE")=$G(RMPR7I("VALUE"))
192 S RMPRERR=$$FIFO^RMPRPIUB(.RMPR7I)
193 Q
194UP9 ;file 661.9
195 D NOW^%DTC
196 S RMPR9("STA")=RMPR11I("STATION")
197 S RMPR9("HCP")=RMPR11I("HCPCS")
198 S RMPR9("ITE")=RMPR11I("ITEM")
199 S RMPR9("RDT")=$P(%,".",1)
200 S RMPR9("TQTY")=RMPR9("QUANTITY")
201 S RMPR9("TCST")=RMPR9("VALUE")
202 S RMPERR=$$UPCR^RMPRPIXJ(.RMPR9)
203 Q
204 ;
205QUAN ;only update quantity
206 ;quit if not in PIP
207 Q:'$G(RMIEN6)!'$D(RMDTTIM)!'$D(RMPRRET)
208 S RMPR11I("STATION")=RMPRRET("STATION")
209 S RMPR11I("HCPCS")=RMPRRET("HCPCS")
210 S RMPR11I("ITEM")=RMPRRET("ITEM")
211 S RMPR5("IEN")=RMPRRET("LOCATION")
212 D UP6,UP63
213 I RMPR60("QUANTITY")>($P(R1BCK(0),U,7)) D D UP7,UP9
214 .S RMPR7I("QUANTITY")=RMPR60("QUANTITY")-($P(R1BCK(0),U,7))
215 .S RMPR7I("VALUE")=RMPR60("COST")-($P(R1BCK(0),U,16))
216 .S RMPR9("QUANTITY")=0-($G(RMPR60("QUANTITY"))-$P(R1BCK(0),U,7))
217 .S RMPR9("VALUE")=0-($G(RMPR60("COST"))-$P(R1BCK(0),U,16))
218 I RMPR60("QUANTITY")<($P(R1BCK(0),U,7)) D D BACK,UP9
219 .S RMPR9("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY"))
220 .S RMPRRET("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY"))
221 .S RMPR9("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST"))
222 .S RMPRRET("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST"))
223 Q
224 ;
225ERR W !!,"Error encountered while posting to PIP. Patient 10-2319 not deleted!! Please check with your Application Coordinator." H 5 G EXIT
Note: See TracBrowser for help on using the repository browser.