IBAUTL1 ;ALB/AAS - IB UTILITY ROUTINE FOR MEDICARE RATES ; 30-AUG-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
RATE ; - Calculates the Medicare rate for a CPT code.
; - Input X = visit date ^ division ^ ifn of cpt code
; - Output Y = charge
;
S IBX=X N X S X=IBX
S IBRG=$O(^IBE(350.4,"AIVDT",+$P(X,"^",3),-($P(X,"^")+1))) I IBRG S IBRG=$O(^(+IBRG,0)) ;determine current ib action type for code
I $S('IBRG:1,'$D(^IBE(350.4,+IBRG,0)):1,'$P(^(0),"^",3):1,1:0) S Y=-1 G RATEQ
S IBRG=+$P(^IBE(350.4,IBRG,0),"^",3)
S DA=$O(^IBE(350.2,"AIVDT",IBRG,-($P(X,"^")+1))) I DA S DA=$O(^(+DA,0)) ; determine current ib action charge for rate group
I $S('DA:1,'$D(^IBE(350.2,DA,10)):1,1:0) S Y=-1 G RATEQ
X ^IBE(350.2,DA,10)
RATEQ K IBRG,IBX
Q
;
VAR ; -Called by entries in 350.2 to get variables
; -input x=visit date^division ifn
; da=internal number from 350.2
; -output y=wage%^non-wage%^locality multiplier
;
S IBLOC=$O(^IBE(350.5,"AIVDT",+$P(X,"^",2),-($P(X,"^")+1))) I IBLOC S IBLOC=$O(^(+IBLOC,0))
I $S('IBLOC:1,'$D(^IBE(350.5,+IBLOC,0)):1,'$P(^(0),"^",7):1,1:0) S Y=-1 G VARQ
S Y=$P(^IBE(350.5,IBLOC,0),"^",5,7)
VARQ K IBLOC,IBWAG Q
;
TEST S DA=14,X=DT_"^1^10141" D RATE ;X ^IBE(350.2,DA,10) W X," ",Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL1 1337 printed Dec 13, 2024@02:08:03 Page 2
IBAUTL1 ;ALB/AAS - IB UTILITY ROUTINE FOR MEDICARE RATES ; 30-AUG-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
RATE ; - Calculates the Medicare rate for a CPT code.
+1 ; - Input X = visit date ^ division ^ ifn of cpt code
+2 ; - Output Y = charge
+3 ;
+4 SET IBX=X
NEW X
SET X=IBX
+5 ;determine current ib action type for code
SET IBRG=$ORDER(^IBE(350.4,"AIVDT",+$PIECE(X,"^",3),-($PIECE(X,"^")+1)))
IF IBRG
SET IBRG=$ORDER(^(+IBRG,0))
+6 IF $SELECT('IBRG:1,'$DATA(^IBE(350.4,+IBRG,0)):1,'$PIECE(^(0),"^",3):1,1:0)
SET Y=-1
GOTO RATEQ
+7 SET IBRG=+$PIECE(^IBE(350.4,IBRG,0),"^",3)
+8 ; determine current ib action charge for rate group
SET DA=$ORDER(^IBE(350.2,"AIVDT",IBRG,-($PIECE(X,"^")+1)))
IF DA
SET DA=$ORDER(^(+DA,0))
+9 IF $SELECT('DA:1,'$DATA(^IBE(350.2,DA,10)):1,1:0)
SET Y=-1
GOTO RATEQ
+10 XECUTE ^IBE(350.2,DA,10)
RATEQ KILL IBRG,IBX
+1 QUIT
+2 ;
VAR ; -Called by entries in 350.2 to get variables
+1 ; -input x=visit date^division ifn
+2 ; da=internal number from 350.2
+3 ; -output y=wage%^non-wage%^locality multiplier
+4 ;
+5 SET IBLOC=$ORDER(^IBE(350.5,"AIVDT",+$PIECE(X,"^",2),-($PIECE(X,"^")+1)))
IF IBLOC
SET IBLOC=$ORDER(^(+IBLOC,0))
+6 IF $SELECT('IBLOC:1,'$DATA(^IBE(350.5,+IBLOC,0)):1,'$PIECE(^(0),"^",7):1,1:0)
SET Y=-1
GOTO VARQ
+7 SET Y=$PIECE(^IBE(350.5,IBLOC,0),"^",5,7)
VARQ KILL IBLOC,IBWAG
QUIT
+1 ;
TEST ;X ^IBE(350.2,DA,10) W X," ",Y
SET DA=14
SET X=DT_"^1^10141"
DO RATE
