IBNCPDPH ;DALOI/SS - ECME REPORT OF ON HOLD CHARGES FOR A PATIENT ;3/6/08 16:19
;;2.0;INTEGRATED BILLING;**276,347,384**;21-MAR-94;Build 74
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;made after IBOHPT1 to use with ECME User Screen
;see IA# with ECME
;
ONHOLD(DFN) ;
N IBQUIT,IBII,DIRUT,DUOUT,DTOUT,ZTIO,Y S IBQUIT=0
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
;
S DIR(0)="DA^::EX",DIR("A")="Start with DATE: "
S DIR("?")="Enter the starting date for this report."
D ^DIR K DIR G:$D(DIRUT) EXIT S IBSDT=+Y
S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" Go to DATE: "
S DIR("?")="Enter the ending date for this report."
D ^DIR K DIR G:$D(DIRUT) EXIT S IBEDT=+Y
;
S DIR(0)="Y",DIR("A")="Include Pharmacy Co-pay charges on this report",DIR("B")="NO"
S DIR("?",1)=" Enter: 'Y' - to include Pharmacy Co-pay charges on this report"
S DIR("?",2)=" 'N' - to exclude Pharmacy Co-pay charges on this report"
S DIR("?")=" '^' - to select a new patient"
D ^DIR K DIR G:$D(DIRUT) EXIT S IBIBRX=Y
;
QUEUED ; entry point if queued
;***
K ^TMP($J,"IB")
D:'$G(IBQUIT) DEVICE D:'$G(IBQUIT) CHRGS,REPORT^IBOHPT2
D EXIT
;***
Q
EXIT ;
K ^TMP($J,"IB")
K DFN,IBEND,IBSDT,IBEDT,IBIBRX,IBCN,IBDT,IBIFN,X
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 ***"
N %ZIS
S %ZIS="QM" D ^%ZIS I POP S IBQUIT=1 Q
N ZTRTN,ZTIO,ZTDES,ZTSAVE
I $D(IO("Q")) S ZTRTN="QUEUED^IBOHPT1",ZTIO=ION,ZTDESC="ON HOLD CHARGE INFO/PT",ZTSAVE("IB*")="",ZTSAVE("DFN")="" 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 DATE,IBN,IBND,A,B,C,D,E,IBNX
S IBN=0 F S IBN=$O(^IB("C",DFN,IBN)) Q:'IBN S IBND=$G(^IB(IBN,0)) D:IBND
.I 'IBIBRX,$E($G(^IBE(350.1,+$P(IBND,"^",3),0)),1,3)="PSO" Q
.Q:$P(IBND,"^",8)["ADMISSION"
.Q:'$P($G(^IB(IBN,1)),"^",6)
.Q:'$D(^IB("APDT",IBN))
.S (C,D)="",C=$O(^IB("APDT",IBN,C)),D=$O(^IB("APDT",IBN,C,D))
.S E=$P($G(^IB(D,0)),U,3)
.S A=$P($G(^IBE(350.1,E,0)),U,5)
.S IBNX=$S(A=2:$P($Q(^IB("APDT",IBN,C,D)),")",1),A=3:$P($Q(^IB("APDT",IBN,C,D)),")",1),1:IBN)
.I (A=2)!(A=3) D
..I IBNX["[""" S IBNX="^"_$P(IBNX,"]",2)
.I $P(IBNX,",",4)>0 S IBNX=$P(IBNX,",",4)
.S DATE=$P($G(^IB(+$P(IBND,"^",1),0)),"^",17)
.S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",5)
.S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",2)\1
.I (DATE>(IBSDT-.0001))&(DATE<(IBEDT+.9999)) S ^TMP($J,"IB",-DATE,IBNX)="" D BILLS
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,+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
Q
INP ; inpatient bills
N IBEV,IBBILL,IBT,X,X1,X2,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,"IB",-DATE,IBNX,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,"IB",-DATE,IBNX,IBBILL))
..S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 Q:'IBOK
..S ^TMP($J,"IB",-DATE,IBNX,IBBILL)=""
Q
RX ; rx refill bills
Q:'IBIBRX
S (IBRX,IBRXN,IBRF,IBRDT)=0
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,"IB",-DATE,IBNX,IBBILL)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDPH 4973 printed Dec 13, 2024@02:24:44 Page 2
IBNCPDPH ;DALOI/SS - ECME REPORT OF ON HOLD CHARGES FOR A PATIENT ;3/6/08 16:19
+1 ;;2.0;INTEGRATED BILLING;**276,347,384**;21-MAR-94;Build 74
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;made after IBOHPT1 to use with ECME User Screen
+6 ;see IA# with ECME
+7 ;
ONHOLD(DFN) ;
+1 NEW IBQUIT,IBII,DIRUT,DUOUT,DTOUT,ZTIO,Y
SET IBQUIT=0
+2 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+3 ;
+4 SET DIR(0)="DA^::EX"
SET DIR("A")="Start with DATE: "
+5 SET DIR("?")="Enter the starting date for this report."
+6 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET IBSDT=+Y
+7 SET DIR(0)="DA^"_+Y_":NOW:EX"
SET DIR("A")=" Go to DATE: "
+8 SET DIR("?")="Enter the ending date for this report."
+9 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET IBEDT=+Y
+10 ;
+11 SET DIR(0)="Y"
SET DIR("A")="Include Pharmacy Co-pay charges on this report"
SET DIR("B")="NO"
+12 SET DIR("?",1)=" Enter: 'Y' - to include Pharmacy Co-pay charges on this report"
+13 SET DIR("?",2)=" 'N' - to exclude Pharmacy Co-pay charges on this report"
+14 SET DIR("?")=" '^' - to select a new patient"
+15 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET IBIBRX=Y
+16 ;
QUEUED ; entry point if queued
+1 ;***
+2 KILL ^TMP($JOB,"IB")
+3 if '$GET(IBQUIT)
DO DEVICE
if '$GET(IBQUIT)
DO CHRGS
DO REPORT^IBOHPT2
+4 DO EXIT
+5 ;***
+6 QUIT
EXIT ;
+1 KILL ^TMP($JOB,"IB")
+2 KILL DFN,IBEND,IBSDT,IBEDT,IBIBRX,IBCN,IBDT,IBIFN,X
+3 KILL IBRDT,IBRF,IBRX,IBRXN
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+5 DO ^%ZISC
+6 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 NEW %ZIS
+5 SET %ZIS="QM"
DO ^%ZIS
IF POP
SET IBQUIT=1
QUIT
+6 NEW ZTRTN,ZTIO,ZTDES,ZTSAVE
+7 IF $DATA(IO("Q"))
SET ZTRTN="QUEUED^IBOHPT1"
SET ZTIO=ION
SET ZTDESC="ON HOLD CHARGE INFO/PT"
SET ZTSAVE("IB*")=""
SET ZTSAVE("DFN")=""
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
DO HOME^%ZIS
KILL ZTSK
SET IBQUIT=1
QUIT
+8 USE IO
+9 QUIT
+10 ; indexes records that should be included in report
+11 ;
CHRGS ; charges on hold
+1 NEW DATE,IBN,IBND,A,B,C,D,E,IBNX
+2 SET IBN=0
FOR
SET IBN=$ORDER(^IB("C",DFN,IBN))
if 'IBN
QUIT
SET IBND=$GET(^IB(IBN,0))
if IBND
Begin DoDot:1
+3 IF 'IBIBRX
IF $EXTRACT($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),1,3)="PSO"
QUIT
+4 if $PIECE(IBND,"^",8)["ADMISSION"
QUIT
+5 if '$PIECE($GET(^IB(IBN,1)),"^",6)
QUIT
+6 if '$DATA(^IB("APDT",IBN))
QUIT
+7 SET (C,D)=""
SET C=$ORDER(^IB("APDT",IBN,C))
SET D=$ORDER(^IB("APDT",IBN,C,D))
+8 SET E=$PIECE($GET(^IB(D,0)),U,3)
+9 SET A=$PIECE($GET(^IBE(350.1,E,0)),U,5)
+10 SET IBNX=$SELECT(A=2:$PIECE($QUERY(^IB("APDT",IBN,C,D)),")",1),A=3:$PIECE($QUERY(^IB("APDT",IBN,C,D)),")",1),1:IBN)
+11 IF (A=2)!(A=3)
Begin DoDot:2
+12 IF IBNX["["""
SET IBNX="^"_$PIECE(IBNX,"]",2)
End DoDot:2
+13 IF $PIECE(IBNX,",",4)>0
SET IBNX=$PIECE(IBNX,",",4)
+14 SET DATE=$PIECE($GET(^IB(+$PIECE(IBND,"^",1),0)),"^",17)
+15 if 'DATE
SET DATE=$PIECE($GET(^IB(IBNX,1)),"^",5)
+16 if 'DATE
SET DATE=$PIECE($GET(^IB(IBNX,1)),"^",2)\1
+17 IF (DATE>(IBSDT-.0001))&(DATE<(IBEDT+.9999))
SET ^TMP($JOB,"IB",-DATE,IBNX)=""
DO BILLS
End DoDot:1
+18 QUIT
+19 ;
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,+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
+7 QUIT
INP ; inpatient bills
+1 NEW IBEV,IBBILL,IBT,X,X1,X2,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,"IB",-DATE,IBNX,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,"IB",-DATE,IBNX,IBBILL))
QUIT
+5 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
DO CK4
if 'IBOK
QUIT
+6 SET ^TMP($JOB,"IB",-DATE,IBNX,IBBILL)=""
End DoDot:2
End DoDot:1
+7 QUIT
RX ; rx refill bills
+1 if 'IBIBRX
QUIT
+2 SET (IBRX,IBRXN,IBRF,IBRDT)=0
+3 IF $PIECE(IBND,"^",4)'["52:"
QUIT
+4 ;
+5 SET IBRXN=$PIECE($PIECE(IBND,"^",4),":",2)
SET IBRX=$PIECE($PIECE(IBND,"^",8),"-")
SET IBRF=$PIECE($PIECE(IBND,"^",4),":",3)
+6 ;
+7 IF +IBRF>0
SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
+8 IF +IBRF=0
SET IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
+9 ;
+10 if (IBRX="")!('IBRDT)
QUIT
+11 NEW X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK
SET IBBILL=0
+12 SET IBFILL=0
FOR
SET IBFILL=$ORDER(^IBA(362.4,"B",IBRX,IBFILL))
if IBFILL=""
QUIT
Begin DoDot:1
+13 SET IBFILL0=$GET(^IBA(362.4,IBFILL,0))
IF $PIECE(IBFILL0,"^",3)'=IBRDT
QUIT
+14 SET IBBILL=+$PIECE(IBFILL0,"^",2)
IF 'IBBILL
QUIT
+15 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
DO CK4
IF 'IBOK
QUIT
+16 SET ^TMP($JOB,"IB",-DATE,IBNX,IBBILL)=""
End DoDot:1
+17 QUIT
