- 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 Feb 18, 2025@23:52:16 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