source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPRPLM.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1RCDPRPLM ;WISC/RFJ-receipt profile listmanager top routine ;1 Jun 99
2 ;;4.5;Accounts Receivable;**114,148,149,173,196,220,217**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 N RCDPFXIT
6 ;
7RECTPROF ; entry point called by link payment to prevent newing
8 ; fast exit var RCDPFXIT
9 N RCRECTDA
10 ;
11 F D Q:'RCRECTDA
12 . W !! S RCRECTDA=$$SELRECT^RCDPUREC(1) ;allow adding new receipt
13 . I RCRECTDA<1 S RCRECTDA=0 Q
14 . D EN^VALM("RCDP RECEIPT PROFILE")
15 . ; fast exit
16 . I $G(RCDPFXIT) S RCRECTDA=0
17 Q
18 ;
19 ;
20INIT ; init for list manager
21 N DATE,FMSDOC,GECSDA1,GECSDATA,RCCANCEL,RCDPDATA,RCDPFCAN,RCLINE,RCTOTAL,RCTRDA,SPACE,RCEFT,X,Z,Z0,RCZ,RCZ0,RCZ1,RCZ2,EFTFUND
22 K ^TMP("RCDPRPLM",$J),^TMP("VALM VIDEO",$J)
23 ;
24 ; fast exit
25 I $G(RCDPFXIT) S VALMQUIT=1 Q
26 ;
27 D DIQ344(RCRECTDA,".02:200")
28 ;
29 ; set listmanager line #
30 S RCLINE=0
31 ;
32 K ^TMP($J,"RCEFT")
33 S EFTFUND=$S(DT<$$ADDPTEDT^PRCAACC():"5287.4/8NZZ ",1:"528704/8NZZ ")
34 S RCEFT=+$O(^RCY(344.3,"ARDEP",+$P($G(^RCY(344,RCRECTDA,0)),U,6),0))
35 I RCEFT D
36 . S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S Z0=$G(^RCY(344.31,+Z,0)) I $P(Z0,U,14) S ^TMP($J,"RCEFT",$P(Z0,U,14))=Z_U_$E($P(Z0,U,2),1,12)
37 S RCTRDA=0 F S RCTRDA=$O(^RCY(344,RCRECTDA,1,RCTRDA)) Q:'RCTRDA D
38 . D DIQ34401(RCRECTDA,RCTRDA)
39 . S RCLINE=RCLINE+1 D SET("",RCLINE,1,80,.01)
40 . ;check for payment cancelled
41 . S RCCANCEL=0
42 . I $P($G(^RCY(344,RCRECTDA,1,RCTRDA,0)),"^",4)=0,$P($G(^(1)),"^")'="" D
43 . . S RCCANCEL=1,RCDPFCAN=1
44 . . D SET("**",RCLINE,5,6)
45 . ;account
46 . I $G(RCDPDATA(344.01,RCTRDA,.03,"E"))="" D
47 . . S RCDPDATA(344.01,RCTRDA,.03,"E")="[ "_$S(RCEFT:EFTFUND_$P($G(^TMP($J,"RCEFT",RCTRDA)),U,2),1:"suspense"_$$GETUNAPP^RCXFMSCR(RCRECTDA,RCTRDA,0))_" ]"
48 . D SET("",RCLINE,7,33,.03)
49 . ;date of payment
50 . I RCDPDATA(344.01,RCTRDA,.06,"I") D
51 . . D SET($E(RCDPDATA(344.01,RCTRDA,.06,"I"),4,5)_"/"_$E(RCDPDATA(344.01,RCTRDA,.06,"I"),6,7)_"/"_$E(RCDPDATA(344.01,RCTRDA,.06,"I"),2,3),RCLINE,35,42)
52 . ;entered by
53 . I RCDPDATA(344.01,RCTRDA,.12,"E")'="" D
54 . . S X=$E($P(RCDPDATA(344.01,RCTRDA,.12,"E"),",",2))_$E(RCDPDATA(344.01,RCTRDA,.12,"E"))
55 . . I RCDPDATA(344.01,RCTRDA,.12,"I")=.5 S X="ar"
56 . . D SET(X,RCLINE,45,46)
57 . I RCDPDATA(344.01,RCTRDA,.14,"E")'="" D
58 . . S X=$E($P(RCDPDATA(344.01,RCTRDA,.14,"E"),",",2))_$E(RCDPDATA(344.01,RCTRDA,.14,"E"))
59 . . D SET(X,RCLINE,54,55)
60 . D SET($J(RCDPDATA(344.01,RCTRDA,.04,"E"),8,2),RCLINE,62,70)
61 . D SET($J(RCDPDATA(344.01,RCTRDA,.05,"E"),8,2),RCLINE,72,80)
62 . ;
63 . ;if not processed, show if amount > bill
64 . S X=$$CHECKPAY^RCDPRPL3(RCRECTDA,RCTRDA) I X D
65 . . S RCLINE=RCLINE+1
66 . . D SET(" WARNING: Pending Payments ($ "_$J($P(X,"^",3),0,2)_") exceed amount billed ($ "_$J($P(X,"^",2),0,2)_")",RCLINE,1,80)
67 . ;
68 . ;show line 2 for check/credit payment
69 . I $$OPTCK^RCDPRPL2("SHOWCHECK",2) D
70 . . ;receipt type of payment is check
71 . . I RCDPDATA(344,RCRECTDA,.04,"I")=4!(RCDPDATA(344,RCRECTDA,.04,"I")=12) D Q
72 . . . S RCLINE=RCLINE+1
73 . . . D SET(" Check #",RCLINE,1,80,.07)
74 . . . I 'RCDPDATA(344.01,RCTRDA,.1,"I") S RCDPDATA(344.01,RCTRDA,.1,"I")="???????"
75 . . . D SET("Date: "_$E(RCDPDATA(344.01,RCTRDA,.1,"I"),4,5)_"/"_$E(RCDPDATA(344.01,RCTRDA,.1,"I"),6,7)_"/"_$E(RCDPDATA(344.01,RCTRDA,.1,"I"),2,3),RCLINE,32,80)
76 . . . D SET("Bank #",RCLINE,47,80,.08)
77 . . ;receipt type of payment is credit
78 . . I RCDPDATA(344,RCRECTDA,.04,"I")=7 D
79 . . . S RCLINE=RCLINE+1
80 . . . D SET(" Card #",RCLINE,1,80,.11)
81 . . . D SET("Confirmation #",RCLINE,35,80,.02)
82 . ;
83 . ;show line 3 for acct lookup, batch and seq #
84 . I $$OPTCK^RCDPRPL2("SHOWACCT",2) D
85 . . I RCDPDATA(344.01,RCTRDA,.21,"E")="",RCDPDATA(344.01,RCTRDA,.22,"E")="",RCDPDATA(344.01,RCTRDA,.23,"E")="" Q
86 . . S RCLINE=RCLINE+1
87 . . D SET(" AcctLU",RCLINE,1,80,.21)
88 . . D SET("Batch/Sequence: "_RCDPDATA(344.01,RCTRDA,.22,"E")_"/"_RCDPDATA(344.01,RCTRDA,.23,"E"),RCLINE,37,80)
89 . ;
90 . ;show if posting error
91 . I $$OPTCK^RCDPRPL2("SHOWCOMMENTS",2),RCDPDATA(344.01,RCTRDA,1.01,"E")'="" D
92 . . S RCLINE=RCLINE+1
93 . . S X="Posting Error"
94 . . I RCCANCEL S X="Cancel Data"
95 . . D SET(" "_X,RCLINE,1,80,1.01)
96 . ;
97 . ;show if comment
98 . I $$OPTCK^RCDPRPL2("SHOWCOMMENTS",2),RCDPDATA(344.01,RCTRDA,1.02,"E")'="" D
99 . . S RCLINE=RCLINE+1
100 . . D SET(" Comment",RCLINE,1,80,1.02)
101 . ;
102 . ;if EDI Lockbox pending adjustments, show it
103 . I $P($G(^RCY(344,RCRECTDA,0)),U,18),$G(RCDPDATA(344.01,RCTRDA,.27,"E")) D
104 . . S RCZ=$P(^RCY(344,RCRECTDA,0),U,18),RCZ0=RCDPDATA(344.01,RCTRDA,.27,"E")
105 . . S RCZ1=0 F S RCZ1=$O(^RCY(344.49,RCZ,1,RCZ0,1,RCZ1)) Q:'RCZ1 S RCZ2=$G(^(RCZ1,0)) I $P(RCZ2,U,5)'="","12"[$P(RCZ2,U,5),'$P(RCZ2,U,8) D
106 . . . I $P(RCZ2,U,5)=1 S RCLINE=RCLINE+1 D SET(" Pending decrease adjustment for "_$J($P(RCZ2,U,3),"",2),RCLINE,1,80) Q
107 . . . I $$OPTCK^RCDPRPL2("SHOWCOMMENTS",2),$P(RCZ2,U,5)=2 S RCLINE=RCLINE+1 D SET(" Comment: "_$P(RCZ2,U,9),RCLINE,1,80) Q
108 . ;
109 . ;calculate totals
110 . S RCTOTAL(1)=$G(RCTOTAL(1))+RCDPDATA(344.01,RCTRDA,.04,"E")
111 . S RCTOTAL(2)=$G(RCTOTAL(2))+RCDPDATA(344.01,RCTRDA,.05,"E")
112 . ;
113 . ;kill local variable to prevent store errors
114 . K RCDPDATA(344.01,RCTRDA)
115 ;
116 ; show totals
117 K ^TMP($J,"RCEFT")
118 S RCLINE=RCLINE+1 D SET("",RCLINE,1,80)
119 D SET("-------- --------",RCLINE,62,80)
120 S RCLINE=RCLINE+1
121 D SET(" TOTAL DOLLARS FOR RECEIPT",RCLINE,1,80)
122 D SET($J($G(RCTOTAL(1)),8,2),RCLINE,62,70)
123 D SET($J($G(RCTOTAL(2)),8,2),RCLINE,72,80)
124 ; show cancelled
125 I $G(RCDPFCAN) D
126 . S RCLINE=RCLINE+1
127 . D SET("**indicates payment is CANCELLED",RCLINE,5,80)
128 ;
129 ; show history
130 S RCLINE=RCLINE+1
131 D SET(" ",RCLINE,1,80)
132 ; start history on first line of a screen if it does not fit on
133 ; current screen
134 I (RCLINE#12)>8 F SPACE=(RCLINE#12):1:12 S RCLINE=RCLINE+1 D SET(" ",RCLINE,1,80)
135 S RCLINE=RCLINE+1
136 D SET("Receipt History",RCLINE,1,80,0,IOUON,IOUOFF)
137 S DATE=RCDPDATA(344,RCRECTDA,.03,"E"),DATE=$P(DATE,"@")_" "_$P($P(DATE,"@",2),":",1,2)
138 S RCLINE=RCLINE+1
139 S SPACE="",$P(SPACE," ",80)=""
140 I RCDPDATA(344,RCRECTDA,.02,"I")=.5 S RCDPDATA(344,RCRECTDA,.02,"E")="accounts receivable"
141 D SET($E(" Opened By: "_RCDPDATA(344,RCRECTDA,.02,"E")_SPACE,1,39)_"Date/Time Opened: "_DATE,RCLINE,1,80)
142 S DATE=RCDPDATA(344,RCRECTDA,.12,"E"),DATE=$P(DATE,"@")_" "_$P($P(DATE,"@",2),":",1,2)
143 S RCLINE=RCLINE+1
144 I RCDPDATA(344,RCRECTDA,.11,"I")=.5 S RCDPDATA(344,RCRECTDA,.11,"E")="accounts receivable"
145 D SET($E("Last Edit By: "_RCDPDATA(344,RCRECTDA,.11,"E")_SPACE,1,39)_"Date/Time Last Edit: "_DATE,RCLINE,1,80)
146 S DATE=RCDPDATA(344,RCRECTDA,.08,"E"),DATE=$P(DATE,"@")_" "_$P($P(DATE,"@",2),":",1,2)
147 S RCLINE=RCLINE+1
148 I RCDPDATA(344,RCRECTDA,.07,"I")=.5 S RCDPDATA(344,RCRECTDA,.07,"E")="accounts receivable"
149 D SET($E("Processed By: "_RCDPDATA(344,RCRECTDA,.07,"E")_SPACE,1,39)_"Date/Time Processed: "_DATE,RCLINE,1,80)
150 ;
151 ;show fms code sheets if switch on
152 I $$OPTCK^RCDPRPL2("SHOWFMS",2) D
153 . S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
154 . S RCLINE=RCLINE+1 D SET(" ",RCLINE,1,80)
155 . S RCLINE=RCLINE+1 D SET("FMS Cash Receipt Document:",RCLINE,1,80,0,IOUON,IOUOFF)
156 . D SET($P(FMSDOC,"^")_$S($P(FMSDOC,"^",3):"(on deposit)",1:""),RCLINE,28,80)
157 . D SET("Status: "_$P(FMSDOC,"^",2),RCLINE,55,80)
158 . N DIQ2 D DATA^GECSSGET($P(FMSDOC,"^"),1)
159 . I '$G(GECSDATA) Q
160 . S GECSDA1=0 F S GECSDA1=$O(GECSDATA(2100.1,GECSDATA,10,GECSDA1)) Q:'GECSDA1 D
161 . . S RCLINE=RCLINE+1 D SET(GECSDATA(2100.1,GECSDATA,10,GECSDA1),RCLINE,1,80)
162 ;
163 ; show EEOB detail if switch on
164 D SHEOB^RCDPRPL2
165 ;
166 ; set valmcnt to # of lines in list
167 S VALMCNT=RCLINE
168 D HDR
169 Q
170 ;
171 ;
172SET(STRING,LINE,COLBEG,COLEND,FIELD,ON,OFF) ; set array
173 I $G(FIELD) S STRING=STRING_$S(STRING="":"",1:": ")_$G(RCDPDATA(344.01,RCTRDA,FIELD,"E"))
174 I STRING="",'$G(FIELD) D SET^VALM10(LINE,$J("",80)) Q
175 I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80))
176 D SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLBEG,COLEND-COLBEG+1))
177 I $G(ON)]""!($G(OFF)]"") D CNTRL^VALM10(LINE,COLBEG,$L(STRING),ON,OFF)
178 Q
179 ;
180 ;
181DIQ344(DA,DR) ; retrieves data for flds in file 344
182 N %I,D0,DIC,DIQ,DIQ2,YY
183 K RCDPDATA(344,DA)
184 S DIQ(0)="IE",DIC="^RCY(344,",DIQ="RCDPDATA" D EN^DIQ1
185 Q
186 ;
187 ;
188DIQ34401(DA,SUBDA) ; retrieves data for flds in file 344
189 ; da = receipt da
190 N %I,D0,DIC,DIQ,DIQ2,DR
191 K RCDPDATA(344.01,SUBDA)
192 S DR=1,DR(344.01)=".01:1.02",DA(344.01)=SUBDA
193 S DIQ(0)="IE",DIC="^RCY(344,",DIQ="RCDPDATA" D EN^DIQ1
194 Q
195 ;
196 ;
197HDR ; header code for list manager display
198 N DATE,FMSDOC,RCDPDATA,SPACE,RCEFT,Z
199 D DIQ344(RCRECTDA,".01;.04;.06;.08;.14;.17;.18;")
200 S SPACE="",$P(SPACE," ",80)=""
201 S VALMHDR(1)=$E(" Receipt #: "_RCDPDATA(344,RCRECTDA,.01,"E")_SPACE,1,39)_"Type of Payment: "_RCDPDATA(344,RCRECTDA,.04,"E")
202 S Z=RCDPDATA(344,RCRECTDA,.06,"E"),RCEFT=+$O(^RCY(344.3,"ARDEP",+$P($G(^RCY(344,RCRECTDA,0)),U,6),0))
203 S VALMHDR(2)=$E($S('RCEFT&'RCDPDATA(344,RCRECTDA,.17,"I"):" Deposit #: "_Z,RCEFT:" EFT Deposit: "_Z,1:"EFT Detail #: "_RCDPDATA(344,RCRECTDA,.17,"E"))_" "_$P($G(^RCY(344.31,+RCDPDATA(344,RCRECTDA,.17,"I"),0)),U,2)_SPACE,1,23)
204 S VALMHDR(2)=VALMHDR(2)_$E($S(RCDPDATA(344,RCRECTDA,.18,"E")'="":" ERA #: "_RCDPDATA(344,RCRECTDA,.18,"E"),1:"")_SPACE,1,16)_" Receipt Status: "_RCDPDATA(344,RCRECTDA,.14,"E")
205 ; get fms document and status
206 S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
207 S VALMHDR(3)=$E("FMS Document: "_$TR($P(FMSDOC,"^")," ")_$S($P(FMSDOC,"^",3):"(on deposit)",1:"")_SPACE,1,39)_" FMS Doc Status: "_$P(FMSDOC,"^",2)
208 ;
209 I RCDPDATA(344,RCRECTDA,.08,"I") S VALMSG="Receipt processed on "_RCDPDATA(344,RCRECTDA,.08,"E")
210 Q
211 ;
212 ;
213EXIT ; exit option/clean up
214 K ^TMP("RCDPRPLM",$J)
215 Q
Note: See TracBrowser for help on using the repository browser.