IBATCM ;LL/ELZ - TRANSFER PRICING TRANSACTION CHARGES ; 02-MAR-1999
;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
TOTAL(IBIEN) ; -- recalculate total and set
N IBT,IBD,IBTL S IBTL=0
S IBT=$P(^IBAT(351.61,IBIEN,0),"^",12)
I IBT["DGPM(" D Q
. S IBD=^IBAT(351.61,IBIEN,1)
. S IBTL=$P(IBD,"^",5)*$P(IBD,"^",6)+$P(IBD,"^",2)
. D SETTL(IBTL)
I IBT["SCE(" D Q
. N IBX S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 D
.. S IBD=^IBAT(351.61,IBIEN,3,IBX,0)
.. S IBTL=$P(IBD,"^",2)*$P(IBD,"^",3)+IBTL
. D SETTL(IBTL)
I IBT["RMPR(660," D SETTL($P($G(^IBAT(351.61,IBIEN,4)),"^",5)) Q
S IBD=^IBAT(351.61,IBIEN,4)
S IBTL=$P(IBD,"^",2)*$P(IBD,"^",3)
D SETTL(IBTL)
Q
SETTL(X) ; -- files total
N DIE,DR,DA Q:X<.01
S DIE="^IBAT(351.61,",DA=IBIEN,DR="6.02///"_$FN(X,"",2)_";.05////P"
D ^DIE
Q
INPT(DRG,DATE,FAC) ; -- returns inpatient rates
;
Q $$RATE("TP INPATIENT",DRG,DATE,$G(FAC))
;
OPT(CPT,DATE,FAC) ; -- returns outpatient rates
;
Q $$RATE("TP OUTPATIENT",CPT,DATE,FAC)
;
RATE(BR,ITEM,DATE,FAC) ; -- returns rates for BR from charge master
; CHARGE=1!0^default rate^nego rate^rate to use
; if FAC undefined, send back default
N IBCHARGE,IBFAC
;
; look up negotiated rates if exist
I $G(FAC) F IBFAC=FAC,+$$VISN^IBATUTL(FAC) S $P(IBCHARGE,"^",2)=+$$ITCHG^IBCRCI($$TPCS^IBCRU7(BR,IBFAC),ITEM,DATE) Q:$P(IBCHARGE,"^",2)
;
; find default adjust by .8 and round
S $P(IBCHARGE,"^")=$FN((+$$ITCHG^IBCRCI($$TPCS^IBCRU7(BR),ITEM,DATE))*.8,"",2)
;
; set rate to use
S $P(IBCHARGE,"^",3)=$S($P(IBCHARGE,"^",2):$P(IBCHARGE,"^",2),1:+IBCHARGE)
;
Q $S($P(IBCHARGE,"^",3):"1^",1:"0^")_IBCHARGE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATCM 1739 printed Nov 22, 2024@17:17:48 Page 2
IBATCM ;LL/ELZ - TRANSFER PRICING TRANSACTION CHARGES ; 02-MAR-1999
+1 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
TOTAL(IBIEN) ; -- recalculate total and set
+1 NEW IBT,IBD,IBTL
SET IBTL=0
+2 SET IBT=$PIECE(^IBAT(351.61,IBIEN,0),"^",12)
+3 IF IBT["DGPM("
Begin DoDot:1
+4 SET IBD=^IBAT(351.61,IBIEN,1)
+5 SET IBTL=$PIECE(IBD,"^",5)*$PIECE(IBD,"^",6)+$PIECE(IBD,"^",2)
+6 DO SETTL(IBTL)
End DoDot:1
QUIT
+7 IF IBT["SCE("
Begin DoDot:1
+8 NEW IBX
SET IBX=0
FOR
SET IBX=$ORDER(^IBAT(351.61,IBIEN,3,IBX))
if IBX<1
QUIT
Begin DoDot:2
+9 SET IBD=^IBAT(351.61,IBIEN,3,IBX,0)
+10 SET IBTL=$PIECE(IBD,"^",2)*$PIECE(IBD,"^",3)+IBTL
End DoDot:2
+11 DO SETTL(IBTL)
End DoDot:1
QUIT
+12 IF IBT["RMPR(660,"
DO SETTL($PIECE($GET(^IBAT(351.61,IBIEN,4)),"^",5))
QUIT
+13 SET IBD=^IBAT(351.61,IBIEN,4)
+14 SET IBTL=$PIECE(IBD,"^",2)*$PIECE(IBD,"^",3)
+15 DO SETTL(IBTL)
+16 QUIT
SETTL(X) ; -- files total
+1 NEW DIE,DR,DA
if X<.01
QUIT
+2 SET DIE="^IBAT(351.61,"
SET DA=IBIEN
SET DR="6.02///"_$FNUMBER(X,"",2)_";.05////P"
+3 DO ^DIE
+4 QUIT
INPT(DRG,DATE,FAC) ; -- returns inpatient rates
+1 ;
+2 QUIT $$RATE("TP INPATIENT",DRG,DATE,$GET(FAC))
+3 ;
OPT(CPT,DATE,FAC) ; -- returns outpatient rates
+1 ;
+2 QUIT $$RATE("TP OUTPATIENT",CPT,DATE,FAC)
+3 ;
RATE(BR,ITEM,DATE,FAC) ; -- returns rates for BR from charge master
+1 ; CHARGE=1!0^default rate^nego rate^rate to use
+2 ; if FAC undefined, send back default
+3 NEW IBCHARGE,IBFAC
+4 ;
+5 ; look up negotiated rates if exist
+6 IF $GET(FAC)
FOR IBFAC=FAC,+$$VISN^IBATUTL(FAC)
SET $PIECE(IBCHARGE,"^",2)=+$$ITCHG^IBCRCI($$TPCS^IBCRU7(BR,IBFAC),ITEM,DATE)
if $PIECE(IBCHARGE,"^",2)
QUIT
+7 ;
+8 ; find default adjust by .8 and round
+9 SET $PIECE(IBCHARGE,"^")=$FNUMBER((+$$ITCHG^IBCRCI($$TPCS^IBCRU7(BR),ITEM,DATE))*.8,"",2)
+10 ;
+11 ; set rate to use
+12 SET $PIECE(IBCHARGE,"^",3)=$SELECT($PIECE(IBCHARGE,"^",2):$PIECE(IBCHARGE,"^",2),1:+IBCHARGE)
+13 ;
+14 QUIT $SELECT($PIECE(IBCHARGE,"^",3):"1^",1:"0^")_IBCHARGE
+15 ;
