- 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/RCDPEM.m
r613 r623 1 RCDPEM 2 ;;4.5;Accounts Receivable;**173,255**;Mar 20, 1995;Build 1 3 4 5 6 7 EN 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 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),($E($P(RC0,U,6),1,3)="469")!($E($P(RC0,U,6),1,3)="569") D28 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 61 62 63 64 65 66 67 68 69 ENQ 70 71 72 MATCH(RCMAN,RCPROC) 73 74 75 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 MATCHQ 101 102 103 LOCKDEP(RCDEP,LOCK) 104 105 106 107 108 109 110 111 112 RCPTDET(RCRZ,RECTDA1,RCER) 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 DET(RCZ,RCR,RECTDA1,RCTRANDA) 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 1 RCDPEM ;ALB/TMK - POST EFT, ERA MATCHING TO EFT ;05-NOV-02 2 ;;4.5;Accounts Receivable;**173**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; IA 4050 covers call to SPL1^IBCEOBAR 5 Q 6 ; Note - keep processing in line with RCDPXPAP 7 EN ; Post EFT deposits, auto-match EFT's and ERA's 8 ; 9 K ^TMP($J,"RCDPETOT") 10 ; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)= 11 ; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref 12 ; (5) EFT deposit ien 344.1 if added for EFT 13 ; 14 N RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR 15 M RCDUZ=DUZ 16 N DUZ S DUZ=+$O(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0)),DUZ(0)="" S:'DUZ DUZ=.5 17 K ^TMP($J,"RCXM"),^TMP($J,"RCTOT") 18 S ZTREQ="@" 19 L +^RCY(344.3,"ALOCK"):5 I '$T D G ENQ ; Lock record 20 . ; Send bulletin that job could not be run 21 . 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"") )" 22 . D SENDBULL^RCDPEM1 23 ; 24 ; Post deposits for any unposted EFTs in file 344.3 25 ; 'Unposted' EFTs have a 0 in AMOUNT POSTED field 26 S ^TMP($J,"RCTOT","EFT_DEP")=0 27 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'="",$E($P(RC0,U,6),1,3)="469",$P(RC0,U,8) D 28 . S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1 29 . ; Verify check sums 30 . S RCSUM=$$CHKSUM^RCDPESR3(RCZ) 31 . I RCSUM'=$P(RC0,U,9) D Q 32 .. ; Bulletin that check sums do not match 33 .. ; Update record error list and checksum error field 34 .. S RCER(1)=$$SETERR^RCDPEM0(2) 35 .. 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" 36 .. S RCER(5)=" retransmitted to your site." 37 .. D BULL^RCDPEM1(344.3,RC0,.RCER) 38 .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) 39 .. D STORERR^RCDPEM0(RCZ,.RCER) 40 .. S DIE="^RCY(344.3,",DA=RCZ,DR=".1////1" D ^DIE 41 .. S ^TMP($J,"RCTOT","CSUM")=$G(^TMP($J,"RCTOT","CSUM"))+1 42 . ; 43 . S RCDEP=+$P(RC0,U,3),RECTDA=+$O(^RCY(344,"AD",RCDEP,0)) 44 . I RCDEP D LOCKDEP(RCDEP,1) 45 . I 'RCDEP!'RECTDA D ; Add deposit and/or receipt to files 344.1, 344 46 .. I 'RCDEP D ; Add dep record RCDEP, update field .03 with the pointer 47 ... S RCDEP=+$$ADDDEP^RCDPEM0($P(RC0,U,6),$P(RC0,U,7),RCZ) 48 ... S ^TMP($J,"RCTOT","DEPOSIT")=$G(^TMP($J,"RCTOT","DEPOSIT"))+1 49 .. ; 50 .. I 'RECTDA,RCDEP D ; Add receipt record, post to rev source cd 8NZZ 51 ... S RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ) 52 .. ; 53 . I RCDEP D LOCKDEP(RCDEP,0) 54 . ; 55 . I 'RCDEP!'RECTDA D Q ; Could not add entry to file 344.1 or 344 56 .. ; Send a bulletin, update error text 57 .. 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" 58 .. I RCDEP,'RECTDA S RCER(3)=" Deposit Ticket # created: "_$P($G(^RCY(344.1,+$P(RC0,U,3),0)),U) 59 .. S RCER($O(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit" 60 .. D BULL^RCDPEM1(344.3,RC0,.RCER) 61 .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) 62 .. D STORERR^RCDPEM0(RCZ,.RCER) 63 .. S ^TMP($J,"RCTOT","ERR")=$G(^TMP($J,"RCTOT","ERR"))+1 64 . ; 65 . 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 66 ; 67 D MATCH(0,1) 68 L -^RCY(344.3,"ALOCK") 69 ENQ K ^TMP($J,"RCDPETOT") 70 Q 71 ; 72 MATCH(RCMAN,RCPROC) ; Try to matched unmatched EFTs 73 ; RCMAN = 1 if job run manually, outside of nightly processing 74 ; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match 75 ; 76 N RC0,RCER,RCZ,RCHAC 77 I '$O(^RCY(344.31,"AMATCH",0,0)) D G MATCHQ 78 . ; Send bulletin - no unmatched EFTs found 79 . N RCT 80 . S RCT=+$O(^TMP($J,"RCXM"," "),-1)+1 81 . 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" 82 . I $G(RCMAN) S ^TMP($J,"RCXM",RCT+1)="The action was initiated by "_$P($G(^VA(200,DUZ,0)),U) 83 . D SENDBULL^RCDPEM1 84 ; 85 S RCZ=0 F S RCZ=$O(^RCY(344.31,"AMATCH",0,RCZ)) Q:'RCZ D 86 . K RCER 87 . S RC0=$G(^RCY(344.31,RCZ,0)),RCHAC=($E($P($G(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC") 88 . Q:RC0="" ; Bad xref 89 . Q:$S('RCHAC:'$P(RC0,U,11),1:0) ; EFT deposit must have been recorded 90 . S ^TMP($J,"RCTOT","EFT")=$G(^TMP($J,"RCTOT","EFT"))+1 91 . I RCHAC S ^TMP($J,"RCTOT","EFT_HAC")=$G(^TMP($J,"RCTOT","EFT_HAC"))+1 92 . S ^TMP($J,"RCDPETOT",344.31,RCZ)="" 93 . ; 94 . D MATCH^RCDPEM0(RCZ,RCPROC) 95 ; 96 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 97 D EN2^RCDPEM1,BULL^RCDPEM1("","",.RCER) 98 D SENDBULL^RCDPEM1 99 ; 100 MATCHQ K ^TMP($J,"RCDPETOT"),^TMP($J,"RCTOT") 101 Q 102 ; 103 LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1 104 ; If LOCK = 1 lock deposit 105 ; If LOCK = 0 unlock deposit 106 I $G(LOCK) D 107 . L +^RCY(344.1,RCDEP,0) 108 . D CONFIRM^RCDPUDEP(RCDEP) ; confirm to prevent changes 109 I '$G(LOCK) L -^RCY(344.1,RCDEP,0) 110 Q 111 ; 112 RCPTDET(RCRZ,RECTDA1,RCER) ; Adds detail to a receipt based on file 344.49 113 ; RCRZ = ien of ERA entry in file 344.49 114 ; RECTDA1 = ien of receipt entry in file 344 115 ; RCER = error array returned if passed by reference 116 ; 117 N RCR,RCSPL,RCZ0,RCTRANDA,RCQ,DR,DA,DIE,X,Y,Q,Z0,Z1,Z 118 ; 119 S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D 120 . S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0)) 121 . I $P(RCZ0,U)'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q 122 . 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 123 . S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1) 124 . ; 125 . I 'RCTRANDA D Q ; Error adding receipt detail 126 .. S RCER(1)=$$SETERR^RCDPEM0() 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" 127 . ; 128 . ;Store receipt line detail 129 . D DET(RCRZ,RCR,RECTDA1,RCTRANDA) 130 . S RCSPL(RCZ0\1,+RCZ0)=RCZ0 131 S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D 132 . S Z1=$O(RCSPL(Z,"")) Q:$O(RCSPL(Z,""),-1)=Z1 ; No split occurred 133 . S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D 134 .. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec 135 .. Q:'Q 136 .. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspensed 137 ... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050 138 .. E D 139 ... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050 140 ; 141 Q 142 ; 143 DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail 144 ; RCZ = ien of entry file 344.49 145 ; RCR = ien of entry in file 344.491 146 ; RCPROC = Function calling this subroutine 147 ; = 1 EFT match to ERA = 0 manual add receipt 148 ; RECTDA1 = ien of entry in file 344 149 ; RCTRANDA = ien of entry in subfile 344.01 150 ; 151 N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0 152 S RC0=$G(^RCY(344.49,RCZ,0)) 153 S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0)) 154 S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0)) 155 I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";" 156 S DR=DR_".04////"_(+$P(RCZ0,U,3))_";"_$S($P(RC0,U,4)'="":".13////"_$P(RC0,U,4)_";",1:"")_".27////"_RCR_";" 157 I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";" 158 I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";" 159 S RCCOM=$P(RCZ0,U,10) 160 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 161 I $P(RCUP,U,2)["**ADJ" S DR=DR_"1.02////"_$E($S(RCCOM'="":RCCOM_"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA"),1,60)_";" 162 I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";" 163 S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1," 164 D ^DIE 165 Q 166 ;
Note:
See TracChangeset
for help on using the changeset viewer.
