IBOLK ;ALB/AAS - INTEGRATED BILLING - DISPLAY BY BILL NUMBER ;6-MAR-91
;;2.0;INTEGRATED BILLING ;**199,420,433,618**;21-MAR-94;Build 61
;Per VA Directive 6402, this routine should not be modified.
;
% ;
;***
;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
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
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)
; user needs to be able to look-up any iteration ie. K600111 or K600111-01
;S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2),0))
S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2,3),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)),+$P(IBND,"^",4)=52 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
;IB*2.0*618 Corrected display for new Action Types
S IBTYP=$S($E(IBTYP,1,2)="DG":$P(IBTYP," ",2,99),$E(IBTYP,1,3)="PSO":$P(IBTYP," ",2,99),1:IBTYP)
W ?15,$E($P(IBTYP,"^"),1,20)
; display brief description if not a CC action type
I ($P(IBTYP,U)'["CC"),($P(IBTYP,U)'["CHOICE") W ?37,$E($P(IBND,"^",8),1,20)
;end IB*2.0*618
W ?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
W $E($P(IBNAME,"^"),1,20)," ",$P(IBNAME,"^",2),?36,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOLK 5017 printed Jan 18, 2025@03:26:58 Page 2
IBOLK ;ALB/AAS - INTEGRATED BILLING - DISPLAY BY BILL NUMBER ;6-MAR-91
+1 ;;2.0;INTEGRATED BILLING ;**199,420,433,618**;21-MAR-94;Build 61
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
% ;
+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 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+5 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)
+6 ; user needs to be able to look-up any iteration ie. K600111 or K600111-01
+7 ;S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2),0))
+8 SET IBIFN=$ORDER(^DGCR(399,"B",$PIECE(IBIL,"-",2,3),0))
+9 IF '$DATA(^IB("ABIL",IBIL))
IF 'IBIFN
WRITE !!,"Billing has no Record of this Charge ID.",!
GOTO %
+10 ;
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))
IF +$PIECE(IBND,"^",4)=52
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 ;IB*2.0*618 Corrected display for new Action Types
+7 SET IBTYP=$SELECT($EXTRACT(IBTYP,1,2)="DG":$PIECE(IBTYP," ",2,99),$EXTRACT(IBTYP,1,3)="PSO":$PIECE(IBTYP," ",2,99),1:IBTYP)
+8 WRITE ?15,$EXTRACT($PIECE(IBTYP,"^"),1,20)
+9 ; display brief description if not a CC action type
+10 IF ($PIECE(IBTYP,U)'["CC")
IF ($PIECE(IBTYP,U)'["CHOICE")
WRITE ?37,$EXTRACT($PIECE(IBND,"^",8),1,20)
+11 ;end IB*2.0*618
+12 WRITE ?60,$JUSTIFY($PIECE(IBND,"^",6),5)
+13 ;cancel types are decrease adjustments
SET IBCHRG=$PIECE(IBND,"^",7)
IF IBSEQNO=2
SET IBCHRG=(-IBCHRG)
+14 SET X=IBCHRG
SET X2="2$"
SET X3=10
DO COMMA^%DTC
WRITE ?69,X
+15 SET IBTOTL=IBTOTL+IBCHRG
+16 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")
+17 QUIT
+18 ;
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 ;W $E($P(IBNAME,"^"),1,20)," ",$P(IBNAME,"^",2),?38,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG
+2 WRITE $EXTRACT($PIECE(IBNAME,"^"),1,20)," ",$PIECE(IBNAME,"^",2),?36,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG
+3 DO DISP^IBARXEU(DFN,DT,2)
WRITE !
+4 if 'IBFULL
WRITE !,"DATE",?15,"CHARGE TYPE",?37,"BRIEF DESCRIPTION",?62,"UNITS",?73,"CHARGE"
+5 SET IBLINE=""
SET $PIECE(IBLINE,"=",IOM)=""
WRITE !,IBLINE
KILL IBLINE
+6 QUIT
+7 ;
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
