source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPURET.m@ 1119

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1RCDPURET ;WISC/RFJ-receipt utilities (transactions) ;1 Jun 99
2 ;;4.5;Accounts Receivable;**114,141,169,173,196,221**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7SELTRAN(DA) ; select a transaction for a receipt
8 ; returns -1 for timeout or ^, 0 for no selection, or ien of trans
9 N %,DIC,DTOUT,DUOUT,RCDATA,X,Y
10 S DIC="^RCY(344,"_DA_",1,",DIC(0)="QEAM",DIC("A")="Select Receipt TRANSACTION #: "
11 S DIC("W")="S RCDATA=@(DIC_Y_"",0)"") W:$P(RCDATA,U,3) ?8,"" "",$P(@(U_$P($P(RCDATA,U,3),"";"",2)_+$P(RCDATA,U,3)_"",0)""),U) W ?40,"" $ "",$J($P(RCDATA,U,4),0,2)"
12 D ^DIC
13 I Y<0,'$G(DTOUT),'$G(DUOUT) S Y=0
14 Q +Y
15 ;
16 ;
17ADDTRAN(RECTDA) ; add transaction for receipt (in da)
18 N %DT,%T,D0,DA,DD,DI,DIC,DIE,DINUM,DLAYGO,DO,DQ,DR,X,Y
19 I '$D(^RCY(344,RECTDA,1,0)) S ^(0)="^344.01A^"
20 ;
21 ; find next transaction number
22 S X=$O(^RCY(344,RECTDA,1,9999999),-1)
23 F X=X+1:1 Q:'$D(^RCY(344,RECTDA,1,X,0))
24 S DINUM=X
25 ;
26 S DA(1)=RECTDA
27 S DIC="^RCY(344,"_RECTDA_",1,",DIC(0)="L",DLAYGO=344.01
28 S DIC("DR")=".12////"_DUZ_";.06///TODAY;"
29 D FILE^DICN
30 Q +Y
31 ;
32 ;
33EDITTRAN(RECTDA,TRANDA) ; edit a receipt transaction
34 ; returns 1 for success, or 0 (error message)
35 I '$D(^RCY(344,RECTDA,1,TRANDA,0)) Q 0
36 ;
37 N %,%DT,%T,%Y,C,D,D0,D1,DA,DATA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DIU,DIV,DIW,DG,DQ,DR,DZ,RCAMOUNT,RCTYPE,RESULT,X,Y
38 N RCXAMONT,RCXSUSP,RCXADJ,RCERA,RCADJ,RCXERA
39 ;
40 ; build dr string based on type of payment on receipt
41 S RCTYPE=$P($G(^RC(341.1,+$P(^RCY(344,RECTDA,0),"^",4),0)),"^",2)
42 S RCADJ=0,RCERA=+$O(^RCY(344.4,"AREC",RECTDA,0))
43 S DR=""
44 I RCERA,$D(^RCY(344.49,+RCERA,0)),$P(^RCY(344,RECTDA,1,TRANDA,0),"^",28) D ; Worklist has a dec adj associated with it
45 . N Z
46 . S Z=$$EXTERNAL^DILFD(344.01,.09,,$P($G(^RCY(344,RECTDA,1,TRANDA,0)),U,9))
47 . S RCADJ=1,RCXERA="W !,""NOTE: This payment has an EEOB Worklist dec adj associated with it."",!,""BILL NUMBER: "_Z_" (uneditable)""",DR="X RCXERA;"
48 E D
49 . ; patient name or bill number
50 . S DR=".09;"
51 S DR=DR_"S Y=$S('$P(^RCY(344,DA(1),1,DA,0),U,9):""@1"",1:""@2"");"
52 ; ask comment if no acct (unapplied)
53 S RCXSUSP="W !?5,""NOTE: This payment will be posted to the station's suspense fund."""
54 S DR=DR_"@1;X RCXSUSP;1.02;S Y=""@3"";"
55 ; payment amount
56 S RCXAMONT="W !,"" Amount Owed: $"",$J($$PAYDEF^RCDPURET($P(^RCY(344,DA(1),1,DA,0),U,9)),0,2)"
57 S DR=DR_"@2;X RCXAMONT;@3;.04;"
58 ; date of payment
59 S DR=DR_".06;"
60 ; type of payment = district counsel (3), check (4),
61 ; dept of justice (5), irs (11),
62 ; lockbox (12)
63 I RCTYPE=3!(RCTYPE=4)!(RCTYPE=5)!(RCTYPE=11)!(RCTYPE=12)!(RCTYPE=13) D
64 . S DR=DR_".07d;" ; check number
65 . S DR=DR_".08d;" ; bank number
66 . S DR=DR_".1d;" ; date of check
67 ; type of payment = credit card (7)
68 I RCTYPE=7 D
69 . S DR=DR_".11d;" ; credit card number
70 . S DR=DR_".02d;" ; confirmation number
71 ;
72 S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
73 S DA=TRANDA,DA(1)=RECTDA
74 ; edited by
75 S DR=DR_".14////"_DUZ
76 D ^DIE
77 D LASTEDIT^RCDPUREC(RECTDA)
78 ;
79 ; check for missing fields
80 S DATA=^RCY(344,RECTDA,1,TRANDA,0)
81 S RESULT=1
82 I RESULT,'$P(DATA,"^",4) S RESULT="Payment Amount is ZERO."
83 I RESULT,'$P(DATA,"^",6) S RESULT="Date of Payment NOT entered."
84 I RESULT,RCTYPE=13,$$TRACE($P(DATA,"^",3))="" S RESULT="TOP TRACE NUMBER NOT ENTERED"
85 I RESULT,RCTYPE=7,$P(DATA,"^",11)="" W !,"WARNING: Credit Card Number NOT entered."
86 I RESULT,$P(DATA,"^",6)<$P(DATA,"^",10) W !,"WARNING: Date of check is greater than the date of payment."
87 ;
88 ; if field is missing, delete the transaction
89 I 'RESULT D DELETRAN(RECTDA,TRANDA)
90 ;
91 ; if transaction okay, print receipt
92 I RESULT D RECEIPT^RCDPRECT(RECTDA,TRANDA)
93 ;
94 Q RESULT
95 ;
96 ;
97EDITACCT(RECTDA,TRANDA) ; edit the account on a receipt
98 N C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
99 S DR=".09;"
100 S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
101 S DA=TRANDA,DA(1)=RECTDA
102 D ^DIE
103 D LASTEDIT^RCDPUREC(RECTDA)
104 Q
105 ;
106 ;
107DELEACCT(RECTDA,TRANDA) ; delete the account on a receipt
108 N D,D0,D1,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,X
109 S DR=".09///@;.03///@;"
110 S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
111 S DA=TRANDA,DA(1)=RECTDA
112 D ^DIE
113 D LASTEDIT^RCDPUREC(RECTDA)
114 Q
115 ;
116 ;
117EDITFMS(RECTDA,TRANDA,DEFAULT) ; edit fms document number for clearing suspense
118 N C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
119 S DR=".26;"
120 I $G(DEFAULT)'="" S DR=".26////"_DEFAULT_";"
121 S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
122 S DA=TRANDA,DA(1)=RECTDA
123 D ^DIE
124 Q
125 ;
126 ;
127MOVETRAN(RCOLDREC,RCOLDTRA,RCNEWREC) ; move a transactions data
128 N %DT,%T,D0,D1,DA,DG,DIC,DICR,DIK,DIU,RCNEWTRA,RESULT,X,Y
129 ;
130 ; add new transaction to 2nd receipt
131 W !,"Adding a NEW payment transaction to receipt "_$P(^RCY(344,RCNEWREC,0),"^")_": "
132 S RCNEWTRA=$$ADDTRAN(RCNEWREC)
133 I 'RCNEWTRA Q "Unable to ADD a new payment transaction."
134 ;
135 W "# ",RCNEWTRA
136 ;
137 ; move data to selected receipt and re-index entry
138 S ^RCY(344,RCNEWREC,1,RCNEWTRA,0)=RCNEWTRA_"^"_$P(^RCY(344,RCOLDREC,1,RCOLDTRA,0),"^",2,99)
139 S DIK="^RCY(344,"_RCNEWREC_",1,",DA(1)=RCNEWREC,DA=RCNEWTRA
140 D IX^DIK
141 ;
142 S RESULT=$$EDITTRAN(RCNEWREC,RCNEWTRA)
143 Q RESULT
144 ;
145 ;
146CANCTRAN(RECTDA,RECTRAN) ; cancel a transaction
147 N D,D0,DA,DI,DIC,DIE,DQ,DR,RCDATA,X,Y
148 S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
149 S RCDATA="Cancelled by: "_$P(^VA(200,DUZ,0),"^")_" Amount: $ "_$J($P(^RCY(344,RECTDA,1,RECTRAN,0),"^",4),0,2)
150 S DR="1.01////^S X=RCDATA;.04////^S X=0;.05////^S X=0;1.02;"
151 S DA=RECTRAN,DA(1)=RECTDA
152 D ^DIE
153 D LASTEDIT^RCDPUREC(RECTDA)
154 Q
155 ;
156 ;
157DELETRAN(RECTDA,TRANDA) ; delete a transaction
158 N %,D0,D1,DA,DIC,DICR,DIG,DIH,DIK,DIU,DIV,DIW,X,Y
159 S DIK="^RCY(344,"_RECTDA_",1,",DA(1)=RECTDA,DA=TRANDA
160 D ^DIK
161 D LASTEDIT^RCDPUREC(RECTDA)
162 Q
163 ;
164 ;
165SETUNAPP(RECTDA,TRANDA,UNAPPNUM) ; store the unapplied deposit number
166 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
167 S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
168 S DR=".25////"_UNAPPNUM_";"
169 S DA=TRANDA,DA(1)=RECTDA
170 D ^DIE
171 Q
172 ;
173 ;
174PAYDEF(DEBTOR) ; get default for payment amount (used in input templates for payments)
175 N X
176 I 'DEBTOR Q 0
177 I DEBTOR[";DPT(" S X=$$BAL^PRCAFN(DEBTOR)
178 I DEBTOR[";PRCA(430,",",112,107,102,"[(","_$P($G(^PRCA(430.3,+$P($G(^PRCA(430,+DEBTOR,0)),"^",8),0)),"^",3)_",") S X=$G(^PRCA(430,+DEBTOR,7)),X=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
179 Q +$G(X)
180 ;
181 ;
182PENDPAY(DEBTOR) ; return pending payments for a debtor
183 ; returns ^tmp($j,"rcdpurec","pp",rectda,tranda)=data in 344.01
184 ; and the total pending payment dollars
185 N DATA,RECTDA,TOTAL,TRANDA
186 K ^TMP($J,"RCDPUREC","PP")
187 ; look at open receipts
188 S RECTDA=0 F S RECTDA=$O(^RCY(344,"ASTAT",1,RECTDA)) Q:'RECTDA D
189 . S TRANDA=0 F S TRANDA=$O(^RCY(344,"AACCT",DEBTOR,RECTDA,TRANDA)) Q:'TRANDA D
190 . . S DATA=$G(^RCY(344,RECTDA,1,TRANDA,0)) I DATA="" Q
191 . . ; total paid = total processed
192 . . I +$P(DATA,"^",4)=+$P(DATA,"^",5) Q
193 . . S ^TMP($J,"RCDPUREC","PP",RECTDA,TRANDA)=DATA
194 . . S TOTAL=$G(TOTAL)+$P(DATA,"^",4)
195 Q +$G(TOTAL)
196TRACE(DEBTOR) ;ENTER TOP TRACE NUMBER FOR TOP RECEIPTS
197 N TRACE,DIC,DIE,DR,DA
198 S TRACE="" G TRACEQ:'DEBTOR
199 S DA=$S(DEBTOR["DPT(":$O(^RCD(340,"B",DEBTOR,0)),1:$P($G(^PRCA(430,+DEBTOR,0)),U,9))
200 G TRACEQ:'DA
201 S (DIC,DIE)="^RCD(340,",DR=6.07 D ^DIE
202 S TRACE=$P($G(^RCD(340,DA,6)),"^",7)
203TRACEQ Q TRACE
Note: See TracBrowser for help on using the repository browser.