source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXFMST1.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1RCXFMST1 ;ALB/TMK-EDI Lockbox fms transfer (tr) cd sht gen ;31 Mar 03
2 ;;4.5;Accounts Receivable;**173,220,184,238**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7GETTR(RCRECTDA,RCGECSDA) ; extract transfer data for TR code sheet for
8 ; a receipt in rcrectda
9 ; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
10 ;
11 N TRANDA,AMOUNT,DETAIL,UNAPPLY,TOTAL,RCTOTAL,FUND,REVSRCE,VENDORID,RCSEQ,RESULT,GECSDATA,RCTRANS,UNAPPNUM,TRANNUMB
12 ;
13 ; extract all payments on receipt
14 S RESULT=""
15 K ^TMP($J,"RCFMSCR") ; used for 215 report, not used here
16 D FMSLINES^RCXFMSC1(RCRECTDA,1)
17 K ^TMP($J,"RCFMSCR")
18 ;
19 ; unapplied payments to accounts
20 S TRANDA=0 F S TRANDA=$O(^RCY(344,RCRECTDA,1,TRANDA)) Q:'TRANDA D
21 . ; dollars applied in AR
22 . I $P(^RCY(344,RCRECTDA,1,TRANDA,0),U,5) Q
23 . ; no dollars on transaction
24 . S AMOUNT=$P(^RCY(344,RCRECTDA,1,TRANDA,0),U,4) I 'AMOUNT Q
25 . ;
26 . S UNAPPLY($$GETUNAPP^RCXFMSCR(RCRECTDA,TRANDA,1))=AMOUNT
27 ;
28 ; no code sheets to send
29 I '$D(DETAIL),'$D(TOTAL),'$D(UNAPPLY) S RESULT="-1^No code sheets to send for this receipt" G QUIT
30 ;
31 ; get the next common number in the series = station "-" nextnumber
32 ; use (field 200 in file 344) if document previously sent
33 S TRANNUMB=$P($P($G(^RCY(344,RCRECTDA,2)),U),"-",2)
34 I TRANNUMB="" S TRANNUMB=$$ENUM^RCMSNUM
35 I TRANNUMB<0 S RESULT="0^Unable to lookup next transaction number" G QUIT
36 ; remove the dash (i,e, 460-K1A05HY)
37 S TRANNUMB=$TR(TRANNUMB,"-")
38 ;
39 ; extract transfer from/to array for applied payments
40 S (RCTOTAL,RCSEQ)=0
41 S FUND="" F S FUND=$O(TOTAL(FUND)) Q:FUND="" D
42 . S REVSRCE="" F S REVSRCE=$O(TOTAL(FUND,REVSRCE)) Q:REVSRCE="" D
43 . . S VENDORID="" F S VENDORID=$O(TOTAL(FUND,REVSRCE,VENDORID)) Q:VENDORID="" D
44 . . . S RCSEQ=RCSEQ+1,RCTRANS($$TRFUND(),"8NZZ",RCSEQ)=FUND_U_REVSRCE_U_TOTAL(FUND,REVSRCE,VENDORID)_U_U_VENDORID
45 ;
46 ; extract unapplied payments
47 S UNAPPNUM="" F S UNAPPNUM=$O(UNAPPLY(UNAPPNUM)) Q:UNAPPNUM="" D
48 . S RCSEQ=RCSEQ+1,RCTRANS($$TRFUND(),"8NZZ",RCSEQ)=3875_U_U_UNAPPLY(UNAPPNUM)_U_UNAPPNUM
49 ;
50 ; build the TR document
51 S RESULT=$$BUILDTR(.RCTRANS,.DETAIL,+$G(GECSDATA),TRANNUMB,RCRECTDA)
52 ;
53QUIT Q RESULT
54 ;
55BUILDTR(RCTRANS,RCDETAIL,RCGECSDA,TRANNUMB,RCRECTDA) ; generate a tr code
56 ; sheet for transferring dollars out of 528704/8NZZ
57 ;
58 ; rctrans(fund,rsc,seq) = data array passed
59 ; fund=fund to transfer from (always 528704)
60 ; rsc = rsc to transfer from (always 8NZZ)
61 ; seq = sequence to make record unique for each 'transferred to' rsc
62 ; data = fund to transfer to (piece 1)
63 ; rsc to transfer to (piece 2)
64 ; dollars to transfer (piece 3)
65 ; unapplied deposit # for suspense (fund to transfer to=3875)
66 ; vendor id (piece 5)
67 ;
68 ; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
69 ;
70 ; trannumb is the document identifier
71 ;
72 ; rcrectda is the ien of the receipt (file 344)
73 ;
74 ; rcdetail array contains accrual data for BD transactions
75 ;
76 N COUNT,DATA,DESCRIP,FISCALYR,FUND,GECSFMS,LINE,REVSRCE,TR2,X,Y,RCSUSP,BILLDA,FMSTYPE,AMOUNT,RCSEQ
77 ;
78 S FISCALYR=$$FY^RCFN01(DT)
79 ;
80 ; build detail lines
81 S COUNT=0
82 ;
83 S FMSTYPE="" F S FMSTYPE=$O(RCDETAIL(FMSTYPE)) Q:FMSTYPE="" D
84 . S BILLDA=0 F S BILLDA=$O(RCDETAIL(FMSTYPE,BILLDA)) Q:'BILLDA D
85 . . S AMOUNT=RCDETAIL(FMSTYPE,BILLDA)
86 . . ; Decrease from 528704/8NZZ
87 . . S COUNT=COUNT+1
88 . . S LINE(COUNT)=$$DEC(COUNT,FISCALYR,TRANNUMB,AMOUNT)
89 . . ; Send BD
90 . . S COUNT=COUNT+1
91 . . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
92 . . S $P(LINE(COUNT),U,20)=$J(AMOUNT,0,2)
93 . . S $P(LINE(COUNT),U,21)="I"
94 . . S $P(LINE(COUNT),U,23)=$S(FMSTYPE'=75:FMSTYPE,$$GETFUNDB^RCXFMSUF(BILLDA,1)["5287":33,1:75)
95 . . S $P(LINE(COUNT),U,24)="BD"
96 . . S $P(LINE(COUNT),U,25)=$TR($P(^PRCA(430,BILLDA,0),U),"-")
97 . . S $P(LINE(COUNT),U,26)=$$LINE^RCXFMSC1(BILLDA)
98 . . S $P(LINE(COUNT),U,27)="~"
99 . ;
100 ;
101 S FUND=$$TRFUND(),REVSRCE="8NZZ"
102 S RCSEQ=0 F S RCSEQ=$O(RCTRANS(FUND,REVSRCE,RCSEQ)) Q:'RCSEQ D
103 . S DATA=RCTRANS(FUND,REVSRCE,RCSEQ)
104 . ; if no value, quit
105 . I '$P(DATA,U,3) Q
106 . ;
107 . ; create line to transfer from (decrease)
108 . S COUNT=COUNT+1
109 . S LINE(COUNT)=$$DEC(COUNT,FISCALYR,TRANNUMB,$P(DATA,U,3))
110 . ;
111 . ; create line to transfer to (increase)
112 . S COUNT=COUNT+1
113 . S RCSUSP=($P(DATA,U)=3875)
114 . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
115 . S $P(LINE(COUNT),U,4)=FISCALYR
116 . S $P(LINE(COUNT),U,4)=$S($E(FUND,1,4)=5287:"05",1:FISCALYR)
117 . S $P(LINE(COUNT),U,6)=$P(DATA,U)
118 . S $P(LINE(COUNT),U,7)=$E(TRANNUMB,1,3) ; station #
119 . I 'RCSUSP S $P(LINE(COUNT),U,10)=$P(DATA,U,2)
120 . ;
121 . ; vendor id
122 . I 'RCSUSP S $P(LINE(COUNT),U,18)=$P(DATA,U,5)
123 . ;
124 . S $P(LINE(COUNT),U,20)=$J($P(DATA,U,3),0,2)
125 . S $P(LINE(COUNT),U,21)="I"
126 . S $P(LINE(COUNT),U,23)=$S('RCSUSP:33,1:24)
127 . S $P(LINE(COUNT),U,24)=$S('RCSUSP:"~",1:"~CRB")
128 . I RCSUSP D
129 . . S $P(LINE(COUNT),U,32)=$P(DATA,U,4)
130 . . S $P(LINE(COUNT),U,33)="~"
131 ;
132 ; build tr2
133 N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
134 S TR2="CR2^"_$E(FMSDT,2,3)_U_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_"^^^^^^E^^^"
135 ; deposit number which is equal to the gcs id
136 ; $j(0,0,2) is the document total which is zero
137 S TR2=TR2_$P(TRANNUMB,U)_"^^"_$J(0,0,2)_"^^"
138 ; deposit/transfer date
139 S TR2=TR2_$E(DT,2,3)_U_$E(DT,4,5)_U_$E(DT,6,7)_"^~"
140 ;
141 ; put together document in gcs
142 N D0,DA,DI,DIC,DIE,DIQ2,DQ,DR
143 S DESCRIP="EDI Lockbox Detail Receipt: "_$P(^RCY(344,RCRECTDA,0),U)
144 I 'RCGECSDA D CONTROL^GECSUFMS("A",$E(TRANNUMB,1,3),TRANNUMB,"TR",10,0,"",DESCRIP)
145 I RCGECSDA D REBUILD^GECSUFM1(RCGECSDA,"A",10,"N","Rebuild "_DESCRIP) S GECSFMS("DA")=RCGECSDA
146 ;
147 ; store document in gcs
148 D SETCS^GECSSTAA(GECSFMS("DA"),TR2)
149 F COUNT=1:1 Q:'$D(LINE(COUNT)) D SETCS^GECSSTAA(GECSFMS("DA"),LINE(COUNT))
150 D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
151 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
152 ;
153 ; add/update entry in file 347 for unprocessed document report
154 N %DT,%X,D,DA347,D0,DI,DQ,DIC,ERROR,FMSDOCNO,X
155 S FMSDOCNO="TR-"_$P(GECSFMS("CTL"),U,9)
156 S DA347=$O(^RC(347,"C",FMSDOCNO,0))
157 ; if not in the file, addit fmsdocid tr id
158 I 'DA347 D OPEN^RCFMDRV1(FMSDOCNO,9,"TR-"_$P($G(^RCY(344,RCRECTDA,0)),U),.DA347,.ERROR)
159 I DA347 D SSTAT^RCFMFN02(FMSDOCNO,1)
160 ;
161 ; return 1 for success ^ fms document id
162 Q 1_"^TR-"_$P(GECSFMS("CTL"),U,9)
163 ;
164 ;
165DEC(COUNT,FISCALYR,TRANNUMB,AMOUNT) ; Add decrease from 528704/8NZZ
166 ; Returns LINE with decrease TR info
167 ; FISCALYR/TRANNUMB from above
168 ; COUNT = line counter
169 ; AMOUNT = amount to be transferred
170 ;
171 S LINE="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
172 S $P(LINE,U,4)=FISCALYR
173 S $P(LINE,U,6)=$$TRFUND()
174 S $P(LINE,U,4)=$S($E($P(LINE,U,6),1,4)=5287:"05",1:FISCALYR)
175 S $P(LINE,U,7)=$E(TRANNUMB,1,3) ; station #
176 S $P(LINE,U,10)="8NZZ"
177 ;
178 ; vendor id
179 S $P(LINE,U,18)="MCCFVALUE"
180 S $P(LINE,U,20)=$J(AMOUNT,0,2)
181 S $P(LINE,U,21)="D"
182 S $P(LINE,U,23)=33
183 S $P(LINE,U,24)="~"
184 Q LINE
185 ;
186TRFUND() ; Determine if fund should be 5287 or 528704, based on date
187 I DT<3030926 Q 5287
188 I DT<$$ADDPTEDT^PRCAACC() Q 5287.4
189 Q 528704
190 ;
Note: See TracBrowser for help on using the repository browser.