IB20P810 ;MNTVBB/RXD - UPDATE RX ADMINISTRATIVE FEE FOR CY 2025 ; 11/22/2024
;;2.0;INTEGRATED BILLING;**810**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
; Reference to MES^XPDUTL in ICR #10141
Q
EN ; Backup 363 RATE SCHEDULE File
N I810FILE,I810FILES,IBCNT
S I810FILE=""
S I810FILES="363"
S IBCNT=0
F IBCNT=1:1:$L(I810FILES,"^") D
. S I810FILE=$P(I810FILES,"^",IBCNT)
. D GLBBKUP
. Q
; Begin Update
D POST
Q
;
POST ; Update pharmacy administrative fee for CY 2025 in Rate Schedule file 363
N IBA,U S U="^"
D MSG("IB*2.0*810 Post-Install starts.....")
D RXUPD
D MSG("IB*2.0*810 Post-Install is complete.")
Q
;
RXUPD ; Rate Schedule
N IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
D MSG("")
D MSG(" >>>Effect. JAN 01, 2025 of RX Rate Schedule Adjustment for the Rate Type:"),MSG("")
S IBADFE="",IBEFFDT="3250101",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 file (#399.3), 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 file (#399.3), 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 entry for cy 2024 and add new rx entry for cy 2025
. 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 MSG("")
D MSG(" Total "_IBCT_$S(IBCT>1:" entries",1:" entry")_" added to the Rate Schedule file (#363)")
D MSG("")
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
;
GLBBKUP ; XTMP Backup of file(s)
N IBBKNDE
S IBBKNDE="IB*2.0*810-RATE SCHEDULE file updates (#363)"
S ^XTMP("IB810P",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^"_IBBKNDE
M ^XTMP("IB810P",I810FILE,$H)=^IBE(I810FILE)
Q
;
RSF ; 23 Rate types^dispensing fee^adjustment
;;CC MTF REIMB INS^15.61^S X=X+15.61
;;CC NO-FAULT AUTO^15.61^S X=X+15.61
;;CC REIMB INS^15.61^S X=X+15.61
;;CC TORT FEASOR^15.61^S X=X+15.61
;;CC WORKERS' COMP^15.61^S X=X+15.61
;;CCN NO-FAULT AUTO^15.61^S X=X+15.61
;;CCN REIMB INS^15.61^S X=X+15.61
;;CCN TORT FEASOR^15.61^S X=X+15.61
;;CCN WORKERS' COMP^15.61^S X=X+15.61
;;CHOICE NO-FAULT AUTO^15.61^S X=X+15.61
;;CHOICE REIMB INS^15.61^S X=X+15.61
;;CHOICE TORT FEASOR^15.61^S X=X+15.61
;;CHOICE WORKERS' COMP^15.61^S X=X+15.61
;;DENTAL REIMB. INS.^15.61^S X=X+15.61
;;HUMANITARIAN^15.61^S X=X+15.61
;;HUMANITARIAN REIMB. INS.^15.61^S X=X+15.61
;;INELIGIBLE^15.61^S X=X+15.61
;;INTERAGENCY^15.61^S X=X+15.61
;;INELIGIBLE REIMB. INS.^15.61^S X=X+15.61
;;NO FAULT INS.^15.61^S X=X+15.61
;;REIMBURSABLE INS.^15.61^S X=X+15.61
;;TORT FEASOR^15.61^S X=X+15.61
;;WORKERS' COMP.^15.61^S X=X+15.61
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P810 3420 printed Jan 29, 2026@15:03:45 Page 2
IB20P810 ;MNTVBB/RXD - UPDATE RX ADMINISTRATIVE FEE FOR CY 2025 ; 11/22/2024
+1 ;;2.0;INTEGRATED BILLING;**810**;21-MAR-94;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; Reference to MES^XPDUTL in ICR #10141
+4 QUIT
EN ; Backup 363 RATE SCHEDULE File
+1 NEW I810FILE,I810FILES,IBCNT
+2 SET I810FILE=""
+3 SET I810FILES="363"
+4 SET IBCNT=0
+5 FOR IBCNT=1:1:$LENGTH(I810FILES,"^")
Begin DoDot:1
+6 SET I810FILE=$PIECE(I810FILES,"^",IBCNT)
+7 DO GLBBKUP
+8 QUIT
End DoDot:1
+9 ; Begin Update
+10 DO POST
+11 QUIT
+12 ;
POST ; Update pharmacy administrative fee for CY 2025 in Rate Schedule file 363
+1 NEW IBA,U
SET U="^"
+2 DO MSG("IB*2.0*810 Post-Install starts.....")
+3 DO RXUPD
+4 DO MSG("IB*2.0*810 Post-Install is complete.")
+5 QUIT
+6 ;
RXUPD ; Rate Schedule
+1 NEW IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
+2 DO MSG("")
+3 DO MSG(" >>>Effect. JAN 01, 2025 of RX Rate Schedule Adjustment for the Rate Type:")
DO MSG("")
+4 SET IBADFE=""
SET IBEFFDT="3250101"
SET IBCT=0
+5 FOR IBX=1:1
SET IBT=$PIECE($TEXT(RSF+IBX),";;",2)
if IBT="Q"
QUIT
Begin DoDot:1
+6 SET IBRATY=$PIECE(IBT,U)
+7 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBRATY,0))
+8 IF 'IBRSIN
DO MSG(" "_IBRATY_" not defined in the Rate Type file (#399.3), not added")
QUIT
+9 ; latest entry
+10 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBRATY,99999),-1)
+11 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
DO MSG(" "_IBRATY_" inactivated in the Rate Type file (#399.3), not added")
QUIT
+12 IF $$RSEXIST(IBEFFDT,IBRSIN)
DO MSG(" "_IBRATY_" already exists")
QUIT
+13 SET IBDISP=$PIECE(IBT,U,2)
+14 SET IBADJUST=$PIECE(IBT,U,3)
+15 ; inactivate rx entry for cy 2024 and add new rx entry for cy 2025
+16 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
+17 ; double check if no active RS
+18 IF '$$RSEXIST(IBEFFDT,IBRSIN)
DO MSG(" "_IBRATY_" not added, no active RX Rate Schedule found")
QUIT
+19 SET IBCT=IBCT+1
DO MSG(" "_IBRATY)
End DoDot:1
+20 DO MSG("")
+21 DO MSG(" Total "_IBCT_$SELECT(IBCT>1:" entries",1:" entry")_" added to the Rate Schedule file (#363)")
+22 DO MSG("")
+23 QUIT
+24 ;
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
+3 ;
GLBBKUP ; XTMP Backup of file(s)
+1 NEW IBBKNDE
+2 SET IBBKNDE="IB*2.0*810-RATE SCHEDULE file updates (#363)"
+3 SET ^XTMP("IB810P",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^"_IBBKNDE
+4 MERGE ^XTMP("IB810P",I810FILE,$HOROLOG)=^IBE(I810FILE)
+5 QUIT
+6 ;
RSF ; 23 Rate types^dispensing fee^adjustment
+1 ;;CC MTF REIMB INS^15.61^S X=X+15.61
+2 ;;CC NO-FAULT AUTO^15.61^S X=X+15.61
+3 ;;CC REIMB INS^15.61^S X=X+15.61
+4 ;;CC TORT FEASOR^15.61^S X=X+15.61
+5 ;;CC WORKERS' COMP^15.61^S X=X+15.61
+6 ;;CCN NO-FAULT AUTO^15.61^S X=X+15.61
+7 ;;CCN REIMB INS^15.61^S X=X+15.61
+8 ;;CCN TORT FEASOR^15.61^S X=X+15.61
+9 ;;CCN WORKERS' COMP^15.61^S X=X+15.61
+10 ;;CHOICE NO-FAULT AUTO^15.61^S X=X+15.61
+11 ;;CHOICE REIMB INS^15.61^S X=X+15.61
+12 ;;CHOICE TORT FEASOR^15.61^S X=X+15.61
+13 ;;CHOICE WORKERS' COMP^15.61^S X=X+15.61
+14 ;;DENTAL REIMB. INS.^15.61^S X=X+15.61
+15 ;;HUMANITARIAN^15.61^S X=X+15.61
+16 ;;HUMANITARIAN REIMB. INS.^15.61^S X=X+15.61
+17 ;;INELIGIBLE^15.61^S X=X+15.61
+18 ;;INTERAGENCY^15.61^S X=X+15.61
+19 ;;INELIGIBLE REIMB. INS.^15.61^S X=X+15.61
+20 ;;NO FAULT INS.^15.61^S X=X+15.61
+21 ;;REIMBURSABLE INS.^15.61^S X=X+15.61
+22 ;;TORT FEASOR^15.61^S X=X+15.61
+23 ;;WORKERS' COMP.^15.61^S X=X+15.61
+24 ;;Q
+25 ;
