IB20P810.m

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 ---IB20P810   3420     printed  Apr 23, 2025@18:19:33                                                                                                                                                                                                    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      ;