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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1IBJDF63 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE/PRINT SUMMARY);15-APR-00
2 ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94
3 ;
4INIT ; - Initialize counters, if necessary.
5 I IBSDV,IBDIV," 6 7 10 21 "'[(" "_IBCAT_" ") Q
6 I IBSDV,'IBDIV," 6 7 10 21 "[(" "_IBCAT_" ") Q
7 F I=1:1:8 S IB(IBDIV,IBCAT,I)=0
8 Q
9 ;
10EN ; - Compile entry point from IBJDF61.
11 ; Pre-set variables IBA, IBCAT, IBDIV required.
12 N I,IB0,IBAGE,IBARD,IBOUT,J
13 ;
14 ; - Add totals for summary.
15 S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.
16 S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)
17 S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IB0=$$CAT(IBAGE)
18 S $P(IB(IBDIV,IBCAT,IB0),U)=+IB(IBDIV,IBCAT,IB0)+1
19 S $P(IB(IBDIV,IBCAT,IB0),U,2)=$P(IB(IBDIV,IBCAT,IB0),U,2)+IBOUT
20ENQ Q
21 ;
22PRT ; - Print entry point from IBJDF62.
23 ;
24 ; - Extract summary data.
25 I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
26 ;
27 S IBDIV=""
28 F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D SUM(IBDIV) Q:IBQ
29 ;
30ENQ1 Q
31 ;
32EXTMO(IBS) ; Extract/transmit data to DM Extract Module
33 ; IBS - Array containing the summary information
34 ;
35 N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
36 ;
37 F IBI=1,2,3 F IBJ=1:1:16 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
38 ;
39 F IBCT=6,7,10 D
40 . S IBTP=0
41 . I IBCT=7 S IBTP=1 ; Workman's Comp.
42 . I IBCT=10 S IBTP=2 ; NO-Fault Auto Accident
43 . I IBCT=6 S IBTP=3 ; Tort-Feasor
44 . S IBSQ=1
45 . F IBI=1:1:7 D
46 . . S IBZ=$G(IBS(0,IBCT,IBI))
47 . . S IB(IBTP,IBSQ)=+IBZ
48 . . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
49 . . S IB(IBTP,15)=IB(IBTP,15)+IBZ
50 . . S IB(IBTP,16)=IB(IBTP,16)+$P(IBZ,"^",2)
51 . . S IBSQ=IBSQ+2
52 . S IB(IBTP,16)=$FN(IB(IBTP,16),"",2)
53 ;
54 F IBR=22:1:24 D E^IBJDE(IBR,0)
55 Q
56 ;
57SUM(IBDIV) ; - Print summary for division.
58 ; Input: IBDIV=Pointer to the division in file #40.8 and pre-set
59 ; variable IBRPT
60 N IBDH,IBTYP,I,J,Z,%
61 ;
62 S IBCAT=0
63 F S IBCAT=$O(IB(IBDIV,IBCAT)) Q:'IBCAT D Q:IBQ
64 . D HDR Q:IBQ
65 . S IBTYP=$G(IBCTG(IBCAT(IBCAT)))_" RECEIVABLES"
66 . W !!?(80-$L(IBTYP))\2,IBTYP
67 . W !?(80-$L(IBTYP)\2),$$DASH($L(IBTYP))
68 . I IBDIV D
69 . . S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U)
70 . . W !?(80-$L(IBDH)\2),IBDH
71 . ;
72 . W !!
73 . ;
74 . ; - Calculate totals first.
75 . F I=1:1:7 F J=1,2 S $P(IB(IBDIV,IBCAT,8),U,J)=$P(IB(IBDIV,IBCAT,8),U,J)+$P(IB(IBDIV,IBCAT,I),U,J)
76 . ;
77 . W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
78 . W "-----------",?31,"-------------",?52,"-------------------------"
79 . I 'IB(IBDIV,IBCAT,8) W !!,"There are no active receivables",$S(IBDIV:" for this division",1:""),".",!! D PAUSE Q
80 . ;
81 . ; - Primary loop to write results.
82 . S Y=$P(IB(IBDIV,IBCAT,8),U,2) F I=1:1:8 S X=$P($T(CATN+I),";;",2,99) D
83 . . W:I=8 ! W !,X,?30,$J(+IB(IBDIV,IBCAT,I),6)
84 . . W " (",$J(+IB(IBDIV,IBCAT,I)/+IB(IBDIV,IBCAT,8)*100,0,$S(I=8:0,1:2)),"%)"
85 . . S Z=$FN($P(IB(IBDIV,IBCAT,I),U,2),",",2)
86 . . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
87 . . W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBCAT,I),U,2)/Y*100),0,$S(I=8:0,1:2)),"%)"
88 . . W:I=8 !!
89 . ;
90 . D PAUSE
91 ;
92SUMQ Q
93 ;
94HDR ; - Write the summary report header.
95 N X,PD,PDA,PDF,PDL
96 ;
97 I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
98 S IBPAG=$G(IBPAG)+1
99 W "MISCELLANEOUS BILLS FOLLOW-UP SUMMARY REPORT"
100 W ?71,"Page: ",$J(IBPAG,3),!,"Run Date: ",IBRUN
101 S X=""
102 I IBRPT="D" D
103 . I IBSMN'="A" D
104 . . S X=" RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
105 . I IBCAT(IBCAT)>4 S PD="DEBTORS",PDA=IBSDA,PDF=IBSDF,PDL=IBSDL
106 . I IBCAT(IBCAT)<5 S PD="PATIENTS",PDA=IBSNA,PDF=IBSNF,PDL=IBSNL
107 . I $G(PDA)'="ALL" D
108 . . S X=X_"/ "_PD_" FROM '"_$S(PDF="":"FIRST",1:PDF)_"' TO '"
109 . . S X=X_$S(PDL="zzzzz":"LAST",1:PDL)_"' "
110 . I $G(IBSAM) S X=X_"/ MINIMUM BALANCE: $"_$FN(IBSAM,",",2)_" "
111 S $E(X,1,2)=""
112 I X'="" F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
113 ;
114 Q
115DASH(X) ; - Return a dashed line.
116 Q $TR($J("",X)," ","=")
117 ;
118PAUSE ; - Page break.
119 I $E(IOST,1,2)'="C-" Q
120 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
121 F IBX=$Y:1:(IOSL-3) W !
122 S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
123 Q
124 ;
125CAT(X) ; - Determine category to place receivable.
126 Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
127 ;
128CATN ; - List of category names.
129 ;;Less than 30 days old
130 ;;31-60 days
131 ;;61-90 days
132 ;;91-120 days
133 ;;121-180 days
134 ;;181-365 days
135 ;;Over 365 days
136 ;;Total Misc. Receivables
Note: See TracBrowser for help on using the repository browser.