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/IBCRBH1.m

    r613 r623  
    1 IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
    2         ;;2.0;INTEGRATED BILLING;**106,245,370**;21-MAR-94;Build 5
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 DISPCHG(IBIFN)  ; display a bills items and their charges, display only, does not change the charges on the bill
    6         ;
    7         D BILL(IBIFN,1),SORTCI(IBIFN),DSPCHRG(1) ;     display auto add charges
    8         K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
    9         D BILL(IBIFN,""),SORTCI(IBIFN),DSPCHRG("") ;   display non-auto add charges
    10         K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
    11         D NOTES(IBIFN,1)
    12         Q
    13         ;
    14 BILL(IBIFN,IBAA,IBRSARR)        ; given a bill number calculate charges using schedules that match the auto add flag
    15         ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
    16         ; Output:  ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill
    17         ;
    18         N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN)
    19         K ^TMP($J,"IBCRCC")
    20         ;
    21         S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0=""  S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
    22         S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3),IBCTYPE=+$P(IB0,U,27)
    23         ;
    24         ; get standard set of all rate schedules and charge sets available for the bill
    25         I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END
    26         ;
    27         ; process charge sets - set all charges for the bill into array
    28         S IBRS=0 F  S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS  D
    29         . S IBCS=0 F  S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS  I IBRSARR(IBRS,IBCS)=IBAA D
    30         .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
    31         .. ;
    32         .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
    33         .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
    34         .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
    35         .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS)
    36         .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
    37         .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
    38         ;
    39 END     Q
    40         ;
    41         ;
    42 SORTCI(IBIFN)   ; process charge array - create new array in sorted order with items combined, if possible
    43         ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined
    44         ; Input:  TMP($J,"IBCRCC",X) = ...  (from IBCRBC2)
    45         ; Output: TMP($J,"IBCRCSX",X) =
    46         ;         RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME
    47         ;         TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages
    48         ;         TMP($J,"IBCRCSXR",BS,RV CD,X) = ""
    49         ;         TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = ""
    50         ;
    51         N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY
    52         K ^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
    53         ;
    54         S IBI=0 F  S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI  D
    55         . ;
    56         . S IBLN=^TMP($J,"IBCRCC",IBI)
    57         . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=+$FN($P(IBLN,U,12),"",2),IBUNITS=$P(IBLN,U,13)
    58         . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18)
    59         . S IBCS=$P(IBLN,U,2),IBDT=$P(IBLN,U,8),IBNM=$$ITMNM($G(IBIFN),IBBS,IBIT,IBIP,IBCPT)
    60         . ;
    61         . ; combine like charges, unless there are comments
    62         . S (IBTUNITS,IBK,IBJ)=0 F  S IBJ=$O(^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBJ)) Q:'IBJ  S IBK=IBJ D  Q:+IBTUNITS
    63         .. I $D(^TMP($J,"IBCRCC",IBI,"CC")) Q
    64         .. S IBX=$G(^TMP($J,"IBCRCSX",IBJ))
    65         .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D
    66         ... S IBTUNITS=$P(IBX,U,4),IBDT=$P(IBX,U,11)
    67         . ;
    68         . I 'IBTUNITS S IBK=IBI ; no combination, new line item charge
    69         . S IBTUNITS=IBTUNITS+IBUNITS
    70         . ;
    71         . S ^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBK)=""
    72         . S ^TMP($J,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)=""
    73         . S ^TMP($J,"IBCRCSX",IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT_U_IBCS_U_IBDT_U_IBNM
    74         . S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCC",IBI,"CC",IBY)) Q:'IBY  S ^TMP($J,"IBCRCSX",IBK,"CC",IBY)=^TMP($J,"IBCRCC",IBI,"CC",IBY)
    75         Q
    76         ;
    77 DSPCHRG(AA)     ; display charges
    78         ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI)
    79         ;
    80         N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY S (IBTOTAL,IBQUIT)=0
    81         ;
    82         D DSPHDR(AA) S IBCNT=4
    83         ;
    84         S IBI="" F  S IBI=$O(^TMP($J,"IBCRCSXN",IBI)) Q:IBI=""  D  Q:IBQUIT
    85         . S IBJ="" F  S IBJ=$O(^TMP($J,"IBCRCSXN",IBI,IBJ)) Q:IBJ=""  D  Q:IBQUIT
    86         .. S IBK=0 F  S IBK=$O(^TMP($J,"IBCRCSXN",IBI,IBJ,IBK)) Q:'IBK  D  Q:IBQUIT
    87         ... S IBLN=$G(^TMP($J,"IBCRCSX",IBK)) Q:IBLN=""
    88         ... ;
    89         ... ; add charges to RC multiple
    90         ... S IBRVCD=$P(IBLN,U,1),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBDV=$P(IBLN,U,6)
    91         ... S IBCMPT=$P(IBLN,U,9),IBCS=$P(IBLN,U,10),IBDT=$P(IBLN,U,11),IBNM=$P(IBLN,U,12)
    92         ... S IBTOTAL=IBTOTAL+(IBCHG*IBUNITS),IBCNT=IBCNT+1
    93         ... ;
    94         ... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM D DSPLN(IBX)
    95         ... ;
    96         ... S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) Q:'IBY  D
    97         .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX'="" D DISPLNC(IBX) S IBCNT=IBCNT+1
    98         ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") S IBCNT=IBCNT+1
    99         ... ;
    100         ... I IBCNT>20 S IBQUIT=$$PAUSE(IBCNT) Q:IBQUIT  D DSPHDR(AA) S IBCNT=4
    101         ;
    102         I +IBTOTAL W !,?72,"--------",!,?70,$J(IBTOTAL,10,2) S IBCNT=IBCNT+2
    103         I 'IBQUIT S IBQUIT=$$PAUSE(IBCNT)
    104         Q
    105         ;
    106 DSPHDR(AA)      ;
    107         W @IOF,!,"Items and Charges on this Bill ("_$S('AA:"NOT ",1:"")_"Auto Add)"
    108         W !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total"
    109         W !,"--------------------------------------------------------------------------------"
    110         Q
    111         ;
    112 DSPLN(LN)       ;
    113         N CS,DIV,CMP,RVCD,ITM,CHG,UNIT S LN=$G(LN)
    114         S CS=$P(LN,U,5) I +CS S CS=$P($G(^IBE(363.1,+$P(LN,U,5),0)),U,1)
    115         S DIV=$P($G(^DG(40.8,+$P(LN,U,7),0)),U,2)
    116         S CMP=$S($P(LN,U,4)=1:"INST",$P(LN,U,4)=2:"PROF",1:"")
    117         S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1)
    118         S ITM=$P(LN,U,8),CHG=+$P(LN,U,2),UNIT=$P(LN,U,3)
    119         W !,$E(ITM,1,15),?18,$$DATE($P(LN,U,6)),?28,$E(CS,1,7),?40,DIV,?47,CMP,?52,RVCD,?57,$J(UNIT,3),?62,$J(CHG,8,2),?71,$J((UNIT*CHG),9,2)
    120         Q
    121         ;
    122 DISPLNC(LN)     ; display charge adjustment commenmts
    123         W !,?18,$G(LN)
    124         Q
    125         ;
    126 DATE(X) ;
    127         S X=$G(X),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
    128         Q X
    129         ;
    130 PAUSE(CNT)      ;
    131         N IBI F IBI=CNT:1:22 W !
    132         N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
    133         Q IBX
    134         ;
    135 ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT)       ; return external form of the item name
    136         N ITM S ITM="",IBBS=$G(IBBS),IBIT=$G(IBIT),IBIP=$G(IBIP),IBCPT=$G(IBCPT)
    137         I +IBIP S ITM=$$NAME^IBCSC61(IBIT,IBIP)
    138         I ITM="",+IBIT=4,+$G(IBIFN) S ITM=$$CPTNM(IBIFN,IBIT,IBIP)
    139         I ITM="",+IBCPT S ITM=$P($$CPT^ICPTCOD(+IBCPT,DT),U,2)
    140         I ITM="" S ITM=$$EMUTL^IBCRU1(IBBS)
    141         Q ITM
    142         ;
    143 CPTNM(IBIFN,TYPE,ITEM)  ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1)
    144         N IBX,NAME S IBX=0,NAME=""
    145         I +$G(TYPE)=4 S IBX=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(ITEM),0))
    146         I +IBX S NAME=$P($$CPT^ICPTCOD(+$P(IBX,U,1),DT),U,2)
    147         I +IBX S IBX=$$GETMOD^IBEFUNC(+$G(IBIFN),+$G(ITEM),1) I IBX'="" S NAME=NAME_"-"_IBX
    148         Q NAME
    149         ;
    150         ;
    151         ;
    152         ;
    153 NOTES(IBIFN,PAUSE)      ; compile and print charge notes for a bill
    154         ;
    155         ; Current Checks are for those Treating Specialties that should not be billed using DRG:
    156         ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty
    157         ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty
    158         ;
    159         I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
    160         N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX S IBFND=0 K ^TMP($J,"IBCRC-PTF")
    161         S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""  S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU
    162         ;
    163         I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q  ; not Reasonable Charges bill
    164         ;
    165         ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill
    166         I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$RCDV^IBCRU8(+$P(IB0,U,22)),U,3)=3 D
    167         . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only.",IBMSG(IBFND)=IBX
    168         ;
    169         ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG
    170         I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D
    171         . ;
    172         . S PTF=+$P(IB0,U,8),BEG=+$P(IBU,U,1)\1,END=$S(+$P(IBU,U,2):+$P(IBU,U,2)\1,1:DT)
    173         . ;
    174         . D PTF^IBCRBG(PTF)
    175         . ;
    176         . S IBENDDT=BEG F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D  I IBENDDT>END Q
    177         .. I (IBENDDT\1)=BEG,BEG'=END Q
    178         .. ;
    179         .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+$P(IBMVLN,U,6) Q:'IBMVLN
    180         .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG
    181         .. ;
    182         .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG"
    183         .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG["Observa" IBX=IBX_", use Procedures."
    184         .. S IBMSG(IBFND)=$G(IBX)
    185         ;
    186         I +IBFND D  I +$G(PAUSE) S IBFND=$$PAUSE(21)
    187         . W ! S IBX="" F  S IBX=$O(IBMSG(IBX)) Q:IBX=""  W !,IBMSG(IBX)
    188         K ^TMP($J,"IBCRC-PTF")
    189         Q
     1IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
     2 ;;2.0;INTEGRATED BILLING;**106,245**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill
     6 ;
     7 D BILL(IBIFN,1),SORTCI(IBIFN),DSPCHRG(1) ;     display auto add charges
     8 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
     9 D BILL(IBIFN,""),SORTCI(IBIFN),DSPCHRG("") ;   display non-auto add charges
     10 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
     11 D NOTES(IBIFN,1)
     12 Q
     13 ;
     14BILL(IBIFN,IBAA,IBRSARR) ; given a bill number calculate charges using schedules that match the auto add flag
     15 ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
     16 ; Output:  ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill
     17 ;
     18 N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN)
     19 K ^TMP($J,"IBCRCC")
     20 ;
     21 S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0=""  S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
     22 S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3),IBCTYPE=+$P(IB0,U,27)
     23 ;
     24 ; get standard set of all rate schedules and charge sets available for the bill
     25 I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END
     26 ;
     27 ; process charge sets - set all charges for the bill into array
     28 S IBRS=0 F  S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS  D
     29 . S IBCS=0 F  S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS  I IBRSARR(IBRS,IBCS)=IBAA D
     30 .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
     31 .. ;
     32 .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
     33 .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
     34 .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
     35 .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS)
     36 .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
     37 .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
     38 ;
     39 I '$D(^TMP($J,"IBCRCC")) G END
     40 ;
     41 D MULTCPT^IBCRBCA1
     42 D PSB^IBCRBCA2
     43 D MODADJ^IBCRBCA3
     44 ;
     45END Q
     46 ;
     47 ;
     48SORTCI(IBIFN) ; process charge array - create new array in sorted order with items combined, if possible
     49 ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined
     50 ; Input:  TMP($J,"IBCRCC",X) = ...  (from IBCRBC2)
     51 ; Output: TMP($J,"IBCRCSX",X) =
     52 ;         RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME
     53 ;         TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages
     54 ;         TMP($J,"IBCRCSXR",BS,RV CD,X) = ""
     55 ;         TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = ""
     56 ;
     57 N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY
     58 K ^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
     59 ;
     60 S IBI=0 F  S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI  D
     61 . ;
     62 . S IBLN=^TMP($J,"IBCRCC",IBI)
     63 . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=+$FN($P(IBLN,U,12),"",2),IBUNITS=$P(IBLN,U,13)
     64 . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18)
     65 . S IBCS=$P(IBLN,U,2),IBDT=$P(IBLN,U,8),IBNM=$$ITMNM($G(IBIFN),IBBS,IBIT,IBIP,IBCPT)
     66 . ;
     67 . ; combine like charges, unless there are comments
     68 . S (IBTUNITS,IBK,IBJ)=0 F  S IBJ=$O(^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBJ)) Q:'IBJ  S IBK=IBJ D  Q:+IBTUNITS
     69 .. I $D(^TMP($J,"IBCRCC",IBI,"CC")) Q
     70 .. S IBX=$G(^TMP($J,"IBCRCSX",IBJ))
     71 .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D
     72 ... S IBTUNITS=$P(IBX,U,4),IBDT=$P(IBX,U,11)
     73 . ;
     74 . I 'IBTUNITS S IBK=IBI ; no combination, new line item charge
     75 . S IBTUNITS=IBTUNITS+IBUNITS
     76 . ;
     77 . S ^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBK)=""
     78 . S ^TMP($J,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)=""
     79 . S ^TMP($J,"IBCRCSX",IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT_U_IBCS_U_IBDT_U_IBNM
     80 . S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCC",IBI,"CC",IBY)) Q:'IBY  S ^TMP($J,"IBCRCSX",IBK,"CC",IBY)=^TMP($J,"IBCRCC",IBI,"CC",IBY)
     81 Q
     82 ;
     83DSPCHRG(AA) ; display charges
     84 ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI)
     85 ;
     86 N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY S (IBTOTAL,IBQUIT)=0
     87 ;
     88 D DSPHDR(AA) S IBCNT=4
     89 ;
     90 S IBI="" F  S IBI=$O(^TMP($J,"IBCRCSXN",IBI)) Q:IBI=""  D  Q:IBQUIT
     91 . S IBJ="" F  S IBJ=$O(^TMP($J,"IBCRCSXN",IBI,IBJ)) Q:IBJ=""  D  Q:IBQUIT
     92 .. S IBK=0 F  S IBK=$O(^TMP($J,"IBCRCSXN",IBI,IBJ,IBK)) Q:'IBK  D  Q:IBQUIT
     93 ... S IBLN=$G(^TMP($J,"IBCRCSX",IBK)) Q:IBLN=""
     94 ... ;
     95 ... ; add charges to RC multiple
     96 ... S IBRVCD=$P(IBLN,U,1),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBDV=$P(IBLN,U,6)
     97 ... S IBCMPT=$P(IBLN,U,9),IBCS=$P(IBLN,U,10),IBDT=$P(IBLN,U,11),IBNM=$P(IBLN,U,12)
     98 ... S IBTOTAL=IBTOTAL+(IBCHG*IBUNITS),IBCNT=IBCNT+1
     99 ... ;
     100 ... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM D DSPLN(IBX)
     101 ... ;
     102 ... S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) Q:'IBY  D
     103 .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX'="" D DISPLNC(IBX) S IBCNT=IBCNT+1
     104 ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") S IBCNT=IBCNT+1
     105 ... ;
     106 ... I IBCNT>20 S IBQUIT=$$PAUSE(IBCNT) Q:IBQUIT  D DSPHDR(AA) S IBCNT=4
     107 ;
     108 I +IBTOTAL W !,?72,"--------",!,?70,$J(IBTOTAL,10,2) S IBCNT=IBCNT+2
     109 I 'IBQUIT S IBQUIT=$$PAUSE(IBCNT)
     110 Q
     111 ;
     112DSPHDR(AA) ;
     113 W @IOF,!,"Items and Charges on this Bill ("_$S('AA:"NOT ",1:"")_"Auto Add)"
     114 W !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total"
     115 W !,"--------------------------------------------------------------------------------"
     116 Q
     117 ;
     118DSPLN(LN) ;
     119 N CS,DIV,CMP,RVCD,ITM,CHG,UNIT S LN=$G(LN)
     120 S CS=$P(LN,U,5) I +CS S CS=$P($G(^IBE(363.1,+$P(LN,U,5),0)),U,1)
     121 S DIV=$P($G(^DG(40.8,+$P(LN,U,7),0)),U,2)
     122 S CMP=$S($P(LN,U,4)=1:"INST",$P(LN,U,4)=2:"PROF",1:"")
     123 S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1)
     124 S ITM=$P(LN,U,8),CHG=+$P(LN,U,2),UNIT=$P(LN,U,3)
     125 W !,$E(ITM,1,15),?18,$$DATE($P(LN,U,6)),?28,$E(CS,1,7),?40,DIV,?47,CMP,?52,RVCD,?57,$J(UNIT,3),?62,$J(CHG,8,2),?71,$J((UNIT*CHG),9,2)
     126 Q
     127 ;
     128DISPLNC(LN) ; display charge adjustment commenmts
     129 W !,?18,$G(LN)
     130 Q
     131 ;
     132DATE(X) ;
     133 S X=$G(X),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
     134 Q X
     135 ;
     136PAUSE(CNT) ;
     137 N IBI F IBI=CNT:1:22 W !
     138 N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
     139 Q IBX
     140 ;
     141ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT) ; return external form of the item name
     142 N ITM S ITM="",IBBS=$G(IBBS),IBIT=$G(IBIT),IBIP=$G(IBIP),IBCPT=$G(IBCPT)
     143 I +IBIP S ITM=$$NAME^IBCSC61(IBIT,IBIP)
     144 I ITM="",+IBIT=4,+$G(IBIFN) S ITM=$$CPTNM(IBIFN,IBIT,IBIP)
     145 I ITM="",+IBCPT S ITM=$P($$CPT^ICPTCOD(+IBCPT,DT),U,2)
     146 I ITM="" S ITM=$$EMUTL^IBCRU1(IBBS)
     147 Q ITM
     148 ;
     149CPTNM(IBIFN,TYPE,ITEM) ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1)
     150 N IBX,NAME S IBX=0,NAME=""
     151 I +$G(TYPE)=4 S IBX=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(ITEM),0))
     152 I +IBX S NAME=$P($$CPT^ICPTCOD(+$P(IBX,U,1),DT),U,2)
     153 I +IBX S IBX=$$GETMOD^IBEFUNC(+$G(IBIFN),+$G(ITEM),1) I IBX'="" S NAME=NAME_"-"_IBX
     154 Q NAME
     155 ;
     156 ;
     157 ;
     158 ;
     159NOTES(IBIFN,PAUSE) ; compile and print charge notes for a bill
     160 ;
     161 ; Current Checks are for those Treating Specialties that should not be billed using DRG:
     162 ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty
     163 ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty
     164 ;
     165 I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
     166 N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX S IBFND=0 K ^TMP($J,"IBCRC-PTF")
     167 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""  S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU
     168 ;
     169 I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q  ; not Reasonable Charges bill
     170 ;
     171 ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill
     172 I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$RCDV^IBCRU8(+$P(IB0,U,22)),U,3)=3 D
     173 . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only.",IBMSG(IBFND)=IBX
     174 ;
     175 ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG
     176 I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D
     177 . ;
     178 . S PTF=+$P(IB0,U,8),BEG=+$P(IBU,U,1)\1,END=$S(+$P(IBU,U,2):+$P(IBU,U,2)\1,1:DT)
     179 . ;
     180 . D PTF^IBCRBG(PTF)
     181 . ;
     182 . S IBENDDT=BEG F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D  I IBENDDT>END Q
     183 .. I (IBENDDT\1)=BEG,BEG'=END Q
     184 .. ;
     185 .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+$P(IBMVLN,U,6) Q:'IBMVLN
     186 .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG
     187 .. ;
     188 .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG"
     189 .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG["Observa" IBX=IBX_", use Procedures."
     190 .. S IBMSG(IBFND)=$G(IBX)
     191 ;
     192 I +IBFND D  I +$G(PAUSE) S IBFND=$$PAUSE(21)
     193 . W ! S IBX="" F  S IBX=$O(IBMSG(IBX)) Q:IBX=""  W !,IBMSG(IBX)
     194 K ^TMP($J,"IBCRC-PTF")
     195 Q
Note: See TracChangeset for help on using the changeset viewer.