- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m
r613 r623 1 RCDPESR3 2 ;;4.5;Accounts Receivable;**173,214,208,255**;Mar 20, 1995;Build 1 3 4 5 EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 EFTQ 61 62 63 64 ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) 65 66 67 68 69 70 71 72 73 74 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 number75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 ADDQ 125 126 CHKSUM(RCTDA) 127 128 129 130 131 132 133 134 135 136 137 138 DISP(RCTIT,RCCT,RCDXM,RCXMZ) 139 140 141 142 143 144 145 146 147 148 149 150 151 152 DUP(RCM,RCIFN,RCAMT,RCAMT1) 153 154 155 156 157 158 159 160 161 162 163 164 165 166 DUPERA(DUP,RCNOUPD) 167 168 169 170 171 172 173 BULLS(RCFILE,RCTDA,DUP,RCXMSG) 174 175 176 177 178 ADJERR(RCERR) 179 180 181 182 1 RCDPESR3 ;ALB/TMK - Server auto-update utilities - EDI Lockbox ;06/06/02 2 ;;4.5;Accounts Receivable;**173,214,208**;Mar 20, 1995 3 Q 4 ; 5 EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3 6 ; from Lockbox EFT msg 7 ; RCTXN = the data on the header record of the message text 8 ; RCD = array containing formatted mail message header data 9 ; XMZ = the mail message number 10 ; RCGBL = the name of the array or global where the message is stored 11 ; RCEFLG = error flag returned if passed by reference 12 ; 13 N CT,RC,RC1,RCLAST,RCEFT,RCTDA,RCERR,RCTYP1,DA,DIK,RCZ,Z,Z0,DLAYGO 14 ; 15 ; Take data out of mail message 16 S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT" 17 F X XMREC Q:XMER<0 D Q:RCLAST 18 . I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q 19 . S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG 20 ; 21 I 'RCLAST,'$G(RCERR) K @RCGBL S RCERR=2 ;No $ as last character of msg 22 ; 23 I $G(RCERR)>0 D G EFTQ 24 . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) 25 . S RCEFLG=1 26 ; 27 ; Add top-level entry to file 344.3 28 S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR) 29 ; 30 I $G(RCERR) D G EFTQ ; 'BAD' EFT's 31 . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) 32 . S RCEFLG=1 33 ; 34 G:'RCEFT EFTQ 35 ; 36 ; Add the detail data to file 344.31 for this EFT record 37 S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DA=Z,DIK="^RCY(344.31," D ^DIK ; Delete any detail data already there 38 ; 39 S (RC,RC1,RCZ)=0 40 F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR) 41 . I $P(Z0,U)="01" D ; Each payer's data 42 .. N DA,DIE,DR,X,Y,DO,DD,DIC 43 .. S X=RCEFT 44 .. S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)_";.06////"_$S($P(Z0,U,8)'="":1,1:0) 45 .. S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"") 46 .. ; 47 .. I $P(Z0,U,8)'="" D ; tax id error 48 ... D TAXERR^RCDPESR1("EFT",$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6),$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin 49 .. ; 50 .. S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31 D FILE^DICN K DIC,DLAYGO,DO,DD 51 .. I Y'>0 D ; Error filing data 52 ... S DIK="^RCY(344.3,",DA=RCEFT D ^DIK 53 ... S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK 54 ... S RCEFLG=1,RCERR=3 55 ... D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR) 56 ; 57 I '$G(RCEFLG) D 58 . S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE 59 ; 60 EFTQ ; 61 D CLEAN^DILF 62 Q 63 ; 64 ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3 65 ; RCTXN = the data on the header record of the message text 66 ; RCXMZ = the mail message number 67 ; RCGBL = the name of the array or global where the message is stored 68 ; Function returns the ien of the total record found/added 69 ; and also returns RCERR if passed by reference 70 ; 71 N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0 72 S (RCERR,RCTDA)="" 73 ; 74 I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number 75 . N RCDXM,RCCT 76 . S RCCT=0 77 . 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)=" " 78 . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" 79 . D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ) 80 ; 81 ; Make sure it's not already there or if so, it has no ptr to a deposit 82 ; or if a deposit exists, that the deposit does not yet have a receipt 83 S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit 84 I $P(RCTXN,U,6)'="" D 85 . S Z=0 ; Lookup deposit by deposit # 86 . F S Z=$O(^RCY(344.3,"C",$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 87 .. ; Deposit found - find receipt 88 .. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q 89 .. S RCTDA=Z 90 ; 91 I RCDUP D ; Send bulletin that duplicate EFT received 92 . N RCDXM,RCCT 93 . S RCCT=0 94 . S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" " 95 . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" 96 . D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ) 97 ; 98 I 'RCDUP D ; Add or update the record 99 . N RCX,RCDTTM,DIE,DIC,DLAYGO,DD,DA,DO,DR,X,Y,%DT,DINUM 100 . ; 101 . S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4) 102 . S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y 103 . ; 104 . S DIC("DR")="" 105 . S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"") 106 . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7)) 107 . S DIC("DR")=DIC("DR")_";.08////"_$$ZERO^RCDPESR9($P(RCTXN,U,8),1)_";.13////"_$$NOW^XLFDT()_";.05////"_RCXMZ_";.14////0;.12////0" 108 . ; 109 . I RCTDA D ; Overwrite the data already there 110 .. L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q 111 .. S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE 112 .. L -^RCY(344.3,RCTDA) 113 . ; 114 . I 'RCTDA D 115 .. S RCX=+$O(^RCY(344.3," "),-1) 116 .. 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 117 .. S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX 118 .. D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM 119 .. L -^RCY(344.3,RCX,0) 120 .. S RCTDA=$S(Y<0:"",1:+Y) 121 . ; 122 . I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3 123 ; 124 ADDQ Q $S(RCTDA>0:RCTDA,1:"") 125 ; 126 CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3 127 ; 128 N RCDPCSUM,RCDPDATA,X,Y,Z,Z0 129 ; 130 S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0)) 131 ; Use pcs 1-8, leaving out piece 3 132 S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)="" 133 S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y 134 ; Use detail iens and pieces 3,4,7 to complete the checksum 135 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 136 Q RCDPCSUM 137 ; 138 DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message 139 ; RCTIT = title of bulletin 140 ; RCCT = # of lines previously populated 141 ; RCXDM = array containing the text of the bulletin 142 N RC,Z 143 K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) 144 S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0)) 145 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)) 146 D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75) 147 S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z)) 148 D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM) 149 K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) 150 Q 151 ; 152 DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1? 153 ; RCM = msg # EOB was received in 154 ; RCIFN = bill ien 155 ; RCAMT = amt pd 156 ; RCAMT1 = amt reported billed 157 ; Returns 0 if none found, entry #^message checksum on file if found 158 N Z,DUP,DUP1 159 S (DUP,DUP1,Z)=0 160 F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP 161 . I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before 162 . 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 163 I 'DUP,DUP1 S DUP=DUP1_"^0" 164 Q DUP 165 ; 166 DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA 167 ; RCNOUPD = # of message with duplicate data 168 ; DUP = flag = -1 if duplicate message received in same mail msg # 169 K ^TMP("RCERR1",$J) 170 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") 171 Q 172 ; 173 BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA 174 I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:"")) 175 I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG) 176 Q 177 ; 178 ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref 179 ; Function returns # of lines for error text 180 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)=" " 181 Q 4 182 ;
Note:
See TracChangeset
for help on using the changeset viewer.
