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