source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDF41.m@ 1806

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1IBJDF41 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (COMPILE) ;15-APR-00
2 ;;2.0;INTEGRATED BILLING;**123,159,204,356**;21-MAR-94
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ST ; - Tasked entry point.
6 K IB,IBCAT,^TMP("IBJDF4",$J) S IBQ=0
7 ;
8 ; - Set selected categories for report.
9 I IBSEL[1 S IBCAT(2)=1
10 I IBSEL[2 S IBCAT(1)=2
11 I IBSEL[3 S IBCAT(18)=3 F X=22,23 S IBCAT(X)=4
12 I IBSEL[4 F X=33:1:39 S IBCAT(X)=5
13 ;
14 ; - Print the header line for the Excel spreadsheet
15 I $G(IBEXCEL) D PHDL
16 ;
17 ; - Find data required for report.
18 F IB=16,19,40 D G:IBQ ENQ
19 . I IBSTA="A",IB'=16 Q ; Active AR's only.
20 . I IBSTA="S",IB=16 Q ; Suspended AR's only.
21 . I IB'=40 D
22 . . S IBCAT=""
23 . . F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
24 . . . D INIT^IBJDF43
25 . S IBA=0
26 . F S IBA=$O(^PRCA(430,"AC",IB,IBA)) Q:'IBA D Q:IBQ
27 . . D PROC
28 ;
29 I 'IBQ,'$G(IBEXCEL) D EN^IBJDF42 ; Print the report.
30 ;
31ENQ K ^TMP("IBJDF4",$J)
32 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
33 ;
34 D ^%ZISC
35ENQ1 K IB,IB0,IBA,IBA1,IBADM,IBAGE,IBAR,IBAR1,IBBA,IBBN,IBBU,IBC,IBCAT,IBCAT1
36 K IBELIG,IBEXCEL,IBFLG,IBAI,IBAIQ,IBIDX,IBIO,IBINT,IBN,IBPA,IBPD,IBPAT
37 K IBPT,IBQ,IBRFD,IBRFT,IBSRC,IBRP,IBVA,COM,COM1,DAT,DFN,X,X1,X2,Y,Z
38 Q
39 ;
40PROC ; - Process data for report(s).
41 I IBA#100=0 D Q:IBQ
42 .S IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
43 S IBAR=$G(^PRCA(430,IBA,0)) I 'IBAR Q
44 S IBCAT=+$P(IBAR,U,2) I '$D(IBCAT(IBCAT)) Q ;Get valid AR category.
45 I '$$CLMACT^IBJD(IBA,IBCAT) Q ; Invalid IB claim/action.
46 S IBPT=$$PAT(IBA) I IBPT="" Q ; Get patient info.
47 S DFN=$P(IBPT,U,2)
48 S IBAGE=$$FMDIFF^XLFDT(DT,+$P(IBAR,U,10))
49 I IBSMN,IBAGE<IBSMN!(IBAGE>IBSMX) Q ; AR outside age range.
50 S IBVA=$$VA^IBJD1(DFN),IBBN=$P(IBAR,U),IBPD=$P($$PYMT^IBJD1(IBA),U)
51 S IBPAT=$P(IBPT,U)_"@@"_DFN
52 ;
53 ; - Check the AR balance amounts, if necessary.
54 S (IBADM,IBBA,IBINT,IBPA)=0,IBN=$G(^PRCA(430,IBA,7))
55 F X=1:1:5 D
56 . S IBBA=IBBA+$P(IBN,U,X)
57 . S:X=1 IBPA=+IBN S:X=2 IBINT=$P(IBN,U,2) S:X=3 IBADM=$P(IBN,U,3)
58 ;
59 I '$G(IBEXCEL) D EN^IBJDF43 I IBRPT="S" Q ; Get summary stats.
60 ;
61 I IBSAM,IBBA<IBSAM Q
62 ;
63 ; - Check if AR was referred to R-Regional Counsel, D-DMC, or T-TOP
64 ; and exclude, if necessary.
65 S IB0=$S(IB=40:19,1:IB),IBIDX=0,IBRFT=""
66 S IBAIQ=0,IBAI=$G(^TMP("IBJDF4",$J,IBPAT,0,"A"))
67 S IBRFD=$P($G(^PRCA(430,IBA,6)),U,4)
68 I IBRPT="D",IBRFD D I IBAIQ Q ; Referred to RC
69 . S IBRFT="R" I IBAI'["R" S IBAI=IBAI_"R"
70 . I 'IBSRC S IBAIQ=1 Q
71 . D SREF("R",IBRFD,IB0,,.IBIDX)
72 S IBRFD=+$G(^PRCA(430,IBA,12))
73 I IBRPT="D",IBRFD D ; Referred to DMC
74 . S IBRFT=IBRFT_"D" I IBAI'["D" S IBAI=IBAI_"D"
75 . D SREF("D",IBRFD,IB0,,.IBIDX)
76 S IBRFD=+$G(^PRCA(430,IBA,14))
77 I IBRPT="D",IBRFD D ; Referred to TOP
78 . S IBRFT=IBRFT_"T" I IBAI'["T" S IBAI=IBAI_"T"
79 . D SREF("T",IBRFD,IB0,,.IBIDX)
80 ;
81 ; - Check if AR is on P-Repayment plan or F-Defaulted repayment plan.
82 ; and exclude if repayment plan is active.
83 S IBRP=$$RP(IBA)
84 I IBRP D
85 . I IBRP=2 S IBRFT=IBRFT_"F" I IBAI'["F" S IBAI=IBAI_"F"
86 . I IBRP=1 S IBRFT=IBRFT_"P" I IBAI'["P"&(IBAI'["F") S IBAI=IBAI_"P"
87 . D SREF("P",$P(IBRP,"^",2),IB0,$S(+IBRP=2:1,1:0),.IBIDX)
88 ;
89 I IBIDX S IBFLG=1
90 ;
91 ; - Check if VA Employee
92 I $P(IBVA,"^")["*",IBAI'["V" S IBAI=IBAI_"V"
93 ;
94 I IBAI'="" S ^TMP("IBJDF4",$J,IBPAT,0,"A")=IBAI
95 ;
96 ; - Set up indexes for detail report.
97 I $G(IBEXCEL) D Q
98 . S IBEXCEL1=$P($G(^PRCA(430.2,IBCAT,0)),U,2)_U_$P(IBPT,U,3)_U_$P(IBVA,U)_U_$P(IBPT,U,4)_U_$$DT^IBJD($P(IBPT,U,6),1)_U_$$ELIG^IBJDF42(+$P(IBPT,U,5))_U
99 . S IBEXCEL1=IBEXCEL1_$$GET1^DIQ(2,DFN,.381)_U_$$MTRX(DFN)_U_IBBN_U_$S(IB=16:"A",1:"S")_U_IBRFT_U_$$DT^IBJD($P(IBAR,U,10),1)_U_$$DT^IBJD(IBPD,1)_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U
100 . I IBSH D COM
101 . S IBD=0 I DAT!IBPD S IBD=$$FMDIFF^XLFDT(DT,$S('DAT:IBPD,1:$G(DAT)))
102 . S IBEXCEL1=IBEXCEL1_U_IBD W !,IBEXCEL1 K IBD,IBEXCEL1
103 ;
104 I '($D(^TMP("IBJDF4",$J,IBPAT))#10) D
105 . S ^TMP("IBJDF4",$J,IBPAT)=$P(IBPT,U,3,5)_U_$$MTRX(DFN)_U_$P(IBPT,U,6)_"^"_$P(IBVA,"^",2)_"^"_$$ACCBAL($P(IBPT,U,7))
106 S ^TMP("IBJDF4",$J,IBPAT,IB0,IBCAT,IBBN)=IBPD_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U_IBIDX
107 ;
108 I IBSH D COM
109 ;
110 Q
111 ;
112ACCBAL(DFN) ; Calculates the Account Balance for the Bill
113 ; Input: DFN - Patient/Debtor internal number
114 ; Output: BAL - Patient/Debtor Account Balance
115 ;
116 N B0,B7,BAL,BILL,I
117 S (BAL,BILL)=0
118 F S BILL=$O(^PRCA(430,"C",DFN,BILL)) Q:BILL="" D
119 . S B0=$G(^PRCA(430,BILL,0)) I $P(B0,"^",8)'=16 Q
120 . S B7=$G(^PRCA(430,BILL,7))
121 . F I=1:1:5 S BAL=BAL+$P(B7,"^",I)
122 Q BAL
123 ;
124PHDL ; - Print the header line for the Excel spreadsheet
125 N X
126 S X="Cat^Patient^VA Empl.?^SSN^Dt Death^Prim.Elig.^Med.Elig.?^"
127 S X=X_"Means Tst Sts^Means Tst Dt^RX Copay Exemp.Sts^RX Copay Exemp.Dt^"
128 S X=X_"Bill #^Act/Susp^Refer. to^Dt Bill prep.^Last Pymt Dt^"
129 S X=X_"Curr.Bal.^Princ.Bal.^Int.^Admin.^Last Comm.Dt^Days Lst Comm."
130 W !,X
131 Q
132 ;
133PAT(X) ; - Find the AR patient and decide to include the AR.
134 ; Input: X=AR pointer to file #430 and pre-set variables IBS*
135 ; Output: Y=Sort key (name or last 4) ^ Patient pointer to file #2
136 ; ^ Name ^ SSN ^ Eligibilities ^ Date of death (if any)
137 ; ^ Debtor pointer to file #340
138 N PAT,KEY,DBTR,DFN,DEATH,NAME,SSN,VAEL,VADM,X1,X2
139 S PAT="" G:'$G(X) PATQ
140 S DBTR=+$P($G(^PRCA(430,X,0)),U,9)
141 S X1=$P($G(^RCD(340,DBTR,0)),U) G:X1'["DPT" PATQ
142 S DFN=+X1 G:'DFN PATQ D DEM^VADPT
143 S NAME=VADM(1),SSN=$P(VADM(2),"^"),DEATH=VADM(6)\1
144 S KEY=$S(IBSN="N":NAME,1:$E(SSN,6,9))
145 I KEY=""!(IBSNF'="@"&('DFN)) G PATQ
146 I $D(IBSNA) G:IBSNA="ALL"&('DFN) PATQ G:IBSNA="NULL"&(DFN) PATQ
147 I $G(IBSNA)="ALL" G PATC
148 I IBSNF="@",IBSNL="zzzzz" G PATC
149 I IBSNF'=KEY,IBSNF]KEY G PATQ
150 I IBSNL'=KEY,KEY]IBSNL G PATQ
151 ;
152PATC ; - Set patient eligibilities.
153 D ELIG^VADPT S X2=+$G(VAEL(1))_";"
154 I +X2 S X1=0 F S X1=$O(VAEL(1,X1)) Q:'X1 S X2=X2_X1_";"
155 ;
156 S PAT=KEY_U_DFN_U_$E(NAME,1,26)_U_SSN_U_X2_U_DEATH
157 S PAT=PAT_U_DBTR
158PATQ Q PAT
159 ;
160RP(X) ; - Check if claim/receivable is under a repayment plan.
161 ; Input: X=Bill pointer to file #399/#430
162 ; Output: 0-Not on repay plan, 1-On repay plan, 2-On defaulted plan
163 N Z
164 S Z=$$REPDATA^RCBECHGA(X,1) I Z="" Q 0
165 I '$P(Z,"^",7) Q ("1^"_$P(Z,"^"))
166 Q ("2^"_$P(Z,"^"))
167 ;
168MTRX(X) ; - Return patient's means test and/or RX copay status and most recent
169 ; test dates for both.
170 ; Input: X=Patient pointer to file #2 and opt. variable IBEXCEL
171 ; Output: Y=Means test status ^ Date ^ RX copay status ^ Date
172 N MTST,RXST,Y
173 S Y="^^^",MTST=$$LST^DGMTU(X),RXST=$$RXST^IBARXEU(X)
174 I '$G(IBEXCEL) D
175 . S $P(Y,"^",1,2)=$P(MTST,"^",3)_"^"_$$DAT1^IBOUTL($P(MTST,"^",2))
176 . S $P(Y,"^",3)=$S('RXST:"NON-EXEMPT",+RXST=1:"EXEMPT",1:"")
177 . I $P(Y,"^",3)'="" S $P(Y,"^",4)=$$DAT1^IBOUTL($P(RXST,"^",5))
178 I $G(IBEXCEL) D
179 . S $P(Y,"^",1,2)=$P(MTST,"^",4)_"^"_$$DT^IBJD($P(MTST,"^",2),1)
180 . S $P(Y,"^",3)=$S('RXST:"M",+RXST=1:"E",1:"")
181 . I $P(Y,"^",3)'="" S $P(Y,"^",4)=$$DT^IBJD($P(RXST,"^",5),1)
182 Q Y
183 ;
184SREF(RFT,DAT,STS,DEF,IDX) ; Set the "referred to" information on the
185 ; temporary global ^TMP
186 ;Input: RFT: "R": RC, "D": DMC, "T": TOP, "P": REPAYMENT PLAN
187 ; DAT: Date it was referred/established
188 ; STS: Receivable status (16-Active,19-Suspended)
189 ; DEF: Repayment Plan in Default? (1 - YES, 0 - NO)
190 ; IDX: Subscript to be set in the Temporary global ^TMP
191 ;Output: IDX: Subscript set in the Temporary global ^TMP
192 ;
193 N SREF,IDX1
194 S DEF=+$G(DEF),IDX=+$G(IDX)
195 I RFT="R" S SREF="REFERRED TO RC"
196 I RFT="D" S SREF="REFERRED TO DMC"
197 I RFT="T" S SREF="REFERRED TO TOP"
198 I RFT="P" D
199 . S SREF="REPAYMENT PLAN ESTABLISHED"
200 . I $G(DEF) S SREF=SREF_" (CURRENTLY IN DEFAULT)"
201 ;
202 I 'IDX S IDX=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",STS,""),-1)+1
203 S IDX1=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,""),-1)+1
204 S ^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,IDX1)=DAT
205 S ^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,IDX1,1)=SREF
206 Q
207 ;
208COM ; - Get bill comments.
209 I 'IBIDX,'$G(IBEXCEL) D
210 . S IBFLG=0,IBIDX=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,""),-1)+1
211 ;
212 S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
213 F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q
214 . S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
215 . I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)>IBSH2 Q ; Comment age not minimum.
216 . I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
217 . S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
218 . I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
219 . ;
220 . ; - Append brief and transaction comments.
221 . K COM,COM1 S COM(0)=DAT,X1=0
222 . S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
223 . S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)
224 . S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
225 . I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
226 . ;
227 . ; - Get main comments.
228 . S X2=0
229 . F S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2 D
230 . . S COM($S(X1:X2+1,1:X2))=^PRCA(433,IBA1,7,X2,0)
231 . ;
232 . I $G(IBEXCEL) Q
233 . ;
234 . S IBFLG=1,^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,IBIDX,IBA1)=$G(COM(0)),X1=0
235 . F S X1=$O(COM(X1)) Q:X1="" D
236 . . S ^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,IBIDX,IBA1,X1)=COM(X1)
237 ;
238 I '$G(IBEXCEL),IBFLG D
239 . S $P(^TMP("IBJDF4",$J,IBPAT,IB0,IBCAT,IBBN),"^",6)=IBIDX
240 Q
Note: See TracBrowser for help on using the repository browser.