DG_53_P842.KID

KIDS Distribution saved on May 17, 2012@12:08:22
ESR 3.6 Pension Data Sharing project VistA changes.
**KIDS**:DG*5.3*842^IVM*2.0*150^

**INSTALL NAME**
DG*5.3*842
"BLD",8193,0)
DG*5.3*842^REGISTRATION^0^3120517^y
"BLD",8193,1,0)
^^3^3^3110818^
"BLD",8193,1,1,0)
This patch contains VistA changes to support technology and business
"BLD",8193,1,2,0)
changes that are occurring with the implementation of Pension Data 
"BLD",8193,1,3,0)
Sharing.
"BLD",8193,4,0)
^9.64PA^27.18^2
"BLD",8193,4,2,0)
2
"BLD",8193,4,2,2,0)
^9.641^2^1
"BLD",8193,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",8193,4,2,2,2,1,0)
^9.6411^.36235^12
"BLD",8193,4,2,2,2,1,.36235,0)
RECEIVING A VA PENSION?
"BLD",8193,4,2,2,2,1,.3851,0)
PENSION AWARD EFFECTIVE DATE
"BLD",8193,4,2,2,2,1,.3852,0)
PENSION AWARD REASON CODE
"BLD",8193,4,2,2,2,1,.3853,0)
PENSION TERMINATED DATE
"BLD",8193,4,2,2,2,1,.3854,0)
PENSION TERMINATED REASON1
"BLD",8193,4,2,2,2,1,.3855,0)
PENSION TERMINATED REASON2
"BLD",8193,4,2,2,2,1,.3856,0)
PENSION TERMINATED REASON3
"BLD",8193,4,2,2,2,1,.3857,0)
PENSION TERMINATED REASON4
"BLD",8193,4,2,2,2,1,.3858,0)
CLASS II DENTAL INDICATOR
"BLD",8193,4,2,2,2,1,.3859,0)
DENTAL APPL DUE BEFORE DATE
"BLD",8193,4,2,2,2,1,.386,0)
PENSION INDICATOR LOCK
"BLD",8193,4,2,2,2,1,.3861,0)
PENSION AWARD LOCK
"BLD",8193,4,2,222)
y^n^p^^^^n^^n
"BLD",8193,4,2,224)

"BLD",8193,4,27.18,0)
27.18
"BLD",8193,4,27.18,222)
y^n^f^^n^^y^o^n
"BLD",8193,4,"APDD",2,2)

"BLD",8193,4,"APDD",2,2,.36235)

"BLD",8193,4,"APDD",2,2,.3851)

"BLD",8193,4,"APDD",2,2,.3852)

"BLD",8193,4,"APDD",2,2,.3853)

"BLD",8193,4,"APDD",2,2,.3854)

"BLD",8193,4,"APDD",2,2,.3855)

"BLD",8193,4,"APDD",2,2,.3856)

"BLD",8193,4,"APDD",2,2,.3857)

"BLD",8193,4,"APDD",2,2,.3858)

"BLD",8193,4,"APDD",2,2,.3859)

"BLD",8193,4,"APDD",2,2,.386)

"BLD",8193,4,"APDD",2,2,.3861)

"BLD",8193,4,"B",2,2)

"BLD",8193,4,"B",27.18,27.18)

"BLD",8193,6)
1^
"BLD",8193,6.3)
33
"BLD",8193,"ABPKG")
n
"BLD",8193,"INI")
EN^DG53842P
"BLD",8193,"INID")
^^n
"BLD",8193,"KRN",0)
^9.67PA^779.2^20
"BLD",8193,"KRN",.4,0)
.4
"BLD",8193,"KRN",.401,0)
.401
"BLD",8193,"KRN",.402,0)
.402
"BLD",8193,"KRN",.402,"NM",0)
^9.68A^1^1
"BLD",8193,"KRN",.402,"NM",1,0)
DG LOAD EDIT SCREEN 7    FILE #2^2^0
"BLD",8193,"KRN",.402,"NM","B","DG LOAD EDIT SCREEN 7    FILE #2",1)

"BLD",8193,"KRN",.403,0)
.403
"BLD",8193,"KRN",.5,0)
.5
"BLD",8193,"KRN",.84,0)
.84
"BLD",8193,"KRN",3.6,0)
3.6
"BLD",8193,"KRN",3.8,0)
3.8
"BLD",8193,"KRN",9.2,0)
9.2
"BLD",8193,"KRN",9.8,0)
9.8
"BLD",8193,"KRN",9.8,"NM",0)
^9.68A^14^14
"BLD",8193,"KRN",9.8,"NM",1,0)
DGRP7^^0^B19041748
"BLD",8193,"KRN",9.8,"NM",2,0)
DGRP7CP^^0^B20220559
"BLD",8193,"KRN",9.8,"NM",3,0)
DGRP6^^0^B18281969
"BLD",8193,"KRN",9.8,"NM",4,0)
DGRPE^^0^B53481298
"BLD",8193,"KRN",9.8,"NM",5,0)
DGENPTA^^0^B48293501
"BLD",8193,"KRN",9.8,"NM",6,0)
DGENPTA1^^0^B25498748
"BLD",8193,"KRN",9.8,"NM",7,0)
DGENUPL1^^0^B41786889
"BLD",8193,"KRN",9.8,"NM",8,0)
DGENUPL2^^0^B78421208
"BLD",8193,"KRN",9.8,"NM",9,0)
DGENUPLB^^0^B9493909
"BLD",8193,"KRN",9.8,"NM",10,0)
VAFHLZE2^^0^B3792068
"BLD",8193,"KRN",9.8,"NM",11,0)
DGENUPL4^^0^B87089440
"BLD",8193,"KRN",9.8,"NM",12,0)
DG53842P^^0^B247157
"BLD",8193,"KRN",9.8,"NM",13,0)
DGRPH^^0^B25194652
"BLD",8193,"KRN",9.8,"NM",14,0)
DGRPV^^0^B18383656
"BLD",8193,"KRN",9.8,"NM","B","DG53842P",12)

"BLD",8193,"KRN",9.8,"NM","B","DGENPTA",5)

"BLD",8193,"KRN",9.8,"NM","B","DGENPTA1",6)

"BLD",8193,"KRN",9.8,"NM","B","DGENUPL1",7)

"BLD",8193,"KRN",9.8,"NM","B","DGENUPL2",8)

"BLD",8193,"KRN",9.8,"NM","B","DGENUPL4",11)

"BLD",8193,"KRN",9.8,"NM","B","DGENUPLB",9)

"BLD",8193,"KRN",9.8,"NM","B","DGRP6",3)

"BLD",8193,"KRN",9.8,"NM","B","DGRP7",1)

"BLD",8193,"KRN",9.8,"NM","B","DGRP7CP",2)

"BLD",8193,"KRN",9.8,"NM","B","DGRPE",4)

"BLD",8193,"KRN",9.8,"NM","B","DGRPH",13)

"BLD",8193,"KRN",9.8,"NM","B","DGRPV",14)

"BLD",8193,"KRN",9.8,"NM","B","VAFHLZE2",10)

"BLD",8193,"KRN",19,0)
19
"BLD",8193,"KRN",19.1,0)
19.1
"BLD",8193,"KRN",101,0)
101
"BLD",8193,"KRN",409.61,0)
409.61
"BLD",8193,"KRN",771,0)
771
"BLD",8193,"KRN",779.2,0)
779.2
"BLD",8193,"KRN",870,0)
870
"BLD",8193,"KRN",8989.51,0)
8989.51
"BLD",8193,"KRN",8989.52,0)
8989.52
"BLD",8193,"KRN",8994,0)
8994
"BLD",8193,"KRN","B",.4,.4)

"BLD",8193,"KRN","B",.401,.401)

"BLD",8193,"KRN","B",.402,.402)

"BLD",8193,"KRN","B",.403,.403)

"BLD",8193,"KRN","B",.5,.5)

"BLD",8193,"KRN","B",.84,.84)

"BLD",8193,"KRN","B",3.6,3.6)

"BLD",8193,"KRN","B",3.8,3.8)

"BLD",8193,"KRN","B",9.2,9.2)

"BLD",8193,"KRN","B",9.8,9.8)

"BLD",8193,"KRN","B",19,19)

"BLD",8193,"KRN","B",19.1,19.1)

"BLD",8193,"KRN","B",101,101)

"BLD",8193,"KRN","B",409.61,409.61)

"BLD",8193,"KRN","B",771,771)

"BLD",8193,"KRN","B",779.2,779.2)

"BLD",8193,"KRN","B",870,870)

"BLD",8193,"KRN","B",8989.51,8989.51)

"BLD",8193,"KRN","B",8989.52,8989.52)

"BLD",8193,"KRN","B",8994,8994)

"BLD",8193,"QUES",0)
^9.62^^
"BLD",8193,"REQB",0)
^9.611^4^2
"BLD",8193,"REQB",1,0)
DG*5.3*841^2
"BLD",8193,"REQB",4,0)
DG*5.3*763^2
"BLD",8193,"REQB","B","DG*5.3*763",4)

"BLD",8193,"REQB","B","DG*5.3*841",1)

"DATA",27.18,1,0)
Accrued Payable - Reimbursement^APREIM
"DATA",27.18,2,0)
Accrued Payable - Relationship^APRLN
"DATA",27.18,3,0)
Additional Disability Withholding^ADW
"DATA",27.18,4,0)
Adjusted Protected 1978 IVAP^AP78IVAP
"DATA",27.18,5,0)
Administrative Error^ADMERR
"DATA",27.18,6,0)
Allotment Adjustment^37
"DATA",27.18,7,0)
Apportionment Granted^AG
"DATA",27.18,8,0)
Apportionment Rate Change^ARC
"DATA",27.18,9,0)
Apportionment Terminated^AT
"DATA",27.18,10,0)
Award Rate Overridden Due to Change in Legislation^ARODCL
"DATA",27.18,11,0)
Award Rate Overridden Due to System Error^ARODSE
"DATA",27.18,12,0)
Beneficiary Error^BENEERR
"DATA",27.18,13,0)
Benefit Change to Compensation^03
"DATA",27.18,14,0)
Benefit Change to Improved Pension^10
"DATA",27.18,15,0)
Benefit Eligibility Adjustment^04
"DATA",27.18,16,0)
Benefit Eligibility Adjustment - Pension^11
"DATA",27.18,17,0)
CONV - Adjustment (Child Award)^CONVAWD40
"DATA",27.18,18,0)
CONV - Change of Payee or Suspended^CONVAWD31
"DATA",27.18,19,0)
CONV - Character of Discharge is a Bar^CONVAWD03
"DATA",27.18,20,0)
CONV - Child in Another Award Reaches 18^CONVAWD44
"DATA",27.18,21,0)
CONV - Child in Another Award Terminates School^CONVAWD45
"DATA",27.18,22,0)
CONV - Computer Substitute^CONVAWD90
"DATA",27.18,23,0)
CONV - Dependent Added^CONVAWD26
"DATA",27.18,24,0)
CONV - Disability Not Permanent and Total^CONVAWD10
"DATA",27.18,25,0)
CONV - Disability Not Shown at Last Exam^CONVAWD07
"DATA",27.18,26,0)
CONV - Disability Not Shown by Evidence^CONVAWD08
"DATA",27.18,27,0)
CONV - Disability Zero Percent^CONVAWD05
"DATA",27.18,28,0)
CONV - Disability or Death Not Due to Service^CONVAWD06
"DATA",27.18,29,0)
CONV - Disability/Death Not in Line of Duty^CONVAWD09
"DATA",27.18,30,0)
CONV - Election of VA or Other Benefits^CONVAWD30
"DATA",27.18,31,0)
CONV - Failure to Report for Examination^CONVAWD17
"DATA",27.18,32,0)
CONV - Grant Of A/A For Spouse^CONVSPSAA
"DATA",27.18,33,0)
CONV - Insufficient or No Qualifying Service^CONVAWD02
"DATA",27.18,34,0)
CONV - No Military Service^CONVAWD01
"DATA",27.18,35,0)
CONV - Other Reason^CONVAWD29
"DATA",27.18,36,0)
CONV - Payment of Attorney Fees^CONVAWD57
"DATA",27.18,37,0)
CONV - Protected Rate^CONVAWD96
"DATA",27.18,38,0)
CONV - Reduction Due to Award of DEA^CONVAWD41
"DATA",27.18,39,0)
CONV - Relationship Not Established^CONVAWD14
"DATA",27.18,40,0)
CONV - Retire Pay (Spec Law 06) On Awd Line^CONVRETPAY
"DATA",27.18,41,0)
CONV - SEV/SEP/TORT Contained in Monthly Adjsmt^CONVMTHADJ
"DATA",27.18,42,0)
CONV - SEV/SEP/TORT Offset & RMNG BAL Starts Here^CONVOFFSET
"DATA",27.18,43,0)
CONV - Undetermined Withholding^CONVWTH
"DATA",27.18,44,0)
CONV - Veteran - Surviving Spouse Hospitalized^CONVAWD35
"DATA",27.18,45,0)
CONV - Veteran on Active Duty/Drill Pay Adjustment^CONVAWD19
"DATA",27.18,46,0)
Change in Disability Level^CIDL
"DATA",27.18,47,0)
Change in Number of Parents^CINOP
"DATA",27.18,48,0)
Change in Parent Status^24
"DATA",27.18,49,0)
Change in Spouse Status^23
"DATA",27.18,50,0)
Child Conceived Prior to Vietnam Service^CCPTVS
"DATA",27.18,51,0)
Child Deceased^CHDP1201
"DATA",27.18,52,0)
Child Status Change^CHSC
"DATA",27.18,53,0)
Compensation Rating Adjustment^31
"DATA",27.18,54,0)
Conversion PFOP^CONVPFOP
"DATA",27.18,55,0)
Conversion Recoup and PFOP^CONVPFOPRCP
"DATA",27.18,56,0)
Conversion Recoupment^CONVRCP
"DATA",27.18,57,0)
Converted Award^CONVAWD
"DATA",27.18,58,0)
Cost of Living Adjustment^02
"DATA",27.18,59,0)
Countable Income Adjustment^15
"DATA",27.18,60,0)
Custody Status Change^CUSC
"DATA",27.18,61,0)
DIC Spouse Award Status Change^DSASC
"DATA",27.18,62,0)
DIC-Spouse Minor Child Rate Adjustment^41
"DATA",27.18,63,0)
Death of Beneficiary^DB
"DATA",27.18,64,0)
Disability Due to a Familial Disorder^DDFDISOR
"DATA",27.18,65,0)
Disability Not Permanent^DNPERM
"DATA",27.18,66,0)
Disability Not Related to Vietnam Service^DNRVIET
"DATA",27.18,67,0)
Disability a Result of Birth Related Injury^DRBRINJ
"DATA",27.18,68,0)
Disability a Result of Fetal/Neo-natal Infirmity^DRFNEOIFM
"DATA",27.18,69,0)
Discharge Adjustment^DISCADJ
"DATA",27.18,70,0)
Drill Pay Adjustment^07
"DATA",27.18,71,0)
EVR Adjustment^EVRADJ
"DATA",27.18,72,0)
Eligible Helpless Child^EHC
"DATA",27.18,73,0)
Eligible School Child^ESC
"DATA",27.18,74,0)
Entitled to A&A^ETAA
"DATA",27.18,75,0)
Entitled to MOD Benefit^MOD
"DATA",27.18,76,0)
Estate Adjustment^08
"DATA",27.18,77,0)
Failed to Furnish Requested Evidence^FFRE
"DATA",27.18,78,0)
Forfeiture^FORF
"DATA",27.18,79,0)
Fraud^FRD
"DATA",27.18,80,0)
Fraud Adjustment^FRDADJ
"DATA",27.18,81,0)
Fugitive Felon^FF
"DATA",27.18,82,0)
Gain of Dependent^GD
"DATA",27.18,83,0)
Gross Rate Additional Amount^GRAA
"DATA",27.18,84,0)
Gross Rate Replacement Amount^GRRA
"DATA",27.18,85,0)
Helpless Child Adjustment^20
"DATA",27.18,86,0)
Hospitalized Basic Pension Adjustment^01
"DATA",27.18,87,0)
Hospitalized SMC Adjustment^38
"DATA",27.18,88,0)
IVM Adjustment^IVMADJ
"DATA",27.18,89,0)
Incarceration Adjustment^13
"DATA",27.18,90,0)
Individual Unemployability Adjustment^14
"DATA",27.18,91,0)
Institutionalization Adjustment^INSTADJ
"DATA",27.18,92,0)
Loss of Dependent^LD
"DATA",27.18,93,0)
Manually Entered Rate^MER
"DATA",27.18,94,0)
Maximum Annual Pension Rate^16
"DATA",27.18,95,0)
Medicaid Adjustment^17
"DATA",27.18,96,0)
Minor Child Adjustment^21
"DATA",27.18,97,0)
Net Worth Adjustment^18
"DATA",27.18,98,0)
No Entitlement to Benefit Sought^NETBS
"DATA",27.18,99,0)
No Longer A&A^NLAA
"DATA",27.18,100,0)
No Longer Helpless^NLH
"DATA",27.18,101,0)
No Qualifying Birth Defect Exists^NQBDEFCT
"DATA",27.18,102,0)
No Qualifying Vietnam Service^NQVIET
"DATA",27.18,103,0)
No Spina Bifida Condition Exists^NSBCE
"DATA",27.18,104,0)
Not Currently Disabling^NCD
"DATA",27.18,105,0)
Not a Natural Child of the Veteran^NNCOV
"DATA",27.18,106,0)
Original Award^00
"DATA",27.18,107,0)
Original Grant by SSA^OGBSSA
"DATA",27.18,108,0)
Other^OTH
"DATA",27.18,109,0)
Other Concurrent Entitlement Adjustment^25
"DATA",27.18,110,0)
Other Recoupment^26
"DATA",27.18,111,0)
Other Withholding Adjustment^39
"DATA",27.18,112,0)
Parent Marital Status Change^PMSC
"DATA",27.18,113,0)
Parent's Vietnam Service NOT Established^PVNSE
"DATA",27.18,114,0)
Pension Rating Adjustment^27
"DATA",27.18,115,0)
Philippine Adjustment^PA
"DATA",27.18,116,0)
Preserve Net Rate Amount^PNRA
"DATA",27.18,117,0)
RECA Adjustment^28
"DATA",27.18,118,0)
Rating Effective Date Backed UP For Conversion^CONVRATGBKUP
"DATA",27.18,119,0)
Rating Effective Date for Conversion^CONVRATGEFDT
"DATA",27.18,120,0)
Recoupment of Disability Severance Pay^06
"DATA",27.18,121,0)
Recoupment of Separation Pay^30
"DATA",27.18,122,0)
Recoupment of Tort Settlement^34
"DATA",27.18,123,0)
Recurring Benefit Established^RBE
"DATA",27.18,124,0)
Reduction Due to Administrative Error^REDADMERR
"DATA",27.18,125,0)
Renouncement^REN
"DATA",27.18,126,0)
Reopened Award^REOPNAWD
"DATA",27.18,127,0)
Retired Pay Adjustment^29
"DATA",27.18,128,0)
Reverify Entitlement Annually^REA
"DATA",27.18,129,0)
SSA Rate Change^SSARC
"DATA",27.18,130,0)
School Child Adjustment^22
"DATA",27.18,131,0)
Special Monthly Compensation Adjustment^32
"DATA",27.18,132,0)
Special Monthly Entitlement Adjustment^40
"DATA",27.18,133,0)
Special Monthly Pension Adjustment^33
"DATA",27.18,134,0)
Spina Bifida Occulta^SBO
"DATA",27.18,135,0)
Terminated by SSA^TSSA
"DATA",27.18,136,0)
Terminated by SSA-Excessive Earnings^TSSAEE
"DATA",27.18,137,0)
Terminated by SSA-Marriage^TSSAM
"DATA",27.18,138,0)
Terminated by SSA-Marriage of Surviving Spouse^TSSAMOSS
"DATA",27.18,139,0)
Terminated by SSA-Turns 18^TSSAT18
"DATA",27.18,140,0)
Terminated by SSA-Widow Under 60 w/No Dependent^TSSAWU60WND
"DATA",27.18,141,0)
Terminated-Age 18^TA18
"DATA",27.18,142,0)
Terminated-Age 23^TA23
"DATA",27.18,143,0)
Terminated-CH 18 Birth Defects is Greater^TERMCH18
"DATA",27.18,144,0)
Terminated-Change to Compensation^TCTC
"DATA",27.18,145,0)
Terminated-Elected Chapter 35^TEC35
"DATA",27.18,146,0)
Terminated-Elected Compensation^TEC
"DATA",27.18,147,0)
Terminated-Elected DIC^TEDIC
"DATA",27.18,148,0)
Terminated-Elected Improved Pension^TEIP
"DATA",27.18,149,0)
Terminated-Elected Under 0th Parent-Same Par Line^TEUOPISPL
"DATA",27.18,150,0)
Terminated-IVAP^TIVAP
"DATA",27.18,151,0)
Terminated-Incarceration^TI
"DATA",27.18,152,0)
Terminated-Incarceration/No Apportionment^TINA
"DATA",27.18,153,0)
Terminated-Marriage^TM
"DATA",27.18,154,0)
Terminated-Net Worth^TNW
"DATA",27.18,155,0)
Terminated-No Longer Dependent^TNLD
"DATA",27.18,156,0)
Terminated-No Longer Helpless^TNLH
"DATA",27.18,157,0)
Terminated-Other^TO
"DATA",27.18,158,0)
Terminated-School Termination^TST
"DATA",27.18,159,0)
Total Withholding Adjustment^05
"DATA",27.18,160,0)
Total Withholding Adjustment - Pension^12
"DATA",27.18,161,0)
Treason^TRE
"DATA",27.18,162,0)
Undetermined BDN Apportionment Paid/Due Audit Reqd Veteran NOT Female^CONVAPPOR
"DATA",27.18,163,0)
Veteran NOT Female^VETNFEM
"DATA",27.18,164,0)
Whereabouts Unknown^WHUNK
"DATA",27.18,165,0)
Workers Compensation Adjustment^36
"FIA",2)
PATIENT
"FIA",2,0)
^DPT(
"FIA",2,0,0)
2I
"FIA",2,0,1)
y^n^p^^^^n^^n
"FIA",2,0,10)

"FIA",2,0,11)

"FIA",2,0,"RLRO")

"FIA",2,0,"VR")
5.3^DG
"FIA",2,2)
1
"FIA",2,2,.36235)

"FIA",2,2,.3851)

"FIA",2,2,.3852)

"FIA",2,2,.3853)

"FIA",2,2,.3854)

"FIA",2,2,.3855)

"FIA",2,2,.3856)

"FIA",2,2,.3857)

"FIA",2,2,.3858)

"FIA",2,2,.3859)

"FIA",2,2,.386)

"FIA",2,2,.3861)

"FIA",27.18)
PENSION AWARD REASONS
"FIA",27.18,0)
^DG(27.18,
"FIA",27.18,0,0)
27.18
"FIA",27.18,0,1)
y^n^f^^n^^y^o^n
"FIA",27.18,0,10)

"FIA",27.18,0,11)

"FIA",27.18,0,"RLRO")

"FIA",27.18,0,"VR")
5.3^DG
"FIA",27.18,27.18)
0
"INI")
EN^DG53842P
"KRN",.402,420,-1)
0^1
"KRN",.402,420,0)
DG LOAD EDIT SCREEN 7^3120510.1004^^2^^^3120517
"KRN",.402,420,"%D",0)
^.4021^1^1^3110428^^^^
"KRN",.402,420,"%D",1,0)
This template is used to enter/edit data on registration screen 7.
"KRN",.402,420,"DIAB",1,1,2.05,0)
ALL
"KRN",.402,420,"DIAB",6,0,2,2)
PENSION AWARD EFFECTIVE DATE///"@"
"KRN",.402,420,"DIAB",7,0,2,4)
PENSION AWARD REASON///"@"
"KRN",.402,420,"DIAB",8,0,2,2)
PENSION AWARD REASON///"@"
"KRN",.402,420,"DR",1,2)
S:DGDR'["701" Y="@702";391;D SC7^DGRPV;1901;.301;S:X'="Y" Y=.293;.302;.3012;.305;I $P($G(^DPT(DFN,.361)),U)="V" I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@293";.304;S:X'="Y" Y=.293;.3013;S Y=.293;@293;
"KRN",.402,420,"DR",1,2,1)
W !,"No editing P&T Data, Eligibility record verified by HEC";.293;S:'X Y=.313;.292;.291;.313;.314;@702;S:DGDR'["702" Y="@703";.36205;.36215;S:$P($G(^DPT(DFN,.385)),U,11)="Y" Y="@7025";
"KRN",.402,420,"DR",1,2,2)
S:($P($G(^DPT(DFN,.385)),U,10)="Y")&($P($G(^DPT(DFN,.362)),U,14)="N") Y="@7025";S:$P($G(^DPT(DFN,.385)),U,10)="Y" Y="@7022";.36235;I X="Y" S Y="@7022";Q;.3851///^S X="@";Q;.3852///^S X="@";S Y="@7026";@7022;
"KRN",.402,420,"DR",1,2,3)
S:($P($G(^DPT(DFN,.385)),U,10)'="Y") Y="@7023";D EN^DDIOL("Pension Award Date and Pension Award Reason are editable only if VA Pension","","!!");
"KRN",.402,420,"DR",1,2,4)
D EN^DDIOL("Indicator is Yes and Pension Award Reason is not 'Original Award'.  For any","","!");D EN^DDIOL("other assistance, use the HEC Alert process.","","!");@7023;.3851;I X]"" S Y="@7024";Q;.3852///^S X="@";S Y="@7026";@7024;
"KRN",.402,420,"DR",1,2,5)
.3852;I X="" S Y="@7026";I X=$$GET1^DIQ(2,DFN,.3852,"I") S Y="@7026";I $$GET1^DIQ(27.18,X,.01,"E")'["Original Award" D EN^DDIOL("Only 'Original Award' may be entered",,"!!") S Y="@7024";S Y="@7026";@7025;
"KRN",.402,420,"DR",1,2,6)
D EN^DDIOL("Pension Award Date and Pension Award Reason are editable only if VA Pension","","!!");D EN^DDIOL("Indicator is Yes and Pension Award Reason is not 'Original Award'.  For any","","!");
"KRN",.402,420,"DR",1,2,7)
D EN^DDIOL("other assistance, use the HEC Alert process.","","!");@7026;.3025;S:(X'="Y")&($P($G(^DPT(DA,.362)),U,12,14)'["Y") Y=.36265;.36295;.36265;S:X'="Y" Y="@703";.3626;@703;S:DGDR'["703" Y="@704";.361;
"KRN",.402,420,"DR",1,2,8)
D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361;.309;361;.323;D ^DGYZODS S:'DGODS Y="@704";11500.02;11500.03;@704;S:DGDR'["704" Y="@99";.3731;@99;
"KRN",.402,420,"DR",2,2.0361)
.01;
"KRN",.402,420,"DR",2,2.05)
.01:.02
"KRN",.402,420,"ROU")
^DGRPX7
"KRN",.402,420,"ROUOLD")
DGRPX7
"MBREQ")
0
"ORD",7,.402)
.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%)
"ORD",7,.402,0)
INPUT TEMPLATE
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
842^3120517^100992
"PKG",47,22,1,"PAH",1,1,0)
^^3^3^3120517
"PKG",47,22,1,"PAH",1,1,1,0)
This patch contains VistA changes to support technology and business
"PKG",47,22,1,"PAH",1,1,2,0)
changes that are occurring with the implementation of Pension Data 
"PKG",47,22,1,"PAH",1,1,3,0)
Sharing.
"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")
14
"RTN","DG53842P")
0^12^B247157
"RTN","DG53842P",1,0)
DG53842P ;ALB/BDB - PRE-INSTALL DG*5.3*842;AUG 18, 2011
"RTN","DG53842P",2,0)
 ;;5.3;Registration;**842**;Aug 13, 1993;Build 33
"RTN","DG53842P",3,0)
 Q
"RTN","DG53842P",4,0)
EN ;Pre-install entry point
"RTN","DG53842P",5,0)
 ;Pre-install process to delete the old X-Ref trigger in
"RTN","DG53842P",6,0)
 ;PATIENT file #2 for RECEIVING A VA PENSION? field #.36235
"RTN","DG53842P",7,0)
 D BMES^XPDUTL("Deleting trigger on RECEIVING A VA PENSION? field")
"RTN","DG53842P",8,0)
 D DELIX^DDMOD(2,.36235,1)
"RTN","DG53842P",9,0)
 Q
"RTN","DG53842P",10,0)
 ;
"RTN","DGENPTA")
0^5^B48293501
"RTN","DGENPTA",1,0)
DGENPTA ;ALB/CJM,ERC,CKN,TDM,PWC - Patient API - Retrieve Data ; 5/25/11 4:25pm
"RTN","DGENPTA",2,0)
 ;;5.3;Registration;**121,122,147,688,754,838,841,842**;Aug 13,1993;Build 33
"RTN","DGENPTA",3,0)
 ;
"RTN","DGENPTA",4,0)
VET(DFN) ;returns 1 if the patient is an eligible veteran
"RTN","DGENPTA",5,0)
 ;returns 0 if not a veteran or not eligible
"RTN","DGENPTA",6,0)
 ;
"RTN","DGENPTA",7,0)
 N VET S VET=0
"RTN","DGENPTA",8,0)
 I $G(DFN),$D(^DPT(DFN,0)) D
"RTN","DGENPTA",9,0)
 .S VET=1
"RTN","DGENPTA",10,0)
 .I $P($G(^DPT(DFN,"VET")),"^")="N" S VET=0
"RTN","DGENPTA",11,0)
 .I $P($G(^DPT(DFN,.15)),"^",2) S VET=0
"RTN","DGENPTA",12,0)
 Q VET
"RTN","DGENPTA",13,0)
 ;
"RTN","DGENPTA",14,0)
VET1(DFN) ;returns 1 if the patient is a veteran
"RTN","DGENPTA",15,0)
 ;returns 0 if not a veteran
"RTN","DGENPTA",16,0)
 ;
"RTN","DGENPTA",17,0)
 N VET S VET=0
"RTN","DGENPTA",18,0)
 I $G(DFN),$D(^DPT(DFN,0)) D
"RTN","DGENPTA",19,0)
 .I $P($G(^DPT(DFN,"VET")),"^")="Y" S VET=1
"RTN","DGENPTA",20,0)
 Q VET
"RTN","DGENPTA",21,0)
 ;
"RTN","DGENPTA",22,0)
ACTIVE(DFN,DGDT) ;
"RTN","DGENPTA",23,0)
 ;Description - Used to determine whether or not the patient has had a
