DG_53_P754.KID

KIDS Distribution saved on Feb 01, 2011@16:13:58
ESR 3.1/VOA (02/01/2011)
**KIDS**:DG*5.3*754^IVM*2.0*121^

**INSTALL NAME**
DG*5.3*754
"BLD",7090,0)
DG*5.3*754^REGISTRATION^0^3110201^y
"BLD",7090,4,0)
^9.64PA^43^5
"BLD",7090,4,2,0)
2
"BLD",7090,4,2,2,0)
^9.641^2^1
"BLD",7090,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",7090,4,2,2,2,1,0)
^9.6411^.34011^26
"BLD",7090,4,2,2,2,1,.03,0)
DATE OF BIRTH
"BLD",7090,4,2,2,2,1,.119,0)
ADDRESS CHANGE SOURCE
"BLD",7090,4,2,2,2,1,.1311,0)
CELLULAR NUMBER CHANGE SOURCE
"BLD",7090,4,2,2,2,1,.1313,0)
PAGER NUMBER CHANGE SOURCE
"BLD",7090,4,2,2,2,1,.1315,0)
CONFIDENTIAL PHONE NUMBER
"BLD",7090,4,2,2,2,1,.137,0)
EMAIL ADDRESS CHANGE SOURCE
"BLD",7090,4,2,2,2,1,.14112,0)
CONFIDENTIAL ADDR CHANGE DT/TM
"BLD",7090,4,2,2,2,1,.152,0)
INELIGIBLE DATE
"BLD",7090,4,2,2,2,1,.21011,0)
K-WORK PHONE NUMBER
"BLD",7090,4,2,2,2,1,.211011,0)
K2-WORK PHONE NUMBER
"BLD",7090,4,2,2,2,1,.211012,0)
SECONDARY NOK CHANGE DATE/TIME
"BLD",7090,4,2,2,2,1,.219,0)
K-PHONE NUMBER
"BLD",7090,4,2,2,2,1,.2199,0)
K2-PHONE NUMBER
"BLD",7090,4,2,2,2,1,.291,0)
DATE RULED INCOMPETENT (VA)
"BLD",7090,4,2,2,2,1,.292,0)
DATE RULED INCOMPETENT (CIVIL)
"BLD",7090,4,2,2,2,1,.3013,0)
P&T EFFECTIVE DATE
"BLD",7090,4,2,2,2,1,.33011,0)
E-WORK PHONE NUMBER
"BLD",7090,4,2,2,2,1,.33012,0)
E-CONTACT CHANGE DATE/TIME
"BLD",7090,4,2,2,2,1,.331011,0)
E2-WORK PHONE NUMBER
"BLD",7090,4,2,2,2,1,.33112,0)
E2-CONTACT CHANGE DATE/TIME
"BLD",7090,4,2,2,2,1,.3319,0)
E2-PHONE NUMBER
"BLD",7090,4,2,2,2,1,.339,0)
E-PHONE NUMBER
"BLD",7090,4,2,2,2,1,.34011,0)
D-WORK PHONE NUMBER
"BLD",7090,4,2,2,2,1,.3412,0)
DESIGNEE CHANGE DATE/TIME
"BLD",7090,4,2,2,2,1,.349,0)
D-PHONE NUMBER
"BLD",7090,4,2,2,2,1,.351,0)
DATE OF DEATH
"BLD",7090,4,2,222)
y^y^p^^^^n^^n
"BLD",7090,4,2,224)

"BLD",7090,4,27.11,0)
27.11
"BLD",7090,4,27.11,2,0)
^9.641^27.11^1
"BLD",7090,4,27.11,2,27.11,0)
PATIENT ENROLLMENT  (File-top level)
"BLD",7090,4,27.11,2,27.11,1,0)
^9.6411^.01^1
"BLD",7090,4,27.11,2,27.11,1,.01,0)
ENROLLMENT APPLICATION DATE
"BLD",7090,4,27.11,222)
y^n^p^^^^n^^n
"BLD",7090,4,27.11,224)

"BLD",7090,4,43,0)
43
"BLD",7090,4,43,2,0)
^9.641^43^1
"BLD",7090,4,43,2,43,0)
MAS PARAMETERS  (File-top level)
"BLD",7090,4,43,2,43,1,0)
^9.6411^1302^2
"BLD",7090,4,43,2,43,1,1301,0)
AO STA EXP DATE
"BLD",7090,4,43,2,43,1,1302,0)
SWAC STA EXP DATE
"BLD",7090,4,43,222)
y^y^p^^^^n^^n
"BLD",7090,4,43,224)

"BLD",7090,4,391.23,0)
391.23
"BLD",7090,4,391.23,222)
y^y^f^^n^^y^r^n
"BLD",7090,4,408.13,0)
408.13
"BLD",7090,4,408.13,2,0)
^9.641^408.13^1
"BLD",7090,4,408.13,2,408.13,0)
INCOME PERSON  (File-top level)
"BLD",7090,4,408.13,2,408.13,1,0)
^9.6411^1.8^8
"BLD",7090,4,408.13,2,408.13,1,1.2,0)
STREET ADDRESS [LINE 1]
"BLD",7090,4,408.13,2,408.13,1,1.3,0)
STREET ADDRESS [LINE 2]
"BLD",7090,4,408.13,2,408.13,1,1.4,0)
STREET ADDRESS [LINE 3]
"BLD",7090,4,408.13,2,408.13,1,1.5,0)
CITY
"BLD",7090,4,408.13,2,408.13,1,1.6,0)
STATE
"BLD",7090,4,408.13,2,408.13,1,1.7,0)
ZIP
"BLD",7090,4,408.13,2,408.13,1,1.8,0)
TELEPHONE NUMBER
"BLD",7090,4,408.13,2,408.13,1,1.9,0)
SPOUSE ADDR LAST DT/TM UPDATED
"BLD",7090,4,408.13,222)
y^y^p^^^^n^^n
"BLD",7090,4,408.13,224)

"BLD",7090,4,"APDD",2,2)

"BLD",7090,4,"APDD",2,2,.03)

"BLD",7090,4,"APDD",2,2,.119)

"BLD",7090,4,"APDD",2,2,.1311)

"BLD",7090,4,"APDD",2,2,.1313)

"BLD",7090,4,"APDD",2,2,.1315)

"BLD",7090,4,"APDD",2,2,.137)

"BLD",7090,4,"APDD",2,2,.14112)

"BLD",7090,4,"APDD",2,2,.152)

"BLD",7090,4,"APDD",2,2,.21011)

"BLD",7090,4,"APDD",2,2,.211011)

"BLD",7090,4,"APDD",2,2,.211012)

"BLD",7090,4,"APDD",2,2,.219)

"BLD",7090,4,"APDD",2,2,.2199)

"BLD",7090,4,"APDD",2,2,.291)

"BLD",7090,4,"APDD",2,2,.292)

"BLD",7090,4,"APDD",2,2,.3013)

"BLD",7090,4,"APDD",2,2,.33011)

"BLD",7090,4,"APDD",2,2,.33012)

"BLD",7090,4,"APDD",2,2,.331011)

"BLD",7090,4,"APDD",2,2,.33112)

"BLD",7090,4,"APDD",2,2,.3319)

"BLD",7090,4,"APDD",2,2,.339)

"BLD",7090,4,"APDD",2,2,.34011)

"BLD",7090,4,"APDD",2,2,.3412)

"BLD",7090,4,"APDD",2,2,.349)

"BLD",7090,4,"APDD",2,2,.351)

"BLD",7090,4,"APDD",27.11,27.11)

"BLD",7090,4,"APDD",27.11,27.11,.01)

"BLD",7090,4,"APDD",43,43)

"BLD",7090,4,"APDD",43,43,1301)

"BLD",7090,4,"APDD",43,43,1302)

"BLD",7090,4,"APDD",408.13,408.13)

"BLD",7090,4,"APDD",408.13,408.13,1.2)

"BLD",7090,4,"APDD",408.13,408.13,1.3)

"BLD",7090,4,"APDD",408.13,408.13,1.4)

"BLD",7090,4,"APDD",408.13,408.13,1.5)

"BLD",7090,4,"APDD",408.13,408.13,1.6)

"BLD",7090,4,"APDD",408.13,408.13,1.7)

"BLD",7090,4,"APDD",408.13,408.13,1.8)

"BLD",7090,4,"APDD",408.13,408.13,1.9)

"BLD",7090,4,"B",2,2)

"BLD",7090,4,"B",27.11,27.11)

"BLD",7090,4,"B",43,43)

"BLD",7090,4,"B",391.23,391.23)

"BLD",7090,4,"B",408.13,408.13)

"BLD",7090,6.3)
46
"BLD",7090,"ABNS",0)
^9.66A^1^1
"BLD",7090,"ABNS",1,0)
DG
"BLD",7090,"ABNS",1,1,0)
^9.661A^^
"BLD",7090,"ABNS","B","DG",1)

"BLD",7090,"ABPKG")
n^n
"BLD",7090,"INI")
EP^DG53754P
"BLD",7090,"INID")
^^n
"BLD",7090,"INIT")
EN^DG53754B
"BLD",7090,"KRN",0)
^9.67PA^8989.52^19
"BLD",7090,"KRN",.4,0)
.4
"BLD",7090,"KRN",.401,0)
.401
"BLD",7090,"KRN",.402,0)
.402
"BLD",7090,"KRN",.403,0)
.403
"BLD",7090,"KRN",.5,0)
.5
"BLD",7090,"KRN",.84,0)
.84
"BLD",7090,"KRN",3.6,0)
3.6
"BLD",7090,"KRN",3.8,0)
3.8
"BLD",7090,"KRN",9.2,0)
9.2
"BLD",7090,"KRN",9.8,0)
9.8
"BLD",7090,"KRN",9.8,"NM",0)
^9.68A^38^36
"BLD",7090,"KRN",9.8,"NM",1,0)
DGENDD^^0^B10373132
"BLD",7090,"KRN",9.8,"NM",2,0)
DGLOCK^^0^B51327037
"BLD",7090,"KRN",9.8,"NM",3,0)
DGRODEBR^^0^B51758161
"BLD",7090,"KRN",9.8,"NM",4,0)
DGROHLR^^0^B17894920
"BLD",7090,"KRN",9.8,"NM",5,0)
DGROHLR1^^0^B36915578
"BLD",7090,"KRN",9.8,"NM",6,0)
DGROHLU^^0^B26960116
"BLD",7090,"KRN",9.8,"NM",7,0)
DGRPC^^0^B27065601
"BLD",7090,"KRN",9.8,"NM",8,0)
DGRPC3^^0^B27710641
"BLD",7090,"KRN",9.8,"NM",9,0)
DGRPCE^^0^B36086453
"BLD",7090,"KRN",9.8,"NM",10,0)
DGRPCE1^^0^B61785296
"BLD",7090,"KRN",9.8,"NM",11,0)
DGRPCF^^0^B24182202
"BLD",7090,"KRN",9.8,"NM",12,0)
VAFHLZRD^^0^B10015130
"BLD",7090,"KRN",9.8,"NM",13,0)
VAFHLZSP^^0^B5338744
"BLD",7090,"KRN",9.8,"NM",14,0)
DGCLEAR^^0^B7082785
"BLD",7090,"KRN",9.8,"NM",15,0)
DGDDDTTM^^0^B5522558
"BLD",7090,"KRN",9.8,"NM",16,0)
DGENPTA^^0^B39663736
"BLD",7090,"KRN",9.8,"NM",17,0)
DGENPTA1^^0^B21277182
"BLD",7090,"KRN",9.8,"NM",18,0)
DGENUPLA^^0^B65304654
"BLD",7090,"KRN",9.8,"NM",19,0)
DGREGTE2^^0^B21234416
"BLD",7090,"KRN",9.8,"NM",20,0)
DGRPCADD^^0^B13888843
"BLD",7090,"KRN",9.8,"NM",23,0)
VAFHLZDP^^0^B8641835
"BLD",7090,"KRN",9.8,"NM",24,0)
VAFHLZEM^^0^B9782974
"BLD",7090,"KRN",9.8,"NM",25,0)
VAFHLIN1^^0^B26305328
"BLD",7090,"KRN",9.8,"NM",26,0)
DG53754P^^0^B126007468
"BLD",7090,"KRN",9.8,"NM",27,0)
DG53754C^^0^B14090704
"BLD",7090,"KRN",9.8,"NM",28,0)
DGENEGT1^^0^B67955645
"BLD",7090,"KRN",9.8,"NM",29,0)
DGENELA4^^0^B68278282
"BLD",7090,"KRN",9.8,"NM",30,0)
DG53754A^^0^B1497395
"BLD",7090,"KRN",9.8,"NM",31,0)
VADPT^^0^B16796389
"BLD",7090,"KRN",9.8,"NM",32,0)
VADPT0^^0^B13592370
"BLD",7090,"KRN",9.8,"NM",33,0)
VADPT1^^0^B44162439
"BLD",7090,"KRN",9.8,"NM",34,0)
VAFCQRY3^^0^B59042687
"BLD",7090,"KRN",9.8,"NM",35,0)
VAFHLZIR^^0^B14809010
"BLD",7090,"KRN",9.8,"NM",36,0)
VAFHLZCT^^0^B9453735
"BLD",7090,"KRN",9.8,"NM",37,0)
DG53754B^^0^B1383730
"BLD",7090,"KRN",9.8,"NM",38,0)
DGRPEIS3^^0^B91146674
"BLD",7090,"KRN",9.8,"NM","B","DG53754A",30)

"BLD",7090,"KRN",9.8,"NM","B","DG53754B",37)

"BLD",7090,"KRN",9.8,"NM","B","DG53754C",27)

"BLD",7090,"KRN",9.8,"NM","B","DG53754P",26)

"BLD",7090,"KRN",9.8,"NM","B","DGCLEAR",14)

"BLD",7090,"KRN",9.8,"NM","B","DGDDDTTM",15)

"BLD",7090,"KRN",9.8,"NM","B","DGENDD",1)

"BLD",7090,"KRN",9.8,"NM","B","DGENEGT1",28)

"BLD",7090,"KRN",9.8,"NM","B","DGENELA4",29)

"BLD",7090,"KRN",9.8,"NM","B","DGENPTA",16)

"BLD",7090,"KRN",9.8,"NM","B","DGENPTA1",17)

"BLD",7090,"KRN",9.8,"NM","B","DGENUPLA",18)

"BLD",7090,"KRN",9.8,"NM","B","DGLOCK",2)

"BLD",7090,"KRN",9.8,"NM","B","DGREGTE2",19)

"BLD",7090,"KRN",9.8,"NM","B","DGRODEBR",3)

"BLD",7090,"KRN",9.8,"NM","B","DGROHLR",4)

"BLD",7090,"KRN",9.8,"NM","B","DGROHLR1",5)

"BLD",7090,"KRN",9.8,"NM","B","DGROHLU",6)

"BLD",7090,"KRN",9.8,"NM","B","DGRPC",7)

"BLD",7090,"KRN",9.8,"NM","B","DGRPC3",8)

"BLD",7090,"KRN",9.8,"NM","B","DGRPCADD",20)

"BLD",7090,"KRN",9.8,"NM","B","DGRPCE",9)

"BLD",7090,"KRN",9.8,"NM","B","DGRPCE1",10)

"BLD",7090,"KRN",9.8,"NM","B","DGRPCF",11)

"BLD",7090,"KRN",9.8,"NM","B","DGRPEIS3",38)

"BLD",7090,"KRN",9.8,"NM","B","VADPT",31)

"BLD",7090,"KRN",9.8,"NM","B","VADPT0",32)

"BLD",7090,"KRN",9.8,"NM","B","VADPT1",33)

"BLD",7090,"KRN",9.8,"NM","B","VAFCQRY3",34)

"BLD",7090,"KRN",9.8,"NM","B","VAFHLIN1",25)

"BLD",7090,"KRN",9.8,"NM","B","VAFHLZCT",36)

"BLD",7090,"KRN",9.8,"NM","B","VAFHLZDP",23)

"BLD",7090,"KRN",9.8,"NM","B","VAFHLZEM",24)

"BLD",7090,"KRN",9.8,"NM","B","VAFHLZIR",35)

"BLD",7090,"KRN",9.8,"NM","B","VAFHLZRD",12)

"BLD",7090,"KRN",9.8,"NM","B","VAFHLZSP",13)

"BLD",7090,"KRN",19,0)
19
"BLD",7090,"KRN",19,"NM",0)
^9.68A^^
"BLD",7090,"KRN",19.1,0)
19.1
"BLD",7090,"KRN",101,0)
101
"BLD",7090,"KRN",409.61,0)
409.61
"BLD",7090,"KRN",771,0)
771
"BLD",7090,"KRN",870,0)
870
"BLD",7090,"KRN",8989.51,0)
8989.51
"BLD",7090,"KRN",8989.52,0)
8989.52
"BLD",7090,"KRN",8994,0)
8994
"BLD",7090,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",7090,"KRN","B",3.6,3.6)

"BLD",7090,"KRN","B",3.8,3.8)

"BLD",7090,"KRN","B",9.2,9.2)

"BLD",7090,"KRN","B",9.8,9.8)

"BLD",7090,"KRN","B",19,19)

"BLD",7090,"KRN","B",19.1,19.1)

"BLD",7090,"KRN","B",101,101)

"BLD",7090,"KRN","B",409.61,409.61)

"BLD",7090,"KRN","B",771,771)

"BLD",7090,"KRN","B",870,870)

"BLD",7090,"KRN","B",8989.51,8989.51)

"BLD",7090,"KRN","B",8989.52,8989.52)

"BLD",7090,"KRN","B",8994,8994)

"BLD",7090,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",7090,"QUES",0)
^9.62^^
"BLD",7090,"REQB",0)
^9.611^17^15
"BLD",7090,"REQB",1,0)
DG*5.3*733^2
"BLD",7090,"REQB",3,0)
DG*5.3*572^2
"BLD",7090,"REQB",5,0)
DG*5.3*653^2
"BLD",7090,"REQB",6,0)
DG*5.3*144^2
"BLD",7090,"REQB",7,0)
DG*5.3*688^2
"BLD",7090,"REQB",8,0)
DG*5.3*740^2
"BLD",7090,"REQB",9,0)
DG*5.3*803^2
"BLD",7090,"REQB",10,0)
DG*5.3*809^2
"BLD",7090,"REQB",11,0)
DG*5.3*786^2
"BLD",7090,"REQB",12,0)
DG*5.3*707^2
"BLD",7090,"REQB",13,0)
DG*5.3*759^2
"BLD",7090,"REQB",14,0)
DG*5.3*810^2
"BLD",7090,"REQB",15,0)
DG*5.3*804^2
"BLD",7090,"REQB",16,0)
DG*5.3*749^2
"BLD",7090,"REQB",17,0)
IB*2.0*404^2
"BLD",7090,"REQB","B","DG*5.3*144",6)

"BLD",7090,"REQB","B","DG*5.3*572",3)

"BLD",7090,"REQB","B","DG*5.3*653",5)

"BLD",7090,"REQB","B","DG*5.3*688",7)

"BLD",7090,"REQB","B","DG*5.3*707",12)

"BLD",7090,"REQB","B","DG*5.3*733",1)

"BLD",7090,"REQB","B","DG*5.3*740",8)

"BLD",7090,"REQB","B","DG*5.3*749",16)

"BLD",7090,"REQB","B","DG*5.3*759",13)

"BLD",7090,"REQB","B","DG*5.3*786",11)

"BLD",7090,"REQB","B","DG*5.3*803",9)

"BLD",7090,"REQB","B","DG*5.3*804",15)

"BLD",7090,"REQB","B","DG*5.3*809",10)

"BLD",7090,"REQB","B","DG*5.3*810",14)

"BLD",7090,"REQB","B","IB*2.0*404",17)

"DATA",391.23,1,0)
OCCUPATION^2^.07^OCCUPATION^0^I
"DATA",391.23,2,0)
STREET ADDRESS [LINE 1]^2^.111^STREET ADDRESS [Line 1]^1^I
"DATA",391.23,3,0)
ZIP+4^2^.1112^ZIP + 4^1^I
"DATA",391.23,4,0)
STREET ADDRESS [LINE 2]^2^.112^STREET ADDRESS [Line 2]^1^I
"DATA",391.23,5,0)
STREET ADDRESS [LINE 3]^2^.113^STREET ADDRESS [Line 3]^1^I
"DATA",391.23,6,0)
CITY^2^.114^CITY^1^I
"DATA",391.23,7,0)
STATE^2^.115^STATE^1^C
"DATA",391.23,8,0)
ZIP CODE^2^.116^ZIP CODE^1^I
"DATA",391.23,9,0)
COUNTY^2^.117^VA COUNTY CODE^1^I
"DATA",391.23,10,0)
ADDRESS CHANGE DT/TM^2^.118^ADDRESS CHANGE DT/TM^1^I
"DATA",391.23,11,0)
ADDRESS CHANGE SOURCE^2^.119^ADDRESS CHANGE SOURCE^1^I
"DATA",391.23,12,0)
ADDRESS CHANGE SITE^2^.12^ADDRESS CHANGE SITE^1^I
"DATA",391.23,13,0)
TEMPORARY ADDRESS ACTIVE?^2^.12105^TEMPORARY ADDRESS ACTIVE? (ZTA^0^C
"DATA",391.23,14,0)
TEMPORARY STREET [LINE 1]^2^.1211^TEMPORARY STREET [Line 1] (ZTA^0^I
"DATA",391.23,15,0)
TEMPORARY ADDRESS COUNTY^2^.12111^TEMPORARY ADDRESS COUNTY (ZTA ^0^I
"DATA",391.23,16,0)
TEMPORARY ZIP+4^2^.12112^TEMPORARY ZIP+4 (ZTA not retur^0^I
"DATA",391.23,17,0)
TEMPORARY STREET [LINE 2]^2^.1212^TEMPORARY STREET [Line 2] (ZTA^0^I
"DATA",391.23,18,0)
TEMPORARY STREET [LINE 3]^2^.1213^TEMPORARY STREET [Line 3] (ZTA^0^I
"DATA",391.23,19,0)
TEMPORARY CITY^2^.1214^TEMPORARY CITY (ZTA not return^0^I
"DATA",391.23,20,0)
TEMPORARY STATE^2^.1215^TEMPORARY STATE (ZTA not retur^0^E
"DATA",391.23,21,0)
TEMPORARY ZIP CODE^2^.1216^TEMPORARY ZIP CODE (ZTA not re^0^I
"DATA",391.23,22,0)
TEMPORARY ADDRESS START DATE^2^.1217^TEMPORARY ADDRESS START DATE (^0^E
"DATA",391.23,23,0)
TEMPORARY ADDRESS END DATE^2^.1218^TEMPORARY ADDRESS END DATE (ZT^0^I
"DATA",391.23,24,0)
TEMPORARY PHONE NUMBER^2^.1219^TEMPORARY PHONE NUMBER (ZTA no^0^I
"DATA",391.23,25,0)
PHONE NUMBER [RESIDENCE]^2^.131^PHONE NUMBER RESIDENCE ^1^I
"DATA",391.23,26,0)
PHONE NUMBER [WORK]^2^.132^PHONE NUMBER WORK ^0^I
"DATA",391.23,27,0)
CONFIDENTIAL ADDRESS CATEGORY^2.141^.01^CONFIDENTIAL ADDRESS CATEGORY^0^Q
"DATA",391.23,28,0)
CONFIDENTIAL ADDRESS ACTIVE?^2^.14105^CONFIDENTIAL ADDRESS ACTIVE (Y^0^C
"DATA",391.23,29,0)
CONFIDENTIAL STREET [LINE 1]^2^.1411^CONFIDENTIAL ADDRESS LINE 1^0^I
"DATA",391.23,30,0)
CONFIDENTIAL ADDRESS COUNTY^2^.14111^CONFIDENTIAL ADDRESS COUNTY^0^I
"DATA",391.23,31,0)
CONFIDENTIAL STREET [LINE 2]^2^.1412^CONFIDENTIAL ADDRESS LINE 2^0^I
"DATA",391.23,32,0)
CONFIDENTIAL STREET [LINE 3]^2^.1413^CONFIDENTIAL ADDRESS LINE 3^0^I
"DATA",391.23,33,0)
CONFIDENTIAL ADDRESS CITY^2^.1414^CONFIDENTIAL CITY^0^I
"DATA",391.23,34,0)
CONFIDENTIAL ADDRESS STATE^2^.1415^CONFIDENTIAL STATE^0^E
"DATA",391.23,35,0)
CONFIDENTIAL ADDRESS ZIP CODE^2^.1416^CONFIDENTIAL ZIP^0^I
"DATA",391.23,36,0)
CONFIDENTIAL START DATE^2^.1417^CONFIDENTIAL ADDRESS START DAT^0^D
"DATA",391.23,37,0)
CONFIDENTIAL END DATE^2^.1418^CONFIDENTIAL ADDRESS END DATE^0^I
"DATA",391.23,38,0)
K-WORK PHONE NUMBER^2^.21011^Business Phone Number (NK1) (N^0^I
"DATA",391.23,39,0)
K-NAME OF PRIMARY NOK^2^.211^Name (NK1) (Not returned to Vi^0^C
"DATA",391.23,40,0)
K2-WORK PHONE NUMBER^2^.211011^Business Phone Number (NK2) (N^0^I
"DATA",391.23,41,0)
K-RELATIONSHIP TO PATIENT^2^.212^Relationship (NK1) (Not return^0^I
"DATA",391.23,42,0)
K-STREET ADDRESS [LINE 1]^2^.213^STREET ADDRESS [LINE 1] (NK1) ^0^I
"DATA",391.23,43,0)
K-STREET ADDRESS [LINE 2]^2^.214^STREET ADDRESS [LINE 2] (NK1) ^0^I
"DATA",391.23,44,0)
K-STREET ADDRESS [LINE 3]^2^.215^STREET ADDRESS [LINE 3] (NK1) ^0^I
"DATA",391.23,45,0)
K-CITY^2^.216^CITY (NK1) (Not returned to Vi^0^I
"DATA",391.23,46,0)
K-STATE^2^.217^STATE (NK1) (Not returned to V^0^I
"DATA",391.23,47,0)
K-ZIP CODE^2^.218^ZIP (NK1) (Not returned to Vis^0^I
"DATA",391.23,48,0)
K-PHONE NUMBER^2^.219^Phone Number (NK1) (Not return^0^I
"DATA",391.23,49,0)
K2-NAME OF SECONDARY NOK^2^.2191^Name (NK2) (Not returned to Vi^0^E
"DATA",391.23,50,0)
K2-RELATIONSHIP TO PATIENT^2^.2192^Relationship (NK2) (Not return^0^I
"DATA",391.23,51,0)
K2-STREET ADDRESS [LINE 1]^2^.2193^STREET ADDRESS [LINE 1] (NK2) ^0^I
"DATA",391.23,52,0)
K2-STREET ADDRESS [LINE 2]^2^.2194^STREET ADDRESS [LINE 2] (NK2) ^0^I
"DATA",391.23,53,0)
K2-STREET ADDRESS [LINE 3]^2^.2195^STREET ADDRESS [LINE 3] (NK2) ^0^I
"DATA",391.23,54,0)
K2-CITY^2^.2196^CITY (NK2) (Not returned to Vi^0^I
"DATA",391.23,55,0)
K2-STATE^2^.2197^STATE (NK2) (Not returned to V^0^I
"DATA",391.23,56,0)
K2-ZIP CODE^2^.2198^ZIP (NK2) (Not returned to Vis^0^I
"DATA",391.23,57,0)
K2-PHONE NUMBER^2^.2199^Phone Number (NK2) (Not return^0^I
"DATA",391.23,58,0)
EMPLOYER ZIP+4^2^.2205^EMPLOYER ZIP+4^0^I
"DATA",391.23,59,0)
SPOUSE'S EMP ZIP+4^2^.2206^SPOUSE'S EMP ZIP+4^0^I
"DATA",391.23,60,0)
SPOUSE'S EMPLOYER NAME^2^.251^SPOUSE'S EMPLOYER NAME^0^E
"DATA",391.23,61,0)
SPOUSE'S OCCUPATION^2^.2514^SPOUSE'S OCCUPATION^0^I
"DATA",391.23,62,0)
SPOUSE'S EMPLOYMENT STATUS^2^.2515^SPOUSE'S EMPLOYMENT STATUS^0^I
"DATA",391.23,63,0)
SPOUSE'S EMP STREET [LINE 1]^2^.252^SPOUSE'S EMP STREET [LINE 1]^0^I
"DATA",391.23,64,0)
SPOUSE'S EMP STREET [LINE 2]^2^.253^SPOUSE'S EMP STREET [LINE 2]^0^I
"DATA",391.23,65,0)
SPOUSE'S EMP STREET [LINE 3]^2^.254^SPOUSE'S EMP STREET [LINE 3]^0^I
"DATA",391.23,66,0)
SPOUSE'S EMPLOYER'S CITY^2^.255^SPOUSE'S EMPLOYER'S CITY^0^I
"DATA",391.23,67,0)
SPOUSE'S EMPLOYER'S STATE^2^.256^SPOUSE'S EMPLOYER'S STATE^0^I
"DATA",391.23,68,0)
SPOUSE'S EMP PHONE NUMBER^2^.258^SPOUSE'S EMP PHONE NUMBER^0^I
"DATA",391.23,69,0)
EMPLOYER NAME^2^.3111^EMPLOYER NAME^0^E
"DATA",391.23,70,0)
EMPLOYMENT STATUS^2^.31115^EMPLOYMENT STATUS^0^C
"DATA",391.23,71,0)
EMPLOYER STREET [LINE 1]^2^.3113^EMPLOYER STREET LINE 1^0^I
"DATA",391.23,72,0)
EMPLOYER STREET [LINE 2]^2^.3114^EMPLOYER STREET LINE 2^0^I
"DATA",391.23,73,0)
EMPLOYER STREET [LINE 3]^2^.3115^EMPLOYER STREET LINE 3^0^I
"DATA",391.23,74,0)
EMPLOYER CITY^2^.3116^EMPLOYER CITY^0^I
"DATA",391.23,75,0)
EMPLOYER STATE^2^.3117^EMPLOYER STATE^0^I
"DATA",391.23,76,0)
EMPLOYER PHONE NUMBER^2^.3119^EMPLOYER PHONE^0^I
"DATA",391.23,77,0)
VIETNAM FROM DATE^2^.32104^VIETNAM FROM DATE^0^I
"DATA",391.23,78,0)
VIETNAM TO DATE^2^.32105^VIETNAM TO DATE^0^I
"DATA",391.23,79,0)
AGENT ORANGE REGISTRATION DATE^2^.32107^AGENT ORANGE REGISTRATION DATE^0^I
"DATA",391.23,80,0)
AGENT ORANGE EXAM DATE^2^.32109^AGENT ORANGE EXAM DATE^0^I
"DATA",391.23,81,0)
AGENT ORANGE REGISTRATION #^2^.3211^ AGENT ORANGE REGISTRATION #^0^I
"DATA",391.23,82,0)
RADIATION REGISTRATION DATE^2^.32111^RADIATION REGISTRATION DATE^0^I
"DATA",391.23,83,0)
RADIATION EXPOSURE METHOD^2^.3212^RADIATION EXPOSURE METHOD^1^I
"DATA",391.23,84,0)
PERSIAN GULF SERVICE?^2^.32201^PERSIAN GULF SERVICE?^0^C
"DATA",391.23,85,0)
PERSIAN GULF FROM DATE^2^.322011^PERSIAN GULF FROM DATE^0^E
"DATA",391.23,86,0)
PERSIAN GULF TO DATE^2^.322012^PERSIAN GULF TO DATE^0^I
"DATA",391.23,87,0)
SOMALIA SERVICE INDICATED?^2^.322016^SOMALIA SERVICE INDICATED?^0^C
"DATA",391.23,88,0)
SOMALIA FROM DATE^2^.322017^SOMALIA FROM DATE^0^E
"DATA",391.23,89,0)
SOMALIA TO DATE^2^.322018^SOMALIA TO DATE^0^I
"DATA",391.23,90,0)
YUGOSLAVIA SERVICE INDICATED?^2^.322019^YUGOSLAVIA SERVICE INDICATED?^0^C
"DATA",391.23,91,0)
YUGOSLAVIA FROM DATE^2^.32202^YUGOSLAVIA FROM DATE^0^E
"DATA",391.23,92,0)
YUGOSLAVIA TO DATE^2^.322021^YUGOSLAVIA TO DATE^0^I
"DATA",391.23,93,0)
LEBANON SERVICE INDICATED?^2^.3221^LEBANON SERVICE INDICATED?^0^C
"DATA",391.23,94,0)
LEBANON FROM DATE^2^.3222^LEBANON FROM DATE^0^E
"DATA",391.23,95,0)
LEBANON TO DATE^2^.3223^LEBANON TO DATE^0^I
"DATA",391.23,96,0)
GRENADA SERVICE INDICATED?^2^.3224^GRENADA SERVICE INDICATED?^0^C
"DATA",391.23,97,0)
GRENADA FROM DATE^2^.3225^GRENADA FROM DATE^0^E
"DATA",391.23,98,0)
GRENADA TO DATE^2^.3226^GRENADA TO DATE^0^I
"DATA",391.23,99,0)
PANAMA SERVICE INDICATED?^2^.3227^PANAMA SERVICE INDICATED?^0^C
"DATA",391.23,100,0)
PANAMA FROM DATE^2^.3228^PANAMA FROM DATE^0^E
"DATA",391.23,101,0)
PANAMA TO DATE^2^.3229^PANAMA TO DATE^0^I
"DATA",391.23,102,0)
SERVICE DISCHARGE TYPE [LAST]^2^.324^SERVICE DISCHARGE TYPE [LAST]^0^I
"DATA",391.23,103,0)
SERVICE BRANCH [LAST]^2^.325^SERVICE BRANCH [LAST]^0^I
"DATA",391.23,104,0)
SERVICE ENTRY DATE [LAST]^2^.326^SERVICE ENTRY DATE [LAST]^0^E
"DATA",391.23,105,0)
SERVICE SEPARATION DATE [LAST]^2^.327^SERVICE SEPARATION DATE [LAST]^0^I
"DATA",391.23,106,0)
SERVICE NUMBER [LAST]^2^.328^SERVICE NUMBER [LAST]^0^I
"DATA",391.23,107,0)
SERVICE SECOND EPISODE?^2^.3285^SERVICE SECOND EPISODE?^0^C
"DATA",391.23,108,0)
SERVICE DISCHARGE TYPE [NTL]^2^.329^SERVICE DISCHARGE TYPE [NTL]^0^I
"DATA",391.23,109,0)
SERVICE BRANCH [NTL]^2^.3291^SERVICE BRANCH [NTL]^0^I
"DATA",391.23,110,0)
SERVICE ENTRY DATE [NTL]^2^.3292^SERVICE ENTRY DATE [NTL]^0^H
"DATA",391.23,111,0)
SERVICE SEPARATION DATE [NTL]^2^.3293^SERVICE SEPARATION DATE [NTL]^0^I
"DATA",391.23,112,0)
SERVICE NUMBER [NTL]^2^.3294^SERVICE NUMBER [NTL]^0^I
"DATA",391.23,113,0)
SERVICE THIRD EPISODE?^2^.32945^SERVICE THIRD EPISODE?^0^E
"DATA",391.23,114,0)
SERVICE DISCHARGE TYPE [NNTL]^2^.3295^SERVICE DISCHARGE TYPE [NNTL]^0^I
"DATA",391.23,115,0)
SERVICE BRANCH [NNTL]^2^.3296^SERVICE BRANCH [NNTL]^0^I
"DATA",391.23,116,0)
SERVICE ENTRY DATE [NNTL]^2^.3297^SERVICE ENTRY DATE [NNTL]^0^I
"DATA",391.23,117,0)
SERVICE SEPARATION DATE [NNTL]^2^.3298^SERVICE SEPARATION DATE [NNTL]^0^I
"DATA",391.23,118,0)
SERVICE NUMBER [NNTL]^2^.3299^SERVICE NUMBER [NNTL]^0^I
"DATA",391.23,119,0)
E-WORK PHONE NUMBER^2^.33011^Business Phone Number (EC1) (N^0^I
"DATA",391.23,120,0)
E-NAME^2^.331^Name (EC1) (Not returned to Vi^0^C
"DATA",391.23,121,0)
E2-WORK PHONE NUMBER^2^.331011^Business Phone Number (EC2) (N^0^I
"DATA",391.23,122,0)
E2-NAME OF SECONDARY CONTACT^2^.3311^Name (EC2) (Not returned to Vi^0^E
"DATA",391.23,123,0)
E2-RELATIONSHIP TO PATIENT^2^.3312^Relationship (EC2)(Not returne^0^I
"DATA",391.23,124,0)
E2-STREET ADDRESS [LINE 1]^2^.3313^STREET ADDRESS [LINE 1] (EC2) ^0^I
"DATA",391.23,125,0)
E2-STREET ADDRESS [LINE 2]^2^.3314^STREET ADDRESS [LINE 2] (EC2) ^0^I
"DATA",391.23,126,0)
E2-STREET ADDRESS [LINE 3]^2^.3315^STREET ADDRESS [LINE 3] (EC2) ^0^I
"DATA",391.23,127,0)
E2-CITY^2^.3316^CITY (EC2) (Not returned to Vi^0^I
"DATA",391.23,128,0)
E2-STATE^2^.3317^STATE (EC2) (Not returned to V^0^I
"DATA",391.23,129,0)
E2-ZIP CODE^2^.3318^ZIP (EC2) (Not returned to Vis^0^I
"DATA",391.23,130,0)
E2-PHONE NUMBER^2^.3319^Phone Number (EC2) (Not return^0^I
"DATA",391.23,131,0)
E-RELATIONSHIP TO PATIENT^2^.332^Relationship (EC1) (Not return^0^I
"DATA",391.23,132,0)
E-STREET ADDRESS [LINE 1]^2^.333^STREET ADDRESS [LINE 1] (EC1) ^0^I
"DATA",391.23,133,0)
E-STREET ADDRESS [LINE 2]^2^.334^STREET ADDRESS [LINE 2] (EC1) ^0^I
"DATA",391.23,134,0)
E-STREET ADDRESS [LINE 3]^2^.335^STREET ADDRESS [LINE 3] (EC1) ^0^I
"DATA",391.23,135,0)
E-CITY^2^.336^CITY (EC1) (Not returned to Vi^0^I
"DATA",391.23,136,0)
E-STATE^2^.337^STATE (EC1) (Not returned to V^0^I
"DATA",391.23,137,0)
E-ZIP CODE^2^.338^ZIP (EC1) (Not returned to Vis^0^I
"DATA",391.23,138,0)
E-PHONE NUMBER^2^.339^Phone Number (EC1) (Not return^0^I
"DATA",391.23,139,0)
D-WORK PHONE NUMBER^2^.34011^Business Phone Number (DESIG) ^0^I
"DATA",391.23,140,0)
D-NAME OF DESIGNEE^2^.341^Name (DESIG) (Not returned to ^0^C
"DATA",391.23,141,0)
D-RELATIONSHIP TO PATIENT^2^.342^Relationship (DESIG) (Not retu^0^I
"DATA",391.23,142,0)
D-STREET ADDRESS [LINE 1]^2^.343^STREET ADDRESS [LINE 1] (DESIG^0^I
"DATA",391.23,143,0)
D-STREET ADDRESS [LINE 2]^2^.344^STREET ADDRESS [LINE 2] (DESIG^0^I
"DATA",391.23,144,0)
D-STREET ADDRESS [LINE 3]^2^.345^STREET ADDRESS [LINE 3] (DESIG^0^I
"DATA",391.23,145,0)
D-CITY^2^.346^CITY (DESIG) (Not returned to ^0^I
"DATA",391.23,146,0)
D-STATE^2^.347^STATE (DESIG) (Not returned to^0^I
"DATA",391.23,147,0)
D-ZIP CODE^2^.348^ZIP (DESIG) (Not returned to V^0^I
"DATA",391.23,148,0)
D-PHONE NUMBER^2^.349^Phone Number (DESIG) (Not retu^0^I
"DATA",391.23,149,0)
DATE OF DEATH^2^.351^DATE OF DEATH^0^I
"DATA",391.23,150,0)
POW CONFINEMENT LOCATION^2^.526^POW LOCATION^1^I
"DATA",391.23,151,0)
POW FROM DATE^2^.527^POW FROM DATE^1^I
"DATA",391.23,152,0)
POW TO DATE^2^.528^POW TO DATE^1^I
"DATA",391.23,153,0)
COMBAT SERVICE INDICATED?^2^.5291^COMBAT SERVICE INDICATED?^0^C
"DATA",391.23,154,0)
COMBAT SERVICE LOCATION^2^.5292^COMBAT SERVICE LOCATION^0^I
"DATA",391.23,155,0)
COMBAT FROM DATE^2^.5293^COMBAT FROM DATE^0^I
"DATA",391.23,156,0)
COMBAT TO DATE^2^.5294^COMBAT TO DATE^0^I
"DATA",391.23,157,0)
LAST EDITED BY^2^.355^^^I
"DATA",391.23,158,0)
ALIAS^2.01^.01^ALIAS^1^K
"DATA",391.23,159,0)
ALIAS SSN^2.01^1^ALIAS SSN ^1^K
"DATA",391.23,160,0)
SPONSOR^355.8^.01^SPONSOR NAME^0^i
"DATA",391.23,161,0)
MILITARY STATUS^355.8^.02^SPONSOR MILITARY STATUS^0^i
"DATA",391.23,162,0)
BRANCH^355.8^.03^SPONSOR BRANCH OF SERVICE^0^i
"DATA",391.23,163,0)
RANK^355.8^.04^SPONSOR RANK^0^i
"DATA",391.23,164,0)
FAMILY PREFIX^355.81^.03^SPONSOR PREFIX^0^m
"DATA",391.23,165,0)
SPONSOR TYPE^355.81^.04^SPONSOR TYPE^0^m
"DATA",391.23,166,0)
EFFECTIVE DATE^355.81^.05^SPONSOR EFFECTIVE DATE^0^m
"DATA",391.23,167,0)
EXPIRATION DATE^355.81^.06^SPONSOR EXPIRATION DATE^0^m
"DATA",391.23,168,0)
DATE OF BIRTH^355.82^.02^SPONSOR SOCIAL SECURITY NUMBER^0^p
"DATA",391.23,169,0)
MARRIED THIS YEAR^408.22^.14^Married this year^0^s
"DATA",391.23,170,0)
LIVING WITH PATIENT^408.22^.15^Living with Patient^0^s
"DATA",391.23,171,0)
BAD ADDRESS INDICATOR^2^.121^BAD ADDRESS INDICATOR^1^I
"DATA",391.23,172,0)
NAME^38.1^.01^NAME Pointer to Patient File^0^f
"DATA",391.23,173,0)
SECURITY LEVEL^38.1^2^SECURITY LEVEL SENS PATIENT^0^f
"DATA",391.23,174,0)
SPONSOR PERSON NAME^355.82^.01^NAME^0^p
"DATA",391.23,175,0)
SOCIAL SECURITY NUMBER^355.82^.03^SPONSOR SOCIAL SECURITY NUMBER^0^p
"DATA",391.23,176,0)
RACE^2.02^.01^RACE MULTIPLE SUB-FILE^^M
"DATA",391.23,177,0)
ETHNICITY^2.06^.01^ETHNICITY INFORMATION^^O
"DATA",391.23,178,0)
ETHNICITY METHOD OF COLLECTION^2.06^.02^ETHNICITY METHOD OF COLLECTION^^O
"DATA",391.23,179,0)
RACE METHOD OF COLLECTION^2.02^.02^RACE METHOD OF COLLECTION^^M
"DATA",391.23,180,0)
CONFIDENTIAL CATEGORY ACTIVE^2.141^1^CONFIDENTIAL CATEGORY ACTIVE^^Q
"DATA",391.23,181,0)
VIETNAM SERVICE INDICATED?^2^.32101^VIETNAM SERVICE INDICATED?^^C
"DATA",391.23,182,0)
DEATH ENTERED BY^2^.352^DEATH ENTERED BY^^I
"DATA",391.23,183,0)
SOURCE OF NOTIFICATION^2^.353^SOURCE OF NOTIFICATION^^I
"DATA",391.23,184,0)
DATE OF DEATH LAST UPDATED^2^.354^DATE OF DEATH LAST UPDATED^^I
"DATA",391.23,185,0)
POW STATUS INDICATED?^2^.525^POW STATUS INDICATED?^1^I
"DATA",391.23,186,0)
AGENT ORANGE EXPOS. INDICATED?^2^.32102^AGENT ORANGE EXPOS. INDICATED?^^C
"DATA",391.23,187,0)
RADIATION EXPOSURE INDICATED?^2^.32103^RADIATION EXPOSURE INDICATED?^^C
"DATA",391.23,188,0)
AGENT ORANGE EXPOSURE LOCATION^2^.3213^AGENT ORANGE EXPOSURE LOCATION^1^I
"DATA",391.23,189,0)
MARITAL STATUS^2^.05^MARITAL STATUS^0^C
"DATA",391.23,190,0)
PERIOD OF SERVICE^2^.323^^^I
"DATA",391.23,191,0)
PRIMARY ELIGIBILITY CODE^2^.361^PEC for Veteran^0^C
"DATA",391.23,192,0)
TEMPORARY POSTAL CODE^2^.1222^^^I
"DATA",391.23,193,0)
TEMPORARY PROVINCE^2^.1221^TEMPORARY PROVINCE^^I
"DATA",391.23,194,0)
TEMPORARY COUNTRY^2^.1223^TEMPORARY COUNTRY^^I
"DATA",391.23,195,0)
CONFIDENTIAL POSTAL CODE^2^.14115^CONFIDENTIAL POSTAL CODE^^I
"DATA",391.23,196,0)
CONFIDENTIAL PROVINCE^2^.14114^CONFIDENTIAL PROVINCE^^I
"DATA",391.23,197,0)
CONFIDENTIAL COUNTRY^2^.14116^CONFIDENTIAL COUNTRY^^I
"DATA",391.23,201,0)
DATE OF RETIREMENT^2^.31116^RETIRED DATE (SPOUSE)^^I
"DATA",391.23,202,0)
SPOUSE'S RETIREMENT DATE^2^.2516^RETIREMENT DATE (SPOUSE)^^I
"DATA",391.23,203,0)
FILIPINO VETERAN PROOF^2^.3214^FILIPINO VETERAN PROOF^^I
"DATA",391.23,204,0)
SERVICE COMPONENT [LAST]^2^.32911^SERVICE COMPONENT (LAST)^^I
"DATA",391.23,205,0)
SERVICE COMPONENT [NTL]^2^.32912^SERVICE COMPONENT [NTL]^^I
"DATA",391.23,206,0)
SERVICE COMPONENT [NNTL]^2^.32913^SERVICE COMPONENT [NNTL]^^I
"DATA",391.23,207,0)
SOUTHWEST ASIA CONDITIONS^2^.322013^SOUTHWEST ASIA CONDITIONS^^I
"DATA",391.23,208,0)
SW ASIA COND REGISTRATION DATE^2^.322014^SW ASIA COND REGISTRATION DATE^^I
"DATA",391.23,209,0)
SW ASIA COND EXAM DATE^2^.322015^SW ASIA COND EXAM DATE^^I
"DATA",391.23,221,0)
PLACE OF BIRTH [CITY]^2^.092^PLACE OF BIRTH [CITY]^^I
"DATA",391.23,222,0)
PLACE OF BIRTH [STATE]^2^.093^PLACE OF BIRTH [STATE]^^I
"DATA",391.23,223,0)
MOTHER'S NAME^2^.2402^MOTHERS NAME^^I
"DATA",391.23,224,0)
MOTHER'S MAIDEN NAME^2^.2403^MOTHERS MAIDEN NAME^^I
"DATA",391.23,225,0)
MOST RECENT DATE OF CARE^2^1010.151^MOST RECENT DATE OF CARE^^I
"DATA",391.23,226,0)
MOST RECENT LOCATION OF CARE^2^1010.152^MOST RECENT LOCATION OF CARE^^I
"DATA",391.23,227,0)
2ND MOST RECENT DATE OF CARE^2^1010.153^2ND MOST RECENT DATE OF CARE^^I
"DATA",391.23,228,0)
2ND MOST RECENT LOCATION^2^1010.154^2ND MOST RECENT LOCATION^^I
"DATA",391.23,229,0)
SC AWARD DATE^2^.3012^SC AWARD DATE^^I
"DATA",391.23,230,0)
DATE RULED INCOMPETENT (CIVIL)^2^.292^DATE RULED INCOMPETENT (CIVIL)^^I
"DATA",391.23,231,0)
GI INSURANCE POLICY?^2^.36265^GI INSURANCE POLICY^^I
"DATA",391.23,232,0)
AMOUNT OF GI INSURANCE^2^.3626^AMOUNT OF GI INSURANCE^^I
"DATA",391.23,233,0)
INELIGIBLE TWX STATE^2^.1654^INELIGIBLE TWX STATE^0^I
"DATA",391.23,234,0)
INELIGIBLE VARO DECISION^2^.1656^INELIGIBLE VARO DECISION^^I
"DATA",391.23,235,0)
RELIGIOUS PREFERENCE^2^.08^RELIGIOUS PREFERENCE^^I
"DATA",391.23,236,0)
FATHER'S NAME^2^.2401^RELIGIOUS PREFERENCE^^I
"DATA",391.23,244,0)
SERVICE DENTAL INJURY?^2^.368^SERVICE DENTAL INJURY^^I
"DATA",391.23,245,0)
SERVICE TEETH EXTRACTED?^2^.369^SERVICE TEETH EXTRACTED^^I
"DATA",391.23,246,0)
DATE OF DENTAL TREATMENT^2.11^.01^DENTAL TRMT MULTIPLE SUB-FILE^^S
"DATA",391.23,247,0)
RATED INCOMPETENT (Y/N)^2^.293^RATED INCOMPETENT^^I
"DATA",391.23,248,0)
INELIGIBLE TWX CITY^2^.1653^INELIGIBLE TWX CITY^0^I
"DATA",391.23,249,0)
SPINAL CORD INJURY^2^57.4^SPINAL CORD INJURY^^I
"DATA",391.23,250,0)
TEMPORARY ADDRESS CHANGE DT/TM^2^.12113^TEMPORARY ADDR CHANGE DT/TM^^I
"DATA",391.23,251,0)
TEMPORARY ADDR CHANGE SITE^2^.12114^TEMPORARY ADDR CHANGE SITE^^I
"DATA",391.23,252,0)
CONFIDENTIAL ADDR CHANGE DT/TM^2^.14112^CONFIDENTIAL ADDR CHANGE DT/TM^^I
"DATA",391.23,253,0)
CONFIDENTIAL ADDR CHANGE SITE^2^.14113^CONFIDENTIAL ADDR CHANGE SITE^^I
"DATA",391.23,254,0)
INELIGIBLE TWX SOURCE^2^.1651^INELIGIBLE TWX SOURCE^0^I
"DATA",391.23,255,0)
INELIGIBLE DATE^2^.152^INELIGIBLE DATE^^I
"DATA",391.23,256,0)
INELIGIBLE REASON^2^.307^INELIGIBLE REASON^^I
"DATA",391.23,257,0)
DENTAL CONDITION^2.11^2^DENTAL CONDITION^^S
"DATA",391.23,258,0)
DENTAL CONDITION FIRST NOTICED^2.11^3^DENTAL CONDITION FIRST NOTICED^^S
"DATA",391.23,259,0)
RECEIVED VA CARE PREVIOUSLY?^2^1010.15^RECEIVED VA CARE PREVIOUSLY?^^I
"DATA",391.23,260,0)
CONFIDENTIAL PHONE NUMBER^2^.1315^CONFIDENTIAL PHONE^^I
"FIA",2)
PATIENT
"FIA",2,0)
^DPT(
"FIA",2,0,0)
2I
"FIA",2,0,1)
y^y^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,.03)

"FIA",2,2,.119)

"FIA",2,2,.1311)

"FIA",2,2,.1313)

"FIA",2,2,.1315)

"FIA",2,2,.137)

"FIA",2,2,.14112)

"FIA",2,2,.152)

"FIA",2,2,.21011)

"FIA",2,2,.211011)

"FIA",2,2,.211012)

"FIA",2,2,.219)

"FIA",2,2,.2199)

"FIA",2,2,.291)

"FIA",2,2,.292)

"FIA",2,2,.3013)

"FIA",2,2,.33011)

"FIA",2,2,.33012)

"FIA",2,2,.331011)

"FIA",2,2,.33112)

"FIA",2,2,.3319)

"FIA",2,2,.339)

"FIA",2,2,.34011)

"FIA",2,2,.3412)

"FIA",2,2,.349)

"FIA",2,2,.351)

"FIA",27.11)
PATIENT ENROLLMENT
"FIA",27.11,0)
^DGEN(27.11,
"FIA",27.11,0,0)
27.11OID
"FIA",27.11,0,1)
y^n^p^^^^n^^n
"FIA",27.11,0,10)

"FIA",27.11,0,11)

"FIA",27.11,0,"RLRO")

"FIA",27.11,0,"VR")
5.3^DG
"FIA",27.11,27.11)
1
"FIA",27.11,27.11,.01)

"FIA",43)
MAS PARAMETERS
"FIA",43,0)
^DG(43,
"FIA",43,0,0)
43
"FIA",43,0,1)
y^y^p^^^^n^^n
"FIA",43,0,10)

"FIA",43,0,11)

"FIA",43,0,"RLRO")

"FIA",43,0,"VR")
5.3^DG
"FIA",43,43)
1
"FIA",43,43,1301)

"FIA",43,43,1302)

"FIA",391.23)
DG REGISTER ONCE FIELD DEFINITION
"FIA",391.23,0)
^DGRO(391.23,
"FIA",391.23,0,0)
391.23
"FIA",391.23,0,1)
y^y^f^^n^^y^r^n
"FIA",391.23,0,10)

"FIA",391.23,0,11)

"FIA",391.23,0,"RLRO")

"FIA",391.23,0,"VR")
5.3^DG
"FIA",391.23,391.23)
0
"FIA",408.13)
INCOME PERSON
"FIA",408.13,0)
^DGPR(408.13,
"FIA",408.13,0,0)
408.13
"FIA",408.13,0,1)
y^y^p^^^^n^^n
"FIA",408.13,0,10)

"FIA",408.13,0,11)

"FIA",408.13,0,"RLRO")

"FIA",408.13,0,"VR")
5.3^DG
"FIA",408.13,408.13)
1
"FIA",408.13,408.13,1.2)

"FIA",408.13,408.13,1.3)

"FIA",408.13,408.13,1.4)

"FIA",408.13,408.13,1.5)

"FIA",408.13,408.13,1.6)

"FIA",408.13,408.13,1.7)

"FIA",408.13,408.13,1.8)

"FIA",408.13,408.13,1.9)

"INI")
EP^DG53754P
"INIT")
EN^DG53754B
"IX",2,2,"ADGFM351",0)
2^ADGFM351^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFM351",.1,0)
^^5^5^3020624
"IX",2,2,"ADGFM351",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFM351",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFM351",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFM351",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFM351",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFM351",1)
D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFM351",2)
D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFM351",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFM351",11.1,1,0)
1^F^2^.351^^^F
"IX",2,2,"ADGFMD03",0)
2^ADGFMD03^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD03",.1,0)
^^5^5^3021116
"IX",2,2,"ADGFMD03",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD03",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD03",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD03",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD03",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD03",1)
D FC^DGFCPROT(.DA,2,.03,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD03",2)
D FC^DGFCPROT(.DA,2,.03,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD03",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD03",11.1,1,0)
1^F^2^.03^^^F
"IX",2,2,"ADGFMD1315",0)
2^ADGFMD1315^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD1315",.1,0)
^^6^6^3080811^
"IX",2,2,"ADGFMD1315",.1,1,0)
This cross reference activates the DG FIELD MONITOR event
"IX",2,2,"ADGFMD1315",.1,2,0)
point. Applications that wish to monitor edit activity
"IX",2,2,"ADGFMD1315",.1,3,0)
related to this field may subscribe to that event point and
"IX",2,2,"ADGFMD1315",.1,4,0)
take action as indicated by the changes that occur.  Refer
"IX",2,2,"ADGFMD1315",.1,5,0)
to the DG FIELD MONITOR protocol for a description of the
"IX",2,2,"ADGFMD1315",.1,6,0)
information available at the time of the event.
"IX",2,2,"ADGFMD1315",1)
D FC^DGFCPROT(.DA,2,.1315,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1315",2)
D FC^DGFCPROT(.DA,2,.1315,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1315",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD1315",11.1,1,0)
1^F^2^.1315^^^F
"IX",2,2,"ADGFMD351",0)
2^ADGFMD351^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD351",.1,0)
^^5^5^3020820
"IX",2,2,"ADGFMD351",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD351",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD351",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD351",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD351",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD351",1)
D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD351",2)
D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD351",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD351",11.1,1,0)
1^F^2^.351^^^F
"IX",2,2,"ADTTM2",0)
2^ADTTM2^CONFIDENTIAL ADDRESS Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM2",.1,0)
^^2^2^3080811^^
"IX",2,2,"ADTTM2",.1,1,0)
This cross-reference will update the CONFIDENTIAL ADDR CHANGE DT/TM field
"IX",2,2,"ADTTM2",.1,2,0)
when the confidential address data changes for a patient.
"IX",2,2,"ADTTM2",1)
D CONF^DGDDDTTM
"IX",2,2,"ADTTM2",2)
D CONF^DGDDDTTM
"IX",2,2,"ADTTM2",11.1,0)
^.114IA^14^14
"IX",2,2,"ADTTM2",11.1,1,0)
1^F^2^.1411^^^F
"IX",2,2,"ADTTM2",11.1,2,0)
2^F^2^.1412^^^F
"IX",2,2,"ADTTM2",11.1,3,0)
3^F^2^.1413^^^F
"IX",2,2,"ADTTM2",11.1,4,0)
4^F^2^.1414^^^F
"IX",2,2,"ADTTM2",11.1,5,0)
5^F^2^.1415^^^F
"IX",2,2,"ADTTM2",11.1,6,0)
6^F^2^.1416^^^F
"IX",2,2,"ADTTM2",11.1,7,0)
7^F^2^.1417^^^F
"IX",2,2,"ADTTM2",11.1,8,0)
8^F^2^.1418^^^F
"IX",2,2,"ADTTM2",11.1,9,0)
9^F^2^.14105^^^F
"IX",2,2,"ADTTM2",11.1,10,0)
10^F^2^.14114^^^F
"IX",2,2,"ADTTM2",11.1,11,0)
11^F^2^.14115^^^F
"IX",2,2,"ADTTM2",11.1,12,0)
12^F^2^.14116^^^F
"IX",2,2,"ADTTM2",11.1,13,0)
13^F^2^.14111^^^F
"IX",2,2,"ADTTM2",11.1,14,0)
14^F^2^.1315^^^F
"IX",2,2,"ADTTM2",11.1,14,3)

"IX",2,2,"ADTTM3",0)
2^ADTTM3^PRIMARY NOK Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM3",.1,0)
^^2^2^3050813
"IX",2,2,"ADTTM3",.1,1,0)
This cross-reference will update the PRIMARY NOK CHANGE DATE/TIME field
"IX",2,2,"ADTTM3",.1,2,0)
when the Primary Next of Kin data changes for a patient.
"IX",2,2,"ADTTM3",1)
D PNOK^DGDDDTTM
"IX",2,2,"ADTTM3",2)
D PNOK^DGDDDTTM
"IX",2,2,"ADTTM3",11.1,0)
^.114IA^12^12
"IX",2,2,"ADTTM3",11.1,1,0)
1^F^2^.211^^^F
"IX",2,2,"ADTTM3",11.1,2,0)
2^F^2^.212^^^F
"IX",2,2,"ADTTM3",11.1,3,0)
3^F^2^.213^^^F
"IX",2,2,"ADTTM3",11.1,4,0)
4^F^2^.214^^^F
"IX",2,2,"ADTTM3",11.1,5,0)
5^F^2^.215^^^F
"IX",2,2,"ADTTM3",11.1,6,0)
6^F^2^.216^^^F
"IX",2,2,"ADTTM3",11.1,7,0)
7^F^2^.217^^^F
"IX",2,2,"ADTTM3",11.1,8,0)
8^F^2^.218^^^F
"IX",2,2,"ADTTM3",11.1,9,0)
9^F^2^.2125^^^F
"IX",2,2,"ADTTM3",11.1,10,0)
10^F^2^.2207^^^F
"IX",2,2,"ADTTM3",11.1,11,0)
11^F^2^.219^^^F
"IX",2,2,"ADTTM3",11.1,12,0)
12^F^2^.21011^^^F
"IX",2,2,"ADTTM4",0)
2^ADTTM4^SECONDARY NOK Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM4",.1,0)
^^2^2^3050830
"IX",2,2,"ADTTM4",.1,1,0)
This cross-reference will update the SECONDARY NOK CHANGE DATE/TIME field
"IX",2,2,"ADTTM4",.1,2,0)
when the Secondary Next of Kin data changes for a patient.
"IX",2,2,"ADTTM4",1)
D SNOK^DGDDDTTM
"IX",2,2,"ADTTM4",2)
D SNOK^DGDDDTTM
"IX",2,2,"ADTTM4",11.1,0)
^.114IA^12^12
"IX",2,2,"ADTTM4",11.1,1,0)
1^F^2^.2191^^^F
"IX",2,2,"ADTTM4",11.1,2,0)
2^F^2^.2192^^^F
"IX",2,2,"ADTTM4",11.1,3,0)
3^F^2^.2193^^^F
"IX",2,2,"ADTTM4",11.1,4,0)
4^F^2^.2194^^^F
"IX",2,2,"ADTTM4",11.1,5,0)
5^F^2^.2195^^^F
"IX",2,2,"ADTTM4",11.1,6,0)
6^F^2^.2196^^^F
"IX",2,2,"ADTTM4",11.1,7,0)
7^F^2^.2197^^^F
"IX",2,2,"ADTTM4",11.1,8,0)
8^F^2^.2198^^^F
"IX",2,2,"ADTTM4",11.1,9,0)
9^F^2^.21925^^^F
"IX",2,2,"ADTTM4",11.1,10,0)
10^F^2^.2203^^^F
"IX",2,2,"ADTTM4",11.1,11,0)
11^F^2^.2199^^^F
"IX",2,2,"ADTTM4",11.1,12,0)
12^F^2^.211011^^^F
"IX",2,2,"ADTTM5",0)
2^ADTTM5^E-CONTACT Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM5",.1,0)
^^2^2^3050813
"IX",2,2,"ADTTM5",.1,1,0)
This cross-reference will update the E-CONTACT CHANGE DATE/TIME field when
"IX",2,2,"ADTTM5",.1,2,0)
the Emergency Contact data changes for a patient.
"IX",2,2,"ADTTM5",1)
D ECON^DGDDDTTM
"IX",2,2,"ADTTM5",2)
D ECON^DGDDDTTM
"IX",2,2,"ADTTM5",11.1,0)
^.114IA^12^12
"IX",2,2,"ADTTM5",11.1,1,0)
1^F^2^.331^^^F
"IX",2,2,"ADTTM5",11.1,2,0)
2^F^2^.332^^^F
"IX",2,2,"ADTTM5",11.1,3,0)
3^F^2^.333^^^F
"IX",2,2,"ADTTM5",11.1,4,0)
4^F^2^.334^^^F
"IX",2,2,"ADTTM5",11.1,5,0)
5^F^2^.335^^^F
"IX",2,2,"ADTTM5",11.1,6,0)
6^F^2^.336^^^F
"IX",2,2,"ADTTM5",11.1,6,3)

"IX",2,2,"ADTTM5",11.1,7,0)
7^F^2^.337^^^F
"IX",2,2,"ADTTM5",11.1,8,0)
8^F^2^.338^^^F
"IX",2,2,"ADTTM5",11.1,9,0)
9^F^2^.3305^^^F
"IX",2,2,"ADTTM5",11.1,10,0)
10^F^2^.2201^^^F
"IX",2,2,"ADTTM5",11.1,11,0)
11^F^2^.339^^^F
"IX",2,2,"ADTTM5",11.1,11,3)

"IX",2,2,"ADTTM5",11.1,12,0)
12^F^2^.33011^^^F
"IX",2,2,"ADTTM5",11.1,12,3)

"IX",2,2,"ADTTM6",0)
2^ADTTM6^E2-CONTACT Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM6",.1,0)
^^2^2^3050830
"IX",2,2,"ADTTM6",.1,1,0)
This cross-reference will update the E2-CONTACT CHANGE DATE/TIME field
"IX",2,2,"ADTTM6",.1,2,0)
when the Secondary Emergency Contact data changes for a patient.
"IX",2,2,"ADTTM6",1)
D ECON2^DGDDDTTM
"IX",2,2,"ADTTM6",2)
D ECON2^DGDDDTTM
"IX",2,2,"ADTTM6",11.1,0)
^.114IA^11^11
"IX",2,2,"ADTTM6",11.1,1,0)
1^F^2^.3311^^^F
"IX",2,2,"ADTTM6",11.1,2,0)
2^F^2^.3312^^^F
"IX",2,2,"ADTTM6",11.1,3,0)
3^F^2^.3313^^^F
"IX",2,2,"ADTTM6",11.1,4,0)
4^F^2^.3314^^^F
"IX",2,2,"ADTTM6",11.1,5,0)
5^F^2^.3315^^^F
"IX",2,2,"ADTTM6",11.1,6,0)
6^F^2^.3316^^^F
"IX",2,2,"ADTTM6",11.1,7,0)
7^F^2^.3317^^^F
"IX",2,2,"ADTTM6",11.1,8,0)
8^F^2^.3318^^^F
"IX",2,2,"ADTTM6",11.1,9,0)
9^F^2^.2204^^^F
"IX",2,2,"ADTTM6",11.1,10,0)
10^F^2^.3319^^^F
"IX",2,2,"ADTTM6",11.1,11,0)
11^F^2^.331011^^^F
"IX",2,2,"ADTTM7",0)
2^ADTTM7^DESIGNEE Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM7",.1,0)
^^2^2^3050813
"IX",2,2,"ADTTM7",.1,1,0)
This cross-reference will update the DESIGNEE CHANGE DATE/TIME field when
"IX",2,2,"ADTTM7",.1,2,0)
the Designee data changes for a patient.
"IX",2,2,"ADTTM7",1)
D DESIG^DGDDDTTM
"IX",2,2,"ADTTM7",2)
D DESIG^DGDDDTTM
"IX",2,2,"ADTTM7",11.1,0)
^.114IA^12^12
"IX",2,2,"ADTTM7",11.1,1,0)
1^F^2^.341^^^F
"IX",2,2,"ADTTM7",11.1,2,0)
2^F^2^.342^^^F
"IX",2,2,"ADTTM7",11.1,3,0)
3^F^2^.343^^^F
"IX",2,2,"ADTTM7",11.1,4,0)
4^F^2^.344^^^F
"IX",2,2,"ADTTM7",11.1,5,0)
5^F^2^.345^^^F
"IX",2,2,"ADTTM7",11.1,6,0)
6^F^2^.346^^^F
"IX",2,2,"ADTTM7",11.1,7,0)
7^F^2^.347^^^F
"IX",2,2,"ADTTM7",11.1,8,0)
8^F^2^.348^^^F
"IX",2,2,"ADTTM7",11.1,9,0)
9^F^2^.3405^^^F
"IX",2,2,"ADTTM7",11.1,10,0)
10^F^2^.2202^^^F
"IX",2,2,"ADTTM7",11.1,11,0)
11^F^2^.349^^^F
"IX",2,2,"ADTTM7",11.1,12,0)
12^F^2^.34011^^^F
"IX",391.23,391.23,"C",0)
391.23^C^Cross reference on File and Field numbers^R^^R^IR^I^391.23^^^^^LS
"IX",391.23,391.23,"C",1)
S ^DGRO(391.23,"C",X(1),X(2),DA)=""
"IX",391.23,391.23,"C",2)
K ^DGRO(391.23,"C",X(1),X(2),DA)
"IX",391.23,391.23,"C",2.5)
K ^DGRO(391.23,"C")
"IX",391.23,391.23,"C",11.1,0)
^.114IA^2^2
"IX",391.23,391.23,"C",11.1,1,0)
1^F^391.23^1^^1^F
"IX",391.23,391.23,"C",11.1,2,0)
2^F^391.23^2^^2^F
"IX",391.23,391.23,"E",0)
391.23^E^Index on File Number, Field Number, and Order Index.^R^^R^IR^I^391.23^^^^^LS
"IX",391.23,391.23,"E",.1,0)
^^4^4^3040413^^
"IX",391.23,391.23,"E",.1,1,0)
This index cross references FILE NUMBER, FIELD NUMBER, and ORDER INDEX.
"IX",391.23,391.23,"E",.1,2,0)
It is used by ROM code to return the ORDER INDEX when given the FILE
"IX",391.23,391.23,"E",.1,3,0)
NUMBER and FIELD NUMBER.  It speeds up the filing of data at the Register
"IX",391.23,391.23,"E",.1,4,0)
Once Messaging Querying Site.
"IX",391.23,391.23,"E",1)
S ^DGRO(391.23,"E",X(1),X(2),$E(X(3),1,30),DA)=""
"IX",391.23,391.23,"E",2)
K ^DGRO(391.23,"E",X(1),X(2),$E(X(3),1,30),DA)
"IX",391.23,391.23,"E",2.5)
K ^DGRO(391.23,"E")
"IX",391.23,391.23,"E",11.1,0)
^.114IA^3^3
"IX",391.23,391.23,"E",11.1,1,0)
1^F^391.23^1^^1^F
"IX",391.23,391.23,"E",11.1,2,0)
2^F^391.23^2^^2^F
"IX",391.23,391.23,"E",11.1,3,0)
3^F^391.23^5^30^3^F
"MBREQ")
0
"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)
754^3110201
"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")
YES
"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")
36
"RTN","DG53754A")
0^30^B1497395
"RTN","DG53754A",1,0)
DG53754A ;ALB/TDM - Patch DG*5.3*754 Pre-Install Utility Routine ; 6/8/09 11:36am
"RTN","DG53754A",2,0)
 ;;5.3;Registration;**754**;AUG 13, 1993;Build 46
"RTN","DG53754A",3,0)
 ;
"RTN","DG53754A",4,0)
 Q
"RTN","DG53754A",5,0)
START ;Entry point for field definition cleanup
"RTN","DG53754A",6,0)
 N X,DGFIL,DGFLD,MSG
"RTN","DG53754A",7,0)
 ;
"RTN","DG53754A",8,0)
 D BMES^XPDUTL(">> Starting field definition cleanup...")
"RTN","DG53754A",9,0)
 S DGFIL=2 D HEADER F DGFLD=.03,.152,.351 D DELETE(DGFIL,DGFLD)
"RTN","DG53754A",10,0)
 D BMES^XPDUTL(">> Field definition cleanup completed")
"RTN","DG53754A",11,0)
 Q
"RTN","DG53754A",12,0)
 ;
"RTN","DG53754A",13,0)
HEADER ;Display file name & #
"RTN","DG53754A",14,0)
 S MSG=">> "_$P($G(^DIC(DGFIL,0)),U,1)_" File (#"_DGFIL_")"
"RTN","DG53754A",15,0)
 D BMES^XPDUTL(MSG)
"RTN","DG53754A",16,0)
 Q
"RTN","DG53754A",17,0)
 ;
"RTN","DG53754A",18,0)
DELETE(DGFIL,DGFLD) ;The procedure will delete the field definition from the Data Dictionary
"RTN","DG53754A",19,0)
 ;    DGFIL  - DD File Number (Required)
"RTN","DG53754A",20,0)
 ;    DGFLD  - DD Field Number (Required)
"RTN","DG53754A",21,0)
 ;
"RTN","DG53754A",22,0)
 Q:($G(DGFIL)=""!$G(DGFLD)="")
"RTN","DG53754A",23,0)
 N DIK,DA,DGFLDNM
"RTN","DG53754A",24,0)
 ;
"RTN","DG53754A",25,0)
 S DIK="^DD("_DGFIL_","
"RTN","DG53754A",26,0)
 S DA=DGFLD,DA(1)=DGFIL
"RTN","DG53754A",27,0)
 S DGFLDNM=$P($G(^DD(DGFIL,DGFLD,0)),U,1)
"RTN","DG53754A",28,0)
 S MSG="   Updating the '"_DGFLDNM_"' field (#"_DGFLD_") definition"
"RTN","DG53754A",29,0)
 D MES^XPDUTL(MSG)
"RTN","DG53754A",30,0)
 D ^DIK
"RTN","DG53754A",31,0)
 Q
"RTN","DG53754B")
0^37^B1383730
"RTN","DG53754B",1,0)
DG53754B ;ALB/TDM - POST-INSTALL DG*5.3*754 ; 12/16/10 9:53am
"RTN","DG53754B",2,0)
 ;;5.3;Registration;**754**;Aug 13, 1993;Build 46
"RTN","DG53754B",3,0)
 Q
"RTN","DG53754B",4,0)
EN ;Post-install entry point
"RTN","DG53754B",5,0)
 N X,Y,DMAX,ZTMP
"RTN","DG53754B",6,0)
 S DMAX=$$ROUSIZE^DILF
"RTN","DG53754B",7,0)
 D BMES^XPDUTL("Re-compiling input templates")
"RTN","DG53754B",8,0)
 D ADDPTID
"RTN","DG53754B",9,0)
 D RECOMP("DG LOAD EDIT SCREEN 7","DGRPX7")
"RTN","DG53754B",10,0)
 Q
"RTN","DG53754B",11,0)
 ;
"RTN","DG53754B",12,0)
RECOMP(ZTMP,X) ;Recompile Input Templates
"RTN","DG53754B",13,0)
 Q:((ZTMP="")!(X=""))
"RTN","DG53754B",14,0)
 S Y=$$FIND1^DIC(.402,"","MX",ZTMP)
"RTN","DG53754B",15,0)
 I Y<0 D BMES^XPDUTL("Error re-compiling '"_ZTMP_"' input template") Q
"RTN","DG53754B",16,0)
 D EN^DIEZ
"RTN","DG53754B",17,0)
 D BMES^XPDUTL("' "_ZTMP_"' input template has been re-compiled.")
"RTN","DG53754B",18,0)
 Q
"RTN","DG53754B",19,0)
 ;
"RTN","DG53754B",20,0)
ADDPTID ; DBIA #4139 - This is a one-time agreement to allow Registration to
"RTN","DG53754B",21,0)
 ; set the IDENTIFIER node as follows for the PATIENT (#2) file:
"RTN","DG53754B",22,0)
 ; ^DD(2,0,"ID",.03)="D EN^DDIOL($TR($$DOB^DPTLK1(Y,1),""/"",""-""),,""?$X+2"")"
"RTN","DG53754B",23,0)
 ; 
"RTN","DG53754B",24,0)
 ; This api will add the IDENTIFIER parameter back to the PATIENT
"RTN","DG53754B",25,0)
 ; file (#2).  It was an unknown fact that the IDENTIFIER parameter
"RTN","DG53754B",26,0)
 ; would be removed when the DG*5.3*754 pre-init routine (DG53754P)
"RTN","DG53754B",27,0)
 ; initialized the field definition for the DATE OF BIRTH field (#.03)
"RTN","DG53754B",28,0)
 ; from the PATIENT file (#2).
"RTN","DG53754B",29,0)
 ;
"RTN","DG53754B",30,0)
 S ^DD(2,0,"ID",.03)="D EN^DDIOL($TR($$DOB^DPTLK1(Y,1),"_"""/"""_","_"""-"""_"),,"_"""?$X+2"""_")"
"RTN","DG53754B",31,0)
 Q
"RTN","DG53754C")
0^27^B14090704
"RTN","DG53754C",1,0)
DG53754C ;ALB/TDM - Patch DG*5.3*754 Install Utility Routine ; 7/6/10 3:55pm
"RTN","DG53754C",2,0)
 ;;5.3;Registration;**754**;AUG 13, 1993;Build 46
"RTN","DG53754C",3,0)
 Q
"RTN","DG53754C",4,0)
 ;
"RTN","DG53754C",5,0)
EP ; Continuation of DG53754P post install routine.
"RTN","DG53754C",6,0)
 F I=1:1 S ELEMNT=$P($T(TEXT+I),";;",2) Q:ELEMNT="QUIT"!(ABORT)  D
"RTN","DG53754C",7,0)
 . S EXIST=0
"RTN","DG53754C",8,0)
 . K DGDATA S (DATA,SUB)="" F J=1:1:$L(ELEMNT,";") S DATA=$P(ELEMNT,";",J) D  Q:EXIST
"RTN","DG53754C",9,0)
 . . S SUB=$P(DATA,"~",1),VALUE=$P(DATA,"~",2),DGDATA(SUB)=VALUE
"RTN","DG53754C",10,0)
 . . I SUB=.01 S EXIST=$$FIND1^DIC(FILE,,,DGDATA(.01))
"RTN","DG53754C",11,0)
 . I 'EXIST D
"RTN","DG53754C",12,0)
 . . S FILEFLG=$$ADD^DGENDBS(FILE,,.DGDATA)
"RTN","DG53754C",13,0)
 . . I FILEFLG D MES^XPDUTL("Added - "_$G(DGDATA(.01)))
"RTN","DG53754C",14,0)
 . . I 'FILEFLG D
"RTN","DG53754C",15,0)
 . . . S ABORT=1,XPDABORT=2
"RTN","DG53754C",16,0)
 . . . D BMES^XPDUTL("Install process could not add an entry in file for "_$G(DGDATA(.01)))
"RTN","DG53754C",17,0)
 . . . D BMES^XPDUTL("                        <<<< INSTALLATION ABORTED >>>>")
"RTN","DG53754C",18,0)
 Q
"RTN","DG53754C",19,0)
 ;
"RTN","DG53754C",20,0)
TEXT ;;FIELD#~VALUE;FIELD#~VALUE;FIELD#~VALUE.....
"RTN","DG53754C",21,0)
 ;;.01~SPOUSE'S EMPLOYMENT STATUS;.02~ZEM03S;.03~1;.04~2;.05~.2515;.06~1;.08~0;10~S DR=.2515 D LOOK^IVMPREC9;20~S DR=.2515,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754C",22,0)
 ;;.01~SPOUSE'S EMPLOYER NAME;.02~ZEM04S;.03~1;.04~2;.05~.251;.08~0;10~S DR=.251 D LOOK^IVMPREC9;20~S DR=.251 D LOOK^IVMPREC9
"RTN","DG53754C",23,0)
 ;;.01~SPOUSE'S OCCUPATION;.02~ZEM05S;.03~1;.04~2;.05~.2514;.08~0;10~S DR=.2514 D LOOK^IVMPREC9;20~S DR=.2514 D LOOK^IVMPREC9
"RTN","DG53754C",24,0)
 ;;.01~SPOUSE'S EMPLOYER ADDR LINE 1;.02~ZEM061S;.03~1;.04~2;.05~.252;.08~0;10~S DR=.252 D LOOK^IVMPREC9;20~S DR=.252 D LOOK^IVMPREC9
"RTN","DG53754C",25,0)
 ;;.01~SPOUSE'S EMPLOYER ADDR LINE 2;.02~ZEM062S;.03~1;.04~2;.05~.253;.08~0;10~S DR=.253 D LOOK^IVMPREC9;20~S DR=.253 D LOOK^IVMPREC9
"RTN","DG53754C",26,0)
 ;;.01~SPOUSE'S EMPLOYER ADDR LINE 3;.02~ZEM068S;.03~1;.04~2;.05~.254;.08~0;10~S DR=.254 D LOOK^IVMPREC9;20~S DR=.254 D LOOK^IVMPREC9
"RTN","DG53754C",27,0)
 ;;.01~SPOUSE'S EMPLOYER CITY;.02~ZEM063S;.03~1;.04~2;.05~.255;.08~0;10~S DR=.255 D LOOK^IVMPREC9;20~S DR=.255 D LOOK^IVMPREC9
"RTN","DG53754C",28,0)
 ;;.01~SPOUSE'S EMPLOYER STATE;.02~ZEM064S;.03~1;.04~2;.05~.256;.06~1;.08~0;10~S DR=.256 D LOOK^IVMPREC9;20~S DR=.256,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754C",29,0)
 ;;.01~SPOUSE'S EMPLOYER ZIP;.02~ZEM065S;.03~1;.04~2;.05~.257;.08~0;10~S DR=.257 D LOOK^IVMPREC9;20~S DR=.257 D LOOK^IVMPREC9
"RTN","DG53754C",30,0)
 ;;.01~SPOUSE'S EMPLOYER TELEPHONE;.02~ZEM07S;.03~1;.04~2;.05~.258;.08~0;10~S DR=.258 D LOOK^IVMPREC9;20~S DR=.258 D LOOK^IVMPREC9
"RTN","DG53754C",31,0)
 ;;.01~SPOUSE'S RETIREMENT DATE;.02~ZEM09S;.03~1;.04~2;.05~.2516;.06~1;.08~0;10~S DR=.2516 D LOOK^IVMPREC9;20~S DR=.2516,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754C",32,0)
 ;;.01~PHONE NUMBER [WORK];.02~PID13W;.03~1;.04~2;.05~.132;.08~0;10~S DR=.132 D LOOK^IVMPREC9;20~S DR=.132 D LOOK^IVMPREC9
"RTN","DG53754C",33,0)
 ;;QUIT
"RTN","DG53754C",34,0)
 ;;
"RTN","DG53754C",35,0)
 ;;The following have been disabled until further notice
"RTN","DG53754C",36,0)
 ;;.01~CONFIDENTIAL ADDR CHANGE SITE;.02~RF161CA;.03~1;.04~2;.05~.14113;.08~0;10~S DR=.14113 D LOOK^IVMPREC9;20~S DR=.14113 D LOOK^IVMPREC9
"RTN","DG53754C",37,0)
 ;;.01~CONFIDENTIAL ADDR CHANGE DT/TM;.02~RF171CA;.03~1;.04~2;.05~.14112;.08~0;10~S DR=.14112 D LOOK^IVMPREC9;20~S DR=.14112,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P")
0^26^B126007468
"RTN","DG53754P",1,0)
DG53754P ;ALB/TDM - Patch DG*5.3*754 Install Utility Routine ; 7/22/10 10:58am
"RTN","DG53754P",2,0)
 ;;5.3;Registration;**754**;AUG 13, 1993;Build 46
"RTN","DG53754P",3,0)
 Q
"RTN","DG53754P",4,0)
EP ;Entry point - Driver
"RTN","DG53754P",5,0)
 N ABORT,FILE,I,ELEMNT,EXIST,DGDATA,DATA,SUB,J,VALUE,FILEFLG
"RTN","DG53754P",6,0)
 ;
"RTN","DG53754P",7,0)
 D START^DG53754A    ;Run field definition clean-up per EVC_CR9102
"RTN","DG53754P",8,0)
 ;
"RTN","DG53754P",9,0)
 S (ABORT,FILEFLG)=0,FILE=301.92
"RTN","DG53754P",10,0)
 F I=1:1 S ELEMNT=$P($T(TEXT+I),";;",2) Q:ELEMNT="QUIT"!(ABORT)  D
"RTN","DG53754P",11,0)
 . S EXIST=0
"RTN","DG53754P",12,0)
 . K DGDATA S (DATA,SUB)="" F J=1:1:$L(ELEMNT,";") S DATA=$P(ELEMNT,";",J) D  Q:EXIST
"RTN","DG53754P",13,0)
 . . S SUB=$P(DATA,"~",1),VALUE=$P(DATA,"~",2),DGDATA(SUB)=VALUE
"RTN","DG53754P",14,0)
 . . I SUB=.01 S EXIST=$$FIND1^DIC(FILE,,,DGDATA(.01))
"RTN","DG53754P",15,0)
 . I 'EXIST D
"RTN","DG53754P",16,0)
 . . S FILEFLG=$$ADD^DGENDBS(FILE,,.DGDATA)
"RTN","DG53754P",17,0)
 . . I FILEFLG D MES^XPDUTL("Added - "_$G(DGDATA(.01)))
"RTN","DG53754P",18,0)
 . . I 'FILEFLG D
"RTN","DG53754P",19,0)
 . . . S ABORT=1,XPDABORT=2
"RTN","DG53754P",20,0)
 . . . D BMES^XPDUTL("Install process could not add an entry in file for "_$G(DGDATA(.01)))
"RTN","DG53754P",21,0)
 . . . D BMES^XPDUTL("                        <<<< INSTALLATION ABORTED >>>>")
"RTN","DG53754P",22,0)
 I 'ABORT D EP^DG53754C  ;Continuation due to routine size limit
"RTN","DG53754P",23,0)
 I 'ABORT D BMES^XPDUTL("<<<< Post Install Successful >>>>")
"RTN","DG53754P",24,0)
 Q
"RTN","DG53754P",25,0)
 ;
"RTN","DG53754P",26,0)
TEXT ;;FIELD#~VALUE;FIELD#~VALUE;FIELD#~VALUE.....
"RTN","DG53754P",27,0)
 ;;.01~MOTHER'S MAIDEN NAME;.02~PID06;.03~1;.04~2;.05~.2403;.08~0;10~S DR=.2403 D LOOK^IVMPREC9;20~S DR=.2403 D LOOK^IVMPREC9
"RTN","DG53754P",28,0)
 ;;.01~RACE;.02~PID10;.03~1;.04~2;.05~2;.08~0;10~S Y=$P(VADM(12),"^");20~S Y=$P(VADM(12),"^",2)
"RTN","DG53754P",29,0)
 ;;.01~MARITAL STATUS;.02~PID16;.03~1;.04~2;.05~.05;.06~1;.08~0;10~S Y=$P(VADM(10),"^");20~S Y=$P(VADM(10),"^",2)
"RTN","DG53754P",30,0)
 ;;.01~RELIGION;.02~PID17;.03~1;.04~2;.05~.08;.06~1;.08~0;10~S Y=$P(VADM(9),"^");20~S Y=$P(VADM(9),"^",2)
"RTN","DG53754P",31,0)
 ;;.01~ETHNICITY;.02~PID22;.03~1;.04~2;.05~6;.06~1;.08~0;10~S Y=$P($G(VADM(11,1)),"^");20~S Y=$P($G(VADM(11,1)),"^",2)
"RTN","DG53754P",32,0)
 ;;.01~SPINAL CORD INJURY;.02~ZPD30;.03~0;.04~2;.05~57.4;.08~0;10~S DR=57.4 D LOOK^IVMPREC9;20~S DR=57.4,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",33,0)
 ;;.01~PSEUDO SSN REASON;.02~ZPD34;.03~1;.04~2;.05~.0906;.08~0;10~S DR=.0906 D LOOK^IVMPREC9;20~S DR=.0906,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",34,0)
 ;;.01~TEMPORARY ADDRESS ACTIVE;.02~ZTA02;.03~1;.04~2;.05~.12105;.08~0;10~S DR=.12105 D LOOK^IVMPREC9;20~S DR=.12105 D LOOK^IVMPREC9
"RTN","DG53754P",35,0)
 ;;.01~TEMPORARY ADDRESS BEGIN DATE;.02~ZTA03;.03~1;.04~2;.05~.1217;.06~1;.08~0;10~S DR=.1217 D LOOK^IVMPREC9;20~S DR=.1217,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",36,0)
 ;;.01~TEMPORARY ADDRESS END DATE;.02~ZTA04;.03~1;.04~2;.05~.1218;.06~1;.08~0;10~S DR=.1218 D LOOK^IVMPREC9;20~S DR=.1218,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",37,0)
 ;;.01~TEMPORARY ADDRESS [LINE] 1;.02~ZTA051;.03~1;.04~2;.05~.1211;.08~0;10~S DR=.1211 D LOOK^IVMPREC9;20~S DR=.1211 D LOOK^IVMPREC9
"RTN","DG53754P",38,0)
 ;;.01~TEMPORARY ADDRESS [LINE] 2;.02~ZTA052;.03~1;.04~2;.05~.1212;.08~0;10~S DR=.1212 D LOOK^IVMPREC9;20~S DR=.1212 D LOOK^IVMPREC9
"RTN","DG53754P",39,0)
 ;;.01~TEMPORARY ADDRESS [LINE] 3;.02~ZTA058;.03~1;.04~2;.05~.1213;.08~0;10~S DR=.1213 D LOOK^IVMPREC9;20~S DR=.1213 D LOOK^IVMPREC9
"RTN","DG53754P",40,0)
 ;;.01~TEMPORARY ADDRESS CITY;.02~ZTA053;.03~1;.04~2;.05~.1214;.08~0;10~S DR=.1214 D LOOK^IVMPREC9;20~S DR=.1214 D LOOK^IVMPREC9
"RTN","DG53754P",41,0)
 ;;.01~TEMPORARY ADDRESS STATE;.02~ZTA054;.03~1;.04~2;.05~.1215;.06~1;.08~0;10~S DR=.1215 D LOOK^IVMPREC9;20~S DR=.1215,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",42,0)
 ;;.01~TEMPORARY ADDRESS ZIP;.02~ZTA055;.03~1;.04~2;.05~.1216;.08~0;10~S DR=.1216 D LOOK^IVMPREC9;S DR=.1216 D LOOK^IVMPREC9
"RTN","DG53754P",43,0)
 ;;.01~TEMPORARY ADDRESS COUNTRY;.02~ZTA056;.03~1;.04~2;.05~.1223;.06~1;.08~0;10~S DR=.1223 D LOOK^IVMPREC9;S DR=.1223,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",44,0)
 ;;.01~TEMPORARY ADDRESS COUNTY;.02~ZTA059;.03~1;.04~2;.05~.12111;.06~1;.08~0;10~S DR=.12111 D LOOK^IVMPREC9;S DR=.12111 D LOOK^IVMPREC9
"RTN","DG53754P",45,0)
 ;;.01~TEMPORARY ADDRESS PROVINCE;.02~ZTA054F;.03~1;.04~2;.05~.1221;.08~0;10~S DR=.1221 D LOOK^IVMPREC9;20~S DR=.1221 D LOOK^IVMPREC9"
"RTN","DG53754P",46,0)
 ;;.01~TEMPORARY ADDRESS POSTAL CODE;.02~ZTA055F;.03~1;.04~2;.05~.1222;.08~0;10~S DR=.1222 D LOOK^IVMPREC9;20~S DR=.1222 D LOOK^IVMPREC9"
"RTN","DG53754P",47,0)
 ;;.01~TEMPORARY ADDRESS TELEPHONE;.02~ZTA07;.03~1;.04~2;.05~.1219;.08~0;10~S DR=.1219 D LOOK^IVMPREC9;20~S DR=.1219 D LOOK^IVMPREC9
"RTN","DG53754P",48,0)
 ;;.01~TEMP ADDR LAST UPDATED DT/TM;.02~ZTA08;.03~1;.04~2;.05~.12113;.06~1;.08~0;10~S DR=.12113 D LOOK^IVMPREC9;20~S DR=.12113,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",49,0)
 ;;.01~TEMP ADDR LAST UPDATED SITE;.02~ZTA09;.03~1;.04~2;.05~.12114;.06~1;.08~0;10~S DR=.12114 D LOOK^IVMPREC9;20~S DR=.12114 D LOOK^IVMPREC9
"RTN","DG53754P",50,0)
 ;;.01~E-NAME;.02~ZCT03E1;.03~1;.04~2;.05~.331;.08~0;10~S DR=.331 D LOOK^IVMPREC9;20~S DR=.331 D LOOK^IVMPREC9
"RTN","DG53754P",51,0)
 ;;.01~E-RELATIONSHIP TO PATIENT;.02~ZCT04E1;.03~1;.04~2;.05~.332;.08~0;10~S DR=.332 D LOOK^IVMPREC9;20~S DR=.332 D LOOK^IVMPREC9
"RTN","DG53754P",52,0)
 ;;.01~E-STREET ADDRESS [LINE 1];.02~ZCT051E1;.03~1;.04~2;.05~.333;.08~0;10~S DR=.333 D LOOK^IVMPREC9;20~S DR=.333 D LOOK^IVMPREC9
"RTN","DG53754P",53,0)
 ;;.01~E-STREET ADDRESS [LINE 2];.02~ZCT052E1;.03~1;.04~2;.05~.334;.08~0;10~S DR=.334 D LOOK^IVMPREC9;20~S DR=.334 D LOOK^IVMPREC9
"RTN","DG53754P",54,0)
 ;;.01~E-CITY;.02~ZCT053E1;.03~1;.04~2;.05~.336;.08~0;10~S DR=.336 D LOOK^IVMPREC9;20~S DR=.336 D LOOK^IVMPREC9
"RTN","DG53754P",55,0)
 ;;.01~E-STATE;.02~ZCT054E1;.03~1;.04~2;.05~.337;.06~1;.08~0;10~S DR=.337 D LOOK^IVMPREC9;20~S DR=.337,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",56,0)
 ;;.01~E-ZIP CODE;.02~ZCT055E1;.03~1;.04~2;.05~.338;.08~0;10~S DR=.338 D LOOK^IVMPREC9;20~S DR=.338 D LOOK^IVMPREC9
"RTN","DG53754P",57,0)
 ;;.01~E-PHONE NUMBER;.02~ZCT06E1;.03~1;.04~2;.05~.339;.08~0;10~S DR=.339 D LOOK^IVMPREC9;20~S DR=.339 D LOOK^IVMPREC9
"RTN","DG53754P",58,0)
 ;;.01~E-WORK PHONE NUMBER;.02~ZCT07E1;.03~1;.04~2;.05~.33011;.08~0;10~S DR=.33011 D LOOK^IVMPREC9;20~S DR=.33011 D LOOK^IVMPREC9
"RTN","DG53754P",59,0)
 ;;.01~E-CONTACT CHANGE DATE/TIME;.02~ZCT10E1;.03~1;.04~2;.05~.33012;.06~1;.08~0;10~S DR=.33012 D LOOK^IVMPREC9;20~S DR=.33012,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",60,0)
 ;;.01~E2-NAME OF SECONDARY CONTACT;.02~ZCT03E2;.03~1;.04~2;.05~.3311;.08~0;10~S DR=.3311 D LOOK^IVMPREC9;20~S DR=.3311 D LOOK^IVMPREC9
"RTN","DG53754P",61,0)
 ;;.01~E2-RELATIONSHIP TO PATIENT;.02~ZCT04E2;.03~1;.04~2;.05~.3312;.08~0;10~S DR=.3312 D LOOK^IVMPREC9;20~S DR=.3312 D LOOK^IVMPREC9
"RTN","DG53754P",62,0)
 ;;.01~E2-STREET ADDRESS [LINE 1];.02~ZCT051E2;.03~1;.04~2;.05~.3313;.08~0;10~S DR=.3313 D LOOK^IVMPREC9;20~S DR=.3313 D LOOK^IVMPREC9
"RTN","DG53754P",63,0)
 ;;.01~E2-STREET ADDRESS [LINE 2];.02~ZCT052E2;.03~1;.04~2;.05~.3314;.08~0;10~S DR=.3314 D LOOK^IVMPREC9;20~S DR=.3314 D LOOK^IVMPREC9
"RTN","DG53754P",64,0)
 ;;.01~E2-CITY;.02~ZCT053E2;.03~1;.04~2;.05~.3316;.08~0;10~S DR=.3316 D LOOK^IVMPREC9;20~S DR=.3316 D LOOK^IVMPREC9
"RTN","DG53754P",65,0)
 ;;.01~E2-STATE;.02~ZCT054E2;.03~1;.04~2;.05~.3317;.06~1;.08~0;10~S DR=.3317 D LOOK^IVMPREC9;20~S DR=.3317,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",66,0)
 ;;.01~E2-ZIP CODE;.02~ZCT055E2;.03~1;.04~2;.05~.3318;.08~0;10~S DR=.3318 D LOOK^IVMPREC9;20~S DR=.3318 D LOOK^IVMPREC9
"RTN","DG53754P",67,0)
 ;;.01~E2-PHONE NUMBER;.02~ZCT06E2;.03~1;.04~2;.05~.3319;.08~0;10~S DR=.3319 D LOOK^IVMPREC9;20~S DR=.3319 D LOOK^IVMPREC9
"RTN","DG53754P",68,0)
 ;;.01~E2-WORK PHONE NUMBER;.02~ZCT07E2;.03~1;.04~2;.05~.331011;.08~0;10~S DR=.331011 D LOOK^IVMPREC9;20~S DR=.331011 D LOOK^IVMPREC9
"RTN","DG53754P",69,0)
 ;;.01~E2-CONTACT CHANGE DATE/TIME;.02~ZCT10E2;.03~1;.04~2;.05~.33112;.06~1;.08~0;10~S DR=.33112 D LOOK^IVMPREC9;20~S DR=.33112,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",70,0)
 ;;.01~K-NAME OF PRIMARY NOK;.02~ZCT03K1;.03~1;.04~2;.05~.211;.08~0;10~S DR=.211 D LOOK^IVMPREC9;20~S DR=.211 D LOOK^IVMPREC9
"RTN","DG53754P",71,0)
 ;;.01~K-RELATIONSHIP TO PATIENT;.02~ZCT04K1;.03~1;.04~2;.05~.212;.08~0;10~S DR=.212 D LOOK^IVMPREC9;20~S DR=.212 D LOOK^IVMPREC9
"RTN","DG53754P",72,0)
 ;;.01~K-STREET ADDRESS [LINE 1];.02~ZCT051K1;.03~1;.04~2;.05~.213;.08~0;10~S DR=.213 D LOOK^IVMPREC9;20~S DR=.213 D LOOK^IVMPREC9
"RTN","DG53754P",73,0)
 ;;.01~K-STREET ADDRESS [LINE 2];.02~ZCT052K1;.03~1;.04~2;.05~.214;.08~0;10~S DR=.214 D LOOK^IVMPREC9;20~S DR=.214 D LOOK^IVMPREC9
"RTN","DG53754P",74,0)
 ;;.01~K-CITY;.02~ZCT053K1;.03~1;.04~2;.05~.216;.08~0;10~S DR=.216 D LOOK^IVMPREC9;20~S DR=.216 D LOOK^IVMPREC9
"RTN","DG53754P",75,0)
 ;;.01~K-STATE;.02~ZCT054K1;.03~1;.04~2;.05~.217;.06~1;.08~0;10~S DR=.217 D LOOK^IVMPREC9;20~S DR=.217,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",76,0)
 ;;.01~K-ZIP CODE;.02~ZCT055K1;.03~1;.04~2;.05~.218;.08~0;10~S DR=.218 D LOOK^IVMPREC9;20~S DR=.218 D LOOK^IVMPREC9
"RTN","DG53754P",77,0)
 ;;.01~K-PHONE NUMBER;.02~ZCT06K1;.03~1;.04~2;.05~.219;.08~0;10~S DR=.219 D LOOK^IVMPREC9;20~S DR=.219 D LOOK^IVMPREC9
"RTN","DG53754P",78,0)
 ;;.01~K-WORK PHONE NUMBER;.02~ZCT07K1;.03~1;.04~2;.05~.21011;.08~0;10~S DR=.21011 D LOOK^IVMPREC9;20~S DR=.21011 D LOOK^IVMPREC9
"RTN","DG53754P",79,0)
 ;;.01~PRIMARY NOK CHANGE DATE/TIME;.02~ZCT10K1;.03~1;.04~2;.05~.21012;.06~1;.08~0;10~S DR=.21012 D LOOK^IVMPREC9;20~S DR=.21012,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",80,0)
 ;;.01~K2-NAME OF SECONDARY NOK;.02~ZCT03K2;.03~1;.04~2;.05~.2191;.08~0;10~S DR=.2191 D LOOK^IVMPREC9;20~S DR=.2191 D LOOK^IVMPREC9
"RTN","DG53754P",81,0)
 ;;.01~K2-RELATIONSHIP TO PATIENT;.02~ZCT04K2;.03~1;.04~2;.05~.2192;.08~0;10~S DR=.2192 D LOOK^IVMPREC9;20~S DR=.2192 D LOOK^IVMPREC9
"RTN","DG53754P",82,0)
 ;;.01~K2-STREET ADDRESS [LINE 1];.02~ZCT051K2;.03~1;.04~2;.05~.2193;.08~0;10~S DR=.2193 D LOOK^IVMPREC9;20~S DR=.2193 D LOOK^IVMPREC9
"RTN","DG53754P",83,0)
 ;;.01~K2-STREET ADDRESS [LINE 2];.02~ZCT052K2;.03~1;.04~2;.05~.2194;.08~0;10~S DR=.2194 D LOOK^IVMPREC9;20~S DR=.2194 D LOOK^IVMPREC9
"RTN","DG53754P",84,0)
 ;;.01~K2-CITY;.02~ZCT053K2;.03~1;.04~2;.05~.2196;.08~0;10~S DR=.2196 D LOOK^IVMPREC9;20~S DR=.2196 D LOOK^IVMPREC9
"RTN","DG53754P",85,0)
 ;;.01~K2-STATE;.02~ZCT054K2;.03~1;.04~2;.05~.2197;.06~1;.08~0;10~S DR=.2197 D LOOK^IVMPREC9;20~S DR=.2197,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",86,0)
 ;;.01~K2-ZIP CODE;.02~ZCT055K2;.03~1;.04~2;.05~.2198;.08~0;10~S DR=.2198 D LOOK^IVMPREC9;20~S DR=.2198 D LOOK^IVMPREC9
"RTN","DG53754P",87,0)
 ;;.01~K2-PHONE NUMBER;.02~ZCT06K2;.03~1;.04~2;.05~.2199;.08~0;10~S DR=.2199 D LOOK^IVMPREC9;20~S DR=.2199 D LOOK^IVMPREC9
"RTN","DG53754P",88,0)
 ;;.01~K2-WORK PHONE NUMBER;.02~ZCT07K2;.03~1;.04~2;.05~.211011;.08~0;10~S DR=.211011 D LOOK^IVMPREC9;20~S DR=.211011 D LOOK^IVMPREC9
"RTN","DG53754P",89,0)
 ;;.01~SECONDARY NOK CHANGE DT/TM;.02~ZCT10K2;.03~1;.04~2;.05~.211012;.06~1;.08~0;10~S DR=.211012 D LOOK^IVMPREC9;20~S DR=.211012,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",90,0)
 ;;.01~D-NAME OF DESIGNEE;.02~ZCT03D1;.03~1;.04~2;.05~.341;.08~0;10~S DR=.341 D LOOK^IVMPREC9;20~S DR=.341 D LOOK^IVMPREC9
"RTN","DG53754P",91,0)
 ;;.01~D-RELATIONSHIP TO PATIENT;.02~ZCT04D1;.03~1;.04~2;.05~.342;.08~0;10~S DR=.342 D LOOK^IVMPREC9;20~S DR=.342 D LOOK^IVMPREC9
"RTN","DG53754P",92,0)
 ;;.01~D-STREET ADDRESS [LINE 1];.02~ZCT051D1;.03~1;.04~2;.05~.343;.08~0;10~S DR=.343 D LOOK^IVMPREC9;20~S DR=.343 D LOOK^IVMPREC9
"RTN","DG53754P",93,0)
 ;;.01~D-STREET ADDRESS [LINE 2];.02~ZCT052D1;.03~1;.04~2;.05~.344;.08~0;10~S DR=.344 D LOOK^IVMPREC9;20~S DR=.344 D LOOK^IVMPREC9
"RTN","DG53754P",94,0)
 ;;.01~D-CITY;.02~ZCT053D1;.03~1;.04~2;.05~.346;.08~0;10~S DR=.346 D LOOK^IVMPREC9;20~S DR=.346 D LOOK^IVMPREC9
"RTN","DG53754P",95,0)
 ;;.01~D-STATE;.02~ZCT054D1;.03~1;.04~2;.05~.347;.06~1;.08~0;10~S DR=.347 D LOOK^IVMPREC9;20~S DR=.347,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",96,0)
 ;;.01~D-ZIP CODE;.02~ZCT055D1;.03~1;.04~2;.05~.348;.08~0;10~S DR=.348 D LOOK^IVMPREC9;20~S DR=.348 D LOOK^IVMPREC9
"RTN","DG53754P",97,0)
 ;;.01~D-PHONE NUMBER;.02~ZCT06D1;.03~1;.04~2;.05~.349;.08~0;10~S DR=.349 D LOOK^IVMPREC9;20~S DR=.349 D LOOK^IVMPREC9
"RTN","DG53754P",98,0)
 ;;.01~D-WORK PHONE NUMBER;.02~ZCT07D1;.03~1;.04~2;.05~.34011;.08~0;10~S DR=.34011 D LOOK^IVMPREC9;20~S DR=.34011 D LOOK^IVMPREC9
"RTN","DG53754P",99,0)
 ;;.01~DESIGNEE CHANGE DATE/TIME;.02~ZCT10D1;.03~1;.04~2;.05~.3412;.06~1;.08~0;10~S DR=.3412 D LOOK^IVMPREC9;20~S DR=.3412,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",100,0)
 ;;.01~EMPLOYMENT STATUS;.02~ZEM03;.03~1;.04~2;.05~.31115;.06~1;.08~0;10~S DR=.31115 D LOOK^IVMPREC9;20~S DR=.31115,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",101,0)
 ;;.01~EMPLOYER NAME;.02~ZEM04;.03~1;.04~2;.05~.3111;.08~0;10~S DR=.3111 D LOOK^IVMPREC9;20~S DR=.3111 D LOOK^IVMPREC9
"RTN","DG53754P",102,0)
 ;;.01~OCCUPATION;.02~ZEM05;.03~1;.04~2;.05~.07;.08~0;10~S DR=.07 D LOOK^IVMPREC9;20~S DR=.07 D LOOK^IVMPREC9
"RTN","DG53754P",103,0)
 ;;.01~EMPLOYER ADDR [LINE 1];.02~ZEM061;.03~1;.04~2;.05~.3113;.08~0;10~S DR=.3113 D LOOK^IVMPREC9;20~S DR=.3113 D LOOK^IVMPREC9
"RTN","DG53754P",104,0)
 ;;.01~EMPLOYER ADDR [LINE 2];.02~ZEM062;.03~1;.04~2;.05~.3114;.08~0;10~S DR=.3114 D LOOK^IVMPREC9;20~S DR=.3114 D LOOK^IVMPREC9
"RTN","DG53754P",105,0)
 ;;.01~EMPLOYER ADDR [LINE 3];.02~ZEM068;.03~1;.04~2;.05~.3115;.08~0;10~S DR=.3115 D LOOK^IVMPREC9;20~S DR=.3115 D LOOK^IVMPREC9
"RTN","DG53754P",106,0)
 ;;.01~EMPLOYER CITY;.02~ZEM063;.03~1;.04~2;.05~.3116;.08~0;10~S DR=.3116 D LOOK^IVMPREC9;20~S DR=.3116 D LOOK^IVMPREC9
"RTN","DG53754P",107,0)
 ;;.01~EMPLOYER STATE;.02~ZEM064;.03~1;.04~2;.05~.3117;.06~1;.08~0;10~S DR=.3117 D LOOK^IVMPREC9;20~S DR=.3117,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",108,0)
 ;;.01~EMPLOYER ZIP;.02~ZEM065;.03~1;.04~2;.05~.3118;.08~0;10~S DR=.3118 D LOOK^IVMPREC9;20~S DR=.3118 D LOOK^IVMPREC9
"RTN","DG53754P",109,0)
 ;;.01~EMPLOYER TELEPHONE;.02~ZEM07;.03~1;.04~2;.05~.3119;.08~0;10~S DR=.3119 D LOOK^IVMPREC9;20~S DR=.3119 D LOOK^IVMPREC9
"RTN","DG53754P",110,0)
 ;;.01~RETIREMENT DATE;.02~ZEM09;.03~1;.04~2;.05~.31116;.06~1;.08~0;10~S DR=.31116 D LOOK^IVMPREC9;20~S DR=.31116,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",111,0)
 ;;QUIT
"RTN","DG53754P",112,0)
 ;;
"RTN","DG53754P",113,0)
 ;;The following have been disabled until further notice
"RTN","DG53754P",114,0)
 ;;.01~PLACE OF BIRTH CITY;.02~PID113N;.03~1;.04~2;.05~.092;.08~0;10~S DR=.092 D LOOK^IVMPREC9;20~S DR=.092 D LOOK^IVMPREC9
"RTN","DG53754P",115,0)
 ;;.01~PLACE OF BIRTH STATE;.02~PID114N;.03~1;.04~2;.05~.093;.06~1;.08~0;10~S DR=.093 D LOOK^IVMPREC9;20~S DR=.093,DIQ(0)="E" D LOOK^IVMPREC9
"RTN","DG53754P",116,0)
 ;;.01~CONFIDENTIAL STREET [LINE 1];.02~PID111C;.03~1;.04~2;.05~.1411;.08~0;10~S Y=$P(VAPA(13),"^");20~S Y=$P(VAPA(13),"^")
"RTN","DG53754P",117,0)
 ;;.01~CONFIDENTIAL STREET [LINE 2];.02~PID112C;.03~1;.04~2;.05~.1412;.08~0;10~S Y=$P(VAPA(14),"^");20~S Y=$P(VAPA(14),"^")
"RTN","DG53754P",118,0)
 ;;.01~CONFIDENTIAL STREET [LINE 3];.02~PID118C;.03~1;.04~2;.05~.1413;.08~0;10~S Y=$P(VAPA(15),"^");20~S Y=$P(VAPA(15),"^")
"RTN","DG53754P",119,0)
 ;;.01~CONFIDENTIAL ADDR CITY;.02~PID113C;.03~1;.04~2;.05~.1414;.08~0;10~S Y=$P(VAPA(16),"^");20~S Y=$P(VAPA(16),"^")
"RTN","DG53754P",120,0)
 ;;.01~CONFIDENTIAL ADDR STATE;.02~PID114C;.03~1;.04~2;.05~.1415;.06~1;.08~0;10~S Y=$P(VAPA(17),"^");20~S Y=$P(VAPA(17),"^",2)
"RTN","DG53754P",121,0)
 ;;.01~CONFIDENTIAL ADDR ZIP CODE;.02~PID115C;.03~1;.04~2;.05~.1416;.08~0;10~S Y=$P(VAPA(18),"^");20~S Y=$P(VAPA(18),"^",2)
"RTN","DG53754P",122,0)
 ;;.01~CONFIDENTIAL ADDR PROVINCE;.02~PID114CF;.03~1;.04~2;.05~.14114;.08~0;10~S Y=$P(VAPA(26),"^");20~S Y=$P(VAPA(26),"^")
"RTN","DG53754P",123,0)
 ;;.01~CONFIDENTIAL ADDR POSTAL CODE;.02~PID115CF;.03~1;.04~2;.05~.14115;.08~0;10~S Y=$P(VAPA(27),"^");20~S Y=$P(VAPA(27),"^")
"RTN","DG53754P",124,0)
 ;;.01~CONFIDENTIAL START DATE;.02~PID1112C1;.03~1;.04~2;.05~.1417;.06~1;.08~0;10~S Y=$P(VAPA(20),"^");20~S Y=$P(VAPA(20),"^",2)
"RTN","DG53754P",125,0)
 ;;.01~CONFIDENTIAL END DATE;.02~PID1112C2;.03~1;.04~2;.05~.1418;.06~1;.08~0;10~S Y=$P(VAPA(21),"^");20~S Y=$P(VAPA(21),"^",2)
"RTN","DG53754P",126,0)
 ;;.01~CONFIDENTIAL ADDR COUNTRY;.02~PID116C;.03~1;.04~2;.05~.14116;.06~1;.08~0;10~S Y=$P(VAPA(28),"^");20~S Y=$P(VAPA(28),"^",2)
"RTN","DG53754P",127,0)
 ;;.01~CONFIDENTIAL ADDR CATEGORY;.02~PID117C;.03~1;.04~2;.05~.141;.08~0;10~S Y=$P(VAPA(22),"^");20~S Y=$P(VAPA(22),"^",2)
"RTN","DG53754P",128,0)
 ;;.01~CONFIDENTIAL ADDR COUNTY;.02~PID119C;.03~1;.04~2;.05~.14111;.06~0;.08~0;10~S Y=$P($G(^DIC(5,+VAPA(5),1,+VAPA(19),0)),"^",3);20~S Y=$P(VAPA(19),"^",2)
"RTN","DG53754P",129,0)
 ;;.01~MULTIPLE BIRTH INDICATOR;.02~PID24;.03~1;.04~2;.05~994;.08~0;10~S DR=994 D LOOK^IVMPREC9;20~S DR=994 D LOOK^IVMPREC9
"RTN","DG53754P",130,0)
 ;;.01~CONFIDENTIAL PHONE NUMBER;.02~PID13CA;.03~1;.04~2;.05~.1315;.08~0;10~S Y=$P(VAPA(29),"^");20~S Y=$P(VAPA(29),"^")
"RTN","DG53754P",131,0)
 ;;.01~FATHER'S NAME;.02~ZPD06;.03~1;.04~2;.05~.2401;.08~0;10~S DR=.2401 D LOOK^IVMPREC9;20~S DR=.2401 D LOOK^IVMPREC9
"RTN","DG53754P",132,0)
 ;;.01~MOTHER'S NAME;.02~ZPD07;.03~1;.04~2;.05~.2402;.08~0;10~S DR=.2402 D LOOK^IVMPREC9;20~S DR=.2402 D LOOK^IVMPREC9
"RTN","DGCLEAR")
0^14^B7082785
"RTN","DGCLEAR",1,0)
DGCLEAR ;ALB/BAJ,TDM - REGISTRATION CROSS REFERENCE CLEANUP ; 12/22/08 4:14pm
"RTN","DGCLEAR",2,0)
 ;;5.3;Registration;**653,688,754**;Aug 13, 1993;Build 46
"RTN","DGCLEAR",3,0)
 ;
"RTN","DGCLEAR",4,0)
 ; Called from ASK^DGLOCK or ADK^DGLOCK3, The purpose of this routine is to clear All temporary or confidential address fields
"RTN","DGCLEAR",5,0)
 ; Also called from Z07 process to clear Permanent address before update 
"RTN","DGCLEAR",6,0)
 ;               
"RTN","DGCLEAR",7,0)
 ; 
"RTN","DGCLEAR",8,0)
EN(DGENDA,TYPE) ; entry point
"RTN","DGCLEAR",9,0)
 ;
"RTN","DGCLEAR",10,0)
 ; Code to TRIGGER deletion of field data.
"RTN","DGCLEAR",11,0)
 N DATA,CALLTYP
"RTN","DGCLEAR",12,0)
 S CALLTYP=$S(TYPE="TEMP":"T",TYPE="PERM":"P",1:"C")
"RTN","DGCLEAR",13,0)
 D SETARR(CALLTYP,.DATA)
"RTN","DGCLEAR",14,0)
 Q $$UPD^DGENDBS(2,.DGENDA,.DATA)
"RTN","DGCLEAR",15,0)
 ;
"RTN","DGCLEAR",16,0)
SETARR(CALLTYP,DATA) ;set up data array
"RTN","DGCLEAR",17,0)
 N CNT,CURFILE,CTRYFLD,FDFLG,ADDTYPE,T,FTYPE,CURFTYPE
"RTN","DGCLEAR",18,0)
 ; assemble array of fields to clear
"RTN","DGCLEAR",19,0)
 F CNT=1:1 S T=$P($T(DTABLE+CNT),";;",3) Q:T="QUIT"  D
"RTN","DGCLEAR",20,0)
 . Q:$P(T,";",1)'=CALLTYP  S DATA($P(T,";",3))=$P(T,";",4)
"RTN","DGCLEAR",21,0)
 Q
"RTN","DGCLEAR",22,0)
DTABLE ;TABLE of Foreign and Domestic fields: structure -->>;;Description;;(T)EMPORARY/(C)ONFIDENTIAL/(P)ERMANENT;FILE;FIELD;DATA
"RTN","DGCLEAR",23,0)
 ;;TEMPORARY STREET [LINE 1];;T;2;.1211;@
"RTN","DGCLEAR",24,0)
 ;;TEMPORARY ZIP+4;;T;2;.12112;@
"RTN","DGCLEAR",25,0)
 ;;TEMPORARY STREET [LINE 2];;T;2;.1212;@
"RTN","DGCLEAR",26,0)
 ;;TEMPORARY STREET [LINE 3];;T;2;.1213;@
"RTN","DGCLEAR",27,0)
 ;;TEMPORARY CITY;;T;2;.1214;@
"RTN","DGCLEAR",28,0)
 ;;TEMPORARY STATE;;T;2;.1215;@
"RTN","DGCLEAR",29,0)
 ;;TEMPORARY COUNTY;;T;2;.12111;@
"RTN","DGCLEAR",30,0)
 ;;TEMPORARY ZIP CODE;;T;2;.1216;@
"RTN","DGCLEAR",31,0)
 ;;TEMPORARY ADDRESS START DATE;;T;2;.1217;@
"RTN","DGCLEAR",32,0)
 ;;TEMPORARY ADDRESS END DATE;;T;2;.1218;@
"RTN","DGCLEAR",33,0)
 ;;TEMPORARY PHONE NUMBER;;T;2;.1219;@
"RTN","DGCLEAR",34,0)
 ;;TEMPORARY ADDRESS PROVINCE;;T;2;.1221;@
"RTN","DGCLEAR",35,0)
 ;;TEMPORARY ADDRESS POSTAL CODE;;T;2;.1222;@
"RTN","DGCLEAR",36,0)
 ;;TEMPORARY ADDRESS COUNTRY;;T;2;.1223;@
"RTN","DGCLEAR",37,0)
 ;;TEMPORARY ADDRESS ACTIVE;;T;2;.12105;N
"RTN","DGCLEAR",38,0)
 ;;CONFIDENTIAL STREET [LINE 1];;C;2;.1411;@
"RTN","DGCLEAR",39,0)
 ;;CONFIDENTIAL STREET [LINE 2];;C;2;.1412;@
"RTN","DGCLEAR",40,0)
 ;;CONFIDENTIAL STREET [LINE 3];;C;2;.1413;@
"RTN","DGCLEAR",41,0)
 ;;CONFIDENTIAL CITY;;C;2;.1414;@
"RTN","DGCLEAR",42,0)
 ;;CONFIDENTIAL STATE;;C;2;.1415;@
"RTN","DGCLEAR",43,0)
 ;;CONFIDENTIAL COUNTY;;C;2;.14111;@
"RTN","DGCLEAR",44,0)
 ;;CONFIDENTIAL ZIP CODE;;C;2;.1416;@
"RTN","DGCLEAR",45,0)
 ;;CONFIDENTIAL ADDRESS START DATE;;C;2;.1417;@
"RTN","DGCLEAR",46,0)
 ;;CONFIDENTIAL ADDRESS END DATE;;C;2;.1418;@
"RTN","DGCLEAR",47,0)
 ;;CONFIDENTIAL PHONE NUMBER;;C;2;.1315;@
"RTN","DGCLEAR",48,0)
 ;;CONFIDENTIAL ADDRESS PROVINCE;;C;2;.14114;@
"RTN","DGCLEAR",49,0)
 ;;CONFIDENTIAL ADDRESS POSTAL CODE;;C;2;.14115;@
"RTN","DGCLEAR",50,0)
 ;;CONFIDENTIAL ADDRESS COUNTRY;;C;2;.14116;@
"RTN","DGCLEAR",51,0)
 ;;CONFIDENTIAL ADDRESS ACTIVE;;C;2;.14105;N
"RTN","DGCLEAR",52,0)
 ;;PERMANENT STREET [LINE 1];;P;2;.111;@
"RTN","DGCLEAR",53,0)
 ;;PERMANENT STREET [LINE 2];;P;2;.112;@
"RTN","DGCLEAR",54,0)
 ;;PERMANENT CITY;;P;2;.114;@
"RTN","DGCLEAR",55,0)
 ;;PERMANENT STATE;;P;2;.115;@
"RTN","DGCLEAR",56,0)
 ;;PERMANENT COUNTY;;P;2;.117;@
"RTN","DGCLEAR",57,0)
 ;;PERMANENT ZIP CODE;;P;2;.1112;@
"RTN","DGCLEAR",58,0)
 ;;PERMANENT ADDRESS PROVINCE;;P;2;.1171;@
"RTN","DGCLEAR",59,0)
 ;;PERMANENT ADDRESS POSTAL CODE;;P;2;.1172;@
"RTN","DGCLEAR",60,0)
 ;;PERMANENT ADDRESS COUNTRY;;P;2;.1173;@
"RTN","DGCLEAR",61,0)
 ;;PERMANENT BAD ADDRESS INDICATOR;;P;2;.121;@
"RTN","DGCLEAR",62,0)
 ;;QUIT;;QUIT
"RTN","DGDDDTTM")
0^15^B5522558
"RTN","DGDDDTTM",1,0)
DGDDDTTM ;ALB/MRL,BAJ,TDM - TRIGGER DT/TM CROSS REFERENCES [PATIENT] ; 5/28/10 1:17pm
"RTN","DGDDDTTM",2,0)
 ;;5.3;Registration;**665,653,688,754**;Aug 13, 1993;Build 46
"RTN","DGDDDTTM",3,0)
 ;
"RTN","DGDDDTTM",4,0)
 ; This routine contains the code for new style cross-reference record
"RTN","DGDDDTTM",5,0)
 ; triggers for the PATIENT File #2.
"RTN","DGDDDTTM",6,0)
 ;
"RTN","DGDDDTTM",7,0)
TEMP ; PATIENT File #2 Record Index: ADTTM1
"RTN","DGDDDTTM",8,0)
 ; 
"RTN","DGDDDTTM",9,0)
 ; This code updates the TEMPORARY ADDRESS CHANGE DT/TM field when any 
"RTN","DGDDDTTM",10,0)
 ; of the following Temporary Address related data changes for a patient:
"RTN","DGDDDTTM",11,0)
 ;    
"RTN","DGDDDTTM",12,0)
 ;    TEMPORARY STREET [LINE 1]    (#.1211)
"RTN","DGDDDTTM",13,0)
 ;    TEMPORARY STREET [LINE 2]    (#.1212)
"RTN","DGDDDTTM",14,0)
 ;    TEMPORARY STREET [LINE 3]    (#.1213)
"RTN","DGDDDTTM",15,0)
 ;    TEMPORARY CITY               (#.1214)
"RTN","DGDDDTTM",16,0)
 ;    TEMPORARY STATE              (#.1215)
"RTN","DGDDDTTM",17,0)
 ;    TEMPORARY ZIP CODE           (#.1216)
"RTN","DGDDDTTM",18,0)
 ;    TEMPORARY ADDRESS START DATE (#.1217)
"RTN","DGDDDTTM",19,0)
 ;    TEMPORARY ADDRESS END DATE   (#.1218)
"RTN","DGDDDTTM",20,0)
 ;    TEMPORARY ADDRESS ACTIVE?    (#.12105)
"RTN","DGDDDTTM",21,0)
 ;    TEMPORARY ZIP+4              (#.12112)
"RTN","DGDDDTTM",22,0)
 ;    TEMPORARY ADDRESS COUNTY     (#.12111)
"RTN","DGDDDTTM",23,0)
 ;    TEMPORARY ADDRESS PROVINCE   (#.1221)
"RTN","DGDDDTTM",24,0)
 ;    TEMPORARY ADDRESS POSTAL CODE (#.1222)
"RTN","DGDDDTTM",25,0)
 ;    TEMPORARY ADDRESS COUNTRY     (#.1223)
"RTN","DGDDDTTM",26,0)
 ;
"RTN","DGDDDTTM",27,0)
 Q:$G(DGRONUPD)=1  ;Suppress update for ROM (set in routine DGROHLR1)
"RTN","DGDDDTTM",28,0)
 N DGIEN,DATA S DATA(.12113)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",29,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",30,0)
 Q
"RTN","DGDDDTTM",31,0)
 ;
"RTN","DGDDDTTM",32,0)
CONF ; PATIENT File #2 Record Index: ADTTM2
"RTN","DGDDDTTM",33,0)
 ;
"RTN","DGDDDTTM",34,0)
 ; This code updates the CONFIDENTIAL ADDR CHANGE DT/TM field when any
"RTN","DGDDDTTM",35,0)
 ; of the following Confidential Address related data changes for a
"RTN","DGDDDTTM",36,0)
 ; patient:
"RTN","DGDDDTTM",37,0)
 ;
"RTN","DGDDDTTM",38,0)
 ;    CONFIDENTIAL STREET [LINE 1]  (#.1411)
"RTN","DGDDDTTM",39,0)
 ;    CONFIDENTIAL STREET [LINE 2]  (#.1412)
"RTN","DGDDDTTM",40,0)
 ;    CONFIDENTIAL STREET [LINE 3]  (#.1413)
"RTN","DGDDDTTM",41,0)
 ;    CONFIDENTIAL ADDRESS CITY     (#.1414)
"RTN","DGDDDTTM",42,0)
 ;    CONFIDENTIAL ADDRESS STATE    (#.1415)
"RTN","DGDDDTTM",43,0)
 ;    CONFIDENTIAL ADDRESS ZIP CODE (#.1416)
"RTN","DGDDDTTM",44,0)
 ;    CONFIDENTIAL START DATE       (#.1417)
"RTN","DGDDDTTM",45,0)
 ;    CONFIDENTIAL END DATE         (#.1418)
"RTN","DGDDDTTM",46,0)
 ;    CONFIDENTIAL ADDRESS ACTIVE?  (#.14105)
"RTN","DGDDDTTM",47,0)
 ;    CONFIDENTIAL ADDRESS COUNTY   (#.14111)
"RTN","DGDDDTTM",48,0)
 ;    CONFIDENTIAL ADDR PROVINCE    (#.14114)
"RTN","DGDDDTTM",49,0)
 ;    CONFIDENTIAL ADDR POSTAL CODE (#.14115)
"RTN","DGDDDTTM",50,0)
 ;    CONFIDENTIAL ADDR COUNTRY     (#.14116)
"RTN","DGDDDTTM",51,0)
 ;    CONFIDENTIAL PHONE NUMBER     (#.1315)
"RTN","DGDDDTTM",52,0)
 ;
"RTN","DGDDDTTM",53,0)
 Q:$G(DGRONUPD)=1  ;Suppress update for ROM (set in routine DGROHLR1)
"RTN","DGDDDTTM",54,0)
 N DGIEN,DATA S DATA(.14112)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",55,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",56,0)
 Q
"RTN","DGDDDTTM",57,0)
 ;
"RTN","DGDDDTTM",58,0)
PNOK ; PATIENT File #2 Record Index: ADTTM3
"RTN","DGDDDTTM",59,0)
 ;
"RTN","DGDDDTTM",60,0)
 ; This code updates the PRIMARY NOK CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",61,0)
 ; of the following Primary Next of Kin related data changes for a
"RTN","DGDDDTTM",62,0)
 ; patient:
"RTN","DGDDDTTM",63,0)
 ;
"RTN","DGDDDTTM",64,0)
 ;    K-NAME OF PRIMARY NOK        (#.211)
"RTN","DGDDDTTM",65,0)
 ;    K-RELATIONSHIP TO PATIENT    (#.212)
"RTN","DGDDDTTM",66,0)
 ;    K-STREET ADDRESS [LINE 1]    (#.213)
"RTN","DGDDDTTM",67,0)
 ;    K-STREET ADDRESS [LINE 2]    (#.214)
"RTN","DGDDDTTM",68,0)
 ;    K-STREET ADDRESS [LINE 3]    (#.215)
"RTN","DGDDDTTM",69,0)
 ;    K-CITY                       (#.216)
"RTN","DGDDDTTM",70,0)
 ;    K-STATE                      (#.217)
"RTN","DGDDDTTM",71,0)
 ;    K-ZIP CODE                   (#.218)
"RTN","DGDDDTTM",72,0)
 ;    K-ADDRESS SAME AS PATIENT'S? (#.2125)
"RTN","DGDDDTTM",73,0)
 ;    K-ZIP+4                      (#.2207)
"RTN","DGDDDTTM",74,0)
 ;    K-PHONE NUMBER               (#.219)
"RTN","DGDDDTTM",75,0)
 ;    K-WORK PHONE NUMBER          (#.21011)
"RTN","DGDDDTTM",76,0)
 ;
"RTN","DGDDDTTM",77,0)
 N DGIEN,DATA S DATA(.21012)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",78,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",79,0)
 Q
"RTN","DGDDDTTM",80,0)
 ;
"RTN","DGDDDTTM",81,0)
SNOK ; PATIENT File #2 Record Index: ADTTM4
"RTN","DGDDDTTM",82,0)
 ;
"RTN","DGDDDTTM",83,0)
 ; This code updates the SECONDARY NOK CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",84,0)
 ; of the following Secondary Next of Kin related data changes for a
"RTN","DGDDDTTM",85,0)
 ; patient:
"RTN","DGDDDTTM",86,0)
 ;
"RTN","DGDDDTTM",87,0)
 ;    K2-NAME OF SECONDARY NOK      (#.2191)
"RTN","DGDDDTTM",88,0)
 ;    K2-RELATIONSHIP TO PATIENT    (#.2192)
"RTN","DGDDDTTM",89,0)
 ;    K2-STREET ADDRESS [LINE 1]    (#.2193)
"RTN","DGDDDTTM",90,0)
 ;    K2-STREET ADDRESS [LINE 2]    (#.2194)
"RTN","DGDDDTTM",91,0)
 ;    K2-STREET ADDRESS [LINE 3]    (#.2195)
"RTN","DGDDDTTM",92,0)
 ;    K2-CITY                       (#.2196)
"RTN","DGDDDTTM",93,0)
 ;    K2-STATE                      (#.2197)
"RTN","DGDDDTTM",94,0)
 ;    K2-ZIP CODE                   (#.2198)
"RTN","DGDDDTTM",95,0)
 ;    K2-ADDRESS SAME AS PATIENT'S? (#.21925)
"RTN","DGDDDTTM",96,0)
 ;    K2-ZIP+4                      (#.2203)
"RTN","DGDDDTTM",97,0)
 ;    K2-PHONE NUMBER               (#.2199)
"RTN","DGDDDTTM",98,0)
 ;    K2-WORK PHONE NUMBER          (#.211011)
"RTN","DGDDDTTM",99,0)
 ;
"RTN","DGDDDTTM",100,0)
 N DGIEN,DATA S DATA(.211012)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",101,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",102,0)
 Q
"RTN","DGDDDTTM",103,0)
 ;
"RTN","DGDDDTTM",104,0)
ECON ; PATIENT File #2 Record Index: ADTTM5
"RTN","DGDDDTTM",105,0)
 ;
"RTN","DGDDDTTM",106,0)
 ; This code updates the E-CONTACT CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",107,0)
 ; of the following Emergency Contact related data changes for a
"RTN","DGDDDTTM",108,0)
 ; patient:
"RTN","DGDDDTTM",109,0)
 ;
"RTN","DGDDDTTM",110,0)
 ;    E-NAME (#.331)
"RTN","DGDDDTTM",111,0)
 ;    E-RELATIONSHIP TO PATIENT    (#.332)
"RTN","DGDDDTTM",112,0)
 ;    E-STREET ADDRESS [LINE 1]    (#.333)
"RTN","DGDDDTTM",113,0)
 ;    E-STREET ADDRESS [LINE 2]    (#.334)
"RTN","DGDDDTTM",114,0)
 ;    E-STREET ADDRESS [LINE 3]    (#.335)
"RTN","DGDDDTTM",115,0)
 ;    E-CITY                       (#.336)
"RTN","DGDDDTTM",116,0)
 ;    E-STATE                      (#.337)
"RTN","DGDDDTTM",117,0)
 ;    E-ZIP CODE                   (#.338)
"RTN","DGDDDTTM",118,0)
 ;    E-EMER. CONTACT SAME AS NOK? (#.3305)
"RTN","DGDDDTTM",119,0)
 ;    E-ZIP+4                      (#.2201)
"RTN","DGDDDTTM",120,0)
 ;    E-PHONE NUMBER               (#.339)
"RTN","DGDDDTTM",121,0)
 ;    E-WORK PHONE NUMBER          (#.33011)
"RTN","DGDDDTTM",122,0)
 ;
"RTN","DGDDDTTM",123,0)
 N DGIEN,DATA S DATA(.33012)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",124,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",125,0)
 Q
"RTN","DGDDDTTM",126,0)
 ;
"RTN","DGDDDTTM",127,0)
ECON2 ; PATIENT File #2 Record Index: ADTTM6
"RTN","DGDDDTTM",128,0)
 ;
"RTN","DGDDDTTM",129,0)
 ; This code updates the E2-CONTACT CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",130,0)
 ; of the following Secondary Emergency Contact related data changes
"RTN","DGDDDTTM",131,0)
 ; for a patient:
"RTN","DGDDDTTM",132,0)
 ;
"RTN","DGDDDTTM",133,0)
 ;    E2-NAME OF SECONDARY CONTACT (#.3311)
"RTN","DGDDDTTM",134,0)
 ;    E2-RELATIONSHIP TO PATIENT   (#.3312)
"RTN","DGDDDTTM",135,0)
 ;    E2-STREET ADDRESS [LINE 1]   (#.3313)
"RTN","DGDDDTTM",136,0)
 ;    E2-STREET ADDRESS [LINE 2]   (#.3314)
"RTN","DGDDDTTM",137,0)
 ;    E2-STREET ADDRESS [LINE 3]   (#.3315)
"RTN","DGDDDTTM",138,0)
 ;    E2-CITY                      (#.3316)
"RTN","DGDDDTTM",139,0)
 ;    E2-STATE                     (#.3317)
"RTN","DGDDDTTM",140,0)
 ;    E2-ZIP CODE                  (#.3318)
"RTN","DGDDDTTM",141,0)
 ;    E2-ZIP+4                     (#.2204)
"RTN","DGDDDTTM",142,0)
 ;    E2-PHONE NUMBER              (#.3319)
"RTN","DGDDDTTM",143,0)
 ;    E2-WORK PHONE NUMBER         (#.331011)
"RTN","DGDDDTTM",144,0)
 ;
"RTN","DGDDDTTM",145,0)
 N DGIEN,DATA S DATA(.33112)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",146,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",147,0)
 Q
"RTN","DGDDDTTM",148,0)
 ;
"RTN","DGDDDTTM",149,0)
DESIG ; PATIENT File #2 Record Index: ADTTM7
"RTN","DGDDDTTM",150,0)
 ;
"RTN","DGDDDTTM",151,0)
 ; This code updates the DESIGNEE CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",152,0)
 ; of the following Designee related data changes for a patient:
"RTN","DGDDDTTM",153,0)
 ;
"RTN","DGDDDTTM",154,0)
 ;    D-NAME OF DESIGNEE        (#.341)
"RTN","DGDDDTTM",155,0)
 ;    D-RELATIONSHIP TO PATIENT (#.342)
"RTN","DGDDDTTM",156,0)
 ;    D-STREET ADDRESS [LINE 1] (#.343)
"RTN","DGDDDTTM",157,0)
 ;    D-STREET ADDRESS [LINE 2] (#.344)
"RTN","DGDDDTTM",158,0)
 ;    D-STREET ADDRESS [LINE 3] (#.345)
"RTN","DGDDDTTM",159,0)
 ;    D-CITY                    (#.346)
"RTN","DGDDDTTM",160,0)
 ;    D-STATE                   (#.347)
"RTN","DGDDDTTM",161,0)
 ;    D-ZIP CODE                (#.348)
"RTN","DGDDDTTM",162,0)
 ;    D-DESIGNEE SAME AS NOK?   (#.3405)
"RTN","DGDDDTTM",163,0)
 ;    D-ZIP+4                   (#.2202)
"RTN","DGDDDTTM",164,0)
 ;    D-PHONE NUMBER            (#.349)
"RTN","DGDDDTTM",165,0)
 ;    D-WORK PHONE NUMBER       (#.34011)
"RTN","DGDDDTTM",166,0)
 ;
"RTN","DGDDDTTM",167,0)
 N DGIEN,DATA S DATA(.3412)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",168,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",169,0)
 Q
"RTN","DGENDD")
0^1^B10373132
"RTN","DGENDD",1,0)
DGENDD ;ALB/CJM,JAN,LBD,AMA,ERC - Enrollment Data Dictionary Functions; 13 JUN 1997;6-28-01 ; 5/8/07 11:28am
"RTN","DGENDD",2,0)
 ;;5.3;Registration;**121,351,503,733,754**;Aug 13,1993;Build 46
"RTN","DGENDD",3,0)
 ;
"RTN","DGENDD",4,0)
SET1(DFN,DGENRIEN) ;
"RTN","DGENDD",5,0)
 ;Description: sets the "AENRC" X-ref on the patient file
"RTN","DGENDD",6,0)
 ;Inputs:
"RTN","DGENDD",7,0)
 ;  DFN - the patient ien
"RTN","DGENDD",8,0)
 ;  DGENRIEN - ien of current enrollment
"RTN","DGENDD",9,0)
 ;
"RTN","DGENDD",10,0)
 Q:'$G(DGENRIEN)
"RTN","DGENDD",11,0)
 Q:'$G(DFN)
"RTN","DGENDD",12,0)
 ;
"RTN","DGENDD",13,0)
 N STATUS
"RTN","DGENDD",14,0)
 S STATUS=$P($G(^DGEN(27.11,DGENRIEN,0)),"^",4)
"RTN","DGENDD",15,0)
 S:STATUS ^DPT("AENRC",STATUS,DFN)=""
"RTN","DGENDD",16,0)
 ;
"RTN","DGENDD",17,0)
 Q
"RTN","DGENDD",18,0)
 ;
"RTN","DGENDD",19,0)
KILL1(DFN) ;
"RTN","DGENDD",20,0)
 ;Description: This is the kill logic that corresponds to SET1.
"RTN","DGENDD",21,0)
 ;Input: DFN is the patient ien
"RTN","DGENDD",22,0)
 ;
"RTN","DGENDD",23,0)
 Q:'$G(DFN)
"RTN","DGENDD",24,0)
 ;
"RTN","DGENDD",25,0)
 N DGSTATUS,STATUS
"RTN","DGENDD",26,0)
 S DGSTATUS=$P(^DGEN(27.15,0),U,3)
"RTN","DGENDD",27,0)
 F STATUS=1:1:DGSTATUS K ^DPT("AENRC",STATUS,DFN)
"RTN","DGENDD",28,0)
 Q
"RTN","DGENDD",29,0)
 ;
"RTN","DGENDD",30,0)
SET2(DGENRIEN,STATUS) ;
"RTN","DGENDD",31,0)
 ;Description: This MUMPS x-ref on the Patient Enrollment file sets the
"RTN","DGENDD",32,0)
 ;  "AENRC" X-ref on the patient file.
"RTN","DGENDD",33,0)
 ;Inputs:
"RTN","DGENDD",34,0)
 ;  DGENRIEN - enrollment ien
"RTN","DGENDD",35,0)
 ;  STATUS - the enrollment status
"RTN","DGENDD",36,0)
 ;
"RTN","DGENDD",37,0)
 Q:'$G(DGENRIEN)
"RTN","DGENDD",38,0)
 Q:'$G(STATUS)
"RTN","DGENDD",39,0)
 ;
"RTN","DGENDD",40,0)
 N DFN
"RTN","DGENDD",41,0)
 S DFN=$P($G(^DGEN(27.11,DGENRIEN,0)),"^",2)
"RTN","DGENDD",42,0)
 Q:'DFN
"RTN","DGENDD",43,0)
 I $$FINDCUR^DGENA(DFN)=DGENRIEN D
"RTN","DGENDD",44,0)
 . S ^DPT("AENRC",STATUS,DFN)=""
"RTN","DGENDD",45,0)
 ;
"RTN","DGENDD",46,0)
 Q
"RTN","DGENDD",47,0)
 ;
"RTN","DGENDD",48,0)
KILL2(DGENRIEN,STATUS) ;
"RTN","DGENDD",49,0)
 ;Description: This is the kill logic that corresponds to SET2.
"RTN","DGENDD",50,0)
 ;Inputs:
"RTN","DGENDD",51,0)
 ;  DGENRIEN - enrollment ien
"RTN","DGENDD",52,0)
 ;  STATUS - the enrollment status
"RTN","DGENDD",53,0)
 ;
"RTN","DGENDD",54,0)
 Q:'$G(DGENRIEN)
"RTN","DGENDD",55,0)
 Q:'$G(STATUS)
"RTN","DGENDD",56,0)
 ;
"RTN","DGENDD",57,0)
 N DFN
"RTN","DGENDD",58,0)
 S DFN=$P($G(^DGEN(27.11,DGENRIEN,0)),"^",2)
"RTN","DGENDD",59,0)
 Q:'DFN
"RTN","DGENDD",60,0)
 I $$FINDCUR^DGENA(DFN)=DGENRIEN D
"RTN","DGENDD",61,0)
 . K ^DPT("AENRC",STATUS,DFN)
"RTN","DGENDD",62,0)
 Q
"RTN","DGENDD",63,0)
 ;
"RTN","DGENDD",64,0)
SETREM(DGENRIEN,STATUS) ;
"RTN","DGENDD",65,0)
 ;This set logic is called by the Enrollment Status field (#.04) in 
"RTN","DGENDD",66,0)
 ;the Patient Enrollment file (#27.11).  If the Enrollment Status
"RTN","DGENDD",67,0)
 ;contains the word REJECTED, then "**REJECTED**" will be stuffed
"RTN","DGENDD",68,0)
 ;into the Remarks field (#.091) of the Patient file (#2).  If the
"RTN","DGENDD",69,0)
 ;Enrollment Status does not contain REJECTED, then the word
"RTN","DGENDD",70,0)
 ;"**REJECTED**" will be removed.
"RTN","DGENDD",71,0)
 ;Input:
"RTN","DGENDD",72,0)
 ;  DGENRIEN - IEN of the enrollment record
"RTN","DGENDD",73,0)
 ;  STATUS - enrollment status
"RTN","DGENDD",74,0)
 ;
"RTN","DGENDD",75,0)
 Q:'$G(DGENRIEN)
"RTN","DGENDD",76,0)
 Q:'$G(STATUS)
"RTN","DGENDD",77,0)
 ;
"RTN","DGENDD",78,0)
 N DFN,REM
"RTN","DGENDD",79,0)
 S DFN=$P($G(^DGEN(27.11,DGENRIEN,0)),U,2)
"RTN","DGENDD",80,0)
 Q:'DFN  Q:$G(^DPT(DFN,0))=""
"RTN","DGENDD",81,0)
 L +^DPT(DFN,0):5 I '$T Q
"RTN","DGENDD",82,0)
 S REM=$P(^DPT(DFN,0),U,10)
"RTN","DGENDD",83,0)
 ;The enrollment status contains REJECTED, set REMARKS
"RTN","DGENDD",84,0)
 I "^11^12^13^14^22^"[(U_STATUS_U) D  G SETREMQ
"RTN","DGENDD",85,0)
 . I REM["**REJECTED**" Q  ;Remarks already contain REJECTED
"RTN","DGENDD",86,0)
 . S REM=REM_"**REJECTED**"
"RTN","DGENDD",87,0)
 . S $P(^DPT(DFN,0),U,10)=REM
"RTN","DGENDD",88,0)
 ;The enrollment status does not contain REJECTED, remove REMARKS
"RTN","DGENDD",89,0)
 I REM'["**REJECTED**" G SETREMQ
"RTN","DGENDD",90,0)
 S REM=$P(REM,"**REJECTED**",1)_$P(REM,"**REJECTED**",2,99)
"RTN","DGENDD",91,0)
 S $P(^DPT(DFN,0),U,10)=REM
"RTN","DGENDD",92,0)
SETREMQ L -^DPT(DFN,0)
"RTN","DGENDD",93,0)
 Q
"RTN","DGENDD",94,0)
 ;
"RTN","DGENDD",95,0)
CSI1010(DA) ;
"RTN","DGENDD",96,0)
 ;If COMBAT SERVICE INDICATED? (2/.5291) is "NO,"
"RTN","DGENDD",97,0)
 ;set COMBAT INDICATED ON 1010EZ (2/1010.157) to "NO."
"RTN","DGENDD",98,0)
 I $P($G(^DPT(DA,.52)),U,11)="N" D
"RTN","DGENDD",99,0)
 . N DGFDA
"RTN","DGENDD",100,0)
 . S DGFDA(2,DA_",",1010.157)=0
"RTN","DGENDD",101,0)
 . D FILE^DIE(,"DGFDA")
"RTN","DGENDD",102,0)
 Q
"RTN","DGENDD",103,0)
 ;
"RTN","DGENDD",104,0)
CTD1010(DA) ;
"RTN","DGENDD",105,0)
 ;If COMBAT SERVICE INDICATED? (2/.5291) is "YES" and
"RTN","DGENDD",106,0)
 ;COMBAT TO DATE (2/.5294) is greater than 11/11/1998,
"RTN","DGENDD",107,0)
 ;set COMBAT INDICATED ON 1010EZ (2/1010.157) to "YES."
"RTN","DGENDD",108,0)
 N NODE,ANS,DGFDA
"RTN","DGENDD",109,0)
 S NODE=$G(^DPT(DA,.52)),ANS=0
"RTN","DGENDD",110,0)
 I ($P(NODE,U,11)="Y"),($P(NODE,U,14)>2981111) S ANS=1
"RTN","DGENDD",111,0)
 S DGFDA(2,DA_",",1010.157)=ANS
"RTN","DGENDD",112,0)
 D FILE^DIE(,"DGFDA")
"RTN","DGENDD",113,0)
 Q
"RTN","DGENDD",114,0)
ENRAPP ;check to see if the Enrollment Application Date (.01 of file 27.11)
"RTN","DGENDD",115,0)
 ;is before 10/1/1996 or before DOB or after DOD
"RTN","DGENDD",116,0)
 N DGFLD
"RTN","DGENDD",117,0)
 S DGFLD=$P(^DD(27.11,.01,0),U)
"RTN","DGENDD",118,0)
 I $G(X)<2961001 D EN^DDIOL(DGFLD_" must not be before 10/1/1996.",,"!!!") K X Q
"RTN","DGENDD",119,0)
 I $G(X)<$P(^DPT(DFN,0),U,3) D EN^DDIOL(DGFLD_" cannot be before Date of Birth.") K X Q
"RTN","DGENDD",120,0)
 I $P($G(^DPT(DFN,.35)),U)>0,($G(X)>$P(^DPT(DFN,.35),U)) D
"RTN","DGENDD",121,0)
 . D EN^DDIOL(DGFLD_" cannot be after Date of Death.") K X
"RTN","DGENDD",122,0)
 Q
"RTN","DGENEGT1")
0^28^B67955645
"RTN","DGENEGT1",1,0)
DGENEGT1 ;ALB/KCL,ISA/KWP,LBD,RGL,BRM,DLF,TDM - Enrollment Group Threshold API's ; 6/17/09 11:05am
"RTN","DGENEGT1",2,0)
 ;;5.3;Registration;**232,417,454,491,513,451,564,672,717,688,803,754**;Aug 13, 1993;Build 46
"RTN","DGENEGT1",3,0)
 ;
"RTN","DGENEGT1",4,0)
 ;
"RTN","DGENEGT1",5,0)
NOTIFY(DGEGT,OLDEGT) ;
"RTN","DGENEGT1",6,0)
 ; Description: This is used to send a message to local mail group.
"RTN","DGENEGT1",7,0)
 ; The notification is used to communicate changes in the Enrollment
"RTN","DGENEGT1",8,0)
 ; Group Threshold (EGT) setting to users at the local site.
"RTN","DGENEGT1",9,0)
 ;
"RTN","DGENEGT1",10,0)
 ;  Input:
"RTN","DGENEGT1",11,0)
 ;    DGEGT - the new Enrollment Group Threshold array, passed by reference
"RTN","DGENEGT1",12,0)
 ;   OLDEGT - the previous Enrollment Group Threshold array, passed by reference
"RTN","DGENEGT1",13,0)
 ;
"RTN","DGENEGT1",14,0)
 ; Output: None
"RTN","DGENEGT1",15,0)
 ;
"RTN","DGENEGT1",16,0)
 N TEXT,XMDUN,XMDUZ,XMTEXT,XMROU,XMSTRIP,XMSUB,XMY,XMZ,OLDPRI
"RTN","DGENEGT1",17,0)
 ;
"RTN","DGENEGT1",18,0)
 ; init subject and sender
"RTN","DGENEGT1",19,0)
 S XMSUB="Enrollment Group Threshold (EGT) Changed"
"RTN","DGENEGT1",20,0)
 S (XMDUN,XMDUZ)="Registration Enrollment Module"
"RTN","DGENEGT1",21,0)
 ;
"RTN","DGENEGT1",22,0)
 ; recipient
"RTN","DGENEGT1",23,0)
 S XMY("G.DGEN EGT UPDATES")=""
"RTN","DGENEGT1",24,0)
 ;
"RTN","DGENEGT1",25,0)
 ; get old EGT priority
"RTN","DGENEGT1",26,0)
 S OLDPRI=$G(OLDEGT("PRIORITY"))
"RTN","DGENEGT1",27,0)
 ;
"RTN","DGENEGT1",28,0)
 S XMTEXT="TEXT("
"RTN","DGENEGT1",29,0)
 S TEXT(1)="The Secretary of the VA has officially changed the enrollment priority"
"RTN","DGENEGT1",30,0)
 S TEXT(2)="grouping of veterans who shall receive care.  This change may place"
"RTN","DGENEGT1",31,0)
 S TEXT(3)="veterans under your facilities care into a 'Not Enrolled' category."
"RTN","DGENEGT1",32,0)
 S TEXT(4)=""
"RTN","DGENEGT1",33,0)
 S TEXT(5)=""
"RTN","DGENEGT1",34,0)
 S TEXT(6)="           Prior EGT Priority:  "_$S($G(OLDPRI):$$EXTERNAL^DILFD(27.16,.02,"F",OLDPRI),1:"N/A")_$S($G(OLDEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",OLDEGT("SUBGRP")),1:"")
"RTN","DGENEGT1",35,0)
 S TEXT(7)=""
"RTN","DGENEGT1",36,0)
 S TEXT(8)=""
"RTN","DGENEGT1",37,0)
 S TEXT(9)="  New Enrollment Group Threshold (EGT) Settings:"
"RTN","DGENEGT1",38,0)
 S TEXT(10)=""
"RTN","DGENEGT1",39,0)
 S TEXT(11)="                 EGT Priority:  "_$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY"))_$S($G(DGEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP")),1:"")
"RTN","DGENEGT1",40,0)
 S TEXT(12)="                     EGT Type:  "_$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE"))
"RTN","DGENEGT1",41,0)
 S TEXT(13)="           EGT Effective Date:  "_$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("EFFDATE"))
"RTN","DGENEGT1",42,0)
 ;
"RTN","DGENEGT1",43,0)
 ; mailman deliverey
"RTN","DGENEGT1",44,0)
 D ^XMD
"RTN","DGENEGT1",45,0)
 ;
"RTN","DGENEGT1",46,0)
 Q
"RTN","DGENEGT1",47,0)
 ;
"RTN","DGENEGT1",48,0)
 ;
"RTN","DGENEGT1",49,0)
DISPLAY() ;
"RTN","DGENEGT1",50,0)
 ; Description: Display Enrollment Group Threshold (EGT) settings.
"RTN","DGENEGT1",51,0)
 ;
"RTN","DGENEGT1",52,0)
 N DGEGT
"RTN","DGENEGT1",53,0)
 ;
"RTN","DGENEGT1",54,0)
 W !
"RTN","DGENEGT1",55,0)
 I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT) W !,"Enrollment Group Threshold (EGT) settings not found."
"RTN","DGENEGT1",56,0)
 E  D
"RTN","DGENEGT1",57,0)
 .W !,?3,"Enrollment Group Threshold (EGT) Settings"
"RTN","DGENEGT1",58,0)
 .W !,?3,"========================================="
"RTN","DGENEGT1",59,0)
 .W !
"RTN","DGENEGT1",60,0)
 .W !?5,"Date Entered",?25,": ",$S('$G(DGEGT("ENTERED")):"-none-",1:$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("ENTERED")))
"RTN","DGENEGT1",61,0)
 .W !?5,"EGT Priority",?25,": ",$S('$G(DGEGT("PRIORITY")):"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY")))_$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP")))
"RTN","DGENEGT1",62,0)
 .W !?5,"EGT Type",?25,": ",$S($G(DGEGT("TYPE"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE")))
"RTN","DGENEGT1",63,0)
 .W !?5,"EGT Effective Date",?25,": ",$S('$G(DGEGT("EFFDATE")):"-none-",1:$$EXTERNAL^DILFD(27.16,.05,"F",DGEGT("EFFDATE")))
"RTN","DGENEGT1",64,0)
 ;
"RTN","DGENEGT1",65,0)
 Q
"RTN","DGENEGT1",66,0)
 ;
"RTN","DGENEGT1",67,0)
ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ;
"RTN","DGENEGT1",68,0)
 ; Description: This function will determine if the enrollment is above
"RTN","DGENEGT1",69,0)
 ; the threshold.
"RTN","DGENEGT1",70,0)
 ;
"RTN","DGENEGT1",71,0)
 ;Input:
"RTN","DGENEGT1",72,0)
 ; DPTDFN - Patient File IEN
"RTN","DGENEGT1",73,0)
 ; ENRPRI - Enrollment Priority
"RTN","DGENEGT1",74,0)
 ; ENRGRP - Enrollment Sub-Group
"RTN","DGENEGT1",75,0)
 ; EGTPRI - EGT Priority (optional) - not used
"RTN","DGENEGT1",76,0)
 ; EGTGRP - EGT Sub-Group (optional) - not used
"RTN","DGENEGT1",77,0)
 ; EGTFLG - Flag to bypass additional EGT type 2 check (optional)
"RTN","DGENEGT1",78,0)
 ;          It is used by $$ABOVE2 to prevent re-entering the
"RTN","DGENEGT1",79,0)
 ;          sub-priority API ($$SUBPRI^DGENELA4)
"RTN","DGENEGT1",80,0)
 ; Output:
"RTN","DGENEGT1",81,0)
 ; Returns 1 if above 0 below. 
"RTN","DGENEGT1",82,0)
 ;
"RTN","DGENEGT1",83,0)
 I $G(ENRGRP)="" S ENRGRP=""
"RTN","DGENEGT1",84,0)
 I $G(ENRPRI)="" S ENRPRI=""
"RTN","DGENEGT1",85,0)
 N ABOVE,EGT,TODAY,X
"RTN","DGENEGT1",86,0)
 I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) Q 1
"RTN","DGENEGT1",87,0)
 D NOW^%DTC S TODAY=X
"RTN","DGENEGT1",88,0)
 I TODAY<EGT("EFFDATE") Q 1
"RTN","DGENEGT1",89,0)
 ;
"RTN","DGENEGT1",90,0)
 ;EGT type 2 - Stop New Enrollments
"RTN","DGENEGT1",91,0)
 ; or EGT type 4 - Enrollment Decision (ESP DG*5.3*491)
"RTN","DGENEGT1",92,0)
 I EGT("TYPE")=2!(EGT("TYPE")=4) D  Q ABOVE
"RTN","DGENEGT1",93,0)
 .S ABOVE=0
"RTN","DGENEGT1",94,0)
 .I ENRPRI<7 D  Q
"RTN","DGENEGT1",95,0)
 ..I ENRPRI'>EGT("PRIORITY") S ABOVE=1 Q
"RTN","DGENEGT1",96,0)
 .;do check for priorities 7 and 8
"RTN","DGENEGT1",97,0)
 .I ENRPRI<EGT("PRIORITY") S ABOVE=1 Q
"RTN","DGENEGT1",98,0)
 .I ENRGRP'>EGT("SUBGRP") S ABOVE=1 Q
"RTN","DGENEGT1",99,0)
 .I $$OVRRIDE(.DPTDFN,.EGT) S ABOVE=1
"RTN","DGENEGT1",100,0)
 ;
"RTN","DGENEGT1",101,0)
 ;EGT types 1 & 3
"RTN","DGENEGT1",102,0)
 ;do check for priorities 7 and 8
"RTN","DGENEGT1",103,0)
 I ENRPRI>6&(ENRPRI=EGT("PRIORITY")) S ABOVE=0 D  Q ABOVE
"RTN","DGENEGT1",104,0)
 .I ENRGRP'>(EGT("SUBGRP")) S ABOVE=1
"RTN","DGENEGT1",105,0)
 I ENRPRI'>(EGT("PRIORITY")) Q 1
"RTN","DGENEGT1",106,0)
 Q 0
"RTN","DGENEGT1",107,0)
 ;
"RTN","DGENEGT1",108,0)
ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ;
"RTN","DGENEGT1",109,0)
 ;
"RTN","DGENEGT1",110,0)
 ; Input: DPTDFN    - Patient File IEN
"RTN","DGENEGT1",111,0)
 ;        ENRDT     - enrollment effective date
"RTN","DGENEGT1",112,0)
 ;        PRIORITY  - enrollment priority
"RTN","DGENEGT1",113,0)
 ;        SUBGRP    - enrollment sub-priority (internal numeric value)
"RTN","DGENEGT1",114,0)
 ;
"RTN","DGENEGT1",115,0)
 ; Output: 1 or 0 for above or below EGT threshold
"RTN","DGENEGT1",116,0)
 ;
"RTN","DGENEGT1",117,0)
 N ABOVE,TODAY,X,EGT
"RTN","DGENEGT1",118,0)
 S ABOVE=1
"RTN","DGENEGT1",119,0)
 S:'$G(SUBGRP) SUBGRP=""
"RTN","DGENEGT1",120,0)
 S:'$G(PRIORITY) PRIORITY=""
"RTN","DGENEGT1",121,0)
 S:'$G(ENRDT) ENRDT=""
"RTN","DGENEGT1",122,0)
 D NOW^%DTC S TODAY=X
"RTN","DGENEGT1",123,0)
 Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT) 1
"RTN","DGENEGT1",124,0)
 Q:'$G(EGT("EFFDATE")) 1
"RTN","DGENEGT1",125,0)
 Q:TODAY<EGT("EFFDATE") 1
"RTN","DGENEGT1",126,0)
 Q:EGT("TYPE")#2 $$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1)  ;If EGT type 1 or 3
"RTN","DGENEGT1",127,0)
 I '$$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) Q 0
"RTN","DGENEGT1",128,0)
 Q ABOVE
"RTN","DGENEGT1",129,0)
 ;
"RTN","DGENEGT1",130,0)
OVRRIDE(DPTDFN,EGT) ;check for previous EGT override by HEC and new rules
"RTN","DGENEGT1",131,0)
 N CVDT,ENRCAT,ENRDT,EGTENR,ENRIEN,DGPAT,STOP,CUR,CE
"RTN","DGENEGT1",132,0)
 S (STOP,CUR)=0
"RTN","DGENEGT1",133,0)
 I '$$GET^DGENELA(DPTDFN,.DGPAT) Q 0  ;Get current Patient file data
"RTN","DGENEGT1",134,0)
 ; Find most recent enrollment record
"RTN","DGENEGT1",135,0)
 S ENRIEN=$$FINDCUR^DGENA(.DPTDFN)
"RTN","DGENEGT1",136,0)
 F  Q:STOP!CUR  D
"RTN","DGENEGT1",137,0)
 .I 'ENRIEN S STOP=1 Q  ;cannot check if no current enrollment
"RTN","DGENEGT1",138,0)
 .I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q  ;need enr info to proceed
"RTN","DGENEGT1",139,0)
 .S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
"RTN","DGENEGT1",140,0)
 .; If status is Pending, Deceased, Not Eligible, or Not Applicable
"RTN","DGENEGT1",141,0)
 .; ignore record and get previous
"RTN","DGENEGT1",142,0)
 .I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
"RTN","DGENEGT1",143,0)
 .S CUR=1
"RTN","DGENEGT1",144,0)
 I STOP Q 0
"RTN","DGENEGT1",145,0)
 S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
"RTN","DGENEGT1",146,0)
 S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
"RTN","DGENEGT1",147,0)
 ; If enrollment status was overridden at HEC, then cont. enroll.
"RTN","DGENEGT1",148,0)
 I EGTENR("SOURCE")=2,ENRDT'<EGT("EFFDATE"),ENRCAT="E" Q 1
"RTN","DGENEGT1",149,0)
 ; If status is Rejected or Cancelled/Declined, quit (no cont. enroll.)
"RTN","DGENEGT1",150,0)
 I "^4^7^11^12^13^22^"[(U_EGTENR("STATUS")_U) Q 0
"RTN","DGENEGT1",151,0)
 ; If Application Date or Effective Date of Change are prior to the
"RTN","DGENEGT1",152,0)
 ; EGT Effective Date then cont. enroll.
"RTN","DGENEGT1",153,0)
 I ENRDT<EGT("EFFDATE") Q 1
"RTN","DGENEGT1",154,0)
 ; If Enrollment Record is Verified, and meets one of the special CE
"RTN","DGENEGT1",155,0)
 ; rules, then cont. enroll.
"RTN","DGENEGT1",156,0)
 I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE Q CE>0
"RTN","DGENEGT1",157,0)
 ; Check previous enrollment records for Application Date/Effective
"RTN","DGENEGT1",158,0)
 ; Date and special CE rules
"RTN","DGENEGT1",159,0)
 S (STOP,CE)=0
"RTN","DGENEGT1",160,0)
 F  Q:STOP  D
"RTN","DGENEGT1",161,0)
 .I 'ENRIEN S STOP=1 Q  ;cannot check if no current enrollment
"RTN","DGENEGT1",162,0)
 .I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q  ;need enr info to proceed
"RTN","DGENEGT1",163,0)
 .S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
"RTN","DGENEGT1",164,0)
 .; If status is Pending, Deceased, Not Eligible; Ineligible Date,
"RTN","DGENEGT1",165,0)
 .; or Not Applicable ignore record and get previous
"RTN","DGENEGT1",166,0)
 .I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
"RTN","DGENEGT1",167,0)
 .S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
"RTN","DGENEGT1",168,0)
 .S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
"RTN","DGENEGT1",169,0)
 .; If Application Date or Effective Date of Change are prior to the
"RTN","DGENEGT1",170,0)
 .; EGT Effective Date then cont. enroll.
"RTN","DGENEGT1",171,0)
 .I ENRDT<EGT("EFFDATE") S (STOP,CE)=1 Q
"RTN","DGENEGT1",172,0)
 .; If Enrollment Record is Verified, and meets one of the special CE
"RTN","DGENEGT1",173,0)
 .; rules, then cont. enroll.
"RTN","DGENEGT1",174,0)
 .I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE S STOP=1,CE=CE>0 Q
"RTN","DGENEGT1",175,0)
 Q CE
"RTN","DGENEGT1",176,0)
 ;
"RTN","DGENEGT1",177,0)
RULES(DPTDFN,EGTENR,EGT,DGPAT) ;check for new cont enrollment rules (DG*5.3*672)
"RTN","DGENEGT1",178,0)
 N RTN,STAEXP
"RTN","DGENEGT1",179,0)
 ; If veteran ever had a verified enrollment with SC 10%+ and is now
"RTN","DGENEGT1",180,0)
 ; SC 0% non-compensable then cont. enroll
"RTN","DGENEGT1",181,0)
 I EGTENR("ELIG","VACKAMT")&(EGTENR("ELIG","SCPER")>9)&(DGPAT("SCPER")=0)&(DGPAT("VACKAMT")'>0) Q 1
"RTN","DGENEGT1",182,0)
 ; If veteran ever had a verified enrollment with one of these
"RTN","DGENEGT1",183,0)
 ; eligibilities then cont. enroll:  AA, HB, VA Pension
"RTN","DGENEGT1",184,0)
 I EGTENR("ELIG","VACKAMT")&((EGTENR("ELIG","A&A")="Y")!(EGTENR("ELIG","HB")="Y")!(EGTENR("ELIG","VAPEN")="Y")) Q 1
"RTN","DGENEGT1",185,0)
 ; If AO Exposure Location = Korean DMZ prior to ESR implementation,
"RTN","DGENEGT1",186,0)
 ; or AO Exposure Location = Vietnam prior to Special Treatment
"RTN","DGENEGT1",187,0)
 ;    Authority (STA) termination
"RTN","DGENEGT1",188,0)
 ; then cont. enroll.
"RTN","DGENEGT1",189,0)
 ; **** NOTE: For patch DG*5.3*672 the ESR implementation date will
"RTN","DGENEGT1",190,0)
 ; be set to 12/29/2040.  This will be changed to the actual ESR
"RTN","DGENEGT1",191,0)
 ; implementation date in a later patch.
"RTN","DGENEGT1",192,0)
 ; DG*5.3*688 - Date changed to 3/21/2009
"RTN","DGENEGT1",193,0)
 I DGPAT("AO")="Y" D  I $G(RTN) Q RTN
"RTN","DGENEGT1",194,0)
 .I $S($D(EGTENR("ELIG","AOEXPLOC")):EGTENR("ELIG","AOEXPLOC"),1:DGPAT("AOEXPLOC"))="K",EGTENR("EFFDATE"),EGTENR("EFFDATE")<3090321 S RTN=1
"RTN","DGENEGT1",195,0)
 .I EGTENR("ELIG","AOEXPLOC")="V" D   ;Added with DG*5.3*754
"RTN","DGENEGT1",196,0)
 ..S STAEXP=$$STAEXP^DGENELA4("AO") Q:STAEXP<1
"RTN","DGENEGT1",197,0)
 ..I EGTENR("EFFDATE"),EGTENR("EFFDATE")<STAEXP S RTN=1
"RTN","DGENEGT1",198,0)
 ; If SWAC/EC = YES prior to Special Treatment (STA) termination
"RTN","DGENEGT1",199,0)
 ; then cont. enroll.
"RTN","DGENEGT1",200,0)
 I DGPAT("EC")="Y" D  I $G(RTN) Q RTN   ;Added with DG*5.3*754
"RTN","DGENEGT1",201,0)
 .Q:EGTENR("ELIG","EC")'="Y"
"RTN","DGENEGT1",202,0)
 .S STAEXP=$$STAEXP^DGENELA4("EC") Q:STAEXP<1
"RTN","DGENEGT1",203,0)
 .I EGTENR("EFFDATE"),EGTENR("EFFDATE")<STAEXP S RTN=1
"RTN","DGENEGT1",204,0)
 ; If combat vet end date is before application date, cont. enroll
"RTN","DGENEGT1",205,0)
 I $G(EGTENR("ELIG","CVELEDT"))'<ENRDT Q 1
"RTN","DGENEGT1",206,0)
 ; If veteran is enrolled due to MT status or Medicaid, cont. enroll
"RTN","DGENEGT1",207,0)
 ; UNLESS first verified enrollment record is due to MT status or
"RTN","DGENEGT1",208,0)
 ; Medicaid and the primary MT of that income year was changed to a
"RTN","DGENEGT1",209,0)
 ; status that would not enroll (e.g. due to IVM converted test,
"RTN","DGENEGT1",210,0)
 ; Hardship removal, or Medicaid removal).
"RTN","DGENEGT1",211,0)
 I ((EGTENR("PRIORITY")=7!EGTENR("PRIORITY")=8)&("^2^16^"[(U_EGTENR("ELIG","MTSTA")_U)))!((EGTENR("PRIORITY")=5)&((EGTENR("ELIG","MTSTA")=4)!(EGTENR("ELIG","MEDICAID")=1))) S RTN=1 D  Q RTN
"RTN","DGENEGT1",212,0)
 .N ENIEN,ENR,MTDT,MTIEN
"RTN","DGENEGT1",213,0)
 .S ENIEN=0 F  S ENIEN=$O(^DGEN(27.11,"C",+DPTDFN,ENIEN)) Q:'ENIEN  I $P($G(^DGEN(27.11,+ENIEN,0)),U,4)=2 D  Q
"RTN","DGENEGT1",214,0)
 ..I '$$GET^DGENA(ENIEN,.ENR) Q
"RTN","DGENEGT1",215,0)
 ..I ((ENR("PRIORITY")=7!ENR("PRIORITY")=8)&("^2^16^"[(U_ENR("ELIG","MTSTA")_U)))!((ENR("PRIORITY")=5)&(ENR("ELIG","VAPEN")'="Y")&((ENR("ELIG","MTSTA")=4)!(ENR("ELIG","MEDICAID")=1))) D
"RTN","DGENEGT1",216,0)
 ...S MTDT=$E(ENR("APP"),1,3)_"1231",MTIEN=$$LST^DGMTU(MTDT) Q:'MTIEN
"RTN","DGENEGT1",217,0)
 ...I $P($G(^DGMT(408.31,MTIEN,0)),U,3)=6 S RTN=-1
"RTN","DGENEGT1",218,0)
 Q 0
"RTN","DGENEGT1",219,0)
 ;
"RTN","DGENEGT1",220,0)
EDATE(APP,EFF) ; Compare the Application Date and Effective Date and
"RTN","DGENEGT1",221,0)
 ; return the earlier date
"RTN","DGENEGT1",222,0)
 N EDT
"RTN","DGENEGT1",223,0)
 S APP=$G(APP),EFF=$G(EFF)
"RTN","DGENEGT1",224,0)
 S EDT=APP I 'EDT S EDT=EFF Q EDT
"RTN","DGENEGT1",225,0)
 I EFF S:EFF<EDT EDT=EFF
"RTN","DGENEGT1",226,0)
 Q EDT
"RTN","DGENELA4")
0^29^B68278282
"RTN","DGENELA4",1,0)
DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN,DLF,TDM - Patient Eligibility API ; 11/10/09 10:48am
"RTN","DGENELA4",2,0)
 ;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653,688,803,754**;Aug 13,1993;Build 46
"RTN","DGENELA4",3,0)
 ;
"RTN","DGENELA4",4,0)
 ;
"RTN","DGENELA4",5,0)
PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE) ;
"RTN","DGENELA4",6,0)
 ; Description: Used to compute the priority group and subgroup for a
"RTN","DGENELA4",7,0)
 ; patient, also returning the subset of the eligibility data on which 
"RTN","DGENELA4",8,0)
 ; the priority subgroup is based.
"RTN","DGENELA4",9,0)
 ;
"RTN","DGENELA4",10,0)
 ;Input:
"RTN","DGENELA4",11,0)
 ;      DFN - ien of patient
"RTN","DGENELA4",12,0)
 ;    DGELG - ELIGIBILITY object array (optional, pass by reference)
"RTN","DGENELA4",13,0)
 ;  ENRDATE - The Enrollment Date. This date is used in the priority
"RTN","DGENELA4",14,0)
 ;            determination only if the application date is not passed.
"RTN","DGENELA4",15,0)
 ;  APPDATE - The Enrollment Application Date.  This date is used
"RTN","DGENELA4",16,0)
 ;            to determine the priority. If the application date
"RTN","DGENELA4",17,0)
 ;            is not passed then the enrollment date (ENRDATE) is used.
"RTN","DGENELA4",18,0)
 ;
"RTN","DGENELA4",19,0)
 ;Output:
"RTN","DGENELA4",20,0)
 ;  Function Value - returns the priority and subgroup computed by the
"RTN","DGENELA4",21,0)
 ;    function as a 2 piece string 'PRIORITY^SUBGROUP'
"RTN","DGENELA4",22,0)
 ;  DGELGSUB - this local array will contain the eligibility data on
"RTN","DGENELA4",23,0)
 ;    which the priority determination was based, pass by reference
"RTN","DGENELA4",24,0)
 ;    if needed.
"RTN","DGENELA4",25,0)
 ;
"RTN","DGENELA4",26,0)
 N CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
"RTN","DGENELA4",27,0)
 K DGELGSUB S DGELGSUB=""
"RTN","DGENELA4",28,0)
 S (HICODE,HIPRI,SUBGRP,HISUB)=""
"RTN","DGENELA4",29,0)
 D
"RTN","DGENELA4",30,0)
 .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q  ;can not proceed with eligibility
"RTN","DGENELA4",31,0)
 .; can't proceed without an Enrollment Date or Application Date
"RTN","DGENELA4",32,0)
 .I '$G(ENRDATE),'$G(APPDATE) Q
"RTN","DGENELA4",33,0)
 .I $$GET^DGENPTA(DFN,.DGPAT)
"RTN","DGENELA4",34,0)
 .; determine priority/subgroup based on primary eligibility
"RTN","DGENELA4",35,0)
 .S HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
"RTN","DGENELA4",36,0)
 .S PRIORITY=$$PRI(HICODE,.DGELG,$G(ENRDATE),$G(APPDATE))
"RTN","DGENELA4",37,0)
 .S HIPRI=$P(PRIORITY,"^"),HISUB=$P(PRIORITY,"^",2)
"RTN","DGENELA4",38,0)
 .S CODE=""
"RTN","DGENELA4",39,0)
 .;
"RTN","DGENELA4",40,0)
 .; determine if other eligibilities result in higher priority/subgroup
"RTN","DGENELA4",41,0)
 .F  S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:('CODE!(HIPRI=1))  D
"RTN","DGENELA4",42,0)
 ..S PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$G(ENRDATE),$G(APPDATE))
"RTN","DGENELA4",43,0)
 ..S PRI=$P(PRIORITY,"^"),SUB=$P(PRIORITY,"^",2)
"RTN","DGENELA4",44,0)
 ..S:((PRI>0)&((PRI<HIPRI)!(HIPRI=""))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
"RTN","DGENELA4",45,0)
 ..S:((PRI=HIPRI)&((SUB>0)&(SUB<HISUB))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
"RTN","DGENELA4",46,0)
 .;
"RTN","DGENELA4",47,0)
 .;set the DGELGSUB() array with the eligibility information used in the
"RTN","DGENELA4",48,0)
 .;priority determination
"RTN","DGENELA4",49,0)
 .S DGELGSUB("CODE")=HICODE,DGELGSUB("SC")=DGELG("SC"),DGELGSUB("SCPER")=DGELG("SCPER"),DGELGSUB("POW")=DGELG("POW"),DGELGSUB("A&A")=DGELG("A&A"),DGELGSUB("HB")=DGELG("HB")
"RTN","DGENELA4",50,0)
 .S DGELGSUB("VAPEN")=DGELG("VAPEN"),DGELGSUB("VACKAMT")=DGELG("VACKAMT"),DGELGSUB("DISRET")=DGELG("DISRET"),DGELGSUB("DISLOD")=DGELG("DISLOD")
"RTN","DGENELA4",51,0)
 .S DGELGSUB("MEDICAID")=DGELG("MEDICAID"),DGELGSUB("AO")=DGELG("AO"),DGELGSUB("IR")=DGELG("IR"),DGELGSUB("EC")=DGELG("EC"),DGELGSUB("MTSTA")=DGELG("MTSTA")
"RTN","DGENELA4",52,0)
 .;Purple Heart Added to DGELGSUB
"RTN","DGENELA4",53,0)
 .S DGELGSUB("VCD")=DGELG("VCD"),DGELGSUB("PH")=DGELG("PH")
"RTN","DGENELA4",54,0)
 .;Added for HVE Phase III (DG*5.3*564)
"RTN","DGENELA4",55,0)
 .S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("CVELEDT")=DGELG("CVELEDT"),DGELGSUB("SHAD")=DGELG("SHAD")
"RTN","DGENELA4",56,0)
 .;added dg*5.3*659
"RTN","DGENELA4",57,0)
 .S DGELGSUB("RADEXPM")=DGELG("RADEXPM")
"RTN","DGENELA4",58,0)
 .S DGELGSUB("AOEXPLOC")=DGELG("AOEXPLOC")
"RTN","DGENELA4",59,0)
 .I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)=""
"RTN","DGENELA4",60,0)
 ;
"RTN","DGENELA4",61,0)
 Q HIPRI_$S(HIPRI:"^"_HISUB,1:"")
"RTN","DGENELA4",62,0)
 ;
"RTN","DGENELA4",63,0)
 ;
"RTN","DGENELA4",64,0)
PRI(CODE,DGELG,ENRDATE,APPDATE) ;
"RTN","DGENELA4",65,0)
 ; Description: Returns the priority group and subgroup based on a
"RTN","DGENELA4",66,0)
 ; single eligibility code.
"RTN","DGENELA4",67,0)
 ;Input -
"RTN","DGENELA4",68,0)
 ;  CODE - pointer to file #8.1, MAS Eligibility Code
"RTN","DGENELA4",69,0)
 ;  DGELG - local array obtained by calling $$GET, pass by reference
"RTN","DGENELA4",70,0)
 ;  ENRDATE - The Enrollment Date. This date is used in the priority
"RTN","DGENELA4",71,0)
 ;            determination only if the application date is not passed.
"RTN","DGENELA4",72,0)
 ;  APPDATE - The Enrollment Application Date.  This date is used
"RTN","DGENELA4",73,0)
 ;            to determine the priority. If the application date
"RTN","DGENELA4",74,0)
 ;            is not passed then the enrollment date (ENRDATE) is used.
"RTN","DGENELA4",75,0)
 ;
"RTN","DGENELA4",76,0)
 ;Output -
"RTN","DGENELA4",77,0)
 ;  Function Value - returns the priority and subgroup computed by the
"RTN","DGENELA4",78,0)
 ;   function as a 2 piece string 'PRIORITY^SUBGROUP'
"RTN","DGENELA4",79,0)
 ;
"RTN","DGENELA4",80,0)
 N CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR,STAEXP
"RTN","DGENELA4",81,0)
 N NODE2,DGNCM,DGNETW,DGMEDEX,DGEDEX,DGASSTS,DGMTYR,MTTEST1,MTTEST2
"RTN","DGENELA4",82,0)
 S SUBGRP=""
"RTN","DGENELA4",83,0)
 ;
"RTN","DGENELA4",84,0)
 ; use the Application Date when determining the priority, otherwise use
"RTN","DGENELA4",85,0)
 ; the Enrollment Date (ESP DG*5,3*491)
"RTN","DGENELA4",86,0)
 S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE))
"RTN","DGENELA4",87,0)
 ;
"RTN","DGENELA4",88,0)
 ;get the name of the national eligibility code
"RTN","DGENELA4",89,0)
 S CODENAME=$$CODENAME^DGENELA(CODE)
"RTN","DGENELA4",90,0)
 ;
"RTN","DGENELA4",91,0)
 ;get the means test code
"RTN","DGENELA4",92,0)
 S MTSTA=""
"RTN","DGENELA4",93,0)
 I DGELG("MTSTA") S MTSTA=$P($G(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
"RTN","DGENELA4",94,0)
 ;
"RTN","DGENELA4",95,0)
 ;get MT and GMT thresholds
"RTN","DGENELA4",96,0)
 S DGMTI=$P($$LST^DGMTU(DFN),"^")
"RTN","DGENELA4",97,0)
 S MTTHR=$$GET1^DIQ(408.31,+DGMTI,.12,"I")
"RTN","DGENELA4",98,0)
 S GMTTHR=$$GET1^DIQ(408.31,+DGMTI,.27,"I")
"RTN","DGENELA4",99,0)
 S DGNCM=$$GET1^DIQ(408.31,+DGMTI,.04,"I")
"RTN","DGENELA4",100,0)
 S DGNETW=$$GET1^DIQ(408.31,+DGMTI,.05,"I")
"RTN","DGENELA4",101,0)
 D ALL^DGMTU21(DFN,"V",DT,"I",+DGMTI)
"RTN","DGENELA4",102,0)
 S DGAICM=0
"RTN","DGENELA4",103,0)
 S:$G(DGINC("V")) DGAICM=+DGINC("V")
"RTN","DGENELA4",104,0)
 S (DGMEDEX,DGEDEX,DGASSTS)=0
"RTN","DGENELA4",105,0)
 S DGMTYR=$$GET1^DIQ(408.21,+DGAICM,.01,"E")
"RTN","DGENELA4",106,0)
 I $D(^DGMT(408.21,DGAICM,2))  D
"RTN","DGENELA4",107,0)
 .S NODE2=^DGMT(408.21,DGAICM,2)
"RTN","DGENELA4",108,0)
 .S DGASSTS=DGASSTS+$P(NODE2,U,1)+$P(NODE2,U,2)+$P(NODE2,U,3)+$P(NODE2,U,4)-$P(NODE2,U,5)
"RTN","DGENELA4",109,0)
 .S DGASSTS=DGASSTS+$P(NODE2,U,6)+$P(NODE2,U,7)+$P(NODE2,U,8)+$P(NODE2,U,9)
"RTN","DGENELA4",110,0)
 S:$D(^DGMT(408.21,DGAICM,1)) DGMEDEX=$P(^DGMT(408.21,DGAICM,1),"^",12)
"RTN","DGENELA4",111,0)
 S:$D(^DGMT(408.21,DGAICM,1)) DGEDEX=$P(^DGMT(408.21,DGAICM,1),"^",3)
"RTN","DGENELA4",112,0)
 ;
"RTN","DGENELA4",113,0)
 ; get expiration dates for Special Treatment Authority
"RTN","DGENELA4",114,0)
 S STAEXP("AO")=$$STAEXP^DGENELA4("AO")
"RTN","DGENELA4",115,0)
 S STAEXP("EC")=$$STAEXP^DGENELA4("EC")
"RTN","DGENELA4",116,0)
 ;
"RTN","DGENELA4",117,0)
 ;get the Enrollment Group Threshold (EGT) setting
"RTN","DGENELA4",118,0)
 S DGEGT=""
"RTN","DGENELA4",119,0)
 I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
"RTN","DGENELA4",120,0)
 I '$G(DGELG("RADEXPM")) S DGELG("RADEXPM")=""
"RTN","DGENELA4",121,0)
 I '$G(DGELG("SHAD")) S DGELG("SHAD")=""
"RTN","DGENELA4",122,0)
 ;
"RTN","DGENELA4",123,0)
 D  ;drops out when priority determined
"RTN","DGENELA4",124,0)
 .S PRIORITY=""
"RTN","DGENELA4",125,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q
"RTN","DGENELA4",126,0)
 .I (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMPLOY")="Y")&(DGELG("VACKAMT")>0)&(DGELG("VAPEN")'="Y")&(DGELG("A&A")'="Y")&(DGELG("HB")'="Y") S PRIORITY=1 Q
"RTN","DGENELA4",127,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q
"RTN","DGENELA4",128,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>9)&(CODENAME="SC LESS THAN 50%"))!(DGELG("POW")="Y")!(CODENAME="PRISONER OF WAR")!(DGELG("DISRET")=1)!(DGELG("DISLOD")=1)!(CODENAME="PURPLE HEART RECIPIENT")!(DGELG("PH")="Y") S PRIORITY=3 Q
"RTN","DGENELA4",129,0)
 .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q
"RTN","DGENELA4",130,0)
 .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q
"RTN","DGENELA4",131,0)
 .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1) S PRIORITY=6 Q
"RTN","DGENELA4",132,0)
 .I DGELG("EC")="Y" I (STAEXP("EC")<1)!($$DT^XLFDT<STAEXP("EC")) S PRIORITY=6 Q
"RTN","DGENELA4",133,0)
 .I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
"RTN","DGENELA4",134,0)
 .I (DGELG("AO")="Y"),(DGELG("AOEXPLOC"))="V" I (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO")) S PRIORITY=6 Q
"RTN","DGENELA4",135,0)
 .I (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR)) S PRIORITY=7 D  Q
"RTN","DGENELA4",136,0)
 ..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
"RTN","DGENELA4",137,0)
 ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
"RTN","DGENELA4",138,0)
 .S MTTEST1=MTTHR
"RTN","DGENELA4",139,0)
 .I GMTTHR>MTTHR S MTTEST1=GMTTHR
"RTN","DGENELA4",140,0)
 .S MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01 ; Add 10% to the test threshold
"RTN","DGENELA4",141,0)
 .I $$SC^DGMTR(DFN),DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
"RTN","DGENELA4",142,0)
 .I $$SC^DGMTR(DFN),DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
"RTN","DGENELA4",143,0)
 .I DGELG("SC")="N",DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
"RTN","DGENELA4",144,0)
 .I DGELG("SC")="N",DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
"RTN","DGENELA4",145,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
"RTN","DGENELA4",146,0)
 .I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q
"RTN","DGENELA4",147,0)
 ;
"RTN","DGENELA4",148,0)
 Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"")
"RTN","DGENELA4",149,0)
 ;
"RTN","DGENELA4",150,0)
SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT
"RTN","DGENELA4",151,0)
 ;
"RTN","DGENELA4",152,0)
 N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X
"RTN","DGENELA4",153,0)
 Q:'$G(DFN)
"RTN","DGENELA4",154,0)
 S U="^"
"RTN","DGENELA4",155,0)
 S:$G(PRIORITY)="" PRIORITY=""
"RTN","DGENELA4",156,0)
 S:$G(SUBGRP)="" SUBGRP=""
"RTN","DGENELA4",157,0)
 D NOW^%DTC S TODAY=X
"RTN","DGENELA4",158,0)
 Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP  ;EGT isn't set
"RTN","DGENELA4",159,0)
 Q:TODAY<EGT("EFFDATE") SUBGRP  ;EGT is not in effect
"RTN","DGENELA4",160,0)
 I "^1^3^"[(U_EGT("TYPE")_U) Q SUBGRP
"RTN","DGENELA4",161,0)
 I EGT("TYPE")=2,(PRIORITY+(SUBGRP*.01))<(EGT("PRIORITY")+(EGT("SUBGRP")*.01)) Q SUBGRP
"RTN","DGENELA4",162,0)
 I EGT("TYPE")=4 Q:(PRIORITY<EGT("PRIORITY")) SUBGRP  Q:(PRIORITY>EGT("PRIORITY")) $$SUBCNV(SUBGRP)
"RTN","DGENELA4",163,0)
 ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP
"RTN","DGENELA4",164,0)
 S DGENRIEN=$$FINDCUR^DGENA(DFN)
"RTN","DGENELA4",165,0)
 I 'DGENRIEN,$G(ENRDATE),ENRDATE<EGT("EFFDATE") Q SUBGRP
"RTN","DGENELA4",166,0)
 S DONE=0
"RTN","DGENELA4",167,0)
 F  Q:DONE  D
"RTN","DGENELA4",168,0)
 .I 'DGENRIEN S DONE=2 Q
"RTN","DGENELA4",169,0)
 .I '$$GET^DGENA(DGENRIEN,.DGENRC) S DONE=2 Q
"RTN","DGENELA4",170,0)
 .S DGENRIEN=$$FINDPRI^DGENA(DGENRIEN)
"RTN","DGENELA4",171,0)
 .Q:DGENRC("STATUS")=6   ;deceased
"RTN","DGENELA4",172,0)
 .I $P($G(^DGEN(27.15,+DGENRC("STATUS"),0)),"^",2)="N" S DONE=2 Q
"RTN","DGENELA4",173,0)
 .S ENRDT=$G(DGENRC("APP")) S:'ENRDT ENRDT=$G(DGENRC("EFFDATE"))
"RTN","DGENELA4",174,0)
 .I ENRDT,ENRDT<EGT("EFFDATE") S DONE=1 Q
"RTN","DGENELA4",175,0)
 .; HEC is the authoritative source on continuous enrollment
"RTN","DGENELA4",176,0)
 .I $$OVRRIDE^DGENEGT1(DFN,.EGT) S DONE=1
"RTN","DGENELA4",177,0)
 ;
"RTN","DGENELA4",178,0)
 Q $S(DONE=2:$$SUBCNV(SUBGRP),1:SUBGRP)
"RTN","DGENELA4",179,0)
 ;
"RTN","DGENELA4",180,0)
SUBCNV(SUBGRP) ;return new subgrp
"RTN","DGENELA4",181,0)
 I SUBGRP=1 Q 5
"RTN","DGENELA4",182,0)
 I SUBGRP=3 Q 7
"RTN","DGENELA4",183,0)
 Q SUBGRP
"RTN","DGENELA4",184,0)
 ;
"RTN","DGENELA4",185,0)
STAEXP(STATYP) ;return expiration date for Special Treatment Authority (STA)
"RTN","DGENELA4",186,0)
 ;Input -
"RTN","DGENELA4",187,0)
 ;  STATYP - STA Type (Only AO & EC (SWAC) currently supported)
"RTN","DGENELA4",188,0)
 ;
"RTN","DGENELA4",189,0)
 ;Output -
"RTN","DGENELA4",190,0)
 ;  Function Value - returns the requested expiration date from the
"RTN","DGENELA4",191,0)
 ;                   MAS PARAMETERS file (#43), otherwise returns 0
"RTN","DGENELA4",192,0)
 ;
"RTN","DGENELA4",193,0)
 I STATYP="AO" Q +$P($G(^DG(43,1,"ENR")),U,1)  ;AO Exp Dt
"RTN","DGENELA4",194,0)
 I STATYP="EC" Q +$P($G(^DG(43,1,"ENR")),U,2)  ;EC (SWAC) Exp Dt
"RTN","DGENELA4",195,0)
 Q 0
"RTN","DGENPTA")
0^16^B39663736
"RTN","DGENPTA",1,0)
DGENPTA ;ALB/CJM,ERC,CKN,TDM - Patient API - Retrieve Data ; 12/22/08 4:17pm
"RTN","DGENPTA",2,0)
 ;;5.3;Registration;**121,122,147,688,754**;Aug 13,1993;Build 46
"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 identifing infor 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" - prefered facility
"RTN","DGENPTA",84,0)
 ;      "SSN" - Social Security Number
"RTN","DGENPTA",85,0)
 ;      "SEX" - M=male, F=female
"RTN","DGENPTA",86,0)
 ;      "VETERAN" - VETERAN (Y/N)? - "Y"=YES,"N"=NO
"RTN","DGENPTA",87,0)
 ;      "AG/ALLY" - Agency/Allied Country
"RTN","DGENPTA",88,0)
 ;      "SPININJ" - Spinal Cord Injury
"RTN","DGENPTA",89,0)
 ;
"RTN","DGENPTA",90,0)
 N NODE
"RTN","DGENPTA",91,0)
 Q:'$G(DFN) 0
"RTN","DGENPTA",92,0)
 K DGPAT S DGPAT=""
"RTN","DGENPTA",93,0)
 S DGPAT("DFN")=DFN
"RTN","DGENPTA",94,0)
 S NODE=$G(^DPT(DFN,0))
"RTN","DGENPTA",95,0)
 Q:NODE="" 0
"RTN","DGENPTA",96,0)
 S DGPAT("NAME")=$P(NODE,"^")
"RTN","DGENPTA",97,0)
 S DGPAT("DOB")=$P(NODE,"^",3)
"RTN","DGENPTA",98,0)
 S DGPAT("SEX")=$P(NODE,"^",2)
"RTN","DGENPTA",99,0)
 S DGPAT("SSN")=$P(NODE,"^",9)
"RTN","DGENPTA",100,0)
 ;
"RTN","DGENPTA",101,0)
 S DGPAT("DEATH")=$P($G(^DPT(DFN,.35)),"^")
"RTN","DGENPTA",102,0)
 S DGPAT("PATYPE")=$P($G(^DPT(DFN,"TYPE")),"^")
"RTN","DGENPTA",103,0)
 S DGPAT("VETERAN")=$P($G(^DPT(DFN,"VET")),"^")
"RTN","DGENPTA",104,0)
 S DGPAT("PREFAC")=$P($G(^DPT(DFN,"ENR")),"^",2)
"RTN","DGENPTA",105,0)
 S DGPAT("INELDATE")=$P($G(^DPT(DFN,.15)),"^",2)
"RTN","DGENPTA",106,0)
 S DGPAT("INELREA")=$P($G(^DPT(DFN,.3)),"^",7)
"RTN","DGENPTA",107,0)
 S DGPAT("INELDEC")=$P($G(^DPT(DFN,"INE")),"^",6)
"RTN","DGENPTA",108,0)
 S DGPAT("PID")=$P($G(^DPT(DFN,.36)),"^",3)
"RTN","DGENPTA",109,0)
 S DGPAT("AG/ALLY")=$P($G(^DPT(DFN,.3)),"^",9)
"RTN","DGENPTA",110,0)
 S DGPAT("SPININJ")=$P($G(^DPT(DFN,57)),"^",4)
"RTN","DGENPTA",111,0)
 Q 1
"RTN","DGENPTA",112,0)
 ;
"RTN","DGENPTA",113,0)
SSN(DFN) ;
"RTN","DGENPTA",114,0)
 ;Description: Function returns the patient's SSN, or "" on failure.
"RTN","DGENPTA",115,0)
 ;
"RTN","DGENPTA",116,0)
 Q:'DFN ""
"RTN","DGENPTA",117,0)
 Q $P($G(^DPT(DFN,0)),"^",9)
"RTN","DGENPTA",118,0)
 ;
"RTN","DGENPTA",119,0)
NAME(DFN) ;
"RTN","DGENPTA",120,0)
 ;Description: Function returns the patient's NAME, or "" on failure.
"RTN","DGENPTA",121,0)
 ;
"RTN","DGENPTA",122,0)
 Q:'DFN ""
"RTN","DGENPTA",123,0)
 Q $P($G(^DPT(DFN,0)),"^")
"RTN","DGENPTA",124,0)
 ;
"RTN","DGENPTA",125,0)
EXT(SUB,VAL) ;
"RTN","DGENPTA",126,0)
 ;Description: Given the subscript used in the PATIENT object array,
"RTN","DGENPTA",127,0)
 ;   DGPAT(), and a field value, returns the external representation of
"RTN","DGENPTA",128,0)
 ;   the value, as defined in the fields output transform of the PATIENT
"RTN","DGENPTA",129,0)
 ;   file.
"RTN","DGENPTA",130,0)
 ;Input: 
"RTN","DGENPTA",131,0)
 ;  SUB - array subscript
"RTN","DGENPTA",132,0)
 ;  VAL - field value
"RTN","DGENPTA",133,0)
 ;Output:
"RTN","DGENPTA",134,0)
 ;  Function Value - returns the external value of the field
"RTN","DGENPTA",135,0)
 ;
"RTN","DGENPTA",136,0)
 Q:(($G(SUB)="")!($G(VAL)="")) ""
"RTN","DGENPTA",137,0)
 ;
"RTN","DGENPTA",138,0)
 N FLD
"RTN","DGENPTA",139,0)
 S FLD=$$FIELD^DGENPTA1(SUB)
"RTN","DGENPTA",140,0)
 Q:(FLD="") ""
"RTN","DGENPTA",141,0)
 Q $$EXTERNAL^DILFD(2,FLD,"F",VAL)
"RTN","DGENPTA",142,0)
 ;
"RTN","DGENPTA",143,0)
 ;
"RTN","DGENPTA",144,0)
VALPAT(DFN) ; --
"RTN","DGENPTA",145,0)
 ; Description: This function returns a 1 if the patient DFN is valid, 0 if the patient DFN is not valid.
"RTN","DGENPTA",146,0)
 ;
"RTN","DGENPTA",147,0)
 ;  Input:
"RTN","DGENPTA",148,0)
 ;    DFN - as pointer to patient in Patient (#2) file
"RTN","DGENPTA",149,0)
 ;
"RTN","DGENPTA",150,0)
 ; Output:
"RTN","DGENPTA",151,0)
 ;   Function Value - Is patient (DFN) valid?
"RTN","DGENPTA",152,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",153,0)
 ;
"RTN","DGENPTA",154,0)
 ; init variables
"RTN","DGENPTA",155,0)
 N DGVALID S DGVALID=0
"RTN","DGENPTA",156,0)
 ;
"RTN","DGENPTA",157,0)
 ; is patient (DFN) valid?
"RTN","DGENPTA",158,0)
 I $G(DFN),$D(^DPT(DFN,0)) S DGVALID=1
"RTN","DGENPTA",159,0)
 ;
"RTN","DGENPTA",160,0)
 Q DGVALID
"RTN","DGENPTA",161,0)
 ;
"RTN","DGENPTA",162,0)
 ;
"RTN","DGENPTA",163,0)
CURINPAT(DFN) ; --
"RTN","DGENPTA",164,0)
 ; Description: This function will determine if the patient is a current inpatient.
"RTN","DGENPTA",165,0)
 ;
"RTN","DGENPTA",166,0)
 ;  Input:
"RTN","DGENPTA",167,0)
 ;    DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",168,0)
 ;
"RTN","DGENPTA",169,0)
 ; Output:
"RTN","DGENPTA",170,0)
 ;   Function Value - Is patient a current inpatient? 
"RTN","DGENPTA",171,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",172,0)
 ;
"RTN","DGENPTA",173,0)
 N DGCUR S DGCUR=0
"RTN","DGENPTA",174,0)
 ;
"RTN","DGENPTA",175,0)
 ; if valid patient, check if current inpatient
"RTN","DGENPTA",176,0)
 I $$VALPAT(DFN) D
"RTN","DGENPTA",177,0)
 .;
"RTN","DGENPTA",178,0)
 .; is patient a current inpatient?
"RTN","DGENPTA",179,0)
 .I $G(^DPT(DFN,.105)) S DGCUR=1
"RTN","DGENPTA",180,0)
 ;
"RTN","DGENPTA",181,0)
 Q DGCUR
"RTN","DGENPTA",182,0)
 ;
"RTN","DGENPTA",183,0)
 ;
"RTN","DGENPTA",184,0)
INPAT(DFN,DGBEG,DGEND) ; --
"RTN","DGENPTA",185,0)
 ; Description: This function will determine if a patient was an inpatient between a specified date range.
"RTN","DGENPTA",186,0)
 ;
"RTN","DGENPTA",187,0)
 ;  Input:
"RTN","DGENPTA",188,0)
 ;       DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",189,0)
 ;    DGBEG - as begin date/time for inpatient search
"RTN","DGENPTA",190,0)
 ;    DGEND - as end date/time for inpatient search
"RTN","DGENPTA",191,0)
 ;
"RTN","DGENPTA",192,0)
 ; Output:
"RTN","DGENPTA",193,0)
 ;   Function Value - Was patient an inpatient between date range?
"RTN","DGENPTA",194,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",195,0)
 ;
"RTN","DGENPTA",196,0)
 N DGINPAT,DGSDT,DGEDT,DGMOVE,DGTRANS
"RTN","DGENPTA",197,0)
 S DGINPAT=0
"RTN","DGENPTA",198,0)
 ;
"RTN","DGENPTA",199,0)
 ; if not valid patient (DFN) and not valid date range, exit
"RTN","DGENPTA",200,0)
 I '$$VALPAT(DFN),'($$RANGE(DGBEG,DGEND)) G INPATQ
"RTN","DGENPTA",201,0)
 ;
"RTN","DGENPTA",202,0)
 ; init date/time(s)
"RTN","DGENPTA",203,0)
 S DGSDT=DGBEG-.0001,DGEDT=DGEND+$S($P(DGEND,".",2)="":.2359,1:"")
"RTN","DGENPTA",204,0)
 ;
"RTN","DGENPTA",205,0)
 ; use "APRD" x-ref of Patient Movement (#405) file
"RTN","DGENPTA",206,0)
 F  S DGSDT=$O(^DGPM("APRD",+DFN,DGSDT)) Q:'DGSDT!(DGSDT>DGEDT)!(DGINPAT)  D
"RTN","DGENPTA",207,0)
 .S DGMOVE=0 F  S DGMOVE=$O(^DGPM("APRD",+DFN,DGSDT,DGMOVE)) Q:'DGMOVE!(DGINPAT)  D
"RTN","DGENPTA",208,0)
 ..; - transaction type of movement
"RTN","DGENPTA",209,0)
 ..S DGTRANS=$P($G(^DGPM(DGMOVE,0)),"^",2)  ; movement transaction type
"RTN","DGENPTA",210,0)
 ..; - if trans type not DISCHARGE, CHECK-IN LODGER, CHECK-OUT LODGER
"RTN","DGENPTA",211,0)
 ..I DGTRANS'=3,(DGTRANS'=4),(DGTRANS'=5) S DGINPAT=1
"RTN","DGENPTA",212,0)
 ;
"RTN","DGENPTA",213,0)
INPATQ Q DGINPAT
"RTN","DGENPTA",214,0)
 ;
"RTN","DGENPTA",215,0)
 ;
"RTN","DGENPTA",216,0)
OUTPAT(DFN,DGBEG,DGEND) ; --
"RTN","DGENPTA",217,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",218,0)
 ;
"RTN","DGENPTA",219,0)
 ;  Input:
"RTN","DGENPTA",220,0)
 ;       DFN - IEN of record in Patient (#2) file
"RTN","DGENPTA",221,0)
 ;    DGBEG - as begin date/time for outpatient search
"RTN","DGENPTA",222,0)
 ;    DGEND - as end date/time for outpatient search
"RTN","DGENPTA",223,0)
 ;
"RTN","DGENPTA",224,0)
 ; Output:
"RTN","DGENPTA",225,0)
 ;   Function Value - Does patient have outpatient encounter between date
"RTN","DGENPTA",226,0)
 ;                    range that that has successfully been checked out?
"RTN","DGENPTA",227,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",228,0)
 ;
"RTN","DGENPTA",229,0)
 N DGOUT,DGSDT,DGEDT,DGOE
"RTN","DGENPTA",230,0)
 S DGOUT=0
"RTN","DGENPTA",231,0)
 ;
"RTN","DGENPTA",232,0)
 ; if not valid patient (DFN) and not valid date range, exit
"RTN","DGENPTA",233,0)
 I '$$VALPAT(DFN),'($$RANGE(DGBEG,DGEND)) G OUTPATQ
"RTN","DGENPTA",234,0)
 ;
"RTN","DGENPTA",235,0)
 ; init date/time(s)
"RTN","DGENPTA",236,0)
 S DGSDT=DGBEG-.0001,DGEDT=DGEND+$S($P(DGEND,".",2)="":.2359,1:"")
"RTN","DGENPTA",237,0)
 ;
"RTN","DGENPTA",238,0)
 ; use "ADFN" x-ref of Outpatient Encounter (#409.68) file
"RTN","DGENPTA",239,0)
 F  S DGSDT=$O(^SCE("ADFN",+DFN,DGSDT)) Q:'DGSDT!(DGSDT>DGEDT)!(DGOUT)  D
"RTN","DGENPTA",240,0)
 .;
"RTN","DGENPTA",241,0)
 .S DGOE=0 F  S DGOE=$O(^SCE("ADFN",+DFN,DGSDT,DGOE)) Q:'DGOE!(DGOUT)  D
"RTN","DGENPTA",242,0)
 ..; - if encounter checked out, set flag
"RTN","DGENPTA",243,0)
 ..I $P($G(^SCE(+DGOE,0)),"^",7) S DGOUT=1
"RTN","DGENPTA",244,0)
 ;
"RTN","DGENPTA",245,0)
OUTPATQ Q DGOUT
"RTN","DGENPTA",246,0)
 ;
"RTN","DGENPTA",247,0)
 ;
"RTN","DGENPTA",248,0)
RANGE(DGBEG,DGEND) ; --
"RTN","DGENPTA",249,0)
 ; Description: This function returns a 1 if two dates are a valid date range, 0 if they are not valid.
"RTN","DGENPTA",250,0)
 ;
"RTN","DGENPTA",251,0)
 ;  Input:
"RTN","DGENPTA",252,0)
 ;    DGBEG - as begin date of date range
"RTN","DGENPTA",253,0)
 ;    DGEND - as end date of date range
"RTN","DGENPTA",254,0)
 ;
"RTN","DGENPTA",255,0)
 ; Output:
"RTN","DGENPTA",256,0)
 ;   Function Value - Is date range valid?
"RTN","DGENPTA",257,0)
 ;                    Return 1 if successful, otherwise 0
"RTN","DGENPTA",258,0)
 ;
"RTN","DGENPTA",259,0)
 N DGOK
"RTN","DGENPTA",260,0)
 ;
"RTN","DGENPTA",261,0)
 S DGOK=0
"RTN","DGENPTA",262,0)
 ;
"RTN","DGENPTA",263,0)
 ; if input parameters not defined, exit
"RTN","DGENPTA",264,0)
 I '$D(DGBEG),('$D(DGEND)) G RANGEQ
"RTN","DGENPTA",265,0)
 ;
"RTN","DGENPTA",266,0)
 ; remove time from dates
"RTN","DGENPTA",267,0)
 S DGBEG=(DGBEG/1),DGEND=(DGEND/1)
"RTN","DGENPTA",268,0)
 ;
"RTN","DGENPTA",269,0)
 ; if begin date greater than end date, exit
"RTN","DGENPTA",270,0)
 I DGBEG>DGEND G RANGEQ
"RTN","DGENPTA",271,0)
 ;
"RTN","DGENPTA",272,0)
 ; if begin date and end date future dates, exit
"RTN","DGENPTA",273,0)
 I DGBEG>DT,(DGEND>DT) G RANGEQ
"RTN","DGENPTA",274,0)
 ;
"RTN","DGENPTA",275,0)
 S DGOK=1
"RTN","DGENPTA",276,0)
 ;
"RTN","DGENPTA",277,0)
RANGEQ Q DGOK
"RTN","DGENPTA",278,0)
 ;
"RTN","DGENPTA",279,0)
LOOKUP(SSN,DOB,SEX,ERROR) ;
"RTN","DGENPTA",280,0)
 ;Description: This function will do a search for the patient based on
"RTN","DGENPTA",281,0)
 ;the identifying information provided. The function will be successful
"RTN","DGENPTA",282,0)
 ;only if a single patient is found matching the identifiers provided.
"RTN","DGENPTA",283,0)
 ;
"RTN","DGENPTA",284,0)
 ;Inputs:
"RTN","DGENPTA",285,0)
 ;  SSN - patient Social Security Number
"RTN","DGENPTA",286,0)
 ;  DOB - patient date of birth (FM format)
"RTN","DGENPTA",287,0)
 ;  SEX - patient sex
"RTN","DGENPTA",288,0)
 ;Outputs:
"RTN","DGENPTA",289,0)
 ;  Function Value - patient DFN if successful, 0 otherwise
"RTN","DGENPTA",290,0)
 ;  ERROR - if unsuccessful, an error message is returned (optional, pass by reference)
"RTN","DGENPTA",291,0)
 ;
"RTN","DGENPTA",292,0)
 N DFN,NODE
"RTN","DGENPTA",293,0)
 ;
"RTN","DGENPTA",294,0)
 I $G(SSN)="" S ERROR="INVALID SSN" Q 0
"RTN","DGENPTA",295,0)
 S DFN=$O(^DPT("SSN",SSN,0))
"RTN","DGENPTA",296,0)
 I 'DFN S ERROR="SSN NOT FOUND" Q 0
"RTN","DGENPTA",297,0)
 I $O(^DPT("SSN",SSN,DFN)) S ERROR="MULTIPLE PATIENTS MATCHING SSN" Q 0
"RTN","DGENPTA",298,0)
 S NODE=$G(^DPT(DFN,0))
"RTN","DGENPTA",299,0)
 I $P(NODE,"^",2)'=SEX S ERROR="SEX DOES NOT MATCH" Q 0
"RTN","DGENPTA",300,0)
 I $E($P(NODE,"^",3),1,3)'=$E(DOB,1,3) S ERROR="DOB DOES NOT MATCH" Q 0
"RTN","DGENPTA",301,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",302,0)
 Q DFN
"RTN","DGENPTA1")
0^17^B21277182
"RTN","DGENPTA1",1,0)
DGENPTA1 ;ALB/CJM,EG,CKN,ERC,TDM - Patient API - File Data ; 9/26/09 2:54pm
"RTN","DGENPTA1",2,0)
 ;;5.3;Registration;**121,147,314,677,659,653,688,810,754**;Aug 13,1993;Build 46
"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 a 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 SUCESS=$$UPD^DGENDBS(2,DFN,.DATA)
"RTN","DGENPTA1",44,0)
 Q SUCCESS
"RTN","DGENPTA1",45,0)
 ;
"RTN","DGENPTA1",46,0)
CHECK(DGPAT,ERROR) ;
"RTN","DGENPTA1",47,0)
 ;Description: Does validation checks on the patient contained in the
"RTN","DGENPTA1",48,0)
 ;DGPAT array.
"RTN","DGENPTA1",49,0)
 ;
"RTN","DGENPTA1",50,0)
 ;Input:
"RTN","DGENPTA1",51,0)
 ;  DGPAT - this local array contains patient data
"RTN","DGENPTA1",52,0)
 ;Output:
"RTN","DGENPTA1",53,0)
 ;  Function Value - returns 1 if all validation checks passed, 0 otherwise
"RTN","DGENPTA1",54,0)
 ;  ERROR - if validation checks fail, an error message is returned (pass by reference)
"RTN","DGENPTA1",55,0)
 ;
"RTN","DGENPTA1",56,0)
 ;
"RTN","DGENPTA1",57,0)
 N SUCCESS,FIELD
"RTN","DGENPTA1",58,0)
 S SUCCESS=1
"RTN","DGENPTA1",59,0)
 S ERROR=""
"RTN","DGENPTA1",60,0)
 ;
"RTN","DGENPTA1",61,0)
 ;check field values
"RTN","DGENPTA1",62,0)
 ;
"RTN","DGENPTA1",63,0)
 ;some of the field's input transforms require DA or DUZ to be defined, so do not do this
"RTN","DGENPTA1",64,0)
 ;F  S SUB=$O(DGPAT(SUB)) Q:SUB=""  D:(DGPAT(SUB)'="")  Q:'SUCCESS
"RTN","DGENPTA1",65,0)
 ;.S FIELD=$$FIELD(SUB)
"RTN","DGENPTA1",66,0)
 ;.I '$$TESTVAL^DGENDBS(2,FIELD,DGPAT(SUB)) D
"RTN","DGENPTA1",67,0)
 ;..S SUCCESS=0
"RTN","DGENPTA1",68,0)
 ;..S ERROR="BAD FIELD VALUE, PATIENT FILE FIELD = "_$$GET1^DID(2,FIELD,,"LABEL")
"RTN","DGENPTA1",69,0)
 ;
"RTN","DGENPTA1",70,0)
 ;instead, check field values without referencing DD
"RTN","DGENPTA1",71,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",72,0)
 ;
"RTN","DGENPTA1",73,0)
 I DGPAT("INELREA")'="",($L(DGPAT("INELREA"))>40) S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD FIELD = INELIGIBLE REASON" G QCHECK
"RTN","DGENPTA1",74,0)
 ;
"RTN","DGENPTA1",75,0)
 I DGPAT("VETERAN")="" S SUCCESS=0,ERROR="BAD FIELD VALUE, PATIENT FIELD = VETERAN (Y/N)?" G QCHECK
"RTN","DGENPTA1",76,0)
 ;
"RTN","DGENPTA1",77,0)
 I DGPAT("DEATH"),(DGPAT("DEATH")>DT) S SUCCESS=0,ERROR="DATE OF DEATH CAN NOT BE A FUTURE DATE" G QCHECK
"RTN","DGENPTA1",78,0)
 ;
"RTN","DGENPTA1",79,0)
 I DGPAT("INELDATE"),(DGPAT("INELREA")="") S SUCCESS=0,ERROR="INELIGIBLE REASON UNSPECIFIED FOR INELIGIBLE PATIENT" G QCHECK
"RTN","DGENPTA1",80,0)
 ;
"RTN","DGENPTA1",81,0)
QCHECK ;
"RTN","DGENPTA1",82,0)
 Q SUCCESS
"RTN","DGENPTA1",83,0)
 ;
"RTN","DGENPTA1",84,0)
STORE(DGPAT,ERROR,NOCHECK) ;
"RTN","DGENPTA1",85,0)
 ;Description: Files data in the patient record.  It requires a lock
"RTN","DGENPTA1",86,0)
 ;on the Patient record, adn releases the lock when done.
"RTN","DGENPTA1",87,0)
 ;
"RTN","DGENPTA1",88,0)
 ;Input:
"RTN","DGENPTA1",89,0)
 ;  DGPAT- the patient array, passed by reference
"RTN","DGENPTA1",90,0)
 ;  NOCHECK - a flag, if set to 1 it means consistency checks were done aready, so skip
"RTN","DGENPTA1",91,0)
 ;
"RTN","DGENPTA1",92,0)
 ;Output:
"RTN","DGENPTA1",93,0)
 ;  Function Value - returns 1 if successful, otherwise 0
"RTN","DGENPTA1",94,0)
 ;  ERROR - on failure, an error message is returned (optional, pass by reference)
"RTN","DGENPTA1",95,0)
 ;
"RTN","DGENPTA1",96,0)
 S ERROR=""
"RTN","DGENPTA1",97,0)
 I '$D(DGPAT) S ERROR="PATIENT NOT FOUND" Q 0
"RTN","DGENPTA1",98,0)
 I '$$LOCK(DGPAT("DFN")) S ERROR="UNABLE TO LOCK THE PATIENT RECORD" Q 0
"RTN","DGENPTA1",99,0)
 I $G(NOCHECK)'=1 Q:'$$CHECK(.DGPAT,.ERROR) 0
"RTN","DGENPTA1",100,0)
 ;
"RTN","DGENPTA1",101,0)
 N DATA,SUB,FIELD,SUCCESS
"RTN","DGENPTA1",102,0)
 S SUB=""
"RTN","DGENPTA1",103,0)
 ;
"RTN","DGENPTA1",104,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",105,0)
 S SUCCESS=$$UPD^DGENDBS(2,DGPAT("DFN"),.DATA)
"RTN","DGENPTA1",106,0)
 I 'SUCCESS S ERROR="FILEMAN UNABLE TO UPDATE PATIENT RECORD"
"RTN","DGENPTA1",107,0)
 ; Call Purple Heart API to file PH data in file 2
"RTN","DGENPTA1",108,0)
 I SUCCESS,$D(DGPAT("PHI")) D EDITPH^DGRPLE($G(DGPAT("PHI")),$G(DGPAT("PHST")),$G(DGPAT("PHRR")),DGPAT("DFN"))
"RTN","DGENPTA1",109,0)
 ; Call POW API to file POW data in file 2 - DG*5.3*653
"RTN","DGENPTA1",110,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",111,0)
 I SUCCESS D
"RTN","DGENPTA1",112,0)
 . I '$D(DGPAT("POWI")) D  Q
"RTN","DGENPTA1",113,0)
 . . N DATA,ERROR,DGENDA
"RTN","DGENPTA1",114,0)
 . . S DGENDA=DGPAT("DFN")
"RTN","DGENPTA1",115,0)
 . . S (DATA(.525),DATA(.526),DATA(.527),DATA(.528),DATA(.529))="@"
"RTN","DGENPTA1",116,0)
 . . I '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR) D
"RTN","DGENPTA1",117,0)
 . . . D ADDMSG^DGENUPL3(.MSGS,"Unable to update POW Data.",1)
"RTN","DGENPTA1",118,0)
 . . K DATA,ERROR,DGENDA
"RTN","DGENPTA1",119,0)
 . D EDITPOW^DGRPLE($G(DGPAT("POWI")),$G(DGPAT("POWLOC")),$G(DGPAT("POWFDT")),$G(DGPAT("POWTDT")),DGPAT("DFN"))
"RTN","DGENPTA1",120,0)
 D UNLOCK(DGPAT("DFN"))
"RTN","DGENPTA1",121,0)
 Q SUCCESS
"RTN","DGENPTA1",122,0)
 ;
"RTN","DGENPTA1",123,0)
FIELD(SUB) ;
"RTN","DGENPTA1",124,0)
 ;Description: Returns the field number of a subscript for the PATIENT object.
"RTN","DGENPTA1",125,0)
 ;
"RTN","DGENPTA1",126,0)
 N FNUM
"RTN","DGENPTA1",127,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",128,0)
 S:'FNUM FNUM=$S(SUB="INELDATE":.152,SUB="INELREA":.307,SUB="INELDEC":.1656,SUB="PID":.363,SUB="EMGRES":.181,1:"")
"RTN","DGENPTA1",129,0)
 I FNUM="" S FNUM=$S(SUB="IR":.32103,SUB="RADEXPM":.3212,SUB="APPREQ":1010.159,SUB="APPREQDT":1010.1511,SUB="SPININJ":57.4,1:"")
"RTN","DGENPTA1",130,0)
 Q FNUM
"RTN","DGENUPLA")
0^18^B65304654
"RTN","DGENUPLA",1,0)
DGENUPLA ;ALB/CKN,TDM,PJR,RGL,EG,TMK,CKN,TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 7/28/09 2:41pm
"RTN","DGENUPLA",2,0)
 ;;5.3;REGISTRATION;**397,379,497,451,564,672,659,583,653,688,754**;Aug 13,1993;Build 46
"RTN","DGENUPLA",3,0)
 ;
"RTN","DGENUPLA",4,0)
 ;***************************************************************
"RTN","DGENUPLA",5,0)
 ; This routine was created because DGENUPL2 had reached it's
"RTN","DGENUPLA",6,0)
 ; maximum size, therefore no new code could not be added.  All
"RTN","DGENUPLA",7,0)
 ; code that existed in the ZEL and OBX tags of DGENUPL2 has
"RTN","DGENUPLA",8,0)
 ; been moved to the ZEL,ZPD and OBX tags of DGENUPLA.  A line of code
"RTN","DGENUPLA",9,0)
 ; was placed in ZEL^DGENUPL2 to call ZEL^DGENUPLA.  A line of
"RTN","DGENUPLA",10,0)
 ; code was placed in OBX^DGENUPL2 to call OBX^DGENUPLA.
"RTN","DGENUPLA",11,0)
 ; Any routine that calls ZEL,ZPD or OBX^DGENUPL2 will not
"RTN","DGENUPLA",12,0)
 ; be affected by this change.
"RTN","DGENUPLA",13,0)
 ;***************************************************************
"RTN","DGENUPLA",14,0)
 ;
"RTN","DGENUPLA",15,0)
 ;***************************************************************
"RTN","DGENUPLA",16,0)
 ;The following procedures parse particular segment types.
"RTN","DGENUPLA",17,0)
 ;Input:SEG(),MSGID
"RTN","DGENUPLA",18,0)
 ;Output:DGPAT(),DGELG(),DGENR(),DGNTR(),DGMST(),ERROR
"RTN","DGENUPLA",19,0)
 ;***************************************************************
"RTN","DGENUPLA",20,0)
 ;
"RTN","DGENUPLA",21,0)
 ;
"RTN","DGENUPLA",22,0)
ZEL(COUNT) ;
"RTN","DGENUPLA",23,0)
 N CODE,SEQ
"RTN","DGENUPLA",24,0)
 S CODE=$$CONVERT^DGENUPL1(SEG(2),"ELIGIBILITY",.ERROR)
"RTN","DGENUPLA",25,0)
 I ERROR D  Q
"RTN","DGENUPLA",26,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ELIGIBILITY CODE "_SEG(2)_" NOT FOUND IN ELIGIBILTIY CODE FILE",.ERRCOUNT)
"RTN","DGENUPLA",27,0)
 I COUNT=1 D
"RTN","DGENUPLA",28,0)
 .S DGELG("ELIG","CODE")=CODE
"RTN","DGENUPLA",29,0)
 .S DGELG("DISRET")=$$CONVERT^DGENUPL1(SEG(5),"1/0",.ERROR)
"RTN","DGENUPLA",30,0)
 .I ERROR D  Q
"RTN","DGENUPLA",31,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 5",.ERRCOUNT)
"RTN","DGENUPLA",32,0)
 .S DGELG("CLAIMNUM")=$$CONVERT^DGENUPL1(SEG(6))
"RTN","DGENUPLA",33,0)
 .S DGELG("CLAIMLOC")=$$SITECNV(SEG(7))
"RTN","DGENUPLA",34,0)
 .;
"RTN","DGENUPLA",35,0)
 .S DGPAT("VETERAN")=$$CONVERT^DGENUPL1(SEG(8),"Y/N",.ERROR)
"RTN","DGENUPLA",36,0)
 .I ERROR D  Q
"RTN","DGENUPLA",37,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 8",.ERRCOUNT)
"RTN","DGENUPLA",38,0)
 .S DGELG("ELIGSTA")=$$CONVERT^DGENUPL1(SEG(10))
"RTN","DGENUPLA",39,0)
 .S DGELG("ELIGSTADATE")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
"RTN","DGENUPLA",40,0)
 .I ERROR D  Q
"RTN","DGENUPLA",41,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 11",.ERRCOUNT)
"RTN","DGENUPLA",42,0)
 .S DGELG("ELIGVERIF")=$$CONVERT^DGENUPL1(SEG(13))
"RTN","DGENUPLA",43,0)
 .S DGELG("A&A")=$$CONVERT^DGENUPL1(SEG(14),"Y/N",.ERROR)
"RTN","DGENUPLA",44,0)
 .I ERROR D  Q
"RTN","DGENUPLA",45,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 14",.ERRCOUNT)
"RTN","DGENUPLA",46,0)
 .S DGELG("HB")=$$CONVERT^DGENUPL1(SEG(15),"Y/N",.ERROR)
"RTN","DGENUPLA",47,0)
 .I ERROR D  Q
"RTN","DGENUPLA",48,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 15",.ERRCOUNT)
"RTN","DGENUPLA",49,0)
 .S DGELG("VAPEN")=$$CONVERT^DGENUPL1(SEG(16),"Y/N",.ERROR)
"RTN","DGENUPLA",50,0)
 .I ERROR D  Q
"RTN","DGENUPLA",51,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 16",.ERRCOUNT)
"RTN","DGENUPLA",52,0)
 .S DGELG("VADISAB")=$$CONVERT^DGENUPL1(SEG(17),"Y/N",.ERROR)
"RTN","DGENUPLA",53,0)
 .I ERROR D  Q
"RTN","DGENUPLA",54,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 17",.ERRCOUNT)
"RTN","DGENUPLA",55,0)
 .S DGELG("AO")=$$CONVERT^DGENUPL1(SEG(18),"Y/N",.ERROR)
"RTN","DGENUPLA",56,0)
 .N AOERR S AOERR=ERROR            ;  See SEG(29) below.
"RTN","DGENUPLA",57,0)
 .I ERROR D  Q
"RTN","DGENUPLA",58,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 18",.ERRCOUNT)
"RTN","DGENUPLA",59,0)
 .S (DGPAT("IR"),DGELG("IR"))=$$CONVERT^DGENUPL1(SEG(19),"Y/N",.ERROR)
"RTN","DGENUPLA",60,0)
 .I ERROR D  Q
"RTN","DGENUPLA",61,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 19",.ERRCOUNT)
"RTN","DGENUPLA",62,0)
 .S DGELG("EC")=$$CONVERT^DGENUPL1(SEG(20),"Y/N",.ERROR)
"RTN","DGENUPLA",63,0)
 .I ERROR D  Q
"RTN","DGENUPLA",64,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 20",.ERRCOUNT)
"RTN","DGENUPLA",65,0)
 .S (DGPAT("RADEXPM"),DGELG("RADEXPM"))=$$CONVERT^DGENUPL1($G(SEG(22)))
"RTN","DGENUPLA",66,0)
 .S ERROR=$S(DGELG("RADEXPM")="":0,",2,3,4,5,6,7,"[(","_DGELG("RADEXPM")_","):0,DGELG("RADEXPM")="@":0,1:1)
"RTN","DGENUPLA",67,0)
 .I ERROR D  Q
"RTN","DGENUPLA",68,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 22",.ERRCOUNT)
"RTN","DGENUPLA",69,0)
 .;
"RTN","DGENUPLA",70,0)
 .S DGELG("VACKAMT")=$$CONVERT^DGENUPL1(SEG(21))
"RTN","DGENUPLA",71,0)
 .;
"RTN","DGENUPLA",72,0)
 .;Parse MST data into DGMST array from sequences 23, 24, 25 of ZEL segment
"RTN","DGENUPLA",73,0)
 . F SEQ=23,24,25 S:SEG(SEQ)=HLQ SEG(SEQ)=""
"RTN","DGENUPLA",74,0)
 . S DGMST("MSTSTAT")=$$CONVERT^DGENUPL1(SEG(23))
"RTN","DGENUPLA",75,0)
 . S DGMST("MSTDT")=$$CONVERT^DGENUPL1(SEG(24),"TS",.ERROR)
"RTN","DGENUPLA",76,0)
 . I ERROR D  Q
"RTN","DGENUPLA",77,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 24",.ERRCOUNT)
"RTN","DGENUPLA",78,0)
 . S DGMST("MSTST")=$$CONVERT^DGENUPL1(SEG(25),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",79,0)
 . I ERROR D  Q
"RTN","DGENUPLA",80,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 25",.ERRCOUNT)
"RTN","DGENUPLA",81,0)
 .;
"RTN","DGENUPLA",82,0)
 . S DGELG("AOEXPLOC")=$$CONVERT^DGENUPL1(SEG(29))
"RTN","DGENUPLA",83,0)
 .; Logic enhanced during SQA of patch 451.  AOERR from SEG(18) above.
"RTN","DGENUPLA",84,0)
 . I 'AOERR,DGELG("AO")'="Y",DGELG("AOEXPLOC")="" S DGELG("AOEXPLOC")="@"
"RTN","DGENUPLA",85,0)
 . S DGELG("UEYEAR")=$$CONVERT^DGENUPL1(SEG(34),"DATE",.ERROR)
"RTN","DGENUPLA",86,0)
 . I ERROR D  Q
"RTN","DGENUPLA",87,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 34",.ERRCOUNT)
"RTN","DGENUPLA",88,0)
 . S DGELG("UESITE")=$$CONVERT^DGENUPL1(SEG(35),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",89,0)
 . I ERROR D  Q
"RTN","DGENUPLA",90,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 35",.ERRCOUNT)
"RTN","DGENUPLA",91,0)
 . S DGELG("CVELEDT")=$$CONVERT^DGENUPL1(SEG(38),"DATE",.ERROR)
"RTN","DGENUPLA",92,0)
 . I ERROR D  Q
"RTN","DGENUPLA",93,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 38",.ERRCOUNT)
"RTN","DGENUPLA",94,0)
 . I $G(DGELG("DISLOD"))="" S DGELG("DISLOD")=$$CONVERT^DGENUPL1(SEG(39),"1/0",.ERROR) ;Discharge due to Disability - DG*5.3*653
"RTN","DGENUPLA",95,0)
 . I ERROR D  Q
"RTN","DGENUPLA",96,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 39",.ERRCOUNT)
"RTN","DGENUPLA",97,0)
 . S DGELG("SHAD")=$$CONVERT^DGENUPL1(SEG(40),"1/0",.ERROR) ;Proj 112/SHAD - DG*5.3*653
"RTN","DGENUPLA",98,0)
 . I ERROR D  Q
"RTN","DGENUPLA",99,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 40 - SHAD Indicator",.ERRCOUNT)
"RTN","DGENUPLA",100,0)
 ;
"RTN","DGENUPLA",101,0)
 I COUNT>1 D
"RTN","DGENUPLA",102,0)
 .S DGELG("ELIG","CODE",CODE)=""
"RTN","DGENUPLA",103,0)
 Q
"RTN","DGENUPLA",104,0)
 ;
"RTN","DGENUPLA",105,0)
OBX ;
"RTN","DGENUPLA",106,0)
 N OBXPCE,OBXVAL,OBXTBL,I,CS,SS,RS
"RTN","DGENUPLA",107,0)
 I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
"RTN","DGENUPLA",108,0)
 I $G(HLFS)="" N HLFS S HLFS="^"
"RTN","DGENUPLA",109,0)
 S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
"RTN","DGENUPLA",110,0)
 I $G(SEG(3))=("38.1"_$E(HLECH)_"SECURITY LOG") D
"RTN","DGENUPLA",111,0)
 . N LEVEL
"RTN","DGENUPLA",112,0)
 . S LEVEL=$P(SEG(5),$E(HLECH))
"RTN","DGENUPLA",113,0)
 . S DGSEC("LEVEL")=$$CONVERT^DGENUPL1(LEVEL,"1/0",.ERROR)
"RTN","DGENUPLA",114,0)
 . I ERROR D  Q
"RTN","DGENUPLA",115,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, OBX SEGMENT, SEQ 5",.ERRCOUNT)
"RTN","DGENUPLA",116,0)
 . S DGSEC("DATETIME")=$$CONVERT^DGENUPL1(SEG(14),"TS",.ERROR)
"RTN","DGENUPLA",117,0)
 . I ERROR D  Q
"RTN","DGENUPLA",118,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, OBX SEGMENT, SEQ 14, Patient Sensitivity Date/Time",.ERRCOUNT) ;DG*5.3*653
"RTN","DGENUPLA",119,0)
 . S DGSEC("SOURCE")=$$CONVERT^DGENUPL1(SEG(16))
"RTN","DGENUPLA",120,0)
 ;
"RTN","DGENUPLA",121,0)
 I $G(SEG(3))=("VISTA"_CS_"28.11") D
"RTN","DGENUPLA",122,0)
 . S OBXTBL(1)="NTR^Y",OBXTBL(2)="AVI^Y",OBXTBL(3)="SUB^Y"
"RTN","DGENUPLA",123,0)
 . S OBXTBL(4)="HNC^Y",OBXTBL(5)="NTR^N",OBXTBL(6)="AVI^N"
"RTN","DGENUPLA",124,0)
 . S OBXTBL(7)="SUB^N",OBXTBL(8)="HNC^N",OBXTBL(9)="NTR^U"
"RTN","DGENUPLA",125,0)
 . F I=1:1:$L($G(SEG(5)),RS) D
"RTN","DGENUPLA",126,0)
 . . S OBXPCE=$P($G(SEG(5)),RS,I),OBXVAL=$P($G(OBXPCE),CS)
"RTN","DGENUPLA",127,0)
 . . S DGNTR($P($G(OBXTBL(OBXVAL)),"^"))=$P($G(OBXTBL(OBXVAL)),"^",2)
"RTN","DGENUPLA",128,0)
 . I $G(SEG(12))'="" S DGNTR("HDT")=$$CONVERT^DGENUPL1(SEG(12),"TS",.ERROR)
"RTN","DGENUPLA",129,0)
 . S DGNTR("VDT")=$$CONVERT^DGENUPL1(SEG(14),"TS",.ERROR)
"RTN","DGENUPLA",130,0)
 . S DGNTR("VSIT")=$$CONVERT^DGENUPL1(SEG(15),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",131,0)
 . S DGNTR("HSIT")=$P($P($G(SEG(16)),CS,14),SS,2)
"RTN","DGENUPLA",132,0)
 . I DGNTR("HSIT")'="" S DGNTR("HSIT")=$$CONVERT^DGENUPL1($G(DGNTR("HSIT")),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",133,0)
 . S DGNTR("VER")=$$CONVERT^DGENUPL1($P($G(SEG(17)),CS))
"RTN","DGENUPLA",134,0)
 Q
"RTN","DGENUPLA",135,0)
 ;
"RTN","DGENUPLA",136,0)
ZIO ;New segment - DG*5.3*653
"RTN","DGENUPLA",137,0)
 S DGPAT("APPREQ")=$$CONVERT^DGENUPL1(SEG(5),"1/0",.ERROR)
"RTN","DGENUPLA",138,0)
 I ERROR D  Q
"RTN","DGENUPLA",139,0)
 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIO SEGMENT, SEQ 5, APPOINTMENT REQUEST ON 1010EZ",.ERRCOUNT)
"RTN","DGENUPLA",140,0)
 S DGPAT("APPREQDT")=$$CONVERT^DGENUPL1(SEG(6),"DATE",.ERROR)
"RTN","DGENUPLA",141,0)
 I ERROR D  Q
"RTN","DGENUPLA",142,0)
 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIO SEGMENT, SEQ 6, APPOINTMENT REQUEST DATE",.ERRCOUNT)
"RTN","DGENUPLA",143,0)
 Q
"RTN","DGENUPLA",144,0)
 ;
"RTN","DGENUPLA",145,0)
ZPD ;
"RTN","DGENUPLA",146,0)
 S DGELG("RATEINC")=$$CONVERT^DGENUPL1(SEG(8))
"RTN","DGENUPLA",147,0)
 S DGPAT("DEATH")=$$CONVERT^DGENUPL1(SEG(9),"TS",.ERROR)
"RTN","DGENUPLA",148,0)
 I ERROR D  Q
"RTN","DGENUPLA",149,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 9",.ERRCOUNT)
"RTN","DGENUPLA",150,0)
 S DGELG("MEDICAID")=$$CONVERT^DGENUPL1(SEG(12))
"RTN","DGENUPLA",151,0)
 S DGELG("MEDASKDT")=$$CONVERT^DGENUPL1(SEG(13),"TS",.ERROR)
"RTN","DGENUPLA",152,0)
 I ERROR D  Q
"RTN","DGENUPLA",153,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 13",.ERRCOUNT)
"RTN","DGENUPLA",154,0)
 S DGELG("POW")=$$CONVERT^DGENUPL1(SEG(17))
"RTN","DGENUPLA",155,0)
 S DGPAT("SPININJ")=$$CONVERT^DGENUPL1(SEG(30))
"RTN","DGENUPLA",156,0)
 S ERROR=$S(DGPAT("SPININJ")="":0,",1,2,3,4,X,"[(","_DGPAT("SPININJ")_","):0,DGPAT("SPININJ")="@":0,1:1)
"RTN","DGENUPLA",157,0)
 I ERROR D  Q
"RTN","DGENUPLA",158,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 30",.ERRCOUNT)
"RTN","DGENUPLA",159,0)
 ;DG*5.3*688
"RTN","DGENUPLA",160,0)
 S DGPAT("AG/ALLY")=$$CONVERT^DGENUPL1(SEG(35),"AGENCY",.ERROR)
"RTN","DGENUPLA",161,0)
 I ERROR D
"RTN","DGENUPLA",162,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 35",.ERRCOUNT)
"RTN","DGENUPLA",163,0)
 S DGPAT("EMGRES")=$$CONVERT^DGENUPL1(SEG(40)) ;DG*5.3*677
"RTN","DGENUPLA",164,0)
 Q
"RTN","DGENUPLA",165,0)
 ;
"RTN","DGENUPLA",166,0)
SITECNV(STRING) ; Convert claim folder loc (site # or site # and name) to
"RTN","DGENUPLA",167,0)
 ; ptr to file 4
"RTN","DGENUPLA",168,0)
 N SITE
"RTN","DGENUPLA",169,0)
 S SITE=""
"RTN","DGENUPLA",170,0)
 I STRING'="" D
"RTN","DGENUPLA",171,0)
 . N SUB,START,END
"RTN","DGENUPLA",172,0)
 . ; Find site ien if only site # is returned
"RTN","DGENUPLA",173,0)
 . I $O(^DIC(4,"D",STRING,0)) S SITE=$O(^DIC(4,"D",STRING,0)) Q
"RTN","DGENUPLA",174,0)
 . ; Check if name is concatenated onto site # to find site ien
"RTN","DGENUPLA",175,0)
 . S SUB=""
"RTN","DGENUPLA",176,0)
 . F  S SUB=$O(^DIC(4,"D",SUB)) Q:SUB=""  I $E(SUB,1,3)=$E(STRING,1,3),$$CHK(SUB,STRING) S SITE=$O(^DIC(4,"D",SUB,0)) Q
"RTN","DGENUPLA",177,0)
 ; SITE is the pointer to file 4 or null for site not found
"RTN","DGENUPLA",178,0)
 Q SITE
"RTN","DGENUPLA",179,0)
 ;
"RTN","DGENUPLA",180,0)
CHK(SUB,STRING) ;
"RTN","DGENUPLA",181,0)
 N IEN,X,STN,RET
"RTN","DGENUPLA",182,0)
 I SUB=STRING Q 1
"RTN","DGENUPLA",183,0)
 S RET=0
"RTN","DGENUPLA",184,0)
 S IEN=+$O(^DIC(4,"D",SUB,""))
"RTN","DGENUPLA",185,0)
 I IEN D
"RTN","DGENUPLA",186,0)
 . S X=$P($G(^DIC(4,IEN,0)),U),STN=$P($G(^(99)),U)
"RTN","DGENUPLA",187,0)
 . ; assume institution file names will be the same on HEC and VistA
"RTN","DGENUPLA",188,0)
 . I STN=SUB,X'="",$E($P(STRING,SUB,2,999),1,40)=X S RET=1
"RTN","DGENUPLA",189,0)
 Q RET
"RTN","DGENUPLA",190,0)
 ;
"RTN","DGLOCK")
0^2^B51327037
"RTN","DGLOCK",1,0)
DGLOCK ;ALB/MRL,ERC,BAJ,LBD - PATIENT FILE DATA EDIT CHECKS ; 2/1/11 3:31pm
"RTN","DGLOCK",2,0)
 ;;5.3;Registration;**108,161,247,485,672,673,688,754**;Aug 13, 1993;Build 46
"RTN","DGLOCK",3,0)
FFP ; DGFFP Access key required
"RTN","DGLOCK",4,0)
 I '$D(^XUSEC("DGFFP ACCESS",DUZ)) D EN^DDIOL("Fugitive Felon Key required to edit this field.","","!!?4") K X
"RTN","DGLOCK",5,0)
 Q
"RTN","DGLOCK",6,0)
EK ;EKey Rqrd
"RTN","DGLOCK",7,0)
 I '$D(^XUSEC("DG ELIGIBILITY",DUZ)) W !?4,$C(7),"Eligibility Key required to edit this field." K X
"RTN","DGLOCK",8,0)
 Q
"RTN","DGLOCK",9,0)
EV ;EK rqrd if Elig Ver
"RTN","DGLOCK",10,0)
 I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D EN^DDIOL("Eligibility verified...Eligibility Key required to edit this field.","","!?4") K X
"RTN","DGLOCK",11,0)
 Q
"RTN","DGLOCK",12,0)
EV2 ;if elig is ver Discharged Due to Disability can't be edited - DG 672
"RTN","DGLOCK",13,0)
 ;if elig is ver P&T and P&T Eff Date can't be edited - DG*5.3*688
"RTN","DGLOCK",14,0)
 I $D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D
"RTN","DGLOCK",15,0)
 . I $P(^DPT(DFN,.361),U,3)'="H" Q
"RTN","DGLOCK",16,0)
 . D EN^DDIOL("Eligibility verified at the HEC...NO EDITING!","","!?4") K X
"RTN","DGLOCK",17,0)
 Q
"RTN","DGLOCK",18,0)
SV ;EK Rqrd if Svc Rcrd Ver
"RTN","DGLOCK",19,0)
 I "NU"'[$E(X) D VET Q:'$D(X)
"RTN","DGLOCK",20,0)
SV1 I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.32)) I $P(^(.32),U,2)]"" D EN^DDIOL("Service Record verfied...Eligibility Key required to edit this field.","","!?4") K X
"RTN","DGLOCK",21,0)
 Q
"RTN","DGLOCK",22,0)
MV ;EK Rqrd if Money Ver
"RTN","DGLOCK",23,0)
 I "NU"'[$E(X) D VET Q:'$D(X)
"RTN","DGLOCK",24,0)
 I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.3)) I $P(^(.3),U,6)]"" W !?4,$C(7),"Monetary Benefits verified...Eligibility Key required to edit this field." K X
"RTN","DGLOCK",25,0)
 Q
"RTN","DGLOCK",26,0)
VET ;Veteran
"RTN","DGLOCK",27,0)
 S DGVV=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:""),DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"")
"RTN","DGLOCK",28,0)
 I $D(^DPT(DFN,"VET")),^("VET")'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X
"RTN","DGLOCK",29,0)
 K DGVV Q
"RTN","DGLOCK",30,0)
VAGE ;Vet Age
"RTN","DGLOCK",31,0)
 S DGDATA=X,X1=DT,X2=$S($D(DFN):$P(^DPT(DFN,0),U,3),1:DPTIDS(.03)) S X=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7))
"RTN","DGLOCK",32,0)
 I X<17 W !?4,$C(7),"Applicant is TOO YOUNG to be a veteran...ONLY ",X," YEARS OLD!!",!?4,"See your supervisor if you require assistance." K X,X1,X2,DGDATA Q
"RTN","DGLOCK",33,0)
 S X=DGDATA K X1,X2,DGDATA Q
"RTN","DGLOCK",34,0)
AO ;Agent Orange
"RTN","DGLOCK",35,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,2)'="Y":1,1:0) W !?4,$C(7),"Exposure to Agent Orange not indicated...NO EDITING!" K X
"RTN","DGLOCK",36,0)
 Q
"RTN","DGLOCK",37,0)
EC ;SW Asia Contaminants - name change from Env. Contam. DG*5.3*688
"RTN","DGLOCK",38,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.322)):1,$P(^(.322),U,13)'="Y":1,1:0) W !?4,$C(7),"Southwest Asia Conditions not indicated...NO EDITING!" K X
"RTN","DGLOCK",39,0)
 I $D(X) I X<2900802 K X W !?4,$C(7),"Date must be on or after 8/2/1990!"
"RTN","DGLOCK",40,0)
 Q
"RTN","DGLOCK",41,0)
COM ;Combat
"RTN","DGLOCK",42,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.52)):1,$P(^(.52),U,11)'="Y":1,1:0) W !?4,$C(7),"Service in Combat Zone not indicated...NO EDITING!" K X
"RTN","DGLOCK",43,0)
 Q
"RTN","DGLOCK",44,0)
INE ;Ineligible
"RTN","DGLOCK",45,0)
 D EK I $D(X),$S('$D(^DPT(DFN,.15)):1,$P(^(.15),U,2)']"":1,1:0) W !?4,$C(7),"Requirement for 'Ineligible patient' data not indicated...NO EDITING!" K X
"RTN","DGLOCK",46,0)
 Q
"RTN","DGLOCK",47,0)
IR ;ION Rad
"RTN","DGLOCK",48,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,3)'="Y":1,1:0) W !?4,$C(7),"Exposure to Ionizing Radiation is not indicated...NO EDITING!" K X
"RTN","DGLOCK",49,0)
 Q
"RTN","DGLOCK",50,0)
POW ;Prisoner of War
"RTN","DGLOCK",51,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.52)):1,$P(^(.52),U,5)'="Y":1,1:0) W !?5,$C(7),"Not identified as a former Prisoner of War...NO EDITING!" K X
"RTN","DGLOCK",52,0)
 Q
"RTN","DGLOCK",53,0)
SER1 ;NTL Svc
"RTN","DGLOCK",54,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.32)):1,$P(^(.32),U,19)'="Y":1,X="N":0,1:0) W !?4,$C(7),"Other Periods of Service are not indicated...NO EDITING!" K X
"RTN","DGLOCK",55,0)
 Q
"RTN","DGLOCK",56,0)
SER2 ;NNTL
"RTN","DGLOCK",57,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.32)):1,$P(^(.32),U,20)'="Y":1,X="N":0,1:0) W !?4,$C(7),"Third Period of Service is not indicated...NO EDITING!" K X
"RTN","DGLOCK",58,0)
 Q
"RTN","DGLOCK",59,0)
TAD ;Temp Add Edit
"RTN","DGLOCK",60,0)
 I $S('$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) W !?4,$C(7),"Requirement for Temporary Address data not indicated...NO EDITING!" K X
"RTN","DGLOCK",61,0)
 Q
"RTN","DGLOCK",62,0)
TADD ;Temp Address Delete?
"RTN","DGLOCK",63,0)
 Q:'$D(^DPT(DFN,.121))  I $P(^(.121),"^",9)="N"!($P(^(.121),"^",1,6)="^^^^^") Q
"RTN","DGLOCK",64,0)
ASK W !,"Do you want to delete all temporary address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove temporary address information, 'N'o to leave data in file" G ASK
"RTN","DGLOCK",65,0)
 Q:%'=1  D EN^DGCLEAR(DFN,"TEMP") Q
"RTN","DGLOCK",66,0)
VN ;Viet Svc
"RTN","DGLOCK",67,0)
 D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,1)'="Y":1,1:0) I "UN"'[$E(X) W !?4,$C(7),"Service in Republic of Vietnam not indicated...NO EDITING!" K X
"RTN","DGLOCK",68,0)
 Q
"RTN","DGLOCK",69,0)
 ;
"RTN","DGLOCK",70,0)
OEIF ;OIF/ OEF/ UNKNOWN OEF/OIF Svc
"RTN","DGLOCK",71,0)
 D SV
"RTN","DGLOCK",72,0)
 Q
"RTN","DGLOCK",73,0)
SVED ;Lebanon, Grenada, Panama, Persian Gulf & Yugoslavia svc edit
"RTN","DGLOCK",74,0)
 ;      (from and to dates)
"RTN","DGLOCK",75,0)
 ;DGX = piece position of corresponding service indicated? field
"RTN","DGLOCK",76,0)
 ;      for multiple serv indicated dgx=sv1^sv2^...
"RTN","DGLOCK",77,0)
 ;DGSV= service (sv1, sv2 from above)
"RTN","DGLOCK",78,0)
 ;DGOK= 1=YES,at least one of the required sv indicated is yes,0=NO
"RTN","DGLOCK",79,0)
 D SV I '$D(X) K DGX Q
"RTN","DGLOCK",80,0)
 N DGSV,DGOK,DGPC,PC
"RTN","DGLOCK",81,0)
 S DGOK=0
"RTN","DGLOCK",82,0)
 F PC=1:1 S DGSV=$P(DGX,U,PC) Q:DGSV']""  S:$P($G(^DPT(DFN,.322)),U,DGSV)="Y" DGOK=1
"RTN","DGLOCK",83,0)
 S PC=PC-1
"RTN","DGLOCK",84,0)
 I DGOK=0 D
"RTN","DGLOCK",85,0)
 .I "UN"'[$E(X) D
"RTN","DGLOCK",86,0)
 ..W !?4,$C(7),"Service in "
"RTN","DGLOCK",87,0)
 ..F DGPC=1:1:PC D
"RTN","DGLOCK",88,0)
 ...S DGSV=$P(DGX,U,DGPC) W $S(DGSV=1:"Lebanon",DGSV=4:"Grenada",DGSV=7:"Panama",DGSV=10:"Persian Gulf",DGSV=16:"Somalia",DGSV=19:"Yugoslavia",1:"")
"RTN","DGLOCK",89,0)
 ...W:(DGPC<PC) " or "
"RTN","DGLOCK",90,0)
 ..W " not indicated...NO EDITING!" K X
"RTN","DGLOCK",91,0)
 K DGX
"RTN","DGLOCK",92,0)
 Q
"RTN","DGLOCK",93,0)
PTDT  ;P&T Effective Date cannot be edited unless P&T is 'YES' - DG*5.3*688
"RTN","DGLOCK",94,0)
 ;P&T Effective Date cannot be earlier than the DOB or after DOD - DG*5.3*754
"RTN","DGLOCK",95,0)
 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),U,4)'="Y":1,1:0) D EN^DDIOL("P&T not indicated...no editing","","!?4") K X Q
"RTN","DGLOCK",96,0)
 N DGFLD
"RTN","DGLOCK",97,0)
 S DGFLD=$P(^DD(2,.3013,0),U)
"RTN","DGLOCK",98,0)
 I $G(X)<$P(^DPT(DFN,0),U,3) D  Q
"RTN","DGLOCK",99,0)
 . D DOBDOD(DGFLD,1)
"RTN","DGLOCK",100,0)
 I $P($G(^DPT(DFN,.35)),U)]"" D
"RTN","DGLOCK",101,0)
 . I $G(X)>$P(^DPT(DFN,.35),U) D
"RTN","DGLOCK",102,0)
 . . D DOBDOD(DGFLD,2)
"RTN","DGLOCK",103,0)
 Q
"RTN","DGLOCK",104,0)
POWV  ;POW Status cannot be edited once it has been verified by the HEC
"RTN","DGLOCK",105,0)
 ;DG*5.3*688
"RTN","DGLOCK",106,0)
 I $P($G(^DPT(DFN,.52)),U,9)'="" D EN^DDIOL("POW Status verified at the HEC...NO EDITING!!","","!?4") K X
"RTN","DGLOCK",107,0)
 Q
"RTN","DGLOCK",108,0)
INEL ;check ineligible date - cannot be before DOB
"RTN","DGLOCK",109,0)
 ;DG*5.3*754
"RTN","DGLOCK",110,0)
 N DGFLD
"RTN","DGLOCK",111,0)
 I $G(X)<$P(^DPT(DFN,0),U,3) D
"RTN","DGLOCK",112,0)
 . S DGFLD=$P(^DD(2,.152,0),U)
"RTN","DGLOCK",113,0)
 . D DOBDOD(DGFLD,1)
"RTN","DGLOCK",114,0)
 Q
"RTN","DGLOCK",115,0)
INCOM ;check date ruled incompetent (VA) - cannot be before DOB
"RTN","DGLOCK",116,0)
 ;or after DOD - DG*5.3*754)
"RTN","DGLOCK",117,0)
 N DGFLD
"RTN","DGLOCK",118,0)
 S DGFLD=$P(^DD(2,.291,0),U)
"RTN","DGLOCK",119,0)
 I $G(X)<$P(^DPT(DFN,0),U,3) D  Q
"RTN","DGLOCK",120,0)
 . D DOBDOD(DGFLD,1)
"RTN","DGLOCK",121,0)
 I $P($G(^DPT(DFN,.35)),U)]"" D
"RTN","DGLOCK",122,0)
 . I $G(X)>$P(^DPT(DFN,.35),U) D
"RTN","DGLOCK",123,0)
 . . D DOBDOD(DGFLD,2)
"RTN","DGLOCK",124,0)
 Q
"RTN","DGLOCK",125,0)
INCOM2 ;check date ruled incompetent (civil - cannot be before DOB
"RTN","DGLOCK",126,0)
 ;or after DOD - DG*5.3*754)
"RTN","DGLOCK",127,0)
 N DGFLD
"RTN","DGLOCK",128,0)
 S DGFLD=$P(^DD(2,.292,0),U)
"RTN","DGLOCK",129,0)
 I $G(X)<$P(^DPT(DFN,0),U,3) D  Q
"RTN","DGLOCK",130,0)
 . D DOBDOD(DGFLD,1)
"RTN","DGLOCK",131,0)
 I $P($G(^DPT(DFN,.35)),U)]"" D
"RTN","DGLOCK",132,0)
 . I $G(X)>$P(^DPT(DFN,.35),U) D
"RTN","DGLOCK",133,0)
 . . D DOBDOD(DGFLD,2)
"RTN","DGLOCK",134,0)
 Q
"RTN","DGLOCK",135,0)
DOBDOD(DGFLD,DGX) ;called from subroutines to check if 
"RTN","DGLOCK",136,0)
 ;date is before DOB or after DOD.  The subroutines 
"RTN","DGLOCK",137,0)
 ;are called from the field input transforms. DG*5.3*754
"RTN","DGLOCK",138,0)
 I $G(DGFLD)']"" Q
"RTN","DGLOCK",139,0)
 I "12"'[$G(DGX) Q
"RTN","DGLOCK",140,0)
 D EN^DDIOL(DGFLD_" cannot be "_$S(DGX=1:"prior to",1:"after")_" Date of "_$S(DGX=1:"Birth.",1:"Death."),"","!?4")
"RTN","DGLOCK",141,0)
 K X
"RTN","DGLOCK",142,0)
 Q
"RTN","DGLOCK",143,0)
DEATH ;new date constraints added with ESR 3.1 - DG*5.3*754
"RTN","DGLOCK",144,0)
 Q:$G(X)'>0
"RTN","DGLOCK",145,0)
 N DGFLD
"RTN","DGLOCK",146,0)
 S DGFLD=$P(^DD(2,.351,0),U)
"RTN","DGLOCK",147,0)
 ;check for DOD before DOB
"RTN","DGLOCK",148,0)
 I X<$P(^DPT(DFN,0),U,3) D DOBDOD(DGFLD,1) Q
"RTN","DGLOCK",149,0)
 ;check for DOD before P&T Effective Date
"RTN","DGLOCK",150,0)
 I X<$P($G(^DPT(DFN,.3)),U,13) D  Q
"RTN","DGLOCK",151,0)
 . D EN^DDIOL(DGFLD_" cannot be prior to the P&T Effective Date","","!?4")
"RTN","DGLOCK",152,0)
 . K X
"RTN","DGLOCK",153,0)
 ;check for DOD before Date Ruled Incompetent (VA)
"RTN","DGLOCK",154,0)
 I X<$P($G(^DPT(DFN,.29)),U) D  Q
"RTN","DGLOCK",155,0)
 . D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (VA)","","!?4")
"RTN","DGLOCK",156,0)
 . K X
"RTN","DGLOCK",157,0)
 ;check for DOD before Date Ruled Incompetent (Civil)
"RTN","DGLOCK",158,0)
 I X<$P($G(^DPT(DFN,.29)),U,2) D  Q
"RTN","DGLOCK",159,0)
 . D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (Civil)","","!?4")
"RTN","DGLOCK",160,0)
 . K X
"RTN","DGLOCK",161,0)
 ;check for DOD before Enrollment Application Date
"RTN","DGLOCK",162,0)
 ;I $P($G(^DPT(DFN,"ENR")),U)>0 D
"RTN","DGLOCK",163,0)
 ;. N DGENR
"RTN","DGLOCK",164,0)
 ;. S DGENR=$P(^DPT(DFN,"ENR"),U)
"RTN","DGLOCK",165,0)
 ;. Q:$G(DGENR)']""
"RTN","DGLOCK",166,0)
 ;. Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN
"RTN","DGLOCK",167,0)
 ;. I X<$P(^DGEN(27.11,DGENR,0),U) D
"RTN","DGLOCK",168,0)
 ;. . D EN^DDIOL(DGFLD_" cannot be prior to the Enrollment Application Date","","!?4")
"RTN","DGLOCK",169,0)
 ;. . K X
"RTN","DGLOCK",170,0)
 Q
"RTN","DGLOCK",171,0)
BIRTH ;checks for DOB added with DG*5.3*754
"RTN","DGLOCK",172,0)
 I (($G(EASAPP)'="")&($G(DGADDF)=1)) Q  ;Ignore New 1010EZ patients
"RTN","DGLOCK",173,0)
 Q:$G(X)'>0
"RTN","DGLOCK",174,0)
 Q:'$D(DA)
"RTN","DGLOCK",175,0)
 N DFN
"RTN","DGLOCK",176,0)
 S DFN=DA
"RTN","DGLOCK",177,0)
 N DGFLD
"RTN","DGLOCK",178,0)
 S DGFLD=$P(^DD(2,.03,0),U)
"RTN","DGLOCK",179,0)
 ;check for DOB after Ineligible Date
"RTN","DGLOCK",180,0)
 I $P($G(^DPT(DFN,.15)),U,2)]"" D  Q:'$G(X)
"RTN","DGLOCK",181,0)
 . I X>$P(^DPT(DFN,.15),U,2) D
"RTN","DGLOCK",182,0)
 . . D EN^DDIOL(DGFLD_" cannot be after the Ineligible Date","","!?4") K X
"RTN","DGLOCK",183,0)
 ;check for DOB after Enrollment Application Date
"RTN","DGLOCK",184,0)
 I $P($G(^DPT(DFN,"ENR")),U)>0 D
"RTN","DGLOCK",185,0)
 . N DGENR
"RTN","DGLOCK",186,0)
 . S DGENR=$P(^DPT(DFN,"ENR"),U)
"RTN","DGLOCK",187,0)
 . Q:$G(DGENR)']""
"RTN","DGLOCK",188,0)
 . Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN
"RTN","DGLOCK",189,0)
 . I X>$P(^DGEN(27.11,DGENR,0),U) D
"RTN","DGLOCK",190,0)
 . . D EN^DDIOL(DGFLD_" cannot be after the Enrollment Application Date","","!?4")
"RTN","DGLOCK",191,0)
 . . K X
"RTN","DGLOCK",192,0)
 Q
"RTN","DGREGTE2")
0^19^B21234416
"RTN","DGREGTE2",1,0)
DGREGTE2 ;ALB/BAJ,TDM - Temporary & Confidential Address Support Routine; 02/27/2006 ; 12/24/08 12:12pm
"RTN","DGREGTE2",2,0)
 ;;5.3;Registration;**688,754**;Aug 13, 1993;Build 46
"RTN","DGREGTE2",3,0)
 ;
"RTN","DGREGTE2",4,0)
 Q
"RTN","DGREGTE2",5,0)
 ;
"RTN","DGREGTE2",6,0)
GETOLD(DGCMP,DFN,TYPE) ;populate array with existing address info
"RTN","DGREGTE2",7,0)
 N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,FDESC,FNODE,FPECE,CCNTRY,COUNTRY
"RTN","DGREGTE2",8,0)
 S CFORGN=0,FDESC=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTRY",1:"CONFIDENTIAL ADDR COUNTRY")
"RTN","DGREGTE2",9,0)
 ; get current country
"RTN","DGREGTE2",10,0)
 S FNODE=$S(TYPE="TEMP":.122,TYPE="CONF":.141,1:.11)
"RTN","DGREGTE2",11,0)
 S FPECE=$S(TYPE="TEMP":3,TYPE="CONF":16,1:10)
"RTN","DGREGTE2",12,0)
 S CCIEN=$P($G(^DPT(DFN,FNODE)),U,FPECE)
"RTN","DGREGTE2",13,0)
 I CCIEN="" S CCNTRY=$O(^HL(779.004,"D","UNITED STATES",""))
"RTN","DGREGTE2",14,0)
 S CFORGN=$$FORIEN^DGADDUTL(CCIEN)
"RTN","DGREGTE2",15,0)
 ;get current address fields and xlate to ^DIQ format
"RTN","DGREGTE2",16,0)
 S CFSTR=$$INPT1(DFN,CFORGN),CFSTR=$TR(CFSTR,",",";")
"RTN","DGREGTE2",17,0)
 ; Domestic data needs some extra fields
"RTN","DGREGTE2",18,0)
 ; add country field before lookup
"RTN","DGREGTE2",19,0)
 D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR")
"RTN","DGREGTE2",20,0)
 F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E"))
"RTN","DGREGTE2",21,0)
 S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY"
"RTN","DGREGTE2",22,0)
 S DGCMP("OLD",FCNTRY)=COUNTRY
"RTN","DGREGTE2",23,0)
 I 'CFORGN D
"RTN","DGREGTE2",24,0)
 . S DGCIEN=$G(DGCURR(2,DFN_",",FCOUNTY,"I"))
"RTN","DGREGTE2",25,0)
 . S DGST=$G(DGCURR(2,DFN_",",FSTATE,"I"))
"RTN","DGREGTE2",26,0)
 . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
"RTN","DGREGTE2",27,0)
 . I DGCNTY=-1 S DGCNTY=""
"RTN","DGREGTE2",28,0)
 . S DGCMP("OLD",FCOUNTY)="" I DGCNTY]"" S DGCMP("OLD",FCOUNTY)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3)
"RTN","DGREGTE2",29,0)
 Q
"RTN","DGREGTE2",30,0)
INPT1(DFN,FORGN,PSTR) ; address input prompts
"RTN","DGREGTE2",31,0)
 N FSTR
"RTN","DGREGTE2",32,0)
 ; PSTR contains the full list of address fields to be modified
"RTN","DGREGTE2",33,0)
 ; FSTR contains the field list based on country
"RTN","DGREGTE2",34,0)
 S PSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPROV_","_FPSTAL_","_FCNTRY_","_FPHONE
"RTN","DGREGTE2",35,0)
 S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPHONE
"RTN","DGREGTE2",36,0)
 I FORGN S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FPROV_","_FPSTAL_","_FPHONE
"RTN","DGREGTE2",37,0)
 Q FSTR
"RTN","DGREGTE2",38,0)
 ;
"RTN","DGREGTE2",39,0)
SURE() ; Are you sure prompt
"RTN","DGREGTE2",40,0)
 N DIR,X,Y,DUOUT,DTOUT,DIRUT
"RTN","DGREGTE2",41,0)
 S DIR(0)="Y"
"RTN","DGREGTE2",42,0)
 S DIR("B")="NO"
"RTN","DGREGTE2",43,0)
 S DIR("A")="   SURE YOU WANT TO DELETE"
"RTN","DGREGTE2",44,0)
 D ^DIR
"RTN","DGREGTE2",45,0)
 Q Y
"RTN","DGREGTE2",46,0)
SKIP(DGN,DGINPUT) ; determine whether or not to skip the prompt
"RTN","DGREGTE2",47,0)
 N SKIP,NULL
"RTN","DGREGTE2",48,0)
 S SKIP=0
"RTN","DGREGTE2",49,0)
 S NULL=($G(DGINPUT(FSLINE1))="")!(($G(DGINPUT(FSLINE1))="@"))
"RTN","DGREGTE2",50,0)
 I NULL,(DGN=FSLINE2) S SKIP=1
"RTN","DGREGTE2",51,0)
 S NULL=($G(DGINPUT(FSLINE2))="")!(($G(DGINPUT(FSLINE2))="@"))
"RTN","DGREGTE2",52,0)
 I NULL,(DGN=FSLINE3) S SKIP=1
"RTN","DGREGTE2",53,0)
 Q SKIP
"RTN","DGREGTE2",54,0)
 ;
"RTN","DGREGTE2",55,0)
INIT ; initialize variables
"RTN","DGREGTE2",56,0)
 ; This tag reads the table at FLDDAT (below) to set relationship between
"RTN","DGREGTE2",57,0)
 ; variables and Field numbers.
"RTN","DGREGTE2",58,0)
 ; 
"RTN","DGREGTE2",59,0)
 ; Set up array of fields needed
"RTN","DGREGTE2",60,0)
 N I,T,FTYPE,VNAME,FNUM,RFLD
"RTN","DGREGTE2",61,0)
 F I=1:1 S T=$P($T(FLDDAT+I^DGREGTE2),";;",3) Q:T="QUIT"  D
"RTN","DGREGTE2",62,0)
 . S FTYPE=$P(T,";",1),VNAME=$P(T,";",2),FNUM=$P(T,";",3)
"RTN","DGREGTE2",63,0)
 . I FTYPE=TYPE S @VNAME=FNUM
"RTN","DGREGTE2",64,0)
 ; Set up array of field and prompting rules
"RTN","DGREGTE2",65,0)
 K T,I
"RTN","DGREGTE2",66,0)
 F I=1:1 S T=$P($T(FLDPRMPT+I^DGREGTE2),";;",2) Q:T="QUIT"  D
"RTN","DGREGTE2",67,0)
 . S RFLD=$P(T,";",1) I RFLD'="ALL" S RFLD=@RFLD
"RTN","DGREGTE2",68,0)
 . S RPROC(RFLD,$P(T,";",2),$P(T,";",3))=$P(T,";",4)
"RTN","DGREGTE2",69,0)
 Q
"RTN","DGREGTE2",70,0)
FLDDAT ; Table of field values STRUCTURE --> Description;;Type;Variable Name;Field Number
"RTN","DGREGTE2",71,0)
 ;;Street Line 1;;TEMP;FSLINE1;.1211
"RTN","DGREGTE2",72,0)
 ;;Street Line 2;;TEMP;FSLINE2;.1212
"RTN","DGREGTE2",73,0)
 ;;Street Line 3;;TEMP;FSLINE3;.1213
"RTN","DGREGTE2",74,0)
 ;;City;;TEMP;FCITY;.1214
"RTN","DGREGTE2",75,0)
 ;;State;;TEMP;FSTATE;.1215
"RTN","DGREGTE2",76,0)
 ;;County;;TEMP;FCOUNTY;.12111
"RTN","DGREGTE2",77,0)
 ;;Zip;;TEMP;FZIP;.12112
"RTN","DGREGTE2",78,0)
 ;;Phone;;TEMP;FPHONE;.1219
"RTN","DGREGTE2",79,0)
 ;;Province;;TEMP;FPROV;.1221
"RTN","DGREGTE2",80,0)
 ;;Postal Code;;TEMP;FPSTAL;.1222
"RTN","DGREGTE2",81,0)
 ;;Country;;TEMP;FCNTRY;.1223
"RTN","DGREGTE2",82,0)
 ;;Address Node 1;;TEMP;FNODE1;.121
"RTN","DGREGTE2",83,0)
 ;;Address Node 2;;TEMP;FNODE2;.122
"RTN","DGREGTE2",84,0)
 ;;Country data piece;;TEMP;CPEICE;3
"RTN","DGREGTE2",85,0)
 ;;Street Line 1;;CONF;FSLINE1;.1411
"RTN","DGREGTE2",86,0)
 ;;Street Line 2;;CONF;FSLINE2;.1412
"RTN","DGREGTE2",87,0)
 ;;Street Line 3;;CONF;FSLINE3;.1413
"RTN","DGREGTE2",88,0)
 ;;City;;CONF;FCITY;.1414
"RTN","DGREGTE2",89,0)
 ;;State;;CONF;FSTATE;.1415
"RTN","DGREGTE2",90,0)
 ;;County;;CONF;FCOUNTY;.14111
"RTN","DGREGTE2",91,0)
 ;;Zip;;CONF;FZIP;.1416
"RTN","DGREGTE2",92,0)
 ;;Phone;;CONF;FPHONE;.1315
"RTN","DGREGTE2",93,0)
 ;;Province;;CONF;FPROV;.14114
"RTN","DGREGTE2",94,0)
 ;;Postal Code;;CONF;FPSTAL;.14115
"RTN","DGREGTE2",95,0)
 ;;Country;;CONF;FCNTRY;.14116
"RTN","DGREGTE2",96,0)
 ;;Address Node 1;;CONF;FNODE1;.141
"RTN","DGREGTE2",97,0)
 ;;Address Node 2;;CONF;FNODE2;.141
"RTN","DGREGTE2",98,0)
 ;;Country data piece;;CONF;CPEICE;16
"RTN","DGREGTE2",99,0)
 ;;QUIT;;QUIT
"RTN","DGREGTE2",100,0)
 ;;
"RTN","DGREGTE2",101,0)
FLDPRMPT ;Table of prompts and responses STRUCTURE --> Description;;Field;Old Value;New Value;Response Code
"RTN","DGREGTE2",102,0)
 ;;ALL;NULL;UPCAR;REPEAT
"RTN","DGREGTE2",103,0)
 ;;ALL;NULL;DELETE;QUES
"RTN","DGREGTE2",104,0)
 ;;ALL;NULL;VALUE;OK
"RTN","DGREGTE2",105,0)
 ;;ALL;VALUE;UPCAR;REPEAT
"RTN","DGREGTE2",106,0)
 ;;ALL;VALUE;NULL;OK
"RTN","DGREGTE2",107,0)
 ;;ALL;VALUE;VALUE;OK
"RTN","DGREGTE2",108,0)
 ;;FSLINE1;NULL;NULL;REVERSE
"RTN","DGREGTE2",109,0)
 ;;FSLINE2;NULL;NULL;OK
"RTN","DGREGTE2",110,0)
 ;;FSLINE3;NULL;NULL;OK
"RTN","DGREGTE2",111,0)
 ;;FCITY;NULL;NULL;REVERSE
"RTN","DGREGTE2",112,0)
 ;;FSTATE;NULL;NULL;REVERSE
"RTN","DGREGTE2",113,0)
 ;;FZIP;NULL;NULL;REVERSE
"RTN","DGREGTE2",114,0)
 ;;FCOUNTY;NULL;NULL;REVERSE
"RTN","DGREGTE2",115,0)
 ;;FPROV;NULL;NULL;OK
"RTN","DGREGTE2",116,0)
 ;;FPSTAL;NULL;NULL;OK
"RTN","DGREGTE2",117,0)
 ;;FCNTRY;NULL;NULL;REVERSE
"RTN","DGREGTE2",118,0)
 ;;FSLINE1;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",119,0)
 ;;FSLINE2;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",120,0)
 ;;FSLINE3;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",121,0)
 ;;FCITY;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",122,0)
 ;;FSTATE;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",123,0)
 ;;FZIP;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",124,0)
 ;;FCOUNTY;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",125,0)
 ;;FPROV;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",126,0)
 ;;FPSTAL;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",127,0)
 ;;FCNTRY;VALUE;DELETE;REVERSE
"RTN","DGREGTE2",128,0)
 ;;QUIT
"RTN","DGREGTE2",129,0)
 ;;
"RTN","DGRODEBR")
0^3^B51758161
"RTN","DGRODEBR",1,0)
DGRODEBR ;DJH/AMA,TDM - ROM DATA ELEMENT BUSINESS RULES ; 4/7/10 4:16pm
"RTN","DGRODEBR",2,0)
 ;;5.3;Registration;**533,572,754**;Aug 13, 1993;Build 46
"RTN","DGRODEBR",3,0)
 ;
"RTN","DGRODEBR",4,0)
 ;BUSINESS RULES TO BE CHECKED JUST BEFORE FILING THE
"RTN","DGRODEBR",5,0)
 ;PATIENT DATA RETRIEVED FROM THE LAST SITE TREATED (LST)
"RTN","DGRODEBR",6,0)
 ;
"RTN","DGRODEBR",7,0)
 ;* DG*5.3*572 changed "I"nternal references to "E"xternal references
"RTN","DGRODEBR",8,0)
POW(DGDATA,DFN,LSTDFN) ;POW STATUS INDICATED?
"RTN","DGRODEBR",9,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",10,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",11,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",12,0)
 N RSPOW    ;REQUESTING SITE POW STATUS INDICATED
"RTN","DGRODEBR",13,0)
 N LSTPOW   ;LAST SITE TREATED POW STATUS INDICATED
"RTN","DGRODEBR",14,0)
 S RSPOW=$$GET1^DIQ(2,DFN,.525)
"RTN","DGRODEBR",15,0)
 S LSTPOW=$G(@DGDATA@(2,LSTDFN_",",.525,"E"))
"RTN","DGRODEBR",16,0)
 ;If either of the POW STATUS INDICATED? flags
"RTN","DGRODEBR",17,0)
 ;are "N"o, don't file the POW data element(s)
"RTN","DGRODEBR",18,0)
 I (RSPOW="NO")!(LSTPOW="NO") D
"RTN","DGRODEBR",19,0)
 . N FIELD
"RTN","DGRODEBR",20,0)
 . F FIELD=.525:.001:.528 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",21,0)
 Q
"RTN","DGRODEBR",22,0)
 ;
"RTN","DGRODEBR",23,0)
AO(DGDATA,DFN,LSTDFN) ;AGENT ORANGE EXPOSURE INDICATED?
"RTN","DGRODEBR",24,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",25,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",26,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",27,0)
 N RSAO    ;R.S. AGENT ORANGE EXPOSURE INDICATED
"RTN","DGRODEBR",28,0)
 N LSTAO   ;LST AGENT ORANGE EXPOSURE INDICATED
"RTN","DGRODEBR",29,0)
 S RSAO=$$GET1^DIQ(2,DFN,.32102)
"RTN","DGRODEBR",30,0)
 S LSTAO=$G(@DGDATA@(2,LSTDFN_",",.32102,"E"))
"RTN","DGRODEBR",31,0)
 ;If either of the AGENT ORANGE EXPOSURE INDICATED?
"RTN","DGRODEBR",32,0)
 ;flags are "N"o, delete the AO data element(s)
"RTN","DGRODEBR",33,0)
 I (RSAO="NO")!(LSTAO="NO") D
"RTN","DGRODEBR",34,0)
 . N FIELD
"RTN","DGRODEBR",35,0)
 . ;added AO LOCATION OF EXPOSURE (2/.3213) for DG*5.3*572  DJH
"RTN","DGRODEBR",36,0)
 . F FIELD=.32102,.32107,.32108,.32109,.3211,.3213 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",37,0)
 Q
"RTN","DGRODEBR",38,0)
 ;
"RTN","DGRODEBR",39,0)
IR(DGDATA,DFN,LSTDFN) ;RADIATION EXPOSURE INDICATED?
"RTN","DGRODEBR",40,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",41,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",42,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",43,0)
 N RSIR    ;R.S. RADIATION EXPOSURE INDICATED
"RTN","DGRODEBR",44,0)
 N LSTIR   ;LST RADIATION EXPOSURE INDICATED
"RTN","DGRODEBR",45,0)
 S RSIR=$$GET1^DIQ(2,DFN,.32103)
"RTN","DGRODEBR",46,0)
 S LSTIR=$G(@DGDATA@(2,LSTDFN_",",.32103,"E"))
"RTN","DGRODEBR",47,0)
 ;If either of the RADIATION EXPOSURE INDICATED
"RTN","DGRODEBR",48,0)
 ;flags are "N"o, delete the IR data elements
"RTN","DGRODEBR",49,0)
 I (RSIR="NO")!(LSTIR="NO") D
"RTN","DGRODEBR",50,0)
 . N FIELD
"RTN","DGRODEBR",51,0)
 . F FIELD=.32103,.32111,.3212 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",52,0)
 Q
"RTN","DGRODEBR",53,0)
 ;
"RTN","DGRODEBR",54,0)
INC(DGDATA,DFN,LSTDFN) ;RATED INCOMPETENT (Y/N)
"RTN","DGRODEBR",55,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",56,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",57,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",58,0)
 N RSIN    ;RATED INCOMPETENT (Y/N)
"RTN","DGRODEBR",59,0)
 N LSTIN   ;LST RATED INCOMPETENT (Y/N)
"RTN","DGRODEBR",60,0)
 S RSIN=$$GET1^DIQ(2,DFN,.293)
"RTN","DGRODEBR",61,0)
 S LSTIN=$G(@DGDATA@(2,LSTDFN_",",.293,"E"))
"RTN","DGRODEBR",62,0)
 ;If either of the RATED INCOMPETENT
"RTN","DGRODEBR",63,0)
 ;flags are "N"o, delete the IR data elements
"RTN","DGRODEBR",64,0)
 I (RSIN="NO")!(LSTIN="NO") D
"RTN","DGRODEBR",65,0)
 . N FIELD
"RTN","DGRODEBR",66,0)
 . F FIELD=.292,.293 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",67,0)
 Q
"RTN","DGRODEBR",68,0)
 ;
"RTN","DGRODEBR",69,0)
INE(DGDATA,DFN,LSTDFN) ;INELIGIBLE DATA
"RTN","DGRODEBR",70,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",71,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",72,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",73,0)
 ;
"RTN","DGRODEBR",74,0)
 N LSTID ;INELIGIBLE DATE
"RTN","DGRODEBR",75,0)
 S LSTID=$G(@DGDATA@(2,LSTDFN_",",.152,"E"))
"RTN","DGRODEBR",76,0)
 ;
"RTN","DGRODEBR",77,0)
 ;If no INELIGIBLE DATE from LST don't upload ineligible fields.
"RTN","DGRODEBR",78,0)
 I LSTID="" D
"RTN","DGRODEBR",79,0)
 . N FIELD
"RTN","DGRODEBR",80,0)
 . F FIELD=.152,.307,.1651,.1653,.1654,.1656 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",81,0)
 Q
"RTN","DGRODEBR",82,0)
 ;
"RTN","DGRODEBR",83,0)
DOD(DGDATA,DFN,LSTDFN) ;DATE OF DEATH
"RTN","DGRODEBR",84,0)
 ;Retrieve all DATE OF DEATH data elements, but instead of being filed,
"RTN","DGRODEBR",85,0)
 ;they will be placed into a mail message to the appropriate group.
"RTN","DGRODEBR",86,0)
 ;
"RTN","DGRODEBR",87,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",88,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",89,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",90,0)
 ;
"RTN","DGRODEBR",91,0)
 N DGMSG,FLD
"RTN","DGRODEBR",92,0)
 ;Only send messages if actual DOD is defined (field # .351) ;DG*5.3*572
"RTN","DGRODEBR",93,0)
 I $D(@DGDATA@(2,LSTDFN_",",.351)) D
"RTN","DGRODEBR",94,0)
 . D DODMAIL^DGROMAIL(DGDATA,DFN,LSTDFN)
"RTN","DGRODEBR",95,0)
 . S DGMSG(1)=" "
"RTN","DGRODEBR",96,0)
 . S DGMSG(2)="Date of Death information has been retrieved from the LST."
"RTN","DGRODEBR",97,0)
 . S DGMSG(3)="This information has NOT been filed into the patient's record."
"RTN","DGRODEBR",98,0)
 . S DGMSG(4)="A mail message has been sent to the Register Once mail group."
"RTN","DGRODEBR",99,0)
 . D EN^DDIOL(.DGMSG) R A:5
"RTN","DGRODEBR",100,0)
 ;Delete DoD fields from FDA array so they're not filed.
"RTN","DGRODEBR",101,0)
 F FLD=.351:.001:.355 K @DGDATA@(2,LSTDFN_",",FLD)   ;DG*5.3*572 - added .355
"RTN","DGRODEBR",102,0)
 Q
"RTN","DGRODEBR",103,0)
 ;
"RTN","DGRODEBR",104,0)
TA(DGDATA,LSTDFN) ;TEMPORARY ADDRESS
"RTN","DGRODEBR",105,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",106,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",107,0)
 N LSTTAED ;LST TEMPORARY ADDRESS END DATE (EXTERNAL)
"RTN","DGRODEBR",108,0)
 N LSTTAEDF ;LST TEMPORARY ADDRESS END DATE FILEMAN (DG*5.3*572)
"RTN","DGRODEBR",109,0)
 S LSTTAED=$G(@DGDATA@(2,LSTDFN_",",.1218,"E"))
"RTN","DGRODEBR",110,0)
 ;*Convert External LST date to Fileman date (DG*5.3*572)
"RTN","DGRODEBR",111,0)
 S X=LSTTAED
"RTN","DGRODEBR",112,0)
 S %DT="RSN"
"RTN","DGRODEBR",113,0)
 D ^%DT
"RTN","DGRODEBR",114,0)
 S LSTTAEDF=Y
"RTN","DGRODEBR",115,0)
 ;If the TEMPORARY ADDRESS END DATE is less than the
"RTN","DGRODEBR",116,0)
 ;date of the query, delete the TA data elements
"RTN","DGRODEBR",117,0)
 I (LSTTAEDF>0),(LSTTAEDF<DT) D
"RTN","DGRODEBR",118,0)
 . N FIELD
"RTN","DGRODEBR",119,0)
 . F FIELD=.12105,.12111,.12112,.1211:.0001:.1219 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",120,0)
 K X,%DT,Y
"RTN","DGRODEBR",121,0)
 Q
"RTN","DGRODEBR",122,0)
 ;
"RTN","DGRODEBR",123,0)
SP(DGDATA,DFN,LSTDFN) ;SENSITIVE PATIENT
"RTN","DGRODEBR",124,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",125,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",126,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",127,0)
 ;
"RTN","DGRODEBR",128,0)
 N RSSP    ;R.S. SENSITIVE PATIENT
"RTN","DGRODEBR",129,0)
 N LSTSP   ;LST SENSITIVE PATIENT
"RTN","DGRODEBR",130,0)
 S RSSP=$$GET1^DIQ(38.1,DFN,2)
"RTN","DGRODEBR",131,0)
 S LSTSP=$G(@DGDATA@(38.1,LSTDFN_",",2,"E"))
"RTN","DGRODEBR",132,0)
 ;
"RTN","DGRODEBR",133,0)
 ;* Remove code deleting Primary Eligibility Code (DG*5.3*572)
"RTN","DGRODEBR",134,0)
 ;* In all cases, delete Patient Type
"RTN","DGRODEBR",135,0)
 K @DGDATA@(2,LSTDFN_",",391)
"RTN","DGRODEBR",136,0)
 ;
"RTN","DGRODEBR",137,0)
 ;If the SENSITIVE PATIENT flag is received from the HEC -- OR -- if the
"RTN","DGRODEBR",138,0)
 ;flag is NOT received from both the HEC and LST, retrieve and file all
"RTN","DGRODEBR",139,0)
 ;Sensitive data elements, but NOT the fields for the Security Log file.
"RTN","DGRODEBR",140,0)
 I '((RSSP'="SENSITIVE")&(LSTSP="SENSITIVE")) D  I 1
"RTN","DGRODEBR",141,0)
 . K @DGDATA@(38.1)
"RTN","DGRODEBR",142,0)
 E  D
"RTN","DGRODEBR",143,0)
 . ;Otherwise (flag not received from the HEC but is from the LST),
"RTN","DGRODEBR",144,0)
 . ;send a mail message to the ISO and the "Register Once" mail
"RTN","DGRODEBR",145,0)
 . ;group that this patient is listed as Sensitive
"RTN","DGRODEBR",146,0)
 . D SPMAIL^DGROMAIL(DFN)
"RTN","DGRODEBR",147,0)
 . N DGMSG
"RTN","DGRODEBR",148,0)
 . S DGMSG(1)=" "
"RTN","DGRODEBR",149,0)
 . S DGMSG(2)="Sensitive Patient information has been retrieved from the LST."
"RTN","DGRODEBR",150,0)
 . S DGMSG(3)="This information has been filed into the patient's record."
"RTN","DGRODEBR",151,0)
 . S DGMSG(4)="A mail message has been sent to the Register Once mail group"
"RTN","DGRODEBR",152,0)
 . S DGMSG(5)="and the ISO explaining that this information has been received."
"RTN","DGRODEBR",153,0)
 . D EN^DDIOL(.DGMSG) R A:5
"RTN","DGRODEBR",154,0)
 Q
"RTN","DGRODEBR",155,0)
 ;
"RTN","DGRODEBR",156,0)
SWA(DGDATA,DFN,LSTDFN) ;SOUTHWEST ASIA CONDITIONS
"RTN","DGRODEBR",157,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",158,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",159,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",160,0)
 N RSSWA    ;REQUESTING SITE SOUTHWEST ASIA CONDITIONS
"RTN","DGRODEBR",161,0)
 N LSTSWA   ;LAST SITE TREATED SOUTHWEST ASIA CONDITIONS
"RTN","DGRODEBR",162,0)
 S RSSWA=$$GET1^DIQ(2,DFN,.322013)
"RTN","DGRODEBR",163,0)
 S LSTSWA=$G(@DGDATA@(2,LSTDFN_",",.322013,"E"))
"RTN","DGRODEBR",164,0)
 ;If either of the SOUTHWEST ASIA CONDITIONS flags
"RTN","DGRODEBR",165,0)
 ;are "N"o, don't file the SOUTWEST ASIA CONDITION data element(s)
"RTN","DGRODEBR",166,0)
 I (RSSWA="NO")!(LSTSWA="NO") D
"RTN","DGRODEBR",167,0)
 . N FIELD
"RTN","DGRODEBR",168,0)
 . F FIELD=.322013,322014,322015 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",169,0)
 Q
"RTN","DGRODEBR",170,0)
 ;
"RTN","DGRODEBR",171,0)
RE ;RACE AND ETHNICITY
"RTN","DGRODEBR",172,0)
 ;If the RACE AND ETHNICITY data not already
"RTN","DGRODEBR",173,0)
 ;populated, file it (already the basic rule)
"RTN","DGRODEBR",174,0)
 Q
"RTN","DGRODEBR",175,0)
 ;
"RTN","DGRODEBR",176,0)
CA(DGDATA,LSTDFN) ;CONFIDENTIAL ADDRESS
"RTN","DGRODEBR",177,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",178,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",179,0)
 N LSTCAAF   ;LST CONFIDENTIAL ADDRESS ACTIVE FLAG
"RTN","DGRODEBR",180,0)
 N LSTCAED   ;LST CONFIDENTIAL ADDRESS END DATE
"RTN","DGRODEBR",181,0)
 N LSTCAEDF ;LST CONFIDENTIAL ADDRESS END DATE FILEMAN (DG*5.3*572)
"RTN","DGRODEBR",182,0)
 S LSTCAAF=$G(@DGDATA@(2,LSTDFN_",",.14105,"E"))
"RTN","DGRODEBR",183,0)
 S LSTCAED=$G(@DGDATA@(2,LSTDFN_",",.1418,"E"))
"RTN","DGRODEBR",184,0)
 ;*Convert LSTCAED to Fileman format date for compare (DG*5.3*572)
"RTN","DGRODEBR",185,0)
 S X=LSTCAED
"RTN","DGRODEBR",186,0)
 S %DT="SN"
"RTN","DGRODEBR",187,0)
 D ^%DT
"RTN","DGRODEBR",188,0)
 S LSTCAEDF=Y
"RTN","DGRODEBR",189,0)
 ;If the CONFIDENTIAL ADDRESS FLAG from the Last Site Treated is "N"o,
"RTN","DGRODEBR",190,0)
 ;  OR  if the C.A. END DATE from the LST is less than the Query date,
"RTN","DGRODEBR",191,0)
 ;delete the C.A. data elements
"RTN","DGRODEBR",192,0)
 I (LSTCAAF'="YES")!((LSTCAEDF>0)&(LSTCAEDF<DT)) D
"RTN","DGRODEBR",193,0)
 . N FIELD
"RTN","DGRODEBR",194,0)
 . F FIELD=.1315,.14105,.14111:.00001:.14116,.1411:.0001:.1418 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",195,0)
 . K @DGDATA@(2.141)
"RTN","DGRODEBR",196,0)
 ;Else the Confidential Address information will be filed
"RTN","DGRODEBR",197,0)
 ;and a User Interface message will be displayed.
"RTN","DGRODEBR",198,0)
 E  D
"RTN","DGRODEBR",199,0)
 . N DGMSG
"RTN","DGRODEBR",200,0)
 . N DATEFM ;*DATE converted to Fileman format (DG*5.3*572)
"RTN","DGRODEBR",201,0)
 . S DGMSG(1)=" "
"RTN","DGRODEBR",202,0)
 . S DGMSG(2)="Confidential Address information has been retrieved from the LST."
"RTN","DGRODEBR",203,0)
 . S DGMSG(3)="This information has been filed into the patient's record."
"RTN","DGRODEBR",204,0)
 . S DATE=$G(@DGDATA@(2,LSTDFN_",",.1417,"E"))
"RTN","DGRODEBR",205,0)
 . ;* Convert DATE to FM format (DG*5.3*572)
"RTN","DGRODEBR",206,0)
 . K X,%DT,Y
"RTN","DGRODEBR",207,0)
 . S X=DATE
"RTN","DGRODEBR",208,0)
 . S %DT="SN"
"RTN","DGRODEBR",209,0)
 . D ^%DT
"RTN","DGRODEBR",210,0)
 . S DATEFM=Y
"RTN","DGRODEBR",211,0)
 . I DATEFM>DT D
"RTN","DGRODEBR",212,0)
 . . S DGMSG(4)="   NOTE:  Confidential Address Start Date is in the future, "_DATE
"RTN","DGRODEBR",213,0)
 . . S DGMSG(5)=" "
"RTN","DGRODEBR",214,0)
 . D EN^DDIOL(.DGMSG) R A:5
"RTN","DGRODEBR",215,0)
 K X,%DT,Y
"RTN","DGRODEBR",216,0)
 Q
"RTN","DGRODEBR",217,0)
 ;
"RTN","DGRODEBR",218,0)
PA(DGDATA,LSTDFN) ;PERMANENT ADDRESS
"RTN","DGRODEBR",219,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",220,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",221,0)
 N LSTBAI   ;LST BAD ADDRESS INDICATOR
"RTN","DGRODEBR",222,0)
 S LSTBAI=$G(@DGDATA@(2,LSTDFN_",",.121,"E"))
"RTN","DGRODEBR",223,0)
 ;If the BAD ADDRESS INDICATOR from LST is NOT null,
"RTN","DGRODEBR",224,0)
 ;delete the PERMANENT ADDRESS data elements
"RTN","DGRODEBR",225,0)
 I LSTBAI'="" D
"RTN","DGRODEBR",226,0)
 . N FIELD
"RTN","DGRODEBR",227,0)
 . F FIELD=.1112,.111:.001:.119,.12,.121 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",228,0)
 Q
"RTN","DGRODEBR",229,0)
 ;
"RTN","DGRODEBR",230,0)
RDOC(DGDATA,DFN,LSTDFN) ;RECENT DATE(S) OF CARE
"RTN","DGRODEBR",231,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",232,0)
 ;      DFN - Pointer to the PATIENT (#2) file
"RTN","DGRODEBR",233,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",234,0)
 N LSTRCP     ;LST RECEIVED VA CARE PREVIOUSLY?
"RTN","DGRODEBR",235,0)
 N LSTLOC1    ;LST MOST RECENT LOCATION OF CARE
"RTN","DGRODEBR",236,0)
 S LSTRCP=$G(@DGDATA@(2,LSTDFN_",",1010.15,"E"))
"RTN","DGRODEBR",237,0)
 S LSTLOC1=$G(@DGDATA@(2,LSTDFN_",",1010.152,"E"))
"RTN","DGRODEBR",238,0)
 ;
"RTN","DGRODEBR",239,0)
 ;If the RECEIVED VA CARE PREVIOUSLY? from LST is not YES,
"RTN","DGRODEBR",240,0)
 ;  OR  the MOST RECENT LOCATION OF CARE from LST is NULL,
"RTN","DGRODEBR",241,0)
 ;delete all the RDOC fields.
"RTN","DGRODEBR",242,0)
 I (LSTRCP'="YES")!(LSTLOC1="") D
"RTN","DGRODEBR",243,0)
 . N FIELD
"RTN","DGRODEBR",244,0)
 . F FIELD=1010.15,1010.151,1010.152,1010.153,1010.154 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",245,0)
 Q
"RTN","DGROHLR")
0^4^B17894920
"RTN","DGROHLR",1,0)
DGROHLR ;DJH/AMA - ROM HL7 RECEIVE DRIVERS ; 7/9/09 4:16pm
"RTN","DGROHLR",2,0)
 ;;5.3;Registration;**533,572,754**;Aug 13, 1993;Build 46
"RTN","DGROHLR",3,0)
 ;
"RTN","DGROHLR",4,0)
RCV ;Receive all message types and route to message specific receiver
"RTN","DGROHLR",5,0)
 ;
"RTN","DGROHLR",6,0)
 ;This procedure is the main driver entry point for receiving all
"RTN","DGROHLR",7,0)
 ;message types (ACK, QRY and ORF) for Register Once Messaging.
"RTN","DGROHLR",8,0)
 ;
"RTN","DGROHLR",9,0)
 ;All procedures and functions assume that all VistA HL7 environment
"RTN","DGROHLR",10,0)
 ;variables are properly initialized and will produce a fatal error if
"RTN","DGROHLR",11,0)
 ;they are missing.
"RTN","DGROHLR",12,0)
 ;
"RTN","DGROHLR",13,0)
 ;The received message is copied to a temporary work global for
"RTN","DGROHLR",14,0)
 ;processing.  The message type is determined from the MSH segment and
"RTN","DGROHLR",15,0)
 ;a receive processing procedure specific to the message type is called.
"RTN","DGROHLR",16,0)
 ;(Ex. ORF~R01 message calls procedure: RCVORF).  The specific receive
"RTN","DGROHLR",17,0)
 ;processing procedure calls a message specific parse procedure to
"RTN","DGROHLR",18,0)
 ;validate the message data and return data arrays for storage.  If no
"RTN","DGROHLR",19,0)
 ;parse errors are reported during validation, then the data arrays are
"RTN","DGROHLR",20,0)
 ;stored by the receive processing procedure.  Control, along with any
"RTN","DGROHLR",21,0)
 ;parse validation errors, is then passed to the message specific send
"RTN","DGROHLR",22,0)
 ;processing procedures to build and transmit the acknowledgment and
"RTN","DGROHLR",23,0)
 ;query results messages.
"RTN","DGROHLR",24,0)
 ;
"RTN","DGROHLR",25,0)
 ;  The message specific procedures are as follows:
"RTN","DGROHLR",26,0)
 ;
"RTN","DGROHLR",27,0)
 ;  Message   Receive Procedure   Parse Procedure    Send Procedure
"RTN","DGROHLR",28,0)
 ;  -------   -----------------   ----------------    --------------
"RTN","DGROHLR",29,0)
 ;                                                   SNDACK^DGROHLS
"RTN","DGROHLR",30,0)
 ;  ACK~R01   RCVACK^DGROHLR      PARSACK^DGROHLU4   N/A
"RTN","DGROHLR",31,0)
 ;  QRY~R02   RCVQRY^DGROHLR      PARSQRY^DGROHLQ3   SNDORF^DGROHLS
"RTN","DGROHLR",32,0)
 ;  ORF~R01   RCVORF^DGROHLR      PARSORF^DGROHLQ3   N/A
"RTN","DGROHLR",33,0)
 ;
"RTN","DGROHLR",34,0)
 N DGCNT,DGMSGTYP,DGSEG,DGSEGCNT,DGWRK
"RTN","DGROHLR",35,0)
 ;
"RTN","DGROHLR",36,0)
 S DGWRK=$NA(^TMP("DGROHL7",$J))
"RTN","DGROHLR",37,0)
 K @DGWRK
"RTN","DGROHLR",38,0)
 ;
"RTN","DGROHLR",39,0)
 ;load work global with segments
"RTN","DGROHLR",40,0)
 F DGSEGCNT=1:1 X HLNEXT Q:HLQUIT'>0  D
"RTN","DGROHLR",41,0)
 . S DGCNT=0
"RTN","DGROHLR",42,0)
 . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE
"RTN","DGROHLR",43,0)
 . F  S DGCNT=$O(HLNODE(DGCNT)) Q:'DGCNT  D
"RTN","DGROHLR",44,0)
 . . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT)
"RTN","DGROHLR",45,0)
 ;
"RTN","DGROHLR",46,0)
 ;get message type from "MSH"
"RTN","DGROHLR",47,0)
 I $$NXTSEG^DGROHLUT(DGWRK,0,HL("FS"),.DGSEG),$G(DGSEG("TYPE"))="MSH" D
"RTN","DGROHLR",48,0)
 . S DGMSGTYP=$P(DGSEG(9),$E(HL("ECH"),1),1)
"RTN","DGROHLR",49,0)
 . ;HLMTIENS is only required by RCVORU and RCVQRY, thus $GET
"RTN","DGROHLR",50,0)
 . I DGMSGTYP="" S (DGMSGTYP,HL("MTN"))="ORF",HLMTIENS=HLMTIEN
"RTN","DGROHLR",51,0)
 . I DGMSGTYP=HL("MTN") D @("RCV"_DGMSGTYP_"(DGWRK,$G(HLMTIENS),.HL)")
"RTN","DGROHLR",52,0)
 ;
"RTN","DGROHLR",53,0)
 ;cleanup
"RTN","DGROHLR",54,0)
 K @DGWRK
"RTN","DGROHLR",55,0)
 Q
"RTN","DGROHLR",56,0)
 ;
"RTN","DGROHLR",57,0)
RCVACK(DGWRK,DGMIEN,DGHL) ;Receive ACK Message Types (ACK~R01)
"RTN","DGROHLR",58,0)
 ;
"RTN","DGROHLR",59,0)
 ;  Input:
"RTN","DGROHLR",60,0)
 ;    DGWRK - name of work global containing segments
"RTN","DGROHLR",61,0)
 ;   DGMIEN - IEN of message entry in file #773
"RTN","DGROHLR",62,0)
 ;     DGHL - HL environment array
"RTN","DGROHLR",63,0)
 ;
"RTN","DGROHLR",64,0)
 ;  Output:
"RTN","DGROHLR",65,0)
 ;    none
"RTN","DGROHLR",66,0)
 ;
"RTN","DGROHLR",67,0)
 N DGACK   ;ACK data array
"RTN","DGROHLR",68,0)
 N DGERR   ;error array
"RTN","DGROHLR",69,0)
 N DGLIEN  ;HL7 transmission log IEN
"RTN","DGROHLR",70,0)
 N DGROL   ;HL7 transmssion log data array
"RTN","DGROHLR",71,0)
 ;
"RTN","DGROHLR",72,0)
 S ACKCODE=0
"RTN","DGROHLR",73,0)
 D PARSACK^DGROHLU4(DGWRK,.DGHL,.DGACK,.DGERR)
"RTN","DGROHLR",74,0)
 I $G(DGACK("ACKCODE"))'="AA" S ACKCODE=1
"RTN","DGROHLR",75,0)
 Q
"RTN","DGROHLR",76,0)
 ;
"RTN","DGROHLR",77,0)
RCVQRY(DGWRK,DGMIEN,DGHL) ;Receive QRY Message Types (QRY~R02)
"RTN","DGROHLR",78,0)
 ;
"RTN","DGROHLR",79,0)
 ;  Input:
"RTN","DGROHLR",80,0)
 ;    DGWRK - name of work global containing segments
"RTN","DGROHLR",81,0)
 ;   DGMIEN - IEN of message entry in file #773
"RTN","DGROHLR",82,0)
 ;     DGHL - HL environment array
"RTN","DGROHLR",83,0)
 ;
"RTN","DGROHLR",84,0)
 ;  Output:
"RTN","DGROHLR",85,0)
 ;    none
"RTN","DGROHLR",86,0)
 ;
"RTN","DGROHLR",87,0)
 N DGDFN,DGQRY,DGQRYERR,DGSEGERR
"RTN","DGROHLR",88,0)
 ;
"RTN","DGROHLR",89,0)
 D PARSQRY^DGROHLQ3(DGWRK,.DGHL,.DGQRY,.DGSEGERR)
"RTN","DGROHLR",90,0)
 S DGDFN=$$GETDFN^DGROUT2(DGQRY("ICN"),DGQRY("DOB"),DGQRY("SSN"))
"RTN","DGROHLR",91,0)
 I DGDFN'>0 D
"RTN","DGROHLR",92,0)
 . S DGQRYERR="NM"
"RTN","DGROHLR",93,0)
 . ;
"RTN","DGROHLR",94,0)
 . ;THE ICN FROM THE MPI DOES NOT MATCH A PATIENT, SO NOTIFY THE MPI
"RTN","DGROHLR",95,0)
 . D MPIMAIL^DGROMAIL(.DGQRY)
"RTN","DGROHLR",96,0)
 . ;
"RTN","DGROHLR",97,0)
 D SNDORF^DGROHLS(.DGQRY,DGMIEN,.DGHL,DGDFN,.DGSEGERR,.DGQRYERR)
"RTN","DGROHLR",98,0)
 Q
"RTN","DGROHLR",99,0)
 ;
"RTN","DGROHLR",100,0)
RCVORF(DGWRK,DGMIEN,DGHL) ;Receive ORF Message Types (ORF~R01)
"RTN","DGROHLR",101,0)
 ;
"RTN","DGROHLR",102,0)
 ;  Input:
"RTN","DGROHLR",103,0)
 ;    DGWRK - name of work global containing segments, ^TMP("DGROHL7",$J)
"RTN","DGROHLR",104,0)
 ;   DGMIEN - IEN of message entry in file #773
"RTN","DGROHLR",105,0)
 ;     DGHL - HL environment array
"RTN","DGROHLR",106,0)
 ;
"RTN","DGROHLR",107,0)
 ;  Output:
"RTN","DGROHLR",108,0)
 ;    none
"RTN","DGROHLR",109,0)
 ;
"RTN","DGROHLR",110,0)
 N DGDATA    ;patient data array to upload
"RTN","DGROHLR",111,0)
 N DGERR     ;parse error array
"RTN","DGROHLR",112,0)
 N DGORF     ;ORF data array
"RTN","DGROHLR",113,0)
 ;
"RTN","DGROHLR",114,0)
 S DGDATA=$NA(^TMP("DGROFDA",$J)) K @DGDATA
"RTN","DGROHLR",115,0)
 D PARSORF^DGROHLQ3(DGWRK,.DGHL,.DGORF,.DGERR,.DGDATA)
"RTN","DGROHLR",116,0)
 ;
"RTN","DGROHLR",117,0)
 I $D(DGROVRCK) DO
"RTN","DGROHLR",118,0)
 . S:('$D(DGORF("PATCH"))) DGROVRCK=0
"RTN","DGROHLR",119,0)
 . I ($D(DGORF("PATCH"))),(+DGORF("PATCH")'=572) S DGROVRCK=0
"RTN","DGROHLR",120,0)
 ;
"RTN","DGROHLR",121,0)
 ;* QUIT conditions
"RTN","DGROHLR",122,0)
 Q:'$D(DGORF)
"RTN","DGROHLR",123,0)
 Q:(+$G(DGORF("DFN"))'>0)
"RTN","DGROHLR",124,0)
 Q:'$D(^DPT(DGORF("DFN"),0))
"RTN","DGROHLR",125,0)
 Q:('$D(DGORF("PATCH")))
"RTN","DGROHLR",126,0)
 ;Q:(+DGORF("PATCH")'=572)
"RTN","DGROHLR",127,0)
 ;
"RTN","DGROHLR",128,0)
 S DFN=DGORF("DFN")
"RTN","DGROHLR",129,0)
 ;
"RTN","DGROHLR",130,0)
 ;Get DFN at Last Site Treated
"RTN","DGROHLR",131,0)
 S LSTDFN=+$O(@DGDATA@(2,""))
"RTN","DGROHLR",132,0)
 ;CHECK BUSINESS RULES
"RTN","DGROHLR",133,0)
 D AO^DGRODEBR(DGDATA,DFN,LSTDFN)    ;AGENT ORANGE EXPOSURE
"RTN","DGROHLR",134,0)
 D IR^DGRODEBR(DGDATA,DFN,LSTDFN)    ;RADIATION EXPOSURE
"RTN","DGROHLR",135,0)
 D DOD^DGRODEBR(DGDATA,DFN,LSTDFN)   ;DATE OF DEATH
"RTN","DGROHLR",136,0)
 D TA^DGRODEBR(DGDATA,LSTDFN)        ;TEMPORARY ADDRESS
"RTN","DGROHLR",137,0)
 D SP^DGRODEBR(DGDATA,DFN,LSTDFN)    ;SENSITIVE PATIENT
"RTN","DGROHLR",138,0)
 D CA^DGRODEBR(DGDATA,LSTDFN)        ;CONFIDENTIAL ADDRESS
"RTN","DGROHLR",139,0)
 D SWA^DGRODEBR(DGDATA,DFN,LSTDFN)   ;SOUTHWEST ASIA CONDITIONS
"RTN","DGROHLR",140,0)
 D INC^DGRODEBR(DGDATA,DFN,LSTDFN)   ;RULED INCOMPETENT
"RTN","DGROHLR",141,0)
 D INE^DGRODEBR(DGDATA,DFN,LSTDFN)   ;INELIGIBLE
"RTN","DGROHLR",142,0)
 D RDOC^DGRODEBR(DGDATA,DFN,LSTDFN)  ;RECENT DATE(S) OF CARE
"RTN","DGROHLR",143,0)
 ;
"RTN","DGROHLR",144,0)
 ;File the data
"RTN","DGROHLR",145,0)
 D CONVFDA^DGROHLR1(DFN,DGDATA)
"RTN","DGROHLR",146,0)
 ;CLEAN UP
"RTN","DGROHLR",147,0)
 K @DGDATA
"RTN","DGROHLR",148,0)
 Q
"RTN","DGROHLR1")
0^5^B36915578
"RTN","DGROHLR1",1,0)
DGROHLR1 ;GTS/PHH,TDM - ROM HL7 RECEIVE DRIVERS ; 9/29/09 2:08pm
"RTN","DGROHLR1",2,0)
 ;;5.3;Registration;**572,622,647,809,754**;Aug 13, 1993;Build 46
"RTN","DGROHLR1",3,0)
 ;
"RTN","DGROHLR1",4,0)
CONVFDA(DFN,DGDATA) ; LOOP THROUGH DATA TO FILE
"RTN","DGROHLR1",5,0)
 N DFNC,F,IEN,FIELD,DGROAR,FNUM,QVAR,INX,DGRONUPD
"RTN","DGROHLR1",6,0)
 ;
"RTN","DGROHLR1",7,0)
 ;*DGROAR: Indirect reference to DGROAYi where "i" is the ORDER INDEX
"RTN","DGROHLR1",8,0)
 ;* field value in 391.23.  ORDER INDEX defines order for a group of
"RTN","DGROHLR1",9,0)
 ;* fields loaded into the LST.
"RTN","DGROHLR1",10,0)
 ;* DGROAYi defined for each group maintaining proper order.
"RTN","DGROHLR1",11,0)
 ;*  DG*5.3*572
"RTN","DGROHLR1",12,0)
 ;* DGRONUPD flag used to suppress updating the 'CHANGE DT/TM' &
"RTN","DGROHLR1",13,0)
 ;*          'CHANGE SITE' fields for CONF & TEMP address data.
"RTN","DGROHLR1",14,0)
 ;
"RTN","DGROHLR1",15,0)
 S DFNC=DFN_","
"RTN","DGROHLR1",16,0)
 S INX=""
"RTN","DGROHLR1",17,0)
 S DGRONUPD=1
"RTN","DGROHLR1",18,0)
 F  S INX=$O(^DGRO(391.23,"D",INX)) Q:INX=""  D
"RTN","DGROHLR1",19,0)
 . S DGROAR="DGROAY"_INX
"RTN","DGROHLR1",20,0)
 . S QVAR=0
"RTN","DGROHLR1",21,0)
 . S F=""
"RTN","DGROHLR1",22,0)
 . F  S F=$O(@DGDATA@(F)) Q:F=""  D
"RTN","DGROHLR1",23,0)
 . . S IEN=""
"RTN","DGROHLR1",24,0)
 . . F  S IEN=$O(@DGDATA@(F,IEN)) Q:IEN=""  D
"RTN","DGROHLR1",25,0)
 . . . S FIELD=""
"RTN","DGROHLR1",26,0)
 . . . F  S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:FIELD=""  D
"RTN","DGROHLR1",27,0)
 . . . . Q:$$DIS(F,FIELD)
"RTN","DGROHLR1",28,0)
 . . . . S ORDINX=$O(^DGRO(391.23,"E",F,FIELD,""))
"RTN","DGROHLR1",29,0)
 . . . . D:(ORDINX=INX) SETARY
"RTN","DGROHLR1",30,0)
 . . . . ;* Following line files Internal PEC, Rmv once Ext PEC is filed
"RTN","DGROHLR1",31,0)
 . . . . I (ORDINX=INX)&(F=2) DO
"RTN","DGROHLR1",32,0)
 . . . . .D:(FIELD=.1417) FILECSTD
"RTN","DGROHLR1",33,0)
 . . . . .D:(FIELD=.361) FILEPEC
"RTN","DGROHLR1",34,0)
 . . . . .D:((FIELD=.117)!(FIELD=.12111)!(FIELD=.14111)) FILECNTY
"RTN","DGROHLR1",35,0)
 . . I (+$O(@DGROAR@(""))>0) S QVAR=1 D FILE
"RTN","DGROHLR1",36,0)
 Q
"RTN","DGROHLR1",37,0)
 ;
"RTN","DGROHLR1",38,0)
FILECSTD ;File CONFIDENTIAL START DATE bypassing FM restrictions
"RTN","DGROHLR1",39,0)
 ;Called from CONVFDA^DGROHLR1
"RTN","DGROHLR1",40,0)
 I $D(@DGROAR@(F,DFNC,FIELD)) D
"RTN","DGROHLR1",41,0)
 . S X=@DGROAR@(F,DFNC,FIELD)
"RTN","DGROHLR1",42,0)
 . S %DT="X" D ^%DT I Y D
"RTN","DGROHLR1",43,0)
 . . S DGROCST(F,DFNC,FIELD)=Y
"RTN","DGROHLR1",44,0)
 . . D FILE^DIE("U","DGROCST","ERR")
"RTN","DGROHLR1",45,0)
 . K @DGROAR@(F,DFNC,FIELD)
"RTN","DGROHLR1",46,0)
 . K DGROCST,X,%DT,Y
"RTN","DGROHLR1",47,0)
 Q
"RTN","DGROHLR1",48,0)
 ;
"RTN","DGROHLR1",49,0)
FILECNTY ;*Retrieve county IEN and file county
"RTN","DGROHLR1",50,0)
 ;*Retrieve State IEN corresponding to Temp, Conf, or Perm State
"RTN","DGROHLR1",51,0)
 I (FIELD=.117),($D(^DPT(DFN,.11))) S STATEIEN=$P(^DPT(DFN,.11),"^",5)
"RTN","DGROHLR1",52,0)
 I (FIELD=.12111),($D(^DPT(DFN,.121))) S STATEIEN=$P(^DPT(DFN,.121),"^",5)
"RTN","DGROHLR1",53,0)
 I (FIELD=.14111),($D(^DPT(DFN,.141))) S STATEIEN=$P(^DPT(DFN,.141),"^",5)
"RTN","DGROHLR1",54,0)
 ;
"RTN","DGROHLR1",55,0)
 ;*Retrieve County IEN for exact county returned from LST
"RTN","DGROHLR1",56,0)
 ; DG*647
"RTN","DGROHLR1",57,0)
 I $G(STATEIEN)="" G NOCNTY
"RTN","DGROHLR1",58,0)
 I '$D(@DGROAR@(F,DFNC,FIELD)) G NOCNTY
"RTN","DGROHLR1",59,0)
 S DIC="^DIC(5,"_STATEIEN_",1,"
"RTN","DGROHLR1",60,0)
 S DIC(0)="XS"
"RTN","DGROHLR1",61,0)
 S X=@DGROAR@(F,DFNC,FIELD)
"RTN","DGROHLR1",62,0)
 D ^DIC
"RTN","DGROHLR1",63,0)
 S DGROCTY(F,DFNC,FIELD)=+Y
"RTN","DGROHLR1",64,0)
 D FILE^DIE("","DGROCTY","ERR") ;File County IEN
"RTN","DGROHLR1",65,0)
NOCNTY K @DGROAR@(F,DFNC,FIELD)
"RTN","DGROHLR1",66,0)
 K STATEIEN,DGROCTY
"RTN","DGROHLR1",67,0)
 Q
"RTN","DGROHLR1",68,0)
 ;
"RTN","DGROHLR1",69,0)
FILEPEC ;File Internal value of Prim Elig Code
"RTN","DGROHLR1",70,0)
 ;Called from CONVFDA^DGROHLR1
"RTN","DGROHLR1",71,0)
 ;Remove this call when fields required by PEC are received
"RTN","DGROHLR1",72,0)
 ; from LST
"RTN","DGROHLR1",73,0)
 I $D(@DGROAR@(F,DFNC,FIELD)) DO
"RTN","DGROHLR1",74,0)
 . S DIC="^DIC(8,"
"RTN","DGROHLR1",75,0)
 . S DIC(0)="MNSX"
"RTN","DGROHLR1",76,0)
 . S X=@DGROAR@(F,DFNC,FIELD)
"RTN","DGROHLR1",77,0)
 . D ^DIC
"RTN","DGROHLR1",78,0)
 . S DGROPEC(F,DFNC,FIELD)=+Y
"RTN","DGROHLR1",79,0)
 . D FILE^DIE("","DGROPEC","ERR")
"RTN","DGROHLR1",80,0)
 . K @DGROAR@(F,DFNC,FIELD)
"RTN","DGROHLR1",81,0)
 . K DGROPEC,DIC,X
"RTN","DGROHLR1",82,0)
 Q
"RTN","DGROHLR1",83,0)
 ;
"RTN","DGROHLR1",84,0)
FILE ;*Execute FILE or UPDATE per FNUM (1st subscpt) for file # according
"RTN","DGROHLR1",85,0)
 ;* to file/multiple record add or adding existing Patient data add
"RTN","DGROHLR1",86,0)
 S FNUM=$O(@DGROAR@(""))
"RTN","DGROHLR1",87,0)
 K %DT ;* Clean up leaks from Input transforms that set %DT(0)
"RTN","DGROHLR1",88,0)
 ;
"RTN","DGROHLR1",89,0)
 ;* Patient file processing
"RTN","DGROHLR1",90,0)
 I +FNUM=2 DO
"RTN","DGROHLR1",91,0)
 . D FILE^DIE("E","@DGROAR","ERR") ;*Add to existing Patient entry
"RTN","DGROHLR1",92,0)
 ;
"RTN","DGROHLR1",93,0)
 ;* Patient file multiples processing
"RTN","DGROHLR1",94,0)
 I (+FNUM=2.01)!(+FNUM=2.141)!(+FNUM=2.11) DO
"RTN","DGROHLR1",95,0)
 . D UPDATE^DIE("E","@DGROAR","","ERR")
"RTN","DGROHLR1",96,0)
 I (+FNUM=2.02)!(+FNUM=2.06) DO
"RTN","DGROHLR1",97,0)
 . N DGRODNUM,DGIEN,DNUMDATA,DGIEN2,DGROIEN
"RTN","DGROHLR1",98,0)
 . S DGRODNUM=0
"RTN","DGROHLR1",99,0)
 . F  S DGRODNUM=$O(@DGROAR@(+FNUM,DGRODNUM)) Q:DGRODNUM=""  D
"RTN","DGROHLR1",100,0)
 . . S DGIEN=$P(DGRODNUM,",")
"RTN","DGROHLR1",101,0)
 . . I DGIEN S DGIEN2=$P(DGIEN,"+",2)
"RTN","DGROHLR1",102,0)
 . . S DNUMDATA=$G(@DGROAR@(+FNUM,DGRODNUM,.01))
"RTN","DGROHLR1",103,0)
 . . I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA D
"RTN","DGROHLR1",104,0)
 . . . D UPDATE^DIE("","@DGROAR","DGROIEN","ERR") ;*Converted Ext to Int
"RTN","DGROHLR1",105,0)
 ;
"RTN","DGROHLR1",106,0)
 ;* Processing fields [indicated in 391.23] not part of Patient file.
"RTN","DGROHLR1",107,0)
 ;* Define IF section for each file not a Patient file field or
"RTN","DGROHLR1",108,0)
 ;* Multiple.
"RTN","DGROHLR1",109,0)
 I (+$P(FNUM,".")'=2) DO
"RTN","DGROHLR1",110,0)
 . I +FNUM=38.1 DO
"RTN","DGROHLR1",111,0)
 . . N DGROARBI
"RTN","DGROHLR1",112,0)
 . . S DGROARBI(1)=DFN ;*Set 38.1 IEN to DFN
"RTN","DGROHLR1",113,0)
 . . D UPDATE^DIE("E","@DGROAR","DGROARBI","ERR")
"RTN","DGROHLR1",114,0)
 ;
"RTN","DGROHLR1",115,0)
 K @DGROAR
"RTN","DGROHLR1",116,0)
 Q
"RTN","DGROHLR1",117,0)
 ;
"RTN","DGROHLR1",118,0)
SETARY ;* Setup arrays of data to be filed
"RTN","DGROHLR1",119,0)
 N U,D,DATA,NODE,NODE2,INENNUM
"RTN","DGROHLR1",120,0)
 ;
"RTN","DGROHLR1",121,0)
 I '$D(^DGRO(391.23,"C",F,FIELD)) Q
"RTN","DGROHLR1",122,0)
 ;
"RTN","DGROHLR1",123,0)
 S U="^"
"RTN","DGROHLR1",124,0)
 ;
"RTN","DGROHLR1",125,0)
 ;CHECK LOCAL PATIENT FILE FOR EXISTING DATA, DO NOT OVERWRITE
"RTN","DGROHLR1",126,0)
 S D=$$GET1^DIQ(F,DFNC,FIELD)
"RTN","DGROHLR1",127,0)
 I D'="" K @DGDATA@(F,IEN,FIELD) Q
"RTN","DGROHLR1",128,0)
 ;
"RTN","DGROHLR1",129,0)
 S DATA=$G(@DGDATA@(F,IEN,FIELD,"E"))
"RTN","DGROHLR1",130,0)
 Q:DATA=""
"RTN","DGROHLR1",131,0)
 ;
"RTN","DGROHLR1",132,0)
 ;* Design of this Subroutine:
"RTN","DGROHLR1",133,0)
 ;* Set array defining groups of date for Fileman filing in
"RTN","DGROHLR1",134,0)
 ;*  a predefined order.
"RTN","DGROHLR1",135,0)
 ;* Indirection defined various array names for different ordered
"RTN","DGROHLR1",136,0)
 ;*  data groups in CONVFDA.
"RTN","DGROHLR1",137,0)
 ;* File Ext. values returned from LST per ORDER INDEX.
"RTN","DGROHLR1",138,0)
 ;* DG*5.3*572
"RTN","DGROHLR1",139,0)
 ;
"RTN","DGROHLR1",140,0)
 ;* Get field entry IEN in ROM 391.23 file
"RTN","DGROHLR1",141,0)
 S INENNUM=INX
"RTN","DGROHLR1",142,0)
 ;
"RTN","DGROHLR1",143,0)
 I F=2 DO  Q
"RTN","DGROHLR1",144,0)
 . S @DGROAR@(F,DFNC,FIELD)=DATA ;*Indirection to Patient Array
"RTN","DGROHLR1",145,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",146,0)
 ;
"RTN","DGROHLR1",147,0)
 ;* Set array for all other files (not Patient or Security files)
"RTN","DGROHLR1",148,0)
 ;* This section is for new entries in files.  Not for Multiples.
"RTN","DGROHLR1",149,0)
 ;*  Code to process specific files needed in CONVFDA
"RTN","DGROHLR1",150,0)
 I (+$P(F,".")'=2),(F'=38.1) DO  Q
"RTN","DGROHLR1",151,0)
 . S @DGROAR@(F,"+1,",FIELD)=DATA
"RTN","DGROHLR1",152,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",153,0)
 ;
"RTN","DGROHLR1",154,0)
 ;SET ALIAS AND CONFIDENTIAL ADDRESS CAT. SUBFILE ARRAYS
"RTN","DGROHLR1",155,0)
 I (F=2.01)!(F=2.141)!(F=2.11) D  Q
"RTN","DGROHLR1",156,0)
 . S NODE2="+"
"RTN","DGROHLR1",157,0)
 . S NODE2=NODE2_$P(IEN,",")_","_DFNC
"RTN","DGROHLR1",158,0)
 . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
"RTN","DGROHLR1",159,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",160,0)
 ;
"RTN","DGROHLR1",161,0)
 ;SET RACE AND ETHNICITY ARRAYS
"RTN","DGROHLR1",162,0)
 I (F=2.02)!(F=2.06) D  Q
"RTN","DGROHLR1",163,0)
 . N REFILE,REIEN,DATA30,QFL,DATACOMP,TEST,ERR,INACTIVE
"RTN","DGROHLR1",164,0)
 . I (F=2.02),(FIELD=.01) S REFILE=10
"RTN","DGROHLR1",165,0)
 . I (F=2.06),(FIELD=.01) S REFILE=10.2
"RTN","DGROHLR1",166,0)
 . I FIELD=.02 S REFILE=10.3
"RTN","DGROHLR1",167,0)
 . S DATA30=$E(DATA,1,30) D
"RTN","DGROHLR1",168,0)
 . . S QFL=0,REIEN="",NODE=""
"RTN","DGROHLR1",169,0)
 . . D FIND^DIC(REFILE,"","@;.01;200","",DATA30,,"B","","","TEST","ERR")
"RTN","DGROHLR1",170,0)
 . . F  S NODE=$O(TEST("DILIST",2,NODE)) Q:'NODE  D  Q:$G(QFL)=1
"RTN","DGROHLR1",171,0)
 . . . S REIEN=$G(TEST("DILIST",2,NODE))
"RTN","DGROHLR1",172,0)
 . . . S INACTIVE=$G(TEST("DILIST","ID",NODE,200))
"RTN","DGROHLR1",173,0)
 . . . Q:INACTIVE="YES"  ;* QUIT if Race or Eth Inact
"RTN","DGROHLR1",174,0)
 . . . S DATACOMP=$G(TEST("DILIST","ID",NODE,.01))
"RTN","DGROHLR1",175,0)
 . . . I DATACOMP=DATA S QFL=1
"RTN","DGROHLR1",176,0)
 . Q:'QFL
"RTN","DGROHLR1",177,0)
 . Q:$G(INACTIVE)="YES"  ;* No entry for Inactive Race/Ethncty
"RTN","DGROHLR1",178,0)
 . S DATA=REIEN ;*Race/Ethncty/MOC (10/10.2/10.3) IEN for data recvd
"RTN","DGROHLR1",179,0)
 . ;
"RTN","DGROHLR1",180,0)
 . S NODE2="+" ;*+ for all fields, All fields added in one UPDATE
"RTN","DGROHLR1",181,0)
 . S NODE2=NODE2_$P(IEN,",")_","_DFNC ;*No + for DFNC, DPT record exists
"RTN","DGROHLR1",182,0)
 . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
"RTN","DGROHLR1",183,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",184,0)
 ;
"RTN","DGROHLR1",185,0)
 ;* Set all sensitive fields (38.1) in array
"RTN","DGROHLR1",186,0)
 I F=38.1 D  Q
"RTN","DGROHLR1",187,0)
 . Q:('$D(@DGDATA@(F)))  ;*Data already filed
"RTN","DGROHLR1",188,0)
 . S FIELD=.01
"RTN","DGROHLR1",189,0)
 . S @DGROAR@(F,"+1,",FIELD)=$$GET1^DIQ(2,DFN,.01)
"RTN","DGROHLR1",190,0)
 . F  S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:'FIELD  D
"RTN","DGROHLR1",191,0)
 . . S @DGROAR@(F,"+1,",FIELD)=@DGDATA@(F,IEN,FIELD,"E")
"RTN","DGROHLR1",192,0)
 . K @DGDATA@(F,IEN)
"RTN","DGROHLR1",193,0)
 . S FIELD=999999 ;*Skip to end of 38.1 field list in @DGDATA
"RTN","DGROHLR1",194,0)
 Q
"RTN","DGROHLR1",195,0)
 ;
"RTN","DGROHLR1",196,0)
DIS(F,FIELD) ;Check for disabled
"RTN","DGROHLR1",197,0)
 N SUB S SUB=$O(^DGRO(391.23,"C",F,FIELD,0)) Q:'SUB 1
"RTN","DGROHLR1",198,0)
 I $P($G(^DGRO(391.23,SUB,0)),"^",5)=1 Q 1
"RTN","DGROHLR1",199,0)
 Q 0
"RTN","DGROHLU")
0^6^B26960116
"RTN","DGROHLU",1,0)
DGROHLU ;DJH/AMA,TDM - ROM HL7 BUILD ORF SEGMENT ; 11/6/09 3:43pm
"RTN","DGROHLU",2,0)
 ;;5.3;Registration;**533,572,754**;Aug 13, 1993;Build 46
"RTN","DGROHLU",3,0)
 ;
"RTN","DGROHLU",4,0)
 Q
"RTN","DGROHLU",5,0)
 ;
"RTN","DGROHLU",6,0)
DIQ(DGROFDA,FILE,DFN,DGQRY)   ;GATHER THE PATIENT DATA USING GETS^DIQ
"RTN","DGROHLU",7,0)
 ;Called from BLDORF^DGROHLQ
"RTN","DGROHLU",8,0)
 ;  INPUT:
"RTN","DGROHLU",9,0)
 ;    DGROFDA = ROOT FILE NAME OF TEMP GLOBAL ARRAY, ^TMP("DGROFDA",$J)
"RTN","DGROHLU",10,0)
 ;    FILE    = FILE FROM WHICH TO GATHER THE DATA
"RTN","DGROHLU",11,0)
 ;    DFN     = POINTER TO PATIENT (#2) FILE
"RTN","DGROHLU",12,0)
 ;    DGQRY   = ARRAY OF PARSED "QRY" DATA   ;DG*5.3*572
"RTN","DGROHLU",13,0)
 ;
"RTN","DGROHLU",14,0)
 ;  OUTPUT:
"RTN","DGROHLU",15,0)
 ;    GLOBAL ARRAY OF REQUESTED DATA ELEMENTS, IN DGROFDA
"RTN","DGROHLU",16,0)
 ;
"RTN","DGROHLU",17,0)
 ;THIS ROUTINE ALSO CHECKS THE DG REGISTER ONCE FIELD DEFINITION
"RTN","DGROHLU",18,0)
 ;(#391.23) FILE TO ENSURE EACH DATA ELEMENT IS REQUESTED.
"RTN","DGROHLU",19,0)
 ;
"RTN","DGROHLU",20,0)
 N U,FLAG,FIELD,TMPFLD,F,IEN,CNT,F1,F2,F3,F4,EIEN,STATEIEN,CNTYIEN,CNTY
"RTN","DGROHLU",21,0)
 N CAGET,CANOD,CAACT,CABDT,CAEDT
"RTN","DGROHLU",22,0)
 ;
"RTN","DGROHLU",23,0)
 ;BUILD THE INITIAL DATA ELEMENT GLOBAL ARRAY
"RTN","DGROHLU",24,0)
 ;* County name is sent instead of number (avoid duplicate on number)
"RTN","DGROHLU",25,0)
 ;*  Direct global reads of STATE file, COUNTY multiple supported with
"RTN","DGROHLU",26,0)
 ;*  IA #10056
"RTN","DGROHLU",27,0)
 ;
"RTN","DGROHLU",28,0)
 S U="^",FLAG="EN" ;*Get External value (DG*5.3*572)
"RTN","DGROHLU",29,0)
 S (STATEIEN,CNTYIEN)=""
"RTN","DGROHLU",30,0)
 S FILE=0
"RTN","DGROHLU",31,0)
 ;
"RTN","DGROHLU",32,0)
 ;Determine if Confidential Address info should be retreived.
"RTN","DGROHLU",33,0)
 S CAGET=0,CANOD=$G(^DPT(DFN,.141))
"RTN","DGROHLU",34,0)
 S CAACT=$P(CANOD,"^",9),CABDT=$P(CANOD,"^",7),CAEDT=$P(CANOD,"^",8)
"RTN","DGROHLU",35,0)
 I CAACT="Y",+CABDT>0,((CAEDT="")!((CAEDT+1)>DT)) S CAGET=1
"RTN","DGROHLU",36,0)
 ;
"RTN","DGROHLU",37,0)
 F  S FILE=$O(^DGRO(391.23,"C",FILE)) Q:'FILE  D
"RTN","DGROHLU",38,0)
 . I (FILE=2.01)!(FILE=2.02)!(FILE=2.06)!(FILE=2.141)!(FILE=2.11) Q
"RTN","DGROHLU",39,0)
 . S FIELD=0
"RTN","DGROHLU",40,0)
 . F  S FIELD=$O(^DGRO(391.23,"C",FILE,FIELD)) Q:'FIELD  D
"RTN","DGROHLU",41,0)
 . . Q:$$DIS^DGROHLR1(FILE,FIELD)
"RTN","DGROHLU",42,0)
 . . I 'CAGET,FILE=2,((FIELD=.1315)!(FIELD=.14105)!((FIELD>.1410)&(FIELD<.1419))!((FIELD>.14110)&(FIELD<.14117))) Q
"RTN","DGROHLU",43,0)
 . . S (CNTY,CNTYIEN,STATEIEN)=0
"RTN","DGROHLU",44,0)
 . . I FILE=2 DO
"RTN","DGROHLU",45,0)
 . . . I (FIELD=.117),($D(^DPT(DFN,.11))) DO
"RTN","DGROHLU",46,0)
 . . . . S STATEIEN=$P(^DPT(DFN,.11),"^",5)
"RTN","DGROHLU",47,0)
 . . . . S CNTYIEN=$P(^DPT(DFN,.11),"^",7)
"RTN","DGROHLU",48,0)
 . . . . S:((+STATEIEN>0)&(+CNTYIEN>0)) @DGROFDA@(FILE,DFN,FIELD,"E")=$P(^DIC(5,STATEIEN,1,CNTYIEN,0),"^",1)
"RTN","DGROHLU",49,0)
 . . . . S CNTY=1
"RTN","DGROHLU",50,0)
 . . . I (FIELD=.12111),($D(^DPT(DFN,.121))) DO
"RTN","DGROHLU",51,0)
 . . . . S STATEIEN=$P(^DPT(DFN,.121),"^",5)
"RTN","DGROHLU",52,0)
 . . . . S CNTYIEN=$P(^DPT(DFN,.121),"^",11)
"RTN","DGROHLU",53,0)
 . . . . S:((+STATEIEN>0)&(+CNTYIEN>0)) @DGROFDA@(FILE,DFN,FIELD,"E")=$P(^DIC(5,STATEIEN,1,CNTYIEN,0),"^",1)
"RTN","DGROHLU",54,0)
 . . . . S CNTY=1
"RTN","DGROHLU",55,0)
 . . . I (FIELD=.14111),($D(^DPT(DFN,.141))) DO
"RTN","DGROHLU",56,0)
 . . . . S STATEIEN=$P(^DPT(DFN,.141),"^",5)
"RTN","DGROHLU",57,0)
 . . . . S CNTYIEN=$P(^DPT(DFN,.141),"^",11)
"RTN","DGROHLU",58,0)
 . . . . S:((+STATEIEN>0)&(+CNTYIEN>0)) @DGROFDA@(FILE,DFN,FIELD,"E")=$P(^DIC(5,STATEIEN,1,CNTYIEN,0),"^",1)
"RTN","DGROHLU",59,0)
 . . . . S CNTY=1
"RTN","DGROHLU",60,0)
 . . ; Figure out how to skip the following line if CA is skipped
"RTN","DGROHLU",61,0)
 . . D:(CNTY=0) GETS^DIQ(FILE,DFN,FIELD,FLAG,DGROFDA)
"RTN","DGROHLU",62,0)
 ;
"RTN","DGROHLU",63,0)
 ;IF THERE'S NO DATE OF DEATH, KILL ALL OTHER DoD FIELDS
"RTN","DGROHLU",64,0)
 I '$D(@DGROFDA@(2,DFN_",",.351)) F FIELD=.351:.001:.355 K @DGROFDA@(2,DFN_",",FIELD)
"RTN","DGROHLU",65,0)
 ;
"RTN","DGROHLU",66,0)
 ;GET INTERNAL AND EXTERNAL VALUES - ALIAS, RACE, AND ETHNICITY SUB-FILES
"RTN","DGROHLU",67,0)
 F FILE=2.01,2.02,2.06,2.141,2.11 D
"RTN","DGROHLU",68,0)
 . N SBFL,SBDA,SBFLD
"RTN","DGROHLU",69,0)
 . S FLAG="IEN" ;*Get Internal and External; no Null values (DG*5.3*572)
"RTN","DGROHLU",70,0)
 . S SBFL=FILE-2 I FILE=2.141 S SBFL=.14
"RTN","DGROHLU",71,0)
 . I FILE=2.11 S SBFL=.37
"RTN","DGROHLU",72,0)
 . S SBDA=0 F  S SBDA=$O(^DPT(DFN,SBFL,SBDA)) Q:'SBDA  D
"RTN","DGROHLU",73,0)
 . . S SBFLD=0 F  S SBFLD=$O(^DGRO(391.23,"C",FILE,SBFLD)) Q:'SBFLD  D
"RTN","DGROHLU",74,0)
 . . . Q:$$DIS^DGROHLR1(FILE,SBFLD)
"RTN","DGROHLU",75,0)
 . . . D GETS^DIQ(FILE,SBDA_","_DFN,SBFLD,FLAG,DGROFDA)
"RTN","DGROHLU",76,0)
 ;ENSURE THE RACE DATA IS ACTIVE
"RTN","DGROHLU",77,0)
 S IEN="" F  S IEN=$O(@DGROFDA@(2.02,IEN)) Q:IEN=""  D
"RTN","DGROHLU",78,0)
 . N RIEN,MIEN
"RTN","DGROHLU",79,0)
 . S RIEN=$G(@DGROFDA@(2.02,IEN,.01,"I"))
"RTN","DGROHLU",80,0)
 . I $$GET1^DIQ(10,RIEN,200,"I") K @DGROFDA@(2.02,IEN) Q
"RTN","DGROHLU",81,0)
 . K @DGROFDA@(2.02,IEN,.01,"I")
"RTN","DGROHLU",82,0)
 . K @DGROFDA@(2.02,IEN,.02,"I")
"RTN","DGROHLU",83,0)
 ;ENSURE THE ETHNICITY DATA IS ACTIVE
"RTN","DGROHLU",84,0)
 S IEN="" F  S IEN=$O(@DGROFDA@(2.06,IEN)) Q:IEN=""  D
"RTN","DGROHLU",85,0)
 . N EIEN,MIEN
"RTN","DGROHLU",86,0)
 . S EIEN=$G(@DGROFDA@(2.06,IEN,.01,"I"))
"RTN","DGROHLU",87,0)
 . I $$GET1^DIQ(10.2,EIEN,200,"I") K @DGROFDA@(2.06,IEN) Q
"RTN","DGROHLU",88,0)
 . K @DGROFDA@(2.06,IEN,.01,"I")
"RTN","DGROHLU",89,0)
 . K @DGROFDA@(2.06,IEN,.02,"I")
"RTN","DGROHLU",90,0)
 ;
"RTN","DGROHLU",91,0)
 ;CHECK FOR SENSITIVE PATIENT; IF SO, THEN PUT THE QUERY SITE (QS)
"RTN","DGROHLU",92,0)
 ;USER IN THE NEW PERSON (#200) FILE, RECORD THE ACCESS IN THE
"RTN","DGROHLU",93,0)
 ;SECURITY LOG, AND SEND A MAIL BULLETIN TO THE ISO.    ;DG*5.3*572
"RTN","DGROHLU",94,0)
 I $D(@DGROFDA@(38.1)) D
"RTN","DGROHLU",95,0)
 . N DGREMS,DGREMN,DGUSER
"RTN","DGROHLU",96,0)
 . S DGREMS=$$IEN^XUAF4(DGQRY("SNDFAC"))   ;QS Institution File (#4) IEN
"RTN","DGROHLU",97,0)
 . S DGREMN=$P($$NS^XUAF4(DGREMS),U)       ;Get QS Station Name
"RTN","DGROHLU",98,0)
 . S DGUSER=$TR(DGQRY("USER"),"~",U)       ;Get QS user data
"RTN","DGROHLU",99,0)
 . ;
"RTN","DGROHLU",100,0)
 . ;Build input for New Person File
"RTN","DGROHLU",101,0)
 . ;(format: SSN^Name^Station Name^Station #^Remote DUZ^Phone)
"RTN","DGROHLU",102,0)
 . S DGUSER=$P(DGUSER,U,1,2)_U_DGREMN_U_DGQRY("SNDFAC")_U_$P(DGUSER,U,3,4)
"RTN","DGROHLU",103,0)
 . I '$$PUT^XUESSO1(DGUSER) K @DGROFDA Q
"RTN","DGROHLU",104,0)
 . ;
"RTN","DGROHLU",105,0)
 . S DUZ=$$FIND1^DIC(200,"","",$P(DGUSER,U),"SSN","")
"RTN","DGROHLU",106,0)
 . S EVENT="DGRO ROM QRY/R02 EVENT"
"RTN","DGROHLU",107,0)
 . D SETLOG1^DGSEC(DFN,DUZ,0,U_EVENT)   ;Create Security Log entry
"RTN","DGROHLU",108,0)
 . D BULTIN1^DGSEC(DFN,DUZ,U_EVENT)     ;Send ISO mail bulletin
"RTN","DGROHLU",109,0)
 Q
"RTN","DGROHLU",110,0)
 ;
"RTN","DGROHLU",111,0)
FDA(DGWRK,DGCURLIN,DGFS,DGCS,DGRS,DGDATA)   ;Download patient data from Last Site Treated
"RTN","DGROHLU",112,0)
 ;Called from PARSORF^DGROHLQ3
"RTN","DGROHLU",113,0)
 ;  Input:
"RTN","DGROHLU",114,0)
 ;    DGWRK - Root global with all of the patient data segments, ^TMP("DGROHL7",$J)
"RTN","DGROHLU",115,0)
 ;    DGCNT - Counter for the root global subscript
"RTN","DGROHLU",116,0)
 ;     DGFS - HL7 field separator
"RTN","DGROHLU",117,0)
 ;     DGCS - HL7 component separator
"RTN","DGROHLU",118,0)
 ;     DGRS - HL7 repetition separator
"RTN","DGROHLU",119,0)
 ;
"RTN","DGROHLU",120,0)
 ;  Output:
"RTN","DGROHLU",121,0)
 ;    DGDATA - Root global for the patient data to upload, ^TMP("DGROFDA",$J)
"RTN","DGROHLU",122,0)
 ;
"RTN","DGROHLU",123,0)
 N DGSUBS,DGVAL,DGFILE,DGIEN,DGFIELD,DGINT,DGRODA
"RTN","DGROHLU",124,0)
 ;
"RTN","DGROHLU",125,0)
 S DGCURLIN=DGCURLIN-1
"RTN","DGROHLU",126,0)
 F  S DGCURLIN=$O(@DGWRK@(DGCURLIN)) Q:'DGCURLIN  D
"RTN","DGROHLU",127,0)
 . N DGSEG
"RTN","DGROHLU",128,0)
 . S DGSEG=$P(@DGWRK@(DGCURLIN,0),DGFS,2)
"RTN","DGROHLU",129,0)
 . S DGSUBS=$P(DGSEG,DGRS),DGVAL=$P(DGSEG,DGRS,2)
"RTN","DGROHLU",130,0)
 . S DGFILE=$P(DGSUBS,DGCS),DGIEN=$P(DGSUBS,DGCS,2)
"RTN","DGROHLU",131,0)
 . S DGFIELD=$P(DGSUBS,DGCS,3),DGINT=$P(DGVAL,DGCS)
"RTN","DGROHLU",132,0)
 . ;
"RTN","DGROHLU",133,0)
 . I '$D(^DGRO(391.23,"C",DGFILE,DGFIELD)) Q
"RTN","DGROHLU",134,0)
 . N SUB S SUB=$O(^DGRO(391.23,"C",DGFILE,DGFIELD,0)) Q:'SUB
"RTN","DGROHLU",135,0)
 . I $P($G(^DGRO(391.23,SUB,0)),"^",5)=1 Q
"RTN","DGROHLU",136,0)
 . ;
"RTN","DGROHLU",137,0)
 . ;BUILD/STORE EXTERNAL VALUES INTO ;*DG*5.3*572
"RTN","DGROHLU",138,0)
 . ;  ^TMP("DGROFDA",$J,FILE,IEN,FIELD,"E")=VALUE
"RTN","DGROHLU",139,0)
 . S @DGDATA@(DGFILE,DGIEN,DGFIELD,"E")=DGINT
"RTN","DGROHLU",140,0)
 Q
"RTN","DGRPC")
0^7^B27065601
"RTN","DGRPC",1,0)
DGRPC ;ALB/MRL/PJR/PHH/EG/BAJ,TDM - CHECK CONSISTENCY OF PATIENT DATA ; 5/23/07 2:50pm
"RTN","DGRPC",2,0)
 ;;5.3;Registration;**108,121,314,301,470,489,505,451,568,585,641,653,688,754**;Aug 13, 1993;Build 46
"RTN","DGRPC",3,0)
 ;
"RTN","DGRPC",4,0)
 ;linetags in routines correspond to IEN of file 38.6
"RTN","DGRPC",5,0)
 ;
"RTN","DGRPC",6,0)
 ;variables:  DGVT = 1 if VETERAN? = YES, 0 if NO
"RTN","DGRPC",7,0)
 ;            DGSC = 1 if SC? = YES, 0 if NO
"RTN","DGRPC",8,0)
 ;            DGCD = 0 node of file EC file (#8)
"RTN","DGRPC",9,0)
 ;        DGRPCOLD = old inconsistencies for pt (separated by ,s)
"RTN","DGRPC",10,0)
 ;           DGCHK = #s to check (separated by ,s)
"RTN","DGRPC",11,0)
 ;           DGLST = next # to check
"RTN","DGRPC",12,0)
 ;            DGER = inconsistencies found (separated by ,s)
"RTN","DGRPC",13,0)
 ;           DGNCK = 1 if missing key elig data...can't process further
"RTN","DGRPC",14,0)
 ;
"RTN","DGRPC",15,0)
 N ANYMSE,CONARR,CONCHK,CONERR,CONSPEC,LOC,I5,I6
"RTN","DGRPC",16,0)
 N MSECHK,MSESET,MSERR,MSDATERR,RANGE,RANSET,OVER99
"RTN","DGRPC",17,0)
 D ON I $S(('$D(DFN)#2):1,'$D(^DPT(DFN,0)):1,DGER:1,1:0) G KVAR^DGRPCE:DGER
"RTN","DGRPC",18,0)
EN S:'$D(DGEDCN)#2 DGEDCN=0 I DGEDCN W !!,"Checking data for consistency..."
"RTN","DGRPC",19,0)
 D START:DGEDCN
"RTN","DGRPC",20,0)
 F I=0,.13,.141,.121,.122,.22,.24,.3,.31,.311,.32,.321,.322,.33,.35,.36,.362,.38,.39,.52,.53,"TYPE","VET" S DGP(I)=$G(^DPT(DFN,I))
"RTN","DGRPC",21,0)
 ;get old inconsistencies
"RTN","DGRPC",22,0)
 S DGRPCOLD="," I $D(^DGIN(38.5,DFN)) F I=0:0 S I=$O(^DGIN(38.5,DFN,"I",I)) Q:'I  S DGRPCOLD=DGRPCOLD_I_","
"RTN","DGRPC",23,0)
 ;find consistencies to check/not check
"RTN","DGRPC",24,0)
 ; DG*5.3*653 modified to exclude checks numbered>99  BAJ  10/25/2005
"RTN","DGRPC",25,0)
 S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I!(I=99)  I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,'$P(^(0),"^",5):1,1:0),I'=99 S DGCHK=DGCHK_I_","
"RTN","DGRPC",26,0)
 S OVER99=",301,303,304,306,307,308,402,403,406,407,501,502,503,504,505,506,507,516,517,"
"RTN","DGRPC",27,0)
 S DGVT=$S(DGP("VET")="Y":1,1:0),DGSC=$S($P(DGP(.3),"^",1)="Y":1,1:0),DGCD=$S($D(^DIC(8,+DGP(.36),0)):^(0),1:""),(DGCT,DGER,DGNCK)="" I 'DGVT,$D(^DG(391,+DGP("TYPE"),0)),$P(^(0),"^",2) S DGVT=2
"RTN","DGRPC",28,0)
 S DGLST=+$P(DGCHK,",",2) G @DGLST
"RTN","DGRPC",29,0)
1 S DGD=$P(DGP(0),"^",1) I DGD?1L.E!(DGD?.E1L.E)!(DGD="") S X=1 D COMB,NEXT I +DGLST'=2 G @DGLST
"RTN","DGRPC",30,0)
 S I1=0 F I=1:1:$L(DGD) Q:I1  S J=$E(DGD,I) I J?1NP,$A(J)>32,J'=",",J'="-",J'=".",J'="'" S I1=1
"RTN","DGRPC",31,0)
 I I1 S X=1 D COMB
"RTN","DGRPC",32,0)
 D NEXT I +DGLST'=2 G @DGLST
"RTN","DGRPC",33,0)
2 S I1=0 F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:'I!(I1)  I $P(^(I,0),"^",1)'?1A.E S I1=1
"RTN","DGRPC",34,0)
 I I1 S X=2 D COMB
"RTN","DGRPC",35,0)
 D NEXT I +DGLST>7!('DGLST) G @DGLST
"RTN","DGRPC",36,0)
3 ;
"RTN","DGRPC",37,0)
4 ;
"RTN","DGRPC",38,0)
5 ;
"RTN","DGRPC",39,0)
6 ;
"RTN","DGRPC",40,0)
7 F I=2,3,5,8,9 I $P(DGP(0),"^",I)="" S X=$S(I=2:3,I=3:4,I=5:5,I=8:6,1:7) D COMB:DGCHK[(","_X_",")
"RTN","DGRPC",41,0)
 S DGLST=7 G:DGCHK'[",7," FIND^DGRPC2 D NEXT I +DGLST'=8 G @DGLST
"RTN","DGRPC",42,0)
8 S I1=0,DGD=$G(^DPT(DFN,.11)) I '$P(DGD,"^",10) S I1=1,X=8 D COMB,NEXT G @DGLST
"RTN","DGRPC",43,0)
 I '$D(^HL(779.004,$P(DGD,"^",10))) S I1=1,X=8 D COMB,NEXT G @DGLST
"RTN","DGRPC",44,0)
 N STR8 S STR8="1,4,5,6,7" I $$FORIEN^DGADDUTL($P(DGD,"^",10)) S STR8="1,4"
"RTN","DGRPC",45,0)
 F T=1:1:$L(STR8,",") S I=$P(STR8,",",T) Q:I1  I $P(DGD,"^",I)="" S I1=1
"RTN","DGRPC",46,0)
 I I1 S X=8 D COMB
"RTN","DGRPC",47,0)
 D NEXT I +DGLST'=9 G @DGLST
"RTN","DGRPC",48,0)
9 I DGP("VET")="" S X=9,DGNCK=1 D COMB
"RTN","DGRPC",49,0)
 D NEXT I +DGLST'=10 G @DGLST
"RTN","DGRPC",50,0)
10 I $P(DGP(.3),"^",1)="" S X=10,DGNCK=1 D COMB
"RTN","DGRPC",51,0)
 D NEXT I +DGLST'=11 G @DGLST
"RTN","DGRPC",52,0)
11 I 'DGVT,DGSC S X=11 D COMB
"RTN","DGRPC",53,0)
 D NEXT I +DGLST'=12 G @DGLST
"RTN","DGRPC",54,0)
12 I DGSC,DGVT,$P(DGP(.3),"^",2)="" S X=12 D COMB
"RTN","DGRPC",55,0)
 D NEXT I +DGLST'=13 G @DGLST
"RTN","DGRPC",56,0)
13 I '$D(^DIC(21,+$P(DGP(.32),"^",3),0)) S X=13,DGNCK=1 D COMB
"RTN","DGRPC",57,0)
 D NEXT I +DGLST'=14 G @DGLST
"RTN","DGRPC",58,0)
14 I $P(DGCD,"^",1)="" S X=14,DGNCK=1 D COMB
"RTN","DGRPC",59,0)
 ;
"RTN","DGRPC",60,0)
 ;Check Patient Eligibilities multiple if Primary Elig Code defined
"RTN","DGRPC",61,0)
 I DGP(.36),'$D(^DPT(DFN,"E",+DGP(.36),0)) D PRI^VADPT60 ;5.3*301
"RTN","DGRPC",62,0)
 ;
"RTN","DGRPC",63,0)
 D NEXT I +DGLST'=15 G FIND^DGRPC2:+DGLST=35,@DGLST
"RTN","DGRPC",64,0)
15 I $P($G(^DPT(DFN,.15)),"^",2)]"",$P(DGP(.3),"^",7)="" S X=15 D COMB
"RTN","DGRPC",65,0)
 D NEXT I +DGLST'=16 G FIND^DGRPC2:+DGLST=35,@DGLST
"RTN","DGRPC",66,0)
16 D H^DGUTL I +DGP(.35)>DGTIME S X=16 D COMB
"RTN","DGRPC",67,0)
 D NEXT I +DGLST'=17 G FIND^DGRPC2:+DGLST=35,@DGLST
"RTN","DGRPC",68,0)
17 K DGDATE,DGTIME
"RTN","DGRPC",69,0)
 N SDARRAY,SDCLIEN,SDDATE
"RTN","DGRPC",70,0)
 S I1=0,DGD=DT
"RTN","DGRPC",71,0)
 S SDARRAY("FLDS")=3
"RTN","DGRPC",72,0)
 S SDARRAY(4)=DFN
"RTN","DGRPC",73,0)
 I +DGP(.35),$$SDAPI^SDAMA301(.SDARRAY) D
"RTN","DGRPC",74,0)
 .;if there is data hanging from the 101 subscript,
"RTN","DGRPC",75,0)
 .;then this is a valid appointment
"RTN","DGRPC",76,0)
 .;otherwise it is an error eg 01/21/2005
"RTN","DGRPC",77,0)
 .I $D(^TMP($J,"SDAMA301",101))=1 Q
"RTN","DGRPC",78,0)
 .S SDCLIEN=0
"RTN","DGRPC",79,0)
 .F  S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(I1)  D
"RTN","DGRPC",80,0)
 ..S SDDATE=0
"RTN","DGRPC",81,0)
 ..F  S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(I1)  D
"RTN","DGRPC",82,0)
 ...S X=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";")
"RTN","DGRPC",83,0)
 ...I X=""!(X="I") S I1=1
"RTN","DGRPC",84,0)
 K ^TMP($J,"SDAMA301")
"RTN","DGRPC",85,0)
 I I1 S X=17 D COMB
"RTN","DGRPC",86,0)
 ;
"RTN","DGRPC",87,0)
END ; end of routine...find next check to execute (or goto end)
"RTN","DGRPC",88,0)
 S:DGNCK DGLST=35 G:DGCHK'[",35,"&(DGNCK) FIND^DGRPC2 D NEXT G @DGLST
"RTN","DGRPC",89,0)
 ;
"RTN","DGRPC",90,0)
COMB ;record inconsistency
"RTN","DGRPC",91,0)
 S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
"RTN","DGRPC",92,0)
 Q
"RTN","DGRPC",93,0)
 ;
"RTN","DGRPC",94,0)
NEXT ; find the next consistency check to check (goto end if can't process further)
"RTN","DGRPC",95,0)
 S I=$F(DGCHK,(","_DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,DGLST<18 Q
"RTN","DGRPC",96,0)
 I +DGLST,DGNCK,+DGLST>17,+DGLST<36 S DGLST=35 Q:DGCHK'[",35,"  G NEXT
"RTN","DGRPC",97,0)
 S:'+DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC"_$S(+DGLST<43:1,+DGLST<79:2,1:3)
"RTN","DGRPC",98,0)
 Q
"RTN","DGRPC",99,0)
 ;
"RTN","DGRPC",100,0)
PAT ;check inconsistencies for a selected patient
"RTN","DGRPC",101,0)
 D ON G KVAR^DGRPCE:DGER W !! S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Check consistency for which PATIENT: " D ^DIC K DIC G KVAR^DGRPCE:Y'>0 S DFN=+Y,DGEDCN=1 D DGRPC G PAT
"RTN","DGRPC",102,0)
 ;
"RTN","DGRPC",103,0)
START ;record start time for checker
"RTN","DGRPC",104,0)
 S DGSTART=$H Q
"RTN","DGRPC",105,0)
 ;
"RTN","DGRPC",106,0)
TIME ;record end time for checker
"RTN","DGRPC",107,0)
 Q:'$D(DGSTART)#2  S DGEND=$H,X=$P(DGSTART,",",2),X1=$P(DGEND,",",2)
"RTN","DGRPC",108,0)
 I +DGSTART=+DGEND S DGTIME=X1-X
"RTN","DGRPC",109,0)
 E  S DGTIME=(5184000-X)+X1
"RTN","DGRPC",110,0)
 I $S(DGCT:0,DGCON=1:1,1:0) G TIMEQ
"RTN","DGRPC",111,0)
 W !!,"===> ",$S(DGCT:DGCT,DGCON<2:"No",1:"All")," inconsistenc",$S(DGCT=1:"y",1:"ies")," ",$S('DGCON:"found",DGCON=1:"filed",1:"removed")," in ",DGTIME," second",$S(DGTIME=1:"",1:"s"),"..." H 1
"RTN","DGRPC",112,0)
TIMEQ K DGSTART,DGEND,DGTIME,X,X1,DGCON Q
"RTN","DGRPC",113,0)
 ;
"RTN","DGRPC",114,0)
ON ;check if checker is on
"RTN","DGRPC",115,0)
 S DGER=0 I $S('$D(^DG(43,1,0)):1,'$P(^(0),"^",37):1,1:0) S DGER=1
"RTN","DGRPC",116,0)
 S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER TURNED OFF!!",$C(7) Q
"RTN","DGRPC3")
0^8^B27710641
"RTN","DGRPC3",1,0)
DGRPC3 ;ALB/PJR,LBD,BAJ,TDM - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 12/14/10 12:48pm
"RTN","DGRPC3",2,0)
 ;;5.3;Registration;**451,632,673,657,688,754**;Aug 13, 1993;Build 46
"RTN","DGRPC3",3,0)
 ;
"RTN","DGRPC3",4,0)
79 ;; MSE Dates overlap
"RTN","DGRPC3",5,0)
 ;; Don't check if MSE Dates Incomplete or if MSE TO precedes FROM
"RTN","DGRPC3",6,0)
 ;; or unless at least 2 ranges
"RTN","DGRPC3",7,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR!($L(ANYMSE)<2) D NEXT G @DGLST
"RTN","DGRPC3",8,0)
 I ANYMSE[1,'$$OVRLPCHK^DGRPDT(DFN,$P(DGP(.32),"^",6),$P(DGP(.32),"^",7),1,".326^.327") S X=79 D COMB S MSERR=1 D NEXT G @DGLST
"RTN","DGRPC3",9,0)
 I ANYMSE'[1,'$$OVRLPCHK^DGRPDT(DFN,$P(DGP(.32),"^",11),$P(DGP(.32),"^",12),1,".3292^.3293") S X=79 D COMB S MSERR=1 D NEXT G @DGLST
"RTN","DGRPC3",10,0)
 D NEXT G @DGLST
"RTN","DGRPC3",11,0)
80 ;; POW Dates not within MSE
"RTN","DGRPC3",12,0)
 ;; Check turned off by EVC project (DG*5.3*688)
"RTN","DGRPC3",13,0)
 D NEXT G @DGLST
"RTN","DGRPC3",14,0)
81 ;; Combat Dates not within MSE
"RTN","DGRPC3",15,0)
 I '$P(DGP(.52),"^",12) D NEXT G @DGLST ;; Don't check if no COMBAT Data
"RTN","DGRPC3",16,0)
 ;; Don't check if COMBAT Data Incomplete or if COMBAT TO precedes FROM
"RTN","DGRPC3",17,0)
 I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
"RTN","DGRPC3",18,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
"RTN","DGRPC3",19,0)
 ;; If COMBAT, but no MSE, then Range is NOT within MSE
"RTN","DGRPC3",20,0)
 I 'ANYMSE S X=81 D COMB D NEXT G @DGLST
"RTN","DGRPC3",21,0)
 I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=81 D COMB
"RTN","DGRPC3",22,0)
 D NEXT G @DGLST
"RTN","DGRPC3",23,0)
82 ;; Conflict Dates not within MSE
"RTN","DGRPC3",24,0)
 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
"RTN","DGRPC3",25,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
"RTN","DGRPC3",26,0)
 S LOC="",I2=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC=""  I CONARR(LOC)=1 D
"RTN","DGRPC3",27,0)
 .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
"RTN","DGRPC3",28,0)
 .S DATA=CONSPEC(LOC)
"RTN","DGRPC3",29,0)
 .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
"RTN","DGRPC3",30,0)
 .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
"RTN","DGRPC3",31,0)
 .I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB:'I2 S CONARR(LOC)=2,I2=1
"RTN","DGRPC3",32,0)
 .Q
"RTN","DGRPC3",33,0)
 ; Check OIF/OEF conflict dates
"RTN","DGRPC3",34,0)
 N DGOEIF D GET^DGENOEIF(DFN,.DGOEIF,0,"",0)
"RTN","DGRPC3",35,0)
 I $G(DGOEIF("COUNT")),DGER'[",82," D
"RTN","DGRPC3",36,0)
 . N Z
"RTN","DGRPC3",37,0)
 . S Z=0 F  S Z=$O(DGOEIF("IEN",Z)) Q:'Z  D  Q:DGER[",82,"
"RTN","DGRPC3",38,0)
 .. S FROMDAT=$G(DGOEIF("FR",Z)),TODAT=$G(DGOEIF("TO",Z)),LOC=$G(DGOEIF("LOC",Z))
"RTN","DGRPC3",39,0)
 .. I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB S I2=1
"RTN","DGRPC3",40,0)
 D NEXT G @DGLST
"RTN","DGRPC3",41,0)
83 ;Merchant Seaman or Filipino Vet BOS requires service dates during WWII
"RTN","DGRPC3",42,0)
 N BOS,BOSN,MS,MSE,OUT
"RTN","DGRPC3",43,0)
 F MS=1:1:3 D  Q:$G(OUT)
"RTN","DGRPC3",44,0)
 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
"RTN","DGRPC3",45,0)
 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
"RTN","DGRPC3",46,0)
 .S BOS=$P(DGP(.32),U,(5*MS)) Q:'BOS  S BOSN=$P($G(^DIC(23,BOS,0)),U)
"RTN","DGRPC3",47,0)
 .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
"RTN","DGRPC3",48,0)
 .I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
"RTN","DGRPC3",49,0)
 D NEXT G @DGLST
"RTN","DGRPC3",50,0)
84 ;Filipino Vet BOS requires Filipino Vet Proof
"RTN","DGRPC3",51,0)
 N MS,BOS,OUT
"RTN","DGRPC3",52,0)
 F MS=1:1:3 D  Q:$G(OUT)
"RTN","DGRPC3",53,0)
 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
"RTN","DGRPC3",54,0)
 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
"RTN","DGRPC3",55,0)
 .S BOS=$P(DGP(.32),U,(5*MS))
"RTN","DGRPC3",56,0)
 .I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
"RTN","DGRPC3",57,0)
 D NEXT G @DGLST
"RTN","DGRPC3",58,0)
85 ;Eligible Filipino Vet should have Veteran status = 'YES'
"RTN","DGRPC3",59,0)
86 ;Ineligible Filipino Vet should have Veteran status = 'NO'
"RTN","DGRPC3",60,0)
 N MS,BOS,FV,FILV,NOTFV,MSE,OUT
"RTN","DGRPC3",61,0)
 F MS=1:1:3 D  Q:$G(OUT)
"RTN","DGRPC3",62,0)
 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
"RTN","DGRPC3",63,0)
 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
"RTN","DGRPC3",64,0)
 .S BOS=$P(DGP(.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
"RTN","DGRPC3",65,0)
 .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
"RTN","DGRPC3",66,0)
 .I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
"RTN","DGRPC3",67,0)
 .I FV=2 S FILV("E")="" Q
"RTN","DGRPC3",68,0)
 .I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
"RTN","DGRPC3",69,0)
 .S FILV("E")=""
"RTN","DGRPC3",70,0)
 I $D(FILV) D
"RTN","DGRPC3",71,0)
 .I DGVT'=1,$D(FILV("E")) S X=85 D COMB Q
"RTN","DGRPC3",72,0)
 .I DGCHK'[(",86,") Q
"RTN","DGRPC3",73,0)
 .I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S X=86 D COMB
"RTN","DGRPC3",74,0)
 S DGLST=86
"RTN","DGRPC3",75,0)
 D NEXT G @DGLST
"RTN","DGRPC3",76,0)
87 ; DG*5.3*657 BAJ 11/24/2005 CC #87 added
"RTN","DGRPC3",77,0)
 ; SC Eligibility but no rated Disability Codes
"RTN","DGRPC3",78,0)
 ; 1. Svc Connected is answered "YES"
"RTN","DGRPC3",79,0)
 ; 2. Eligibility code is either SC < 50% or SC 50-100%
"RTN","DGRPC3",80,0)
 ; 3. Svc connected %-age is 0 or greater
"RTN","DGRPC3",81,0)
 ; 4. Patient has no rated disabilities
"RTN","DGRPC3",82,0)
 ; .. VAEL(1) $P 1 = Primary Eligibility Code  $p 2 = Primary Elig External Value
"RTN","DGRPC3",83,0)
 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
"RTN","DGRPC3",84,0)
 ; .. Rated Disabilities : ^DPT(DFN,.372,0) $P 4 is number of records  '($P($G(^DPT(DFN,.372,0)),"^",4)) is TRUE
"RTN","DGRPC3",85,0)
 ;
"RTN","DGRPC3",86,0)
 ; Get Eligibility info
"RTN","DGRPC3",87,0)
 D ELIG^VADPT
"RTN","DGRPC3",88,0)
 ;
"RTN","DGRPC3",89,0)
 ; If not svc connected, don't check
"RTN","DGRPC3",90,0)
 I '$G(VAEL(3)) D NEXT G @DGLST
"RTN","DGRPC3",91,0)
 ;
"RTN","DGRPC3",92,0)
 I +VAEL(3)=1!(+VAEL(3)=3) D
"RTN","DGRPC3",93,0)
 . Q:$P(VAEL(3),"^",2)<0
"RTN","DGRPC3",94,0)
 . Q:$P(VAEL(3),"^",2)=""
"RTN","DGRPC3",95,0)
 . I '($P($G(^DPT(DFN,.372,0)),"^",4)) S X=87 D COMB
"RTN","DGRPC3",96,0)
 D NEXT G @DGLST
"RTN","DGRPC3",97,0)
 ;
"RTN","DGRPC3",98,0)
88 ;Temporary Address check
"RTN","DGRPC3",99,0)
 N STR88,J,DGI,DGERR,START,END
"RTN","DGRPC3",100,0)
 S DGERR=0
"RTN","DGRPC3",101,0)
 I $P(DGP(.121),U,9)="Y" D
"RTN","DGRPC3",102,0)
 . ;check only if current date is within effective range
"RTN","DGRPC3",103,0)
 . S START=$P(DGP(.121),U,7),END=$P(DGP(.121),U,8)
"RTN","DGRPC3",104,0)
 . Q:START=""  I END="" S END=9999999
"RTN","DGRPC3",105,0)
 . ; quit if current date is not within range
"RTN","DGRPC3",106,0)
 . I '(DT'<START&(DT'>END)) Q
"RTN","DGRPC3",107,0)
 . ; country is either NULL or non-numeric
"RTN","DGRPC3",108,0)
 . I '$P(DGP(.122),U,3) S DGERR=1 Q
"RTN","DGRPC3",109,0)
 . ; country is not in Country file
"RTN","DGRPC3",110,0)
 . I '$D(^HL(779.004,$P(DGP(.122),U,3))) S DGERR=1 Q
"RTN","DGRPC3",111,0)
 . S STR88="1,4,5,6" I $$FORIEN^DGADDUTL($P(DGP(.122),"^",3)) S STR88="1,4"
"RTN","DGRPC3",112,0)
 . F J=1:1:$L(STR88,",") S DGI=$P(STR88,",",J) Q:DGERR  I $P(DGP(.121),U,DGI)="" S DGERR=1
"RTN","DGRPC3",113,0)
 I DGERR S X=88 D COMB
"RTN","DGRPC3",114,0)
 D NEXT G @DGLST
"RTN","DGRPC3",115,0)
99 ; synonymous with END
"RTN","DGRPC3",116,0)
END I DGNCK S X=99 D COMB
"RTN","DGRPC3",117,0)
 D OVER99CK
"RTN","DGRPC3",118,0)
 I DGEDCN S DGCON=0 D TIME^DGRPC
"RTN","DGRPC3",119,0)
 K C,C1,C2,DGCD,DGD,DGD1,DGD2,DGDATE,DGDEP,DGCHK,DGFL,DGINC,DGISYR,DGLST,DGMS,DGNCK,DGP,DGPTYP,DGREL,DGSCT,DGT,DGTIME,DGTOT,DGVT,I,I2,I2,J,VAIN,X,X1
"RTN","DGRPC3",120,0)
 G ^DGRPCF
"RTN","DGRPC3",121,0)
 ;
"RTN","DGRPC3",122,0)
COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
"RTN","DGRPC3",123,0)
 ;;
"RTN","DGRPC3",124,0)
NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) S:'DGLST DGLST="END"
"RTN","DGRPC3",125,0)
 Q
"RTN","DGRPC3",126,0)
 ;
"RTN","DGRPC3",127,0)
OVER99CK N DGP,DGSD,RULE,FILERR
"RTN","DGRPC3",128,0)
 D LOADPT^IVMZ07C(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD)
"RTN","DGRPC3",129,0)
 F RULE=301,303,304,306:1:308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
"RTN","DGRPC3",130,0)
 F RULE=402,403,406,407 S DGLST=RULE_"^IVMZ7CE" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
"RTN","DGRPC3",131,0)
 F RULE=501:1:507,516,517 S DGLST=RULE_"^IVMZ7CS" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
"RTN","DGRPC3",132,0)
 S DGLST="END"
"RTN","DGRPC3",133,0)
 Q
"RTN","DGRPCADD")
0^20^B13888843
"RTN","DGRPCADD",1,0)
DGRPCADD ;ALB/MRL,BAJ,TDM - REGISTRATION SCREEN 1.1/CONFIDENTIAL ADDRESS INFORMATION ; 9/29/09 1:16pm
"RTN","DGRPCADD",2,0)
 ;;5.3;Registration;**489,624,688,754**;Aug 13, 1993;Build 46
"RTN","DGRPCADD",3,0)
 ;;**688 BAJ Jan 17,2006 Modifications to support Foreign addresses
"RTN","DGRPCADD",4,0)
CADD ;Confidential Address
"RTN","DGRPCADD",5,0)
 N CNT,DGA1,DGA2,DGA3,DGA4,DGACT,DGBEG,DGCAN,DGCAT,DGCC,DGEND,DGTYP,DGTYPNAM,DGX,DGXX,DGZ,DGZIP,DGI,Y,Z,DGERR
"RTN","DGRPCADD",6,0)
 N DGA14,DGA15,DGA16,FORGN,DGCNTRY,DGA1315
"RTN","DGRPCADD",7,0)
 S DGRPS=1.1 D H^DGRPU
"RTN","DGRPCADD",8,0)
 S DGRP(.141)=$G(^DPT(DFN,.141))
"RTN","DGRPCADD",9,0)
 S Z=1,DGRPW=1.1 D WW^DGRPV W "Confidential Address"
"RTN","DGRPCADD",10,0)
 ; if no data or no Category, display "NO CONFIDENTIAL..."
"RTN","DGRPCADD",11,0)
 ;I DGRP(.141)=""!($P(DGRP(.141),U)="")!('$P($$CAACT(DFN),U)) D  G END
"RTN","DGRPCADD",12,0)
 I DGRP(.141)=""!('$P($$CAACT(DFN),U)) D  G END
"RTN","DGRPCADD",13,0)
 .W !?5,"NO CONFIDENTIAL ADDRESS"
"RTN","DGRPCADD",14,0)
 .W !!?42,"From/To:  NOT APPLICABLE"
"RTN","DGRPCADD",15,0)
 S DGXX=DGRP(.141),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4)
"RTN","DGRPCADD",16,0)
 S DGA14=$P(DGXX,"^",14),DGA15=$P(DGXX,"^",15)
"RTN","DGRPCADD",17,0)
 S DGA16=$P(DGXX,"^",16) S:'DGA16 DGA16=""
"RTN","DGRPCADD",18,0)
 S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA16),1,25),FORGN=$$FORIEN^DGADDUTL(DGA16)
"RTN","DGRPCADD",19,0)
 I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
"RTN","DGRPCADD",20,0)
 W:DGA1'="" !?3,DGA1
"RTN","DGRPCADD",21,0)
 I 'FORGN D
"RTN","DGRPCADD",22,0)
 . ;If we didn't skip a line for Address Line 1, skip line now
"RTN","DGRPCADD",23,0)
 . I DGA1="" W !
"RTN","DGRPCADD",24,0)
 . W ?43,"County: "
"RTN","DGRPCADD",25,0)
 . I $D(^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0)) D
"RTN","DGRPCADD",26,0)
 . . S DGCC=^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0) W $P(DGCC,"^",1),"(",$P(DGCC,"^",3),")"
"RTN","DGRPCADD",27,0)
 S DGA1315=$P($G(^DPT(DFN,.13)),U,15) S:DGA1315="" DGA1315="UNANSWERED"
"RTN","DGRPCADD",28,0)
 I DGA2'="" W !?3,DGA2,?44,"Phone: ",DGA1315
"RTN","DGRPCADD",29,0)
 I DGA3'="" W !?3,DGA3 I DGA2="" W ?44,"Phone: ",DGA1315
"RTN","DGRPCADD",30,0)
 I FORGN W !?3,DGA15_" "_DGA4_" "_DGA14
"RTN","DGRPCADD",31,0)
 I 'FORGN W !?3,DGA4 D
"RTN","DGRPCADD",32,0)
 . I $D(^DIC(5,+$P(DGRP(.141),"^",5),0)) W ",",$P(^DIC(5,+$P(DGRP(.141),"^",5),0),"^",2)
"RTN","DGRPCADD",33,0)
 . S DGZIP=$P(DGRP(.141),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
"RTN","DGRPCADD",34,0)
 . W " ",DGZIP
"RTN","DGRPCADD",35,0)
 I DGA2="",DGA3="" W ?44,"Phone: ",DGA1315
"RTN","DGRPCADD",36,0)
 W !?3,DGCNTRY
"RTN","DGRPCADD",37,0)
 W ?42,"From/To: " S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D
"RTN","DGRPCADD",38,0)
 .I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y
"RTN","DGRPCADD",39,0)
 .I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED")
"RTN","DGRPCADD",40,0)
 W DGX
"RTN","DGRPCADD",41,0)
 W !!,"Categories: " I $D(^DPT(DFN,.14)) D
"RTN","DGRPCADD",42,0)
 .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
"RTN","DGRPCADD",43,0)
 .S DGX="",DGCAN="" F  S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN=""  D
"RTN","DGRPCADD",44,0)
 ..Q:'$D(^DPT(DFN,.14,DGCAN,0))
"RTN","DGRPCADD",45,0)
 ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2)
"RTN","DGRPCADD",46,0)
 ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
"RTN","DGRPCADD",47,0)
 ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM=""  D
"RTN","DGRPCADD",48,0)
 ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
"RTN","DGRPCADD",49,0)
 S DGXX="",CNT=0 F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX=""  D
"RTN","DGRPCADD",50,0)
 .W:CNT>0 !
"RTN","DGRPCADD",51,0)
 .W ?13,DGXX
"RTN","DGRPCADD",52,0)
 .S CNT=CNT+1
"RTN","DGRPCADD",53,0)
 ; line feed before continuing
"RTN","DGRPCADD",54,0)
 W !
"RTN","DGRPCADD",55,0)
END ;
"RTN","DGRPCADD",56,0)
 S DGRP(.13)=$G(^DPT(DFN,.13))
"RTN","DGRPCADD",57,0)
 S Z=2,DGRPW=1.1 D WW^DGRPV W "    Cell Phone: "
"RTN","DGRPCADD",58,0)
 ;
"RTN","DGRPCADD",59,0)
 ;* Output Cell phone
"RTN","DGRPCADD",60,0)
 I $P(DGRP(.13),U,4)'="" W ?20,$P(DGRP(.13),U,4)
"RTN","DGRPCADD",61,0)
 I $P(DGRP(.13),U,4)="" W ?20,"UNANSWERED"
"RTN","DGRPCADD",62,0)
 ;
"RTN","DGRPCADD",63,0)
 ;* Output Pager
"RTN","DGRPCADD",64,0)
 W !,"          Pager #: "
"RTN","DGRPCADD",65,0)
 I $P(DGRP(.13),U,5)'="" W ?19,$P(DGRP(.13),U,5)
"RTN","DGRPCADD",66,0)
 I $P(DGRP(.13),U,5)="" W ?19,"UNANSWERED"
"RTN","DGRPCADD",67,0)
 ;
"RTN","DGRPCADD",68,0)
 ;* Output Email Address
"RTN","DGRPCADD",69,0)
 W !,"    Email Address: "
"RTN","DGRPCADD",70,0)
 I $P(DGRP(.13),U,3)'="" W ?19,$P(DGRP(.13),U,3)
"RTN","DGRPCADD",71,0)
 I $P(DGRP(.13),U,3)="" W ?19,"UNANSWERED"
"RTN","DGRPCADD",72,0)
 ;
"RTN","DGRPCADD",73,0)
 G ^DGRPP
"RTN","DGRPCADD",74,0)
CAACT(DFN,ACTDT) ;Determines if the Confidential Address is active
"RTN","DGRPCADD",75,0)
 ;Input:  DFN - Patient (#2) file internal entry number (Required)
"RTN","DGRPCADD",76,0)
 ;        ACTDT - Date used to determine if address is active 
"RTN","DGRPCADD",77,0)
 ;                (Optional) Defaults to DT if not defined. 
"RTN","DGRPCADD",78,0)
 ;
"RTN","DGRPCADD",79,0)
 ;Output:
"RTN","DGRPCADD",80,0)
 ;   1st piece 0 inactive based on start/stop dates
"RTN","DGRPCADD",81,0)
 ;             1 active based on start/stop dates
"RTN","DGRPCADD",82,0)
 ;   2nd piece 0 - no active correspondence types
"RTN","DGRPCADD",83,0)
 ;             1 - at least one active correspondence type
"RTN","DGRPCADD",84,0)
 ;
"RTN","DGRPCADD",85,0)
 N DGCA,DGCABEG,DGCAEND,DGSTAT,DGIEN,DGTYP,DGFLG
"RTN","DGRPCADD",86,0)
 S DGSTAT="0^0"
"RTN","DGRPCADD",87,0)
 I '$D(DFN) Q DGSTAT
"RTN","DGRPCADD",88,0)
 I '$D(ACTDT) S ACTDT=DT
"RTN","DGRPCADD",89,0)
 S DGCA=$G(^DPT(DFN,.141)) D
"RTN","DGRPCADD",90,0)
 .I DGCA="" Q
"RTN","DGRPCADD",91,0)
 .S DGCABEG=$P(DGCA,U,7)
"RTN","DGRPCADD",92,0)
 .S DGCAEND=$P(DGCA,U,8)
"RTN","DGRPCADD",93,0)
 .I 'DGCABEG!(DGCABEG>ACTDT)!(DGCAEND&(DGCAEND<ACTDT)) Q
"RTN","DGRPCADD",94,0)
 .S DGSTAT="1^0"
"RTN","DGRPCADD",95,0)
 ;Build array of correspondence types
"RTN","DGRPCADD",96,0)
 S (DGIEN,DGFLG)=0
"RTN","DGRPCADD",97,0)
 F  S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN  D  Q:DGFLG
"RTN","DGRPCADD",98,0)
 .S DGTYP=$G(^DPT(DFN,.14,+DGIEN,0))
"RTN","DGRPCADD",99,0)
 .I $P(DGTYP,U,2)="Y" S DGFLG=1
"RTN","DGRPCADD",100,0)
 S $P(DGSTAT,U,2)=$S(DGFLG=1:1,1:0)
"RTN","DGRPCADD",101,0)
 Q DGSTAT
"RTN","DGRPCE")
0^9^B36086453
"RTN","DGRPCE",1,0)
DGRPCE ;ALB/MRL,KV,PJR,BRM,ERC,TDM - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 5/14/09 3:05pm
"RTN","DGRPCE",2,0)
 ;;5.3;Registration;**121,122,175,297,342,451,626,689,653,754**;Aug 13, 1993;Build 46
"RTN","DGRPCE",3,0)
 ;
"RTN","DGRPCE",4,0)
 ;KV;11/15/00;DG*5.3*297;Disable addition of CD Elig Code in Reg. Screens
"RTN","DGRPCE",5,0)
 ;                      ;Adding CD Elig Codes in Load/Edit Screen used to
"RTN","DGRPCE",6,0)
 ;                      ;cause undefined line tag error.
"RTN","DGRPCE",7,0)
 ;
"RTN","DGRPCE",8,0)
 S DGVTYN=$P($G(^DPT(DFN,"VET")),"^",1),DGDR="DR",(DR,DGD,DGDRC,DGCCF)="",DGASK=",",DGER=","_DGER D ^DGRPCE1
"RTN","DGRPCE",9,0)
 S DGEK=0 F I=9,10,11,12,13,14,18,19,20,22,24,36,51 Q:DGEK  I DGER[(","_I_",") S DGEK=1 Q
"RTN","DGRPCE",10,0)
 I 'DGKEY(1) D:DGEK ELDR S I=15 D SASK S I=23 D SASK
"RTN","DGRPCE",11,0)
 F I=29,30,31,32,33,43,44,45,48,56 D SASK,MON:DGCCF S DGCCF=0
"RTN","DGRPCE",12,0)
 G NKEY:DGKEY(3) F I=25,26,27,28,34,35 D SASK
"RTN","DGRPCE",13,0)
 I DGASK'[26 F I=41,42 I DGASK'[41 D SASK
"RTN","DGRPCE",14,0)
 I DGASK'[27 S I=60 I DGASK'[25 D SASK
"RTN","DGRPCE",15,0)
 I DGASK'[34 F I=37,38 I DGASK'[37 D SASK
"RTN","DGRPCE",16,0)
 I DGASK'[35 F I=39,40 I DGASK'[39 D SASK
"RTN","DGRPCE",17,0)
NKEY D ^DGRPCE1
"RTN","DGRPCE",18,0)
 I $S(DGER[49:1,(DGER[",50,"):1,(DGER[52):1,1:0) D
"RTN","DGRPCE",19,0)
 .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
"RTN","DGRPCE",20,0)
 .D REG^IBCNBME(DFN)
"RTN","DGRPCE",21,0)
 .Q
"RTN","DGRPCE",22,0)
 D Q S DIE="^DPT(",(DA,Y)=DFN D ^DIE:$D(DR)
"RTN","DGRPCE",23,0)
 I DGER[54 D GETREL^DGMTU11(DFN,"SD",$$LYR^DGMTSCU1(DT)) D
"RTN","DGRPCE",24,0)
 . I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") D ASKSSN(DGREL("S"))
"RTN","DGRPCE",25,0)
 . F DGDEP=0:0 S DGDEP=$O(DGREL("D",DGDEP)) Q:'DGDEP  I $$SSN^DGMTU1(+DGREL("D",DGDEP))']"" D ASKSSN(DGREL("D",DGDEP))
"RTN","DGRPCE",26,0)
 ;
"RTN","DGRPCE",27,0)
 I DGER[59 D CATDIB
"RTN","DGRPCE",28,0)
 I DGER["82" D EN2^DGRP6CL
"RTN","DGRPCE",29,0)
 ;
"RTN","DGRPCE",30,0)
 I (DGER[301)!(DGER[303)!(DGER[304)!(DGER[307) D
"RTN","DGRPCE",31,0)
 . N DEPFLD
"RTN","DGRPCE",32,0)
 . S DEPFLD=""
"RTN","DGRPCE",33,0)
 . I DGER[301 S DEPFLD=".01;"
"RTN","DGRPCE",34,0)
 . I (DGER[303)!(DGER[304) S DEPFLD=DEPFLD_".02;"
"RTN","DGRPCE",35,0)
 . I DGER[307 S DEPFLD=DEPFLD_".1;"
"RTN","DGRPCE",36,0)
 . D GETREL^DGMTU11(DFN,"SD",$$LYR^DGMTSCU1(DT))
"RTN","DGRPCE",37,0)
 . I $D(DGREL("S")) D DEPEDT(DGREL("S"),DEPFLD)
"RTN","DGRPCE",38,0)
 . F DGDEP=0:0 S DGDEP=$O(DGREL("D",DGDEP)) Q:'DGDEP  D DEPEDT(DGREL("D",DGDEP),DEPFLD)
"RTN","DGRPCE",39,0)
 ;
"RTN","DGRPCE",40,0)
 K DGREL,DGDEP
"RTN","DGRPCE",41,0)
KVAR K DR,DGEDCN,DGCT,DGER,DGINC55,DGRPADI,DGRPOUT,DGVTYN
"RTN","DGRPCE",42,0)
Q K %,C,DA,DGASK,DGCCF,DGCT1,DGCT2,DGCT3,DGD,DGD1,DGD2,DGDR,DGDRC,DGECODE,DGEDIT,DGEK,DGKEY,DGP,DGRPADI,DGRPE,DIC,DIE,DIK,I,I1,J,X,X1,X2
"RTN","DGRPCE",43,0)
 K DGCOMLOC,DGCOMBR,FRDT,DGFRDT,DGCTZ7
"RTN","DGRPCE",44,0)
 D KVAR^VADPT
"RTN","DGRPCE",45,0)
 Q
"RTN","DGRPCE",46,0)
SASK I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=$P($T(@I),";;",2,999),DGASK=DGASK_I_",",DGCCF=1 D SAVE
"RTN","DGRPCE",47,0)
 Q
"RTN","DGRPCE",48,0)
SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q
"RTN","DGRPCE",49,0)
 S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
"RTN","DGRPCE",50,0)
ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38,"
"RTN","DGRPCE",51,0)
 I 'DGKEY(1) S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
"RTN","DGRPCE",52,0)
 I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
"RTN","DGRPCE",53,0)
 D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
"RTN","DGRPCE",54,0)
 I 'DGKEY(1) D ELIG^DGRPCE1
"RTN","DGRPCE",55,0)
 Q
"RTN","DGRPCE",56,0)
MON I $S(I<40:1,I=56:1,1:0) D SAVE Q
"RTN","DGRPCE",57,0)
 I $S(I<46:1,1:0),DGASK'[(","_(I-14)_",") D SAVE Q
"RTN","DGRPCE",58,0)
 I DGASK'[(","_(I-15)_",") D SAVE
"RTN","DGRPCE",59,0)
 Q
"RTN","DGRPCE",60,0)
 ;
"RTN","DGRPCE",61,0)
15 ;;.152;S:X']"" Y="@15";S DIE("NO^")="";.307;I X']"" W !!,*7,"But I need a reason why this applicant is ineligible!" S Y=.152;@15;K DIE("NO^");
"RTN","DGRPCE",62,0)
23 ;;.3611;S:X'="V" Y="@23";.3612;S DIE("NO^")="";I X']"" W !!,*7,"But I need to know the date eligibility was verifed!";@23;K DIE("NO^");
"RTN","DGRPCE",63,0)
25 ;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25;
"RTN","DGRPCE",64,0)
26 ;;
"RTN","DGRPCE",65,0)
27 ;;
"RTN","DGRPCE",66,0)
28 ;;
"RTN","DGRPCE",67,0)
29 ;;.36205;S:X'="Y" Y="@29";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim A&A" S Y=.36205;.36295;@29;
"RTN","DGRPCE",68,0)
30 ;;.36215;S:X'="Y" Y="@30";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim HOUSEBOUND" S Y=.36215;.36295;@30;
"RTN","DGRPCE",69,0)
31 ;;.36235;S:X'="Y" Y="@31";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim VA PENSION" S Y=.36235;.36295;@31;
"RTN","DGRPCE",70,0)
32 ;;.36255;S:X'="Y" Y="@32";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim MIL. RET." S Y=.36255;.3625;@32;
"RTN","DGRPCE",71,0)
33 ;;
"RTN","DGRPCE",72,0)
34 ;;.525;S:X'="Y" Y="@34";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim POW STATUS" S Y=.525;.526:.528;@34;
"RTN","DGRPCE",73,0)
35 ;;
"RTN","DGRPCE",74,0)
37 ;;.525;S:X'="Y" Y="@37";.526:.528;@37;
"RTN","DGRPCE",75,0)
38 ;;.525;S:X'="Y" Y="@38";.526:.528;@38;
"RTN","DGRPCE",76,0)
39 ;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39;
"RTN","DGRPCE",77,0)
40 ;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40;
"RTN","DGRPCE",78,0)
41 ;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41;
"RTN","DGRPCE",79,0)
42 ;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42;
"RTN","DGRPCE",80,0)
43 ;;
"RTN","DGRPCE",81,0)
44 ;;
"RTN","DGRPCE",82,0)
45 ;;
"RTN","DGRPCE",83,0)
46 ;;
"RTN","DGRPCE",84,0)
47 ;;
"RTN","DGRPCE",85,0)
48 ;;.36265;S:X'="Y" Y="@48";.3626;@48;
"RTN","DGRPCE",86,0)
51 ;;I DGVTYN'="Y" S Y="@51";.324:.328;@51;
"RTN","DGRPCE",87,0)
56 ;;.3025;S:X'="Y" Y="@56";.36295;@56;
"RTN","DGRPCE",88,0)
60 ;;.32102;S:X'="Y" Y="@60";.32107;.3211;.32109;.3213;@60;
"RTN","DGRPCE",89,0)
 ;
"RTN","DGRPCE",90,0)
 ; NOTE: #46 & 47 REMOVED WITH PIMS5.3
"RTN","DGRPCE",91,0)
 ;
"RTN","DGRPCE",92,0)
ASKSSN(DEP) ;edit ssns if missing
"RTN","DGRPCE",93,0)
 ;
"RTN","DGRPCE",94,0)
 ; input:  DEP as string for dependent (from GETREL)
"RTN","DGRPCE",95,0)
 ;
"RTN","DGRPCE",96,0)
 W !,$$NAME^DGMTU1(+DEP)
"RTN","DGRPCE",97,0)
 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
"RTN","DGRPCE",98,0)
PS ;
"RTN","DGRPCE",99,0)
 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
"RTN","DGRPCE",100,0)
 I $$GET1^DIQ(408.13,DA_",",.09)["P" D
"RTN","DGRPCE",101,0)
 . S DR=.1,DA=$P(DA,";") D ^DIE
"RTN","DGRPCE",102,0)
 . I X']"" W !,"If SSN is a Pseudo SSN, the Pseudo SSN Reason field is required." G PS
"RTN","DGRPCE",103,0)
 K DA,DR,DIE
"RTN","DGRPCE",104,0)
 Q
"RTN","DGRPCE",105,0)
 ;
"RTN","DGRPCE",106,0)
CATDIB ;
"RTN","DGRPCE",107,0)
 ;Could be inconsistent because there is the catastrophic disability
"RTN","DGRPCE",108,0)
 ;code without supporting information, or visa versa
"RTN","DGRPCE",109,0)
 ;
"RTN","DGRPCE",110,0)
 N DGCDIS,CODE,INFO
"RTN","DGRPCE",111,0)
 S (INFO,CODE)=0
"RTN","DGRPCE",112,0)
 I $$GET^DGENCDA(DFN,.DGCDIS),DGCDIS("DATE") S INFO=1
"RTN","DGRPCE",113,0)
 S CODE=$$HASCAT^DGENCDA(DFN)
"RTN","DGRPCE",114,0)
 I CODE D  Q
"RTN","DGRPCE",115,0)
 .W !!,">>> Catastrophically Disabled eligibilty requires additional information <<<"
"RTN","DGRPCE",116,0)
 .D EDITCD^DGENCD(DFN)
"RTN","DGRPCE",117,0)
 I INFO D
"RTN","DGRPCE",118,0)
 . ;KV;11/15/00;DG*5.3*297;Start of modifications
"RTN","DGRPCE",119,0)
 . W !!,"The patient record indicates that a  determination was made "
"RTN","DGRPCE",120,0)
 . W "that the patient",!,"is catastrophically disabled."
"RTN","DGRPCE",121,0)
 . W !!,"To add Catastrophic Disability Eligibility Code(s), please use "
"RTN","DGRPCE",122,0)
 . W "the menu option",!,"DGEN PATIENT ENROLLMENT.",!!
"RTN","DGRPCE",123,0)
 .I $$ASKDEL() D
"RTN","DGRPCE",124,0)
 .. I $$DELETE^DGENCDA1(DFN) D
"RTN","DGRPCE",125,0)
 ...W !,">>> Determination Deleted <<<"
"RTN","DGRPCE",126,0)
 ..;
"RTN","DGRPCE",127,0)
 ..;could fail if lock could not be obtained
"RTN","DGRPCE",128,0)
 ..E  W !,"Catastrophic disability determination can not be deleted at this time.",!,"Please try again later."
"RTN","DGRPCE",129,0)
 ;KV;11/15/00;DG*5.3*297;End of modifications
"RTN","DGRPCE",130,0)
 Q
"RTN","DGRPCE",131,0)
 ;
"RTN","DGRPCE",132,0)
ASKDEL() ;
"RTN","DGRPCE",133,0)
 ;ask whether to delete catastrphic disability determination
"RTN","DGRPCE",134,0)
 N DIR
"RTN","DGRPCE",135,0)
 S DIR(0)="Y"
"RTN","DGRPCE",136,0)
 ;KV;11/15/00;DG*5.3*297;Cosmetic change for DIR("A")
"RTN","DGRPCE",137,0)
 S DIR("A")="Do you want to delete the determination showing that patient is catastrophically disabled"
"RTN","DGRPCE",138,0)
 S DIR("B")="YES"
"RTN","DGRPCE",139,0)
 D ^DIR
"RTN","DGRPCE",140,0)
 Q:$D(DIRUT) 0
"RTN","DGRPCE",141,0)
 Q $S(Y=1:1,1:0)
"RTN","DGRPCE",142,0)
 ;
"RTN","DGRPCE",143,0)
DEPEDT(DEP,FLD) ;edit dependent fields if missing or invalid
"RTN","DGRPCE",144,0)
 ;
"RTN","DGRPCE",145,0)
 ; input:  DEP as string for dependent (from GETREL)
"RTN","DGRPCE",146,0)
 ;         FLD as 408.13 field(s) to edit (separated by ';')
"RTN","DGRPCE",147,0)
 ;
"RTN","DGRPCE",148,0)
 Q:$G(FLD)=""
"RTN","DGRPCE",149,0)
 W !!,$$NAME^DGMTU1(+DEP)
"RTN","DGRPCE",150,0)
 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=FLD D ^DIE
"RTN","DGRPCE",151,0)
 K DA,DR,DIE
"RTN","DGRPCE",152,0)
 Q
"RTN","DGRPCE1")
0^10^B61785296
"RTN","DGRPCE1",1,0)
DGRPCE1 ;ALB/MIR/BRM/LBD,BAJ,TDM - CONSISTENCY CHECKER EDIT ; 10/6/09 10:24am
"RTN","DGRPCE1",2,0)
 ;;5.3;Registration;**108,226,470,454,489,505,522,451,632,689,657,688,804,754**;Aug 13, 1993;Build 46
"RTN","DGRPCE1",3,0)
 N I,J F I=1:1:8,16,53,57,58,61:1:88 D SASK
"RTN","DGRPCE1",4,0)
 F I=301,303,304,306:1:308,402,403,406,407,501:1:507,516,517 D SASK
"RTN","DGRPCE1",5,0)
 ;F I=49,50,52 D SASK ;BELOW REPLACED WITH ^IBCNSP2 CALL
"RTN","DGRPCE1",6,0)
 ;OLDS DR(2,2.312)="S DGRPADI="""";.01;1;2;15;8;7;3;6;S DGRPADI=X;I DGRPADI'=""v"" S Y=""@2312"";17///^S X=""`""_DFN;16///^S X=""01"";S Y=""@23121"";@2312;17;16//^S X=$S(DGRPADI=""s"":""02"",1:"""");@23121;9:14;"
"RTN","DGRPCE1",7,0)
 Q
"RTN","DGRPCE1",8,0)
SASK I DGER[(","_I_","),DGASK'[(","_I_",") F J=I,I*1000:1 Q:'$T(@J)  S DGD=DGD_$P($T(@J),";;",2,999) D SAVE
"RTN","DGRPCE1",9,0)
 S DGASK=DGASK_I_","
"RTN","DGRPCE1",10,0)
 Q
"RTN","DGRPCE1",11,0)
SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q
"RTN","DGRPCE1",12,0)
 S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
"RTN","DGRPCE1",13,0)
 ;
"RTN","DGRPCE1",14,0)
 ;
"RTN","DGRPCE1",15,0)
ELIG ;eligibility code...if M11+, use compiled template, otherwise DR string
"RTN","DGRPCE1",16,0)
 I ^%ZOSF("OS")'["M/11+" S DGD=$P($T(14),";;",2,999) D SAVE Q
"RTN","DGRPCE1",17,0)
 N DA,DIE,DR S DIE="^DPT(",DA=DFN,DR="[DG CONSISTENCY CHECKER]" D ^DIE
"RTN","DGRPCE1",18,0)
 Q
"RTN","DGRPCE1",19,0)
 ;
"RTN","DGRPCE1",20,0)
 ;
"RTN","DGRPCE1",21,0)
1 ;;.01;
"RTN","DGRPCE1",22,0)
2 ;;1;
"RTN","DGRPCE1",23,0)
3 ;;.02;
"RTN","DGRPCE1",24,0)
4 ;;.03;
"RTN","DGRPCE1",25,0)
5 ;;.05;
"RTN","DGRPCE1",26,0)
6 ;;.08;
"RTN","DGRPCE1",27,0)
7 ;;.09;
"RTN","DGRPCE1",28,0)
8 ;;N FLG S FLG(2)=1 S:$G(DGER)[",61," FLG(1)=1 D EN^DGREGAED(DFN,.FLG);
"RTN","DGRPCE1",29,0)
14 ;;.361;S DGECODE=$S($D(^DIC(8,+X,0)):$P(^(0),"^",1),1:"");S:$S(DGECODE["ALLIED":0,DGECODE["FEDERAL":0,1:1) Y=.323;.309;.323;D ^DGYZODS;S:'DGODS Y="@14";11500.02;11500.03;@14;
"RTN","DGRPCE1",30,0)
16 ;;.351;
"RTN","DGRPCE1",31,0)
53 ;;.07;.31115;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@53";.3111;S:X']"" Y="@53";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@53;
"RTN","DGRPCE1",32,0)
57 ;;.381;.382///NOW;
"RTN","DGRPCE1",33,0)
58 ;;.322013;S:X'="Y" Y="@589";.322014;.322015;.32201;S:X'="Y" Y="@581";.322011;.322012;@581;.322016;S:X'="Y" Y="@589";.322017;.322018;@589;
"RTN","DGRPCE1",34,0)
61 ;;S:$G(DGER)[",8," Y="@619";.132;@619;
"RTN","DGRPCE1",35,0)
62 ;;.331;
"RTN","DGRPCE1",36,0)
63 ;;D EN^DGREGTED(DFN,"CONF");
"RTN","DGRPCE1",37,0)
64 ;;.092;.093;
"RTN","DGRPCE1",38,0)
65 ;;.2403;
"RTN","DGRPCE1",39,0)
66 ;;.09;
"RTN","DGRPCE1",40,0)
67 ;;S:$$DGERCK^DGRPCE1("73^79^80^81^82",.DGER) Y="@67";W !!,$C(7),"SERVICE SEPARATION DATE [LAST] must be a precise date to determine CV Elig",!;.325;.32911;.326;.327;@67;
"RTN","DGRPCE1",41,0)
68 ;;S:$$DGERCK^DGRPCE1("39^40",.DGER) Y="@68";W !!,$C(7),"COMBAT TO DATE must be a precise date to determine CV Eligibility",!;.5291;S:X'="Y" Y="@68";.5292;.5293;.5294;@68;
"RTN","DGRPCE1",42,0)
69 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@69";W !!,$C(7),"YUGOSLAVIA TO DATE must be a precise date to determine CV Eligibility",!;.322019;S:X'="Y" Y="@69";.32202;.322021;@69;
"RTN","DGRPCE1",43,0)
70 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@70";W !!,$C(7),"SOMALIA TO DATE must be a precise date to determine CV Eligibility",!;.322016;S:X'="Y" Y="@70";.322017;.322018,@70;
"RTN","DGRPCE1",44,0)
71 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@71";W !!,$C(7),"PERSIAN GULF TO DATE must be a precise date to determine CV Eligibility",!;.32201;S:X'="Y" Y="@71";.322011;.322012;@71;
"RTN","DGRPCE1",45,0)
72 ;;.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@7201";.3291;.32912;.3292;.3293;.329;@7201;S:'$$YN^DGRPCE1(.32945) Y="@7202";.3296;.32913;.3297;.3298;.3295;@7202;
"RTN","DGRPCE1",46,0)
 ;
"RTN","DGRPCE1",47,0)
73 ;;S:$$DGERCK^DGRPCE1(72,.DGER) Y="@7302";.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@7301";.3291;.32912;.3292;.3293;.329;@7301;S:'$$YN^DGRPCE1(.32945) Y="@7302";.3296;.32913;.3297;.3298;.3295;@7302;
"RTN","DGRPCE1",48,0)
74 ;;S:'$$YN^DGRPCE1(.32101) Y="@7401";.32101;S:X'="Y" Y="@7401";.32104;.32105;@7401;S:'$$YN^DGRPCE1(.322016) Y="@7402";.322016;S:X'="Y" Y="@7402";.322017;.322018;@7402;
"RTN","DGRPCE1",49,0)
74000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7403";.322019;S:X'="Y" Y="@7403";.32202;.322021;@7403;S:'$$YN^DGRPCE1(.3221) Y="@7404";.3221;S:X'="Y" Y="@7404";.3222;.3223;@7404;
"RTN","DGRPCE1",50,0)
74001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7405";.3224;S:X'="Y" Y="@7405";.3225;.3226;@7405;S:'$$YN^DGRPCE1(.3227) Y="@7406";.3227;S:X'="Y" Y="@7406";.3228;.3229;@7406;
"RTN","DGRPCE1",51,0)
74002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7407";.32201;S:X'="Y" Y="@7407";.322011;.322012;@7407;
"RTN","DGRPCE1",52,0)
75 ;;S:$$DGERCK^DGRPCE1(74,.DGER) Y="@7507";S:'$$YN^DGRPCE1(.32101) Y="@7501";.32101;S:X'="Y" Y="@7501";.32104;.32105;@7501;S:'$$YN^DGRPCE1(.322016) Y="@7502";.322016;S:X'="Y" Y="@7502";.322017;.322018;@7502;
"RTN","DGRPCE1",53,0)
75000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7503";.322019;S:X'="Y" Y="@7503";.32202;.322021;@7503;S:'$$YN^DGRPCE1(.3221) Y="@7504";.3221;S:X'="Y" Y="@7504";.3222;.3223;@7504;
"RTN","DGRPCE1",54,0)
75001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7505";.3224;S:X'="Y" Y="@7505";.3225;.3226;@7505;S:'$$YN^DGRPCE1(.3227) Y="@7506";.3227;S:X'="Y" Y="@7506";.3228;.3229;@7506;
"RTN","DGRPCE1",55,0)
75002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7507";.32201;S:X'="Y" Y="@7507";.322011;.322012;@7507;
"RTN","DGRPCE1",56,0)
76 ;;S:$$DGERCK^DGRPCE1("74^75",.DGER) Y="@7607";S:'$$YN^DGRPCE1(.32101) Y="@7601";.32101;S:X'="Y" Y="@7601";.32104;.32105;@7601;S:'$$YN^DGRPCE1(.322016) Y="@7602";.322016;S:X'="Y" Y="@7602";.322017;.322018;@7602;
"RTN","DGRPCE1",57,0)
76000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7603";.322019;S:X'="Y" Y="@7603";.32202;.322021;@7603;S:'$$YN^DGRPCE1(.3221) Y="@7604";.3221;S:X'="Y" Y="@7604";.3222;.3223;@7604;
"RTN","DGRPCE1",58,0)
76001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7605";.3224;S:X'="Y" Y="@7605";.3225;.3226;@7605;S:'$$YN^DGRPCE1(.3227) Y="@7606";.3227;S:X'="Y" Y="@7606";.3228;.3229;@7606;
"RTN","DGRPCE1",59,0)
76002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7607";.32201;S:X'="Y" Y="@7607";.322011;.322012;@7607;
"RTN","DGRPCE1",60,0)
77 ;;S:(($$DGERCK^DGRPCE1("37^38",.DGER))!('$$YN^DGRPCE1(.525))) Y="@77";.525;S:X'="Y" Y="@77";.526;.527;.528;@77;
"RTN","DGRPCE1",61,0)
78 ;;S:(($$DGERCK^DGRPCE1("39^40^68",.DGER))!('$$YN^DGRPCE1(.5291))) Y="@78";.5291;S:X'="Y" Y="@78";.5292;.5293;.5294;@78;
"RTN","DGRPCE1",62,0)
79 ;;S:$$DGERCK^DGRPCE1("72^73",.DGER) Y="@7902";.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@7901";.3291;.32912;.3292;.3293;.329;@7901;S:'$$YN^DGRPCE1(.32945) Y="@7902";.3296;.32913;.3297;.3298;.3295;@7902;
"RTN","DGRPCE1",63,0)
80 ;;S:(($$DGERCK^DGRPCE1("37^38^77",.DGER))!('$$YN^DGRPCE1(.525))) Y="@8001";.525;S:X'="Y" Y="@8001";.526;.527;.528;@8001;S:$$DGERCK^DGRPCE1("72^73^79",.DGER) Y="@8003";
"RTN","DGRPCE1",64,0)
80000 ;;.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8002";.3291;.32912;.3292;.3293;.329;@8002;S:'$$YN^DGRPCE1(.32945) Y="@8003";.3296;.32913;.3297;.3298;.3295;@8003;
"RTN","DGRPCE1",65,0)
81 ;;S:(($$DGERCK^DGRPCE1("39^40^78",.DGER))!('$$YN^DGRPCE1(.5291))) Y="@8101";.5291;S:X'="Y" Y="@8101";.5292;.5293;.5294;@8101;S:$$DGERCK^DGRPCE1("72^73^79^80",.DGER) Y="@8103";
"RTN","DGRPCE1",66,0)
81000 ;;.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8102";.3291;.32912;.3292;.3293;.329;@8102;S:'$$YN^DGRPCE1(.32945) Y="@8103";.3296;.32913;.3297;.3298;.3295;@8103;
"RTN","DGRPCE1",67,0)
82 ;;S:($$DGERCK^DGRPCE1("74^75^76",.DGER)) Y="@8207";S:'$$YN^DGRPCE1(.32101) Y="@8201";.32101;S:X'="Y" Y="@8201";.32104;.32105;@8201;S:'$$YN^DGRPCE1(.322016) Y="@8202";.322016;
"RTN","DGRPCE1",68,0)
82000 ;;S:X'="Y" Y="@8202";.322017;.322018;@8202;S:'$$YN^DGRPCE1(.322019) Y="@8203";.322019;S:X'="Y" Y="@8203";.32202;.322021;@8203;S:'$$YN^DGRPCE1(.3221) Y="@8204";.3221;
"RTN","DGRPCE1",69,0)
82001 ;;S:X'="Y" Y="@8204";.3222;.3223;@8204;S:'$$YN^DGRPCE1(.3224) Y="@8205";.3224;S:X'="Y" Y="@8205";.3225;.3226;@8205;S:'$$YN^DGRPCE1(.3227) Y="@8206";.3227;S:X'="Y" Y="@8206";
"RTN","DGRPCE1",70,0)
82002 ;;.3228;.3229;@8206;S:'$$YN^DGRPCE1(.32201) Y="@8207";.32201;S:X'="Y" Y="@8207";.322011;.322012;@8207;S:($$DGERCK^DGRPCE1("72^73^79^80^81",.DGER)) Y="@8209";
"RTN","DGRPCE1",71,0)
82003 ;;.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8208";.3291;.32912;.3292;.3293;.329;@8208;S:'$$YN^DGRPCE1(.32945) Y="@8209";.3296;.32913;.3297;.3298;.3295;@8209;
"RTN","DGRPCE1",72,0)
83 ;;S:$$DGERCK^DGRPCE1(73,.DGER) Y="@83";@8295;D SET32^DGRPE(DA,.DIPA,1);.325;S DIPA("X1")=X S:X']"" Y="@83";S:$$FV^DGRPMS(X)'=1 Y="@8296";.3214;I X']"" W !?4,$C(7),"Proof is required for Filipino Vet." S Y="@8295";
"RTN","DGRPCE1",73,0)
83000 ;;@8296;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y) S:$E(Y,1,4)="@601" Y=.326;.32911;.326;.327;
"RTN","DGRPCE1",74,0)
83001 ;;.3285//NO;S:X'="Y" Y="@83";D SET32^DGRPE(DA,.DIPA,2);.3291;S DIPA("X2")=X S:X']"" Y="@83";S:$$FV^DGRPMS(X)'=1 Y="@832";.3214;I X']"" W !?4,$C(7),"Proof is required for Filipino Vet." S Y=".3291";S Y=.3292;
"RTN","DGRPCE1",75,0)
83002 ;;@832;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y) S:$E(Y,1,4)="@601" Y=.3292;.32912;.3292;.3293;
"RTN","DGRPCE1",76,0)
83003 ;;.32945//NO;S:X'="Y" Y="@83";D SET32^DGRPE(DA,.DIPA,3);.3296;S DIPA("X3")=X S:X']"" Y="@83";S:$$FV^DGRPMS(X)'=1 Y="@833";.3214;I X']"" W !?4,$C(7),"Proof is required for Filipino Vet." S Y=".3296";S Y=.3297;@833;
"RTN","DGRPCE1",77,0)
83004 ;;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y) S:$E(Y,1,4)="@601" Y=.3297;.32913;.3297;.3298;@83;
"RTN","DGRPCE1",78,0)
84 ;;.3214;
"RTN","DGRPCE1",79,0)
85 ;;1901;
"RTN","DGRPCE1",80,0)
86 ;;1901;
"RTN","DGRPCE1",81,0)
87 ;;D VETTYPE^DGRPE1;D MSG^DGRPE1 S Y=0;@114;K DGRDCHG;D DR^DGRPE1;.302;.3721;D EFF^DGRPE1;D:$G(DGRDCHG) BULL^DGRPE1;K DGRDCHG;
"RTN","DGRPCE1",82,0)
88 ;;D EN^DGREGTED(DFN,"TEMP");
"RTN","DGRPCE1",83,0)
301 ;;.01;
"RTN","DGRPCE1",84,0)
303 ;;.02;
"RTN","DGRPCE1",85,0)
304 ;;.02;
"RTN","DGRPCE1",86,0)
306 ;;.09;
"RTN","DGRPCE1",87,0)
307 ;;.0906;
"RTN","DGRPCE1",88,0)
308 ;;.351;
"RTN","DGRPCE1",89,0)
402 ;;.381;
"RTN","DGRPCE1",90,0)
403 ;;.382;
"RTN","DGRPCE1",91,0)
406 ;;.313;
"RTN","DGRPCE1",92,0)
407 ;;.3611;
"RTN","DGRPCE1",93,0)
501 ;;.525;
"RTN","DGRPCE1",94,0)
502 ;;.3602;
"RTN","DGRPCE1",95,0)
503 ;;.3603;
"RTN","DGRPCE1",96,0)
504 ;;.32102;
"RTN","DGRPCE1",97,0)
505 ;;.32103;
"RTN","DGRPCE1",98,0)
506 ;;.322013;
"RTN","DGRPCE1",99,0)
507 ;;.32103;.3212;
"RTN","DGRPCE1",100,0)
516 ;;.03;
"RTN","DGRPCE1",101,0)
517 ;;.03;
"RTN","DGRPCE1",102,0)
 ;
"RTN","DGRPCE1",103,0)
YN(FLD,DFN,FILE) ; return binary for YES/NO flds in the Patient (#2) file
"RTN","DGRPCE1",104,0)
 N RTN
"RTN","DGRPCE1",105,0)
 Q:$G(FLD)']"" ""
"RTN","DGRPCE1",106,0)
 S:$G(FILE)="" FILE=2 S:$G(DFN)="" DFN=$G(DA) Q:$G(DFN)']"" ""
"RTN","DGRPCE1",107,0)
 S RTN=$$GET1^DIQ(FILE,DFN_",",FLD,"I")
"RTN","DGRPCE1",108,0)
 Q $S(RTN=1:1,RTN=0:0,RTN="Y":1,RTN="N":0,1:"")
"RTN","DGRPCE1",109,0)
 ;
"RTN","DGRPCE1",110,0)
DGERCK(STR,DGER) ;do any of the STR errors exist in DGER?
"RTN","DGRPCE1",111,0)
 N RTN,X
"RTN","DGRPCE1",112,0)
 Q:$G(STR)']"" 0  Q:$G(DGER)']"" 0
"RTN","DGRPCE1",113,0)
 S RTN=0 F X=1:1 Q:RTN!($P(STR,"^",X)="")  I DGER[(","_$P(STR,"^",X)_",") S RTN=1
"RTN","DGRPCE1",114,0)
 Q RTN
"RTN","DGRPCF")
0^11^B24182202
"RTN","DGRPCF",1,0)
DGRPCF ;ALB/MRL,BAJ,TDM - CONSISTENCY OF PATIENT DATA (FILE/EDIT) ; 6/17/09 12:28pm
"RTN","DGRPCF",2,0)
 ;;5.3;Registration;**250,653,786,754**;Aug 13, 1993;Build 46
"RTN","DGRPCF",3,0)
 ;
"RTN","DGRPCF",4,0)
 ; file new inconsistencies or update file entries for patient
"RTN","DGRPCF",5,0)
 ;
"RTN","DGRPCF",6,0)
 ; DGCT = count of inconsistencies found (passed in from checker)
"RTN","DGRPCF",7,0)
 ; DGCT1= count of inconsistencies which can't be edited because
"RTN","DGRPCF",8,0)
 ;        user does not hold appropriate key
"RTN","DGRPCF",9,0)
 ; DGCT2= count of already filed inconsistencies
"RTN","DGRPCF",10,0)
 ; DGCT3= count of inconsistencies which are uneditable through
"RTN","DGRPCF",11,0)
 ;        checker options
"RTN","DGRPCF",12,0)
 ; DGCTZ7= count of inconsistencies found that will prevent Z07
"RTN","DGRPCF",13,0)
 ;
"RTN","DGRPCF",14,0)
 ;
"RTN","DGRPCF",15,0)
 ; 
"RTN","DGRPCF",16,0)
EN I '$D(DGCT) G KVAR^DGRPCE
"RTN","DGRPCF",17,0)
 ; DG*5.3*653 BAJ modified to delete only inconsistencies numbered 99 or less
"RTN","DGRPCF",18,0)
 N DGADD S DGADD=0 ;786 corrects problem with incorrect header
"RTN","DGRPCF",19,0)
 ;I 'DGCT,$O(^DGIN(38.5,DFN,"I",""),-1)>99 D DELETE G KVAR^DGRPCE
"RTN","DGRPCF",20,0)
 I 'DGCT D DELETE G KVAR^DGRPCE
"RTN","DGRPCF",21,0)
 S DGEDCN=+$G(DGEDCN),DGRPOUT=+$G(DGRPOUT),DGCON=1 D:DGEDCN START^DGRPC I 'DGCT D ^DGRPCF1,TIMEQ^DGRPC G KVAR^DGRPCE
"RTN","DGRPCF",22,0)
 S:'$D(^DGIN(38.5,DFN,0)) ^(0)=DFN_"^"_DT_"^"_$S(('$D(DUZ)#2):"",1:DUZ),DGADD=1 S X=$P(^(0),"^",4),^DGIN(38.5,DFN,0)=$P(^(0),"^",1,3)_"^"_DT_"^"_$S(('$D(DUZ)#2):"",1:DUZ)_"^"_$P(^(0),"^",6) K ^DGIN(38.5,"AC",9999999-X,DFN)
"RTN","DGRPCF",23,0)
 S ^DGIN(38.5,"B",DFN,DFN)="",^DGIN(38.5,"AC",9999999-DT,DFN)="",^DGIN(38.5,0)=$P(^DGIN(38.5,0),"^",1,2)_"^"_DFN_"^"_($P(^(0),"^",4)+DGADD) ;786 corrected for incorrect header
"RTN","DGRPCF",24,0)
 I $D(^DGIN(38.5,DFN,"I")) D DELETE
"RTN","DGRPCF",25,0)
 S DGD2=0 F DGD=1:1 S DGD1=$P(DGER,",",DGD) Q:DGD1=""  I $D(^DGIN(38.6,DGD1,0)) S DGD2=DGD1 S ^DGIN(38.5,DFN,"I",DGD1,0)=DGD1
"RTN","DGRPCF",26,0)
 S ^DGIN(38.5,DFN,"I",0)="^38.51PA^"_DGD2_"^"_DGCT I DGCT,DGEDCN G DIS
"RTN","DGRPCF",27,0)
 G KVAR^DGRPCE
"RTN","DGRPCF",28,0)
 ;
"RTN","DGRPCF",29,0)
DIS D TIME^DGRPC S DGRPE=$S($D(DGRPE):DGRPE+1,1:0) D KEY S IOP="HOME" D ^%ZIS K IOP W @IOF,! D DEM^VADPT W VADM(1)," (",$P(VADM(2),"^",2),")",?65,$P(VADM(3),"^",2) S X="",$P(X,"=",79)="" W !,X
"RTN","DGRPCF",30,0)
 S (C,DGCT1,DGCT2,DGCT3,DGCTZ7)=0,DGEDIT="0000000011111110011111113333222223313333332222220030000" F I=1:1 S J=$P(DGER,",",I) Q:J=""  I $D(^DGIN(38.6,J,0)) S X2=$P(^(0),"^",1) D WRIT
"RTN","DGRPCF",31,0)
 I DGCT1!DGCT3 W ! D NOEDIT
"RTN","DGRPCF",32,0)
 I DGCTZ7 W !!,"Inconsistencies followed by [+] will prevent a Z07"
"RTN","DGRPCF",33,0)
 S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1)
"RTN","DGRPCF",34,0)
EDIT G:DGRPOUT BUL I DGCT1+DGCT3'=DGCT W !!,"DO YOU WANT TO UPDATE THESE INCONSISTENCIES NOW" S %=1 D YN^DICN I %=1 D  G ^DGRPC
"RTN","DGRPCF",35,0)
 . S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1)
"RTN","DGRPCF",36,0)
 . L +^DPT(DFN):3 E  W *7,!!,"Patient is being edited. Try again later."  S DGEDCN=0 Q
"RTN","DGRPCF",37,0)
 . D ^DGRPCE
"RTN","DGRPCF",38,0)
 . L -^DPT(DFN)
"RTN","DGRPCF",39,0)
 . S DGEDCN=1
"RTN","DGRPCF",40,0)
 I $S(($G(DGRETURN)>10):0,$G(DGINC55):1,1:0) D
"RTN","DGRPCF",41,0)
 .N DIR
"RTN","DGRPCF",42,0)
 .S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? ",DIR("B")="YES" D ^DIR
"RTN","DGRPCF",43,0)
 .S:Y>0 DGRPV=0
"RTN","DGRPCF",44,0)
 .S:Y>0 DGRETURN=$G(DGRETURN)+1
"RTN","DGRPCF",45,0)
 I $S($G(Y)'>0:0,(DGRETURN>11):0,1:1) D ^DGRPV G ^DGRP9
"RTN","DGRPCF",46,0)
 I DGCT1+DGCT3'=DGCT,'% W !!?4,"YES - To correct inconsistencies to unrestricted fields immediately.",!?4,"NO  - To abort this process immediately." G EDIT
"RTN","DGRPCF",47,0)
BUL K DGRETURN,X,Y D ^DGRPCB G KVAR^DGRPCE
"RTN","DGRPCF",48,0)
 ;
"RTN","DGRPCF",49,0)
WRIT ;S C=C+1 W:(C#2) ! S X1=$S((C#2):0,1:40) W ?X1,$E(J_"  ",1,3),"- ",X2 I DGKEY(+$E(DGEDIT,J)) W "*" S DGCT1=DGCT1+1
"RTN","DGRPCF",50,0)
 S C=C+1 W:(C#2) ! S X1=$S((C#2):0,1:40) W ?X1,$E(J_"  ",1,3),"- "
"RTN","DGRPCF",51,0)
 W X2 I DGKEY(+$E(DGEDIT,J))!(J=407) W "*" S DGCT1=DGCT1+1
"RTN","DGRPCF",52,0)
 I "^17^55^"[("^"_+J_"^") W "**" S DGCT3=DGCT3+1
"RTN","DGRPCF",53,0)
 I +$P(DGRPCOLD,",",2),DGRPCOLD'[(","_J_",") S DGCT2=DGCT2+1
"RTN","DGRPCF",54,0)
 I $P($G(^DGIN(38.6,J,0)),"^",6) W "+" S DGCTZ7=DGCTZ7+1
"RTN","DGRPCF",55,0)
 Q
"RTN","DGRPCF",56,0)
KEY S X=$S(('$D(DUZ)#2):1,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):1,1:0) F I=.3,.32,.361 S DGP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPCF",57,0)
 F I=0:1:4 S DGKEY(I)=""
"RTN","DGRPCF",58,0)
 I $P(DGP(.361),"^",1)="V",X S DGKEY(1)=1
"RTN","DGRPCF",59,0)
 I $P(DGP(.3),"^",6)]"",X S DGKEY(2)=1
"RTN","DGRPCF",60,0)
 I $P(DGP(.32),"^",2)]"",X S DGKEY(3)=1
"RTN","DGRPCF",61,0)
 S:'X DGKEY(4)=1 K DGP Q
"RTN","DGRPCF",62,0)
 ;
"RTN","DGRPCF",63,0)
DELETE ; Delete all Registration inconsistencies from INCONSISTENT DATA file (#38.5).
"RTN","DGRPCF",64,0)
 ; 
"RTN","DGRPCF",65,0)
 ;
"RTN","DGRPCF",66,0)
 N RULE,DIK,DA
"RTN","DGRPCF",67,0)
 ;
"RTN","DGRPCF",68,0)
 S RULE=0,DA=""
"RTN","DGRPCF",69,0)
 S DIK="^DGIN(38.5,"_DFN_","_"""I"""_","
"RTN","DGRPCF",70,0)
 ;F  S RULE=$O(^DGIN(38.5,DFN,"I",RULE)) Q:RULE=""  Q:RULE>99  S DA=RULE D ^DIK
"RTN","DGRPCF",71,0)
 F  S RULE=$O(^DGIN(38.5,DFN,"I",RULE)) Q:RULE=""  D
"RTN","DGRPCF",72,0)
 . I RULE>99,OVER99'[(","_RULE_",") Q
"RTN","DGRPCF",73,0)
 . S DA=RULE D ^DIK
"RTN","DGRPCF",74,0)
 Q
"RTN","DGRPCF",75,0)
 ;
"RTN","DGRPCF",76,0)
NOEDIT ; write explanation of non-editable items
"RTN","DGRPCF",77,0)
 I DGCT1 W !,"You will not be able to edit inconsistencies followed by an asterisk [*]",!,"as you do not hold the appropriate ""DG ELIGIBILITY"" security key."
"RTN","DGRPCF",78,0)
 I DGCT3 W !,"Inconsistencies followed by two (2) asterisks [**] must be corrected by",!,"using the appropriate MAS menu option(s)."
"RTN","DGRPCF",79,0)
 I DGCT1+DGCT3'=DGCT W !!,"All items not followed by an asterisk can be edited at this time.  If these",!,"items are not corrected at this time, a bulletin will be sent to the",!,"appropriate hospital personnel."
"RTN","DGRPCF",80,0)
 ;;QUIT
"RTN","DGRPEIS3")
0^38^B91146674
"RTN","DGRPEIS3",1,0)
DGRPEIS3 ;ALB/CAW,EG,ERC,BAJ,TDM - INCOME SCREENING DATA (CON'T) ; 5/26/10 2:03pm
"RTN","DGRPEIS3",2,0)
 ;;5.3;Registration;**45,624,659,653,688,754**;Aug 13, 1993;Build 46
"RTN","DGRPEIS3",3,0)
 ;
"RTN","DGRPEIS3",4,0)
HELP ; Display information when veteran's DOB is past the income year
"RTN","DGRPEIS3",5,0)
 ;
"RTN","DGRPEIS3",6,0)
 W !!,"Please return to screen 8 and check the veteran's effective date."
"RTN","DGRPEIS3",7,0)
 W !,"The effective date was created based on the veteran's date of birth."
"RTN","DGRPEIS3",8,0)
 W !,"You might also want to check the date of birth for this veteran."
"RTN","DGRPEIS3",9,0)
 W ! S DIR(0)="E" D ^DIR K DIR W !
"RTN","DGRPEIS3",10,0)
 Q
"RTN","DGRPEIS3",11,0)
 ;
"RTN","DGRPEIS3",12,0)
WRT ; Write age statement
"RTN","DGRPEIS3",13,0)
 Q:'$G(DGMTI)
"RTN","DGRPEIS3",14,0)
 W !!,"This dependent is 18 years or older.  To list this person as a dependent"
"RTN","DGRPEIS3",15,0)
 W !,"they have to be:"
"RTN","DGRPEIS3",16,0)
 W !,"     1.  An UNMARRIED child who is under the age of 18."
"RTN","DGRPEIS3",17,0)
 W !,"     2.  Between the ages of 18 and 23 and attending school."
"RTN","DGRPEIS3",18,0)
 W !,"     3.  An unmarried child over the age of 17 who became permanently"
"RTN","DGRPEIS3",19,0)
 W !,"         incapable of self support before the age of 18."
"RTN","DGRPEIS3",20,0)
 Q
"RTN","DGRPEIS3",21,0)
 ;
"RTN","DGRPEIS3",22,0)
EDIT ;CALLED FROM ROUTINE DGRPEIS
"RTN","DGRPEIS3",23,0)
 N DGEXIT,SSNV,SSNVL,SSNUM
"RTN","DGRPEIS3",24,0)
 S DGEDDEP=1
"RTN","DGRPEIS3",25,0)
 S DGFL=$G(DGFL)
"RTN","DGRPEIS3",26,0)
 S DATE=$S($G(DATE):DATE,1:$$LYR^DGMTSCU1(DT))
"RTN","DGRPEIS3",27,0)
 S X=$P(DGPREF,"^",2)
"RTN","DGRPEIS3",28,0)
 S DGTYPE=$G(DGTYPE),DGTYPE=$S(DGTYPE']"":"S",DGTYPE="C":"C",DGTYPE="D":"D",1:"S")
"RTN","DGRPEIS3",29,0)
 S DIE="^"_$P(X,";",2),DA=+X
"RTN","DGRPEIS3",30,0)
 ;
"RTN","DGRPEIS3",31,0)
 ; DG*5.3*653 ERC Pseudo SSN Reason changes
"RTN","DGRPEIS3",32,0)
 ; DG*5.3*688 BAJ SSN Verification changes
"RTN","DGRPEIS3",33,0)
 ; 
"RTN","DGRPEIS3",34,0)
 ; Retrieve SSN VERIFIED statusrequired 
"RTN","DGRPEIS3",35,0)
 S SSNVL=DIE_DA_",0)"
"RTN","DGRPEIS3",36,0)
 S SSNUM=$P(@SSNVL,"^",9),SSNV=$P(@SSNVL,"^",11)
"RTN","DGRPEIS3",37,0)
 ;
"RTN","DGRPEIS3",38,0)
 ; Lock SSN if SSN is VERIFIED
"RTN","DGRPEIS3",39,0)
 S DR=$S(SSNV=4:".01;.02;.03;S UPARROW=1",1:".01;.02;.03;.09;S UPARROW=1")
"RTN","DGRPEIS3",40,0)
 S DGEXIT=0
"RTN","DGRPEIS3",41,0)
 K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1 D EDITQ Q
"RTN","DGRPEIS3",42,0)
 I SSNV="V" W !,"SOCIAL SECURITY NUMBER "_SSNUM_" has been verified by SSA -- NO EDITING"
"RTN","DGRPEIS3",43,0)
 ;
"RTN","DGRPEIS3",44,0)
 ; changes to make Pseudo SSN Reason required - DG*5.3*653, ERC
"RTN","DGRPEIS3",45,0)
 S DGEXIT=0 I $P($G(@(DIE_DA_",0)")),U,9)["P" D SSNREA(.DGEXIT) I DGEXIT=1 Q
"RTN","DGRPEIS3",46,0)
 I DGTYPE="S" D
"RTN","DGRPEIS3",47,0)
 . S DR="1.1;S UPARROW=1"
"RTN","DGRPEIS3",48,0)
 . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1
"RTN","DGRPEIS3",49,0)
 I DGEXIT=1 Q
"RTN","DGRPEIS3",50,0)
 ;
"RTN","DGRPEIS3",51,0)
 ; ; end SSN Verification & Pseudo SSN Reason changes
"RTN","DGRPEIS3",52,0)
 ; 
"RTN","DGRPEIS3",53,0)
 S DOB=$P($G(@(DIE_DA_",0)")),U,3)
"RTN","DGRPEIS3",54,0)
 ;
"RTN","DGRPEIS3",55,0)
 N DGVADD,DGSADD,DGIPIEN,DGUQTLP,SPOUSE,DGFL,DGRPI
"RTN","DGRPEIS3",56,0)
 S (DGVADD,DGSADD,DGIPIEN,DGUQTLP)=0
"RTN","DGRPEIS3",57,0)
 S SPOUSE=$S(DGTYPE="S":1,1:0),DGFL=$G(DGFL)
"RTN","DGRPEIS3",58,0)
 ;
"RTN","DGRPEIS3",59,0)
 ; if veteran address is not USA, skip this ^DIR call
"RTN","DGRPEIS3",60,0)
 I $$FORIEN^DGADDUTL($P($G(^DPT(DFN,.11)),U,10)) G FOREIGN
"RTN","DGRPEIS3",61,0)
 ; Is spouse/dependent address same as patient address?
"RTN","DGRPEIS3",62,0)
 K DIR
"RTN","DGRPEIS3",63,0)
 S DIR(0)="YAO^^"
"RTN","DGRPEIS3",64,0)
 S DIR("A")="STREET ADDRESS SAME AS PATIENT'S: "
"RTN","DGRPEIS3",65,0)
 S DIR("B")="YES"
"RTN","DGRPEIS3",66,0)
 S DIR("?")="Enter 'Y' if the "_$S(SPOUSE:"spouse",1:"child")_" has the same address as the patient, otherwise enter 'N'."
"RTN","DGRPEIS3",67,0)
 D ^DIR
"RTN","DGRPEIS3",68,0)
 S DGVADD=+Y
"RTN","DGRPEIS3",69,0)
 K Y,DIR
"RTN","DGRPEIS3",70,0)
FOREIGN ;tag added for rejoining if country not USA
"RTN","DGRPEIS3",71,0)
 S DGIPIEN=$$SPSCHK^DGRPEIS(DFN)
"RTN","DGRPEIS3",72,0)
 I 'DGVADD,(DGTYPE'="S"),DGIPIEN D
"RTN","DGRPEIS3",73,0)
 . K DIR,Y
"RTN","DGRPEIS3",74,0)
 . S DIR(0)="YAO^^"
"RTN","DGRPEIS3",75,0)
 . S DIR("A")="STREET ADDRESS SAME AS SPOUSE'S: "
"RTN","DGRPEIS3",76,0)
 . S DIR("B")="YES"
"RTN","DGRPEIS3",77,0)
 . S DIR("?")="Enter 'Y' if the child has the same address as the spouse, otherwise enter 'N'."
"RTN","DGRPEIS3",78,0)
 . D ^DIR
"RTN","DGRPEIS3",79,0)
 . S DGSADD=+Y
"RTN","DGRPEIS3",80,0)
 . K Y,DIR
"RTN","DGRPEIS3",81,0)
 ;
"RTN","DGRPEIS3",82,0)
 ; If spouse/dependent address is same as patient's, set spouse/dep address
"RTN","DGRPEIS3",83,0)
 I DGVADD!DGSADD D
"RTN","DGRPEIS3",84,0)
 . I DGVADD D PATASET^DGRPEIS(DFN) ;*Set to Patient address
"RTN","DGRPEIS3",85,0)
 . I DGSADD D SPSASET^DGRPEIS(DGIPIEN) ;*Set to Spouse address
"RTN","DGRPEIS3",86,0)
 . N FLD,FDA S FLD=0 F  S FLD=$O(ANS(FLD)) Q:'FLD  D
"RTN","DGRPEIS3",87,0)
 . . S FDA(408.13,DA_",",FLD)=ANS(FLD) K ANS(FLD)
"RTN","DGRPEIS3",88,0)
 . D FILE^DIE("","FDA","")
"RTN","DGRPEIS3",89,0)
 ;
"RTN","DGRPEIS3",90,0)
 ;Spouse/dep address not same as patient/spouse address; prompt for it
"RTN","DGRPEIS3",91,0)
 I 'DGVADD,'DGSADD D
"RTN","DGRPEIS3",92,0)
 . S DR="1.2;S:X']"""" Y=1.5;1.3;S:X']"""" Y=1.5;1.4;1.5;1.6;1.7;1.8;S UPARROW=1"
"RTN","DGRPEIS3",93,0)
 . K DG,DQ D ^DIE
"RTN","DGRPEIS3",94,0)
 I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) D EDITQ Q
"RTN","DGRPEIS3",95,0)
 ;
"RTN","DGRPEIS3",96,0)
 I DGTYPE'="S" K UPARROW S DIE="^DGPR(408.12,",DA=+DGPREF,DR=".02;S UPARROW=1" K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1)
"RTN","DGRPEIS3",97,0)
 S RELATION=$P($G(^DGPR(408.12,+DGPREF,0)),"^",2)
"RTN","DGRPEIS3",98,0)
 S DGX=$O(^DGPR(408.12,+DGPREF,"E","AID","")),DGMIEN=$O(^(+DGX,0))
"RTN","DGRPEIS3",99,0)
EDACTDT I $G(^DGPR(408.12,+DGPREF,"E",+DGMIEN,0)) D  G:$G(DGFL)<0 EDITQ
"RTN","DGRPEIS3",100,0)
 . S (DGACT,Y)=+^(0) X ^DD("DD")
"RTN","DGRPEIS3",101,0)
 . S DIR("B")=Y
"RTN","DGRPEIS3",102,0)
 . D READ^DGRPEIS2
"RTN","DGRPEIS3",103,0)
 . I -DGACT'=DGX W !,"Use 'Expand Dependent' option to change effective date." H 2 S DGFL=-1 Q
"RTN","DGRPEIS3",104,0)
 . Q:$G(DGFL)<0
"RTN","DGRPEIS3",105,0)
 . S DIE="^DGPR(408.12,"_+DGPREF_",""E"",",DA(1)=+DGPREF,DA=DGMIEN,DR=".01///"_DGACT
"RTN","DGRPEIS3",106,0)
 . D ^DIE
"RTN","DGRPEIS3",107,0)
 I DGTYPE="S" S X=+DGPREF D SETUP^DGRPEIS1
"RTN","DGRPEIS3",108,0)
 K DGACT,DGMIEN,RELATION,DA,DIE,DR,UPARROW,DTOUT,DUOUT,DIRUT
"RTN","DGRPEIS3",109,0)
EDITQ K DA,DIE,DIRUT,DR,DTOUT,DUOUT
"RTN","DGRPEIS3",110,0)
 Q
"RTN","DGRPEIS3",111,0)
 ;
"RTN","DGRPEIS3",112,0)
SSNREA(DGEXIT) ;if SSN is pseudo Pseudo SSN Reason is required - DG*5.3*653
"RTN","DGRPEIS3",113,0)
 N I,EXIT
"RTN","DGRPEIS3",114,0)
 S EXIT=0
"RTN","DGRPEIS3",115,0)
 F  D  Q:EXIT
"RTN","DGRPEIS3",116,0)
 . S DR=$S(DIE["DGPR":.1,1:.0906)_";S UPARROW=1"
"RTN","DGRPEIS3",117,0)
 . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S (EXIT,DGEXIT)=1 Q
"RTN","DGRPEIS3",118,0)
 . I $P($G(@(DIE_DA_",0)")),U,10)']"" S EXIT=0 Q
"RTN","DGRPEIS3",119,0)
 . S EXIT=1
"RTN","DGRPEIS3",120,0)
 Q
"RTN","DGRPEIS3",121,0)
HELP1(DGISDT) ; Displays the help for the active/inactive prompt
"RTN","DGRPEIS3",122,0)
 ;
"RTN","DGRPEIS3",123,0)
 D CLEAR^VALM1
"RTN","DGRPEIS3",124,0)
 W !,"Enter the date this person first became a dependent of the veteran."
"RTN","DGRPEIS3",125,0)
 W !,"In the case of a spouse, this would be the date of marriage.  For"
"RTN","DGRPEIS3",126,0)
 W !,"a child, this would be the date of birth or date of adoption.  For a"
"RTN","DGRPEIS3",127,0)
 W !,"stepchild, this would be the date of marriage to the child's parent."
"RTN","DGRPEIS3",128,0)
 W !!,"Date must be before DEC 31, "_DGISDT_" as dependents are collected for the"
"RTN","DGRPEIS3",129,0)
 W !,"prior calendar year only."
"RTN","DGRPEIS3",130,0)
 S VALMBCK="R"
"RTN","DGRPEIS3",131,0)
 Q
"RTN","DGRPEIS3",132,0)
 ;
"RTN","DGRPEIS3",133,0)
HELPDOB ; * Displays help for Date of Birth
"RTN","DGRPEIS3",134,0)
 N DGRDVAR
"RTN","DGRPEIS3",135,0)
 I X="?" D  Q
"RTN","DGRPEIS3",136,0)
 . W !?5,"Enter the date this dependent was born.  The date must not be during the"
"RTN","DGRPEIS3",137,0)
 . W !?5,"current calendar year.  Only persons that were dependents before the"
"RTN","DGRPEIS3",138,0)
 . W !?5,"current year may be entered.",!
"RTN","DGRPEIS3",139,0)
 . I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
"RTN","DGRPEIS3",140,0)
 ;
"RTN","DGRPEIS3",141,0)
 W !?8,"Enter the date on which this relative was born.  This information is"
"RTN","DGRPEIS3",142,0)
 W !?8,"necessary for use in the income screening and means test portions of"
"RTN","DGRPEIS3",143,0)
 W !?8,"MAS."
"RTN","DGRPEIS3",144,0)
 W !!?8,"The date entered must not be during the current calendar year.  That"
"RTN","DGRPEIS3",145,0)
 W !?8,"is, it must be on or before December 31 or the prior calendar year."
"RTN","DGRPEIS3",146,0)
 I $G(DA) W ! S DIR(0)="E" D ^DIR Q:+Y<1
"RTN","DGRPEIS3",147,0)
 W !!?8,"The reason for this is that this data is used for collecting income"
"RTN","DGRPEIS3",148,0)
 W !?8,"information for the purposes of comparing this data with the Internal"
"RTN","DGRPEIS3",149,0)
 W !?8,"Revenue Service (IRS).  Children born during the calendar year cannot"
"RTN","DGRPEIS3",150,0)
 W !?8,"be entered until next year."
"RTN","DGRPEIS3",151,0)
 I $G(DA) W !!,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
"RTN","DGRPEIS3",152,0)
 Q
"RTN","DGRPEIS3",153,0)
 ;
"RTN","DGRPEIS3",154,0)
HELPMN ; * Displays help for Spouse Maiden Name
"RTN","DGRPEIS3",155,0)
 W !?8,"Enter the spouse's maiden name in 'LAST,FIRST MIDDLE SUFFIX' format."
"RTN","DGRPEIS3",156,0)
 W !?8,"Entry of the LAST name only is permitted and the comma may be omitted."
"RTN","DGRPEIS3",157,0)
 W !?8,"If the response contains no comma, one will be appended to the value."
"RTN","DGRPEIS3",158,0)
 W !?8,"Including the comma, the value must be at least 3 characters in length.",!
"RTN","DGRPEIS3",159,0)
 Q
"RTN","DGRPEIS3",160,0)
 ;
"RTN","DGRPEIS3",161,0)
HELPSA1 ; * Displays help for Street Address 1
"RTN","DGRPEIS3",162,0)
 N DGRELTP
"RTN","DGRPEIS3",163,0)
 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
"RTN","DGRPEIS3",164,0)
 W !,"If a "_DGRELTP_"'s name has been specified, enter the first line of"
"RTN","DGRPEIS3",165,0)
 W !,"that person's street address [3-30 characters]; otherwise this field"
"RTN","DGRPEIS3",166,0)
 W !,"may be left blank.  This field cannot be deleted as long as a "_DGRELTP_"'s"
"RTN","DGRPEIS3",167,0)
 W !,"name is on file."
"RTN","DGRPEIS3",168,0)
 I $G(DA),(X="?") W !
"RTN","DGRPEIS3",169,0)
 Q
"RTN","DGRPEIS3",170,0)
 ;
"RTN","DGRPEIS3",171,0)
HELPSA2 ; * Displays help for Street Address 2
"RTN","DGRPEIS3",172,0)
 N DGRELTP
"RTN","DGRPEIS3",173,0)
 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
"RTN","DGRPEIS3",174,0)
 W !,"If a "_DGRELTP_"'s name has been specified, enter the second line of"
"RTN","DGRPEIS3",175,0)
 W !,"that person's street address [3-30 characters]; otherwise this field"
"RTN","DGRPEIS3",176,0)
 W !,"may be left blank.  This field cannot be deleted as long as a "_DGRELTP_"'s"
"RTN","DGRPEIS3",177,0)
 W !,"name is on file."
"RTN","DGRPEIS3",178,0)
 I $G(DA),(X="?") W !
"RTN","DGRPEIS3",179,0)
 Q
"RTN","DGRPEIS3",180,0)
 ;
"RTN","DGRPEIS3",181,0)
HELPSA3 ; * Displays help for Street Address 3
"RTN","DGRPEIS3",182,0)
 N DGRELTP
"RTN","DGRPEIS3",183,0)
 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
"RTN","DGRPEIS3",184,0)
 W !,"If a "_DGRELTP_"'s name has been specified, enter the third line of"
"RTN","DGRPEIS3",185,0)
 W !,"that person's street address [3-30 characters]; otherwise this field"
"RTN","DGRPEIS3",186,0)
 W !,"may be left blank.  This field cannot be deleted as long as a "_DGRELTP_"'s"
"RTN","DGRPEIS3",187,0)
 W !,"name is on file."
"RTN","DGRPEIS3",188,0)
 I $G(DA),(X="?") W !
"RTN","DGRPEIS3",189,0)
 Q
"RTN","DGRPEIS3",190,0)
 ;
"RTN","DGRPEIS3",191,0)
HELPCITY ; * Displays help for City
"RTN","DGRPEIS3",192,0)
 N DGRELTP
"RTN","DGRPEIS3",193,0)
 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
"RTN","DGRPEIS3",194,0)
 W !,"If a "_DGRELTP_"'s name has been specified, enter the city in which"
"RTN","DGRPEIS3",195,0)
 W !,"that person resides [3-30 characters]; otherwise this field may be"
"RTN","DGRPEIS3",196,0)
 W !,"left blank.  This field cannot be deleted as long as a "_DGRELTP_"'s"
"RTN","DGRPEIS3",197,0)
 W !,"name is on file."
"RTN","DGRPEIS3",198,0)
 I $G(DA),(X="?") W !
"RTN","DGRPEIS3",199,0)
 Q
"RTN","DGRPEIS3",200,0)
 ;
"RTN","DGRPEIS3",201,0)
HELPSTAT ; * Displays help for the state
"RTN","DGRPEIS3",202,0)
 N DGRELTP,DIRA,DGRDVAR,DDIOLARY
"RTN","DGRPEIS3",203,0)
 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
"RTN","DGRPEIS3",204,0)
 S DDIOLARY(1)="If a "_DGRELTP_"'s name has been specified, select the state in which"
"RTN","DGRPEIS3",205,0)
 S DDIOLARY(1,"F")="!"
"RTN","DGRPEIS3",206,0)
 S DDIOLARY(2)="that person resides; otherwise this field may be left blank.  This"
"RTN","DGRPEIS3",207,0)
 S DDIOLARY(2,"F")="!"
"RTN","DGRPEIS3",208,0)
 S DDIOLARY(3)="field cannot be deleted as long as a "_DGRELTP_"'s name is on file."
"RTN","DGRPEIS3",209,0)
 S DDIOLARY(3,"F")="!"
"RTN","DGRPEIS3",210,0)
 S DDIOLARY(4)=""
"RTN","DGRPEIS3",211,0)
 S DDIOLARY(4,"F")="!"
"RTN","DGRPEIS3",212,0)
 D EN^DDIOL(.DDIOLARY)
"RTN","DGRPEIS3",213,0)
 ;
"RTN","DGRPEIS3",214,0)
 Q:X="?"
"RTN","DGRPEIS3",215,0)
 D EN^DDIOL("Enter RETURN to continue:","","!")
"RTN","DGRPEIS3",216,0)
 R DGRDVAR:DTIME
"RTN","DGRPEIS3",217,0)
 Q
"RTN","DGRPEIS3",218,0)
 ;
"RTN","DGRPEIS3",219,0)
HELPZIP ; * Displays help for the Zip code
"RTN","DGRPEIS3",220,0)
 N DGRELTP
"RTN","DGRPEIS3",221,0)
 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
"RTN","DGRPEIS3",222,0)
 W !,"Answer with the 5 digit format (e.g. 12345) or the nine digit"
"RTN","DGRPEIS3",223,0)
 W !,"format (e.g. 12345-6789 or 123456789).  This is related to the"
"RTN","DGRPEIS3",224,0)
 W !,DGRELTP_"'s address."
"RTN","DGRPEIS3",225,0)
 I $G(DA),(X="?") W !
"RTN","DGRPEIS3",226,0)
 Q
"RTN","DGRPEIS3",227,0)
HELPPHON ; * Displays help for the Phone number
"RTN","DGRPEIS3",228,0)
 N DGRELTP
"RTN","DGRPEIS3",229,0)
 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
"RTN","DGRPEIS3",230,0)
 W !,"If a "_DGRELTP_"'s name has been specified, enter the "_DGRELTP_"'s"
"RTN","DGRPEIS3",231,0)
 W !,"phone number [4-20 characters], otherwise this field may be left"
"RTN","DGRPEIS3",232,0)
 W !,"blank.  This field cannot be deleted as long as a "_DGRELTP_"'s"
"RTN","DGRPEIS3",233,0)
 W !,"name is on file."
"RTN","DGRPEIS3",234,0)
 I $G(DA),(X="?") W !
"RTN","DGRPEIS3",235,0)
 Q
"RTN","VADPT")
0^31^B16796389
"RTN","VADPT",1,0)
VADPT ;ALB/MRL/MJK,ERC,TDM - RETURN PATIENT VARIABLE ARRAYS [DRIVER] ; 7/28/09 1:52pm
"RTN","VADPT",2,0)
 ;;5.3;Registration;**193,343,389,415,489,498,688,754**;Aug 13, 1993;Build 46
"RTN","VADPT",3,0)
 ;DFN = Patient IFN [if not passed entire array returned as null]
"RTN","VADPT",4,0)
 ;
"RTN","VADPT",5,0)
DEM ;Demographic Variables
"RTN","VADPT",6,0)
 S VAN=1,VAN(1)=12,VAV="VADM" D ^VADPT0 Q
"RTN","VADPT",7,0)
 ;
"RTN","VADPT",8,0)
OPD ;Other Patient Data
"RTN","VADPT",9,0)
 S VAN=2,VAN(1)=8,VAV="VAPD" D ^VADPT0 Q
"RTN","VADPT",10,0)
 ;
"RTN","VADPT",11,0)
ADD ;Current Address
"RTN","VADPT",12,0)
 S VAN=3,VAN(1)=29,VAV="VAPA" D ^VADPT0 Q
"RTN","VADPT",13,0)
 ;
"RTN","VADPT",14,0)
OAD ;Other Patient Variables
"RTN","VADPT",15,0)
 S VAN=4,VAN(1)=11,VAV="VAOA" D ^VADPT0 Q
"RTN","VADPT",16,0)
 ;
"RTN","VADPT",17,0)
INP ;Inpatient Data [pre-version 5]
"RTN","VADPT",18,0)
 N VAINDTT S VAN=5,VAN(1)=11,VAV="VAIN",VAINDTT=$G(VAINDT) N VAINDT S:VAINDTT VAINDT=$$DATIM(VAINDTT) D ^VADPT0 Q
"RTN","VADPT",19,0)
 ;
"RTN","VADPT",20,0)
IN5 ;Inpatient Data [v5.0 and above]
"RTN","VADPT",21,0)
 N VAINDTT S VAN=6,VAN(1)=19,VAV=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")),VAINDTT=$G(VAIP("D")) S:$L(VAINDTT) VAIP("D")=VAINDTT S:VAINDTT VAIP("D")=$$DATIM(VAINDTT) D ^VADPT0 S:$L(VAINDTT) VAIP("D")=VAINDTT Q
"RTN","VADPT",22,0)
 ;
"RTN","VADPT",23,0)
ELIG ;Eligibility Information
"RTN","VADPT",24,0)
 S VAN=7,VAN(1)=9,VAV="VAEL" D ^VADPT0 Q
"RTN","VADPT",25,0)
 ;
"RTN","VADPT",26,0)
MB ;Monetary Benefits
"RTN","VADPT",27,0)
 S VAN=8,VAN(1)=9,VAV="VAMB" D ^VADPT0 Q
"RTN","VADPT",28,0)
 ;
"RTN","VADPT",29,0)
SVC ;Service Information
"RTN","VADPT",30,0)
 S VAN=9,VAN(1)=14,VAV="VASV" D ^VADPT0 Q
"RTN","VADPT",31,0)
 ;
"RTN","VADPT",32,0)
REG ;Registration data
"RTN","VADPT",33,0)
 S VAN=10,VAV="VARP" D ^VADPT0 Q
"RTN","VADPT",34,0)
 ;
"RTN","VADPT",35,0)
SDE ;Enrollment Information
"RTN","VADPT",36,0)
 S VAN=11,VAV="VAEN" D ^VADPT0 Q
"RTN","VADPT",37,0)
 ;
"RTN","VADPT",38,0)
SDA ;Appointment Information
"RTN","VADPT",39,0)
 S VAN=12,VAV="VASD" D ^VADPT0 Q
"RTN","VADPT",40,0)
 ;
"RTN","VADPT",41,0)
PID ;Patient Id
"RTN","VADPT",42,0)
 S VAN=13,VAV="VA" D ^VADPT0 Q
"RTN","VADPT",43,0)
 ;
"RTN","VADPT",44,0)
TESTPAT(DFN)    ;Test patient ?  Returns 0 (No) or 1 (Yes)
"RTN","VADPT",45,0)
 S DFN=+$G(DFN) I 'DFN Q 0
"RTN","VADPT",46,0)
 I $D(^DPT("ATEST",DFN)) Q 1
"RTN","VADPT",47,0)
 N NODE S NODE=$G(^DPT(DFN,0))
"RTN","VADPT",48,0)
 I $P(NODE,"^",21)=1 Q 1
"RTN","VADPT",49,0)
 I $E($P(NODE,"^",9),1,5)="00000" Q 1
"RTN","VADPT",50,0)
 Q 0
"RTN","VADPT",51,0)
 ;
"RTN","VADPT",52,0)
V5 S X=$S($D(^DG(43,1,"VERSION")):+^("VERSION"),1:""),VADPT("V")=$S(X<5:0,1:1) K X Q
"RTN","VADPT",53,0)
OERR ;
"RTN","VADPT",54,0)
1 S VATAG=1 D MULT Q
"RTN","VADPT",55,0)
2 S VATAG=2 D MULT Q
"RTN","VADPT",56,0)
3 S VATAG=3 D MULT Q
"RTN","VADPT",57,0)
4 S VATAG=4 D MULT Q
"RTN","VADPT",58,0)
5 S VATAG=5 D MULT Q
"RTN","VADPT",59,0)
6 S VATAG=6 D MULT Q
"RTN","VADPT",60,0)
7 S VATAG=7 D MULT Q
"RTN","VADPT",61,0)
8 S VATAG=8 D MULT Q
"RTN","VADPT",62,0)
9 S VATAG=9 D MULT Q
"RTN","VADPT",63,0)
10 S VATAG=10 D MULT Q
"RTN","VADPT",64,0)
51 S VATAG=11 D MULT Q
"RTN","VADPT",65,0)
52 S VATAG=12 D MULT Q
"RTN","VADPT",66,0)
53 S VATAG=13 D MULT Q
"RTN","VADPT",67,0)
ALL S VATAG=14 D MULT Q
"RTN","VADPT",68,0)
A5 S VATAG=15 D MULT Q
"RTN","VADPT",69,0)
SEL Q:$O(VARRAY(0))']""  S VATAG=0,VATAG(2)=$P($T(TAG),";;",2)
"RTN","VADPT",70,0)
 F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG=""  I VATAG(2)[("^"_VATAG_"^") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT(VATAG),1:"") D @VATAG
"RTN","VADPT",71,0)
 G Q
"RTN","VADPT",72,0)
 ;
"RTN","VADPT",73,0)
MULT S VATAG=$P($T(TG+VATAG),";;",2)
"RTN","VADPT",74,0)
 F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,"^",VATAG(1)) Q:VATAG(2)=""  S VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"") D @(VATAG(2))
"RTN","VADPT",75,0)
Q S VAROOT="" K:$D(VAROOT)'=11 VAROOT K VATAG Q
"RTN","VADPT",76,0)
 ;
"RTN","VADPT",77,0)
KVA K VA
"RTN","VADPT",78,0)
KVAR D KVAR^VADPT0 K:$D(VAIP("V")) @(VAIP("V")) K I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY("VADPT",$J),VA200,VATEST Q
"RTN","VADPT",79,0)
DATIM(DATIM) ;If time not specified see if movement on that date
"RTN","VADPT",80,0)
 Q:DATIM'?7N DATIM
"RTN","VADPT",81,0)
 N A,B S A=$O(^DGPM("ADFN"_DFN,DATIM)),B=+$O(^(+A,0))
"RTN","VADPT",82,0)
 I 'A Q DATIM
"RTN","VADPT",83,0)
 I $P($G(^DGPM(+B,0)),"^",2)=3 Q DATIM  ;Next movement is discharge
"RTN","VADPT",84,0)
 F  Q:"^4^5^7^"'[(U_$P($G(^DGPM(+B,0)),"^",2))  S A=$O(^DGPM("ADFN"_DFN,A)),B=+$O(^(+A,0)) I $E(A,1,7)'=DATIM Q
"RTN","VADPT",85,0)
 I 'A Q DATIM
"RTN","VADPT",86,0)
 I $E(A,1,7)'=DATIM Q DATIM
"RTN","VADPT",87,0)
 Q A
"RTN","VADPT",88,0)
 ;
"RTN","VADPT",89,0)
TG ;
"RTN","VADPT",90,0)
 ;;DEM^INP
"RTN","VADPT",91,0)
 ;;DEM^ELIG
"RTN","VADPT",92,0)
 ;;ELIG^INP
"RTN","VADPT",93,0)
 ;;DEM^ADD
"RTN","VADPT",94,0)
 ;;ADD^INP
"RTN","VADPT",95,0)
 ;;DEM^ELIG^ADD
"RTN","VADPT",96,0)
 ;;ELIG^SVC
"RTN","VADPT",97,0)
 ;;ELIG^SVC^MB
"RTN","VADPT",98,0)
 ;;DEM^REG^SDE^SDA
"RTN","VADPT",99,0)
 ;;SDE^SDA
"RTN","VADPT",100,0)
 ;;DEM^IN5
"RTN","VADPT",101,0)
 ;;ELIG^IN5
"RTN","VADPT",102,0)
 ;;ADD^IN5
"RTN","VADPT",103,0)
 ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA
"RTN","VADPT",104,0)
 ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA
"RTN","VADPT",105,0)
 ;
"RTN","VADPT",106,0)
TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^
"RTN","VADPT0")
0^32^B13592370
"RTN","VADPT0",1,0)
VADPT0 ;ALB/MRL/MJK,ERC,TDM - PATIENT VARIABLE ROUTINE DRIVER, CONT. ; 9/24/09 5:30pm
"RTN","VADPT0",2,0)
 ;;5.3;Registration;**343,342,415,489,498,528,689,789,688,759,754**;Aug 13, 1993;Build 46
"RTN","VADPT0",3,0)
 ;
"RTN","VADPT0",4,0)
 ;Initialize variables
"RTN","VADPT0",5,0)
 N I1
"RTN","VADPT0",6,0)
 S U="^" D DT^DICRW:'$D(DT)
"RTN","VADPT0",7,0)
 S VAERR=$S($G(DFN)="":1,'$D(^DPT(DFN,0)):1,1:0)
"RTN","VADPT0",8,0)
 S Y=VAN'=13 I Y,$D(VAROOT)'[0,VAROOT]"" S Y=0,VAV=VAROOT K @VAV
"RTN","VADPT0",9,0)
 I Y S:$S(VAN>9:1,'$D(VAHOW):0,1:VAHOW[2) VAV="^UTILITY("_""""_VAV_""""_","_$J_")"
"RTN","VADPT0",10,0)
 D @VAN
"RTN","VADPT0",11,0)
Q K X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ Q
"RTN","VADPT0",12,0)
 ;
"RTN","VADPT0",13,0)
INIT ; -- determine #'s or names then init array
"RTN","VADPT0",14,0)
 ;
"RTN","VADPT0",15,0)
 S VAS="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^26^27^28^29"
"RTN","VADPT0",16,0)
 I VAN<10,$D(VAHOW),VAHOW[1 S VAS=$P($T(SS+VAN),";;",2)
"RTN","VADPT0",17,0)
 I $D(VAN(1)) F I=1:1:VAN(1) S @VAV@($P(VAS,"^",I))=""
"RTN","VADPT0",18,0)
 Q
"RTN","VADPT0",19,0)
 ;
"RTN","VADPT0",20,0)
1 ; -- [DEM] demos 
"RTN","VADPT0",21,0)
 D C1,INIT I 'VAERR D 1^VADPT1,13 Q
"RTN","VADPT0",22,0)
 ;
"RTN","VADPT0",23,0)
2 ; -- [OPD] other pt vars
"RTN","VADPT0",24,0)
 D C2,INIT,2^VADPT1:'VAERR Q
"RTN","VADPT0",25,0)
 ;
"RTN","VADPT0",26,0)
3 ; -- [ADD] current address
"RTN","VADPT0",27,0)
 D C3,INIT,3^VADPT1:'VAERR Q
"RTN","VADPT0",28,0)
 ;
"RTN","VADPT0",29,0)
4 ; -- [OAD] other pt vars
"RTN","VADPT0",30,0)
 D C4,INIT,4^VADPT1:'VAERR Q
"RTN","VADPT0",31,0)
 ;
"RTN","VADPT0",32,0)
5 ; -- [INP] inpt data -v5
"RTN","VADPT0",33,0)
 D C5,INIT,5^VADPT2:'VAERR Q
"RTN","VADPT0",34,0)
 ;
"RTN","VADPT0",35,0)
6 ; -- [IN5] inpt data v5
"RTN","VADPT0",36,0)
 D C6,INIT F I=13:1:17 F I1=1:1:7 S @VAV@($P(VAS,"^",I),I1)=""
"RTN","VADPT0",37,0)
 F I=1:1:3 S @VAV@($P(VAS,"^",19),I)=""
"RTN","VADPT0",38,0)
 D 6^VADPT3:'VAERR Q
"RTN","VADPT0",39,0)
 ;
"RTN","VADPT0",40,0)
7 ; -- [ELIG] elig data
"RTN","VADPT0",41,0)
 D C7,INIT F I=1:1:6 S @VAV@($P(VAS,"^",5),I)=""
"RTN","VADPT0",42,0)
 D 7^VADPT4:'VAERR Q
"RTN","VADPT0",43,0)
 ;
"RTN","VADPT0",44,0)
8 ; -- [MB] $ benefits
"RTN","VADPT0",45,0)
 D C8,INIT D 8^VADPT4:'VAERR Q
"RTN","VADPT0",46,0)
 ;
"RTN","VADPT0",47,0)
9 ; -- [SVC] service data
"RTN","VADPT0",48,0)
 D C9,INIT F I=1:1:9 S @VAV@($P(VAS,"^",I),1)="",@VAV@($P(VAS,"^",I),2)=""
"RTN","VADPT0",49,0)
 S @VAV@($P(VAS,"^",10),1)=""
"RTN","VADPT0",50,0)
 F I=11:1:13 S @VAV@($P(VAS,"^",I))=0
"RTN","VADPT0",51,0)
 S @VAV@($P(VAS,"^",14),1)=""
"RTN","VADPT0",52,0)
 S @VAV@($P(VAS,"^",4),3)="",@VAV@($P(VAS,"^",5),3)=""
"RTN","VADPT0",53,0)
 F I=2,6,7,8 F I1=3,4,5 S @VAV@($P(VAS,"^",I),I1)=""
"RTN","VADPT0",54,0)
 D 9^VADPT4:'VAERR Q
"RTN","VADPT0",55,0)
 ;
"RTN","VADPT0",56,0)
10 ; -- [REG] registration data
"RTN","VADPT0",57,0)
 D C10,INIT D 10^VADPT5:'VAERR Q
"RTN","VADPT0",58,0)
 ;
"RTN","VADPT0",59,0)
11 ; -- [SDE] clinic enrollment data
"RTN","VADPT0",60,0)
 D C11,INIT D 11^VADPT5:'VAERR Q
"RTN","VADPT0",61,0)
 ;
"RTN","VADPT0",62,0)
12 ; -- [SDA] appt data
"RTN","VADPT0",63,0)
 D C12,INIT D 12^VADPT5:'VAERR Q
"RTN","VADPT0",64,0)
 ;
"RTN","VADPT0",65,0)
13 ; -- [PID] pt id's
"RTN","VADPT0",66,0)
 S (VA("PID"),VA("BID"))="" D 13^VADPT6:'VAERR Q
"RTN","VADPT0",67,0)
 ;
"RTN","VADPT0",68,0)
KVAR ; kill all vadpt data
"RTN","VADPT0",69,0)
 K VAN
"RTN","VADPT0",70,0)
C1 K ^UTILITY("VADM",$J),VADM Q:$D(VAN)
"RTN","VADPT0",71,0)
C2 K ^UTILITY("VAPD",$J),VAPD Q:$D(VAN)
"RTN","VADPT0",72,0)
C3 K X S:$D(VAPA("P")) X("P")=VAPA("P")
"RTN","VADPT0",73,0)
 S:$D(VAPA("CD")) X("CD")=VAPA("CD")
"RTN","VADPT0",74,0)
 K ^UTILITY("VAPA",$J),VAPA
"RTN","VADPT0",75,0)
 S:$D(X("P")) VAPA("P")=X("P") K X("P")
"RTN","VADPT0",76,0)
 S:$D(X("CD")) VAPA("CD")=X("CD") K X Q:$D(VAN)
"RTN","VADPT0",77,0)
C4 K X S:$D(VAOA("A")) X("A")=VAOA("A")
"RTN","VADPT0",78,0)
 K ^UTILITY("VAOA",$J),VAOA
"RTN","VADPT0",79,0)
 S:$D(X("A")) VAOA("A")=X("A") K X Q:$D(VAN)
"RTN","VADPT0",80,0)
C5 K ^UTILITY("VAIN",$J),VAIN Q:$D(VAN)
"RTN","VADPT0",81,0)
C6 K X F I="D","E","L","M","V" I $D(VAIP(I)) S X(I)=VAIP(I)
"RTN","VADPT0",82,0)
 S Y=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")) K ^UTILITY(Y,$J),@Y
"RTN","VADPT0",83,0)
 F I="D","E","L","M","V" I $D(X(I)) S VAIP(I)=X(I)
"RTN","VADPT0",84,0)
 K X Q:$D(VAN)
"RTN","VADPT0",85,0)
C7 K ^UTILITY("VAEL",$J),VAEL Q:$D(VAN)
"RTN","VADPT0",86,0)
C8 K ^UTILITY("VAMB",$J),VAMB Q:$D(VAN)
"RTN","VADPT0",87,0)
C9 K ^UTILITY("VASV",$J),VASV Q:$D(VAN)
"RTN","VADPT0",88,0)
C10 K ^UTILITY("VARP",$J) Q:$D(VAN)
"RTN","VADPT0",89,0)
C11 K ^UTILITY("VAEN",$J) Q:$D(VAN)
"RTN","VADPT0",90,0)
C12 K ^UTILITY("VASD",$J) Q
"RTN","VADPT0",91,0)
C13 Q
"RTN","VADPT0",92,0)
 ;
"RTN","VADPT0",93,0)
SS ;  1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^26^27^28
"RTN","VADPT0",94,0)
 ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS^ET^RC
"RTN","VADPT0",95,0)
 ;;BC^BS^FN^MN^MM^OC^ES^WP
"RTN","VADPT0",96,0)
 ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE^Z4^CCA^CL1^CL2^CL3^CCI^CST^CZP^CCO^CCS^CCE^CTY^PR^PC^CT^CPR^CPC^CCT^CPN
"RTN","VADPT0",97,0)
 ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE^Z4
"RTN","VADPT0",98,0)
 ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT^AP
"RTN","VADPT0",99,0)
 ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN^AP^FD
"RTN","VADPT0",100,0)
 ;;EL^PS^SC^VT^IN^TY^CN^ES^MT
"RTN","VADPT0",101,0)
 ;;AA^HB^SS^PE^MR^SI^DI^OR^GI
"RTN","VADPT0",102,0)
 ;;VN^AO^IR^PW^CS^S1^S2^S3^PH^CV^OIF^OEF^UNK^SHD
"RTN","VADPT1")
0^33^B44162439
"RTN","VADPT1",1,0)
VADPT1 ;ALB/MRL/MJK,ERC,TDM - PATIENT VARIABLES ; 7/28/09 1:54pm
"RTN","VADPT1",2,0)
 ;;5.3;Registration;**415,489,516,614,688,754**;Aug 13, 1993;Build 46
"RTN","VADPT1",3,0)
1 ;Demographic [DEM]
"RTN","VADPT1",4,0)
 N W,Z,NODE
"RTN","VADPT1",5,0)
 ;
"RTN","VADPT1",6,0)
 ; -- name [1 - NM]
"RTN","VADPT1",7,0)
 S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^")
"RTN","VADPT1",8,0)
 ;
"RTN","VADPT1",9,0)
 ; -- ssn [2 - SS]
"RTN","VADPT1",10,0)
 S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"")
"RTN","VADPT1",11,0)
 ;
"RTN","VADPT1",12,0)
 ; -- date of birth [2 - DB]
"RTN","VADPT1",13,0)
 S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y
"RTN","VADPT1",14,0)
 ;
"RTN","VADPT1",15,0)
 ; -- age [4 - AG]
"RTN","VADPT1",16,0)
 S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
"RTN","VADPT1",17,0)
 ;
"RTN","VADPT1",18,0)
 ; -- expired date [6 - EX]
"RTN","VADPT1",19,0)
 S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y
"RTN","VADPT1",20,0)
 ;
"RTN","VADPT1",21,0)
 ; -- sex [5 - SX]
"RTN","VADPT1",22,0)
 S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z
"RTN","VADPT1",23,0)
 ;
"RTN","VADPT1",24,0)
 ; -- remarks [7 - RE]
"RTN","VADPT1",25,0)
 S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10)
"RTN","VADPT1",26,0)
 ;
"RTN","VADPT1",27,0)
 ; -- historic race [8 - RA]
"RTN","VADPT1",28,0)
 S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"")
"RTN","VADPT1",29,0)
 ;
"RTN","VADPT1",30,0)
 ; -- religion [9 - RP]
"RTN","VADPT1",31,0)
 S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"")
"RTN","VADPT1",32,0)
 ;
"RTN","VADPT1",33,0)
 ; -- marital status [10 - MS]
"RTN","VADPT1",34,0)
 S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"")
"RTN","VADPT1",35,0)
 ;
"RTN","VADPT1",36,0)
 ; -- ethnicity [11 - ET]
"RTN","VADPT1",37,0)
 S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X  D
"RTN","VADPT1",38,0)
 .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D
"RTN","VADPT1",39,0)
 ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1)
"RTN","VADPT1",40,0)
 ..; -- collection method
"RTN","VADPT1",41,0)
 ..S Z=$P(NODE,"^",2) I Z D
"RTN","VADPT1",42,0)
 ...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
"RTN","VADPT1",43,0)
 S @VAV@($P(VAS,"^",11))=Y-1
"RTN","VADPT1",44,0)
 ;
"RTN","VADPT1",45,0)
 ; -- race [12 - RC]
"RTN","VADPT1",46,0)
 S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X  D
"RTN","VADPT1",47,0)
 .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D
"RTN","VADPT1",48,0)
 ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1)
"RTN","VADPT1",49,0)
 ..; -- collection method
"RTN","VADPT1",50,0)
 ..S Z=$P(NODE,"^",2) I Z D
"RTN","VADPT1",51,0)
 ...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
"RTN","VADPT1",52,0)
 S @VAV@($P(VAS,"^",12))=Y-1
"RTN","VADPT1",53,0)
 Q
"RTN","VADPT1",54,0)
 ;
"RTN","VADPT1",55,0)
2 ;Other Patient Variables [OPD]
"RTN","VADPT1",56,0)
 N W,Z
"RTN","VADPT1",57,0)
 S VAX=^DPT(DFN,0)
"RTN","VADPT1",58,0)
 ;
"RTN","VADPT1",59,0)
 ; -- city of birth [1 - BC]
"RTN","VADPT1",60,0)
 S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11)
"RTN","VADPT1",61,0)
 ;
"RTN","VADPT1",62,0)
 ; -- state of birth [2 - BS]
"RTN","VADPT1",63,0)
 S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"")
"RTN","VADPT1",64,0)
 ;
"RTN","VADPT1",65,0)
 ; -- occupation [6 - OC]
"RTN","VADPT1",66,0)
 S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7)
"RTN","VADPT1",67,0)
 ;
"RTN","VADPT1",68,0)
 ; -- names
"RTN","VADPT1",69,0)
 S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"")
"RTN","VADPT1",70,0)
 S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's        [3 - FN]
"RTN","VADPT1",71,0)
 S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's        [4 - MN]
"RTN","VADPT1",72,0)
 S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM]
"RTN","VADPT1",73,0)
 ;
"RTN","VADPT1",74,0)
 ; -- employment status [7 - ES]
"RTN","VADPT1",75,0)
 S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
"RTN","VADPT1",76,0)
 S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"")
"RTN","VADPT1",77,0)
 ;
"RTN","VADPT1",78,0)
 ; -- PHONE NUMBER [WORK] [8 - WP]
"RTN","VADPT1",79,0)
 I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",2)
"RTN","VADPT1",80,0)
 Q
"RTN","VADPT1",81,0)
 ;
"RTN","VADPT1",82,0)
3 ;Address [ADD]
"RTN","VADPT1",83,0)
 N VAFOR
"RTN","VADPT1",84,0)
 S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
"RTN","VADPT1",85,0)
 I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)<VAEND) S VAX=$S($D(^DPT(DFN,.11)):^(.11),1:""),VAX(1)=0
"RTN","VADPT1",86,0)
 E  S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""),VAX(1)=1
"RTN","VADPT1",87,0)
 ;set the foreign address fields into local variables for later
"RTN","VADPT1",88,0)
 I 'VAX(1) S VAFOR=$P(VAX,U,8,10)
"RTN","VADPT1",89,0)
 I VAX(1) D
"RTN","VADPT1",90,0)
 . I '$D(^DPT(DFN,.122)) S VAFOR="" Q
"RTN","VADPT1",91,0)
 . S VAFOR=$P(^DPT(DFN,.122),U,1,3)
"RTN","VADPT1",92,0)
 F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I))=VAZ I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",5))=@VAV@($P(VAS,"^",5))_"^"_VAZ
"RTN","VADPT1",93,0)
 S VAZ=$S('VAX(1):$P(VAX,"^",7),1:$P(VAX,"^",11)) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",7))=VAZ
"RTN","VADPT1",94,0)
 S VAZIP4=$P(VAX,U,12)
"RTN","VADPT1",95,0)
 S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
"RTN","VADPT1",96,0)
 ;DG*5.3*516
"RTN","VADPT1",97,0)
 I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",1)
"RTN","VADPT1",98,0)
 ;foreign address fields
"RTN","VADPT1",99,0)
 F I=1:1:3 S VAZ=$P(VAFOR,U,I) S @VAV@($P(VAS,U,I+22))=VAZ
"RTN","VADPT1",100,0)
 ;
"RTN","VADPT1",101,0)
 I $P($G(VAFOR),U,3)]"" D
"RTN","VADPT1",102,0)
 . S VACNTRY=$P(VAFOR,U,3)
"RTN","VADPT1",103,0)
 . S VACNTRY=$$CNTRYI^DGADDUTL(VACNTRY)
"RTN","VADPT1",104,0)
 . S $P(@VAV@($P(VAS,U,25)),U,2)=VACNTRY
"RTN","VADPT1",105,0)
 I 'VAX(1) G CA
"RTN","VADPT1",106,0)
 S @VAV@($P(VAS,"^",8))=$P(VAX,"^",10)
"RTN","VADPT1",107,0)
 F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+2))=VAZ_"^"_Y
"RTN","VADPT1",108,0)
CA ;Confidential Address
"RTN","VADPT1",109,0)
 I '$D(^DPT(DFN,.141)) G Q3
"RTN","VADPT1",110,0)
 N VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
"RTN","VADPT1",111,0)
 S VAX=$S($D(^DPT(DFN,.141)):^(.141),1:"")
"RTN","VADPT1",112,0)
 S VAACTDT=$S($D(VAPA("CD")):VAPA("CD"),1:DT)
"RTN","VADPT1",113,0)
 F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I+12))=VAZ D
"RTN","VADPT1",114,0)
 .I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_VAZ Q
"RTN","VADPT1",115,0)
 .I I=6,($G(VAZ)]"") S @VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_$S(($L(VAZ)=5):VAZ,1:$E(VAZ,1,5)_"-"_$E(VAZ,6,9))
"RTN","VADPT1",116,0)
 S VAZ=$P(VAX,"^",11) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",19))=VAZ
"RTN","VADPT1",117,0)
 F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+13))=VAZ_"^"_Y
"RTN","VADPT1",118,0)
 S VABEG=$P(VAX,"^",7),VAEND=$P(VAX,"^",8)
"RTN","VADPT1",119,0)
 S @VAV@($P(VAS,"^",12))=1
"RTN","VADPT1",120,0)
 I 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT)) S @VAV@($P(VAS,"^",12))=0
"RTN","VADPT1",121,0)
 I $D(^DPT(DFN,.14)) D
"RTN","VADPT1",122,0)
 .S VACAN="" F  S VACAN=$O(^DPT(DFN,.14,VACAN)) Q:VACAN=""  D
"RTN","VADPT1",123,0)
 ..Q:'$D(^DPT(DFN,.14,VACAN,0))
"RTN","VADPT1",124,0)
 ..S VATYP=$P(^DPT(DFN,.14,VACAN,0),"^",1),VAACT=$P(^DPT(DFN,.14,VACAN,0),"^",2)
"RTN","VADPT1",125,0)
 ..S VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
"RTN","VADPT1",126,0)
 ..S VATYPNAM="" F I=1:1 S VATYPNAM=$P(VACAT,";",I) Q:VATYPNAM=""  D
"RTN","VADPT1",127,0)
 ...I +VATYPNAM[VATYP S VATYPNAM=$P(VATYPNAM,":",2),@VAV@($P(VAS,"^",22),VATYP)=VATYP_"^"_VATYPNAM_"^"_VAACT
"RTN","VADPT1",128,0)
 ;foreign address fields for the confidential address
"RTN","VADPT1",129,0)
 F I=1:1:3 S @VAV@($P(VAS,U,I+25))=$P(VAX,U,I+13)
"RTN","VADPT1",130,0)
 I @VAV@($P(VAS,U,28))]"" D
"RTN","VADPT1",131,0)
 . I '$D(^HL(779.004,$P(VAX,U,16),0)) Q
"RTN","VADPT1",132,0)
 . S $P(@VAV@($P(VAS,U,28)),U,2)=$$CNTRYI^DGADDUTL($P(VAX,U,16))
"RTN","VADPT1",133,0)
 ; -- CONFIDENTIAL PHONE NUMBER [29 - CPN]
"RTN","VADPT1",134,0)
 I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",29))=$P(^(.13),"^",15)
"RTN","VADPT1",135,0)
Q3 K VABEG,VAEND,VAZIP4 Q
"RTN","VADPT1",136,0)
 ;
"RTN","VADPT1",137,0)
4 ;Other Address [OAD]
"RTN","VADPT1",138,0)
 N VAZIP4
"RTN","VADPT1",139,0)
 I $S('$D(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0) S VAX=.21,VAOA("A")=7
"RTN","VADPT1",140,0)
 E  S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A"))
"RTN","VADPT1",141,0)
 S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99)
"RTN","VADPT1",142,0)
 S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
"RTN","VADPT1",143,0)
 S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8
"RTN","VADPT1",144,0)
 F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
"RTN","VADPT1",145,0)
 I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))=""
"RTN","VADPT1",146,0)
 S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1)
"RTN","VADPT1",147,0)
 S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A"))
"RTN","VADPT1",148,0)
 S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
"RTN","VADPT1",149,0)
 Q
"RTN","VAFCQRY3")
0^34^B59042687
"RTN","VAFCQRY3",1,0)
VAFCQRY3 ;BIR/CMC,CKN-CONT TO BLD PID 2.4 SEGMENT ; 8/21/09 4:45pm
"RTN","VAFCQRY3",2,0)
 ;;5.3;Registration;**575,707,754**;Aug 13, 1993;Build 46
"RTN","VAFCQRY3",3,0)
 ;
"RTN","VAFCQRY3",4,0)
CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP,SSN,VAFCMN) ; continue to bld pid segment
"RTN","VAFCQRY3",5,0)
ADDR ;had to split routine
"RTN","VAFCQRY3",6,0)
 I $D(SARY(11))!(SEQ="ALL") S APID(12)="" D
"RTN","VAFCQRY3",7,0)
 .I $D(^DPT(DFN,0)) D
"RTN","VAFCQRY3",8,0)
 ..;address info
"RTN","VAFCQRY3",9,0)
 ..N COUNTY K HL7STRG
"RTN","VAFCQRY3",10,0)
 ..S HL7STRG=$$GET1^DIQ(2,DFN_",",.111) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
"RTN","VAFCQRY3",11,0)
 ..S $P(APID(12),COMP)=HL7STRG I $P(APID(12),COMP)="" S $P(APID(12),COMP)=HL("Q") K HL7STRG
"RTN","VAFCQRY3",12,0)
 ..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.112) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
"RTN","VAFCQRY3",13,0)
 ..S $P(APID(12),COMP,2)=HL7STRG I $P(APID(12),COMP,2)="" S $P(APID(12),COMP,2)=HL("Q")
"RTN","VAFCQRY3",14,0)
 ..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.113) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
"RTN","VAFCQRY3",15,0)
 ..S $P(APID(12),COMP,8)=HL7STRG I $P(APID(12),COMP,8)="" S $P(APID(12),COMP,8)=HL("Q")
"RTN","VAFCQRY3",16,0)
 ..K HL7STRG
"RTN","VAFCQRY3",17,0)
 ..; **707 changes to include foreign address
"RTN","VAFCQRY3",18,0)
 ..N CNTRY S CNTRY=$$GET1^DIQ(2,DFN_",",.1173) ;RETURN EXTERNAL VALUE from country code file #779.004 field .01
"RTN","VAFCQRY3",19,0)
 ..I CNTRY="US" S CNTRY="USA"
"RTN","VAFCQRY3",20,0)
 ..S HL7STRG=$$GET1^DIQ(2,DFN_",",.114) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(APID(12),COMP,3)=HL7STRG  I $P(APID(12),COMP,3)="" S $P(APID(12),COMP,3)=HL("Q")
"RTN","VAFCQRY3",21,0)
 ..I CNTRY=""!(CNTRY="USA") D
"RTN","VAFCQRY3",22,0)
 ...;have USA address
"RTN","VAFCQRY3",23,0)
 ...S STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I") S $P(APID(12),COMP,4)=$$GET1^DIQ(5,+STATEIEN_",",1)
"RTN","VAFCQRY3",24,0)
 ...I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q")
"RTN","VAFCQRY3",25,0)
 ...S $P(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q")
"RTN","VAFCQRY3",26,0)
 ...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;country
"RTN","VAFCQRY3",27,0)
 ..I CNTRY'="",(CNTRY'="USA") D
"RTN","VAFCQRY3",28,0)
 ...;Check for foreign address fields
"RTN","VAFCQRY3",29,0)
 ...S $P(APID(12),COMP,4)=$P($G(^DPT(DFN,.11)),"^",8) I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q") ;province
"RTN","VAFCQRY3",30,0)
 ...S $P(APID(12),COMP,5)=$P($G(^DPT(DFN,.11)),"^",9) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q") ;postal code
"RTN","VAFCQRY3",31,0)
 ...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;COUNTRY
"RTN","VAFCQRY3",32,0)
 ...; ***707 end of code
"RTN","VAFCQRY3",33,0)
 ..S $P(APID(12),COMP,7)="P"
"RTN","VAFCQRY3",34,0)
BADADDR ..;BAD ADDRESS INDICATOR (if present overwrite the "P" ermanent type with the Bad Address type
"RTN","VAFCQRY3",35,0)
 ..I $D(^DPT(DFN,.11)) N BADADR S BADADR=$P(^DPT(DFN,.11),"^",16) I BADADR'="" S $P(APID(12),COMP,7)="VAB"_BADADR
"RTN","VAFCQRY3",36,0)
 ..S COUNTY=$$GET1^DIQ(2,DFN_",",.117) I COUNTY="" S COUNTY=HL("Q") ;**648 add COUNTY Code to PID-11, retained in PID-12 also
"RTN","VAFCQRY3",37,0)
 ..S $P(APID(12),COMP,9)=COUNTY ;county code
"RTN","VAFCQRY3",38,0)
 ..;place of birth information
"RTN","VAFCQRY3",39,0)
 ..S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG D
"RTN","VAFCQRY3",40,0)
 ...N X
"RTN","VAFCQRY3",41,0)
 ...I $G(CITY)'="" S $P(X,COMP,3)=CITY
"RTN","VAFCQRY3",42,0)
 ...I $G(CITY)="" S $P(X,COMP,3)=HL("Q")
"RTN","VAFCQRY3",43,0)
 ...S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
"RTN","VAFCQRY3",44,0)
 ....I $G(STATE)'="" S $P(X,COMP,4)=STATE
"RTN","VAFCQRY3",45,0)
 ....I $G(STATE)="" S $P(X,COMP,4)=HL("Q")
"RTN","VAFCQRY3",46,0)
 ... S $P(X,COMP,7)="N",APID(12)=$G(APID(12))_REP_X
"RTN","VAFCQRY3",47,0)
CONF .;CONFIDENTIAL ADDRESS
"RTN","VAFCQRY3",48,0)
 .I $D(^DPT(DFN,.141)) N CNFADD S CNFADD=$$GET1^DIQ(2,DFN_",",.14105) D
"RTN","VAFCQRY3",49,0)
 ..N LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,CNFEND,CNFSTRT,SUBCOMP,CNTY,CITY
"RTN","VAFCQRY3",50,0)
 ..S SUBCOMP=$E(HL("ECH"),4)
"RTN","VAFCQRY3",51,0)
 ..S LINE1=$$GET1^DIQ(2,DFN_",",.1411) S HL7STRG=LINE1 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE1=HL7STRG
"RTN","VAFCQRY3",52,0)
 ..S LINE2=$$GET1^DIQ(2,DFN_",",.1412) S HL7STRG=LINE2 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE2=HL7STRG
"RTN","VAFCQRY3",53,0)
 ..S LINE3=$$GET1^DIQ(2,DFN_",",.1413) S HL7STRG=LINE3 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE3=HL7STRG
"RTN","VAFCQRY3",54,0)
 ..S CNFSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1417,"I")),CNFEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1418,"I"))
"RTN","VAFCQRY3",55,0)
 ..S CITY=$$GET1^DIQ(2,DFN_",",.1414) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
"RTN","VAFCQRY3",56,0)
 ..S CNTRY=$$GET1^DIQ(2,DFN_",",.14116)
"RTN","VAFCQRY3",57,0)
 ..;if foriegn address
"RTN","VAFCQRY3",58,0)
 ..I CNTRY=""!(CNTRY="USA")!(CNTRY="US") S:CNTRY="US" CNTRY="USA" S STATEIEN=$$GET1^DIQ(2,DFN_",",.1415,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1),CNTY=$$GET1^DIQ(2,DFN_",",.14111),ZIP=$$GET1^DIQ(2,DFN_",",.1416)
"RTN","VAFCQRY3",59,0)
 ..E  S STATE=$$GET1^DIQ(2,DFN_",",.14114),ZIP=$$GET1^DIQ(2,DFN_",",.14115)  ;if USA address or null assume USA address
"RTN","VAFCQRY3",60,0)
 ..S LVL=0,LNGTH=$L(APID(12))
"RTN","VAFCQRY3",61,0)
 ..I $D(^DPT(DFN,.14,0)) N CNFTYP S CNFTYP=0 F  S CNFTYP=$O(^DPT(DFN,.14,CNFTYP)) Q:'CNFTYP  N CNFTYPA S CNFTYPA=$P(^DPT(DFN,.14,CNFTYP,0),"^",2) I CNFTYPA="Y" S CNFTYPA=$P(^DPT(DFN,.14,CNFTYP,0),"^") D
"RTN","VAFCQRY3",62,0)
 ...S NXT=""
"RTN","VAFCQRY3",63,0)
 ...S $P(NXT,COMP)=$S(LINE1'="":LINE1,1:HL("Q"))
"RTN","VAFCQRY3",64,0)
 ...S $P(NXT,COMP,2)=$S(LINE2'="":LINE2,1:HL("Q"))
"RTN","VAFCQRY3",65,0)
 ...S $P(NXT,COMP,8)=$S(LINE3'="":LINE3,1:HL("Q"))
"RTN","VAFCQRY3",66,0)
 ...S $P(NXT,COMP,3)=$S(CITY'="":CITY,1:HL("Q"))
"RTN","VAFCQRY3",67,0)
 ...S $P(NXT,COMP,4)=$S($G(STATE)'="":STATE,1:HL("Q"))
"RTN","VAFCQRY3",68,0)
 ...S $P(NXT,COMP,5)=$S(ZIP'="":ZIP,1:HL("Q"))
"RTN","VAFCQRY3",69,0)
 ...S $P(NXT,COMP,6)=$S(CNTRY'="":CNTRY,1:HL("Q"))
"RTN","VAFCQRY3",70,0)
 ...S $P(NXT,COMP,7)=$S(CNFTYPA=1:"VACAE",CNFTYPA=2:"VACAA",CNFTYPA=3:"VACAC",CNFTYPA=4:"VACAM",CNFTYPA=5:"VACAO",1:HL("Q"))
"RTN","VAFCQRY3",71,0)
 ...S $P(NXT,COMP,9)=$S($G(CNTY)'="":CNTY,1:HL("Q"))
"RTN","VAFCQRY3",72,0)
 ...S $P(NXT,COMP,12)=CNFSTRT_SUBCOMP_CNFEND
"RTN","VAFCQRY3",73,0)
 ...S NXT=REP_NXT
"RTN","VAFCQRY3",74,0)
 ...I LVL=0 D
"RTN","VAFCQRY3",75,0)
 ....I $L(APID(12)_NXT)'>244 S APID(12)=APID(12)_NXT Q
"RTN","VAFCQRY3",76,0)
 ....I $L(APID(12)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(12)),APID(12)=APID(12)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT))
"RTN","VAFCQRY3",77,0)
 ...I LVL>0 D
"RTN","VAFCQRY3",78,0)
 ....I $L($G(APID(12,LVL))_NXT)'>245 S APID(12,LVL)=$G(APID(12,LVL))_NXT Q
"RTN","VAFCQRY3",79,0)
 ....I $L($G(APID(12,LVL))_NXT)>245 S LNGTH=244-$L(APID(12,LVL)),APID(12,LVL)=APID(12,LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(12,LVL)=NXT
"RTN","VAFCQRY3",80,0)
 I $D(SARY(12))!(SEQ="ALL") S APID(13)=$$GET1^DIQ(2,DFN_",",.117) I APID(13)="" S APID(13)=HL("Q")  ;county code **648 backwards compatibility only
"RTN","VAFCQRY3",81,0)
PHONE I $D(SARY(13))!($D(SARY(14)))!(SEQ="ALL") D
"RTN","VAFCQRY3",82,0)
 .;**707 change PID-13 to have home and work phones, cell, pager and e-mail address with the components ; **754 add confidential phone number to PID-13
"RTN","VAFCQRY3",83,0)
 .N PHONEN,HNUM,WNUM,EMAIL,CELL,PAGER,CONFNUM ;**754
"RTN","VAFCQRY3",84,0)
 .S PHONEN=$G(^DPT(DFN,.13))
"RTN","VAFCQRY3",85,0)
 .; **707 change to ensure that null doesn't end up for any of these fields cmc 12/7/06
"RTN","VAFCQRY3",86,0)
 .S HNUM=$P(PHONEN,"^") I HNUM'="" S HNUM=$$HLPHONE^HLFNC(HNUM) I HNUM'="" S HL7STRG=HNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S HNUM=HL7STRG_COMP_"PRN"_COMP_"PH"
"RTN","VAFCQRY3",87,0)
 .S WNUM=$P(PHONEN,"^",2) I WNUM'="" S WNUM=$$HLPHONE^HLFNC(WNUM) I WNUM'="" S HL7STRG=WNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S WNUM=HL7STRG_COMP_"WPN"_COMP_"PH"
"RTN","VAFCQRY3",88,0)
 .S CELL=$P(PHONEN,"^",4) I CELL'="" S CELL=$$HLPHONE^HLFNC(CELL) I CELL'="" S HL7STRG=CELL D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CELL=HL7STRG_COMP_"ORN"_COMP_"CP"
"RTN","VAFCQRY3",89,0)
 .S PAGER=$P(PHONEN,"^",5) I PAGER'="" S PAGER=$$HLPHONE^HLFNC(PAGER) I PAGER'="" S HL7STRG=PAGER D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S PAGER=HL7STRG_COMP_"BPN"_COMP_"BP"
"RTN","VAFCQRY3",90,0)
 .S EMAIL=$P(PHONEN,"^",3) I EMAIL'="" S HL7STRG=EMAIL D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S EMAIL=COMP_"NET"_COMP_"INTERNET"_COMP_HL7STRG
"RTN","VAFCQRY3",91,0)
 .S CONFNUM=$P(PHONEN,"^",15) I CONFNUM'="" S CONFNUM=$$HLPHONE^HLFNC(CONFNUM) I CONFNUM'="" S HL7STRG=CONFNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CONFNUM=HL7STRG_COMP_"VACPN"_COMP_"PH" ;**574
"RTN","VAFCQRY3",92,0)
 .I HNUM'="" S APID(14)=HNUM
"RTN","VAFCQRY3",93,0)
 .I WNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_WNUM
"RTN","VAFCQRY3",94,0)
 .I WNUM'="",APID(14)="" S APID(14)=WNUM
"RTN","VAFCQRY3",95,0)
 .I CELL'="",APID(14)'="" S APID(14)=APID(14)_REP_CELL
"RTN","VAFCQRY3",96,0)
 .I CELL'="",APID(14)="" S APID(14)=CELL
"RTN","VAFCQRY3",97,0)
 .I PAGER'="",APID(14)'="" S APID(14)=APID(14)_REP_PAGER
"RTN","VAFCQRY3",98,0)
 .I PAGER'="",APID(14)="" S APID(14)=PAGER
"RTN","VAFCQRY3",99,0)
 .I EMAIL'="",APID(14)'="" S APID(14)=APID(14)_REP_EMAIL
"RTN","VAFCQRY3",100,0)
 .I EMAIL'="",APID(14)="" S APID(14)=EMAIL
"RTN","VAFCQRY3",101,0)
 .I CONFNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_CONFNUM ;**754
"RTN","VAFCQRY3",102,0)
 .I CONFNUM'="",APID(14)="" S APID(14)=CONFNUM ;**754
"RTN","VAFCQRY3",103,0)
 .I APID(14)="" S APID(14)=HL("Q")
"RTN","VAFCQRY3",104,0)
 I $D(SARY(14))!(SEQ="ALL") N WNUM S WNUM=$P($G(^DPT(DFN,.13)),"^",2) S WNUM=$$HLPHONE^HLFNC(WNUM) S HL7STRG=WNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S APID(15)=HL7STRG I APID(15)="" S APID(15)=HL("Q")
"RTN","VAFCQRY3",105,0)
 ;**707 keep work# in PID-14 for backwards compatability but should use PID-13 to get work#
"RTN","VAFCQRY3",106,0)
 I $D(SARY(19))!(SEQ="ALL") S APID(20)=SSN  ;ssn passed in PID-3
"RTN","VAFCQRY3",107,0)
 I $D(SARY(23))!(SEQ="ALL") D
"RTN","VAFCQRY3",108,0)
 .S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
"RTN","VAFCQRY3",109,0)
 .S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
"RTN","VAFCQRY3",110,0)
 .I CITY'=""&(STATE'="") S APID(24)=CITY_" "_STATE  ;place of birth (not used) use PID-11 with an 'N' instead
"RTN","VAFCQRY3",111,0)
 .I CITY=""&(STATE="") S APID(24)=HL("Q")
"RTN","VAFCQRY3",112,0)
 D CONT^VAFCQRY4(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERROR,REP,COMP)
"RTN","VAFCQRY3",113,0)
 ;**707 had to break routine
"RTN","VAFCQRY3",114,0)
 Q
"RTN","VAFHLIN1")
0^25^B26305328
"RTN","VAFHLIN1",1,0)
VAFHLIN1 ;ALB/KCL/SCK/PHH,TDM - CREATE HL7 INSURANCE (IN1) SEGMENT ; 1/21/09 4:05pm
"RTN","VAFHLIN1",2,0)
 ;;5.3;Registration;**122,190,670,740,754**;Aug 13, 1993;Build 46
"RTN","VAFHLIN1",3,0)
 ;
"RTN","VAFHLIN1",4,0)
 ;
"RTN","VAFHLIN1",5,0)
 ;  This generic function was designed to return the HL7 IN1 (Insurance)
"RTN","VAFHLIN1",6,0)
 ;  segment.  This segment contains VA-specific patient insurance
"RTN","VAFHLIN1",7,0)
 ;  information. (All active insurance data for a patient including
"RTN","VAFHLIN1",8,0)
 ;  those insurance carriers that do not reimburse the VA i.e Medicare)
"RTN","VAFHLIN1",9,0)
 ;
"RTN","VAFHLIN1",10,0)
 ;  SCK - modified for Insurance Encapsulation API
"RTN","VAFHLIN1",11,0)
 ;  1. The Insurance API does not currently support the Pre-Certification flag
"RTN","VAFHLIN1",12,0)
 ;  in the IN1 segment, Field 28.  No value will be returned for field 28.
"RTN","VAFHLIN1",13,0)
 ;  2.  The Insurance API does not support Line 2 or Line 3 of the address.
"RTN","VAFHLIN1",14,0)
 ;  The API returns a single address line.
"RTN","VAFHLIN1",15,0)
 ;
"RTN","VAFHLIN1",16,0)
EN(DFN,VAFSTR,VAFHLQ,VAFHLFS,VAFARRY,VAFHLECH) ; --
"RTN","VAFHLIN1",17,0)
 ; Entry point to return HL7 IN1 segments.
"RTN","VAFHLIN1",18,0)
 ;
"RTN","VAFHLIN1",19,0)
 ;  Input:
"RTN","VAFHLIN1",20,0)
 ;       DFN - internal entry number of the PATIENT (#2) file.
"RTN","VAFHLIN1",21,0)
 ;    VAFSTR - (optional) string of fields requested seperated
"RTN","VAFHLIN1",22,0)
 ;             by commas.  If not passed, return all data fields.
"RTN","VAFHLIN1",23,0)
 ;    VAFHLQ - (optional) HL7 null variable.
"RTN","VAFHLIN1",24,0)
 ;   VAFHLFS - (optional) HL7 field separator.
"RTN","VAFHLIN1",25,0)
 ;   VAFARRY - (optional) user-supplied array name which will hold
"RTN","VAFHLIN1",26,0)
 ;             HL7 IN1 segments.  Otherwise, ^TMP("VAFIN1",$J) will
"RTN","VAFHLIN1",27,0)
 ;             be used.
"RTN","VAFHLIN1",28,0)
 ;  VAFHLECH - (optional) HL7 encoding characters.
"RTN","VAFHLIN1",29,0)
 ;
"RTN","VAFHLIN1",30,0)
 ; Output:
"RTN","VAFHLIN1",31,0)
 ;      Array of HL7 IN1 segments
"RTN","VAFHLIN1",32,0)
 ;
"RTN","VAFHLIN1",33,0)
 N VAFGRP,VAFI,VAFIDX,VAFINS,VAFNODE,VAFPHN,VAFY,VAF36,X,VAFX,VAFTMP
"RTN","VAFHLIN1",34,0)
 S VAFARRY=$G(VAFARRY),VAFIDX=0
"RTN","VAFHLIN1",35,0)
 ;
"RTN","VAFHLIN1",36,0)
 ; if VAFARRY not defined, use ^TMP("VAFIN1",$J)
"RTN","VAFHLIN1",37,0)
 S:(VAFARRY="") VAFARRY="^TMP(""VAFIN1"",$J)"
"RTN","VAFHLIN1",38,0)
 ;
"RTN","VAFHLIN1",39,0)
 ; if VAFHLQ or VAFHLFS not passed, use default HL7 variables
"RTN","VAFHLIN1",40,0)
 S VAFHLQ=$S($D(VAFHLQ):VAFHLQ,1:$G(HLQ)),VAFHLFS=$S($D(VAFHLFS):VAFHLFS,1:$G(HLFS))
"RTN","VAFHLIN1",41,0)
 S VAFHLECH=$S($D(VAFHLECH):VAFHLECH,1:$G(HLECH))
"RTN","VAFHLIN1",42,0)
 ;
"RTN","VAFHLIN1",43,0)
 ; if DFN not passed, exit
"RTN","VAFHLIN1",44,0)
 I '$G(DFN) S @VAFARRY@(1,0)="IN1"_VAFHLFS_1 G ENQ
"RTN","VAFHLIN1",45,0)
 ;
"RTN","VAFHLIN1",46,0)
 ; find all insurance data for a patient (IB SUPPORTED CALL)
"RTN","VAFHLIN1",47,0)
 ; This uses the Encapsulated Insurance API to retrieve data into an array
"RTN","VAFHLIN1",48,0)
 ; See IB*2*267 Release Notes v1.0 for flags and array ID's
"RTN","VAFHLIN1",49,0)
 S VAFX=$$INSUR^IBBAPI(DFN,,"R",.VAFTMP,"*")
"RTN","VAFHLIN1",50,0)
 ;
"RTN","VAFHLIN1",51,0)
 ; if no active insurance on file for patient, build IN1
"RTN","VAFHLIN1",52,0)
 I VAFX'=1 D
"RTN","VAFHLIN1",53,0)
 .; Build a null array if no insurance data returned
"RTN","VAFHLIN1",54,0)
 . F VAFI=1:1:24 S VAFINS(1,VAFI)=""
"RTN","VAFHLIN1",55,0)
 .; Merge array to remove first two nodes to simplify handling
"RTN","VAFHLIN1",56,0)
 E  M VAFINS=VAFTMP("IBBAPI","INSUR")
"RTN","VAFHLIN1",57,0)
 ;
"RTN","VAFHLIN1",58,0)
ALL ; get all active insurance for patient
"RTN","VAFHLIN1",59,0)
 F VAFI=0:0 S VAFI=$O(VAFINS(VAFI)) Q:'VAFI  D
"RTN","VAFHLIN1",60,0)
 .D BUILD
"RTN","VAFHLIN1",61,0)
 ;
"RTN","VAFHLIN1",62,0)
ENQ Q
"RTN","VAFHLIN1",63,0)
 ;
"RTN","VAFHLIN1",64,0)
 ;
"RTN","VAFHLIN1",65,0)
BUILD ; Build array of HL7 (IN1) segments
"RTN","VAFHLIN1",66,0)
 S $P(VAFY,VAFHLFS,36)="",VAFIDX=VAFIDX+1
"RTN","VAFHLIN1",67,0)
 ;
"RTN","VAFHLIN1",68,0)
 ; if VAFSTR not passed, return all data fields
"RTN","VAFHLIN1",69,0)
 I $G(VAFSTR)']"" S VAFSTR="4,5,7,8,9,12,13,15,16,17,28,36"
"RTN","VAFHLIN1",70,0)
 S VAFSTR=","_VAFSTR_","
"RTN","VAFHLIN1",71,0)
 ;
"RTN","VAFHLIN1",72,0)
 ; sequential number (required field)
"RTN","VAFHLIN1",73,0)
 S $P(VAFY,VAFHLFS,1)=VAFIDX
"RTN","VAFHLIN1",74,0)
 ;
"RTN","VAFHLIN1",75,0)
 ; build HL7 (IN1) segment fields
"RTN","VAFHLIN1",76,0)
 I VAFSTR[",3," S $P(VAFY,VAFHLFS,3)=+$P(VAFINS(VAFI,1),U) ;Insurance company IEN (P-190)
"RTN","VAFHLIN1",77,0)
 I VAFSTR[",4," S $P(VAFY,VAFHLFS,4)=$S($P(VAFINS(VAFI,1),U,2)]"":$P(VAFINS(VAFI,1),U,2),1:VAFHLQ) ; Insurance Carrier Name
"RTN","VAFHLIN1",78,0)
 I VAFSTR[",5," S X=$$ADDR1(VAFI) S $P(VAFY,VAFHLFS,5)=$S(+X>0:X,1:VAFHLQ)
"RTN","VAFHLIN1",79,0)
 I VAFSTR[",7," S X=$$HLPHONE^HLFNC(VAFINS(VAFI,6)) S $P(VAFY,VAFHLFS,7)=$S(X]"":X,1:VAFHLQ) ; Insurance Co. Phone Number
"RTN","VAFHLIN1",80,0)
 I VAFSTR[",8," S $P(VAFY,VAFHLFS,8)=$S(VAFINS(VAFI,18)]"":VAFINS(VAFI,18),1:VAFHLQ) ; Group Number
"RTN","VAFHLIN1",81,0)
 I VAFSTR[",9," S $P(VAFY,VAFHLFS,9)=$S($P(VAFINS(VAFI,8),U,2)]"":$P(VAFINS(VAFI,8),U,2),1:VAFHLQ) ; Group Name ** The Insurance Encapsulation API doesnot return a "Group" Name, this field will display the Policy Name returned by the API
"RTN","VAFHLIN1",82,0)
 I VAFSTR[",12," S X=$$HLDATE^HLFNC(VAFINS(VAFI,10)) S $P(VAFY,VAFHLFS,12)=$S(X]"":X,1:VAFHLQ) ; Policy Effective Date
"RTN","VAFHLIN1",83,0)
 I VAFSTR[",13," S X=$$HLDATE^HLFNC(VAFINS(VAFI,11)) S $P(VAFY,VAFHLFS,13)=$S(X]"":X,1:VAFHLQ) ; Policy Expiration Date
"RTN","VAFHLIN1",84,0)
 I VAFSTR[",15," S $P(VAFY,VAFHLFS,15)=$S(+$P($G(VAFINS(VAFI,21)),"^")>0:+$P(VAFINS(VAFI,21),"^"),1:VAFHLQ) ; Plan Type (ptr. to Type of Plan (#355.1) file)
"RTN","VAFHLIN1",85,0)
 I VAFSTR[",16," S $P(VAFY,VAFHLFS,16)=$S(VAFINS(VAFI,13)]"":VAFINS(VAFI,13),1:VAFHLQ) ; Name of Insured
"RTN","VAFHLIN1",86,0)
 I VAFSTR[",17," S X=$$WHOSE($P(VAFINS(VAFI,12),U)) S $P(VAFY,VAFHLFS,17)=$S(X]"":X,1:VAFHLQ) ; Whose Insurance
"RTN","VAFHLIN1",87,0)
 ;I VAFSTR[",28," S $P(VAFY,VAFHLFS,28)=VAFHLQ ; $S($P(VAFGRP,"^",6)]"":$P(VAFGRP,"^",6),1:VAFHLQ) ; Is Pre-Certification Required?
"RTN","VAFHLIN1",88,0)
 I VAFSTR[",36," S $P(VAFY,VAFHLFS,36)=$S(VAFINS(VAFI,14)]"":VAFINS(VAFI,14),1:VAFHLQ) ; Subscriber ID
"RTN","VAFHLIN1",89,0)
 ;
"RTN","VAFHLIN1",90,0)
 ; set all active insurance policies into array
"RTN","VAFHLIN1",91,0)
 S @VAFARRY@(VAFIDX,0)="IN1"_VAFHLFS_$G(VAFY)
"RTN","VAFHLIN1",92,0)
 Q
"RTN","VAFHLIN1",93,0)
 ;
"RTN","VAFHLIN1",94,0)
WHOSE(VAFWHO) ; Format Subscriber relationship for HL7 conversion
"RTN","VAFHLIN1",95,0)
 ;
"RTN","VAFHLIN1",96,0)
 ;  Input:  Subscriber relationship from Insurance API, ID=12
"RTN","VAFHLIN1",97,0)
 ;    P - Patient
"RTN","VAFHLIN1",98,0)
 ;    S - Spouse
"RTN","VAFHLIN1",99,0)
 ;    O - Other
"RTN","VAFHLIN1",100,0)
 ;
"RTN","VAFHLIN1",101,0)
 ;  Output:
"RTN","VAFHLIN1",102,0)
 ;    v - Veteran
"RTN","VAFHLIN1",103,0)
 ;    s - Spouse
"RTN","VAFHLIN1",104,0)
 ;    o - Other
"RTN","VAFHLIN1",105,0)
 ;
"RTN","VAFHLIN1",106,0)
 S:VAFWHO["P" VAFWHO="V"
"RTN","VAFHLIN1",107,0)
 Q $$LOW^XLFSTR(VAFWHO)
"RTN","VAFHLIN1",108,0)
 ;
"RTN","VAFHLIN1",109,0)
ADDR1(VAFI) ; Format insurance company address from Insurance API for HL7 conversion.
"RTN","VAFHLIN1",110,0)
 ;
"RTN","VAFHLIN1",111,0)
 ; Input:
"RTN","VAFHLIN1",112,0)
 ;   Index number for Insurance API array
"RTN","VAFHLIN1",113,0)
 ;
"RTN","VAFHLIN1",114,0)
 ; Output:
"RTN","VAFHLIN1",115,0)
 ;   String in the form of the HL7 address field
"RTN","VAFHLIN1",116,0)
 ;
"RTN","VAFHLIN1",117,0)
 N VAFAD,VAFGL,RETVAL
"RTN","VAFHLIN1",118,0)
 S VAFAD=VAFINS(VAFI,2)_"^"_VAFINS(VAFI,23)  ;Ins Addr Line 1 & 2
"RTN","VAFHLIN1",119,0)
 S VAFGL=VAFINS(VAFI,3)_"^"_$P(VAFINS(VAFI,4),U)_"^"_VAFINS(VAFI,5)
"RTN","VAFHLIN1",120,0)
 ;
"RTN","VAFHLIN1",121,0)
 ; convert DHCP address to HL7 format using HL7 utility
"RTN","VAFHLIN1",122,0)
 S RETVAL=$$HLADDR^HLFNC(VAFAD,VAFGL)
"RTN","VAFHLIN1",123,0)
 S $P(RETVAL,$E(VAFHLECH),8)=VAFINS(VAFI,24)   ;Ins Addr Line 3
"RTN","VAFHLIN1",124,0)
 Q RETVAL
"RTN","VAFHLIN1",125,0)
 ;
"RTN","VAFHLIN1",126,0)
ADDR(VAFPTR) ; Format insurance company address for HL7 conversion
"RTN","VAFHLIN1",127,0)
 ; Retained for backword compatibility
"RTN","VAFHLIN1",128,0)
 ;
"RTN","VAFHLIN1",129,0)
 ;  Input:  
"RTN","VAFHLIN1",130,0)
 ;    VAFPTR - pointer to Insurance Co. (#36) file 
"RTN","VAFHLIN1",131,0)
 ;
"RTN","VAFHLIN1",132,0)
 ; Output:
"RTN","VAFHLIN1",133,0)
 ;    String in the form of the HL7 address field
"RTN","VAFHLIN1",134,0)
 ;
"RTN","VAFHLIN1",135,0)
 N VAFAD,VAFADDR,VAFGL,VAFST
"RTN","VAFHLIN1",136,0)
 S VAFAD=""
"RTN","VAFHLIN1",137,0)
 ;
"RTN","VAFHLIN1",138,0)
 ; get (.11) node of Insurance Co. (#36) file
"RTN","VAFHLIN1",139,0)
 S VAFADDR=$G(^DIC(36,+VAFPTR,.11))
"RTN","VAFHLIN1",140,0)
 ;
"RTN","VAFHLIN1",141,0)
 ; 1st & 2nd street address lines
"RTN","VAFHLIN1",142,0)
 F VAFST=1,2 S VAFAD=VAFAD_"^"_$P(VAFADDR,"^",VAFST)
"RTN","VAFHLIN1",143,0)
 S VAFAD=$P(VAFAD,"^",2,99)
"RTN","VAFHLIN1",144,0)
 S VAFGL=$P(VAFADDR,"^",4) ; city
"RTN","VAFHLIN1",145,0)
 S VAFGL=VAFGL_"^"_$P(VAFADDR,"^",5) ; state
"RTN","VAFHLIN1",146,0)
 S VAFGL=VAFGL_"^"_$P(VAFADDR,"^",6) ; zip
"RTN","VAFHLIN1",147,0)
 ;
"RTN","VAFHLIN1",148,0)
 ; convert DHCP address to HL7 format using HL7 utility
"RTN","VAFHLIN1",149,0)
 Q $$HLADDR^HLFNC(VAFAD,VAFGL)
"RTN","VAFHLZCT")
0^36^B9453735
"RTN","VAFHLZCT",1,0)
VAFHLZCT ;ALB/ESD,TDM - Creation of ZCT segment ; 12/9/09 2:10pm
"RTN","VAFHLZCT",2,0)
 ;;5.3;Registration;**68,653,754**;Aug 13, 1993;Build 46
"RTN","VAFHLZCT",3,0)
 ;
"RTN","VAFHLZCT",4,0)
 ; This generic extrinsic function transfers information pertaining to
"RTN","VAFHLZCT",5,0)
 ; a patient's next of kin through the Emergency Contact (ZCT) segment.
"RTN","VAFHLZCT",6,0)
 ;
"RTN","VAFHLZCT",7,0)
 ;
"RTN","VAFHLZCT",8,0)
EN(DFN,VAFSTR,VAFNUM,VAFTYPE,VAFNAMFT) ;function returns ZCT segment containing emergency contact info.
"RTN","VAFHLZCT",9,0)
 ;
"RTN","VAFHLZCT",10,0)
 ;  Input:
"RTN","VAFHLZCT",11,0)
 ;            DFN -- Internal entry number of the PATIENT file.
"RTN","VAFHLZCT",12,0)
 ;         VAFSTR -- String of fields requested separated by commas
"RTN","VAFHLZCT",13,0)
 ;         VAFNUM -- Set Id (sequential number-if not passed, set to 1).
"RTN","VAFHLZCT",14,0)
 ;        VAFTYPE -- Contact type to determine type of data returned
"RTN","VAFHLZCT",15,0)
 ;                   (1=NOK, 2=2nd NOK, 3=Emer Cont, 4=2nd Emer Cont,
"RTN","VAFHLZCT",16,0)
 ;                    5=Designee).
"RTN","VAFHLZCT",17,0)
 ;       VAFNAMFT -- Flag indicating to format the name field (SEQ-3)
"RTN","VAFHLZCT",18,0)
 ;                   to HL7 XPN data type.(1=Format, 0=Do Not Format)
"RTN","VAFHLZCT",19,0)
 ;
"RTN","VAFHLZCT",20,0)
 ;  Output:          String of components forming ZCT segment.
"RTN","VAFHLZCT",21,0)
 ;
"RTN","VAFHLZCT",22,0)
 ;      ****Also assumes all HL7 variables returned from****
"RTN","VAFHLZCT",23,0)
 ;          INIT^HLTRANS are defined.
"RTN","VAFHLZCT",24,0)
 ;
"RTN","VAFHLZCT",25,0)
 N VAFNODE,VAFCNODE,X,X1,VAFY
"RTN","VAFHLZCT",26,0)
 I '$G(DFN)!($G(VAFSTR)']"") G QUIT
"RTN","VAFHLZCT",27,0)
 S $P(VAFY,HLFS,9)="",VAFSTR=","_VAFSTR_","
"RTN","VAFHLZCT",28,0)
 I "^1^2^3^4^5^"'[("^"_$G(VAFTYPE)_"^") S VAFTYPE=1
"RTN","VAFHLZCT",29,0)
 I $G(VAFNAMFT)<1 S VAFNAMFT=0
"RTN","VAFHLZCT",30,0)
 S VAFNODE=$P($T(TYPE+VAFTYPE),";;",2),VAFCNODE=$G(^DPT(DFN,VAFNODE))
"RTN","VAFHLZCT",31,0)
 S $P(VAFY,HLFS,1)=$S($G(VAFNUM):+VAFNUM\1,1:1) ; If Set Id not passed in, set to 1
"RTN","VAFHLZCT",32,0)
 S $P(VAFY,HLFS,2)=VAFTYPE ; Contact Type
"RTN","VAFHLZCT",33,0)
 I VAFSTR[",3," D   ;Name of Next of Kin
"RTN","VAFHLZCT",34,0)
 . S X=$P(VAFCNODE,"^",1)
"RTN","VAFHLZCT",35,0)
 . I VAFNAMFT D
"RTN","VAFHLZCT",36,0)
 . . S X=$$HLNAME^XLFNAME(X,"",$E(HL("ECH"),1))
"RTN","VAFHLZCT",37,0)
 . . I X'="",$P(X,$E(HL("ECH"),1),7)'="L" S $P(X,$E(HL("ECH"),1),7)="L"
"RTN","VAFHLZCT",38,0)
 . S $P(VAFY,HLFS,3)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZCT",39,0)
 I VAFSTR[",4," S X=$P(VAFCNODE,"^",2),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Relationship to Patient
"RTN","VAFHLZCT",40,0)
 I VAFSTR[",5," D
"RTN","VAFHLZCT",41,0)
 . S X1=$G(^DPT(DFN,.22))
"RTN","VAFHLZCT",42,0)
 . S X=$$ADDR^VAFHLFNC($P(VAFCNODE,"^",3,7)_"^"_$P(X1,"^",$P($T(TYPE+VAFTYPE),";;",3)))
"RTN","VAFHLZCT",43,0)
 . S $P(VAFY,HLFS,5)=$S(X]"":$P(X,HLFS,1),1:HLQ) ; Next of Kin address
"RTN","VAFHLZCT",44,0)
 ;
"RTN","VAFHLZCT",45,0)
 I VAFSTR[",6," S X=$$HLPHONE^HLFNC($P(VAFCNODE,"^",9)),$P(VAFY,HLFS,6)=$S(X]"":X,1:HLQ) ; Home Phone
"RTN","VAFHLZCT",46,0)
 I VAFSTR[",7," S X=$$HLPHONE^HLFNC($P(VAFCNODE,"^",11)),$P(VAFY,HLFS,7)=$S(X]"":X,1:HLQ) ; Work Phone
"RTN","VAFHLZCT",47,0)
 S X=$P(VAFCNODE,"^",10) ;Get this piece for next two fields
"RTN","VAFHLZCT",48,0)
 I VAFSTR[",8," S $P(VAFY,HLFS,8)=$S(VAFTYPE=1!(VAFTYPE=2):$$YN^VAFHLFNC(X),1:HLQ) ; Contact Address Same as NOK?
"RTN","VAFHLZCT",49,0)
 I VAFSTR[",9," S $P(VAFY,HLFS,9)=$S(VAFTYPE=3!(VAFTYPE=5):$$YN^VAFHLFNC(X),1:HLQ) ; Contact Person Same as NOK?
"RTN","VAFHLZCT",50,0)
 I VAFSTR[",10," D    ; Last Date/Time Updated
"RTN","VAFHLZCT",51,0)
 . ;Q:((VAFTYPE'=1)&(VAFTYPE'=2))   ; Currently only available for type 1 & 2
"RTN","VAFHLZCT",52,0)
 . I (VAFTYPE=1)!(VAFTYPE=2) S X=$P($G(^DPT(DFN,.212)),"^",VAFTYPE)
"RTN","VAFHLZCT",53,0)
 . I (VAFTYPE=3)!(VAFTYPE=4)!(VAFTYPE=5) S X=$P($G(^DPT(DFN,.332)),"^",(VAFTYPE-2))
"RTN","VAFHLZCT",54,0)
 . S $P(VAFY,HLFS,10)=$S(X'="":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZCT",55,0)
QUIT Q "ZCT"_HLFS_$G(VAFY)
"RTN","VAFHLZCT",56,0)
TYPE ; Corresponding nodes for emergency contact type and ZIP+4 field piece.
"RTN","VAFHLZCT",57,0)
 ;;.21;;7
"RTN","VAFHLZCT",58,0)
 ;;.211;;3
"RTN","VAFHLZCT",59,0)
 ;;.33;;1
"RTN","VAFHLZCT",60,0)
 ;;.331;;4
"RTN","VAFHLZCT",61,0)
 ;;.34;;2
"RTN","VAFHLZDP")
0^23^B8641835
"RTN","VAFHLZDP",1,0)
VAFHLZDP ;ALB/MLI,TDM - Creates HL7 segments ZDP and/or ZIC ; 1/21/09 3:49pm
"RTN","VAFHLZDP",2,0)
 ;;5.3;Registration;**33,653,688,754**;Aug 13, 1993;Build 46
"RTN","VAFHLZDP",3,0)
 ;
"RTN","VAFHLZDP",4,0)
 ; This routine will return the ZDP (dependent) segment for the
"RTN","VAFHLZDP",5,0)
 ; dependent specified by the variable VAFIEN.
"RTN","VAFHLZDP",6,0)
 ;
"RTN","VAFHLZDP",7,0)
EN(VAFIEN,VAFSTR,VAFNUM,VAFMTDT,VAFIADT) ; Call to produce ZDP segment for given individual
"RTN","VAFHLZDP",8,0)
 ;
"RTN","VAFHLZDP",9,0)
 ;
"RTN","VAFHLZDP",10,0)
 ;  Input:  VAFIEN   as IEN of PATIENT RELATION (#408.12) file
"RTN","VAFHLZDP",11,0)
 ;          VAFSTR   as string of desired fields separated by commas
"RTN","VAFHLZDP",12,0)
 ;          VAFNUM   as the number desired for the set id (default = 1)
"RTN","VAFHLZDP",13,0)
 ;          VAFMTDT  as the date of the means test (default = DT)
"RTN","VAFHLZDP",14,0)
 ;          VAFIADT  as spouse/dependent inactivation date (optional)
"RTN","VAFHLZDP",15,0)
 ;
"RTN","VAFHLZDP",16,0)
 ; Output:  String of fields forming HL7 ZDP segment
"RTN","VAFHLZDP",17,0)
 ;
"RTN","VAFHLZDP",18,0)
 N NODE,NODE0,X,VAFY,NODE1,CS,SS,RS
"RTN","VAFHLZDP",19,0)
 S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
"RTN","VAFHLZDP",20,0)
 S NODE=$$DEM^DGMTU1(+$G(VAFIEN)),NODE1=$$NODE1(+$G(VAFIEN))
"RTN","VAFHLZDP",21,0)
 I $G(VAFSTR)']"" G QUIT
"RTN","VAFHLZDP",22,0)
 S $P(VAFY,HLFS,14)="",VAFSTR=","_VAFSTR_","
"RTN","VAFHLZDP",23,0)
 S $P(VAFY,HLFS,1)=$S($G(VAFNUM):VAFNUM,1:1)
"RTN","VAFHLZDP",24,0)
 S VAFMTDT=$S($G(VAFMTDT):VAFMTDT,1:DT)
"RTN","VAFHLZDP",25,0)
 I VAFSTR[",2," S X=$$HLNAME^HLFNC($P(NODE,"^",1)),$P(VAFY,HLFS,2)=$S(X]"":X,1:HLQ) ; name
"RTN","VAFHLZDP",26,0)
 I VAFSTR[",3," S $P(VAFY,HLFS,3)=$S($P(NODE,"^",2)]"":$P(NODE,"^",2),1:HLQ) ; sex
"RTN","VAFHLZDP",27,0)
 I VAFSTR[",4," S X=$$HLDATE^HLFNC($P(NODE,"^",3)),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; dob
"RTN","VAFHLZDP",28,0)
 I VAFSTR[",5," S $P(VAFY,HLFS,5)=$S($P(NODE,"^",9)]"":$P(NODE,"^",9),1:HLQ) ; ssn
"RTN","VAFHLZDP",29,0)
 I VAFSTR[",6," D
"RTN","VAFHLZDP",30,0)
 .S NODE0=$G(^DGPR(408.12,+$G(VAFIEN),0))
"RTN","VAFHLZDP",31,0)
 .S $P(VAFY,HLFS,6)=$S($P(NODE0,"^",2)]"":$P(NODE0,"^",2),1:HLQ) ; relationship to patient
"RTN","VAFHLZDP",32,0)
 I VAFSTR[",7," S $P(VAFY,HLFS,7)=+$G(VAFIEN) ; internal entry number
"RTN","VAFHLZDP",33,0)
 I VAFSTR[",8,",$$REL^DGMTU1(VAFIEN)="SPOUSE" D
"RTN","VAFHLZDP",34,0)
 .S $P(VAFY,HLFS,8)=$S($P(NODE1,"^")]"":$P(NODE1,"^"),1:HLQ) ; spouse's maiden name
"RTN","VAFHLZDP",35,0)
 I VAFSTR[",9," D
"RTN","VAFHLZDP",36,0)
 .S X=-($E(VAFMTDT,1,3)-1_"1231.9"),X=-$O(^DGPR(408.12,+$G(VAFIEN),"E","AID",X))
"RTN","VAFHLZDP",37,0)
 .S X=$$HLDATE^HLFNC(X),$P(VAFY,HLFS,9)=$S(X]"":X,1:HLQ) ; effective date
"RTN","VAFHLZDP",38,0)
 I VAFSTR[",10," S $P(VAFY,HLFS,10)=$S($P(NODE,"^",10)]"":$P(NODE,"^",10),1:HLQ) ; pseudo ssn reason
"RTN","VAFHLZDP",39,0)
 I VAFSTR[",11," S X=$$HLDATE^HLFNC($G(VAFIADT)),$P(VAFY,HLFS,11)=$S(X]"":X,1:HLQ) ; inactivation date
"RTN","VAFHLZDP",40,0)
 I VAFSTR[",13," D       ; Address
"RTN","VAFHLZDP",41,0)
 .S X=$$HLADDR^HLFNC($P(NODE1,"^",2,3),$P(NODE1,"^",5,7))
"RTN","VAFHLZDP",42,0)
 .I $P(X,CS)="" S $P(VAFY,HLFS,13)=HLQ Q    ;Must have Addr Line 1
"RTN","VAFHLZDP",43,0)
 .S $P(X,CS,6)="",$P(X,CS,7)="P",$P(X,CS,8)=$P(NODE1,"^",4)
"RTN","VAFHLZDP",44,0)
 .S $P(X,CS,12)=$$HLDATE^HLFNC($P(NODE1,"^",9))
"RTN","VAFHLZDP",45,0)
 .S $P(VAFY,HLFS,13)=X
"RTN","VAFHLZDP",46,0)
 I VAFSTR[",14," D       ; Telephone
"RTN","VAFHLZDP",47,0)
 .S X=$$HLPHONE^HLFNC($P(NODE1,"^",8))
"RTN","VAFHLZDP",48,0)
 .I X="" S $P(VAFY,HLFS,14)=HLQ Q
"RTN","VAFHLZDP",49,0)
 .S $P(VAFY,HLFS,14)=X_CS_"PRN"_CS_"PH"
"RTN","VAFHLZDP",50,0)
 ;
"RTN","VAFHLZDP",51,0)
QUIT Q "ZDP"_HLFS_$G(VAFY)
"RTN","VAFHLZDP",52,0)
 ;
"RTN","VAFHLZDP",53,0)
NODE1(DGPRI) ;GET Node 1 of Patient Relation
"RTN","VAFHLZDP",54,0)
 N DGVPI,DGVP1
"RTN","VAFHLZDP",55,0)
 S DGVPI=$P($G(^DGPR(408.12,DGPRI,0)),"^",3)
"RTN","VAFHLZDP",56,0)
 I DGVPI]"" S DGVP1=$G(@("^"_$P(DGVPI,";",2)_+DGVPI_",1)"))
"RTN","VAFHLZDP",57,0)
 Q $S($G(DGVP1)]"":DGVP1,1:"")
"RTN","VAFHLZEM")
0^24^B9782974
"RTN","VAFHLZEM",1,0)
VAFHLZEM ;ALB/KCL,TDM - Create generic HL7 ZEM segment ; 12/22/08 4:37pm
"RTN","VAFHLZEM",2,0)
 ;;5.3;Registration;**68,754**;Aug 13, 1993;Build 46
"RTN","VAFHLZEM",3,0)
 ;
"RTN","VAFHLZEM",4,0)
 ;
"RTN","VAFHLZEM",5,0)
EN(DFN,VAFSTR,VAFREQ,VAFNUM) ; This generic extrinsic function was
"RTN","VAFHLZEM",6,0)
 ;                         designed to return the HL7 ZEM segment.  This
"RTN","VAFHLZEM",7,0)
 ;                         segment contains VA-specific information
"RTN","VAFHLZEM",8,0)
 ;                         pertaining to the employment of a patient or
"RTN","VAFHLZEM",9,0)
 ;                         his/her spouse.
"RTN","VAFHLZEM",10,0)
 ;
"RTN","VAFHLZEM",11,0)
 ;  Input - DFN as internal entry number of the PATIENT file.
"RTN","VAFHLZEM",12,0)
 ;          VAFSTR as the string of fields requested seperated by commas.
"RTN","VAFHLZEM",13,0)
 ;          VAFREQ is 1 for PATIENT request, is 2 for SPOUSAL request.
"RTN","VAFHLZEM",14,0)
 ;                   If nothing is passed default to PATIENT request.
"RTN","VAFHLZEM",15,0)
 ;          VAFNUM as sequential number to add to SETID.
"RTN","VAFHLZEM",16,0)
 ;
"RTN","VAFHLZEM",17,0)
 ;     *****Also assumes all HL7 variables returned from*****
"RTN","VAFHLZEM",18,0)
 ;          INIT^HLTRANS are defined.
"RTN","VAFHLZEM",19,0)
 ;
"RTN","VAFHLZEM",20,0)
 ; Output - String of data forming the HL7 ZEM segment.
"RTN","VAFHLZEM",21,0)
 ;
"RTN","VAFHLZEM",22,0)
 N X,X1,VAFY
"RTN","VAFHLZEM",23,0)
 I '$G(DFN)!($G(VAFSTR)']"") G QUIT
"RTN","VAFHLZEM",24,0)
 S $P(VAFY,HLFS,9)="",VAFSTR=","_VAFSTR_",",VAFREQ=$G(VAFREQ)
"RTN","VAFHLZEM",25,0)
 S $P(VAFY,HLFS,1)=$S($G(VAFNUM):VAFNUM,1:1) ; Sequential number (required field)
"RTN","VAFHLZEM",26,0)
 I VAFREQ'=2 S $P(VAFY,HLFS,2)=1 D PATZEM
"RTN","VAFHLZEM",27,0)
 I VAFREQ=2 S $P(VAFY,HLFS,2)=2 D SPOUZEM
"RTN","VAFHLZEM",28,0)
QUIT ; 
"RTN","VAFHLZEM",29,0)
 Q "ZEM"_HLFS_$G(VAFY)
"RTN","VAFHLZEM",30,0)
 ;
"RTN","VAFHLZEM",31,0)
PATZEM ; Patient data requested.
"RTN","VAFHLZEM",32,0)
 S X=$G(^DPT(DFN,.311))
"RTN","VAFHLZEM",33,0)
 I VAFSTR[",3," S $P(VAFY,HLFS,3)=$S($P(X,"^",15)]"":$P(X,"^",15),1:HLQ) ; Employment Status.
"RTN","VAFHLZEM",34,0)
 I VAFSTR[",4," S $P(VAFY,HLFS,4)=$S($P(X,"^",1)]"":$P(X,"^",1),1:HLQ) ; Employer Name.
"RTN","VAFHLZEM",35,0)
 I VAFSTR[",5," S X1=$P($G(^DPT(DFN,0)),"^",7),$P(VAFY,HLFS,5)=$S(X1]"":X1,1:HLQ) ; Occupation.
"RTN","VAFHLZEM",36,0)
 I VAFSTR[",6," S X1=$$ADDR^VAFHLFNC($P(X,"^",3,7)_"^"_$P($G(^DPT(DFN,.22)),"^",5)),$P(VAFY,HLFS,6)=$S(X1]"":X1,1:HLQ) ; Employer Address.
"RTN","VAFHLZEM",37,0)
 I VAFSTR[",7," S X1=$$HLPHONE^HLFNC($P(X,"^",9)),$P(VAFY,HLFS,7)=$S(X1]"":X1,1:HLQ) ; Employer Phone.
"RTN","VAFHLZEM",38,0)
 I VAFSTR[",8," S X1=$$YN^VAFHLFNC($P(X,"^",2)),$P(VAFY,HLFS,8)=$S(X1]"":X1,1:HLQ) ; Government Agency.
"RTN","VAFHLZEM",39,0)
 ;I VAFSTR[",8," S $P(VAFY,HLFS,8)=$S($P(X,"^",2)]"":$P(X,"^",2),1:HLQ) ; Government Agency.
"RTN","VAFHLZEM",40,0)
 I VAFSTR[",9," S X1=$$HLDATE^HLFNC($P(X,"^",16)),$P(VAFY,HLFS,9)=$S(X1]"":X1,1:HLQ)  ;Retirement Date
"RTN","VAFHLZEM",41,0)
 Q
"RTN","VAFHLZEM",42,0)
 ;
"RTN","VAFHLZEM",43,0)
SPOUZEM ; Spousal data requested.
"RTN","VAFHLZEM",44,0)
 S X=$G(^DPT(DFN,.25))
"RTN","VAFHLZEM",45,0)
 I VAFSTR[",3," S $P(VAFY,HLFS,3)=$S($P(X,"^",15)]"":$P(X,"^",15),1:HLQ) ; Employment Status.
"RTN","VAFHLZEM",46,0)
 I VAFSTR[",4," S $P(VAFY,HLFS,4)=$S($P(X,"^",1)]"":$P(X,"^",1),1:HLQ) ; Employer Name.
"RTN","VAFHLZEM",47,0)
 I VAFSTR[",5," S $P(VAFY,HLFS,5)=$S($P(X,"^",14)]"":$P(X,"^",14),1:HLQ) ; Occupation.
"RTN","VAFHLZEM",48,0)
 I VAFSTR[",6," S X1=$$ADDR^VAFHLFNC($P(X,"^",2,6)_"^"_$P($G(^DPT(DFN,.22)),"^",6)),$P(VAFY,HLFS,6)=$S(X1]"":X1,1:HLQ) ; Employer Address.
"RTN","VAFHLZEM",49,0)
 I VAFSTR[",7," S X1=$$HLPHONE^HLFNC($P(X,"^",8)),$P(VAFY,HLFS,7)=$S(X1]"":X1,1:HLQ) ; Employer Phone.
"RTN","VAFHLZEM",50,0)
 I VAFSTR[",8," S $P(VAFY,HLFS,8)=HLQ
"RTN","VAFHLZEM",51,0)
 I VAFSTR[",9," S X1=$$HLDATE^HLFNC($P(X,"^",16)),$P(VAFY,HLFS,9)=$S(X1]"":X1,1:HLQ)  ;Retirement Date
"RTN","VAFHLZEM",52,0)
 Q
"RTN","VAFHLZIR")
0^35^B14809010
"RTN","VAFHLZIR",1,0)
VAFHLZIR ;ALB/SEK,TDM - Create generic HL7 ZIR segment ; 6/3/10 9:43am
"RTN","VAFHLZIR",2,0)
 ;;5.3;Registration;**33,94,151,466,653,754**;Aug 13, 1993;Build 46
"RTN","VAFHLZIR",3,0)
 ;
"RTN","VAFHLZIR",4,0)
 ;
"RTN","VAFHLZIR",5,0)
EN(VAFIEN,VAFSTR,VAFNUM,VAFENC) ; This generic extrinsic function was designed to
"RTN","VAFHLZIR",6,0)
 ;          return the HL7 ZIR segment.  This segment contains
"RTN","VAFHLZIR",7,0)
 ;          VA-specific information pertaining to income relation type
"RTN","VAFHLZIR",8,0)
 ;          data for a veteran and any applicable relations.
"RTN","VAFHLZIR",9,0)
 ;
"RTN","VAFHLZIR",10,0)
 ;  Input - VAFIEN as internal entry number of the INCOME RELATION file.
"RTN","VAFHLZIR",11,0)
 ;          VAFSTR as the string of fields requested seperated by commas.
"RTN","VAFHLZIR",12,0)
 ;          VAFNUM as the number desired for the SET ID (default = 1)
"RTN","VAFHLZIR",13,0)
 ;          VAFENC as Outpatient Encounter IEN (from file #409.68)
"RTN","VAFHLZIR",14,0)
 ;
"RTN","VAFHLZIR",15,0)
 ;  NOTE:   Input variable VAFENC was added as part of the Ambulatory
"RTN","VAFHLZIR",16,0)
 ;          Care Reporting project.
"RTN","VAFHLZIR",17,0)
 ;
"RTN","VAFHLZIR",18,0)
 ;     *****Also assumes all HL7 variables returned from*****
"RTN","VAFHLZIR",19,0)
 ;          INIT^HLTRANS are defined.
"RTN","VAFHLZIR",20,0)
 ;
"RTN","VAFHLZIR",21,0)
 ; Output - String of data forming the ZIR segment.
"RTN","VAFHLZIR",22,0)
 ;
"RTN","VAFHLZIR",23,0)
 ;
"RTN","VAFHLZIR",24,0)
 N VAFDFN,VAFERR,VAFENODE,VAFNODE,VAFY,X,RELTYP,DCHILD
"RTN","VAFHLZIR",25,0)
 I $G(VAFSTR)']"" G QUIT
"RTN","VAFHLZIR",26,0)
 S VAFENC=+$G(VAFENC)
"RTN","VAFHLZIR",27,0)
 I '$G(VAFIEN)&('VAFENC) G QUIT
"RTN","VAFHLZIR",28,0)
 S $P(VAFY,HLFS,14)="",VAFSTR=","_VAFSTR_","
"RTN","VAFHLZIR",29,0)
 S VAFNODE=$G(^DGMT(408.22,+$G(VAFIEN),0))
"RTN","VAFHLZIR",30,0)
 I $G(VAFNODE)']""&('VAFENC) G QUIT
"RTN","VAFHLZIR",31,0)
 S $P(VAFY,HLFS,1)=$S($G(VAFNUM):VAFNUM,1:1)
"RTN","VAFHLZIR",32,0)
 S RELTYP=+$P($G(^DGPR(408.12,+$P($G(^DGMT(408.21,+$P(VAFNODE,"^",2),0)),"^",2),0)),"^",2)
"RTN","VAFHLZIR",33,0)
 S DCHILD=$S(((RELTYP>2)&(RELTYP<7)):1,1:0)
"RTN","VAFHLZIR",34,0)
 I VAFSTR[",2," S $P(VAFY,HLFS,2)=$$YN^VAFHLFNC($P(VAFNODE,"^",5)) ; Married last calendar year
"RTN","VAFHLZIR",35,0)
 I VAFSTR[",3," S $P(VAFY,HLFS,3)=$$YN^VAFHLFNC($P(VAFNODE,"^",6)) ; Lived with patient
"RTN","VAFHLZIR",36,0)
 ;I VAFSTR[",4," S X=$P(VAFNODE,"^",7),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Amount contributed to spouse
"RTN","VAFHLZIR",37,0)
 I VAFSTR[",4," S X=$P(VAFNODE,"^",$S(DCHILD:19,1:7)),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Amount contributed to spouse/child
"RTN","VAFHLZIR",38,0)
 I VAFSTR[",5," S $P(VAFY,HLFS,5)=$$YN^VAFHLFNC($P(VAFNODE,"^",8)) ; Dependent children (y/n)
"RTN","VAFHLZIR",39,0)
 I VAFSTR[",6," S $P(VAFY,HLFS,6)=$$YN^VAFHLFNC($P(VAFNODE,"^",9)) ; Incapable of self-support
"RTN","VAFHLZIR",40,0)
 I VAFSTR[",7," S $P(VAFY,HLFS,7)=$$YN^VAFHLFNC($P(VAFNODE,"^",10)) ; Contributed to support
"RTN","VAFHLZIR",41,0)
 I VAFSTR[",8," S $P(VAFY,HLFS,8)=$$YN^VAFHLFNC($P(VAFNODE,"^",11)) ; Child had income
"RTN","VAFHLZIR",42,0)
 I VAFSTR[",9," S $P(VAFY,HLFS,9)=$$YN^VAFHLFNC($P(VAFNODE,"^",12)) ; Income available to you
"RTN","VAFHLZIR",43,0)
 I VAFSTR[",10," S X=$P(VAFNODE,"^",13),$P(VAFY,HLFS,10)=$S(X]"":X,1:HLQ) ; Number of dependent children
"RTN","VAFHLZIR",44,0)
 ;
"RTN","VAFHLZIR",45,0)
 ; ALB/ESD - Data elements 11,12,13 added as part of Ambulatory Care
"RTN","VAFHLZIR",46,0)
 ;           Reporting Project requirements.
"RTN","VAFHLZIR",47,0)
 ;
"RTN","VAFHLZIR",48,0)
 I VAFSTR[",11,"!(VAFSTR[",12,")!(VAFSTR[",13,") D
"RTN","VAFHLZIR",49,0)
 . ;
"RTN","VAFHLZIR",50,0)
 . ;- If no encounter ptr, encounter node or DFN elements 11 - 13 = HLQ
"RTN","VAFHLZIR",51,0)
 . I ('VAFENC) S VAFERR=1 Q
"RTN","VAFHLZIR",52,0)
 . S VAFENODE=$$SCE^DGSDU(VAFENC) I VAFENODE']"" S VAFERR=1 Q
"RTN","VAFHLZIR",53,0)
 . S VAFDFN=$P(VAFENODE,"^",2) S:VAFDFN="" VAFERR=1 Q
"RTN","VAFHLZIR",54,0)
 I VAFSTR[",11," S $P(VAFY,HLFS,11)=$S('$G(VAFERR):+$$DEP^VAFMON(VAFDFN,$P(VAFENODE,"^")),1:HLQ) ;Total Dependents
"RTN","VAFHLZIR",55,0)
 I VAFSTR[",12," S $P(VAFY,HLFS,12)=$S('$G(VAFERR):+$$INCOME^VAFMON(VAFDFN,$P(VAFENODE,"^")),1:HLQ) ;Patient Income
"RTN","VAFHLZIR",56,0)
 ;
"RTN","VAFHLZIR",57,0)
 ;- If outpat encounter node exists, get appointment type &
"RTN","VAFHLZIR",58,0)
 ;  eligibility of encounter and make call to get means test indicator
"RTN","VAFHLZIR",59,0)
 I VAFSTR[",13," S $P(VAFY,HLFS,13)=$S('$G(VAFERR):$$MTI^SCDXUTL0(VAFDFN,$P(VAFENODE,"^"),$P(VAFENODE,"^",13),$P(VAFENODE,"^",10),VAFENC),1:HLQ) ;Means Test Indicator
"RTN","VAFHLZIR",60,0)
 ;
"RTN","VAFHLZIR",61,0)
 ;- If MT Indicator not = code AN, C, or G, change number of dependents
"RTN","VAFHLZIR",62,0)
 ;  to XX (not applicable)
"RTN","VAFHLZIR",63,0)
 I VAFSTR[",11," I '$G(VAFERR) D
"RTN","VAFHLZIR",64,0)
 . I $P(VAFY,HLFS,13)'="AN"&($P(VAFY,HLFS,13)'="C")&($P(VAFY,HLFS,13)'="G") S $P(VAFY,HLFS,11)="XX" ;Total Dependents not applicable for MT indicators AS,N,X,U
"RTN","VAFHLZIR",65,0)
 ;
"RTN","VAFHLZIR",66,0)
 I VAFSTR[",14," S X=$P(VAFNODE,"^",18),$P(VAFY,HLFS,14)=$S(X=0:"N",X=1:"Y",1:HLQ) ; Dependent child school indicator
"RTN","VAFHLZIR",67,0)
 ;
"RTN","VAFHLZIR",68,0)
QUIT Q "ZIR"_HLFS_$G(VAFY)
"RTN","VAFHLZRD")
0^12^B10015130
"RTN","VAFHLZRD",1,0)
VAFHLZRD ;ALB/KCL,PJH - CREATE HL7 RATED DISABILITIES (ZRD) SEGMENTS ; 5/31/07 2:59pm
"RTN","VAFHLZRD",2,0)
 ;;5.3;Registration;**122,144,754**;Aug 13,1993;Build 46
"RTN","VAFHLZRD",3,0)
 ;
"RTN","VAFHLZRD",4,0)
 ;
"RTN","VAFHLZRD",5,0)
 ; This generic function creates HL7 VA-Specific Rated Disabilities
"RTN","VAFHLZRD",6,0)
 ; (ZRD) segments for a patient.
"RTN","VAFHLZRD",7,0)
 ;
"RTN","VAFHLZRD",8,0)
EN(DFN,VAFSTR,VAFHLQ,VAFHLFS,VAFARRY) ;--
"RTN","VAFHLZRD",9,0)
 ; Entry point to return HL7 Rated Disabilities (ZRD) segments.
"RTN","VAFHLZRD",10,0)
 ;
"RTN","VAFHLZRD",11,0)
 ;  Input:
"RTN","VAFHLZRD",12,0)
 ;        DFN - internal entry number of Patient (#2) file
"RTN","VAFHLZRD",13,0)
 ;     VAFSTR - (optional) string of fields requested, separated
"RTN","VAFHLZRD",14,0)
 ;              by commas. If not passed return all data fields.
"RTN","VAFHLZRD",15,0)
 ;     VAFHLQ - (optional) HL7 null variable.
"RTN","VAFHLZRD",16,0)
 ;     VAFHLS - (optional) HL7 field separator.
"RTN","VAFHLZRD",17,0)
 ;    VAFARRY - (optional) user-supplied array name which will
"RTN","VAFHLZRD",18,0)
 ;              hold HL7 ZRD segments.  Otherwise, ^TMP("VAFZRD",$J
"RTN","VAFHLZRD",19,0)
 ;              will be used.
"RTN","VAFHLZRD",20,0)
 ;
"RTN","VAFHLZRD",21,0)
 ; Output:
"RTN","VAFHLZRD",22,0)
 ;    Array containing the HL7 ZRD segments.
"RTN","VAFHLZRD",23,0)
 ;
"RTN","VAFHLZRD",24,0)
 N VAFINDX,VAFSUB,VAFNODE,VAFY,X
"RTN","VAFHLZRD",25,0)
 S VAFARRY=$G(VAFARRY)
"RTN","VAFHLZRD",26,0)
 ;
"RTN","VAFHLZRD",27,0)
 ; if VAFHLQ or VAFHLFS not passed, use default HL7 variables
"RTN","VAFHLZRD",28,0)
 S VAFHLQ=$S($D(VAFHLQ):VAFHLQ,1:$G(HLQ)),VAFHLFS=$S($D(VAFHLFS):VAFHLFS,1:$G(HLFS))
"RTN","VAFHLZRD",29,0)
 ;
"RTN","VAFHLZRD",30,0)
 ; if VAFARRY not defined, use ^TMP("VAFZRD",$J)
"RTN","VAFHLZRD",31,0)
 S:(VAFARRY="") VAFARRY="^TMP(""VAFZRD"",$J)"
"RTN","VAFHLZRD",32,0)
 ;
"RTN","VAFHLZRD",33,0)
 ; if DFN not passed, exit
"RTN","VAFHLZRD",34,0)
 I '$G(DFN) S @VAFARRY@(1,0)="ZRD"_VAFHLFS_1 G ENQ
"RTN","VAFHLZRD",35,0)
 ;
"RTN","VAFHLZRD",36,0)
 ; if VAFSTR not passed, return all data fields
"RTN","VAFHLZRD",37,0)
 I $G(VAFSTR)']"" S VAFSTR="1,2,3,4,12,13,14"
"RTN","VAFHLZRD",38,0)
 S (VAFINDX,VAFSUB)=0,VAFSTR=","_VAFSTR_","
"RTN","VAFHLZRD",39,0)
 ;
"RTN","VAFHLZRD",40,0)
 ; get all rated disabilities for patient
"RTN","VAFHLZRD",41,0)
 F  S VAFSUB=$O(^DPT(DFN,.372,VAFSUB)) Q:'VAFSUB  D
"RTN","VAFHLZRD",42,0)
 .;
"RTN","VAFHLZRD",43,0)
 .; - get rated disabilities node
"RTN","VAFHLZRD",44,0)
 .S VAFNODE=$G(^DPT(DFN,.372,+VAFSUB,0))
"RTN","VAFHLZRD",45,0)
 .;
"RTN","VAFHLZRD",46,0)
 .; - build array of ZRD segments
"RTN","VAFHLZRD",47,0)
 .D BUILD
"RTN","VAFHLZRD",48,0)
 ;
"RTN","VAFHLZRD",49,0)
 ; if no rated disabilities, build ZRD
"RTN","VAFHLZRD",50,0)
 I 'VAFINDX D
"RTN","VAFHLZRD",51,0)
 .S @VAFARRY@(1,0)="ZRD"_VAFHLFS_1_VAFHLFS_VAFHLFS_VAFHLFS
"RTN","VAFHLZRD",52,0)
 ;
"RTN","VAFHLZRD",53,0)
ENQ Q
"RTN","VAFHLZRD",54,0)
 ;
"RTN","VAFHLZRD",55,0)
 ;
"RTN","VAFHLZRD",56,0)
BUILD ; Build array of ZRD segments
"RTN","VAFHLZRD",57,0)
 N DCNODE ;0 node of Disability Condition
"RTN","VAFHLZRD",58,0)
 N DXCODE
"RTN","VAFHLZRD",59,0)
 N NAME
"RTN","VAFHLZRD",60,0)
 ;
"RTN","VAFHLZRD",61,0)
 ;if the Rated Disability node doesn't point to a Disability Condition,
"RTN","VAFHLZRD",62,0)
 ;then the data is meaningless and should not be sent
"RTN","VAFHLZRD",63,0)
 Q:'$P(VAFNODE,"^")
"RTN","VAFHLZRD",64,0)
 S DCNODE=$G(^DIC(31,$P(VAFNODE,"^"),0))
"RTN","VAFHLZRD",65,0)
 S DXCODE=$P(DCNODE,"^",3)
"RTN","VAFHLZRD",66,0)
 Q:DXCODE=""
"RTN","VAFHLZRD",67,0)
 S NAME=$P(DCNODE,"^",1)
"RTN","VAFHLZRD",68,0)
 ;
"RTN","VAFHLZRD",69,0)
 S VAFINDX=VAFINDX+1,$P(VAFY,"^",4)=""
"RTN","VAFHLZRD",70,0)
 S $P(VAFY,VAFHLFS,1)=VAFINDX ; Set ID
"RTN","VAFHLZRD",71,0)
 I VAFSTR[",2," S $P(VAFY,VAFHLFS,2)=DXCODE_$E($G(HLECH))_NAME ;Disabilty Condition
"RTN","VAFHLZRD",72,0)
 I VAFSTR[",3," S $P(VAFY,VAFHLFS,3)=$S($P(VAFNODE,"^",2)]"":$P(VAFNODE,"^",2),1:VAFHLQ) ; Disability %
"RTN","VAFHLZRD",73,0)
 I VAFSTR[",4," S $P(VAFY,VAFHLFS,4)=$S($P(VAFNODE,"^",3)]"":$P(VAFNODE,"^",3),1:VAFHLQ) ; Service Connected?
"RTN","VAFHLZRD",74,0)
 ;
"RTN","VAFHLZRD",75,0)
 ; *** PJH - DG*5.3*754 data fields added ***
"RTN","VAFHLZRD",76,0)
 I VAFSTR[",12," S $P(VAFY,VAFHLFS,12)=$S($P(VAFNODE,"^",4)]"":$P(VAFNODE,"^",4),1:VAFHLQ) ; Extremity
"RTN","VAFHLZRD",77,0)
 I VAFSTR[",13," S $P(VAFY,VAFHLFS,13)=$S($P(VAFNODE,"^",5)]"":$$HLDATE^HLFNC($P(VAFNODE,"^",5)),1:VAFHLQ) ; Original Effective Date
"RTN","VAFHLZRD",78,0)
 I VAFSTR[",14," S $P(VAFY,VAFHLFS,14)=$S($P(VAFNODE,"^",6)]"":$$HLDATE^HLFNC($P(VAFNODE,"^",6)),1:VAFHLQ) ; Current Effective Date
"RTN","VAFHLZRD",79,0)
 ;
"RTN","VAFHLZRD",80,0)
 ; set segment into array
"RTN","VAFHLZRD",81,0)
 S @VAFARRY@(VAFINDX,0)="ZRD"_VAFHLFS_$G(VAFY)
"RTN","VAFHLZRD",82,0)
 Q
"RTN","VAFHLZSP")
0^13^B5338744
"RTN","VAFHLZSP",1,0)
VAFHLZSP ;ALB/RJS,TDM,PJH - ZSP SEGMENT - 3/18/96 ; 5/30/07 4:21pm
"RTN","VAFHLZSP",2,0)
 ;;5.3;Registration;**94,106,122,220,653,754**;Aug 13, 1993;Build 46
"RTN","VAFHLZSP",3,0)
EN(DFN,VAFNUM,VAFAMB) ;
"RTN","VAFHLZSP",4,0)
 N VAROOT,VAFHROOT,VAFY,VAFNODE,VIETSRV,SERVCONN,PERCENT,POS,RETURN
"RTN","VAFHLZSP",5,0)
 S VAROOT="VAFHROOT"
"RTN","VAFHLZSP",6,0)
 D ELIG^VADPT
"RTN","VAFHLZSP",7,0)
 ;- ALB/ESD - Added VAFNUM as part of Ambulatory Care Reporting Project
"RTN","VAFHLZSP",8,0)
 ;            requirements.
"RTN","VAFHLZSP",9,0)
 S VAFNUM=$S($G(VAFNUM):VAFNUM,1:1)
"RTN","VAFHLZSP",10,0)
 S VAFAMB=+$G(VAFAMB,1)
"RTN","VAFHLZSP",11,0)
 I $P(VAFHROOT(3),U,1)=1 S SERVCONN="Y",PERCENT=$P(VAFHROOT(3),U,2)
"RTN","VAFHLZSP",12,0)
 I $P(VAFHROOT(3),U,1)=0 S SERVCONN="N"
"RTN","VAFHLZSP",13,0)
 I VAFHROOT(2)'="" S POS=$P($G(^DIC(21,+VAFHROOT(2),0)),U,3)
"RTN","VAFHLZSP",14,0)
 I '$D(SERVCONN) S SERVCONN=""""""
"RTN","VAFHLZSP",15,0)
 I '$D(PERCENT) S PERCENT=""""""
"RTN","VAFHLZSP",16,0)
 I '$D(POS) S POS=""""""
"RTN","VAFHLZSP",17,0)
 ;
"RTN","VAFHLZSP",18,0)
 ;- Convert Y/N to 1/0 (HL7 Table VA01)
"RTN","VAFHLZSP",19,0)
 I $D(SERVCONN) S SERVCONN=$$YN^VAFHLFNC(SERVCONN)
"RTN","VAFHLZSP",20,0)
 S RETURN="ZSP"_HLFS_VAFNUM_HLFS_SERVCONN_HLFS_PERCENT_HLFS_POS
"RTN","VAFHLZSP",21,0)
 ;- ALB/ESD - Get 'Vietnam Service Indicated?' field from PATIENT file
"RTN","VAFHLZSP",22,0)
 ;            (required by Ambulatory Care Reporting Project).
"RTN","VAFHLZSP",23,0)
 ;I +$G(VAFAMB)=1 D
"RTN","VAFHLZSP",24,0)
 ;. ;
"RTN","VAFHLZSP",25,0)
 ;. ;- 'Vietnam Service Indicated?' field = Y, N, or U (UNKNOWN)
"RTN","VAFHLZSP",26,0)
 ;. S VIETSRV=$P($G(^DPT(DFN,.321)),"^")
"RTN","VAFHLZSP",27,0)
 ;. I $G(VIETSRV)="" S VIETSRV=""""""
"RTN","VAFHLZSP",28,0)
 ;. S RETURN=RETURN_HLFS_VIETSRV
"RTN","VAFHLZSP",29,0)
 ;
"RTN","VAFHLZSP",30,0)
 ;- DG*5.3*220 REMOVED CHECK FOR VAFAMB PARAMETER
"RTN","VAFHLZSP",31,0)
 ;'Vietnam Service Indicated?' field = Y, N, or U (UNKNOWN)
"RTN","VAFHLZSP",32,0)
 S VIETSRV=$P($G(^DPT(DFN,.321)),"^")
"RTN","VAFHLZSP",33,0)
 I $G(VIETSRV)="" S VIETSRV=""""""
"RTN","VAFHLZSP",34,0)
 S RETURN=RETURN_HLFS_VIETSRV
"RTN","VAFHLZSP",35,0)
 ;
"RTN","VAFHLZSP",36,0)
 ; **** ALB/KCL - Patch DG*5.3*122; Add additional data fields ****
"RTN","VAFHLZSP",37,0)
 S VAFNODE=$G(^DPT(DFN,.3))
"RTN","VAFHLZSP",38,0)
 S $P(VAFY,HLFS,3)="",HLQ=$S($D(HLQ):HLQ,1:"""""")
"RTN","VAFHLZSP",39,0)
 S $P(VAFY,HLFS,1)=$S($P(VAFNODE,"^",4)]"":$$YN^VAFHLFNC($P(VAFNODE,"^",4)),1:HLQ) ; P&T
"RTN","VAFHLZSP",40,0)
 S $P(VAFY,HLFS,2)=$S($P(VAFNODE,"^",5)]"":$$YN^VAFHLFNC($P(VAFNODE,"^",5)),1:HLQ) ; Unemployable
"RTN","VAFHLZSP",41,0)
 S $P(VAFY,HLFS,3)=$S($P(VAFNODE,"^",12)]"":$$HLDATE^HLFNC($P(VAFNODE,"^",12)),1:HLQ) ; SC Award Date
"RTN","VAFHLZSP",42,0)
 S $P(VAFY,HLFS,5)=$S($P(VAFNODE,"^",13)]"":$$HLDATE^HLFNC($P(VAFNODE,"^",13)),1:HLQ) ; P&T Effective Date
"RTN","VAFHLZSP",43,0)
 ; **** PJH - Patch DG*5.3*754; Add additional data field ****
"RTN","VAFHLZSP",44,0)
 S $P(VAFY,HLFS,6)=$S($P(VAFNODE,"^",14)]"":$$HLDATE^HLFNC($P(VAFNODE,"^",14)),1:HLQ) ; Combined SC percent Effective Date
"RTN","VAFHLZSP",45,0)
 ;
"RTN","VAFHLZSP",46,0)
 S RETURN=RETURN_HLFS_$G(VAFY)
"RTN","VAFHLZSP",47,0)
 ;
"RTN","VAFHLZSP",48,0)
 ;
"RTN","VAFHLZSP",49,0)
 D KVAR^VADPT
"RTN","VAFHLZSP",50,0)
 Q RETURN
"SEC","^DIC",391.23,391.23,0,"AUDIT")
@
"SEC","^DIC",391.23,391.23,0,"DD")
@
"SEC","^DIC",391.23,391.23,0,"DEL")
@
"SEC","^DIC",391.23,391.23,0,"LAYGO")
@
"SEC","^DIC",391.23,391.23,0,"RD")
@
"SEC","^DIC",391.23,391.23,0,"WR")
@
"VER")
8.0^22.0
"^DD",2,2,.03,0)
DATE OF BIRTH^RDXOa^^0;3^S %DT="EP" D ^%DT S X=Y K:1701231>X!(DT<X) X I $D(X) D BIRTH^DGLOCK
"^DD",2,2,.03,.1)
DOB
"^DD",2,2,.03,1,0)
^.1
"^DD",2,2,.03,1,1,0)
2^ADOB
"^DD",2,2,.03,1,1,1)
S ^DPT("ADOB",$E(X,1,30),DA)=""
"^DD",2,2,.03,1,1,2)
K ^DPT("ADOB",$E(X,1,30),DA)
"^DD",2,2,.03,1,2,0)
^^TRIGGER^2^.083
"^DD",2,2,.03,1,2,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X=DIV S X="1" S DIH=$G(^DPT(DIV(0),0)),DIV=X S $P(^(0),U,20)=DIV,DIH=2,DIG=.083 D ^DICR
"^DD",2,2,.03,1,2,2)
Q
"^DD",2,2,.03,1,2,"CREATE VALUE")
"1"
"^DD",2,2,.03,1,2,"DELETE VALUE")
NO EFFECT
"^DD",2,2,.03,1,2,"DT")
3080310
"^DD",2,2,.03,1,2,"FIELD")
#.083
"^DD",2,2,.03,1,3,0)
2^AODS3^MUMPS
"^DD",2,2,.03,1,3,1)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.03,1,3,2)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.03,1,301,0)
2^IVM03^MUMPS
"^DD",2,2,.03,1,301,1)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.03,1,301,2)
S IVMX=X,IVMKILL=3,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX,IVMKILL
"^DD",2,2,.03,1,301,"%D",0)
^^8^8^2991027^
"^DD",2,2,.03,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.03,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.03,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.03,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.03,1,301,"%D",5,0)
 
"^DD",2,2,.03,1,301,"%D",6,0)
Also, if this field is edited, this cross-reference will check to see if the
"^DD",2,2,.03,1,301,"%D",7,0)
patient requires a financial query to be sent to the IVM Center (Data
"^DD",2,2,.03,1,301,"%D",8,0)
Collection Division (DCD).
"^DD",2,2,.03,1,301,"DT")
2991027
"^DD",2,2,.03,1,991,0)
2^AVAFC03^MUMPS
"^DD",2,2,.03,1,991,1)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".03;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.03,1,991,2)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".03;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.03,1,991,"%D",0)
^^15^15^2990204^^^^
"^DD",2,2,.03,1,991,"%D",1,0)
This cross reference is used to remember that changes were made to the
"^DD",2,2,.03,1,991,"%D",2,0)
PATIENT file (#2) outside of the Registration process.  Execution of this
"^DD",2,2,.03,1,991,"%D",3,0)
cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
"^DD",2,2,.03,1,991,"%D",4,0)
and mark it as requiring transmission of an HL7 ADT-A08 message.
"^DD",2,2,.03,1,991,"%D",5,0)
 
"^DD",2,2,.03,1,991,"%D",6,0)
The local variable VAFCFLG will be set to 1 if the cross reference is
"^DD",2,2,.03,1,991,"%D",7,0)
not executed because the change is being made from within the Registration
"^DD",2,2,.03,1,991,"%D",8,0)
process.
"^DD",2,2,.03,1,991,"%D",9,0)
 
"^DD",2,2,.03,1,991,"%D",10,0)
Execution of this cross reference can be prevented by setting the local
"^DD",2,2,.03,1,991,"%D",11,0)
variable VAFCA08 equal to 1.
"^DD",2,2,.03,1,991,"%D",12,0)
  
"^DD",2,2,.03,1,991,"%D",13,0)
The local variable VAFCF is used to identify the field edited.
"^DD",2,2,.03,1,991,"%D",14,0)
This data is stored in the FIELD(S) EDITED (#2.1) field in the 
"^DD",2,2,.03,1,991,"%D",15,0)
ADT/HL7 PIVOT file (#391.71).
"^DD",2,2,.03,1,991,"DT")
2980501
"^DD",2,2,.03,1,992,0)
2^ADGRU03^MUMPS
"^DD",2,2,.03,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.03,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.03,1,992,"%D",0)
^^9^9^2990920^
"^DD",2,2,.03,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.03,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.03,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.03,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.03,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.03,1,992,"%D",6,0)
interface.
"^DD",2,2,.03,1,992,"%D",7,0)
 
"^DD",2,2,.03,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.03,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.03,1,992,"DT")
2990920
"^DD",2,2,.03,2)
S Y(0)=Y S X=Y(0) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) S Y=X
"^DD",2,2,.03,2.1)
NUMDATE4(DOB)
"^DD",2,2,.03,3)
Enter the patient's DATE OF BIRTH which must be later than 12/31/1870.  DATE OF BIRTH cannot be a date after the beneficiary 'Ineligible Date' or a date after the 'Enrollment Application Date'.
"^DD",2,2,.03,20,0)
^.3LA^1^1
"^DD",2,2,.03,20,1,0)
DEMOG^
"^DD",2,2,.03,21,0)
^.001^3^3^3101213^^^^
"^DD",2,2,.03,21,1,0)
Enter the patient's DATE OF BIRTH which must be later than 12/31/1870.  
"^DD",2,2,.03,21,2,0)
DATE OF BIRTH cannot be a date after the beneficiary 'Ineligible Date' 
"^DD",2,2,.03,21,3,0)
or a date after the 'Enrollment Application Date'.
"^DD",2,2,.03,"AUDIT")
y
"^DD",2,2,.03,"DT")
3090904
"^DD",2,2,.119,0)
ADDRESS CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;NCOA:NCOA;BVA:BVA;VAINS:VAINS;USPS:USPS;LACS:LACS;VOA:VOA;^.11;14^Q
"^DD",2,2,.119,1,0)
^.1^^-1
"^DD",2,2,.119,1,1,0)
^^TRIGGER^2^.12
"^DD",2,2,.119,1,1,1)
X ^DD(2,.119,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.119,1,1,1.4)
"^DD",2,2,.119,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.119,0)),U,3) S X='$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="VAMC"
"^DD",2,2,.119,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,15)=DIV,DIH=2,DIG=.12 D ^DICR
"^DD",2,2,.119,1,1,2)
X ^DD(2,.119,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.119,1,1,2.4)
"^DD",2,2,.119,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,.119,0)),U,3),Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X='$P($P(Y(2),$C(59)_$P(Y(1),U,14)_":",2),$C(59))'="VAMC"
"^DD",2,2,.119,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,15)=DIV,DIH=2,DIG=.12 D ^DICR
"^DD",2,2,.119,1,1,"%D",0)
^^6^6^3080818^
"^DD",2,2,.119,1,1,"%D",1,0)
This cross-reference will trigger the population of the
"^DD",2,2,.119,1,1,"%D",2,0)
ADDRESS CHANGE SITE field with the appropriate station
"^DD",2,2,.119,1,1,"%D",3,0)
number if the ADDRESS CHANGE SOURCE equals "VAMC".  The
"^DD",2,2,.119,1,1,"%D",4,0)
Address Change Site field should be overwritten for cases
"^DD",2,2,.119,1,1,"%D",5,0)
where the site would be incorrect (i.e. uploading Z05
"^DD",2,2,.119,1,1,"%D",6,0)
message).
"^DD",2,2,.119,1,1,"CREATE CONDITION")
'ADDRESS CHANGE SOURCE'="VAMC"
"^DD",2,2,.119,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.119,1,1,"DELETE CONDITION")
'ADDRESS CHANGE SOURCE'="VAMC"
"^DD",2,2,.119,1,1,"DELETE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.119,1,1,"DT")
3060215
"^DD",2,2,.119,1,1,"FIELD")
#.12
"^DD",2,2,.119,3)
Please enter the source of the address change.
"^DD",2,2,.119,5,1,0)
2^.118^1
"^DD",2,2,.119,9)
^
"^DD",2,2,.119,21,0)
^.001^1^1^3060420^^^^
"^DD",2,2,.119,21,1,0)
This field will hold the source of the Last address change.
"^DD",2,2,.119,"DT")
3080818
"^DD",2,2,.1311,0)
CELLULAR NUMBER CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;VOA:VOA;^.13;10^Q
"^DD",2,2,.1311,1,0)
^.1
"^DD",2,2,.1311,1,1,0)
^^TRIGGER^2^.13111
"^DD",2,2,.1311,1,1,1)
X ^DD(2,.1311,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1311,1,1,1.4)
"^DD",2,2,.1311,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.1311,0)),U,3) S X='$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="VAMC"
"^DD",2,2,.1311,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,11)=DIV,DIH=2,DIG=.13111 D ^DICR
"^DD",2,2,.1311,1,1,2)
X ^DD(2,.1311,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1311,1,1,2.4)
"^DD",2,2,.1311,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,.1311,0)),U,3),Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X='$P($P(Y(2),$C(59)_$P(Y(1),U,10)_":",2),$C(59))'="VAMC"
"^DD",2,2,.1311,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,11)=DIV,DIH=2,DIG=.13111 D ^DICR
"^DD",2,2,.1311,1,1,"%D",0)
^.101^5^5^3080808^^^
"^DD",2,2,.1311,1,1,"%D",1,0)
This cross-reference will trigger the population of the CELLULAR NUMBER
"^DD",2,2,.1311,1,1,"%D",2,0)
CHANGE SITE field with the appropriate station number if the CELLULAR
"^DD",2,2,.1311,1,1,"%D",3,0)
NUMBER CHANGE SOURCE equals "VAMC".  The Cellular Number Change Site field
"^DD",2,2,.1311,1,1,"%D",4,0)
should be overwritten for cases where the site would be incorrect (i.e.
"^DD",2,2,.1311,1,1,"%D",5,0)
uploading Z05 message).
"^DD",2,2,.1311,1,1,"CREATE CONDITION")
'CELLULAR NUMBER CHANGE SOURCE'="VAMC"
"^DD",2,2,.1311,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.1311,1,1,"DELETE CONDITION")
'CELLULAR NUMBER CHANGE SOURCE'="VAMC"
"^DD",2,2,.1311,1,1,"DELETE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.1311,1,1,"DT")
3060410
"^DD",2,2,.1311,1,1,"FIELD")
#.13111
"^DD",2,2,.1311,3)
Please enter the source of the Cellular number change.
"^DD",2,2,.1311,5,1,0)
2^.139^1
"^DD",2,2,.1311,21,0)
^^2^2^3060410^
"^DD",2,2,.1311,21,1,0)
This field will hold the source of the last Cellular number
"^DD",2,2,.1311,21,2,0)
change.
"^DD",2,2,.1311,"DT")
3080725
"^DD",2,2,.1313,0)
PAGER NUMBER CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;VOA:VOA;^.13;13^Q
"^DD",2,2,.1313,1,0)
^.1
"^DD",2,2,.1313,1,1,0)
^^TRIGGER^2^.1314
"^DD",2,2,.1313,1,1,1)
X ^DD(2,.1313,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1313,1,1,1.4)
"^DD",2,2,.1313,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.1313,0)),U,3) S X='$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="VAMC"
"^DD",2,2,.1313,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,14)=DIV,DIH=2,DIG=.1314 D ^DICR
"^DD",2,2,.1313,1,1,2)
X ^DD(2,.1313,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1313,1,1,2.4)
"^DD",2,2,.1313,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,.1313,0)),U,3),Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X='$P($P(Y(2),$C(59)_$P(Y(1),U,13)_":",2),$C(59))'="VAMC"
"^DD",2,2,.1313,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,14)=DIV,DIH=2,DIG=.1314 D ^DICR
"^DD",2,2,.1313,1,1,"%D",0)
^^5^5^3060411^
"^DD",2,2,.1313,1,1,"%D",1,0)
This cross-reference will trigger the population of the PAGER NUMBER
"^DD",2,2,.1313,1,1,"%D",2,0)
CHANGE SITE field with the appropriate station number if the PAGER NUMBER
"^DD",2,2,.1313,1,1,"%D",3,0)
CHANGE SOURCE equals "VAMC". The Pager Number Change Site field should be
"^DD",2,2,.1313,1,1,"%D",4,0)
overwritten for cases where the site would be incorrect (i.e. uploading
"^DD",2,2,.1313,1,1,"%D",5,0)
Z05 message).
"^DD",2,2,.1313,1,1,"CREATE CONDITION")
'PAGER NUMBER CHANGE SOURCE'="VAMC"
"^DD",2,2,.1313,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.1313,1,1,"DELETE CONDITION")
'PAGER NUMBER CHANGE SOURCE'="VAMC"
"^DD",2,2,.1313,1,1,"DELETE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.1313,1,1,"DT")
3060410
"^DD",2,2,.1313,1,1,"FIELD")
#.1314
"^DD",2,2,.1313,3)
Please enter the source of the Pager number change.
"^DD",2,2,.1313,5,1,0)
2^.1312^1
"^DD",2,2,.1313,21,0)
^^2^2^3060410^
"^DD",2,2,.1313,21,1,0)
This field will hold the source of the last Pager number
"^DD",2,2,.1313,21,2,0)
change.
"^DD",2,2,.1313,"DT")
3080725
"^DD",2,2,.1315,0)
CONFIDENTIAL PHONE NUMBER^FX^^.13;15^K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D CAD^DGLOCK3
"^DD",2,2,.1315,3)
Enter the telephone number of the confidential address at which the patient is located [4-20 characters].
"^DD",2,2,.1315,21,0)
^^3^3^3080811^
"^DD",2,2,.1315,21,1,0)
If the 'Confidential Address Active' prompt is answered
"^DD",2,2,.1315,21,2,0)
YES, enter the telephone number of the confidential
"^DD",2,2,.1315,21,3,0)
address at which the patient is located [4-20 characters].
"^DD",2,2,.1315,"DT")
3090824
"^DD",2,2,.137,0)
EMAIL ADDRESS CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;VOA:VOA;^.13;7^Q
"^DD",2,2,.137,1,0)
^.1
"^DD",2,2,.137,1,1,0)
^^TRIGGER^2^.138
"^DD",2,2,.137,1,1,1)
X ^DD(2,.137,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.137,1,1,1.4)
"^DD",2,2,.137,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.137,0)),U,3) S X='$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="VAMC"
"^DD",2,2,.137,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,8)=DIV,DIH=2,DIG=.138 D ^DICR
"^DD",2,2,.137,1,1,2)
X ^DD(2,.137,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.137,1,1,2.4)
"^DD",2,2,.137,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,.137,0)),U,3),Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X='$P($P(Y(2),$C(59)_$P(Y(1),U,7)_":",2),$C(59))'="VAMC"
"^DD",2,2,.137,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,8)=DIV,DIH=2,DIG=.138 D ^DICR
"^DD",2,2,.137,1,1,"%D",0)
^^5^5^3060411^
"^DD",2,2,.137,1,1,"%D",1,0)
This cross-reference will trigger the population of the EMAIL ADDRESS
"^DD",2,2,.137,1,1,"%D",2,0)
CHANGE SITE field with the appropriate station number if the EMAIL ADDRESS
"^DD",2,2,.137,1,1,"%D",3,0)
CHANGE SOURCE equals "VAMC". The EMAIL ADDRESS Change Site field should be
"^DD",2,2,.137,1,1,"%D",4,0)
overwritten for cases where the site would be incorrect (i.e. uploading
"^DD",2,2,.137,1,1,"%D",5,0)
Z05 message).
"^DD",2,2,.137,1,1,"CREATE CONDITION")
'EMAIL ADDRESS CHANGE SOURCE'="VAMC"
"^DD",2,2,.137,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.137,1,1,"DELETE CONDITION")
'EMAIL ADDRESS CHANGE SOURCE'="VAMC"
"^DD",2,2,.137,1,1,"DELETE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.137,1,1,"FIELD")
#.138
"^DD",2,2,.137,3)
Please enter the source of the EMAIL address change.
"^DD",2,2,.137,5,1,0)
2^.136^1
"^DD",2,2,.137,21,0)
^^1^1^3060410^
"^DD",2,2,.137,21,1,0)
This field will hold the source of the last EMAIL address change.
"^DD",2,2,.137,"DT")
3080725
"^DD",2,2,.14112,0)
CONFIDENTIAL ADDR CHANGE DT/TM^DX^^.141;12^S %DT="ESTX" D ^%DT S X=Y K:X<1 X
"^DD",2,2,.14112,1,0)
^.1
"^DD",2,2,.14112,1,1,0)
2^AENR14112^MUMPS
"^DD",2,2,.14112,1,1,1)
I $$EECONF^DGRPCTRG(DFN) D EVENT^IVMPLOG(DA)
"^DD",2,2,.14112,1,1,2)
I $$EECONF^DGRPCTRG(DFN) D EVENT^IVMPLOG(DA)
"^DD",2,2,.14112,1,1,3)
 DO NOT DELETE
"^DD",2,2,.14112,1,1,"%D",0)
^.101^2^2^3060828^^^^
"^DD",2,2,.14112,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.14112,1,1,"%D",2,0)
enrollment.
"^DD",2,2,.14112,1,1,"DT")
3060501
"^DD",2,2,.14112,1,2,0)
^^TRIGGER^2^.14113
"^DD",2,2,.14112,1,2,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.141)):^(.141),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.14112,1,2,1.4)
"^DD",2,2,.14112,1,2,1.4)
S DIH=$G(^DPT(DIV(0),.141)),DIV=X S $P(^(.141),U,13)=DIV,DIH=2,DIG=.14113 D ^DICR
"^DD",2,2,.14112,1,2,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.141)):^(.141),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.14112,1,2,2.4)
"^DD",2,2,.14112,1,2,2.4)
S DIH=$G(^DPT(DIV(0),.141)),DIV=X S $P(^(.141),U,13)=DIV,DIH=2,DIG=.14113 D ^DICR
"^DD",2,2,.14112,1,2,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.14112,1,2,"DELETE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.14112,1,2,"DT")
3060501
"^DD",2,2,.14112,1,2,"FIELD")
#.14113
"^DD",2,2,.14112,9)
^
"^DD",2,2,.14112,21,0)
^^10^10^3100526^
"^DD",2,2,.14112,21,1,0)
This field will hold the date and time of the last Confidential Address
"^DD",2,2,.14112,21,2,0)
Update.
"^DD",2,2,.14112,21,3,0)
 
"^DD",2,2,.14112,21,4,0)
Any change to the following Confidential Address fields will trigger an
"^DD",2,2,.14112,21,5,0)
update: Confidential Street [Line 1], Confidential Street [Line 2],
"^DD",2,2,.14112,21,6,0)
Confidential Street [Line 3], Confidential Address City, Confidential
"^DD",2,2,.14112,21,7,0)
Address State, Confidential Address Zip Code, Confidential Start Date,
"^DD",2,2,.14112,21,8,0)
Confidential End Date, Confidential Address Active?, Confidential Address
"^DD",2,2,.14112,21,9,0)
County, Confidential Addr Province, Confidential Addr Postal Code,
"^DD",2,2,.14112,21,10,0)
Confidential Addr Country and Confidential Phone Number
"^DD",2,2,.14112,"DT")
3100526
"^DD",2,2,.152,0)
INELIGIBLE DATE^DX^^.15;2^S %DT="EP",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) D EK^DGLOCK I $D(X) S DFN=DA D INEL^DGLOCK
"^DD",2,2,.152,.1)

"^DD",2,2,.152,1,0)
^.1
"^DD",2,2,.152,1,1,0)
^^TRIGGER^2^.091
"^DD",2,2,.152,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DIU_"**INELIGIBLE**" S DIH=$G(^DPT(DIV(0),0)),DIV=X S $P(^(0),U,10)=DIV,DIH=2,DIG=.091 D ^DICR
"^DD",2,2,.152,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV X ^DD(2,.152,1,1,59.2) S X=$P(Y(4),Y(5),Y(6),X) S Y=X,X=Y(3),X=X_Y X ^DD(2,.152,1,1,2.4)
"^DD",2,2,.152,1,1,2.4)
S DIH=$G(^DPT(DIV(0),0)),DIV=X S $P(^(0),U,10)=DIV,DIH=2,DIG=.091 D ^DICR
"^DD",2,2,.152,1,1,59.2)
S X=DIU,Y(1)=$G(X) S X="**INELIGIBLE**",Y(2)=$G(X) S X=1,X=$P(Y(1),Y(2),X),Y(3)=$G(X) S X=DIU,Y(4)=$G(X) S X="**INELIGIBLE**",Y(5)=$G(X) S X=2,Y(6)=$G(X) S X=99
"^DD",2,2,.152,1,1,"CREATE VALUE")
REMARKS_"**INELIGIBLE**"
"^DD",2,2,.152,1,1,"DELETE VALUE")
$P(REMARKS,"**INELIGIBLE**",1)_$P(REMARKS,"**INELIGIBLE**",2,99)
"^DD",2,2,.152,1,1,"DT")
3080310
"^DD",2,2,.152,1,1,"FIELD")
REMARKS
"^DD",2,2,.152,1,2,0)
2^AENR152^MUMPS
"^DD",2,2,.152,1,2,1)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.152,1,2,2)
D AUTOUPD^DGENA2(DA,2)
"^DD",2,2,.152,1,2,3)
DO NOT DELETE
"^DD",2,2,.152,1,2,"%D",0)
^^3^3^2981016^^^^
"^DD",2,2,.152,1,2,"%D",1,0)
 
"^DD",2,2,.152,1,2,"%D",2,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.152,1,2,"%D",3,0)
enrollment.
"^DD",2,2,.152,1,2,"DT")
2981016
"^DD",2,2,.152,1,3,0)
2^AXR7^MUMPS
"^DD",2,2,.152,1,3,1)
Q
"^DD",2,2,.152,1,3,2)
S DGXRF=.152 D ^DGDDC Q
"^DD",2,2,.152,3)
The Ineligible Date cannot be prior to the beneficiary Date of Birth.  Enter the date this patient was identified as being ineligible for treatment.
"^DD",2,2,.152,20,0)
^.3LA^1^1
"^DD",2,2,.152,20,1,0)
IPT
"^DD",2,2,.152,21,0)
^.001^4^4^3070522^^
"^DD",2,2,.152,21,1,0)
If this applicant is ineligible for treatment enter the effective date.
"^DD",2,2,.152,21,2,0)
Only users who hold the designated security key may enter/edit this
"^DD",2,2,.152,21,3,0)
field.  The Ineligible Date cannot be prior to the beneficiary Date of 
"^DD",2,2,.152,21,4,0)
Birth.
"^DD",2,2,.152,"DEL",1,0)
D EK^DGLOCK I '$D(X)
"^DD",2,2,.152,"DT")
3080310
"^DD",2,2,.21011,0)
K-WORK PHONE NUMBER^F^^.21;11^K:$L(X)>20!($L(X)<4) X
"^DD",2,2,.21011,3)
Enter the next of kin's work phone number.  Answer must be 4-20 characters in length.
"^DD",2,2,.21011,21,0)
^^2^2^2920113^
"^DD",2,2,.21011,21,1,0)
If the person designated as next of kin for this patient is employed,
"^DD",2,2,.21011,21,2,0)
enter the phone number at which the NOK can be reached while at work.
"^DD",2,2,.21011,"DT")
3100528
"^DD",2,2,.211011,0)
K2-WORK PHONE NUMBER^F^^.211;11^K:$L(X)>20!($L(X)<4) X
"^DD",2,2,.211011,3)
Enter the work phone for the secondary next of kin.  Answer must be 4-20 characters in length.
"^DD",2,2,.211011,21,0)
^^3^3^2920113^
"^DD",2,2,.211011,21,1,0)
If the person designated as secondary next of kin for this patient is
"^DD",2,2,.211011,21,2,0)
employed, enter the phone number that individual can be reached at while
"^DD",2,2,.211011,21,3,0)
at work.
"^DD",2,2,.211011,"DT")
3100528
"^DD",2,2,.211012,0)
SECONDARY NOK CHANGE DATE/TIME^DX^^.212;2^S %DT="ESTX" D ^%DT S X=Y K:X<1 X
"^DD",2,2,.211012,1,0)
^.1
"^DD",2,2,.211012,1,1,0)
2^AENR211012^MUMPS
"^DD",2,2,.211012,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.211012,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.211012,1,1,3)
 DO NOT DELETE
"^DD",2,2,.211012,1,1,"%D",0)
^^2^2^3100525^
"^DD",2,2,.211012,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that
"^DD",2,2,.211012,1,1,"%D",2,0)
may affect enrollment.
"^DD",2,2,.211012,1,1,"DT")
3100525
"^DD",2,2,.211012,21,0)
^^8^8^3100526^
"^DD",2,2,.211012,21,1,0)
This field will hold the date and time of the last Secondary Next of Kin
"^DD",2,2,.211012,21,2,0)
Update.
"^DD",2,2,.211012,21,3,0)
 
"^DD",2,2,.211012,21,4,0)
Any change to the following Secondary Next of Kin fields will trigger an
"^DD",2,2,.211012,21,5,0)
update: K2-Name Of Secondary NOK, K2-Relationship To Patient, K2-Street
"^DD",2,2,.211012,21,6,0)
Address [Line 1], K2-Street Address [Line 2], K2-Street Address [Line 3],
"^DD",2,2,.211012,21,7,0)
K2-City, K2-State, K2-Zip Code, K2-Phone Number, K2-Address Same As
"^DD",2,2,.211012,21,8,0)
Patient's? and K2-Work Phone Number
"^DD",2,2,.211012,"DT")
3100526
"^DD",2,2,.219,0)
K-PHONE NUMBER^FXa^^.21;9^K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D K1^DGLOCK2
"^DD",2,2,.219,.1)

"^DD",2,2,.219,1,0)
^.1
"^DD",2,2,.219,1,991,0)
2^AVAFC219^MUMPS
"^DD",2,2,.219,1,991,1)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.219,1,991,2)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.219,1,991,"%D",0)
^^15^15^2990204^^^^
"^DD",2,2,.219,1,991,"%D",1,0)
This cross reference is used to remember that changes were made to the
"^DD",2,2,.219,1,991,"%D",2,0)
PATIENT file (#2) outside of the Registration process.  Execution of this
"^DD",2,2,.219,1,991,"%D",3,0)
cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
"^DD",2,2,.219,1,991,"%D",4,0)
and mark it as requiring transmission of an HL7 ADT-A08 message.
"^DD",2,2,.219,1,991,"%D",5,0)
 
"^DD",2,2,.219,1,991,"%D",6,0)
The local variable VAFCFLG will be set to 1 if the cross reference is
"^DD",2,2,.219,1,991,"%D",7,0)
not executed because the change is being made from within the Registration
"^DD",2,2,.219,1,991,"%D",8,0)
process.
"^DD",2,2,.219,1,991,"%D",9,0)
 
"^DD",2,2,.219,1,991,"%D",10,0)
Execution of this cross reference can be prevented by setting the local
"^DD",2,2,.219,1,991,"%D",11,0)
variable VAFCA08 equal to 1.
"^DD",2,2,.219,1,991,"%D",12,0)
  
"^DD",2,2,.219,1,991,"%D",13,0)
The local variable VAFCF is used to identify the field edited.
"^DD",2,2,.219,1,991,"%D",14,0)
This data is stored in the FIELD(S) EDITED (#2.1) field in the 
"^DD",2,2,.219,1,991,"%D",15,0)
ADT/HL7 PIVOT file (#391.71).
"^DD",2,2,.219,1,991,"DT")
2970825
"^DD",2,2,.219,1,992,0)
2^ADGRU219^MUMPS
"^DD",2,2,.219,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.219,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.219,1,992,"%D",0)
^^9^9^2990921^
"^DD",2,2,.219,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.219,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.219,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.219,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.219,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.219,1,992,"%D",6,0)
interface.
"^DD",2,2,.219,1,992,"%D",7,0)
 
"^DD",2,2,.219,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.219,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.219,1,992,"DT")
2990921
"^DD",2,2,.219,3)
Enter the phone number of the primary NOK [4-20 characters].
"^DD",2,2,.219,20,0)
^.3LA^1^1
"^DD",2,2,.219,20,1,0)
NK1
"^DD",2,2,.219,21,0)
^^4^4^2861117^^
"^DD",2,2,.219,21,1,0)
If a primary next-of-kin is specified enter that person's
"^DD",2,2,.219,21,2,0)
telephone number [4-20 characters], otherwise nothing may
"^DD",2,2,.219,21,3,0)
be entered.  This field cannot be deleted as long as a
"^DD",2,2,.219,21,4,0)
'next of kin' name is on file.
"^DD",2,2,.219,"AUDIT")
y
"^DD",2,2,.219,"DT")
3100528
"^DD",2,2,.2199,0)
K2-PHONE NUMBER^FX^^.211;9^K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D K2^DGLOCK2
"^DD",2,2,.2199,.1)

"^DD",2,2,.2199,3)
Enter the phone number of the secondary NOK [3-20 characters].
"^DD",2,2,.2199,20,0)
^.3LA^1^1
"^DD",2,2,.2199,20,1,0)
NK2
"^DD",2,2,.2199,21,0)
^^4^4^2861007^
"^DD",2,2,.2199,21,1,0)
If a secondary NOK is specified enter the telephone number at which
"^DD",2,2,.2199,21,2,0)
that person may be reached [3-20 characters], otherwise nothing may
"^DD",2,2,.2199,21,3,0)
be entered.  This field cannot be deleted as long as a secondary
"^DD",2,2,.2199,21,4,0)
NOK is on file.
"^DD",2,2,.2199,"DT")
3100528
"^DD",2,2,.291,0)
DATE RULED INCOMPETENT (VA)^DX^^.29;1^S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D INCOM^DGLOCK
"^DD",2,2,.291,3)
Enter the date this patient was ruled incompetent to handle his VA funds.  The Date Ruled Incompetent cannot be after the Date of Death.
"^DD",2,2,.291,21,0)
^.001^2^2^3070531^^^^
"^DD",2,2,.291,21,1,0)
Enter the date this patient was ruled to be incompetent to handle his
"^DD",2,2,.291,21,2,0)
VA funds.  The Date Ruled Incompetent cannot be after the Date of Death.
"^DD",2,2,.291,"DT")
3070522
"^DD",2,2,.292,0)
DATE RULED INCOMPETENT (CIVIL)^DX^^.29;2^S %DT="EP" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D INCOM2^DGLOCK
"^DD",2,2,.292,3)
Enter the date ruled incompetent.  The Date Ruled Incompetent cannot be after the Date of Death.
"^DD",2,2,.292,21,0)
^^3^3^3090904^
"^DD",2,2,.292,21,1,0)
If this patient was ruled incompetent to handle his funds, enter the
"^DD",2,2,.292,21,2,0)
date he was ruled incompetent.  The Date Ruled Incompetent cannot be 
"^DD",2,2,.292,21,3,0)
after the Date of Death.
"^DD",2,2,.292,"DT")
3090904
"^DD",2,2,.3013,0)
P&T EFFECTIVE DATE^DX^^.3;13^S %DT="EXP" D ^%DT S X=Y K:X<1!(DT<X) X I $D(X) S DFN=DA D PTDT^DGLOCK I $D(X) S DFN=DA D EV2^DGLOCK
"^DD",2,2,.3013,1,0)
^.1
"^DD",2,2,.3013,1,1,0)
2^AENR3013^MUMPS
"^DD",2,2,.3013,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3013,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3013,1,1,3)
DO NOT DELETE
"^DD",2,2,.3013,1,1,"%D",0)
^^2^2^3060412^
"^DD",2,2,.3013,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.3013,1,1,"%D",2,0)
enrollment.
"^DD",2,2,.3013,1,1,"DT")
3060412
"^DD",2,2,.3013,3)
Enter the Effective Date the patient was awarded P&T disability status by VARO.  This date is optional, but cannot be in the future, before DOB or after DOD
"^DD",2,2,.3013,5,1,0)
2^.304^2
"^DD",2,2,.3013,21,0)
^^6^6^3070517^
"^DD",2,2,.3013,21,1,0)
Enter the Effective Date the patient was awarded P&T disability status
"^DD",2,2,.3013,21,2,0)
by VARO.
"^DD",2,2,.3013,21,3,0)
This field is optional (not required).  But if entered, the date needs 
"^DD",2,2,.3013,21,4,0)
to be a precise date, i.e. a day, month and year MUST be included.  
"^DD",2,2,.3013,21,5,0)
P&T Effective Date can not be a date prior to the Veteran's 'Date of 
"^DD",2,2,.3013,21,6,0)
Birth', a future date, or a date after the Veteran's 'Date of Death'.
"^DD",2,2,.3013,"DT")
3070516
"^DD",2,2,.33011,0)
E-WORK PHONE NUMBER^F^^.33;11^K:$L(X)>20!($L(X)<4) X
"^DD",2,2,.33011,3)
Enter the work phone number for the emergency contact.  Answer must be 4-20 characters in length.
"^DD",2,2,.33011,21,0)
^^2^2^2920113^
"^DD",2,2,.33011,21,1,0)
If the emergency contact for this patient is employed, enter the phone
"^DD",2,2,.33011,21,2,0)
number at which this individual may be reached while at work.
"^DD",2,2,.33011,"DT")
3100528
"^DD",2,2,.33012,0)
E-CONTACT CHANGE DATE/TIME^DX^^.332;1^S %DT="ESTX" D ^%DT S X=Y K:X<1 X
"^DD",2,2,.33012,1,0)
^.1
"^DD",2,2,.33012,1,1,0)
2^AENR33012^MUMPS
"^DD",2,2,.33012,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.33012,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.33012,1,1,3)
 DO NOT DELETE
"^DD",2,2,.33012,1,1,"%D",0)
^^2^2^3100525^
"^DD",2,2,.33012,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that
"^DD",2,2,.33012,1,1,"%D",2,0)
may affect enrollment.
"^DD",2,2,.33012,1,1,"DT")
3100525
"^DD",2,2,.33012,21,0)
^^8^8^3100526^
"^DD",2,2,.33012,21,1,0)
This field will hold the date and time of the last Emergency Contact
"^DD",2,2,.33012,21,2,0)
Update.
"^DD",2,2,.33012,21,3,0)
 
"^DD",2,2,.33012,21,4,0)
Any change to the following Emergency Contact fields will trigger an
"^DD",2,2,.33012,21,5,0)
update: E-Name, E-Relationship To Patient, E-Street Address [Line 1],
"^DD",2,2,.33012,21,6,0)
E-Street Address [Line 2], E-Street Address [Line 3], E-City, E-State,
"^DD",2,2,.33012,21,7,0)
E-Zip Code, E-Phone Number, E-Emer. Contact Same As NOK? and E-Work Phone
"^DD",2,2,.33012,21,8,0)
Number
"^DD",2,2,.33012,"DT")
3100526
"^DD",2,2,.331011,0)
E2-WORK PHONE NUMBER^F^^.331;11^K:$L(X)>20!($L(X)<4) X
"^DD",2,2,.331011,3)
Enter the work phone number for the secondary emergency contact.  Answer must be 4-20 characters in length.
"^DD",2,2,.331011,21,0)
^^2^2^2920113^
"^DD",2,2,.331011,21,1,0)
If the person designated as the secondary emergency contact is employed,
"^DD",2,2,.331011,21,2,0)
enter the person's work phone number.
"^DD",2,2,.331011,"DT")
3100528
"^DD",2,2,.33112,0)
E2-CONTACT CHANGE DATE/TIME^DX^^.332;2^S %DT="ESTX" D ^%DT S X=Y K:X<1 X
"^DD",2,2,.33112,1,0)
^.1
"^DD",2,2,.33112,1,1,0)
2^AENR33112^MUMPS
"^DD",2,2,.33112,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.33112,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.33112,1,1,3)
 DO NOT DELETE
"^DD",2,2,.33112,1,1,"%D",0)
^^2^2^3100525^
"^DD",2,2,.33112,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that
"^DD",2,2,.33112,1,1,"%D",2,0)
may affect enrollment.
"^DD",2,2,.33112,1,1,"DT")
3100525
"^DD",2,2,.33112,21,0)
^^8^8^3100526^
"^DD",2,2,.33112,21,1,0)
This field will hold the date and time of the last Secondary Emergency
"^DD",2,2,.33112,21,2,0)
Contact Update.
"^DD",2,2,.33112,21,3,0)
 
"^DD",2,2,.33112,21,4,0)
Any change to the following Secondary Emergency Contact fields will
"^DD",2,2,.33112,21,5,0)
trigger an update: E2-Name Of Secondary Contact, E2-Relationship To
"^DD",2,2,.33112,21,6,0)
Patient, E2-Street Address [Line 1], E2-Street Address [Line 2], E2-Street
"^DD",2,2,.33112,21,7,0)
Address [Line 3], E2-City, E2-State, E2-Zip Code, E2-Phone Number and
"^DD",2,2,.33112,21,8,0)
E2-Work Phone Number
"^DD",2,2,.33112,"DT")
3100526
"^DD",2,2,.3319,0)
E2-PHONE NUMBER^FX^^.331;9^K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D E2^DGLOCK2
"^DD",2,2,.3319,.1)

"^DD",2,2,.3319,3)
Enter the phone number of the secondary emergency contact [3-20 characters].
"^DD",2,2,.3319,20,0)
^.3LA^1^1
"^DD",2,2,.3319,20,1,0)
EC2
"^DD",2,2,.3319,21,0)
^^4^4^2861007^
"^DD",2,2,.3319,21,1,0)
If a secondary emergency contact is specified enter the telephone
"^DD",2,2,.3319,21,2,0)
number at which that person may be reached [3-20 characters],
"^DD",2,2,.3319,21,3,0)
otherwise nothing may be entered.  This field cannot be deleted as
"^DD",2,2,.3319,21,4,0)
long as a secondary emergency contact is on file.
"^DD",2,2,.3319,"DT")
3100528
"^DD",2,2,.339,0)
E-PHONE NUMBER^FX^^.33;9^K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
"^DD",2,2,.339,.1)

"^DD",2,2,.339,3)
Enter the phone number of the emergency contact [3-20 characters].
"^DD",2,2,.339,20,0)
^.3LA^1^1
"^DD",2,2,.339,20,1,0)
EC1
"^DD",2,2,.339,21,0)
^^4^4^2861007^
"^DD",2,2,.339,21,1,0)
If a primary emergency contact is specified enter the telephone
"^DD",2,2,.339,21,2,0)
number [3-20 characters] at which that person may be reached,
"^DD",2,2,.339,21,3,0)
otherwise nothing may be entered.  This field cannot be deleted
"^DD",2,2,.339,21,4,0)
as long as a primary emergency contact is on file.
"^DD",2,2,.339,"DT")
3100528
"^DD",2,2,.34011,0)
D-WORK PHONE NUMBER^F^^.34;11^K:$L(X)>20!($L(X)<4) X
"^DD",2,2,.34011,3)
Enter the designee's work phone number.  Answer must be 4-20 characters in length.
"^DD",2,2,.34011,21,0)
^^3^3^2920113^
"^DD",2,2,.34011,21,1,0)
If the person designated to receive the patient's personal effects is
"^DD",2,2,.34011,21,2,0)
employed, enter the phone number at which that person may be reached
"^DD",2,2,.34011,21,3,0)
while at work.
"^DD",2,2,.34011,"DT")
3100528
"^DD",2,2,.3412,0)
DESIGNEE CHANGE DATE/TIME^DX^^.332;3^S %DT="ESTX" D ^%DT S X=Y K:X<1 X
"^DD",2,2,.3412,1,0)
^.1
"^DD",2,2,.3412,1,1,0)
2^AENR3412^MUMPS
"^DD",2,2,.3412,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3412,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.3412,1,1,3)
 DO NOT DELETE
"^DD",2,2,.3412,1,1,"%D",0)
^.101^2^2^3100525^^
"^DD",2,2,.3412,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that
"^DD",2,2,.3412,1,1,"%D",2,0)
may affect enrollment.
"^DD",2,2,.3412,1,1,"DT")
3100525
"^DD",2,2,.3412,21,0)
^^6^6^3100526^
"^DD",2,2,.3412,21,1,0)
This field will hold the date and time of the last Designee Update.
"^DD",2,2,.3412,21,2,0)
 
"^DD",2,2,.3412,21,3,0)
Any change to the following Designee fields will trigger an update:
"^DD",2,2,.3412,21,4,0)
D-Name Of Designee, D-Relationship To Patient, D-Street Address [Line 1],
"^DD",2,2,.3412,21,5,0)
D-Street Address [Line 2], D-Street Address [Line 3], D-City, D-State,
"^DD",2,2,.3412,21,6,0)
D-Zip Code, D-Phone Number, D-Designee Same As Nok?, D-Work Phone Number
"^DD",2,2,.3412,"DT")
3100526
"^DD",2,2,.349,0)
D-PHONE NUMBER^FX^^.34;9^K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D D^DGLOCK2
"^DD",2,2,.349,.1)
PHONE NUMBER OF PERSONAL POSSESSION DESIGNEE
"^DD",2,2,.349,3)
Enter the phone number of the designee [3-20 characters].
"^DD",2,2,.349,20,0)
^.3LA^1^1
"^DD",2,2,.349,20,1,0)
D1
"^DD",2,2,.349,21,0)
^^4^4^2861007^
"^DD",2,2,.349,21,1,0)
If a designee is specified enter the telephone number at which
"^DD",2,2,.349,21,2,0)
that person may be reached [3-20 characters], otherwise nothing
"^DD",2,2,.349,21,3,0)
may be entered.  This field cannot be deleted as long as a
"^DD",2,2,.349,21,4,0)
designee is on file.
"^DD",2,2,.349,"DT")
3100528
"^DD",2,2,.351,0)
DATE OF DEATH^DXa^^.35;1^S %DT="EPX" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL K:X>DGTIME X K DGTIME,DGDATE I $D(X) S DFN=DA D DEATH^DGLOCK
"^DD",2,2,.351,1,0)
^.1
"^DD",2,2,.351,1,1,0)
^^TRIGGER^2^.091
"^DD",2,2,.351,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV X ^DD(2,.351,1,1,49.3) S X=$E(Y(8),Y(9),X) S Y=X,X=Y(7),X=X_Y_"]" X ^DD(2,.351,1,1,1.4)
"^DD",2,2,.351,1,1,1.4)
S DIH=$G(^DPT(DIV(0),0)),DIV=X S $P(^(0),U,10)=DIV,DIH=2,DIG=.091 D ^DICR
"^DD",2,2,.351,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,2.1) S DIH=$G(^DPT(DIV(0),0)),DIV=X S $P(^(0),U,10)=DIV,DIH=2,DIG=.091 D ^DICR
"^DD",2,2,.351,1,1,2.1)
S X=DIV X ^DD(2,.351,1,1,59.2) S X=$P(Y(5),Y(6),X),Y(7)=$G(X) S X="]",Y(8)=$G(X) S X=2,X=$P(Y(7),Y(8),X) S Y=X,X=Y(3),X=X_Y
"^DD",2,2,.351,1,1,49.2)
S X=DIU_"[PATIENT DIED ON ",Y(1)=$G(X) S X=DIV,Y(2)=$G(X) S X=4,Y(3)=$G(X) S X=5,X=$E(Y(2),Y(3),X) S Y=X,X=Y(1),X=X_Y_"/",Y(4)=$G(X) S X=DIV,Y(5)=$G(X) S X=6
"^DD",2,2,.351,1,1,49.3)
X ^DD(2,.351,1,1,49.2) S Y(6)=$G(X) S X=7,X=$E(Y(5),Y(6),X) S Y=X,X=Y(4),X=X_Y_"/",Y(7)=$G(X) S X=DIV,Y(8)=$G(X) S X=2,Y(9)=$G(X) S X=3
"^DD",2,2,.351,1,1,59.2)
S X=DIU,Y(1)=$G(X) S X="[PATIENT DIED",Y(2)=$G(X) S X=1,X=$P(Y(1),Y(2),X),Y(3)=$G(X),Y(4)=$G(X) S X=DIU,Y(5)=$G(X) S X="PATIENT DIED",Y(6)=$G(X) S X=2
"^DD",2,2,.351,1,1,"%D",0)
^^3^3^3080310^
"^DD",2,2,.351,1,1,"%D",1,0)
This appends into the REMARKS field a notation regarding the DATE OF
"^DD",2,2,.351,1,1,"%D",2,0)
DEATH.  If DATE OF DEATH is deleted, the notation will be stripped out
"^DD",2,2,.351,1,1,"%D",3,0)
of the REMARKS field.
"^DD",2,2,.351,1,1,"CREATE VALUE")
REMARKS_"[PATIENT DIED ON "_$E(DATE OF DEATH,4,5)_"/"_$E(DATE OF DEATH,6,7)_"/"_$E(DATE OF DEATH,2,3)_"]"
"^DD",2,2,.351,1,1,"DELETE VALUE")
$P(REMARKS,"[PATIENT DIED",1)_$P($P(REMARKS,"PATIENT DIED",2),"]",2)
"^DD",2,2,.351,1,1,"DT")
3080310
"^DD",2,2,.351,1,1,"FIELD")
REMARKS
"^DD",2,2,.351,1,2,0)
^^TRIGGER^2^.352
"^DD",2,2,.351,1,2,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.35)):^(.35),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") S DIH=$G(^DPT(DIV(0),.35)),DIV=X S $P(^(.35),U,2)=DIV,DIH=2,DIG=.352 D ^DICR
"^DD",2,2,.351,1,2,2)
Q
"^DD",2,2,.351,1,2,"CREATE VALUE")
S X=$S(($D(DUZ)#2):DUZ,1:"")
"^DD",2,2,.351,1,2,"DELETE VALUE")
NO EFFECT
"^DD",2,2,.351,1,2,"DT")
3080310
"^DD",2,2,.351,1,2,"FIELD")
DEATH ENTERED BY
"^DD",2,2,.351,1,3,0)
2^ADGDBUL^MUMPS
"^DD",2,2,.351,1,3,1)
D DSBULL^DGDEATH
"^DD",2,2,.351,1,3,2)
D DKBULL^DGDEATH
"^DD",2,2,.351,1,3,"DT")
3031008
"^DD",2,2,.351,1,4,0)
2^AEXP1
"^DD",2,2,.351,1,4,1)
S ^DPT("AEXP1",$E(X,1,30),DA)=""
"^DD",2,2,.351,1,4,2)
K ^DPT("AEXP1",$E(X,1,30),DA)
"^DD",2,2,.351,1,5,0)
2^AOERR^MUMPS
"^DD",2,2,.351,1,5,1)
D DEATH^DGOERNOT
"^DD",2,2,.351,1,5,2)
Q
"^DD",2,2,.351,1,5,"%D",0)
^^3^3^2910716^^^^
"^DD",2,2,.351,1,5,"%D",1,0)
     This cross-reference is used in conjunction with ORDER ENTRY/RESULTS
"^DD",2,2,.351,1,5,"%D",2,0)
REPORTING v2.09 or higher to send MAS OE/RR NOTIFICATIONS of
"^DD",2,2,.351,1,5,"%D",3,0)
DEATH to users who are on an OE/RR LIST for a patient.
"^DD",2,2,.351,1,5,"DT")
2910715
"^DD",2,2,.351,1,6,0)
2^APSJD^MUMPS
"^DD",2,2,.351,1,6,1)
S XX=X,X="PSJADT" X ^%ZOSF("TEST") S X=XX K XX I  D END^PSJADT
"^DD",2,2,.351,1,6,2)
Q
"^DD",2,2,.351,1,6,3)
Cancels Inpatient Medication orders.
"^DD",2,2,.351,1,6,"%D",0)
^^3^3^2930608^^^
"^DD",2,2,.351,1,6,"%D",1,0)
This is used by the Inpatient Medications package to cancel a patient's
"^DD",2,2,.351,1,6,"%D",2,0)
IV and Unit Dose orders whenever a date of death is entered for the
"^DD",2,2,.351,1,6,"%D",3,0)
patient.
"^DD",2,2,.351,1,6,"DT")
2930608
"^DD",2,2,.351,1,7,0)
2^ARCDTH^MUMPS
"^DD",2,2,.351,1,7,1)
S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I  D SET^RCAMDTH
"^DD",2,2,.351,1,7,2)
S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I  D ERR^RCAMDTH
"^DD",2,2,.351,1,7,3)
ACCOUNTS RECEIVABLE DEATH NOTIFICATION
"^DD",2,2,.351,1,7,"%D",0)
^^3^3^2930722^^^^
"^DD",2,2,.351,1,7,"%D",1,0)
This cross-reference is used to notify the Accounts Receivable package (v4 or
"^DD",2,2,.351,1,7,"%D",2,0)
higher) of a patient's death so that the patient's account may be reviewed for
"^DD",2,2,.351,1,7,"%D",3,0)
appropriate action. 
"^DD",2,2,.351,1,7,"DT")
2930609
"^DD",2,2,.351,1,8,0)
2^ADEP^MUMPS
"^DD",2,2,.351,1,8,1)
D SET^DGDEPINA
"^DD",2,2,.351,1,8,2)
D KILL^DGDEPINA
"^DD",2,2,.351,1,8,"%D",0)
^^1^1^2941114^
"^DD",2,2,.351,1,8,"%D",1,0)
This is used to updated the effective dates in file 408.12.
"^DD",2,2,.351,1,8,"DT")
2941114
"^DD",2,2,.351,1,9,0)
2^AENR351^MUMPS
"^DD",2,2,.351,1,9,1)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.351,1,9,2)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.351,1,9,3)
DO NOT DELETE
"^DD",2,2,.351,1,9,"%D",0)
^^1^1^2970630^^^^
"^DD",2,2,.351,1,9,"%D",1,0)
Used to update the patient's enrollment.
"^DD",2,2,.351,1,9,"DT")
2970630
"^DD",2,2,.351,1,10,0)
2^DG714^MUMPS
"^DD",2,2,.351,1,10,1)
D START^DGMTDELS(DA)
"^DD",2,2,.351,1,10,2)
Q
"^DD",2,2,.351,1,10,3)
Deletes last REQUIRED means test
"^DD",2,2,.351,1,10,"DT")
3060814
"^DD",2,2,.351,1,52,0)
2^APSOD^MUMPS
"^DD",2,2,.351,1,52,1)
I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOCAN3(DA)
"^DD",2,2,.351,1,52,2)
I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOAUTOC(DA)
"^DD",2,2,.351,1,52,3)
Discontinues Outpatient Medications.
"^DD",2,2,.351,1,52,"%D",0)
^^3^3^2961122^^^^
"^DD",2,2,.351,1,52,"%D",1,0)
This xref is used to discontinue all active outpatient medications whenever
"^DD",2,2,.351,1,52,"%D",2,0)
a date of death is entered for the patient.  This xref is used with v7 of
"^DD",2,2,.351,1,52,"%D",3,0)
Outpatient Pharmacy (DBIA #1624).
"^DD",2,2,.351,1,52,"%D",4,0)
Kill logic updated with DG*5.3*455.  Mail message sent to pharmacy when date
"^DD",2,2,.351,1,52,"%D",5,0)
of death is deleted to holders of PSORPH key.
"^DD",2,2,.351,1,52,"DT")
3020926
"^DD",2,2,.351,1,301,0)
2^IVM351^MUMPS
"^DD",2,2,.351,1,301,1)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.351,1,301,2)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.351,1,301,"%D",0)
^^5^5^2930605^
"^DD",2,2,.351,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.351,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.351,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.351,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.351,1,301,"DT")
2930605
"^DD",2,2,.351,1,991,0)
2^AVAFC351^MUMPS
"^DD",2,2,.351,1,991,1)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.351,1,991,2)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.351,1,991,"%D",0)
^^15^15^2990204^^
"^DD",2,2,.351,1,991,"%D",1,0)
This cross reference is used to remember that changes were made to the
"^DD",2,2,.351,1,991,"%D",2,0)
PATIENT file (#2) outside of the Registration process.  Execution of this
"^DD",2,2,.351,1,991,"%D",3,0)
cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
"^DD",2,2,.351,1,991,"%D",4,0)
and mark it as requiring transmission of an HL7 ADT-A08 message.
"^DD",2,2,.351,1,991,"%D",5,0)
 
"^DD",2,2,.351,1,991,"%D",6,0)
The local variable VAFCFLG will be set to 1 if the cross reference is
"^DD",2,2,.351,1,991,"%D",7,0)
not executed because the change is being made from within the Registration
"^DD",2,2,.351,1,991,"%D",8,0)
process.
"^DD",2,2,.351,1,991,"%D",9,0)
 
"^DD",2,2,.351,1,991,"%D",10,0)
Execution of this cross reference can be prevented by setting the local
"^DD",2,2,.351,1,991,"%D",11,0)
variable VAFCA08 equal to 1.
"^DD",2,2,.351,1,991,"%D",12,0)
  
"^DD",2,2,.351,1,991,"%D",13,0)
The local variable VAFCF is used to identify the field edited.
"^DD",2,2,.351,1,991,"%D",14,0)
This data is stored in the FIELD(S) EDITED (#2.1) field in the 
"^DD",2,2,.351,1,991,"%D",15,0)
ADT/HL7 PIVOT file (#391.71).
"^DD",2,2,.351,1,991,"DT")
2990204
"^DD",2,2,.351,1,992,0)
2^ADGRU351^MUMPS
"^DD",2,2,.351,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.351,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.351,1,992,"%D",0)
^^9^9^2990920^
"^DD",2,2,.351,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.351,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.351,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.351,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.351,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.351,1,992,"%D",6,0)
interface.
"^DD",2,2,.351,1,992,"%D",7,0)
 
"^DD",2,2,.351,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.351,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.351,1,992,"DT")
2990920
"^DD",2,2,.351,3)
Enter the date the patient died.  Date must not be before date of birth.
"^DD",2,2,.351,5,1,0)
405^.01^3
"^DD",2,2,.351,5,2,0)
405^.18^2
"^DD",2,2,.351,21,0)
^^6^6^3110119^
"^DD",2,2,.351,21,1,0)
Enter the date the patient died.  Date needs to be a precise date, i.e. 
"^DD",2,2,.351,21,2,0)
a day, month, and year MUST be included.
"^DD",2,2,.351,21,3,0)
Date of Death can not be prior to
"^DD",2,2,.351,21,4,0)
        P&T Effective Date
"^DD",2,2,.351,21,5,0)
        Date Ruled Incompetent (Civil and VA)
"^DD",2,2,.351,21,6,0)
        Date of Birth
"^DD",2,2,.351,"AUDIT")
y
"^DD",2,2,.351,"DT")
3110119
"^DD",27.11,27.11,.01,0)
ENROLLMENT APPLICATION DATE^RDIX^^0;1^S %DT="EPX" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL K:X>DGTIME X K DGTIME,DGDATE I $G(X)>0 D ENRAPP^DGENDD
"^DD",27.11,27.11,.01,1,0)
^.1
"^DD",27.11,27.11,.01,1,1,0)
27.11^B
"^DD",27.11,27.11,.01,1,1,1)
S ^DGEN(27.11,"B",$E(X,1,30),DA)=""
"^DD",27.11,27.11,.01,1,1,2)
K ^DGEN(27.11,"B",$E(X,1,30),DA)
"^DD",27.11,27.11,.01,1,2,0)
27.11^AENR01^MUMPS
"^DD",27.11,27.11,.01,1,2,1)
D E2711^DGRTRIG(DA)
"^DD",27.11,27.11,.01,1,2,2)
D E2711^DGRTRIG(DA)
"^DD",27.11,27.11,.01,1,2,3)
 DO NOT DELETE
"^DD",27.11,27.11,.01,1,2,"%D",0)
^.101^2^2^3050913^^^^
"^DD",27.11,27.11,.01,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",27.11,27.11,.01,1,2,"%D",2,0)
enrollment.
"^DD",27.11,27.11,.01,1,2,"DT")
3050913
"^DD",27.11,27.11,.01,3)
Enter the date of the application for enrollment. Date must not be before 10/1/1996 or before patient's DOB.
"^DD",27.11,27.11,.01,21,0)
^^9^9^3070605^
"^DD",27.11,27.11,.01,21,1,0)
 
"^DD",27.11,27.11,.01,21,2,0)
The date the enrollment application/registration was completed, i.e., the
"^DD",27.11,27.11,.01,21,3,0)
the signature date.
"^DD",27.11,27.11,.01,21,4,0)
Enrollment Application Date:
"^DD",27.11,27.11,.01,21,5,0)
   Must be a date prior or equal to the veterans 'Date of Death'
"^DD",27.11,27.11,.01,21,6,0)
   Must be a precise date, i.e. a day, month and year MUST be included 
"^DD",27.11,27.11,.01,21,7,0)
   Cannot be a date prior to the veterans 'Date of Birth'
"^DD",27.11,27.11,.01,21,8,0)
   Cannot be a date in the future
"^DD",27.11,27.11,.01,21,9,0)
   Cannot be a date prior to 10/1/1996
"^DD",27.11,27.11,.01,"DT")
3070531
"^DD",43,43,1301,0)
AO STA EXP DATE^DI^^ENR;1^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",43,43,1301,3)
(No range limit on date)
"^DD",43,43,1301,9)
^
"^DD",43,43,1301,21,0)
^^6^6^3090511^
"^DD",43,43,1301,21,1,0)
If populated, this field will be used as the expiration date for the 
"^DD",43,43,1301,21,2,0)
Special Treatment Authority (STA) for Agent Orange (AO) Veterans with an 
"^DD",43,43,1301,21,3,0)
AO exposure location of Vietnam.  New enrollments of AO Veterans with 
"^DD",43,43,1301,21,4,0)
an exposure location of Vietnam and no additional eligibility factors 
"^DD",43,43,1301,21,5,0)
will no longer be enrolled as a Priority Group 6 if the enrollment date 
"^DD",43,43,1301,21,6,0)
is greater than the expiration date.
"^DD",43,43,1301,"DT")
3091105
"^DD",43,43,1302,0)
SWAC STA EXP DATE^DI^^ENR;2^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",43,43,1302,3)
(No range limit on date)
"^DD",43,43,1302,9)
^
"^DD",43,43,1302,21,0)
^^5^5^3090511^
"^DD",43,43,1302,21,1,0)
If populated, this field will be used as the expiration date for the 
"^DD",43,43,1302,21,2,0)
Special Treatment Authority (STA) for Southwest Asia Condition (SWAC) 
"^DD",43,43,1302,21,3,0)
Veterans.  New enrollments of SWAC Veterans and no additional eligibility 
"^DD",43,43,1302,21,4,0)
factors will no longer be enrolled as a Priority Group 6 if the 
"^DD",43,43,1302,21,5,0)
enrollment date is greater than the expiration date.
"^DD",43,43,1302,"DT")
3090512
"^DD",391.23,391.23,0)
FIELD^^5^6
"^DD",391.23,391.23,0,"DDA")
N
"^DD",391.23,391.23,0,"DT")
3040319
"^DD",391.23,391.23,0,"IX","B",391.23,.01)

"^DD",391.23,391.23,0,"IX","D",391.23,5)

"^DD",391.23,391.23,0,"NM","DG REGISTER ONCE FIELD DEFINITION")

"^DD",391.23,391.23,0,"VRPK")
DG
"^DD",391.23,391.23,.01,0)
NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X
"^DD",391.23,391.23,.01,.1)
Description of Field
"^DD",391.23,391.23,.01,1,0)
^.1
"^DD",391.23,391.23,.01,1,1,0)
391.23^B
"^DD",391.23,391.23,.01,1,1,1)
S ^DGRO(391.23,"B",$E(X,1,30),DA)=""
"^DD",391.23,391.23,.01,1,1,2)
K ^DGRO(391.23,"B",$E(X,1,30),DA)
"^DD",391.23,391.23,.01,3)
NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION
"^DD",391.23,391.23,.01,"DT")
3040107
"^DD",391.23,391.23,1,0)
FILE NUMBER^RNJ13,5^^0;2^K:+X'=X!(X>9999999)!(X<0)!(X?.E1"."6.N) X
"^DD",391.23,391.23,1,.1)
File Number of File
"^DD",391.23,391.23,1,3)
Type a number between 0 and 9999999, 5 Decimal Digits
"^DD",391.23,391.23,1,"DT")
3040413
"^DD",391.23,391.23,2,0)
FIELD NUMBER^RNJ15,6^^0;3^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."7.N) X
"^DD",391.23,391.23,2,3)
Type a number between 0 and 99999999, 6 Decimal Digits
"^DD",391.23,391.23,2,"DT")
3040413
"^DD",391.23,391.23,3,0)
FIELD DESCRIPTION^F^^0;4^K:$L(X)>30!($L(X)<3) X
"^DD",391.23,391.23,3,3)
Answer must be 3-30 characters in length
"^DD",391.23,391.23,3,"DT")
3030827
"^DD",391.23,391.23,4,0)
Disable Field^S^0:No;1:Yes;^0;5^Q
"^DD",391.23,391.23,4,3)
Enter Yes to disable the entry of this field from the LST.
"^DD",391.23,391.23,4,"DT")
3030718
"^DD",391.23,391.23,5,0)
ORDER INDEX^RF^^0;6^K:$L(X)>2!($L(X)<1)!'(X?1A.N) X
"^DD",391.23,391.23,5,1,0)
^.1^^-1
"^DD",391.23,391.23,5,1,1,0)
391.23^D
"^DD",391.23,391.23,5,1,1,1)
S ^DGRO(391.23,"D",$E(X,1,30),DA)=""
"^DD",391.23,391.23,5,1,1,2)
K ^DGRO(391.23,"D",$E(X,1,30),DA)
"^DD",391.23,391.23,5,1,1,3)
Do not delete.
"^DD",391.23,391.23,5,1,1,"%D",0)
^.101^4^4^3040413^^^^
"^DD",391.23,391.23,5,1,1,"%D",1,0)
This cross reference is required to define the arrays passed between
"^DD",391.23,391.23,5,1,1,"%D",2,0)
FileMan calls in Register Once Messaging software.  The ORDER INDEX field
"^DD",391.23,391.23,5,1,1,"%D",3,0)
defines the order that groups of fields are loaded into the data base at
"^DD",391.23,391.23,5,1,1,"%D",4,0)
the Querying Site.
"^DD",391.23,391.23,5,1,1,"DT")
3040322
"^DD",391.23,391.23,5,3)
Enter one Alpha character (mandatory) followed by 1 Numeric (optional).
"^DD",391.23,391.23,5,21,0)
^.001^5^5^3040413^^^^
"^DD",391.23,391.23,5,21,1,0)
This field indexes the order that data must be loaded into the respective
"^DD",391.23,391.23,5,21,2,0)
fields at the Querying Site.
"^DD",391.23,391.23,5,21,3,0)
 
"^DD",391.23,391.23,5,21,4,0)
Is of the format 1 Alpha character followed by an optional Numeric
"^DD",391.23,391.23,5,21,5,0)
character.
"^DD",391.23,391.23,5,23,0)
^.001^41^41^3040413^^^^
"^DD",391.23,391.23,5,23,1,0)
Referenced by Register Once Messaging routine which loads data returned
"^DD",391.23,391.23,5,23,2,0)
from the Last Site Treated into the Querying Site.
"^DD",391.23,391.23,5,23,3,0)
 
"^DD",391.23,391.23,5,23,4,0)
Is of the format 1 Alpha character followed by an optional Numeric
"^DD",391.23,391.23,5,23,5,0)
character.
"^DD",391.23,391.23,5,23,6,0)
 
"^DD",391.23,391.23,5,23,7,0)
With exception of the Patient file, Indices used must contain a
"^DD",391.23,391.23,5,23,8,0)
single file, only.  The Patient file can be referenced across
"^DD",391.23,391.23,5,23,9,0)
multiple indices to set order of entry for fields in that file.
"^DD",391.23,391.23,5,23,10,0)
However, Register Once Messaging will not support other files
"^DD",391.23,391.23,5,23,11,0)
using multiple indices.
"^DD",391.23,391.23,5,23,12,0)
 
"^DD",391.23,391.23,5,23,13,0)
The ORDER INDEX field must contain a letter and optionally may be
"^DD",391.23,391.23,5,23,14,0)
followed by a number.  The optional number is not used with initial
"^DD",391.23,391.23,5,23,15,0)
release but is allowed so that further levels of order may be added
"^DD",391.23,391.23,5,23,16,0)
within a specific "letter group" for the Patient file.
"^DD",391.23,391.23,5,23,17,0)
 
"^DD",391.23,391.23,5,23,18,0)
The DG REGISTER ONCE FIELD DEFINITION file is released with ORDER
"^DD",391.23,391.23,5,23,19,0)
INDEX defined for each field.  Groups of fields in the Patient file
"^DD",391.23,391.23,5,23,20,0)
has been defined with upper case letters.  Fields in other files
"^DD",391.23,391.23,5,23,21,0)
have been defined with lower case letters.  This is done to support
"^DD",391.23,391.23,5,23,22,0)
greater expansion for entries in the Patient file.  Use of upper case
"^DD",391.23,391.23,5,23,23,0)
letters for fields in files other than the Patient file should be
"^DD",391.23,391.23,5,23,24,0)
avoided unless those fields are depended upon by Patient file fields.
"^DD",391.23,391.23,5,23,25,0)
 
"^DD",391.23,391.23,5,23,26,0)
Reasons for the Constraints on defining ORDER INDEX values:
"^DD",391.23,391.23,5,23,27,0)
  Register Once Messaging is designed so that this field's value
"^DD",391.23,391.23,5,23,28,0)
  assumes a record EDIT for the PATIENT file (#2), ONLY.  Fields
"^DD",391.23,391.23,5,23,29,0)
  in other files and PATIENT file multiples will be added as new
"^DD",391.23,391.23,5,23,30,0)
  records.  Examples of other files include the DG SECURITY LOG
"^DD",391.23,391.23,5,23,31,0)
  file (#38.1).  Examples of PATIENT file multiples include the
"^DD",391.23,391.23,5,23,32,0)
  Patient file ALIAS multiple (2.01).
"^DD",391.23,391.23,5,23,33,0)
 
"^DD",391.23,391.23,5,23,34,0)
  The ORDER INDEX will NOT support adding data to existing records
"^DD",391.23,391.23,5,23,35,0)
  in any file or multiple EXCEPT the PATIENT file.  This means that
"^DD",391.23,391.23,5,23,36,0)
  only fields in the Patient file can have an ORDER INDEX different
"^DD",391.23,391.23,5,23,37,0)
  from another field in the Patient file.
"^DD",391.23,391.23,5,23,38,0)
 
"^DD",391.23,391.23,5,23,39,0)
Ordering modifications for the fields defined in this file MUST be designed
"^DD",391.23,391.23,5,23,40,0)
according to this ordering specification or a technical redesign of ROM
"^DD",391.23,391.23,5,23,41,0)
will be necessary.
"^DD",391.23,391.23,5,"DT")
3040413
"^DD",408.13,408.13,1.2,0)
STREET ADDRESS [LINE 1]^FX^^1;2^K:X[""""!($A(X)=45) X K:$L(X)>30!($L(X)<3) X
"^DD",408.13,408.13,1.2,1,0)
^.1
"^DD",408.13,408.13,1.2,1,1,0)
408.13^AC^MUMPS
"^DD",408.13,408.13,1.2,1,1,1)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.2,1,1,2)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.2,1,1,"%D",0)
^^2^2^3080815^
"^DD",408.13,408.13,1.2,1,1,"%D",1,0)
Sets the Spouse Address Last Updated DT/TM field (1.9). If $D(IVMSPFLG)
"^DD",408.13,408.13,1.2,1,1,"%D",2,0)
- ORU~Z10 - don't update DT/TM with trigger.
"^DD",408.13,408.13,1.2,1,1,"DT")
3080812
"^DD",408.13,408.13,1.2,3)
Answer must be 3-30 characters in length.
"^DD",408.13,408.13,1.2,4)
D HELPSA1^DGRPEIS3
"^DD",408.13,408.13,1.2,21,0)
^^1^1^3080818^
"^DD",408.13,408.13,1.2,21,1,0)
The first line of the spouse's residence street address.
"^DD",408.13,408.13,1.2,"DEL",1,0)
D SDD^DGLOCK2 I '$D(X)
"^DD",408.13,408.13,1.2,"DT")
3080818
"^DD",408.13,408.13,1.3,0)
STREET ADDRESS [LINE 2]^FX^^1;3^K:X[""""!($A(X)=45) X K:$L(X)>30!($L(X)<3) X
"^DD",408.13,408.13,1.3,1,0)
^.1
"^DD",408.13,408.13,1.3,1,1,0)
408.13^AD^MUMPS
"^DD",408.13,408.13,1.3,1,1,1)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.3,1,1,2)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.3,1,1,"%D",0)
^^2^2^3080815^
"^DD",408.13,408.13,1.3,1,1,"%D",1,0)
Sets the Spouse Address Last Updated DT/TM field (1.9). If $D(IVMSPFLG)
"^DD",408.13,408.13,1.3,1,1,"%D",2,0)
- ORU~Z10 - don't update DT/TM with trigger.
"^DD",408.13,408.13,1.3,1,1,"DT")
3080812
"^DD",408.13,408.13,1.3,3)
Answer must be 3-30 characters in length.
"^DD",408.13,408.13,1.3,4)
D HELPSA2^DGRPEIS3
"^DD",408.13,408.13,1.3,21,0)
^^1^1^3080818^
"^DD",408.13,408.13,1.3,21,1,0)
The second line of the spouse's residence street address.
"^DD",408.13,408.13,1.3,"DEL",1,0)
D SDD^DGLOCK2 I '$D(X)
"^DD",408.13,408.13,1.3,"DT")
3080818
"^DD",408.13,408.13,1.4,0)
STREET ADDRESS [LINE 3]^F^^1;4^K:$L(X)>30!($L(X)<3) X
"^DD",408.13,408.13,1.4,1,0)
^.1
"^DD",408.13,408.13,1.4,1,1,0)
408.13^AE^MUMPS
"^DD",408.13,408.13,1.4,1,1,1)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.4,1,1,2)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.4,1,1,"%D",0)
^^2^2^3080815^
"^DD",408.13,408.13,1.4,1,1,"%D",1,0)
Sets the Spouse Address Last Updated DT/TM field (1.9). If $D(IVMSPFLG)
"^DD",408.13,408.13,1.4,1,1,"%D",2,0)
- ORU~Z10 - don't update DT/TM with trigger.
"^DD",408.13,408.13,1.4,1,1,"DT")
3080812
"^DD",408.13,408.13,1.4,3)
Answer must be 3-30 characters in length.
"^DD",408.13,408.13,1.4,4)
D HELPSA3^DGRPEIS3
"^DD",408.13,408.13,1.4,21,0)
^^1^1^3080818^
"^DD",408.13,408.13,1.4,21,1,0)
The third line of the spouse's residence street address.
"^DD",408.13,408.13,1.4,"DEL",1,0)
D SDD^DGLOCK2 I '$D(X)
"^DD",408.13,408.13,1.4,"DT")
3080818
"^DD",408.13,408.13,1.5,0)
CITY^F^^1;5^K:$L(X)>30!($L(X)<3) X
"^DD",408.13,408.13,1.5,1,0)
^.1
"^DD",408.13,408.13,1.5,1,1,0)
408.13^AF^MUMPS
"^DD",408.13,408.13,1.5,1,1,1)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.5,1,1,2)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.5,1,1,"%D",0)
^^2^2^3080815^
"^DD",408.13,408.13,1.5,1,1,"%D",1,0)
Sets the Spouse Address Last Updated DT/TM field (1.9). If $D(IVMSPFLG)
"^DD",408.13,408.13,1.5,1,1,"%D",2,0)
- ORU~Z10 - don't update DT/TM with trigger.
"^DD",408.13,408.13,1.5,1,1,"DT")
3080812
"^DD",408.13,408.13,1.5,3)
Answer must be 3-30 characters in length.
"^DD",408.13,408.13,1.5,4)
D HELPCITY^DGRPEIS3
"^DD",408.13,408.13,1.5,21,0)
^^1^1^3080818^
"^DD",408.13,408.13,1.5,21,1,0)
The city where the spouse's residence is located.
"^DD",408.13,408.13,1.5,"DEL",1,0)
D SDD^DGLOCK2 I '$D(X)
"^DD",408.13,408.13,1.5,"DT")
3080818
"^DD",408.13,408.13,1.6,0)
STATE^P5'^DIC(5,^1;6^Q
"^DD",408.13,408.13,1.6,1,0)
^.1
"^DD",408.13,408.13,1.6,1,1,0)
408.13^AG^MUMPS
"^DD",408.13,408.13,1.6,1,1,1)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.6,1,1,2)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.6,1,1,"%D",0)
^^2^2^3080815^
"^DD",408.13,408.13,1.6,1,1,"%D",1,0)
Sets the Spouse Address Last Updated DT/TM field (1.9). If $D(IVMSPFLG)
"^DD",408.13,408.13,1.6,1,1,"%D",2,0)
- ORU~Z10 - don't update DT/TM with trigger.
"^DD",408.13,408.13,1.6,1,1,"DT")
3080812
"^DD",408.13,408.13,1.6,3)

"^DD",408.13,408.13,1.6,4)
D HELPSTAT^DGRPEIS3
"^DD",408.13,408.13,1.6,21,0)
^^1^1^3080818^
"^DD",408.13,408.13,1.6,21,1,0)
The state where the spouse's residence is located.
"^DD",408.13,408.13,1.6,"DEL",1,0)
D SDD^DGLOCK2 I '$D(X)
"^DD",408.13,408.13,1.6,"DT")
3080818
"^DD",408.13,408.13,1.7,0)
ZIP^F^^1;7^K:$L(X)>10!($L(X)<5)!'((X?5N)!(X?5N1"-"4N)) X
"^DD",408.13,408.13,1.7,1,0)
^.1
"^DD",408.13,408.13,1.7,1,1,0)
408.13^AH^MUMPS
"^DD",408.13,408.13,1.7,1,1,1)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.7,1,1,2)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.7,1,1,"%D",0)
^^2^2^3080815^
"^DD",408.13,408.13,1.7,1,1,"%D",1,0)
Sets the Spouse Address Last Updated DT/TM field (1.9). If $D(IVMSPFLG)
"^DD",408.13,408.13,1.7,1,1,"%D",2,0)
- ORU~Z10 - don't update DT/TM with trigger.
"^DD",408.13,408.13,1.7,1,1,"DT")
3080812
"^DD",408.13,408.13,1.7,3)
Answer must be 5-10 characters in length.
"^DD",408.13,408.13,1.7,4)
D HELPZIP^DGRPEIS3
"^DD",408.13,408.13,1.7,21,0)
^^1^1^3080818^
"^DD",408.13,408.13,1.7,21,1,0)
The zip code where the spouse's residence is located.
"^DD",408.13,408.13,1.7,"DT")
3080818
"^DD",408.13,408.13,1.8,0)
TELEPHONE NUMBER^FX^^1;8^K:$L(X)>20!($L(X)<4) X
"^DD",408.13,408.13,1.8,1,0)
^.1
"^DD",408.13,408.13,1.8,1,1,0)
408.13^AI^MUMPS
"^DD",408.13,408.13,1.8,1,1,1)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.8,1,1,2)
D TRIGGER^IVMCM9(DA) Q
"^DD",408.13,408.13,1.8,1,1,"%D",0)
^^2^2^3080815^
"^DD",408.13,408.13,1.8,1,1,"%D",1,0)
Sets the Spouse Address Last Updated DT/TM field (1.9). If $D(IVMSPFLG)
"^DD",408.13,408.13,1.8,1,1,"%D",2,0)
- ORU~Z10 - don't update DT/TM with trigger.
"^DD",408.13,408.13,1.8,1,1,"DT")
3080812
"^DD",408.13,408.13,1.8,3)
Answer must be 4-20 characters in length.
"^DD",408.13,408.13,1.8,4)
D HELPPHON^DGRPEIS3
"^DD",408.13,408.13,1.8,21,0)
^^1^1^3080818^
"^DD",408.13,408.13,1.8,21,1,0)
The telephone number for the spouse's residence.
"^DD",408.13,408.13,1.8,23,0)
^^7^7^3080815^
"^DD",408.13,408.13,1.8,23,1,0)
May be exactly 10 digits or may be formatted up to 13 characters as:
"^DD",408.13,408.13,1.8,23,2,0)
 
"^DD",408.13,408.13,1.8,23,3,0)
   (nnn)nnn-nnnn
"^DD",408.13,408.13,1.8,23,4,0)
   i.e., (<area_code>)<exchange>-<number>
"^DD",408.13,408.13,1.8,23,5,0)
   or
"^DD",408.13,408.13,1.8,23,6,0)
   nnn.nnn.nnnn
"^DD",408.13,408.13,1.8,23,7,0)
   i.e., <area_code>.<exchange>.<number>
"^DD",408.13,408.13,1.8,"DT")
3080818
"^DD",408.13,408.13,1.9,0)
SPOUSE ADDR LAST DT/TM UPDATED^D^^1;9^S %DT="ESTX" D ^%DT S X=Y K:X<1 X
"^DD",408.13,408.13,1.9,3)

"^DD",408.13,408.13,1.9,21,0)
^.001^12^12^3100526^^
"^DD",408.13,408.13,1.9,21,1,0)
This field will contain the date and time of the last update to the 
"^DD",408.13,408.13,1.9,21,2,0)
Spouse's address.
"^DD",408.13,408.13,1.9,21,3,0)
 
"^DD",408.13,408.13,1.9,21,4,0)
VistA shall upload all of the Spouse Address fields during the HL7 Z10 
"^DD",408.13,408.13,1.9,21,5,0)
receiver process if
"^DD",408.13,408.13,1.9,21,6,0)
1. the Address Line 1 (field 1.2) is NOT null
"^DD",408.13,408.13,1.9,21,7,0)
2. the received Changed Date/Time is greater than the Spouse Address Last 
"^DD",408.13,408.13,1.9,21,8,0)
   Date/Time Updated that is on VistA.
"^DD",408.13,408.13,1.9,21,9,0)
 
"^DD",408.13,408.13,1.9,21,10,0)
Any change to the following Spouse Address fields will trigger an update:
"^DD",408.13,408.13,1.9,21,11,0)
Street Address [Line 1], Street Address [Line 2], Street Address [Line 3],
"^DD",408.13,408.13,1.9,21,12,0)
City, State, Zip, and Telephone Number
"^DD",408.13,408.13,1.9,"DT")
3080814
"^DIC",391.23,391.23,0)
DG REGISTER ONCE FIELD DEFINITION^391.23
"^DIC",391.23,391.23,0,"GL")
^DGRO(391.23,
"^DIC",391.23,391.23,"%",0)
^1.005^^0
"^DIC",391.23,391.23,"%D",0)
^1.001^6^6^3040413^^^^
"^DIC",391.23,391.23,"%D",1,0)
This file is used to define the fields that are collected at a Last Site
"^DIC",391.23,391.23,"%D",2,0)
Treated and loaded into a Querying Site via Register Once Messaging.
"^DIC",391.23,391.23,"%D",3,0)
 
"^DIC",391.23,391.23,"%D",4,0)
NOTICE: This file is part of an implementation of a Nationally 
"^DIC",391.23,391.23,"%D",5,0)
        Controlled Procedure.  Local modifications to this file 
"^DIC",391.23,391.23,"%D",6,0)
        are prohibited per VHA Directive 10-93-142.  
"^DIC",391.23,"B","DG REGISTER ONCE FIELD DEFINITION",391.23)

**INSTALL NAME**
IVM*2.0*121
"BLD",7093,0)
IVM*2.0*121^INCOME VERIFICATION MATCH^0^3110201^y
"BLD",7093,4,0)
^9.64PA^^
"BLD",7093,6.3)
45
"BLD",7093,"KRN",0)
^9.67PA^8989.52^19
"BLD",7093,"KRN",.4,0)
.4
"BLD",7093,"KRN",.401,0)
.401
"BLD",7093,"KRN",.402,0)
.402
"BLD",7093,"KRN",.403,0)
.403
"BLD",7093,"KRN",.5,0)
.5
"BLD",7093,"KRN",.84,0)
.84
"BLD",7093,"KRN",3.6,0)
3.6
"BLD",7093,"KRN",3.8,0)
3.8
"BLD",7093,"KRN",9.2,0)
9.2
"BLD",7093,"KRN",9.8,0)
9.8
"BLD",7093,"KRN",9.8,"NM",0)
^9.68A^12^12
"BLD",7093,"KRN",9.8,"NM",1,0)
IVMPTRN8^^0^B74827499
"BLD",7093,"KRN",9.8,"NM",2,0)
IVMCM9^^0^B15363550
"BLD",7093,"KRN",9.8,"NM",3,0)
IVMLERR^^0^B7302107
"BLD",7093,"KRN",9.8,"NM",4,0)
IVMLERR1^^0^B41105016
"BLD",7093,"KRN",9.8,"NM",5,0)
IVMLERR2^^0^B29385999
"BLD",7093,"KRN",9.8,"NM",6,0)
IVMCM2^^0^B31637468
"BLD",7093,"KRN",9.8,"NM",7,0)
IVMLINS1^^0^B30151402
"BLD",7093,"KRN",9.8,"NM",8,0)
IVMPREC6^^0^B143009000
"BLD",7093,"KRN",9.8,"NM",9,0)
IVMPREC8^^0^B186534384
"BLD",7093,"KRN",9.8,"NM",10,0)
IVMPREC9^^0^B63018866
"BLD",7093,"KRN",9.8,"NM",11,0)
IVMPRECA^^0^B87129700
"BLD",7093,"KRN",9.8,"NM",12,0)
IVMLINS3^^0^B12231839
"BLD",7093,"KRN",9.8,"NM","B","IVMCM2",6)

"BLD",7093,"KRN",9.8,"NM","B","IVMCM9",2)

"BLD",7093,"KRN",9.8,"NM","B","IVMLERR",3)

"BLD",7093,"KRN",9.8,"NM","B","IVMLERR1",4)

"BLD",7093,"KRN",9.8,"NM","B","IVMLERR2",5)

"BLD",7093,"KRN",9.8,"NM","B","IVMLINS1",7)

"BLD",7093,"KRN",9.8,"NM","B","IVMLINS3",12)

"BLD",7093,"KRN",9.8,"NM","B","IVMPREC6",8)

"BLD",7093,"KRN",9.8,"NM","B","IVMPREC8",9)

"BLD",7093,"KRN",9.8,"NM","B","IVMPREC9",10)

"BLD",7093,"KRN",9.8,"NM","B","IVMPRECA",11)

"BLD",7093,"KRN",9.8,"NM","B","IVMPTRN8",1)

"BLD",7093,"KRN",19,0)
19
"BLD",7093,"KRN",19,"NM",0)
^9.68A^^
"BLD",7093,"KRN",19.1,0)
19.1
"BLD",7093,"KRN",101,0)
101
"BLD",7093,"KRN",409.61,0)
409.61
"BLD",7093,"KRN",771,0)
771
"BLD",7093,"KRN",870,0)
870
"BLD",7093,"KRN",8989.51,0)
8989.51
"BLD",7093,"KRN",8989.52,0)
8989.52
"BLD",7093,"KRN",8994,0)
8994
"BLD",7093,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",7093,"KRN","B",3.6,3.6)

"BLD",7093,"KRN","B",3.8,3.8)

"BLD",7093,"KRN","B",9.2,9.2)

"BLD",7093,"KRN","B",9.8,9.8)

"BLD",7093,"KRN","B",19,19)

"BLD",7093,"KRN","B",19.1,19.1)

"BLD",7093,"KRN","B",101,101)

"BLD",7093,"KRN","B",409.61,409.61)

"BLD",7093,"KRN","B",771,771)

"BLD",7093,"KRN","B",870,870)

"BLD",7093,"KRN","B",8989.51,8989.51)

"BLD",7093,"KRN","B",8989.52,8989.52)

"BLD",7093,"KRN","B",8994,8994)

"BLD",7093,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",7093,"QUES",0)
^9.62^^
"BLD",7093,"REQB",0)
^9.611^5^5
"BLD",7093,"REQB",1,0)
IVM*2.0*9^2
"BLD",7093,"REQB",2,0)
IVM*2.0*115^2
"BLD",7093,"REQB",3,0)
IVM*2.0*111^2
"BLD",7093,"REQB",4,0)
IVM*2.0*139^2
"BLD",7093,"REQB",5,0)
IVM*2.0*144^2
"BLD",7093,"REQB","B","IVM*2.0*111",3)

"BLD",7093,"REQB","B","IVM*2.0*115",2)

"BLD",7093,"REQB","B","IVM*2.0*139",4)

"BLD",7093,"REQB","B","IVM*2.0*144",5)

"BLD",7093,"REQB","B","IVM*2.0*9",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)
121^3110201
"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")
12
"RTN","IVMCM2")
0^6^B31637468
"RTN","IVMCM2",1,0)
IVMCM2 ;ALB/SEK,CKN,TDM - ADD NEW DCD DEPENDENT TO INCOME PERSON FILE ; 3/18/10 2:07pm
"RTN","IVMCM2",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**17,105,115,139,121**;21-OCT-94;Build 45
"RTN","IVMCM2",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMCM2",4,0)
 ;
"RTN","IVMCM2",5,0)
EN ; this routine will add entries to INCOME PERSON file (408.13) for
"RTN","IVMCM2",6,0)
 ; new dependents (spouse/children).  if DCD demo data (name, dob, 
"RTN","IVMCM2",7,0)
 ; ssn, sex) is different than VAMC data, 408.13 will be changed to
"RTN","IVMCM2",8,0)
 ; contain the DCD data.  the MEANS TEST CHANGES file (408.41) will
"RTN","IVMCM2",9,0)
 ; contain both values.
"RTN","IVMCM2",10,0)
 ;
"RTN","IVMCM2",11,0)
INPIEN ; get INCOME PERSON IEN
"RTN","IVMCM2",12,0)
 ; if PATIENT RELATION IEN not in ZDP
"RTN","IVMCM2",13,0)
 ;    add dependent to INCOME PERSON file if dependent not found
"RTN","IVMCM2",14,0)
 ;    dependent found if dob, sex, & relationship (408.12) match
"RTN","IVMCM2",15,0)
 ;
"RTN","IVMCM2",16,0)
 ;     Input    DFN     IEN of file #2
"RTN","IVMCM2",17,0)
 ;              IVMSEG  dependent's ZDP segment
"RTN","IVMCM2",18,0)
 ;
"RTN","IVMCM2",19,0)
 ; ivmflg1=1 have 408.13 ien when exit (found or added)
"RTN","IVMCM2",20,0)
 ; ivmflg2=1 dep record must be added to 408.12
"RTN","IVMCM2",21,0)
 ; ivmflg5=1 spouse ZDP incomplete(not dependent) - always spouse records
"RTN","IVMCM2",22,0)
 N IVMSPFLG,IVMSPMNM
"RTN","IVMCM2",23,0)
 N IVMZDP13,IVMSADL1,IVMSADL2,IVMSADL3,IVMSCITY,IVMSST,IVMSZIP,IVMSALU,IVMSTELE
"RTN","IVMCM2",24,0)
 N IVMAL113,IVMAL213,IVMAL313,IVMCTY13,IVMST13,IVMZIP13,IVMTEL13,IVMALU13
"RTN","IVMCM2",25,0)
 S (IVMFLG1,IVMFLG2,IVMFLG5)=0
"RTN","IVMCM2",26,0)
 S IVMSPFLG=1 ; VOA
"RTN","IVMCM2",27,0)
 S DGPRI=$P(IVMSEG,"^",7) ; ien of patient relation file
"RTN","IVMCM2",28,0)
 ;
"RTN","IVMCM2",29,0)
 S IVMNM=$$FMNAME^HLFNC($P(IVMSEG,"^",2)),IVMSEX=$P(IVMSEG,"^",3),IVMDOB=$$FMDATE^HLFNC($P(IVMSEG,"^",4)),IVMSSN=$P(IVMSEG,"^",5)
"RTN","IVMCM2",30,0)
 S IVMPSSNR=$P(IVMSEG,"^",10) ;Pseudo SSN Reason IVM*2*105
"RTN","IVMCM2",31,0)
 ;if there is a valid Pseudo SSN Reason, then append a "P" to the end
"RTN","IVMCM2",32,0)
 ;of the SSN so that it cam be recognized on VistA as a pseudo - IVM*2*115
"RTN","IVMCM2",33,0)
 S IVMSSN=$G(IVMSSN)_$S($G(IVMPSSNR)="N":"P",$G(IVMPSSNR)="R":"P",$G(IVMPSSNR)="S":"P",1:"")
"RTN","IVMCM2",34,0)
 S IVMEFFDT=$$FMDATE^HLFNC($P(IVMSEG,"^",9)),IVMRELN=$P(IVMSEG,"^",6)
"RTN","IVMCM2",35,0)
 S IVMSPMNM=$P(IVMSEG,"^",8) ;Spouse Maiden Name IVM*2*105
"RTN","IVMCM2",36,0)
 ;If not valid value, set it to null
"RTN","IVMCM2",37,0)
 I IVMPSSNR]"",IVMPSSNR'="R",IVMPSSNR'="S",IVMPSSNR'="N" S IVMPSSNR=""
"RTN","IVMCM2",38,0)
 S IVMSSNVS=$P(IVMSEG,"^",12) ;SSN Verification Status IVM*2*115
"RTN","IVMCM2",39,0)
 ;If not valid value, set it to null
"RTN","IVMCM2",40,0)
 I IVMSSNVS]"",IVMSSNVS'=2,IVMSSNVS'=4 S IVMSSNVS=""  ;IVM*2*115
"RTN","IVMCM2",41,0)
 ;
"RTN","IVMCM2",42,0)
 I IVMSPCHV="S"&((IVMNM']"")!(IVMSEX']"")!(IVMDOB']"")) S IVMFLG5=1 Q
"RTN","IVMCM2",43,0)
 ;
"RTN","IVMCM2",44,0)
 ; VOA Spouse additional info
"RTN","IVMCM2",45,0)
 S IVMZDP13=$P(IVMSEG,"^",13)
"RTN","IVMCM2",46,0)
 S IVMSADL1=$P(IVMZDP13,$E(HLECH,1),1) ; Addr Line 1 - 13.1
"RTN","IVMCM2",47,0)
 S IVMSADL2=$P(IVMZDP13,$E(HLECH,1),2) ; Addr Line 2 - 13.2
"RTN","IVMCM2",48,0)
 S IVMSADL3=$P(IVMZDP13,$E(HLECH,1),8) ; Addr Line 3 - 13.8
"RTN","IVMCM2",49,0)
 S IVMSCITY=$P(IVMZDP13,$E(HLECH,1),3) ; City - 13.3
"RTN","IVMCM2",50,0)
 S IVMSST=$P(IVMZDP13,$E(HLECH,1),4) ; State - 13.4
"RTN","IVMCM2",51,0)
 S IVMSZIP=$P(IVMZDP13,$E(HLECH,1),5) ; Zip - 13.5
"RTN","IVMCM2",52,0)
 S IVMSALU=$P(IVMZDP13,$E(HLECH,1),12)
"RTN","IVMCM2",53,0)
 S IVMSALU=$P(IVMSALU,$E(HLECH,2),1) ; Addr Last DT/TM Upt - 13.12.1
"RTN","IVMCM2",54,0)
 S IVMSALU=$$FMDATE^HLFNC(IVMSALU) ; Convert DT/TM from HL7 to FM
"RTN","IVMCM2",55,0)
 S IVMSTELE=$P(IVMSEG,"^",14)
"RTN","IVMCM2",56,0)
 S IVMSTELE=$P(IVMSTELE,$E(HLECH,1),1) ; Telephone - 14.1
"RTN","IVMCM2",57,0)
 ;
"RTN","IVMCM2",58,0)
 I 'DGPRI G NOIEN
"RTN","IVMCM2",59,0)
 ;
"RTN","IVMCM2",60,0)
 ; if ien of patient relation file (dgpri) transmitted by IVM Center
"RTN","IVMCM2",61,0)
 ; and found in 408.12, get ien of income person.  if DCD demo data
"RTN","IVMCM2",62,0)
 ; is different, change in 408.13 & add to 408.41
"RTN","IVMCM2",63,0)
 ; ivmprn is 0 node of 408.12
"RTN","IVMCM2",64,0)
 ; dgipi is ien of 408.13
"RTN","IVMCM2",65,0)
 S IVMPRN=$G(^DGPR(408.12,+DGPRI,0))
"RTN","IVMCM2",66,0)
 I IVMPRN]"" D GETIPI Q:$D(IVMFERR)  S DGIPI=+$P($P(IVMPRN,"^",3),";"),IVMFLG1=1,IVMRELO=$P(IVMPRN,"^",2) D AUDITP^IVMCM9,AUDIT^IVMCM9 Q
"RTN","IVMCM2",67,0)
 ;
"RTN","IVMCM2",68,0)
NOIEN ; ien of patient relation file is not transmitted or transmitted and
"RTN","IVMCM2",69,0)
 ; not found
"RTN","IVMCM2",70,0)
 ; check if dependent in income person file
"RTN","IVMCM2",71,0)
 ; if dependent not found in 408.13, setup ivmstr =  0 node of 408.13
"RTN","IVMCM2",72,0)
 ; subscript of array IVMAR is ien of 408.12 transmitted by IVM Center or
"RTN","IVMCM2",73,0)
 ; created or found by upload.
"RTN","IVMCM2",74,0)
 ;
"RTN","IVMCM2",75,0)
 S DGPRI=0 F  S DGPRI=$O(^DGPR(408.12,"B",DFN,DGPRI)) Q:'DGPRI  D  Q:IVMFLG1!($D(IVMFERR))
"RTN","IVMCM2",76,0)
 .D GETIP
"RTN","IVMCM2",77,0)
 .Q:$D(IVMFERR)!($D(IVMAR(DGPRI)))!(IVMRELO=1)
"RTN","IVMCM2",78,0)
 .I IVMSEX=IVMSEX13&(IVMDOB=IVMDOB13)&(IVMRELN=IVMRELO) S IVMFLG1=1,IVMAR(DGPRI)=""
"RTN","IVMCM2",79,0)
 .Q
"RTN","IVMCM2",80,0)
 ;
"RTN","IVMCM2",81,0)
 ; found dependent in 408.13. if demo data different, change in 408.13
"RTN","IVMCM2",82,0)
 ; and add in 408.41
"RTN","IVMCM2",83,0)
 Q:$D(IVMFERR)
"RTN","IVMCM2",84,0)
 I IVMFLG1 S DGIPI=+$P($P(IVMPRN,"^",3),";") D AUDITP^IVMCM9,AUDIT1^IVMCM9 Q
"RTN","IVMCM2",85,0)
 ;
"RTN","IVMCM2",86,0)
 ; dependent not found. add record to 408.13
"RTN","IVMCM2",87,0)
 I 'IVMFLG1 D
"RTN","IVMCM2",88,0)
 .S $P(IVMSTR,"^")=IVMNM,$P(IVMSTR,"^",2)=IVMSEX,$P(IVMSTR,"^",3)=IVMDOB,$P(IVMSTR,"^",9)=IVMSSN,$P(IVMSTR,"^",10)=IVMPSSNR,$P(IVMSTR,"^",11)=IVMSSNVS
"RTN","IVMCM2",89,0)
 .S $P(IVMSTR1,"^")=IVMSPMNM
"RTN","IVMCM2",90,0)
 .S $P(IVMSTR1,"^",2)=IVMSADL1,$P(IVMSTR1,"^",3)=IVMSADL2,$P(IVMSTR1,"^",4)=IVMSADL3
"RTN","IVMCM2",91,0)
 .S $P(IVMSTR1,"^",5)=IVMSCITY,$P(IVMSTR1,"^",6)=IVMSST,$P(IVMSTR1,"^",7)=IVMSZIP,$P(IVMSTR1,"^",8)=IVMSTELE
"RTN","IVMCM2",92,0)
 .S $P(IVMSTR1,"^",9)=IVMSALU
"RTN","IVMCM2",93,0)
 .D ADDDEP
"RTN","IVMCM2",94,0)
 Q
"RTN","IVMCM2",95,0)
 ;
"RTN","IVMCM2",96,0)
ADDDEP ; add dependent to 408.13 file
"RTN","IVMCM2",97,0)
 ; In - DFN=IEN of File #2
"RTN","IVMCM2",98,0)
 ;      DGRP0ND=0 node of 408.13
"RTN","IVMCM2",99,0)
 ;      DGRP1ND=1 node of 408.13
"RTN","IVMCM2",100,0)
 ;Out - DGIPI=408.13 IEN
"RTN","IVMCM2",101,0)
 ;
"RTN","IVMCM2",102,0)
 N X,Y
"RTN","IVMCM2",103,0)
 S DGRP0ND=IVMSTR
"RTN","IVMCM2",104,0)
 S DGRP1ND=IVMSTR1
"RTN","IVMCM2",105,0)
 K DINUM
"RTN","IVMCM2",106,0)
 N CNT,I S CNT=0
"RTN","IVMCM2",107,0)
 F I=2,3,9 D
"RTN","IVMCM2",108,0)
 .S CNT=CNT+1,$P(DIC("DR"),";",CNT)=".0"_I_"////"_$P(DGRP0ND,U,I)
"RTN","IVMCM2",109,0)
 F I=10,11 D
"RTN","IVMCM2",110,0)
 .S CNT=CNT+1,$P(DIC("DR"),";",CNT)="."_I_"////"_$P(DGRP0ND,U,I)
"RTN","IVMCM2",111,0)
 F I=1:1:8 S DIC("DR")=DIC("DR")_";1."_I_"////"_$P(DGRP1ND,U,I)
"RTN","IVMCM2",112,0)
 S (DIK,DIC)="^DGPR(408.13,",DIC(0)="L",DLAYGO=408.13,X=$P(DGRP0ND,"^") K DD,DO D FILE^DICN S (DGIPI,DA)=+Y K DLAYGO
"RTN","IVMCM2",113,0)
 ;
"RTN","IVMCM2",114,0)
 ; if can't create stub notify site & IVM Center
"RTN","IVMCM2",115,0)
 I DGIPI'>0 D  Q
"RTN","IVMCM2",116,0)
 .S (IVMTEXT(6))="Can't create stub for file 408.13"
"RTN","IVMCM2",117,0)
 .D PROB^IVMCMC(IVMTEXT(6))
"RTN","IVMCM2",118,0)
 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
"RTN","IVMCM2",119,0)
 .S IVMFERR=""
"RTN","IVMCM2",120,0)
 S IVMFLG2=1 ; added dep to 408.13 must add to 408.12
"RTN","IVMCM2",121,0)
 K DIK,DIC
"RTN","IVMCM2",122,0)
 Q
"RTN","IVMCM2",123,0)
 ;
"RTN","IVMCM2",124,0)
 ;
"RTN","IVMCM2",125,0)
GETIP ; if can't find 408.12 record notify site & IVM Center
"RTN","IVMCM2",126,0)
 S IVMPRN=$G(^DGPR(408.12,+DGPRI,0))
"RTN","IVMCM2",127,0)
 S IVMRELO=$P(IVMPRN,"^",2)
"RTN","IVMCM2",128,0)
 I IVMPRN']"" D  Q
"RTN","IVMCM2",129,0)
 .S (IVMTEXT(6))="Can't find 408.12 record "_DGPRI
"RTN","IVMCM2",130,0)
 .D PROB^IVMCMC(IVMTEXT(6))
"RTN","IVMCM2",131,0)
 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
"RTN","IVMCM2",132,0)
 .S IVMFERR=""
"RTN","IVMCM2",133,0)
 Q:IVMRELO=1
"RTN","IVMCM2",134,0)
 ;
"RTN","IVMCM2",135,0)
GETIPI ; ivmseg13 is 0 node of income person file
"RTN","IVMCM2",136,0)
 ; get demo data in 408.13 & 408.12
"RTN","IVMCM2",137,0)
 S IVMSEG13=$$DEM^DGMTU1(DGPRI)
"RTN","IVMCM2",138,0)
 S IVMSG131=$$DEM1^DGMTU1(DGPRI) ;Get node 1
"RTN","IVMCM2",139,0)
 I IVMSEG13']"" D  Q
"RTN","IVMCM2",140,0)
 .S (IVMTEXT(6))="Can't find 408.13 record"
"RTN","IVMCM2",141,0)
 .D PROB^IVMCMC(IVMTEXT(6))
"RTN","IVMCM2",142,0)
 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
"RTN","IVMCM2",143,0)
 .S IVMFERR=""
"RTN","IVMCM2",144,0)
 S IVMSEX13=$P(IVMSEG13,"^",2),IVMDOB13=$P(IVMSEG13,"^",3),IVMSSN13=$P(IVMSEG13,"^",9),IVMPSR13=$P(IVMSEG13,"^",10),IVMSVS13=$P(IVMSEG13,"^",11)
"RTN","IVMCM2",145,0)
 S IVMSMN13=$P($G(IVMSG131),"^")
"RTN","IVMCM2",146,0)
 S IVMNM13=$P(IVMSEG13,"^")
"RTN","IVMCM2",147,0)
 S IVMAL113=$P($G(IVMSG131),"^",2),IVMAL213=$P($G(IVMSG131),"^",3),IVMAL313=$P($G(IVMSG131),"^",4)
"RTN","IVMCM2",148,0)
 S IVMCTY13=$P($G(IVMSG131),"^",5),IVMST13=$P($G(IVMSG131),"^",6),IVMZIP13=$P($G(IVMSG131),"^",7)
"RTN","IVMCM2",149,0)
 S IVMTEL13=$P($G(IVMSG131),"^",8),IVMALU13=$P($G(IVMSG131),"^",9)
"RTN","IVMCM2",150,0)
 Q
"RTN","IVMCM9")
0^2^B15363550
"RTN","IVMCM9",1,0)
IVMCM9 ;ALB/SEK,CKN,TDM - ADD DCD DEPENDENT CHANGES TO 408.13 & 408.41 ; 6/17/09 2:30pm
"RTN","IVMCM9",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**17,105,115,121**;21-OCT-94;Build 45
"RTN","IVMCM9",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMCM9",4,0)
 ;
"RTN","IVMCM9",5,0)
AUDIT ; change dependent demo data in 408.13 and add changes to 408.41.
"RTN","IVMCM9",6,0)
 ; if IVM transmitted IEN of 408.12 and IEN found at VAMC, any of the
"RTN","IVMCM9",7,0)
 ; 4 demo fields could be different.  if ien of 408.12 is not
"RTN","IVMCM9",8,0)
 ; transmitted and dependent is found in 408.13, name & ssn could be
"RTN","IVMCM9",9,0)
 ; different because sex, dob, & relationship (408.12) must be the same.
"RTN","IVMCM9",10,0)
 I IVMDOB'=IVMDOB13 D
"RTN","IVMCM9",11,0)
 .S DGMTACT="DOB",DGMTSOLD=IVMDOB13,DGMTSNEW=IVMDOB D SET^DGMTAUD
"RTN","IVMCM9",12,0)
 .S IVMDR=".03////^S X=IVMDOB"
"RTN","IVMCM9",13,0)
 .Q
"RTN","IVMCM9",14,0)
 I IVMSEX'=IVMSEX13 D
"RTN","IVMCM9",15,0)
 .S DGMTACT="SEX",DGMTSOLD=IVMSEX13,DGMTSNEW=IVMSEX D SET^DGMTAUD
"RTN","IVMCM9",16,0)
 .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".02////^S X=IVMSEX"
"RTN","IVMCM9",17,0)
 .Q
"RTN","IVMCM9",18,0)
AUDIT1 I IVMNM'=IVMNM13 D
"RTN","IVMCM9",19,0)
 .S DGMTACT="NAM",DGMTSOLD=IVMNM13,DGMTSNEW=IVMNM D SET^DGMTAUD
"RTN","IVMCM9",20,0)
 .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".01////^S X=IVMNM"
"RTN","IVMCM9",21,0)
 .Q
"RTN","IVMCM9",22,0)
 I IVMSSN'=IVMSSN13 D
"RTN","IVMCM9",23,0)
 .;If not a pseudo quit if not verified
"RTN","IVMCM9",24,0)
 .Q:(IVMSSNVS'=4)&(IVMSSN'["P")
"RTN","IVMCM9",25,0)
 .S DGMTACT="SSN",DGMTSOLD=IVMSSN13,DGMTSNEW=IVMSSN D SET^DGMTAUD
"RTN","IVMCM9",26,0)
 .S IVMSSN=$S(IVMSSN="":"@",1:IVMSSN)
"RTN","IVMCM9",27,0)
 .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".09////^S X=IVMSSN"
"RTN","IVMCM9",28,0)
 .Q
"RTN","IVMCM9",29,0)
 I IVMPSSNR'=IVMPSR13 D
"RTN","IVMCM9",30,0)
 .S IVMPSSNR=$S(IVMPSSNR="":"@",1:IVMPSSNR)
"RTN","IVMCM9",31,0)
 .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".1////^S X=IVMPSSNR"
"RTN","IVMCM9",32,0)
 .Q
"RTN","IVMCM9",33,0)
 I IVMSSNVS'=IVMSVS13 D
"RTN","IVMCM9",34,0)
 .I IVMSSNVS="" Q  ;quit if no verify status
"RTN","IVMCM9",35,0)
 .I IVMSSNVS=2,IVMSSN'=IVMSSN13 Q  ;Quit if verify status=Invalid and NO SSN match
"RTN","IVMCM9",36,0)
 .S IVMSSNVS=$S(IVMSSNVS="":"@",1:IVMSSNVS)
"RTN","IVMCM9",37,0)
 .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_".11////^S X=IVMSSNVS"
"RTN","IVMCM9",38,0)
 .Q
"RTN","IVMCM9",39,0)
 I IVMSPMNM'=IVMSMN13 D
"RTN","IVMCM9",40,0)
 .S IVMSPMNM=$S(IVMSPMNM="":"@",1:IVMSPMNM)
"RTN","IVMCM9",41,0)
 .S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.1////^S X=IVMSPMNM"
"RTN","IVMCM9",42,0)
 .Q
"RTN","IVMCM9",43,0)
 ;
"RTN","IVMCM9",44,0)
 I IVMSALU'=""&(IVMSADL1'=""&(IVMSALU>IVMALU13)) D
"RTN","IVMCM9",45,0)
 . I IVMSADL1'=IVMAL113 D
"RTN","IVMCM9",46,0)
 . . S IVMSADL1=$S(IVMSADL1="":"@",1:IVMSADL1)
"RTN","IVMCM9",47,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.2////^S X=IVMSADL1"
"RTN","IVMCM9",48,0)
 . I IVMSADL2'=IVMAL213 D
"RTN","IVMCM9",49,0)
 . . S IVMSADL2=$S(IVMSADL2="":"@",1:IVMSADL2)
"RTN","IVMCM9",50,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.3////^S X=IVMSADL2"
"RTN","IVMCM9",51,0)
 . I IVMSADL3'=IVMAL313 D
"RTN","IVMCM9",52,0)
 . . S IVMSADL3=$S(IVMSADL3="":"@",1:IVMSADL3)
"RTN","IVMCM9",53,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.4////^S X=IVMSADL3"
"RTN","IVMCM9",54,0)
 . I IVMSCITY'=IVMCTY13 D
"RTN","IVMCM9",55,0)
 . . S IVMSCITY=$S(IVMSCITY="":"@",1:IVMSCITY)
"RTN","IVMCM9",56,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.5////^S X=IVMSCITY"
"RTN","IVMCM9",57,0)
 . I IVMSST'=IVMST13 D
"RTN","IVMCM9",58,0)
 . . S IVMSST=$S(IVMSST="":"@",1:IVMSST)
"RTN","IVMCM9",59,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.6////^S X=IVMSST"
"RTN","IVMCM9",60,0)
 . I IVMSZIP'=IVMZIP13 D
"RTN","IVMCM9",61,0)
 . . S IVMSZIP=$S(IVMSZIP="":"@",1:IVMSZIP)
"RTN","IVMCM9",62,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.7////^S X=IVMSZIP"
"RTN","IVMCM9",63,0)
 . I IVMSTELE'=IVMTEL13 D
"RTN","IVMCM9",64,0)
 . . S IVMSTELE=$S(IVMSTELE="":"@",1:IVMSTELE)
"RTN","IVMCM9",65,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.8////^S X=IVMSTELE"
"RTN","IVMCM9",66,0)
 . I IVMSALU'=IVMALU13 D
"RTN","IVMCM9",67,0)
 . . S IVMDR=$S($D(IVMDR):IVMDR_";",1:"") S IVMDR=IVMDR_"1.9////^S X=IVMSALU"
"RTN","IVMCM9",68,0)
 ;
"RTN","IVMCM9",69,0)
 ; change 408.13
"RTN","IVMCM9",70,0)
 I $D(IVMDR) S DR=IVMDR,DA=DGIPI,DIE="^DGPR(408.13," D ^DIE K DA,DIE,DR,IVMDR Q
"RTN","IVMCM9",71,0)
 K DGDEPI,DGMTA,DGMTACT,DGMTSNEW,DGMTSOLD
"RTN","IVMCM9",72,0)
 Q
"RTN","IVMCM9",73,0)
 ;
"RTN","IVMCM9",74,0)
AUDITP ; set common variables for audit
"RTN","IVMCM9",75,0)
 S DGMTYPT=$S(IVMTYPE=3:"",1:IVMTYPE),DGDEPI=DGIPI
"RTN","IVMCM9",76,0)
 I IVMMTIEN S DGMTA=$G(^DGMT(408.31,IVMMTIEN,0))
"RTN","IVMCM9",77,0)
 S $P(DGMTA,"^",2)=DFN
"RTN","IVMCM9",78,0)
 K IVMDR
"RTN","IVMCM9",79,0)
 ;
"RTN","IVMCM9",80,0)
 ; dgrel("s") contains 408.12 IEN of active spouse of VAMC test
"RTN","IVMCM9",81,0)
 ; dgrel("c",xxx) contains 408.12 IEN of active children of VAMC test
"RTN","IVMCM9",82,0)
 ; if VAMC dependent not a DCD dependent the dependent must be inactivated
"RTN","IVMCM9",83,0)
 ; dependents remaining in dgrel after all DCD dependents are uploaded, will be inactivated
"RTN","IVMCM9",84,0)
 ; if DCD & VAMC dependent, kill dgrel to prevent inactivation of dependent
"RTN","IVMCM9",85,0)
 ; dgpri is DCD (or DCD & VAMC) dependent's 408.12 IEN
"RTN","IVMCM9",86,0)
 I IVMSPCHV="S" D  Q
"RTN","IVMCM9",87,0)
 .I +$G(DGREL("S"))=DGPRI K DGREL("S")
"RTN","IVMCM9",88,0)
 S IVMFLG4=1,IVMCC=0 F  S IVMCC=$O(DGREL("C",IVMCC)) Q:'IVMCC  D  Q:'IVMFLG4
"RTN","IVMCM9",89,0)
 .I +$G(DGREL("C",IVMCC))=DGPRI S IVMFLG4=0 K DGREL("C",IVMCC)
"RTN","IVMCM9",90,0)
 K IVMCC
"RTN","IVMCM9",91,0)
 Q
"RTN","IVMCM9",92,0)
 ;
"RTN","IVMCM9",93,0)
TRIGGER(IVMDA) ; Trigger logic for Spouse Address fields to update the Spouse
"RTN","IVMCM9",94,0)
 ; Addr Last Update Date/Time' field.  The variable IVMSPFLG is set at
"RTN","IVMCM9",95,0)
 ; the beginning of IVMCM2 to specify a Z10 spouse address update.
"RTN","IVMCM9",96,0)
 ; A Z10 transmission should not allow the trigger to run.
"RTN","IVMCM9",97,0)
 ; If IVMSPFLG does NOT exist then a manual update will be assumed. A
"RTN","IVMCM9",98,0)
 ; manual update is the only change allowed by the trigger.
"RTN","IVMCM9",99,0)
 ;
"RTN","IVMCM9",100,0)
 ; INPUT
"RTN","IVMCM9",101,0)
 ;   IVMDA: The IEN of the field that was changed to cause the trigger
"RTN","IVMCM9",102,0)
 Q:$D(IVMSPFLG)
"RTN","IVMCM9",103,0)
 N DGIEN,DATA
"RTN","IVMCM9",104,0)
 S DATA(1.9)=$$NOW^XLFDT(),DGIEN=IVMDA
"RTN","IVMCM9",105,0)
 I $$UPD^DGENDBS(408.13,.DGIEN,.DATA)
"RTN","IVMCM9",106,0)
 Q
"RTN","IVMLERR")
0^3^B7302107
"RTN","IVMLERR",1,0)
IVMLERR ;ALB/RMO,ERC - IVM Transmission Error Processing - List Manager Screen; 15-SEP-1997 ; 5/25/07 11:09am
"RTN","IVMLERR",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,121**; 21-OCT-94;Build 45
"RTN","IVMLERR",3,0)
 ;
"RTN","IVMLERR",4,0)
EN ;Main entry point for IVM transmission error processing option
"RTN","IVMLERR",5,0)
 ; Input  -- None
"RTN","IVMLERR",6,0)
 ; Output -- None
"RTN","IVMLERR",7,0)
 ;
"RTN","IVMLERR",8,0)
 ;Invoke IVM TRANSMISSION ERRORS list template
"RTN","IVMLERR",9,0)
 D EN^VALM("IVM TRANSMISSION ERRORS")
"RTN","IVMLERR",10,0)
 Q
"RTN","IVMLERR",11,0)
 ;
"RTN","IVMLERR",12,0)
HDR ;Header code
"RTN","IVMLERR",13,0)
 ;
"RTN","IVMLERR",14,0)
 ;Sort by
"RTN","IVMLERR",15,0)
 S VALMHDR(1)="Sort By: "_$S(IVMSRTBY="P":"Patient Name",IVMSRTBY="D":"Date/Time ACK Received",IVMSRTBY="E":"Error Message",IVMSRTBY="O":"Person Not Found",1:"Unknown")
"RTN","IVMLERR",16,0)
 ;
"RTN","IVMLERR",17,0)
 ;Date range
"RTN","IVMLERR",18,0)
 S VALMHDR(1)=$$SETSTR^VALM1("Date Range: "_$$FDATE^VALM1(IVMBEG)_" thru "_$$FDATE^VALM1(IVMEND),VALMHDR(1),46,80)
"RTN","IVMLERR",19,0)
 ;
"RTN","IVMLERR",20,0)
 ;Error processing status
"RTN","IVMLERR",21,0)
 N HDR,PCE,STA
"RTN","IVMLERR",22,0)
 S HDR=""
"RTN","IVMLERR",23,0)
 F PCE=1:1 S STA=$P(IVMEPSTA,U,PCE) Q:STA=""  D
"RTN","IVMLERR",24,0)
 . S:HDR'="" HDR=HDR_"/"
"RTN","IVMLERR",25,0)
 . S HDR=HDR_$$LOWER^VALM1($$EXT^IVMTLOG("ERROR STATUS",STA))
"RTN","IVMLERR",26,0)
 S VALMHDR(2)="Error Processing Statuses: "_$S(HDR="":"Unknown",1:HDR)
"RTN","IVMLERR",27,0)
 Q
"RTN","IVMLERR",28,0)
 ;
"RTN","IVMLERR",29,0)
INIT ;Init variables and list array
"RTN","IVMLERR",30,0)
 N VALMB,VALMBEG,VALMEND,X,X1,X2
"RTN","IVMLERR",31,0)
 K IVMBEG,IVMEND,IVMEPSTA,IVMSRTBY
"RTN","IVMLERR",32,0)
 ;
"RTN","IVMLERR",33,0)
 S VALMSG=$$MSG
"RTN","IVMLERR",34,0)
 ;
"RTN","IVMLERR",35,0)
 ;Ask user for date range - default two weeks prior to today
"RTN","IVMLERR",36,0)
 S X1=DT,X2=-14 D C^%DTC S VALMB=X
"RTN","IVMLERR",37,0)
 D RANGE^VALM1
"RTN","IVMLERR",38,0)
 I 'VALMBEG!('VALMEND) S VALMQUIT=1 G INITQ
"RTN","IVMLERR",39,0)
 S IVMBEG=VALMBEG,IVMEND=VALMEND
"RTN","IVMLERR",40,0)
 ;
"RTN","IVMLERR",41,0)
ASK ;
"RTN","IVMLERR",42,0)
 ;ask user for sort criteria
"RTN","IVMLERR",43,0)
 N DIROUT,DUOUT
"RTN","IVMLERR",44,0)
 N IVMFLG ;flag indicating that the report has not yet run
"RTN","IVMLERR",45,0)
 N IVMY
"RTN","IVMLERR",46,0)
 S IVMFLG=1
"RTN","IVMLERR",47,0)
 S IVMEPSTA=1
"RTN","IVMLERR",48,0)
 W !!?5,"How would you like this display sorted?",!
"RTN","IVMLERR",49,0)
 D SL^IVMLERR2
"RTN","IVMLERR",50,0)
 I $D(DUOUT)!($D(DIROUT)) S VALMQUIT=1 G INITQ
"RTN","IVMLERR",51,0)
 ;Build IVM transmission error screen
"RTN","IVMLERR",52,0)
 D BLD
"RTN","IVMLERR",53,0)
INITQ Q
"RTN","IVMLERR",54,0)
 ;
"RTN","IVMLERR",55,0)
BLD ;Build IVM transmission error screen
"RTN","IVMLERR",56,0)
 D CLEAN^VALM10
"RTN","IVMLERR",57,0)
 K IVMARY,VALMHDR
"RTN","IVMLERR",58,0)
 S IVMARY="IVMERR"
"RTN","IVMLERR",59,0)
 K ^TMP(IVMARY_"SRT",$J),^TMP(IVMARY_"IDX",$J)
"RTN","IVMLERR",60,0)
 S VALMBG=1,VALMCNT=0
"RTN","IVMLERR",61,0)
 ;
"RTN","IVMLERR",62,0)
 ;Build header
"RTN","IVMLERR",63,0)
 D HDR
"RTN","IVMLERR",64,0)
 ;
"RTN","IVMLERR",65,0)
 ;Build list area for transmission errors
"RTN","IVMLERR",66,0)
 D EN^IVMLERR1(IVMARY,IVMBEG,IVMEND,IVMEPSTA,IVMSRTBY,.VALMCNT)
"RTN","IVMLERR",67,0)
 Q
"RTN","IVMLERR",68,0)
 ;
"RTN","IVMLERR",69,0)
MSG() ;Custom message for list manager 'message window'
"RTN","IVMLERR",70,0)
 Q "* = Patient has been flagged for transmission"
"RTN","IVMLERR",71,0)
 ;
"RTN","IVMLERR",72,0)
HELP ;Help code
"RTN","IVMLERR",73,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","IVMLERR",74,0)
 Q
"RTN","IVMLERR",75,0)
 ;
"RTN","IVMLERR",76,0)
EXIT ;Exit code
"RTN","IVMLERR",77,0)
 D CLEAN^VALM10
"RTN","IVMLERR",78,0)
 D CLEAR^VALM1
"RTN","IVMLERR",79,0)
 K IVMBEG,IVMEND,IVMEPSTA,IVMSRTBY,^TMP(IVMARY_"SRT",$J),^TMP(IVMARY_"IDX",$J),IVMARY
"RTN","IVMLERR",80,0)
 Q
"RTN","IVMLERR",81,0)
 ;
"RTN","IVMLERR",82,0)
EXPND ;Expand code
"RTN","IVMLERR",83,0)
 Q
"RTN","IVMLERR",84,0)
 ;
"RTN","IVMLERR1")
0^4^B41105016
"RTN","IVMLERR1",1,0)
IVMLERR1 ;ALB/RMO,ERC - IVM Transmission Error Processing - Build List area; 15-SEP-1997 ; 2/20/08 11:10am
"RTN","IVMLERR1",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,121**; 21-OCT-94;Build 45
"RTN","IVMLERR1",3,0)
 ;
"RTN","IVMLERR1",4,0)
EN(IVMARY,IVMBEG,IVMEND,IVMEPSTA,IVMSRTBY,IVMCNT) ;Entry point to build list area for IVM transmission errors
"RTN","IVMLERR1",5,0)
 ;The following variables are 'system wide variables' in the
"RTN","IVMLERR1",6,0)
 ;IVM Transmission Error Processing List Manager application:
"RTN","IVMLERR1",7,0)
 ; Input  -- IVMARY   Global array subscript
"RTN","IVMLERR1",8,0)
 ;           IVMBEG   Begin date
"RTN","IVMLERR1",9,0)
 ;           IVMEND   End date
"RTN","IVMLERR1",10,0)
 ;           IVMEPSTA Error processing statuses
"RTN","IVMLERR1",11,0)
 ;                    1   - New
"RTN","IVMLERR1",12,0)
 ;                    2   - Checked
"RTN","IVMLERR1",13,0)
 ;                    1^2 - Both
"RTN","IVMLERR1",14,0)
 ;           IVMSRTBY Sort by criteria
"RTN","IVMLERR1",15,0)
 ;                    P - patient name
"RTN","IVMLERR1",16,0)
 ;                    D - date/time ack received
"RTN","IVMLERR1",17,0)
 ;                    E - error message
"RTN","IVMLERR1",18,0)
 ;                    O - error message of 'Person Not Found' only
"RTN","IVMLERR1",19,0)
 ; Output -- IVMCNT   Number of lines in the list
"RTN","IVMLERR1",20,0)
 D WAIT^DICD
"RTN","IVMLERR1",21,0)
 ;
"RTN","IVMLERR1",22,0)
 ;Get IVM transmission log errors
"RTN","IVMLERR1",23,0)
 D GET(IVMARY,IVMBEG,IVMEND,IVMEPSTA,IVMSRTBY)
"RTN","IVMLERR1",24,0)
 ;
"RTN","IVMLERR1",25,0)
 ;Build list area for for IVM transmission log errors
"RTN","IVMLERR1",26,0)
 D BLD(IVMSRTBY,.IVMCNT)
"RTN","IVMLERR1",27,0)
 ;
"RTN","IVMLERR1",28,0)
 ;Print message if no IVM transmission log errors meet selection criteria
"RTN","IVMLERR1",29,0)
 I 'IVMCNT D
"RTN","IVMLERR1",30,0)
 . D SET(IVMARY,1,"",1,60,0,,,.IVMCNT)
"RTN","IVMLERR1",31,0)
 . D SET(IVMARY,2,"No 'Transmission Errors' meet the selection criteria.",4,60,0,,,.IVMCNT)
"RTN","IVMLERR1",32,0)
 Q
"RTN","IVMLERR1",33,0)
 ;
"RTN","IVMLERR1",34,0)
GET(IVMARY,IVMBEG,IVMEND,IVMEPSTA,IVMSRTBY) ;Get IVM transmission log errors
"RTN","IVMLERR1",35,0)
 ; Input  -- IVMARY   Global array subscript
"RTN","IVMLERR1",36,0)
 ;           IVMBEG   Begin date
"RTN","IVMLERR1",37,0)
 ;           IVMEND   End date
"RTN","IVMLERR1",38,0)
 ;           IVMEPSTA Error processing statuses
"RTN","IVMLERR1",39,0)
 ;           IVMSRTBY Sort by criteria
"RTN","IVMLERR1",40,0)
 ; Output -- IVM Transmission log error list sorted by patient name
"RTN","IVMLERR1",41,0)
 ;           ^TMP("IVMERRSRT",$J,<sort by>,<patient name>,<trans log IEN>)
"RTN","IVMLERR1",42,0)
 ;                            or date/time ack received
"RTN","IVMLERR1",43,0)
 ;           ^TMP("IVMERRSRT",$J,<sort by>,<date/time ack received>,<trans log IEN>)
"RTN","IVMLERR1",44,0)
 ;                            or by error message (added with IVM*2*121)
"RTN","IVMLERR1",45,0)
 ;           ^TMP("IVMERRSRT",$J,<sort by>,<error message>,<trans log IEN>)
"RTN","IVMLERR1",46,0)
 N IVMDFN,IVMDTR,IVMTLIEN,PCE,STA
"RTN","IVMLERR1",47,0)
 ;
"RTN","IVMLERR1",48,0)
 ;Loop through IVM transmission log for selected date range
"RTN","IVMLERR1",49,0)
 F IVMDTR=IVMBEG:0 S IVMDTR=$O(^IVM(301.6,"AEPS",IVMDTR)) Q:'IVMDTR!($P(IVMDTR,".")>IVMEND)  D
"RTN","IVMLERR1",50,0)
 . ;Loop through selected error processing statuses
"RTN","IVMLERR1",51,0)
 . F PCE=1:1 S STA=$P(IVMEPSTA,U,PCE) Q:STA=""  D
"RTN","IVMLERR1",52,0)
 . . ;Loop through patients
"RTN","IVMLERR1",53,0)
 . . S IVMDFN=0
"RTN","IVMLERR1",54,0)
 . . F  S IVMDFN=$O(^IVM(301.6,"AEPS",IVMDTR,STA,IVMDFN)) Q:'IVMDFN  D
"RTN","IVMLERR1",55,0)
 . . . ;Loop though internal entry numbers
"RTN","IVMLERR1",56,0)
 . . . S IVMTLIEN=0
"RTN","IVMLERR1",57,0)
 . . . F  S IVMTLIEN=$O(^IVM(301.6,"AEPS",IVMDTR,STA,IVMDFN,IVMTLIEN)) Q:'IVMTLIEN  D SORT(IVMSRTBY,IVMDTR,IVMDFN,IVMTLIEN)
"RTN","IVMLERR1",58,0)
 Q
"RTN","IVMLERR1",59,0)
 ;
"RTN","IVMLERR1",60,0)
SORT(IVMSRTBY,IVMDTR,IVMDFN,IVMTLIEN) ;Set array based on sort criteria for IVM transmission log error list display
"RTN","IVMLERR1",61,0)
 ; Input  -- IVMSRTBY Sort by criteria
"RTN","IVMLERR1",62,0)
 ;           IVMDTR   IVM transmission log date/time ack received
"RTN","IVMLERR1",63,0)
 ;           IVMDFN   IVM patient IEN
"RTN","IVMLERR1",64,0)
 ;           IVMTLIEN IVM transmission log IEN
"RTN","IVMLERR1",65,0)
 ; Output -- None
"RTN","IVMLERR1",66,0)
 N IVMTLOG
"RTN","IVMLERR1",67,0)
 I $G(IVMSRTBY)']"" S IVMSRTBY="P"
"RTN","IVMLERR1",68,0)
 I IVMSRTBY="P" D  ;patient name
"RTN","IVMLERR1",69,0)
 . I $$GET^IVMTLOG(IVMTLIEN,.IVMTLOG) D
"RTN","IVMLERR1",70,0)
 . . S ^TMP("IVMERRSRT",$J,IVMSRTBY,$S($P($G(^DPT(+IVMTLOG("DFN"),0)),U)'="":$P(^(0),U),1:"UNKNOWN"),IVMTLIEN)=""
"RTN","IVMLERR1",71,0)
 I IVMSRTBY="D" D  ;default date/time ack received
"RTN","IVMLERR1",72,0)
 . S ^TMP("IVMERRSRT",$J,IVMSRTBY,IVMDTR,IVMTLIEN)=""
"RTN","IVMLERR1",73,0)
 I IVMSRTBY="E"!(IVMSRTBY="O") D  ;added with IVM*2*121
"RTN","IVMLERR1",74,0)
 . N IVMQ
"RTN","IVMLERR1",75,0)
 . S IVMQ=0
"RTN","IVMLERR1",76,0)
 . I $$GET^IVMTLOG(IVMTLIEN,.IVMTLOG) D
"RTN","IVMLERR1",77,0)
 . . I IVMSRTBY="O" D
"RTN","IVMLERR1",78,0)
 . . . I $$UPPER^DGUTL($G(IVMTLOG("ERROR")))'["PERSON NOT FOUND" S IVMQ=1
"RTN","IVMLERR1",79,0)
 . . Q:IVMQ=1
"RTN","IVMLERR1",80,0)
 . . S ^TMP("IVMERRSRT",$J,IVMSRTBY,$S($G(IVMTLOG("ERROR"))]"":IVMTLOG("ERROR"),1:"UNKNOWN"),IVMTLIEN)=""
"RTN","IVMLERR1",81,0)
 Q
"RTN","IVMLERR1",82,0)
 ;
"RTN","IVMLERR1",83,0)
BLD(IVMSRTBY,IVMCNT) ;Build list area for for IVM transmission log errors
"RTN","IVMLERR1",84,0)
 ; Input  -- IVMSRTBY Sort by criteria
"RTN","IVMLERR1",85,0)
 ;                    P - patient name
"RTN","IVMLERR1",86,0)
 ;                    D - date/time ack received
"RTN","IVMLERR1",87,0)
 ;                    E - error message
"RTN","IVMLERR1",88,0)
 ;                    O - error message of 'Person Not Found' only
"RTN","IVMLERR1",89,0)
 ; Output -- IVMCNT   Number of lines in the list
"RTN","IVMLERR1",90,0)
 N DFN,IVMCOL,IVMSUB,IVMTEXT,IVMTLIEN,IVMTLOG,IVMWID,X,VA
"RTN","IVMLERR1",91,0)
 ;
"RTN","IVMLERR1",92,0)
 ;Initialize variables
"RTN","IVMLERR1",93,0)
 S (IVMLINE,IVMNUM)=0
"RTN","IVMLERR1",94,0)
 S X=VALMDDF("NUMBER"),IVMCOL("NUM")=$P(X,U,2),IVMWID("NUM")=$P(X,U,3)
"RTN","IVMLERR1",95,0)
 S X=VALMDDF("RETRANSMIT"),IVMCOL("RET")=$P(X,U,2),IVMWID("RET")=$P(X,U,3)
"RTN","IVMLERR1",96,0)
 S X=VALMDDF("PATIENT"),IVMCOL("PAT")=$P(X,U,2),IVMWID("PAT")=$P(X,U,3)
"RTN","IVMLERR1",97,0)
 S X=VALMDDF("PTID"),IVMCOL("PTID")=$P(X,U,2),IVMWID("PTID")=$P(X,U,3)
"RTN","IVMLERR1",98,0)
 S X=VALMDDF("DATE/TIME"),IVMCOL("DTR")=$P(X,U,2),IVMWID("DTR")=$P(X,U,3)
"RTN","IVMLERR1",99,0)
 S X=VALMDDF("STATUS"),IVMCOL("STA")=$P(X,U,2),IVMWID("STA")=$P(X,U,3)
"RTN","IVMLERR1",100,0)
 ;
"RTN","IVMLERR1",101,0)
 ;Loop through by patient name,error message or date/time ack received
"RTN","IVMLERR1",102,0)
 S IVMSUB=$S(IVMSRTBY="D":0,1:"")
"RTN","IVMLERR1",103,0)
 F  S IVMSUB=$O(^TMP("IVMERRSRT",$J,IVMSRTBY,IVMSUB)) Q:IVMSUB=""  D
"RTN","IVMLERR1",104,0)
 . ;Loop through IVM transmission log IEN(s)
"RTN","IVMLERR1",105,0)
 . S IVMTLIEN=0
"RTN","IVMLERR1",106,0)
 . F  S IVMTLIEN=$O(^TMP("IVMERRSRT",$J,IVMSRTBY,IVMSUB,IVMTLIEN)) Q:'IVMTLIEN  D
"RTN","IVMLERR1",107,0)
 . . W:'(IVMLINE#50) "."
"RTN","IVMLERR1",108,0)
 . . ;Get information for IVM transmission log entry
"RTN","IVMLERR1",109,0)
 . . I $$GET^IVMTLOG(IVMTLIEN,.IVMTLOG) D
"RTN","IVMLERR1",110,0)
 . . . ;Increment selection number
"RTN","IVMLERR1",111,0)
 . . . S IVMNUM=IVMNUM+1
"RTN","IVMLERR1",112,0)
 . . . ;Increment line counter
"RTN","IVMLERR1",113,0)
 . . . S IVMLINE=IVMLINE+1
"RTN","IVMLERR1",114,0)
 . . . ;Set selection number in display array
"RTN","IVMLERR1",115,0)
 . . . D SET(IVMARY,IVMLINE,IVMNUM,IVMCOL("NUM"),IVMWID("NUM"),IVMNUM,IVMTLIEN,IVMTLOG("PAT"),.IVMCNT)
"RTN","IVMLERR1",116,0)
 . . . ;Set retransmit flag in display array
"RTN","IVMLERR1",117,0)
 . . . S IVMTEXT=$S('$G(IVMTLOG("PAT")):" ",'$$STATUS^IVMPLOG(IVMTLOG("PAT")):"*",1:" ")
"RTN","IVMLERR1",118,0)
 . . . D SET(IVMARY,IVMLINE,IVMTEXT,IVMCOL("RET"),IVMWID("RET"),IVMNUM,,,.IVMCNT)
"RTN","IVMLERR1",119,0)
 . . . ;Set patient name in display array
"RTN","IVMLERR1",120,0)
 . . . S IVMTEXT=$$LOWER^VALM1($S($G(IVMTLOG("PAT")):$$EXT^IVMTLOG("PAT",IVMTLOG("PAT")),1:"UNKNOWN"))
"RTN","IVMLERR1",121,0)
 . . . D SET(IVMARY,IVMLINE,IVMTEXT,IVMCOL("PAT"),IVMWID("PAT"),IVMNUM,,,.IVMCNT)
"RTN","IVMLERR1",122,0)
 . . . ;Set patient id in display array
"RTN","IVMLERR1",123,0)
 . . . S DFN=+IVMTLOG("DFN") D PID^VADPT
"RTN","IVMLERR1",124,0)
 . . . D SET(IVMARY,IVMLINE,VA("BID"),IVMCOL("PTID"),IVMWID("PTID"),IVMNUM,,,.IVMCNT)
"RTN","IVMLERR1",125,0)
 . . . ;Set date/time ack received in display array
"RTN","IVMLERR1",126,0)
 . . . S IVMTEXT=$$LOWER^VALM1($S($G(IVMTLOG("DT/TM ACK")):$$EXT^IVMTLOG("DT/TM ACK",IVMTLOG("DT/TM ACK")),1:"UNKNOWN"))
"RTN","IVMLERR1",127,0)
 . . . D SET(IVMARY,IVMLINE,IVMTEXT,IVMCOL("DTR"),IVMWID("DTR"),IVMNUM,,,.IVMCNT)
"RTN","IVMLERR1",128,0)
 . . . ;Set error processing status in display array
"RTN","IVMLERR1",129,0)
 . . . S IVMTEXT=$$LOWER^VALM1($S($G(IVMTLOG("ERROR STATUS")):$$EXT^IVMTLOG("ERROR STATUS",IVMTLOG("ERROR STATUS")),1:"UNKNOWN"))
"RTN","IVMLERR1",130,0)
 . . . D SET(IVMARY,IVMLINE,IVMTEXT,IVMCOL("STA"),IVMWID("STA"),IVMNUM,,,.IVMCNT)
"RTN","IVMLERR1",131,0)
 . . . ;Increment line counter
"RTN","IVMLERR1",132,0)
 . . . S IVMLINE=IVMLINE+1
"RTN","IVMLERR1",133,0)
 . . . ;Set error message in display array
"RTN","IVMLERR1",134,0)
 . . . S IVMTEXT="Error: "_$S($G(IVMTLOG("ERROR"))'="":$$EXT^IVMTLOG("ERROR",IVMTLOG("ERROR")),1:"UNKNOWN")
"RTN","IVMLERR1",135,0)
 . . . K X S $P(X," ",160)=""
"RTN","IVMLERR1",136,0)
 . . . S IVMTEXT=$E(IVMTEXT_X,1,160)
"RTN","IVMLERR1",137,0)
 . . . D SET(IVMARY,IVMLINE,IVMTEXT,3,$L(IVMTEXT),IVMNUM,,,.IVMCNT)
"RTN","IVMLERR1",138,0)
 Q
"RTN","IVMLERR1",139,0)
 ;
"RTN","IVMLERR1",140,0)
SET(IVMARY,IVMLINE,IVMTEXT,IVMCOL,IVMWID,IVMNUM,IVMTLIEN,IVMDFN,IVMCNT) ;Set display array
"RTN","IVMLERR1",141,0)
 ; Input  -- IVMARY   Global array subscript
"RTN","IVMLERR1",142,0)
 ;           IVMLINE  Line number
"RTN","IVMLERR1",143,0)
 ;           IVMTEXT  Text
"RTN","IVMLERR1",144,0)
 ;           IVMCOL   Column to start at
"RTN","IVMLERR1",145,0)
 ;           IVMWID   Column or text width
"RTN","IVMLERR1",146,0)
 ;           IVMNUM   Selection number
"RTN","IVMLERR1",147,0)
 ;           IVMTLIEN IVM transmission log IEN
"RTN","IVMLERR1",148,0)
 ;           IVMDFN   IVM patient IEN
"RTN","IVMLERR1",149,0)
 ; Output -- IVMCNT   Number of lines in the list
"RTN","IVMLERR1",150,0)
 N X
"RTN","IVMLERR1",151,0)
 S:IVMLINE>IVMCNT IVMCNT=IVMLINE
"RTN","IVMLERR1",152,0)
 S X=$S($D(^TMP(IVMARY,$J,IVMLINE,0)):^(0),1:"")
"RTN","IVMLERR1",153,0)
 S ^TMP(IVMARY,$J,IVMLINE,0)=$$SETSTR^VALM1(IVMTEXT,X,IVMCOL,IVMWID)
"RTN","IVMLERR1",154,0)
 S ^TMP(IVMARY,$J,"IDX",IVMLINE,IVMNUM)=""
"RTN","IVMLERR1",155,0)
 ;
"RTN","IVMLERR1",156,0)
 ;Set special index used in retransmitting patient
"RTN","IVMLERR1",157,0)
 I $G(IVMTLIEN),$G(IVMDFN) D
"RTN","IVMLERR1",158,0)
 . S ^TMP(IVMARY_"IDX",$J,IVMNUM)=IVMLINE_U_IVMTLIEN
"RTN","IVMLERR1",159,0)
 . S ^TMP(IVMARY_"IDX",$J,"PT",IVMDFN,IVMLINE)=IVMTLIEN
"RTN","IVMLERR1",160,0)
 Q
"RTN","IVMLERR2")
0^5^B29385999
"RTN","IVMLERR2",1,0)
IVMLERR2 ;ALB/RMO,ERC - IVM Transmission Error Processing - Protocols; 15-SEP-1997 ; 5/29/07 9:29am
"RTN","IVMLERR2",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,121**; 21-OCT-94;Build 45
"RTN","IVMLERR2",3,0)
 ;
"RTN","IVMLERR2",4,0)
 ;This routine contains the IVM transmission log error processing
"RTN","IVMLERR2",5,0)
 ;protocols.
"RTN","IVMLERR2",6,0)
 ;
"RTN","IVMLERR2",7,0)
 ;See EN^IVMLERR1 for additional documentation on 'system wide variables'
"RTN","IVMLERR2",8,0)
 ;used in this routine.
"RTN","IVMLERR2",9,0)
 ;
"RTN","IVMLERR2",10,0)
CL ;Entry point for IVMLE CHANGE LIST protocol
"RTN","IVMLERR2",11,0)
 ; Input  -- IVMEPSTA Error processing statuses
"RTN","IVMLERR2",12,0)
 ; Output -- IVMEPSTA Error processing statuses
"RTN","IVMLERR2",13,0)
 ;           VALMSG   Custom message
"RTN","IVMLERR2",14,0)
 ;           VALMBCK  R   =Refresh screen
"RTN","IVMLERR2",15,0)
 N DIR,DTOUT,DUOUT,Y
"RTN","IVMLERR2",16,0)
 D FULL^VALM1
"RTN","IVMLERR2",17,0)
 ;
"RTN","IVMLERR2",18,0)
 ;Ask user to select error processing statuses
"RTN","IVMLERR2",19,0)
 S DIR(0)="SMO^1:New;2:Checked;3:Both"
"RTN","IVMLERR2",20,0)
 S DIR("A")="Select Error Processing Status"
"RTN","IVMLERR2",21,0)
 D ^DIR
"RTN","IVMLERR2",22,0)
 ;
"RTN","IVMLERR2",23,0)
 ;Process user response
"RTN","IVMLERR2",24,0)
 S:Y=3 Y="1^2"
"RTN","IVMLERR2",25,0)
 I Y,"^1^2^"[(U_Y_U) D
"RTN","IVMLERR2",26,0)
 . S IVMEPSTA=Y
"RTN","IVMLERR2",27,0)
 . ;Re-build error list for selected statuses
"RTN","IVMLERR2",28,0)
 . D BLD^IVMLERR
"RTN","IVMLERR2",29,0)
 S VALMSG=$$MSG^IVMLERR
"RTN","IVMLERR2",30,0)
 S VALMBCK="R"
"RTN","IVMLERR2",31,0)
 Q
"RTN","IVMLERR2",32,0)
 ;
"RTN","IVMLERR2",33,0)
CD ;Entry point for IVMLE CHANGE DATE RANGE protocol
"RTN","IVMLERR2",34,0)
 ; Input  -- IVMBEG   Begin date
"RTN","IVMLERR2",35,0)
 ;           IVMEND   End date
"RTN","IVMLERR2",36,0)
 ; Output -- IVMBEG   Begin date
"RTN","IVMLERR2",37,0)
 ;           IVMEND   End date
"RTN","IVMLERR2",38,0)
 ;           VALMSG   Custom message
"RTN","IVMLERR2",39,0)
 ;           VALMBCK  R   =Refresh screen
"RTN","IVMLERR2",40,0)
 N VALMB,VALMBEG,VALMEND
"RTN","IVMLERR2",41,0)
 S VALMB=IVMBEG
"RTN","IVMLERR2",42,0)
 ;
"RTN","IVMLERR2",43,0)
 ;Ask user for date range
"RTN","IVMLERR2",44,0)
 D RANGE^VALM1
"RTN","IVMLERR2",45,0)
 ;
"RTN","IVMLERR2",46,0)
 ;Process user response
"RTN","IVMLERR2",47,0)
 I 'VALMBEG!((IVMBEG=VALMBEG)&(IVMEND=VALMEND)) D
"RTN","IVMLERR2",48,0)
 . W !!,"Date Range was not changed."
"RTN","IVMLERR2",49,0)
 . D PAUSE^VALM1
"RTN","IVMLERR2",50,0)
 . S VALMBCK=""
"RTN","IVMLERR2",51,0)
 ELSE  D
"RTN","IVMLERR2",52,0)
 . S IVMBEG=VALMBEG,IVMEND=VALMEND
"RTN","IVMLERR2",53,0)
 . ;Re-build error list for selected date range
"RTN","IVMLERR2",54,0)
 . D BLD^IVMLERR
"RTN","IVMLERR2",55,0)
 . S VALMBCK="R"
"RTN","IVMLERR2",56,0)
 S VALMSG=$$MSG^IVMLERR
"RTN","IVMLERR2",57,0)
 Q
"RTN","IVMLERR2",58,0)
 ;
"RTN","IVMLERR2",59,0)
SL ;Entry point for IVMLE SORT LIST protocol
"RTN","IVMLERR2",60,0)
 ; Input  -- IVMSRTBY Sort by criteria
"RTN","IVMLERR2",61,0)
 ; Output -- IVMSRTBY Sort by criteria
"RTN","IVMLERR2",62,0)
 ;           VALMSG   Custom message
"RTN","IVMLERR2",63,0)
 ;           VALMBCK  R   =Refresh screen
"RTN","IVMLERR2",64,0)
 N DIR,Y
"RTN","IVMLERR2",65,0)
 D FULL^VALM1
"RTN","IVMLERR2",66,0)
 ;
"RTN","IVMLERR2",67,0)
 ;Ask user to select sort criteria
"RTN","IVMLERR2",68,0)
 S DIR(0)="SMO^P:Patient Name;D:Date/Time ACK Received;E:Error Message"
"RTN","IVMLERR2",69,0)
 S DIR("A")="Select Sort By"
"RTN","IVMLERR2",70,0)
 S DIR("B")="P"
"RTN","IVMLERR2",71,0)
 D ^DIR
"RTN","IVMLERR2",72,0)
 S IVMY=$G(Y)
"RTN","IVMLERR2",73,0)
 ;S IVMSRTBY=$S($G(Y)="E":"E",$G(Y)="D":"D",1:"P")
"RTN","IVMLERR2",74,0)
 ;if sorting by error message ask if just Person Not Found
"RTN","IVMLERR2",75,0)
 I $G(Y)="E" D
"RTN","IVMLERR2",76,0)
 . N DIR,Y
"RTN","IVMLERR2",77,0)
 . S DIR(0)="SMO^O:'Person Not Found' only;A:All Error Messages"
"RTN","IVMLERR2",78,0)
 . S DIR("A")="Select ALL Error Messages or 'Person Not Found' only"
"RTN","IVMLERR2",79,0)
 . D ^DIR
"RTN","IVMLERR2",80,0)
 . I $D(DIRUT)!($D(DIROUT)) G ASK^IVMLERR
"RTN","IVMLERR2",81,0)
 . ;if by 'Person Not Found' only, use Error Processing
"RTN","IVMLERR2",82,0)
 . ;Status of NEW and CHECKED
"RTN","IVMLERR2",83,0)
 . I $G(Y)="O" S IVMEPSTA="1^2",IVMY="O"
"RTN","IVMLERR2",84,0)
 ;if the report has not run once already, Q and return to 
"RTN","IVMLERR2",85,0)
 ;INIT^IVMLERR
"RTN","IVMLERR2",86,0)
 I $G(IVMFLG)=1 D  Q
"RTN","IVMLERR2",87,0)
 . S IVMFLG=0
"RTN","IVMLERR2",88,0)
 . S IVMSRTBY=IVMY
"RTN","IVMLERR2",89,0)
 ;
"RTN","IVMLERR2",90,0)
 ;Process user response
"RTN","IVMLERR2",91,0)
 I "^P^D^E^O^"[(U_IVMY_U),IVMSRTBY'=IVMY D
"RTN","IVMLERR2",92,0)
 . S IVMSRTBY=IVMY
"RTN","IVMLERR2",93,0)
 . ;Re-build error list for selected sort criteria
"RTN","IVMLERR2",94,0)
 . D BLD^IVMLERR
"RTN","IVMLERR2",95,0)
 S VALMSG=$$MSG^IVMLERR
"RTN","IVMLERR2",96,0)
 S VALMBCK="R"
"RTN","IVMLERR2",97,0)
 Q
"RTN","IVMLERR2",98,0)
 ;
"RTN","IVMLERR2",99,0)
CE ;Entry point for IVMLE CHECK ERROR OFF LIST protocol
"RTN","IVMLERR2",100,0)
 ; Input  -- None
"RTN","IVMLERR2",101,0)
 ; Output -- VALMSG   Custom message
"RTN","IVMLERR2",102,0)
 ;           VALMBCK  R   =Refresh screen
"RTN","IVMLERR2",103,0)
 N IVMLINE,IVMNUM,IVMTLIEN,VALMY
"RTN","IVMLERR2",104,0)
 ;
"RTN","IVMLERR2",105,0)
 ;Ask user to select transmission errors to check off the list
"RTN","IVMLERR2",106,0)
 D EN^VALM2(XQORNOD(0))
"RTN","IVMLERR2",107,0)
 D FULL^VALM1
"RTN","IVMLERR2",108,0)
 ;
"RTN","IVMLERR2",109,0)
 ;Process user selection
"RTN","IVMLERR2",110,0)
 S IVMNUM=0
"RTN","IVMLERR2",111,0)
 F  S IVMNUM=$O(VALMY(IVMNUM)) Q:'IVMNUM  D
"RTN","IVMLERR2",112,0)
 . ;Invoke call to check error off list
"RTN","IVMLERR2",113,0)
 . I $D(^TMP(IVMARY_"IDX",$J,IVMNUM)) S IVMLINE=+^(IVMNUM),IVMTLIEN=+$P(^(IVMNUM),U,2) D CHKERR(IVMARY,IVMLINE,IVMTLIEN)
"RTN","IVMLERR2",114,0)
 S VALMBCK="R"
"RTN","IVMLERR2",115,0)
 S VALMSG=$$MSG^IVMLERR
"RTN","IVMLERR2",116,0)
 Q
"RTN","IVMLERR2",117,0)
 ;
"RTN","IVMLERR2",118,0)
CHKERR(IVMARY,IVMLINE,IVMTLIEN) ;Check error off list
"RTN","IVMLERR2",119,0)
 ; Input  -- IVMARY   Global array subscript
"RTN","IVMLERR2",120,0)
 ;           IVMLINE  Line number
"RTN","IVMLERR2",121,0)
 ;           IVMTLIEN IVM transmission log IEN
"RTN","IVMLERR2",122,0)
 ; Output -- None
"RTN","IVMLERR2",123,0)
 N IVMERMSG
"RTN","IVMLERR2",124,0)
 I $$ERRSTAT^IVMTLOG(IVMTLIEN,2,.IVMERMSG) D
"RTN","IVMLERR2",125,0)
 . D FLDTEXT^VALM10(IVMLINE,"STATUS","Checked")
"RTN","IVMLERR2",126,0)
 . D FLDCTRL^VALM10(IVMLINE,"STATUS",IOINHI,IOINORM)
"RTN","IVMLERR2",127,0)
 ELSE  D
"RTN","IVMLERR2",128,0)
 . W !,^TMP(IVMARY,$J,IVMLINE,0)
"RTN","IVMLERR2",129,0)
 . W:$G(IVMERMSG)'="" !,"...",$$LOWER^VALM1(IVMERMSG)
"RTN","IVMLERR2",130,0)
 . W !,"...Unable to check error off list"
"RTN","IVMLERR2",131,0)
 . D PAUSE^VALM1
"RTN","IVMLERR2",132,0)
 Q
"RTN","IVMLERR2",133,0)
 ;
"RTN","IVMLERR2",134,0)
RP ;Entry point for IVMLE RETRANSMIT PATIENT protocol
"RTN","IVMLERR2",135,0)
 ; Input  -- None
"RTN","IVMLERR2",136,0)
 ; Output -- VALMSG   Custom message
"RTN","IVMLERR2",137,0)
 ;           VALMBCK  R   =Refresh screen
"RTN","IVMLERR2",138,0)
 N IVMLINE,IVMNUM,IVMTLIEN,IVMTLOG,VALMY
"RTN","IVMLERR2",139,0)
 ;
"RTN","IVMLERR2",140,0)
 ;Ask user to select transmission errors to retransmit patient
"RTN","IVMLERR2",141,0)
 D EN^VALM2(XQORNOD(0))
"RTN","IVMLERR2",142,0)
 D FULL^VALM1
"RTN","IVMLERR2",143,0)
 ;
"RTN","IVMLERR2",144,0)
 ;Process user selection
"RTN","IVMLERR2",145,0)
 S IVMNUM=0
"RTN","IVMLERR2",146,0)
 F  S IVMNUM=$O(VALMY(IVMNUM)) Q:'IVMNUM  D
"RTN","IVMLERR2",147,0)
 . I $D(^TMP(IVMARY_"IDX",$J,IVMNUM)) S IVMLINE=+^(IVMNUM),IVMTLIEN=+$P(^(IVMNUM),U,2) D
"RTN","IVMLERR2",148,0)
 . . ;Get information for IVM transmission log entry and invoke code
"RTN","IVMLERR2",149,0)
 . . ;to set patient to retransmit
"RTN","IVMLERR2",150,0)
 . . I $$GET^IVMTLOG(IVMTLIEN,.IVMTLOG) D SETPAT(IVMARY,IVMLINE,.IVMTLOG)
"RTN","IVMLERR2",151,0)
 S VALMBCK="R"
"RTN","IVMLERR2",152,0)
 S VALMSG=$$MSG^IVMLERR
"RTN","IVMLERR2",153,0)
 Q
"RTN","IVMLERR2",154,0)
 ;
"RTN","IVMLERR2",155,0)
SETPAT(IVMARY,IVMLINE,IVMTLOG) ;Set patient to retransmit
"RTN","IVMLERR2",156,0)
 ; Input  -- IVMARY   Global array subscript
"RTN","IVMLERR2",157,0)
 ;           IVMLINE  Line number
"RTN","IVMLERR2",158,0)
 ;           IVMTLOG  IVM transmission log entry array
"RTN","IVMLERR2",159,0)
 ; Output -- None
"RTN","IVMLERR2",160,0)
 N IVMERMSG,IVMEVTS
"RTN","IVMLERR2",161,0)
 M IVMEVTS=IVMTLOG("EVENTS")
"RTN","IVMLERR2",162,0)
 ;
"RTN","IVMLERR2",163,0)
 ;Set patient to retransmit
"RTN","IVMLERR2",164,0)
 I $$SETSTAT^IVMPLOG(IVMTLOG("PAT"),.IVMEVTS,.IVMERMSG) D
"RTN","IVMLERR2",165,0)
 . D UPDPAT(IVMARY,IVMTLOG("PAT"))
"RTN","IVMLERR2",166,0)
 ELSE  D
"RTN","IVMLERR2",167,0)
 . W !,^TMP(IVMARY,$J,IVMLINE,0)
"RTN","IVMLERR2",168,0)
 . W:$G(IVMERMSG)'="" !,"...",$$LOWER^VALM1(IVMERMSG)
"RTN","IVMLERR2",169,0)
 . W !,"...Unable to set transmit flag for patient"
"RTN","IVMLERR2",170,0)
 . D PAUSE^VALM1
"RTN","IVMLERR2",171,0)
 Q
"RTN","IVMLERR2",172,0)
 ;
"RTN","IVMLERR2",173,0)
UPDPAT(IVMARY,IVMDFN) ;Update all IVM transmssion error log entries in the list
"RTN","IVMLERR2",174,0)
 ;for the patient as retransmit
"RTN","IVMLERR2",175,0)
 ; Input  -- IVMARY   Global array subscript
"RTN","IVMLERR2",176,0)
 ;           IVMDFN   IVM patient IEN
"RTN","IVMLERR2",177,0)
 ; Output -- None
"RTN","IVMLERR2",178,0)
 N IVMLINE,IVMTLIEN
"RTN","IVMLERR2",179,0)
 ;
"RTN","IVMLERR2",180,0)
 ;Loop through entries in the list for the patient
"RTN","IVMLERR2",181,0)
 S IVMLINE=0
"RTN","IVMLERR2",182,0)
 F  S IVMLINE=$O(^TMP(IVMARY_"IDX",$J,"PT",IVMDFN,IVMLINE)) Q:'IVMLINE  S IVMTLIEN=+^(IVMLINE) D
"RTN","IVMLERR2",183,0)
 . ;Update entry as retransmit
"RTN","IVMLERR2",184,0)
 . D FLDTEXT^VALM10(IVMLINE,"RETRANSMIT","*")
"RTN","IVMLERR2",185,0)
 . D FLDCTRL^VALM10(IVMLINE,"RETRANSMIT",IOINHI,IOINORM)
"RTN","IVMLERR2",186,0)
 . ;Invoke code to check error off the list
"RTN","IVMLERR2",187,0)
 . D CHKERR(IVMARY,IVMLINE,IVMTLIEN)
"RTN","IVMLERR2",188,0)
 Q
"RTN","IVMLINS1")
0^7^B30151402
"RTN","IVMLINS1",1,0)
IVMLINS1 ;ALB/KCL,TDM - IVM INSURANCE DISPLAY POLICY ; 12/23/08 3:44pm
"RTN","IVMLINS1",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**14,94,111,121**; 21-OCT-94;Build 45
"RTN","IVMLINS1",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMLINS1",4,0)
 ;
"RTN","IVMLINS1",5,0)
 ;
"RTN","IVMLINS1",6,0)
DE ; - select patient for insurance information upload/purge
"RTN","IVMLINS1",7,0)
 ;
"RTN","IVMLINS1",8,0)
 ;  Input:   - ^TMP("IVMLST",$J,"IDX",CTR,CTR)=pat name_pat ssn_ivm ien_ivm sub ien
"RTN","IVMLINS1",9,0)
 ;
"RTN","IVMLINS1",10,0)
 ;
"RTN","IVMLINS1",11,0)
 ;
"RTN","IVMLINS1",12,0)
 S IVMDONE=0
"RTN","IVMLINS1",13,0)
 ;
"RTN","IVMLINS1",14,0)
 ; - generic seletor used within a list manager action call
"RTN","IVMLINS1",15,0)
 D EN^VALM2($G(XQORNOD(0)),"S")
"RTN","IVMLINS1",16,0)
 Q:'$D(VALMY)
"RTN","IVMLINS1",17,0)
 S IVMENT=0 F  S IVMENT=$O(VALMY(IVMENT)) Q:'IVMENT  D
"RTN","IVMLINS1",18,0)
 .;
"RTN","IVMLINS1",19,0)
 .; - get index for look-up
"RTN","IVMLINS1",20,0)
 .S IVMIDX=$G(^TMP("IVMLST",$J,"IDX",IVMENT,IVMENT)) I IVMIDX']"" Q
"RTN","IVMLINS1",21,0)
 .;
"RTN","IVMLINS1",22,0)
 .; - change if HL7 segment sep ever changes!
"RTN","IVMLINS1",23,0)
 .S HLFS="^",HLECH="~"
"RTN","IVMLINS1",24,0)
 .;
"RTN","IVMLINS1",25,0)
 .; - get patient name, ssn, da(1), da
"RTN","IVMLINS1",26,0)
 .S IVMNAME=$P(IVMIDX,"^",1),IVMSSN=$P(IVMIDX,"^",2),IVMI=$P(IVMIDX,"^",3),IVMJ=$P(IVMIDX,"^",4)
"RTN","IVMLINS1",27,0)
 .;
"RTN","IVMLINS1",28,0)
 .; - get data node from list manager storage array
"RTN","IVMLINS1",29,0)
 .S IVMDND=$G(^TMP("IVMIUPL",$J,IVMNAME,IVMI,IVMJ)),DFN=$P(IVMDND,"^",1)
"RTN","IVMLINS1",30,0)
 .;
"RTN","IVMLINS1",31,0)
 . S IVMIN1=$$GETIN1(IVMI,IVMJ)
"RTN","IVMLINS1",32,0)
 .;
"RTN","IVMLINS1",33,0)
 .; - alert user if date of death
"RTN","IVMLINS1",34,0)
 .I $P(IVMDND,"^",6)]""!($P($G(^DPT(+DFN,.35)),"^")]"") D DOD^IVMLINS2
"RTN","IVMLINS1",35,0)
 .;
"RTN","IVMLINS1",36,0)
 .; - display all insurance currently on file in DHCP
"RTN","IVMLINS1",37,0)
 .D CLEAR^VALM1,ALL
"RTN","IVMLINS1",38,0)
 .; - display insurance information received from IVM IN1 segment
"RTN","IVMLINS1",39,0)
 .D HDR,DISP1
"RTN","IVMLINS1",40,0)
 .S DIR(0)="E",DIR("A")="Press RETURN to continue or '^' to return to display screen" D ^DIR K DIR Q:'Y
"RTN","IVMLINS1",41,0)
 .;
"RTN","IVMLINS1",42,0)
 .; - ask user to add or purge
"RTN","IVMLINS1",43,0)
 .D ASK^IVMLINS2
"RTN","IVMLINS1",44,0)
 ;
"RTN","IVMLINS1",45,0)
DEQ ; - clean up variables
"RTN","IVMLINS1",46,0)
 D IVMQ
"RTN","IVMLINS1",47,0)
 Q
"RTN","IVMLINS1",48,0)
 ;
"RTN","IVMLINS1",49,0)
 ;
"RTN","IVMLINS1",50,0)
GETIN1(IVMI,IVMJ) ; get IN1 segment from (#301.5) file containing ins data
"RTN","IVMLINS1",51,0)
 S IVMIN1=$G(^IVM(301.5,IVMI,"IN",IVMJ,"ST"))
"RTN","IVMLINS1",52,0)
 ; - set if IN1 segment exceeds 245 chars
"RTN","IVMLINS1",53,0)
 S:$D(^IVM(301.5,IVMI,"IN",IVMJ,"ST1")) IVMIN1=IVMIN1_(^("ST1"))
"RTN","IVMLINS1",54,0)
 ;
"RTN","IVMLINS1",55,0)
 Q IVMIN1
"RTN","IVMLINS1",56,0)
 ;
"RTN","IVMLINS1",57,0)
ALL ; - display all insurance company information for patient in DHCP
"RTN","IVMLINS1",58,0)
 ;
"RTN","IVMLINS1",59,0)
 W !,?22,"INSURANCE POLICIES CURRENTLY ON FILE"
"RTN","IVMLINS1",60,0)
 ; - write dashed line
"RTN","IVMLINS1",61,0)
 W !,?7,$TR($J("",66)," ","*")
"RTN","IVMLINS1",62,0)
 ;
"RTN","IVMLINS1",63,0)
 ; - IB call to display all DHCP ins co. information
"RTN","IVMLINS1",64,0)
 D DISP^DGIBDSP
"RTN","IVMLINS1",65,0)
 W !
"RTN","IVMLINS1",66,0)
 Q
"RTN","IVMLINS1",67,0)
 ;
"RTN","IVMLINS1",68,0)
 ;
"RTN","IVMLINS1",69,0)
HDR ; - header for insurance data received from HEC
"RTN","IVMLINS1",70,0)
 W !,?23,"INSURANCE POLICY RECEIVED FROM HEC"
"RTN","IVMLINS1",71,0)
 ; - write dashed line
"RTN","IVMLINS1",72,0)
 W !,?7,$TR($J("",66)," ","*")
"RTN","IVMLINS1",73,0)
 Q
"RTN","IVMLINS1",74,0)
 ;
"RTN","IVMLINS1",75,0)
 ;
"RTN","IVMLINS1",76,0)
DISP1 ; - display insurance fields from IN1 segment
"RTN","IVMLINS1",77,0)
 ;
"RTN","IVMLINS1",78,0)
 ; - ins effec and exp dates in FM format
"RTN","IVMLINS1",79,0)
 S IVMEFF=$$FMDATE^HLFNC($P(IVMIN1,HLFS,12)),IVMEXP=$$FMDATE^HLFNC($P(IVMIN1,HLFS,13))
"RTN","IVMLINS1",80,0)
 ;
"RTN","IVMLINS1",81,0)
 S IVMADD=$P(IVMIN1,"^",5)
"RTN","IVMLINS1",82,0)
 S IVMPLAN=$P(IVMIN1,HLFS,15),IVMPLAN=$P($G(^IBE(355.1,+IVMPLAN,0)),"^")
"RTN","IVMLINS1",83,0)
 ;
"RTN","IVMLINS1",84,0)
 ; - display insurance policy fields from IVM
"RTN","IVMLINS1",85,0)
 W !,?2,"Company: ",?9,$E($P(IVMIN1,HLFS,4),1,32),?45,"Effective Date: ",?62,$$DAT2^IVMUFNC4(IVMEFF)
"RTN","IVMLINS1",86,0)
 W !,?2,"Phone #: ",?9,$E($P(IVMIN1,HLFS,7),1,25),?45,"Expiration Date: ",?62,$$DAT2^IVMUFNC4(IVMEXP)
"RTN","IVMLINS1",87,0)
 W !,?2,"Address: ",?45,"Subscriber ID: " W:$P(IVMIN1,HLFS,36)]"" ?59,$E($P(IVMIN1,HLFS,36),1,20) W !
"RTN","IVMLINS1",88,0)
 W:$P(IVMADD,HLECH,1)]"" ?4,$E($P(IVMADD,HLECH,1),1,35) W ?45,"Policy Holder: " W:$P(IVMIN1,HLFS,17)]"" ?59,$S($P(IVMIN1,HLFS,17)="v":"SELF",$P(IVMIN1,HLFS,17)="s":"SPOUSE",1:"OTHER")
"RTN","IVMLINS1",89,0)
 W:$P(IVMADD,HLECH,1)']"" !
"RTN","IVMLINS1",90,0)
 W:$P(IVMADD,HLECH,2)]"" !,?4,$E($P(IVMADD,HLECH,2),1,35)
"RTN","IVMLINS1",91,0)
 W:$P(IVMADD,HLECH,8)]"" !,?4,$E($P(IVMADD,HLECH,8),1,35) ; address line 3
"RTN","IVMLINS1",92,0)
 W:$P(IVMADD,HLECH,3)]""!($P(IVMADD,HLECH,4)]"")!($P(IVMADD,HLECH,5)]"") !,?4,$P(IVMADD,HLECH,3) W:$P(IVMADD,HLECH,3)]""&($P(IVMADD,HLECH,4)]"") ", ",$E($P(IVMADD,HLECH,4),1,2)
"RTN","IVMLINS1",93,0)
 W:$P(IVMADD,HLECH,5)]""&($P(IVMADD,HLECH,3)]""!($P(IVMADD,HLECH,4)]"")) " "
"RTN","IVMLINS1",94,0)
 W $P(IVMADD,HLECH,5)
"RTN","IVMLINS1",95,0)
 I $P(IVMADD,HLECH,2)']"" D
"RTN","IVMLINS1",96,0)
 .W !,?45,"Group Name: " W:$P(IVMIN1,HLFS,9)]"" ?59,$E($P(IVMIN1,HLFS,9),1,20)
"RTN","IVMLINS1",97,0)
 W:$P(IVMADD,HLECH,2)]"" ?45,"Group Name: " W:$P(IVMADD,HLECH,2)]""&($P(IVMIN1,HLFS,9)]"") ?59,$E($P(IVMIN1,HLFS,9),1,20)
"RTN","IVMLINS1",98,0)
 W !,?45,"Group Number: " W:$P(IVMIN1,HLFS,8)]"" ?59,$E($P(IVMIN1,HLFS,8),1,20)
"RTN","IVMLINS1",99,0)
 W !,?2,"Name of Insured: " W:$P(IVMIN1,HLFS,16)]"" ?9,$E($$FMNAME^HLFNC($P(IVMIN1,HLFS,16)),1,23) W:$P(IVMIN1,HLFS,16)']"" ?9,$E(IVMNAME,1,23)
"RTN","IVMLINS1",100,0)
 W ?45,"Pre-Cert. Req?: " W:$P(IVMIN1,HLFS,28)]"" ?60,$S($P(IVMIN1,HLFS,28)=1:"YES",$P(IVMIN1,HLFS,28)=0:"NO",1:"")
"RTN","IVMLINS1",101,0)
 I $P(IVMIN1,HLFS,16)]"" S $P(IVMIN1,HLFS,16)=$$FMNAME^HLFNC($P(IVMIN1,HLFS,16))
"RTN","IVMLINS1",102,0)
 W !,?45,"Plan Type: ",?55,$E(IVMPLAN,1,23) W !
"RTN","IVMLINS1",103,0)
 Q
"RTN","IVMLINS1",104,0)
 ;
"RTN","IVMLINS1",105,0)
 ;
"RTN","IVMLINS1",106,0)
DISP2 ; - display ins co. name and address
"RTN","IVMLINS1",107,0)
 W !,?4,"Insurance Company: ",$E($P(IVMIN1,HLFS,4),1,45),!
"RTN","IVMLINS1",108,0)
 W !,?4,"Company Address:   " W:$P(IVMADD,HLECH,1)]"" ?23,$E($P(IVMADD,HLECH,1),1,35) ; address line1
"RTN","IVMLINS1",109,0)
 W:$P(IVMADD,HLECH,2)]"" !?23,$E($P(IVMADD,HLECH,2),1,35) ; address line2
"RTN","IVMLINS1",110,0)
 W:$P(IVMADD,HLECH,8)]"" !,23,$E($P(IVMADD,HLECH,2),1,35) ; address line3
"RTN","IVMLINS1",111,0)
 W:$P(IVMADD,HLECH,3)]""!($P(IVMADD,HLECH,4)]"")!($P(IVMADD,HLECH,5)]"") !?23
"RTN","IVMLINS1",112,0)
 W $P(IVMADD,HLECH,3) W:$P(IVMADD,HLECH,3)]""&($P(IVMADD,HLECH,4)]"") ", " ; city
"RTN","IVMLINS1",113,0)
 W $E($P(IVMADD,HLECH,4),1,2) ; state
"RTN","IVMLINS1",114,0)
 W:$P(IVMADD,HLECH,5)]""&($P(IVMADD,HLECH,3)]""!($P(IVMADD,HLECH,4)]"")) " "
"RTN","IVMLINS1",115,0)
 W $P(IVMADD,HLECH,5) ; zip
"RTN","IVMLINS1",116,0)
 Q
"RTN","IVMLINS1",117,0)
 ;
"RTN","IVMLINS1",118,0)
 ;
"RTN","IVMLINS1",119,0)
IVMQ ; - kill variables used from all protocols
"RTN","IVMLINS1",120,0)
 ;
"RTN","IVMLINS1",121,0)
 ; - if action completed reset List Man array for display
"RTN","IVMLINS1",122,0)
 I $D(^TMP("IVMLST",$J)) D  ; Only if list manager array exists
"RTN","IVMLINS1",123,0)
 . I IVMDONE D INIT^IVMLINS
"RTN","IVMLINS1",124,0)
 . ;
"RTN","IVMLINS1",125,0)
 . S VALMBCK="R"
"RTN","IVMLINS1",126,0)
 K DA,DFN,IVM0NOD,IVMADD,IVMDND,IVMDONE,IVMEFF,IVMENT,IVMEXP
"RTN","IVMLINS1",127,0)
 K IVMI,IVMIDX,IVMIN1,IVMJ,IVMNAME,IVMPLAN,IVMSSN,Y
"RTN","IVMLINS1",128,0)
 Q
"RTN","IVMLINS3")
0^12^B12231839
"RTN","IVMLINS3",1,0)
IVMLINS3 ;ALB/KCL,TDM - IVM INSURANCE POLICY TRANSFER ; 3/9/09 2:01pm
"RTN","IVMLINS3",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**14,111,121**; 21-OCT-94;Build 45
"RTN","IVMLINS3",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMLINS3",4,0)
 ;
"RTN","IVMLINS3",5,0)
 ;
"RTN","IVMLINS3",6,0)
TRANSFER(IVMAUTO) ; user has chosen to transfer insurance information,
"RTN","IVMLINS3",7,0)
 ; received from HEC, to the MCCR insurance buffer.  this routine
"RTN","IVMLINS3",8,0)
 ; will call $$ADDSTF^IBCNBES(3,DFN,IVMIBDAT) to place HEC's insurance
"RTN","IVMLINS3",9,0)
 ; information in the MCCR insurance buffer where authorized insurance
"RTN","IVMLINS3",10,0)
 ; personnel will either upload or reject the data.
"RTN","IVMLINS3",11,0)
 ;      3 indicates that source of information is IVM
"RTN","IVMLINS3",12,0)
 ;      IVMIBDAT = data, to be filed in the MCCR buffer, in an array
"RTN","IVMLINS3",13,0)
 ;                 subscripted by field number of the data field in
"RTN","IVMLINS3",14,0)
 ;                 the INSURANCE BUFFER file (#355.33) 
"RTN","IVMLINS3",15,0)
 ; INPUT: IVMAUTO = 1 if auto-filing directly from upload
"RTN","IVMLINS3",16,0)
 ;                  0 if using list manager interface to file
"RTN","IVMLINS3",17,0)
 ;        THE FOLLOWING ARE ASSUMED TO BE DEFINED:
"RTN","IVMLINS3",18,0)
 ;          IVMIN1 (ST/ST1 segment string nodes of file 301.5)
"RTN","IVMLINS3",19,0)
 ;          IVMADD (5th "^" piece of IVMIN1 for ins co address data)
"RTN","IVMLINS3",20,0)
 ;
"RTN","IVMLINS3",21,0)
 N IVMIB,IVMIBDAT,IVMNOI,IVMPRTI
"RTN","IVMLINS3",22,0)
 ;
"RTN","IVMLINS3",23,0)
 I '$G(IVMAUTO) W !!,"Transferring HEC'S insurance data to the MCCR insurance buffer",!
"RTN","IVMLINS3",24,0)
 S IVMNOI=$S($P(IVMIN1,HLFS,17)="v":$P($$PT^IVMUFNC4(DFN),"^"),1:$P(IVMIN1,HLFS,16))
"RTN","IVMLINS3",25,0)
 S IVMPRTI=$S($P(IVMIN1,HLFS,17)="v":"01",1:"02")
"RTN","IVMLINS3",26,0)
 ;
"RTN","IVMLINS3",27,0)
 S IVMIBDAT(20.01)=$E($P(IVMIN1,HLFS,4),1,30) ;ins co name
"RTN","IVMLINS3",28,0)
 S IVMIBDAT(20.02)=$E($P(IVMIN1,HLFS,7),1,20) ;phone number
"RTN","IVMLINS3",29,0)
 S IVMIBDAT(21.01)=$E($P(IVMADD,"~",1),1,35) ;street add [line 1]
"RTN","IVMLINS3",30,0)
 S IVMIBDAT(21.02)=$E($P(IVMADD,"~",2),1,30) ;street add [line 2]
"RTN","IVMLINS3",31,0)
 S IVMIBDAT(21.03)=$E($P(IVMADD,"~",8),1,30) ;street add [line 3]
"RTN","IVMLINS3",32,0)
 S IVMIBDAT(21.04)=$E($P(IVMADD,"~",3),1,25) ;city
"RTN","IVMLINS3",33,0)
 S IVMIBDAT(21.05)=$$STATE1^IVMUFNC4($P(IVMADD,"~",4)) ;state
"RTN","IVMLINS3",34,0)
 S IVMIBDAT(21.06)=$E($P(IVMADD,"~",5),1,20) ;zip
"RTN","IVMLINS3",35,0)
 S IVMIBDAT(40.02)=$E($P(IVMIN1,HLFS,9),1,20) ;group name
"RTN","IVMLINS3",36,0)
 S IVMIBDAT(40.03)=$E($P(IVMIN1,HLFS,8),1,17) ;group number
"RTN","IVMLINS3",37,0)
 S IVMIBDAT(40.05)=$S($P(IVMIN1,HLFS,28)=1:1,1:0) ;precertification required
"RTN","IVMLINS3",38,0)
 S IVMIBDAT(40.09)=$P(IVMIN1,HLFS,15) ;type of plan
"RTN","IVMLINS3",39,0)
 S IVMIBDAT(60.01)=DFN ;patient name
"RTN","IVMLINS3",40,0)
 S IVMIBDAT(60.02)=$$FMDATE^HLFNC($P(IVMIN1,HLFS,12)) ;effective date
"RTN","IVMLINS3",41,0)
 S IVMIBDAT(60.03)=$$FMDATE^HLFNC($P(IVMIN1,HLFS,13)) ;expiration date
"RTN","IVMLINS3",42,0)
 S IVMIBDAT(60.04)=$E($P(IVMIN1,HLFS,36),1,20) ;subcriber id
"RTN","IVMLINS3",43,0)
 S IVMIBDAT(60.05)=$P(IVMIN1,HLFS,17) ;whose insurance
"RTN","IVMLINS3",44,0)
 S IVMIBDAT(60.06)=IVMPRTI ;pt relationship to insured
"RTN","IVMLINS3",45,0)
 S IVMIBDAT(60.07)=IVMNOI ;name of insured
"RTN","IVMLINS3",46,0)
 ;
"RTN","IVMLINS3",47,0)
 S IVMIB=$$ADDSTF^IBCNBES(3,DFN,.IVMIBDAT)
"RTN","IVMLINS3",48,0)
 I 'IVMIB D  Q
"RTN","IVMLINS3",49,0)
 .Q:$G(IVMAUTO)
"RTN","IVMLINS3",50,0)
 .W !,"The following error occurred when transferring data:"
"RTN","IVMLINS3",51,0)
 .W !,$P(IVMIB,"^",2)
"RTN","IVMLINS3",52,0)
 .W !,"Please contact your IRM staff for help"
"RTN","IVMLINS3",53,0)
 ;
"RTN","IVMLINS3",54,0)
 N DA,DIE,DR
"RTN","IVMLINS3",55,0)
 S DA=IVMJ,DA(1)=IVMI
"RTN","IVMLINS3",56,0)
 ;
"RTN","IVMLINS3",57,0)
 ; - delete segment name (.02 field of 301.501 multiple) from IVM PATIENT
"RTN","IVMLINS3",58,0)
 ;   file to remove from ASEG cross-reference
"RTN","IVMLINS3",59,0)
 S DIE="^IVM(301.5,"_DA(1)_",""IN"",",DR=".02////@" D ^DIE
"RTN","IVMLINS3",60,0)
 ;
"RTN","IVMLINS3",61,0)
 I $G(IVMAUTO) G IVMQ
"RTN","IVMLINS3",62,0)
 ;
"RTN","IVMLINS3",63,0)
 W "completed.",!
"RTN","IVMLINS3",64,0)
 ;
"RTN","IVMLINS3",65,0)
 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
"RTN","IVMLINS3",66,0)
 ;
"RTN","IVMLINS3",67,0)
REMOVE ; - remove entry from the List Manager display after transferring
"RTN","IVMLINS3",68,0)
 K ^TMP("IVMIUPL",$J,IVMNAME,IVMI,IVMJ)
"RTN","IVMLINS3",69,0)
 ;
"RTN","IVMLINS3",70,0)
 ; - action completed
"RTN","IVMLINS3",71,0)
 S IVMDONE=1
"RTN","IVMLINS3",72,0)
 ;
"RTN","IVMLINS3",73,0)
IVMQ K DIRUT,DTOUT,DUOUT,IVMACT,IVMDA,IVMFLAG,IVMREPTR,X,Y
"RTN","IVMLINS3",74,0)
 Q
"RTN","IVMLINS3",75,0)
 ;
"RTN","IVMLINS3",76,0)
AUTO ; Auto-upload all Z04 entries pending in file 301.501
"RTN","IVMLINS3",77,0)
 ; Called by the patch IVM*2*111 post-install
"RTN","IVMLINS3",78,0)
 N DFN,IVMI,IVMJ,IVMIN1,IVMADD,IVM0NOD,HLFS
"RTN","IVMLINS3",79,0)
 S HLFS=U
"RTN","IVMLINS3",80,0)
 ;
"RTN","IVMLINS3",81,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.5,"ASEG","IN1",IVMI)) Q:'IVMI  D
"RTN","IVMLINS3",82,0)
 . S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,"ASEG","IN1",IVMI,IVMJ)) Q:'IVMJ  D
"RTN","IVMLINS3",83,0)
 .. S IVM0NOD=$G(^IVM(301.5,IVMI,0)) I IVM0NOD']"" Q
"RTN","IVMLINS3",84,0)
 .. S DFN=+IVM0NOD
"RTN","IVMLINS3",85,0)
 .. I $G(^DPT(+DFN,0))']"" Q
"RTN","IVMLINS3",86,0)
 .. Q:$P($G(^IVM(301.5,IVMI,"IN",IVMJ,0)),U,2)'="IN1"
"RTN","IVMLINS3",87,0)
 .. S IVMIN1=$$GETIN1^IVMLINS1(IVMI,IVMJ)
"RTN","IVMLINS3",88,0)
 .. Q:IVMIN1=""
"RTN","IVMLINS3",89,0)
 .. S IVMADD=$P(IVMIN1,U,5)
"RTN","IVMLINS3",90,0)
 .. D TRANSFER(1)
"RTN","IVMLINS3",91,0)
 ;
"RTN","IVMLINS3",92,0)
 Q
"RTN","IVMLINS3",93,0)
 ;
"RTN","IVMPREC6")
0^8^B143009000
"RTN","IVMPREC6",1,0)
IVMPREC6 ;ALB/KCL/BRM/CKN,TDM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ; 1/19/11 11:12am
"RTN","IVMPREC6",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**3,4,12,17,34,58,79,102,115,140,144,121**;21-OCT-94;Build 45
"RTN","IVMPREC6",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMPREC6",4,0)
 ;
"RTN","IVMPREC6",5,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC6",6,0)
 ; messages received from the IVM center.  Format of HL7 batch message:
"RTN","IVMPREC6",7,0)
 ;
"RTN","IVMPREC6",8,0)
 ;       BHS
"RTN","IVMPREC6",9,0)
 ;       {MSH
"RTN","IVMPREC6",10,0)
 ;        PID
"RTN","IVMPREC6",11,0)
 ;        ZPD
"RTN","IVMPREC6",12,0)
 ;        ZTA
"RTN","IVMPREC6",13,0)
 ;        ZGD
"RTN","IVMPREC6",14,0)
 ;        ZCT (1 episode required, multiple possible)
"RTN","IVMPREC6",15,0)
 ;        ZEM (Veteran)
"RTN","IVMPREC6",16,0)
 ;        ZEM (Spouse - Optional)
"RTN","IVMPREC6",17,0)
 ;        RF1 (optional, multiple possible)
"RTN","IVMPREC6",18,0)
 ;       }
"RTN","IVMPREC6",19,0)
 ;       BTS
"RTN","IVMPREC6",20,0)
 ;
"RTN","IVMPREC6",21,0)
 ;
"RTN","IVMPREC6",22,0)
EN ; - entry point to process HL7 patient demographic message 
"RTN","IVMPREC6",23,0)
 ;
"RTN","IVMPREC6",24,0)
 N DGENUPLD,VAFCA08,DGRUGA08,COMP,DODSEG,GUARSEG
"RTN","IVMPREC6",25,0)
 ;N MULTDONE,XREP
"RTN","IVMPREC6",26,0)
 N XIVMA,IVMALADT,MULTIDONE
"RTN","IVMPREC6",27,0)
 ;
"RTN","IVMPREC6",28,0)
 ; Setup array to hold all the Allowed Address Types
"RTN","IVMPREC6",29,0)
 ;F XIVMA="N","P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
"RTN","IVMPREC6",30,0)
 F XIVMA="P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
"RTN","IVMPREC6",31,0)
 ; Define the Confidential Address Categories
"RTN","IVMPREC6",32,0)
 ;S IVMALADT("VACAE")="CA^1"      ; ELIGIBILITY/ENROLLMENT
"RTN","IVMPREC6",33,0)
 ;S IVMALADT("VACAA")="CA^2"      ; APPOINTMENT/SCHEDULING
"RTN","IVMPREC6",34,0)
 ;S IVMALADT("VACAC")="CA^3"      ; COPAYMENTS/VETERAN BILLING
"RTN","IVMPREC6",35,0)
 ;S IVMALADT("VACAM")="CA^4"      ; MEDICAL RECORDS
"RTN","IVMPREC6",36,0)
 ;S IVMALADT("VACAO")="CA^5"      ; ALL OTHERS
"RTN","IVMPREC6",37,0)
 ; prevent a return Z07 when uploading a Z05 (Patient file triggers)
"RTN","IVMPREC6",38,0)
 S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
"RTN","IVMPREC6",39,0)
 ;
"RTN","IVMPREC6",40,0)
 ; prevent MPI A08 message when uploading Z05 (Patient file triggers)
"RTN","IVMPREC6",41,0)
 S VAFCA08=1  ;MPI/CIRN A08 suppression flag
"RTN","IVMPREC6",42,0)
 ;
"RTN","IVMPREC6",43,0)
 S IVMFLG=0,IVMADFLG=0
"RTN","IVMPREC6",44,0)
 ; - get incoming HL7 message from HL7 Transmission (#772) file
"RTN","IVMPREC6",45,0)
 F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA  S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D
"RTN","IVMPREC6",46,0)
 .K HLERR
"RTN","IVMPREC6",47,0)
 .;
"RTN","IVMPREC6",48,0)
 .; - message control id from MSH segment
"RTN","IVMPREC6",49,0)
 .S MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID
"RTN","IVMPREC6",50,0)
 .;
"RTN","IVMPREC6",51,0)
 .; - perform demographics message consistency check
"RTN","IVMPREC6",52,0)
 .D EN^IVMPRECA Q:$D(HLERR)
"RTN","IVMPREC6",53,0)
 .;
"RTN","IVMPREC6",54,0)
 .;Set array of Email, Cell, Pager fields
"RTN","IVMPREC6",55,0)
 .D EPCFLDS(.EPCFARY,.EPCDEL)
"RTN","IVMPREC6",56,0)
 .D AUPBLD(.AUPFARY,.UPDAUPG)
"RTN","IVMPREC6",57,0)
 .; - get next msg segment
"RTN","IVMPREC6",58,0)
 .D NEXT I $E(IVMSEG,1,3)'="PID" D  Q
"RTN","IVMPREC6",59,0)
 ..S HLERR="Missing PID segment" D ACK^IVMPREC
"RTN","IVMPREC6",60,0)
 .;
"RTN","IVMPREC6",61,0)
 .F I=1:1 D NEXT Q:$E(IVMSEG,1,4)="ZPD^"  ;Go through all PID
"RTN","IVMPREC6",62,0)
 .; - patient IEN (DFN) from PID segment
"RTN","IVMPREC6",63,0)
 .;Use IVMPID array created in IVMPRECA while performing consistency
"RTN","IVMPREC6",64,0)
 .;to process PID segment
"RTN","IVMPREC6",65,0)
 .;
"RTN","IVMPREC6",66,0)
 .;I '$G(IVMDFN) S HLERR="Invalid DFN" D ACK^IVMPREC  Q
"RTN","IVMPREC6",67,0)
 .S DFN=$G(IVMDFN)
"RTN","IVMPREC6",68,0)
 .;I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D  Q
"RTN","IVMPREC6",69,0)
 .;.S HLERR="Invalid DFN" D ACK^IVMPREC
"RTN","IVMPREC6",70,0)
 .;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) D  Q
"RTN","IVMPREC6",71,0)
 .;.S HLERR="Couldn't match HEC SSN with DHCP SSN" D ACK^IVMPREC
"RTN","IVMPREC6",72,0)
 .;
"RTN","IVMPREC6",73,0)
 .; - check for entry in IVM PATIENT file, otherwise create stub entry
"RTN","IVMPREC6",74,0)
 .S IVM3015=$O(^IVM(301.5,"B",DFN,0))
"RTN","IVMPREC6",75,0)
 .I 'IVM3015 S IVM3015=$$LOG^IVMPLOG(DFN,DT)
"RTN","IVMPREC6",76,0)
 .I 'IVM3015 D  Q
"RTN","IVMPREC6",77,0)
 ..S HLERR="Failed to create entry in IVM PATIENT file"
"RTN","IVMPREC6",78,0)
 ..D ACK^IVMPREC
"RTN","IVMPREC6",79,0)
 .;
"RTN","IVMPREC6",80,0)
 .; - compare PID segment fields with DHCP fields
"RTN","IVMPREC6",81,0)
 .S IVMSEG="PID"  ;Setting IVMSEG to PID before it calls COMPARE
"RTN","IVMPREC6",82,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) Q:$D(HLERR)
"RTN","IVMPREC6",83,0)
 .;
"RTN","IVMPREC6",84,0)
 .; - get next msg segment -decrement the counter so it can pickup ZPD
"RTN","IVMPREC6",85,0)
 .S IVMDA=IVMDA-1 D NEXT I $E(IVMSEG,1,3)'="ZPD" D  Q
"RTN","IVMPREC6",86,0)
 ..S HLERR="Missing ZPD segment" D ACK^IVMPREC
"RTN","IVMPREC6",87,0)
 .;Convert "" to null in ZPD segment except seq. 8,9, 31 and 32
"RTN","IVMPREC6",88,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",9,10,32,33,")
"RTN","IVMPREC6",89,0)
 .;
"RTN","IVMPREC6",90,0)
 .; - compare ZPD segment fields with DHCP fields
"RTN","IVMPREC6",91,0)
 .D COMPARE(IVMSEG)
"RTN","IVMPREC6",92,0)
 .;
"RTN","IVMPREC6",93,0)
 .; - get next msg segment
"RTN","IVMPREC6",94,0)
 .D NEXT I $E(IVMSEG,1,3)="ZEL" D  Q
"RTN","IVMPREC6",95,0)
 ..S HLERR="ZEL segment should not be sent in Z05 message" D ACK^IVMPREC
"RTN","IVMPREC6",96,0)
 .;
"RTN","IVMPREC6",97,0)
 .;I $E(IVMSEG,1,3)="ZTA" D NEXT    ;Skip ZTA -coming later
"RTN","IVMPREC6",98,0)
 .; - get next msg segment
"RTN","IVMPREC6",99,0)
 .I $E(IVMSEG,1,3)'="ZTA" D  Q
"RTN","IVMPREC6",100,0)
 ..S HLERR="Missing ZTA segment" D ACK^IVMPREC
"RTN","IVMPREC6",101,0)
 .;Convert "" to null in ZTA segment seq. 7
"RTN","IVMPREC6",102,0)
 .I $P(IVMSEG,HLFS,8)=HLQ S $P(IVMSEG,HLFS,8)=""
"RTN","IVMPREC6",103,0)
 .;
"RTN","IVMPREC6",104,0)
 .; - compare ZTA segment fields with DHCP fields
"RTN","IVMPREC6",105,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",106,0)
 .D NEXT
"RTN","IVMPREC6",107,0)
 .;
"RTN","IVMPREC6",108,0)
 .; - get next msg segment
"RTN","IVMPREC6",109,0)
 .I $E(IVMSEG,1,3)'="ZGD" D  Q
"RTN","IVMPREC6",110,0)
 ..S HLERR="Missing ZGD segment" D ACK^IVMPREC
"RTN","IVMPREC6",111,0)
 .;
"RTN","IVMPREC6",112,0)
 .; - compare ZGD segment fields with DHCP fields
"RTN","IVMPREC6",113,0)
 .; convert "" to null for ZGD segment
"RTN","IVMPREC6",114,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
"RTN","IVMPREC6",115,0)
 .; convert seq. 6 separately
"RTN","IVMPREC6",116,0)
 .S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
"RTN","IVMPREC6",117,0)
 .D COMPARE(IVMSEG)
"RTN","IVMPREC6",118,0)
 .;S IVMFLG=0
"RTN","IVMPREC6",119,0)
 .;
"RTN","IVMPREC6",120,0)
 .;S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Skip ZCT & ZEM -coming later
"RTN","IVMPREC6",121,0)
 .;.D NEXT
"RTN","IVMPREC6",122,0)
 .;.I ($E(IVMSEG,1,3)'="ZCT")&($E(IVMSEG,1,3)'="ZEM") S MULTDONE=1 Q
"RTN","IVMPREC6",123,0)
 .;S IVMDA=IVMDA-1
"RTN","IVMPREC6",124,0)
 .;
"RTN","IVMPREC6",125,0)
 .; - get next msg segment
"RTN","IVMPREC6",126,0)
 .D NEXT
"RTN","IVMPREC6",127,0)
 .I $E(IVMSEG,1,3)'="ZCT" D  Q
"RTN","IVMPREC6",128,0)
 ..S HLERR="Missing ZCT segment" D ACK^IVMPREC
"RTN","IVMPREC6",129,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",130,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)   ;Process 1st ZCT
"RTN","IVMPREC6",131,0)
 .S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Handle possible mult ZCTs
"RTN","IVMPREC6",132,0)
 ..D NEXT I $E(IVMSEG,1,3)'="ZCT" S MULTDONE=1 Q
"RTN","IVMPREC6",133,0)
 ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",134,0)
 ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",135,0)
 .;
"RTN","IVMPREC6",136,0)
 .S IVMDA=IVMDA-1 D NEXT
"RTN","IVMPREC6",137,0)
 .I $E(IVMSEG,1,3)'="ZEM" D  Q
"RTN","IVMPREC6",138,0)
 ..S HLERR="Missing ZEM segment" D ACK^IVMPREC
"RTN","IVMPREC6",139,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)   ;Process 1st ZEM
"RTN","IVMPREC6",140,0)
 .S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Handle possible mult ZEMs
"RTN","IVMPREC6",141,0)
 ..D NEXT I $E(IVMSEG,1,3)'="ZEM" S MULTDONE=1 Q
"RTN","IVMPREC6",142,0)
 ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",143,0)
 .S IVMDA=IVMDA-1
"RTN","IVMPREC6",144,0)
 .;
"RTN","IVMPREC6",145,0)
 .; - check for RF1 segment and get segment if it exists
"RTN","IVMPREC6",146,0)
 .;     This process will automatically update patient address data
"RTN","IVMPREC6",147,0)
 .;     in the Patient (#2) file if the incoming address is more
"RTN","IVMPREC6",148,0)
 .;     recent than the existing one.
"RTN","IVMPREC6",149,0)
 .;Modified code to handle multiple RF1 segment - IVM*2*115
"RTN","IVMPREC6",150,0)
 .S (UPDEPC("SAD"),UPDEPC("CPH"),UPDEPC("PNO"),UPDEPC("EAD"))=0
"RTN","IVMPREC6",151,0)
 .S QFLG=0 I $$RF1CHK(IVMRTN,IVMDA) F I=1:1 D  Q:QFLG
"RTN","IVMPREC6",152,0)
 ..D NEXT
"RTN","IVMPREC6",153,0)
 ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
"RTN","IVMPREC6",154,0)
 ..S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
"RTN","IVMPREC6",155,0)
 ..I $P(IVMSEG,HLFS,4)="" S QFLG=1 Q  ;Quit if RF1 is blank
"RTN","IVMPREC6",156,0)
 ..D COMPARE(IVMSEG)
"RTN","IVMPREC6",157,0)
 ..I '$$RF1CHK(IVMRTN,IVMDA) S QFLG=1
"RTN","IVMPREC6",158,0)
 .D AUTOAUP^IVMPREC9(DFN,.UPDAUP,.UPDAUPG)
"RTN","IVMPREC6",159,0)
 .S IVMFLG=0
"RTN","IVMPREC6",160,0)
 ;
"RTN","IVMPREC6",161,0)
 ; - send mail message if necessary
"RTN","IVMPREC6",162,0)
 ; This bulletin has been disabled.  IVM*2*140
"RTN","IVMPREC6",163,0)
 ;I IVMCNTR D MAIL^IVMUFNC()
"RTN","IVMPREC6",164,0)
 ; Cleanup variables if no msg necessary
"RTN","IVMPREC6",165,0)
 I 'IVMCNTR K IVMTEXT,XMSUB
"RTN","IVMPREC6",166,0)
 ;
"RTN","IVMPREC6",167,0)
ENQ ; - cleanup variables
"RTN","IVMPREC6",168,0)
 K DA,DFN,IVMADDR,IVMADFLG,IVMDA,IVMDHCP,IVMFLAG,IVMFLD,IVMPIECE,IVMSEG,IVMSTART,IVMXREF,DGENUPLD,IVMPID,PIDSTR,ADDRESS,TELECOM,UPDEPC,EPCFARY,IVMDFN,DODSEG,EPCDEL,GUARSEG,UPDAUP,IVMRACE
"RTN","IVMPREC6",169,0)
 Q
"RTN","IVMPREC6",170,0)
 ;
"RTN","IVMPREC6",171,0)
 ;
"RTN","IVMPREC6",172,0)
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
"RTN","IVMPREC6",173,0)
 ;
"RTN","IVMPREC6",174,0)
 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
"RTN","IVMPREC6",175,0)
 Q
"RTN","IVMPREC6",176,0)
 ;
"RTN","IVMPREC6",177,0)
 ;
"RTN","IVMPREC6",178,0)
COMPARE(IVMSEG) ; - compare incoming HL7 segment/fields with DHCP fields
"RTN","IVMPREC6",179,0)
 ;
"RTN","IVMPREC6",180,0)
 ;  Input:  IVMSEG  --  as the text of the incoming HL7 message
"RTN","IVMPREC6",181,0)
 ;
"RTN","IVMPREC6",182,0)
 ; Output:  None
"RTN","IVMPREC6",183,0)
 ;
"RTN","IVMPREC6",184,0)
 ; - get 3 letter HL7 segment name
"RTN","IVMPREC6",185,0)
 S IVMXREF=$P(IVMSEG,HLFS,1),IVMSTART=IVMXREF
"RTN","IVMPREC6",186,0)
 ;
"RTN","IVMPREC6",187,0)
 ; - strip off HL7 segment name
"RTN","IVMPREC6",188,0)
 S IVMSEG=$P(IVMSEG,HLFS,2,99)
"RTN","IVMPREC6",189,0)
 ;
"RTN","IVMPREC6",190,0)
 ; - roll through "C" x-ref in IVM Demographic Upload Fields (#301.92) file
"RTN","IVMPREC6",191,0)
 F  S IVMXREF=$O(^IVM(301.92,"C",IVMXREF)) Q:IVMXREF']""  D
"RTN","IVMPREC6",192,0)
 .S IVMDEMDA=$O(^IVM(301.92,"C",IVMXREF,"")) Q:IVMDEMDA']""
"RTN","IVMPREC6",193,0)
 .I $$INACTIVE(IVMDEMDA) Q
"RTN","IVMPREC6",194,0)
 .;
"RTN","IVMPREC6",195,0)
 .; - compare incoming HL7 segment fields with DHCP fields
"RTN","IVMPREC6",196,0)
 .I IVMXREF["PID",(IVMSTART["PID") D PID^IVMPREC8
"RTN","IVMPREC6",197,0)
 .I IVMXREF["ZPD",(IVMSTART["ZPD") D ZPD^IVMPREC8
"RTN","IVMPREC6",198,0)
 .;I IVMXREF["ZTA",(IVMSTART["ZTA") D ZTA^IVMPREC8
"RTN","IVMPREC6",199,0)
 .I IVMXREF["ZGD",(IVMSTART["ZGD") D ZGD^IVMPREC8
"RTN","IVMPREC6",200,0)
 .;I IVMXREF["ZCT",(IVMSTART["ZCT") D ZCT^IVMPREC8
"RTN","IVMPREC6",201,0)
 .;I IVMXREF["ZEM",(IVMSTART["ZEM") D ZEM^IVMPREC8
"RTN","IVMPREC6",202,0)
 .I IVMXREF["RF1",(IVMSTART["RF1") D RF1^IVMPREC8
"RTN","IVMPREC6",203,0)
 Q
"RTN","IVMPREC6",204,0)
 ;
"RTN","IVMPREC6",205,0)
 ;
"RTN","IVMPREC6",206,0)
DEMBULL ; -  build mail message for transmission to IVM mail group notifying
"RTN","IVMPREC6",207,0)
 ;    them that patients with updated demographic data has been received
"RTN","IVMPREC6",208,0)
 ;    from the IVM Center and may now be uploaded into DHCP.
"RTN","IVMPREC6",209,0)
 ;
"RTN","IVMPREC6",210,0)
 ; If record is auto uploaded, don't add veteran to bulletin
"RTN","IVMPREC6",211,0)
 I $$CKAUTO Q
"RTN","IVMPREC6",212,0)
 ;
"RTN","IVMPREC6",213,0)
 S IVMPTID=$$PT^IVMUFNC4(DFN)
"RTN","IVMPREC6",214,0)
 S XMSUB="IVM - DEMOGRAPHIC UPLOAD for "_$P($P(IVMPTID,"^"),",")_" ("_$P(IVMPTID,"^",3)_")"
"RTN","IVMPREC6",215,0)
 S IVMTEXT(1)="Updated demographic information has been received from the"
"RTN","IVMPREC6",216,0)
 S IVMTEXT(2)="Health Eligibilty Center.  Please select the 'Demographic Upload'"
"RTN","IVMPREC6",217,0)
 S IVMTEXT(3)="option from the IVM Upload Menu in order to take action on this"
"RTN","IVMPREC6",218,0)
 S IVMTEXT(4)="demographic information.  If you have any questions concerning the"
"RTN","IVMPREC6",219,0)
 S IVMTEXT(5)="information received, please contact the Health Eligibility Center."
"RTN","IVMPREC6",220,0)
 S IVMTEXT(7)=""
"RTN","IVMPREC6",221,0)
 S IVMTEXT(8)="The Health Eligibilty Center has identified the following"
"RTN","IVMPREC6",222,0)
 S IVMTEXT(9)="patients as having updated demographic information:"
"RTN","IVMPREC6",223,0)
 S IVMTEXT(10)=""
"RTN","IVMPREC6",224,0)
 S IVMCNTR=IVMCNTR+1
"RTN","IVMPREC6",225,0)
 S IVMTEXT(IVMCNTR+10)=$J(IVMCNTR_")",5)_"  "_$P(IVMPTID,"^")_" ("_$P(IVMPTID,"^",3)_")"
"RTN","IVMPREC6",226,0)
 Q
"RTN","IVMPREC6",227,0)
 ;
"RTN","IVMPREC6",228,0)
INACTIVE(IVMDEMDA) ;Check if field is inactive in Demographic Upload
"RTN","IVMPREC6",229,0)
 ; Input  -- IVMDEMDA IVM Demographic Upload Fields IEN
"RTN","IVMPREC6",230,0)
 ; Output -- 1=Yes and 0=No
"RTN","IVMPREC6",231,0)
 Q +$P($G(^IVM(301.92,IVMDEMDA,0)),U,9)
"RTN","IVMPREC6",232,0)
 ;
"RTN","IVMPREC6",233,0)
RF1CHK(IVMRTN,IVMDA) ;does an RF1 segment exist in this message?
"RTN","IVMPREC6",234,0)
 N RF1
"RTN","IVMPREC6",235,0)
 S RF1=$O(^TMP($J,IVMRTN,IVMDA))
"RTN","IVMPREC6",236,0)
 I $E($G(^(+RF1,0)),1,3)'="RF1" Q 0
"RTN","IVMPREC6",237,0)
 Q 1
"RTN","IVMPREC6",238,0)
 ;
"RTN","IVMPREC6",239,0)
CKAUTO() ;
"RTN","IVMPREC6",240,0)
 ; Chect if message qualifies for an auto upload.
"RTN","IVMPREC6",241,0)
 N AUTO,IVMI,DOD
"RTN","IVMPREC6",242,0)
 S AUTO=0,IVMI=$O(^IVM(301.92,"C","ZPD09",""))
"RTN","IVMPREC6",243,0)
 I IVMI=IVMDEMDA  D
"RTN","IVMPREC6",244,0)
 .I +IVMFLD'>0 S AUTO=1 Q
"RTN","IVMPREC6",245,0)
 .S DOD=$P($G(^DPT(DFN,.35)),U)
"RTN","IVMPREC6",246,0)
 .I DOD=IVMFLD S AUTO=1 Q
"RTN","IVMPREC6",247,0)
 ;
"RTN","IVMPREC6",248,0)
 Q AUTO
"RTN","IVMPREC6",249,0)
BLDPID(PIDTMP,IVMPID) ;Build IVMPID subscripted by sequence number
"RTN","IVMPREC6",250,0)
 N STR,X1,X2,N,TEXT,C,L
"RTN","IVMPREC6",251,0)
 S STR="",X1=1,(N,X2)=0
"RTN","IVMPREC6",252,0)
 F  S N=$O(PIDTMP(N)) Q:N=""  S TEXT=PIDTMP(N) F L=1:1:$L(TEXT) S C=$E(TEXT,L) D
"RTN","IVMPREC6",253,0)
 . I C="^" D  Q
"RTN","IVMPREC6",254,0)
 . . I X2 S X2=X2+1,IVMPID(X1,X2)=STR
"RTN","IVMPREC6",255,0)
 . . E  S IVMPID(X1)=STR
"RTN","IVMPREC6",256,0)
 . . S STR="",X1=X1+1,X2=0
"RTN","IVMPREC6",257,0)
 . I C="|" D  Q
"RTN","IVMPREC6",258,0)
 . . S X2=X2+1,IVMPID(X1,X2)=STR,STR=""
"RTN","IVMPREC6",259,0)
 . S STR=STR_C
"RTN","IVMPREC6",260,0)
 I $G(C)'="",$G(C)'="^",$G(C)'="|" D
"RTN","IVMPREC6",261,0)
 . I X2 S X2=X2+1,IVMPID(X1,X2)=STR Q
"RTN","IVMPREC6",262,0)
 . S IVMPID(X1)=STR
"RTN","IVMPREC6",263,0)
 Q
"RTN","IVMPREC6",264,0)
ADDRCHNG(DFN) ;Store Address Change Date/time, Source and site if necessary
"RTN","IVMPREC6",265,0)
 N IVMVALUE,IVMFIELD
"RTN","IVMPREC6",266,0)
 I '$D(^TMP($J,"CHANGE UPDATE")) Q
"RTN","IVMPREC6",267,0)
 S IVMFIELD=0 F  S IVMFIELD=$O(^TMP($J,"CHANGE UPDATE",IVMFIELD)) Q:IVMFIELD=""  D
"RTN","IVMPREC6",268,0)
 . S IVMVALUE=$G(^TMP($J,"CHANGE UPDATE",IVMFIELD))
"RTN","IVMPREC6",269,0)
 . S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
"RTN","IVMPREC6",270,0)
 . D ^DIE K DA,DIE,DR
"RTN","IVMPREC6",271,0)
 .; - delete inaccurate Addr Change Site data if Source is not VAMC
"RTN","IVMPREC6",272,0)
 . I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMPREC6",273,0)
 K ^TMP($J,"CHANGE UPDATE")
"RTN","IVMPREC6",274,0)
 Q
"RTN","IVMPREC6",275,0)
EPCFLDS(EPCFARY,EPCDEL) ;
"RTN","IVMPREC6",276,0)
 ;EPCFARY - Contains IENs of Pager, email and Cell phone records in 301.92 File - Passed by reference
"RTN","IVMPREC6",277,0)
 ;EPCDEL - Contains field # of Pager, Email and Cell phone fields in Patient(#2) file. - Passed by reference
"RTN","IVMPREC6",278,0)
 I (DODSEG)!(GUARSEG) Q
"RTN","IVMPREC6",279,0)
 S EPCFARY("PNO")=$O(^IVM(301.92,"B","PAGER NUMBER",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE SOURCE",0))
"RTN","IVMPREC6",280,0)
 S EPCFARY("CPH")=$O(^IVM(301.92,"B","CELLULAR NUMBER",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE SOURCE",0))
"RTN","IVMPREC6",281,0)
 S EPCFARY("EAD")=$O(^IVM(301.92,"B","EMAIL ADDRESS",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE SOURCE",0))
"RTN","IVMPREC6",282,0)
 S EPCDEL("PNO")=".135^.1312^.1313^.1314"
"RTN","IVMPREC6",283,0)
 S EPCDEL("CPH")=".134^.139^.1311^.13111"
"RTN","IVMPREC6",284,0)
 S EPCDEL("EAD")=".133^.136^.137^.138"
"RTN","IVMPREC6",285,0)
 Q
"RTN","IVMPREC6",286,0)
 ;
"RTN","IVMPREC6",287,0)
AUPBLD(AUPFARY,UPDAUPG) ; Set up array containing fields for auto upload.
"RTN","IVMPREC6",288,0)
 ;AUPFARY - Contains fields in 301.92 File-Passed by reference
"RTN","IVMPREC6",289,0)
 ;UPDAUPG - Contains all groups initialized to '0'
"RTN","IVMPREC6",290,0)
 N AUPSTR,AUPGRP,AUPFLST,AUPPCE,AUPSGSQ,AUPDA
"RTN","IVMPREC6",291,0)
 F I=3:1 S AUPSTR=$P($T(AUPLST+I),";;",2,3) Q:$P(AUPSTR,";")="QUIT"  D
"RTN","IVMPREC6",292,0)
 .S AUPGRP=$P(AUPSTR,";"),AUPFLST=$P(AUPSTR,";",2)
"RTN","IVMPREC6",293,0)
 .F AUPPCE=1:1:$L(AUPFLST,"^") D
"RTN","IVMPREC6",294,0)
 ..S AUPSGSQ=$P(AUPFLST,"^",AUPPCE) Q:AUPSGSQ=""
"RTN","IVMPREC6",295,0)
 ..S AUPDA=$O(^IVM(301.92,"C",AUPSGSQ,0)) Q:AUPDA=""
"RTN","IVMPREC6",296,0)
 ..S AUPFARY(AUPDA)=AUPGRP
"RTN","IVMPREC6",297,0)
 ..S:AUPGRP'="" UPDAUPG(AUPGRP)=0  ; Default group update flags to '0'
"RTN","IVMPREC6",298,0)
 Q
"RTN","IVMPREC6",299,0)
 ;
"RTN","IVMPREC6",300,0)
AUPLST ; P1;P2
"RTN","IVMPREC6",301,0)
 ; P1 = Group Name (treat all entries as this group if present)
"RTN","IVMPREC6",302,0)
 ; P2 = .01 field(s) from 301.92 seperated by '^'
"RTN","IVMPREC6",303,0)
 ;;D1;ZCT03D1^ZCT04D1^ZCT051D1^ZCT052D1^ZCT053D1^ZCT054D1^ZCT055D1^ZCT06D1^ZCT07D1^ZCT10D1
"RTN","IVMPREC6",304,0)
 ;;E1;ZCT03E1^ZCT04E1^ZCT051E1^ZCT052E1^ZCT053E1^ZCT054E1^ZCT055E1^ZCT06E1^ZCT07E1^ZCT10E1
"RTN","IVMPREC6",305,0)
 ;;E2;ZCT03E2^ZCT04E2^ZCT051E2^ZCT052E2^ZCT053E2^ZCT054E2^ZCT055E2^ZCT06E2^ZCT07E2^ZCT10E2
"RTN","IVMPREC6",306,0)
 ;;K1;ZCT03K1^ZCT04K1^ZCT051K1^ZCT052K1^ZCT053K1^ZCT054K1^ZCT055K1^ZCT06K1^ZCT07K1^ZCT10K1
"RTN","IVMPREC6",307,0)
 ;;K2;ZCT03K2^ZCT04K2^ZCT051K2^ZCT052K2^ZCT053K2^ZCT054K2^ZCT055K2^ZCT06K2^ZCT07K2^ZCT10K2
"RTN","IVMPREC6",308,0)
 ;;TA;ZTA02^ZTA03^ZTA04^ZTA051^ZTA052^ZTA053^ZTA054^ZTA055^ZTA056^ZTA058^ZTA059^ZTA07^ZTA08^ZTA09^ZTA054F^ZTA055F
"RTN","IVMPREC6",309,0)
 ;;;ZEM03S^ZEM04S^ZEM05S^ZEM061S^ZEM062S^ZEM063S^ZEM064S^ZEM065S^ZEM068S^ZEM07S^ZEM09S
"RTN","IVMPREC6",310,0)
 ;;;PID06^PID10^PID16^PID17^PID22^ZPD30
"RTN","IVMPREC6",311,0)
 ;;QUIT
"RTN","IVMPREC6",312,0)
 ;;
"RTN","IVMPREC6",313,0)
 ;;The following have been disabled until further notice
"RTN","IVMPREC6",314,0)
 ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1112C1^PID1112C2^PID13CA^RF161CA^RF171CA
"RTN","IVMPREC6",315,0)
 ;;;ZEM03^ZEM04^ZEM05^ZEM061^ZEM062^ZEM063^ZEM064^ZEM065^ZEM068^ZEM07^ZEM09
"RTN","IVMPREC6",316,0)
 ;;;PID113N^PID114N^PID24^ZPD06^ZPD07^PID13W
"RTN","IVMPREC8")
0^9^B186534384
"RTN","IVMPREC8",1,0)
IVMPREC8 ;ALB/KCL/BRM/PJR/CKN,TDM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ; 1/19/11 11:12am
"RTN","IVMPREC8",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,58,73,79,102,115,121**;21-OCT-94;Build 45
"RTN","IVMPREC8",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMPREC8",4,0)
 ;
"RTN","IVMPREC8",5,0)
 ; This routine is called from IVMPREC6.
"RTN","IVMPREC8",6,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC8",7,0)
 ; messages received from the IVM center.
"RTN","IVMPREC8",8,0)
 ;
"RTN","IVMPREC8",9,0)
 ;
"RTN","IVMPREC8",10,0)
 ;
"RTN","IVMPREC8",11,0)
PID ; - compare PID segment fields with DHCP fields
"RTN","IVMPREC8",12,0)
 N COMPPH1,COMPPH2,COUNTRY
"RTN","IVMPREC8",13,0)
 ;
"RTN","IVMPREC8",14,0)
 S IVMFLD=""
"RTN","IVMPREC8",15,0)
 ; - strip off segment name
"RTN","IVMPREC8",16,0)
 S IVMPIECE=$E(IVMXREF,4,9)
"RTN","IVMPREC8",17,0)
 ;Only process if value exist - also handles multiple address
"RTN","IVMPREC8",18,0)
 I $G(IVMPID(+$E(IVMPIECE,1,2)))'=""!($O(IVMPID(+$E(IVMPIECE,1,2),""))) D
"RTN","IVMPREC8",19,0)
 .;
"RTN","IVMPREC8",20,0)
 .; - if PID field is the address field - parse address
"RTN","IVMPREC8",21,0)
 .S IVMADFLG=0
"RTN","IVMPREC8",22,0)
 .I IVMXREF["PID11",'$G(DODSEG) D  Q:IVMFLD=""
"RTN","IVMPREC8",23,0)
 ..;
"RTN","IVMPREC8",24,0)
 ..; - Process Place of Birth City & State
"RTN","IVMPREC8",25,0)
 ..;I (IVMXREF="PID113N")!(IVMXREF="PID114N") D  Q
"RTN","IVMPREC8",26,0)
 ..;.Q:'$D(ADDRESS("N"))
"RTN","IVMPREC8",27,0)
 ..;.S IVMADDR=ADDRESS("N")
"RTN","IVMPREC8",28,0)
 ..;.S IVMPIECE=$E(IVMPIECE,3,4),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",29,0)
 ..;.Q:IVMFLD=""
"RTN","IVMPREC8",30,0)
 ..;.I IVMPIECE="4N" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",31,0)
 ..;
"RTN","IVMPREC8",32,0)
 ..; - get PID address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",33,0)
 ..;I $G(AUPFARY(IVMDEMDA))="CA" S IVMADDR=$G(ADDRESS("CA")) ;Conf Addr
"RTN","IVMPREC8",34,0)
 ..I $G(AUPFARY(IVMDEMDA))'="CA" D
"RTN","IVMPREC8",35,0)
 ...S IVMADDR=$S($D(ADDRESS("P")):ADDRESS("P"),$D(ADDRESS("VAB1")):ADDRESS("VAB1"),$D(ADDRESS("VAB2")):ADDRESS("VAB2"),$D(ADDRESS("VAB3")):ADDRESS("VAB3"),$D(ADDRESS("VAB4")):ADDRESS("VAB4"),1:"")
"RTN","IVMPREC8",36,0)
 ..I IVMADDR="" Q
"RTN","IVMPREC8",37,0)
 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)
"RTN","IVMPREC8",38,0)
 ..S FORADDR=$S(COUNTRY="USA":0,1:1)
"RTN","IVMPREC8",39,0)
 ..; - get piece of address field, and set IVMFLD
"RTN","IVMPREC8",40,0)
 ..S IVMPIECE=$E(IVMPIECE,3,6),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",41,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",42,0)
 ..; - convert state abbrev. to pointer
"RTN","IVMPREC8",43,0)
 ..I (IVMPIECE=4)!(IVMPIECE="4C") D
"RTN","IVMPREC8",44,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")
"RTN","IVMPREC8",45,0)
 ...I IVMFLD'="" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",46,0)
 ..I (IVMPIECE=5)!(IVMPIECE="5C") D
"RTN","IVMPREC8",47,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")
"RTN","IVMPREC8",48,0)
 ...I IVMFLD'="" S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=X
"RTN","IVMPREC8",49,0)
 ..I (IVMPIECE="4F")!(IVMPIECE="4CF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;PROVINCE
"RTN","IVMPREC8",50,0)
 ..I (IVMPIECE="5F")!(IVMPIECE="5CF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;POSTAL CODE
"RTN","IVMPREC8",51,0)
 ..I (IVMPIECE=6)!(IVMPIECE="6C") S IVMFLD=$$CNTRCONV(COUNTRY) ;COUNTRY
"RTN","IVMPREC8",52,0)
 ..I IVMPIECE=7 S IVMFLD=$$BAICONV(IVMFLD) ;Bad Address Indicator
"RTN","IVMPREC8",53,0)
 ..I IVMPIECE="7C" S IVMFLD=CONFADCT  ;CONFADCT set in PID11^IVMPRECA
"RTN","IVMPREC8",54,0)
 ..I IVMPIECE="9C" D
"RTN","IVMPREC8",55,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""
"RTN","IVMPREC8",56,0)
 ...S IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",IVMFLD,0))  ;CONF ADDR COUNTY
"RTN","IVMPREC8",57,0)
 ..I $E(IVMPIECE,1,3)="12C" S IVMFLD=$$FMDATE^HLFNC($P(IVMFLD,$E(HLECH,4),$E(IVMPIECE,4)))
"RTN","IVMPREC8",58,0)
 ..S IVMADFLG=1
"RTN","IVMPREC8",59,0)
 .;
"RTN","IVMPREC8",60,0)
 .I IVMXREF["PID12",'$G(DODSEG) D
"RTN","IVMPREC8",61,0)
 ..I 'FORADDR S IVMADFLG=1,IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",IVMPID(12),0))  ;Process county only if not foreign address
"RTN","IVMPREC8",62,0)
 .; line remove so that the phone number is compared 
"RTN","IVMPREC8",63,0)
 .; before saving to 301.5.
"RTN","IVMPREC8",64,0)
 .I IVMXREF["PID13",$D(TELECOM),'$G(DODSEG) D
"RTN","IVMPREC8",65,0)
 ..;Confidential Phone Number
"RTN","IVMPREC8",66,0)
 ..;I IVMXREF="PID13CA",$D(TELECOM("VACPN")) D
"RTN","IVMPREC8",67,0)
 ..;.S IVMFLD=$$CONVPH($P($G(TELECOM("VACPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",68,0)
 ..;Phone Number [Work]
"RTN","IVMPREC8",69,0)
 ..;I IVMXREF="PID13W",$D(TELECOM("WPN")) D
"RTN","IVMPREC8",70,0)
 ..;.S IVMFLD=$$CONVPH($P($G(TELECOM("WPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",71,0)
 ..;Pager Number
"RTN","IVMPREC8",72,0)
 ..I IVMXREF="PID13B",$D(TELECOM("BPN")) D
"RTN","IVMPREC8",73,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("BPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",74,0)
 ..;Cell Phone Number
"RTN","IVMPREC8",75,0)
 ..I IVMXREF="PID13C",$D(TELECOM("ORN")) D
"RTN","IVMPREC8",76,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("ORN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",77,0)
 ..;Email Address
"RTN","IVMPREC8",78,0)
 ..I IVMXREF="PID13E",$D(TELECOM("NET")) D
"RTN","IVMPREC8",79,0)
 ...S IVMFLD=$P($G(TELECOM("NET")),$E(HLECH),4)
"RTN","IVMPREC8",80,0)
 ...S IVMFLD=$S($$CHKEMAIL(IVMFLD):IVMFLD,1:""),IVMADFLG=1
"RTN","IVMPREC8",81,0)
 .; - file address fields and quit
"RTN","IVMPREC8",82,0)
 .I IVMADFLG D STORE^IVMPREC9 Q
"RTN","IVMPREC8",83,0)
 .;
"RTN","IVMPREC8",84,0)
 .; - otherwise, set IVMFLD to field rec'd from IVM
"RTN","IVMPREC8",85,0)
 .;   for comparison with DHCP field
"RTN","IVMPREC8",86,0)
 .;I (IVMXREF'="PID113N")&(IVMXREF'="PID114N")&($E(IVMXREF,1,5)'="PID13") S IVMFLD=$G(IVMPID(+IVMPIECE))
"RTN","IVMPREC8",87,0)
 .I $E(IVMXREF,1,5)'="PID13" S IVMFLD=$G(IVMPID(+IVMPIECE))
"RTN","IVMPREC8",88,0)
 .;
"RTN","IVMPREC8",89,0)
 .; - if HL7 date convert to FM date and set IVMFLD
"RTN","IVMPREC8",90,0)
 .I IVMXREF["PID07" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",91,0)
 .;
"RTN","IVMPREC8",92,0)
 .; - if HL7 code convert to VistA and set IVMFLD
"RTN","IVMPREC8",93,0)
 .I IVMXREF["PID16" D  ;Marital Status
"RTN","IVMPREC8",94,0)
 ..S IVMFLD=$S(IVMFLD="D":"DIVORCED",IVMFLD="M":"MARRIED",IVMFLD="W":"WIDOWED",IVMFLD="A":"SEPARATED",IVMFLD="S":"NEVER MARRIED",IVMFLD="U":"UNKNOWN")
"RTN","IVMPREC8",95,0)
 ..S IVMFLD=$O(^DIC(11,"B",IVMFLD,0))
"RTN","IVMPREC8",96,0)
 .;
"RTN","IVMPREC8",97,0)
 .I IVMXREF["PID17" S IVMFLD=$O(^DIC(13,"C",IVMFLD,0))  ;Religion
"RTN","IVMPREC8",98,0)
 .;
"RTN","IVMPREC8",99,0)
 .I IVMXREF["PID22" D  ;Ethnicity
"RTN","IVMPREC8",100,0)
 ..S IVMFLD=$$CODE2PTR^DGUTL4($P($G(IVMPID(22)),$E(HLECH),4),2,2)
"RTN","IVMPREC8",101,0)
 .;
"RTN","IVMPREC8",102,0)
 .I IVMXREF="PID10",'$G(DODSEG),$D(IVMRACE) D  Q
"RTN","IVMPREC8",103,0)
 ..N XVAL,IVMLST,DHCPLST
"RTN","IVMPREC8",104,0)
 ..S (XVAL,IVMLST,DHCPLST)=""
"RTN","IVMPREC8",105,0)
 ..F  S XVAL=$O(^DPT(DFN,.02,"B",XVAL)) Q:XVAL=""  S IVMLST=IVMLST_XVAL_U
"RTN","IVMPREC8",106,0)
 ..S XVAL="" F  S XVAL=$O(IVMRACE(2,XVAL)) Q:XVAL=""  S DHCPLST=DHCPLST_XVAL_U
"RTN","IVMPREC8",107,0)
 ..Q:IVMLST=DHCPLST
"RTN","IVMPREC8",108,0)
 ..F XVAL=1:1:($L(DHCPLST,U)-1) S IVMFLD=$P(DHCPLST,U,XVAL) D
"RTN","IVMPREC8",109,0)
 ...D STORE^IVMPREC9
"RTN","IVMPREC8",110,0)
 .;
"RTN","IVMPREC8",111,0)
 .; - call VADPT routine to return DHCP demographics
"RTN","IVMPREC8",112,0)
 .D DEM^VADPT,ADD^VADPT,OPD^VADPT
"RTN","IVMPREC8",113,0)
 .;
"RTN","IVMPREC8",114,0)
 .; - execute code on the 1 node and get DHCP field for comparison
"RTN","IVMPREC8",115,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",116,0)
 .;
"RTN","IVMPREC8",117,0)
 .; - special logic for phone number processing
"RTN","IVMPREC8",118,0)
 .; - if different, then store the actual value received, then quit
"RTN","IVMPREC8",119,0)
 .;
"RTN","IVMPREC8",120,0)
 .I IVMXREF="PID13",$D(TELECOM("PRN")),'$G(DODSEG) D  Q
"RTN","IVMPREC8",121,0)
 ..S IVMFLD=$P($G(TELECOM("PRN")),$E(HLECH))
"RTN","IVMPREC8",122,0)
 ..I IVMFLD]"" D
"RTN","IVMPREC8",123,0)
 ...S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
"RTN","IVMPREC8",124,0)
 ...I COMPPH1'=COMPPH2 D STORE^IVMPREC9
"RTN","IVMPREC8",125,0)
 .;
"RTN","IVMPREC8",126,0)
 .; - if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",127,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",128,0)
 Q
"RTN","IVMPREC8",129,0)
 ;
"RTN","IVMPREC8",130,0)
 ;
"RTN","IVMPREC8",131,0)
ZPD ; - compare ZPD segment fields with DHCP fields
"RTN","IVMPREC8",132,0)
 N STFLG
"RTN","IVMPREC8",133,0)
 S STFLG=0
"RTN","IVMPREC8",134,0)
 S IVMPIECE=$E(IVMXREF,4,5)
"RTN","IVMPREC8",135,0)
 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
"RTN","IVMPREC8",136,0)
 .;
"RTN","IVMPREC8",137,0)
 .; - set var to HL7 field
"RTN","IVMPREC8",138,0)
 .S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
"RTN","IVMPREC8",139,0)
 .;
"RTN","IVMPREC8",140,0)
 .; - if HL7 name format convert to FM
"RTN","IVMPREC8",141,0)
 .;I (IVMXREF["ZPD06")!(IVMXREF["ZPD07") S IVMFLD=$$FMNAME^HLFNC(IVMFLD)
"RTN","IVMPREC8",142,0)
 .;
"RTN","IVMPREC8",143,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",144,0)
 .I IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",145,0)
 .;
"RTN","IVMPREC8",146,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",147,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",148,0)
 .;
"RTN","IVMPREC8",149,0)
 .; - if field from IVM does not equal DHCP field - store for uploading 
"RTN","IVMPREC8",150,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) S STFLG=1 D STORE^IVMPREC9 Q
"RTN","IVMPREC8",151,0)
 .I IVMXREF["ZPD09"!(IVMXREF["ZPD31")!(IVMXREF["ZPD32") D STORE^IVMPREC9
"RTN","IVMPREC8",152,0)
 I IVMXREF["ZPD08",STFLG,$$AUTORINC^IVMPREC9(DFN) Q
"RTN","IVMPREC8",153,0)
 I IVMXREF["ZPD32",$$AUTODOD^IVMLDEMD(DFN)
"RTN","IVMPREC8",154,0)
 Q
"RTN","IVMPREC8",155,0)
 ;
"RTN","IVMPREC8",156,0)
ZTA ; - compare ZTA segment fields with DHCP fields
"RTN","IVMPREC8",157,0)
 N COMPPH1,COMPPH2,COUNTRY
"RTN","IVMPREC8",158,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",159,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",160,0)
 .;
"RTN","IVMPREC8",161,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",162,0)
 .S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",163,0)
 .;
"RTN","IVMPREC8",164,0)
 .; - ZTA05 as the ZTA address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",165,0)
 .I IVMXREF["ZTA05" D
"RTN","IVMPREC8",166,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)) Q:IVMADDR=""
"RTN","IVMPREC8",167,0)
 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)
"RTN","IVMPREC8",168,0)
 ..S FORADDR=$S(COUNTRY="USA":0,1:1)
"RTN","IVMPREC8",169,0)
 ..; - get piece of address field, and set IVMFLD
"RTN","IVMPREC8",170,0)
 ..S IVMPIECE=$E(IVMPIECE,3,4)
"RTN","IVMPREC8",171,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE) Q:IVMFLD=""
"RTN","IVMPREC8",172,0)
 ..I (IVMPIECE=4)!(IVMPIECE=5)!(IVMPIECE=9) S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""
"RTN","IVMPREC8",173,0)
 ..I IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",174,0)
 ..I IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",175,0)
 ..I IVMPIECE="4F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;PROVINCE
"RTN","IVMPREC8",176,0)
 ..I IVMPIECE="5F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;POSTAL CODE
"RTN","IVMPREC8",177,0)
 ..I IVMPIECE=6 S IVMFLD=$$CNTRCONV(COUNTRY)         ;COUNTRY
"RTN","IVMPREC8",178,0)
 ..I IVMPIECE=9 S IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",IVMFLD,0))  ;COUNTY
"RTN","IVMPREC8",179,0)
 .Q:IVMFLD=""
"RTN","IVMPREC8",180,0)
 .;
"RTN","IVMPREC8",181,0)
 .; - if HL7 data convert to Y/N value
"RTN","IVMPREC8",182,0)
 .I IVMXREF["ZTA02" S IVMFLD=$S(IVMFLD=0:"N",IVMFLD=1:"Y",1:"")
"RTN","IVMPREC8",183,0)
 .;
"RTN","IVMPREC8",184,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",185,0)
 .I (IVMXREF["ZTA03")!(IVMXREF["ZTA04")!(IVMXREF["ZTA08") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",186,0)
 .;
"RTN","IVMPREC8",187,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",188,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",189,0)
 .;
"RTN","IVMPREC8",190,0)
 .; - special logic for phone number processing
"RTN","IVMPREC8",191,0)
 .; - if different, then store the actual value received, then quit
"RTN","IVMPREC8",192,0)
 .I IVMXREF["ZTA07" D  Q
"RTN","IVMPREC8",193,0)
 ..S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
"RTN","IVMPREC8",194,0)
 ..I COMPPH1'=COMPPH2 D STORE^IVMPREC9
"RTN","IVMPREC8",195,0)
 .;
"RTN","IVMPREC8",196,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",197,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",198,0)
 .;
"RTN","IVMPREC8",199,0)
 .I IVMXREF["ZTA08" D
"RTN","IVMPREC8",200,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("TA")=1
"RTN","IVMPREC8",201,0)
 Q
"RTN","IVMPREC8",202,0)
 ;
"RTN","IVMPREC8",203,0)
ZGD ; - compare ZGD segment fields with DHCP fields
"RTN","IVMPREC8",204,0)
 S IVMADFLG=0
"RTN","IVMPREC8",205,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",206,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",207,0)
 .;
"RTN","IVMPREC8",208,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",209,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
"RTN","IVMPREC8",210,0)
 .;
"RTN","IVMPREC8",211,0)
 .; - ZGD06 as the ZGD address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",212,0)
 .I IVMXREF["ZGD06" D
"RTN","IVMPREC8",213,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",214,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
"RTN","IVMPREC8",215,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",216,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",217,0)
 .;
"RTN","IVMPREC8",218,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",219,0)
 .I IVMXREF["ZGD08" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",220,0)
 .;
"RTN","IVMPREC8",221,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",222,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",223,0)
 .;
"RTN","IVMPREC8",224,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",225,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",226,0)
 Q
"RTN","IVMPREC8",227,0)
 ;
"RTN","IVMPREC8",228,0)
ZCT ; - compare ZCT segment fields with DHCP fields
"RTN","IVMPREC8",229,0)
 N ZCTTYP
"RTN","IVMPREC8",230,0)
 S IVMADFLG=0
"RTN","IVMPREC8",231,0)
 S IVMPIECE=$E(IVMXREF,4,8)
"RTN","IVMPREC8",232,0)
 S ZCTTYP=$E(IVMPIECE,$L(IVMPIECE)-1,$L(IVMPIECE))
"RTN","IVMPREC8",233,0)
 Q:$P(IVMSEG,HLFS,2)'=$S(ZCTTYP="K1":1,ZCTTYP="K2":2,ZCTTYP="E1":3,ZCTTYP="E2":4,ZCTTYP="D1":5,1:"")
"RTN","IVMPREC8",234,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",235,0)
 .;
"RTN","IVMPREC8",236,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",237,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",238,0)
 .;
"RTN","IVMPREC8",239,0)
 .; - if HL7 name format convert to FM
"RTN","IVMPREC8",240,0)
 .I IVMXREF["ZCT03" S IVMFLD=$$FMNAME^HLFNC(IVMFLD)
"RTN","IVMPREC8",241,0)
 .;
"RTN","IVMPREC8",242,0)
 .; - ZCT05 as the ZCT address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",243,0)
 .I IVMXREF["ZCT05" D
"RTN","IVMPREC8",244,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",245,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
"RTN","IVMPREC8",246,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",247,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",248,0)
 .;
"RTN","IVMPREC8",249,0)
 .I IVMADFLG D STORE^IVMPREC9 Q
"RTN","IVMPREC8",250,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",251,0)
 .I IVMXREF["ZCT10" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",252,0)
 .;
"RTN","IVMPREC8",253,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",254,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",255,0)
 .;
"RTN","IVMPREC8",256,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",257,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",258,0)
 .;
"RTN","IVMPREC8",259,0)
 .I IVMXREF["ZCT10" D
"RTN","IVMPREC8",260,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG(ZCTTYP)=1
"RTN","IVMPREC8",261,0)
 Q
"RTN","IVMPREC8",262,0)
 ;
"RTN","IVMPREC8",263,0)
ZEM ; - compare ZEM segment fields with DHCP fields
"RTN","IVMPREC8",264,0)
 S IVMADFLG=0
"RTN","IVMPREC8",265,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",266,0)
 S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC8",267,0)
 Q:$P(IVMSEG,HLFS,2)'=$S($E(IVMXREF,$L(IVMXREF))="S":2,1:1)
"RTN","IVMPREC8",268,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",269,0)
 .;
"RTN","IVMPREC8",270,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",271,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",272,0)
 .;
"RTN","IVMPREC8",273,0)
 .; - ZEM06 as the ZEM address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",274,0)
 .I IVMXREF["ZEM06" D
"RTN","IVMPREC8",275,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",276,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)    ;,IVMADFLG=1
"RTN","IVMPREC8",277,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",278,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",279,0)
 .;
"RTN","IVMPREC8",280,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",281,0)
 .I IVMXREF["ZEM09" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",282,0)
 .;
"RTN","IVMPREC8",283,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",284,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",285,0)
 .;
"RTN","IVMPREC8",286,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",287,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",288,0)
 Q
"RTN","IVMPREC8",289,0)
 ;
"RTN","IVMPREC8",290,0)
RF1 ; - compare RF1 segment fields with DHCP fields
"RTN","IVMPREC8",291,0)
 S IVMPIECE=$E(IVMXREF,4),IVMADFLG=1,RF1TYPE=$P(IVMSEG,HLFS,3)
"RTN","IVMPREC8",292,0)
 ;As per requirements, delete the communication data (Email, Cell and Pager) if it is not received in Z05.
"RTN","IVMPREC8",293,0)
 ;Hence, remove it from EPCDEL (deletion array) if Data exist in Z05. Comm. fields contained in EPCDEL will be deleted after updating all incoming communication data.
"RTN","IVMPREC8",294,0)
 K EPCDEL(RF1TYPE)
"RTN","IVMPREC8",295,0)
 ;if RF1 field is SEQ6, then parse subcomponents
"RTN","IVMPREC8",296,0)
 I RF1TYPE="SAD",((IVMXREF="RF161")!(IVMXREF="RF162")!(IVMXREF="RF171")) D RF1PROC
"RTN","IVMPREC8",297,0)
 ;I RF1TYPE="CAD",((IVMXREF="RF161CA")!(IVMXREF="RF171CA")) D RF1PROC
"RTN","IVMPREC8",298,0)
 I RF1TYPE="CPH",((IVMXREF="RF161C")!(IVMXREF="RF162C")!(IVMXREF="RF171C")) D RF1PROC
"RTN","IVMPREC8",299,0)
 I RF1TYPE="PNO",((IVMXREF="RF161B")!(IVMXREF="RF162B")!(IVMXREF="RF171B")) D RF1PROC
"RTN","IVMPREC8",300,0)
 I RF1TYPE="EAD",((IVMXREF="RF161E")!(IVMXREF="RF162E")!(IVMXREF="RF171E")) D RF1PROC
"RTN","IVMPREC8",301,0)
 I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171E" D  ;Last RF1
"RTN","IVMPREC8",302,0)
 . I $$AUTOEPC^IVMPREC9(DFN,.UPDEPC)
"RTN","IVMPREC8",303,0)
 . I 'UPDEPC("SAD") S NOUPDT=1
"RTN","IVMPREC8",304,0)
 . I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT)
"RTN","IVMPREC8",305,0)
 Q
"RTN","IVMPREC8",306,0)
 ;
"RTN","IVMPREC8",307,0)
RF1PROC ;
"RTN","IVMPREC8",308,0)
 N IVMEPC
"RTN","IVMPREC8",309,0)
 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
"RTN","IVMPREC8",310,0)
 .;if RF1 field is SEQ6, then parse subcomponents
"RTN","IVMPREC8",311,0)
 .I IVMXREF["RF16" D  Q
"RTN","IVMPREC8",312,0)
 ..;- get data containing 4 pieces seperated by HLECH (~)
"RTN","IVMPREC8",313,0)
 ..S IVMRFDAT=$P(IVMSEG,HLFS,6)
"RTN","IVMPREC8",314,0)
 ..S IVMPIECE=$E(IVMXREF,5),IVMFLD=$P(IVMRFDAT,"~",IVMPIECE)
"RTN","IVMPREC8",315,0)
 ..;get 6th character of IVMXREF to determine if value is for Address
"RTN","IVMPREC8",316,0)
 ..;OR Email, Cell and Pager
"RTN","IVMPREC8",317,0)
 ..S IVMEPC=$E(IVMXREF,6)
"RTN","IVMPREC8",318,0)
 ..;Convert Change Source for Address, Email, Cell and Pager
"RTN","IVMPREC8",319,0)
 ..I IVMPIECE=2 S IVMFLD=$S(IVMEPC'="":$$EPCSRCC(IVMFLD),1:$$ADDRCNV(IVMFLD))
"RTN","IVMPREC8",320,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",321,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",322,0)
 .I IVMXREF["RF17" D  Q
"RTN","IVMPREC8",323,0)
 ..;get address/telecomm change date/tm field
"RTN","IVMPREC8",324,0)
 ..S IVMFLD=$$FMDATE^HLFNC($P(IVMSEG,HLFS,7))
"RTN","IVMPREC8",325,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",326,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",327,0)
 ..;
"RTN","IVMPREC8",328,0)
 ..;I RF1TYPE="CAD",$P($G(ADDRESS("CA")),HLFS)]"" D  Q
"RTN","IVMPREC8",329,0)
 ..;.; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",330,0)
 ..;.S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",331,0)
 ..;.I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("CA")=1
"RTN","IVMPREC8",332,0)
 ..;
"RTN","IVMPREC8",333,0)
 ..; check for auto-upload
"RTN","IVMPREC8",334,0)
 ..S NOUPDT=0
"RTN","IVMPREC8",335,0)
 ..S IVMDHCP=$S(RF1TYPE="SAD":$P($G(^DPT(DFN,.11)),HLFS,13),RF1TYPE="CPH":$P($G(^DPT(DFN,.13)),HLFS,9),RF1TYPE="PNO":$P($G(^DPT(DFN,.13)),HLFS,12),RF1TYPE="EAD":$P($G(^DPT(DFN,.13)),HLFS,6),1:"")
"RTN","IVMPREC8",336,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) D
"RTN","IVMPREC8",337,0)
 ...S UPDEPC(RF1TYPE)=$G(EPCFARY(RF1TYPE))
"RTN","IVMPREC8",338,0)
 ...I RF1TYPE="SAD" S UPDEPC("SAD")=1
"RTN","IVMPREC8",339,0)
 Q
"RTN","IVMPREC8",340,0)
ADDRCNV(ADDRSRC) ;convert Address Source from HL7 to DHCP format
"RTN","IVMPREC8",341,0)
 ;
"RTN","IVMPREC8",342,0)
 Q:$G(ADDRSRC)']"" ""
"RTN","IVMPREC8",343,0)
 Q:ADDRSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",344,0)
 Q:ADDRSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",345,0)
 Q:ADDRSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",346,0)
 Q:ADDRSRC="USNCOA" "NCOA"
"RTN","IVMPREC8",347,0)
 Q:ADDRSRC="USVABVA" "BVA"
"RTN","IVMPREC8",348,0)
 Q:ADDRSRC="USVAINS" "VAINS"
"RTN","IVMPREC8",349,0)
 Q:ADDRSRC="USPS" "USPS"
"RTN","IVMPREC8",350,0)
 Q:ADDRSRC="LACS" "LACS"
"RTN","IVMPREC8",351,0)
 Q:ADDRSRC="USVOA" "VOA"
"RTN","IVMPREC8",352,0)
 Q ""
"RTN","IVMPREC8",353,0)
EPCSRCC(EPCSRC) ;Convert Email, Cell, Pager Change Source from HL7 to DHCP
"RTN","IVMPREC8",354,0)
 ;
"RTN","IVMPREC8",355,0)
 Q:$G(EPCSRC)']"" ""
"RTN","IVMPREC8",356,0)
 Q:EPCSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",357,0)
 Q:EPCSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",358,0)
 Q:EPCSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",359,0)
 Q ""
"RTN","IVMPREC8",360,0)
BAICONV(BAISRC) ;Convert Bad address source from HL7 to DHCP format
"RTN","IVMPREC8",361,0)
 Q:$G(BAISRC)']"" ""
"RTN","IVMPREC8",362,0)
 Q:BAISRC="VAB1" 1
"RTN","IVMPREC8",363,0)
 Q:BAISRC="VAB2" 2
"RTN","IVMPREC8",364,0)
 Q:BAISRC="VAB3" 3
"RTN","IVMPREC8",365,0)
 Q:BAISRC="VAB4" 4
"RTN","IVMPREC8",366,0)
 Q ""
"RTN","IVMPREC8",367,0)
CONVPH(PH) ;remove special chars/spaces from Phone number
"RTN","IVMPREC8",368,0)
 Q $TR(PH," )(/#\-","")
"RTN","IVMPREC8",369,0)
CNTRCONV(COUNTRY) ;Check if valid country
"RTN","IVMPREC8",370,0)
 I COUNTRY="" Q 0
"RTN","IVMPREC8",371,0)
 Q $O(^HL(779.004,"B",COUNTRY,""))
"RTN","IVMPREC8",372,0)
CHKEMAIL(EMAIL) ;Check for Valid Email
"RTN","IVMPREC8",373,0)
 I $G(EMAIL)="" Q 0
"RTN","IVMPREC8",374,0)
 I '(EMAIL?1.E1"@"1.E1"."1.E) Q 0
"RTN","IVMPREC8",375,0)
 Q 1
"RTN","IVMPREC9")
0^10^B63018866
"RTN","IVMPREC9",1,0)
IVMPREC9 ;ALB/KCL/BRM/CKN,TDM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ; 5/11/10 11:42am
"RTN","IVMPREC9",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**34,58,115,121**; 21-OCT-94;Build 45
"RTN","IVMPREC9",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMPREC9",4,0)
 ;
"RTN","IVMPREC9",5,0)
 ;
"RTN","IVMPREC9",6,0)
 ;
"RTN","IVMPREC9",7,0)
STORE ; - store HL7 fields that have a different value than DHCP fields in
"RTN","IVMPREC9",8,0)
 ;   the IVM Patient (#301.5) file (#301.511) multiple for uploading
"RTN","IVMPREC9",9,0)
 ;
"RTN","IVMPREC9",10,0)
 S:$D(AUPFARY(IVMDEMDA)) UPDAUP(IVMDEMDA)=""
"RTN","IVMPREC9",11,0)
 G:IVMFLG STORE2
"RTN","IVMPREC9",12,0)
 S X=$$IEN^IVMUFNC4("PID")
"RTN","IVMPREC9",13,0)
 ;
"RTN","IVMPREC9",14,0)
 K DIC("DR")
"RTN","IVMPREC9",15,0)
 S DA(1)=IVM3015
"RTN","IVMPREC9",16,0)
 I $G(^IVM(301.5,DA(1),"IN",0))']"" S ^(0)="^301.501PA^^"
"RTN","IVMPREC9",17,0)
 S DIC="^IVM(301.5,"_DA(1)_",""IN"",",DIC(0)="L",DLAYGO=301.501
"RTN","IVMPREC9",18,0)
 K DD,DO D FILE^DICN
"RTN","IVMPREC9",19,0)
 K DIC,DLAYGO,X,Y
"RTN","IVMPREC9",20,0)
 ;
"RTN","IVMPREC9",21,0)
 ; - build mail message if SUPRESS DEMOGRAPHIC NOTIFICATION field is
"RTN","IVMPREC9",22,0)
 ;   not set in the IVM Site Parameter (#301.9) file
"RTN","IVMPREC9",23,0)
 ;
"RTN","IVMPREC9",24,0)
 I '$P($G(^IVM(301.9,1,0)),"^",5),'IVMADFLG D DEMBULL^IVMPREC6
"RTN","IVMPREC9",25,0)
 ;
"RTN","IVMPREC9",26,0)
 ; - set flag in order to not repeat STORE tag for one msg
"RTN","IVMPREC9",27,0)
 S IVMFLG=1
"RTN","IVMPREC9",28,0)
 ;
"RTN","IVMPREC9",29,0)
 S DA(2)=DA(1)
"RTN","IVMPREC9",30,0)
 S DA(1)=$P(^IVM(301.5,DA(1),"IN",0),"^",3)
"RTN","IVMPREC9",31,0)
 ;
"RTN","IVMPREC9",32,0)
STORE2 ;
"RTN","IVMPREC9",33,0)
 ; - X as the record in the IVM Demo Upload Fields (#301.92) file
"RTN","IVMPREC9",34,0)
 S X=+IVMDEMDA
"RTN","IVMPREC9",35,0)
 I $G(^IVM(301.5,DA(2),"IN",DA(1),"DEM",0))']"" S ^(0)="^301.511PA^^"
"RTN","IVMPREC9",36,0)
 S DIC="^IVM(301.5,"_DA(2)_",""IN"",DA(1),""DEM"",",DIC(0)="L"
"RTN","IVMPREC9",37,0)
 S DIC("DR")=".02////^S X=IVMFLD",DLAYGO=301.511
"RTN","IVMPREC9",38,0)
 K DD,DO D FILE^DICN
"RTN","IVMPREC9",39,0)
 K DIC,DLAYGO,X,Y
"RTN","IVMPREC9",40,0)
 ;
"RTN","IVMPREC9",41,0)
 Q
"RTN","IVMPREC9",42,0)
 ;
"RTN","IVMPREC9",43,0)
 ;
"RTN","IVMPREC9",44,0)
LOOK ; Find the current DHCP field value.
"RTN","IVMPREC9",45,0)
 ;  Input:   DR  --   Field number of the field in file #2
"RTN","IVMPREC9",46,0)
 ;          DFN  --   Pointer to the patient in file #2
"RTN","IVMPREC9",47,0)
 ;  Output:   Y  --   Internal value of field
"RTN","IVMPREC9",48,0)
 ;
"RTN","IVMPREC9",49,0)
 N IVMOUTTY,I
"RTN","IVMPREC9",50,0)
 ;S DIC="^DPT(",DA=DFN,DIQ="IVM",DIQ(0)="I" D EN^DIQ1
"RTN","IVMPREC9",51,0)
 S DIQ(0)=$S($G(DIQ(0))="":"I",$G(DIQ(0))="E":"E",1:"I")
"RTN","IVMPREC9",52,0)
 S IVMOUTTY=DIQ(0)
"RTN","IVMPREC9",53,0)
 S DIC="^DPT(",DA=DFN,DIQ="IVM" D EN^DIQ1
"RTN","IVMPREC9",54,0)
 ;S Y=$G(IVM(2,DFN,DR,"I"))
"RTN","IVMPREC9",55,0)
 S Y=$G(IVM(2,DFN,DR,IVMOUTTY))
"RTN","IVMPREC9",56,0)
 K DIC,DIQ,DR,IVM
"RTN","IVMPREC9",57,0)
 Q
"RTN","IVMPREC9",58,0)
AUTOEPC(DFN,UPDEPC) ;
"RTN","IVMPREC9",59,0)
 ; this functionality is copied from IVMLDEM6 and modified to allow
"RTN","IVMPREC9",60,0)
 ; an automated upload of patient communications information
"RTN","IVMPREC9",61,0)
 ;  Input:     DFN  -  as patient IEN
"RTN","IVMPREC9",62,0)
 ;          UPDEPC  -  array contains flag for update/noupdate for all
"RTN","IVMPREC9",63,0)
 ;                     communication types.
"RTN","IVMPREC9",64,0)
 ; Output: IVMFLAG  -  1 if communications fields updated
"RTN","IVMPREC9",65,0)
 ;                     0 if communications fields not updated
"RTN","IVMPREC9",66,0)
 ;
"RTN","IVMPREC9",67,0)
 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,UPDT,IVMCVAL,IVMCFLD,SITEFLD,DFLG,CTYP,UPDT
"RTN","IVMPREC9",68,0)
 S IVMFLAG=0  ;initialize flags
"RTN","IVMPREC9",69,0)
 ; - check for required parameters
"RTN","IVMPREC9",70,0)
 Q:'$G(DFN) IVMFLAG
"RTN","IVMPREC9",71,0)
 S IVMDA2=$G(IVM3015)
"RTN","IVMPREC9",72,0)
 Q:'$G(IVMDA2) IVMFLAG
"RTN","IVMPREC9",73,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMPREC9",74,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
"RTN","IVMPREC9",75,0)
 Q:'IVMDA1 IVMFLAG
"RTN","IVMPREC9",76,0)
 ;
"RTN","IVMPREC9",77,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']""  D
"RTN","IVMPREC9",78,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMPREC9",79,0)
 ..S (UPDT,DFLG)=0
"RTN","IVMPREC9",80,0)
 ..; - check for data node in (#301.511) sub-file
"RTN","IVMPREC9",81,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMPREC9",82,0)
 ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
"RTN","IVMPREC9",83,0)
 ..;Check if fields needs to be updated for particular comm. Type.
"RTN","IVMPREC9",84,0)
 ..S CTYP=0 F  S CTYP=$O(UPDEPC(CTYP)) Q:CTYP=""!UPDT  D
"RTN","IVMPREC9",85,0)
 ...I ("^"_$G(UPDEPC(CTYP))_"^")[("^"_+IVMNODE_"^") S UPDT=1
"RTN","IVMPREC9",86,0)
 ..S IVMCFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMCVAL=$P(IVMNODE,"^",2)
"RTN","IVMPREC9",87,0)
 ..; - load communications fields rec'd from IVM into DHCP (#2) file
"RTN","IVMPREC9",88,0)
 ..I UPDT D UPLOAD^IVMLDEM6(+DFN,IVMCFLD,IVMCVAL) S IVMFLAG=1
"RTN","IVMPREC9",89,0)
 ..; delete inaccurate Addr Change Site data if Source is not VAMC
"RTN","IVMPREC9",90,0)
 ..I UPDT,((IVMCFLD=.1311)!(IVMCFLD=.1313)!(IVMCFLD=.137)) D
"RTN","IVMPREC9",91,0)
 ...I IVMCVAL="VAMC" Q
"RTN","IVMPREC9",92,0)
 ...S SITEFLD=$S(IVMCFLD=.1311:.13111,IVMCFLD=.1313:.1314,IVMCFLD=.137:.138)
"RTN","IVMPREC9",93,0)
 ... S FDA(2,+DFN_",",SITEFLD)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMPREC9",94,0)
 ..; - remove entry only for Email, Cell and Pager from (#301.511) sub-file
"RTN","IVMPREC9",95,0)
 ..S CTYP=0 F  S CTYP=$O(EPCFARY(CTYP)) Q:CTYP=""!DFLG  D
"RTN","IVMPREC9",96,0)
 ...I ("^"_$G(EPCFARY(CTYP))_"^")[("^"_+IVMNODE_"^") S DFLG=1
"RTN","IVMPREC9",97,0)
 ..I DFLG D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMPREC9",98,0)
 ;Delete all communication data (Email, Cell phone, Pager) if they are not received in Z05.
"RTN","IVMPREC9",99,0)
 I $D(EPCDEL) D
"RTN","IVMPREC9",100,0)
 . N CTYPE,DIE,DR,DA,CNTR,VAL
"RTN","IVMPREC9",101,0)
 . S DR="",CNTR=0,VAL="@"
"RTN","IVMPREC9",102,0)
 . S CTYPE="" F  S CTYPE=$O(EPCDEL(CTYPE)) Q:CTYPE=""  D
"RTN","IVMPREC9",103,0)
 . . F I=1:1:$L(EPCDEL(CTYPE),"^") S CNTR=CNTR+1,$P(DR,";",CNTR)=$P(EPCDEL(CTYPE),"^",I)_"////^S X=VAL"
"RTN","IVMPREC9",104,0)
 . S DIE="^DPT(",DA=DFN
"RTN","IVMPREC9",105,0)
 . D ^DIE K DIE,DA,DR
"RTN","IVMPREC9",106,0)
 Q IVMFLAG
"RTN","IVMPREC9",107,0)
 ;
"RTN","IVMPREC9",108,0)
AUTORINC(DFN) ;
"RTN","IVMPREC9",109,0)
 ; application to automatically upload Rated Incompetent data
"RTN","IVMPREC9",110,0)
 ; Input:     DFN   -   Patient IEN
"RTN","IVMPREC9",111,0)
 N IVMI,IVMJ,IVMDA1,IVMDA2,IVMNODE,IVMFLAG,IVMRIVAL,IVMRIFLD
"RTN","IVMPREC9",112,0)
 S IVMFLAG=0
"RTN","IVMPREC9",113,0)
 S IVMDA2=$G(IVM3015)
"RTN","IVMPREC9",114,0)
 I 'IVMDA2 Q IVMFLAG
"RTN","IVMPREC9",115,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMPREC9",116,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
"RTN","IVMPREC9",117,0)
 S IVMI=$O(^IVM(301.92,"C","ZPD08","")) I IVMI="" Q IVMFLAG
"RTN","IVMPREC9",118,0)
 S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
"RTN","IVMPREC9",119,0)
 I IVMJ']"" Q IVMFLAG
"RTN","IVMPREC9",120,0)
 ; - check for data node in (#301.511) sub-file
"RTN","IVMPREC9",121,0)
 S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMPREC9",122,0)
 I '(+IVMNODE)!($P(IVMNODE,"^",2)']"") Q IVMFLAG
"RTN","IVMPREC9",123,0)
 S IVMRIFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMRIVAL=$P(IVMNODE,"^",2)
"RTN","IVMPREC9",124,0)
 I IVMRIVAL="""""" S IVMRIVAL="@"
"RTN","IVMPREC9",125,0)
 D UPLOAD^IVMLDEM6(DFN,IVMRIFLD,IVMRIVAL) S IVMFLAG=1
"RTN","IVMPREC9",126,0)
 ; - remove entry from (#301.511) sub-file
"RTN","IVMPREC9",127,0)
 D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMPREC9",128,0)
 Q IVMFLAG
"RTN","IVMPREC9",129,0)
PHONE ; - ask user to delete phone # [Residence] from Patient (#2) file
"RTN","IVMPREC9",130,0)
 ; This tag is moved here from IVMLDEM6 due to routine size limit
"RTN","IVMPREC9",131,0)
 D FULL^VALM1
"RTN","IVMPREC9",132,0)
 W ! S DIR("A")="Is it okay to delete the patient's Phone Number [Residence]"
"RTN","IVMPREC9",133,0)
 W ! S DIR("A",1)="The patient's address has been updated and the phonenumber"
"RTN","IVMPREC9",134,0)
 S DIR("A",2)="remains on file."
"RTN","IVMPREC9",135,0)
 S DIR("A",3)=" "
"RTN","IVMPREC9",136,0)
 S DIR("A",4)="Patient Name: "_$P($$PT^IVMUFNC4(+DFN),"^")_" ("_$P($$PT^IVMUFNC4(+DFN),"^",3)_")"
"RTN","IVMPREC9",137,0)
 S DIR("A",5)="Phone Number [Residence]: "_$P($G(^DPT(+DFN,.13)),"^")
"RTN","IVMPREC9",138,0)
 S DIR("A",6)=" "
"RTN","IVMPREC9",139,0)
 S DIR("?",1)="Enter 'YES' to delete the patient's Phone Number [Residence] that is"
"RTN","IVMPREC9",140,0)
 S DIR("?",2)="currently on file.  Enter 'NO' to quit without deleting the patient's"
"RTN","IVMPREC9",141,0)
 S DIR("?")="Phone Number [Residence]."
"RTN","IVMPREC9",142,0)
 S DIR(0)="Y",DIR("B")="NO"
"RTN","IVMPREC9",143,0)
 D ^DIR K DIR
"RTN","IVMPREC9",144,0)
 S:Y $P(^DPT(DFN,.13),"^")="" W !!,"Patient's Phone Number [Residence] has ",$S(Y:"",1:"not "),"been deleted."
"RTN","IVMPREC9",145,0)
 Q
"RTN","IVMPREC9",146,0)
 ;
"RTN","IVMPREC9",147,0)
AUTOAUP(DFN,UPDAUP,UPDAUPG) ;
"RTN","IVMPREC9",148,0)
 ; automated upload of misc information
"RTN","IVMPREC9",149,0)
 ;  Input:     DFN  -  patient IEN
"RTN","IVMPREC9",150,0)
 ;          UPDAUP  -  array contains fields for auto-upload
"RTN","IVMPREC9",151,0)
 ;         UPDAUPG  -  array contains field group flag for auto-upload
"RTN","IVMPREC9",152,0)
 ;
"RTN","IVMPREC9",153,0)
 N IVMDA2,IVMDA1,IVMI,MULTFLG,IVMXREF,UFLG,IVMJ,IVMNODE,IVMCFLD,IVMCVAL,Y,IVM30192,MULFIL
"RTN","IVMPREC9",154,0)
 Q:'$G(DFN)
"RTN","IVMPREC9",155,0)
 S IVMDA2=$G(IVM3015) Q:'IVMDA2
"RTN","IVMPREC9",156,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMPREC9",157,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1) Q:'IVMDA1
"RTN","IVMPREC9",158,0)
 ;
"RTN","IVMPREC9",159,0)
 S IVMI="" F  S IVMI=$O(UPDAUP(IVMI)) Q:IVMI=""  D
"RTN","IVMPREC9",160,0)
 .;
"RTN","IVMPREC9",161,0)
 .;If DHCP field is a multiple set multiple flag for special filing
"RTN","IVMPREC9",162,0)
 .S MULTFLG=0
"RTN","IVMPREC9",163,0)
 .S IVM30192=$G(^IVM(301.92,IVMI,0)),IVMXREF=$P(IVM30192,"^",2)
"RTN","IVMPREC9",164,0)
 .I IVMXREF="PID10" S MULTFLG=1       ;Race
"RTN","IVMPREC9",165,0)
 .I IVMXREF="PID117C" S MULTFLG=1     ;Conf Addr Category
"RTN","IVMPREC9",166,0)
 .I IVMXREF="PID22" S MULTFLG=1       ;Ethnicity
"RTN","IVMPREC9",167,0)
 .;
"RTN","IVMPREC9",168,0)
 .;Don't file if part of a group & group update flag not set
"RTN","IVMPREC9",169,0)
 .S UFLG=1 I AUPFARY(IVMI)'="",'UPDAUPG(AUPFARY(IVMI)) S UFLG=0
"RTN","IVMPREC9",170,0)
 .;
"RTN","IVMPREC9",171,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMPREC9",172,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMPREC9",173,0)
 ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
"RTN","IVMPREC9",174,0)
 ..S IVMCFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5)
"RTN","IVMPREC9",175,0)
 ..S IVMCVAL=$P(IVMNODE,"^",2)
"RTN","IVMPREC9",176,0)
 ..;
"RTN","IVMPREC9",177,0)
 ..I UFLG D
"RTN","IVMPREC9",178,0)
 ...I MULTFLG D AUTOAUPM(+DFN,IVM30192,IVMCVAL)         ;file mult fld
"RTN","IVMPREC9",179,0)
 ...I 'MULTFLG D UPLOAD^IVMLDEM6(+DFN,IVMCFLD,IVMCVAL)  ;file non-mult
"RTN","IVMPREC9",180,0)
 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)          ;remove from 301.511
"RTN","IVMPREC9",181,0)
 ..; - if no display or uploadable fields left, delete the PID segment
"RTN","IVMPREC9",182,0)
 ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
"RTN","IVMPREC9",183,0)
 ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
"RTN","IVMPREC9",184,0)
 Q
"RTN","IVMPREC9",185,0)
 ;
"RTN","IVMPREC9",186,0)
AUTOAUPM(DFN,IVM30192,IVMVALUE) ;
"RTN","IVMPREC9",187,0)
 ;  Input:       DFN  -  as patient IEN
"RTN","IVMPREC9",188,0)
 ;          IVM30192  -  as '0' node of the 301.92 entry
"RTN","IVMPREC9",189,0)
 ;          IVMVALUE  -  as the value of the field
"RTN","IVMPREC9",190,0)
 ;
"RTN","IVMPREC9",191,0)
 ; Output: None
"RTN","IVMPREC9",192,0)
 ;
"RTN","IVMPREC9",193,0)
 N MFIL,MFLD,DDINFO,DDMNOD,DDMFLD,DA,DIK,DGENDA,MULFIL,DATA,SUB
"RTN","IVMPREC9",194,0)
 S MFIL=$P(IVM30192,"^",4),MFLD=$P(IVM30192,"^",5)
"RTN","IVMPREC9",195,0)
 S DDINFO=$G(^DD(MFIL,MFLD,0))
"RTN","IVMPREC9",196,0)
 S DDMNOD=$P($P(DDINFO,"^",4),";"),DDMFLD=+$P(DDINFO,"^",2)
"RTN","IVMPREC9",197,0)
 ;
"RTN","IVMPREC9",198,0)
 ; - delete values currently in the multiple field
"RTN","IVMPREC9",199,0)
 S DA(1)=DFN,DIK="^DPT("_DFN_","""_DDMNOD_""","
"RTN","IVMPREC9",200,0)
 S DA=0 F  S DA=$O(^DPT(DFN,DDMNOD,DA)) Q:'DA  D ^DIK
"RTN","IVMPREC9",201,0)
 ;
"RTN","IVMPREC9",202,0)
 ; - add new values to multiple field
"RTN","IVMPREC9",203,0)
 S DGENDA(1)=DFN
"RTN","IVMPREC9",204,0)
 ;
"RTN","IVMPREC9",205,0)
 I DDMFLD=2.02 D
"RTN","IVMPREC9",206,0)
 .S DATA(.02)=$$FIND1^DIC(10.3,,,"SELF IDENTIFICATION")
"RTN","IVMPREC9",207,0)
 .S SUB="" F  S SUB=$O(IVMRACE(2,SUB)) Q:SUB=""  D
"RTN","IVMPREC9",208,0)
 ..S DATA(.01)=SUB
"RTN","IVMPREC9",209,0)
 ..I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
"RTN","IVMPREC9",210,0)
 ;
"RTN","IVMPREC9",211,0)
 I DDMFLD=2.06 D
"RTN","IVMPREC9",212,0)
 .S DATA(.01)=IVMVALUE
"RTN","IVMPREC9",213,0)
 .S DATA(.02)=$$FIND1^DIC(10.3,,,"SELF IDENTIFICATION")
"RTN","IVMPREC9",214,0)
 .I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
"RTN","IVMPREC9",215,0)
 ;
"RTN","IVMPREC9",216,0)
 I DDMFLD=2.141 D
"RTN","IVMPREC9",217,0)
 .S DATA(1)="Y"
"RTN","IVMPREC9",218,0)
 .S SUB="" F  S SUB=$O(CONFADCT(SUB)) Q:SUB=""  D
"RTN","IVMPREC9",219,0)
 ..S DATA(.01)=SUB
"RTN","IVMPREC9",220,0)
 ..I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
"RTN","IVMPREC9",221,0)
 Q
"RTN","IVMPRECA")
0^11^B87129700
"RTN","IVMPRECA",1,0)
IVMPRECA ;ALB/KCL/BRM/PJR/RGL/CKN,TDM - DEMOGRAPHICS MESSAGE CONSISTENCY CHECK ; 7/8/10 12:51pm
"RTN","IVMPRECA",2,0)
 ;;2.0; INCOME VERIFICATION MATCH ;**5,6,12,34,58,56,115,144,121**; 21-OCT-94;Build 45
"RTN","IVMPRECA",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMPRECA",4,0)
 ;
"RTN","IVMPRECA",5,0)
 ; This routine will perform data validation checks on uploadable
"RTN","IVMPRECA",6,0)
 ; demographic fields received from the IVM Center to ensure they
"RTN","IVMPRECA",7,0)
 ; are acurate prior to their upload into DHCP.
"RTN","IVMPRECA",8,0)
 ;
"RTN","IVMPRECA",9,0)
 ;
"RTN","IVMPRECA",10,0)
 ; Called from routine IVMPREC6 before uploadable demographic fields
"RTN","IVMPRECA",11,0)
 ; are stored in DHCP.
"RTN","IVMPRECA",12,0)
 ;
"RTN","IVMPRECA",13,0)
 ;
"RTN","IVMPRECA",14,0)
EN ; - Entry point to create temp array and perform msg consistency checks
"RTN","IVMPRECA",15,0)
 ;
"RTN","IVMPRECA",16,0)
 N DFN,IVMCNTY,IVMCR,IVMEG,IVMFLAG,IVMFLD,IVMNUM,IVMSTR,IVMSTPTR,X
"RTN","IVMPRECA",17,0)
 N COMP,CNTR,NOPID,ADDRTYPE,ADDSEQ,TELESEQ,COMMTYPE,TCFLG,TMPARRY,PID3ARRY,CNTR2
"RTN","IVMPRECA",18,0)
 N MULTDONE
"RTN","IVMPRECA",19,0)
 K IVMRACE
"RTN","IVMPRECA",20,0)
 S IVMNUM=IVMDA ; 'current' line in ^HL(772,"IN",...
"RTN","IVMPRECA",21,0)
 S DODSEG=0 ;Initialize flag for DOD information
"RTN","IVMPRECA",22,0)
 S GUARSEG=0 ;Initialize flag for Guardian information
"RTN","IVMPRECA",23,0)
 ;
"RTN","IVMPRECA",24,0)
 ; - check the format of the HL7 demographic message
"RTN","IVMPRECA",25,0)
 D NEXT I $E(IVMSTR,1,3)'="PID" S HLERR="Missing PID segment" G ENQ
"RTN","IVMPRECA",26,0)
 S CNTR=1,NOPID=0,PIDSTR(CNTR)=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",27,0)
 ;Handle wrapped PID segment
"RTN","IVMPRECA",28,0)
 F I=1:1 D  Q:NOPID
"RTN","IVMPRECA",29,0)
 . D NEXT I $E(IVMSTR,1,4)="ZPD^" S NOPID=1 Q
"RTN","IVMPRECA",30,0)
 . S CNTR=CNTR+1,PIDSTR(CNTR)=IVMSTR
"RTN","IVMPRECA",31,0)
 D BLDPID^IVMPREC6(.PIDSTR,.IVMPID)  ;Create IVMPID subscript by seq #
"RTN","IVMPRECA",32,0)
 ;convert "" to null for PID segment
"RTN","IVMPRECA",33,0)
 S CNTR="" F  S CNTR=$O(IVMPID(CNTR)) Q:CNTR=""  D
"RTN","IVMPRECA",34,0)
 . I $O(IVMPID(CNTR,"")) D  Q
"RTN","IVMPRECA",35,0)
 . . S CNTR2="" F  S CNTR2=$O(IVMPID(CNTR,CNTR2)) Q:CNTR2=""  D
"RTN","IVMPRECA",36,0)
 . . . S IVMPID(CNTR,CNTR2)=$$CLEARF(IVMPID(CNTR,CNTR2),$E(HLECH))
"RTN","IVMPRECA",37,0)
 . I CNTR=11 S IVMPID(CNTR)=$$CLEARF(IVMPID(CNTR),$E(HLECH)) Q
"RTN","IVMPRECA",38,0)
 . I IVMPID(CNTR)=HLQ S IVMPID(CNTR)=""
"RTN","IVMPRECA",39,0)
 I $E(IVMSTR,1,3)'="ZPD" S HLERR="Missing ZPD segment" G ENQ
"RTN","IVMPRECA",40,0)
 S IVMSTR("ZPD")=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",41,0)
 I $P(IVMSTR("ZPD"),HLFS,8)'="" S GUARSEG=1
"RTN","IVMPRECA",42,0)
 I $P(IVMSTR("ZPD"),HLFS,9)'="" S DODSEG=1
"RTN","IVMPRECA",43,0)
 D NEXT I $E(IVMSTR,1,3)="ZEL" S HLERR="ZEL segment should not be sent in Z05 message" G ENQ
"RTN","IVMPRECA",44,0)
 ;I $E(IVMSTR,1,3)="ZTA" D NEXT  ;Skip ZTA -coming later
"RTN","IVMPRECA",45,0)
 I $E(IVMSTR,1,3)'="ZTA" S HLERR="Missing ZTA segment" G ENQ
"RTN","IVMPRECA",46,0)
 S IVMSTR("ZTA")=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",47,0)
 D NEXT
"RTN","IVMPRECA",48,0)
 I $E(IVMSTR,1,3)'="ZGD" S HLERR="Missing ZGD segment" G ENQ
"RTN","IVMPRECA",49,0)
 S IVMSTR("ZGD")=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",50,0)
 ;
"RTN","IVMPRECA",51,0)
 ; - perform field validation checks for PID segment
"RTN","IVMPRECA",52,0)
 M TMPARRY(3)=IVMPID(3) D PARSPID3^IVMUFNC(.TMPARRY,.PID3ARY)
"RTN","IVMPRECA",53,0)
 S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
"RTN","IVMPRECA",54,0)
 K TMPARRY,PID3ARY
"RTN","IVMPRECA",55,0)
 I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) S HLERR=ERRMSG G ENQ
"RTN","IVMPRECA",56,0)
 S IVMDFN=DFN  ;Store DFN in temp variable to use later
"RTN","IVMPRECA",57,0)
 ;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVM SSN with DHCP SSN" G ENQ
"RTN","IVMPRECA",58,0)
 ;
"RTN","IVMPRECA",59,0)
 S X=IVMPID(7) I X]"",($$FMDATE^HLFNC(X)>DT) S HLERR="Date of Birth greater than current date" G ENQ
"RTN","IVMPRECA",60,0)
 ;
"RTN","IVMPRECA",61,0)
 S X=IVMPID(8) I X]"",X'="M",X'="F" S HLERR="Invalid code sent for Patient sex" G ENQ
"RTN","IVMPRECA",62,0)
 ;
"RTN","IVMPRECA",63,0)
 ; Marital Status
"RTN","IVMPRECA",64,0)
 S X=$G(IVMPID(16)) I (X'="")&(X'="D")&(X'="M")&(X'="W")&(X'="U")&(X'="A")&(X'="S") D  G ENQ
"RTN","IVMPRECA",65,0)
 . S HLERR="Invalid code sent for Patient Marital Status" G ENQ
"RTN","IVMPRECA",66,0)
 ; Religion
"RTN","IVMPRECA",67,0)
 S X=$G(IVMPID(17)) I X'="" S X=$O(^DIC(13,"C",+X,"")) I X="" D  G ENQ
"RTN","IVMPRECA",68,0)
 . S HLERR="Invalid code sent for Patient Religion"
"RTN","IVMPRECA",69,0)
 ; Ethnicity
"RTN","IVMPRECA",70,0)
 S X=$P($G(IVMPID(22)),$E(HLECH),4) I X]"" S X=$O(^DIC(10.2,"AHL7",X,"")) I X="" D  G ENQ
"RTN","IVMPRECA",71,0)
 . S HLERR="Invalid code sent for Patient Ethnicity" G ENQ
"RTN","IVMPRECA",72,0)
 ;
"RTN","IVMPRECA",73,0)
 ; - if address - perform validation checks on addr fields
"RTN","IVMPRECA",74,0)
 ;Get all address from seq. 11 of PID segment
"RTN","IVMPRECA",75,0)
 I 'DODSEG,'GUARSEG D
"RTN","IVMPRECA",76,0)
 . D PID11 Q:$D(HLERR)
"RTN","IVMPRECA",77,0)
 . D PID10 Q:$D(HLERR)
"RTN","IVMPRECA",78,0)
 . D PID13
"RTN","IVMPRECA",79,0)
 G ENQ:$D(HLERR)
"RTN","IVMPRECA",80,0)
 ;
"RTN","IVMPRECA",81,0)
 ; - perform field validation check for ZPD and ZGD segment
"RTN","IVMPRECA",82,0)
 ; - I X]"" was changed to I X below for IVM*2*56
"RTN","IVMPRECA",83,0)
 S X=$P(IVMSTR("ZPD"),HLFS,9) I X,($$FMDATE^HLFNC(X)<$P($G(^DPT(+DFN,0)),"^",3))!($$FMDATE^HLFNC(X)>$$DT^XLFDT) S HLERR="Invalid date of death" G ENQ
"RTN","IVMPRECA",84,0)
 ; IVM*2*121 - Added new check for ZGD
"RTN","IVMPRECA",85,0)
 N ZGD3
"RTN","IVMPRECA",86,0)
 S ZGD3=$P(IVMSTR("ZGD"),HLFS,3)
"RTN","IVMPRECA",87,0)
 S X=$P(IVMSTR("ZGD"),HLFS,2)
"RTN","IVMPRECA",88,0)
 I X=HLQ S HLERR="Invalid Guardian Type" G ENQ
"RTN","IVMPRECA",89,0)
 I X,X'=1 S HLERR="Invalid Guardian Type" G ENQ
"RTN","IVMPRECA",90,0)
 I X=1,((ZGD3=HLQ)!(ZGD3="")) S HLERR="Invalid Guardian Type" G ENQ
"RTN","IVMPRECA",91,0)
 ;
"RTN","IVMPRECA",92,0)
 ;
"RTN","IVMPRECA",93,0)
ENQ ; - send acknowledgement (ACK) 'AE' msg to the IVM Center
"RTN","IVMPRECA",94,0)
 I $D(HLERR) D ACK^IVMPREC
"RTN","IVMPRECA",95,0)
 Q
"RTN","IVMPRECA",96,0)
 ;
"RTN","IVMPRECA",97,0)
 ;
"RTN","IVMPRECA",98,0)
ADDRCHK ; - validate address fields sent by IVM Center
"RTN","IVMPRECA",99,0)
 N HLERRDEF
"RTN","IVMPRECA",100,0)
 ;I ADDRTYPE="N" D  Q   ;Birth City & State
"RTN","IVMPRECA",101,0)
 ;. I $P(X,$E(HLECH),3)']"" S HLERR="Invalid address - Missing birth city" Q
"RTN","IVMPRECA",102,0)
 ;. I $P(X,$E(HLECH),4)']"" S HLERR="Invalid address - Missing birth state abbreviation" Q
"RTN","IVMPRECA",103,0)
 ;. S IVMSTPTR=+$O(^DIC(5,"C",$P(X,$E(HLECH),4),0))
"RTN","IVMPRECA",104,0)
 ;. I 'IVMSTPTR S HLERR="Invalid birth state abbreviation" Q
"RTN","IVMPRECA",105,0)
 ;
"RTN","IVMPRECA",106,0)
 S HLERRDEF="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"address - "
"RTN","IVMPRECA",107,0)
 S CNTRY=$P(X,$E(HLECH),6) I CNTRY']"" S HLERR=HLERRDEF_"Missing Country" Q
"RTN","IVMPRECA",108,0)
 I '$$CNTRCONV^IVMPREC8(CNTRY) S HLERR=HLERRDEF_"Invalid Country" Q
"RTN","IVMPRECA",109,0)
 S FORFLG=$S(CNTRY="USA":0,1:1)
"RTN","IVMPRECA",110,0)
 I $P(X,$E(HLECH),1)']"" S HLERR=HLERRDEF_"Missing street address [line 1]" Q
"RTN","IVMPRECA",111,0)
 I $P(X,$E(HLECH),3)']"" S HLERR=HLERRDEF_"Missing city" Q
"RTN","IVMPRECA",112,0)
 ;I $P(X,$E(HLECH),4)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"state abbreviation",1:"province") Q
"RTN","IVMPRECA",113,0)
 ;I $P(X,$E(HLECH),5)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"zip code",1:"postal code") Q
"RTN","IVMPRECA",114,0)
 I $P(X,$E(HLECH),4)']"",'FORFLG S HLERR=HLERRDEF_"Missing State abbreviation" Q
"RTN","IVMPRECA",115,0)
 I $P(X,$E(HLECH),5)']"",'FORFLG S HLERR=HLERRDEF_"Missing Zip Code" Q
"RTN","IVMPRECA",116,0)
 I 'FORFLG D  Q:$D(HLERR)
"RTN","IVMPRECA",117,0)
 . S IVMCNTY=$G(IVMPID(12))
"RTN","IVMPRECA",118,0)
 . I IVMCNTY']"" S HLERR=HLERRDEF_"Missing county code" Q
"RTN","IVMPRECA",119,0)
 I $L($P(X,$E(HLECH),1))>35!($L($P(X,$E(HLECH),1))<3) S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 1]" Q
"RTN","IVMPRECA",120,0)
 I $P(X,$E(HLECH),2)]"",(($L($P(X,$E(HLECH),2))>30)!($L($P(X,$E(HLECH),2))<3)) S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 2]" Q
"RTN","IVMPRECA",121,0)
 I $L($P(X,$E(HLECH),3))>15!($L($P(X,$E(HLECH),3))<2) S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"city" Q
"RTN","IVMPRECA",122,0)
 ;
"RTN","IVMPRECA",123,0)
 ; - save state pointer for county code validation only if not foreign address
"RTN","IVMPRECA",124,0)
 I 'FORFLG D  Q:$D(HLERR)
"RTN","IVMPRECA",125,0)
 .S IVMSTPTR=+$O(^DIC(5,"C",$P(X,$E(HLECH),4),0))
"RTN","IVMPRECA",126,0)
 .I 'IVMSTPTR S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"state abbreviation" Q
"RTN","IVMPRECA",127,0)
 .I '$O(^DIC(5,IVMSTPTR,1,"C",IVMCNTY,0)) D  Q:$G(HLERR)]""
"RTN","IVMPRECA",128,0)
 ..N STFIPS
"RTN","IVMPRECA",129,0)
 ..S STFIPS=IVMSTPTR
"RTN","IVMPRECA",130,0)
 ..S:$L(STFIPS)<2 STFIPS="0"_STFIPS
"RTN","IVMPRECA",131,0)
 ..Q:$$FIPSCHK^XIPUTIL(STFIPS_IVMCNTY)  ;county code is valid
"RTN","IVMPRECA",132,0)
 ..S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"county code"
"RTN","IVMPRECA",133,0)
 .S X=$P(X,$E(HLECH),5) D ZIPIN^VAFADDR I $D(X)[0 S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"zip code" Q
"RTN","IVMPRECA",134,0)
 Q
"RTN","IVMPRECA",135,0)
 ;
"RTN","IVMPRECA",136,0)
 ;
"RTN","IVMPRECA",137,0)
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
"RTN","IVMPRECA",138,0)
 S IVMNUM=$O(^TMP($J,IVMRTN,IVMNUM)),IVMSTR=$G(^(+IVMNUM,0))
"RTN","IVMPRECA",139,0)
 Q
"RTN","IVMPRECA",140,0)
 ;
"RTN","IVMPRECA",141,0)
PID10 ; Perform consistency checks for seq. 10
"RTN","IVMPRECA",142,0)
 ; Get all Race data from seq. 10 of PID segment
"RTN","IVMPRECA",143,0)
 N RACEVAL,RACEDA,RACEFLG,RACESQ
"RTN","IVMPRECA",144,0)
 S RACEFLG=1 ;Flag to check if Race data exist.
"RTN","IVMPRECA",145,0)
 I $D(IVMPID(10)) D
"RTN","IVMPRECA",146,0)
 . I $O(IVMPID(10,"")) D  Q
"RTN","IVMPRECA",147,0)
 . . S RACESQ=0 F  S RACESQ=$O(IVMPID(10,RACESQ)) Q:((RACESQ="")!($D(HLERR))!('RACEFLG))  D
"RTN","IVMPRECA",148,0)
 . . . I $G(IVMPID(10,RACESQ))="" S RACEFLG=0 Q
"RTN","IVMPRECA",149,0)
 . . . S RACEVAL=$P($P(IVMPID(10,RACESQ),$E(HLECH),1),"-",1,2)
"RTN","IVMPRECA",150,0)
 . . . I RACEVAL="" S HLERR="Missing Race Value - PID Seq 10" Q
"RTN","IVMPRECA",151,0)
 . . . S IVMRACE(1,RACEVAL)=IVMPID(10,RACESQ)
"RTN","IVMPRECA",152,0)
 . I $G(IVMPID(10))="" S RACEFLG=0 Q
"RTN","IVMPRECA",153,0)
 . I $P($P(IVMPID(10),$E(HLECH),1),"-",1,2)="" S HLERR="Missing Race Value - PID Seq 10" Q
"RTN","IVMPRECA",154,0)
 . S RACEVAL=$P($P(IVMPID(10),$E(HLECH),1),"-",1,2)
"RTN","IVMPRECA",155,0)
 . I RACEVAL="" S HLERR="Missing Race Value - PID Seq 10" Q
"RTN","IVMPRECA",156,0)
 . S IVMRACE(1,RACEVAL)=IVMPID(10)
"RTN","IVMPRECA",157,0)
 Q:$D(HLERR)
"RTN","IVMPRECA",158,0)
 ;perform consistency checks on Race
"RTN","IVMPRECA",159,0)
 I RACEFLG D
"RTN","IVMPRECA",160,0)
 . S RACEVAL="" F  S RACEVAL=$O(IVMRACE(1,RACEVAL)) Q:RACEVAL=""!$D(HLERR)  D
"RTN","IVMPRECA",161,0)
 . . S RACEDA=$$CODE2PTR^DGUTL4(RACEVAL,1,2)
"RTN","IVMPRECA",162,0)
 . . I RACEVAL="UNK-SLF" S RACEDA=$$CODE2PTR^DGUTL4("9999-4",1,2)
"RTN","IVMPRECA",163,0)
 . . I RACEDA<1 S HLERR="Invalid Race Value - PID Seq 10" Q
"RTN","IVMPRECA",164,0)
 . . S IVMRACE(2,RACEDA)=IVMRACE(1,RACEVAL)
"RTN","IVMPRECA",165,0)
 Q
"RTN","IVMPRECA",166,0)
 ;
"RTN","IVMPRECA",167,0)
PID11 ; Perform consistency check for seq. 11
"RTN","IVMPRECA",168,0)
 S CONFADCT=""
"RTN","IVMPRECA",169,0)
 I $D(IVMPID(11)) D
"RTN","IVMPRECA",170,0)
 . I $O(IVMPID(11,"")) D  Q
"RTN","IVMPRECA",171,0)
 . . S ADDSEQ=0 F  S ADDSEQ=$O(IVMPID(11,ADDSEQ)) Q:ADDSEQ=""!($D(HLERR))  D
"RTN","IVMPRECA",172,0)
 . . . I $G(IVMPID(11,ADDSEQ))="" S HLERR="Invalid Address - Missing Address information" Q
"RTN","IVMPRECA",173,0)
 . . . S ADDRTYPE=$P($G(IVMPID(11,ADDSEQ)),$E(HLECH),7)
"RTN","IVMPRECA",174,0)
 . . . I ADDRTYPE="" S HLERR="Invalid Address - Missing Address Type" Q
"RTN","IVMPRECA",175,0)
 . . . ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
"RTN","IVMPRECA",176,0)
 . . . Q:'$D(IVMALADT(ADDRTYPE))
"RTN","IVMPRECA",177,0)
 . . . I IVMALADT(ADDRTYPE)="" S ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
"RTN","IVMPRECA",178,0)
 . . . ;I $P(IVMALADT(ADDRTYPE),"^")="CA" D
"RTN","IVMPRECA",179,0)
 . . . ;. S ADDRESS("CA")=IVMPID(11,ADDSEQ)
"RTN","IVMPRECA",180,0)
 . . . ;. S CONFADCT=$P(IVMALADT(ADDRTYPE),"^",2)
"RTN","IVMPRECA",181,0)
 . . . ;. S CONFADCT(CONFADCT)=""
"RTN","IVMPRECA",182,0)
 . I $G(IVMPID(11))="" S HLERR="Invalid Address - Missing Address information" Q
"RTN","IVMPRECA",183,0)
 . S ADDRTYPE=$P($G(IVMPID(11)),$E(HLECH),7)
"RTN","IVMPRECA",184,0)
 . I ADDRTYPE="" S HLERR="Invalid Address - Missing Address Type" Q
"RTN","IVMPRECA",185,0)
 . ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11)
"RTN","IVMPRECA",186,0)
 . Q:'$D(IVMALADT(ADDRTYPE))
"RTN","IVMPRECA",187,0)
 . I IVMALADT(ADDRTYPE)="" S ADDRESS(ADDRTYPE)=IVMPID(11)
"RTN","IVMPRECA",188,0)
 . ;I $P(IVMALADT(ADDRTYPE),"^")="CA" D
"RTN","IVMPRECA",189,0)
 . ;. S ADDRESS("CA")=IVMPID(11)
"RTN","IVMPRECA",190,0)
 . ;. S CONFADCT=$P(IVMALADT(ADDRTYPE),"^",2)
"RTN","IVMPRECA",191,0)
 . ;. S CONFADCT(CONFADCT)=""
"RTN","IVMPRECA",192,0)
 Q:$D(HLERR)
"RTN","IVMPRECA",193,0)
 ;perform consistency checks on Permanent and all bad address
"RTN","IVMPRECA",194,0)
 I '$D(ADDRESS) S HLERR="Invalid Address - Invalid Address Type" Q
"RTN","IVMPRECA",195,0)
 S ADDRTYPE="" S ADDRTYPE=$O(ADDRESS(ADDRTYPE)) D
"RTN","IVMPRECA",196,0)
 . S X=$G(ADDRESS(ADDRTYPE)) D ADDRCHK
"RTN","IVMPRECA",197,0)
 Q
"RTN","IVMPRECA",198,0)
 ;
"RTN","IVMPRECA",199,0)
PID13 ; Perform consistency checks for seq. 13
"RTN","IVMPRECA",200,0)
 ;Get communication data for all types from seq. 13 or PID segment
"RTN","IVMPRECA",201,0)
 S TCFLG=1 ;Flag to check if Telecom data exist.
"RTN","IVMPRECA",202,0)
 I $D(IVMPID(13)) D
"RTN","IVMPRECA",203,0)
 . I $O(IVMPID(13,"")) D  Q
"RTN","IVMPRECA",204,0)
 . . S TELESEQ=0 F  S TELESEQ=$O(IVMPID(13,TELESEQ)) Q:((TELESEQ="")!($D(HLERR))!('TCFLG))  D
"RTN","IVMPRECA",205,0)
 . . . I $G(IVMPID(13,TELESEQ))="" S TCFLG=0 Q
"RTN","IVMPRECA",206,0)
 . . . I $P(IVMPID(13,TELESEQ),$E(HLECH),2)="" S HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13" Q
"RTN","IVMPRECA",207,0)
 . . . S TELECOM($P(IVMPID(13,TELESEQ),$E(HLECH),2))=IVMPID(13,TELESEQ)
"RTN","IVMPRECA",208,0)
 . I $G(IVMPID(13))="" S TCFLG=0 Q
"RTN","IVMPRECA",209,0)
 . I $P(IVMPID(13),$E(HLECH),2)="" S HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13" Q
"RTN","IVMPRECA",210,0)
 . S TELECOM($P(IVMPID(13),$E(HLECH),2))=IVMPID(13)
"RTN","IVMPRECA",211,0)
 Q:$D(HLERR)
"RTN","IVMPRECA",212,0)
 ;perform consistency checks on all types of communication data.
"RTN","IVMPRECA",213,0)
 I TCFLG D
"RTN","IVMPRECA",214,0)
 . S COMMTYPE="" F  S COMMTYPE=$O(TELECOM(COMMTYPE)) Q:COMMTYPE=""!$D(HLERR)  D
"RTN","IVMPRECA",215,0)
 . . I COMMTYPE="NET" D  Q
"RTN","IVMPRECA",216,0)
 . . . S X=$P(TELECOM(COMMTYPE),$E(HLECH),4)
"RTN","IVMPRECA",217,0)
 . . . I X]"",'$$CHKEMAIL^IVMPREC8(X) S HLERR="Invalid Email address"
"RTN","IVMPRECA",218,0)
 . . S X=$P(TELECOM(COMMTYPE),$E(HLECH)) I X]"",(($L(X)>20)!($L(X)<4)) S HLERR="Invalid phone number"
"RTN","IVMPRECA",219,0)
 Q
"RTN","IVMPRECA",220,0)
 ;
"RTN","IVMPRECA",221,0)
CLEARF(NODE,DEL,IGNORE) ;
"RTN","IVMPRECA",222,0)
 ; Input:       NODE    - SEGMENT/SEQ.
"RTN","IVMPRECA",223,0)
 ;               DEL    - Delimiter (optional - default is ^)
"RTN","IVMPRECA",224,0)
 ;            IGNORE    - String of seq # to avoid (optional)
"RTN","IVMPRECA",225,0)
 N I
"RTN","IVMPRECA",226,0)
 I $G(DEL)="" S DEL=HLFS
"RTN","IVMPRECA",227,0)
 F I=1:1:$L(NODE,DEL) D
"RTN","IVMPRECA",228,0)
 . I $G(IGNORE)[(","_I_",") Q  ;Ignore this seq. to convert
"RTN","IVMPRECA",229,0)
 . I $P(NODE,DEL,I)=HLQ S $P(NODE,DEL,I)=""
"RTN","IVMPRECA",230,0)
 Q NODE
"RTN","IVMPTRN8")
0^1^B74827499
"RTN","IVMPTRN8",1,0)
IVMPTRN8 ;ALB/RKS/PDJ/BRM,TDM,PJH,TDM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER ; 11/12/10 2:21pm
"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**; 21-OCT-94;Build 45
"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,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 (ZEN) Enrollment segment
"RTN","IVMPTRN8",93,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEN(DFN)
"RTN","IVMPTRN8",94,0)
 ;
"RTN","IVMPTRN8",95,0)
 ; create (ZCD) Catastrophic Disability segment(s)
"RTN","IVMPTRN8",96,0)
 D BUILD^VAFHLZCD(.IVMZCD,DFN,,HLQ,HLFS)
"RTN","IVMPTRN8",97,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZCD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",98,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZCD(+IVMSUB))
"RTN","IVMPTRN8",99,0)
 ;
"RTN","IVMPTRN8",100,0)
 ; Optionally create (ZMH) Military History segments
"RTN","IVMPTRN8",101,0)
 D ENTER^VAFHLZMH(DFN,"IVMZMH")
"RTN","IVMPTRN8",102,0)
 S (ZMHSQ,SETID)=0
"RTN","IVMPTRN8",103,0)
 I $D(IVMZMH) F  S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ=""  D
"RTN","IVMPTRN8",104,0)
 . Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")=""
"RTN","IVMPTRN8",105,0)
 . S SETID=SETID+1,IVMCT=IVMCT+1
"RTN","IVMPTRN8",106,0)
 . S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6)
"RTN","IVMPTRN8",107,0)
 ;
"RTN","IVMPTRN8",108,0)
 ; create (ZRD) Rated Disabilities segment(s)
"RTN","IVMPTRN8",109,0)
 D EN^VAFHLZRD(DFN,"1,2,3,4,12,13,14,",HLQ,HLFS,"IVMZRD")
"RTN","IVMPTRN8",110,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",111,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0))
"RTN","IVMPTRN8",112,0)
 ;
"RTN","IVMPTRN8",113,0)
 ; create (ZCT) Emergency Contact segment
"RTN","IVMPTRN8",114,0)
 ;S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1)
"RTN","IVMPTRN8",115,0)
 K ZCTARY F ZCTTYP=1:1:5 D   ;Create Optional ZCT Segments
"RTN","IVMPTRN8",116,0)
 . S ZCTARY(ZCTTYP)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",ZCTTYP,1)
"RTN","IVMPTRN8",117,0)
 S (ZCTTYP,ZCTSQ)=0
"RTN","IVMPTRN8",118,0)
 I $D(ZCTARY) F  S ZCTTYP=$O(ZCTARY(ZCTTYP)) Q:ZCTTYP=""  D
"RTN","IVMPTRN8",119,0)
 . Q:$P(ZCTARY(ZCTTYP),HLFS,11)=HLQ
"RTN","IVMPTRN8",120,0)
 . S ZCTSQ=ZCTSQ+1,$P(ZCTARY(ZCTTYP),HLFS,2)=ZCTSQ
"RTN","IVMPTRN8",121,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(ZCTTYP)
"RTN","IVMPTRN8",122,0)
 I ZCTSQ=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(1)
"RTN","IVMPTRN8",123,0)
 ;
"RTN","IVMPTRN8",124,0)
 ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse
"RTN","IVMPTRN8",125,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,5,7")
"RTN","IVMPTRN8",126,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7",2,2)
"RTN","IVMPTRN8",127,0)
 ;
"RTN","IVMPTRN8",128,0)
 ; create (ZGD) Guardian segment for (1) VA & (2) Civil 
"RTN","IVMPTRN8",129,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1)
"RTN","IVMPTRN8",130,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2)
"RTN","IVMPTRN8",131,0)
 ;
"RTN","IVMPTRN8",132,0)
 ; Income Year requiring transmission from IVM Patient File (301.5)
"RTN","IVMPTRN8",133,0)
 S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000))
"RTN","IVMPTRN8",134,0)
 N MTINFO S MTINFO=$$FUT^DGMTU(DFN)
"RTN","IVMPTRN8",135,0)
 I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2)
"RTN","IVMPTRN8",136,0)
 ;get the primary test for the income year
"RTN","IVMPTRN8",137,0)
 S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN)
"RTN","IVMPTRN8",138,0)
 ;
"RTN","IVMPTRN8",139,0)
 ; The following function call returns:
"RTN","IVMPTRN8",140,0)
 ;   - Patient Relation IEN array in DGREL
"RTN","IVMPTRN8",141,0)
 ;   - Individual Annual Income IEN array in DGINC
"RTN","IVMPTRN8",142,0)
 ;   - Income Relation IEN array in DGINR
"RTN","IVMPTRN8",143,0)
 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN)
"RTN","IVMPTRN8",144,0)
 ;
"RTN","IVMPTRN8",145,0)
 S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1
"RTN","IVMPTRN8",146,0)
 ; create (ZIC) Income segment for veteran
"RTN","IVMPTRN8",147,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",148,0)
 ;IVM*2.0*115 -- Check for Means Test Version Indicator
"RTN","IVMPTRN8",149,0)
 N MTVERS S MTVERS=$S(+$G(ACTVIEN):+$P($G(^DGMT(408.31,ACTVIEN,2)),"^",11),1:0)
"RTN","IVMPTRN8",150,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",151,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",152,0)
 E  D
"RTN","IVMPTRN8",153,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,9,12,13,14,15,16,18,19")
"RTN","IVMPTRN8",154,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",155,0)
 ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct
"RTN","IVMPTRN8",156,0)
 S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY)
"RTN","IVMPTRN8",157,0)
 ;
"RTN","IVMPTRN8",158,0)
 ; create (ZIR) Income Relation segment for veteran
"RTN","IVMPTRN8",159,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("V")),"1,2,3,4,5,10")
"RTN","IVMPTRN8",160,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1"
"RTN","IVMPTRN8",161,0)
 ;
"RTN","IVMPTRN8",162,0)
 ; create (ZDP) Patient Dependent Info. segment for spouse
"RTN","IVMPTRN8",163,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",164,0)
 I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",165,0)
 . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",166,0)
 . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",167,0)
 ;
"RTN","IVMPTRN8",168,0)
 ; create (ZIC) Income segment for spouse
"RTN","IVMPTRN8",169,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",170,0)
 ;IVM*2.0*115
"RTN","IVMPTRN8",171,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",172,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",173,0)
 E  D
"RTN","IVMPTRN8",174,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,9,12,16,18,19")
"RTN","IVMPTRN8",175,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",176,0)
 ;
"RTN","IVMPTRN8",177,0)
 ; create (ZIR) Income Relation segment for spouse
"RTN","IVMPTRN8",178,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3")
"RTN","IVMPTRN8",179,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",180,0)
 ;
"RTN","IVMPTRN8",181,0)
 ;
"RTN","IVMPTRN8",182,0)
 ; create ZDP, ZIC, and ZIR segments for all Means Test dependents
"RTN","IVMPTRN8",183,0)
 F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",184,0)
 . ;
"RTN","IVMPTRN8",185,0)
 . ; - create (ZDP) Dependent Info. segment for dependent child
"RTN","IVMPTRN8",186,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",187,0)
 . I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",188,0)
 . . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",189,0)
 . . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",190,0)
 . ;
"RTN","IVMPTRN8",191,0)
 . ; - create (ZIC) Income segment for dependent child
"RTN","IVMPTRN8",192,0)
 . S IVMCT=IVMCT+1
"RTN","IVMPTRN8",193,0)
 . ;IVM*2.0*115
"RTN","IVMPTRN8",194,0)
 . I MTVERS=0 D  I 1
"RTN","IVMPTRN8",195,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",196,0)
 . E  D
"RTN","IVMPTRN8",197,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,9,12,15,16,18,19")
"RTN","IVMPTRN8",198,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",199,0)
 . ;
"RTN","IVMPTRN8",200,0)
 . ; - create (ZIR) Income Relation segment for dependent child
"RTN","IVMPTRN8",201,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",202,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",203,0)
 . ;
"RTN","IVMPTRN8",204,0)
 ; Send INACTIVE spouse/dependents.
"RTN","IVMPTRN8",205,0)
 D GETINACD^DGMTU11(DFN,.DGREL)
"RTN","IVMPTRN8",206,0)
 F I="S","C" D
"RTN","IVMPTRN8",207,0)
 . F IVMSUB=0:0 S IVMSUB=$O(DGIREL(I,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",208,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",209,0)
 ;
"RTN","IVMPTRN8",210,0)
 D GOTO^IVMPTRN9
"RTN","IVMPTRN8",211,0)
 Q
"RTN","IVMPTRN8",212,0)
 ;
"RTN","IVMPTRN8",213,0)
STRIP11 N APID,ZPID,ASQ,ATYP,SSQ
"RTN","IVMPTRN8",214,0)
 ;Extract PID segment
"RTN","IVMPTRN8",215,0)
 S IVMPID(1)=$E(IVMPID(1),5,$L(IVMPID(1)))
"RTN","IVMPTRN8",216,0)
 D BLDPID^IVMPREC6(.IVMPID,.APID)
"RTN","IVMPTRN8",217,0)
 ;
"RTN","IVMPTRN8",218,0)
 S CAFLG=0
"RTN","IVMPTRN8",219,0)
 I $D(APID(11)) D
"RTN","IVMPTRN8",220,0)
 .I $O(APID(11,"")) D  Q
"RTN","IVMPTRN8",221,0)
 ..M ZPID(11)=APID(11) K APID(11)
"RTN","IVMPTRN8",222,0)
 ..S (ASQ,SSQ)=0 F  S ASQ=$O(ZPID(11,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",223,0)
 ...S ATYP=$P($G(ZPID(11,ASQ)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",224,0)
 ...I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") Q
"RTN","IVMPTRN8",225,0)
 ...I ATYP="VACAE" S CAFLG=1
"RTN","IVMPTRN8",226,0)
 ...S SSQ=SSQ+1,APID(11,SSQ)=ZPID(11,ASQ)
"RTN","IVMPTRN8",227,0)
 .Q:$G(APID(11))=""
"RTN","IVMPTRN8",228,0)
 .S ATYP=$P($G(APID(11)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",229,0)
 .I ATYP="VACAE" S CAFLG=1 Q
"RTN","IVMPTRN8",230,0)
 .I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") K APID(11)
"RTN","IVMPTRN8",231,0)
 ;
"RTN","IVMPTRN8",232,0)
 I 'CAFLG,$D(APID(13)) D
"RTN","IVMPTRN8",233,0)
 .I $O(APID(13,"")) D  Q
"RTN","IVMPTRN8",234,0)
 ..S ASQ=0 F  S ASQ=$O(APID(13,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",235,0)
 ...Q:$G(APID(13,ASQ))=""
"RTN","IVMPTRN8",236,0)
 ...S ATYP=$P($G(APID(13,ASQ)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",237,0)
 ...I ATYP="VACPN" K APID(13,ASQ) Q
"RTN","IVMPTRN8",238,0)
 .Q:$G(APID(13))=""
"RTN","IVMPTRN8",239,0)
 .S ATYP=$P($G(APID(13)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",240,0)
 .I ATYP="VACPN" K APID(13) Q
"RTN","IVMPTRN8",241,0)
 ;
"RTN","IVMPTRN8",242,0)
 ;Rebuild PID
"RTN","IVMPTRN8",243,0)
 D KVA^VADPT
"RTN","IVMPTRN8",244,0)
 D MAKEIT^VAFHLU("PID",.APID,.VAFPID,.VAFPID)
"RTN","IVMPTRN8",245,0)
 S VAFPID(0)=VAFPID
"RTN","IVMPTRN8",246,0)
 Q
"VER")
8.0^22.0
**END**
**END**