Summary Table
Categories |
Total Count |
PII |
0 |
URL |
0 |
DNS |
0 |
EKL |
0 |
IP |
0 |
PORT |
0 |
VsID |
0 |
CF |
0 |
AI |
0 |
VPD |
0 |
PL |
0 |
Other |
0 |
File Content
KIDS Distribution saved on Feb 15, 2019@12:02:52
ACA BUILD CVA AND SB
**KIDS**:CPEACA*1.0*001^
**INSTALL NAME**
CPEACA*1.0*001
"BLD",9826,0)
CPEACA*1.0*001^^0^3190215^n
"BLD",9826,1,0)
^^219^219^3190215^
"BLD",9826,1,1,0)
Subject: CP&E CPEACA*1.0*001
"BLD",9826,1,2,0)
"BLD",9826,1,3,0)
"BLD",9826,1,4,0)
Category:
"BLD",9826,1,5,0)
- Data Dictionary
"BLD",9826,1,6,0)
- Enhancement
"BLD",9826,1,7,0)
"BLD",9826,1,8,0)
"BLD",9826,1,9,0)
Description:
"BLD",9826,1,10,0)
============
"BLD",9826,1,11,0)
"BLD",9826,1,12,0)
The Veterans Health Administration Office of Community Care (VHA OCC)
"BLD",9826,1,13,0)
in Denver, Colo., manages the Spina Bifida (SB) and CHAMPVA (CVA) and
"BLD",9826,1,14,0)
Health Care Benefits Program, including authorization of benefits and the
"BLD",9826,1,15,0)
subsequent processing and payment of health care claims after a
"BLD",9826,1,16,0)
determination of eligibility has been made by the Denver VA Regional
"BLD",9826,1,17,0)
Office (VARO).
"BLD",9826,1,18,0)
"BLD",9826,1,19,0)
This patch supports the following user stories:
"BLD",9826,1,20,0)
"BLD",9826,1,21,0)
* Create SB enrollment statuses ENROLLED, DISENROLLED, RE-ENROLLED,
"BLD",9826,1,22,0)
and DECEASED.
"BLD",9826,1,23,0)
* Create SB enrollment Start Date(s)and End Date(s).
"BLD",9826,1,24,0)
* Display the current SB Enrollment Period and status.
"BLD",9826,1,25,0)
* Display historical SB Enrollment Period(s) and status(es).
"BLD",9826,1,26,0)
* Create the ability to disenroll a family member from the SB Program.
"BLD",9826,1,27,0)
* Create the ability to re-enroll a family member from the SB Program.
"BLD",9826,1,28,0)
* Create new CVA Re-enrollment.
"BLD",9826,1,29,0)
* Update CVA Disenrollment to work with new Re-enrollment.
"BLD",9826,1,30,0)
* Create new CVA True Period of Eligibility (TPOE).
"BLD",9826,1,31,0)
* End CVA family member's period of eligibility to discontinue claim
"BLD",9826,1,32,0)
payments, as part of CVA TPOE.
"BLD",9826,1,33,0)
* Maintain history of CVA disenrollment notifications.
"BLD",9826,1,34,0)
"BLD",9826,1,35,0)
"BLD",9826,1,36,0)
Patch Components:
"BLD",9826,1,37,0)
-----------------
"BLD",9826,1,38,0)
Files & Fields Associated:
"BLD",9826,1,39,0)
"BLD",9826,1,40,0)
File Name (Number) Field Name (Number) New/Modified/Deleted
"BLD",9826,1,41,0)
------------------------ ------------------- --------------------
"BLD",9826,1,42,0)
CHAMPVA BENEFICIARY (#554801) SB - STATUS (10.12) New
"BLD",9826,1,43,0)
"BLD",9826,1,44,0)
BENEFICIARY NAME SUB-FILE SB - STATUS (11.01) New
"BLD",9826,1,45,0)
(#554801.01)
"BLD",9826,1,46,0)
"BLD",9826,1,47,0)
BENEFICIARY NAME SUB-FILE SB - STATUS (11.01) New
"BLD",9826,1,48,0)
(#554801.03)
"BLD",9826,1,49,0)
SB - STATUS DATE (11.02) New
"BLD",9826,1,50,0)
SB - INELIGIBLE REASON (11.03) New
"BLD",9826,1,51,0)
SB - ELIGIBLE REASON (11.04) New
"BLD",9826,1,52,0)
SB - INELIG REASON DOC (11.05) New
"BLD",9826,1,53,0)
SB - ELIG REASON DOC (11.06) New
"BLD",9826,1,54,0)
"BLD",9826,1,55,0)
"BLD",9826,1,56,0)
Routine Information:
"BLD",9826,1,57,0)
----------------------------
"BLD",9826,1,58,0)
Routine Summary
"BLD",9826,1,59,0)
Checksums shown are NEW Checksums
"BLD",9826,1,60,0)
The following routines are included in this patch. The second line of
"BLD",9826,1,61,0)
each of these routines now looks like:
"BLD",9826,1,62,0)
;;1.0;CHAMPVA SYSTEM;**[Patch List]**;JULY 4, 1990;Build 1
"BLD",9826,1,63,0)
"BLD",9826,1,64,0)
Checksums
"BLD",9826,1,65,0)
Routine Old New Patch List
"BLD",9826,1,66,0)
CHFCD017 n/a 2044913 **1**
"BLD",9826,1,67,0)
CHMEAD6 n/a 41032175 **1**
"BLD",9826,1,68,0)
CHMEAE81 n/a 231789217 **10,1**
"BLD",9826,1,69,0)
CHMEAE8U n/a 455962457 **1**
"BLD",9826,1,70,0)
CHMEAE9 n/a 190241743 **1**
"BLD",9826,1,71,0)
CHMEAM n/a 14578573 **1**
"BLD",9826,1,72,0)
CHMEAM12 n/a 30444083 **1**
"BLD",9826,1,73,0)
CHMEAMB n/a 135578521 **1**
"BLD",9826,1,74,0)
CHMEAMB1 n/a 4668902 **1**
"BLD",9826,1,75,0)
CHMEAV52 n/a 12402550 **1**
"BLD",9826,1,76,0)
CHMEAV6 n/a 24700216 **1**
"BLD",9826,1,77,0)
CHMEAV62 n/a 28557424 **7,1**
"BLD",9826,1,78,0)
CHMEAV9 n/a 44160865 **7,1**
"BLD",9826,1,79,0)
CHMEAV91 n/a 53174414 **7,1**
"BLD",9826,1,80,0)
CHMEAV92 n/a 40714342 **1**
"BLD",9826,1,81,0)
CHSBE001 n/a 4990340 **10,1**
"BLD",9826,1,82,0)
CHSBE005 n/a 7474587 **1**
"BLD",9826,1,83,0)
CHSBE050 n/a 42096645 **1**
"BLD",9826,1,84,0)
CHSBE062 n/a 31249615 **1**
"BLD",9826,1,85,0)
CHSBE068 n/a 30778027 **1**
"BLD",9826,1,86,0)
CHSBE070 n/a 6202990 **1**
"BLD",9826,1,87,0)
CHSBE100 n/a 133057221 **1**
"BLD",9826,1,88,0)
CHSBE111 n/a 70867179 **1**
"BLD",9826,1,89,0)
CHSBE120 n/a 15880710 **1**
"BLD",9826,1,90,0)
CHSBEU01 n/a 15678828 **1**
"BLD",9826,1,91,0)
CHTDISEN n/a 46077789 **1**
"BLD",9826,1,92,0)
"BLD",9826,1,93,0)
List of preceding patches: 7, 10
"BLD",9826,1,94,0)
Sites should use CHECK1^XTSUMBLD to verify checksums.
"BLD",9826,1,95,0)
"BLD",9826,1,96,0)
"BLD",9826,1,97,0)
User Stories:
"BLD",9826,1,98,0)
----------------------------
"BLD",9826,1,99,0)
ACA_Disenrollment_US001 - Create SB Enrollment Periods and statuses
"BLD",9826,1,100,0)
ACA_Disenrollment_US002 - Display current SB Enrollment Period and
"BLD",9826,1,101,0)
status
"BLD",9826,1,102,0)
ACA_Disenrollment_US003 - Display historical SB Enrollment Period(s)
"BLD",9826,1,103,0)
and status(es)
"BLD",9826,1,104,0)
ACA_Disenrollment_US004 - CHAMPVA Disenrollment
"BLD",9826,1,105,0)
ACA_Disenrollment_US005 - End CVA True Period of Eligiblity (TPOE)
"BLD",9826,1,106,0)
ACA_Disenrollment_US007 - Maintain history of CHAMPVA disenrollment
"BLD",9826,1,107,0)
notifications
"BLD",9826,1,108,0)
ACA_Disenrollment_US010 - SB Disenrollment
"BLD",9826,1,109,0)
ACA_Disenrollment_US016 - CVA Re-enrollment
"BLD",9826,1,110,0)
ACA_Disenrollment_US017 - Create new CVA True Period of Eligiblity (TPOE)
"BLD",9826,1,111,0)
ACA_Disenrollment_US022 - SB Re-enrollment
"BLD",9826,1,112,0)
DEFECT_855699 - ACA Disenrollment Display issue on Enrollment Hist screen
"BLD",9826,1,113,0)
DEFECT_855725 - ACA Disenrollment System allows Award letter date of
"BLD",9826,1,114,0)
"0/0/2018"
"BLD",9826,1,115,0)
DEFECT_857352 - ACA SB Sponsor screen error at "^" prompt
"BLD",9826,1,116,0)
DEFECT_857207 - ACA Error - <UNDEFINED>GLSET+50^CHSBE100 *CHRDOCDT
"BLD",9826,1,117,0)
DEFECT_797518 - ACA Disenrollment Date must be greater than the last
"BLD",9826,1,118,0)
Re-Enrollment Date
"BLD",9826,1,119,0)
"BLD",9826,1,120,0)
"BLD",9826,1,121,0)
Test Environment:
"BLD",9826,1,122,0)
-----------
"BLD",9826,1,123,0)
TBD
"BLD",9826,1,124,0)
"BLD",9826,1,125,0)
"BLD",9826,1,126,0)
Software and Documentation Retrieval Instructions:
"BLD",9826,1,127,0)
-------------------------------------
"BLD",9826,1,128,0)
The software is distributed in a Host file generated from the
"BLD",9826,1,129,0)
Development Environment. Documentation describing new
"BLD",9826,1,130,0)
functionality introduced by this patch is available from the
"BLD",9826,1,131,0)
developer.
"BLD",9826,1,132,0)
"BLD",9826,1,133,0)
Title File Name FTP Mode
"BLD",9826,1,134,0)
------------------------------------------------------------------------
"BLD",9826,1,135,0)
KIDS Host file: HAC_HFS$:[DSMMANAG.CHAMPVA]CPEACA_1_0_001_V01.KID ASCII
"BLD",9826,1,136,0)
"BLD",9826,1,137,0)
"BLD",9826,1,138,0)
Deployment/Installation Rollback/Backout Guide
"BLD",9826,1,139,0)
------------------------------
"BLD",9826,1,140,0)
It is recommended when installing the KIDS package that the installer
"BLD",9826,1,141,0)
choose option #5 in step 2b. of the below Installation Instructions.
"BLD",9826,1,142,0)
If a rollback/backout is needed, the prior version of the routines
"BLD",9826,1,143,0)
can be re-installed using the backup packman message created in
"BLD",9826,1,144,0)
step 2b. However, please notify the development team if a
"BLD",9826,1,145,0)
rollback/backout of this patch is desired. Because this patch contains
"BLD",9826,1,146,0)
Data Dictionary changes, the development team will need to provide
"BLD",9826,1,147,0)
steps to backout the file changes of this patch, if necessary.
"BLD",9826,1,148,0)
"BLD",9826,1,149,0)
"BLD",9826,1,150,0)
Patch Installation:
"BLD",9826,1,151,0)
"BLD",9826,1,152,0)
Pre/Post Installation Overview
"BLD",9826,1,153,0)
------------------------------
"BLD",9826,1,154,0)
"BLD",9826,1,155,0)
There is no Pre installation routine processes.
"BLD",9826,1,156,0)
"BLD",9826,1,157,0)
"BLD",9826,1,158,0)
Pre-Installation Instructions
"BLD",9826,1,159,0)
-----------------------------
"BLD",9826,1,160,0)
This patch may be installed with users on the system although it is
"BLD",9826,1,161,0)
recommended that it be installed during non-peak hours to minimize
"BLD",9826,1,162,0)
potential disruption to users. This patch should take less than
"BLD",9826,1,163,0)
5 minutes to install.
"BLD",9826,1,164,0)
"BLD",9826,1,165,0)
"BLD",9826,1,166,0)
Installation Instructions
"BLD",9826,1,167,0)
-------------------------
"BLD",9826,1,168,0)
1. Load a Distribution
"BLD",9826,1,169,0)
From the Kernel Installation & Distribution System menu, select
"BLD",9826,1,170,0)
the Installation menu. From this menu, select the option Load a
"BLD",9826,1,171,0)
distribution and select
"BLD",9826,1,172,0)
HAC_HFS$:[DSMMANAG.CHAMPVA]CPEACA_1_0_001_V01.KID
"BLD",9826,1,173,0)
"BLD",9826,1,174,0)
2. Use INSTALL NAME: CPEACA*1.0*001 to install this Distribution.
"BLD",9826,1,175,0)
The following are optional.
"BLD",9826,1,176,0)
"BLD",9826,1,177,0)
a. Option #4: Compare Transport Global to Current System
"BLD",9826,1,178,0)
This option will allow you to view all changes that will be
"BLD",9826,1,179,0)
made when this patch is installed. It compares all
"BLD",9826,1,180,0)
components of this patch (routines, DD's, templates, etc.).
"BLD",9826,1,181,0)
b. Option #5: Backup a Transport Global.
"BLD",9826,1,182,0)
As part of the Deployment/Installation Rollback/Backout
"BLD",9826,1,183,0)
Guide it is recommended when installing the KIDS package
"BLD",9826,1,184,0)
that the installer choose option #5 to create a backup Packman
"BLD",9826,1,185,0)
message:
"BLD",9826,1,186,0)
"BLD",9826,1,187,0)
Select Installation <TEST ACCOUNT> Option: 5 Backup a Transport Global
"BLD",9826,1,188,0)
Select INSTALL NAME: CPEACA*1.0*001
"BLD",9826,1,189,0)
=> CPEACA*1.0*001
"BLD",9826,1,190,0)
"BLD",9826,1,191,0)
This Distribution was loaded on Aug 2, 2018@15:41:25 with header of
"BLD",9826,1,192,0)
CPEACA*1.0*001
"BLD",9826,1,193,0)
It consisted of the following Install(s):
"BLD",9826,1,194,0)
CPEACA*1.0*001
"BLD",9826,1,195,0)
Subject: Backup of CPEACA*1.0*001 install on Aug 2, 2018
"BLD",9826,1,196,0)
Replace
"BLD",9826,1,197,0)
"BLD",9826,1,198,0)
Send mail to: NAME,INSTALLER//
"BLD",9826,1,199,0)
"BLD",9826,1,200,0)
3. From the Installation Menu, select the Install Package(s) option and
"BLD",9826,1,201,0)
choose the patch to install. Enter CPEACA*1.0*001.
"BLD",9826,1,202,0)
"BLD",9826,1,203,0)
4. When prompted 'Want KIDS to Rebuild Menu Trees Upon Completion of
"BLD",9826,1,204,0)
Install? NO//', respond NO.
"BLD",9826,1,205,0)
"BLD",9826,1,206,0)
5. When prompted 'Want KIDS to INHIBIT LOGONs during the install? NO//',
"BLD",9826,1,207,0)
respond NO.
"BLD",9826,1,208,0)
"BLD",9826,1,209,0)
6. When prompted 'Want to DISABLE Scheduled Options, Menu Options, and
"BLD",9826,1,210,0)
Protocols? NO//', respond NO.
"BLD",9826,1,211,0)
"BLD",9826,1,212,0)
7. If prompted 'Delay Install (Minutes): (0 - 60): 0//', respond 0.
"BLD",9826,1,213,0)
"BLD",9826,1,214,0)
"BLD",9826,1,215,0)
Post-Installation Instructions
"BLD",9826,1,216,0)
------------------------------
"BLD",9826,1,217,0)
There is no Post installation routine processes.
"BLD",9826,1,218,0)
"BLD",9826,1,219,0)
====================
"BLD",9826,4,0)
^9.64PA^554801^1
"BLD",9826,4,554801,0)
554801
"BLD",9826,4,554801,2,0)
^9.641^554801.03^3
"BLD",9826,4,554801,2,554801,0)
CHAMPVA BENEFICIARY (File-top level)
"BLD",9826,4,554801,2,554801,1,0)
^9.6411^10.12^1
"BLD",9826,4,554801,2,554801,1,10.12,0)
SB - STATUS
"BLD",9826,4,554801,2,554801.01,0)
100 (sub-file)
"BLD",9826,4,554801,2,554801.01,1,0)
^9.6411^11.01^1
"BLD",9826,4,554801,2,554801.01,1,11.01,0)
SB - STATUS
"BLD",9826,4,554801,2,554801.03,0)
BENEFICIARY HISTORY (sub-file)
"BLD",9826,4,554801,2,554801.03,1,0)
^9.6411^11.06^6
"BLD",9826,4,554801,2,554801.03,1,11.01,0)
SB - STATUS
"BLD",9826,4,554801,2,554801.03,1,11.02,0)
SB - STATUS DATE
"BLD",9826,4,554801,2,554801.03,1,11.03,0)
SB - INELIGIBLE REASON
"BLD",9826,4,554801,2,554801.03,1,11.04,0)
SB - ELIGIBLE REASON
"BLD",9826,4,554801,2,554801.03,1,11.05,0)
SB - INELIG REASON DOC
"BLD",9826,4,554801,2,554801.03,1,11.06,0)
SB - ELIG REASON DOC
"BLD",9826,4,554801,222)
y^n^p^^^^n^^n
"BLD",9826,4,554801,224)
"BLD",9826,4,"APDD",554801,554801)
"BLD",9826,4,"APDD",554801,554801,10.12)
"BLD",9826,4,"APDD",554801,554801.01)
"BLD",9826,4,"APDD",554801,554801.01,11.01)
"BLD",9826,4,"APDD",554801,554801.03)
"BLD",9826,4,"APDD",554801,554801.03,11.01)
"BLD",9826,4,"APDD",554801,554801.03,11.02)
"BLD",9826,4,"APDD",554801,554801.03,11.03)
"BLD",9826,4,"APDD",554801,554801.03,11.04)
"BLD",9826,4,"APDD",554801,554801.03,11.05)
"BLD",9826,4,"APDD",554801,554801.03,11.06)
"BLD",9826,4,"B",554801,554801)
"BLD",9826,6.3)
4
"BLD",9826,"KRN",0)
^9.67PA^779.2^20
"BLD",9826,"KRN",.4,0)
.4
"BLD",9826,"KRN",.401,0)
.401
"BLD",9826,"KRN",.402,0)
.402
"BLD",9826,"KRN",.403,0)
.403
"BLD",9826,"KRN",.5,0)
.5
"BLD",9826,"KRN",.84,0)
.84
"BLD",9826,"KRN",3.6,0)
3.6
"BLD",9826,"KRN",3.8,0)
3.8
"BLD",9826,"KRN",9.2,0)
9.2
"BLD",9826,"KRN",9.8,0)
9.8
"BLD",9826,"KRN",9.8,"NM",0)
^9.68A^27^26
"BLD",9826,"KRN",9.8,"NM",1,0)
CHMEAE81^^0^B231789217
"BLD",9826,"KRN",9.8,"NM",2,0)
CHMEAE9^^0^B189081791
"BLD",9826,"KRN",9.8,"NM",3,0)
CHMEAM^^0^B14578573
"BLD",9826,"KRN",9.8,"NM",4,0)
CHMEAMB^^0^B135578521
"BLD",9826,"KRN",9.8,"NM",5,0)
CHMEAMB1^^0^B4668902
"BLD",9826,"KRN",9.8,"NM",6,0)
CHMEAV9^^0^B44160865
"BLD",9826,"KRN",9.8,"NM",7,0)
CHMEAV91^^0^B53174414
"BLD",9826,"KRN",9.8,"NM",8,0)
CHMEAV92^^0^B40714342
"BLD",9826,"KRN",9.8,"NM",9,0)
CHFCD017^^0^B2044913
"BLD",9826,"KRN",9.8,"NM",10,0)
CHSBE005^^0^B7474587
"BLD",9826,"KRN",9.8,"NM",11,0)
CHSBE050^^0^B42096645
"BLD",9826,"KRN",9.8,"NM",12,0)
CHSBE100^^0^B133057221
"BLD",9826,"KRN",9.8,"NM",13,0)
CHSBEU01^^0^B15678828
"BLD",9826,"KRN",9.8,"NM",14,0)
CHSBE070^^0^B6202990
"BLD",9826,"KRN",9.8,"NM",15,0)
CHSBE120^^0^B15880710
"BLD",9826,"KRN",9.8,"NM",16,0)
CHSBE062^^0^B31249615
"BLD",9826,"KRN",9.8,"NM",18,0)
CHSBE111^^0^B70867179
"BLD",9826,"KRN",9.8,"NM",19,0)
CHSBE068^^0^B30778027
"BLD",9826,"KRN",9.8,"NM",20,0)
CHSBE001^^0^B4990340
"BLD",9826,"KRN",9.8,"NM",21,0)
CHTDISEN^^0^B3299
"BLD",9826,"KRN",9.8,"NM",22,0)
CHMEAV52^^0^B12402550
"BLD",9826,"KRN",9.8,"NM",23,0)
CHMEAE8U^^0^B455962457
"BLD",9826,"KRN",9.8,"NM",24,0)
CHMEAD6^^0^B41032175
"BLD",9826,"KRN",9.8,"NM",25,0)
CHMEAM12^^0^B30444083
"BLD",9826,"KRN",9.8,"NM",26,0)
CHMEAV6^^0^B24700216
"BLD",9826,"KRN",9.8,"NM",27,0)
CHMEAV62^^0^B28557424
"BLD",9826,"KRN",9.8,"NM","B","CHFCD017",9)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAD6",24)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAE81",1)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAE8U",23)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAE9",2)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAM",3)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAM12",25)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAMB",4)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAMB1",5)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAV52",22)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAV6",26)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAV62",27)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAV9",6)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAV91",7)
"BLD",9826,"KRN",9.8,"NM","B","CHMEAV92",8)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE001",20)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE005",10)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE050",11)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE062",16)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE068",19)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE070",14)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE100",12)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE111",18)
"BLD",9826,"KRN",9.8,"NM","B","CHSBE120",15)
"BLD",9826,"KRN",9.8,"NM","B","CHSBEU01",13)
"BLD",9826,"KRN",9.8,"NM","B","CHTDISEN",21)
"BLD",9826,"KRN",19,0)
19
"BLD",9826,"KRN",19,"NM",0)
^9.68A^^
"BLD",9826,"KRN",19.1,0)
19.1
"BLD",9826,"KRN",101,0)
101
"BLD",9826,"KRN",409.61,0)
409.61
"BLD",9826,"KRN",771,0)
771
"BLD",9826,"KRN",779.2,0)
779.2
"BLD",9826,"KRN",870,0)
870
"BLD",9826,"KRN",8989.51,0)
8989.51
"BLD",9826,"KRN",8989.52,0)
8989.52
"BLD",9826,"KRN",8994,0)
8994
"BLD",9826,"KRN","B",.4,.4)
"BLD",9826,"KRN","B",.401,.401)
"BLD",9826,"KRN","B",.402,.402)
"BLD",9826,"KRN","B",.403,.403)
"BLD",9826,"KRN","B",.5,.5)
"BLD",9826,"KRN","B",.84,.84)
"BLD",9826,"KRN","B",3.6,3.6)
"BLD",9826,"KRN","B",3.8,3.8)
"BLD",9826,"KRN","B",9.2,9.2)
"BLD",9826,"KRN","B",9.8,9.8)
"BLD",9826,"KRN","B",19,19)
"BLD",9826,"KRN","B",19.1,19.1)
"BLD",9826,"KRN","B",101,101)
"BLD",9826,"KRN","B",409.61,409.61)
"BLD",9826,"KRN","B",771,771)
"BLD",9826,"KRN","B",779.2,779.2)
"BLD",9826,"KRN","B",870,870)
"BLD",9826,"KRN","B",8989.51,8989.51)
"BLD",9826,"KRN","B",8989.52,8989.52)
"BLD",9826,"KRN","B",8994,8994)
"BLD",9826,"QUES",0)
^9.62^^
"BLD",9826,"REQB",0)
^9.611^^
"FIA",554801)
CHAMPVA BENEFICIARY
"FIA",554801,0)
^AHCHVA(
"FIA",554801,0,0)
554801I
"FIA",554801,0,1)
y^n^p^^^^n^^n
"FIA",554801,0,10)
"FIA",554801,0,11)
"FIA",554801,0,"RLRO")
"FIA",554801,554801)
1
"FIA",554801,554801,10.12)
"FIA",554801,554801.01)
1
"FIA",554801,554801.01,11.01)
"FIA",554801,554801.03)
1
"FIA",554801,554801.03,11.01)
"FIA",554801,554801.03,11.02)
"FIA",554801,554801.03,11.03)
"FIA",554801,554801.03,11.04)
"FIA",554801,554801.03,11.05)
"FIA",554801,554801.03,11.06)
"MBREQ")
0
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")
"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
26
"RTN","CHFCD017")
0^9^B2044913
"RTN","CHFCD017",1,0)
CHFCD017 ;CVA/JLR;REJ OF SB CLAIMS FOR DOS<BEGIN DATE;Jan 08, 2019@09:21:31
"RTN","CHFCD017",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHFCD017",3,0)
;;DEV023457 JAK 11-05-2015 ACA: DISENROLLMENT
"RTN","CHFCD017",4,0)
Q:'$D(@(GLPAY_"X1,0)"))
"RTN","CHFCD017",5,0)
S CLMDOS=$P(^(0),"^",8)
"RTN","CHFCD017",6,0)
S DFN=$P(^(0),"^",21)
"RTN","CHFCD017",7,0)
S BFN=$P(^(0),"^",22)
"RTN","CHFCD017",8,0)
Q:'DFN Q:'BFN
"RTN","CHFCD017",9,0)
D DOSCHK ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",10,0)
D ENRCHK ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",11,0)
D END ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",12,0)
Q
"RTN","CHFCD017",13,0)
DOSCHK ;
"RTN","CHFCD017",14,0)
S CHKDOS=""
"RTN","CHFCD017",15,0)
S:$D(@(GLELG_"DFN,100,BFN,15)")) CHKDOS=$P(^(15),"^",2)
"RTN","CHFCD017",16,0)
D:CHKDOS="" REJECT
"RTN","CHFCD017",17,0)
Q:CLMDOS=""
"RTN","CHFCD017",18,0)
D:CLMDOS<CHKDOS REJECT
"RTN","CHFCD017",19,0)
ENRCHK ;
"RTN","CHFCD017",20,0)
;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",21,0)
S ENRSTAT=""
"RTN","CHFCD017",22,0)
;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",23,0)
S:$D(@(GLELG_"DFN,100,BFN,11)")) ENRSTAT=$P(@(GLELG_"DFN,100,BFN,11)"),"^",1) ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",24,0)
I ENRSTAT = "DIS" D ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",25,0)
.D REJECT ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",26,0)
END K CLMDOS,CHKDOS ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",27,0)
K ENRSTAT ;DEV023457 JAK 11-05-2015
"RTN","CHFCD017",28,0)
Q
"RTN","CHFCD017",29,0)
REJECT ;
"RTN","CHFCD017",30,0)
S REAS=$P(^CHMDIC(741002.34,1,1),"^",11) S CHREJ=X1,CHGRP="OTH"
"RTN","CHFCD017",31,0)
D ^CHMFREJ S CHMFQ(CL)=1,CHMFREJ(CL)="" S CHINHCL=X1 D ^CHMG280
"RTN","CHFCD017",32,0)
Q
"RTN","CHMEAD6")
0^24^B41032175
"RTN","CHMEAD6",1,0)
CHMEAD6 ;CSW/DEN;DUMP DEERS,VBA,STUDENT,LETTER,ID CARD INFO;Jan 08, 2019@09:22:31
"RTN","CHMEAD6",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAD6",3,0)
D:'$D(CHOICE) HEADER I $D(CHOICE) S $Y=4
"RTN","CHMEAD6",4,0)
W !!,"Date Of DEERS Tape",?40,"Status"
"RTN","CHMEAD6",5,0)
W !,"------------------",?40,"-----------"
"RTN","CHMEAD6",6,0)
S (K,CT)=0
"RTN","CHMEAD6",7,0)
DEERS S K=$O(^AHCHVA(I,100,J,101,K)) G CMPUS:'K,DEERS:'$D(^(K,0))
"RTN","CHMEAD6",8,0)
S DA=^(0),X=$P($P(DA,U),".") D:X'="" DTPRT S Y1=Y S:X="" Y1=X
"RTN","CHMEAD6",9,0)
S X=$P(DA,U,2),Y2=$S(X="S":"SENT",X="A":"ACCEPTED",X="R":"REJECTED",X="SD":"SENT-DELETE",1:X)
"RTN","CHMEAD6",10,0)
S CT=1 W !,Y1,?40,Y2
"RTN","CHMEAD6",11,0)
I ($D(CHOICE)),($Y>15) D G END:$D(DUOUT)
"RTN","CHMEAD6",12,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",13,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",14,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",15,0)
G DEERS
"RTN","CHMEAD6",16,0)
CMPUS W:'CT !,"Beneficiary has never been on a DEERS Tape..."
"RTN","CHMEAD6",17,0)
I '$D(CHOICE) D HEADER:$Y>50
"RTN","CHMEAD6",18,0)
I ($D(CHOICE)),($Y>10) D G END:$D(DUOUT)
"RTN","CHMEAD6",19,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",20,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",21,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",22,0)
W !!!,"TRICARE Begin Date",?40,"TRICARE End Date" ;TLH 12/10/07 DEV002915 CHG CHAMPUS TO TRICARE
"RTN","CHMEAD6",23,0)
W !,"------------------",?40,"----------------"
"RTN","CHMEAD6",24,0)
S (K,CT)=0
"RTN","CHMEAD6",25,0)
C1 S K=$O(^AHCHVA(I,100,J,102,K)) G VBA:'K,C1:'$D(^(K,0))
"RTN","CHMEAD6",26,0)
S DA=^(0),X=$P($P(DA,U),".") D:X'="" DTPRT S Y1=Y S:X="" Y1=X
"RTN","CHMEAD6",27,0)
S X=$P($P(DA,U,2),".") D:X'="" DTPRT S Y2=Y S:X="" Y2=X
"RTN","CHMEAD6",28,0)
S CT=1 W !,Y1,?40,Y2
"RTN","CHMEAD6",29,0)
I ($D(CHOICE)),($Y>15) D G END:$D(DUOUT)
"RTN","CHMEAD6",30,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",31,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",32,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",33,0)
G C1
"RTN","CHMEAD6",34,0)
VBA W:'CT !,"Beneficiary has never been TRICARE eligible..." ;TLH 12/10/07 DEV002915 CHG CHAMPUS TO TRICARE
"RTN","CHMEAD6",35,0)
I ($D(CHOICE)),($Y>10) D G END:$D(DUOUT)
"RTN","CHMEAD6",36,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",37,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",38,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",39,0)
I '$D(CHOICE) D HEADER:$Y>58
"RTN","CHMEAD6",40,0)
W !!!,"VBA Tape Date",?40,"VBA/CHAMPVA Merge Date"
"RTN","CHMEAD6",41,0)
W !,"-------------",?40,"----------------------"
"RTN","CHMEAD6",42,0)
S (K,CT)=0
"RTN","CHMEAD6",43,0)
V1 S K=$O(^AHCHVA(I,100,J,103,K)) G STU:'K,V1:'$D(^(K,0))
"RTN","CHMEAD6",44,0)
S DA=^(0),X=$P($P(DA,U),".") D DTPRT S Y1=Y S:X="" Y1=X
"RTN","CHMEAD6",45,0)
S X=$P($P(DA,U,2),".") D DTPRT S Y2=Y,Y=$P(DA,U,2) X ^DD("DD") S Y3=Y
"RTN","CHMEAD6",46,0)
S CT=1 W !,Y1,?40,Y2 W:$P(Y3,"@",2)'="" " at ",$P(Y3,"@",2)
"RTN","CHMEAD6",47,0)
I ($D(CHOICE)),($Y>15) D G END:$D(DUOUT)
"RTN","CHMEAD6",48,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",49,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",50,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",51,0)
G V1
"RTN","CHMEAD6",52,0)
STU W:'CT !,"Beneficiary has never been on a VBA tape..."
"RTN","CHMEAD6",53,0)
I '$D(CHOICE) D HEADER:$Y>58
"RTN","CHMEAD6",54,0)
I ($D(CHOICE)),($Y>10) D G END:$D(DUOUT)
"RTN","CHMEAD6",55,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",56,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",57,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",58,0)
W !!!,"Student Beg Sem Date",?40,"Student End Sem Date"
"RTN","CHMEAD6",59,0)
W !,"--------------------",?40,"--------------------"
"RTN","CHMEAD6",60,0)
S (K,CT)=0
"RTN","CHMEAD6",61,0)
S1 S K=$O(^AHCHVA(I,100,J,104,K)) G LET:'K,S1:'$D(^(K,0))
"RTN","CHMEAD6",62,0)
S DA=^(0),X=$P($P(DA,U),".") D:X'="" DTPRT S Y1=Y S:X="" Y1=X
"RTN","CHMEAD6",63,0)
S X=$P($P(DA,U,2),".") D:X'="" DTPRT S Y2=Y S:X="" Y2=X
"RTN","CHMEAD6",64,0)
S CT=1 W !,Y1,?40,Y2
"RTN","CHMEAD6",65,0)
I ($D(CHOICE)),($Y>15) D G END:$D(DUOUT)
"RTN","CHMEAD6",66,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",67,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",68,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",69,0)
G S1
"RTN","CHMEAD6",70,0)
LET W:'CT !,"No school dates on file for this beneficiary..."
"RTN","CHMEAD6",71,0)
I '$D(CHOICE) D HEADER:$Y>58
"RTN","CHMEAD6",72,0)
I ($D(CHOICE)),($Y>10) D G END:$D(DUOUT)
"RTN","CHMEAD6",73,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",74,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",75,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",76,0)
W !!!,"Letter Mailed Date",?40,"Letter Name"
"RTN","CHMEAD6",77,0)
W !,"---------------------",?40,"------------------------------"
"RTN","CHMEAD6",78,0)
S (K,CT)=0
"RTN","CHMEAD6",79,0)
L1 S K=$O(^AHCHVA(I,100,J,500,K)) G ID:'K,L1:'$D(^(K,0))
"RTN","CHMEAD6",80,0)
S DA=^(0),X=$P($P(DA,U),".") D DTPRT S Y1=Y
"RTN","CHMEAD6",81,0)
S Y=$P(DA,U) X ^DD("DD") S Y2=Y
"RTN","CHMEAD6",82,0)
S X=$P(DA,U,2) S Y3=X
"RTN","CHMEAD6",83,0)
I Y3'="" S:$D(^AHADIC(554801.1,Y3,0)) Y3=$P(^(0),U)
"RTN","CHMEAD6",84,0)
S CT=1 W !,Y1 W:$P(Y2,"@",2)'="" " at ",$P(Y2,"@",2) W ?40,Y3
"RTN","CHMEAD6",85,0)
I ($D(CHOICE)),($Y>15) D G END:$D(DUOUT)
"RTN","CHMEAD6",86,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",87,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",88,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",89,0)
G L1
"RTN","CHMEAD6",90,0)
ID W:'CT !,"No letters have been printed for this beneficiary..."
"RTN","CHMEAD6",91,0)
I '$D(CHOICE) D HEADER:$Y>58
"RTN","CHMEAD6",92,0)
I ($D(CHOICE)),($Y>10) D G END:$D(DUOUT)
"RTN","CHMEAD6",93,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",94,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",95,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",96,0)
W !!!,"ID Card Issue Date ID Card Effect Date ID Card Expire Date ID Card Number"
"RTN","CHMEAD6",97,0)
W !,"------------------ ------------------- ------------------- --------------"
"RTN","CHMEAD6",98,0)
S (K,CT)=0
"RTN","CHMEAD6",99,0)
I1 S K=$O(^AHCHVA(I,100,J,"ID",K)) G ELIG:'K,I1:'$D(^(K,0))
"RTN","CHMEAD6",100,0)
S DA=^(0),X=$P(DA,U,2) D:X'="" DTPRT S Y1=Y S:X="" Y1=X
"RTN","CHMEAD6",101,0)
S X=$P(DA,U,3) D:X'="" DTPRT S Y2=Y S:X="" Y2=X
"RTN","CHMEAD6",102,0)
S L=2,X=$P(DA,U,4) D:X'="" DTPRT S Y3=Y S:X="" Y3=X
"RTN","CHMEAD6",103,0)
S L=3,X=$P(DA,U) S Y4=X
"RTN","CHMEAD6",104,0)
S L=4,X=$P(DA,U,5) S Y5=X
"RTN","CHMEAD6",105,0)
I Y5'="" S:$D(^DIC(3,Y5,0)) Y5=$P(^(0),U)
"RTN","CHMEAD6",106,0)
S L=5,X=$P(DA,U,6) S Y6=X
"RTN","CHMEAD6",107,0)
I Y6'="" S:$D(^DIC(3,Y6,0)) Y6=$P(^(0),U)
"RTN","CHMEAD6",108,0)
S L=6,X=$P(DA,U,7) S Y7=X
"RTN","CHMEAD6",109,0)
I Y7'="" S:$D(^DIC(3,Y7,0)) Y7=$P(^(0),U)
"RTN","CHMEAD6",110,0)
S CT=1 W !,Y1,?21,Y2,?44,Y3,?66,Y4
"RTN","CHMEAD6",111,0)
I ($D(CHOICE)),($Y>15) D G END:$D(DUOUT)
"RTN","CHMEAD6",112,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",113,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",114,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",115,0)
G I1
"RTN","CHMEAD6",116,0)
ELIG W:'CT !,"No ID cards have been printed for this beneficiary..."
"RTN","CHMEAD6",117,0)
I '$D(CHOICE) D HEADER:$Y>58
"RTN","CHMEAD6",118,0)
I ($D(CHOICE)),($Y>10) D G END:$D(DUOUT)
"RTN","CHMEAD6",119,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",120,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",121,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",122,0)
W !!!,"Eligibility:",?20,"Begin Date",?35,"End Date",!,?20,"------------",?35,"------------"
"RTN","CHMEAD6",123,0)
;W !,"'Possible' Dates:"
"RTN","CHMEAD6",124,0)
;I '$D(^AHCHVA(I,100,J,105)) W ?20,"none" D G END:$D(DUOUT) G A1
"RTN","CHMEAD6",125,0)
;.I ($D(CHOICE)),($Y>15) D Q:$D(DUOUT)
"RTN","CHMEAD6",126,0)
;..W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",127,0)
;..I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",128,0)
;...F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",129,0)
;S CHBEG="",INDX=105 D DISPLAY G END:$D(DUOUT)
"RTN","CHMEAD6",130,0)
A1 W !,?2,"'Actual' Dates:"
"RTN","CHMEAD6",131,0)
I '$D(^AHCHVA(I,100,J,109)) W ?20,"none" G END
"RTN","CHMEAD6",132,0)
S CHBEG="",INDX=109 D DISPLAY
"RTN","CHMEAD6",133,0)
END Q
"RTN","CHMEAD6",134,0)
DTPRT S Y="" Q:X'?7N S Y=$E(X,1,3)+1700,%M=+$E(X,4,5),%D=+$E(X,6,7)
"RTN","CHMEAD6",135,0)
I %M S:%D Y=$E(" ",$L(%D))_%D_", "_Y S Y=$P($P($T(JAN),";;",2)," ",%M)_" "_Y
"RTN","CHMEAD6",136,0)
Q
"RTN","CHMEAD6",137,0)
JAN ;;JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
"RTN","CHMEAD6",138,0)
HEADER W:'$D(CHOICE) #
"RTN","CHMEAD6",139,0)
S PG=PG+1 W !,DUZ,?33,"CHAMPVA CENTER",?72,"page: ",PG
"RTN","CHMEAD6",140,0)
W !,?25,"Application Processing File Dump"
"RTN","CHMEAD6",141,0)
S X=DT D DTPRT W !,?80-$L(Y)\2,Y
"RTN","CHMEAD6",142,0)
S ST="Current Values - Beneficiary" W !!,?80-$L(ST)\2,ST
"RTN","CHMEAD6",143,0)
Q
"RTN","CHMEAD6",144,0)
DISPLAY S CHBEG=$O(^AHCHVA(I,100,J,INDX,CHBEG)),CHEND="" Q:'CHBEG
"RTN","CHMEAD6",145,0)
D1 S CHEND=$O(^AHCHVA(I,100,J,INDX,CHBEG,CHEND)) G DISPLAY:'CHEND
"RTN","CHMEAD6",146,0)
S X=CHBEG D DTPRT W ?20,Y
"RTN","CHMEAD6",147,0)
S X=CHEND D DTPRT W ?35,Y,!
"RTN","CHMEAD6",148,0)
I ($D(CHOICE)),($Y>15) D Q:$D(DUOUT)
"RTN","CHMEAD6",149,0)
.W !!,"Press <RETURN> to continue, or '^' to exit. " D SBRS
"RTN","CHMEAD6",150,0)
.I '$D(DUOUT) S DX=1 D S DY=4 X XY S $Y=4
"RTN","CHMEAD6",151,0)
..F DY=4:1:19 X XY W @CHEEL
"RTN","CHMEAD6",152,0)
G D1
"RTN","CHMEAD6",153,0)
SBRS R Y:$S($D(DTIME):DTIME,1:60)
"RTN","CHMEAD6",154,0)
I '$T W *7 R Y:5 G SBRS:Y="." S:'$T Y=IOZFO
"RTN","CHMEAD6",155,0)
SBRS1 K DFOUT,DUOUT,DQOUT S:'$D(IOZFO) IOZFO="^^" S:'$D(IOZBK) IOZBK="^"
"RTN","CHMEAD6",156,0)
I IOZFO=Y W:$D(IOZF) # S (DFOUT,Y)="" Q
"RTN","CHMEAD6",157,0)
S:Y=IOZBK (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
"RTN","CHMEAD6",158,0)
Q
"RTN","CHMEAE81")
0^1^B231789217
"RTN","CHMEAE81",1,0)
CHMEAE81 ;CSW/DEN;CALC BEGIN AND END ELIGIBILITY DATES;Jan 08, 2019@09:23:21
"RTN","CHMEAE81",2,0)
;;1.0;CHAMPVA SYSTEM;**10,1**;JULY 4, 1990;Build 4
"RTN","CHMEAE81",3,0)
;CPTS 10042* BY CAM
"RTN","CHMEAE81",4,0)
;CPTS 10733* (AEB)
"RTN","CHMEAE81",5,0)
;CPTS 10739* (AEB) CPTS 8591* BY CAM
"RTN","CHMEAE81",6,0)
;CPTS 12589* BY AEB
"RTN","CHMEAE81",7,0)
;FEB, 96 (DTP) BEGINNING TO PULL SUBROUTINES OUT INTO CHMEAE8U TO DECREASE SIZE-CMOPCHK IS FIRST TO GO INTO THE UTILITY ROUTINE
"RTN","CHMEAE81",8,0)
;CPTS 12942* BY CAM
"RTN","CHMEAE81",9,0)
;CPTS 16468* BY CAM (MODIFIED SCHOOL TO CALC FOR 120 DAYS)
"RTN","CHMEAE81",10,0)
;CPTS 16523 (AEB)
"RTN","CHMEAE81",11,0)
;JSG;07/08/2008;DEV003763-02;BUG003763-05;DEERS DATA EXCHANGE
"RTN","CHMEAE81",12,0)
;YJK 3/12/2010 DEV008682 - Benes under 65 with Medicare A only do not calculate correctly
"RTN","CHMEAE81",13,0)
;YJK 5/24/2010 BUG008682-06-05 - Eligibility dates not correct for deceased benes
"RTN","CHMEAE81",14,0)
;YJK 7/9/2010 DEV009699 Beneficiaries over 65 with split medicare dates are not updating correctly;Med Flg=0, Under 65 - Elg should end on 65th-1.
"RTN","CHMEAE81",15,0)
;DEV012197-01 YJK 4/6/11 CAREGIVER
"RTN","CHMEAE81",16,0)
;DEV012502-01 YJK 6/6/2010 <UNDEFINED>END+1^CHMEAE81 *Y
"RTN","CHMEAE81",17,0)
;DEV012281-02 YJK 6/6/2011 beneficiaries of DOAD
"RTN","CHMEAE81",18,0)
;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE81",19,0)
;DEV007167-03 YJK 9/26/2011 true dates are in bene files that have never been to PR
"RTN","CHMEAE81",20,0)
;DEV015626-01 DPT 11/16/2012 Fix Error Trap UNDEFINED - CHMEAE81+24 | ADD EDIT OF BENE
"RTN","CHMEAE81",21,0)
;DEF015703-01 JSE 01/25/2013 Fix Error Trap UNDEFINED -PTDT+7^CHMEAE8U
"RTN","CHMEAE81",22,0)
;DEF015703-01 JSE 01/25/2013 Fix coding error found in this rtn while working above error.
"RTN","CHMEAE81",23,0)
;BUG015626-03-01 DPT 3/27/13 added more bene edits
"RTN","CHMEAE81",24,0)
;DEV017624-02 4/2/13 YJK
"RTN","CHMEAE81",25,0)
;MTN018346 6/19/13 YJK (subtask of DEV017624-02)
"RTN","CHMEAE81",26,0)
;BUG017624-10-01 3/17/14 YJK
"RTN","CHMEAE81",27,0)
;BUG017624-10-01 6/13/14 YJK
"RTN","CHMEAE81",28,0)
;DEV023183 ACA DISENROLLMENT 5/21/15 JAK/AEB
"RTN","CHMEAE81",29,0)
;DEV023457 AEB 10-27-2015
"RTN","CHMEAE81",30,0)
;JEH 3/12/15 - ENC22734 - Enhancement of Cache Systems to support Retired Reservists Functionality
"RTN","CHMEAE81",31,0)
;DEV025745-01 SBB 08/05/2016 Fix for medicare elig auto-calc ;commented VER 37 code for the fix
"RTN","CHMEAE81",32,0)
;DEF025745 FIX MEDICARE SPLIT ELIGIBILITY FOR UAT DRW 02/27/2018
"RTN","CHMEAE81",33,0)
;DEF831715 10/1/18 BDB ELIGIBILITY DATES
"RTN","CHMEAE81",34,0)
;DEF831715 10/18/2018 TGH Prevent Reset of Eligibility Dates if Relationship is Caregiver
"RTN","CHMEAE81",35,0)
;ACA Disenrollment TGH 1/3/2018 Prevent Reset of Eligibility Dates if Disenrolled or Reenrolled
"RTN","CHMEAE81",36,0)
;
"RTN","CHMEAE81",37,0)
S U="^" I '$D(DT) D NOW^%DTC S DT=X
"RTN","CHMEAE81",38,0)
Q:'BFN ;BUG015626-03-01 reactivate
"RTN","CHMEAE81",39,0)
Q:'$D(^AHCHVA(DFN,100,BFN)) ;DEV015626 DPT 11/16/12,BUG015626-03-01 3/27/13
"RTN","CHMEAE81",40,0)
I $D(^AHCHVA(DFN,100,BFN,8)) I $P(^(8),U,1)=1 D CMOPCHK^CHMEAE8U I $P(CHCD,U,5)=$P(CHPD,U,5) I $P(CHCD2,U,5)'="" I '$D(CHCD30)!(+$P($G(CHCD30),U,1)=0) Q D RRCALC^CHMEAE8U(DFN,BFN) Q ;TLH 6/18/08 DEV005164 ;JEH 3/12/15 - ENC22734 ;BDB 10/1/18 +$P
"RTN","CHMEAE81",41,0)
I $D(^AHCHVA(DFN,100,BFN,0)) I ($P(^AHCHVA(DFN,100,BFN,0),"^",4)="CG") D CMOPCHK^CHMEAE8U ;DEV012197-01 YJK 4/6/11 CAREGIVER
"RTN","CHMEAE81",42,0)
;S CHSTA=$P(^AHCHVA(DFN,0),U,5) I CHSTA="I" Q ;AEB 4/2/2008 DEF004699
"RTN","CHMEAE81",43,0)
;S CHSTA=$P(^AHCHVA(DFN,0),U,5) I CHSTA="I" D PTDT^CHMEAE8U D CMOPCHK^CHMEAE8U Q ;TLH 7/28/08 DEV005327
"RTN","CHMEAE81",44,0)
S CHSTA=$P(^AHCHVA(DFN,0),U,5) I CHSTA="I" S:'$D(CHBEG) CHBEG="" D PTDT^CHMEAE8U D CMOPCHK^CHMEAE8U I $P(CHCD,U,5)=$P(CHPD,U,5) I $P(CHCD2,U,5)'="" I '$D(CHCD30)!(+$P($G(CHCD30),U,1)=0) Q D RRCALC^CHMEAE8U(DFN,BFN) Q ;DEF015703 JSE 1/25/13 ;JEH 3/12/15 - ENC22734 ;BDB 10/1/18 +$P
"RTN","CHMEAE81",45,0)
; DEF831715 10/18/2018 TGH Prevent Reset of Eligibility Dates if Relationship is Caregiver
"RTN","CHMEAE81",46,0)
I $P($G(^AHCHVA(DFN,100,BFN,0)),"^",4)="CG" Q
"RTN","CHMEAE81",47,0)
; ACA Disenrollment TGH 1/3/2018 Prevent Reset of Eligibility Dates if Disenrolled or Reenrolled
"RTN","CHMEAE81",48,0)
I $D(^AHCHVA(DFN,100,BFN,115)) Q
"RTN","CHMEAE81",49,0)
;'I','SSN','IR','SI','CHE' are Inelig reasons that should not have eligibility periods per Vicki B.
"RTN","CHMEAE81",50,0)
S BINELRSN="",BINELRSN=$P(CHCD,"^",12) ;DEV007167-03 YJK 9/26/2011
"RTN","CHMEAE81",51,0)
I BINELRSN="I"!(BINELRSN="SSN")!(BINELRSN="IR")!(BINELRSN="SI")!((BINELRSN="CHE")&($P($G(CHCD30),U,5)'=1)) D Q ;DEV007167-03 YJK 9/26/2011 ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE81",52,0)
.K ^AHCHVA(DFN,100,BFN,105) ;DEV007167-03 YJK 9/26/2011
"RTN","CHMEAE81",53,0)
.K ^AHCHVA(DFN,100,BFN,109) ;DEV007167-03 YJK 9/26/2011
"RTN","CHMEAE81",54,0)
.Q ;DEV007167-03 YJK 9/26/2011
"RTN","CHMEAE81",55,0)
S DOB="",DOB=$P(^AHCHVA(DFN,100,BFN,0),"^",3) I DOB="" Q ;BUG015626-03-01 DPT 3/27/13
"RTN","CHMEAE81",56,0)
S AGE=$$AGE^CHTFLIB(DOB,DT) ;BUG015626-03-01 DPT 3/27/13
"RTN","CHMEAE81",57,0)
S (CHPTBEG,CHPTEND,CHBEG,CHEND,CHINEL)="" D NOW^%DTC S CHNOW=%
"RTN","CHMEAE81",58,0)
K ^AHCHVA(DFN,100,BFN,105) S MEDFLG=0
"RTN","CHMEAE81",59,0)
F I=0:0 S I=$O(^AHCHVA(DFN,100,BFN,109,I)) Q:'I F J=0:0 S J=$O(^AHCHVA(DFN,100,BFN,109,I,J)) Q:'J K:$P(^(J),U,3)'=1 ^(J)
"RTN","CHMEAE81",60,0)
G END:($P(CHCD,U,4)="")!($P(CHCD,U,3)'?7N)
"RTN","CHMEAE81",61,0)
F I=0:0 S I=$O(^AHCHVA(DFN,102,I)) Q:'I I $D(^(I,0)) S:$P(^(0),U)>CHPTBEG CHPTBEG=$P(^(0),U),CHPTEND=$P(^(0),U,2)
"RTN","CHMEAE81",62,0)
S CHBEG=$P(^AHCHVA(DFN,100,BFN,0),"^",10) I CHBEG<11111 D S:CHBEG'="" $P(^AHCHVA(DFN,100,BFN,0),"^",10)=CHBEG
"RTN","CHMEAE81",63,0)
.I $D(^AHCHVA(DFN,100,BFN,2)),$D(^AHCHVA(DFN,100,BFN,3)) F I=1,2,3,4,5,6,9,14,15 I $P(^(2),U,I)=2,$P(^(3),U,I)'="" S:CHBEG<11111 CHBEG=$P(^(3),U,I) S:$P(^(3),U,I)<CHBEG CHBEG=$P(^(3),U,I)
"RTN","CHMEAE81",64,0)
I CHBEG<11111 D
"RTN","CHMEAE81",65,0)
.I $D(^AHCHVA(DFN,100,BFN,2)),$D(^AHCHVA(DFN,100,BFN,3)) F I=1,2,3,4,5,6,9,14,15 D
"RTN","CHMEAE81",66,0)
..S TCHCD3=^AHCHVA(DFN,100,BFN,3)
"RTN","CHMEAE81",67,0)
..S:CHBEG<11111 CHBEG=$P(TCHCD3,U,I),$P(^AHCHVA(DFN,100,BFN,0),"^",10)=CHBEG
"RTN","CHMEAE81",68,0)
..I $P(TCHCD3,U,I)'="" S:$P(TCHCD3,U,I)<CHBEG CHBEG=$P(TCHCD3,U,I),$P(^AHCHVA(DFN,100,BFN,0),"^",10)=CHBEG
"RTN","CHMEAE81",69,0)
.I CHBEG<11111 S CHBEG=DT,$P(^AHCHVA(DFN,100,BFN,0),"^",10)=CHBEG
"RTN","CHMEAE81",70,0)
I $D(^AHCHVA(DFN,100,BFN,4)) I $P(^(4),U,3)'="" S:CHBEG>$P(^(4),U,3) CHBEG=$P(^(4),U,3)
"RTN","CHMEAE81",71,0)
I $P(^AHCHVA(DFN,0),"^",14)=3&($P(^AHCHVA(DFN,3),"^",20)'="")&($P(^AHCHVA(DFN,0),"^",4)'="")&($P(^AHCHVA(DFN,0),"^",17)="") I CHBEG<$P(^AHCHVA(DFN,0),"^",4) S CHBEG=$P(^AHCHVA(DFN,0),"^",4),$P(^AHCHVA(DFN,100,BFN,0),"^",10)=CHBEG ;======> BUG017624-10-01 6/13/14 YJK
"RTN","CHMEAE81",72,0)
I $P(^AHCHVA(DFN,0),"^",4)=""&($P(^AHCHVA(DFN,0),"^",5)="E")&($P(^AHCHVA(DFN,0),"^",17)'="") I CHBEG<$P(^AHCHVA(DFN,0),"^",17) S CHBEG=$P(^AHCHVA(DFN,0),"^",17) ;======> BUG017624-10-01 6/13/14 YJK
"RTN","CHMEAE81",73,0)
;
"RTN","CHMEAE81",74,0)
;DEF015703 JSE 1/25/13
"RTN","CHMEAE81",75,0)
;The line of code below has never worked b/c it's pulling the data from the wrong pieces.
"RTN","CHMEAE81",76,0)
;(P)iece 9 contains the date & P10 has the status flag indicating if the remit address was set correctly.
"RTN","CHMEAE81",77,0)
;The line below is looking 4 the status flag in P9 (instead of P10) & the date from P10 (instead of P9).
"RTN","CHMEAE81",78,0)
;As a result the code fails to execute b/c after the $D check, it checks if the date in P9 equals 2.
"RTN","CHMEAE81",79,0)
;But even if set to the correct pieces, it's checking for the wrong value of the status flag.
"RTN","CHMEAE81",80,0)
;A flag set to 2 means "Wrong Format". It should look for flag set to 1 "Yes" (Correct Address).
"RTN","CHMEAE81",81,0)
;
"RTN","CHMEAE81",82,0)
;Fixed the line below, however after talking with PST it was decided to comment out the line.
"RTN","CHMEAE81",83,0)
;I $D(^AHCHVA(DFN,100,BFN,1)) I $P(^(1),U,9)=2,$P(^(1),U,10)'="" S:$P(^(1),U,10)<CHBEG CHBEG=$P(^(1),U,10)
"RTN","CHMEAE81",84,0)
;I CHBEG="",$D(^AHCHVA(DFN,100,BFN,1)) I $P(^(1),U,10)=1,$P(^(1),U,9)'="" S:$P(^(1),U,9)<CHBEG CHBEG=$P(^(1),U,9) ;DEF015703 JSE 1/25/13
"RTN","CHMEAE81",85,0)
G A1:CHBEG'=9999999 S CHBEG=0
"RTN","CHMEAE81",86,0)
F S CHBEG=$O(^AHCHVA(DFN,101,CHBEG)) Q:'CHBEG Q:$D(^(CHBEG,100,BFN,0))
"RTN","CHMEAE81",87,0)
S CHBEG=$P(CHBEG,".")
"RTN","CHMEAE81",88,0)
A1 I CHPTBEG'="" S:CHPTBEG>CHBEG CHBEG=CHPTBEG
"RTN","CHMEAE81",89,0)
I $P(^AHCHVA(DFN,0),U,5)="I" D SINEL S:Y?7N CHINEL=Y
"RTN","CHMEAE81",90,0)
I $P(CHCD,U,5)="D" D BINEL I Y?7N S:Y<CHINEL CHINEL=Y
"RTN","CHMEAE81",91,0)
I ($P(CHCD,U,26)="A"),($P(CHCD,U,4)="C"),($P(^AHCHVA(DFN,0),U,4)?7N),($P(CHCD,U,27)?7N) I ($P(CHCD,U,27)-20000)>($P(^AHCHVA(DFN,0),U,4)) S (CHBEG,CHEND)="" G END
"RTN","CHMEAE81",92,0)
I $P(CHCD,U,6)?7N S Y=$P(CHCD,U,6) D G:AGE>64 END G SET
"RTN","CHMEAE81",93,0)
.S AGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,100,BFN,0),"^",3),DT)
"RTN","CHMEAE81",94,0)
.I AGE>64 D MEDP^CHMEAE8A
"RTN","CHMEAE81",95,0)
.I CHEND="" I AGE>64 I $P(CHCD,"^",32)=0 S CHEND=$P(CHCD,U,6)
"RTN","CHMEAE81",96,0)
.I CHEND="" I AGE>64 S Y=$P(CHCD,U,3)+650000,CHEND=$$FMADD^XLFDT(Y,-1,0,0,0) ;TLH 8/8/06 CHANGED TO EFFECT EA BENES ONLY PROJECT 1499
"RTN","CHMEAE81",97,0)
.Q
"RTN","CHMEAE81",98,0)
G DIVORCE:($P(CHCD,U,16)=1)&($P(CHCD,U,4)'="C")
"RTN","CHMEAE81",99,0)
;I ($P(CHCD,U,18)=1)&($P(CHCD,U,4)'="C") S X=$P(CHCD,U,7) G END:X'?7N D LEAP,DTBS^CHMEAE8U S X=Y+1 D DATE^CHMEAE8U S:Y>CHBEG CHBEG=Y G SPOUSE
"RTN","CHMEAE81",100,0)
;I ($P(CHCD,U,18)=1)&($P(CHCD,U,4)'="C") S X=$P(CHCD,U,7) G END:X'?7N D LEAP,DTBS^CHMEAE8U S X=Y+1 D DATE^CHMEAE8U D TERM^CHMEAE8U G SET ;TLH 3/21/07 MODIFIED FOR DEV001764 REMARRIED WIDOW FIX
"RTN","CHMEAE81",101,0)
I ($P(CHCD,U,18)=1)&($P(CHCD,U,4)'="C") S X=$P(CHCD,U,7) G END:X'?7N D LEAP,DTBS^CHMEAE8U S X=Y+1 D DATE^CHMEAE8U S OLDCHBEG=CHBEG D TERM^CHMEAE8U S CHBEG=OLDCHBEG G SPOUSE ;MTN017725 TEST 4/11/13 YJK (Added "G SPOUSE" instead of "G SET" to give MDCR logic priority)
"RTN","CHMEAE81",102,0)
;I ($P(CHCD,U,17)=1)&($P(CHCD,U,4)'="C") S X=$P(CHCD,U,8) I X?7N D LEAP S:(X<CHEND)!(CHEND'?7N) CHEND=X G END
"RTN","CHMEAE81",103,0)
;NEXT LINE IS REMARRIAGE AFTER AGE 55 CHECK
"RTN","CHMEAE81",104,0)
I ($P(CHCD,U,17)=1)&($P(CHCD,U,4)'="C") D
"RTN","CHMEAE81",105,0)
.I '$D(AGE) S AGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,100,BFN,0),"^",3),DT)
"RTN","CHMEAE81",106,0)
.I AGE>64 Q
"RTN","CHMEAE81",107,0)
.I (($P(CHCD,"^",13)="W55")!($P(CHCD,"^",13)="N55")) D RMA54^CHMEAE83
"RTN","CHMEAE81",108,0)
G MARRIAG:($P(CHCD,U,19)=1)&($P(CHCD,U,4)="C")
"RTN","CHMEAE81",109,0)
G SPOUSE:($P(CHCD,U,13)="H")!($P(CHCD,U,4)'="C")
"RTN","CHMEAE81",110,0)
G STUDENT:($P(CHCD,U,22)=1)&($P(CHCD,U,4)="C")
"RTN","CHMEAE81",111,0)
CHILD I ($P(CHCD,U,26)="S")&($D(^AHCHVA(DFN,100,BFN,114))) D HH^CHMEAE83 G END
"RTN","CHMEAE81",112,0)
S X=$P(CHCD,U,3)+180000 S Y=$$FMADD^XLFDT(X,-1,0,0,0)
"RTN","CHMEAE81",113,0)
;I $P(CHCD,"^",33)=1 D ;HELPLESS CHILD ;=====> DEV017624-02 4/2/13 TEST YJK
"RTN","CHMEAE81",114,0)
I $P(CHCD,"^",33)=1!($P(CHCD,U,13)="H") D ;HELPLESS CHILD ;=====> DEV017624-02 4/2/13 TEST YJK
"RTN","CHMEAE81",115,0)
CO65 .I AGE>64 D Q ;OVER 65 STUFF ADDED DO AEB 5/6/2009 DEV007158 UNDER 65 STUFF
"RTN","CHMEAE81",116,0)
..S TX=$P(CHCD,U,3)+1200000
"RTN","CHMEAE81",117,0)
..I $P(CHCD,U,32)=""&($P(CHCD,U,12)="PMI") S TX=$P(CHCD,U,3)+650000 ;DEV017624-02 1/27/14 YJK
"RTN","CHMEAE81",118,0)
..S X=$$FMADD^XLFDT(TX,-1,0,0,0)
"RTN","CHMEAE81",119,0)
..D LEAP,DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U
"RTN","CHMEAE81",120,0)
..D MEDP^CHMEAE8A
"RTN","CHMEAE81",121,0)
..Q
"RTN","CHMEAE81",122,0)
CU65 .I AGE<65 D ;UNDER 65 STUFF ADDED DO& CODE AEB 5/6/2009 DEV007158
"RTN","CHMEAE81",123,0)
..Q:'$D(^AHCHVA(DFN,100,BFN,111)) ;QUIT IF NO MEDICARE A
"RTN","CHMEAE81",124,0)
..S TMPDT=9999999999
"RTN","CHMEAE81",125,0)
..S TMPDT=$O(^AHCHVA(DFN,100,BFN,111,TMPDT),-1) Q:'TMPDT
"RTN","CHMEAE81",126,0)
..S TMEDABDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",1)
"RTN","CHMEAE81",127,0)
..S TMEDAEDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",4)
"RTN","CHMEAE81",128,0)
..Q:TMEDAEDT'=""
"RTN","CHMEAE81",129,0)
..S Y=$$FMADD^XLFDT(TMEDABDT,-1,0,0,0)
"RTN","CHMEAE81",130,0)
..Q:'$D(^AHCHVA(DFN,100,BFN,112)) ;QUIT ID NO MEDICARE B
"RTN","CHMEAE81",131,0)
..S TMPDT=9999999999
"RTN","CHMEAE81",132,0)
..S TMPDT=$O(^AHCHVA(DFN,100,BFN,112,TMPDT),-1) Q:'TMPDT
"RTN","CHMEAE81",133,0)
..S TMEDBBDT=$P(^AHCHVA(DFN,100,BFN,112,TMPDT,0),"^",1)
"RTN","CHMEAE81",134,0)
..S TMEDBEDT=$P(^AHCHVA(DFN,100,BFN,112,TMPDT,0),"^",4)
"RTN","CHMEAE81",135,0)
..I TMEDBEDT=""&($P(CHCD,U,3)+180000)'<CHBEG S X=$P(CHCD,U,3)+180000 S Y=$$FMADD^XLFDT(X,-1,0,0,0) Q ;DEV017624-02 4/2/13 YJK
"RTN","CHMEAE81",136,0)
..I TMEDBEDT=""&($P(CHCD,U,32)=2) S X=$P(CHCD,U,3)+1200000 S Y=$$FMADD^XLFDT(X,-1,0,0,0) Q ;DEV017624-02 1/27/14 YJK
"RTN","CHMEAE81",137,0)
..Q:TMEDBEDT=""
"RTN","CHMEAE81",138,0)
..S Y=$$FMADD^XLFDT(TMEDBEDT,-1,0,0,0)
"RTN","CHMEAE81",139,0)
..Q
"RTN","CHMEAE81",140,0)
.Q
"RTN","CHMEAE81",141,0)
G SET
"RTN","CHMEAE81",142,0)
SPOUSE S X=$P(CHCD,U,7)
"RTN","CHMEAE81",143,0)
S Y=$P(CHCD,U,3)+650000 D NOW^%DTC
"RTN","CHMEAE81",144,0)
I Y>X G U65
"RTN","CHMEAE81",145,0)
;CALC FOR OVER 65
"RTN","CHMEAE81",146,0)
O65 I ($P(CHCD,U,32)=0)!($P(CHCD,U,32)=3),($D(^AHCHVA(DFN,100,BFN,2))) D G SET
"RTN","CHMEAE81",147,0)
.S X=$P(CHCD,U,3)+1200000
"RTN","CHMEAE81",148,0)
.I ($P(^AHCHVA(DFN,100,BFN,0),"^",12)="W55")&($P(^AHCHVA(DFN,100,BFN,0),"^",8)'="")&($D(CHEND)) S X=CHEND ;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE81",149,0)
.S Y=X
"RTN","CHMEAE81",150,0)
.D MEDP^CHMEAE8A
"RTN","CHMEAE81",151,0)
I $P(CHCD,U,32)="",($D(^AHCHVA(DFN,100,BFN,2))) D G SET
"RTN","CHMEAE81",152,0)
.S X1=$P(CHCD,U,3)+650000,X=$$FMADD^XLFDT(X1,-1,0,0,0) D DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U
"RTN","CHMEAE81",153,0)
.I $P(CHCD,"^",12)="W55" S:$P(CHCD,"^",8)'="" X=$P(CHCD,U,8) D DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U ;TLH 2/21/2007
"RTN","CHMEAE81",154,0)
.Q
"RTN","CHMEAE81",155,0)
I (($P(CHCD,U,32)=1)!($P(CHCD,U,32)=2)),($D(^AHCHVA(DFN,100,BFN,2))) D G SET
"RTN","CHMEAE81",156,0)
.Q:$G(CHBSTA)="D"&($G(CHIREA)="SDE") ;MTN018346 6/19/13 YJK ; ADDED $G FOR CHBSTA 1/3/14
"RTN","CHMEAE81",157,0)
.S X=$P(CHCD,U,3)+1200000 D DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U S Y="" ;AEB 2-2-2016 BUG022643 ADDED S Y=""
"RTN","CHMEAE81",158,0)
.I $P(CHCD,"^",12)="W55" S:$P(CHCD,"^",8)'="" X=$P(CHCD,U,8) D DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U ;TLH 1/24/2007
"RTN","CHMEAE81",159,0)
.I ($P(CHCD,U,4)'="C") D MEDBCHK^CHMEAE83 ;DEV017624-02 4/2/13 YJK
"RTN","CHMEAE81",160,0)
.;D MEDBCHK^CHMEAE83 ;DEV017624-02 4/2/13 YJK (Replace by the above code)
"RTN","CHMEAE81",161,0)
.D MEDP^CHMEAE8A
"RTN","CHMEAE81",162,0)
.Q
"RTN","CHMEAE81",163,0)
G SET
"RTN","CHMEAE81",164,0)
U65 ;
"RTN","CHMEAE81",165,0)
; I ($P(CHCD,U,32)=0)!($P(CHCD,U,32)=3),($D(^AHCHVA(DFN,100,BFN,2))),(($P(^(2),U,14)=22)!($P(^(2),U,14)=6)) D G SET
"RTN","CHMEAE81",166,0)
I ($P(CHCD,U,32)=0)!($P(CHCD,U,32)=3) D G SET ;JAKMEDICARE REMOVED CHECK FOR SPECIFIC DOCUMENTS DEF025745 02/27/2018
"RTN","CHMEAE81",167,0)
.S X=$P(CHCD,U,3)+650000,X=$$FMADD^XLFDT(X,-1,0,0,0),Y=X ;ONE DAY PRIOR TO 65 B-DAY
"RTN","CHMEAE81",168,0)
.I $P(CHCD,U,32)=0 S X=$P(CHCD,U,3)+1200000 S Y=X I $D(^AHCHVA(DFN,100,BFN,111)) D
"RTN","CHMEAE81",169,0)
..S TMPDT=9999999999
"RTN","CHMEAE81",170,0)
U651 ..S TMPDT=$O(^AHCHVA(DFN,100,BFN,111,TMPDT),-1) Q:'TMPDT
"RTN","CHMEAE81",171,0)
..S TMEDABDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",1)
"RTN","CHMEAE81",172,0)
..S TMEDAEDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",4)
"RTN","CHMEAE81",173,0)
..Q:TMEDAEDT=""
"RTN","CHMEAE81",174,0)
..;S CHBEG=$$FMADD^XLFDT(TMEDAEDT,-1,0,0,0) ;JAKMEDICARE THIS DATE NOT NEEDED WILL BE CALCULATED IN OTHER PROCESSES DEF25745 02/27/2018
"RTN","CHMEAE81",175,0)
..I $D(^AHCHVA(DFN,100,BFN,111)) D ;IF MED A PERIOD EXISTS
"RTN","CHMEAE81",176,0)
...I $D(^AHCHVA(DFN,100,BFN,112)) D G SET1 ; IF MED B PERIOD EXITS
"RTN","CHMEAE81",177,0)
....D MEDBCHK^CHMEAE83
"RTN","CHMEAE81",178,0)
....D MEDP^CHMEAE8A
"RTN","CHMEAE81",179,0)
..Q
"RTN","CHMEAE81",180,0)
;I $P(CHCD,"^",17)=1 I $P(CHCD,"^",18)'=1 S Y=$P(CHCD,"^",8) D REMAR^CHMEAE8U G:Y'="" SET1 ;TLH 5/23/06 ERROR IN DEV ;===> YJK TEST 5/6/14
"RTN","CHMEAE81",181,0)
I $P(CHCD,"^",17)=1 I $P(CHCD,"^",18)'=1 S Y=$P(CHCD,"^",8) D G:Y'="" SET1 ;===> YJK TEST 5/6/14
"RTN","CHMEAE81",182,0)
.D REMAR^CHMEAE8U ;===> YJK TEST 5/6/14
"RTN","CHMEAE81",183,0)
.I ($P(CHCD,U,32)=1!($P(CHCD,U,32)=2)) I ($P(CHCD,U,4)'="C") D MEDBCHK^CHMEAE83 D MEDP^CHMEAE8A ;===> YJK TEST 5/6/14
"RTN","CHMEAE81",184,0)
.Q ;===> YJK TEST 5/6/14
"RTN","CHMEAE81",185,0)
;I ($P(CHCD,U,32)=1!($P(CHCD,U,32)=2)) D MEDBCHK^CHMEAE83 D MEDP^CHMEAE8A G SET1 ;TLH MOVED AFTER REMARRIAGE CKS 2/21/2007 ;BUG017624-10-01 3/17/14 YJK
"RTN","CHMEAE81",186,0)
I ($P(CHCD,U,32)=1!($P(CHCD,U,32)=2)) I ($P(CHCD,U,4)'="C") D MEDBCHK^CHMEAE83 D MEDP^CHMEAE8A G SET1 ;BUG017624-10-01 3/17/14 YJK
"RTN","CHMEAE81",187,0)
;SBB FIX
"RTN","CHMEAE81",188,0)
I ($P(CHCD,U,32)=1!($P(CHCD,U,32)=2)) I (($P(CHCD,U,13)="H")&($P(CHCD,U,4)="C")) D MEDBCHK^CHMEAE83 D MEDP^CHMEAE8A G SET1
"RTN","CHMEAE81",189,0)
;
"RTN","CHMEAE81",190,0)
D D DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U
"RTN","CHMEAE81",191,0)
.S X1=$P(CHCD,U,3)+650000 S X=$$FMADD^XLFDT(X1,-1,0,0,0) ;ONE DAY PRIOR TO 65 B-DAY
"RTN","CHMEAE81",192,0)
.Q
"RTN","CHMEAE81",193,0)
SET S CHEND=Y ;AEB 2-2-2016 commented off BUG022643
"RTN","CHMEAE81",194,0)
;I '$D(CHEND) I $D(Y),(Y?7N) S CHEND=Y ;AEB 2-2-2016 line added BUG022643
"RTN","CHMEAE81",195,0)
SET1 I CHPTEND'="" S:CHEND>CHPTEND CHEND=CHPTEND
"RTN","CHMEAE81",196,0)
I CHINEL?7N S:CHEND>CHINEL CHEND=CHINEL
"RTN","CHMEAE81",197,0)
END I $P(CHCD,U,9)'?9N D DTSET^CHMEAE8U
"RTN","CHMEAE81",198,0)
;I '$D(CHEND)&(Y'="") S CHEND=Y ;DEV012502-01 YJK 6/6/2011
"RTN","CHMEAE81",199,0)
I '$D(CHEND) I $D(Y),(Y?7N) S CHEND=Y ;DEV012502-01 YJK 6/6/2011
"RTN","CHMEAE81",200,0)
I $P(CHCD,U,9)'?9N D DTSET^CHMEAE8U
"RTN","CHMEAE81",201,0)
;I (CHBEG?7N)&(CHEND?7N) K ^AHCHVA(DFN,100,BFN,105) D ;DEV012502-01 YJK 6/6/2011
"RTN","CHMEAE81",202,0)
;DEV025745-01 SBB 08/05/2016 Fix for medicare elig auto-calc
"RTN","CHMEAE81",203,0)
;I $D(CHBEG)&($D(CHEND)) I (CHBEG?7N)&(CHEND?7N) K ^AHCHVA(DFN,100,BFN,105) D ;DEV012502-01 YJK 6/6/2011
"RTN","CHMEAE81",204,0)
I (CHBEG?7N)&(CHEND?7N) D
"RTN","CHMEAE81",205,0)
.Q:$P(CHCD,"^",12)="A55" ;TLH 02/27/06 TRC 1369
"RTN","CHMEAE81",206,0)
.Q:$P(CHCD,"^",12)="SCP" ;AEB 5/24/2006
"RTN","CHMEAE81",207,0)
.Q:$P(CHCD,"^",12)="SDE" ;DEV012281-02 YJK 6/6/2010
"RTN","CHMEAE81",208,0)
.Q:$P(CHCD,"^",15)=1&('$D(^AHCHVA(DFN,30))) ;AEB 12/10/2009 ;JEH 3/12/15 - ENC22734 IF RET/RES THEN THE DATES ARE NEEDED OTHERWISE DON'T CREATE DATES IF TRICARE ELIG
"RTN","CHMEAE81",209,0)
.Q:(($P(CHCD,"^",13)="CFL")&($P(CHCD,"^",32)=2))
"RTN","CHMEAE81",210,0)
.;I $P(CHCD,"^",6)?7N D EA^CHMEAE8U I CHGOOD=1 K CHDBFLG,CHGOOD S ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_U_CHNOW,^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND)=DUZ_U_CHNOW Q ;TLH 6/26/2006 MC255/PROJECT 1499 ;YJK 5/24/2010 BUG008682-06-05 - replaced with D ^DECEASED (NEXT LINE)
"RTN","CHMEAE81",211,0)
.K ^AHCHVA(DFN,100,BFN,105)
"RTN","CHMEAE81",212,0)
.I $P(CHCD,"^",6)?7N D EA^CHMEAE8U I CHGOOD=1 K CHDBFLG,CHGOOD D DECEASED Q ;YJK 5/24/2010 BUG008682-06-05
"RTN","CHMEAE81",213,0)
.S ^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND)=DUZ_U_CHNOW
"RTN","CHMEAE81",214,0)
.S ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_U_CHNOW
"RTN","CHMEAE81",215,0)
.D CHECK^CHMEA105(DFN) ;JSG;07/08/2008;DEV003763-02;Queue DEERS if bene 105 dates have changed
"RTN","CHMEAE81",216,0)
.Q
"RTN","CHMEAE81",217,0)
;D DICCHK^CHMEAE82
"RTN","CHMEAE81",218,0)
;MOVED 120CHK TO THE BOTTOM OF THIS ROUTINE TO ALLOW FURTHER EXECUTION OF THIS ROUTINE.
"RTN","CHMEAE81",219,0)
;PROBLEM OCCURED WITH CALCULATIONS AFTER 6/22/07 WHEN 188 WAS MOVED LIVE. WITH MOVING 120CHK PROBLEM LOOKS TO BE RESOLVED.
"RTN","CHMEAE81",220,0)
;D 120CHK ;TLH 4/10/07 ENC000188 - THE CODE BELOW REPLACES THIS CALL.
"RTN","CHMEAE81",221,0)
I '(($P(CHCD,U,18)=1)&($P(CHCD,U,4)'="C")&($P(CHCD,"^",6)?7N)) D 120CHK ;YJK 3/12/2010 DEV008682-120CHK WAS UNDOING TERM^CHMEAE8U SPLIT DATES;YJK 5/24/2010 BUG008682-06-05 - ADDED DECEASED CHECK
"RTN","CHMEAE81",222,0)
S INDX=105 D CLEANUP^CHMEAE8U S (CHBEG,CHEND)=""
"RTN","CHMEAE81",223,0)
F A=0:0 S A=$O(^AHCHVA(DFN,100,BFN,105,A)) Q:A="" F B=0:0 S B=$O(^AHCHVA(DFN,100,BFN,105,A,B)) Q:B="" S CHBEG=A,CHEND=B,$P(^AHCHVA(DFN,100,BFN,5),U,3)=CHBEG,$P(^(5),U,4)=CHEND I MEDFLG=0 D ^CHMEAE82
"RTN","CHMEAE81",224,0)
;D DICCHK^CHMEAE82
"RTN","CHMEAE81",225,0)
S INDX=109 D CLEANUP^CHMEAE8U
"RTN","CHMEAE81",226,0)
I $P(CHCD,"^",12)="CHE"&($P($G(CHCD30),U,5)'=1) K ^AHCHVA(DFN,100,BFN,109),^AHCHVA(DFN,100,BFN,105) ;REMOVE ELIG PERIODS FOR CHAMPUS ELIG BENE'S ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE81",227,0)
I $P(CHCD,"^",12)="RTD" K ^AHCHVA(DFN,100,BFN,109),^AHCHVA(DFN,100,BFN,105) ;REMOVE ELIG PERIODS FOR NO MARRIAGE TERM DATES TLH 11/14/07 BUG0033045
"RTN","CHMEAE81",228,0)
K INDX,CHEND,CHEND2
"RTN","CHMEAE81",229,0)
I $D(^AHCHVA(DFN,30)),$P(^AHCHVA(DFN,30),"^",5)=1 D RRCALC^CHMEAE8U(DFN,BFN) ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE81",230,0)
;D RECALC^CHEDISEN(DFN,BFN) ;DEV023183 ACA DISENROLLMENT 5/21/15 AEB/JAK DEV023457 ;JEH 1/16/18 - COMMENTED OFF
"RTN","CHMEAE81",231,0)
Q:$D(CHMXDERS)
"RTN","CHMEAE81",232,0)
D CMOPCHK^CHMEAE8U
"RTN","CHMEAE81",233,0)
;I $P(^AHCHVA(DFN,0),"^",5)="D" K ^AHCHVA(DFN,100,BFN,109),^AHCHVA(DFN,100,BFN,105) ;AEB 8/30/2007 DEF002890
"RTN","CHMEAE81",234,0)
;I $P(^AHCHVA(DFN,100,BFN,0),"^",5)="D" I $P(^AHCHVA(DFN,100,BFN,0),"^",12)="I" K ^AHCHVA(DFN,100,BFN,109),^AHCHVA(DFN,100,BFN,105) ;AEB 8/30/2007 DEF002890
"RTN","CHMEAE81",235,0)
Q
"RTN","CHMEAE81",236,0)
DIVORCE ;S X=$P(CHCD,U,3)+650000,X=$E(X,1,5)_"01" D DTBS^CHMEAE8U S X=Y-1 D DATE^CHMEAE8U S CHEND=Y
"RTN","CHMEAE81",237,0)
;S X=$P(CHCD,U,3)+650000,X=$E(X,1,5)_"01" D DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U S CHEND=Y
"RTN","CHMEAE81",238,0)
I $P(CHCD,U,29)'="" S X=$P(CHCD,U,29) D DTBS^CHMEAE8U S X=Y D DATE^CHMEAE8U S CHEND=Y
"RTN","CHMEAE81",239,0)
S:Y<CHEND CHEND=Y
"RTN","CHMEAE81",240,0)
;I ($P(CHCD,U,14)=0),($D(^AHCHVA(DFN,100,BFN,2))),(($P(^(2),U,14)=22)!($P(^(2),U,14)=6)) S X=$P(CHCD,U,3)+1150000,X=$E(X,1,5)_"01" D DTBS^CHMEAE8U S X=Y-1 D DATE^CHMEAE8U S:Y<CHEND CHEND=Y G SET1 ;TLB 07012010
"RTN","CHMEAE81",241,0)
;I ($P(CHCD,U,14)=1),($D(^AHCHVA(DFN,100,BFN,2))),(($P(^(2),U,14)=22)!($P(^(2),U,14)=6)) I $D(^(3)),($P(^(3),U,14)<CHEND) S Y=$P(^(3),U,14) S:Y<CHEND CHEND=Y G SET1 ;TLB 07012010
"RTN","CHMEAE81",242,0)
G END
"RTN","CHMEAE81",243,0)
MARRIAG S X=$P(CHCD,U,31),CHEND="" I X?7N D LEAP,DTBS^CHMEAE8U S X=Y-1 D DATE^CHMEAE8U S CHEND=Y
"RTN","CHMEAE81",244,0)
S X=$P(CHCD,U,3)+650000,X=$E(X,1,5)_"01" D DTBS^CHMEAE8U S X=Y-1 D DATE^CHMEAE8U
"RTN","CHMEAE81",245,0)
S:Y<CHEND CHEND=Y
"RTN","CHMEAE81",246,0)
;I ($P(CHCD,U,14)=0),($D(^AHCHVA(DFN,100,BFN,2))),(($P(^(2),U,14)=22)!($P(^(2),U,14)=6)) S X=$P(CHCD,U,3)+1150000,X=$E(X,1,5)_"01" D DTBS^CHMEAE8U S X=Y-1 D DATE^CHMEAE8U G SET ;TLB 07012010
"RTN","CHMEAE81",247,0)
;I ($P(CHCD,U,14)=1),($D(^AHCHVA(DFN,100,BFN,2))),(($P(^(2),U,14)=22)!($P(^(2),U,14)=6)) I $D(^(3)),($P(^(3),U,14)<CHEND) S Y=$P(^(3),U,14) G SET ;TLB 07012010
"RTN","CHMEAE81",248,0)
G END
"RTN","CHMEAE81",249,0)
STUDENT K A S J=0
"RTN","CHMEAE81",250,0)
I ($P(CHCD,U,3)+180000)'<CHBEG S X=$P(CHCD,U,3)+180000 D LEAP,DTBS^CHMEAE8U S X=Y-1 D DATE^CHMEAE8U S A(1)=CHBEG_U_Y,J=1
"RTN","CHMEAE81",251,0)
F I=0:0 S I=$O(^AHCHVA(DFN,100,BFN,104,I)) Q:'I D
"RTN","CHMEAE81",252,0)
.I $D(^AHCHVA(DFN,100,BFN,104,I,0)) D
"RTN","CHMEAE81",253,0)
..I $P(^AHCHVA(DFN,100,BFN,104,I,0),U)?7N I $P(^AHCHVA(DFN,100,BFN,104,I,0),U,2)?7N D
"RTN","CHMEAE81",254,0)
...S J=J+1,A(J)=^(0)
"RTN","CHMEAE81",255,0)
..S:$P(A(J),U)<CHBEG $P(A(J),U)=CHBEG
"RTN","CHMEAE81",256,0)
..S:(CHPTEND'="")&($P(A(J),U,2)>CHPTEND) $P(A(J),U,2)=CHPTEND K:$P(A(J),U,2)<CHBEG A(J)
"RTN","CHMEAE81",257,0)
G END:'$D(A) S (I,CT)=0
"RTN","CHMEAE81",258,0)
S1 S:'CT I=$O(A(I)) S:CT I=$O(A(I),-1)
"RTN","CHMEAE81",259,0)
I 'I S I=999 G S3:CT S CT=1 G S1
"RTN","CHMEAE81",260,0)
S J=I,CHBEG=$P(A(I),U),CHEND=$P(A(I),U,2)
"RTN","CHMEAE81",261,0)
S X=$P(CHCD,U,3)+230000 S:CHEND>X $P(A(I),U,2)=$$FMADD^XLFDT(X,-1,0,0,0)
"RTN","CHMEAE81",262,0)
S2 S:'CT J=$O(A(J)) S:CT J=$O(A(J),-1) G S1:'J
"RTN","CHMEAE81",263,0)
S CHBEG2=$P(A(J),U),CHEND2=$P(A(J),U,2)
"RTN","CHMEAE81",264,0)
S X=$P(CHCD,U,3)+230000 S:CHEND2>X $P(A(J),U,2)=$$FMADD^XLFDT(X,-1,0,0,0)
"RTN","CHMEAE81",265,0)
S:CHBEG>CHBEG2 X1=CHBEG,X2=CHEND2 S:CHBEG<CHBEG2 X1=CHEND,X2=CHBEG2
"RTN","CHMEAE81",266,0)
I CHBEG=CHBEG2 S:CHEND'<CHEND2 X1=CHBEG,X2=CHEND2 S:CHEND<CHEND2 X1=CHEND,X2=CHBEG2
"RTN","CHMEAE81",267,0)
S X=X1 D LEAP,DTBS^CHMEAE8U S X1=Y,X=X2 D LEAP,DTBS^CHMEAE8U S X2=Y
"RTN","CHMEAE81",268,0)
S X=X1-X2 S:X<0 X=-X
"RTN","CHMEAE81",269,0)
;I X<183 S:CHBEG'>CHBEG2 $P(A(I),U,2)=CHEND2 S:CHBEG>CHBEG2 $P(A(I),U)=CHBEG2 K A(J) S I=0 G S1
"RTN","CHMEAE81",270,0)
; FOR SCHOOL DATE MODS - IF THE 6TH PIECE IS ONE THE BREAK SHOULD BE SET
"RTN","CHMEAE81",271,0)
; IN TRN CHECK ON CUDMORE,JAY SHOULD BE 2990331-2990618 FOR DTD
"RTN","CHMEAE81",272,0)
I 'CT I X<121 I $P(A(J),U,6)'=1 S:CHBEG'>CHBEG2 $P(A(I),U,2)=CHEND2 S:CHBEG>CHBEG2 $P(A(I),U)=CHBEG2 K A(J) S I=0 G S1
"RTN","CHMEAE81",273,0)
I 'CT I X>120 I $P(A(J),U,6)=0 S:CHBEG'>CHBEG2 $P(A(I),U,2)=CHEND2 S:CHBEG>CHBEG2 $P(A(I),U)=CHBEG2 K A(J) S I=0 G S1
"RTN","CHMEAE81",274,0)
I CT I X<121 I $P(A(I),U,6)'=1 S:CHBEG'>CHBEG2 $P(A(I),U,2)=CHEND2 S:CHBEG>CHBEG2 $P(A(I),U)=CHBEG2 K A(J) S I=0 G S1
"RTN","CHMEAE81",275,0)
I CT I X>120 I $P(A(I),U,6)=0 S:CHBEG'>CHBEG2 $P(A(I),U,2)=CHEND2 S:CHBEG>CHBEG2 $P(A(I),U)=CHBEG2 K A(J) S I=0 G S1
"RTN","CHMEAE81",276,0)
S I=J-1 G S1
"RTN","CHMEAE81",277,0)
S3 S I=0,I=$O(A(I)) G:I="" S3A
"RTN","CHMEAE81",278,0)
I $D(^AHCHVA(DFN,100,BFN,4)) I $P(^(4),U,3)'="" S:CHBEG>$P(^(4),U,3) $P(A(I),U)=$P(^(4),U,3)
"RTN","CHMEAE81",279,0)
S3A ;F I=0:0 S I=$O(A(I)) Q:'I S CHBEG=$P(A(I),U),CHEND=$P(A(I),U,2) I (CHBEG?7N),(CHEND?7N) S ^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND)=DUZ_U_CHNOW S:$P(CHCD,U,5)="EA" ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_U_CHNOW ;REMOVED TLH 7/27/06 MC254/PROJECT 1500
"RTN","CHMEAE81",280,0)
F I=0:0 S I=$O(A(I)) Q:'I S CHBEG=$P(A(I),U),CHEND=$P(A(I),U,2) I (CHBEG?7N),(CHEND?7N) S ^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND)=DUZ_U_CHNOW S ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_U_CHNOW
"RTN","CHMEAE81",281,0)
K A G END
"RTN","CHMEAE81",282,0)
LEAP S:$E(X,4,7)="0229" $E(X,6,7)=28
"RTN","CHMEAE81",283,0)
Q
"RTN","CHMEAE81",284,0)
SINEL S Y=0,CHDT=9999999
"RTN","CHMEAE81",285,0)
I $D(^AHCHVA(DFN,3)),$P(^(3),U,5)'="" S Y=$P(^(3),U,5) Q:Y?7N
"RTN","CHMEAE81",286,0)
SI1 S CHDT=$O(^AHCHVA(DFN,101,CHDT),-1) Q:'CHDT G SI1:'$D(^(CHDT,0))
"RTN","CHMEAE81",287,0)
I $P(^(0),U,5)="I" S Y=$P(CHDT,".") Q:Y?7N
"RTN","CHMEAE81",288,0)
G SI1
"RTN","CHMEAE81",289,0)
BINEL S Y=0,CHDT=9999999
"RTN","CHMEAE81",290,0)
I $P(^AHCHVA(DFN,100,BFN,0),"^",6)'="" S CHEND=$P(^AHCHVA(DFN,100,BFN,0),U,6) Q:CHEND?7N ;AEB 1/2/2008
"RTN","CHMEAE81",291,0)
I $P(^AHCHVA(DFN,100,BFN,0),"^",12)="W55" I $P(^AHCHVA(DFN,100,BFN,0),"^",8)'="" S CHEND=$P(^AHCHVA(DFN,100,BFN,0),"^",8) Q:CHEND?7N ;TLH 1/2/2008 BUG003054
"RTN","CHMEAE81",292,0)
I $D(^AHCHVA(DFN,100,BFN,3)),$P(^(3),U,5)'="" S Y=$P(^(3),U,5) Q:Y?7N
"RTN","CHMEAE81",293,0)
BI1 S CHDT=$O(^AHCHVA(DFN,101,CHDT),-1) Q:'CHDT G BI1:'$D(^(CHDT,100,BFN,0))
"RTN","CHMEAE81",294,0)
I $P(^(0),U,5)="D" S Y=$P(CHDT,".") Q:Y?7N
"RTN","CHMEAE81",295,0)
G BI1
"RTN","CHMEAE81",296,0)
;
"RTN","CHMEAE81",297,0)
120CHK ; CHECK FOR 120TH BIRTHDAY AS AN ENDING DATE FOR BENES UNDER 65 WITH MEDICARE INFORMATION ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",298,0)
I $D(AGE) Q:AGE'<65 ;AEB 1-19-2016
"RTN","CHMEAE81",299,0)
S MEDFLG=$P(^AHCHVA(DFN,100,BFN,0),"^",32) ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",300,0)
I (MEDFLG=1)!(MEDFLG=3)!(MEDFLG="")!(MEDFLG=0) Q ;TLH 4/10/07 ENC000188 ;YJK 7/9/2010 DEV009699 (added (MEDFLG=0)
"RTN","CHMEAE81",301,0)
S X=$P(^AHCHVA(DFN,100,BFN,0),"^",3)+650000 ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",302,0)
S DOB65=$$FMADD^XLFDT(X,-1,0,0,0) ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",303,0)
S CHBEG=9999999 ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",304,0)
ELIG1 S CHBEG=$O(^AHCHVA(DFN,100,BFN,109,CHBEG),-1) Q:'CHBEG ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",305,0)
S CHEND=9999999 ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",306,0)
ELIG2 S CHEND=$O(^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND),-1) G:'CHEND ELIG1 ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",307,0)
I CHEND'=DOB65 Q ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",308,0)
I (CHEMDA'=""&&(CHEMDB'="")) Q ;JAKMEDICARE BYPASS IF OPEN MED A AND MED B DATES DEF25745 02/27/2018
"RTN","CHMEAE81",309,0)
K ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND) ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",310,0)
K ^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND) ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",311,0)
S X=$P(^AHCHVA(DFN,100,BFN,0),"^",3)+1200000 ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",312,0)
S ^AHCHVA(DFN,100,BFN,105,CHBEG,X)=DUZ_U_CHNOW ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",313,0)
S ^AHCHVA(DFN,100,BFN,109,CHBEG,X)=DUZ_U_CHNOW ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",314,0)
Q ;TLH 4/10/07 ENC000188
"RTN","CHMEAE81",315,0)
DECEASED ;YJK 5/24/2010 BUG008682-06-05
"RTN","CHMEAE81",316,0)
NEW MEDABDT,MEDAEDT,TMPEND,T65BD,MEDBBDT,MEDBEDT,TMPAR
"RTN","CHMEAE81",317,0)
S (MEDABDT,MEDAEDT,TMPEND,T65BD,MEDBBDT,MEDBEDT)=""
"RTN","CHMEAE81",318,0)
S T65BD=$P(CHCD,"^",3)+650000
"RTN","CHMEAE81",319,0)
I $P(CHCD,"^",32)=1 D
"RTN","CHMEAE81",320,0)
.S MEDDT=9999999
"RTN","CHMEAE81",321,0)
.S MEDDT=$O(^AHCHVA(DFN,100,BFN,111,MEDDT),-1)
"RTN","CHMEAE81",322,0)
.S:$G(MEDDT)'="" MEDABDT=$P(^AHCHVA(DFN,100,BFN,111,MEDDT,0),"^",1),MEDAEDT=$P(^AHCHVA(DFN,100,BFN,111,MEDDT,0),"^",4),TMPAR(MEDABDT)="E"
"RTN","CHMEAE81",323,0)
.S MEDDT=9999999
"RTN","CHMEAE81",324,0)
.S MEDDT=$O(^AHCHVA(DFN,100,BFN,112,MEDDT),-1)
"RTN","CHMEAE81",325,0)
.S:$G(MEDDT)'="" MEDBBDT=$P(^AHCHVA(DFN,100,BFN,112,MEDDT,0),"^",1),MEDBEDT=$P(^AHCHVA(DFN,100,BFN,112,MEDDT,0),"^",4)
"RTN","CHMEAE81",326,0)
.I MEDBBDT'="" S TMPAR(MEDBBDT)="S"
"RTN","CHMEAE81",327,0)
.I MEDBEDT'="" I MEDBEDT>MEDABDT S TMPAR(MEDBEDT)="E"
"RTN","CHMEAE81",328,0)
.S TMPEND=0 D SETEND
"RTN","CHMEAE81",329,0)
.I (TMPEND'="")&(T65BD>=3010605)&(MEDABDT'="")&((MEDAEDT="")!(MEDAEDT>$P(CHCD,"^",6))&(MEDABDT<$P(CHCD,"^",6))&(T65BD>=3010605)) S ^AHCHVA(DFN,100,BFN,109,CHBEG,TMPEND)=DUZ_U_CHNOW,^AHCHVA(DFN,100,BFN,105,CHBEG,TMPEND)=DUZ_U_CHNOW Q
"RTN","CHMEAE81",330,0)
.E S ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_U_CHNOW,^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND)=DUZ_U_CHNOW Q
"RTN","CHMEAE81",331,0)
E S ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_U_CHNOW,^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND)=DUZ_U_CHNOW
"RTN","CHMEAE81",332,0)
Q
"RTN","CHMEAE81",333,0)
SETEND ;
"RTN","CHMEAE81",334,0)
S TMPEND=$O(TMPAR(TMPEND)) Q:'TMPEND
"RTN","CHMEAE81",335,0)
G:TMPAR(TMPEND)'="E" SETEND
"RTN","CHMEAE81",336,0)
I TMPEND>CHEND!(TMPEND="") S TMPEND=CHEND
"RTN","CHMEAE81",337,0)
Q
"RTN","CHMEAE8U")
0^23^B455962457
"RTN","CHMEAE8U",1,0)
CHMEAE8U ;CVA/DTP;UTILITIES FOR BEGIN/END ELIGIBILITY CALC;Jan 08, 2019@09:23:57
"RTN","CHMEAE8U",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAE8U",3,0)
;;CPTS #10650* BY DTP (25-JULY-96)
"RTN","CHMEAE8U",4,0)
;CPTS 11761 BY CAM 12219
"RTN","CHMEAE8U",5,0)
;CPTS 12219 BY DTP (8-AUG-97), CPTS #11032 BY DTP (27-APR-98)
"RTN","CHMEAE8U",6,0)
;CPTS 15328 BY DTP (24-JUL-98)*
"RTN","CHMEAE8U",7,0)
;;see ^CHMXLUE2 for anothwer CMOP check.
"RTN","CHMEAE8U",8,0)
;YJK 3/12/2010 DEV008682 - Benes under 65 with Medicare A only do not calculate correctly
"RTN","CHMEAE8U",9,0)
;SKD 7/29/10 BUG009803 - RW error
"RTN","CHMEAE8U",10,0)
;YJK 10/26/10 DEV009825-05 - OHI Coverage Code 22
"RTN","CHMEAE8U",11,0)
;DEV012197-01 YJK 4/6/11 CAREGIVER
"RTN","CHMEAE8U",12,0)
;BUG012197-03-03 YJK 5/12/2011 Let CG go thru CMOP logic
"RTN","CHMEAE8U",13,0)
;DEV012503-01 YJK 6/6/2011 Remarried Widow of DOAD
"RTN","CHMEAE8U",14,0)
;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE8U",15,0)
;DEV014754-02 YJK 8/6/12
"RTN","CHMEAE8U",16,0)
;ENC22734 JEH 3/12/15 - Enhancement of Cache Systems to support Retired Reservists Functionality
"RTN","CHMEAE8U",17,0)
;CPE-US005 BDB 12/28/18 - Fix coding error in DISCHK(DFN,BFN)
"RTN","CHMEAE8U",18,0)
;ACA US017 BDB 1/14/19 Re-enrollment check
"RTN","CHMEAE8U",19,0)
CMOPCHK ;
"RTN","CHMEAE8U",20,0)
I $D(^AHCHVA(DFN,100,BFN,0)) I $P(^AHCHVA(DFN,100,BFN,0),"^",4)="CG" D ^CHCGCMOP ;DEV012197-01 YJK 4/6/11 ;BUG012197-03-03
"RTN","CHMEAE8U",21,0)
K CMPKEEP,CHBNCMP
"RTN","CHMEAE8U",22,0)
D NOW^%DTC S CHNOW=%
"RTN","CHMEAE8U",23,0)
I '$D(DT) D NOW^%DTC S DT=X
"RTN","CHMEAE8U",24,0)
S CHDFNI=0,CHDFNI=$O(^CHMDFN("B",DFN,0)) Q:'CHDFNI
"RTN","CHMEAE8U",25,0)
S CHDFNJ=0,CHDFNJ=$O(^CHMDFN(CHDFNI,100,"B",BFN,CHDFNJ)) Q:'CHDFNJ
"RTN","CHMEAE8U",26,0)
Q:'$D(^CHMDFN(CHDFNI,100,CHDFNJ,5))
"RTN","CHMEAE8U",27,0)
S CHDFNK=9999,CHDFNK=$O(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK),-1) Q:'CHDFNK
"RTN","CHMEAE8U",28,0)
I '$D(^AHCHVA(DFN,100,BFN,109)) D INELG G CMPKILL ;AEB 10/8/2008 DEV005390
"RTN","CHMEAE8U",29,0)
S CHBEDT=0
"RTN","CHMEAE8U",30,0)
CP1 S CHBEDT=$O(^AHCHVA(DFN,100,BFN,109,CHBEDT)) G:'CHBEDT CMP2 ;MUST BE ea AND HAVE CURRENT ELIG PERODS
"RTN","CHMEAE8U",31,0)
S CHEEDT=0
"RTN","CHMEAE8U",32,0)
CP2 S CHEEDT=$O(^AHCHVA(DFN,100,BFN,109,CHBEDT,CHEEDT)) G:CHEEDT="" CP1
"RTN","CHMEAE8U",33,0)
S CHEAFLG="" ;USED ONLY AT CMP2 - IF DEFINED BENE IS ELIG
"RTN","CHMEAE8U",34,0)
I CHBEDT>DT K CHEAFLG ; D INELG G CMPKILL ;BEGIN IN THE FUTURE
"RTN","CHMEAE8U",35,0)
I CHEEDT<DT K CHEAFLG ; D INELG G CMPKILL ;END IN THE PAST
"RTN","CHMEAE8U",36,0)
I $D(CHEAFLG) G CMP2 ;BUG012197-03-03 YJK 5/12/2011 - for multiple 109 entries with future date
"RTN","CHMEAE8U",37,0)
G CP2
"RTN","CHMEAE8U",38,0)
CMP2 I '$D(CHEAFLG) D INELG G CMPKILL
"RTN","CHMEAE8U",39,0)
K CHEAFLG D MDDDATE^CHMEAE6F I CHMDD=0 D INELG G CMPKILL ;AEB 6/22/2009 DEV007436 ADDED LINE for MED D CHK
"RTN","CHMEAE8U",40,0)
S CHDFNOHK=9999 ;FIN CURRENT OHI SEGMENT
"RTN","CHMEAE8U",41,0)
CMPLP3 S CHDFNOHK=$O(^CHMDFN(CHDFNI,100,CHDFNJ,2,CHDFNOHK),-1) I 'CHDFNOHK G NEXT
"RTN","CHMEAE8U",42,0)
G:'$D(^CHMDFN(CHDFNI,100,CHDFNJ,2,CHDFNOHK,0)) CMPLP3
"RTN","CHMEAE8U",43,0)
S CMOPTY=$P(^CHMDFN(CHDFNI,100,CHDFNJ,2,CHDFNOHK,0),"^",3),CMOPSR=$P(^(0),"^",6),CMOPSDT=$P(^(0),"^"),CMOPEDT=$P(^(0),"^",2)
"RTN","CHMEAE8U",44,0)
G:DT<CMOPSDT CMPLP3 G:CMOPEDT="" CMPLP3N G:DT>CMOPEDT CMPLP3
"RTN","CHMEAE8U",45,0)
CMPLP3N I (CMOPSR'=3)&(CMOPSR'=4)&(CMOPSR'=5) G CMPLP3 ;MUST HAVE OHI SOURCE AS ELG,CERT,INQ
"RTN","CHMEAE8U",46,0)
S EAFLG=""
"RTN","CHMEAE8U",47,0)
;OHI TYPE OF COVERAGE MUST BE 1,4,5,6,7,8,12,14,16,OR 19 ; Removed 22 from comment - YJK 10/26/10 DEV009825-05
"RTN","CHMEAE8U",48,0)
I CMOPTY=2 D INELG G CMPKILL
"RTN","CHMEAE8U",49,0)
I CMOPTY=3 D INELG G CMPKILL
"RTN","CHMEAE8U",50,0)
I CMOPTY=8 D INELG G CMPKILL
"RTN","CHMEAE8U",51,0)
I CMOPTY=10 D INELG G CMPKILL
"RTN","CHMEAE8U",52,0)
I CMOPTY=11 D INELG G CMPKILL
"RTN","CHMEAE8U",53,0)
I CMOPTY=13 D INELG G CMPKILL
"RTN","CHMEAE8U",54,0)
I CMOPTY=15 D INELG G CMPKILL
"RTN","CHMEAE8U",55,0)
I CMOPTY=17 D INELG G CMPKILL
"RTN","CHMEAE8U",56,0)
I CMOPTY=18 D INELG G CMPKILL
"RTN","CHMEAE8U",57,0)
I CMOPTY=20 D INELG G CMPKILL
"RTN","CHMEAE8U",58,0)
I CMOPTY=21 D INELG G CMPKILL
"RTN","CHMEAE8U",59,0)
I CMOPTY=22 D INELG G CMPKILL ;YJK 10/26/10 DEV009825-05
"RTN","CHMEAE8U",60,0)
I CMOPTY=23 D INELG G CMPKILL
"RTN","CHMEAE8U",61,0)
I CMOPTY=24 D INELG G CMPKILL
"RTN","CHMEAE8U",62,0)
;G CMPLP3
"RTN","CHMEAE8U",63,0)
NEXT I '$D(EAFLG) D INELG G CMPKILL
"RTN","CHMEAE8U",64,0)
I $D(^CHMDIC(741002.83,"CMOP",DFN,BFN)) S CHBNCMP="" G CMPLP5
"RTN","CHMEAE8U",65,0)
G:'$D(^AHCHVA(DFN,100,BFN,1)) CMPKILL S CMOPST=$P(^(1),"^",4)
"RTN","CHMEAE8U",66,0)
I 'CMOPST D INELG G CMPKILL ;ADDED FOR AEB 10/8/2008 DEV005390
"RTN","CHMEAE8U",67,0)
I $D(^CHMDIC(741002.83,"B",CMOPST)) S CHBNCMP=""
"RTN","CHMEAE8U",68,0)
CMPLP5 ;
"RTN","CHMEAE8U",69,0)
D NOW^%DTC S CHNOW=%
"RTN","CHMEAE8U",70,0)
I $D(CHBNCMP) D G CMPKILL ;IF PLACE OF RESIDIENCE IS DEFINED IN GLOBAL THEN STATUS IS EA
"RTN","CHMEAE8U",71,0)
.S CPOLDRC=^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0)
"RTN","CHMEAE8U",72,0)
.I $P(CPOLDRC,"^",3)=1 I $P(CPOLDRC,"^",4)="ELG" Q ; NO CHANGE QUIT
"RTN","CHMEAE8U",73,0)
.S ^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,101,CHNOW,0)=CPOLDRC
"RTN","CHMEAE8U",74,0)
.S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",3)=1,$P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",4)="ELG"
"RTN","CHMEAE8U",75,0)
.S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",5)=CHBEDT,$P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",6)=DUZ,$P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",7)=CHNOW
"RTN","CHMEAE8U",76,0)
.S ^CHMZHOLD("CMOP-ADD",DT,DFN,BFN,CHDFNI,CHDFNJ)=""
"RTN","CHMEAE8U",77,0)
.S CHDFN=DFN,DFNI=CHDFNI,DFNJ=CHDFNJ D RXCNT^CHMXCPCC,DATASET^CHMXCPCC ; ,LTRSET^CHMXCPCC
"RTN","CHMEAE8U",78,0)
.S:CHST="" ST="UNK" S:CHST'="" ST=CHST
"RTN","CHMEAE8U",79,0)
.S ^CHMZHOLD("CMOP-ELIGIBLES",DT,ST,CHDFN,BFN)=CHACRD_"^"_CHSTS_"^"_CHEEDT_"^"_CMOPSDT_"^"_CMOPEDT_"^"_CMOPTY_"^"_CHBEN_"^"_CHSSN_"^"_CHDOB_"^"_CHADD1_"^"_CHADD2_"^"_CHCTY_"^"_CHST_"^"_CHZP_"^"_CHRXI
"RTN","CHMEAE8U",80,0)
.S DPTX=CHBEN D ^CHMXCPAA ;CAUSES DOB TO BE DISPLYED WHEN %dt IS CALLED IN THIS ROUTINE
"RTN","CHMEAE8U",81,0)
;IF PLACE OF RESIDIENCE NOT DEFINED IN GLOBAL THEN STATUS IS EI
"RTN","CHMEAE8U",82,0)
S CPOLDRC=^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0)
"RTN","CHMEAE8U",83,0)
I $P(CPOLDRC,"^",3)=2 I $P(CPOLDRC,"^",4)="ELG" Q ; NO CHANGE QUIT
"RTN","CHMEAE8U",84,0)
S ^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,101,CHNOW,0)=CPOLDRC
"RTN","CHMEAE8U",85,0)
S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",3)=2,$P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",4)="ELG"
"RTN","CHMEAE8U",86,0)
S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",5)=CHBEDT,$P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",6)=DUZ,$P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",7)=CHNOW
"RTN","CHMEAE8U",87,0)
CMPKILL K CMPKEEP,CHDFNI,CHDFNJ,CHDFNK,CHKDT,CHKDTM,CHBEDT,CHEEDT,CPOLDRC
"RTN","CHMEAE8U",88,0)
K CMOPTY,CMOPSR,CMOPST,OHISRFG,CHDFNOHK,CHBNCMP,EAFLG,CHEAFLG
"RTN","CHMEAE8U",89,0)
Q
"RTN","CHMEAE8U",90,0)
;
"RTN","CHMEAE8U",91,0)
INELG ;SET BENE CMOP ELIGIBILITY TO INELIGIBLE ;SUBRTN ADDED AEB 10/8/2008 DEV005390
"RTN","CHMEAE8U",92,0)
S CPOLDRC=^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0)
"RTN","CHMEAE8U",93,0)
I $P(CPOLDRC,"^",3)=0 I $P(CPOLDRC,"^",4)="ELG" Q ; NO CHANGE QUIT
"RTN","CHMEAE8U",94,0)
S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",3)=0
"RTN","CHMEAE8U",95,0)
S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",4)="ELG"
"RTN","CHMEAE8U",96,0)
S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",5)=0
"RTN","CHMEAE8U",97,0)
S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",6)=DUZ
"RTN","CHMEAE8U",98,0)
S $P(^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,0),"^",7)=CHNOW
"RTN","CHMEAE8U",99,0)
S ^CHMDFN(CHDFNI,100,CHDFNJ,5,CHDFNK,101,CHNOW,0)=CPOLDRC ;AEB 6/22/2009 DEV007436 ADDED LINE
"RTN","CHMEAE8U",100,0)
Q
"RTN","CHMEAE8U",101,0)
;
"RTN","CHMEAE8U",102,0)
DATE S Y="" Q:X'?5N D ZDATE S Y=$E(Y,7,10)-1700_$E(Y,1,2)_$E(Y,4,5) Q
"RTN","CHMEAE8U",103,0)
ZDATE I X'?1N.N S Y="" Q
"RTN","CHMEAE8U",104,0)
S %a=$S(X<21915:0,1:X-21914\36524+1),%a=X+%a-(%a+2\4),%b=%a#1461
"RTN","CHMEAE8U",105,0)
S %f=$E(%b*.00273785,1),%y=%a\1461*4+1841+%f
"RTN","CHMEAE8U",106,0)
S %m=101,%d=%b-(%f*365) I %d=0 S %m=112,%y=%y-1,%d=31 G ZDATEQ
"RTN","CHMEAE8U",107,0)
F %i=31,$S(%y#100:%y#4=0,1:%y#400=0)+28,31,30,31,30,31,31,30,31,30 Q:%i'<%d S %m=%m+1,%d=%d-%i
"RTN","CHMEAE8U",108,0)
ZDATEQ S Y=$E(%m,2,3)_"/"_$E(%d+100,2,3)_"/"_$E(%y,1,4) K %a,%b,%d,%f,%i,%m,%y Q
"RTN","CHMEAE8U",109,0)
DTBS S %M=+$E(X,4,5),%D=+$E(X,6,7),%Y=$E(X,1,3)+1700
"RTN","CHMEAE8U",110,0)
I %M<1!(%M>12)!(%D<1)!(%D>31)!(%Y<1841) S Y=-1 G DTBSK
"RTN","CHMEAE8U",111,0)
S %L=0 I %Y#4=0,'(%Y=1900) S %L=1
"RTN","CHMEAE8U",112,0)
I %D>30,%M=4!(%M=6)!(%M=9)!(%M=11) S Y=-1 G DTBSK
"RTN","CHMEAE8U",113,0)
I %M=2,%L=0*(%D>28)!(%L=1*(%D>29)) S Y=-1 G DTBSK
"RTN","CHMEAE8U",114,0)
I %L=0 S %J=$P("0,31,59,90,120,151,181,212,243,273,304,334",",",%M)+%D
"RTN","CHMEAE8U",115,0)
E S %J=$P("0,31,60,91,121,152,182,213,244,274,305,335",",",%M)+%D
"RTN","CHMEAE8U",116,0)
S Y=%J+(%Y-1841*365)+(%Y-1841\4)-(%Y>1900*1)
"RTN","CHMEAE8U",117,0)
DTBSK K %D,%J,%L,%M,%Y Q
"RTN","CHMEAE8U",118,0)
;
"RTN","CHMEAE8U",119,0)
DTSET ;SET END ELIG DATE
"RTN","CHMEAE8U",120,0)
; I BEG DATE > 10-31-90 SET END ELIG DATE=BEG ELIG DATE + 1
"RTN","CHMEAE8U",121,0)
; I BEG DATE < 10-31-90 SET END ELIG DATE = 10-31-90
"RTN","CHMEAE8U",122,0)
S I1=DFN,J1=BFN
"RTN","CHMEAE8U",123,0)
D NOW^%DTC S X1=X
"RTN","CHMEAE8U",124,0)
S BGDT=CHBEG
"RTN","CHMEAE8U",125,0)
I BGDT="" S BGDT=X1 S EDDT=$$FMADD^XLFDT(BGDT,1,0,0,0) G D1
"RTN","CHMEAE8U",126,0)
I BGDT'<2901031 S EDDT=$$FMADD^XLFDT(BGDT,1,0,0,0)
"RTN","CHMEAE8U",127,0)
I BGDT<2901031 S EDDT=2901031
"RTN","CHMEAE8U",128,0)
D1 S:(BGDT?7N)&(EDDT?7N) ^AHCHVA(DFN,100,BFN,105,BGDT,EDDT)=DUZ_"^"_CHNOW
"RTN","CHMEAE8U",129,0)
S:(BGDT?7N)&(EDDT?7N) ^AHCHVA(DFN,100,BFN,109,BGDT,EDDT)=DUZ_"^"_CHNOW
"RTN","CHMEAE8U",130,0)
;
"RTN","CHMEAE8U",131,0)
S CHBEG=BGDT,CHEND=EDDT K I1,J1,BGDT,EDDT,X1
"RTN","CHMEAE8U",132,0)
S ^CHMZHOLD("ELIGIBILITY BEG DATE ",CHBEG)=""
"RTN","CHMEAE8U",133,0)
S ^CHMZHOLD("ELIGIBILTY END DATE ",CHEND)=""
"RTN","CHMEAE8U",134,0)
Q
"RTN","CHMEAE8U",135,0)
;
"RTN","CHMEAE8U",136,0)
CLEANUP S CHBEG="",LOOP=0
"RTN","CHMEAE8U",137,0)
C1 S:'LOOP CHBEG=$O(^AHCHVA(DFN,100,BFN,INDX,CHBEG))
"RTN","CHMEAE8U",138,0)
S:LOOP CHBEG=$O(^AHCHVA(DFN,100,BFN,INDX,CHBEG),-1)
"RTN","CHMEAE8U",139,0)
I 'CHBEG Q:LOOP S CHBEG=9999999,LOOP=1 G C1
"RTN","CHMEAE8U",140,0)
S CHEND=""
"RTN","CHMEAE8U",141,0)
C2 S:'LOOP CHEND=$O(^AHCHVA(DFN,100,BFN,INDX,CHBEG,CHEND))
"RTN","CHMEAE8U",142,0)
S:LOOP CHEND=$O(^AHCHVA(DFN,100,BFN,INDX,CHBEG,CHEND),-1)
"RTN","CHMEAE8U",143,0)
G C1:'CHEND S X=CHBEG,Y=CHEND G C4
"RTN","CHMEAE8U",144,0)
C3 S:'LOOP X=$O(^AHCHVA(DFN,100,BFN,INDX,X))
"RTN","CHMEAE8U",145,0)
S:LOOP X=$O(^AHCHVA(DFN,100,BFN,INDX,X),-1)
"RTN","CHMEAE8U",146,0)
G C2:'X S Y=""
"RTN","CHMEAE8U",147,0)
C4 S:'LOOP Y=$O(^AHCHVA(DFN,100,BFN,INDX,X,Y))
"RTN","CHMEAE8U",148,0)
S:LOOP Y=$O(^AHCHVA(DFN,100,BFN,INDX,X,Y),-1)
"RTN","CHMEAE8U",149,0)
G C3:'Y I (X'<CHBEG),(Y'>CHEND) K ^AHCHVA(DFN,100,BFN,INDX,X,Y)
"RTN","CHMEAE8U",150,0)
I CHEND=X K ^AHCHVA(DFN,100,BFN,INDX,CHBEG,CHEND),^AHCHVA(DFN,100,BFN,INDX,X,Y) S ^AHCHVA(DFN,100,BFN,INDX,CHBEG,Y)=DUZ_"^"_CHNOW G CLEANUP
"RTN","CHMEAE8U",151,0)
G C4
"RTN","CHMEAE8U",152,0)
;
"RTN","CHMEAE8U",153,0)
TERM ; ADDED FOR TERMINATION OF REMARRAGE OF A BENE WHO MARRIES PRIOR TO 55 TO RE-ESTABLISH ELIGIBILITY FOR DEF001764
"RTN","CHMEAE8U",154,0)
S DOB=$P(^AHCHVA(DFN,100,BFN,0),"^",3)
"RTN","CHMEAE8U",155,0)
S REMDT=$P(^AHCHVA(DFN,100,BFN,0),"^",8)
"RTN","CHMEAE8U",156,0)
I REMDT'="" S AGE=$$AGE^CHTFLIB(DOB,REMDT) I AGE>55 D G TEM1 ;TLH 6/18/08 DEV005104
"RTN","CHMEAE8U",157,0)
.S CHBEG=$P(CHCD,"^",10) D RMA54A^CHMEAE83 ;TLH 6/18/08 DEV005104
"RTN","CHMEAE8U",158,0)
.S Y=CHEND ;TLH 6/18/08 DEV005104
"RTN","CHMEAE8U",159,0)
.S CHTBEG=0,SFLG=0 ;TLH 6/23/08 DEV005104
"RTN","CHMEAE8U",160,0)
.Q ;TLH 6/18/08 DEV005104
"RTN","CHMEAE8U",161,0)
K TA S CHTERBEG=CHBEG ;TLH 2/19/08 BUG003054
"RTN","CHMEAE8U",162,0)
S (CHTERDT,Y)=$P(CHCD,"^",7),CHBEG=CHTERBEG ;TLH 2/19/08 BUG003054
"RTN","CHMEAE8U",163,0)
I CHTERDT<3011001 D MEDP^CHMEAE8A K ^AHCHVA(DFN,100,BFN,109),^AHCHVA(DFN,100,BFN,105) ;TLH 02/19/08 BUG003054
"RTN","CHMEAE8U",164,0)
S CHDAYS=+$E(CHTERDT,6,7)-1 S CHBEG=CHTERBEG
"RTN","CHMEAE8U",165,0)
I $E(Y,4,5)'=12 S Y=$$FMADD^XLFDT(CHTERDT,-CHDAYS,,,)+100,CHRTD1=Y ;TLH 8/13/07 SET TO FIRST DAY OF MONTH AFTER TERM DATE DEF003054
"RTN","CHMEAE8U",166,0)
I $E(Y,4,5)=12 D ;TLH 8/13/07 SET TO FIRST DAY OF MONTH WHEN YEAR CHANGES DEF003054
"RTN","CHMEAE8U",167,0)
.S Y=$$FMADD^XLFDT(CHTERDT,-CHDAYS,,,) ;TLH 8/13/07 DEF003054
"RTN","CHMEAE8U",168,0)
.S TEST=+$E(Y,1,3)+1 ;TLH 8/13/07 GET NEXT YEAR (CYY) DEF003054
"RTN","CHMEAE8U",169,0)
.S CHRTD1=TEST_"01"_$E(Y,6,7) ;8/13/07 SET = Y - CENTURY+YY; NEXT YEAR 01 - JANUARY; $E(Y,6,7) - DAY DEF003054
"RTN","CHMEAE8U",170,0)
.Q ;TLH 8/13/07 DEF003054
"RTN","CHMEAE8U",171,0)
;CHRTD1 = 1ST DAY OF MONTH AFTER TERMINATION OF REMARRIAGE DATE
"RTN","CHMEAE8U",172,0)
S TA(CHBEG)="S"
"RTN","CHMEAE8U",173,0)
S TAQEDT=$P(CHCD,"^",10)
"RTN","CHMEAE8U",174,0)
S:$G(TAQEDT) TA(TAQEDT)="S" ;QE DATE ;SKD 7-29-10 BUG009803
"RTN","CHMEAE8U",175,0)
S:$P(CHCD,"^",8)'="" TA($P(CHCD,"^",8))="E" ;REMARRIED DATE
"RTN","CHMEAE8U",176,0)
S TA65BD=$P(CHCD,"^",3)+650000 S X=$$FMADD^XLFDT(TA65BD,-1,0,0,0) S TA65BD=X
"RTN","CHMEAE8U",177,0)
S TA(TA65BD)="E"
"RTN","CHMEAE8U",178,0)
S TRMSTART="" ;DEV011487-01 YJK 7/26/2011 "TRMSTART" HOLDS THE FINAL FOR "TA" START DATE FOR THE ADJUSTMENTS ACCORDING TO THE REMAR_TERM_DATE BELOW
"RTN","CHMEAE8U",179,0)
I $P(CHCD,"^",7)<2901101 I $P(CHCD,"^",7)>2730901 S TA(CHRTD1)="S",TRMSTART=CHRTD1 I CHRTD1<TAQEDT K TA(CHRTD1) S TA(TAQEDT)="S",TRMSTART=TAQEDT ;TLH 6/20/08 DEV005104 ;REMARRIAGE END DATE ;TLH 10/02/07 BUG003054 ;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE8U",180,0)
I $P(CHCD,"^",7)>2991201 S TA(CHRTD1)="S",TRMSTART=CHRTD1 ;TLH 7/9/08 BUG005104 ;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE8U",181,0)
I $P(CHCD,"^",7)>2901100 I $P(CHCD,"^",7)<2991130 D ;TLH 10/02/07 BUG003054
"RTN","CHMEAE8U",182,0)
.S TA(2991201)="S",TRMSTART=2991201 ;TLH 10/02/07 BUG003054 ;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE8U",183,0)
.I CHRTD1>2991201 D Q ; TLH 10/02/07 BUG003054
"RTN","CHMEAE8U",184,0)
..S TA(CHRTD1)="S",TRMSTART=CHRTD1 ;TLH 10/02/07 BUG003054 ;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE8U",185,0)
..K TA(2991201) ;TLH 10/02/07 BUG003054
"RTN","CHMEAE8U",186,0)
..Q ;TLH 10/02/07 BUG003054
"RTN","CHMEAE8U",187,0)
;.I CHRTD1<2991201 D Q ;REMOVED TO HAVE EVANGELINE J COOPER TO HAVE SPLIT DATES QE DATE TO REMARRIAGE, TERMINATION TO ENDING DATE
"RTN","CHMEAE8U",188,0)
;..K TA(CHBEG)
"RTN","CHMEAE8U",189,0)
I '$D(DT) D NOW^%DTC S DT=X ;DEV014754-02 YJK 8/6/12
"RTN","CHMEAE8U",190,0)
S AGE=$$AGE^CHTFLIB($P(CHCD,"^",3),DT) ;DEV014754-02 YJK 8/6/12
"RTN","CHMEAE8U",191,0)
I TA65BD<3011001 I $P(CHCD,"^",32)>0 I CHBEG'=2991201 K TA(2991201) ;TLH 2/21/08 RECOGNIZE MEDICARE DATES OVER TERM DATE ;TLH 3/10/09 ISSUE W/12/01/1999 QE DATES
"RTN","CHMEAE8U",192,0)
;I $P(CHCD,"^",7)>3011001 S TA120BD=$P(CHCD,"^",3)+1200000,TA(CHRTD1)="S",TA(TA120BD)="E" I TRMSTART'="" I TRMSTART<TA65BD K TA(TA65BD) ;TLH 2/21/08 RECOGNIZE TERM DATE OVER MEDICARE DATE ;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE8U",193,0)
I $P(CHCD,"^",7)>3011001 S TA120BD=$P(CHCD,"^",3)+1200000,TA(CHRTD1)="S",TA(TA120BD)="E" I TRMSTART'="" I TRMSTART<TA65BD&(AGE>=65) K TA(TA65BD) ;TLH 2/21/08 RECOGNIZE TERM DATE OVER MEDICARE DATE ;DEV014754-02 YJK 8/6/12
"RTN","CHMEAE8U",194,0)
I $P(CHCD,"^",10)>2991201 D ;TLH 1/14/2008 BUG003054
"RTN","CHMEAE8U",195,0)
.S TA(TAQEDT)="S" ;TLH 1/14/2008 BUG003054
"RTN","CHMEAE8U",196,0)
.K TA(2991201) ;TLH 2/27/08
"RTN","CHMEAE8U",197,0)
.Q ;TLH 1/14/2008 BUG003054
"RTN","CHMEAE8U",198,0)
S CHTBEG=0,SFLG=0
"RTN","CHMEAE8U",199,0)
I $P(CHCD,"^",32)=0 S TA120BD=$P(CHCD,"^",3)+1200000,TA(TA120BD)="E" I TRMSTART'="" I TRMSTART<TA65BD K TA(TA65BD) ;TLH ;DEV011487-01 YJK 7/26/2011
"RTN","CHMEAE8U",200,0)
I ($P(CHCD,U,18)=1)&($P(CHCD,U,4)'="C") I $P(^AHCHVA(DFN,0),"^",19)=1 G TEM1 ;DEV012503-01 YJK 6/6/2011
"RTN","CHMEAE8U",201,0)
;=========> START YJK 3/12/2010 DEV008682
"RTN","CHMEAE8U",202,0)
I $P(CHCD,"^",32)=0 G TEM1
"RTN","CHMEAE8U",203,0)
MEDT ;SET UP ALL MEDICARE DATES
"RTN","CHMEAE8U",204,0)
S MEDDT=0
"RTN","CHMEAE8U",205,0)
S (MEDAGE,MEDABDT,MEDAEDT,MEDBBDT,MEDBEDT)=""
"RTN","CHMEAE8U",206,0)
MDA ;
"RTN","CHMEAE8U",207,0)
S MEDDT=$O(^AHCHVA(DFN,100,BFN,111,MEDDT)) G:'MEDDT MDB
"RTN","CHMEAE8U",208,0)
G:'$D(^AHCHVA(DFN,100,BFN,111,MEDDT,0)) MDB
"RTN","CHMEAE8U",209,0)
S MEDABDT=$P(^AHCHVA(DFN,100,BFN,111,MEDDT,0),"^",1)
"RTN","CHMEAE8U",210,0)
S MEDAEDT=$P(^AHCHVA(DFN,100,BFN,111,MEDDT,0),"^",4)
"RTN","CHMEAE8U",211,0)
S MEDAGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,100,BFN,0),"^",3),MEDABDT)
"RTN","CHMEAE8U",212,0)
MDB ;
"RTN","CHMEAE8U",213,0)
S MEDBEDT=0
"RTN","CHMEAE8U",214,0)
S MEDBEDT=$O(^AHCHVA(DFN,100,BFN,112,MEDBEDT)) G:'MEDBEDT MDB1
"RTN","CHMEAE8U",215,0)
G:'$D(^AHCHVA(DFN,100,BFN,112,MEDBEDT,0)) MDB
"RTN","CHMEAE8U",216,0)
S MEDBBDT=$P(^AHCHVA(DFN,100,BFN,112,MEDBEDT,0),"^",1)
"RTN","CHMEAE8U",217,0)
S MEDBEDT=$P(^AHCHVA(DFN,100,BFN,112,MEDBEDT,0),"^",4)
"RTN","CHMEAE8U",218,0)
MDB1 ;
"RTN","CHMEAE8U",219,0)
I MEDAGE=""&(MEDBBDT'="") S MEDAGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,100,BFN,0),"^",3),MEDBBDT)
"RTN","CHMEAE8U",220,0)
I MEDAGE<65 D
"RTN","CHMEAE8U",221,0)
.I MEDABDT'="" D
"RTN","CHMEAE8U",222,0)
..I MEDBBDT="" S TA(MEDABDT)="E" Q
"RTN","CHMEAE8U",223,0)
..I MEDAEDT'="" S TA(MEDAEDT)="S" Q
"RTN","CHMEAE8U",224,0)
..I MEDBBDT'="" I MEDABDT=MEDBBDT S TA(MEDABDT)="S"
"RTN","CHMEAE8U",225,0)
..I MEDBBDT'="" I MEDABDT=MEDBBDT I MEDBEDT'="" S TA(MEDBEDT)="E"
"RTN","CHMEAE8U",226,0)
..I MEDBBDT'="" I MEDABDT<MEDBBDT S TA(MEDABDT)="E",TA(MEDBBDT)="S"
"RTN","CHMEAE8U",227,0)
..Q
"RTN","CHMEAE8U",228,0)
.Q
"RTN","CHMEAE8U",229,0)
;<========= END YJK 3/12/2010 DEV008682
"RTN","CHMEAE8U",230,0)
TEM1 S CHTBEG=$O(TA(CHTBEG)) I 'CHTBEG K TA Q ;TLH 6/23/08 DEV005104
"RTN","CHMEAE8U",231,0)
I $P(TA(CHTBEG),"^",1)'="S" I SFLG=0 G TEM1
"RTN","CHMEAE8U",232,0)
S CHSTART=CHTBEG,SFLG=1
"RTN","CHMEAE8U",233,0)
TEM2 S CHTBEG=$O(TA(CHTBEG)) Q:'CHTBEG
"RTN","CHMEAE8U",234,0)
I $P(TA(CHTBEG),"^",1)'="E" G TEM2
"RTN","CHMEAE8U",235,0)
S CHEND=CHTBEG,SFLG=0
"RTN","CHMEAE8U",236,0)
S ^AHCHVA(DFN,100,BFN,109,CHSTART,CHEND)=DUZ_"^"_DT
"RTN","CHMEAE8U",237,0)
S CHBEG=CHSTART,(Y,CHEND)=CHEND
"RTN","CHMEAE8U",238,0)
G TEM1
"RTN","CHMEAE8U",239,0)
REMAR ;ADDED FOR PL 107-330
"RTN","CHMEAE8U",240,0)
;CODE ADDED FOR BENES THAT HAVE APPLIED PREVIOUSLY AND NOW RE-APPLYING AFTER THE
"RTN","CHMEAE8U",241,0)
;DEADLINE BUT REMARRIED BEFORE THE ENACTMENT DATE
"RTN","CHMEAE8U",242,0)
I $P(CHCD,"^",38)>3041231 I $P(CHCD,"^",8)>3030204 I AGE<55 D
"RTN","CHMEAE8U",243,0)
.S CHEND=($P(CHCD,"^",8))
"RTN","CHMEAE8U",244,0)
.Q
"RTN","CHMEAE8U",245,0)
S X1=$P(CHCD,U,3)+650000,X=$$FMADD^XLFDT(X1,-1,0,0,0)
"RTN","CHMEAE8U",246,0)
S CHEND=X ;USE IF END DATE NEEDS TO BE 1 DAY BEFORE 65 B-DAY
"RTN","CHMEAE8U",247,0)
S CAGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,100,BFN,0),"^",3),DT)
"RTN","CHMEAE8U",248,0)
I CAGE<65 D Q
"RTN","CHMEAE8U",249,0)
.S CHBEG=$P(CHCD,"^",10) ;TLH 3/15/06 trc 1369
"RTN","CHMEAE8U",250,0)
.Q:'$G(CHBEG) ;SKD 7/1/10 DEV009803
"RTN","CHMEAE8U",251,0)
.I $P(CHCD,"^",12)="W55" I $P(CHCD,"^",8)'="" S CHEND=$P(CHCD,"^",8) ;TLH 11/1/2006 FIX TO REMARRIED WIDOW PROBLEMS DEF000853 (MTN000626 & MTN000814)
"RTN","CHMEAE8U",252,0)
.Q:'$G(CHEND) ;SKD 7/1/10 DEV009803
"RTN","CHMEAE8U",253,0)
.S ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_"^"_CHNOW ;TLH 2/15/06 trc 1369
"RTN","CHMEAE8U",254,0)
.Q
"RTN","CHMEAE8U",255,0)
S CHBEG=$P(CHCD,"^",10) S CHEND=$P(CHCD,"^",8) ;TLH 3/15/06 trc 1369
"RTN","CHMEAE8U",256,0)
Q:CHBEG="" Q:CHEND="" ;TLH 05/24/06 ERROR IN DEV
"RTN","CHMEAE8U",257,0)
S ^AHCHVA(DFN,100,BFN,109,CHBEG,CHEND)=DUZ_"^"_CHNOW ;TLH 2/15/06 trc 1369
"RTN","CHMEAE8U",258,0)
Q
"RTN","CHMEAE8U",259,0)
EA ;CHECK TO SEE IF A BENE WAS ea PRIOR TO DATE OF DEATH
"RTN","CHMEAE8U",260,0)
;TLH 6/26/2006
"RTN","CHMEAE8U",261,0)
S CHTDAT=9999999,CHDEATH="",CHGOOD="" K CHDBFLG ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",262,0)
EA1 S CHTDAT=$O(^AHCHVA(DFN,101,CHTDAT),-1) Q:'CHTDAT ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",263,0)
Q:CHGOOD=1
"RTN","CHMEAE8U",264,0)
G:'$D(^AHCHVA(DFN,101,CHTDAT,100,BFN,0)) EA1 ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",265,0)
I $P(^AHCHVA(DFN,101,CHTDAT,100,BFN,0),"^",12)="DB" S CHDBFLG=""
"RTN","CHMEAE8U",266,0)
I $D(CHDBFLG) D G EA1 ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",267,0)
.S CHDEATH=CHTDAT ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",268,0)
.Q:CHDEATH="" ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",269,0)
.Q:$P(^AHCHVA(DFN,101,CHTDAT,100,BFN,0),"^",5)="" ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",270,0)
.I ($P(^AHCHVA(DFN,101,CHTDAT,100,BFN,0),"^",5)="EA")!($P(^AHCHVA(DFN,101,CHTDAT,100,BFN,0),"^",5)="PS")!($P(^AHCHVA(DFN,101,CHTDAT,100,BFN,0),"^",5)="PR") S CHGOOD=1 ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",271,0)
.Q
"RTN","CHMEAE8U",272,0)
G EA1 ;TLH 072606 MC255/PROJECT 1499
"RTN","CHMEAE8U",273,0)
;REMOVED LINE TAGS MEDT, MDA, MDB SINCE MEDICARE CALCULATION ARE IN OTHER ROUTINES TLH 2/19/08 BUG003054
"RTN","CHMEAE8U",274,0)
;MEDT ;SET UP ALL MEDICARE DATES
"RTN","CHMEAE8U",275,0)
;Q ;AEB
"RTN","CHMEAE8U",276,0)
;S MEDDT=0 S MEDAGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,100,BFN,0),"^",3),DT)
"RTN","CHMEAE8U",277,0)
;S (MEDABDT,MEDAEDT,MEDBBDT,MEDBEDT)=""
"RTN","CHMEAE8U",278,0)
;MDA ; BENEFICIARY HAS MEDICARE A
"RTN","CHMEAE8U",279,0)
;S MEDABDT=$O(^AHCHVA(DFN,100,BFN,111,MEDDT)) G:'MEDDT MDB
"RTN","CHMEAE8U",280,0)
;G:'$D(^AHCHVA(DFN,100,BFN,111,MEDDT,0)) MDA
"RTN","CHMEAE8U",281,0)
;S MEDABDT=$P(^AHCHVA(DFN,100,BFN,111,MEDDT,0),"^",1)
"RTN","CHMEAE8U",282,0)
;S MEDAEDT=$P(^AHCHVA(DFN,100,BFN,111,MEDDT,0),"^",4)
"RTN","CHMEAE8U",283,0)
;MDB ; BENEFICIARY HAS MEDICARE B
"RTN","CHMEAE8U",284,0)
;S MEDBEDT=0 ;tlh 4/16/07
"RTN","CHMEAE8U",285,0)
;S MEDBEDT=$O(^AHCHVA(DFN,100,BFN,112,MEDBEDT)) G:'MEDBEDT TEM1 ;tlh 4/16/07
"RTN","CHMEAE8U",286,0)
;G:'$D(^AHCHVA(DFN,100,BFN,112,MEDBEDT,0)) MDB ;tlh 4/16/07
"RTN","CHMEAE8U",287,0)
;S MEDBBDT=$P(^AHCHVA(DFN,100,BFN,112,MEDBEDT,0),"^",1) ;tlh 4/16/07
"RTN","CHMEAE8U",288,0)
;S MEDBEDT=$P(^AHCHVA(DFN,100,BFN,112,MEDBEDT,0),"^",4) ;tlh 4/16/07
"RTN","CHMEAE8U",289,0)
;I MEDAGE<65 I MEDBBDT'="" Q
"RTN","CHMEAE8U",290,0)
;FIND 65TH DOB
"RTN","CHMEAE8U",291,0)
;IF MED A BEG BEFORE 65 DOB DO SOMETHING
"RTN","CHMEAE8U",292,0)
;IF MED B BEG AFTER 65 DOB DO SOMETHING
"RTN","CHMEAE8U",293,0)
;I MEDAGE<65 D Q ;UNDER THE AGE OF 65
"RTN","CHMEAE8U",294,0)
;.I MEDABDT'="" D ; IF BENE HAS MED A
"RTN","CHMEAE8U",295,0)
;..I MEDBBDT="" S TA(MEDABDT)="E" Q ;IF BENE HAS NO MED B
"RTN","CHMEAE8U",296,0)
;..I MEDAEDT'="" S TA(MEDAEDT)="S" Q ;IF BENE HAS ENDED MED A
"RTN","CHMEAE8U",297,0)
;..I MEDBBDT'="" I MEDABDT=MEDBBDT S TA(MEDABDT)="S" ;BENE HAS MED A&B AT SAME TIME
"RTN","CHMEAE8U",298,0)
;..I MEDBBDT'="" I MEDABDT=MEDBBDT I MEDBEDT'="" S TA(MEDBEDT)="E" ;BENE HAS NOW ONLY MED A
"RTN","CHMEAE8U",299,0)
;..Q
"RTN","CHMEAE8U",300,0)
;.Q
"RTN","CHMEAE8U",301,0)
;I MEDAGE>64 D Q
"RTN","CHMEAE8U",302,0)
;.
"RTN","CHMEAE8U",303,0)
;G MDA
"RTN","CHMEAE8U",304,0)
;Q
"RTN","CHMEAE8U",305,0)
;END OF REMOVAL FOR BUG003054 TLH 02/19/08
"RTN","CHMEAE8U",306,0)
PTDT ; NEW SUBROUTINE CALLED FROM CHMEAE81 IF SPONSOR IS SITTING INELIGIBLE.
"RTN","CHMEAE8U",307,0)
;THIS SUBROUTINE WILL CHECK FOR P&T DATE LOST DATE TO ALLOW BENES TO HAVE
"RTN","CHMEAE8U",308,0)
;TRUE PERIODS OF ELIGIBILITY FROM BEGIN DATE (QE DATE) TO DATE OF P&T LOST DATE
"RTN","CHMEAE8U",309,0)
S CHPTDT=9999999 ;TLH DEV005327 8/4/08
"RTN","CHMEAE8U",310,0)
S CHPTDT=$O(^AHCHVA(DFN,102,CHPTDT),-1) Q:'CHPTDT ;TLH DEV005327 8/4/08
"RTN","CHMEAE8U",311,0)
Q:'$D(^AHCHVA(DFN,102,CHPTDT,0)) ;TLH DEV005327 8/4/08
"RTN","CHMEAE8U",312,0)
S CHPTLDT=$P(^AHCHVA(DFN,102,CHPTDT,0),"^",2) ;TLH DEV005327 8/4/08
"RTN","CHMEAE8U",313,0)
S CHBEG=$O(^AHCHVA(DFN,100,BFN,109,CHBEG)) ;TLH DEV005327
"RTN","CHMEAE8U",314,0)
I CHPTLDT'="" S CHEND=CHPTLDT ;TLH DEV005327 8/4/08
"RTN","CHMEAE8U",315,0)
Q ;TLH DEV005327 8/4/08
"RTN","CHMEAE8U",316,0)
RRCALC(DFN,BFN) ;RESERVIST/RETIRED ELIGIBLITY RECALC ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE8U",317,0)
Q:$P(^AHCHVA(DFN,100,BFN,0),"^",4)="CG" ;DO NOT RECALC CAREGIVERS
"RTN","CHMEAE8U",318,0)
Q:'$D(^AHCHVA(DFN,30))
"RTN","CHMEAE8U",319,0)
Q:$P(^AHCHVA(DFN,30),"^",5)'=1 ;MANUAL RECALC 0:NO/1:YES
"RTN","CHMEAE8U",320,0)
;Q:$P(^AHCHVA(DFN,100,BFN,0),"^",5)="D" ;STATUS CHECK: D-INELIGIBLE
"RTN","CHMEAE8U",321,0)
I $P(^AHCHVA(DFN,30),"^",4)=0&($P(^AHCHVA(DFN,30),"^",5)=1) Q ;NOT RES/RET BUT WANT TO RECALC ELIG
"RTN","CHMEAE8U",322,0)
I $D(^AHCHVA(DFN,100,BFN,8)) I $P(^AHCHVA(DFN,100,BFN,8),"^",1)=1 Q ;STOP RE-CALC 0-NO/1-YES
"RTN","CHMEAE8U",323,0)
N SPTEDT,SPTLDT,J,QEDATE,PTDATE,TMPBDT,TMPEDT,SPTDT,CTR
"RTN","CHMEAE8U",324,0)
N CHNOW
"RTN","CHMEAE8U",325,0)
D NOW^%DTC S CHNOW=%
"RTN","CHMEAE8U",326,0)
S SDOB=$P(^AHCHVA(DFN,0),"^",3) ;DATE OF BIRTH
"RTN","CHMEAE8U",327,0)
S SAGE60=SDOB+600000 ;DATE OF 60TH BIRTHDAY
"RTN","CHMEAE8U",328,0)
S SAGE120=SDOB+1200000 ;DATE OF 120TH BIRTHDAY
"RTN","CHMEAE8U",329,0)
S SDOD=$P(^AHCHVA(DFN,0),"^",4) ;SPN DATE OF DEATH
"RTN","CHMEAE8U",330,0)
;I SDOD'="" I SDOD<SAGE60 Q
"RTN","CHMEAE8U",331,0)
S BDOB=$P(^AHCHVA(DFN,100,BFN,0),"^",3) ;BENE DATE OF BIRTH
"RTN","CHMEAE8U",332,0)
S BDOD=$P(^AHCHVA(DFN,100,BFN,0),"^",6) ;BENE DATE OF DEATH
"RTN","CHMEAE8U",333,0)
S BAGE65=BDOB+650000 ;DATE OF BENE 65TH BIRTHDAY
"RTN","CHMEAE8U",334,0)
I BDOD'="" I BDOD<SAGE60 Q
"RTN","CHMEAE8U",335,0)
S SSTAT=$P(^AHCHVA(DFN,0),"^",5) ;STATUS
"RTN","CHMEAE8U",336,0)
S SAGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,0),"^",3),DT) ;CURRENT AGE
"RTN","CHMEAE8U",337,0)
S BREL=$P(^AHCHVA(DFN,100,BFN,0),"^",4) ;RELATIONSHIP
"RTN","CHMEAE8U",338,0)
S QEDATE=$P(^AHCHVA(DFN,100,BFN,0),"^",10) ;{BEN} QE DT
"RTN","CHMEAE8U",339,0)
S PTDATE=""
"RTN","CHMEAE8U",340,0)
I $D(^AHCHVA(DFN,102)) D
"RTN","CHMEAE8U",341,0)
.S SPTDT=9999999 S SPTDT=$O(^AHCHVA(DFN,102,SPTDT),-1) Q:SPTDT="" ;P&T DATES {SPON}
"RTN","CHMEAE8U",342,0)
.S PTDATE=$P(^AHCHVA(DFN,102,SPTDT,0),"^",1) ;{SPN} LAST P&T EFFECTIVE DATE
"RTN","CHMEAE8U",343,0)
S TMPBDT=$S(QEDATE=PTDATE:QEDATE,QEDATE>PTDATE:QEDATE,PTDATE>QEDATE:PTDATE,1:"") Q:TMPBDT="" ;TEMP BEGIN DATE {WHICH EVER DATE IS LATER}
"RTN","CHMEAE8U",344,0)
S TMPEDT=$$FMADD^XLFDT(SAGE60,-1) ;TEMP END DATE
"RTN","CHMEAE8U",345,0)
I BREL="S"&(SAGE>59) D ;RULE 1: Spouse is ineligible when sponsor is a retired reservist over 60
"RTN","CHMEAE8U",346,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",347,0)
.K FLG109
"RTN","CHMEAE8U",348,0)
.S RRBDT=0,CTR=0 F S RRBDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT)) Q:'RRBDT S CTR=CTR+1
"RTN","CHMEAE8U",349,0)
.I CTR=1 D
"RTN","CHMEAE8U",350,0)
..K ^AHCHVA(DFN,100,BFN,109),^AHCHVA(DFN,100,BFN,105)
"RTN","CHMEAE8U",351,0)
..S NEWEDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",352,0)
..S NEWEDT=$$RRMEDCHK(NEWEDT) ;CHECK IF MEDICARE EXISTS
"RTN","CHMEAE8U",353,0)
..S ^AHCHVA(DFN,100,BFN,109,TMPBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",354,0)
..S ^AHCHVA(DFN,100,BFN,105,TMPBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",355,0)
.E D
"RTN","CHMEAE8U",356,0)
..S RRBDT=0 F S RRBDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT)) Q:'RRBDT D
"RTN","CHMEAE8U",357,0)
...S RREDT=0 F S RREDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT)) Q:'RREDT D
"RTN","CHMEAE8U",358,0)
....I RRBDT<SAGE60&(SAGE60<RREDT) D
"RTN","CHMEAE8U",359,0)
.....S NEWEDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",360,0)
.....S ^AHCHVA(DFN,100,BFN,109,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",361,0)
.....S ^AHCHVA(DFN,100,BFN,105,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",362,0)
.....S FLG109=""
"RTN","CHMEAE8U",363,0)
....I $D(FLG109) K ^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT),^AHCHVA(DFN,100,BFN,105,RRBDT,RREDT)
"RTN","CHMEAE8U",364,0)
I BREL="S"&(SAGE<60) D ;RULE 2: Spouse is eligible when sponsor is a reservist until sponsor's 60th
"RTN","CHMEAE8U",365,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",366,0)
.S BEGDT=$P(^AHCHVA(DFN,100,BFN,0),"^",10) ;QE DATE {BENE}
"RTN","CHMEAE8U",367,0)
.S (SPTEDT,SPTLDT)=0
"RTN","CHMEAE8U",368,0)
.I $D(^AHCHVA(DFN,102)) D
"RTN","CHMEAE8U",369,0)
..S SPTDT=9999999 S SPTDT=$O(^AHCHVA(DFN,102,SPTDT),-1) Q:SPTDT="" ;P&T DATES {SPON}
"RTN","CHMEAE8U",370,0)
..S SPTEDT=$P(^AHCHVA(DFN,102,SPTDT,0),"^",1) ;P&T EFFECTIVE DATE
"RTN","CHMEAE8U",371,0)
..S SPTLDT=$P(^AHCHVA(DFN,102,SPTDT,0),"^",2) ;P&T LOSS DATE
"RTN","CHMEAE8U",372,0)
.I BEGDT<SPTEDT S BEGDT=SPTEDT
"RTN","CHMEAE8U",373,0)
.S X1=SAGE60,X2=-1 D C^%DTC S ENDDT=X
"RTN","CHMEAE8U",374,0)
.S X1=SPTEDT,X2=-1 D C^%DTC S SPTEDT=X
"RTN","CHMEAE8U",375,0)
.I ENDDT<SPTLDT S ENDDT=SPTLDT
"RTN","CHMEAE8U",376,0)
.K FLG109
"RTN","CHMEAE8U",377,0)
.S RRBDT=0,CTR=0 F S RRBDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT)) Q:'RRBDT S CTR=CTR+1
"RTN","CHMEAE8U",378,0)
.I CTR=1 D
"RTN","CHMEAE8U",379,0)
..K ^AHCHVA(DFN,100,BFN,109),^AHCHVA(DFN,100,BFN,105)
"RTN","CHMEAE8U",380,0)
..S NEWEDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",381,0)
..I $P(^AHCHVA(DFN,100,BFN,0),"^",32)=""!($P(^AHCHVA(DFN,100,BFN,0),"^",32)=0) I BAGE65<SAGE60 S NEWEDT=$$FMADD^XLFDT(BAGE65,-1) ;DAY BEFORE BENE 65TH BIRTHDAY
"RTN","CHMEAE8U",382,0)
..S ^AHCHVA(DFN,100,BFN,109,TMPBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",383,0)
..S ^AHCHVA(DFN,100,BFN,105,TMPBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",384,0)
.E D
"RTN","CHMEAE8U",385,0)
..S RRBDT=0 F S RRBDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT)) Q:'RRBDT D
"RTN","CHMEAE8U",386,0)
...S RREDT=0 F S RREDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT)) Q:'RREDT D
"RTN","CHMEAE8U",387,0)
....I RRBDT<SAGE60&(SAGE60<RREDT) D
"RTN","CHMEAE8U",388,0)
.....S NEWEDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",389,0)
.....I BAGE65<SAGE60 S NEWEDT=$$FMADD^XLFDT(BAGE65,-1) ;DAY BEFORE BENE 65TH BIRTHDAY
"RTN","CHMEAE8U",390,0)
.....S ^AHCHVA(DFN,100,BFN,109,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",391,0)
.....S ^AHCHVA(DFN,100,BFN,105,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",392,0)
.....S FLG109=""
"RTN","CHMEAE8U",393,0)
....I $D(FLG109) K ^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT),^AHCHVA(DFN,100,BFN,105,RRBDT,RREDT),FLG109
"RTN","CHMEAE8U",394,0)
I BREL="C"&(SAGE>59) D ;RULE 3: Beneficiary is ineligible when sponsor is a retired reservist over 60
"RTN","CHMEAE8U",395,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",396,0)
.S RRBDT=0 F S RRBDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT)) Q:'RRBDT D
"RTN","CHMEAE8U",397,0)
..S RREDT=0 F S RREDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT)) Q:'RREDT D
"RTN","CHMEAE8U",398,0)
...S NEWEDT=$$RRCEDCHK(RREDT)
"RTN","CHMEAE8U",399,0)
...K ^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT),^AHCHVA(DFN,100,BFN,105,RRBDT,RREDT)
"RTN","CHMEAE8U",400,0)
...Q:SAGE60<RRBDT
"RTN","CHMEAE8U",401,0)
...S ^AHCHVA(DFN,100,BFN,109,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",402,0)
...S ^AHCHVA(DFN,100,BFN,105,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",403,0)
I BREL="C"&(SAGE<60) D ;RULE 4: Beneficiary is eligible when sponsor is a reservist until sponsor's 60th birthday
"RTN","CHMEAE8U",404,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",405,0)
.S BEGDT=$P(^AHCHVA(DFN,100,BFN,0),"^",10) ;QE DATE {BENE}
"RTN","CHMEAE8U",406,0)
.S (SPTEDT,SPTLDT)=0
"RTN","CHMEAE8U",407,0)
.I $D(^AHCHVA(DFN,102)) D
"RTN","CHMEAE8U",408,0)
..S SPTDT=9999999 S SPTDT=$O(^AHCHVA(DFN,102,SPTDT),-1) Q:SPTDT="" ;P&T DATES {SPON}
"RTN","CHMEAE8U",409,0)
..S SPTEDT=$P(^AHCHVA(DFN,102,SPTDT,0),"^",1) ;P&T EFFECTIVE DATE
"RTN","CHMEAE8U",410,0)
..S SPTLDT=$P(^AHCHVA(DFN,102,SPTDT,0),"^",2) ;P&T LOSS DATE
"RTN","CHMEAE8U",411,0)
.I BEGDT<SPTEDT S BEGDT=SPTEDT
"RTN","CHMEAE8U",412,0)
.S X1=SAGE60,X2=-1 D C^%DTC S ENDDT=X
"RTN","CHMEAE8U",413,0)
.S X1=SPTEDT,X2=-1 D C^%DTC S SPTEDT=X
"RTN","CHMEAE8U",414,0)
.I ENDDT<SPTLDT S ENDDT=SPTLDT
"RTN","CHMEAE8U",415,0)
.S RRBDT=0 F S RRBDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT)) Q:'RRBDT D
"RTN","CHMEAE8U",416,0)
..S RREDT=0 F S RREDT=$O(^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT)) Q:'RREDT D
"RTN","CHMEAE8U",417,0)
...S NEWEDT=$$RRCEDCHK(RREDT)
"RTN","CHMEAE8U",418,0)
...K ^AHCHVA(DFN,100,BFN,109,RRBDT,RREDT),^AHCHVA(DFN,100,BFN,105,RRBDT,RREDT),FLG109
"RTN","CHMEAE8U",419,0)
...S ^AHCHVA(DFN,100,BFN,109,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",420,0)
...S ^AHCHVA(DFN,100,BFN,105,RRBDT,NEWEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",421,0)
I '$D(^AHCHVA(DFN,100,BFN,109))&($D(^AHCHVA(DFN,100,BFN,105))) D
"RTN","CHMEAE8U",422,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",423,0)
.S ^AHCHVA(DFN,100,BFN,109,TMPBDT,TMPEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",424,0)
.S ^AHCHVA(DFN,100,BFN,105,TMPBDT,TMPEDT)=DUZ_U_CHNOW
"RTN","CHMEAE8U",425,0)
Q
"RTN","CHMEAE8U",426,0)
RRSTAT(DFN,BFN) ;RESERVIST/RETIRED ELIGIBLITY STATUS CHECK ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE8U",427,0)
Q:$P(^AHCHVA(DFN,100,BFN,0),"^",4)="CG" ;DO NOT RECALC CAREGIVERS
"RTN","CHMEAE8U",428,0)
Q:'$D(^AHCHVA(DFN,30))
"RTN","CHMEAE8U",429,0)
Q:$P(^AHCHVA(DFN,30),"^",5)'=1 ;MANUAL RECALC 0:NO/1:YES
"RTN","CHMEAE8U",430,0)
;Q:$P(^AHCHVA(DFN,100,BFN,0),"^",5)="D" ;STATUS CHECK: D-INELIGIBLE
"RTN","CHMEAE8U",431,0)
I $P(^AHCHVA(DFN,30),"^",4)=0&($P(^AHCHVA(DFN,30),"^",5)=1) Q ;NOT RES/RET BUT WANT TO RECALC ELIG
"RTN","CHMEAE8U",432,0)
I $D(^AHCHVA(DFN,100,BFN,8)) I $P(^AHCHVA(DFN,100,BFN,8),"^",1)=1 Q ;STOP RE-CALC 0-NO/1-YES
"RTN","CHMEAE8U",433,0)
N SPTEDT,SPTLDT
"RTN","CHMEAE8U",434,0)
I $P(^AHCHVA(DFN,30),"^",4)=0&($P(^AHCHVA(DFN,30),"^",5)=1) Q ;NOT RES/RET BUT WANT TO RECALC ELIG
"RTN","CHMEAE8U",435,0)
I $P(^AHCHVA(DFN,30),"^",4)=1&($P(^AHCHVA(DFN,30),"^",5)=1)&($P(^AHCHVA(DFN,30),"^",1)=0) Q ;NOT RES/RET BUT WANT TO RECALC ELIG
"RTN","CHMEAE8U",436,0)
N CHNOW
"RTN","CHMEAE8U",437,0)
D NOW^%DTC S CHNOW=%
"RTN","CHMEAE8U",438,0)
S SDOB=$P(^AHCHVA(DFN,0),"^",3) ;DATE OF BIRTH
"RTN","CHMEAE8U",439,0)
S SAGE60=SDOB+600000 ;DATE OF 60TH BIRTHDAY
"RTN","CHMEAE8U",440,0)
S SAGE120=SDOB+1200000 ;DATE OF 120TH BIRTHDAY
"RTN","CHMEAE8U",441,0)
S SDOD=$P(^AHCHVA(DFN,0),"^",4) ;SPN DATE OF DEATH
"RTN","CHMEAE8U",442,0)
;I SDOD'="" I SDOD<SAGE60 Q
"RTN","CHMEAE8U",443,0)
S BDOD=$P(^AHCHVA(DFN,100,BFN,0),"^",6) ;BENE DATE OF DEATH
"RTN","CHMEAE8U",444,0)
I BDOD'="" I BDOD<SAGE60
"RTN","CHMEAE8U",445,0)
S SSTAT=$P(^AHCHVA(DFN,0),"^",5) ;STATUS
"RTN","CHMEAE8U",446,0)
S SAGE=$$AGE^CHTFLIB($P(^AHCHVA(DFN,0),"^",3),DT) ;CURRENT AGE
"RTN","CHMEAE8U",447,0)
S BREL=$P(^AHCHVA(DFN,100,BFN,0),"^",4) ;RELATIONSHIP
"RTN","CHMEAE8U",448,0)
I BREL="S"&(SAGE>59) D ;RULE 1: Spouse is ineligible when sponsor is a retired reservist over 60
"RTN","CHMEAE8U",449,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",450,0)
.S $P(CHCD,U,5)="D"
"RTN","CHMEAE8U",451,0)
.S $P(CHCD,U,12)="CHE",$P(CHCD,U,13)=""
"RTN","CHMEAE8U",452,0)
.S $P(^AHCHVA(DFN,100,BFN,0),"^",15)=1
"RTN","CHMEAE8U",453,0)
I BREL="S"&(SAGE<60) D ;RULE 2: Spouse is eligible when sponsor is a reservist until sponsor's 60th
"RTN","CHMEAE8U",454,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",455,0)
.S $P(CHCD,U,5)="EA"
"RTN","CHMEAE8U",456,0)
.S $P(CHCD,U,12)="",$P(CHCD,U,13)="R60"
"RTN","CHMEAE8U",457,0)
I BREL="C"&(SAGE>59) D ;RULE 3: Beneficiary is ineligible when sponsor is a retired reservist over 60
"RTN","CHMEAE8U",458,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",459,0)
.S $P(CHCD,U,5)="D"
"RTN","CHMEAE8U",460,0)
.S $P(CHCD,U,12)="CHE",$P(CHCD,U,13)=""
"RTN","CHMEAE8U",461,0)
.S $P(^AHCHVA(DFN,100,BFN,0),"^",15)=1
"RTN","CHMEAE8U",462,0)
I BREL="C"&(SAGE<60) D ;RULE 4: Beneficiary is eligible when sponsor is a reservist until sponsor's 60th birthday
"RTN","CHMEAE8U",463,0)
.Q:$P(^AHCHVA(DFN,30),"^",1)'=1 ;RES/RET STATUS
"RTN","CHMEAE8U",464,0)
.S $P(CHCD,U,5)="EA"
"RTN","CHMEAE8U",465,0)
.S $P(CHCD,U,12)="",$P(CHCD,U,13)="R60"
"RTN","CHMEAE8U",466,0)
.Q
"RTN","CHMEAE8U",467,0)
Q
"RTN","CHMEAE8U",468,0)
RRCEDCHK(RREDT) ;RESERVIST/RETIRED CHILD SCHOOL END DATE CHECK ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE8U",469,0)
N ENDDT,BDOB,CAGE18,CAGE23
"RTN","CHMEAE8U",470,0)
S ENDDT=""
"RTN","CHMEAE8U",471,0)
S BDOB=$P(^AHCHVA(DFN,100,BFN,0),"^",3) ;BENE DATE OF BIRTH
"RTN","CHMEAE8U",472,0)
S CAGE18=BDOB+180000 ;DATE OF 18TH BIRTHDAY
"RTN","CHMEAE8U",473,0)
S CAGE23=BDOB+230000 ;DATE OF 23TH BIRTHDAY
"RTN","CHMEAE8U",474,0)
I SAGE60<CAGE18 S ENDDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",475,0)
I CAGE18<SAGE60&(SAGE60<CAGE23) D
"RTN","CHMEAE8U",476,0)
.I $P(^AHCHVA(DFN,100,BFN,0),"^",22)=1 D
"RTN","CHMEAE8U",477,0)
..S ENDDT=$$FMADD^XLFDT(CAGE23,-1) ;FULL-TIME STUDENT
"RTN","CHMEAE8U",478,0)
..I $D(^AHCHVA(DFN,100,BFN,104)) D
"RTN","CHMEAE8U",479,0)
...S K=99,K=$O(^AHCHVA(DFN,100,BFN,104,K),-1)
"RTN","CHMEAE8U",480,0)
...S SCLEDT=$P(^AHCHVA(DFN,100,BFN,104,K,0),"^",2) ;STUDENT END SEMESTER DATE
"RTN","CHMEAE8U",481,0)
...Q:SCLEDT=""
"RTN","CHMEAE8U",482,0)
...I SAGE60<SCLEDT S ENDDT=$$FMADD^XLFDT(SAGE60,-1)
"RTN","CHMEAE8U",483,0)
...I SAGE60>SCLEDT S ENDDT=SCLEDT
"RTN","CHMEAE8U",484,0)
I CAGE23<SAGE60 S ENDDT=$$FMADD^XLFDT(CAGE23,-1)
"RTN","CHMEAE8U",485,0)
I $P(^AHCHVA(DFN,100,BFN,0),"^",33)=1 S ENDDT=$$FMADD^XLFDT(SAGE60,-1) ;HELPLESS CHILD
"RTN","CHMEAE8U",486,0)
I ENDDT="" S ENDDT=$$FMADD^XLFDT(CAGE18,-1)
"RTN","CHMEAE8U",487,0)
I ENDDT>RREDT D
"RTN","CHMEAE8U",488,0)
.S ENDDT=RREDT
"RTN","CHMEAE8U",489,0)
Q ENDDT
"RTN","CHMEAE8U",490,0)
RRMEDCHK(NWEDT) ;CHECK IF MEDICARE EXISTS ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE8U",491,0)
N MEDINFO
"RTN","CHMEAE8U",492,0)
N MDBGDT,MDENDT
"RTN","CHMEAE8U",493,0)
S MEDINFO=$P(^AHCHVA(DFN,100,BFN,0),"^",32)
"RTN","CHMEAE8U",494,0)
S ENDDT=NWEDT ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",495,0)
I MEDINFO=""!(MEDINFO=0) D ;NO MEDICARE ENTERED
"RTN","CHMEAE8U",496,0)
.I BAGE65<SAGE60 S ENDDT=$$FMADD^XLFDT(BAGE65,-1) ;DAY BEFORE BENE 65TH BIRTHDAY
"RTN","CHMEAE8U",497,0)
E D
"RTN","CHMEAE8U",498,0)
.I $D(^AHCHVA(DFN,100,BFN,111)) D ;CHECK FOR MED A DATES
"RTN","CHMEAE8U",499,0)
..S K=99 S K=$O(^AHCHVA(DFN,100,BFN,111,K),-1) Q:'K!(K="")
"RTN","CHMEAE8U",500,0)
..S MDBGDT=$P(^AHCHVA(DFN,100,BFN,111,K,0),"^",1)
"RTN","CHMEAE8U",501,0)
..S MDENDT=$P(^AHCHVA(DFN,100,BFN,111,K,0),"^",4)
"RTN","CHMEAE8U",502,0)
..I MDBGDT<ENDDT!(ENDDT>MDENDT) S ENDDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",503,0)
.I $D(^AHCHVA(DFN,100,BFN,112)) D ;CHECK FOR MED B DATES
"RTN","CHMEAE8U",504,0)
..S K=99 S K=$O(^AHCHVA(DFN,100,BFN,112,K),-1) Q:'K!(K="")
"RTN","CHMEAE8U",505,0)
..S MDBGDT=$P(^AHCHVA(DFN,100,BFN,112,K,0),"^",1)
"RTN","CHMEAE8U",506,0)
..S MDENDT=$P(^AHCHVA(DFN,100,BFN,112,K,0),"^",1)
"RTN","CHMEAE8U",507,0)
..I MDBGDT<ENDDT!(ENDDT>MDENDT) S ENDDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",508,0)
.I $D(^AHCHVA(DFN,100,BFN,113)) D ;CHECK FOR MED EXHAUSTION DATES
"RTN","CHMEAE8U",509,0)
..S K=99 S K=$O(^AHCHVA(DFN,100,BFN,113,K),-1) Q:'K!(K="")
"RTN","CHMEAE8U",510,0)
..S MDBGDT=$P(^AHCHVA(DFN,100,BFN,113,K,0),"^",1)
"RTN","CHMEAE8U",511,0)
..S MDENDT=$P(^AHCHVA(DFN,100,BFN,113,K,0),"^",1)
"RTN","CHMEAE8U",512,0)
..I MDBGDT<ENDDT!(ENDDT>MDENDT) S ENDDT=$$FMADD^XLFDT(SAGE60,-1) ;DAY BEFORE 60TH BIRTHDAY
"RTN","CHMEAE8U",513,0)
Q ENDDT
"RTN","CHMEAE8U",514,0)
;
"RTN","CHMEAE8U",515,0)
;SBB Testing
"RTN","CHMEAE8U",516,0)
DISCHK(DFN,BFN) ;
"RTN","CHMEAE8U",517,0)
;
"RTN","CHMEAE8U",518,0)
N RTN,TMPK,SFLG
"RTN","CHMEAE8U",519,0)
;AEB DEV023457 11-2-2015 ADDED CODE TO SKIP STATUS RECALC IF BENE IS DISENROLLED
"RTN","CHMEAE8U",520,0)
I $D(^AHCHVA(DFN,100,BFN,115)) D
"RTN","CHMEAE8U",521,0)
.S TMPK=9999
"RTN","CHMEAE8U",522,0)
.;S TMPK=$O(^AHCHVA(DFN,100,BFN,TMPK),-1) Q:'TMPK
"RTN","CHMEAE8U",523,0)
.S TMPK=$O(^AHCHVA(DFN,100,BFN,115,TMPK),-1) Q:'TMPK ;BDB 12/28/18 - Fix coding error
"RTN","CHMEAE8U",524,0)
.Q:$P($G(^AHCHVA(DFN,100,BFN,115,TMPK,0)),"^",8)'=""
"RTN","CHMEAE8U",525,0)
.S SFLG=""
"RTN","CHMEAE8U",526,0)
.Q
"RTN","CHMEAE8U",527,0)
S RTN=0
"RTN","CHMEAE8U",528,0)
S:$D(SFLG) RTN=1
"RTN","CHMEAE8U",529,0)
Q RTN
"RTN","CHMEAE8U",530,0)
;
"RTN","CHMEAE8U",531,0)
REECHK(DFN,BFN) ;ACA US017 BDB 1/14/19 Re-enrollment check
"RTN","CHMEAE8U",532,0)
N RTN,TMPK,SFLG
"RTN","CHMEAE8U",533,0)
I $D(^AHCHVA(DFN,100,BFN,115)) D
"RTN","CHMEAE8U",534,0)
.S TMPK=9999
"RTN","CHMEAE8U",535,0)
.S TMPK=$O(^AHCHVA(DFN,100,BFN,115,TMPK),-1) Q:'TMPK
"RTN","CHMEAE8U",536,0)
.I $P($G(^AHCHVA(DFN,100,BFN,115,TMPK,0)),"^",8)'="" S SFLG=""
"RTN","CHMEAE8U",537,0)
.Q
"RTN","CHMEAE8U",538,0)
S RTN=0
"RTN","CHMEAE8U",539,0)
S:$D(SFLG) RTN=1
"RTN","CHMEAE8U",540,0)
Q RTN
"RTN","CHMEAE8U",541,0)
;
"RTN","CHMEAE9")
0^2^B189081791
"RTN","CHMEAE9",1,0)
CHMEAE9 ;CVA/AEB;BENEFICIARY STATUS RE-CALC;Jan 08, 2019@09:31:38
"RTN","CHMEAE9",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAE9",3,0)
;CPTS 10042* BY CAM,10311* BY AEB,10579* BY PEJ 10662, CPTS 10748 BY CAM
"RTN","CHMEAE9",4,0)
;YJK 3/9/2010 DEV008403-02; Medicare Part A beneficiaries are not updating correctly (status)
"RTN","CHMEAE9",5,0)
;YJK 4/6/2010 BUG008682-06-01 ; Medicare rule overrides public law/widowers marriage terminated check
"RTN","CHMEAE9",6,0)
;YJK 7/13/10 BUG008403-09-01 ; Modify Eligibility status lgic for benes under 65 with future Medicare dates.
"RTN","CHMEAE9",7,0)
;DEV012197-01 YJK 4/6/11 CAREGIVER
"RTN","CHMEAE9",8,0)
;BUG007167-05-01 If sponsor's status = "PR", the bene is set to ineligible.
"RTN","CHMEAE9",9,0)
;DEV016528 YJK 1/22/1
"RTN","CHMEAE9",10,0)
;MTN017725 4/11/13 YJK (subtask of DEV017624-02)
"RTN","CHMEAE9",11,0)
;MTN018346 6/19/13 YJK (subtask of DEV017624-02)
"RTN","CHMEAE9",12,0)
;DEV023183 ACA DISENROLLMENT 5/21/15 AEB/JAK
"RTN","CHMEAE9",13,0)
;DEV023457 AEB 10-27-2015
"RTN","CHMEAE9",14,0)
;JEH 3/12/15 - ENC22734 - Enhancement of Cache Systems to support Retired Reservists Functionality
"RTN","CHMEAE9",15,0)
;RTC786742 NCD 07/25/2018 ACA Merge
"RTN","CHMEAE9",16,0)
;DEF025745 Correct Medicare Eligiblity Based on UAT DRW 01/02/2019
"RTN","CHMEAE9",17,0)
;ACA US017 BDB 1/14/19 Skip re-calc if bene is re-enrolled
"RTN","CHMEAE9",18,0)
S U="^" N SFLG
"RTN","CHMEAE9",19,0)
;change to account for no bene
"RTN","CHMEAE9",20,0)
Q:'$D(^AHCHVA(DFN,100,BFN,0))
"RTN","CHMEAE9",21,0)
;SBB Testing
"RTN","CHMEAE9",22,0)
;;AEB DEV023457 11-2-2015 ADDED CODE TO SKIP STATUS RECALC IF BENE IS DISENROLLED
"RTN","CHMEAE9",23,0)
;I $D(^AHCHVA(DFN,100,BFN,115)) D Q:$D(SFLG)
"RTN","CHMEAE9",24,0)
;.S TMPK=9999
"RTN","CHMEAE9",25,0)
;.S TMPK=$O(^AHCHVA(DFN,100,BFN,TMPK),-1) Q:'TMPK
"RTN","CHMEAE9",26,0)
;.Q:$P($G(^AHCHVA(DFN,100,BFN,115,TMPK,0)),"^",8)'=""
"RTN","CHMEAE9",27,0)
;.S SFLG=""
"RTN","CHMEAE9",28,0)
;.Q
"RTN","CHMEAE9",29,0)
Q:$$DISCHK^CHMEAE8U(DFN,BFN)
"RTN","CHMEAE9",30,0)
Q:$$REECHK^CHMEAE8U(DFN,BFN) ;ACA US017 BDB 1/14/19 Skip re-calc if bene is re-enrolled
"RTN","CHMEAE9",31,0)
;
"RTN","CHMEAE9",32,0)
I $D(^AHCHVA(DFN,100,BFN,8)) I $P(^(8),U,1)=1 D CMOPCHK^CHMEAE8U I $P(CHCD,U,5)=$P(CHPD,U,5) I $P(CHCD2,U,5)'="" I '$D(CHCD30)!($P($G(CHCD30),U,1)=0) Q D RRSTAT^CHMEAE8U(DFN,BFN) Q ;TLH 6/18/08 DEV005164 ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE9",33,0)
I $D(^AHCHVA(DFN,100,BFN,0)) I ($P(^AHCHVA(DFN,100,BFN,0),"^",4)="CG") D CMOPCHK^CHMEAE8U Q ;DEV012197-01 YJK 4/6/11 CAREGIVER
"RTN","CHMEAE9",34,0)
I $P(CHCD,U,13)="H"&($P(^AHCHVA(DFN,100,BFN,0),U,33)'=1) S $P(^AHCHVA(DFN,100,BFN,0),U,33)=1,CHCD=^AHCHVA(DFN,100,BFN,0)
"RTN","CHMEAE9",35,0)
S RO3884=0
"RTN","CHMEAE9",36,0)
S CHBSTA="D",CHIREA="I",CHEREA="" G R1:'$D(^AHCHVA(DFN,100,BFN,2))
"RTN","CHMEAE9",37,0)
S:'$D(CHCD2) CHCD2=^AHCHVA(DFN,100,BFN,2)
"RTN","CHMEAE9",38,0)
S:'$D(CHPD) CHPD=CHCD
"RTN","CHMEAE9",39,0)
F I=1,2,3,4,5,6,9,14,15 I $P(CHCD2,U,I)=1 S RO3884=1 Q
"RTN","CHMEAE9",40,0)
I $P(CHCD,U,4)'="C" D
"RTN","CHMEAE9",41,0)
.F I=1,2,3,4,5,6,9,14,15 I $P(CHCD2,U,I)=4 S RO3884=1 Q
"RTN","CHMEAE9",42,0)
I $P(CHCD,U,4)="C" D
"RTN","CHMEAE9",43,0)
.I $P(CHCD,U,26)="N" D
"RTN","CHMEAE9",44,0)
..F I=1,2,3,4,5,6,9,14,15 I $P(CHCD2,U,I)=8 S RO3884=1 Q
"RTN","CHMEAE9",45,0)
..Q
"RTN","CHMEAE9",46,0)
.I $P(CHCD,U,26)="A" D
"RTN","CHMEAE9",47,0)
..F I=1,2,3,4,5,6,9,14,15 I $P(CHCD2,U,I)=10 S RO3884=1 Q
"RTN","CHMEAE9",48,0)
..Q
"RTN","CHMEAE9",49,0)
.I $P(CHCD,U,26)="I" D
"RTN","CHMEAE9",50,0)
..F I=1,2,3,4,5,6,9,14,15 I $P(CHCD2,U,I)=10 S RO3884=1 Q
"RTN","CHMEAE9",51,0)
..Q
"RTN","CHMEAE9",52,0)
.I $P(CHCD,U,26)="S" D
"RTN","CHMEAE9",53,0)
..F I=1,2,3,4,5,6,9,14,15 I $P(CHCD2,U,I)=4 S RO3884=1 Q
"RTN","CHMEAE9",54,0)
..Q
"RTN","CHMEAE9",55,0)
.Q
"RTN","CHMEAE9",56,0)
R1 I ($P(CHCD,U)="")!($P(CHCD,U,4)="")!($P(CHCD,U,3)="")!($P(CHCD1,U)="") S CHBSTA="D",CHIREA="I",CHEREA="" G END
"RTN","CHMEAE9",57,0)
I ($P(CHCD,U,9))'?9N S CHBSTA="D",CHIREA="SSN",CHEREA="" G END
"RTN","CHMEAE9",58,0)
I $P(CHCD1,U,11),$P(CHCD1,U,13)="" S CHBSTA="D",CHIREA="I",CHEREA="" G END
"RTN","CHMEAE9",59,0)
I '$P(CHCD1,U,11) I ($P(CHCD1,U,3)="")!($P(CHCD1,U,4)="")!($P(CHCD1,U,5)="") S CHBSTA="D",CHIREA="I",CHEREA="" G END
"RTN","CHMEAE9",60,0)
I ($P(CHCD,U,5)="D"),($P(CHCD,U,12)="I") I 'RO3884 S CHBSTA="D",CHIREA="I",CHEREA="" G END
"RTN","CHMEAE9",61,0)
S CHSTA=$P(^AHCHVA(DFN,0),U,5),CHREA=$P(^AHCHVA(DFN,0),U,14)
"RTN","CHMEAE9",62,0)
I CHSTA="PR" I 'RO3884 S CHBSTA="D",CHIREA="I",CHEREA="" G END ;BUG007167-05-01
"RTN","CHMEAE9",63,0)
S:CHSTA="I" CHREA=$P(^AHCHVA(DFN,0),U,12)
"RTN","CHMEAE9",64,0)
S (CHBEG,CHEND)="" S:'$D(CHPTEND) CHPTEND=""
"RTN","CHMEAE9",65,0)
F I=0:0 S I=$O(^AHCHVA(DFN,100,BFN,105,I)) Q:I="" F J=0:0 S J=$O(^AHCHVA(DFN,100,BFN,105,I,J)) Q:J="" S CHBEG=I,CHEND=J
"RTN","CHMEAE9",66,0)
I $P(CHCD,U,15)=1 S CHBSTA="D",CHIREA="CHE",CHEREA="" G END ;AEB 12/22/2009
"RTN","CHMEAE9",67,0)
I CHSTA="I" S CHBSTA="D",CHIREA="SI",CHEREA="" G END
"RTN","CHMEAE9",68,0)
I ($P(CHCD,U,6)?7N),($P(CHCD,U,6)'>DT) S CHBSTA="D",CHIREA="DB",CHEREA="" G END
"RTN","CHMEAE9",69,0)
S DOB=$P(CHCD,"^",3)
"RTN","CHMEAE9",70,0)
D NOW^%DTC S DT=X S AGE=$$AGE^CHTFLIB(DOB,DT)
"RTN","CHMEAE9",71,0)
;I $P(CHCD,U,15)=1 S CHBSTA="D",CHIREA="CHE",CHEREA="" G END ;AEB 12/22/2009
"RTN","CHMEAE9",72,0)
;I (CHSTA'="I")&(CHREA=1) D D PLWMT D:AGE>64 CFLCK G END ; REPLACED BY BELOW - YJK 4/6/2010 BUG008682-06-01
"RTN","CHMEAE9",73,0)
;I (CHSTA'="I")&(CHREA=1)&'((AGE<64)&($P(CHCD,U,32)=1)) D D PLWMT D:AGE>64 CFLCK G END ;YJK 4/6/2010 BUG008682-06-01 ; MTN017725 TEST 4/11/13 YJK
"RTN","CHMEAE9",74,0)
I (CHSTA'="I")&(CHREA=1)&'((AGE<64)&($P(CHCD,U,32)=1)) D D PLWMT D CFLCK G END ; MTN017725 TEST 4/11/13 YJK (Removed AGE>64 for CFLCK)
"RTN","CHMEAE9",75,0)
.S CHBSTA="D",CHIREA="SDE",CHEREA=""
"RTN","CHMEAE9",76,0)
.S X=$P(CHCD,U,3)+650000,X=$E(X,1,5)_"01" D DTBS S X=Y-1 D DATE
"RTN","CHMEAE9",77,0)
.;ADDED FOR REMARRIAGE AFTER 55
"RTN","CHMEAE9",78,0)
.S DOB=$P(CHCD,U,3),CYR=$P(CHCD,U,8)
"RTN","CHMEAE9",79,0)
.S W55AGE=$$AGE^CHTFLIB(DOB,CYR)
"RTN","CHMEAE9",80,0)
.S CHAPP=$P(CHCD,U,38) ;TLH 1/24/06 trc 1369 CHAPP IS BENE APPLICATION DATE
"RTN","CHMEAE9",81,0)
.S CHMD=$P(CHCD,U,8) ;TLH 1/24/06 trc 1369 CHMD IS BENE REMARRIAGE DATE
"RTN","CHMEAE9",82,0)
.S CHIND=3030204 ;TLH 1/24/06 trc 1369 INACTMENT DATE OF PL 107-330
"RTN","CHMEAE9",83,0)
.S CHDDT=3041231 ;TLH 1/24/06 trc 1369 CHDDT DEADLINE TO APPLY FOR BENEFITS UNDER PL 107-330
"RTN","CHMEAE9",84,0)
.I W55AGE>54 I CHMD<CHIND I CHAPP>CHDDT S CHBSTA="D",CHIREA="A55",CHEREA="" Q ;TLH 1/24/06 trc 1369
"RTN","CHMEAE9",85,0)
.I W55AGE>54 S CHBSTA="E",CHIREA="",CHEREA="W55" D Q
"RTN","CHMEAE9",86,0)
..I AGE>64 I ($P(CHCD,U,32)=1)!($P(CHCD,U,32)=2)!($P(CHCD,U,32)="")!($P(CHCD,U,32)=3) D CFLCK I CHEREA="CFL" S CHEREA="N55"
"RTN","CHMEAE9",87,0)
..Q
"RTN","CHMEAE9",88,0)
.I $P(CHCD,"^",8)=0 S $P(CHCD,"^",8)=""
"RTN","CHMEAE9",89,0)
.Q:$P(CHCD,"^",8)=""
"RTN","CHMEAE9",90,0)
.I W55AGE<55 S CHBSTA="D",CHIREA="W55",CHEREA="" Q
"RTN","CHMEAE9",91,0)
G SPOUSE:$P(CHCD,U,4)'="C"
"RTN","CHMEAE9",92,0)
CHILD I $P(CHCD,U,19)=1 S CHBSTA="D",CHIREA="CM",CHEREA="" G END
"RTN","CHMEAE9",93,0)
I ($P(CHCD,U,13)="H")!($P(CHCD,U,33)=1) S CHBSTA="E",CHIREA="",CHEREA="H" D G END
"RTN","CHMEAE9",94,0)
.S X=$P(CHCD,U,3)+650000,X=$E(X,1,5)_"01" D DTBS S X=Y-1 D DATE
"RTN","CHMEAE9",95,0)
OVR65 .I Y<DT D Q
"RTN","CHMEAE9",96,0)
..I $P(^AHCHVA(DFN,100,BFN,0),"^",32)="" S CHBSTA="D",CHIREA="PMI",CHEREA=""
"RTN","CHMEAE9",97,0)
..S:($D(^AHCHVA(DFN,100,BFN,113))) CHBSTA="E",CHIREA="",CHEREA="EXH"
"RTN","CHMEAE9",98,0)
..D CFLCK Q
"RTN","CHMEAE9",99,0)
UND65 .I Y>DT S:($P(CHCD,U,32)=1) CHBSTA="D",CHIREA="AM",CHEREA="" Q
"RTN","CHMEAE9",100,0)
.Q
"RTN","CHMEAE9",101,0)
I ($P(CHCD,U,22)=1),($P(CHCD,U,3)<(DT-230000)) S CHBSTA="D",CHIREA="S23",CHEREA="" G END
"RTN","CHMEAE9",102,0)
I ($P(CHCD,U,22)=1&($P(CHCD,U,26)'="S")) S CHBSTA="E",CHIREA="",CHEREA="S23" D SCHOOL G END
"RTN","CHMEAE9",103,0)
I ($P(CHCD,U,22)=1&($P(CHCD,U,21)=1)) S CHBSTA="E",CHIREA="",CHEREA="S23" D SCHOOL G END
"RTN","CHMEAE9",104,0)
I ($P(CHCD,U,22)=1&($P(CHCD,U,21)=0)) S CHBSTA="D",CHIREA="CNH",CHEREA="" G END
"RTN","CHMEAE9",105,0)
I $P(CHCD,U,3)<(DT-180000) S CHBSTA="D",CHIREA="18",CHEREA="" G END
"RTN","CHMEAE9",106,0)
I ($P(CHCD,U,26)="A"),($P(CHCD,U,4)="C"),($P(^AHCHVA(DFN,0),U,4)?7N),($P(CHCD,U,27)?7N) I ($P(CHCD,U,27)-20000)>($P(^AHCHVA(DFN,0),U,4)) S CHBSTA="D",CHIREA="ASD",CHEREA="" G END ;TLH ADDED FOR CHECK IF ADOPTION >2YRS AFTER SPONSOR DOD ADDED NEW INELIGIBLE REASON
"RTN","CHMEAE9",107,0)
I $P(CHCD,U,26)'="S" S CHBSTA="E",CHIREA="",CHEREA="C18" G C1
"RTN","CHMEAE9",108,0)
I $P(CHCD,U,21)'=1 S CHBSTA="D",CHIREA="CNH",CHEREA="" G END
"RTN","CHMEAE9",109,0)
C1 I CHPTEND'="" I CHEND>CHPTEND S CHBSTA="D",CHIREA="SPT",CHEREA="" G END
"RTN","CHMEAE9",110,0)
S CHBSTA="E",CHIREA="",CHEREA="C18"
"RTN","CHMEAE9",111,0)
G END
"RTN","CHMEAE9",112,0)
SPOUSE I $P(CHCD,U,34)=1 S CHBSTA="D",CHIREA="PL",CHEREA="" G END
"RTN","CHMEAE9",113,0)
;I $D(CHFLGDIV) S CHBSTA="D",CHIREA="PL",CHEREA="" K CHFLGDIV G END ;SEE CHMEAE62
"RTN","CHMEAE9",114,0)
I $P(CHCD,U,16)=1 S CHBSTA="D",CHIREA="SMT",CHEREA="" G END
"RTN","CHMEAE9",115,0)
;S X=$P(CHCD,U,3)+650000 D DTBS S X=Y-1 D DATE
"RTN","CHMEAE9",116,0)
S DOB=$P(CHCD,U,3),CYR=DT
"RTN","CHMEAE9",117,0)
S AGE=$$AGE^CHTFLIB(DOB,CYR)
"RTN","CHMEAE9",118,0)
;CHKS ELIG FOR SPOUSE OVER 65
"RTN","CHMEAE9",119,0)
;I $P(CHCD,U,17)=1 D G END ;======================>DEV016528 YJK 1/22/13 Replaced by below
"RTN","CHMEAE9",120,0)
I $P(CHCD,U,17)=1 D ;======================>DEV016528 YJK 1/22/13
"RTN","CHMEAE9",121,0)
.;CHECK FOR REMARRAGE AGE OVER 55
"RTN","CHMEAE9",122,0)
.S DOB=$P(CHCD,U,3),RMDT=$P(CHCD,U,8)
"RTN","CHMEAE9",123,0)
.S W55AGE=$$AGE^CHTFLIB(DOB,RMDT)
"RTN","CHMEAE9",124,0)
.S CHAPP=$P(CHCD,U,38) ;TLH 1/24/06 trc 1369 CHAPP IS BENE APPLICATION DATE
"RTN","CHMEAE9",125,0)
.S CHMD=$P(CHCD,U,8) ;TLH 1/24/06 trc 1369 CHMD IS BENE REMARRIAGE DATE
"RTN","CHMEAE9",126,0)
.S CHIND=3030204 ;TLH 1/24/06 trc 1369 INACTMENT DATE OF PL 107-330
"RTN","CHMEAE9",127,0)
.S CHDDT=3041231 ;TLH 1/24/06 trc 1369 CHDDT DEADLINE TO APPLY FOR BENEFITS UNDER PL 107-330
"RTN","CHMEAE9",128,0)
.I W55AGE>54 I CHMD<CHIND I CHAPP>CHDDT S CHBSTA="D",CHIREA="A55",CHEREA="" Q ;TLH 1/24/06 trc 1369
"RTN","CHMEAE9",129,0)
.I W55AGE>54 S CHBSTA="E",CHIREA="",CHEREA="W55" D Q
"RTN","CHMEAE9",130,0)
..I AGE>64 I ($P(CHCD,U,32)=1)!($P(CHCD,U,32)=2)!($P(CHCD,U,32)="")!($P(CHCD,U,32)=3) D CFLCK I CHEREA="CFL" S CHEREA="N55"
"RTN","CHMEAE9",131,0)
..Q
"RTN","CHMEAE9",132,0)
.S CHBSTA="D",CHIREA="W55",CHEREA="" Q
"RTN","CHMEAE9",133,0)
I $P(CHCD,U,4)="XS" S CHBSTA="D",CHIREA="SMT",CHEREA="" G END
"RTN","CHMEAE9",134,0)
I CHPTEND'="" I CHEND>CHPTEND S CHBSTA="D",CHIREA="SPT",CHEREA="" G END
"RTN","CHMEAE9",135,0)
;I Y<DT I ($P(CHCD,U,32)=1)!($P(CHCD,U,32)=2)!($P(CHCD,U,32)="") S CHBSTA="D",CHIREA="AM",CHEREA="" S:($D(^AHCHVA(DFN,100,BFN,113))) CHBSTA="E",CHIREA="",CHEREA="EXH" G END
"RTN","CHMEAE9",136,0)
;S AGE=$$AGE^CHTFLIB(DOB,CYR)
"RTN","CHMEAE9",137,0)
;I AGE>64 I ($P(CHCD,U,32)=1)!($P(CHCD,U,32)=2)!($P(CHCD,U,32)="")!($P(CHCD,U,32)=3) D CFLCK G END ;======================> DEV016528 2/7/13 YJK Replaced by the below
"RTN","CHMEAE9",138,0)
;S X=$P(^AHCHVA(DFN,100,BFN,0),"^",3)+650000 ;MTN018287 TEST 6/13/13 YJK
"RTN","CHMEAE9",139,0)
;S DOB65=$$FMADD^XLFDT(X,-1,0,0,0) ;MTN018287 TEST 6/13/13 YJK
"RTN","CHMEAE9",140,0)
I AGE>64 I $P(CHCD,U,17)'=1 I ($P(CHCD,U,32)=1)!($P(CHCD,U,32)=2)!($P(CHCD,U,32)="")!($P(CHCD,U,32)=3) D CFLCK G END ;======================> DEV016528 2/7/13 YJK:
"RTN","CHMEAE9",141,0)
;I AGE>64 I $P(CHCD,U,32)=0 D G END
"RTN","CHMEAE9",142,0)
;.S CHBSTA="E",CHIREA="",CHEREA="M65"
"RTN","CHMEAE9",143,0)
;.I DOB65 > 3011000 D CFLCK ;MTN018287 TEST 6/13/13 YJK
"RTN","CHMEAE9",144,0)
;I AGE>64 I $P(CHCD,U,32)=0 S CHBSTA="E",CHIREA="",CHEREA="M65" G END
"RTN","CHMEAE9",145,0)
I AGE>64 I $P(CHCD,U,32)=0 D FUTDT1 G END ;DRW DEF0257 01/15/2019
"RTN","CHMEAE9",146,0)
I AGE>64 I $P(CHCD,U,32)=3 S CHBSTA="E",CHIREA="",CHEREA="M65" G END
"RTN","CHMEAE9",147,0)
;CKS ELIG FOR SPOUSE UNDER 65
"RTN","CHMEAE9",148,0)
I AGE<65 I $P(CHCD,U,32)=1 S CHBSTA="D",CHIREA="AM",CHEREA="" G END
"RTN","CHMEAE9",149,0)
;CHECK FOR SPOUSE UNDER 65 AND MEDICARE STATUS 0 IS NO MEDICARE
"RTN","CHMEAE9",150,0)
I AGE<65 I $P(CHCD,U,32)=0 S CHBSTA="E",CHIREA="",CHEREA="S65" G END ;DRW DEF025745 01/02/2019
"RTN","CHMEAE9",151,0)
I ($P(CHCD,U,18)=1)&($P(CHCD,U,7)="") S CHBST="D",CHIREA="RTD",CHEREA="" G END ;TLH 10/2/07 BUG003054
"RTN","CHMEAE9",152,0)
I (AGE>65)&($P(CHCD,U,18)=1)&($P(CHCD,U,7)="") S CHBST="D",CHIREA="RTD",CHEREA="" G END ;TLH 10/2/07 BUG003054
"RTN","CHMEAE9",153,0)
I $P(CHCD,U,18)=1 S CHBSTA="E",CHIREA="",CHEREA="WMT" G END
"RTN","CHMEAE9",154,0)
;I $P(CHCD,U,17)=1 S CHBSTA="D",CHIREA="RW",CHEREA="" G END ;======================> DEV016528 2/7/13 YJK: conflict with ReMarried logic above
"RTN","CHMEAE9",155,0)
I $P(CHCD,U,4)="XS" S CHBSTA="D",CHIREA="SMT",CHEREA="" G END
"RTN","CHMEAE9",156,0)
I CHPTEND'="" I CHEND>CHPTEND S CHBSTA="D",CHIREA="SPT",CHEREA="" G END
"RTN","CHMEAE9",157,0)
I $P(CHCD,U,17)=1 G END ;======================> DEV016528 2/7/13 YJK
"RTN","CHMEAE9",158,0)
S CHBSTA="E",CHIREA="",CHEREA="S65"
"RTN","CHMEAE9",159,0)
I ($P(CHCD,U,32)=0)!($P(CHCD,U,32)=2) S CHBSTA="E",CHIREA="",CHEREA="CFL" ;TLH 4/10/07 ENC000188
"RTN","CHMEAE9",160,0)
I ($P(CHCD,U,32)=2) D FUTDT ;YJK 3/9/2010 - DEV008403-02; YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",161,0)
END ;
"RTN","CHMEAE9",162,0)
I (($P(CHCD,U,5)["E")!($P(CHCD,U,5)["P")),(CHBSTA="E") D
"RTN","CHMEAE9",163,0)
.S J=0,CHVD1="" F I=0:0 S I=$O(^AHCHVA(DFN,100,BFN,110,I)) Q:'I D S J=I
"RTN","CHMEAE9",164,0)
..S:($P(^(I,0),U))!($P(^(0),U)=0) $P(CHVD1,U,1,3)=$P(^(0),U,1,3)
"RTN","CHMEAE9",165,0)
..S:($P(^(0),U,4))!($P(^(0),U,4)=0) $P(CHVD1,U,4,6)=$P(^(0),U,4,6)
"RTN","CHMEAE9",166,0)
..S:($P(^(0),U,7))!($P(^(0),U,7)=0) $P(CHVD1,U,7,9)=$P(^(0),U,7,9)
"RTN","CHMEAE9",167,0)
..S:($P(^(0),U,10))!($P(^(0),U,10)=0) $P(CHVD1,U,10,12)=$P(^(0),U,10,12)
"RTN","CHMEAE9",168,0)
..S:($P(^(0),U,13))!($P(^(0),U,13)=0) $P(CHVD1,U,13,15)=$P(^(0),U,13,15)
"RTN","CHMEAE9",169,0)
..S:($P(^(0),U,16))!($P(^(0),U,16)=0) $P(CHVD1,U,16,18)=$P(^(0),U,16,18)
"RTN","CHMEAE9",170,0)
..S:($P(^(0),U,19))!($P(^(0),U,19)=0) $P(CHVD1,U,19,21)=$P(^(0),U,19,21)
"RTN","CHMEAE9",171,0)
..S:($P(^(0),U,22))!($P(^(0),U,22)=0) $P(CHVD1,U,22,24)=$P(^(0),U,22,24)
"RTN","CHMEAE9",172,0)
..S:($P(^(0),U,25))!($P(^(0),U,25)=0) $P(CHVD1,U,25,27)=$P(^(0),U,25,27)
"RTN","CHMEAE9",173,0)
..Q
"RTN","CHMEAE9",174,0)
.I ($P(CHVD1,U,1)'=1)!($P(CHVD1,U,4)'=1)!($P(CHVD1,U,7)'=1)!($P(CHVD1,U,10)'=1) S CHBSTA="PS" K CHVD1 Q
"RTN","CHMEAE9",175,0)
.I ($P(CHVD1,U,13)=0)!($P(CHVD1,U,16)'=1)!($P(CHVD1,U,19)'=1) S CHBSTA="PS" K CHVD1 Q
"RTN","CHMEAE9",176,0)
.I ($P(CHVD1,U,22)'=1)!($P(CHVD1,U,25)'=1) S CHBSTA="PS" K CHVD1 Q
"RTN","CHMEAE9",177,0)
.S CHBSTA="EA"
"RTN","CHMEAE9",178,0)
.Q
"RTN","CHMEAE9",179,0)
I ($P(CHCD,U,5)="D"),(CHBSTA="E") S $P(CHCD,U,5)="PS"
"RTN","CHMEAE9",180,0)
E S $P(CHCD,U,5)=CHBSTA
"RTN","CHMEAE9",181,0)
S $P(CHCD,U,12)=CHIREA,$P(CHCD,U,13)=CHEREA
"RTN","CHMEAE9",182,0)
I $P(CHCD,U,5)=$P(CHPD,U,5) I $P(CHCD2,U,5)'="" I '$D(CHCD30)!($P($G(CHCD30),U,1)=0) Q ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE9",183,0)
S $P(CHCD2,U,5)=20,$P(CHCD3,U,5)=DT
"RTN","CHMEAE9",184,0)
S:CHIREA'="" $P(CHCD2,U,12)=20,$P(CHCD3,U,12)=DT
"RTN","CHMEAE9",185,0)
S:CHEREA'="" $P(CHCD2,U,13)=20,$P(CHCD3,U,13)=DT
"RTN","CHMEAE9",186,0)
S:$P(CHCD,U,5)'=$P(CHPD,U,5) $P(CHCD,U,11)=DT
"RTN","CHMEAE9",187,0)
D RRSTAT^CHMEAE8U(DFN,BFN) ;JEH 3/12/15 - ENC22734
"RTN","CHMEAE9",188,0)
S:$P(CHCD,U,5)'=$P(CHPD,U,5) $P(CHCD,U,11)=DT D STATUS^CHEDISEN ;DEV023183 ACA DISENROLLMENT 5/21/15 AEB/JAK
"RTN","CHMEAE9",189,0)
K AGE Q
"RTN","CHMEAE9",190,0)
PLWMT ;public law/widowers marriage terminated check
"RTN","CHMEAE9",191,0)
I ($P(CHCD,U,4)'="C")&($P(CHCD,U,18)=1)&(CHEND'<DT) S CHBSTA="E",CHIREA="",CHEREA="WMT"
"RTN","CHMEAE9",192,0)
I $P(CHCD,U,34)=1 S CHBSTA="D",CHIREA="PL",CHEREA=""
"RTN","CHMEAE9",193,0)
Q
"RTN","CHMEAE9",194,0)
SCHOOL S CHBEG="",CHBSTA="D",CHIREA="NCL",CHEREA=""
"RTN","CHMEAE9",195,0)
S1 S CHBEG=$O(^AHCHVA(DFN,100,BFN,105,CHBEG)),CHEND="" Q:'CHBEG
"RTN","CHMEAE9",196,0)
S2 S CHEND=$O(^AHCHVA(DFN,100,BFN,105,CHBEG,CHEND)) G S1:CHEND=""
"RTN","CHMEAE9",197,0)
I (CHBEG'>DT),(DT'>CHEND) S CHBSTA="E",CHIREA="",CHEREA="S23" Q
"RTN","CHMEAE9",198,0)
G S2
"RTN","CHMEAE9",199,0)
DTBS S %M=+$E(X,4,5),%D=+$E(X,6,7),%Y=$E(X,1,3)+1700
"RTN","CHMEAE9",200,0)
I %M<1!(%M>12)!(%D<1)!(%D>31)!(%Y<1841) S Y=-1 G DTBSK
"RTN","CHMEAE9",201,0)
S %L=0 I %Y#4=0,'(%Y=1900) S %L=1
"RTN","CHMEAE9",202,0)
I %D>30,%M=4!(%M=6)!(%M=9)!(%M=11) S Y=-1 G DTBSK
"RTN","CHMEAE9",203,0)
I %M=2,%L=0*(%D>28)!(%L=1*(%D>29)) S Y=-1 G DTBSK
"RTN","CHMEAE9",204,0)
I %L=0 S %J=$P("0,31,59,90,120,151,181,212,243,273,304,334",",",%M)+%D
"RTN","CHMEAE9",205,0)
E S %J=$P("0,31,60,91,121,152,182,213,244,274,305,335",",",%M)+%D
"RTN","CHMEAE9",206,0)
S Y=%J+(%Y-1841*365)+(%Y-1841\4)-(%Y>1900*1)
"RTN","CHMEAE9",207,0)
DTBSK K %D,%J,%L,%M,%Y Q
"RTN","CHMEAE9",208,0)
DATE S Y="" Q:X'?5N D ZDATE S Y=$E(Y,7,10)-1700_$E(Y,1,2)_$E(Y,4,5) Q
"RTN","CHMEAE9",209,0)
ZDATE I X'?1N.N S Y="" Q
"RTN","CHMEAE9",210,0)
S %a=$S(X<21915:0,1:X-21914\36524+1),%a=X+%a-(%a+2\4),%b=%a#1461
"RTN","CHMEAE9",211,0)
S %f=$E(%b*.00273785,1),%y=%a\1461*4+1841+%f
"RTN","CHMEAE9",212,0)
S %m=101,%d=%b-(%f*365) I %d=0 S %m=112,%y=%y-1,%d=31 G ZDATEQ
"RTN","CHMEAE9",213,0)
F %i=31,$S(%y#100:%y#4=0,1:%y#400=0)+28,31,30,31,30,31,31,30,31,30 Q:%i'<%d S %m=%m+1,%d=%d-%i
"RTN","CHMEAE9",214,0)
ZDATEQ S Y=$E(%m,2,3)_"/"_$E(%d+100,2,3)_"/"_$E(%y,1,4) K %a,%b,%d,%f,%i,%m,%y Q
"RTN","CHMEAE9",215,0)
CFLCK ;CHECK TO SEE IF ELIG UNDER CFL EFFECTIVE 10/01/01
"RTN","CHMEAE9",216,0)
I CHBSTA="D" I CHIREA="A55" G END ;TLH 1/25/06 trc 1369
"RTN","CHMEAE9",217,0)
Q:RO3884=0
"RTN","CHMEAE9",218,0)
Q:(CHSTA'="I")&(CHREA=1)&($P(CHCD,U,17)'=1)&($P(CHCD,U,7)="")&($P(CHCD,U,8)="") ;MTN018346 6/19/13 YJK
"RTN","CHMEAE9",219,0)
I (AGE>65)&($P(CHCD,U,18)=1)&($P(CHCD,U,7)="") S CHBST="D",CHIREA="RTD",CHEREA="" Q ;TLH 10/2/07 BUG003054
"RTN","CHMEAE9",220,0)
CFL1 I '$D(DT) D NOW^%DTC S DT=X
"RTN","CHMEAE9",221,0)
I $P(CHCD,U,4)="C" D
"RTN","CHMEAE9",222,0)
.S:($P(CHCD,U,32)=1) CHBSTA="D",CHIREA="AM",CHEREA="" S:($D(^AHCHVA(DFN,100,BFN,113))) CHBSTA="E",CHIREA="",CHEREA="EXH"
"RTN","CHMEAE9",223,0)
.Q
"RTN","CHMEAE9",224,0)
I $P(CHCD,U,4)'="C" D
"RTN","CHMEAE9",225,0)
.S CHBSTA="D",CHIREA="PMI",CHEREA="" S:($D(^AHCHVA(DFN,100,BFN,113))) CHBSTA="E",CHIREA="",CHEREA="EXH"
"RTN","CHMEAE9",226,0)
.Q
"RTN","CHMEAE9",227,0)
S (CHMEDA,CHMEDB)=0
"RTN","CHMEAE9",228,0)
Q:$P(CHCD,U,32)=""
"RTN","CHMEAE9",229,0)
I DT<3010101 Q
"RTN","CHMEAE9",230,0)
S CHKYR=3010605
"RTN","CHMEAE9",231,0)
;TLH 7/24/06 MC256/PROJECT 1503 LINE BELOW CHANGED TO STATE IF "^"32 IS =1 SET BENE INELIGIBLE ;tlh 4/3/07
"RTN","CHMEAE9",232,0)
I AGE>64 I $P(CHCD,"^",32)>0 I $P(CHCD,"^",10)>3010605 I $P(CHCD,"^",32)=1 S CHBSTA="D",CHIREA="SCP",CHEREA="" Q ;AEB 5/18/2006 (PT1392) change for qe date chk ;tlh 4/3/07 change to if not having Med A&B MODIFIED 7/16/07 DEF002711
"RTN","CHMEAE9",233,0)
MEDACK ;CHK TO SEE IF MED A IN CHYR
"RTN","CHMEAE9",234,0)
S TMPAYR=0,CHMEDA=0 G:'$D(^AHCHVA(DFN,100,BFN,111)) MEDBCK
"RTN","CHMEAE9",235,0)
MEDA1 S TMPAYR=$O(^AHCHVA(DFN,100,BFN,111,TMPAYR)) G:'TMPAYR MEDBCK
"RTN","CHMEAE9",236,0)
G:'$D(^AHCHVA(DFN,100,BFN,111,TMPAYR,0)) MEDA1
"RTN","CHMEAE9",237,0)
S CHAYR=$P(^AHCHVA(DFN,100,BFN,111,TMPAYR,0),"^",1)
"RTN","CHMEAE9",238,0)
S CHEYR=$P(^AHCHVA(DFN,100,BFN,111,TMPAYR,0),"^",4)
"RTN","CHMEAE9",239,0)
I CHAYR<CHKYR S CHMEDA=-1
"RTN","CHMEAE9",240,0)
I CHAYR'<CHKYR S CHMEDA=1
"RTN","CHMEAE9",241,0)
I CHMEDA=-1 I CHEYR'="" I CHEYR<CHKYR S CHMEDA=0
"RTN","CHMEAE9",242,0)
G MEDA1
"RTN","CHMEAE9",243,0)
MEDBCK ;CHK TO SEE IF MED B IN CHYR
"RTN","CHMEAE9",244,0)
S TMPBYR=9,CHMEDB=0
"RTN","CHMEAE9",245,0)
MEDB1 S TMPBYR=$O(^AHCHVA(DFN,100,BFN,112,TMPBYR)) G:'TMPBYR CFLCK1
"RTN","CHMEAE9",246,0)
G:'$D(^AHCHVA(DFN,100,BFN,112,TMPBYR)) MEDB1
"RTN","CHMEAE9",247,0)
S CHBBYR=$P(^AHCHVA(DFN,100,BFN,112,TMPBYR,0),"^",1)
"RTN","CHMEAE9",248,0)
S CHBEYR=$P(^AHCHVA(DFN,100,BFN,112,TMPBYR,0),"^",4)
"RTN","CHMEAE9",249,0)
I CHBBYR<CHKYR I CHBEYR="" S CHMEDB=3 ;MED B BEFORE 6/5/01 STILL HAS MED B
"RTN","CHMEAE9",250,0)
I CHBBYR<CHKYR I CHBEYR'="" I CHBEYR<CHKYR S CHMEDB=-1 ;MED B BEFORE 6/5/01 AND DROPPED
"RTN","CHMEAE9",251,0)
I CHBBYR'<CHKYR I CHBEYR="" S CHMEDB=1
"RTN","CHMEAE9",252,0)
I CHBBYR<CHKYR I CHBEYR'="" I CHBEYR<CHKYR S CHMEDB=0
"RTN","CHMEAE9",253,0)
I CHBBYR<CHKYR I CHBEYR'="" I CHBEYR>CHKYR S CHMEDB=2
"RTN","CHMEAE9",254,0)
I CHBBYR'<CHKYR I CHBEYR'="" I CHBEYR>CHKYR S CHMEDB=2
"RTN","CHMEAE9",255,0)
G MEDB1
"RTN","CHMEAE9",256,0)
CFLCK1 ;CHMEDA = -1 HAD MED A PRIOR TO 6/5/01
"RTN","CHMEAE9",257,0)
; = 0 NEVER HAD MED A
"RTN","CHMEAE9",258,0)
; = 1 HAS MED A ON/OR AFTER 6/5/01
"RTN","CHMEAE9",259,0)
;
"RTN","CHMEAE9",260,0)
;CHMEDB = -1 HAD MED B PRIOR TO 6/5/01 DROPPPED MED B BEFORE 6/5/01
"RTN","CHMEAE9",261,0)
; = 0 NEVER HAD MED B
"RTN","CHMEAE9",262,0)
; = 1 HAS MED B AFTER 6/5/01
"RTN","CHMEAE9",263,0)
; = 2 MED B ENDED ON/OR AFTER 6/5/01
"RTN","CHMEAE9",264,0)
; = 3 HAD MED B PRIOR TO 6/5/01
"RTN","CHMEAE9",265,0)
;
"RTN","CHMEAE9",266,0)
; MED A PRIOR TO 6/5/01
"RTN","CHMEAE9",267,0)
I CHMEDA=-1 D
"RTN","CHMEAE9",268,0)
.I CHMEDB=0 D Q
"RTN","CHMEAE9",269,0)
..S T65BD=$P(CHCD,"^",3)+650000 I T65BD>3010605 S CHBSTA="D",CHIREA="CFB",CHEREA="" K T65BD Q
"RTN","CHMEAE9",270,0)
..S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",271,0)
..K T65BD Q
"RTN","CHMEAE9",272,0)
.I CHMEDB=-1 D Q
"RTN","CHMEAE9",273,0)
..S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",274,0)
..Q
"RTN","CHMEAE9",275,0)
.I CHMEDB=1 D Q
"RTN","CHMEAE9",276,0)
..S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",277,0)
..Q
"RTN","CHMEAE9",278,0)
.;I CHMEDB=2 D Q
"RTN","CHMEAE9",279,0)
.;.S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",280,0)
.;.Q
"RTN","CHMEAE9",281,0)
.I CHMEDB=3 D Q
"RTN","CHMEAE9",282,0)
..S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",283,0)
..Q
"RTN","CHMEAE9",284,0)
.Q
"RTN","CHMEAE9",285,0)
;
"RTN","CHMEAE9",286,0)
;NEVER HAD MED A
"RTN","CHMEAE9",287,0)
;
"RTN","CHMEAE9",288,0)
I CHMEDA=0 D
"RTN","CHMEAE9",289,0)
.I CHMEDB=0 D Q
"RTN","CHMEAE9",290,0)
..S CHBSTA="E",CHIREA="",CHEREA="M65"
"RTN","CHMEAE9",291,0)
..Q
"RTN","CHMEAE9",292,0)
.I CHMEDB=-1 D Q
"RTN","CHMEAE9",293,0)
..S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",294,0)
..Q
"RTN","CHMEAE9",295,0)
.I CHMEDB=1 D Q
"RTN","CHMEAE9",296,0)
..S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",297,0)
..Q
"RTN","CHMEAE9",298,0)
.I CHMEDB=2 D Q
"RTN","CHMEAE9",299,0)
..S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",300,0)
..Q
"RTN","CHMEAE9",301,0)
.I CHMEDB=3 D Q
"RTN","CHMEAE9",302,0)
..S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",303,0)
..Q
"RTN","CHMEAE9",304,0)
.Q
"RTN","CHMEAE9",305,0)
;
"RTN","CHMEAE9",306,0)
;GOT MED A ON/OR AFTER 6/5/01
"RTN","CHMEAE9",307,0)
I CHMEDA=1 D
"RTN","CHMEAE9",308,0)
.I CHMEDB=0 D Q
"RTN","CHMEAE9",309,0)
..S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",310,0)
..S TAGE=$$AGE^CHTFLIB($P(CHCD,"^",3),CHKYR)
"RTN","CHMEAE9",311,0)
..I TAGE>64 S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",312,0)
..Q
"RTN","CHMEAE9",313,0)
.I CHMEDB=-1 D Q
"RTN","CHMEAE9",314,0)
..S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",315,0)
..Q
"RTN","CHMEAE9",316,0)
.I CHMEDB=1 D Q
"RTN","CHMEAE9",317,0)
..S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",318,0)
..Q
"RTN","CHMEAE9",319,0)
.I CHMEDB=2 D Q
"RTN","CHMEAE9",320,0)
..S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",321,0)
..Q
"RTN","CHMEAE9",322,0)
.I CHMEDB=3 D Q
"RTN","CHMEAE9",323,0)
..S CHBSTA="E",CHIREA="",CHEREA="CFL"
"RTN","CHMEAE9",324,0)
..Q
"RTN","CHMEAE9",325,0)
.Q
"RTN","CHMEAE9",326,0)
Q
"RTN","CHMEAE9",327,0)
FUTDT ;Check for future Medicare dates and set eligibility status ;YJK 3/9/2010 - DEV008403-02
"RTN","CHMEAE9",328,0)
N MEDBSDT,MEDBEDT,MEDASDT,MEDAEDT ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",329,0)
S (MEDBSDT,MEDBEDT,MEDASDT,MEDAEDT)="" ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",330,0)
Q:'$D(^AHCHVA(DFN,100,BFN,112))
"RTN","CHMEAE9",331,0)
S TMPDT=9999999999
"RTN","CHMEAE9",332,0)
S TMPDT=$O(^AHCHVA(DFN,100,BFN,112,TMPDT),-1) Q:'TMPDT
"RTN","CHMEAE9",333,0)
S MEDBSDT=$P(^AHCHVA(DFN,100,BFN,112,TMPDT,0),"^",1)
"RTN","CHMEAE9",334,0)
S MEDBEDT=$P(^AHCHVA(DFN,100,BFN,112,TMPDT,0),"^",4)
"RTN","CHMEAE9",335,0)
Q:'$D(^AHCHVA(DFN,100,BFN,111)) ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",336,0)
S TMPDT=9999999999 ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",337,0)
S TMPDT=$O(^AHCHVA(DFN,100,BFN,111,TMPDT),-1) Q:'TMPDT ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",338,0)
S MEDASDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",1) ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",339,0)
S MEDAEDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",4) ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",340,0)
Q:MEDASDT=MEDBSDT ;YJK 7/13/2010 - BUG008403-09-01
"RTN","CHMEAE9",341,0)
I (MEDBSDT>DT)!(MEDBEDT'=""&(MEDBEDT<DT)) S CHBSTA="D",CHIREA="AM",CHEREA=""
"RTN","CHMEAE9",342,0)
Q
"RTN","CHMEAE9",343,0)
;;DEF025745 DRW 01/02/2019 ADDED THIS LINE TAG FOR STATUS REASONS
"RTN","CHMEAE9",344,0)
FUTDT1 ;CHECKING FOR MED A AND B END DATES FOR OVER 65
"RTN","CHMEAE9",345,0)
N MEDBSDT,MEDBEDT,MEDASDT,MEDAEDT
"RTN","CHMEAE9",346,0)
S (MEDBSDT,MEDBEDT,MEDASDT,MEDAEDT)=""
"RTN","CHMEAE9",347,0)
S NOMED=0 ;SET MEDICARE FLAG
"RTN","CHMEAE9",348,0)
S:'$D(^AHCHVA(DFN,100,BFN,112)) NOMED=1
"RTN","CHMEAE9",349,0)
I NOMED G ENDLN
"RTN","CHMEAE9",350,0)
S TMPDT=9999999999
"RTN","CHMEAE9",351,0)
S TMPDT=$O(^AHCHVA(DFN,100,BFN,112,TMPDT),-1) Q:'TMPDT
"RTN","CHMEAE9",352,0)
S MEDBSDT=$P(^AHCHVA(DFN,100,BFN,112,TMPDT,0),"^",1)
"RTN","CHMEAE9",353,0)
S MEDBEDT=$P(^AHCHVA(DFN,100,BFN,112,TMPDT,0),"^",4)
"RTN","CHMEAE9",354,0)
S:'$D(^AHCHVA(DFN,100,BFN,111)) NOMED=1
"RTN","CHMEAE9",355,0)
I NOMED G ENDLN
"RTN","CHMEAE9",356,0)
S TMPDT=9999999999
"RTN","CHMEAE9",357,0)
S TMPDT=$O(^AHCHVA(DFN,100,BFN,111,TMPDT),-1) Q:'TMPDT
"RTN","CHMEAE9",358,0)
S MEDASDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",1)
"RTN","CHMEAE9",359,0)
S MEDAEDT=$P(^AHCHVA(DFN,100,BFN,111,TMPDT,0),"^",4)
"RTN","CHMEAE9",360,0)
I NOMED=0 D
"RTN","CHMEAE9",361,0)
.I AGE>64 I $P(CHCD,U,32)=0 D
"RTN","CHMEAE9",362,0)
..I MEDAEDT=MEDBEDT S CHBSTA="D",CHIREA="PMI",CHEREA=""
"RTN","CHMEAE9",363,0)
..I MEDAEDT'=MEDBEDT S CHBSTA="D",CHIREA="CFB",CHEREA=""
"RTN","CHMEAE9",364,0)
G ENDLN1
"RTN","CHMEAE9",365,0)
ENDLN
"RTN","CHMEAE9",366,0)
S CHBSTA="D",CHIREA="",CHEREA="65"
"RTN","CHMEAE9",367,0)
ENDLN1 Q
"RTN","CHMEAM")
0^3^B14578573
"RTN","CHMEAM",1,0)
CHMEAM ;CSW/DEN;"MORE" SCREENS DRIVER;Jan 08, 2019@09:32:26
"RTN","CHMEAM",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAM",3,0)
;CPTS 8591 CPTS 13197 BY CAM
"RTN","CHMEAM",4,0)
;CPTS 16846 (AEB)
"RTN","CHMEAM",5,0)
;;DEV023457 AEB 10-21-2015
"RTN","CHMEAM",6,0)
W @CHMARESET S DY=20,DX=1 X X Y D BOTTOM S DY=18 X CHMAR,XY S CHMFLAG=0
"RTN","CHMEAM",7,0)
Z1 S DY=20,DX=1 X XY W "More Screen: VIEW// ",@CHEOL
"RTN","CHMEAM",8,0)
D CSBRS^CHSC2 G END:($D(DUOUT))!($D(DFOUT))
"RTN","CHMEAM",9,0)
I $D(DQOUT) W !!,"Use the Table below for valid entries." G Z1
"RTN","CHMEAM",10,0)
S:Y="" Y="V" S:Y="q" Y="Q" S:Y="v" Y="V"
"RTN","CHMEAM",11,0)
G END:(Y="V")!(Y="Q") S Y=+Y S:Y<1 Y=0
"RTN","CHMEAM",12,0)
D OPTION I X="" W *7," ??" G Z1
"RTN","CHMEAM",13,0)
I ((CHSEC=0)!(CHSEC=1))&(Y'=12) W *7,!!,"You cannot access this option." G Z1
"RTN","CHMEAM",14,0)
I ((Y=1)!(Y=2)!(Y=7)!(Y=8))&(CHSEC=2) W *7,!!,"You cannot access this option." G Z1
"RTN","CHMEAM",15,0)
S CHDEFNUM=Y,CHPROG="^CHMEAM"_Y
"RTN","CHMEAM",16,0)
;S:Y=14 CHPROG="^CHMEAMA" ;AEB DEV023457 10-21-2015 COMMENTED OFF
"RTN","CHMEAM",17,0)
S:Y=14 CHPROG="^CHMEAMB" ;AEB DEV023457 10-21-2015; ADDED NEW ROUTINE CHMEAMB
"RTN","CHMEAM",18,0)
W @IOZF,@CHMARESET D TOP^CHMEAV
"RTN","CHMEAM",19,0)
S DY=19,DX=1 X XY W CHL D BOTTOM
"RTN","CHMEAM",20,0)
D @CHPROG
"RTN","CHMEAM",21,0)
Z2 W @CHMARESET S DY=20,DX=1 X XY D BOTTOM
"RTN","CHMEAM",22,0)
S CHDEF="VIEW",CHDEFNUM="V"
"RTN","CHMEAM",23,0)
ASK S DY=20,DX=1 X XY W " "
"RTN","CHMEAM",24,0)
X XY W "More Screen: ",CHDEF,"// "
"RTN","CHMEAM",25,0)
;S DY=20,DX=1 X XY W @CHEEL,"More Screen: ",CHDEF,"// "
"RTN","CHMEAM",26,0)
A1 S DX=$L(CHDEF)+17 X XY W @CHEOL D CSBRS^CHSC2 G END:($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAM",27,0)
I $D(DQOUT) W " Use the Table below for valid entries." R X:2 G A1
"RTN","CHMEAM",28,0)
S:Y="" Y=CHDEFNUM S:Y="q" Y="Q" S:Y="v" Y="V" S CHMFLAG=1
"RTN","CHMEAM",29,0)
G END:(Y="V")!(Y="Q") S Y=+Y S:Y<1 Y=0
"RTN","CHMEAM",30,0)
D OPTION I X="" W *7," ??" R X:2 G A1
"RTN","CHMEAM",31,0)
I ((CHSEC=0)!(CHSEC=1))&(Y'=12) W *7," You cannot access this option." R X:2 G A1
"RTN","CHMEAM",32,0)
I ((Y=1)!(Y=2)!(Y=7)!(Y=8))&(CHSEC=2) W *7," You cannot access this option." R X:2 G A1
"RTN","CHMEAM",33,0)
S CHDEFNUM=Y,CHPROG="^CHMEAM"_Y
"RTN","CHMEAM",34,0)
;S:Y=14 CHPROG="^CHMEAMA" ;AEB DEV023457 10-21-2015 COMMENTED OFF
"RTN","CHMEAM",35,0)
S:Y=14 CHPROG="^CHMEAMB" ;AEB DEV023457 10-21-2015; ADDED NEW ROUTINE CHMEAMB
"RTN","CHMEAM",36,0)
D @CHPROG
"RTN","CHMEAM",37,0)
END K CHDEF,CHDEFNUM
"RTN","CHMEAM",38,0)
Q
"RTN","CHMEAM",39,0)
OPTION S X=$P($T(OPTION+(Y+1)),";;",2)
"RTN","CHMEAM",40,0)
Q:X="" W " ",X Q
"RTN","CHMEAM",41,0)
1 ;;SET SPECIAL HANDLING FLAG
"RTN","CHMEAM",42,0)
2 ;;ASSIGN SECURITY
"RTN","CHMEAM",43,0)
3 ;;VERIFY DATA ENTRY
"RTN","CHMEAM",44,0)
4 ;;RETURNED MAIL HANDLING
"RTN","CHMEAM",45,0)
5 ;;REQUEST RO-3884
"RTN","CHMEAM",46,0)
6 ;;CLEAR RO-3884
"RTN","CHMEAM",47,0)
7 ;;PRODUCE MANAGEMENT REPORTS
"RTN","CHMEAM",48,0)
8 ;;DATA DISCREPANCY CHECKER
"RTN","CHMEAM",49,0)
9 ;;FILE DUMP
"RTN","CHMEAM",50,0)
10 ;;REQUEST BENEFICIARY ID CARD
"RTN","CHMEAM",51,0)
11 ;;ADD BENEFICIARY TO DEERS TAPE
"RTN","CHMEAM",52,0)
12 ;;DISPLAY ELIGIBILITY PERIODS
"RTN","CHMEAM",53,0)
13 ;;BACKDATE ELIGIBILITY
"RTN","CHMEAM",54,0)
14 ;;DISENROLLMENT/REENROLLMENT DATES ;;AEB DEV023457 10-21-2015
"RTN","CHMEAM",55,0)
Q
"RTN","CHMEAM",56,0)
SBRS R Y:$S($D(DTIME):DTIME,1:60)
"RTN","CHMEAM",57,0)
I '$T W *7 R Y:5 G SBRS:Y="." S:'$T Y=IOZFO
"RTN","CHMEAM",58,0)
SBRS1 K DFOUT,DUOUT,DQOUT S:'$D(IOZFO) IOZFO="^^" S:'$D(IOZBK) IOZBK="^"
"RTN","CHMEAM",59,0)
I IOZFO=Y W:$D(IOZF) @IOZF S (DFOUT,Y)="" Q
"RTN","CHMEAM",60,0)
S:Y=IOZBK (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
"RTN","CHMEAM",61,0)
Q
"RTN","CHMEAM",62,0)
BOTTOM ;U $I:81 ;skd
"RTN","CHMEAM",63,0)
U $I:"^%X364" ;skd
"RTN","CHMEAM",64,0)
S DY=21,DX=1 X XY W @CHREVON,@CHBON,1,@CHBOFF,@CHREVON," Specl Hand Flag "
"RTN","CHMEAM",65,0)
W @CHBON,5,@CHBOFF,@CHREVON," Request RO-3884 "
"RTN","CHMEAM",66,0)
W @CHBON,9,@CHBOFF,@CHREVON," File Dump "
"RTN","CHMEAM",67,0)
W @CHBON,13,@CHBOFF,@CHREVON," Backdate Elig "
"RTN","CHMEAM",68,0)
S DY=22,DX=1 X XY W @CHBON,2,@CHBOFF,@CHREVON," Assign Security "
"RTN","CHMEAM",69,0)
W @CHBON,6,@CHBOFF,@CHREVON," Clear RO-3884 "
"RTN","CHMEAM",70,0)
W @CHBON,10,@CHBOFF,@CHREVON," Request ID Card "
"RTN","CHMEAM",71,0)
W @CHBON,14,@CHBOFF,@CHREVON," Disenroll data " ;AEB DEV023457 10-21-2015
"RTN","CHMEAM",72,0)
S DY=23,DX=1 X XY W @CHBON,3,@CHBOFF,@CHREVON," Verify Data "
"RTN","CHMEAM",73,0)
W @CHBON,7,@CHBOFF,@CHREVON," Mgmt Reports "
"RTN","CHMEAM",74,0)
W @CHBON,11,@CHBOFF,@CHREVON," Add to DEERS Tape "
"RTN","CHMEAM",75,0)
W @CHBON,"^",@CHBOFF,@CHREVON," New Sponsor "
"RTN","CHMEAM",76,0)
S DY=24,DX=1 X XY W @CHBON,4,@CHBOFF,@CHREVON," Returned Mail "
"RTN","CHMEAM",77,0)
W @CHBON,8,@CHBOFF,@CHREVON," Data Discrp Check "
"RTN","CHMEAM",78,0)
W @CHBON,12,@CHBOFF,@CHREVON," Eligibility Dates "
"RTN","CHMEAM",79,0)
W @CHBON,"V",@CHBOFF,@CHREVON," View ",@CHREVOFF
"RTN","CHMEAM",80,0)
U $I:"^%X364"
"RTN","CHMEAM",81,0)
Q
"RTN","CHMEAM12")
0^25^B30444083
"RTN","CHMEAM12",1,0)
CHMEAM12 ;CSW/DEN;DISPLAY ELIGIBILITY DATES;Jan 08, 2019@09:33:05
"RTN","CHMEAM12",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAM12",3,0)
;S DY=2,DX=1 X XY F I=2:1:18 W @CHEEL,!
"RTN","CHMEAM12",4,0)
;S DY=2,DX=1 X XY F DY=2:1:17 X XY W @CHEEL
"RTN","CHMEAM12",5,0)
S DY=3,DX=1 X XY F DY=3:1:17 X XY W @CHEEL ; JEH 9/12/05
"RTN","CHMEAM12",6,0)
S DY=DY+1 X XY W @CHEEL S DTM=5,DBM=18,DY=2 X CHMAR,XY
"RTN","CHMEAM12",7,0)
;S DY=DY+1 X XY W ?30,@CHBON,"Eligibility Dates",@CHBOFF
"RTN","CHMEAM12",8,0)
;D ^CHMEAV52 G ASK:'$D(BFN) S DY=5,DX=1 X XY F I=1:1:16 W @CHEEL,! ; JEH 9/12/05
"RTN","CHMEAM12",9,0)
D ^CHMEAV52 G ASK:'$D(BFN)
"RTN","CHMEAM12",10,0)
S CHMAX=10 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",11,0)
S DTM=3,DBM=17 X CHMAR X XY ; JEH 9/12/05
"RTN","CHMEAM12",12,0)
S DY=5,DX=1 X XY F I=1:1:16 W @CHEEL,! ; JEH 9/12/05
"RTN","CHMEAM12",13,0)
S DY=2,DX=33 X XY W @CHBON,"Beneficiary",@CHBOFF
"RTN","CHMEAM12",14,0)
;S DY=4,DX=30 X XY W @CHBON,"Eligibility Dates",@CHBOFF S TMPCT=0 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",15,0)
S DY=3,DX=30 X XY W @CHBON,"Eligibility Dates",@CHBOFF S TMPCT=0 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",16,0)
;I ('$D(^AHCHVA(DFN,100,BFN,105))),('$D(^(109))) W $C(7),!!,"This beneficiary has no periods of eligibility!",!!! S CT=CT+5 G A2 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",17,0)
;S DY=5,DX=1 X XY F I=1:1:15 W @CHEEL,!
"RTN","CHMEAM12",18,0)
;S DY=5,DX=1 X XY F DY=5:1:15 X XY W @CHEEL
"RTN","CHMEAM12",19,0)
;S DY=5 X XY W ! S CT=CT+1
"RTN","CHMEAM12",20,0)
;S DY=DY+2,DX=22 X XY W @CHULON,"Begin Date ",@CHULOFF S DX=38 X XY W @CHULON,"End Date ",@CHULOFF S CT=CT+1 ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",21,0)
S DY=4,DX=22 X XY W @CHULON,"Begin Date ",@CHULOFF S DX=38 X XY W @CHULON,"End Date ",@CHULOFF S CT=CT+1 ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",22,0)
I ('$D(^AHCHVA(DFN,100,BFN,105))),('$D(^(109))) S DY=DY+1,DX=22 X XY W $C(7),"This beneficiary has no periods of eligibility!",!!!!! S CT=CT+CHMAX,DY=DY+1 G A2 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",23,0)
;W !,@CHBON,"'Possible' Dates:",@CHBOFF
"RTN","CHMEAM12",24,0)
;I '$D(^AHCHVA(DFN,100,BFN,105)) W ?29,"none" G A1
"RTN","CHMEAM12",25,0)
;S FG=0,CHBEG="",INDX=105 D DISPLAY
"RTN","CHMEAM12",26,0)
;W:'FG ?29,"none",!
"RTN","CHMEAM12",27,0)
A1 S DY=DY+1,DX=2 X XY W @CHBON,"'Actual' Dates:",@CHBOFF S CT=CT+1
"RTN","CHMEAM12",28,0)
;I '$D(^AHCHVA(DFN,100,BFN,109)) W ?29,"none",! S CT=CT+1 G A2 ;skd
"RTN","CHMEAM12",29,0)
;I '$D(^AHCHVA(DFN,100,BFN,109)) S DX=21 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A2 ;skd
"RTN","CHMEAM12",30,0)
I '$D(^AHCHVA(DFN,100,BFN,109)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A2 ;skd ; JEH 9/12/05
"RTN","CHMEAM12",31,0)
S FG=0,CHBEG="",INDX=109 D DISPLAY
"RTN","CHMEAM12",32,0)
A2 ;I CT>7 D CHKR
"RTN","CHMEAM12",33,0)
;I CT>8 D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",34,0)
I CT>CHMAX D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",35,0)
S DY=DY+1,DX=2 X XY W @CHBON,"'MED A' Date:",@CHBOFF S CT=CT+1
"RTN","CHMEAM12",36,0)
;I '$D(^AHCHVA(DFN,100,BFN,111)) W ?29,"none",! S CT=CT+1 G A3 ;SKD
"RTN","CHMEAM12",37,0)
;I '$D(^AHCHVA(DFN,100,BFN,111)) S DX=21 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A3 ;SKD
"RTN","CHMEAM12",38,0)
I '$D(^AHCHVA(DFN,100,BFN,111)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A3 ;SKD ; JEH 9/12/05
"RTN","CHMEAM12",39,0)
S CHMDADT=0,FG=0
"RTN","CHMEAM12",40,0)
A21 S CHMDADT=$O(^AHCHVA(DFN,100,BFN,111,CHMDADT)) G:'CHMDADT A3
"RTN","CHMEAM12",41,0)
I '$D(^AHCHVA(DFN,100,BFN,111,CHMDADT,0)) W ?36,"none" S DY=DY+1 X XY S CT=CT+1 G A3
"RTN","CHMEAM12",42,0)
S CHMDA=^AHCHVA(DFN,100,BFN,111,CHMDADT,0)
"RTN","CHMEAM12",43,0)
;S CHMDABG=$P(CHMDA,"^",1)
"RTN","CHMEAM12",44,0)
;S X=CHMDABG D DTPRT W:'FG ?29 W:FG ?20 W Y,!
"RTN","CHMEAM12",45,0)
S INDX=111,CHMDBDT=CHMDADT D DISPL1 G A21
"RTN","CHMEAM12",46,0)
S FG=1 G A21
"RTN","CHMEAM12",47,0)
A3 ;I CT>7 D CHKR
"RTN","CHMEAM12",48,0)
;I CT>8 D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",49,0)
I CT>CHMAX D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",50,0)
S DX=2,DY=DY+1 X XY W @CHBON,"'MED B' Dates:",@CHBOFF S CT=CT+1
"RTN","CHMEAM12",51,0)
;I '$D(^AHCHVA(DFN,100,BFN,112)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A4 ;SKD 4-9-08 DEV004223-01 ; JEH 9/12/05
"RTN","CHMEAM12",52,0)
I '$D(^AHCHVA(DFN,100,BFN,112)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A3A ;SKD 4-9-08 DEV004223-01 ; JEH 9/12/05
"RTN","CHMEAM12",53,0)
S CHMDBDT=0,FG=0
"RTN","CHMEAM12",54,0)
A31 ;S CHMDBDT=$O(^AHCHVA(DFN,100,BFN,112,CHMDBDT)) G:'CHMDBDT A4 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",55,0)
S CHMDBDT=$O(^AHCHVA(DFN,100,BFN,112,CHMDBDT)) G:'CHMDBDT A3A ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",56,0)
;I '$D(^AHCHVA(DFN,100,BFN,112,CHMDBDT,0)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A4 ;SKD 4-9-08 DEV004223-01 ; JEH 9/12/05
"RTN","CHMEAM12",57,0)
I '$D(^AHCHVA(DFN,100,BFN,112,CHMDBDT,0)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A3A ;SKD 4-9-08 DEV004223-01 ; JEH 9/12/05
"RTN","CHMEAM12",58,0)
S INDX=112 D DISPL1 G A31
"RTN","CHMEAM12",59,0)
;
"RTN","CHMEAM12",60,0)
A3A ;BEG SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",61,0)
;I CT>8 D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",62,0)
I CT>CHMAX D CHKR ; SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",63,0)
S DX=2,DY=DY+1 X XY W @CHBON,"'MED D' Dates:",@CHBOFF S CT=CT+1
"RTN","CHMEAM12",64,0)
I '$D(^AHCHVA(DFN,100,BFN,117)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A4
"RTN","CHMEAM12",65,0)
S CHMDBDT=0,FG=0
"RTN","CHMEAM12",66,0)
A3A1 S CHMDBDT=$O(^AHCHVA(DFN,100,BFN,117,CHMDBDT)) G:'CHMDBDT A4
"RTN","CHMEAM12",67,0)
I '$D(^AHCHVA(DFN,100,BFN,117,CHMDBDT,0)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A4
"RTN","CHMEAM12",68,0)
S INDX=117 D DISPL1 G A3A1
"RTN","CHMEAM12",69,0)
;END SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",70,0)
;
"RTN","CHMEAM12",71,0)
A4 ;I CT>7 D CHKR
"RTN","CHMEAM12",72,0)
;I CT>8 D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",73,0)
I CT>CHMAX D CHKR ; SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",74,0)
;S DY=DY+1,DX=1 X XY W @CHBON,"'EXHAUSTION' Dates:",@CHBOFF S CT=CT+1
"RTN","CHMEAM12",75,0)
S DY=DY+1,DX=2 X XY W @CHBON,"'EXHAUSTION' Dates:",@CHBOFF S CT=CT+1 ; JEH 9/12/05
"RTN","CHMEAM12",76,0)
;I '$D(^AHCHVA(DFN,100,BFN,113)) W ?29,"none",! S CT=CT+1 G A5 ;SKD
"RTN","CHMEAM12",77,0)
;I '$D(^AHCHVA(DFN,100,BFN,113)) S DX=21 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A5 ;SKD
"RTN","CHMEAM12",78,0)
I '$D(^AHCHVA(DFN,100,BFN,113)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A5 ;SKD ; JEH 9/12/05
"RTN","CHMEAM12",79,0)
S CHEXDT=0,FG=0
"RTN","CHMEAM12",80,0)
A41 S CHEXDT=$O(^AHCHVA(DFN,100,BFN,113,CHEXDT)) G:'CHEXDT A5
"RTN","CHMEAM12",81,0)
;I '$D(^AHCHVA(DFN,100,BFN,113,CHEXDT,0)) W ?29,"none",! S CT=CT+1 G A5 ;SKD
"RTN","CHMEAM12",82,0)
;I '$D(^AHCHVA(DFN,100,BFN,113,CHEXDT,0)) S DX=21 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A5 ;SKD
"RTN","CHMEAM12",83,0)
I '$D(^AHCHVA(DFN,100,BFN,113,CHEXDT,0)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G A5 ;SKD ; JEH 9/12/05
"RTN","CHMEAM12",84,0)
S INDX=113,CHMDBDT=CHEXDT D DISPL1 G A41
"RTN","CHMEAM12",85,0)
A5 ;I CT>7 D CHKR
"RTN","CHMEAM12",86,0)
;I CT>8 D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",87,0)
I CT>CHMAX D CHKR ; JEH 9/12/05 ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAM12",88,0)
;S DY=DY+1,DX=21 X XY W @CHULON,"Left HH Date",@CHULOFF S DX=38 X XY W @CHULON,"Entered HH",@CHULOFF S CT=CT+1
"RTN","CHMEAM12",89,0)
S DY=DY+1,DX=22 X XY W @CHULON,"Left HH Date",@CHULOFF S DX=39 X XY W @CHULON,"Entered HH",@CHULOFF S CT=CT+1 ; JEH 9/12/05
"RTN","CHMEAM12",90,0)
;S DY=DY+1,DX=1 X XY W @CHBON,"Stepchild Dates:",@CHBOFF S CT=CT+1
"RTN","CHMEAM12",91,0)
S DY=DY+1,DX=2 X XY W @CHBON,"Stepchild Dates:",@CHBOFF S CT=CT+1 ; JEH 9/12/05
"RTN","CHMEAM12",92,0)
;I '$D(^AHCHVA(DFN,100,BFN,114)) W ?29,"none",! S CT=CT+1 G ASK ;SKD
"RTN","CHMEAM12",93,0)
;I '$D(^AHCHVA(DFN,100,BFN,114)) S DX=21 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G ASK ;SKD
"RTN","CHMEAM12",94,0)
I '$D(^AHCHVA(DFN,100,BFN,114)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G ASK ;SKD ; JEH 9/12/05
"RTN","CHMEAM12",95,0)
S CHHHDT=0,FG=0
"RTN","CHMEAM12",96,0)
A51 S CHHHDT=$O(^AHCHVA(DFN,100,BFN,114,CHHHDT)) G:'CHHHDT ASK
"RTN","CHMEAM12",97,0)
;I '$D(^AHCHVA(DFN,100,BFN,114,CHHHDT,0)) W ?29,"none",! S CT=CT+1 G ASK ;SKD
"RTN","CHMEAM12",98,0)
;I '$D(^AHCHVA(DFN,100,BFN,114,CHHHDT,0)) S DX=21 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G ASK ;SKD
"RTN","CHMEAM12",99,0)
I '$D(^AHCHVA(DFN,100,BFN,114,CHHHDT,0)) S DX=22 X XY W "none" S DY=DY+1 X XY S CT=CT+1 G ASK ;SKD ; JEH 9/12/05
"RTN","CHMEAM12",100,0)
S CHHH=^AHCHVA(DFN,100,BFN,114,CHHHDT,0)
"RTN","CHMEAM12",101,0)
S INDX=114,CHMDBDT=CHHHDT D DISPL1 G A51
"RTN","CHMEAM12",102,0)
ASK S CHDEF="VIEW",CHDEFNUM="V" W @CHMARESET
"RTN","CHMEAM12",103,0)
G ASK^CHMEAM
"RTN","CHMEAM12",104,0)
DISPLAY S CHBEG=$O(^AHCHVA(DFN,100,BFN,INDX,CHBEG)),CHEND="" Q:'CHBEG
"RTN","CHMEAM12",105,0)
D1 S CHEND=$O(^AHCHVA(DFN,100,BFN,INDX,CHBEG,CHEND)) G DISPLAY:'CHEND
"RTN","CHMEAM12",106,0)
G D1:CHBEG>CHEND
"RTN","CHMEAM12",107,0)
;S X=CHBEG D DTPRT W:'FG ?29 W:FG ?20 W Y ;SKD
"RTN","CHMEAM12",108,0)
;S X=CHBEG D DTPRT W:'FG ?29 W:FG ?20 W Y ;SKD
"RTN","CHMEAM12",109,0)
;S X=CHBEG D DTPRT S:'FG DX=21 S:FG DX=21 X XY W Y ;AEB
"RTN","CHMEAM12",110,0)
S X=CHBEG D DTPRT S:'FG DX=22 S:FG DX=22 X XY W Y ;AEB ; JEH 9/12/05
"RTN","CHMEAM12",111,0)
;S X=CHEND D DTPRT W:'FG ?45 W:FG ?36 W Y,! S:FG CT=CT+1
"RTN","CHMEAM12",112,0)
;S X=CHEND D DTPRT S:'FG DX=38 S:FG DX=38 X XY W Y
"RTN","CHMEAM12",113,0)
S X=CHEND D DTPRT S:'FG DX=39 S:FG DX=39 X XY W Y ; JEH 9/12/05
"RTN","CHMEAM12",114,0)
S DY=DY+1 X XY S:FG CT=CT+1
"RTN","CHMEAM12",115,0)
S FG=1 G D1
"RTN","CHMEAM12",116,0)
DISPL1 S CHBEG=$P(^AHCHVA(DFN,100,BFN,INDX,CHMDBDT,0),"^",1)
"RTN","CHMEAM12",117,0)
D2 S CHEND=$P(^AHCHVA(DFN,100,BFN,INDX,CHMDBDT,0),"^",4)
"RTN","CHMEAM12",118,0)
;S X=CHBEG D DTPRT W:'FG ?29 W:FG ?20 W Y ;SKD
"RTN","CHMEAM12",119,0)
;S X=CHBEG D DTPRT S:'FG DX=21 S:FG DX=21 X XY W Y ;SKD
"RTN","CHMEAM12",120,0)
S X=CHBEG D DTPRT S:'FG DX=22 S:FG DX=22 X XY W Y ;SKD ; JEH 9/12/05
"RTN","CHMEAM12",121,0)
;S X=CHEND D DTPRT S:'FG DX=38 S:FG DX=38 X XY W Y S DY=DY+1 X XY S:FG CT=CT+1
"RTN","CHMEAM12",122,0)
S X=CHEND D DTPRT S:'FG DX=39 S:FG DX=39 X XY W Y S DY=DY+1 X XY S:FG CT=CT+1 ; JEH 9/12/05
"RTN","CHMEAM12",123,0)
S FG=1 Q
"RTN","CHMEAM12",124,0)
DTPRT S Y="" Q:X'?7N S Y=$E(X,1,3)+1700,%M=+$E(X,4,5),%D=+$E(X,6,7)
"RTN","CHMEAM12",125,0)
I %M S:%D Y=$E(" ",$L(%D))_%D_", "_Y S Y=$P($P($T(JAN),";;",2)," ",%M)_" "_Y
"RTN","CHMEAM12",126,0)
Q
"RTN","CHMEAM12",127,0)
JAN ;;JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
"RTN","CHMEAM12",128,0)
CHKR ;S DY=DY+2,LINE=DY,DX=1 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue" R X
"RTN","CHMEAM12",129,0)
S LINE=DY,DY=DY+2,DX=1 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue" R X ; JEH 9/12/05
"RTN","CHMEAM12",130,0)
;S CT=0 S DY=LINE,DX=1 X XY W @CHEOL
"RTN","CHMEAM12",131,0)
S CT=0 S DX=1 X XY W @CHEOL S DY=LINE ; JEH 9/12/05
"RTN","CHMEAM12",132,0)
Q
"RTN","CHMEAMB")
0^4^B135578521
"RTN","CHMEAMB",1,0)
CHMEAMB ;HAC/AEB;MORE OPTION 14 - DISENROLLMENT DATA;Jan 18, 2019@12:50:49
"RTN","CHMEAMB",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAMB",3,0)
;;DEV023457 AEB 10-21-2015
"RTN","CHMEAMB",4,0)
;;CFS 12/28/2018 - ACA User Story 007 - Update Edit History with Disenrollment information.
"RTN","CHMEAMB",5,0)
;ACA Disenrollment TGH 12/28/18 Store Date in 109 and 105 nodes
"RTN","CHMEAMB",6,0)
;ACA US018 TGH 1/15/19 - Auto generate CVA re-enrollment notification
"RTN","CHMEAMB",7,0)
MENU D TOP^CHMEAV,BOTTOM^CHMEAM S STAT=""
"RTN","CHMEAMB",8,0)
I '$D(BFN) D ^CHMEAV5 I '$D(BFN) G MENU
"RTN","CHMEAMB",9,0)
S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB",10,0)
S DY=3,DX=25 X XY
"RTN","CHMEAMB",11,0)
W @CHREVON,@CHBON,"Disenroll/Re-Enroll Dates",@CHREVOFF,@CHBOFF
"RTN","CHMEAMB",12,0)
D:'$D(CHSEC) CHSEC
"RTN","CHMEAMB",13,0)
S DTM=5,DBM=18 X CHMAR S DY=5,DX=1 X XY
"RTN","CHMEAMB",14,0)
I '$D(CHSEC) D Q
"RTN","CHMEAMB",15,0)
.W *7,!!,"You do not have a security level to access this option."
"RTN","CHMEAMB",16,0)
.R X:5
"RTN","CHMEAMB",17,0)
I CHSEC="" D Q
"RTN","CHMEAMB",18,0)
.W *7,!!,"You do not have a security level to access this option."
"RTN","CHMEAMB",19,0)
.R X:5
"RTN","CHMEAMB",20,0)
I CHSEC'>2 W *7,!!,"You are not authorized to access this option." Q
"RTN","CHMEAMB",21,0)
;
"RTN","CHMEAMB",22,0)
W !?25,"<",@CHBON,"A",@CHBOFF,">dd dates"
"RTN","CHMEAMB",23,0)
W !?25,"<",@CHBON,"V",@CHBOFF,">iew current dates"
"RTN","CHMEAMB",24,0)
ENTER W !!?2,"Enter your choice: Q// "
"RTN","CHMEAMB",25,0)
D CSBRS^CHSC2
"RTN","CHMEAMB",26,0)
G:$D(DUOUT)!($D(DFOUT)) END
"RTN","CHMEAMB",27,0)
I $D(DQOUT) D G ENTER
"RTN","CHMEAMB",28,0)
.W !?5,"Please enter A, V or Q at this prompt."
"RTN","CHMEAMB",29,0)
S Y=$E(Y) S:Y="" Y="Q"
"RTN","CHMEAMB",30,0)
I "aAVvQq"'[Y D G ENTER
"RTN","CHMEAMB",31,0)
.W !?5,"Please enter A, V or Q at this prompt."
"RTN","CHMEAMB",32,0)
G:"Qq"[Y END
"RTN","CHMEAMB",33,0)
I "aA"[Y D ADD G MENU
"RTN","CHMEAMB",34,0)
I "Vv"[Y D VIEW^CHMEAMB1 G MENU
"RTN","CHMEAMB",35,0)
;
"RTN","CHMEAMB",36,0)
;
"RTN","CHMEAMB",37,0)
ADD K CHDISDT,CHREDT
"RTN","CHMEAMB",38,0)
S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB",39,0)
S DY=3,DX=21 X XY W @CHREVON,@CHBON
"RTN","CHMEAMB",40,0)
W "Add Disenrollment Periods",@CHREVOFF,@CHBOFF
"RTN","CHMEAMB",41,0)
S DTM=5,DBM=18 X CHMAR S DY=5,DX=1 X XY
"RTN","CHMEAMB",42,0)
D CHK ;DETERMINE IF DISENROLLMENT OR REENROLLMENT DATE NEEDS TO BE SET
"RTN","CHMEAMB",43,0)
I DTFLG="D" D DISDT ;ENTER DISENROLMENT DATE
"RTN","CHMEAMB",44,0)
I DTFLG="R" D REDT ;ENTER REENROLLMENT DATE
"RTN","CHMEAMB",45,0)
Q:$D(DUOUT) Q:$D(DTOUT)
"RTN","CHMEAMB",46,0)
D GLSET
"RTN","CHMEAMB",47,0)
Q
"RTN","CHMEAMB",48,0)
CHSEC Q:'$D(^CHMDIC(741002.21,DUZ,108,"E"))
"RTN","CHMEAMB",49,0)
S CHSEC=$O(^CHMDIC(741002.21,DUZ,108,"E",0)),CHSEC=$O(^(CHSEC,0))
"RTN","CHMEAMB",50,0)
S CHSEC=$P(^CHMDIC(741002.21,DUZ,108,CHSEC,0),U,3) Q
"RTN","CHMEAMB",51,0)
END K TMP,Y,X,AEVJJ
"RTN","CHMEAMB",52,0)
S Y=1 ;THIS NEEDS TO BE SET TO PREVENT '$D(Y) WILL CALL CHMEAV1
"RTN","CHMEAMB",53,0)
S:STAT'=1 Y=5
"RTN","CHMEAMB",54,0)
Q
"RTN","CHMEAMB",55,0)
GLSET ;SET DISENROLLMENT AND/OR REENROLLMENT DATES WITH HISTORY
"RTN","CHMEAMB",56,0)
; CHDISDT - DATE OF DISENROLLMENT
"RTN","CHMEAMB",57,0)
; CHREDT - DATE OF RE-ENROLLMENT
"RTN","CHMEAMB",58,0)
;CHDDOCDT - DISENROLLMENT DOCUMENT DATE
"RTN","CHMEAMB",59,0)
; TREC115 - ^AHCHVA(DFN,100,BFN,115,(LAST K VALUE),0)
"RTN","CHMEAMB",60,0)
N TMPK ;,TREC115
"RTN","CHMEAMB",61,0)
Q:'DFN Q:'BFN
"RTN","CHMEAMB",62,0)
;I '$D(^AHCHVA(DFN,100,BFN,115,0)) S ^AHCHVA(DFN,100,BFN,115,0)="^554801.1115SA^0^0",TREC115=""
"RTN","CHMEAMB",63,0)
I $D(CHDISDT) D
"RTN","CHMEAMB",64,0)
.;L +^AHCHVA(DFN,100,BFN,115,0) S TMPK=$P(^AHCHVA(DFN,100,BFN,115,0),"^",3)+1
"RTN","CHMEAMB",65,0)
.;S $P(^AHCHVA(DFN,100,BFN,115,0),"^",3)=TMPK,$P(^AHCHVA(DFN,100,BFN,115,0),"^",4)=TMPK
"RTN","CHMEAMB",66,0)
.;L -^AHCHVA(DFN,100,BFN,115,0)
"RTN","CHMEAMB",67,0)
.;S TREC115=1_"^"_1_"^"_CHDISDT_"^"_29_"^"_CHDDOCDT_"^"_DUZ_"^"_DT
"RTN","CHMEAMB",68,0)
.S DY=DY+1,DX=1 X XY W @CHEOL
"RTN","CHMEAMB",69,0)
.S DY=DY+1,DX=3 X XY W "YOU ARE ENTERING A NEW DISENROLLMENT PERIOD BEGINNING ",$$FMTE^XLFDT(CHDISDT,"5D")," (Y/N):N// "
"RTN","CHMEAMB",70,0)
.D CSBRS^CHSC2 S Y=$E(Y) S Y=$$UP^XLFSTR(Y) I Y="" S Y="N"
"RTN","CHMEAMB",71,0)
.Q:Y="N"
"RTN","CHMEAMB",72,0)
.I Y="Y" D ;S ^AHCHVA(DFN,100,BFN,115,TMPK,0)=TREC115 D
"RTN","CHMEAMB",73,0)
..S NEWSTAT="D",OLDSTAT=$P(^AHCHVA(DFN,100,BFN,0),"^",5)
"RTN","CHMEAMB",74,0)
..K ^AHCHVA("AF",OLDSTAT,DFN,BFN)
"RTN","CHMEAMB",75,0)
..I $D(^AHCHVA("AF","PR",DFN,BFN)) K ^AHCHVA("AF","PR",DFN,BFN) ;"PR" XREF is currently not getting removed by the Elig module.
"RTN","CHMEAMB",76,0)
..S ^AHCHVA("AF",NEWSTAT,DFN,BFN)=""
"RTN","CHMEAMB",77,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",5)=NEWSTAT ;BENE STATUS
"RTN","CHMEAMB",78,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",11)=DT ;STATUS DATE
"RTN","CHMEAMB",79,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",12)="DIS" ;INELIGIBLE REASON
"RTN","CHMEAMB",80,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",13)=""
"RTN","CHMEAMB",81,0)
..;
"RTN","CHMEAMB",82,0)
..L +^AHCHVA(DFN,100,BFN,115,0) S TMPK=$P($G(^AHCHVA(DFN,100,BFN,115,0)),"^",3)+1
"RTN","CHMEAMB",83,0)
..I '$D(^AHCHVA(DFN,100,BFN,115,0)) S ^AHCHVA(DFN,100,BFN,115,0)="^554801.1115SA"
"RTN","CHMEAMB",84,0)
..S $P(^AHCHVA(DFN,100,BFN,115,0),"^",3)=TMPK,$P(^AHCHVA(DFN,100,BFN,115,0),"^",4)=TMPK
"RTN","CHMEAMB",85,0)
..L -^AHCHVA(DFN,100,BFN,115,0)
"RTN","CHMEAMB",86,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",2)=2
"RTN","CHMEAMB",87,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",3)=CHDISDT
"RTN","CHMEAMB",88,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",4)=29
"RTN","CHMEAMB",89,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",5)=CHDDOCDT
"RTN","CHMEAMB",90,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",6)=DUZ
"RTN","CHMEAMB",91,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",7)=DT
"RTN","CHMEAMB",92,0)
..;
"RTN","CHMEAMB",93,0)
..;;HISTORY
"RTN","CHMEAMB",94,0)
..N CURDATE
"RTN","CHMEAMB",95,0)
..D NOW^%DTC S CURDATE=%
"RTN","CHMEAMB",96,0)
..S ^AHCHVA(DFN,101,CURDATE,100,BFN,99)=CURDATE_"^"_DUZ_"^"_"DISENROLLMENT DATE"
"RTN","CHMEAMB",97,0)
..;S ^AHCHVA(DFN,101,%,100,BFN,115)=TREC115
"RTN","CHMEAMB",98,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,0),"^",5)="D" ;STATUS
"RTN","CHMEAMB",99,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,0),"^",11)=$P(CURDATE,".",1) ;STATUS DATE
"RTN","CHMEAMB",100,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,0),"^",12)="DIS" ;INELIGIBLE REASON
"RTN","CHMEAMB",101,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,0),"^",13)="@"_NEWSTAT ;ELIGIBLE REASON
"RTN","CHMEAMB",102,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,0),"^",16)=0 ;SPOUSE DIVORCE FR SPONSOR - NO
"RTN","CHMEAMB",103,0)
..;CFS 12/28/2018 ACA User Story 007 - DISENROLLMENT HISTORY
"RTN","CHMEAMB",104,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",2)=1 ;Type
"RTN","CHMEAMB",105,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",4)=29 ;Doc Type Disenrollment
"RTN","CHMEAMB",106,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",3)=CHDISDT ;Disenrollment Date
"RTN","CHMEAMB",107,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",6)=DUZ ;User ID
"RTN","CHMEAMB",108,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",7)=DT ;Date Disenrollment Entered
"RTN","CHMEAMB",109,0)
..;LETTER
"RTN","CHMEAMB",110,0)
..I CHLTRFLG="Y" S ^CHMZHOLD("DAILY_ELIG_CCL_LTRS",342,DFN,BFN)="" ;,$P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",13)=1
"RTN","CHMEAMB",111,0)
..;
"RTN","CHMEAMB",112,0)
..N DTDOC,NCHEND,NCHENDM1,CHEDT
"RTN","CHMEAMB",113,0)
..;ACA Disenrollment TGH 12/28/18 Store Date in 109 and 105 nodes
"RTN","CHMEAMB",114,0)
..;S DTDOC=CHDDOCDT,NCHEND=CHDISDT,NCHENDM1=$$FMADD^XLFDT(NCHEND,-1,0,0,0),CHEDT=%
"RTN","CHMEAMB",115,0)
..S DTDOC=CHDDOCDT,NCHEND=CHDISDT,NCHENDM1=NCHEND,CHEDT=%
"RTN","CHMEAMB",116,0)
..D LAST109^CHTDISEN
"RTN","CHMEAMB",117,0)
..D NEW105^CHTDISEN
"RTN","CHMEAMB",118,0)
..Q
"RTN","CHMEAMB",119,0)
.Q
"RTN","CHMEAMB",120,0)
I $D(CHREDT) D
"RTN","CHMEAMB",121,0)
.I $D(^AHCHVA(DFN,100,BFN,115,0)) D Q:'TMPK
"RTN","CHMEAMB",122,0)
..S TMPK=999
"RTN","CHMEAMB",123,0)
..S TMPK=$O(^AHCHVA(DFN,100,BFN,115,TMPK),-1) Q:'TMPK
"RTN","CHMEAMB",124,0)
..S TREC115=$G(^AHCHVA(DFN,100,BFN,115,TMPK,0))
"RTN","CHMEAMB",125,0)
..Q
"RTN","CHMEAMB",126,0)
.I $P(TREC115,"^",8)'="" Q ;CAN'T ADD RE-ENROLLMENT DATE SINCE NO OPEN DISENROLLEMNT
"RTN","CHMEAMB",127,0)
.I DY>18 S DY=10
"RTN","CHMEAMB",128,0)
.S DY=DY+1,DX=1 X XY W @CHEOL
"RTN","CHMEAMB",129,0)
.S DY=DY+1,DX=3 X XY W "YOU ARE ENDING A PERIOD OF DISENROLLMENT ",$$FMTE^XLFDT(CHREDT,"5D")," (Y/N):N// "
"RTN","CHMEAMB",130,0)
.D CSBRS^CHSC2 S Y=$E(Y) S Y=$$UP^XLFSTR(Y) I Y="" S Y="N"
"RTN","CHMEAMB",131,0)
.Q:Y="N"
"RTN","CHMEAMB",132,0)
.I Y="Y" D
"RTN","CHMEAMB",133,0)
..D NOW^%DTC
"RTN","CHMEAMB",134,0)
..S NEWSTAT="EA",OLDSTAT=$P(^AHCHVA(DFN,100,BFN,0),"^",5)
"RTN","CHMEAMB",135,0)
..K ^AHCHVA("AF",OLDSTAT,DFN,BFN)
"RTN","CHMEAMB",136,0)
..I $D(^AHCHVA("AF","PR",DFN,BFN)) K ^AHCHVA("AF","PR",DFN,BFN) ;"PR" XREF is currently not getting removed by the Elig module.
"RTN","CHMEAMB",137,0)
..S ^AHCHVA("AF",NEWSTAT,DFN,BFN)=""
"RTN","CHMEAMB",138,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",5)=NEWSTAT ;BENE STATUS
"RTN","CHMEAMB",139,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",11)=$P(%,".",1) ;STATUS DATE
"RTN","CHMEAMB",140,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",12)="" ;INELIGIBLE REASON
"RTN","CHMEAMB",141,0)
..S $P(^AHCHVA(DFN,100,BFN,0),"^",13)="REE"
"RTN","CHMEAMB",142,0)
..;;HISTORY
"RTN","CHMEAMB",143,0)
..S ^AHCHVA(DFN,101,%,100,BFN,99)=%_"^"_DUZ_"^"_"RE-ENROLLMENT DATE"
"RTN","CHMEAMB",144,0)
..S ^AHCHVA(DFN,101,%,100,BFN,115)=TREC115
"RTN","CHMEAMB",145,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,0),"^",5)="E" ;STATUS
"RTN","CHMEAMB",146,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,0),"^",11)=$P(%,".",1) ;STATUS DATE
"RTN","CHMEAMB",147,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,0),"^",12)="@"_"E" ;INELIGIBLE REASON
"RTN","CHMEAMB",148,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,0),"^",13)="REE" ;ELIGIBLE REASON
"RTN","CHMEAMB",149,0)
..;
"RTN","CHMEAMB",150,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",2)=0
"RTN","CHMEAMB",151,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",9)=2
"RTN","CHMEAMB",152,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",8)=CHREDT
"RTN","CHMEAMB",153,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",11)=DUZ
"RTN","CHMEAMB",154,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",12)=DT
"RTN","CHMEAMB",155,0)
..N CURDATE
"RTN","CHMEAMB",156,0)
..D NOW^%DTC S CURDATE=%
"RTN","CHMEAMB",157,0)
..S ^AHCHVA(DFN,101,CURDATE,100,BFN,99)=CURDATE_"^"_DUZ_"^"_"RE-ENROLLMENT DATE"
"RTN","CHMEAMB",158,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",2)=0
"RTN","CHMEAMB",159,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",9)=2
"RTN","CHMEAMB",160,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",8)=CHREDT
"RTN","CHMEAMB",161,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",11)=DUZ
"RTN","CHMEAMB",162,0)
..S $P(^AHCHVA(DFN,101,CURDATE,100,BFN,115),"^",12)=DT
"RTN","CHMEAMB",163,0)
..;ACA Disenrollment TGH 12/28/18 Store Date in 109 and 105 nodes
"RTN","CHMEAMB",164,0)
..N NCHEND,NCHENDM1,CHEDT
"RTN","CHMEAMB",165,0)
..S NCHEND=CHREDT,NCHENDM1=NCHEND,CHEDT=%
"RTN","CHMEAMB",166,0)
..D LAST109
"RTN","CHMEAMB",167,0)
..D NEW105^CHTDISEN
"RTN","CHMEAMB",168,0)
..;ACA US018 TGH 1/15/19 - Auto generate CVA re-enrollment ID card
"RTN","CHMEAMB",169,0)
..D IDCARD
"RTN","CHMEAMB",170,0)
..Q
"RTN","CHMEAMB",171,0)
.Q
"RTN","CHMEAMB",172,0)
K CHLTRFLG
"RTN","CHMEAMB",173,0)
Q
"RTN","CHMEAMB",174,0)
CHK ;DETERMINE IF DISENROLLMENT OR REENROLLMENT DATE SHOULD BE ENTERED.
"RTN","CHMEAMB",175,0)
; DTFLG - 'R' USER SHOULD ENTER A RE-ENROLLMENT DATE
"RTN","CHMEAMB",176,0)
; 'D' USER SHOULD ENTER A DISENROLLMENT DATE.
"RTN","CHMEAMB",177,0)
N TMPK,REC115
"RTN","CHMEAMB",178,0)
S DTFLG="D" ;HAVE USER ENTER A DISENROLLMENT DATE
"RTN","CHMEAMB",179,0)
Q:'DFN Q:'BFN
"RTN","CHMEAMB",180,0)
Q:'$D(^AHCHVA(DFN,100,BFN,115,0))
"RTN","CHMEAMB",181,0)
S TMPK=999
"RTN","CHMEAMB",182,0)
S TMPK=$O(^AHCHVA(DFN,100,BFN,115,TMPK),-1) Q:'TMPK
"RTN","CHMEAMB",183,0)
S REC115=$G(^AHCHVA(DFN,100,BFN,115,TMPK,0)) I TMPK'=1 I REC115="" Q
"RTN","CHMEAMB",184,0)
I $P(REC115,"^",3)'="" I $P(REC115,"^",8)="" S DTFLG="R" ;SINCE DISENOLLMENT DATE WITH NO REENROLLMENT DATE USER INPUTS REENROLLMENT DATE
"RTN","CHMEAMB",185,0)
Q
"RTN","CHMEAMB",186,0)
;
"RTN","CHMEAMB",187,0)
DISDT ;ENTER DISENROLLMENT DATE
"RTN","CHMEAMB",188,0)
N REC1
"RTN","CHMEAMB",189,0)
K CHDISDT,CHREDT,TMPI,EDT
"RTN","CHMEAMB",190,0)
S DY=DY+1,DX=10 X XY
"RTN","CHMEAMB",191,0)
DIS1 S DIR(0)="DO" S DIR("A")="Enter Disenrollment date in MMDDYY format " D ^DIR K DIR
"RTN","CHMEAMB",192,0)
I Y=""!(Y=-1)!(Y="^") S DUOUT=1 Q
"RTN","CHMEAMB",193,0)
Q:Y=-1
"RTN","CHMEAMB",194,0)
Q:$D(DUOUT)
"RTN","CHMEAMB",195,0)
S CHDISDT=Y
"RTN","CHMEAMB",196,0)
S DIR(0)="DO" S DIR("A")="Enter Disenrollment document date in MMDDYY format " D ^DIR K DIR
"RTN","CHMEAMB",197,0)
I Y=""!(Y=-1) S DUOUT=1 Q
"RTN","CHMEAMB",198,0)
S:Y="^" DUOUT=1 Q:Y=-1
"RTN","CHMEAMB",199,0)
G:$D(DUOUT) DIS1
"RTN","CHMEAMB",200,0)
I Y>DT W !!,"Disenrollment document date may not be a future date." G DIS1
"RTN","CHMEAMB",201,0)
S CHDDOCDT=Y
"RTN","CHMEAMB",202,0)
D VER I $D(DFLG) K DFLG G DISDT ;IF NOT FIRST ENTRY OR NO REENROLLMENT DATE - SKIP
"RTN","CHMEAMB",203,0)
S REC1=$G(^AHCHVA(DFN,100,BFN,1)) I REC1="" D R X:10 Q
"RTN","CHMEAMB",204,0)
.S CHLTRFLG="N"
"RTN","CHMEAMB",205,0)
.S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB",206,0)
.S DY=6,DX=10 X XY W "This beneficiary has no address."
"RTN","CHMEAMB",207,0)
.Q
"RTN","CHMEAMB",208,0)
I $P(REC1,"^",10)'="" I $P(REC1,"^",10)'=1 D R X:10 Q
"RTN","CHMEAMB",209,0)
.S CHLTRFLG="N"
"RTN","CHMEAMB",210,0)
.S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB",211,0)
.S DY=6,DX=10 X XY W "This beneficiary's address has been flagged as bad."
"RTN","CHMEAMB",212,0)
.Q
"RTN","CHMEAMB",213,0)
S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB",214,0)
S DY=6,DX=1 X XY W @CHEOL S DY=DY,DX=10 X XY W "Do you want to mail a Disenrollment letter: (Y/N): Y// " D CSBRS^CHSC2
"RTN","CHMEAMB",215,0)
K CHLTRFLG
"RTN","CHMEAMB",216,0)
I (Y=-1)!(Y="^") S DUOUT=1 Q
"RTN","CHMEAMB",217,0)
S:Y="" Y="Y" S CHLTRFLG="N"
"RTN","CHMEAMB",218,0)
S Y=$E(Y) S Y=$$UP^XLFSTR(Y)
"RTN","CHMEAMB",219,0)
S:Y="Y" CHLTRFLG="Y"
"RTN","CHMEAMB",220,0)
Q
"RTN","CHMEAMB",221,0)
;
"RTN","CHMEAMB",222,0)
REDT ;ENTER REENROLLMENT DATE
"RTN","CHMEAMB",223,0)
K CHDISDT,CHREDT
"RTN","CHMEAMB",224,0)
S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB",225,0)
S DY=6,DX=10 X XY
"RTN","CHMEAMB",226,0)
S DIR(0)="D" S DIR("A")="ENTER RE-ENROLLMENT DATE IN MMDDYY FORMAT " D ^DIR S CHREDT=Y
"RTN","CHMEAMB",227,0)
I Y=""!(Y=-1)!(Y="^") S DUOUT=1 Q
"RTN","CHMEAMB",228,0)
Q:Y=-1
"RTN","CHMEAMB",229,0)
Q:$D(DUOUT)
"RTN","CHMEAMB",230,0)
S CHREDT=Y
"RTN","CHMEAMB",231,0)
D VER I $D(DFLG) K DFLG G REDT
"RTN","CHMEAMB",232,0)
Q
"RTN","CHMEAMB",233,0)
VER ;
"RTN","CHMEAMB",234,0)
N TMPI,EDT
"RTN","CHMEAMB",235,0)
S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB",236,0)
S TMPI=999
"RTN","CHMEAMB",237,0)
V1 S TMPI=$O(^AHCHVA(DFN,100,BFN,115,TMPI),-1) Q:'TMPI Q:$D(DFLG)
"RTN","CHMEAMB",238,0)
S TREC=$G(^AHCHVA(DFN,100,BFN,115,TMPI,0)) Q:TREC=""
"RTN","CHMEAMB",239,0)
I $D(CHDISDT) D
"RTN","CHMEAMB",240,0)
.I $P(^AHCHVA(DFN,100,BFN,0),"^",5)="D"&($P(^AHCHVA(DFN,100,BFN,0),"^",12)="DIS") S DFLG="" S DY=10,DX=1 X XY W !,"This Beneficiary is in Disenrolled status.",! R X:20 Q
"RTN","CHMEAMB",241,0)
.I $P(^AHCHVA(DFN,100,BFN,0),"^",6)?7N S DFLG=1 S DY=11,DX=1 X XY W !,"Cannot disenroll a deceased Beneficiary.",! R X:20 Q
"RTN","CHMEAMB",242,0)
.S EDT=$P(TREC,"^",8)
"RTN","CHMEAMB",243,0)
.I $P(TREC,"^",3)'="" I $P(TREC,"^",8)="" S DFLG="" S DY=DY+1,DX=1 X XY W @CHEOL S DY=10,DX=1 X XY W "Missing a re-enrollment date",! R X:20 Q
"RTN","CHMEAMB",244,0)
.I CHDISDT'>EDT S DFLG="" S DY=DY+1,DX=15 X XY W @CHEOL S DY=11,DX=1 X XY W "Disenrollment date must be greater than last re-enrollment date",! R X:20 Q
"RTN","CHMEAMB",245,0)
I $D(CHREDT) D
"RTN","CHMEAMB",246,0)
.S EDT=$P(TREC,"^",8)
"RTN","CHMEAMB",247,0)
.I $P(TREC,"^",3)'="" I $P(TREC,"^",8)'="" S DFLG="" S DY=DY+1,DX=1 X XY W @CHEOL S DY=10,DX=1 X XY W "Missing a disenrollment date",! R X:20 Q
"RTN","CHMEAMB",248,0)
.I CHREDT'>$P(TREC,"^",3) S DFLG="" S DY=DY+1,DX=1 W @CHEOL S DY=11,DX=1 X XY W "Re-enrollment date must be greater than last disenrollment date",! R X:20 Q
"RTN","CHMEAMB",249,0)
Q
"RTN","CHMEAMB",250,0)
LAST109 ;ACA Disenrollment TGH 12/31/18 Store Date in 109 node for Reenrollment
"RTN","CHMEAMB",251,0)
; Use Reenrollmnet Date as start date
"RTN","CHMEAMB",252,0)
; Use Backdate Expiration date as end date
"RTN","CHMEAMB",253,0)
N NEWEND
"RTN","CHMEAMB",254,0)
S NEWEND=$P($G(^AHCHVA(DFN,100,BFN,5)),"^",4)
"RTN","CHMEAMB",255,0)
S ^AHCHVA(DFN,100,BFN,109,NCHEND,NEWEND)=DUZ_"^"_CHEDT_"^"_1
"RTN","CHMEAMB",256,0)
Q
"RTN","CHMEAMB",257,0)
IDCARD ;ACA US018 TGH 1/16/19 - Auto generate CVA re-enrollment notification
"RTN","CHMEAMB",258,0)
N CHCD,PGI,CHB,CHBEG,CHEND,X,I,J
"RTN","CHMEAMB",259,0)
S CHCD=^AHCHVA(DFN,100,BFN,0)
"RTN","CHMEAMB",260,0)
I $D(^AHCHVA(DFN,100,BFN,0)) I $P(^AHCHVA(DFN,100,BFN,0),"^",4)="CG" W $C(7),!!,"CHAMPVA ID card is not issued for Caregiver beneficiary" R X:3 Q
"RTN","CHMEAMB",261,0)
S PGI=0 F I=0:0 S I=$O(^AHCHVA(DFN,100,BFN,108,I)) Q:'I I $D(^(I,0)) S PGI=+$P(^(0),U,2) Q
"RTN","CHMEAMB",262,0)
S CHB=$S('PGI:+^AHADIC(554804.05,1,20),1:+^AHADIC(554804.05,1,21))
"RTN","CHMEAMB",263,0)
;ACA US018 TGH 1/16/19 - Remove to allow for overwrite if existing ID Card in Batch
"RTN","CHMEAMB",264,0)
;I $D(^AHADIC(554804.03,"C",$P(CHCD,U),DFN,BFN,CHB)) W $C(7),!!,"This beneficiary is scheduled to receive a card when the next batch is run!" R X:3 G TEND
"RTN","CHMEAMB",265,0)
S (CHBEG,CHEND)=""
"RTN","CHMEAMB",266,0)
F I=0:0 S I=$O(^AHCHVA(DFN,100,BFN,105,I)) Q:I="" F J=0:0 S J=$O(^AHCHVA(DFN,100,BFN,105,I,J)) Q:J="" S CHBEG=I,CHEND=J
"RTN","CHMEAMB",267,0)
S:'PGI CHB=+^AHADIC(554804.05,1,20) S:PGI CHB=+^AHADIC(554804.05,1,21)
"RTN","CHMEAMB",268,0)
D ADD^CHMACARD($P(CHCD,U),CHB,DFN,BFN,$P(^AHCHVA(DFN,100,BFN,0),U,9),CHBEG,CHEND,"",DUZ) ;JSG;DEV002207;
"RTN","CHMEAMB",269,0)
I PGI'=0 D
"RTN","CHMEAMB",270,0)
.I $P(^AHCHVA(DFN,100,BFN,5),U,1)["A" Q
"RTN","CHMEAMB",271,0)
.S $P(^AHCHVA(DFN,100,BFN,5),U,11)="GRC"
"RTN","CHMEAMB",272,0)
.Q
"RTN","CHMEAMB",273,0)
S ^CHMZHOLD("DRS_SCRN_EA",$P(CHCD,U),DFN,BFN)=""
"RTN","CHMEAMB",274,0)
S:PGI PGI=1 S ^(PGI)=^AHCHVA("DM","IDCARD",PGI)+1
"RTN","CHMEAMB",275,0)
W !!,$P(^AHCHVA(DFN,100,BFN,0),U,1)," has been placed into the ID card batch ",CHB R X:5
"RTN","CHMEAMB",276,0)
Q
"RTN","CHMEAMB1")
0^5^B4668902
"RTN","CHMEAMB1",1,0)
CHMEAMB1 ;HAC/AEB;VIEW PERIODS OF DISENROLLMENT;Jan 08, 2019@09:34:45
"RTN","CHMEAMB1",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAMB1",3,0)
;;DEV023457 AEB 10-21-2015
"RTN","CHMEAMB1",4,0)
;RTC786744 BDB 07-25-2018 ACA MERGE
"RTN","CHMEAMB1",5,0)
VIEW S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHMEAMB1",6,0)
N TMP,REC115,PLTRST,LTRST
"RTN","CHMEAMB1",7,0)
S DY=3,DX=27 X XY W @CHREVON,@CHBON
"RTN","CHMEAMB1",8,0)
W "VIEW Periods of Disenrollment",@CHREVOFF,@CHBOFF
"RTN","CHMEAMB1",9,0)
S DTM=5,DBM=18 X CHMAR S DY=5,DX=1 X XY
"RTN","CHMEAMB1",10,0)
S TMP=999999,CNT=1
"RTN","CHMEAMB1",11,0)
W !,"DISENROLL DT",?14,"USER",?25,"DATE",?34,"RE-ENROLL DT",?49,"USER",?60,"DATE",?72,"LTR SNT"
"RTN","CHMEAMB1",12,0)
W !,"------------",?14,"----",?25,"----",?34,"------------",?49,"----",?60,"----",?72,"-------"
"RTN","CHMEAMB1",13,0)
VIEW1 S TMP=$O(^AHCHVA(DFN,100,BFN,115,TMP),-1) I 'TMP R X:60 Q
"RTN","CHMEAMB1",14,0)
I TMP="" D Q
"RTN","CHMEAMB1",15,0)
.W !!?17,"NO Disenrollment data for this beneficiary"
"RTN","CHMEAMB1",16,0)
.W !!,?27,"Press return to continue."
"RTN","CHMEAMB1",17,0)
.R X:10
"RTN","CHMEAMB1",18,0)
G:'$D(^AHCHVA(DFN,100,BFN,115,TMP,0)) VIEW1 S REC115=^AHCHVA(DFN,100,BFN,115,TMP,0)
"RTN","CHMEAMB1",19,0)
S DISDT=$P(REC115,U,3),IUSER=$P(REC115,U,6),IDT=$P(REC115,U,7)
"RTN","CHMEAMB1",20,0)
S REDT=$P(REC115,U,8),RUSER=$P(REC115,U,11),RDT=$P(REC115,U,12),LTRST=$P(REC115,U,13) S:LTRST'=1 PLTRST="NO" S:LTRST=1 PLTRST="YES"
"RTN","CHMEAMB1",21,0)
W !?2,$$FMTE^XLFDT(DISDT,"5D"),?14,IUSER,?22,$$FMTE^XLFDT(IDT,"5D"),?36,$$FMTE^XLFDT(REDT,"5D"),?49,RUSER,?57,$$FMTE^XLFDT(RDT,"5D"),?72,PLTRST
"RTN","CHMEAMB1",22,0)
;W !,?10,"LETTER SENT ",PLTRST,!
"RTN","CHMEAMB1",23,0)
G VIEW1
"RTN","CHMEAMB1",24,0)
I (USER'="") I USERDT'="" D
"RTN","CHMEAMB1",25,0)
.Q:'$D(^VA(200,USER,0)) S USER=$P(^(0),U)
"RTN","CHMEAMB1",26,0)
.S Y=USERDT X ^DD("DD") S USERDT=Y
"RTN","CHMEAMB1",27,0)
.W ?13,"by ",$E(USER,1,20)," on ",$E(USERDT,1,28)
"RTN","CHMEAMB1",28,0)
Q:X="^"
"RTN","CHMEAMB1",29,0)
S KK=0
"RTN","CHMEAMB1",30,0)
CLEAR S DX=1 F DY=4:1:24 X XY W @CHEOL
"RTN","CHMEAMB1",31,0)
S DTM=4,DBM=24 X CHMAR S DY=4,DX=1 X XY
"RTN","CHMEAMB1",32,0)
Q
"RTN","CHMEAMB1",33,0)
X CHRESET
"RTN","CHMEAMB1",34,0)
D TOP^CHMEAV S DY=19,DX=1 X XY W CHL D BOTTOM^CHMEAM
"RTN","CHMEAMB1",35,0)
S DY=19 F DX=1:1:78 X XY W "-"
"RTN","CHMEAMB1",36,0)
END Q
"RTN","CHMEAV52")
0^22^B12402550
"RTN","CHMEAV52",1,0)
CHMEAV52 ;CSW/DEN;SPONSOR DEPENDENTS (QUICK);Jan 08, 2019@09:36:22
"RTN","CHMEAV52",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAV52",3,0)
;DEV012197-01 YJK 4/6/11 CAREGIVER
"RTN","CHMEAV52",4,0)
;RTM790991 DYO 11-02-2018 Fix repainting
"RTN","CHMEAV52",5,0)
;
"RTN","CHMEAV52",6,0)
I '$G(DY) S DY=1 ;SKD, 6-27-05
"RTN","CHMEAV52",7,0)
I '$G(DX) S DX=1 ;SKD, 6-27-05
"RTN","CHMEAV52",8,0)
;W @IOF ;SKD, 6-27-05 commented line to allow top and bottom banners to remain AEB 7/30/2005
"RTN","CHMEAV52",9,0)
;S DY=DY+2 X XY ; JEH 8/24/05
"RTN","CHMEAV52",10,0)
S DX=1 F DY=7:1:17 X XY W @CHEOL ; JEH 8/24/05
"RTN","CHMEAV52",11,0)
;S DTM=8,DBM=18,DY=8 X CHMAR,XY ; DYO RTM790991 JEH 8/24/05
"RTN","CHMEAV52",12,0)
S DTM=8,DBM=18,DY=4 X CHMAR,XY ; DYO RTM790991
"RTN","CHMEAV52",13,0)
S DX=3 X XY W "Beneficiary Name" S DX=20 X XY W "DOB" S DX=29 X XY W "Relation" S DX=39 X XY W "Status" S DX=50 X XY W "Reason" S DX=66 X XY W "Sta Date" S DX=75 X XY W "C" S DX=77 X XY W "ROC"
"RTN","CHMEAV52",14,0)
S DY=DY+1,DX=3 X XY W "----------------" S DX=20 X XY W "--------" S DX=29 X XY W "---------" S DX=39 X XY W "----------" S DX=50 X XY W "---------------" S DX=66 X XY W "--------" S DX=75 X XY W "-" S DX=77 X XY W "---"
"RTN","CHMEAV52",15,0)
I '$D(DFN) S DY=DY+1,DX=3 X XY W *7,"No Beneficiaries for this sponsor." G END
"RTN","CHMEAV52",16,0)
I '$D(^AHCHVA(DFN,100,"B")) S DY=DY+1,DX=3 X XY W "No Beneficiaries for this sponsor." G END
"RTN","CHMEAV52",17,0)
S BN="",CT=0 K CHBFN,BFN
"RTN","CHMEAV52",18,0)
A1 S BN=$O(^AHCHVA(DFN,100,"B",BN)),BFN2=0 G ASK:BN=""
"RTN","CHMEAV52",19,0)
A2 S BFN2=$O(^AHCHVA(DFN,100,"B",BN,BFN2))
"RTN","CHMEAV52",20,0)
G A1:'BFN2,A2:'$D(^AHCHVA(DFN,100,BFN2,0))
"RTN","CHMEAV52",21,0)
S STR=^(0),DOB=$P(STR,"^",3),REL=$P(STR,"^",4)
"RTN","CHMEAV52",22,0)
S STA=$P(STR,"^",5),CHSTADT=$P(STR,"^",11)
"RTN","CHMEAV52",23,0)
I STA'="" S STA=$P($P(^DD(554801.01,.05,0),STA_":",2),";")
"RTN","CHMEAV52",24,0)
E S STA="INVALD"
"RTN","CHMEAV52",25,0)
;S:REL'="" REL=$S(REL="C":"CHILD",REL="XS":"EX-SPOUSE",REL="S":"SPOUSE",1:"INVALID") ;DEV012197-01 YJK 4/6/11
"RTN","CHMEAV52",26,0)
S:REL'="" REL=$S(REL="C":"CHILD",REL="XS":"EX-SPOUSE",REL="S":"SPOUSE",REL="CG":"CAREGIVER",1:"INVALID") ;DEV012197-01 YJK 4/6/11
"RTN","CHMEAV52",27,0)
S REA=""
"RTN","CHMEAV52",28,0)
I $P(STR,"^",12)'="" S REA=$O(^AHADIC(554801.7,"B",$P(STR,"^",12),0)) S:REA'="" REA=$P(^AHADIC(554801.7,REA,0),"^",2)
"RTN","CHMEAV52",29,0)
I REA="" I $P(STR,"^",13)'="" S REA=$O(^AHADIC(554801.6,"B",$P(STR,"^",13),0)) S:REA'="" REA=$P(^AHADIC(554801.6,REA,0),"^",2)
"RTN","CHMEAV52",30,0)
S:REA="" REA="INVALID REASON"
"RTN","CHMEAV52",31,0)
S:DOB?7N DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$E(DOB,2,3)
"RTN","CHMEAV52",32,0)
S:CHSTADT?7N CHSTADT=$E(CHSTADT,4,5)_"/"_$E(CHSTADT,6,7)_"/"_$E(CHSTADT,2,3)
"RTN","CHMEAV52",33,0)
S CT=CT+1,CHBFN(CT)=BFN2
"RTN","CHMEAV52",34,0)
;W !,@CHBON,CT,@CHBOFF,") ",$E(BN,1,16),?29,DOB,?38,$E(REL,1,9),?48,$E(STA,1,10),?59,$E(REA,1,15),?75,CHSTADT ;SKD
"RTN","CHMEAV52",35,0)
S DY=DY+1,DX=1 X XY W @CHBON,CT,@CHBOFF,") ",$E(BN,1,16) S DX=20 X XY W DOB S DX=29 X XY W $E(REL,1,9) S DX=39 X XY W $E(STA,1,10) S DX=50 X XY W $E(REA,1,15) S DX=66 X XY W CHSTADT ;SKD
"RTN","CHMEAV52",36,0)
;W ?84,$S($D(^AHCHVA(DFN,100,BFN2,107)):"Y",1:"N") ;SKD
"RTN","CHMEAV52",37,0)
;W ?87,$S($D(^AHCHVA(DFN,100,BFN2,106)):"Y",1:"N") ;SKD
"RTN","CHMEAV52",38,0)
S DX=75 X XY W $S($D(^AHCHVA(DFN,100,BFN2,107)):"Y",1:"N") ;SKD
"RTN","CHMEAV52",39,0)
S DX=77 X XY W $S($D(^AHCHVA(DFN,100,BFN2,106)):"Y",1:"N") ;SKD
"RTN","CHMEAV52",40,0)
G A2:CT#12'=0,ASK:($O(^AHCHVA(DFN,100,"B",BN))="")&('$O(^(BN,BFN2)))
"RTN","CHMEAV52",41,0)
S DY=DY+2 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," for more: " D SBRS
"RTN","CHMEAV52",42,0)
G A2
"RTN","CHMEAV52",43,0)
ASK ;
"RTN","CHMEAV52",44,0)
S DY=DY+4,DX=1 X XY W @CHEOL,"Select Beneficiary number: 1// " ;DYO RTM790991
"RTN","CHMEAV52",45,0)
;S DY=DY+2,DX=1 X XY W "Select Beneficiary number: 1// " ;DYO RTM790991
"RTN","CHMEAV52",46,0)
D SBRS G END:($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV52",47,0)
I $D(DQOUT) W " Choose 1-",CT,"." G ASK
"RTN","CHMEAV52",48,0)
S:Y="" Y=1 S:'+Y Y=$E(Y) I '$D(CHBFN(Y)) W *7," ??" G ASK
"RTN","CHMEAV52",49,0)
S BFN=CHBFN(Y)
"RTN","CHMEAV52",50,0)
END Q
"RTN","CHMEAV52",51,0)
SBRS D CSBRS^CHSC2 Q ;AEB
"RTN","CHMEAV52",52,0)
R Y:$S($D(DTIME):DTIME,1:60)
"RTN","CHMEAV52",53,0)
I '$T W *7 R Y:5 G SBRS:Y="." S:'$T Y=IOZFO
"RTN","CHMEAV52",54,0)
SBRS1 K DFOUT,DUOUT,DQOUT S:'$D(IOZFO) IOZFO="^^" S:'$D(IOZBK) IOZBK="^"
"RTN","CHMEAV52",55,0)
I IOZFO=Y S (DFOUT,Y)="" Q
"RTN","CHMEAV52",56,0)
S:Y=IOZBK (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
"RTN","CHMEAV52",57,0)
Q
"RTN","CHMEAV6")
0^26^B24700216
"RTN","CHMEAV6",1,0)
CHMEAV6 ;CVA/CAM;BENEFICIARY BASIC;Jan 08, 2019@09:58:33
"RTN","CHMEAV6",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAV6",3,0)
;CPTS 10042 BY CAM, #10106 BY RLC
"RTN","CHMEAV6",4,0)
;CPTS 10748 BY CAM
"RTN","CHMEAV6",5,0)
;CPTS 12075 BY CAM
"RTN","CHMEAV6",6,0)
START G ASK:'$D(BFN)
"RTN","CHMEAV6",7,0)
G ASK:BFN=""
"RTN","CHMEAV6",8,0)
S U="^",DX=1 F DY=2:1:18 X XY W @CHEOL
"RTN","CHMEAV6",9,0)
S DY=2,DX=20 X XY W @CHBON,"Basic Beneficiary Data",@CHBOFF
"RTN","CHMEAV6",10,0)
S (CHCD,CHPD)=$S($D(^AHCHVA(DFN,100,BFN,0)):^(0),1:"")
"RTN","CHMEAV6",11,0)
S (CHCD1,CHPD1)=$S($D(^AHCHVA(DFN,100,BFN,1)):^(1),1:"")
"RTN","CHMEAV6",12,0)
S CHCD2=$S($D(^AHCHVA(DFN,100,BFN,2)):^(2),1:"")
"RTN","CHMEAV6",13,0)
S CHCD3=$S($D(^AHCHVA(DFN,100,BFN,3)):^(3),1:"")
"RTN","CHMEAV6",14,0)
S CHCD5=$S($D(^AHCHVA(DFN,100,BFN,5)):^(5),1:"")
"RTN","CHMEAV6",15,0)
S CHCD9=$S($D(^AHCHVA(DFN,100,BFN,9)):^(9),1:"")
"RTN","CHMEAV6",16,0)
I $P(CHCD,U,5)'="T" D ^CHMEAE9 D:CHCD'=CHPD ^CHMEAE8 S CHPD=CHCD D ^CHMEAE81,^CHMEAE9 D:CHCD'=CHPD ^CHMEAE8
"RTN","CHMEAV6",17,0)
S (CHBEG,CHEND,CHID)=""
"RTN","CHMEAV6",18,0)
F I=0:0 Q:'$D(^AHCHVA(DFN,100,BFN,"ID")) S I=$O(^("ID",I)) Q:'I I $D(^(I,0)) I ($P(^(0),U)'=""),($P(^(0),U,2)'=""),($P(^(0),U,3)'=""),($P(^(0),U,4)'="") S CHID=^(0) Q
"RTN","CHMEAV6",19,0)
I '$D(CHID)!(CHID="") D
"RTN","CHMEAV6",20,0)
.D:$D(^AHCHVA(DFN,100,BFN,5))
"RTN","CHMEAV6",21,0)
..S TMPCHID=^AHCHVA(DFN,100,BFN,5)
"RTN","CHMEAV6",22,0)
..Q:$P(TMPCHID,U,1)="" Q:$P(TMPCHID,U,2)=""
"RTN","CHMEAV6",23,0)
..Q:$P(TMPCHID,U,3)="" Q:$P(TMPCHID,U,4)=""
"RTN","CHMEAV6",24,0)
..S CHID=TMPCHID
"RTN","CHMEAV6",25,0)
STATUS S X=$P(CHCD,U,5)
"RTN","CHMEAV6",26,0)
I X'="" S X=$P($P(^DD(554801.01,.05,0),X_":",2),";")
"RTN","CHMEAV6",27,0)
E S X="INVALID"
"RTN","CHMEAV6",28,0)
S DY=2,DX=45 X XY W @CHBON,"Status:",@CHBOFF," ",X
"RTN","CHMEAV6",29,0)
F I=0:0 S I=$O(^AHCHVA(DFN,100,BFN,105,I)) Q:I="" F J=0:0 S J=$O(^AHCHVA(DFN,100,BFN,105,I,J)) Q:J="" S CHBEG=I,CHEND=J
"RTN","CHMEAV6",30,0)
S CHBN=$P($P(CHCD,U),"(SN)")_" "_$P($P(CHCD,U),"(SN)",2)
"RTN","CHMEAV6",31,0)
S L=$P(CHBN,","),F1=$TR($P($P(CHBN,",",2)," ")," ")
"RTN","CHMEAV6",32,0)
S F2=$TR($P($P(CHBN,",",2)," ",2,99)," ")
"RTN","CHMEAV6",33,0)
S CHBN=F1 S:F2'="" CHBN=CHBN_" "_F2 S CHBN=CHBN_" "_L
"RTN","CHMEAV6",34,0)
S:$P(CHCD,U)["(SN)" CHBN=CHBN_" (SN)"
"RTN","CHMEAV6",35,0)
NAME I $D(^AHCHVA("SB",DFN,BFN)) D
"RTN","CHMEAV6",36,0)
.S DY=3,DX=1 X XY W @CHREVON,@CHBON,"SB",@CHREVOFF,@CHBOFF
"RTN","CHMEAV6",37,0)
.Q
"RTN","CHMEAV6",38,0)
S DY=3,DX=4 X XY W @CHBON,"Name:",@CHBOFF," ",CHBN S Z=1 D SB4
"RTN","CHMEAV6",39,0)
APDT S (X,X1)="NONE",CHDTTIT="QE Date:" I $P(CHCD,U,10)?7N.1".".6N D G APDT1
"RTN","CHMEAV6",40,0)
.S X=$E($P(CHCD,U,10),4,5)_"/"_$E($P(CHCD,U,10),6,7)_"/"_$E($P(CHCD,U,10),2,3)
"RTN","CHMEAV6",41,0)
.S CHDTTIT="QE Date:" Q
"RTN","CHMEAV6",42,0)
I $P(CHCD1,U,8)=2 D G APDT1
"RTN","CHMEAV6",43,0)
.S (X1,X)=$P(CHCD1,U,9)
"RTN","CHMEAV6",44,0)
.S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) Q
"RTN","CHMEAV6",45,0)
G:'$D(CHCD2) APDT1
"RTN","CHMEAV6",46,0)
F I=1:1:18 I $P(CHCD2,U,I)=2 D Q:$P(CHCD2,U,I)=2
"RTN","CHMEAV6",47,0)
.Q:'$D(CHCD3) S (X1,X)=$P(CHCD3,U,I)
"RTN","CHMEAV6",48,0)
.S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) Q
"RTN","CHMEAV6",49,0)
APDT1 ;S DY=3,DX=60 X XY W @CHBON,"Ap Date:",@CHBOFF," ",X
"RTN","CHMEAV6",50,0)
S DY=3,DX=60 X XY W @CHBON,CHDTTIT,@CHBOFF," ",X
"RTN","CHMEAV6",51,0)
I $P(CHCD,U,10)'=X1 D
"RTN","CHMEAV6",52,0)
.I X1'?1.13N Q
"RTN","CHMEAV6",53,0)
.S $P(CHCD,U,10)=X1
"RTN","CHMEAV6",54,0)
.S $P(^AHCHVA(DFN,100,BFN,0),"^",10)=X1
"RTN","CHMEAV6",55,0)
;
"RTN","CHMEAV6",56,0)
D ^CHMEAV61 ;BREAK UP OF CHMEAV6
"RTN","CHMEAV6",57,0)
D ^CHMEAV62
"RTN","CHMEAV6",58,0)
;
"RTN","CHMEAV6",59,0)
DAD D CMOP
"RTN","CHMEAV6",60,0)
S DY=19,DX=1 X XY S LN="",$P(LN,"-",81)="" W LN
"RTN","CHMEAV6",61,0)
ASK K CHCD S CHDEF="B EDIT HX",CHDEFNUM=9
"RTN","CHMEAV6",62,0)
S (FL,FL1)=256 ;SKD 3-10-08 DEV004223-01
"RTN","CHMEAV6",63,0)
G ASK^CHMEAV
"RTN","CHMEAV6",64,0)
A1 ;
"RTN","CHMEAV6",65,0)
S DX=$L(CHDEF)+17 X XY W @CHEOL D CSBRS^CHSC2 G END:$D(DFOUT),END:$D(DUOUT)
"RTN","CHMEAV6",66,0)
I $D(DQOUT) W " Use the Table below for valid entries." R X:2 G A1
"RTN","CHMEAV6",67,0)
S:Y="" Y=CHDEFNUM I 'Y S:$A(Y)'<97 Y=$C($A(Y)-32)
"RTN","CHMEAV6",68,0)
I Y="Q" G END
"RTN","CHMEAV6",69,0)
I ((Y=10)!(Y=11)!(Y=12)!(Y=13))&(CHSEC=0) W $C(7),!!,"You cannot access this option." G A1
"RTN","CHMEAV6",70,0)
I (Y=13)&(CHSEC=1) W $C(7),!!,"You cannot access this option." G ASK
"RTN","CHMEAV6",71,0)
I Y="M" S M1(1)=CHDEF,M1(2)=CHDEFNUM,M1(3)=CHPROG D Z2^CHMEAM G END:$D(DFOUT),END:$D(DUOUT),END:Y="Q",END:$D(QFLG) W @CHMARESET S DY=20,DX=1 X XY D BOTTOM^CHMEAV S CHDEF=M1(1),CHDEFNUM=M1(2),CHPROG=M1(3) G ASK
"RTN","CHMEAV6",72,0)
S Y=+Y S:Y<1 Y=-Y S:Y<1 Y=0
"RTN","CHMEAV6",73,0)
D OPTION^CHMEAV I X="" W $C(7)," ??" R X:2 G A1
"RTN","CHMEAV6",74,0)
I Y=10 S CHDEFNUM=Y D ^CHMEAE I $D(QFLG) G END
"RTN","CHMEAV6",75,0)
I Y=11 S CHDEFNUM=Y D:'$D(BFN) ^CHMEAV5 D ^CHMEAE4
"RTN","CHMEAV6",76,0)
I CHDEFNUM=10!(CHDEFNUM=11) D BOTTOM^CHMEAV G START
"RTN","CHMEAV6",77,0)
S CHDEFNUM=Y,CHPROG="^CHMEAV"_Y
"RTN","CHMEAV6",78,0)
I ((Y=6)!(Y=7)!(Y=8)!(Y=9))&('$D(BFN)) D ^CHMEAV5 G ASK:'$D(BFN)
"RTN","CHMEAV6",79,0)
D @CHPROG ;G END
"RTN","CHMEAV6",80,0)
G START
"RTN","CHMEAV6",81,0)
END Q
"RTN","CHMEAV6",82,0)
CMOP G:('DFN)!('BFN) SETCMOP
"RTN","CHMEAV6",83,0)
S CMOPSN=0,CMOPSN=$O(^CHMDFN("B",DFN,CMOPSN)) G:'CMOPSN SETCMOP
"RTN","CHMEAV6",84,0)
G:'$D(^CHMDFN(CMOPSN,0)) SETCMOP
"RTN","CHMEAV6",85,0)
S CMOPBN=0,CMOPBN=$O(^CHMDFN(CMOPSN,100,"B",BFN,CMOPBN)) G:'CMOPBN SETCMOP
"RTN","CHMEAV6",86,0)
S CMOPK=9999,CMOPK=$O(^CHMDFN(CMOPSN,100,CMOPBN,5,CMOPK),-1) G:'CMOPK SETCMOP
"RTN","CHMEAV6",87,0)
G:'$D(^CHMDFN(CMOPSN,100,CMOPBN,5,CMOPK,0)) SETCMOP
"RTN","CHMEAV6",88,0)
S CMOPFLG=$P($G(^CHMDFN(CMOPSN,100,CMOPBN,5,CMOPK,0)),U,3)
"RTN","CHMEAV6",89,0)
D MDDDATE^CHMEAE6F ;SKD 5-19-08 DEV004223-01
"RTN","CHMEAV6",90,0)
I CHMDD=0 S CMOPFG=0
"RTN","CHMEAV6",91,0)
I $G(CMOPFG)=0 D ;SKD 5-19-08 DEV004223-01
"RTN","CHMEAV6",92,0)
.I CMOPFLG=1!(CMOPFLG=2) D STCMPELG^CHMEAE8A ;SKD 5-19-08 DEV004223-01
"RTN","CHMEAV6",93,0)
.S CMOPFLG=0
"RTN","CHMEAV6",94,0)
SETCMOP S CMOPDISP="I"
"RTN","CHMEAV6",95,0)
I $D(CMOPFLG),(CMOPFLG=1) S CMOPDISP="EA"
"RTN","CHMEAV6",96,0)
I $D(CMOPFLG),(CMOPFLG=2) S CMOPDISP="EI"
"RTN","CHMEAV6",97,0)
S DY=6,DX=60 X XY W @CHBON,"CMOP Elig:",@CHBOFF," ",CMOPDISP
"RTN","CHMEAV6",98,0)
K CMOPFLG,CMOPDISP,CMOPSN,CMOPBN,CMOPK Q
"RTN","CHMEAV6",99,0)
DTPRT S Y="" Q:X'?7N S Y=$E(X,1,3)+1700,%M=+$E(X,4,5),%D=+$E(X,6,7)
"RTN","CHMEAV6",100,0)
I %M S:%D Y=$E(" ",$L(%D))_%D_", "_Y S Y=$P($P($T(JAN),";;",2)," ",%M)_" "_Y
"RTN","CHMEAV6",101,0)
Q
"RTN","CHMEAV6",102,0)
JAN ;;JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
"RTN","CHMEAV6",103,0)
SB4 ;
"RTN","CHMEAV6",104,0)
S X=$S($D(^AHADIC(741003.01,+$P(CHCD2,U,Z),0)):$E($P(^(0),U,2),1,8),1:"")
"RTN","CHMEAV6",105,0)
S Y=$P(CHCD3,U,Z),Y=$S(Y?7N:$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),1:"")
"RTN","CHMEAV6",106,0)
I $P(CHCD,U,Z)'="" S DX=40 X XY W X S DX=50 X XY W Y
"RTN","CHMEAV6",107,0)
Q
"RTN","CHMEAV62")
0^27^B28557424
"RTN","CHMEAV62",1,0)
CHMEAV62 ;CVA/CAM;BENEFICIARY BASIC - CONTINUED;08/20/97 8:00 AM
"RTN","CHMEAV62",2,0)
;;1.0;CHAMPVA SYSTEM;**7,1**;JULY 4, 1990;Build 4
"RTN","CHMEAV62",3,0)
;CPTS 10042* BY CAM, #10106* 10809*, #11136* BY RLC, #11783 (RLC)
"RTN","CHMEAV62",4,0)
;DEV012197-01 YJK 4/6/11 CAREGIVER
"RTN","CHMEAV62",5,0)
;DEV022991-01 YJK May 2015
"RTN","CHMEAV62",6,0)
;GEF 06/05/2017 Beneficiary Edit/Enter MBI Screen changes
"RTN","CHMEAV62",7,0)
;CFS 07/05/2018 - Task #763342 Allow HICN to display for an unlimited amount of time.
"RTN","CHMEAV62",8,0)
;SBB 07/12/2018 - Story #771377 Make CG screen similar to other benes
"RTN","CHMEAV62",9,0)
;ACA US017 BDB 1/14/19 Re-enrollment reason check
"RTN","CHMEAV62",10,0)
MDCR ;
"RTN","CHMEAV62",11,0)
S X=$P(CHCD,U,3) S:$E(X,4,7)="0229" $E(X,4,7)="0228"
"RTN","CHMEAV62",12,0)
S CHAGE=$E(DT,1,3)-$E(X,1,3) S:$E(X,4,7)>$E(DT,4,7) CHAGE=CHAGE-1
"RTN","CHMEAV62",13,0)
I CHAGE>64 G MDCR1
"RTN","CHMEAV62",14,0)
S X=$S($P(CHCD,U,32)=0:"NO",$P(CHCD,U,32)=1:"MED A ONLY",$P(CHCD,U,32)=2:"MED A&B",$P(CHCD,U,32)=3:"MED B ONLY",$P(CHCD,U,32)="":"NO",1:"NO") ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAV62",15,0)
G MDCR2
"RTN","CHMEAV62",16,0)
MDCR1 S X=$S($P(CHCD,U,32)=0:"NO",$P(CHCD,U,32)=1:"MED A ONLY",$P(CHCD,U,32)=2:"MED A&B",$P(CHCD,U,32)=3:"MED B ONLY",$P(CHCD,U,32)="":"NOT ENTERED",1:"YES") ;SKD 4-9-08 DEV004223-01
"RTN","CHMEAV62",17,0)
MDCR2 D MDDT^CHMEAE5
"RTN","CHMEAV62",18,0)
S DY=14,DX=3 X XY W @CHBON,"MDcare:",@CHBOFF," ",X
"RTN","CHMEAV62",19,0)
S Z=14 D SB4
"RTN","CHMEAV62",20,0)
CHMPUS S DY=15,DX=2 X XY W @CHBON,"TRICARE:",@CHBOFF," ",$S($P(CHCD,U,15)=0:"NO",$P(CHCD,U,15)=1:"YES",1:"") ;TLH 12/10/07 DEV002915 CHG CHAMPUS TO TRICARE
"RTN","CHMEAV62",21,0)
S Z=15 D SB4
"RTN","CHMEAV62",22,0)
CGCHK I $D(CHCD) I $P(CHCD,U,4)="CG" D CG3883 G ROC ;DEV012197-01 YJK 4/6/11
"RTN","CHMEAV62",23,0)
3884SD ;
"RTN","CHMEAV62",24,0)
S X="NONE",TSNT=0,(RTN,CHUSER1,CHUSER2,CHDZ)=""
"RTN","CHMEAV62",25,0)
D CHK109 S:'$D(FLAG9) X="NONE" G 3884S
"RTN","CHMEAV62",26,0)
3884S ;
"RTN","CHMEAV62",27,0)
S DY=16,DX=1 X XY W @CHBON,"3884 Snd:",@CHBOFF," ",X I CHUSER1'="" W " by ",CHUSER1 W " (",TSNT,")"
"RTN","CHMEAV62",28,0)
;BEG CODE CHANGE PER DEV000123-03, SKD 1-28-08
"RTN","CHMEAV62",29,0)
PGI ;S DY=15,DX=60 X XY W @CHBON,"PGI:",@CHBOFF S I=$O(^AHCHVA(DFN,100,BFN,108,0)) I I,$D(^(I,0)) W " ",$S($P(^(0),U,2)=0:"FISCAL INT",$P(^(0),U,2)=1:"CHAMPVA",$P(^(0),U,2)=2:"SPCL-CHAMPVA",1:"")
"RTN","CHMEAV62",30,0)
HICN ; Move HICN to begin phase-in of MBI & don't display the HICN field if we are past the implementation date
"RTN","CHMEAV62",31,0)
;CFS 07/05/2018 Task #763342
"RTN","CHMEAV62",32,0)
;I DT<($P($$MDT^CHMEAE4(549),"^")) S DY=5,DX=60 X XY W @CHBON,"HICN:",@CHBOFF S HICN=$P($G(^AHCHVA(DFN,100,BFN,0)),U,39) W " ",HICN
"RTN","CHMEAV62",33,0)
S DY=5,DX=60 X XY W @CHBON,"HICN:",@CHBOFF S HICN=$P($G(^AHCHVA(DFN,100,BFN,0)),U,39) W " ",HICN
"RTN","CHMEAV62",34,0)
;END CODE CHANGE PER DEV000123-03, SKD 1-28-08
"RTN","CHMEAV62",35,0)
MBI S DY=15,DX=60 X XY W @CHBON,"MBI:",@CHBOFF S MBI=$P($G(^AHCHVA(DFN,100,BFN,0)),U,40) W " ",MBI
"RTN","CHMEAV62",36,0)
;
"RTN","CHMEAV62",37,0)
3884RD ;I RTN="" S RTN="Still Awaiting Return" G 3884R
"RTN","CHMEAV62",38,0)
G:RTN="" 3884R
"RTN","CHMEAV62",39,0)
S RTN=$P(RTN,".",1),RTN=$E(RTN,4,5)_"/"_$E(RTN,6,7)_"/"_$E(RTN,2,3)
"RTN","CHMEAV62",40,0)
S CHUSER2=""
"RTN","CHMEAV62",41,0)
I CHDZ'="" I $D(^VA(200,CHDZ,0)) S CHUSER2=$P(^(0),U,2)
"RTN","CHMEAV62",42,0)
3884R ;
"RTN","CHMEAV62",43,0)
S DY=17,DX=1 X XY W @CHBON,"3884 Rcd:",@CHBOFF," ",RTN I CHUSER2'="" W " by ",CHUSER2
"RTN","CHMEAV62",44,0)
ROC S DY=16,DX=60 X XY W @CHBON,"ROC:",@CHBOFF," ",$S($D(^AHCHVA(DFN,100,BFN,106)):"YES",1:"NO")
"RTN","CHMEAV62",45,0)
S (X,Z)=""
"RTN","CHMEAV62",46,0)
REASON I $P(CHCD,U,12)'="" S X=$O(^AHADIC(554801.7,"B",$P(CHCD,U,12),0)) S:X'="" X=$P(^AHADIC(554801.7,X,0),U,2),Z=.12
"RTN","CHMEAV62",47,0)
I X="" I $P(CHCD,U,13)'="" S X=$O(^AHADIC(554801.6,"B",$P(CHCD,U,13),0)) S:X'="" X=$P(^AHADIC(554801.6,X,0),U,2),Z=.13
"RTN","CHMEAV62",48,0)
S:X="" X="" I $D(^AHCHVA("DIC",DFN)) S X="(DIC) "_X
"RTN","CHMEAV62",49,0)
S DY=18,DX=1 X XY W @CHBON,"Stat Rsn:",@CHBOFF," ",X
"RTN","CHMEAV62",50,0)
I X="INCOMPLETE" D INC W X
"RTN","CHMEAV62",51,0)
I X="WIDOW(ER)S MARRIAGE TERMINATED" S X=$P(CHCD,U,7) D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",52,0)
I X="SPOUSE MARRIAGE TERMINATED" S X=$P(CHCD,U,29) D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",53,0)
I X="REMARRIED WIDOW" S X=$P(CHCD,U,8) D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",54,0)
I X="RW OVER 55 PL 107-330" S X=$P(CHCD,U,8) D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",55,0)
I X="RW UNDER 55 PL 170-330" S X=$P(CHCD,U,8) D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",56,0)
I X="(OV 55) CHAMPVA" S X=$P(CHCD,U,8) D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",57,0)
I X="DISENROLLMENT" D DTDISENR ;DEV022991-01 YJK May 2015
"RTN","CHMEAV62",58,0)
I X="RE-ENROLLMENT" D DTREEENR ;ACA US017 BDB 1-14-2019
"RTN","CHMEAV62",59,0)
STDT S X=$P(CHCD,U,11) S:X?.A X=$$FMTE^XLFDT($P(CHCD,U,11),"2D")
"RTN","CHMEAV62",60,0)
S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHMEAV62",61,0)
S DY=18,DX=60 X XY W @CHBON,"Stat Dt:",@CHBOFF," ",X
"RTN","CHMEAV62",62,0)
CMMTS S DY=17,DX=60 X XY W @CHBON,"Comments:",@CHBOFF," ",$S($D(^AHCHVA(DFN,100,BFN,107)):"YES",1:"NO")
"RTN","CHMEAV62",63,0)
Q
"RTN","CHMEAV62",64,0)
DTDISENR ;DISENROLLMENT REASON&DATE - DEV022991-01 YJK May 2015
"RTN","CHMEAV62",65,0)
S K=9999999,K=$O(^AHCHVA(DFN,100,BFN,115,K),-1)
"RTN","CHMEAV62",66,0)
I 'K S X=""
"RTN","CHMEAV62",67,0)
E S X=$P(^AHCHVA(DFN,100,BFN,115,K,0),"^",3)
"RTN","CHMEAV62",68,0)
D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",69,0)
Q
"RTN","CHMEAV62",70,0)
DTREEENR ;REEENROLLMENT REASON&DATE - ACA US017 BDB 1-14-2019
"RTN","CHMEAV62",71,0)
S K=9999999,K=$O(^AHCHVA(DFN,100,BFN,115,K),-1)
"RTN","CHMEAV62",72,0)
I 'K S X=""
"RTN","CHMEAV62",73,0)
E S X=$P(^AHCHVA(DFN,100,BFN,115,K,0),"^",8)
"RTN","CHMEAV62",74,0)
D DTPRT W " (",Y W:Y="" "NO DATE ON FILE" W ")"
"RTN","CHMEAV62",75,0)
Q
"RTN","CHMEAV62",76,0)
DTPRT S Y="" Q:X'?7N S Y=$E(X,1,3)+1700,%M=+$E(X,4,5),%D=+$E(X,6,7)
"RTN","CHMEAV62",77,0)
I %M S:%D Y=$E(" ",$L(%D))_%D_", "_Y S Y=$P($P($T(JAN),";;",2)," ",%M)_" "_Y
"RTN","CHMEAV62",78,0)
Q
"RTN","CHMEAV62",79,0)
JAN ;;JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
"RTN","CHMEAV62",80,0)
SB4 ;
"RTN","CHMEAV62",81,0)
S X=$S($D(^AHADIC(741003.01,+$P(CHCD2,U,Z),0)):$E($P(^(0),U,2),1,8),1:"")
"RTN","CHMEAV62",82,0)
S Y=$P(CHCD3,U,Z),Y=$S(Y?7N:$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),1:"")
"RTN","CHMEAV62",83,0)
I $P(CHCD,U,Z)'="" S DX=40 X XY W X S DX=50 X XY W Y
"RTN","CHMEAV62",84,0)
Q
"RTN","CHMEAV62",85,0)
INC S X=" (",CT=0
"RTN","CHMEAV62",86,0)
F I=1,4,3 I $P(CHCD,U,I)="" S:CT=1 X=X_", " S X=X_$S(I=1:"Name",I=3:"DOB",1:"Rel"),CT=1
"RTN","CHMEAV62",87,0)
I $P(CHCD1,U)="" S:CT=1 X=X_", " S X=X_"Line 1",CT=1
"RTN","CHMEAV62",88,0)
I $P(CHCD1,U,11) I $P(CHCD1,U,13)="" S:CT=1 X=X_", " S X=X_"Country",CT=1
"RTN","CHMEAV62",89,0)
I '$P(CHCD1,U,11) F I=3,4,5 I $P(CHCD1,U,I)="" S:CT=1 X=X_", " S X=X_$S(I=3:"City",I=4:"State",1:"Zip"),CT=1
"RTN","CHMEAV62",90,0)
;I (($P(CHCD1,U)="")&($P(CHCD1,U,2)=""))!(($P(CHCD1,U,11))&($P(CHCD1,U,3)="")) S:CT=1 X=X_", " S X=X_"Addr",CT=1
"RTN","CHMEAV62",91,0)
S RO3884=0 G R1:'$D(^AHCHVA(DFN,100,BFN,2))
"RTN","CHMEAV62",92,0)
S:'$D(CHCD2) CHCD2=^(2) F I=1:1:30 I $P(CHCD2,U,I)=1 S RO3884=1 Q
"RTN","CHMEAV62",93,0)
R1 I 'RO3884 S:CT=1 X=X_", " S X=X_"RO-3884"
"RTN","CHMEAV62",94,0)
S X=X_")" Q
"RTN","CHMEAV62",95,0)
;
"RTN","CHMEAV62",96,0)
CHK109 S PJ=9999999,TSNT=0,(CHUSER1,CHUSER2,RTN,X)="" K FLAG9
"RTN","CHMEAV62",97,0)
CHK1 S PJ=$O(^AHCHVA(DFN,109,PJ),-1) Q:'PJ
"RTN","CHMEAV62",98,0)
G:'$D(^AHCHVA(DFN,109,PJ,0)) CHK1
"RTN","CHMEAV62",99,0)
G:$P(^AHCHVA(DFN,109,PJ,0),U,3)="B" CHK1
"RTN","CHMEAV62",100,0)
S RTN=$P(^AHCHVA(DFN,109,PJ,0),U,4)
"RTN","CHMEAV62",101,0)
;Q:RTN'=""
"RTN","CHMEAV62",102,0)
S TSNT=$P(^(0),U,7),DT1=$P(^(0),U,1),CHDZ=$P(^(0),U,6),CHDZ1=$P(^(0),U,5)
"RTN","CHMEAV62",103,0)
S CHUSER1=""
"RTN","CHMEAV62",104,0)
I CHDZ1'="" I $D(^VA(200,CHDZ1,0)) S CHUSER1=$P(^(0),U,2)
"RTN","CHMEAV62",105,0)
S X=DT1,X=$P(X,".",1),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHMEAV62",106,0)
S FLAG9=""
"RTN","CHMEAV62",107,0)
Q
"RTN","CHMEAV62",108,0)
CG3883 ;DEV012197-01 YJK 4/6/11
"RTN","CHMEAV62",109,0)
;SBB 07/12/2018 Story #771377
"RTN","CHMEAV62",110,0)
;S DY=15,DX=60 X XY W @CHBON,"HICN:",@CHBOFF S HICN=$P($G(^AHCHVA(DFN,100,BFN,0)),U,39) W " ",HICN
"RTN","CHMEAV62",111,0)
S DY=5,DX=60 X XY W @CHBON,"HICN:",@CHBOFF S HICN=$P($G(^AHCHVA(DFN,100,BFN,0)),U,39) W " ",HICN
"RTN","CHMEAV62",112,0)
S DY=15,DX=60 X XY W @CHBON,"MBI:",@CHBOFF S MBI=$P($G(^AHCHVA(DFN,100,BFN,0)),U,40) W " ",MBI
"RTN","CHMEAV62",113,0)
S DY=16,DX=1 X XY W @CHBON,"3884 Snd:",@CHBOFF
"RTN","CHMEAV62",114,0)
S DY=17,DX=1 X XY W @CHBON,"3884 Rcd:",@CHBOFF
"RTN","CHMEAV62",115,0)
Q
"RTN","CHMEAV9")
0^6^B44160865
"RTN","CHMEAV9",1,0)
CHMEAV9 ;CSW/DEN;BENEFICIARY EDIT HISTORY;Jan 08, 2019@09:59:10
"RTN","CHMEAV9",2,0)
;;2.0;CHAMPVA SYSTEM;**7,1**;JULY 4, 1990;Build 4
"RTN","CHMEAV9",3,0)
;CPTS 10042* BY CAM
"RTN","CHMEAV9",4,0)
;CPTS 10895 BY AEB
"RTN","CHMEAV9",5,0)
;CPTS 11757 BY CAM
"RTN","CHMEAV9",6,0)
;DEV023457 AEB 10-21-2015
"RTN","CHMEAV9",7,0)
;CC4044.15 JSE 08-23-2017 920222-DISPLAY MBI EDIT HISTORY
"RTN","CHMEAV9",8,0)
;RTC786744 BDB 07-25-2018 ACA MERGE
"RTN","CHMEAV9",9,0)
S DX=1 F DY=2:1:19 X XY W @CHEOL
"RTN","CHMEAV9",10,0)
S DY=3,DX=28 X XY W @CHBON,"Beneficiary Edit History",@CHBOFF
"RTN","CHMEAV9",11,0)
S CHDATE=0 K A
"RTN","CHMEAV9",12,0)
Z1 S CHDATE=$O(^AHCHVA(DFN,101,CHDATE)) G Z2:'CHDATE
"RTN","CHMEAV9",13,0)
;;DEV023456 AEB 10-21-2015 ADDED 115 CHECK
"RTN","CHMEAV9",14,0)
G Z1:('$D(^AHCHVA(DFN,101,CHDATE,100,BFN,0)))&('$D(^AHCHVA(DFN,101,CHDATE,100,BFN,1)))&('$D(^AHCHVA(DFN,101,CHDATE,100,BFN,9)))&('$D(^AHCHVA(DFN,101,CHDATE,100,BFN,4))&('$D(^AHCHVA(DFN,101,CHDATE,100,BFN,115))))
"RTN","CHMEAV9",15,0)
S:$P(CHDATE,".")?7N A(-CHDATE)=$E(CHDATE,4,5)_"/"_$E(CHDATE,6,7)_"/"_$E(CHDATE,2,3)
"RTN","CHMEAV9",16,0)
G Z1
"RTN","CHMEAV9",17,0)
Z2 I '$D(A) W *7,!!,"No edit dates for this beneficiary!!" G ASK
"RTN","CHMEAV9",18,0)
W @CHMARESET
"RTN","CHMEAV9",19,0)
S DX=1 F DY=4:1:19 X XY W @CHEOL
"RTN","CHMEAV9",20,0)
W !,@CHEEL S DTM=5,DBM=18 X CHMAR
"RTN","CHMEAV9",21,0)
S DY=5,DX=1 X XY
"RTN","CHMEAV9",22,0)
W @CHBON,1,@CHBOFF,". View All Data",!,@CHBON,2,@CHBOFF,". View By Subject",!,@CHBON,3,@CHBOFF,". List Dates of Edit"
"RTN","CHMEAV9",23,0)
Z3 W !!,"SELECT: " D SBRS G ASK:($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",24,0)
I $D(DQOUT) W " Choose 1, 2, or 3." G Z3
"RTN","CHMEAV9",25,0)
G ASK:Y="" I (Y'=1)&(Y'=2)&(Y'=3) W *7," ??" G Z3
"RTN","CHMEAV9",26,0)
I Y=3 D LIST G ^CHMEAV:$D(DUOUT),ASK:$D(DFOUT) G Z2
"RTN","CHMEAV9",27,0)
K %DT S A=Y,%DT="APER",%DT("A")="From DATE: ",%DT("B")="NOW"
"RTN","CHMEAV9",28,0)
W ! D ^%DT K %DT G Z2:Y=-1 S CHFROM=Y
"RTN","CHMEAV9",29,0)
F Y=0:0 S Y=$O(^AHCHVA(DFN,101,Y)) Q:$D(^(Y,100,BFN,0))
"RTN","CHMEAV9",30,0)
S Y=$E(Y,1,12) X ^DD("DD") S %DT="APER",%DT("A")="To DATE: ",%DT("B")=Y
"RTN","CHMEAV9",31,0)
W ! D ^%DT K %DT G Z2:Y=-1 S CHTO=Y
"RTN","CHMEAV9",32,0)
I A=1 D ALL G ^CHMEAV:$D(DUOUT),ASK:$D(DFOUT) G Z2
"RTN","CHMEAV9",33,0)
I A=2 D SUBJ^CHMEAV91 G ^CHMEAV:$D(DUOUT),ASK:$D(DFOUT) G Z2
"RTN","CHMEAV9",34,0)
ASK K A
"RTN","CHMEAV9",35,0)
W @CHMARESET S CHDEF="MORE",CHDEFNUM="M"
"RTN","CHMEAV9",36,0)
G ASK^CHMEAV
"RTN","CHMEAV9",37,0)
LIST S DX=1 F DY=4:1:19 X XY W @CHEOL
"RTN","CHMEAV9",38,0)
S DY=4,DX=1 X XY W @CHULON,"Beneficiary Edit Dates:" F I=1:1:57 W " "
"RTN","CHMEAV9",39,0)
W @CHULOFF S DY=5,DX=1,CHDATE="",CHCOL=1,CT=0
"RTN","CHMEAV9",40,0)
L1 S CHDATE=$O(A(CHDATE)) G L2:CHDATE=""
"RTN","CHMEAV9",41,0)
S X=$P(CHDATE,".",2),CT=CT+1 D TIME
"RTN","CHMEAV9",42,0)
X XY S DY=DY+1 W A(CHDATE)," at ",X
"RTN","CHMEAV9",43,0)
I CT=14 G L2:CHCOL=3 S DY=5,CT=0 S:CHCOL=2 DX=61,CHCOL=3 S:CHCOL=1 DX=31,CHCOL=2
"RTN","CHMEAV9",44,0)
G L1
"RTN","CHMEAV9",45,0)
L2 S DY=20,DX=1 X XY W @CHEEL
"RTN","CHMEAV9",46,0)
I (CHCOL'=3)!(CHDATE="") W "Hit ",@CHBON,"RETURN",@CHBOFF," for Main Menu: " D SBRS Q
"RTN","CHMEAV9",47,0)
W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue, or ",@CHBON,"S",@CHBOFF," to Stop: "
"RTN","CHMEAV9",48,0)
D SBRS S Y=$E(Y) Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",49,0)
S DX=1 F DY=5:1:19 X XY W @CHEOL
"RTN","CHMEAV9",50,0)
S DY=5,DX=1,CHCOL=1,CT=0 X XY
"RTN","CHMEAV9",51,0)
G L1
"RTN","CHMEAV9",52,0)
ALL S CHDATE=-CHFROM+.0001,CT=0,U="^"
"RTN","CHMEAV9",53,0)
A1 S CHDATE=$O(A(CHDATE)) G A5:(CHDATE="")!(-CHDATE<CHTO)
"RTN","CHMEAV9",54,0)
S DX=1 F DY=4:1:16 X XY W @CHEOL
"RTN","CHMEAV9",55,0)
S DY=17,DX=48 X XY W @CHEBOL S DY=18,DX=48 X XY W @CHEBOL
"RTN","CHMEAV9",56,0)
S DY=4,DX=1 X XY
"RTN","CHMEAV9",57,0)
S S1=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,0)):^(0),1:"")
"RTN","CHMEAV9",58,0)
S S2=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,1)):^(1),1:"")
"RTN","CHMEAV9",59,0)
S S3=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,9)):^(9),1:"")
"RTN","CHMEAV9",60,0)
S S4=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,4)):^(4),1:"")
"RTN","CHMEAV9",61,0)
S S115=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,115)):^(115),1:"") ;DEV023457 AEB 10-21-2015 ADDED 115 CHECK
"RTN","CHMEAV9",62,0)
;F I=1,2,3,4,5,6,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,35,36,38,39 G A2:$P(S1,U,I)'="" ;920222 JSE 08-23-2017
"RTN","CHMEAV9",63,0)
F I=1,2,3,4,5,6,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,35,36,38,39,40 G A2:$P(S1,U,I)'="" ;920222 JSE 08-23-2017
"RTN","CHMEAV9",64,0)
K FLG F I=1,2,3,4,5,6,11,12,13 I $P(S2,U,I)'="" S FLG=1
"RTN","CHMEAV9",65,0)
I $D(FLG) D A3^CHMEAV92 S DY=4,DX=1 X XY W @CHEOL
"RTN","CHMEAV9",66,0)
Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",67,0)
K FLG2 F I=1:1:10 I $P(S3,U,I)'="" S FLG2=1
"RTN","CHMEAV9",68,0)
I $D(FLG2) D B3^CHMEAV92 S DY=4,DX=1 X XY W @CHEOL
"RTN","CHMEAV9",69,0)
Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",70,0)
K FLG3 F I=2:1:6 I $P(S4,U,I)'="" S FLG2=1
"RTN","CHMEAV9",71,0)
I $D(FLG3) D C3^CHMEAV92 S DY=4,DX=1 X XY W @CHEOL
"RTN","CHMEAV9",72,0)
K FLG4 F I=1,2,3,8 I $P(S115,"^",I)'="" S FLG4="" ;DEV023457 AEB 10-21-2015 ADDED 115 CHECK
"RTN","CHMEAV9",73,0)
I $D(FLG4) D E1^CHMEAV92 S DY=4,DX=1 X XY W @CHEOL ;DEV023457 AEB 10-21-2015 ADDED 115 CHECK
"RTN","CHMEAV9",74,0)
G A1
"RTN","CHMEAV9",75,0)
A2 I $P(S1,U,1)'="" S STR="Name:",PE=1 D ^CHMEAV91
"RTN","CHMEAV9",76,0)
I $P(S1,U,2)'="" S STR="Sex:",PE=2 D ^CHMEAV91
"RTN","CHMEAV9",77,0)
I $P(S1,U,3)'="" S STR="DOB:",PE=3 D ^CHMEAV91
"RTN","CHMEAV9",78,0)
I $P(S1,U,4)'="" S STR="Relation:",PE=4 D ^CHMEAV91
"RTN","CHMEAV9",79,0)
I $P(S1,U,5)'="" S STR="Status:",PE=5 D ^CHMEAV91
"RTN","CHMEAV9",80,0)
I $P(S1,U,6)'="" S STR="DOD:",PE=6 D ^CHMEAV91
"RTN","CHMEAV9",81,0)
I $P(S1,U,9)'="" S STR="SSN:",PE=9 D ^CHMEAV91
"RTN","CHMEAV9",82,0)
I $P(S1,U,10)'="" S STR="User Cmnt:",PE=10 D ^CHMEAV91
"RTN","CHMEAV9",83,0)
I $P(S1,U,11)'="" S STR="Sta Date:",PE=11 D ^CHMEAV91
"RTN","CHMEAV9",84,0)
I $P(S1,U,12)'="" S STR="Inel Reason:",PE=12,ST=.12 D ^CHMEAV91
"RTN","CHMEAV9",85,0)
I $P(S1,U,13)'="" S STR="Elig Reason:",PE=13,ST=.13 D ^CHMEAV91
"RTN","CHMEAV9",86,0)
I $P(S1,U,14)'="" S STR="MDcare Elig?",PE=14 D ^CHMEAV91
"RTN","CHMEAV9",87,0)
I $P(S1,U,15)'="" S STR="TRICARE Elig?",PE=15 D ^CHMEAV91 ;TLH 1/3/08 DEV002915 CHANGED CHAMPUS TO TRICARE
"RTN","CHMEAV9",88,0)
I $P(S1,U,16)'="" S STR="SP Divorced?",PE=16 D ^CHMEAV91
"RTN","CHMEAV9",89,0)
I $P(S1,U,17)'="" S STR="SP Remarried?",PE=17 D ^CHMEAV91
"RTN","CHMEAV9",90,0)
I $P(S1,U,18)'="" S STR="Remarr Term?",PE=18 D ^CHMEAV91
"RTN","CHMEAV9",91,0)
I $P(S1,U,19)'="" S STR="Chld Married?",PE=19 D ^CHMEAV91
"RTN","CHMEAV9",92,0)
I $P(S1,U,20)'="" S STR="In Armd Frc?",PE=20 D ^CHMEAV91
"RTN","CHMEAV9",93,0)
I $P(S1,U,21)'="" S STR="Chld In Hsld?",PE=21 D ^CHMEAV91
"RTN","CHMEAV9",94,0)
I $P(S1,U,22)'="" S STR="F-T Student?",PE=22 D ^CHMEAV91
"RTN","CHMEAV9",95,0)
I $P(S1,U,23)'="" S STR="Enrlmnt Dt:",PE=23 D ^CHMEAV91
"RTN","CHMEAV9",96,0)
I $P(S1,U,24)'="" S STR="Enrlmnt Inst:",PE=24 D ^CHMEAV91
"RTN","CHMEAV9",97,0)
I $P(S1,U,25)'="" S STR="Chl Mar Trm?",PE=25 D ^CHMEAV91
"RTN","CHMEAV9",98,0)
I $P(S1,U,26)'="" S STR="Chl Rel Ext:",PE=26 D ^CHMEAV91
"RTN","CHMEAV9",99,0)
I $P(S1,U,27)'="" S STR="Dt Of Adptn:",PE=27 D ^CHMEAV91
"RTN","CHMEAV9",100,0)
I $P(S1,U,28)'="" S STR="Illegit?",PE=28 D ^CHMEAV91
"RTN","CHMEAV9",101,0)
I $P(S1,U,35)'="" S STR="Deleted MED A date of ",PE=35 D ^CHMEAV91
"RTN","CHMEAV9",102,0)
I $P(S1,U,36)'="" S STR="Deleted MED B period from ",PE=36 D ^CHMEAV91
"RTN","CHMEAV9",103,0)
I $P(S1,U,38)'="" S STR="deleted PERIODS OF EXHAUSTION ",PE=38 D ^CHMEAV91
"RTN","CHMEAV9",104,0)
I $P(S1,U,39)'="" S STR="QE Date:",PE=39 D ^CHMEAV91
"RTN","CHMEAV9",105,0)
I $P(S1,U,40)'="" S STR="MBI:",PE=40 D ^CHMEAV91 ; JSE 920222 08/23/17 DISPLAY MBI IN EDIT HISTORY
"RTN","CHMEAV9",106,0)
A4 S CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,99)):$P(^(99),U,2),1:"")
"RTN","CHMEAV9",107,0)
S:CHUSER="" CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,99)):$P(^(99),U,2),1:"")
"RTN","CHMEAV9",108,0)
I (CHUSER),($D(^VA(200,CHUSER,0))) S CHUSER=$P(^(0),U)
"RTN","CHMEAV9",109,0)
E S CHUSER="UNKNOWN"
"RTN","CHMEAV9",110,0)
D BENE^CHMEAV94
"RTN","CHMEAV9",111,0)
S CHFLINE=CHHTIT_": "_$E(CHUSER,1,18)
"RTN","CHMEAV9",112,0)
F I=1:1:32-$L(CHFLINE) S CHFLINE=CHFLINE_" "
"RTN","CHMEAV9",113,0)
;skd
"RTN","CHMEAV9",114,0)
W @CHREVOFF
"RTN","CHMEAV9",115,0)
F I=1:1:(20-$L(CHUSER)) W " "
"RTN","CHMEAV9",116,0)
S DY=17,DX=49 X XY W @CHREVON,CHFLINE
"RTN","CHMEAV9",117,0)
;skd
"RTN","CHMEAV9",118,0)
S X=$P(CHDATE,".",2) D TIME
"RTN","CHMEAV9",119,0)
S DY=18,DX=49 X XY W "DATE/TIME: ",A(CHDATE)," at ",X,@CHREVOFF
"RTN","CHMEAV9",120,0)
I 'CT S DY=20,DX=1 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue, or ",@CHBON,"S",@CHBOFF," to Stop: "
"RTN","CHMEAV9",121,0)
E S DY=20,DX=39 X XY
"RTN","CHMEAV9",122,0)
D SBRS S Y=$E(Y),CT=1 Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",123,0)
I S2'="" D A3^CHMEAV92 Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",124,0)
I S3'="" D B3^CHMEAV92 Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",125,0)
I S4'="" D C3^CHMEAV92 Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV9",126,0)
I S115'="" D E1^CHMEAV92 Q:(Y="S")!($D(DFOUT))!($D(DUOUT)) ;DEV023457 AEB 10-21-2015 ADDED 115 CHECK
"RTN","CHMEAV9",127,0)
S Y=$O(A(CHDATE)) G A5:(Y="")!(-Y'>CHTO)
"RTN","CHMEAV9",128,0)
G A1
"RTN","CHMEAV9",129,0)
A5 S DY=20,DX=1 X XY
"RTN","CHMEAV9",130,0)
W "Last History. Hit ",@CHBON,"RETURN",@CHBOFF," for Main Menu: "
"RTN","CHMEAV9",131,0)
D SBRS
"RTN","CHMEAV9",132,0)
Q
"RTN","CHMEAV9",133,0)
TIME S I=$E(X,1,2),J=$E(X,3,4) S:J="" J="00" S:$E(J,2)'?1N J=J_0
"RTN","CHMEAV9",134,0)
S:$E(I)=0 I=$E(I,2) S:I=12 I=24 S:I=0 I=12
"RTN","CHMEAV9",135,0)
S X=I_":"_J_" am" S:I>12 X=I-12_":"_J_" pm"
"RTN","CHMEAV9",136,0)
S:$L($P(X,":"))=1 X=" "_X Q
"RTN","CHMEAV9",137,0)
SBRS D CSBRS^CHSC2 Q ;AEB 6/2/2005
"RTN","CHMEAV9",138,0)
R Y:$S($D(DTIME):DTIME,1:60)
"RTN","CHMEAV9",139,0)
I '$T W *7 R Y:5 G SBRS:Y="." S:'$T Y=IOZFO
"RTN","CHMEAV9",140,0)
SBRS1 K DFOUT,DUOUT,DQOUT S:'$D(IOZFO) IOZFO="^^" S:'$D(IOZBK) IOZBK="^"
"RTN","CHMEAV9",141,0)
I IOZFO=Y S (DFOUT,Y)="" Q
"RTN","CHMEAV9",142,0)
S:Y=IOZBK (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
"RTN","CHMEAV9",143,0)
Q
"RTN","CHMEAV91")
0^7^B53174414
"RTN","CHMEAV91",1,0)
CHMEAV91 ;CSW/DEN;LIST BENEFICIARY HISTORY;Jan 08, 2019@10:01:13
"RTN","CHMEAV91",2,0)
;;2.0;CHAMPVA SYSTEM;**7,1**;JULY 4, 1990;Build 4
"RTN","CHMEAV91",3,0)
;CPTS 10042* BY CAM
"RTN","CHMEAV91",4,0)
;CPTS 10895 BY AEB
"RTN","CHMEAV91",5,0)
;CPTS 11757 BY CAM
"RTN","CHMEAV91",6,0)
;DEV023457 AEB 10-21-2015
"RTN","CHMEAV91",7,0)
;CC4044.15 JSE 08-24-2017 920222-DISPLAY MBI IN AUDIT HISTORY
"RTN","CHMEAV91",8,0)
;RTC786743 ACA MERGE - TGH - 7/25/18
"RTN","CHMEAV91",9,0)
BENE S DA=$P(S1,"^",PE),DA2="" S:$E(DA)="@" DA=$E(DA,2,99),DA2=" (DELETED)"
"RTN","CHMEAV91",10,0)
S:PE=2 DA=$S(DA="M":"MALE",DA="F":"FEMALE",1:"")
"RTN","CHMEAV91",11,0)
S:(PE=9)&(DA?9N) DA=$E(DA,1,3)_"-"_$E(DA,4,5)_"-"_$E(DA,6,9)
"RTN","CHMEAV91",12,0)
I (PE=35)!(PE=36)!(PE=38) D MED
"RTN","CHMEAV91",13,0)
D REL:PE=4,STATUS:PE=5,REASON:(PE=12)!(PE=13),RELEXT:PE=26
"RTN","CHMEAV91",14,0)
I (PE=3)!(PE=6)!(PE=11)!(PE=23)!(PE=27)!(PE=39) S X=DA D DTPRT S DA=Y S:Y="" DA=X
"RTN","CHMEAV91",15,0)
I (PE=14)!(PE=15)!(PE=16)!(PE=17)!(PE=18)!(PE=19)!(PE=20)!(PE=21)!(PE=22)!(PE=25) S DA=$S(DA=1:"YES",1:"NO")
"RTN","CHMEAV91",16,0)
W !,STR,?14,$E(DA,1,50),DA2
"RTN","CHMEAV91",17,0)
Q
"RTN","CHMEAV91",18,0)
REL S DA=$P($P(^DD(554801.01,.04,0),DA_":",2),";")
"RTN","CHMEAV91",19,0)
S:DA="" DA="INVALID RELATIONSHIP" Q
"RTN","CHMEAV91",20,0)
STATUS S:DA="E" DA="ELIGIBLE" S:DA="EA" DA="ELIGIBLE-ACTIVE"
"RTN","CHMEAV91",21,0)
S:DA="I" DA="INCOMPLETE" S:DA="PD" DA="PENDING-NEED DATA"
"RTN","CHMEAV91",22,0)
S:DA="DC" DA="DATA CONFLICT" S:DA="D" DA="INELIGIBLE"
"RTN","CHMEAV91",23,0)
S:DA="PS" DA="PENDING-REVIEW" S:DA="A" DA="ACTIVE"
"RTN","CHMEAV91",24,0)
S:DA="T" DA="SENT TO DEERS-UNEDITABLE"
"RTN","CHMEAV91",25,0)
S:DA="PC" DA="PENDING DEERS-DATA CONFLICT"
"RTN","CHMEAV91",26,0)
S:DA="PR" DA="PENDING DEERS ACCEPTANCE"
"RTN","CHMEAV91",27,0)
S:$L(DA)<3 DA="INVALID"
"RTN","CHMEAV91",28,0)
Q
"RTN","CHMEAV91",29,0)
REASON I ST=.12 S DA=$O(^AHADIC(554801.7,"B",DA,0)) S:DA'="" DA=$P(^AHADIC(554801.7,DA,0),"^",2) Q
"RTN","CHMEAV91",30,0)
I ST=.13 S DA=$O(^AHADIC(554801.6,"B",DA,0)) S:DA'="" DA=$P(^AHADIC(554801.6,DA,0),"^",2) Q
"RTN","CHMEAV91",31,0)
S DA="INVALID REASON" Q
"RTN","CHMEAV91",32,0)
RELEXT S DA=$P($P(^DD(554801.01,.26,0),DA_":",2),";")
"RTN","CHMEAV91",33,0)
S:DA="" DA="INVALID CHILD REL EXTENSION" Q
"RTN","CHMEAV91",34,0)
SPONACK S DA=$P($P(^DD(554801.01,.28,0),DA_":",2),";")
"RTN","CHMEAV91",35,0)
S:DA="" DA="INVALID SPONSOR ACKNOWL. OF ILLEGIT." Q
"RTN","CHMEAV91",36,0)
SUBJ ;F I=.01:.01:.3 S:$D(^DD(554801.01,I,0)) B(I*100)=$P(^(0),"^") ;JSE 08-24-2017 920222 DISP MBI IN EDIT HIST
"RTN","CHMEAV91",37,0)
F I=.01:.01:.3,.4 S:$D(^DD(554801.01,I,0)) B(I*100)=$P(^(0),"^") ;JSE 08-24-2017 920222 DISP MBI IN EDIT HIST
"RTN","CHMEAV91",38,0)
S J=65 F I=1.01:.01:1.06,1.11:.01:1.13 S C($C(J))=$P(^DD(554801.01,I,0),"^"),J=J+1
"RTN","CHMEAV91",39,0)
F I=9.01,9.02,9.06:.01:9.08,9.1,9.09,9.03,9.05,4.02,4.03,4.04,4.05,4.06 S C($C(J))=$P(^DD(554801.01,I,0),"^"),J=J+1
"RTN","CHMEAV91",40,0)
F I=.03,.08 S C($C(J))=$P(^DD(554801.1115,I,0),"^"),J=J+1 ;AEB 10-21-2015 DEV023456
"RTN","CHMEAV91",41,0)
A1 W !!,"Which beneficiary field to view? " D CSBRS^CHSC2
"RTN","CHMEAV91",42,0)
I $D(DQOUT) D HELP^CHMEAV93 K DUOUT,DFOUT
"RTN","CHMEAV91",43,0)
G END:$D(DFOUT)!($D(DUOUT))!(Y="")
"RTN","CHMEAV91",44,0)
I '$D(B(Y))&'$D(C(Y)) W !!,"Enter a valid field number. Type a ? for help." G A1
"RTN","CHMEAV91",45,0)
;
"RTN","CHMEAV91",46,0)
; JSE 08-24-2017 920222 ADD MBI TO EDIT HIST - CNVT ENTRY #29 FRM HELP DISP TO 40th PIECE(MBI)
"RTN","CHMEAV91",47,0)
I $D(B(Y)),Y=29 S (Y,PE)=40,STR=B(Y) G A1A
"RTN","CHMEAV91",48,0)
;
"RTN","CHMEAV91",49,0)
; ajm - in the following seq $S(Y=10:39,1:Y) translates the qe date location from the
"RTN","CHMEAV91",50,0)
; 10th piece in the ^AHCHVA(I,100,J,0) node to the 39th piece in the history
"RTN","CHMEAV91",51,0)
; node, ^AHCHVA(I,101,J,100,K,0)
"RTN","CHMEAV91",52,0)
I $D(B(Y)) S STR=B(Y) S PE=$S(Y=10:39,1:Y) G A1A
"RTN","CHMEAV91",53,0)
S:$D(C(Y)) STR=C(Y)
"RTN","CHMEAV91",54,0)
S:Y="G" PE=7 S:Y="H" PE=8 S:Y="I" PE=9 S:Y="J" PE=10 S:Y="K" PE=11
"RTN","CHMEAV91",55,0)
S:Y="L" PE=12 S:Y="M" PE=13 S:Y="N" PE=14 S:Y="O" PE=15 S:Y="P" PE=16
"RTN","CHMEAV91",56,0)
S:Y="Q" PE=17 S:Y="R" PE=18
"RTN","CHMEAV91",57,0)
S:Y="S" PE=19 S:Y="T" PE=20 S:Y="U" PE=21 S:Y="V" PE=22 S:Y="W" PE=23
"RTN","CHMEAV91",58,0)
S:Y="A" PE=1 S:Y="B" PE=2 S:Y="C" PE=3 S:Y="D" PE=4 S:Y="E" PE=5
"RTN","CHMEAV91",59,0)
S:Y="F" PE=6
"RTN","CHMEAV91",60,0)
S:Y="X" PE=30 S:Y="Y" PE=30 ;AEB 10-21-2015 DEV023457
"RTN","CHMEAV91",61,0)
A1A S DX=1 F DY=6:1:18 X XY W @CHEOL ;TLH 053105
"RTN","CHMEAV91",62,0)
S DTM=7,DTB=18 X CHMAR ;TLH 053105
"RTN","CHMEAV91",63,0)
S DY=5,DX=1 X XY W @CHEEL S DY=5,DX=1 X XY W @CHULON,"SUBJECT: ",STR,@CHULOFF ;AEB 6/2/2005
"RTN","CHMEAV91",64,0)
S CHDATE=-CHFROM+.0001,CT=0
"RTN","CHMEAV91",65,0)
I PE=30 I Y="X" G A31
"RTN","CHMEAV91",66,0)
I PE=30 I Y="Y" G A31
"RTN","CHMEAV91",67,0)
G A3:('Y)&(PE<10) I ('Y)&(PE>9) D CONV G A3A
"RTN","CHMEAV91",68,0)
A2 S CHDATE=$O(A(CHDATE)) G A4:(CHDATE="")!(-CHDATE<CHTO)
"RTN","CHMEAV91",69,0)
G A2:'$D(^AHCHVA(DFN,101,-CHDATE,100,BFN,0)),A2:$P(^(0),"^",PE)=""
"RTN","CHMEAV91",70,0)
I (CT#3=0)&(CT) W !,"Hit ",@CHBON,"RETURN",@CHBOFF," to Continue, ",@CHBON,"S",@CHBOFF," to Stop: " D SBRS G END:($D(DFOUT))!($D(DUOUT))!(Y="S") ;AEB 3/2/2011 CHANGED CT#4 TO CT#3
"RTN","CHMEAV91",71,0)
S CT=CT+1,DA=$P(^(0),"^",PE),DA2="" S:$E(DA)="@" DA=$E(DA,2,99),DA2=" (DELETED)"
"RTN","CHMEAV91",72,0)
S:PE=2 DA=$S(DA="M":"MALE",DA="F":"FEMALE",1:"")
"RTN","CHMEAV91",73,0)
D REL:PE=4,STATUS:PE=5
"RTN","CHMEAV91",74,0)
S:(PE=9)&(DA?9N) DA=$E(DA,1,3)_"-"_$E(DA,4,5)_"-"_$E(DA,6,9)
"RTN","CHMEAV91",75,0)
I (PE=3)!(PE=6)!(PE=7)!(PE=8)!(PE=11)!(PE=23)!(PE=27)!(PE=29)!(PE=39) S X=DA D DTPRT S DA=Y S:Y="" DA=X
"RTN","CHMEAV91",76,0)
I PE=12 S ST=.12 D REASON
"RTN","CHMEAV91",77,0)
I PE=13 S ST=.13 D REASON
"RTN","CHMEAV91",78,0)
I (PE=14)!(PE=15)!(PE=16)!(PE=17)!(PE=18)!(PE=19)!(PE=20)!(PE=21)!(PE=22)!(PE=23)!(PE=25) S:DA=1 DA="YES" S:DA'=1 DA="NO"
"RTN","CHMEAV91",79,0)
D RELEXT:PE=26,SPONACK:PE=28
"RTN","CHMEAV91",80,0)
W !,CT,". " W:CT<10 " " W $E((DA_DA2),1,30)
"RTN","CHMEAV91",81,0)
D USER
"RTN","CHMEAV91",82,0)
G A2
"RTN","CHMEAV91",83,0)
A3 S CHDATE=$O(A(CHDATE)) G A4:(CHDATE="")!(-CHDATE'>CHTO)
"RTN","CHMEAV91",84,0)
G A3:'$D(^AHCHVA(DFN,101,-CHDATE,100,BFN,1)),A3:$P(^(1),"^",PE)=""
"RTN","CHMEAV91",85,0)
I (CT#4=0)&(CT) W !,"Hit ",@CHBON,"RETURN",@CHBOFF," to Continue, ",@CHBON,"S",@CHBOFF," to Stop: " D SBRS G END:($D(DFOUT))!($D(DUOUT))!(Y="S")
"RTN","CHMEAV91",86,0)
S DA=$P(^(1),"^",PE),DA2="",CT=CT+1 S:$E(DA)="@" DA=$E(DA,2,99),DA2=" (DELETED)"
"RTN","CHMEAV91",87,0)
S:PE=4 DA=$S($D(^DIC(5,+DA,0)):$P(^(0),"^"),1:"")
"RTN","CHMEAV91",88,0)
S:PE=6 DA=$S((DA?10N.E)!(DA?1"FTS".7N):"("_$E(DA,1,3)_") "_$E(DA,4,6)_"-"_$E(DA,7,99),DA?7N.E:$E(DA,1,3)_"-"_$E(DA,4,99),1:DA)
"RTN","CHMEAV91",89,0)
W !,CT,". " W:CT<10 " " W $E((DA_DA2),1,30)
"RTN","CHMEAV91",90,0)
D USER
"RTN","CHMEAV91",91,0)
G A3
"RTN","CHMEAV91",92,0)
A3A ;WHERE CORR WILL BE SET UP
"RTN","CHMEAV91",93,0)
G:PE>18 A3B ; PE>18 IS 4 NODE - BACKDATE ELIGIBILITY
"RTN","CHMEAV91",94,0)
S CHDATE=$O(A(CHDATE)) G A4:(CHDATE="")!(-CHDATE'>CHTO)
"RTN","CHMEAV91",95,0)
G A3A:'$D(^AHCHVA(DFN,101,-CHDATE,100,BFN,9)),A3A:$P(^(9),"^",PE)=""
"RTN","CHMEAV91",96,0)
I (CT#4=0)&(CT) W !,"Hit ",@CHBON,"RETURN",@CHBOFF," to Continue, ",@CHBON,"S",@CHBOFF," to Stop: " D SBRS G END:($D(DFOUT))!($D(DUOUT))!(Y="S")
"RTN","CHMEAV91",97,0)
S DA=$P(^(9),"^",PE),DA2="",CT=CT+1 S:$E(DA)="@" DA=$E(DA,2,99),DA2=" (DELETED)"
"RTN","CHMEAV91",98,0)
S:(PE=5)!(PE=7) DA=$S($D(^DIC(5,+DA,0)):$P(^(0),"^"),1:"")
"RTN","CHMEAV91",99,0)
S:PE=10 DA=$S((DA?10N.E)!(DA?1"FTS".7N):"("_$E(DA,1,3)_") "_$E(DA,4,6)_"-"_$E(DA,7,99),DA?7N.E:$E(DA,1,3)_"-"_$E(DA,4,99),1:DA)
"RTN","CHMEAV91",100,0)
W !,CT,". " W:CT<10 " " W $E((DA_DA2),1,30)
"RTN","CHMEAV91",101,0)
D USER
"RTN","CHMEAV91",102,0)
G A3A
"RTN","CHMEAV91",103,0)
A3B ;HISTORY FOR THE 4 NODE
"RTN","CHMEAV91",104,0)
S CHDATE=$O(A(CHDATE)) G A4:(CHDATE="")!(-CHDATE'>CHTO)
"RTN","CHMEAV91",105,0)
I PE<24 S PE=PE-17 ; WILL CONVERT THE PE VALUES TO PROPER PIECES
"RTN","CHMEAV91",106,0)
G A3B:'$D(^AHCHVA(DFN,101,-CHDATE,100,BFN,4)) G A3B:$P(^(4),"^",PE)=""
"RTN","CHMEAV91",107,0)
I (CT#4=0)&(CT) W !,"Hit ",@CHBON,"RETURN",@CHBOFF," to Continue, ",@CHBON,"S",@CHBOFF," to Stop: " D SBRS G END:($D(DFOUT))!($D(DUOUT))!(Y="S")
"RTN","CHMEAV91",108,0)
S DA=$P(^(4),"^",PE),CT=CT+1
"RTN","CHMEAV91",109,0)
W !,CT,". " W:CT<10 " " W:DA?7N $E(DA,4,5)_"/"_$E(DA,6,7)_"/"_$E(DA,2,3)
"RTN","CHMEAV91",110,0)
W:DA=1 "Yes" W:DA=0 "No" ;these will only be written for $P(^4) 5 & 6
"RTN","CHMEAV91",111,0)
D USER
"RTN","CHMEAV91",112,0)
G A3B
"RTN","CHMEAV91",113,0)
A31 ;;AEB 10-21-2015 DEV023457
"RTN","CHMEAV91",114,0)
S CHDATE=$O(A(CHDATE)) G A4:(CHDATE="")!(-CHDATE'>CHTO)
"RTN","CHMEAV91",115,0)
G A31:'$D(^AHCHVA(DFN,101,-CHDATE,100,BFN,115))
"RTN","CHMEAV91",116,0)
I Y="Y" G A31:$P(^(115),"^",8)=""
"RTN","CHMEAV91",117,0)
I Y="X" G A31:$P(^(115),"^",3)=""
"RTN","CHMEAV91",118,0)
I (CT#4=0)&(CT) W !,"Hit ",@CHBON,"RETURN",@CHBOFF," to Continue, ",@CHBON,"S",@CHBOFF," to Stop: " D SBRS G END:($D(DFOUT))!($D(DUOUT))!(Y="S")
"RTN","CHMEAV91",119,0)
I Y="X" S DA=$P(^(115),"^",3),CT=CT+1
"RTN","CHMEAV91",120,0)
I Y="Y" S DA=$P(^(115),"^",8),CT=CT+1
"RTN","CHMEAV91",121,0)
W !,CT,". " W:CT<10 " " W:DA?7N $E(DA,4,5)_"/"_$E(DA,6,7)_"/"_$E(DA,2,3)
"RTN","CHMEAV91",122,0)
D USER
"RTN","CHMEAV91",123,0)
G A31
"RTN","CHMEAV91",124,0)
A4 W:CT=0 !!!!!!!!!! W:CT#4=1 !!!!!!! W:CT#4=2 !!!! W:CT#4=3 !! ;AEB 6/2/2005
"RTN","CHMEAV91",125,0)
W !,"Last Page. Hit ",@CHBON,"RETURN",@CHBOFF," to Continue: " D SBRS
"RTN","CHMEAV91",126,0)
G END
"RTN","CHMEAV91",127,0)
MED I PE=35 S DA=$$FMTE^XLFDT($P(S1,"^",35),"2D") Q
"RTN","CHMEAV91",128,0)
I PE=36 D Q
"RTN","CHMEAV91",129,0)
.S DA=$$FMTE^XLFDT($P(S1,"^",36),"2D")_" to "_$$FMTE^XLFDT($P(S1,"^",37),"2D"),DA2=""
"RTN","CHMEAV91",130,0)
.Q
"RTN","CHMEAV91",131,0)
I PE=38 D Q
"RTN","CHMEAV91",132,0)
.S DA=$$FMTE^XLFDT($P(S1,"^",38),"2D")_" to "_$$FMTE^XLFDT($P(S1,"^",39),"2D"),DA2=""
"RTN","CHMEAV91",133,0)
.Q
"RTN","CHMEAV91",134,0)
END K CHDATE,AHDT,B,C,CT,DA,J,PE,ST,STR,T,X,Y
"RTN","CHMEAV91",135,0)
Q
"RTN","CHMEAV91",136,0)
CONV ;subr that converts the current PE value into the proper piece
"RTN","CHMEAV91",137,0)
;for the 9 node - we needed to maintain the previous number up
"RTN","CHMEAV91",138,0)
;until this point
"RTN","CHMEAV91",139,0)
S:PE=10 PE=1 S:PE=11 PE=2 S:PE=12 PE=6 S:PE=13 PE=7 S:PE=14 PE=8
"RTN","CHMEAV91",140,0)
S:PE=15 PE=10 S:PE=16 PE=9 S:PE=17 PE=3 S:PE=18 PE=5
"RTN","CHMEAV91",141,0)
Q
"RTN","CHMEAV91",142,0)
USER S CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,99)):$P(^(99),"^",2),1:"")
"RTN","CHMEAV91",143,0)
S:CHUSER="" CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,99)):$P(^(99),"^",2),1:"")
"RTN","CHMEAV91",144,0)
I (CHUSER),$D(^VA(200,CHUSER,0)) S CHUSER=$P(^(0),"^")
"RTN","CHMEAV91",145,0)
E S CHUSER="UNKNOWN"
"RTN","CHMEAV91",146,0)
D BENE^CHMEAV94
"RTN","CHMEAV91",147,0)
S CHFLINE=CHHTIT_": "_$E(CHUSER,1,18)
"RTN","CHMEAV91",148,0)
F I=1:1:32-$L(CHFLINE) S CHFLINE=CHFLINE_" "
"RTN","CHMEAV91",149,0)
;S DY=DY+1,DX=40 X XY W CHFLINE
"RTN","CHMEAV91",150,0)
W ?40,CHFLINE
"RTN","CHMEAV91",151,0)
S X=$P(CHDATE,".",2)
"RTN","CHMEAV91",152,0)
S I=$E(X,1,2),J=$E(X,3,4) S:J="" J="00" S:$E(J,2)'?1N J=J_0
"RTN","CHMEAV91",153,0)
S:$E(I)=0 I=$E(I,2) S:I=12 I=24 S:I=0 I=12
"RTN","CHMEAV91",154,0)
S X=I_":"_J_" am" S:I>12 X=I-12_":"_J_" pm"
"RTN","CHMEAV91",155,0)
S:$L($P(X,":"))=1 X=" "_X
"RTN","CHMEAV91",156,0)
W !?40,"DATE/TIME: ",A(CHDATE)," at ",X,!
"RTN","CHMEAV91",157,0)
Q
"RTN","CHMEAV91",158,0)
SBRS R Y:$S($D(DTIME):DTIME,1:60)
"RTN","CHMEAV91",159,0)
I '$T W *7 R Y:5 G SBRS:Y="." S:'$T Y=IOZFO
"RTN","CHMEAV91",160,0)
SBRS1 K DFOUT,DUOUT,DQOUT S:'$D(IOZFO) IOZFO="^^" S:'$D(IOZBK) IOZBK="^"
"RTN","CHMEAV91",161,0)
I IOZFO=Y S (DFOUT,Y)="" Q
"RTN","CHMEAV91",162,0)
S:Y=IOZBK (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
"RTN","CHMEAV91",163,0)
Q
"RTN","CHMEAV91",164,0)
DTPRT S Y="" Q:X'?7N S Y=$E(X,1,3)+1700,%M=+$E(X,4,5),%D=+$E(X,6,7)
"RTN","CHMEAV91",165,0)
I %M S:%D Y=$E(" ",$L(%D))_%D_", "_Y S Y=$P($P($T(JAN),";;",2)," ",%M)_" "_Y
"RTN","CHMEAV91",166,0)
Q
"RTN","CHMEAV91",167,0)
JAN ;;JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
"RTN","CHMEAV92")
0^8^B40714342
"RTN","CHMEAV92",1,0)
CHMEAV92 ;CSW/DEN;BENEFICIARY EDIT HISTORY;Jan 08, 2019@10:07:51
"RTN","CHMEAV92",2,0)
;;2.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHMEAV92",3,0)
;CPTS 10042* BY CAM
"RTN","CHMEAV92",4,0)
;CPTS 10895 BY AEB
"RTN","CHMEAV92",5,0)
;CPTS 11757 CY CAM
"RTN","CHMEAV92",6,0)
;RTC786743 ACA MERGE - TGH - 7/25/18
"RTN","CHMEAV92",7,0)
A3 K FLG Q:S2="" W !
"RTN","CHMEAV92",8,0)
F I=4:1:18 S DY=I,DX=1 X XY W @CHEOL
"RTN","CHMEAV92",9,0)
;S DY=4,DX=1 X XY W @CHULON,"Remit-to Address",@CHULOFF ;SKD
"RTN","CHMEAV92",10,0)
S DY=5,DX=1 X XY W @CHULON,"Remit-to Address",@CHULOFF ;SKD
"RTN","CHMEAV92",11,0)
G A31:$P(S2,U)="" W !,"Address Line 1:",?18
"RTN","CHMEAV92",12,0)
I $E($P(S2,U))'="@" W $P(S2,U)
"RTN","CHMEAV92",13,0)
E W $E($P(S2,U),2,99)," (DELETED)"
"RTN","CHMEAV92",14,0)
A31 G A32:$P(S2,U,2)="" W !,"Address Line 2:",?18
"RTN","CHMEAV92",15,0)
I $E($P(S2,U,2))'="@" W $P(S2,U,2)
"RTN","CHMEAV92",16,0)
E W $E($P(S2,U,2),2,99)," (DELETED)"
"RTN","CHMEAV92",17,0)
A32 G A33:$P(S2,U,3)="" W !,"City:",?18
"RTN","CHMEAV92",18,0)
I $E($P(S2,U,3))'="@" W $P(S2,U,3)
"RTN","CHMEAV92",19,0)
E W $E($P(S2,U,3),2,99)," (DELETED)"
"RTN","CHMEAV92",20,0)
A33 G A34:$P(S2,U,4)="" W !,"State:",?18
"RTN","CHMEAV92",21,0)
I $E($P(S2,U,4))'="@" I $P(S2,U,4)'="" W:$D(^DIC(5,$P(S2,U,4),0)) $P(^(0),U)
"RTN","CHMEAV92",22,0)
E I $P(S2,U,4)'="" W:$D(^DIC(5,$E($P(S2,U,4),2,99),0)) $P(^(0),U)," (DELETED)"
"RTN","CHMEAV92",23,0)
A34 G A35:$P(S2,U,5)="" W !,"Zip:",?18
"RTN","CHMEAV92",24,0)
I $E($P(S2,U,5))'="@" S X=$P(S2,U,5) W $S(X?9N:$E(X,1,5)_"-"_$E(X,6,9),X?5N:X,X?5N1"-"4N:X,1:"")
"RTN","CHMEAV92",25,0)
E S X=$E($P(S2,U,5),2,99) W $S(X?9N:$E(X,1,5)_"-"_$E(X,6,9),X?5N:X,X?5N1"-"4N:X,1:"")," (DELETED)"
"RTN","CHMEAV92",26,0)
A35 G A36:$P(S2,U,6)="" W !,"Phone:",?18
"RTN","CHMEAV92",27,0)
I $E($P(S2,U,6))'="@" S X=$P(S2,U,6) W $S((X?10N.E)!(X?1"FTS".7N):"("_$E(X,1,3)_") "_$E(X,4,6)_"-"_$E(X,7,99),X?7N.E:$E(X,1,3)_"-"_$E(X,4,99),1:X)
"RTN","CHMEAV92",28,0)
E S X=$E($P(S2,U,6),2,99) W $S((X?10N.E)!(X?1"FTS".7N):"("_$E(X,1,3)_") "_$E(X,4,6)_"-"_$E(X,7,99),X?7N.E:$E(X,1,3)_"-"_$E(X,4,99),1:X)," (DELETED)"
"RTN","CHMEAV92",29,0)
A36 S U="^"
"RTN","CHMEAV92",30,0)
G A37:$P(S2,U,11)="" W !,"Foreign Addr?",?18
"RTN","CHMEAV92",31,0)
S X=$P(S2,U,11) S:X=1 X="YES" S:X=0 X="NO"
"RTN","CHMEAV92",32,0)
I $E($P(S2,U,11))'="@" W X
"RTN","CHMEAV92",33,0)
E S X=$E(X,2) S:X=1 X="YES" S:X=0 X="NO" W X," (DELETED)"
"RTN","CHMEAV92",34,0)
A37 G A38:$P(S2,U,12)="" W !,"Address Line 3:",?18
"RTN","CHMEAV92",35,0)
I $E($P(S2,U,12))'="@" W $P(S2,U,12)
"RTN","CHMEAV92",36,0)
E W $E($P(S2,U,12),2,99)," (DELETED)"
"RTN","CHMEAV92",37,0)
A38 G:$P(S2,U,13)="" A4 W !,"Country:",?18
"RTN","CHMEAV92",38,0)
I $E($P(S2,U,13))'="@" I $P(S2,U,13)'="" W:$D(^DIC(5,$P(S2,U,13),0)) $P(^(0),U)
"RTN","CHMEAV92",39,0)
E I $P(S2,U,13)'="" W:$D(^DIC(5,$E($P(S2,U,13),2,99),0)) $P(^(0),U)," (DELETED)"
"RTN","CHMEAV92",40,0)
A4 S CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,99)):$P(^(99),U,2),1:"")
"RTN","CHMEAV92",41,0)
S:CHUSER="" CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,99)):$P(^(99),U,2),1:"")
"RTN","CHMEAV92",42,0)
I (CHUSER),($D(^VA(200,CHUSER,0))) S CHUSER=$P(^(0),U)
"RTN","CHMEAV92",43,0)
E S CHUSER="UNKNOWN"
"RTN","CHMEAV92",44,0)
D BENE^CHMEAV94
"RTN","CHMEAV92",45,0)
S CHFLINE=CHHTIT_": "_$E(CHUSER,1,18)
"RTN","CHMEAV92",46,0)
F I=1:1:32-$L(CHFLINE) S CHFLINE=CHFLINE_" "
"RTN","CHMEAV92",47,0)
S DY=17,DX=49 X XY W @CHREVON,CHFLINE
"RTN","CHMEAV92",48,0)
;;F I=1:1:(20-$L(CHUSER)) W @(CHREVOFF)," " ;SKD - extra blank space causes a wrap to next line
"RTN","CHMEAV92",49,0)
F I=1:1:(20-$L(CHUSER)) W @(CHREVOFF) ;," " ;SKD
"RTN","CHMEAV92",50,0)
S X=$P(CHDATE,".",2) D TIME
"RTN","CHMEAV92",51,0)
S DY=18,DX=49 X XY W @CHREVON W "DATE/TIME: ",A(CHDATE)," at ",X,@CHREVOFF
"RTN","CHMEAV92",52,0)
I 'CT S DY=20,DX=1 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue, or ",@CHBON,"S",@CHBOFF," to Stop: "
"RTN","CHMEAV92",53,0)
E S DY=20,DX=39 X XY
"RTN","CHMEAV92",54,0)
D SBRS S Y=$E(Y),CT=1 Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV92",55,0)
Q
"RTN","CHMEAV92",56,0)
A5 S DY=20,DX=1 X XY
"RTN","CHMEAV92",57,0)
W "Last History. Hit ",@CHBON,"RETURN",@CHBOFF," for Main Menu: "
"RTN","CHMEAV92",58,0)
D SBRS
"RTN","CHMEAV92",59,0)
Q
"RTN","CHMEAV92",60,0)
;
"RTN","CHMEAV92",61,0)
B3 K FLG2 Q:S3=""
"RTN","CHMEAV92",62,0)
B30 ;ALT ADDRESS HISTORY
"RTN","CHMEAV92",63,0)
F I=4:1:18 S DY=I,DX=1 X XY W @CHEOL
"RTN","CHMEAV92",64,0)
S DY=4,DX=1 X XY W @CHULON,"Alternate/Correspondence Address",@CHULOFF
"RTN","CHMEAV92",65,0)
G B31:$P(S3,U)="" W !,"Address Line 1:",?18
"RTN","CHMEAV92",66,0)
I $E($P(S3,U))'="@" W $P(S3,U)
"RTN","CHMEAV92",67,0)
E W $E($P(S3,U),2,99)," (DELETED)"
"RTN","CHMEAV92",68,0)
B31 G B32:$P(S3,U,2)="" W !,"Address Line 2:",?18
"RTN","CHMEAV92",69,0)
I $E($P(S3,U,2))'="@" W $P(S3,U,2)
"RTN","CHMEAV92",70,0)
E W $E($P(S3,U,2),2,99)," (DELETED)"
"RTN","CHMEAV92",71,0)
B32 G B33:$P(S3,U,3)="" W !,"Address Line 3:",?18
"RTN","CHMEAV92",72,0)
I $E($P(S3,U,3))'="@" W $P(S3,U,3)
"RTN","CHMEAV92",73,0)
E W $E($P(S3,U,3),2,99)," (DELETED)"
"RTN","CHMEAV92",74,0)
B33 G B34:$P(S3,U,4)="" W !,"Address Line 4:",?18
"RTN","CHMEAV92",75,0)
I $E($P(S3,U,4))'="@" W $P(S3,U,4)
"RTN","CHMEAV92",76,0)
E W $E($P(S3,U,4),2,99)," (DELETED)"
"RTN","CHMEAV92",77,0)
B34 G B35:$P(S3,U,5)="" W !,"Country:",?18
"RTN","CHMEAV92",78,0)
I $E($P(S3,U,5))'="@" I $P(S3,U,5)'="" W:$D(^DIC(5,$P(S3,U,5),0)) $P(^(0),U)
"RTN","CHMEAV92",79,0)
E I $P(S3,U,5)'="" W:$D(^DIC(5,$E($P(S3,U,5),2,99),0)) $P(^(0),U)," (DELETED)"
"RTN","CHMEAV92",80,0)
B35 G B36:$P(S3,U,6)="" W !,"City:",?18
"RTN","CHMEAV92",81,0)
I $E($P(S3,U,6))'="@" W $P(S3,U,6)
"RTN","CHMEAV92",82,0)
E W $E($P(S3,U,6),2,99)," (DELETED)"
"RTN","CHMEAV92",83,0)
B36 G B37:$P(S3,U,7)="" W !,"State:",?18
"RTN","CHMEAV92",84,0)
I $E($P(S3,U,7))'="@" I $P(S3,U,7)'="" W:$D(^DIC(5,$P(S3,U,7),0)) $P(^(0),U)
"RTN","CHMEAV92",85,0)
E I $P(S3,U,7)'="" W:$D(^DIC(5,$E($P(S3,U,7),2,99),0)) $P(^(0),U)," (DELETED)"
"RTN","CHMEAV92",86,0)
B37 G B38:$P(S3,U,8)="" W !,"Zip:",?18
"RTN","CHMEAV92",87,0)
I $E($P(S3,U,8))'="@" S X=$P(S3,U,8) W $S(X?9N:$E(X,1,5)_"-"_$E(X,6,9),X?5N:X,X?5N1"-"4N:X,1:"")
"RTN","CHMEAV92",88,0)
E S X=$E($P(S3,U,8),2,99) W $S(X?9N:$E(X,1,5)_"-"_$E(X,6,9),X?5N:X,X?5N1"-"4N:X,1:"")," (DELETED)"
"RTN","CHMEAV92",89,0)
B38 G B39:$P(S3,U,9)="" W !,"Foreign Addr?",?18
"RTN","CHMEAV92",90,0)
S X=$P(S3,U,9) S:X=1 X="YES" S:X=0 X="NO"
"RTN","CHMEAV92",91,0)
I $E($P(S3,U,9))'="@" W X
"RTN","CHMEAV92",92,0)
E S X=$E(X,2) S:X=1 X="YES" S:X=0 X="NO" W X," (DELETED)"
"RTN","CHMEAV92",93,0)
B39 G:$P(S3,U,10)="" A40 W !,"Phone:",?18
"RTN","CHMEAV92",94,0)
I $E($P(S3,U,10))'="@" S X=$P(S3,U,10) W $S((X?10N.E)!(X?1"FTS".7N):"("_$E(X,1,3)_") "_$E(X,4,6)_"-"_$E(X,7,99),X?7N.E:$E(X,1,3)_"-"_$E(X,4,99),1:X)
"RTN","CHMEAV92",95,0)
E S X=$E($P(S3,U,10),2,99) W $S((X?10N.E)!(X?1"FTS".7N):"("_$E(X,1,3)_") "_$E(X,4,6)_"-"_$E(X,7,99),X?7N.E:$E(X,1,3)_"-"_$E(X,4,99),1:X)," (DELETED)"
"RTN","CHMEAV92",96,0)
A40 D A4 Q
"RTN","CHMEAV92",97,0)
;S CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,100,BFN,99)):$P(^(99),U,2),1:"")
"RTN","CHMEAV92",98,0)
;S:CHUSER="" CHUSER=$S($D(^AHCHVA(DFN,101,-CHDATE,99)):$P(^(99),U,2),1:"")
"RTN","CHMEAV92",99,0)
;I (CHUSER),($D(^VA(200,CHUSER,0))) S CHUSER=$P(^(0),U)
"RTN","CHMEAV92",100,0)
;E S CHUSER="UNKNOWN"
"RTN","CHMEAV92",101,0)
;D BENE^CHMEAV94
"RTN","CHMEAV92",102,0)
;S CHFLINE=CHHTIT_": "_$E(CHUSER,1,18)
"RTN","CHMEAV92",103,0)
;F I=1:1:32-$L(CHFLINE) S CHFLINE=CHFLINE_" "
"RTN","CHMEAV92",104,0)
;S DY=17,DX=49 X XY W @CHREVON,CHFLINE
"RTN","CHMEAV92",105,0)
;F I=1:1:(20-$L(CHUSER)) W " "
"RTN","CHMEAV92",106,0)
;S X=$P(CHDATE,".",2) D TIME
"RTN","CHMEAV92",107,0)
;S DY=18,DX=49 X XY W "DATE/TIME: ",A(CHDATE)," at ",X,@CHREVOFF
"RTN","CHMEAV92",108,0)
;S Y=$O(A(CHDATE)) G A5:(Y="")!(-Y'>CHTO)
"RTN","CHMEAV92",109,0)
;I 'CT S DY=20,DX=1 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue, or ",@CHBON,"S",@CHBOFF," to Stop: "
"RTN","CHMEAV92",110,0)
;E S DY=20,DX=39 X XY
"RTN","CHMEAV92",111,0)
;D SBRS S Y=$E(Y),CT=1 Q:(Y="S")!($D(DFOUT))!($D(DUOUT))
"RTN","CHMEAV92",112,0)
;Q
"RTN","CHMEAV92",113,0)
C3 K FLG3 Q:S4=""
"RTN","CHMEAV92",114,0)
C30 ;BACKDATE ELIGIBILITY
"RTN","CHMEAV92",115,0)
F I=4:1:18 S DY=I,DX=1 X XY W @CHEOL
"RTN","CHMEAV92",116,0)
S DY=4,DX=1 X XY W @CHULON,"Backdate Eligibility",@CHULOFF
"RTN","CHMEAV92",117,0)
I $P(S4,U,2)'="" D
"RTN","CHMEAV92",118,0)
.W !,"Backdate - Start of 180 days: ",?37
"RTN","CHMEAV92",119,0)
.W $E($P(S4,U,2),4,5)_"/"_$E($P(S4,U,2),6,7)_"/"_$E($P(S4,U,2),2,3)
"RTN","CHMEAV92",120,0)
C31 I $P(S4,U,3)'="" D
"RTN","CHMEAV92",121,0)
.W !,"Backdate - Begin Eligibility Date: ",?37
"RTN","CHMEAV92",122,0)
.W $E($P(S4,U,3),4,5)_"/"_$E($P(S4,U,3),6,7)_"/"_$E($P(S4,U,3),2,3)
"RTN","CHMEAV92",123,0)
C32 I $P(S4,U,4)'="" D
"RTN","CHMEAV92",124,0)
.W !,"Backdate - End Eligibility Date: ",?37
"RTN","CHMEAV92",125,0)
.W $E($P(S4,U,4),4,5)_"/"_$E($P(S4,U,4),6,7)_"/"_$E($P(S4,U,4),2,3)
"RTN","CHMEAV92",126,0)
C33 I $P(S4,U,5)'="" D
"RTN","CHMEAV92",127,0)
.W !,"Backdate - New Bene: ",?37
"RTN","CHMEAV92",128,0)
.W:$P(S4,U,5)=1 "Yes" W:$P(S4,U,5)=0 "No"
"RTN","CHMEAV92",129,0)
C34 I $P(S4,U,6)'="" D
"RTN","CHMEAV92",130,0)
.W !,"Backdated Via Option 13? ",?37
"RTN","CHMEAV92",131,0)
.W:$P(S4,U,6)=1 "Yes" W:$P(S4,U,6)=0 "No"
"RTN","CHMEAV92",132,0)
D A4 Q
"RTN","CHMEAV92",133,0)
E1 ;;DEV023457 AEB 10-21-2015 ADDED 115 CHECK
"RTN","CHMEAV92",134,0)
Q:S115=""
"RTN","CHMEAV92",135,0)
F I=4:1:18 S DY=I,DX=1 X XY W @CHEOL
"RTN","CHMEAV92",136,0)
S DY=5,DX=1 X XY W @CHULON,"DISENROLLMENT DATA",@CHULOFF
"RTN","CHMEAV92",137,0)
N TMP
"RTN","CHMEAV92",138,0)
E11 I $P(S115,U,1)'="" D ;PROGRAM
"RTN","CHMEAV92",139,0)
.W !,"Program: ",?37
"RTN","CHMEAV92",140,0)
.S:$P(S115,U,1)=1 TMP="CVA" S:$P(S115,U,1)=6 TMP="SB" S:$P(S115,U,1)=7 TMP="WV"
"RTN","CHMEAV92",141,0)
.W TMP
"RTN","CHMEAV92",142,0)
E12 I $P(S115,U,2)'="" D ;TYPE - 0=ENROLL; 1=DISENROLL
"RTN","CHMEAV92",143,0)
.W !,"TYPE =",?37
"RTN","CHMEAV92",144,0)
.W:$P(S115,U,2)=0 "ENROLL" W:$P(S115,U,2)=1 "DISENROLL"
"RTN","CHMEAV92",145,0)
E13 I $P(S115,U,3)'="" D ;DISENROLLMENT DATE
"RTN","CHMEAV92",146,0)
.W !,"DISENROLLMENT DATE =",?37
"RTN","CHMEAV92",147,0)
.W $$FMTE^XLFDT($P(S115,U,3),"5D")
"RTN","CHMEAV92",148,0)
E14 I $P(S115,U,8)'="" D ;RE-ENROLLMENT DATE
"RTN","CHMEAV92",149,0)
.W !,"REENROLLMENT DATE =",?37
"RTN","CHMEAV92",150,0)
.W $$FMTE^XLFDT($P(S115,U,8),"5D")
"RTN","CHMEAV92",151,0)
D A4
"RTN","CHMEAV92",152,0)
Q
"RTN","CHMEAV92",153,0)
TIME S I=$E(X,1,2),J=$E(X,3,4) S:J="" J="00" S:$E(J,2)'?1N J=J_0
"RTN","CHMEAV92",154,0)
S:$E(I)=0 I=$E(I,2) S:I=12 I=24 S:I=0 I=12
"RTN","CHMEAV92",155,0)
S X=I_":"_J_" am" S:I>12 X=I-12_":"_J_" pm"
"RTN","CHMEAV92",156,0)
S:$L($P(X,":"))=1 X=" "_X Q
"RTN","CHMEAV92",157,0)
SBRS R Y:$S($D(DTIME):DTIME,1:60)
"RTN","CHMEAV92",158,0)
I '$T W *7 R Y:5 G SBRS:Y="." S:'$T Y=IOZFO
"RTN","CHMEAV92",159,0)
SBRS1 K DFOUT,DUOUT,DQOUT S:'$D(IOZFO) IOZFO="^^" S:'$D(IOZBK) IOZBK="^"
"RTN","CHMEAV92",160,0)
I IOZFO=Y S (DFOUT,Y)="" Q
"RTN","CHMEAV92",161,0)
S:Y=IOZBK (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
"RTN","CHMEAV92",162,0)
Q
"RTN","CHSBE001")
0^20^B4990340
"RTN","CHSBE001",1,0)
CHSBE001 ;HAC/CAM;APPLICANT LOOK-UP MODULE FOR SB;Jan 08, 2019@10:08:25
"RTN","CHSBE001",2,0)
;;1.0;CHAMPVA SYSTEM;**10,1**;JULY 4, 1990;Build 4
"RTN","CHSBE001",3,0)
;CPTS 12075 BY CAM
"RTN","CHSBE001",4,0)
;Defect-BDB-11/1/2018-screen error on "^" at sponsor prompt
"RTN","CHSBE001",5,0)
;
"RTN","CHSBE001",6,0)
A1 K DFN,BFN,CHNS,CHNEW
"RTN","CHSBE001",7,0)
S DY=7,DX=1 X XY
"RTN","CHSBE001",8,0)
A11 ; bdb 11/1/2018
"RTN","CHSBE001",9,0)
W "Enter Spina Bifida bene or sponsor: "
"RTN","CHSBE001",10,0)
D CSBRS^CHSC2
"RTN","CHSBE001",11,0)
I $D(DQOUT) D G A1
"RTN","CHSBE001",12,0)
.S DY=9,DX=1 X XY
"RTN","CHSBE001",13,0)
.W "Valid entries are: - Full or partial Bene or Sponsor name"
"RTN","CHSBE001",14,0)
.S DY=10,DX=20 X XY W "- Sponsor file number"
"RTN","CHSBE001",15,0)
.S DY=11,DX=20 X XY W "- Beneficiary ID Card number"
"RTN","CHSBE001",16,0)
.S DY=12,DX=20 X XY W "- Sponsor or Beneficiary SSN"
"RTN","CHSBE001",17,0)
.S DY=20,DX=11 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF
"RTN","CHSBE001",18,0)
.W " to enter a Spina Bifida beneficiary or sponsor."
"RTN","CHSBE001",19,0)
.R X:DTIME
"RTN","CHSBE001",20,0)
.S DX=1 F DY=7:1:20 X XY W @CHEOL
"RTN","CHSBE001",21,0)
G END:$D(DFOUT)!($D(DUOUT))!(Y="")
"RTN","CHSBE001",22,0)
I Y'?.N S CHENTRY=Y
"RTN","CHSBE001",23,0)
K DIC S X=Y,DIC=554801,DIC(0)="ZEM"
"RTN","CHSBE001",24,0)
S DIC("W")="W !,?9,""SSN: "" W:$P(^(0),U,9)?9N $E($P(^(0),U,9),1,3),""-"",$E($P(^(0),U,9),4,5),""-"",$E($P(^(0),U,9),6,9) W ?35,""FILE #: "",$P(^(0),U,7),!"
"RTN","CHSBE001",25,0)
D ^DIC K DIC
"RTN","CHSBE001",26,0)
I (X="?")!(X="^") W !! G A11 ;bdb 11/1/2018
"RTN","CHSBE001",27,0)
G:(Y=-1)!(X="") END
"RTN","CHSBE001",28,0)
S DFN=+Y,CHSSN=$P(Y(0),U,9)
"RTN","CHSBE001",29,0)
S:CHSSN CHSSN=$E(CHSSN,1,3)_"-"_$E(CHSSN,4,5)_"-"_$E(CHSSN,6,9)
"RTN","CHSBE001",30,0)
W !!,$E($P(Y(0),U),1,20),?22,"SSN: ",CHSSN
"RTN","CHSBE001",31,0)
W ?43,"FILE #: ",$P(Y(0),U,7)
"RTN","CHSBE001",32,0)
S J=0 I $D(DFN) F I=0:0 S I=$O(^AHCHVA(DFN,110,I)) Q:'I S:$P(^(I,0),U,4) J=1 S:$P(^(0),U,4)=0 J=0
"RTN","CHSBE001",33,0)
W:J " (VERIFIED)"
"RTN","CHSBE001",34,0)
A2 W !!,"Correct? Y// "
"RTN","CHSBE001",35,0)
D CSBRS^CHSC2
"RTN","CHSBE001",36,0)
G:$D(DFOUT) END
"RTN","CHSBE001",37,0)
I $D(DUOUT) D G A1
"RTN","CHSBE001",38,0)
.S DX=1 F DY=7:1:13 X XY W @CHEOL
"RTN","CHSBE001",39,0)
I $D(DQOUT) W !!,"Do you want to process SB info for this sponsor?" G A2
"RTN","CHSBE001",40,0)
S:Y="" Y="Y" S Y=$E(Y)
"RTN","CHSBE001",41,0)
I "YyNn"'[Y W *7," ??" G A2
"RTN","CHSBE001",42,0)
I "Nn"[Y D G A1
"RTN","CHSBE001",43,0)
.S DX=1 F DY=7:1:24 X XY W @CHEOL
"RTN","CHSBE001",44,0)
S ^DISV(DUZ,"^AHCHVA(SPONSOR,")=DFN
"RTN","CHSBE001",45,0)
END K CHSSN,CHSN,C,Y(0),Y(0,0) Q
"RTN","CHSBE005")
0^10^B7474587
"RTN","CHSBE005",1,0)
CHSBE005 ;HAC/CAM;SPINA BIFIDA - ENTER OPTION NUMBER;Jan 08, 2019@10:09:11
"RTN","CHSBE005",2,0)
;;2.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE005",3,0)
;;CPTS 12075 BY CAM
"RTN","CHSBE005",4,0)
;;WE NOW HAVE A DFN
"RTN","CHSBE005",5,0)
;;DEV023457 JAK 11-05-2015
"RTN","CHSBE005",6,0)
;;RTC786712 SBB 07-25-2018 ACA merge
"RTN","CHSBE005",7,0)
;
"RTN","CHSBE005",8,0)
A1 X CHRESET
"RTN","CHSBE005",9,0)
D TOP^CHSBEU01,BOTTOM^CHSBEU01,LINE19^CHSBEU01
"RTN","CHSBE005",10,0)
S CHOPT=" View Bene",CHNUM=5
"RTN","CHSBE005",11,0)
A1A I '$D(BFN) S CHOPT=" SB Benes",CHNUM=11
"RTN","CHSBE005",12,0)
S DY=20,DX=1 X XY W @CHEOL,CHNUM," ",CHOPT,"// "
"RTN","CHSBE005",13,0)
A2 D CSBRS^CHSC2
"RTN","CHSBE005",14,0)
G:$D(DFOUT) END G:$D(DUOUT) END
"RTN","CHSBE005",15,0)
I $D(DQOUT) D VALID^CHSBEU02 G A1
"RTN","CHSBE005",16,0)
S:Y="" Y=CHNUM
"RTN","CHSBE005",17,0)
D NUMOPT
"RTN","CHSBE005",18,0)
G:$E(Y)="Q" END
"RTN","CHSBE005",19,0)
I (Y<1)!(Y>15) D VALID^CHSBEU02 G A1
"RTN","CHSBE005",20,0)
I 'Y D VALID^CHSBEU02 G A1
"RTN","CHSBE005",21,0)
;I ((Y=2)!(Y=6)!(Y=10)!(Y=14))&(CHSEC=1) D SECURE^CHSBEU02 G A1
"RTN","CHSBE005",22,0)
;I ((Y=10)!(Y=14))&(CHSEC=2) D SECURE^CHSBEU02 G A1
"RTN","CHSBE005",23,0)
I (Y=5)!(Y=6)!(Y=7)!(Y=8)!(Y=9)!(Y=10) I '$D(BFN) S CHTMP=Y D ^CHSBE110 S Y=CHTMP D NUMOPT
"RTN","CHSBE005",24,0)
S CHNUM=Y
"RTN","CHSBE005",25,0)
A3 I CHNUM=1 D ^CHSBE010 S CHNUM=2,CHOPT=" Edit Spon" G A1A ; VIEW SPON
"RTN","CHSBE005",26,0)
I CHNUM=2 D ^CHSBE020 G A1A ; EDIT SPON
"RTN","CHSBE005",27,0)
I CHNUM=3 D ^CHSBE030 G A1A ; VIEW SPON HISTORY
"RTN","CHSBE005",28,0)
I CHNUM=4 D ^CHSBE040 G A1A ; SPON ROC
"RTN","CHSBE005",29,0)
I CHNUM=5 D ^CHSBE050 G A1A ; VIEW BENE
"RTN","CHSBE005",30,0)
I CHNUM=6 D ^CHSBE060 S CHNUM=5,CHOPT=" View Bene" G A1A ; EDIT BENE
"RTN","CHSBE005",31,0)
I CHNUM=7 D ^CHSBE070 G A1A ; VIEW BENE HIST
"RTN","CHSBE005",32,0)
I CHNUM=8 D ^CHSBE080 G A1A ; BENE ROC
"RTN","CHSBE005",33,0)
I CHNUM=9 D ^CHSBE090 G A1A ; ID CARD
"RTN","CHSBE005",34,0)
I CHNUM=10 D ^CHSBE100 G A1A ; DISENROLL DATA ;DEV023457 JAK 04-11-2017
"RTN","CHSBE005",35,0)
I CHNUM=11 D ^CHSBE110 G A1A ; SB BENE
"RTN","CHSBE005",36,0)
I CHNUM=12 D ^CHSBE120 G A1A ; CR
"RTN","CHSBE005",37,0)
I CHNUM=13 D ^CHSBE130 G A1A ; FILE UTILITIES
"RTN","CHSBE005",38,0)
I CHNUM=14 D ^CHSBE140 G A1A ; ASSIGN SECURITY
"RTN","CHSBE005",39,0)
I CHNUM=15 D ^CHSBE150 G A1A ; PRINT/QUEUE
"RTN","CHSBE005",40,0)
;
"RTN","CHSBE005",41,0)
END K A,BFN,BFN2,BN,CHBFN,CHBN,CHCD,CHCD1,CHCD2,CHCD2,CHCD3,CHCD15
"RTN","CHSBE005",42,0)
K CHDEF,CHDEFNUM,CHL,CHNEW,CHCD9,CHPD9,DFN
"RTN","CHSBE005",43,0)
K CHSN,CHSTA,CHSTADT,CHY,CT,DBM,DFN,DOB,DTM,DX,DY,F1,F2,I,L,QFLG
"RTN","CHSBE005",44,0)
K CHPROG,REA,REL,SSN,ST,STA,STR,X,Y,Z,IOZ,CHCD,CHCD1,CHPD,CHPD1
"RTN","CHSBE005",45,0)
K CHECH,CHD,CHBSTA,CHDD,CHEDIT,CHEREA,CHID
"RTN","CHSBE005",46,0)
K CHREA,CHST,CHSEC
"RTN","CHSBE005",47,0)
L Q
"RTN","CHSBE005",48,0)
NUMOPT S:Y=1 CHOPT=" View Sponsor"
"RTN","CHSBE005",49,0)
S:Y=2 CHOPT=" Edit Sponsor"
"RTN","CHSBE005",50,0)
S:Y=3 CHOPT=" View Sponsor History"
"RTN","CHSBE005",51,0)
S:Y=4 CHOPT=" Sponsor ROC"
"RTN","CHSBE005",52,0)
S:Y=5 CHOPT=" View Bene"
"RTN","CHSBE005",53,0)
S:Y=6 CHOPT=" Edit Bene"
"RTN","CHSBE005",54,0)
S:Y=7 CHOPT=" Edit Bene History"
"RTN","CHSBE005",55,0)
S:Y=8 CHOPT=" Bene ROC"
"RTN","CHSBE005",56,0)
S:Y=9 CHOPT=" ID Card"
"RTN","CHSBE005",57,0)
S:Y=10 CHOPT=" Disenroll data" ;DEV023457 JAK 04-11-2017
"RTN","CHSBE005",58,0)
S:Y=11 CHOPT=" SB Benes"
"RTN","CHSBE005",59,0)
S:Y=12 CHOPT=" Enroll Hist"
"RTN","CHSBE005",60,0)
S:Y=13 CHOPT=" File Utilities"
"RTN","CHSBE005",61,0)
S:Y=14 CHOPT=" Assign Security"
"RTN","CHSBE005",62,0)
Q
"RTN","CHSBE050")
0^11^B42096645
"RTN","CHSBE050",1,0)
CHSBE050 ;HAC/CAM;SB - VIEW BENE;Jan 08, 2019@10:10:24
"RTN","CHSBE050",2,0)
;;2.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE050",3,0)
;CPTS 12075 BY CAM
"RTN","CHSBE050",4,0)
;BUG022991-03-02 YJK 6/18/15
"RTN","CHSBE050",5,0)
; RTC791769 TGH 08-07-2018 - Rewrite Status to include Deceased and Re-enrolled
"RTN","CHSBE050",6,0)
S DX=1 F DY=2:1:18 X XY W @CHEOL
"RTN","CHSBE050",7,0)
I '$D(BFN) S CHOPT=" View Spon",CHNUM=1 Q
"RTN","CHSBE050",8,0)
S DY=3,DX=20 X XY
"RTN","CHSBE050",9,0)
W @CHBON,"SPINA BIFIDA BENEFICIAIRY VIEW SCREEN",@CHBOFF
"RTN","CHSBE050",10,0)
;
"RTN","CHSBE050",11,0)
S CHCD=$S($D(^AHCHVA(DFN,100,BFN,0)):^(0),1:"")
"RTN","CHSBE050",12,0)
S CHCD1=$S($D(^AHCHVA(DFN,100,BFN,1)):^(1),1:"")
"RTN","CHSBE050",13,0)
S CHCD10=$S($D(^AHCHVA(DFN,100,BFN,10)):^(10),1:"")
"RTN","CHSBE050",14,0)
S CHCD15=$S($D(^AHCHVA(DFN,100,BFN,15)):^(15),1:"")
"RTN","CHSBE050",15,0)
S CHCD16=$S($D(^AHCHVA(DFN,100,BFN,16)):^(16),1:"")
"RTN","CHSBE050",16,0)
;
"RTN","CHSBE050",17,0)
D STAT115 ;BUG022991-03-02 YJK 6/18/15
"RTN","CHSBE050",18,0)
D NAME,SBIND,ADDRESS,CVAIND,SSN,DOB,DOD,PHONE
"RTN","CHSBE050",19,0)
D GENDER,RELA,AWARD,ID,GNAME,CVAROC,GADD,SBROC,GPHONE
"RTN","CHSBE050",20,0)
D DISENLTR,REENLTR,SBSTATUS ;BUG022991-03-02 YJK 6/18/15
"RTN","CHSBE050",21,0)
Q
"RTN","CHSBE050",22,0)
;
"RTN","CHSBE050",23,0)
;
"RTN","CHSBE050",24,0)
NAME S X=""
"RTN","CHSBE050",25,0)
S:$P(CHCD,U)'="" X=$P($P(CHCD,U),",",2)_" "_$P($P(CHCD,U),",")
"RTN","CHSBE050",26,0)
S DY=5,DX=11 X XY W @CHBON,"NAME: ",@CHBOFF,X
"RTN","CHSBE050",27,0)
Q
"RTN","CHSBE050",28,0)
SBIND S X="NO" S:$D(^AHCHVA("SB",DFN,BFN)) X="YES"
"RTN","CHSBE050",29,0)
S DY=5,DX=50 X XY W @CHBON,"SB: ",@CHBOFF,X
"RTN","CHSBE050",30,0)
Q
"RTN","CHSBE050",31,0)
ADDRESS D CLEAR1
"RTN","CHSBE050",32,0)
S (CH1A,CH2A,CH3A,CH4A)=""
"RTN","CHSBE050",33,0)
S CH1A=$P(CHCD1,U)
"RTN","CHSBE050",34,0)
S DY=6,DX=8 X XY W @CHBON,"ADDRESS: ",@CHBOFF,$E(CH1A,1,30)
"RTN","CHSBE050",35,0)
A2 D CLEAR2
"RTN","CHSBE050",36,0)
S CH2A=$P(CHCD1,U,2)
"RTN","CHSBE050",37,0)
S DY=7,DX=18 X XY W $E(CH2A,1,30)
"RTN","CHSBE050",38,0)
A3 D CLEAR3,CLEAR4
"RTN","CHSBE050",39,0)
I $P(CHCD1,U,11)=1 D Q
"RTN","CHSBE050",40,0)
.S X=$P(CHCD1,U,12)
"RTN","CHSBE050",41,0)
.S X1=$P(CHCD1,U,13),X2="" D:X1
"RTN","CHSBE050",42,0)
..Q:'$D(^DIC(5,X1,0))
"RTN","CHSBE050",43,0)
..S X2=$P(^DIC(5,X1,0),U,1) Q
"RTN","CHSBE050",44,0)
.I '$D(X2) S X2="",$P(CHCD1,U,13)=""
"RTN","CHSBE050",45,0)
.S DY=8,DX=18 X XY W $E(X,1,30)
"RTN","CHSBE050",46,0)
.S DY=9,DX=18 X XY W $E(X2,1,30)
"RTN","CHSBE050",47,0)
S X=$P(CHCD1,U,3) ;DOMESTIC
"RTN","CHSBE050",48,0)
S X1=$S($D(^DIC(5,+$P(CHCD1,U,4),0)):$P(^(0),U,2),1:"")
"RTN","CHSBE050",49,0)
S X2=$P(CHCD1,U,5) D
"RTN","CHSBE050",50,0)
.I X2?9N S X3=$E(X2,1,5)_"-"_$E(X2,6,9) Q
"RTN","CHSBE050",51,0)
.S X3=X2
"RTN","CHSBE050",52,0)
S X4=$P(CHCD1,U,13),X5="" D:X4
"RTN","CHSBE050",53,0)
.Q:'$D(^DIC(5,X4,0))
"RTN","CHSBE050",54,0)
.S X5=$P(^DIC(5,X4,0),U,1) Q
"RTN","CHSBE050",55,0)
S DY=8,DX=18 X XY W $E(X,1,25) W:X1'="" ", "
"RTN","CHSBE050",56,0)
W $E(X1,1,20) W:X3'="" " " W X3
"RTN","CHSBE050",57,0)
S DY=9,DX=18 X XY W $E(X5,1,10)
"RTN","CHSBE050",58,0)
;D ADDRESS^CHSBEU02
"RTN","CHSBE050",59,0)
;S DY=6,DX=8 X XY W @CHBON,"ADDRESS: ",@CHBOFF,CH1A
"RTN","CHSBE050",60,0)
;S DY=7,DX=18 X XY W CH2A
"RTN","CHSBE050",61,0)
;S DY=8,DX=18 X XY W CH3A
"RTN","CHSBE050",62,0)
;S DY=9,DX=18 X XY W CH4A
"RTN","CHSBE050",63,0)
Q
"RTN","CHSBE050",64,0)
CVAIND S X="NO" I $D(^AHCHVA(DFN,100,BFN,109)) S X="YES"
"RTN","CHSBE050",65,0)
S DY=6,DX=50 X XY W @CHBON,"CHAMPVA: ",@CHBOFF,X
"RTN","CHSBE050",66,0)
Q
"RTN","CHSBE050",67,0)
SSN S X=$P(CHCD,U,9)
"RTN","CHSBE050",68,0)
S:X?9N X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,9)
"RTN","CHSBE050",69,0)
S DY=7,DX=50 X XY W @CHBON,"SSN: ",@CHBOFF,X
"RTN","CHSBE050",70,0)
Q
"RTN","CHSBE050",71,0)
DOB S X=$P(CHCD,U,3)
"RTN","CHSBE050",72,0)
S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHSBE050",73,0)
S DY=8,DX=50 X XY W @CHBON,"DOB: ",@CHBOFF,X
"RTN","CHSBE050",74,0)
Q
"RTN","CHSBE050",75,0)
DOD S X=$P(CHCD,U,6)
"RTN","CHSBE050",76,0)
S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHSBE050",77,0)
S DY=9,DX=50 X XY W @CHBON,"DOD: ",@CHBOFF,X
"RTN","CHSBE050",78,0)
Q
"RTN","CHSBE050",79,0)
PHONE S X=$P(CHCD1,U,6)
"RTN","CHSBE050",80,0)
I X'="" S:'$P(CHCD1,U,11) X="("_$E(X,1,3)_") "_$E(X,4,6)_"-"_$E(X,7,10)
"RTN","CHSBE050",81,0)
S DY=10,DX=10 X XY W @CHBON,"PHONE: ",@CHBOFF,X
"RTN","CHSBE050",82,0)
Q
"RTN","CHSBE050",83,0)
GENDER S X=$P(CHCD,U,2) S:X="F" X="FEMALE" S:X="M" X="MALE"
"RTN","CHSBE050",84,0)
S DY=10,DX=50 X XY W @CHBON,"GENDER: ",@CHBOFF,X
"RTN","CHSBE050",85,0)
Q
"RTN","CHSBE050",86,0)
RELA S X=""
"RTN","CHSBE050",87,0)
S:$P(CHCD,U,2)="M" X="SON" S:$P(CHCD,U,2)="F" X="DAUGHTER"
"RTN","CHSBE050",88,0)
S DY=11,DX=18 X XY W " "
"RTN","CHSBE050",89,0)
S DY=11,DX=3 X XY W @CHBON,"RELATIONSHIP: ",@CHBOFF,X
"RTN","CHSBE050",90,0)
Q
"RTN","CHSBE050",91,0)
AWARD S X=$P(CHCD15,U,2)
"RTN","CHSBE050",92,0)
S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHSBE050",93,0)
S DY=11,DX=50 X XY W @CHBON,"AWARD LETTER: ",@CHBOFF,X
"RTN","CHSBE050",94,0)
Q
"RTN","CHSBE050",95,0)
ID ;CODE THIS PORTION!!
"RTN","CHSBE050",96,0)
S CHCD10=$S($D(^AHCHVA(DFN,100,BFN,10)):^(10),1:"") ;SKD, 7-7-05
"RTN","CHSBE050",97,0)
S X=$P(CHCD10,U,2)
"RTN","CHSBE050",98,0)
S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHSBE050",99,0)
S DY=12,DX=50 X XY W @CHBON,"ID CARD ISSUED: ",@CHBOFF,X
"RTN","CHSBE050",100,0)
Q
"RTN","CHSBE050",101,0)
GNAME S X=""
"RTN","CHSBE050",102,0)
S:$P(CHCD15,U)'="" X=$P($P(CHCD15,U),",",2)_" "_$P($P(CHCD15,U),",")
"RTN","CHSBE050",103,0)
S DY=13,DX=1 X XY W @CHBON,"GUARD/FID NAME: ",@CHBOFF,X
"RTN","CHSBE050",104,0)
Q
"RTN","CHSBE050",105,0)
CVAROC S X="NO" S:$D(^AHCHVA(DFN,100,BFN,106)) X="YES"
"RTN","CHSBE050",106,0)
S DY=13,DX=50 X XY W @CHBON,"CHAMPVA ROC: ",@CHBOFF,X
"RTN","CHSBE050",107,0)
Q
"RTN","CHSBE050",108,0)
GADD D CLEAR1G
"RTN","CHSBE050",109,0)
S (CH1B,CH2B,CH3B,CH4B)=""
"RTN","CHSBE050",110,0)
S CH1B=$P(CHCD16,U)
"RTN","CHSBE050",111,0)
S DY=14,DX=1 X XY W @CHBON,"GUARD/FID ADDR: ",@CHBOFF,$E(CH1B,1,30)
"RTN","CHSBE050",112,0)
GA2 D CLEAR2G
"RTN","CHSBE050",113,0)
S CH2B=$P(CHCD16,U,2)
"RTN","CHSBE050",114,0)
S DY=15,DX=18 X XY W $E(CH2B,1,30)
"RTN","CHSBE050",115,0)
GA3 D CLEAR3G,CLEAR4G
"RTN","CHSBE050",116,0)
I $P(CHCD16,U,11)=1 D Q
"RTN","CHSBE050",117,0)
.S X=$P(CHCD16,U,12)
"RTN","CHSBE050",118,0)
.S X1=$P(CHCD16,U,13),X2="" D:X1
"RTN","CHSBE050",119,0)
..Q:'$D(^DIC(5,X1,0))
"RTN","CHSBE050",120,0)
..S X2=$P(^DIC(5,X1,0),U,1) Q
"RTN","CHSBE050",121,0)
.I '$D(X2) S X2="",$P(CHCD16,U,13)=""
"RTN","CHSBE050",122,0)
.S DY=16,DX=18 X XY W $E(X,1,30)
"RTN","CHSBE050",123,0)
.S DY=17,DX=18 X XY W $E(X2,1,30)
"RTN","CHSBE050",124,0)
S X=$P(CHCD16,U,3) ;DOMESTIC
"RTN","CHSBE050",125,0)
S X1=$S($D(^DIC(5,+$P(CHCD16,U,4),0)):$P(^(0),U,2),1:"")
"RTN","CHSBE050",126,0)
S X2=$P(CHCD16,U,5) D
"RTN","CHSBE050",127,0)
.I X2?9N S X3=$E(X2,1,5)_"-"_$E(X2,6,9) Q
"RTN","CHSBE050",128,0)
.S X3=X2
"RTN","CHSBE050",129,0)
S X4=$P(CHCD16,U,13),X5="" D:X4
"RTN","CHSBE050",130,0)
.Q:'$D(^DIC(5,X4,0))
"RTN","CHSBE050",131,0)
.S X5=$P(^DIC(5,X4,0),U,1) Q
"RTN","CHSBE050",132,0)
S DY=16,DX=18 X XY W $E(X,1,25) W:X1'="" ", "
"RTN","CHSBE050",133,0)
W $E(X1,1,20) W:X3'="" " " W X3
"RTN","CHSBE050",134,0)
S DY=17,DX=18 X XY W $E(X5,1,10)
"RTN","CHSBE050",135,0)
;S (CH1B,CH2B,CH3B,CH4B)=""
"RTN","CHSBE050",136,0)
;D ADDRESS^CHSBEU03
"RTN","CHSBE050",137,0)
;S DY=14,DX=1 X XY W @CHBON,"GUARD/FID ADDR: ",@CHBOFF,CH1B
"RTN","CHSBE050",138,0)
;S DY=15,DX=18 X XY W CH2B
"RTN","CHSBE050",139,0)
;S DY=16,DX=18 X XY W CH3B
"RTN","CHSBE050",140,0)
;S DY=17,DX=18 X XY W CH4B
"RTN","CHSBE050",141,0)
Q
"RTN","CHSBE050",142,0)
SBROC S X="NO" S:$D(^AHCHVA(DFN,100,BFN,116)) X="YES"
"RTN","CHSBE050",143,0)
S DY=14,DX=50 X XY W @CHBON,"SB ROC: ",@CHBOFF,X
"RTN","CHSBE050",144,0)
Q
"RTN","CHSBE050",145,0)
DISENLTR ;BUG022991-03-02 YJK 6/18/15 ;ST DT DOC DATE 554801.1115,.05
"RTN","CHSBE050",146,0)
S X=ENRDOC
"RTN","CHSBE050",147,0)
S DY=16,DX=50 X XY W @CHBON,"DISENROLLMENT LTR: ",@CHBOFF
"RTN","CHSBE050",148,0)
S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHSBE050",149,0)
W X W:X="" " "
"RTN","CHSBE050",150,0)
Q
"RTN","CHSBE050",151,0)
REENLTR ;BUG022991-03-02 YJK 6/18/15
"RTN","CHSBE050",152,0)
S X=REENRDOC
"RTN","CHSBE050",153,0)
S DY=17,DX=50 X XY W @CHBON,"RE-ENROLLMENT LTR: ",@CHBOFF
"RTN","CHSBE050",154,0)
S:X'="" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","CHSBE050",155,0)
W X W:X="" " "
"RTN","CHSBE050",156,0)
Q
"RTN","CHSBE050",157,0)
SBSTATUS ;BUG022991-03-02 YJK 6/18/15
"RTN","CHSBE050",158,0)
S DY=18,DX=50 X XY W @CHBON,"SB ENROLL STATUS: ",@CHBOFF
"RTN","CHSBE050",159,0)
; RTC791769 TGH 08-07-2018 - Rewrite Status to include Deceased and Re-enrolled
"RTN","CHSBE050",160,0)
;W $S(SBSTAT="1":"DISENROLLED",1:"ENROLLED")
"RTN","CHSBE050",161,0)
N SBS
"RTN","CHSBE050",162,0)
S SBS=$$SBSDET
"RTN","CHSBE050",163,0)
W SBS
"RTN","CHSBE050",164,0)
Q
"RTN","CHSBE050",165,0)
SBSDET() ;Determine SBS value for Screen
"RTN","CHSBE050",166,0)
I $P(CHCD,U,6)'="" S SBS="DECEASED"
"RTN","CHSBE050",167,0)
I $G(SBS)="",SBSTAT=1 S SBS="DISENROLLED"
"RTN","CHSBE050",168,0)
I $G(SBS)="" D
"RTN","CHSBE050",169,0)
. S SBS(1)=$O(^AHCHVA(DFN,100,BFN,115,"A"),-1)
"RTN","CHSBE050",170,0)
. I SBS(1)'="" S SBS(2)=$P(^AHCHVA(DFN,100,BFN,115,SBS(1),0),U,1,2)
"RTN","CHSBE050",171,0)
. I $G(SBS(2))'="",SBS(2)="6^0" S SBS="RE-ENROLLED" Q
"RTN","CHSBE050",172,0)
. S SBS="ENROLLED"
"RTN","CHSBE050",173,0)
Q SBS
"RTN","CHSBE050",174,0)
GPHONE S X=$P(CHCD16,U,6)
"RTN","CHSBE050",175,0)
I X'="" S:'$P(CHCD16,U,11) X="("_$E(X,1,3)_")-"_$E(X,4,6)_"-"_$E(X,7,10)
"RTN","CHSBE050",176,0)
S DY=18,DX=1 X XY W @CHBON,"GUARD/FID PHON: ",@CHBOFF,X
"RTN","CHSBE050",177,0)
S CHOPT=" View Spon",CHNUM=1
"RTN","CHSBE050",178,0)
Q
"RTN","CHSBE050",179,0)
STAT115 ;BUG022991-03-02 YJK 6/18/15
"RTN","CHSBE050",180,0)
S ENRDOC="",SBSTAT="",REENRDOC="",REC115=""
"RTN","CHSBE050",181,0)
S K=9999999,K=$O(^AHCHVA(DFN,100,BFN,115,K),-1) Q:'K
"RTN","CHSBE050",182,0)
S REC115=^AHCHVA(DFN,100,BFN,115,K,0)
"RTN","CHSBE050",183,0)
Q:REC115=""
"RTN","CHSBE050",184,0)
S ENRDOC=$P(REC115,"^",5) ;DISENROLLMENT DOCUMENT DATE
"RTN","CHSBE050",185,0)
S SBSTAT=$P(REC115,"^",2) ;TYPE: 0=ENROLLED; 1=DISENROLLED
"RTN","CHSBE050",186,0)
S REENRDOC=$P(REC115,"^",10) ;REENROLLMENT DOCUMENT DATE (ED DT DOC DT)
"RTN","CHSBE050",187,0)
Q
"RTN","CHSBE050",188,0)
CLEAR1 S DY=6,DX=18 X XY W " " Q
"RTN","CHSBE050",189,0)
CLEAR2 S DY=7,DX=18 X XY W " " Q
"RTN","CHSBE050",190,0)
CLEAR3 S DY=8,DX=18 X XY W " " Q
"RTN","CHSBE050",191,0)
CLEAR4 S DY=9,DX=18 X XY W " " Q
"RTN","CHSBE050",192,0)
CLEAR1G S DY=14,DX=18 X XY W " " Q
"RTN","CHSBE050",193,0)
CLEAR2G S DY=15,DX=18 X XY W " " Q
"RTN","CHSBE050",194,0)
CLEAR3G S DY=16,DX=18 X XY W " " Q
"RTN","CHSBE050",195,0)
CLEAR4G S DY=17,DX=18 X XY W " " Q
"RTN","CHSBE062")
0^16^B31249615
"RTN","CHSBE062",1,0)
CHSBE062 ;HAC/CAM;SB - EDIT BENE SAVE FUNCTION;Jan 08, 2019@10:11:04
"RTN","CHSBE062",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE062",3,0)
;V1.0
"RTN","CHSBE062",4,0)
;CPTS 12075 BY CAM
"RTN","CHSBE062",5,0)
;DEV17932 - CKN 5/17/13 - Trigger update to MVI
"RTN","CHSBE062",6,0)
;DEV22528-JAH/CEP-update MVI trigger for address changes
"RTN","CHSBE062",7,0)
;RTC791768 - TGH - 08/07/2018 - Storing Deceased Data
"RTN","CHSBE062",8,0)
SAVE S X="NOW",%DT="T" D ^%DT S CHDT=Y K %DT
"RTN","CHSBE062",9,0)
S1 G:CHCD=CHPD S2
"RTN","CHSBE062",10,0)
;name
"RTN","CHSBE062",11,0)
I $P(CHCD,U)'=$P(CHPD,U) D
"RTN","CHSBE062",12,0)
.K:$P(CHPD,U)'="" ^AHCHVA(DFN,100,"B",$P(CHPD,U),BFN)
"RTN","CHSBE062",13,0)
.K:$P(CHPD,U)'="" ^AHCHVA("F",$P(CHPD,U),DFN,BFN)
"RTN","CHSBE062",14,0)
.S:$P(CHCD,U)'="" ^AHCHVA(DFN,100,"B",$P(CHCD,U),BFN)=""
"RTN","CHSBE062",15,0)
.S:$P(CHCD,U)'="" ^AHCHVA("F",$P(CHCD,U),DFN,BFN)=""
"RTN","CHSBE062",16,0)
;ssn
"RTN","CHSBE062",17,0)
I $P(CHCD,U,9)'=$P(CHPD,U,9) D
"RTN","CHSBE062",18,0)
.K:$P(CHPD,U,9)'="" ^AHCHVA("G",$P(CHPD,U,9),DFN,BFN)
"RTN","CHSBE062",19,0)
.S:$P(CHCD,U,9)'="" ^AHCHVA("G",$P(CHCD,U,9),DFN,BFN)=""
"RTN","CHSBE062",20,0)
.S $P(^AHCHVA(DFN,100,BFN,5),U,1)=$P(CHCD,U,9)
"RTN","CHSBE062",21,0)
.;D STBATCH this is is CHMEAE8
"RTN","CHSBE062",22,0)
S:$P(CHCD,U,6)'="" $P(^AHCHVA(DFN,100,BFN,10),U,4)=$P(CHCD,U,6)
"RTN","CHSBE062",23,0)
F I=1:1:35 S:$P(CHCD,U,I)'=$P(CHPD,U,I) $P(^AHCHVA(DFN,100,BFN,0),U,I)=$P(CHCD,U,I)
"RTN","CHSBE062",24,0)
F I=1:1:35 S:$P(CHCD,U,I)'=$P(CHPD,U,I) $P(^AHCHVA(DFN,101,CHDT,100,BFN,0),U,I)=$P(CHCD,U,I) S:($P(CHCD,U,I)="")&($P(CHPD,U,I)'="") $P(^(0),U,I)="@"_$P(CHPD,U,I)
"RTN","CHSBE062",25,0)
S $P(^AHCHVA(DFN,100,BFN,99),U)=CHDT,$P(^(99),U,2)=DUZ,$P(^(99),U,3)="SB BENEFICIARY EDIT"
"RTN","CHSBE062",26,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_"^SB BENEFICIARY EDIT"
"RTN","CHSBE062",27,0)
S ^AHCHVA("AC",CHDT,DFN,BFN)=""
"RTN","CHSBE062",28,0)
;RTC791768 - TGH - 08/07/2018 - Storing Deceased Data in 11 level of 100 and 101
"RTN","CHSBE062",29,0)
I $P(CHCD,U,6)'=$P(CHPD,U,6) D DECSET
"RTN","CHSBE062",30,0)
S2 G:CHCD1=CHPD1 S3
"RTN","CHSBE062",31,0)
F I=1:1:13 S:$P(CHCD1,U,I)'=$P(CHPD1,U,I) $P(^AHCHVA(DFN,100,BFN,1),U,I)=$P(CHCD1,U,I)
"RTN","CHSBE062",32,0)
F I=1:1:13 S:$P(CHCD1,U,I)'=$P(CHPD1,U,I) $P(^AHCHVA(DFN,101,CHDT,100,BFN,1),U,I)=$P(CHCD1,U,I) S:($P(CHCD1,U,I)="")&($P(CHPD1,U,I)'="") $P(^(1),U,I)="@"_$P(CHPD1,U,I)
"RTN","CHSBE062",33,0)
S CHCOR=$P(^AHCHVA(DFN,100,BFN,1),U,10)
"RTN","CHSBE062",34,0)
S:CHCOR'=1 $P(^AHCHVA(DFN,100,BFN,1),U,10)=1
"RTN","CHSBE062",35,0)
S $P(^AHCHVA(DFN,100,BFN,99),U)=CHDT,$P(^(99),U,2)=DUZ,$P(^(99),U,3)="SB BENEFICIARY EDIT"
"RTN","CHSBE062",36,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_"^SB BENEFICIARY EDIT"
"RTN","CHSBE062",37,0)
S ^AHCHVA("AC",CHDT,DFN,BFN)=""
"RTN","CHSBE062",38,0)
S3 G:CHCD15=CHPD15 S4
"RTN","CHSBE062",39,0)
F I=1:1:13 S:$P(CHCD15,U,I)'=$P(CHPD15,U,I) $P(^AHCHVA(DFN,100,BFN,15),U,I)=$P(CHCD15,U,I)
"RTN","CHSBE062",40,0)
F I=1:1:13 S:$P(CHCD15,U,I)'=$P(CHPD15,U,I) $P(^AHCHVA(DFN,101,CHDT,100,BFN,15),U,I)=$P(CHCD15,U,I) S:($P(CHCD15,U,I)="")&($P(CHPD15,U,I)'="") $P(^(15),U,I)="@"_$P(CHPD15,U,I)
"RTN","CHSBE062",41,0)
S $P(^AHCHVA(DFN,100,BFN,99),U)=CHDT,$P(^(99),U,2)=DUZ,$P(^(99),U,3)="SB BENEFICIARY EDIT"
"RTN","CHSBE062",42,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_"^SB BENEFICIARY EDIT"
"RTN","CHSBE062",43,0)
S ^AHCHVA("AC",CHDT,DFN,BFN)=""
"RTN","CHSBE062",44,0)
S4 G:CHCD16=CHPD16 RESET
"RTN","CHSBE062",45,0)
F I=1:1:13 S:$P(CHCD16,U,I)'=$P(CHPD16,U,I) $P(^AHCHVA(DFN,100,BFN,16),U,I)=$P(CHCD16,U,I)
"RTN","CHSBE062",46,0)
F I=1:1:13 S:$P(CHCD16,U,I)'=$P(CHPD16,U,I) $P(^AHCHVA(DFN,101,CHDT,100,BFN,16),U,I)=$P(CHCD16,U,I) S:($P(CHCD16,U,I)="")&($P(CHPD16,U,I)'="") $P(^(16),U,I)="@"_$P(CHPD16,U,I)
"RTN","CHSBE062",47,0)
S CHCOR=$P(^AHCHVA(DFN,100,BFN,16),U,10)
"RTN","CHSBE062",48,0)
S:CHCOR'=1 $P(^AHCHVA(DFN,100,BFN,16),U,10)=1
"RTN","CHSBE062",49,0)
S $P(^AHCHVA(DFN,100,BFN,99),U)=CHDT,$P(^(99),U,2)=DUZ,$P(^(99),U,3)="SB BENEFICIARY EDIT"
"RTN","CHSBE062",50,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_"^SB BENEFICIARY EDIT"
"RTN","CHSBE062",51,0)
S ^AHCHVA("AC",CHDT,DFN,BFN)=""
"RTN","CHSBE062",52,0)
RESET ;
"RTN","CHSBE062",53,0)
; MVI event moved here to catch address changes as well as general identity traits
"RTN","CHSBE062",54,0)
; also updated to make call to re-usable change check and update
"RTN","CHSBE062",55,0)
D MVIUPDT^CHMEAE8
"RTN","CHSBE062",56,0)
;
"RTN","CHSBE062",57,0)
S (CHCD,CHPD)=$S($D(^AHCHVA(DFN,100,BFN,0)):^(0),1:"")
"RTN","CHSBE062",58,0)
S (CHCD1,CHPD1)=$S($D(^AHCHVA(DFN,100,BFN,1)):^(1),1:"")
"RTN","CHSBE062",59,0)
S (CHCD15,CHPD15)=$S($D(^AHCHVA(DFN,100,BFN,15)):^(15),1:"")
"RTN","CHSBE062",60,0)
S (CHCD16,CHPD16)=$S($D(^AHCHVA(DFN,100,BFN,16)):^(16),1:"")
"RTN","CHSBE062",61,0)
D BOTTOM^CHSBEU01
"RTN","CHSBE062",62,0)
Q
"RTN","CHSBE062",63,0)
END Q
"RTN","CHSBE062",64,0)
DECSET ;RTC791768 - TGH - 08/07/2018 - Storing Deceased Data in 11 level of 100 and 101
"RTN","CHSBE062",65,0)
N NEWSTAT,CNTR
"RTN","CHSBE062",66,0)
; When date of death exists
"RTN","CHSBE062",67,0)
I $P(CHCD,U,6)'="" D
"RTN","CHSBE062",68,0)
.S NEWSTAT="DEC"
"RTN","CHSBE062",69,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,1)=NEWSTAT ;BENE STATUS
"RTN","CHSBE062",70,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,2)=$P(CHDT,".",1) ;STATUS DATE
"RTN","CHSBE062",71,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,3)=2 ;INELIGIBLE REASON - DECEASED
"RTN","CHSBE062",72,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,4)=""
"RTN","CHSBE062",73,0)
.;HISTORY
"RTN","CHSBE062",74,0)
.S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_U_"DECEASED DATE"
"RTN","CHSBE062",75,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,1)=NEWSTAT ;STATUS
"RTN","CHSBE062",76,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,2)=$P(CHDT,".",1) ;STATUS DATE
"RTN","CHSBE062",77,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,3)=2 ;INELIGIBLE REASON - DECEASED
"RTN","CHSBE062",78,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,4)="@"_NEWSTAT ;ELIGIBLE REASON
"RTN","CHSBE062",79,0)
;
"RTN","CHSBE062",80,0)
;When date of death is null entry will be Deceased Date Deleted
"RTN","CHSBE062",81,0)
I $P(CHCD,U,6)="" D
"RTN","CHSBE062",82,0)
.S NEWSTAT="DEC"
"RTN","CHSBE062",83,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,1)=NEWSTAT ;BENE STATUS
"RTN","CHSBE062",84,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,2)=$P(CHDT,".",1) ;STATUS DATE
"RTN","CHSBE062",85,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,3)=2 ;INELIGIBLE REASON - DECEASED
"RTN","CHSBE062",86,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,4)=""
"RTN","CHSBE062",87,0)
.;HISTORY
"RTN","CHSBE062",88,0)
.S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_U_"DECEASED DATE DELETED"
"RTN","CHSBE062",89,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,1)=NEWSTAT ;STATUS
"RTN","CHSBE062",90,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,2)=$P(CHDT,".",1) ;STATUS DATE
"RTN","CHSBE062",91,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,3)=2 ;INELIGIBLE REASON - DECEASED
"RTN","CHSBE062",92,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,4)="@"_NEWSTAT ;ELIGIBLE REASON
"RTN","CHSBE062",93,0)
.;Also reset History to show status prior to entering Deceased Date
"RTN","CHSBE062",94,0)
.;Start with Enrolled, then if 115 level exists reset to Re-enrolled or Disenrolled
"RTN","CHSBE062",95,0)
.S NEWSTAT="ENR"
"RTN","CHSBE062",96,0)
.I $D(^AHCHVA(DFN,100,BFN,115)) S CNTR=$O(^AHCHVA(DFN,100,BFN,115,999),-1)
"RTN","CHSBE062",97,0)
.I '$G(CNTR) S NEWSTAT=$S($P(^AHCHVA(DFN,100,BFN,115,CNTR,0),U,8):"REE",1:"DIS")
"RTN","CHSBE062",98,0)
.;
"RTN","CHSBE062",99,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,1)=NEWSTAT ;BENE STATUS
"RTN","CHSBE062",100,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,2)=$P(CHDT,".",1) ;STATUS DATE
"RTN","CHSBE062",101,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,3)=1 ;INELIGIBLE REASON
"RTN","CHSBE062",102,0)
.S $P(^AHCHVA(DFN,100,BFN,11),U,4)=""
"RTN","CHSBE062",103,0)
.;HISTORY
"RTN","CHSBE062",104,0)
.S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_U_$S(NEWSTAT="ENR":"ENROLLED",NEWSTAT="DIS":"DISENROLLED",1:"RE-ENROLLED")
"RTN","CHSBE062",105,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,1)=NEWSTAT ;STATUS
"RTN","CHSBE062",106,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,2)=$P(CHDT,".",1) ;STATUS DATE
"RTN","CHSBE062",107,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,3)=1 ;INELIGIBLE REASON
"RTN","CHSBE062",108,0)
.S $P(^AHCHVA(DFN,101,CHDT,100,BFN,11),U,4)="@"_NEWSTAT ;ELIGIBLE REASON
"RTN","CHSBE062",109,0)
Q
"RTN","CHSBE068")
0^19^B30778027
"RTN","CHSBE068",1,0)
CHSBE068 ;HAC/CAM;SB - EDIT BENE SSN,DOB,DOD,GENDER,AWARD;Jan 08, 2019@10:12:10
"RTN","CHSBE068",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE068",3,0)
;V1.0
"RTN","CHSBE068",4,0)
;CPTS 12075 BY CAM
"RTN","CHSBE068",5,0)
;DEFECT 855725 DYO 11/01/18 Fix invalid Award letter Date
"RTN","CHSBE068",6,0)
;
"RTN","CHSBE068",7,0)
SSN S DY=7,DX=50 X XY W @CHBON,@CHREVON,"SSN:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",8,0)
S DY=20,DX=1 X XY W @CHEOL
"RTN","CHSBE068",9,0)
S DY=20,DX=12 X XY W @CHBON,@CHREVON,"SSN:",@CHBOFF,@CHREVOFF," "
"RTN","CHSBE068",10,0)
S DY=21,DX=12 X XY W @CHEOL,@CHBON,"Enter the bene's SSN: ",@CHBOFF
"RTN","CHSBE068",11,0)
D CSBRS^CHSC2
"RTN","CHSBE068",12,0)
I $D(DFOUT)!($D(DDOUT))!($D(DUOUT)) D CLEARAL,SSN^CHSBE050 Q
"RTN","CHSBE068",13,0)
I $D(DQOUT) D G SSN
"RTN","CHSBE068",14,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",15,0)
.W "Social Security Number must be a unique 9 digit number."
"RTN","CHSBE068",16,0)
I Y="" I $P(CHCD,U,9)'="" G SSN1
"RTN","CHSBE068",17,0)
I Y="" D G SSN
"RTN","CHSBE068",18,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",19,0)
.W "The Social Security Number is mandatory."
"RTN","CHSBE068",20,0)
.W " You may not proceed without it."
"RTN","CHSBE068",21,0)
I Y?3N1"-"2N1"-"4N S Y=$E(Y,1,3)_$E(Y,5,6)_$E(Y,8,11)
"RTN","CHSBE068",22,0)
I Y'?9N D G SSN
"RTN","CHSBE068",23,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",24,0)
.W "Social Security Number must be a unique 9 digit number."
"RTN","CHSBE068",25,0)
I $D(^AHCHVA("G",Y))!($D(^AHCHVA("C",Y))) D G SSN
"RTN","CHSBE068",26,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",27,0)
.W *7,@CHBON,"There is already a " W:$D(^AHCHVA("C",Y)) "sponsor "
"RTN","CHSBE068",28,0)
.W:$D(^AHCHVA("G",Y)) "beneficiary " W "with that SSN!",@CHBOFF
"RTN","CHSBE068",29,0)
S $P(CHCD,U,9)=Y
"RTN","CHSBE068",30,0)
SSN1 S DY=7,DX=54 X XY W @CHEOL
"RTN","CHSBE068",31,0)
D SSN^CHSBE050
"RTN","CHSBE068",32,0)
D CLEARAL
"RTN","CHSBE068",33,0)
Q
"RTN","CHSBE068",34,0)
;
"RTN","CHSBE068",35,0)
DOB S DY=8,DX=50 X XY W @CHBON,@CHREVON,"DOB:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",36,0)
S DY=20,DX=1 X XY W @CHEOL
"RTN","CHSBE068",37,0)
S DY=20,DX=12 X XY W @CHEOL,@CHBON,@CHREVON,"DOB:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",38,0)
S DY=21,DX=12 X XY W @CHEOL
"RTN","CHSBE068",39,0)
W @CHBON,"Enter the bene's date of birth: ",@CHBOFF
"RTN","CHSBE068",40,0)
D CSBRS^CHSC2
"RTN","CHSBE068",41,0)
I $D(DFOUT)!($D(DDOUT))!($D(DUOUT)) D CLEARAL,DOB^CHSBE050 Q
"RTN","CHSBE068",42,0)
I $D(DQOUT) D G DOB
"RTN","CHSBE068",43,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",44,0)
.W "Enter a Date of Birth in usual FileMan format."
"RTN","CHSBE068",45,0)
I Y="@" D G DOB
"RTN","CHSBE068",46,0)
.S $P(CHCD,U,3)=""
"RTN","CHSBE068",47,0)
.S DY=8,DX=54 X XY W @CHEOL
"RTN","CHSBE068",48,0)
.D DOB^CHSBE050
"RTN","CHSBE068",49,0)
I Y="" I $P(CHCD,U,3)'="" G DOB1
"RTN","CHSBE068",50,0)
I Y="" D G DOB
"RTN","CHSBE068",51,0)
.S DY=20,DX=12 X XY W @CHEOL
"RTN","CHSBE068",52,0)
.W "The Date of Birth is mandatory."
"RTN","CHSBE068",53,0)
.W " You may not proceed without it."
"RTN","CHSBE068",54,0)
S X=Y K %DT S %DT="EQ",%DT(0)=-DT D ^%DT K %DT
"RTN","CHSBE068",55,0)
I Y=-1 W !,"The Date of Birth must be in the past!" G DOB
"RTN","CHSBE068",56,0)
S $P(CHCD,U,3)=Y
"RTN","CHSBE068",57,0)
DOB1 S DY=8,DX=54 X XY W @CHEOL
"RTN","CHSBE068",58,0)
D DOB^CHSBE050
"RTN","CHSBE068",59,0)
D CLEARAL
"RTN","CHSBE068",60,0)
Q
"RTN","CHSBE068",61,0)
DOD S DY=9,DX=50 X XY W @CHBON,@CHREVON,"DOD:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",62,0)
S DY=20,DX=1 X XY W @CHEOL
"RTN","CHSBE068",63,0)
S DY=20,DX=12 X XY W @CHEOL,@CHBON,@CHREVON,"DOD:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",64,0)
S DY=21,DX=12 X XY W @CHEOL
"RTN","CHSBE068",65,0)
W @CHBON,"Enter the bene's date of death: ",@CHBOFF
"RTN","CHSBE068",66,0)
D CSBRS^CHSC2
"RTN","CHSBE068",67,0)
I $D(DFOUT)!($D(DDOUT))!($D(DUOUT)) D CLEARAL,DOD^CHSBE050 Q
"RTN","CHSBE068",68,0)
I $D(DQOUT) D G DOD
"RTN","CHSBE068",69,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",70,0)
.W "Enter a date of death in usual FileMan format."
"RTN","CHSBE068",71,0)
I Y="@" D G DOB
"RTN","CHSBE068",72,0)
.S $P(CHCD,U,6)=""
"RTN","CHSBE068",73,0)
.S DY=9,DX=54 X XY W @CHEOL
"RTN","CHSBE068",74,0)
.D DOD^CHSBE050
"RTN","CHSBE068",75,0)
I Y="" G DOD1
"RTN","CHSBE068",76,0)
S X=Y K %DT S %DT="EQ",%DT(0)=-DT D ^%DT K %DT
"RTN","CHSBE068",77,0)
I Y=-1 D G DOD
"RTN","CHSBE068",78,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",79,0)
.W "The Date of Death must be in the past!"
"RTN","CHSBE068",80,0)
I Y<$P(CHCD,U,3) D G DOD
"RTN","CHSBE068",81,0)
.S DY=22,DX=12 X XY W @CHEOL
"RTN","CHSBE068",82,0)
.W "Date of Death must be after the date of birth!"
"RTN","CHSBE068",83,0)
S $P(CHCD,U,6)=Y
"RTN","CHSBE068",84,0)
DOD1 S DY=9,DX=54 X XY W @CHEOL
"RTN","CHSBE068",85,0)
D DOD^CHSBE050
"RTN","CHSBE068",86,0)
D CLEARAL
"RTN","CHSBE068",87,0)
Q
"RTN","CHSBE068",88,0)
GENDER S DY=10,DX=50 X XY W @CHBON,@CHREVON,"GENDER:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",89,0)
S DY=20,DX=1 X XY W @CHEOL
"RTN","CHSBE068",90,0)
S DY=20,DX=9 X XY W @CHEOL,@CHBON,@CHREVON,"GENDER:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",91,0)
S DY=21,DX=9 X XY W @CHBON,@CHEOL
"RTN","CHSBE068",92,0)
W "Enter the gender of the bene: ",@CHBOFF
"RTN","CHSBE068",93,0)
D CSBRS^CHSC2
"RTN","CHSBE068",94,0)
I $D(DFOUT)!($D(DDOUT))!($D(DUOUT)) D CLEARAL,GENDER^CHSBE050 Q
"RTN","CHSBE068",95,0)
I $D(DQOUT) D G GENDER
"RTN","CHSBE068",96,0)
.S DY=22,DX=9 X XY W @CHEOL
"RTN","CHSBE068",97,0)
.W "The gender is mandatory. Enter M or F."
"RTN","CHSBE068",98,0)
I Y="",$P(CHCD,U,2)'="" G GENDER1
"RTN","CHSBE068",99,0)
I Y="" D G GENDER
"RTN","CHSBE068",100,0)
.S DY=22,DX=9 X XY W @CHEOL
"RTN","CHSBE068",101,0)
.W "The gender is mandatory. Enter M or F."
"RTN","CHSBE068",102,0)
I "MF"'[$E(Y) D G GENDER
"RTN","CHSBE068",103,0)
.S DY=22,DX=9 X XY W @CHEOL
"RTN","CHSBE068",104,0)
.W "Enter M or F."
"RTN","CHSBE068",105,0)
S $P(CHCD,U,2)=$E(Y)
"RTN","CHSBE068",106,0)
GENDER1 S DY=10,DX=58 X XY W @CHEOL
"RTN","CHSBE068",107,0)
D GENDER^CHSBE050
"RTN","CHSBE068",108,0)
D RELA^CHSBE050
"RTN","CHSBE068",109,0)
D CLEARAL
"RTN","CHSBE068",110,0)
Q
"RTN","CHSBE068",111,0)
AWARD S DY=11,DX=50 X XY W @CHBON,@CHREVON
"RTN","CHSBE068",112,0)
W "AWARD LETTER:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",113,0)
S DY=20,DX=1 X XY W @CHEOL
"RTN","CHSBE068",114,0)
S DY=20,DX=3 X XY W @CHEOL,@CHBON,@CHREVON
"RTN","CHSBE068",115,0)
W "AWARD LETTER:",@CHBOFF,@CHREVOFF
"RTN","CHSBE068",116,0)
S DY=21,DX=3 X XY W @CHBON,@CHEOL
"RTN","CHSBE068",117,0)
W "Enter the date the award letter was given: ",@CHBOFF
"RTN","CHSBE068",118,0)
D CSBRS^CHSC2
"RTN","CHSBE068",119,0)
I $D(DFOUT)!($D(DDOUT))!($D(DUOUT)) D CLEARAL,AWARD^CHSBE050 Q
"RTN","CHSBE068",120,0)
I $D(DQOUT) D G AWARD
"RTN","CHSBE068",121,0)
.S DY=22,DX=3 X XY W @CHEOL
"RTN","CHSBE068",122,0)
.W "Enter the award letter date in usual FileMan format."
"RTN","CHSBE068",123,0)
I Y="" I $P(CHCD15,U,2)'="" G AWARD1
"RTN","CHSBE068",124,0)
I Y="" D G AWARD
"RTN","CHSBE068",125,0)
.S DY=22,DX=3 X XY W @CHEOL
"RTN","CHSBE068",126,0)
.W "The award letter date is mandatory."
"RTN","CHSBE068",127,0)
.W " You may not proceed without it."
"RTN","CHSBE068",128,0)
; Defect 855725 fix start
"RTN","CHSBE068",129,0)
; Expect a exact input with month and date if variable %DT set to X
"RTN","CHSBE068",130,0)
S X=Y K %DT S %DT="X" D ^%DT K %DT
"RTN","CHSBE068",131,0)
I Y=-1 D G AWARD
"RTN","CHSBE068",132,0)
. S DY=22,DX=3 X XY W @CHEOL
"RTN","CHSBE068",133,0)
. W "Invalid Award Letter Date."
"RTN","CHSBE068",134,0)
; Defect 855725 fix end
"RTN","CHSBE068",135,0)
S X=Y K %DT S %DT="EQ",%DT(0)=-DT D ^%DT K %DT
"RTN","CHSBE068",136,0)
I Y=-1 D G AWARD
"RTN","CHSBE068",137,0)
.S DY=22,DX=3 X XY W @CHEOL
"RTN","CHSBE068",138,0)
.W "The award letter date must be in the past!"
"RTN","CHSBE068",139,0)
I Y<$P(CHCD,U,3) D G AWARD
"RTN","CHSBE068",140,0)
.S DY=22,DX=3 X XY W @CHEOL
"RTN","CHSBE068",141,0)
.W "The award letter date must be after the date of birth!"
"RTN","CHSBE068",142,0)
I Y>$P(CHCD,U,6)
"RTN","CHSBE068",143,0)
.S DY=22,DX=3 X XY W @CHEOL
"RTN","CHSBE068",144,0)
.W "The award letter date must be before the date of death!"
"RTN","CHSBE068",145,0)
S $P(CHCD15,U,2)=Y
"RTN","CHSBE068",146,0)
AWARD1 S DY=11,DX=56 X XY W @CHEOL
"RTN","CHSBE068",147,0)
D AWARD^CHSBE050
"RTN","CHSBE068",148,0)
D CLEAR
"RTN","CHSBE068",149,0)
Q
"RTN","CHSBE068",150,0)
CLEARAL S DX=1 F DY=20:1:24 X XY W @CHEOL
"RTN","CHSBE068",151,0)
Q
"RTN","CHSBE068",152,0)
CLEAR S DX=1 F DY=21:1:24 X XY W @CHEOL
"RTN","CHSBE068",153,0)
Q
"RTN","CHSBE068",154,0)
END Q
"RTN","CHSBE070")
0^14^B6202990
"RTN","CHSBE070",1,0)
CHSBE070 ;HAC/JAK;SB - VIEW BENE HIST;Jan 08, 2019@10:12:48
"RTN","CHSBE070",2,0)
;;2.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE070",3,0)
;JAK - SB BENE HISTORY
"RTN","CHSBE070",4,0)
;DEV023457 JAK 04/11/2017
"RTN","CHSBE070",5,0)
;RTC786712 SBB 07-25-2018 ACA Merge
"RTN","CHSBE070",6,0)
;RTC791768 - CFS - 08/08/2018 - New DT in DATA to prevent errors
"RTN","CHSBE070",7,0)
;
"RTN","CHSBE070",8,0)
S DY=3,DX=1 X XY F DY=3:1:17 X XY W @CHEEL
"RTN","CHSBE070",9,0)
S DY=DY+1 X XY W @CHEEL S DTM=5,DBM=18,DY=2 X CHMAR,XY
"RTN","CHSBE070",10,0)
S CNT=0,TMP=0,CHMAX=12
"RTN","CHSBE070",11,0)
I '$D(BFN) S DY=10,DX=5 X XY W "NO BENEFICIARY SELECTED" S CHOPT=" SB BENES",CHNUM=11 Q
"RTN","CHSBE070",12,0)
K ^CHMZHOLD($J,"SB_BENE_HISTORY")
"RTN","CHSBE070",13,0)
S DTM=3,DBM=17 X CHMAR X XY
"RTN","CHSBE070",14,0)
S DY=5,DX=1 X XY F I=1:1:16 W @CHEEL,!
"RTN","CHSBE070",15,0)
S DY=2,DX=31 X XY W @CHBON,"VIEW BENE EDIT HISTORY",@CHBOFF
"RTN","CHSBE070",16,0)
D CLEAR
"RTN","CHSBE070",17,0)
;I ('$D(^AHCHVA(DFN,100,BFN,115))),('$D(^AHCHVA(DFN,100,BFN,115))) S DY=DY+1,DX=22 X XY W $C(7),"This beneficiary has no periods of enrollment!",!!!!! S DY=DY+1 Q
"RTN","CHSBE070",18,0)
DATA ;
"RTN","CHSBE070",19,0)
; RTC791768 - CFS - 08/08/2018 - New DT to prevent errors
"RTN","CHSBE070",20,0)
N DT
"RTN","CHSBE070",21,0)
;S DT=111 F S DT=$O(^AHCHVA(DFN,101,DT,100,BFN,11)) Q:'DT D
"RTN","CHSBE070",22,0)
S DT=1 F S DT=$O(^AHCHVA(DFN,101,DT)) Q:'DT D
"RTN","CHSBE070",23,0)
.Q:'$D(^AHCHVA(DFN,101,DT,100,BFN,11))
"RTN","CHSBE070",24,0)
.S REC11=^AHCHVA(DFN,101,DT,100,BFN,11) Q:'$D(REC11)
"RTN","CHSBE070",25,0)
.S SBUDUZ=$P($G(^AHCHVA(DFN,101,DT,100,BFN,99)),"^",2)
"RTN","CHSBE070",26,0)
.S SBUNAME=""
"RTN","CHSBE070",27,0)
.S:SBUDUZ'="" SBUNAME=$P(^VA(200,SBUDUZ,0),"^",1)
"RTN","CHSBE070",28,0)
.S SBSTDATE=$P(REC11,"^",2)
"RTN","CHSBE070",29,0)
.S SBST=$P(REC11,"^",1)
"RTN","CHSBE070",30,0)
.S SBSTATUS=$S(SBST="REE":"RE-ENROLLED",SBST="DIS":"DISENROLLED",SBST="ENR":"ENROLLED",SBST="DEC":"DECEASED",1:"WRONG")
"RTN","CHSBE070",31,0)
.S TMP=TMP+1
"RTN","CHSBE070",32,0)
.S ^CHMZHOLD($J,"SB_BENE_HISTORY",TMP)=SBUDUZ_" "_SBUNAME_"^"_SBSTDATE_"^"_SBSTATUS
"RTN","CHSBE070",33,0)
DISP ;
"RTN","CHSBE070",34,0)
;I '$D(^CHMZHOLD($J,"SB_BENE_HISTORY")) W !!?17,"NO BENE EDIT HISTORY FOR THIS BENEFICIARY"
"RTN","CHSBE070",35,0)
S TMP=0 F S TMP=$O(^CHMZHOLD($J,"SB_BENE_HISTORY",TMP)) Q:'TMP D
"RTN","CHSBE070",36,0)
.S SBUSER=$P(^CHMZHOLD($J,"SB_BENE_HISTORY",TMP),"^",1)
"RTN","CHSBE070",37,0)
.S SBSTDT=$P(^CHMZHOLD($J,"SB_BENE_HISTORY",TMP),"^",2)
"RTN","CHSBE070",38,0)
.S STATUS=$P(^CHMZHOLD($J,"SB_BENE_HISTORY",TMP),"^",3)
"RTN","CHSBE070",39,0)
.S DX=1,DY=DY+1 X XY W "USERID: "_SBUSER
"RTN","CHSBE070",40,0)
.S DX=1,DY=DY+1 X XY W "ENROLLMENT STATUS CHANGE DATE: "_$$FMTE^XLFDT(SBSTDT,"5D")
"RTN","CHSBE070",41,0)
.S DX=1,DY=DY+1 X XY W "ENROLLMENT STATUS: "_STATUS
"RTN","CHSBE070",42,0)
.S DX=1,DY=DY+1 X XY W " "
"RTN","CHSBE070",43,0)
.S CNT=CNT+4
"RTN","CHSBE070",44,0)
.I CNT>CHMAX D CHKR
"RTN","CHSBE070",45,0)
K ^CHMZHOLD($J,"SB_BENE_HISTORY")
"RTN","CHSBE070",46,0)
S CHOPT=" View Bene",CHNUM=5
"RTN","CHSBE070",47,0)
Q
"RTN","CHSBE070",48,0)
CHKR ;
"RTN","CHSBE070",49,0)
S LINE=DY,DY=20,DX=1 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue" R X ; JEH 9/12/05
"RTN","CHSBE070",50,0)
S CNT=0 D CLEAR
"RTN","CHSBE070",51,0)
Q
"RTN","CHSBE070",52,0)
CLEAR ;
"RTN","CHSBE070",53,0)
S DX=1
"RTN","CHSBE070",54,0)
F DY=3:1:20 D
"RTN","CHSBE070",55,0)
.X XY
"RTN","CHSBE070",56,0)
.W @CHEOL
"RTN","CHSBE070",57,0)
S DY=2
"RTN","CHSBE070",58,0)
Q
"RTN","CHSBE070",59,0)
END ;
"RTN","CHSBE070",60,0)
Q
"RTN","CHSBE100")
0^12^B133057221
"RTN","CHSBE100",1,0)
CHSBE100 ;HAC/CAM;SB - DISENROLL DATA;Jan 18, 2019@12:48:58
"RTN","CHSBE100",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE100",3,0)
;DEV023457 JAK 11-05-2015 BUGS 02-08-2016,04/03/2017,08/02/2017
"RTN","CHSBE100",4,0)
;RTC786743 ACA MERGE- TGH -7/25/18
"RTN","CHSBE100",5,0)
;Defect 857207 - TGH - 11/2/18
"RTN","CHSBE100",6,0)
;Defect 797519 - TGH - 11/2/18
"RTN","CHSBE100",7,0)
;ACA US024 TGH 1/15/19 - Auto generate SB re-enrollment ID Card. Use CHREDT as start
"RTN","CHSBE100",8,0)
; Date for ID Card
"RTN","CHSBE100",9,0)
MENU ;
"RTN","CHSBE100",10,0)
D TOP S STAT=""
"RTN","CHSBE100",11,0)
I '$D(BFN) D ^CHSBE110
"RTN","CHSBE100",12,0)
S DX=1 F DY=2:1:18 X XY W @CHEOL
"RTN","CHSBE100",13,0)
S DY=3,DX=25 X XY
"RTN","CHSBE100",14,0)
W @CHREVON,@CHBON,"Disenroll/Re-Enroll Dates",@CHREVOFF,@CHBOFF
"RTN","CHSBE100",15,0)
D:'$D(CHSEC) CHSEC^CHMEAMB
"RTN","CHSBE100",16,0)
S DTM=5,DBM=18 X CHMAR S DY=5,DX=1 X XY
"RTN","CHSBE100",17,0)
I '$D(CHSEC) D Q
"RTN","CHSBE100",18,0)
.W *7,!!,"You do not have a security level to access this option."
"RTN","CHSBE100",19,0)
.R X:5
"RTN","CHSBE100",20,0)
I CHSEC="" D Q
"RTN","CHSBE100",21,0)
.W *7,!!,"You do not have a security level to access this option."
"RTN","CHSBE100",22,0)
.R X:5
"RTN","CHSBE100",23,0)
I CHSEC'>2 W *7,!!,"You are not authorized to access this option." Q
"RTN","CHSBE100",24,0)
;
"RTN","CHSBE100",25,0)
W !?25,"<",@CHBON,"A",@CHBOFF,">dd dates"
"RTN","CHSBE100",26,0)
W !?25,"<",@CHBON,"V",@CHBOFF,">iew current dates"
"RTN","CHSBE100",27,0)
ENTER W !!?2,"Enter your choice: Q// "
"RTN","CHSBE100",28,0)
D CSBRS^CHSC2
"RTN","CHSBE100",29,0)
G:$D(DUOUT)!($D(DFOUT)) END
"RTN","CHSBE100",30,0)
I $D(DQOUT) D G ENTER
"RTN","CHSBE100",31,0)
.W !?5,"Please enter A, V or Q at this prompt."
"RTN","CHSBE100",32,0)
S Y=$E(Y) S:Y="" Y="Q"
"RTN","CHSBE100",33,0)
I "aAVvQq"'[Y D G ENTER
"RTN","CHSBE100",34,0)
.W !?5,"Please enter A, V or Q at this prompt."
"RTN","CHSBE100",35,0)
G:"Qq"[Y END
"RTN","CHSBE100",36,0)
I "aA"[Y D ADD G MENU
"RTN","CHSBE100",37,0)
I "Vv"[Y D VIEW^CHMEAMB1 G MENU
"RTN","CHSBE100",38,0)
ADD K CHDISDT,CHREDT
"RTN","CHSBE100",39,0)
S DX=1 F DY=3:1:18 X XY W @CHEOL
"RTN","CHSBE100",40,0)
S DY=3,DX=21 X XY W @CHREVON,@CHBON
"RTN","CHSBE100",41,0)
W "Add Disenrollment Periods",@CHREVOFF,@CHBOFF ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",42,0)
S DTM=5,DBM=18 X CHMAR S DY=5,DX=1 X XY
"RTN","CHSBE100",43,0)
D CHK ;DETERMINE IF DISENROLLMENT OR REENROLLMENT DATE NEEDS TO BE SET
"RTN","CHSBE100",44,0)
I DTFLG="D" D DISDT ;ENTER DISENROLMENT DATE
"RTN","CHSBE100",45,0)
I DTFLG="R" D REDT ;ENTER REENROLLMENT DATE
"RTN","CHSBE100",46,0)
Q:$D(DUOUT) Q:$D(DTOUT)
"RTN","CHSBE100",47,0)
D GLSET
"RTN","CHSBE100",48,0)
Q
"RTN","CHSBE100",49,0)
END K TMP,Y,X,AEVJJ
"RTN","CHSBE100",50,0)
K BFN ;JAK 04/03/2017 BUG023457-06 reset BFN after completion to default prompt to 11 SB Benes
"RTN","CHSBE100",51,0)
S Y=1 ;THIS NEEDS TO BE SET TO PREVENT '$D(Y) WILL CALL CHMEAV1
"RTN","CHSBE100",52,0)
S:STAT'=1 Y=5
"RTN","CHSBE100",53,0)
Q
"RTN","CHSBE100",54,0)
GLSET ;SET DISENROLLMENT AND/OR REENROLLMENT DATES WITH HISTORY
"RTN","CHSBE100",55,0)
; CHDISDT - DATE OF DISENROLLMENT
"RTN","CHSBE100",56,0)
; CHREDT - DATE OF RE-ENROLLMENT
"RTN","CHSBE100",57,0)
; CHDDOCDT - DISENROLLMENT DOCUMENT DATE
"RTN","CHSBE100",58,0)
; TREC115 - ^AHCHVA(DFN,100,BFN,115,(LAST K VALUE),0)
"RTN","CHSBE100",59,0)
N TMPK,TREC115
"RTN","CHSBE100",60,0)
Q:'DFN Q:'BFN
"RTN","CHSBE100",61,0)
; Defect 857207 - TGH - 11/2/18 - Move to above data set below
"RTN","CHSBE100",62,0)
;I '$D(^AHCHVA(DFN,100,BFN,115,0)) S ^AHCHVA(DFN,100,BFN,115,0)="^554801.1115SA^0^0",TREC115=""
"RTN","CHSBE100",63,0)
I $D(CHDISDT) D
"RTN","CHSBE100",64,0)
.; Devect 857207 - tgh- 11/2/18 - Add $Get to prevent null value for TMPK and move below Disenrollment question
"RTN","CHSBE100",65,0)
.;L +^AHCHVA(DFN,100,BFN,115,0) S TMPK=$P(^AHCHVA(DFN,100,BFN,115,0),"^",3)+1
"RTN","CHSBE100",66,0)
.;S $P(^AHCHVA(DFN,100,BFN,115,0),"^",3)=TMPK,$P(^AHCHVA(DFN,100,BFN,115,0),"^",4)=TMPK
"RTN","CHSBE100",67,0)
.;L -^AHCHVA(DFN,100,BFN,115,0)
"RTN","CHSBE100",68,0)
.S TREC115=6_"^"_1_"^"_CHDISDT_"^^"_CHDDOCDT_"^"_DUZ_"^"_DT ;JAK add SB (program = 6)
"RTN","CHSBE100",69,0)
.S DY=DY+1,DX=1 X XY W @CHEOL
"RTN","CHSBE100",70,0)
.; Defect 857207 - TGH - 11/2/18 - Correct message display
"RTN","CHSBE100",71,0)
.;S DY=DY+1,DX=10 X XY W "YOU ARE ENTERING A NEW DISENROLLMENT PERIOD BEGINNING ",$$FMTE^XLFDT(CHDISDT,"5D")," (Y/N):N// " ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",72,0)
.S DY=DY+1,DX=1 X XY W "YOU ARE ENTERING A NEW DISENROLLMENT PERIOD BEGINNING ",$$FMTE^XLFDT(CHDISDT,"5D")," (Y/N):N// " ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",73,0)
.D CSBRS^CHSC2 S Y=$E(Y) S Y=$$UP^XLFSTR(Y) I Y="" S Y="N"
"RTN","CHSBE100",74,0)
.Q:Y="N"
"RTN","CHSBE100",75,0)
.; Defect 857207 - TGH- 11/2/18 - Set top level of global just before data set
"RTN","CHSBE100",76,0)
.;I Y="Y" S ^AHCHVA(DFN,100,BFN,115,TMPK,0)=TREC115 D
"RTN","CHSBE100",77,0)
.I Y="Y" D
"RTN","CHSBE100",78,0)
..L +^AHCHVA(DFN,100,BFN,115,0) S TMPK=$P($G(^AHCHVA(DFN,100,BFN,115,0)),"^",3)+1
"RTN","CHSBE100",79,0)
..I $G(^AHCHVA(DFN,100,BFN,115,TMPK-1,0))="" S TMPK=1
"RTN","CHSBE100",80,0)
..S ^AHCHVA(DFN,100,BFN,115,0)="^554801.1115SA^"_TMPK_"^"_TMPK
"RTN","CHSBE100",81,0)
..L -^AHCHVA(DFN,100,BFN,115,0)
"RTN","CHSBE100",82,0)
..S ^AHCHVA(DFN,100,BFN,115,TMPK,0)=TREC115
"RTN","CHSBE100",83,0)
..; Defect 857207 - TGH - 11/2/18 - Set done above
"RTN","CHSBE100",84,0)
..;S ^AHCHVA(DFN,100,BFN,115,0)="^554801.1115SA^"_TMPK_"^"_TMPK
"RTN","CHSBE100",85,0)
..D NOW^%DTC S NEWSTAT="DIS"
"RTN","CHSBE100",86,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",1)=NEWSTAT ;BENE STATUS
"RTN","CHSBE100",87,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",2)=$P(%,".",1) ;STATUS DATE
"RTN","CHSBE100",88,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",3)=1 ;INELIGIBLE REASON
"RTN","CHSBE100",89,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",4)=""
"RTN","CHSBE100",90,0)
..;;HISTORY
"RTN","CHSBE100",91,0)
..S ^AHCHVA(DFN,101,%,100,BFN,99)=%_"^"_DUZ_"^"_"DISENROLLMENT DATE"
"RTN","CHSBE100",92,0)
..S ^AHCHVA(DFN,101,%,100,BFN,115)=TREC115
"RTN","CHSBE100",93,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",1)="DIS" ;STATUS
"RTN","CHSBE100",94,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",2)=$P(%,".",1) ;STATUS DATE
"RTN","CHSBE100",95,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",3)=1 ;INELIGIBLE REASON
"RTN","CHSBE100",96,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",4)="@"_NEWSTAT ;ELIGIBLE REASON
"RTN","CHSBE100",97,0)
..;LETTER
"RTN","CHSBE100",98,0)
..I CHLTRFLG="Y" S ^CHMZHOLD("DAILY_ELIG_CCL_LTRS",342,DFN,BFN)="",$P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",13)=1
"RTN","CHSBE100",99,0)
..Q
"RTN","CHSBE100",100,0)
.Q
"RTN","CHSBE100",101,0)
I $D(CHREDT) D
"RTN","CHSBE100",102,0)
.I $D(^AHCHVA(DFN,100,BFN,115,0)) D Q:'TMPK
"RTN","CHSBE100",103,0)
..S TMPK=999
"RTN","CHSBE100",104,0)
..S TMPK=$O(^AHCHVA(DFN,100,BFN,115,TMPK),-1) Q:'TMPK
"RTN","CHSBE100",105,0)
..S TREC115=$G(^AHCHVA(DFN,100,BFN,115,TMPK,0))
"RTN","CHSBE100",106,0)
..Q
"RTN","CHSBE100",107,0)
.I $P(TREC115,"^",8)'="" Q ;CAN'T ADD RE-ENROLLMENT DATE SINCE NO OPEN DISENROLLEMNT
"RTN","CHSBE100",108,0)
.I DY'<18 S DY=10 ;JAK BUG023457-06 08/02/2017
"RTN","CHSBE100",109,0)
.S DY=DY+1,DX=1 X XY W @CHEOL
"RTN","CHSBE100",110,0)
.S DY=DY+1,DX=10 X XY W "YOU ARE ENDING A PERIOD OF DISENROLLMENT ",$$FMTE^XLFDT(CHREDT,"5D")," (Y/N): N// " ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",111,0)
.D CSBRS^CHSC2 S Y=$E(Y) S Y=$$UP^XLFSTR(Y) I Y="" S Y="N"
"RTN","CHSBE100",112,0)
.Q:Y="N"
"RTN","CHSBE100",113,0)
.I Y="Y" D
"RTN","CHSBE100",114,0)
..D NOW^%DTC
"RTN","CHSBE100",115,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",2)=0
"RTN","CHSBE100",116,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",8)=CHREDT
"RTN","CHSBE100",117,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",10)=CHRDOCDT
"RTN","CHSBE100",118,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",11)=DUZ
"RTN","CHSBE100",119,0)
..S $P(^AHCHVA(DFN,100,BFN,115,TMPK,0),"^",12)=DT
"RTN","CHSBE100",120,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",1)="REE" ;BENE STATUS
"RTN","CHSBE100",121,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",2)=$P(%,".",1) ;STATUS DATE
"RTN","CHSBE100",122,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",3)="" ;INELIGIBLE REASON
"RTN","CHSBE100",123,0)
..S $P(^AHCHVA(DFN,100,BFN,11),"^",4)=1
"RTN","CHSBE100",124,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",1)="REE" ;STATUS
"RTN","CHSBE100",125,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",2)=$P(%,".",1) ;STATUS DATE
"RTN","CHSBE100",126,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",3)="@"_"REE" ;INELIGIBLE REASON
"RTN","CHSBE100",127,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,11),"^",4)=1 ;ELIGIBLE REASON
"RTN","CHSBE100",128,0)
..S ^AHCHVA(DFN,101,%,100,BFN,99)=%_"^"_DUZ_"^"_"RE-ENROLLMENT DATE"
"RTN","CHSBE100",129,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,115),"^",2)=0
"RTN","CHSBE100",130,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,115),"^",8)=CHREDT
"RTN","CHSBE100",131,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,115),"^",10)=CHRDOCDT
"RTN","CHSBE100",132,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,115),"^",11)=DUZ
"RTN","CHSBE100",133,0)
..S $P(^AHCHVA(DFN,101,%,100,BFN,115),"^",12)=DT
"RTN","CHSBE100",134,0)
..;ACA US024 TGH 1/15/19 - Auto generate SB re-enrollment ID Card
"RTN","CHSBE100",135,0)
..D IDCARD
"RTN","CHSBE100",136,0)
..Q
"RTN","CHSBE100",137,0)
.Q
"RTN","CHSBE100",138,0)
K CHLTRFLG
"RTN","CHSBE100",139,0)
Q
"RTN","CHSBE100",140,0)
CHK ; DETERMINE IF DISENROLLMENT OR REENROLLMENT DATE SHOULD BE ENTERED.
"RTN","CHSBE100",141,0)
; DTFLG - 'R' USER SHOULD ENTER A RE-ENROLLMENT DATE
"RTN","CHSBE100",142,0)
; 'D' USER SHOULD ENTER A DISENROLLMENT DATE.
"RTN","CHSBE100",143,0)
N TMPK,REC115
"RTN","CHSBE100",144,0)
S DTFLG="D" ;HAVE USER ENTER A DISENROLLMENT DATE
"RTN","CHSBE100",145,0)
Q:'DFN Q:'BFN
"RTN","CHSBE100",146,0)
Q:'$D(^AHCHVA(DFN,100,BFN,115,0))
"RTN","CHSBE100",147,0)
S TMPK=999
"RTN","CHSBE100",148,0)
S TMPK=$O(^AHCHVA(DFN,100,BFN,115,TMPK),-1) Q:'TMPK
"RTN","CHSBE100",149,0)
S REC115=$G(^AHCHVA(DFN,100,BFN,115,TMPK,0)) I TMPK'=1 I REC115="" Q
"RTN","CHSBE100",150,0)
I $P(REC115,"^",3)'="" I $P(REC115,"^",8)="" S DTFLG="R" ;SINCE DISENROLLMENT DATE WITH NO REENROLLMENT DATE USER INPUTS REENROLLMENT DATE
"RTN","CHSBE100",151,0)
Q
"RTN","CHSBE100",152,0)
;
"RTN","CHSBE100",153,0)
DISDT ;ENTER DISENROLLMENT DATE
"RTN","CHSBE100",154,0)
N REC1
"RTN","CHSBE100",155,0)
K CHDISDT,CHREDT,TMPI,EDT
"RTN","CHSBE100",156,0)
;S DY=DY+1,DX=10 X XY
"RTN","CHSBE100",157,0)
;Defect 757519 - TGH - 11/2/18 - Clear screen before data entry
"RTN","CHSBE100",158,0)
S DX=1 F DY=3:1:18 X XY W @CHEOL
"RTN","CHSBE100",159,0)
S DY=5,DX=10 X XY
"RTN","CHSBE100",160,0)
DIS1 S DIR(0)="DO" S DIR("A")="Enter Disenrollment date in MMDDYY format " D ^DIR K DIR
"RTN","CHSBE100",161,0)
I Y=""!(Y=-1)!(Y="^") S DUOUT=1 Q
"RTN","CHSBE100",162,0)
Q:Y=-1
"RTN","CHSBE100",163,0)
Q:$D(DUOUT)
"RTN","CHSBE100",164,0)
S CHDISDT=Y
"RTN","CHSBE100",165,0)
S DIR(0)="DO" S DIR("A")="Enter disenrollment document date in MMDDYY format " D ^DIR K DIR ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",166,0)
I Y=""!(Y=-1) S DUOUT=1 Q
"RTN","CHSBE100",167,0)
S:Y="^" DUOUT=1 Q:Y=-1
"RTN","CHSBE100",168,0)
G:$D(DUOUT) DIS1
"RTN","CHSBE100",169,0)
S CHDDOCDT=Y
"RTN","CHSBE100",170,0)
D VER I $D(DFLG) K DFLG G DISDT ;IF NOT FIRST ENTRY OR NO REENROLLMENT DATE - SKIP
"RTN","CHSBE100",171,0)
S REC1=$G(^AHCHVA(DFN,100,BFN,1)) I REC1="" D R X:10 Q
"RTN","CHSBE100",172,0)
.S CHLTRFLG="N"
"RTN","CHSBE100",173,0)
.S DX=1 F DY=3:1:20 X XY W @CHEOL
"RTN","CHSBE100",174,0)
.S DY=6,DX=10 X XY W "This beneficiary has no address."
"RTN","CHSBE100",175,0)
.Q
"RTN","CHSBE100",176,0)
I $P(REC1,"^",10)'="" I $P(REC1,"^",10)'=1 D R X:10 Q
"RTN","CHSBE100",177,0)
.S CHLTRFLG="N"
"RTN","CHSBE100",178,0)
.S DX=1 F DY=3:1:18 X XY W @CHEOL
"RTN","CHSBE100",179,0)
.S DY=6,DX=10 X XY W "This beneficiary's address has been flagged as bad."
"RTN","CHSBE100",180,0)
.Q
"RTN","CHSBE100",181,0)
S DX=1 F DY=3:1:18 X XY W @CHEOL
"RTN","CHSBE100",182,0)
S DY=6,DX=1 X XY W @CHEOL S DY=DY,DX=10 X XY W "Do you want to mail a Disenrollment letter: (Y/N): Y//" D CSBRS^CHSC2 ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",183,0)
K CHLTRFLG
"RTN","CHSBE100",184,0)
I (Y=-1)!(Y="^") S DUOUT=1 Q
"RTN","CHSBE100",185,0)
S:Y="" Y="Y" S CHLTRFLG="N"
"RTN","CHSBE100",186,0)
S Y=$E(Y) S Y=$$UP^XLFSTR(Y)
"RTN","CHSBE100",187,0)
S:Y="Y" CHLTRFLG="Y"
"RTN","CHSBE100",188,0)
Q
"RTN","CHSBE100",189,0)
;
"RTN","CHSBE100",190,0)
REDT ;ENTER REENROLLMENT DATE
"RTN","CHSBE100",191,0)
K CHDISDT,CHREDT
"RTN","CHSBE100",192,0)
S DX=1 F DY=3:1:18 X XY W @CHEOL
"RTN","CHSBE100",193,0)
S DY=6,DX=10 X XY
"RTN","CHSBE100",194,0)
S DIR(0)="D" S DIR("A")="ENTER RE-ENROLLMENT DATE IN MMDDYY FORMAT " D ^DIR S CHREDT=Y
"RTN","CHSBE100",195,0)
I Y=""!(Y=-1)!(Y="^") S DUOUT=1 Q
"RTN","CHSBE100",196,0)
Q:Y=-1
"RTN","CHSBE100",197,0)
Q:$D(DUOUT)
"RTN","CHSBE100",198,0)
S CHREDT=Y
"RTN","CHSBE100",199,0)
; REMOVED COMMENTS BELOW BDB
"RTN","CHSBE100",200,0)
S DIR(0)="DO" S DIR("A")="Enter re-enrollment document date in MMDDYY format " D ^DIR K DIR ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",201,0)
I Y=""!(Y=-1) S DUOUT=1 Q ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",202,0)
S:Y="^" DUOUT=1 Q:Y=-1 ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",203,0)
G:$D(DUOUT) DIS1 ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",204,0)
S CHRDOCDT=Y ;JAK 04/03/2017 BUG023457-06
"RTN","CHSBE100",205,0)
;
"RTN","CHSBE100",206,0)
D VER I $D(DFLG) K DFLG G REDT
"RTN","CHSBE100",207,0)
Q
"RTN","CHSBE100",208,0)
VER ;
"RTN","CHSBE100",209,0)
N TMPI,EDT
"RTN","CHSBE100",210,0)
S DX=1 F DY=3:1:18 X XY W @CHEOL
"RTN","CHSBE100",211,0)
S TMPI=999
"RTN","CHSBE100",212,0)
V1 S TMPI=$O(^AHCHVA(DFN,100,BFN,115,TMPI),-1) Q:'TMPI Q:$D(DFLG)
"RTN","CHSBE100",213,0)
S TREC=$G(^AHCHVA(DFN,100,BFN,115,TMPI,0)) Q:TREC=""
"RTN","CHSBE100",214,0)
I $D(CHDISDT) D
"RTN","CHSBE100",215,0)
.I $P(^AHCHVA(DFN,100,BFN,11),"^",1)="DIS"&($P(^AHCHVA(DFN,100,BFN,11),"^",3)=1) S DFLG="" S DY=DY,DX=15 X XY W !,"This Beneficiary is in Disenrolled status.",! R X:20 Q ;DEV023457 JAK 11-05-2015
"RTN","CHSBE100",216,0)
.I $P(^AHCHVA(DFN,100,BFN,0),"^",6)?7N S DFLG=1 S DY=DY,DX=15 X XY W !,"Cannot disenroll a deceased Beneficiary.",! R X:20 Q ;DEV023457 JAK 11-05-2015
"RTN","CHSBE100",217,0)
.S EDT=$P(TREC,"^",8)
"RTN","CHSBE100",218,0)
.I $P(TREC,"^",3)'="" I $P(TREC,"^",8)="" S DFLG="" S DY=DY,DX=1 X XY W @CHEOL S DY=DY,DX=15 X XY W "Missing a re-enrollment date"
"RTN","CHSBE100",219,0)
.;Defect 757519 - TGH - 11/2/18 - Add carriage return and move error message up on screen
"RTN","CHSBE100",220,0)
.;.I CHDISDT'>EDT S DFLG="" S DY=DY+1,DX=15 X XY W @CHEOL S DY=DY,DX=15 X XY W "Disenrollment date must be greater then last re-enrollment date"
"RTN","CHSBE100",221,0)
.I CHDISDT'>EDT S DFLG="" S DY=DY,DX=1 X XY W @CHEOL S DY=DY,DX=15 X XY W "Disenrollment date must be greater than last re-enrollment date",! R X:20 Q
"RTN","CHSBE100",222,0)
I $D(CHREDT) D
"RTN","CHSBE100",223,0)
.S SDT=$P(TREC,"^",3)
"RTN","CHSBE100",224,0)
.;Defect 757519 - TGH - 11/2/18 - Add carriage return and move error message up on screen
"RTN","CHSBE100",225,0)
.;I $P(TREC,"^",3)'="" I $P(TREC,"^",8)'="" S DFLG="" S DY=DY,DX=1 X XY W @CHEOL S DY=DY,DX=15 X XY W "Missing a disenrollment date",! R X:20 Q
"RTN","CHSBE100",226,0)
.I $P(TREC,"^",3)'="" I $P(TREC,"^",8)'="" S DFLG="" S DY=DY,DX=1 X XY W @CHEOL S DY=DY,DX=15 X XY W "Missing a disenrollment date",! R X:20 Q
"RTN","CHSBE100",227,0)
.;Defect 757519 - TGH - 11/2/18 - Add carriage return and move error message up on screen
"RTN","CHSBE100",228,0)
.;I CHREDT'>SDT S DFLG="" S DY=DY,DX=1 W @CHEOL S DY=DY,DX=15 X XY W "Re-enrollment date must be greater then last disenrollment date"
"RTN","CHSBE100",229,0)
.I CHREDT'>SDT S DFLG="" S DY=DY,DX=1 W @CHEOL S DY=DY,DX=15 X XY W "Re-enrollment date must be greater than last disenrollment date",! R X:20 Q
"RTN","CHSBE100",230,0)
Q
"RTN","CHSBE100",231,0)
TOP ; COPIED FROM TOP^CHMEAV (REMOVED S:$D(CHCD) STR=CHCD SO THAT SPONSOR SHOWS AT TOP OF BANNER) BUG023457
"RTN","CHSBE100",232,0)
W @CHMARESET
"RTN","CHSBE100",233,0)
S STR=" " F I=1:1:79 S STR=STR_" "
"RTN","CHSBE100",234,0)
U $I:0:"^%X364"
"RTN","CHSBE100",235,0)
S DX=1,DY=1 X XY W @CHREVON,STR
"RTN","CHSBE100",236,0)
S:$D(DFN) STR=^AHCHVA(DFN,0) ;S:$D(CHCD) STR=CHCD BUG023457
"RTN","CHSBE100",237,0)
S DX=1 X XY W $E($P(STR,"^"),1,20)
"RTN","CHSBE100",238,0)
S Y=$P(STR,"^",9) S:Y?9N Y=$E(Y,1,3)_"-"_$E(Y,4,5)_"-"_$E(Y,6,9)
"RTN","CHSBE100",239,0)
S DX=24 X XY W "SSN: ",Y
"RTN","CHSBE100",240,0)
S DX=42 X XY W "FILE #: ",$P(STR,"^",7)
"RTN","CHSBE100",241,0)
S J=0 I $D(DFN) F I=0:0 S I=$O(^AHCHVA(DFN,110,I)) Q:'I S:$P(^(I,0),"^",4) J=1 S:$P(^(0),"^",4)=0 J=0
"RTN","CHSBE100",242,0)
W:J " (VERIFIED)"
"RTN","CHSBE100",243,0)
S DX=71 X XY W "STATUS: ",$P(STR,"^",5)
"RTN","CHSBE100",244,0)
W:$L($P(STR,"^",5))=1 " " W:$L($P(STR,"^",5))=0 " "
"RTN","CHSBE100",245,0)
W @CHREVOFF S DY=2,DX=1 X XY W @CHEOL ;,!,@CHEOL
"RTN","CHSBE100",246,0)
Q
"RTN","CHSBE100",247,0)
IDCARD ;ACA US024 TGH 1/15/19 - Auto generate SB re-enrollment ID Card. Use CHREDT as start
"RTN","CHSBE100",248,0)
; Date for ID Card
"RTN","CHSBE100",249,0)
N NAME,SSN,CHB
"RTN","CHSBE100",250,0)
S NAME=$P(^AHCHVA(DFN,100,BFN,0),U)
"RTN","CHSBE100",251,0)
S SSN=$P(^AHCHVA(DFN,100,BFN,0),U,9)
"RTN","CHSBE100",252,0)
S $P(^AHCHVA(DFN,100,BFN,10),U,1)=$P(^AHCHVA(DFN,100,BFN,0),U,9)
"RTN","CHSBE100",253,0)
S $P(^AHCHVA(DFN,100,BFN,10),U,3)=$P(^AHCHVA(DFN,100,BFN,15),U,2)
"RTN","CHSBE100",254,0)
S $P(^AHCHVA(DFN,100,BFN,10),U,4)=$P(^AHCHVA(DFN,100,BFN,0),U,6)
"RTN","CHSBE100",255,0)
S:'$D(^AHADIC(554804.05,1,22)) ^AHADIC(554804.05,1,22)=1
"RTN","CHSBE100",256,0)
S:$P(^AHADIC(554804.05,1,22),U,1)=0 $P(^AHADIC(554804.05,1,22),U,1)=1
"RTN","CHSBE100",257,0)
S CHB=+^AHADIC(554804.05,1,22)
"RTN","CHSBE100",258,0)
S $P(^AHCHVA(DFN,100,BFN,10),U,11)=""
"RTN","CHSBE100",259,0)
S:'$D(^AHADIC(554805.03,CHB,"SB-ID",0)) ^AHADIC(554805.03,CHB,"SB-ID",0)="^554804.04PA^0"
"RTN","CHSBE100",260,0)
S ^AHADIC(554805.03,CHB,"SB-ID",NAME,DFN,BFN)=DFN_U_BFN_U_SSN_U_CHREDT_U_$P(^AHCHVA(DFN,100,BFN,10),U,4)_"^^"_DUZ
"RTN","CHSBE100",261,0)
S ^AHADIC(554805.03,"C",NAME,DFN,BFN,CHB)=""
"RTN","CHSBE100",262,0)
Q
"RTN","CHSBE111")
0^18^B70867179
"RTN","CHSBE111",1,0)
CHSBE111 ;HAC/CAM;SB - ENTER NEW SB BENE;Jan 08, 2019@10:14:49
"RTN","CHSBE111",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE111",3,0)
;V2.1D
"RTN","CHSBE111",4,0)
;CPTS 12075 BY CAM
"RTN","CHSBE111",5,0)
;CPTS 12934 BY CAM
"RTN","CHSBE111",6,0)
;CPTS 14626 BY CAM
"RTN","CHSBE111",7,0)
;DEV17932 - CKN 5/17/13 - Trigger ADD to MVI
"RTN","CHSBE111",8,0)
;DEFECT 855725 DYO 11/01/18 Fix invalid Award letter Date
"RTN","CHSBE111",9,0)
;
"RTN","CHSBE111",10,0)
S DY=20,DX=1 X XY W @CHEOL
"RTN","CHSBE111",11,0)
S DX=1 F DY=2:1:18 X XY W @CHEOL
"RTN","CHSBE111",12,0)
S DX=31,DY=2 X XY W @CHBON,"Register New SB Bene",@CHBOFF
"RTN","CHSBE111",13,0)
I CHSEC'>1 D R X:10 Q
"RTN","CHSBE111",14,0)
.S DY=7,DX=1 X XY W @CHEEL X XY
"RTN","CHSBE111",15,0)
.W *7,"Sorry! You need a higher security level to add benes."
"RTN","CHSBE111",16,0)
S (CHCD,CHCD1,CHCD15,CHCD16)=""
"RTN","CHSBE111",17,0)
S X="NOW",%DT="T" D ^%DT S CHDT=Y K %DT
"RTN","CHSBE111",18,0)
S DTM=4,DBM=18 X CHMAR S DY=4,DX=1 X XY
"RTN","CHSBE111",19,0)
S U="^"
"RTN","CHSBE111",20,0)
;
"RTN","CHSBE111",21,0)
NAME W !,"Enter the ",@CHBON,"name",@CHBOFF," of the SB bene: "
"RTN","CHSBE111",22,0)
D CSBRS^CHSC2
"RTN","CHSBE111",23,0)
G:$D(DFOUT)!($D(DUOUT))!(Y="") END
"RTN","CHSBE111",24,0)
I ($D(DQOUT))!(Y'?1U.ANP1","1U.ANP) D G NAME
"RTN","CHSBE111",25,0)
.W !," Enter new SB bene name in format Last,First MI."
"RTN","CHSBE111",26,0)
.W !," Names must be 3 to 30 characters in length."
"RTN","CHSBE111",27,0)
I ($L(Y)<3)!($L(Y)>30) D G NAME
"RTN","CHSBE111",28,0)
.W !,*7," Bene Name MUST be between 3 and 30 characters in length."
"RTN","CHSBE111",29,0)
S TMPLN=$P(^AHCHVA(DFN,0),U),TMPNAME=Y
"RTN","CHSBE111",30,0)
N1 I $P(Y,",")'=$P(TMPLN,",") D G:$D(DUOUT)!($D(DQOUT))!($E(Y)="N") NAME G:$D(DFOUT) END
"RTN","CHSBE111",31,0)
.W !,"The Sponsor's last name is: ",@CHBON,$P(TMPLN,","),@CHBOFF
"RTN","CHSBE111",32,0)
.W !,"The Beneficiary's last name is: ",@CHBON,$P(Y,","),@CHBOFF
"RTN","CHSBE111",33,0)
N2 .W !!,"Add new beneficiary anyway? Y// "
"RTN","CHSBE111",34,0)
.D CSBRS^CHSC2 Q:$D(DFOUT)!($D(DUOUT))
"RTN","CHSBE111",35,0)
.I $D(DQOUT) W !!,"The last names are different. Figure it out." Q
"RTN","CHSBE111",36,0)
.G:"YN"'[$E(Y) N2
"RTN","CHSBE111",37,0)
S $P(CHCD,U)=TMPNAME
"RTN","CHSBE111",38,0)
D CVA
"RTN","CHSBE111",39,0)
S:$P(CHCD,U)="" $P(CHCD,U)=TMPNAME
"RTN","CHSBE111",40,0)
;
"RTN","CHSBE111",41,0)
SSN W !!,"Enter the ",@CHBON,"SSN",@CHBOFF," for the SB bene: " D
"RTN","CHSBE111",42,0)
.Q:$P(CHCD,U,9)'?9N
"RTN","CHSBE111",43,0)
.W $E($P(CHCD,U,9),1,3),"-",$E($P(CHCD,U,9),4,5),"-"
"RTN","CHSBE111",44,0)
.W $E($P(CHCD,U,9),6,9),"// "
"RTN","CHSBE111",45,0)
D CSBRS^CHSC2
"RTN","CHSBE111",46,0)
G:$D(DFOUT) END G:$D(DUOUT) NAME
"RTN","CHSBE111",47,0)
I $D(DQOUT) D G SSN
"RTN","CHSBE111",48,0)
.W !," Social Security Number must be a unique 9 digit number."
"RTN","CHSBE111",49,0)
I Y="",$P(CHCD,U,9)'="" G ADDRESS
"RTN","CHSBE111",50,0)
I Y="" D G SSN
"RTN","CHSBE111",51,0)
.W !," The Social Security Number is mandatory."
"RTN","CHSBE111",52,0)
.W " You may not proceed without it."
"RTN","CHSBE111",53,0)
I Y?3N1"-"2N1"-"4N S Y=$E(Y,1,3)_$E(Y,5,6)_$E(Y,8,11)
"RTN","CHSBE111",54,0)
I Y'?9N D G SSN
"RTN","CHSBE111",55,0)
.W !," Social Security Number must be a unique 9 digit number."
"RTN","CHSBE111",56,0)
I $D(^AHCHVA("G",Y))!($D(^AHCHVA("C",Y))) D G SSN
"RTN","CHSBE111",57,0)
.W !,*7,@CHBON,"There is already a " W:$D(^AHCHVA("C",Y)) "sponsor "
"RTN","CHSBE111",58,0)
.W:$D(^AHCHVA("G",Y)) "beneficiary " W "with that SSN!",@CHBOFF
"RTN","CHSBE111",59,0)
S $P(CHCD,U,9)=Y
"RTN","CHSBE111",60,0)
;
"RTN","CHSBE111",61,0)
ADDRESS W !!,?31,@CHBON,"SB BENE'S ADDRESS",@CHBOFF
"RTN","CHSBE111",62,0)
S (CHADD1,CHADD2,CHADD3,CHCITY,CHSTATE,CHZIP,CHADD4,CHCNTRY)=""
"RTN","CHSBE111",63,0)
S (CHFORD,CHPHONE)=""
"RTN","CHSBE111",64,0)
I CHCD1'="" D
"RTN","CHSBE111",65,0)
.S CHADD1=$P(CHCD1,U),CHADD2=$P(CHCD1,U,2),CHCITY=$P(CHCD1,U,3)
"RTN","CHSBE111",66,0)
.S CHSTATE=$P(CHCD1,U,4),CHZIP=$P(CHCD1,U,5),CHPHONE=$P(CHCD1,U,6)
"RTN","CHSBE111",67,0)
.S CHFORD=$P(CHCD1,U,11),CHADD3=$P(CHCD1,U,12),CHCNTRY=$P(CHCD1,U,13)
"RTN","CHSBE111",68,0)
D FORN^CHSBE003
"RTN","CHSBE111",69,0)
G:$D(DFOUT) END G:$D(DUOUT) SSN
"RTN","CHSBE111",70,0)
DOB W !!,"Enter the ",@CHBON,"Date of Birth",@CHBOFF," for this SB bene: " D
"RTN","CHSBE111",71,0)
.Q:$P(CHCD,U,3)'?7N
"RTN","CHSBE111",72,0)
.S X=$P(CHCD,U,3)
"RTN","CHSBE111",73,0)
.W $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),"// "
"RTN","CHSBE111",74,0)
D CSBRS^CHSC2
"RTN","CHSBE111",75,0)
G:$D(DFOUT) END G:$D(DUOUT) ADDRESS
"RTN","CHSBE111",76,0)
I $D(DQOUT) D G DOB
"RTN","CHSBE111",77,0)
.W !," Enter a Date of Birth in usual FileMan format."
"RTN","CHSBE111",78,0)
I Y="",$P(CHCD,U,3)'="" G DOD
"RTN","CHSBE111",79,0)
I Y="" D G DOB
"RTN","CHSBE111",80,0)
.W !," The Date of Birth is mandatory. "
"RTN","CHSBE111",81,0)
.W " You may not proceed without it."
"RTN","CHSBE111",82,0)
S X=Y K %DT S %DT="EQ",%DT(0)=-DT D ^%DT K %DT
"RTN","CHSBE111",83,0)
I Y=-1 W !,"The Date of Birth must be in the past!" G DOB
"RTN","CHSBE111",84,0)
S $P(CHCD,U,3)=Y
"RTN","CHSBE111",85,0)
;
"RTN","CHSBE111",86,0)
DOD W !!,"Enter the ",@CHBON,"Date of Death",@CHBOFF," for this SB bene: " D
"RTN","CHSBE111",87,0)
.Q:$P(CHCD,U,6)'?7N
"RTN","CHSBE111",88,0)
.S X=$P(CHCD,U,3)
"RTN","CHSBE111",89,0)
.W $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),"// "
"RTN","CHSBE111",90,0)
D CSBRS^CHSC2
"RTN","CHSBE111",91,0)
G:$D(DFOUT) END G:$D(DUOUT) DOB
"RTN","CHSBE111",92,0)
I $D(DQOUT) D G DOD
"RTN","CHSBE111",93,0)
.W !," Enter a Date of Death in usual FileMan format."
"RTN","CHSBE111",94,0)
I Y="",$P(CHCD,U,6)'="" G SEX
"RTN","CHSBE111",95,0)
G:Y="" SEX
"RTN","CHSBE111",96,0)
S X=Y K %DT S %DT="EQ",%DT(0)=-DT D ^%DT K %DT
"RTN","CHSBE111",97,0)
I Y=-1 W !,"The Date of Death must be in the past!" G DOD
"RTN","CHSBE111",98,0)
I Y<$P(CHCD,U,3) D G DOD
"RTN","CHSBE111",99,0)
.W !,"Date of Death must be after the date of birth!"
"RTN","CHSBE111",100,0)
S $P(CHCD,U,6)=Y
"RTN","CHSBE111",101,0)
;
"RTN","CHSBE111",102,0)
;
"RTN","CHSBE111",103,0)
SEX W !!,"Enter the ",@CHBON,"Gender",@CHBOFF," of this SB Bene: " D
"RTN","CHSBE111",104,0)
.Q:$P(CHCD,U,2)=""
"RTN","CHSBE111",105,0)
.W:$P(CHCD,U,2)="F" "FEMALE// "
"RTN","CHSBE111",106,0)
.W:$P(CHCD,U,2)="M" "MALE// "
"RTN","CHSBE111",107,0)
D CSBRS^CHSC2
"RTN","CHSBE111",108,0)
G:$D(DFOUT) END G:$D(DUOUT) DOD
"RTN","CHSBE111",109,0)
I $D(DQOUT) W !," The gender is mandatory. Enter M or F." G SEX
"RTN","CHSBE111",110,0)
I Y="",$P(CHCD,U,2)'="" G RELATN
"RTN","CHSBE111",111,0)
I Y="" W !," The gender is mandatory. Enter M or F." G SEX
"RTN","CHSBE111",112,0)
I "MF"'[$E(Y) W !,"Enter M or F." G SEX
"RTN","CHSBE111",113,0)
S $P(CHCD,U,2)=$E(Y)
"RTN","CHSBE111",114,0)
RELATN W !!,"Enter the ",@CHBON,"Relationship",@CHBOFF," of this SB Bene: " D
"RTN","CHSBE111",115,0)
.I $P(CHCD,U,2)="M" W "Son// "
"RTN","CHSBE111",116,0)
.I $P(CHCD,U,2)="F" W "Daughter// "
"RTN","CHSBE111",117,0)
D CSBRS^CHSC2
"RTN","CHSBE111",118,0)
G:$D(DFOUT) END G:$D(DUOUT) SEX
"RTN","CHSBE111",119,0)
I $D(DQOUT) D G RELATN
"RTN","CHSBE111",120,0)
.W !," The relationship must be a natural child: either"
"RTN","CHSBE111",121,0)
.W " a son or daughter."
"RTN","CHSBE111",122,0)
I Y'="" D G RELATN
"RTN","CHSBE111",123,0)
.W !," The relationship must be a son or daughter!"
"RTN","CHSBE111",124,0)
.W " Just press return!"
"RTN","CHSBE111",125,0)
GUARD W !!,"Do you want to enter the ",@CHBON,"guardian information"
"RTN","CHSBE111",126,0)
W @CHBOFF,"? N//"
"RTN","CHSBE111",127,0)
D CSBRS^CHSC2
"RTN","CHSBE111",128,0)
G:$D(DFOUT) END G:$D(DUOUT) RELATN
"RTN","CHSBE111",129,0)
I $D(DQOUT) D G GUARD
"RTN","CHSBE111",130,0)
.W !,"You'll be prompted for the name and address of the guardian"
"RTN","CHSBE111",131,0)
.W " if you enter Yes."
"RTN","CHSBE111",132,0)
I Y=""!($E(Y)="N")!($E(Y)="n") G APPL
"RTN","CHSBE111",133,0)
GNAME W !!,?29,@CHBON,"SB GUARDIAN'S INFORMATION",@CHBOFF
"RTN","CHSBE111",134,0)
W !!,"Enter the ",@CHBON,"name",@CHBOFF," of the guardian: " D
"RTN","CHSBE111",135,0)
.Q:$P(CHCD15,U)=""
"RTN","CHSBE111",136,0)
.W $P(CHCD15,U),"// "
"RTN","CHSBE111",137,0)
D CSBRS^CHSC2
"RTN","CHSBE111",138,0)
G:$D(DUOUT) RELATN
"RTN","CHSBE111",139,0)
G:$D(DFOUT) END
"RTN","CHSBE111",140,0)
;I Y="" W !,"Entry is mandatory!" G GNAME
"RTN","CHSBE111",141,0)
I ($D(DQOUT))!(Y'?1U.ANP1","1U.ANP) D G GNAME
"RTN","CHSBE111",142,0)
.W !," Enter new SB bene name in format Last,First MI."
"RTN","CHSBE111",143,0)
.W !," Names must be 3 to 30 characters in length."
"RTN","CHSBE111",144,0)
I ($L(Y)<3)!($L(Y)>30) D G GNAME
"RTN","CHSBE111",145,0)
.W !,*7," Bene Name MUST be between 3 and 30 characters in length."
"RTN","CHSBE111",146,0)
S CHCD15=Y
"RTN","CHSBE111",147,0)
GADD S HOLD=CHCD1
"RTN","CHSBE111",148,0)
S (CHADD1,CHADD2,CHADD3,CHCITY,CHSTATE,CHZIP,CHADD4,CHCNTRY)=""
"RTN","CHSBE111",149,0)
S (CHFORD,CHPHONE)=""
"RTN","CHSBE111",150,0)
I CHCD16'="" D
"RTN","CHSBE111",151,0)
.S CHADD1=$P(CHCD16,U),CHADD2=$P(CHCD16,U,2),CHCITY=$P(CHCD16,U,3)
"RTN","CHSBE111",152,0)
.S CHSTATE=$P(CHCD16,U,4),CHZIP=$P(CHCD16,U,5),CHPHONE=$P(CHCD16,U,6)
"RTN","CHSBE111",153,0)
.S CHFORD=$P(CHCD16,U,11),CHADD3=$P(CHCD16,U,12),CHCNTRY=$P(CHCD16,U,13)
"RTN","CHSBE111",154,0)
D FORN^CHSBE003
"RTN","CHSBE111",155,0)
G:$D(DFOUT) END G:$D(DUOUT) GNAME
"RTN","CHSBE111",156,0)
S CHCD16=CHCD1
"RTN","CHSBE111",157,0)
S CHCD1=HOLD
"RTN","CHSBE111",158,0)
APPL W !!,"Enter the ",@CHBON,"Active Award",@CHBOFF," date: " D
"RTN","CHSBE111",159,0)
.Q:$P(CHCD15,U,2)'?7N
"RTN","CHSBE111",160,0)
.S X=$P(CHCD,U,2)
"RTN","CHSBE111",161,0)
.W $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),"// "
"RTN","CHSBE111",162,0)
D CSBRS^CHSC2
"RTN","CHSBE111",163,0)
G:$D(DFOUT) END G:$D(DUOUT) GADD
"RTN","CHSBE111",164,0)
I $D(DQOUT) D G APPL
"RTN","CHSBE111",165,0)
.W !," Enter the date the bene was granted the award."
"RTN","CHSBE111",166,0)
I Y="" D G APPL
"RTN","CHSBE111",167,0)
.W !," The Award Date is mandatory. "
"RTN","CHSBE111",168,0)
.W " You may not proceed without it."
"RTN","CHSBE111",169,0)
; Defect 855725 fix start
"RTN","CHSBE111",170,0)
; Expect a exact input with month and date if variable %DT set to X
"RTN","CHSBE111",171,0)
S X=Y K %DT S %DT="X" D ^%DT K %DT
"RTN","CHSBE111",172,0)
I Y=-1 W !,"Invalid Award Letter Date." G APPL
"RTN","CHSBE111",173,0)
; Defect 855725 fix end
"RTN","CHSBE111",174,0)
S X=Y K %DT S:$P(CHCD,U,3)?7N %DT(0)=$P(CHCD,U,3) D ^%DT K %DT
"RTN","CHSBE111",175,0)
I Y=-1 W !,"The Award Date must be greater than the date of birth!!" G APPL
"RTN","CHSBE111",176,0)
S %DT="EQ",%DT(0)=-DT D ^%DT K %DT
"RTN","CHSBE111",177,0)
I Y=-1 W !,"The Award Date must be prior to today's date!!" G APPL
"RTN","CHSBE111",178,0)
S $P(CHCD15,U,2)=Y
"RTN","CHSBE111",179,0)
;
"RTN","CHSBE111",180,0)
SHOW D SHOW^CHSBE112
"RTN","CHSBE111",181,0)
ASKADD W !!,"Add the new bene to the SB program? Y// "
"RTN","CHSBE111",182,0)
D CSBRS^CHSC2
"RTN","CHSBE111",183,0)
G:$D(DFOUT) END G:$D(DUOUT) END
"RTN","CHSBE111",184,0)
I $D(DQOUT) D G ASKADD
"RTN","CHSBE111",185,0)
.W !,"Answer ",@CHBON,"Y",@CHBOFF," to add this bene, "
"RTN","CHSBE111",186,0)
.W @CHBON,"N",@CHBOFF," to not add."
"RTN","CHSBE111",187,0)
S:Y="" Y="Y" S Y=$E(Y) I "YyNn"'[Y W *7," ??" G ASKADD
"RTN","CHSBE111",188,0)
G END:"Nn"[Y
"RTN","CHSBE111",189,0)
D NOW^%DTC S CHDT=%
"RTN","CHSBE111",190,0)
I $D(FLGCVA) K FLGCVA G ASKADD1 ;BFN ALREADY ENROLLED IN CVA
"RTN","CHSBE111",191,0)
S BFN=0 F I=0:0 S I=$O(^AHCHVA(DFN,100,I)) Q:'I S BFN=I
"RTN","CHSBE111",192,0)
S BFN=BFN+1
"RTN","CHSBE111",193,0)
ASKADD1 S ^AHCHVA(DFN,100,BFN,0)=CHCD
"RTN","CHSBE111",194,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,0)=CHCD
"RTN","CHSBE111",195,0)
S ^AHCHVA(DFN,100,BFN,1)=CHCD1
"RTN","CHSBE111",196,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,1)=CHCD1
"RTN","CHSBE111",197,0)
S ^AHCHVA(DFN,100,BFN,15)=CHCD15
"RTN","CHSBE111",198,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,15)=CHCD15
"RTN","CHSBE111",199,0)
S ^AHCHVA(DFN,100,BFN,16)=CHCD16
"RTN","CHSBE111",200,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,16)=CHCD16
"RTN","CHSBE111",201,0)
S ^AHCHVA(DFN,100,BFN,99)=CHDT_U_DUZ_"^NEW SB BENE ADDED^"_CHDT
"RTN","CHSBE111",202,0)
S ^AHCHVA(DFN,101,CHDT,100,BFN,99)=CHDT_U_DUZ_"^NEW SB BENE ADDED"
"RTN","CHSBE111",203,0)
S ^AHCHVA("F",$P(CHCD,U),DFN,BFN)=""
"RTN","CHSBE111",204,0)
S ^AHCHVA("G",$P(CHCD,U,9),DFN,BFN)=""
"RTN","CHSBE111",205,0)
S ^AHCHVA(DFN,100,"B",$P(CHCD,U),BFN)=""
"RTN","CHSBE111",206,0)
S ^AHCHVA("SB",DFN,BFN)=""
"RTN","CHSBE111",207,0)
S $P(^AHCHVA(DFN,15),U)=1
"RTN","CHSBE111",208,0)
D IDCARD^CHSBE112
"RTN","CHSBE111",209,0)
W !!,"Beneficiary added to the SPINA BIFIDA database and the next"
"RTN","CHSBE111",210,0)
W !!,"SPINA BIFIDA ID card batch."
"RTN","CHSBE111",211,0)
;*17932 - CKN - Trigger A28 Add to MPI
"RTN","CHSBE111",212,0)
I $$CHECK^CHMPIEVT(DFN,BFN) D EVENT^CHMPIEVT(DFN,BFN,"A28")
"RTN","CHSBE111",213,0)
Q
"RTN","CHSBE111",214,0)
END W *7,!!,"The BENE was not added to the SB database!" K BFN
"RTN","CHSBE111",215,0)
Q
"RTN","CHSBE111",216,0)
CVA S CHCD=""
"RTN","CHSBE111",217,0)
Q:'$D(^AHCHVA("F",TMPNAME,DFN))
"RTN","CHSBE111",218,0)
S BFN=0 S BFN=$O(^AHCHVA("F",TMPNAME,DFN,BFN))
"RTN","CHSBE111",219,0)
S:$D(^AHCHVA(DFN,100,BFN,0)) CHCD=^(0)
"RTN","CHSBE111",220,0)
S:$D(^AHCHVA(DFN,100,BFN,1)) CHCD1=^(1)
"RTN","CHSBE111",221,0)
S FLGCVA=1
"RTN","CHSBE111",222,0)
Q
"RTN","CHSBE111",223,0)
ASK W @CHMARESET S CHDEF="EDIT SPONSOR",CHDEFNUM=10
"RTN","CHSBE111",224,0)
Q
"RTN","CHSBE111",225,0)
;G ASK^CHMEAV
"RTN","CHSBE111",226,0)
;CHMEAV53
"RTN","CHSBE120")
0^15^B15880710
"RTN","CHSBE120",1,0)
CHSBE120 ;HAC/JAK;SB - CR;Jan 08, 2019@10:15:45
"RTN","CHSBE120",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBE120",3,0)
;JAK - SB ENROLLMENT HISTORY
"RTN","CHSBE120",4,0)
;DEV023457 JAK 04/11/2017
"RTN","CHSBE120",5,0)
;RTC786744 BDB 07-25-2018 ACA MERGE
"RTN","CHSBE120",6,0)
;RTC790954 TGH 08-06-2018 ACA FIX HISTORY
"RTN","CHSBE120",7,0)
;DEFECT855699 DYO 11-01-2018 ACA Enroll Hist NOT Displaying all data on the first screen
"RTN","CHSBE120",8,0)
;
"RTN","CHSBE120",9,0)
S DY=3,DX=1 X XY F DY=3:1:17 X XY W @CHEEL
"RTN","CHSBE120",10,0)
S DY=DY+1 X XY W @CHEEL S DTM=5,DBM=18,DY=2 X CHMAR,XY
"RTN","CHSBE120",11,0)
S CNT=0,CHMAX=12
"RTN","CHSBE120",12,0)
I '$D(BFN) S DY=10,DX=5 X XY W "NO BENEFICIARY SELECTED" S CHOPT=" SB BENES",CHNUM=11 Q
"RTN","CHSBE120",13,0)
K ^CHMZHOLD($J,"ENR_HISTORY")
"RTN","CHSBE120",14,0)
S DTM=3,DBM=17 X CHMAR X XY
"RTN","CHSBE120",15,0)
S DY=5,DX=1 X XY F I=1:1:16 W @CHEEL,!
"RTN","CHSBE120",16,0)
S DY=2,DX=31 X XY W @CHBON,"SB Beneficiary",@CHBOFF
"RTN","CHSBE120",17,0)
S DY=3,DX=30 X XY W @CHBON,"ENROLLMENT DATES",@CHBOFF
"RTN","CHSBE120",18,0)
S DY=4,DX=22 X XY W @CHULON,"BEGIN DATE ",@CHULOFF S DX=38 X XY W @CHULON,"END DATE ",@CHULOFF S DX=52 X XY W @CHULON,"SB STATUS ",@CHULOFF
"RTN","CHSBE120",19,0)
;
"RTN","CHSBE120",20,0)
; RTC790954 TGH 08-06-2018 - Add logic to put Initial Award Date as first entry
"RTN","CHSBE120",21,0)
N AWDDT
"RTN","CHSBE120",22,0)
S AWDDT=$P($G(^AHCHVA(DFN,100,BFN,15)),U,2)
"RTN","CHSBE120",23,0)
;
"RTN","CHSBE120",24,0)
; RTC790954 TGH 08-06-2018 - If no Initial Award Date print error message
"RTN","CHSBE120",25,0)
;I ('$D(^AHCHVA(DFN,100,BFN,115))),('$D(^AHCHVA(DFN,100,BFN,115))) S DY=DY+1,DX=22 X XY W $C(7),"This beneficiary has no periods of enrollment!",!!!!! S DY=DY+1 Q
"RTN","CHSBE120",26,0)
I AWDDT="",'$D(^AHCHVA(DFN,100,BFN,115)) S DY=DY+1,DX=22 X XY W $C(7),"This beneficiary has no periods of enrollment!",!!!!! S DY=DY+1 Q
"RTN","CHSBE120",27,0)
;
"RTN","CHSBE120",28,0)
S ^CHMZHOLD($J,"ENR_HISTORY",1)=AWDDT_U_""_U_"ENROLLED"
"RTN","CHSBE120",29,0)
;
"RTN","CHSBE120",30,0)
DATA ; RTC790954 TGH 08-2018 - Change to set to print after Award Letter Date
"RTN","CHSBE120",31,0)
;S TMP=9999999999 F S TMP=$O(^AHCHVA(DFN,100,BFN,115,TMP),-1) Q:'TMP D
"RTN","CHSBE120",32,0)
N TMP,CNT,REE
"RTN","CHSBE120",33,0)
S TMP=0,(CNT,REE)=1 F S TMP=$O(^AHCHVA(DFN,100,BFN,115,TMP)) Q:TMP="" D
"RTN","CHSBE120",34,0)
.N REC115,TP,DISDT,REDT
"RTN","CHSBE120",35,0)
.S REC115=$G(^AHCHVA(DFN,100,BFN,115,TMP,0)) Q:'$D(REC115)
"RTN","CHSBE120",36,0)
.S TP=$P(REC115,U,2),DISDT=$P(REC115,U,3),REDT=$P(REC115,U,8)
"RTN","CHSBE120",37,0)
.; RTC790954 TGH 08-06-2018 - Set data for writing Disenrollment and Re-enrollment
"RTN","CHSBE120",38,0)
.S CNT=CNT+1
"RTN","CHSBE120",39,0)
.I REE D
"RTN","CHSBE120",40,0)
..N X1,X2,X
"RTN","CHSBE120",41,0)
..S X1=DISDT,X2=-1 D C^%DTC
"RTN","CHSBE120",42,0)
..S $P(^CHMZHOLD($J,"ENR_HISTORY",CNT-1),U,2)=X,REE=0
"RTN","CHSBE120",43,0)
.I REDT'="" D
"RTN","CHSBE120",44,0)
..N X1,X2,X
"RTN","CHSBE120",45,0)
..S X1=REDT,X2=-1 D C^%DTC
"RTN","CHSBE120",46,0)
..S ^CHMZHOLD($J,"ENR_HISTORY",CNT)=DISDT_U_X_U_"DISENROLLED"
"RTN","CHSBE120",47,0)
.I REDT="" S ^CHMZHOLD($J,"ENR_HISTORY",CNT)=DISDT_U_REDT_U_"DISENROLLED"
"RTN","CHSBE120",48,0)
.I TP=0 S CNT=CNT+1 D
"RTN","CHSBE120",49,0)
..S ^CHMZHOLD($J,"ENR_HISTORY",CNT)=REDT_U_""_U_"RE-ENROLLED",REE=1
"RTN","CHSBE120",50,0)
; If bene is deceased and either Enrolled or Re-enrolled has no end date set end date to DOD
"RTN","CHSBE120",51,0)
I $P($G(^AHCHVA(DFN,100,BFN,0)),U,6)'="" D
"RTN","CHSBE120",52,0)
.I $P(^CHMZHOLD($J,"ENR_HISTORY",CNT),U,2)="",$P(^CHMZHOLD($J,"ENR_HISTORY",CNT),U,3)'="DISENROLLED" S $P(^CHMZHOLD($J,"ENR_HISTORY",CNT),U,2)=$P(^AHCHVA(DFN,100,BFN,0),U,6)
"RTN","CHSBE120",53,0)
.I $P(^CHMZHOLD($J,"ENR_HISTORY",1),U,2)="" S $P(^CHMZHOLD($J,"ENR_HISTORY",1),U,2)=$P(^AHCHVA(DFN,100,BFN,0),U,6)
"RTN","CHSBE120",54,0)
.; RTC790954 TGH 08-06-2018 - Rewritten to add complete history
"RTN","CHSBE120",55,0)
.;I TP=0 D
"RTN","CHSBE120",56,0)
.;.S TYPE="ENROLLED"
"RTN","CHSBE120",57,0)
.;E D
"RTN","CHSBE120",58,0)
.;.S TYPE="DISENROLLED"
"RTN","CHSBE120",59,0)
.;S ^CHMZHOLD($J,"ENR_HISTORY",TMP)=DISDT_"^"_REDT_"^"_TYPE
"RTN","CHSBE120",60,0)
DISP I '$D(^CHMZHOLD($J,"ENR_HISTORY")) W !!?17,"NO ENROLLMENT HISTORY FOR THIS BENEFICIARY"
"RTN","CHSBE120",61,0)
S TMP=0 F S TMP=$O(^CHMZHOLD($J,"ENR_HISTORY",TMP)) Q:'TMP D
"RTN","CHSBE120",62,0)
.S DISDT=$P(^CHMZHOLD($J,"ENR_HISTORY",TMP),"^",1)
"RTN","CHSBE120",63,0)
.S REDT=$P(^CHMZHOLD($J,"ENR_HISTORY",TMP),"^",2)
"RTN","CHSBE120",64,0)
.S TYPE=$P(^CHMZHOLD($J,"ENR_HISTORY",TMP),"^",3)
"RTN","CHSBE120",65,0)
.; defect 855699 fix start
"RTN","CHSBE120",66,0)
.; S DX=22,DY=DY+1 X XY W $$FMTE^XLFDT(DISDT,"5D")
"RTN","CHSBE120",67,0)
.; S DX=38 X XY W $$FMTE^XLFDT(REDT,"5D")
"RTN","CHSBE120",68,0)
.S DX=22,DY=DY+1 X XY W $$FMTE^XLFDT(DISDT,"5ZP")
"RTN","CHSBE120",69,0)
.S DX=38 X XY W $$FMTE^XLFDT(REDT,"5ZP")
"RTN","CHSBE120",70,0)
.; defect 855699 fix end
"RTN","CHSBE120",71,0)
.S DX=52 X XY W TYPE
"RTN","CHSBE120",72,0)
.; defect 855699 fix start
"RTN","CHSBE120",73,0)
.; S CNT=CNT+1
"RTN","CHSBE120",74,0)
.; I CNT>CHMAX D CHKR
"RTN","CHSBE120",75,0)
.I TMP>CHMAX D CHKR
"RTN","CHSBE120",76,0)
.; defect 855699 fix end
"RTN","CHSBE120",77,0)
K ^CHMZHOLD($J,"ENR_HISTORY")
"RTN","CHSBE120",78,0)
Q
"RTN","CHSBE120",79,0)
CHKR S LINE=DY,DY=20,DX=1 X XY W "Hit ",@CHBON,"RETURN",@CHBOFF," to continue" R X ; JEH 9/12/05
"RTN","CHSBE120",80,0)
S CNT=0 D CLEAR
"RTN","CHSBE120",81,0)
Q
"RTN","CHSBE120",82,0)
CLEAR S DX=1
"RTN","CHSBE120",83,0)
F DY=5:1:17 D
"RTN","CHSBE120",84,0)
.X XY
"RTN","CHSBE120",85,0)
.W @CHEOL
"RTN","CHSBE120",86,0)
S DY=4
"RTN","CHSBE120",87,0)
Q
"RTN","CHSBE120",88,0)
END Q
"RTN","CHSBEU01")
0^13^B15678828
"RTN","CHSBEU01",1,0)
CHSBEU01 ;HAC/CAM;SPINA BIFIDA UTILITIES;Jan 08, 2019@10:16:38
"RTN","CHSBEU01",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHSBEU01",3,0)
;;DEV023457 JAK 11-05-2015 ACA DISENROLLMENT
"RTN","CHSBEU01",4,0)
;RTM 786712 DYO 07-25-2018 ACA Merge
"RTN","CHSBEU01",5,0)
SETUP ;initial setup from CHSBEDRV
"RTN","CHSBEU01",6,0)
S CHTR=13 I $D(^AHADIC(554804.05,1,2)),^(2)="R" S CHTR=9
"RTN","CHSBEU01",7,0)
S (XY,CHREVON,CHREVOFF,CHEOL,CHULON,CHULOFF,CHBON,CHBOFF,CHMAR)=""
"RTN","CHSBEU01",8,0)
S (CHMARESET,CHEBOL,CHEEL,CHECH)=""
"RTN","CHSBEU01",9,0)
S:$D(^%ZIS(2,IOST(0),554001)) XY=$P(^(554001),U,4)
"RTN","CHSBEU01",10,0)
S:$D(^%ZIS(2,IOST(0),5)) CHREVON=$P(^(5),U,4),CHREVOFF=$P(^(5),U,5),CHEOL=$P(^(5),U,6)
"RTN","CHSBEU01",11,0)
S:$D(^%ZIS(2,IOST(0),6)) CHULON=$P(^(6),U,4),CHULOFF=$P(^(6),U,5)
"RTN","CHSBEU01",12,0)
S:$D(^%ZIS(2,IOST(0),7)) CHBON=$P(^(7),U),CHBOFF=$P(^(7),U,2),CHMAR=$P(^(7),U,6),CHMARESET=$P(^(7),U,7)
"RTN","CHSBEU01",13,0)
S:$D(^%ZIS(2,IOST(0),13)) CHEBOL=$P(^(13),U,3),CHEEL=$P(^(13),U,4),CHECH=$P(^(13),U,5)
"RTN","CHSBEU01",14,0)
Q
"RTN","CHSBEU01",15,0)
;
"RTN","CHSBEU01",16,0)
GETSEC ;grabs security level for SB program
"RTN","CHSBEU01",17,0)
I '$D(^CHMDIC(741002.21,DUZ,109,"B")) D HELP109 Q
"RTN","CHSBEU01",18,0)
S TMP=9999999,TMP=$O(^CHMDIC(741002.21,DUZ,109,"B",TMP),-1)
"RTN","CHSBEU01",19,0)
I '$D(^CHMDIC(741002.21,DUZ,109,"B",TMP)) D HELP109 Q
"RTN","CHSBEU01",20,0)
S TMPI=0,TMPI=$O(^CHMDIC(741002.21,DUZ,109,"B",TMP,TMPI))
"RTN","CHSBEU01",21,0)
I '$D(^CHMDIC(741002.21,DUZ,109,TMPI,0)) D HELP109 Q
"RTN","CHSBEU01",22,0)
S CHSEC=$P(^CHMDIC(741002.21,DUZ,109,TMPI,0),U,3)
"RTN","CHSBEU01",23,0)
K TMP,TMPI
"RTN","CHSBEU01",24,0)
Q
"RTN","CHSBEU01",25,0)
BANNER S DY=1,DX=1 X XY W CHL
"RTN","CHSBEU01",26,0)
S DY=2,DX=1 X XY W "|"
"RTN","CHSBEU01",27,0)
S DY=2,DX=28 X XY W @CHBON,"HEALTH ADMINISTRATION CENTER",@CHBOFF
"RTN","CHSBEU01",28,0)
S DY=2,DX=80 X XY W "|"
"RTN","CHSBEU01",29,0)
S DY=3,DX=1 X XY W "|"
"RTN","CHSBEU01",30,0)
S DY=3,DX=29 X XY W @CHBON,"SPINA BIFIDA REGISTRATION",@CHBOFF
"RTN","CHSBEU01",31,0)
S DY=3,DX=80 X XY W "|"
"RTN","CHSBEU01",32,0)
S DY=4,DX=1 X XY W CHL
"RTN","CHSBEU01",33,0)
Q
"RTN","CHSBEU01",34,0)
HELP109 S DY=12,DX=1 X XY W "Please contact IRM: "
"RTN","CHSBEU01",35,0)
S DY=13,DX=1 X XY W "Something is wrong with your ^CHMDIC(741002.21,DUZ,109 node."
"RTN","CHSBEU01",36,0)
R X:10
"RTN","CHSBEU01",37,0)
Q
"RTN","CHSBEU01",38,0)
OPTION S X=$P($T(OPTION+(Y+1)),";;",2)
"RTN","CHSBEU01",39,0)
Q:X="" W " ",X Q
"RTN","CHSBEU01",40,0)
1 ;;VIEW SPONSOR
"RTN","CHSBEU01",41,0)
2 ;;EDIT SPONSOR
"RTN","CHSBEU01",42,0)
3 ;;VIEW SPONSOR EDIT HISTORY
"RTN","CHSBEU01",43,0)
4 ;;SPONSOR ROC
"RTN","CHSBEU01",44,0)
5 ;;VIEW BENEFICIARY
"RTN","CHSBEU01",45,0)
6 ;;EDIT BENEFICIARY
"RTN","CHSBEU01",46,0)
7 ;;VIEW BENEFICIARY EDIT HISTORY
"RTN","CHSBEU01",47,0)
8 ;;BENEFICIARY ROC
"RTN","CHSBEU01",48,0)
9 ;;ID CARD
"RTN","CHSBEU01",49,0)
10 ;;BACKDATE ELIGIBILITY
"RTN","CHSBEU01",50,0)
11 ;;SB BENES
"RTN","CHSBEU01",51,0)
12 ;;ENROLL HISTORY
"RTN","CHSBEU01",52,0)
13 ;;FILE UTILITIES
"RTN","CHSBEU01",53,0)
14 ;;ASSIGN SECURITY
"RTN","CHSBEU01",54,0)
15 ;;PRINT/QUEUE
"RTN","CHSBEU01",55,0)
Q
"RTN","CHSBEU01",56,0)
TOP S DY=1,DX=1 X XY
"RTN","CHSBEU01",57,0)
S STR="" S:$D(DFN) STR=^AHCHVA(DFN,0) S:$D(CHCD) STR=CHCD
"RTN","CHSBEU01",58,0)
S CH1ST=$E($P(STR,U),1,30)
"RTN","CHSBEU01",59,0)
S BLANKS=31-$L(CH1ST) F I=1:1:BLANKS S CH1ST=CH1ST_" "
"RTN","CHSBEU01",60,0)
S CH2ND=$P(STR,U,9)
"RTN","CHSBEU01",61,0)
S:CH2ND?9N CH2ND=$E(CH2ND,1,3)_"-"_$E(CH2ND,4,5)_"-"_$E(CH2ND,6,9)
"RTN","CHSBEU01",62,0)
S CH2ND="SSN: "_CH2ND
"RTN","CHSBEU01",63,0)
S BLANKS=31-$L(CH2ND) F I=1:1:BLANKS S CH2ND=CH2ND_" "
"RTN","CHSBEU01",64,0)
S CH3RD="FILE #: "_$P(STR,U,7)
"RTN","CHSBEU01",65,0)
S BLANKS=18-$L(CH3RD) F I=1:1:BLANKS S CH3RD=CH3RD_" "
"RTN","CHSBEU01",66,0)
;W ?32,"SSN: ",Y
"RTN","CHSBEU01",67,0)
;W ?62,"FILE #: ",$P(STR,"^",7)
"RTN","CHSBEU01",68,0)
;W:$L($P(STR,"^",5))=1 " " W:$L($P(STR,"^",5))=0 " "
"RTN","CHSBEU01",69,0)
W @CHREVON,CH1ST,CH2ND,CH3RD,@CHREVOFF
"RTN","CHSBEU01",70,0)
S DY=2,DX=1 X XY W @CHEOL
"RTN","CHSBEU01",71,0)
Q
"RTN","CHSBEU01",72,0)
BOTTOM ;U $I:81
"RTN","CHSBEU01",73,0)
U $I::"^%X364" ;SKD,NEW
"RTN","CHSBEU01",74,0)
S DY=21,DX=1 X XY
"RTN","CHSBEU01",75,0)
W @CHREVON,@CHBON," 1",@CHBOFF,@CHREVON," View Spon "
"RTN","CHSBEU01",76,0)
W @CHBON," 5",@CHBOFF,@CHREVON," View Bene "
"RTN","CHSBEU01",77,0)
W @CHBON," 9",@CHBOFF,@CHREVON," ID Card "
"RTN","CHSBEU01",78,0)
W @CHBON,13,@CHBOFF,@CHREVON," File Utilities "
"RTN","CHSBEU01",79,0)
S DY=22,DX=1 X XY W @CHBON," 2",@CHBOFF,@CHREVON," Edit Spon "
"RTN","CHSBEU01",80,0)
W @CHBON," 6",@CHBOFF,@CHREVON," Edit Bene "
"RTN","CHSBEU01",81,0)
W @CHBON,10,@CHBOFF,@CHREVON," Disenroll Data " ;DEV023457 JAK 04-11-2017
"RTN","CHSBEU01",82,0)
W @CHBON,14,@CHBOFF,@CHREVON," Assign Security "
"RTN","CHSBEU01",83,0)
S DY=23,DX=1 X XY W @CHBON," 3",@CHBOFF,@CHREVON," View S Hist "
"RTN","CHSBEU01",84,0)
W @CHBON," 7",@CHBOFF,@CHREVON," View B Hist "
"RTN","CHSBEU01",85,0)
W @CHBON,11,@CHBOFF,@CHREVON," SB Benes "
"RTN","CHSBEU01",86,0)
W @CHBON,15,@CHBOFF,@CHREVON," Print/Queue "
"RTN","CHSBEU01",87,0)
S DY=24,DX=1 X XY W @CHBON," 4",@CHBOFF,@CHREVON," Spon ROC "
"RTN","CHSBEU01",88,0)
W @CHBON," 8",@CHBOFF,@CHREVON," Bene ROC "
"RTN","CHSBEU01",89,0)
W @CHBON,12,@CHBOFF,@CHREVON," Enroll Hist " ;DEV023457 JAK 04-11-2017
"RTN","CHSBEU01",90,0)
W @CHBON,"^^",@CHBOFF,@CHREVON," Quit ",@CHREVOFF
"RTN","CHSBEU01",91,0)
Q
"RTN","CHSBEU01",92,0)
LINE17 K CHL S $P(CHL,"-",81)=""
"RTN","CHSBEU01",93,0)
S DY=17,DX=1 X XY W CHL
"RTN","CHSBEU01",94,0)
Q
"RTN","CHSBEU01",95,0)
LINE19 K CHL S $P(CHL,"-",81)=""
"RTN","CHSBEU01",96,0)
S DY=19,DX=1 X XY W CHL
"RTN","CHSBEU01",97,0)
Q
"RTN","CHTDISEN")
0^21^B3299
"RTN","CHTDISEN",1,0)
CHTDISEN ;Affordable Care Act Eligiblity;;Aug 20, 2018@14:13:18
"RTN","CHTDISEN",2,0)
;;1.0;CHAMPVA SYSTEM;**1**;JULY 4, 1990;Build 4
"RTN","CHTDISEN",3,0)
;DEV022991-01 YJK May 2015
"RTN","CHTDISEN",4,0)
;Allow for EEV to make Benes "Ineligible" with reason "disenrollment"
"RTN","CHTDISEN",5,0)
;Adjust eligibility period according to the disenrollment date.
"RTN","CHTDISEN",6,0)
;Populate Disenrollment data ^AHCHVA(I,100,J,115,K,0)
"RTN","CHTDISEN",7,0)
;input dates - disenrollment date, disenrollment document date
"RTN","CHTDISEN",8,0)
;BUG022991-03-01 YJK 5/21/15
"RTN","CHTDISEN",9,0)
;BUG022991-03-02 YJK 6/15/15
"RTN","CHTDISEN",10,0)
;BUG022991-03-03 YJK 6/29/15
"RTN","CHTDISEN",11,0)
ZSET
"RTN","CHTDISEN",12,0)
I '$D(DUZ) W !!,"Your DUZ is not set. Please set your DUZ. " Q
"RTN","CHTDISEN",13,0)
I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
"RTN","CHTDISEN",14,0)
S:'$D(IOZFO) IOZFO="^^" S:'$D(IOZBK) IOZBK="^" S:'$D(DTIME) DTIME=60
"RTN","CHTDISEN",15,0)
I '$D(IOZ) S %IS="N",IOP=$I D ^%ZIS K IOP S IOZ=IO,IOZL=IOSL,IOZW=IOM,IOZF=IOF,IOZT=IOST,IOZN=ION,IOZS=IOS
"RTN","CHTDISEN",16,0)
ZNAM ;
"RTN","CHTDISEN",17,0)
D ^CHMFSET X CHRESET D NOW^%DTC S CHDATE=X S TL="Set Disenrollment Date"
"RTN","CHTDISEN",18,0)
S DONE=0
"RTN","CHTDISEN",19,0)
D SELBEN
"RTN","CHTDISEN",20,0)
WHILE 'DONE&(GOTBENE) {
"RTN","CHTDISEN",21,0)
S HASDT=0
"RTN","CHTDISEN",22,0)
S OLDSTAT=$P(^AHCHVA(DFN,100,BFN,0),"^",5)
"RTN","CHTDISEN",23,0)
I $D(^AHCHVA("SB",DFN,BFN)) D ELIGDATE D SBDATE
"RTN","CHTDISEN",24,0)
E D ELIGDATE I HASDT D NEWENDDT
"RTN","CHTDISEN",25,0)
D SELBEN
"RTN","CHTDISEN",26,0)
}
"RTN","CHTDISEN",27,0)
D END
"RTN","CHTDISEN",28,0)
Q
"RTN","CHTDISEN",29,0)
SELBEN
"RTN","CHTDISEN",30,0)
S GOTBENE=0
"RTN","CHTDISEN",31,0)
X CHRESET W !,?(80-$L(TL))/2,@CHBON,TL,@CHBOFF
"RTN","CHTDISEN",32,0)
D ^CHMEAV11
"RTN","CHTDISEN",33,0)
I $D(DFOUT)!($D(DUOUT))!($D(DTOUT)) S DONE=1 Q
"RTN","CHTDISEN",34,0)
I $D(DFOUT) S DONE=1 Q
"RTN","CHTDISEN",35,0)
I '$D(DFN) S DONE=1 Q
"RTN","CHTDISEN",36,0)
L +^AHCHVA(DFN):1 I '$T W !,"This file is locked by another user." K DFN X CHRESET G SELBEN
"RTN","CHTDISEN",37,0)
SELBEN1
"RTN","CHTDISEN",38,0)
I $D(DFN) X CHRESET D TOP^CHMEAV
"RTN","CHTDISEN",39,0)
D ^CHMEAV52 S (CHBEG,CHEND)=""
"RTN","CHTDISEN",40,0)
G SELBEN:$D(DUOUT)!($D(DTOUT))
"RTN","CHTDISEN",41,0)
G SELBEN1:'$D(BFN)
"RTN","CHTDISEN",42,0)
G SELBEN1:(BFN="")
"RTN","CHTDISEN",43,0)
I $D(DFOUT) S DONE=1
"RTN","CHTDISEN",44,0)
S GOTBENE=1
"RTN","CHTDISEN",45,0)
Q
"RTN","CHTDISEN",46,0)
ELIGDATE ;DISPLAY CURRENT ELIG DATES
"RTN","CHTDISEN",47,0)
S HASDT=0,DISENR=0,DECSD=0
"RTN","CHTDISEN",48,0)
D CKSTAT
"RTN","CHTDISEN",49,0)
Q:DISENR
"RTN","CHTDISEN",50,0)
Q:DECSD
"RTN","CHTDISEN",51,0)
F A=0:0 S A=$O(^AHCHVA(DFN,100,BFN,105,A)) Q:A="" F B=0:0 S B=$O(^AHCHVA(DFN,100,BFN,105,A,B)) Q:B="" S CHBEG=A,CHEND=B
"RTN","CHTDISEN",52,0)
I $D(^AHCHVA("SB",DFN,BFN)) W *7,!!,"Spina Bifida BENE - No CHAMPVA eligibility dates. " H 3 Q
"RTN","CHTDISEN",53,0)
I (CHBEG'?7N)!(CHEND'?7N) W *7,!!,"This bene has no eligibility dates!" H 3 Q
"RTN","CHTDISEN",54,0)
W !,?26,@CHBON,"ELIGIBILITY DATES",@CHBOFF
"RTN","CHTDISEN",55,0)
W !,?20,@CHULON,"Begin Date ",@CHULOFF,?45,@CHULON,"End Date ",@CHULOFF
"RTN","CHTDISEN",56,0)
W !
"RTN","CHTDISEN",57,0)
S X=CHBEG D DTPRT W ?20,Y
"RTN","CHTDISEN",58,0)
S X=CHEND D DTPRT W ?45,Y
"RTN","CHTDISEN",59,0)
S HASDT=1
"RTN","CHTDISEN",60,0)
Q
"RTN","CHTDISEN",61,0)
CKSTAT ;
"RTN","CHTDISEN",62,0)
Q:'$D(^AHCHVA(DFN,100,BFN,0))
"RTN","CHTDISEN",63,0)
I $P(^AHCHVA(DFN,100,BFN,0),"^",5)="D"&($P(^AHCHVA(DFN,100,BFN,0),"^",12)="DIS") S DISENR=1 W !,"This Beneficiary is in Disenrolled status.",! H 3 Q
"RTN","CHTDISEN",64,0)
I $P(^AHCHVA(DFN,100,BFN,0),"^",6)?7N S DECSD=1 W !,"Cannot disenroll a deceased Beneficiary.",! H 3 Q
"RTN","CHTDISEN",65,0)
Q
"RTN","CHTDISEN",66,0)
SBDATE
"RTN","CHTDISEN",67,0)
Q:DISENR
"RTN","CHTDISEN",68,0)
Q:DECSD
"RTN","CHTDISEN",69,0)
S %DT="AEPX",%DT("A")="Enter Disenrollment Date: ",%DT(0)="-NOW"
"RTN","CHTDISEN",70,0)
W ! D ^%DT K %DT
"RTN","CHTDISEN",71,0)
Q:Y=-1!($D(DUOUT))
"RTN","CHTDISEN",72,0)
I $D(DFOUT)!($D(DTOUT)) S DONE=1 Q
"RTN","CHTDISEN",73,0)
S NCHEND=Y
"RTN","CHTDISEN",74,0)
W !,@CHBON,"DISENROLLMENT DATE = ",@CHBOFF
"RTN","CHTDISEN",75,0)
S X=NCHEND D DTPRT W Y
"RTN","CHTDISEN",76,0)
W !!,*7,"Is this correct? N// " D SBRS G SBDATE:$D(DUOUT),END:$D(DFOUT)
"RTN","CHTDISEN",77,0)
I $D(DQOUT) D G SBDATE
"RTN","CHTDISEN",78,0)
.W !!,"Enter 'Y' if these are the correct dates."
"RTN","CHTDISEN",79,0)
G SBDATE:Y="" S Y=$E(Y) I "Yy"'[Y G SBDATE
"RTN","CHTDISEN",80,0)
S NCHENDM1=$$FMADD^XLFDT(NCHEND,-1,0,0,0) ;DISENROLLMENT DATE MINUS 1 (USED FOR ELIG END_DATE)
"RTN","CHTDISEN",81,0)
/* DOCUMENT DATE ---------------- */
"RTN","CHTDISEN",82,0)
SBDOCDT
"RTN","CHTDISEN",83,0)
S %DT="AEPX",%DT("A")="Enter the Disenrollment Document Date: ",%DT(0)="-NOW"
"RTN","CHTDISEN",84,0)
W ! D ^%DT K %DT
"RTN","CHTDISEN",85,0)
Q:Y=-1!($D(DUOUT))
"RTN","CHTDISEN",86,0)
I $D(DFOUT)!($D(DTOUT)) S DONE=1 Q
"RTN","CHTDISEN",87,0)
S DTDOC=Y
"RTN","CHTDISEN",88,0)
W !!,@CHBON,"DOCUMENT DATE = ",@CHBOFF
"RTN","CHTDISEN",89,0)
S X=DTDOC D DTPRT W Y
"RTN","CHTDISEN",90,0)
W !!,*7,"Is this correct? N// " D SBRS G SBDOCDT:$D(DUOUT),END:$D(DFOUT)
"RTN","CHTDISEN",91,0)
I $D(DQOUT) D G SBDOCDT
"RTN","CHTDISEN",92,0)
.W !!,"Enter 'Y' if these are the correct dates."
"RTN","CHTDISEN",93,0)
G SBDATE:Y="" S Y=$E(Y) I "Yy"'[Y G SBDOCDT
"RTN","CHTDISEN",94,0)
/*------------------------------ */
"RTN","CHTDISEN",95,0)
S CHIREA="DIS"
"RTN","CHTDISEN",96,0)
D NOW^%DTC S CHEDT=%
"RTN","CHTDISEN",97,0)
D SETSTAT
"RTN","CHTDISEN",98,0)
S ^AHCHVA(DFN,100,BFN,8)=1_"^"_DUZ_"^"_CHEDT ;TURN OFF AUTO-CALC
"RTN","CHTDISEN",99,0)
D UPD115
"RTN","CHTDISEN",100,0)
L
"RTN","CHTDISEN",101,0)
Q
"RTN","CHTDISEN",102,0)
NEWENDDT
"RTN","CHTDISEN",103,0)
S %DT="AEPX",%DT("A")="Enter Disenrollment Date: ",%DT(0)="-NOW"
"RTN","CHTDISEN",104,0)
W ! D ^%DT K %DT
"RTN","CHTDISEN",105,0)
Q:Y=-1!($D(DUOUT))
"RTN","CHTDISEN",106,0)
I $D(DFOUT)!($D(DTOUT)) S DONE=1 Q
"RTN","CHTDISEN",107,0)
S NCHEND=Y
"RTN","CHTDISEN",108,0)
W !,@CHBON,"DISENROLLMENT DATE = ",@CHBOFF
"RTN","CHTDISEN",109,0)
S X=NCHEND D DTPRT W Y
"RTN","CHTDISEN",110,0)
W !!,*7,"Is this correct? N// " D SBRS G NEWENDDT:$D(DUOUT),END:$D(DFOUT)
"RTN","CHTDISEN",111,0)
I $D(DQOUT) D G NEWENDDT
"RTN","CHTDISEN",112,0)
.W !!,"Enter 'Y' if these are the correct dates."
"RTN","CHTDISEN",113,0)
G NEWENDDT:Y="" S Y=$E(Y) I "Yy"'[Y G NEWENDDT
"RTN","CHTDISEN",114,0)
S NCHENDM1=$$FMADD^XLFDT(NCHEND,-1,0,0,0) ;DISENROLLMENT DATE MINUS 1 (USED FOR ELIG END_DATE)
"RTN","CHTDISEN",115,0)
/* DOCUMENT DATE ---------------- */
"RTN","CHTDISEN",116,0)
DOCDATE
"RTN","CHTDISEN",117,0)
S %DT="AEPX",%DT("A")="Enter the Disenrollment Document Date: ",%DT(0)="-NOW"
"RTN","CHTDISEN",118,0)
W ! D ^%DT K %DT
"RTN","CHTDISEN",119,0)
Q:Y=-1!($D(DUOUT))
"RTN","CHTDISEN",120,0)
I $D(DFOUT)!($D(DTOUT)) S DONE=1 Q
"RTN","CHTDISEN",121,0)
S DTDOC=Y
"RTN","CHTDISEN",122,0)
W !!,@CHBON,"DOCUMENT DATE = ",@CHBOFF
"RTN","CHTDISEN",123,0)
S X=DTDOC D DTPRT W Y
"RTN","CHTDISEN",124,0)
I Y>DT W !!,"Document Date may not be a Future Date." G DOCDATE
"RTN","CHTDISEN",125,0)
W !!,*7,"Is this correct? N// " D SBRS G DOCDATE:$D(DUOUT),END:$D(DFOUT)
"RTN","CHTDISEN",126,0)
I $D(DQOUT) D G DOCDATE
"RTN","CHTDISEN",127,0)
.W !!,"Enter 'Y' if these are the correct dates."
"RTN","CHTDISEN",128,0)
G DOCDATE:Y="" S Y=$E(Y) I "Yy"'[Y G DOCDATE
"RTN","CHTDISEN",129,0)
/*------------------------------ */
"RTN","CHTDISEN",130,0)
S CHIREA="DIS"
"RTN","CHTDISEN",131,0)
D NOW^%DTC S CHEDT=%
"RTN","CHTDISEN",132,0)
D SETSTAT
"RTN","CHTDISEN",133,0)
S ^AHCHVA(DFN,100,BFN,8)=1_"^"_DUZ_"^"_CHEDT ;TURN OFF AUTO-CALC
"RTN","CHTDISEN",134,0)
D LAST109
"RTN","CHTDISEN",135,0)
D NEW105
"RTN","CHTDISEN",136,0)
D UPD115
"RTN","CHTDISEN",137,0)
L
"RTN","CHTDISEN",138,0)
Q
"RTN","CHTDISEN",139,0)
SETSTAT
"RTN","CHTDISEN",140,0)
S NEWSTAT="D"
"RTN","CHTDISEN",141,0)
K ^AHCHVA("AF",OLDSTAT,DFN,BFN)
"RTN","CHTDISEN",142,0)
I $D(^AHCHVA("AF","PR",DFN,BFN)) K ^AHCHVA("AF","PR",DFN,BFN) ;"PR" XREF is currently not getting removed by the Elig module.
"RTN","CHTDISEN",143,0)
S ^AHCHVA("AF",NEWSTAT,DFN,BFN)=""
"RTN","CHTDISEN",144,0)
S $P(^AHCHVA(DFN,100,BFN,0),"^",5)=NEWSTAT ;BENE STATUS
"RTN","CHTDISEN",145,0)
S $P(^AHCHVA(DFN,100,BFN,0),"^",11)=$P(CHEDT,".",1) ;STATUS DATE
"RTN","CHTDISEN",146,0)
S $P(^AHCHVA(DFN,100,BFN,0),"^",12)=CHIREA ;INELIGIBLE REASON
"RTN","CHTDISEN",147,0)
S $P(^AHCHVA(DFN,100,BFN,0),"^",13)="" ;ELIGIBLE REASON
"RTN","CHTDISEN",148,0)
S $P(^AHCHVA(DFN,101,CHEDT,100,BFN,0),"^",5)="D" ;STATUS
"RTN","CHTDISEN",149,0)
S $P(^AHCHVA(DFN,101,CHEDT,100,BFN,0),"^",11)=$P(CHEDT,".",1) ;STATUS DATE
"RTN","CHTDISEN",150,0)
S $P(^AHCHVA(DFN,101,CHEDT,100,BFN,0),"^",12)=CHIREA ;INELIGIBLE REASON
"RTN","CHTDISEN",151,0)
S $P(^AHCHVA(DFN,101,CHEDT,100,BFN,0),"^",13)="@"_NEWSTAT ;ELIGIBLE REASON
"RTN","CHTDISEN",152,0)
S $P(^AHCHVA(DFN,101,CHEDT,100,BFN,0),"^",16)=0 ;SPOUSE DIVORCE FR SPONSOR - NO
"RTN","CHTDISEN",153,0)
S ^AHCHVA(DFN,101,CHEDT,100,BFN,99)=CHEDT_"^"_DUZ_"^"_"DISENROLLMENT" ;EDIT DATE, EDIT USER, EDIT COMMENT
"RTN","CHTDISEN",154,0)
W #
"RTN","CHTDISEN",155,0)
W !,"Beneficiary "_$P(^AHCHVA(DFN,100,BFN,0),"^")_" ("_$P(^AHCHVA(DFN,100,BFN,0),"^",9)_") has been set to Disenrolled status."
"RTN","CHTDISEN",156,0)
W !,"Disenrollment Date = " S X=NCHEND D DTPRT W Y
"RTN","CHTDISEN",157,0)
W !,"Disenrollment Document Date = " S X=DTDOC D DTPRT W Y,!
"RTN","CHTDISEN",158,0)
H 5
"RTN","CHTDISEN",159,0)
X CHRESET
"RTN","CHTDISEN",160,0)
;W !,?(80-$L(TL))/2,@CHBON,TL,@CHBOFF
"RTN","CHTDISEN",161,0)
Q
"UP",554801,554801.01,-1)
554801^100
"UP",554801,554801.01,0)
554801.01
"UP",554801,554801.03,-2)
554801^101
"UP",554801,554801.03,-1)
554801.02^100
"UP",554801,554801.03,0)
554801.03
"VER")
8.0^22.2
"^DD",554801,554801,10.12,0)
SB - STATUS^S^R:RE-ENROLLED;D:DISENROLLED;^ENUM;2^Q
"^DD",554801,554801,10.12,"DT")
3170718
"^DD",554801,554801.01,11.01,0)
SB - STATUS^RS^REE:RE-ENROLLED;DIS:DISENROLLED;ENR:ENROLLED;DEC:DECEASED;^11;1^Q
"^DD",554801,554801.01,11.01,"DT")
3170718
"^DD",554801,554801.03,11.01,0)
SB - STATUS^RS^REE:RE-ENROLLED;DIS:DISENROLLED;ENR:ENROLLED;DEC:DECEASED;^11;1^Q
"^DD",554801,554801.03,11.01,3)
ENTER THE STATUS FROM THE GIVEN SET OF CODES
"^DD",554801,554801.03,11.01,"DT")
3170502
"^DD",554801,554801.03,11.02,0)
SB - STATUS DATE^D^^11;2^S %DT="E" D ^%DT S X=Y K:Y<1 X
"^DD",554801,554801.03,11.02,3)
ENTER THE STATUS DATE
"^DD",554801,554801.03,11.02,"DT")
3170502
"^DD",554801,554801.03,11.03,0)
SB - INELIGIBLE REASON^S^1:DISENROLLMENT;2:DECEASED;^11;3^Q
"^DD",554801,554801.03,11.03,3)
"^DD",554801,554801.03,11.03,"DT")
3170502
"^DD",554801,554801.03,11.04,0)
SB - ELIGIBLE REASON^S^1:RE-ENROLLMENT;2:ENROLLED;^11;4^Q
"^DD",554801,554801.03,11.04,3)
ENTER ELIGIBLE REASON
"^DD",554801,554801.03,11.04,"DT")
3170502
"^DD",554801,554801.03,11.05,0)
SB - INELIG REASON DOC^P741003.01'^AHADIC(741003.01,^11;5^Q
"^DD",554801,554801.03,11.05,3)
ENTER INELIG REASON DOCUMENT
"^DD",554801,554801.03,11.05,"DT")
3170502
"^DD",554801,554801.03,11.06,0)
SB - ELIG REASON DOC^P741003.01'^AHADIC(741003.01,^11;6^Q
"^DD",554801,554801.03,11.06,3)
ENTER ELIG REASON DOCUMENT
"^DD",554801,554801.03,11.06,"DT")
3170502
**END**
**END**