"RTN","DGENPTA",24,0)
 ;  recent epiosode of inpatient or outpatient care.
"RTN","DGENPTA",25,0)
 ;Input:
"RTN","DGENPTA",26,0)
 ;  DFN - ien of record in Patient file
"RTN","DGENPTA",27,0)
 ;  DGDT - date used to specify how far back to go looking for episode
"RTN","DGENPTA",28,0)
 ;      of care
"RTN","DGENPTA",29,0)
 ;Output -
"RTN","DGENPTA",30,0)
 ;  returns 1 if recent episode of care, 0 otherwise
"RTN","DGENPTA",31,0)
 ;
"RTN","DGENPTA",32,0)
 ;!!!!!!! NOTE: This routine is not complete. !!!!!!!!!!!!!!!
"RTN","DGENPTA",33,0)
 ; Still need to define how user wants to define an 'active' patient.
"RTN","DGENPTA",34,0)
 ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
"RTN","DGENPTA",35,0)
 ;
"RTN","DGENPTA",36,0)
 Q 1
"RTN","DGENPTA",37,0)
 ;
"RTN","DGENPTA",38,0)
PREF(DFN,FACNAME) ;
"RTN","DGENPTA",39,0)
 ;Description: Used to determine the patient's preferred facility.
"RTN","DGENPTA",40,0)
 ;Input:
"RTN","DGENPTA",41,0)
 ;  DFN - an ien of a record in the PATIENT file
"RTN","DGENPTA",42,0)
 ;Output:     
"RTN","DGENPTA",43,0)
 ;  Function Value - Returns a pointer to the INSTITUTION file entry that
"RTN","DGENPTA",44,0)
 ;    is the patient's preferred facility, NULL if the preferred facility
"RTN","DGENPTA",45,0)
 ;    can not be determined.
"RTN","DGENPTA",46,0)
 ;  FACNAME - optional parm, pass by reference - returns institution name
"RTN","DGENPTA",47,0)
 ;
"RTN","DGENPTA",48,0)
 N FAC
"RTN","DGENPTA",49,0)
 S (FACNAME,FAC)=""
"RTN","DGENPTA",50,0)
 I $D(DFN),$D(^DPT(DFN,0)) S FAC=$P($G(^DPT(DFN,"ENR")),"^",2)
"RTN","DGENPTA",51,0)
 S:FAC FACNAME=$P($G(^DIC(4,FAC,0)),"^")
"RTN","DGENPTA",52,0)
 Q FAC
"RTN","DGENPTA",53,0)
 ;
"RTN","DGENPTA",54,0)
DEATH(DFN) ;
"RTN","DGENPTA",55,0)
 ;Description: Used to determine whether or not the patient is alive.
"RTN","DGENPTA",56,0)
 ;Input:
"RTN","DGENPTA",57,0)
 ;  DFN - an ien of a record in the PATIENT file
"RTN","DGENPTA",58,0)
 ;Output:     
"RTN","DGENPTA",59,0)
 ;  Function Value - Returns 0 if there is no record of the patient's
"RTN","DGENPTA",60,0)
 ;    death, otherwise returns the patients date of death
"RTN","DGENPTA",61,0)
 ;
"RTN","DGENPTA",62,0)
 N DATE S DATE=0
"RTN","DGENPTA",63,0)
 I $D(DFN),$D(^DPT(DFN,0)) S DATE=$P($G(^DPT(DFN,.35)),"^")
"RTN","DGENPTA",64,0)
 I DATE S DATE=(DATE\1) ;get rid of the time portion
"RTN","DGENPTA",65,0)
 Q +DATE
"RTN","DGENPTA",66,0)
 ;
"RTN","DGENPTA",67,0)
GET(DFN,DGPAT) ;
"RTN","DGENPTA",68,0)
 ;Description: Returns DGPAT() array with identifying info for patient
"RTN","DGENPTA",69,0)
 ;  Input:
"RTN","DGENPTA",70,0)
 ;    DFN - ien, PATIENT file
"RTN","DGENPTA",71,0)
 ;  Output:
"RTN","DGENPTA",72,0)
 ;    Function Value - 1 on success, 0 on failure
"RTN","DGENPTA",73,0)
 ;    DGPAT() array (pass by reference)
"RTN","DGENPTA",74,0)
 ;      "DEATH" - date of death
"RTN","DGENPTA",75,0)
 ;      "DFN" - ien, PATIENT file
"RTN","DGENPTA",76,0)
 ;      "DOB" - date of birth
"RTN","DGENPTA",77,0)
 ;      "INELDATE" - INELIGIBLE DATE
"RTN","DGENPTA",78,0)
 ;      "INELREA" - INELIGIBLE REASON
"RTN","DGENPTA",79,0)
 ;      "INELDEC" - INELIGIBLE VARO DECISION
"RTN","DGENPTA",80,0)
 ;      "NAME" - patient name
"RTN","DGENPTA",81,0)
 ;      "PATYPE" - patient type
"RTN","DGENPTA",82,0)
 ;      "PID" - Primary Long ID
"RTN","DGENPTA",83,0)
 ;      "PREFAC" - preferred facility
"RTN","DGENPTA",84,0)
 ;      "PFSRC" - preferred facility source designation
"RTN","DGENPTA",85,0)
 ;      "SSN" - Social Security Number
"RTN","DGENPTA",86,0)
 ;      "SEX" - M=male, F=female
"RTN","DGENPTA",87,0)
 ;      "VETERAN" - VETERAN (Y/N)? - "Y"=YES,"N"=NO
"RTN","DGENPTA",88,0)
 ;      "AG/ALLY" - Agency/Allied Country
"RTN","DGENPTA",89,0)
 ;      "SPININJ" - Spinal Cord Injury
"RTN","DGENPTA",90,0)
 ;      "MOH" - Medal of Honor
"RTN","DGENPTA",91,0)
 ;      "PENAEFDT" - Pension Award Effective Date
"RTN","DGENPTA",92,0)
 ;      "PENTRMDT" - Pension Terminated Date
"RTN","DGENPTA",93,0)
 ;      "PENAREAS" - Pension Award Reason
"RTN","DGENPTA",94,0)
 ;      "PENTRMR1" - Pension Terminated Reason 1
"RTN","DGENPTA",95,0)
 ;      "PENTRMR2" - Pension Terminated Reason 2
"RTN","DGENPTA",96,0)
 ;      "PENTRMR3" - Pension Terminated Reason 3
"RTN","DGENPTA",97,0)
 ;      "PENTRMR4" - Pension Terminated Reason 4
"RTN","DGENPTA",98,0)
 ;      "DENTC2IN" - Class II Dental Indicator - "Y"=YES,"N"=NO
"RTN","DGENPTA",99,0)
 ;      "DENTC2DT" - Dental Appl Due Before Date
"RTN","DGENPTA",100,0)
 ;      "PILOCK"   - Pension Indicator Lock
"RTN","DGENPTA",101,0)
 ;      "PALOCK"   - Pension Award Lock
"RTN","DGENPTA",102,0)
 ;
"RTN","DGENPTA",103,0)
 N NODE
"RTN","DGENPTA",104,0)
 Q:'$G(DFN) 0
"RTN","DGENPTA",105,0)
 K DGPAT S DGPAT=""
"RTN","DGENPTA",106,0)
 S DGPAT("DFN")=DFN
"RTN","DGENPTA",107,0)
 S NODE=$G(^DPT(DFN,0))
"RTN","DGENPTA",108,0)
 Q:NODE="" 0
"RTN","DGENPTA",109,0)
 S DGPAT("NAME")=$P(NODE,"^")
"RTN","DGENPTA",110,0)
 S DGPAT("DOB")=$P(NODE,"^",3)
"RTN","DGENPTA",111,0)
 S DGPAT("SEX")=$P(NODE,"^",2)
"RTN","DGENPTA",112,0)
 S DGPAT("SSN")=$P(NODE,"^",9)
"RTN","DGENPTA",113,0)
 ;
"RTN","DGENPTA",114,0)
 S DGPAT("DEATH")=$P($G(^DPT(DFN,.35)),"^")
"RTN","DGENPTA",115,0)
 S DGPAT("PATYPE")=$P($G(^DPT(DFN,"TYPE")),"^")
"RTN","DGENPTA",116,0)
 S DGPAT("VETERAN")=$P($G(^DPT(DFN,"VET")),"^")
"RTN","DGENPTA",117,0)
 S DGPAT("PREFAC")=$P($G(^DPT(DFN,"ENR")),"^",2)
"RTN","DGENPTA",118,0)
 S DGPAT("PFSRC")=$P($G(^DPT(DFN,"ENR")),"^",3)
"RTN","DGENPTA",119,0)
 S DGPAT("INELDATE")=$P($G(^DPT(DFN,.15)),"^",2)
"RTN","DGENPTA",120,0)
 S DGPAT("INELREA")=$P($G(^DPT(DFN,.3)),"^",7)
"RTN","DGENPTA",121,0)
 S DGPAT("INELDEC")=$P($G(^DPT(DFN,"INE")),"^",6)
"RTN","DGENPTA",122,0)
 S DGPAT("PID")=$P($G(^DPT(DFN,.36)),"^",3)
"RTN","DGENPTA",123,0)
 S DGPAT("AG/ALLY")=$P($G(^DPT(DFN,.3)),"^",9)
"RTN","DGENPTA",124,0)
 S DGPAT("SPININJ")=$P($G(^DPT(DFN,57)),"^",4)
"RTN","DGENPTA",125,0)
 S DGPAT("MOH")=$P($G(^DPT(DFN,.54)),"^",1)
"RTN","DGENPTA",126,0)
 ;
"RTN","DGENPTA",127,0)
 S NODE=$G(^DPT(DFN,.385))
"RTN","DGENPTA",128,0)
 S DGPAT("PENAEFDT")=$P(NODE,"^")
"RTN","DGENPTA",129,0)
 S DGPAT("PENAREAS")=$P(NODE,"^",2)
"RTN","DGENPTA",130,0)
 S DGPAT("PENTRMDT")=$P(NODE,"^",3)
"RTN","DGENPTA",131,0)
 S DGPAT("PENTRMR1")=$P(NODE,"^",4)
"RTN","DGENPTA",132,0)
 S DGPAT("PENTRMR2")=$P(NODE,"^",5)
"RTN","DGENPTA",133,0)
 S DGPAT("PENTRMR3")=$P(NODE,"^",6)
"RTN","DGENPTA",134,0)
 S DGPAT("PENTRMR4")=$P(NODE,"^",7)
"RTN","DGENPTA",135,0)
 S DGPAT("DENTC2IN")=$P(NODE,"^",8)
"RTN","DGENPTA",136,0)
 S DGPAT("DENTC2DT")=$P(NODE,"^",9)
"RTN","DGENPTA",137,0)
 S DGPAT("PILOCK")=$P(NODE,"^",10)
"RTN","DGENPTA",138,0)
 S DGPAT("PALOCK")=$P(NODE,"^",11)
"RTN","DGENPTA",139,0)
 Q 1
"RTN","DGENPTA",140,0)
 ;
"RTN","DGENPTA",141,0)
SSN(DFN) ;
"RTN","DGENPTA",142,0)
 ;Description: Function returns the patient's SSN, or "" on failure.
"RTN","DGENPTA",143,0)
 ;
"RTN","DGENPTA",144,0)
 Q:'DFN ""
"RTN","DGENPTA",145,0)
 Q $P($G(^DPT(DFN,0)),"^",9)
"RTN","DGENPTA",146,0)
 ;
"RTN","DGENPTA",147,0)
NAME(DFN) ;
"RTN","DGENPTA",148,0)
 ;Description: Function returns the patient's NAME, or "" on failure.
"RTN","DGENPTA",149,0)
 ;
"RTN","DGENPTA",150,0)
 Q:'DFN ""
"RTN","DGENPTA",151,0)
 Q $P($G(^DPT(DFN,0)),"^")
"RTN","DGENPTA",152,0)
 ;
"RTN","DGENPTA",153,0)
EXT(SUB,VAL) ;
"RTN","DGENPTA",154,0)
 ;Description: Given the subscript used in the PATIENT object array,
"RTN","DGENPTA",155,0)
 ;   DGPAT(), and a field value, returns the external representation of
"RTN","DGENPTA",156,0)
 ;   the value, as defined in the fields output transform of the PATIENT
"RTN","DGENPTA",157,0)
 ;   file.
"RTN","DGENPTA",158,0)
 ;Input: 
"RTN","DGENPTA",159,0)
 ;  SUB - array subscript
"RTN","DGENPTA",160,0)
 ;  VAL - field value
"RTN","DGENPTA",161,0)
 ;Output:
"RTN","DGENPTA",162,0)
 ;  Function Value - returns the external value of the field
"RTN","DGENPTA",163,0)
 ;
"RTN","DGENPTA",164,0)
 Q:(($G(SUB)="")!($G(VAL)="")) ""
"RTN","DGENPTA",165,0)
 ;
"RTN","DGENPTA",166,0)
 N FLD
"RTN","DGENPTA",167,0)
 S FLD=$$FIELD^DGENPTA1(SUB)
"RTN","DGENPTA",168,0)
 Q:(FLD="") ""
"RTN","DGENPTA",169,0)
 Q $$EXTERNAL^DILFD(2,FLD,"F",VAL)
"RTN","DGENPTA",170,0)
 ;
"RTN","DGENPTA",171,0)
 ;
"RTN","DGENPTA",172,0)
VALPAT(DFN) ; --
"RTN","DGENPTA",173,0)
 ; Description: This function returns a 1 if the patient DFN is valid, 0 if the patient DFN is not valid.
"RTN","DGENPTA",174,0)
 ;
"RTN","DGENPTA",175,0)
 ;  Input:
"RTN","DGENPTA",176,0)
 ;    DFN - as pointer to patient in Patient (#2) file
"RTN","DGENPTA",177,0)
 ;
"RTN","DGENPTA",178,0)
 ; Output:
"RTN","DGENPTA",179,0)
 ;   Function Value - Is patient (DFN) valid?
"RTN","DGENPTA",180,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",181,0)
 ;
"RTN","DGENPTA",182,0)
 ; init variables
"RTN","DGENPTA",183,0)
 N DGVALID S DGVALID=0
"RTN","DGENPTA",184,0)
 ;
"RTN","DGENPTA",185,0)
 ; is patient (DFN) valid?
"RTN","DGENPTA",186,0)
 I $G(DFN),$D(^DPT(DFN,0)) S DGVALID=1
"RTN","DGENPTA",187,0)
 ;
"RTN","DGENPTA",188,0)
 Q DGVALID
"RTN","DGENPTA",189,0)
 ;
"RTN","DGENPTA",190,0)
 ;
"RTN","DGENPTA",191,0)
CURINPAT(DFN) ; --
"RTN","DGENPTA",192,0)
 ; Description: This function will determine if the patient is a current inpatient.
"RTN","DGENPTA",193,0)
 ;
"RTN","DGENPTA",194,0)
 ;  Input:
"RTN","DGENPTA",195,0)
 ;    DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",196,0)
 ;
"RTN","DGENPTA",197,0)
 ; Output:
"RTN","DGENPTA",198,0)
 ;   Function Value - Is patient a current inpatient? 
"RTN","DGENPTA",199,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",200,0)
 ;
"RTN","DGENPTA",201,0)
 N DGCUR S DGCUR=0
"RTN","DGENPTA",202,0)
 ;
"RTN","DGENPTA",203,0)
 ; if valid patient, check if current inpatient
"RTN","DGENPTA",204,0)
 I $$VALPAT(DFN) D
"RTN","DGENPTA",205,0)
 .;
"RTN","DGENPTA",206,0)
 .; is patient a current inpatient?
"RTN","DGENPTA",207,0)
 .I $G(^DPT(DFN,.105)) S DGCUR=1
"RTN","DGENPTA",208,0)
 ;
"RTN","DGENPTA",209,0)
 Q DGCUR
"RTN","DGENPTA",210,0)
 ;
"RTN","DGENPTA",211,0)
 ;
"RTN","DGENPTA",212,0)
INPAT(DFN,DGBEG,DGEND) ; --
"RTN","DGENPTA",213,0)
 ; Description: This function will determine if a patient was an inpatient between a specified date range.
"RTN","DGENPTA",214,0)
 ;
"RTN","DGENPTA",215,0)
 ;  Input:
"RTN","DGENPTA",216,0)
 ;       DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",217,0)
 ;    DGBEG - as begin date/time for inpatient search
"RTN","DGENPTA",218,0)
 ;    DGEND - as end date/time for inpatient search
"RTN","DGENPTA",219,0)
 ;
"RTN","DGENPTA",220,0)
 ; Output:
"RTN","DGENPTA",221,0)
 ;   Function Value - Was patient an inpatient between date range?
"RTN","DGENPTA",222,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",223,0)
 ;
"RTN","DGENPTA",224,0)
 N DGINPAT,DGSDT,DGEDT,DGMOVE,DGTRANS
"RTN","DGENPTA",225,0)
 S DGINPAT=0
"RTN","DGENPTA",226,0)
 ;
"RTN","DGENPTA",227,0)
 ; if not valid patient (DFN) and not valid date range, exit
"RTN","DGENPTA",228,0)
 I '$$VALPAT(DFN),'($$RANGE(DGBEG,DGEND)) G INPATQ
"RTN","DGENPTA",229,0)
 ;
"RTN","DGENPTA",230,0)
 ; init date/time(s)
"RTN","DGENPTA",231,0)
 S DGSDT=DGBEG-.0001,DGEDT=DGEND+$S($P(DGEND,".",2)="":.2359,1:"")
"RTN","DGENPTA",232,0)
 ;
"RTN","DGENPTA",233,0)
 ; use "APRD" x-ref of Patient Movement (#405) file
"RTN","DGENPTA",234,0)
 F  S DGSDT=$O(^DGPM("APRD",+DFN,DGSDT)) Q:'DGSDT!(DGSDT>DGEDT)!(DGINPAT)  D
"RTN","DGENPTA",235,0)
 .S DGMOVE=0 F  S DGMOVE=$O(^DGPM("APRD",+DFN,DGSDT,DGMOVE)) Q:'DGMOVE!(DGINPAT)  D
"RTN","DGENPTA",236,0)
 ..; - transaction type of movement
"RTN","DGENPTA",237,0)
 ..S DGTRANS=$P($G(^DGPM(DGMOVE,0)),"^",2)  ; movement transaction type
"RTN","DGENPTA",238,0)
 ..; - if trans type not DISCHARGE, CHECK-IN LODGER, CHECK-OUT LODGER
"RTN","DGENPTA",239,0)
 ..I DGTRANS'=3,(DGTRANS'=4),(DGTRANS'=5) S DGINPAT=1
"RTN","DGENPTA",240,0)
 ;
"RTN","DGENPTA",241,0)
INPATQ Q DGINPAT
"RTN","DGENPTA",242,0)
 ;
"RTN","DGENPTA",243,0)
 ;
"RTN","DGENPTA",244,0)
OUTPAT(DFN,DGBEG,DGEND) ; --
"RTN","DGENPTA",245,0)
 ; Description: This function will determine if a patient has an outpatient encounter between a specified date range that has successfully been checked out.
"RTN","DGENPTA",246,0)
 ;
"RTN","DGENPTA",247,0)
 ;  Input:
"RTN","DGENPTA",248,0)
 ;       DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",249,0)
 ;    DGBEG - as begin date/time for outpatient search
"RTN","DGENPTA",250,0)
 ;    DGEND - as end date/time for outpatient search
"RTN","DGENPTA",251,0)
 ;
"RTN","DGENPTA",252,0)
 ; Output:
"RTN","DGENPTA",253,0)
 ;   Function Value - Does patient have outpatient encounter between date
"RTN","DGENPTA",254,0)
 ;                    range that that has successfully been checked out?
"RTN","DGENPTA",255,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",256,0)
 ;
"RTN","DGENPTA",257,0)
 N DGOUT,DGSDT,DGEDT,DGOE
"RTN","DGENPTA",258,0)
 S DGOUT=0
"RTN","DGENPTA",259,0)
 ;
"RTN","DGENPTA",260,0)
 ; if not valid patient (DFN) and not valid date range, exit
"RTN","DGENPTA",261,0)
 I '$$VALPAT(DFN),'($$RANGE(DGBEG,DGEND)) G OUTPATQ
"RTN","DGENPTA",262,0)
 ;
"RTN","DGENPTA",263,0)
 ; init date/time(s)
"RTN","DGENPTA",264,0)
 S DGSDT=DGBEG-.0001,DGEDT=DGEND+$S($P(DGEND,".",2)="":.2359,1:"")
"RTN","DGENPTA",265,0)
 ;
"RTN","DGENPTA",266,0)
 ; use "ADFN" x-ref of Outpatient Encounter (#409.68) file
"RTN","DGENPTA",267,0)
 F  S DGSDT=$O(^SCE("ADFN",+DFN,DGSDT)) Q:'DGSDT!(DGSDT>DGEDT)!(DGOUT)  D
"RTN","DGENPTA",268,0)
 .;
"RTN","DGENPTA",269,0)
 .S DGOE=0 F  S DGOE=$O(^SCE("ADFN",+DFN,DGSDT,DGOE)) Q:'DGOE!(DGOUT)  D
"RTN","DGENPTA",270,0)
 ..; - if encounter checked out, set flag
"RTN","DGENPTA",271,0)
 ..I $P($G(^SCE(+DGOE,0)),"^",7) S DGOUT=1
"RTN","DGENPTA",272,0)
 ;
"RTN","DGENPTA",273,0)
OUTPATQ Q DGOUT
"RTN","DGENPTA",274,0)
 ;
"RTN","DGENPTA",275,0)
 ;
"RTN","DGENPTA",276,0)
RANGE(DGBEG,DGEND) ; --
"RTN","DGENPTA",277,0)
 ; Description: This function returns a 1 if two dates are a valid date range, 0 if they are not valid.
"RTN","DGENPTA",278,0)
 ;
"RTN","DGENPTA",279,0)
 ;  Input:
"RTN","DGENPTA",280,0)
 ;    DGBEG - as begin date of date range
"RTN","DGENPTA",281,0)
 ;    DGEND - as end date of date range
"RTN","DGENPTA",282,0)
 ;
"RTN","DGENPTA",283,0)
 ; Output:
"RTN","DGENPTA",284,0)
 ;   Function Value - Is date range valid?
"RTN","DGENPTA",285,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",286,0)
 ;
"RTN","DGENPTA",287,0)
 N DGOK
"RTN","DGENPTA",288,0)
 ;
"RTN","DGENPTA",289,0)
 S DGOK=0
"RTN","DGENPTA",290,0)
 ;
"RTN","DGENPTA",291,0)
 ; if input parameters not defined, exit
"RTN","DGENPTA",292,0)
 I '$D(DGBEG),('$D(DGEND)) G RANGEQ
"RTN","DGENPTA",293,0)
 ;
"RTN","DGENPTA",294,0)
 ; remove time from dates
"RTN","DGENPTA",295,0)
 S DGBEG=(DGBEG/1),DGEND=(DGEND/1)
"RTN","DGENPTA",296,0)
 ;
"RTN","DGENPTA",297,0)
 ; if begin date greater than end date, exit
"RTN","DGENPTA",298,0)
 I DGBEG>DGEND G RANGEQ
"RTN","DGENPTA",299,0)
 ;
"RTN","DGENPTA",300,0)
 ; if begin date and end date future dates, exit
"RTN","DGENPTA",301,0)
 I DGBEG>DT,(DGEND>DT) G RANGEQ
"RTN","DGENPTA",302,0)
 ;
"RTN","DGENPTA",303,0)
 S DGOK=1
"RTN","DGENPTA",304,0)
 ;
"RTN","DGENPTA",305,0)
RANGEQ Q DGOK
"RTN","DGENPTA",306,0)
 ;
"RTN","DGENPTA",307,0)
LOOKUP(SSN,DOB,SEX,ERROR) ;
"RTN","DGENPTA",308,0)
 ;Description: This function will do a search for the patient based on
"RTN","DGENPTA",309,0)
 ;the identifying information provided. The function will be successful
"RTN","DGENPTA",310,0)
 ;only if a single patient is found matching the identifiers provided.
"RTN","DGENPTA",311,0)
 ;
"RTN","DGENPTA",312,0)
 ;Inputs:
"RTN","DGENPTA",313,0)
 ;  SSN - patient Social Security Number
"RTN","DGENPTA",314,0)
 ;  DOB - patient date of birth (FM format)
"RTN","DGENPTA",315,0)
 ;  SEX - patient sex
"RTN","DGENPTA",316,0)
 ;Outputs:
"RTN","DGENPTA",317,0)
 ;  Function Value - patient DFN if successful, 0 otherwise
"RTN","DGENPTA",318,0)
 ;  ERROR - if unsuccessful, an error message is returned (optional, pass by reference)
"RTN","DGENPTA",319,0)
 ;
"RTN","DGENPTA",320,0)
 N DFN,NODE
"RTN","DGENPTA",321,0)
 ;
"RTN","DGENPTA",322,0)
 I $G(SSN)="" S ERROR="INVALID SSN" Q 0
"RTN","DGENPTA",323,0)
 S DFN=$O(^DPT("SSN",SSN,0))
"RTN","DGENPTA",324,0)
 I 'DFN S ERROR="SSN NOT FOUND" Q 0
"RTN","DGENPTA",325,0)
 I $O(^DPT("SSN",SSN,DFN)) S ERROR="MULTIPLE PATIENTS MATCHING SSN" Q 0
"RTN","DGENPTA",326,0)
 S NODE=$G(^DPT(DFN,0))
"RTN","DGENPTA",327,0)
 I $P(NODE,"^",2)'=SEX S ERROR="SEX DOES NOT MATCH" Q 0
"RTN","DGENPTA",328,0)
 I $E($P(NODE,"^",3),1,3)'=$E(DOB,1,3) S ERROR="DOB DOES NOT MATCH" Q 0
"RTN","DGENPTA",329,0)
 I $E($P(NODE,"^",3),4,5),$E($P(NODE,"^",3),4,5)'=$E(DOB,4,5) S ERROR="DOB DOES NOT MATCH" Q 0
"RTN","DGENPTA",330,0)
 Q DFN
"RTN","DGENPTA1")
0^6^B25498748
"RTN","DGENPTA1",1,0)
DGENPTA1 ;ALB/CJM,EG,CKN,ERC,TDM,PWC - Patient API - File Data ; 5/24/11 4:54pm
"RTN","DGENPTA1",2,0)
 ;;5.3;Registration;**121,147,314,677,659,653,688,810,754,838,841,842**;Aug 13,1993;Build 33
"RTN","DGENPTA1",3,0)
 ;
"RTN","DGENPTA1",4,0)
LOCK(DFN) ;
"RTN","DGENPTA1",5,0)
 ;Description: Given an internal entry number of a PATIENT  record, this
"RTN","DGENPTA1",6,0)
 ;   function will lock the record. It should be used when updating the
"RTN","DGENPTA1",7,0)
 ;   record.
"RTN","DGENPTA1",8,0)
 ;Input:
"RTN","DGENPTA1",9,0)
 ;  DFN - Patient IEN
"RTN","DGENPTA1",10,0)
 ;Output:
"RTN","DGENPTA1",11,0)
 ;  Function Value - Returns 1 if the lock was successful, 0 otherwise
"RTN","DGENPTA1",12,0)
 ;
"RTN","DGENPTA1",13,0)
 I $G(DFN) L +^DPT(DFN):2
"RTN","DGENPTA1",14,0)
 Q $T
"RTN","DGENPTA1",15,0)
UNLOCK(DFN) ;
"RTN","DGENPTA1",16,0)
 ;Description: Given an internal entry number of a record in the PATIENT
"RTN","DGENPTA1",17,0)
 ;   file, this function will unlock the record that was previously
"RTN","DGENPTA1",18,0)
 ;   locked by LOCK PATIENT RECORD.  
"RTN","DGENPTA1",19,0)
 ;Input:
"RTN","DGENPTA1",20,0)
 ;   DFN - Patient IEN
"RTN","DGENPTA1",21,0)
 ;Output: None
"RTN","DGENPTA1",22,0)
 ;
"RTN","DGENPTA1",23,0)
 I $G(DFN) L -^DPT(DFN)
"RTN","DGENPTA1",24,0)
 Q
"RTN","DGENPTA1",25,0)
 ;
"RTN","DGENPTA1",26,0)
STOREPRE(DFN,DGPREFAC) ;
"RTN","DGENPTA1",27,0)
 ;Description: Used to store the patient's preferred facility in the
"RTN","DGENPTA1",28,0)
 ;   patient record.
"RTN","DGENPTA1",29,0)
 ;Input:
"RTN","DGENPTA1",30,0)
 ;  DFN - Patient IEN
"RTN","DGENPTA1",31,0)
 ;  DGPREFAC - pointer to the record in the INSTITUTION file.
"RTN","DGENPTA1",32,0)
 ;Output:
"RTN","DGENPTA1",33,0)
 ;  Function Value - Returns 1 on success, 0 on failure.
"RTN","DGENPTA1",34,0)
 ;
"RTN","DGENPTA1",35,0)
 N SUCCESS,DATA
"RTN","DGENPTA1",36,0)
 S SUCCESS=1
"RTN","DGENPTA1",37,0)
 D  ;drops out if invalid condition found
"RTN","DGENPTA1",38,0)
 . I $G(DFN),$D(^DPT(DFN,0))
"RTN","DGENPTA1",39,0)
 . E  S SUCCESS=0 Q
"RTN","DGENPTA1",40,0)
 . I ($G(DGPREFAC)'=""),'$G(DGPREFAC) S SUCCESS=0 Q
"RTN","DGENPTA1",41,0)
 . I $G(DGPREFAC),'$D(^DIC(4,DGPREFAC,0)) S SUCCESS=0 Q
"RTN","DGENPTA1",42,0)
 . S DATA(27.02)=DGPREFAC
"RTN","DGENPTA1",43,0)
 . S DATA(27.03)="V"     ; DG*5.3*838
"RTN","DGENPTA1",44,0)
 . S SUCCESS=$$UPD^DGENDBS(2,DFN,.DATA)
"RTN","DGENPTA1",45,0)
 Q SUCCESS
"RTN","DGENPTA1",46,0)
 ;
"RTN","DGENPTA1",47,0)
CHECK(DGPAT,ERROR) ;
"RTN","DGENPTA1",48,0)
 ;Description: Does validation checks on the patient contained in the
"RTN","DGENPTA1",49,0)
 ;DGPAT array.
"RTN","DGENPTA1",50,0)
 ;
"RTN","DGENPTA1",51,0)
 ;Input:
"RTN","DGENPTA1",52,0)
 ;  DGPAT - this local array contains patient data
"RTN","DGENPTA1",53,0)
 ;Output:
