- IBCRBC3 ;ALB/ARH - RATES: BILL CALCULATION SORT/STORE ;22-MAY-1996
- ;;2.0;INTEGRATED BILLING;**52,106,138,51,447**;21-MAR-94;Build 80
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- SORTCI ; process charge array - create new array sorted by bedsection and revenue code
- ; if bs, rv cd, unit 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,"IBCRCS",BS,RV CD,Y) =
- ; RV CD PTR ^ BS PTR ^ UNIT $ ^ UNITS ^ CPT ^ DIV ^ ITEM TYPE ^ ITEM PTR ^ CHARGE COMPONENT
- ;
- N IBI,IBLN,IBRVCD,IBBS,IBUNITS,IBCHG,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBTUNITS,IBK,IBJ,IBX K ^TMP($J,"IBCRCS")
- ;
- S IBI=0 F S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI D
- . ;
- . S IBLN=^TMP($J,"IBCRCC",IBI)
- . ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
- . ;S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=$P(IBLN,U,12),IBUNITS=$P(IBLN,U,13) Q:'IBCHG
- . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=$P(IBLN,U,12),IBUNITS=$P(IBLN,U,13)
- . ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
- . 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 (IBTUNITS,IBK)=0 ; combine like charges
- . S IBJ=0 F S IBJ=$O(^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBJ)) Q:'IBJ D Q:+IBTUNITS
- .. S IBK=IBJ,IBX=$G(^TMP($J,"IBCRCS",+IBBS,+IBRVCD,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)
- . ;
- . I 'IBTUNITS S IBK=IBK+1 ; no combination, new line item charge
- . S IBTUNITS=IBTUNITS+IBUNITS
- . ;
- . S ^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT
- Q
- ;
- ;
- ADDBCHGS(IBIFN) ; store all auto calculated charges: add charges to bill: sets RC multiple
- ; Input: TMP($J,"IBCRCS",BS,RV CD,X) = ... (from SORTCI)
- ;
- N IBX,IBI,IBJ,IBK,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBAUTOAD,IBCPT,IBDIV,IBITYP,IBIPTR,IBCMPNT,IBRCFN,Z
- ;
- D DSPHDR
- ;
- S IBI=0 F S IBI=$O(^TMP($J,"IBCRCS",IBI)) Q:'IBI D
- . S IBJ=0 F S IBJ=$O(^TMP($J,"IBCRCS",IBI,IBJ)) Q:'IBJ D
- .. S IBK=0 F S IBK=$O(^TMP($J,"IBCRCS",IBI,IBJ,IBK)) Q:'IBK D
- ... S IBLN=$G(^TMP($J,"IBCRCS",IBI,IBJ,IBK)) Q:IBLN=""
- ... ;
- ... ; add charges to RC multiple
- ... S IBRVCD=$P(IBLN,U,1),IBBS=$P(IBLN,U,2),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBAUTOAD=1
- ... S IBCPT=$P(IBLN,U,5),IBDIV=$P(IBLN,U,6),IBITYP=$P(IBLN,U,7),IBIPTR=$P(IBLN,U,8),IBCMPNT=$P(IBLN,U,9)
- ... ;
- ... S IBRCFN=$$ADDRC^IBCRBF(IBIFN,IBRVCD,IBBS,.IBCHG,IBUNITS,IBCPT,IBDIV,IBAUTOAD,IBITYP,IBIPTR,IBCMPNT)
- ... ;
- ... I +IBRCFN D
- .... I IBITYP=3,IBIPTR'="" D DEFAULT^IBCSC5C(IBIFN,+IBRCFN)
- .... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBBS_U_IBITYP_U_IBIPTR_U_IBCPT D DSPLN(IBX)
- ;
- D CLEANRX(IBIFN)
- Q
- ;
- CLEANRX(IBIFN) ; Clean up any procedures left over from deleted Rx entries
- N Z,DA,DIK
- S Z=0 F S Z=$O(^TMP("IBCRRX",$J,Z)) Q:'Z S DA=0 F S DA=$O(^TMP("IBCRRX",$J,Z,DA)) Q:'DA S DA(1)=IBIFN,DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK
- K ^TMP("IBCRRX",$J)
- Q
- ;
- DSPDL ;
- I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
- W !,"Removing old Revenue Codes and Rate Schedules..."
- Q
- DSPHDR ;
- I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
- W !,"Updating Revenue Codes and Charges"
- W !,?9,"Rev Code",?19,"Units",?31,"Charge",?41,"Bedsection"
- Q
- DSPLN(LN) ;
- I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
- N RVCD,BS,ITM S LN=$G(LN)
- S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1),BS=$$EMUTL^IBCRU1(+$P(LN,U,4)),ITM=$$NAME^IBCSC61($P(LN,U,5),$P(LN,U,6))
- I ITM="",$P(LN,U,7) S ITM=$P($$CPT^ICPTCOD(+$P(LN,U,7),DT),U,2)
- W !,"Adding",?11,RVCD,?19,$J($P(LN,U,3),3),?28,"$",$J($P(LN,U,2),8,2),?41,$E(BS,U,26),?69,$E(ITM,1,11)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRBC3 3734 printed Feb 18, 2025@23:45:11 Page 2
- IBCRBC3 ;ALB/ARH - RATES: BILL CALCULATION SORT/STORE ;22-MAY-1996
- +1 ;;2.0;INTEGRATED BILLING;**52,106,138,51,447**;21-MAR-94;Build 80
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- SORTCI ; process charge array - create new array sorted by bedsection and revenue code
- +1 ; if bs, rv cd, unit 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,"IBCRCS",BS,RV CD,Y) =
- +4 ; RV CD PTR ^ BS PTR ^ UNIT $ ^ UNITS ^ CPT ^ DIV ^ ITEM TYPE ^ ITEM PTR ^ CHARGE COMPONENT
- +5 ;
- +6 NEW IBI,IBLN,IBRVCD,IBBS,IBUNITS,IBCHG,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBTUNITS,IBK,IBJ,IBX
- KILL ^TMP($JOB,"IBCRCS")
- +7 ;
- +8 SET IBI=0
- FOR
- SET IBI=$ORDER(^TMP($JOB,"IBCRCC",IBI))
- if 'IBI
- QUIT
- Begin DoDot:1
- +9 ;
- +10 SET IBLN=^TMP($JOB,"IBCRCC",IBI)
- +11 ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
- +12 ;S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=$P(IBLN,U,12),IBUNITS=$P(IBLN,U,13) Q:'IBCHG
- +13 SET IBRVCD=$PIECE(IBLN,U,6)
- SET IBBS=$PIECE(IBLN,U,7)
- SET IBCHG=$PIECE(IBLN,U,12)
- SET IBUNITS=$PIECE(IBLN,U,13)
- +14 ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
- +15 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)
- +16 ;
- +17 ; combine like charges
- SET (IBTUNITS,IBK)=0
- +18 SET IBJ=0
- FOR
- SET IBJ=$ORDER(^TMP($JOB,"IBCRCS",+IBBS,+IBRVCD,IBJ))
- if 'IBJ
- QUIT
- Begin DoDot:2
- +19 SET IBK=IBJ
- SET IBX=$GET(^TMP($JOB,"IBCRCS",+IBBS,+IBRVCD,IBJ))
- +20 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
- +21 SET IBTUNITS=$PIECE(IBX,U,4)
- End DoDot:3
- End DoDot:2
- if +IBTUNITS
- QUIT
- +22 ;
- +23 ; no combination, new line item charge
- IF 'IBTUNITS
- SET IBK=IBK+1
- +24 SET IBTUNITS=IBTUNITS+IBUNITS
- +25 ;
- +26 SET ^TMP($JOB,"IBCRCS",+IBBS,+IBRVCD,IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT
- End DoDot:1
- +27 QUIT
- +28 ;
- +29 ;
- ADDBCHGS(IBIFN) ; store all auto calculated charges: add charges to bill: sets RC multiple
- +1 ; Input: TMP($J,"IBCRCS",BS,RV CD,X) = ... (from SORTCI)
- +2 ;
- +3 NEW IBX,IBI,IBJ,IBK,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBAUTOAD,IBCPT,IBDIV,IBITYP,IBIPTR,IBCMPNT,IBRCFN,Z
- +4 ;
- +5 DO DSPHDR
- +6 ;
- +7 SET IBI=0
- FOR
- SET IBI=$ORDER(^TMP($JOB,"IBCRCS",IBI))
- if 'IBI
- QUIT
- Begin DoDot:1
- +8 SET IBJ=0
- FOR
- SET IBJ=$ORDER(^TMP($JOB,"IBCRCS",IBI,IBJ))
- if 'IBJ
- QUIT
- Begin DoDot:2
- +9 SET IBK=0
- FOR
- SET IBK=$ORDER(^TMP($JOB,"IBCRCS",IBI,IBJ,IBK))
- if 'IBK
- QUIT
- Begin DoDot:3
- +10 SET IBLN=$GET(^TMP($JOB,"IBCRCS",IBI,IBJ,IBK))
- if IBLN=""
- QUIT
- +11 ;
- +12 ; add charges to RC multiple
- +13 SET IBRVCD=$PIECE(IBLN,U,1)
- SET IBBS=$PIECE(IBLN,U,2)
- SET IBCHG=$PIECE(IBLN,U,3)
- SET IBUNITS=$PIECE(IBLN,U,4)
- SET IBAUTOAD=1
- +14 SET IBCPT=$PIECE(IBLN,U,5)
- SET IBDIV=$PIECE(IBLN,U,6)
- SET IBITYP=$PIECE(IBLN,U,7)
- SET IBIPTR=$PIECE(IBLN,U,8)
- SET IBCMPNT=$PIECE(IBLN,U,9)
- +15 ;
- +16 SET IBRCFN=$$ADDRC^IBCRBF(IBIFN,IBRVCD,IBBS,.IBCHG,IBUNITS,IBCPT,IBDIV,IBAUTOAD,IBITYP,IBIPTR,IBCMPNT)
- +17 ;
- +18 IF +IBRCFN
- Begin DoDot:4
- +19 IF IBITYP=3
- IF IBIPTR'=""
- DO DEFAULT^IBCSC5C(IBIFN,+IBRCFN)
- +20 SET IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBBS_U_IBITYP_U_IBIPTR_U_IBCPT
- DO DSPLN(IBX)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 ;
- +22 DO CLEANRX(IBIFN)
- +23 QUIT
- +24 ;
- CLEANRX(IBIFN) ; Clean up any procedures left over from deleted Rx entries
- +1 NEW Z,DA,DIK
- +2 SET Z=0
- FOR
- SET Z=$ORDER(^TMP("IBCRRX",$JOB,Z))
- if 'Z
- QUIT
- SET DA=0
- FOR
- SET DA=$ORDER(^TMP("IBCRRX",$JOB,Z,DA))
- if 'DA
- QUIT
- SET DA(1)=IBIFN
- SET DIK="^DGCR(399,"_DA(1)_",""CP"","
- DO ^DIK
- +3 KILL ^TMP("IBCRRX",$JOB)
- +4 QUIT
- +5 ;
- DSPDL ;
- +1 IF $DATA(ZTQUEUED)!(+$GET(IBAUTO))
- QUIT
- +2 WRITE !,"Removing old Revenue Codes and Rate Schedules..."
- +3 QUIT
- DSPHDR ;
- +1 IF $DATA(ZTQUEUED)!(+$GET(IBAUTO))
- QUIT
- +2 WRITE !,"Updating Revenue Codes and Charges"
- +3 WRITE !,?9,"Rev Code",?19,"Units",?31,"Charge",?41,"Bedsection"
- +4 QUIT
- DSPLN(LN) ;
- +1 IF $DATA(ZTQUEUED)!(+$GET(IBAUTO))
- QUIT
- +2 NEW RVCD,BS,ITM
- SET LN=$GET(LN)
- +3 SET RVCD=$PIECE($GET(^DGCR(399.2,+LN,0)),U,1)
- SET BS=$$EMUTL^IBCRU1(+$PIECE(LN,U,4))
- SET ITM=$$NAME^IBCSC61($PIECE(LN,U,5),$PIECE(LN,U,6))
- +4 IF ITM=""
- IF $PIECE(LN,U,7)
- SET ITM=$PIECE($$CPT^ICPTCOD(+$PIECE(LN,U,7),DT),U,2)
- +5 WRITE !,"Adding",?11,RVCD,?19,$JUSTIFY($PIECE(LN,U,3),3),?28,"$",$JUSTIFY($PIECE(LN,U,2),8,2),?41,$EXTRACT(BS,U,26),?69,$EXTRACT(ITM,1,11)
- +6 QUIT
