IB20P661 ;DEV/BJR - POST-INIT FOR IB*2.0*661 ;10/17/2019 10:39am
;;2.0;INTEGRATED BILLING;**661**;21-MAR-94;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;
Q
PRE ; set up check points for pre/post-init
N %
S %=$$NEWCP^XPDUTL("THRESH","THRESH^IB20P661")
S %=$$NEWCP^XPDUTL("MCRDED","MCRDED^IB20P661")
S %=$$NEWCP^XPDUTL("PRIOR","PRIOR^IB20P661")
Q
;
THRESH ; Pension Threshold
N IBA,IBERRM,IBRN,IBTYPE,IBX,DA,DIK,IBADLDEP
S IBTYPE="Pension Threshold"
D BMES^XPDUTL("Filing CY 2020 Pension Threshold rates.")
S IBX=3191200 ;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/2019
. 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)=3191201 ; effective date for CY 2020 values
S IBA(354.3,"+1,",.02)=1 ; internal value 1 = BASIC PENSION
S IBA(354.3,"+1,",.03)="13752" ; base rate for veteran
S IBA(354.3,"+1,",.04)="18008" ; 1 dependent
S IBADLDEP="2351" ; 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 2020
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
;
MCRDED ; Medicare deductible rate for CY 2020
; check to see if rate already entered.
N IBA,IBERRM,IBIEN,IBRN,IBTYPE,DA,DIK
S IBTYPE="Medicare Deductible"
D BMES^XPDUTL("Filing Medicare Deductible Rate for 01/01/2020")
S IBIEN=0
F S IBIEN=$O(^IBE(350.2,"B","MEDICARE DEDUCTIBLE",IBIEN)) Q:'IBIEN D
. Q:$P($G(^IBE(350.2,IBIEN,0)),"^",2)'>3190101
. S DIK="^IBE(350.2,",DA=IBIEN D ^DIK
S IBA(350.2,"+1,",.01)="MEDICARE DEDUCTIBLE"
S IBA(350.2,"+1,",.02)=3200101
S IBA(350.2,"+1,",.03)=$O(^IBE(350.1,"B","MEDICARE DEDUCTIBLE",""))
S IBA(350.2,"+1,",.04)="1408"
D UPDATE^DIE("","IBA","","IBERRM") ; file the new record
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
MCRX Q
;
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",3171201)) ; quit if the "APRIOR" x-ref is not set for 12/1/17.
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/19 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*661 CY 2020 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*661. 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 2020 "_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*661 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[HIB20P661 5515 printed Dec 13, 2024@02:04:22 Page 2
IB20P661 ;DEV/BJR - POST-INIT FOR IB*2.0*661 ;10/17/2019 10:39am
+1 ;;2.0;INTEGRATED BILLING;**661**;21-MAR-94;Build 7
+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^IB20P661")
+3 SET %=$$NEWCP^XPDUTL("MCRDED","MCRDED^IB20P661")
+4 SET %=$$NEWCP^XPDUTL("PRIOR","PRIOR^IB20P661")
+5 QUIT
+6 ;
THRESH ; Pension Threshold
+1 NEW IBA,IBERRM,IBRN,IBTYPE,IBX,DA,DIK,IBADLDEP
+2 SET IBTYPE="Pension Threshold"
+3 DO BMES^XPDUTL("Filing CY 2020 Pension Threshold rates.")
+4 ;set IBX so that it will pick up all record on or after the new effective date
SET IBX=3191200
+5 ; remove any records since 12/01/2019
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 2020 values
SET IBA(354.3,"+1,",.01)=3191201
+10 ; internal value 1 = BASIC PENSION
SET IBA(354.3,"+1,",.02)=1
+11 ; base rate for veteran
SET IBA(354.3,"+1,",.03)="13752"
+12 ; 1 dependent
SET IBA(354.3,"+1,",.04)="18008"
+13 ; additional dependent amount
SET IBADLDEP="2351"
+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 2020
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 ;
MCRDED ; Medicare deductible rate for CY 2020
+1 ; check to see if rate already entered.
+2 NEW IBA,IBERRM,IBIEN,IBRN,IBTYPE,DA,DIK
+3 SET IBTYPE="Medicare Deductible"
+4 DO BMES^XPDUTL("Filing Medicare Deductible Rate for 01/01/2020")
+5 SET IBIEN=0
+6 FOR
SET IBIEN=$ORDER(^IBE(350.2,"B","MEDICARE DEDUCTIBLE",IBIEN))
if 'IBIEN
QUIT
Begin DoDot:1
+7 if $PIECE($GET(^IBE(350.2,IBIEN,0)),"^",2)'>3190101
QUIT
+8 SET DIK="^IBE(350.2,"
SET DA=IBIEN
DO ^DIK
End DoDot:1
+9 SET IBA(350.2,"+1,",.01)="MEDICARE DEDUCTIBLE"
+10 SET IBA(350.2,"+1,",.02)=3200101
+11 SET IBA(350.2,"+1,",.03)=$ORDER(^IBE(350.1,"B","MEDICARE DEDUCTIBLE",""))
+12 SET IBA(350.2,"+1,",.04)="1408"
+13 ; file the new record
DO UPDATE^DIE("","IBA","","IBERRM")
+14 IF $DATA(IBERRM)
Begin DoDot:1
+15 DO BMES^XPDUTL("Unable to file the new rates. The error message is as follows:")
+16 SET IBRN=0
+17 FOR
SET IBRN=$ORDER(IBERRM("DIERR",1,"TEXT",IBRN))
if IBRN=""
QUIT
DO MES^XPDUTL(IBERRM("DIERR",1,"TEXT",IBRN))
+18 DO BMES^XPDUTL("Please check the database and then file the new rates manually.")
+19 DO MMSG
End DoDot:1
+20 IF '$TEST
DO COMPLETE
MCRX QUIT
+1 ;
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/17.
if '$DATA(^IBA(354.1,"APRIOR",3171201))
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/19 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*661 CY 2020 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*661. 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 2020 "_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*661 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 ;
