IB20P750 ;MNTVBB/RFS - UPDATE TRICARE RX ADMINISTRATIVE FEE FOR CY 2023 ; 11/01/2022@12:56
;;2.0;INTEGRATED BILLING;**750**;21-MAR-94;Build 2
;;Per VA Directive 6402, this routine should not be modified.
Q
POST ;
; Update TRICARE pharmacy administrative fee for CY 2023 in Rate Schedule (#363) file
N IBA,U S U="^"
D BMSG("IB*2.0*750 Post-Install starts.....")
D TRXAF
D BMSG("IB*2.0*750 Post-Install is complete.")
Q
;
TRXAF ; Rate Schedule
N IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
D BMSG(" >>>Effect. JAN 01, 2023 of RX Rate Schedule Adjustment for the Rate Type:")
S IBADFE="",IBEFFDT="3230101",IBCT=0
F IBX=1:1 S IBT=$P($T(RSF+IBX),";;",2) Q:IBT="Q" D
. S IBRATY=$P(IBT,U)
. S IBRSIN=$O(^DGCR(399.3,"B",IBRATY,0))
. I 'IBRSIN D MSG(" "_IBRATY_" not defined in the RATE TYPE (#399.3) file, not added") Q
. ; latest entry
. S IBRSIN=$O(^DGCR(399.3,"B",IBRATY,99999),-1)
. I $P($G(^DGCR(399.3,+IBRSIN,0)),U,3) D MSG(" "_IBRATY_" inactivated in the RATE TYPE (#399.3) file, not added") Q
. I $$RSEXIST(IBEFFDT,IBRSIN) D MSG(" "_IBRATY_" already exists") Q
. S IBDISP=$P(IBT,U,2)
. S IBADJUST=$P(IBT,U,3)
. ; inactivate rx RS for cy 2022 and add new rx RS for cy 2023
. D ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
. ; double check if no active RS
. I '$$RSEXIST(IBEFFDT,IBRSIN) D MSG(" "_IBRATY_" not added, no active RX Rate Schedule found") Q
. S IBCT=IBCT+1 D MSG(" "_IBRATY)
D BMSG(" Total "_IBCT_$S(IBCT>1:" entries",1:" entry")_" added to the RATE SCHEDULE (#363) file")
Q
;
RSEXIST(IBEFFDT,IBRSIN) ; return RS IFN if Rate Schedule exists for Effective Date
N IBX,IBRSFN,IBRS0 S IBX=0
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
. S IBRS0=$G(^IBE(363,IBRSFN,0))
. I $P(IBRS0,U,2)=IBRSIN,$P(IBRS0,U,5)=IBEFFDT S IBX=IBRSFN
Q IBX
;
MSG(IBA) ;
D MES^XPDUTL(IBA)
Q
BMSG(IBA) ;
D BMES^XPDUTL(IBA)
Q
;
RSF ; 3 Rate types^dispensing fee^adjustment
;;TRICARE^11.77^S X=X+11.77
;;TRICARE PHARMACY^11.77^S X=X+11.77
;;TRICARE REIMB. INS.^11.77^S X=X+11.77
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P750 2155 printed Sep 23, 2025@19:40:55 Page 2
IB20P750 ;MNTVBB/RFS - UPDATE TRICARE RX ADMINISTRATIVE FEE FOR CY 2023 ; 11/01/2022@12:56
+1 ;;2.0;INTEGRATED BILLING;**750**;21-MAR-94;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
POST ;
+1 ; Update TRICARE pharmacy administrative fee for CY 2023 in Rate Schedule (#363) file
+2 NEW IBA,U
SET U="^"
+3 DO BMSG("IB*2.0*750 Post-Install starts.....")
+4 DO TRXAF
+5 DO BMSG("IB*2.0*750 Post-Install is complete.")
+6 QUIT
+7 ;
TRXAF ; Rate Schedule
+1 NEW IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
+2 DO BMSG(" >>>Effect. JAN 01, 2023 of RX Rate Schedule Adjustment for the Rate Type:")
+3 SET IBADFE=""
SET IBEFFDT="3230101"
SET IBCT=0
+4 FOR IBX=1:1
SET IBT=$PIECE($TEXT(RSF+IBX),";;",2)
if IBT="Q"
QUIT
Begin DoDot:1
+5 SET IBRATY=$PIECE(IBT,U)
+6 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBRATY,0))
+7 IF 'IBRSIN
DO MSG(" "_IBRATY_" not defined in the RATE TYPE (#399.3) file, not added")
QUIT
+8 ; latest entry
+9 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBRATY,99999),-1)
+10 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
DO MSG(" "_IBRATY_" inactivated in the RATE TYPE (#399.3) file, not added")
QUIT
+11 IF $$RSEXIST(IBEFFDT,IBRSIN)
DO MSG(" "_IBRATY_" already exists")
QUIT
+12 SET IBDISP=$PIECE(IBT,U,2)
+13 SET IBADJUST=$PIECE(IBT,U,3)
+14 ; inactivate rx RS for cy 2022 and add new rx RS for cy 2023
+15 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
+16 ; double check if no active RS
+17 IF '$$RSEXIST(IBEFFDT,IBRSIN)
DO MSG(" "_IBRATY_" not added, no active RX Rate Schedule found")
QUIT
+18 SET IBCT=IBCT+1
DO MSG(" "_IBRATY)
End DoDot:1
+19 DO BMSG(" Total "_IBCT_$SELECT(IBCT>1:" entries",1:" entry")_" added to the RATE SCHEDULE (#363) file")
+20 QUIT
+21 ;
RSEXIST(IBEFFDT,IBRSIN) ; return RS IFN if Rate Schedule exists for Effective Date
+1 NEW IBX,IBRSFN,IBRS0
SET IBX=0
+2 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+3 SET IBRS0=$GET(^IBE(363,IBRSFN,0))
+4 IF $PIECE(IBRS0,U,2)=IBRSIN
IF $PIECE(IBRS0,U,5)=IBEFFDT
SET IBX=IBRSFN
End DoDot:1
IF IBX
QUIT
+5 QUIT IBX
+6 ;
MSG(IBA) ;
+1 DO MES^XPDUTL(IBA)
+2 QUIT
BMSG(IBA) ;
+1 DO BMES^XPDUTL(IBA)
+2 QUIT
+3 ;
RSF ; 3 Rate types^dispensing fee^adjustment
+1 ;;TRICARE^11.77^S X=X+11.77
+2 ;;TRICARE PHARMACY^11.77^S X=X+11.77
+3 ;;TRICARE REIMB. INS.^11.77^S X=X+11.77
+4 ;;Q
+5 ;
