- IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96
- ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270,370**;21-MAR-94;Build 5
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; For each type of Billable Event, search for items on the bill and calculate the charges
- ; 1) search the bill for items of the billable event type
- ; 2) determine how the charges should be calculated, based on Billable Item and Charge Method of the Set's Rate
- ; 3) calculate charges
- ; For per diem Billing Rates, no item pointers are passed since all items have a standard charge
- ; The Insurance Company Different Revenue Codes to Use (36,.07) is passed so standard rev codes can be replaced
- ; The Charge Type (363.1,.04) is passed so it can be added to the charge on the bill if it is defined for a Set
- ; Output: ^TMP($J,"IBCRCC")= ..., (created in IBCRBC2 based on charge items found here)
- ;
- INPTBS(IBIFN,RS,CS) ; Determine charges for INPATIENT BEDSECTION STAY billable events
- ; - the billable events are billable bedsections based on the patient movement treating specialties,
- ; these are pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG)
- ; - each day of billable care is calculated separately in case a rate becomes inactive
- ;
- N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBDIV,IBITM,IBDIV,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
- ;
- D INPTPTF^IBCRBG(IBIFN,CS)
- ;
- S IBTYPE=1,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
- S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
- I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
- S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
- ;
- S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
- ;
- I IBBLITEM=1,IBCHGMTH=1 D ; inpt/bedsection/per diem
- . S IBEVDT="" F S IBEVDT=$O(^TMP($J,"IBCRC-INDT",IBEVDT)) Q:'IBEVDT D
- .. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=+$P(IBX,U,2),IBDIV=$P(IBX,U,5)
- .. ;
- .. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division
- .. ;
- .. S IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^^"_IBCMPNT
- .. D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
- K ^TMP($J,"IBCRC-INDT")
- Q
- ;
- OPTVST(IBIFN,RS,CS) ; Determine charges for OUTPATIENT VISIT DATE billable events
- ; - the billable event is the outpatient visit date(s) on the bill (399,43)
- ;
- N IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBOPVARR,IBI,IBEVDT,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
- ;
- D OPTVD^IBCRBG1(IBIFN,.IBOPVARR) Q:'IBOPVARR
- ;
- S IBTYPE=2,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
- S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
- I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
- S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
- ;
- I IBBLITEM=1,IBCHGMTH=1 D ; opt vst/bedsection/per diem
- . S IBI="" F S IBI=$O(IBOPVARR(IBI)) Q:IBI="" D
- .. S IBEVDT=IBOPVARR(IBI)
- .. S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
- .. D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
- Q
- ;
- RX(IBIFN,RS,CS) ; Determine charges for PRESCRIPTION billable events
- ; - the billable event is an rx that has been added to the bill (362.4)
- ; - the insurance company Prescription Refill Rev Code (36,.15) is passed to the calculator to be used as
- ; the rev code for all Rx charges, all types, this overrides the rev codes for the set or item
- ; - on HCFA 1500, the site parameter Default Rx Refill CPT (350.9,1.3) is added as the CPT to all Rx RC entries
- ;
- N IBX,IBBLITEM,IBCHGMTH,IBRXCPT,IBIDRC,IBIRC,IBRXARR,IBRX,IBEVDT,IBUNIT,IBITM,IBNDC,IBTYPE,IBCMPNT,IBSAVE
- I '$G(IBIFN)!'$G(CS) Q
- ;
- D SET^IBCSC5A(IBIFN,.IBRXARR) Q:'$P(IBRXARR,U,2)
- ;
- S IBTYPE=3,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
- S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
- I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
- S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIRC=$P(IBIDRC,U,15),IBIDRC=$P(IBIDRC,U,7)
- ;
- S IBRXCPT="" I $$FT^IBCU3(IBIFN)=2 S IBRXCPT=$P($G(^IBE(350.9,1,1)),U,30)
- ;
- I IBBLITEM=1,IBCHGMTH=1 D ; rx refill/bedsection/per diem
- . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D
- .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D
- ... ;
- ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_+IBRXARR(IBRX,IBEVDT)_"^"_IBCMPNT
- ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,IBIRC,IBIDRC,IBSAVE)
- ;
- I IBBLITEM=3,IBCHGMTH=3 D ; ndc/quantity
- . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D
- .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D
- ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4),IBNDC=$P(IBX,U,5) Q:IBNDC=""
- ... S IBNDC=$O(^IBA(363.21,"B",IBNDC,0)) Q:'IBNDC
- ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
- ... D BITMCHG^IBCRBC2(RS,CS,IBNDC,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
- ;
- I IBCHGMTH=2 D ; va cost
- . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D
- .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D
- ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4) Q:'IBITM
- ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
- ... D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
- ;
- Q
- ;
- CPT(IBIFN,RS,CS) ; Determine charges for PROCEDURE billable events
- ; - the billable event is a CPT procedure from the bill (399,304)
- ; - the item to be billed is a CPT, this may include Modifier
- ; - for each CPT found on the bill that has a modifier, will first check to see if that CPT-modifier
- ; combination is billable (ie. is defined as a charge item for the Billing Rate, does not have to be active)
- ; if it does not then assumes the charge should be the CPT charge
- ; - if the charge set is limited by region then either the CPT's division or if no CPT division then the bill's
- ; Default Division must be contained in the sets region
- ; - the billable CPT is added as the CPT of the charge entry, Division is also added if defined for the CPT
- ; - the procedures provider may affect the charges due to a provider discount
- ; - if an inpatient bill then the bedsection on date of procedure will be used as the default bedsection
- ; - different sets of charges apply to SNF and Inpatient care although the bill is defined as inpatient
- ; - the Default Rx CPT should not be billed the CPT charge, instead the Rx is charged
- ;
- N IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT
- N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX,IBMODS I '$G(IBIFN)!'$G(CS) Q
- ;
- D CPT^IBCRBG1(IBIFN,.IBCPTARR) Q:'IBCPTARR
- ;
- S IBTYPE=4,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
- S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
- I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
- S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
- S IBBR=$P(IBX,U,3) S IBCPTRX="" I $O(^IBA(362.4,"C",IBIFN,0)) S IBCPTRX=+$P($G(^IBE(350.9,1,1)),U,30)
- ;
- S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
- D INPTPTF^IBCRBG(IBIFN,CS) ; get inpatient bedsections
- ;
- I IBBLITEM=2 D ; cpt/count/minutes/miles/hours
- . S IBCPT=0 F S IBCPT=$O(IBCPTARR(IBCPT)) Q:'IBCPT D
- .. S IBCPTFN=0 F S IBCPTFN=$O(IBCPTARR(IBCPT,IBCPTFN)) Q:'IBCPTFN D
- ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),(IBMOD,IBMODS)=$P(IBX,U,2)
- ... S IBDIV=$P(IBX,U,3),IBPPRV=$P(IBX,U,4),IBCLIN=$P(IBX,U,5),IBOE=$P(IBX,U,6)
- ... ;
- ... I '$$CHGOTH^IBCRBC2(IBIFN,RS,IBEVDT) Q
- ... I +IBCPTRX,'IBOE,IBCPT=IBCPTRX Q ; site parameter rx procedure
- ... ;
- ... S IBUNIT=$$CPTUNITS^IBCRBC2(CS,IBCHGMTH,IBX) Q:'IBUNIT
- ... ;
- ... S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBEVDT)),U,2) ; get inpatient bedsection
- ... I 'IBBS S IBX=$O(^TMP($J,"IBCRC-INDT",IBEVDT),-1) I +IBX S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBX)),U,2)
- ... ;
- ... I '$P($$CPT^ICPTCOD(+IBCPT,+IBEVDT),U,7) Q ; check is a valid active CPT
- ... I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division
- ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1) ; check CPT-MODs for billable combination
- ... ;
- ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE_U_IBMODS
- ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE)
- K ^TMP($J,"IBCRC-INDT")
- Q
- ;
- PI(IBIFN,RS,CS) ; Determine charges for PROSTHETICS billable events
- ; - the billable event is a prosthetic item that has been added to the bill (362.5)
- ;
- N IBX,IBBLITEM,IBCHGMTH,IBPIARR,IBIDRC,IBEVDT,IBPI,IBITM,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
- ;
- D SET^IBCSC5B(IBIFN,.IBPIARR) Q:'$P(IBPIARR,U,2)
- ;
- S IBTYPE=5,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
- S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
- I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
- S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
- ;
- I IBBLITEM=1,IBCHGMTH=1 D ; pros/bedsection/per diem
- . S IBEVDT="" F S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT D
- .. S IBPI=0 F S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI D
- ... S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
- ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
- ;
- I IBCHGMTH=2 D ; va cost
- . S IBEVDT="" F S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT D
- .. S IBPI=0 F S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI D
- ... S IBITM=IBPIARR(IBEVDT,IBPI) Q:'IBITM
- ... S IBSAVE="1^^^"_IBTYPE_"^"_+IBITM_"^"_IBCMPNT
- ... D BITMCHG^IBCRBC2(RS,CS,+IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRBC1 9678 printed Mar 13, 2025@21:23:43 Page 2
- IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96
- +1 ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270,370**;21-MAR-94;Build 5
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; For each type of Billable Event, search for items on the bill and calculate the charges
- +5 ; 1) search the bill for items of the billable event type
- +6 ; 2) determine how the charges should be calculated, based on Billable Item and Charge Method of the Set's Rate
- +7 ; 3) calculate charges
- +8 ; For per diem Billing Rates, no item pointers are passed since all items have a standard charge
- +9 ; The Insurance Company Different Revenue Codes to Use (36,.07) is passed so standard rev codes can be replaced
- +10 ; The Charge Type (363.1,.04) is passed so it can be added to the charge on the bill if it is defined for a Set
- +11 ; Output: ^TMP($J,"IBCRCC")= ..., (created in IBCRBC2 based on charge items found here)
- +12 ;
- INPTBS(IBIFN,RS,CS) ; Determine charges for INPATIENT BEDSECTION STAY billable events
- +1 ; - the billable events are billable bedsections based on the patient movement treating specialties,
- +2 ; these are pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG)
- +3 ; - each day of billable care is calculated separately in case a rate becomes inactive
- +4 ;
- +5 NEW IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBDIV,IBITM,IBDIV,IBTYPE,IBCMPNT,IBSAVE
- IF '$GET(IBIFN)!'$GET(CS)
- QUIT
- +6 ;
- +7 DO INPTPTF^IBCRBG(IBIFN,CS)
- +8 ;
- +9 SET IBTYPE=1
- SET IBCMPNT=$PIECE($GET(^IBE(363.1,+CS,0)),U,4)
- SET IBX=$$CSBR^IBCRU3(CS)
- SET IBBLITEM=$PIECE(IBX,U,4)
- SET IBCHGMTH=$PIECE(IBX,U,5)
- +10 SET IBIDRC=+$GET(^DGCR(399,+IBIFN,"MP"))
- +11 IF 'IBIDRC
- IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
- SET IBIDRC=$$CURR^IBCEF2(IBIFN)
- +12 SET IBIDRC=$GET(^DIC(36,+IBIDRC,0))
- SET IBIDRC=$PIECE(IBIDRC,U,7)
- +13 ;
- +14 ; bill's default division
- SET IBBDIV=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,22)
- +15 ;
- +16 ; inpt/bedsection/per diem
- IF IBBLITEM=1
- IF IBCHGMTH=1
- Begin DoDot:1
- +17 SET IBEVDT=""
- FOR
- SET IBEVDT=$ORDER(^TMP($JOB,"IBCRC-INDT",IBEVDT))
- if 'IBEVDT
- QUIT
- Begin DoDot:2
- +18 SET IBX=$GET(^TMP($JOB,"IBCRC-INDT",IBEVDT))
- SET IBITM=+$PIECE(IBX,U,2)
- SET IBDIV=$PIECE(IBX,U,5)
- +19 ;
- +20 ; check division
- IF $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0
- QUIT
- +21 ;
- +22 SET IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^^"_IBCMPNT
- +23 DO BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
- End DoDot:2
- End DoDot:1
- +24 KILL ^TMP($JOB,"IBCRC-INDT")
- +25 QUIT
- +26 ;
- OPTVST(IBIFN,RS,CS) ; Determine charges for OUTPATIENT VISIT DATE billable events
- +1 ; - the billable event is the outpatient visit date(s) on the bill (399,43)
- +2 ;
- +3 NEW IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBOPVARR,IBI,IBEVDT,IBTYPE,IBCMPNT,IBSAVE
- IF '$GET(IBIFN)!'$GET(CS)
- QUIT
- +4 ;
- +5 DO OPTVD^IBCRBG1(IBIFN,.IBOPVARR)
- if 'IBOPVARR
- QUIT
- +6 ;
- +7 SET IBTYPE=2
- SET IBCMPNT=$PIECE($GET(^IBE(363.1,+CS,0)),U,4)
- SET IBX=$$CSBR^IBCRU3(CS)
- SET IBBLITEM=$PIECE(IBX,U,4)
- SET IBCHGMTH=$PIECE(IBX,U,5)
- +8 SET IBIDRC=+$GET(^DGCR(399,+IBIFN,"MP"))
- +9 IF 'IBIDRC
- IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
- SET IBIDRC=$$CURR^IBCEF2(IBIFN)
- +10 SET IBIDRC=$GET(^DIC(36,+IBIDRC,0))
- SET IBIDRC=$PIECE(IBIDRC,U,7)
- +11 ;
- +12 ; opt vst/bedsection/per diem
- IF IBBLITEM=1
- IF IBCHGMTH=1
- Begin DoDot:1
- +13 SET IBI=""
- FOR
- SET IBI=$ORDER(IBOPVARR(IBI))
- if IBI=""
- QUIT
- Begin DoDot:2
- +14 SET IBEVDT=IBOPVARR(IBI)
- +15 SET IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
- +16 DO ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
- End DoDot:2
- End DoDot:1
- +17 QUIT
- +18 ;
- RX(IBIFN,RS,CS) ; Determine charges for PRESCRIPTION billable events
- +1 ; - the billable event is an rx that has been added to the bill (362.4)
- +2 ; - the insurance company Prescription Refill Rev Code (36,.15) is passed to the calculator to be used as
- +3 ; the rev code for all Rx charges, all types, this overrides the rev codes for the set or item
- +4 ; - on HCFA 1500, the site parameter Default Rx Refill CPT (350.9,1.3) is added as the CPT to all Rx RC entries
- +5 ;
- +6 NEW IBX,IBBLITEM,IBCHGMTH,IBRXCPT,IBIDRC,IBIRC,IBRXARR,IBRX,IBEVDT,IBUNIT,IBITM,IBNDC,IBTYPE,IBCMPNT,IBSAVE
- +7 IF '$GET(IBIFN)!'$GET(CS)
- QUIT
- +8 ;
- +9 DO SET^IBCSC5A(IBIFN,.IBRXARR)
- if '$PIECE(IBRXARR,U,2)
- QUIT
- +10 ;
- +11 SET IBTYPE=3
- SET IBCMPNT=$PIECE($GET(^IBE(363.1,+CS,0)),U,4)
- SET IBX=$$CSBR^IBCRU3(CS)
- SET IBBLITEM=$PIECE(IBX,U,4)
- SET IBCHGMTH=$PIECE(IBX,U,5)
- +12 SET IBIDRC=+$GET(^DGCR(399,+IBIFN,"MP"))
- +13 IF 'IBIDRC
- IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
- SET IBIDRC=$$CURR^IBCEF2(IBIFN)
- +14 SET IBIDRC=$GET(^DIC(36,+IBIDRC,0))
- SET IBIRC=$PIECE(IBIDRC,U,15)
- SET IBIDRC=$PIECE(IBIDRC,U,7)
- +15 ;
- +16 SET IBRXCPT=""
- IF $$FT^IBCU3(IBIFN)=2
- SET IBRXCPT=$PIECE($GET(^IBE(350.9,1,1)),U,30)
- +17 ;
- +18 ; rx refill/bedsection/per diem
- IF IBBLITEM=1
- IF IBCHGMTH=1
- Begin DoDot:1
- +19 SET IBRX=""
- FOR
- SET IBRX=$ORDER(IBRXARR(IBRX))
- if IBRX=""
- QUIT
- Begin DoDot:2
- +20 SET IBEVDT=0
- FOR
- SET IBEVDT=$ORDER(IBRXARR(IBRX,IBEVDT))
- if 'IBEVDT
- QUIT
- Begin DoDot:3
- +21 ;
- +22 SET IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_+IBRXARR(IBRX,IBEVDT)_"^"_IBCMPNT
- +23 DO ALLBEDS^IBCRBC2(RS,CS,IBEVDT,IBIRC,IBIDRC,IBSAVE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 ;
- +25 ; ndc/quantity
- IF IBBLITEM=3
- IF IBCHGMTH=3
- Begin DoDot:1
- +26 SET IBRX=""
- FOR
- SET IBRX=$ORDER(IBRXARR(IBRX))
- if IBRX=""
- QUIT
- Begin DoDot:2
- +27 SET IBEVDT=0
- FOR
- SET IBEVDT=$ORDER(IBRXARR(IBRX,IBEVDT))
- if 'IBEVDT
- QUIT
- Begin DoDot:3
- +28 SET IBX=IBRXARR(IBRX,IBEVDT)
- SET IBITM=+IBX
- SET IBUNIT=$PIECE(IBX,U,4)
- SET IBNDC=$PIECE(IBX,U,5)
- if IBNDC=""
- QUIT
- +29 SET IBNDC=$ORDER(^IBA(363.21,"B",IBNDC,0))
- if 'IBNDC
- QUIT
- +30 SET IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
- +31 DO BITMCHG^IBCRBC2(RS,CS,IBNDC,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +32 ;
- +33 ; va cost
- IF IBCHGMTH=2
- Begin DoDot:1
- +34 SET IBRX=""
- FOR
- SET IBRX=$ORDER(IBRXARR(IBRX))
- if IBRX=""
- QUIT
- Begin DoDot:2
- +35 SET IBEVDT=0
- FOR
- SET IBEVDT=$ORDER(IBRXARR(IBRX,IBEVDT))
- if 'IBEVDT
- QUIT
- Begin DoDot:3
- +36 SET IBX=IBRXARR(IBRX,IBEVDT)
- SET IBITM=+IBX
- SET IBUNIT=$PIECE(IBX,U,4)
- if 'IBITM
- QUIT
- +37 SET IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
- +38 DO BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +39 ;
- +40 QUIT
- +41 ;
- CPT(IBIFN,RS,CS) ; Determine charges for PROCEDURE billable events
- +1 ; - the billable event is a CPT procedure from the bill (399,304)
- +2 ; - the item to be billed is a CPT, this may include Modifier
- +3 ; - for each CPT found on the bill that has a modifier, will first check to see if that CPT-modifier
- +4 ; combination is billable (ie. is defined as a charge item for the Billing Rate, does not have to be active)
- +5 ; if it does not then assumes the charge should be the CPT charge
- +6 ; - if the charge set is limited by region then either the CPT's division or if no CPT division then the bill's
- +7 ; Default Division must be contained in the sets region
- +8 ; - the billable CPT is added as the CPT of the charge entry, Division is also added if defined for the CPT
- +9 ; - the procedures provider may affect the charges due to a provider discount
- +10 ; - if an inpatient bill then the bedsection on date of procedure will be used as the default bedsection
- +11 ; - different sets of charges apply to SNF and Inpatient care although the bill is defined as inpatient
- +12 ; - the Default Rx CPT should not be billed the CPT charge, instead the Rx is charged
- +13 ;
- +14 NEW IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT
- +15 NEW IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX,IBMODS
- IF '$GET(IBIFN)!'$GET(CS)
- QUIT
- +16 ;
- +17 DO CPT^IBCRBG1(IBIFN,.IBCPTARR)
- if 'IBCPTARR
- QUIT
- +18 ;
- +19 SET IBTYPE=4
- SET IBCMPNT=$PIECE($GET(^IBE(363.1,+CS,0)),U,4)
- SET IBX=$$CSBR^IBCRU3(CS)
- SET IBBLITEM=$PIECE(IBX,U,4)
- SET IBCHGMTH=$PIECE(IBX,U,5)
- +20 SET IBIDRC=+$GET(^DGCR(399,+IBIFN,"MP"))
- +21 IF 'IBIDRC
- IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
- SET IBIDRC=$$CURR^IBCEF2(IBIFN)
- +22 SET IBIDRC=$GET(^DIC(36,+IBIDRC,0))
- SET IBIDRC=$PIECE(IBIDRC,U,7)
- +23 SET IBBR=$PIECE(IBX,U,3)
- SET IBCPTRX=""
- IF $ORDER(^IBA(362.4,"C",IBIFN,0))
- SET IBCPTRX=+$PIECE($GET(^IBE(350.9,1,1)),U,30)
- +24 ;
- +25 ; bill's default division
- SET IBBDIV=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,22)
- +26 ; get inpatient bedsections
- DO INPTPTF^IBCRBG(IBIFN,CS)
- +27 ;
- +28 ; cpt/count/minutes/miles/hours
- IF IBBLITEM=2
- Begin DoDot:1
- +29 SET IBCPT=0
- FOR
- SET IBCPT=$ORDER(IBCPTARR(IBCPT))
- if 'IBCPT
- QUIT
- Begin DoDot:2
- +30 SET IBCPTFN=0
- FOR
- SET IBCPTFN=$ORDER(IBCPTARR(IBCPT,IBCPTFN))
- if 'IBCPTFN
- QUIT
- Begin DoDot:3
- +31 SET IBX=IBCPTARR(IBCPT,IBCPTFN)
- SET IBEVDT=$PIECE(IBX,U,1)
- SET (IBMOD,IBMODS)=$PIECE(IBX,U,2)
- +32 SET IBDIV=$PIECE(IBX,U,3)
- SET IBPPRV=$PIECE(IBX,U,4)
- SET IBCLIN=$PIECE(IBX,U,5)
- SET IBOE=$PIECE(IBX,U,6)
- +33 ;
- +34 IF '$$CHGOTH^IBCRBC2(IBIFN,RS,IBEVDT)
- QUIT
- +35 ; site parameter rx procedure
- IF +IBCPTRX
- IF 'IBOE
- IF IBCPT=IBCPTRX
- QUIT
- +36 ;
- +37 SET IBUNIT=$$CPTUNITS^IBCRBC2(CS,IBCHGMTH,IBX)
- if 'IBUNIT
- QUIT
- +38 ;
- +39 ; get inpatient bedsection
- SET IBBS=$PIECE($GET(^TMP($JOB,"IBCRC-INDT",IBEVDT)),U,2)
- +40 IF 'IBBS
- SET IBX=$ORDER(^TMP($JOB,"IBCRC-INDT",IBEVDT),-1)
- IF +IBX
- SET IBBS=$PIECE($GET(^TMP($JOB,"IBCRC-INDT",IBX)),U,2)
- +41 ;
- +42 ; check is a valid active CPT
- IF '$PIECE($$CPT^ICPTCOD(+IBCPT,+IBEVDT),U,7)
- QUIT
- +43 ; check division
- IF $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0
- QUIT
- +44 ; check CPT-MODs for billable combination
- IF +IBMOD
- SET IBMOD=$PIECE($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1)
- +45 ;
- +46 SET IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE_U_IBMODS
- +47 DO BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +48 KILL ^TMP($JOB,"IBCRC-INDT")
- +49 QUIT
- +50 ;
- PI(IBIFN,RS,CS) ; Determine charges for PROSTHETICS billable events
- +1 ; - the billable event is a prosthetic item that has been added to the bill (362.5)
- +2 ;
- +3 NEW IBX,IBBLITEM,IBCHGMTH,IBPIARR,IBIDRC,IBEVDT,IBPI,IBITM,IBTYPE,IBCMPNT,IBSAVE
- IF '$GET(IBIFN)!'$GET(CS)
- QUIT
- +4 ;
- +5 DO SET^IBCSC5B(IBIFN,.IBPIARR)
- if '$PIECE(IBPIARR,U,2)
- QUIT
- +6 ;
- +7 SET IBTYPE=5
- SET IBCMPNT=$PIECE($GET(^IBE(363.1,+CS,0)),U,4)
- SET IBX=$$CSBR^IBCRU3(CS)
- SET IBBLITEM=$PIECE(IBX,U,4)
- SET IBCHGMTH=$PIECE(IBX,U,5)
- +8 SET IBIDRC=+$GET(^DGCR(399,+IBIFN,"MP"))
- +9 IF 'IBIDRC
- IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
- SET IBIDRC=$$CURR^IBCEF2(IBIFN)
- +10 SET IBIDRC=$GET(^DIC(36,+IBIDRC,0))
- SET IBIDRC=$PIECE(IBIDRC,U,7)
- +11 ;
- +12 ; pros/bedsection/per diem
- IF IBBLITEM=1
- IF IBCHGMTH=1
- Begin DoDot:1
- +13 SET IBEVDT=""
- FOR
- SET IBEVDT=$ORDER(IBPIARR(IBEVDT))
- if 'IBEVDT
- QUIT
- Begin DoDot:2
- +14 SET IBPI=0
- FOR
- SET IBPI=$ORDER(IBPIARR(IBEVDT,IBPI))
- if 'IBPI
- QUIT
- Begin DoDot:3
- +15 SET IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
- +16 DO ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +17 ;
- +18 ; va cost
- IF IBCHGMTH=2
- Begin DoDot:1
- +19 SET IBEVDT=""
- FOR
- SET IBEVDT=$ORDER(IBPIARR(IBEVDT))
- if 'IBEVDT
- QUIT
- Begin DoDot:2
- +20 SET IBPI=0
- FOR
- SET IBPI=$ORDER(IBPIARR(IBEVDT,IBPI))
- if 'IBPI
- QUIT
- Begin DoDot:3
- +21 SET IBITM=IBPIARR(IBEVDT,IBPI)
- if 'IBITM
- QUIT
- +22 SET IBSAVE="1^^^"_IBTYPE_"^"_+IBITM_"^"_IBCMPNT
- +23 DO BITMCHG^IBCRBC2(RS,CS,+IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 ;
- +25 QUIT