"RTN","DGENPTA1",54,0)
 ;  Function Value - returns 1 if all validation checks passed, 0 otherwise
"RTN","DGENPTA1",55,0)
 ;  ERROR - if validation checks fail, an error message is returned (pass by reference)
"RTN","DGENPTA1",56,0)
 ;
"RTN","DGENPTA1",57,0)
 ;
"RTN","DGENPTA1",58,0)
 N SUCCESS,FIELD
"RTN","DGENPTA1",59,0)
 S SUCCESS=1
"RTN","DGENPTA1",60,0)
 S ERROR=""
"RTN","DGENPTA1",61,0)
 ;
"RTN","DGENPTA1",62,0)
 ;check field values
"RTN","DGENPTA1",63,0)
 ;
"RTN","DGENPTA1",64,0)
 ;some of the field's input transforms require DA or DUZ to be defined, so do not do this
"RTN","DGENPTA1",65,0)
 ;F  S SUB=$O(DGPAT(SUB)) Q:SUB=""  D:(DGPAT(SUB)'="")  Q:'SUCCESS
"RTN","DGENPTA1",66,0)
 ;.S FIELD=$$FIELD(SUB)
"RTN","DGENPTA1",67,0)
 ;.I '$$TESTVAL^DGENDBS(2,FIELD,DGPAT(SUB)) D
"RTN","DGENPTA1",68,0)
 ;..S SUCCESS=0
"RTN","DGENPTA1",69,0)
 ;..S ERROR="BAD FIELD VALUE, PATIENT FILE FIELD = "_$$GET1^DID(2,FIELD,,"LABEL")
"RTN","DGENPTA1",70,0)
 ;
"RTN","DGENPTA1",71,0)
 ;instead, check field values without referencing DD
"RTN","DGENPTA1",72,0)
 I DGPAT("INELDEC")'="",($L(DGPAT("INELDEC"))>75)!($L(DGPAT("INELDEC"))<3) S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD FIELD = INELIGIBLE VARO DECISION" G QCHECK
"RTN","DGENPTA1",73,0)
 ;
"RTN","DGENPTA1",74,0)
 I DGPAT("INELREA")'="",($L(DGPAT("INELREA"))>40) S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD FIELD = INELIGIBLE REASON" G QCHECK
"RTN","DGENPTA1",75,0)
 ;
"RTN","DGENPTA1",76,0)
 I DGPAT("VETERAN")="" S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD = VETERAN (Y/N)?" G QCHECK
"RTN","DGENPTA1",77,0)
 ;
"RTN","DGENPTA1",78,0)
 I DGPAT("DEATH"),(DGPAT("DEATH")>DT) S SUCCESS=0,ERROR="DATE OF DEATH CAN NOT BE A FUTURE DATE" G QCHECK
"RTN","DGENPTA1",79,0)
 ;
"RTN","DGENPTA1",80,0)
 I DGPAT("INELDATE"),(DGPAT("INELREA")="") S SUCCESS=0,ERROR="INELIGIBLE REASON UNSPECIFIED FOR INELIGIBLE PATIENT" G QCHECK
"RTN","DGENPTA1",81,0)
 ;
"RTN","DGENPTA1",82,0)
QCHECK ;
"RTN","DGENPTA1",83,0)
 Q SUCCESS
"RTN","DGENPTA1",84,0)
 ;
"RTN","DGENPTA1",85,0)
STORE(DGPAT,ERROR,NOCHECK) ;
"RTN","DGENPTA1",86,0)
 ;Description: Files data in the patient record.  It requires a lock
"RTN","DGENPTA1",87,0)
 ;on the Patient record, adn releases the lock when done.
"RTN","DGENPTA1",88,0)
 ;
"RTN","DGENPTA1",89,0)
 ;Input:
"RTN","DGENPTA1",90,0)
 ;  DGPAT- the patient array, passed by reference
"RTN","DGENPTA1",91,0)
 ;  NOCHECK - a flag, if set to 1 it means consistency checks were done aready, so skip
"RTN","DGENPTA1",92,0)
 ;
"RTN","DGENPTA1",93,0)
 ;Output:
"RTN","DGENPTA1",94,0)
 ;  Function Value - returns 1 if successful, otherwise 0
"RTN","DGENPTA1",95,0)
 ;  ERROR - on failure, an error message is returned (optional, pass by reference)
"RTN","DGENPTA1",96,0)
 ;
"RTN","DGENPTA1",97,0)
 S ERROR=""
"RTN","DGENPTA1",98,0)
 I '$D(DGPAT) S ERROR="PATIENT NOT FOUND" Q 0
"RTN","DGENPTA1",99,0)
 I '$$LOCK(DGPAT("DFN")) S ERROR="UNABLE TO LOCK THE PATIENT RECORD" Q 0
"RTN","DGENPTA1",100,0)
 I $G(NOCHECK)'=1 Q:'$$CHECK(.DGPAT,.ERROR) 0
"RTN","DGENPTA1",101,0)
 ;
"RTN","DGENPTA1",102,0)
 N DATA,SUB,FIELD,SUCCESS
"RTN","DGENPTA1",103,0)
 S SUB=""
"RTN","DGENPTA1",104,0)
 ;
"RTN","DGENPTA1",105,0)
 F  S SUB=$O(DGPAT(SUB)) Q:(SUB="")  I (SUB'="DEATH")&(SUB'="SSN") S FIELD=$$FIELD(SUB) I FIELD S DATA(FIELD)=$G(DGPAT(SUB))
"RTN","DGENPTA1",106,0)
 S SUCCESS=$$UPD^DGENDBS(2,DGPAT("DFN"),.DATA)
"RTN","DGENPTA1",107,0)
 I 'SUCCESS S ERROR="FILEMAN UNABLE TO UPDATE PATIENT RECORD"
"RTN","DGENPTA1",108,0)
 ; Call Purple Heart API to file PH data in file 2
"RTN","DGENPTA1",109,0)
 I SUCCESS,$D(DGPAT("PHI")) D EDITPH^DGRPLE($G(DGPAT("PHI")),$G(DGPAT("PHST")),$G(DGPAT("PHRR")),DGPAT("DFN"))
"RTN","DGENPTA1",110,0)
 ; Call POW API to file POW data in file 2 - DG*5.3*653
"RTN","DGENPTA1",111,0)
 ;I SUCCESS,$D(DGPAT("POWI")) D EDITPOW^DGRPLE($G(DGPAT("POWI")),$G(DGPAT("POWLOC")),$G(DGPAT("POWFDT")),$G(DGPAT("POWTDT")),DGPAT("DFN"))
"RTN","DGENPTA1",112,0)
 I SUCCESS D
"RTN","DGENPTA1",113,0)
 . I '$D(DGPAT("POWI")) D  Q
"RTN","DGENPTA1",114,0)
 . . N DATA,ERROR,DGENDA
"RTN","DGENPTA1",115,0)
 . . S DGENDA=DGPAT("DFN")
"RTN","DGENPTA1",116,0)
 . . S (DATA(.525),DATA(.526),DATA(.527),DATA(.528),DATA(.529))="@"
"RTN","DGENPTA1",117,0)
 . . I '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR) D
"RTN","DGENPTA1",118,0)
 . . . D ADDMSG^DGENUPL3(.MSGS,"Unable to update POW Data.",1)
"RTN","DGENPTA1",119,0)
 . . K DATA,ERROR,DGENDA
"RTN","DGENPTA1",120,0)
 . D EDITPOW^DGRPLE($G(DGPAT("POWI")),$G(DGPAT("POWLOC")),$G(DGPAT("POWFDT")),$G(DGPAT("POWTDT")),DGPAT("DFN"))
"RTN","DGENPTA1",121,0)
 D UNLOCK(DGPAT("DFN"))
"RTN","DGENPTA1",122,0)
 Q SUCCESS
"RTN","DGENPTA1",123,0)
 ;
"RTN","DGENPTA1",124,0)
FIELD(SUB) ;
"RTN","DGENPTA1",125,0)
 ;Description: Returns the field number of a subscript for the PATIENT object.
"RTN","DGENPTA1",126,0)
 ;
"RTN","DGENPTA1",127,0)
 N FNUM
"RTN","DGENPTA1",128,0)
 S FNUM=$S(SUB="DEATH":.351,SUB="PATYPE":391,SUB="VETERAN":1901,SUB="NAME":.01,SUB="DOB":.03,SUB="SEX":.02,SUB="SSN":.09,SUB="PREFAC":27.02,SUB="AG/ALLY":.309,1:"")
"RTN","DGENPTA1",129,0)
 S:'FNUM FNUM=$S(SUB="INELDATE":.152,SUB="INELREA":.307,SUB="INELDEC":.1656,SUB="PID":.363,SUB="EMGRES":.181,1:"")
"RTN","DGENPTA1",130,0)
 I FNUM="" S FNUM=$S(SUB="IR":.32103,SUB="RADEXPM":.3212,SUB="APPREQ":1010.159,SUB="APPREQDT":1010.1511,SUB="SPININJ":57.4,SUB="PFSRC":27.03,1:"")
"RTN","DGENPTA1",131,0)
 I FNUM="" S FNUM=$S(SUB="MOH":.541,SUB="DENTC2IN":.3858,SUB="DENTC2DT":.3859,1:"")
"RTN","DGENPTA1",132,0)
 I FNUM="" S FNUM=$S(SUB="PENAEFDT":.3851,SUB="PENAREAS":.3852,SUB="PENTRMDT":.3853,1:"")
"RTN","DGENPTA1",133,0)
 I FNUM="" S FNUM=$S(SUB="PENTRMR1":.3854,SUB="PENTRMR2":.3855,SUB="PENTRMR3":.3856,SUB="PENTRMR4":.3857,SUB="PILOCK":.386,SUB="PALOCK":.3861,1:"")
"RTN","DGENPTA1",134,0)
 Q FNUM
"RTN","DGENUPL1")
0^7^B41786889
"RTN","DGENUPL1",1,0)
DGENUPL1 ;ALB/CJM,ISA/KWP,CKN,LBD,TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 5/19/11 3:45pm
"RTN","DGENUPL1",2,0)
 ;;5.3;REGISTRATION;**147,222,232,314,397,379,407,363,673,653,688,797,842**;Aug 13,1993;Build 33
"RTN","DGENUPL1",3,0)
 ;
"RTN","DGENUPL1",4,0)
PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE) ;
"RTN","DGENUPL1",5,0)
 ;
"RTN","DGENUPL1",6,0)
 ;Description:  This function parses the HL7 segments.  It creates arrays
"RTN","DGENUPL1",7,0)
 ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY,
"RTN","DGENUPL1",8,0)
 ;OEF/OIF CONFLICT objects.
"RTN","DGENUPL1",9,0)
 ;Field values are put in DHCP format and the validity at the
"RTN","DGENUPL1",10,0)
 ;field level is tested.  Fields to be deleted are set to "@".
"RTN","DGENUPL1",11,0)
 ;
"RTN","DGENUPL1",12,0)
 ;Input:
"RTN","DGENUPL1",13,0)
 ;  MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772)
"RTN","DGENUPL1",14,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",15,0)
 ;  CURLINE - the subscript of the PID segment of the current message (pass by reference)
"RTN","DGENUPL1",16,0)
 ;  ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref)
"RTN","DGENUPL1",17,0)
 ;
"RTN","DGENUPL1",18,0)
 ;Output:
"RTN","DGENUPL1",19,0)
 ;  Function Value: Returns 1 on success, 0 on failure.
"RTN","DGENUPL1",20,0)
 ;  CURLINE - upon leaving the procedure this parameter should be set to the end of the current message.
"RTN","DGENUPL1",21,0)
 ;  ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref)
"RTN","DGENUPL1",22,0)
 ;  DGPAT - array defined by the PATIENT object. (pass by ref)
"RTN","DGENUPL1",23,0)
 ;  DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref)
"RTN","DGENUPL1",24,0)
 ;  DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref)
"RTN","DGENUPL1",25,0)
 ;  DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref)
"RTN","DGENUPL1",26,0)
 ;  DGSEC - array defined by the PATIENT SECURITY object. (pass by ref)
"RTN","DGENUPL1",27,0)
 ;  DGOEIF - array defined by the OEF/OIF CONFLICT object.  (pass by ref)
"RTN","DGENUPL1",28,0)
 ;  DGNTR - array defined for NTR data.
"RTN","DGENUPL1",29,0)
 ;  DGMST - array defined for MST data.
"RTN","DGENUPL1",30,0)
 ;  DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref)
"RTN","DGENUPL1",31,0)
 N SEG,ERROR,COUNT,QFLG,NFLG
"RTN","DGENUPL1",32,0)
 ;
"RTN","DGENUPL1",33,0)
 K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST
"RTN","DGENUPL1",34,0)
 ;
"RTN","DGENUPL1",35,0)
 S ERROR=0,NFLG=1
"RTN","DGENUPL1",36,0)
 F SEG="PID","ZPD","ZIE","ZIO","ZEL"  D  Q:ERROR
"RTN","DGENUPL1",37,0)
 .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",38,0)
 .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q
"RTN","DGENUPL1",39,0)
 .I SEG("TYPE")=SEG D  Q
"RTN","DGENUPL1",40,0)
 ..D:(SEG'="ZEL") @SEG^DGENUPL2
"RTN","DGENUPL1",41,0)
 ..D:(SEG="ZEL") ZEL^DGENUPL2(1)
"RTN","DGENUPL1",42,0)
 ..S NFLG=1
"RTN","DGENUPL1",43,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",44,0)
 .S ERROR=1
"RTN","DGENUPL1",45,0)
 .;
"RTN","DGENUPL1",46,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",47,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",48,0)
 ;
"RTN","DGENUPL1",49,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL")  D  Q:ERROR
"RTN","DGENUPL1",50,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",51,0)
 .D ZEL^DGENUPL2(COUNT)
"RTN","DGENUPL1",52,0)
 ;
"RTN","DGENUPL1",53,0)
 ;ZE2 is optional, If no ZE2 segment delete pension data
"RTN","DGENUPL1",54,0)
 I 'ERROR D
"RTN","DGENUPL1",55,0)
 .I SEG("TYPE")="ZE2" D ZE2^DGENUPLB S CURLINE=CURLINE+1 Q
"RTN","DGENUPL1",56,0)
 .I SEG("TYPE")'="ZE2" D
"RTN","DGENUPL1",57,0)
 ..Q:$$GET1^DIQ(2,DFN,.3852,"I")=$O(^DG(27.18,"C","00",""))
"RTN","DGENUPL1",58,0)
 ..N PSUB
"RTN","DGENUPL1",59,0)
 ..F PSUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S DGPAT(PSUB)="@"
"RTN","DGENUPL1",60,0)
 ;
"RTN","DGENUPL1",61,0)
 ;Phase II Add the capability to accept more than 1 ZCD
"RTN","DGENUPL1",62,0)
 I 'ERROR F SEG="ZEN","ZMT","ZCD" D  Q:ERROR
"RTN","DGENUPL1",63,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",64,0)
 .I SEG("TYPE")=SEG D
"RTN","DGENUPL1",65,0)
 ..D @SEG^DGENUPL2
"RTN","DGENUPL1",66,0)
 .E  D
"RTN","DGENUPL1",67,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUTOF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",68,0)
 ..S ERROR=1
"RTN","DGENUPL1",69,0)
 ..;
"RTN","DGENUPL1",70,0)
 ..;possible that in a bad message we are now past the end
"RTN","DGENUPL1",71,0)
 ..S CURLINE=CURLINE-1
"RTN","DGENUPL1",72,0)
 ;
"RTN","DGENUPL1",73,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZCD")  D  Q:ERROR
"RTN","DGENUPL1",74,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",75,0)
 .D ZCD^DGENUPL2
"RTN","DGENUPL1",76,0)
 ;
"RTN","DGENUPL1",77,0)
 ; Purple Heart/OEF-OIF  Addition of optional ZMH segment
"RTN","DGENUPL1",78,0)
 ;              Modified handling of ZSP and ZRD to accomodate ZMH
"RTN","DGENUPL1",79,0)
 ;
"RTN","DGENUPL1",80,0)
 I 'ERROR D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",81,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",82,0)
 .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q
"RTN","DGENUPL1",83,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",84,0)
 .S ERROR=1
"RTN","DGENUPL1",85,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",86,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",87,0)
 ;
"RTN","DGENUPL1",88,0)
 ;Modified following code to receive multiple ZMH segment for
"RTN","DGENUPL1",89,0)
 ;Military service information - DG*5.3*653
"RTN","DGENUPL1",90,0)
 I 'ERROR D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",91,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",92,0)
 .S QFLG=0 F  D  Q:QFLG
"RTN","DGENUPL1",93,0)
 . . I SEG("TYPE")'="ZMH" S QFLG=1 Q
"RTN","DGENUPL1",94,0)
 . . D ZMH^DGENUPL2,NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",95,0)
 .I SEG("TYPE")="ZRD" D ZRD^DGENUPL2 Q 
"RTN","DGENUPL1",96,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",97,0)
 .S ERROR=1
"RTN","DGENUPL1",98,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",99,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",100,0)
 ;
"RTN","DGENUPL1",101,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZRD")  D  Q:ERROR
"RTN","DGENUPL1",102,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",103,0)
 .D ZRD^DGENUPL2
"RTN","DGENUPL1",104,0)
 ;
"RTN","DGENUPL1",105,0)
 I 'ERROR F  D  Q:(ERROR!(SEG("TYPE")'="OBX"))
"RTN","DGENUPL1",106,0)
 .;possible if OBX segment not present that we are now past the end
"RTN","DGENUPL1",107,0)
 .I SEG("TYPE")'="OBX" S CURLINE=CURLINE-1 Q
"RTN","DGENUPL1",108,0)
 .D OBX^DGENUPL2
"RTN","DGENUPL1",109,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",110,0)
 .D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG)
"RTN","DGENUPL1",111,0)
 ;
"RTN","DGENUPL1",112,0)
 Q $S(ERROR:0,1:1)
"RTN","DGENUPL1",113,0)
 ;
"RTN","DGENUPL1",114,0)
CONVERT(VAL,DATATYPE,ERROR) ;
"RTN","DGENUPL1",115,0)
 ;Description: Converts the value found in the HL7 segment to DHCP format
"RTN","DGENUPL1",116,0)
 ;
"RTN","DGENUPL1",117,0)
 ;Input:
"RTN","DGENUPL1",118,0)
 ;  VAL - value parsed from the HL7 segment
"RTN","DGENUPL1",119,0)
 ;  DATATYPE: indicates the type of conversion necessary
"RTN","DGENUPL1",120,0)
 ;      "DATE" - needs to be converted to FM format
"RTN","DGENUPL1",121,0)
 ;      "TS" - time stamp, needs to be converted to FM format
"RTN","DGENUPL1",122,0)
 ;      "Y/N" - 0->"N",1->"Y"
"RTN","DGENUPL1",123,0)
 ;      "1/0" - "Y"->1,"N"->0
"RTN","DGENUPL1",124,0)
 ;      "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file
"RTN","DGENUPL1",125,0)
 ;      "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8)
"RTN","DGENUPL1",126,0)
 ;
"RTN","DGENUPL1",127,0)
 ;      "MT" - VAL  is a Means Test Status code, it needs to be converted
"RTN","DGENUPL1",128,0)
 ;             to a pointer to the Means Test Status file
"RTN","DGENUPL1",129,0)
 ;       Phase II convert code to RSN IEN for DGCDIS object
"RTN","DGENUPL1",130,0)
 ;       "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5)
"RTN","DGENUPL1",131,0)
 ;       "EXT" convert from code to abbreviation
"RTN","DGENUPL1",132,0)
 ;       "POS" convert from Period of Service code to a point to Period of Service file
"RTN","DGENUPL1",133,0)
 ;       "AGENCY" convert Agency/Allied Country code from file 35
"RTN","DGENUPL1",134,0)
 ;       "PENSIONCD" convert Pension Award/Termination Reason code from file 27.18
"RTN","DGENUPL1",135,0)
 ;OUTPUT:
"RTN","DGENUPL1",136,0)
 ;  Function Value - the result of the conversion
"RTN","DGENUPL1",137,0)
 ;  ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref)
"RTN","DGENUPL1",138,0)
 ;
"RTN","DGENUPL1",139,0)
 S ERROR=0
"RTN","DGENUPL1",140,0)
 D
"RTN","DGENUPL1",141,0)
 .I VAL="" Q
"RTN","DGENUPL1",142,0)
 .I VAL="""""" S VAL="@" Q
"RTN","DGENUPL1",143,0)
 .I $G(DATATYPE)="EXT" D  Q
"RTN","DGENUPL1",144,0)
 ..S VAL=$$HLTOLIMB^DGENA5(VAL)
"RTN","DGENUPL1",145,0)
 .I $G(DATATYPE)="CDRSN" D  Q
"RTN","DGENUPL1",146,0)
 ..S VAL=$$HL7TORSN^DGENA5(VAL)
"RTN","DGENUPL1",147,0)
 .I ($G(DATATYPE)="MT") D  Q
"RTN","DGENUPL1",148,0)
 ..S VAL=$O(^DG(408.32,"AC",1,VAL,0))
"RTN","DGENUPL1",149,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",150,0)
 .I ($G(DATATYPE)="DATE") D  Q
"RTN","DGENUPL1",151,0)
 ..I $L(VAL)'=8 S ERROR=1 Q
"RTN","DGENUPL1",152,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",153,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",154,0)
 .I ($G(DATATYPE)="TS") D  Q
"RTN","DGENUPL1",155,0)
 ..I $L(VAL)<8 S ERROR=1 Q
"RTN","DGENUPL1",156,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",157,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",158,0)
 .I ($G(DATATYPE)="Y/N") D  Q
"RTN","DGENUPL1",159,0)
 ..I VAL=0 S VAL="N" Q
"RTN","DGENUPL1",160,0)
 ..I VAL=1 S VAL="Y" Q
"RTN","DGENUPL1",161,0)
 ..S ERROR=1
"RTN","DGENUPL1",162,0)
 .I ($G(DATATYPE)="1/0") D  Q
"RTN","DGENUPL1",163,0)
 ..I VAL="N" S VAL=0 Q
"RTN","DGENUPL1",164,0)
 ..I VAL="Y" S VAL=1 Q
"RTN","DGENUPL1",165,0)
 ..S ERROR=1
"RTN","DGENUPL1",166,0)
 .I ($G(DATATYPE)="ELIGIBILITY") D  Q
"RTN","DGENUPL1",167,0)
 ..S VAL=$$MAP(VAL)
"RTN","DGENUPL1",168,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",169,0)
 .I ($G(DATATYPE)="INSTITUTION") D  Q
"RTN","DGENUPL1",170,0)
 ..N OLDVAL
"RTN","DGENUPL1",171,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",172,0)
 ..S VAL=$O(^DIC(4,"D",OLDVAL,0))
"RTN","DGENUPL1",173,0)
 ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0))
"RTN","DGENUPL1",174,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",175,0)
 .I ($G(DATATYPE)="POS") D  Q
"RTN","DGENUPL1",176,0)
 ..N OLDVAL
"RTN","DGENUPL1",177,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",178,0)
 ..S VAL=$O(^DIC(21,"D",OLDVAL,0))
"RTN","DGENUPL1",179,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",180,0)
 .I ($G(DATATYPE)="AGENCY") D  Q
"RTN","DGENUPL1",181,0)
 ..N OLDVAL
"RTN","DGENUPL1",182,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",183,0)
 ..S VAL=$O(^DIC(35,"C",OLDVAL,0))
"RTN","DGENUPL1",184,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",185,0)
 .I ($G(DATATYPE)="PENSIONCD") D  Q
"RTN","DGENUPL1",186,0)
 ..N OLDVAL
"RTN","DGENUPL1",187,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",188,0)
 ..S VAL=$O(^DG(27.18,"C",OLDVAL,0))
"RTN","DGENUPL1",189,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",190,0)
 Q VAL
"RTN","DGENUPL1",191,0)
 ;
"RTN","DGENUPL1",192,0)
MAP(VALUE) ;
"RTN","DGENUPL1",193,0)
 ;Description: Tries to map an eligibility code from file #8.1 (the national MAS ELIGIBILITY CODE file) to file #8 (the local ELIGIBILITY CODE file)
"RTN","DGENUPL1",194,0)
 ;
"RTN","DGENUPL1",195,0)
 ;Input: VALUE - ien of an entry in file #8.1
"RTN","DGENUPL1",196,0)
 ;
"RTN","DGENUPL1",197,0)
 ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8
"RTN","DGENUPL1",198,0)
 ;
"RTN","DGENUPL1",199,0)
 N ECODE,NODE,COUNT,NAME
"RTN","DGENUPL1",200,0)
 ;try to choose a code from file 8 to use that is appropriate
"RTN","DGENUPL1",201,0)
 S (COUNT,ECODE)=0
"RTN","DGENUPL1",202,0)
 ;
"RTN","DGENUPL1",203,0)
 F  S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE  D
"RTN","DGENUPL1",204,0)
 .S NODE=$G(^DIC(8,ECODE,0))
"RTN","DGENUPL1",205,0)
 .;put code on list if active
"RTN","DGENUPL1",206,0)
 .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1
"RTN","DGENUPL1",207,0)
 ;
"RTN","DGENUPL1",208,0)
 ;only one match found, so use it
"RTN","DGENUPL1",209,0)
 Q:COUNT=1 $O(ECODE(0))
"RTN","DGENUPL1",210,0)
 ;
"RTN","DGENUPL1",211,0)
 ;no match found
"RTN","DGENUPL1",212,0)
 Q:'COUNT ""
"RTN","DGENUPL1",213,0)
 ;
"RTN","DGENUPL1",214,0)
 ;multiple matches found, try to match by name
"RTN","DGENUPL1",215,0)
 I COUNT>1 D
"RTN","DGENUPL1",216,0)
 .S ECODE=0
"RTN","DGENUPL1",217,0)
 .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^")
"RTN","DGENUPL1",218,0)
 .F  S ECODE=$O(ECODE(ECODE)) Q:'ECODE  Q:ECODE(ECODE)=NAME
"RTN","DGENUPL1",219,0)
 Q ECODE
"RTN","DGENUPL1",220,0)
 ;
"RTN","DGENUPL1",221,0)
ACCEPT(MSGID) ;
"RTN","DGENUPL1",222,0)
 ;Description: Writes an ack (AA) to a global to be transmitted later.
"RTN","DGENUPL1",223,0)
 ;
"RTN","DGENUPL1",224,0)
 ;Inputs:
"RTN","DGENUPL1",225,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",226,0)
 ;
"RTN","DGENUPL1",227,0)
 ;Outputs: none
"RTN","DGENUPL1",228,0)
 ;
"RTN","DGENUPL1",229,0)
 K HL,HLMID,HLMTIEN,HLDT,HLDT1
"RTN","DGENUPL1",230,0)
 D INIT^HLFNC2(HLEID,.HL)
"RTN","DGENUPL1",231,0)
 D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
"RTN","DGENUPL1",232,0)
 S HLEVN=1
"RTN","DGENUPL1",233,0)
 S MID=HLMID_"-"_HLEVN
"RTN","DGENUPL1",234,0)
 D MSH^HLFNC2(.HL,MID,.HLRES)
"RTN","DGENUPL1",235,0)
 S ^TMP("HLS",$J,1)=HLRES
"RTN","DGENUPL1",236,0)
 ;
"RTN","DGENUPL1",237,0)
 ;it seems HLFS sometimes disappears upon reaching this point
"RTN","DGENUPL1",238,0)
 I $G(HLFS)="" S HLFS="^"
"RTN","DGENUPL1",239,0)
 ;
"RTN","DGENUPL1",240,0)
 S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID
"RTN","DGENUPL1",241,0)
 Q
"RTN","DGENUPL1",242,0)
 ;
"RTN","DGENUPL1",243,0)
MVERRORS ;
"RTN","DGENUPL1",244,0)
 ;Error messages were being deleted from ^TMP("HLS",$J by another package
"RTN","DGENUPL1",245,0)
 ;during the upload.  To fix this, errors are written to another
"RTN","DGENUPL1",246,0)
 ;subscript, then moved when the error list is complete.
"RTN","DGENUPL1",247,0)
 ;
"RTN","DGENUPL1",248,0)
 M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",249,0)
 K ^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",250,0)
 Q
"RTN","DGENUPL2")
0^8^B78421208
"RTN","DGENUPL2",1,0)
DGENUPL2 ;ALB/CJM,RTK,TMK,ISA/KWP/RMM/CKN,EG,ERC,PWC,TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 5/19/11 5:00pm
"RTN","DGENUPL2",2,0)
 ;;5.3;REGISTRATION;**147,222,232,310,314,367,397,677,631,675,672,673,716,653,688,838,842**;Aug 13,1993;Build 33
"RTN","DGENUPL2",3,0)
 ;
"RTN","DGENUPL2",4,0)
 ;**************************************************************
"RTN","DGENUPL2",5,0)
 ;The following procedures parse particular segment types.
"RTN","DGENUPL2",6,0)
 ;Input:SEG(),MSGID
"RTN","DGENUPL2",7,0)
 ;Output:DGPAT(),DGELG(),DGENR(),DGCDIS(),DGNTR(),DGOEIF(),ERROR
"RTN","DGENUPL2",8,0)
 ;**************************************************************
"RTN","DGENUPL2",9,0)
 ;
"RTN","DGENUPL2",10,0)
PID ;
"RTN","DGENUPL2",11,0)
 S DGPAT("SSN")=SEG(19)
"RTN","DGENUPL2",12,0)
 Q
"RTN","DGENUPL2",13,0)
 ;
"RTN","DGENUPL2",14,0)
ZPD ;
"RTN","DGENUPL2",15,0)
 D ZPD^DGENUPLA ;code removed due to size of DGENUPLA - DG*5.3*688
"RTN","DGENUPL2",16,0)
 Q
"RTN","DGENUPL2",17,0)
 ;
"RTN","DGENUPL2",18,0)
ZIE ;
"RTN","DGENUPL2",19,0)
 S DGPAT("INELDATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
"RTN","DGENUPL2",20,0)
 I ERROR D  Q
"RTN","DGENUPL2",21,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIE SEGMENT, SEQ 2",.ERRCOUNT)
"RTN","DGENUPL2",22,0)
 S DGPAT("INELREA")=$$CONVERT^DGENUPL1(SEG(3))
"RTN","DGENUPL2",23,0)
 S DGPAT("INELDEC")=$$CONVERT^DGENUPL1(SEG(4))
"RTN","DGENUPL2",24,0)
 Q
"RTN","DGENUPL2",25,0)
 ;
"RTN","DGENUPL2",26,0)
ZIO ;New segment - DG*5.3*653
"RTN","DGENUPL2",27,0)
 D ZIO^DGENUPLA  ;Code for ZIO has moved to DGENUPLA
