IB20P620 ;MNT/BJR - POST-INIT FOR IB*2.0*620 ;Mar 8,2018@8:29am
;;2.0;INTEGRATED BILLING;**620**;21-MAR-94;Build 1
;;Per VA Directive 6402, this routine should not be modified.
;
Q
THRESH ; Pension Threshold
N IBA,IBERRM,IBRN,IBTYPE,IBX,DA,DIK,IBADLDEP
S IBTYPE="Pension Threshold"
D BMES^XPDUTL("Filing CY 2017 Pension Threshold rates.")
I $D(^IBE(354.3,"B",3161201)) D ; remove 12/01/2016 if exists befre filing
. S IBRN=0
. F S IBRN=$O(^IBE(354.3,"B",3161201,IBRN)) Q:'IBRN D
.. S DIK="^IBE(354.3,",DA=IBRN D ^DIK
S IBA(354.3,"+1,",.01)=3161201 ; effective date for CY 2017 values
S IBA(354.3,"+1,",.02)=1 ; internal value 1 = BASIC PENSION
S IBA(354.3,"+1,",.03)=12907 ; base rate for veteran
S IBA(354.3,"+1,",.04)=16902 ; 1 dependent
S IBADLDEP=2205 ; 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 2017
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
Q
;
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*620 CY 2017 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*620. 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 2017 "_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)="350.2 - IB ACTION CHARGE and then enter the new rates manually."
S IBC=IBC+1,IBTXT(IBC)="You can consult the IB*2.0*620 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.")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P620 2886 printed Dec 13, 2024@02:04:09 Page 2
IB20P620 ;MNT/BJR - POST-INIT FOR IB*2.0*620 ;Mar 8,2018@8:29am
+1 ;;2.0;INTEGRATED BILLING;**620**;21-MAR-94;Build 1
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
THRESH ; Pension Threshold
+1 NEW IBA,IBERRM,IBRN,IBTYPE,IBX,DA,DIK,IBADLDEP
+2 SET IBTYPE="Pension Threshold"
+3 DO BMES^XPDUTL("Filing CY 2017 Pension Threshold rates.")
+4 ; remove 12/01/2016 if exists befre filing
IF $DATA(^IBE(354.3,"B",3161201))
Begin DoDot:1
+5 SET IBRN=0
+6 FOR
SET IBRN=$ORDER(^IBE(354.3,"B",3161201,IBRN))
if 'IBRN
QUIT
Begin DoDot:2
+7 SET DIK="^IBE(354.3,"
SET DA=IBRN
DO ^DIK
End DoDot:2
End DoDot:1
+8 ; effective date for CY 2017 values
SET IBA(354.3,"+1,",.01)=3161201
+9 ; internal value 1 = BASIC PENSION
SET IBA(354.3,"+1,",.02)=1
+10 ; base rate for veteran
SET IBA(354.3,"+1,",.03)=12907
+11 ; 1 dependent
SET IBA(354.3,"+1,",.04)=16902
+12 ; additional dependent amount
SET IBADLDEP=2205
+13 ;2 thru 8 dependents
FOR IBX=.05:.01:.11
SET IBA(354.3,"+1,",IBX)=IBA(354.3,"+1,",IBX-.01)+IBADLDEP
+14 ; additional dependent amount
SET IBA(354.3,"+1,",.12)=IBADLDEP
+15 ; file the new record for CY 2017
DO UPDATE^DIE("","IBA","","IBERRM")
+16 IF $DATA(IBERRM)
Begin DoDot:1
+17 DO BMES^XPDUTL("Unable to file the new rates. The error message is as follows:")
+18 SET IBRN=0
+19 FOR
SET IBRN=$ORDER(IBERRM("DIERR",1,"TEXT",IBRN))
if IBRN=""
QUIT
DO MES^XPDUTL(IBERRM("DIERR",1,"TEXT",IBRN))
+20 DO BMES^XPDUTL("Please check the database and then file the new rates manually.")
+21 DO MMSG
End DoDot:1
+22 IF '$TEST
DO COMPLETE
+23 QUIT
+24 ;
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*620 CY 2017 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*620. 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 2017 "_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)="350.2 - IB ACTION CHARGE and then enter the new rates manually."
+15 SET IBC=IBC+1
SET IBTXT(IBC)="You can consult the IB*2.0*620 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 ;
