IBJDI41 ;ALB/CPM - PATIENTS WITH UNIDENTIFIED INSURANCE (CONT'D) ;17-DEC-96
;;2.0;INTEGRATED BILLING;**98,100,118,528,771**;21-MAR-94;Build 26
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; - Entry point from IBJDI4.
;
; - Find inpatients treated within the user-specified date range.
N IBDCNT,IBFEED S IBDCNT=0 ;IB*771/DTG new var's
I IOST["C-" S IBFEED=21
E S IBFEED=50 ; IB*771/DTG correct for excessive line feeds at end of report
I '$D(ZTQUEUED)&($E(IOST,1,2)="C-") W !,"Identify Patients "
S IBD=IBBDT-.01 F S IBD=$O(^DGPM("ATT3",IBD)) Q:'IBD!(IBD\1>IBEDT) D Q:IBQ
.; IB*771/DTG check for 'dots'
.I '$D(ZTQUEUED)&($E(IOST,1,2)="C-") S IBDCNT=IBDCNT+1 I IBDCNT#500=0 W "."
.S IBPM=0 F S IBPM=$O(^DGPM("ATT3",IBD,IBPM)) Q:'IBPM D Q:IBQ
..I IBPM#100=0 S IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report") Q:IBQ
..S IBPMD=$G(^DGPM(IBPM,0)) I 'IBPMD Q
..I IBSORT S IBDIV=$$DIV^IBJDI21(1,+$P(IBPMD,U,6)) Q:'$D(IB(IBDIV))
..S DFN=+$P(IBPMD,U,3) Q:'DFN
..;
..; - Process patient.
..I '$D(^TMP("IBJDI41",$J,DFN)) D PROC(DFN,IBD\1,"*")
;
I IBQ G ENQ
;
; - Find outpatients treated within the user-specified date range.
D CLOSE^IBSDU(.IBQUERY)
I '$D(ZTQUEUED)&($E(IOST,1,2)="C-") W !,"Gathering schedule info" ;IB*771/DTG message before schedule check
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)
D CLOSE^IBSDU(.IBQUERY)
;
I IBQ G ENQ
;
I IBRPT'="D" G PRT
;
; - Find data required for the report.
S IBDCNT=0 ; IB*771/DTG count for 'dot' display
I '$D(ZTQUEUED)&($E(IOST,1,2)="C-") W !,"Compiling Detail "
S DFN=0 F S DFN=$O(^TMP("IBJDI41",$J,DFN)) Q:'DFN S IBX=^(DFN) D Q:IBQ
.I '$D(ZTQUEUED)&($E(IOST,1,2)="C-") S IBDCNT=IBDCNT+1 I IBDCNT#1000=0 W "." ; IB*771/DTG count for 'dot' display
.I IBSEL=0,$P(IBX,U,4)'="*" Q
.I DFN#100=0 S IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report") Q:IBQ
.;
.; - Set patient eligibilities for report.
.D ELIG^VADPT S IBELIG=+$G(VAEL(1))_";"
.I +IBELIG>0 S X=0 F S X=$O(VAEL(1,X)) Q:'X S IBELIG=IBELIG_X_";"
.;
.; - Set up detailed information to appear on the report.
.S IBDN=$G(^DPT(DFN,0)),IBPAT=$P(IBDN,U)_$P(IBX,U,2)
.S IBPH=$P($G(^DPT(DFN,.13)),U,1,2),IBSEL1=$P(IBX,U,3)
.S IBDOD=$S(+$G(^DPT(DFN,.35)):$$DAT1^IBOUTL(+$G(^(.35))\1),1:"")
.F X=1:1 S X1=$P(IBSEL1,",",X) Q:X1="" D
..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:"")
.;
.K VA,VAEL,VAERR
;
I IBQ G ENQ
;
PRT ; - Print the reports.
;
N IBDNXT S IBDNXT="" ;IB*771/DTG for print loop management
; - Extract summary data.
I $G(IBXTRACT) D G ENQ
.F X="BILL","DEC","HMO","IND","MEDC","MEDG","NO","NULL","TOT","UNK","YES" S IB(X)=$G(IB("ALL",X))
.D E^IBJDE(4,0)
;
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
I IBOUT="E" W ! ; IB*771/DTG add additional line feed for excel at start of print
;S IBDIV="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D Q:IBQ
S IBDIV="",IBDXT="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" S IBDNXT=$O(IB(IBDIV)) D Q:IBQ ;IB*771/DTG add check for next division
.I IBRPT="D" D DET
.;I IBOUT="E" D EXCSUM,PAUSE Q
.I IBOUT="E" D EXCSUM D:IBDNXT'="" PAUSE Q ;IB*771/DTG check for next division
.;I 'IBQ D SUM,PAUSE
.I 'IBQ D SUM D:IBDNXT'="" PAUSE ;IB*771/DTG check for next division
I '$G(IBQ) D EOR,PAUSE ;IB*771/DTG print EOR message
;
ENQ Q
;
EOR ; IB*771/DTG end of report
W ! W:$G(IBOUT)="R" ?30 W "*** END OF REPORT ***",!
Q
;
ENC(IBOED) ; - Encounter extract for all patients loop.
; Input: IBOED = Outpatient encounter in file #409.68
; Pre-set variables IB array, IBSORT also required.
;
I IBSORT S IBDIV=$$DIV^IBJDI21(0,+$P(IBOED,U,11)) Q:'$D(IB(IBDIV))
D PROC(+$P(IBOED,U,2),+IBOED\1,"") ; Process patient.
Q
;
PROC(DFN,IBINDT,IBIPC) ; - Process each specific patient.
; Input: DFN = Pointer to the patient in file #2
; IBINDT = Encounter or discharge date
; IBIPC = Inpatient treatment marker
; ("*"=Had inpat. treatment, null=No inpat. treatment)
;
; Pre-set variables IB array, IBDIV, IBRPT, IBSEL also required.
;
I $$TESTP^IBJDI1(DFN) Q ; Test patient.
D ELIG^VADPT I 'VAEL(4) G PRCQ ; Patient is not a vet.
;
; - Find 'Covered by Insurance' indicator and set flags.
S IBINSC="",IBSEL1=$S(IBSEL=0:"0,",1:""),IBX=$P($G(^DPT(DFN,.31)),U,11)
I IBX="Y"!(IBX="N") D
.I IBX="Y" D
..S IB(IBDIV,"YES")=IB(IBDIV,"YES")+1 S:IBSEL[1 IBSEL1=IBSEL1_"1,"
.E S IB(IBDIV,"NO")=IB(IBDIV,"NO")+1 S:IBSEL[7 IBSEL1=IBSEL1_"7,"
.;
.S (IBOUTP,IBWNR)=1 D ^IBCNS Q:'IBINS F X=0:1:4 S IBFL(X)=0
.S X=0 F S X=$O(IBDD(X)) Q:'X D
..I IBRPT="D",IBSEL'=0 S IBINSC=IBINSC_X_";"
..I $P($G(^DIC(36,X,0)),U,2)'="N",'IBFL(0) D
...S IB(IBDIV,"BILL")=IB(IBDIV,"BILL")+1,IBFL(0)=1
...I IBSEL[2 S IBSEL1=IBSEL1_"2,"
..S IBTYP=$$TYPE^IBJDI4(IBDD(X))
..I IBTYP=1,'IBFL(1) D
...S IB(IBDIV,"HMO")=IB(IBDIV,"HMO")+1,IBFL(1)=1
...I IBSEL[3 S IBSEL1=IBSEL1_"3,"
..I IBTYP=2,'IBFL(2) D
...S IB(IBDIV,"MEDC")=IB(IBDIV,"MEDC")+1,IBFL(2)=1
...I IBSEL[4 S IBSEL1=IBSEL1_"4,"
..I IBTYP=3,'IBFL(3) D
...S IB(IBDIV,"MEDG")=IB(IBDIV,"MEDG")+1,IBFL(3)=1
...I IBSEL[5 S IBSEL1=IBSEL1_"5,"
..I IBTYP=4,'IBFL(4) D
...S IB(IBDIV,"IND")=IB(IBDIV,"IND")+1,IBFL(4)=1
...I IBSEL[6 S IBSEL1=IBSEL1_"6,"
I IBX="U" D
.S IB(IBDIV,"UNK")=IB(IBDIV,"UNK")+1 S:IBSEL[8 IBSEL1=IBSEL1_"8,"
I IBX="" D
.S IB(IBDIV,"NULL")=IB(IBDIV,"NULL")+1 S:IBSEL[9 IBSEL1=IBSEL1_"9,"
I IBRPT="D",IBSEL=0,(IBX="U"!(IBX="")) S IBINSC="*"
;
; - Set patient index and 'total patients' accumulator.
S ^TMP("IBJDI41",$J,DFN)=IBDIV_U_$S(IBRPT="D":IBIPC_U_IBSEL1_U_IBINSC,1:"")
S IB(IBDIV,"TOT")=IB(IBDIV,"TOT")+1
I +$G(^DPT(DFN,.35)) S IB(IBDIV,"DEC")=IB(IBDIV,"DEC")+1 ; Deceased.
;
PRCQ K IBDD,IBFL,IBINS,IBINSC,IBOUTP,IBTYP,IBWNR,IBX,VA,VAERR,VAEL,X
Q
;
DIV(X) ; - Return division name.
S Y=$P($G(^DG(40.8,X,0)),U) I Y="" S Y=0
Q Y
;
DET ; - Print the detailed report.
;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
I IBSEL=0,'$D(^TMP("IBJDI42",$J,IBDIV,0)) S IBPAG=0,IBX=0 D HDET W !!,"There were no ",$$TITLE^IBJDI4(0)," during this period." G DETQ ;IB*771/DTG add initialize of page number
I IBSEL'=0 F X=1:1 S IBX=$P(IBSEL,",",X) Q:IBX="" D
.I '$D(^TMP("IBJDI42",$J,IBDIV,IBX)) S IBPAG=0 D HDET W !!,"There were no ",$$TITLE^IBJDI4(IBX)," during this period."
;
I IBOUT="E" D EXCHDR
S IBX="" F S IBX=$O(^TMP("IBJDI42",$J,IBDIV,IBX)) Q:IBX="" D Q:IBQ
.I IBOUT="R" S IBPAG=0 D HDET Q:IBQ
.S IBX1="" F S IBX1=$O(^TMP("IBJDI42",$J,IBDIV,IBX,IBX1)) Q:IBX1="" S IBX2=^(IBX1) D Q:IBQ
..I IBOUT="E" D EXCOUT Q
..I $Y>(IOSL-3) D PAUSE Q:IBQ D HDET Q:IBQ
..W $P(IBX1,"@@"),?27,$$SSN($P(IBX2,U)),?41,$E($P(IBX2,U,2),1,15),?58,$P(IBX2,U,3)
..S IBELIG=$P(IBX2,U,4) W ?80,$$ELIG(+IBELIG)
..S IBINSC=$P(IBX2,U,5) W ?102,$$INSC(+IBINSC),?124,$P(IBX2,U,6),!
..I IBRMK,$P(IBX2,U,7)]"" W ?2,"Remarks: ",$P(IBX2,U,7)
..I '$P(IBELIG,";",2),'$P(IBINSC,";",2),$P(IBX2,U,7)]"" W ! Q
..F X=2:1 Q:'$P(IBELIG,";",X)&('$P(IBINSC,";",X)) D
...W ?80,$$ELIG($P(IBELIG,";",X)),?102,$$INSC($P(IBINSC,";",X)),!
;
DETQ I 'IBQ D PAUSE
Q
;
EXCOUT ; OUTPUT EXCEL FORMAT
W !,$P(IBX1,"@@")_U_$$SSN($P(IBX2,U))_U_$E($P(IBX2,U,2),1,15)_U_$P(IBX2,U,3)_U
S IBELIG=$P(IBX2,U,4) W $$ELIG(+IBELIG)_U
S IBINSC=$P(IBX2,U,5) W $$INSC(+IBINSC)_U_$P(IBX2,U,6)_U
I IBRMK,$P(IBX2,U,7)]"" W $P(IBX2,U,7)_U
F X=2:1 Q:'$P(IBELIG,";",X)&('$P(IBINSC,";",X)) D
.W $$ELIG($P(IBELIG,";",X))_U_$$INSC($P(IBINSC,";",X))
Q
;
HDET ; - Write the detail report header.
I IBOUT="E" D EXCHDR Q ;IB*771/DTG use excel header for excel
W @IOF,*13 S IBPAG=$G(IBPAG)+1
W !,$$TITLE^IBJDI4(IBX),$S(IBDIV'="ALL":" for "_IBDIV,1:""),?80,"Run Date: ",IBRUN,?123,"Page: ",IBPAG
W !,"Patients treated in the period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," NOTE: *=Had inpatient care, +=Billable insurance"
W !!?45,"Home",?62,"Work",?124,"Date of"
W !,"Patient",?27,"SSN",?41,"Phone Number",?58,"Phone Number",?80,"Eligibility",?102,"Insurance",?125,"Death"
W !,$$DASH(132),!!
S IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report")
Q
;
EXCHDR ; Write the excel header.
W !,$$TITLE^IBJDI4(IBX),$S(IBDIV'="ALL":" for "_IBDIV,1:"")
W !,"Run Date: ",IBRUN
W !,"Patients treated in the period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," NOTE: *=Had inpatient care, +=Billable insurance"
W !,"Patient"_U_"SSN"_U_"Home Phone Number"_U_"Work Phone Number"_U_"Eligibility"_U_"Insurance"_U_"Date of Death"
Q
;
SUM ; - Print the summary report.
W @IOF,*13 S IBPAG=$G(IBPAG)+1
W !!?26,"PATIENT INSURANCE STATISTICS",!
I IBDIV'="ALL" W ?(61-$L(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
E W ?33,"SUMMARY REPORT"
W !!?19,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
W !!?24,"Run Date: ",IBRUN,!?20,$$DASH(40),!!
;
S IBPER(1)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"YES")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(2)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(3)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"YES")*100),0,2)
S IBPER(4)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(5)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"YES")*100),0,2)
S IBPER(6)=$J($S('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"BILL")*100),0,2)
S IBPER(7)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(8)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"YES")*100),0,2)
S IBPER(9)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(10)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"YES")*100),0,2)
S IBPER(11)=$J($S('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"BILL")*100),0,2)
S IBPER(12)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"IND")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(13)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NO")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(14)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"UNK")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(15)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NULL")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(16)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
W ?22,"Number of Patients Treated:",?50,$J(IB(IBDIV,"TOT"),5)
W !?9,"Number of Patients Covered by Insurance:",?50,$J(IB(IBDIV,"YES"),5)," (",IBPER(1),"%)"
W !?3,"No. of Patients Covered by Billable Insurance:",?50,$J(IB(IBDIV,"BILL"),5)," (",IBPER(2),"%-",IBPER(3),"%)*"
W !?12,"Number of Patients Covered by an HMO:",?50,$J(IB(IBDIV,"HMO"),5)," (",IBPER(4),"%-",IBPER(5),"%-",IBPER(6),"%)**"
W !?10,"Number of Patients Covered by Medicare:",?50,$J(IB(IBDIV,"MEDC"),5)," (",IBPER(7),"%-",IBPER(8),"%)*"
W !?11,"Number of Patients Covered by Medigap:",?50,$J(IB(IBDIV,"MEDG"),5)," (",IBPER(9),"%-",IBPER(10),"%-",IBPER(11),"%)**"
W !?2,"No. of Patients Covered by an Indemnity Policy:",?50,$J(IB(IBDIV,"IND"),5)," (",IBPER(12),"%)"
W !?5,"Number of Patients Not Covered by Insurance:",?50,$J(IB(IBDIV,"NO"),5)," (",IBPER(13),"%)"
W !?7,"Number of Patients with Unknown Insurance:",?50,$J(IB(IBDIV,"UNK"),5)," (",IBPER(14),"%)"
W !," No. of Patients w/Insurance Question Unanswered:",?50,$J(IB(IBDIV,"NULL"),5)," (",IBPER(15),"%)"
W !?21,"Number of Deceased Patients:",?50,$J(IB(IBDIV,"DEC"),5)," (",IBPER(16),"%)"
W !!," *(% from patients treated-% from patients with insurance)"
W !,"**(% from patients treated-% from patients w/ins-% from patients w/billable ins)"
Q
;
EXCSUM ; - Print the summary report in excel format.
W @IOF,*13 S IBPAG=$G(IBPAG)+1
W !!,"PATIENT INSURANCE STATISTICS",!
I IBDIV'="ALL" W ?(61-$L(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
E W ?33,"SUMMARY REPORT"
W !,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
W !,"Run Date: ",IBRUN,!
;
S IBPER(1)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"YES")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(2)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(3)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"YES")*100),0,2)
S IBPER(4)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(5)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"YES")*100),0,2)
S IBPER(6)=$J($S('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"BILL")*100),0,2)
S IBPER(7)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(8)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"YES")*100),0,2)
S IBPER(9)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(10)=$J($S('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"YES")*100),0,2)
S IBPER(11)=$J($S('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"BILL")*100),0,2)
S IBPER(12)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"IND")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(13)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NO")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(14)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"UNK")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(15)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NULL")/IB(IBDIV,"TOT")*100),0,2)
S IBPER(16)=$J($S('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
W "Number of Patients Treated:"_U_$J(IB(IBDIV,"TOT"),5)
W !,"Number of Patients Covered by Insurance:"_U_$J(IB(IBDIV,"YES"),5)," (",IBPER(1),"%)"
W !,"No. of Patients Covered by Billable Insurance:"_U_$J(IB(IBDIV,"BILL"),5)," (",IBPER(2),"%-",IBPER(3),"%)*"
W !,"Number of Patients Covered by an HMO:"_U_$J(IB(IBDIV,"HMO"),5)," (",IBPER(4),"%-",IBPER(5),"%-",IBPER(6),"%)**"
W !,"Number of Patients Covered by Medicare:"_U_$J(IB(IBDIV,"MEDC"),5)," (",IBPER(7),"%-",IBPER(8),"%)*"
W !,"Number of Patients Covered by Medigap:"_U_$J(IB(IBDIV,"MEDG"),5)," (",IBPER(9),"%-",IBPER(10),"%-",IBPER(11),"%)**"
W !,"No. of Patients Covered by an Indemnity Policy:"_U_$J(IB(IBDIV,"IND"),5)," (",IBPER(12),"%)"
W !,"Number of Patients Not Covered by Insurance:"_U_$J(IB(IBDIV,"NO"),5)," (",IBPER(13),"%)"
W !,"Number of Patients with Unknown Insurance:"_U_$J(IB(IBDIV,"UNK"),5)," (",IBPER(14),"%)"
W !,"No. of Patients w/Insurance Question Unanswered:"_U_$J(IB(IBDIV,"NULL"),5)," (",IBPER(15),"%)"
W !,"Number of Deceased Patients:"_U_$J(IB(IBDIV,"DEC"),5)," (",IBPER(16),"%)"
W !!," *(% from patients treated-% from patients with insurance)"
W !,"**(% from patients treated-% from patients w/ins-% from patients w/billable ins)"
Q
;
DASH(X) ; - Return a dashed line.
Q $TR($J("",X)," ","=")
;
ELIG(X) ; - Return eligibility code name.
Q $E($P($G(^DIC(8,+X,0)),U),1,20)
;
INSC(X) ; - Return insurance company.
S X=$G(^DIC(36,+X,0))
Q $E($P(X,U),1,20)_$S($P(X,U,2)["Y"!($P(X,U,2)["*"):"+",1:"")
;
PAUSE ; - Page break.
I $D(ZTQUEUED) Q ;IB*771/DTG quit if report was queued
I $E(IOST,1,2)'="C-" Q
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
;F IBX=$Y:1:(IOSL-3) W !
F IBX=1:1:(IBFEED-$Y) W ! ;IB*771/DTG stop extra blank lines
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
Q
;
SSN(X) ; - Format the SSN.
Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDI41 15460 printed Sep 23, 2025@19:59:36 Page 2
IBJDI41 ;ALB/CPM - PATIENTS WITH UNIDENTIFIED INSURANCE (CONT'D) ;17-DEC-96
+1 ;;2.0;INTEGRATED BILLING;**98,100,118,528,771**;21-MAR-94;Build 26
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; - Entry point from IBJDI4.
+1 ;
+2 ; - Find inpatients treated within the user-specified date range.
+3 ;IB*771/DTG new var's
NEW IBDCNT,IBFEED
SET IBDCNT=0
+4 IF IOST["C-"
SET IBFEED=21
+5 ; IB*771/DTG correct for excessive line feeds at end of report
IF '$TEST
SET IBFEED=50
+6 IF '$DATA(ZTQUEUED)&($EXTRACT(IOST,1,2)="C-")
WRITE !,"Identify Patients "
+7 SET IBD=IBBDT-.01
FOR
SET IBD=$ORDER(^DGPM("ATT3",IBD))
if 'IBD!(IBD\1>IBEDT)
QUIT
Begin DoDot:1
+8 ; IB*771/DTG check for 'dots'
+9 IF '$DATA(ZTQUEUED)&($EXTRACT(IOST,1,2)="C-")
SET IBDCNT=IBDCNT+1
IF IBDCNT#500=0
WRITE "."
+10 SET IBPM=0
FOR
SET IBPM=$ORDER(^DGPM("ATT3",IBD,IBPM))
if 'IBPM
QUIT
Begin DoDot:2
+11 IF IBPM#100=0
SET IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report")
if IBQ
QUIT
+12 SET IBPMD=$GET(^DGPM(IBPM,0))
IF 'IBPMD
QUIT
+13 IF IBSORT
SET IBDIV=$$DIV^IBJDI21(1,+$PIECE(IBPMD,U,6))
if '$DATA(IB(IBDIV))
QUIT
+14 SET DFN=+$PIECE(IBPMD,U,3)
if 'DFN
QUIT
+15 ;
+16 ; - Process patient.
+17 IF '$DATA(^TMP("IBJDI41",$JOB,DFN))
DO PROC(DFN,IBD\1,"*")
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+18 ;
+19 IF IBQ
GOTO ENQ
+20 ;
+21 ; - Find outpatients treated within the user-specified date range.
+22 DO CLOSE^IBSDU(.IBQUERY)
+23 ;IB*771/DTG message before schedule check
IF '$DATA(ZTQUEUED)&($EXTRACT(IOST,1,2)="C-")
WRITE !,"Gathering schedule info"
+24 DO 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)
+25 DO CLOSE^IBSDU(.IBQUERY)
+26 ;
+27 IF IBQ
GOTO ENQ
+28 ;
+29 IF IBRPT'="D"
GOTO PRT
+30 ;
+31 ; - Find data required for the report.
+32 ; IB*771/DTG count for 'dot' display
SET IBDCNT=0
+33 IF '$DATA(ZTQUEUED)&($EXTRACT(IOST,1,2)="C-")
WRITE !,"Compiling Detail "
+34 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("IBJDI41",$JOB,DFN))
if 'DFN
QUIT
SET IBX=^(DFN)
Begin DoDot:1
+35 ; IB*771/DTG count for 'dot' display
IF '$DATA(ZTQUEUED)&($EXTRACT(IOST,1,2)="C-")
SET IBDCNT=IBDCNT+1
IF IBDCNT#1000=0
WRITE "."
+36 IF IBSEL=0
IF $PIECE(IBX,U,4)'="*"
QUIT
+37 IF DFN#100=0
SET IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report")
if IBQ
QUIT
+38 ;
+39 ; - Set patient eligibilities for report.
+40 DO ELIG^VADPT
SET IBELIG=+$GET(VAEL(1))_";"
+41 IF +IBELIG>0
SET X=0
FOR
SET X=$ORDER(VAEL(1,X))
if 'X
QUIT
SET IBELIG=IBELIG_X_";"
+42 ;
+43 ; - Set up detailed information to appear on the report.
+44 SET IBDN=$GET(^DPT(DFN,0))
SET IBPAT=$PIECE(IBDN,U)_$PIECE(IBX,U,2)
+45 SET IBPH=$PIECE($GET(^DPT(DFN,.13)),U,1,2)
SET IBSEL1=$PIECE(IBX,U,3)
+46 SET IBDOD=$SELECT(+$GET(^DPT(DFN,.35)):$$DAT1^IBOUTL(+$GET(^(.35))\1),1:"")
+47 FOR X=1:1
SET X1=$PIECE(IBSEL1,",",X)
if X1=""
QUIT
Begin DoDot:2
+48 SET ^TMP("IBJDI42",$JOB,$PIECE(IBX,U),X1,IBPAT_"@@"_DFN)=$PIECE(IBDN,U,9)_U_$PIECE(IBPH,U)_U_$PIECE(IBPH,U,2)_U_$SELECT(+IBELIG>0:IBELIG,1:"")_U_$PIECE(IBX,U,4)_U_IBDOD_U_$SELECT(IBRMK:$PIECE(IBDN,U,10),1:"")
End DoDot:2
+49 ;
+50 KILL VA,VAEL,VAERR
End DoDot:1
if IBQ
QUIT
+51 ;
+52 IF IBQ
GOTO ENQ
+53 ;
PRT ; - Print the reports.
+1 ;
+2 ;IB*771/DTG for print loop management
NEW IBDNXT
SET IBDNXT=""
+3 ; - Extract summary data.
+4 IF $GET(IBXTRACT)
Begin DoDot:1
+5 FOR X="BILL","DEC","HMO","IND","MEDC","MEDG","NO","NULL","TOT","UNK","YES"
SET IB(X)=$GET(IB("ALL",X))
+6 DO E^IBJDE(4,0)
End DoDot:1
GOTO ENQ
+7 ;
+8 SET IBQ=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+9 ; IB*771/DTG add additional line feed for excel at start of print
IF IBOUT="E"
WRITE !
+10 ;S IBDIV="" F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D Q:IBQ
+11 ;IB*771/DTG add check for next division
SET IBDIV=""
SET IBDXT=""
FOR
SET IBDIV=$ORDER(IB(IBDIV))
if IBDIV=""
QUIT
SET IBDNXT=$ORDER(IB(IBDIV))
Begin DoDot:1
+12 IF IBRPT="D"
DO DET
+13 ;I IBOUT="E" D EXCSUM,PAUSE Q
+14 ;IB*771/DTG check for next division
IF IBOUT="E"
DO EXCSUM
if IBDNXT'=""
DO PAUSE
QUIT
+15 ;I 'IBQ D SUM,PAUSE
+16 ;IB*771/DTG check for next division
IF 'IBQ
DO SUM
if IBDNXT'=""
DO PAUSE
End DoDot:1
if IBQ
QUIT
+17 ;IB*771/DTG print EOR message
IF '$GET(IBQ)
DO EOR
DO PAUSE
+18 ;
ENQ QUIT
+1 ;
EOR ; IB*771/DTG end of report
+1 WRITE !
if $GET(IBOUT)="R"
WRITE ?30
WRITE "*** END OF REPORT ***",!
+2 QUIT
+3 ;
ENC(IBOED) ; - Encounter extract for all patients loop.
+1 ; Input: IBOED = Outpatient encounter in file #409.68
+2 ; Pre-set variables IB array, IBSORT also required.
+3 ;
+4 IF IBSORT
SET IBDIV=$$DIV^IBJDI21(0,+$PIECE(IBOED,U,11))
if '$DATA(IB(IBDIV))
QUIT
+5 ; Process patient.
DO PROC(+$PIECE(IBOED,U,2),+IBOED\1,"")
+6 QUIT
+7 ;
PROC(DFN,IBINDT,IBIPC) ; - Process each specific patient.
+1 ; Input: DFN = Pointer to the patient in file #2
+2 ; IBINDT = Encounter or discharge date
+3 ; IBIPC = Inpatient treatment marker
+4 ; ("*"=Had inpat. treatment, null=No inpat. treatment)
+5 ;
+6 ; Pre-set variables IB array, IBDIV, IBRPT, IBSEL also required.
+7 ;
+8 ; Test patient.
IF $$TESTP^IBJDI1(DFN)
QUIT
+9 ; Patient is not a vet.
DO ELIG^VADPT
IF 'VAEL(4)
GOTO PRCQ
+10 ;
+11 ; - Find 'Covered by Insurance' indicator and set flags.
+12 SET IBINSC=""
SET IBSEL1=$SELECT(IBSEL=0:"0,",1:"")
SET IBX=$PIECE($GET(^DPT(DFN,.31)),U,11)
+13 IF IBX="Y"!(IBX="N")
Begin DoDot:1
+14 IF IBX="Y"
Begin DoDot:2
+15 SET IB(IBDIV,"YES")=IB(IBDIV,"YES")+1
if IBSEL[1
SET IBSEL1=IBSEL1_"1,"
End DoDot:2
+16 IF '$TEST
SET IB(IBDIV,"NO")=IB(IBDIV,"NO")+1
if IBSEL[7
SET IBSEL1=IBSEL1_"7,"
+17 ;
+18 SET (IBOUTP,IBWNR)=1
DO ^IBCNS
if 'IBINS
QUIT
FOR X=0:1:4
SET IBFL(X)=0
+19 SET X=0
FOR
SET X=$ORDER(IBDD(X))
if 'X
QUIT
Begin DoDot:2
+20 IF IBRPT="D"
IF IBSEL'=0
SET IBINSC=IBINSC_X_";"
+21 IF $PIECE($GET(^DIC(36,X,0)),U,2)'="N"
IF 'IBFL(0)
Begin DoDot:3
+22 SET IB(IBDIV,"BILL")=IB(IBDIV,"BILL")+1
SET IBFL(0)=1
+23 IF IBSEL[2
SET IBSEL1=IBSEL1_"2,"
End DoDot:3
+24 SET IBTYP=$$TYPE^IBJDI4(IBDD(X))
+25 IF IBTYP=1
IF 'IBFL(1)
Begin DoDot:3
+26 SET IB(IBDIV,"HMO")=IB(IBDIV,"HMO")+1
SET IBFL(1)=1
+27 IF IBSEL[3
SET IBSEL1=IBSEL1_"3,"
End DoDot:3
+28 IF IBTYP=2
IF 'IBFL(2)
Begin DoDot:3
+29 SET IB(IBDIV,"MEDC")=IB(IBDIV,"MEDC")+1
SET IBFL(2)=1
+30 IF IBSEL[4
SET IBSEL1=IBSEL1_"4,"
End DoDot:3
+31 IF IBTYP=3
IF 'IBFL(3)
Begin DoDot:3
+32 SET IB(IBDIV,"MEDG")=IB(IBDIV,"MEDG")+1
SET IBFL(3)=1
+33 IF IBSEL[5
SET IBSEL1=IBSEL1_"5,"
End DoDot:3
+34 IF IBTYP=4
IF 'IBFL(4)
Begin DoDot:3
+35 SET IB(IBDIV,"IND")=IB(IBDIV,"IND")+1
SET IBFL(4)=1
+36 IF IBSEL[6
SET IBSEL1=IBSEL1_"6,"
End DoDot:3
End DoDot:2
End DoDot:1
+37 IF IBX="U"
Begin DoDot:1
+38 SET IB(IBDIV,"UNK")=IB(IBDIV,"UNK")+1
if IBSEL[8
SET IBSEL1=IBSEL1_"8,"
End DoDot:1
+39 IF IBX=""
Begin DoDot:1
+40 SET IB(IBDIV,"NULL")=IB(IBDIV,"NULL")+1
if IBSEL[9
SET IBSEL1=IBSEL1_"9,"
End DoDot:1
+41 IF IBRPT="D"
IF IBSEL=0
IF (IBX="U"!(IBX=""))
SET IBINSC="*"
+42 ;
+43 ; - Set patient index and 'total patients' accumulator.
+44 SET ^TMP("IBJDI41",$JOB,DFN)=IBDIV_U_$SELECT(IBRPT="D":IBIPC_U_IBSEL1_U_IBINSC,1:"")
+45 SET IB(IBDIV,"TOT")=IB(IBDIV,"TOT")+1
+46 ; Deceased.
IF +$GET(^DPT(DFN,.35))
SET IB(IBDIV,"DEC")=IB(IBDIV,"DEC")+1
+47 ;
PRCQ KILL IBDD,IBFL,IBINS,IBINSC,IBOUTP,IBTYP,IBWNR,IBX,VA,VAERR,VAEL,X
+1 QUIT
+2 ;
DIV(X) ; - Return division name.
+1 SET Y=$PIECE($GET(^DG(40.8,X,0)),U)
IF Y=""
SET Y=0
+2 QUIT Y
+3 ;
DET ; - Print the detailed report.
+1 ;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
+2 ;IB*771/DTG add initialize of page number
IF IBSEL=0
IF '$DATA(^TMP("IBJDI42",$JOB,IBDIV,0))
SET IBPAG=0
SET IBX=0
DO HDET
WRITE !!,"There were no ",$$TITLE^IBJDI4(0)," during this period."
GOTO DETQ
+3 IF IBSEL'=0
FOR X=1:1
SET IBX=$PIECE(IBSEL,",",X)
if IBX=""
QUIT
Begin DoDot:1
+4 IF '$DATA(^TMP("IBJDI42",$JOB,IBDIV,IBX))
SET IBPAG=0
DO HDET
WRITE !!,"There were no ",$$TITLE^IBJDI4(IBX)," during this period."
End DoDot:1
+5 ;
+6 IF IBOUT="E"
DO EXCHDR
+7 SET IBX=""
FOR
SET IBX=$ORDER(^TMP("IBJDI42",$JOB,IBDIV,IBX))
if IBX=""
QUIT
Begin DoDot:1
+8 IF IBOUT="R"
SET IBPAG=0
DO HDET
if IBQ
QUIT
+9 SET IBX1=""
FOR
SET IBX1=$ORDER(^TMP("IBJDI42",$JOB,IBDIV,IBX,IBX1))
if IBX1=""
QUIT
SET IBX2=^(IBX1)
Begin DoDot:2
+10 IF IBOUT="E"
DO EXCOUT
QUIT
+11 IF $Y>(IOSL-3)
DO PAUSE
if IBQ
QUIT
DO HDET
if IBQ
QUIT
+12 WRITE $PIECE(IBX1,"@@"),?27,$$SSN($PIECE(IBX2,U)),?41,$EXTRACT($PIECE(IBX2,U,2),1,15),?58,$PIECE(IBX2,U,3)
+13 SET IBELIG=$PIECE(IBX2,U,4)
WRITE ?80,$$ELIG(+IBELIG)
+14 SET IBINSC=$PIECE(IBX2,U,5)
WRITE ?102,$$INSC(+IBINSC),?124,$PIECE(IBX2,U,6),!
+15 IF IBRMK
IF $PIECE(IBX2,U,7)]""
WRITE ?2,"Remarks: ",$PIECE(IBX2,U,7)
+16 IF '$PIECE(IBELIG,";",2)
IF '$PIECE(IBINSC,";",2)
IF $PIECE(IBX2,U,7)]""
WRITE !
QUIT
+17 FOR X=2:1
if '$PIECE(IBELIG,";",X)&('$PIECE(IBINSC,";",X))
QUIT
Begin DoDot:3
+18 WRITE ?80,$$ELIG($PIECE(IBELIG,";",X)),?102,$$INSC($PIECE(IBINSC,";",X)),!
End DoDot:3
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+19 ;
DETQ IF 'IBQ
DO PAUSE
+1 QUIT
+2 ;
EXCOUT ; OUTPUT EXCEL FORMAT
+1 WRITE !,$PIECE(IBX1,"@@")_U_$$SSN($PIECE(IBX2,U))_U_$EXTRACT($PIECE(IBX2,U,2),1,15)_U_$PIECE(IBX2,U,3)_U
+2 SET IBELIG=$PIECE(IBX2,U,4)
WRITE $$ELIG(+IBELIG)_U
+3 SET IBINSC=$PIECE(IBX2,U,5)
WRITE $$INSC(+IBINSC)_U_$PIECE(IBX2,U,6)_U
+4 IF IBRMK
IF $PIECE(IBX2,U,7)]""
WRITE $PIECE(IBX2,U,7)_U
+5 FOR X=2:1
if '$PIECE(IBELIG,";",X)&('$PIECE(IBINSC,";",X))
QUIT
Begin DoDot:1
+6 WRITE $$ELIG($PIECE(IBELIG,";",X))_U_$$INSC($PIECE(IBINSC,";",X))
End DoDot:1
+7 QUIT
+8 ;
HDET ; - Write the detail report header.
+1 ;IB*771/DTG use excel header for excel
IF IBOUT="E"
DO EXCHDR
QUIT
+2 WRITE @IOF,*13
SET IBPAG=$GET(IBPAG)+1
+3 WRITE !,$$TITLE^IBJDI4(IBX),$SELECT(IBDIV'="ALL":" for "_IBDIV,1:""),?80,"Run Date: ",IBRUN,?123,"Page: ",IBPAG
+4 WRITE !,"Patients treated in the period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," NOTE: *=Had inpatient care, +=Billable insurance"
+5 WRITE !!?45,"Home",?62,"Work",?124,"Date of"
+6 WRITE !,"Patient",?27,"SSN",?41,"Phone Number",?58,"Phone Number",?80,"Eligibility",?102,"Insurance",?125,"Death"
+7 WRITE !,$$DASH(132),!!
+8 SET IBQ=$$STOP^IBOUTL("Patients with Unidentified Insurance Report")
+9 QUIT
+10 ;
EXCHDR ; Write the excel header.
+1 WRITE !,$$TITLE^IBJDI4(IBX),$SELECT(IBDIV'="ALL":" for "_IBDIV,1:"")
+2 WRITE !,"Run Date: ",IBRUN
+3 WRITE !,"Patients treated in the period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)," NOTE: *=Had inpatient care, +=Billable insurance"
+4 WRITE !,"Patient"_U_"SSN"_U_"Home Phone Number"_U_"Work Phone Number"_U_"Eligibility"_U_"Insurance"_U_"Date of Death"
+5 QUIT
+6 ;
SUM ; - Print the summary report.
+1 WRITE @IOF,*13
SET IBPAG=$GET(IBPAG)+1
+2 WRITE !!?26,"PATIENT INSURANCE STATISTICS",!
+3 IF IBDIV'="ALL"
WRITE ?(61-$LENGTH(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
+4 IF '$TEST
WRITE ?33,"SUMMARY REPORT"
+5 WRITE !!?19,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
+6 WRITE !!?24,"Run Date: ",IBRUN,!?20,$$DASH(40),!!
+7 ;
+8 SET IBPER(1)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"YES")/IB(IBDIV,"TOT")*100),0,2)
+9 SET IBPER(2)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"TOT")*100),0,2)
+10 SET IBPER(3)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"YES")*100),0,2)
+11 SET IBPER(4)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"TOT")*100),0,2)
+12 SET IBPER(5)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"YES")*100),0,2)
+13 SET IBPER(6)=$JUSTIFY($SELECT('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"BILL")*100),0,2)
+14 SET IBPER(7)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"TOT")*100),0,2)
+15 SET IBPER(8)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"YES")*100),0,2)
+16 SET IBPER(9)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"TOT")*100),0,2)
+17 SET IBPER(10)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"YES")*100),0,2)
+18 SET IBPER(11)=$JUSTIFY($SELECT('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"BILL")*100),0,2)
+19 SET IBPER(12)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"IND")/IB(IBDIV,"TOT")*100),0,2)
+20 SET IBPER(13)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NO")/IB(IBDIV,"TOT")*100),0,2)
+21 SET IBPER(14)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"UNK")/IB(IBDIV,"TOT")*100),0,2)
+22 SET IBPER(15)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NULL")/IB(IBDIV,"TOT")*100),0,2)
+23 SET IBPER(16)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
+24 WRITE ?22,"Number of Patients Treated:",?50,$JUSTIFY(IB(IBDIV,"TOT"),5)
+25 WRITE !?9,"Number of Patients Covered by Insurance:",?50,$JUSTIFY(IB(IBDIV,"YES"),5)," (",IBPER(1),"%)"
+26 WRITE !?3,"No. of Patients Covered by Billable Insurance:",?50,$JUSTIFY(IB(IBDIV,"BILL"),5)," (",IBPER(2),"%-",IBPER(3),"%)*"
+27 WRITE !?12,"Number of Patients Covered by an HMO:",?50,$JUSTIFY(IB(IBDIV,"HMO"),5)," (",IBPER(4),"%-",IBPER(5),"%-",IBPER(6),"%)**"
+28 WRITE !?10,"Number of Patients Covered by Medicare:",?50,$JUSTIFY(IB(IBDIV,"MEDC"),5)," (",IBPER(7),"%-",IBPER(8),"%)*"
+29 WRITE !?11,"Number of Patients Covered by Medigap:",?50,$JUSTIFY(IB(IBDIV,"MEDG"),5)," (",IBPER(9),"%-",IBPER(10),"%-",IBPER(11),"%)**"
+30 WRITE !?2,"No. of Patients Covered by an Indemnity Policy:",?50,$JUSTIFY(IB(IBDIV,"IND"),5)," (",IBPER(12),"%)"
+31 WRITE !?5,"Number of Patients Not Covered by Insurance:",?50,$JUSTIFY(IB(IBDIV,"NO"),5)," (",IBPER(13),"%)"
+32 WRITE !?7,"Number of Patients with Unknown Insurance:",?50,$JUSTIFY(IB(IBDIV,"UNK"),5)," (",IBPER(14),"%)"
+33 WRITE !," No. of Patients w/Insurance Question Unanswered:",?50,$JUSTIFY(IB(IBDIV,"NULL"),5)," (",IBPER(15),"%)"
+34 WRITE !?21,"Number of Deceased Patients:",?50,$JUSTIFY(IB(IBDIV,"DEC"),5)," (",IBPER(16),"%)"
+35 WRITE !!," *(% from patients treated-% from patients with insurance)"
+36 WRITE !,"**(% from patients treated-% from patients w/ins-% from patients w/billable ins)"
+37 QUIT
+38 ;
EXCSUM ; - Print the summary report in excel format.
+1 WRITE @IOF,*13
SET IBPAG=$GET(IBPAG)+1
+2 WRITE !!,"PATIENT INSURANCE STATISTICS",!
+3 IF IBDIV'="ALL"
WRITE ?(61-$LENGTH(IBDIV))\2,"SUMMARY REPORT for ",IBDIV
+4 IF '$TEST
WRITE ?33,"SUMMARY REPORT"
+5 WRITE !,"Patients treated from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
+6 WRITE !,"Run Date: ",IBRUN,!
+7 ;
+8 SET IBPER(1)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"YES")/IB(IBDIV,"TOT")*100),0,2)
+9 SET IBPER(2)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"TOT")*100),0,2)
+10 SET IBPER(3)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"BILL")/IB(IBDIV,"YES")*100),0,2)
+11 SET IBPER(4)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"TOT")*100),0,2)
+12 SET IBPER(5)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"YES")*100),0,2)
+13 SET IBPER(6)=$JUSTIFY($SELECT('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"HMO")/IB(IBDIV,"BILL")*100),0,2)
+14 SET IBPER(7)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"TOT")*100),0,2)
+15 SET IBPER(8)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDC")/IB(IBDIV,"YES")*100),0,2)
+16 SET IBPER(9)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"TOT")*100),0,2)
+17 SET IBPER(10)=$JUSTIFY($SELECT('IB(IBDIV,"YES"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"YES")*100),0,2)
+18 SET IBPER(11)=$JUSTIFY($SELECT('IB(IBDIV,"BILL"):0,1:IB(IBDIV,"MEDG")/IB(IBDIV,"BILL")*100),0,2)
+19 SET IBPER(12)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"IND")/IB(IBDIV,"TOT")*100),0,2)
+20 SET IBPER(13)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NO")/IB(IBDIV,"TOT")*100),0,2)
+21 SET IBPER(14)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"UNK")/IB(IBDIV,"TOT")*100),0,2)
+22 SET IBPER(15)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"NULL")/IB(IBDIV,"TOT")*100),0,2)
+23 SET IBPER(16)=$JUSTIFY($SELECT('IB(IBDIV,"TOT"):0,1:IB(IBDIV,"DEC")/IB(IBDIV,"TOT")*100),0,2)
+24 WRITE "Number of Patients Treated:"_U_$JUSTIFY(IB(IBDIV,"TOT"),5)
+25 WRITE !,"Number of Patients Covered by Insurance:"_U_$JUSTIFY(IB(IBDIV,"YES"),5)," (",IBPER(1),"%)"
+26 WRITE !,"No. of Patients Covered by Billable Insurance:"_U_$JUSTIFY(IB(IBDIV,"BILL"),5)," (",IBPER(2),"%-",IBPER(3),"%)*"
+27 WRITE !,"Number of Patients Covered by an HMO:"_U_$JUSTIFY(IB(IBDIV,"HMO"),5)," (",IBPER(4),"%-",IBPER(5),"%-",IBPER(6),"%)**"
+28 WRITE !,"Number of Patients Covered by Medicare:"_U_$JUSTIFY(IB(IBDIV,"MEDC"),5)," (",IBPER(7),"%-",IBPER(8),"%)*"
+29 WRITE !,"Number of Patients Covered by Medigap:"_U_$JUSTIFY(IB(IBDIV,"MEDG"),5)," (",IBPER(9),"%-",IBPER(10),"%-",IBPER(11),"%)**"
+30 WRITE !,"No. of Patients Covered by an Indemnity Policy:"_U_$JUSTIFY(IB(IBDIV,"IND"),5)," (",IBPER(12),"%)"
+31 WRITE !,"Number of Patients Not Covered by Insurance:"_U_$JUSTIFY(IB(IBDIV,"NO"),5)," (",IBPER(13),"%)"
+32 WRITE !,"Number of Patients with Unknown Insurance:"_U_$JUSTIFY(IB(IBDIV,"UNK"),5)," (",IBPER(14),"%)"
+33 WRITE !,"No. of Patients w/Insurance Question Unanswered:"_U_$JUSTIFY(IB(IBDIV,"NULL"),5)," (",IBPER(15),"%)"
+34 WRITE !,"Number of Deceased Patients:"_U_$JUSTIFY(IB(IBDIV,"DEC"),5)," (",IBPER(16),"%)"
+35 WRITE !!," *(% from patients treated-% from patients with insurance)"
+36 WRITE !,"**(% from patients treated-% from patients w/ins-% from patients w/billable ins)"
+37 QUIT
+38 ;
DASH(X) ; - Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",X)," ","=")
+2 ;
ELIG(X) ; - Return eligibility code name.
+1 QUIT $EXTRACT($PIECE($GET(^DIC(8,+X,0)),U),1,20)
+2 ;
INSC(X) ; - Return insurance company.
+1 SET X=$GET(^DIC(36,+X,0))
+2 QUIT $EXTRACT($PIECE(X,U),1,20)_$SELECT($PIECE(X,U,2)["Y"!($PIECE(X,U,2)["*"):"+",1:"")
+3 ;
PAUSE ; - Page break.
+1 ;IB*771/DTG quit if report was queued
IF $DATA(ZTQUEUED)
QUIT
+2 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+3 NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+4 ;F IBX=$Y:1:(IOSL-3) W !
+5 ;IB*771/DTG stop extra blank lines
FOR IBX=1:1:(IBFEED-$Y)
WRITE !
+6 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+7 QUIT
+8 ;
SSN(X) ; - Format the SSN.
+1 QUIT $SELECT(X]"":$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10),1:"")
