IBTOSA ;ALB/AAS - CLAIMS TRACKING SCHEDULED ADMISSION REPORT ; 27-OCT-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
% I '$D(DT) D DT^DICRW
W !!,"Scheduled Admissions Report"
;
DATE ; -- select date
W !! D DATE^IBOUTL
I IBBDT=""!(IBEDT="") G END
;
DEV ; -- select device, run option
W !!,"You will need a 132 column printer for this report!",!
S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) S ZTRTN="DQ^IBTOSA",ZTSAVE("IB*")="",ZTDESC="IB - scheduled Admissions Report" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
;
U IO
S X=132 X ^%ZOSF("RM")
DQ D PRINT G END
Q
;
END ; -- Clean up
K ^TMP($J) W !
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
K I,J,X,Y,DFN,%ZIS,VA,IBTRN,IBTRND,IBPAG,IBHDT,IBDT,IBBDT,IBEDT,IBQUIT
Q
;
PRINT ; -- print one billing report from ct
S IBPAG=0,IBHDT=$$HTE^XLFDT($H,1),IBQUIT=0
S IBTSBDT=IBBDT-.1,IBTSEDT=IBEDT+.9 D EN^IBTRKR2
K ^TMP($J)
;
D FIX
S IBDT=IBBDT-.1
F S IBDT=$O(^IBT(356,"D",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.24))!(IBQUIT) S IBTRN=0 F S IBTRN=$O(^IBT(356,"D",IBDT,IBTRN)) Q:'IBTRN!(IBQUIT) D
.S IBTRND=$G(^IBT(356,IBTRN,0))
.Q:'$P(IBTRND,"^",20) ; inactive
.Q:+IBDT<IBBDT
.I $P($G(^IBE(356.6,+$P(IBTRND,"^",18),0)),"^",3)=1,$P(IBTRND,"^",7)=1,$$INSURED^IBCNS1($P(IBTRND,"^",2),IBDT),$$SCH(IBTRN) D SET
;
PR D HDR
I '$D(^TMP($J,"IBSCH")) W !!,"No Scheduled Admission found in date range",! Q
S IBNAM="",IBCNT=0
F S IBNAM=$O(^TMP($J,"IBSCH",IBNAM)) Q:IBNAM=""!(IBQUIT) S IBDT=0 F S IBDT=$O(^TMP($J,"IBSCH",IBNAM,IBDT)) Q:'IBDT!(IBQUIT) S IBTRN=0 F S IBTRN=$O(^TMP($J,"IBSCH",IBNAM,IBDT,IBTRN)) Q:'IBTRN!(IBQUIT) S IBTRND=^(IBTRN) D ONE
;
Q:IBQUIT
W !!,"------------------"
W !,"TOTAL = ",IBCNT
I $D(ZTQUEUED) G END
Q
;
ONE ; -- Print one patients data
Q:IBQUIT
I IOSL<($Y+5) D HDR Q:IBQUIT
S IBCNT=IBCNT+1
S DFN=$P(IBTRND,"^",2) D PID^VADPT
W !,$E(IBNAM,1,27),?30,VA("PID"),?45,$$DAT1^IBOUTL($P(IBTRND,"^",6),"2P")
W ?66,$S('$P(IBTRND,"^",19):"YES",1:$E("NO - "_$P($G(^IBE(356.8,+$P(IBTRND,"^",19),0)),"^"),1,27))
W ?100,$E($P($G(^DPT(DFN,.1)),"^"),1,12),?115,$E($$EXPAND^IBTRE(356,.07,$P(IBTRND,"^",7)),1,15)
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 !,"Scheduled Admissions with Insurance",?(IOM-33),"Page ",IBPAG," ",IBHDT
W !,"For Period beginning on ",$$DAT1^IBOUTL(IBBDT)," to ",$$DAT1^IBOUTL(IBEDT)
W !,"Patient",?30,"Pt. ID",?45,"Adm. Date",?66,"Billable",?100,"Ward",?115,"Type"
W !,$TR($J(" ",IOM)," ","-")
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,IBQUIT=1 W !!,"....task stop* ed at user request" Q
Q
;
SET ; -- set tmp array
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,IBQUIT=1 D HDR W !!,"....task stop* ed at user request" Q
S ^TMP($J,"IBSCH",$P(^DPT(+$P(IBTRND,"^",2),0),"^"),IBDT,IBTRN)=IBTRND
Q
;
SCH(IBTRN) ; -- is patient either admitted or still scheduled
;
N IBX,IBTRND S IBX=1
S IBTRND=$G(^IBT(356,+IBTRN,0))
I '$P(IBTRND,"^",32) G SCHQ
I $P(IBTRND,"^",5) G SCHQ
S X=$G(^DGS(41.1,+$P(IBTRND,"^",32),0)) I X=""!($P(X,"^",13)) D S IBX=0
.N DA,DR,DIC,DIE
.S DIE="^IBT(356,",DR=".2////0",DA=IBTRN
.D ^DIE
SCHQ Q IBX
;
FIX ; -- find bad episode dates and fix
S IBDT=DT
F S IBDT=$O(^IBT(356,"D",IBDT)) Q:'IBDT S IBTRN=0 F S IBTRN=$O(^IBT(356,"D",IBDT,IBTRN)) Q:'IBTRN D F1(IBTRN)
Q
;
F1(IBTRN) ; fix EPISODE DATE
N IBDT,DA,DR,DIC,DIE
Q:'$G(IBTRN)
Q:$G(^IBT(356,+IBTRN,0))=""
S IBDT=$P(^IBT(356,+IBTRN,0),"^",6)
I +IBDT'=IBDT,$E(IBDT,$L(IBDT))=0 S IBDT=+IBDT,DA=IBTRN,DR=".06////"_IBDT,DIE="^IBT(356," D ^DIE
Q
IBTOSA ;ALB/AAS - CLAIMS TRACKING SCHEDULED ADMISSION REPORT ; 27-OCT-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
% IF '$DATA(DT)
DO DT^DICRW
+1 WRITE !!,"Scheduled Admissions Report"
+2 ;
DATE ; -- select date
+1 WRITE !!
DO DATE^IBOUTL
+2 IF IBBDT=""!(IBEDT="")
GOTO END
+3 ;
DEV ; -- select device, run option
+1 WRITE !!,"You will need a 132 column printer for this report!",!
+2 SET %ZIS="QM"
DO ^%ZIS
IF POP
GOTO END
+3 IF $DATA(IO("Q"))
SET ZTRTN="DQ^IBTOSA"
SET ZTSAVE("IB*")=""
SET ZTDESC="IB - scheduled Admissions Report"
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO HOME^%ZIS
GOTO END
+4 ;
+5 USE IO
+6 SET X=132
XECUTE ^%ZOSF("RM")
DQ DO PRINT
GOTO END
+1 QUIT
+2 ;
END ; -- Clean up
+1 KILL ^TMP($JOB)
WRITE !
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 DO ^%ZISC
+4 KILL I,J,X,Y,DFN,%ZIS,VA,IBTRN,IBTRND,IBPAG,IBHDT,IBDT,IBBDT,IBEDT,IBQUIT
+5 QUIT
+6 ;
PRINT ; -- print one billing report from ct
+1 SET IBPAG=0
SET IBHDT=$$HTE^XLFDT($HOROLOG,1)
SET IBQUIT=0
+2 SET IBTSBDT=IBBDT-.1
SET IBTSEDT=IBEDT+.9
DO EN^IBTRKR2
+3 KILL ^TMP($JOB)
+4 ;
+5 DO FIX
+6 SET IBDT=IBBDT-.1
+7 FOR
SET IBDT=$ORDER(^IBT(356,"D",IBDT))
IF 'IBDT!(IBDT>(IBEDT+.24))!(IBQUIT)
QUIT
SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"D",IBDT,IBTRN))
IF 'IBTRN!(IBQUIT)
QUIT
Begin DoDot:1
+8 SET IBTRND=$GET(^IBT(356,IBTRN,0))
+9 ; inactive
IF '$PIECE(IBTRND,"^",20)
QUIT
+10 IF +IBDT<IBBDT
QUIT
+11 IF $PIECE($GET(^IBE(356.6,+$PIECE(IBTRND,"^",18),0)),"^",3)=1
IF $PIECE(IBTRND,"^",7)=1
IF $$INSURED^IBCNS1($PIECE(IBTRND,"^",2),IBDT)
IF $$SCH(IBTRN)
DO SET
End DoDot:1
+12 ;
PR DO HDR
+1 IF '$DATA(^TMP($JOB,"IBSCH"))
WRITE !!,"No Scheduled Admission found in date range",!
QUIT
+2 SET IBNAM=""
SET IBCNT=0
+3 FOR
SET IBNAM=$ORDER(^TMP($JOB,"IBSCH",IBNAM))
IF IBNAM=""!(IBQUIT)
QUIT
SET IBDT=0
FOR
SET IBDT=$ORDER(^TMP($JOB,"IBSCH",IBNAM,IBDT))
IF 'IBDT!(IBQUIT)
QUIT
SET IBTRN=0
FOR
SET IBTRN=$ORDER(^TMP($JOB,"IBSCH",IBNAM,IBDT,IBTRN))
IF 'IBTRN!(IBQUIT)
QUIT
SET IBTRND=^(IBTRN)
DO ONE
+4 ;
+5 IF IBQUIT
QUIT
+6 WRITE !!,"------------------"
+7 WRITE !,"TOTAL = ",IBCNT
+8 IF $DATA(ZTQUEUED)
GOTO END
+9 QUIT
+10 ;
ONE ; -- Print one patients data
+1 IF IBQUIT
QUIT
+2 IF IOSL<($Y+5)
DO HDR
IF IBQUIT
QUIT
+3 SET IBCNT=IBCNT+1
+4 SET DFN=$PIECE(IBTRND,"^",2)
DO PID^VADPT
+5 WRITE !,$EXTRACT(IBNAM,1,27),?30,VA("PID"),?45,$$DAT1^IBOUTL($PIECE(IBTRND,"^",6),"2P")
+6 WRITE ?66,$SELECT('$PIECE(IBTRND,"^",19):"YES",1:$EXTRACT("NO - "_$PIECE($GET(^IBE(356.8,+$PIECE(IBTRND,"^",19),0)),"^"),1,27))
+7 WRITE ?100,$EXTRACT($PIECE($GET(^DPT(DFN,.1)),"^"),1,12),?115,$EXTRACT($$EXPAND^IBTRE(356,.07,$PIECE(IBTRND,"^",7)),1,15)
+8 QUIT
+9 ;
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 !,"Scheduled Admissions with Insurance",?(IOM-33),"Page ",IBPAG," ",IBHDT
+6 WRITE !,"For Period beginning on ",$$DAT1^IBOUTL(IBBDT)," to ",$$DAT1^IBOUTL(IBEDT)
+7 WRITE !,"Patient",?30,"Pt. ID",?45,"Adm. Date",?66,"Billable",?100,"Ward",?115,"Type"
+8 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+9 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET IBQUIT=1
WRITE !!,"....task stop* ed at user request"
QUIT
+10 QUIT
+11 ;
SET ; -- set tmp array
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET IBQUIT=1
DO HDR
WRITE !!,"....task stop* ed at user request"
QUIT
+2 SET ^TMP($JOB,"IBSCH",$PIECE(^DPT(+$PIECE(IBTRND,"^",2),0),"^"),IBDT,IBTRN)=IBTRND
+3 QUIT
+4 ;
SCH(IBTRN) ; -- is patient either admitted or still scheduled
+1 ;
+2 NEW IBX,IBTRND
SET IBX=1
+3 SET IBTRND=$GET(^IBT(356,+IBTRN,0))
+4 IF '$PIECE(IBTRND,"^",32)
GOTO SCHQ
+5 IF $PIECE(IBTRND,"^",5)
GOTO SCHQ
+6 SET X=$GET(^DGS(41.1,+$PIECE(IBTRND,"^",32),0))
IF X=""!($PIECE(X,"^",13))
Begin DoDot:1
+7 NEW DA,DR,DIC,DIE
+8 SET DIE="^IBT(356,"
SET DR=".2////0"
SET DA=IBTRN
+9 DO ^DIE
End DoDot:1
SET IBX=0
SCHQ QUIT IBX
+1 ;
FIX ; -- find bad episode dates and fix
+1 SET IBDT=DT
+2 FOR
SET IBDT=$ORDER(^IBT(356,"D",IBDT))
IF 'IBDT
QUIT
SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"D",IBDT,IBTRN))
IF 'IBTRN
QUIT
DO F1(IBTRN)
+3 QUIT
+4 ;
F1(IBTRN) ; fix EPISODE DATE
+1 NEW IBDT,DA,DR,DIC,DIE
+2 IF '$GET(IBTRN)
QUIT
+3 IF $GET(^IBT(356,+IBTRN,0))=""
QUIT
+4 SET IBDT=$PIECE(^IBT(356,+IBTRN,0),"^",6)
+5 IF +IBDT'=IBDT
IF $EXTRACT(IBDT,$LENGTH(IBDT))=0
SET IBDT=+IBDT
SET DA=IBTRN
SET DR=".06////"_IBDT
SET DIE="^IBT(356,"
DO ^DIE
+6 QUIT
