RCDPEWLZ ;ALB/PJH-Block Auto-decrease protocol ;09 Feb 2018
;;4.5;Accounts Receivable;**326,332**;Mar 20, 1995;Build 40
;;Per VA Directive 6402, this routine should not be modified.
Q
;
BLOCK(RCERA) ; Stop/Allow Auto Decrease of zero balance denials
;
; Input - RCERA - IEN of ERA in #344.4
;
; Check that the ERA has auto-decrease CARCs which are not decreased
N RCARRAY
D AUTO(RCERA,.RCARRAY)
;
D FULL^VALM1
S VALMBCK="R"
;
I 'RCARRAY D G QUIT
.W !!,"This option is only valid if an ERA has auto-decrease CARCs."
;
I RCARRAY("D") D G QUIT
.W !!,"This option is not valid, the ERA has already been auto-decreased."
;
N RCSTA,X
S RCSTA=$$GET1^DIQ(344.4,RCERA_",",.19,"I")
;
;
W !!,"This option will "
W $S(RCSTA:"ALLOW the nightly process to auto-decrease",1:"STOP the nightly process from auto-decreasing")
W !," the CARCs on this ERA.",!
;
I $$ASKSTAT(RCSTA)'=1 Q
;
; Update ERA
D UPD(RCERA,RCSTA)
;
W !,"... CARCs on this ERA will "_$S(RCSTA:"",1:"NOT ")_"be auto-decreased ..."
;
QUIT ; pause and rebuild the header
W !!,"press RETURN to continue: "
R X:DTIME
;
N RCARC
S RCARC=$$WLH^RCDPEWLZ(+RCSCR)
S:RCARC]"" VALMHDR(4)=RCARC
Q
;
ASKSTAT(RCSTA) ; ask if its okay to block to unblock from auto-decrease
; 1 is yes, otherwise no
N DIR,DIQ2,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="Y"
S DIR("A")="Do you want to "_$S(RCSTA:"ALLOW",1:"STOP")_" auto-decrease of this ERA"
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q Y
;
AUTO(RCERA,RCARRAY) ; Search ERA for Auto-Decrease CARCs
; INPUT - RCERA = ERA number/IEN
; RCARRAY = return array reference
; OUTPUT - RCARRAY = list of ERA lines and auto-decrease CARC/amounts for each line
;
; RCARRAY=1
; RCARRAY(1)="5.71;22;^10.00;23;" - list of decrease amounts for each auto-decrease CARC
; RCARRAY(1,"D")=1 - indicates line is decreased already
; RCARRAY(1,"B")=1 - indicates line is/was blocked
;
N EOBIEN,PAYID,PAYNAM,RC3446,RCARC,RCBLK,RCDAY,RCPARM,RCRCVD,RCSUB,RCRTYPE,RCZERO
K RCARRAY
S RCARRAY=0,RCARRAY("D")=0
; Ignore ERA if total paid is not zero
Q:+$$GET1^DIQ(344.4,RCERA_",",.05)
; Ignore ERA if removed from worklist
Q:+$$GET1^DIQ(344.4,RCERA_",",.16,"I")
; Calculate process date by subtracting DENIAL decrease days from today's date
S RCDAY=$$FMADD^XLFDT(DT\1,-$$GET1^DIQ(344.61,"1,",.12))
; Compare to ERA received date
S RCRCVD=$$GET1^DIQ(344.4,RCERA_",",.07,"I")
; If not already decreased then check that auto-decrease date is not already past
I $$GET1^DIQ(344.4,RCERA_",",4.03,"I")="",RCRCVD\1<RCDAY Q
; Ignore ERA if not payment type of NON
I $$GET1^DIQ(344.4,RCERA_",",.15)'="NON"
; Ignore ERA if it has PLBs
Q:$D(^TMP($J,"RCDPEWLA","ERA LEVEL ADJUSTMENT EXISTS"))
; Quit if ERA is for Pharmacy
S RCRTYPE=$$PHARM^RCDPEAP1(RCERA)
Q:RCRTYPE
; Check payer exclusion file for this ERA's payer
S PAYID=$P($G(^RCY(344.4,RCERA,0)),U,3)
S PAYNAM=$P($G(^RCY(344.4,RCERA,0)),U,6)
I PAYID'="",PAYNAM'="" D
. S RCPARM=$O(^RCY(344.6,"CPID",PAYNAM,PAYID,""))
. S:RCPARM'="" RC3446=$G(^RCY(344.6,RCPARM,0))
; Ignore ERA if EXCLUDE MED CLAIMS POSTING (#.06) or EXCLUDE MED CLAIMS DECREASE (#.07) fields set to 'yes'
I $G(RC3446)'="" Q:$P(RC3446,U,6)=1 Q:$P(RC3446,U,7)=1
; Scan ERA for EOB - do NOT use scratchpad
S RCSUB=0,RCZERO=1
F S RCSUB=$O(^RCY(344.4,RCERA,1,RCSUB)) Q:'RCSUB D
.; Get IEN of EOB
.S EOBIEN=$$GET1^DIQ(344.41,RCSUB_","_RCERA,.02,"I")
.Q:'EOBIEN
.; Get CARCS
.S RCARC=$$CARCLMT^RCDPEAD(EOBIEN,RCZERO)
.; No CARCs on EOB were eligible for auto-decrease
.Q:$L(RCARC)=0
.; Save CARCs agains line number
.S RCARRAY(RCSUB)=RCARC
.; CARCs found indicator
.S RCARRAY=1
.; Determine if line is already auto-decreased
.S:$$GET1^DIQ(344.41,RCSUB_","_RCERA_",",10,"I")]"" RCARRAY("D")=1
Q
;
UPD(RCERA,RCSTA) ; Update AUTO-DECREASE BLOCKED status of an ERA
N DA,DIE,DR
S DA=RCERA
S DIE="^RCY(344.4,",DR=".19///"_$S(RCSTA:0,1:1) D ^DIE
Q
;
WLF(RCERA) ; Return auto-decrease flag - EP EXTRACT^RCDPEWL7
; INPUT - RCERA = IEN of ERA in #344.4
; OUTPUT - 'c' or null
N RCARRAY
; Check for CARCs
D AUTO(RCERA,.RCARRAY)
; Return result
Q $S(RCARRAY:"c",1:"")
;
WLH(RCERA) ; Auto-decrease status for ERA - EP HDR^RCDPEWL
; INPUT - RCERA = IEN of ERA in #344.4
; OUTPUT - RCTXT = display text
N RCARRAY
; Check for CARCs
D AUTO(RCERA,.RCARRAY)
; If none return null
I 'RCARRAY Q ""
; Check if ERA is auto-decrease blocked
Q:$$GET1^DIQ(344.4,RCERA_",",.19,"I") "Auto-Decrease CARCS are stopped from auto-decrease"
; Check if already auto-decreased
Q:RCARRAY("D") "ERA has processed Auto-Decrease CARCS"
; Else
Q "ERA has unprocessed Auto-Decrease CARCS"
;
WLL(RCERA,RCLINE) ; Auto-decrease status for ERA line - EP - RCDPEWL0
; INPUT - RCERA = IEN of ERA in #344.4
; RCLINE = ERA line number
; OUTPUT - RCTXT = display text
N I,RCARC,RCARRAY,RCTOT
; Check for CARCs on ERA
D AUTO(RCERA,.RCARRAY)
; Check for CARCs on line
Q:'$D(RCARRAY(RCLINE)) ""
; Total line CARCS
S RCTOT=0
F I=1:1 S RCARC=$P(RCARRAY(RCLINE),U,I) Q:RCARC="" S RCTOT=RCTOT+$P(RCARC,";")
Q $S(RCTOT:"Auto-decrease CARC total: $"_RCTOT,1:"")
;
SCRPAD(RCERA) ;Build Scratchpad entry in #344.49 for the ERA - EP REJ^RCDPEAD
;
; Input - RCERA - IEN for #344.4
;
; Output - RCSCR = Scratchpad IEN (Success) or 0 (Fail)
;
N RC0,RC5,RCSCR,RCDAT,X
S RC0=$G(^RCY(344.4,RCERA,0)),RC5=$G(^RCY(344.4,RCERA,5))
;Ignore is this ERA already has a receipt
I +$P(RC0,U,8) Q 0
;Denial ERA must be expected payment type NON
I $P(RC0,U,15)'="NON" Q 0
;Scratchpad already exists
S RCSCR=+$O(^RCY(344.49,"B",RCERA,0)) I RCSCR G SCRPADX
;Create new Scratchpad
S RCSCR=+$$ADDREC^RCDPEWL(RCERA,.RCDAT) I 'RCSCR Q 0
;Add all the ERA lines to the Scratchpad entry
D ADDLINES^RCDPEWLA(RCSCR)
SCRPADX ;Return Scratchpad IEN
Q RCSCR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEWLZ 6031 printed Dec 13, 2024@01:45:52 Page 2
RCDPEWLZ ;ALB/PJH-Block Auto-decrease protocol ;09 Feb 2018
+1 ;;4.5;Accounts Receivable;**326,332**;Mar 20, 1995;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
BLOCK(RCERA) ; Stop/Allow Auto Decrease of zero balance denials
+1 ;
+2 ; Input - RCERA - IEN of ERA in #344.4
+3 ;
+4 ; Check that the ERA has auto-decrease CARCs which are not decreased
+5 NEW RCARRAY
+6 DO AUTO(RCERA,.RCARRAY)
+7 ;
+8 DO FULL^VALM1
+9 SET VALMBCK="R"
+10 ;
+11 IF 'RCARRAY
Begin DoDot:1
+12 WRITE !!,"This option is only valid if an ERA has auto-decrease CARCs."
End DoDot:1
GOTO QUIT
+13 ;
+14 IF RCARRAY("D")
Begin DoDot:1
+15 WRITE !!,"This option is not valid, the ERA has already been auto-decreased."
End DoDot:1
GOTO QUIT
+16 ;
+17 NEW RCSTA,X
+18 SET RCSTA=$$GET1^DIQ(344.4,RCERA_",",.19,"I")
+19 ;
+20 ;
+21 WRITE !!,"This option will "
+22 WRITE $SELECT(RCSTA:"ALLOW the nightly process to auto-decrease",1:"STOP the nightly process from auto-decreasing")
+23 WRITE !," the CARCs on this ERA.",!
+24 ;
+25 IF $$ASKSTAT(RCSTA)'=1
QUIT
+26 ;
+27 ; Update ERA
+28 DO UPD(RCERA,RCSTA)
+29 ;
+30 WRITE !,"... CARCs on this ERA will "_$SELECT(RCSTA:"",1:"NOT ")_"be auto-decreased ..."
+31 ;
QUIT ; pause and rebuild the header
+1 WRITE !!,"press RETURN to continue: "
+2 READ X:DTIME
+3 ;
+4 NEW RCARC
+5 SET RCARC=$$WLH^RCDPEWLZ(+RCSCR)
+6 if RCARC]""
SET VALMHDR(4)=RCARC
+7 QUIT
+8 ;
ASKSTAT(RCSTA) ; ask if its okay to block to unblock from auto-decrease
+1 ; 1 is yes, otherwise no
+2 NEW DIR,DIQ2,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="YO"
SET DIR("B")="Y"
+4 SET DIR("A")="Do you want to "_$SELECT(RCSTA:"ALLOW",1:"STOP")_" auto-decrease of this ERA"
+5 DO ^DIR
+6 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+7 QUIT Y
+8 ;
AUTO(RCERA,RCARRAY) ; Search ERA for Auto-Decrease CARCs
+1 ; INPUT - RCERA = ERA number/IEN
+2 ; RCARRAY = return array reference
+3 ; OUTPUT - RCARRAY = list of ERA lines and auto-decrease CARC/amounts for each line
+4 ;
+5 ; RCARRAY=1
+6 ; RCARRAY(1)="5.71;22;^10.00;23;" - list of decrease amounts for each auto-decrease CARC
+7 ; RCARRAY(1,"D")=1 - indicates line is decreased already
+8 ; RCARRAY(1,"B")=1 - indicates line is/was blocked
+9 ;
+10 NEW EOBIEN,PAYID,PAYNAM,RC3446,RCARC,RCBLK,RCDAY,RCPARM,RCRCVD,RCSUB,RCRTYPE,RCZERO
+11 KILL RCARRAY
+12 SET RCARRAY=0
SET RCARRAY("D")=0
+13 ; Ignore ERA if total paid is not zero
+14 if +$$GET1^DIQ(344.4,RCERA_",",.05)
QUIT
+15 ; Ignore ERA if removed from worklist
+16 if +$$GET1^DIQ(344.4,RCERA_",",.16,"I")
QUIT
+17 ; Calculate process date by subtracting DENIAL decrease days from today's date
+18 SET RCDAY=$$FMADD^XLFDT(DT\1,-$$GET1^DIQ(344.61,"1,",.12))
+19 ; Compare to ERA received date
+20 SET RCRCVD=$$GET1^DIQ(344.4,RCERA_",",.07,"I")
+21 ; If not already decreased then check that auto-decrease date is not already past
+22 IF $$GET1^DIQ(344.4,RCERA_",",4.03,"I")=""
IF RCRCVD\1<RCDAY
QUIT
+23 ; Ignore ERA if not payment type of NON
+24 IF $$GET1^DIQ(344.4,RCERA_",",.15)'="NON"
+25 ; Ignore ERA if it has PLBs
+26 if $DATA(^TMP($JOB,"RCDPEWLA","ERA LEVEL ADJUSTMENT EXISTS"))
QUIT
+27 ; Quit if ERA is for Pharmacy
+28 SET RCRTYPE=$$PHARM^RCDPEAP1(RCERA)
+29 if RCRTYPE
QUIT
+30 ; Check payer exclusion file for this ERA's payer
+31 SET PAYID=$PIECE($GET(^RCY(344.4,RCERA,0)),U,3)
+32 SET PAYNAM=$PIECE($GET(^RCY(344.4,RCERA,0)),U,6)
+33 IF PAYID'=""
IF PAYNAM'=""
Begin DoDot:1
+34 SET RCPARM=$ORDER(^RCY(344.6,"CPID",PAYNAM,PAYID,""))
+35 if RCPARM'=""
SET RC3446=$GET(^RCY(344.6,RCPARM,0))
End DoDot:1
+36 ; Ignore ERA if EXCLUDE MED CLAIMS POSTING (#.06) or EXCLUDE MED CLAIMS DECREASE (#.07) fields set to 'yes'
+37 IF $GET(RC3446)'=""
if $PIECE(RC3446,U,6)=1
QUIT
if $PIECE(RC3446,U,7)=1
QUIT
+38 ; Scan ERA for EOB - do NOT use scratchpad
+39 SET RCSUB=0
SET RCZERO=1
+40 FOR
SET RCSUB=$ORDER(^RCY(344.4,RCERA,1,RCSUB))
if 'RCSUB
QUIT
Begin DoDot:1
+41 ; Get IEN of EOB
+42 SET EOBIEN=$$GET1^DIQ(344.41,RCSUB_","_RCERA,.02,"I")
+43 if 'EOBIEN
QUIT
+44 ; Get CARCS
+45 SET RCARC=$$CARCLMT^RCDPEAD(EOBIEN,RCZERO)
+46 ; No CARCs on EOB were eligible for auto-decrease
+47 if $LENGTH(RCARC)=0
QUIT
+48 ; Save CARCs agains line number
+49 SET RCARRAY(RCSUB)=RCARC
+50 ; CARCs found indicator
+51 SET RCARRAY=1
+52 ; Determine if line is already auto-decreased
+53 if $$GET1^DIQ(344.41,RCSUB_","_RCERA_",",10,"I")]""
SET RCARRAY("D")=1
End DoDot:1
+54 QUIT
+55 ;
UPD(RCERA,RCSTA) ; Update AUTO-DECREASE BLOCKED status of an ERA
+1 NEW DA,DIE,DR
+2 SET DA=RCERA
+3 SET DIE="^RCY(344.4,"
SET DR=".19///"_$SELECT(RCSTA:0,1:1)
DO ^DIE
+4 QUIT
+5 ;
WLF(RCERA) ; Return auto-decrease flag - EP EXTRACT^RCDPEWL7
+1 ; INPUT - RCERA = IEN of ERA in #344.4
+2 ; OUTPUT - 'c' or null
+3 NEW RCARRAY
+4 ; Check for CARCs
+5 DO AUTO(RCERA,.RCARRAY)
+6 ; Return result
+7 QUIT $SELECT(RCARRAY:"c",1:"")
+8 ;
WLH(RCERA) ; Auto-decrease status for ERA - EP HDR^RCDPEWL
+1 ; INPUT - RCERA = IEN of ERA in #344.4
+2 ; OUTPUT - RCTXT = display text
+3 NEW RCARRAY
+4 ; Check for CARCs
+5 DO AUTO(RCERA,.RCARRAY)
+6 ; If none return null
+7 IF 'RCARRAY
QUIT ""
+8 ; Check if ERA is auto-decrease blocked
+9 if $$GET1^DIQ(344.4,RCERA_",",.19,"I")
QUIT "Auto-Decrease CARCS are stopped from auto-decrease"
+10 ; Check if already auto-decreased
+11 if RCARRAY("D")
QUIT "ERA has processed Auto-Decrease CARCS"
+12 ; Else
+13 QUIT "ERA has unprocessed Auto-Decrease CARCS"
+14 ;
WLL(RCERA,RCLINE) ; Auto-decrease status for ERA line - EP - RCDPEWL0
+1 ; INPUT - RCERA = IEN of ERA in #344.4
+2 ; RCLINE = ERA line number
+3 ; OUTPUT - RCTXT = display text
+4 NEW I,RCARC,RCARRAY,RCTOT
+5 ; Check for CARCs on ERA
+6 DO AUTO(RCERA,.RCARRAY)
+7 ; Check for CARCs on line
+8 if '$DATA(RCARRAY(RCLINE))
QUIT ""
+9 ; Total line CARCS
+10 SET RCTOT=0
+11 FOR I=1:1
SET RCARC=$PIECE(RCARRAY(RCLINE),U,I)
if RCARC=""
QUIT
SET RCTOT=RCTOT+$PIECE(RCARC,";")
+12 QUIT $SELECT(RCTOT:"Auto-decrease CARC total: $"_RCTOT,1:"")
+13 ;
SCRPAD(RCERA) ;Build Scratchpad entry in #344.49 for the ERA - EP REJ^RCDPEAD
+1 ;
+2 ; Input - RCERA - IEN for #344.4
+3 ;
+4 ; Output - RCSCR = Scratchpad IEN (Success) or 0 (Fail)
+5 ;
+6 NEW RC0,RC5,RCSCR,RCDAT,X
+7 SET RC0=$GET(^RCY(344.4,RCERA,0))
SET RC5=$GET(^RCY(344.4,RCERA,5))
+8 ;Ignore is this ERA already has a receipt
+9 IF +$PIECE(RC0,U,8)
QUIT 0
+10 ;Denial ERA must be expected payment type NON
+11 IF $PIECE(RC0,U,15)'="NON"
QUIT 0
+12 ;Scratchpad already exists
+13 SET RCSCR=+$ORDER(^RCY(344.49,"B",RCERA,0))
IF RCSCR
GOTO SCRPADX
+14 ;Create new Scratchpad
+15 SET RCSCR=+$$ADDREC^RCDPEWL(RCERA,.RCDAT)
IF 'RCSCR
QUIT 0
+16 ;Add all the ERA lines to the Scratchpad entry
+17 DO ADDLINES^RCDPEWLA(RCSCR)
SCRPADX ;Return Scratchpad IEN
+1 QUIT RCSCR
