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

RCKATP ;ALB/CPM - ADJUST ACCOUNTS FOR KATRINA VETS ; 28-FEB-06

 ;;4.5;Accounts Receivable;**241,246**;Mar 20, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 Q

 ;

 ;

POST ; Queue PRCA*4.5*241 post-init job.

 ;

 D BMES^XPDUTL(">>> Queuing the post-initialization to run now...")

 S ZTDTH=$H,ZTRTN="EN^RCKATP",ZTIO=""

 S ZTDESC="RC - PATCH PRCA*4.5*241 POST INITIALIZATION"

 D ^%ZTLOAD

 I $D(ZTSK) D MES^XPDUTL(" >> Queued as task #"_ZTSK_".")

 I '$D(ZTSK) D MES^XPDUTL(" >> Unable to queue task - contact EVS.")

 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO

 Q

 ;

 ;

EN ; Queued entry point to run the PRCA*4.5*241 post init.

 ;

 D EX ;                    exempt interest - return RCTOTAL

 ;

 S RCRES=$$CAN^IBAKAT() ;  cancel copay charges

 ;

 D BULL ;                  generate bulletin with results

 ;

 I $D(ZTQUEUED) S ZTREQ="@"

 K RCTOTAL,RCRES

 Q

 ;

 ;

EX ; Entry point to exempt interest/admin charges

 ;

 ; - get all 'Katrina' vets based on interest/admin charges 

 K ^TMP("RCKATP",$J)

 S RCCOM(1)="INTEREST ADJUSTMENT FOR HURRICANE KATRINA VETERAN"

 S RCD=3050828.9

 F  S RCD=$O(^PRCA(433,"AT",13,RCD)) Q:'RCD!($P(RCD,".")>3060430)  D

 .S RCT=0 F  S RCT=$O(^PRCA(433,"AT",13,RCD,RCT)) Q:'RCT  D

 ..S RCB=+$P($G(^PRCA(433,RCT,0)),"^",2) Q:'RCB

 ..I '$P($G(^PRCA(430,RCB,0)),"^",12) Q

 ..S RCDPT=+$P($G(^PRCA(430,RCB,0)),"^",9)

 ..S RCDEB=$G(^RCD(340,RCDPT,0))

 ..Q:$P(RCDEB,"^")'["DPT"  Q:'RCDEB

 ..;Q:$$EMERES^PRCAUTL(+RCDEB)=""

 ..Q:$$EMGRES^DGUTL(+RCDEB)=""

 ..Q:$P(RCDEB,"^",8)  ;    vet has been already been processed

 ..;

 ..; - store the vet and bill

 ..S ^TMP("RCKATP",$J,RCDPT,RCB)=""

 ;

 ; - look for extra interest exemptions to create

 S RCTOTAL="0^0"

 S RCDEB=0 F  S RCDEB=$O(^TMP("RCKATP",$J,RCDEB)) Q:'RCDEB  D

 .;

 .; - initialize bucket and new patient flag

 .S (RCBUCK,RCNEWP)=0

 .S RCB=0 F  S RCB=$O(^TMP("RCKATP",$J,RCDEB,RCB)) Q:'RCB  D

 ..;

 ..; - review transactions to find interest added/exempted

 ..S RCCB=$$GETTRANS^RCDPBTLM(RCB),RCH=0,RCHOLD=""

 ..S RCDT=3050828.9 F  S RCDT=$O(RCLIST(RCDT)) Q:'RCDT  D

 ...S RCT=0 F  S RCT=$O(RCLIST(RCDT,RCT)) Q:'RCT  D

 ....S RCV=RCLIST(RCDT,RCT)

 ....;

 ....; - if transaction is an interest charge, save off amount

 ....I RCV["INTEREST/ADM. CHARGE",RCDT<3060501 S RCH=1 D  Q

 .....S $P(RCHOLD,"^")=$P(RCHOLD,"^")+$P(RCV,"^",3)

 .....S $P(RCHOLD,"^",2)=$P(RCHOLD,"^",2)+$P(RCV,"^",4)

 ....;

 ....; - if transaction is an interest exemption, save off (+) amount

 ....I RCV["EXEMPT INT/ADM. COST",RCH D  Q

 .....S $P(RCHOLD,"^",3)=$P(RCHOLD,"^",3)-$P(RCV,"^",3)

 .....S $P(RCHOLD,"^",4)=$P(RCHOLD,"^",4)-$P(RCV,"^",4)

 ..;

 ..; - get total amounts of interest added and exempted

 ..S RCINT=$P(RCHOLD,"^")+$P(RCHOLD,"^",2)

 ..S RCEXEM=$P(RCHOLD,"^",3)+$P(RCHOLD,"^",4)

 ..;

 ..; - quit if interest added less than or equal to exemptions

 ..S RCAPPLY=RCINT-RCEXEM

 ..Q:RCAPPLY'>0

 ..;

 ..; - get bill's interest balance

 ..S RCNEWP=1

 ..S X=$G(^PRCA(430,RCB,7)),RCINTB=$P(X,"^",2)+$P(X,"^",3)

 ..;

 ..; - if no balance, put in bucket and quit

 ..I 'RCINTB S RCBUCK=RCBUCK+RCAPPLY Q

 ..;

 ..; - adjust bucket and amount to apply

 ..S RCAMT=$S(RCAPPLY'<RCINTB:RCINTB,1:RCAPPLY)

 ..S RCBUCK=$S(RCAPPLY>RCINTB:RCBUCK+(RCAPPLY-RCINTB),1:RCBUCK)

 ..;

 ..; - will apply RCAMT - spread over admin then interest.

 ..S RCAPA=$S(RCAMT'<$P(X,"^",3):$P(X,"^",3),1:RCAMT)

 ..S RCAPI=RCAMT-RCAPA

 ..S RC=$$EXEMPT^RCBEUTR2(RCB,RCAPI_"^"_RCAPA,.RCCOM,0)

 ..;

 ..; - update total amount exempted

 ..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCAMT

 .;

 .;

 .; - set debtor as having been processed

 .S $P(^RCD(340,RCDEB,0),"^",8)=1

 .;

 .; - if an amount is left in the bucket, process it,

 .;   update total exempted, and the number of vets exempted

 .I RCBUCK D

 ..D EN^RCKATPD($P($G(^RCD(340,RCDEB,0)),"^"),RCBUCK,RCCOM(1))

 ..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCBUCK

 .I RCNEWP S $P(RCTOTAL,"^")=$P(RCTOTAL,"^")+1

 ;

 ;

 K ^TMP("RCKATP",$J)

 K RCD,RCT,RCB,RCDPT,RCDEB,RCBUCK,RCNEWP,RC,RCCB,RCH,RCHOLD,RCDT

 K RCLIST,RCV,RCINT,RCINTB,RCEXEM,RCAPPLY,RCAMT,RCAPA,RCAPI,RCCOM,X

 Q

 ;

 ;

CHK(DFN) ; Check to see if vet should have charges cancelled

 ;  Input:  DFN  --  Pointer to patient in file 2

 ; Output:    0  --  No, don't cancel charges

 ;            1  --  Yes, cancel charges

 N RCDEB,RCH

 S RCH=0

 ;I $$EMERES^PRCAUTL(DFN)="" G CHKQ

 I $$EMGRES^DGUTL(DFN)="" G CHKQ

 S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))

 ;

 ; - if a Katrina vet is not in file #340, must look for held charges

 I 'RCDEB S RCH=1 G CHKQ

 ;

 ; - make sure charges have not yet been canceled

 I '$P($G(^RCD(340,RCDEB,0)),"^",9) S RCH=1

CHKQ Q RCH

 ;

 ;

TPP(RCTI,RCH) ; Identify decreases that are credits for third party payments

 ;  Input:  RCTI  --  Pointer to AR Transaction in file 433

 ;           RCH  --  Array of 'counted' transactions passed by reference

 ; Output:  RCRES --  1^2, where

 ;                      1 = total amount of credit adjustments

 ;                      2 = pointer to the affected bill in file #430

 ;

 N RCRES,RCB,RCAMT,RCT,RCTD,RCQ,RCI,RCS

 S RCRES="",RCAMT=0

 I '$G(RCTI) G TPPQ

 S RCB=+$P($G(^PRCA(433,RCTI,0)),"^",2) I 'RCB G TPPQ

 S RCAMT=0

 S RCT=RCTI F  S RCT=$O(^PRCA(433,"C",RCB,RCT)) Q:'RCT  D

 .Q:$D(RCH(RCB,RCT))  ;    transaction has been counted

 .S RCTD=$G(^PRCA(433,RCT,1))

 .Q:$P(RCTD,"^",2)'=35  ;  not a decrease

 .;

 .; - check for a potential 'Katrina decrease'

 .S RCQ=0,RCS="HURRICANE KATRINA VETERAN" D  Q:RCQ

 ..S RCI=0 F  S RCI=$O(^PRCA(433,RCT,7,RCI)) Q:'RCI  D  Q:RCQ

 ...I $G(^PRCA(433,RCT,7,RCI,0))[RCS S RCQ=1

 .;

 .; - increment the credit amount

 .S RCAMT=RCAMT+$P(RCTD,"^",5),RCH(RCB,RCT)=""

 ;

 S RCRES=RCAMT_"^"_RCB

TPPQ Q RCRES

 ;

 ;

DEC(RCBILL,RCAMT) ; Decrease a bill

 ;  Input:  RCBILL  --  Bill Number of a bill in file 430

 ;           RCAMT  --  Amount to decrease bill

 ; Output:  RCBUCK  --  Amount not decreased, to go to bucket

 ;

 N RCBUCK,RCMSG,RCT

 S RCBUCK=RCAMT

 S RCB=$O(^PRCA(430,"B",RCBILL,0))

 I RCB D

 .S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"

 .D DEC^PRCASER1(RCB,.RCBUCK,DUZ,RCMSG,"",.RCT)

DECQ Q RCBUCK

 ;

 ;

FLAG(DFN) ; Flag veteran as having had copay charges cancelled

 ;  Input:  DFN  --  Pointer to patient in file 2

 ;

 N RCDEB

 S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))

 I 'RCDEB D

 .S DIC="^RCD(340,",DIC(0)="QL",X=DFN_";DPT(",DLAYGO=340

 .K DD,DO D FILE^DICN K DIC,DLAYGO,DO,DD S RCDEB=+Y

 I RCDEB>0 S $P(^RCD(340,RCDEB,0),"^",9)=1

 Q

 ;

 ;

ADJ(DFN,RCAMT) ; Make final credit adjustments to the vet's account

 ;  Input:  DFN  --  Pointer to patient in file 2

 ;        RCAMT  --  Amount to decrease from account

 ;

 N RCDEBN,RCMSG

 S RCDEBN=DFN_";DPT("

 S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"

 D EN^RCKATPD(RCDEBN,RCAMT,RCMSG)

 Q

 ;

 ;

BULL ; Send job completion bulletin

 N XMSUB,XMTEXT,XMY,XMDUZ,RCT,RCN

 S RCT(1)="The patch PRCA*4.5*241 post initialization has completed."

 S RCT(2)=" "

 S RCT(3)="Number of Veterans with Interest Exempted:  "_+RCTOTAL

 S RCT(4)="        Total Amount of Interest Exempted: $"_$J($P(RCTOTAL,"^",2),0,2)

 S RCT(5)=" "

 I RCRES="" S RCT(6)="*** Note: Copay Charges were not cancelled - contact EVS ***"

 I RCRES'="" D

 .S RCT(6)="Number of Veterans with Charges Cancelled:  "_+RCRES

 .S RCT(7)="        Total Amount of Charges Cancelled: $"_$J($P(RCRES,"^",2),0,2)

 .S RCT(8)="   Total Amount of Held Charges Cancelled: $"_$J($P(RCRES,"^",3),0,2)

 ;

 S XMSUB="Job Completion - PRCA*4.5*241 Post Initialization"

 S XMTEXT="RCT("

 S XMY("G.PRCA ADJUSTMENT TRANS")="",XMY(DUZ)=""

 S XMDUZ="ACCOUNTS RECEIVABLE"

 D ^XMD

 Q