Routine: IB20P818

IB20P818 ;MNTVBB/JWB - FIX FOR IB*2.0*808 BASE RATE FOR VETERAN; JAN 27, 2025@13:00

 ;;2.0;INTEGRATED BILLING;**818**;21-MAR-94;Build 2

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

PRE ; set up check points for pre/post-init

N %

 S %=$$NEWCP^XPDUTL("THRESH","THRESH^IB20P818")

 S %=$$NEWCP^XPDUTL("PRIOR","PRIOR^IB20P818")

THRESH ; Pension Threshold

 N IBA,IBERRM,IBRN,IBTYPE,IBX,DA,DIK,IBADLDEP

 S IBTYPE="Pension Threshold"

 D BMES^XPDUTL("Filing CY 2025 Pension Threshold rates.")

 S IBX=3241200 ;set IBX so that it will pick up all record on or after the new effective date

 F  S IBX=$O(^IBE(354.3,"B",IBX)) Q:'IBX  D  ; remove any records since 12/01/2022

 . S IBRN=0

 . F  S IBRN=$O(^IBE(354.3,"B",IBX,IBRN)) Q:'IBRN  D

 .. S DIK="^IBE(354.3,",DA=IBRN D ^DIK

 S IBA(354.3,"+1,",.01)=3241201 ; effective date for CY 2025 values

 S IBA(354.3,"+1,",.02)=1 ;     internal value 1 = BASIC PENSION

 S IBA(354.3,"+1,",.03)="16965" ;  base rate for veteran

 S IBA(354.3,"+1,",.04)="22216" ; 1 dependent

 S IBADLDEP="2902" ;  additional dependent amount

 F IBX=.05:.01:.11 S IBA(354.3,"+1,",IBX)=IBA(354.3,"+1,",IBX-.01)+IBADLDEP ;2 thru 8 dependents

 S IBA(354.3,"+1,",.12)=IBADLDEP  ;  additional dependent amount

 D UPDATE^DIE("","IBA","","IBERRM") ; file the new record for CY 2025

 I $D(IBERRM) D

 . D BMES^XPDUTL("Unable to file the new rates.  The error message is as follows:")

 . S IBRN=0

 . F  S IBRN=$O(IBERRM("DIERR",1,"TEXT",IBRN)) Q:IBRN=""  D MES^XPDUTL(IBERRM("DIERR",1,"TEXT",IBRN))

 . D BMES^XPDUTL("Please check the database and then file the new rates manually.")

 . D MMSG

 E  D COMPLETE

PRIOR ;This code sets up the variables and calls the routine to print or print-and-update the

 ;exemption status.  XPDQUES variables set in the pre-install are used.

 Q:'$D(^IBA(354.1,"APRIOR",3231201))  ; quit if the "APRIOR" x-ref is not set for 12/1/22.

 N %,IBACT,IBBMES,IBPR,IBPRDT,X,ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSK

 S IBACT=$G(XPDQUES("POS1")),IBACT=$S(IBACT="U":3,1:2)

 S ZTIO=$G(XPDQUES("POS2"))

 D NOW^%DTC S ZTDTH=%

 ; -- check to see if prior year thresholds used

 S IBPR=$P($G(^IBE(354.3,0)),"^",3) I IBPR="" Q

 S IBPR=$P(^IBE(354.3,IBPR,0),"^")

 S X=$S($E($P(IBPR,"^"),1,3)>296:1,1:2) S IBPRDT=$O(^IBE(354.3,"AIVDT",X,-($P(IBPR,"^")))) ;threshold prior to the one entered

 I IBPRDT<0 S IBPRDT=-IBPRDT ; invert negative number

 ; Queuing job.

 S IBBMES=$S(IBACT=3:"& UPDATE ",1:"") D BMES^XPDUTL(" >>>Queuing the PRINT "_IBBMES_"job to run NOW")

 S IO("Q")="",ZTRTN="DQ^IBARXET",ZTDESC="IB PRIOR YEAR THRESHOLD PRINT"_$S(IBACT=3:" AND UPDATE",1:""),ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q")

 S IBBMES=$S($D(ZTSK):"This job has been queued for NOW, as task number "_ZTSK_".",1:"This job could not be queued. Please edit the 12/1/22 threshold through the 'Add Income Thresholds' option, which allows you to queue this job.")

 D BMES^XPDUTL(" >>>"_IBBMES)

PRIORQ Q  ; end of prior exemptions section

