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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1IBJDF43 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (COMPILE/PRINT SUMMARY);15-APR-00
2 ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94
3 ;
4INIT ; - Initialize counters (Called by IBJDF41)
5 ; Pre-set variables IB, IB(, IBCAT, IBSRC required.
6 N I,IB0 S IB0=$S(IB=40:19,1:IB)
7 ;
8 I '$D(IB(IBCAT,IB0)) D
9 .I IBSTA="A",IB0'=16 Q ; Active AR's only.
10 .I IBSTA="S",IB0=16 Q ; Suspended AR's only.
11 .F I=1:1:$S(IBSRC:8,1:7),9 S IB(IBCAT,IB0,I)=0
12 Q
13 ;
14EN ; - Compile entry point from IBJDF41.
15 ; Pre-set variables IB, IB(, IBA, IBCAT, IBSRC required.
16 N I,IB0,IBAGE,IBARD,IBCAT1,IBOUT S IB0=$S(IB=40:19,1:IB)
17 ;
18 ; - Add totals for summary.
19 S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.
20 S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)
21 ;
22 ; - Handle claims referred to Regional Counsel.
23 I IBSRC,$P($G(^PRCA(430,IBA,6)),U,4) D G ENQ
24 .S $P(IB(IBCAT,IB0,8),U)=$P(IB(IBCAT,IB0,8),U)+1
25 .S $P(IB(IBCAT,IB0,8),U,2)=$P(IB(IBCAT,IB0,8),U,2)+IBOUT
26 ;
27 S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IBCAT1=$$CAT^IBJDF2(IBAGE)
28 S $P(IB(IBCAT,IB0,IBCAT1),U)=$P(IB(IBCAT,IB0,IBCAT1),U)+1
29 S $P(IB(IBCAT,IB0,IBCAT1),U,2)=$P(IB(IBCAT,IB0,IBCAT1),U,2)+IBOUT
30 ;
31ENQ K IBPRTFLG,IBPAG,IBRUN,J,Z Q
32 ;
33PRT ; - Print entry point from IBJDF42.
34 ;
35 ; - Extract summary data.
36 I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
37 ;
38 ; - Print the summary report.
39 D SUM
40 ;
41ENQ1 Q
42 ;
43EXTMO(IBS) ; Extract/transmit data to DM Extract Module
44 ; IBS - Array containing the summary information
45 ;
46 N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
47 ;
48 F IBI=1:1:5 F IBJ=1:1:18 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
49 ;
50 S IBCT=""
51 F S IBCT=$O(IBS(IBCT)) Q:IBCT="" D
52 . S IBTP=0
53 . I IBCT=2 S IBTP=1 ; Emergency/Humatiatiran
54 . I IBCT=1 S IBTP=2 ; Ineligible
55 . I IBCT=18 S IBTP=3 ; C - Means Test
56 . I IBCT=22 S IBTP=4 ; RX CO-Payment/SC VET
57 . I IBCT=23 S IBTP=5 ; RX CO-Payment/NSC VET
58 . S IBSQ=1
59 . F IBI=1:1:8 D
60 . . S IBZ=$G(IBS(IBCT,16,IBI))
61 . . S IB(IBTP,IBSQ)=+IBZ
62 . . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
63 . . S IB(IBTP,17)=IB(IBTP,17)+IBZ
64 . . S IB(IBTP,18)=IB(IBTP,18)+$P(IBZ,"^",2)
65 . . S IBSQ=IBSQ+2
66 . S IB(IBTP,18)=$FN(IB(IBTP,18),"",2)
67 ;
68 F IBR=12:1:16 D E^IBJDE(IBR,0)
69 Q
70 ;
71SUM ; - Print summary for AR category.
72 ; Input: IBCAT=AR category pointer to file #430.2
73 S IBS=$S(IBSRC:8,1:7)
74 S (IBCAT,IB,IBPRTFLG)=0
75 F S IBCAT=$O(IB(IBCAT)) Q:'IBCAT D Q:IBQ
76 . D HDR
77 . F S IB=$O(IB(IBCAT,IB)) Q:'IB D Q:IBQ
78 . . ; - Calculate totals first.
79 . . F I=1:1:IBS D Q:IBQ
80 . . . F J=1,2 S $P(IB(IBCAT,IB,9),U,J)=$P(IB(IBCAT,IB,9),U,J)+$P(IB(IBCAT,IB,I),U,J)
81 . . ;
82 . . I $Y>(IOSL-16) D HDR Q:IBQ
83 . . ;
84 . . S X=$S(IB=16:"ACTIVE ",1:"SUSPENDED ")
85 . . S X=X_$P($G(^PRCA(430.2,IBCAT,0)),U)
86 . . W !!!!?(80-$L(X)\2),X,!?(80-$L(X)\2),$$DASH($L(X)),!!
87 . . ;
88 . . W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
89 . . W "-----------",?31,"-------------",?52,"-------------------------",!
90 . . I 'IB(IBCAT,IB,9) W !,"There are no statistics for this category." D PAUSE Q
91 . . ;
92 . . ; - Primary loop to write results.
93 . . S Y=$P(IB(IBCAT,IB,9),U,2)
94 . . F I=1:1:IBS,9 S X=$P($T(CATN+I),";;",2,99) D
95 . . . W:I=9 ! W !,X,?30,$J(+IB(IBCAT,IB,I),6)
96 . . . W " (",$J(+IB(IBCAT,IB,I)/+IB(IBCAT,IB,9)*100,0,$S(I=9:0,1:2)),"%)"
97 . . . S Z=$FN($P(IB(IBCAT,IB,I),U,2),",",2)
98 . . . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
99 . . . W " (",$J($S('Y:0,1:$P(IB(IBCAT,IB,I),U,2)/Y*100),0,$S(I=9:0,1:2)),"%)"
100 . . ;
101 . . S IBPRTFLG=1 D PAUSE
102 ;
103 I 'IBPRTFLG D
104 . W !!!!!!,"There are no receivables for the parameters entered."
105 ;
106SUMQ Q
107 ;
108HDR ; - Write the summary report header.
109 W:'$G(IBPAG) ! I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
110 S IBPAG=$G(IBPAG)+1
111 W "FIRST PARTY FOLLOW-UP SUMMARY REPORT Run Date: ",IBRUN
112 W ?71,"Page: ",$J(IBPAG,3)
113 S X=""
114 I IBRPT="D" D
115 . I IBSMN'="A" D
116 . . S X=" RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
117 . I $G(IBSNA)'="ALL" D
118 . . S X=X_"/ PATIENTS FROM '"_$S(IBSNF="":"FIRST",1:IBSNF)_"' TO '"
119 . . S X=X_$S(IBSNL="zzzzz":"LAST",1:IBSNL)_"' "
120 . I $G(IBSAM) S X=X_"/ MINIMUM BALANCE: $"_$FN(IBSAM,",",2)_" "
121 S X=X_"/ RECEIVABLES REFERRED TO RC "_$S('IBSRC:"NOT ",1:"")_"INCLUDED"
122 S $E(X,1,2)=""
123 F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
124 ;
125 Q
126 ;
127DASH(X) ; - Return a dashed line.
128 Q $TR($J("",X)," ","=")
129 ;
130PAUSE ; - Page break.
131 I $E(IOST,1,2)'="C-" Q
132 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
133 F IBX=$Y:1:(IOSL-3) W !
134 S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
135 Q
136 ;
137CATN ; - List of category names.
138 ;;Less than 30 days old
139 ;;31-60 days
140 ;;61-90 days
141 ;;91-120 days
142 ;;121-180 days
143 ;;181-365 days
144 ;;Over 365 days
145 ;;Referred to Regional Counsel
146 ;;Total First Party Receivables
Note: See TracBrowser for help on using the repository browser.