Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCRHBS8

IBCRHBS8.m

Go to the documentation of this file. 
  1. IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
  1.  ;;2.0;INTEGRATED BILLING;**245,382**;21-MAR-94;Build 2
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ;
  1. ISA(SITE,ITLINE) ; Return Inpatient DRG Standard Ancillary Charge
  1.  N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  I $P(ITLINE,U,2)'="DRG" G ISAQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ
  1.  S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. ISAQ Q IBCHG
  1.  ;
  1. ISR(SITE,ITLINE) ; Return Inpatient DRG Standard Room & Board Charge
  1.  N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  I $P(ITLINE,U,2)'="DRG" G ISRQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ
  1.  S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. ISRQ Q IBCHG
  1.  ;
  1. IIA(SITE,ITLINE) ; Return Inpatient DRG ICU Ancillary Charge
  1.  N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  I $P(ITLINE,U,2)'="DRG" G IIAQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ
  1.  S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. IIAQ Q IBCHG
  1.  ;
  1. IIR(SITE,ITLINE) ; Return Inpatient DRG ICU Room & Board Charge
  1.  N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  I $P(ITLINE,U,2)'="DRG" G IIRQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ
  1.  S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. IIRQ Q IBCHG
  1.  ;
  1. ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem
  1.  N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  I $P(ITLINE,U,2)'="SNF" G ISNFQ
  1.  I $P(ITLINE,U,1)'="999",$P(ITLINE,U,1)'="000" G ISNFQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. ISNFQ Q IBCHG
  1.  ;
  1.  ;
  1. FAC(SITE,ITLINE) ; Return Facility Charge (Table B) for All Charge and Unit Types
  1.  ; each line record contains 1 charge that may be calculated in multiple ways
  1.  N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
  1.  ;
  1.  S IBUT=$P(ITLINE,U,10)
  1.  ;
  1.  I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
  1.  I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
  1.  I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ
  1.  ;
  1. FACQ Q IBCHG
  1.  ;
  1. FSTD(SITE,ITLINE) ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles)
  1.  N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ
  1.  S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. FSTDQ Q IBCHG
  1.  ;
  1. FHRS(SITE,ITLINE) ; Return Facility Charge of Unit Type = 2 (Hours)
  1.  N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ
  1.  S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
  1.  S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2)
  1.  ;
  1. FHRSQ Q IBCHG_U_IBCHGB
  1.  ;
  1.  ;
  1. PROF(SITE,ITLINE) ; Return Professional Charge (Table C) for All Charge and Unit Types
  1.  ; each line record contains 1 charge that may be calculated in multiple ways
  1.  N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
  1.  ;
  1.  S IBCT=$P(ITLINE,U,8)
  1.  S IBUT=$P(ITLINE,U,16)
  1.  ;
  1.  I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ
  1.  I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ
  1.  I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ
  1.  I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ
  1.  ;
  1. PROFQ Q IBCHG
  1.  ;
  1. PRBRVS(SITE,ITLINE) ; Return Professional RBRVS Based Charge
  1.  N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ
  1.  S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ
  1.  S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ
  1.  ;
  1.  S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site
  1.  ;
  1.  S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7)
  1.  S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8)
  1.  S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
  1.  ;
  1.  S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. PRBRVSQ Q IBCHG
  1.  ;
  1.  ;
  1. PTRVU(SITE,ITLINE) ; Return Professional Total RVU Charge
  1.  N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ
  1.  S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ
  1.  S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ
  1.  ;
  1.  S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9)
  1.  S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
  1.  ;
  1.  S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. PTRVUQ Q IBCHG
  1.  ;
  1. PNW(SITE,ITLINE) ; Return Professional Nationwide Charge
  1.  N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ
  1.  S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ
  1.  S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
  1.  ;
  1. PNWQ Q IBCHG
  1.  ;
  1. PANES(SITE,ITLINE) ; Return Professional Anesthesia Charge
  1.  N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
  1.  S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ
  1.  S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ
  1.  ;
  1.  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ
  1.  S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ
  1.  ;
  1.  S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
  1.  ;
  1.  S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2)
  1.  S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2)
  1.  ;
  1. PANESQ Q IBCHG_U_IBCHGB
  1.  ;
  1.  ;
  1.  ;
  1.  ;
  1. GETAA(ZIP) ; return Area Factor entry for Zip from Table E
  1.  N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV=""
  1.  ;
  1.  I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0))
  1.  I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN
  1.  ;
  1.  Q IBAALN
  1.  ;
  1. GETSCC(SCC) ; return Service Category Code entry from Table D
  1.  N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC=""
  1.  ;
  1.  I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0))
  1.  I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN
  1.  ;
  1.  Q IBSCCLN