- 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 Feb 18, 2025@23:49:42 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:"")