"RTN","DGENUPL2",28,0)
 Q
"RTN","DGENUPL2",29,0)
 ;
"RTN","DGENUPL2",30,0)
ZEL(COUNT) ;
"RTN","DGENUPL2",31,0)
 D ZEL^DGENUPLA(COUNT)  ;code for ZEL segment has moved to DGENUPLA
"RTN","DGENUPL2",32,0)
 Q
"RTN","DGENUPL2",33,0)
 ;
"RTN","DGENUPL2",34,0)
ZEN ;
"RTN","DGENUPL2",35,0)
 N SUB
"RTN","DGENUPL2",36,0)
 S DGENR("DATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
"RTN","DGENUPL2",37,0)
 I ERROR D  Q
"RTN","DGENUPL2",38,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 2",.ERRCOUNT)
"RTN","DGENUPL2",39,0)
 S DGENR("SOURCE")=$$CONVERT^DGENUPL1(SEG(3))
"RTN","DGENUPL2",40,0)
 S DGENR("STATUS")=$$CONVERT^DGENUPL1(SEG(4))
"RTN","DGENUPL2",41,0)
 S ERROR=$$PEND(DFN,DGENR("STATUS"))
"RTN","DGENUPL2",42,0)
 I ERROR D  Q
"RTN","DGENUPL2",43,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ENROLLMENT STATUS PENDING-ELIGIBILITY IS VERIFIED",.ERRCOUNT)
"RTN","DGENUPL2",44,0)
 S DGENR("REASON")=$$CONVERT^DGENUPL1(SEG(5))
"RTN","DGENUPL2",45,0)
 S DGENR("REMARKS")=$$CONVERT^DGENUPL1(SEG(6))
"RTN","DGENUPL2",46,0)
 S DGENR("FACREC")=$$CONVERT^DGENUPL1(SEG(7),"INSTITUTION",.ERROR)
"RTN","DGENUPL2",47,0)
 I ERROR D  Q
"RTN","DGENUPL2",48,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY RECEIVED "_SEG(7)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
"RTN","DGENUPL2",49,0)
 S DGPAT("PREFAC")=$$CONVERT^DGENUPL1(SEG(8),"INSTITUTION",.ERROR)
"RTN","DGENUPL2",50,0)
 I ERROR D  Q
"RTN","DGENUPL2",51,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"PREFERRED FACILITY "_SEG(8)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
"RTN","DGENUPL2",52,0)
 ;
"RTN","DGENUPL2",53,0)
 S DGENR("PRIORITY")=$$CONVERT^DGENUPL1(SEG(9))
"RTN","DGENUPL2",54,0)
 S DGENR("EFFDATE")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
"RTN","DGENUPL2",55,0)
 I ERROR D  Q
"RTN","DGENUPL2",56,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 10",.ERRCOUNT)
"RTN","DGENUPL2",57,0)
 S DGENR("APP")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
"RTN","DGENUPL2",58,0)
 I ERROR D  Q
"RTN","DGENUPL2",59,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 11",.ERRCOUNT)
"RTN","DGENUPL2",60,0)
 ;
"RTN","DGENUPL2",61,0)
 ;!!!!!! take next line out when HEC begins transmitting application dt
"RTN","DGENUPL2",62,0)
 I DGENR("APP")=""!(DGENR("APP")="@") S DGENR("APP")=DGENR("DATE")
"RTN","DGENUPL2",63,0)
 I DGENR("APP")=""!(DGENR("APP")="@") S DGENR("APP")=DGENR("EFFDATE")
"RTN","DGENUPL2",64,0)
 ;
"RTN","DGENUPL2",65,0)
 S DGENR("END")=$$CONVERT^DGENUPL1(SEG(12),"DATE",.ERROR)
"RTN","DGENUPL2",66,0)
 I ERROR D  Q
"RTN","DGENUPL2",67,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 12",.ERRCOUNT)
"RTN","DGENUPL2",68,0)
 ;Phase II Parse out Sub-Group (SRS 6[B.4)
"RTN","DGENUPL2",69,0)
 S DGENR("SUBGRP")=$$CONVERT^DGENUPL1(SEG(13))
"RTN","DGENUPL2",70,0)
 S DGPAT("PFSRC")=$$CONVERT^DGENUPL1(SEG(14)) N PFSRC S PFSRC=DGPAT("PFSRC")
"RTN","DGENUPL2",71,0)
 I PFSRC'="V"&(PFSRC'="E")&(PFSRC'="PA")&(PFSRC'="PI")&(PFSRC'="@")&(PFSRC'="") D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 14",.ERRCOUNT) Q
"RTN","DGENUPL2",72,0)
 ;
"RTN","DGENUPL2",73,0)
 ;want to ignore double quotes sent for enrollment fields
"RTN","DGENUPL2",74,0)
 S SUB=""
"RTN","DGENUPL2",75,0)
 F  S SUB=$O(DGENR(SUB)) Q:SUB=""  I DGENR(SUB)="@"!(DGENR(SUB)="""""") S DGENR(SUB)=""
"RTN","DGENUPL2",76,0)
 ;
"RTN","DGENUPL2",77,0)
 Q
"RTN","DGENUPL2",78,0)
 ;
"RTN","DGENUPL2",79,0)
ZMT ;
"RTN","DGENUPL2",80,0)
 I SEG(1)>1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ZMT SEGMENT, SEQ 1, SHOULD SPECIFY MEANS TEST",.ERRCOUNT) S ERROR=1 Q
"RTN","DGENUPL2",81,0)
 S DGELG("MTSTA")=$$CONVERT^DGENUPL1(SEG(3),"MT",.ERROR)
"RTN","DGENUPL2",82,0)
 I ERROR D  Q
"RTN","DGENUPL2",83,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMT SEGMENT, SEQ 3",.ERRCOUNT)
"RTN","DGENUPL2",84,0)
 Q
"RTN","DGENUPL2",85,0)
 ;
"RTN","DGENUPL2",86,0)
ZCD ;
"RTN","DGENUPL2",87,0)
 ;Phase II for multiple ZCD's
"RTN","DGENUPL2",88,0)
 I SEG(1)>1 G SKIP
"RTN","DGENUPL2",89,0)
 S DGCDIS("BY")=$$CONVERT^DGENUPL1(SEG(3))
"RTN","DGENUPL2",90,0)
 S DGCDIS("DATE")=$$CONVERT^DGENUPL1(SEG(5),"DATE",.ERROR)
"RTN","DGENUPL2",91,0)
 I ERROR D  Q
"RTN","DGENUPL2",92,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 5",.ERRCOUNT)
"RTN","DGENUPL2",93,0)
 S DGCDIS("FACDET")=$$CONVERT^DGENUPL1(SEG(4),"INSTITUTION",.ERROR)
"RTN","DGENUPL2",94,0)
 I ERROR D  Q
"RTN","DGENUPL2",95,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY "_SEG(4)_" MAKING CATASTROPHIC DISABILITY DETERMINATION NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
"RTN","DGENUPL2",96,0)
 S DGCDIS("REVDTE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
"RTN","DGENUPL2",97,0)
 I ERROR D  Q
"RTN","DGENUPL2",98,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 2",.ERRCOUNT)
"RTN","DGENUPL2",99,0)
 S DGCDIS("METDET")=$$CONVERT^DGENUPL1($P(SEG(6),$E(HLECH)))
"RTN","DGENUPL2",100,0)
 S DGCDIS("VCD")=$$CONVERT^DGENUPL1(SEG(12))
"RTN","DGENUPL2",101,0)
 ;SEQ 14 - DATE VETERAN REQUESTED CD EVALUATION
"RTN","DGENUPL2",102,0)
 S DGCDIS("VETREQDT")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
"RTN","DGENUPL2",103,0)
 I ERROR D  Q
"RTN","DGENUPL2",104,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 14",.ERRCOUNT)
"RTN","DGENUPL2",105,0)
 ;SEQ 15 - DATE FACILITY INITIATED REVIEW
"RTN","DGENUPL2",106,0)
 S DGCDIS("DTFACIRV")=$$CONVERT^DGENUPL1(SEG(15),"DATE",.ERROR)
"RTN","DGENUPL2",107,0)
 I ERROR D  Q
"RTN","DGENUPL2",108,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 15",.ERRCOUNT)
"RTN","DGENUPL2",109,0)
 ;SEQ 16 - DATE VETERAN WAS NOTIFIED
"RTN","DGENUPL2",110,0)
 S DGCDIS("DTVETNOT")=$$CONVERT^DGENUPL1(SEG(16),"DATE",.ERROR)
"RTN","DGENUPL2",111,0)
 I ERROR D  Q
"RTN","DGENUPL2",112,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 16",.ERRCOUNT)
"RTN","DGENUPL2",113,0)
SKIP ;
"RTN","DGENUPL2",114,0)
 ;Phase II Parse out additional fields.  CONVERT type of RSN converts the code to IEN for diagnosis,procedure and condition (HL7TORSN^DGENA5).
"RTN","DGENUPL2",115,0)
 S DGCDIS("DIAG",SEG(1))=$$CONVERT^DGENUPL1(SEG(7),"CDRSN")
"RTN","DGENUPL2",116,0)
 S DGCDIS("PROC",SEG(1))=$$CONVERT^DGENUPL1(SEG(8),"CDRSN")
"RTN","DGENUPL2",117,0)
 S DGCDIS("EXT",SEG(1),1)=$$CONVERT^DGENUPL1($P(SEG(9),$E(HLECH)),"EXT")
"RTN","DGENUPL2",118,0)
 S DGCDIS("COND",SEG(1))=$$CONVERT^DGENUPL1(SEG(10),"CDRSN")
"RTN","DGENUPL2",119,0)
 S DGCDIS("SCORE",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(11),$E(HLECH)))
"RTN","DGENUPL2",120,0)
 S DGCDIS("PERM",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(13),$E(HLECH)))
"RTN","DGENUPL2",121,0)
 I DGCDIS("VCD")="Y",'DGCDIS("DIAG",SEG(1)),'DGCDIS("PROC",SEG(1)),'DGCDIS("COND",SEG(1)) D  Q
"RTN","DGENUPL2",122,0)
 .S ERROR=1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"NO VALID DIAGNOSIS,PROCEDURE, OR CONDITION IN THE ZCD SEGMENT",.ERRCOUNT)
"RTN","DGENUPL2",123,0)
 Q
"RTN","DGENUPL2",124,0)
 ;
"RTN","DGENUPL2",125,0)
ZSP ;
"RTN","DGENUPL2",126,0)
 S DGELG("SC")=$$CONVERT^DGENUPL1(SEG(2),"Y/N",.ERROR)
"RTN","DGENUPL2",127,0)
 I ERROR D  Q
"RTN","DGENUPL2",128,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 2",.ERRCOUNT)
"RTN","DGENUPL2",129,0)
 S DGELG("SCPER")=$$CONVERT^DGENUPL1(SEG(3))
"RTN","DGENUPL2",130,0)
 S DGELG("POS")=$$CONVERT^DGENUPL1(SEG(4),"POS",.ERROR)
"RTN","DGENUPL2",131,0)
 I ERROR D  Q
"RTN","DGENUPL2",132,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 4",.ERRCOUNT)
"RTN","DGENUPL2",133,0)
 S DGELG("EFFDT")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
"RTN","DGENUPL2",134,0)
 I ERROR D  Q
"RTN","DGENUPL2",135,0)
 . D ADDERROR^DGENUPL(MSGID,$G(DGELG("EFFDT")),"BAD VALUE, ZSP SEGMENT, SEQ 11",.ERRCOUNT)
"RTN","DGENUPL2",136,0)
 ;if effective date is null, set update value to "@" (delete)
"RTN","DGENUPL2",137,0)
 I DGELG("EFFDT")="" S DGELG("EFFDT")="@"
"RTN","DGENUPL2",138,0)
 ;
"RTN","DGENUPL2",139,0)
 ;added 8/3/98 to reduce #rejects
"RTN","DGENUPL2",140,0)
 ;if HEC sends SC=NO, SC% not sent, and site has value for SC% then delete it
"RTN","DGENUPL2",141,0)
 I DGELG("SC")="N",DGELG("SCPER")="" S DGELG("SCPER")="@"
"RTN","DGENUPL2",142,0)
 ;
"RTN","DGENUPL2",143,0)
 S DGELG("P&T")=$$CONVERT^DGENUPL1(SEG(6),"Y/N",.ERROR)
"RTN","DGENUPL2",144,0)
 I ERROR D  Q
"RTN","DGENUPL2",145,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 6",.ERRCOUNT)
"RTN","DGENUPL2",146,0)
 S DGELG("UNEMPLOY")=$$CONVERT^DGENUPL1(SEG(7),"Y/N",.ERROR)
"RTN","DGENUPL2",147,0)
 I ERROR D  Q
"RTN","DGENUPL2",148,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 7",.ERRCOUNT)
"RTN","DGENUPL2",149,0)
 S DGELG("SCAWDATE")=$$CONVERT^DGENUPL1(SEG(8),"DATE",.ERROR)
"RTN","DGENUPL2",150,0)
 I ERROR D  Q
"RTN","DGENUPL2",151,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 8",.ERRCOUNT)
"RTN","DGENUPL2",152,0)
 S DGELG("P&TDT")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
"RTN","DGENUPL2",153,0)
 I ERROR D
"RTN","DGENUPL2",154,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 10 - P&T EFFECTIVE DATE",.ERRCOUNT)
"RTN","DGENUPL2",155,0)
 S DGPAT("DENTC2IN")=$$CONVERT^DGENUPL1(SEG(12),"Y/N",.ERROR)
"RTN","DGENUPL2",156,0)
 I ERROR D  Q
"RTN","DGENUPL2",157,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 12",.ERRCOUNT)
"RTN","DGENUPL2",158,0)
 S DGPAT("DENTC2DT")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
"RTN","DGENUPL2",159,0)
 I ERROR D  Q
"RTN","DGENUPL2",160,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 13",.ERRCOUNT)
"RTN","DGENUPL2",161,0)
 Q
"RTN","DGENUPL2",162,0)
 ;
"RTN","DGENUPL2",163,0)
ZMH ;Purple Heart, OEFOIE, POW
"RTN","DGENUPL2",164,0)
 D ZMH^DGENUPL3 ;Moved to DGENUPL3 - DG*5.3*653 
"RTN","DGENUPL2",165,0)
 Q
"RTN","DGENUPL2",166,0)
 ;
"RTN","DGENUPL2",167,0)
ZRD ;
"RTN","DGENUPL2",168,0)
 N COUNT,DXCODE,NAME,COND
"RTN","DGENUPL2",169,0)
 S DXCODE=$P(SEG(2),$E(HLECH))
"RTN","DGENUPL2",170,0)
 I DXCODE="""""" S DXCODE=""
"RTN","DGENUPL2",171,0)
 S NAME=$P(SEG(2),$E(HLECH),2)
"RTN","DGENUPL2",172,0)
 Q:DXCODE=""  ;segment does not contain a disability condition
"RTN","DGENUPL2",173,0)
 ;
"RTN","DGENUPL2",174,0)
 S COUNT=1+(+$G(DGELG("RATEDIS")))
"RTN","DGENUPL2",175,0)
 S (COND,DGELG("RATEDIS",COUNT,"RD"))=$$DCLOOKUP(DXCODE,NAME)
"RTN","DGENUPL2",176,0)
 S DGELG("RATEDIS",COUNT,"PER")=$$CONVERT^DGENUPL1(SEG(3)),DGELG("RATEDIS")=COUNT
"RTN","DGENUPL2",177,0)
 S DGELG("RATEDIS",COUNT,"RDEXT")=$$CONVERT^DGENUPL1(SEG(12))
"RTN","DGENUPL2",178,0)
 S DGELG("RATEDIS",COUNT,"RDORIG")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
"RTN","DGENUPL2",179,0)
 I ERROR D  Q
"RTN","DGENUPL2",180,0)
 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 13",.ERRCOUNT)
"RTN","DGENUPL2",181,0)
 S DGELG("RATEDIS",COUNT,"RDCURR")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
"RTN","DGENUPL2",182,0)
 I ERROR D  Q
"RTN","DGENUPL2",183,0)
 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 14",.ERRCOUNT)
"RTN","DGENUPL2",184,0)
 I 'COND D  Q
"RTN","DGENUPL2",185,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, SEQ 2 - DISABILTY CONDITION LOOKUP FAILED",.ERRCOUNT)
"RTN","DGENUPL2",186,0)
 .S ERROR=1
"RTN","DGENUPL2",187,0)
 Q
"RTN","DGENUPL2",188,0)
OBX ;
"RTN","DGENUPL2",189,0)
 D OBX^DGENUPLA  ;code for OBX segment moved to DGENUPLA
"RTN","DGENUPL2",190,0)
 Q
"RTN","DGENUPL2",191,0)
 ;
"RTN","DGENUPL2",192,0)
 ;*********** end of segment parsers ****
"RTN","DGENUPL2",193,0)
 ;
"RTN","DGENUPL2",194,0)
DCLOOKUP(DGCODE,DGNAME) ;
"RTN","DGENUPL2",195,0)
 ; Description: Returns the ien of a Disability Condition (file #31) based on the DGCODE and DGNAME
"RTN","DGENUPL2",196,0)
 ;
"RTN","DGENUPL2",197,0)
 ;Input:
"RTN","DGENUPL2",198,0)
 ;  DGCODE - DX Code of the Disability Condition
"RTN","DGENUPL2",199,0)
 ;  DGNAME - name of the Disability Condition
"RTN","DGENUPL2",200,0)
 ;Output:
"RTN","DGENUPL2",201,0)
 ;  Function Value: ien of the entry found, or 0 otherwise
"RTN","DGENUPL2",202,0)
 ;
"RTN","DGENUPL2",203,0)
 Q:(DGCODE="") 0
"RTN","DGENUPL2",204,0)
 N NODE,IEN,FOUND
"RTN","DGENUPL2",205,0)
 S (FOUND,IEN)=0
"RTN","DGENUPL2",206,0)
 F  S IEN=$O(^DIC(31,"C",DGCODE,IEN)) Q:'IEN  D  Q:FOUND
"RTN","DGENUPL2",207,0)
 .S NODE=$G(^DIC(31,IEN,0))
"RTN","DGENUPL2",208,0)
 .I DGNAME=$P(NODE,"^"),DGCODE=$P(NODE,"^",3) S FOUND=1
"RTN","DGENUPL2",209,0)
 I 'FOUND S IEN=$O(^DIC(31,"C",DGCODE,0))
"RTN","DGENUPL2",210,0)
 Q +IEN
"RTN","DGENUPL2",211,0)
 ;
"RTN","DGENUPL2",212,0)
REGCHECK(DFN) ;
"RTN","DGENUPL2",213,0)
 ; Description: passes patient through the registration consistency checker
"RTN","DGENUPL2",214,0)
 ;Input -
"RTN","DGENUPL2",215,0)
 ;  DFN - is a pointer to the Patient File
"RTN","DGENUPL2",216,0)
 ;
"RTN","DGENUPL2",217,0)
 N DGCD,DGCHK,DGDAY,DGEDCN,DGER,DGLST,DGNCK,DGRPCOLD,DGSC,DGTYPE,DGVT,VA,X
"RTN","DGENUPL2",218,0)
 ;
"RTN","DGENUPL2",219,0)
 S DGEDCN=0
"RTN","DGENUPL2",220,0)
 D ^DGRPC
"RTN","DGENUPL2",221,0)
 Q
"RTN","DGENUPL2",222,0)
PEND(DFN,DGSTAT) ;
"RTN","DGENUPL2",223,0)
 N DGARR,DGEC,DGERR,DGX
"RTN","DGENUPL2",224,0)
 I $P($G(^DPT(DFN,.361)),U)'="V" Q 0
"RTN","DGENUPL2",225,0)
 I $G(DGSTAT)="@" Q 0
"RTN","DGENUPL2",226,0)
 I $G(DGSTAT)']"" Q 0
"RTN","DGENUPL2",227,0)
 S DGSTAT="^"_DGSTAT_"^"
"RTN","DGENUPL2",228,0)
 Q:"^15^17^"'[DGSTAT 0
"RTN","DGENUPL2",229,0)
 D GETS^DIQ(2,DFN_",",".301;.302;.361;.36295","IE","DGARR","DGERR")
"RTN","DGENUPL2",230,0)
 I $D(DGERR) Q 0
"RTN","DGENUPL2",231,0)
 S DGEC=$G(DGARR(2,DFN_",",.361,"I"))
"RTN","DGENUPL2",232,0)
 I $G(DGEC)']"" Q 0
"RTN","DGENUPL2",233,0)
 S DGEC=$P($G(^DIC(8,DGEC,0)),U,9)
"RTN","DGENUPL2",234,0)
 I $G(DGEC)']"" Q 0
"RTN","DGENUPL2",235,0)
 I DGEC=5 Q 1
"RTN","DGENUPL2",236,0)
 I DGEC=3 D  Q DGX
"RTN","DGENUPL2",237,0)
 . S DGX=1
"RTN","DGENUPL2",238,0)
 . I $G(DGARR(2,DFN_",",.301,"I"))'="Y" S DGX=0 Q
"RTN","DGENUPL2",239,0)
 . I +$G(DGARR(2,DFN_",",.302,"I"))>0 S DGX=0 Q
"RTN","DGENUPL2",240,0)
 . I +$G(DGARR(2,DFN_",",.36295,"I"))>0 S DGX=0 Q
"RTN","DGENUPL2",241,0)
 Q 0
"RTN","DGENUPL4")
0^11^B87089440
"RTN","DGENUPL4",1,0)
DGENUPL4 ;ALB/CJM,RTK,ISA/KWP,ISD/GSN,PHH,RGL,PJR,BRM,TDM,TMK,EG,BAJ - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 6/28/11 4:36pm
"RTN","DGENUPL4",2,0)
 ;;5.3;REGISTRATION;**147,177,232,253,327,367,377,514,451,625,673,708,688,841,842**;Aug 13,1993;Build 33
"RTN","DGENUPL4",3,0)
 ;
"RTN","DGENUPL4",4,0)
UOBJECTS(DFN,DGPAT,DGELG,DGCDIS,DGOEIF,MSGID,ERRCOUNT,MSGS,OLDPAT,OLDELG,OLDCDIS,OLDOEIF) ;
"RTN","DGENUPL4",5,0)
 ;Used to update PATIENT, ELIGIBILITY, CATASTROPHIC
"RTN","DGENUPL4",6,0)
 ;DISABILITY, and OEF/OIF CONFLICT objects 'in memory'.
"RTN","DGENUPL4",7,0)
 ;
"RTN","DGENUPL4",8,0)
 ;Input:
"RTN","DGENUPL4",9,0)
 ;  DFN - ien of record in the PATIENT file
"RTN","DGENUPL4",10,0)
 ;  DGPAT - PATIENT object array (pass by reference)
"RTN","DGENUPL4",11,0)
 ;  DGELG - ELIGIBILITY object array (pass by ref)
"RTN","DGENUPL4",12,0)
 ;  DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
"RTN","DGENUPL4",13,0)
 ;  DGOEIF - OEF/OIF conflict object array (pass by ref)
"RTN","DGENUPL4",14,0)
 ;  MSGID - message control id of the HL7 message being processed
"RTN","DGENUPL4",15,0)
 ;  ERRCOUNT - count of errors (pass by ref)
"RTN","DGENUPL4",16,0)
 ;  MSGS - array of messages for the site (pass by ref)
"RTN","DGENUPL4",17,0)
 ;
"RTN","DGENUPL4",18,0)
 ;Output:
"RTN","DGENUPL4",19,0)
 ;  Function Value: 1 if update was successful 'in memory',
"RTN","DGENUPL4",20,0)
 ;           consistency checks pass and the objects can be stored in
"RTN","DGENUPL4",21,0)
 ;           the local database, 0 otherwise.
"RTN","DGENUPL4",22,0)
 ;  DGPAT - PATIENT object array (pass by reference)
"RTN","DGENUPL4",23,0)
 ;  DGELG - ELIGIBILITY object array (pass by ref)
"RTN","DGENUPL4",24,0)
 ;  DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
"RTN","DGENUPL4",25,0)
 ;  ERRCOUNT - count of errors (pass by ref)
"RTN","DGENUPL4",26,0)
 ;  MSGS - array of messages for the site (pass by ref)
"RTN","DGENUPL4",27,0)
 ;  OLDPAT - patient object array as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",28,0)
 ;  OLDELG - eligibility object array as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",29,0)
 ;  OLDCDIS - catastrophically disability object array as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",30,0)
 ;  OLDOEIF - OEF/OIF conflict data as it currently exists in database before the update (pass by ref)
"RTN","DGENUPL4",31,0)
 ;
"RTN","DGENUPL4",32,0)
 N DGPAT3,DGELG3,DGCDIS3,SUCCESS
"RTN","DGENUPL4",33,0)
 S SUCCESS=1
"RTN","DGENUPL4",34,0)
 D
"RTN","DGENUPL4",35,0)
 .;first get local site's current data
"RTN","DGENUPL4",36,0)
 .I ('$$GET^DGENPTA(DFN,.OLDPAT))!('$$GET^DGENELA(DFN,.OLDELG))!('$$GET^DGENCDA(DFN,.OLDCDIS))!('$P($$GET^DGENOEIF(DFN,.OLDOEIF,0),U,2)) D  Q
"RTN","DGENUPL4",37,0)
 ..D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"UNABLE TO ACCESS PATIENT RECORD",.ERRCOUNT)
"RTN","DGENUPL4",38,0)
 ..S SUCCESS=0
"RTN","DGENUPL4",39,0)
 .;
"RTN","DGENUPL4",40,0)
 .;Phase II CD Consistency Checks (SRS 6.5.1.4) check VISTA against HEC
"RTN","DGENUPL4",41,0)
 .S SUCCESS=$$CDCHECK^DGENUPL9()
"RTN","DGENUPL4",42,0)
 .Q:'SUCCESS
"RTN","DGENUPL4",43,0)
 .;
"RTN","DGENUPL4",44,0)
 .;If no 'MH' ZMH segment or Z11 value is null delete VistA value.
"RTN","DGENUPL4",45,0)
 .I ($G(DGPAT("MOH"))="")&($G(OLDPAT("MOH"))'="") S DGPAT("MOH")="@"
"RTN","DGENUPL4",46,0)
 .I ($G(DGELG("MOH"))="")&($G(OLDELG("MOH"))'="") S DGELG("MOH")="@"
"RTN","DGENUPL4",47,0)
 .;
"RTN","DGENUPL4",48,0)
 .; Don't upload Pension data if site Pension Reason='Original Award'
"RTN","DGENUPL4",49,0)
 .; & Site Pension Effective Date <= the Z11 Pension Effective Date
"RTN","DGENUPL4",50,0)
 .; & the Z11 does not contain a Termination Date.
"RTN","DGENUPL4",51,0)
 .I +$G(OLDPAT("PENAREAS")),$P($G(^DG(27.18,OLDPAT("PENAREAS"),0)),U,2)="00" D
"RTN","DGENUPL4",52,0)
 ..I (OLDPAT("PENAEFDT")<($G(DGPAT("PENAEFDT"))+1)),($G(DGPAT("PENTRMDT"))<1) D
"RTN","DGENUPL4",53,0)
 ...N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4","PILOCK","PALOCK" S DGPAT(SUB)=""
"RTN","DGENUPL4",54,0)
 .;
"RTN","DGENUPL4",55,0)
 .;If Z11 Pension fields are set, initialize VistA Lock fields to "@"
"RTN","DGENUPL4",56,0)
 .N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" I $G(DGPAT(SUB))'="" D
"RTN","DGENUPL4",57,0)
 ..S:(OLDPAT("PILOCK")'="") DGPAT("PILOCK")="@"
"RTN","DGENUPL4",58,0)
 ..S:(OLDPAT("PALOCK")'="") DGPAT("PALOCK")="@"
"RTN","DGENUPL4",59,0)
 .;
"RTN","DGENUPL4",60,0)
 .;If Z11 RECEIVING A VA PENSION? not null, Pension Indicator Lock=Y
"RTN","DGENUPL4",61,0)
 .;If Z11 RECEIVING A VA PENSION? deletion, Pension Indicator Lock=@
"RTN","DGENUPL4",62,0)
 .S:DGELG("VAPEN")'="" DGPAT("PILOCK")="Y"
"RTN","DGENUPL4",63,0)
 .S:DGELG("VAPEN")="@" DGPAT("PILOCK")="@"
"RTN","DGENUPL4",64,0)
 .;
"RTN","DGENUPL4",65,0)
 .;If any Z11 Pension fields populated, Pension Indicator Lock=Y
"RTN","DGENUPL4",66,0)
 .N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" I $G(DGPAT(SUB))'="",$G(DGPAT(SUB))'="@" S DGPAT("PILOCK")="Y"
"RTN","DGENUPL4",67,0)
 .;
"RTN","DGENUPL4",68,0)
 .;If Z11 Pension Termination Reason received, Pension Award Lock=Y
"RTN","DGENUPL4",69,0)
 .N SUB F SUB="PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" I $G(DGPAT(SUB))'="",$G(DGPAT(SUB))'="@" S DGPAT("PALOCK")="Y"
"RTN","DGENUPL4",70,0)
 .;
"RTN","DGENUPL4",71,0)
 .;If Z11 Pension Award Reason='Original Award', Pension Award Lock=Y
"RTN","DGENUPL4",72,0)
 .I +$G(DGPAT("PENAREAS")),$P($G(^DG(27.18,DGPAT("PENAREAS"),0)),U,2)="00" S DGPAT("PALOCK")="Y"
"RTN","DGENUPL4",73,0)
 .;
"RTN","DGENUPL4",74,0)
 .;now merge with the update
"RTN","DGENUPL4",75,0)
 .D MERGE
"RTN","DGENUPL4",76,0)
 .;
"RTN","DGENUPL4",77,0)
 .;add the assumed values
"RTN","DGENUPL4",78,0)
 .D ADD
"RTN","DGENUPL4",79,0)
 .;
"RTN","DGENUPL4",80,0)
 .;now do the consistency checks
"RTN","DGENUPL4",81,0)
 .S SUCCESS=$$CHECK()
"RTN","DGENUPL4",82,0)
 .Q:'SUCCESS
"RTN","DGENUPL4",83,0)
 .;
"RTN","DGENUPL4",84,0)
 .;replace input arrays with fully updated versions
"RTN","DGENUPL4",85,0)
 .K DGPAT M DGPAT=DGPAT3
"RTN","DGENUPL4",86,0)
 .K DGELG M DGELG=DGELG3
"RTN","DGENUPL4",87,0)
 .K DGCDIS M DGCDIS=DGCDIS3
