Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCRJRBD

RCRJRBD.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ; IA 4385 for calls to $$MRATYPE^IBCEMU2 and $$MRADTACT^IBCEMU2
  1. Q
  1. ;
  1. ;PRCA*4.5*346 Modify SGL compile code 133.N3 to 133N.3 to
  1. ; ensure line item 528713 - 133N dollars are accrued
  1. ;
  1. ;
  1. START(DATEEND) ; run bad debt report
  1. ; the DATEEND is the last day of the month being run
  1. ; from the routine RCRJRCOL which is the data extractor. The
  1. ; current receivable dollars is stored in ^TMP($J,"RCRJRBD",SGL)
  1. ; where SGL is the standard general ledger 1319, 1338, or 1339.
  1. ;
  1. N ACTDATE,ACTUALCA,ACTUALWO,BEGDATE,BILLDA,CATEGORY
  1. N COLLECT,CONTRACT,DR,ENDDATE,FUND,PAY,PAYMENT,PRIN,PRINCPAL
  1. N RCRJFMM,RCRJDATE,SGL,TRANDA,TRANDATE,TRANTYPE,VALUE,WRITEOFF
  1. N RCPRIN,RCTOMCCF,RCVALUE,RSC,MRATYPE,ARACTDT
  1. ;
  1. ; lock the bad debt file for storing data, lock cannot fail
  1. ; this lock can be used to monitor if the report is running
  1. F L +^RC(348.1):$S($G(DILOCKTM)>5:DILOCKTM,1:5) Q:$T
  1. ;
  1. ; calculate the base percentages from past data
  1. ; example: DATEEND=2980331 => BEGDATE=2970300
  1. ; => ENDDATE=2980229
  1. ; add one day to ending date to go to next month
  1. S BEGDATE=($E(DATEEND,1,3)-1)_$E(DATEEND,4,5)_"00"
  1. S ENDDATE=($$FMADD^XLFDT($E(DATEEND,1,5)_"00",-1))+1
  1. ; loop bills activated between these dates
  1. S ACTDATE=BEGDATE
  1. F S ACTDATE=$O(^PRCA(430,"ACTDT",ACTDATE)) Q:'ACTDATE!(ACTDATE>ENDDATE) D
  1. . S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ACTDT",ACTDATE,BILLDA)) Q:'BILLDA D
  1. . . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
  1. . . ; do not look at prepayments
  1. . . I 'CATEGORY!(CATEGORY=26) Q
  1. . . ;
  1. . . ; only look at bills with a 0 principal balance
  1. . . I $P($G(^PRCA(430,BILLDA,7)),"^") Q
  1. . . ;
  1. . . ; only report fund 528701,03,04,11 and 4032/528709 bills
  1. . . ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
  1. . . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
  1. . . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
  1. . . ;end PRCA*4.5*338
  1. . . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
  1. . . ;
  1. . . ; determine MRA type of bill, given bill# and bill active date
  1. . . ; DBIA #4385 activated on 31-Mar-2004
  1. . . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ACTDATE)
  1. . . ;
  1. . . ; derive standard general ledger (SGL) from cat/fund/MRA type
  1. . . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
  1. . . ;
  1. . . ; determine the original amount of the bill (add increase
  1. . . ; adjustments below)
  1. . . S PRIN=$P($G(^PRCA(430,BILLDA,0)),"^",3)
  1. . . S PAY=0
  1. . . ;
  1. . . ; get the $ transations for bills
  1. . . S TRANDA=0
  1. . . F S TRANDA=$O(^PRCA(433,"C",BILLDA,TRANDA)) Q:'TRANDA D
  1. . . . S TRANTYPE=$P($G(^PRCA(433,TRANDA,1)),"^",2)
  1. . . . I "^1^73^2^34^43^"'[("^"_TRANTYPE_"^") Q ; *340 added 73
  1. . . . S VALUE=$$TRANBAL^RCRJRCOT(TRANDA) I VALUE="" Q
  1. . . . ; increase adjustments or re-establish
  1. . . . I TRANTYPE=1!(TRANTYPE=73)!(TRANTYPE=43) S PRIN=PRIN+$P(VALUE,"^") Q ; *340 added 73
  1. . . . ; payments
  1. . . . I TRANTYPE=2!(TRANTYPE=34) S PAY=PAY+$P(VALUE,"^") Q
  1. . . ;
  1. . . ; payment cannot be greater than principle
  1. . . I PAY>PRIN S PAY=PRIN
  1. . . ;
  1. . . ; store the data
  1. . . S PRINCPAL(SGL)=$G(PRINCPAL(SGL))+PRIN
  1. . . S PAYMENT(SGL)=$G(PAYMENT(SGL))+PAY
  1. . . ;
  1. ;
  1. ; calculate the writeoffs from 2/0/98
  1. ; 2/0/98 is when fms cleared out actual writeoffs and contract adj
  1. K ^XTMP("PRCABDET")
  1. S ^XTMP("PRCABDET",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^BAD DEBT REPORT AUDIT"
  1. F TRANTYPE=8,9,10,11,35 D
  1. . S TRANDATE=2980200
  1. . ; do not pick up transactions after the end date
  1. . F S TRANDATE=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE)) Q:'TRANDATE!($P(TRANDATE,".")>DATEEND) D
  1. . . S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE,TRANDA)) Q:'TRANDA D
  1. . . . ; do not look at decrease adj which are not contract adj
  1. . . . I TRANTYPE=35,'$P($G(^PRCA(433,TRANDA,8)),"^",8) Q
  1. . . . ;
  1. . . . S BILLDA=$P($G(^PRCA(433,TRANDA,0)),"^",2)
  1. . . . I 'BILLDA Q
  1. . . . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
  1. . . . ; do not look at prepayments
  1. . . . I 'CATEGORY!(CATEGORY=26) Q
  1. . . . ;
  1. . . . ; only report fund 528701,03,04,11 and 4032/528709 (ltc) bills
  1. . . . ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
  1. . . . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
  1. . . . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
  1. . . . ;end PRCA*4.5*338
  1. . . . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
  1. . . . ;
  1. . . . ; get bill active date
  1. . . . S ARACTDT=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
  1. . . . ; determine MRA type of bill, given bill# and bill active date
  1. . . . ; DBIA #4385 activated on 31-Mar-2004
  1. . . . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT)
  1. . . . ;
  1. . . . ; derive standard general ledger (SGL) from cat/fund/MRA type
  1. . . . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
  1. . . . ;
  1. . . . ; get the principal transaction value
  1. . . . S RCVALUE=+$P($$TRANBAL^RCRJRCOT(TRANDA),"^")
  1. . . . ; temp variable for value (used below)
  1. . . . S RCPRIN=RCVALUE
  1. . . . ;
  1. . . . ; add actual writeoff amount for fiscal year
  1. . . . I TRANTYPE'=35 S ACTUALWO(SGL)=$G(ACTUALWO(SGL))+RCVALUE
  1. . . . ; add actual contract adjustments for fiscal year
  1. . . . I TRANTYPE=35 S ACTUALCA(SGL)=$G(ACTUALCA(SGL))+RCVALUE
  1. . . . ;PRCA*4.5*338 - retrieve RSC from Bill. If no RSC in BILL, calculate it.
  1. . . . S RSC=$$GET1^DIQ(430,BILLDA_",",255.1) ;Check for accrued RSC
  1. . . . S:RSC="" RSC=$$GET1^DIQ(430,BILLDA_",",255) ;if no accrued RSC, check for non-accrued.
  1. . . . S:RSC="" RSC=$$CALCRSC^RCXFMSUR(BILLDA) ;if neither present, calculate
  1. . . . ;end PRCA*4.5*338
  1. . . . S ^XTMP("PRCABDET",BILLDA,CATEGORY,FUND,RSC,SGL,TRANDA,TRANDATE,TRANTYPE,RCPRIN,RCVALUE,0,0)=""
  1. ;
  1. ; remove all the entries from the bad debt file
  1. D DELETALL
  1. ;
  1. ; calculate percentages and store them
  1. ; PRCA*4.5*338 - corrected 133.N3 to 133N.3, also added 1319.7, 1319.8, 1319.9
  1. 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
  1. . ; collection %
  1. . S COLLECT=0 I $G(PRINCPAL(SGL)) S COLLECT=$J($G(PAYMENT(SGL))/PRINCPAL(SGL)*100,0,2)
  1. . ; patch PRCA*4.5*138: for the first year from when MRA is activated at a site, there is no collection
  1. . ; history for post-MRA non-Medicare bills(SGL 133N). So, to calculate the percentage for SGL 133N, the
  1. . ; payment and the principal for SGL 1339 are used in the first year.
  1. . ; override the collection value for SGL=133N for the first year from MRA activation.
  1. . ;; Re-evaluate the calc. of the percentage for 133N as well as 1339.
  1. . ;;I SGL="133N",$G(PRINCIPAL(1339)) D ;
  1. . ;;. N X1,X2,X,%Y
  1. . ;;. ; X2=MRA Activation Date, X1=Today, X=diff in days, %Y=0 invalid dates
  1. . ;;. ; DBIA #4385 activated on 31-Mar-2004
  1. . ;;. S X2=$$MRADTACT^IBCEMU2,X1=$$DT^XLFDT D ^%DTC
  1. . ;;. I %Y,X'>364.25 S COLLECT=$J($G(PAYMENT(1339))/PRINCPAL(1339)*100,0,2)
  1. . S DR=".02////"_+COLLECT_";"
  1. . ;
  1. . ; current month receivable (this is built in the routine
  1. . ; RCRJRCO1 and is stored in ^TMP($J,"RCRJRBD",SGL))
  1. . S DR=DR_".07////"_+$G(^TMP($J,"RCRJRBD",SGL))_";"
  1. . ;
  1. . ; calculate allowance estimate for 1319 and 1338
  1. . ; .08 allowance estimate = (writeoff % * current receivables)
  1. . ; .09 actual writeoffs fytd
  1. . 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
  1. . . S WRITEOFF=100-COLLECT
  1. . . S DR=DR_".03////"_WRITEOFF_";"
  1. . . S DR=DR_".08////"_$J((WRITEOFF/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
  1. . . S DR=DR_".09////"_+$G(ACTUALWO(SGL))_";"
  1. . ; calculate allowance estimate for 1339
  1. . ; .08 allowance estimate = (contract % * current receivables)
  1. . ; .09 actual contract adjustments fytd
  1. . I SGL=1339!(SGL=1339.1)!(SGL="133N")!(SGL="133N.2")!(SGL="133N.3") D
  1. . . S CONTRACT=100-COLLECT
  1. . . S DR=DR_".04////"_CONTRACT_";"
  1. . . S DR=DR_".08////"_$J((CONTRACT/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
  1. . . S DR=DR_".09////"_+$G(ACTUALCA(SGL))_";"
  1. . ;
  1. . ; set changed locally flag to no
  1. . S DR=DR_".1////0;"
  1. . D STORE(SGL,DR)
  1. ;
  1. L -^RC(348.1)
  1. ;
  1. ; ; put the report in a mail message (rcrjfmm=1)
  1. ; S RCRJFMM=1
  1. ; S RCRJDATE=DATEEND
  1. ; D DQ^RCRJRBDR
  1. ;
  1. ; transmit the allowances to FMS, and then generate the report.
  1. D BADDEBT^RCXFMSSV(DATEEND)
  1. Q
  1. ;
  1. ;
  1. STORE(SGL,DR) ; store data for Standard Ledger Account
  1. N D0,DA,DD,DI,DIC,DIE,DINUM,DO,DQ,X,Y
  1. S DIC="^RC(348.1,",DIC(0)="L",X=SGL,DIC("DR")=DR
  1. D FILE^DICN
  1. Q
  1. ;
  1. ;
  1. DELETALL ; delete all the entries from the bad debt file
  1. N %,DA,DIC,DIK,X,Y
  1. S DIK="^RC(348.1,"
  1. S DA=0 F S DA=$O(^RC(348.1,DA)) Q:'DA D ^DIK
  1. Q
  1. ;
  1. ;
  1. WD3() ; return the third work day of the month
  1. N J,P,V,X
  1. 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
  1. S X=+$E(P,6,7)
  1. Q X
  1. ;
  1. ;
  1. PREVMONT(FORDATE) ; return the previous month's date
  1. N PREVDATE
  1. S PREVDATE=$E(FORDATE,1,5)-1
  1. I $E(PREVDATE,4,5)="00" S PREVDATE=($E(PREVDATE,1,3)-1)_12
  1. Q PREVDATE_"00"
  1. ;
  1. ; derive standard general ledger (SGL) from category and fund
  1. SGL(CATEGORY,FUND) ;
  1. I $G(FUND)=528709 Q 1319.2 ;new long term care fund
  1. I $E($G(FUND),1,4)=4032 Q 1319.2 ; breakout long term care as a subset
  1. I $G(FUND)=528711&(CAT=6)!(CAT=7) Q 1319.5 ; breakout pharmacy
  1. I $G(FUND)=528711&(CAT=9) Q "133N.2" ; pharmacy reimburs health ins
  1. I $G(FUND)=528711&(CAT=10) Q 1338.2 ; pharmacy tort feasor
  1. I CATEGORY=8 Q 1339 ; crime or per. vio.
  1. I CATEGORY=9 Q 1339 ; reimbursable health insurance
  1. I CATEGORY=46 Q 1339 ; EMER/HUMAN REIMB INS ;315
  1. I CATEGORY=10 Q 1338 ; tort feasor
  1. I CATEGORY=21 Q 1339 ; medicare
  1. I CATEGORY=45 Q 1339.1 ; Fee Basis
  1. Q 1319
  1. ;
  1. ;
  1. BDRSGL(CAT,FUND,MRATYPE) ; Calculate SGLs for the BDR process
  1. ;PRCA*4.5*310/DRF Added fund 528713, Non-VA Reimbursable Insurance
  1. ;
  1. ; This API will be used by both the ARDC (routine RCRJRCOC)
  1. ; and the BDR estimate calculator to associate receivables
  1. ; with the correct standard general ledger account (SGL).
  1. ; The following table will be implemented:
  1. ;
  1. ; Receivable Type (Category) Fund SGL
  1. ;==================================================
  1. ; Medical Care Co-payments 528703 1319
  1. ; (plus Inelig, Emerg./Hum. rec.)
  1. ; Long Term Care Co-payments 528709 1319.2
  1. ; Medication Co-payments 528701 1319.3
  1. ; Crimes of Personal Violence (8), 528704 1319.4
  1. ; Medicare (21), No-Fault Auto
  1. ; (7), Workman's Comp (6)
  1. ; Tort Feasor (10) 528704 1338
  1. ; RHI (9), pre-MRA 528704 1339
  1. ; RHI (9), post-MRA, MRA rec. 528704 133H
  1. ; RHI (9), post-MRA, non-MRA rec. 528704 133N
  1. ; Non-VA Tort Feasor 528713 1338.3
  1. ; Non-VA RHI (45), pre-MRA 528713 1339.1
  1. ; Non-VA RHI (45), post-MRA, MRA rec. 528713 133H.2
  1. ; Non-VA RHI (45), post-MRA, non-MRA rec. 528713 133N.3
  1. ; Non-VA No-Fault Auto, Workman's Comp (6) 528713 1319.6
  1. ; Inpat./Outpat./Urgent Care Community 528714 1319.7
  1. ; Care copayments
  1. ; RX Community Care copayments 528714 1319.8
  1. ; LTC Community Care copayments 528714 1319.9
  1. ; Pharmacy No Fault Auto(7), 528711 1319.5
  1. ; Pharmacy Workman's Comp(6)
  1. ; Pharmacy RHI, non MRA (9) 528711 133N.2
  1. ; Pharmacy Tort Feasor (10) 528711 1338.2
  1. ;
  1. ; Input: CAT -- Pointer to the receivable category in file 430.2
  1. ; FUND -- Receivable fund calculated by routine RCXFMSUF
  1. ; MRATYPE -- Indicator of an MRA (2) or non-MRA (3) receivable
  1. ;
  1. ;
  1. I $G(FUND)=528709 Q 1319.2
  1. I $E($G(FUND),1,4)=4032 Q 1319.2
  1. I $G(FUND)=528701 Q 1319.3
  1. I $G(FUND)=528711&((CAT=6)!(CAT=7)) Q 1319.5
  1. I $G(FUND)=528711&(CAT=9) Q "133N.2"
  1. I $G(FUND)=528711&(CAT=10) Q 1338.2
  1. ;PRCA*4.5*338 - Add new Community Care Categories
  1. ; THIRD PARTY =528713 new code begins
  1. I $G(FUND)=528713&(CAT=10!(CAT=53)!(CAT=56)!(CAT=59)) Q 1338.3 ;patch 338 Add Comm Care Tort Feasor
  1. 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
  1. 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.
  1. ; FIRST PARTY = 528714 - Community Care Copays
  1. 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
  1. I $G(FUND)=528714&(CAT=62!(CAT=64)!(CAT=66)!(CAT=68)) Q 1319.8 ;rx copays
  1. I $G(FUND)=528714&(CAT>68)&(CAT<75) Q 1319.9 ;LTC copays
  1. ;end PRCA*4.5*338
  1. I CAT=8!(CAT=21)!(CAT=7)!(CAT=6) Q 1319.4
  1. I CAT=10 Q 1338
  1. I CAT=9 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339)
  1. I CAT=46 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339) ;315
  1. I CAT=45 Q $S(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1)
  1. Q 1319