IBTODD1 ;ALB/AAS - CLAIMS TRACKING DENIED DAYS REPORT ; 27-OCT-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
% I '$D(DT) D DT^DICRW
PRINT ; -- print data
; -- ^tmp($j,"ibtodd",primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^ billing bed section ^ billing rate
;
K IBCNT
I 'IBSUM D HDR
I 'IBSUM,$O(^TMP($J,"IBTODD",""))="" W !!,"No Denials Found in Date Range." G PRINTQ
;
S IBI="",IBISV=""
F S IBI=$O(^TMP($J,"IBTODD",IBI)) Q:IBI=""!(IBQUIT) D
.I IBSORT'="P",IBISV'=IBI D SUBT^IBTODD
.S IBISV=IBI
.D SUBH^IBTODD(IBI) S IBJ="" F S IBJ=$O(^TMP($J,"IBTODD",IBI,IBJ)) Q:IBJ=""!(IBQUIT) D
..S IBTRC=""
..F S IBTRC=$O(^TMP($J,"IBTODD",IBI,IBJ,IBTRC)) Q:IBTRC=""!(IBQUIT) S IBDATA=^(IBTRC) D ONE
I 'IBSUM D SUBT^IBTODD
D SUM
;
PRINTQ Q
;
ONE ; -- print one entry
; -- ^tmp($j,"ibtodd",primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^ billing bed section ^ billing rate
;
S IBAPL=$$APPEAL(IBTRC)
D CNTS
S IBTALL=+$P($G(^IBT(356.2,+IBTRC,1)),"^",7) ;entire admission denied
Q:IBSUM
;
I IOSL<($Y+4) D HDR
S DFN=+IBDATA D PID^VADPT
S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
L1 W !,$E($P(^DPT(DFN,0),"^"),1,22),?25,VA("PID")
S IBCDT=$$CDT($P(IBTRCD,"^",2))
W ?38,$$DAT1^IBOUTL(+IBCDT\1) W:$P(IBCDT,"^",2) " to"
W ?50,$J($P(IBDATA,"^",2),8)
I IBTALL W ?64,"ALL"
I 'IBTALL W ?64,$$DAT1^IBOUTL($P(IBTRCD,"^",15),"2P") W:$P(IBTRCD,"^",16) " to"
I IBTALL!('$P(IBTRCD,"^",16)) W " (",$P(IBDATA,"^",7),")"
K IBDEN,IBC S IBDEN=0,IBC=0
F S IBDEN=$O(^IBT(356.2,+IBTRC,12,IBDEN)) Q:'IBDEN S IBC=IBC+1,IBC(IBC)=^(IBDEN,0)
W:$G(IBC(1)) ?78,$E($$EXPAND^IBTRE(356.212,.01,+IBC(1)),1,25)
W ?110,$S(+$P(IBAPL,"^",2):"YES",1:"NO")
W ?117,$J(+IBAPL,8)
;
;
L2 W !?38,$$DAT1^IBOUTL($P(IBCDT,"^",2)\1,"2P")
W ?64,$$DAT1^IBOUTL($P(IBTRCD,"^",16),"2P")
I 'IBTALL,$P(IBTRCD,"^",16) W " (",$P(IBDATA,"^",7),")"
W ?78,$E($$EXPAND^IBTRE(356.212,.01,$G(IBC(2))),1,25)
;
I $O(IBC(2)) S IBDEN=2 F S IBDEN=$O(IBC(IBDEN)) Q:'IBDEN W !?78,$E($$EXPAND^IBTRE(356.212,.01,$G(IBC(IBDEN))),1,25)
ONEQ W !
Q
;
SUM ; -- Print summary report
Q:IBQUIT
I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF
S IBPAG=IBPAG+1
W !,"MCCR/UR DENIED DAYS Summary Report for Reviews Dated ",$$FMTE^XLFDT(IBBDT),$S(IBBDT'=IBEDT:" to "_$$FMTE^XLFDT(IBEDT),1:"")," "
W ?(IOM-33),"Page ",IBPAG," ",IBHDT
W !!,?35,"Number",?50,"Days",?65,"Amount",?80,"Days won",?100,"Maximum"
W !,"Service",?35,"Denials",?50,"Denied",?65,"Denied",?80,"on Appeal",?100,"Billing Rate"
W !,$TR($J(" ",IOM)," ","-")
;
I $O(^TMP($J,"IBTODD",""))="" W !!,"No Denials Found in Date Range." G SUMQ
;
S IBSERV="" F S IBSERV=$O(IBCNT(IBSERV)) Q:IBSERV="" D
.W !,$$EXPAND^IBTRE(42.4,3,IBSERV)
.W ?32,$J($P(IBCNT(IBSERV),"^",3),8)
.W ?46,$J(+IBCNT(IBSERV),8)
.S X=$P(IBCNT(IBSERV),"^",2),X2="0$" D COMMA^%DTC W ?60,X
.W ?81,$J($P(IBCNT(IBSERV),"^",4),6)
.S X=$P(IBCNT(IBSERV),"^",6),X2="0$" D COMMA^%DTC W ?95,X
;
W !?48,"--------",!,?48,$J(IBTOTL,6)
SUMQ ;
Q
;
CNTS ; -- develop summary data
S IBSERV=$P(IBDATA,"^",4)
I IBSERV="" S IBSERV="UNKNOWN"
S:'$D(IBCNT(IBSERV)) IBCNT(IBSERV)=""
S $P(IBCNT(IBSERV),"^")=$P(IBCNT(IBSERV),"^")+$P(IBDATA,"^",7)
S $P(IBCNT(IBSERV),"^",2)=$P(IBCNT(IBSERV),"^",2)+($P(IBDATA,"^",7)*$P(IBDATA,"^",6))
S $P(IBCNT(IBSERV),"^",3)=$P(IBCNT(IBSERV),"^",3)+1
S $P(IBCNT(IBSERV),"^",4)=$P(IBCNT(IBSERV),"^",4)+$G(IBAPL)
S:$P(IBCNT(IBSERV),"^",6)<$P(IBDATA,"^",6) $P(IBCNT(IBSERV),"^",6)=$P(IBDATA,"^",6)
S IBSUBT=$G(IBSUBT)+$P(IBDATA,"^",7)
S IBTOTL=$G(IBTOTL)+$P(IBDATA,"^",7)
Q
;
HDR ; -- Print header for billing report
Q:IBQUIT
I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF
S IBPAG=IBPAG+1
W !,"MCCR/UR DENIED DAYS Report for Reviews Dated ",$$FMTE^XLFDT(IBBDT),$S(IBBDT'=IBEDT:" to "_$$FMTE^XLFDT(IBEDT),1:"")," "
W ?(IOM-33),"Page ",IBPAG," ",IBHDT
W !!,?38,"Dates of",?64,"Dates",?117,"Days Approved"
W !,"Patient",?25,"Pt. ID",?38,"Care",?50,"Attending",?64,"Denied",?78,"Denial Reason",?105,"Appealed",?117,"on Appeal"
W !,$TR($J(" ",IOM)," ","-")
Q
;
CDT(IBTRN) ; -- compute dates of care
N X,Y S X=$G(^IBT(356,+IBTRN,0)),Y=""
I $P(X,"^",5) S DGPM=$G(^DGPM($P(X,"^",5),0)) D
.S Y=+DGPM
.I $P(DGPM,"^",17) S Y=Y_"^"_+$G(^DGPM($P(DGPM,"^",17),0))
I 'Y S Y=$P(X,"^",6)
Q Y
;
APPEAL(IBTRC) ; -- Find appeals
N X,Y,IBAPEAL,IBTRN,IBTRSV S (Y,X)=0
S IBTRSV=IBTRC
S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"AP",+IBTRSV,IBTRC)) Q:'IBTRC S Y=1,X=X+$$AP(IBTRC)
;
Q X_"^"_Y
;
AP(IBTRC) ; -- count days approved
N X,Y,Z
S (X,Z)=0
F S X=$O(^IBT(356.2,+IBTRC,14,X)) Q:'X S Y=$G(^(X,0)),Z=Z+$$FMDIFF^XLFDT($P(Y,"^",2),+Y)+1
Q Z
IBTODD1 ;ALB/AAS - CLAIMS TRACKING DENIED DAYS REPORT ; 27-OCT-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
% IF '$DATA(DT)
DO DT^DICRW
PRINT ; -- print data
+1 ; -- ^tmp($j,"ibtodd",primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^ billing bed section ^ billing rate
+2 ;
+3 KILL IBCNT
+4 IF 'IBSUM
DO HDR
+5 IF 'IBSUM
IF $ORDER(^TMP($JOB,"IBTODD",""))=""
WRITE !!,"No Denials Found in Date Range."
GOTO PRINTQ
+6 ;
+7 SET IBI=""
SET IBISV=""
+8 FOR
SET IBI=$ORDER(^TMP($JOB,"IBTODD",IBI))
IF IBI=""!(IBQUIT)
QUIT
Begin DoDot:1
+9 IF IBSORT'="P"
IF IBISV'=IBI
DO SUBT^IBTODD
+10 SET IBISV=IBI
+11 DO SUBH^IBTODD(IBI)
SET IBJ=""
FOR
SET IBJ=$ORDER(^TMP($JOB,"IBTODD",IBI,IBJ))
IF IBJ=""!(IBQUIT)
QUIT
Begin DoDot:2
+12 SET IBTRC=""
+13 FOR
SET IBTRC=$ORDER(^TMP($JOB,"IBTODD",IBI,IBJ,IBTRC))
IF IBTRC=""!(IBQUIT)
QUIT
SET IBDATA=^(IBTRC)
DO ONE
End DoDot:2
End DoDot:1
+14 IF 'IBSUM
DO SUBT^IBTODD
+15 DO SUM
+16 ;
PRINTQ QUIT
+1 ;
ONE ; -- print one entry
+1 ; -- ^tmp($j,"ibtodd",primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^ billing bed section ^ billing rate
+2 ;
+3 SET IBAPL=$$APPEAL(IBTRC)
+4 DO CNTS
+5 ;entire admission denied
SET IBTALL=+$PIECE($GET(^IBT(356.2,+IBTRC,1)),"^",7)
+6 IF IBSUM
QUIT
+7 ;
+8 IF IOSL<($Y+4)
DO HDR
+9 SET DFN=+IBDATA
DO PID^VADPT
+10 SET IBTRCD=$GET(^IBT(356.2,+IBTRC,0))
L1 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,22),?25,VA("PID")
+1 SET IBCDT=$$CDT($PIECE(IBTRCD,"^",2))
+2 WRITE ?38,$$DAT1^IBOUTL(+IBCDT\1)
IF $PIECE(IBCDT,"^",2)
WRITE " to"
+3 WRITE ?50,$JUSTIFY($PIECE(IBDATA,"^",2),8)
+4 IF IBTALL
WRITE ?64,"ALL"
+5 IF 'IBTALL
WRITE ?64,$$DAT1^IBOUTL($PIECE(IBTRCD,"^",15),"2P")
IF $PIECE(IBTRCD,"^",16)
WRITE " to"
+6 IF IBTALL!('$PIECE(IBTRCD,"^",16))
WRITE " (",$PIECE(IBDATA,"^",7),")"
+7 KILL IBDEN,IBC
SET IBDEN=0
SET IBC=0
+8 FOR
SET IBDEN=$ORDER(^IBT(356.2,+IBTRC,12,IBDEN))
IF 'IBDEN
QUIT
SET IBC=IBC+1
SET IBC(IBC)=^(IBDEN,0)
+9 IF $GET(IBC(1))
WRITE ?78,$EXTRACT($$EXPAND^IBTRE(356.212,.01,+IBC(1)),1,25)
+10 WRITE ?110,$SELECT(+$PIECE(IBAPL,"^",2):"YES",1:"NO")
+11 WRITE ?117,$JUSTIFY(+IBAPL,8)
+12 ;
+13 ;
L2 WRITE !?38,$$DAT1^IBOUTL($PIECE(IBCDT,"^",2)\1,"2P")
+1 WRITE ?64,$$DAT1^IBOUTL($PIECE(IBTRCD,"^",16),"2P")
+2 IF 'IBTALL
IF $PIECE(IBTRCD,"^",16)
WRITE " (",$PIECE(IBDATA,"^",7),")"
+3 WRITE ?78,$EXTRACT($$EXPAND^IBTRE(356.212,.01,$GET(IBC(2))),1,25)
+4 ;
+5 IF $ORDER(IBC(2))
SET IBDEN=2
FOR
SET IBDEN=$ORDER(IBC(IBDEN))
IF 'IBDEN
QUIT
WRITE !?78,$EXTRACT($$EXPAND^IBTRE(356.212,.01,$GET(IBC(IBDEN))),1,25)
ONEQ WRITE !
+1 QUIT
+2 ;
SUM ; -- Print summary report
+1 IF IBQUIT
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
IF IBPAG
DO PAUSE^VALM1
IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF
+4 SET IBPAG=IBPAG+1
+5 WRITE !,"MCCR/UR DENIED DAYS Summary Report for Reviews Dated ",$$FMTE^XLFDT(IBBDT),$SELECT(IBBDT'=IBEDT:" to "_$$FMTE^XLFDT(IBEDT),1:"")," "
+6 WRITE ?(IOM-33),"Page ",IBPAG," ",IBHDT
+7 WRITE !!,?35,"Number",?50,"Days",?65,"Amount",?80,"Days won",?100,"Maximum"
+8 WRITE !,"Service",?35,"Denials",?50,"Denied",?65,"Denied",?80,"on Appeal",?100,"Billing Rate"
+9 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+10 ;
+11 IF $ORDER(^TMP($JOB,"IBTODD",""))=""
WRITE !!,"No Denials Found in Date Range."
GOTO SUMQ
+12 ;
+13 SET IBSERV=""
FOR
SET IBSERV=$ORDER(IBCNT(IBSERV))
IF IBSERV=""
QUIT
Begin DoDot:1
+14 WRITE !,$$EXPAND^IBTRE(42.4,3,IBSERV)
+15 WRITE ?32,$JUSTIFY($PIECE(IBCNT(IBSERV),"^",3),8)
+16 WRITE ?46,$JUSTIFY(+IBCNT(IBSERV),8)
+17 SET X=$PIECE(IBCNT(IBSERV),"^",2)
SET X2="0$"
DO COMMA^%DTC
WRITE ?60,X
+18 WRITE ?81,$JUSTIFY($PIECE(IBCNT(IBSERV),"^",4),6)
+19 SET X=$PIECE(IBCNT(IBSERV),"^",6)
SET X2="0$"
DO COMMA^%DTC
WRITE ?95,X
End DoDot:1
+20 ;
+21 WRITE !?48,"--------",!,?48,$JUSTIFY(IBTOTL,6)
SUMQ ;
+1 QUIT
+2 ;
CNTS ; -- develop summary data
+1 SET IBSERV=$PIECE(IBDATA,"^",4)
+2 IF IBSERV=""
SET IBSERV="UNKNOWN"
+3 IF '$DATA(IBCNT(IBSERV))
SET IBCNT(IBSERV)=""
+4 SET $PIECE(IBCNT(IBSERV),"^")=$PIECE(IBCNT(IBSERV),"^")+$PIECE(IBDATA,"^",7)
+5 SET $PIECE(IBCNT(IBSERV),"^",2)=$PIECE(IBCNT(IBSERV),"^",2)+($PIECE(IBDATA,"^",7)*$PIECE(IBDATA,"^",6))
+6 SET $PIECE(IBCNT(IBSERV),"^",3)=$PIECE(IBCNT(IBSERV),"^",3)+1
+7 SET $PIECE(IBCNT(IBSERV),"^",4)=$PIECE(IBCNT(IBSERV),"^",4)+$GET(IBAPL)
+8 IF $PIECE(IBCNT(IBSERV),"^",6)<$PIECE(IBDATA,"^",6)
SET $PIECE(IBCNT(IBSERV),"^",6)=$PIECE(IBDATA,"^",6)
+9 SET IBSUBT=$GET(IBSUBT)+$PIECE(IBDATA,"^",7)
+10 SET IBTOTL=$GET(IBTOTL)+$PIECE(IBDATA,"^",7)
+11 QUIT
+12 ;
HDR ; -- Print header for billing report
+1 IF IBQUIT
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
IF IBPAG
DO PAUSE^VALM1
IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF
+4 SET IBPAG=IBPAG+1
+5 WRITE !,"MCCR/UR DENIED DAYS Report for Reviews Dated ",$$FMTE^XLFDT(IBBDT),$SELECT(IBBDT'=IBEDT:" to "_$$FMTE^XLFDT(IBEDT),1:"")," "
+6 WRITE ?(IOM-33),"Page ",IBPAG," ",IBHDT
+7 WRITE !!,?38,"Dates of",?64,"Dates",?117,"Days Approved"
+8 WRITE !,"Patient",?25,"Pt. ID",?38,"Care",?50,"Attending",?64,"Denied",?78,"Denial Reason",?105,"Appealed",?117,"on Appeal"
+9 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+10 QUIT
+11 ;
CDT(IBTRN) ; -- compute dates of care
+1 NEW X,Y
SET X=$GET(^IBT(356,+IBTRN,0))
SET Y=""
+2 IF $PIECE(X,"^",5)
SET DGPM=$GET(^DGPM($PIECE(X,"^",5),0))
Begin DoDot:1
+3 SET Y=+DGPM
+4 IF $PIECE(DGPM,"^",17)
SET Y=Y_"^"_+$GET(^DGPM($PIECE(DGPM,"^",17),0))
End DoDot:1
+5 IF 'Y
SET Y=$PIECE(X,"^",6)
+6 QUIT Y
+7 ;
APPEAL(IBTRC) ; -- Find appeals
+1 NEW X,Y,IBAPEAL,IBTRN,IBTRSV
SET (Y,X)=0
+2 SET IBTRSV=IBTRC
+3 SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"AP",+IBTRSV,IBTRC))
IF 'IBTRC
QUIT
SET Y=1
SET X=X+$$AP(IBTRC)
+4 ;
+5 QUIT X_"^"_Y
+6 ;
AP(IBTRC) ; -- count days approved
+1 NEW X,Y,Z
+2 SET (X,Z)=0
+3 FOR
SET X=$ORDER(^IBT(356.2,+IBTRC,14,X))
IF 'X
QUIT
SET Y=$GET(^(X,0))
SET Z=Z+$$FMDIFF^XLFDT($PIECE(Y,"^",2),+Y)+1
+4 QUIT Z
