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
