IBTOSA.m

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