"RTN","DGENUPL4",88,0)
 ;
"RTN","DGENUPL4",89,0)
 I SUCCESS D
"RTN","DGENUPL4",90,0)
 .;
"RTN","DGENUPL4",91,0)
 .;list of required notifications
"RTN","DGENUPL4",92,0)
 .;
"RTN","DGENUPL4",93,0)
 .;change in date of death
"RTN","DGENUPL4",94,0)
 .I DGPAT("DEATH"),$P(OLDPAT("DEATH"),".")'=$P(DGPAT("DEATH"),".") D
"RTN","DGENUPL4",95,0)
 ..D ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS DATE OF DEATH = "_$$FMTE^XLFDT(DGPAT("DEATH"),"1"),1)
"RTN","DGENUPL4",96,0)
 ..D ADDMSG^DGENUPL3(.MSGS,$S('OLDPAT("DEATH"):"SITE DOES NOT HAVE DATE OF DEATH",1:"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1")),1)
"RTN","DGENUPL4",97,0)
 .;
"RTN","DGENUPL4",98,0)
 .I OLDPAT("DEATH"),'DGPAT("DEATH") D
"RTN","DGENUPL4",99,0)
 ..D ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS NO DATE OF DEATH",1)
"RTN","DGENUPL4",100,0)
 ..D ADDMSG^DGENUPL3(.MSGS,"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1"),1)
"RTN","DGENUPL4",101,0)
 .;
"RTN","DGENUPL4",102,0)
 .;change in POW
"RTN","DGENUPL4",103,0)
 .I OLDELG("POW")="N",DGELG("POW")="Y" D ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO YES")
"RTN","DGENUPL4",104,0)
 .I OLDELG("POW")="Y",DGELG("POW")="N" D ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO NO")
"RTN","DGENUPL4",105,0)
 .;
"RTN","DGENUPL4",106,0)
 .;SC to NSC
"RTN","DGENUPL4",107,0)
 .I OLDELG("SC")="Y",DGELG("SC")="N" D ADDMSG^DGENUPL3(.MSGS,"VETERAN CHANGED TO NON-SERVICE CONNECTED",1)
"RTN","DGENUPL4",108,0)
 .;
"RTN","DGENUPL4",109,0)
 .; Change from Eligible to Ineligible
"RTN","DGENUPL4",110,0)
 .I 'OLDPAT("INELDATE"),DGPAT("INELDATE") D ADDMSG^DGENUPL3(.MSGS,"VETERAN PREVIOUSLY ELIGIBLE FOR VA HEALTH CARE, NOW INELIGIBLE.",1)
"RTN","DGENUPL4",111,0)
 .;
"RTN","DGENUPL4",112,0)
 .; Check for erroneous CD deletion
"RTN","DGENUPL4",113,0)
 .I OLDCDIS("VCD")="","@"[DGCDIS("VCD") Q  ;no notification is needed
"RTN","DGENUPL4",114,0)
 .;
"RTN","DGENUPL4",115,0)
 .; CD Determination Changed
"RTN","DGENUPL4",116,0)
 .I OLDCDIS("VCD")'=DGCDIS("VCD") D ADDMSG^DGENUPL3(.MSGS,"VETERANS CD EVALUATION HAS CHANGED.")
"RTN","DGENUPL4",117,0)
 D EP^DGENUPLB
"RTN","DGENUPL4",118,0)
 Q SUCCESS
"RTN","DGENUPL4",119,0)
 ;
"RTN","DGENUPL4",120,0)
ADD ;
"RTN","DGENUPL4",121,0)
 ;Description: adds computed and assumed values to the updated objects
"RTN","DGENUPL4",122,0)
 ;
"RTN","DGENUPL4",123,0)
 ;Input: DGELG3(),DGPAT3() created in the UOBJECTS procedure.
"RTN","DGENUPL4",124,0)
 ;
"RTN","DGENUPL4",125,0)
 N SUB,TYPE,DATA
"RTN","DGENUPL4",126,0)
 S DGELG3("ELIGENTBY")=.5
"RTN","DGENUPL4",127,0)
 S SUB=0 F  S SUB=$O(DGELG3("RATEDIS",SUB)) Q:'SUB  S DGELG3("RATEDIS",SUB,"RDSC")=1
"RTN","DGENUPL4",128,0)
 ;
"RTN","DGENUPL4",129,0)
 ; Default Patient Types
"RTN","DGENUPL4",130,0)
 D SCVET^DGENUPL3
"RTN","DGENUPL4",131,0)
 ;
"RTN","DGENUPL4",132,0)
 ; If Ineldate apply business rules
"RTN","DGENUPL4",133,0)
 I DGPAT3("INELDATE"),DGELG3("SC")'="Y" D
"RTN","DGENUPL4",134,0)
 .S DGPAT3("VETERAN")="N",DGPAT3("PATYPE")=$O(^DG(391,"B","NON-VETERAN (OTHER)",0))
"RTN","DGENUPL4",135,0)
 .S DGELG3("POS")=$O(^DIC(21,"B","OTHER NON-VETERANS",0))
"RTN","DGENUPL4",136,0)
 ;
"RTN","DGENUPL4",137,0)
 ;update/set ELIGIBILITY VERIF. SOURCE field (Ineligible Project):
"RTN","DGENUPL4",138,0)
 S DATA(.3613)=$S(DGELG3("ELIGVERIF")["VBA":"H",DGELG3("ELIGVERIF")["CEV":"H",DGELG3("ELIGVERIF")["VIVA":"H",1:"V")
"RTN","DGENUPL4",139,0)
 ;
"RTN","DGENUPL4",140,0)
 ; File data fields modified by Ineligible Business Rules
"RTN","DGENUPL4",141,0)
 I $$UPD^DGENDBS(2,DFN,.DATA,.ERROR)
"RTN","DGENUPL4",142,0)
 Q
"RTN","DGENUPL4",143,0)
 ;
"RTN","DGENUPL4",144,0)
MERGE ;
"RTN","DGENUPL4",145,0)
 ;Description: merges arrays with current patient data with the updates
"RTN","DGENUPL4",146,0)
 ; Merges DGPAT() + OLDPAT() -> DGPAT3()
"RTN","DGENUPL4",147,0)
 ;        DGELG() + OLDELG() -> DGELG3()
"RTN","DGENUPL4",148,0)
 ; overlays catastrophic disability array with data from HEC
"RTN","DGENUPL4",149,0)
 ;        DGCDIS() is info from HEC
"RTN","DGENUPL4",150,0)
 ;
"RTN","DGENUPL4",151,0)
 N SUB,SUB2,LOC,HEC,NATCODE
"RTN","DGENUPL4",152,0)
 M DGPAT3=OLDPAT,DGELG3=OLDELG
"RTN","DGENUPL4",153,0)
 ;Replace POW in VistA with HEC data
"RTN","DGENUPL4",154,0)
 I '$D(DGPAT3("POWI")) S DGELG3("POW")=""
"RTN","DGENUPL4",155,0)
 K DGCDIS3 M DGCDIS3=OLDCDIS K DGCDIS3("EXT"),DGCDIS3("PROC"),DGCDIS3("COND"),DGCDIS3("DIAG")
"RTN","DGENUPL4",156,0)
 ;
"RTN","DGENUPL4",157,0)
 ;discard MT status from local database - don't ever want to use it during upload
"RTN","DGENUPL4",158,0)
 S DGELG3("MTSTA")=DGELG("MTSTA")
"RTN","DGENUPL4",159,0)
 ;
"RTN","DGENUPL4",160,0)
 ;patient array
"RTN","DGENUPL4",161,0)
 S SUB=""
"RTN","DGENUPL4",162,0)
 F  S SUB=$O(DGPAT(SUB)) Q:(SUB="")  I (DGPAT(SUB)'="") S DGPAT3(SUB)=$S((DGPAT(SUB)="@"):"",1:DGPAT(SUB))
"RTN","DGENUPL4",163,0)
 ;
"RTN","DGENUPL4",164,0)
 ;Allow Ineligible info deletion (Ineligible Project):
"RTN","DGENUPL4",165,0)
 I $D(DGPAT("INELDEC")),DGPAT("INELDEC")="" S DGPAT("INELDEC")="@"
"RTN","DGENUPL4",166,0)
 I $D(DGPAT("INELREA")),DGPAT("INELREA")="" S DGPAT("INELREA")="@"
"RTN","DGENUPL4",167,0)
 I $D(DGPAT("INELDATE")),DGPAT("INELDATE")="" S DGPAT("INELDATE")="@"
"RTN","DGENUPL4",168,0)
 ;
"RTN","DGENUPL4",169,0)
 ;catastrophic disability array
"RTN","DGENUPL4",170,0)
 S SUB=""
"RTN","DGENUPL4",171,0)
 F  S SUB=$O(DGCDIS(SUB)) Q:(SUB="")  D
"RTN","DGENUPL4",172,0)
 .I $D(DGCDIS(SUB))=1 I ($G(DGCDIS(SUB))'="") S DGCDIS3(SUB)=DGCDIS(SUB)
"RTN","DGENUPL4",173,0)
 .I $D(DGCDIS(SUB))=10 D
"RTN","DGENUPL4",174,0)
 ..S SUB2=""
"RTN","DGENUPL4",175,0)
 ..F  S SUB2=$O(DGCDIS(SUB,SUB2)) Q:SUB2=""  D
"RTN","DGENUPL4",176,0)
 ...I ($G(DGCDIS(SUB,SUB2))'="") S DGCDIS3(SUB,SUB2)=DGCDIS(SUB,SUB2)
"RTN","DGENUPL4",177,0)
 ...I SUB="PROC" D
"RTN","DGENUPL4",178,0)
 ....N CDPROC,CDEXT,LIEN
"RTN","DGENUPL4",179,0)
 ....S CDPROC=$G(DGCDIS("PROC",SUB2))
"RTN","DGENUPL4",180,0)
 ....Q:CDPROC=""
"RTN","DGENUPL4",181,0)
 ....S CDEXT=$G(DGCDIS("EXT",SUB2,1))
"RTN","DGENUPL4",182,0)
 ....Q:CDEXT=""
"RTN","DGENUPL4",183,0)
 ....S LIEN=$O(^DGEN(27.17,CDPROC,1,"B",CDEXT,0))
"RTN","DGENUPL4",184,0)
 ....Q:LIEN=""
"RTN","DGENUPL4",185,0)
 ....S DGCDIS3("EXT",SUB2,LIEN)=CDEXT
"RTN","DGENUPL4",186,0)
 ;
"RTN","DGENUPL4",187,0)
 ;eligibility array
"RTN","DGENUPL4",188,0)
 F  S SUB=$O(DGELG(SUB)) Q:(SUB="")  I ($G(DGELG(SUB))'="") S DGELG3(SUB)=$S((DGELG(SUB)="@"):"",1:DGELG(SUB))
"RTN","DGENUPL4",189,0)
 ;
"RTN","DGENUPL4",190,0)
 ;rated disabilities from HEC should replace local sites
"RTN","DGENUPL4",191,0)
 D
"RTN","DGENUPL4",192,0)
 .K DGELG3("RATEDIS")
"RTN","DGENUPL4",193,0)
 .M DGELG3("RATEDIS")=DGELG("RATEDIS")
"RTN","DGENUPL4",194,0)
 ;
"RTN","DGENUPL4",195,0)
 ;primary eligibility
"RTN","DGENUPL4",196,0)
 I (DGELG("ELIG","CODE")'="") S DGELG3("ELIG","CODE")=$S((DGELG("ELIG","CODE")="@"):"",($$NATCODE^DGENELA(DGELG("ELIG","CODE"))=$$NATCODE^DGENELA(DGELG3("ELIG","CODE"))):DGELG3("ELIG","CODE"),1:DGELG("ELIG","CODE"))
"RTN","DGENUPL4",197,0)
 ;
"RTN","DGENUPL4",198,0)
 ;patient eligibilities multiple
"RTN","DGENUPL4",199,0)
 ;delete veteran type codes not mapped to national codes sent by HEC, but leave non-veteran types and the codes where there is a match
"RTN","DGENUPL4",200,0)
 ;first find all local codes already in the patient file and the ones sent from HEC, keep in arrays LOC and HEC
"RTN","DGENUPL4",201,0)
 S NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE")) I NATCODE S HEC(NATCODE)=""
"RTN","DGENUPL4",202,0)
 S SUB=0 F  S SUB=$O(DGELG("ELIG","CODE",SUB)) Q:'SUB  S NATCODE=$$NATCODE^DGENELA(SUB) I NATCODE S HEC(NATCODE)=""
"RTN","DGENUPL4",203,0)
 S SUB=0 F  S SUB=$O(DGELG3("ELIG","CODE",SUB)) Q:'SUB  S NATCODE=$$NATCODE^DGENELA(SUB) I NATCODE S LOC(NATCODE)=""
"RTN","DGENUPL4",204,0)
 ;Now discard the codes in the local patient database that don't map to a national code sent by HEC, as well as HUMANIARIAN EMERGENCY code if not sent by HEC: 
"RTN","DGENUPL4",205,0)
 S SUB=0
"RTN","DGENUPL4",206,0)
 F  S SUB=$O(DGELG3("ELIG","CODE",SUB)) Q:'SUB  D
"RTN","DGENUPL4",207,0)
 .I $P($G(^DIC(8,SUB,0)),"^",5)="Y"!($P($G(^DIC(8,SUB,0)),"^")["HUMANITARIAN EMERGENCY"),'$D(HEC($$NATCODE^DGENELA(SUB))) K DGELG3("ELIG","CODE",SUB)
"RTN","DGENUPL4",208,0)
 ;now add codes included in the update that the local database does not already contain
"RTN","DGENUPL4",209,0)
 S SUB=0
"RTN","DGENUPL4",210,0)
 F  S SUB=$O(DGELG("ELIG","CODE",SUB)) Q:'SUB  D
"RTN","DGENUPL4",211,0)
 .I '$D(LOC($$NATCODE^DGENELA(SUB))) S DGELG3("ELIG","CODE",SUB)=SUB
"RTN","DGENUPL4",212,0)
 ;Agent Orange Exp. Location, use local database when upload is NULL
"RTN","DGENUPL4",213,0)
 D AO^DGENUPL9
"RTN","DGENUPL4",214,0)
 Q
"RTN","DGENUPL4",215,0)
 ;
"RTN","DGENUPL4",216,0)
CHECK() ;
"RTN","DGENUPL4",217,0)
 ;
"RTN","DGENUPL4",218,0)
 N SUCCESS,ALIVE,ERRMSG,DGENR
"RTN","DGENUPL4",219,0)
 S SUCCESS=1
"RTN","DGENUPL4",220,0)
 S ERRMSG=""
"RTN","DGENUPL4",221,0)
 ;
"RTN","DGENUPL4",222,0)
 ;if upload includes date of death, check for indications that patient is alive
"RTN","DGENUPL4",223,0)
 I DGPAT3("DEATH"),'OLDPAT("DEATH") D  S:ALIVE SUCCESS=0
"RTN","DGENUPL4",224,0)
 .;
"RTN","DGENUPL4",225,0)
 .;determine if patient is at the moment being registered
"RTN","DGENUPL4",226,0)
 .S ALIVE=$$IFREG^DGREG(DFN)
"RTN","DGENUPL4",227,0)
 .;
"RTN","DGENUPL4",228,0)
 .;check if an inpatient
"RTN","DGENUPL4",229,0)
 .I 'ALIVE,$$INPAT^DGENPTA(DFN,DT,DT) S ALIVE=1
"RTN","DGENUPL4",230,0)
 .;
"RTN","DGENUPL4",231,0)
 .;Phase II locally enrolled with enrollment date after death date and status of unverified and rejected-initial application by vamc (SRS 6.5.1.2 e)
"RTN","DGENUPL4",232,0)
 .N CURIEN,CURENR
"RTN","DGENUPL4",233,0)
 .S CURIEN=$$FINDCUR^DGENA(DFN)
"RTN","DGENUPL4",234,0)
 .I CURIEN,$$GET^DGENA(CURIEN,.CURENR),CURENR("DATE")>DGPAT3("DEATH"),CURENR("STATUS")=1!(CURENR("STATUS")=14) S ALIVE=1
"RTN","DGENUPL4",235,0)
 .;there is an indication that he patient may not be dead
"RTN","DGENUPL4",236,0)
 .D:ALIVE ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE VERIFY PATIENT DEATH",.ERRCOUNT),ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD CONTAINED DATE OF DEATH AND WAS REJECTED, PLEASE VERIFY PATIENT DEATH",1),NOTIFY^DGENUPL3(.DGPAT,.MSGS)
"RTN","DGENUPL4",237,0)
 ;
"RTN","DGENUPL4",238,0)
 ;only do consistency checks on this data if it is verified
"RTN","DGENUPL4",239,0)
 I SUCCESS,(DGELG3("ELIGSTA")="V") D
"RTN","DGENUPL4",240,0)
 .I $$CHECK^DGENPTA1(.DGPAT3,.ERRMSG),$$CHECK^DGENELA1(.DGELG3,.DGPAT3,.DGCDIS3,.ERRMSG),$$CHECK^DGENCDA1(.DGCDIS3,.ERRMSG)
"RTN","DGENUPL4",241,0)
 .E  D
"RTN","DGENUPL4",242,0)
 ..S SUCCESS=0
"RTN","DGENUPL4",243,0)
 ..D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL4",244,0)
 Q SUCCESS
"RTN","DGENUPLB")
0^9^B9493909
"RTN","DGENUPLB",1,0)
DGENUPLB ;ALB/TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 5/19/11 12:30pm
"RTN","DGENUPLB",2,0)
 ;;5.3;REGISTRATION;**625,763,842**;Aug 13,1993;Build 33
"RTN","DGENUPLB",3,0)
 ;
"RTN","DGENUPLB",4,0)
EP N MSGARY
"RTN","DGENUPLB",5,0)
 D CHECK
"RTN","DGENUPLB",6,0)
 Q
"RTN","DGENUPLB",7,0)
 ;
"RTN","DGENUPLB",8,0)
CHECK ;Check for Rated Disability Changes
"RTN","DGENUPLB",9,0)
 Q:'$D(DGELG)
"RTN","DGENUPLB",10,0)
 N RDOCC,TMPARY,RD,RDOCC1,RDOCC2,RDFLG,RDNOD
"RTN","DGENUPLB",11,0)
 ;
"RTN","DGENUPLB",12,0)
 ;Change in Rated Disabilities
"RTN","DGENUPLB",13,0)
 I $D(OLDELG("RATEDIS")) D
"RTN","DGENUPLB",14,0)
 .S RDOCC=0 F  S RDOCC=$O(OLDELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
"RTN","DGENUPLB",15,0)
 ..S RD=$P(OLDELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
"RTN","DGENUPLB",16,0)
 ..S TMPARY(RD)=RDOCC
"RTN","DGENUPLB",17,0)
 ;
"RTN","DGENUPLB",18,0)
 I $D(DGELG("RATEDIS")) D
"RTN","DGENUPLB",19,0)
 .S RDOCC=0 F  S RDOCC=$O(DGELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
"RTN","DGENUPLB",20,0)
 ..S RD=$P(DGELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
"RTN","DGENUPLB",21,0)
 ..S $P(TMPARY(RD),"^",2)=RDOCC
"RTN","DGENUPLB",22,0)
 ;
"RTN","DGENUPLB",23,0)
 I $D(TMPARY) D
"RTN","DGENUPLB",24,0)
 .S RD=""
"RTN","DGENUPLB",25,0)
 .F  S RD=$O(TMPARY(RD)) Q:RD=""  D
"RTN","DGENUPLB",26,0)
 ..S RDOCC2=+$P(TMPARY(RD),"^",2) Q:'RDOCC2
"RTN","DGENUPLB",27,0)
 ..S RDOCC1=+$P(TMPARY(RD),"^")
"RTN","DGENUPLB",28,0)
 ..I 'RDOCC1 D STOR390 Q
"RTN","DGENUPLB",29,0)
 ..S RDFLG=0
"RTN","DGENUPLB",30,0)
 ..F RDNOD="RD","PER","RDSC","RDEXT","RDORIG","RDCURR" D  Q:RDFLG
"RTN","DGENUPLB",31,0)
 ...I $G(OLDELG("RATEDIS",RDOCC1,RDNOD))'=$G(DGELG("RATEDIS",RDOCC2,RDNOD)) D STOR390
"RTN","DGENUPLB",32,0)
 Q
"RTN","DGENUPLB",33,0)
 ;
"RTN","DGENUPLB",34,0)
STOR390 ;Store Data in file# 390
"RTN","DGENUPLB",35,0)
 S RDFLG=1
"RTN","DGENUPLB",36,0)
 N DATA,DA
"RTN","DGENUPLB",37,0)
 S DATA(.01)=$$NOW^XLFDT
"RTN","DGENUPLB",38,0)
 S DATA(2)=DFN
"RTN","DGENUPLB",39,0)
 S DATA(3)=DGELG("RATEDIS",RDOCC2,"RD")
"RTN","DGENUPLB",40,0)
 S DATA(4)=DGELG("RATEDIS",RDOCC2,"PER")
"RTN","DGENUPLB",41,0)
 S DATA(5)=DGELG("RATEDIS",RDOCC2,"RDEXT")
"RTN","DGENUPLB",42,0)
 S DATA(6)=DGELG("RATEDIS",RDOCC2,"RDORIG")
"RTN","DGENUPLB",43,0)
 S DATA(7)=DGELG("RATEDIS",RDOCC2,"RDCURR")
"RTN","DGENUPLB",44,0)
 I '$$ADD^DGENDBS(390,,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILITY UPLOAD AUDIT"
"RTN","DGENUPLB",45,0)
 Q
"RTN","DGENUPLB",46,0)
 ;
"RTN","DGENUPLB",47,0)
ZE2 ; Process ZE2 segment
"RTN","DGENUPLB",48,0)
 N HL7REP,HL7SC,SUB
"RTN","DGENUPLB",49,0)
 S HL7SC=$E(HLECH,1)
"RTN","DGENUPLB",50,0)
 S DGPAT("PENAEFDT")=$$CONVERT^DGENUPL1($P(SEG(1),HL7SC),"DATE",.ERROR)
"RTN","DGENUPLB",51,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 1-1",.ERRCOUNT) Q
"RTN","DGENUPLB",52,0)
 S DGPAT("PENTRMDT")=$$CONVERT^DGENUPL1($P(SEG(1),HL7SC,2),"DATE",.ERROR)
"RTN","DGENUPLB",53,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 1-2",.ERRCOUNT) Q
"RTN","DGENUPLB",54,0)
 S DGPAT("PENAREAS")=$$CONVERT^DGENUPL1($P(SEG(2),HL7SC),"PENSIONCD",.ERRCOUNT)
"RTN","DGENUPLB",55,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 2",.ERRCOUNT) Q
"RTN","DGENUPLB",56,0)
 F HL7REP=1:1:4 D  Q:ERROR
"RTN","DGENUPLB",57,0)
 .Q:$P($P(SEG(3),"|",HL7REP),HL7SC)=""
"RTN","DGENUPLB",58,0)
 .S SUB="PENTRMR"_HL7REP
"RTN","DGENUPLB",59,0)
 .S DGPAT(SUB)=$$CONVERT^DGENUPL1($P($P(SEG(3),"|",HL7REP),HL7SC),"PENSIONCD",.ERRCOUNT)
"RTN","DGENUPLB",60,0)
 .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 3",.ERRCOUNT)
"RTN","DGENUPLB",61,0)
 ;
"RTN","DGENUPLB",62,0)
 ; Convert to deletion indicator if null
"RTN","DGENUPLB",63,0)
 N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S:$G(DGPAT(SUB))="" DGPAT(SUB)="@"
"RTN","DGENUPLB",64,0)
 Q
"RTN","DGRP6")
0^3^B18281969
"RTN","DGRP6",1,0)
DGRP6 ;ALB/MRL,LBD,TMK - REGISTRATION SCREEN 6/SERVICE INFORMATION ; 5/12/11 10:49am
"RTN","DGRP6",2,0)
 ;;5.3;Registration;**161,247,343,397,342,451,672,689,797,841,842**;Aug 13, 1993;Build 33
"RTN","DGRP6",3,0)
 N DIPA,LIN,XX,Z1,GLBL
"RTN","DGRP6",4,0)
 S DGRPS=6 D H^DGRPU F I=.32,.321,.322,.36,.385,.52,.53,.54 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP6",5,0)
 S (DGRPW,Z)=1 D WW2^DGRPV S Z=" Service Branch/Component",Z1=27 D WW1^DGRPV S Z="Service #",Z1=16 D WW1^DGRPV S Z=" Entered",Z1=12 D WW1^DGRPV S Z="Separated",Z1=12 D WW1^DGRPV W "Discharge"
"RTN","DGRP6",6,0)
 W !?4,"------------------------",?30,"---------",?47,"-------",?58,"---------",?70,"---------"
"RTN","DGRP6",7,0)
 ;Get MSEs from Military Service Episode sub-file #2.3216 (DG*5.3*797)
"RTN","DGRP6",8,0)
 K ^TMP("DGRP6",$J)
"RTN","DGRP6",9,0)
 S GLBL=$NA(^TMP("DGRP6",$J))
"RTN","DGRP6",10,0)
 D GETMSE^DGRP61(DFN,GLBL,0)
"RTN","DGRP6",11,0)
 D S
"RTN","DGRP6",12,0)
 W !
"RTN","DGRP6",13,0)
 D CL^DGRP6CL2(DFN,.LIN)
"RTN","DGRP6",14,0)
 S Z=2 D WW2^DGRPV S Z="  Conflict Locations: ",Z1=20 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
"RTN","DGRP6",15,0)
 S Z=1 F  S Z=$O(LIN(Z)) Q:'Z  W !,?25,LIN(Z)
"RTN","DGRP6",16,0)
 D EF^DGRP6EF(DFN,.LIN)
"RTN","DGRP6",17,0)
 S Z=3 D WW2^DGRPV S Z=" Environment Factors: ",Z1=21 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
"RTN","DGRP6",18,0)
 S Z=1 F  S Z=$O(LIN(Z)) Q:'Z  W !,?4,"+ ",LIN(Z)
"RTN","DGRP6",19,0)
 S Z=4,DGRPX=DGRP(.52) D WW^DGRPV W "          POW: " S X=5,Z1=6 D YN W "From: " S X=7,Z1=13 D DAT W "To: " S X=8,Z1=12 D DAT W "War: ",$S($D(^DIC(22,+$P(DGRPX,"^",6),0)):$P(^(0),"^",2),1:"")
"RTN","DGRP6",20,0)
 S Z=5 D WW^DGRPV W "       Combat: " S X=11,Z1=6 D YN W "From: " S X=13,Z1=13 D DAT W "To: " S X=14,Z1=12 D DAT W "Loc: ",$S($D(^DIC(22,+$P(DGRPX,"^",12),0)):$P(^(0),"^",2),1:"")
"RTN","DGRP6",21,0)
 S Z=6 D WW^DGRPV S X=$P(DGRP(.36),"^",12),XX=$P(DGRP(.36),"^",13)
"RTN","DGRP6",22,0)
 N DGSPACE
"RTN","DGRP6",23,0)
 S DGSPACE=$S($G(X)="0":" ",$G(X)="1":"",1:"   ")
"RTN","DGRP6",24,0)
 W "     Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"") W DGSPACE_"        Dischrg Due to Disab: ",$S(XX=0:"NO",XX=1:"YES",1:"")
"RTN","DGRP6",25,0)
 ;W !
"RTN","DGRP6",26,0)
 S Z=7 D WW^DGRPV W "     Dent Inj: " S DGRPX=DGRP(.36),X=8,Z1=28 D YN W "Teeth Extracted: " S X=9,Z1=9 D YN S DGRPD=0 I $P(DGRPX,"^",8)="Y",$P(DGRPX,"^",9)="Y" S DGRPD=1
"RTN","DGRP6",27,0)
 I DGRPD S I1="" F I=0:0 S I=$O(^DPT(DFN,.37,I)) Q:'I  S I1=1,DGRPX=^(I,0) D DEN
"RTN","DGRP6",28,0)
 S Z=8 D WW^DGRPV W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D
"RTN","DGRP6",29,0)
 . I $P($G(DGRPX),U)="Y",($P($G(DGRPX),U,2)]"") W ?26,"PH Status: "_$S($P($G(DGRPX),U,2)="1":"Pending",$P($G(DGRPX),U,2)="2":"In Process",$P($G(DGRPX),U,2)="3":"Confirmed",1:"")
"RTN","DGRP6",30,0)
 I $P($G(DGRPX),U)="N" D
"RTN","DGRP6",31,0)
 . S DGX=$P(DGRPX,U,3)
"RTN","DGRP6",32,0)
 . S DGX=$S($G(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGX)=2:"NO DOCUMENTATION REC'D",$G(DGX)=3:"ENTERED IN ERROR",$G(DGX)=4:"UNSUPPORTED PURPLE HEART",$G(DGX)=5:"VAMC",$G(DGX)=6:"UNDELIVERABLE MAIL",1:"")
"RTN","DGRP6",33,0)
 . I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"")
"RTN","DGRP6",34,0)
 ;DG*5.3*841
"RTN","DGRP6",35,0)
 I $P(DGRP(.54),"^")="Y" W !,"<9> Medal of Honor: YES"
"RTN","DGRP6",36,0)
 ;DG*5.3*842
"RTN","DGRP6",37,0)
 I ($P(DGRP(.385),U,8)["Y")!($P(DGRP(.385),U,8)["N") D EN^DDIOL("<10> Class II Dental Indicator: ","","!?0") S DGRPX=DGRP(.385),X=8,Z1=6 D YN I $P(DGRP(.385),U,8)["Y" D EN^DDIOL("Dental Appl Due Before Date: ","","?0") S X=9 D DAT
"RTN","DGRP6",38,0)
Q K DGRPD,DGRPSV
"RTN","DGRP6",39,0)
 G ^DGRPP
"RTN","DGRP6",40,0)
YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNK",1:"") D WW1^DGRPV Q
"RTN","DGRP6",41,0)
DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z=""
"RTN","DGRP6",42,0)
 E  S Z=$$FMTE^XLFDT(Z,"5DZ")
"RTN","DGRP6",43,0)
 D WW1^DGRPV Q
"RTN","DGRP6",44,0)
DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q
"RTN","DGRP6",45,0)
S ;Write Military Service Episodes (DG*5.3*797)
"RTN","DGRP6",46,0)
 N DGL
"RTN","DGRP6",47,0)
 Q:$G(GLBL)=""
"RTN","DGRP6",48,0)
 S DGL=0 F  S DGL=$O(@GLBL@(DGL)) Q:'DGL!(DGL>3)  D
