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

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

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1IBJDF53 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (SUMMARY);15-APR-00
2 ;;2.0;INTEGRATED BILLING;**123,185,240**;21-MAR-94
3 ;
4INIT ; - Initialize counters, if necessary.
5 ; Pre-set variables IBCAT, IBDIV, IBSEL1 required.
6 N I,IB0
7 I '$D(IB(IBDIV,IBCAT)) D
8 . F IB0=1:1:4 I IBSEL1[IB0 F I=1:1:8 S IB(IBDIV,IBCAT,IB0,I)=0
9 ;
10 Q
11 ;
12EN ; - Compile entry point from IBJDF51.
13 ; Pre-set variables IB(, IBA, IBCAT, IBDIV, IBSEL1, IBTYP required.
14 N I,IB0,IBAGE,IBARD,IBOUT
15 ;
16 ; - Add totals for summary.
17 S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.
18 S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)
19 S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IB0=$$CAT(IBAGE)
20 F I=IBTYP,4 I IBSEL1[I D
21 . S $P(IB(IBDIV,IBCAT,I,IB0),U)=+IB(IBDIV,IBCAT,I,IB0)+1
22 . S $P(IB(IBDIV,IBCAT,I,IB0),U,2)=$P(IB(IBDIV,IBCAT,I,IB0),U,2)+IBOUT
23 ;
24ENQ Q
25 ;
26PRT ; - Print entry point from IBJDF52.
27 N IBDIV
28 ;
29 ; - Extract summary data.
30 I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
31 ;
32 S IBDIV=""
33 F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D
34 . S IBCAT=0
35 . F S IBCAT=$O(IB(IBDIV,IBCAT)) Q:'IBCAT D SUM(.IBCAT) Q:IBQ
36 ;
37ENQ1 Q
38 ;
39EXTMO(IBS) ; Extract/transmit data to DM Extract Module
40 ; IBS - Array containing the summary information
41 ;
42 N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
43 ;
44 F IBI=1:1:6 F IBJ=1:1:16 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
45 ;
46 S IBCT=""
47 F S IBCT=$O(IBS(0,IBCT)) Q:IBCT="" D
48 . S IBTP=0
49 . I IBCT=31 S IBTP=1 ; TRICARE Patient
50 . I IBCT=19 Q ; Sharing Agreements (NOT EXTRACTED)
51 . I IBCT=30 S IBTP=2 ; TRICARE
52 . I IBCT=32 S IBTP=3 ; TRICARE THIRD PARTY
53 . I IBCT=28 S IBTP=4 ; CHAMPVA
54 . I IBCT=29 S IBTP=5 ; CHAMPVA THRID PARTY
55 . S IBSQ=1
56 . F IBI=1:1:7 D
57 . . S IBZ=$G(IBS(0,IBCT,4,IBI))
58 . . S IB(IBTP,IBSQ)=+IBZ
59 . . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
60 . . S IB(IBTP,15)=IB(IBTP,15)+IBZ
61 . . S IB(IBTP,16)=IB(IBTP,16)+$P(IBZ,"^",2)
62 . . S IBSQ=IBSQ+2
63 . S IB(IBTP,16)=$FN(IB(IBTP,16),"",2)
64 ;
65 F IBR=17:1:21 D E^IBJDE(IBR,0)
66 Q
67 ;
68SUM(IBCAT) ; - Print summary for AR category.
69 ; Input: IBCAT=AR category pointer to file #430.2, and pre-set
70 ; variables IBDIV and IBRPT
71 N IBDH,IBTYP,IBTYPH,I,J
72 ;
73 S (IBFLG,IBTYP)=0 D HDR
74 F S IBTYP=$O(IB(IBDIV,IBCAT,IBTYP)) Q:'IBTYP D Q:IBQ
75 . I $Y>(IOSL-16) D HDR Q:IBQ
76 . S IBTYPH=$G(IBCTG(IBCAT(IBCAT)))_" RECEIVABLES ("_$G(IBTPR(IBTYP))_")"
77 . W !!!?(80-$L(IBTYPH))\2,IBTYPH
78 . W !?(80-$L(IBTYPH)\2),$$DASH($L(IBTYPH))
79 . I IBDIV D
80 . . S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U)
81 . . W !?(80-$L(IBDH)\2),IBDH
82 . W !!
83 . ;
84 . ; - Calculate totals first.
85 . F I=1:1:7 F J=1,2 S $P(IB(IBDIV,IBCAT,IBTYP,8),U,J)=$P(IB(IBDIV,IBCAT,IBTYP,8),U,J)+$P(IB(IBDIV,IBCAT,IBTYP,I),U,J)
86 . ;
87 . W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
88 . W "-----------",?31,"-------------",?52,"-------------------------"
89 . I 'IB(IBDIV,IBCAT,IBTYP,8) D D PAUSE Q
90 . . W !!,"There are no active receivables",$S(IBDIV:" for this division",1:""),"."
91 . . S IBFLG=1
92 . ;
93 . ; - Primary loop to write results.
94 . S Y=$P(IB(IBDIV,IBCAT,IBTYP,8),U,2)
95 . F I=1:1:8 S X=$P($T(CATN+I),";;",2,99) D
96 . . W:I=8 ! W !,X,?30,$J(+IB(IBDIV,IBCAT,IBTYP,I),6)
97 . . W " (",$J(+IB(IBDIV,IBCAT,IBTYP,I)/+IB(IBDIV,IBCAT,IBTYP,8)*100,0,$S(I=8:0,1:2)),"%)"
98 . . S Z=$FN($P(IB(IBDIV,IBCAT,IBTYP,I),U,2),",",2)
99 . . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
100 . . W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBCAT,IBTYP,I),U,2)/Y*100),0,$S(I=8:0,1:2)),"%)"
101 . ;
102 . D PAUSE
103 ;
104SUMQ Q
105 ;
106HDR ; - Write the summary report header.
107 N X
108 ;
109 I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
110 S IBPAG=$G(IBPAG)+1
111 W "CHAMPVA/TRICARE FOLLOW-UP SUMMARY REPORT"
112 W ?71,"Page: ",$J(IBPAG,3),!,"Run Date: ",IBRUN
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 $E(X,1,2)=""
122 I X'="" F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
123 ;
124 Q
125 ;
126DASH(X) ; - Return a dashed line.
127 Q $TR($J("",X)," ","=")
128 ;
129PAUSE ; - Page break.
130 I $E(IOST,1,2)'="C-" Q
131 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
132 F IBX=$Y:1:(IOSL-3) W !
133 S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
134 Q
135 ;
136CAT(X) ; - Determine category to place receivable.
137 Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
138 ;
139CATN ; - List of category names.
140 ;;Less than 30 days old
141 ;;31-60 days
142 ;;61-90 days
143 ;;91-120 days
144 ;;121-180 days
145 ;;181-365 days
146 ;;Over 365 days
147 ;;Total C/C-Tricare Receivables
Note: See TracBrowser for help on using the repository browser.