source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCBEPAYF.m@ 1361

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1RCBEPAYF ;WISC/RFJ-first party payment processing(called by rcbepay) ;1 Jun 00
2 ;;4.5;Accounts Receivable;**153**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7FIRSTPTY() ; apply payment to first party account
8 ; called by rcbepay
9 N PAYMENT,RCBILBAL,RCBILLDA,RCDATE,RCDEBTDA,RCERROR,RCREPAMT,RCSTATUS,RCTRANDA,X
10 K ^TMP("RCBEPAY",$J)
11 ;
12 ; look up account in debtor file
13 S RCDEBTDA=$$DEBT^RCEVUTL(RCACCT)
14 I RCDEBTDA<0 Q "1^Could not add Patient ("_RCACCT_") to debtor file"
15 ;
16 ; lock the debtor account
17 L +^RCD(340,RCDEBTDA):20 I '$T Q "1^Another user is working with this patient account"
18 ;
19 ; build list of active(16) and open(42) bills for patient
20 ; sorted by date bill prepared
21 F RCSTATUS=16,42 S RCBILLDA=0 F S RCBILLDA=$O(^PRCA(430,"AS",RCDEBTDA,RCSTATUS,RCBILLDA)) Q:'RCBILLDA D
22 . ; check bill for prepayment
23 . I $P(^PRCA(430,RCBILLDA,0),"^",2)=26 Q
24 . ; if this bill was entered for payment applied against it on
25 . ; the receipt, set the tmp global with the date prepared
26 . ; equal to zero so payment will be applied to it first
27 . I $P(RCDATA,"^",3)["PRCA(430,",RCBILLDA=+$P(RCDATA,"^",3) S ^TMP("RCBEPAY",$J,0,RCBILLDA)="" Q
28 . S ^TMP("RCBEPAY",$J,+$P(^PRCA(430,RCBILLDA,0),"^",10),RCBILLDA)=""
29 ;
30 ; loop all the bills for a patients account and keep looping them
31 ; until either there is no more bills or the money paid is zero.
32 ; the bills are looped in case of repayments. if there is money
33 ; left over, this will apply more money to the repayment bills
34 ; instead of creating a prepayment. a prepayment should only be
35 ; created if all bills for the account is collected/closed.
36 S RCERROR=0
37 ; quit the loop if no money left to apply OR an error occurred OR
38 ; no more bills left to apply payment to
39 F D I 'RCPAYAMT!(RCERROR)!($O(^TMP("RCBEPAY",$J,""))="") Q
40 . ; loop the bills by date prepared and apply the payment
41 . ; quit if no money left to apply OR and error occurred
42 . S RCDATE="" F S RCDATE=$O(^TMP("RCBEPAY",$J,RCDATE)) Q:RCDATE="" D I 'RCPAYAMT!(RCERROR) Q
43 . . S RCBILLDA=0 F S RCBILLDA=$O(^TMP("RCBEPAY",$J,RCDATE,RCBILLDA)) Q:'RCBILLDA D I 'RCPAYAMT!(RCERROR) Q
44 . . . L +^PRCA(430,RCBILLDA):10
45 . . . I '$T S RCERROR="1^Another user is working will bill "_$P(^PRCA(430,RCBILLDA,0),"^") Q
46 . . . ;
47 . . . ; exempt any interest/admin/penalty charges added on or after
48 . . . ; the payment date
49 . . . D EXEMPT^RCBECHGE(RCBILLDA,RCPAYDAT)
50 . . . ;
51 . . . ; get the repayment amount (if any)
52 . . . S RCREPAMT=$P($G(^PRCA(430,RCBILLDA,4)),"^",3)
53 . . . ;
54 . . . ; get the balance of the bill
55 . . . S X=$G(^PRCA(430,RCBILLDA,7))
56 . . . S RCBILBAL=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
57 . . . ; if bill has no balance, chg status = collected/closed
58 . . . I 'RCBILBAL D CHGSTAT^RCBEUBIL(RCBILLDA,22) L -^PRCA(430,RCBILLDA) K ^TMP("RCBEPAY",$J,RCDATE,RCBILLDA) Q
59 . . . ;
60 . . . ; determine amount to pay
61 . . . ; if the payment is greater than billed amount, pay billed amount
62 . . . ; if there is a repayment amount, pay the repayment amount
63 . . . ; do not allow payment to exceed amount paid
64 . . . S PAYMENT=RCPAYAMT
65 . . . I PAYMENT>RCBILBAL S PAYMENT=RCBILBAL
66 . . . I RCREPAMT S PAYMENT=RCREPAMT I PAYMENT>RCBILBAL S PAYMENT=RCBILBAL
67 . . . I PAYMENT>RCPAYAMT S PAYMENT=RCPAYAMT
68 . . . ;
69 . . . ; apply payment to bill
70 . . . ; return error if problem adding payment transaction
71 . . . S RCTRANDA=$$PAYTRAN^RCBEPAY1(RCBILLDA,PAYMENT,RCRECTDA,RCPAYDA,RCPAYDAT)
72 . . . I 'RCTRANDA L -^PRCA(430,RCBILLDA) S RCERROR="1^"_$P(RCTRANDA,"^",2) Q
73 . . . ;
74 . . . ; payment applied to bill, subtract off the payment amount
75 . . . S RCPAYAMT=RCPAYAMT-$P($G(^PRCA(433,RCTRANDA,1)),"^",5)
76 . . . ;
77 . . . ; set the amount processed on the receipt payment
78 . . . D SETAMT^RCBEPAY(RCRECTDA,RCPAYDA,$P($G(^PRCA(433,RCTRANDA,1)),"^",5))
79 . . . ;
80 . . . ; get the new balance of the bill. if it is zero
81 . . . ; remove it from the tmp global (this will stop the
82 . . . ; loop if dollars are left and no bills are active)
83 . . . S X=$G(^PRCA(430,RCBILLDA,7))
84 . . . S RCBILBAL=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
85 . . . I 'RCBILBAL K ^TMP("RCBEPAY",$J,RCDATE,RCBILLDA)
86 . . . ;
87 . . . L -^PRCA(430,RCBILLDA)
88 ;
89 K ^TMP("RCBEPAY",$J)
90 ;
91 ; if an error occurred, quit
92 I RCERROR L -^RCD(340,RCDEBTDA) Q RCERROR
93 ;
94 ; if no money left, quit
95 I 'RCPAYAMT L -^RCD(340,RCDEBTDA) Q 0
96 ;
97 ; dollars remaining, create a prepayment
98 N %,%H,%I,%X,D,D0,DFN,DI,DIC,DICR,DIG,DIH,DIU,DIV,DIW,DQ,I,PRCA,RCREF,VA,VADM
99 D EN^PRCAPAY3(RCACCT,RCPAYAMT,RCPAYDAT,DUZ,$P(^RCY(344,RCRECTDA,0),"^"),"","",.RCERROR,"")
100 ; no errors
101 I RCERROR=""!(RCERROR=0) D
102 . S RCERROR=0
103 . ; set the amount processed on the receipt
104 . D SETAMT^RCBEPAY(RCRECTDA,RCPAYDA,RCPAYAMT)
105 ; error creating prepayment
106 I RCERROR'=0 S RCERROR="1^"_RCERROR
107 ;
108 L -^RCD(340,RCDEBTDA)
109 Q RCERROR
Note: See TracBrowser for help on using the repository browser.