- IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
- ;;2.0;INTEGRATED BILLING;**106,245,370**;21-MAR-94;Build 5
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill
- ;
- D BILL(IBIFN,1),SORTCI(IBIFN),DSPCHRG(1) ; display auto add charges
- K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
- D BILL(IBIFN,""),SORTCI(IBIFN),DSPCHRG("") ; display non-auto add charges
- K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
- D NOTES(IBIFN,1)
- Q
- ;
- BILL(IBIFN,IBAA,IBRSARR) ; given a bill number calculate charges using schedules that match the auto add flag
- ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
- ; Output: ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill
- ;
- N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN)
- K ^TMP($J,"IBCRCC")
- ;
- S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
- S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3),IBCTYPE=+$P(IB0,U,27)
- ;
- ; get standard set of all rate schedules and charge sets available for the bill
- I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END
- ;
- ; process charge sets - set all charges for the bill into array
- S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D
- . S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I IBRSARR(IBRS,IBCS)=IBAA D
- .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
- .. ;
- .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
- .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
- .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
- .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS)
- .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
- .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
- ;
- END Q
- ;
- ;
- SORTCI(IBIFN) ; process charge array - create new array in sorted order with items combined, if possible
- ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined
- ; Input: TMP($J,"IBCRCC",X) = ... (from IBCRBC2)
- ; Output: TMP($J,"IBCRCSX",X) =
- ; RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME
- ; TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages
- ; TMP($J,"IBCRCSXR",BS,RV CD,X) = ""
- ; TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = ""
- ;
- N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY
- K ^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
- ;
- S IBI=0 F S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI D
- . ;
- . S IBLN=^TMP($J,"IBCRCC",IBI)
- . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=+$FN($P(IBLN,U,12),"",2),IBUNITS=$P(IBLN,U,13)
- . 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)
- . S IBCS=$P(IBLN,U,2),IBDT=$P(IBLN,U,8),IBNM=$$ITMNM($G(IBIFN),IBBS,IBIT,IBIP,IBCPT)
- . ;
- . ; combine like charges, unless there are comments
- . S (IBTUNITS,IBK,IBJ)=0 F S IBJ=$O(^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBJ)) Q:'IBJ S IBK=IBJ D Q:+IBTUNITS
- .. I $D(^TMP($J,"IBCRCC",IBI,"CC")) Q
- .. S IBX=$G(^TMP($J,"IBCRCSX",IBJ))
- .. 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
- ... S IBTUNITS=$P(IBX,U,4),IBDT=$P(IBX,U,11)
- . ;
- . I 'IBTUNITS S IBK=IBI ; no combination, new line item charge
- . S IBTUNITS=IBTUNITS+IBUNITS
- . ;
- . S ^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBK)=""
- . S ^TMP($J,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)=""
- . 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
- . 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)
- Q
- ;
- DSPCHRG(AA) ; display charges
- ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI)
- ;
- N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY S (IBTOTAL,IBQUIT)=0
- ;
- D DSPHDR(AA) S IBCNT=4
- ;
- S IBI="" F S IBI=$O(^TMP($J,"IBCRCSXN",IBI)) Q:IBI="" D Q:IBQUIT
- . S IBJ="" F S IBJ=$O(^TMP($J,"IBCRCSXN",IBI,IBJ)) Q:IBJ="" D Q:IBQUIT
- .. S IBK=0 F S IBK=$O(^TMP($J,"IBCRCSXN",IBI,IBJ,IBK)) Q:'IBK D Q:IBQUIT
- ... S IBLN=$G(^TMP($J,"IBCRCSX",IBK)) Q:IBLN=""
- ... ;
- ... ; add charges to RC multiple
- ... S IBRVCD=$P(IBLN,U,1),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBDV=$P(IBLN,U,6)
- ... S IBCMPT=$P(IBLN,U,9),IBCS=$P(IBLN,U,10),IBDT=$P(IBLN,U,11),IBNM=$P(IBLN,U,12)
- ... S IBTOTAL=IBTOTAL+(IBCHG*IBUNITS),IBCNT=IBCNT+1
- ... ;
- ... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM D DSPLN(IBX)
- ... ;
- ... S IBY=0 F S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) Q:'IBY D
- .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX'="" D DISPLNC(IBX) S IBCNT=IBCNT+1
- ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") S IBCNT=IBCNT+1
- ... ;
- ... I IBCNT>20 S IBQUIT=$$PAUSE(IBCNT) Q:IBQUIT D DSPHDR(AA) S IBCNT=4
- ;
- I +IBTOTAL W !,?72,"--------",!,?70,$J(IBTOTAL,10,2) S IBCNT=IBCNT+2
- I 'IBQUIT S IBQUIT=$$PAUSE(IBCNT)
- Q
- ;
- DSPHDR(AA) ;
- W @IOF,!,"Items and Charges on this Bill ("_$S('AA:"NOT ",1:"")_"Auto Add)"
- W !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total"
- W !,"--------------------------------------------------------------------------------"
- Q
- ;
- DSPLN(LN) ;
- N CS,DIV,CMP,RVCD,ITM,CHG,UNIT S LN=$G(LN)
- S CS=$P(LN,U,5) I +CS S CS=$P($G(^IBE(363.1,+$P(LN,U,5),0)),U,1)
- S DIV=$P($G(^DG(40.8,+$P(LN,U,7),0)),U,2)
- S CMP=$S($P(LN,U,4)=1:"INST",$P(LN,U,4)=2:"PROF",1:"")
- S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1)
- S ITM=$P(LN,U,8),CHG=+$P(LN,U,2),UNIT=$P(LN,U,3)
- 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)
- Q
- ;
- DISPLNC(LN) ; display charge adjustment commenmts
- W !,?18,$G(LN)
- Q
- ;
- DATE(X) ;
- S X=$G(X),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
- Q X
- ;
- PAUSE(CNT) ;
- N IBI F IBI=CNT:1:22 W !
- N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
- Q IBX
- ;
- ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT) ; return external form of the item name
- N ITM S ITM="",IBBS=$G(IBBS),IBIT=$G(IBIT),IBIP=$G(IBIP),IBCPT=$G(IBCPT)
- I +IBIP S ITM=$$NAME^IBCSC61(IBIT,IBIP)
- I ITM="",+IBIT=4,+$G(IBIFN) S ITM=$$CPTNM(IBIFN,IBIT,IBIP)
- I ITM="",+IBCPT S ITM=$P($$CPT^ICPTCOD(+IBCPT,DT),U,2)
- I ITM="" S ITM=$$EMUTL^IBCRU1(IBBS)
- Q ITM
- ;
- CPTNM(IBIFN,TYPE,ITEM) ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1)
- N IBX,NAME S IBX=0,NAME=""
- I +$G(TYPE)=4 S IBX=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(ITEM),0))
- I +IBX S NAME=$P($$CPT^ICPTCOD(+$P(IBX,U,1),DT),U,2)
- I +IBX S IBX=$$GETMOD^IBEFUNC(+$G(IBIFN),+$G(ITEM),1) I IBX'="" S NAME=NAME_"-"_IBX
- Q NAME
- ;
- ;
- ;
- ;
- NOTES(IBIFN,PAUSE) ; compile and print charge notes for a bill
- ;
- ; Current Checks are for those Treating Specialties that should not be billed using DRG:
- ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty
- ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty
- ;
- I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
- N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX S IBFND=0 K ^TMP($J,"IBCRC-PTF")
- S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU
- ;
- I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q ; not Reasonable Charges bill
- ;
- ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill
- I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$RCDV^IBCRU8(+$P(IB0,U,22)),U,3)=3 D
- . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only.",IBMSG(IBFND)=IBX
- ;
- ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG
- I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D
- . ;
- . 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)
- . ;
- . D PTF^IBCRBG(PTF)
- . ;
- . S IBENDDT=BEG F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D I IBENDDT>END Q
- .. I (IBENDDT\1)=BEG,BEG'=END Q
- .. ;
- .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+$P(IBMVLN,U,6) Q:'IBMVLN
- .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG
- .. ;
- .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG"
- .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG["Observa" IBX=IBX_", use Procedures."
- .. S IBMSG(IBFND)=$G(IBX)
- ;
- I +IBFND D I +$G(PAUSE) S IBFND=$$PAUSE(21)
- . W ! S IBX="" F S IBX=$O(IBMSG(IBX)) Q:IBX="" W !,IBMSG(IBX)
- K ^TMP($J,"IBCRC-PTF")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRBH1 9147 printed Feb 18, 2025@23:45:17 Page 2
- IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
- +1 ;;2.0;INTEGRATED BILLING;**106,245,370**;21-MAR-94;Build 5
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill
- +1 ;
- +2 ; display auto add charges
- DO BILL(IBIFN,1)
- DO SORTCI(IBIFN)
- DO DSPCHRG(1)
- +3 KILL ^TMP($JOB,"IBCRCC"),^TMP($JOB,"IBCRCSX"),^TMP($JOB,"IBCRCSXR"),^TMP($JOB,"IBCRCSXN")
- +4 ; display non-auto add charges
- DO BILL(IBIFN,"")
- DO SORTCI(IBIFN)
- DO DSPCHRG("")
- +5 KILL ^TMP($JOB,"IBCRCC"),^TMP($JOB,"IBCRCSX"),^TMP($JOB,"IBCRCSXR"),^TMP($JOB,"IBCRCSXN")
- +6 DO NOTES(IBIFN,1)
- +7 QUIT
- +8 ;
- BILL(IBIFN,IBAA,IBRSARR) ; given a bill number calculate charges using schedules that match the auto add flag
- +1 ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
- +2 ; Output: ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill
- +3 ;
- +4 NEW IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT
- if '$GET(IBIFN)
- QUIT
- +5 KILL ^TMP($JOB,"IBCRCC")
- +6 ;
- +7 SET IB0=$GET(^DGCR(399,+IBIFN,0))
- if IB0=""
- QUIT
- SET IBU=$GET(^DGCR(399,+IBIFN,"U"))
- if 'IBU
- QUIT
- +8 SET IBBRT=+$PIECE(IB0,U,7)
- SET IBBTYPE=$SELECT($PIECE(IB0,U,5)<3:1,1:3)
- SET IBCTYPE=+$PIECE(IB0,U,27)
- +9 ;
- +10 ; get standard set of all rate schedules and charge sets available for the bill
- +11 IF '$DATA(IBRSARR)
- DO RT^IBCRU3(IBBRT,IBBTYPE,$PIECE(IBU,U,1,2),.IBRSARR,"",IBCTYPE)
- IF 'IBRSARR
- GOTO END
- +12 ;
- +13 ; process charge sets - set all charges for the bill into array
- +14 SET IBRS=0
- FOR
- SET IBRS=$ORDER(IBRSARR(IBRS))
- if 'IBRS
- QUIT
- Begin DoDot:1
- +15 SET IBCS=0
- FOR
- SET IBCS=$ORDER(IBRSARR(IBRS,IBCS))
- if 'IBCS
- QUIT
- IF IBRSARR(IBRS,IBCS)=IBAA
- Begin DoDot:2
- +16 SET IBBEVNT=+$PIECE($GET(^IBE(363.1,+IBCS,0)),U,3)
- if 'IBBEVNT
- QUIT
- SET IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT)
- if IBBEVNT=""
- QUIT
- +17 ;
- +18 IF IBBEVNT["INPATIENT BEDSECTION STAY"
- DO INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
- +19 IF IBBEVNT["INPATIENT DRG"
- DO INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
- +20 IF IBBEVNT["OUTPATIENT VISIT DATE"
- DO OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
- +21 IF IBBEVNT["PRESCRIPTION"
- DO RX^IBCRBC1(IBIFN,IBRS,IBCS)
- +22 IF IBBEVNT["PROSTHETICS"
- DO PI^IBCRBC1(IBIFN,IBRS,IBCS)
- +23 IF IBBEVNT["PROCEDURE"
- DO CPT^IBCRBC1(IBIFN,IBRS,IBCS)
- End DoDot:2
- End DoDot:1
- +24 ;
- END QUIT
- +1 ;
- +2 ;
- SORTCI(IBIFN) ; process charge array - create new array in sorted order with items combined, if possible
- +1 ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined
- +2 ; Input: TMP($J,"IBCRCC",X) = ... (from IBCRBC2)
- +3 ; Output: TMP($J,"IBCRCSX",X) =
- +4 ; RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME
- +5 ; TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages
- +6 ; TMP($J,"IBCRCSXR",BS,RV CD,X) = ""
- +7 ; TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = ""
- +8 ;
- +9 NEW IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY
- +10 KILL ^TMP($JOB,"IBCRCSX"),^TMP($JOB,"IBCRCSXR"),^TMP($JOB,"IBCRCSXN")
- +11 ;
- +12 SET IBI=0
- FOR
- SET IBI=$ORDER(^TMP($JOB,"IBCRCC",IBI))
- if 'IBI
- QUIT
- Begin DoDot:1
- +13 ;
- +14 SET IBLN=^TMP($JOB,"IBCRCC",IBI)
- +15 SET IBRVCD=$PIECE(IBLN,U,6)
- SET IBBS=$PIECE(IBLN,U,7)
- SET IBCHG=+$FNUMBER($PIECE(IBLN,U,12),"",2)
- SET IBUNITS=$PIECE(IBLN,U,13)
- +16 SET IBCPT=$PIECE(IBLN,U,14)
- SET IBDV=$PIECE(IBLN,U,15)
- SET IBIT=$PIECE(IBLN,U,16)
- SET IBIP=$PIECE(IBLN,U,17)
- SET IBCMPT=$PIECE(IBLN,U,18)
- +17 SET IBCS=$PIECE(IBLN,U,2)
- SET IBDT=$PIECE(IBLN,U,8)
- SET IBNM=$$ITMNM($GET(IBIFN),IBBS,IBIT,IBIP,IBCPT)
- +18 ;
- +19 ; combine like charges, unless there are comments
- +20 SET (IBTUNITS,IBK,IBJ)=0
- FOR
- SET IBJ=$ORDER(^TMP($JOB,"IBCRCSXR",+IBBS,+IBRVCD,IBJ))
- if 'IBJ
- QUIT
- SET IBK=IBJ
- Begin DoDot:2
- +21 IF $DATA(^TMP($JOB,"IBCRCC",IBI,"CC"))
- QUIT
- +22 SET IBX=$GET(^TMP($JOB,"IBCRCSX",IBJ))
- +23 IF IBCHG=$PIECE(IBX,U,3)
- IF IBCPT=$PIECE(IBX,U,5)
- IF IBDV=$PIECE(IBX,U,6)
- IF IBIT=$PIECE(IBX,U,7)
- IF IBIP=$PIECE(IBX,U,8)
- IF IBCMPT=$PIECE(IBX,U,9)
- Begin DoDot:3
- +24 SET IBTUNITS=$PIECE(IBX,U,4)
- SET IBDT=$PIECE(IBX,U,11)
- End DoDot:3
- End DoDot:2
- if +IBTUNITS
- QUIT
- +25 ;
- +26 ; no combination, new line item charge
- IF 'IBTUNITS
- SET IBK=IBI
- +27 SET IBTUNITS=IBTUNITS+IBUNITS
- +28 ;
- +29 SET ^TMP($JOB,"IBCRCSXR",+IBBS,+IBRVCD,IBK)=""
- +30 SET ^TMP($JOB,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)=""
- +31 SET ^TMP($JOB,"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
- +32 SET IBY=0
- FOR
- SET IBY=$ORDER(^TMP($JOB,"IBCRCC",IBI,"CC",IBY))
- if 'IBY
- QUIT
- SET ^TMP($JOB,"IBCRCSX",IBK,"CC",IBY)=^TMP($JOB,"IBCRCC",IBI,"CC",IBY)
- End DoDot:1
- +33 QUIT
- +34 ;
- DSPCHRG(AA) ; display charges
- +1 ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI)
- +2 ;
- +3 NEW IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY
- SET (IBTOTAL,IBQUIT)=0
- +4 ;
- +5 DO DSPHDR(AA)
- SET IBCNT=4
- +6 ;
- +7 SET IBI=""
- FOR
- SET IBI=$ORDER(^TMP($JOB,"IBCRCSXN",IBI))
- if IBI=""
- QUIT
- Begin DoDot:1
- +8 SET IBJ=""
- FOR
- SET IBJ=$ORDER(^TMP($JOB,"IBCRCSXN",IBI,IBJ))
- if IBJ=""
- QUIT
- Begin DoDot:2
- +9 SET IBK=0
- FOR
- SET IBK=$ORDER(^TMP($JOB,"IBCRCSXN",IBI,IBJ,IBK))
- if 'IBK
- QUIT
- Begin DoDot:3
- +10 SET IBLN=$GET(^TMP($JOB,"IBCRCSX",IBK))
- if IBLN=""
- QUIT
- +11 ;
- +12 ; add charges to RC multiple
- +13 SET IBRVCD=$PIECE(IBLN,U,1)
- SET IBCHG=$PIECE(IBLN,U,3)
- SET IBUNITS=$PIECE(IBLN,U,4)
- SET IBDV=$PIECE(IBLN,U,6)
- +14 SET IBCMPT=$PIECE(IBLN,U,9)
- SET IBCS=$PIECE(IBLN,U,10)
- SET IBDT=$PIECE(IBLN,U,11)
- SET IBNM=$PIECE(IBLN,U,12)
- +15 SET IBTOTAL=IBTOTAL+(IBCHG*IBUNITS)
- SET IBCNT=IBCNT+1
- +16 ;
- +17 SET IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM
- DO DSPLN(IBX)
- +18 ;
- +19 SET IBY=0
- FOR
- SET IBY=$ORDER(^TMP($JOB,"IBCRCSX",IBK,"CC",IBY))
- if 'IBY
- QUIT
- Begin DoDot:4
- +20 SET IBX=$GET(^TMP($JOB,"IBCRCSX",IBK,"CC",IBY))
- IF IBX'=""
- DO DISPLNC(IBX)
- SET IBCNT=IBCNT+1
- End DoDot:4
- +21 IF $ORDER(^TMP($JOB,"IBCRCSX",IBK,"CC",0))
- DO DISPLNC("")
- SET IBCNT=IBCNT+1
- +22 ;
- +23 IF IBCNT>20
- SET IBQUIT=$$PAUSE(IBCNT)
- if IBQUIT
- QUIT
- DO DSPHDR(AA)
- SET IBCNT=4
- End DoDot:3
- if IBQUIT
- QUIT
- End DoDot:2
- if IBQUIT
- QUIT
- End DoDot:1
- if IBQUIT
- QUIT
- +24 ;
- +25 IF +IBTOTAL
- WRITE !,?72,"--------",!,?70,$JUSTIFY(IBTOTAL,10,2)
- SET IBCNT=IBCNT+2
- +26 IF 'IBQUIT
- SET IBQUIT=$$PAUSE(IBCNT)
- +27 QUIT
- +28 ;
- DSPHDR(AA) ;
- +1 WRITE @IOF,!,"Items and Charges on this Bill ("_$SELECT('AA:"NOT ",1:"")_"Auto Add)"
- +2 WRITE !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total"
- +3 WRITE !,"--------------------------------------------------------------------------------"
- +4 QUIT
- +5 ;
- DSPLN(LN) ;
- +1 NEW CS,DIV,CMP,RVCD,ITM,CHG,UNIT
- SET LN=$GET(LN)
- +2 SET CS=$PIECE(LN,U,5)
- IF +CS
- SET CS=$PIECE($GET(^IBE(363.1,+$PIECE(LN,U,5),0)),U,1)
- +3 SET DIV=$PIECE($GET(^DG(40.8,+$PIECE(LN,U,7),0)),U,2)
- +4 SET CMP=$SELECT($PIECE(LN,U,4)=1:"INST",$PIECE(LN,U,4)=2:"PROF",1:"")
- +5 SET RVCD=$PIECE($GET(^DGCR(399.2,+LN,0)),U,1)
- +6 SET ITM=$PIECE(LN,U,8)
- SET CHG=+$PIECE(LN,U,2)
- SET UNIT=$PIECE(LN,U,3)
- +7 WRITE !,$EXTRACT(ITM,1,15),?18,$$DATE($PIECE(LN,U,6)),?28,$EXTRACT(CS,1,7),?40,DIV,?47,CMP,?52,RVCD,?57,$JUSTIFY(UNIT,3),?62,$JUSTIFY(CHG,8,2),?71,$JUSTIFY((UNIT*CHG),9,2)
- +8 QUIT
- +9 ;
- DISPLNC(LN) ; display charge adjustment commenmts
- +1 WRITE !,?18,$GET(LN)
- +2 QUIT
- +3 ;
- DATE(X) ;
- +1 SET X=$GET(X)
- SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
- +2 QUIT X
- +3 ;
- PAUSE(CNT) ;
- +1 NEW IBI
- FOR IBI=CNT:1:22
- WRITE !
- +2 NEW DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y
- SET IBX=0
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET IBX=1
- +3 QUIT IBX
- +4 ;
- ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT) ; return external form of the item name
- +1 NEW ITM
- SET ITM=""
- SET IBBS=$GET(IBBS)
- SET IBIT=$GET(IBIT)
- SET IBIP=$GET(IBIP)
- SET IBCPT=$GET(IBCPT)
- +2 IF +IBIP
- SET ITM=$$NAME^IBCSC61(IBIT,IBIP)
- +3 IF ITM=""
- IF +IBIT=4
- IF +$GET(IBIFN)
- SET ITM=$$CPTNM(IBIFN,IBIT,IBIP)
- +4 IF ITM=""
- IF +IBCPT
- SET ITM=$PIECE($$CPT^ICPTCOD(+IBCPT,DT),U,2)
- +5 IF ITM=""
- SET ITM=$$EMUTL^IBCRU1(IBBS)
- +6 QUIT ITM
- +7 ;
- CPTNM(IBIFN,TYPE,ITEM) ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1)
- +1 NEW IBX,NAME
- SET IBX=0
- SET NAME=""
- +2 IF +$GET(TYPE)=4
- SET IBX=$GET(^DGCR(399,+$GET(IBIFN),"CP",+$GET(ITEM),0))
- +3 IF +IBX
- SET NAME=$PIECE($$CPT^ICPTCOD(+$PIECE(IBX,U,1),DT),U,2)
- +4 IF +IBX
- SET IBX=$$GETMOD^IBEFUNC(+$GET(IBIFN),+$GET(ITEM),1)
- IF IBX'=""
- SET NAME=NAME_"-"_IBX
- +5 QUIT NAME
- +6 ;
- +7 ;
- +8 ;
- +9 ;
- NOTES(IBIFN,PAUSE) ; compile and print charge notes for a bill
- +1 ;
- +2 ; Current Checks are for those Treating Specialties that should not be billed using DRG:
- +3 ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty
- +4 ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty
- +5 ;
- +6 IF $DATA(ZTQUEUED)!(+$GET(IBAUTO))
- QUIT
- +7 NEW IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX
- SET IBFND=0
- KILL ^TMP($JOB,"IBCRC-PTF")
- +8 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
- if IB0=""
- QUIT
- SET IBU=$GET(^DGCR(399,+$GET(IBIFN),"U"))
- if 'IBU
- QUIT
- +9 ;
- +10 ; not Reasonable Charges bill
- IF '$$BILLRATE^IBCRU3($PIECE(IB0,U,7),$PIECE(IB0,U,5),$PIECE(IB0,U,3),"RC")
- QUIT
- +11 ;
- +12 ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill
- +13 IF $PIECE(IB0,U,5)=3
- IF $PIECE(IB0,U,3)'<$$VERSDT^IBCRU8(2)
- IF $PIECE($$RCDV^IBCRU8(+$PIECE(IB0,U,22)),U,3)=3
- Begin DoDot:1
- +14 SET IBFND=IBFND+1
- SET IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only."
- SET IBMSG(IBFND)=IBX
- End DoDot:1
- +15 ;
- +16 ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG
- +17 IF +$PIECE(IB0,U,8)
- IF $PIECE(IB0,U,5)<3
- IF $PIECE(IB0,U,27)<2
- Begin DoDot:1
- +18 ;
- +19 SET PTF=+$PIECE(IB0,U,8)
- SET BEG=+$PIECE(IBU,U,1)\1
- SET END=$SELECT(+$PIECE(IBU,U,2):+$PIECE(IBU,U,2)\1,1:DT)
- +20 ;
- +21 DO PTF^IBCRBG(PTF)
- +22 ;
- +23 SET IBENDDT=BEG
- FOR
- SET IBENDDT=$ORDER(^TMP($JOB,"IBCRC-PTF",IBENDDT))
- if 'IBENDDT
- QUIT
- Begin DoDot:2
- +24 IF (IBENDDT\1)=BEG
- IF BEG'=END
- QUIT
- +25 ;
- +26 SET IBMVLN=$GET(^TMP($JOB,"IBCRC-PTF",IBENDDT))
- SET IBMVLN=+$PIECE(IBMVLN,U,6)
- if 'IBMVLN
- QUIT
- +27 SET IBMDRG=$$NODRG^IBCRBG2(IBMVLN)
- if 'IBMDRG
- QUIT
- +28 ;
- +29 SET IBFND=IBFND+1
- SET IBX=">>> "_$PIECE(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG"
- +30 if IBMDRG["Nursing"
- SET IBX=IBX_", use SNF."
- if IBMDRG["Observa"
- SET IBX=IBX_", use Procedures."
- +31 SET IBMSG(IBFND)=$GET(IBX)
- End DoDot:2
- IF IBENDDT>END
- QUIT
- End DoDot:1
- +32 ;
- +33 IF +IBFND
- Begin DoDot:1
- +34 WRITE !
- SET IBX=""
- FOR
- SET IBX=$ORDER(IBMSG(IBX))
- if IBX=""
- QUIT
- WRITE !,IBMSG(IBX)
- End DoDot:1
- IF +$GET(PAUSE)
- SET IBFND=$$PAUSE(21)
- +35 KILL ^TMP($JOB,"IBCRC-PTF")
- +36 QUIT