- IBCU3 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 4/4/03 8:49am
- ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,211,245,348,399,400,592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;MAP TO DGCRU3
- SC(DFN) ; returns 1 if service connection indicated, 0 otherwise (based on VAEL(3))
- N X,VAEL,VAERR S X=0
- I +$G(DFN) D ELIG^VADPT S X=+$G(VAEL(3))
- Q X
- ;
- APPT(DATE,DFN,DISP) ;Check date to see if patient has any visit data
- ;input: DATE - required, date to check for appointments
- ; DFN - required, patient to check for appointments on date
- ; DISP - if true then error message will be printed before exit, if any
- ;returns: 1 - if appt visit found
- ; 2 - if unscheduled add/edit clinic stop entry found
- ; 3 - if only disposition found
- ; "0^error message" if no valid visit data/disposition found
- ;
- N Y,X,X1,X2 S DATE=$P(DATE,".",1),Y="0^* Patient has no Visits for this date..."
- I 'DATE!'$D(^DPT(DFN,0)) S Y="0^Unable to check for appointments on this date!" G APPTE
- N IBVAL,IBCBK,IBVTYP
- S IBVAL("DFN")=DFN,IBVAL("BDT")=DATE,IBVAL("EDT")=DATE+.9
- S IBCBK="I '$P(Y0,U,6) S IBVTYP=+$P(Y0,U,8) I $S(IBVTYP=2:1,IBVTYP=1:$$APPTCT^IBEFUNC(Y0),IBVTYP=3:$$DISCT^IBEFUNC(Y,Y0),1:0) S IBVTYP(IBVTYP)="""" S:$D(IBVTYP(1)) SDSTOP=1"
- D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1) K ^TMP("DIERR",$J)
- S IBVTYP=$O(IBVTYP(0))
- S:IBVTYP Y=IBVTYP
- ;
- APPTE I +$G(DISP),'Y W !,?10,*7,$P(Y,U,2)
- Q Y
- ;
- BDT(DFN,DATE) ; returns primary bill defined for an event date, "" if none
- N X,Y S X="" I '$O(^DGCR(399,"C",+$G(DFN),0))!'$G(DATE) G BDTE
- S Y="",DATE=9999999-DATE F S Y=$O(^DGCR(399,"APDT",+DFN,Y)) Q:'Y D
- . I $O(^DGCR(399,"APDT",+DFN,Y,0))=DATE,'$P($G(^DGCR(399,Y,"S")),U,16) S X=$P($G(^DGCR(399,Y,0)),U,17) Q
- BDTE Q X
- ;
- BILLED(PTF) ;returns bill "IFN^^rate group" if PTF record is already associated with an uncancelled final bill
- ;returns "bill IFN ^ bill date (stm to) ^ bill rate group" if inpatients interim with no final bill, 0 otherwise
- N IFN,Y,X S Y=0 I '$D(^DGCR(399,"APTF",+$G(PTF))) G BILLEDQ
- S IFN=0 F S IFN=$O(^DGCR(399,"APTF",PTF,IFN)) Q:'IFN D I +Y,'$P(Y,U,2) Q
- . S X=$G(^DGCR(399,IFN,0)) I $P(X,U,13)=7 Q ; bill cancelled
- . S Y=IFN_"^^"_$P(X,U,7) I $P(X,U,6)=2!($P(X,U,6)=3) S Y=IFN_"^"_$P($G(^DGCR(399,IFN,"U")),U,2)_"^"_$P(X,U,7)
- BILLEDQ Q Y
- ;
- FTN(FT) ;returns name of the form type passed in, "" if not defined
- N X S X=$P($G(^IBE(353,+$G(FT),0)),U,1)
- Q X
- ;
- FT(IFN,IBRESET) ;return the correct form type for a bill (trigger code in 399 to set .19)
- ; if IBRESET is not a positive value ('IBRESET), returns the bills current form type (if defined)
- ; if IBRESET is a positive value (+IBRESET), interpret form type according to following rules (for triggers):
- ; first use if bill is inst (UB) or prof (1500) (399,.27), then current (399,.19), then UB
- N X,Y,FTC,FTT
- S X="",IFN=+$G(IFN),Y=$G(^DGCR(399,IFN,0))
- S FTC=$P(Y,U,19) I FTC=1 S FTC=3
- I '$G(IBRESET),+FTC S X=FTC G FTQ
- S FTT=$S($P(Y,U,27)=1:3,$P(Y,U,27)=2:2,1:"")
- ;JWS;IB*2.0*592;Dental form 7
- I FTC=7,FTT=2 Q 7
- S X=$S(+FTT:FTT,+FTC:FTC,1:3)
- FTQ Q X
- ;
- FNT(FTN) ;returns the ifn of the form type name passed in, must be exact match, 0 if none found
- N X,Y S X=0 I $G(FTN)'="" S X=$O(^IBE(353,"B",FTN,0))
- Q X
- ;
- BILLDEV(IFN,PRT) ;returns the default device for a bill's form type, if PRT is passed as true then returns the AR follow up device, otherwise the billing device
- N X,Y S X=0 I $D(^DGCR(399,+$G(IFN),0)) S PRT=$S(+$G(PRT):3,1:2),Y=$$FT(IFN),X=$P($G(^IBE(353,+Y,0)),U,PRT)
- Q X
- ;
- RXDUP(RX,DATE,IFN,DISP,DFN,RTG) ;returns bill ifn if rx # exists on another bill
- ;input: rx # - required, rx # to check for
- ; date - required, date of refill
- ;ifn, dfn, rtg are optional - if not passed then not used to specify rx
- ;(if ifn not passed then returns true if on any bill same or dfn and rtgetc.)
- ;if ifn passed the dfn and rtg do not need to be
- N X,LN,RIFN,BIFN,RLN,BLN S (RIFN,X)=0,DATE=$G(DATE),RX=$G(RX),IFN=$G(IFN) I RX=""!('DATE) G RXDUPE
- S LN=$G(^DGCR(399,+IFN,0)),DFN=$S(+$G(DFN):DFN,1:+$P(LN,U,2)),RTG=$S(+$G(RTG):RTG,1:+$P(LN,U,7))
- F S RIFN=$O(^IBA(362.4,"B",RX,RIFN)) Q:'RIFN S RLN=$G(^IBA(362.4,+RIFN,0)) I +DATE=+$P(RLN,U,3) D Q:+X
- . S BIFN=+$P(RLN,U,2),BLN=$G(^DGCR(399,BIFN,0)) Q:(BLN="")!(BIFN=+$G(IFN))
- . I $P(BLN,U,13)=7 Q ; bill cancelled
- . I +DFN,$P(BLN,U,2)'=DFN Q ; different patient
- . I +RTG,+RTG'=$P(BLN,U,7) Q ; different rate group
- . S X=BIFN_"^A "_$P($G(^DGCR(399.3,+$P(BLN,U,7),0)),U,1)_" bill ("_$P(BLN,U,1)_") exists for Rx # "_RX_" and refill date "_$$DAT1^IBOUTL(DATE)_"."
- RXDUPE I +$G(DISP),+X W !,?10,$P(X,U,2)
- Q X
- ;
- BCOB(IBIFN,IBCOB) ; returns an array of all bills related COB to the bill passed in
- ; includes prior bills defined on this bill then checks the Primary, Secondary and Tertiary Bills and adds
- ; all the prior bills defined on them
- ; ARR(BILL SEQUENCE (1,2,3), INSURANCE CO, BILL #)=""
- ;
- N IBM1,IBI,IBIFN1,IBM,IBM11,IBSEQ,IBSEQN,IBJ K IBCOB
- S IBM1=$G(^DGCR(399,IBIFN,"M1"))
- F IBI=IBIFN,+$P(IBM1,U,5),+$P(IBM1,U,6),+$P(IBM1,U,7) I +IBI S IBIFN1=+IBI D
- . ;
- . S IBM=$G(^DGCR(399,IBIFN1,"M")),IBM11=$G(^DGCR(399,IBIFN1,"M1")) I IBIFN=IBIFN1,'$P(IBM,U,2),'$P(IBM,U,3) Q
- . S IBSEQ=$P($G(^DGCR(399,IBIFN1,0)),U,21),IBSEQN=$S(IBSEQ="P":1,IBSEQ="S":2,IBSEQ="T":3,1:"") Q:'IBSEQN
- . ;
- . F IBJ=1:1:3 I +$P(IBM,U,IBJ) S IBCOB(IBJ,+$P(IBM,U,IBJ),+$P(IBM11,U,(IBJ+4)))=""
- . I +$P(IBM,U,IBSEQN) S IBCOB(IBSEQN,$P(IBM,U,IBSEQN),+IBIFN1)=""
- ;
- S IBI=0 F S IBI=$O(IBCOB(IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ I +$O(IBCOB(IBI,IBJ,0)) K IBCOB(IBI,IBJ,0)
- Q
- ;
- BINS(IBIFN) ; return list of billable insurance carriers on a bill (COB)
- ; output: sequence:carrier:policy ^ sequence:carrier:policy ^ sequence:carrier:policy
- N IBM0,IBI,IBS,IBC,IBP,IBX S IBI=0,IBX="",IBM0=$G(^DGCR(399,+$G(IBIFN),"M"))
- F IBS="P","S","T" S IBI=IBI+1,IBC=+$P(IBM0,U,IBI) I +IBC D
- . S IBP=+$P(IBM0,U,(11+IBI)) I $P($G(^DIC(36,+IBC,0)),U,2)'="N" S IBX=IBX_IBS_":"_IBC_":"_IBP_U
- Q IBX
- ;
- BOTHER(IBIFN,IBDT) ; return Bedsection of Type of Care if date is Other Type of care, based on "OT" multiple
- ; Other care is not inpatient or outpatient, SNF and Sub-Acute became distinct with RC v2.0
- ; as with all other bedsection movements, the last date is not included since that is the date they left
- N IBX,IBY,IBFND S IBFND=0,IBDT=$G(IBDT)\1
- I +$G(IBIFN),+IBDT S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"OT",IBX)) Q:'IBX D
- . S IBY=$G(^DGCR(399,IBIFN,"OT",IBX,0)) Q:'IBY
- . I IBDT'<$P(IBY,U,2),IBDT<$P(IBY,U,3) S IBFND=+IBY
- . I IBDT=($P(IBY,U,2)\1),IBDT=($P(IBY,U,3)\1) S IBFND=+IBY ; 1 day SNF stay
- Q IBFND
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU3 6779 printed Jan 18, 2025@03:21:50 Page 2
- IBCU3 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 4/4/03 8:49am
- +1 ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,211,245,348,399,400,592**;21-MAR-94;Build 58
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;MAP TO DGCRU3
- SC(DFN) ; returns 1 if service connection indicated, 0 otherwise (based on VAEL(3))
- +1 NEW X,VAEL,VAERR
- SET X=0
- +2 IF +$GET(DFN)
- DO ELIG^VADPT
- SET X=+$GET(VAEL(3))
- +3 QUIT X
- +4 ;
- APPT(DATE,DFN,DISP) ;Check date to see if patient has any visit data
- +1 ;input: DATE - required, date to check for appointments
- +2 ; DFN - required, patient to check for appointments on date
- +3 ; DISP - if true then error message will be printed before exit, if any
- +4 ;returns: 1 - if appt visit found
- +5 ; 2 - if unscheduled add/edit clinic stop entry found
- +6 ; 3 - if only disposition found
- +7 ; "0^error message" if no valid visit data/disposition found
- +8 ;
- +9 NEW Y,X,X1,X2
- SET DATE=$PIECE(DATE,".",1)
- SET Y="0^* Patient has no Visits for this date..."
- +10 IF 'DATE!'$DATA(^DPT(DFN,0))
- SET Y="0^Unable to check for appointments on this date!"
- GOTO APPTE
- +11 NEW IBVAL,IBCBK,IBVTYP
- +12 SET IBVAL("DFN")=DFN
- SET IBVAL("BDT")=DATE
- SET IBVAL("EDT")=DATE+.9
- +13 SET IBCBK="I '$P(Y0,U,6) S IBVTYP=+$P(Y0,U,8) I $S(IBVTYP=2:1,IBVTYP=1:$$APPTCT^IBEFUNC(Y0),IBVTYP=3:$$DISCT^IBEFUNC(Y,Y0),1:0) S IBVTYP(IBVTYP)="""" S:$D(IBVTYP(1)) SDSTOP=1"
- +14 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1)
- KILL ^TMP("DIERR",$JOB)
- +15 SET IBVTYP=$ORDER(IBVTYP(0))
- +16 if IBVTYP
- SET Y=IBVTYP
- +17 ;
- APPTE IF +$GET(DISP)
- IF 'Y
- WRITE !,?10,*7,$PIECE(Y,U,2)
- +1 QUIT Y
- +2 ;
- BDT(DFN,DATE) ; returns primary bill defined for an event date, "" if none
- +1 NEW X,Y
- SET X=""
- IF '$ORDER(^DGCR(399,"C",+$GET(DFN),0))!'$GET(DATE)
- GOTO BDTE
- +2 SET Y=""
- SET DATE=9999999-DATE
- FOR
- SET Y=$ORDER(^DGCR(399,"APDT",+DFN,Y))
- if 'Y
- QUIT
- Begin DoDot:1
- +3 IF $ORDER(^DGCR(399,"APDT",+DFN,Y,0))=DATE
- IF '$PIECE($GET(^DGCR(399,Y,"S")),U,16)
- SET X=$PIECE($GET(^DGCR(399,Y,0)),U,17)
- QUIT
- End DoDot:1
- BDTE QUIT X
- +1 ;
- BILLED(PTF) ;returns bill "IFN^^rate group" if PTF record is already associated with an uncancelled final bill
- +1 ;returns "bill IFN ^ bill date (stm to) ^ bill rate group" if inpatients interim with no final bill, 0 otherwise
- +2 NEW IFN,Y,X
- SET Y=0
- IF '$DATA(^DGCR(399,"APTF",+$GET(PTF)))
- GOTO BILLEDQ
- +3 SET IFN=0
- FOR
- SET IFN=$ORDER(^DGCR(399,"APTF",PTF,IFN))
- if 'IFN
- QUIT
- Begin DoDot:1
- +4 ; bill cancelled
- SET X=$GET(^DGCR(399,IFN,0))
- IF $PIECE(X,U,13)=7
- QUIT
- +5 SET Y=IFN_"^^"_$PIECE(X,U,7)
- IF $PIECE(X,U,6)=2!($PIECE(X,U,6)=3)
- SET Y=IFN_"^"_$PIECE($GET(^DGCR(399,IFN,"U")),U,2)_"^"_$PIECE(X,U,7)
- End DoDot:1
- IF +Y
- IF '$PIECE(Y,U,2)
- QUIT
- BILLEDQ QUIT Y
- +1 ;
- FTN(FT) ;returns name of the form type passed in, "" if not defined
- +1 NEW X
- SET X=$PIECE($GET(^IBE(353,+$GET(FT),0)),U,1)
- +2 QUIT X
- +3 ;
- FT(IFN,IBRESET) ;return the correct form type for a bill (trigger code in 399 to set .19)
- +1 ; if IBRESET is not a positive value ('IBRESET), returns the bills current form type (if defined)
- +2 ; if IBRESET is a positive value (+IBRESET), interpret form type according to following rules (for triggers):
- +3 ; first use if bill is inst (UB) or prof (1500) (399,.27), then current (399,.19), then UB
- +4 NEW X,Y,FTC,FTT
- +5 SET X=""
- SET IFN=+$GET(IFN)
- SET Y=$GET(^DGCR(399,IFN,0))
- +6 SET FTC=$PIECE(Y,U,19)
- IF FTC=1
- SET FTC=3
- +7 IF '$GET(IBRESET)
- IF +FTC
- SET X=FTC
- GOTO FTQ
- +8 SET FTT=$SELECT($PIECE(Y,U,27)=1:3,$PIECE(Y,U,27)=2:2,1:"")
- +9 ;JWS;IB*2.0*592;Dental form 7
- +10 IF FTC=7
- IF FTT=2
- QUIT 7
- +11 SET X=$SELECT(+FTT:FTT,+FTC:FTC,1:3)
- FTQ QUIT X
- +1 ;
- FNT(FTN) ;returns the ifn of the form type name passed in, must be exact match, 0 if none found
- +1 NEW X,Y
- SET X=0
- IF $GET(FTN)'=""
- SET X=$ORDER(^IBE(353,"B",FTN,0))
- +2 QUIT X
- +3 ;
- BILLDEV(IFN,PRT) ;returns the default device for a bill's form type, if PRT is passed as true then returns the AR follow up device, otherwise the billing device
- +1 NEW X,Y
- SET X=0
- IF $DATA(^DGCR(399,+$GET(IFN),0))
- SET PRT=$SELECT(+$GET(PRT):3,1:2)
- SET Y=$$FT(IFN)
- SET X=$PIECE($GET(^IBE(353,+Y,0)),U,PRT)
- +2 QUIT X
- +3 ;
- RXDUP(RX,DATE,IFN,DISP,DFN,RTG) ;returns bill ifn if rx # exists on another bill
- +1 ;input: rx # - required, rx # to check for
- +2 ; date - required, date of refill
- +3 ;ifn, dfn, rtg are optional - if not passed then not used to specify rx
- +4 ;(if ifn not passed then returns true if on any bill same or dfn and rtgetc.)
- +5 ;if ifn passed the dfn and rtg do not need to be
- +6 NEW X,LN,RIFN,BIFN,RLN,BLN
- SET (RIFN,X)=0
- SET DATE=$GET(DATE)
- SET RX=$GET(RX)
- SET IFN=$GET(IFN)
- IF RX=""!('DATE)
- GOTO RXDUPE
- +7 SET LN=$GET(^DGCR(399,+IFN,0))
- SET DFN=$SELECT(+$GET(DFN):DFN,1:+$PIECE(LN,U,2))
- SET RTG=$SELECT(+$GET(RTG):RTG,1:+$PIECE(LN,U,7))
- +8 FOR
- SET RIFN=$ORDER(^IBA(362.4,"B",RX,RIFN))
- if 'RIFN
- QUIT
- SET RLN=$GET(^IBA(362.4,+RIFN,0))
- IF +DATE=+$PIECE(RLN,U,3)
- Begin DoDot:1
- +9 SET BIFN=+$PIECE(RLN,U,2)
- SET BLN=$GET(^DGCR(399,BIFN,0))
- if (BLN="")!(BIFN=+$GET(IFN))
- QUIT
- +10 ; bill cancelled
- IF $PIECE(BLN,U,13)=7
- QUIT
- +11 ; different patient
- IF +DFN
- IF $PIECE(BLN,U,2)'=DFN
- QUIT
- +12 ; different rate group
- IF +RTG
- IF +RTG'=$PIECE(BLN,U,7)
- QUIT
- +13 SET X=BIFN_"^A "_$PIECE($GET(^DGCR(399.3,+$PIECE(BLN,U,7),0)),U,1)_" bill ("_$PIECE(BLN,U,1)_") exists for Rx # "_RX_" and refill date "_$$DAT1^IBOUTL(DATE)_"."
- End DoDot:1
- if +X
- QUIT
- RXDUPE IF +$GET(DISP)
- IF +X
- WRITE !,?10,$PIECE(X,U,2)
- +1 QUIT X
- +2 ;
- BCOB(IBIFN,IBCOB) ; returns an array of all bills related COB to the bill passed in
- +1 ; includes prior bills defined on this bill then checks the Primary, Secondary and Tertiary Bills and adds
- +2 ; all the prior bills defined on them
- +3 ; ARR(BILL SEQUENCE (1,2,3), INSURANCE CO, BILL #)=""
- +4 ;
- +5 NEW IBM1,IBI,IBIFN1,IBM,IBM11,IBSEQ,IBSEQN,IBJ
- KILL IBCOB
- +6 SET IBM1=$GET(^DGCR(399,IBIFN,"M1"))
- +7 FOR IBI=IBIFN,+$PIECE(IBM1,U,5),+$PIECE(IBM1,U,6),+$PIECE(IBM1,U,7)
- IF +IBI
- SET IBIFN1=+IBI
- Begin DoDot:1
- +8 ;
- +9 SET IBM=$GET(^DGCR(399,IBIFN1,"M"))
- SET IBM11=$GET(^DGCR(399,IBIFN1,"M1"))
- IF IBIFN=IBIFN1
- IF '$PIECE(IBM,U,2)
- IF '$PIECE(IBM,U,3)
- QUIT
- +10 SET IBSEQ=$PIECE($GET(^DGCR(399,IBIFN1,0)),U,21)
- SET IBSEQN=$SELECT(IBSEQ="P":1,IBSEQ="S":2,IBSEQ="T":3,1:"")
- if 'IBSEQN
- QUIT
- +11 ;
- +12 FOR IBJ=1:1:3
- IF +$PIECE(IBM,U,IBJ)
- SET IBCOB(IBJ,+$PIECE(IBM,U,IBJ),+$PIECE(IBM11,U,(IBJ+4)))=""
- +13 IF +$PIECE(IBM,U,IBSEQN)
- SET IBCOB(IBSEQN,$PIECE(IBM,U,IBSEQN),+IBIFN1)=""
- End DoDot:1
- +14 ;
- +15 SET IBI=0
- FOR
- SET IBI=$ORDER(IBCOB(IBI))
- if 'IBI
- QUIT
- SET IBJ=0
- FOR
- SET IBJ=$ORDER(IBCOB(IBI,IBJ))
- if 'IBJ
- QUIT
- IF +$ORDER(IBCOB(IBI,IBJ,0))
- KILL IBCOB(IBI,IBJ,0)
- +16 QUIT
- +17 ;
- BINS(IBIFN) ; return list of billable insurance carriers on a bill (COB)
- +1 ; output: sequence:carrier:policy ^ sequence:carrier:policy ^ sequence:carrier:policy
- +2 NEW IBM0,IBI,IBS,IBC,IBP,IBX
- SET IBI=0
- SET IBX=""
- SET IBM0=$GET(^DGCR(399,+$GET(IBIFN),"M"))
- +3 FOR IBS="P","S","T"
- SET IBI=IBI+1
- SET IBC=+$PIECE(IBM0,U,IBI)
- IF +IBC
- Begin DoDot:1
- +4 SET IBP=+$PIECE(IBM0,U,(11+IBI))
- IF $PIECE($GET(^DIC(36,+IBC,0)),U,2)'="N"
- SET IBX=IBX_IBS_":"_IBC_":"_IBP_U
- End DoDot:1
- +5 QUIT IBX
- +6 ;
- BOTHER(IBIFN,IBDT) ; return Bedsection of Type of Care if date is Other Type of care, based on "OT" multiple
- +1 ; Other care is not inpatient or outpatient, SNF and Sub-Acute became distinct with RC v2.0
- +2 ; as with all other bedsection movements, the last date is not included since that is the date they left
- +3 NEW IBX,IBY,IBFND
- SET IBFND=0
- SET IBDT=$GET(IBDT)\1
- +4 IF +$GET(IBIFN)
- IF +IBDT
- SET IBX=0
- FOR
- SET IBX=$ORDER(^DGCR(399,IBIFN,"OT",IBX))
- if 'IBX
- QUIT
- Begin DoDot:1
- +5 SET IBY=$GET(^DGCR(399,IBIFN,"OT",IBX,0))
- if 'IBY
- QUIT
- +6 IF IBDT'<$PIECE(IBY,U,2)
- IF IBDT<$PIECE(IBY,U,3)
- SET IBFND=+IBY
- +7 ; 1 day SNF stay
- IF IBDT=($PIECE(IBY,U,2)\1)
- IF IBDT=($PIECE(IBY,U,3)\1)
- SET IBFND=+IBY
- End DoDot:1
- +8 QUIT IBFND