- IBOHDT ;ALB/EMG - REPORT OF CHARGES ON HOLD > 60 DAYS ;FEB 14 1997
- ;;2.0;INTEGRATED BILLING;**70,95,142,347,555**;21-MAR-94;Build 22
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- MAIN ;
- N DIRUT,DTOUT,DUOUT,IBNUM,IBQUIT,POP,VA,ZTIO,Y S (IBQUIT,IBNUM)=0
- W !!
- S DIR(0)="NO",DIR("B")=60,DIR("A")="Enter number of days",DIR("A",1)="This report is used to follow-up on charges that have been on hold for an"
- S DIR("A",2)="extended period of time. Press return to print a list of charges on hold",DIR("A",3)="for longer than 60 days. You may limit your search to older charges"
- S DIR("A",4)="by typing a higher number. (For example, type 80 to see charges on hold",DIR("A",5)="for longer than 80 days.)",DIR("A",6)=""
- D ^DIR K DIR S IBNUM=+Y Q:$D(DIRUT)
- QUEUED ; entry point if queued
- ;***
- K ^TMP($J)
- D:'$G(IBQUIT) DEVICE D:'$G(IBQUIT) CHRGS,REPORT^IBOHDT1
- D EXIT
- ;***
- Q
- EXIT ;
- K ^TMP($J)
- K IBRDT,IBRF,IBRX,IBRXN
- I $D(ZTQUEUED) S ZTREQ="@" Q
- D ^%ZISC
- Q
- DEVICE ;
- I $D(ZTQUEUED) Q
- W !!,*7,"*** Margin width of this output is 132 ***"
- W !,"*** This output should be queued ***"
- S %ZIS="QM" D ^%ZIS I POP S IBQUIT=1 Q
- I $D(IO("Q")) S ZTRTN="QUEUED^IBOHDT",ZTIO=ION,ZTDESC="HELD CHARGES REPORT",ZTSAVE("IB*")="" D ^%ZTLOAD W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") D HOME^%ZIS K ZTSK S IBQUIT=1 Q
- U IO
- Q
- ; indexes records that should be included in report
- ;
- CHRGS ; charges on hold
- N DFN,IBDT,IBN,IBNAME,IBND,IBPID,IBTYPE,X1,X2
- S X1=DT,X2=(-IBNUM) D C^%DTC S IBTO=X
- S IBPID=0 F S IBPID=$O(^IB("AHDT",IBPID)) Q:'IBPID S IBDT=0 F S IBDT=$O(^IB("AHDT",IBPID,8,IBDT)) Q:'IBDT!(IBDT>IBTO) S IBN=0 F S IBN=$O(^IB("AHDT",IBPID,8,IBDT,IBN)) Q:IBN="" D
- .S IBND=$G(^IB(IBN,0)) Q:'IBND
- .S DFN=+$P(IBND,"^",2) D ;fetch patient name
- ..N VAERR,VADM D DEM^VADPT I VAERR K VADM
- ..S IBNAME=$G(VADM(1))
- ..Q
- .S IBTYPE=$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^"),IBATYPE=$S(IBTYPE["OPT":"O",IBTYPE["PSO":"RX",1:"I")
- .S ^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN)=""
- .D BILLS
- Q
- PAT ; patient name
- N VAERR,VADM D DEM^VADPT I VAERR K VADM
- S IBNAME=$G(VADM(1)) S:IBNAME="" IBNAME=" "
- Q
- BILLS ; find bills for charges on hold
- N IBFR,IBT,IBATYPE,IBTO
- S IBATYPE=$S($P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^")["OPT":"O",$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^")["PSO":"RX",1:"I")
- S IBFR=$P(IBND,"^",14),IBTO=$P(IBND,"^",15)
- I IBATYPE="I" D INP
- I IBATYPE="O" D OPT
- E D RX,OPT
- Q
- INP ; inpatient bills
- N IBEV,IBBILL,IBT,X,IBEND,IBOK
- S IBEV=$P(IBND,"^",16) Q:'IBEV ; parent event
- S IBEV=($P($G(^IB(IBEV,0)),"^",17)\1) Q:'IBEV ; date of parent event
- S X1=IBEV,X2=1 D C^%DTC S IBEND=X
- S IBT=(IBEV-.0001) F S IBT=$O(^DGCR(399,"D",IBT)) Q:'IBT!(IBT'<IBEND) S IBBILL=0 F S IBBILL=$O(^DGCR(399,"D",IBT,IBBILL)) Q:IBBILL="" D
- .D INPTCK
- .I IBOK S ^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL)=""
- Q
- ;
- INPTCK ; does bill belong to charge? returns IBOK=0 if no
- N IBBILL0,IBBILLU
- S IBBILL0=$G(^DGCR(399,IBBILL,0)),IBBILLU=$G(^("U"))
- S IBOK=1
- CK1 ; for same patient?
- I DFN=$P(IBBILL0,"^",2)
- S IBOK=$T
- Q:'IBOK
- CK2 ; same type- inp or opt?
- N B S B=$S(+$P(IBBILL0,"^",5)<3:"I",1:"O")
- I B=IBATYPE
- S IBOK=$T
- Q:'IBOK
- CK3 ; overlap in date range?
- N F,T
- S F=+IBBILLU,T=$P(IBBILLU,"^",2)
- I (IBTO<F)!(IBFR>T)
- S IBOK='$T
- Q:'IBOK
- CK4 ; insurance bill?
- I $P(IBBILL0,"^",11)="i"
- S IBOK=$T
- Q
- OPT ; outpatient bills
- N X,IBV,IBBILL,IBOK,IBBILL0
- S IBV=(IBFR\1)-.0001 F S IBV=$O(^DGCR(399,"AOPV",DFN,IBV)) Q:'IBV!(IBV>IBTO) S IBBILL=0 D
- .F S IBBILL=$O(^DGCR(399,"AOPV",DFN,IBV,IBBILL)) Q:('IBBILL) D
- ..Q:$D(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL))
- ..S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 Q:'IBOK
- ..S ^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL)=""
- Q
- RX ; rx refill bills
- S (IBRX,IBRXN,IBRF,IBRDT)=0 N IENS
- I $P(IBND,"^",4)'["52:" Q
- ;
- S IBRXN=$P($P(IBND,"^",4),":",2),IBRX=$P($P(IBND,"^",8),"-"),IBRF=$P($P(IBND,"^",4),":",3)
- ;
- I +IBRF>0 S IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
- I +IBRF=0 S IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
- ;
- Q:(IBRX="")!('IBRDT)
- N X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK S IBBILL=0
- S IBFILL=0 F S IBFILL=$O(^IBA(362.4,"B",IBRX,IBFILL)) Q:IBFILL="" D
- .S IBFILL0=$G(^IBA(362.4,IBFILL,0)) I $P(IBFILL0,"^",3)'=IBRDT Q
- .S IBBILL=+$P(IBFILL0,"^",2) I 'IBBILL Q
- .S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 I 'IBOK Q
- .S ^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHDT 4489 printed Feb 18, 2025@23:52:03 Page 2
- IBOHDT ;ALB/EMG - REPORT OF CHARGES ON HOLD > 60 DAYS ;FEB 14 1997
- +1 ;;2.0;INTEGRATED BILLING;**70,95,142,347,555**;21-MAR-94;Build 22
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- MAIN ;
- +1 NEW DIRUT,DTOUT,DUOUT,IBNUM,IBQUIT,POP,VA,ZTIO,Y
- SET (IBQUIT,IBNUM)=0
- +2 WRITE !!
- +3 SET DIR(0)="NO"
- SET DIR("B")=60
- SET DIR("A")="Enter number of days"
- SET DIR("A",1)="This report is used to follow-up on charges that have been on hold for an"
- +4 SET DIR("A",2)="extended period of time. Press return to print a list of charges on hold"
- SET DIR("A",3)="for longer than 60 days. You may limit your search to older charges"
- +5 SET DIR("A",4)="by typing a higher number. (For example, type 80 to see charges on hold"
- SET DIR("A",5)="for longer than 80 days.)"
- SET DIR("A",6)=""
- +6 DO ^DIR
- KILL DIR
- SET IBNUM=+Y
- if $DATA(DIRUT)
- QUIT
- QUEUED ; entry point if queued
- +1 ;***
- +2 KILL ^TMP($JOB)
- +3 if '$GET(IBQUIT)
- DO DEVICE
- if '$GET(IBQUIT)
- DO CHRGS
- DO REPORT^IBOHDT1
- +4 DO EXIT
- +5 ;***
- +6 QUIT
- EXIT ;
- +1 KILL ^TMP($JOB)
- +2 KILL IBRDT,IBRF,IBRX,IBRXN
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +4 DO ^%ZISC
- +5 QUIT
- DEVICE ;
- +1 IF $DATA(ZTQUEUED)
- QUIT
- +2 WRITE !!,*7,"*** Margin width of this output is 132 ***"
- +3 WRITE !,"*** This output should be queued ***"
- +4 SET %ZIS="QM"
- DO ^%ZIS
- IF POP
- SET IBQUIT=1
- QUIT
- +5 IF $DATA(IO("Q"))
- SET ZTRTN="QUEUED^IBOHDT"
- SET ZTIO=ION
- SET ZTDESC="HELD CHARGES REPORT"
- SET ZTSAVE("IB*")=""
- DO ^%ZTLOAD
- WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
- DO HOME^%ZIS
- KILL ZTSK
- SET IBQUIT=1
- QUIT
- +6 USE IO
- +7 QUIT
- +8 ; indexes records that should be included in report
- +9 ;
- CHRGS ; charges on hold
- +1 NEW DFN,IBDT,IBN,IBNAME,IBND,IBPID,IBTYPE,X1,X2
- +2 SET X1=DT
- SET X2=(-IBNUM)
- DO C^%DTC
- SET IBTO=X
- +3 SET IBPID=0
- FOR
- SET IBPID=$ORDER(^IB("AHDT",IBPID))
- if 'IBPID
- QUIT
- SET IBDT=0
- FOR
- SET IBDT=$ORDER(^IB("AHDT",IBPID,8,IBDT))
- if 'IBDT!(IBDT>IBTO)
- QUIT
- SET IBN=0
- FOR
- SET IBN=$ORDER(^IB("AHDT",IBPID,8,IBDT,IBN))
- if IBN=""
- QUIT
- Begin DoDot:1
- +4 SET IBND=$GET(^IB(IBN,0))
- if 'IBND
- QUIT
- +5 ;fetch patient name
- SET DFN=+$PIECE(IBND,"^",2)
- Begin DoDot:2
- +6 NEW VAERR,VADM
- DO DEM^VADPT
- IF VAERR
- KILL VADM
- +7 SET IBNAME=$GET(VADM(1))
- +8 QUIT
- End DoDot:2
- +9 SET IBTYPE=$PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")
- SET IBATYPE=$SELECT(IBTYPE["OPT":"O",IBTYPE["PSO":"RX",1:"I")
- +10 SET ^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE,IBN)=""
- +11 DO BILLS
- End DoDot:1
- +12 QUIT
- PAT ; patient name
- +1 NEW VAERR,VADM
- DO DEM^VADPT
- IF VAERR
- KILL VADM
- +2 SET IBNAME=$GET(VADM(1))
- if IBNAME=""
- SET IBNAME=" "
- +3 QUIT
- BILLS ; find bills for charges on hold
- +1 NEW IBFR,IBT,IBATYPE,IBTO
- +2 SET IBATYPE=$SELECT($PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")["OPT":"O",$PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")["PSO":"RX",1:"I")
- +3 SET IBFR=$PIECE(IBND,"^",14)
- SET IBTO=$PIECE(IBND,"^",15)
- +4 IF IBATYPE="I"
- DO INP
- +5 IF IBATYPE="O"
- DO OPT
- +6 IF '$TEST
- DO RX
- DO OPT
- +7 QUIT
- INP ; inpatient bills
- +1 NEW IBEV,IBBILL,IBT,X,IBEND,IBOK
- +2 ; parent event
- SET IBEV=$PIECE(IBND,"^",16)
- if 'IBEV
- QUIT
- +3 ; date of parent event
- SET IBEV=($PIECE($GET(^IB(IBEV,0)),"^",17)\1)
- if 'IBEV
- QUIT
- +4 SET X1=IBEV
- SET X2=1
- DO C^%DTC
- SET IBEND=X
- +5 SET IBT=(IBEV-.0001)
- FOR
- SET IBT=$ORDER(^DGCR(399,"D",IBT))
- if 'IBT!(IBT'<IBEND)
- QUIT
- SET IBBILL=0
- FOR
- SET IBBILL=$ORDER(^DGCR(399,"D",IBT,IBBILL))
- if IBBILL=""
- QUIT
- Begin DoDot:1
- +6 DO INPTCK
- +7 IF IBOK
- SET ^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL)=""
- End DoDot:1
- +8 QUIT
- +9 ;
- INPTCK ; does bill belong to charge? returns IBOK=0 if no
- +1 NEW IBBILL0,IBBILLU
- +2 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
- SET IBBILLU=$GET(^("U"))
- +3 SET IBOK=1
- CK1 ; for same patient?
- +1 IF DFN=$PIECE(IBBILL0,"^",2)
- +2 SET IBOK=$TEST
- +3 if 'IBOK
- QUIT
- CK2 ; same type- inp or opt?
- +1 NEW B
- SET B=$SELECT(+$PIECE(IBBILL0,"^",5)<3:"I",1:"O")
- +2 IF B=IBATYPE
- +3 SET IBOK=$TEST
- +4 if 'IBOK
- QUIT
- CK3 ; overlap in date range?
- +1 NEW F,T
- +2 SET F=+IBBILLU
- SET T=$PIECE(IBBILLU,"^",2)
- +3 IF (IBTO<F)!(IBFR>T)
- +4 SET IBOK='$TEST
- +5 if 'IBOK
- QUIT
- CK4 ; insurance bill?
- +1 IF $PIECE(IBBILL0,"^",11)="i"
- +2 SET IBOK=$TEST
- +3 QUIT
- OPT ; outpatient bills
- +1 NEW X,IBV,IBBILL,IBOK,IBBILL0
- +2 SET IBV=(IBFR\1)-.0001
- FOR
- SET IBV=$ORDER(^DGCR(399,"AOPV",DFN,IBV))
- if 'IBV!(IBV>IBTO)
- QUIT
- SET IBBILL=0
- Begin DoDot:1
- +3 FOR
- SET IBBILL=$ORDER(^DGCR(399,"AOPV",DFN,IBV,IBBILL))
- if ('IBBILL)
- QUIT
- Begin DoDot:2
- +4 if $DATA(^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL))
- QUIT
- +5 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
- DO CK4
- if 'IBOK
- QUIT
- +6 SET ^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL)=""
- End DoDot:2
- End DoDot:1
- +7 QUIT
- RX ; rx refill bills
- +1 SET (IBRX,IBRXN,IBRF,IBRDT)=0
- NEW IENS
- +2 IF $PIECE(IBND,"^",4)'["52:"
- QUIT
- +3 ;
- +4 SET IBRXN=$PIECE($PIECE(IBND,"^",4),":",2)
- SET IBRX=$PIECE($PIECE(IBND,"^",8),"-")
- SET IBRF=$PIECE($PIECE(IBND,"^",4),":",3)
- +5 ;
- +6 IF +IBRF>0
- SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
- +7 IF +IBRF=0
- SET IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
- +8 ;
- +9 if (IBRX="")!('IBRDT)
- QUIT
- +10 NEW X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK
- SET IBBILL=0
- +11 SET IBFILL=0
- FOR
- SET IBFILL=$ORDER(^IBA(362.4,"B",IBRX,IBFILL))
- if IBFILL=""
- QUIT
- Begin DoDot:1
- +12 SET IBFILL0=$GET(^IBA(362.4,IBFILL,0))
- IF $PIECE(IBFILL0,"^",3)'=IBRDT
- QUIT
- +13 SET IBBILL=+$PIECE(IBFILL0,"^",2)
- IF 'IBBILL
- QUIT
- +14 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
- DO CK4
- IF 'IBOK
- QUIT
- +15 SET ^TMP($JOB,"HOLD",IBNAME,DFN,IBATYPE,IBN,IBBILL)=""
- End DoDot:1
- +16 QUIT