RCDPEM ;ALB/TMK/PJH - POST EFT, ERA MATCHING TO EFT ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**173,255,269,276,283,298,304,318,321,326,345,349,424**;Mar 20, 1995;Build 11
;Per VA Directive 6402, this routine should not be modified.
; IA 4050 covers call to SPL1^IBCEOBAR
; Note - keep processing in line with RCDPXPAP
;
EN ; Post EFT deposits, auto-match EFT's and ERA's
;
K ^TMP($J,"RCDPETOT"),^TMP("RCDPEAP",$J)
; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)=
; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref
; (5) EFT deposit ien 344.1 if added for EFT
;
N RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR
M RCDUZ=DUZ
N DUZ S DUZ=+$O(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0)),DUZ(0)="",DUZ(2)=$G(RCDUZ(2)) S:'DUZ DUZ=.5
K ^TMP($J,"RCXM"),^TMP($J,"RCTOT")
S ZTREQ="@"
L +^RCY(344.3,"ALOCK"):5 I '$T D G ENQ ; Lock record
. ; Send bulletin that job could not be run
. S ^TMP($J,"RCXM",1)="The nightly job to post EFT deposits and match EFTs to ERAs could not be run",^TMP($J,"RCXM",2)="Another match process was already running (lock on ^RCY(344.3,""ALOCK"") )"
. D SENDBULL^RCDPEM1
;
; Post deposits for any unposted EFTs in file 344.3
; 'Unposted' EFTs have a 0 in AMOUNT POSTED field
S ^TMP($J,"RCTOT","EFT_DEP")=0
S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$P(RC0,U,8) D
. S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1
. ; Verify check sums
. S RCSUM=$$CHKSUM^RCDPESR3(RCZ)
. I RCSUM'=$P(RC0,U,9) D Q
.. ; Bulletin that check sums do not match
.. ; Update record error list and checksum error field
.. S RCER(1)=$$SETERR^RCDPEM0(2)
.. S RCER(2)=" Checksum is invalid and the EFT deposit record is corrupted.",RCER(3)=" Stored Checksum = "_$P(RC0,U,9)_" Calculated Checksum: "_RCSUM,RCER(4)=" This EFT deposit cannot be sent to FMS. You must ask for it to be"
.. S RCER(5)=" retransmitted to your site."
.. D BULL^RCDPEM1(344.3,RC0,.RCER)
.. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0))
.. D STORERR^RCDPEM0(344.3,RCZ,.RCER) ; PRCA*4.5*424. Old bug. Add file to parameter list.
.. S DIE="^RCY(344.3,",DA=RCZ,DR=".1////1" D ^DIE
.. S ^TMP($J,"RCTOT","CSUM")=$G(^TMP($J,"RCTOT","CSUM"))+1
. ;
. S RCDEP=+$P(RC0,U,3),RECTDA=+$O(^RCY(344,"AD",RCDEP,0))
. I RCDEP D LOCKDEP(RCDEP,1)
. I 'RCDEP!'RECTDA D ; Add deposit and/or receipt to files 344.1, 344
.. I 'RCDEP D ; Add dep record RCDEP, update field .03 with the pointer
... S RCDEP=+$$ADDDEP^RCDPEM0($P(RC0,U,6),$P(RC0,U,7),RCZ)
... S ^TMP($J,"RCTOT","DEPOSIT")=$G(^TMP($J,"RCTOT","DEPOSIT"))+1
.. ;
.. I 'RECTDA,RCDEP D ; Add receipt record, post to rev source cd 8NZZ
... S RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ)
.. ;
. I RCDEP D LOCKDEP(RCDEP,0)
. ;
. I 'RCDEP!'RECTDA D Q ; Could not add entry to file 344.1 or 344
.. ; Send a bulletin, update error text
.. S RCER(1)=$$SETERR^RCDPEM0(2),RCER(2)=" "_$S('RCDEP:"Neither a deposit nor a receipt were able",1:"A receipt was not able")_" to be added - no match attempted"
.. I RCDEP,'RECTDA S RCER(3)=" Deposit Ticket # created: "_$P($G(^RCY(344.1,+$P(RC0,U,3),0)),U)
.. S RCER($O(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit"
.. D BULL^RCDPEM1(344.3,RC0,.RCER)
.. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0))
.. D STORERR^RCDPEM0(344.3,RCZ,.RCER) ; PRCA*4.5*424.Old bug. Added file to parameter list
.. S ^TMP($J,"RCTOT","ERR")=$G(^TMP($J,"RCTOT","ERR"))+1
. ;
. S DIE="^RCY(344.31," S Z=0 F S Z=$O(^RCY(344.31,"B",RCZ,Z)) Q:'Z S DA=Z,DR=".11////1" D ^DIE
;
;Update payer table for new payers - PRCA*4.5*298
D NEWPYR^RCDPESP
;Scan Non-Released Rx Exceptions for released Rx - PRCA*4.5*298
D EN^RCDPEX4
;
D MATCH(0,1)
;
;Auto Post - PRCA*4.5*298
D EN^RCDPEAP
;Auto Decrease - PRCA*4.5*298
D EN^RCDPEAD
;
I $$GET1^DIQ(342,"1,",.14,"I") D EN^RCDPEAD3() ; PRCA*4.5*345 - 1st Party Auto-Decrease
;
;Workload Notifications - PRCA*4.5*321
D EN^RCDPEM7
;
L -^RCY(344.3,"ALOCK")
ENQ K ^TMP($J,"RCDPETOT"),^TMP("RCDPEAP",$J)
;
;ePayments 5010 part II enhancements
;Create Bulletins of EEOB Moved or Copied today
D EN^RCDPEM8
Q
;
MATCH(RCMAN,RCPROC) ; match unmatched EFTs with ERAs
; RCMAN = 1 if job run manually, outside of nightly processing
; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match
;
N RC0,RCER,RCZ,RCHAC
I '$O(^RCY(344.31,"AMATCH",0,0)) D G MATCHQ
. ; Send bulletin - no unmatched EFTs found
. N RCT
. S RCT=+$O(^TMP($J,"RCXM"," "),-1)+1
. S ^TMP($J,"RCXM",RCT)=$S('$G(RCMAN):"The nightly job",1:"The manual option")_" to match EFTs has found no EFTs are currently unmatched on your system"
. I $G(RCMAN) S ^TMP($J,"RCXM",RCT+1)="The action was initiated by "_$P($G(^VA(200,DUZ,0)),U)
. D SENDBULL^RCDPEM1
;
S RCZ=0 F S RCZ=$O(^RCY(344.31,"AMATCH",0,RCZ)) Q:'RCZ D
. K RCER
. S RC0=$G(^RCY(344.31,RCZ,0)),RCHAC=($E($P($G(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC")
. Q:RC0="" ; Bad xref
. Q:$S('RCHAC:'$P(RC0,U,11),1:0) ; EFT deposit must have been recorded
. S ^TMP($J,"RCTOT","EFT")=$G(^TMP($J,"RCTOT","EFT"))+1
. I RCHAC S ^TMP($J,"RCTOT","EFT_HAC")=$G(^TMP($J,"RCTOT","EFT_HAC"))+1
. S ^TMP($J,"RCDPETOT",344.31,RCZ)=""
. ;
. D MATCH^RCDPEM0(RCZ,RCPROC)
;
I '$O(^TMP($J,"RCXM",0)) K RCER S RCER(1)="",RCER(2)="NO EXCEPTIONS WHILE MATCHING EFTs-ERAs OR IN RECORDING THE DEPOSITS TO FMS" D BULL^RCDPEM1("","",.RCER) K RCER
D EN2^RCDPEM1,BULL^RCDPEM1("","",.RCER)
D SENDBULL^RCDPEM1
;
MATCHQ K ^TMP($J,"RCDPETOT"),^TMP($J,"RCTOT")
Q
;
LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1
; If LOCK = 1 lock deposit
; If LOCK = 0 unlock deposit
I $G(LOCK) D
. L +^RCY(344.1,RCDEP,0):DILOCKTM
. D CONFIRM^RCDPUDEP(RCDEP) ; confirm to prevent changes
I '$G(LOCK) L -^RCY(344.1,RCDEP,0)
Q
; PRCA*4.5*326 Add RCDUZ to parameters
RCPTDET(RCRZ,RECTDA1,RCER,RCDUZ) ; Adds detail to a receipt based on file 344.49
; RCRZ = ien of ERA entry in file 344.49
; RECTDA1 = ien of receipt entry in file 344
; RCER = error array returned if passed by reference
;
N DA,DIE,DR,Q,RCR,RCSPL,RCZ0,RCTRANDA,RCQ,X,Y,Z0,Z1,Z ; PRCA*4.5*318
;
S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D
. S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0))
. I $P(RCZ0,U)'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q
. I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q
. S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1,$G(RCDUZ)) ; PRCA*4.5*326 Add RCDUZ to parameters
. ;
. I RCTRANDA'>0 D Q ; Error adding receipt detail - PRCA*4.5*318
.. S RCER(1)=$$SETERR^RCDPEM0(1) ; PRCA*4.5*318 - pass RCPROC value to $$SETERR
.. S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
. ;
. ;Store receipt line detail
. D DET(RCRZ,RCR,RECTDA1,RCTRANDA)
. S RCSPL(RCZ0\1,+RCZ0)=RCZ0
;
; Update A/R CORRECTED PAYMENT multiple with apportionment for split lines
S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D
. S Z1=$O(RCSPL(Z,"")) Q:Z1=""
. I $O(RCSPL(Z,""),-1)=Z1,'$$SPLIT(Z,Z1,RCERA) Q ; No split occurred
. S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D
.. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec
.. Q:'Q
.. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspensed
... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050
.. E D
... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050
. ; BEGIN - PRCA*4.5*321
. ;Move/Copy/Remove EEOB detail for split line
. N CLAIM,IEN3611,RCSPLIT,RCSUB,RCZSAV
. ; Sub-array of split claim detail for individual line
. M RCSPLIT=RCSPL(Z)
. ; Protect Z subscript variable from overwrite by triggers
. S RCZSAV=Z
. ; Get scratchpad line number for this ERA line
. S RCSUB=$O(^RCY(344.49,RCRZ,1,"ASEQ",Z,""))
. ; Original claim number from Scratchpad line
. S CLAIM=$$GET1^DIQ(344.491,RCSUB_","_RCRZ_",",.02)
. ; EOB for original claim from ERA line
. S IEN3611=$$GET1^DIQ(344.41,RCQ_","_RCRZ_",",.02,"I")
. ; Automatic Move/Copy/Remove EOB
. I $$AUTO^RCDPEM5(CLAIM,.RCSPLIT,RCERA,"W",IEN3611)
. ; Restore Z
. S Z=RCZSAV
. ; END - PRCA*4.5*321
;
Q
SPLIT(Z,Z1,RCERA) ;Check if worklist was split but to to single claim
N SUB,NBILL,OBILL
;Find split line in scratchpad
S SUB=$O(^RCY(344.49,RCERA,1,"B",Z1,"")) Q:'SUB 0
;Get original claim number from scratchpad
S OBILL=$P($G(^RCY(344.49,RCERA,1,SUB-1,0)),U,2)
;New claim number
S NBILL=$P(RCSPL(Z,Z1),U,2)
;If new and old claim are not the same this is a move via split
I OBILL'="",OBILL'=NBILL Q 1
;Otherwise this is not a split
Q 0
;
DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
; RCZ = ien of entry file 344.49
; RCR = ien of entry in file 344.491
; RCPROC = Function calling this subroutine
; = 1 EFT match to ERA = 0 manual add receipt
; RECTDA1 = ien of entry in file 344
; RCTRANDA = ien of entry in subfile 344.01
;
N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
S RC0=$G(^RCY(344.49,RCZ,0))
S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0))
S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0))
I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
S DR=DR_".04////"_(+$P(RCZ0,U,3))_";.27////"_RCR_";"
I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";"
I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";"
S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag
S RCCOM=$P(RCZ0,U,10)
I $P(RCUP,U,2)["**ADJ" S RCCOM=RCCOM_$S(RCCOM'="":"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA")
I RCCOM]"" S DR=DR_"1.02////"_$E(RCCOM,1,60)_";"
I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";"
S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1,"
D ^DIE
;Update comment history - PRCA*4.5*321
D:RCCOM]"" AUDIT^RCDPECH(RECTDA1,RCTRANDA,RCZ,RCR)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEM 10307 printed Oct 16, 2024@17:45:33 Page 2
RCDPEM ;ALB/TMK/PJH - POST EFT, ERA MATCHING TO EFT ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**173,255,269,276,283,298,304,318,321,326,345,349,424**;Mar 20, 1995;Build 11
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ; IA 4050 covers call to SPL1^IBCEOBAR
+4 ; Note - keep processing in line with RCDPXPAP
+5 ;
EN ; Post EFT deposits, auto-match EFT's and ERA's
+1 ;
+2 KILL ^TMP($JOB,"RCDPETOT"),^TMP("RCDPEAP",$JOB)
+3 ; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)=
+4 ; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref
+5 ; (5) EFT deposit ien 344.1 if added for EFT
+6 ;
+7 NEW RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR
+8 MERGE RCDUZ=DUZ
+9 NEW DUZ
SET DUZ=+$ORDER(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0))
SET DUZ(0)=""
SET DUZ(2)=$GET(RCDUZ(2))
if 'DUZ
SET DUZ=.5
+10 KILL ^TMP($JOB,"RCXM"),^TMP($JOB,"RCTOT")
+11 SET ZTREQ="@"
+12 ; Lock record
LOCK +^RCY(344.3,"ALOCK"):5
IF '$TEST
Begin DoDot:1
+13 ; Send bulletin that job could not be run
+14 SET ^TMP($JOB,"RCXM",1)="The nightly job to post EFT deposits and match EFTs to ERAs could not be run"
SET ^TMP($JOB,"RCXM",2)="Another match process was already running (lock on ^RCY(344.3,""ALOCK"") )"
+15 DO SENDBULL^RCDPEM1
End DoDot:1
GOTO ENQ
+16 ;
+17 ; Post deposits for any unposted EFTs in file 344.3
+18 ; 'Unposted' EFTs have a 0 in AMOUNT POSTED field
+19 SET ^TMP($JOB,"RCTOT","EFT_DEP")=0
+20 SET RCZ=0
FOR
SET RCZ=$ORDER(^RCY(344.3,"APOST",0,RCZ))
if 'RCZ
QUIT
SET RC0=$GET(^RCY(344.3,RCZ,0))
IF RC0'=""
IF $PIECE(RC0,U,8)
Begin DoDot:1
+21 SET ^TMP($JOB,"RCTOT","EFT_DEP")=^TMP($JOB,"RCTOT","EFT_DEP")+1
+22 ; Verify check sums
+23 SET RCSUM=$$CHKSUM^RCDPESR3(RCZ)
+24 IF RCSUM'=$PIECE(RC0,U,9)
Begin DoDot:2
+25 ; Bulletin that check sums do not match
+26 ; Update record error list and checksum error field
+27 SET RCER(1)=$$SETERR^RCDPEM0(2)
+28 SET RCER(2)=" Checksum is invalid and the EFT deposit record is corrupted."
SET RCER(3)=" Stored Checksum = "_$PIECE(RC0,U,9)_" Calculated Checksum: "_RCSUM
SET RCER(4)=" This EFT deposit cannot be sent to FMS. You must ask for it to be"
+29 SET RCER(5)=" retransmitted to your site."
+30 DO BULL^RCDPEM1(344.3,RC0,.RCER)
+31 SET $PIECE(^TMP($JOB,"RCDPETOT",344.3,RCZ),U,4)=+$GET(^TMP($JOB,"RCXM",0))
+32 ; PRCA*4.5*424. Old bug. Add file to parameter list.
DO STORERR^RCDPEM0(344.3,RCZ,.RCER)
+33 SET DIE="^RCY(344.3,"
SET DA=RCZ
SET DR=".1////1"
DO ^DIE
+34 SET ^TMP($JOB,"RCTOT","CSUM")=$GET(^TMP($JOB,"RCTOT","CSUM"))+1
End DoDot:2
QUIT
+35 ;
+36 SET RCDEP=+$PIECE(RC0,U,3)
SET RECTDA=+$ORDER(^RCY(344,"AD",RCDEP,0))
+37 IF RCDEP
DO LOCKDEP(RCDEP,1)
+38 ; Add deposit and/or receipt to files 344.1, 344
IF 'RCDEP!'RECTDA
Begin DoDot:2
+39 ; Add dep record RCDEP, update field .03 with the pointer
IF 'RCDEP
Begin DoDot:3
+40 SET RCDEP=+$$ADDDEP^RCDPEM0($PIECE(RC0,U,6),$PIECE(RC0,U,7),RCZ)
+41 SET ^TMP($JOB,"RCTOT","DEPOSIT")=$GET(^TMP($JOB,"RCTOT","DEPOSIT"))+1
End DoDot:3
+42 ;
+43 ; Add receipt record, post to rev source cd 8NZZ
IF 'RECTDA
IF RCDEP
Begin DoDot:3
+44 SET RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ)
End DoDot:3
+45 ;
End DoDot:2
+46 IF RCDEP
DO LOCKDEP(RCDEP,0)
+47 ;
+48 ; Could not add entry to file 344.1 or 344
IF 'RCDEP!'RECTDA
Begin DoDot:2
+49 ; Send a bulletin, update error text
+50 SET RCER(1)=$$SETERR^RCDPEM0(2)
SET RCER(2)=" "_$SELECT('RCDEP:"Neither a deposit nor a receipt were able",1:"A receipt was not able")_" to be added - no match attempted"
+51 IF RCDEP
IF 'RECTDA
SET RCER(3)=" Deposit Ticket # created: "_$PIECE($GET(^RCY(344.1,+$PIECE(RC0,U,3),0)),U)
+52 SET RCER($ORDER(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit"
+53 DO BULL^RCDPEM1(344.3,RC0,.RCER)
+54 SET $PIECE(^TMP($JOB,"RCDPETOT",344.3,RCZ),U,4)=+$GET(^TMP($JOB,"RCXM",0))
+55 ; PRCA*4.5*424.Old bug. Added file to parameter list
DO STORERR^RCDPEM0(344.3,RCZ,.RCER)
+56 SET ^TMP($JOB,"RCTOT","ERR")=$GET(^TMP($JOB,"RCTOT","ERR"))+1
End DoDot:2
QUIT
+57 ;
+58 SET DIE="^RCY(344.31,"
SET Z=0
FOR
SET Z=$ORDER(^RCY(344.31,"B",RCZ,Z))
if 'Z
QUIT
SET DA=Z
SET DR=".11////1"
DO ^DIE
End DoDot:1
+59 ;
+60 ;Update payer table for new payers - PRCA*4.5*298
+61 DO NEWPYR^RCDPESP
+62 ;Scan Non-Released Rx Exceptions for released Rx - PRCA*4.5*298
+63 DO EN^RCDPEX4
+64 ;
+65 DO MATCH(0,1)
+66 ;
+67 ;Auto Post - PRCA*4.5*298
+68 DO EN^RCDPEAP
+69 ;Auto Decrease - PRCA*4.5*298
+70 DO EN^RCDPEAD
+71 ;
+72 ; PRCA*4.5*345 - 1st Party Auto-Decrease
IF $$GET1^DIQ(342,"1,",.14,"I")
DO EN^RCDPEAD3()
+73 ;
+74 ;Workload Notifications - PRCA*4.5*321
+75 DO EN^RCDPEM7
+76 ;
+77 LOCK -^RCY(344.3,"ALOCK")
ENQ KILL ^TMP($JOB,"RCDPETOT"),^TMP("RCDPEAP",$JOB)
+1 ;
+2 ;ePayments 5010 part II enhancements
+3 ;Create Bulletins of EEOB Moved or Copied today
+4 DO EN^RCDPEM8
+5 QUIT
+6 ;
MATCH(RCMAN,RCPROC) ; match unmatched EFTs with ERAs
+1 ; RCMAN = 1 if job run manually, outside of nightly processing
+2 ; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match
+3 ;
+4 NEW RC0,RCER,RCZ,RCHAC
+5 IF '$ORDER(^RCY(344.31,"AMATCH",0,0))
Begin DoDot:1
+6 ; Send bulletin - no unmatched EFTs found
+7 NEW RCT
+8 SET RCT=+$ORDER(^TMP($JOB,"RCXM"," "),-1)+1
+9 SET ^TMP($JOB,"RCXM",RCT)=$SELECT('$GET(RCMAN):"The nightly job",1:"The manual option")_" to match EFTs has found no EFTs are currently unmatched on your system"
+10 IF $GET(RCMAN)
SET ^TMP($JOB,"RCXM",RCT+1)="The action was initiated by "_$PIECE($GET(^VA(200,DUZ,0)),U)
+11 DO SENDBULL^RCDPEM1
End DoDot:1
GOTO MATCHQ
+12 ;
+13 SET RCZ=0
FOR
SET RCZ=$ORDER(^RCY(344.31,"AMATCH",0,RCZ))
if 'RCZ
QUIT
Begin DoDot:1
+14 KILL RCER
+15 SET RC0=$GET(^RCY(344.31,RCZ,0))
SET RCHAC=($EXTRACT($PIECE($GET(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC")
+16 ; Bad xref
if RC0=""
QUIT
+17 ; EFT deposit must have been recorded
if $SELECT('RCHAC
QUIT
+18 SET ^TMP($JOB,"RCTOT","EFT")=$GET(^TMP($JOB,"RCTOT","EFT"))+1
+19 IF RCHAC
SET ^TMP($JOB,"RCTOT","EFT_HAC")=$GET(^TMP($JOB,"RCTOT","EFT_HAC"))+1
+20 SET ^TMP($JOB,"RCDPETOT",344.31,RCZ)=""
+21 ;
+22 DO MATCH^RCDPEM0(RCZ,RCPROC)
End DoDot:1
+23 ;
+24 IF '$ORDER(^TMP($JOB,"RCXM",0))
KILL RCER
SET RCER(1)=""
SET RCER(2)="NO EXCEPTIONS WHILE MATCHING EFTs-ERAs OR IN RECORDING THE DEPOSITS TO FMS"
DO BULL^RCDPEM1("","",.RCER)
KILL RCER
+25 DO EN2^RCDPEM1
DO BULL^RCDPEM1("","",.RCER)
+26 DO SENDBULL^RCDPEM1
+27 ;
MATCHQ KILL ^TMP($JOB,"RCDPETOT"),^TMP($JOB,"RCTOT")
+1 QUIT
+2 ;
LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1
+1 ; If LOCK = 1 lock deposit
+2 ; If LOCK = 0 unlock deposit
+3 IF $GET(LOCK)
Begin DoDot:1
+4 LOCK +^RCY(344.1,RCDEP,0):DILOCKTM
+5 ; confirm to prevent changes
DO CONFIRM^RCDPUDEP(RCDEP)
End DoDot:1
+6 IF '$GET(LOCK)
LOCK -^RCY(344.1,RCDEP,0)
+7 QUIT
+8 ; PRCA*4.5*326 Add RCDUZ to parameters
RCPTDET(RCRZ,RECTDA1,RCER,RCDUZ) ; Adds detail to a receipt based on file 344.49
+1 ; RCRZ = ien of ERA entry in file 344.49
+2 ; RECTDA1 = ien of receipt entry in file 344
+3 ; RCER = error array returned if passed by reference
+4 ;
+5 ; PRCA*4.5*318
NEW DA,DIE,DR,Q,RCR,RCSPL,RCZ0,RCTRANDA,RCQ,X,Y,Z0,Z1,Z
+6 ;
+7 SET RCR=0
FOR
SET RCR=$ORDER(^RCY(344.49,RCRZ,1,RCR))
if 'RCR
QUIT
Begin DoDot:1
+8 SET RCZ0=$GET(^RCY(344.49,RCRZ,1,RCR,0))
+9 IF $PIECE(RCZ0,U)'["."
SET RCSPL(+RCZ0)=$PIECE(RCZ0,U,9)
QUIT
+10 IF $SELECT(+$PIECE(RCZ0,U,3)=0:$PIECE($GET(^RCY(344.49,RCRZ,0)),U,3),1:$PIECE(RCZ0,U,3)<0)
SET RCSPL(RCZ0\1,+RCZ0)=RCZ0
QUIT
+11 ; PRCA*4.5*326 Add RCDUZ to parameters
SET RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1,$GET(RCDUZ))
+12 ;
+13 ; Error adding receipt detail - PRCA*4.5*318
IF RCTRANDA'>0
Begin DoDot:2
+14 ; PRCA*4.5*318 - pass RCPROC value to $$SETERR
SET RCER(1)=$$SETERR^RCDPEM0(1)
+15 SET RCER($ORDER(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$PIECE($GET(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$PIECE(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
End DoDot:2
QUIT
+16 ;
+17 ;Store receipt line detail
+18 DO DET(RCRZ,RCR,RECTDA1,RCTRANDA)
+19 SET RCSPL(RCZ0\1,+RCZ0)=RCZ0
End DoDot:1
+20 ;
+21 ; Update A/R CORRECTED PAYMENT multiple with apportionment for split lines
+22 SET Z=0
FOR
SET Z=$ORDER(RCSPL(Z))
if 'Z
QUIT
SET RCQ=+$GET(RCSPL(Z))
IF RCQ
Begin DoDot:1
+23 SET Z1=$ORDER(RCSPL(Z,""))
if Z1=""
QUIT
+24 ; No split occurred
IF $ORDER(RCSPL(Z,""),-1)=Z1
IF '$$SPLIT(Z,Z1,RCERA)
QUIT
+25 SET Z1=0
FOR
SET Z1=$ORDER(RCSPL(Z,Z1))
if 'Z1
QUIT
SET Z0=$GET(RCSPL(Z,Z1))
Begin DoDot:2
+26 ; EOB detail rec
SET Q=+$PIECE($GET(^RCY(344.4,RCRZ,1,RCQ,0)),U,2)
+27 if 'Q
QUIT
+28 ; Suspensed
IF '$PIECE(Z0,U,7)!($PIECE(Z0,U,2)="")
Begin DoDot:3
+29 ; IA 4050
DO SPL1^IBCEOBAR(Q,$SELECT($PIECE(Z0,U,2)="":"NO BILL",1:$PIECE(Z0,U,2)),"",$PIECE(Z0,U,6))
End DoDot:3
+30 IF '$TEST
Begin DoDot:3
+31 ; Add the split bill # ; IA 4050
DO SPL1^IBCEOBAR(Q,$PIECE(Z0,U,2),$PIECE(Z0,U,7),$PIECE(Z0,U,6))
End DoDot:3
End DoDot:2
+32 ; BEGIN - PRCA*4.5*321
+33 ;Move/Copy/Remove EEOB detail for split line
+34 NEW CLAIM,IEN3611,RCSPLIT,RCSUB,RCZSAV
+35 ; Sub-array of split claim detail for individual line
+36 MERGE RCSPLIT=RCSPL(Z)
+37 ; Protect Z subscript variable from overwrite by triggers
+38 SET RCZSAV=Z
+39 ; Get scratchpad line number for this ERA line
+40 SET RCSUB=$ORDER(^RCY(344.49,RCRZ,1,"ASEQ",Z,""))
+41 ; Original claim number from Scratchpad line
+42 SET CLAIM=$$GET1^DIQ(344.491,RCSUB_","_RCRZ_",",.02)
+43 ; EOB for original claim from ERA line
+44 SET IEN3611=$$GET1^DIQ(344.41,RCQ_","_RCRZ_",",.02,"I")
+45 ; Automatic Move/Copy/Remove EOB
+46 IF $$AUTO^RCDPEM5(CLAIM,.RCSPLIT,RCERA,"W",IEN3611)
+47 ; Restore Z
+48 SET Z=RCZSAV
+49 ; END - PRCA*4.5*321
End DoDot:1
+50 ;
+51 QUIT
SPLIT(Z,Z1,RCERA) ;Check if worklist was split but to to single claim
+1 NEW SUB,NBILL,OBILL
+2 ;Find split line in scratchpad
+3 SET SUB=$ORDER(^RCY(344.49,RCERA,1,"B",Z1,""))
if 'SUB
QUIT 0
+4 ;Get original claim number from scratchpad
+5 SET OBILL=$PIECE($GET(^RCY(344.49,RCERA,1,SUB-1,0)),U,2)
+6 ;New claim number
+7 SET NBILL=$PIECE(RCSPL(Z,Z1),U,2)
+8 ;If new and old claim are not the same this is a move via split
+9 IF OBILL'=""
IF OBILL'=NBILL
QUIT 1
+10 ;Otherwise this is not a split
+11 QUIT 0
+12 ;
DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
+1 ; RCZ = ien of entry file 344.49
+2 ; RCR = ien of entry in file 344.491
+3 ; RCPROC = Function calling this subroutine
+4 ; = 1 EFT match to ERA = 0 manual add receipt
+5 ; RECTDA1 = ien of entry in file 344
+6 ; RCTRANDA = ien of entry in subfile 344.01
+7 ;
+8 NEW DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
+9 SET RC0=$GET(^RCY(344.49,RCZ,0))
+10 SET RCZ0=$GET(^RCY(344.49,RCZ,1,RCR,0))
+11 SET DR=""
SET RCUP=+$ORDER(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0))
SET RCUP=$GET(^RCY(344.49,RCZ,1,RCUP,0))
+12 IF $PIECE(RCZ0,U,7)
SET DR=".09////^S X="_+$PIECE(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
+13 SET DR=DR_".04////"_(+$PIECE(RCZ0,U,3))_";.27////"_RCR_";"
+14 IF $PIECE(RC0,U,5)'=""
SET DR=DR_".1////"_$PIECE(RC0,U,5)_";"
+15 IF $PIECE(RC0,U,6)'=""
SET DR=DR_".08////"_$PIECE(RC0,U,6)_";"
+16 ; Update receipt line with dec adj flag
SET Z=0
FOR
SET Z=$ORDER(^RCY(344.49,RCZ,1,RCR,1,Z))
if 'Z
QUIT
IF $PIECE($GET(^(Z,0)),U,5)=1
SET DR=DR_".28////1;"
QUIT
+17 SET RCCOM=$PIECE(RCZ0,U,10)
+18 IF $PIECE(RCUP,U,2)["**ADJ"
SET RCCOM=RCCOM_$SELECT(RCCOM'="":"/",1:"")_$SELECT($PIECE($PIECE(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA")
+19 IF RCCOM]""
SET DR=DR_"1.02////"_$EXTRACT(RCCOM,1,60)_";"
+20 IF $PIECE($GET(^RCY(344.49,RCZ,0)),U,4)'=""
SET DR=DR_".07////"_$PIECE($GET(^RCY(344.49,RCZ,0)),U,4)_";"
+21 SET DA(1)=RECTDA1
SET DA=RCTRANDA
SET DIE="^RCY(344,"_DA(1)_",1,"
+22 DO ^DIE
+23 ;Update comment history - PRCA*4.5*321
+24 if RCCOM]""
DO AUDIT^RCDPECH(RECTDA1,RCTRANDA,RCZ,RCR)
+25 QUIT
+26 ;