"RTN","DGRP6",49,0)
 .I $G(@GLBL@(DGL,0))]"" W !,@GLBL@(DGL,0)
"RTN","DGRP6",50,0)
 I DGL>3 W !,"    <more episodes>" Q
"RTN","DGRP6",51,0)
 Q
"RTN","DGRP6",52,0)
MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q
"RTN","DGRP6",53,0)
 ;
"RTN","DGRP6",54,0)
SETLNEX(Z,SEQ,LIN,LENGTH) ;
"RTN","DGRP6",55,0)
 I 'LIN S LIN=1,LIN(1)=""
"RTN","DGRP6",56,0)
 S Z=$E("("_SEQ_") "_Z,1,75)
"RTN","DGRP6",57,0)
 I LENGTH+$L(Z)>$S(LIN<2:49,1:70) S LIN=LIN+1,LIN(LIN)="",LENGTH=0
"RTN","DGRP6",58,0)
 S LIN(LIN)=LIN(LIN)_$S(LENGTH:"    ",1:"")_Z,LENGTH=$L(LIN(LIN))
"RTN","DGRP6",59,0)
 Q
"RTN","DGRP6",60,0)
 ;
"RTN","DGRP7")
0^1^B19041748
"RTN","DGRP7",1,0)
DGRP7 ;ALB/MRL,CKN,ERC - REGISTRATION SCREEN 7/ELIGIBILITY INFORMATION ; 7/25/06 12:06pm
"RTN","DGRP7",2,0)
 ;;5.3;Registration;**528,653,688,842**;Aug 13, 1993;Build 33
"RTN","DGRP7",3,0)
 N DGCASH,DGMBCK
"RTN","DGRP7",4,0)
 S DGRPS=7 D H^DGRPU F I=0,.29,.3,.31,.32,.321,.36,.362,.385,"TYPE","VET" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP7",5,0)
 S (DGRPW,Z)=1 D WW^DGRPV W "       Patient Type: " S DGRPX=DGRP("TYPE"),Z=$S($D(^DG(391,+DGRPX,0)):$P(^(0),"^",1),1:DGRPU),Z1=34 D WW1^DGRPV W "Veteran: " S DGRPX=DGRP("VET"),(X,Z1)=1 D YN
"RTN","DGRP7",6,0)
 W !?9,"Svc Connected: " S DGRPX=DGRP(.3),X=1,Z1=31,DGNA=$S($P(DGRP("VET"),"^",1)="Y":0,1:1) D YN2 W "SC Percent: " W:$E(Z)'="Y" "N/A" I $E(Z)="Y" D
"RTN","DGRP7",7,0)
 .S X=$P(DGRPX,"^",2) W $S(X="":"UNANSWERED",1:+X_"%")
"RTN","DGRP7",8,0)
 .S X=$P(DGRP(.3),"^",1),DGNA=$S(X'="Y":1,1:0)
"RTN","DGRP7",9,0)
 .W !?9,"SC Award Date: ",$$DATENP^DG1010P0(DGRPX,12) W ?53,"Unemployable: " S X=5,Z1=0 D YN2
"RTN","DGRP7",10,0)
 .W !?19,"P&T: " S X=4,Z1=23 D YN2 I $P(DGRP(.3),U,4)["Y" W "P&T Effective Date: " W:$P(DGRP(.3),U,13)']"" "UNANSWERED" I $P(DGRP(.3),U,13)]"" S Y=$P(DGRP(.3),U,13) D DD^%DT W $G(Y)
"RTN","DGRP7",11,0)
 W !?9,"Rated Incomp.: " S X=$$YN2^DG1010P0(DGRP(.29),12) W X D:X["Y"
"RTN","DGRP7",12,0)
 .W "   Date (CIVIL): ",$$DATENP^DG1010P0(DGRP(.29),2)
"RTN","DGRP7",13,0)
 .W "    Date (VA): ",$$DATENP^DG1010P0(DGRP(.29),1)
"RTN","DGRP7",14,0)
 S DGRPX=DGRP(.31) W !?10,"Claim Number: ",$S($P(DGRPX,"^",3)]"":$P(DGRPX,"^",3),1:DGRPU),!?11,"Folder Loc.: ",$$POINT^DG1010P0(DGRP(.31),4,4)
"RTN","DGRP7",15,0)
 S Z=2 D WW^DGRPV ;monetary benefits section
"RTN","DGRP7",16,0)
 W "   Aid & Attendance: " S Z=$$YN2^DG1010P0(DGRP(.362),12) D MBCK S Z1=31 D WW1^DGRPV
"RTN","DGRP7",17,0)
 W "Housebound: ",$$YN2^DG1010P0(DGRP(.362),13) D MBCK
"RTN","DGRP7",18,0)
 W !?12,"VA Pension: " S Z=$$YN2^DG1010P0(DGRP(.362),14) D MBCK S Z1=25 D WW1^DGRPV
"RTN","DGRP7",19,0)
 I $P(DGRP(.362),"^",14)]"" D  ;DG*5.3*842
"RTN","DGRP7",20,0)
 .I DGRPV=1 D DISPPEN^DGRP7CP Q
"RTN","DGRP7",21,0)
 .I ($P(DGRP(.362),"^",14)="N")&($P(DGRP(.385),"^",3)]"") W "Pension A/T Date: "_$$DATENP^DG1010P0(DGRP(.385),3) Q
"RTN","DGRP7",22,0)
 .I ($P(DGRP(.362),"^",14)="Y")&($P(DGRP(.385),"^",1)]"") W "Pension A/T Date: "_$$DATENP^DG1010P0(DGRP(.385),1) Q
"RTN","DGRP7",23,0)
 W !?9,"VA Disability: ",$$YN2^DG1010P0(DGRP(.3),11) D MBCK
"RTN","DGRP7",24,0)
 W !?4,"Total Check Amount: " S X=$$DISP^DG1010P0(DGRP(.362),20,'DGMBCK) W $S(X:"$"_X,1:X)
"RTN","DGRP7",25,0)
 W !?10,"GI Insurance: " S Z=$$YN2^DG1010P0(DGRP(.362),17) S Z1=35 D WW1^DGRPV
"RTN","DGRP7",26,0)
 W "Amount: " S X=$$DISP^DG1010P0(DGRP(.362),6) W $S(X:"$"_X,1:X)
"RTN","DGRP7",27,0)
 S Z=3 D WW^DGRPV S DGRPE=+DGRP(.36),Z=$S($D(^DIC(8,+DGRPE,0)):$P(^(0),"^",1),1:DGRPU)
"RTN","DGRP7",28,0)
 W "  Primary Elig Code: ",Z D AAC1^DGLOCK2 I DGAAC(1)]"" W !?8,"Agency/Country: ",$S($D(^DIC(35,+$P(DGRP(.3),"^",9),0)):$P(^(0),"^",1),1:DGRPU)
"RTN","DGRP7",29,0)
 W !?4,"Other Elig Code(s): " S I1="" F I=0:0 S I=$O(^DPT("AEL",DFN,I)) Q:'I  I $D(^DIC(8,+I,0)),I'=DGRPE S I1=I1+1 W:I1>1 !?24 W $P(^(0),"^",1)
"RTN","DGRP7",30,0)
 W:'I1 "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
"RTN","DGRP7",31,0)
 S DGRPX=+$P(DGRP(.32),"^",3) W !?5,"Period of Service: ",$S($D(^DIC(21,+DGRPX,0)):$P(^(0),"^",1),1:DGRPU)
"RTN","DGRP7",32,0)
 D ^DGYZODS G:'DGODS CONT S DGRPX=$S($D(^DPT(DFN,"ODS")):^("ODS"),1:"") W !?6,"Recalled to Duty: ",$S($P(DGRPX,"^",2)=1:"FROM NATIONAL GUARDS",$P(DGRPX,"^",2)=2:"FROM RESERVES",$P(DGRPX,"^",2)=0:"NO",1:DGRPU)
"RTN","DGRP7",33,0)
 W !?18,"Rank: ",$S($D(^DIC(25002.1,+$P(DGRPX,"^",3),0)):$P(^(0),"^",1),1:DGRPU)
"RTN","DGRP7",34,0)
CONT ;
"RTN","DGRP7",35,0)
 ;display Combat Vet Eligibility, if present
"RTN","DGRP7",36,0)
 N DGCV,SHAD
"RTN","DGRP7",37,0)
 S SHAD=$P(DGRP(.321),"^",15)  ;SHAD Indicator
"RTN","DGRP7",38,0)
 S DGCV=$$CVEDT^DGCV(DFN) I +$G(DGCV)=1 D
"RTN","DGRP7",39,0)
 . W !,"<3.1> Combat Vet Elig.: "
"RTN","DGRP7",40,0)
 . W $S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)=0:"EXPIRED",1:"")
"RTN","DGRP7",41,0)
 . I $P($G(DGCV),U,2)]"" D
"RTN","DGRP7",42,0)
 . . S Y=$P(DGCV,U,2) D DD^%DT
"RTN","DGRP7",43,0)
 . . W " End Date: "_Y
"RTN","DGRP7",44,0)
 . I SHAD=1 W ?56,"<3.2>Proj 112/SHAD: YES"  ;Only display if YES
"RTN","DGRP7",45,0)
 ;
"RTN","DGRP7",46,0)
 I (+$G(DGCV)'=1)&(SHAD=1) W !,?56,"<3.2>Proj 112/SHAD: YES"
"RTN","DGRP7",47,0)
 ;
"RTN","DGRP7",48,0)
 ;print sc disabilities (per patient)
"RTN","DGRP7",49,0)
 W ! S Z=4 D WW^DGRPV W " Service Connected Conditions as stated by applicant" S X="",$P(X,"-",52)="" W !?4,X
"RTN","DGRP7",50,0)
 W !?4 S I3=0 F I=0:0 S I=$O(^DPT(DFN,.373,I)) Q:'I  S I1=$P(^(I,0),"^",1)_" ("_+$P(^(0),"^",2)_"%), ",I3=I W:(79-$X)<$L(I1) !?4 W I1
"RTN","DGRP7",51,0)
 W:'I3 ?4,"NONE STATED"
"RTN","DGRP7",52,0)
Q K DGAAC,DGNA,DGODS,DGRP,DGRPE,DGRPX,I,I1,I2,I3,X,X1,Z,Z1
"RTN","DGRP7",53,0)
 G ^DGRPP
"RTN","DGRP7",54,0)
YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNKNOWN",1:"UNANSWERED") D WW1^DGRPV
"RTN","DGRP7",55,0)
 Q
"RTN","DGRP7",56,0)
YN2 S Z=$S(DGNA:"N/A",$P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNKNOWN",1:"UNANSWERED") D WW1^DGRPV
"RTN","DGRP7",57,0)
 Q
"RTN","DGRP7",58,0)
MBCK ;flag for any MB Y/N fields = yes
"RTN","DGRP7",59,0)
 S DGMBCK=$S($G(DGMBCK):1,(X="Y"):1,1:0)
"RTN","DGRP7",60,0)
 Q
"RTN","DGRP7CP")
0^2^B20220559
"RTN","DGRP7CP",1,0)
DGRP7CP ;ALB/BDB - REGISTRATION SCREEN 7 EXPANSION FIELDS FOR VBA PENSION;04/21/2011
"RTN","DGRP7CP",2,0)
 ;;5.3;Registration;**842**;Aug 13, 1993;Build 33
"RTN","DGRP7CP",3,0)
 ;
"RTN","DGRP7CP",4,0)
EN(DFN,QUIT) ; Display/edit Pension Award and Termination
"RTN","DGRP7CP",5,0)
 ; Returns QUIT=1 if ^ entered
"RTN","DGRP7CP",6,0)
 ;
"RTN","DGRP7CP",7,0)
EN1 D CLEAR^VALM1
"RTN","DGRP7CP",8,0)
 N DGRP,X,Z,ZP,I,DGMBCK
"RTN","DGRP7CP",9,0)
 F I=0,.29,.3,.31,.32,.321,.36,.362,.385,"TYPE","VET" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP7CP",10,0)
 D EN^DDIOL("                 COMPENSATION AND PENSION, SCREEN <7> EXPANSION","","!")
"RTN","DGRP7CP",11,0)
 D EN^DDIOL($$SSNNM^DGRPU(DFN),"","!")
"RTN","DGRP7CP",12,0)
 S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) D EN^DDIOL(X,"","?X1")
"RTN","DGRP7CP",13,0)
 S X="",$P(X,"=",80)="" D EN^DDIOL(X,"","!")
"RTN","DGRP7CP",14,0)
 D EN^DDIOL("Aid & Attendance: ","","!!?17")
"RTN","DGRP7CP",15,0)
 S Z=$$YN2^DG1010P0(DGRP(.362),12) D MBCK^DGRP7 D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",16,0)
 D EN^DDIOL("Housebound: ","","!?23")
"RTN","DGRP7CP",17,0)
 S Z=$$YN2^DG1010P0(DGRP(.362),13) D MBCK^DGRP7 D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",18,0)
 D EN^DDIOL("VA Pension: ","","!?23")
"RTN","DGRP7CP",19,0)
 I $P(DGRP(.362),"^",14)']"" D EN^DDIOL("UNANSWERED","","?0")
"RTN","DGRP7CP",20,0)
 I $P(DGRP(.362),"^",14)]"" S ZP=$$YN2^DG1010P0(DGRP(.362),14) D MBCK^DGRP7 D EN^DDIOL(ZP,"","?0") D
"RTN","DGRP7CP",21,0)
 . I $P(DGRP(.385),"^",1)]"" D EN^DDIOL("Pension Award Effective Date: ","","!?5") S Z=$$DATENP^DG1010P0(DGRP(.385),1) D EN^DDIOL(Z,"","?0") D
"RTN","DGRP7CP",22,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3852,"I") I Z]"" D EN^DDIOL("Pension Award Reason: ","","!?13") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",23,0)
 . I $E(ZP,1)="N",$P(DGRP(.385),"^",3)]"" D EN^DDIOL("Pension Terminated Date: ","","!?10") S Z=$$DATENP^DG1010P0(DGRP(.385),3) D EN^DDIOL(Z,"","?0") D
"RTN","DGRP7CP",24,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3854,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 1: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",25,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3855,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 2: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",26,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3856,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 3: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",27,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3857,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 4: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",28,0)
 D EN^DDIOL("VA Disability: ","","!?20") S Z=$$YN2^DG1010P0(DGRP(.3),11) D MBCK^DGRP7 D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",29,0)
 D EN^DDIOL("Total Check Amount: ","","!?15") S Z=$$DISP^DG1010P0(DGRP(.362),20,'DGMBCK) D EN^DDIOL($S(Z:"$"_Z,1:Z),"","?0")
"RTN","DGRP7CP",30,0)
 D EN^DDIOL("GI Insurance: ","","!?21") D EN^DDIOL($$YN2^DG1010P0(DGRP(.362),17),"","?0")
"RTN","DGRP7CP",31,0)
 D EN^DDIOL("Amount: ","","!?27") S Z=$$DISP^DG1010P0(DGRP(.362),6) D EN^DDIOL($S(Z:"$"_Z,1:Z),"","?0")
"RTN","DGRP7CP",32,0)
 D EN^DDIOL(" ","","!!")
"RTN","DGRP7CP",33,0)
 Q
"RTN","DGRP7CP",34,0)
 ;
"RTN","DGRP7CP",35,0)
DTCHK ;check to see that the pension award date is not greater than today or less that DOB+16 years
"RTN","DGRP7CP",36,0)
 I $G(X)>DT D EN^DDIOL("The Pension Award Date must not be greater than today.","","!!!") K X Q
"RTN","DGRP7CP",37,0)
 I $G(X)<($P(^DPT(DFN,0),U,3)+160000) D EN^DDIOL("The Pension Award Date must not be before the patient's 16th birthday.","","!!!") K X
"RTN","DGRP7CP",38,0)
 Q
"RTN","DGRP7CP",39,0)
 ;
"RTN","DGRP7CP",40,0)
DISPPEN ;
"RTN","DGRP7CP",41,0)
 I $P(DGRP(.362),"^",14)]"" S ZP=$$YN2^DG1010P0(DGRP(.362),14) D
"RTN","DGRP7CP",42,0)
 . I $P(DGRP(.385),"^",1)]"" D EN^DDIOL("Pension Award Effective Date: ","","!?5") S Z=$$DATENP^DG1010P0(DGRP(.385),1) D EN^DDIOL(Z,"","?0") D
"RTN","DGRP7CP",43,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3852,"I") I Z]"" D EN^DDIOL("Pension Award Reason: ","","!?13") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",44,0)
 . I $E(ZP,1)="N",$P(DGRP(.385),"^",3)]"" D EN^DDIOL("Pension Terminated Date: ","","!?10") S Z=$$DATENP^DG1010P0(DGRP(.385),3) D EN^DDIOL(Z,"","?0") D
"RTN","DGRP7CP",45,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3854,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 1: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",46,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3855,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 2: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",47,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3856,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 3: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",48,0)
 .. S Z=$$GET1^DIQ(2,DFN,.3857,"I") I Z]"" D EN^DDIOL("Pension Terminated Reason 4: ","","!?6") S Z=$$GET1^DIQ(27.18,Z,.01,"E") D EN^DDIOL(Z,"","?0")
"RTN","DGRP7CP",49,0)
 ;
"RTN","DGRPE")
0^4^B53481298
"RTN","DGRPE",1,0)
DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ - REGISTRATIONS EDITS ; 6/24/09 3:03pm
"RTN","DGRPE",2,0)
 ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,688,797,842**;Aug 13, 1993;Build 33
"RTN","DGRPE",3,0)
 ;
"RTN","DGRPE",4,0)
 ;DGDR contains a string of edits; edit=screen*10+item #
"RTN","DGRPE",5,0)
 ;
"RTN","DGRPE",6,0)
 ;line tag screen*10+item*1000 = continuation line
"RTN","DGRPE",7,0)
 ;
"RTN","DGRPE",8,0)
 I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
"RTN","DGRPE",9,0)
 I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
"RTN","DGRPE",10,0)
 I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
"RTN","DGRPE",11,0)
 I DGRPS=5,DGDR["501," D
"RTN","DGRPE",12,0)
 .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
"RTN","DGRPE",13,0)
 .D REG^IBCNBME(DFN)
"RTN","DGRPE",14,0)
 .Q
"RTN","DGRPE",15,0)
 N QUIT S QUIT=0
"RTN","DGRPE",16,0)
 I DGRPS=6,$S(DGDR["601,"!(DGDR["602,")!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
"RTN","DGRPE",17,0)
 .;Use new ListMan screen for Military Service Episodes (DG*5.3*797)
"RTN","DGRPE",18,0)
 . I DGDR["601," D EN^DGRP61(DFN)   ; MSEs
"RTN","DGRPE",19,0)
 . ; D SETDR("601,",.DR)
"RTN","DGRPE",20,0)
 . ; S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",21,0)
 . ; D ^DIE I $D(Y) S QUIT=1
"RTN","DGRPE",22,0)
 . ; S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
"RTN","DGRPE",23,0)
 . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
"RTN","DGRPE",24,0)
 . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
"RTN","DGRPE",25,0)
 I DGRPS=7,(DGDR["702,") D EN^DGRP7CP(DFN,.QUIT) I QUIT D Q Q  ;DG*5.3*842 screen 7 cp subscreen
"RTN","DGRPE",26,0)
 ;-- Tricare screen #15
"RTN","DGRPE",27,0)
 I DGRPS=15 D EDIT^DGRP15,Q Q
"RTN","DGRPE",28,0)
 ;
"RTN","DGRPE",29,0)
 N DGPH,DGPHFLG
"RTN","DGRPE",30,0)
 K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",31,0)
 G ^DGRPE1:DGRPS>6
"RTN","DGRPE",32,0)
 I DGRPS=4 D ^DGRPE4
"RTN","DGRPE",33,0)
 D SETDR(DGDR,.DR)
"RTN","DGRPE",34,0)
 S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",35,0)
 D ^DIE
"RTN","DGRPE",36,0)
 ;check for Combat Vet status
"RTN","DGRPE",37,0)
 I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
"RTN","DGRPE",38,0)
 . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
"RTN","DGRPE",39,0)
 . S DIR(0)="EA" D ^DIR K DIR
"RTN","DGRPE",40,0)
 I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
"RTN","DGRPE",41,0)
Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
"RTN","DGRPE",42,0)
 Q
"RTN","DGRPE",43,0)
 ;
"RTN","DGRPE",44,0)
SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected
"RTN","DGRPE",45,0)
 N DGCT,DGDRS,J1,J2
"RTN","DGRPE",46,0)
 K DR S DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",47,0)
 F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
"RTN","DGRPE",48,0)
 . S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",49,0)
 . N J2
"RTN","DGRPE",50,0)
 . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",51,0)
 Q
"RTN","DGRPE",52,0)
 ;
"RTN","DGRPE",53,0)
S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
"RTN","DGRPE",54,0)
 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
"RTN","DGRPE",55,0)
 Q
"RTN","DGRPE",56,0)
 ;
"RTN","DGRPE",57,0)
SETFLDS(DGDR) ; Set up fields to edit
"RTN","DGRPE",58,0)
 Q
"RTN","DGRPE",59,0)
 ;
"RTN","DGRPE",60,0)
101 ;;
"RTN","DGRPE",61,0)
102 ;;1;
"RTN","DGRPE",62,0)
103 ;;.091;
"RTN","DGRPE",63,0)
104 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
"RTN","DGRPE",64,0)
105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;
"RTN","DGRPE",65,0)
105000 ;;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET Y=.12105;@15;K DIE("NO^");
"RTN","DGRPE",66,0)
109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
"RTN","DGRPE",67,0)
111 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
"RTN","DGRPE",68,0)
111000 ;;K DR(2,2.141);N RET S RET=1 D EN^DGREGTED(DFN,"CONF",.RET) S:'RET Y=.14105;@111;K DIE("NO^");
"RTN","DGRPE",69,0)
112 ;;.134;.135;.133
"RTN","DGRPE",70,0)
201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;
"RTN","DGRPE",71,0)
202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
"RTN","DGRPE",72,0)
203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
"RTN","DGRPE",73,0)
205 ;;.181;
"RTN","DGRPE",74,0)
301 ;;.211;S:X']"" Y="@31";.212;D DR301^DGRPE S:DG4=1 Y=.213;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;K DG4;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31;
"RTN","DGRPE",75,0)
302 ;;.2191;S:X']"" Y="@32";.2192;D DR301^DGRPE S:DG4=1 Y=.2193;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
"RTN","DGRPE",76,0)
302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
"RTN","DGRPE",77,0)
303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34;
"RTN","DGRPE",78,0)
303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
"RTN","DGRPE",79,0)
303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35;
"RTN","DGRPE",80,0)
303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2;
"RTN","DGRPE",81,0)
304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;        
"RTN","DGRPE",82,0)
305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371;
"RTN","DGRPE",83,0)
305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
"RTN","DGRPE",84,0)
305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
"RTN","DGRPE",85,0)
305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
"RTN","DGRPE",86,0)
401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
"RTN","DGRPE",87,0)
402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
"RTN","DGRPE",88,0)
501 ;;
"RTN","DGRPE",89,0)
502 ;;.381;.382///NOW;
"RTN","DGRPE",90,0)
503 ;;.383;
"RTN","DGRPE",91,0)
601 ;;Q;
"RTN","DGRPE",92,0)
602 ;;Q;
"RTN","DGRPE",93,0)
603 ;;Q;
"RTN","DGRPE",94,0)
604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
"RTN","DGRPE",95,0)
605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
"RTN","DGRPE",96,0)
606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
"RTN","DGRPE",97,0)
607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
"RTN","DGRPE",98,0)
608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
"RTN","DGRPE",99,0)
AD N DGZ4,DGPC
"RTN","DGRPE",100,0)
 S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10)
"RTN","DGRPE",101,0)
 I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4
"RTN","DGRPE",102,0)
 K DGADD,DGPHONE Q
"RTN","DGRPE",103,0)
DR109 ;Drop through (use same logic as DR203)
"RTN","DGRPE",104,0)
DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;"
"RTN","DGRPE",105,0)
 S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;"
"RTN","DGRPE",106,0)
 Q
"RTN","DGRPE",107,0)
DR111 ;Set DR string for Confidential Address categories
"RTN","DGRPE",108,0)
 S DR(2,2.141)=".01;1//YES;"
"RTN","DGRPE",109,0)
 Q
"RTN","DGRPE",110,0)
DR301 ;set up variables for foreign address
"RTN","DGRPE",111,0)
 N DG3,DG33
"RTN","DGRPE",112,0)
 S DG4=0
"RTN","DGRPE",113,0)
 S DG3=$P($G(^DPT(DFN,.11)),U,10)
"RTN","DGRPE",114,0)
 S DG33=$O(^HL(779.004,"B","USA",""))
"RTN","DGRPE",115,0)
 I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1
"RTN","DGRPE",116,0)
 Q
"RTN","DGRPE",117,0)
PRF ; Write Proof needed for FV
"RTN","DGRPE",118,0)
 W !?4,$C(7),"Proof is required for Filipino vet."
"RTN","DGRPE",119,0)
 Q
"RTN","DGRPE",120,0)
 ;
"RTN","DGRPE",121,0)
SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA
"RTN","DGRPE",122,0)
 ; array with the BOS and component data for the SEQ military service
"RTN","DGRPE",123,0)
 ; episode (1-3)
"RTN","DGRPE",124,0)
 N I,Q,Z
"RTN","DGRPE",125,0)
 K DIPA(32,SEQ)
"RTN","DGRPE",126,0)
 S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
"RTN","DGRPE",127,0)
 S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U)
"RTN","DGRPE",128,0)
 Q
"RTN","DGRPE",129,0)
 ;
"RTN","DGRPE",130,0)
WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will
"RTN","DGRPE",131,0)
 ; be deleted
"RTN","DGRPE",132,0)
 ; Returns Y to skip component if the component should not be asked
"RTN","DGRPE",133,0)
 ;   for this branch of service
"RTN","DGRPE",134,0)
 N Z
"RTN","DGRPE",135,0)
 I '$$CMP(X) S Y="@601"_SEQ
"RTN","DGRPE",136,0)
 S Z=$G(DIPA(32,SEQ))
"RTN","DGRPE",137,0)
 Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
"RTN","DGRPE",138,0)
 ;
"RTN","DGRPE",139,0)
 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
"RTN","DGRPE",140,0)
 Q
"RTN","DGRPE",141,0)
 ;
"RTN","DGRPE",142,0)
CMP(X) ; Function to determine if service component is valid for
"RTN","DGRPE",143,0)
 ; branch of service ien in X   0 = invalid  1 = valid  
"RTN","DGRPE",144,0)
 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
"RTN","DGRPE",145,0)
 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
"RTN","DGRPE",146,0)
 ;
"RTN","DGRPH")
0^13^B25194652
"RTN","DGRPH",1,0)
DGRPH ;ALB/MRL,TMK - REGISTRATION HELP ROUTINE ; 12/14/11 4:29pm
"RTN","DGRPH",2,0)
 ;;5.3;Registration;**114,343,397,415,489,545,638,624,689,842**;Aug 13, 1993;Build 33
"RTN","DGRPH",3,0)
 S DGRPH="" D H^DGRPU K DGRPH W !,"Enter '^' to stop the display ",$S(DGRPV:"",1:"and edit "),"of data, '^N' to jump to screen #N (see",!,"listing below), <RET> to continue on to the next available screen" I DGRPV W "." G M
"RTN","DGRPH",4,0)
 W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters.  Those groups enclosed in brackets ""[]"" are editable while those",!,"enclosed in arrows ""<>"" are not."
"RTN","DGRPH",5,0)
 W "  Enter 'ALL' to edit all editable data",!,"elements on the screen."
"RTN","DGRPH",6,0)
M I DGRPS=9,DGRPSEL="V" W !!,"You may precede your selection with 'V' to denote veteran."
"RTN","DGRPH",7,0)
 I DGRPS=9,DGRPSEL]"V" W !!,"To edit a specific column, enter 'V'",$S($D(DGREL("S")):", 'S'",1:""),$S($D(DGREL("D")):", 'D'",1:"")," in front of the selected items."
"RTN","DGRPH",8,0)
 S Z="DATA GROUPS ON SCREEN "_DGRPS,DGRPCM=1 W ! D WW^DGRPV S DGRPCM=0 D:DGRPS=1.1 A1 D:DGRPS'=1.1 @DGRPS D:$S(DGRPS<11:1,DGRPS=14:1,1:0) W D S W ! F I=$Y:1:20 W !
"RTN","DGRPH",9,0)
 ;S Z="Press RETURN key",DGRPCM=1 D WW^DGRPV S DGRPCM=0 W " to EXIT Screen ",DGRPS," HELP " R X:DTIME S X="" Q
"RTN","DGRPH",10,0)
 S DGRPW=0 W "Press " S Z="<RETURN>",DGRPCM=1 D WW^DGRPV W " KEY " S Z="TO EXIT" D WW^DGRPV W " SCREEN ",DGRPS," " S Z="HELP" D WW^DGRPV W " " R X:DTIME S (DGRPCM,DGRPW)=0 Q
"RTN","DGRPH",11,0)
1 S X="Name, SSN, DOB, Sex^Alias Name & SSN (if applicable)^Remarks concerning this patient^Home Address, Phone & Work Phone^Temporary Address, Dates, Phone" Q
"RTN","DGRPH",12,0)
A1 S X="Conf. Address,Dates and Types^E-Mail, Cell Phone & Pager #s" Q
"RTN","DGRPH",13,0)
2 S X="POB, Parents, etc.^Dates/Locations of Previous Care^Race and Ethnicity^Date of Death Information" Q
"RTN","DGRPH",14,0)
3 S X="Primary Next-of-Kin^Secondary Next-of-Kin^Primary Emergency Contact^Secondary Emergency Contact^Designee to receive personal effects" Q
"RTN","DGRPH",15,0)
4 S X="Applicant Employer, Address^Spouses Employer, Address" Q
"RTN","DGRPH",16,0)
5 S X="Unexpired Insurance Policies^Eligibile for Medicaid" Q
"RTN","DGRPH",17,0)
6 S X="Service History^Conflict Locations^Exposure Factors^Prisoner of War^Combat^Military Retirement/Disability^Dental History^Purple Heart Recipient^Medal of Honor^Class II Dental Indicator" Q
"RTN","DGRPH",18,0)
7 S X="Patient Type, SC Data, Claim Info^VA Monetary Benefits^POS, Eligibility Code(s)^SC Conditions relayed by applicant" Q
"RTN","DGRPH",19,0)
8 S X="Spouse's Demographic Info^Dependents' Demographic Info" Q
"RTN","DGRPH",20,0)
9 S X="Social Security^U.S. Civil Service^U.S. Railroad Retirement^Military Retirement^Unemployment^Other Retirement^Total Employment Income^Interest,Dividend,Annuity^Workers Comp or Black Lung^Other Income" Q
"RTN","DGRPH",21,0)
10 S X="Ineligible Patient Information^Missing Patient Information" Q
"RTN","DGRPH",22,0)
11 S X="Eligibility Verification^Monetary Benefits Verification^Service Record Verification^Rated Disabilities (VA)" Q
"RTN","DGRPH",23,0)
12 W !,"Four most recent admission episodes on file for this applicant are displayed",!,"in inverse order." Q
"RTN","DGRPH",24,0)
13 W !,"Four most recent applications for care (registrations) are displayed in",!,"inverse order." Q
"RTN","DGRPH",25,0)
14 S X="Clinics in which actively enrolled^Pending (future) appointments" Q
"RTN","DGRPH",26,0)
15 W !,"Sponsor information is displayed for patients." Q
"RTN","DGRPH",27,0)
S W ! S Z="AVAILABLE SCREENS",DGRPCM=1 D WW^DGRPV S DGRPCM=0
"RTN","DGRPH",28,0)
 S X="Demographic^Confidential Address^Patient^Contact^Employment^Insurance^Service Record^Eligibility^Family Demographic^Income Screening^Missing/Ineligible^Eligibility Verification^"
