IBOHCT ;ALB/EMG - CHECK FOR IB CHARGES ON HOLD ; MAY 2 1997
;;2.0;INTEGRATED BILLING;**70,95,347,622**;21-MAR-94;Build 35
;;Per VA Directive 6402, this routine should not be modified.
;
FIND(DFN,IBTRN) ; find all related IB charges on hold for episodes of care
; for this Claims Tracking entry with Reason Not Billable
; once IB Charge is found, release Charge On Hold to AR
; so patient can be billed.
;
; Input: DFN -- pointer to the patient in file #2
; IBTRN -- ien of Claims Tracking entry
;
N IBQ
I '$G(DFN)!('$G(IBTRN)) G ALLQ
D HOME^%ZIS
;
N X,Y,Y1,IBA,IBX,IBCTR,IBEDT,IBEND,IBNOS,IBSEQNO,IBDUZ,DP,DL
;
S IBCT=$G(^IBT(356,IBTRN,0)),IBEDT=$P($P(IBCT,"^",6),"."),IBI=0
I $P(IBCT,"^",18)=4 D RXCHG,REL G ALLQ
;
;
; - find related inpatient/outpatient patient charges on hold
S (IBNUM,Y)=0 F S Y=$O(^IB("AFDT",DFN,-IBEDT,Y)) Q:'Y D
.S Y1=0 F S Y1=$O(^IB("AF",Y,Y1)) Q:'Y1 D
..Q:'$D(^IB(Y1,0)) S IBX=^(0)
..I $P(IBX,"^",5)'=8 Q
..S IBNUM=IBNUM+1,IBA(IBNUM)=Y1
..Q
.Q
;
REL ; allow user to select IB charges to pass to Accounts Receivable
;
I '$G(IBNUM) G ALLQ
W !!,"The following IB Action"_$S(IBNUM>2:"s",1:"")_", related to this CT entry, ",$S(IBNUM>2:"are",1:"is")," ON HOLD:" D HDR
S IBQ=0 F IBNUM=1:1 Q:'$D(IBA(IBNUM)) D:'(IBNUM#15) Q:IBQ S IBN=IBA(IBNUM) D LST
. R !,"Enter RETURN to continue or '^' to stop: ",X:DTIME S:X["^"!('$T) IBQ=1 Q
;
; prompt user to select IB Actions
S DIR(0)="LA^1:"_(IBNUM-1)_"^",DIR("A")="Select IB Action"_$E("s",IBNUM>2)_" (REF #) to release to Accounts Receivable (or '^' to exit): ",DIR("?")="^D HELP^IBRREL"
W ! D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) Q
;
S IBRANGE=Y,IBSEQNO=1,IBDUZ=DUZ
S DIR(0)="Y",DIR("A")="OK to pass "_$S($P(Y,",",2):"these charges",1:"this charge")_" to Accounts Receivable"
D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) G ALLQ
;
; pass charges to Accounts Receivable
W !!,"Passing charges to Accounts Receivable...",! D HDR
F IBCTR=1:1 S IBNUM=$P(IBRANGE,",",IBCTR) Q:'IBNUM I $D(IBA(IBNUM)) S IBNOS=IBA(IBNUM) D ^IBR,ERR:Y<1 I Y>0 S IBN=IBA(IBNUM) D LST
W !!,"The charge"_$E("s",$P(IBRANGE,",",2)>0)_" listed above "_$S($P(IBRANGE,",",2):"have",1:"has")_" been passed to Accounts Receivable.",!
;
W ! S DIR(0)="E" D ^DIR K DIR G ALLQ
;
ALLQ K IBC,IBCRG,IBCT,IBCTR,IBEDT,IBEND,IBI,IBLINE,IBN,IBND
K IBNOS,IBNUM,IBOHD,IBQ,IBRANGE,IBRXN,IBRXDT,IBRXEND,IBSEQNO
K DIRUT,DUOUT
Q
;
;
HDR ; Display charge header.
N IBLINE S $P(IBLINE,"=",81)=""
W !,IBLINE,!," REF Action ID Bill Type",?42,"Bill #",?51,"Fr/Fl Dt",?61,"To/Rls Dt",?73,"Charge"
W !,IBLINE Q
;
LST ; Display individual IB Action.
N IBND,IBND1,IBRXN,IBRX,IBRF,IBRDT,IENS
S IBND=$G(^IB(IBN,0)),IBND1=$G(^IB(IBN,1)),(IBRXN,IBRX,IBRF,IBRDT)=0
I $P(IBND,"^",4)["52:" S IBRXN=$P($P(IBND,"^",4),":",2),IBRX=$P($P(IBND,"^",8),"-"),IBRF=$P($P(IBND,"^",4),":",3)
I $P(IBND,"^",4)["52:" D
.I IBRF>0 S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01)
.E S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22)
W !?1,$J(IBNUM,2),?7,$J(+IBND,9)
W ?18,$S(IBRXN>0:"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),1:$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^",8))
W ?42,$P($P(IBND,"^",11),"-",2)
W ?51,$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",14)))
W ?61,$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":($P(IBND,"^",15)),1:$P(IBND1,"^",2)))
W ?70,$J(+$P(IBND,"^",7),9,2)
Q
;
RXCHG ; - find related rx copay's on hold in file 350
N IBRXN,IBRXBN,IBRXEND,IBRXDT,IBCRG,IBC
S IBNUM=0
S IBRXEND=+IBEDT+.999999 F S IBEDT=$O(^IB("APTDT",DFN,IBEDT)) Q:'IBEDT!(IBEDT>IBRXEND) S Y1=0 F S Y1=$O(^IB("APTDT",DFN,IBEDT,Y1)) Q:'Y1 S IBX=^IB(Y1,0),IBOHD=$P($G(^IB(Y1,1)),"^",6) D
.I $P(IBX,"^",5)'=8 Q
.S IBNUM=IBNUM+1,IBA(IBNUM)=Y1 Q
Q
;
ERR ; display error message
W !,?5,"Error encountered - a separate bulletin has been posted"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHCT 3904 printed Apr 09, 2024@21:21:48 Page 2
IBOHCT ;ALB/EMG - CHECK FOR IB CHARGES ON HOLD ; MAY 2 1997
+1 ;;2.0;INTEGRATED BILLING;**70,95,347,622**;21-MAR-94;Build 35
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
FIND(DFN,IBTRN) ; find all related IB charges on hold for episodes of care
+1 ; for this Claims Tracking entry with Reason Not Billable
+2 ; once IB Charge is found, release Charge On Hold to AR
+3 ; so patient can be billed.
+4 ;
+5 ; Input: DFN -- pointer to the patient in file #2
+6 ; IBTRN -- ien of Claims Tracking entry
+7 ;
+8 NEW IBQ
+9 IF '$GET(DFN)!('$GET(IBTRN))
GOTO ALLQ
+10 DO HOME^%ZIS
+11 ;
+12 NEW X,Y,Y1,IBA,IBX,IBCTR,IBEDT,IBEND,IBNOS,IBSEQNO,IBDUZ,DP,DL
+13 ;
+14 SET IBCT=$GET(^IBT(356,IBTRN,0))
SET IBEDT=$PIECE($PIECE(IBCT,"^",6),".")
SET IBI=0
+15 IF $PIECE(IBCT,"^",18)=4
DO RXCHG
DO REL
GOTO ALLQ
+16 ;
+17 ;
+18 ; - find related inpatient/outpatient patient charges on hold
+19 SET (IBNUM,Y)=0
FOR
SET Y=$ORDER(^IB("AFDT",DFN,-IBEDT,Y))
if 'Y
QUIT
Begin DoDot:1
+20 SET Y1=0
FOR
SET Y1=$ORDER(^IB("AF",Y,Y1))
if 'Y1
QUIT
Begin DoDot:2
+21 if '$DATA(^IB(Y1,0))
QUIT
SET IBX=^(0)
+22 IF $PIECE(IBX,"^",5)'=8
QUIT
+23 SET IBNUM=IBNUM+1
SET IBA(IBNUM)=Y1
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 ;
REL ; allow user to select IB charges to pass to Accounts Receivable
+1 ;
+2 IF '$GET(IBNUM)
GOTO ALLQ
+3 WRITE !!,"The following IB Action"_$SELECT(IBNUM>2:"s",1:"")_", related to this CT entry, ",$SELECT(IBNUM>2:"are",1:"is")," ON HOLD:"
DO HDR
+4 SET IBQ=0
FOR IBNUM=1:1
if '$DATA(IBA(IBNUM))
QUIT
if '(IBNUM#15)
Begin DoDot:1
+5 READ !,"Enter RETURN to continue or '^' to stop: ",X:DTIME
if X["^"!('$TEST)
SET IBQ=1
QUIT
End DoDot:1
if IBQ
QUIT
SET IBN=IBA(IBNUM)
DO LST
+6 ;
+7 ; prompt user to select IB Actions
+8 SET DIR(0)="LA^1:"_(IBNUM-1)_"^"
SET DIR("A")="Select IB Action"_$EXTRACT("s",IBNUM>2)_" (REF #) to release to Accounts Receivable (or '^' to exit): "
SET DIR("?")="^D HELP^IBRREL"
+9 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
QUIT
+10 ;
+11 SET IBRANGE=Y
SET IBSEQNO=1
SET IBDUZ=DUZ
+12 SET DIR(0)="Y"
SET DIR("A")="OK to pass "_$SELECT($PIECE(Y,",",2):"these charges",1:"this charge")_" to Accounts Receivable"
+13 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))!($DATA(DUOUT))
GOTO ALLQ
+14 ;
+15 ; pass charges to Accounts Receivable
+16 WRITE !!,"Passing charges to Accounts Receivable...",!
DO HDR
+17 FOR IBCTR=1:1
SET IBNUM=$PIECE(IBRANGE,",",IBCTR)
if 'IBNUM
QUIT
IF $DATA(IBA(IBNUM))
SET IBNOS=IBA(IBNUM)
DO ^IBR
if Y<1
DO ERR
IF Y>0
SET IBN=IBA(IBNUM)
DO LST
+18 WRITE !!,"The charge"_$EXTRACT("s",$PIECE(IBRANGE,",",2)>0)_" listed above "_$SELECT($PIECE(IBRANGE,",",2):"have",1:"has")_" been passed to Accounts Receivable.",!
+19 ;
+20 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO ALLQ
+21 ;
ALLQ KILL IBC,IBCRG,IBCT,IBCTR,IBEDT,IBEND,IBI,IBLINE,IBN,IBND
+1 KILL IBNOS,IBNUM,IBOHD,IBQ,IBRANGE,IBRXN,IBRXDT,IBRXEND,IBSEQNO
+2 KILL DIRUT,DUOUT
+3 QUIT
+4 ;
+5 ;
HDR ; Display charge header.
+1 NEW IBLINE
SET $PIECE(IBLINE,"=",81)=""
+2 WRITE !,IBLINE,!," REF Action ID Bill Type",?42,"Bill #",?51,"Fr/Fl Dt",?61,"To/Rls Dt",?73,"Charge"
+3 WRITE !,IBLINE
QUIT
+4 ;
LST ; Display individual IB Action.
+1 NEW IBND,IBND1,IBRXN,IBRX,IBRF,IBRDT,IENS
+2 SET IBND=$GET(^IB(IBN,0))
SET IBND1=$GET(^IB(IBN,1))
SET (IBRXN,IBRX,IBRF,IBRDT)=0
+3 IF $PIECE(IBND,"^",4)["52:"
SET IBRXN=$PIECE($PIECE(IBND,"^",4),":",2)
SET IBRX=$PIECE($PIECE(IBND,"^",8),"-")
SET IBRF=$PIECE($PIECE(IBND,"^",4),":",3)
+4 IF $PIECE(IBND,"^",4)["52:"
Begin DoDot:1
+5 IF IBRF>0
SET IENS=+IBRF
SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01)
+6 IF '$TEST
SET IENS=+IBRXN
SET IBRDT=$$FILE^IBRXUTL(+IENS,22)
End DoDot:1
+7 WRITE !?1,$JUSTIFY(IBNUM,2),?7,$JUSTIFY(+IBND,9)
+8 WRITE ?18,$SELECT(IBRXN>0:"Rx #: "_IBRX_$SELECT(IBRF>0:"("_IBRF_")",1:""),1:$PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^",8))
+9 WRITE ?42,$PIECE($PIECE(IBND,"^",11),"-",2)
+10 WRITE ?51,$$DAT1^IBOUTL($SELECT(IBRXN>0:IBRDT,1:$PIECE(IBND,"^",14)))
+11 WRITE ?61,$$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",15)'="":($PIECE(IBND,"^",15)),1:$PIECE(IBND1,"^",2)))
+12 WRITE ?70,$JUSTIFY(+$PIECE(IBND,"^",7),9,2)
+13 QUIT
+14 ;
RXCHG ; - find related rx copay's on hold in file 350
+1 NEW IBRXN,IBRXBN,IBRXEND,IBRXDT,IBCRG,IBC
+2 SET IBNUM=0
+3 SET IBRXEND=+IBEDT+.999999
FOR
SET IBEDT=$ORDER(^IB("APTDT",DFN,IBEDT))
if 'IBEDT!(IBEDT>IBRXEND)
QUIT
SET Y1=0
FOR
SET Y1=$ORDER(^IB("APTDT",DFN,IBEDT,Y1))
if 'Y1
QUIT
SET IBX=^IB(Y1,0)
SET IBOHD=$PIECE($GET(^IB(Y1,1)),"^",6)
Begin DoDot:1
+4 IF $PIECE(IBX,"^",5)'=8
QUIT
+5 SET IBNUM=IBNUM+1
SET IBA(IBNUM)=Y1
QUIT
End DoDot:1
+6 QUIT
+7 ;
ERR ; display error message
+1 WRITE !,?5,"Error encountered - a separate bulletin has been posted"
+2 QUIT
