source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRJRCOL.m@ 846

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1RCRJRCOL ;WISC/RFJ-start of the ar data collector ;1 Mar 97
2 ;;4.5;Accounts Receivable;**68,96,101,103,170,176,191**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7START(PRCASITE,DATEBEG,DATEEND) ; start ar1 collector and fms data collector
8 N %,ACTDATE,AYEAROLD,BILLDA,CLOSED,CRITERIA,DATA0,DATASTOR,DATE,IBCNS,PREVSTAT,STAT,STRTTIME
9 D KILLTMP
10 ;
11 ; set start time
12 D NOW^%DTC S STRTTIME=%
13 ;
14 S DATASTOR="^TMP($J,""RCRJRCOLNDB"",CRITERIA)"
15 ;
16 ; count new receivables
17 S %=$$GETNEW(DATEBEG,DATEEND,1)
18 ;
19 ; used to determine future payments less than a year old
20 S AYEAROLD=$$FMADD^XLFDT(DATEEND,365)
21 ;
22 ; count current receivables for period and decrease in debts
23 ; do not look at bills not approved/finished (18,20,27,31)
24 S STAT=0 F S STAT=$O(^PRCA(430,"ASDT",STAT)) Q:'STAT I STAT'=18,STAT'=20,STAT'=27,STAT'=31 D
25 . S DATE=0,CLOSED=0
26 . ; do not look at bills closed before begin date
27 . ; count decrease number of debts, must be closed in month
28 . ; stat 17 (in-active) ; stat 22 (collected/closed)
29 . ; stat 23 (write-off) ; stat 26 (cancelled)
30 . ; stat 39 (cancellation) ; stat 41 (refunded)
31 . I ",17,22,23,26,39,41,"[(","_STAT_",") S DATE=DATEBEG-1,CLOSED=1
32 . F S DATE=$O(^PRCA(430,"ASDT",STAT,DATE)) Q:'DATE D
33 . . S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ASDT",STAT,DATE,BILLDA)) Q:'BILLDA D
34 . . . ; do not count bills already skipped
35 . . . I $D(^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)) Q
36 . . . S DATA0=$G(^PRCA(430,BILLDA,0))
37 . . . I '$P(DATA0,"^",12) S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
38 . . . ; no original amount
39 . . . I $P(DATA0,"^",3)="" S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
40 . . . ;
41 . . . ; do not look at bills activated after end date
42 . . . S ACTDATE=$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
43 . . . I 'ACTDATE!(ACTDATE>DATEEND) S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
44 . . . ;
45 . . . ; bill is closed before end date, decrease debt
46 . . . I CLOSED,DATE'>DATEEND D Q
47 . . . . ; if previous status was:
48 . . . . ; 18 (new bill), 27 (incomplete), 20 (pend approval)
49 . . . . ; then the bill was never counted as a new receivable
50 . . . . ; and should not be counted as a decrease in debts
51 . . . . S PREVSTAT=$P($G(^PRCA(430,BILLDA,9)),"^",6)
52 . . . . I PREVSTAT=18!(PREVSTAT=20)!(PREVSTAT=27) S ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
53 . . . . D SETTOTAL^RCRJRCO1(17,0,0)
54 . . . ;
55 . . . D CURRENT^RCRJRCOB(BILLDA,DATEEND,AYEAROLD)
56 ;
57 ; collect data from file 433
58 D START^RCRJRCO1
59 ; send data to ndb and fms
60 D SEND^RCRJRCOR
61 ; print summary report
62 D SUMMARY^RCRJRCOR
63 ;
64 ; compile and print bad debt report
65 I '$G(RCRJFBDR) D START^RCRJRBD(DATEEND)
66 ;
67KILLTMP ; kill tmp globals
68 K ^TMP($J,"RCRJRBD") ;stores the bad debt report
69 K ^TMP($J,"RCRJRCOL") ;used internally
70 K ^TMP($J,"RCRJRCOLNDB") ;stores the ndb data
71 K ^TMP($J,"RCRJROIG") ;stores the data for the oig extract
72 K ^TMP($J,"RCRJRCOLSV") ;stores the fms sv code sheet
73 K ^TMP($J,"RCRJRCOLWR") ;stores the fms wr code sheet
74 K ^TMP($J,"RCRJRCOLREPORT") ;stores the user report
75 K ^TMP($J,"RCBMILLDATA") ;stores the mccf/hsif payment split for rx
76 Q
77 ;
78 ;
79GETNEW(DATEBEG,DATEEND,RCRJFSTO) ; get new receivables between two dates
80 ; rcrjfsto is a flag which is set to 1 for the ndb rollup and it
81 ; will store the data in tmp. If its not a 1, it will count the
82 ; new bills and just return the count ^ amount.
83 N COUNT,DATE,ORIGAMT,PRINBAL
84 S COUNT=0,PRINBAL=0
85 S DATE=DATEBEG-1
86 F S DATE=$O(^PRCA(430,"ACTDT",DATE)) Q:'DATE!(DATE>DATEEND) D
87 . S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ACTDT",DATE,BILLDA)) Q:'BILLDA D
88 . . S ORIGAMT=$$TESTNEW(BILLDA,DATEBEG,DATEEND)
89 . . ; not a new receivable
90 . . I ORIGAMT="" S:RCRJFSTO ^TMP($J,"RCRJRCOL","COUNT",BILLDA,0)="" Q
91 . . ; store for ndb
92 . . I RCRJFSTO D SETTOTAL^RCRJRCO1(13,ORIGAMT,0)
93 . . S COUNT=COUNT+1,PRINBAL=PRINBAL+ORIGAMT
94 ;
95 Q COUNT_"^"_PRINBAL
96 ;
97 ;
98TESTNEW(BILLDA,DATEBEG,DATEEND) ; test to see if a bill is a new receivable
99 ; returns the principal balance if a bill is new
100 N DATA0,STAT
101 S DATA0=$G(^PRCA(430,BILLDA,0))
102 ; no site
103 I '$P(DATA0,"^",12) Q ""
104 ; bill never had an original amount (prepayments would not be
105 ; picked up here since they do not have an original amount)
106 I $P(DATA0,"^",3)="" Q ""
107 ;
108 S STAT=$P(DATA0,"^",8)
109 ; no status
110 I 'STAT Q ""
111 ; bill was cancelled the same month
112 ;I STAT=26,($E($P(DATA0,"^",14),1,5)=$E(DATEBEG,1,5)) Q ""
113 I STAT=26&($P(DATA0,"^",14)<DATEBEG!($P(DATA0,"^",14)>DATEEND)) Q ""
114 ; bill incomplete
115 I STAT=27 Q ""
116 ; bill new
117 I STAT=18 Q ""
118 ; bill pending approval
119 I STAT=20 Q ""
120 ; bill returned from AR (new)
121 I STAT=31 Q ""
122 ;
123 ; yes, its a new receivable, return its original amount
124 Q +$P(DATA0,"^",3)
125 ;
126 ;
127CRITERIA(BILLDA) ; find a bills criteria/category 1,3,4,5
128 ; returns 1--3-4-5 where the number is the criteria number
129 ; the second piece is set at settotal^rcrjrco1
130 ;
131 N %,CRITER1,CRITER35,DATA0,X
132 S DATA0=$G(^PRCA(430,BILLDA,0))
133 ;
134 ; % = segment
135 S %=$P(DATA0,"^",21)
136 S CRITER1=$S(%=243:1,%=244:3,%=245:2,%=246:8,%=247:9,%=248:10,%=249:5,%=251:14,%=252:16,%=292:6,%=293:7,%=294:11,%=295:19,%=296:20,%=297:4,%=298:12,1:0)
137 ;
138 ; acck = accrual
139 I CRITER1=8,'$$ACCK^PRCAACC(BILLDA) S CRITER1=18
140 ;
141 I 'CRITER1 D
142 . S %=$P($G(^PRCA(430.2,+$P(DATA0,"^",2),0)),"^",7)
143 . ; % = Category Number:
144 . ; 22 TORT FEASOR
145 . ; 18 SHARING AGREEMENTS
146 . ; 33 PREPAYMENT
147 . ; 40 ADULT DAY HEALTH CARE
148 . ; 41 DOMICILIARY
149 . ; 42 RESPITE CARE-INSTITUTIONAL
150 . ; 43 RESPITE CARE-NON-INSTITUTIONAL
151 . ; 44 GERIATRIC EVAL-INSTITUTIONAL
152 . ; 45 GERIATRIC EVAL-NON-INSTITUTION
153 . ; 46 NURSING HOME CARE-LTC
154 . S CRITER1=$S(%=22:15,%=18:17,%=33:13,%=40:1,%=41:20,%=42:20,%=43:1,%=44:20,%=45:1,%=46:20,1:18)
155 ;
156 ; determine criteria 3,4,5
157 S CRITER35="0-0-0"
158 I CRITER1>3,CRITER1<8 D
159 . S %=$TR($$CRIT^IBRFN2(BILLDA),"^","-") ;integration agreement 1182
160 . I %=-1 S CRITER35="3-1-4" Q
161 . I $P(%,"-")="" S $P(%,"-")=3
162 . I $P(%,"-",2)="" S $P(%,"-",2)=1
163 . I $P(%,"-",3)="" S $P(%,"-",3)=4
164 . S CRITER35=%
165 ;
166 Q CRITER1_"--"_CRITER35
Note: See TracBrowser for help on using the repository browser.