IB20P754.m

IB20P754 ;MNTVBB/RFS - UPDATE RX ADMINISTRATIVE FEE FOR CY 2023 ; 11/15/2022

 ;;2.0;INTEGRATED BILLING;**754**;21-MAR-94;Build 1

 ;;Per VA Directive 6402, this routine should not be modified.

 ; Reference to MES^XPDUTL in ICR #10141

 Q

POST ; Update pharmacy administrative fee for CY 2023 in Rate Schedule file 363

 N IBA,U S U="^"

 D MSG("IB*2.0*754 Post-Install starts.....")

 D RXUPD

 D MSG("IB*2.0*754 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, 2023 of RX Rate Schedule Adjustment for the Rate Type:"),MSG("")

 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 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 2022 and add new rx entry 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 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

 ;

RSF ; 23 Rate types^dispensing fee^adjustment

 ;;CC MTF REIMB INS^14.95^S X=X+14.95

 ;;CC NO-FAULT AUTO^14.95^S X=X+14.95

 ;;CC REIMB INS^14.95^S X=X+14.95

 ;;CC TORT FEASOR^14.95^S X=X+14.95

 ;;CC WORKERS' COMP^14.95^S X=X+14.95

 ;;CCN NO-FAULT AUTO^14.95^S X=X+14.95

 ;;CCN REIMB INS^14.95^S X=X+14.95

 ;;CCN TORT FEASOR^14.95^S X=X+14.95

 ;;CCN WORKERS' COMP^14.95^S X=X+14.95

 ;;CHOICE NO-FAULT AUTO^14.95^S X=X+14.95

 ;;CHOICE REIMB INS^14.95^S X=X+14.95

 ;;CHOICE TORT FEASOR^14.95^S X=X+14.95

 ;;CHOICE WORKERS' COMP^14.95^S X=X+14.95

 ;;DENTAL REIMB. INS.^14.95^S X=X+14.95

 ;;HUMANITARIAN^14.95^S X=X+14.95

 ;;HUMANITARIAN REIMB. INS.^14.95^S X=X+14.95

 ;;INELIGIBLE^14.95^S X=X+14.95

 ;;INTERAGENCY^14.95^S X=X+14.95

 ;;INELIGIBLE REIMB. INS.^14.95^S X=X+14.95

 ;;NO FAULT INS.^14.95^S X=X+14.95

 ;;REIMBURSABLE INS.^14.95^S X=X+14.95

 ;;TORT FEASOR^14.95^S X=X+14.95

 ;;WORKERS' COMP.^14.95^S X=X+14.95

 ;;Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P754   2956     printed  Mar 13, 2025@21:09:37                                                                                                                                                                                                    Page 2

IB20P754  ;MNTVBB/RFS - UPDATE RX ADMINISTRATIVE FEE FOR CY 2023 ; 11/15/2022

 +1       ;;2.0;INTEGRATED BILLING;**754**;21-MAR-94;Build 1

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ; Reference to MES^XPDUTL in ICR #10141

 +4        QUIT 

POST      ; Update pharmacy administrative fee for CY 2023 in Rate Schedule file 363

 +1        NEW IBA,U

           SET U="^"

 +2        DO MSG("IB*2.0*754 Post-Install starts.....")

 +3        DO RXUPD

 +4        DO MSG("IB*2.0*754 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, 2023 of RX Rate Schedule Adjustment for the Rate Type:")

           DO MSG("")

 +4        SET IBADFE=""

           SET IBEFFDT="3230101"

           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 2022 and add new rx entry for cy 2023

 +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       ;

RSF       ; 23 Rate types^dispensing fee^adjustment

 +1       ;;CC MTF REIMB INS^14.95^S X=X+14.95

 +2       ;;CC NO-FAULT AUTO^14.95^S X=X+14.95

 +3       ;;CC REIMB INS^14.95^S X=X+14.95

 +4       ;;CC TORT FEASOR^14.95^S X=X+14.95

 +5       ;;CC WORKERS' COMP^14.95^S X=X+14.95

 +6       ;;CCN NO-FAULT AUTO^14.95^S X=X+14.95

 +7       ;;CCN REIMB INS^14.95^S X=X+14.95

 +8       ;;CCN TORT FEASOR^14.95^S X=X+14.95

 +9       ;;CCN WORKERS' COMP^14.95^S X=X+14.95

 +10      ;;CHOICE NO-FAULT AUTO^14.95^S X=X+14.95

 +11      ;;CHOICE REIMB INS^14.95^S X=X+14.95

 +12      ;;CHOICE TORT FEASOR^14.95^S X=X+14.95

 +13      ;;CHOICE WORKERS' COMP^14.95^S X=X+14.95

 +14      ;;DENTAL REIMB. INS.^14.95^S X=X+14.95

 +15      ;;HUMANITARIAN^14.95^S X=X+14.95

 +16      ;;HUMANITARIAN REIMB. INS.^14.95^S X=X+14.95

 +17      ;;INELIGIBLE^14.95^S X=X+14.95

 +18      ;;INTERAGENCY^14.95^S X=X+14.95

 +19      ;;INELIGIBLE REIMB. INS.^14.95^S X=X+14.95

 +20      ;;NO FAULT INS.^14.95^S X=X+14.95

 +21      ;;REIMBURSABLE INS.^14.95^S X=X+14.95

 +22      ;;TORT FEASOR^14.95^S X=X+14.95

 +23      ;;WORKERS' COMP.^14.95^S X=X+14.95

 +24      ;;Q

 +25      ;