MMSG ; MailMan message to report update problem to billing groups, patch installer and patch developer

 N DA,IBC,IBGROUP,IBPARAM,IBTXT,XMDUZ,XMSUB,XMTEXT,XMY

 S XMSUB="Integrated Billing Annual Rate Update Error"

 S XMDUZ=DUZ,XMTEXT="IBTXT"

 S IBPARAM("FROM")="PATCH IB*2.0*818 CY 2025 RATE UPDATE"

 F IBGROUP="IB EDI SUPERVISOR","IB ERROR","MCCR" D

 . I $D(^XMB(3.8,"B",IBGROUP)) S IBGROUP="G."_IBGROUP,XMY(IBGROUP)=""

 S XMY(DUZ)=""

 S IBC=0

 S IBC=IBC+1,IBTXT(IBC)="This message has been sent by patch IB*2.0*818. If you have received this"

 S IBC=IBC+1,IBTXT(IBC)="message, it indicates that the patch encountered some difficulty in filing"

 S IBC=IBC+1,IBTXT(IBC)="the CY 2025 "_IBTYPE_" rates as outlined in the patch description."

 S IBC=IBC+1,IBTXT(IBC)="Please verify the integrity of files 354.3 - BILLING THRESHOLDS and"

 S IBC=IBC+1,IBTXT(IBC)="then enter the new rates manually."

 S IBC=IBC+1,IBTXT(IBC)="You can consult the IB*2.0*818 patch description for additional information."

 S IBC=IBC+1,IBTXT(IBC)="  "

 S IBC=IBC+1,IBTXT(IBC)="This action only needs to be done by one person.  Please verify with the"

 S IBC=IBC+1,IBTXT(IBC)="appropriate billing supervisor that the update has been accomplished."

 D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.IBPARAM,"","")

MMSGQ Q  ; end of Mail Message subroutine

COMPLETE ; display message that step has completed successfully

 D BMES^XPDUTL("Step complete.")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P818   4471     printed  Mar 13, 2025@21:09:52                                                                                                                                                                                                    Page 2

IB20P818  ;MNTVBB/JWB - FIX FOR IB*2.0*808 BASE RATE FOR VETERAN; JAN 27, 2025@13:00

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

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

 +3       ;

 +4        QUIT

PRE       ; set up check points for pre/post-init

 +1        NEW %

 +2        SET %=$$NEWCP^XPDUTL("THRESH","THRESH^IB20P818")

 +3        SET %=$$NEWCP^XPDUTL("PRIOR","PRIOR^IB20P818")

 +4        QUIT

 +5       ;

THRESH    ; Pension Threshold

 +1        NEW IBA,IBERRM,IBRN,IBTYPE,IBX,DA,DIK,IBADLDEP

 +2        SET IBTYPE="Pension Threshold"

 +3        DO BMES^XPDUTL("Filing CY 2025 Pension Threshold rates.")

 +4       ;set IBX so that it will pick up all record on or after the new effective date

           SET IBX=3241200

 +5       ; remove any records since 12/01/2022

FOR

               SET IBX=$ORDER(^IBE(354.3,"B",IBX))

               if 'IBX

                   QUIT

               Begin DoDot:1

 +6                SET IBRN=0

 +7                FOR

                       SET IBRN=$ORDER(^IBE(354.3,"B",IBX,IBRN))

                       if 'IBRN

                           QUIT

                       Begin DoDot:2

 +8                        SET DIK="^IBE(354.3,"

                           SET DA=IBRN

                           DO ^DIK

                       End DoDot:2

               End DoDot:1

 +9       ; effective date for CY 2025 values

           SET IBA(354.3,"+1,",.01)=3241201

 +10      ;     internal value 1 = BASIC PENSION

           SET IBA(354.3,"+1,",.02)=1

 +11      ;  base rate for veteran

           SET IBA(354.3,"+1,",.03)="16965"

 +12      ; 1 dependent

           SET IBA(354.3,"+1,",.04)="22216"

 +13      ;  additional dependent amount

           SET IBADLDEP="2902"

 +14      ;2 thru 8 dependents

           FOR IBX=.05:.01:.11

               SET IBA(354.3,"+1,",IBX)=IBA(354.3,"+1,",IBX-.01)+IBADLDEP

 +15      ;  additional dependent amount

           SET IBA(354.3,"+1,",.12)=IBADLDEP

 +16      ; file the new record for CY 2025

           DO UPDATE^DIE("","IBA","","IBERRM")

 +17       IF $DATA(IBERRM)

               Begin DoDot:1

 +18               DO BMES^XPDUTL("Unable to file the new rates.  The error message is as follows:")

 +19               SET IBRN=0

 +20               FOR

                       SET IBRN=$ORDER(IBERRM("DIERR",1,"TEXT",IBRN))

                       if IBRN=""

                           QUIT

                       DO MES^XPDUTL(IBERRM("DIERR",1,"TEXT",IBRN))

 +21               DO BMES^XPDUTL("Please check the database and then file the new rates manually.")

 +22               DO MMSG

               End DoDot:1

 +23      IF '$TEST

               DO COMPLETE

 +24       QUIT

 +25      ;

