IBOLK.m

IBOLK	;ALB/AAS - INTEGRATED BILLING - DISPLAY BY BILL NUMBER ; 6-MAR-91

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;

%	;

	;***

	;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock

	;S XRTL=$ZU(0),XRTN="IBOLK-1" D T0^%ZOSV ;start rt clock

	S DIC("A")="Select CHARGE ID or PATIENT NAME: ",DIC="^PRCA(430,",DIC(0)="AEQM" D ^DIC K DIC G END1:+Y<1 S IBIL=$P(Y,"^",2)

	S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2),0))

	I '$D(^IB("ABIL",IBIL)),'IBIFN W !!,"Billing has no Record of this Charge ID.",! G %

	;

BRIEF	R !,"(B)rief or (F)ull Inquiry: B// ",X:DTIME G:X="^"!('$T) END1 S:X="" X="B" S X=$E(X)

	I "BFbf"'[X D  G BRIEF

	. W !!?5,"Enter: '<CR>'  -  To select the Brief Inquiry."

	. W !?12,"'F'     -  To select the Full Inquiry.  This option will"

	. W !?23,"include the Address Inquiry, and more detailed"

	. W !?23,"information for Pharmacy Co-Pay bills."

	. W !?12,"'^'     -  To quit this option.",!

	W $S("Bb"[X:"   BRIEF",1:"   FULL") S IBFULL="Ff"[X

	I IBIFN S IBAC=8,IBQUIT=0

	;

DEV	W ! S %ZIS="QM",%ZIS("A")="Output Device: " D ^%ZIS G:POP END

	I $D(IO("Q")) D  D ^%ZTLOAD K IO("Q") D HOME^%ZIS W ! G %

	. S ZTDESC="IB Print Actions by Bill Number"

	. S ZTRTN=$S(IBIFN:"VIEW^IBCNQ",1:"EN^IBOLK")

	. S ZTSAVE("IBFULL")="",ZTSAVE("IBIL")="",ZTSAVE("IBIFN")=""

	. I IBIFN F I="IBAC","IBQUIT" S ZTSAVE(I)=""

	;

	U IO

	;***

	;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock

	I 'IBIFN D EN G %

	D VIEW^IBCNQ,Q^IBCNQ,END1 G %

	;

EN	;  -Entry to display IB Action data for an AR Bill number

	;  -Input   IBIL = external form of bill number, ie 500-K10001

	;           IBFULL = 1 for full profile logic, 0 for brief description

	;***

	;S XRTL=$ZU(0),XRTN="IBOLK-2" D T0^%ZOSV ;start rt clock

	S IBN=$O(^IB("ABIL",IBIL,"")) G:'$D(^IB(IBN,0)) ENQ

	S IBTOTL=0,IBQUIT="",IBPAG=0 D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12)) D HDR

	;

	S IBN="" F IBI=0:0 S IBN=$O(^IB("ABIL",IBIL,IBN)) Q:'IBN  I $D(^IB(IBN,0)) D LINE Q:IBQUIT

	I 'IBQUIT D TOTAL,PAUSE,^IBOLK1:IBFULL&('IBQUIT)

ENQ	D END Q

	;

LINE	;  -find data for one line, write line, accumulate totals

	I '$D(IBTRAN),$Y>(IOSL-5) D PAUSE Q:IBQUIT  D HDR1

	S IBND=^IB(IBN,0),IBND1=$G(^(1))

	I IBFULL,$D(^IBE(350.1,+$P(IBND,"^",3),30)) W ! S X1=$P($P($P(IBND,"^",4),";",1),":",2),X2=$P($P($P(IBND,"^",4),";",2),":",2),X=X1_"^"_$S(X2:X2,1:0) X ^(30)

	S IBTYP=$G(^IBE(350.1,+$P(IBND,"^",3),0)),IBSEQNO=$P(IBTYP,"^",5)

	W ! S Y=$P($P(IBND1,"^",2),".",1) D DT^DIQ

	W ?15,$E($P($P(IBTYP,"^")," ",2,99),1,20),?37,$E($P(IBND,"^",8),1,20),?60,$J($P(IBND,"^",6),5)

	S IBCHRG=$P(IBND,"^",7) I IBSEQNO=2 S IBCHRG=(-IBCHRG) ;cancel types are decrease adjustments

	S X=IBCHRG,X2="2$",X3=10 D COMMA^%DTC W ?69,X

	S IBTOTL=IBTOTL+IBCHRG

	I $P(IBND,"^",10),IBSEQNO=2 W !,?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,$P(IBND,"^",10),0)):$P(^(0),"^"),1:"UNKNOWN")

	Q

	;

