IBTUTL5 ;ALB/OEC - CLAIMS TRACKING UTILITY ROUTINE ;16-JAN-09
;;2.0;INTEGRATED BILLING;**399**;21-MAR-94;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
OPT(IBOE,IBDT) ; - Has the outpatient encounter been billed?
; Input: IBOE=pointer to outpatient encounter in file #409.68
; IBDT=event date CLAIMS TRACKING(#356)
;
; ; *Pre-set variables: DFN=patient IEN, RIMB=bill rate
;
;
I '$G(DFN)!('$G(IBDT))!('$G(RIMB))!('$G(IBOE)) S IBRTN=0 G OPTQ
N IBCN,IBCPT,IBCT,IBDATA,IBDAY,IBDIV,IBXX,IBYD,IBYY,IBZ,IBMRA,IBCPTSUM,IBTCHRG,IBRTN,IBAUTH
; - Check to be sure the encounter is billable.
I $$INPT^IBAMTS1(DFN,IBDT\1_.2359) S IBRTN=0 G OPTQ ; Became inpatient same day.
I $$ENCL^IBAMTS2(IBOE)["1" S IBRTN=0 G OPTQ ; "ao^ir^sc^swa^mst^hnc^cv^shad" encounter.
;
;
; - Gather all procedures associated with the encounter.
D GETCPT^SDOE(IBOE,"IBYY") I '$G(IBYY) S IBRTN=0 G OPTQ ; Check CPT qty.
;
; - Determine the encounter division.
S IBDIV=+$P($$GETOE^SDOE(IBOE),U,11) S:'IBDIV IBDIV=+$$PRIM^VASITE()
;
; - Build array of all billable encounter procedures.
S IBXX=0 F S IBXX=$O(IBYY(IBXX)) Q:'IBXX D
. ;
. ; - Get procedure pointer and code.
. S IBZ=+IBYY(IBXX),IBCN=$P($$CPT^ICPTCOD(IBZ),"^",2)
. ;
. ; - Ignore LAB services for vets with Medicare Supplemental coverage.
. I IBCN>79999,IBCN<90000 Q
. ;
. ; - Get the institutional/professional charge components.
. S IBCPT(IBZ,1)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",1)
. S IBCPT(IBZ,2)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",2)
. ;
. ; - Eliminate components without a charge.
. S IBCPTSUM(IBZ)=+$G(IBCPT(IBZ,1))+$G(IBCPT(IBZ,2))
. I 'IBCPT(IBZ,1) K IBCPT(IBZ,1)
. I 'IBCPT(IBZ,2) K IBCPT(IBZ,2)
;
I '$D(IBCPT) S IBRTN=0 G OPTQ ; Quit if no billable procedures remain.
;
; - Look at all of the vet's bills for the day and eliminate
; from the array those procedures that have been billed.
S IBXX=0 S IBDAY=$E(IBDT,1,7)
F S IBXX=$O(^DGCR(399,"AOPV",DFN,IBDAY,IBXX)) Q:'IBXX D
. ;
. ; - Perform general checks on the claim.
. S IBDATA=$$CKBIL^IBTUBOU(IBXX) Q:IBDATA=""
. S IBAUTH=$P($G(IBDATA),U,2)
. I $G(IBAUTH)<2&($G(IBAUTH)>5) Q
. ; - The episode has been billed. Check the revenue code multiple for
. ; all procedures billed on the claim.
. S IBYY=0
. F S IBYY=$O(^DGCR(399,IBXX,"RC",IBYY)) Q:'IBYY S IBYD=^(IBYY,0) D
. . ;
. . ; - Get the procedure code,charge type and total charges for the revenue code.
. . S IBZ=$P(IBYD,U,6)
. . S IBCT=$S($P(IBYD,U,12):$P(IBYD,U,12),1:$P(IBDATA,U,4))
. . S IBTCHRG=$P(IBYD,U,4)
. . I 'IBZ!('IBCT) Q ; Can't determine code/charge type for procedure.
. . ; Delete procedure from unbilled procedures array.
. . I $G(IBTCHRG)'<$G(IBCPTSUM(IBZ)) K IBCPT(IBZ)
. . I $D(IBCPT(IBZ,IBCT)) K IBCPT(IBZ,IBCT)
;
; - Again, quit if no billable procedures remain.
I '$D(IBCPT) S IBRTN=0 G OPTQ
; - If there are billable procedures return TOTAL AMOUNT
I $D(IBCPT) S (IBZ,IBCT,IBRTN)=0
F S IBZ=$O(IBCPT(IBZ)) Q:'IBZ D
.F S IBCT=$O(IBCPT(IBZ,IBCT)) Q:'IBCT D
..S IBRTN=IBRTN+IBCPT(IBZ,IBCT)
;
OPTQ K IBCPT Q IBRTN
;
;
ADMDT(DFN,EPDT) ;
;
;Returns the next Admission dt for CLAIMS TRACKING entry with RNB 72 HR Rule
; input : DFN (required) := Pointer to PATIENT file (#2)
; from CLAIMS TRACKING file (#356)
; EPDT (required): = Episode dt field (.06) from
; CLAIMS TRAKCING file (#356)
;
; output : If patient has an admission after episode dt
; IBADMDT := ADMISSION DT
; IF NO ADMISSION DT IBADMDT := NULL
;
K IBADMDT,ADMID,EPID,ADMIFN
I '$G(DFN)!('$G(EPDT)) S IBADMDT="" G ADMDTQ
I '$D(^DGPM("ATID1",DFN)) S IBADMDT="" G ADMDTQ ; REF DBIA419
S ADMID=9999999.999999-EPDT,EPID=ADMID,ADMIFN=0,X=0
F X=1:1:1 S ADMID=$O(^DGPM("ATID1",DFN,ADMID),-1) Q:'ADMID D
.S ADMIFN=+$O(^DGPM("ATID1",DFN,ADMID,0))
.I $D(^DGPM(ADMIFN,0)) S IBADMDT=$E($P(^(0),U),1,7)
;
;Format date for PRINTED and EXCEL RNB report
;
I $G(IBEXCEL) S IBADMDT=$$DT^IBJD($G(IBADMDT),1)
I '$G(IBEXCEL) S IBADMDT=$$DTE^IBJDB22($G(IBADMDT))
;
ADMDTQ ;
;
S:'$D(IBADMDT) IBADMDT=""
Q IBADMDT
;
;
RXAMT(EPDT,RXIEN) ;
;
; -- input epdt := episode date from CLAIMS TRACKING(#356)
; RXIEN := RX field from CLAIMS TRACKING(#356)
;
; -- output 0 if RX billed or -1 if RX not billed
;
I '$G(EPDT)!('$G(IBRX)) S IBRTN=-1 G RXAMTQ
N IBRXCLM,IBCLM,IBRTN,IBAUTH,IBMRA
S IBRX=$$FILE^IBRXUTL(RXIEN,.01)
S IBRXCLM=0
F S IBRXCLM=$O(^IBA(362.4,"B",IBRX,IBRXCLM)) Q:'IBRXCLM D
.I $P(^IBA(362.4,IBRXCLM,0),U,3)=EPDT S IBCLM=$P(^(0),U,2)
I '$G(IBCLM) S IBRTN=-1 G RXAMTQ
I $G(IBCLM) S IBAUTH=$P($$CKBIL^IBTUBOU(IBCLM),U,2)
I $G(IBAUTH)>2!($G(IBAUTH)<5) S IBRTN=0 G RXAMTQ
E S IBRTN=-1 G RXAMTQ
;
RXAMTQ Q IBRTN
;
;
PRSAMT(EPDT,PRST) ;
;
; input epdt := episode date from CLAIMS TRACKING(#356)
; prst := prosthetic item from CLAIMS TRACKING(#356)
;
; ouptut 0 if prosthetics item billed or -1 if item not billed
;
I '$G(EPDT)!('$G(PRST)) S IBRTN=-1 G PRSAMTQ
N IBPRCLM,IBCLM,IBRTN,IBAUTH,IBMRA
S IBPRCLM=0
F S IBPRCLM=$O(^IBA(362.5,"AE",PRST,IBPRCLM)) Q:'IBPRCLM D
.S IBCLM=$P(^IBA(362.5,IBPRCLM,0),U,2)
I '$G(IBCLM) S IBRTN=-1 G PRSAMTQ
I $G(IBCLM) S IBAUTH=$P(^DGCR(399,IBCLM,0),U,13)
I $G(IBAUTH)'<2&($G(IBAUTH)'>5) S IBRTN=0 G PRSAMTQ
E S IBRTN=-1 G PRSAMTQ
;
;
PRSAMTQ Q IBRTN
;
;
RELBIL(IEN,EPDT,DFN,ENCTYP) ;
;
; ---- Input IEN := IEN of encounter
; epdt := Episode Date from CLAIMS TRACKING
; DFN := Patient file (#2) IEN
; ENCTYP := Type of encounter 1=inpatient 2=Outpatient
; 3=Prosthetics 4=Prescription
;
; Output Related Bills IF NO RELATED BILL IBRTN=""
; IF RELATED BILLS
; IBRTN= #OF RELATED BILLS;RELATED BILL
;
I '$G(EPDT)!('$G(DFN))!('$G(ENCTYP)) S IBRTN=-1 G RELBILQ
;
I ENCTYP=1 S IBRTN=$$INPTREL(DFN,EPDT) G RELBILQ
;
I ENCTYP=2 S IBRTN=$$OPTREL(DFN,EPDT) G RELBILQ
;
I ENCTYP=3 S IBRTN=$$RXREL(IEN,EPDT) G RELBILQ
;
I ENCTYP=4 S IBRTN=$$PROSREL(IEN,EPDT) G RELBILQ
;
RELBILQ Q IBRTN
;
;
INPTREL(DFN,EPDT) ;
;
;
I '$G(DFN)!('$G(EPDT)) S IBRTN=-1 Q IBRTN
N IBCLM,IBDATA,IBN0,IBCLM,IBCNT,IBRTN
S (IBCLM,IBCNT,IBRTN)=0
F S IBCLM=$O(^DGCR(399,"C",DFN,IBCLM)) Q:'IBCLM D
.Q:$P($G(^DGCR(399,IBCLM,0)),U,5)'=1
.Q:$E($P($G(^DGCR(399,IBCLM,0)),U,3),1,7)'=EPDT S IBDATA=$$CKBIL^IBTUBOU(IBCLM,1) Q:'+IBDATA
.S IBN0=^DGCR(399,IBCLM,0) Q:IBRTN[$P(^(0),U)
.S IBCNT=IBCNT+1,$P(IBRTN,";",1)=IBCNT
.S $P(IBRTN,";",IBCNT+1)=$P(IBN0,U)_$S($P(IBN0,U,27)=1:"i",$P(IBN0,U,27)=2:"p",1:"")
I IBRTN=0 S IBRTN=-1
Q IBRTN
;
;
OPTREL(DFN,EPDT) ;
;
;
I '$G(DFN)!('$G(EPDT)) S IBRTN=-1 Q IBRTN
N IBXX,IBCNT,IBN0,IBDATA,IBXX,IBCNT,IBRTN
S (IBXX,IBCNT,IBRTN)=0
F S IBXX=$O(^DGCR(399,"AOPV",DFN,EPDT,IBXX)) Q:'IBXX D
.S IBDATA=$$CKBIL^IBTUBOU(IBXX) Q:'+IBDATA
.S IBN0=^DGCR(399,IBXX,0)
.Q:IBRTN[$P(^(0),U)
.S IBCNT=IBCNT+1,$P(IBRTN,";",1)=IBCNT
.S $P(IBRTN,";",IBCNT+1)=$P(IBN0,U)_$S($P(IBN0,U,27)=1:"i",$P(IBN0,U,27)=2:"p",1:"")
I IBRTN=0 S IBRTN=-1
Q IBRTN
;
;
PROSREL(IEN,EPDT) ;
;
;INPUT IEN=POINTER TO FILE 660
; EPDT=DATE PROS ITEM ISSUED
;
;OUTPUT IBRTN=-1 IF NOT BILL FOUND OR
; # OF RELATED;RELATED BILLS
;
N IBXX,IBCLM,IBYY,IBCNT,IBRTN,IBDATA,IBN0
I '$G(IEN) S IBRTN=-1 Q IBRTN
S (IBXX,IBYY,IBCNT,IBRTN)=0
F S IBXX=$O(^IBA(362.5,"AE",IEN,IBXX)) Q:'IBXX D
.S IBCLM=$P(^IBA(362.5,IBXX,0),U,2)
.I '$D(^DGCR(399,IBCLM,0)) Q
.S IBN0=^DGCR(399,IBCLM,0) Q:IBRTN[$P(^(0),U)
.I $P(IBN0,U,13)<2!($P(IBN0,U,13)>5) Q
.S IBCNT=IBCNT+1,$P(IBRTN,";",1)=IBCNT
.S $P(IBRTN,";",IBCNT+1)=$P(IBN0,U)_$S($P(IBN0,U,27)=1:"i",$P(IBN0,U,27)=2:"p",1:"")
I IBRTN=0 S IBRTN=-1
Q IBRTN
;
;
RXREL(IEN,EPDT) ;
;
;
N IBCLM,IBYY,IBRX,IBRTN,IBCNT
I '$G(IEN) S IBRTN=-1 Q IBRTN
S IBRX=$$FILE^IBRXUTL(IEN,.01)
S (IBYY,IBCNT,IBRTN)=0
F S IBYY=$O(^IBA(362.4,"B",IBRX,IBYY)) Q:'IBYY D
.Q:$P(^IBA(362.4,IBYY,0),U,3)'=EPDT S IBCLM=$P(^(0),U,2)
.S IBDATA=$$CKBIL^IBTUBOU(IBCLM) Q:'+IBDATA
.S IBN0=^DGCR(399,IBCLM,0) Q:IBRTN[$P(^(0),U)
.S IBCNT=IBCNT+1,$P(IBRTN,";",1)=IBCNT
.S $P(IBRTN,";",IBCNT+1)=$P(IBN0,U)_$S($P(IBN0,U,27)=1:"i",$P(IBN0,U,27)=2:"p",1:"")
I IBRTN=0 S IBRTN=-1
Q IBRTN
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTUTL5 8728 printed Apr 09, 2024@21:15:23 Page 2
IBTUTL5 ;ALB/OEC - CLAIMS TRACKING UTILITY ROUTINE ;16-JAN-09
+1 ;;2.0;INTEGRATED BILLING;**399**;21-MAR-94;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
OPT(IBOE,IBDT) ; - Has the outpatient encounter been billed?
+1 ; Input: IBOE=pointer to outpatient encounter in file #409.68
+2 ; IBDT=event date CLAIMS TRACKING(#356)
+3 ;
+4 ; ; *Pre-set variables: DFN=patient IEN, RIMB=bill rate
+5 ;
+6 ;
+7 IF '$GET(DFN)!('$GET(IBDT))!('$GET(RIMB))!('$GET(IBOE))
SET IBRTN=0
GOTO OPTQ
+8 NEW IBCN,IBCPT,IBCT,IBDATA,IBDAY,IBDIV,IBXX,IBYD,IBYY,IBZ,IBMRA,IBCPTSUM,IBTCHRG,IBRTN,IBAUTH
+9 ; - Check to be sure the encounter is billable.
+10 ; Became inpatient same day.
IF $$INPT^IBAMTS1(DFN,IBDT\1_.2359)
SET IBRTN=0
GOTO OPTQ
+11 ; "ao^ir^sc^swa^mst^hnc^cv^shad" encounter.
IF $$ENCL^IBAMTS2(IBOE)["1"
SET IBRTN=0
GOTO OPTQ
+12 ;
+13 ;
+14 ; - Gather all procedures associated with the encounter.
+15 ; Check CPT qty.
DO GETCPT^SDOE(IBOE,"IBYY")
IF '$GET(IBYY)
SET IBRTN=0
GOTO OPTQ
+16 ;
+17 ; - Determine the encounter division.
+18 SET IBDIV=+$PIECE($$GETOE^SDOE(IBOE),U,11)
if 'IBDIV
SET IBDIV=+$$PRIM^VASITE()
+19 ;
+20 ; - Build array of all billable encounter procedures.
+21 SET IBXX=0
FOR
SET IBXX=$ORDER(IBYY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+22 ;
+23 ; - Get procedure pointer and code.
+24 SET IBZ=+IBYY(IBXX)
SET IBCN=$PIECE($$CPT^ICPTCOD(IBZ),"^",2)
+25 ;
+26 ; - Ignore LAB services for vets with Medicare Supplemental coverage.
+27 IF IBCN>79999
IF IBCN<90000
QUIT
+28 ;
+29 ; - Get the institutional/professional charge components.
+30 SET IBCPT(IBZ,1)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",1)
+31 SET IBCPT(IBZ,2)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",2)
+32 ;
+33 ; - Eliminate components without a charge.
+34 SET IBCPTSUM(IBZ)=+$GET(IBCPT(IBZ,1))+$GET(IBCPT(IBZ,2))
+35 IF 'IBCPT(IBZ,1)
KILL IBCPT(IBZ,1)
+36 IF 'IBCPT(IBZ,2)
KILL IBCPT(IBZ,2)
End DoDot:1
+37 ;
+38 ; Quit if no billable procedures remain.
IF '$DATA(IBCPT)
SET IBRTN=0
GOTO OPTQ
+39 ;
+40 ; - Look at all of the vet's bills for the day and eliminate
+41 ; from the array those procedures that have been billed.
+42 SET IBXX=0
SET IBDAY=$EXTRACT(IBDT,1,7)
+43 FOR
SET IBXX=$ORDER(^DGCR(399,"AOPV",DFN,IBDAY,IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+44 ;
+45 ; - Perform general checks on the claim.
+46 SET IBDATA=$$CKBIL^IBTUBOU(IBXX)
if IBDATA=""
QUIT
+47 SET IBAUTH=$PIECE($GET(IBDATA),U,2)
+48 IF $GET(IBAUTH)<2&($GET(IBAUTH)>5)
QUIT
+49 ; - The episode has been billed. Check the revenue code multiple for
+50 ; all procedures billed on the claim.
+51 SET IBYY=0
+52 FOR
SET IBYY=$ORDER(^DGCR(399,IBXX,"RC",IBYY))
if 'IBYY
QUIT
SET IBYD=^(IBYY,0)
Begin DoDot:2
+53 ;
+54 ; - Get the procedure code,charge type and total charges for the revenue code.
+55 SET IBZ=$PIECE(IBYD,U,6)
+56 SET IBCT=$SELECT($PIECE(IBYD,U,12):$PIECE(IBYD,U,12),1:$PIECE(IBDATA,U,4))
+57 SET IBTCHRG=$PIECE(IBYD,U,4)
+58 ; Can't determine code/charge type for procedure.
IF 'IBZ!('IBCT)
QUIT
+59 ; Delete procedure from unbilled procedures array.
+60 IF $GET(IBTCHRG)'<$GET(IBCPTSUM(IBZ))
KILL IBCPT(IBZ)
+61 IF $DATA(IBCPT(IBZ,IBCT))
KILL IBCPT(IBZ,IBCT)
End DoDot:2
End DoDot:1
+62 ;
+63 ; - Again, quit if no billable procedures remain.
+64 IF '$DATA(IBCPT)
SET IBRTN=0
GOTO OPTQ
+65 ; - If there are billable procedures return TOTAL AMOUNT
+66 IF $DATA(IBCPT)
SET (IBZ,IBCT,IBRTN)=0
+67 FOR
SET IBZ=$ORDER(IBCPT(IBZ))
if 'IBZ
QUIT
Begin DoDot:1
+68 FOR
SET IBCT=$ORDER(IBCPT(IBZ,IBCT))
if 'IBCT
QUIT
Begin DoDot:2
+69 SET IBRTN=IBRTN+IBCPT(IBZ,IBCT)
End DoDot:2
End DoDot:1
+70 ;
OPTQ KILL IBCPT
QUIT IBRTN
+1 ;
+2 ;
ADMDT(DFN,EPDT) ;
+1 ;
+2 ;Returns the next Admission dt for CLAIMS TRACKING entry with RNB 72 HR Rule
+3 ; input : DFN (required) := Pointer to PATIENT file (#2)
+4 ; from CLAIMS TRACKING file (#356)
+5 ; EPDT (required): = Episode dt field (.06) from
+6 ; CLAIMS TRAKCING file (#356)
+7 ;
+8 ; output : If patient has an admission after episode dt
+9 ; IBADMDT := ADMISSION DT
+10 ; IF NO ADMISSION DT IBADMDT := NULL
+11 ;
+12 KILL IBADMDT,ADMID,EPID,ADMIFN
+13 IF '$GET(DFN)!('$GET(EPDT))
SET IBADMDT=""
GOTO ADMDTQ
+14 ; REF DBIA419
IF '$DATA(^DGPM("ATID1",DFN))
SET IBADMDT=""
GOTO ADMDTQ
+15 SET ADMID=9999999.999999-EPDT
SET EPID=ADMID
SET ADMIFN=0
SET X=0
+16 FOR X=1:1:1
SET ADMID=$ORDER(^DGPM("ATID1",DFN,ADMID),-1)
if 'ADMID
QUIT
Begin DoDot:1
+17 SET ADMIFN=+$ORDER(^DGPM("ATID1",DFN,ADMID,0))
+18 IF $DATA(^DGPM(ADMIFN,0))
SET IBADMDT=$EXTRACT($PIECE(^(0),U),1,7)
End DoDot:1
+19 ;
+20 ;Format date for PRINTED and EXCEL RNB report
+21 ;
+22 IF $GET(IBEXCEL)
SET IBADMDT=$$DT^IBJD($GET(IBADMDT),1)
+23 IF '$GET(IBEXCEL)
SET IBADMDT=$$DTE^IBJDB22($GET(IBADMDT))
+24 ;
ADMDTQ ;
+1 ;
+2 if '$DATA(IBADMDT)
SET IBADMDT=""
+3 QUIT IBADMDT
+4 ;
+5 ;
RXAMT(EPDT,RXIEN) ;
+1 ;
+2 ; -- input epdt := episode date from CLAIMS TRACKING(#356)
+3 ; RXIEN := RX field from CLAIMS TRACKING(#356)
+4 ;
+5 ; -- output 0 if RX billed or -1 if RX not billed
+6 ;
+7 IF '$GET(EPDT)!('$GET(IBRX))
SET IBRTN=-1
GOTO RXAMTQ
+8 NEW IBRXCLM,IBCLM,IBRTN,IBAUTH,IBMRA
+9 SET IBRX=$$FILE^IBRXUTL(RXIEN,.01)
+10 SET IBRXCLM=0
+11 FOR
SET IBRXCLM=$ORDER(^IBA(362.4,"B",IBRX,IBRXCLM))
if 'IBRXCLM
QUIT
Begin DoDot:1
+12 IF $PIECE(^IBA(362.4,IBRXCLM,0),U,3)=EPDT
SET IBCLM=$PIECE(^(0),U,2)
End DoDot:1
+13 IF '$GET(IBCLM)
SET IBRTN=-1
GOTO RXAMTQ
+14 IF $GET(IBCLM)
SET IBAUTH=$PIECE($$CKBIL^IBTUBOU(IBCLM),U,2)
+15 IF $GET(IBAUTH)>2!($GET(IBAUTH)<5)
SET IBRTN=0
GOTO RXAMTQ
+16 IF '$TEST
SET IBRTN=-1
GOTO RXAMTQ
+17 ;
RXAMTQ QUIT IBRTN
+1 ;
+2 ;
PRSAMT(EPDT,PRST) ;
+1 ;
+2 ; input epdt := episode date from CLAIMS TRACKING(#356)
+3 ; prst := prosthetic item from CLAIMS TRACKING(#356)
+4 ;
+5 ; ouptut 0 if prosthetics item billed or -1 if item not billed
+6 ;
+7 IF '$GET(EPDT)!('$GET(PRST))
SET IBRTN=-1
GOTO PRSAMTQ
+8 NEW IBPRCLM,IBCLM,IBRTN,IBAUTH,IBMRA
+9 SET IBPRCLM=0
+10 FOR
SET IBPRCLM=$ORDER(^IBA(362.5,"AE",PRST,IBPRCLM))
if 'IBPRCLM
QUIT
Begin DoDot:1
+11 SET IBCLM=$PIECE(^IBA(362.5,IBPRCLM,0),U,2)
End DoDot:1
+12 IF '$GET(IBCLM)
SET IBRTN=-1
GOTO PRSAMTQ
+13 IF $GET(IBCLM)
SET IBAUTH=$PIECE(^DGCR(399,IBCLM,0),U,13)
+14 IF $GET(IBAUTH)'<2&($GET(IBAUTH)'>5)
SET IBRTN=0
GOTO PRSAMTQ
+15 IF '$TEST
SET IBRTN=-1
GOTO PRSAMTQ
+16 ;
+17 ;
PRSAMTQ QUIT IBRTN
+1 ;
+2 ;
RELBIL(IEN,EPDT,DFN,ENCTYP) ;
+1 ;
+2 ; ---- Input IEN := IEN of encounter
+3 ; epdt := Episode Date from CLAIMS TRACKING
+4 ; DFN := Patient file (#2) IEN
+5 ; ENCTYP := Type of encounter 1=inpatient 2=Outpatient
+6 ; 3=Prosthetics 4=Prescription
+7 ;
+8 ; Output Related Bills IF NO RELATED BILL IBRTN=""
+9 ; IF RELATED BILLS
+10 ; IBRTN= #OF RELATED BILLS;RELATED BILL
+11 ;
+12 IF '$GET(EPDT)!('$GET(DFN))!('$GET(ENCTYP))
SET IBRTN=-1
GOTO RELBILQ
+13 ;
+14 IF ENCTYP=1
SET IBRTN=$$INPTREL(DFN,EPDT)
GOTO RELBILQ
+15 ;
+16 IF ENCTYP=2
SET IBRTN=$$OPTREL(DFN,EPDT)
GOTO RELBILQ
+17 ;
+18 IF ENCTYP=3
SET IBRTN=$$RXREL(IEN,EPDT)
GOTO RELBILQ
+19 ;
+20 IF ENCTYP=4
SET IBRTN=$$PROSREL(IEN,EPDT)
GOTO RELBILQ
+21 ;
RELBILQ QUIT IBRTN
+1 ;
+2 ;
INPTREL(DFN,EPDT) ;
+1 ;
+2 ;
+3 IF '$GET(DFN)!('$GET(EPDT))
SET IBRTN=-1
QUIT IBRTN
+4 NEW IBCLM,IBDATA,IBN0,IBCLM,IBCNT,IBRTN
+5 SET (IBCLM,IBCNT,IBRTN)=0
+6 FOR
SET IBCLM=$ORDER(^DGCR(399,"C",DFN,IBCLM))
if 'IBCLM
QUIT
Begin DoDot:1
+7 if $PIECE($GET(^DGCR(399,IBCLM,0)),U,5)'=1
QUIT
+8 if $EXTRACT($PIECE($GET(^DGCR(399,IBCLM,0)),U,3),1,7)'=EPDT
QUIT
SET IBDATA=$$CKBIL^IBTUBOU(IBCLM,1)
if '+IBDATA
QUIT
+9 SET IBN0=^DGCR(399,IBCLM,0)
if IBRTN[$PIECE(^(0),U)
QUIT
+10 SET IBCNT=IBCNT+1
SET $PIECE(IBRTN,";",1)=IBCNT
+11 SET $PIECE(IBRTN,";",IBCNT+1)=$PIECE(IBN0,U)_$SELECT($PIECE(IBN0,U,27)=1:"i",$PIECE(IBN0,U,27)=2:"p",1:"")
End DoDot:1
+12 IF IBRTN=0
SET IBRTN=-1
+13 QUIT IBRTN
+14 ;
+15 ;
OPTREL(DFN,EPDT) ;
+1 ;
+2 ;
+3 IF '$GET(DFN)!('$GET(EPDT))
SET IBRTN=-1
QUIT IBRTN
+4 NEW IBXX,IBCNT,IBN0,IBDATA,IBXX,IBCNT,IBRTN
+5 SET (IBXX,IBCNT,IBRTN)=0
+6 FOR
SET IBXX=$ORDER(^DGCR(399,"AOPV",DFN,EPDT,IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+7 SET IBDATA=$$CKBIL^IBTUBOU(IBXX)
if '+IBDATA
QUIT
+8 SET IBN0=^DGCR(399,IBXX,0)
+9 if IBRTN[$PIECE(^(0),U)
QUIT
+10 SET IBCNT=IBCNT+1
SET $PIECE(IBRTN,";",1)=IBCNT
+11 SET $PIECE(IBRTN,";",IBCNT+1)=$PIECE(IBN0,U)_$SELECT($PIECE(IBN0,U,27)=1:"i",$PIECE(IBN0,U,27)=2:"p",1:"")
End DoDot:1
+12 IF IBRTN=0
SET IBRTN=-1
+13 QUIT IBRTN
+14 ;
+15 ;
PROSREL(IEN,EPDT) ;
+1 ;
+2 ;INPUT IEN=POINTER TO FILE 660
+3 ; EPDT=DATE PROS ITEM ISSUED
+4 ;
+5 ;OUTPUT IBRTN=-1 IF NOT BILL FOUND OR
+6 ; # OF RELATED;RELATED BILLS
+7 ;
+8 NEW IBXX,IBCLM,IBYY,IBCNT,IBRTN,IBDATA,IBN0
+9 IF '$GET(IEN)
SET IBRTN=-1
QUIT IBRTN
+10 SET (IBXX,IBYY,IBCNT,IBRTN)=0
+11 FOR
SET IBXX=$ORDER(^IBA(362.5,"AE",IEN,IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+12 SET IBCLM=$PIECE(^IBA(362.5,IBXX,0),U,2)
+13 IF '$DATA(^DGCR(399,IBCLM,0))
QUIT
+14 SET IBN0=^DGCR(399,IBCLM,0)
if IBRTN[$PIECE(^(0),U)
QUIT
+15 IF $PIECE(IBN0,U,13)<2!($PIECE(IBN0,U,13)>5)
QUIT
+16 SET IBCNT=IBCNT+1
SET $PIECE(IBRTN,";",1)=IBCNT
+17 SET $PIECE(IBRTN,";",IBCNT+1)=$PIECE(IBN0,U)_$SELECT($PIECE(IBN0,U,27)=1:"i",$PIECE(IBN0,U,27)=2:"p",1:"")
End DoDot:1
+18 IF IBRTN=0
SET IBRTN=-1
+19 QUIT IBRTN
+20 ;
+21 ;
RXREL(IEN,EPDT) ;
+1 ;
+2 ;
+3 NEW IBCLM,IBYY,IBRX,IBRTN,IBCNT
+4 IF '$GET(IEN)
SET IBRTN=-1
QUIT IBRTN
+5 SET IBRX=$$FILE^IBRXUTL(IEN,.01)
+6 SET (IBYY,IBCNT,IBRTN)=0
+7 FOR
SET IBYY=$ORDER(^IBA(362.4,"B",IBRX,IBYY))
if 'IBYY
QUIT
Begin DoDot:1
+8 if $PIECE(^IBA(362.4,IBYY,0),U,3)'=EPDT
QUIT
SET IBCLM=$PIECE(^(0),U,2)
+9 SET IBDATA=$$CKBIL^IBTUBOU(IBCLM)
if '+IBDATA
QUIT
+10 SET IBN0=^DGCR(399,IBCLM,0)
if IBRTN[$PIECE(^(0),U)
QUIT
+11 SET IBCNT=IBCNT+1
SET $PIECE(IBRTN,";",1)=IBCNT
+12 SET $PIECE(IBRTN,";",IBCNT+1)=$PIECE(IBN0,U)_$SELECT($PIECE(IBN0,U,27)=1:"i",$PIECE(IBN0,U,27)=2:"p",1:"")
End DoDot:1
+13 IF IBRTN=0
SET IBRTN=-1
+14 QUIT IBRTN
+15 ;
+16 ;
