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