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

RCKATPD.m

Go to the documentation of this file.
  1. RCKATPD ;ALB/CPM/TJK - ADJUST ACCOUNTS FOR KATRINA VETS (CON'T);Jun 06, 2014@19:11:19
  1. ;;4.5;Accounts Receivable;**241,371**;Mar 20, 1995;Build 29
  1. ;;Per VHA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. EN(ACCT,BUCKET,RCMSG) ; Entry point to credit an account for a Katrina vet
  1. ; Input: ACCT -- value of .01 field for debtor in file 340
  1. ; BUCKET -- Amount to credit the account
  1. ; RCMSG -- Bill or transaction comment
  1. ;
  1. N DFN,RCDEBTDA,RCCOM
  1. S DFN=+ACCT,RCDEBTDA=$$DEBT^RCEVUTL(ACCT)
  1. I 'DFN!($G(^DPT(DFN,0))="") Q
  1. K ^TMP($J)
  1. N BILL,B0,OLDBAL,PREPAY,TRAN,TDATE,T0,T1,TRAMT,X,TTYPE,STATUS,BN7
  1. N DECAMT,EXTOT,I,PRCAEN,DIC,DIE,DA,DR,MSG,PERROR,NBILL,NTRAN,MSGCNTS,ERR
  1. S PREPAY=$O(^PRCA(430.2,"B","PREPAYMENT",0)),RCCOM(1)=RCMSG
  1. F STATUS=16,42 S BILL=0 F S BILL=$O(^PRCA(430,"AS",RCDEBTDA,STATUS,BILL)) Q:'BILL!'BUCKET D PROC,APPLY:OLDBAL
  1. D REFUND:BUCKET
  1. S ERR=$G(PERROR) K ^TMP($J)
  1. Q
  1. ;
  1. PROC ; Determine the bill's balance
  1. S B0=$G(^PRCA(430,BILL,0)),BN7=$G(^(7))
  1. S OLDBAL=0 F I=1:1:5 S OLDBAL=OLDBAL+$P(BN7,U,I)
  1. Q
  1. ;
  1. APPLY ; Exempt interest and decrease a bill
  1. S EXTOT=0 F I=2:1:5 S EXTOT=EXTOT+$P(BN7,U,I)
  1. ;
  1. ; - interest balance is zero - do a decrease
  1. G DEC:'EXTOT
  1. ;
  1. S TRAMT=0 S:EXTOT'<BUCKET EXTOT=BUCKET
  1. INT F I=5:-1:2 Q:'EXTOT I $P(BN7,U,I) D
  1. .S X=$P(BN7,U,I),DECAMT=$S(X>BUCKET:BUCKET,1:X)
  1. .S $P(BN7,U,I)=$P(BN7,U,I)-DECAMT,BUCKET=BUCKET-DECAMT
  1. .S EXTOT=EXTOT-DECAMT,TRAMT=TRAMT+DECAMT
  1. S OLDBAL=OLDBAL-TRAMT
  1. ;
  1. ; - create exemption transaction
  1. D SETTR^PRCAUTL
  1. S TTYPE=14,DIE="^PRCA(433,",DA=PRCAEN
  1. S DR=".03////"_BILL_";11////"_DT_";12////"_TTYPE_";15///"_TRAMT_";41///"_RCMSG_";89///1;4///2"
  1. S DIC=DIE D ^DIE
  1. K DA,DIC,DIE,DR,TRAMT
  1. ;
  1. ; - update the balance of the bill
  1. ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
  1. N RCFDA S RCFDA(430,BILL_",",72)=$P(BN7,U,2),RCFDA(430,BILL_",",73)=$P(BN7,U,3),RCFDA(430,BILL_",",74)=$P(BN7,U,4),RCFDA(430,BILL_",",75)=$P(BN7,U,5)
  1. D FILE^DIE(,"RCFDA")
  1. ;
  1. ; - if the bill was decreased by its entire balance, set the
  1. ; bill status to Cancellation
  1. I 'OLDBAL D CHGSTAT^RCBEUBIL(BILL,39),ADDCOMM^RCBEUBIL(BILL,.RCCOM) Q
  1. ;
  1. ; - no need for decrease if the amount to credit the account is zero
  1. Q:'BUCKET
  1. ;
  1. DEC ; - create a decrease adjustment
  1. S PRCAEN=0,DECAMT=BUCKET
  1. D DEC^PRCASER1(BILL,.DECAMT,DUZ,RCMSG,"",.PRCAEN)
  1. S BUCKET=DECAMT
  1. Q
  1. ;
  1. ;
  1. REFUND ; Create a prepayment in an Open status
  1. S PERROR="" D EN^PRCAPAY3(DFN_";DPT(",BUCKET,DT,DUZ,"","","",.PERROR)
  1. Q:PERROR]""
  1. ;
  1. ; - find the Open prepayment just increased to add a comment
  1. S NBILL=0 F S NBILL=$O(^PRCA(430,"AS",RCDEBTDA,$O(^PRCA(430.3,"AC",112,0)),NBILL)) Q:'NBILL I $P(^PRCA(430,NBILL,0),U,2)=PREPAY Q
  1. I NBILL D ADDCOMM^RCBEUBIL(NBILL,.RCCOM)
  1. Q