"RTN","DGRPH",29,0)
 S X=X_"Admission Info^Application Info^Appointment Info^Sponsor Demographics"
"RTN","DGRPH",30,0)
 ;S C=0 F I=1:1 S J=$P(X,"^",I) Q:J=""  I '$E(DGRPVV,I) S C=C+1,Z="^"_I,DGRPW=(C#2) D WW^DGRPV S Z=$S(I?1N:"  ",1:" ")_J_" Data",Z1=$S((C#2)&(I?1N):36,(C#2):35,1:1) D WW1^DGRPV:(C#2) I '(C#2) W Z
"RTN","DGRPH",31,0)
 N DGJ
"RTN","DGRPH",32,0)
 S DGJ=""
"RTN","DGRPH",33,0)
 S C=0 F I=1:1 S DGJ=$O(DGRPVV(DGJ)) Q:DGJ=""  I '$E(DGRPVV,DGJ) D
"RTN","DGRPH",34,0)
 .S C=C+1,Z="^"_DGJ,DGRPW=(C#2)
"RTN","DGRPH",35,0)
 .D WW^DGRPV
"RTN","DGRPH",36,0)
 .S Z1=$S((C#2)&(DGJ?1N):36,(C#2):35,1:1)
"RTN","DGRPH",37,0)
 .S Z=$S(DGJ?1N:"  ",1:" ")_$P(X,U,I)_" Data"
"RTN","DGRPH",38,0)
 .D WW1^DGRPV:(C#2)
"RTN","DGRPH",39,0)
 .I '(C#2) W Z
"RTN","DGRPH",40,0)
 Q
"RTN","DGRPH",41,0)
W F I=1:1 S J=$P(X,"^",I) Q:J=""  S Z=I,DGRPW=(I#2) D WW^DGRPV S Z=$S(I<10:"  ",1:" ")_J,Z1=$S((I#2)&(I>10):36,(I#2):37,1:1) D WW1^DGRPV
"RTN","DGRPH",42,0)
 W:'((I-1)#2) ! Q
"RTN","DGRPV")
0^14^B18383656
"RTN","DGRPV",1,0)
DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD,TDM - REGISTRATION DEFINE VARIABLES ON ENTRY ; 12/15/11 1:47pm
"RTN","DGRPV",2,0)
 ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797,842**;Aug 13, 1993;Build 33
"RTN","DGRPV",3,0)
 ;
"RTN","DGRPV",4,0)
 ;
"RTN","DGRPV",5,0)
 ;set up variables for registration screen processing
"RTN","DGRPV",6,0)
 ;
"RTN","DGRPV",7,0)
 ;DGRPVV   :string of 15 ones and zeros each character corresponding to
"RTN","DGRPV",8,0)
 ;          a particular screen (0 means allow edit, 1 means don't)
"RTN","DGRPV",9,0)
 ;
"RTN","DGRPV",10,0)
 ;DGRPVV(n):where n=screen number.  String of x ones and zeros where
"RTN","DGRPV",11,0)
 ;          x is the number of elements on screen n (0=edit, 1=don't)
"RTN","DGRPV",12,0)
 ;
"RTN","DGRPV",13,0)
 ;DGVI     :Turn on high intensity
"RTN","DGRPV",14,0)
 ;DGVO     :Turn off high intensity
"RTN","DGRPV",15,0)
 ;
"RTN","DGRPV",16,0)
EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS
"RTN","DGRPV",17,0)
 S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity
"RTN","DGRPV",18,0)
 I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X)
"RTN","DGRPV",19,0)
M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
"RTN","DGRPV",20,0)
 S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1)
"RTN","DGRPV",21,0)
MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2
"RTN","DGRPV",22,0)
 ;DG*5.3*797
"RTN","DGRPV",23,0)
 I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN)
"RTN","DGRPV",24,0)
SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",25,0)
 S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",26,0)
 I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10"))
"RTN","DGRPV",27,0)
 ;
"RTN","DGRPV",28,0)
 S DGPH=$P($G(^DPT(DFN,.53)),U)  ;Purple Heart Indicator
"RTN","DGRPV",29,0)
 I $G(DGPRFLG)=1 D
"RTN","DGRPV",30,0)
 . S DGRPVV="000001111111111"
"RTN","DGRPV",31,0)
 E  D
"RTN","DGRPV",32,0)
 . S DGRPVV="000000000000000"
"RTN","DGRPV",33,0)
 S X="5^3^5^2^3^10^4^2^3^2^4^5^5^2^1"
"RTN","DGRPV",34,0)
 F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J))
"RTN","DGRPV",35,0)
 S DGRPVV(1.1)="00"
"RTN","DGRPV",36,0)
 S DGRPVV(2)="00010"
"RTN","DGRPV",37,0)
 I $P($G(^DPT(DFN,.52)),U,9)'="" S $E(DGRPVV(6),4)=1  ;POW status verified, no editing (DG*5.3*688)
"RTN","DGRPV",38,0)
 I $G(DGPH)]"" S $E(DGRPVV(6),8)=1
"RTN","DGRPV",39,0)
 S $E(DGRPVV(6),9,10)="11"
"RTN","DGRPV",40,0)
 ;
"RTN","DGRPV",41,0)
 F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
"RTN","DGRPV",42,0)
 ;
"RTN","DGRPV",43,0)
 ;-- if patient type is TRICARE then turn off screens 2,4
"RTN","DGRPV",44,0)
 ;
"RTN","DGRPV",45,0)
 ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 
"RTN","DGRPV",46,0)
 ;-- commented the line to allow screens 2 & 4 to display for Tricare
"RTN","DGRPV",47,0)
 ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
"RTN","DGRPV",48,0)
 ;
"RTN","DGRPV",49,0)
 F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
"RTN","DGRPV",50,0)
 I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99)
"RTN","DGRPV",51,0)
 K DIRUT,DUOUT,DTOUT
"RTN","DGRPV",52,0)
 ;
"RTN","DGRPV",53,0)
 ;Fields are numbered screen_item and put in that piece position.
"RTN","DGRPV",54,0)
 ;Because FM does not allow more than 100 pieces on a node, it was
"RTN","DGRPV",55,0)
 ;necessary to start a new node E10 for fields on screens 10 or higher.
"RTN","DGRPV",56,0)
 ;In these instances, the piece position will be screen_item-100 so,
"RTN","DGRPV",57,0)
 ;for example, screen 11, item 2 would be field 112, but piece 12.
"RTN","DGRPV",58,0)
 ;Items on screens <10 will be found on node E.
"RTN","DGRPV",59,0)
 ;
"RTN","DGRPV",60,0)
 F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
"RTN","DGRPV",61,0)
 ;
"RTN","DGRPV",62,0)
 I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip
"RTN","DGRPV",63,0)
 F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPV",64,0)
 S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob
"RTN","DGRPV",65,0)
 I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
"RTN","DGRPV",66,0)
 I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
"RTN","DGRPV",67,0)
 ;
"RTN","DGRPV",68,0)
ELVER ;set up variables for eligibility verification
"RTN","DGRPV",69,0)
 ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
"RTN","DGRPV",70,0)
 ;   and 11 if they're turned on).
"RTN","DGRPV",71,0)
 ;
"RTN","DGRPV",72,0)
 S DGRP(.361)=$G(^DPT(DFN,.361))
"RTN","DGRPV",73,0)
 I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10
"RTN","DGRPV",74,0)
 I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=1000
"RTN","DGRPV",75,0)
 S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
"RTN","DGRPV",76,0)
 I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I
"RTN","DGRPV",77,0)
Q K DGRPSC,DGRPSCE
"RTN","DGRPV",78,0)
 Q
"RTN","DGRPV",79,0)
 ;
"RTN","DGRPV",80,0)
WW ;Write number on screens for display and/or edit (Z=number)
"RTN","DGRPV",81,0)
 W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
"RTN","DGRPV",82,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",83,0)
 I 'DGRPCM&($E(Z)'="[") W Z
"RTN","DGRPV",84,0)
 Q
"RTN","DGRPV",85,0)
 ;
"RTN","DGRPV",86,0)
WW1 ;spacing for screen display (Z=item to print)
"RTN","DGRPV",87,0)
 F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
"RTN","DGRPV",88,0)
 W Z K Z2
"RTN","DGRPV",89,0)
 Q
"RTN","DGRPV",90,0)
 ;
"RTN","DGRPV",91,0)
WW2 ; Write number on screen for fields always selectable
"RTN","DGRPV",92,0)
 W:DGRPW ! S Z="["_Z_"]"
"RTN","DGRPV",93,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",94,0)
 Q
"RTN","VAFHLZE2")
0^10^B3792068
"RTN","VAFHLZE2",1,0)
VAFHLZE2 ;ALB/TDM - Create HL7 ZE2 segment ; 5/17/12 11:22am
"RTN","VAFHLZE2",2,0)
 ;;5.3;Registration;**842**;Aug 13, 1993;Build 33
"RTN","VAFHLZE2",3,0)
 ;
"RTN","VAFHLZE2",4,0)
 ;
"RTN","VAFHLZE2",5,0)
 ; This generic extrinsic function is designed to return the
"RTN","VAFHLZE2",6,0)
 ; HL7 ZE2 segment. This segment is a continuation of the ZEL
"RTN","VAFHLZE2",7,0)
 ; segment.
"RTN","VAFHLZE2",8,0)
 ;
"RTN","VAFHLZE2",9,0)
EN(DFN,VAFSTR,VAFHLQ,VAFHLFS) ; --
"RTN","VAFHLZE2",10,0)
 ; Entry point for creating HL7 ZE2 segment.
"RTN","VAFHLZE2",11,0)
 ;
"RTN","VAFHLZE2",12,0)
 ;Variables Required to use this routine:
"RTN","VAFHLZE2",13,0)
 ;    HL - array that contains the necessary HL variables (init^hlsub)
"RTN","VAFHLZE2",14,0)
 ;
"RTN","VAFHLZE2",15,0)
 ;  Input(s):
"RTN","VAFHLZE2",16,0)
 ;        DFN - internal entry number of Patient (#2) file
"RTN","VAFHLZE2",17,0)
 ;     VAFSTR - (optional) string of fields requested, separated by
"RTN","VAFHLZE2",18,0)
 ;              commas.  If not passed, return all data fields.
"RTN","VAFHLZE2",19,0)
 ;     VAFHLQ - (optional) HL7 null variable.
"RTN","VAFHLZE2",20,0)
 ;    VAFHLFS - (optional) HL7 field separator.
"RTN","VAFHLZE2",21,0)
 ;
"RTN","VAFHLZE2",22,0)
 ; Output(s):
"RTN","VAFHLZE2",23,0)
 ;    String containing the desired components of the HL7 ZE2 segment
"RTN","VAFHLZE2",24,0)
 ;
"RTN","VAFHLZE2",25,0)
 N VAFY,VAF385,VAL,VAFHLSC
"RTN","VAFHLZE2",26,0)
 ;
"RTN","VAFHLZE2",27,0)
 ; if VAFHLQ or VAFHLFS not passed, use default HL7 variables
"RTN","VAFHLZE2",28,0)
 S VAFHLFS=$G(VAFHLS) I VAFHLFS="" S VAFHLFS="^"
"RTN","VAFHLZE2",29,0)
 S:($L(VAFHLFS)'=1) VAFHLFS="^"
"RTN","VAFHLZE2",30,0)
 S VAFHLC=$G(VAFHLC) I VAFHLC="" S VAFHLC="~|\&"
"RTN","VAFHLZE2",31,0)
 S:($L(VAFHLC)'=4) VAFHLC="~|\&"
"RTN","VAFHLZE2",32,0)
 S:('$D(VAFHLQ)) VAFHLQ=$C(34,34)
"RTN","VAFHLZE2",33,0)
 S VAFHLSC=$E(VAFHLC,1)
"RTN","VAFHLZE2",34,0)
 ;
"RTN","VAFHLZE2",35,0)
 ; if DFN not passed, exit
"RTN","VAFHLZE2",36,0)
 I '$G(DFN) S VAFY=1 G ENQ
"RTN","VAFHLZE2",37,0)
 ;
"RTN","VAFHLZE2",38,0)
 ; if VAFSTR not passed, return all data fields
"RTN","VAFHLZE2",39,0)
 I $G(VAFSTR)']"" S VAFSTR="1,2"
"RTN","VAFHLZE2",40,0)
 ;
"RTN","VAFHLZE2",41,0)
 ; initialize output string and requested data fields
"RTN","VAFHLZE2",42,0)
 S $P(VAFY,VAFHLFS,2)="",VAFSTR=","_VAFSTR_","
"RTN","VAFHLZE2",43,0)
 ;
"RTN","VAFHLZE2",44,0)
 ; get pension data node of Patient (#2) file
"RTN","VAFHLZE2",45,0)
 S VAF385=$G(^DPT(DFN,.385))
"RTN","VAFHLZE2",46,0)
 ;
"RTN","VAFHLZE2",47,0)
 I VAFSTR[",1," S $P(VAFY,VAFHLFS,1)=$S($P(VAF385,"^",1)]"":$$HLDATE^HLFNC($P(VAF385,"^",1)),1:VAFHLQ)  ; Pension Award Effective Date (#.3851)
"RTN","VAFHLZE2",48,0)
 I VAFSTR[",2," D  ; Pension Award Reason Code (#.3852)
"RTN","VAFHLZE2",49,0)
 .I $P(VAF385,"^",2)']"" S $P(VAFY,VAFHLFS,2)=VAFHLQ Q
"RTN","VAFHLZE2",50,0)
 .S VAL=$P(VAF385,"^",2)_","
"RTN","VAFHLZE2",51,0)
 .S $P(VAFY,VAFHLFS,2)=$$GET1^DIQ(27.18,VAL,1)
"RTN","VAFHLZE2",52,0)
 .S $P(VAFY,VAFHLFS,2)=$P(VAFY,VAFHLFS,2)_VAFHLSC_VAFHLSC_"VistA27.18"
"RTN","VAFHLZE2",53,0)
 ;
"RTN","VAFHLZE2",54,0)
ENQ Q "ZE2"_VAFHLFS_$G(VAFY)
"VER")
8.0^22.0
"^DD",2,2,.36235,0)
RECEIVING A VA PENSION?^SX^Y:YES;N:NO;U:UNKNOWN;^.362;14^S DFN=DA D MV^DGLOCK
"^DD",2,2,.36235,1,0)
^.1
"^DD",2,2,.36235,1,1,0)
^^TRIGGER^2^.3624
"^DD",2,2,.36235,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.36235,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="NO" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4)
"^DD",2,2,.36235,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.362)),DIV=X S $P(^(.362),U,4)=DIV,DIH=2,DIG=.3624 D ^DICR
"^DD",2,2,.36235,1,1,2)
X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.362)),DIV=X S $P(^(.362),U,4)=DIV,DIH=2,DIG=.3624 D ^DICR
"^DD",2,2,.36235,1,1,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(2,.36235,0)),U,3),Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,14)_":",2),$C(59))=""
"^DD",2,2,.36235,1,1,"CREATE CONDITION")
#.36235="NO"
"^DD",2,2,.36235,1,1,"CREATE VALUE")
@
"^DD",2,2,.36235,1,1,"DELETE CONDITION")
#.36235=""
"^DD",2,2,.36235,1,1,"DELETE VALUE")
@
"^DD",2,2,.36235,1,1,"DT")
3110818
"^DD",2,2,.36235,1,1,"FIELD")
AMOUNT OF VA PENSION
"^DD",2,2,.36235,1,2,0)
2^AM^MUMPS
"^DD",2,2,.36235,1,2,1)
S DFN=DA D EN^DGMTCOR K DGMTCOR
"^DD",2,2,.36235,1,2,2)
S DFN=DA D EN^DGMTCOR K DGMTCOR
"^DD",2,2,.36235,1,2,"%D",0)
^^3^3^2930119^^^^
"^DD",2,2,.36235,1,2,"%D",1,0)
This cross reference acts like a trigger.  It 'triggers' the status field
"^DD",2,2,.36235,1,2,"%D",2,0)
in file 408.31 (ANNUAL MEANS TEST) for the co-pay exemption test.  It
"^DD",2,2,.36235,1,2,"%D",3,0)
will update the field to 'NO LONGER APPLICABLE' if appropriate.
"^DD",2,2,.36235,1,2,"DT")
2930119
"^DD",2,2,.36235,1,3,0)
^^TRIGGER^2^.36295
"^DD",2,2,.36235,1,3,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4)
"^DD",2,2,.36235,1,3,1.4)
S DIH=$S($D(^DPT(DIV(0),.362)):^(.362),1:""),DIV=X S $P(^(.362),U,20)=DIV,DIH=2,DIG=.36295 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",2,2,.36235,1,3,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4)
"^DD",2,2,.36235,1,3,2.4)
S DIH=$S($D(^DPT(DIV(0),.362)):^(.362),1:""),DIV=X S $P(^(.362),U,20)=DIV,DIH=2,DIG=.36295 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",2,2,.36235,1,3,"CREATE CONDITION")
S X='$$TOTCHK^DGLOCK2(DA)
"^DD",2,2,.36235,1,3,"CREATE VALUE")
@
"^DD",2,2,.36235,1,3,"DELETE CONDITION")
S X='$$TOTCHK^DGLOCK2(DA)
"^DD",2,2,.36235,1,3,"DELETE VALUE")
@
"^DD",2,2,.36235,1,3,"DT")
2970327
"^DD",2,2,.36235,1,3,"FIELD")
#.36295
"^DD",2,2,.36235,1,4,0)
2^AENR36235^MUMPS
"^DD",2,2,.36235,1,4,1)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.36235,1,4,2)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.36235,1,4,3)
DO NOT DELETE
"^DD",2,2,.36235,1,4,"%D",0)
^^2^2^2970630^^
"^DD",2,2,.36235,1,4,"%D",1,0)
This cross-reference is used to update the patient's current Patient Enrollment 
"^DD",2,2,.36235,1,4,"%D",2,0)
record.
"^DD",2,2,.36235,1,4,"DT")
2970630
"^DD",2,2,.36235,3)
Is this patient receiving a VA pension?
"^DD",2,2,.36235,20,0)
^.3LA^1^1
"^DD",2,2,.36235,20,1,0)
MB
"^DD",2,2,.36235,21,0)
^^6^6^3110525^
"^DD",2,2,.36235,21,1,0)
For this veteran applicant enter 'Y' if s/he is in receipt of a pension
"^DD",2,2,.36235,21,2,0)
from the Dept of Veterans Affairs, 'N' if not, or 'U' if unknown. 
"^DD",2,2,.36235,21,3,0)
Answering "yes" will prompt you to enter a Pension Award Effective Date 
"^DD",2,2,.36235,21,4,0)
and Pension Award Reason. Once monetary benefits have been verified
"^DD",2,2,.36235,21,5,0)
only users holding the designated security key may enter/edit
"^DD",2,2,.36235,21,6,0)
this field.
"^DD",2,2,.36235,"DEL",1,0)
S DFN=DA D MV^DGLOCK I '$D(X)
"^DD",2,2,.36235,"DT")
3110818
"^DD",2,2,.3851,0)
PENSION AWARD EFFECTIVE DATE^DX^^.385;1^S %DT="EPX" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL I $G(X)>0 S DFN=DA D DTCHK^DGRP7CP
"^DD",2,2,.3851,1,0)
^.1
"^DD",2,2,.3851,1,1,0)
2^AENR3851^MUMPS
"^DD",2,2,.3851,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3851,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3851,1,1,3)
DO NOT DELETE
"^DD",2,2,.3851,1,1,"%D",0)
^^15^15^3110516^
"^DD",2,2,.3851,1,1,"%D",1,0)
 This cross-reference is called in response
"^DD",2,2,.3851,1,1,"%D",2,0)
 to enrollment events to notify HEC of
"^DD",2,2,.3851,1,1,"%D",3,0)
 changes that may affect enrollment.  A call
"^DD",2,2,.3851,1,1,"%D",4,0)
 is made to the IVM Patient file to determine
"^DD",2,2,.3851,1,1,"%D",5,0)
 whether transmission is appropriate for this
"^DD",2,2,.3851,1,1,"%D",6,0)
 patient.  Executing this cross-reference
"^DD",2,2,.3851,1,1,"%D",7,0)
 will result in the following file and field
"^DD",2,2,.3851,1,1,"%D",8,0)
 changes:
"^DD",2,2,.3851,1,1,"%D",9,0)
 
"^DD",2,2,.3851,1,1,"%D",10,0)
 IVM PATIENT file (#301.5)
"^DD",2,2,.3851,1,1,"%D",11,0)
 Field: TRANSMISSION STATUS (#.03)
"^DD",2,2,.3851,1,1,"%D",12,0)
 Sets the value of the TRANSMISSION STATUS
"^DD",2,2,.3851,1,1,"%D",13,0)
 field of the IVM PATIENT file for a
"^DD",2,2,.3851,1,1,"%D",14,0)
 particular record to 0, meaning transmission
"^DD",2,2,.3851,1,1,"%D",15,0)
 is requested.
"^DD",2,2,.3851,1,1,"DT")
3110513
"^DD",2,2,.3851,3)
Enter the Original Effective Date that Pension Entitlement was awarded to the Veteran by VBA.
"^DD",2,2,.3851,21,0)
^^5^5^3110608^
"^DD",2,2,.3851,21,1,0)
It is the Effective Date that the patient was awarded VA Pension
"^DD",2,2,.3851,21,2,0)
Entitlement of Original Award by VBA. This field is optional. 
"^DD",2,2,.3851,21,3,0)
But if entered, must be a precise date (Month/Day/Year) 
"^DD",2,2,.3851,21,4,0)
(00/00/0000). This date cannot be a future date. This date
"^DD",2,2,.3851,21,5,0)
also cannot be before the veteran's 16th birthday.
"^DD",2,2,.3851,"DT")
3110517
"^DD",2,2,.3852,0)
PENSION AWARD REASON^*P27.18'X^DG(27.18,^.385;2^S:($G(X)]"")&(X'?1P.P) X=$$UPPER^DGUTL(X) S X=$$LOWER^DGUTL(X) S DIC("S")="I $P($G(^(0)),U)[""Original Award""" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
"^DD",2,2,.3852,1,0)
^.1
"^DD",2,2,.3852,1,1,0)
2^AENR3852^MUMPS
"^DD",2,2,.3852,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3852,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3852,1,1,3)
DO NOT DELETE
"^DD",2,2,.3852,1,1,"%D",0)
^.101^2^2^3110513^^
"^DD",2,2,.3852,1,1,"%D",1,0)
This cross-reference is used to notify HEC of
"^DD",2,2,.3852,1,1,"%D",2,0)
changes that may affect enrollment.
"^DD",2,2,.3852,1,1,"DT")
3110513
"^DD",2,2,.3852,3)
Select the Pension Award Reason.
"^DD",2,2,.3852,12)
Only ORIGINAL AWARD can be entered.
"^DD",2,2,.3852,12.1)
S DIC("S")="I $P($G(^(0)),U)[""Original Award"""
"^DD",2,2,.3852,21,0)
^^5^5^3110917^
"^DD",2,2,.3852,21,1,0)
Enter the Pension Award Reason only if VA Pension (#.36235) field
"^DD",2,2,.3852,21,2,0)
is equal to "Yes". VistA users are only allowed to enter a 
"^DD",2,2,.3852,21,3,0)
Pension Award Reason of "Original Award" (106).  This field is
"^DD",2,2,.3852,21,4,0)
optional.  If Pension Award Reason is entered, an Award Date
"^DD",2,2,.3852,21,5,0)
must be entered.
"^DD",2,2,.3852,"DT")
3110918
"^DD",2,2,.3853,0)
PENSION TERMINATED DATE^D^^.385;3^S %DT="EX" D ^%DT S X=Y K:Y<1 X
"^DD",2,2,.3853,3)
When was the Pension Terminated?
"^DD",2,2,.3853,21,0)
^.001^2^2^3110601^^
"^DD",2,2,.3853,21,1,0)
The date that the Pension was terminated.
"^DD",2,2,.3853,21,2,0)
The Pension Terminated Date is not editable.
"^DD",2,2,.3853,"DT")
3110419
"^DD",2,2,.3854,0)
PENSION TERMINATED REASON 1^P27.18'^DG(27.18,^.385;4^Q
"^DD",2,2,.3854,3)
What is the first Pension Terminated Reason?
"^DD",2,2,.3854,21,0)
^^2^2^3110601^
"^DD",2,2,.3854,21,1,0)
The first Reason for the Pension Termination.
"^DD",2,2,.3854,21,2,0)
This field is not editable. 
"^DD",2,2,.3854,"DT")
3110510
"^DD",2,2,.3855,0)
PENSION TERMINATED REASON 2^P27.18'^DG(27.18,^.385;5^Q
"^DD",2,2,.3855,3)
What is the second Pension Terminated Reason?
"^DD",2,2,.3855,21,0)
^^2^2^3110601^
"^DD",2,2,.3855,21,1,0)
The second Reason for the Pension Termination.
"^DD",2,2,.3855,21,2,0)
This field is not editable.
"^DD",2,2,.3855,"DT")
3110510
"^DD",2,2,.3856,0)
PENSION TERMINATED REASON 3^P27.18'^DG(27.18,^.385;6^Q
"^DD",2,2,.3856,3)
What is the third Pension Terminated Reason?
"^DD",2,2,.3856,21,0)
^^2^2^3110601^
"^DD",2,2,.3856,21,1,0)
The third Reason for the Pension Termination.
"^DD",2,2,.3856,21,2,0)
This field is not editable.
"^DD",2,2,.3856,"DT")
3110510
"^DD",2,2,.3857,0)
PENSION TERMINATED REASON 4^P27.18'^DG(27.18,^.385;7^Q
"^DD",2,2,.3857,3)
What is the fourth Pension Terminated Reason?
"^DD",2,2,.3857,21,0)
^^2^2^3110601^
"^DD",2,2,.3857,21,1,0)
The fourth Reason for the Pension Termination.
"^DD",2,2,.3857,21,2,0)
This field is not editable.
"^DD",2,2,.3857,"DT")
3110510
"^DD",2,2,.3858,0)
CLASS II DENTAL INDICATOR^S^Y:YES;N:NO;^.385;8^Q
"^DD",2,2,.3858,3)
Enter the Class II Dental Indicator as described in the VBA Military Service data.
"^DD",2,2,.3858,21,0)
^^10^10^3110531^
"^DD",2,2,.3858,21,1,0)
Class II Dental Indication is for Veterans
"^DD",2,2,.3858,21,2,0)
having a SC non-compensable dental
"^DD",2,2,.3858,21,3,0)
condition(s) or disability shown to have been
"^DD",2,2,.3858,21,4,0)
in existence at the time of discharge or
"^DD",2,2,.3858,21,5,0)
release from active duty (after September
"^DD",2,2,.3858,21,6,0)
30, 1981).  Treatment may be authorized, as
"^DD",2,2,.3858,21,7,0)
reasonably necessary, for a one-time
"^DD",2,2,.3858,21,8,0)
correction of the SC non-compensable
"^DD",2,2,.3858,21,9,0)
condition under certain conditions
"^DD",2,2,.3858,21,10,0)
(38 CFR § 17.16).
"^DD",2,2,.3858,"DT")
3110419
"^DD",2,2,.3859,0)
DENTAL APPL DUE BEFORE DATE^D^^.385;9^S %DT="EX" D ^%DT S X=Y K:Y<1 X
"^DD",2,2,.3859,3)
Enter the Dental Application Due Before date as described in the VBA Military Service data.
"^DD",2,2,.3859,21,0)
^^3^3^3110531^
"^DD",2,2,.3859,21,1,0)
An application for Class II Dental treatment
"^DD",2,2,.3859,21,2,0)
must be made within 180 days after discharge
"^DD",2,2,.3859,21,3,0)
or release (38 CFR § 17.160).
"^DD",2,2,.3859,"DT")
3110419
"^DD",2,2,.386,0)
PENSION INDICATOR LOCK^S^Y:YES;N:NO;^.385;10^Q
"^DD",2,2,.386,.1)
PENSION INDICATOR LOCKED BY ESR
"^DD",2,2,.386,3)
Is the Pension Indicator field locked by ESR?
"^DD",2,2,.386,21,0)
^.001^7^7^3110608^^
"^DD",2,2,.386,21,1,0)
This field is used to restrict the site's
"^DD",2,2,.386,21,2,0)
ability to edit the Pension Indicator field
"^DD",2,2,.386,21,3,0)
'RECEIVING A VA PENSION?'(#.36253) field. Once
"^DD",2,2,.386,21,4,0)
an incoming message is received from ESR with
"^DD",2,2,.386,21,5,0)
any Pension Data, the Pension Indicator field
"^DD",2,2,.386,21,6,0)
becomes 'display only' and is not editable
"^DD",2,2,.386,21,7,0)
by the VistA user.
"^DD",2,2,.386,"DT")
3110505
"^DD",2,2,.3861,0)
PENSION AWARD LOCK^S^Y:YES;N:NO;^.385;11^Q
"^DD",2,2,.3861,.1)
PENSION AWARD FIELDS LOCKED BY ESR
"^DD",2,2,.3861,3)
Are the Pension Award fields locked by ESR?
"^DD",2,2,.3861,21,0)
^.001^14^14^3110608^^
"^DD",2,2,.3861,21,1,0)
This field is used to restrict the site's
"^DD",2,2,.3861,21,2,0)
ability to edit the Pension Award fields
"^DD",2,2,.3861,21,3,0)
'PENSION AWARD EFFECTIVE DATE'(#.3851) field
"^DD",2,2,.3861,21,4,0)
and 'PENSION AWARD REASON'(#.3852) field.
"^DD",2,2,.3861,21,5,0)
Once an incoming message is received from ESR
"^DD",2,2,.3861,21,6,0)
with a 'PENSION AWARD EFFECTIVE DATE'(#.3851)
"^DD",2,2,.3861,21,7,0)
field and with a 'PENSION AWARD REASON'
"^DD",2,2,.3861,21,8,0)
(#.3852) field of 'ORIGINAL AWARD', or with
"^DD",2,2,.3861,21,9,0)
a 'PENSION TERMINATED REASON'(#.3854,#.3855,
"^DD",2,2,.3861,21,10,0)
#.3856 or #.3857) field that does not have a
"^DD",2,2,.3861,21,11,0)
NULL value, then the 'PENSION AWARD EFFECTIVE
"^DD",2,2,.3861,21,12,0)
DATE' (#.3851) field and 'PENSION AWARD
"^DD",2,2,.3861,21,13,0)
REASON' (#.3852) field become 'display only'
"^DD",2,2,.3861,21,14,0)
and are not editable by the VistA user.
"^DD",2,2,.3861,"DT")
3110505
"^DD",27.18,27.18,0)
FIELD^^1^2
"^DD",27.18,27.18,0,"DDA")
N
"^DD",27.18,27.18,0,"DT")
3110504
"^DD",27.18,27.18,0,"IX","B",27.18,.01)

