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
