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 Nov 22, 2024@17:35:36 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
