source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRJRBD.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: 9.5 KB
Line 
1RCRJRBD ;WISC/RFJ,TJK-bad debt extractor and report ;1 Feb 98
2 ;;4.5;Accounts Receivable;**101,139,170,193,203,215,220,138,239**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; IA 4385 for calls to $$MRATYPE^IBCEMU2 and $$MRADTACT^IBCEMU2
5 Q
6 ;
7 ;
8START(DATEEND) ; run bad debt report
9 ; the DATEEND is the last day of the month being run
10 ; from the routine RCRJRCOL which is the data extractor. The
11 ; current receivable dollars is stored in ^TMP($J,"RCRJRBD",SGL)
12 ; where SGL is the standard general ledger 1319, 1338, or 1339.
13 ;
14 N ACTDATE,ACTUALCA,ACTUALWO,BEGDATE,BILLDA,CATEGORY
15 N COLLECT,CONTRACT,DR,ENDDATE,FUND,PAY,PAYMENT,PRIN,PRINCPAL
16 N RCRJFMM,RCRJDATE,SGL,TRANDA,TRANDATE,TRANTYPE,VALUE,WRITEOFF
17 N RCPRIN,RCTOMCCF,RCVALUE,RSC,MRATYPE,ARACTDT
18 ;
19 ; lock the bad debt file for storing data, lock cannot fail
20 ; this lock can be used to monitor if the report is running
21 L +^RC(348.1)
22 ;
23 ; calculate the base percentages from past data
24 ; example: DATEEND=2980331 => BEGDATE=2970300
25 ; => ENDDATE=2980229
26 ; add one day to ending date to go to next month
27 S BEGDATE=($E(DATEEND,1,3)-1)_$E(DATEEND,4,5)_"00"
28 S ENDDATE=($$FMADD^XLFDT($E(DATEEND,1,5)_"00",-1))+1
29 ; loop bills activated between these dates
30 S ACTDATE=BEGDATE
31 F S ACTDATE=$O(^PRCA(430,"ACTDT",ACTDATE)) Q:'ACTDATE!(ACTDATE>ENDDATE) D
32 . S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ACTDT",ACTDATE,BILLDA)) Q:'BILLDA D
33 . . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
34 . . ; do not look at prepayments
35 . . I 'CATEGORY!(CATEGORY=26) Q
36 . . ;
37 . . ; only look at bills with a 0 principal balance
38 . . I $P($G(^PRCA(430,BILLDA,7)),"^") Q
39 . . ;
40 . . ; only report fund 528701,03,04, and 4032/528709 bills
41 . . S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
42 . . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
43 . . ;
44 . . ; determine MRA type of bill, given bill# and bill active date
45 . . ; DBIA #4385 activated on 31-Mar-2004
46 . . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ACTDATE)
47 . . ;
48 . . ; derive standard general ledger (SGL) from cat/fund/MRA type
49 . . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
50 . . ;
51 . . ; determine the original amount of the bill (add increase
52 . . ; adjustments below)
53 . . S PRIN=$P($G(^PRCA(430,BILLDA,0)),"^",3)
54 . . S PAY=0
55 . . ;
56 . . ; get the $ transations for bills
57 . . S TRANDA=0
58 . . F S TRANDA=$O(^PRCA(433,"C",BILLDA,TRANDA)) Q:'TRANDA D
59 . . . S TRANTYPE=$P($G(^PRCA(433,TRANDA,1)),"^",2)
60 . . . I "^1^2^34^43^"'[("^"_TRANTYPE_"^") Q
61 . . . S VALUE=$$TRANBAL^RCRJRCOT(TRANDA) I VALUE="" Q
62 . . . ; increase adjustments or re-establish
63 . . . I TRANTYPE=1!(TRANTYPE=43) S PRIN=PRIN+$P(VALUE,"^") Q
64 . . . ; payments
65 . . . I TRANTYPE=2!(TRANTYPE=34) S PAY=PAY+$P(VALUE,"^") Q
66 . . ;
67 . . ; payment cannot be greater than principle
68 . . I PAY>PRIN S PAY=PRIN
69 . . ;
70 . . ; store the data
71 . . S PRINCPAL(SGL)=$G(PRINCPAL(SGL))+PRIN
72 . . S PAYMENT(SGL)=$G(PAYMENT(SGL))+PAY
73 . . ;
74 ;
75 ; calculate the writeoffs from 2/0/98
76 ; 2/0/98 is when fms cleared out actual writeoffs and contract adj
77 K ^XTMP("PRCABDET")
78 S ^XTMP("PRCABDET",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^BAD DEBT REPORT AUDIT"
79 F TRANTYPE=8,9,10,11,35 D
80 . S TRANDATE=2980200
81 . ; do not pick up transactions after the end date
82 . F S TRANDATE=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE)) Q:'TRANDATE!($P(TRANDATE,".")>DATEEND) D
83 . . S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE,TRANDA)) Q:'TRANDA D
84 . . . ; do not look at decrease adj which are not contract adj
85 . . . I TRANTYPE=35,'$P($G(^PRCA(433,TRANDA,8)),"^",8) Q
86 . . . ;
87 . . . S BILLDA=$P($G(^PRCA(433,TRANDA,0)),"^",2)
88 . . . I 'BILLDA Q
89 . . . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
90 . . . ; do not look at prepayments
91 . . . I 'CATEGORY!(CATEGORY=26) Q
92 . . . ;
93 . . . ; only report fund 528701,03,04 and 4032/528709 (ltc) bills
94 . . . S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
95 . . . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
96 . . . ;
97 . . . ; get bill active date
98 . . . S ARACTDT=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
99 . . . ; determine MRA type of bill, given bill# and bill active date
100 . . . ; DBIA #4385 activated on 31-Mar-2004
101 . . . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT)
102 . . . ;
103 . . . ; derive standard general ledger (SGL) from cat/fund/MRA type
104 . . . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
105 . . . ;
106 . . . ; get the principal transaction value
107 . . . S RCVALUE=+$P($$TRANBAL^RCRJRCOT(TRANDA),"^")
108 . . . ; temp variable for value (used below)
109 . . . S RCPRIN=RCVALUE
110 . . . ;
111 . . . ; add actual writeoff amount for fiscal year
112 . . . I TRANTYPE'=35 S ACTUALWO(SGL)=$G(ACTUALWO(SGL))+RCVALUE
113 . . . ; add actual contract adjustments for fiscal year
114 . . . I TRANTYPE=35 S ACTUALCA(SGL)=$G(ACTUALCA(SGL))+RCVALUE
115 . . . S RSC=$$CALCRSC^RCXFMSUR(BILLDA)
116 . . . S ^XTMP("PRCABDET",BILLDA,CATEGORY,FUND,RSC,SGL,TRANDA,TRANDATE,TRANTYPE,RCPRIN,RCVALUE,0,0)=""
117 ;
118 ; remove all the entries from the bad debt file
119 D DELETALL
120 ;
121 ; calculate percentages and store them
122 F SGL=1319,1319.2,1319.3,1319.4,1338,1339,"133N" D
123 . ; collection %
124 . S COLLECT=0 I $G(PRINCPAL(SGL)) S COLLECT=$J($G(PAYMENT(SGL))/PRINCPAL(SGL)*100,0,2)
125 . ; patch PRCA*4.5*138: for the first year from when MRA is activated at a site, there is no collection
126 . ; history for post-MRA non-Medicare bills(SGL 133N). So, to calculate the percentage for SGL 133N, the
127 . ; payment and the principal for SGL 1339 are used in the first year.
128 . ; override the collection value for SGL=133N for the first year from MRA activation.
129 . ;; Re-evaluate the calc. of the percentage for 133N as well as 1339.
130 . ;;I SGL="133N",$G(PRINCIPAL(1339)) D ;
131 . ;;. N X1,X2,X,%Y
132 . ;;. ; X2=MRA Activation Date, X1=Today, X=diff in days, %Y=0 invalid dates
133 . ;;. ; DBIA #4385 activated on 31-Mar-2004
134 . ;;. S X2=$$MRADTACT^IBCEMU2,X1=$$DT^XLFDT D ^%DTC
135 . ;;. I %Y,X'>364.25 S COLLECT=$J($G(PAYMENT(1339))/PRINCPAL(1339)*100,0,2)
136 . S DR=".02////"_+COLLECT_";"
137 . ;
138 . ; current month receivable (this is built in the routine
139 . ; RCRJRCO1 and is stored in ^TMP($J,"RCRJRBD",SGL))
140 . S DR=DR_".07////"_+$G(^TMP($J,"RCRJRBD",SGL))_";"
141 . ;
142 . ; calculate allowance estimate for 1319 and 1338
143 . ; .08 allowance estimate = (writeoff % * current receivables)
144 . ; .09 actual writeoffs fytd
145 . I SGL=1319!(SGL=1319.2)!(SGL=1319.3)!(SGL=1319.4)!(SGL=1338) D
146 . . S WRITEOFF=100-COLLECT
147 . . S DR=DR_".03////"_WRITEOFF_";"
148 . . S DR=DR_".08////"_$J((WRITEOFF/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
149 . . S DR=DR_".09////"_+$G(ACTUALWO(SGL))_";"
150 . ; calculate allowance estimate for 1339
151 . ; .08 allowance estimate = (contract % * current receivables)
152 . ; .09 actual contract adjustments fytd
153 . I SGL=1339!(SGL="133N") D
154 . . S CONTRACT=100-COLLECT
155 . . S DR=DR_".04////"_CONTRACT_";"
156 . . S DR=DR_".08////"_$J((CONTRACT/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
157 . . S DR=DR_".09////"_+$G(ACTUALCA(SGL))_";"
158 . ;
159 . ; set changed locally flag to no
160 . S DR=DR_".1////0;"
161 . D STORE(SGL,DR)
162 ;
163 L -^RC(348.1)
164 ;
165 ; ; put the report in a mail message (rcrjfmm=1)
166 ; S RCRJFMM=1
167 ; S RCRJDATE=DATEEND
168 ; D DQ^RCRJRBDR
169 ;
170 ; transmit the allowances to FMS, and then generate the report.
171 D BADDEBT^RCXFMSSV(DATEEND)
172 Q
173 ;
174 ;
175STORE(SGL,DR) ; store data for Standard Ledger Account
176 N D0,DA,DD,DI,DIC,DIE,DINUM,DO,DQ,X,Y
177 S DIC="^RC(348.1,",DIC(0)="L",X=SGL,DIC("DR")=DR
178 D FILE^DICN
179 Q
180 ;
181 ;
182DELETALL ; delete all the entries from the bad debt file
183 N %,DA,DIC,DIK,X,Y
184 S DIK="^RC(348.1,"
185 S DA=0 F S DA=$O(^RC(348.1,DA)) Q:'DA D ^DIK
186 Q
187 ;
188 ;
189WD3() ; return the third work day of the month
190 N J,P,V,X
191 S J=0 F P=$E(DT,1,5)_"01":1 S V=$$DOW^XLFDT(P,1) I V,V<6,'$D(^HOLIDAY("B",P)) S J=J+1 Q:J=3
192 S X=+$E(P,6,7)
193 Q X
194 ;
195 ;
196PREVMONT(FORDATE) ; return the previous month's date
197 N PREVDATE
198 S PREVDATE=$E(FORDATE,1,5)-1
199 I $E(PREVDATE,4,5)="00" S PREVDATE=($E(PREVDATE,1,3)-1)_12
200 Q PREVDATE_"00"
201 ;
202 ; derive standard general ledger (SGL) from category and fund
203SGL(CATEGORY,FUND) ;
204 I $G(FUND)=528709 Q 1319.2 ;new long term care fund
205 I $E($G(FUND),1,4)=4032 Q 1319.2 ; breakout long term care as a subset
206 I CATEGORY=8 Q 1339 ; crime or per. vio.
207 I CATEGORY=9 Q 1339 ; reimbursable health insurance
208 I CATEGORY=10 Q 1338 ; tort feasor
209 I CATEGORY=21 Q 1339 ; medicare
210 Q 1319
211 ;
212 ;
213BDRSGL(CAT,FUND,MRATYPE) ; Calculate SGLs for the BDR process
214 ;
215 ; This API will be used by both the ARDC (routine RCRJRCOC)
216 ; and the BDR estimate calculator to associate receivables
217 ; with the correct standard general ledger account (SGL).
218 ; The following table will be implemented:
219 ;
220 ; Receivable Type (Category) Fund SGL
221 ;==================================================
222 ; Medical Care Co-payments 528703 1319
223 ; (plus Inelig, Emerg./Hum. rec.)
224 ; Long Term Care Co-payments 528709 1319.2
225 ; Medication Co-payments 528701 1319.3
226 ; Crimes of Personal Violence (8), 528704 1319.4
227 ; Medicare (21), No-Fault Auto
228 ; (7), Workman's Comp (6)
229 ; Tort Feasor (10) 528704 1338
230 ; RHI (9), pre-MRA 528704 1339
231 ; RHI (9), post-MRA, MRA rec. 528704 133H
232 ; RHI (9), post-MRA, non-MRA rec. 528704 133N
233 ;
234 ; Input: CAT -- Pointer to the receivable category in file 430.2
235 ; FUND -- Receivable fund calcualted by routine RCXFMSUF
236 ; MRATYPE -- Indicator of an MRA (2) or non-MRA (3) receivable
237 ;
238 ;
239 I $G(FUND)=528709 Q 1319.2
240 I $E($G(FUND),1,4)=4032 Q 1319.2
241 I $G(FUND)=528701 Q 1319.3
242 I CAT=8!(CAT=21)!(CAT=7)!(CAT=6) Q 1319.4
243 I CAT=10 Q 1338
244 I CAT=9 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339)
245 Q 1319
Note: See TracBrowser for help on using the repository browser.