IBTOSUM ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ; 29-OCT-93
;;2.0;INTEGRATED BILLING;**118,133,217**;21-MAR-94
;
% I '$D(DT) D DT^DICRW
W !!,"MCCR/UR Summary Report",!!
S IBQUIT=0
;
SORT ; - Print either by admissions or discharges.
N DIR
S DIR(0)="SOBA^A:Admissions;D:Discharges"
S DIR("A")="Print Report By [A]dmissions [D]ischarges: "
S DIR("B")="D"
S DIR("?",1)="This summary report may be prepared by either Admissions or Discharges."
S DIR("?",2)="If you choose by discharge the report will contain information on all"
S DIR("?",3)="claims tracking information for the discharges that fall in the date"
S DIR("?",4)="Range. That is, all reviews for discharges found in the date range"
S DIR("?",5)="will be included in the report. If you choose by Admissions all"
S DIR("?",6)="reviews found in the date range will be included but the reviews"
S DIR("?",7)="may be for cases not related to the admissions."
S DIR("?",8)=" "
S DIR("?")="If you want to know the total reviews done during a date range sort by admissions. If you want to know the total reviews done on the discharges for a date range sort by Discharges"
D ^DIR K DIR
S IBSORT=Y I "AD"'[Y!($D(DIRUT)) G END
;
; - Get date range.
W ! D DATE^IBOUTL I IBBDT=""!(IBEDT="") G END
;
DEV ; - Select device, run option.
W ! S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) D G END
.S ZTRTN="RPT^IBTOSUM",ZTSAVE("IB*")=""
.S ZTDESC="IB - MCCR/UR Summary Report" D ^%ZTLOAD K IO("Q"),ZTSK
.D HOME^%ZIS
U IO
;
RPT ; - Entry point from taskman/Store data in ^TMP($J,"IBTOSUM",n).
;
I $G(IBXTRACT) D E^IBJDE(11,1) ; Change extract status.
;
K ^TMP($J)
S IBQUIT=0,IBPAG=0,Y=DT D D^DIQ S IBHDT=Y
F I=0:1:13,20,21,80,81,82,99,30:1:34 S IBCNT(I)=0
S IBCNT(3,0)=0
I IBSORT="A" D ADM
I IBSORT="D" D DIS
D CHK^IBTOSUM2 I $G(ZTSTOP) G END
;
; - Extract summary data, if necessary.
I $G(IBXTRACT) S IBCNT(3,0)=+$G(IBCNT(3,0)) D E^IBJDE(11,0) G END1
;
D PRINT^IBTOSUM2
;
END ; - Clean up.
W ! I $D(IBCNT(1)),$E(IOST,1,2)="C-" D PAUSE^VALM1
;
END1 K ^TMP($J) I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
K X,X1,X2,X3,Y,%ZIS,POP,DA,DIRUT,DUOUT,IBRATE,IBBBS,IBSORT,IBC,IBPCNT
K IBDCNT,IBMAX,IBCDT,IBDT,IBBDT,IBEDT,IBQUIT,IBPAG,IBHDT,IBCNT,IBSPEC
K IBINS,IBAC,IBPEN,IBPEND,IBTRN,IBTRND,IBTRC,IBTRCD,DFN,DGPM,IBNOD,IBDAY
K IBFAC,IBSITE,IBSNM,I,J
Q
;
ADM ; - Count admissions.
D CHK^IBTOSUM2 I $G(ZTSTOP) Q
S IBDT=IBBDT-.000000001
F S IBDT=$O(^DGPM("AMV1",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.24)) D
.S DFN=0 F S DFN=$O(^DGPM("AMV1",IBDT,DFN)) Q:'DFN D
..S DA=0 F S DA=$O(^DGPM("AMV1",IBDT,DFN,DA)) Q:'DA D PROC
;
Q
;
DIS ; - Count discharges.
D CHK^IBTOSUM2 I $G(ZTSTOP) Q
S IBDT=IBBDT-.000000001
F S IBDT=$O(^DGPM("AMV3",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.24)) D
.S DFN=0 F S DFN=$O(^DGPM("AMV3",IBDT,DFN)) Q:'DFN D
..S DA=0 F S DA=$O(^DGPM("AMV3",IBDT,DFN,DA)) Q:'DA D PROC
;
Q
;
PROC ; - Process each admission or discharge.
S DGPM=+$P($G(^DGPM(DA,0)),U,14)
S IBCNT(1)=IBCNT(1)+1 ; Admissions or discharges.
S IBTRN=$O(^IBT(356,"AD",DGPM,0)) I 'IBTRN Q
S IBTRND=$G(^IBT(356,+IBTRN,0)) ;W !,IBTRND
I '$P(IBTRND,U,20) Q ; Must be an active visit.
I '$$INSURED^IBCNS1(DFN,IBDT) Q ; Must be insured for visit to count.
S IBCNT(2)=IBCNT(2)+1 ; Insured admissions or discharges.
S IBCNT(3,+$P(IBTRND,U,19))=$G(IBCNT(3,+$P(IBTRND,U,19)))+1 ; Billables.
I $P(IBTRND,U,19) S IBCNT(3,"NB")=$G(IBCNT(3,"NB"))+1
S X=$P($G(^IBT(356,+IBTRN,1)),U,7) I X>3 S IBCNT(4)=IBCNT(4)+1
I X="",$P(IBTRND,U,24),'$P(IBTRND,U,19) S IBCNT(4)=IBCNT(4)+1
I $$APPEAL(IBTRN) S IBCNT(80)=IBCNT(80)+1
;
K IBDCNT,IBPCNT S IBTRC=0
F S IBTRC=$O(^IBT(356.2,"C",IBTRN,IBTRC)) Q:'IBTRC D RCNT^IBTOSUM1
I $D(IBPCNT(IBTRN)) S IBCNT(99)=IBCNT(99)+1
I $O(IBPCNT(IBTRN,+$O(IBPCNT(IBTRN,0)))) S IBCNT(13)=IBCNT(13)+1
Q
;
APPEAL(IBTRN) ; - Was this case appealed?
N A,X
S A=0 I 'IBTRN G APPEALQ
S X=$O(^IBE(356.11,"ACODE",60,0)) ; Initial appeal.
I $O(^IBT(356.2,"ATRTP",IBTRN,X,0)) S A=1 G APPEALQ
S X=$O(^IBE(356.11,"ACODE",65,0)) ; Subsequent appeal.
I $O(^IBT(356.2,"ATRTP",IBTRN,X,0)) S A=1 G APPEALQ
APPEALQ Q A
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTOSUM 4237 printed Oct 16, 2024@18:27:59 Page 2
IBTOSUM ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ; 29-OCT-93
+1 ;;2.0;INTEGRATED BILLING;**118,133,217**;21-MAR-94
+2 ;
% IF '$DATA(DT)
DO DT^DICRW
+1 WRITE !!,"MCCR/UR Summary Report",!!
+2 SET IBQUIT=0
+3 ;
SORT ; - Print either by admissions or discharges.
+1 NEW DIR
+2 SET DIR(0)="SOBA^A:Admissions;D:Discharges"
+3 SET DIR("A")="Print Report By [A]dmissions [D]ischarges: "
+4 SET DIR("B")="D"
+5 SET DIR("?",1)="This summary report may be prepared by either Admissions or Discharges."
+6 SET DIR("?",2)="If you choose by discharge the report will contain information on all"
+7 SET DIR("?",3)="claims tracking information for the discharges that fall in the date"
+8 SET DIR("?",4)="Range. That is, all reviews for discharges found in the date range"
+9 SET DIR("?",5)="will be included in the report. If you choose by Admissions all"
+10 SET DIR("?",6)="reviews found in the date range will be included but the reviews"
+11 SET DIR("?",7)="may be for cases not related to the admissions."
+12 SET DIR("?",8)=" "
+13 SET DIR("?")="If you want to know the total reviews done during a date range sort by admissions. If you want to know the total reviews done on the discharges for a date range sort by Discharges"
+14 DO ^DIR
KILL DIR
+15 SET IBSORT=Y
IF "AD"'[Y!($DATA(DIRUT))
GOTO END
+16 ;
+17 ; - Get date range.
+18 WRITE !
DO DATE^IBOUTL
IF IBBDT=""!(IBEDT="")
GOTO END
+19 ;
DEV ; - Select device, run option.
+1 WRITE !
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="RPT^IBTOSUM"
SET ZTSAVE("IB*")=""
+4 SET ZTDESC="IB - MCCR/UR Summary Report"
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
+5 DO HOME^%ZIS
End DoDot:1
GOTO END
+6 USE IO
+7 ;
RPT ; - Entry point from taskman/Store data in ^TMP($J,"IBTOSUM",n).
+1 ;
+2 ; Change extract status.
IF $GET(IBXTRACT)
DO E^IBJDE(11,1)
+3 ;
+4 KILL ^TMP($JOB)
+5 SET IBQUIT=0
SET IBPAG=0
SET Y=DT
DO D^DIQ
SET IBHDT=Y
+6 FOR I=0:1:13,20,21,80,81,82,99,30:1:34
SET IBCNT(I)=0
+7 SET IBCNT(3,0)=0
+8 IF IBSORT="A"
DO ADM
+9 IF IBSORT="D"
DO DIS
+10 DO CHK^IBTOSUM2
IF $GET(ZTSTOP)
GOTO END
+11 ;
+12 ; - Extract summary data, if necessary.
+13 IF $GET(IBXTRACT)
SET IBCNT(3,0)=+$GET(IBCNT(3,0))
DO E^IBJDE(11,0)
GOTO END1
+14 ;
+15 DO PRINT^IBTOSUM2
+16 ;
END ; - Clean up.
+1 WRITE !
IF $DATA(IBCNT(1))
IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^VALM1
+2 ;
END1 KILL ^TMP($JOB)
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+1 DO ^%ZISC
+2 KILL X,X1,X2,X3,Y,%ZIS,POP,DA,DIRUT,DUOUT,IBRATE,IBBBS,IBSORT,IBC,IBPCNT
+3 KILL IBDCNT,IBMAX,IBCDT,IBDT,IBBDT,IBEDT,IBQUIT,IBPAG,IBHDT,IBCNT,IBSPEC
+4 KILL IBINS,IBAC,IBPEN,IBPEND,IBTRN,IBTRND,IBTRC,IBTRCD,DFN,DGPM,IBNOD,IBDAY
+5 KILL IBFAC,IBSITE,IBSNM,I,J
+6 QUIT
+7 ;
ADM ; - Count admissions.
+1 DO CHK^IBTOSUM2
IF $GET(ZTSTOP)
QUIT
+2 SET IBDT=IBBDT-.000000001
+3 FOR
SET IBDT=$ORDER(^DGPM("AMV1",IBDT))
if 'IBDT!(IBDT>(IBEDT+.24))
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",IBDT,DFN))
if 'DFN
QUIT
Begin DoDot:2
+5 SET DA=0
FOR
SET DA=$ORDER(^DGPM("AMV1",IBDT,DFN,DA))
if 'DA
QUIT
DO PROC
End DoDot:2
End DoDot:1
+6 ;
+7 QUIT
+8 ;
DIS ; - Count discharges.
+1 DO CHK^IBTOSUM2
IF $GET(ZTSTOP)
QUIT
+2 SET IBDT=IBBDT-.000000001
+3 FOR
SET IBDT=$ORDER(^DGPM("AMV3",IBDT))
if 'IBDT!(IBDT>(IBEDT+.24))
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV3",IBDT,DFN))
if 'DFN
QUIT
Begin DoDot:2
+5 SET DA=0
FOR
SET DA=$ORDER(^DGPM("AMV3",IBDT,DFN,DA))
if 'DA
QUIT
DO PROC
End DoDot:2
End DoDot:1
+6 ;
+7 QUIT
+8 ;
PROC ; - Process each admission or discharge.
+1 SET DGPM=+$PIECE($GET(^DGPM(DA,0)),U,14)
+2 ; Admissions or discharges.
SET IBCNT(1)=IBCNT(1)+1
+3 SET IBTRN=$ORDER(^IBT(356,"AD",DGPM,0))
IF 'IBTRN
QUIT
+4 ;W !,IBTRND
SET IBTRND=$GET(^IBT(356,+IBTRN,0))
+5 ; Must be an active visit.
IF '$PIECE(IBTRND,U,20)
QUIT
+6 ; Must be insured for visit to count.
IF '$$INSURED^IBCNS1(DFN,IBDT)
QUIT
+7 ; Insured admissions or discharges.
SET IBCNT(2)=IBCNT(2)+1
+8 ; Billables.
SET IBCNT(3,+$PIECE(IBTRND,U,19))=$GET(IBCNT(3,+$PIECE(IBTRND,U,19)))+1
+9 IF $PIECE(IBTRND,U,19)
SET IBCNT(3,"NB")=$GET(IBCNT(3,"NB"))+1
+10 SET X=$PIECE($GET(^IBT(356,+IBTRN,1)),U,7)
IF X>3
SET IBCNT(4)=IBCNT(4)+1
+11 IF X=""
IF $PIECE(IBTRND,U,24)
IF '$PIECE(IBTRND,U,19)
SET IBCNT(4)=IBCNT(4)+1
+12 IF $$APPEAL(IBTRN)
SET IBCNT(80)=IBCNT(80)+1
+13 ;
+14 KILL IBDCNT,IBPCNT
SET IBTRC=0
+15 FOR
SET IBTRC=$ORDER(^IBT(356.2,"C",IBTRN,IBTRC))
if 'IBTRC
QUIT
DO RCNT^IBTOSUM1
+16 IF $DATA(IBPCNT(IBTRN))
SET IBCNT(99)=IBCNT(99)+1
+17 IF $ORDER(IBPCNT(IBTRN,+$ORDER(IBPCNT(IBTRN,0))))
SET IBCNT(13)=IBCNT(13)+1
+18 QUIT
+19 ;
APPEAL(IBTRN) ; - Was this case appealed?
+1 NEW A,X
+2 SET A=0
IF 'IBTRN
GOTO APPEALQ
+3 ; Initial appeal.
SET X=$ORDER(^IBE(356.11,"ACODE",60,0))
+4 IF $ORDER(^IBT(356.2,"ATRTP",IBTRN,X,0))
SET A=1
GOTO APPEALQ
+5 ; Subsequent appeal.
SET X=$ORDER(^IBE(356.11,"ACODE",65,0))
+6 IF $ORDER(^IBT(356.2,"ATRTP",IBTRN,X,0))
SET A=1
GOTO APPEALQ
APPEALQ QUIT A
