source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m@ 1211

Last change on this file since 1211 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 7.9 KB
RevLine 
[623]1RCDPESR3 ;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 ;
5EFTIN(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 ;
60EFTQ ;
61 D CLEAN^DILF
62 Q
63 ;
64ADDEFT(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 ;
124ADDQ Q $S(RCTDA>0:RCTDA,1:"")
125 ;
126CHKSUM(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 ;
138DISP(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 ;
152DUP(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 ;
166DUPERA(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 ;
173BULLS(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 ;
178ADJERR(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 TracBrowser for help on using the repository browser.