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