RCDPEX4 ;ALB/DRF - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**298,321**;Mar 20, 1995;Build 48
;Per VA Directive 6402, this routine should not be modified.
;Call to $$RXBIL^IBNCPDPU via private IA #4435
;
;Cycle through the exception list looking for entries with an ECME number:
EN N ARRAY,ECME,EOB,ERA,RCBILL,RCER
S RCER=0 F S RCER=$O(^RCY(344.4,"AEXC",RCER)) Q:'RCER D
.S ERA="" F S ERA=$O(^RCY(344.4,"AEXC",RCER,ERA)) Q:'ERA D
..S EOB="" F S EOB=$O(^RCY(344.4,"AEXC",RCER,ERA,EOB)) Q:'EOB D
...;Ignore the exception if no ECME number is present
...S ECME=$P($G(^RCY(344.4,ERA,1,EOB,4)),U,2) Q:ECME=""
...;Lock zero node of ERA DETAIL
...L +^RCY(344.4,ERA,1,EOB,0):5 Q:'$T
...;Check for a matching bill in #399 (Rx Released) and if found remove error from exception list
...K ARRAY S ARRAY("ECME")=ECME,ARRAY("FILLDT")=$$SDATE(ERA,EOB) ; PRCA*4.5*326
...S RCBILL=$$RXBIL^IBNCPDPU(.ARRAY) ; DBIA 4435
...I RCBILL>0 S RCBILL(1)=$P($G(^PRCA(430,RCBILL,0)),U) D REMOVE(ERA,EOB,.RCBILL,ECME)
...;Unlock zero node of ERA DETAIL
...L -^RCY(344.4,ERA,1,EOB,0)
Q
;
REMOVE(RCXDA1,RCXDA,RCBILL,RCSAVE) ;Remove from exception list and file EEOB against matched claim
;RCXDA1 - ERA IEN
;RCXDA - ERA DETAIL IEN
;RCBILL - CLAIM array for released Rx
;RCSAVE - ORIGINAL CLAIM from ERA (ECME #)
K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR")
N DA,Q,Q0,RC0,RCEOB,DIE,DR
S RC0=$G(^RCY(344.4,RCXDA1,1,RCXDA,0))
S Q=0 F S Q=$O(^RCY(344.4,RCXDA1,1,RCXDA,1,Q)) Q:'Q S Q0=$G(^(Q,0)) D
.I $P(Q0,U)["835ERA" S ^TMP($J,"RCDPEOB","HDR")=Q0
.I $P(Q0,U,2)=$P(RC0,U,5) S $P(Q0,U,2)=RCBILL(1)
.S ^TMP($J,"RCDP-EOB",1,Q,0)=Q0
S ^TMP($J,"RCDP-EOB",1,.5,0)="835ERA"
S RCEOB=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"",1)",RCBILL) ; IA 4042
K ^TMP($J,"RCDP-EOB",1,.5,0)
I RCEOB D Q
.N RCWHY S RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB"
.D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
.S DA(1)=RCXDA1,DA=RCXDA D CHGED(.DA,RCEOB,RCSAVE)
;
; Add stub rec to 361.1 if not there
S RCEOB=+$$ADD3611^IBCEOB(+$P($G(^RCY(344.4,RCXDA1,0)),U,12),"","",RCBILL,1,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042
;
I RCEOB<0 D Q
.N RCWHY S RCWHY(1)="Error encountered trying to change claim # and file into IB"
.D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
;
; Update EOB in file 361.1
; Call needs ^TMP arrays: $J,"RCDPEOB","HDR" and $J,"RCDP-EOB"
D UPD3611^IBCEOB(RCEOB,1,1) ; IA 4042
; errors in ^TMP("RCDPERR-EOB",$J
I $O(^TMP("RCDPERR-EOB",$J,0)) D
.D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") ; Adds error msgs to IB file 361.1 ; IA 4042
;
N RCWHY S RCWHY(1)="EEOB claim # changed and filed into IB under new claim #"
D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
S DA(1)=RCXDA1,DA=RCXDA
D CHGED(.DA,RCEOB,RCSAVE)
S DIE="^RCY(344.4,"_DA(1)_",1,",DR="1///@" D ^DIE
;
K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR"),^TMP("RCDPERR-EOB",$J)
Q
;
CHGED(DA,RCEOB,RCSAVE) ; Change bad bill # to good one for EOB
; DA = DA and DA(1) to use for DIE call
; RCEOB = the ien of the entry in file 361.1
; RCSAVE = the free text of the original bill #
N DIE,DR,X,Y
S DIE="^RCY(344.4,"_DA(1)_",1,",DR=".05///@;.02////"_RCEOB_";.13////1"_$S(RCSAVE'="":";.17////"_RCSAVE,1:"")_";.07///@" D ^DIE
Q
;
; BEGIN PRCA*4.5*321
SDATE(ERA,LINE) ;Return Service Date for the ERA
; INPUT
; ERA = ERA number
; LINE = ERA line
; OUTPUT
; SDATE = Service date
;Scan RAW DATA multiple SERVICE DATE is piece 19 of record type 40
N SUB,REC,SDATE,STDAT
S SUB=0,SDATE="",STDAT=""
F S SUB=$O(^RCY(344.4,ERA,1,LINE,1,SUB)) Q:'SUB D Q:SDATE]""
.S REC=$G(^RCY(344.4,ERA,1,LINE,1,SUB,0))
.I +REC=5 S STDAT=$P(REC,U,9) Q
.I +REC=40 S SDATE=$P(REC,U,19)
;If no service date use statement date
I 'SDATE,STDAT S SDATE=STDAT
Q SDATE
; END PRCA*4.5*321
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEX4 3943 printed Oct 16, 2024@17:46:51 Page 2
RCDPEX4 ;ALB/DRF - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**298,321**;Mar 20, 1995;Build 48
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;Call to $$RXBIL^IBNCPDPU via private IA #4435
+4 ;
+5 ;Cycle through the exception list looking for entries with an ECME number:
EN NEW ARRAY,ECME,EOB,ERA,RCBILL,RCER
+1 SET RCER=0
FOR
SET RCER=$ORDER(^RCY(344.4,"AEXC",RCER))
if 'RCER
QUIT
Begin DoDot:1
+2 SET ERA=""
FOR
SET ERA=$ORDER(^RCY(344.4,"AEXC",RCER,ERA))
if 'ERA
QUIT
Begin DoDot:2
+3 SET EOB=""
FOR
SET EOB=$ORDER(^RCY(344.4,"AEXC",RCER,ERA,EOB))
if 'EOB
QUIT
Begin DoDot:3
+4 ;Ignore the exception if no ECME number is present
+5 SET ECME=$PIECE($GET(^RCY(344.4,ERA,1,EOB,4)),U,2)
if ECME=""
QUIT
+6 ;Lock zero node of ERA DETAIL
+7 LOCK +^RCY(344.4,ERA,1,EOB,0):5
if '$TEST
QUIT
+8 ;Check for a matching bill in #399 (Rx Released) and if found remove error from exception list
+9 ; PRCA*4.5*326
KILL ARRAY
SET ARRAY("ECME")=ECME
SET ARRAY("FILLDT")=$$SDATE(ERA,EOB)
+10 ; DBIA 4435
SET RCBILL=$$RXBIL^IBNCPDPU(.ARRAY)
+11 IF RCBILL>0
SET RCBILL(1)=$PIECE($GET(^PRCA(430,RCBILL,0)),U)
DO REMOVE(ERA,EOB,.RCBILL,ECME)
+12 ;Unlock zero node of ERA DETAIL
+13 LOCK -^RCY(344.4,ERA,1,EOB,0)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
REMOVE(RCXDA1,RCXDA,RCBILL,RCSAVE) ;Remove from exception list and file EEOB against matched claim
+1 ;RCXDA1 - ERA IEN
+2 ;RCXDA - ERA DETAIL IEN
+3 ;RCBILL - CLAIM array for released Rx
+4 ;RCSAVE - ORIGINAL CLAIM from ERA (ECME #)
+5 KILL ^TMP($JOB,"RCDP-EOB"),^TMP($JOB,"RCDPEOB","HDR")
+6 NEW DA,Q,Q0,RC0,RCEOB,DIE,DR
+7 SET RC0=$GET(^RCY(344.4,RCXDA1,1,RCXDA,0))
+8 SET Q=0
FOR
SET Q=$ORDER(^RCY(344.4,RCXDA1,1,RCXDA,1,Q))
if 'Q
QUIT
SET Q0=$GET(^(Q,0))
Begin DoDot:1
+9 IF $PIECE(Q0,U)["835ERA"
SET ^TMP($JOB,"RCDPEOB","HDR")=Q0
+10 IF $PIECE(Q0,U,2)=$PIECE(RC0,U,5)
SET $PIECE(Q0,U,2)=RCBILL(1)
+11 SET ^TMP($JOB,"RCDP-EOB",1,Q,0)=Q0
End DoDot:1
+12 SET ^TMP($JOB,"RCDP-EOB",1,.5,0)="835ERA"
+13 ; IA 4042
SET RCEOB=$$DUP^IBCEOB("^TMP("_$JOB_",""RCDP-EOB"",1)",RCBILL)
+14 KILL ^TMP($JOB,"RCDP-EOB",1,.5,0)
+15 IF RCEOB
Begin DoDot:1
+16 NEW RCWHY
SET RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB"
+17 DO STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
+18 SET DA(1)=RCXDA1
SET DA=RCXDA
DO CHGED(.DA,RCEOB,RCSAVE)
End DoDot:1
QUIT
+19 ;
+20 ; Add stub rec to 361.1 if not there
+21 ; IA 4042
SET RCEOB=+$$ADD3611^IBCEOB(+$PIECE($GET(^RCY(344.4,RCXDA1,0)),U,12),"","",RCBILL,1,"^TMP("_$JOB_",""RCDP-EOB"",1)")
+22 ;
+23 IF RCEOB<0
Begin DoDot:1
+24 NEW RCWHY
SET RCWHY(1)="Error encountered trying to change claim # and file into IB"
+25 DO STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
End DoDot:1
QUIT
+26 ;
+27 ; Update EOB in file 361.1
+28 ; Call needs ^TMP arrays: $J,"RCDPEOB","HDR" and $J,"RCDP-EOB"
+29 ; IA 4042
DO UPD3611^IBCEOB(RCEOB,1,1)
+30 ; errors in ^TMP("RCDPERR-EOB",$J
+31 IF $ORDER(^TMP("RCDPERR-EOB",$JOB,0))
Begin DoDot:1
+32 ; Adds error msgs to IB file 361.1 ; IA 4042
DO ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB")
End DoDot:1
+33 ;
+34 NEW RCWHY
SET RCWHY(1)="EEOB claim # changed and filed into IB under new claim #"
+35 DO STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
+36 SET DA(1)=RCXDA1
SET DA=RCXDA
+37 DO CHGED(.DA,RCEOB,RCSAVE)
+38 SET DIE="^RCY(344.4,"_DA(1)_",1,"
SET DR="1///@"
DO ^DIE
+39 ;
+40 KILL ^TMP($JOB,"RCDP-EOB"),^TMP($JOB,"RCDPEOB","HDR"),^TMP("RCDPERR-EOB",$JOB)
+41 QUIT
+42 ;
CHGED(DA,RCEOB,RCSAVE) ; Change bad bill # to good one for EOB
+1 ; DA = DA and DA(1) to use for DIE call
+2 ; RCEOB = the ien of the entry in file 361.1
+3 ; RCSAVE = the free text of the original bill #
+4 NEW DIE,DR,X,Y
+5 SET DIE="^RCY(344.4,"_DA(1)_",1,"
SET DR=".05///@;.02////"_RCEOB_";.13////1"_$SELECT(RCSAVE'="":";.17////"_RCSAVE,1:"")_";.07///@"
DO ^DIE
+6 QUIT
+7 ;
+8 ; BEGIN PRCA*4.5*321
SDATE(ERA,LINE) ;Return Service Date for the ERA
+1 ; INPUT
+2 ; ERA = ERA number
+3 ; LINE = ERA line
+4 ; OUTPUT
+5 ; SDATE = Service date
+6 ;Scan RAW DATA multiple SERVICE DATE is piece 19 of record type 40
+7 NEW SUB,REC,SDATE,STDAT
+8 SET SUB=0
SET SDATE=""
SET STDAT=""
+9 FOR
SET SUB=$ORDER(^RCY(344.4,ERA,1,LINE,1,SUB))
if 'SUB
QUIT
Begin DoDot:1
+10 SET REC=$GET(^RCY(344.4,ERA,1,LINE,1,SUB,0))
+11 IF +REC=5
SET STDAT=$PIECE(REC,U,9)
QUIT
+12 IF +REC=40
SET SDATE=$PIECE(REC,U,19)
End DoDot:1
if SDATE]""
QUIT
+13 ;If no service date use statement date
+14 IF 'SDATE
IF STDAT
SET SDATE=STDAT
+15 QUIT SDATE
+16 ; END PRCA*4.5*321