HDR	S IBND=^IB(IBN,0),DFN=+$P(IBND,"^",2),IBNAME=$$PT^IBEFUNC(DFN)

HDR1	S IBPAG=IBPAG+1 I $E(IOST,1,2)["C-"!(IBPAG>1) W @IOF,*13

	W $E($P(IBNAME,"^"),1,20),"   ",$P(IBNAME,"^",2),?38,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG

	D DISP^IBARXEU(DFN,DT,2) W !

	W:'IBFULL !,"DATE",?15,"CHARGE TYPE",?37,"BRIEF DESCRIPTION",?62,"UNITS",?73,"CHARGE"

	S IBLINE="",$P(IBLINE,"=",IOM)="" W !,IBLINE K IBLINE

	Q

	;

TOTAL	W !?67,"------------" S X=IBTOTL,X2="2$",X3=12 D COMMA^%DTC

	W !,?67,X

	Q

	;

PAUSE	Q:$E(IOST,1,2)'["C-"

	F IBJ=$Y:1:(IOSL-4) W !

	S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT

	Q

	;

END1	K IBFULL

END	W !

	;***

	;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock

	I $D(ZTQUEUED) S ZTREQ="@" Q

	K X,X2,X3,Y,DFN,IBIFN,IBAC,I,IB,IBIL,IBI,IBJ,IBNAME,IBLINE,IBN,IBND,IBND1,IBCHRG,IBSEQNO,IBTYP,IBTOTL,ZTSK,IBHDT,IBPAG,IBQUIT,DN,D0,DUOUT,DTOUT,VA,VADM,VAERR

	D ^%ZISC

	Q

	;

ENF	;  -entry point for AR to print full profile for IB actions for

	;   an ar transaction number.

	;  -input   x = ar transaction number ($p(^ib(ibn,0),u,12)

	;

	S IBFULL=1

	;

ENB	;  -entry point for AR to print brief profile for IB actions for

	;   an ar transaction number.

	;  -input   x = ar transaction number

	;

	S IBTOTL=0,IBPAG=0,IBQUIT="" S:'$D(IBFULL) IBFULL=0

	S IBTRAN=X

	S IBN="" F  S IBN=$O(^IB("AT",IBTRAN,IBN)) Q:IBN=""  D LINE

	K D0,DN,X,X2,X3,Y,IBFULL,IBTOTL,IBPAG,IBQUIT,IBTRAN,IBN,IBND,IBND1,IBSEQNO,IBTYP,IBCHRG

	Q

IBOLK     ;ALB/AAS - INTEGRATED BILLING - DISPLAY BY BILL NUMBER ; 6-MAR-91

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;

%         ;

 +1       ;***

 +2       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock

 +3       ;S XRTL=$ZU(0),XRTN="IBOLK-1" D T0^%ZOSV ;start rt clock

 +4        SET DIC("A")="Select CHARGE ID or PATIENT NAME: "

           SET DIC="^PRCA(430,"

           SET DIC(0)="AEQM"

           DO ^DIC

           KILL DIC

           IF +Y<1

               GOTO END1

           SET IBIL=$PIECE(Y,"^",2)

 +5        SET IBIFN=$ORDER(^DGCR(399,"B",$PIECE(IBIL,"-",2),0))

 +6        IF '$DATA(^IB("ABIL",IBIL))

               IF 'IBIFN

                   WRITE !!,"Billing has no Record of this Charge ID.",!

                   GOTO %

 +7       ;

BRIEF      READ !,"(B)rief or (F)ull Inquiry: B// ",X:DTIME

           IF X="^"!('$TEST)

               GOTO END1

           IF X=""

               SET X="B"

           SET X=$EXTRACT(X)

 +1        IF "BFbf"'[X

               Begin DoDot:1

 +2                WRITE !!?5,"Enter: '<CR>'  -  To select the Brief Inquiry."

 +3                WRITE !?12,"'F'     -  To select the Full Inquiry.  This option will"

 +4                WRITE !?23,"include the Address Inquiry, and more detailed"

 +5                WRITE !?23,"information for Pharmacy Co-Pay bills."

 +6                WRITE !?12,"'^'     -  To quit this option.",!

               End DoDot:1

               GOTO BRIEF

 +7        WRITE $SELECT("Bb"[X:"   BRIEF",1:"   FULL")

           SET IBFULL="Ff"[X

 +8        IF IBIFN

               SET IBAC=8

               SET IBQUIT=0

 +9       ;

DEV        WRITE !

           SET %ZIS="QM"

           SET %ZIS("A")="Output Device: "

           DO ^%ZIS

           IF POP

               GOTO END

 +1        IF $DATA(IO("Q"))

               Begin DoDot:1

 +2                SET ZTDESC="IB Print Actions by Bill Number"

 +3                SET ZTRTN=$SELECT(IBIFN:"VIEW^IBCNQ",1:"EN^IBOLK")

 +4                SET ZTSAVE("IBFULL")=""

                   SET ZTSAVE("IBIL")=""

                   SET ZTSAVE("IBIFN")=""

 +5                IF IBIFN

                       FOR I="IBAC","IBQUIT"

                           SET ZTSAVE(I)=""

               End DoDot:1

               DO ^%ZTLOAD

               KILL IO("Q")

               DO HOME^%ZIS

               WRITE !

               GOTO %

 +6       ;

 +7        USE IO

 +8       ;***

 +9       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock

 +10       IF 'IBIFN

               DO EN

               GOTO %

 +11       DO VIEW^IBCNQ

           DO Q^IBCNQ

           DO END1

           GOTO %

 +12      ;

EN        ;  -Entry to display IB Action data for an AR Bill number

 +1       ;  -Input   IBIL = external form of bill number, ie 500-K10001

 +2       ;           IBFULL = 1 for full profile logic, 0 for brief description

 +3       ;***

 +4       ;S XRTL=$ZU(0),XRTN="IBOLK-2" D T0^%ZOSV ;start rt clock

 +5        SET IBN=$ORDER(^IB("ABIL",IBIL,""))

           IF '$DATA(^IB(IBN,0))

               GOTO ENQ

 +6        SET IBTOTL=0

           SET IBQUIT=""

           SET IBPAG=0

           DO NOW^%DTC

           SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))

           DO HDR

 +7       ;

 +8        SET IBN=""

           FOR IBI=0:0

               SET IBN=$ORDER(^IB("ABIL",IBIL,IBN))

               IF 'IBN

                   QUIT 

               IF $DATA(^IB(IBN,0))

                   DO LINE

                   IF IBQUIT

                       QUIT 

 +9        IF 'IBQUIT

               DO TOTAL

               DO PAUSE

               IF IBFULL&('IBQUIT)

                   DO ^IBOLK1

ENQ        DO END

           QUIT 

 +1       ;

LINE      ;  -find data for one line, write line, accumulate totals

 +1        IF '$DATA(IBTRAN)

               IF $Y>(IOSL-5)

                   DO PAUSE

                   IF IBQUIT

                       QUIT 

                   DO HDR1

 +2        SET IBND=^IB(IBN,0)

           SET IBND1=$GET(^(1))

 +3        IF IBFULL

               IF $DATA(^IBE(350.1,+$PIECE(IBND,"^",3),30))

                   WRITE !

                   SET X1=$PIECE($PIECE($PIECE(IBND,"^",4),";",1),":",2)

                   SET X2=$PIECE($PIECE($PIECE(IBND,"^",4),";",2),":",2)

                   SET X=X1_"^"_$SELECT(X2:X2,1:0)

                   XECUTE ^(30)

 +4        SET IBTYP=$GET(^IBE(350.1,+$PIECE(IBND,"^",3),0))

           SET IBSEQNO=$PIECE(IBTYP,"^",5)

 +5        WRITE !

           SET Y=$PIECE($PIECE(IBND1,"^",2),".",1)

           DO DT^DIQ

 +6        WRITE ?15,$EXTRACT($PIECE($PIECE(IBTYP,"^")," ",2,99),1,20),?37,$EXTRACT($PIECE(IBND,"^",8),1,20),?60,$JUSTIFY($PIECE(IBND,"^",6),5)

 +7       ;cancel types are decrease adjustments

           SET IBCHRG=$PIECE(IBND,"^",7)

           IF IBSEQNO=2

               SET IBCHRG=(-IBCHRG)

 +8        SET X=IBCHRG

           SET X2="2$"

           SET X3=10

           DO COMMA^%DTC

           WRITE ?69,X

 +9        SET IBTOTL=IBTOTL+IBCHRG

 +10       IF $PIECE(IBND,"^",10)

               IF IBSEQNO=2

                   WRITE !,?5,"Charge Removal Reason: ",$SELECT($DATA(^IBE(350.3,$PIECE(IBND,"^",10),0)):$PIECE(^(0),"^"),1:"UNKNOWN")

 +11       QUIT 

 +12      ;

HDR        SET IBND=^IB(IBN,0)

           SET DFN=+$PIECE(IBND,"^",2)

           SET IBNAME=$$PT^IBEFUNC(DFN)

HDR1       SET IBPAG=IBPAG+1

           IF $EXTRACT(IOST,1,2)["C-"!(IBPAG>1)

               WRITE @IOF,*13

 +1        WRITE $EXTRACT($PIECE(IBNAME,"^"),1,20),"   ",$PIECE(IBNAME,"^",2),?38,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG

 +2        DO DISP^IBARXEU(DFN,DT,2)

           WRITE !

 +3        IF 'IBFULL

               WRITE !,"DATE",?15,"CHARGE TYPE",?37,"BRIEF DESCRIPTION",?62,"UNITS",?73,"CHARGE"

 +4        SET IBLINE=""

           SET $PIECE(IBLINE,"=",IOM)=""

           WRITE !,IBLINE

           KILL IBLINE

 +5        QUIT 

 +6       ;

TOTAL      WRITE !?67,"------------"

           SET X=IBTOTL

           SET X2="2$"

           SET X3=12

           DO COMMA^%DTC

 +1        WRITE !,?67,X

 +2        QUIT 

 +3       ;

PAUSE      IF $EXTRACT(IOST,1,2)'["C-"

               QUIT 

 +1        FOR IBJ=$Y:1:(IOSL-4)

               WRITE !

 +2        SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)!($DATA(DUOUT))

               SET IBQUIT=1

               KILL DIRUT,DTOUT,DUOUT

 +3        QUIT 

 +4       ;

END1       KILL IBFULL

END        WRITE !

 +1       ;***

 +2       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock

 +3        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT 

 +4        KILL X,X2,X3,Y,DFN,IBIFN,IBAC,I,IB,IBIL,IBI,IBJ,IBNAME,IBLINE,IBN,IBND,IBND1,IBCHRG,IBSEQNO,IBTYP,IBTOTL,ZTSK,IBHDT,IBPAG,IBQUIT,DN,D0,DUOUT,DTOUT,VA,VADM,VAERR

 +5        DO ^%ZISC

 +6        QUIT 

 +7       ;

ENF       ;  -entry point for AR to print full profile for IB actions for

 +1       ;   an ar transaction number.

 +2       ;  -input   x = ar transaction number ($p(^ib(ibn,0),u,12)

 +3       ;

 +4        SET IBFULL=1

 +5       ;

ENB       ;  -entry point for AR to print brief profile for IB actions for

 +1       ;   an ar transaction number.

 +2       ;  -input   x = ar transaction number

 +3       ;

 +4        SET IBTOTL=0

           SET IBPAG=0

           SET IBQUIT=""

           IF '$DATA(IBFULL)

               SET IBFULL=0

 +5        SET IBTRAN=X

 +6        SET IBN=""

           FOR 

               SET IBN=$ORDER(^IB("AT",IBTRAN,IBN))

               IF IBN=""

                   QUIT 

               DO LINE

 +7        KILL D0,DN,X,X2,X3,Y,IBFULL,IBTOTL,IBPAG,IBQUIT,IBTRAN,IBN,IBND,IBND1,IBSEQNO,IBTYP,IBCHRG

 +8        QUIT