IBOHLD1 ;ALB/CJM - REPORT OF CHARGES ON HOLD W/INS INFO ;MARCH 3 1992
;;2.0;INTEGRATED BILLING;**70,95,133,356,347,618,651**;21-MAR-94;Build 9
;;Per VA Directive 6402, this routine should not be modified.
;
; modified HELD CHARGES REPORT - includes INS info
;
MAIN ;
N IBQUIT,IBII,DIRUT,DUOUT,DTOUT,ZTIO,Y S IBQUIT=0
S DIR(0)="Y",DIR("A")="Include Insurance information on this report",DIR("B")="NO"
S DIR("?",1)=" Enter: 'Y' - to include patient insurance information on this report"
S DIR("?",2)=" 'N' - to exclude patient insurance information on this report"
S DIR("?",3)=" '^' - to exit this option"
D ^DIR K DIR G:$D(DIRUT) EXIT S IBII=+Y
;
QUEUED ; entry point if queued
;***
K ^TMP($J)
D:'$G(IBQUIT) DEVICE D:'$G(IBQUIT) CHRGS,REPORT^IBOHLD2
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")) D Q
. S ZTRTN="QUEUED^IBOHLD1"
. S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
. S ZTDESC="HELD CHARGES RPT W/INS"
. S ZTSAVE("IB*")=""
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS K ZTSK S IBQUIT=1
U IO
Q
; indexes records that should be included in report
;
CHRGS ; charges on hold
N IBN,DFN,IBNAME,IBND
S DFN=0 F S DFN=$O(^IB("AH",DFN)) Q:'DFN D PAT S IBN=0 F S IBN=$O(^IB("AH",DFN,IBN)) Q:'IBN D
.S IBND=$G(^IB(IBN,0)) Q:'IBND
.S ^TMP($J,"HOLD",IBNAME,DFN,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
;***IB*2.0*618
; Look up the type to match to using the Action Type name
S IBATYPE=$$FNDBTYP($P(IBND,"^",3)) ;end IB*2.0*618
S IBFR=$P(IBND,"^",14),IBTO=$P(IBND,"^",15)
I IBATYPE="I" D INP
I IBATYPE="O" D OTP
E D RX
Q
;
FNDBTYP(IBACTIEN) ;Determine what type of 3rd party bill to try and match the
; held charge to.
; INPUT - IB Action Type IEN (350.1,.01)
;
N IBACTPNM
;
S IBACTPNM=$P($G(^IBE(350.1,IBACTIEN,0)),"^")
I IBACTPNM["OPT" Q "O"
I IBACTPNM["URGENT" Q "O" ;IB*2.0*651 - add CC URGENT CARE as an outpatient
I IBACTPNM["PSO" Q "RX"
I IBACTPNM["RX" Q "O" ;any other RX after PSO link to Outpatient
Q "I" ;assume inpatient if not matched above
;
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,"HOLD",IBNAME,DFN,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
OTP ; 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,IBN,IBBILL))
..S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 Q:'IBOK
..S ^TMP($J,"HOLD",IBNAME,DFN,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,IBN,IBBILL)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHLD1 4545 printed Apr 09, 2024@21:33:48 Page 2
IBOHLD1 ;ALB/CJM - REPORT OF CHARGES ON HOLD W/INS INFO ;MARCH 3 1992
+1 ;;2.0;INTEGRATED BILLING;**70,95,133,356,347,618,651**;21-MAR-94;Build 9
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; modified HELD CHARGES REPORT - includes INS info
+5 ;
MAIN ;
+1 NEW IBQUIT,IBII,DIRUT,DUOUT,DTOUT,ZTIO,Y
SET IBQUIT=0
+2 SET DIR(0)="Y"
SET DIR("A")="Include Insurance information on this report"
SET DIR("B")="NO"
+3 SET DIR("?",1)=" Enter: 'Y' - to include patient insurance information on this report"
+4 SET DIR("?",2)=" 'N' - to exclude patient insurance information on this report"
+5 SET DIR("?",3)=" '^' - to exit this option"
+6 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET IBII=+Y
+7 ;
QUEUED ; entry point if queued
+1 ;***
+2 KILL ^TMP($JOB)
+3 if '$GET(IBQUIT)
DO DEVICE
if '$GET(IBQUIT)
DO CHRGS
DO REPORT^IBOHLD2
+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"))
Begin DoDot:1
+6 SET ZTRTN="QUEUED^IBOHLD1"
+7 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
+8 SET ZTDESC="HELD CHARGES RPT W/INS"
+9 SET ZTSAVE("IB*")=""
+10 DO ^%ZTLOAD
+11 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+12 DO HOME^%ZIS
KILL ZTSK
SET IBQUIT=1
End DoDot:1
QUIT
+13 USE IO
+14 QUIT
+15 ; indexes records that should be included in report
+16 ;
CHRGS ; charges on hold
+1 NEW IBN,DFN,IBNAME,IBND
+2 SET DFN=0
FOR
SET DFN=$ORDER(^IB("AH",DFN))
if 'DFN
QUIT
DO PAT
SET IBN=0
FOR
SET IBN=$ORDER(^IB("AH",DFN,IBN))
if 'IBN
QUIT
Begin DoDot:1
+3 SET IBND=$GET(^IB(IBN,0))
if 'IBND
QUIT
+4 SET ^TMP($JOB,"HOLD",IBNAME,DFN,IBN)=""
+5 DO BILLS
End DoDot:1
+6 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 ;***IB*2.0*618
+3 ; Look up the type to match to using the Action Type name
+4 ;end IB*2.0*618
SET IBATYPE=$$FNDBTYP($PIECE(IBND,"^",3))
+5 SET IBFR=$PIECE(IBND,"^",14)
SET IBTO=$PIECE(IBND,"^",15)
+6 IF IBATYPE="I"
DO INP
+7 IF IBATYPE="O"
DO OTP
+8 IF '$TEST
DO RX
+9 QUIT
+10 ;
FNDBTYP(IBACTIEN) ;Determine what type of 3rd party bill to try and match the
+1 ; held charge to.
+2 ; INPUT - IB Action Type IEN (350.1,.01)
+3 ;
+4 NEW IBACTPNM
+5 ;
+6 SET IBACTPNM=$PIECE($GET(^IBE(350.1,IBACTIEN,0)),"^")
+7 IF IBACTPNM["OPT"
QUIT "O"
+8 ;IB*2.0*651 - add CC URGENT CARE as an outpatient
IF IBACTPNM["URGENT"
QUIT "O"
+9 IF IBACTPNM["PSO"
QUIT "RX"
+10 ;any other RX after PSO link to Outpatient
IF IBACTPNM["RX"
QUIT "O"
+11 ;assume inpatient if not matched above
QUIT "I"
+12 ;
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,"HOLD",IBNAME,DFN,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
OTP ; 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,IBN,IBBILL))
QUIT
+5 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
DO CK4
if 'IBOK
QUIT
+6 SET ^TMP($JOB,"HOLD",IBNAME,DFN,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,IBN,IBBILL)=""
End DoDot:1
+16 QUIT
