RCDPESR3 ;ALB/TMK/PJH - Server auto-update utilities - EDI Lockbox ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**173,214,208,255,269,283,298,321,345,349,380**;Mar 20, 1995;Build 14
;Per VA Directive 6402, this routine should not be modified.
Q
;
EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3
; from Lockbox EFT msg
; Input: RCTXN - Data on the header record of the message text
; RCD - Array containing formatted mail message header data
; XMZ - Mail message number
; RCGBL - Name of the array or global where the message is stored
; Output: RCEFLG - Error flag returned if passed by reference
;
N CT,DA,DIK,DLAYGO,RC,RC1,RCLAST,RCDEPAMT,RCEFT,RCMEFTS,RCTDA,RCERR,RCTYP1,RCZ,XX,Z,Z0
;
; Take data out of mail message
S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT"
F X XMREC Q:XMER<0 D Q:RCLAST
. I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q
. S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG
;
; PRCA*4.5*349 - Removed killing of RCGBL to ensure raw data gets sent in error message
I 'RCLAST,'$G(RCERR) S RCERR=2 ; No $ as last character of msg
;
I $G(RCERR)>0 D G EFTQ
. D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
. S RCEFLG=1
;
; Add top-level entry to file 344.3
S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR)
;
I $G(RCERR) D G EFTQ ; 'BAD' EFT's
. D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
. S RCEFLG=1
;
G:'RCEFT EFTQ
;
; PRCA*4.5*380 - No longer deleting EFT Details
;
S (RC,RC1,RCZ)=0
F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR)
. I $P(Z0,U)="01" D ; Each payer's data
. . N DA,DD,DIC,DIE,DO,DR,X,Y
. . S X=RCEFT
. . S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"
. . S DIC("DR")=DIC("DR")_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")
. . S DIC("DR")=DIC("DR")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")
. . S DIC("DR")=DIC("DR")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)
. . S DIC("DR")=DIC("DR")_";.06////"_$S($P(Z0,U,8)'="":1,1:0)
. . S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))
. . S DIC("DR")=DIC("DR")_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")
. . S DIC("DR")=DIC("DR")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"")
. . S XX=$S($P(Z0,U,10)="D":"D",$P(Z0,U,10)="-":"D",1:"")
. . S DIC("DR")=DIC("DR")_";3////"_XX ; PRCA*4.5*321 added filing of this field
. . ;
. . I $P(Z0,U,8)'="" D ; Tax id error
. . . S XX=$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6)
. . . D TAXERR^RCDPESR1("EFT",XX,$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin
. . ;
. . S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31
. . D FILE^DICN
. . K DIC,DLAYGO,DO,DD
. . I Y'>0 D ; Error filing data
. . . S DIK="^RCY(344.3,",DA=RCEFT D ^DIK
. . . S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK
. . . S RCEFLG=1,RCERR=3
. . . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR)
;
I '$G(RCEFLG) D
. S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE
;
EFTQ ;
D CLEAN^DILF
Q
;
ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3
; RCTXN = the data on the header record of the message text
; RCXMZ = the mail message number
; RCGBL = the name of the array or global where the message is stored
; Function returns the ien of the total record found/added
; and also returns RCERR if passed by reference
;
N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0
S (RCERR,RCTDA)=""
;
;----- changed for PRCA*4.5*283
;I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="569",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number
;. N RCDXM,RCCT
;. S RCCT=0
;. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
;. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
;. D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ)
;-----
;
; Make sure it's not already there or if so, it has no ptr to a deposit
; or if a deposit exists, that the deposit does not yet have a receipt
S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit
I $P(RCTXN,U,6)'="" D
. ;Format Deposit Date as FM date
. N RCDDAT
. S X=$$FDT^RCDPESR9($P(RCTXN,U,7))
. S RCDDAT=0,%DT="X" D ^%DT S:Y>0 RCDDAT=Y
. S Z=0 ; Lookup deposit by deposit #
. ; PRCA*4.5*380 - Don't quit now until we've either gone through all the records or found a valid match, since we might be matching
. ; a duplicate record now
. F S Z=$O(^RCY(344.3,"ADEP",RCDDAT,$P(RCTXN,U,6),Z)) Q:'Z S Z0=$G(^RCY(344.3,Z,0)) S:'$P(Z0,U,3) RCTDA=Z Q:RCTDA D Q:RCTDA
.. ; Deposit found - find receipt
.. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q
.. S RCTDA=Z
;
;-----
; PRCA*4.5*298 - MailMan message disabled, logic retained - 14 Feb 2014
;I RCDUP D ; Send bulletin that duplicate EFT received
;. N RCDXM,RCCT
;. S RCCT=0
;. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
;. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
;. D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ)
;-----
;
; PRCA*4.5*380 - Removed check for dup; will now just create new transaction, instead
N %DT,DA,DD,DEPAMT,DIC,DIE,DINUM,DLAYGO,DO,DR,RCDTTM,RCX,X,Y
;
S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4)
S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y
;
;PRCA*4.5*380 - If updating an existing deposit, add new deposit amount to existing total
S DEPAMT=$S(RCTDA:+$$GET1^DIQ(344.3,RCTDA_",",.08),1:0)+$$ZERO^RCDPESR9($P(RCTXN,U,8),1)
;
S DIC("DR")=""
S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"")
S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7))
;PRCA*4.5*380 - If updating an existing deposit, add new deposit amount to existing total
S DIC("DR")=DIC("DR")_";.08////"_DEPAMT_";.13////"_$$NOW^XLFDT()_$S('RCTDA:";.05////"_RCXMZ,1:"")_";.14////0;.12////0"
;
I RCTDA D ; Update the data already there
. L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q
. S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE
. K DIE,DA,DR
. ; PRCA*4.5*380 - Add an entry to the subsequent mail messages multiple
. S DIC="^RCY(344.3,"_RCTDA_",3,",DIC(0)="L",DA(1)=RCTDA,X=RCXMZ
. D FILE^DICN K DA,DIC
. L -^RCY(344.3,RCTDA)
;
I 'RCTDA D
. S RCX=+$O(^RCY(344.3," "),-1)
. F RCX=RCX+1:1 I '$D(^RCY(344.3,RCX,0)) L +^RCY(344.3,RCX,0):1 I $T S X=RCX Q
. S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX
. D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM
. L -^RCY(344.3,RCX,0)
. S RCTDA=$S(Y<0:"",1:+Y)
;
I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3
;
ADDQ Q $S(RCTDA>0:RCTDA,1:"")
;
CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3
;
N RCDPCSUM,RCDPDATA,X,Y,Z,Z0
;
S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0))
; Use pcs 1-8, leaving out piece 3
S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)=""
S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y
; Use detail iens and pieces 3,4,7 to complete the checksum
S Z=0 F S Z=$O(^RCY(344.31,"B",RCTDA,Z)) Q:'Z S Z0=$G(^RCY(344.31,Z,0)),RCDPDATA=Z_U_$P(Z0,U,3,4)_U_$P(Z0,U,7),X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y
Q RCDPCSUM
;
DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message
; RCTIT = title of bulletin
; RCCT = # of lines previously populated
; RCXDM = array containing the text of the bulletin
N RC,Z
K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0))
S Z=0 F S Z=$O(^TMP("RCMSG",$J,2,"D",Z)) Q:'Z S RC=RC+1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSG",$J,2,"D",Z))
D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75)
S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z))
D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM)
K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
Q
;
DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1?
; RCM = msg # EOB was received in
; RCIFN = bill ien
; RCAMT = amt pd
; RCAMT1 = amt reported billed
; Returns 0 if none found, entry #^message checksum on file if found
N Z,DUP,DUP1
S (DUP,DUP1,Z)=0
F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP
. I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before
. I +$G(^IBM(361.1,Z,1))=+RCAMT,+$P($G(^IBM(361.1,1,Z,2)),U,4)=+RCAMT1 S DUP=Z_U_+$P($G(^IBM(361.1,Z,100)),U,5) Q
I 'DUP,DUP1 S DUP=DUP1_"^0"
Q DUP
;
DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA
; RCNOUPD = # of message with duplicate data
; DUP = flag = -1 if duplicate message received in same mail msg #
K ^TMP("RCERR1",$J)
S ^TMP("RCERR1",$J,1)=$S(DUP>0:"This an exact duplicate of an ERA received previously in mail msg "_RCNOUPD,1:"This ERA message was already fully processed - message was ignored")
Q
;
BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA
; PRCA*4.5*298 - DUPLICATE TRANSMISSION MSG AND EEOB - EXCEPTIONS message disabled - 14 Feb 2014
;I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:""))
I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG)
Q
;
ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref
; Function returns # of lines for error text
S RCERR(1)="At least 1 adjustment transaction has been found on this ERA. Before the",RCERR(2)=" receipt for this ERA can be processed, the appropriate adjustments",RCERR(3)=" must be made using the EEOB Worklist",RCERR(4)=" "
Q 4
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPESR3 9917 printed Dec 13, 2024@01:45:24 Page 2
RCDPESR3 ;ALB/TMK/PJH - Server auto-update utilities - EDI Lockbox ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**173,214,208,255,269,283,298,321,345,349,380**;Mar 20, 1995;Build 14
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3
+1 ; from Lockbox EFT msg
+2 ; Input: RCTXN - Data on the header record of the message text
+3 ; RCD - Array containing formatted mail message header data
+4 ; XMZ - Mail message number
+5 ; RCGBL - Name of the array or global where the message is stored
+6 ; Output: RCEFLG - Error flag returned if passed by reference
+7 ;
+8 NEW CT,DA,DIK,DLAYGO,RC,RC1,RCLAST,RCDEPAMT,RCEFT,RCMEFTS,RCTDA,RCERR,RCTYP1,RCZ,XX,Z,Z0
+9 ;
+10 ; Take data out of mail message
+11 SET (RCEFLG,RCLAST)=0
SET CT=0
SET RCTYP1="835EFT"
+12 FOR
XECUTE XMREC
if XMER<0
QUIT
Begin DoDot:1
+13 IF +XMRG=99
IF $PIECE(XMRG,U,2)="$"
SET RCLAST=1
QUIT
+14 if XMRG'=""
SET CT=CT+1
SET @RCGBL@(2,"D",CT)=XMRG
End DoDot:1
if RCLAST
QUIT
+15 ;
+16 ; PRCA*4.5*349 - Removed killing of RCGBL to ensure raw data gets sent in error message
+17 ; No $ as last character of msg
IF 'RCLAST
IF '$GET(RCERR)
SET RCERR=2
+18 ;
+19 IF $GET(RCERR)>0
Begin DoDot:1
+20 DO ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
+21 SET RCEFLG=1
End DoDot:1
GOTO EFTQ
+22 ;
+23 ; Add top-level entry to file 344.3
+24 SET RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR)
+25 ;
+26 ; 'BAD' EFT's
IF $GET(RCERR)
Begin DoDot:1
+27 DO ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
+28 SET RCEFLG=1
End DoDot:1
GOTO EFTQ
+29 ;
+30 if 'RCEFT
GOTO EFTQ
+31 ;
+32 ; PRCA*4.5*380 - No longer deleting EFT Details
+33 ;
+34 SET (RC,RC1,RCZ)=0
+35 FOR
SET RCZ=$ORDER(@RCGBL@(2,"D",RCZ))
if 'RCZ
QUIT
SET Z0=$GET(^(RCZ))
IF Z0'=""
Begin DoDot:1
+36 ; Each payer's data
IF $PIECE(Z0,U)="01"
Begin DoDot:2
+37 NEW DA,DD,DIC,DIE,DO,DR,X,Y
+38 SET X=RCEFT
+39 SET DIC("DR")=".11////0;.04////"_$PIECE(Z0,U,2)_";.08////0"
+40 SET DIC("DR")=DIC("DR")_$SELECT($PIECE(Z0,U,5)'="":";.02////"_$PIECE(Z0,U,5),1:"")
+41 SET DIC("DR")=DIC("DR")_$SELECT($PIECE(Z0,U,6)'="":";.03////"_$PIECE(Z0,U,6),1:"")
+42 SET DIC("DR")=DIC("DR")_";.07////"_$JUSTIFY(+$PIECE(Z0,U,4)/100,"",2)
+43 SET DIC("DR")=DIC("DR")_";.06////"_$SELECT($PIECE(Z0,U,8)'="":1,1:0)
+44 SET DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($PIECE(Z0,U,3))
+45 SET DIC("DR")=DIC("DR")_";.13////"_DT_$SELECT($PIECE(Z0,U,7)'="":";.05////"_$PIECE(Z0,U,7),1:"")
+46 SET DIC("DR")=DIC("DR")_$SELECT($PIECE(Z0,U,9)'="":";.15////"_$PIECE(Z0,U,9),1:"")
+47 SET XX=$SELECT($PIECE(Z0,U,10)="D":"D",$PIECE(Z0,U,10)="-":"D",1:"")
+48 ; PRCA*4.5*321 added filing of this field
SET DIC("DR")=DIC("DR")_";3////"_XX
+49 ;
+50 ; Tax id error
IF $PIECE(Z0,U,8)'=""
Begin DoDot:3
+51 SET XX=$PIECE(Z0,U,5)_" Payer ID: "_$PIECE(RCTXN,U,6)
+52 ; Send bad tax id bulletin
DO TAXERR^RCDPESR1("EFT",XX,$PIECE(RCTXN,U,7),$PIECE(RCTXN,U,8))
End DoDot:3
+53 ;
+54 SET DIC(0)="L"
SET DIC="^RCY(344.31,"
SET DLAYGO=344.31
+55 DO FILE^DICN
+56 KILL DIC,DLAYGO,DO,DD
+57 ; Error filing data
IF Y'>0
Begin DoDot:3
+58 SET DIK="^RCY(344.3,"
SET DA=RCEFT
DO ^DIK
+59 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.31,"B",RCEFT,Z))
if 'Z
QUIT
SET DIK="^RCY(344.31,"
SET DA=Z
DO ^DIK
+60 SET RCEFLG=1
SET RCERR=3
+61 DO ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR)
End DoDot:3
End DoDot:2
End DoDot:1
if $GET(RCERR)
QUIT
+62 ;
+63 IF '$GET(RCEFLG)
Begin DoDot:1
+64 SET DIE="^RCY(344.3,"
SET DA=RCEFT
SET DR=".09////"_$$CHKSUM(RCEFT)
DO ^DIE
End DoDot:1
+65 ;
EFTQ ;
+1 DO CLEAN^DILF
+2 QUIT
+3 ;
ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3
+1 ; RCTXN = the data on the header record of the message text
+2 ; RCXMZ = the mail message number
+3 ; RCGBL = the name of the array or global where the message is stored
+4 ; Function returns the ien of the total record found/added
+5 ; and also returns RCERR if passed by reference
+6 ;
+7 NEW RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0
+8 SET (RCERR,RCTDA)=""
+9 ;
+10 ;----- changed for PRCA*4.5*283
+11 ;I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="569",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number
+12 ;. N RCDXM,RCCT
+13 ;. S RCCT=0
+14 ;. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
+15 ;. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
+16 ;. D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ)
+17 ;-----
+18 ;
+19 ; Make sure it's not already there or if so, it has no ptr to a deposit
+20 ; or if a deposit exists, that the deposit does not yet have a receipt
+21 ; This is a HAC deposit
SET RCDUP=0
SET RCHAC=$EXTRACT($PIECE(RCTXN,U,6),1,3)="HAC"
+22 IF $PIECE(RCTXN,U,6)'=""
Begin DoDot:1
+23 ;Format Deposit Date as FM date
+24 NEW RCDDAT
+25 SET X=$$FDT^RCDPESR9($PIECE(RCTXN,U,7))
+26 SET RCDDAT=0
SET %DT="X"
DO ^%DT
if Y>0
SET RCDDAT=Y
+27 ; Lookup deposit by deposit #
SET Z=0
+28 ; PRCA*4.5*380 - Don't quit now until we've either gone through all the records or found a valid match, since we might be matching
+29 ; a duplicate record now
+30 FOR
SET Z=$ORDER(^RCY(344.3,"ADEP",RCDDAT,$PIECE(RCTXN,U,6),Z))
if 'Z
QUIT
SET Z0=$GET(^RCY(344.3,Z,0))
if '$PIECE(Z0,U,3)
SET RCTDA=Z
if RCTDA
QUIT
Begin DoDot:2
+31 ; Deposit found - find receipt
+32 IF $ORDER(^RCY(344,"AD",$PIECE(Z0,U,3),0))
SET RCDUP=Z
QUIT
+33 SET RCTDA=Z
End DoDot:2
if RCTDA
QUIT
End DoDot:1
+34 ;
+35 ;-----
+36 ; PRCA*4.5*298 - MailMan message disabled, logic retained - 14 Feb 2014
+37 ;I RCDUP D ; Send bulletin that duplicate EFT received
+38 ;. N RCDXM,RCCT
+39 ;. S RCCT=0
+40 ;. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
+41 ;. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
+42 ;. D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ)
+43 ;-----
+44 ;
+45 ; PRCA*4.5*380 - Removed check for dup; will now just create new transaction, instead
+46 NEW %DT,DA,DD,DEPAMT,DIC,DIE,DINUM,DLAYGO,DO,DR,RCDTTM,RCX,X,Y
+47 ;
+48 SET X=$$FDT^RCDPESR9($PIECE(RCTXN,U,3))_"@"_$PIECE(RCTXN,U,4)
+49 SET %DT="XTS"
DO ^%DT
if Y>0
SET RCDTTM=Y
+50 ;
+51 ;PRCA*4.5*380 - If updating an existing deposit, add new deposit amount to existing total
+52 SET DEPAMT=$SELECT(RCTDA:+$$GET1^DIQ(344.3,RCTDA_",",.08),1:0)+$$ZERO^RCDPESR9($PIECE(RCTXN,U,8),1)
+53 ;
+54 SET DIC("DR")=""
+55 SET DIC("DR")=$SELECT(RCDTTM'="":".02////"_RCDTTM,1:"")
+56 SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")'="":";",1:"")_".06////"_$PIECE(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($PIECE(RCTXN,U,7))
+57 ;PRCA*4.5*380 - If updating an existing deposit, add new deposit amount to existing total
+58 SET DIC("DR")=DIC("DR")_";.08////"_DEPAMT_";.13////"_$$NOW^XLFDT()_$SELECT('RCTDA:";.05////"_RCXMZ,1:"")_";.14////0;.12////0"
+59 ;
+60 ; Update the data already there
IF RCTDA
Begin DoDot:1
+61 LOCK +^RCY(344.3,RCTDA):1
IF '$TEST
SET RCTDA=-1
QUIT
+62 SET DIE="^RCY(344.3,"
SET DA=RCTDA
SET DR=DIC("DR")
KILL DIC
DO ^DIE
+63 KILL DIE,DA,DR
+64 ; PRCA*4.5*380 - Add an entry to the subsequent mail messages multiple
+65 SET DIC="^RCY(344.3,"_RCTDA_",3,"
SET DIC(0)="L"
SET DA(1)=RCTDA
SET X=RCXMZ
+66 DO FILE^DICN
KILL DA,DIC
+67 LOCK -^RCY(344.3,RCTDA)
End DoDot:1
+68 ;
+69 IF 'RCTDA
Begin DoDot:1
+70 SET RCX=+$ORDER(^RCY(344.3," "),-1)
+71 FOR RCX=RCX+1:1
IF '$DATA(^RCY(344.3,RCX,0))
LOCK +^RCY(344.3,RCX,0):1
IF $TEST
SET X=RCX
QUIT
+72 SET DIC(0)="L"
SET DIC="^RCY(344.3,"
SET DLAYGO=344.3
SET DINUM=RCX
+73 DO FILE^DICN
KILL DO,DD,DLAYGO,DIC,DINUM
+74 LOCK -^RCY(344.3,RCX,0)
+75 SET RCTDA=$SELECT(Y<0:"",1:+Y)
End DoDot:1
+76 ;
+77 ; Error in add of EFT record to file 344.3
IF 'RCTDA
SET RCERR=3
+78 ;
ADDQ QUIT $SELECT(RCTDA>0:RCTDA,1:"")
+1 ;
CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3
+1 ;
+2 NEW RCDPCSUM,RCDPDATA,X,Y,Z,Z0
+3 ;
+4 SET (RCDPCSUM,X)=0
SET Z0=$GET(^RCY(344.3,RCTDA,0))
+5 ; Use pcs 1-8, leaving out piece 3
+6 SET RCDPDATA=$PIECE(Z0,U,1,8)
SET $PIECE(RCDPDATA,U,3)=""
+7 SET X=RCDPCSUM_RCDPDATA
XECUTE $SELECT($GET(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""")
SET RCDPCSUM=Y
+8 ; Use detail iens and pieces 3,4,7 to complete the checksum
+9 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.31,"B",RCTDA,Z))
if 'Z
QUIT
SET Z0=$GET(^RCY(344.31,Z,0))
SET RCDPDATA=Z_U_$PIECE(Z0,U,3,4)_U_$PIECE(Z0,U,7)
SET X=RCDPCSUM_RCDPDATA
XECUTE $SELECT($GET(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""")
SET RCDPCSUM=Y
+10 QUIT RCDPCSUM
+11 ;
DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message
+1 ; RCTIT = title of bulletin
+2 ; RCCT = # of lines previously populated
+3 ; RCXDM = array containing the text of the bulletin
+4 NEW RC,Z
+5 KILL ^TMP("RC1",$JOB),^TMP("RC",$JOB),^TMP("RCTEMP",$JOB)
+6 SET RC=1
SET ^TMP("RCTEMP",$JOB,RC)=$GET(^TMP("RCMSGH",$JOB,0))
+7 SET Z=0
FOR
SET Z=$ORDER(^TMP("RCMSG",$JOB,2,"D",Z))
if 'Z
QUIT
SET RC=RC+1
SET ^TMP("RCTEMP",$JOB,RC)=$GET(^TMP("RCMSG",$JOB,2,"D",Z))
+8 DO DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75)
+9 SET Z=0
FOR
SET Z=$ORDER(^TMP("RC",$JOB,Z))
if 'Z
QUIT
SET RCCT=RCCT+1
SET RCDXM(RCCT)=$GET(^TMP("RC",$JOB,Z))
+10 DO BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM)
+11 KILL ^TMP("RC1",$JOB),^TMP("RC",$JOB),^TMP("RCTEMP",$JOB)
+12 QUIT
+13 ;
DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1?
+1 ; RCM = msg # EOB was received in
+2 ; RCIFN = bill ien
+3 ; RCAMT = amt pd
+4 ; RCAMT1 = amt reported billed
+5 ; Returns 0 if none found, entry #^message checksum on file if found
+6 NEW Z,DUP,DUP1
+7 SET (DUP,DUP1,Z)=0
+8 FOR
SET Z=$ORDER(^IBM(361.1,"AC",RCM,Z))
if 'Z
QUIT
IF +$GET(^IBM(361.1,Z,0))=RCIFN
Begin DoDot:1
+9 ; Partially filed before
IF '$PIECE($GET(^IBM(361.1,Z,100)),U,5)
SET DUP1=Z
QUIT
+10 IF +$GET(^IBM(361.1,Z,1))=+RCAMT
IF +$PIECE($GET(^IBM(361.1,1,Z,2)),U,4)=+RCAMT1
SET DUP=Z_U_+$PIECE($GET(^IBM(361.1,Z,100)),U,5)
QUIT
End DoDot:1
if DUP
QUIT
+11 IF 'DUP
IF DUP1
SET DUP=DUP1_"^0"
+12 QUIT DUP
+13 ;
DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA
+1 ; RCNOUPD = # of message with duplicate data
+2 ; DUP = flag = -1 if duplicate message received in same mail msg #
+3 KILL ^TMP("RCERR1",$JOB)
+4 SET ^TMP("RCERR1",$JOB,1)=$SELECT(DUP>0:"This an exact duplicate of an ERA received previously in mail msg "_RCNOUPD,1:"This ERA message was already fully processed - message was ignored")
+5 QUIT
+6 ;
BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA
+1 ; PRCA*4.5*298 - DUPLICATE TRANSMISSION MSG AND EEOB - EXCEPTIONS message disabled - 14 Feb 2014
+2 ;I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:""))
+3 IF RCFILE=4
DO BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG)
+4 QUIT
+5 ;
ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref
+1 ; Function returns # of lines for error text
+2 SET RCERR(1)="At least 1 adjustment transaction has been found on this ERA. Before the"
SET RCERR(2)=" receipt for this ERA can be processed, the appropriate adjustments"
SET RCERR(3)=" must be made using the EEOB Worklist"
SET RCERR(4)=" "
+3 QUIT 4
+4 ;
