IBCU ;ALB/MRL - BILLING UTILITY ROUTINE ;01 JUN 88 12:00
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRU
;
ARSTAT ;find status of bill in file 430.3 (ar) return status number
S IBARST=$$STA^PRCAFN(IBIFN)
Q
;
ARCAT ;Trigger logic to set who's responsible in 399.3 from AR Category
S X=$P($$CATN^PRCAFN($P(^DGCR(399.3,DA,0),"^",6)),"^",3)
S:X'="" X=$S("PC"[X:"p",X="N":"o",X="T":"i",1:"")
Q
;
PTF ;Screen for appropriate PTF records
K IBDD1 S DFN=+$P(^DGCR(399,+DA,0),"^",2) Q:'$D(^DPT(+DFN,0)) S IB05=$P(^(0),"^",1),IB03=$P(^DGCR(399,+DA,0),"^",3)
S IB01="",IB02=0 F IB02=0:0 S IB01=$O(^DD(45,0,"ID",IB01)) Q:'IB01 S IB02=IB02+1,IBDD(IB02)=^(IB01)
F IB01=0:0 S IB01=$O(^DGPT("B",+DFN,IB01)) Q:'IB01 I $D(^DGPT(+IB01,0)) S IB04=$P(^(0),"^",2),Y=+IB01 I $P(IB03,".",1)=$P(IB04,".",1) S IBDD1(+Y)="" I $S('$D(X):0,X["?":1,1:0) D PTFW
G PTFQ:X'["?" I '$O(IBDD1(0)) W !,"Patient has no ACTIVE PTF RECORDS for this event date.",!,"A 'PTF NUMBER' is required for inpatient billing records."
E W !!,"Select the appropriate billing record from the above listing by number."
PTFQ W ! K IB01,IB02,IB03,IB04,IB05,IBDD Q
PTFW W !,Y,?15,IB05 F IB02=0:0 S IB02=$O(IBDD(IB02)) Q:'IB02 X IBDD(IB02)
Q
;
AGE ;Input Transform for Condition Code 17
I X=18 G SEX
I X=17 S IBC=X,DFN=$P(^DGCR(399,D0,0),"^",2) D DEM^VADPT I VADM(4)<100 W !!,"This patient is only ",VADM(4)," years old!!",!! K IBC Q
I $D(IBC) S X=IBC
Q
;
SEX ;Input Transform for Condition Code 18
I X=18 S IBC=X,DFN=$P(^DGCR(399,D0,0),"^",2) D DEM^VADPT I $E(VADM(5))="M" W !!,"This patient is a MALE!! Condition code 18 applies only to FEMALES!!",!! K IBC,X
I $D(IBC) S X=IBC
Q
;
REV ;Input Transform for Revenue Code
I X=-1 W !!,"Choose only ACTIVE Revenue Codes!!",!! S D="AC" ;S X="" S X=$O(^DGCR(399.2,"AC",X)) Q:X="" W !,$P(^DGCR(399.2,X,0),"^",1),?30,$P(^(0),"^",2) K X Q
I '$D(IBC) I $D(^DGCR(399.2,X,0)) I '$P(^DGCR(399.2,X,0),"^",3) W !!,"Only ACTIVE Revenue Codes may be selected!!",!! K X Q
Q
;
YN S X=$E(X),X=$S(X=1:X,X=0:X,X="Y":1,X="y":1,X="n":0,X="N":0,1:2) I X'=2 W " (",$S(X:"YES",1:"NO"),")" Q
W !?4,"NOT A VALID CHOICE!",*7 K X Q
Q
;
DIS ;Determine Billing Discharge status from PTF
;Called from triggers on fields .08 and 161
N A
I '$D(^DGCR(399,DA,0)) S X="" G DISQ
S X=$P(^DGCR(399,DA,0),"^",6) I X=2!(X=3) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
S X=$P(^DGCR(399,DA,0),"^",8) I $S(X="":1,'$D(^DGPT(X)):1,1:0) S X="" G DISQ
I '+$G(^DGPT(X,70)) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
S A=$P($G(^DGCR(399,DA,"U")),"^",2) I A,(A+.24)<+$G(^DGPT(X,70)) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
S X=+$P($G(^DGPT(X,70)),"^",3)
I X=1 S X=$O(^DGCR(399.1,"B",$E("DISCHARGED TO HOME OR SELF CARE",1,30),0)) G DISQ
I X=4 S X=$O(^DGCR(399.1,"B",$E("LEFT AGAINST MEDICAL ADVICE",1,30),0)) G DISQ
I X=6!(X=7) S X=$O(^DGCR(399.1,"B","EXPIRED",0)) G DISQ
I X=5!(X=2) S X=$O(^DGCR(399.1,"B",$E("DISCHARGED TO ANOTHER SHORT-TERM GENERAL HOSPITAL",1,30),0)) G DISQ
S X=""
DISQ Q
;
INST ;Ask Institutution address info
S DIC("DR")="1.01;1.02;1.03;.02;1.04" I $D(^XUSEC("IB SUPERVISOR",DUZ)) S DLAYGO=4
Q
;
SM ;Flag for printing medicare statment on UB-82
;DGSM=0 means figure out which statement, DGSM=1 means no statements
S DGSM=0 Q
;IBCU
IBCU ;ALB/MRL - BILLING UTILITY ROUTINE ;01 JUN 88 12:00
+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 DGCRU
+5 ;
ARSTAT ;find status of bill in file 430.3 (ar) return status number
+1 SET IBARST=$$STA^PRCAFN(IBIFN)
+2 QUIT
+3 ;
ARCAT ;Trigger logic to set who's responsible in 399.3 from AR Category
+1 SET X=$PIECE($$CATN^PRCAFN($PIECE(^DGCR(399.3,DA,0),"^",6)),"^",3)
+2 IF X'=""
SET X=$SELECT("PC"[X:"p",X="N":"o",X="T":"i",1:"")
+3 QUIT
+4 ;
PTF ;Screen for appropriate PTF records
+1 KILL IBDD1
SET DFN=+$PIECE(^DGCR(399,+DA,0),"^",2)
IF '$DATA(^DPT(+DFN,0))
QUIT
SET IB05=$PIECE(^(0),"^",1)
SET IB03=$PIECE(^DGCR(399,+DA,0),"^",3)
+2 SET IB01=""
SET IB02=0
FOR IB02=0:0
SET IB01=$ORDER(^DD(45,0,"ID",IB01))
IF 'IB01
QUIT
SET IB02=IB02+1
SET IBDD(IB02)=^(IB01)
+3 FOR IB01=0:0
SET IB01=$ORDER(^DGPT("B",+DFN,IB01))
IF 'IB01
QUIT
IF $DATA(^DGPT(+IB01,0))
SET IB04=$PIECE(^(0),"^",2)
SET Y=+IB01
IF $PIECE(IB03,".",1)=$PIECE(IB04,".",1)
SET IBDD1(+Y)=""
IF $SELECT('$DATA(X):0,X["?":1,1:0)
DO PTFW
+4 IF X'["?"
GOTO PTFQ
IF '$ORDER(IBDD1(0))
WRITE !,"Patient has no ACTIVE PTF RECORDS for this event date.",!,"A 'PTF NUMBER' is required for inpatient billing records."
+5 IF '$TEST
WRITE !!,"Select the appropriate billing record from the above listing by number."
PTFQ WRITE !
KILL IB01,IB02,IB03,IB04,IB05,IBDD
QUIT
PTFW WRITE !,Y,?15,IB05
FOR IB02=0:0
SET IB02=$ORDER(IBDD(IB02))
IF 'IB02
QUIT
XECUTE IBDD(IB02)
+1 QUIT
+2 ;
AGE ;Input Transform for Condition Code 17
+1 IF X=18
GOTO SEX
+2 IF X=17
SET IBC=X
SET DFN=$PIECE(^DGCR(399,D0,0),"^",2)
DO DEM^VADPT
IF VADM(4)<100
WRITE !!,"This patient is only ",VADM(4)," years old!!",!!
KILL IBC
QUIT
+3 IF $DATA(IBC)
SET X=IBC
+4 QUIT
+5 ;
SEX ;Input Transform for Condition Code 18
+1 IF X=18
SET IBC=X
SET DFN=$PIECE(^DGCR(399,D0,0),"^",2)
DO DEM^VADPT
IF $EXTRACT(VADM(5))="M"
WRITE !!,"This patient is a MALE!! Condition code 18 applies only to FEMALES!!",!!
KILL IBC,X
+2 IF $DATA(IBC)
SET X=IBC
+3 QUIT
+4 ;
REV ;Input Transform for Revenue Code
+1 ;S X="" S X=$O(^DGCR(399.2,"AC",X)) Q:X="" W !,$P(^DGCR(399.2,X,0),"^",1),?30,$P(^(0),"^",2) K X Q
IF X=-1
WRITE !!,"Choose only ACTIVE Revenue Codes!!",!!
SET D="AC"
+2 IF '$DATA(IBC)
IF $DATA(^DGCR(399.2,X,0))
IF '$PIECE(^DGCR(399.2,X,0),"^",3)
WRITE !!,"Only ACTIVE Revenue Codes may be selected!!",!!
KILL X
QUIT
+3 QUIT
+4 ;
YN SET X=$EXTRACT(X)
SET X=$SELECT(X=1:X,X=0:X,X="Y":1,X="y":1,X="n":0,X="N":0,1:2)
IF X'=2
WRITE " (",$SELECT(X:"YES",1:"NO"),")"
QUIT
+1 WRITE !?4,"NOT A VALID CHOICE!",*7
KILL X
QUIT
+2 QUIT
+3 ;
DIS ;Determine Billing Discharge status from PTF
+1 ;Called from triggers on fields .08 and 161
+2 NEW A
+3 IF '$DATA(^DGCR(399,DA,0))
SET X=""
GOTO DISQ
+4 SET X=$PIECE(^DGCR(399,DA,0),"^",6)
IF X=2!(X=3)
SET X=$ORDER(^DGCR(399.1,"B","STILL PATIENT",0))
GOTO DISQ
+5 SET X=$PIECE(^DGCR(399,DA,0),"^",8)
IF $SELECT(X="":1,'$DATA(^DGPT(X)):1,1:0)
SET X=""
GOTO DISQ
+6 IF '+$GET(^DGPT(X,70))
SET X=$ORDER(^DGCR(399.1,"B","STILL PATIENT",0))
GOTO DISQ
+7 SET A=$PIECE($GET(^DGCR(399,DA,"U")),"^",2)
IF A
IF (A+.24)<+$GET(^DGPT(X,70))
SET X=$ORDER(^DGCR(399.1,"B","STILL PATIENT",0))
GOTO DISQ
+8 SET X=+$PIECE($GET(^DGPT(X,70)),"^",3)
+9 IF X=1
SET X=$ORDER(^DGCR(399.1,"B",$EXTRACT("DISCHARGED TO HOME OR SELF CARE",1,30),0))
GOTO DISQ
+10 IF X=4
SET X=$ORDER(^DGCR(399.1,"B",$EXTRACT("LEFT AGAINST MEDICAL ADVICE",1,30),0))
GOTO DISQ
+11 IF X=6!(X=7)
SET X=$ORDER(^DGCR(399.1,"B","EXPIRED",0))
GOTO DISQ
+12 IF X=5!(X=2)
SET X=$ORDER(^DGCR(399.1,"B",$EXTRACT("DISCHARGED TO ANOTHER SHORT-TERM GENERAL HOSPITAL",1,30),0))
GOTO DISQ
+13 SET X=""
DISQ QUIT
+1 ;
INST ;Ask Institutution address info
+1 SET DIC("DR")="1.01;1.02;1.03;.02;1.04"
IF $DATA(^XUSEC("IB SUPERVISOR",DUZ))
SET DLAYGO=4
+2 QUIT
+3 ;
SM ;Flag for printing medicare statment on UB-82
+1 ;DGSM=0 means figure out which statement, DGSM=1 means no statements
+2 SET DGSM=0
QUIT
+3 ;IBCU
