source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBNCPRR.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1IBNCPRR ;DALOI/AAT - Prescription Report for 3rd Party Billing cross check ;07/21/04
2 ;;2.0;INTEGRATED BILLING;**276,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ;
6 N IBQ,IBSITE,IBWMC,IBENB,IBBDT,IBEDT,IBINS,IBSDE,IBSCR
7 S IBQ=0 ; quit flag
8 ; Prompts to the user:
9 D DIV Q:IBQ ; Division
10 D WMC Q:IBQ ; W/M/C criteria
11 D ENB Q:IBQ ; ECME/NON-ECME/BOTH criteria
12 D DATE Q:IBQ ; From-To date range
13 D INS Q:IBQ ; Insurance company
14 D SDE Q:IBQ ; Summary/Detailed/Excel criteria
15 D DEVICE Q:IBQ
16 D RUN
17 I IBQ'=2 D PAUSE2
18 Q
19 ;
20DIV N DIC,DIRUT
21 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEQM" D DIC^PSODI(59,.DIC,) S IBSITE=+Y K Y
22 I $D(DIRUT) S IBQ=1 Q
23 I IBSITE'>0 S IBQ=1 Q
24 I $G(PSODIY) K PSODIY
25 Q
26 ;
27WMC N DIR,DIRUT,Y
28 W ! S DIR("B")="CMOP",DIR("A")="(W)INDOW/(M)AIL/(C)MOP: "
29 S DIR(0)="SA^W:WINDOW;M:MAIL;C:CMOP" D ^DIR
30 I $D(DIRUT) S IBQ=1 Q
31 S IBWMC=Y
32 Q
33 ;
34ENB N DIR,DIRUT,Y
35 W ! S DIR("B")="ECME BILLABLE",DIR("A")="(E)CME Billable/(N)on-ECME Billable/(B)OTH: "
36 S DIR(0)="SA^E:ECME BILLABLE;N:NON-ECME BILLABLE;B:BOTH" D ^DIR
37 I $D(DIRUT) S IBQ=1 Q
38 S IBENB=Y
39 Q
40 ;
41DATE ;
42 N %DT,Y
43 S (IBBDT,IBEDT)=DT
44 S %DT="AEX"
45 S %DT("A")="FROM RELEASE DATE: ",%DT("B")="TODAY"
46 W ! D ^%DT K %DT
47 I Y<0 S IBQ=1 Q
48 S IBBDT=+Y
49 S %DT="AEX"
50 S %DT("A")="TO RELEASE DATE: ",%DT("B")="TODAY" ;$$DAT2^IBOUTL(IBBDT)
51 D ^%DT K %DT
52 I Y<0 S IBQ=1 Q
53 S IBEDT=+Y
54 Q
55 ;
56INS N DIR,DIC,DIRUT,Y
57 W ! S DIR("B")="ALL",DIR("A")="(S)INGLE Insurance Company /(A)LL Insurance Companies: "
58 S DIR(0)="SA^S:SINGLE INSURANCE COMPANY;A:ALL" D ^DIR
59 I $D(DIRUT) S IBQ=1 Q
60 I Y="A" S IBINS=0 Q
61 ;
62 S DIC(0)="AEQM",DIC=36
63 W ! D ^DIC
64 I $D(DIRUT) S IBQ=1 Q
65 I Y'>0 S IBQ=1 Q
66 S IBINS=+Y
67 Q
68 ;
69SDE N DIR,DIRUT
70 S DIR("B")="SUMMARY",DIR("A")="(S)UMMARY/(D)ETAILED/(E)XCEL: "
71 S DIR(0)="SA^S:SUMMARY;D:DETAILED;E:EXCEL"
72 W ! D ^DIR
73 I $D(DIRUT) S IBQ=1 Q
74 S IBSDE=Y
75 Q
76 ;
77DEVICE ;
78 N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,POP,ZTSAVE
79 S %ZIS="QM"
80 W ! D ^%ZIS
81 I POP S IBQ=1 Q
82 S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
83 ;
84 I $D(IO("Q")) D S IBQ=1
85 . S ZTRTN="RUN^IBNCPRR"
86 . S ZTIO=ION
87 . S ZTSAVE("IB*")=""
88 . S ZTDESC="IB ECME CMOP REPORT"
89 . D ^%ZTLOAD
90 . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
91 . D HOME^%ZIS
92 U IO
93 Q
94 ;
95RUN ;
96 N IBPAGE,REF
97 S REF=$NA(^TMP($J,"IBNCPRR"))
98 K @REF
99 S IBPAGE=0
100 D COLLECT ; Collect the data in ^TMP
101 U IO
102 D REPORT
103 I 'IBSCR W !,@IOF
104 D ^%ZISC
105 K @REF
106 Q
107 ;
108REPORT ;
109 N IBDT,IBRX,IBFL,IBPN,DFN,IBD
110 D HDR
111 I '$D(@REF) W !,"No data meet the criteria."
112 S IBDT="" F S IBDT=$O(@REF@(IBDT)) Q:IBDT="" D Q:IBQ
113 . S IBPN="" F S IBPN=$O(@REF@(IBDT,IBPN)) Q:IBPN="" D Q:IBQ
114 .. S IBRX="" F S IBRX=$O(@REF@(IBDT,IBPN,IBRX)) Q:IBRX="" D Q:IBQ
115 ... S IBFL="" F S IBFL=$O(@REF@(IBDT,IBPN,IBRX,IBFL)) Q:IBFL="" D Q:IBQ
116 .... S IBD=$G(@REF@(IBDT,IBPN,IBRX,IBFL)) Q:IBD=""
117 .... I IBSDE="S" D WRLINE Q
118 .... I IBSDE="D" D WRLINE2 Q
119 .... I IBSDE="E" D WRLINE3 Q
120 ;
121 Q
122 ;
123WRLINE ; Write the summary report line
124 D CHKP Q:IBQ
125 W !,$$DAT3^IBOUTL(IBDT)," ",?12,$E(IBPN,1,23)," "
126 W ?36,$E($$FILE^IBRXUTL(IBRX,.01),1,11)," ",?48,IBFL
127 W ?51,$P(IBD,U,3)," " ; ECME number
128 W ?59,$P($G(^DGCR(399,+$P(IBD,U,4),0)),U)," " ; Bill #
129 W ?67,$E($P($G(^DIC(36,+$P(IBD,U,5),0)),U),1,13) ; Insurance
130 Q
131 ;
132WRLINE2 ; Write the detailed report line
133 N IBRXARR
134 D CHKP Q:IBQ
135 W !,$$DAT^IBNCPRR1(IBDT)," ",?10,$E(IBPN,1,18)," "
136 W ?29,$$SSN4^IBNCPRR1(+IBD)
137 W ?34,$E($$FILE^IBRXUTL(IBRX,.01),1,10)," "
138 W ?45,IBFL," "
139 W ?49,$$DAT^IBNCPRR1($P(IBD,U,2))," "
140 N DRGIFN,DRUGNM,SEQNUM
141 S DRGIFN=$$FILE^IBRXUTL(IBRX,6) D ZERO^IBRXUTL(DRGIFN) S DRUGNM=^TMP($J,"IBDRUG",DRGIFN,.01)
142 K ^TMP($J,"IBDRUG")
143 W ?60,$E(DRUGNM,1,20)
144 ; ECME#/Rx Status/Copay
145 D CHKP Q:IBQ
146 W !?5,"ECME#: ",$P(IBD,U,3),", Rx Status: ",$$FILE^IBRXUTL(IBRX,100,"E"),", Rx Copay: ",$$COPAY^IBNCPRR1(IBRX,IBFL)
147 ; Bill Number/Insurance/Group
148 I $P(IBD,U,4) D CHKP Q:IBQ D
149 . W !?5,"Bill#: ",$P($G(^DGCR(399,+$P(IBD,U,4),0)),U)
150 . W ", Insurance: ",$E($P($G(^DIC(36,+$P(IBD,U,5),0)),U),1,20)
151 . ;W ", Group Ins.Plan: ?"
152 ; CMOP Transactions
153 I IBWMC="C" D Q:IBQ
154 . N IBCMOP,IBZ,IBANY
155 . S IBANY=0
156 . S IBCMOP=0
157 . S DFN=$$FILE^IBRXUTL(IBRX,2)
158 . D RX^PSO52API(DFN,"IBRX",IBRX,,"C",,)
159 . F S IBCMOP=$O(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP)) Q:'IBCMOP D Q:IBQ
160 .. S IBZ=$O(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,0)) Q:IBZ=""
161 .. I +$P(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,2),"^",1)'=IBFL Q ; different refill
162 .. D CHKP Q:IBQ
163 .. N DR,DA,DIQ,DIC
164 .. S DR=400,DR(52.01)="1"
165 .. S DA=IBRX,DA(52.01)=IBCMOP
166 .. S DIQ="IBRXARR",DIQ(0)="E"
167 .. D DIQ^PSODI(52,52,.DR,.DA,.DIQ) S SEQNUM=$G(IBRXARR(52.01,DA(52.01),DR(52.01),DIQ(0)))
168 .. W !?5,"CMOP SEQUENCE# ",SEQNUM
169 .. W ", STATUS: ",$P(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,3),"^",2)
170 .. W ", NDC: ",$P(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,4),"^",1) S IBANY=1
171 .K ^TMP($J,"IBRX")
172 . I 'IBANY D CHKP Q:IBQ W !?5,"NO CMOP TRANSACTIONS FOUND"
173 ;
174 ; Write activity log
175 N IBACT,IBFROM,IBTO,IBTMP
176 S IBFROM=IBDT,IBTO=$$NXTREFDT^IBNCPRR1(IBRX,IBFL)
177 I IBTO<IBFROM S IBTO=IBFROM
178 S DFN=$$FILE^IBRXUTL(IBRX,2),LIST="IBTMPARR",NODE="A"
179 D RX^PSO52API(DFN,LIST,IBRX,,NODE,,) Q:$P(^TMP($J,LIST,DFN,IBRX,"A",.01),"^",1)<0
180 S IBTMP=0
181 F S IBTMP=$O(^TMP($J,LIST,DFN,IBRX,"A",IBTMP)) Q:IBTMP="" D Q:IBQ
182 . N IBZ,IBTXT
183 . I $P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.02),"^",1)'="B",$P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.02),"^",1)'="M" Q
184 . S IBZ=$P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.01),"^",1)
185 . I IBZ<IBFROM Q
186 . I IBZ>IBTO Q
187 . D CHKP Q:IBQ
188 . S IBTXT=$P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.05),"^",1)
189 . S:$TR(IBTXT," ")="" IBTXT=$$EXTERNAL^DILFD(52.3,.02,,$P(IBZ,U,2))
190 . W !?5,$$DATTIM^IBNCPRR1(+IBZ),?21,$E(IBTXT,1,59)
191 K ^TMP($J,LIST)
192 D CHKP Q:IBQ
193 W !?5,"-------------------------------"
194 Q
195 ;
196WRLINE3 ; Write the Excel report line
197 W !,$$DAT^IBNCPRR1(IBDT),U,$E(IBPN,1,23),U
198 W $E($$FILE^IBRXUTL(IBRX,.01),1,11),U,IBFL,U
199 W $$DAT^IBNCPRR1($P(IBD,U,2)),U
200 W $P(IBD,U,3),U ; ECME number
201 W $P($G(^DGCR(399,+$P(IBD,U,4),0)),U),U ; Bill #
202 W $E($P($G(^DIC(36,+$P(IBD,U,5),0)),U),1,13) ; Insurance
203 Q
204 ;
205HDR ;
206 N LIST,IBSNAME
207 S LIST="HDRLIST"
208 S IBSNAME=""
209 D PSS^PSO59(IBSITE,,LIST)
210 I $G(^TMP($J,LIST,IBSITE,0))>0 S IBSNAME=^TMP($J,LIST,IBSITE,.01)
211 K ^TMP($J,LIST)
212 S IBPAGE=IBPAGE+1
213 W @IOF,?10,"IB THIRD PARTY BILLING PHARMACY CROSS-CHECK REPORT for "_IBSNAME,!
214 W ?10,$S(IBWMC="C":"CMOP",IBWMC="M":"MAIL",1:"WINDOW")," PRESCRIPTIONS" W ", ",$S(IBSDE="S":"SUMMARY",1:"DETAILED")
215 W !?10,"Released ",$$DAT3^IBOUTL(IBBDT)_" to "_$$DAT3^IBOUTL(IBEDT),?70,"Page: "_IBPAGE
216 I IBSDE="S" D
217 . W !!,"Rel.Date Patient Name Rx No Fill# ECME# Bill Insurance"
218 I IBSDE="D" D
219 . W !!,"Rel.Date Patient Name SSN Rx No Fill# Fil.Date Drug"
220 I IBSDE="E" D
221 . W !!,"Rel.Date^Patient Name^SSN^Rx No^Fill#^Fil.Date^ECME#^Bill"
222 I IBSDE'="E" D ULINE("=")
223 Q
224 ;
225 ;
226COLLECT ;
227 N IBDT,IBRX,IBFL,IBP,DFN,IBRXINS,IBZ,IBRXN,IBFLDT,IBPN,IBECN,IBECMBIL,IBRXSITE,IBBIL,IBFILD,LIST,CNT
228 S IBDT=IBBDT-.0001
229 ; Released Prescriptions/Refills
230 S LIST="IBRXARR"
231 D EXTRACT^PSO52EX(IBBDT,IBEDT,LIST)
232 S DTE=0,CNT=0
233 F S DTE=$O(^TMP($J,LIST,"AL",DTE)) Q:'DTE D
234 .S IBRX="" F S IBRX=$O(^TMP($J,LIST,"AL",DTE,IBRX)) Q:'IBRX D
235 ..S IBFIL="" F S IBFIL=$O(^TMP($J,LIST,"AL",DTE,IBRX,IBFIL)) Q:IBFIL="" D
236 ...S DFN=$$FILE^IBRXUTL(IBRX,2) ;Patient
237 ...S IBZ=$$RXZERO^IBRXUTL(DFN,IBRX)
238 ...S IBPN=$$FILE^IBRXUTL(IBRX,2,"E")
239 ...S IBRXSITE=$$FILE^IBRXUTL(IBRX,20)
240 ...I IBSITE'=IBRXSITE Q
241 ...I IBFIL=0 S IBFLDT=$$FILE^IBRXUTL(IBRX,22)
242 ...I IBFIL>0 S IBFLDT=$$SUBFILE^IBRXUTL(IBRX,IBFL,52,.01)
243 ...S:'IBFLDT IBFLDT=IBDT
244 ... S IBBIL=$$BILL^IBNCPBB(IBRXN,IBFLDT) ; IB Bill
245 ... S IBRXINS=$$BILLINS^IBNCPRR1(IBBIL)
246 ... I 'IBRXINS S IBRXINS=$$RXINS^IBNCPRR1(IBRX,IBFL)
247 ... S IBECMBIL=$$ECMEBIL^IBNCPDPU(DFN,IBFLDT) ; ECME Billable?
248 ... ; Apply filters:
249 ... I IBENB="E",'IBECMBIL Q
250 ... I IBENB="N",IBECMBIL Q
251 ... I IBINS,IBRXINS'=IBINS Q
252 ... ; Mail/Window/CMOP
253 ... I IBWMC'=$$RXWMC(IBRX) Q
254 ... S IBECN=$S(IBECMBIL:$$ECMENO^IBNCPRR1(IBRX),1:"")
255 ... S @REF@($P(IBDT,"."),IBPN,IBRX,IBFL)=DFN_U_IBFLDT_U_IBECN_U_IBBIL_U_IBRXINS
256 K ^TMP($J,LIST)
257 ;
258 ;;Partial Prescriptions
259 ;S IBRXN=0
260 ;S IBDT=IBBDT-.001 F S IBDT=$O(^PSRX("ADP",IBDT)) Q:'IBDT!($P(IBDT,".")>IBEDT) D
261 ;. F S IBRX=$O(^PSRX("ADP",IBDT,IBRX)) Q:'IBRX D
262 ;.. S IBP=0 F S IBP=$O(^PSRX("ADP",IBDT,IBRX,IBP)) Q:'IBP D
263 ;... I $G(^PSRX(IBRX,0))="" Q
264 ;... S IBPAR=1 D REF
265 Q
266 ;
267 ;
268RXWMC(IBRX) ;WMC
269 N IBZ,IBWM,DFN
270 S DFN=$$FILE^IBRXUTL(IBRX,2),NODE="C",LIST="IBCMOP"
271 D RX^PSO52API(DFN,LIST,IBRX,,NODE,,)
272 I ^TMP($J,LIST,DFN,IBRX,"C",0)'=-1 Q "C"
273 S IBZ=$$RXZERO^IBRXUTL($$FILE^IBRXUTL(IBRX,2),IBRX)
274 S IBWM=$P(IBZ,U,11)
275 I IBWM="" S IBWM="W" ;default
276 K ^TMP($J,LIST)
277 Q IBWM
278 ;
279CHKP ;Check for EOP
280 I $Y>(IOSL-4) D:IBSCR PAUSE Q:IBQ D HDR
281 Q
282 ;
283PAUSE ;
284 N X U IO(0) W !!,"Press RETURN to continue, '^' to exit:" R X:DTIME S:'$T X="^" S:X["^" IBQ=2
285 U IO
286 Q
287 ;
288PAUSE2 ;
289 N X U IO(0) W !!,"Press RETURN to continue:" R X:DTIME S:'$T X="^" S:X["^" IBQ=2
290 U IO
291 Q
292 ;
293ULINE(X) ;line
294 D CHKP Q:IBQ
295 N I W ! F I=1:1:80 W $G(X,"-")
296 Q
297 ;
298RXSTAT(IBDFN,IBRX) ;
299 N IBS
300 ;instead of: S IBS=$P($G(^PSRX(IBRX,"STA")),U)
301 S IBS=$$RXSTATUS(IBDFN,IBRX)
302 Q $$EXTERNAL^DILFD(52,100,,IBS)
303 ;
304RXSTATUS(IBDFN,IBRX) ;
305 N X
306 K ^TMP($J,"IBNCPDP52")
307 D RX^PSO52API(IBDFN,"IBNCPDP52",IBRX,"","ST")
308 S X=+$G(^TMP($J,"IBNCPDP52",IBDFN,IBRX,100))
309 K ^TMP($J,"IBNCPDP52")
310 Q X
311 ;
Note: See TracBrowser for help on using the repository browser.