RCDPEM21 ;ALB/TMK/PJH - MANUAL MATCH TO PAPER EOB ;Jun 11, 2014@13:24:36
;;4.5;Accounts Receivable;**173,208,276,284,293,298,303,304,321,326**;Mar 20, 1995;Build 26
;;Per VA Directive 6402, this routine should not be modified.
Q
;
; Called from [RCDPE ERA POSTED BY PAPER EOB]
;
; Begin PRCA*4.5*276 - PJH
POSTED ;
N DIR,X,Y
S DIR("A")="Select type of receipt to ERA link"
S DIR("B")="M"
S DIR(0)="S^M:Manually select receipt to post;"
S DIR(0)=DIR(0)_"A:Automatic search for receipt to post"
D ^DIR K DIR
I Y="M" D MANUAL Q
I Y="A" D AUTO
Q
;
MANUAL ; Mark an ERA as posted when the data
; was previously posted using paper EOB information
N DIC,DIE,DIR,DA,DR,ERA,RCPT,X,Y,%
; Must be unmatched or matched to paper check, must be accepted by FMS, must not be posted yet
W !!,"THIS OPTION IS USED WHEN YOU HAVE POSTED AN ERA PAID WITH A PAPER CHECK",!,"BY USING THE PAPER EOB AND YOU DID NOT REFERENCE THE ERA IN THE RECEIPT",!!
MAN1 S DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0",DIC="^RCY(344.4,",DIC(0)="AEMQ"
D ^DIC K DIC
;
I Y'>0 G MANUALQ
;
;Check if ERA is already linked to a receipt
I $$RCHECK(+Y) G MAN1
S ERA=+Y
;
S DIC="^RCY(344,",DIC(0)="AEMQ",DIC("A")="RECEIPT: ",DIC("S")="I $$FMS^RCDPEM21(Y,0)"
D ^DIC K DIC
I Y'>0 G MANUALQ
S RCPT=+Y
;
D NOW^%DTC
;Update Receipt #, EFT Match Status, Detail Post Status and Paper EOB
S DIE="^RCY(344.4,",DR=".08////"_RCPT_";.09////2;.14////2;20.03////1",DA=ERA
;Update Date/Time Posted and User fields
S DR=DR_";7.01///"_%_";7.02///"_DUZ
D ^DIE
I '$D(Y) D
. S DIR(0)="EA",DIR("A",1)="ERA HAS BEEN MARKED AS POSTED USING PAPER EOB",DIR("A")="Press ENTER to continue: " D ^DIR K DIR
;
MANUALQ Q
;
;VISN 15 software - created by Karen Flores
;
AUTO ;Select ERA's for linking to receipt
N EXIT
S EXIT=0 F D LNKERA Q:EXIT
Q
;
RCHECK(RCSCR) ;Check if already linked to a receipt
N REC,RNUM,RNAM,AMT
S REC=$G(^RCY(344.4,RCSCR,0)),RNUM=$P(REC,U,8)
;Ignore check if zero amount ERA
Q:'$P(REC,U,5) 0
;Check if already linked to a different receipt
Q:'RNUM 0
S RNAM=$P($G(^RCY(344,RNUM,0)),U)
W !!,"ERA ",RCSCR," is already linked to receipt ",RNAM,!
Q 1
;
LNKERA ;Select ERA
N ABORT,DIC,DUOUT,DTOUT,REC,RCSCR,X,Y
;Must be unposted and either unmatched or matched to paper check
S DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0"
S DIC="^RCY(344.4,",DIC(0)="AEMQ" W ! D ^DIC K DIC
S RCSCR=+Y I RCSCR'>0 S EXIT=1 Q
;Check if already linked to a different receipt
Q:$$RCHECK(RCSCR)
;
;Finds receipt automatically from AR TRANSACTION file #433
N AMT,ART,ARTND1,ATTY,BILL,EOB,EOBND,FOUND,RCND,RCSCR1,RECEPT,TAMT
N TRACE
;Trace# from ERA
S TRACE=$P($G(^RCY(344.4,RCSCR,0)),U,2)
;Clear workfile
K ^TMP("RCDPEM2",$J)
;
S (FOUND,ABORT,RCSCR1)=0
;Scan claim lines in ERA for non zero bills
F S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:+RCSCR1=0!(FOUND) D
.S RCND=$G(^RCY(344.4,RCSCR,1,RCSCR1,0))
.;Ignore bill if AMOUNT PAID is zero
.S AMT=$P(RCND,"^",3) Q:+AMT=0
.;Ignore if EOB has no EOB detail record
.S EOB=+$P(RCND,"^",2) Q:'EOB
.;Get EOB detail record
.S EOBND=$G(^IBM(361.1,EOB,0))
.;Extract Bill number from EOB detail
.S BILL=$P(EOBND,"^",1) Q:BILL=""
.;Ignore duplicate bills on ERA
.Q:$D(^TMP("RCDPEM2",$J,BILL))
.S ^TMP("RCDPEM2",$J,BILL)=""
.;Search AR TRANSACTION file #433 for the bill - newest first
.S ART=""
.F S ART=$O(^PRCA(433,"C",BILL,ART),-1) Q:+ART=0!(FOUND) D
..S ARTND1=$G(^PRCA(433,ART,1))
..;Get transaction type
..S ATTY=$P(ARTND1,"^",2) Q:'ATTY
..;Ignore if not a payment
..S ATTY=$P($G(^PRCA(430.3,ATTY,0)),"^",1) Q:ATTY'["PAYMENT"
..;Get receipt number
..S RECEPT=$P(ARTND1,"^",3) Q:RECEPT=""
..;Ignore receipt if status is not 'ACCEPTED BY FMS'
..Q:'$$FMS(RECEPT,1)
..W !!,"PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)
..W !,"Bill number: ",$P($G(^DGCR(399,BILL,0)),U)
..W !,"Check #: ",$$CHQ(RECEPT,BILL)
..W !,"Trace #: ",TRACE
..W !,"DOS: ",$$FMTE^XLFDT($P($G(^DGCR(399,BILL,0)),U,3))
..S TAMT=+$P(ARTND1,"^",5)
..W !,"AR Transaction amount: ",TAMT
..W !,"RECEIPT#: ",RECEPT
..W !,"Date of Receipt: ",$$FMTE^XLFDT($$RCDATE^RCDPRU(RECEPT))
..W !,"Total Receipt AMOUNT: ",$J($$AMT^RCDPRU(RECEPT),2,2),!
.. ; PRCA*4.5*284 Change default response from YES to NO
..S DIR(0)="Y",DIR("B")="NO"
..S DIR("A")="Link to update Remittance entry # "_RCSCR
..S DIR("A")=DIR("A")_" with receipt "_RECEPT
..D ^DIR K DIR
..;Aborted
..I $D(DUOUT)!$D(DTOUT) S ABORT=1,FOUND=1 Q
..;Attempt to update ERA - finish if successful
..I +Y>0 D UPDERA(RCSCR,RECEPT,.FOUND)
;Update failed
I FOUND=0 W !!,"No matching payment transactions found for this ERA"
;Clear workfile
K ^TMP("RCDPEM2",$J)
Q
;
; Moved to RCDPRU because of size issues PRCA*4.5*303
UPDERA(DA,RECEPT,FOUND) ;Mark ERA as posted to paper EOB
D UPDERA^RCDPRU(DA,RECEPT,.FOUND)
Q FOUND
;
;Check FMS status
FMS(RECEPT,FLG) ;
; FLG = 1 if RECEPT contains receipt number
; FLG = 0 if RECEPT contains ien of the receipt
N FMSDOCNO,RCRECTDA,RES
S RES=0 I $G(RECEPT)="" G FMSX
;Get receipt IEN
I 'FLG S RCRECTDA=RECEPT
I FLG S RCRECTDA=$O(^RCY(344,"B",RECEPT,0))
I 'RCRECTDA G FMSX
;Get FMS document number
S FMSDOCNO=$$FMSSTAT^RCDPUREC(RCRECTDA)
;Ignore if not accepted
I $P(FMSDOCNO,U,2)'="ACCEPTED BY FMS" G FMSX
;Otherwise can be linked
S RES=1
FMSX ;
Q RES
;
CHQ(RECEPT,BILL) ;Get check number for this bill
N RCRECTDA,RCTRAN,RCCHK,PATBILL
;Get receipt IEN
S RCRECTDA=$O(^RCY(344,"B",RECEPT,0)) Q:'RCRECTDA ""
;Scan Receipt looking for this bill IEN
S RCTRAN=0,RCCHK=""
F S RCTRAN=$O(^RCY(344,RCRECTDA,1,RCTRAN)) Q:'RCTRAN D Q:RCCHK]""
.;Check for match on bill IEN
.S PATBILL=$P($G(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,3)
.;Ignore Patient pointers or null field
.Q:$P(PATBILL,";",2)'="PRCA(430,"
.;Compare bill IEN399 to IEN430
.Q:$P(PATBILL,";")'=BILL
.;Get check number for this line
.S RCCHK=$P($G(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,7)
Q RCCHK
;
;; End PRCA*4.5*276 - PJH
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEM21 6132 printed Sep 23, 2025@19:20:48 Page 2
RCDPEM21 ;ALB/TMK/PJH - MANUAL MATCH TO PAPER EOB ;Jun 11, 2014@13:24:36
+1 ;;4.5;Accounts Receivable;**173,208,276,284,293,298,303,304,321,326**;Mar 20, 1995;Build 26
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; Called from [RCDPE ERA POSTED BY PAPER EOB]
+6 ;
+7 ; Begin PRCA*4.5*276 - PJH
POSTED ;
+1 NEW DIR,X,Y
+2 SET DIR("A")="Select type of receipt to ERA link"
+3 SET DIR("B")="M"
+4 SET DIR(0)="S^M:Manually select receipt to post;"
+5 SET DIR(0)=DIR(0)_"A:Automatic search for receipt to post"
+6 DO ^DIR
KILL DIR
+7 IF Y="M"
DO MANUAL
QUIT
+8 IF Y="A"
DO AUTO
+9 QUIT
+10 ;
MANUAL ; Mark an ERA as posted when the data
+1 ; was previously posted using paper EOB information
+2 NEW DIC,DIE,DIR,DA,DR,ERA,RCPT,X,Y,%
+3 ; Must be unmatched or matched to paper check, must be accepted by FMS, must not be posted yet
+4 WRITE !!,"THIS OPTION IS USED WHEN YOU HAVE POSTED AN ERA PAID WITH A PAPER CHECK",!,"BY USING THE PAPER EOB AND YOU DID NOT REFERENCE THE ERA IN THE RECEIPT",!!
MAN1 SET DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0"
SET DIC="^RCY(344.4,"
SET DIC(0)="AEMQ"
+1 DO ^DIC
KILL DIC
+2 ;
+3 IF Y'>0
GOTO MANUALQ
+4 ;
+5 ;Check if ERA is already linked to a receipt
+6 IF $$RCHECK(+Y)
GOTO MAN1
+7 SET ERA=+Y
+8 ;
+9 SET DIC="^RCY(344,"
SET DIC(0)="AEMQ"
SET DIC("A")="RECEIPT: "
SET DIC("S")="I $$FMS^RCDPEM21(Y,0)"
+10 DO ^DIC
KILL DIC
+11 IF Y'>0
GOTO MANUALQ
+12 SET RCPT=+Y
+13 ;
+14 DO NOW^%DTC
+15 ;Update Receipt #, EFT Match Status, Detail Post Status and Paper EOB
+16 SET DIE="^RCY(344.4,"
SET DR=".08////"_RCPT_";.09////2;.14////2;20.03////1"
SET DA=ERA
+17 ;Update Date/Time Posted and User fields
+18 SET DR=DR_";7.01///"_%_";7.02///"_DUZ
+19 DO ^DIE
+20 IF '$DATA(Y)
Begin DoDot:1
+21 SET DIR(0)="EA"
SET DIR("A",1)="ERA HAS BEEN MARKED AS POSTED USING PAPER EOB"
SET DIR("A")="Press ENTER to continue: "
DO ^DIR
KILL DIR
End DoDot:1
+22 ;
MANUALQ QUIT
+1 ;
+2 ;VISN 15 software - created by Karen Flores
+3 ;
AUTO ;Select ERA's for linking to receipt
+1 NEW EXIT
+2 SET EXIT=0
FOR
DO LNKERA
if EXIT
QUIT
+3 QUIT
+4 ;
RCHECK(RCSCR) ;Check if already linked to a receipt
+1 NEW REC,RNUM,RNAM,AMT
+2 SET REC=$GET(^RCY(344.4,RCSCR,0))
SET RNUM=$PIECE(REC,U,8)
+3 ;Ignore check if zero amount ERA
+4 if '$PIECE(REC,U,5)
QUIT 0
+5 ;Check if already linked to a different receipt
+6 if 'RNUM
QUIT 0
+7 SET RNAM=$PIECE($GET(^RCY(344,RNUM,0)),U)
+8 WRITE !!,"ERA ",RCSCR," is already linked to receipt ",RNAM,!
+9 QUIT 1
+10 ;
LNKERA ;Select ERA
+1 NEW ABORT,DIC,DUOUT,DTOUT,REC,RCSCR,X,Y
+2 ;Must be unposted and either unmatched or matched to paper check
+3 SET DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0"
+4 SET DIC="^RCY(344.4,"
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
+5 SET RCSCR=+Y
IF RCSCR'>0
SET EXIT=1
QUIT
+6 ;Check if already linked to a different receipt
+7 if $$RCHECK(RCSCR)
QUIT
+8 ;
+9 ;Finds receipt automatically from AR TRANSACTION file #433
+10 NEW AMT,ART,ARTND1,ATTY,BILL,EOB,EOBND,FOUND,RCND,RCSCR1,RECEPT,TAMT
+11 NEW TRACE
+12 ;Trace# from ERA
+13 SET TRACE=$PIECE($GET(^RCY(344.4,RCSCR,0)),U,2)
+14 ;Clear workfile
+15 KILL ^TMP("RCDPEM2",$JOB)
+16 ;
+17 SET (FOUND,ABORT,RCSCR1)=0
+18 ;Scan claim lines in ERA for non zero bills
+19 FOR
SET RCSCR1=$ORDER(^RCY(344.4,RCSCR,1,RCSCR1))
if +RCSCR1=0!(FOUND)
QUIT
Begin DoDot:1
+20 SET RCND=$GET(^RCY(344.4,RCSCR,1,RCSCR1,0))
+21 ;Ignore bill if AMOUNT PAID is zero
+22 SET AMT=$PIECE(RCND,"^",3)
if +AMT=0
QUIT
+23 ;Ignore if EOB has no EOB detail record
+24 SET EOB=+$PIECE(RCND,"^",2)
if 'EOB
QUIT
+25 ;Get EOB detail record
+26 SET EOBND=$GET(^IBM(361.1,EOB,0))
+27 ;Extract Bill number from EOB detail
+28 SET BILL=$PIECE(EOBND,"^",1)
if BILL=""
QUIT
+29 ;Ignore duplicate bills on ERA
+30 if $DATA(^TMP("RCDPEM2",$JOB,BILL))
QUIT
+31 SET ^TMP("RCDPEM2",$JOB,BILL)=""
+32 ;Search AR TRANSACTION file #433 for the bill - newest first
+33 SET ART=""
+34 FOR
SET ART=$ORDER(^PRCA(433,"C",BILL,ART),-1)
if +ART=0!(FOUND)
QUIT
Begin DoDot:2
+35 SET ARTND1=$GET(^PRCA(433,ART,1))
+36 ;Get transaction type
+37 SET ATTY=$PIECE(ARTND1,"^",2)
if 'ATTY
QUIT
+38 ;Ignore if not a payment
+39 SET ATTY=$PIECE($GET(^PRCA(430.3,ATTY,0)),"^",1)
if ATTY'["PAYMENT"
QUIT
+40 ;Get receipt number
+41 SET RECEPT=$PIECE(ARTND1,"^",3)
if RECEPT=""
QUIT
+42 ;Ignore receipt if status is not 'ACCEPTED BY FMS'
+43 if '$$FMS(RECEPT,1)
QUIT
+44 WRITE !!,"PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)
+45 WRITE !,"Bill number: ",$PIECE($GET(^DGCR(399,BILL,0)),U)
+46 WRITE !,"Check #: ",$$CHQ(RECEPT,BILL)
+47 WRITE !,"Trace #: ",TRACE
+48 WRITE !,"DOS: ",$$FMTE^XLFDT($PIECE($GET(^DGCR(399,BILL,0)),U,3))
+49 SET TAMT=+$PIECE(ARTND1,"^",5)
+50 WRITE !,"AR Transaction amount: ",TAMT
+51 WRITE !,"RECEIPT#: ",RECEPT
+52 WRITE !,"Date of Receipt: ",$$FMTE^XLFDT($$RCDATE^RCDPRU(RECEPT))
+53 WRITE !,"Total Receipt AMOUNT: ",$JUSTIFY($$AMT^RCDPRU(RECEPT),2,2),!
+54 ; PRCA*4.5*284 Change default response from YES to NO
+55 SET DIR(0)="Y"
SET DIR("B")="NO"
+56 SET DIR("A")="Link to update Remittance entry # "_RCSCR
+57 SET DIR("A")=DIR("A")_" with receipt "_RECEPT
+58 DO ^DIR
KILL DIR
+59 ;Aborted
+60 IF $DATA(DUOUT)!$DATA(DTOUT)
SET ABORT=1
SET FOUND=1
QUIT
+61 ;Attempt to update ERA - finish if successful
+62 IF +Y>0
DO UPDERA(RCSCR,RECEPT,.FOUND)
End DoDot:2
End DoDot:1
+63 ;Update failed
+64 IF FOUND=0
WRITE !!,"No matching payment transactions found for this ERA"
+65 ;Clear workfile
+66 KILL ^TMP("RCDPEM2",$JOB)
+67 QUIT
+68 ;
+69 ; Moved to RCDPRU because of size issues PRCA*4.5*303
UPDERA(DA,RECEPT,FOUND) ;Mark ERA as posted to paper EOB
+1 DO UPDERA^RCDPRU(DA,RECEPT,.FOUND)
+2 QUIT FOUND
+3 ;
+4 ;Check FMS status
FMS(RECEPT,FLG) ;
+1 ; FLG = 1 if RECEPT contains receipt number
+2 ; FLG = 0 if RECEPT contains ien of the receipt
+3 NEW FMSDOCNO,RCRECTDA,RES
+4 SET RES=0
IF $GET(RECEPT)=""
GOTO FMSX
+5 ;Get receipt IEN
+6 IF 'FLG
SET RCRECTDA=RECEPT
+7 IF FLG
SET RCRECTDA=$ORDER(^RCY(344,"B",RECEPT,0))
+8 IF 'RCRECTDA
GOTO FMSX
+9 ;Get FMS document number
+10 SET FMSDOCNO=$$FMSSTAT^RCDPUREC(RCRECTDA)
+11 ;Ignore if not accepted
+12 IF $PIECE(FMSDOCNO,U,2)'="ACCEPTED BY FMS"
GOTO FMSX
+13 ;Otherwise can be linked
+14 SET RES=1
FMSX ;
+1 QUIT RES
+2 ;
CHQ(RECEPT,BILL) ;Get check number for this bill
+1 NEW RCRECTDA,RCTRAN,RCCHK,PATBILL
+2 ;Get receipt IEN
+3 SET RCRECTDA=$ORDER(^RCY(344,"B",RECEPT,0))
if 'RCRECTDA
QUIT ""
+4 ;Scan Receipt looking for this bill IEN
+5 SET RCTRAN=0
SET RCCHK=""
+6 FOR
SET RCTRAN=$ORDER(^RCY(344,RCRECTDA,1,RCTRAN))
if 'RCTRAN
QUIT
Begin DoDot:1
+7 ;Check for match on bill IEN
+8 SET PATBILL=$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,3)
+9 ;Ignore Patient pointers or null field
+10 if $PIECE(PATBILL,";",2)'="PRCA(430,"
QUIT
+11 ;Compare bill IEN399 to IEN430
+12 if $PIECE(PATBILL,";")'=BILL
QUIT
+13 ;Get check number for this line
+14 SET RCCHK=$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,7)
End DoDot:1
if RCCHK]""
QUIT
+15 QUIT RCCHK
+16 ;
+17 ;; End PRCA*4.5*276 - PJH
+18 ;