PRIOR     ;This code sets up the variables and calls the routine to print or print-and-update the

 +1       ;exemption status.  XPDQUES variables set in the pre-install are used.

 +2       ;

 +3       ; quit if the "APRIOR" x-ref is not set for 12/1/22.

           if '$DATA(^IBA(354.1,"APRIOR",3231201))

               QUIT

 +4        NEW %,IBACT,IBBMES,IBPR,IBPRDT,X,ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSK

 +5        SET IBACT=$GET(XPDQUES("POS1"))

           SET IBACT=$SELECT(IBACT="U":3,1:2)

 +6        SET ZTIO=$GET(XPDQUES("POS2"))

 +7        DO NOW^%DTC

           SET ZTDTH=%

 +8       ;

 +9       ; -- check to see if prior year thresholds used

 +10      ;

 +11       SET IBPR=$PIECE($GET(^IBE(354.3,0)),"^",3)

           IF IBPR=""

               QUIT

 +12       SET IBPR=$PIECE(^IBE(354.3,IBPR,0),"^")

 +13      ;threshold prior to the one entered

           SET X=$SELECT($EXTRACT($PIECE(IBPR,"^"),1,3)>296:1,1:2)

           SET IBPRDT=$ORDER(^IBE(354.3,"AIVDT",X,-($PIECE(IBPR,"^"))))

 +14      ; invert negative number

           IF IBPRDT<0

               SET IBPRDT=-IBPRDT

 +15      ; Queuing job.

 +16       SET IBBMES=$SELECT(IBACT=3:"& UPDATE ",1:"")

           DO BMES^XPDUTL(" >>>Queuing the PRINT "_IBBMES_"job to run NOW")

 +17       SET IO("Q")=""

           SET ZTRTN="DQ^IBARXET"

           SET ZTDESC="IB PRIOR YEAR THRESHOLD PRINT"_$SELECT(IBACT=3:" AND UPDATE",1:"")

           SET ZTSAVE("IB*")=""

           DO ^%ZTLOAD

           KILL IO("Q")

 +18       SET IBBMES=$SELECT($DATA(ZTSK):"This job has been queued for NOW, as task number "_ZTSK_".",1:"This job could not be queued. Please edit the 12/1/22 threshold through the 'Add Income Thresholds' option, which allows you to queue this job.")

 +19       DO BMES^XPDUTL(" >>>"_IBBMES)

PRIORQ    ; end of prior exemptions section

           QUIT

 +1       ;

MMSG      ; MailMan message to report update problem to billing groups, patch installer and patch developer

 +1        NEW DA,IBC,IBGROUP,IBPARAM,IBTXT,XMDUZ,XMSUB,XMTEXT,XMY

 +2        SET XMSUB="Integrated Billing Annual Rate Update Error"

 +3        SET XMDUZ=DUZ

           SET XMTEXT="IBTXT"

 +4        SET IBPARAM("FROM")="PATCH IB*2.0*818 CY 2025 RATE UPDATE"

 +5        FOR IBGROUP="IB EDI SUPERVISOR","IB ERROR","MCCR"

               Begin DoDot:1

 +6                IF $DATA(^XMB(3.8,"B",IBGROUP))

                       SET IBGROUP="G."_IBGROUP

                       SET XMY(IBGROUP)=""

               End DoDot:1

 +7        SET XMY(DUZ)=""

 +8       ;

 +9        SET IBC=0

 +10       SET IBC=IBC+1

           SET IBTXT(IBC)="This message has been sent by patch IB*2.0*818. If you have received this"

 +11       SET IBC=IBC+1

           SET IBTXT(IBC)="message, it indicates that the patch encountered some difficulty in filing"

 +12       SET IBC=IBC+1

           SET IBTXT(IBC)="the CY 2025 "_IBTYPE_" rates as outlined in the patch description."

 +13       SET IBC=IBC+1

           SET IBTXT(IBC)="Please verify the integrity of files 354.3 - BILLING THRESHOLDS and"

 +14       SET IBC=IBC+1

           SET IBTXT(IBC)="then enter the new rates manually."

 +15       SET IBC=IBC+1

           SET IBTXT(IBC)="You can consult the IB*2.0*818 patch description for additional information."

 +16       SET IBC=IBC+1

           SET IBTXT(IBC)="  "

 +17       SET IBC=IBC+1

           SET IBTXT(IBC)="This action only needs to be done by one person.  Please verify with the"

 +18       SET IBC=IBC+1

           SET IBTXT(IBC)="appropriate billing supervisor that the update has been accomplished."

 +19       DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.IBPARAM,"","")

MMSGQ     ; end of Mail Message subroutine

           QUIT

 +1       ;

COMPLETE  ; display message that step has completed successfully

 +1        DO BMES^XPDUTL("Step complete.")

 +2        QUIT

 +3       ;

IB20P818.m