source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDF2.m@ 1006

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

initial load of WorldVistAEHR

File size: 8.3 KB
RevLine 
[613]1IBJDF2 ;ALB/CPM - THIRD PARTY FOLLOW-UP SUMMARY REPORT ; 03-JAN-97
2 ;;2.0;INTEGRATED BILLING;**69,91,100,118,133,205**;21-MAR-94
3 ;
4EN ; - Option entry point.
5 ;
6 W !!,"This report provides a summary of all outstanding Third Party receivables.",!
7 ;
8DATE ; - Choose date to use for calculation
9 W !!,"Calculate report using (D)ATE OF CARE or (A)CTIVE IN AR (days): (A)CTIVE IN AR// " R X:DTIME
10 G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
11 I "ADad"'[X S IBOFF=99 D HELP^IBJDF1H G DATE
12 W " ",$S("Dd"[X:"DATE OF CARE",1:"(DAYS) ACTIVE IN AR")
13 S IBSDATE=$S("Dd"[X:"D",1:"A")
14 ;
15 ; - Sort by division.
16 S DIR(0)="Y",DIR("B")="NO"
17 S DIR("A")="Do you wish to sort this report by division"
18 S DIR("?")="^D DHLP^IBJDF2"
19 D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
20 S IBSORT=+Y K DIROUT,DTOUT,DUOUT,DIRUT
21 ;
22 ; - Issue prompt for division.
23 I IBSORT D PSDR^IBODIV G:Y<0 ENQ
24 ;
25TYP ; - Select type of summaries to print.
26 W !!,"Choose which type of summaries to print:",!
27 S DIR(0)="LO^1:4^K:+$P(X,""-"",2)>4 X"
28 S DIR("A",1)=" 1 - INPATIENT RECEIVABLES"
29 S DIR("A",2)=" 2 - OUTPATIENT RECEIVABLES"
30 S DIR("A",3)=" 3 - PHARMACY REFILL RECEIVABLES"
31 S DIR("A",4)=" 4 - ALL RECEIVABLES"
32 S DIR("A",5)="",DIR("A")="Select",DIR("B")=4
33 D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
34 S IBSEL=Y K DIROUT,DTOUT,DUOUT,DIRUT
35 ;
36 W !!,"This report only requires an 80 column printer."
37 W !!,"Note: This report requires a search through all active receivables."
38 W !?6,"You should queue this report to run after normal business hours.",!
39 ;
40 ; - Select a device.
41 S %ZIS="QM" D ^%ZIS G:POP ENQ
42 I $D(IO("Q")) D G ENQ
43 .S ZTRTN="DQ^IBJDF2",ZTDESC="IB - FOLLOW-UP SUMMARY REPORT"
44 .F I="IBSEL","IBSDATE","IBSORT","VAUTD","VAUTD(" S ZTSAVE(I)=""
45 .D ^%ZTLOAD
46 .W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
47 .K ZTSK,IO("Q") D HOME^%ZIS
48 ;
49 U IO
50 ;
51DQ ; - Tasked entry point.
52 ;
53 I $G(IBXTRACT) D E^IBJDE(9,1) ; Change extract status.
54 ;
55 K IB F I=1,2,3,4 I IBSEL[I D
56 .I 'IBSORT D Q
57 ..F J=1:1:9 S IB(0,I,J)=""
58 .I 'VAUTD D Q
59 ..S J=0 F S J=$O(VAUTD(J)) Q:'J F K=1:1:9 S IB(J,I,K)=""
60 .S J=0 F S J=$O(^DG(40.8,J)) Q:'J F K=1:1:9 S IB(J,I,K)=""
61 ;
62 ; - Find data required for the report.
63 S (IBQ,IBA)=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
64 .;
65 .I IBA#100=0 S IBQ=$$STOP^IBOUTL("Third Party Follow-Up Summary Report") Q:IBQ
66 .;
67 .S IBAR=$G(^PRCA(430,IBA,0))
68 .I $P(IBAR,U,2)'=9 Q ; Not an RI bill.
69 .S:"Aa"[IBSDATE IBARD=$$ACT(IBA) S:"Dd"[IBSDATE IBARD=$$DATE1(IBA) I 'IBARD Q ; No activation date.
70 .I '$D(^DGCR(399,IBA,0)) Q ; No corresponding claim to this AR.
71 .;
72 .; - Get division if necessary.
73 .I 'IBSORT S IBDIV=0
74 .E S IBDIV=$$DIV(IBA) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
75 .I IBSORT,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
76 .;
77 .; - Determine whether bill is inpatient, outpatient, or RX refill.
78 .S IBTYP=$P($G(^DGCR(399,IBA,0)),U,5),IBTYP=$S(IBTYP>2:2,1:1)
79 .S:$D(^IBA(362.4,"C",IBA)) IBTYP=3 I IBSEL'[IBTYP,IBSEL'[4 Q
80 .;
81 .; - Handle claims referred to Regional Counsel.
82 .S IBOUT=+$G(^PRCA(430,IBA,7))
83 .I $P($G(^PRCA(430,IBA,6)),U,4) D Q
84 ..F I=IBTYP,4 I IBSEL[I D
85 ...S $P(IB(IBDIV,I,8),U)=+IB(IBDIV,I,8)+1
86 ...S $P(IB(IBDIV,I,8),U,2)=$P(IB(IBDIV,I,8),U,2)+IBOUT
87 .;
88 .; - Determine age and outstanding balance.
89 .S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IBCAT=$$CAT(IBAGE)
90 .;
91 .F I=IBTYP,4 I IBSEL[I D
92 ..S $P(IB(IBDIV,I,IBCAT),U)=+IB(IBDIV,I,IBCAT)+1
93 ..S $P(IB(IBDIV,I,IBCAT),U,2)=$P(IB(IBDIV,I,IBCAT),U,2)+IBOUT
94 ;
95 I IBQ G ENQ
96 ;
97 ; - Extract summary data.
98 I $G(IBXTRACT) D G ENQ
99 .F I=1:1:8 D
100 ..F J=1,2 S $P(IB(0,4,9),U,J)=$P(IB(0,4,9),U,J)+$P(IB(0,4,I),U,J)
101 .S I=0 F J=1:1:9 D
102 ..S I=I+1,IB(I)=+IB(0,4,J),I=I+1,IB(I)=$J(+$P(IB(0,4,J),U,2),0,2)
103 .D E^IBJDE(9,0)
104 ;
105 ; - Print the reports.
106 S (IBPAG,IBQ)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
107 I 'IBSORT D SUM(0) G ENQ
108 ;
109 S IBDIV=0 F S IBDIV=$O(IB(IBDIV)) Q:'IBDIV D SUM(IBDIV) Q:IBQ
110 ;
111ENQ I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
112 ;
113 D ^%ZISC
114ENQ1 K IB,IBOFF,IBQ,IBSDATE,IBSEL,IBSORT,IBTEXT,IBA,IBAR,IBARD,IBDIV,IBAGE,IBOUT,IBCAT,IBPAG,IBRUN
115 K IBDH,IBTYP,IBTYPH,%,%ZIS,DFN,I,J,K,POP,VAUTD,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE
116 K DIROUT,DTOUT,DUOUT,DIRUT
117 Q
118 ;
119SUM(IBDIV) ; - Print the report.
120 ; Input: IBDIV=Pointer to the division in file #40.8
121 ;
122 S IBTYP=0 F S IBTYP=$O(IB(IBDIV,IBTYP)) Q:'IBTYP D Q:IBQ
123 .I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
124 .S IBPAG=IBPAG+1 I $E(IOST,1,2)'="C-" W !?68,"Page: ",IBPAG
125 .W !!?22,"THIRD PARTY FOLLOW-UP SUMMARY REPORT"
126 .S IBTYPH=$S(IBTYP=1:"INPATIENT",IBTYP=2:"OUTPATIENT",IBTYP=3:"RX REFILL",1:"ALL REIMBURSABLE")_" RECEIVABLES"_$S(IBSDATE="D":" ( date of care )",1:" ( days in AR )")
127 .W !?(80-$L(IBTYPH))\2,IBTYPH
128 .I IBDIV S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U) W !?(80-$L(IBDH)\2),IBDH
129 .W !!?24,"Run Date: ",IBRUN,!?24,$$DASH(31),!!
130 .;
131 .; - Calculate totals first.
132 .F I=1:1:8 F J=1,2 S $P(IB(IBDIV,IBTYP,9),U,J)=$P(IB(IBDIV,IBTYP,9),U,J)+$P(IB(IBDIV,IBTYP,I),U,J)
133 .;
134 .W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance"
135 .W !,"-----------",?31,"-------------",?52,"-------------------------",!
136 .;
137 .I 'IB(IBDIV,IBTYP,9) W !,"There are no active receivables",$S(IBDIV:" for this division",1:""),"." D PAUSE Q
138 .;
139 .; - Primary loop to write results.
140 .S Y=$P(IB(IBDIV,IBTYP,9),U,2) F I=1:1:9 S X=$P($T(CATN+I),";;",2,99) D
141 ..W:I=9 ! W !,X,?30,$J(+IB(IBDIV,IBTYP,I),6)
142 ..W " (",$J(+IB(IBDIV,IBTYP,I)/+IB(IBDIV,IBTYP,9)*100,0,$S(I=9:0,1:2)),"%)"
143 ..S Z=$FN($P(IB(IBDIV,IBTYP,I),U,2),",",2)
144 ..W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
145 ..W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBTYP,I),U,2)/Y*100),0,$S(I=9:0,1:2)),"%)"
146 .;
147 .D PAUSE
148 ;
149SUMQ Q
150 ;
151DASH(X) ; - Return a dashed line.
152 Q $TR($J("",X)," ","=")
153 ;
154PAUSE ; - Page break.
155 I $E(IOST,1,2)'="C-" Q
156 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
157 F IBX=$Y:1:(IOSL-3) W !
158 S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
159 Q
160 ;
161DHLP ; - 'Display Registration User' help.
162 W !,"Enter <CR> to summarize all receivables without regard to division,"
163 W !,"or YES to select those divisions for which a separate report should"
164 W !,"be created."
165 Q
166 ;
167CAT(X) ; - Determine category to place receivable.
168 Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
169 ;
170ACT(X) ; - Determine the activation date for a receivable.
171 N Y S Y=0 I '$G(X) G ACTQ
172 S Y=$P($G(^PRCA(430,X,6)),U,21) I Y G ACTQ
173 S Y=$P($G(^PRCA(430,X,9)),U,3) I Y G ACTQ
174 S Y=$P($G(^PRCA(430,X,0)),U,10)
175ACTQ Q Y
176 ;
177DATE1(X) ; - Determine the Date of Care
178 N Y S Y=0 I '$G(X) G DATEQ
179 S Y=$P($G(^DGCR(399,X,"U")),U,2) I Y G DATEQ
180DATEQ Q Y
181 ;
182DIV(IBX) ; - Determine the division for a claim.
183 ; Input: IBX=Pointer to a claim in file #399
184 ; Output: IBY=Pointer to a division in file #40.8,
185 ; or 0 if not determined
186 ;
187 N DFN,IBADM,IBEV,IBD,IBPTF,IBU,IBY,IBC,IBTY,VAINDT,VADMVT
188 S IBY=0,IBC=$G(^DGCR(399,+$G(IBX),0)) I $P(IBC,U)="" G DIVQ
189 S DFN=+$P(IBC,U,2),IBEV=+$P(IBC,U,3)\1,IBTY=$P(IBC,U,5)
190 ;
191 S IBY=+$P(IBC,U,22) I +IBY G DIVQ ; use bill default division if defined
192 ;
193 ; - For Pharmacy or Prosthetics claims, use the primary division.
194 I $D(^IBA(362.4,"AIFN"_IBX))!$D(^IBA(362.5,"AIFN"_IBX)) D G DIVQ
195 .S IBY=$$PRIM^VASITE(DT) S:IBY'>0 IBY=0
196 ;
197 ; - Check all visit dates if outpatient claim.
198 I IBTY>2 D G DIVQ
199 .S IBY=$$OPT(IBEV,DFN) Q:IBY
200 .S IBD=0 F S IBD=$O(^DGCR(399,IBX,"OP",IBD)) Q:'IBD S IBY=$$OPT(IBD,DFN) Q:IBY
201 ;
202 ; - Check inpatient claim.
203 S IBPTF=+$P(IBC,U,8),IBU=$G(^DGCR(399,IBX,"U"))
204 I IBPTF S IBADM=$O(^DGPM("APTF",IBPTF,0)) I IBADM S IBY=$$INP(IBADM) G:IBY DIVQ
205 S VAINDT=+IBU\1_.23 D ADM^VADPT2 I VADMVT S IBY=$$INP(VADMVT) G:IBY DIVQ
206 S VAINDT=$S($P(IBEV,".",2):IBEV,1:+IBEV\1_.23) D ADM^VADPT2 I VADMVT S IBY=$$INP(VADMVT)
207 ;
208DIVQ ; - If a division cannot be determined, use the primary division.
209 I 'IBY S IBY=$$PRIM^VASITE(DT) S:IBY'>0 IBY=0
210 Q IBY
211 ;
212INP(X) ; - Return division for a movement.
213 Q +$P($G(^DIC(42,+$P($G(^DGPM(+$G(X),0)),U,6),0)),U,11)
214 ;
215OPT(X,DFN) ; - Return division for a patient's outpatient visit date.
216 N IBFR,IBTO,IBY,IBY1,IBZ,IBZERR
217 S IBY=0 I '$G(X) G OPTQ
218 S IBFR=X,IBTO=X\1_".99"
219 F S IBZ=$$EXOE^SDOE(DFN,IBFR,IBTO,,"IBZERR") K IBZERR Q:'IBZ S IBY1=$$SCE^IBSDU(IBZ) D Q:IBY
220 .I $P(IBY1,U,11) S IBY=$P(IBY1,U,11) Q
221 .S IBFR=IBY1+.000001
222OPTQ Q IBY
223 ;
224CATN ; - List of category names.
225 ;;Less than 30 days old
226 ;;31-60 days
227 ;;61-90 days
228 ;;91-120 days
229 ;;121-180 days
230 ;;181-365 days
231 ;;Over 365 days
232 ;;Referred to Regional Counsel
233 ;;Total Third Party Receivables
Note: See TracBrowser for help on using the repository browser.