- IBOHDT1 ;ALB/EMG - REPORT OF CHARGES ON HOLD > 60 DAYS-CONT ;FEB 18 1997
- ;;2.0;INTEGRATED BILLING;**70,95,347,452,618**;21-MAR-94;Build 61
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- REPORT ;
- N IBQUIT,IBPAGE,IBNOW,IBLINE,IBCRT,IBBOT,DFN,IBNAME,IBATYPE,IBN,X
- S IBCRT=0,IBBOT=6,IBQUIT=0 I $E(IOST,1,2)="C-" S IBCRT=1,IBBOT=4
- S IBLINE="",$P(IBLINE,"=",96)="||",IBLINE=IBLINE_$E(IBLINE,1,32)
- S IBNOW=$$FMTE^XLFDT($$NOW^XLFDT)
- I IBCRT W @IOF
- LOOP ;
- S IBPAGE=1 D HEADER Q:IBQUIT
- S IBNAME="" F S IBNAME=$O(^TMP($J,"HOLD",IBNAME)) Q:IBNAME="" S DFN=0 F S DFN=$O(^TMP($J,"HOLD",IBNAME,DFN)) Q:DFN="" D PRNTPAT Q:IBQUIT S IBATYPE="" F S IBATYPE=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE)) Q:IBATYPE="" D
- .S IBN=0 F S IBN=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN)) Q:'IBN!(IBQUIT) D
- ..D PRNTCHG,PRNTBILL:'IBQUIT
- Q
- PRNTBILL ; prints bills for a charge
- N IB,IB0,IBSTAT,IBCHG,IBPD,Y,I,IBT
- D:$Y-IBBOT+1>IOSL HEADER Q:IBQUIT
- S IB="" F I=1:1 S IB=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN,IB)) W:'IB&(I<2) ?90,"||",! D:$Y+IBBOT>IOSL HEADER Q:'IB!(IBQUIT) D
- .W ?95,"||"
- .S IB0=$G(^DGCR(399,IB,0)) Q:IB0=""
- .W ?98,$P(IB0,"^",1) ; bill #
- .S IBSTAT=$$STA^PRCAFN(IB)
- .W:+IBSTAT>0 ?106,$E($P(IBSTAT,"^",2),1,3)
- .S IBT=$J((+^DGCR(399,IB,"U1")-$P(^("U1"),"^",2)),9,2)
- .W ?113,IBT ; total charges
- .S IBPD=$$TPR^PRCAFN(IB) S:IBPD<0 IBPD="" S IBPD=$J(IBPD,9,2) W ?122,IBPD,! D:$Y+IBBOT>IOSL HEADER
- Q
- PRNTPAT ; prints patient data
- N VAERR,VADM,IBSSN D DEM^VADPT S:'VAERR IBNAME=$G(VADM(1)),IBSSN=VA("BID") ; pt id,brief
- D:$Y+IBBOT>IOSL HEADER Q:IBQUIT
- W $E(IBNAME,1,20),?22,IBSSN
- Q
- PRNTCHG ; prints a charge
- N IBACT,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1,IBDAY,IBOHDT,X1,X2
- N IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME
- S IBND=$G(^IB(IBN,0))
- S IBND1=$G(^IB(IBN,1))
- S (IBRX,IBRXN,IBRF,IBRDT,IBX,IBECME)=0
- ; action id
- S IBACT=+IBND
- ; type
- ; Patch IB*2.0*618 - added community care - action types to DAYS ON HOLD report
- S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1)
- S IBTYPE=$$IBACTYPE^IBOHLD2(IBTYPE)
- ; end of Patch IB*2.0*618
- ; bill #
- ; S IBBILL=$P($P(IBND,"^",11),"-",2)
- ;
- ; 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) ; fill date
- . Q
- ;
- S IBX=$$APPT^IBCU3(IBRDT,DFN)
- ; from/fill date
- S IBFR=$$DAT1^IBOUTL($S(+IBRXN>0:IBRDT,1:$P(IBND,"^",14)))
- ; to date
- S IBTO=$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":$P(IBND,"^",15),1:$P(IBND1,"^",2)))
- ; on hold date
- S IBOHDT=$$DAT1^IBOUTL($P(IBND1,"^",6))
- ; number of days on hold
- S X1=DT,X2=$P(IBND1,"^",6) D ^%DTC S IBDAY=$J(X,7)
- ; charge$
- S IBCHG=$J(+$P(IBND,"^",7),9,2)
- W ?29,IBACT,?40,IBTYPE W:IBRX>0 ?46,"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),?68,$S(IBECME:"ECME #: "_IBECME,1:""),?95,"||",!
- W:IBX=1 ?45,"*"
- W ?46,IBFR,?55,IBTO,?66,IBOHDT,?77,IBDAY,?86,IBCHG
- 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 ?53,"CHARGES ON HOLD LONGER THAN "_IBNUM_" DAYS",?110,IBNOW," PAGE ",IBPAGE,!,"HELD CHARGES",?98,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE
- W !,?46,"From/",?55,"To/",?66,"On Hold",?77,"# Days",?95,"||",?105,"AR"
- W !,"Name",?22,"Pt.ID",?29,"Act.ID",?40,"Type",?46,"Fill Dt",?55,"Rls Dt",?66,"Date",?77,"On Hold",?89,"Charge",?95,"||",?98,"Bill#",?105,"Status",?113,"Charge",?125,"Paid"
- W !,IBLINE,!
- W ?44,"'*' = outpt visit on same day as Rx fill date",?95,"||",!,IBLINE,!
- S IBPAGE=IBPAGE+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHDT1 3986 printed Feb 18, 2025@23:52:04 Page 2
- IBOHDT1 ;ALB/EMG - REPORT OF CHARGES ON HOLD > 60 DAYS-CONT ;FEB 18 1997
- +1 ;;2.0;INTEGRATED BILLING;**70,95,347,452,618**;21-MAR-94;Build 61
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- REPORT ;
- +1 NEW IBQUIT,IBPAGE,IBNOW,IBLINE,IBCRT,IBBOT,DFN,IBNAME,IBATYPE,IBN,X
- +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,"=",96)="||"
- SET IBLINE=IBLINE_$EXTRACT(IBLINE,1,32)
- +4 SET IBNOW=$$FMTE^XLFDT($$NOW^XLFDT)
- +5 IF IBCRT
- WRITE @IOF
- LOOP ;
- +1 SET IBPAGE=1
- DO HEADER
- if IBQUIT
- QUIT
- +2 SET IBNAME=""
- FOR
- SET IBNAME=$ORDER(^TMP($JOB,"HOLD",IBNAME))
- if IBNAME=""
- QUIT
- SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP($JOB,"HOLD",IBNAME,DFN))
- if DFN=""
- QUIT
- DO PRNTPAT
- if IBQUIT
- QUIT
- SET IBATYPE=""
- FOR
- SET IBATYPE=$ORDER(^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE))
- if IBATYPE=""
- QUIT
- Begin DoDot:1
- +3 SET IBN=0
- FOR
- SET IBN=$ORDER(^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE,IBN))
- if 'IBN!(IBQUIT)
- QUIT
- Begin DoDot:2
- +4 DO PRNTCHG
- if 'IBQUIT
- DO PRNTBILL
- End DoDot:2
- End DoDot:1
- +5 QUIT
- PRNTBILL ; prints bills for a charge
- +1 NEW IB,IB0,IBSTAT,IBCHG,IBPD,Y,I,IBT
- +2 if $Y-IBBOT+1>IOSL
- DO HEADER
- if IBQUIT
- QUIT
- +3 SET IB=""
- FOR I=1:1
- SET IB=$ORDER(^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE,IBN,IB))
- if 'IB&(I<2)
- WRITE ?90,"||",!
- if $Y+IBBOT>IOSL
- DO HEADER
- if 'IB!(IBQUIT)
- QUIT
- Begin DoDot:1
- +4 WRITE ?95,"||"
- +5 SET IB0=$GET(^DGCR(399,IB,0))
- if IB0=""
- QUIT
- +6 ; bill #
- WRITE ?98,$PIECE(IB0,"^",1)
- +7 SET IBSTAT=$$STA^PRCAFN(IB)
- +8 if +IBSTAT>0
- WRITE ?106,$EXTRACT($PIECE(IBSTAT,"^",2),1,3)
- +9 SET IBT=$JUSTIFY((+^DGCR(399,IB,"U1")-$PIECE(^("U1"),"^",2)),9,2)
- +10 ; total charges
- WRITE ?113,IBT
- +11 SET IBPD=$$TPR^PRCAFN(IB)
- if IBPD<0
- SET IBPD=""
- SET IBPD=$JUSTIFY(IBPD,9,2)
- WRITE ?122,IBPD,!
- if $Y+IBBOT>IOSL
- DO HEADER
- End DoDot:1
- +12 QUIT
- PRNTPAT ; prints patient data
- +1 ; pt id,brief
- NEW VAERR,VADM,IBSSN
- DO DEM^VADPT
- if 'VAERR
- SET IBNAME=$GET(VADM(1))
- SET IBSSN=VA("BID")
- +2 if $Y+IBBOT>IOSL
- DO HEADER
- if IBQUIT
- QUIT
- +3 WRITE $EXTRACT(IBNAME,1,20),?22,IBSSN
- +4 QUIT
- PRNTCHG ; prints a charge
- +1 NEW IBACT,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1,IBDAY,IBOHDT,X1,X2
- +2 NEW IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME
- +3 SET IBND=$GET(^IB(IBN,0))
- +4 SET IBND1=$GET(^IB(IBN,1))
- +5 SET (IBRX,IBRXN,IBRF,IBRDT,IBX,IBECME)=0
- +6 ; action id
- +7 SET IBACT=+IBND
- +8 ; type
- +9 ; Patch IB*2.0*618 - added community care - action types to DAYS ON HOLD report
- +10 SET IBTYPE=$PIECE(IBND,"^",3)
- SET IBTYPE=$PIECE($GET(^IBE(350.1,IBTYPE,0)),"^",1)
- +11 SET IBTYPE=$$IBACTYPE^IBOHLD2(IBTYPE)
- +12 ; end of Patch IB*2.0*618
- +13 ; bill #
- +14 ; S IBBILL=$P($P(IBND,"^",11),"-",2)
- +15 ;
- +16 ; rx info
- +17 IF $PIECE(IBND,"^",4)["52:"
- Begin DoDot:1
- +18 ; Rx ien
- SET IBRXN=$PIECE($PIECE(IBND,"^",4),":",2)
- +19 ; external Rx#
- SET IBRX=$PIECE($PIECE(IBND,"^",8),"-")
- +20 ; fill# or 0 for original fill
- SET IBRF=$PIECE($PIECE(IBND,"^",4),":",3)
- +21 ; ecme# DBIA 4719
- SET IBECME=$PIECE($$CLAIM^BPSBUTL(+IBRXN,+IBRF),U,6)
- +22 ; refill date
- IF IBRF
- SET IENS=+IBRF
- SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01)
- +23 ; fill date
- IF 'IBRF
- SET IENS=+IBRXN
- SET IBRDT=$$FILE^IBRXUTL(IENS,22)
- +24 QUIT
- End DoDot:1
- +25 ;
- +26 SET IBX=$$APPT^IBCU3(IBRDT,DFN)
- +27 ; from/fill date
- +28 SET IBFR=$$DAT1^IBOUTL($SELECT(+IBRXN>0:IBRDT,1:$PIECE(IBND,"^",14)))
- +29 ; to date
- +30 SET IBTO=$$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",15)'="":$PIECE(IBND,"^",15),1:$PIECE(IBND1,"^",2)))
- +31 ; on hold date
- +32 SET IBOHDT=$$DAT1^IBOUTL($PIECE(IBND1,"^",6))
- +33 ; number of days on hold
- +34 SET X1=DT
- SET X2=$PIECE(IBND1,"^",6)
- DO ^%DTC
- SET IBDAY=$JUSTIFY(X,7)
- +35 ; charge$
- +36 SET IBCHG=$JUSTIFY(+$PIECE(IBND,"^",7),9,2)
- +37 WRITE ?29,IBACT,?40,IBTYPE
- if IBRX>0
- WRITE ?46,"Rx #: "_IBRX_$SELECT(IBRF>0:"("_IBRF_")",1:""),?68,$SELECT(IBECME:"ECME #: "_IBECME,1:""),?95,"||",!
- +38 if IBX=1
- WRITE ?45,"*"
- +39 WRITE ?46,IBFR,?55,IBTO,?66,IBOHDT,?77,IBDAY,?86,IBCHG
- +40 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 WRITE ?53,"CHARGES ON HOLD LONGER THAN "_IBNUM_" DAYS",?110,IBNOW," PAGE ",IBPAGE,!,"HELD CHARGES",?98,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE
- +7 WRITE !,?46,"From/",?55,"To/",?66,"On Hold",?77,"# Days",?95,"||",?105,"AR"
- +8 WRITE !,"Name",?22,"Pt.ID",?29,"Act.ID",?40,"Type",?46,"Fill Dt",?55,"Rls Dt",?66,"Date",?77,"On Hold",?89,"Charge",?95,"||",?98,"Bill#",?105,"Status",?113,"Charge",?125,"Paid"
- +9 WRITE !,IBLINE,!
- +10 WRITE ?44,"'*' = outpt visit on same day as Rx fill date",?95,"||",!,IBLINE,!
- +11 SET IBPAGE=IBPAGE+1
- +12 QUIT