source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXFMSCR.m@ 824

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

initial load of WorldVistAEHR
File size: 6.2 KB
Line 
1RCXFMSCR ;WISC/RFJ-fms cash receipt (cr) code sheet generator ;1 Oct 97
2 ;;4.5;Accounts Receivable;**90,114,148,172,204,203,173,220,184**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6BUILDCR(RCRECTDA,RCGECSDA,RCEFT) ; generate a cr/tr code sheet for a receipt
7 ; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
8 ; rceft = 1 if processing CR for an EFT deposit (CR to rev src cd 8NZZ)
9 ; = 2 if processing TR for the receipt detail relating to an EFT
10 ; (TR from 528704/8NZZ to original fund/rsc)
11 ;
12 N AMOUNT,BILLDA,COUNT,CR2,DETAIL,DEPOSIT,DESCRIP,DOCTOTAL,FISCALYR,FMSTYPE,FUND,GECSFMS,LINE,RCDEPTDA,REVSRCE,TOTAL,TRANDA,TRANNUMB,UNAPPLY,UNAPPNUM,VENDORID,EFTDEP
13 ;
14 ; build the lines for all payments on receipt
15 S RCEFT=+$G(RCEFT)
16 K ^TMP($J,"RCFMSCR") ; used for 215 report, not used here
17 D FMSLINES^RCXFMSC1(RCRECTDA)
18 K ^TMP($J,"RCFMSCR")
19 ;
20 ; unapplied payments to accounts
21 S TRANDA=0 F S TRANDA=$O(^RCY(344,RCRECTDA,1,TRANDA)) Q:'TRANDA D
22 . ; dollars applied in AR
23 . I $P(^RCY(344,RCRECTDA,1,TRANDA,0),"^",5) Q
24 . ; no dollars on transaction
25 . S AMOUNT=$P(^RCY(344,RCRECTDA,1,TRANDA,0),"^",4) I 'AMOUNT Q
26 . ;
27 . I RCEFT=1 S TOTAL("5287"_$S(DT<3030926:"",DT'<3030926&(DT<$$ADDPTEDT^PRCAACC()):".4",1:"04"),"8NZZ","MCCFVALUE")=$G(TOTAL("5287"_$S(DT<3030926:"",1:"04"),"8NZZ","MCCFVALUE"))+AMOUNT Q
28 . S UNAPPLY($$GETUNAPP(RCRECTDA,TRANDA,1))=AMOUNT
29 ;
30 ; no code sheets to send
31 I '$D(DETAIL),'$D(TOTAL),'$D(UNAPPLY) Q "-1^No code sheets to send for this receipt"
32 ;
33 ; get the next common number in the series = station "-" nextnumber
34 ; use (field 200 in file 344) if document previously sent
35 S TRANNUMB=$P($P($G(^RCY(344,RCRECTDA,2)),"^"),"-",2)
36 I TRANNUMB="" S TRANNUMB=$$ENUM^RCMSNUM
37 I TRANNUMB<0 Q "0^Unable to lookup next transaction number"
38 ; remove the dash (i,e, 460-K1A05HY)
39 S TRANNUMB=$TR(TRANNUMB,"-")
40 ;
41 S FISCALYR=$$FY^RCFN01(DT)
42 ;
43 S COUNT=0,DOCTOTAL=0
44 ; build detail line
45 S FMSTYPE="" F S FMSTYPE=$O(DETAIL(FMSTYPE)) Q:FMSTYPE="" D
46 . S BILLDA=0 F S BILLDA=$O(DETAIL(FMSTYPE,BILLDA)) Q:'BILLDA D
47 . . S AMOUNT=DETAIL(FMSTYPE,BILLDA),DOCTOTAL=DOCTOTAL+AMOUNT
48 . . S COUNT=COUNT+1
49 . . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
50 . . S $P(LINE(COUNT),"^",20)=$J(AMOUNT,0,2)
51 . . S $P(LINE(COUNT),"^",21)="I"
52 . . S $P(LINE(COUNT),"^",23)=FMSTYPE
53 . . S $P(LINE(COUNT),"^",24)="BD"
54 . . S $P(LINE(COUNT),"^",25)=$TR($P(^PRCA(430,BILLDA,0),"^"),"-")
55 . . S $P(LINE(COUNT),"^",26)=$$LINE^RCXFMSC1(BILLDA)
56 . . S $P(LINE(COUNT),"^",27)="~"
57 ;
58 ; build summary line
59 S FUND="" F S FUND=$O(TOTAL(FUND)) Q:FUND="" D
60 . S REVSRCE="" F S REVSRCE=$O(TOTAL(FUND,REVSRCE)) Q:REVSRCE="" D
61 . . S VENDORID="" F S VENDORID=$O(TOTAL(FUND,REVSRCE,VENDORID)) Q:VENDORID="" D
62 . . . S AMOUNT=TOTAL(FUND,REVSRCE,VENDORID),DOCTOTAL=DOCTOTAL+AMOUNT
63 . . . S COUNT=COUNT+1
64 . . . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
65 . . . S $P(LINE(COUNT),"^",4)=$S(FUND=4032:"03",1:FISCALYR)
66 . . . S $P(LINE(COUNT),"^",4)=$S($E(FUND,1,4)=5287:"05",1:FISCALYR)
67 . . . S $P(LINE(COUNT),"^",6)=FUND
68 . . . S $P(LINE(COUNT),"^",7)=$E(TRANNUMB,1,3) ; station #
69 . . . S $P(LINE(COUNT),"^",10)=REVSRCE
70 . . . ;I FUND=4032 S $P(LINE(COUNT),"^",13)="24GX40100"
71 . . . S $P(LINE(COUNT),"^",18)=VENDORID
72 . . . S $P(LINE(COUNT),"^",20)=$J(AMOUNT,0,2)
73 . . . S $P(LINE(COUNT),"^",21)="I"
74 . . . S $P(LINE(COUNT),"^",23)=23
75 . . . S $P(LINE(COUNT),"^",24)="~"
76 ;
77 ; build unapplied payment lines
78 S UNAPPNUM="" F S UNAPPNUM=$O(UNAPPLY(UNAPPNUM)) Q:UNAPPNUM="" D
79 . S AMOUNT=UNAPPLY(UNAPPNUM),DOCTOTAL=DOCTOTAL+AMOUNT
80 . S COUNT=COUNT+1
81 . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
82 . S $P(LINE(COUNT),"^",4)=FISCALYR
83 . S $P(LINE(COUNT),"^",6)=3875
84 . S $P(LINE(COUNT),"^",7)=$E(TRANNUMB,1,3) ; station #
85 . S $P(LINE(COUNT),"^",20)=$J(AMOUNT,0,2)
86 . S $P(LINE(COUNT),"^",21)="I"
87 . S $P(LINE(COUNT),"^",23)=17
88 . S $P(LINE(COUNT),"^",24)="~CRB"
89 . S $P(LINE(COUNT),"^",32)=UNAPPNUM
90 . S $P(LINE(COUNT),"^",33)="~"
91 ;
92 ; get data from file 344.1, the ar deposit file
93 S RCDEPTDA=$P(^RCY(344,RCRECTDA,0),"^",6),DEPOSIT=$G(^RCY(344.1,RCDEPTDA,0))
94 ;
95 ; build cr2, $p(deposit,^,3)=deposit date
96 N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
97 S CR2="CR2^"_$E(FMSDT,2,3)_"^"_$E(FMSDT,4,5)_"^"_$E(FMSDT,6,7)_"^^^^^^E^^^"
98 S CR2=CR2_$P(DEPOSIT,"^")_"^^"_$J(DOCTOTAL,0,2)_"^^"
99 S CR2=CR2_$E($P(DEPOSIT,"^",3),2,3)_"^"_$E($P(DEPOSIT,"^",3),4,5)_"^"_$E($P(DEPOSIT,"^",3),6,7)_"^~"
100 ;
101 ; put together document in gcs
102 N %DT,D,D0,DA,DI,DIC,DIE,DIQ2,DQ,DR
103 S DESCRIP="Receipt: "_$P(^RCY(344,RCRECTDA,0),"^")
104 I 'RCGECSDA D CONTROL^GECSUFMS("A",$E(TRANNUMB,1,3),TRANNUMB,"CR",10,0,"",DESCRIP)
105 I RCGECSDA D REBUILD^GECSUFM1(RCGECSDA,"A",10,"N","Rebuild "_DESCRIP) S GECSFMS("DA")=RCGECSDA
106 ;
107 ; store document in gcs
108 D SETCS^GECSSTAA(GECSFMS("DA"),CR2)
109 F COUNT=1:1 Q:'$D(LINE(COUNT)) D SETCS^GECSSTAA(GECSFMS("DA"),LINE(COUNT))
110 D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
111 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
112 ;
113 ; add/update entry in file 347 for unprocessed document report
114 N %DT,%X,D,DA347,D0,DI,DQ,DIC,ERROR,FMSDOCNO,X
115 S FMSDOCNO="CR-"_$P(GECSFMS("CTL"),"^",9)
116 S DA347=$O(^RC(347,"C",FMSDOCNO,0))
117 ; if not in the file, addit fmsdocid cr id
118 I 'DA347 D OPEN^RCFMDRV1(FMSDOCNO,3,"RC"_$P($G(^RCY(344,RCRECTDA,0)),"^"),.DA347,.ERROR)
119 I DA347 D SSTAT^RCFMFN02(FMSDOCNO,1)
120 ;
121 ; return 1 for success ^ fms document transaction number
122 Q "1^"_FMSDOCNO
123 ;
124 ;
125GETUNAPP(RCRECTDA,RCTRANDA,RCSTORE) ; get unapplied deposit number for receipt
126 ; if $g(rcstore) store it with transaction
127 N UNAPPNUM
128 ; if number is already assigned, use it
129 I $P($G(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",5)'="" Q $P(^(2),"^",5)
130 ;
131 S UNAPPNUM=$P(^RCY(344,RCRECTDA,0),"^")
132 ; if the receipt number is more than 9 characters, take the last 9
133 I $L(UNAPPNUM)>9 S UNAPPNUM=$E(UNAPPNUM,$L(UNAPPNUM)-8,$L(UNAPPNUM))
134 S UNAPPNUM=UNAPPNUM_$TR($J(RCTRANDA,4)," ",0)
135 ;
136 ; store unapplied number
137 I $G(RCSTORE) D SETUNAPP^RCDPURET(RCRECTDA,RCTRANDA,UNAPPNUM)
138 ;
139 Q UNAPPNUM
Note: See TracBrowser for help on using the repository browser.