source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR5HQA.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1RMPR5HQA ;HCIOFO/RVD - ITEM USAGE REPORT FOR HQ and CTL PRG ; 04 Oct 00
2 ;;3.0;PROSTHETICS;**51**;Feb 09, 1996
3 ;
4 ;variables rmprdet,rmprpip1,rmprpip2 are external (from the server).
5 ;all ITEMs for all STATION is the default processing for the date range.
6START Q:RMPRPIP1>RMPRPIP2
7 D NATION^RMPR5HQ5 S RMPRSEL("*")="",RMPRSTN="*"
8 N RLN,RMPAGE,R5,REQ,RSL,RMTVAL,RMTCOML,RMTDLEL,RMTUSEL,RHCPC,RMTVAH
9 N RMTUSEG,RMTVAG,RMTCOMG,RMTQOHG,RMTVALG,RMGVAL,RGCNT,RLCNT,RSCNT,RFL
10 N RLINE,RGRP,RST,RI,RST,RJ,RK,RGRP,RDAT,RMBD,RMED,RPR,RMARRAY,RMTUSEH
11 N RMTQOHNL,RMTQOHUL,RMTISNL,RMTISUL,RMTVALNL,RMTVALUL,RMTAVELU
12 N RMTQOHNG,RMTQOHUG,RMTISNG,RMTISUG,RMTVALNG,RMTVALUG,RMTCOMH,RMTISUH
13 N RMTVALUH,RMTVALNH,RMTQOHUH,RMTQOHNH,RMTDLEH,RMTDLEG,RMTAVEG,RMGTOT
14 N RTAVEGA,RTAVEGC,RTDLEGA,RTDLEGC,RTUSEGA,RTUSEGC,RMGTIU,RMGTIN,RMTISNH
15 N RTAVELA,RTAVELC,RTDLELA,RTDLELC,RTUSELA,RTUSELC,RMTUSELU,RMTUSELN
16 N RTAVEHA,RTAVEHC,RTDLEHA,RTDLEHC,RTUSEHA,RTUSEHC,RMCALDAY,RMTAVELN
17 ;
18 S (RMTVAL,RMTCOML,RMTDLEL,RMTUSEL,RMTAVEG,RMGTOT,RMTUSELU,RMGISNG)=0
19 S (RMTQOHNL,RMTQOHUL,RMTISNL,RMTISUL,RMTVALNL,RMTVALUL,RMTAVELU)=0
20 S (RMTQOHNG,RMTQOHUG,RMTISNG,RMTISUG,RMTVALNG,RMTVALUG,RMTISUH)=0
21 S (RMTUSEG,RMTVAG,RMTCOMG,RMGTOU,RMGTON,RMTVAH,RMTCOMH,RMTVALUH)=0
22 S (RMGVAL,RGCNT,RLCNT,RSCNT,RFL,RPRINT,RMTQOHNH,RMTUSEH,RMTDLEH)=0
23 S (RTAVEGA,RTAVEGC,RTDLEGA,RTDLEGC,RTUSEGA,RTUSEGC,RMGTIU,RMGTIN)=0
24 S (RTAVELA,RTAVELC,RTDLELA,RTDLELC,RTUSELA,RTUSELC,RMTAVELN)=0
25 S (RTAVEHA,RTAVEHC,RTDLEHA,RTDLEHC,RTUSEHA,RTUSEHC,RC,RPR)=0
26 S (RMTVALNH,RMTQOHUH,RMTISNH,RMTUSELN,RMGISUG)=0
27 S (RLINE,RGRP,RST,RNPGRP,RNPLINE,RHCPC,RMTDLEG,RSTA)=""
28 ;
29 S X2=RMPRPIP1,X1=RMPRPIP2 D ^%DTC S RMCALDAY=X+1
30 S Y=RMPRPIP1 D DD^%DT S RMBD=Y S Y=RMPRPIP2 D DD^%DT S RMED=Y
31 D NOW^%DTC S Y=% X ^DD("DD") S RMRDATE=Y
32 S $P(RLN,"-",132)="",RMPAGE=0,R5="RMPR5",$P(REQ,"=",132)=""
33 S $P(RES,"*",132)="",$P(RB1," ",2)=""
34 S $P(RB2," ",3)=""
35 S $P(RB3," ",4)=""
36 S $P(RB4," ",5)=""
37 S $P(RB5," ",6)=""
38 S $P(RB6," ",7)=""
39 S $P(RB7," ",8)=""
40 S $P(RB8," ",9)=""
41 S $P(RB9," ",10)=""
42 S $P(RB10," ",11)=""
43 S $P(RB11," ",12)=""
44 S $P(RB12," ",13)=""
45 S $P(RB13," ",14)=""
46 S $P(RB14," ",15)=""
47 S $P(RB15," ",16)=""
48 S $P(RB16," ",17)=""
49 S $P(RB18," ",19)=""
50 S $P(RB23," ",24)=""
51 S $P(RB24," ",25)=""
52 S $P(RB26," ",27)=""
53 S $P(RB30," ",31)=""
54 S $P(RB31," ",32)=""
55 S $P(RB33," ",34)=""
56 S $P(RB50," ",51)=""
57 K RX D GRPARY^RMPR5HQ4(.RMARRAY)
58 ;
59ITEM ;entry point for Item Detail Usage report
60 I RMPRDET="I" S RMQSUBJ="PIP DETAIL ITEM REPORT" G DQ1
61 ;
62HCPCS ;entry point for HCPCS Summary Usage report.
63 I RMPRDET="H" S RMQSUBJ="PIP HCPCS SUMMARY REPORT" D ^RMPR5HQB G TOT
64LINE ;entry point for NPPD LINE Usage report.
65 I RMPRDET="L" S RMQSUBJ="PIP NPPD LINE SUMMARY REPORT" D ^RMPR5HQC G TOT
66 ;
67GROUP ;entry point for NPPD GROUP Usage report.
68 I RMPRDET="G" S RMQSUBJ="PIP NPPD GROUP SUMMARY REPORT" D ^RMPR5HQD
69 G SEND
70 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
71 ;
72DQ1 ;print PIP Report (Item Detail Usage report).
73 ;$O the ^TMP( global for all the records
74 ;print all records based on the sort criteria given.
75 F RST=0:0 S RST=$O(^TMP($J,R5,RST)) Q:RST'>0 D:(RSTA'="")&(RSTA'=RST)&(RPR=1) HDRI S RSTA=RST F RI=0:0 S RI=$O(^TMP($J,R5,RST,RI)) Q:$G(RFL) Q:RI'>0 D
76 .D:RPR=0 HDRI S RNPGRP=RMARRAY(RI),RJ=""
77 .F S RJ=$O(^TMP($J,R5,RST,RI,RJ)) Q:$G(RFL) D:(RLINE'="")&(RLINE'=RJ) SUML1 Q:RJ="" D
78 ..S RLINE=RJ,RNPLINE=$$NPLIN^RMPR5HQ5(RJ)
79 ..I RGCNT=0 S RGCNT=RGCNT+1
80 ..S RK="" F S RK=$O(^TMP($J,R5,RST,RI,RJ,RK)) Q:$G(RFL)!(RK="") D
81 ...S RL="" F S RL=$O(^TMP($J,R5,RST,RI,RJ,RK,RL)) Q:$G(RFL)!(RL="") D
82 ....S RHCPC=$P(RK,"/",1) S:RMPRDET="I" RHCPC=RHCPC_"-"_RL
83 ....S RNPITEM=$$GETITEM^RMPR5HQ5($P(RK,"/",2),RL)
84 ....I RLCNT=0 D GLN1
85 ....S RLCNT=RLCNT+1,RDAT=^TMP($J,R5,RST,RI,RJ,RK,RL)
86 ....S RMVA=$P(RDAT,U,1)
87 ....S RMCOM=$P(RDAT,U,2)
88 ....S RMUSE=$P(RDAT,U,3)
89 ....S RMISU=$P(RDAT,U,4)
90 ....S RMISN=$P(RDAT,U,5)
91 ....S RMAVEN=$P(RDAT,U,6)
92 ....S RMDLEN=$P(RDAT,U,7)
93 ....S RMQOHU=$P(RDAT,U,8)
94 ....S RMQOHN=$P(RDAT,U,9)
95 ....S RMVALU=$P(RDAT,U,10)
96 ....S RMVALN=$P(RDAT,U,11)
97 ....S RMAVEU=$P(RDAT,U,12)
98 ....S RMDLEU=$P(RDAT,U,13)
99 ....S RMDLEU=$S(RMDLEU>999:">999",1:$J(RMDLEU,6,0))
100 ....S RMDLEN=$S(RMDLEN>999:">999",1:$J(RMDLEN,6,0))
101 ....S:(RMVA<1)&(RMVALU>0) RMDLEU=">"_RMCALDAY
102 ....S:(RMCOM<1)&(RMVALN>0) RMDLEN=">"_RMCALDAY
103 ....;total for line item
104 ....S RMTVAL=RMTVAL+RMVA
105 ....S RMTCOML=RMTCOML+RMCOM
106 ....S:RMVA'="" RMTUSELU=RMTUSELU+RMVA
107 ....S:RMCOM'="" RMTUSELN=RMTUSELN+RMCOM
108 ....S RMTISUL=RMTISUL+RMISU
109 ....S RMTISNL=RMTISNL+RMISN
110 ....S RMTAVELU=RMTAVELU+RMAVEU
111 ....S RMTAVELN=RMTAVELN+RMAVEN
112 ....S RMTQOHUL=RMTQOHUL+RMQOHU
113 ....S RMTQOHNL=RMTQOHNL+RMQOHN
114 ....S RMTVALUL=RMTVALUL+RMVALU
115 ....S RMTVALNL=RMTVALNL+RMVALN
116 ....;total for group
117 ....S RMTVAG=RMTVAG+RMVA
118 ....S RMTCOMG=RMTCOMG+RMCOM
119 ....S RMTUSEG=RMTUSEG+RMVA
120 ....S RMTISUG=RMTISUG+RMISU
121 ....S RMTISNG=RMTISNG+RMISN
122 ....S RMTQOHUG=RMTQOHUG+RMQOHU
123 ....S RMTQOHNG=RMTQOHNG+RMQOHN
124 ....S RMTVALUG=RMTVALUG+RMVALU
125 ....S RMTVALNG=RMTVALNG+RMVALN
126 ....S RMGTOU=RMGTOU+RMVALU
127 ....S RMGTON=RMGTON+RMVALN
128 ....S RMGTIU=RMGTIU+RMISU
129 ....S RMGTIN=RMGTIN+RMISN
130 ....S:'RMISU RMISU=""
131 ....S:'RMISN RMISN=""
132 ....S RMVALU=$FN(RMVALU,",",2) S:'RMVALU RMVALU=""
133 ....S RMVALN=$FN(RMVALN,",",2) S:'RMVALN RMVALN=""
134 ....S RNPITEM=RNPITEM_" "
135 ....S RHCPC=RHCPC_" "
136 ....;for used item
137 ....I (RMVA>0)!(RMVALU>0)!(RMVALU<0) D CNTRX S ^TMP($J,"RI",RC)=$E(RHCPC,1,11)_$E(RNPITEM,1,12)_RB1_$J(RMVA,5)_RB1_$J($FN(RMISU,",",2),9)_RB1_"|"_RB18_"|"_RB1_$J(RMVA,5)_RB1_"|"_RB1_$J(RMAVEU,8,2)_RB1_"|"_RB1_$J(RMQOHU,6)
138 ....I (RMVA>0)!(RMVALU>0)!(RMVALU<0) S ^TMP($J,"RI",RC)=^TMP($J,"RI",RC)_RB8_"|"_RB1_$J(RMDLEU,6)_RB1_"|"_RB1_$J(RMVALU,11)
139 ....;for new item
140 ....I (RMCOM>0)!(RMVALN>0)!(RMVALN<0) D CNTRX S ^TMP($J,"RI",RC)=$E(RHCPC,1,11)_$E(RNPITEM,1,13)_RB16_"|"_RB1_$J(RMCOM,6)_RB1_$J($FN(RMISN,",",2),9)_RB1_"|"_RB1_$J(RMCOM,5)_RB1_"|"_RB1_$J(RMAVEN,8,2)_RB1_"|"
141 ....I (RMCOM>0)!(RMVALN>0)!(RMVALN<0) S ^TMP($J,"RI",RC)=^TMP($J,"RI",RC)_RB6_$J(RMQOHN,8)_RB1_"|"_RB1_$J(RMDLEN,6)_RB1_"|"_RB11_$J(RMVALN,11)
142 ....S (RPRINT,RPR)=1
143 ;
144TOT ;print total for Used and New items (all report type)
145 G:$G(RFL) CLEAN1
146 D CNTRX S ^TMP($J,"RI",RC)="" D CNTRX S ^TMP($J,"RI",RC)=RLN
147 D CNTRX S ^TMP($J,"RI",RC)=""
148 I '$G(RPRINT) D CNTRX S ^TMP($J,"RI",RC)="No Records to Print !!" G CLEAN1
149 D CNTRX
150 S ^TMP($J,"RI",RC)=" GRAND TOTAL $ VALUE ISSUED (Used) = $"_$J($FN(RMGTIU,",",2),10)
151 S ^TMP($J,"RI",RC)=^TMP($J,"RI",RC)_" GRAND TOTAL $ VALUE ON-HAND (Used) = $"_$J($FN(RMGTOU,",",2),12)
152 D CNTRX
153 S ^TMP($J,"RI",RC)=" GRAND TOTAL $ VALUE ISSUED (New) = $"_$J($FN(RMGTIN,",",2),10)
154 S ^TMP($J,"RI",RC)=^TMP($J,"RI",RC)_" GRAND TOTAL $ VALUE ON-HAND (New) = $"_$J($FN(RMGTON,",",2),12)
155 D CNTRX S ^TMP($J,"RI",RC)="<End of Report>"
156 ;
157SEND ;send report to HQ
158 S RMQMAIL=$$GETADDR^RMPR5HQ1()
159 D:RMQMAIL="" NOADDR^RMPR5HQ1() G:$D(RQUIT) CLEAN1
160 S RD=$O(^TMP($J,"RMPR5",0)) S RMBDT=RMPRPIP1,RMEDT=RMPRPIP2
161 S XMSUB=RMQSUBJ,XMCHAN=1,XMDUZ=.5,XMY(RMQMAIL)=""
162 ;next line for testing
163 D GET^XMA2 I XMZ<1 G CLEAN1
164 S RMQMES=XMZ,XMTEXT="^TMP($J,""RI""," D ^XMD
165 ;send a confirmation message to local user.
166 D SENDCONF^RMPR5HQ1(RMQSUBJ,RMBD,RMED)
167 ;
168CLEAN1 ; Clean and EXITS program.
169 I $D(ZTQUEUED) S ZTREQ="@" Q
170 D ^%ZISC N RMPR,RMPRSITE D KILL^XUSCLEAN K ^TMP($J) Q
171 ;
172HDRI ;print heading.
173 D CNTRX S ^TMP($J,"RI",RC)=""
174 I RPR=1 D CNTRX S ^TMP($J,"RI",RC)=RES
175 D CNTRX S ^TMP($J,"RI",RC)="",RPR=1,RMPAGE=RMPAGE+1 D CNTRX
176 S ^TMP($J,"RI",RC)="PROSTHETIC INVENTORY ITEM DETAIL REPORT"_RB10_"Run Date: "_RMRDATE
177 S RSTN=$$STN^RMPR5HQC(RSTA)
178 D CNTRX S ^TMP($J,"RI",RC)="STATION: "_$E(RSTN,1,30)_RB6_RMBD_" - "_RMED_" [ "_RMCALDAY_" calendar days ]"
179 Q
180 ;
181CNTRX ;INCREMENT MAIL LINE COUNTER
182 S RC=RC+1 Q
183 ;
184LBL1 ;print column header.
185 D CNTRX S ^TMP($J,"RI",RC)=RLN D CNTRX
186 I RMPRDET="I" S ^TMP($J,"RI",RC)="HCPCS PSAS/ITEM"
187 I RMPRDET="H" S ^TMP($J,"RI",RC)="HCPCS DESCRIPTION"
188 I RMPRDET="L" S ^TMP($J,"RI",RC)="NPPD LINE "
189 I RMPRDET="G" S ^TMP($J,"RI",RC)="NPPD GROUP "
190 S ^TMP($J,"RI",RC)=^TMP($J,"RI",RC)_" V.A.(Used) Total| COM. (New) Total| Total |Days Ave | Stock On-Hand| Days |Total $ Value On-Hand"
191 D CNTRX
192 S ^TMP($J,"RI",RC)=RB23_"Issue $ Value| Issue $ Value| Issue |Usage Rate| Used New | On-Hand| Used New"
193 I RMPRDET'="G" D CNTRX S ^TMP($J,"RI",RC)=RLN
194 Q
195 ;
196GLN1 ;print NPPD GROUP and LINE header.
197 D CNTRX S ^TMP($J,"RI",RC)=""
198 D CNTRX S ^TMP($J,"RI",RC)=RJ_" "_RNPLINE_" ["_RNPGRP_" ]"
199 D LBL1 Q
200 ;
201SUML1 ;print summary total for NPPD LINE
202 D CNTRX S ^TMP($J,"RI",RC)=REQ
203 ;next two lines print used total
204 D CNTRX S:$G(RMTUSELU) RMTAVELU=RMTUSELU/RMCALDAY
205 S:$G(RMTUSELN) RMTAVELN=RMTUSELN/RMCALDAY
206 S ^TMP($J,"RI",RC)=" (Used)"_RB13_$J(RMTVAL,5)_RB1_$J($FN(RMTISUL,",",2),9)_RB1_"|"_RB18_"|"_RB1_$J(RMTUSELU,5)_RB1_"|"_RB1_$J(RMTAVELU,8,2)_RB1_"|"
207 S ^TMP($J,"RI",RC)=^TMP($J,"RI",RC)_RB1_$J(RMTQOHUL,6)_RB8_"|"_RB8_"|"_RB1_$J($FN(RMTVALUL,",",2),11)
208 ;next two lines print new total
209 D CNTRX
210 S ^TMP($J,"RI",RC)=" (New)"_RB30_"|"_RB1_$J(RMTCOML,6)_RB1_$J($FN(RMTISNL,",",2),9)_RB1_"|"_RB1_$J(RMTUSELN,5)_RB1_"|"_RB1_$J(RMTAVELN,8,2)_RB1_"|"
211 S ^TMP($J,"RI",RC)=^TMP($J,"RI",RC)_RB6_$J(RMTQOHNL,8)_RB1_"|"_RB8_"|"_RB11_$J($FN(RMTVALNL,",",2),11)
212 S (RMTVAL,RMTISUL,RMTCOML,RMTISNL,RMTUSEL,RMTAVELU,RMTAVELN,RMTQOHUL,RMTQOHNL,RMTVALUL,RMTVALNL,RLCNT,RMTUSELU,RMTUSELN)=0
213 S (RNPLINE,RLINE)=""
214 Q
Note: See TracBrowser for help on using the repository browser.