RCDPEM2 ;ALB/TMK/PJH - MANUAL ERA AND EFT MATCHING ;Jun 11, 2014@13:24:36
;;4.5;Accounts Receivable;**173,208,276,284,293,298,303,304,321,326,332,409**;Mar 20, 1995;Build 17
;Per VA Directive 6402, this routine should not be modified.
Q
;
; PRCA*4.5*303 - Manually Match EFT from Worklist screen
;
MATCHWL ; Manually 'match' ERA to an EFT that originates from [RCDPE WORKLIST ERA LIST]
N DA,DIC,DIE,DIR,DR,DTRNG,DTOUT,DUOUT,EFTTOT,END,ERATOT,RCEFT,RCERA,RCMBG,RCMATCH,RCNAME,RCQUIT,START,X,Y
D FULL^VALM1
; PRCA*4.5*332 - Begin modified code block
S RCMBG=VALMBG
S RCERA=$$SEL^RCDPEWL7() ; Select ERA to use from screen
I RCERA=0 D MWQ Q
;
; Save the line, we need it when we go back to the worklist.
S RCERA(0)=^RCY(344.4,RCERA,0) ; Get the zero node for this ERA
I ((+($P(RCERA(0),U,9)))>0)!($P(RCERA(0),U,8)'="") D Q ; PRCA*4.5*326
. W !,"ERA is already matched please select another ERA..."
. D WAIT^VALM1
. D MWQ
D EN^RCDPEE(RCERA) ; Select EFT by partial matches?
D MWQ
Q
; PRCA*4.5*332 - End modified code block
;
GETDINFO(RCEFT,DEPNUM,DEPDT) ;EP from RCDPEE
; Get the Deposit Date and Deposit Number for the specified EFT
; Input: RCEFT - IEN for file #344.31
; Output: DEPNUM - Deposit Number (#344.3, .06)
; DEPDT - Deposit Date (#344.3, .07)
N IEN3443
S IEN3443=$$GET1^DIQ(344.31,RCEFT_",",.01,"I") ; IEN for file 344.3
S DEPNUM=$$GET1^DIQ(344.3,IEN3443_",",.06,"E") ; Deposit Number
S DEPDT=$$GET1^DIQ(344.3,IEN3443_",",.07,"E") ; Deposit Number
Q
;
; Quit back to the worklist VALMBCK will be killed by List Manager.
; Rebuild the screen because we may have changed it.
MWQ D INIT^RCDPEWL7
S VALMBCK="R",VALMBG=RCMBG
Q
;
MATCH1 ; Manually 'match' an ERA to an EFT
N DA,DIC,DIE,DIR,DIROUT,DR,DTRNG,DTOUT,DUOUT,EFTTOT,END,ERATOT
N RCEFT,RCERA,RCMATCH,RCMTFLG,RCNAME,RCQUIT,START,X,XX,Y,YY
W !,"THIS OPTION WILL ALLOW YOU TO MANUALLY MATCH AN EFT DETAIL RECORD"
W !,"WITH AN ERA RECORD."
;S XX=$$PMATCH(RCERA)
; PRCA*4.5*298 - Add ability to specify a date range
S DIR("A")="Select by date Range? (Y/N) ",DIR(0)="YA",DIR("B")="NO"
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G M1Q
I Y<1 G M1
S DTRNG=Y ; flag indicating date range selected
K DIR
S DIR("?")="Enter the earliest date for the selection range."
; value in DIR(0) for %DT = APE: ask date, past assumed, echo answer
S DIR(0)="DAO^:"_DT_":APE",DIR("A")="Start Date: "
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G M1Q
S START=Y
K DIR,X,Y
S DIR("?")="Enter the latest date for the selection range."
S DIR(0)="DAO^"_START_":"_DT_":APE",DIR("A")="End Date: ",DIR("B")=$$FMTE^XLFDT(DT)
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G M1Q
S END=Y
;
; Replace DIR with DIC call for EFT line identifier - PRCA*4.5*326
M1 S DIC("A")="SELECT THE UNMATCHED EFT TO MATCH TO AN ERA: "
;
; start PRCA*4.5*293 Add extra checks to filter out EFTs that have
; a payment amount of zero or EFTs that have been removed.
; Only UNMATCHED EFTs with payment amt >0 and not removed should
; be selectable by the user.
;
N DEPDT,DEPNUM
S DIC("W")="D DICW^RCDPEM3"
S DIC(0)="AEMQ"
S DIC=344.31
S DIC("S")="I ('$P(^(0),U,8))&($P($G(^(0)),U,7))&('$P($G(^(3)),U))"
S:$G(DTRNG) DIC("S")=DIC("S")_"&'($P($G(^(0)),U,13)<START)&'($P($G(^(0)),U,13)>END)"
; end PRCA*4.5*293
;
W !
D ^DIC K DIC
I $D(DUOUT)!$D(DTOUT)!(Y<0) G M1Q
S RCEFT=+Y
D GETDINFO(RCEFT,.DEPNUM,.DEPDT)
W !
S DIC="^RCY(344.31,",DR="0",DA=RCEFT D EN^DIQ
W " DEPOSIT NUMBER: ",DEPNUM,?40,"DEPOSIT DATE: ",DEPDT
W !
S DIR("A")="ARE YOU SURE THIS IS THE EFT YOU WANT TO MATCH?: "
S DIR(0)="YA",DIR("B")="YES"
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G M1Q
I Y'=1 G M1
; Add EFT line identifier - PRCA*4.5*326
M12 S DIR("A")="SELECT THE UNMATCHED ERA TO MATCH TO EFT #" ; PRCA*4.5*326
S DIR("A")=DIR("A")_$$GET1^DIQ(344.31,RCEFT,.01,"E")_": " ; PRCA*4.5*326
S DIR(0)="PAO^RCY(344.4,:AEMQ",DIR("S")="I '$P(^(0),U,9),'$P(^(0),U,8)"
W ! D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT)!(Y<0) G M1Q
S RCERA=+Y
W !
S DIC="^RCY(344.4,",DR="0",DA=RCERA D EN^DIQ
W !
S DIR("A")="ARE YOU SURE THIS IS THE CORRECT ERA TO MATCH TO?: ",DIR(0)="YA",DIR("B")="YES" D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G M1Q
I Y'=1 G M12
;
M12A ; PRCA*4.5*303 - MATCH WL jumps here to complete the manual match
; BEGIN PRCA*4.5*326
S ERATOT=$$GET1^DIQ(344.4,RCERA,.05,"I") ; ERA Paid Amount
S EFTTOT=$$GET1^DIQ(344.31,RCEFT,.07,"I") ; EFT Amount of Payment
S RCMATCH=(+ERATOT=+EFTTOT) ; Do the Totals Match
;
; If the totals don't match, manual match is not allowed
;I 'RCMATCH D G M1Q
;. W !,*7,$J("",3)_"> The amount of payment on these two records do not agree."
;. K DIR S DIR(0)="EA",DIR("A")="Press ENTER to continue: "
;. D ^DIR
;. S RCQUIT=1
;
S XX=$$GET1^DIQ(344.4,RCERA,.06,"I") ; ERA Payer Name
S YY=$$GET1^DIQ(344.31,RCEFT,.02,"I") ; EFT Payer Name
S RCNAME=(XX=YY) ; Do the Payer Names Match
I 'RCNAME D G:RCQUIT M1Q
. N Z
. S RCQUIT=0,Z=1
. S DIR("A",1)="***WARNING***"
. I 'RCNAME S Z=Z+1,DIR("A",Z)=$J("",3)_"> The payer names on these two records do not agree"
. S DIR(0)="YA",DIR("B")="NO",DIR("A")="ARE YOU SURE YOU WANT TO MATCH THESE 2 RECORDS?: "
. W ! D ^DIR K DIR
. I $S($D(DUOUT)!$D(DTOUT):1,Y'=1:1,1:0) S RCQUIT=1 Q
; END PRCA*4.5*326
S DIE="^RCY(344.4,",DR=".09////1",DA=RCERA D ^DIE
I '$D(Y) S DIE="^RCY(344.31,",DR=".08////1;.1////"_RCERA,DA=RCEFT D ^DIE
S RCMTFLG=$S('$D(Y):1,1:0)
; PRCA*4.5*326 - Add EFT suffix
W !,"EFT #"_$$GET1^DIQ(344.31,RCEFT,.01,"E")_" WAS "_$S(RCMTFLG:"SUCCESSFULLY",1:"NOT")_" MATCHED TO ERA #"_RCERA ; PRCA*4.5*326
I 'RCMTFLG S DIR(0)="E" D ^DIR K DIR G M1Q
;PRCA*4.5*304 add ability to use auto-posting for a manually matched item
; Only if the amount of payments match.
I 'RCMATCH D G M1Q ;if payment amounts don't match, don't allow for auto-posting.
. W !,"ERA/EFT balances do not match - cannot Mark for Auto-Post. Press any key." S DIR(0)="E" D ^DIR K DIR
W !
K DIR
S DIR("A")="Do you wish to mark this entry for Auto Posting (Y/N)? "
S DIR(0)="YA"
D ^DIR
I 'Y K DIR S DIR(0)="E" D ^DIR G M1Q
N AUTOPOST
S AUTOPOST=$$AUTOCHK2^RCDPEAP1(RCERA,1) ; Allow auto-post for CHK and ACH type ERA - PRCA*4.5*321
I AUTOPOST D
. D SETSTA^RCDPEAP(RCERA,0,"Manual Match: Marked as Auto-Post Candidate")
. W !,"ERA has been successfully Marked as an Auto-Post CANDIDATE"
I 'AUTOPOST D
. D AUDITLOG^RCDPEAP(RCERA,"","Manual Match: Not Marked as Auto-Post Candidate-"_$P(AUTOPOST,U,2))
. W !,"ERA was NOT Marked as an Auto-Post CANDIDATE - ",$P(AUTOPOST,U,2)
K DIR S DIR(0)="E" D ^DIR
M1Q Q
;
MATCH2 ; Manually 'match' a 0-balance EFT to a paper EOB
N DUOUT,DTOUT,DA,DR,DIE,DIC,DIR,X,Y,RCEFT,RCRCPT
W !,"THIS OPTION WILL ALLOW YOU TO MANUALLY MARK A 0-BALANCE EFT DETAIL RECORD",!,"AS MATCHED TO A PAPER EOB"
; BEGIN PRCA*4.5*326
M2 S DIC("A")="SELECT THE UNMATCHED 0-BALANCE EFT TO MARK AS MATCHED TO PAPER EOB: "
S DIC("W")="D DICW^RCDPEM3"
S DIC(0)="AEMQ"
S DIC("S")="I '$P(^(0),U,8),'$P(^(0),U,7)"
S DIC=344.31
D ^DIC
; END PRCA*4.5*326
I $D(DUOUT)!$D(DTOUT)!(Y'>0) G M2Q
S RCEFT=+Y
W !
S DIC="^RCY(344.31,",DR="0",DA=RCEFT D EN^DIQ
W !
S DIR("A")="ARE YOU SURE THIS IS THE EFT YOU WANT TO MARK AS MATCHED?: ",DIR(0)="YA",DIR("B")="YES" D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G M2Q
I Y'=1 G M2
S DIE="^RCY(344.31,",DR=".08////2",DA=RCEFT D ^DIE
S DIR(0)="EA",DIR("A")="EFT #"_RCEFT_" WAS "_$S('$D(Y):"SUCCESSFULLY",1:"NOT")_" MARKED AS MATCHED TO PAPER EOB" D ^DIR K DIR
M2Q Q
;
MANTR ; Mark an EFT detail record as 'TR' posted manually
N DA,DR,DIC,DIE,DIR,X,Y,RCEFT,DUOUT,DTOUT,RCZ0,RCTR,RCHOW
; EFT detail cannot be associated with a receipt or TR document
;
W !,"*****",!," YOU SHOULD ONLY USE THIS OPTION IF YOU HAVE AN EFT DETAIL RECORD ON YOUR",!," UNAPPLIED DEPOSIT REPORT WHOSE DETAIL WAS ENTERED ON LINE VIA A TR DOCUMENT",!,"*****",!
S DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,16)="""",$P(^(0),U,11)",DIC("A")="SELECT THE EFT DETAIL WHOSE 'TR' DOC WAS MANUALLY ENTERED ON LINE: ",DIC="^RCY(344.31,"
W ! D ^DIC K DIC
I Y'>0 G MANTRQ
S RCEFT=+Y,RCZ0=$G(^RCY(344.31,RCEFT,0))
S DIR(0)="FA^2:30^K:X'?1""TR"".E X",DIR("A")="ENTER THE TR DOC # THAT WAS ENTERED ON-LINE FOR THE EFT DETAIL: "
W ! D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) G MANTRQ
S RCTR=Y,DR=""
;
I '$P(RCZ0,U,8) D G:RCQUIT MANTRQ ;Unmatched
. S DIR(0)="SA^E:ELECTRONIC ERA;P:PAPER EOB",DIR("A")="WAS THE EFT DETAIL RECEIVED BY (E)RA or (P)APER EOB?: " W ! D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
. S RCHOW=Y,DR=""
. I RCHOW="E" D
.. S DR=";.09R;.08////1"
. I RCHOW="P" D
.. S DR=";.08////2"
;
S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="THIS WILL MARK EFT DETAIL #: "_RCEFT_" AS MANUALLY POSTED",DIR("A",2)=" USING TR DOC: "_RCTR
S DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: " W ! D ^DIR K DIR
I Y'=1 D G MANTRQ
. S DIR(0)="EA",DIR("A")="EFT NOT UPDATED - Press ENTER to continue: " W ! D ^DIR K DIR
S DIE="^RCY(344.31,",DA=RCEFT,DR=".16R"_DR D ^DIE
I $D(Y) D
. S DIE="^RCY(344.31,",DA=RCEFT,DR=".16///@;.08///"_$S($P(RCZ0,U,8)'="":$P(RCZ0,U,8),1:"@") D ^DIE
. S DIR("A")="EFT NOT UPDATED - Press ENTER to continue: "
E D
. S DIR("A")="STATUS UPDATED FOR EFT DETAIL #: "_RCEFT_" - Press ENTER to continue: "
S DIR(0)="EA"
W ! D ^DIR K DIR
;
MANTRQ Q
;
CHK() ; Function returns the ien of CHECK/MO payment type
Q +$O(^RC(341.1,"AC",4,0))
;
;
;
MATCH3 ; Manually 'match' a 0-balance ERA that has no check or EFT
N DUOUT,DTOUT,DA,DR,DIE,DIC,DIR,X,Y,RCERA,RCRCPT
W !,"THIS OPTION WILL ALLOW YOU TO MANUALLY MARK A 0-BALANCE ERA WITH NO",!,"CHECK OR EFT AS 'MATCH-0 PAYMENT' TO REMOVE IT FROM THE ERA AGING REPORT"
M3 S DIR("A")="SELECT THE UNMATCHED 0-BALANCE ERA TO MARK AS MATCHED: "
S DIR(0)="PAO^RCY(344.4,:AEMQ",DIR("S")="I '$P(^(0),U,9),'$P(^(0),U,5)"
W ! D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT)!(Y'>0) G M3Q
S RCERA=+Y
W !
S DIC="^RCY(344.4,",DR="0",DA=RCERA D EN^DIQ
W !
S DIR("A")="ARE YOU SURE THIS IS THE ERA YOU WANT TO MARK AS MATCH-0 PAYMENT? (Y/N) ",DIR(0)="YA",DIR("B")="YES" D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G M3Q
I Y'=1 G M3
S DIE="^RCY(344.4,",DR=".09////3",DA=RCERA D ^DIE
S DIR(0)="EA",DIR("A")="ERA #"_RCERA_" WAS "_$S('$D(Y):"SUCCESSFULLY",1:"NOT")_" MARKED AS MATCH-0 PAYMENT" D ^DIR K DIR
M3Q Q
;
UNMATCH ; Used to 'unmatch' an ERA matched in error
N AUTOPOST,DA,DIC,DIE,DIK,DIR,DIROUT,DR,DTOUT,DUOUTX,RCEFT,RCQUIT,RCWL,X,XX,Y
S DIC(0)="AEMQ",DIC="^RCY(344.4,"
S DIC("S")="I '$P(^(0),U,8),$S('$P(^(0),U,14):1,1:$P(^(0),U,9)=3),$P(^(0),U,9)"
D ^DIC K DIC
Q:Y'>0
S RCWL=+Y,RCQUIT=0
I $D(^RCY(344.49,RCWL,0)) D Q:RCQUIT
. S DIR(0)="YA"
. S XX="THIS ERA ALREADY HAS A SCRATCH PAD ENTRY AND MUST BE DELETED BEFORE IT CAN BE"
. S DIR("A",1)=XX
. S DIR("A")="UNMATCHED. DO YOU WANT TO DELETE THE SCRATCH PAD ENTRY FOR THIS ERA NOW? "
. W ! D ^DIR K DIR
. I Y'=1 S RCQUIT=1 Q
. S DIK="^RCY(344.49,",DA=RCWL D ^DIK
S AUTOPOST=""
I $O(^RCY(344.31,"AERA",RCWL,0)) S RCEFT=+$O(^(0)) D Q:RCQUIT
. S AUTOPOST=$$GET1^DIQ(344.4,RCWL_",",4.02,"I")
. W !!,"THIS ERA IS MATCHED TO EFT #"_$$OUT^RCDPEM3(RCEFT)
. I AUTOPOST=0 W !,"* WARNING: This ERA will be Un-Marked as an Auto-Post CANDIDATE"
. S DIR("A")="ARE YOU SURE YOU WANT TO UNMATCH THEM? ",DIR(0)="YA"
. D ^DIR K DIR
. I Y'=1 S RCQUIT=1 Q
. S DIE="^RCY(344.31,",DR=".1///@;.08////0",DA=RCEFT D ^DIE
. W !,"EFT #"_$$OUT^RCDPEM3(RCEFT)_" IS NOW UNMATCHED",!
; PRCA*4.5*326 - If check if unmatched, delete date matched and user
S DIE="^RCY(344.4,",DR=".09////0;.13///@;.14////0;5.03///@;5.04///@"
S DA=RCWL
D ^DIE
I AUTOPOST=0 D SETSTA^RCDPEAP(RCWL,"@","Unmatch: Removed as Auto-Post Candidate")
S DIR("A")="ERA HAS BEEN SUCCESSFULLY UNMATCHED - Press ENTER to continue: "
S DIR(0)="EA" W ! D ^DIR K DIR
Q
;
; PRCA*4.5*284 - Changed option name from 'Mark ERA Return to Payer' to 'Remove ERA from Active Worklist'
RETN ; Entrypoint for Remove ERA from Active Worklist
N DA,DIC,DIR,DR,DTOUT,DUOUT,EXC,RCY,REASON,DIE,MSG,X,XX,Y,% ;PRCA*4.5*409 Added REASON,XX
D OWNSKEY^XUSRB(.MSG,"RCDPE MARK ERA",DUZ)
I 'MSG(0) D Q
. W !!,"SORRY, YOU ARE NOT AUTHORIZED TO USE THIS OPTION"
. W !,"This option is locked with RCDPE MARK ERA key.",!
. S DIR(0)="E" D ^DIR K DIR
W !!,"Use this option to remove an ERA from the EEOB Worklist that should not have"
W !,"been sent to your site by the payer; or the ERA cannot be removed off the"
W !,"Worklist using the 'Update ERA Posted Using Paper EOB' option."
W !!,"This option is only to be used if the paper check has been sent back to the"
W !,"payer without being deposited. Once removed, the ERA can no longer be"
W !,"accessed for processing, but can be viewed under the posted Worklist. For"
W !,"auditing purposes, this option requires the user to enter a reason for"
W !,"removing the ERA.",!
S DIC="^RCY(344.4,",DIC(0)="AEMQ",DIC("S")="I '$P(^(0),U,9),'$P(^(0),U,14)"
D ^DIC K DIC
Q:Y'>0
S RCY=+Y
S DIR(0)="YA"
S DIR("A",1)="THIS WILL REMOVE THE ERA # "_+Y_" FROM THE ACTIVE WORKLIST"
S DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE? "
W !
D ^DIR K DIR
W !
I $D(DUOUT)!$D(DTOUT)!(Y=0) D NOCHNG^RCDPEMB Q
S DIE="^RCY(344.4,",DA=RCY,DR=".18" D ^DIE
I $D(Y) D NOCHNG^RCDPEMB Q ; User didn't enter a removal reason
;
; PRCA*4.5*284 Set EFT MATCH STATUS (#344.4,.09) as '4' FOR REMOVED rather than '2' FOR MATCHED TO PAPER CHECK
D NOW^%DTC S DR=".14////4;.09////4;.16////"_DUZ_";.17////"_% D ^DIE
;
; PRCA*4.5*409 Start
; Ask the user if they want to remove all data exceptions for the ERA
; being removed from the worklist
S DIR(0)="YA"
S DIR("A")="Remove all Data Exceptions for ERA # "_RCY_" from the Exceptions Worklist? "
W !
D ^DIR K DIR
S EXC=$S(+Y:1,1:0)
S REASON=$P(^RCY(344.4,RCY,6),"^",3)
W !
I $D(DUOUT)!$D(DTOUT)!(Y=0) S EXC=0 ; Don't remove exceptions
I EXC=1 D REMEXC^RCDPEX31(RCY,REASON) ; Remove any data exceptions
; PRCA*4.5*409 End
;
S DIR(0)="EA",DIR("A")="Press ENTER to continue: "
W ! D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEM2 14355 printed Oct 16, 2024@17:45:36 Page 2
RCDPEM2 ;ALB/TMK/PJH - MANUAL ERA AND EFT MATCHING ;Jun 11, 2014@13:24:36
+1 ;;4.5;Accounts Receivable;**173,208,276,284,293,298,303,304,321,326,332,409**;Mar 20, 1995;Build 17
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; PRCA*4.5*303 - Manually Match EFT from Worklist screen
+6 ;
MATCHWL ; Manually 'match' ERA to an EFT that originates from [RCDPE WORKLIST ERA LIST]
+1 NEW DA,DIC,DIE,DIR,DR,DTRNG,DTOUT,DUOUT,EFTTOT,END,ERATOT,RCEFT,RCERA,RCMBG,RCMATCH,RCNAME,RCQUIT,START,X,Y
+2 DO FULL^VALM1
+3 ; PRCA*4.5*332 - Begin modified code block
+4 SET RCMBG=VALMBG
+5 ; Select ERA to use from screen
SET RCERA=$$SEL^RCDPEWL7()
+6 IF RCERA=0
DO MWQ
QUIT
+7 ;
+8 ; Save the line, we need it when we go back to the worklist.
+9 ; Get the zero node for this ERA
SET RCERA(0)=^RCY(344.4,RCERA,0)
+10 ; PRCA*4.5*326
IF ((+($PIECE(RCERA(0),U,9)))>0)!($PIECE(RCERA(0),U,8)'="")
Begin DoDot:1
+11 WRITE !,"ERA is already matched please select another ERA..."
+12 DO WAIT^VALM1
+13 DO MWQ
End DoDot:1
QUIT
+14 ; Select EFT by partial matches?
DO EN^RCDPEE(RCERA)
+15 DO MWQ
+16 QUIT
+17 ; PRCA*4.5*332 - End modified code block
+18 ;
GETDINFO(RCEFT,DEPNUM,DEPDT) ;EP from RCDPEE
+1 ; Get the Deposit Date and Deposit Number for the specified EFT
+2 ; Input: RCEFT - IEN for file #344.31
+3 ; Output: DEPNUM - Deposit Number (#344.3, .06)
+4 ; DEPDT - Deposit Date (#344.3, .07)
+5 NEW IEN3443
+6 ; IEN for file 344.3
SET IEN3443=$$GET1^DIQ(344.31,RCEFT_",",.01,"I")
+7 ; Deposit Number
SET DEPNUM=$$GET1^DIQ(344.3,IEN3443_",",.06,"E")
+8 ; Deposit Number
SET DEPDT=$$GET1^DIQ(344.3,IEN3443_",",.07,"E")
+9 QUIT
+10 ;
+11 ; Quit back to the worklist VALMBCK will be killed by List Manager.
+12 ; Rebuild the screen because we may have changed it.
MWQ DO INIT^RCDPEWL7
+1 SET VALMBCK="R"
SET VALMBG=RCMBG
+2 QUIT
+3 ;
MATCH1 ; Manually 'match' an ERA to an EFT
+1 NEW DA,DIC,DIE,DIR,DIROUT,DR,DTRNG,DTOUT,DUOUT,EFTTOT,END,ERATOT
+2 NEW RCEFT,RCERA,RCMATCH,RCMTFLG,RCNAME,RCQUIT,START,X,XX,Y,YY
+3 WRITE !,"THIS OPTION WILL ALLOW YOU TO MANUALLY MATCH AN EFT DETAIL RECORD"
+4 WRITE !,"WITH AN ERA RECORD."
+5 ;S XX=$$PMATCH(RCERA)
+6 ; PRCA*4.5*298 - Add ability to specify a date range
+7 SET DIR("A")="Select by date Range? (Y/N) "
SET DIR(0)="YA"
SET DIR("B")="NO"
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO M1Q
+10 IF Y<1
GOTO M1
+11 ; flag indicating date range selected
SET DTRNG=Y
+12 KILL DIR
+13 SET DIR("?")="Enter the earliest date for the selection range."
+14 ; value in DIR(0) for %DT = APE: ask date, past assumed, echo answer
+15 SET DIR(0)="DAO^:"_DT_":APE"
SET DIR("A")="Start Date: "
+16 DO ^DIR
KILL DIR
+17 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO M1Q
+18 SET START=Y
+19 KILL DIR,X,Y
+20 SET DIR("?")="Enter the latest date for the selection range."
+21 SET DIR(0)="DAO^"_START_":"_DT_":APE"
SET DIR("A")="End Date: "
SET DIR("B")=$$FMTE^XLFDT(DT)
+22 DO ^DIR
KILL DIR
+23 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO M1Q
+24 SET END=Y
+25 ;
+26 ; Replace DIR with DIC call for EFT line identifier - PRCA*4.5*326
M1 SET DIC("A")="SELECT THE UNMATCHED EFT TO MATCH TO AN ERA: "
+1 ;
+2 ; start PRCA*4.5*293 Add extra checks to filter out EFTs that have
+3 ; a payment amount of zero or EFTs that have been removed.
+4 ; Only UNMATCHED EFTs with payment amt >0 and not removed should
+5 ; be selectable by the user.
+6 ;
+7 NEW DEPDT,DEPNUM
+8 SET DIC("W")="D DICW^RCDPEM3"
+9 SET DIC(0)="AEMQ"
+10 SET DIC=344.31
+11 SET DIC("S")="I ('$P(^(0),U,8))&($P($G(^(0)),U,7))&('$P($G(^(3)),U))"
+12 if $GET(DTRNG)
SET DIC("S")=DIC("S")_"&'($P($G(^(0)),U,13)<START)&'($P($G(^(0)),U,13)>END)"
+13 ; end PRCA*4.5*293
+14 ;
+15 WRITE !
+16 DO ^DIC
KILL DIC
+17 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y<0)
GOTO M1Q
+18 SET RCEFT=+Y
+19 DO GETDINFO(RCEFT,.DEPNUM,.DEPDT)
+20 WRITE !
+21 SET DIC="^RCY(344.31,"
SET DR="0"
SET DA=RCEFT
DO EN^DIQ
+22 WRITE " DEPOSIT NUMBER: ",DEPNUM,?40,"DEPOSIT DATE: ",DEPDT
+23 WRITE !
+24 SET DIR("A")="ARE YOU SURE THIS IS THE EFT YOU WANT TO MATCH?: "
+25 SET DIR(0)="YA"
SET DIR("B")="YES"
+26 DO ^DIR
KILL DIR
+27 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO M1Q
+28 IF Y'=1
GOTO M1
+29 ; Add EFT line identifier - PRCA*4.5*326
M12 ; PRCA*4.5*326
SET DIR("A")="SELECT THE UNMATCHED ERA TO MATCH TO EFT #"
+1 ; PRCA*4.5*326
SET DIR("A")=DIR("A")_$$GET1^DIQ(344.31,RCEFT,.01,"E")_": "
+2 SET DIR(0)="PAO^RCY(344.4,:AEMQ"
SET DIR("S")="I '$P(^(0),U,9),'$P(^(0),U,8)"
+3 WRITE !
DO ^DIR
KILL DIR
+4 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y<0)
GOTO M1Q
+5 SET RCERA=+Y
+6 WRITE !
+7 SET DIC="^RCY(344.4,"
SET DR="0"
SET DA=RCERA
DO EN^DIQ
+8 WRITE !
+9 SET DIR("A")="ARE YOU SURE THIS IS THE CORRECT ERA TO MATCH TO?: "
SET DIR(0)="YA"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
+10 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO M1Q
+11 IF Y'=1
GOTO M12
+12 ;
M12A ; PRCA*4.5*303 - MATCH WL jumps here to complete the manual match
+1 ; BEGIN PRCA*4.5*326
+2 ; ERA Paid Amount
SET ERATOT=$$GET1^DIQ(344.4,RCERA,.05,"I")
+3 ; EFT Amount of Payment
SET EFTTOT=$$GET1^DIQ(344.31,RCEFT,.07,"I")
+4 ; Do the Totals Match
SET RCMATCH=(+ERATOT=+EFTTOT)
+5 ;
+6 ; If the totals don't match, manual match is not allowed
+7 ;I 'RCMATCH D G M1Q
+8 ;. W !,*7,$J("",3)_"> The amount of payment on these two records do not agree."
+9 ;. K DIR S DIR(0)="EA",DIR("A")="Press ENTER to continue: "
+10 ;. D ^DIR
+11 ;. S RCQUIT=1
+12 ;
+13 ; ERA Payer Name
SET XX=$$GET1^DIQ(344.4,RCERA,.06,"I")
+14 ; EFT Payer Name
SET YY=$$GET1^DIQ(344.31,RCEFT,.02,"I")
+15 ; Do the Payer Names Match
SET RCNAME=(XX=YY)
+16 IF 'RCNAME
Begin DoDot:1
+17 NEW Z
+18 SET RCQUIT=0
SET Z=1
+19 SET DIR("A",1)="***WARNING***"
+20 IF 'RCNAME
SET Z=Z+1
SET DIR("A",Z)=$JUSTIFY("",3)_"> The payer names on these two records do not agree"
+21 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="ARE YOU SURE YOU WANT TO MATCH THESE 2 RECORDS?: "
+22 WRITE !
DO ^DIR
KILL DIR
+23 IF $SELECT($DATA(DUOUT)!$DATA(DTOUT):1,Y'=1:1,1:0)
SET RCQUIT=1
QUIT
End DoDot:1
if RCQUIT
GOTO M1Q
+24 ; END PRCA*4.5*326
+25 SET DIE="^RCY(344.4,"
SET DR=".09////1"
SET DA=RCERA
DO ^DIE
+26 IF '$DATA(Y)
SET DIE="^RCY(344.31,"
SET DR=".08////1;.1////"_RCERA
SET DA=RCEFT
DO ^DIE
+27 SET RCMTFLG=$SELECT('$DATA(Y):1,1:0)
+28 ; PRCA*4.5*326 - Add EFT suffix
+29 ; PRCA*4.5*326
WRITE !,"EFT #"_$$GET1^DIQ(344.31,RCEFT,.01,"E")_" WAS "_$SELECT(RCMTFLG:"SUCCESSFULLY",1:"NOT")_" MATCHED TO ERA #"_RCERA
+30 IF 'RCMTFLG
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO M1Q
+31 ;PRCA*4.5*304 add ability to use auto-posting for a manually matched item
+32 ; Only if the amount of payments match.
+33 ;if payment amounts don't match, don't allow for auto-posting.
IF 'RCMATCH
Begin DoDot:1
+34 WRITE !,"ERA/EFT balances do not match - cannot Mark for Auto-Post. Press any key."
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO M1Q
+35 WRITE !
+36 KILL DIR
+37 SET DIR("A")="Do you wish to mark this entry for Auto Posting (Y/N)? "
+38 SET DIR(0)="YA"
+39 DO ^DIR
+40 IF 'Y
KILL DIR
SET DIR(0)="E"
DO ^DIR
GOTO M1Q
+41 NEW AUTOPOST
+42 ; Allow auto-post for CHK and ACH type ERA - PRCA*4.5*321
SET AUTOPOST=$$AUTOCHK2^RCDPEAP1(RCERA,1)
+43 IF AUTOPOST
Begin DoDot:1
+44 DO SETSTA^RCDPEAP(RCERA,0,"Manual Match: Marked as Auto-Post Candidate")
+45 WRITE !,"ERA has been successfully Marked as an Auto-Post CANDIDATE"
End DoDot:1
+46 IF 'AUTOPOST
Begin DoDot:1
+47 DO AUDITLOG^RCDPEAP(RCERA,"","Manual Match: Not Marked as Auto-Post Candidate-"_$PIECE(AUTOPOST,U,2))
+48 WRITE !,"ERA was NOT Marked as an Auto-Post CANDIDATE - ",$PIECE(AUTOPOST,U,2)
End DoDot:1
+49 KILL DIR
SET DIR(0)="E"
DO ^DIR
M1Q QUIT
+1 ;
MATCH2 ; Manually 'match' a 0-balance EFT to a paper EOB
+1 NEW DUOUT,DTOUT,DA,DR,DIE,DIC,DIR,X,Y,RCEFT,RCRCPT
+2 WRITE !,"THIS OPTION WILL ALLOW YOU TO MANUALLY MARK A 0-BALANCE EFT DETAIL RECORD",!,"AS MATCHED TO A PAPER EOB"
+3 ; BEGIN PRCA*4.5*326
M2 SET DIC("A")="SELECT THE UNMATCHED 0-BALANCE EFT TO MARK AS MATCHED TO PAPER EOB: "
+1 SET DIC("W")="D DICW^RCDPEM3"
+2 SET DIC(0)="AEMQ"
+3 SET DIC("S")="I '$P(^(0),U,8),'$P(^(0),U,7)"
+4 SET DIC=344.31
+5 DO ^DIC
+6 ; END PRCA*4.5*326
+7 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y'>0)
GOTO M2Q
+8 SET RCEFT=+Y
+9 WRITE !
+10 SET DIC="^RCY(344.31,"
SET DR="0"
SET DA=RCEFT
DO EN^DIQ
+11 WRITE !
+12 SET DIR("A")="ARE YOU SURE THIS IS THE EFT YOU WANT TO MARK AS MATCHED?: "
SET DIR(0)="YA"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
+13 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO M2Q
+14 IF Y'=1
GOTO M2
+15 SET DIE="^RCY(344.31,"
SET DR=".08////2"
SET DA=RCEFT
DO ^DIE
+16 SET DIR(0)="EA"
SET DIR("A")="EFT #"_RCEFT_" WAS "_$SELECT('$DATA(Y):"SUCCESSFULLY",1:"NOT")_" MARKED AS MATCHED TO PAPER EOB"
DO ^DIR
KILL DIR
M2Q QUIT
+1 ;
MANTR ; Mark an EFT detail record as 'TR' posted manually
+1 NEW DA,DR,DIC,DIE,DIR,X,Y,RCEFT,DUOUT,DTOUT,RCZ0,RCTR,RCHOW
+2 ; EFT detail cannot be associated with a receipt or TR document
+3 ;
+4 WRITE !,"*****",!," YOU SHOULD ONLY USE THIS OPTION IF YOU HAVE AN EFT DETAIL RECORD ON YOUR",!," UNAPPLIED DEPOSIT REPORT WHOSE DETAIL WAS ENTERED ON LINE VIA A TR DOCUMENT",!,"*****",!
+5 SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,16)="""",$P(^(0),U,11)"
SET DIC("A")="SELECT THE EFT DETAIL WHOSE 'TR' DOC WAS MANUALLY ENTERED ON LINE: "
SET DIC="^RCY(344.31,"
+6 WRITE !
DO ^DIC
KILL DIC
+7 IF Y'>0
GOTO MANTRQ
+8 SET RCEFT=+Y
SET RCZ0=$GET(^RCY(344.31,RCEFT,0))
+9 SET DIR(0)="FA^2:30^K:X'?1""TR"".E X"
SET DIR("A")="ENTER THE TR DOC # THAT WAS ENTERED ON-LINE FOR THE EFT DETAIL: "
+10 WRITE !
DO ^DIR
KILL DIR
+11 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO MANTRQ
+12 SET RCTR=Y
SET DR=""
+13 ;
+14 ;Unmatched
IF '$PIECE(RCZ0,U,8)
Begin DoDot:1
+15 SET DIR(0)="SA^E:ELECTRONIC ERA;P:PAPER EOB"
SET DIR("A")="WAS THE EFT DETAIL RECEIVED BY (E)RA or (P)APER EOB?: "
WRITE !
DO ^DIR
KILL DIR
+16 IF $DATA(DTOUT)!$DATA(DUOUT)
SET RCQUIT=1
QUIT
+17 SET RCHOW=Y
SET DR=""
+18 IF RCHOW="E"
Begin DoDot:2
+19 SET DR=";.09R;.08////1"
End DoDot:2
+20 IF RCHOW="P"
Begin DoDot:2
+21 SET DR=";.08////2"
End DoDot:2
End DoDot:1
if RCQUIT
GOTO MANTRQ
+22 ;
+23 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A",1)="THIS WILL MARK EFT DETAIL #: "_RCEFT_" AS MANUALLY POSTED"
SET DIR("A",2)=" USING TR DOC: "_RCTR
+24 SET DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: "
WRITE !
DO ^DIR
KILL DIR
+25 IF Y'=1
Begin DoDot:1
+26 SET DIR(0)="EA"
SET DIR("A")="EFT NOT UPDATED - Press ENTER to continue: "
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO MANTRQ
+27 SET DIE="^RCY(344.31,"
SET DA=RCEFT
SET DR=".16R"_DR
DO ^DIE
+28 IF $DATA(Y)
Begin DoDot:1
+29 SET DIE="^RCY(344.31,"
SET DA=RCEFT
SET DR=".16///@;.08///"_$SELECT($PIECE(RCZ0,U,8)'="":$PIECE(RCZ0,U,8),1:"@")
DO ^DIE
+30 SET DIR("A")="EFT NOT UPDATED - Press ENTER to continue: "
End DoDot:1
+31 IF '$TEST
Begin DoDot:1
+32 SET DIR("A")="STATUS UPDATED FOR EFT DETAIL #: "_RCEFT_" - Press ENTER to continue: "
End DoDot:1
+33 SET DIR(0)="EA"
+34 WRITE !
DO ^DIR
KILL DIR
+35 ;
MANTRQ QUIT
+1 ;
CHK() ; Function returns the ien of CHECK/MO payment type
+1 QUIT +$ORDER(^RC(341.1,"AC",4,0))
+2 ;
+3 ;
+4 ;
MATCH3 ; Manually 'match' a 0-balance ERA that has no check or EFT
+1 NEW DUOUT,DTOUT,DA,DR,DIE,DIC,DIR,X,Y,RCERA,RCRCPT
+2 WRITE !,"THIS OPTION WILL ALLOW YOU TO MANUALLY MARK A 0-BALANCE ERA WITH NO",!,"CHECK OR EFT AS 'MATCH-0 PAYMENT' TO REMOVE IT FROM THE ERA AGING REPORT"
M3 SET DIR("A")="SELECT THE UNMATCHED 0-BALANCE ERA TO MARK AS MATCHED: "
+1 SET DIR(0)="PAO^RCY(344.4,:AEMQ"
SET DIR("S")="I '$P(^(0),U,9),'$P(^(0),U,5)"
+2 WRITE !
DO ^DIR
KILL DIR
+3 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y'>0)
GOTO M3Q
+4 SET RCERA=+Y
+5 WRITE !
+6 SET DIC="^RCY(344.4,"
SET DR="0"
SET DA=RCERA
DO EN^DIQ
+7 WRITE !
+8 SET DIR("A")="ARE YOU SURE THIS IS THE ERA YOU WANT TO MARK AS MATCH-0 PAYMENT? (Y/N) "
SET DIR(0)="YA"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
+9 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO M3Q
+10 IF Y'=1
GOTO M3
+11 SET DIE="^RCY(344.4,"
SET DR=".09////3"
SET DA=RCERA
DO ^DIE
+12 SET DIR(0)="EA"
SET DIR("A")="ERA #"_RCERA_" WAS "_$SELECT('$DATA(Y):"SUCCESSFULLY",1:"NOT")_" MARKED AS MATCH-0 PAYMENT"
DO ^DIR
KILL DIR
M3Q QUIT
+1 ;
UNMATCH ; Used to 'unmatch' an ERA matched in error
+1 NEW AUTOPOST,DA,DIC,DIE,DIK,DIR,DIROUT,DR,DTOUT,DUOUTX,RCEFT,RCQUIT,RCWL,X,XX,Y
+2 SET DIC(0)="AEMQ"
SET DIC="^RCY(344.4,"
+3 SET DIC("S")="I '$P(^(0),U,8),$S('$P(^(0),U,14):1,1:$P(^(0),U,9)=3),$P(^(0),U,9)"
+4 DO ^DIC
KILL DIC
+5 if Y'>0
QUIT
+6 SET RCWL=+Y
SET RCQUIT=0
+7 IF $DATA(^RCY(344.49,RCWL,0))
Begin DoDot:1
+8 SET DIR(0)="YA"
+9 SET XX="THIS ERA ALREADY HAS A SCRATCH PAD ENTRY AND MUST BE DELETED BEFORE IT CAN BE"
+10 SET DIR("A",1)=XX
+11 SET DIR("A")="UNMATCHED. DO YOU WANT TO DELETE THE SCRATCH PAD ENTRY FOR THIS ERA NOW? "
+12 WRITE !
DO ^DIR
KILL DIR
+13 IF Y'=1
SET RCQUIT=1
QUIT
+14 SET DIK="^RCY(344.49,"
SET DA=RCWL
DO ^DIK
End DoDot:1
if RCQUIT
QUIT
+15 SET AUTOPOST=""
+16 IF $ORDER(^RCY(344.31,"AERA",RCWL,0))
SET RCEFT=+$ORDER(^(0))
Begin DoDot:1
+17 SET AUTOPOST=$$GET1^DIQ(344.4,RCWL_",",4.02,"I")
+18 WRITE !!,"THIS ERA IS MATCHED TO EFT #"_$$OUT^RCDPEM3(RCEFT)
+19 IF AUTOPOST=0
WRITE !,"* WARNING: This ERA will be Un-Marked as an Auto-Post CANDIDATE"
+20 SET DIR("A")="ARE YOU SURE YOU WANT TO UNMATCH THEM? "
SET DIR(0)="YA"
+21 DO ^DIR
KILL DIR
+22 IF Y'=1
SET RCQUIT=1
QUIT
+23 SET DIE="^RCY(344.31,"
SET DR=".1///@;.08////0"
SET DA=RCEFT
DO ^DIE
+24 WRITE !,"EFT #"_$$OUT^RCDPEM3(RCEFT)_" IS NOW UNMATCHED",!
End DoDot:1
if RCQUIT
QUIT
+25 ; PRCA*4.5*326 - If check if unmatched, delete date matched and user
+26 SET DIE="^RCY(344.4,"
SET DR=".09////0;.13///@;.14////0;5.03///@;5.04///@"
+27 SET DA=RCWL
+28 DO ^DIE
+29 IF AUTOPOST=0
DO SETSTA^RCDPEAP(RCWL,"@","Unmatch: Removed as Auto-Post Candidate")
+30 SET DIR("A")="ERA HAS BEEN SUCCESSFULLY UNMATCHED - Press ENTER to continue: "
+31 SET DIR(0)="EA"
WRITE !
DO ^DIR
KILL DIR
+32 QUIT
+33 ;
+34 ; PRCA*4.5*284 - Changed option name from 'Mark ERA Return to Payer' to 'Remove ERA from Active Worklist'
RETN ; Entrypoint for Remove ERA from Active Worklist
+1 ;PRCA*4.5*409 Added REASON,XX
NEW DA,DIC,DIR,DR,DTOUT,DUOUT,EXC,RCY,REASON,DIE,MSG,X,XX,Y,%
+2 DO OWNSKEY^XUSRB(.MSG,"RCDPE MARK ERA",DUZ)
+3 IF 'MSG(0)
Begin DoDot:1
+4 WRITE !!,"SORRY, YOU ARE NOT AUTHORIZED TO USE THIS OPTION"
+5 WRITE !,"This option is locked with RCDPE MARK ERA key.",!
+6 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+7 WRITE !!,"Use this option to remove an ERA from the EEOB Worklist that should not have"
+8 WRITE !,"been sent to your site by the payer; or the ERA cannot be removed off the"
+9 WRITE !,"Worklist using the 'Update ERA Posted Using Paper EOB' option."
+10 WRITE !!,"This option is only to be used if the paper check has been sent back to the"
+11 WRITE !,"payer without being deposited. Once removed, the ERA can no longer be"
+12 WRITE !,"accessed for processing, but can be viewed under the posted Worklist. For"
+13 WRITE !,"auditing purposes, this option requires the user to enter a reason for"
+14 WRITE !,"removing the ERA.",!
+15 SET DIC="^RCY(344.4,"
SET DIC(0)="AEMQ"
SET DIC("S")="I '$P(^(0),U,9),'$P(^(0),U,14)"
+16 DO ^DIC
KILL DIC
+17 if Y'>0
QUIT
+18 SET RCY=+Y
+19 SET DIR(0)="YA"
+20 SET DIR("A",1)="THIS WILL REMOVE THE ERA # "_+Y_" FROM THE ACTIVE WORKLIST"
+21 SET DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE? "
+22 WRITE !
+23 DO ^DIR
KILL DIR
+24 WRITE !
+25 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y=0)
DO NOCHNG^RCDPEMB
QUIT
+26 SET DIE="^RCY(344.4,"
SET DA=RCY
SET DR=".18"
DO ^DIE
+27 ; User didn't enter a removal reason
IF $DATA(Y)
DO NOCHNG^RCDPEMB
QUIT
+28 ;
+29 ; PRCA*4.5*284 Set EFT MATCH STATUS (#344.4,.09) as '4' FOR REMOVED rather than '2' FOR MATCHED TO PAPER CHECK
+30 DO NOW^%DTC
SET DR=".14////4;.09////4;.16////"_DUZ_";.17////"_%
DO ^DIE
+31 ;
+32 ; PRCA*4.5*409 Start
+33 ; Ask the user if they want to remove all data exceptions for the ERA
+34 ; being removed from the worklist
+35 SET DIR(0)="YA"
+36 SET DIR("A")="Remove all Data Exceptions for ERA # "_RCY_" from the Exceptions Worklist? "
+37 WRITE !
+38 DO ^DIR
KILL DIR
+39 SET EXC=$SELECT(+Y:1,1:0)
+40 SET REASON=$PIECE(^RCY(344.4,RCY,6),"^",3)
+41 WRITE !
+42 ; Don't remove exceptions
IF $DATA(DUOUT)!$DATA(DTOUT)!(Y=0)
SET EXC=0
+43 ; Remove any data exceptions
IF EXC=1
DO REMEXC^RCDPEX31(RCY,REASON)
+44 ; PRCA*4.5*409 End
+45 ;
+46 SET DIR(0)="EA"
SET DIR("A")="Press ENTER to continue: "
+47 WRITE !
DO ^DIR
+48 QUIT
