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

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

initial load of FOIAVistA 6/30/08 version

File size: 9.5 KB
Line 
1IBJDI41 ;ALB/CPM - PATIENTS WITH UNIDENTIFIED INSURANCE (CONT'D) ; 17-DEC-96
2 ;;2.0;INTEGRATED BILLING;**98,100,118**;21-MAR-94
3 ;
4EN ; - Entry point from IBJDI4.
5 ;
6 ; - Find inpatients treated within the user-specified date range.
7 S IBD=IBBDT-.01 F S IBD=$O(^DGPM("ATT3",IBD)) Q:'IBD!(IBD\1>IBEDT) D Q:IBQ
8 .S IBPM=0 F S IBPM=$O(^DGPM("ATT3",IBD,IBPM)) Q:'IBPM D Q:IBQ
9 ..I IBPM#100=0 S IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report") Q:IBQ
10 ..S IBPMD=$G(^DGPM(IBPM,0)) I 'IBPMD Q
11 ..I IBSORT S IBDIV=$$DIV^IBJDI21(1,+$P(IBPMD,U,6)) Q:'$D(IB(IBDIV))
12 ..S DFN=+$P(IBPMD,U,3) Q:'DFN
13 ..;
14 ..; - Process patient.
15 ..I '$D(^TMP("IBJDI41",$J,DFN)) D PROC(DFN,IBD\1,"*")
16 ;
17 I IBQ G ENQ
18 ;
19 ; - Find outpatients treated within the user-specified date range.
20 D CLOSE^IBSDU(.IBQUERY)
21 D OUTPT^IBJDI21("",IBBDT,IBEDT,"S:IBQ SDSTOP=1 I 'IBQ,$$ENCHK^IBJDI5(Y0) D ENC^IBJDI41(Y0)","Patients with Unidentified Insurance Report",.IBQ,"IBJDI41",.IBQUERY)
22 D CLOSE^IBSDU(.IBQUERY)
23 ;
24 I IBQ G ENQ
25 ;
26 I IBRPT'="D" G PRT
27 ;
28 ; - Find data required for the report.
29 S DFN=0 F S DFN=$O(^TMP("IBJDI41",$J,DFN)) Q:'DFN S IBX=^(DFN) D Q:IBQ
30 .I IBSEL=0,$P(IBX,U,4)'="*" Q
31 .I DFN#100=0 S IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report") Q:IBQ
32 .;
33 .; - Set patient eligibilities for report.
34 .D ELIG^VADPT S IBELIG=+$G(VAEL(1))_";"
35 .I +IBELIG>0 S X=0 F S X=$O(VAEL(1,X)) Q:'X S IBELIG=IBELIG_X_";"
36 .;
37 .; - Set up detailed information to appear on the report.
38 .S IBDN=$G(^DPT(DFN,0)),IBPAT=$P(IBDN,U)_$P(IBX,U,2)
39 .S IBPH=$P($G(^DPT(DFN,.13)),U,1,2),IBSEL1=$P(IBX,U,3)
40 .S IBDOD=$S(+$G(^DPT(DFN,.35)):$$DAT1^IBOUTL(+$G(^(.35))\1),1:"")
41 .F X=1:1 S X1=$P(IBSEL1,",",X) Q:X1="" D
42 ..S ^TMP("IBJDI42",$J,$P(IBX,U),X1,IBPAT_"@@"_DFN)=$P(IBDN,U,9)_U_$P(IBPH,U)_U_$P(IBPH,U,2)_U_$S(+IBELIG>0:IBELIG,1:"")_U_$P(IBX,U,4)_U_IBDOD_U_$S(IBRMK:$P(IBDN,U,10),1:"")
43 .;
44 .K VA,VAEL,VAERR
45 ;
46 I IBQ G ENQ
47 ;
48PRT ; - Print the reports.
49 ;
50 ; - Extract summary data.
51 I $G(IBXTRACT) D G ENQ
52 .F X="BILL","DEC","HMO","IND","MEDC","MEDG","NO","NULL","TOT","UNK","YES" S IB(X)=$G(IB("ALL",X))
53 .D E^IBJDE(4,0)
54 ;
55 S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
56 S IBDIV="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D Q:IBQ
57 .I IBRPT="D" D DET
58 .I 'IBQ D SUM,PAUSE
59 ;
60ENQ Q
61 ;
62ENC(IBOED) ; - Encounter extract for all patients loop.
63 ; Input: IBOED = Outpatient encounter in file #409.68
64 ; Pre-set variables IB array, IBSORT also required.
65 ;
66 I IBSORT S IBDIV=$$DIV^IBJDI21(0,+$P(IBOED,U,11)) Q:'$D(IB(IBDIV))
67 D PROC(+$P(IBOED,U,2),+IBOED\1,"") ; Process patient.
68 Q
69 ;
70PROC(DFN,IBINDT,IBIPC) ; - Process each specific patient.
71 ; Input: DFN = Pointer to the patient in file #2
72 ; IBINDT = Encounter or discharge date
73 ; IBIPC = Inpatient treatment marker
74 ; ("*"=Had inpat. treatment, null=No inpat. treatment)
75 ;
76 ; Pre-set variables IB array, IBDIV, IBRPT, IBSEL also required.
77 ;
78 I $$TESTP^IBJDI1(DFN) Q ; Test patient.
79 D ELIG^VADPT I 'VAEL(4) G PRCQ ; Patient is not a vet.
80 ;
81 ; - Find 'Covered by Insurance' indicator and set flags.
82 S IBINSC="",IBSEL1=$S(IBSEL=0:"0,",1:""),IBX=$P($G(^DPT(DFN,.31)),U,11)
83 I IBX="Y"!(IBX="N") D
84 .I IBX="Y" D
85 ..S IB(IBDIV,"YES")=IB(IBDIV,"YES")+1 S:IBSEL[1 IBSEL1=IBSEL1_"1,"
86 .E S IB(IBDIV,"NO")=IB(IBDIV,"NO")+1 S:IBSEL[7 IBSEL1=IBSEL1_"7,"
87 .;
88 .S (IBOUTP,IBWNR)=1 D ^IBCNS Q:'IBINS F X=0:1:4 S IBFL(X)=0
89 .S X=0 F S X=$O(IBDD(X)) Q:'X D
90 ..I IBRPT="D",IBSEL'=0 S IBINSC=IBINSC_X_";"
91 ..I $P($G(^DIC(36,X,0)),U,2)'="N",'IBFL(0) D
92 ...S IB(IBDIV,"BILL")=IB(IBDIV,"BILL")+1,IBFL(0)=1
93 ...I IBSEL[2 S IBSEL1=IBSEL1_"2,"
94 ..S IBTYP=$$TYPE^IBJDI4(IBDD(X))
95 ..I IBTYP=1,'IBFL(1) D
96 ...S IB(IBDIV,"HMO")=IB(IBDIV,"HMO")+1,IBFL(1)=1
97 ...I IBSEL[3 S IBSEL1=IBSEL1_"3,"
98 ..I IBTYP=2,'IBFL(2) D
99 ...S IB(IBDIV,"MEDC")=IB(IBDIV,"MEDC")+1,IBFL(2)=1
100 ...I IBSEL[4 S IBSEL1=IBSEL1_"4,"
101 ..I IBTYP=3,'IBFL(3) D
102 ...S IB(IBDIV,"MEDG")=IB(IBDIV,"MEDG")+1,IBFL(3)=1
103 ...I IBSEL[5 S IBSEL1=IBSEL1_"5,"
104 ..I IBTYP=4,'IBFL(4) D
105 ...S IB(IBDIV,"IND")=IB(IBDIV,"IND")+1,IBFL(4)=1
106 ...I IBSEL[6 S IBSEL1=IBSEL1_"6,"
107 I IBX="U" D
108 .S IB(IBDIV,"UNK")=IB(IBDIV,"UNK")+1 S:IBSEL[8 IBSEL1=IBSEL1_"8,"
109 I IBX="" D
110 .S IB(IBDIV,"NULL")=IB(IBDIV,"NULL")+1 S:IBSEL[9 IBSEL1=IBSEL1_"9,"
111 I IBRPT="D",IBSEL=0,(IBX="U"!(IBX="")) S IBINSC="*"
112 ;
113 ; - Set patient index and 'total patients' accumulator.
114 S ^TMP("IBJDI41",$J,DFN)=IBDIV_U_$S(IBRPT="D":IBIPC_U_IBSEL1_U_IBINSC,1:"")
115 S IB(IBDIV,"TOT")=IB(IBDIV,"TOT")+1
116 I +$G(^DPT(DFN,.35)) S IB(IBDIV,"DEC")=IB(IBDIV,"DEC")+1 ; Deceased.
117 ;
118PRCQ K IBDD,IBFL,IBINS,IBINSC,IBOUTP,IBTYP,IBWNR,IBX,VA,VAERR,VAEL,X
119 Q
120 ;
121DIV(X) ; - Return division name.
122 S Y=$P($G(^DG(40.8,X,0)),U) I Y="" S Y=0
123 Q Y
124 ;
125DET ; - Print the detailed report.
126 I IBSEL=0,'$D(^TMP("IBJDI42",$J,IBDIV,0)) S IBX=0 D HDET W !!,"There were no ",$$TITLE^IBJDI4(0)," during this period." G DETQ
127 I IBSEL'=0 F X=1:1 S IBX=$P(IBSEL,",",X) Q:IBX="" D
128 .I '$D(^TMP("IBJDI42",$J,IBDIV,IBX)) S IBPAG=0 D HDET W !!,"There were no ",$$TITLE^IBJDI4(IBX)," during this period."
129 ;
130 S IBX="" F S IBX=$O(^TMP("IBJDI42",$J,IBDIV,IBX)) Q:IBX="" D Q:IBQ
131 .S IBPAG=0 D HDET Q:IBQ
132 .S IBX1="" F S IBX1=$O(^TMP("IBJDI42",$J,IBDIV,IBX,IBX1)) Q:IBX1="" S IBX2=^(IBX1) D Q:IBQ
133 ..I $Y>(IOSL-3) D PAUSE Q:IBQ D HDET Q:IBQ
134 ..W $P(IBX1,"@@"),?27,$$SSN($P(IBX2,U)),?41,$E($P(IBX2,U,2),1,15),?58,$P(IBX2,U,3)
135 ..S IBELIG=$P(IBX2,U,4) W ?80,$$ELIG(+IBELIG)
136 ..S IBINSC=$P(IBX2,U,5) W ?102,$$INSC(+IBINSC),?124,$P(IBX2,U,6),!
137 ..I IBRMK,$P(IBX2,U,7)]"" W ?2,"Remarks: ",$P(IBX2,U,7)
138 ..I '$P(IBELIG,";",2),'$P(IBINSC,";",2),$P(IBX2,U,7)]"" W ! Q
139 ..F X=2:1 Q:'$P(IBELIG,";",X)&('$P(IBINSC,";",X)) D
140 ...W ?80,$$ELIG($P(IBELIG,";",X)),?102,$$INSC($P(IBINSC,";",X)),!
141 ;
142DETQ I 'IBQ D PAUSE
143 Q
144 ;
145HDET ; - Write the detail report header.
146 W @IOF,*13 S IBPAG=$G(IBPAG)+1
147 W !,$$TITLE^IBJDI4(IBX),$S(IBDIV'="ALL":" for "_IBDIV,1:""),?80,"Run Date: ",IBRUN,?123,"Page: ",IBPAG
148 W !,"Patients treated in the period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," NOTE: *=Had inpatient care, +=Billable insurance"
149 W !!?45,"Home",?62,"Work",?124,"Date of"
150 W !,"Patient",?27,"SSN",?41,"Phone Number",?58,"Phone Number",?80,"Eligibility",?102,"Insurance",?125,"Death"
151 W !,$$DASH(132),!!
152 S IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report")
153 Q
154 ;
155SUM ; - Print the summary report.
156 W @IOF,*13 S IBPAG=$G(IBPAG)+1
157 W !!?26,"PATIENT INSURANCE STATISTICS",!
158 I IBDIV'="ALL" W ?(61-$L(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
159 E W ?33,"SUMMARY REPORT"
160 W !!?19,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
161 W !!?24,"Run Date: ",IBRUN,!?20,$$DASH(40),!!
162 ;
163 S IBPER(1)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"YES")/IB(IBDIV,"TOT")*100),0,2)
164 S IBPER(2)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"TOT")*100),0,2)
165 S IBPER(3)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"YES")*100),0,2)
166 S IBPER(4)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"TOT")*100),0,2)
167 S IBPER(5)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"YES")*100),0,2)
168 S IBPER(6)=$J($S('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"BILL")*100),0,2)
169 S IBPER(7)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"TOT")*100),0,2)
170 S IBPER(8)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"YES")*100),0,2)
171 S IBPER(9)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"TOT")*100),0,2)
172 S IBPER(10)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"YES")*100),0,2)
173 S IBPER(11)=$J($S('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"BILL")*100),0,2)
174 S IBPER(12)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"IND")/IB(IBDIV,"TOT")*100),0,2)
175 S IBPER(13)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NO")/IB(IBDIV,"TOT")*100),0,2)
176 S IBPER(14)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"UNK")/IB(IBDIV,"TOT")*100),0,2)
177 S IBPER(15)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NULL")/IB(IBDIV,"TOT")*100),0,2)
178 S IBPER(16)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
179 W ?22,"Number of Patients Treated:",?50,$J(IB(IBDIV,"TOT"),5)
180 W !?9,"Number of Patients Covered by Insurance:",?50,$J(IB(IBDIV,"YES"),5)," (",IBPER(1),"%)"
181 W !?3,"No. of Patients Covered by Billable Insurance:",?50,$J(IB(IBDIV,"BILL"),5)," (",IBPER(2),"%-",IBPER(3),"%)*"
182 W !?12,"Number of Patients Covered by an HMO:",?50,$J(IB(IBDIV,"HMO"),5)," (",IBPER(4),"%-",IBPER(5),"%-",IBPER(6),"%)**"
183 W !?10,"Number of Patients Covered by Medicare:",?50,$J(IB(IBDIV,"MEDC"),5)," (",IBPER(7),"%-",IBPER(8),"%)*"
184 W !?11,"Number of Patients Covered by Medigap:",?50,$J(IB(IBDIV,"MEDG"),5)," (",IBPER(9),"%-",IBPER(10),"%-",IBPER(11),"%)**"
185 W !?2,"No. of Patients Covered by an Indemnity Policy:",?50,$J(IB(IBDIV,"IND"),5)," (",IBPER(12),"%)"
186 W !?5,"Number of Patients Not Covered by Insurance:",?50,$J(IB(IBDIV,"NO"),5)," (",IBPER(13),"%)"
187 W !?7,"Number of Patients with Unknown Insurance:",?50,$J(IB(IBDIV,"UNK"),5)," (",IBPER(14),"%)"
188 W !," No. of Patients w/Insurance Question Unanswered:",?50,$J(IB(IBDIV,"NULL"),5)," (",IBPER(15),"%)"
189 W !?21,"Number of Deceased Patients:",?50,$J(IB(IBDIV,"DEC"),5)," (",IBPER(16),"%)"
190 W !!," *(% from patients treated-% from patients with insurance)"
191 W !,"**(% from patients treated-% from patients w/ins-% from patients w/billable ins)"
192 Q
193 ;
194DASH(X) ; - Return a dashed line.
195 Q $TR($J("",X)," ","=")
196 ;
197ELIG(X) ; - Return eligibility code name.
198 Q $E($P($G(^DIC(8,+X,0)),U),1,20)
199 ;
200INSC(X) ; - Return insurance company.
201 S X=$G(^DIC(36,+X,0))
202 Q $E($P(X,U),1,20)_$S($P(X,U,2)["Y"!($P(X,U,2)["*"):"+",1:"")
203 ;
204PAUSE ; - Page break.
205 I $E(IOST,1,2)'="C-" Q
206 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
207 F IBX=$Y:1:(IOSL-3) W !
208 S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
209 Q
210 ;
211SSN(X) ; - Format the SSN.
212 Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
Note: See TracBrowser for help on using the repository browser.