Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m

    r613 r623  
    1 IBCRHBS8        ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
    2         ;;2.0;INTEGRATED BILLING;**245,382**;21-MAR-94;Build 2
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;
    6 ISA(SITE,ITLINE)        ; Return Inpatient DRG Standard Ancillary Charge
    7         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    8         I $P(ITLINE,U,2)'="DRG" G ISAQ
    9         ;
    10         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ
    11         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ
    12         ;
    13         S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    14         ;
    15 ISAQ    Q IBCHG
    16         ;
    17 ISR(SITE,ITLINE)        ; Return Inpatient DRG Standard Room & Board Charge
    18         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    19         I $P(ITLINE,U,2)'="DRG" G ISRQ
    20         ;
    21         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ
    22         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ
    23         ;
    24         S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    25         ;
    26 ISRQ    Q IBCHG
    27         ;
    28 IIA(SITE,ITLINE)        ; Return Inpatient DRG ICU Ancillary Charge
    29         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    30         I $P(ITLINE,U,2)'="DRG" G IIAQ
    31         ;
    32         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ
    33         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ
    34         ;
    35         S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    36         ;
    37 IIAQ    Q IBCHG
    38         ;
    39 IIR(SITE,ITLINE)        ; Return Inpatient DRG ICU Room & Board Charge
    40         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    41         I $P(ITLINE,U,2)'="DRG" G IIRQ
    42         ;
    43         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ
    44         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ
    45         ;
    46         S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    47         ;
    48 IIRQ    Q IBCHG
    49         ;
    50 ISNF(SITE,ITLINE)       ; Return Inpatient Skilled Nursing Facility Per Diem
    51         N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    52         I $P(ITLINE,U,2)'="SNF" G ISNFQ
    53         I $P(ITLINE,U,1)'="999",$P(ITLINE,U,1)'="000" G ISNFQ
    54         ;
    55         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
    56         ;
    57         S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2)
    58         ;
    59 ISNFQ   Q IBCHG
    60         ;
    61         ;
    62 FAC(SITE,ITLINE)        ; Return Facility Charge (Table B) for All Charge and Unit Types
    63         ; each line record contains 1 charge that may be calculated in multiple ways
    64         N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
    65         ;
    66         S IBUT=$P(ITLINE,U,10)
    67         ;
    68         I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
    69         I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
    70         I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ
    71         ;
    72 FACQ    Q IBCHG
    73         ;
    74 FSTD(SITE,ITLINE)       ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles)
    75         N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    76         S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ
    77         ;
    78         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ
    79         S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ
    80         ;
    81         S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
    82         ;
    83 FSTDQ   Q IBCHG
    84         ;
    85 FHRS(SITE,ITLINE)       ; Return Facility Charge of Unit Type = 2 (Hours)
    86         N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    87         S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ
    88         ;
    89         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ
    90         S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ
    91         ;
    92         S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
    93         S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2)
    94         ;
    95 FHRSQ   Q IBCHG_U_IBCHGB
    96         ;
    97         ;
    98 PROF(SITE,ITLINE)       ; Return Professional Charge (Table C) for All Charge and Unit Types
    99         ; each line record contains 1 charge that may be calculated in multiple ways
    100         N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
    101         ;
    102         S IBCT=$P(ITLINE,U,8)
    103         S IBUT=$P(ITLINE,U,16)
    104         ;
    105         I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ
    106         I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ
    107         I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ
    108         I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ
    109         ;
    110 PROFQ   Q IBCHG
    111         ;
    112 PRBRVS(SITE,ITLINE)     ; Return Professional RBRVS Based Charge
    113         N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    114         S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ
    115         S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ
    116         ;
    117         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ
    118         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ
    119         ;
    120         S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site
    121         ;
    122         S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7)
    123         S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8)
    124         S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
    125         ;
    126         S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2)
    127         ;
    128 PRBRVSQ Q IBCHG
    129         ;
    130         ;
    131 PTRVU(SITE,ITLINE)      ; Return Professional Total RVU Charge
    132         N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    133         S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ
    134         S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ
    135         ;
    136         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ
    137         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ
    138         ;
    139         S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9)
    140         S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
    141         ;
    142         S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2)
    143         ;
    144 PTRVUQ  Q IBCHG
    145         ;
    146 PNW(SITE,ITLINE)        ; Return Professional Nationwide Charge
    147         N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    148         S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ
    149         S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ
    150         ;
    151         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ
    152         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ
    153         ;
    154         S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
    155         ;
    156 PNWQ    Q IBCHG
    157         ;
    158 PANES(SITE,ITLINE)      ; Return Professional Anesthesia Charge
    159         N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    160         S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ
    161         S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ
    162         ;
    163         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ
    164         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ
    165         ;
    166         S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
    167         ;
    168         S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2)
    169         S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2)
    170         ;
    171 PANESQ  Q IBCHG_U_IBCHGB
    172         ;
    173         ;
    174         ;
    175         ;
    176 GETAA(ZIP)      ; return Area Factor entry for Zip from Table E
    177         N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV=""
    178         ;
    179         I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0))
    180         I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN
    181         ;
    182         Q IBAALN
    183         ;
    184 GETSCC(SCC)     ; return Service Category Code entry from Table D
    185         N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC=""
    186         ;
    187         I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0))
    188         I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN
    189         ;
    190         Q IBSCCLN
     1IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
     2 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;
     6ISA(SITE,ITLINE) ; Return Inpatient DRG Standard Ancillary Charge
     7 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     8 I $P(ITLINE,U,2)'="DRG" G ISAQ
     9 ;
     10 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ
     11 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ
     12 ;
     13 S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     14 ;
     15ISAQ Q IBCHG
     16 ;
     17ISR(SITE,ITLINE) ; Return Inpatient DRG Standard Room & Board Charge
     18 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     19 I $P(ITLINE,U,2)'="DRG" G ISRQ
     20 ;
     21 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ
     22 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ
     23 ;
     24 S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     25 ;
     26ISRQ Q IBCHG
     27 ;
     28IIA(SITE,ITLINE) ; Return Inpatient DRG ICU Ancillary Charge
     29 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     30 I $P(ITLINE,U,2)'="DRG" G IIAQ
     31 ;
     32 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ
     33 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ
     34 ;
     35 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     36 ;
     37IIAQ Q IBCHG
     38 ;
     39IIR(SITE,ITLINE) ; Return Inpatient DRG ICU Room & Board Charge
     40 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     41 I $P(ITLINE,U,2)'="DRG" G IIRQ
     42 ;
     43 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ
     44 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ
     45 ;
     46 S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     47 ;
     48IIRQ Q IBCHG
     49 ;
     50ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem
     51 N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) I $P(ITLINE,U,2)'="SNF" G ISNFQ
     52 I $P(ITLINE,U,1)'="999" G ISNFQ
     53 ;
     54 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
     55 ;
     56 S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2)
     57 ;
     58ISNFQ Q IBCHG
     59 ;
     60 ;
     61FAC(SITE,ITLINE) ; Return Facility Charge (Table B) for All Charge and Unit Types
     62 ; each line record contains 1 charge that may be calculated in multiple ways
     63 N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
     64 ;
     65 S IBUT=$P(ITLINE,U,10)
     66 ;
     67 I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
     68 I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
     69 I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ
     70 ;
     71FACQ Q IBCHG
     72 ;
     73FSTD(SITE,ITLINE) ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles)
     74 N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     75 S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ
     76 ;
     77 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ
     78 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ
     79 ;
     80 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
     81 ;
     82FSTDQ Q IBCHG
     83 ;
     84FHRS(SITE,ITLINE) ; Return Facility Charge of Unit Type = 2 (Hours)
     85 N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     86 S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ
     87 ;
     88 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ
     89 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ
     90 ;
     91 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
     92 S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2)
     93 ;
     94FHRSQ Q IBCHG_U_IBCHGB
     95 ;
     96 ;
     97PROF(SITE,ITLINE) ; Return Professional Charge (Table C) for All Charge and Unit Types
     98 ; each line record contains 1 charge that may be calculated in multiple ways
     99 N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
     100 ;
     101 S IBCT=$P(ITLINE,U,8)
     102 S IBUT=$P(ITLINE,U,16)
     103 ;
     104 I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ
     105 I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ
     106 I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ
     107 I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ
     108 ;
     109PROFQ Q IBCHG
     110 ;
     111PRBRVS(SITE,ITLINE) ; Return Professional RBRVS Based Charge
     112 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     113 S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ
     114 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ
     115 ;
     116 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ
     117 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ
     118 ;
     119 S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site
     120 ;
     121 S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7)
     122 S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8)
     123 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
     124 ;
     125 S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2)
     126 ;
     127PRBRVSQ Q IBCHG
     128 ;
     129 ;
     130PTRVU(SITE,ITLINE) ; Return Professional Total RVU Charge
     131 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     132 S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ
     133 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ
     134 ;
     135 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ
     136 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ
     137 ;
     138 S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9)
     139 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
     140 ;
     141 S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2)
     142 ;
     143PTRVUQ Q IBCHG
     144 ;
     145PNW(SITE,ITLINE) ; Return Professional Nationwide Charge
     146 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     147 S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ
     148 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ
     149 ;
     150 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ
     151 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ
     152 ;
     153 S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
     154 ;
     155PNWQ Q IBCHG
     156 ;
     157PANES(SITE,ITLINE) ; Return Professional Anesthesia Charge
     158 N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     159 S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ
     160 S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ
     161 ;
     162 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ
     163 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ
     164 ;
     165 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
     166 ;
     167 S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2)
     168 S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2)
     169 ;
     170PANESQ Q IBCHG_U_IBCHGB
     171 ;
     172 ;
     173 ;
     174 ;
     175GETAA(ZIP) ; return Area Factor entry for Zip from Table E
     176 N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV=""
     177 ;
     178 I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0))
     179 I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN
     180 ;
     181 Q IBAALN
     182 ;
     183GETSCC(SCC) ; return Service Category Code entry from Table D
     184 N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC=""
     185 ;
     186 I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0))
     187 I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN
     188 ;
     189 Q IBSCCLN
Note: See TracChangeset for help on using the changeset viewer.