Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPESR3

RCDPESR3.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3
  1. ; from Lockbox EFT msg
  1. ; Input: RCTXN - Data on the header record of the message text
  1. ; RCD - Array containing formatted mail message header data
  1. ; XMZ - Mail message number
  1. ; RCGBL - Name of the array or global where the message is stored
  1. ; Output: RCEFLG - Error flag returned if passed by reference
  1. ;
  1. N CT,DA,DIK,DLAYGO,RC,RC1,RCLAST,RCDEPAMT,RCEFT,RCMEFTS,RCTDA,RCERR,RCTYP1,RCZ,XX,Z,Z0
  1. ;
  1. ; Take data out of mail message
  1. S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT"
  1. F X XMREC Q:XMER<0 D Q:RCLAST
  1. . I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q
  1. . S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG
  1. ;
  1. ; PRCA*4.5*349 - Removed killing of RCGBL to ensure raw data gets sent in error message
  1. I 'RCLAST,'$G(RCERR) S RCERR=2 ; No $ as last character of msg
  1. ;
  1. I $G(RCERR)>0 D G EFTQ
  1. . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
  1. . S RCEFLG=1
  1. ;
  1. ; Add top-level entry to file 344.3
  1. S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR)
  1. ;
  1. I $G(RCERR) D G EFTQ ; 'BAD' EFT's
  1. . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
  1. . S RCEFLG=1
  1. ;
  1. G:'RCEFT EFTQ
  1. ;
  1. ; PRCA*4.5*380 - No longer deleting EFT Details
  1. ;
  1. S (RC,RC1,RCZ)=0
  1. F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR)
  1. . I $P(Z0,U)="01" D ; Each payer's data
  1. . . N DA,DD,DIC,DIE,DO,DR,X,Y
  1. . . S X=RCEFT
  1. . . S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"
  1. . . S DIC("DR")=DIC("DR")_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")
  1. . . S DIC("DR")=DIC("DR")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")
  1. . . S DIC("DR")=DIC("DR")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)
  1. . . S DIC("DR")=DIC("DR")_";.06////"_$S($P(Z0,U,8)'="":1,1:0)
  1. . . S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))
  1. . . S DIC("DR")=DIC("DR")_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")
  1. . . S DIC("DR")=DIC("DR")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"")
  1. . . S XX=$S($P(Z0,U,10)="D":"D",$P(Z0,U,10)="-":"D",1:"")
  1. . . S DIC("DR")=DIC("DR")_";3////"_XX ; PRCA*4.5*321 added filing of this field
  1. . . ;
  1. . . I $P(Z0,U,8)'="" D ; Tax id error
  1. . . . S XX=$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6)
  1. . . . D TAXERR^RCDPESR1("EFT",XX,$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin
  1. . . ;
  1. . . S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31
  1. . . D FILE^DICN
  1. . . K DIC,DLAYGO,DO,DD
  1. . . I Y'>0 D ; Error filing data
  1. . . . S DIK="^RCY(344.3,",DA=RCEFT D ^DIK
  1. . . . S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK
  1. . . . S RCEFLG=1,RCERR=3
  1. . . . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR)
  1. ;
  1. I '$G(RCEFLG) D
  1. . S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE
  1. ;
  1. EFTQ ;
  1. D CLEAN^DILF
  1. Q
  1. ;
  1. 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
  1. ; RCXMZ = the mail message number
  1. ; RCGBL = the name of the array or global where the message is stored
  1. ; Function returns the ien of the total record found/added
  1. ; and also returns RCERR if passed by reference
  1. ;
  1. N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0
  1. S (RCERR,RCTDA)=""
  1. ;
  1. ;----- changed for PRCA*4.5*283
  1. ;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
  1. ;. N RCDXM,RCCT
  1. ;. S RCCT=0
  1. ;. 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)=" "
  1. ;. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
  1. ;. D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ)
  1. ;-----
  1. ;
  1. ; Make sure it's not already there or if so, it has no ptr to a deposit
  1. ; or if a deposit exists, that the deposit does not yet have a receipt
  1. S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit
  1. I $P(RCTXN,U,6)'="" D
  1. . ;Format Deposit Date as FM date
  1. . N RCDDAT
  1. . S X=$$FDT^RCDPESR9($P(RCTXN,U,7))
  1. . S RCDDAT=0,%DT="X" D ^%DT S:Y>0 RCDDAT=Y
  1. . S Z=0 ; Lookup deposit by deposit #
  1. . ; 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
  1. . ; a duplicate record now
  1. . 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
  1. .. ; Deposit found - find receipt
  1. .. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q
  1. .. S RCTDA=Z
  1. ;
  1. ;-----
  1. ; PRCA*4.5*298 - MailMan message disabled, logic retained - 14 Feb 2014
  1. ;I RCDUP D ; Send bulletin that duplicate EFT received
  1. ;. N RCDXM,RCCT
  1. ;. S RCCT=0
  1. ;. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
  1. ;. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
  1. ;. D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ)
  1. ;-----
  1. ;
  1. ; PRCA*4.5*380 - Removed check for dup; will now just create new transaction, instead
  1. N %DT,DA,DD,DEPAMT,DIC,DIE,DINUM,DLAYGO,DO,DR,RCDTTM,RCX,X,Y
  1. ;
  1. S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4)
  1. S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y
  1. ;
  1. ;PRCA*4.5*380 - If updating an existing deposit, add new deposit amount to existing total
  1. S DEPAMT=$S(RCTDA:+$$GET1^DIQ(344.3,RCTDA_",",.08),1:0)+$$ZERO^RCDPESR9($P(RCTXN,U,8),1)
  1. ;
  1. S DIC("DR")=""
  1. S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"")
  1. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7))
  1. ;PRCA*4.5*380 - If updating an existing deposit, add new deposit amount to existing total
  1. S DIC("DR")=DIC("DR")_";.08////"_DEPAMT_";.13////"_$$NOW^XLFDT()_$S('RCTDA:";.05////"_RCXMZ,1:"")_";.14////0;.12////0"
  1. ;
  1. I RCTDA D ; Update the data already there
  1. . L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q
  1. . S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE
  1. . K DIE,DA,DR
  1. . ; PRCA*4.5*380 - Add an entry to the subsequent mail messages multiple
  1. . S DIC="^RCY(344.3,"_RCTDA_",3,",DIC(0)="L",DA(1)=RCTDA,X=RCXMZ
  1. . D FILE^DICN K DA,DIC
  1. . L -^RCY(344.3,RCTDA)
  1. ;
  1. I 'RCTDA D
  1. . S RCX=+$O(^RCY(344.3," "),-1)
  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
  1. . S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX
  1. . D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM
  1. . L -^RCY(344.3,RCX,0)
  1. . S RCTDA=$S(Y<0:"",1:+Y)
  1. ;
  1. I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3
  1. ;
  1. ADDQ Q $S(RCTDA>0:RCTDA,1:"")
  1. ;
  1. CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3
  1. ;
  1. N RCDPCSUM,RCDPDATA,X,Y,Z,Z0
  1. ;
  1. S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0))
  1. ; Use pcs 1-8, leaving out piece 3
  1. S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)=""
  1. S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y
  1. ; Use detail iens and pieces 3,4,7 to complete the checksum
  1. 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
  1. Q RCDPCSUM
  1. ;
  1. DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message
  1. ; RCTIT = title of bulletin
  1. ; RCCT = # of lines previously populated
  1. ; RCXDM = array containing the text of the bulletin
  1. N RC,Z
  1. K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
  1. S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0))
  1. 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))
  1. D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75)
  1. S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z))
  1. D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM)
  1. K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
  1. Q
  1. ;
  1. DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1?
  1. ; RCM = msg # EOB was received in
  1. ; RCIFN = bill ien
  1. ; RCAMT = amt pd
  1. ; RCAMT1 = amt reported billed
  1. ; Returns 0 if none found, entry #^message checksum on file if found
  1. N Z,DUP,DUP1
  1. S (DUP,DUP1,Z)=0
  1. F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP
  1. . I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before
  1. . 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
  1. I 'DUP,DUP1 S DUP=DUP1_"^0"
  1. Q DUP
  1. ;
  1. DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA
  1. ; RCNOUPD = # of message with duplicate data
  1. ; DUP = flag = -1 if duplicate message received in same mail msg #
  1. K ^TMP("RCERR1",$J)
  1. 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")
  1. Q
  1. ;
  1. 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
  1. ;I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:""))
  1. I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG)
  1. Q
  1. ;
  1. ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref
  1. ; Function returns # of lines for error text
  1. 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)=" "
  1. Q 4
  1. ;