Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCKATP

RCKATP.m

Go to the documentation of this file.
  1. RCKATP ;ALB/CPM - ADJUST ACCOUNTS FOR KATRINA VETS ; 28-FEB-06
  1. ;;4.5;Accounts Receivable;**241,246**;Mar 20, 1995
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. POST ; Queue PRCA*4.5*241 post-init job.
  1. ;
  1. D BMES^XPDUTL(">>> Queuing the post-initialization to run now...")
  1. S ZTDTH=$H,ZTRTN="EN^RCKATP",ZTIO=""
  1. S ZTDESC="RC - PATCH PRCA*4.5*241 POST INITIALIZATION"
  1. D ^%ZTLOAD
  1. I $D(ZTSK) D MES^XPDUTL(" >> Queued as task #"_ZTSK_".")
  1. I '$D(ZTSK) D MES^XPDUTL(" >> Unable to queue task - contact EVS.")
  1. K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO
  1. Q
  1. ;
  1. ;
  1. EN ; Queued entry point to run the PRCA*4.5*241 post init.
  1. ;
  1. D EX ; exempt interest - return RCTOTAL
  1. ;
  1. S RCRES=$$CAN^IBAKAT() ; cancel copay charges
  1. ;
  1. D BULL ; generate bulletin with results
  1. ;
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. K RCTOTAL,RCRES
  1. Q
  1. ;
  1. ;
  1. EX ; Entry point to exempt interest/admin charges
  1. ;
  1. ; - get all 'Katrina' vets based on interest/admin charges
  1. K ^TMP("RCKATP",$J)
  1. S RCCOM(1)="INTEREST ADJUSTMENT FOR HURRICANE KATRINA VETERAN"
  1. S RCD=3050828.9
  1. F S RCD=$O(^PRCA(433,"AT",13,RCD)) Q:'RCD!($P(RCD,".")>3060430) D
  1. .S RCT=0 F S RCT=$O(^PRCA(433,"AT",13,RCD,RCT)) Q:'RCT D
  1. ..S RCB=+$P($G(^PRCA(433,RCT,0)),"^",2) Q:'RCB
  1. ..I '$P($G(^PRCA(430,RCB,0)),"^",12) Q
  1. ..S RCDPT=+$P($G(^PRCA(430,RCB,0)),"^",9)
  1. ..S RCDEB=$G(^RCD(340,RCDPT,0))
  1. ..Q:$P(RCDEB,"^")'["DPT" Q:'RCDEB
  1. ..;Q:$$EMERES^PRCAUTL(+RCDEB)=""
  1. ..Q:$$EMGRES^DGUTL(+RCDEB)=""
  1. ..Q:$P(RCDEB,"^",8) ; vet has been already been processed
  1. ..;
  1. ..; - store the vet and bill
  1. ..S ^TMP("RCKATP",$J,RCDPT,RCB)=""
  1. ;
  1. ; - look for extra interest exemptions to create
  1. S RCTOTAL="0^0"
  1. S RCDEB=0 F S RCDEB=$O(^TMP("RCKATP",$J,RCDEB)) Q:'RCDEB D
  1. .;
  1. .; - initialize bucket and new patient flag
  1. .S (RCBUCK,RCNEWP)=0
  1. .S RCB=0 F S RCB=$O(^TMP("RCKATP",$J,RCDEB,RCB)) Q:'RCB D
  1. ..;
  1. ..; - review transactions to find interest added/exempted
  1. ..S RCCB=$$GETTRANS^RCDPBTLM(RCB),RCH=0,RCHOLD=""
  1. ..S RCDT=3050828.9 F S RCDT=$O(RCLIST(RCDT)) Q:'RCDT D
  1. ...S RCT=0 F S RCT=$O(RCLIST(RCDT,RCT)) Q:'RCT D
  1. ....S RCV=RCLIST(RCDT,RCT)
  1. ....;
  1. ....; - if transaction is an interest charge, save off amount
  1. ....I RCV["INTEREST/ADM. CHARGE",RCDT<3060501 S RCH=1 D Q
  1. .....S $P(RCHOLD,"^")=$P(RCHOLD,"^")+$P(RCV,"^",3)
  1. .....S $P(RCHOLD,"^",2)=$P(RCHOLD,"^",2)+$P(RCV,"^",4)
  1. ....;
  1. ....; - if transaction is an interest exemption, save off (+) amount
  1. ....I RCV["EXEMPT INT/ADM. COST",RCH D Q
  1. .....S $P(RCHOLD,"^",3)=$P(RCHOLD,"^",3)-$P(RCV,"^",3)
  1. .....S $P(RCHOLD,"^",4)=$P(RCHOLD,"^",4)-$P(RCV,"^",4)
  1. ..;
  1. ..; - get total amounts of interest added and exempted
  1. ..S RCINT=$P(RCHOLD,"^")+$P(RCHOLD,"^",2)
  1. ..S RCEXEM=$P(RCHOLD,"^",3)+$P(RCHOLD,"^",4)
  1. ..;
  1. ..; - quit if interest added less than or equal to exemptions
  1. ..S RCAPPLY=RCINT-RCEXEM
  1. ..Q:RCAPPLY'>0
  1. ..;
  1. ..; - get bill's interest balance
  1. ..S RCNEWP=1
  1. ..S X=$G(^PRCA(430,RCB,7)),RCINTB=$P(X,"^",2)+$P(X,"^",3)
  1. ..;
  1. ..; - if no balance, put in bucket and quit
  1. ..I 'RCINTB S RCBUCK=RCBUCK+RCAPPLY Q
  1. ..;
  1. ..; - adjust bucket and amount to apply
  1. ..S RCAMT=$S(RCAPPLY'<RCINTB:RCINTB,1:RCAPPLY)
  1. ..S RCBUCK=$S(RCAPPLY>RCINTB:RCBUCK+(RCAPPLY-RCINTB),1:RCBUCK)
  1. ..;
  1. ..; - will apply RCAMT - spread over admin then interest.
  1. ..S RCAPA=$S(RCAMT'<$P(X,"^",3):$P(X,"^",3),1:RCAMT)
  1. ..S RCAPI=RCAMT-RCAPA
  1. ..S RC=$$EXEMPT^RCBEUTR2(RCB,RCAPI_"^"_RCAPA,.RCCOM,0)
  1. ..;
  1. ..; - update total amount exempted
  1. ..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCAMT
  1. .;
  1. .;
  1. .; - set debtor as having been processed
  1. .S $P(^RCD(340,RCDEB,0),"^",8)=1
  1. .;
  1. .; - if an amount is left in the bucket, process it,
  1. .; update total exempted, and the number of vets exempted
  1. .I RCBUCK D
  1. ..D EN^RCKATPD($P($G(^RCD(340,RCDEB,0)),"^"),RCBUCK,RCCOM(1))
  1. ..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCBUCK
  1. .I RCNEWP S $P(RCTOTAL,"^")=$P(RCTOTAL,"^")+1
  1. ;
  1. ;
  1. K ^TMP("RCKATP",$J)
  1. K RCD,RCT,RCB,RCDPT,RCDEB,RCBUCK,RCNEWP,RC,RCCB,RCH,RCHOLD,RCDT
  1. K RCLIST,RCV,RCINT,RCINTB,RCEXEM,RCAPPLY,RCAMT,RCAPA,RCAPI,RCCOM,X
  1. Q
  1. ;
  1. ;
  1. CHK(DFN) ; Check to see if vet should have charges cancelled
  1. ; Input: DFN -- Pointer to patient in file 2
  1. ; Output: 0 -- No, don't cancel charges
  1. ; 1 -- Yes, cancel charges
  1. N RCDEB,RCH
  1. S RCH=0
  1. ;I $$EMERES^PRCAUTL(DFN)="" G CHKQ
  1. I $$EMGRES^DGUTL(DFN)="" G CHKQ
  1. S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))
  1. ;
  1. ; - if a Katrina vet is not in file #340, must look for held charges
  1. I 'RCDEB S RCH=1 G CHKQ
  1. ;
  1. ; - make sure charges have not yet been canceled
  1. I '$P($G(^RCD(340,RCDEB,0)),"^",9) S RCH=1
  1. CHKQ Q RCH
  1. ;
  1. ;
  1. TPP(RCTI,RCH) ; Identify decreases that are credits for third party payments
  1. ; Input: RCTI -- Pointer to AR Transaction in file 433
  1. ; RCH -- Array of 'counted' transactions passed by reference
  1. ; Output: RCRES -- 1^2, where
  1. ; 1 = total amount of credit adjustments
  1. ; 2 = pointer to the affected bill in file #430
  1. ;
  1. N RCRES,RCB,RCAMT,RCT,RCTD,RCQ,RCI,RCS
  1. S RCRES="",RCAMT=0
  1. I '$G(RCTI) G TPPQ
  1. S RCB=+$P($G(^PRCA(433,RCTI,0)),"^",2) I 'RCB G TPPQ
  1. S RCAMT=0
  1. S RCT=RCTI F S RCT=$O(^PRCA(433,"C",RCB,RCT)) Q:'RCT D
  1. .Q:$D(RCH(RCB,RCT)) ; transaction has been counted
  1. .S RCTD=$G(^PRCA(433,RCT,1))
  1. .Q:$P(RCTD,"^",2)'=35 ; not a decrease
  1. .;
  1. .; - check for a potential 'Katrina decrease'
  1. .S RCQ=0,RCS="HURRICANE KATRINA VETERAN" D Q:RCQ
  1. ..S RCI=0 F S RCI=$O(^PRCA(433,RCT,7,RCI)) Q:'RCI D Q:RCQ
  1. ...I $G(^PRCA(433,RCT,7,RCI,0))[RCS S RCQ=1
  1. .;
  1. .; - increment the credit amount
  1. .S RCAMT=RCAMT+$P(RCTD,"^",5),RCH(RCB,RCT)=""
  1. ;
  1. S RCRES=RCAMT_"^"_RCB
  1. TPPQ Q RCRES
  1. ;
  1. ;
  1. DEC(RCBILL,RCAMT) ; Decrease a bill
  1. ; Input: RCBILL -- Bill Number of a bill in file 430
  1. ; RCAMT -- Amount to decrease bill
  1. ; Output: RCBUCK -- Amount not decreased, to go to bucket
  1. ;
  1. N RCBUCK,RCMSG,RCT
  1. S RCBUCK=RCAMT
  1. S RCB=$O(^PRCA(430,"B",RCBILL,0))
  1. I RCB D
  1. .S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
  1. .D DEC^PRCASER1(RCB,.RCBUCK,DUZ,RCMSG,"",.RCT)
  1. DECQ Q RCBUCK
  1. ;
  1. ;
  1. FLAG(DFN) ; Flag veteran as having had copay charges cancelled
  1. ; Input: DFN -- Pointer to patient in file 2
  1. ;
  1. N RCDEB
  1. S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))
  1. I 'RCDEB D
  1. .S DIC="^RCD(340,",DIC(0)="QL",X=DFN_";DPT(",DLAYGO=340
  1. .K DD,DO D FILE^DICN K DIC,DLAYGO,DO,DD S RCDEB=+Y
  1. I RCDEB>0 S $P(^RCD(340,RCDEB,0),"^",9)=1
  1. Q
  1. ;
  1. ;
  1. ADJ(DFN,RCAMT) ; Make final credit adjustments to the vet's account
  1. ; Input: DFN -- Pointer to patient in file 2
  1. ; RCAMT -- Amount to decrease from account
  1. ;
  1. N RCDEBN,RCMSG
  1. S RCDEBN=DFN_";DPT("
  1. S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
  1. D EN^RCKATPD(RCDEBN,RCAMT,RCMSG)
  1. Q
  1. ;
  1. ;
  1. BULL ; Send job completion bulletin
  1. N XMSUB,XMTEXT,XMY,XMDUZ,RCT,RCN
  1. S RCT(1)="The patch PRCA*4.5*241 post initialization has completed."
  1. S RCT(2)=" "
  1. S RCT(3)="Number of Veterans with Interest Exempted: "_+RCTOTAL
  1. S RCT(4)=" Total Amount of Interest Exempted: $"_$J($P(RCTOTAL,"^",2),0,2)
  1. S RCT(5)=" "
  1. I RCRES="" S RCT(6)="*** Note: Copay Charges were not cancelled - contact EVS ***"
  1. I RCRES'="" D
  1. .S RCT(6)="Number of Veterans with Charges Cancelled: "_+RCRES
  1. .S RCT(7)=" Total Amount of Charges Cancelled: $"_$J($P(RCRES,"^",2),0,2)
  1. .S RCT(8)=" Total Amount of Held Charges Cancelled: $"_$J($P(RCRES,"^",3),0,2)
  1. ;
  1. S XMSUB="Job Completion - PRCA*4.5*241 Post Initialization"
  1. S XMTEXT="RCT("
  1. S XMY("G.PRCA ADJUSTMENT TRANS")="",XMY(DUZ)=""
  1. S XMDUZ="ACCOUNTS RECEIVABLE"
  1. D ^XMD
  1. Q