IBOHPT2 ;ALB/EMG - ON HOLD CHARGE INFO/PT CONT. ;JULY 22,1997
;;2.0;INTEGRATED BILLING;**70,95,347,452,747**; 21-MAR-94;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; call to $$CLAIM^BPSBUTL supported by DBIA# 4719
;
REPORT ;
N IBQUIT,IBPAGE,IBNOW,IBLINE,IBLINE2,IBCRT,IBBOT,IBNAME,IBN,IBDT,IBIFN
S IBCRT=0,IBBOT=6,IBQUIT=0 I $E(IOST,1,2)="C-" S IBCRT=1,IBBOT=4
S IBLINE="",$P(IBLINE,"=",86)="||",IBLINE=IBLINE_$E(IBLINE,1,45)
S IBLINE2="",$P(IBLINE2,"-",75)="--"
D NOW^%DTC S Y=X X ^DD("DD") S IBNOW=Y
S IBNAME=$$PT^IBEFUNC(DFN)
I IBCRT W @IOF
LOOP ;
;
S IBPAGE=1 D HEADER Q:IBQUIT
S IBDT="" F S IBDT=$O(^TMP($J,"IB",IBDT)) Q:IBDT=""!(IBDT>0)!(IBQUIT) D
.S IBIFN=0 F S IBIFN=$O(^TMP($J,"IB",IBDT,IBIFN)) Q:'IBIFN!(IBQUIT) D
..D PRNTCHG,PRNTBILL:'IBQUIT
Q
PRNTBILL ; prints bills for a charge
N IB,IB0,IBSTAT,IBCHG,IBPD,C,Y,I,IBT,IBPCT
D:$Y-IBBOT+1>IOSL HEADER Q:IBQUIT
S IB="" F I=1:1 S IB=$O(^TMP($J,"IB",IBDT,IBIFN,IB)) W:'IB&(I=1) ?85,$S(IBCN:"",1:"||"),! D:$Y+IBBOT>IOSL HEADER Q:'IB!(IBQUIT) D
.W ?85,"||"
.S IB0=$G(^DGCR(399,IB,0)) Q:IB0=""
.W ?88,$P(IB0,"^",1) ; bill #
.W ?97,$$BCHGTYPE^IBCU(+IB)
.S IBSTAT=$P($$ARSTATA^IBJTU4(+IB),U,2)
.W ?110,IBSTAT
.S IBT=$J((+^DGCR(399,IB,"U1")-$P(^("U1"),"^",2)),9,2)
.W ?113,IBT ; total charges
.S IBPCT=$P($$BILL^RCJIBFN2(IB),"^",5) W ?128,$J(IBPCT,3,0)_"%",! D:$Y+IBBOT>IOSL HEADER
Q
;
PRNTCHG ; prints a charge
N IBACT,IBAR,IBARIFN,IBARST,IBARTR,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1,IBST,IBARBN,IBAREN
N IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME,X
S IBND=$G(^IB(IBIFN,0)),IBND1=$G(^IB(IBIFN,1)),(IBCN,IBX)=0
S (IBRX,IBRXN,IBRF,IBRDT,IBECME)=0
; action id
S IBACT=+IBND
; type
S X=$P($P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^")," ",2,99)
S IBTYPE=$E($P(X," ",1,$L(X," ")-1),1,6)
; bill #
S IBBILL=$P($P(IBND,"^",11),"-",2)
S IBARBN=$P(IBND,"^",11)
;
; rx info
I $P(IBND,"^",4)["52:" D
. S IBRXN=+$P($P(IBND,"^",4),":",2) ; Rx ien
. S IBRX=$P($P(IBND,"^",8),"-") ; external Rx#
. S IBRF=+$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill
. S IBECME=$P($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6) ; ecme# DBIA# 4719
. I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01) ; refill date
. I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22) ; original fill date
. Q
;
; IBX is a flag checking for visit data on the same day as Rx fill date
S IBX=$$APPT^IBCU3(IBRDT,DFN)
;
; service date
S IBFR=$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",15)))
; release to ar date
S IBAR=$S($P(IBND,"^",11):$$DAT1^IBOUTL($P(IBND1,"^",4)),1:"")
; ib status
S IBST=$E($P($G(^IBE(350.21,+$P(IBND,"^",5),0)),"^",2),1,6)
; charge$
S IBCHG=$J(+$P(IBND,"^",7),9,2)
S IBARTR=$S($P(IBND,"^",12):$P(IBND,"^",12),1:"")
; ar status
S IBAREN=$S(IBARTR]"":$O(^PRCA(430,"B",IBARBN,0)),1:"")
S IBARST=$S(IBAREN]"":$E($P($$STNO^RCJIBFN2($$STAT^RCJIBFN2(IBAREN)),"^"),1,6),1:"")
;
; write data
W IBACT,?15,IBTYPE,?28,IBBILL
I IBRX>0 W ?38,"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),?60,$S(IBECME:"ECME #: "_IBECME,1:""),?85,"||",!
W:IBX=1 ?37,"*" ; any visit data on same day as Rx fill date
W ?38,IBFR,?48,IBAR,?58,IBCHG,?70,IBARST,?79,IBST
I $P(IBND,"^",5)=10 S IBCN=1 W ?85,"|| REASON: ",$P($G(^IBE(350.3,+$P(IBND,"^",10),0)),"^"),!
Q
Q:IBQUIT
I IBCRT,$Y>1 D Q:IBQUIT
.F Q:$Y>(IOSL-3) W !
.N T R " Press RETURN to continue",T:DTIME I '$T!(T["^") S IBQUIT=1 Q
I IBPAGE>1 W !,@IOF
W "List of all HELD bills for ",$P(IBNAME,"^"),?110,IBNOW," PAGE ",IBPAGE,!,"PATIENT CHARGES",?87,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE ; IB*2.0*747
W !,?38,"From/",?48,"Date",?70,"AR",?79,"IB",?85,"||",?110,"AR"
W !,"Action ID",?15,"Type",?28,"Bill#",?38,"Fill Dt",?48,"to AR",?61,"Charge",?70,"Status",?79,"Status",?85,"||",?88,"Bill#",?97,"Classf($Typ)",?110,"ST",?116,"Charge",?126,"% Paid"
W !,IBLINE,!
W:IBIBRX ?36,"'*' = outpt visit on same day as Rx fill date",?85,"||",!,IBLINE,!
S IBPAGE=IBPAGE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHPT2 4125 printed Apr 09, 2024@21:36:34 Page 2
IBOHPT2 ;ALB/EMG - ON HOLD CHARGE INFO/PT CONT. ;JULY 22,1997
+1 ;;2.0;INTEGRATED BILLING;**70,95,347,452,747**; 21-MAR-94;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; call to $$CLAIM^BPSBUTL supported by DBIA# 4719
+5 ;
REPORT ;
+1 NEW IBQUIT,IBPAGE,IBNOW,IBLINE,IBLINE2,IBCRT,IBBOT,IBNAME,IBN,IBDT,IBIFN
+2 SET IBCRT=0
SET IBBOT=6
SET IBQUIT=0
IF $EXTRACT(IOST,1,2)="C-"
SET IBCRT=1
SET IBBOT=4
+3 SET IBLINE=""
SET $PIECE(IBLINE,"=",86)="||"
SET IBLINE=IBLINE_$EXTRACT(IBLINE,1,45)
+4 SET IBLINE2=""
SET $PIECE(IBLINE2,"-",75)="--"
+5 DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
SET IBNOW=Y
+6 SET IBNAME=$$PT^IBEFUNC(DFN)
+7 IF IBCRT
WRITE @IOF
LOOP ;
+1 ;
+2 SET IBPAGE=1
DO HEADER
if IBQUIT
QUIT
+3 SET IBDT=""
FOR
SET IBDT=$ORDER(^TMP($JOB,"IB",IBDT))
if IBDT=""!(IBDT>0)!(IBQUIT)
QUIT
Begin DoDot:1
+4 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^TMP($JOB,"IB",IBDT,IBIFN))
if 'IBIFN!(IBQUIT)
QUIT
Begin DoDot:2
+5 DO PRNTCHG
if 'IBQUIT
DO PRNTBILL
End DoDot:2
End DoDot:1
+6 QUIT
PRNTBILL ; prints bills for a charge
+1 NEW IB,IB0,IBSTAT,IBCHG,IBPD,C,Y,I,IBT,IBPCT
+2 if $Y-IBBOT+1>IOSL
DO HEADER
if IBQUIT
QUIT
+3 SET IB=""
FOR I=1:1
SET IB=$ORDER(^TMP($JOB,"IB",IBDT,IBIFN,IB))
if 'IB&(I=1)
WRITE ?85,$SELECT(IBCN:"",1:"||"),!
if $Y+IBBOT>IOSL
DO HEADER
if 'IB!(IBQUIT)
QUIT
Begin DoDot:1
+4 WRITE ?85,"||"
+5 SET IB0=$GET(^DGCR(399,IB,0))
if IB0=""
QUIT
+6 ; bill #
WRITE ?88,$PIECE(IB0,"^",1)
+7 WRITE ?97,$$BCHGTYPE^IBCU(+IB)
+8 SET IBSTAT=$PIECE($$ARSTATA^IBJTU4(+IB),U,2)
+9 WRITE ?110,IBSTAT
+10 SET IBT=$JUSTIFY((+^DGCR(399,IB,"U1")-$PIECE(^("U1"),"^",2)),9,2)
+11 ; total charges
WRITE ?113,IBT
+12 SET IBPCT=$PIECE($$BILL^RCJIBFN2(IB),"^",5)
WRITE ?128,$JUSTIFY(IBPCT,3,0)_"%",!
if $Y+IBBOT>IOSL
DO HEADER
End DoDot:1
+13 QUIT
+14 ;
PRNTCHG ; prints a charge
+1 NEW IBACT,IBAR,IBARIFN,IBARST,IBARTR,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1,IBST,IBARBN,IBAREN
+2 NEW IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME,X
+3 SET IBND=$GET(^IB(IBIFN,0))
SET IBND1=$GET(^IB(IBIFN,1))
SET (IBCN,IBX)=0
+4 SET (IBRX,IBRXN,IBRF,IBRDT,IBECME)=0
+5 ; action id
+6 SET IBACT=+IBND
+7 ; type
+8 SET X=$PIECE($PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")," ",2,99)
+9 SET IBTYPE=$EXTRACT($PIECE(X," ",1,$LENGTH(X," ")-1),1,6)
+10 ; bill #
+11 SET IBBILL=$PIECE($PIECE(IBND,"^",11),"-",2)
+12 SET IBARBN=$PIECE(IBND,"^",11)
+13 ;
+14 ; rx info
+15 IF $PIECE(IBND,"^",4)["52:"
Begin DoDot:1
+16 ; Rx ien
SET IBRXN=+$PIECE($PIECE(IBND,"^",4),":",2)
+17 ; external Rx#
SET IBRX=$PIECE($PIECE(IBND,"^",8),"-")
+18 ; fill# or 0 for original fill
SET IBRF=+$PIECE($PIECE(IBND,"^",4),":",3)
+19 ; ecme# DBIA# 4719
SET IBECME=$PIECE($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6)
+20 ; refill date
IF IBRF
SET IENS=+IBRF
SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01)
+21 ; original fill date
IF 'IBRF
SET IENS=+IBRXN
SET IBRDT=$$FILE^IBRXUTL(+IENS,22)
+22 QUIT
End DoDot:1
+23 ;
+24 ; IBX is a flag checking for visit data on the same day as Rx fill date
+25 SET IBX=$$APPT^IBCU3(IBRDT,DFN)
+26 ;
+27 ; service date
+28 SET IBFR=$$DAT1^IBOUTL($SELECT(IBRXN>0:IBRDT,1:$PIECE(IBND,"^",15)))
+29 ; release to ar date
+30 SET IBAR=$SELECT($PIECE(IBND,"^",11):$$DAT1^IBOUTL($PIECE(IBND1,"^",4)),1:"")
+31 ; ib status
+32 SET IBST=$EXTRACT($PIECE($GET(^IBE(350.21,+$PIECE(IBND,"^",5),0)),"^",2),1,6)
+33 ; charge$
+34 SET IBCHG=$JUSTIFY(+$PIECE(IBND,"^",7),9,2)
+35 SET IBARTR=$SELECT($PIECE(IBND,"^",12):$PIECE(IBND,"^",12),1:"")
+36 ; ar status
+37 SET IBAREN=$SELECT(IBARTR]"":$ORDER(^PRCA(430,"B",IBARBN,0)),1:"")
+38 SET IBARST=$SELECT(IBAREN]"":$EXTRACT($PIECE($$STNO^RCJIBFN2($$STAT^RCJIBFN2(IBAREN)),"^"),1,6),1:"")
+39 ;
+40 ; write data
+41 WRITE IBACT,?15,IBTYPE,?28,IBBILL
+42 IF IBRX>0
WRITE ?38,"Rx #: "_IBRX_$SELECT(IBRF>0:"("_IBRF_")",1:""),?60,$SELECT(IBECME:"ECME #: "_IBECME,1:""),?85,"||",!
+43 ; any visit data on same day as Rx fill date
if IBX=1
WRITE ?37,"*"
+44 WRITE ?38,IBFR,?48,IBAR,?58,IBCHG,?70,IBARST,?79,IBST
+45 IF $PIECE(IBND,"^",5)=10
SET IBCN=1
WRITE ?85,"|| REASON: ",$PIECE($GET(^IBE(350.3,+$PIECE(IBND,"^",10),0)),"^"),!
+46 QUIT
+1 if IBQUIT
QUIT
+2 IF IBCRT
IF $Y>1
Begin DoDot:1
+3 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+4 NEW T
READ " Press RETURN to continue",T:DTIME
IF '$TEST!(T["^")
SET IBQUIT=1
QUIT
End DoDot:1
if IBQUIT
QUIT
+5 IF IBPAGE>1
WRITE !,@IOF
+6 ; IB*2.0*747
WRITE "List of all HELD bills for ",$PIECE(IBNAME,"^"),?110,IBNOW," PAGE ",IBPAGE,!,"PATIENT CHARGES",?87,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE
+7 WRITE !,?38,"From/",?48,"Date",?70,"AR",?79,"IB",?85,"||",?110,"AR"
+8 WRITE !,"Action ID",?15,"Type",?28,"Bill#",?38,"Fill Dt",?48,"to AR",?61,"Charge",?70,"Status",?79,"Status",?85,"||",?88,"Bill#",?97,"Classf($Typ)",?110,"ST",?116,"Charge",?126,"% Paid"
+9 WRITE !,IBLINE,!
+10 if IBIBRX
WRITE ?36,"'*' = outpt visit on same day as Rx fill date",?85,"||",!,IBLINE,!
+11 SET IBPAGE=IBPAGE+1
+12 QUIT
