source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCKATP.m@ 1500

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

initial load of WorldVistAEHR
File size: 7.3 KB
Line 
1RCKATP ;ALB/CPM - ADJUST ACCOUNTS FOR KATRINA VETS ; 28-FEB-06
2 ;;4.5;Accounts Receivable;**241,246**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7POST ; Queue PRCA*4.5*241 post-init job.
8 ;
9 D BMES^XPDUTL(">>> Queuing the post-initialization to run now...")
10 S ZTDTH=$H,ZTRTN="EN^RCKATP",ZTIO=""
11 S ZTDESC="RC - PATCH PRCA*4.5*241 POST INITIALIZATION"
12 D ^%ZTLOAD
13 I $D(ZTSK) D MES^XPDUTL(" >> Queued as task #"_ZTSK_".")
14 I '$D(ZTSK) D MES^XPDUTL(" >> Unable to queue task - contact EVS.")
15 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO
16 Q
17 ;
18 ;
19EN ; Queued entry point to run the PRCA*4.5*241 post init.
20 ;
21 D EX ; exempt interest - return RCTOTAL
22 ;
23 S RCRES=$$CAN^IBAKAT() ; cancel copay charges
24 ;
25 D BULL ; generate bulletin with results
26 ;
27 I $D(ZTQUEUED) S ZTREQ="@"
28 K RCTOTAL,RCRES
29 Q
30 ;
31 ;
32EX ; Entry point to exempt interest/admin charges
33 ;
34 ; - get all 'Katrina' vets based on interest/admin charges
35 K ^TMP("RCKATP",$J)
36 S RCCOM(1)="INTEREST ADJUSTMENT FOR HURRICANE KATRINA VETERAN"
37 S RCD=3050828.9
38 F S RCD=$O(^PRCA(433,"AT",13,RCD)) Q:'RCD!($P(RCD,".")>3060430) D
39 .S RCT=0 F S RCT=$O(^PRCA(433,"AT",13,RCD,RCT)) Q:'RCT D
40 ..S RCB=+$P($G(^PRCA(433,RCT,0)),"^",2) Q:'RCB
41 ..I '$P($G(^PRCA(430,RCB,0)),"^",12) Q
42 ..S RCDPT=+$P($G(^PRCA(430,RCB,0)),"^",9)
43 ..S RCDEB=$G(^RCD(340,RCDPT,0))
44 ..Q:$P(RCDEB,"^")'["DPT" Q:'RCDEB
45 ..;Q:$$EMERES^PRCAUTL(+RCDEB)=""
46 ..Q:$$EMGRES^DGUTL(+RCDEB)=""
47 ..Q:$P(RCDEB,"^",8) ; vet has been already been processed
48 ..;
49 ..; - store the vet and bill
50 ..S ^TMP("RCKATP",$J,RCDPT,RCB)=""
51 ;
52 ; - look for extra interest exemptions to create
53 S RCTOTAL="0^0"
54 S RCDEB=0 F S RCDEB=$O(^TMP("RCKATP",$J,RCDEB)) Q:'RCDEB D
55 .;
56 .; - initialize bucket and new patient flag
57 .S (RCBUCK,RCNEWP)=0
58 .S RCB=0 F S RCB=$O(^TMP("RCKATP",$J,RCDEB,RCB)) Q:'RCB D
59 ..;
60 ..; - review transactions to find interest added/exempted
61 ..S RCCB=$$GETTRANS^RCDPBTLM(RCB),RCH=0,RCHOLD=""
62 ..S RCDT=3050828.9 F S RCDT=$O(RCLIST(RCDT)) Q:'RCDT D
63 ...S RCT=0 F S RCT=$O(RCLIST(RCDT,RCT)) Q:'RCT D
64 ....S RCV=RCLIST(RCDT,RCT)
65 ....;
66 ....; - if transaction is an interest charge, save off amount
67 ....I RCV["INTEREST/ADM. CHARGE",RCDT<3060501 S RCH=1 D Q
68 .....S $P(RCHOLD,"^")=$P(RCHOLD,"^")+$P(RCV,"^",3)
69 .....S $P(RCHOLD,"^",2)=$P(RCHOLD,"^",2)+$P(RCV,"^",4)
70 ....;
71 ....; - if transaction is an interest exemption, save off (+) amount
72 ....I RCV["EXEMPT INT/ADM. COST",RCH D Q
73 .....S $P(RCHOLD,"^",3)=$P(RCHOLD,"^",3)-$P(RCV,"^",3)
74 .....S $P(RCHOLD,"^",4)=$P(RCHOLD,"^",4)-$P(RCV,"^",4)
75 ..;
76 ..; - get total amounts of interest added and exempted
77 ..S RCINT=$P(RCHOLD,"^")+$P(RCHOLD,"^",2)
78 ..S RCEXEM=$P(RCHOLD,"^",3)+$P(RCHOLD,"^",4)
79 ..;
80 ..; - quit if interest added less than or equal to exemptions
81 ..S RCAPPLY=RCINT-RCEXEM
82 ..Q:RCAPPLY'>0
83 ..;
84 ..; - get bill's interest balance
85 ..S RCNEWP=1
86 ..S X=$G(^PRCA(430,RCB,7)),RCINTB=$P(X,"^",2)+$P(X,"^",3)
87 ..;
88 ..; - if no balance, put in bucket and quit
89 ..I 'RCINTB S RCBUCK=RCBUCK+RCAPPLY Q
90 ..;
91 ..; - adjust bucket and amount to apply
92 ..S RCAMT=$S(RCAPPLY'<RCINTB:RCINTB,1:RCAPPLY)
93 ..S RCBUCK=$S(RCAPPLY>RCINTB:RCBUCK+(RCAPPLY-RCINTB),1:RCBUCK)
94 ..;
95 ..; - will apply RCAMT - spread over admin then interest.
96 ..S RCAPA=$S(RCAMT'<$P(X,"^",3):$P(X,"^",3),1:RCAMT)
97 ..S RCAPI=RCAMT-RCAPA
98 ..S RC=$$EXEMPT^RCBEUTR2(RCB,RCAPI_"^"_RCAPA,.RCCOM,0)
99 ..;
100 ..; - update total amount exempted
101 ..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCAMT
102 .;
103 .;
104 .; - set debtor as having been processed
105 .S $P(^RCD(340,RCDEB,0),"^",8)=1
106 .;
107 .; - if an amount is left in the bucket, process it,
108 .; update total exempted, and the number of vets exempted
109 .I RCBUCK D
110 ..D EN^RCKATPD($P($G(^RCD(340,RCDEB,0)),"^"),RCBUCK,RCCOM(1))
111 ..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCBUCK
112 .I RCNEWP S $P(RCTOTAL,"^")=$P(RCTOTAL,"^")+1
113 ;
114 ;
115 K ^TMP("RCKATP",$J)
116 K RCD,RCT,RCB,RCDPT,RCDEB,RCBUCK,RCNEWP,RC,RCCB,RCH,RCHOLD,RCDT
117 K RCLIST,RCV,RCINT,RCINTB,RCEXEM,RCAPPLY,RCAMT,RCAPA,RCAPI,RCCOM,X
118 Q
119 ;
120 ;
121CHK(DFN) ; Check to see if vet should have charges cancelled
122 ; Input: DFN -- Pointer to patient in file 2
123 ; Output: 0 -- No, don't cancel charges
124 ; 1 -- Yes, cancel charges
125 N RCDEB,RCH
126 S RCH=0
127 ;I $$EMERES^PRCAUTL(DFN)="" G CHKQ
128 I $$EMGRES^DGUTL(DFN)="" G CHKQ
129 S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))
130 ;
131 ; - if a Katrina vet is not in file #340, must look for held charges
132 I 'RCDEB S RCH=1 G CHKQ
133 ;
134 ; - make sure charges have not yet been canceled
135 I '$P($G(^RCD(340,RCDEB,0)),"^",9) S RCH=1
136CHKQ Q RCH
137 ;
138 ;
139TPP(RCTI,RCH) ; Identify decreases that are credits for third party payments
140 ; Input: RCTI -- Pointer to AR Transaction in file 433
141 ; RCH -- Array of 'counted' transactions passed by reference
142 ; Output: RCRES -- 1^2, where
143 ; 1 = total amount of credit adjustments
144 ; 2 = pointer to the affected bill in file #430
145 ;
146 N RCRES,RCB,RCAMT,RCT,RCTD,RCQ,RCI,RCS
147 S RCRES="",RCAMT=0
148 I '$G(RCTI) G TPPQ
149 S RCB=+$P($G(^PRCA(433,RCTI,0)),"^",2) I 'RCB G TPPQ
150 S RCAMT=0
151 S RCT=RCTI F S RCT=$O(^PRCA(433,"C",RCB,RCT)) Q:'RCT D
152 .Q:$D(RCH(RCB,RCT)) ; transaction has been counted
153 .S RCTD=$G(^PRCA(433,RCT,1))
154 .Q:$P(RCTD,"^",2)'=35 ; not a decrease
155 .;
156 .; - check for a potential 'Katrina decrease'
157 .S RCQ=0,RCS="HURRICANE KATRINA VETERAN" D Q:RCQ
158 ..S RCI=0 F S RCI=$O(^PRCA(433,RCT,7,RCI)) Q:'RCI D Q:RCQ
159 ...I $G(^PRCA(433,RCT,7,RCI,0))[RCS S RCQ=1
160 .;
161 .; - increment the credit amount
162 .S RCAMT=RCAMT+$P(RCTD,"^",5),RCH(RCB,RCT)=""
163 ;
164 S RCRES=RCAMT_"^"_RCB
165TPPQ Q RCRES
166 ;
167 ;
168DEC(RCBILL,RCAMT) ; Decrease a bill
169 ; Input: RCBILL -- Bill Number of a bill in file 430
170 ; RCAMT -- Amount to decrease bill
171 ; Output: RCBUCK -- Amount not decreased, to go to bucket
172 ;
173 N RCBUCK,RCMSG,RCT
174 S RCBUCK=RCAMT
175 S RCB=$O(^PRCA(430,"B",RCBILL,0))
176 I RCB D
177 .S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
178 .D DEC^PRCASER1(RCB,.RCBUCK,DUZ,RCMSG,"",.RCT)
179DECQ Q RCBUCK
180 ;
181 ;
182FLAG(DFN) ; Flag veteran as having had copay charges cancelled
183 ; Input: DFN -- Pointer to patient in file 2
184 ;
185 N RCDEB
186 S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))
187 I 'RCDEB D
188 .S DIC="^RCD(340,",DIC(0)="QL",X=DFN_";DPT(",DLAYGO=340
189 .K DD,DO D FILE^DICN K DIC,DLAYGO,DO,DD S RCDEB=+Y
190 I RCDEB>0 S $P(^RCD(340,RCDEB,0),"^",9)=1
191 Q
192 ;
193 ;
194ADJ(DFN,RCAMT) ; Make final credit adjustments to the vet's account
195 ; Input: DFN -- Pointer to patient in file 2
196 ; RCAMT -- Amount to decrease from account
197 ;
198 N RCDEBN,RCMSG
199 S RCDEBN=DFN_";DPT("
200 S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
201 D EN^RCKATPD(RCDEBN,RCAMT,RCMSG)
202 Q
203 ;
204 ;
205BULL ; Send job completion bulletin
206 N XMSUB,XMTEXT,XMY,XMDUZ,RCT,RCN
207 S RCT(1)="The patch PRCA*4.5*241 post initialization has completed."
208 S RCT(2)=" "
209 S RCT(3)="Number of Veterans with Interest Exempted: "_+RCTOTAL
210 S RCT(4)=" Total Amount of Interest Exempted: $"_$J($P(RCTOTAL,"^",2),0,2)
211 S RCT(5)=" "
212 I RCRES="" S RCT(6)="*** Note: Copay Charges were not cancelled - contact EVS ***"
213 I RCRES'="" D
214 .S RCT(6)="Number of Veterans with Charges Cancelled: "_+RCRES
215 .S RCT(7)=" Total Amount of Charges Cancelled: $"_$J($P(RCRES,"^",2),0,2)
216 .S RCT(8)=" Total Amount of Held Charges Cancelled: $"_$J($P(RCRES,"^",3),0,2)
217 ;
218 S XMSUB="Job Completion - PRCA*4.5*241 Post Initialization"
219 S XMTEXT="RCT("
220 S XMY("G.PRCA ADJUSTMENT TRANS")="",XMY(DUZ)=""
221 S XMDUZ="ACCOUNTS RECEIVABLE"
222 D ^XMD
223 Q
Note: See TracBrowser for help on using the repository browser.