RCRJRCOL ;WISC/RFJ-start of the ar data collector ;1 Mar 97
;;4.5;Accounts Receivable;**68,96,101,103,170,176,191,320**;Mar 20, 1995;Build 30
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;
START(PRCASITE,DATEBEG,DATEEND) ; start ar1 collector and fms data collector
N %,ACTDATE,AYEAROLD,BILLDA,CLOSED,CRITERIA,DATA0,DATASTOR,DATE,IBCNS,PREVSTAT,STAT,STRTTIME
D KILLTMP
;
; set start time
D NOW^%DTC S STRTTIME=%
;
S DATASTOR="^TMP($J,""RCRJRCOLNDB"",CRITERIA)"
;
; count new receivables
S %=$$GETNEW(DATEBEG,DATEEND,1)
;
; used to determine future payments less than a year old
S AYEAROLD=$$FMADD^XLFDT(DATEEND,365)
;
; count current receivables for period and decrease in debts
; do not look at bills not approved/finished (18,20,27,31)
S STAT=0 F S STAT=$O(^PRCA(430,"ASDT",STAT)) Q:'STAT I STAT'=18,STAT'=20,STAT'=27,STAT'=31 D
. S DATE=0,CLOSED=0
. ; do not look at bills closed before begin date
. ; count decrease number of debts, must be closed in month
. ; stat 17 (in-active) ; stat 22 (collected/closed)
. ; stat 23 (write-off) ; stat 26 (cancelled)
. ; stat 39 (cancellation) ; stat 41 (refunded)
. I ",17,22,23,26,39,41,"[(","_STAT_",") S DATE=DATEBEG-1,CLOSED=1
. F S DATE=$O(^PRCA(430,"ASDT",STAT,DATE)) Q:'DATE D
. . S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ASDT",STAT,DATE,BILLDA)) Q:'BILLDA D
. . . ; do not count bills already skipped
. . . I $D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)) Q
. . . S DATA0=$G(^PRCA(430,BILLDA,0))
. . . I '$P(DATA0,"^",12) S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
. . . ; no original amount
. . . I $P(DATA0,"^",3)="" S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
. . . ;
. . . ; do not look at bills activated after end date
. . . S ACTDATE=$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
. . . I 'ACTDATE!(ACTDATE>DATEEND) S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
. . . ;
. . . ; bill is closed before end date, decrease debt
. . . I CLOSED,DATE'>DATEEND D Q
. . . . ; if previous status was:
. . . . ; 18 (new bill), 27 (incomplete), 20 (pend approval)
. . . . ; then the bill was never counted as a new receivable
. . . . ; and should not be counted as a decrease in debts
. . . . S PREVSTAT=$P($G(^PRCA(430,BILLDA,9)),"^",6)
. . . . I PREVSTAT=18!(PREVSTAT=20)!(PREVSTAT=27) S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
. . . . ;D SETTOTAL^RCRJRCO1(17,0,0)
. . . . D SETTOTAL^RCRJRCO1(19,0,0)
. . . ;
. . . D CURRENT^RCRJRCOB(BILLDA,DATEEND,AYEAROLD)
;
; collect data from file 433
D START^RCRJRCO1
; send data to ndb and fms
D SEND^RCRJRCOR
; print summary report
D SUMMARY^RCRJRCOR
;
; compile and print bad debt report
I '$G(RCRJFBDR) D START^RCRJRBD(DATEEND)
;
KILLTMP ; kill tmp globals
K ^TMP($J,"RCRJRBD") ;stores the bad debt report
K ^TMP($J,"RCRJRCOL") ;used internally
K ^TMP($J,"RCRJRCOLNDB") ;stores the ndb data
K ^TMP($J,"RCRJROIG") ;stores the data for the oig extract
K ^TMP($J,"RCRJRCOLSV") ;stores the fms sv code sheet
K ^TMP($J,"RCRJRCOLWR") ;stores the fms wr code sheet
K ^TMP($J,"RCRJRCOLREPORT") ;stores the user report
K ^TMP($J,"RCBMILLDATA") ;stores the mccf/hsif payment split for rx
Q
;
;
GETNEW(DATEBEG,DATEEND,RCRJFSTO) ; get new receivables between two dates
; rcrjfsto is a flag which is set to 1 for the ndb rollup and it
; will store the data in tmp. If its not a 1, it will count the
; new bills and just return the count ^ amount.
N COUNT,DATE,ORIGAMT,PRINBAL
S COUNT=0,PRINBAL=0
S DATE=DATEBEG-1
F S DATE=$O(^PRCA(430,"ACTDT",DATE)) Q:'DATE!(DATE>DATEEND) D
. S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ACTDT",DATE,BILLDA)) Q:'BILLDA D
. . S ORIGAMT=$$TESTNEW(BILLDA,DATEBEG,DATEEND)
. . ; not a new receivable
. . I ORIGAMT="" S:RCRJFSTO ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
. . ; store for ndb
. . ;I RCRJFSTO D SETTOTAL^RCRJRCO1(13,ORIGAMT,0) PRCA*4.5*320 - Increase bucket by 2 for FY16 HAPE RRE (TROR aging buckets)
. . I RCRJFSTO D SETTOTAL^RCRJRCO1(15,ORIGAMT,0)
. . S COUNT=COUNT+1,PRINBAL=PRINBAL+ORIGAMT
;
Q COUNT_"^"_PRINBAL
;
;
TESTNEW(BILLDA,DATEBEG,DATEEND) ; test to see if a bill is a new receivable
; returns the principal balance if a bill is new
N DATA0,STAT
S DATA0=$G(^PRCA(430,BILLDA,0))
; no site
I '$P(DATA0,"^",12) Q ""
; bill never had an original amount (prepayments would not be
; picked up here since they do not have an original amount)
I $P(DATA0,"^",3)="" Q ""
;
S STAT=$P(DATA0,"^",8)
; no status
I 'STAT Q ""
; bill was cancelled the same month
;I STAT=26,($E($P(DATA0,"^",14),1,5)=$E(DATEBEG,1,5)) Q ""
I STAT=26&($P(DATA0,"^",14)<DATEBEG!($P(DATA0,"^",14)>DATEEND)) Q ""
; bill incomplete
I STAT=27 Q ""
; bill new
I STAT=18 Q ""
; bill pending approval
I STAT=20 Q ""
; bill returned from AR (new)
I STAT=31 Q ""
;
; yes, its a new receivable, return its original amount
Q +$P(DATA0,"^",3)
;
;
CRITERIA(BILLDA) ; find a bills criteria/category 1,3,4,5
; returns 1--3-4-5 where the number is the criteria number
; the second piece is set at settotal^rcrjrco1
;
N %,CRITER1,CRITER35,DATA0,X
S DATA0=$G(^PRCA(430,BILLDA,0))
;
; % = segment
S %=$P(DATA0,"^",21)
S CRITER1=$S(%=243:1,%=244:3,%=245:2,%=246:8,%=247:9,%=248:10,%=249:5,%=251:14,%=252:16,%=292:6,%=293:7,%=294:11,%=295:19,%=296:20,%=297:4,%=298:12,1:0)
;
; acck = accrual
I CRITER1=8,'$$ACCK^PRCAACC(BILLDA) S CRITER1=18
;
I 'CRITER1 D
. S %=$P($G(^PRCA(430.2,+$P(DATA0,"^",2),0)),"^",7)
. ; % = Category Number:
. ; 22 TORT FEASOR
. ; 18 SHARING AGREEMENTS
. ; 33 PREPAYMENT
. ; 40 ADULT DAY HEALTH CARE
. ; 41 DOMICILIARY
. ; 42 RESPITE CARE-INSTITUTIONAL
. ; 43 RESPITE CARE-NON-INSTITUTIONAL
. ; 44 GERIATRIC EVAL-INSTITUTIONAL
. ; 45 GERIATRIC EVAL-NON-INSTITUTION
. ; 46 NURSING HOME CARE-LTC
. S CRITER1=$S(%=22:15,%=18:17,%=33:13,%=40:1,%=41:20,%=42:20,%=43:1,%=44:20,%=45:1,%=46:20,1:18)
;
; determine criteria 3,4,5
S CRITER35="0-0-0"
I CRITER1>3,CRITER1<8 D
. S %=$TR($$CRIT^IBRFN2(BILLDA),"^","-") ;integration agreement 1182
. I %=-1 S CRITER35="3-1-4" Q
. I $P(%,"-")="" S $P(%,"-")=3
. I $P(%,"-",2)="" S $P(%,"-",2)=1
. I $P(%,"-",3)="" S $P(%,"-",3)=4
. S CRITER35=%
;
Q CRITER1_"--"_CRITER35
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRJRCOL 6664 printed Oct 16, 2024@17:49:02 Page 2
RCRJRCOL ;WISC/RFJ-start of the ar data collector ;1 Mar 97
+1 ;;4.5;Accounts Receivable;**68,96,101,103,170,176,191,320**;Mar 20, 1995;Build 30
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
START(PRCASITE,DATEBEG,DATEEND) ; start ar1 collector and fms data collector
+1 NEW %,ACTDATE,AYEAROLD,BILLDA,CLOSED,CRITERIA,DATA0,DATASTOR,DATE,IBCNS,PREVSTAT,STAT,STRTTIME
+2 DO KILLTMP
+3 ;
+4 ; set start time
+5 DO NOW^%DTC
SET STRTTIME=%
+6 ;
+7 SET DATASTOR="^TMP($J,""RCRJRCOLNDB"",CRITERIA)"
+8 ;
+9 ; count new receivables
+10 SET %=$$GETNEW(DATEBEG,DATEEND,1)
+11 ;
+12 ; used to determine future payments less than a year old
+13 SET AYEAROLD=$$FMADD^XLFDT(DATEEND,365)
+14 ;
+15 ; count current receivables for period and decrease in debts
+16 ; do not look at bills not approved/finished (18,20,27,31)
+17 SET STAT=0
FOR
SET STAT=$ORDER(^PRCA(430,"ASDT",STAT))
if 'STAT
QUIT
IF STAT'=18
IF STAT'=20
IF STAT'=27
IF STAT'=31
Begin DoDot:1
+18 SET DATE=0
SET CLOSED=0
+19 ; do not look at bills closed before begin date
+20 ; count decrease number of debts, must be closed in month
+21 ; stat 17 (in-active) ; stat 22 (collected/closed)
+22 ; stat 23 (write-off) ; stat 26 (cancelled)
+23 ; stat 39 (cancellation) ; stat 41 (refunded)
+24 IF ",17,22,23,26,39,41,"[(","_STAT_",")
SET DATE=DATEBEG-1
SET CLOSED=1
+25 FOR
SET DATE=$ORDER(^PRCA(430,"ASDT",STAT,DATE))
if 'DATE
QUIT
Begin DoDot:2
+26 SET BILLDA=0
FOR
SET BILLDA=$ORDER(^PRCA(430,"ASDT",STAT,DATE,BILLDA))
if 'BILLDA
QUIT
Begin DoDot:3
+27 ; do not count bills already skipped
+28 IF $DATA(^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,0))
QUIT
+29 SET DATA0=$GET(^PRCA(430,BILLDA,0))
+30 IF '$PIECE(DATA0,"^",12)
SET ^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,0)=""
QUIT
+31 ; no original amount
+32 IF $PIECE(DATA0,"^",3)=""
SET ^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,0)=""
QUIT
+33 ;
+34 ; do not look at bills activated after end date
+35 SET ACTDATE=$PIECE($PIECE($GET(^PRCA(430,BILLDA,6)),"^",21),".")
+36 IF 'ACTDATE!(ACTDATE>DATEEND)
SET ^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,0)=""
QUIT
+37 ;
+38 ; bill is closed before end date, decrease debt
+39 IF CLOSED
IF DATE'>DATEEND
Begin DoDot:4
+40 ; if previous status was:
+41 ; 18 (new bill), 27 (incomplete), 20 (pend approval)
+42 ; then the bill was never counted as a new receivable
+43 ; and should not be counted as a decrease in debts
+44 SET PREVSTAT=$PIECE($GET(^PRCA(430,BILLDA,9)),"^",6)
+45 IF PREVSTAT=18!(PREVSTAT=20)!(PREVSTAT=27)
SET ^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,0)=""
QUIT
+46 ;D SETTOTAL^RCRJRCO1(17,0,0)
+47 DO SETTOTAL^RCRJRCO1(19,0,0)
End DoDot:4
QUIT
+48 ;
+49 DO CURRENT^RCRJRCOB(BILLDA,DATEEND,AYEAROLD)
End DoDot:3
End DoDot:2
End DoDot:1
+50 ;
+51 ; collect data from file 433
+52 DO START^RCRJRCO1
+53 ; send data to ndb and fms
+54 DO SEND^RCRJRCOR
+55 ; print summary report
+56 DO SUMMARY^RCRJRCOR
+57 ;
+58 ; compile and print bad debt report
+59 IF '$GET(RCRJFBDR)
DO START^RCRJRBD(DATEEND)
+60 ;
KILLTMP ; kill tmp globals
+1 ;stores the bad debt report
KILL ^TMP($JOB,"RCRJRBD")
+2 ;used internally
KILL ^TMP($JOB,"RCRJRCOL")
+3 ;stores the ndb data
KILL ^TMP($JOB,"RCRJRCOLNDB")
+4 ;stores the data for the oig extract
KILL ^TMP($JOB,"RCRJROIG")
+5 ;stores the fms sv code sheet
KILL ^TMP($JOB,"RCRJRCOLSV")
+6 ;stores the fms wr code sheet
KILL ^TMP($JOB,"RCRJRCOLWR")
+7 ;stores the user report
KILL ^TMP($JOB,"RCRJRCOLREPORT")
+8 ;stores the mccf/hsif payment split for rx
KILL ^TMP($JOB,"RCBMILLDATA")
+9 QUIT
+10 ;
+11 ;
GETNEW(DATEBEG,DATEEND,RCRJFSTO) ; get new receivables between two dates
+1 ; rcrjfsto is a flag which is set to 1 for the ndb rollup and it
+2 ; will store the data in tmp. If its not a 1, it will count the
+3 ; new bills and just return the count ^ amount.
+4 NEW COUNT,DATE,ORIGAMT,PRINBAL
+5 SET COUNT=0
SET PRINBAL=0
+6 SET DATE=DATEBEG-1
+7 FOR
SET DATE=$ORDER(^PRCA(430,"ACTDT",DATE))
if 'DATE!(DATE>DATEEND)
QUIT
Begin DoDot:1
+8 SET BILLDA=0
FOR
SET BILLDA=$ORDER(^PRCA(430,"ACTDT",DATE,BILLDA))
if 'BILLDA
QUIT
Begin DoDot:2
+9 SET ORIGAMT=$$TESTNEW(BILLDA,DATEBEG,DATEEND)
+10 ; not a new receivable
+11 IF ORIGAMT=""
if RCRJFSTO
SET ^TMP($JOB,"RCRJRCOL","COUNT",BILLDA,0)=""
QUIT
+12 ; store for ndb
+13 ;I RCRJFSTO D SETTOTAL^RCRJRCO1(13,ORIGAMT,0) PRCA*4.5*320 - Increase bucket by 2 for FY16 HAPE RRE (TROR aging buckets)
+14 IF RCRJFSTO
DO SETTOTAL^RCRJRCO1(15,ORIGAMT,0)
+15 SET COUNT=COUNT+1
SET PRINBAL=PRINBAL+ORIGAMT
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT COUNT_"^"_PRINBAL
+18 ;
+19 ;
TESTNEW(BILLDA,DATEBEG,DATEEND) ; test to see if a bill is a new receivable
+1 ; returns the principal balance if a bill is new
+2 NEW DATA0,STAT
+3 SET DATA0=$GET(^PRCA(430,BILLDA,0))
+4 ; no site
+5 IF '$PIECE(DATA0,"^",12)
QUIT ""
+6 ; bill never had an original amount (prepayments would not be
+7 ; picked up here since they do not have an original amount)
+8 IF $PIECE(DATA0,"^",3)=""
QUIT ""
+9 ;
+10 SET STAT=$PIECE(DATA0,"^",8)
+11 ; no status
+12 IF 'STAT
QUIT ""
+13 ; bill was cancelled the same month
+14 ;I STAT=26,($E($P(DATA0,"^",14),1,5)=$E(DATEBEG,1,5)) Q ""
+15 IF STAT=26&($PIECE(DATA0,"^",14)<DATEBEG!($PIECE(DATA0,"^",14)>DATEEND))
QUIT ""
+16 ; bill incomplete
+17 IF STAT=27
QUIT ""
+18 ; bill new
+19 IF STAT=18
QUIT ""
+20 ; bill pending approval
+21 IF STAT=20
QUIT ""
+22 ; bill returned from AR (new)
+23 IF STAT=31
QUIT ""
+24 ;
+25 ; yes, its a new receivable, return its original amount
+26 QUIT +$PIECE(DATA0,"^",3)
+27 ;
+28 ;
CRITERIA(BILLDA) ; find a bills criteria/category 1,3,4,5
+1 ; returns 1--3-4-5 where the number is the criteria number
+2 ; the second piece is set at settotal^rcrjrco1
+3 ;
+4 NEW %,CRITER1,CRITER35,DATA0,X
+5 SET DATA0=$GET(^PRCA(430,BILLDA,0))
+6 ;
+7 ; % = segment
+8 SET %=$PIECE(DATA0,"^",21)
+9 SET CRITER1=$SELECT(%=243:1,%=244:3,%=245:2,%=246:8,%=247:9,%=248:10,%=249:5,%=251:14,%=252:16,%=292:6,%=293:7,%=294:11,%=295:19,%=296:20,%=297:4,%=298:12,1:0)
+10 ;
+11 ; acck = accrual
+12 IF CRITER1=8
IF '$$ACCK^PRCAACC(BILLDA)
SET CRITER1=18
+13 ;
+14 IF 'CRITER1
Begin DoDot:1
+15 SET %=$PIECE($GET(^PRCA(430.2,+$PIECE(DATA0,"^",2),0)),"^",7)
+16 ; % = Category Number:
+17 ; 22 TORT FEASOR
+18 ; 18 SHARING AGREEMENTS
+19 ; 33 PREPAYMENT
+20 ; 40 ADULT DAY HEALTH CARE
+21 ; 41 DOMICILIARY
+22 ; 42 RESPITE CARE-INSTITUTIONAL
+23 ; 43 RESPITE CARE-NON-INSTITUTIONAL
+24 ; 44 GERIATRIC EVAL-INSTITUTIONAL
+25 ; 45 GERIATRIC EVAL-NON-INSTITUTION
+26 ; 46 NURSING HOME CARE-LTC
+27 SET CRITER1=$SELECT(%=22:15,%=18:17,%=33:13,%=40:1,%=41:20,%=42:20,%=43:1,%=44:20,%=45:1,%=46:20,1:18)
End DoDot:1
+28 ;
+29 ; determine criteria 3,4,5
+30 SET CRITER35="0-0-0"
+31 IF CRITER1>3
IF CRITER1<8
Begin DoDot:1
+32 ;integration agreement 1182
SET %=$TRANSLATE($$CRIT^IBRFN2(BILLDA),"^","-")
+33 IF %=-1
SET CRITER35="3-1-4"
QUIT
+34 IF $PIECE(%,"-")=""
SET $PIECE(%,"-")=3
+35 IF $PIECE(%,"-",2)=""
SET $PIECE(%,"-",2)=1
+36 IF $PIECE(%,"-",3)=""
SET $PIECE(%,"-",3)=4
+37 SET CRITER35=%
End DoDot:1
+38 ;
+39 QUIT CRITER1_"--"_CRITER35
