RCRJRCOB ;WISC/RFJ-calculate a bills balance ;1 Mar 97
;;4.5;Accounts Receivable;**68,96,103,153,156,320,340**;Mar 20, 1995;Build 9
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;
BILLBAL(BILLDA,DATEEND) ; find bills balance on dateend
; returns principal ^ interest ^ admin ^ mf ^ cc
N ACTDATE,ADMIN,CC,DATA1,DATA7,INTEREST,LASTTRAN,MF,PRINBAL,TRANDA,TYPE,VALUE
;
; bill activated after dateend
S ACTDATE=$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
I 'ACTDATE!(ACTDATE>DATEEND) Q "^^^^"
;
; this lock cannot fail and must be executed to prevent bill
; activity during the calculation of the bills balance
F L +^PRCA(430,BILLDA):$S($G(DILOCKTM)>5:DILOCKTM,1:5) Q:$T H 2
;
; try and find last 433 transaction
S LASTTRAN=999999999999 F S LASTTRAN=$O(^PRCA(433,"C",BILLDA,LASTTRAN),-1) Q:'LASTTRAN S DATA1=$G(^PRCA(433,LASTTRAN,1)) I $P($P(DATA1,"^",9),".")'>DATEEND,$P(DATA1,"^",2)'=45 Q
;
; there are no transactions in file 433
I 'LASTTRAN D G UNLOCK
. S PRINBAL=+$P($G(^PRCA(430,BILLDA,0)),"^",3)
. S (INTEREST,ADMIN,MF,CC)=0
;
; the last transaction may not be in date order
S TRANDA=LASTTRAN F S TRANDA=$O(^PRCA(433,"C",BILLDA,TRANDA)) Q:'TRANDA I $P($P($G(^PRCA(433,TRANDA,1)),"^",9),".")'>DATEEND S LASTTRAN=TRANDA
;
; the last transaction was during time period, use bill balance
I '$O(^PRCA(433,"C",BILLDA,LASTTRAN)) D G UNLOCK
. S DATA7=$G(^PRCA(430,BILLDA,7))
. S PRINBAL=+$P(DATA7,"^")
. S INTEREST=+$P(DATA7,"^",2)
. S ADMIN=$P(DATA7,"^",3)
. S MF=$P(DATA7,"^",4)
. S CC=$P(DATA7,"^",5)
;
; calculate balance
S DATA7=$G(^PRCA(430,BILLDA,7))
S PRINBAL=+$P(DATA7,"^")
S INTEREST=+$P(DATA7,"^",2)
S ADMIN=$P(DATA7,"^",3)
S MF=$P(DATA7,"^",4)
S CC=$P(DATA7,"^",5)
;
; if the bill's status is write-off, balance and int = 0
I $P($G(^PRCA(430,BILLDA,0)),"^",8)=23 S (PRINBAL,INTEREST,ADMIN,MF,CC)=0
;
S TRANDA=LASTTRAN
F S TRANDA=$O(^PRCA(433,"C",BILLDA,TRANDA)) Q:'TRANDA I $P($G(^PRCA(433,TRANDA,0)),"^",4)=2 D
. S VALUE=$$TRANBAL^RCRJRCOT(TRANDA) I VALUE="" Q
. ;
. S TYPE=$P($G(^PRCA(433,TRANDA,1)),"^",2)
. I TYPE=1!(TYPE=12)!(TYPE=13)!(TYPE=43)!(TYPE=73)!(TYPE=74) D Q ; *340 added 73 and 74
. . S PRINBAL=PRINBAL-$P(VALUE,"^")
. . S INTEREST=INTEREST-$P(VALUE,"^",2)
. . S ADMIN=ADMIN-$P(VALUE,"^",3)
. . S MF=MF-$P(VALUE,"^",4)
. . S CC=CC-$P(VALUE,"^",5)
. I TYPE=2!(TYPE=8)!(TYPE=9)!(TYPE=10)!(TYPE=11)!(TYPE=14)!(TYPE=29)!(TYPE=34)!(TYPE=35)!(TYPE=41) D Q
. . S PRINBAL=PRINBAL+$P(VALUE,"^")
. . S INTEREST=INTEREST+$P(VALUE,"^",2)
. . S ADMIN=ADMIN+$P(VALUE,"^",3)
. . S MF=MF+$P(VALUE,"^",4)
. . S CC=CC+$P(VALUE,"^",5)
;
; do not allow balances to be negative
I PRINBAL<0 S PRINBAL=0
; for transaction type 2,11,16, admin could not be broken out separate
; if its negative, add it to interest
I ADMIN<0 S INTEREST=INTEREST+ADMIN,ADMIN=0
I INTEREST<0 S ADMIN=ADMIN+INTEREST,INTEREST=0
;
UNLOCK ; come here to unlock global and return results
L -^PRCA(430,BILLDA)
;
Q PRINBAL_"^"_INTEREST_"^"_ADMIN_"^"_MF_"^"_CC
;
;
CURRENT(BILLDA,DATEEND,AYEAROLD) ; finds a bills balance and age
N DA,DATA4,COUNTCUR,CURRAMT,FUTURAMT,INTEREST,NONCURR,PRINBAL,RCVALUE,TOTREPAY
;
; find a bills balance
S RCVALUE=$$BILLBAL(BILLDA,DATEEND)
;
; count as a current receivable
D CURRENT^RCRJRCOC(BILLDA,RCVALUE)
;
S PRINBAL=$P(RCVALUE,"^"),INTEREST=$P(RCVALUE,"^",2)+$P(RCVALUE,"^",3)+$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5)
; if no repay plan date or its greater than date range or no amt due
S DATA4=$G(^PRCA(430,BILLDA,4))
I '$P(DATA4,"^")!($P($P(DATA4,"^"),".")>DATEEND)!('$P(DATA4,"^",3)) D SETTOTAL^RCRJRCO1(2,PRINBAL,INTEREST),AGE Q
;
; total number of repayment due dates
S TOTREPAY=$P($G(^PRCA(430,BILLDA,5,0)),"^",3)
I 'TOTREPAY D SETTOTAL^RCRJRCO1(2,PRINBAL,INTEREST),AGE Q
;
; count the number of current repayments (less than yr old)
S DA=0 F COUNTCUR=0:1 S DA=$O(^PRCA(430,BILLDA,5,DA)) Q:'DA!($P($G(^(DA,0)),"^")>AYEAROLD)
;
; how many repayments are non-current
S NONCURR=TOTREPAY-COUNTCUR
; all are current
I 'NONCURR D SETTOTAL^RCRJRCO1(2,PRINBAL,INTEREST),AGE Q
;
; future amount = noncurrent bills * repayment amount due
S FUTURAMT=NONCURR*$P(DATA4,"^",3),CURRAMT=PRINBAL-FUTURAMT
; no current amt (all future)
;I 'CURRAMT D SETTOTAL^RCRJRCO1(12,FUTURAMT,INTEREST),AGE Q
; PRCA*4.5*320 - FY16 HAPE RRE (TROR)changes to buckets as per buckets added incrimented the CRITER2 IENS
I 'CURRAMT D SETTOTAL^RCRJRCO1(14,FUTURAMT,INTEREST),AGE Q
;
D SETTOTAL^RCRJRCO1(2,CURRAMT,INTEREST)
;D SETTOTAL^RCRJRCO1(12,FUTURAMT,0)
;PRCA*4.5*320 - FY16 HAPE RRE (TROR) changes to buckets as per buckets added incrimented the CRITER2 IENS
D SETTOTAL^RCRJRCO1(14,FUTURAMT,0)
D AGE
Q
;
;
AGE ; finds the age of delinquents
; the date the 2nd letter was sent
N DAYSDIFF,LETRDATE
S LETRDATE=$P($P($G(^PRCA(430,BILLDA,6)),"^",2),".")
I 'LETRDATE!(LETRDATE>DATEEND) Q
;
S DAYSDIFF=$$FMDIFF^XLFDT(DATEEND,LETRDATE,1)
; pass criteria 2 based on days difference
;PRCA*4.5*320 FY16 HAPE RRE (TROR); reset aging buckets which adds two buckets, requiring adjustments in multiple instances
; 3 DELINQUENT 1 - 30 Days
; 4 DELINQUENT 31 - 60 Days
; 5 DELINQUENT 61 - 90 Days
; 6 DELINQUENT 91 - 120 Days
; 7 DELINQUENT 121 - 150 Days
; 8 DELINQUENT 151 - 180 Days
; 9 DELINQUENT 181 - 365 Days
; 10 DELINQUENT 1 - 2 Years
; 11 DELINQUENT 2 - 6 Years
; 12 DELINQUENT 6 - 10 Years
; 13 DELINQUENT Over 10 Years
;D SETTOTAL^RCRJRCO1($S(DAYSDIFF<31:3,DAYSDIFF<61:4,DAYSDIFF<91:5,DAYSDIFF<121:6,DAYSDIFF<181:7,DAYSDIFF<366:8,DAYSDIFF<731:9,DAYSDIFF<1096:10,1:11),PRINBAL,INTEREST)
D SETTOTAL^RCRJRCO1($S(DAYSDIFF<31:3,DAYSDIFF<61:4,DAYSDIFF<91:5,DAYSDIFF<121:6,DAYSDIFF<151:7,DAYSDIFF<181:8,DAYSDIFF<366:9,DAYSDIFF<731:10,DAYSDIFF<2193:11,DAYSDIFF<3655:12,1:13),PRINBAL,INTEREST)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRJRCOB 6197 printed Oct 16, 2024@17:49 Page 2
RCRJRCOB ;WISC/RFJ-calculate a bills balance ;1 Mar 97
+1 ;;4.5;Accounts Receivable;**68,96,103,153,156,320,340**;Mar 20, 1995;Build 9
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
BILLBAL(BILLDA,DATEEND) ; find bills balance on dateend
+1 ; returns principal ^ interest ^ admin ^ mf ^ cc
+2 NEW ACTDATE,ADMIN,CC,DATA1,DATA7,INTEREST,LASTTRAN,MF,PRINBAL,TRANDA,TYPE,VALUE
+3 ;
+4 ; bill activated after dateend
+5 SET ACTDATE=$PIECE($PIECE($GET(^PRCA(430,BILLDA,6)),"^",21),".")
+6 IF 'ACTDATE!(ACTDATE>DATEEND)
QUIT "^^^^"
+7 ;
+8 ; this lock cannot fail and must be executed to prevent bill
+9 ; activity during the calculation of the bills balance
+10 FOR
LOCK +^PRCA(430,BILLDA):$SELECT($GET(DILOCKTM)>5:DILOCKTM,1:5)
if $TEST
QUIT
HANG 2
+11 ;
+12 ; try and find last 433 transaction
+13 SET LASTTRAN=999999999999
FOR
SET LASTTRAN=$ORDER(^PRCA(433,"C",BILLDA,LASTTRAN),-1)
if 'LASTTRAN
QUIT
SET DATA1=$GET(^PRCA(433,LASTTRAN,1))
IF $PIECE($PIECE(DATA1,"^",9),".")'>DATEEND
IF $PIECE(DATA1,"^",2)'=45
QUIT
+14 ;
+15 ; there are no transactions in file 433
+16 IF 'LASTTRAN
Begin DoDot:1
+17 SET PRINBAL=+$PIECE($GET(^PRCA(430,BILLDA,0)),"^",3)
+18 SET (INTEREST,ADMIN,MF,CC)=0
End DoDot:1
GOTO UNLOCK
+19 ;
+20 ; the last transaction may not be in date order
+21 SET TRANDA=LASTTRAN
FOR
SET TRANDA=$ORDER(^PRCA(433,"C",BILLDA,TRANDA))
if 'TRANDA
QUIT
IF $PIECE($PIECE($GET(^PRCA(433,TRANDA,1)),"^",9),".")'>DATEEND
SET LASTTRAN=TRANDA
+22 ;
+23 ; the last transaction was during time period, use bill balance
+24 IF '$ORDER(^PRCA(433,"C",BILLDA,LASTTRAN))
Begin DoDot:1
+25 SET DATA7=$GET(^PRCA(430,BILLDA,7))
+26 SET PRINBAL=+$PIECE(DATA7,"^")
+27 SET INTEREST=+$PIECE(DATA7,"^",2)
+28 SET ADMIN=$PIECE(DATA7,"^",3)
+29 SET MF=$PIECE(DATA7,"^",4)
+30 SET CC=$PIECE(DATA7,"^",5)
End DoDot:1
GOTO UNLOCK
+31 ;
+32 ; calculate balance
+33 SET DATA7=$GET(^PRCA(430,BILLDA,7))
+34 SET PRINBAL=+$PIECE(DATA7,"^")
+35 SET INTEREST=+$PIECE(DATA7,"^",2)
+36 SET ADMIN=$PIECE(DATA7,"^",3)
+37 SET MF=$PIECE(DATA7,"^",4)
+38 SET CC=$PIECE(DATA7,"^",5)
+39 ;
+40 ; if the bill's status is write-off, balance and int = 0
+41 IF $PIECE($GET(^PRCA(430,BILLDA,0)),"^",8)=23
SET (PRINBAL,INTEREST,ADMIN,MF,CC)=0
+42 ;
+43 SET TRANDA=LASTTRAN
+44 FOR
SET TRANDA=$ORDER(^PRCA(433,"C",BILLDA,TRANDA))
if 'TRANDA
QUIT
IF $PIECE($GET(^PRCA(433,TRANDA,0)),"^",4)=2
Begin DoDot:1
+45 SET VALUE=$$TRANBAL^RCRJRCOT(TRANDA)
IF VALUE=""
QUIT
+46 ;
+47 SET TYPE=$PIECE($GET(^PRCA(433,TRANDA,1)),"^",2)
+48 ; *340 added 73 and 74
IF TYPE=1!(TYPE=12)!(TYPE=13)!(TYPE=43)!(TYPE=73)!(TYPE=74)
Begin DoDot:2
+49 SET PRINBAL=PRINBAL-$PIECE(VALUE,"^")
+50 SET INTEREST=INTEREST-$PIECE(VALUE,"^",2)
+51 SET ADMIN=ADMIN-$PIECE(VALUE,"^",3)
+52 SET MF=MF-$PIECE(VALUE,"^",4)
+53 SET CC=CC-$PIECE(VALUE,"^",5)
End DoDot:2
QUIT
+54 IF TYPE=2!(TYPE=8)!(TYPE=9)!(TYPE=10)!(TYPE=11)!(TYPE=14)!(TYPE=29)!(TYPE=34)!(TYPE=35)!(TYPE=41)
Begin DoDot:2
+55 SET PRINBAL=PRINBAL+$PIECE(VALUE,"^")
+56 SET INTEREST=INTEREST+$PIECE(VALUE,"^",2)
+57 SET ADMIN=ADMIN+$PIECE(VALUE,"^",3)
+58 SET MF=MF+$PIECE(VALUE,"^",4)
+59 SET CC=CC+$PIECE(VALUE,"^",5)
End DoDot:2
QUIT
End DoDot:1
+60 ;
+61 ; do not allow balances to be negative
+62 IF PRINBAL<0
SET PRINBAL=0
+63 ; for transaction type 2,11,16, admin could not be broken out separate
+64 ; if its negative, add it to interest
+65 IF ADMIN<0
SET INTEREST=INTEREST+ADMIN
SET ADMIN=0
+66 IF INTEREST<0
SET ADMIN=ADMIN+INTEREST
SET INTEREST=0
+67 ;
UNLOCK ; come here to unlock global and return results
+1 LOCK -^PRCA(430,BILLDA)
+2 ;
+3 QUIT PRINBAL_"^"_INTEREST_"^"_ADMIN_"^"_MF_"^"_CC
+4 ;
+5 ;
CURRENT(BILLDA,DATEEND,AYEAROLD) ; finds a bills balance and age
+1 NEW DA,DATA4,COUNTCUR,CURRAMT,FUTURAMT,INTEREST,NONCURR,PRINBAL,RCVALUE,TOTREPAY
+2 ;
+3 ; find a bills balance
+4 SET RCVALUE=$$BILLBAL(BILLDA,DATEEND)
+5 ;
+6 ; count as a current receivable
+7 DO CURRENT^RCRJRCOC(BILLDA,RCVALUE)
+8 ;
+9 SET PRINBAL=$PIECE(RCVALUE,"^")
SET INTEREST=$PIECE(RCVALUE,"^",2)+$PIECE(RCVALUE,"^",3)+$PIECE(RCVALUE,"^",4)+$PIECE(RCVALUE,"^",5)
+10 ; if no repay plan date or its greater than date range or no amt due
+11 SET DATA4=$GET(^PRCA(430,BILLDA,4))
+12 IF '$PIECE(DATA4,"^")!($PIECE($PIECE(DATA4,"^"),".")>DATEEND)!('$PIECE(DATA4,"^",3))
DO SETTOTAL^RCRJRCO1(2,PRINBAL,INTEREST)
DO AGE
QUIT
+13 ;
+14 ; total number of repayment due dates
+15 SET TOTREPAY=$PIECE($GET(^PRCA(430,BILLDA,5,0)),"^",3)
+16 IF 'TOTREPAY
DO SETTOTAL^RCRJRCO1(2,PRINBAL,INTEREST)
DO AGE
QUIT
+17 ;
+18 ; count the number of current repayments (less than yr old)
+19 SET DA=0
FOR COUNTCUR=0:1
SET DA=$ORDER(^PRCA(430,BILLDA,5,DA))
if 'DA!($PIECE($GET(^(DA,0)),"^")>AYEAROLD)
QUIT
+20 ;
+21 ; how many repayments are non-current
+22 SET NONCURR=TOTREPAY-COUNTCUR
+23 ; all are current
+24 IF 'NONCURR
DO SETTOTAL^RCRJRCO1(2,PRINBAL,INTEREST)
DO AGE
QUIT
+25 ;
+26 ; future amount = noncurrent bills * repayment amount due
+27 SET FUTURAMT=NONCURR*$PIECE(DATA4,"^",3)
SET CURRAMT=PRINBAL-FUTURAMT
+28 ; no current amt (all future)
+29 ;I 'CURRAMT D SETTOTAL^RCRJRCO1(12,FUTURAMT,INTEREST),AGE Q
+30 ; PRCA*4.5*320 - FY16 HAPE RRE (TROR)changes to buckets as per buckets added incrimented the CRITER2 IENS
+31 IF 'CURRAMT
DO SETTOTAL^RCRJRCO1(14,FUTURAMT,INTEREST)
DO AGE
QUIT
+32 ;
+33 DO SETTOTAL^RCRJRCO1(2,CURRAMT,INTEREST)
+34 ;D SETTOTAL^RCRJRCO1(12,FUTURAMT,0)
+35 ;PRCA*4.5*320 - FY16 HAPE RRE (TROR) changes to buckets as per buckets added incrimented the CRITER2 IENS
+36 DO SETTOTAL^RCRJRCO1(14,FUTURAMT,0)
+37 DO AGE
+38 QUIT
+39 ;
+40 ;
AGE ; finds the age of delinquents
+1 ; the date the 2nd letter was sent
+2 NEW DAYSDIFF,LETRDATE
+3 SET LETRDATE=$PIECE($PIECE($GET(^PRCA(430,BILLDA,6)),"^",2),".")
+4 IF 'LETRDATE!(LETRDATE>DATEEND)
QUIT
+5 ;
+6 SET DAYSDIFF=$$FMDIFF^XLFDT(DATEEND,LETRDATE,1)
+7 ; pass criteria 2 based on days difference
+8 ;PRCA*4.5*320 FY16 HAPE RRE (TROR); reset aging buckets which adds two buckets, requiring adjustments in multiple instances
+9 ; 3 DELINQUENT 1 - 30 Days
+10 ; 4 DELINQUENT 31 - 60 Days
+11 ; 5 DELINQUENT 61 - 90 Days
+12 ; 6 DELINQUENT 91 - 120 Days
+13 ; 7 DELINQUENT 121 - 150 Days
+14 ; 8 DELINQUENT 151 - 180 Days
+15 ; 9 DELINQUENT 181 - 365 Days
+16 ; 10 DELINQUENT 1 - 2 Years
+17 ; 11 DELINQUENT 2 - 6 Years
+18 ; 12 DELINQUENT 6 - 10 Years
+19 ; 13 DELINQUENT Over 10 Years
+20 ;D SETTOTAL^RCRJRCO1($S(DAYSDIFF<31:3,DAYSDIFF<61:4,DAYSDIFF<91:5,DAYSDIFF<121:6,DAYSDIFF<181:7,DAYSDIFF<366:8,DAYSDIFF<731:9,DAYSDIFF<1096:10,1:11),PRINBAL,INTEREST)
+21 DO SETTOTAL^RCRJRCO1($SELECT(DAYSDIFF<31:3,DAYSDIFF<61:4,DAYSDIFF<91:5,DAYSDIFF<121:6,DAYSDIFF<151:7,DAYSDIFF<181:8,DAYSDIFF<366:9,DAYSDIFF<731:10,DAYSDIFF<2193:11,DAYSDIFF<3655:12,1:13),PRINBAL,INTEREST)
+22 QUIT
