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 Nov 22, 2024@17:28:51 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
