RCDPEM5 ;ALB/PJH - EPAYMENTS MOVE EEOB TO NEW CLAIM ;Oct 29, 2014@16:43:51
;;4.5;Accounts Receivable;**173,208,276,298,321,332**;Mar 20, 1995;Build 40
;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ;Entry point for EEOB Move/Copy/Remove [RCDPE EEOB MOVE/COPY/REMOVE] option
;
N DIR,X,Y,DIROUT,DUOUT,MODE
S DIR("A")="Select action"
S DIR("B")="M"
S DIR(0)="S^M:Move EEOB to different claim;"
S DIR(0)=DIR(0)_"C:Copy EEOB to multiple claims;"
S DIR(0)=DIR(0)_"R:Remove EEOB from claim"
D ^DIR Q:$G(DIROUT)!$G(DUOUT)
S MODE=Y
;
; - PRCA*4.5*298 - OWNSKEY^XUSRB - Supported IA 3277
I MODE="R" N MSG D OWNSKEY^XUSRB(.MSG,"RCDPE REMOVE EEOB",DUZ) I 'MSG(0) D Q
.W !!,"SORRY, YOU ARE NOT AUTHORIZED TO USE THIS ACTION"
.W !,"This action is locked with RCDPE REMOVE EEOB key.",!
.N DIR S DIR(0)="E" D ^DIR
;
;Read access to file #361.1 under IA 4051
;
N DA,DIC,DIE,DIR,DR,NCLAIM,ORIG,ORIGNAM,X,Y
;
;Allow selection of a original third party EOB
S DIC("A")="Select EXPLANATION OF BENEFIT (EEOB) to "_$S(MODE="M":"MOVE",MODE="R":"REMOVE",1:"COPY")_": "
; screen to only allow selection of an active EEOB (not marked as deleted) and non-MRA type EOB
S DIC("S")="I ($P(^(0),U,4)=0)&('$P($G(^(102)),U))",DIC="^IBM(361.1,",DIC(0)="AEMQ"
W ! D ^DIC K DIC
;
I Y'>0 Q
; controlled subscription IA 1992
S ORIG=+Y,ORIGNAM=$$GET1^DIQ(399,$P(Y,U,2),.01)
;
;Get current bill payer sequence from claim - IA 3820
D
.N CURR,IEN399
.S IEN399=$P($G(^IBM(361.1,ORIG,0)),U) Q:'IEN399
.S CURR=$P($G(^DGCR(399,IEN399,0)),U,21) I (CURR'="T")&(CURR'="S") Q
.W !!,"Warning - selected EEOB has secondary claims and may have tertiary claims"
;
;Lock Original EOB
Q:'$$LOCK^IBCEOB4(ORIG)
;
;Remove Option
I MODE="R" D REMOVE(ORIG,MODE),EXIT Q
;
;Select Claim(s) to Move/Copy to
N RCBILL,RCBILLNM,NCLAIM,NCLAIMX,QUIT,SUB,LIT
S SUB=0,QUIT=0,LIT=""
W !
F D Q:QUIT Q:SUB&(MODE="M")
.;Allow selection of a third party claim
.I MODE="M" S DIC("A")="Select A/R Bill to MOVE to: "
.I MODE="C" S DIC("A")="Select "_LIT_"A/R Bill to COPY to: "
.S DIC="^PRCA(430,",DIC(0)="AEMQ",DIC("S")="I $D(^DGCR(399,+Y,0))&($$VALSTAT^RCDPEM5(+Y))"
.D ^DIC K DIC
.I Y'>0 S QUIT=1 Q
.S RCBILL=+Y,RCBILLNM=$P($P(Y,U,2),"-",2)
.I ORIGNAM=RCBILLNM,MODE="M" W !,"Cannot move EEOB to same claim" Q
.I $D(NCLAIMX(RCBILL)) W !,"Claim already entered" Q
.S SUB=SUB+1,NCLAIM(SUB)=RCBILL,NCLAIMX(RCBILL)=""
.S:MODE="C" LIT="another "
;
I $G(DUOUT)!$G(DIROUT) D EXIT Q
;
;User Exit or no claims selected
I '$O(NCLAIM("")) D EXIT Q
;
;Prompt user to continue
N DIR,X,Y,DIROUT
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")=$$PROMPT(ORIG,.NCLAIM,MODE)
W ! D ^DIR
;
I $G(DIROUT)!$G(DUOUT)!(Y=0) D EXIT Q
;
;Enter Justification Comment
N DIR,DIROUT,DUOUT,JCOM,X,Y
S DIR(0)="FA^1:100^K:$TR(X,"" "","""")="""" X",DIR("A")="Enter JUSTIFICATION COMMENT: "
W ! D ^DIR I $G(DIROUT)!$G(DUOUT) W !!,"Update not performed" D EXIT Q
S JCOM=Y
;
;Update EOB
D UPDATE(ORIG,.NCLAIM,MODE,JCOM),EXIT
;
Q
;
;Unlock original EOB
EXIT D UNLOCK^IBCEOB4(ORIG)
Q
;
;File EOB #361.1 changes - Integration Agreement 5671 for IBCEOB4
UPDATE(ORIG,NCLAIM,MODE,JUST) ;
; Input - ORIG - Original EOB
; - NCLAIM - New claim (s)
; - MODE M=Move C=Copy
; - JUST = User input justification text
; Output - Updates EOB and Audit log
N JUST1
;Move EOB
I MODE="M" D
.;Auto generate text for AR comments on original claim
.S JUST1=$$JUST1(ORIG,.NCLAIM,"M",0)
.;Update AR Comments on the 'from bill'
.D AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
.;Change claim number on EEOB
.D MOVE^IBCEOB4(ORIG,NCLAIM(1),DUZ,$$NOW^XLFDT,JUST,MODE)
.;Update AR Comments on 'to bill'
.D AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
;Copy EOB
I MODE="C" D
.D COPY^IBCEOB4(ORIG,.NCLAIM,DUZ,$$NOW^XLFDT,JUST,MODE)
.;Auto generate text for AR comments on original claim
.S JUST1=$$JUST1(ORIG,.NCLAIM,"C",0)
.;Update AR Comments on original claim
.D AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
.;Auto generate text for AR comments on new claim
.S JUST1=$$JUST1(ORIG,.NCLAIM,"C",1)
.;Update AR Comments on new claims
.N SUB,NEWEOB
.S SUB=0
.F S SUB=$O(NCLAIM(SUB)) Q:'SUB D
..;Convert Claim pointer to EOB pointer
..S NEWEOB=$O(^IBM(361.1,"B",NCLAIM(SUB),0)) Q:'NEWEOB
..D AUDIT^RCDPAYER(NEWEOB,JUST_"^"_JUST1,MODE)
W !!,"EEOB Update Complete" H 1
Q
;
PROMPT(ORIG,NCLAIM,MODE) ;Construct prompt text
; Input - ORIG - Original EOB
; - NCLAIM - New claim (s)
; - MODE M=Move C=Copy
; Output - Justification text
;
N FIRST,STR,STR1,SUB,TEXT
;Move or copy text
S TEXT=$$EXTERNAL^DILFD(361.1,.01,,$P($G(^IBM(361.1,ORIG,0)),U))
I MODE="M" S STR="Move EEOB from claim "_TEXT_" to claim "
E S STR="Copy EEOB from claim "_TEXT_" to claim(s) "
;Build list of claims
S STR1="",SUB="",FIRST=1
F S SUB=$O(NCLAIM(SUB)) Q:'SUB D
.S TEXT=$P($G(^PRCA(430,NCLAIM(SUB),0)),U)
.I FIRST S STR1=STR1_$P(TEXT,"-",2),FIRST=0 Q
.S STR1=STR1_", "_$P(TEXT,"-",2)
;Return full prompt text
Q STR_STR1_" "
;
JUST(ORIG,NCLAIM,MODE,TYPE,SRC) ;Construct justification text for automatic updates
; Input - ORIG - Original EOB
; - NCLAIM - New claim (s)
; - MODE - "M" = Move "C" =Copy "R" = Remove
; - TYPE - 0 = old EOB 1 = new EOB
; - SRC - "W" = Worklist "A" = Auto-post, "L" = Link Payment
; Output - Justification text
N FIRST,STR,STR1,SUB,TEXT
;Original bill number
S TEXT=$$EXTERNAL^DILFD(361.1,.01,,$P($G(^IBM(361.1,ORIG,0)),U))
;Justification comment for original EOB
I TYPE=0 D
.I MODE="R" S STR="EEOB removed from claim "_TEXT,STR1="" Q ;PRCA*4.5*321
.I MODE="M" S STR="EEOB from claim "_TEXT_" moved to claim "
.I MODE="C" S STR="EEOB from claim "_TEXT_" copied to claim(s) "
.;Build list of claims
.S STR1="",SUB="",FIRST=1
.F S SUB=$O(NCLAIM(SUB)) Q:'SUB D
..S TEXT=$P($G(^PRCA(430,NCLAIM(SUB),0)),U)
..I FIRST S STR1=STR1_$P(TEXT,"-",2),FIRST=0 Q
..S STR1=STR1_", "_$P(TEXT,"-",2)
;Justification comment for new EOB's
I TYPE=1 D
.I MODE="M" S STR="EEOB moved from EEOB for claim "_TEXT,STR1=""
.I MODE="C" S STR="EEOB copied from EEOB for claim "_TEXT,STR1=""
;Return full justification text
Q STR_STR1_" automatically by "_$S(SRC="A":"Auto-post",SRC="L":"Link Payment",1:"Worklist")
;
JUST1(ORIG,NCLAIM,MODE,TYPE) ;Construct AR comment for stand-alone MCR option
; Input - ORIG - Original EOB
; - NCLAIM - New claim (s)
; - MODE M=Move C=Copy
; - TYPE = 0 - original EOB 1 - new EOB(s)
; Output - Justification text
N FIRST,STR,STR1,SUB,TEXT
;Original bill number
S TEXT=$$EXTERNAL^DILFD(361.1,.01,,$P($G(^IBM(361.1,ORIG,0)),U))
;Justification comment for original EOB
I TYPE=0 D
.I MODE="M" S STR="EEOB from claim "_TEXT_" moved to claim "
.I MODE="C" S STR="EEOB from claim "_TEXT_" copied to claim(s) "
.;Build list of claims
.S STR1="",SUB="",FIRST=1
.F S SUB=$O(NCLAIM(SUB)) Q:'SUB D
..S TEXT=$P($G(^PRCA(430,NCLAIM(SUB),0)),U)
..I FIRST S STR1=STR1_$P(TEXT,"-",2),FIRST=0 Q
..S STR1=STR1_", "_$P(TEXT,"-",2)
;Justification comment for new EOB's
I TYPE=1 D
.I MODE="M" S STR="EEOB moved from EEOB for claim "_TEXT,STR1=""
.I MODE="C" S STR="EEOB copied from EEOB for claim "_TEXT,STR1=""
;Return comment text
Q STR_STR1
;
FINDEOB(IEN3444,BILL) ;Find EOB for a claim within an ERA
; Input - IEN3444 = ERA ien
; BILL = Bill number
; Output - IEN of EOB in #361.1
N IEN3611,SUB
S (SUB,IEN3611)=0
F S SUB=$O(^RCY(344.4,IEN3444,1,"AC",SUB)) Q:'SUB D Q:IEN3611
.I $$EXTERNAL^DILFD(344.41,.02,,SUB)=BILL S IEN3611=SUB
Q IEN3611
;
REMOVE(ORIG,MODE) ; Interactive option to Remove EEOB - PRCA*4.5*298
; Input - ORIG = original EOB in #361.1
; Output - mode = "R"
;
;Prompt user to continue
N DIR,X,Y,DIROUT
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Are you sure you want to remove EEOB from claim "_ORIGNAM_" (Y/N)?"
W ! D ^DIR
;
I $G(DIROUT)!$G(DUOUT)!(Y=0) Q
;
;Enter Justification Comment
N DIR,DIROUT,DUOUT,JUST,X,Y
S DIR(0)="FA^1:100^K:$TR(X,"" "","""")="""" X",DIR("A")="Enter JUSTIFICATION COMMENT: "
W ! D ^DIR I $G(DIROUT)!$G(DUOUT) W !!,"Update not performed" D EXIT Q
S JUST=Y
;
;Update EEOB
D REMOVE^IBCEOB4(ORIG,DUZ,JUST)
;Update AR Comments for removed claim
D AUDIT^RCDPAYER(ORIG,JUST,MODE)
;
W !!,"EEOB Update Complete" H 1
Q
;
VALSTAT(CLIEN) ; validation on current status of the AR claim selected for the move/copy event
; Claims that are in a incomplete state cannot be selected
; incomplete states are determined at CURRENT STATUS (8,430) of the AR claim
; AR claims with 'BILL INCOMPLETE', 'INCOMPLETE', 'NEW BILL' statuses cannot be selected
; CLIEN=430 ien
; returns 0 or 1
N CSTAT,FLAG
S CSTAT=$$GET1^DIQ(430,CLIEN,8)
S FLAG=$S(CSTAT="BILL INCOMPLETE":0,CSTAT="INCOMPLETE":0,CSTAT="NEW BILL":0,1:1)
Q FLAG
;
; BEGIN - PRCA*4.5*321
AUTO(OBILL,RCSPLIT,RCERA,SRC,ORIG) ;EP from RCDPEM and RCDPEMA
; Automatic move copy of EOB
; Input: OBILL - Original Bill number in #399
; RCSPLIT - Array of split lines
; RCERA - ERA ien #344.4
; SRC - "W" = Worklist "A" = APAR/Autopost
; ORIG - IEN of EOB in file #361.1
; Output - Update EOBs and audit trail
N CCLAIM,FLAG,IFN,J,NCLAIM,NBILL,JUST,JUST1,SUB,SUB1,VALID ; PRCA*4.5*332
; EOB for the original claim must be present
I 'ORIG Q 1
S (SUB,SUB1)=0,VALID=1 ; ; PRCA*4.5*332
F J="O","N","S" S FLAG(J)=0 ; PRCA*4.5*332 Initialize flags for original, new and suspense EEOBs
; Loop through split lines
F S SUB=$O(RCSPLIT(SUB)) Q:'SUB D
. ; Bill Number on split line
. S NBILL=$P(RCSPLIT(SUB),U,2)
. S IFN=$P(RCSPLIT(SUB),U,7) ; PRCA*4.5*332
. ; Ignore split lines with zero value
. Q:+$P(RCSPLIT(SUB),U,3)=0
. ; Suspense claims, piece 7 is pointer to AR claim file 430
. I 'IFN S FLAG("S")=1 Q ; PRCA*4.5*332
. ; Is original bill is in the array?
. I OBILL=NBILL S FLAG("O")=1 ; PRCA*4.5*332
. ; Save POINTER to AR Claim file 430 (DINUM to 399)
. S SUB1=SUB1+1,NCLAIM(SUB1)=IFN
. ; Build list of new claims to copy
. I OBILL'=NBILL D ; PRCA*4.5*332
. . S CCLAIM(IFN)=IFN ; PRCA*4.5*332
. . S FLAG("N")=1 ; PRCA*4.5*332
;
; No new claims. Payment must have been split to suspense, or suspense and original payment - no action
I 'FLAG("N") Q 1 ; PRCA*4.5*332
;
; Lock Original EOB
I '$$LOCK(ORIG) Q 0
;
; PRCA*4.5*332 - Start modified code block
; If split to single new claim move EOB - i.e. change claim number on EOB
I SUB1=1,'FLAG("S") D ;
. ; Change claim number on original EOB attached to ERA
. D AUTOMOVE(ORIG,.NCLAIM,SRC) ; PRCA*4.5*332
;
; Split was to multiple new claims or new claim(s) and suspense - copy original EOB to new claim(s)
E D ;
. ; Copy EOB to new EOBs for "to" claims
. D AUTOCOPY(ORIG,.CCLAIM,SRC) ; PRCA*4.5*332
. ; If no money went to suspense or the original EOB
. ; mark original EOB removed but with text of 'copied to claims....'
. I 'FLAG("O"),'FLAG("S") D ;
. . S JUST=$$JUST(ORIG,.CCLAIM,"C",0,SRC)_" then removed"
. . D AUTOREM(ORIG,JUST)
; PRCA*4.5*332 - End modified code block
;
D UNLOCK(ORIG)
Q 1
;
AUTOREM(ORIG,JUST) ;Silent remove of EEOB where entire payment is suspensed or moved to other claims
; Input - ORIG = EOB in #361.1
; JUST = Justification text
; Output - Update EOB in #361.1 and audit trail
;
;Lock Original EOB
I '$$LOCK(ORIG) Q
;Update EEOB
D REMOVE^IBCEOB4(ORIG,DUZ,JUST)
;Update AR Comments for removed claim
D AUDIT^RCDPAYER(ORIG,JUST,"R")
;Unlock original EOB
D UNLOCK(ORIG)
;
Q
;
AUTOCOPY(ORIG,CCLAIM,SRC) ; EP from RCDPEU2 - Copy EOBs and upate AR TRANSACTION file - PRCA*4.5*332
; Input: ORIG - IEN for file 361.1 of original EOB
; CCLAIM - Array of claims to copy to
; SRC - "W" = Worklist "A" = APAR/Autopost "L" = Link Payments
N JUST,JUST1,MODE,SUB,NEWEOB
S MODE=$S(SRC="L":"L",1:"W")
S JUST=$$JUST(ORIG,.CCLAIM,"C",0,SRC) ; Text for original EEOB (copied to claims x,y,z - then removed)
S JUST1=$$JUST(ORIG,.CCLAIM,"C",1,SRC) ; Text for copied to EEOB (copied from claim w)
; Copy EOB to new EOBs for "to" claims
D COPY^IBCEOB4(ORIG,.CCLAIM,DUZ,$$NOW^XLFDT,JUST1,"C")
;
; Auto generate text for AR comments on original claim
D AUDIT^RCDPAYER(ORIG,JUST,MODE)
; Auto generate text for AR comments on new claim
S SUB=0
F S SUB=$O(CCLAIM(SUB)) Q:'SUB D
. ; Convert Claim pointer to EOB pointer
. S NEWEOB=$O(^IBM(361.1,"B",CCLAIM(SUB),""),-1) Q:'NEWEOB
. D AUDIT^RCDPAYER(NEWEOB,JUST1,MODE)
Q
;
AUTOMOVE(ORIG,NCLAIM,SRC) ; EP from RCDPEU2 - Move EOB from one claim to another PRCA*4.5*332
; Input: ORIG - IEN for file 361.1 of original EOB
; NCLAIM - Array of new claims
; SRC - "W" = Worklist "A" = APAR/Autopost "L" = Link Payments
N JUST,JUST1,MODE,SUB
S MODE=$S(SRC="L":"L",1:"W")
S JUST=$$JUST(ORIG,.NCLAIM,"M",0,SRC) ;Just. Text for original claim
S JUST1=$$JUST(ORIG,.NCLAIM,"M",1,SRC) ;Just. Text for new claim
; Update AR Transaction for original claim
D AUDIT^RCDPAYER(ORIG,JUST,MODE)
; Change claim number on original EOB attached to ERA
D MOVE^IBCEOB4(ORIG,NCLAIM(1),DUZ,$$NOW^XLFDT,JUST,"M")
; Update AR Transaction for new claim
D AUDIT^RCDPAYER(ORIG,JUST1,MODE)
Q
;
;Read access to file #361.1 under IA 4051
LOCK(EOBIEN) ;Lock Original EOB
L +^IBM(361.1,EOBIEN):5 I Q 1
Q 0
;
UNLOCK(EOBIEN) ;Release EOB
L -^IBM(361.1,EOBIEN)
Q
; END PRCA*4.5*321
;
;US1394 ADDITIONS - EP RCDPRPL1 and RCDPLPL3
EEOB(RCRCPT,RCTRANDA) ; Option to restore associated suspended/removed EEOB
;
; INPUT - RCRCPT - Receipt ien #344
; - RCTRANDA - Receipt line #344.01
;
; OUTPUT - RCEEOB - selected EEOB ien #361.1
; or 0 if no EEOB
; or -1 if ^ abort
;
N CLAIM,DIROUT,DTOUT,DUOUT,RCEEOB,RCEEOBH,RCERA,RCLINE
; Get new claim IEN from receipt line
S CLAIM=$$GET1^DIQ(344.01,RCTRANDA_","_RCRCPT_",",.09,"I")
; Quit if this is not a third party claim payment
Q:CLAIM'["PRCA" 0
; Check if ERA has a suspended EEOB for this line
S RCEEOB=$$SUSP(RCRCPT,RCTRANDA,.RCERA,.RCLINE)
; If no suspended EEOB skip prompt
Q:'RCEEOB 0
;
; Get last move/copy history record - Read access to file #361.1 under IA 4051
S RCEEOBH=$O(^IBM(361.1,RCEEOB,101,"A"),-1)
; Quit if EEOB if no history found - should not occur since EEOB is suspended
Q:'RCEEOBH 0
; Display EOB detail
W !!,"This claim has an associated EEOB on ERA "_RCERA
W !!,"Claim Number : ",$$GET1^DIQ(344.41,RCLINE_","_RCERA,.02,"E")
W !,"Trace Number : ",$$GET1^DIQ(344.4,RCERA,.02,"E")
W !,"Total Amount Paid: ",$$GET1^DIQ(361.1,RCEEOB,1.01,"E")
W !,"Date/Time Removed: ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.01,"E")
W !,"Removed by : ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.02,"E")
W !,"Justification : ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.03,"E"),!
;
; Confirm that this is the correct EEOB
K DIR
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Is this the correct EEOB to associate with this claim"
D ^DIR
I $G(DTOUT)!($G(DUOUT)) Q -1
Q:Y'=1 0
;
;Return selected EEOB
Q RCEEOB
;
SUSP(RCRCPT,RCTRANDA,RCERA,RCLINE) ; Identify suspended EEOB
;
; INPUT - RCRCPT - Receipt ien #344
; - RCTRANDA - Receipt line #344.01
;
; OUTPUT - RCEEOB - selected EEOB ien #361.1
; - RCERA - ERA ien #344.4
; - RCLINE - ERA line #344.41;
;
N RCEEOB,RCORIG,RCRCZ,RCSPLIT
; Get ERA from receipt
S RCERA=$$GET1^DIQ(344,RCRCPT_",",.18,"I")
; Quit if no ERA
Q:'RCERA 0
; Get ERA Scratchpad line
S RCRCZ=$$GET1^DIQ(344.01,RCTRANDA_","_RCRCPT_",",.27,"I")
; Quit if ERA scratchpad line missing
Q:'RCRCZ 0
; Get the original line sequence number from before the split was performed
S RCSPLIT=$$GET1^DIQ(344.491,RCRCZ_","_RCERA_",",.01),RCORIG=RCSPLIT\1
; Convert sequence number into original line IEN
S RCORIG=$O(^RCY(344.49,RCERA,1,"ASEQ",RCORIG,""))
; Quit if original scratchpad line not found
Q:'RCORIG 0
; Get ERA line from original scratchpad line
S RCLINE=$$GET1^DIQ(344.491,RCORIG_","_RCERA_",",.09,"I")
; Quit if ERA line not found
Q:'RCLINE 0
; Get EEOB from ERA line
S RCEEOB=$$GET1^DIQ(344.41,RCLINE_","_RCERA_",",.02,"I")
; Quit if ERA line pointer to EEOB is missing
Q:'RCEEOB 0
; Ignore EEOB if status is not removed - read access to file #361.1 under IA 4051
Q:$$GET1^DIQ(361.1,RCEEOB_",",102,"I")'=1 0
; Return suspended EEOB IEN
Q RCEEOB
;
; EP RCDPRPL1 and RCDPLPL3
RESTORE(RCPTDA,RCTRANDA,ORIG,SRC) ; Change bill number on EOB and clear 'removed' status
;
; INPUT - RCPTDA - Receipt ien #344
; - RCTRANDA - Receipt line #344.01
; - ORIG - EOB ien #361.1
; - SRC - 'L' - Link Payments 'R' - Receipt Porcessing
;
Q:'$$LOCK^IBCEOB4(ORIG)
;
W !,"Updating EEOB...."
;
N NCLAIM,JUST
; Get new claim IEN from receipt line
S NCLAIM=$P($$GET1^DIQ(344.01,RCTRANDA_","_RCPTDA_",",.09,"I"),";")
; Set up justification text
S JUST="EEOB restored from suspense in "_$S(SRC="L":"Link Payments",SRC="R":"Edit Payments",1:"Other")
; Update AR comments on 'from claim'
D AUDIT^RCDPAYER(ORIG,JUST,"W")
; Change claim number on EOB
D MOVE^IBCEOB4(ORIG,NCLAIM,DUZ,$$NOW^XLFDT,JUST,"M")
; Reset EEOB REMOVED status
D RESTORE^IBCEOB4(ORIG)
;Unlock EOB
D UNLOCK^IBCEOB4(ORIG)
;
H 1 W "done"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEM5 17742 printed Sep 23, 2025@19:20:52 Page 2
RCDPEM5 ;ALB/PJH - EPAYMENTS MOVE EEOB TO NEW CLAIM ;Oct 29, 2014@16:43:51
+1 ;;4.5;Accounts Receivable;**173,208,276,298,321,332**;Mar 20, 1995;Build 40
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ;Entry point for EEOB Move/Copy/Remove [RCDPE EEOB MOVE/COPY/REMOVE] option
+1 ;
+2 NEW DIR,X,Y,DIROUT,DUOUT,MODE
+3 SET DIR("A")="Select action"
+4 SET DIR("B")="M"
+5 SET DIR(0)="S^M:Move EEOB to different claim;"
+6 SET DIR(0)=DIR(0)_"C:Copy EEOB to multiple claims;"
+7 SET DIR(0)=DIR(0)_"R:Remove EEOB from claim"
+8 DO ^DIR
if $GET(DIROUT)!$GET(DUOUT)
QUIT
+9 SET MODE=Y
+10 ;
+11 ; - PRCA*4.5*298 - OWNSKEY^XUSRB - Supported IA 3277
+12 IF MODE="R"
NEW MSG
DO OWNSKEY^XUSRB(.MSG,"RCDPE REMOVE EEOB",DUZ)
IF 'MSG(0)
Begin DoDot:1
+13 WRITE !!,"SORRY, YOU ARE NOT AUTHORIZED TO USE THIS ACTION"
+14 WRITE !,"This action is locked with RCDPE REMOVE EEOB key.",!
+15 NEW DIR
SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+16 ;
+17 ;Read access to file #361.1 under IA 4051
+18 ;
+19 NEW DA,DIC,DIE,DIR,DR,NCLAIM,ORIG,ORIGNAM,X,Y
+20 ;
+21 ;Allow selection of a original third party EOB
+22 SET DIC("A")="Select EXPLANATION OF BENEFIT (EEOB) to "_$SELECT(MODE="M":"MOVE",MODE="R":"REMOVE",1:"COPY")_": "
+23 ; screen to only allow selection of an active EEOB (not marked as deleted) and non-MRA type EOB
+24 SET DIC("S")="I ($P(^(0),U,4)=0)&('$P($G(^(102)),U))"
SET DIC="^IBM(361.1,"
SET DIC(0)="AEMQ"
+25 WRITE !
DO ^DIC
KILL DIC
+26 ;
+27 IF Y'>0
QUIT
+28 ; controlled subscription IA 1992
+29 SET ORIG=+Y
SET ORIGNAM=$$GET1^DIQ(399,$PIECE(Y,U,2),.01)
+30 ;
+31 ;Get current bill payer sequence from claim - IA 3820
+32 Begin DoDot:1
+33 NEW CURR,IEN399
+34 SET IEN399=$PIECE($GET(^IBM(361.1,ORIG,0)),U)
if 'IEN399
QUIT
+35 SET CURR=$PIECE($GET(^DGCR(399,IEN399,0)),U,21)
IF (CURR'="T")&(CURR'="S")
QUIT
+36 WRITE !!,"Warning - selected EEOB has secondary claims and may have tertiary claims"
End DoDot:1
+37 ;
+38 ;Lock Original EOB
+39 if '$$LOCK^IBCEOB4(ORIG)
QUIT
+40 ;
+41 ;Remove Option
+42 IF MODE="R"
DO REMOVE(ORIG,MODE)
DO EXIT
QUIT
+43 ;
+44 ;Select Claim(s) to Move/Copy to
+45 NEW RCBILL,RCBILLNM,NCLAIM,NCLAIMX,QUIT,SUB,LIT
+46 SET SUB=0
SET QUIT=0
SET LIT=""
+47 WRITE !
+48 FOR
Begin DoDot:1
+49 ;Allow selection of a third party claim
+50 IF MODE="M"
SET DIC("A")="Select A/R Bill to MOVE to: "
+51 IF MODE="C"
SET DIC("A")="Select "_LIT_"A/R Bill to COPY to: "
+52 SET DIC="^PRCA(430,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^DGCR(399,+Y,0))&($$VALSTAT^RCDPEM5(+Y))"
+53 DO ^DIC
KILL DIC
+54 IF Y'>0
SET QUIT=1
QUIT
+55 SET RCBILL=+Y
SET RCBILLNM=$PIECE($PIECE(Y,U,2),"-",2)
+56 IF ORIGNAM=RCBILLNM
IF MODE="M"
WRITE !,"Cannot move EEOB to same claim"
QUIT
+57 IF $DATA(NCLAIMX(RCBILL))
WRITE !,"Claim already entered"
QUIT
+58 SET SUB=SUB+1
SET NCLAIM(SUB)=RCBILL
SET NCLAIMX(RCBILL)=""
+59 if MODE="C"
SET LIT="another "
End DoDot:1
if QUIT
QUIT
if SUB&(MODE="M")
QUIT
+60 ;
+61 IF $GET(DUOUT)!$GET(DIROUT)
DO EXIT
QUIT
+62 ;
+63 ;User Exit or no claims selected
+64 IF '$ORDER(NCLAIM(""))
DO EXIT
QUIT
+65 ;
+66 ;Prompt user to continue
+67 NEW DIR,X,Y,DIROUT
+68 SET DIR(0)="Y"
SET DIR("B")="YES"
+69 SET DIR("A")=$$PROMPT(ORIG,.NCLAIM,MODE)
+70 WRITE !
DO ^DIR
+71 ;
+72 IF $GET(DIROUT)!$GET(DUOUT)!(Y=0)
DO EXIT
QUIT
+73 ;
+74 ;Enter Justification Comment
+75 NEW DIR,DIROUT,DUOUT,JCOM,X,Y
+76 SET DIR(0)="FA^1:100^K:$TR(X,"" "","""")="""" X"
SET DIR("A")="Enter JUSTIFICATION COMMENT: "
+77 WRITE !
DO ^DIR
IF $GET(DIROUT)!$GET(DUOUT)
WRITE !!,"Update not performed"
DO EXIT
QUIT
+78 SET JCOM=Y
+79 ;
+80 ;Update EOB
+81 DO UPDATE(ORIG,.NCLAIM,MODE,JCOM)
DO EXIT
+82 ;
+83 QUIT
+84 ;
+85 ;Unlock original EOB
EXIT DO UNLOCK^IBCEOB4(ORIG)
+1 QUIT
+2 ;
+3 ;File EOB #361.1 changes - Integration Agreement 5671 for IBCEOB4
UPDATE(ORIG,NCLAIM,MODE,JUST) ;
+1 ; Input - ORIG - Original EOB
+2 ; - NCLAIM - New claim (s)
+3 ; - MODE M=Move C=Copy
+4 ; - JUST = User input justification text
+5 ; Output - Updates EOB and Audit log
+6 NEW JUST1
+7 ;Move EOB
+8 IF MODE="M"
Begin DoDot:1
+9 ;Auto generate text for AR comments on original claim
+10 SET JUST1=$$JUST1(ORIG,.NCLAIM,"M",0)
+11 ;Update AR Comments on the 'from bill'
+12 DO AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
+13 ;Change claim number on EEOB
+14 DO MOVE^IBCEOB4(ORIG,NCLAIM(1),DUZ,$$NOW^XLFDT,JUST,MODE)
+15 ;Update AR Comments on 'to bill'
+16 DO AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
End DoDot:1
+17 ;Copy EOB
+18 IF MODE="C"
Begin DoDot:1
+19 DO COPY^IBCEOB4(ORIG,.NCLAIM,DUZ,$$NOW^XLFDT,JUST,MODE)
+20 ;Auto generate text for AR comments on original claim
+21 SET JUST1=$$JUST1(ORIG,.NCLAIM,"C",0)
+22 ;Update AR Comments on original claim
+23 DO AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
+24 ;Auto generate text for AR comments on new claim
+25 SET JUST1=$$JUST1(ORIG,.NCLAIM,"C",1)
+26 ;Update AR Comments on new claims
+27 NEW SUB,NEWEOB
+28 SET SUB=0
+29 FOR
SET SUB=$ORDER(NCLAIM(SUB))
if 'SUB
QUIT
Begin DoDot:2
+30 ;Convert Claim pointer to EOB pointer
+31 SET NEWEOB=$ORDER(^IBM(361.1,"B",NCLAIM(SUB),0))
if 'NEWEOB
QUIT
+32 DO AUDIT^RCDPAYER(NEWEOB,JUST_"^"_JUST1,MODE)
End DoDot:2
End DoDot:1
+33 WRITE !!,"EEOB Update Complete"
HANG 1
+34 QUIT
+35 ;
PROMPT(ORIG,NCLAIM,MODE) ;Construct prompt text
+1 ; Input - ORIG - Original EOB
+2 ; - NCLAIM - New claim (s)
+3 ; - MODE M=Move C=Copy
+4 ; Output - Justification text
+5 ;
+6 NEW FIRST,STR,STR1,SUB,TEXT
+7 ;Move or copy text
+8 SET TEXT=$$EXTERNAL^DILFD(361.1,.01,,$PIECE($GET(^IBM(361.1,ORIG,0)),U))
+9 IF MODE="M"
SET STR="Move EEOB from claim "_TEXT_" to claim "
+10 IF '$TEST
SET STR="Copy EEOB from claim "_TEXT_" to claim(s) "
+11 ;Build list of claims
+12 SET STR1=""
SET SUB=""
SET FIRST=1
+13 FOR
SET SUB=$ORDER(NCLAIM(SUB))
if 'SUB
QUIT
Begin DoDot:1
+14 SET TEXT=$PIECE($GET(^PRCA(430,NCLAIM(SUB),0)),U)
+15 IF FIRST
SET STR1=STR1_$PIECE(TEXT,"-",2)
SET FIRST=0
QUIT
+16 SET STR1=STR1_", "_$PIECE(TEXT,"-",2)
End DoDot:1
+17 ;Return full prompt text
+18 QUIT STR_STR1_" "
+19 ;
JUST(ORIG,NCLAIM,MODE,TYPE,SRC) ;Construct justification text for automatic updates
+1 ; Input - ORIG - Original EOB
+2 ; - NCLAIM - New claim (s)
+3 ; - MODE - "M" = Move "C" =Copy "R" = Remove
+4 ; - TYPE - 0 = old EOB 1 = new EOB
+5 ; - SRC - "W" = Worklist "A" = Auto-post, "L" = Link Payment
+6 ; Output - Justification text
+7 NEW FIRST,STR,STR1,SUB,TEXT
+8 ;Original bill number
+9 SET TEXT=$$EXTERNAL^DILFD(361.1,.01,,$PIECE($GET(^IBM(361.1,ORIG,0)),U))
+10 ;Justification comment for original EOB
+11 IF TYPE=0
Begin DoDot:1
+12 ;PRCA*4.5*321
IF MODE="R"
SET STR="EEOB removed from claim "_TEXT
SET STR1=""
QUIT
+13 IF MODE="M"
SET STR="EEOB from claim "_TEXT_" moved to claim "
+14 IF MODE="C"
SET STR="EEOB from claim "_TEXT_" copied to claim(s) "
+15 ;Build list of claims
+16 SET STR1=""
SET SUB=""
SET FIRST=1
+17 FOR
SET SUB=$ORDER(NCLAIM(SUB))
if 'SUB
QUIT
Begin DoDot:2
+18 SET TEXT=$PIECE($GET(^PRCA(430,NCLAIM(SUB),0)),U)
+19 IF FIRST
SET STR1=STR1_$PIECE(TEXT,"-",2)
SET FIRST=0
QUIT
+20 SET STR1=STR1_", "_$PIECE(TEXT,"-",2)
End DoDot:2
End DoDot:1
+21 ;Justification comment for new EOB's
+22 IF TYPE=1
Begin DoDot:1
+23 IF MODE="M"
SET STR="EEOB moved from EEOB for claim "_TEXT
SET STR1=""
+24 IF MODE="C"
SET STR="EEOB copied from EEOB for claim "_TEXT
SET STR1=""
End DoDot:1
+25 ;Return full justification text
+26 QUIT STR_STR1_" automatically by "_$SELECT(SRC="A":"Auto-post",SRC="L":"Link Payment",1:"Worklist")
+27 ;
JUST1(ORIG,NCLAIM,MODE,TYPE) ;Construct AR comment for stand-alone MCR option
+1 ; Input - ORIG - Original EOB
+2 ; - NCLAIM - New claim (s)
+3 ; - MODE M=Move C=Copy
+4 ; - TYPE = 0 - original EOB 1 - new EOB(s)
+5 ; Output - Justification text
+6 NEW FIRST,STR,STR1,SUB,TEXT
+7 ;Original bill number
+8 SET TEXT=$$EXTERNAL^DILFD(361.1,.01,,$PIECE($GET(^IBM(361.1,ORIG,0)),U))
+9 ;Justification comment for original EOB
+10 IF TYPE=0
Begin DoDot:1
+11 IF MODE="M"
SET STR="EEOB from claim "_TEXT_" moved to claim "
+12 IF MODE="C"
SET STR="EEOB from claim "_TEXT_" copied to claim(s) "
+13 ;Build list of claims
+14 SET STR1=""
SET SUB=""
SET FIRST=1
+15 FOR
SET SUB=$ORDER(NCLAIM(SUB))
if 'SUB
QUIT
Begin DoDot:2
+16 SET TEXT=$PIECE($GET(^PRCA(430,NCLAIM(SUB),0)),U)
+17 IF FIRST
SET STR1=STR1_$PIECE(TEXT,"-",2)
SET FIRST=0
QUIT
+18 SET STR1=STR1_", "_$PIECE(TEXT,"-",2)
End DoDot:2
End DoDot:1
+19 ;Justification comment for new EOB's
+20 IF TYPE=1
Begin DoDot:1
+21 IF MODE="M"
SET STR="EEOB moved from EEOB for claim "_TEXT
SET STR1=""
+22 IF MODE="C"
SET STR="EEOB copied from EEOB for claim "_TEXT
SET STR1=""
End DoDot:1
+23 ;Return comment text
+24 QUIT STR_STR1
+25 ;
FINDEOB(IEN3444,BILL) ;Find EOB for a claim within an ERA
+1 ; Input - IEN3444 = ERA ien
+2 ; BILL = Bill number
+3 ; Output - IEN of EOB in #361.1
+4 NEW IEN3611,SUB
+5 SET (SUB,IEN3611)=0
+6 FOR
SET SUB=$ORDER(^RCY(344.4,IEN3444,1,"AC",SUB))
if 'SUB
QUIT
Begin DoDot:1
+7 IF $$EXTERNAL^DILFD(344.41,.02,,SUB)=BILL
SET IEN3611=SUB
End DoDot:1
if IEN3611
QUIT
+8 QUIT IEN3611
+9 ;
REMOVE(ORIG,MODE) ; Interactive option to Remove EEOB - PRCA*4.5*298
+1 ; Input - ORIG = original EOB in #361.1
+2 ; Output - mode = "R"
+3 ;
+4 ;Prompt user to continue
+5 NEW DIR,X,Y,DIROUT
+6 SET DIR(0)="Y"
SET DIR("B")="YES"
+7 SET DIR("A")="Are you sure you want to remove EEOB from claim "_ORIGNAM_" (Y/N)?"
+8 WRITE !
DO ^DIR
+9 ;
+10 IF $GET(DIROUT)!$GET(DUOUT)!(Y=0)
QUIT
+11 ;
+12 ;Enter Justification Comment
+13 NEW DIR,DIROUT,DUOUT,JUST,X,Y
+14 SET DIR(0)="FA^1:100^K:$TR(X,"" "","""")="""" X"
SET DIR("A")="Enter JUSTIFICATION COMMENT: "
+15 WRITE !
DO ^DIR
IF $GET(DIROUT)!$GET(DUOUT)
WRITE !!,"Update not performed"
DO EXIT
QUIT
+16 SET JUST=Y
+17 ;
+18 ;Update EEOB
+19 DO REMOVE^IBCEOB4(ORIG,DUZ,JUST)
+20 ;Update AR Comments for removed claim
+21 DO AUDIT^RCDPAYER(ORIG,JUST,MODE)
+22 ;
+23 WRITE !!,"EEOB Update Complete"
HANG 1
+24 QUIT
+25 ;
VALSTAT(CLIEN) ; validation on current status of the AR claim selected for the move/copy event
+1 ; Claims that are in a incomplete state cannot be selected
+2 ; incomplete states are determined at CURRENT STATUS (8,430) of the AR claim
+3 ; AR claims with 'BILL INCOMPLETE', 'INCOMPLETE', 'NEW BILL' statuses cannot be selected
+4 ; CLIEN=430 ien
+5 ; returns 0 or 1
+6 NEW CSTAT,FLAG
+7 SET CSTAT=$$GET1^DIQ(430,CLIEN,8)
+8 SET FLAG=$SELECT(CSTAT="BILL INCOMPLETE":0,CSTAT="INCOMPLETE":0,CSTAT="NEW BILL":0,1:1)
+9 QUIT FLAG
+10 ;
+11 ; BEGIN - PRCA*4.5*321
AUTO(OBILL,RCSPLIT,RCERA,SRC,ORIG) ;EP from RCDPEM and RCDPEMA
+1 ; Automatic move copy of EOB
+2 ; Input: OBILL - Original Bill number in #399
+3 ; RCSPLIT - Array of split lines
+4 ; RCERA - ERA ien #344.4
+5 ; SRC - "W" = Worklist "A" = APAR/Autopost
+6 ; ORIG - IEN of EOB in file #361.1
+7 ; Output - Update EOBs and audit trail
+8 ; PRCA*4.5*332
NEW CCLAIM,FLAG,IFN,J,NCLAIM,NBILL,JUST,JUST1,SUB,SUB1,VALID
+9 ; EOB for the original claim must be present
+10 IF 'ORIG
QUIT 1
+11 ; ; PRCA*4.5*332
SET (SUB,SUB1)=0
SET VALID=1
+12 ; PRCA*4.5*332 Initialize flags for original, new and suspense EEOBs
FOR J="O","N","S"
SET FLAG(J)=0
+13 ; Loop through split lines
+14 FOR
SET SUB=$ORDER(RCSPLIT(SUB))
if 'SUB
QUIT
Begin DoDot:1
+15 ; Bill Number on split line
+16 SET NBILL=$PIECE(RCSPLIT(SUB),U,2)
+17 ; PRCA*4.5*332
SET IFN=$PIECE(RCSPLIT(SUB),U,7)
+18 ; Ignore split lines with zero value
+19 if +$PIECE(RCSPLIT(SUB),U,3)=0
QUIT
+20 ; Suspense claims, piece 7 is pointer to AR claim file 430
+21 ; PRCA*4.5*332
IF 'IFN
SET FLAG("S")=1
QUIT
+22 ; Is original bill is in the array?
+23 ; PRCA*4.5*332
IF OBILL=NBILL
SET FLAG("O")=1
+24 ; Save POINTER to AR Claim file 430 (DINUM to 399)
+25 SET SUB1=SUB1+1
SET NCLAIM(SUB1)=IFN
+26 ; Build list of new claims to copy
+27 ; PRCA*4.5*332
IF OBILL'=NBILL
Begin DoDot:2
+28 ; PRCA*4.5*332
SET CCLAIM(IFN)=IFN
+29 ; PRCA*4.5*332
SET FLAG("N")=1
End DoDot:2
End DoDot:1
+30 ;
+31 ; No new claims. Payment must have been split to suspense, or suspense and original payment - no action
+32 ; PRCA*4.5*332
IF 'FLAG("N")
QUIT 1
+33 ;
+34 ; Lock Original EOB
+35 IF '$$LOCK(ORIG)
QUIT 0
+36 ;
+37 ; PRCA*4.5*332 - Start modified code block
+38 ; If split to single new claim move EOB - i.e. change claim number on EOB
+39 ;
IF SUB1=1
IF 'FLAG("S")
Begin DoDot:1
+40 ; Change claim number on original EOB attached to ERA
+41 ; PRCA*4.5*332
DO AUTOMOVE(ORIG,.NCLAIM,SRC)
End DoDot:1
+42 ;
+43 ; Split was to multiple new claims or new claim(s) and suspense - copy original EOB to new claim(s)
+44 ;
IF '$TEST
Begin DoDot:1
+45 ; Copy EOB to new EOBs for "to" claims
+46 ; PRCA*4.5*332
DO AUTOCOPY(ORIG,.CCLAIM,SRC)
+47 ; If no money went to suspense or the original EOB
+48 ; mark original EOB removed but with text of 'copied to claims....'
+49 ;
IF 'FLAG("O")
IF 'FLAG("S")
Begin DoDot:2
+50 SET JUST=$$JUST(ORIG,.CCLAIM,"C",0,SRC)_" then removed"
+51 DO AUTOREM(ORIG,JUST)
End DoDot:2
End DoDot:1
+52 ; PRCA*4.5*332 - End modified code block
+53 ;
+54 DO UNLOCK(ORIG)
+55 QUIT 1
+56 ;
AUTOREM(ORIG,JUST) ;Silent remove of EEOB where entire payment is suspensed or moved to other claims
+1 ; Input - ORIG = EOB in #361.1
+2 ; JUST = Justification text
+3 ; Output - Update EOB in #361.1 and audit trail
+4 ;
+5 ;Lock Original EOB
+6 IF '$$LOCK(ORIG)
QUIT
+7 ;Update EEOB
+8 DO REMOVE^IBCEOB4(ORIG,DUZ,JUST)
+9 ;Update AR Comments for removed claim
+10 DO AUDIT^RCDPAYER(ORIG,JUST,"R")
+11 ;Unlock original EOB
+12 DO UNLOCK(ORIG)
+13 ;
+14 QUIT
+15 ;
AUTOCOPY(ORIG,CCLAIM,SRC) ; EP from RCDPEU2 - Copy EOBs and upate AR TRANSACTION file - PRCA*4.5*332
+1 ; Input: ORIG - IEN for file 361.1 of original EOB
+2 ; CCLAIM - Array of claims to copy to
+3 ; SRC - "W" = Worklist "A" = APAR/Autopost "L" = Link Payments
+4 NEW JUST,JUST1,MODE,SUB,NEWEOB
+5 SET MODE=$SELECT(SRC="L":"L",1:"W")
+6 ; Text for original EEOB (copied to claims x,y,z - then removed)
SET JUST=$$JUST(ORIG,.CCLAIM,"C",0,SRC)
+7 ; Text for copied to EEOB (copied from claim w)
SET JUST1=$$JUST(ORIG,.CCLAIM,"C",1,SRC)
+8 ; Copy EOB to new EOBs for "to" claims
+9 DO COPY^IBCEOB4(ORIG,.CCLAIM,DUZ,$$NOW^XLFDT,JUST1,"C")
+10 ;
+11 ; Auto generate text for AR comments on original claim
+12 DO AUDIT^RCDPAYER(ORIG,JUST,MODE)
+13 ; Auto generate text for AR comments on new claim
+14 SET SUB=0
+15 FOR
SET SUB=$ORDER(CCLAIM(SUB))
if 'SUB
QUIT
Begin DoDot:1
+16 ; Convert Claim pointer to EOB pointer
+17 SET NEWEOB=$ORDER(^IBM(361.1,"B",CCLAIM(SUB),""),-1)
if 'NEWEOB
QUIT
+18 DO AUDIT^RCDPAYER(NEWEOB,JUST1,MODE)
End DoDot:1
+19 QUIT
+20 ;
AUTOMOVE(ORIG,NCLAIM,SRC) ; EP from RCDPEU2 - Move EOB from one claim to another PRCA*4.5*332
+1 ; Input: ORIG - IEN for file 361.1 of original EOB
+2 ; NCLAIM - Array of new claims
+3 ; SRC - "W" = Worklist "A" = APAR/Autopost "L" = Link Payments
+4 NEW JUST,JUST1,MODE,SUB
+5 SET MODE=$SELECT(SRC="L":"L",1:"W")
+6 ;Just. Text for original claim
SET JUST=$$JUST(ORIG,.NCLAIM,"M",0,SRC)
+7 ;Just. Text for new claim
SET JUST1=$$JUST(ORIG,.NCLAIM,"M",1,SRC)
+8 ; Update AR Transaction for original claim
+9 DO AUDIT^RCDPAYER(ORIG,JUST,MODE)
+10 ; Change claim number on original EOB attached to ERA
+11 DO MOVE^IBCEOB4(ORIG,NCLAIM(1),DUZ,$$NOW^XLFDT,JUST,"M")
+12 ; Update AR Transaction for new claim
+13 DO AUDIT^RCDPAYER(ORIG,JUST1,MODE)
+14 QUIT
+15 ;
+16 ;Read access to file #361.1 under IA 4051
LOCK(EOBIEN) ;Lock Original EOB
+1 LOCK +^IBM(361.1,EOBIEN):5
IF $TEST
QUIT 1
+2 QUIT 0
+3 ;
UNLOCK(EOBIEN) ;Release EOB
+1 LOCK -^IBM(361.1,EOBIEN)
+2 QUIT
+3 ; END PRCA*4.5*321
+4 ;
+5 ;US1394 ADDITIONS - EP RCDPRPL1 and RCDPLPL3
EEOB(RCRCPT,RCTRANDA) ; Option to restore associated suspended/removed EEOB
+1 ;
+2 ; INPUT - RCRCPT - Receipt ien #344
+3 ; - RCTRANDA - Receipt line #344.01
+4 ;
+5 ; OUTPUT - RCEEOB - selected EEOB ien #361.1
+6 ; or 0 if no EEOB
+7 ; or -1 if ^ abort
+8 ;
+9 NEW CLAIM,DIROUT,DTOUT,DUOUT,RCEEOB,RCEEOBH,RCERA,RCLINE
+10 ; Get new claim IEN from receipt line
+11 SET CLAIM=$$GET1^DIQ(344.01,RCTRANDA_","_RCRCPT_",",.09,"I")
+12 ; Quit if this is not a third party claim payment
+13 if CLAIM'["PRCA"
QUIT 0
+14 ; Check if ERA has a suspended EEOB for this line
+15 SET RCEEOB=$$SUSP(RCRCPT,RCTRANDA,.RCERA,.RCLINE)
+16 ; If no suspended EEOB skip prompt
+17 if 'RCEEOB
QUIT 0
+18 ;
+19 ; Get last move/copy history record - Read access to file #361.1 under IA 4051
+20 SET RCEEOBH=$ORDER(^IBM(361.1,RCEEOB,101,"A"),-1)
+21 ; Quit if EEOB if no history found - should not occur since EEOB is suspended
+22 if 'RCEEOBH
QUIT 0
+23 ; Display EOB detail
+24 WRITE !!,"This claim has an associated EEOB on ERA "_RCERA
+25 WRITE !!,"Claim Number : ",$$GET1^DIQ(344.41,RCLINE_","_RCERA,.02,"E")
+26 WRITE !,"Trace Number : ",$$GET1^DIQ(344.4,RCERA,.02,"E")
+27 WRITE !,"Total Amount Paid: ",$$GET1^DIQ(361.1,RCEEOB,1.01,"E")
+28 WRITE !,"Date/Time Removed: ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.01,"E")
+29 WRITE !,"Removed by : ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.02,"E")
+30 WRITE !,"Justification : ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.03,"E"),!
+31 ;
+32 ; Confirm that this is the correct EEOB
+33 KILL DIR
+34 SET DIR(0)="YO"
SET DIR("B")="NO"
+35 SET DIR("A")="Is this the correct EEOB to associate with this claim"
+36 DO ^DIR
+37 IF $GET(DTOUT)!($GET(DUOUT))
QUIT -1
+38 if Y'=1
QUIT 0
+39 ;
+40 ;Return selected EEOB
+41 QUIT RCEEOB
+42 ;
SUSP(RCRCPT,RCTRANDA,RCERA,RCLINE) ; Identify suspended EEOB
+1 ;
+2 ; INPUT - RCRCPT - Receipt ien #344
+3 ; - RCTRANDA - Receipt line #344.01
+4 ;
+5 ; OUTPUT - RCEEOB - selected EEOB ien #361.1
+6 ; - RCERA - ERA ien #344.4
+7 ; - RCLINE - ERA line #344.41;
+8 ;
+9 NEW RCEEOB,RCORIG,RCRCZ,RCSPLIT
+10 ; Get ERA from receipt
+11 SET RCERA=$$GET1^DIQ(344,RCRCPT_",",.18,"I")
+12 ; Quit if no ERA
+13 if 'RCERA
QUIT 0
+14 ; Get ERA Scratchpad line
+15 SET RCRCZ=$$GET1^DIQ(344.01,RCTRANDA_","_RCRCPT_",",.27,"I")
+16 ; Quit if ERA scratchpad line missing
+17 if 'RCRCZ
QUIT 0
+18 ; Get the original line sequence number from before the split was performed
+19 SET RCSPLIT=$$GET1^DIQ(344.491,RCRCZ_","_RCERA_",",.01)
SET RCORIG=RCSPLIT\1
+20 ; Convert sequence number into original line IEN
+21 SET RCORIG=$ORDER(^RCY(344.49,RCERA,1,"ASEQ",RCORIG,""))
+22 ; Quit if original scratchpad line not found
+23 if 'RCORIG
QUIT 0
+24 ; Get ERA line from original scratchpad line
+25 SET RCLINE=$$GET1^DIQ(344.491,RCORIG_","_RCERA_",",.09,"I")
+26 ; Quit if ERA line not found
+27 if 'RCLINE
QUIT 0
+28 ; Get EEOB from ERA line
+29 SET RCEEOB=$$GET1^DIQ(344.41,RCLINE_","_RCERA_",",.02,"I")
+30 ; Quit if ERA line pointer to EEOB is missing
+31 if 'RCEEOB
QUIT 0
+32 ; Ignore EEOB if status is not removed - read access to file #361.1 under IA 4051
+33 if $$GET1^DIQ(361.1,RCEEOB_",",102,"I")'=1
QUIT 0
+34 ; Return suspended EEOB IEN
+35 QUIT RCEEOB
+36 ;
+37 ; EP RCDPRPL1 and RCDPLPL3
RESTORE(RCPTDA,RCTRANDA,ORIG,SRC) ; Change bill number on EOB and clear 'removed' status
+1 ;
+2 ; INPUT - RCPTDA - Receipt ien #344
+3 ; - RCTRANDA - Receipt line #344.01
+4 ; - ORIG - EOB ien #361.1
+5 ; - SRC - 'L' - Link Payments 'R' - Receipt Porcessing
+6 ;
+7 if '$$LOCK^IBCEOB4(ORIG)
QUIT
+8 ;
+9 WRITE !,"Updating EEOB...."
+10 ;
+11 NEW NCLAIM,JUST
+12 ; Get new claim IEN from receipt line
+13 SET NCLAIM=$PIECE($$GET1^DIQ(344.01,RCTRANDA_","_RCPTDA_",",.09,"I"),";")
+14 ; Set up justification text
+15 SET JUST="EEOB restored from suspense in "_$SELECT(SRC="L":"Link Payments",SRC="R":"Edit Payments",1:"Other")
+16 ; Update AR comments on 'from claim'
+17 DO AUDIT^RCDPAYER(ORIG,JUST,"W")
+18 ; Change claim number on EOB
+19 DO MOVE^IBCEOB4(ORIG,NCLAIM,DUZ,$$NOW^XLFDT,JUST,"M")
+20 ; Reset EEOB REMOVED status
+21 DO RESTORE^IBCEOB4(ORIG)
+22 ;Unlock EOB
+23 DO UNLOCK^IBCEOB4(ORIG)
+24 ;
+25 HANG 1
WRITE "done"
+26 QUIT
