- 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 Feb 18, 2025@23:52:02 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
