- 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 Mar 13, 2025@21:34:17 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 ;
