source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRJRBDR.m@ 1661

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1RCRJRBDR ;WISC/RFJ,TJK-bad debt report generator ;1 Feb 98
2 ;;4.5;Accounts Receivable;**101,139,170,191,203,215,220,138,239**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7PRINT ; print report on printer, called from menu option
8 N RCRJDATE
9 W !!,"This option will print the Bad Debt Report. The Bad Debt allowance"
10 W !,"estimates are computed by the AR Data Collector at the end of the"
11 W !,"accounting month, and sent to FMS at that time. The allowance"
12 W !,"estimate is no longer editable prior to transmission to FMS.",!
13 N %ZIS,POP,ZTRTN,ZTDESC S %ZIS="QM" D ^%ZIS Q:POP
14 I $D(IO("Q")) D Q
15 . S ZTRTN="DQ^RCRJRBDR",ZTDESC="Bad Debt Report"
16 . D ^%ZTLOAD
17 ;
18 W !,"please wait"
19 D DQ
20 Q
21 ;
22 ;
23DQ ; generate the report
24 ; rcrjfmm = flag to put in mail message (if $g(rcrjfmm)) (optional)
25 ; rcrjdate = date month and year for report (optional)
26 ; rcrjfxsv = fms document id number if sent to fms (optional)
27 ; (newed and set by rcxfmssv, label Q)
28 ;
29 N %,%I,CHANGED,DATA,DATA1319,DATA1338,DATA1339,DATALTC,DATEREPT,ENDDATE,X
30 N LINE,RCRJFLAG,SCREEN,SPACE,Y,DATA133N
31 ;
32 K ^TMP($J,"RCRJRCORMM")
33 S SPACE="",$P(SPACE," ",81)=""
34 ; the date of the report is for previous month if the DT is before the EOAM date of the current month, it is for the current month if the date is after the EOAM cut-off date.
35 I $G(RCRJDATE) S RCRJDATE=$E($$LDATE^RCRJR(RCRJDATE),1,5)_"00"
36 I '$G(RCRJDATE) D
37 .I $E(DT,6,7)'>$E($$LDATE^RCRJR(DT),6,7) S RCRJDATE=$$PREVMONT^RCRJRBD(DT)
38 .I $E(DT,6,7)>$E($$LDATE^RCRJR(DT),6,7) S RCRJDATE=$E($$LDATE^RCRJR(DT),1,5)_"00"
39 S Y=$E(RCRJDATE,1,5)_"00" D DD^%DT S DATEREPT=Y
40 S LINE=0
41 ;
42 ; jump to RCRJRBDT to generate the new Bad Debt Report,
43 ; in order to save the code for the older report.
44 D BDR^RCRJRBDT G MAIL
45 ;
46 D SETLINE(" ")
47 D SETLINE($E(SPACE,1,32)_"Bad Debt Report")
48 D SETLINE($E(SPACE,1,13)_"Allowance for Bad Debt and Contract Adjustment Report")
49 D SETLINE($E(SPACE,1,27)_"for the month of "_DATEREPT)
50 I $D(RCRJFXSV) D
51 . D SETLINE(" ")
52 . I $E(RCRJFXSV,1,2)="SV" D SETLINE($E(SPACE,1,13)_"***** Report sent to FMS, doc id: "_RCRJFXSV_" *****") Q
53 . ; report errored out or did not get generated to fms
54 . D SETLINE($E(SPACE,1,10)_"***** NOTICE: Report was NOT sent to FMS, the message is *****")
55 . D SETLINE($E(SPACE,1,10)_"***** "_RCRJFXSV_" *****")
56 ;
57 ; show mccf
58 D SETLINE(" ")
59 D SETLINE($E(SPACE,1,26)_"Medical Care Collection Fund")
60 I $E($G(RCRJDATE),2,5)'<"0410" D SETLINE($E(SPACE,1,26)_" Funds 528701, 528703, & 528704")
61 I $E($G(RCRJDATE),2,5)<"0410" D SETLINE($E(SPACE,1,26)_" Funds 5287.1, 5287.3, & 5287.4")
62 D SETLINE($E(SPACE,1,26)_"----------------------------")
63 D SETLINE(" ")
64 D SETLINE("Calculated "_$J(" ",14)_$J(" Third Party",14)_$J(" Third Party",14))
65 D SETLINE("Percentages "_$J(" First Party",14)_$J(" Cont Adj",14)_$J(" Cont Adj",14)_$J("Tort Feasors",14))
66 D SETLINE("For "_$J(" SGL 1319",14)_$J(" SGL 1339",14)_$J(" SGL 133N",14)_$J(" SGL 1338",14))
67 D SETLINE("---------------------"_$J("------------",14)_$J("------------",14)_$J("------------",14)_$J("------------",14))
68 S DATA1319=$G(^RC(348.1,+$O(^RC(348.1,"B",1319,0)),0))
69 S DATA1338=$G(^RC(348.1,+$O(^RC(348.1,"B",1338,0)),0))
70 S DATA1339=$G(^RC(348.1,+$O(^RC(348.1,"B",1339,0)),0))
71 S DATA133N=$G(^RC(348.1,+$O(^RC(348.1,"B","133N",0)),0))
72 D SETLINE("Collection %"_$J($P(DATA1319,"^",2),14,2)_$J($P(DATA1339,"^",2),14,2)_$J($P(DATA133N,"^",2),14,2)_$J($P(DATA1338,"^",2),14,2))
73 D SETLINE("Write-Off %"_$J($P(DATA1319,"^",3),14,2)_$J($P(DATA1339,"^",3),14,2)_$J($P(DATA133N,"^",3),14,2)_$J($P(DATA1338,"^",3),14,2))
74 D SETLINE("Contract Adjustment %"_$J($P(DATA1319,"^",4),14,2)_$J($P(DATA1339,"^",4),14,2)_$J($P(DATA133N,"^",4),14,2)_$J($P(DATA1338,"^",4),14,2))
75 D SETLINE("---------------------"_$J("------------",14)_$J("------------",14)_$J("------------",14)_$J("------------",14))
76 D SETLINE("TOTAL %"_$J(100,14,2)_$J(100,14,2)_$J(100,14,2)_$J(100,14,2))
77 D SETLINE(" ")
78 ;
79 S DATALTC=$G(^RC(348.1,+$O(^RC(348.1,"B",1319.2,0)),0))
80 I $E($G(RCRJDATE),2,5)'<"0410" D SETLINE($E(SPACE,1,26)_" Extended (LTC) Care Fund 528709")
81 I $E($G(RCRJDATE),2,5)<"0410" D SETLINE($E(SPACE,1,26)_" Extended (LTC) Care Fund 4032")
82 D SETLINE($E(SPACE,1,26)_"---------------------------------")
83 D SETLINE(" ")
84 I $E($G(RCRJDATE),2,5)'<"0410" D SETLINE("Calculated "_$J(" Fund 528709",18))
85 I $E($G(RCRJDATE),2,5)<"0410" D SETLINE("Calculated "_$J(" Fund 4032",18))
86 D SETLINE("Percentages "_$J(" First Party",18))
87 D SETLINE("For "_$J(" SGL 1319",18))
88 D SETLINE("---------------------"_$J("------------",18))
89 D SETLINE("Collection %"_$J($P(DATALTC,"^",2),18,2))
90 D SETLINE("Write-Off %"_$J($P(DATALTC,"^",3),18,2))
91 D SETLINE("Contract Adjustment %"_$J($P(DATALTC,"^",4),18,2))
92 D SETLINE("---------------------"_$J("------------",18))
93 D SETLINE("TOTAL %"_$J(100,18,2))
94 D SETLINE(" ")
95 ;
96 ; show totals
97 ; 1319 mccf allowance
98 D SETLINE("Allowance for Bad Debt - First Party (SGL 1319 MCCF):")
99 D SETLINE("----------------------------------------------------")
100 S CHANGED=" " I $P(DATA1319,"^",10) S CHANGED="**"
101 D SETLINE($E("Allowance Estimate for "_DATEREPT_SPACE,1,35)_":"_$J($P(DATA1319,"^",8),16,2)_" "_CHANGED_" (Normally Credit Value)")
102 D SETLINE($E("Bad Debt Write-Off (Plus) "_SPACE,1,35)_":"_$J($P(DATA1319,"^",9),16,2)_" (Normally Debit Value )")
103 D SETLINE("----------------------------------------------------")
104 D SETLINE($E("Transmitted Amount to FMS for Month"_SPACE,1,35)_":"_$J($P(DATA1319,"^",8)+$P(DATA1319,"^",9),16,2)_" "_CHANGED_" (Normally Credit Value)")
105 I $P(DATA1319,"^",10) D SETLINE($E(SPACE,1,53)_"** Changed Locally")
106 D SETLINE(" ")
107 ;
108 ; 1319 ltc allowance
109 D SETLINE("Allowance for Bad Debt - First Party (SGL 1319 LTC 528709):")
110 D SETLINE("----------------------------------------------------")
111 S CHANGED=" " I $P(DATALTC,"^",10) S CHANGED="**"
112 D SETLINE($E("Allowance Estimate for "_DATEREPT_SPACE,1,35)_":"_$J($P(DATALTC,"^",8),16,2)_" "_CHANGED_" (Normally Credit Value)")
113 D SETLINE($E("Bad Debt Write-Off (Plus) "_SPACE,1,35)_":"_$J($P(DATALTC,"^",9),16,2)_" (Normally Debit Value )")
114 D SETLINE("----------------------------------------------------")
115 D SETLINE($E("Transmitted Amount to FMS for Month"_SPACE,1,35)_":"_$J($P(DATALTC,"^",8)+$P(DATALTC,"^",9),16,2)_" "_CHANGED_" (Normally Credit Value)")
116 I $P(DATALTC,"^",10) D SETLINE($E(SPACE,1,53)_"** Changed Locally")
117 D SETLINE(" ")
118 ;
119 ; 1339 allowance
120 D SETLINE("Allowance for Contract Adj - Third Party (SGL 1339):")
121 D SETLINE("----------------------------------------------------")
122 S CHANGED=" " I $P(DATA1339,"^",10) S CHANGED="**"
123 D SETLINE($E("Allowance Estimate for "_DATEREPT_SPACE,1,35)_":"_$J($P(DATA1339,"^",8),16,2)_" "_CHANGED_" (Normally Credit Value)")
124 D SETLINE($E("Bad Debt Contract Adj (Plus) "_SPACE,1,35)_":"_$J($P(DATA1339,"^",9),16,2)_" (Normally Debit Value )")
125 D SETLINE("----------------------------------------------------")
126 D SETLINE($E("Transmitted Amount to FMS for Month"_SPACE,1,35)_":"_$J($P(DATA1339,"^",8)+$P(DATA1339,"^",9),16,2)_" "_CHANGED_" (Normally Credit Value)")
127 I $P(DATA1339,"^",10) D SETLINE($E(SPACE,1,53)_"** Changed Locally")
128 D SETLINE(" ")
129 ;
130 ; 133N allowance - Post-MRA non-Medicare
131 D SETLINE("Allowance for Contract Adj - Third Party (SGL 133N):")
132 D SETLINE("----------------------------------------------------")
133 S CHANGED=" " I $P(DATA133N,"^",10) S CHANGED="**"
134 D SETLINE($E("Allowance Estimate for "_DATEREPT_SPACE,1,35)_":"_$J($P(DATA133N,"^",8),16,2)_" "_CHANGED_" (Normally Credit Value)")
135 D SETLINE($E("Bad Debt Contract Adj (Plus) "_SPACE,1,35)_":"_$J($P(DATA133N,"^",9),16,2)_" (Normally Debit Value )")
136 D SETLINE("----------------------------------------------------")
137 D SETLINE($E("Transmitted Amount to FMS for Month"_SPACE,1,35)_":"_$J($P(DATA133N,"^",8)+$P(DATA133N,"^",9),16,2)_" "_CHANGED_" (Normally Credit Value)")
138 I $P(DATA133N,"^",10) D SETLINE($E(SPACE,1,53)_"** Changed Locally")
139 D SETLINE(" ")
140 ;
141 ; 1338 allowance
142 D SETLINE("Allowance for Bad Debt - Tort Feasors (SGL 1338):")
143 D SETLINE("----------------------------------------------------")
144 S CHANGED=" " I $P(DATA1338,"^",10) S CHANGED="**"
145 D SETLINE($E("Allowance Estimate for "_DATEREPT_SPACE,1,35)_":"_$J($P(DATA1338,"^",8),16,2)_" "_CHANGED_" (Normally Credit Value)")
146 D SETLINE($E("Bad Debt Write-Off (Plus) "_SPACE,1,35)_":"_$J($P(DATA1338,"^",9),16,2)_" (Normally Debit Value )")
147 D SETLINE("----------------------------------------------------")
148 D SETLINE($E("Transmitted Amount to FMS for Month"_SPACE,1,35)_":"_$J($P(DATA1338,"^",8)+$P(DATA1338,"^",9),16,2)_" "_CHANGED_" (Normally Credit Value)")
149 I $P(DATA1338,"^",10) D SETLINE($E(SPACE,1,53)_"** Changed Locally")
150 D SETLINE(" ")
151 D SETLINE("Report Footnotes:")
152 D SETLINE("-----------------")
153 ;
154 D ENDOFREP^RCRJRBDT
155 ;
156MAIL ; put report in mailman
157 I $G(RCRJFMM) D D Q Q
158 . N XMY
159 . S XMY("G.RC AR DATA COLLECTOR")=""
160 . S %=$$SENDMSG^RCRJRCOR("BAD DEBT REPORT",.XMY)
161 ;
162 ; print report
163 S SCREEN=0 I '$D(ZTQUEUED),IO=IO(0),$E(IOST)="C" S SCREEN=1
164 U IO I SCREEN W @IOF
165 S LINE=1 F S LINE=$O(^TMP($J,"RCRJRCORMM",LINE)) Q:'LINE!($G(RCRJFLAG)) D
166 . I $Y>(IOSL-5) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) W @IOF F %=2:1:5 W !,^TMP($J,"RCRJRCORMM",%)
167 . W !,^TMP($J,"RCRJRCORMM",LINE)
168 I '$G(RCRJFLAG),SCREEN R !!,"<end of report, press return to continue>",X:DTIME
169 D ^%ZISC
170 ;
171Q K ^TMP($J,"RCRJRCORMM")
172 Q
173 ;
174 ;
175SETLINE(DATA) ; build the line for the report
176 S LINE=LINE+1,^TMP($J,"RCRJRCORMM",LINE)=DATA
177 Q
Note: See TracBrowser for help on using the repository browser.