RCRJRBD ;WISC/RFJ,TJK-bad debt extractor and report ;10/18/10 9:00am
;;4.5;Accounts Receivable;**101,139,170,193,203,215,220,138,239,273,282,310,315,340,346,338,351,360**;Mar 20, 1995;Build 10
;;Per VA Directive 6402, this routine should not be modified.
; IA 4385 for calls to $$MRATYPE^IBCEMU2 and $$MRADTACT^IBCEMU2
Q
;
;PRCA*4.5*346 Modify SGL compile code 133.N3 to 133N.3 to
; ensure line item 528713 - 133N dollars are accrued
;
;
START(DATEEND) ; run bad debt report
; the DATEEND is the last day of the month being run
; from the routine RCRJRCOL which is the data extractor. The
; current receivable dollars is stored in ^TMP($J,"RCRJRBD",SGL)
; where SGL is the standard general ledger 1319, 1338, or 1339.
;
N ACTDATE,ACTUALCA,ACTUALWO,BEGDATE,BILLDA,CATEGORY
N COLLECT,CONTRACT,DR,ENDDATE,FUND,PAY,PAYMENT,PRIN,PRINCPAL
N RCRJFMM,RCRJDATE,SGL,TRANDA,TRANDATE,TRANTYPE,VALUE,WRITEOFF
N RCPRIN,RCTOMCCF,RCVALUE,RSC,MRATYPE,ARACTDT
;
; lock the bad debt file for storing data, lock cannot fail
; this lock can be used to monitor if the report is running
F L +^RC(348.1):$S($G(DILOCKTM)>5:DILOCKTM,1:5) Q:$T
;
; calculate the base percentages from past data
; example: DATEEND=2980331 => BEGDATE=2970300
; => ENDDATE=2980229
; add one day to ending date to go to next month
S BEGDATE=($E(DATEEND,1,3)-1)_$E(DATEEND,4,5)_"00"
S ENDDATE=($$FMADD^XLFDT($E(DATEEND,1,5)_"00",-1))+1
; loop bills activated between these dates
S ACTDATE=BEGDATE
F S ACTDATE=$O(^PRCA(430,"ACTDT",ACTDATE)) Q:'ACTDATE!(ACTDATE>ENDDATE) D
. S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ACTDT",ACTDATE,BILLDA)) Q:'BILLDA D
. . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
. . ; do not look at prepayments
. . I 'CATEGORY!(CATEGORY=26) Q
. . ;
. . ; only look at bills with a 0 principal balance
. . I $P($G(^PRCA(430,BILLDA,7)),"^") Q
. . ;
. . ; only report fund 528701,03,04,11 and 4032/528709 bills
. . ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
. . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
. . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
. . ;end PRCA*4.5*338
. . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
. . ;
. . ; determine MRA type of bill, given bill# and bill active date
. . ; DBIA #4385 activated on 31-Mar-2004
. . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ACTDATE)
. . ;
. . ; derive standard general ledger (SGL) from cat/fund/MRA type
. . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
. . ;
. . ; determine the original amount of the bill (add increase
. . ; adjustments below)
. . S PRIN=$P($G(^PRCA(430,BILLDA,0)),"^",3)
. . S PAY=0
. . ;
. . ; get the $ transations for bills
. . S TRANDA=0
. . F S TRANDA=$O(^PRCA(433,"C",BILLDA,TRANDA)) Q:'TRANDA D
. . . S TRANTYPE=$P($G(^PRCA(433,TRANDA,1)),"^",2)
. . . I "^1^73^2^34^43^"'[("^"_TRANTYPE_"^") Q ; *340 added 73
. . . S VALUE=$$TRANBAL^RCRJRCOT(TRANDA) I VALUE="" Q
. . . ; increase adjustments or re-establish
. . . I TRANTYPE=1!(TRANTYPE=73)!(TRANTYPE=43) S PRIN=PRIN+$P(VALUE,"^") Q ; *340 added 73
. . . ; payments
. . . I TRANTYPE=2!(TRANTYPE=34) S PAY=PAY+$P(VALUE,"^") Q
. . ;
. . ; payment cannot be greater than principle
. . I PAY>PRIN S PAY=PRIN
. . ;
. . ; store the data
. . S PRINCPAL(SGL)=$G(PRINCPAL(SGL))+PRIN
. . S PAYMENT(SGL)=$G(PAYMENT(SGL))+PAY
. . ;
;
; calculate the writeoffs from 2/0/98
; 2/0/98 is when fms cleared out actual writeoffs and contract adj
K ^XTMP("PRCABDET")
S ^XTMP("PRCABDET",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^BAD DEBT REPORT AUDIT"
F TRANTYPE=8,9,10,11,35 D
. S TRANDATE=2980200
. ; do not pick up transactions after the end date
. F S TRANDATE=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE)) Q:'TRANDATE!($P(TRANDATE,".")>DATEEND) D
. . S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE,TRANDA)) Q:'TRANDA D
. . . ; do not look at decrease adj which are not contract adj
. . . I TRANTYPE=35,'$P($G(^PRCA(433,TRANDA,8)),"^",8) Q
. . . ;
. . . S BILLDA=$P($G(^PRCA(433,TRANDA,0)),"^",2)
. . . I 'BILLDA Q
. . . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
. . . ; do not look at prepayments
. . . I 'CATEGORY!(CATEGORY=26) Q
. . . ;
. . . ; only report fund 528701,03,04,11 and 4032/528709 (ltc) bills
. . . ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
. . . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
. . . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
. . . ;end PRCA*4.5*338
. . . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
. . . ;
. . . ; get bill active date
. . . S ARACTDT=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
. . . ; determine MRA type of bill, given bill# and bill active date
. . . ; DBIA #4385 activated on 31-Mar-2004
. . . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT)
. . . ;
. . . ; derive standard general ledger (SGL) from cat/fund/MRA type
. . . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
. . . ;
. . . ; get the principal transaction value
. . . S RCVALUE=+$P($$TRANBAL^RCRJRCOT(TRANDA),"^")
. . . ; temp variable for value (used below)
. . . S RCPRIN=RCVALUE
. . . ;
. . . ; add actual writeoff amount for fiscal year
. . . I TRANTYPE'=35 S ACTUALWO(SGL)=$G(ACTUALWO(SGL))+RCVALUE
. . . ; add actual contract adjustments for fiscal year
. . . I TRANTYPE=35 S ACTUALCA(SGL)=$G(ACTUALCA(SGL))+RCVALUE
. . . ;PRCA*4.5*338 - retrieve RSC from Bill. If no RSC in BILL, calculate it.
. . . S RSC=$$GET1^DIQ(430,BILLDA_",",255.1) ;Check for accrued RSC
. . . S:RSC="" RSC=$$GET1^DIQ(430,BILLDA_",",255) ;if no accrued RSC, check for non-accrued.
. . . S:RSC="" RSC=$$CALCRSC^RCXFMSUR(BILLDA) ;if neither present, calculate
. . . ;end PRCA*4.5*338
. . . S ^XTMP("PRCABDET",BILLDA,CATEGORY,FUND,RSC,SGL,TRANDA,TRANDATE,TRANTYPE,RCPRIN,RCVALUE,0,0)=""
;
; remove all the entries from the bad debt file
D DELETALL
;
; calculate percentages and store them
; PRCA*4.5*338 - corrected 133.N3 to 133N.3, also added 1319.7, 1319.8, 1319.9
F SGL=1319,1319.2,1319.3,1319.4,1319.5,1319.6,1319.7,1319.8,1319.9,1338,1338.2,1338.3,1339,1339.1,"133N","133N.2","133N.3" D ;PRCA*4.5*346
. ; collection %
. S COLLECT=0 I $G(PRINCPAL(SGL)) S COLLECT=$J($G(PAYMENT(SGL))/PRINCPAL(SGL)*100,0,2)
. ; patch PRCA*4.5*138: for the first year from when MRA is activated at a site, there is no collection
. ; history for post-MRA non-Medicare bills(SGL 133N). So, to calculate the percentage for SGL 133N, the
. ; payment and the principal for SGL 1339 are used in the first year.
. ; override the collection value for SGL=133N for the first year from MRA activation.
. ;; Re-evaluate the calc. of the percentage for 133N as well as 1339.
. ;;I SGL="133N",$G(PRINCIPAL(1339)) D ;
. ;;. N X1,X2,X,%Y
. ;;. ; X2=MRA Activation Date, X1=Today, X=diff in days, %Y=0 invalid dates
. ;;. ; DBIA #4385 activated on 31-Mar-2004
. ;;. S X2=$$MRADTACT^IBCEMU2,X1=$$DT^XLFDT D ^%DTC
. ;;. I %Y,X'>364.25 S COLLECT=$J($G(PAYMENT(1339))/PRINCPAL(1339)*100,0,2)
. S DR=".02////"_+COLLECT_";"
. ;
. ; current month receivable (this is built in the routine
. ; RCRJRCO1 and is stored in ^TMP($J,"RCRJRBD",SGL))
. S DR=DR_".07////"_+$G(^TMP($J,"RCRJRBD",SGL))_";"
. ;
. ; calculate allowance estimate for 1319 and 1338
. ; .08 allowance estimate = (writeoff % * current receivables)
. ; .09 actual writeoffs fytd
. I SGL=1319!(SGL=1319.2)!(SGL=1319.3)!(SGL=1319.4)!(SGL=1319.5)!(SGL=1319.6)!(SGL=1319.7)!(SGL=1319.8)!(SGL=1319.9)!(SGL=1338)!(SGL=1338.2)!(SGL=1338.3) D
. . S WRITEOFF=100-COLLECT
. . S DR=DR_".03////"_WRITEOFF_";"
. . S DR=DR_".08////"_$J((WRITEOFF/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
. . S DR=DR_".09////"_+$G(ACTUALWO(SGL))_";"
. ; calculate allowance estimate for 1339
. ; .08 allowance estimate = (contract % * current receivables)
. ; .09 actual contract adjustments fytd
. I SGL=1339!(SGL=1339.1)!(SGL="133N")!(SGL="133N.2")!(SGL="133N.3") D
. . S CONTRACT=100-COLLECT
. . S DR=DR_".04////"_CONTRACT_";"
. . S DR=DR_".08////"_$J((CONTRACT/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
. . S DR=DR_".09////"_+$G(ACTUALCA(SGL))_";"
. ;
. ; set changed locally flag to no
. S DR=DR_".1////0;"
. D STORE(SGL,DR)
;
L -^RC(348.1)
;
; ; put the report in a mail message (rcrjfmm=1)
; S RCRJFMM=1
; S RCRJDATE=DATEEND
; D DQ^RCRJRBDR
;
; transmit the allowances to FMS, and then generate the report.
D BADDEBT^RCXFMSSV(DATEEND)
Q
;
;
STORE(SGL,DR) ; store data for Standard Ledger Account
N D0,DA,DD,DI,DIC,DIE,DINUM,DO,DQ,X,Y
S DIC="^RC(348.1,",DIC(0)="L",X=SGL,DIC("DR")=DR
D FILE^DICN
Q
;
;
DELETALL ; delete all the entries from the bad debt file
N %,DA,DIC,DIK,X,Y
S DIK="^RC(348.1,"
S DA=0 F S DA=$O(^RC(348.1,DA)) Q:'DA D ^DIK
Q
;
;
WD3() ; return the third work day of the month
N J,P,V,X
S J=0 F P=$E(DT,1,5)_"01":1 S V=$$DOW^XLFDT(P,1) I V,V<6,'$D(^HOLIDAY("B",P)) S J=J+1 Q:J=3
S X=+$E(P,6,7)
Q X
;
;
PREVMONT(FORDATE) ; return the previous month's date
N PREVDATE
S PREVDATE=$E(FORDATE,1,5)-1
I $E(PREVDATE,4,5)="00" S PREVDATE=($E(PREVDATE,1,3)-1)_12
Q PREVDATE_"00"
;
; derive standard general ledger (SGL) from category and fund
SGL(CATEGORY,FUND) ;
I $G(FUND)=528709 Q 1319.2 ;new long term care fund
I $E($G(FUND),1,4)=4032 Q 1319.2 ; breakout long term care as a subset
I $G(FUND)=528711&(CAT=6)!(CAT=7) Q 1319.5 ; breakout pharmacy
I $G(FUND)=528711&(CAT=9) Q "133N.2" ; pharmacy reimburs health ins
I $G(FUND)=528711&(CAT=10) Q 1338.2 ; pharmacy tort feasor
I CATEGORY=8 Q 1339 ; crime or per. vio.
I CATEGORY=9 Q 1339 ; reimbursable health insurance
I CATEGORY=46 Q 1339 ; EMER/HUMAN REIMB INS ;315
I CATEGORY=10 Q 1338 ; tort feasor
I CATEGORY=21 Q 1339 ; medicare
I CATEGORY=45 Q 1339.1 ; Fee Basis
Q 1319
;
;
BDRSGL(CAT,FUND,MRATYPE) ; Calculate SGLs for the BDR process
;PRCA*4.5*310/DRF Added fund 528713, Non-VA Reimbursable Insurance
;
; This API will be used by both the ARDC (routine RCRJRCOC)
; and the BDR estimate calculator to associate receivables
; with the correct standard general ledger account (SGL).
; The following table will be implemented:
;
; Receivable Type (Category) Fund SGL
;==================================================
; Medical Care Co-payments 528703 1319
; (plus Inelig, Emerg./Hum. rec.)
; Long Term Care Co-payments 528709 1319.2
; Medication Co-payments 528701 1319.3
; Crimes of Personal Violence (8), 528704 1319.4
; Medicare (21), No-Fault Auto
; (7), Workman's Comp (6)
; Tort Feasor (10) 528704 1338
; RHI (9), pre-MRA 528704 1339
; RHI (9), post-MRA, MRA rec. 528704 133H
; RHI (9), post-MRA, non-MRA rec. 528704 133N
; Non-VA Tort Feasor 528713 1338.3
; Non-VA RHI (45), pre-MRA 528713 1339.1
; Non-VA RHI (45), post-MRA, MRA rec. 528713 133H.2
; Non-VA RHI (45), post-MRA, non-MRA rec. 528713 133N.3
; Non-VA No-Fault Auto, Workman's Comp (6) 528713 1319.6
; Inpat./Outpat./Urgent Care Community 528714 1319.7
; Care copayments
; RX Community Care copayments 528714 1319.8
; LTC Community Care copayments 528714 1319.9
; Pharmacy No Fault Auto(7), 528711 1319.5
; Pharmacy Workman's Comp(6)
; Pharmacy RHI, non MRA (9) 528711 133N.2
; Pharmacy Tort Feasor (10) 528711 1338.2
;
; Input: CAT -- Pointer to the receivable category in file 430.2
; FUND -- Receivable fund calculated by routine RCXFMSUF
; MRATYPE -- Indicator of an MRA (2) or non-MRA (3) receivable
;
;
I $G(FUND)=528709 Q 1319.2
I $E($G(FUND),1,4)=4032 Q 1319.2
I $G(FUND)=528701 Q 1319.3
I $G(FUND)=528711&((CAT=6)!(CAT=7)) Q 1319.5
I $G(FUND)=528711&(CAT=9) Q "133N.2"
I $G(FUND)=528711&(CAT=10) Q 1338.2
;PRCA*4.5*338 - Add new Community Care Categories
; THIRD PARTY =528713 new code begins
I $G(FUND)=528713&(CAT=10!(CAT=53)!(CAT=56)!(CAT=59)) Q 1338.3 ;patch 338 Add Comm Care Tort Feasor
I $G(FUND)=528713&(CAT=8!(CAT=21)!(CAT=6)!(CAT=7)!(CAT=52)!(CAT=54)!(CAT=55)!(CAT=57)!(CAT=59)!(CAT=60)) Q 1319.6 ;patch 338 Added Comm Care No Fault and Workers Comp
I ((CAT>47)&(CAT<52)) Q $S(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1) ;patch 338 Comm Care Reimb ins types.
; FIRST PARTY = 528714 - Community Care Copays
I $G(FUND)=528714&(CAT=61!(CAT=81)!(CAT=63)!(CAT=82)!(CAT=65)!(CAT=83)!(CAT=67)!(CAT=84)!(CAT=85)) Q 1319.7 ;INP/OPT copays
I $G(FUND)=528714&(CAT=62!(CAT=64)!(CAT=66)!(CAT=68)) Q 1319.8 ;rx copays
I $G(FUND)=528714&(CAT>68)&(CAT<75) Q 1319.9 ;LTC copays
;end PRCA*4.5*338
I CAT=8!(CAT=21)!(CAT=7)!(CAT=6) Q 1319.4
I CAT=10 Q 1338
I CAT=9 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339)
I CAT=46 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339) ;315
I CAT=45 Q $S(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1)
Q 1319
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRJRBD 13401 printed Oct 16, 2024@17:48:54 Page 2
RCRJRBD ;WISC/RFJ,TJK-bad debt extractor and report ;10/18/10 9:00am
+1 ;;4.5;Accounts Receivable;**101,139,170,193,203,215,220,138,239,273,282,310,315,340,346,338,351,360**;Mar 20, 1995;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; IA 4385 for calls to $$MRATYPE^IBCEMU2 and $$MRADTACT^IBCEMU2
+4 QUIT
+5 ;
+6 ;PRCA*4.5*346 Modify SGL compile code 133.N3 to 133N.3 to
+7 ; ensure line item 528713 - 133N dollars are accrued
+8 ;
+9 ;
START(DATEEND) ; run bad debt report
+1 ; the DATEEND is the last day of the month being run
+2 ; from the routine RCRJRCOL which is the data extractor. The
+3 ; current receivable dollars is stored in ^TMP($J,"RCRJRBD",SGL)
+4 ; where SGL is the standard general ledger 1319, 1338, or 1339.
+5 ;
+6 NEW ACTDATE,ACTUALCA,ACTUALWO,BEGDATE,BILLDA,CATEGORY
+7 NEW COLLECT,CONTRACT,DR,ENDDATE,FUND,PAY,PAYMENT,PRIN,PRINCPAL
+8 NEW RCRJFMM,RCRJDATE,SGL,TRANDA,TRANDATE,TRANTYPE,VALUE,WRITEOFF
+9 NEW RCPRIN,RCTOMCCF,RCVALUE,RSC,MRATYPE,ARACTDT
+10 ;
+11 ; lock the bad debt file for storing data, lock cannot fail
+12 ; this lock can be used to monitor if the report is running
+13 FOR
LOCK +^RC(348.1):$SELECT($GET(DILOCKTM)>5:DILOCKTM,1:5)
if $TEST
QUIT
+14 ;
+15 ; calculate the base percentages from past data
+16 ; example: DATEEND=2980331 => BEGDATE=2970300
+17 ; => ENDDATE=2980229
+18 ; add one day to ending date to go to next month
+19 SET BEGDATE=($EXTRACT(DATEEND,1,3)-1)_$EXTRACT(DATEEND,4,5)_"00"
+20 SET ENDDATE=($$FMADD^XLFDT($EXTRACT(DATEEND,1,5)_"00",-1))+1
+21 ; loop bills activated between these dates
+22 SET ACTDATE=BEGDATE
+23 FOR
SET ACTDATE=$ORDER(^PRCA(430,"ACTDT",ACTDATE))
if 'ACTDATE!(ACTDATE>ENDDATE)
QUIT
Begin DoDot:1
+24 SET BILLDA=0
FOR
SET BILLDA=$ORDER(^PRCA(430,"ACTDT",ACTDATE,BILLDA))
if 'BILLDA
QUIT
Begin DoDot:2
+25 SET CATEGORY=+$PIECE($GET(^PRCA(430,BILLDA,0)),"^",2)
+26 ; do not look at prepayments
+27 IF 'CATEGORY!(CATEGORY=26)
QUIT
+28 ;
+29 ; only look at bills with a 0 principal balance
+30 IF $PIECE($GET(^PRCA(430,BILLDA,7)),"^")
QUIT
+31 ;
+32 ; only report fund 528701,03,04,11 and 4032/528709 bills
+33 ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
+34 SET FUND=$$GET1^DIQ(430,BILLDA_",",203)
+35 IF FUND=""
SET FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
+36 ;end PRCA*4.5*338
+37 IF '$$PTACCT^PRCAACC(FUND)
IF $EXTRACT(FUND,1,4)'=4032
QUIT
+38 ;
+39 ; determine MRA type of bill, given bill# and bill active date
+40 ; DBIA #4385 activated on 31-Mar-2004
+41 SET MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ACTDATE)
+42 ;
+43 ; derive standard general ledger (SGL) from cat/fund/MRA type
+44 SET SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
+45 ;
+46 ; determine the original amount of the bill (add increase
+47 ; adjustments below)
+48 SET PRIN=$PIECE($GET(^PRCA(430,BILLDA,0)),"^",3)
+49 SET PAY=0
+50 ;
+51 ; get the $ transations for bills
+52 SET TRANDA=0
+53 FOR
SET TRANDA=$ORDER(^PRCA(433,"C",BILLDA,TRANDA))
if 'TRANDA
QUIT
Begin DoDot:3
+54 SET TRANTYPE=$PIECE($GET(^PRCA(433,TRANDA,1)),"^",2)
+55 ; *340 added 73
IF "^1^73^2^34^43^"'[("^"_TRANTYPE_"^")
QUIT
+56 SET VALUE=$$TRANBAL^RCRJRCOT(TRANDA)
IF VALUE=""
QUIT
+57 ; increase adjustments or re-establish
+58 ; *340 added 73
IF TRANTYPE=1!(TRANTYPE=73)!(TRANTYPE=43)
SET PRIN=PRIN+$PIECE(VALUE,"^")
QUIT
+59 ; payments
+60 IF TRANTYPE=2!(TRANTYPE=34)
SET PAY=PAY+$PIECE(VALUE,"^")
QUIT
End DoDot:3
+61 ;
+62 ; payment cannot be greater than principle
+63 IF PAY>PRIN
SET PAY=PRIN
+64 ;
+65 ; store the data
+66 SET PRINCPAL(SGL)=$GET(PRINCPAL(SGL))+PRIN
+67 SET PAYMENT(SGL)=$GET(PAYMENT(SGL))+PAY
+68 ;
End DoDot:2
End DoDot:1
+69 ;
+70 ; calculate the writeoffs from 2/0/98
+71 ; 2/0/98 is when fms cleared out actual writeoffs and contract adj
+72 KILL ^XTMP("PRCABDET")
+73 SET ^XTMP("PRCABDET",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^BAD DEBT REPORT AUDIT"
+74 FOR TRANTYPE=8,9,10,11,35
Begin DoDot:1
+75 SET TRANDATE=2980200
+76 ; do not pick up transactions after the end date
+77 FOR
SET TRANDATE=$ORDER(^PRCA(433,"AT",TRANTYPE,TRANDATE))
if 'TRANDATE!($PIECE(TRANDATE,".")>DATEEND)
QUIT
Begin DoDot:2
+78 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^PRCA(433,"AT",TRANTYPE,TRANDATE,TRANDA))
if 'TRANDA
QUIT
Begin DoDot:3
+79 ; do not look at decrease adj which are not contract adj
+80 IF TRANTYPE=35
IF '$PIECE($GET(^PRCA(433,TRANDA,8)),"^",8)
QUIT
+81 ;
+82 SET BILLDA=$PIECE($GET(^PRCA(433,TRANDA,0)),"^",2)
+83 IF 'BILLDA
QUIT
+84 SET CATEGORY=+$PIECE($GET(^PRCA(430,BILLDA,0)),"^",2)
+85 ; do not look at prepayments
+86 IF 'CATEGORY!(CATEGORY=26)
QUIT
+87 ;
+88 ; only report fund 528701,03,04,11 and 4032/528709 (ltc) bills
+89 ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
+90 SET FUND=$$GET1^DIQ(430,BILLDA_",",203)
+91 IF FUND=""
SET FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
+92 ;end PRCA*4.5*338
+93 IF '$$PTACCT^PRCAACC(FUND)
IF $EXTRACT(FUND,1,4)'=4032
QUIT
+94 ;
+95 ; get bill active date
+96 SET ARACTDT=+$PIECE($PIECE($GET(^PRCA(430,BILLDA,6)),"^",21),".")
+97 ; determine MRA type of bill, given bill# and bill active date
+98 ; DBIA #4385 activated on 31-Mar-2004
+99 SET MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT)
+100 ;
+101 ; derive standard general ledger (SGL) from cat/fund/MRA type
+102 SET SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
+103 ;
+104 ; get the principal transaction value
+105 SET RCVALUE=+$PIECE($$TRANBAL^RCRJRCOT(TRANDA),"^")
+106 ; temp variable for value (used below)
+107 SET RCPRIN=RCVALUE
+108 ;
+109 ; add actual writeoff amount for fiscal year
+110 IF TRANTYPE'=35
SET ACTUALWO(SGL)=$GET(ACTUALWO(SGL))+RCVALUE
+111 ; add actual contract adjustments for fiscal year
+112 IF TRANTYPE=35
SET ACTUALCA(SGL)=$GET(ACTUALCA(SGL))+RCVALUE
+113 ;PRCA*4.5*338 - retrieve RSC from Bill. If no RSC in BILL, calculate it.
+114 ;Check for accrued RSC
SET RSC=$$GET1^DIQ(430,BILLDA_",",255.1)
+115 ;if no accrued RSC, check for non-accrued.
if RSC=""
SET RSC=$$GET1^DIQ(430,BILLDA_",",255)
+116 ;if neither present, calculate
if RSC=""
SET RSC=$$CALCRSC^RCXFMSUR(BILLDA)
+117 ;end PRCA*4.5*338
+118 SET ^XTMP("PRCABDET",BILLDA,CATEGORY,FUND,RSC,SGL,TRANDA,TRANDATE,TRANTYPE,RCPRIN,RCVALUE,0,0)=""
End DoDot:3
End DoDot:2
End DoDot:1
+119 ;
+120 ; remove all the entries from the bad debt file
+121 DO DELETALL
+122 ;
+123 ; calculate percentages and store them
+124 ; PRCA*4.5*338 - corrected 133.N3 to 133N.3, also added 1319.7, 1319.8, 1319.9
+125 ;PRCA*4.5*346
FOR SGL=1319,1319.2,1319.3,1319.4,1319.5,1319.6,1319.7,1319.8,1319.9,1338,1338.2,1338.3,1339,1339.1,"133N","133N.2","133N.3"
Begin DoDot:1
+126 ; collection %
+127 SET COLLECT=0
IF $GET(PRINCPAL(SGL))
SET COLLECT=$JUSTIFY($GET(PAYMENT(SGL))/PRINCPAL(SGL)*100,0,2)
+128 ; patch PRCA*4.5*138: for the first year from when MRA is activated at a site, there is no collection
+129 ; history for post-MRA non-Medicare bills(SGL 133N). So, to calculate the percentage for SGL 133N, the
+130 ; payment and the principal for SGL 1339 are used in the first year.
+131 ; override the collection value for SGL=133N for the first year from MRA activation.
+132 ;; Re-evaluate the calc. of the percentage for 133N as well as 1339.
+133 ;;I SGL="133N",$G(PRINCIPAL(1339)) D ;
+134 ;;. N X1,X2,X,%Y
+135 ;;. ; X2=MRA Activation Date, X1=Today, X=diff in days, %Y=0 invalid dates
+136 ;;. ; DBIA #4385 activated on 31-Mar-2004
+137 ;;. S X2=$$MRADTACT^IBCEMU2,X1=$$DT^XLFDT D ^%DTC
+138 ;;. I %Y,X'>364.25 S COLLECT=$J($G(PAYMENT(1339))/PRINCPAL(1339)*100,0,2)
+139 SET DR=".02////"_+COLLECT_";"
+140 ;
+141 ; current month receivable (this is built in the routine
+142 ; RCRJRCO1 and is stored in ^TMP($J,"RCRJRBD",SGL))
+143 SET DR=DR_".07////"_+$GET(^TMP($JOB,"RCRJRBD",SGL))_";"
+144 ;
+145 ; calculate allowance estimate for 1319 and 1338
+146 ; .08 allowance estimate = (writeoff % * current receivables)
+147 ; .09 actual writeoffs fytd
+148 IF SGL=1319!(SGL=1319.2)!(SGL=1319.3)!(SGL=1319.4)!(SGL=1319.5)!(SGL=1319.6)!(SGL=1319.7)!(SGL=1319.8)!(SGL=1319.9)!(SGL=1338)!(SGL=1338.2)!(SGL=1338.3)
Begin DoDot:2
+149 SET WRITEOFF=100-COLLECT
+150 SET DR=DR_".03////"_WRITEOFF_";"
+151 SET DR=DR_".08////"_$JUSTIFY((WRITEOFF/100)*$GET(^TMP($JOB,"RCRJRBD",SGL)),0,2)_";"
+152 SET DR=DR_".09////"_+$GET(ACTUALWO(SGL))_";"
End DoDot:2
+153 ; calculate allowance estimate for 1339
+154 ; .08 allowance estimate = (contract % * current receivables)
+155 ; .09 actual contract adjustments fytd
+156 IF SGL=1339!(SGL=1339.1)!(SGL="133N")!(SGL="133N.2")!(SGL="133N.3")
Begin DoDot:2
+157 SET CONTRACT=100-COLLECT
+158 SET DR=DR_".04////"_CONTRACT_";"
+159 SET DR=DR_".08////"_$JUSTIFY((CONTRACT/100)*$GET(^TMP($JOB,"RCRJRBD",SGL)),0,2)_";"
+160 SET DR=DR_".09////"_+$GET(ACTUALCA(SGL))_";"
End DoDot:2
+161 ;
+162 ; set changed locally flag to no
+163 SET DR=DR_".1////0;"
+164 DO STORE(SGL,DR)
End DoDot:1
+165 ;
+166 LOCK -^RC(348.1)
+167 ;
+168 ; ; put the report in a mail message (rcrjfmm=1)
+169 ; S RCRJFMM=1
+170 ; S RCRJDATE=DATEEND
+171 ; D DQ^RCRJRBDR
+172 ;
+173 ; transmit the allowances to FMS, and then generate the report.
+174 DO BADDEBT^RCXFMSSV(DATEEND)
+175 QUIT
+176 ;
+177 ;
STORE(SGL,DR) ; store data for Standard Ledger Account
+1 NEW D0,DA,DD,DI,DIC,DIE,DINUM,DO,DQ,X,Y
+2 SET DIC="^RC(348.1,"
SET DIC(0)="L"
SET X=SGL
SET DIC("DR")=DR
+3 DO FILE^DICN
+4 QUIT
+5 ;
+6 ;
DELETALL ; delete all the entries from the bad debt file
+1 NEW %,DA,DIC,DIK,X,Y
+2 SET DIK="^RC(348.1,"
+3 SET DA=0
FOR
SET DA=$ORDER(^RC(348.1,DA))
if 'DA
QUIT
DO ^DIK
+4 QUIT
+5 ;
+6 ;
WD3() ; return the third work day of the month
+1 NEW J,P,V,X
+2 SET J=0
FOR P=$EXTRACT(DT,1,5)_"01":1
SET V=$$DOW^XLFDT(P,1)
IF V
IF V<6
IF '$DATA(^HOLIDAY("B",P))
SET J=J+1
if J=3
QUIT
+3 SET X=+$EXTRACT(P,6,7)
+4 QUIT X
+5 ;
+6 ;
PREVMONT(FORDATE) ; return the previous month's date
+1 NEW PREVDATE
+2 SET PREVDATE=$EXTRACT(FORDATE,1,5)-1
+3 IF $EXTRACT(PREVDATE,4,5)="00"
SET PREVDATE=($EXTRACT(PREVDATE,1,3)-1)_12
+4 QUIT PREVDATE_"00"
+5 ;
+6 ; derive standard general ledger (SGL) from category and fund
SGL(CATEGORY,FUND) ;
+1 ;new long term care fund
IF $GET(FUND)=528709
QUIT 1319.2
+2 ; breakout long term care as a subset
IF $EXTRACT($GET(FUND),1,4)=4032
QUIT 1319.2
+3 ; breakout pharmacy
IF $GET(FUND)=528711&(CAT=6)!(CAT=7)
QUIT 1319.5
+4 ; pharmacy reimburs health ins
IF $GET(FUND)=528711&(CAT=9)
QUIT "133N.2"
+5 ; pharmacy tort feasor
IF $GET(FUND)=528711&(CAT=10)
QUIT 1338.2
+6 ; crime or per. vio.
IF CATEGORY=8
QUIT 1339
+7 ; reimbursable health insurance
IF CATEGORY=9
QUIT 1339
+8 ; EMER/HUMAN REIMB INS ;315
IF CATEGORY=46
QUIT 1339
+9 ; tort feasor
IF CATEGORY=10
QUIT 1338
+10 ; medicare
IF CATEGORY=21
QUIT 1339
+11 ; Fee Basis
IF CATEGORY=45
QUIT 1339.1
+12 QUIT 1319
+13 ;
+14 ;
BDRSGL(CAT,FUND,MRATYPE) ; Calculate SGLs for the BDR process
+1 ;PRCA*4.5*310/DRF Added fund 528713, Non-VA Reimbursable Insurance
+2 ;
+3 ; This API will be used by both the ARDC (routine RCRJRCOC)
+4 ; and the BDR estimate calculator to associate receivables
+5 ; with the correct standard general ledger account (SGL).
+6 ; The following table will be implemented:
+7 ;
+8 ; Receivable Type (Category) Fund SGL
+9 ;==================================================
+10 ; Medical Care Co-payments 528703 1319
+11 ; (plus Inelig, Emerg./Hum. rec.)
+12 ; Long Term Care Co-payments 528709 1319.2
+13 ; Medication Co-payments 528701 1319.3
+14 ; Crimes of Personal Violence (8), 528704 1319.4
+15 ; Medicare (21), No-Fault Auto
+16 ; (7), Workman's Comp (6)
+17 ; Tort Feasor (10) 528704 1338
+18 ; RHI (9), pre-MRA 528704 1339
+19 ; RHI (9), post-MRA, MRA rec. 528704 133H
+20 ; RHI (9), post-MRA, non-MRA rec. 528704 133N
+21 ; Non-VA Tort Feasor 528713 1338.3
+22 ; Non-VA RHI (45), pre-MRA 528713 1339.1
+23 ; Non-VA RHI (45), post-MRA, MRA rec. 528713 133H.2
+24 ; Non-VA RHI (45), post-MRA, non-MRA rec. 528713 133N.3
+25 ; Non-VA No-Fault Auto, Workman's Comp (6) 528713 1319.6
+26 ; Inpat./Outpat./Urgent Care Community 528714 1319.7
+27 ; Care copayments
+28 ; RX Community Care copayments 528714 1319.8
+29 ; LTC Community Care copayments 528714 1319.9
+30 ; Pharmacy No Fault Auto(7), 528711 1319.5
+31 ; Pharmacy Workman's Comp(6)
+32 ; Pharmacy RHI, non MRA (9) 528711 133N.2
+33 ; Pharmacy Tort Feasor (10) 528711 1338.2
+34 ;
+35 ; Input: CAT -- Pointer to the receivable category in file 430.2
+36 ; FUND -- Receivable fund calculated by routine RCXFMSUF
+37 ; MRATYPE -- Indicator of an MRA (2) or non-MRA (3) receivable
+38 ;
+39 ;
+40 IF $GET(FUND)=528709
QUIT 1319.2
+41 IF $EXTRACT($GET(FUND),1,4)=4032
QUIT 1319.2
+42 IF $GET(FUND)=528701
QUIT 1319.3
+43 IF $GET(FUND)=528711&((CAT=6)!(CAT=7))
QUIT 1319.5
+44 IF $GET(FUND)=528711&(CAT=9)
QUIT "133N.2"
+45 IF $GET(FUND)=528711&(CAT=10)
QUIT 1338.2
+46 ;PRCA*4.5*338 - Add new Community Care Categories
+47 ; THIRD PARTY =528713 new code begins
+48 ;patch 338 Add Comm Care Tort Feasor
IF $GET(FUND)=528713&(CAT=10!(CAT=53)!(CAT=56)!(CAT=59))
QUIT 1338.3
+49 ;patch 338 Added Comm Care No Fault and Workers Comp
IF $GET(FUND)=528713&(CAT=8!(CAT=21)!(CAT=6)!(CAT=7)!(CAT=52)!(CAT=54)!(CAT=55)!(CAT=57)!(CAT=59)!(CAT=60))
QUIT 1319.6
+50 ;patch 338 Comm Care Reimb ins types.
IF ((CAT>47)&(CAT<52))
QUIT $SELECT(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1)
+51 ; FIRST PARTY = 528714 - Community Care Copays
+52 ;INP/OPT copays
IF $GET(FUND)=528714&(CAT=61!(CAT=81)!(CAT=63)!(CAT=82)!(CAT=65)!(CAT=83)!(CAT=67)!(CAT=84)!(CAT=85))
QUIT 1319.7
+53 ;rx copays
IF $GET(FUND)=528714&(CAT=62!(CAT=64)!(CAT=66)!(CAT=68))
QUIT 1319.8
+54 ;LTC copays
IF $GET(FUND)=528714&(CAT>68)&(CAT<75)
QUIT 1319.9
+55 ;end PRCA*4.5*338
+56 IF CAT=8!(CAT=21)!(CAT=7)!(CAT=6)
QUIT 1319.4
+57 IF CAT=10
QUIT 1338
+58 IF CAT=9
QUIT $SELECT(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339)
+59 ;315
IF CAT=46
QUIT $SELECT(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339)
+60 IF CAT=45
QUIT $SELECT(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1)
+61 QUIT 1319
