source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IB20P295.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.3 KB
Line 
1IB20P295 ;ISP/TJH - POST-INIT FOR IB*2.0*295; 12/15/2004
2 ;;2.0;INTEGRATED BILLING;**295**;21-MAR-94
3 ;
4PRE ; set up check points for pre/post-init
5 N %
6 S %=$$NEWCP^XPDUTL("THRESH","THRESH^IB20P295")
7 S %=$$NEWCP^XPDUTL("MCRDED","MCRDED^IB20P295")
8 S %=$$NEWCP^XPDUTL("PRIOR","PRIOR^IB20P295")
9 Q
10 ;
11THRESH ; Pension Threshold
12 N IBA,IBERRM,IBRN,IBTYPE,IBX,DA,DIK
13 S IBTYPE="Pension Threshold"
14 D BMES^XPDUTL("Filing CY 2005 Pension Threshold rates.")
15 S IBX=3031201
16 F S IBX=$O(^IBE(354.3,"B",IBX)) Q:'IBX D ; remove any records since 12/01/2003
17 . S IBRN=0
18 . F S IBRN=$O(^IBE(354.3,"B",IBX,IBRN)) Q:'IBRN D
19 .. S DIK="^IBE(354.3,",DA=IBRN D ^DIK
20 S IBA(354.3,"+1,",.01)=3041201 ; effective date for CY 2005 values
21 S IBA(354.3,"+1,",.02)=1 ; internal value 1 = BASIC PENSION
22 S IBA(354.3,"+1,",.03)=10162 ; base rate for veteran
23 S IBA(354.3,"+1,",.04)=13309 ; 1 dependent
24 S IBA(354.3,"+1,",.05)=15043 ; 2 dependents
25 S IBA(354.3,"+1,",.06)=16777 ; 3 dependents
26 S IBA(354.3,"+1,",.07)=18511 ; 4 dependents
27 S IBA(354.3,"+1,",.08)=20245 ; 5 dependents
28 S IBA(354.3,"+1,",.09)=21979 ; 6 dependents
29 S IBA(354.3,"+1,",.10)=23713 ; 7 dependents
30 S IBA(354.3,"+1,",.11)=25447 ; 8 dependents
31 S IBA(354.3,"+1,",.12)=1734 ; additional dependent amount
32 D UPDATE^DIE("","IBA","","IBERRM") ; file the new record for CY 2005
33 I $D(IBERRM) D
34 . D BMES^XPDUTL("Unable to file the new rates. The error message is as follows:")
35 . S IBRN=0
36 . F S IBRN=$O(IBERRM("DIERR",1,"TEXT",IBRN)) Q:IBRN="" D MES^XPDUTL(IBERRM("DIERR",1,"TEXT",IBRN))
37 . D BMES^XPDUTL("Please check the database and then file the new rates manually.")
38 . D MMSG
39 E D COMPLETE
40 Q
41 ;
42MCRDED ; Medicare deductible rate for CY 2005
43 ; check to see if rate already entered.
44 N IBA,IBERRM,IBIEN,IBRN,IBTYPE,DA,DIK
45 S IBTYPE="Medicare Deductible"
46 D BMES^XPDUTL("Filing Medicare Deductible Rate for 01/01/2005")
47 S IBIEN=0
48 F S IBIEN=$O(^IBE(350.2,"B","MEDICARE DEDUCTIBLE",IBIEN)) Q:'IBIEN D
49 . Q:$P($G(^IBE(350.2,IBIEN,0)),"^",2)'>3040101
50 . S DIK="^IBE(350.2,",DA=IBIEN D ^DIK
51 S IBA(350.2,"+1,",.01)="MEDICARE DEDUCTIBLE"
52 S IBA(350.2,"+1,",.02)=3050101
53 S IBA(350.2,"+1,",.03)=$O(^IBE(350.1,"B","MEDICARE DEDUCTIBLE",""))
54 S IBA(350.2,"+1,",.04)=912
55 D UPDATE^DIE("","IBA","","IBERRM") ; file the new record
56 I $D(IBERRM) D
57 . D BMES^XPDUTL("Unable to file the new rates. The error message is as follows:")
58 . S IBRN=0
59 . F S IBRN=$O(IBERRM("DIERR",1,"TEXT",IBRN)) Q:IBRN="" D MES^XPDUTL(IBERRM("DIERR",1,"TEXT",IBRN))
60 . D BMES^XPDUTL("Please check the database and then file the new rates manually.")
61 . D MMSG
62 E D COMPLETE
63MCRX Q
64 ;
65PRIOR ;This code sets up the variables and calls the routine to print or print-and-update the
66 ;exemption status. XPDQUES variables set in the pre-install are used.
67 ;
68 Q:'$D(^IBA(354.1,"APRIOR",3031201)) ; quit if the "APRIOR" x-ref is not set for 12/1/03.
69 N %,IBACT,IBBMES,IBPR,IBPRDT,X,ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSK
70 S IBACT=$G(XPDQUES("POS1")),IBACT=$S(IBACT="U":3,1:2)
71 S ZTIO=$G(XPDQUES("POS2"))
72 D NOW^%DTC S ZTDTH=%
73 ;
74 ; -- check to see if prior year thresholds used
75 ;
76 S IBPR=$P($G(^IBE(354.3,0)),"^",3) I IBPR="" Q
77 S IBPR=$P(^IBE(354.3,IBPR,0),"^")
78 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
79 I IBPRDT<0 S IBPRDT=-IBPRDT ; invert negative number
80 ; Queuing job.
81 S IBBMES=$S(IBACT=3:"& UPDATE ",1:"") D BMES^XPDUTL(" >>>Queuing the PRINT "_IBBMES_"job to run NOW")
82 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")
83 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/04 threshold through the 'Add Income Thresholds' option, which allows you to queue this job.")
84 D BMES^XPDUTL(" >>>"_IBBMES)
85PRIORQ Q ; end of prior exemptions section
86 ;
87MMSG ; MailMan message to report update problem to billing groups, patch installer and patch developer
88 N DA,IBC,IBGROUP,IBPARAM,IBTXT,XMDUZ,XMSUB,XMTEXT,XMY
89 S XMSUB="Integrated Billing Annual Rate Update Error"
90 S XMDUZ=DUZ,XMTEXT="IBTXT"
91 S IBPARAM("FROM")="PATCH IB*2.0*295 CY 2004 RATE UPDATE"
92 F IBGROUP="IB EDI SUPERVISOR","IB ERROR","MCCR" D
93 . I $D(^XMB(3.8,"B",IBGROUP)) S IBGROUP="G."_IBGROUP,XMY(IBGROUP)=""
94 S XMY(DUZ)="",XMY("HOLLOWAY.THOMAS_J@FORUM.VA.GOV")=""
95 ;
96 S IBC=0
97 S IBC=IBC+1,IBTXT(IBC)="This message has been sent by patch IB*2.0*295. If you have received this"
98 S IBC=IBC+1,IBTXT(IBC)="message, it indicates that the patch encountered some difficulty in filing"
99 S IBC=IBC+1,IBTXT(IBC)="the CY 2005 "_IBTYPE_" rates as outlined in the patch description."
100 S IBC=IBC+1,IBTXT(IBC)="Please verify the integrity of files 354.3 - BILLING THRESHOLDS and"
101 S IBC=IBC+1,IBTXT(IBC)="350.2 - IB ACTION CHARGE and then enter the new rates manually."
102 S IBC=IBC+1,IBTXT(IBC)="You can consult the IB*2.0*295 patch description for additional information."
103 S IBC=IBC+1,IBTXT(IBC)=" "
104 S IBC=IBC+1,IBTXT(IBC)="This action only needs to be done by one person. Please verify with the"
105 S IBC=IBC+1,IBTXT(IBC)="appropriate billing supervisor that the update has been accomplished."
106 D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.IBPARAM,"","")
107MMSGQ Q ; end of Mail Message subroutine
108 ;
109COMPLETE ; display message that step has completed successfully
110 D BMES^XPDUTL("Step complete.")
111 Q
112 ;
Note: See TracBrowser for help on using the repository browser.