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

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

initial load of FOIAVistA 6/30/08 version

File size: 7.6 KB
Line 
1IBJDF42 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (PRINT);15-APR-00
2 ;;2.0;INTEGRATED BILLING;**123,204**;21-MAR-94
3 ;
4EN ; - Print the Follow-up report.
5 ;
6 S IBCT(1)="INELIGIBLE",IBCT(2)="EMERG/HUMAN.",IBCT(18)="C MEANS TEST"
7 S IBCT(22)="RX COPAY/SC",IBCT(23)="RX COPAY/NSC"
8 S IBCT(33)="ADHC LTC"
9 S IBCT(34)="DOM LTC"
10 S IBCT(35)="RESPITE INPT LTC"
11 S IBCT(36)="RESPITE OPT LTC"
12 S IBCT(37)="GERIATRIC INPT LTC"
13 S IBCT(38)="GERIATRIC OPT LTC"
14 S IBCT(39)="NURSING HOME LTC"
15 ;
16 S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
17 S IBPRTFLG=0 D DET D PAUSE:'IBPRTFLG I IBQ!'IBPRTFLG G ENQ
18 ;
19 D PAUSE I IBQ G ENQ
20 ;
21SUM I 'IBQ D PRT^IBJDF43 ; Print summary.
22ENQ K IB0,IBAI,IBC,IBCAT,IBCD,IBC1,IBC2,IBCT,IBCNT,IBN,IBP,IBPAG,IBQ,IBRUN,IBS
23 K IBST,IBTOT,%,DFN,IBPRTFLG
24 Q
25 ;
26DET ; - Print report for a specific category.
27 ;
28 D HDR1 G:IBQ DETQ
29 S (IBPT,IB,IBCAT,IB0)=""
30 F S IBPT=$O(^TMP("IBJDF4",$J,IBPT)) Q:IBPT="" D Q:IBQ
31 . I $O(^TMP("IBJDF4",$J,IBPT,0))="" Q
32 . S IBP=$G(^TMP("IBJDF4",$J,IBPT))
33 . I $Y>(IOSL-14) D PAUSE Q:IBQ D HDR1 Q:IBQ
34 . D WPAT
35 . F IB=16,19 D Q:IBQ
36 . . I IBSTA="A",IB'=16 Q
37 . . I IBSTA="S",IB=16 Q
38 . . I '$D(^TMP("IBJDF4",$J,IBPT,IB)) D Q
39 . . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,WPAT,HDR2 Q:IBQ
40 . . . W !,"-> NO "_$S(IB=16:"ACTIVE",1:"SUSPENDED")_" BILLS."
41 . . I $Y>(IOSL-9) D PAUSE Q:IBQ D HDR1,WPAT Q:IBQ
42 . . D HDR2
43 . . K IBFLG S IBTOT="",IBCNT=0
44 . . F S IBCAT=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT)) Q:IBCAT="" D Q:IBQ
45 . . . F S IB0=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0)) Q:IB0="" D Q:IBQ
46 . . . . S IBN=$G(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0))
47 . . . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,WPAT,HDR2 Q:IBQ
48 . . . . D WBIL Q:IBQ
49 . . . . S IBCNT=IBCNT+1
50 . . . I 'IBQ,$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT))="" D
51 . . . . D TOT W !
52 . . ; - Display bill comment history, if selected.
53 . . S IBPRTFLG=1
54 . . D WCOM(IBPT,IB)
55 ;
56 I 'IBPRTFLG D
57 . W !!!!!!,"There are no receivables for the parameters entered."
58 ;
59DETQ Q
60 ;
61WPAT ; - Write patient data.
62 N I,X
63 S DFN=$P(IBPT,"@@",2),IBAI=$G(^TMP("IBJDF4",$J,IBPT,0,"A"))
64 W !!,"Patient Name : ",$P(IBP,U) W:IBAI["V" " *"
65 W ?63,"SSN: ",$$SSN($P(IBP,U,2)),!,"Means Test Status: ",$P(IBP,U,4)
66 W:$P(IBP,U,5)'="" " ("_$P(IBP,U,5)_")"
67 W ?58,"Medicaid: ",$$GET1^DIQ(2,DFN,.381)
68 W !,"RX Copay Status : ",$P(IBP,U,6)
69 W:$P(IBP,U,7)'="" " ("_$P(IBP,U,7)_")"
70 W:$P(IBP,U,8) ?53,"Date of Death: ",$$DAT1^IBOUTL($P(IBP,U,8))
71 W !,"Eligibilities : " S X=$$ELIG($P(IBP,U,3))
72 F I=1:1 Q:X="" W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
73 S X=$$INFO(IBAI)
74 I X'="" D
75 . W !,"Additional Info : "
76 . F I=1:1 Q:X="" W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
77 ;
78 Q
79 ;
80WBIL ; - Write bill data.
81 W ! W:'$D(IBFLG(IBCAT)) IBCT(IBCAT) W ?13,IB0
82 W:$P(IBN,"^",6) ?25,$J("("_$P(IBN,"^",6)_")",4)
83 W ?30,$$DAT1^IBOUTL(+IBN)
84 W ?39,$J($FN($P(IBN,U,2),",",2),10),?50,$J($FN($P(IBN,U,3),",",2),10)
85 W ?61,$J($FN($P(IBN,U,4),",",2),9),?71,$J($FN($P(IBN,U,5),",",2),9)
86 S $P(IBTOT,"^")=$P(IBTOT,"^")+$P(IBN,U,2)
87 S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+$P(IBN,U,3)
88 S $P(IBTOT,"^",3)=$P(IBTOT,"^",3)+$P(IBN,U,4)
89 S $P(IBTOT,"^",4)=$P(IBTOT,"^",4)+$P(IBN,U,5)
90 S IBFLG(IBCAT)=""
91 Q
92 ;
93WCOM(IBPT,IB) ; - Write bill comments.
94 N CMDT,CONT,DIWL,DIWR,IBIDX,IBTR,IBLN,IBX,X
95 ;
96 S (IBIDX,IBTR,IBLN)="",DIWL=1,DIWR=64 K ^UTILITY($J,"W")
97 F S IBIDX=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX)) Q:IBIDX="" D Q:IBQ
98 . I $Y>(IOSL-6) D WCPB Q:IBQ
99 . D WCD(IBIDX)
100 . F S IBTR=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR)) Q:IBTR="" D Q:IBQ
101 . . S CMDT=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR))
102 . . I $Y>(IOSL-4) D WCPB Q:IBQ
103 . . S CONT=0 D WCD(,1,)
104 . . F S IBLN=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) Q:IBLN="" D Q:IBQ
105 . . . S IBX=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN))
106 . . . I $E(IBX)=" ",$L(IBX)>1 S $E(IBX)=""
107 . . . S X=IBX D ^DIWP
108 . . . I 'CONT,$L(IBX)<66 D WCTX
109 . . . S CONT=$L(IBX)>65
110 . . . I '$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) D
111 . . . . D:$D(^UTILITY($J,"W")) WCTX
112 K ^UTILITY($J,"W")
113 Q
114 ;
115WCD(I,D,C) ; - Write the comment date.
116 ; Input: I - Index # "(I)"
117 ; D - Print the Date " - MM/DD/YY"
118 ; C - Print the Cont. "(Continued)"
119 ;
120 W:$G(I) !,"(",I,")" W:$G(D) ?3," - ",$$DAT1^IBOUTL(CMDT),": "
121 W:$G(C) "(Continued)",!
122 Q
123 ;
124WCTX ; - Write the comment text.
125 N LIN,WLIN,Z
126 S LIN=""
127 F S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN="" D Q:IBQ
128 . S WLIN=$G(^UTILITY($J,"W",1,LIN,0)) Q:WLIN=""
129 . W ?16,WLIN
130 . I '$O(^UTILITY($J,"W",1,LIN)) W ! Q
131 . I $Y>(IOSL-4) D WCPB,WCD(IBIDX,1,1) Q
132 . W !
133 K ^UTILITY($J,"W")
134 Q
135 ;
136WCPB ; - Page Break in the middle of the Comments
137 D PAUSE Q:IBQ D HDR1,WPAT W !!
138 Q
139 ;
140HDR1 ; - Write the report header.
141 N X,I
142 W:'$G(IBPAG) ! I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
143 S IBPAG=$G(IBPAG)+1 W "First Party Follow-Up Report"
144 W ?34,"Run Date: ",IBRUN,?71,"Page: ",$J(IBPAG,3)
145 S X="ALL "_$S(IBSTA'="S":"ACTIVE",1:"")_$S(IBSTA="B":" AND ",1:"")
146 S X=X_$S(IBSTA'="A":"SUSPENDED",1:"")_$$TYPE(IBSEL)_" RECEIVABLES"
147 I IBSMN'="A" S X=X_" OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD"
148 S X=X_" / BY "_$S(IBSN="N":"NAME",1:"LAST 4 SSN")
149 S X=X_" ("_$S($G(IBSNA)="ALL":"ALL",1:"From "_$S(IBSNF="":"FIRST",1:IBSNF)_" to "_$S(IBSNL="zzzzz":"LAST",1:IBSNL))_")"
150 S X=X_" / "_$S('IBSAM:"NO ",1:"")_"MINIMUM BALANCE"
151 S X=X_$S(IBSAM:": $"_$FN(IBSAM,",",2),1:"")
152 S X=X_" / "_$S('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
153 S X=X_$S($G(IBSH2):" LESS THAN "_IBSH2_" DAYS OLD",1:"")
154 S X=X_" / RECEIVABLES REFERRED TO RC "_$S('IBSRC:"NOT ",1:"")_"INCLUDED"
155 F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
156 ;
157 S IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
158 Q
159 ;
160TYPE(SEL) ; Returns a string with the type of receivables (description)
161 ; selected or NULL if ALL receivable type have been selected.
162 ; SEL - User input for the parameter "Type of Receivable"
163 ;
164 N TYPE,I,X
165 I SEL="1,2,3," Q ""
166 S TYPE="",X="EMERGENCY/HUMANITARIAN^INELIGIBLE^C-MEANS TEST & RX COPAY"
167 F I=2:1:($L(SEL,",")-1) D
168 . S TYPE=TYPE_$S(I=($L(SEL,",")-1)&(TYPE'=""):" AND ",1:", ")
169 . S TYPE=TYPE_$P(X,"^",+$P(SEL,",",I))
170 S $E(TYPE,1)=""
171 ;
172 Q TYPE
173 ;
174HDR2 ; - Write bill sub-header.
175 W ! I IBSTA="B" W !,$S(IB=16:"ACTIVE",1:"SUSPENDED")
176 W ! I IBSTA="B" W $S(IB=16:"======",1:"=========")
177 W:IBSH ?26,"COM" W ?30,"Last",?40,"Current",?51,"Principal"
178 W !,"Category",?13,"Bill Number",?26,"REF"
179 W ?30,"Payment",?40,"Balance",?51,"Balance",?62,"Interest",?72,"Admin."
180 W !,$$DASH(80,1)
181 Q
182 ;
183TOT ; - Write balance total for patient.
184 N I,J
185 I IBCNT>1 W ! F I=40,51,62,72 W ?I,$E("---------",1,$S(I>60:8,1:9))
186 W:IBCNT'>1 !
187 W !,"Account Balance: $"_$FN($P(IBP,"^",10),",",2)
188 I IBCNT'>1 Q
189 S J=1 F I=39,50,60,70 W ?I,$J($FN($P(IBTOT,"^",J),",",2),10) S J=J+1
190 Q
191 ;
192DASH(X,Y) ; - Return a dashed line.
193 Q $TR($J("",X)," ",$S(Y:"-",1:"="))
194 ;
195ELIG(X) ; - Return eligibility code name.
196 ; X - Eligibility codes separated by semi-collon (;)
197 ;
198 N ELIG,I
199 S ELIG="" F I=1:1:$L(X,";") D
200 . I '$P(X,";",I) Q
201 . S ELIG=ELIG_", "_$E($P($G(^DIC(8,+$P(X,";",I),0)),U),1,20)
202 S $E(ELIG,1,2)=""
203 ;
204 Q ELIG
205 ;
206INFO(X) ; - Return the patient Additional Information about the Patient Accout
207 ; X - Flags representing the observations
208 ;
209 N INFO,I
210 S INFO="" F I=1:1:$L(X) D
211 . I $E(X,I)="V" S INFO=INFO_", '*' - VA EMPLOYEE"
212 . I $E(X,I)="R" S INFO=INFO_", REFERRED TO RC"
213 . I $E(X,I)="D" S INFO=INFO_", REFERRED TO DMC"
214 . I $E(X,I)="T" S INFO=INFO_", REFERRED TO TOP"
215 . I $E(X,I)="P" S INFO=INFO_", UNDER REPAYMENT PLAN"
216 . I $E(X,I)="F" S INFO=INFO_", UNDER DEFAULTED REPAYMENT PLAN"
217 S $E(INFO,1,2)=""
218 ;
219 Q INFO
220 ;
221SSN(X) ; - Format the SSN.
222 Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
223 ;
224PAUSE ; - Page break.
225 I $E(IOST,1,2)'="C-" Q
226 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
227 F IBX=$Y:1:(IOSL-3) W !
228 S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
229 Q
Note: See TracBrowser for help on using the repository browser.