source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRN6.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1RMPRN6 ;Hines OIFO/HNC-PRINT NPPD LOCAL DATA ;3/17/03 11:38
2 ;;3.0;PROSTHETICS;**31,32,34,36,39,48,51,70,77,90**;Feb 09, 1996
3 ;RVD 3/17/03 patch #77 - fix undefined and closing device.
4 ;SPS 5/24/05 Patch #90 - check for type of 5 Rental.
5 D DIV4^RMPRSIT G:$D(X) EXIT
6DATE S %DT="XEA",%DT("A")="Enter Date to Start NPPD Calculations From: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT
7 S DATE(1)=+Y
8 S %DT="XEA",%DT("A")="Enter End Date: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT S DATE(2)=+Y
9 I DATE(1)>DATE(2) W !!,$C(7),"ENDING DATE RANGE IS LESS THAN BEGINNING DATE RANGE",! G DATE
10 Q:$D(RMPRCDE)
11DET ;select detail or brief
12 D DISP^RMPRN6S
13 K DIR
14 ;S DIR(0)="S^D:DETAIL;B:BRIEF"
15 S DIR(0)="S^1:BRIEF NEW SUMMARY;2:BRIEF USED SUMMARY;3:BRIEF BOTH SUMMARY;4:DETAIL & NEW SUMMARY;5:DETAIL & USED SUMMARY;6:DETAIL & BOTH SUMMARY"
16 S DIR("A")="Type of Report",DIR("B")="DETAIL & NEW SUMMARY" D ^DIR
17 Q:$D(DIRUT)!($D(DTOUT))
18 S RMPRDET=Y
19DEV ;device
20 S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRT
21 I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
22 I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")=""
23 I S ZTRTN="PRT^RMPRN6",ZTDESC="Prosthetic NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
24PRT ;print
25 I '$D(IO("Q")) U IO
26 D GNP,GNPC
27 Q
28ENL ;entry point for one line
29 D DIV4^RMPRSIT G:$D(X) EXIT
30 S RMPRCDE=1
31 D DATE
32 G:'$D(DATE(1))!('$D(DATE(2))) EXIT
33 ;single line always new and used (BOTH) sort
34 S RMPRDET=6
35 D GNPCC,EXIT
36 Q
37GNP ;gather nppd data
38 S $P(LN,"-",IOM)=""
39 S DATE=DATE(1)-1
40 K ^TMP($J)
41 F S DATE=$O(^RMPR(660,"B",DATE)) Q:(DATE="")!($P(DATE,".",1)>DATE(2)) D
42 .S RMPRB=0
43 .F S RMPRB=$O(^RMPR(660,"B",DATE,RMPRB)) Q:RMPRB'>0 D
44 ..;define variables for record
45 ..S REC=$G(^RMPR(660,RMPRB,0)) Q:REC=""
46 ..Q:$P(REC,U,15)["*"
47 ..Q:$P(REC,U,10)'=RMPR("STA")
48 ..;check for used pip
49 ..;if used pip sort, not pip, not va, quit
50 ..I $G(RMPRDET)=2&($P($G(^RMPR(660,RMPRB,1)),U,5)'="")&($P(REC,U,14)'="V") Q
51 ..I $G(RMPRDET)=5&($P($G(^RMPR(660,RMPRB,1)),U,5)'="")&($P(REC,U,14)'="V") Q
52 ..S TYPE=$P(REC,U,4)
53 ..S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
54 ..S MR=$P($G(^RMPR(660,RMPRB,1)),U,4)
55 ..I $P(^RMPR(660,RMPRB,0),U,17)'=""&($P(^(0),U,26)="") S TY=2,LINE="R90 A",MR=2676
56 ..;PICKUP AND DELIVERY
57 ..I $P(^RMPR(660,RMPRB,0),U,26)'="" S TY=2,LINE="R80 D",MR=2951
58 ..Q:MR=""
59 ..; PATCH 70 Auto-fix
60 ..K LINE
61 ..I TY'=2 S LINE=$P(^RMPR(661.1,MR,0),U,7)
62 ..I TY'=2&($G(LINE)="") D
63 ...; I TYPE=5 Q
64 ...S ERR=""
65 ...S LINE=$P(^RMPR(661.1,MR,0),U,6)
66 ...S TYPE="X"
67 ...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
68 ...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
69 ...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
70 ...K DIE,DA,DR
71 ...I ERR=1 S ^TMP($J,"RMPRA",RMPRB)="NO UPDATE!"
72 ...I ERR="" S ^TMP($J,"RMPRA",RMPRB)="NEW TO REPAIR"
73 ...S B=RMPRB D DATA^RMPRN6XM
74 ..I TY=2 S LINE=$P(^RMPR(661.1,MR,0),U,6)
75 ..I TY=2&($G(LINE)="") D
76 ...; I TYPE=5 Q
77 ...S ERR=""
78 ...S LINE=$P(^RMPR(661.1,MR,0),U,7)
79 ...S TYPE="I"
80 ...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
81 ...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
82 ...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
83 ...K DIE,DA,DR
84 ...I ERR=1 S ^TMP($J,"RMPRA",RMPRB)="NO UPDATE!"
85 ...I ERR="" S ^TMP($J,"RMPRA",RMPRB)="REPAIR TO NEW"
86 ...S B=RMPRB D DATA^RMPRN6XM
87 ..;
88 ..I LINE="" W !,"Line is null, something wrong with file 661.1 :",MR
89 ..;set to 999 group if null
90 ..S FLAG=$P(^RMPR(661.1,MR,0),U,8)
91 ..I FLAG="" S FLAG=2
92 ..S CATEGRY=$P($G(^RMPR(660,RMPRB,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P($G(^("AMS")),U,1)
93 ..Q:GN=""
94 ..D SET
95 D FMT^RMPRN6XM,MAIL^RMPRN6XM
96 Q
97GNPC ;worksheet/detail
98 S STN=RMPR("NAME")
99 D CAL^RMPRN6
100 S PAGE=0,FL=""
101 D ^RMPRN6PT
102 G:FL=1 EXIT
103 D ^RMPRN6PR
104 G:FL=1 EXIT
105 I RMPRDET<4 G EXIT
106 D DESP^RMPRN63
107 D DESPR^RMPRN63
108EXIT ;commom exit point
109 D ^%ZISC
110 N RMPR,RMPRSITE
111 K ^TMP($J) D KILL^XUSCLEAN
112 Q
113GNPCC ;one line only
114 S STN=RMPR("NAME")
115 D CODE^RMPRN63
116 D ^RMPRN6UT
117 G:$D(DIRUT)!($D(DTOUT)) EXIT
118 I $G(RMPRCDE)="" S RMPRCDE="",RMPRCDE=$O(BRA(Y,RMPRCDE))
119 S Y=DATE(1) D DD^%DT S DATE(3)=Y,Y=DATE(2) D DD^%DT S DATE(4)=Y
120 S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRTL
121 I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
122 I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")="",ZTSAVE("RMPRCDE")=""
123 I S ZTRTN="PRTL^RMPRN6",ZTDESC="Prosthetic NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
124PRTL ;print one line entry from taskman
125 I '$D(IO("Q")) U IO
126 D GNP
127 D CAL^RMPRN6
128 S PAGE=0,FL=""
129 S CODE=RMPRCDE
130 D DESP^RMPRN6PL
131 Q
132SET ;set temp global
133 S STN=RMPR("NAME")
134 S ^TMP($J,"RMPRGN",STN,GN,FLAG,LINE,RMPRB)=""
135 S RMSSN=$P(^RMPR(660,RMPRB,0),U,2) I RMSSN S RMSSN=$P(^DPT(RMSSN,0),U,9)
136 I RMSSN'="" S ^TMP($J,"A",RMSSN)=""
137 K RMSSN
138 Q
139 ;
140LOOP ;sort on hcpcs key and grouper is complete
141 ;store in tmp($j,"N",station) or "R"
142 S (TAM,T1,RMPRB,COUNT,CODE,RMPRAD,DATE,RMPRFG,RMPRT,RMPRI,RMPRNW,RMPRRPR)=0
143 S (TQTY,RMPROTH,CC,RMPRC,RMPRN,TT,RMPRPSC,VA,CM,RMPRCT1,SO,SI,DIS,RMPRCT,RMPR21,CODE,RMPRB,FM,LEG,RMPRNI,RMPRNO,RMPRSL,RMPRAA,RMPRPHC)=0
144 S DATE=DATE(1),RMPRB=0
145CAL ;loop through grouper key sort
146 S STN=RMPR("NAME")
147 D CODE^RMPRN63
148 S GN=""
149 F S GN=$O(^TMP($J,"RMPRGN",STN,GN)) Q:GN="" D
150 .S FLG=0
151 .F S FLG=$O(^TMP($J,"RMPRGN",STN,GN,FLG)) Q:FLG'>0 D I FLG=1&(RMPRDET'=2)!(RMPRDET'=5) Q
152 ..;used items never get grouped
153 ..I FLG=1&(RMPRDET'=2)&(RMPRDET'=5) D GROUP Q
154 ..;I FLG=1 D GROUP Q
155 ..S CODE=0
156 ..F S CODE=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE)) Q:CODE="" D
157 ...S RD=0
158 ...F S RD=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD)) Q:RD'>0 D
159 ....I RMPRDET=1!(RMPRDET=4) D SORT Q
160 ....I RMPRDET=2!(RMPRDET=5) D SORTUSED^RMPRN6S Q
161 ....I RMPRDET=3!(RMPRDET=6) D SORTBOTH^RMPRN6S Q
162 ....;D SORT
163 Q
164GROUP ;total grouper to main key
165 M BC=^TMP($J,"RMPRGN",STN,GN)
166 S BF=0,BTCOST=0,SRD=""
167 ;bc array is entrie PO 2421
168 F S BF=$O(BC(BF)) Q:BF'>0 D
169 .;b1 is line,or code
170 .S BL=0
171 .F S BL=$O(BC(BF,BL)) Q:BL="" D
172 ..S BR=0
173 ..;BR is record number
174 ..F S BR=$O(BC(BF,BL,BR)) Q:BR'>0 D
175 ...S BCOST=$P(^RMPR(660,BR,0),U,16)
176 ...S BTCOST=BTCOST+BCOST
177 ...I (BF=1)&(SRD="") S SRD=BR,CODE="",CODE=$O(BC(1,CODE))
178 K BC
179 Q:SRD=""
180 ;calculate based on primary
181 S TYPE=$P(^RMPR(660,SRD,0),U,4)
182 S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
183 S SOURCE=$P(^RMPR(660,SRD,0),U,14)
184 S COST=BTCOST
185 ;stock issue display and calculate zero used cost if VA source
186 I $P(^RMPR(660,SRD,1),U,5)'=""&(SOURCE["V") S BTCOST=0,COST=0
187 I $P(^RMPR(660,SRD,0),U,13)["-3" S COST=0,SOURCE="VA",BTCOST=0
188 S QTY=$P(^RMPR(660,SRD,0),U,7)
189 S ^TMP($J,CODE,SRD)=COST
190 S CATEGRY=$P($G(^RMPR(660,SRD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
191 ;new or repair code
192 S B1=SRD
193 I TY=2 D REP
194 I TY'=2 D NEW
195 Q
196SORT ;main data for worksheets
197 S TYPE=$P(^RMPR(660,RD,0),U,4)
198 S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
199 S SOURCE=$P(^RMPR(660,RD,0),U,14)
200 I SOURCE="" S SOURCE="C"
201 S CATEGRY=$P($G(^RMPR(660,RD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
202 S COST=$P(^RMPR(660,RD,0),U,16)
203 ;stock issue source VA, used cost calculation is zero
204 I $P(^RMPR(660,RD,1),U,5)'=""&(SOURCE["V") S COST=0
205 ;form
206 S FORM=$P(^RMPR(660,RD,0),U,13)
207 I (FORM=4)!(FORM=15) S COST=0,SOURCE="V"
208 S QTY=$P(^RMPR(660,RD,0),U,7)
209 S B1=RD
210 S ^TMP($J,CODE,RD)=COST
211 I TY=2 D REP
212 I TY'=2 D NEW
213 Q
214REP ;calculate repair cost
215 ;I $G(RD)'="" D
216 ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
217 ;.I SSN'="" S ^TMP($J,"A",SSN)=""
218 ;.K SSN
219 S LINE=CODE
220 I LINE="R90 A" S SOURCE="C",QTY=1
221 I $G(^TMP($J,"R",STN,LINE))="" S ^TMP($J,"R",STN,LINE)=""
222 I SOURCE["V" S $P(^TMP($J,"R",STN,LINE),U,1)=$P(^TMP($J,"R",STN,LINE),U,1)+QTY
223 I SOURCE["C" S $P(^TMP($J,"R",STN,LINE),U,2)=$P(^TMP($J,"R",STN,LINE),U,2)+QTY
224 ;
225 S $P(^TMP($J,"R",STN,LINE),U,3)=$P(^TMP($J,"R",STN,LINE),U,3)+COST
226 I CATEGRY=1 S $P(^TMP($J,"R",STN,LINE),U,4)=$P(^TMP($J,"R",STN,LINE),U,4)+1
227 I CATEGRY=4 S $P(^TMP($J,"R",STN,LINE),U,5)=$P(^TMP($J,"R",STN,LINE),U,5)+1
228 I CATEGRY=2 S $P(^TMP($J,"R",STN,LINE),U,6)=$P(^TMP($J,"R",STN,LINE),U,6)+1
229 I CATEGRY=3 S $P(^TMP($J,"R",STN,LINE),U,7)=$P(^TMP($J,"R",STN,LINE),U,7)+1
230 I SPEC=1 S $P(^TMP($J,"R",STN,LINE),U,8)=$P(^TMP($J,"R",STN,LINE),U,8)+1
231 I SPEC=2 S $P(^TMP($J,"R",STN,LINE),U,9)=$P(^TMP($J,"R",STN,LINE),U,9)+1
232 I SPEC=3 S $P(^TMP($J,"R",STN,LINE),U,10)=$P(^TMP($J,"R",STN,LINE),U,10)+1
233 I SPEC=4 S $P(^TMP($J,"R",STN,LINE),U,11)=$P(^TMP($J,"R",STN,LINE),U,11)+1,$P(^(LINE),U,16)=$P(^(LINE),U,16)+COST
234 I TYPE="I" S $P(^TMP($J,"R",STN,LINE),U,12)=$P(^TMP($J,"R",STN,LINE),U,12)+1
235 Q
236 ;
237NEW ;calculate new costs
238 ;I $G(RD)'="" D
239 ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
240 ;.I SSN'="" S ^TMP($J,"A",SSN)=""
241 ;.K SSN
242 S LINE=CODE
243 I $G(^TMP($J,"N",STN,LINE))="" S ^TMP($J,"N",STN,LINE)=""
244 I SOURCE["V" S $P(^TMP($J,"N",STN,LINE),U,1)=$P(^TMP($J,"N",STN,LINE),U,1)+QTY
245 I SOURCE["C" S $P(^TMP($J,"N",STN,LINE),U,2)=$P(^TMP($J,"N",STN,LINE),U,2)+QTY
246 S $P(^TMP($J,"N",STN,LINE),U,3)=$P(^TMP($J,"N",STN,LINE),U,3)+COST
247 I CATEGRY=1 S $P(^TMP($J,"N",STN,LINE),U,4)=$P(^TMP($J,"N",STN,LINE),U,4)+1
248 I CATEGRY=4 S $P(^TMP($J,"N",STN,LINE),U,5)=$P(^TMP($J,"N",STN,LINE),U,5)+1
249 I CATEGRY=2 S $P(^TMP($J,"N",STN,LINE),U,6)=$P(^TMP($J,"N",STN,LINE),U,6)+1
250 I CATEGRY=3 S $P(^TMP($J,"N",STN,LINE),U,7)=$P(^TMP($J,"N",STN,LINE),U,7)+1
251 I SPEC=1 S $P(^TMP($J,"N",STN,LINE),U,8)=$P(^TMP($J,"N",STN,LINE),U,8)+1
252 I SPEC=2 S $P(^TMP($J,"N",STN,LINE),U,9)=$P(^TMP($J,"N",STN,LINE),U,9)+1
253 I SPEC=3 S $P(^TMP($J,"N",STN,LINE),U,10)=$P(^TMP($J,"N",STN,LINE),U,10)+1
254 I SPEC=4 S $P(^TMP($J,"N",STN,LINE),U,11)=$P(^TMP($J,"N",STN,LINE),U,11)+1,$P(^(LINE),U,16)=$P(^(LINE),U,16)+COST
255 I TYPE="I" S $P(^TMP($J,"N",STN,LINE),U,12)=$P(^TMP($J,"N",STN,LINE),U,12)+1
256 Q
Note: See TracBrowser for help on using the repository browser.