- 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 Jan 18, 2025@03:25:56 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