IBAUTL1.m

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

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