"^DD",27.18,27.18,0,"IX","C",27.18,1)

"^DD",27.18,27.18,0,"NM","PENSION AWARD REASONS")

"^DD",27.18,27.18,0,"PT",2,.3852)

"^DD",27.18,27.18,0,"PT",2,.3854)

"^DD",27.18,27.18,0,"PT",2,.3855)

"^DD",27.18,27.18,0,"PT",2,.3856)

"^DD",27.18,27.18,0,"PT",2,.3857)

"^DD",27.18,27.18,0,"VRPK")
DG
"^DD",27.18,27.18,.01,0)
REASON^RF^^0;1^K:$L(X)>120!($L(X)<1)!'(X'?1P.E) X
"^DD",27.18,27.18,.01,1,0)
^.1
"^DD",27.18,27.18,.01,1,1,0)
27.18^B
"^DD",27.18,27.18,.01,1,1,1)
S ^DG(27.18,"B",$E(X,1,30),DA)=""
"^DD",27.18,27.18,.01,1,1,2)
K ^DG(27.18,"B",$E(X,1,30),DA)
"^DD",27.18,27.18,.01,3)
Answer must be 1-120 characters in length.
"^DD",27.18,27.18,.01,21,0)
^^1^1^3110608^^^
"^DD",27.18,27.18,.01,21,1,0)
This is the reason for the Pension Award.
"^DD",27.18,27.18,.01,"DT")
3110608
"^DD",27.18,27.18,1,0)
CODE^F^^0;2^K:$L(X)>12!($L(X)<1) X
"^DD",27.18,27.18,1,1,0)
^.1
"^DD",27.18,27.18,1,1,1,0)
27.18^C
"^DD",27.18,27.18,1,1,1,1)
S ^DG(27.18,"C",$E(X,1,30),DA)=""
"^DD",27.18,27.18,1,1,1,2)
K ^DG(27.18,"C",$E(X,1,30),DA)
"^DD",27.18,27.18,1,1,1,"DT")
3110518
"^DD",27.18,27.18,1,3)
Enter a Pension Award Reason Code (1-12 characters).
"^DD",27.18,27.18,1,21,0)
^^1^1^3110606^
"^DD",27.18,27.18,1,21,1,0)
The code identifies the Pension Award Reason.
"^DD",27.18,27.18,1,"DT")
3110608
"^DIC",27.18,27.18,0)
PENSION AWARD REASONS^27.18
"^DIC",27.18,27.18,0,"GL")
^DG(27.18,
"^DIC",27.18,27.18,"%",0)
^1.005^^0
"^DIC",27.18,27.18,"%D",0)
^1.001^5^5^3110608^^^^
"^DIC",27.18,27.18,"%D",1,0)
This file contains reasons for the awarding of and changes to pension benefits. The VBA manages benefits awards and changes to benefits.  Receiving VA Pension is a monetary benefit granted to a 
"^DIC",27.18,27.18,"%D",2,0)
Veteran. Recently, additional information has been shared with the HEC so that periods of award could be more accurately 
"^DIC",27.18,27.18,"%D",3,0)
shown for billing purposes. Simply having a Pension Indicator = yes or no is not enough for that purpose. 
"^DIC",27.18,27.18,"%D",4,0)
 
"^DIC",27.18,27.18,"%D",5,0)
This file comes pre-populated and the sites are not allowed to edit it. Any changes to file will come in a patch.
"^DIC",27.18,"B","PENSION AWARD REASONS",27.18)

**INSTALL NAME**
IVM*2.0*150
"BLD",8396,0)
IVM*2.0*150^INCOME VERIFICATION MATCH^0^3120517^y
"BLD",8396,4,0)
^9.64PA^^
"BLD",8396,6.3)
17
"BLD",8396,"ABPKG")
n
"BLD",8396,"KRN",0)
^9.67PA^779.2^20
"BLD",8396,"KRN",.4,0)
.4
"BLD",8396,"KRN",.401,0)
.401
"BLD",8396,"KRN",.402,0)
.402
"BLD",8396,"KRN",.403,0)
.403
"BLD",8396,"KRN",.5,0)
.5
"BLD",8396,"KRN",.84,0)
.84
"BLD",8396,"KRN",3.6,0)
3.6
"BLD",8396,"KRN",3.8,0)
3.8
"BLD",8396,"KRN",9.2,0)
9.2
"BLD",8396,"KRN",9.8,0)
9.8
"BLD",8396,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",8396,"KRN",9.8,"NM",1,0)
IVMPTRN8^^0^B76977340
"BLD",8396,"KRN",9.8,"NM","B","IVMPTRN8",1)

"BLD",8396,"KRN",19,0)
19
"BLD",8396,"KRN",19.1,0)
19.1
"BLD",8396,"KRN",101,0)
101
"BLD",8396,"KRN",409.61,0)
409.61
"BLD",8396,"KRN",771,0)
771
"BLD",8396,"KRN",779.2,0)
779.2
"BLD",8396,"KRN",870,0)
870
"BLD",8396,"KRN",8989.51,0)
8989.51
"BLD",8396,"KRN",8989.52,0)
8989.52
"BLD",8396,"KRN",8994,0)
8994
"BLD",8396,"KRN","B",.4,.4)

"BLD",8396,"KRN","B",.401,.401)

"BLD",8396,"KRN","B",.402,.402)

"BLD",8396,"KRN","B",.403,.403)

"BLD",8396,"KRN","B",.5,.5)

"BLD",8396,"KRN","B",.84,.84)

"BLD",8396,"KRN","B",3.6,3.6)

"BLD",8396,"KRN","B",3.8,3.8)

"BLD",8396,"KRN","B",9.2,9.2)

"BLD",8396,"KRN","B",9.8,9.8)

"BLD",8396,"KRN","B",19,19)

"BLD",8396,"KRN","B",19.1,19.1)

"BLD",8396,"KRN","B",101,101)

"BLD",8396,"KRN","B",409.61,409.61)

"BLD",8396,"KRN","B",771,771)

"BLD",8396,"KRN","B",779.2,779.2)

"BLD",8396,"KRN","B",870,870)

"BLD",8396,"KRN","B",8989.51,8989.51)

"BLD",8396,"KRN","B",8989.52,8989.52)

"BLD",8396,"KRN","B",8994,8994)

"BLD",8396,"QUES",0)
^9.62^^
"BLD",8396,"REQB",0)
^9.611^1^1
"BLD",8396,"REQB",1,0)
IVM*2.0*151^2
"BLD",8396,"REQB","B","IVM*2.0*151",1)

"MBREQ")
0
"PKG",120,-1)
1^1
"PKG",120,0)
INCOME VERIFICATION MATCH^IVM^IVM Software for interface with the IVM Center
"PKG",120,20,0)
^9.402P^^
"PKG",120,22,0)
^9.49I^1^1
"PKG",120,22,1,0)
2.0^2941021^2960823
"PKG",120,22,1,"PAH",1,0)
150^3120517^100992
"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")
1
"RTN","IVMPTRN8")
0^1^B76977340
"RTN","IVMPTRN8",1,0)
IVMPTRN8 ;ALB/RKS/PDJ/BRM,TDM,PJH,TDM,PWC,LBD - HL7 FULL DATA TRANSMISSION (Z07) BUILDER ; 8/11/11 5:27pm
"RTN","IVMPTRN8",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,24,36,37,47,48,42,34,77,76,75,79,85,89,98,56,97,104,113,109,114,105,115,121,151,141,150**; 21-OCT-94;Build 17
"RTN","IVMPTRN8",3,0)
 ;
"RTN","IVMPTRN8",4,0)
 ;
"RTN","IVMPTRN8",5,0)
BUILD(DFN,IVMMTDT,IVMCT,IVMQUERY) ; --
"RTN","IVMPTRN8",6,0)
 ;  Description: This entry point will be used to create an HL7 
"RTN","IVMPTRN8",7,0)
 ;  "Full Data Transmission" message for a patient.
"RTN","IVMPTRN8",8,0)
 ;
"RTN","IVMPTRN8",9,0)
 ;  Input:
"RTN","IVMPTRN8",10,0)
 ;        DFN - Patient IEN
"RTN","IVMPTRN8",11,0)
 ;    IVMMTDT - date of the patient's Means Test or Copay Test
"RTN","IVMPTRN8",12,0)
 ;      IVMCT - count of hl7 segments transmitted, pass by reference
"RTN","IVMPTRN8",13,0)
 ;   IVMQUERY - array passed in by reference where
"RTN","IVMPTRN8",14,0)
 ;    IVMQUERY("LTD") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",15,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",16,0)
 ;                last treatment date
"RTN","IVMPTRN8",17,0)
 ;    IVMQUERY("OVIS") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",18,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",19,0)
 ;                finding outpatient visits
"RTN","IVMPTRN8",20,0)
 ;
"RTN","IVMPTRN8",21,0)
 ;  HL7 variables as defined by call to INIT^IVMUFNC:
"RTN","IVMPTRN8",22,0)
 ;      HLEVN - HL7 message event counter 
"RTN","IVMPTRN8",23,0)
 ;      HLSDT - a flag that indicates that the data to be sent is
"RTN","IVMPTRN8",24,0)
 ;              stored in the ^TMP("HLS") global array.
"RTN","IVMPTRN8",25,0)
 ;
"RTN","IVMPTRN8",26,0)
 ;  The following variables returned by the INIT^HLTRANS entry point:
"RTN","IVMPTRN8",27,0)
 ;    HLNDAP - Non-DHCP Application Pointer from file 770
"RTN","IVMPTRN8",28,0)
 ;   HLNDAP0 - Zero node from file 770 corresponding to HLNDAP
"RTN","IVMPTRN8",29,0)
 ;     HLDAP - DHCP Application Pointer from file 771
"RTN","IVMPTRN8",30,0)
 ;     HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP
"RTN","IVMPTRN8",31,0)
 ;     HLPID - HL7 processing ID from file 770
"RTN","IVMPTRN8",32,0)
 ;     HLVER - HL7 version number from file 770
"RTN","IVMPTRN8",33,0)
 ;      HLFS - HL7 Field Separator from the 'FS' node of file 771
"RTN","IVMPTRN8",34,0)
 ;     HLECH - HL7 Encoding Characters from the 'EC' node of file 771
"RTN","IVMPTRN8",35,0)
 ;       HLQ - Double quotes ("") for use in building HL7 segments
"RTN","IVMPTRN8",36,0)
 ;     HLERR - if an error is encountered, an error message is returned
"RTN","IVMPTRN8",37,0)
 ;             in the HLERR variable.
"RTN","IVMPTRN8",38,0)
 ;      HLDA - the internal entry number for the entry created in
"RTN","IVMPTRN8",39,0)
 ;             file #772.
"RTN","IVMPTRN8",40,0)
 ;      HLDT - transmission date/time (associated with the entry in file
"RTN","IVMPTRN8",41,0)
 ;             #772 identified by HLDA) in internal VA FileMan format.
"RTN","IVMPTRN8",42,0)
 ;     HLDT1 - the same transmission date/time as the HLDT variable, 
"RTN","IVMPTRN8",43,0)
 ;             only in HL7 format.
"RTN","IVMPTRN8",44,0)
 ;
"RTN","IVMPTRN8",45,0)
 ; Output:
"RTN","IVMPTRN8",46,0)
 ;  ^TMP("HLS",$J,IVMCT) - global array containing all segments of the HL7 message that the VistA application wishes to send.  The HLSDT variable is defined above and the IVMCT variable is a sequential number incremented by 1.
"RTN","IVMPTRN8",47,0)
 ;
"RTN","IVMPTRN8",48,0)
 ;
"RTN","IVMPTRN8",49,0)
 N DGINC,DGIR,DGREL,I,IVMNTE,IVMPID,IVMSUB,IVMZRD,VAFPID,VAFZEL,FBZFE,IVMZCD,DELETE,NODE,IVMPIEN,TEST,IVMPNODE,TESTTYPE,SEQS,TESTCODE,HARDSHIP,ACTVIEN,IVMZMH,IVMSEQ
"RTN","IVMPTRN8",50,0)
 N EDBMTZ06,ZMHSQ,SETID,OBXCNT,OBXTMP,DGSEC,SEGOCC,ZIOSEG,N101015,RF1SEG,ZCTTYP,ZCTARY,ZCTSQ,VAFPID,CAFLG
"RTN","IVMPTRN8",51,0)
 ;
"RTN","IVMPTRN8",52,0)
 ; create (PID) Patient Identification segment
"RTN","IVMPTRN8",53,0)
 ; **** Add ICN to 2nd piece PID segment for MPI@HEC.
"RTN","IVMPTRN8",54,0)
 S IVMCMOR="1,2",IVMSEQ=1
"RTN","IVMPTRN8",55,0)
 ; check to see if site is a legacy site.  If not add ICN to PID segment.
"RTN","IVMPTRN8",56,0)
 I '$D(^PPP(1020.128,"AC",$P($$SITE^VASITE,"^",3))) D
"RTN","IVMPTRN8",57,0)
 . I +$$GETICN^MPIF001(DFN)>0,($$IFLOCAL^MPIF001(DFN)=0) S IVMSEQ=IVMSEQ_",2",IVMCMOR="1,2,3"  ;add SEQ 1 and 2 for PID
"RTN","IVMPTRN8",58,0)
 ;
"RTN","IVMPTRN8",59,0)
 ; send SSN indicating pseudo
"RTN","IVMPTRN8",60,0)
 ; I $P(IVMPID_$G(IVMPID(1)),HLFS,20)["P" D PSEUDO^IVMPTRN1  ; strip 'P' from pseudo SSNs
"RTN","IVMPTRN8",61,0)
 S IVMSEQ=IVMSEQ_",3,5,6,7,8,10,11,12,13,14,16,17,19,22,24"
"RTN","IVMPTRN8",62,0)
 K IVMPID D BLDPID^VAFCQRY1(DFN,1,IVMSEQ,.IVMPID,.HL,.ERROR)
"RTN","IVMPTRN8",63,0)
 K VAFPID D STRIP11
"RTN","IVMPTRN8",64,0)
 S SEGOCC="" F  S SEGOCC=$O(VAFPID(SEGOCC)) Q:SEGOCC=""  D
"RTN","IVMPTRN8",65,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFPID(SEGOCC)
"RTN","IVMPTRN8",66,0)
 ;
"RTN","IVMPTRN8",67,0)
 ; **** create (PD1) Patient CMOR segment for MPI@HEC.
"RTN","IVMPTRN8",68,0)
 S:'$D(HL("FS")) HL("FS")=HLFS
"RTN","IVMPTRN8",69,0)
 S:'$D(HL("ECH")) HL("ECH")=HLECH
"RTN","IVMPTRN8",70,0)
 S:'$D(HL("Q")) HL("Q")=HLQ
"RTN","IVMPTRN8",71,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLPD1(DFN,IVMCMOR)
"RTN","IVMPTRN8",72,0)
 ;
"RTN","IVMPTRN8",73,0)
 ; create (ZPD) Patient Dependent Info. segment
"RTN","IVMPTRN8",74,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN1^VAFHLZPD(DFN,"1,6,7,8,9,11,12,13,17,19,30,31,32,33,34,35,40"),IVMINS=$P(^(IVMCT),HLFS,12)
"RTN","IVMPTRN8",75,0)
 I $D(VAFZPD(1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFZPD(1) K VAFZPD(1)
"RTN","IVMPTRN8",76,0)
 ;
"RTN","IVMPTRN8",77,0)
 ; create (ZTA) Temporary Address segment
"RTN","IVMPTRN8",78,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,8,9",,.HL)
"RTN","IVMPTRN8",79,0)
 ;
"RTN","IVMPTRN8",80,0)
 ; create (ZIE) Ineligible segment
"RTN","IVMPTRN8",81,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIE(DFN,"1,2,3",1)
"RTN","IVMPTRN8",82,0)
 ;
"RTN","IVMPTRN8",83,0)
 ; create (ZEL) Eligibility segment(s) 
"RTN","IVMPTRN8",84,0)
 ; **** Add 5th piece to ZEL to correct consistency check
"RTN","IVMPTRN8",85,0)
 D EN1^VAFHLZEL(DFN,"1,2,5,6,7,8,10,11,13,14,15,16,17,18,19,20,21,22,23,24,25,29,34,35,37,38,39,40",2,.VAFZEL)
"RTN","IVMPTRN8",86,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1))  ; Primary Eligibility
"RTN","IVMPTRN8",87,0)
 I $D(VAFZEL(1,1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1,1))
"RTN","IVMPTRN8",88,0)
 ; - other entitled eligibilities
"RTN","IVMPTRN8",89,0)
 F IVMSUB=1:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",90,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(+IVMSUB))
"RTN","IVMPTRN8",91,0)
 ;
"RTN","IVMPTRN8",92,0)
 ; create ZE2 segment (Optional)
"RTN","IVMPTRN8",93,0)
 I $P($G(^DPT(DFN,.385)),U)'="" S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZE2(DFN,"1,2")
"RTN","IVMPTRN8",94,0)
 ;
"RTN","IVMPTRN8",95,0)
 ; create (ZEN) Enrollment segment
"RTN","IVMPTRN8",96,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEN(DFN)
"RTN","IVMPTRN8",97,0)
 ;
"RTN","IVMPTRN8",98,0)
 ; create (ZCD) Catastrophic Disability segment(s)
"RTN","IVMPTRN8",99,0)
 D BUILD^VAFHLZCD(.IVMZCD,DFN,,HLQ,HLFS)
"RTN","IVMPTRN8",100,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZCD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",101,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZCD(+IVMSUB))
"RTN","IVMPTRN8",102,0)
 ;
"RTN","IVMPTRN8",103,0)
 ; Optionally create (ZMH) Military History segments
"RTN","IVMPTRN8",104,0)
 ; Pass "*" as parameter to send unlimited MSEs in Z07 (IVM*2*141)
"RTN","IVMPTRN8",105,0)
 D ENTER^VAFHLZMH(DFN,"IVMZMH","*")
"RTN","IVMPTRN8",106,0)
 S (ZMHSQ,SETID)=0
"RTN","IVMPTRN8",107,0)
 I $D(IVMZMH) F  S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ=""  D
"RTN","IVMPTRN8",108,0)
 . Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")=""
"RTN","IVMPTRN8",109,0)
 . S SETID=SETID+1,IVMCT=IVMCT+1
"RTN","IVMPTRN8",110,0)
 . S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6)
"RTN","IVMPTRN8",111,0)
 ;
"RTN","IVMPTRN8",112,0)
 ; create (ZRD) Rated Disabilities segment(s)
"RTN","IVMPTRN8",113,0)
 D EN^VAFHLZRD(DFN,"1,2,3,4,12,13,14,",HLQ,HLFS,"IVMZRD")
"RTN","IVMPTRN8",114,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",115,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0))
"RTN","IVMPTRN8",116,0)
 ;
"RTN","IVMPTRN8",117,0)
 ; create (ZCT) Emergency Contact segment
"RTN","IVMPTRN8",118,0)
 ;S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1)
"RTN","IVMPTRN8",119,0)
 K ZCTARY F ZCTTYP=1:1:5 D   ;Create Optional ZCT Segments
"RTN","IVMPTRN8",120,0)
 . S ZCTARY(ZCTTYP)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",ZCTTYP,1)
"RTN","IVMPTRN8",121,0)
 S (ZCTTYP,ZCTSQ)=0
"RTN","IVMPTRN8",122,0)
 I $D(ZCTARY) F  S ZCTTYP=$O(ZCTARY(ZCTTYP)) Q:ZCTTYP=""  D
"RTN","IVMPTRN8",123,0)
 . Q:$P(ZCTARY(ZCTTYP),HLFS,11)=HLQ
"RTN","IVMPTRN8",124,0)
 . S ZCTSQ=ZCTSQ+1,$P(ZCTARY(ZCTTYP),HLFS,2)=ZCTSQ
"RTN","IVMPTRN8",125,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(ZCTTYP)
"RTN","IVMPTRN8",126,0)
 I ZCTSQ=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(1)
"RTN","IVMPTRN8",127,0)
 ;
"RTN","IVMPTRN8",128,0)
 ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse
"RTN","IVMPTRN8",129,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7")
"RTN","IVMPTRN8",130,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7",2,2)
"RTN","IVMPTRN8",131,0)
 ;
"RTN","IVMPTRN8",132,0)
 ; create (ZGD) Guardian segment for (1) VA & (2) Civil 
"RTN","IVMPTRN8",133,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1)
"RTN","IVMPTRN8",134,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2)
"RTN","IVMPTRN8",135,0)
 ;
"RTN","IVMPTRN8",136,0)
 ; Income Year requiring transmission from IVM Patient File (301.5)
"RTN","IVMPTRN8",137,0)
 S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000))
"RTN","IVMPTRN8",138,0)
 N MTINFO S MTINFO=$$FUT^DGMTU(DFN)
"RTN","IVMPTRN8",139,0)
 I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2)
"RTN","IVMPTRN8",140,0)
 ;get the primary test for the income year
"RTN","IVMPTRN8",141,0)
 S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN)
"RTN","IVMPTRN8",142,0)
 ;
"RTN","IVMPTRN8",143,0)
 ; The following function call returns:
"RTN","IVMPTRN8",144,0)
 ;   - Patient Relation IEN array in DGREL
"RTN","IVMPTRN8",145,0)
 ;   - Individual Annual Income IEN array in DGINC
"RTN","IVMPTRN8",146,0)
 ;   - Income Relation IEN array in DGINR
"RTN","IVMPTRN8",147,0)
 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN)
"RTN","IVMPTRN8",148,0)
 ;
"RTN","IVMPTRN8",149,0)
 S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1
"RTN","IVMPTRN8",150,0)
 ; create (ZIC) Income segment for veteran
"RTN","IVMPTRN8",151,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",152,0)
 ;IVM*2.0*115 -- Check for Means Test Version Indicator
"RTN","IVMPTRN8",153,0)
 N MTVERS S MTVERS=$S(+$G(ACTVIEN):+$P($G(^DGMT(408.31,ACTVIEN,2)),"^",11),1:0)
"RTN","IVMPTRN8",154,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",155,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20")
"RTN","IVMPTRN8",156,0)
 E  D
"RTN","IVMPTRN8",157,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,9,12,13,14,15,16,18,19")
"RTN","IVMPTRN8",158,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",159,0)
 ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct
"RTN","IVMPTRN8",160,0)
 S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY)
"RTN","IVMPTRN8",161,0)
 ;
"RTN","IVMPTRN8",162,0)
 ; create (ZIR) Income Relation segment for veteran
"RTN","IVMPTRN8",163,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("V")),"1,2,3,4,5,10")
"RTN","IVMPTRN8",164,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1"
"RTN","IVMPTRN8",165,0)
 ;
"RTN","IVMPTRN8",166,0)
 ; create (ZDP) Patient Dependent Info. segment for spouse
"RTN","IVMPTRN8",167,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGREL("S")),"1,2,3,4,5,6,7,8,9,10,13,14")
"RTN","IVMPTRN8",168,0)
 I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",169,0)
 . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",170,0)
 . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",171,0)
 ;
"RTN","IVMPTRN8",172,0)
 ; create (ZIC) Income segment for spouse
"RTN","IVMPTRN8",173,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",174,0)
 ;IVM*2.0*115
"RTN","IVMPTRN8",175,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",176,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,4,5,6,7,8,9,10,11,12,16,17,18,19,20")
"RTN","IVMPTRN8",177,0)
 E  D
"RTN","IVMPTRN8",178,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,9,12,16,18,19")
"RTN","IVMPTRN8",179,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",180,0)
 ;
"RTN","IVMPTRN8",181,0)
 ; create (ZIR) Income Relation segment for spouse
"RTN","IVMPTRN8",182,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3")
"RTN","IVMPTRN8",183,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",184,0)
 ;
"RTN","IVMPTRN8",185,0)
 ;
"RTN","IVMPTRN8",186,0)
 ; create ZDP, ZIC, and ZIR segments for all Means Test dependents
"RTN","IVMPTRN8",187,0)
 F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",188,0)
 . ;
"RTN","IVMPTRN8",189,0)
 . ; - create (ZDP) Dependent Info. segment for dependent child
"RTN","IVMPTRN8",190,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGREL("C",IVMSUB)),"1,2,3,4,5,6,7,9,10")
"RTN","IVMPTRN8",191,0)
 . I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",192,0)
 . . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",193,0)
 . . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",194,0)
 . ;
"RTN","IVMPTRN8",195,0)
 . ; - create (ZIC) Income segment for dependent child
"RTN","IVMPTRN8",196,0)
 . S IVMCT=IVMCT+1
"RTN","IVMPTRN8",197,0)
 . ;IVM*2.0*115
"RTN","IVMPTRN8",198,0)
 . I MTVERS=0 D  I 1
"RTN","IVMPTRN8",199,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,4,5,6,7,8,9,10,11,12,15")
"RTN","IVMPTRN8",200,0)
 . E  D
"RTN","IVMPTRN8",201,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,9,12,15,16,18,19")
"RTN","IVMPTRN8",202,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",203,0)
 . ;
"RTN","IVMPTRN8",204,0)
 . ; - create (ZIR) Income Relation segment for dependent child
"RTN","IVMPTRN8",205,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("C",IVMSUB)),"1,2,3,4,6,7,8,9,14")
"RTN","IVMPTRN8",206,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",207,0)
 . ;
"RTN","IVMPTRN8",208,0)
 ; Send INACTIVE spouse/dependents.
"RTN","IVMPTRN8",209,0)
 D GETINACD^DGMTU11(DFN,.DGREL)
"RTN","IVMPTRN8",210,0)
 F I="S","C" D
"RTN","IVMPTRN8",211,0)
 . F IVMSUB=0:0 S IVMSUB=$O(DGIREL(I,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",212,0)
 . . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGIREL(I,IVMSUB)),"1,2,3,4,5,6,7,9,10,11",,,$P(DGIREL(I,IVMSUB),U,3))
"RTN","IVMPTRN8",213,0)
 ;
"RTN","IVMPTRN8",214,0)
 D GOTO^IVMPTRN9
"RTN","IVMPTRN8",215,0)
 Q
"RTN","IVMPTRN8",216,0)
 ;
"RTN","IVMPTRN8",217,0)
STRIP11 N APID,ZPID,ASQ,ATYP,SSQ
"RTN","IVMPTRN8",218,0)
 ;Extract PID segment
"RTN","IVMPTRN8",219,0)
 S IVMPID(1)=$E(IVMPID(1),5,$L(IVMPID(1)))
"RTN","IVMPTRN8",220,0)
 D BLDPID^IVMPREC6(.IVMPID,.APID)
"RTN","IVMPTRN8",221,0)
 ;
"RTN","IVMPTRN8",222,0)
 S CAFLG=0
"RTN","IVMPTRN8",223,0)
 I $D(APID(11)) D
"RTN","IVMPTRN8",224,0)
 .I $O(APID(11,"")) D  Q
"RTN","IVMPTRN8",225,0)
 ..M ZPID(11)=APID(11) K APID(11)
"RTN","IVMPTRN8",226,0)
 ..S (ASQ,SSQ)=0 F  S ASQ=$O(ZPID(11,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",227,0)
 ...S ATYP=$P($G(ZPID(11,ASQ)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",228,0)
 ...I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") Q
"RTN","IVMPTRN8",229,0)
 ...I ATYP="VACAE" S CAFLG=1
"RTN","IVMPTRN8",230,0)
 ...S SSQ=SSQ+1,APID(11,SSQ)=ZPID(11,ASQ)
"RTN","IVMPTRN8",231,0)
 .Q:$G(APID(11))=""
"RTN","IVMPTRN8",232,0)
 .S ATYP=$P($G(APID(11)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",233,0)
 .I ATYP="VACAE" S CAFLG=1 Q
"RTN","IVMPTRN8",234,0)
 .I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") K APID(11)
"RTN","IVMPTRN8",235,0)
 ;
"RTN","IVMPTRN8",236,0)
 I 'CAFLG,$D(APID(13)) D
"RTN","IVMPTRN8",237,0)
 .I $O(APID(13,"")) D  Q
"RTN","IVMPTRN8",238,0)
 ..S ASQ=0 F  S ASQ=$O(APID(13,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",239,0)
 ...Q:$G(APID(13,ASQ))=""
"RTN","IVMPTRN8",240,0)
 ...S ATYP=$P($G(APID(13,ASQ)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",241,0)
 ...I ATYP="VACPN" K APID(13,ASQ) Q
"RTN","IVMPTRN8",242,0)
 .Q:$G(APID(13))=""
"RTN","IVMPTRN8",243,0)
 .S ATYP=$P($G(APID(13)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",244,0)
 .I ATYP="VACPN" K APID(13) Q
"RTN","IVMPTRN8",245,0)
 ;
"RTN","IVMPTRN8",246,0)
 ;Rebuild PID
"RTN","IVMPTRN8",247,0)
 D KVA^VADPT
"RTN","IVMPTRN8",248,0)
 D MAKEIT^VAFHLU("PID",.APID,.VAFPID,.VAFPID)
"RTN","IVMPTRN8",249,0)
 S VAFPID(0)=VAFPID
"RTN","IVMPTRN8",250,0)
 Q
"VER")
8.0^22.0
**END**
**END**