source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRN7.m@ 846

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

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