IBJDU1 ;ALB/CPM - UTILIZATION WORKLOAD REPORT ; 24-DEC-96
;;Version 2.0 ; INTEGRATED BILLING ;**69**; 21-MAR-94
;
EN ; Option entry point.
;
W !!,"This report provides a measure of the number of Insurance Reviews"
W !,"which are conducted in the Medical Center.",!
;
D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
;
W !!,"This report only requires an 80 column printer."
;
W !!," Note: This report may take a while to run."
W !?10,"You should queue this report to run after normal business hours.",!
;
; - select a device
S %ZIS="QM" D ^%ZIS G:POP ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="DQ^IBJDU1",ZTDESC="IB - UTILIZATION WORKLOAD REPORT"
.F I="IBBDT","IBEDT" S ZTSAVE(I)=""
.D ^%ZTLOAD
.W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO
;
DQ ; Tasked entry point.
;
K IB F I=1:1:10 S IB(I)=0
;
; - count admissions within the user-specified date range
S IBDT=IBBDT-.000000001,IBQ=0
F S IBDT=$O(^DGPM("AMV1",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.24)) D Q:IBQ
.S DFN=0 F S DFN=$O(^DGPM("AMV1",IBDT,DFN)) Q:'DFN D Q:IBQ
..S IBPM=0 F S IBPM=$O(^DGPM("AMV1",IBDT,DFN,IBPM)) Q:'IBPM D Q:IBQ
...;
...I IBPM#100=0 S IBQ=$$STOP^IBOUTL("Utilization Workload Report") Q:IBQ
...;
...S IB(1)=IB(1)+1 ; total admissions
...;
...Q:'$$INSURED^IBCNS1(DFN,IBDT)
...;
...S IB(2)=IB(2)+1 ; insured admissions
...D ELIG^VADPT
...I VAEL(3) S IB(3)=IB(3)+1 Q ; insured SC admissions
...S IB(4)=IB(4)+1 ; insured NSC admissions
;
I IBQ G ENQ
;
; - count insurance reviews
K ^TMP("IBJDU1",$J)
S IBDT=IBBDT-.000000001
F S IBDT=$O(^IBT(356.2,"B",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.9)) D Q:IBQ
.S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"B",IBDT,IBTRC)) Q:'IBTRC D Q:IBQ
..;
..I IBTRC#100=0 S IBQ=$$STOP^IBOUTL("Utilization Workload Report") Q:IBQ
..;
..S IBTRCD=$G(^IBT(356.2,+IBTRC,0)) Q:IBTRCD=""
..S IBTRN=$P(IBTRCD,"^",2)
..Q:$P(IBTRCD,"^",19)<10 ; review is not complete
..Q:'IBTRN ; no corresponding CT entry
..S IBPM=$P($G(^IBT(356,IBTRN,0)),"^",5)
..Q:'IBPM ; review not for an admission
..;
..; - get contact type
..S IBRTY=$P($G(^IBE(356.11,+$P(IBTRCD,"^",4),0)),"^",2)
..;
..; - appeals
..I IBRTY=60!(IBRTY=65) D Q
...I '$D(^TMP("IBJDU1",$J,IBTRN)) S ^(IBTRN)="",IB(10)=IB(10)+1
..;
..; - admission reviews
..I IBRTY=10!(IBRTY=15)!(IBRTY=20) D Q
...S IB(5)=IB(5)+1
...;
...; - count reviews where the entire admission was denied
...Q:'$P($G(^IBT(356.2,IBTRC,1)),"^",7)
...;
...S IB(7)=IB(7)+1
...S X=$G(^DGPM(IBPM,0)),Y=+$G(^DGPM(+$P(X,"^",17),0))\1
...S:'Y Y=DT
...S IB(9)=IB(9)+$$FMDIFF^XLFDT(Y,+X\1)
..;
..; - continued stay reviews
..I IBRTY=30 D
...S IB(6)=IB(6)+1
...;
...; - look at denials
...Q:$P($G(^IBE(356.7,+$P(IBTRCD,"^",11),1)),"^",3)'=20
...S IB(8)=IB(8)+1
...S X=$P(IBTRCD,"^",15),Y=$P(IBTRCD,"^",16) S:'Y Y=X
...I X S IB(9)=IB(9)+$$FMDIFF^XLFDT(Y,X)+1
;
I IBQ G ENQ
;
; - print the reports
S (IBPAG,IBQ)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
D SUM
;
ENQ K ^TMP("IBJDU1",$J)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IB,IBQ,IBBDT,IBEDT,IBDT,IBPM,IBPAG,IBRUN,IBTRC,IBTRCD,IBTRN,IBRTY
K %,%ZIS,DFN,IBPERI,IBPERS,POP,X,Y,VA,VAERR,VAEL,ZTDESC,ZTRTN,ZTSAVE
Q
;
;
;
SUM ; Print the Summary Report.
I $E(IOST,1,2)="C-" W @IOF,*13
;
; - print overall summary header
W !!?30,"UTILIZATION WORKLOAD"
W !?33,"SUMMARY REPORT"
W !!?22,"For Reviews from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
W !!?24,"Run Date: ",IBRUN
W !?24,$$DASH(31),!!
;
; - print overall summary statistics
S IBPERI=$S('IB(1):0,1:$J(IB(2)/IB(1)*100,0,2))
S IBPERS=$S('IB(2):0,1:$J(IB(3)/IB(2)*100,0,2))
W ?21,"Total Number of Admissions:",?60,$J(IB(1),7)
W !?6,"Total Number of Admissions with Insurance:",?60,$J(IB(2),7)," (",IBPERI,"%)"
W !?39,"SC:",?60,$J(IB(3),7)," (",IBPERS,"%)"
W !?38,"NSC:",?60,$J(IB(4),7)," (",$J(100-IBPERS,0,2),"%)"
;
W !!?7,"Total Number of Admission Reviews completed"
W !?9,"on Insurance Patients (including pre-certifications):",?65,$J(IB(5),7)
W !?13,"Total Number of Continued Stay Reviews completed:",?65,$J(IB(6),7)
W !?5,"Total Number of Admission Denials by Insurance Companies:",?65,$J(IB(7),7)
W !,"Total Number of Continued Stay Denials by Insurance Companies:",?65,$J(IB(8),7)
W !?11,"Total Number of days denied by Insurance Companies:",?65,$J(IB(9),7)
W !?31,"Total Number of Appealed Cases:",?65,$J(IB(10),7)
;
D PAUSE
Q
;
DASH(X) ; Return a dashed line.
Q $TR($J("",X)," ","=")
;
PAUSE ; Page break
Q:$E(IOST,1,2)'="C-"
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F IBX=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDU1 4962 printed Apr 09, 2024@21:32:25 Page 2
IBJDU1 ;ALB/CPM - UTILIZATION WORKLOAD REPORT ; 24-DEC-96
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**69**; 21-MAR-94
+2 ;
EN ; Option entry point.
+1 ;
+2 WRITE !!,"This report provides a measure of the number of Insurance Reviews"
+3 WRITE !,"which are conducted in the Medical Center.",!
+4 ;
+5 DO DATE^IBOUTL
IF IBBDT=""!(IBEDT="")
GOTO ENQ
+6 ;
+7 WRITE !!,"This report only requires an 80 column printer."
+8 ;
+9 WRITE !!," Note: This report may take a while to run."
+10 WRITE !?10,"You should queue this report to run after normal business hours.",!
+11 ;
+12 ; - select a device
+13 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+14 IF $DATA(IO("Q"))
Begin DoDot:1
+15 SET ZTRTN="DQ^IBJDU1"
SET ZTDESC="IB - UTILIZATION WORKLOAD REPORT"
+16 FOR I="IBBDT","IBEDT"
SET ZTSAVE(I)=""
+17 DO ^%ZTLOAD
+18 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
+19 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+20 ;
+21 USE IO
+22 ;
DQ ; Tasked entry point.
+1 ;
+2 KILL IB
FOR I=1:1:10
SET IB(I)=0
+3 ;
+4 ; - count admissions within the user-specified date range
+5 SET IBDT=IBBDT-.000000001
SET IBQ=0
+6 FOR
SET IBDT=$ORDER(^DGPM("AMV1",IBDT))
if 'IBDT!(IBDT>(IBEDT+.24))
QUIT
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",IBDT,DFN))
if 'DFN
QUIT
Begin DoDot:2
+8 SET IBPM=0
FOR
SET IBPM=$ORDER(^DGPM("AMV1",IBDT,DFN,IBPM))
if 'IBPM
QUIT
Begin DoDot:3
+9 ;
+10 IF IBPM#100=0
SET IBQ=$$STOP^IBOUTL("Utilization Workload Report")
if IBQ
QUIT
+11 ;
+12 ; total admissions
SET IB(1)=IB(1)+1
+13 ;
+14 if '$$INSURED^IBCNS1(DFN,IBDT)
QUIT
+15 ;
+16 ; insured admissions
SET IB(2)=IB(2)+1
+17 DO ELIG^VADPT
+18 ; insured SC admissions
IF VAEL(3)
SET IB(3)=IB(3)+1
QUIT
+19 ; insured NSC admissions
SET IB(4)=IB(4)+1
End DoDot:3
if IBQ
QUIT
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+20 ;
+21 IF IBQ
GOTO ENQ
+22 ;
+23 ; - count insurance reviews
+24 KILL ^TMP("IBJDU1",$JOB)
+25 SET IBDT=IBBDT-.000000001
+26 FOR
SET IBDT=$ORDER(^IBT(356.2,"B",IBDT))
if 'IBDT!(IBDT>(IBEDT+.9))
QUIT
Begin DoDot:1
+27 SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"B",IBDT,IBTRC))
if 'IBTRC
QUIT
Begin DoDot:2
+28 ;
+29 IF IBTRC#100=0
SET IBQ=$$STOP^IBOUTL("Utilization Workload Report")
if IBQ
QUIT
+30 ;
+31 SET IBTRCD=$GET(^IBT(356.2,+IBTRC,0))
if IBTRCD=""
QUIT
+32 SET IBTRN=$PIECE(IBTRCD,"^",2)
+33 ; review is not complete
if $PIECE(IBTRCD,"^",19)<10
QUIT
+34 ; no corresponding CT entry
if 'IBTRN
QUIT
+35 SET IBPM=$PIECE($GET(^IBT(356,IBTRN,0)),"^",5)
+36 ; review not for an admission
if 'IBPM
QUIT
+37 ;
+38 ; - get contact type
+39 SET IBRTY=$PIECE($GET(^IBE(356.11,+$PIECE(IBTRCD,"^",4),0)),"^",2)
+40 ;
+41 ; - appeals
+42 IF IBRTY=60!(IBRTY=65)
Begin DoDot:3
+43 IF '$DATA(^TMP("IBJDU1",$JOB,IBTRN))
SET ^(IBTRN)=""
SET IB(10)=IB(10)+1
End DoDot:3
QUIT
+44 ;
+45 ; - admission reviews
+46 IF IBRTY=10!(IBRTY=15)!(IBRTY=20)
Begin DoDot:3
+47 SET IB(5)=IB(5)+1
+48 ;
+49 ; - count reviews where the entire admission was denied
+50 if '$PIECE($GET(^IBT(356.2,IBTRC,1)),"^",7)
QUIT
+51 ;
+52 SET IB(7)=IB(7)+1
+53 SET X=$GET(^DGPM(IBPM,0))
SET Y=+$GET(^DGPM(+$PIECE(X,"^",17),0))\1
+54 if 'Y
SET Y=DT
+55 SET IB(9)=IB(9)+$$FMDIFF^XLFDT(Y,+X\1)
End DoDot:3
QUIT
+56 ;
+57 ; - continued stay reviews
+58 IF IBRTY=30
Begin DoDot:3
+59 SET IB(6)=IB(6)+1
+60 ;
+61 ; - look at denials
+62 if $PIECE($GET(^IBE(356.7,+$PIECE(IBTRCD,"^",11),1)),"^",3)'=20
QUIT
+63 SET IB(8)=IB(8)+1
+64 SET X=$PIECE(IBTRCD,"^",15)
SET Y=$PIECE(IBTRCD,"^",16)
if 'Y
SET Y=X
+65 IF X
SET IB(9)=IB(9)+$$FMDIFF^XLFDT(Y,X)+1
End DoDot:3
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+66 ;
+67 IF IBQ
GOTO ENQ
+68 ;
+69 ; - print the reports
+70 SET (IBPAG,IBQ)=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+71 DO SUM
+72 ;
ENQ KILL ^TMP("IBJDU1",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL IB,IBQ,IBBDT,IBEDT,IBDT,IBPM,IBPAG,IBRUN,IBTRC,IBTRCD,IBTRN,IBRTY
+1 KILL %,%ZIS,DFN,IBPERI,IBPERS,POP,X,Y,VA,VAERR,VAEL,ZTDESC,ZTRTN,ZTSAVE
+2 QUIT
+3 ;
+4 ;
+5 ;
SUM ; Print the Summary Report.
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF,*13
+2 ;
+3 ; - print overall summary header
+4 WRITE !!?30,"UTILIZATION WORKLOAD"
+5 WRITE !?33,"SUMMARY REPORT"
+6 WRITE !!?22,"For Reviews from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
+7 WRITE !!?24,"Run Date: ",IBRUN
+8 WRITE !?24,$$DASH(31),!!
+9 ;
+10 ; - print overall summary statistics
+11 SET IBPERI=$SELECT('IB(1):0,1:$JUSTIFY(IB(2)/IB(1)*100,0,2))
+12 SET IBPERS=$SELECT('IB(2):0,1:$JUSTIFY(IB(3)/IB(2)*100,0,2))
+13 WRITE ?21,"Total Number of Admissions:",?60,$JUSTIFY(IB(1),7)
+14 WRITE !?6,"Total Number of Admissions with Insurance:",?60,$JUSTIFY(IB(2),7)," (",IBPERI,"%)"
+15 WRITE !?39,"SC:",?60,$JUSTIFY(IB(3),7)," (",IBPERS,"%)"
+16 WRITE !?38,"NSC:",?60,$JUSTIFY(IB(4),7)," (",$JUSTIFY(100-IBPERS,0,2),"%)"
+17 ;
+18 WRITE !!?7,"Total Number of Admission Reviews completed"
+19 WRITE !?9,"on Insurance Patients (including pre-certifications):",?65,$JUSTIFY(IB(5),7)
+20 WRITE !?13,"Total Number of Continued Stay Reviews completed:",?65,$JUSTIFY(IB(6),7)
+21 WRITE !?5,"Total Number of Admission Denials by Insurance Companies:",?65,$JUSTIFY(IB(7),7)
+22 WRITE !,"Total Number of Continued Stay Denials by Insurance Companies:",?65,$JUSTIFY(IB(8),7)
+23 WRITE !?11,"Total Number of days denied by Insurance Companies:",?65,$JUSTIFY(IB(9),7)
+24 WRITE !?31,"Total Number of Appealed Cases:",?65,$JUSTIFY(IB(10),7)
+25 ;
+26 DO PAUSE
+27 QUIT
+28 ;
DASH(X) ; Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",X)," ","=")
+2 ;
PAUSE ; Page break
+1 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+3 FOR IBX=$Y:1:(IOSL-3)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+5 QUIT
