Routine: IBCU3

IBCU3	;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED)  ;12-FEB-90

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, 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,Y S (X,Y)=0 I '$G(DFN) G SCE

	I '$D(VAEL(3)) D ELIG^VADPT S Y=1

	S X=+VAEL(3) I Y K VAEL,VAERR

SCE	Q X

APPT(DATE,DFN,DISP)	;Check date to see if patient has Sched. Appt., add/edit or Registration

	;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 a scheduled visit date was found

	;         2 - if unscheduled/add/edit visit found

	;         3 - disposition found

	;         "0^error message" if no valid visit date 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

	S X=DATE,X1=DATE+.9 F  S X=$O(^DPT(DFN,"S",X)) Q:'X!(X>X1)  I $P(^(X,0),"^",2)="" S Y=1

	I $D(^SDV("ADT",DFN,DATE)) S Y=2 G APPTE ; unscheduled appointments

	I $D(^DPT(DFN,"DIS"))>9 S X=(9999999-(DATE+.000001)\1),X1=X+.9 F  S X=$O(^DPT(DFN,"DIS",X)) Q:'X!(X>X1)  S X2=^(X,0) I $P(X2,".",1)=DATE,$P(X2,U,2)<2 S Y=3

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)	;return a bills form type, based on current (399,.19), default (350.9,1.26), and ins co (36,.14) form types

	N X,Y,FTC,FTN,FTD,FTI,INS S X="",IFN=+$G(IFN),Y=$G(^DGCR(399,IFN,0)),FTC=$P(Y,U,19)

	I +FTC,$E($$FTN(FTC),1,3)'="UB-" S X=FTC G FTQ ; not a UB bill, don't change

	; otherwise use the ins co default, then site's default, then current, then UB-82

	S INS=+$G(^DGCR(399,IFN,"M")),FTD=$P($G(^IBE(350.9,1,1)),U,26),FTI=$P($G(^DIC(36,+INS,0)),U,14)

	I 'FTC S X=$S(+FTI:FTI,+FTD:FTD,1:1) G FTQ

	I $E($$FTN(FTI),1,2)="UB" S X=FTI

	I 'X,$E($$FTN(FTD),1,2)="UB" S X=FTD

	I 'X S X=FTC I 'X S X=1

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

IBCU3     ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED)  ;12-FEB-90

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, 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,Y

           SET (X,Y)=0

           IF '$GET(DFN)

               GOTO SCE

 +2        IF '$DATA(VAEL(3))

               DO ELIG^VADPT

               SET Y=1

 +3        SET X=+VAEL(3)

           IF Y

               KILL VAEL,VAERR

SCE        QUIT X

 +1       ;

APPT(DATE,DFN,DISP) ;Check date to see if patient has Sched. Appt., add/edit or Registration

 +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 a scheduled visit date was found

 +5       ;         2 - if unscheduled/add/edit visit found

 +6       ;         3 - disposition found

 +7       ;         "0^error message" if no valid visit date 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       SET X=DATE

           SET X1=DATE+.9

FOR

               SET X=$ORDER(^DPT(DFN,"S",X))

               IF 'X!(X>X1)

                   QUIT

               IF $PIECE(^(X,0),"^",2)=""

                   SET Y=1

 +12      ; unscheduled appointments

           IF $DATA(^SDV("ADT",DFN,DATE))

               SET Y=2

               GOTO APPTE

 +13       IF $DATA(^DPT(DFN,"DIS"))>9

               SET X=(9999999-(DATE+.000001)\1)

               SET X1=X+.9

FOR

                   SET X=$ORDER(^DPT(DFN,"DIS",X))

                   IF 'X!(X>X1)

                       QUIT

                   SET X2=^(X,0)

                   IF $PIECE(X2,".",1)=DATE

                       IF $PIECE(X2,U,2)<2

                           SET Y=3

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)   ;return a bills form type, based on current (399,.19), default (350.9,1.26), and ins co (36,.14) form types

 +1        NEW X,Y,FTC,FTN,FTD,FTI,INS

           SET X=""

           SET IFN=+$GET(IFN)

           SET Y=$GET(^DGCR(399,IFN,0))

           SET FTC=$PIECE(Y,U,19)

 +2       ; not a UB bill, don't change

           IF +FTC

               IF $EXTRACT($$FTN(FTC),1,3)'="UB-"

                   SET X=FTC

                   GOTO FTQ

 +3       ; otherwise use the ins co default, then site's default, then current, then UB-82

 +4        SET INS=+$GET(^DGCR(399,IFN,"M"))

           SET FTD=$PIECE($GET(^IBE(350.9,1,1)),U,26)

           SET FTI=$PIECE($GET(^DIC(36,+INS,0)),U,14)

 +5        IF 'FTC

               SET X=$SELECT(+FTI:FTI,+FTD:FTD,1:1)

               GOTO FTQ

 +6        IF $EXTRACT($$FTN(FTI),1,2)="UB"

               SET X=FTI

 +7        IF 'X

               IF $EXTRACT($$FTN(FTD),1,2)="UB"

                   SET X=FTD

 +8        IF 'X

               SET X=FTC

               IF 'X

                   SET X=1

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

IBCU3.m