- RCRJRCO1 ;WISC/RFJ/BGJ-continuation of ar data collector ;1 Mar 97
- ;;4.5;Accounts Receivable;**68,96,101,120,103,153,156,170,182,203,320,340**;Mar 20, 1995;Build 9
- ;;Per VA Directive 6402, this routine should not be modified.
- Q
- ;
- ;
- START ; calculate ndb values from file 433 transactions
- ; needs datebeg, dateend
- ; total is total by category
- ;
- N ADMIN,BILLDA,DATE,INTEREST,PRINBAL,TRANDA,TRANTYPE,VALUE,RCNOHSIF
- ;
- S RCNOHSIF=$$NOHSIF^RCRJRCO() ; no HSIF (disabled)
- ;
- F TRANTYPE=1,2,3,8,9,10,11,12,13,14,34,35,41,43,73,74 D ; *340 added 73 and 74
- . S DATE=DATEBEG-1
- . F S DATE=$O(^PRCA(433,"AT",TRANTYPE,DATE)) Q:'DATE!(DATE>DATEEND) D
- . . S TRANDA=0
- . . F S TRANDA=$O(^PRCA(433,"AT",TRANTYPE,DATE,TRANDA)) Q:'TRANDA D
- . . . S BILLDA=+$P($G(^PRCA(433,TRANDA,0)),"^",2) I 'BILLDA Q
- . . . ; bill not linked to a site
- . . . I '$P($G(^PRCA(430,BILLDA,0)),"^",12) Q
- . . . ;
- . . . ; get a transactions balance
- . . . S VALUE=$$TRANBAL^RCRJRCOT(TRANDA) I VALUE="" Q
- . . . S PRINBAL=$P(VALUE,"^"),INTEREST=$P(VALUE,"^",2),ADMIN=$P(VALUE,"^",3)+$P(VALUE,"^",4)+$P(VALUE,"^",5)
- . . . ;
- . . . D @TRANTYPE
- Q
- ;
- ;
- 1 ; increase adjustments
- ;D SETTOTAL(14,PRINBAL,0)
- D SETTOTAL(16,PRINBAL,0) ;PRCA*4.5*320 Increease aging buckets by 2
- Q
- ;
- ;
- 2 ; payment in partial
- N CATEGORY
- ; prepayment transaction (field #20)
- I $P($G(^PRCA(433,TRANDA,5)),"^") D Q
- . ;D SETTOTAL(21,PRINBAL,0)
- . D SETTOTAL(23,PRINBAL,0) ;PRCA*4.5*320 Increease aging buckets by 2
- . ;I INTEREST D SETTOTAL(38,INTEREST,0)
- . I INTEREST D SETTOTAL(40,INTEREST,0)
- . ;I ADMIN D SETTOTAL(39,ADMIN,0)
- . I ADMIN D SETTOTAL(41,ADMIN,0)
- ;
- ; check to see if payment is rx copay and is split between
- ; mccf and hsif. if the bill has been run through the
- ; calculator, do it now and report the mccf split to the ndb.
- ; the amount owed to mccf is in piece 3 and is returned negative
- S CATEGORY=$P(^PRCA(430,BILLDA,0),"^",2)
- I 'RCNOHSIF,PRINBAL,(CATEGORY=22!(CATEGORY=23)),'$D(^TMP($J,"RCBMILLDATA",BILLDA,TRANDA)) D
- . S %=$$BILLFUND^RCBMILLC(BILLDA)
- ;
- ; changed by patch PRCA*4.5*182 to no longer separate the mccf and
- ; hsif components. the entire amount is now reported to the ndb.
- ;
- ;. S PRINBAL=-$P($G(^TMP($J,"RCBMILLDATA",BILLDA,TRANDA)),"^",3)
- ;
- ; partial payments (trantype=2), full payments (trantype=34)
- ;D SETTOTAL($S(TRANTYPE=2:19,1:18),PRINBAL,0)
- D SETTOTAL($S(TRANTYPE=2:21,1:20),PRINBAL,0)
- ;I INTEREST D SETTOTAL(38,INTEREST,0)
- I INTEREST D SETTOTAL(40,INTEREST,0)
- ;I ADMIN D SETTOTAL(39,ADMIN,0)
- I ADMIN D SETTOTAL(41,ADMIN,0)
- ;
- ; irs, district counsel, dept of justice (#7)
- S %=$P($G(^PRCA(433,TRANDA,0)),"^",7) I %="" Q
- ;I %="IRS" D SETTOTAL(28,PRINBAL,0) Q
- I %="IRS" D SETTOTAL(30,PRINBAL,0) Q ;PRCA*4.5*320 Increease aging buckets by 2 (on several lines below)
- ;I %="DC" D SETTOTAL(31,PRINBAL,0) Q
- I %="DC" D SETTOTAL(33,PRINBAL,0) Q
- ;I %="DOJ" D SETTOTAL(34,PRINBAL,0) Q
- I %="DOJ" D SETTOTAL(36,PRINBAL,0) Q
- Q
- ;
- ;
- 3 ; refer to district counsel
- ;D SETTOTAL(30,PRINBAL,0)
- D SETTOTAL(32,PRINBAL,0)
- Q
- ;
- ;
- 8 ; terminate by fiscal officer
- ;D WRITEOFF^RCRJRCOC(BILLDA,VALUE,$S(TRANTYPE=8:25,1:24))
- D WRITEOFF^RCRJRCOC(BILLDA,VALUE,$S(TRANTYPE=8:27,1:26))
- ; decrease in number of debts
- ;I '$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,17)) D SETTOTAL(17,0,0)
- I '$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,19)) D SETTOTAL(19,0,0)
- Q
- ;
- ;
- 9 ; terminate by compromise
- D 8
- Q
- ;
- ;
- 10 ; payment waived in full
- ;D WRITEOFF^RCRJRCOC(BILLDA,VALUE,22)
- D WRITEOFF^RCRJRCOC(BILLDA,VALUE,24)
- Q
- ;
- ;
- 11 ; payment waived in partial
- ;D WRITEOFF^RCRJRCOC(BILLDA,VALUE,23)
- D WRITEOFF^RCRJRCOC(BILLDA,VALUE,25)
- Q
- ;
- ;
- 12 ; admin cost / charge
- ; interest/admin added
- ;I INTEREST>0 D SETTOTAL(40,INTEREST,0)
- I INTEREST>0 D SETTOTAL(42,INTEREST,0)
- ;I ADMIN>0 D SETTOTAL(41,ADMIN,0)
- I ADMIN>0 D SETTOTAL(43,ADMIN,0)
- ; interest/admin cost exempt
- ;I INTEREST<0 D SETTOTAL(42,-INTEREST,0)
- I INTEREST<0 D SETTOTAL(44,-INTEREST,0)
- ;I ADMIN<0 D SETTOTAL(42,-ADMIN,0)
- I ADMIN<0 D SETTOTAL(44,-ADMIN,0)
- Q
- ;
- ;
- 13 ; interest / admin charge
- D 12
- Q
- ;
- ;
- 14 ; exempt interest / admin cost
- ;D SETTOTAL(42,INTEREST,0)
- D SETTOTAL(44,INTEREST,0)
- Q
- ;
- ;
- 34 ; payment in full
- D 2
- ; decrease in number of debts
- ;I '$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,17)) D SETTOTAL(17,0,0)
- I '$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,19)) D SETTOTAL(19,0,0)
- Q
- ;
- ;
- 35 ; decrease adjustment
- N CONTRACT
- ; contractual adjustment (field #88)
- S CONTRACT=$P($G(^PRCA(433,TRANDA,8)),"^",8)
- ;I CONTRACT D WRITEOFF^RCRJRCOC(BILLDA,VALUE,20) Q
- I CONTRACT D WRITEOFF^RCRJRCOC(BILLDA,VALUE,22) Q
- ;D SETTOTAL(16,PRINBAL,0)
- D SETTOTAL(18,PRINBAL,0)
- Q
- ;
- ;
- 41 ; refund
- ;D SETTOTAL(43,PRINBAL,0)
- D SETTOTAL(45,PRINBAL,0)
- Q
- ;
- ;
- 43 ; re-establishment
- ;D SETTOTAL(13,PRINBAL,INTEREST+ADMIN)
- D SETTOTAL(15,PRINBAL,INTEREST+ADMIN)
- Q
- ;
- ;
- 73 ; cs increase adjustment - added with *340
- D 1
- Q
- ;
- ;
- 74 ; cs admin.cost charge - added with *340
- D 12
- Q
- ;
- ;
- SETTOTAL(CRITER2,AMOUNT,INTEREST) ; store results
- N RSC,TYPE
- ;
- ; this line of code will prevent duplicate counts if a sites cross
- ; references in file 430 (actdt and asdt) are duplicated (incorrect)
- ;I CRITER2<13,$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,CRITER2)) Q
- I CRITER2<15,$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,CRITER2)) Q
- ;
- ; get a bills criteria 1,3,4,5
- S CRITERIA=$G(^TMP($J,"RCRJRCOL","CRITERIA",BILLDA))
- I CRITERIA="" S CRITERIA=$$CRITERIA^RCRJRCOL(BILLDA),^TMP($J,"RCRJRCOL","CRITERIA",BILLDA)=CRITERIA
- ;
- ; store for ndb
- S $P(CRITERIA,"-",2)=CRITER2
- ;
- ; store results for ndb
- S %=$G(@DATASTOR)
- S $P(%,"^")=$P(%,"^")+1
- S $P(%,"^",2)=$P(%,"^",2)+AMOUNT
- S $P(%,"^",3)=$P(%,"^",3)+INTEREST
- S @DATASTOR=%
- ;
- ; keep a count of which category (criter2) a bill is counted in
- S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,CRITER2)=""
- S ^TMP($J,"RCRJRCOL","CRIT2",CRITER2,BILLDA)=""
- ;
- ; pick up bills with activity which may not have been picked up as
- ; a current receivable because of the wrong status date
- ;I CRITER2>13,CRITER2'=17,'$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,1)),'$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,17)) D CURRENT^RCRJRCOB(BILLDA,DATEEND,AYEAROLD)
- I CRITER2>15,CRITER2'=19,'$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,1)),'$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,19)) D CURRENT^RCRJRCOB(BILLDA,DATEEND,AYEAROLD)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRJRCO1 6631 printed Dec 13, 2024@01:48:08 Page 2
- RCRJRCO1 ;WISC/RFJ/BGJ-continuation of ar data collector ;1 Mar 97
- +1 ;;4.5;Accounts Receivable;**68,96,101,120,103,153,156,170,182,203,320,340**;Mar 20, 1995;Build 9
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- START ; calculate ndb values from file 433 transactions
- +1 ; needs datebeg, dateend
- +2 ; total is total by category
- +3 ;
- +4 NEW ADMIN,BILLDA,DATE,INTEREST,PRINBAL,TRANDA,TRANTYPE,VALUE,RCNOHSIF
- +5 ;
- +6 ; no HSIF (disabled)
- SET RCNOHSIF=$$NOHSIF^RCRJRCO()
- +7 ;
- +8 ; *340 added 73 and 74
- FOR TRANTYPE=1,2,3,8,9,10,11,12,13,14,34,35,41,43,73,74
- Begin DoDot:1
- +9 SET DATE=DATEBEG-1
- +10 FOR
- SET DATE=$ORDER(^PRCA(433,"AT",TRANTYPE,DATE))
- if 'DATE!(DATE>DATEEND)
- QUIT
- Begin DoDot:2
- +11 SET TRANDA=0
- +12 FOR
- SET TRANDA=$ORDER(^PRCA(433,"AT",TRANTYPE,DATE,TRANDA))
- if 'TRANDA
- QUIT
- Begin DoDot:3
- +13 SET BILLDA=+$PIECE($GET(^PRCA(433,TRANDA,0)),"^",2)
- IF 'BILLDA
- QUIT
- +14 ; bill not linked to a site
- +15 IF '$PIECE($GET(^PRCA(430,BILLDA,0)),"^",12)
- QUIT
- +16 ;
- +17 ; get a transactions balance
- +18 SET VALUE=$$TRANBAL^RCRJRCOT(TRANDA)
- IF VALUE=""
- QUIT
- +19 SET PRINBAL=$PIECE(VALUE,"^")
- SET INTEREST=$PIECE(VALUE,"^",2)
- SET ADMIN=$PIECE(VALUE,"^",3)+$PIECE(VALUE,"^",4)+$PIECE(VALUE,"^",5)
- +20 ;
- +21 DO @TRANTYPE
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +22 QUIT
- +23 ;
- +24 ;
- 1 ; increase adjustments
- +1 ;D SETTOTAL(14,PRINBAL,0)
- +2 ;PRCA*4.5*320 Increease aging buckets by 2
- DO SETTOTAL(16,PRINBAL,0)
- +3 QUIT
- +4 ;
- +5 ;
- 2 ; payment in partial
- +1 NEW CATEGORY
- +2 ; prepayment transaction (field #20)
- +3 IF $PIECE($GET(^PRCA(433,TRANDA,5)),"^")
- Begin DoDot:1
- +4 ;D SETTOTAL(21,PRINBAL,0)
- +5 ;PRCA*4.5*320 Increease aging buckets by 2
- DO SETTOTAL(23,PRINBAL,0)
- +6 ;I INTEREST D SETTOTAL(38,INTEREST,0)
- +7 IF INTEREST
- DO SETTOTAL(40,INTEREST,0)
- +8 ;I ADMIN D SETTOTAL(39,ADMIN,0)
- +9 IF ADMIN
- DO SETTOTAL(41,ADMIN,0)
- End DoDot:1
- QUIT
- +10 ;
- +11 ; check to see if payment is rx copay and is split between
- +12 ; mccf and hsif. if the bill has been run through the
- +13 ; calculator, do it now and report the mccf split to the ndb.
- +14 ; the amount owed to mccf is in piece 3 and is returned negative
- +15 SET CATEGORY=$PIECE(^PRCA(430,BILLDA,0),"^",2)
- +16 IF 'RCNOHSIF
- IF PRINBAL
- IF (CATEGORY=22!(CATEGORY=23))
- IF '$DATA(^TMP($JOB,"RCBMILLDATA",BILLDA,TRANDA))
- Begin DoDot:1
- +17 SET %=$$BILLFUND^RCBMILLC(BILLDA)
- End DoDot:1
- +18 ;
- +19 ; changed by patch PRCA*4.5*182 to no longer separate the mccf and
- +20 ; hsif components. the entire amount is now reported to the ndb.
- +21 ;
- +22 ;. S PRINBAL=-$P($G(^TMP($J,"RCBMILLDATA",BILLDA,TRANDA)),"^",3)
- +23 ;
- +24 ; partial payments (trantype=2), full payments (trantype=34)
- +25 ;D SETTOTAL($S(TRANTYPE=2:19,1:18),PRINBAL,0)
- +26 DO SETTOTAL($SELECT(TRANTYPE=2:21,1:20),PRINBAL,0)
- +27 ;I INTEREST D SETTOTAL(38,INTEREST,0)
- +28 IF INTEREST
- DO SETTOTAL(40,INTEREST,0)
- +29 ;I ADMIN D SETTOTAL(39,ADMIN,0)
- +30 IF ADMIN
- DO SETTOTAL(41,ADMIN,0)
- +31 ;
- +32 ; irs, district counsel, dept of justice (#7)
- +33 SET %=$PIECE($GET(^PRCA(433,TRANDA,0)),"^",7)
- IF %=""
- QUIT
- +34 ;I %="IRS" D SETTOTAL(28,PRINBAL,0) Q
- +35 ;PRCA*4.5*320 Increease aging buckets by 2 (on several lines below)
- IF %="IRS"
- DO SETTOTAL(30,PRINBAL,0)
- QUIT
- +36 ;I %="DC" D SETTOTAL(31,PRINBAL,0) Q
- +37 IF %="DC"
- DO SETTOTAL(33,PRINBAL,0)
- QUIT
- +38 ;I %="DOJ" D SETTOTAL(34,PRINBAL,0) Q
- +39 IF %="DOJ"
- DO SETTOTAL(36,PRINBAL,0)
- QUIT
- +40 QUIT
- +41 ;
- +42 ;
- 3 ; refer to district counsel
- +1 ;D SETTOTAL(30,PRINBAL,0)
- +2 DO SETTOTAL(32,PRINBAL,0)
- +3 QUIT
- +4 ;
- +5 ;
- 8 ; terminate by fiscal officer
- +1 ;D WRITEOFF^RCRJRCOC(BILLDA,VALUE,$S(TRANTYPE=8:25,1:24))
- +2 DO WRITEOFF^RCRJRCOC(BILLDA,VALUE,$SELECT(TRANTYPE=8:27,1:26))
- +3 ; decrease in number of debts
- +4 ;I '$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,17)) D SETTOTAL(17,0,0)
- +5 IF '$DATA(^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,19))
- DO SETTOTAL(19,0,0)
- +6 QUIT
- +7 ;
- +8 ;
- 9 ; terminate by compromise
- +1 DO 8
- +2 QUIT
- +3 ;
- +4 ;
- 10 ; payment waived in full
- +1 ;D WRITEOFF^RCRJRCOC(BILLDA,VALUE,22)
- +2 DO WRITEOFF^RCRJRCOC(BILLDA,VALUE,24)
- +3 QUIT
- +4 ;
- +5 ;
- 11 ; payment waived in partial
- +1 ;D WRITEOFF^RCRJRCOC(BILLDA,VALUE,23)
- +2 DO WRITEOFF^RCRJRCOC(BILLDA,VALUE,25)
- +3 QUIT
- +4 ;
- +5 ;
- 12 ; admin cost / charge
- +1 ; interest/admin added
- +2 ;I INTEREST>0 D SETTOTAL(40,INTEREST,0)
- +3 IF INTEREST>0
- DO SETTOTAL(42,INTEREST,0)
- +4 ;I ADMIN>0 D SETTOTAL(41,ADMIN,0)
- +5 IF ADMIN>0
- DO SETTOTAL(43,ADMIN,0)
- +6 ; interest/admin cost exempt
- +7 ;I INTEREST<0 D SETTOTAL(42,-INTEREST,0)
- +8 IF INTEREST<0
- DO SETTOTAL(44,-INTEREST,0)
- +9 ;I ADMIN<0 D SETTOTAL(42,-ADMIN,0)
- +10 IF ADMIN<0
- DO SETTOTAL(44,-ADMIN,0)
- +11 QUIT
- +12 ;
- +13 ;
- 13 ; interest / admin charge
- +1 DO 12
- +2 QUIT
- +3 ;
- +4 ;
- 14 ; exempt interest / admin cost
- +1 ;D SETTOTAL(42,INTEREST,0)
- +2 DO SETTOTAL(44,INTEREST,0)
- +3 QUIT
- +4 ;
- +5 ;
- 34 ; payment in full
- +1 DO 2
- +2 ; decrease in number of debts
- +3 ;I '$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,17)) D SETTOTAL(17,0,0)
- +4 IF '$DATA(^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,19))
- DO SETTOTAL(19,0,0)
- +5 QUIT
- +6 ;
- +7 ;
- 35 ; decrease adjustment
- +1 NEW CONTRACT
- +2 ; contractual adjustment (field #88)
- +3 SET CONTRACT=$PIECE($GET(^PRCA(433,TRANDA,8)),"^",8)
- +4 ;I CONTRACT D WRITEOFF^RCRJRCOC(BILLDA,VALUE,20) Q
- +5 IF CONTRACT
- DO WRITEOFF^RCRJRCOC(BILLDA,VALUE,22)
- QUIT
- +6 ;D SETTOTAL(16,PRINBAL,0)
- +7 DO SETTOTAL(18,PRINBAL,0)
- +8 QUIT
- +9 ;
- +10 ;
- 41 ; refund
- +1 ;D SETTOTAL(43,PRINBAL,0)
- +2 DO SETTOTAL(45,PRINBAL,0)
- +3 QUIT
- +4 ;
- +5 ;
- 43 ; re-establishment
- +1 ;D SETTOTAL(13,PRINBAL,INTEREST+ADMIN)
- +2 DO SETTOTAL(15,PRINBAL,INTEREST+ADMIN)
- +3 QUIT
- +4 ;
- +5 ;
- 73 ; cs increase adjustment - added with *340
- +1 DO 1
- +2 QUIT
- +3 ;
- +4 ;
- 74 ; cs admin.cost charge - added with *340
- +1 DO 12
- +2 QUIT
- +3 ;
- +4 ;
- SETTOTAL(CRITER2,AMOUNT,INTEREST) ; store results
- +1 NEW RSC,TYPE
- +2 ;
- +3 ; this line of code will prevent duplicate counts if a sites cross
- +4 ; references in file 430 (actdt and asdt) are duplicated (incorrect)
- +5 ;I CRITER2<13,$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,CRITER2)) Q
- +6 IF CRITER2<15
- IF $DATA(^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,CRITER2))
- QUIT
- +7 ;
- +8 ; get a bills criteria 1,3,4,5
- +9 SET CRITERIA=$GET(^TMP($JOB,"RCRJRCOL","CRITERIA",BILLDA))
- +10 IF CRITERIA=""
- SET CRITERIA=$$CRITERIA^RCRJRCOL(BILLDA)
- SET ^TMP($JOB,"RCRJRCOL","CRITERIA",BILLDA)=CRITERIA
- +11 ;
- +12 ; store for ndb
- +13 SET $PIECE(CRITERIA,"-",2)=CRITER2
- +14 ;
- +15 ; store results for ndb
- +16 SET %=$GET(@DATASTOR)
- +17 SET $PIECE(%,"^")=$PIECE(%,"^")+1
- +18 SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+AMOUNT
- +19 SET $PIECE(%,"^",3)=$PIECE(%,"^",3)+INTEREST
- +20 SET @DATASTOR=%
- +21 ;
- +22 ; keep a count of which category (criter2) a bill is counted in
- +23 SET ^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,CRITER2)=""
- +24 SET ^TMP($JOB,"RCRJRCOL","CRIT2",CRITER2,BILLDA)=""
- +25 ;
- +26 ; pick up bills with activity which may not have been picked up as
- +27 ; a current receivable because of the wrong status date
- +28 ;I CRITER2>13,CRITER2'=17,'$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,1)),'$D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,17)) D CURRENT^RCRJRCOB(BILLDA,DATEEND,AYEAROLD)
- +29 IF CRITER2>15
- IF CRITER2'=19
- IF '$DATA(^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,1))
- IF '$DATA(^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,19))
- DO CURRENT^RCRJRCOB(BILLDA,DATEEND,AYEAROLD)
- +30 QUIT