- 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 Feb 18, 2025@23:12:16 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