DG_53_P797.KID

KIDS Distribution saved on Feb 06, 2012@10:55:54
MILITARY SERVICE DATA SHARING (2/6/12)
**KIDS**:DG*5.3*797^EAS*1.0*92^IVM*2.0*141^DVB*4.0*62^PXRM*2.0*21^

**INSTALL NAME**
DG*5.3*797
"BLD",8578,0)
DG*5.3*797^REGISTRATION^0^3120206^y
"BLD",8578,1,0)
^^1^1^3101026^^
"BLD",8578,1,1,0)
Military Service Data Sharing (MSDS) project
"BLD",8578,4,0)
^9.64PA^25^3
"BLD",8578,4,2,0)
2
"BLD",8578,4,2,2,0)
^9.641^2.3215^3
"BLD",8578,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",8578,4,2,2,2,1,0)
^9.6411^.327^1
"BLD",8578,4,2,2,2,1,.327,0)
SERVICE SEPARATION DATE [LAST]
"BLD",8578,4,2,2,2.3215,0)
SERVICE [OEF OR OIF]  (sub-file)
"BLD",8578,4,2,2,2.3215,1,0)
^9.6411^.03^1
"BLD",8578,4,2,2,2.3215,1,.03,0)
OEF/OIF TO DATE
"BLD",8578,4,2,2,2.3216,0)
MILITARY SERVICE EPISODE  (sub-file)
"BLD",8578,4,2,2,2.3216,1,0)
^9.6411^^
"BLD",8578,4,2,222)
y^y^p^^^^n^^n
"BLD",8578,4,2,224)

"BLD",8578,4,25,0)
25
"BLD",8578,4,25,222)
y^y^f^^n^^y^r^n
"BLD",8578,4,391.23,0)
391.23
"BLD",8578,4,391.23,222)
y^y^f^^n^^y^o^n
"BLD",8578,4,"APDD",2,2)

"BLD",8578,4,"APDD",2,2,.327)

"BLD",8578,4,"APDD",2,2.3215)

"BLD",8578,4,"APDD",2,2.3215,.03)

"BLD",8578,4,"APDD",2,2.3216)

"BLD",8578,4,"B",2,2)

"BLD",8578,4,"B",25,25)

"BLD",8578,4,"B",391.23,391.23)

"BLD",8578,6.3)
24
"BLD",8578,"ABPKG")
n
"BLD",8578,"KRN",0)
^9.67PA^8989.52^19
"BLD",8578,"KRN",.4,0)
.4
"BLD",8578,"KRN",.4,"NM",0)
^9.68A^^
"BLD",8578,"KRN",.401,0)
.401
"BLD",8578,"KRN",.402,0)
.402
"BLD",8578,"KRN",.402,"NM",0)
^9.68A^^0
"BLD",8578,"KRN",.403,0)
.403
"BLD",8578,"KRN",.5,0)
.5
"BLD",8578,"KRN",.84,0)
.84
"BLD",8578,"KRN",3.6,0)
3.6
"BLD",8578,"KRN",3.8,0)
3.8
"BLD",8578,"KRN",9.2,0)
9.2
"BLD",8578,"KRN",9.8,0)
9.8
"BLD",8578,"KRN",9.8,"NM",0)
^9.68A^34^34
"BLD",8578,"KRN",9.8,"NM",1,0)
VAFHLZMH^^0^B30066508
"BLD",8578,"KRN",9.8,"NM",2,0)
VAFHLZM1^^0^B67564189
"BLD",8578,"KRN",9.8,"NM",3,0)
VAFHLZM2^^0^B10489371
"BLD",8578,"KRN",9.8,"NM",4,0)
DGMSE^^0^B7269534
"BLD",8578,"KRN",9.8,"NM",5,0)
VADPT4^^0^B42853987
"BLD",8578,"KRN",9.8,"NM",6,0)
DGLOCK^^0^B53456898
"BLD",8578,"KRN",9.8,"NM",7,0)
DGRPMS^^0^B64725384
"BLD",8578,"KRN",9.8,"NM",8,0)
DGRPDT^^0^B77027156
"BLD",8578,"KRN",9.8,"NM",9,0)
DGRPDD1^^0^B31264129
"BLD",8578,"KRN",9.8,"NM",10,0)
DGRP6^^0^B15573608
"BLD",8578,"KRN",9.8,"NM",11,0)
DGRP61^^0^B46948072
"BLD",8578,"KRN",9.8,"NM",12,0)
DGRP62^^0^B4564085
"BLD",8578,"KRN",9.8,"NM",13,0)
DGRPE^^0^B52635716
"BLD",8578,"KRN",9.8,"NM",14,0)
DGRPV^^0^B18200549
"BLD",8578,"KRN",9.8,"NM",15,0)
DGMSEUTL^^0^B16538229
"BLD",8578,"KRN",9.8,"NM",16,0)
DGRPP^^0^B19131336
"BLD",8578,"KRN",9.8,"NM",17,0)
DGCV^^0^B53926779
"BLD",8578,"KRN",9.8,"NM",18,0)
DGRP6CL^^0^B70196214
"BLD",8578,"KRN",9.8,"NM",19,0)
DGRODEBR^^0^B55430347
"BLD",8578,"KRN",9.8,"NM",20,0)
DGROHLU^^0^B27082369
"BLD",8578,"KRN",9.8,"NM",21,0)
DGROHLR^^0^B18624727
"BLD",8578,"KRN",9.8,"NM",22,0)
DGROHLR1^^0^B54801555
"BLD",8578,"KRN",9.8,"NM",23,0)
DGMSCK^^0^B10563594
"BLD",8578,"KRN",9.8,"NM",24,0)
DGRPC3^^0^B40710915
"BLD",8578,"KRN",9.8,"NM",25,0)
DGRPC^^0^B28027409
"BLD",8578,"KRN",9.8,"NM",26,0)
DGRPC2^^0^B70981451
"BLD",8578,"KRN",9.8,"NM",27,0)
DGRPCE^^0^B37126023
"BLD",8578,"KRN",9.8,"NM",28,0)
DGRPCE1^^0^B64356482
"BLD",8578,"KRN",9.8,"NM",29,0)
DGENUPL3^^0^B71805311
"BLD",8578,"KRN",9.8,"NM",30,0)
DGENUPL7^^0^B33592868
"BLD",8578,"KRN",9.8,"NM",31,0)
DGENUPL1^^0^B36548434
"BLD",8578,"KRN",9.8,"NM",32,0)
DGCVRPT^^0^B27927471
"BLD",8578,"KRN",9.8,"NM",33,0)
DGREGG^^0^B3973658
"BLD",8578,"KRN",9.8,"NM",34,0)
VAFCPDT2^^0^B26407080
"BLD",8578,"KRN",9.8,"NM","B","DGCV",17)

"BLD",8578,"KRN",9.8,"NM","B","DGCVRPT",32)

"BLD",8578,"KRN",9.8,"NM","B","DGENUPL1",31)

"BLD",8578,"KRN",9.8,"NM","B","DGENUPL3",29)

"BLD",8578,"KRN",9.8,"NM","B","DGENUPL7",30)

"BLD",8578,"KRN",9.8,"NM","B","DGLOCK",6)

"BLD",8578,"KRN",9.8,"NM","B","DGMSCK",23)

"BLD",8578,"KRN",9.8,"NM","B","DGMSE",4)

"BLD",8578,"KRN",9.8,"NM","B","DGMSEUTL",15)

"BLD",8578,"KRN",9.8,"NM","B","DGREGG",33)

"BLD",8578,"KRN",9.8,"NM","B","DGRODEBR",19)

"BLD",8578,"KRN",9.8,"NM","B","DGROHLR",21)

"BLD",8578,"KRN",9.8,"NM","B","DGROHLR1",22)

"BLD",8578,"KRN",9.8,"NM","B","DGROHLU",20)

"BLD",8578,"KRN",9.8,"NM","B","DGRP6",10)

"BLD",8578,"KRN",9.8,"NM","B","DGRP61",11)

"BLD",8578,"KRN",9.8,"NM","B","DGRP62",12)

"BLD",8578,"KRN",9.8,"NM","B","DGRP6CL",18)

"BLD",8578,"KRN",9.8,"NM","B","DGRPC",25)

"BLD",8578,"KRN",9.8,"NM","B","DGRPC2",26)

"BLD",8578,"KRN",9.8,"NM","B","DGRPC3",24)

"BLD",8578,"KRN",9.8,"NM","B","DGRPCE",27)

"BLD",8578,"KRN",9.8,"NM","B","DGRPCE1",28)

"BLD",8578,"KRN",9.8,"NM","B","DGRPDD1",9)

"BLD",8578,"KRN",9.8,"NM","B","DGRPDT",8)

"BLD",8578,"KRN",9.8,"NM","B","DGRPE",13)

"BLD",8578,"KRN",9.8,"NM","B","DGRPMS",7)

"BLD",8578,"KRN",9.8,"NM","B","DGRPP",16)

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

"BLD",8578,"KRN",9.8,"NM","B","VADPT4",5)

"BLD",8578,"KRN",9.8,"NM","B","VAFCPDT2",34)

"BLD",8578,"KRN",9.8,"NM","B","VAFHLZM1",2)

"BLD",8578,"KRN",9.8,"NM","B","VAFHLZM2",3)

"BLD",8578,"KRN",9.8,"NM","B","VAFHLZMH",1)

"BLD",8578,"KRN",19,0)
19
"BLD",8578,"KRN",19,"NM",0)
^9.68A^^
"BLD",8578,"KRN",19.1,0)
19.1
"BLD",8578,"KRN",19.1,"NM",0)
^9.68A^^
"BLD",8578,"KRN",101,0)
101
"BLD",8578,"KRN",101,"NM",0)
^9.68A^5^5
"BLD",8578,"KRN",101,"NM",1,0)
DGEN MSDS ADD^^0
"BLD",8578,"KRN",101,"NM",2,0)
DGEN MSDS DELETE^^0
"BLD",8578,"KRN",101,"NM",3,0)
DGEN MSDS EDIT^^0
"BLD",8578,"KRN",101,"NM",4,0)
DGEN MSDS MENU^^0
"BLD",8578,"KRN",101,"NM",5,0)
DGEN MSDS VIEW HISTORY^^0
"BLD",8578,"KRN",101,"NM","B","DGEN MSDS ADD",1)

"BLD",8578,"KRN",101,"NM","B","DGEN MSDS DELETE",2)

"BLD",8578,"KRN",101,"NM","B","DGEN MSDS EDIT",3)

"BLD",8578,"KRN",101,"NM","B","DGEN MSDS MENU",4)

"BLD",8578,"KRN",101,"NM","B","DGEN MSDS VIEW HISTORY",5)

"BLD",8578,"KRN",409.61,0)
409.61
"BLD",8578,"KRN",409.61,"NM",0)
^9.68A^2^2
"BLD",8578,"KRN",409.61,"NM",1,0)
DGEN MSDS PATIENT^^0
"BLD",8578,"KRN",409.61,"NM",2,0)
DGEN MSDS PATIENT VIEW^^0
"BLD",8578,"KRN",409.61,"NM","B","DGEN MSDS PATIENT",1)

"BLD",8578,"KRN",409.61,"NM","B","DGEN MSDS PATIENT VIEW",2)

"BLD",8578,"KRN",771,0)
771
"BLD",8578,"KRN",870,0)
870
"BLD",8578,"KRN",8989.51,0)
8989.51
"BLD",8578,"KRN",8989.52,0)
8989.52
"BLD",8578,"KRN",8994,0)
8994
"BLD",8578,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",8578,"KRN","B",3.6,3.6)

"BLD",8578,"KRN","B",3.8,3.8)

"BLD",8578,"KRN","B",9.2,9.2)

"BLD",8578,"KRN","B",9.8,9.8)

"BLD",8578,"KRN","B",19,19)

"BLD",8578,"KRN","B",19.1,19.1)

"BLD",8578,"KRN","B",101,101)

"BLD",8578,"KRN","B",409.61,409.61)

"BLD",8578,"KRN","B",771,771)

"BLD",8578,"KRN","B",870,870)

"BLD",8578,"KRN","B",8989.51,8989.51)

"BLD",8578,"KRN","B",8989.52,8989.52)

"BLD",8578,"KRN","B",8994,8994)

"BLD",8578,"QUES",0)
^9.62^^
"BLD",8578,"REQB",0)
^9.611^13^10
"BLD",8578,"REQB",3,0)
DG*5.3*792^2
"BLD",8578,"REQB",4,0)
DG*5.3*793^2
"BLD",8578,"REQB",5,0)
DG*5.3*754^2
"BLD",8578,"REQB",6,0)
DG*5.3*565^2
"BLD",8578,"REQB",8,0)
DG*5.3*764^2
"BLD",8578,"REQB",9,0)
DG*5.3*780^2
"BLD",8578,"REQB",10,0)
DG*5.3*790^2
"BLD",8578,"REQB",11,0)
DG*5.3*828^2
"BLD",8578,"REQB",12,0)
DG*5.3*697^2
"BLD",8578,"REQB",13,0)
DG*5.3*621^2
"BLD",8578,"REQB","B","DG*5.3*565",6)

"BLD",8578,"REQB","B","DG*5.3*621",13)

"BLD",8578,"REQB","B","DG*5.3*697",12)

"BLD",8578,"REQB","B","DG*5.3*754",5)

"BLD",8578,"REQB","B","DG*5.3*764",8)

"BLD",8578,"REQB","B","DG*5.3*780",9)

"BLD",8578,"REQB","B","DG*5.3*790",10)

"BLD",8578,"REQB","B","DG*5.3*792",3)

"BLD",8578,"REQB","B","DG*5.3*793",4)

"BLD",8578,"REQB","B","DG*5.3*828",11)

"DATA",25,1,0)
HONORABLE
"DATA",25,2,0)
DISHONORABLE
"DATA",25,3,0)
GENERAL
"DATA",25,4,0)
OTHER THAN HONORABLE
"DATA",25,5,0)
UNDESIRABLE
"DATA",25,6,0)
BAD CONDUCT
"DATA",25,8,0)
DISHONORABLE-VA
"DATA",25,9,0)
HONORABLE-VA
"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,198,0)
MSDS SERVICE ENTRY DATE^2.3216^.01^MSDS SERVICE SEPARATION DATE^^I
"DATA",391.23,199,0)
MSDS SERVICE SEPARATION DATE^2.3216^.02^MSDS SERVICE SEPARATION DATE^^I
"DATA",391.23,200,0)
MSDS SERVICE BRANCH^2.3216^.03^MSDS SERVICE BRANCH^^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,210,0)
MSDS SERVICE COMPONENT^2.3216^.04^MSDS SERVICE COMPONENT^^I
"DATA",391.23,211,0)
MSDS SERVICE NUMBER^2.3216^.05^MSDS SERVICE NUMBER^^I
"DATA",391.23,212,0)
MSDS SERVICE DISCHARGE^2.3216^.06^MSDS SERVICE DISCHARGE^^I
"DATA",391.23,213,0)
MSDS DATA LOCKED^2.3216^.07^MSDS DATA LOCKED^^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,.3216)

"FIA",2,2,.327)

"FIA",2,2.3215)
1
"FIA",2,2.3215,.03)

"FIA",2,2.3216)
0
"FIA",25)
TYPE OF DISCHARGE
"FIA",25,0)
^DIC(25,
"FIA",25,0,0)
25
"FIA",25,0,1)
y^y^f^^n^^y^r^n
"FIA",25,0,10)

"FIA",25,0,11)

"FIA",25,0,"RLRO")

"FIA",25,0,"VR")
5.3^DG
"FIA",25,25)
0
"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^o^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
"IX",2,2,"ACVCOM",0)
2^ACVCOM^Update Combat Vet Eligibility End Date^MU^^R^^I^2^^^^^A
"IX",2,2,"ACVCOM",.1,0)
^^11^11^3030613^
"IX",2,2,"ACVCOM",.1,1,0)
This multi-level MUMPS x-ref will trigger an update to the Combat Vet 
"IX",2,2,"ACVCOM",.1,2,0)
Eligibility End Date field under the following conditions:
"IX",2,2,"ACVCOM",.1,3,0)
  1) Service Separation Date [Last] is precise and > 2981111 AND EITHER
"IX",2,2,"ACVCOM",.1,4,0)
  2) Combat To Date is after 11/11/98 OR
"IX",2,2,"ACVCOM",.1,5,0)
     Persian Gulf To Date is after 11/11/98 OR
"IX",2,2,"ACVCOM",.1,6,0)
     Somalia To Date is after 11/11/98 OR
"IX",2,2,"ACVCOM",.1,7,0)
     Yugoslavia To Date is after 11/11/98
"IX",2,2,"ACVCOM",.1,8,0)
 
"IX",2,2,"ACVCOM",.1,9,0)
The Combat vet field will be set to the Service Separation Date + 2 
"IX",2,2,"ACVCOM",.1,10,0)
years, and will only be updated if information in these fields has 
"IX",2,2,"ACVCOM",.1,11,0)
changed.
"IX",2,2,"ACVCOM",1)
N DGZ S DGZ=$S(X2(10):X2(10),1:X2(1)) D SETCV^DGCV(DA,DGZ)
"IX",2,2,"ACVCOM",1.4)
I '$P($G(^DPT(DA,.52)),"^",15) S X=$$CVELIG^DGCV(DA)
"IX",2,2,"ACVCOM",2)
Q
"IX",2,2,"ACVCOM",2.4)
Q
"IX",2,2,"ACVCOM",11.1,0)
^.114IA^10^10
"IX",2,2,"ACVCOM",11.1,1,0)
1^F^2^.327^^^F
"IX",2,2,"ACVCOM",11.1,2,0)
2^F^2^.5294^^^F
"IX",2,2,"ACVCOM",11.1,3,0)
3^F^2^.322021^^^F
"IX",2,2,"ACVCOM",11.1,4,0)
4^F^2^.322018^^^F
"IX",2,2,"ACVCOM",11.1,5,0)
5^F^2^.322012^^^F
"IX",2,2,"ACVCOM",11.1,6,0)
6^F^2^.5291^^^F
"IX",2,2,"ACVCOM",11.1,7,0)
7^F^2^.322019^^^F
"IX",2,2,"ACVCOM",11.1,8,0)
8^F^2^.322016^^^F
"IX",2,2,"ACVCOM",11.1,9,0)
9^F^2^.32201^^^F
"IX",2,2,"ACVCOM",11.1,10,0)
10^C
"IX",2,2,"ACVCOM",11.1,10,1.5)
S X=$P($$LAST^DGMSEUTL(DA),U,2)
"IX",2,2,"ACVCOM2",0)
2^ACVCOM2^Update Combat Veteran End Date^MU^^F^IR^W^2.3216^^^^^A
"IX",2,2,"ACVCOM2",.1,0)
^^3^3^3090811^^
"IX",2,2,"ACVCOM2",.1,1,0)
This MUMPS cross reference will trigger an update to the Combat Veteran
"IX",2,2,"ACVCOM2",.1,2,0)
End Date field #.5295 if the Service Separation Date for the
"IX",2,2,"ACVCOM2",.1,3,0)
last (most recent) military service episode is entered.
"IX",2,2,"ACVCOM2",1)
D SETCV^DGCV(DA(1),X2(2))
"IX",2,2,"ACVCOM2",1.4)
I '$P($G(^DPT(DA(1),.52)),U,15) S X=$$CVELIG^DGCV(DA(1))
"IX",2,2,"ACVCOM2",2)
Q
"IX",2,2,"ACVCOM2",11.1,0)
^.114IA^2^2
"IX",2,2,"ACVCOM2",11.1,1,0)
1^F^2.3216^.02^^^F
"IX",2,2,"ACVCOM2",11.1,2,0)
2^C
"IX",2,2,"ACVCOM2",11.1,2,1.5)
S X=$P($$LAST^DGMSEUTL(DA(1)),U,2)
"IX",2,2,"ASERLAST",0)
2^ASERLAST^Index LAST ENTRY and SEPARATION dates^MU^^R^R^I^2^^^^^A
"IX",2,2,"ASERLAST",.1,0)
^^5^5^3060323
"IX",2,2,"ASERLAST",.1,1,0)
This cross-reference indexes the LAST ENTRY and SEPARATION dates.
"IX",2,2,"ASERLAST",.1,2,0)
The form of the index is:
"IX",2,2,"ASERLAST",.1,3,0)
  ^DPT("ASERVICE",SEPARATION DATE,ENTRY DATE,DA,"LAST")
"IX",2,2,"ASERLAST",.1,4,0)

"IX",2,2,"ASERLAST",.1,5,0)
If one of the dates is missing the corresponding subscript is replaced by U_DA.
"IX",2,2,"ASERLAST",1)
D SSERV^DGSRVICE(.X,.DA,"LAST")
"IX",2,2,"ASERLAST",2)
D KSERV^DGSRVICE(.X,.DA,"LAST")
"IX",2,2,"ASERLAST",2.5)
K ^DPT("ASERVICE")
"IX",2,2,"ASERLAST",11.1,0)
^.114IA^2^2
"IX",2,2,"ASERLAST",11.1,1,0)
1^F^2^.326
"IX",2,2,"ASERLAST",11.1,2,0)
2^F^2^.327
"IX",2,2.3215,"ACVCOM1",0)
2.3215^ACVCOM1^Set CV End Date based on OEF/OIF fields^MU^^F^^I^2.3215^^^^^A
"IX",2,2.3215,"ACVCOM1",.1,0)
^^8^8^3061010^^^^
"IX",2,2.3215,"ACVCOM1",.1,1,0)
This MUMPS x-ref will trigger an update to the Combat Vet Eligibility End
"IX",2,2.3215,"ACVCOM1",.1,2,0)
Date field under the following conditions:
"IX",2,2.3215,"ACVCOM1",.1,3,0)
  If the COMBAT VETERAN END DATE (#.5295) of the PATIENT file (#2) is null
"IX",2,2.3215,"ACVCOM1",.1,4,0)
 AND either
"IX",2,2.3215,"ACVCOM1",.1,5,0)
        The SERVICE SEPARATION DATE [LAST] (#.327) is missing
"IX",2,2.3215,"ACVCOM1",.1,6,0)
                          OR
"IX",2,2.3215,"ACVCOM1",.1,7,0)
        The SERVICE SEPARATION DATE [LAST] (#.327) is less than the
"IX",2,2.3215,"ACVCOM1",.1,8,0)
           OEF/OIF TO DATE - #.03 in subfile 2.3215
"IX",2,2.3215,"ACVCOM1",1)
N DGZ S DGZ=$S(X2(3)'<X2(2):X2(3),1:X2(2)) D SETCV^DGCV(DA(1),DGZ)
"IX",2,2.3215,"ACVCOM1",1.4)
I '$P($G(^DPT(DA(1),.52)),"^",15) S X=$$CVELIG^DGCV(DA(1))
"IX",2,2.3215,"ACVCOM1",2)
Q
"IX",2,2.3215,"ACVCOM1",11.1,0)
^.114IA^3^3
"IX",2,2.3215,"ACVCOM1",11.1,1,0)
1^F^2.3215^.03^^^F
"IX",2,2.3215,"ACVCOM1",11.1,2,0)
2^C
"IX",2,2.3215,"ACVCOM1",11.1,2,1.5)
S X=$P($$LAST^DGENOEIF(DA(1)),U)
"IX",2,2.3215,"ACVCOM1",11.1,3,0)
3^C
"IX",2,2.3215,"ACVCOM1",11.1,3,1.5)
S X=$S($D(^DPT(DA(1),.3216)):$P($$LAST^DGMSEUTL(DA(1)),U,2),1:$P($G(^DPT(DA(1),.32)),U,7))
"IX",2,2.3215,"ALOEIF",0)
2.3215^ALOEIF^Sets the latest OIF/ OEF/ UNKNOWN OEF/OIF episode in a cross reference^MU^^R^IR^I^2.3215^^^^^A
"IX",2,2.3215,"ALOEIF",.1,0)
^^10^10^3060105^^^^
"IX",2,2.3215,"ALOEIF",.1,1,0)
Cross reference is:
"IX",2,2.3215,"ALOEIF",.1,2,0)
  ^DPT("ALOEIF",TO DATE,FROM DATE,OIF/ OEF/ UNKNOWN OEF/OIF indicator,
"IX",2,2.3215,"ALOEIF",.1,3,0)
                DA(1),DA)=""
"IX",2,2.3215,"ALOEIF",.1,4,0)
 
"IX",2,2.3215,"ALOEIF",.1,5,0)
Subscripts are:
"IX",2,2.3215,"ALOEIF",.1,6,0)
  TO DATE = latest conflict to date for OIF/ OEF/ UNKNOWN OEF/OIF
"IX",2,2.3215,"ALOEIF",.1,7,0)
  FROM DATE = corresponding from date for TO DATE value
"IX",2,2.3215,"ALOEIF",.1,8,0)
  OIF/ OEF/ UNKNOWN OEF/OIF indicator = "OIF" "OEF" "UNK"
"IX",2,2.3215,"ALOEIF",.1,9,0)
 
"IX",2,2.3215,"ALOEIF",.1,10,0)
 DA(1) = entry in patient file      DA = entry in OEF/OIF subfile
"IX",2,2.3215,"ALOEIF",1)
D UPDLAST^DGENOEIF(.DA,.X2,1)
"IX",2,2.3215,"ALOEIF",2)
D UPDLAST^DGENOEIF(.DA,.X1,0)
"IX",2,2.3215,"ALOEIF",2.5)

"IX",2,2.3215,"ALOEIF",11.1,0)
^.114IA^4^3
"IX",2,2.3215,"ALOEIF",11.1,2,0)
1^F^2.3215^.03^^^F
"IX",2,2.3215,"ALOEIF",11.1,2,3)

"IX",2,2.3215,"ALOEIF",11.1,3,0)
3^F^2.3215^.02^^^F
"IX",2,2.3215,"ALOEIF",11.1,4,0)
2^F^2.3215^.01^^^F
"IX",2,2.3215,"ALSTUP",0)
2.3215^ALSTUP^TRIGGER THE DATE/TIME OF LAST CHANGE WHEN ANY PERTINENT FIELDS CHANGE^MU^^R^IR^I^2.3215^^^^^A
"IX",2,2.3215,"ALSTUP",1)
N DATA,DGENDA S DATA(.05)=$$NOW^XLFDT,DGENDA=DA,DGENDA(1)=DA(1) I $$UPD^DGENDBS(2.3215,.DGENDA,.DATA)
"IX",2,2.3215,"ALSTUP",1.4)
S X=$S($G(X2(1))'=""&($G(X1(1))'=$G(X2(1))):1,$G(X1(2))'=$G(X2(2)):1,$G(X1(3))'=$G(X2(3)):1,1:0)
"IX",2,2.3215,"ALSTUP",2)
N DATA,DGENDA S DATA(.05)=$$NOW^XLFDT,DGENDA=DA,DGENDA(1)=DA(1) I $$UPD^DGENDBS(2.3215,.DGENDA,.DATA)
"IX",2,2.3215,"ALSTUP",11.1,0)
^.114IA^3^3
"IX",2,2.3215,"ALSTUP",11.1,1,0)
1^F^2.3215^.01^^^F
"IX",2,2.3215,"ALSTUP",11.1,2,0)
2^F^2.3215^.02^^^F
"IX",2,2.3215,"ALSTUP",11.1,3,0)
3^F^2.3215^.03^^^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
"KRN",101,4395,-1)
0^4
"KRN",101,4395,0)
DGEN MSDS MENU^Patient MSDS Menu^^M^^^^^^^^REGISTRATION
"KRN",101,4395,1,0)
^101.06^2^2^3081230^^
"KRN",101,4395,1,1,0)
This protocol menu contains all the activities for patient MSDS data 
"KRN",101,4395,1,2,0)
display and edit.
"KRN",101,4395,4)
25^4
"KRN",101,4395,10,0)
^101.01PA^4^4
"KRN",101,4395,10,1,0)
4396^AD^10^
"KRN",101,4395,10,1,"^")
DGEN MSDS ADD
"KRN",101,4395,10,2,0)
4398^ED^20^
"KRN",101,4395,10,2,"^")
DGEN MSDS EDIT
"KRN",101,4395,10,3,0)
4397^DE^30^
"KRN",101,4395,10,3,"^")
DGEN MSDS DELETE
"KRN",101,4395,10,4,0)
4399^VH^40^
"KRN",101,4395,10,4,"^")
DGEN MSDS VIEW HISTORY
"KRN",101,4395,15)
D PEXIT^DGRP61
"KRN",101,4395,26)
D SHOW^VALM
"KRN",101,4395,28)
Select Action:
"KRN",101,4395,99)
62297,67091
"KRN",101,4396,-1)
0^1
"KRN",101,4396,0)
DGEN MSDS ADD^Add^^A^^^^^^^^REGISTRATION
"KRN",101,4396,1,0)
^101.06^1^1^3081229^^
"KRN",101,4396,1,1,0)
This protocol action allows a user to add a new military service episode.
"KRN",101,4396,4)
^^^
"KRN",101,4396,20)
D ACT^DGRP61("A")
"KRN",101,4396,99)
62297,67091
"KRN",101,4397,-1)
0^2
"KRN",101,4397,0)
DGEN MSDS DELETE^Delete^^A^^^^^^^^REGISTRATION
"KRN",101,4397,1,0)
^^4^4^3081229^
"KRN",101,4397,1,1,0)
This protocol action allows a user to delete a military service episode 
"KRN",101,4397,1,2,0)
which has been previously added through the AD - Add option. Military
"KRN",101,4397,1,3,0)
service episodes downloaded from ESR are authoritative and may not be 
"KRN",101,4397,1,4,0)
edited or deleted.
"KRN",101,4397,4)
^^^
"KRN",101,4397,20)
D ACT^DGRP61("D")
"KRN",101,4397,99)
62297,67091
"KRN",101,4398,-1)
0^3
"KRN",101,4398,0)
DGEN MSDS EDIT^Edit^^A^^^^^^^^REGISTRATION
"KRN",101,4398,1,0)
^101.06^4^4^3090317^^
"KRN",101,4398,1,1,0)
This protocol action allows a user to edit a military service episode 
"KRN",101,4398,1,2,0)
which has been previously added through the AD - Add option. Military
"KRN",101,4398,1,3,0)
service episodes downloaded from ESR are authoritative and may not be
"KRN",101,4398,1,4,0)
edited or deleted.
"KRN",101,4398,4)
^^^
"KRN",101,4398,20)
D ACT^DGRP61("E")
"KRN",101,4398,24)

"KRN",101,4398,99)
62297,67091
"KRN",101,4399,-1)
0^5
"KRN",101,4399,0)
DGEN MSDS VIEW HISTORY^View History^^A^^^^^^^^REGISTRATION
"KRN",101,4399,1,0)
^101.06^6^6^3090317^^
"KRN",101,4399,1,1,0)
This protocol action allows the user to view the military service 
"KRN",101,4399,1,2,0)
episodes which were entered into the VistA system before ESR became 
"KRN",101,4399,1,3,0)
the authoritative source for military service data was received from ESR.
"KRN",101,4399,1,4,0)
 
"KRN",101,4399,1,5,0)
This screen is display only. The old VistA military service episode data
"KRN",101,4399,1,6,0)
is no longer used and cannot be changed.
"KRN",101,4399,4)
^^^
"KRN",101,4399,20)
D EN^DGRP62(DFN)
"KRN",101,4399,99)
62297,67091
"KRN",409.61,693,-1)
0^1
"KRN",409.61,693,0)
DGEN MSDS PATIENT^1^^80^6^12^1^1^^DGEN MSDS MENU^Military Service^1^^1
"KRN",409.61,693,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,693,"ARRAY")
 ^TMP("DGRP61",$J)
"KRN",409.61,693,"FNL")
D EXIT^DGRP61
"KRN",409.61,693,"HDR")
D HDR^DGRP61
"KRN",409.61,693,"HLP")
D HELP^DGRP61
"KRN",409.61,693,"INIT")
D INIT^DGRP61
"KRN",409.61,694,-1)
0^2
"KRN",409.61,694,0)
DGEN MSDS PATIENT VIEW^2^^80^6^19^1^1^^^Military History View^1^^1
"KRN",409.61,694,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,694,"ARRAY")
 ^TMP("DGRP62",$J)
"KRN",409.61,694,"FNL")
D EXIT^DGRP62
"KRN",409.61,694,"HDR")
D HDR^DGRP62
"KRN",409.61,694,"HLP")
D HELP^DGRP62
"KRN",409.61,694,"INIT")
D INIT^DGRP62
"MBREQ")
0
"ORD",15,101)
101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA
"ORD",15,101,0)
PROTOCOL
"ORD",17,409.61)
409.61;17;1;;;;LME1^XPDIA1;;;LMDEL^XPDIA1
"ORD",17,409.61,0)
LIST TEMPLATE
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
797^3120206^123457000
"PKG",47,22,1,"PAH",1,1,0)
^^1^1^3120206
"PKG",47,22,1,"PAH",1,1,1,0)
Military Service Data Sharing (MSDS) project
"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")
34
"RTN","DGCV")
0^17^B53926779
"RTN","DGCV",1,0)
DGCV ;ALB/DW,ERC,BRM,TMK,LBD - COMBAT VET ELIGIBILTY; 10/15/05 ; 6/16/09 10:40am
"RTN","DGCV",2,0)
 ;;5.3;Registration;**528,576,564,673,778,792,797**; Aug 13, 1993;Build 24
"RTN","DGCV",3,0)
 ;
"RTN","DGCV",4,0)
CVELIG(DFN) ;
"RTN","DGCV",5,0)
 ;API will determine whether or not this veteran needs to have CV End
"RTN","DGCV",6,0)
 ;Date set.  If this determination cannot be done due to imprecise
"RTN","DGCV",7,0)
 ;or missing dates, it returns which dates need editing.
"RTN","DGCV",8,0)
 ;Input:
"RTN","DGCV",9,0)
 ;  DFN - Patient file IEN
"RTN","DGCV",10,0)
 ;Output
"RTN","DGCV",11,0)
 ;  RESULT
"RTN","DGCV",12,0)
 ;    0 - CV End Date should not be set
"RTN","DGCV",13,0)
 ;    1 - CV End Date should be set
"RTN","DGCV",14,0)
 ;  If critical dates are imprecise return the following
"RTN","DGCV",15,0)
 ;    A - CV End Date should not be set, imprecise Service Sep date
"RTN","DGCV",16,0)
 ;    B - CV End Date should not be set, imprecise Combat To date
"RTN","DGCV",17,0)
 ;    C - CV End Date should not be set, imprecise Yugoslavia To date
"RTN","DGCV",18,0)
 ;    D - CV End Date should not be set, imprecise Somalia To date
"RTN","DGCV",19,0)
 ;    E - CV End Date should not be set, imprecise Pers Gulf To date
"RTN","DGCV",20,0)
 ;  If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
"RTN","DGCV",21,0)
 ;    OEF/OIF records on file, return the following so that it  will
"RTN","DGCV",22,0)
 ;    appear on the Imprecise/Missing Date Report
"RTN","DGCV",23,0)
 ;    F - missing Service Sep Date & no OEF OIF or OEF/OIF Unknown dates
"RTN","DGCV",24,0)
 ;  If critical dates are missing but the corresponding indicator fields
"RTN","DGCV",25,0)
 ;    are set to 'YES' return the following
"RTN","DGCV",26,0)
 ;    G - missing Combat To Date, but Combat Indicated? = 'Yes'
"RTN","DGCV",27,0)
 ;    H - missing PG To Date, but PG Indicated? = 'Yes'
"RTN","DGCV",28,0)
 ;    I - missing Somalia To Date, but Somalia Indicator = 'Yes'
"RTN","DGCV",29,0)
 ;    J - missing Yugoslavia To Date, but Yugoslavia Indicator = 'Yes'
"RTN","DGCV",30,0)
 ;
"RTN","DGCV",31,0)
 N DG1,DG2,I,RESULT
"RTN","DGCV",32,0)
 N DGCOM,DGCVDT,DGCVFLG,DGGULF,DGSOM,DGSRV,DGYUG,DGOEIF
"RTN","DGCV",33,0)
 S (DG1,DG2,RESULT)=0
"RTN","DGCV",34,0)
 I $G(DFN)']"" Q RESULT
"RTN","DGCV",35,0)
 I '$D(^DPT(DFN)) Q RESULT
"RTN","DGCV",36,0)
 ;
"RTN","DGCV",37,0)
 ;get combat related data from top-level VistA fields
"RTN","DGCV",38,0)
 N DGARR,DGERR
"RTN","DGCV",39,0)
 D GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294;.5295","I","DGARR","DGERR")
"RTN","DGCV",40,0)
 D PARSE
"RTN","DGCV",41,0)
 ;
"RTN","DGCV",42,0)
 S DG1=$$CHKSSD(DFN) ;check SSD for imprecise or missing
"RTN","DGCV",43,0)
 S DGDATE=$G(DGCOM)_"^"_$G(DGYUG)_"^"_$G(DGSOM)_"^"_$G(DGGULF)_"^"_$G(DGOEIF)
"RTN","DGCV",44,0)
 ;
"RTN","DGCV",45,0)
 I $S(DG1="F":1,1:$P(DGDATE,U,5)>$G(DGSRV)) D
"RTN","DGCV",46,0)
 . ; Use OIF/OEF/UNKNOWN OEF/OIF to dt only when SSD missing or SSD less
"RTN","DGCV",47,0)
 . ; than OIF/OEF/UNKNOWN OEF/OIF to dt
"RTN","DGCV",48,0)
 . N DGSRV,Z
"RTN","DGCV",49,0)
 . S DGSRV=$P(DGDATE,U,5),Z=$$CHKSSD(DFN)
"RTN","DGCV",50,0)
 . I Z=1 S DG1=Z
"RTN","DGCV",51,0)
 ;
"RTN","DGCV",52,0)
 S DG2=$$CHKREST(DGDATE,$G(DGSRV)) ;check other "TO" dates for imprecise, missing or invalid
"RTN","DGCV",53,0)
 S RESULT=$$RES(DG1,$G(DG2))
"RTN","DGCV",54,0)
 Q RESULT
"RTN","DGCV",55,0)
 ;
"RTN","DGCV",56,0)
RES(DG1,DG2) ;determine the final RESULT code from DG1 & DG2
"RTN","DGCV",57,0)
 ;if SSD evaluates to earlier than 11/11/98, can't set CV End Date
"RTN","DGCV",58,0)
 I DG1=0!($G(DG2)=0) Q 0
"RTN","DGCV",59,0)
 ;if SSD is 1
"RTN","DGCV",60,0)
 I DG1=1,($G(DG2)=1!($G(DG2)']"")) Q 1
"RTN","DGCV",61,0)
 I DG1=1,($G(DG2)=0) Q 0
"RTN","DGCV",62,0)
 I DG1=1 Q DG2
"RTN","DGCV",63,0)
 ;if SSD is imprecise or missing
"RTN","DGCV",64,0)
 I DG1'=1,($G(DG2)=1) S DG2=""
"RTN","DGCV",65,0)
 Q DG1_DG2
"RTN","DGCV",66,0)
 ;
"RTN","DGCV",67,0)
CHKDATE(DGDATE,I,SSD) ;check to see if date is imprecise or missing
"RTN","DGCV",68,0)
 ;if imprecise check to see if the imprecision prevents CV evaluation
"RTN","DGCV",69,0)
 ;if not imprecise check to see if after 11/11/98
"RTN","DGCV",70,0)
 ; Note that SSD doesn't appear to ever be used here (TMK)
"RTN","DGCV",71,0)
 N RES
"RTN","DGCV",72,0)
 S RES=0
"RTN","DGCV",73,0)
 I $G(DGDATE)']"",I'=5 D  Q RES
"RTN","DGCV",74,0)
 . S RES=$S(I=0:"F",I=1:"G",I=2:"H",I=3:"I",I=4:"J",1:"")
"RTN","DGCV",75,0)
 I $E(DGDATE,6,7)="00" D
"RTN","DGCV",76,0)
 . I I=0 I DGDATE>2981111 S RES="A" Q
"RTN","DGCV",77,0)
 . I DGDATE=2980000!(DGDATE=2981100) D  Q
"RTN","DGCV",78,0)
 .. ; Note OIF/OEF/UNKNOWN OEF/OIF will not get here as these dates by
"RTN","DGCV",79,0)
 .. ; definition are after 11/11/98
"RTN","DGCV",80,0)
 . . S RES=$S(I=0:"A",I=1:"B",I=2:"C",I=3:"D",I=4:"E",1:"")
"RTN","DGCV",81,0)
 Q:RES="A" RES
"RTN","DGCV",82,0)
 I DGDATE>2981111 S RES=1
"RTN","DGCV",83,0)
 Q RES
"RTN","DGCV",84,0)
 ;
"RTN","DGCV",85,0)
SETCV(DFN,DGSRV) ;calculate CV end date
"RTN","DGCV",86,0)
 ;    DGSRV is the most recent of the Service Separation Date 
"RTN","DGCV",87,0)
 ;    or the OEF/OIF To Date, called from file #2 new style 
"RTN","DGCV",88,0)
 ;    cross reference "ACVCOM"
"RTN","DGCV",89,0)
 N DGCVEDT,DGFDA
"RTN","DGCV",90,0)
 I $$GET1^DIQ(2,DFN_",",.5295,"I") Q
"RTN","DGCV",91,0)
 S DGCVEDT=$$CALCCV(DFN,DGSRV)
"RTN","DGCV",92,0)
 Q:DGCVEDT=""
"RTN","DGCV",93,0)
 S DGFDA(2,DFN_",",.5295)=DGCVEDT
"RTN","DGCV",94,0)
 D FILE^DIE(,"DGFDA")
"RTN","DGCV",95,0)
 Q
"RTN","DGCV",96,0)
 ;
"RTN","DGCV",97,0)
CALCCV(DFN,DGSRV) ; Calculate CV end date given DFN and date to start 
"RTN","DGCV",98,0)
 ; calculation from
"RTN","DGCV",99,0)
 ; Function returns null or CV end date calculated
"RTN","DGCV",100,0)
 N DGCVEDT,DGNDAA,DGPLUS3,DGTMPDT,DGYRS
"RTN","DGCV",101,0)
 I $G(DFN)']""!($G(DGSRV)']"") Q ""
"RTN","DGCV",102,0)
 I '$D(^DPT(DFN)) Q ""
"RTN","DGCV",103,0)
 S DGNDAA=3080128
"RTN","DGCV",104,0)
 D CVRULES(DFN,DGSRV,DGNDAA,.DGYRS)
"RTN","DGCV",105,0)
 Q:$G(DGYRS)'=3&($G(DGYRS)'=5) ""
"RTN","DGCV",106,0)
 ;NDAA legislation, enacted 1/28/08, gives vets discharged
"RTN","DGCV",107,0)
 ;on or after 1/28/03 (2 years previously) CV Eligibility 
"RTN","DGCV",108,0)
 ;for 5 years.  Vets discharged before 1/28/03 get eligibility 
"RTN","DGCV",109,0)
 ;for 3 years after enactment (or until 1/27/2011) DG*5.3*778
"RTN","DGCV",110,0)
 S DGTMPDT=$S(DGYRS=3:DGNDAA,1:DGSRV)
"RTN","DGCV",111,0)
 S DGCVEDT=($E(DGTMPDT,1,3)+DGYRS)_$E(DGTMPDT,4,7)
"RTN","DGCV",112,0)
 S DGCVEDT=$$FMADD^XLFDT(DGCVEDT,-1)
"RTN","DGCV",113,0)
 Q DGCVEDT
"RTN","DGCV",114,0)
 ;
"RTN","DGCV",115,0)
CVRULES(DFN,DGSRV,DGNDAA,DGYRS) ;apply rules for the CV End Date
"RTN","DGCV",116,0)
 ;extension project - DG*5.3*778
"RTN","DGCV",117,0)
 ;DGSRV - most recent of Service Sep Date or OEIUUF to date
"RTN","DGCV",118,0)
 ;   DGYRS = 3 years from NDAA or 1/27/2011
"RTN","DGCV",119,0)
 ;         = 5 years from SSD or Enrollment App Date
"RTN","DGCV",120,0)
 ;determine how many years extra CV eligibility to give
"RTN","DGCV",121,0)
 N DGCIEN,DGCUTOFF,DGENRDT,DGPIEN,DGPRI,DGQT,DGSTAT
"RTN","DGCV",122,0)
 ;determine if veteran has an enrollment record prior
"RTN","DGCV",123,0)
 ;to 1/28/2008 (the NDAA date) and no CV End Date for
"RTN","DGCV",124,0)
 ;this enrollment
"RTN","DGCV",125,0)
 S DGYRS=5
"RTN","DGCV",126,0)
 S (DGPRI,DGQT)=0
"RTN","DGCV",127,0)
 S DGCUTOFF=3030128
"RTN","DGCV",128,0)
 S DGCIEN=$$FINDCUR^DGENA(DFN)
"RTN","DGCV",129,0)
 I $G(DGCIEN),($D(^DGEN(27.11,DGCIEN,0)))]"" D
"RTN","DGCV",130,0)
 . S DGENRDT=$$GET1^DIQ(27.11,DGCIEN_",",75.01,"I") Q:$G(DGENRDT)']""
"RTN","DGCV",131,0)
 . I $P(DGENRDT,".",1)<DGNDAA S DGPRI=1 Q
"RTN","DGCV",132,0)
 . I DGENRDT'<DGNDAA D
"RTN","DGCV",133,0)
 . . S DGPIEN=DGCIEN
"RTN","DGCV",134,0)
 . . F  S DGPIEN=$$FINDPRI^DGENA(DGPIEN) Q:'DGPIEN  D  Q:DGQT
"RTN","DGCV",135,0)
 . . . S DGENRDT=$$GET1^DIQ(27.11,DGPIEN_",",75.01,"I")
"RTN","DGCV",136,0)
 . . . Q:$G(DGENRDT)']""
"RTN","DGCV",137,0)
 . . . I $P(DGENRDT,".",1)<DGNDAA S (DGPRI,DGQT)=1
"RTN","DGCV",138,0)
 ;if DGPRI=1, then there is an enrollment prior to 1/28/08
"RTN","DGCV",139,0)
 I DGPRI=1 D  Q
"RTN","DGCV",140,0)
 . I $G(DGCIEN)]"" S DGSTAT=$$GET1^DIQ(27.11,DGCIEN_",",.04,"E")
"RTN","DGCV",141,0)
 . I $G(DGSTAT)["INITIAL APPLICATION BY VAMC"!($G(DGSTAT)["BELOW ENROLLMENT GROUP THRESHOLD") D
"RTN","DGCV",142,0)
 . . I DGSRV<DGCUTOFF S DGYRS=3
"RTN","DGCV",143,0)
 ;
"RTN","DGCV",144,0)
 ;if no enrollment prior to 1/28/08 (DGPRI=0) check service date
"RTN","DGCV",145,0)
 ;against cutoff date - 1/28/03
"RTN","DGCV",146,0)
 I DGSRV<DGCUTOFF S DGYRS=3
"RTN","DGCV",147,0)
 Q
"RTN","DGCV",148,0)
 ;
"RTN","DGCV",149,0)
CVEDT(DFN,DGDT) ;Provide Combat Vet Eligibility End Date, if eligible
"RTN","DGCV",150,0)
 ;Supported DBIA #4156
"RTN","DGCV",151,0)
 ;Input:  DFN - Patient file IEN
"RTN","DGCV",152,0)
 ;        DGDT - Treatment date (optional), 
"RTN","DGCV",153,0)
 ;               DT is default
"RTN","DGCV",154,0)
 ;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
"RTN","DGCV",155,0)
 ;               Eligible on DGDT(1,0)^is patient eligible on input date?
"RTN","DGCV",156,0)
 ;      (piece 1)  1 - qualifies as a CV
"RTN","DGCV",157,0)
 ;                 0 - does not qualify as a CV
"RTN","DGCV",158,0)
 ;                -1 - bad DFN or date
"RTN","DGCV",159,0)
 ;      (piece 3)  1 - vet was eligible on date specified (or DT)      
"RTN","DGCV",160,0)
 ;                 0 - vet was not eligible on date specified (or DT)
"RTN","DGCV",161,0)
 ;
"RTN","DGCV",162,0)
 N RESULT
"RTN","DGCV",163,0)
 S RESULT=""
"RTN","DGCV",164,0)
 I $G(DFN)="" Q -1
"RTN","DGCV",165,0)
 I '$D(^DPT(DFN)) Q -1
"RTN","DGCV",166,0)
 ;if time sent in, drop time
"RTN","DGCV",167,0)
 I $G(DGDT)']"" S DGDT=DT
"RTN","DGCV",168,0)
 I DGDT?7N1"."1.6N S DGDT=$E(DGDT,1,7)
"RTN","DGCV",169,0)
 I DGDT'?7N Q -1
"RTN","DGCV",170,0)
 S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
"RTN","DGCV",171,0)
 I $G(RESULT)']"" Q 0
"RTN","DGCV",172,0)
 S RESULT=$S(DGDT'>RESULT:RESULT_"^1",1:RESULT_"^0") ; if treatment date is earlier or equal to end date, veteran is eligible
"RTN","DGCV",173,0)
 S RESULT=$S($G(RESULT):1_"^"_RESULT,1:0)
"RTN","DGCV",174,0)
 Q RESULT
"RTN","DGCV",175,0)
 ;
"RTN","DGCV",176,0)
PARSE ;GETS^DIQ called in CVELIG - in this subroutine stuff results into array
"RTN","DGCV",177,0)
 ;If there's MSE data in new MSE sub-file #2.3216 get last
"RTN","DGCV",178,0)
 ;Service Separation Date (DG*5.3*797)
"RTN","DGCV",179,0)
 I $D(^DPT(DFN,.3216)) S DGSRV=$P($$LAST^DGMSEUTL(DFN),U,2)
"RTN","DGCV",180,0)
 E  S DGSRV=$G(DGARR(2,DFN_",",.327,"I"))
"RTN","DGCV",181,0)
 S DGCOM=$G(DGARR(2,DFN_",",.5294,"I")) ;Combat To Date
"RTN","DGCV",182,0)
 S DGGULF=$G(DGARR(2,DFN_",",.322012,"I")) ;Persian Gulf To Date
"RTN","DGCV",183,0)
 S DGSOM=$G(DGARR(2,DFN_",",.322018,"I")) ;Somalia To Date
"RTN","DGCV",184,0)
 S DGYUG=$G(DGARR(2,DFN_",",.322021,"I")) ;Yugoslavia To Date
"RTN","DGCV",185,0)
 S DGCVDT=$G(DGARR(2,DFN_",",.5295,"I")) ;CV End Date
"RTN","DGCV",186,0)
 ; get last OIF/OEF/UNKNOWN OEF/OIF episode from multiple
"RTN","DGCV",187,0)
 S DGOEIF=$P($$LAST^DGENOEIF(DFN),U)
"RTN","DGCV",188,0)
 Q
"RTN","DGCV",189,0)
 ;
"RTN","DGCV",190,0)
CHKSSD(DFN) ;check the Serv Sep Date [Last]
"RTN","DGCV",191,0)
 ; DGSRV=last SSD
"RTN","DGCV",192,0)
 ;  Output - RESULT
"RTN","DGCV",193,0)
 ;    1 - Date is present and after 11/11/1998
"RTN","DGCV",194,0)
 ;    0 - Date is present but before 11/11/1998
"RTN","DGCV",195,0)
 ;    A - Date is imprecise & either is or potentially is after 11/11/98
"RTN","DGCV",196,0)
 ;    F - Date is missing
"RTN","DGCV",197,0)
 N DG1
"RTN","DGCV",198,0)
 I $G(DGSRV)']"" Q "F"
"RTN","DGCV",199,0)
 S DG1=$$CHKDATE(DGSRV,0)
"RTN","DGCV",200,0)
 I $G(DG1)']"" S DG1=0
"RTN","DGCV",201,0)
 Q DG1
"RTN","DGCV",202,0)
 ;
"RTN","DGCV",203,0)
CHKREST(DGDATE,SSD) ;
"RTN","DGCV",204,0)
 ; SSD = optional, = to the last serv sep date
"RTN","DGCV",205,0)
 N DG3,DG4,DGDT,DGFLG,DGLEN,DGQ,DGR,DGRES,DGX
"RTN","DGCV",206,0)
 S (DG3,DG4,DGR,DGRES)=""
"RTN","DGCV",207,0)
 S DGQ=0 ;loop terminator
"RTN","DGCV",208,0)
 S DGFLG=0 ;flag to indicate that one of the dates is missing (no 
"RTN","DGCV",209,0)
 ;          need to check this for OIF/OEF/UNKNOWN OEF/OIF since
"RTN","DGCV",210,0)
 ;          by definition, these must always be post 11/11/98)
"RTN","DGCV",211,0)
 F DGX=1:1:5 D
"RTN","DGCV",212,0)
 . S DGDT=$P(DGDATE,U,DGX) D
"RTN","DGCV",213,0)
 . . I DGX'=5,$G(DGDT)']"" S DGFLG=1
"RTN","DGCV",214,0)
 . . S DG4=$$CHKDATE(DGDT,DGX,$G(SSD))
"RTN","DGCV",215,0)
 . . I $G(DG4)'=0 S DG3=$G(DG3)_$G(DG4)
"RTN","DGCV",216,0)
 S DGLEN=$L(DG3)
"RTN","DGCV",217,0)
 S DGQ=0
"RTN","DGCV",218,0)
 F DGX=1:1:DGLEN S DGCHAR=$E(DG3,DGX) D  Q:DGQ=1
"RTN","DGCV",219,0)
 . I DGCHAR=1 S DG3=DGCHAR,DGQ=1 Q
"RTN","DGCV",220,0)
 . I "BCDE"[DGCHAR S DGR=DGR_DGCHAR,DGQ=2
"RTN","DGCV",221,0)
 I DGQ=1 Q 1
"RTN","DGCV",222,0)
 I DGQ=2 Q $E(DGR)
"RTN","DGCV",223,0)
 I DGFLG=1 S DGRES=$$MISS(DFN,DGLEN,DG3)
"RTN","DGCV",224,0)
 Q DGRES
"RTN","DGCV",225,0)
 ;
"RTN","DGCV",226,0)
MISS(DFN,DGLEN,DGRES) ;there is at least one missing date, and in order to 
"RTN","DGCV",227,0)
 ;return a RESULT of a missing date, need to check to see if the 
"RTN","DGCV",228,0)
 ;corresponding indicator field is set to 'YES'
"RTN","DGCV",229,0)
 N DGARR,DGCHAR,DGERR,DGQ,DGR,DGX
"RTN","DGCV",230,0)
 N DGCIND,DGPGIND,DGSIND,DGYIND
"RTN","DGCV",231,0)
 S (DGCHAR,DGQ,DGR)=0
"RTN","DGCV",232,0)
 D GETS^DIQ(2,DFN_",",".32201;.322019;.322016;.5291","I","DGARR","DGERR")
"RTN","DGCV",233,0)
 S DGCIND=$G(DGARR(2,DFN_",",.5291,"I")) ;Combat Service Indicated
"RTN","DGCV",234,0)
 S DGYIND=$G(DGARR(2,DFN_",",.322019,"I")) ;Yugo service indicated
"RTN","DGCV",235,0)
 S DGSIND=$G(DGARR(2,DFN_",",.322016,"I")) ;Somalia service indicated
"RTN","DGCV",236,0)
 S DGPGIND=$G(DGARR(2,DFN_",",.32201,"I")) ;Pers Gulf service indicated
"RTN","DGCV",237,0)
 F DGX=1:1:DGLEN S DGCHAR=$E(DGRES,DGX) D  Q:DGQ=1
"RTN","DGCV",238,0)
 . I DGCHAR="G",($G(DGCIND)="Y") S DGR="G",DGQ=1 Q
"RTN","DGCV",239,0)
 . I DGCHAR="H",($G(DGYIND)="Y") S DGR="H",DGQ=1 Q
"RTN","DGCV",240,0)
 . I DGCHAR="I",($G(DGSIND)="Y") S DGR="I",DGQ=1 Q
"RTN","DGCV",241,0)
 . I DGCHAR="J",($G(DGPGIND)="Y") S DGR="J"
"RTN","DGCV",242,0)
 Q DGR
"RTN","DGCV",243,0)
DELCV(DFN) ;called by the Kill logic of the ACVCOM cross reference
"RTN","DGCV",244,0)
 ;if $$CVELIG^DGCV returns a 0 the CV End Date should be deleted
"RTN","DGCV",245,0)
 ;because this would indicate that fields have been changed and
"RTN","DGCV",246,0)
 ;CV eligibility is no longer appropriate
"RTN","DGCV",247,0)
 ;
"RTN","DGCV",248,0)
 N DGCV,DGFDA
"RTN","DGCV",249,0)
 K DGCVFLG
"RTN","DGCV",250,0)
 S DGCVFLG=0
"RTN","DGCV",251,0)
 I $G(DFN)']"" Q
"RTN","DGCV",252,0)
 I '$D(^DPT(DFN)) Q
"RTN","DGCV",253,0)
 S DGCV=$$GET1^DIQ(2,DFN_",",.5295,"I")
"RTN","DGCV",254,0)
 I $G(DGCV)']"" Q
"RTN","DGCV",255,0)
 S DGCVFLG=1
"RTN","DGCV",256,0)
 S DGFDA(2,DFN_",",.5295)="@"
"RTN","DGCV",257,0)
 D FILE^DIE(,"DGFDA")
"RTN","DGCV",258,0)
 Q
"RTN","DGCVRPT")
0^32^B27927471
"RTN","DGCVRPT",1,0)
DGCVRPT ;ALB/PJR,LBD - Unsupported CV End Dates Report;  ; 6/16/09 10:53am
"RTN","DGCVRPT",2,0)
 ;;5.3;Registration;**564,731,792,797**; Aug 13,1993;Build 24
"RTN","DGCVRPT",3,0)
 ;
"RTN","DGCVRPT",4,0)
EN ; Called from DG UNSUPPORTED CV END DATES RPT option
"RTN","DGCVRPT",5,0)
 N DGSRT
"RTN","DGCVRPT",6,0)
 S DGSRT=$$SRT I DGSRT="" Q
"RTN","DGCVRPT",7,0)
 D RPTQUE Q
"RTN","DGCVRPT",8,0)
SRT() ; Get sort order
"RTN","DGCVRPT",9,0)
 ; OUPUT: Y - Sort (N=Name; D=DFN)
"RTN","DGCVRPT",10,0)
 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","DGCVRPT",11,0)
 S DIR(0)="SA^N:Name;D:DFN (Internal ID)"
"RTN","DGCVRPT",12,0)
 S DIR("A")="Sort report by Name or DFN (Internal ID): ",DIR("B")="NAME"
"RTN","DGCVRPT",13,0)
 S DIR("?",1)="Indicate whether the report should be sorted by the"
"RTN","DGCVRPT",14,0)
 S DIR("?")="Veteran's Name or the Internal ID (DFN) of the Veteran"
"RTN","DGCVRPT",15,0)
 D ^DIR I $D(DTOUT)!($D(DUOUT)) Q ""
"RTN","DGCVRPT",16,0)
 Q Y
"RTN","DGCVRPT",17,0)
 ;
"RTN","DGCVRPT",18,0)
RPTQUE ; Get report device. Queue report if requested.
"RTN","DGCVRPT",19,0)
 N POP,ZTRTN,ZTDESC,ZTSAVE,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","DGCVRPT",20,0)
 K IOP,%ZIS
"RTN","DGCVRPT",21,0)
 S %ZIS="MQ"
"RTN","DGCVRPT",22,0)
 W !
"RTN","DGCVRPT",23,0)
 D ^%ZIS I POP W !!,*7,"Report Cancelled!",! S DIR(0)="E" D ^DIR Q
"RTN","DGCVRPT",24,0)
 I $D(IO("Q")) D  Q
"RTN","DGCVRPT",25,0)
 .S ZTRTN="RPT^DGCVRPT(DGSRT)"
"RTN","DGCVRPT",26,0)
 .S ZTDESC="Print Unsupported CV End Dates Report"
"RTN","DGCVRPT",27,0)
 .S ZTSAVE("DGSRT")=""
"RTN","DGCVRPT",28,0)
 .D ^%ZTLOAD
"RTN","DGCVRPT",29,0)
 .W !!,"Report "_$S($D(ZTSK):"Queued!",1:"Cancelled!")
"RTN","DGCVRPT",30,0)
 .W ! S DIR(0)="E" D ^DIR
"RTN","DGCVRPT",31,0)
 .D HOME^%ZIS
"RTN","DGCVRPT",32,0)
 D RPT(DGSRT)
"RTN","DGCVRPT",33,0)
 D ^%ZISC
"RTN","DGCVRPT",34,0)
 Q
"RTN","DGCVRPT",35,0)
 ;
"RTN","DGCVRPT",36,0)
RPT(DGSRT) ; Entry point to produce report
"RTN","DGCVRPT",37,0)
 D EN1,EN2(DGSRT) Q
"RTN","DGCVRPT",38,0)
EN1 ; Extract
"RTN","DGCVRPT",39,0)
 N RNAME,DFN,RECCOUNT,SELCOUNT,DGXTMP,RES,CEN,CALC,EDITED
"RTN","DGCVRPT",40,0)
 ; Initialize ^XTMP global and set start date
"RTN","DGCVRPT",41,0)
 K ^XTMP("DGCVRPT")
"RTN","DGCVRPT",42,0)
 S RNAME="DG UNSUPPORTED CV END DATE REPORT"
"RTN","DGCVRPT",43,0)
 S ^XTMP("DGCVRPT",0)=$$FMADD^XLFDT(DT,60)_U_DT_U_RNAME
"RTN","DGCVRPT",44,0)
 S $P(^XTMP("DGCVRPT","DATE"),U,1)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
"RTN","DGCVRPT",45,0)
 S:$G(ZTSK) ZTREQ="@"
"RTN","DGCVRPT",46,0)
 ; Set variables and initialize array for counts
"RTN","DGCVRPT",47,0)
 S (DFN,RECCOUNT,SELCOUNT,EDITED)=0
"RTN","DGCVRPT",48,0)
 S DGXTMP="^XTMP(""DGCVRPT"",""NOSUP"")"
"RTN","DGCVRPT",49,0)
 ; Loop through cross-reference "E"
"RTN","DGCVRPT",50,0)
 ; If patient meets report criteria, put on list
"RTN","DGCVRPT",51,0)
 F  S EDITED=$O(^DPT("E",EDITED)) Q:'EDITED  S DFN=0 D
"RTN","DGCVRPT",52,0)
 .F  S DFN=$O(^DPT("E",EDITED,DFN)) Q:'DFN  D CHK I CEN,CEN'=CALC D PUT
"RTN","DGCVRPT",53,0)
 S $P(^XTMP("DGCVRPT","DATE"),U,2)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
"RTN","DGCVRPT",54,0)
 K ^XTMP("DGCVRPT","RUNNING"),DGXTMP
"RTN","DGCVRPT",55,0)
 Q
"RTN","DGCVRPT",56,0)
 ;
"RTN","DGCVRPT",57,0)
CHK ; Calculate CV End Date, check MSE data is supporting it
"RTN","DGCVRPT",58,0)
 ; INPUT: DFN - Patient file IEN
"RTN","DGCVRPT",59,0)
 ; OUTPUT: CEN  = CV End Date on file
"RTN","DGCVRPT",60,0)
 ;         CALC = Calculated CV End Date
"RTN","DGCVRPT",61,0)
 N DGARRY
"RTN","DGCVRPT",62,0)
 S RECCOUNT=RECCOUNT+1 D CNT
"RTN","DGCVRPT",63,0)
 S CALC="",CEN=$P($G(^DPT(DFN,.52)),U,15) I 'CEN Q
"RTN","DGCVRPT",64,0)
 S CALC=$$CVDATE(DFN,.DGARRY)
"RTN","DGCVRPT",65,0)
 ; If OEF/OIF date's "to date" is used for the CV End date, (not the
"RTN","DGCVRPT",66,0)
 ;   last SSD), include it as an inconsistency on this report
"RTN","DGCVRPT",67,0)
 I $G(DGARRY("OEF/OIF")),DGARRY("OEF/OIF")>$G(DGARRY("SSD")) S CALC=""
"RTN","DGCVRPT",68,0)
 Q
"RTN","DGCVRPT",69,0)
 ;
"RTN","DGCVRPT",70,0)
SCH S CALC=$$CALCCV^DGCV(DFN,SSD) Q
"RTN","DGCVRPT",71,0)
 ;
"RTN","DGCVRPT",72,0)
PUT ; Put record on list
"RTN","DGCVRPT",73,0)
 N NAM,SSN,NZERO
"RTN","DGCVRPT",74,0)
 S SELCOUNT=SELCOUNT+1 D CNT
"RTN","DGCVRPT",75,0)
 S NZERO=$G(^DPT(DFN,0)),NAM=$P(NZERO,U,1),SSN=$P(NZERO,U,9)
"RTN","DGCVRPT",76,0)
 S @DGXTMP@("DFN",DFN,0)=NAM_U_SSN_U_CEN
"RTN","DGCVRPT",77,0)
 I NAM'="" S @DGXTMP@("NAM",NAM,DFN)=""
"RTN","DGCVRPT",78,0)
 Q
"RTN","DGCVRPT",79,0)
 ;
"RTN","DGCVRPT",80,0)
CNT S @DGXTMP@("CNT","VET")=SELCOUNT_U_RECCOUNT Q
"RTN","DGCVRPT",81,0)
 ;
"RTN","DGCVRPT",82,0)
EN2(DGSRT) ; Print
"RTN","DGCVRPT",83,0)
 ; INPUT    DGSRT - Sort order for report (Name or DFN)
"RTN","DGCVRPT",84,0)
 N PG,LINE,RPTDT,CRT,OUT,DSH,CNT,MXLNE,DGXTMP,DGTOT,LOOP
"RTN","DGCVRPT",85,0)
 S:$G(ZTSK) ZTREQ="@"
"RTN","DGCVRPT",86,0)
 D PRTVAR
"RTN","DGCVRPT",87,0)
 U IO D HDR
"RTN","DGCVRPT",88,0)
 ;;
"RTN","DGCVRPT",89,0)
 S LOOP="LOOP"_DGSRT
"RTN","DGCVRPT",90,0)
 D @LOOP Q:OUT
"RTN","DGCVRPT",91,0)
 D TOT Q:OUT
"RTN","DGCVRPT",92,0)
 W ! S OUT=$$PAUSE
"RTN","DGCVRPT",93,0)
 Q
"RTN","DGCVRPT",94,0)
LOOPN ; Sort by name. Loop through ^XTMP("DGCVRPT","NOSUP","NAM", x-ref
"RTN","DGCVRPT",95,0)
 N NM,DFN
"RTN","DGCVRPT",96,0)
 S (NM,DFN)=""
"RTN","DGCVRPT",97,0)
 F  S NM=$O(@DGXTMP@("NAM",NM)) Q:NM=""!OUT  D
"RTN","DGCVRPT",98,0)
 .F  S DFN=$O(@DGXTMP@("NAM",NM,DFN)) Q:DFN=""!OUT  D PRINT
"RTN","DGCVRPT",99,0)
 Q
"RTN","DGCVRPT",100,0)
LOOPD ; Sort by DFN. Loop through ^XTMP("DGCVRPT","NOSUP","DFN", x-ref
"RTN","DGCVRPT",101,0)
 N DFN S DFN=0
"RTN","DGCVRPT",102,0)
 F  S DFN=$O(@DGXTMP@("DFN",DFN)) Q:'DFN!OUT  D PRINT
"RTN","DGCVRPT",103,0)
 Q
"RTN","DGCVRPT",104,0)
PRINT ; Print veteran
"RTN","DGCVRPT",105,0)
 N VET
"RTN","DGCVRPT",106,0)
 Q:'$D(@DGXTMP@("DFN",DFN))
"RTN","DGCVRPT",107,0)
 S VET=$G(@DGXTMP@("DFN",DFN,0))
"RTN","DGCVRPT",108,0)
 I LINE>MXLNE S OUT=$$PAUSE Q:OUT  D HDR
"RTN","DGCVRPT",109,0)
 W !,DFN,?12,$P(VET,U,2),?24,$E($P(VET,U,1),1,39),?64,$$FMTE^XLFDT($P(VET,U,3))
"RTN","DGCVRPT",110,0)
 S LINE=LINE+1 Q
"RTN","DGCVRPT",111,0)
TOT ; Print total records at the end of the report
"RTN","DGCVRPT",112,0)
 I LINE+4>MXLNE S OUT=$$PAUSE Q:OUT  D HDR
"RTN","DGCVRPT",113,0)
 W !!,"Total Records Printed:          ",$$RJ^XLFSTR($P(DGTOT,U,1),7)
"RTN","DGCVRPT",114,0)
 W !!,"Total Records with CV End Dates:",$$RJ^XLFSTR($P(DGTOT,U,2),7)
"RTN","DGCVRPT",115,0)
 Q
"RTN","DGCVRPT",116,0)
PRTVAR ; Set up variables needed to print report
"RTN","DGCVRPT",117,0)
 S CRT=$S($E(IOST,1,2)="C-":1,1:0)
"RTN","DGCVRPT",118,0)
 S DGXTMP="^XTMP(""DGCVRPT"",""NOSUP"")"
"RTN","DGCVRPT",119,0)
 S DGTOT=$G(@DGXTMP@("CNT","VET"))
"RTN","DGCVRPT",120,0)
 S:$G(DGSRT)="" DGSRT="N"
"RTN","DGCVRPT",121,0)
 S (PG,CNT,OUT)=0,RPTDT=$$FMTE^XLFDT(DT),MXLNE=$S(CRT:15,1:52)
"RTN","DGCVRPT",122,0)
 S DSH="",$P(DSH,"=",80)=""
"RTN","DGCVRPT",123,0)
 Q
"RTN","DGCVRPT",124,0)
HDR ; Print report header
"RTN","DGCVRPT",125,0)
 S PG=PG+1,LINE=0
"RTN","DGCVRPT",126,0)
 W @IOF
"RTN","DGCVRPT",127,0)
 W ?0,"Report Date: ",RPTDT,?68,"Page: ",$$RJ^XLFSTR(PG,4)
"RTN","DGCVRPT",128,0)
 W !,"Sorted By: "_$S(DGSRT="N":"Name",1:"DFN")
"RTN","DGCVRPT",129,0)
 W !!,$$CJ^XLFSTR("CV END DATES WITH NO SUPPORTING MS DATA REPORT",80)
"RTN","DGCVRPT",130,0)
 W !!,"DFN",?12,"SSN",?24,"Veteran's Name",?64,"CV End Date"
"RTN","DGCVRPT",131,0)
 W !,DSH
"RTN","DGCVRPT",132,0)
 Q
"RTN","DGCVRPT",133,0)
PAUSE() ; If report is sent to screen, prompt for next page or quit
"RTN","DGCVRPT",134,0)
 N DIR,DIRUT,DUOUT,DTOUT,X,Y
"RTN","DGCVRPT",135,0)
 I 'CRT Q 0
"RTN","DGCVRPT",136,0)
 S DIR(0)="E"
"RTN","DGCVRPT",137,0)
 D ^DIR I 'Y Q 1
"RTN","DGCVRPT",138,0)
 Q 0
"RTN","DGCVRPT",139,0)
CVDATE(DFN,DGARR,DGERR) ; Returns all values for calculating the CV End date
"RTN","DGCVRPT",140,0)
 ; in DGARR (passed by reference)
"RTN","DGCVRPT",141,0)
 ;   AND
"RTN","DGCVRPT",142,0)
 ; any error codes from the DIQ call in DGERR (passed by reference)
"RTN","DGCVRPT",143,0)
 ;   AND
"RTN","DGCVRPT",144,0)
 ; the calculated CV End Date as the result of the function call
"RTN","DGCVRPT",145,0)
 ;
"RTN","DGCVRPT",146,0)
 N N,DATE,X,Y
"RTN","DGCVRPT",147,0)
 S DATE=""
"RTN","DGCVRPT",148,0)
 D GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294","I","DGARR","DGERR")
"RTN","DGCVRPT",149,0)
 S DGARR("OEF/OIF")=$P($$LAST^DGENOEIF(DFN),U)
"RTN","DGCVRPT",150,0)
 ; If there's MSE data in new MSE sub-file #2.3216 get last
"RTN","DGCVRPT",151,0)
 ; Service Separation Date (DG*5.3*797)
"RTN","DGCVRPT",152,0)
 I $D(^DPT(DFN,.3216)) S DGARR("SSD")=$P($$LAST^DGMSEUTL(DFN),U,2)
"RTN","DGCVRPT",153,0)
 E  S DGARR("SSD")=$G(DGARR(2,DFN_",",.327,"I"))
"RTN","DGCVRPT",154,0)
 ; If OEF/OIF date later than last serv sep dt, use to date of OEF/OIF
"RTN","DGCVRPT",155,0)
 I $G(DGARR("OEF/OIF")),DGARR("OEF/OIF")>DGARR("SSD") S DATE=DGARR("OEF/OIF") G CVDATEQ
"RTN","DGCVRPT",156,0)
 I DGARR("SSD") D
"RTN","DGCVRPT",157,0)
 . Q:$E(DGARR("SSD"),6,7)="00"!(DGARR("SSD")'>2981111)
"RTN","DGCVRPT",158,0)
 . I $G(DGARR("OEF/OIF")) S DATE=DGARR("SSD") Q
"RTN","DGCVRPT",159,0)
 . ; If conflict dates exist for any of the above listed fields, use SSD 
"RTN","DGCVRPT",160,0)
 . S N=0 F  S N=$O(DGARR(2,DFN_",",N)) Q:'N  I N'=.327,$G(DGARR(2,DFN_",",N,"I"))>2981111 S DATE=DGARR("SSD") Q
"RTN","DGCVRPT",161,0)
 ;
"RTN","DGCVRPT",162,0)
CVDATEQ Q $S(DATE:$$CALCCV^DGCV(DFN,DATE),1:"")
"RTN","DGCVRPT",163,0)
 ;
"RTN","DGENUPL1")
0^31^B36548434
"RTN","DGENUPL1",1,0)
DGENUPL1 ;ALB/CJM,ISA/KWP,CKN,LBD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 6/17/09 10:07am
"RTN","DGENUPL1",2,0)
 ;;5.3;REGISTRATION;**147,222,232,314,397,379,407,363,673,653,688,797**;Aug 13,1993;Build 24
"RTN","DGENUPL1",3,0)
 ;
"RTN","DGENUPL1",4,0)
PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE) ;
"RTN","DGENUPL1",5,0)
 ;
"RTN","DGENUPL1",6,0)
 ;Description:  This function parses the HL7 segments.  It creates arrays
"RTN","DGENUPL1",7,0)
 ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY,
"RTN","DGENUPL1",8,0)
 ;OEF/OIF CONFLICT objects.
"RTN","DGENUPL1",9,0)
 ;Field values are put in DHCP format and the validity at the
"RTN","DGENUPL1",10,0)
 ;field level is tested.  Fields to be deleted are set to "@".
"RTN","DGENUPL1",11,0)
 ;
"RTN","DGENUPL1",12,0)
 ;Input:
"RTN","DGENUPL1",13,0)
 ;  MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772)
"RTN","DGENUPL1",14,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",15,0)
 ;  CURLINE - the subscript of the PID segment of the current message (pass by reference)
"RTN","DGENUPL1",16,0)
 ;  ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref)
"RTN","DGENUPL1",17,0)
 ;
"RTN","DGENUPL1",18,0)
 ;Output:
"RTN","DGENUPL1",19,0)
 ;  Function Value: Returns 1 on success, 0 on failure.
"RTN","DGENUPL1",20,0)
 ;  CURLINE - upon leaving the procedure this parameter should be set to the end of the current message.
"RTN","DGENUPL1",21,0)
 ;  ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref)
"RTN","DGENUPL1",22,0)
 ;  DGPAT - array defined by the PATIENT object. (pass by ref)
"RTN","DGENUPL1",23,0)
 ;  DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref)
"RTN","DGENUPL1",24,0)
 ;  DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref)
"RTN","DGENUPL1",25,0)
 ;  DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref)
"RTN","DGENUPL1",26,0)
 ;  DGSEC - array defined by the PATIENT SECURITY object. (pass by ref)
"RTN","DGENUPL1",27,0)
 ;  DGOEIF - array defined by the OEF/OIF CONFLICT object.  (pass by ref)
"RTN","DGENUPL1",28,0)
 ;  DGNTR - array defined for NTR data.
"RTN","DGENUPL1",29,0)
 ;  DGMST - array defined for MST data.
"RTN","DGENUPL1",30,0)
 ;  DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref)
"RTN","DGENUPL1",31,0)
 N SEG,ERROR,COUNT,QFLG,NFLG
"RTN","DGENUPL1",32,0)
 ;
"RTN","DGENUPL1",33,0)
 K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST
"RTN","DGENUPL1",34,0)
 ;
"RTN","DGENUPL1",35,0)
 S ERROR=0,NFLG=1
"RTN","DGENUPL1",36,0)
 F SEG="PID","ZPD","ZIE","ZIO","ZEL"  D  Q:ERROR
"RTN","DGENUPL1",37,0)
 .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",38,0)
 .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q
"RTN","DGENUPL1",39,0)
 .I SEG("TYPE")=SEG D  Q
"RTN","DGENUPL1",40,0)
 ..D:(SEG'="ZEL") @SEG^DGENUPL2
"RTN","DGENUPL1",41,0)
 ..D:(SEG="ZEL") ZEL^DGENUPL2(1)
"RTN","DGENUPL1",42,0)
 ..S NFLG=1
"RTN","DGENUPL1",43,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",44,0)
 .S ERROR=1
"RTN","DGENUPL1",45,0)
 .;
"RTN","DGENUPL1",46,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",47,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",48,0)
 ;
"RTN","DGENUPL1",49,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL")  D  Q:ERROR
"RTN","DGENUPL1",50,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",51,0)
 .D ZEL^DGENUPL2(COUNT)
"RTN","DGENUPL1",52,0)
 ;Phase II Add the capability to accept more than 1 ZCD
"RTN","DGENUPL1",53,0)
 I 'ERROR F SEG="ZEN","ZMT","ZCD" D  Q:ERROR
"RTN","DGENUPL1",54,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",55,0)
 .I SEG("TYPE")=SEG D
"RTN","DGENUPL1",56,0)
 ..D @SEG^DGENUPL2
"RTN","DGENUPL1",57,0)
 .E  D
"RTN","DGENUPL1",58,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUTOF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",59,0)
 ..S ERROR=1
"RTN","DGENUPL1",60,0)
 ..;
"RTN","DGENUPL1",61,0)
 ..;possible that in a bad message we are now past the end
"RTN","DGENUPL1",62,0)
 ..S CURLINE=CURLINE-1
"RTN","DGENUPL1",63,0)
 ;
"RTN","DGENUPL1",64,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZCD")  D  Q:ERROR
"RTN","DGENUPL1",65,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",66,0)
 .D ZCD^DGENUPL2
"RTN","DGENUPL1",67,0)
 ;
"RTN","DGENUPL1",68,0)
 ; Purple Heart/OEF-OIF  Addition of optional ZMH segment
"RTN","DGENUPL1",69,0)
 ;              Modified handling of ZSP and ZRD to accomodate ZMH
"RTN","DGENUPL1",70,0)
 ;
"RTN","DGENUPL1",71,0)
 I 'ERROR D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",72,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",73,0)
 .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q
"RTN","DGENUPL1",74,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",75,0)
 .S ERROR=1
"RTN","DGENUPL1",76,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",77,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",78,0)
 ;
"RTN","DGENUPL1",79,0)
 ;Modified following code to receive multiple ZMH segment for
"RTN","DGENUPL1",80,0)
 ;Military service information - DG*5.3*653
"RTN","DGENUPL1",81,0)
 I 'ERROR D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",82,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",83,0)
 .S QFLG=0 F  D  Q:QFLG
"RTN","DGENUPL1",84,0)
 . . I SEG("TYPE")'="ZMH" S QFLG=1 Q
"RTN","DGENUPL1",85,0)
 . . D ZMH^DGENUPL2,NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",86,0)
 .I SEG("TYPE")="ZRD" D ZRD^DGENUPL2 Q 
"RTN","DGENUPL1",87,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",88,0)
 .S ERROR=1
"RTN","DGENUPL1",89,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",90,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",91,0)
 ;
"RTN","DGENUPL1",92,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZRD")  D  Q:ERROR
"RTN","DGENUPL1",93,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",94,0)
 .D ZRD^DGENUPL2
"RTN","DGENUPL1",95,0)
 ;
"RTN","DGENUPL1",96,0)
 I 'ERROR F  D  Q:(ERROR!(SEG("TYPE")'="OBX"))
"RTN","DGENUPL1",97,0)
 .;possible if OBX segment not present that we are now past the end
"RTN","DGENUPL1",98,0)
 .I SEG("TYPE")'="OBX" S CURLINE=CURLINE-1 Q
"RTN","DGENUPL1",99,0)
 .D OBX^DGENUPL2
"RTN","DGENUPL1",100,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",101,0)
 .D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG)
"RTN","DGENUPL1",102,0)
 ;
"RTN","DGENUPL1",103,0)
 Q $S(ERROR:0,1:1)
"RTN","DGENUPL1",104,0)
 ;
"RTN","DGENUPL1",105,0)
CONVERT(VAL,DATATYPE,ERROR) ;
"RTN","DGENUPL1",106,0)
 ;Description: Converts the value found in the HL7 segment to DHCP format
"RTN","DGENUPL1",107,0)
 ;
"RTN","DGENUPL1",108,0)
 ;Input:
"RTN","DGENUPL1",109,0)
 ;  VAL - value parsed from the HL7 segment
"RTN","DGENUPL1",110,0)
 ;  DATATYPE: indicates the type of conversion necessary
"RTN","DGENUPL1",111,0)
 ;      "DATE" - needs to be converted to FM format
"RTN","DGENUPL1",112,0)
 ;      "TS" - time stamp, needs to be converted to FM format
"RTN","DGENUPL1",113,0)
 ;      "Y/N" - 0->"N",1->"Y"
"RTN","DGENUPL1",114,0)
 ;      "1/0" - "Y"->1,"N"->0
"RTN","DGENUPL1",115,0)
 ;      "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file
"RTN","DGENUPL1",116,0)
 ;      "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8)
"RTN","DGENUPL1",117,0)
 ;
"RTN","DGENUPL1",118,0)
 ;      "MT" - VAL  is a Means Test Status code, it needs to be converted
"RTN","DGENUPL1",119,0)
 ;             to a pointer to the Means Test Status file
"RTN","DGENUPL1",120,0)
 ;       Phase II convert code to RSN IEN for DGCDIS object
"RTN","DGENUPL1",121,0)
 ;       "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5)
"RTN","DGENUPL1",122,0)
 ;       "EXT" convert from code to abbreviation
"RTN","DGENUPL1",123,0)
 ;       "POS" convert from Period of Service code to a point to Period of Service file
"RTN","DGENUPL1",124,0)
 ;       "AGENCY" convert Agency/Allied Country code from file 35
"RTN","DGENUPL1",125,0)
 ;OUTPUT:
"RTN","DGENUPL1",126,0)
 ;  Function Value - the result of the conversion
"RTN","DGENUPL1",127,0)
 ;  ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref)
"RTN","DGENUPL1",128,0)
 ;
"RTN","DGENUPL1",129,0)
 S ERROR=0
"RTN","DGENUPL1",130,0)
 D
"RTN","DGENUPL1",131,0)
 .I VAL="" Q
"RTN","DGENUPL1",132,0)
 .I VAL="""""" S VAL="@" Q
"RTN","DGENUPL1",133,0)
 .I $G(DATATYPE)="EXT" D  Q
"RTN","DGENUPL1",134,0)
 ..S VAL=$$HLTOLIMB^DGENA5(VAL)
"RTN","DGENUPL1",135,0)
 .I $G(DATATYPE)="CDRSN" D  Q
"RTN","DGENUPL1",136,0)
 ..S VAL=$$HL7TORSN^DGENA5(VAL)
"RTN","DGENUPL1",137,0)
 .I ($G(DATATYPE)="MT") D  Q
"RTN","DGENUPL1",138,0)
 ..S VAL=$O(^DG(408.32,"AC",1,VAL,0))
"RTN","DGENUPL1",139,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",140,0)
 .I ($G(DATATYPE)="DATE") D  Q
"RTN","DGENUPL1",141,0)
 ..I $L(VAL)'=8 S ERROR=1 Q
"RTN","DGENUPL1",142,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",143,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",144,0)
 .I ($G(DATATYPE)="TS") D  Q
"RTN","DGENUPL1",145,0)
 ..I $L(VAL)<8 S ERROR=1 Q
"RTN","DGENUPL1",146,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",147,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",148,0)
 .I ($G(DATATYPE)="Y/N") D  Q
"RTN","DGENUPL1",149,0)
 ..I VAL=0 S VAL="N" Q
"RTN","DGENUPL1",150,0)
 ..I VAL=1 S VAL="Y" Q
"RTN","DGENUPL1",151,0)
 ..S ERROR=1
"RTN","DGENUPL1",152,0)
 .I ($G(DATATYPE)="1/0") D  Q
"RTN","DGENUPL1",153,0)
 ..I VAL="N" S VAL=0 Q
"RTN","DGENUPL1",154,0)
 ..I VAL="Y" S VAL=1 Q
"RTN","DGENUPL1",155,0)
 ..S ERROR=1
"RTN","DGENUPL1",156,0)
 .I ($G(DATATYPE)="ELIGIBILITY") D  Q
"RTN","DGENUPL1",157,0)
 ..S VAL=$$MAP(VAL)
"RTN","DGENUPL1",158,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",159,0)
 .I ($G(DATATYPE)="INSTITUTION") D  Q
"RTN","DGENUPL1",160,0)
 ..N OLDVAL
"RTN","DGENUPL1",161,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",162,0)
 ..S VAL=$O(^DIC(4,"D",OLDVAL,0))
"RTN","DGENUPL1",163,0)
 ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0))
"RTN","DGENUPL1",164,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",165,0)
 .I ($G(DATATYPE)="POS") D  Q
"RTN","DGENUPL1",166,0)
 ..N OLDVAL
"RTN","DGENUPL1",167,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",168,0)
 ..S VAL=$O(^DIC(21,"D",OLDVAL,0))
"RTN","DGENUPL1",169,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",170,0)
 .I ($G(DATATYPE)="AGENCY") D  Q
"RTN","DGENUPL1",171,0)
 ..N OLDVAL
"RTN","DGENUPL1",172,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",173,0)
 ..S VAL=$O(^DIC(35,"C",OLDVAL,0))
"RTN","DGENUPL1",174,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",175,0)
 Q VAL
"RTN","DGENUPL1",176,0)
 ;
"RTN","DGENUPL1",177,0)
MAP(VALUE) ;
"RTN","DGENUPL1",178,0)
 ;Description: Tries to map an eligibility code from file #8.1 (the national MAS ELIGIBILITY CODE file) to file #8 (the local ELIGIBILITY CODE file)
"RTN","DGENUPL1",179,0)
 ;
"RTN","DGENUPL1",180,0)
 ;Input: VALUE - ien of an entry in file #8.1
"RTN","DGENUPL1",181,0)
 ;
"RTN","DGENUPL1",182,0)
 ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8
"RTN","DGENUPL1",183,0)
 ;
"RTN","DGENUPL1",184,0)
 N ECODE,NODE,COUNT,NAME
"RTN","DGENUPL1",185,0)
 ;try to choose a code from file 8 to use that is appropriate
"RTN","DGENUPL1",186,0)
 S (COUNT,ECODE)=0
"RTN","DGENUPL1",187,0)
 ;
"RTN","DGENUPL1",188,0)
 F  S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE  D
"RTN","DGENUPL1",189,0)
 .S NODE=$G(^DIC(8,ECODE,0))
"RTN","DGENUPL1",190,0)
 .;put code on list if active
"RTN","DGENUPL1",191,0)
 .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1
"RTN","DGENUPL1",192,0)
 ;
"RTN","DGENUPL1",193,0)
 ;only one match found, so use it
"RTN","DGENUPL1",194,0)
 Q:COUNT=1 $O(ECODE(0))
"RTN","DGENUPL1",195,0)
 ;
"RTN","DGENUPL1",196,0)
 ;no match found
"RTN","DGENUPL1",197,0)
 Q:'COUNT ""
"RTN","DGENUPL1",198,0)
 ;
"RTN","DGENUPL1",199,0)
 ;multiple matches found, try to match by name
"RTN","DGENUPL1",200,0)
 I COUNT>1 D
"RTN","DGENUPL1",201,0)
 .S ECODE=0
"RTN","DGENUPL1",202,0)
 .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^")
"RTN","DGENUPL1",203,0)
 .F  S ECODE=$O(ECODE(ECODE)) Q:'ECODE  Q:ECODE(ECODE)=NAME
"RTN","DGENUPL1",204,0)
 Q ECODE
"RTN","DGENUPL1",205,0)
 ;
"RTN","DGENUPL1",206,0)
ACCEPT(MSGID) ;
"RTN","DGENUPL1",207,0)
 ;Description: Writes an ack (AA) to a global to be transmitted later.
"RTN","DGENUPL1",208,0)
 ;
"RTN","DGENUPL1",209,0)
 ;Inputs:
"RTN","DGENUPL1",210,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",211,0)
 ;
"RTN","DGENUPL1",212,0)
 ;Outputs: none
"RTN","DGENUPL1",213,0)
 ;
"RTN","DGENUPL1",214,0)
 K HL,HLMID,HLMTIEN,HLDT,HLDT1
"RTN","DGENUPL1",215,0)
 D INIT^HLFNC2(HLEID,.HL)
"RTN","DGENUPL1",216,0)
 D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
"RTN","DGENUPL1",217,0)
 S HLEVN=1
"RTN","DGENUPL1",218,0)
 S MID=HLMID_"-"_HLEVN
"RTN","DGENUPL1",219,0)
 D MSH^HLFNC2(.HL,MID,.HLRES)
"RTN","DGENUPL1",220,0)
 S ^TMP("HLS",$J,1)=HLRES
"RTN","DGENUPL1",221,0)
 ;
"RTN","DGENUPL1",222,0)
 ;it seems HLFS sometimes disappears upon reaching this point
"RTN","DGENUPL1",223,0)
 I $G(HLFS)="" S HLFS="^"
"RTN","DGENUPL1",224,0)
 ;
"RTN","DGENUPL1",225,0)
 S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID
"RTN","DGENUPL1",226,0)
 Q
"RTN","DGENUPL1",227,0)
 ;
"RTN","DGENUPL1",228,0)
MVERRORS ;
"RTN","DGENUPL1",229,0)
 ;Error messages were being deleted from ^TMP("HLS",$J by another package
"RTN","DGENUPL1",230,0)
 ;during the upload.  To fix this, errors are written to another
"RTN","DGENUPL1",231,0)
 ;subscript, then moved when the error list is complete.
"RTN","DGENUPL1",232,0)
 ;
"RTN","DGENUPL1",233,0)
 M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",234,0)
 K ^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",235,0)
 Q
"RTN","DGENUPL3")
0^29^B71805311
"RTN","DGENUPL3",1,0)
DGENUPL3 ;ALB/CJM,ISA/KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 6/4/09 4:09pm
"RTN","DGENUPL3",2,0)
 ;;5.3;REGISTRATION;**147,230,232,377,404,451,653,688,793,797**;Aug 13,1993;Build 24
"RTN","DGENUPL3",3,0)
 ;
"RTN","DGENUPL3",4,0)
 ;
"RTN","DGENUPL3",5,0)
ADDMSG(MSGS,MESSAGE,TOHEC) ;
"RTN","DGENUPL3",6,0)
 ;Description: Used to add a message to an array of messages to be sent.
"RTN","DGENUPL3",7,0)
 ;
"RTN","DGENUPL3",8,0)
 ;Input:
"RTN","DGENUPL3",9,0)
 ;  MSGS - the array to store the message (pass by reference)
"RTN","DGENUPL3",10,0)
 ;  MESSAGE - the message to store
"RTN","DGENUPL3",11,0)
 ;  TOHEC - a flag, if set to 1 it means that HEC should also receive notification
"RTN","DGENUPL3",12,0)
 ;
"RTN","DGENUPL3",13,0)
 ;Output: none
"RTN","DGENUPL3",14,0)
 ;
"RTN","DGENUPL3",15,0)
 I MESSAGE["DATE OF DEATH" Q
"RTN","DGENUPL3",16,0)
 S MSGS(0)=($G(MSGS(0))+1)
"RTN","DGENUPL3",17,0)
 S MSGS(MSGS(0))=MESSAGE
"RTN","DGENUPL3",18,0)
 I ($G(TOHEC)=1) S MSGS("HEC")=1
"RTN","DGENUPL3",19,0)
 Q
"RTN","DGENUPL3",20,0)
 ;
"RTN","DGENUPL3",21,0)
 ;
"RTN","DGENUPL3",22,0)
NOTIFY(DGPAT,MSGS) ;
"RTN","DGENUPL3",23,0)
 ;Description: This is used to send a message to the local mail group
"RTN","DGENUPL3",24,0)
 ;defined by the MAS Parameter ELIGIBILITY UPLOAD MAIL GROUP.The
"RTN","DGENUPL3",25,0)
 ;notification is to be used when specific problems or conditions
"RTN","DGENUPL3",26,0)
 ;regarding the upload of the enrollment or eligibility data.
"RTN","DGENUPL3",27,0)
 ;
"RTN","DGENUPL3",28,0)
 ;Input: 
"RTN","DGENUPL3",29,0)
 ;  OLDPAT -used if the DGPAT elements have not been built
"RTN","DGENUPL3",30,0)
 ;  DGPAT - patient array (pass by reference)
"RTN","DGENUPL3",31,0)
 ;  MSGS - the an array of messages that should be included in the
"RTN","DGENUPL3",32,0)
 ;         notification (pass by reference). If MSGS("HEC")=1
"RTN","DGENUPL3",33,0)
 ;         it means that HEC should also receive notification.
"RTN","DGENUPL3",34,0)
 ;
"RTN","DGENUPL3",35,0)
 ;Output:   none
"RTN","DGENUPL3",36,0)
 ;
"RTN","DGENUPL3",37,0)
 N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT
"RTN","DGENUPL3",38,0)
 N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD
"RTN","DGENUPL3",39,0)
 ;
"RTN","DGENUPL3",40,0)
 ;if there are no alerts, then quit
"RTN","DGENUPL3",41,0)
 Q:'$G(MSGS(0))
"RTN","DGENUPL3",42,0)
 ;
"RTN","DGENUPL3",43,0)
 ;Get reason for alert.  If there is more than one reason decide which 
"RTN","DGENUPL3",44,0)
 ;reason to display.  'NON-SERVICE' alerts have a higher priority than
"RTN","DGENUPL3",45,0)
 ;other alerts and are therefore displayed before other alerts in the 
"RTN","DGENUPL3",46,0)
 ;subject line, followed by 'POW' alerts in priority.
"RTN","DGENUPL3",47,0)
 S (ELIG,NSC,POW,CD)=0
"RTN","DGENUPL3",48,0)
 S COUNT=0 F  S COUNT=$O(MSGS(COUNT)) Q:'COUNT!NSC  D
"RTN","DGENUPL3",49,0)
 .I MSGS(COUNT)["PREVIOUSLY ELIGIBLE" S ELIG=1 Q
"RTN","DGENUPL3",50,0)
 .I MSGS(COUNT)["NON-SERVICE" S NSC=1 Q
"RTN","DGENUPL3",51,0)
 .I MSGS(COUNT)["POW" S POW=1 Q
"RTN","DGENUPL3",52,0)
 .I MSGS(COUNT)["CD EVALUATION" S CD=1 Q
"RTN","DGENUPL3",53,0)
 .S HEADER=MSGS(COUNT)
"RTN","DGENUPL3",54,0)
 .Q
"RTN","DGENUPL3",55,0)
 D
"RTN","DGENUPL3",56,0)
 .I ELIG S HEADER="Ineligibility Alert: " Q
"RTN","DGENUPL3",57,0)
 .I NSC S HEADER="NSC Alert: " Q
"RTN","DGENUPL3",58,0)
 .I POW&'NSC S HEADER="POW Alert: " Q
"RTN","DGENUPL3",59,0)
 .I CD S HEADER="CD Alert: " Q
"RTN","DGENUPL3",60,0)
 .Q
"RTN","DGENUPL3",61,0)
 ;
"RTN","DGENUPL3",62,0)
 S XMDF=""
"RTN","DGENUPL3",63,0)
 S (XMDUN,XMDUZ)="Registration Enrollment Module"
"RTN","DGENUPL3",64,0)
 ;Phase II Re-Enrollment
"RTN","DGENUPL3",65,0)
 ;DGPAT("SSN") is built by the parser.  DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT.
"RTN","DGENUPL3",66,0)
 ;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge. 
"RTN","DGENUPL3",67,0)
 I '$D(DGPAT("NAME")) S DGPAT("NAME")=$G(OLDPAT("NAME"))
"RTN","DGENUPL3",68,0)
 I '$D(DGPAT("SEX")) S DGPAT("SEX")=$G(OLDPAT("SEX"))
"RTN","DGENUPL3",69,0)
 I '$D(DGPAT("DOB")) S DGPAT("DOB")=$G(OLDPAT("DOB"))
"RTN","DGENUPL3",70,0)
 S TMPSTR=" ("_$E(DGPAT("NAME"),1,1)
"RTN","DGENUPL3",71,0)
 S TMPSTR=TMPSTR_$E(DGPAT("SSN"),$L(DGPAT("SSN"))-3,1000)_")"
"RTN","DGENUPL3",72,0)
 S XMSUB=$E(HEADER,1,30)_$E(DGPAT("NAME"),1,25)_TMPSTR
"RTN","DGENUPL3",73,0)
 ;
"RTN","DGENUPL3",74,0)
 ; send msg to local mail group specified in IVM SITE PARAMETER file
"RTN","DGENUPL3",75,0)
 S MAILGRP=+$P($G(^IVM(301.9,1,0)),"^",9)
"RTN","DGENUPL3",76,0)
 S MAILGRP=$$EXTERNAL^DILFD(301.9,.09,"F",MAILGRP)
"RTN","DGENUPL3",77,0)
 I MAILGRP]"" S XMY("G."_MAILGRP)=""
"RTN","DGENUPL3",78,0)
 ;
"RTN","DGENUPL3",79,0)
 ; if flag is set, send msg to remote mail group specified in
"RTN","DGENUPL3",80,0)
 ; the IVM SITE PARAMETER file
"RTN","DGENUPL3",81,0)
 I $G(MSGS("HEC"))=1 D
"RTN","DGENUPL3",82,0)
 .S MAILGRP=$P($G(^IVM(301.9,1,0)),"^",10)
"RTN","DGENUPL3",83,0)
 .S MAILGRP=$$EXTERNAL^DILFD(301.9,.10,"F",MAILGRP)
"RTN","DGENUPL3",84,0)
 .I MAILGRP]"" S XMY("G."_MAILGRP)=""
"RTN","DGENUPL3",85,0)
 ;
"RTN","DGENUPL3",86,0)
 ;
"RTN","DGENUPL3",87,0)
 S XMTEXT="TEXT("
"RTN","DGENUPL3",88,0)
 S TEXT(1)="The enrollment/eligibility upload produced the following alerts:"
"RTN","DGENUPL3",89,0)
 S TEXT(2)="  "
"RTN","DGENUPL3",90,0)
 S TEXT(3)="Patient Name   :     "_DGPAT("NAME")
"RTN","DGENUPL3",91,0)
 S TEXT(4)="SSN            :     "_DGPAT("SSN")
"RTN","DGENUPL3",92,0)
 S TEXT(5)="DOB            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB"))
"RTN","DGENUPL3",93,0)
 S TEXT(6)="SEX            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX"))
"RTN","DGENUPL3",94,0)
 S TEXT(7)=" "
"RTN","DGENUPL3",95,0)
 ;
"RTN","DGENUPL3",96,0)
 S TEXT(8)=" ** Alerts **"
"RTN","DGENUPL3",97,0)
 S TEXT(9)=" "
"RTN","DGENUPL3",98,0)
 S COUNT=0 F  S COUNT=$O(MSGS(COUNT)) Q:'COUNT  S TEXT(10+COUNT)=COUNT_") "_MSGS(COUNT)
"RTN","DGENUPL3",99,0)
 ;
"RTN","DGENUPL3",100,0)
 D ^XMD
"RTN","DGENUPL3",101,0)
 Q
"RTN","DGENUPL3",102,0)
 ;
"RTN","DGENUPL3",103,0)
BEGUPLD(DFN) ;
"RTN","DGENUPL3",104,0)
 ;Description: Sets a lock used to determine if an eligibility/enrollment
"RTN","DGENUPL3",105,0)
 ;upload is in progress. 
"RTN","DGENUPL3",106,0)
 ;
"RTN","DGENUPL3",107,0)
 ;Input:
"RTN","DGENUPL3",108,0)
 ;   DFN - ien, Patient record
"RTN","DGENUPL3",109,0)
 ;
"RTN","DGENUPL3",110,0)
 ;Output:
"RTN","DGENUPL3",111,0)
 ;  Function value - returns 1 if the lock was obtained, 0 otherwise.
"RTN","DGENUPL3",112,0)
 ;
"RTN","DGENUPL3",113,0)
 Q:'$G(DFN) 1
"RTN","DGENUPL3",114,0)
 L +^DGEN("ELIGIBILITY UPLOAD",DFN):3
"RTN","DGENUPL3",115,0)
 Q $T
"RTN","DGENUPL3",116,0)
 ;
"RTN","DGENUPL3",117,0)
ENDUPLD(DFN) ;
"RTN","DGENUPL3",118,0)
 ;Description: Releases the lock obtained by calling $$BEGUPLD(DFN)
"RTN","DGENUPL3",119,0)
 ;
"RTN","DGENUPL3",120,0)
 Q:'$G(DFN)
"RTN","DGENUPL3",121,0)
 L -^DGEN("ELIGIBILITY UPLOAD",DFN)
"RTN","DGENUPL3",122,0)
 Q
"RTN","DGENUPL3",123,0)
 ;
"RTN","DGENUPL3",124,0)
CKUPLOAD(DFN) ;
"RTN","DGENUPL3",125,0)
 ;Description: Checks if an upload is in progress.  If so, it pauses
"RTN","DGENUPL3",126,0)
 ;until it is completed.
"RTN","DGENUPL3",127,0)
 ;The enrollment/eligibility upload can take a while to accomplish.
"RTN","DGENUPL3",128,0)
 ;If the lock is not obtained initially, it is assumed that the upload
"RTN","DGENUPL3",129,0)
 ;is in progress, and a message is displayed to the user.
"RTN","DGENUPL3",130,0)
 ;
"RTN","DGENUPL3",131,0)
 ;Input: DFN
"RTN","DGENUPL3",132,0)
 ;Output: none
"RTN","DGENUPL3",133,0)
 ;
"RTN","DGENUPL3",134,0)
 N I
"RTN","DGENUPL3",135,0)
 I '$$BEGUPLD(DFN) D
"RTN","DGENUPL3",136,0)
 .W !!,"Upload of patient enrollment/eligibility data is in progress ..."
"RTN","DGENUPL3",137,0)
 .D UNLOCK^DGENPTA1(DFN)
"RTN","DGENUPL3",138,0)
 .F I=1:1:50 Q:$$BEGUPLD(DFN)  W "."
"RTN","DGENUPL3",139,0)
 .W !,"Upload of patient enrollment/eligibility data is completed.",!
"RTN","DGENUPL3",140,0)
 D ENDUPLD(DFN)
"RTN","DGENUPL3",141,0)
 Q
"RTN","DGENUPL3",142,0)
SCVET ;moved from DGENUPL4 - DG*5.3*688
"RTN","DGENUPL3",143,0)
 I DGPAT3("VETERAN")'="N" D
"RTN","DGENUPL3",144,0)
 . I DGELG3("SC")="N" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","NSC VETERAN",0))
"RTN","DGENUPL3",145,0)
 . I DGELG3("SC")="Y" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","SC VETERAN",0))
"RTN","DGENUPL3",146,0)
 I DGPAT3("VETERAN")="N" S DGPAT3("PATYPE")=$$NONVET(DGELG("ELIG","CODE"))
"RTN","DGENUPL3",147,0)
 Q
"RTN","DGENUPL3",148,0)
 ;
"RTN","DGENUPL3",149,0)
NONVET(DGCODE) ;map Patient Type from Primary Elig (and POS)
"RTN","DGENUPL3",150,0)
 ;added with DG*5.3*688 - ERC
"RTN","DGENUPL3",151,0)
 ; input:         DGCODE is the Primary Eligibility code
"RTN","DGENUPL3",152,0)
 ; output:        DGTPYE is returned as the value for Patient Type
"RTN","DGENUPL3",153,0)
 N PTELG,DGTYPE
"RTN","DGENUPL3",154,0)
 S (PTELG,DGTYPE)=""
"RTN","DGENUPL3",155,0)
 Q:$G(DGCODE)']"" ""
"RTN","DGENUPL3",156,0)
 S PTELG=$$NATNAME^DGENELA(DGCODE)
"RTN","DGENUPL3",157,0)
 Q:$G(PTELG)']"" ""
"RTN","DGENUPL3",158,0)
 I "CHAMPVA^OTHER FEDERAL AGENCY^REIMBURSABLE INSURANCE^SHARING AGREEMENT"[PTELG S DGTYPE=$$POS(.DGTYPE) Q:DGTYPE DGTYPE
"RTN","DGENUPL3",159,0)
 S DGTYPE=$S(PTELG["ALLIED":"ALLIED VETERAN",PTELG["COLLATERAL":"COLLATERAL",PTELG["EMPLOYEE":"EMPLOYEE",PTELG["TRICARE":"TRICARE",1:"")
"RTN","DGENUPL3",160,0)
 I DGTYPE']"" S DGTYPE="NON-VETERAN (OTHER)" ;default Pat Type
"RTN","DGENUPL3",161,0)
 S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
"RTN","DGENUPL3",162,0)
 Q DGTYPE
"RTN","DGENUPL3",163,0)
POS(DGTYPE) ;for these Elig Codes, check POS to determine Patient Type
"RTN","DGENUPL3",164,0)
 S DGPOS=DGELG("POS")
"RTN","DGENUPL3",165,0)
 I $G(DGPOS)']"" Q ""
"RTN","DGENUPL3",166,0)
 I '$D(^DIC(21,DGPOS,0)) Q ""
"RTN","DGENUPL3",167,0)
 S DGPOS=$P(^DIC(21,DGPOS,0),U)
"RTN","DGENUPL3",168,0)
 S DGTYPE=$S(DGPOS["ACTIVE":"ACTIVE DUTY",DGPOS["OPERAT":"ACTIVE DUTY",DGPOS["RETIR":"MILITARY RETIREE",1:"")
"RTN","DGENUPL3",169,0)
 I $G(DGTYPE)]"" S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
"RTN","DGENUPL3",170,0)
 Q DGTYPE
"RTN","DGENUPL3",171,0)
 ;
"RTN","DGENUPL3",172,0)
 ;ZMH code moved here from DGENUPL2 - DG*5.3*653
"RTN","DGENUPL3",173,0)
ZMH ;Purple Heart, POW, OEF/OIF Conflict Loc, Military Service Episodes
"RTN","DGENUPL3",174,0)
 ;PROCESS PH, OEF/OIF & POW FROM ZMH
"RTN","DGENUPL3",175,0)
 ;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797
"RTN","DGENUPL3",176,0)
 I "^SL^SNL^SNNL^MSD^"[("^"_SEG(2)_"^") D  Q
"RTN","DGENUPL3",177,0)
 . N BOS,SN,DIS,SED,SSD,COM
"RTN","DGENUPL3",178,0)
 . S BOS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))  ;Service Branch
"RTN","DGENUPL3",179,0)
 . S:BOS]"" BOS=$O(^DIC(23,"B",BOS,""))
"RTN","DGENUPL3",180,0)
 . S SN=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))  ;Service Number
"RTN","DGENUPL3",181,0)
 . S DIS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3))  ;Discharge Type
"RTN","DGENUPL3",182,0)
 . S:DIS]"" DIS=$O(^DIC(25,"B",DIS,""))
"RTN","DGENUPL3",183,0)
 . S SED=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE")  ;Entry Date
"RTN","DGENUPL3",184,0)
 . I 'SED!ERROR D  Q
"RTN","DGENUPL3",185,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SERVICE ENTRY DATE",.ERRCOUNT)
"RTN","DGENUPL3",186,0)
 . S SSD=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE")  ;Sep. Date
"RTN","DGENUPL3",187,0)
 . S COM=$$CONVERT^DGENUPL1($P(SEG(5),$E(HLECH)))  ;Service Component
"RTN","DGENUPL3",188,0)
 . S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1
"RTN","DGENUPL3",189,0)
 ;
"RTN","DGENUPL3",190,0)
 I SEG(2)="PH" D  Q  ;Process Purple Heart from ZMH
"RTN","DGENUPL3",191,0)
 . S DGPAT("PHI")=$P(SEG(3),$E(HLECH))
"RTN","DGENUPL3",192,0)
 . S DGELG("PH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",193,0)
 . S DGPAT("PHST")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
"RTN","DGENUPL3",194,0)
 . S DGPAT("PHRR")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3))
"RTN","DGENUPL3",195,0)
 ;
"RTN","DGENUPL3",196,0)
 I SEG(2)="OEIF" D  Q
"RTN","DGENUPL3",197,0)
 . N OEIFLOC
"RTN","DGENUPL3",198,0)
 . S OEIFLOC=$P(SEG(3),$E(HLECH))
"RTN","DGENUPL3",199,0)
 . I OEIFLOC="Conflict Unspecified" Q   ;Ignore these entries
"RTN","DGENUPL3",200,0)
 . I OEIFLOC="Unknown OEF/OIF" S OEIFLOC="UNK"
"RTN","DGENUPL3",201,0)
 . S OEIFLOC=$E(OEIFLOC,1,3)
"RTN","DGENUPL3",202,0)
 . Q:((OEIFLOC'="OIF")&(OEIFLOC'="OEF")&(OEIFLOC'="UNK"))
"RTN","DGENUPL3",203,0)
 . S DGOEIF("COUNT")=$G(DGOEIF("COUNT"))+1
"RTN","DGENUPL3",204,0)
 . S DGOEIF("LOC",DGOEIF("COUNT"))=OEIFLOC
"RTN","DGENUPL3",205,0)
 . S DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2),"INSTITUTION")
"RTN","DGENUPL3",206,0)
 . S DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE")
"RTN","DGENUPL3",207,0)
 . S DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE")
"RTN","DGENUPL3",208,0)
 . S DGOEIF("LOCK",DGOEIF("COUNT"))=1
"RTN","DGENUPL3",209,0)
 ;
"RTN","DGENUPL3",210,0)
 I SEG(2)="POW" D  ;Process POW from ZMH
"RTN","DGENUPL3",211,0)
 . S DGPAT("POWI")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;POW STATUS INDICATED
"RTN","DGENUPL3",212,0)
 . S DGELG("POW")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",213,0)
 . S DGPAT("POWLOC")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
"RTN","DGENUPL3",214,0)
 . I DGPAT("POWLOC")'="@" S DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR) ;POW CONFINEMENT LOCATION
"RTN","DGENUPL3",215,0)
 . I ERROR D  Q
"RTN","DGENUPL3",216,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT)
"RTN","DGENUPL3",217,0)
 . S DGPAT("POWFDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE",.ERROR) ;POW FROM DATE
"RTN","DGENUPL3",218,0)
 . I ERROR D  Q
"RTN","DGENUPL3",219,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT)
"RTN","DGENUPL3",220,0)
 . S DGPAT("POWTDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;POW TO DATE
"RTN","DGENUPL3",221,0)
 . I ERROR D  Q
"RTN","DGENUPL3",222,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT)
"RTN","DGENUPL3",223,0)
 Q
"RTN","DGENUPL3",224,0)
POWLOC(LOC,ERROR) ;POW Confinement Location mapping with HL7 table VA023
"RTN","DGENUPL3",225,0)
 ;  Input: LOC - HL7 code for location
"RTN","DGENUPL3",226,0)
 ; Output: ERROR - Return error 1 on failure
"RTN","DGENUPL3",227,0)
 ;         IEN22 - IEN of file 22
"RTN","DGENUPL3",228,0)
 N TBL023
"RTN","DGENUPL3",229,0)
 S ERROR=0
"RTN","DGENUPL3",230,0)
 I LOC="" S ERROR=1 Q ""
"RTN","DGENUPL3",231,0)
 S TBL023(4)="WWI",TBL023(5)="WWII-EUROPE",TBL023(6)="WWII-PACIFIC"
"RTN","DGENUPL3",232,0)
 S TBL023(7)="KOREAN",TBL023(8)="VIETNAM",TBL023(9)="OTHER"
"RTN","DGENUPL3",233,0)
 S TBL023("A")="PERSIAN GULF",TBL023("B")="YUGOSLAVIA"
"RTN","DGENUPL3",234,0)
 S IEN22=$O(^DIC(22,"C",TBL023(LOC),""))
"RTN","DGENUPL3",235,0)
 I IEN22="" S ERROR=1
"RTN","DGENUPL3",236,0)
 Q IEN22
"RTN","DGENUPL3",237,0)
 ;
"RTN","DGENUPL7")
0^30^B33592868
"RTN","DGENUPL7",1,0)
DGENUPL7 ;ISA/KWP/CKN/TMK,TDM,LBD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 8/1/11 5:07pm
"RTN","DGENUPL7",2,0)
 ;;5.3;REGISTRATION;**232,367,397,417,379,431,513,628,673,653,742,688,797**;Aug 13,1993;Build 24
"RTN","DGENUPL7",3,0)
 ;Phase II split from DGENUPL
"RTN","DGENUPL7",4,0)
Z11(MSGIEN,MSGID,CURLINE,DFN,ERRCOUNT) ;
"RTN","DGENUPL7",5,0)
 ;Description:  This is used to process a single ORU~Z11 or ORF~Z11 msg. 
"RTN","DGENUPL7",6,0)
 ;Input:
"RTN","DGENUPL7",7,0)
 ;  MSGIEN - the internal entry number of the HL7 message in the
"RTN","DGENUPL7",8,0)
 ;      HL7 MESSAGE TEXT file (772)
"RTN","DGENUPL7",9,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL7",10,0)
 ;  CURLINE - the subscript of the MSH segment of the current message (pass by reference)
"RTN","DGENUPL7",11,0)
 ;  DFN - identifies the patient, is the ien of a record in the PATIENT file.
"RTN","DGENUPL7",12,0)
 ;  ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by reference)
"RTN","DGENUPL7",13,0)
 ;
"RTN","DGENUPL7",14,0)
 ;Output:
"RTN","DGENUPL7",15,0)
 ;  CURLINE - upon leaving the procedure this parameter should be set to the end of the current message. (pass by reference)
"RTN","DGENUPL7",16,0)
 ;  ERRCOUNT - set to count of messages that were not processed due to errors encountered  (pass by reference)
"RTN","DGENUPL7",17,0)
 ;
"RTN","DGENUPL7",18,0)
 N DGELG,DGENR,DGPAT,DGCDIS,DGOEIF,ERROR,ERRMSG,MSGS,DGELGSUB,DGENUPLD,DGCON,DGNMSE
"RTN","DGENUPL7",19,0)
 N DGNEWVAL,DIV,SUB,OLDELG,OLDPAT,OLDDCDIS,OLDEIF,DGSEC,OLDSEC,DGNTR,DGMST,DGPHINC
"RTN","DGENUPL7",20,0)
 ;
"RTN","DGENUPL7",21,0)
 ;some process is killing these HL7 variables, so need to protect them
"RTN","DGENUPL7",22,0)
 S SUB=HLFS
"RTN","DGENUPL7",23,0)
 S DIV=HLECH
"RTN","DGENUPL7",24,0)
 N HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLECH,HLFS,HLNDAP,HLNDAP0,HLPID,HLQ,HLVER,HLERR,HLMTN,HLSDT
"RTN","DGENUPL7",25,0)
 S HLFS=SUB
"RTN","DGENUPL7",26,0)
 S HLECH=DIV
"RTN","DGENUPL7",27,0)
 S HLQ=""""""
"RTN","DGENUPL7",28,0)
 K DIV,SUB
"RTN","DGENUPL7",29,0)
 ;
"RTN","DGENUPL7",30,0)
 ;drops out of block on error
"RTN","DGENUPL7",31,0)
 D
"RTN","DGENUPL7",32,0)
 .Q:'$$PARSE^DGENUPL1(MSGIEN,MSGID,.CURLINE,.ERRCOUNT,.DGPAT,.DGELG,.DGENR,.DGCDIS,.DGOEIF,.DGSEC,.DGNTR,.DGMST,.DGNMSE)
"RTN","DGENUPL7",33,0)
 .D GETLOCKS^DGENUPL5(DFN)
"RTN","DGENUPL7",34,0)
 .;
"RTN","DGENUPL7",35,0)
 .;Used by cross-references to determine if an upload is in progress.
"RTN","DGENUPL7",36,0)
 .S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
"RTN","DGENUPL7",37,0)
 .;
"RTN","DGENUPL7",38,0)
 .;Update the PATIENT, ELIGIBILITY, CATASTROPHIC DISABILITY objects in memory
"RTN","DGENUPL7",39,0)
 .Q:'$$UOBJECTS^DGENUPL4(DFN,.DGPAT,.DGELG,.DGCDIS,.DGOEIF,MSGID,.ERRCOUNT,.MSGS,.OLDPAT,.OLDELG,.OLDCDIS,.OLDEIF)
"RTN","DGENUPL7",40,0)
 .S ERROR=0
"RTN","DGENUPL7",41,0)
 .;if the msg contains patient security, process it
"RTN","DGENUPL7",42,0)
 .I $D(DGSEC) D  Q:ERROR
"RTN","DGENUPL7",43,0)
 ..S DGSEC("DFN")=DFN
"RTN","DGENUPL7",44,0)
 ..S DGSEC("USER")=.5
"RTN","DGENUPL7",45,0)
 ..I DGSEC("LEVEL")'="" D
"RTN","DGENUPL7",46,0)
 ...I DGSEC("DATETIME")="" S DGSEC("DATETIME")=$$NOW^XLFDT ;DG*5.3*653 
"RTN","DGENUPL7",47,0)
 ..;
"RTN","DGENUPL7",48,0)
 ..; check consistency of patient security record
"RTN","DGENUPL7",49,0)
 ..I '$$CHECK^DGENSEC(.DGSEC,.ERRMSG) D  Q
"RTN","DGENUPL7",50,0)
 ...S ERROR=1
"RTN","DGENUPL7",51,0)
 ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL7",52,0)
 ..;
"RTN","DGENUPL7",53,0)
 ..; upload patient security, consistency checks passed
"RTN","DGENUPL7",54,0)
 ..D SECUPLD^DGENUPL5(DFN,.DGSEC,.OLDSEC)
"RTN","DGENUPL7",55,0)
 .;
"RTN","DGENUPL7",56,0)
 .;if the msg has an enrollment process it
"RTN","DGENUPL7",57,0)
 .I DGENR("STATUS")!DGENR("APP") D  Q:ERROR
"RTN","DGENUPL7",58,0)
 ..;use $$PRIORITY to get the eligibility data used to compute priority
"RTN","DGENUPL7",59,0)
 ..I $$PRIORITY^DGENELA4(DFN,.DGELG,.DGELGSUB,DGENR("DATE"),DGENR("APP"))
"RTN","DGENUPL7",60,0)
 ..;
"RTN","DGENUPL7",61,0)
 ..;store the eligibility data in the enrollment record and other missing fields
"RTN","DGENUPL7",62,0)
 ..M DGENR("ELIG")=DGELGSUB
"RTN","DGENUPL7",63,0)
 ..S DGENR("DFN")=DFN
"RTN","DGENUPL7",64,0)
 ..S DGENR("PRIORREC")=""
"RTN","DGENUPL7",65,0)
 ..S DGENR("USER")=.5
"RTN","DGENUPL7",66,0)
 ..S DGENR("DATETIME")=$$NOW^XLFDT
"RTN","DGENUPL7",67,0)
 ..;
"RTN","DGENUPL7",68,0)
 ..;Allow null overwrites of Ineligible data (Ineligible Project):
"RTN","DGENUPL7",69,0)
 ..I $D(DGENR("DATE")),DGENR("DATE")="" S DGENR("DATE")="@"
"RTN","DGENUPL7",70,0)
 ..I $D(DGENR("FACREC")),DGENR("FACREC")="" S DGENR("FACREC")="@"
"RTN","DGENUPL7",71,0)
 ..;
"RTN","DGENUPL7",72,0)
 ..;check the consistency of the enrollment record
"RTN","DGENUPL7",73,0)
 ..I '$$CHECK^DGENA3(.DGENR,.DGPAT,.ERRMSG) D  Q
"RTN","DGENUPL7",74,0)
 ...S ERROR=1
"RTN","DGENUPL7",75,0)
 ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL7",76,0)
 ..;
"RTN","DGENUPL7",77,0)
 ..; removed EGT consistency check with DG*5.3*628
"RTN","DGENUPL7",78,0)
 ..;Phase II EGT consistency checks (SRS 6.5.1.3)
"RTN","DGENUPL7",79,0)
 ..;Only do the EGT consistency checks for Rejected-Fiscal Year (11),Rejected-Mid Cycle (12),Rejected-Stop enrolling new apps (13),Rejected-Initil App by VAMC (14),Rejected below EGT threshold (22)
"RTN","DGENUPL7",80,0)
 ..;I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$ABOVE^DGENEGT1(DGENR("DFN"),DGENR("PRIORITY"),DGENR("SUBGRP"),"","",1) D  Q
"RTN","DGENUPL7",81,0)
 ..;.S ERROR=1
"RTN","DGENUPL7",82,0)
 ..;.S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE EGT CONSISTENCY CHECKS."
"RTN","DGENUPL7",83,0)
 ..;.D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL7",84,0)
 ..;
"RTN","DGENUPL7",85,0)
 ..;Allow null overwrites for Ineligible vets (Ineligible Project):
"RTN","DGENUPL7",86,0)
 ..I $G(DGPAT("INELDATE"))'="" S (DGENR("PRIORITY"),DGENR("SUBGRP"))=""
"RTN","DGENUPL7",87,0)
 ..I DGENR("DATE")="@" S DGENR("DATE")=""
"RTN","DGENUPL7",88,0)
 ..I DGENR("FACREC")="@" S DGENR("FACREC")=""
"RTN","DGENUPL7",89,0)
 ..;
"RTN","DGENUPL7",90,0)
 ..D ENRUPLD^DGENUPL8(.DGENR,.DGPAT)
"RTN","DGENUPL7",91,0)
 .;
"RTN","DGENUPL7",92,0)
 .;Store the PATIENT, ELIGIBILITY, & CAT. DISB. objects
"RTN","DGENUPL7",93,0)
 .I $$STORE^DGENPTA1(.DGPAT,,1)
"RTN","DGENUPL7",94,0)
 .I $$STORE^DGENELA1(.DGELG,.DGPAT,.DGCDIS,,1)
"RTN","DGENUPL7",95,0)
 .I $G(DGCDIS("VCD"))'="",$$STORE^DGENCDA2(DFN,.DGCDIS) ;checks first if there is catastrophic disability information
"RTN","DGENUPL7",96,0)
 .;
"RTN","DGENUPL7",97,0)
 .;Call PIMS api to file NTR data.
"RTN","DGENUPL7",98,0)
 .I $D(DGNTR),$$ENRUPD^DGNTAPI1(DFN,.DGNTR)
"RTN","DGENUPL7",99,0)
 .;
"RTN","DGENUPL7",100,0)
 .;Call PIMS api to file MST data.
"RTN","DGENUPL7",101,0)
 .I DGMST("MSTSTAT")'="",DGMST("MSTDT")'="",DGMST("MSTST")'="" D
"RTN","DGENUPL7",102,0)
 ..I $$NEWSTAT^DGMSTAPI(DFN,DGMST("MSTSTAT"),DGMST("MSTDT"),".5",DGMST("MSTST"),0)
"RTN","DGENUPL7",103,0)
 .;
"RTN","DGENUPL7",104,0)
 .;Since HEC is authoritative source, If no OEF/OIF data in Z11, set count to 0 so existing data in VistA will be deleted.
"RTN","DGENUPL7",105,0)
 .I '$D(DGOEIF) S DGOEIF("COUNT")=0
"RTN","DGENUPL7",106,0)
 .;Call PIMS api to file OEF/OIF data.
"RTN","DGENUPL7",107,0)
 .I $D(DGOEIF) D OEIFUPD^DGCLAPI1(DFN,.DGOEIF)
"RTN","DGENUPL7",108,0)
 .;
"RTN","DGENUPL7",109,0)
 .;File the Military Service Episode (MSE) data (DG*5.3*797)
"RTN","DGENUPL7",110,0)
 .I $D(DGNMSE) D UPDMSE^DGMSEUTL(DFN,.DGNMSE)
"RTN","DGENUPL7",111,0)
 .;
"RTN","DGENUPL7",112,0)
 .;if the current enrollment is a local then log patient for transmission
"RTN","DGENUPL7",113,0)
 .I $$SOURCE^DGENA(DFN)=1!$G(DGPHINC) K DGENUPLD,DGPHINC D EVENT^IVMPLOG(DFN)
"RTN","DGENUPL7",114,0)
 .;
"RTN","DGENUPL7",115,0)
 .;create the audit trail
"RTN","DGENUPL7",116,0)
 .I $$AUDIT^DGENUPA1(,MSGID,.OLDPAT,.DGPAT,.OLDELG,.DGELG,.OLDCDIS,.DGCDIS,.DGSEC,.OLDSEC)
"RTN","DGENUPL7",117,0)
 .;send notifications
"RTN","DGENUPL7",118,0)
 .D NOTIFY^DGENUPL3(.DGPAT,.MSGS)
"RTN","DGENUPL7",119,0)
 .;
"RTN","DGENUPL7",120,0)
 .;invoke registration consistency checker
"RTN","DGENUPL7",121,0)
 .D REGCHECK^DGENUPL2(DFN)
"RTN","DGENUPL7",122,0)
 ;
"RTN","DGENUPL7",123,0)
 D UNLOCK^DGENUPL5(DFN)
"RTN","DGENUPL7",124,0)
 Q
"RTN","DGLOCK")
0^6^B53456898
"RTN","DGLOCK",1,0)
DGLOCK ;ALB/MRL,ERC,BAJ,LBD - PATIENT FILE DATA EDIT CHECKS ; 2/14/11 4:36pm
"RTN","DGLOCK",2,0)
 ;;5.3;Registration;**108,161,247,485,672,673,688,754,797**;Aug 13, 1993;Build 24
"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","DGLOCK",193,0)
MSE ;Military Service Episode data cannot be edited once it has been
"RTN","DGLOCK",194,0)
 ;verified by the HEC
"RTN","DGLOCK",195,0)
 ;DG*5.3*797
"RTN","DGLOCK",196,0)
 I "NU"'[$E(X) D VET Q:'$D(X)
"RTN","DGLOCK",197,0)
 I $P($G(^DPT(DFN,.3216,DA,0)),U,7)=1 D EN^DDIOL("MSE data verified at the HEC...NO EDITING!!","","!?4") K X
"RTN","DGLOCK",198,0)
 Q
"RTN","DGMSCK")
0^23^B10563594
"RTN","DGMSCK",1,0)
DGMSCK ;ALB/PJR,LBD - CONSISTENCY API'S FROM DGRPC3 ; 5/20/09 5:33pm
"RTN","DGMSCK",2,0)
 ;;5.3;Registration;**451,797**;Mar 12, 2004;Build 24
"RTN","DGMSCK",3,0)
0 Q  ;; Must be called at a tag (API)
"RTN","DGMSCK",4,0)
 ;;
"RTN","DGMSCK",5,0)
MSCK(MSECHK) ;; Check MSE API
"RTN","DGMSCK",6,0)
 N I1,I2,MSE
"RTN","DGMSCK",7,0)
 S (MSERR,MSDATERR)=0,ANYMSE=""
"RTN","DGMSCK",8,0)
 ;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
"RTN","DGMSCK",9,0)
 I $D(DGPMSE) D  Q 1
"RTN","DGMSCK",10,0)
 .S I1=0 F  S I1=$O(DGPMSE(I1)) Q:'I1  D
"RTN","DGMSCK",11,0)
 ..S ANYMSE=ANYMSE_I1
"RTN","DGMSCK",12,0)
 ..I $P(DGPMSE(I1),U,7) Q  ;Don't check MSE verified by HEC
"RTN","DGMSCK",13,0)
 ..;Check if service dates are missing
"RTN","DGMSCK",14,0)
 ..I $P(DGPMSE(I1),U)=""!($P(DGPMSE(I1),U,2)="") S (MSERR,MSDATERR)=1 Q
"RTN","DGMSCK",15,0)
 ..;Check if service dates are inexact
"RTN","DGMSCK",16,0)
 ..I $E($P(DGPMSE(I1),U),4,7)="0000"!($E($P(DGPMSE(I1),U,2),4,7)="0000") S (MSERR,MSDATERR)=1 Q
"RTN","DGMSCK",17,0)
 ..;Check if branch of service or service discharge type are missing
"RTN","DGMSCK",18,0)
 ..I $P(DGPMSE(I1),U,3)=""!($P(DGPMSE(I1),U,6)="") S MSERR=1
"RTN","DGMSCK",19,0)
 ;Otherwise use MSE data in DGP(.32)
"RTN","DGMSCK",20,0)
 F I1=1:1:3 S ANYMSE(I1)=0
"RTN","DGMSCK",21,0)
 F MSE="4;5;6;7","9;10;11;12","14;15;16;17" D ANY
"RTN","DGMSCK",22,0)
 ;; ANYMSE Saved for use with checks 79 through 82
"RTN","DGMSCK",23,0)
 S ANYMSE="" F I1=1:1:3 I ANYMSE(I1) S ANYMSE=ANYMSE_I1
"RTN","DGMSCK",24,0)
 Q 1
"RTN","DGMSCK",25,0)
ANY S ANYMSE=0 F I2=1:1:4 I $P(DGP(.32),"^",$P(MSE,";",I2))]"" S ANYMSE=1 Q
"RTN","DGMSCK",26,0)
 I 'ANYMSE Q
"RTN","DGMSCK",27,0)
 S ANYMSE(MSE+1\5)=1 ;; Set ANY Data found for Last, NTL, and NNTL
"RTN","DGMSCK",28,0)
 F I2=1:1:4 I $P(DGP(.32),"^",$P(MSE,";",I2))']"" S MSERR=1 S:I2>2 MSDATERR=1
"RTN","DGMSCK",29,0)
 I MSDATERR Q
"RTN","DGMSCK",30,0)
 F I2=3,4 I $E($P(DGP(.32),"^",$P(MSE,";",I2)),4,7)="0000" S (MSERR,MSDATERR)=1 Q
"RTN","DGMSCK",31,0)
 Q
"RTN","DGMSCK",32,0)
CNCK(CONCHK) ;; Check Conflicts API
"RTN","DGMSCK",33,0)
 N I1,I2,DATA,DATE,FROMPC,LOC,NODE,TOPC,YESNO
"RTN","DGMSCK",34,0)
 S CONERR=0 F I1=1:1:7 S I2=$T(CNFLT+I1) D LOC
"RTN","DGMSCK",35,0)
 Q 1
"RTN","DGMSCK",36,0)
LOC ;;
"RTN","DGMSCK",37,0)
 S LOC=$P(I2,";;",2),DATA=$P(I2,";;",3),CONSPEC(LOC)=DATA
"RTN","DGMSCK",38,0)
 S NODE=$P(DATA,",",1),YESNO=$P(DATA,",",2)
"RTN","DGMSCK",39,0)
 S FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
"RTN","DGMSCK",40,0)
 S CONARR(LOC)=0 I $P(DGP(NODE),"^",YESNO)'="Y" Q
"RTN","DGMSCK",41,0)
 S CONARR(LOC)=1
"RTN","DGMSCK",42,0)
 F I2=FROMPC,TOPC S DATE=$P(DGP(NODE),"^",I2) I 'DATE!($E(DATE,4,7)="0000") S CONERR=1,CONARR(LOC)=2 Q
"RTN","DGMSCK",43,0)
 Q
"RTN","DGMSCK",44,0)
RANGE(RANSET) ;; Set Conflict Date Ranges
"RTN","DGMSCK",45,0)
 N I1,I2,I3
"RTN","DGMSCK",46,0)
 S I1="WWI,WWIIE,WWIIP,KOR,VIET,LEB,GREN,PAN,GULF,SOM,YUG,OTHER"
"RTN","DGMSCK",47,0)
 F I2=1:1:12 S I3=$P(I1,",",I2),RANGE(I3)=$$GETCNFDT^DGRPDT(I3)
"RTN","DGMSCK",48,0)
 Q 1
"RTN","DGMSCK",49,0)
MSFROMTO(MSESET) ;; Set first and last overall MSE from/to dates
"RTN","DGMSCK",50,0)
 N MSEFROM,MSETO,I1,I2,I3
"RTN","DGMSCK",51,0)
 S MSEFROM=9999999,MSETO=0 ;; Initialize from/to dates
"RTN","DGMSCK",52,0)
 ;;
"RTN","DGMSCK",53,0)
 ;; Find first MSE FROM Date and last MSE TO date
"RTN","DGMSCK",54,0)
 I $G(ANYMSE) D
"RTN","DGMSCK",55,0)
 .;Use MSE data in DGPMSE array, if it exists
"RTN","DGMSCK",56,0)
 .I $D(DGPMSE) D  Q
"RTN","DGMSCK",57,0)
 ..S I1=0
"RTN","DGMSCK",58,0)
 ..F  S I1=$O(DGPMSE(I1)) Q:'I1  S I2=$P(DGPMSE(I1),U),I3=$P(DGPMSE(I1),U,2) S:I2<MSEFROM MSEFROM=I2 S:I3>MSETO MSETO=I3
"RTN","DGMSCK",59,0)
 .;Otherwise, use MSE data from DGP(.32)
"RTN","DGMSCK",60,0)
 .F I1=6,11,16 S I2=$P(DGP(.32),"^",I1) I I2,I2<MSEFROM S MSEFROM=I2
"RTN","DGMSCK",61,0)
 .F I1=7,12,17 S I2=$P(DGP(.32),"^",I1) I I2,I2>MSETO S MSETO=I2
"RTN","DGMSCK",62,0)
 Q MSEFROM_"^"_MSETO
"RTN","DGMSCK",63,0)
 ;;
"RTN","DGMSCK",64,0)
CNFLT ;;
"RTN","DGMSCK",65,0)
 ;;SOM;;.322,16,17,18
"RTN","DGMSCK",66,0)
 ;;YUG;;.322,19,20,21
"RTN","DGMSCK",67,0)
 ;;PAN;;.322,7,8,9
"RTN","DGMSCK",68,0)
 ;;GREN;;.322,4,5,6
"RTN","DGMSCK",69,0)
 ;;LEB;;.322,1,2,3
"RTN","DGMSCK",70,0)
 ;;VIET;;.321,1,4,5
"RTN","DGMSCK",71,0)
 ;;GULF;;.322,10,11,12
"RTN","DGMSE")
0^4^B7269534
"RTN","DGMSE",1,0)
DGMSE ;QLB/PJH,AJB Utilities (continued); 02/01/2012
"RTN","DGMSE",2,0)
 ;;5.3;Registration;**797**;08/13/93;Build 24
"RTN","DGMSE",3,0)
 Q
"RTN","DGMSE",4,0)
 ;
"RTN","DGMSE",5,0)
 ;DBIA -5354
"RTN","DGMSE",6,0)
 ;
"RTN","DGMSE",7,0)
 ;API for clinical reminders to get military service information.
"RTN","DGMSE",8,0)
 ;
"RTN","DGMSE",9,0)
 ;
"RTN","DGMSE",10,0)
MSDATA(DFN,NEPS,ENTRYDTA,MSDATA) ;
"RTN","DGMSE",11,0)
 ;Return data for all military service episodes.
"RTN","DGMSE",12,0)
 ;Service Entry Dates are required fields.
"RTN","DGMSE",13,0)
 ;Gets new ESR data if present from multiple node (.3216)
"RTN","DGMSE",14,0)
 N DA,DGX,ENTRYDT,NODE,SEPDT
"RTN","DGMSE",15,0)
 S NEPS=0,ENTRYDT=""
"RTN","DGMSE",16,0)
 F  S ENTRYDT=$O(^DPT(DFN,.3216,"B",ENTRYDT)) Q:ENTRYDT=""  D
"RTN","DGMSE",17,0)
 . S DA=0
"RTN","DGMSE",18,0)
 . F  S DA=$O(^DPT(DFN,.3216,"B",ENTRYDT,DA)) Q:DA=""  D
"RTN","DGMSE",19,0)
 .. S NEPS=NEPS+1
"RTN","DGMSE",20,0)
 .. S NODE=$G(^DPT(DFN,.3216,DA,0))
"RTN","DGMSE",21,0)
 .. S ENTRYDT=$P(NODE,U,1),SEPDT=$P(NODE,U,2)
"RTN","DGMSE",22,0)
 .. S ENTRYDTA(ENTRYDT)=NEPS
"RTN","DGMSE",23,0)
 .. S MSDATA(NEPS,"DATE")=$S(SEPDT="":ENTRYDT,1:SEPDT)
"RTN","DGMSE",24,0)
 .. S MSDATA(NEPS,"ENTRY DATE")=ENTRYDT
"RTN","DGMSE",25,0)
 .. S MSDATA(NEPS,"SEPARATION DATE")=SEPDT
"RTN","DGMSE",26,0)
 .. S MSDATA(NEPS,"BRANCH")=$$EXTERNAL^DILFD(2,.325,"",$P(NODE,U,3))
"RTN","DGMSE",27,0)
 .. S MSDATA(NEPS,"SERVICE COMPONENT")=$$EXTERNAL^DILFD(2,.32911,"",$P(NODE,U,4))
"RTN","DGMSE",28,0)
 .. S MSDATA(NEPS,"DISCHARGE TYPE")=$$EXTERNAL^DILFD(2,.324,"",$P(NODE,U,6))
"RTN","DGMSE",29,0)
 I NEPS>0 Q
"RTN","DGMSE",30,0)
 ;Gets data from non-multiple node (.32) only if data does not exist
"RTN","DGMSE",31,0)
 ;in the multiple.
"RTN","DGMSE",32,0)
 I '$D(^DPT(DFN,.32)) Q
"RTN","DGMSE",33,0)
 S NODE=$G(^DPT(DFN,.32)),NODE("SC")=$G(^DPT(DFN,.3291))
"RTN","DGMSE",34,0)
 F DGX=7,12,17 D
"RTN","DGMSE",35,0)
 . S ENTRYDT=$P(NODE,U,(DGX-1))
"RTN","DGMSE",36,0)
 . I ENTRYDT="" Q
"RTN","DGMSE",37,0)
 . S NEPS=NEPS+1
"RTN","DGMSE",38,0)
 . S ENTRYDTA(ENTRYDT)=NEPS
"RTN","DGMSE",39,0)
 . S SEPDT=$P(NODE,U,DGX)
"RTN","DGMSE",40,0)
 . S MSDATA(NEPS,"DATE")=$S(SEPDT="":ENTRYDT,1:SEPDT)
"RTN","DGMSE",41,0)
 . S MSDATA(NEPS,"ENTRY DATE")=ENTRYDT
"RTN","DGMSE",42,0)
 . S MSDATA(NEPS,"SEPARATION DATE")=SEPDT
"RTN","DGMSE",43,0)
 . S MSDATA(NEPS,"BRANCH")=$$EXTERNAL^DILFD(2,.325,"",$P(NODE,U,(DGX-2)))
"RTN","DGMSE",44,0)
 . S MSDATA(NEPS,"SERVICE COMPONENT")=$$EXTERNAL^DILFD(2,.32911,"",$P(NODE("SC"),U,$S(DGX=7:1,DGX=12:2,DGX=17:3)))
"RTN","DGMSE",45,0)
 . S MSDATA(NEPS,"DISCHARGE TYPE")=$$EXTERNAL^DILFD(2,.324,"",$P(NODE,U,(DGX-3)))
"RTN","DGMSE",46,0)
 Q
"RTN","DGMSE",47,0)
 ;
"RTN","DGMSE",48,0)
 ;
"RTN","DGMSE",49,0)
OEIF(BDT,EDT,LSUB) ;Return a list of patient with OEF/OIF/UNK service in the
"RTN","DGMSE",50,0)
 ;date range specified by BDT to EDT.
"RTN","DGMSE",51,0)
 N DA,DFN,FDATE,SLOC,TDATE
"RTN","DGMSE",52,0)
 K ^TMP($J,LSUB)
"RTN","DGMSE",53,0)
 S TDATE=BDT-.1
"RTN","DGMSE",54,0)
 F  S TDATE=$O(^DPT("ALOEIF",TDATE)) Q:TDATE=""  D
"RTN","DGMSE",55,0)
 . S FDATE=0
"RTN","DGMSE",56,0)
 . F  S FDATE=$O(^DPT("ALOEIF",TDATE,FDATE)) Q:(FDATE>EDT)!(FDATE="")  D
"RTN","DGMSE",57,0)
 .. S SLOC=""
"RTN","DGMSE",58,0)
 .. F  S SLOC=$O(^DPT("ALOEIF",TDATE,FDATE,SLOC)) Q:SLOC=""  D
"RTN","DGMSE",59,0)
 ... S DFN=""
"RTN","DGMSE",60,0)
 ... F  S DFN=$O(^DPT("ALOEIF",TDATE,FDATE,SLOC,DFN)) Q:DFN=""  D
"RTN","DGMSE",61,0)
 .... S DA=""
"RTN","DGMSE",62,0)
 .... F  S DA=$O(^DPT("ALOEIF",TDATE,FDATE,SLOC,DFN,DA)) Q:DA=""  D
"RTN","DGMSE",63,0)
 ..... S ^TMP($J,LSUB,DFN,FDATE,TDATE,SLOC,DA)=""
"RTN","DGMSE",64,0)
 Q
"RTN","DGMSEUTL")
0^15^B16538229
"RTN","DGMSEUTL",1,0)
DGMSEUTL ;ALB/PJH,LBD - MSDS Utility Routine;12 JUN 1997 10:00 am ; 9/26/11 4:16pm
"RTN","DGMSEUTL",2,0)
 ;;5.3;Registration;**797**;08/13/93;Build 24
"RTN","DGMSEUTL",3,0)
 ;
"RTN","DGMSEUTL",4,0)
 ;
"RTN","DGMSEUTL",5,0)
MOVMSE(DFN) ;Move MSE data from .32 node to .3216 multiple in Patient file #2
"RTN","DGMSEUTL",6,0)
 Q:'$G(DFN)  Q:$O(^DPT(DFN,.3216,0))
"RTN","DGMSEUTL",7,0)
 N ARRAY
"RTN","DGMSEUTL",8,0)
 D ARRAY(DFN,.ARRAY)
"RTN","DGMSEUTL",9,0)
 I $D(ARRAY) D MSE(DFN,.ARRAY)
"RTN","DGMSEUTL",10,0)
 Q
"RTN","DGMSEUTL",11,0)
 ;
"RTN","DGMSEUTL",12,0)
ARRAY(DFN,ARRAY) ;Get old format VistA data
"RTN","DGMSEUTL",13,0)
 N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
"RTN","DGMSEUTL",14,0)
 S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
"RTN","DGMSEUTL",15,0)
 ;Last service episode (SL)
"RTN","DGMSEUTL",16,0)
 D EPISODE(1,4,8)
"RTN","DGMSEUTL",17,0)
 ;Next to last service episode (SNL)
"RTN","DGMSEUTL",18,0)
 Q:$P(DGRP(.32),"^",19)'="Y"  D EPISODE(2,9,13)
"RTN","DGMSEUTL",19,0)
 ;Prior episode (SNNL)
"RTN","DGMSEUTL",20,0)
 I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
"RTN","DGMSEUTL",21,0)
 Q
"RTN","DGMSEUTL",22,0)
 ;
"RTN","DGMSEUTL",23,0)
EPISODE(SUB,P1,P2) ;Get old VistA data and save
"RTN","DGMSEUTL",24,0)
 S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
"RTN","DGMSEUTL",25,0)
 S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
"RTN","DGMSEUTL",26,0)
 S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
"RTN","DGMSEUTL",27,0)
 ;Save in format of new .3216 multiple (no lock flag)
"RTN","DGMSEUTL",28,0)
 S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U
"RTN","DGMSEUTL",29,0)
 Q
"RTN","DGMSEUTL",30,0)
 ;
"RTN","DGMSEUTL",31,0)
MSE(DFN,ARRAY,DEL) ;Copy old VistA data to new .3216 multiple
"RTN","DGMSEUTL",32,0)
 N ECNT,DA,DIK,SUB,X
"RTN","DGMSEUTL",33,0)
 S ECNT=0
"RTN","DGMSEUTL",34,0)
 ;Delete existing entries
"RTN","DGMSEUTL",35,0)
 I $G(DEL) F  S ECNT=$O(^DPT(DFN,.3216,ECNT)) Q:+ECNT'>0  D
"RTN","DGMSEUTL",36,0)
 .S DA(1)=DFN,DA=ECNT,DIK="^DPT("_DA(1)_",.3216," D ^DIK
"RTN","DGMSEUTL",37,0)
 ;Add service episodes
"RTN","DGMSEUTL",38,0)
 S SUB=""
"RTN","DGMSEUTL",39,0)
 F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D
"RTN","DGMSEUTL",40,0)
 .;Ignore if Service Entry Date is null
"RTN","DGMSEUTL",41,0)
 .Q:'+ARRAY(SUB)
"RTN","DGMSEUTL",42,0)
 .N DA,DIC,DD,DO,DLAYGO,FLDS,X
"RTN","DGMSEUTL",43,0)
 .S FLDS=ARRAY(SUB)
"RTN","DGMSEUTL",44,0)
 .S DIC="^DPT(DFN,.3216,"
"RTN","DGMSEUTL",45,0)
 .S DIC(0)="L",DLAYGO=2
"RTN","DGMSEUTL",46,0)
 .S DA(1)=DFN
"RTN","DGMSEUTL",47,0)
 .S X=$P(FLDS,U) ;Entry Date
"RTN","DGMSEUTL",48,0)
 .S DIC("DR")=".02////"_$P(FLDS,U,2) ;Separation Date
"RTN","DGMSEUTL",49,0)
 .S DIC("DR")=DIC("DR")_";.03////"_$P(FLDS,U,3) ;Service Branch
"RTN","DGMSEUTL",50,0)
 .S DIC("DR")=DIC("DR")_";.04////"_$P(FLDS,U,4) ;Service Component
"RTN","DGMSEUTL",51,0)
 .S DIC("DR")=DIC("DR")_";.05////"_$P(FLDS,U,5) ;Service Number
"RTN","DGMSEUTL",52,0)
 .S DIC("DR")=DIC("DR")_";.06////"_$P(FLDS,U,6) ;Discharge type
"RTN","DGMSEUTL",53,0)
 .S DIC("DR")=DIC("DR")_";.07////"_$P(FLDS,U,7) ;Locked
"RTN","DGMSEUTL",54,0)
 .D FILE^DICN
"RTN","DGMSEUTL",55,0)
 Q
"RTN","DGMSEUTL",56,0)
 ;
"RTN","DGMSEUTL",57,0)
GETMSE(DFN,MSE) ;Return all records in MSE sub-file #2.3216 in MSE array
"RTN","DGMSEUTL",58,0)
 ;Records are sorted in reverse chronological order and the second
"RTN","DGMSEUTL",59,0)
 ;subscript is the MSE IEN in the multiple  e.g. MSE(1,4)=last
"RTN","DGMSEUTL",60,0)
 I '$G(DFN) Q
"RTN","DGMSEUTL",61,0)
 N I,SDT,IEN
"RTN","DGMSEUTL",62,0)
 S SDT=""
"RTN","DGMSEUTL",63,0)
 F I=1:1 S SDT=$O(^DPT(DFN,.3216,"B",SDT),-1) Q:'SDT  D
"RTN","DGMSEUTL",64,0)
 .S IEN=0 F  S IEN=$O(^DPT(DFN,.3216,"B",SDT,IEN)) Q:'IEN  D
"RTN","DGMSEUTL",65,0)
 ..I '$D(^DPT(DFN,.3216,IEN,0)) Q
"RTN","DGMSEUTL",66,0)
 ..S MSE(I)=^DPT(DFN,.3216,IEN,0)
"RTN","DGMSEUTL",67,0)
 ..S MSE(I,IEN)=""
"RTN","DGMSEUTL",68,0)
 Q
"RTN","DGMSEUTL",69,0)
 ;
"RTN","DGMSEUTL",70,0)
LAST(DFN) ;Return last (most recent) MSE
"RTN","DGMSEUTL",71,0)
 I '$G(DFN) Q ""
"RTN","DGMSEUTL",72,0)
 N MSE
"RTN","DGMSEUTL",73,0)
 D GETMSE(DFN,.MSE)
"RTN","DGMSEUTL",74,0)
 S MSE=$O(MSE(0))
"RTN","DGMSEUTL",75,0)
 Q $G(MSE(+MSE))
"RTN","DGMSEUTL",76,0)
 ;
"RTN","DGMSEUTL",77,0)
UPDMSE(DFN,DGNMSE) ;File MSE data from the HEC Z11 message
"RTN","DGMSEUTL",78,0)
 Q:'$G(DFN)  Q:'$D(DGNMSE)
"RTN","DGMSEUTL",79,0)
 N DGOMSE,DGTOT,DGCHG,DGN,DGO,I
"RTN","DGMSEUTL",80,0)
 S DGTOT=0,DGN="" F  S DGN=$O(DGNMSE(DGN)) Q:'DGN  S DGTOT=DGTOT+1
"RTN","DGMSEUTL",81,0)
 ;Get current MSE data for patient from MSE sub-file #2.3216
"RTN","DGMSEUTL",82,0)
 D GETMSE(DFN,.DGOMSE)
"RTN","DGMSEUTL",83,0)
 I $D(DGOMSE) D  Q:'DGCHG
"RTN","DGMSEUTL",84,0)
 .;Compare the old and new data.  If they match, no update is needed.
"RTN","DGMSEUTL",85,0)
 .S DGCHG=0
"RTN","DGMSEUTL",86,0)
 .I DGTOT'=$O(DGOMSE(""),-1) S DGCHG=1 Q
"RTN","DGMSEUTL",87,0)
 .S (DGO,DGN)=""
"RTN","DGMSEUTL",88,0)
 .F I=1:1:DGTOT S DGO=$O(DGOMSE(DGO)),DGN=$O(DGNMSE(DGN)) D  Q:DGCHG
"RTN","DGMSEUTL",89,0)
 ..I DGOMSE(DGO)'=DGNMSE(DGN) S DGCHG=1 Q
"RTN","DGMSEUTL",90,0)
 ;File the new MSE data from HEC, delete old data first if it exists
"RTN","DGMSEUTL",91,0)
 D MSE(DFN,.DGNMSE,$D(DGOMSE))
"RTN","DGMSEUTL",92,0)
 Q
"RTN","DGMSEUTL",93,0)
 ;
"RTN","DGMSEUTL",94,0)
ESRDATA(DFN) ;Check if any records in .3216 are from ESR
"RTN","DGMSEUTL",95,0)
 N IEN,LOCKED
"RTN","DGMSEUTL",96,0)
 S IEN=0,LOCKED=0
"RTN","DGMSEUTL",97,0)
 F  S IEN=$O(^DPT(DFN,.3216,IEN)) Q:'IEN  D  Q:LOCKED
"RTN","DGMSEUTL",98,0)
 .;Check if record is locked
"RTN","DGMSEUTL",99,0)
 .S LOCKED=$P($G(^DPT(DFN,.3216,IEN,0)),U,7)
"RTN","DGMSEUTL",100,0)
 ;Return LOCKED indicating ESR data found
"RTN","DGMSEUTL",101,0)
 Q LOCKED
"RTN","DGMSEUTL",102,0)
 ;
"RTN","DGMSEUTL",103,0)
WARNMSG(DFN) ;Warning Message if some episodes did not copy
"RTN","DGMSEUTL",104,0)
 N DATA32,OLDMSE,NEWMSE,DATA
"RTN","DGMSEUTL",105,0)
 ;If ESR data exists quit
"RTN","DGMSEUTL",106,0)
 Q:$$ESRDATA(DFN) 0
"RTN","DGMSEUTL",107,0)
 ;Count number of old episodes
"RTN","DGMSEUTL",108,0)
 N LBRANCH,LDATE,SDAT,NODT
"RTN","DGMSEUTL",109,0)
 S DATA32=$G(^DPT(DFN,.32))
"RTN","DGMSEUTL",110,0)
 S LDATE=$P(DATA32,U,6),LBRANCH=$P(DATA32,U,5),OLDMSE=0,NODT=0
"RTN","DGMSEUTL",111,0)
 ;If entry date or branch assume last episode exists
"RTN","DGMSEUTL",112,0)
 I LDATE!LBRANCH S OLDMSE=OLDMSE+1 S:'LDATE NODT=1
"RTN","DGMSEUTL",113,0)
 ;Check for second episode
"RTN","DGMSEUTL",114,0)
 I $P(DATA32,U,19)="Y" D
"RTN","DGMSEUTL",115,0)
 .S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,11) NODT=1
"RTN","DGMSEUTL",116,0)
 .;and third episode
"RTN","DGMSEUTL",117,0)
 .I $P(DATA32,U,20)="Y" S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,16) NODT=1
"RTN","DGMSEUTL",118,0)
 ;
"RTN","DGMSEUTL",119,0)
 ;If no old episodes no message is necessary
"RTN","DGMSEUTL",120,0)
 Q:'OLDMSE 0
"RTN","DGMSEUTL",121,0)
 ;
"RTN","DGMSEUTL",122,0)
 ;Count number of new episodes
"RTN","DGMSEUTL",123,0)
 S NEWMSE=0,SDAT=""
"RTN","DGMSEUTL",124,0)
 F  S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT  D
"RTN","DGMSEUTL",125,0)
 .S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
"RTN","DGMSEUTL",126,0)
 .S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
"RTN","DGMSEUTL",127,0)
 .S NEWMSE=NEWMSE+1
"RTN","DGMSEUTL",128,0)
 ;
"RTN","DGMSEUTL",129,0)
 ;If number old MSEs greater than new MSEs, and service entry date
"RTN","DGMSEUTL",130,0)
 ;is missing, return 1
"RTN","DGMSEUTL",131,0)
 I OLDMSE>NEWMSE,NODT Q 1
"RTN","DGMSEUTL",132,0)
 ;Otherwise, return 0
"RTN","DGMSEUTL",133,0)
 Q 0
"RTN","DGREGG")
0^33^B3973658
"RTN","DGREGG",1,0)
DGREGG ;ALB/MRL,LBD - CONTINUATION OF REGISTRATION PROCESS ; 3/10/11 4:32pm
"RTN","DGREGG",2,0)
 ;;5.3;Registration;**565,797**;Aug 13, 1993;Build 24
"RTN","DGREGG",3,0)
 N DEF,DGDISTYP,DGSED,Y
"RTN","DGREGG",4,0)
 S DEF=0 W !! I $D(^DPT(DFN,.15))#10,$P(^(.15),"^",2)?7N W !,"Patient is ineligible for benefits." S DEF(1)=1,DEF=1
"RTN","DGREGG",5,0)
 ;Get Military Service Data (DG*5.3*797)
"RTN","DGREGG",6,0)
 D GETMSE
"RTN","DGREGG",7,0)
 I DGDISTYP>1&(DGDISTYP<9) W $S($D(DEF)\10:", He",1:"Patient") W:$X>70 ! W " did not receive an honorable discharge." S DEF(3)=1,DEF=1
"RTN","DGREGG",8,0)
 I DEF W !!
"RTN","DGREGG",9,0)
 S Y=0 F I=1:1:3 I $G(DGSED(I)) S:(DGSED(I)'<2800908) Y=DGSED(I) I DGSED(I)<2800908 S Y=0 Q
"RTN","DGREGG",10,0)
 I Y D
"RTN","DGREGG",11,0)
 .X ^DD("DD") W !,"Entered Service ",Y
"RTN","DGREGG",12,0)
 .W !,"Veteran must have completed at least 24 consecutive months of active"
"RTN","DGREGG",13,0)
 .W !,"military service. If veteran meets an exception to minimum duty requirements"
"RTN","DGREGG",14,0)
 .W !,"as listed on www.va.gov/elig, veteran is eligible for VA health care."
"RTN","DGREGG",15,0)
 .W !,"Otherwise, enter Ineligible Date and Reason on Screen 10 -- veteran is"
"RTN","DGREGG",16,0)
 .W !,"eligible for care of SC conditions only.",!
"RTN","DGREGG",17,0)
 .K A
"RTN","DGREGG",18,0)
 Q
"RTN","DGREGG",19,0)
 ;
"RTN","DGREGG",20,0)
GETMSE ;Get Last Discharge Type and Service Entry Dates (DG*5.3*797)
"RTN","DGREGG",21,0)
 N DGMSE,I,J
"RTN","DGREGG",22,0)
 ;Get MSE data from MSE sub-file #2.3216, if it exists
"RTN","DGREGG",23,0)
 I $D(^DPT(DFN,.3216)) D  Q
"RTN","DGREGG",24,0)
 .D GETMSE^DGMSEUTL(DFN,.DGMSE)
"RTN","DGREGG",25,0)
 .S DGDISTYP=$P($G(DGMSE(1)),U,6)
"RTN","DGREGG",26,0)
 .F I=1:1:3 S DGSED(I)=$P($G(DGMSE(I)),U)
"RTN","DGREGG",27,0)
 ;otherwise, get MSE data from .32 node
"RTN","DGREGG",28,0)
 S DGMSE=$G(^DPT(DFN,.32))
"RTN","DGREGG",29,0)
 S DGDISTYP=$P(DGMSE,U,4)
"RTN","DGREGG",30,0)
 F I=1:1:3 S J=5*I+1,DGSED(I)=$P(DGMSE,U,J)
"RTN","DGREGG",31,0)
 Q
"RTN","DGRODEBR")
0^19^B55430347
"RTN","DGRODEBR",1,0)
DGRODEBR ;DJH/AMA,TDM - ROM DATA ELEMENT BUSINESS RULES ; 10/20/10 9:59am
"RTN","DGRODEBR",2,0)
 ;;5.3;Registration;**533,572,754,797**;Aug 13, 1993;Build 24
"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","DGRODEBR",246,0)
 ;
"RTN","DGRODEBR",247,0)
MSE(DGDATA,LSTDFN) ;MILITARY SERVICE EPISODES
"RTN","DGRODEBR",248,0)
 ;   DGDATA - Data element array from LST, ^TMP("DGROFDA",$J)
"RTN","DGRODEBR",249,0)
 ;   LSTDFN - Pointer to the patient data from the LST, in DGDATA
"RTN","DGRODEBR",250,0)
 ;
"RTN","DGRODEBR",251,0)
 ;If new format MSE data exists from last site visited then do
"RTN","DGRODEBR",252,0)
 ;NOT load old format MSE data.
"RTN","DGRODEBR",253,0)
 ;
"RTN","DGRODEBR",254,0)
 I $D(@DGDATA@(2.3216)) D
"RTN","DGRODEBR",255,0)
 .N FIELD
"RTN","DGRODEBR",256,0)
 .F FIELD=.324,.325,.326,.327,.328,.3285,.329,.3291,.32911,.32912,.32913,.3292,.3293,.3294,.32945,.3295,.3296,.3297,.3298,.3299 K @DGDATA@(2,LSTDFN_",",FIELD)
"RTN","DGRODEBR",257,0)
 Q
"RTN","DGROHLR")
0^21^B18624727
"RTN","DGROHLR",1,0)
DGROHLR ;DJH/AMA - ROM HL7 RECEIVE DRIVERS ; 10/20/10 10:55am
"RTN","DGROHLR",2,0)
 ;;5.3;Registration;**533,572,754,797**;Aug 13, 1993;Build 24
"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)
 D MSE^DGRODEBR(DGDATA,LSTDFN)       ;MILITARY SERVICE EPISODES
"RTN","DGROHLR",144,0)
 ;
"RTN","DGROHLR",145,0)
 ;File the data
"RTN","DGROHLR",146,0)
 D CONVFDA^DGROHLR1(DFN,DGDATA)
"RTN","DGROHLR",147,0)
 ;CLEAN UP
"RTN","DGROHLR",148,0)
 K @DGDATA
"RTN","DGROHLR",149,0)
 Q
"RTN","DGROHLR1")
0^22^B54801555
"RTN","DGROHLR1",1,0)
DGROHLR1 ;GTS/PHH,TDM - ROM HL7 RECEIVE DRIVERS ; 10/20/10 2:47pm
"RTN","DGROHLR1",2,0)
 ;;5.3;Registration;**572,622,647,809,754,797**;Aug 13, 1993;Build 24
"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.3216 D
"RTN","DGROHLR1",97,0)
 . D CONVERT ;Convert MSE fields to internal format
"RTN","DGROHLR1",98,0)
 . D UPDATE^DIE("","@DGROAR","","ERR")
"RTN","DGROHLR1",99,0)
 I (+FNUM=2.02)!(+FNUM=2.06) DO
"RTN","DGROHLR1",100,0)
 . N DGRODNUM,DGIEN,DNUMDATA,DGIEN2,DGROIEN
"RTN","DGROHLR1",101,0)
 . S DGRODNUM=0
"RTN","DGROHLR1",102,0)
 . F  S DGRODNUM=$O(@DGROAR@(+FNUM,DGRODNUM)) Q:DGRODNUM=""  D
"RTN","DGROHLR1",103,0)
 . . S DGIEN=$P(DGRODNUM,",")
"RTN","DGROHLR1",104,0)
 . . I DGIEN S DGIEN2=$P(DGIEN,"+",2)
"RTN","DGROHLR1",105,0)
 . . S DNUMDATA=$G(@DGROAR@(+FNUM,DGRODNUM,.01))
"RTN","DGROHLR1",106,0)
 . . I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA D
"RTN","DGROHLR1",107,0)
 . . . D UPDATE^DIE("","@DGROAR","DGROIEN","ERR") ;*Converted Ext to Int
"RTN","DGROHLR1",108,0)
 ;
"RTN","DGROHLR1",109,0)
 ;* Processing fields [indicated in 391.23] not part of Patient file.
"RTN","DGROHLR1",110,0)
 ;* Define IF section for each file not a Patient file field or
"RTN","DGROHLR1",111,0)
 ;* Multiple.
"RTN","DGROHLR1",112,0)
 I (+$P(FNUM,".")'=2) DO
"RTN","DGROHLR1",113,0)
 . I +FNUM=38.1 DO
"RTN","DGROHLR1",114,0)
 . . N DGROARBI
"RTN","DGROHLR1",115,0)
 . . S DGROARBI(1)=DFN ;*Set 38.1 IEN to DFN
"RTN","DGROHLR1",116,0)
 . . D UPDATE^DIE("E","@DGROAR","DGROARBI","ERR")
"RTN","DGROHLR1",117,0)
 ;
"RTN","DGROHLR1",118,0)
 K @DGROAR
"RTN","DGROHLR1",119,0)
 Q
"RTN","DGROHLR1",120,0)
 ;
"RTN","DGROHLR1",121,0)
SETARY ;* Setup arrays of data to be filed
"RTN","DGROHLR1",122,0)
 N U,D,DATA,NODE,NODE2,INENNUM
"RTN","DGROHLR1",123,0)
 ;
"RTN","DGROHLR1",124,0)
 I '$D(^DGRO(391.23,"C",F,FIELD)) Q
"RTN","DGROHLR1",125,0)
 ;
"RTN","DGROHLR1",126,0)
 S U="^"
"RTN","DGROHLR1",127,0)
 ;
"RTN","DGROHLR1",128,0)
 ;CHECK LOCAL PATIENT FILE FOR EXISTING DATA, DO NOT OVERWRITE
"RTN","DGROHLR1",129,0)
 S D=$$GET1^DIQ(F,DFNC,FIELD)
"RTN","DGROHLR1",130,0)
 I D'="" K @DGDATA@(F,IEN,FIELD) Q
"RTN","DGROHLR1",131,0)
 ;
"RTN","DGROHLR1",132,0)
 S DATA=$G(@DGDATA@(F,IEN,FIELD,"E"))
"RTN","DGROHLR1",133,0)
 Q:DATA=""
"RTN","DGROHLR1",134,0)
 ;
"RTN","DGROHLR1",135,0)
 ;* Design of this Subroutine:
"RTN","DGROHLR1",136,0)
 ;* Set array defining groups of date for Fileman filing in
"RTN","DGROHLR1",137,0)
 ;*  a predefined order.
"RTN","DGROHLR1",138,0)
 ;* Indirection defined various array names for different ordered
"RTN","DGROHLR1",139,0)
 ;*  data groups in CONVFDA.
"RTN","DGROHLR1",140,0)
 ;* File Ext. values returned from LST per ORDER INDEX.
"RTN","DGROHLR1",141,0)
 ;* DG*5.3*572
"RTN","DGROHLR1",142,0)
 ;
"RTN","DGROHLR1",143,0)
 ;* Get field entry IEN in ROM 391.23 file
"RTN","DGROHLR1",144,0)
 S INENNUM=INX
"RTN","DGROHLR1",145,0)
 ;
"RTN","DGROHLR1",146,0)
 I F=2 DO  Q
"RTN","DGROHLR1",147,0)
 . S @DGROAR@(F,DFNC,FIELD)=DATA ;*Indirection to Patient Array
"RTN","DGROHLR1",148,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",149,0)
 ;
"RTN","DGROHLR1",150,0)
 ;* Set array for all other files (not Patient or Security files)
"RTN","DGROHLR1",151,0)
 ;* This section is for new entries in files.  Not for Multiples.
"RTN","DGROHLR1",152,0)
 ;*  Code to process specific files needed in CONVFDA
"RTN","DGROHLR1",153,0)
 I (+$P(F,".")'=2),(F'=38.1) DO  Q
"RTN","DGROHLR1",154,0)
 . S @DGROAR@(F,"+1,",FIELD)=DATA
"RTN","DGROHLR1",155,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",156,0)
 ;
"RTN","DGROHLR1",157,0)
 ;SET ALIAS, CONFIDENTIAL ADDRESS CAT. AND MILITARY SERVICE EPISODE
"RTN","DGROHLR1",158,0)
 ;SUBFILE ARRAYS
"RTN","DGROHLR1",159,0)
 I (F=2.01)!(F=2.141)!(F=2.11)!(F=2.3216) D  Q
"RTN","DGROHLR1",160,0)
 . S NODE2="+"
"RTN","DGROHLR1",161,0)
 . S NODE2=NODE2_$P(IEN,",")_","_DFNC
"RTN","DGROHLR1",162,0)
 . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
"RTN","DGROHLR1",163,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",164,0)
 ;
"RTN","DGROHLR1",165,0)
 ;SET RACE AND ETHNICITY ARRAYS
"RTN","DGROHLR1",166,0)
 I (F=2.02)!(F=2.06) D  Q
"RTN","DGROHLR1",167,0)
 . N REFILE,REIEN,DATA30,QFL,DATACOMP,TEST,ERR,INACTIVE
"RTN","DGROHLR1",168,0)
 . I (F=2.02),(FIELD=.01) S REFILE=10
"RTN","DGROHLR1",169,0)
 . I (F=2.06),(FIELD=.01) S REFILE=10.2
"RTN","DGROHLR1",170,0)
 . I FIELD=.02 S REFILE=10.3
"RTN","DGROHLR1",171,0)
 . S DATA30=$E(DATA,1,30) D
"RTN","DGROHLR1",172,0)
 . . S QFL=0,REIEN="",NODE=""
"RTN","DGROHLR1",173,0)
 . . D FIND^DIC(REFILE,"","@;.01;200","",DATA30,,"B","","","TEST","ERR")
"RTN","DGROHLR1",174,0)
 . . F  S NODE=$O(TEST("DILIST",2,NODE)) Q:'NODE  D  Q:$G(QFL)=1
"RTN","DGROHLR1",175,0)
 . . . S REIEN=$G(TEST("DILIST",2,NODE))
"RTN","DGROHLR1",176,0)
 . . . S INACTIVE=$G(TEST("DILIST","ID",NODE,200))
"RTN","DGROHLR1",177,0)
 . . . Q:INACTIVE="YES"  ;* QUIT if Race or Eth Inact
"RTN","DGROHLR1",178,0)
 . . . S DATACOMP=$G(TEST("DILIST","ID",NODE,.01))
"RTN","DGROHLR1",179,0)
 . . . I DATACOMP=DATA S QFL=1
"RTN","DGROHLR1",180,0)
 . Q:'QFL
"RTN","DGROHLR1",181,0)
 . Q:$G(INACTIVE)="YES"  ;* No entry for Inactive Race/Ethncty
"RTN","DGROHLR1",182,0)
 . S DATA=REIEN ;*Race/Ethncty/MOC (10/10.2/10.3) IEN for data recvd
"RTN","DGROHLR1",183,0)
 . ;
"RTN","DGROHLR1",184,0)
 . S NODE2="+" ;*+ for all fields, All fields added in one UPDATE
"RTN","DGROHLR1",185,0)
 . S NODE2=NODE2_$P(IEN,",")_","_DFNC ;*No + for DFNC, DPT record exists
"RTN","DGROHLR1",186,0)
 . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
"RTN","DGROHLR1",187,0)
 . K @DGDATA@(F,IEN,FIELD)
"RTN","DGROHLR1",188,0)
 ;
"RTN","DGROHLR1",189,0)
 ;* Set all sensitive fields (38.1) in array
"RTN","DGROHLR1",190,0)
 I F=38.1 D  Q
"RTN","DGROHLR1",191,0)
 . Q:('$D(@DGDATA@(F)))  ;*Data already filed
"RTN","DGROHLR1",192,0)
 . S FIELD=.01
"RTN","DGROHLR1",193,0)
 . S @DGROAR@(F,"+1,",FIELD)=$$GET1^DIQ(2,DFN,.01)
"RTN","DGROHLR1",194,0)
 . F  S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:'FIELD  D
"RTN","DGROHLR1",195,0)
 . . S @DGROAR@(F,"+1,",FIELD)=@DGDATA@(F,IEN,FIELD,"E")
"RTN","DGROHLR1",196,0)
 . K @DGDATA@(F,IEN)
"RTN","DGROHLR1",197,0)
 . S FIELD=999999 ;*Skip to end of 38.1 field list in @DGDATA
"RTN","DGROHLR1",198,0)
 Q
"RTN","DGROHLR1",199,0)
 ;
"RTN","DGROHLR1",200,0)
DIS(F,FIELD) ;Check for disabled
"RTN","DGROHLR1",201,0)
 N SUB S SUB=$O(^DGRO(391.23,"C",F,FIELD,0)) Q:'SUB 1
"RTN","DGROHLR1",202,0)
 I $P($G(^DGRO(391.23,SUB,0)),"^",5)=1 Q 1
"RTN","DGROHLR1",203,0)
 Q 0
"RTN","DGROHLR1",204,0)
 ;
"RTN","DGROHLR1",205,0)
CONVERT ;External to Internal Conversion (clears field if no match found)
"RTN","DGROHLR1",206,0)
 N BOS,DATE,COMP,DISCH,F,INTERNAL,LOCK,SUB,X,Y
"RTN","DGROHLR1",207,0)
 S F=2.3216,SUB=""
"RTN","DGROHLR1",208,0)
 F  S SUB=$O(@DGROAR@(F,SUB)) Q:SUB=""  D
"RTN","DGROHLR1",209,0)
 .;Convert Branch
"RTN","DGROHLR1",210,0)
 .I $D(@DGROAR@(F,SUB,.03)) D
"RTN","DGROHLR1",211,0)
 ..S BOS=$G(@DGROAR@(F,SUB,.03)) Q:BOS=""
"RTN","DGROHLR1",212,0)
 ..S INTERNAL=$O(^DIC(23,"B",BOS,""))
"RTN","DGROHLR1",213,0)
 ..S @DGROAR@(F,SUB,.03)=INTERNAL
"RTN","DGROHLR1",214,0)
 .;Convert Discharge
"RTN","DGROHLR1",215,0)
 .I $D(@DGROAR@(F,SUB,.06)) D
"RTN","DGROHLR1",216,0)
 ..S DISCH=$G(@DGROAR@(F,SUB,.06)) Q:DISCH=""
"RTN","DGROHLR1",217,0)
 ..S INTERNAL=$O(^DIC(25,"B",DISCH,""))
"RTN","DGROHLR1",218,0)
 ..S @DGROAR@(F,SUB,.06)=INTERNAL
"RTN","DGROHLR1",219,0)
 .;Convert Component
"RTN","DGROHLR1",220,0)
 .I $D(@DGROAR@(F,SUB,.04)) D
"RTN","DGROHLR1",221,0)
 ..S COMP=$G(@DGROAR@(F,SUB,.04)) Q:COMP=""
"RTN","DGROHLR1",222,0)
 ..S INTERNAL=""
"RTN","DGROHLR1",223,0)
 ..S:COMP="REGULAR" INTERNAL="R"
"RTN","DGROHLR1",224,0)
 ..S:COMP="ACTIVATED NG" INTERNAL="G"
"RTN","DGROHLR1",225,0)
 ..S:COMP="ACTIVATED RESERVE" INTERNAL="V"
"RTN","DGROHLR1",226,0)
 ..S @DGROAR@(F,SUB,.04)=INTERNAL
"RTN","DGROHLR1",227,0)
 .;Convert Lock flag
"RTN","DGROHLR1",228,0)
 .I $D(@DGROAR@(F,SUB,.07)) D
"RTN","DGROHLR1",229,0)
 ..S LOCK=$G(@DGROAR@(F,SUB,.07)) Q:LOCK=""
"RTN","DGROHLR1",230,0)
 ..S INTERNAL=$S(LOCK="YES":1,LOCK="NO":0,1:"")
"RTN","DGROHLR1",231,0)
 ..S @DGROAR@(F,SUB,.07)=INTERNAL
"RTN","DGROHLR1",232,0)
 .;Convert dates
"RTN","DGROHLR1",233,0)
 .I $D(@DGROAR@(F,SUB,.01)) D
"RTN","DGROHLR1",234,0)
 ..S X=$G(@DGROAR@(F,SUB,.01)) Q:X=""
"RTN","DGROHLR1",235,0)
 ..D ^%DT
"RTN","DGROHLR1",236,0)
 ..S @DGROAR@(F,SUB,.01)=Y
"RTN","DGROHLR1",237,0)
 .I $D(@DGROAR@(F,SUB,.02)) D
"RTN","DGROHLR1",238,0)
 ..S X=$G(@DGROAR@(F,SUB,.02)) Q:X=""
"RTN","DGROHLR1",239,0)
 ..D ^%DT
"RTN","DGROHLR1",240,0)
 ..S @DGROAR@(F,SUB,.02)=Y
"RTN","DGROHLR1",241,0)
 Q
"RTN","DGROHLU")
0^20^B27082369
"RTN","DGROHLU",1,0)
DGROHLU ;DJH/AMA,TDM - ROM HL7 BUILD ORF SEGMENT ; 10/20/10 3:00pm
"RTN","DGROHLU",2,0)
 ;;5.3;Registration;**533,572,754,797**;Aug 13, 1993;Build 24
"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)!(FILE=2.3216) 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,2.3216 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","DGRP6")
0^10^B15573608
"RTN","DGRP6",1,0)
DGRP6 ;ALB/MRL,LBD,TMK - REGISTRATION SCREEN 6/SERVICE INFORMATION ; 3/11/09 4:50pm
"RTN","DGRP6",2,0)
 ;;5.3;Registration;**161,247,343,397,342,451,672,689,797**;Aug 13, 1993;Build 24
"RTN","DGRP6",3,0)
 N DIPA,LIN,XX,Z1,GLBL
"RTN","DGRP6",4,0)
 S DGRPS=6 D H^DGRPU F I=.32,.321,.322,.36,.52,.53 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP6",5,0)
 S (DGRPW,Z)=1 D WW2^DGRPV S Z=" Service Branch/Component",Z1=27 D WW1^DGRPV S Z="Service #",Z1=16 D WW1^DGRPV S Z=" Entered",Z1=12 D WW1^DGRPV S Z="Separated",Z1=12 D WW1^DGRPV W "Discharge"
"RTN","DGRP6",6,0)
 W !?4,"------------------------",?30,"---------",?47,"-------",?58,"---------",?70,"---------"
"RTN","DGRP6",7,0)
 ;Get MSEs from Military Service Episode sub-file #2.3216 (DG*5.3*797)
"RTN","DGRP6",8,0)
 K ^TMP("DGRP6",$J)
"RTN","DGRP6",9,0)
 S GLBL=$NA(^TMP("DGRP6",$J))
"RTN","DGRP6",10,0)
 D GETMSE^DGRP61(DFN,GLBL,0)
"RTN","DGRP6",11,0)
 D S
"RTN","DGRP6",12,0)
 W !
"RTN","DGRP6",13,0)
 D CL^DGRP6CL2(DFN,.LIN)
"RTN","DGRP6",14,0)
 S Z=2 D WW2^DGRPV S Z="  Conflict Locations: ",Z1=20 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
"RTN","DGRP6",15,0)
 S Z=1 F  S Z=$O(LIN(Z)) Q:'Z  W !,?25,LIN(Z)
"RTN","DGRP6",16,0)
 D EF^DGRP6EF(DFN,.LIN)
"RTN","DGRP6",17,0)
 S Z=3 D WW2^DGRPV S Z=" Environment Factors: ",Z1=21 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
"RTN","DGRP6",18,0)
 S Z=1 F  S Z=$O(LIN(Z)) Q:'Z  W !,?4,"+ ",LIN(Z)
"RTN","DGRP6",19,0)
 S Z=4,DGRPX=DGRP(.52) D WW^DGRPV W "          POW: " S X=5,Z1=6 D YN W "From: " S X=7,Z1=13 D DAT W "To: " S X=8,Z1=12 D DAT W "War: ",$S($D(^DIC(22,+$P(DGRPX,"^",6),0)):$P(^(0),"^",2),1:"")
"RTN","DGRP6",20,0)
 S Z=5 D WW^DGRPV W "       Combat: " S X=11,Z1=6 D YN W "From: " S X=13,Z1=13 D DAT W "To: " S X=14,Z1=12 D DAT W "Loc: ",$S($D(^DIC(22,+$P(DGRPX,"^",12),0)):$P(^(0),"^",2),1:"")
"RTN","DGRP6",21,0)
 S Z=6 D WW^DGRPV S X=$P(DGRP(.36),"^",12),XX=$P(DGRP(.36),"^",13)
"RTN","DGRP6",22,0)
 N DGSPACE
"RTN","DGRP6",23,0)
 S DGSPACE=$S($G(X)="0":" ",$G(X)="1":"",1:"   ")
"RTN","DGRP6",24,0)
 W "     Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"") W DGSPACE_"        Dischrg Due to Disab: ",$S(XX=0:"NO",XX=1:"YES",1:"")
"RTN","DGRP6",25,0)
 ;W !
"RTN","DGRP6",26,0)
 S Z=7 D WW^DGRPV W "     Dent Inj: " S DGRPX=DGRP(.36),X=8,Z1=28 D YN W "Teeth Extracted: " S X=9,Z1=9 D YN S DGRPD=0 I $P(DGRPX,"^",8)="Y",$P(DGRPX,"^",9)="Y" S DGRPD=1
"RTN","DGRP6",27,0)
 I DGRPD S I1="" F I=0:0 S I=$O(^DPT(DFN,.37,I)) Q:'I  S I1=1,DGRPX=^(I,0) D DEN
"RTN","DGRP6",28,0)
 S Z=8 D WW^DGRPV W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D
"RTN","DGRP6",29,0)
 . I $P($G(DGRPX),U)="Y",($P($G(DGRPX),U,2)]"") W ?26,"PH Status: "_$S($P($G(DGRPX),U,2)="1":"Pending",$P($G(DGRPX),U,2)="2":"In Process",$P($G(DGRPX),U,2)="3":"Confirmed",1:"")
"RTN","DGRP6",30,0)
 I $P($G(DGRPX),U)="N" D
"RTN","DGRP6",31,0)
 . S DGX=$P(DGRPX,U,3)
"RTN","DGRP6",32,0)
 . S DGX=$S($G(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGX)=2:"NO DOCUMENTATION REC'D",$G(DGX)=3:"ENTERED IN ERROR",$G(DGX)=4:"UNSUPPORTED PURPLE HEART",$G(DGX)=5:"VAMC",$G(DGX)=6:"UNDELIVERABLE MAIL",1:"")
"RTN","DGRP6",33,0)
 . I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"")
"RTN","DGRP6",34,0)
Q K DGRPD,DGRPSV
"RTN","DGRP6",35,0)
 G ^DGRPP
"RTN","DGRP6",36,0)
YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNK",1:"") D WW1^DGRPV Q
"RTN","DGRP6",37,0)
DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z=""
"RTN","DGRP6",38,0)
 E  S Z=$$FMTE^XLFDT(Z,"5DZ")
"RTN","DGRP6",39,0)
 D WW1^DGRPV Q
"RTN","DGRP6",40,0)
DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q
"RTN","DGRP6",41,0)
S ;Write Military Service Episodes (DG*5.3*797)
"RTN","DGRP6",42,0)
 N DGL
"RTN","DGRP6",43,0)
 Q:$G(GLBL)=""
"RTN","DGRP6",44,0)
 S DGL=0 F  S DGL=$O(@GLBL@(DGL)) Q:'DGL!(DGL>3)  D
"RTN","DGRP6",45,0)
 .I $G(@GLBL@(DGL,0))]"" W !,@GLBL@(DGL,0)
"RTN","DGRP6",46,0)
 I DGL>3 W !,"    <more episodes>" Q
"RTN","DGRP6",47,0)
 Q
"RTN","DGRP6",48,0)
MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q
"RTN","DGRP6",49,0)
 ;
"RTN","DGRP6",50,0)
SETLNEX(Z,SEQ,LIN,LENGTH) ;
"RTN","DGRP6",51,0)
 I 'LIN S LIN=1,LIN(1)=""
"RTN","DGRP6",52,0)
 S Z=$E("("_SEQ_") "_Z,1,75)
"RTN","DGRP6",53,0)
 I LENGTH+$L(Z)>$S(LIN<2:49,1:70) S LIN=LIN+1,LIN(LIN)="",LENGTH=0
"RTN","DGRP6",54,0)
 S LIN(LIN)=LIN(LIN)_$S(LENGTH:"    ",1:"")_Z,LENGTH=$L(LIN(LIN))
"RTN","DGRP6",55,0)
 Q
"RTN","DGRP6",56,0)
 ;
"RTN","DGRP61")
0^11^B46948072
"RTN","DGRP61",1,0)
DGRP61 ;ALB/PJH,LBD - Patient MSDS History - List Manager Screen;12 JUN 1997 10:00 am ; 2/5/12 10:18pm
"RTN","DGRP61",2,0)
 ;;5.3;Registration;**797**;08/13/93;Build 24
"RTN","DGRP61",3,0)
 ;
"RTN","DGRP61",4,0)
EN(DFN) ;Main entry point to invoke the DGEN MSDS PATIENT list
"RTN","DGRP61",5,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGRP61",6,0)
 ;
"RTN","DGRP61",7,0)
 D WAIT^DICD
"RTN","DGRP61",8,0)
 D EN^VALM("DGEN MSDS PATIENT")
"RTN","DGRP61",9,0)
 Q
"RTN","DGRP61",10,0)
 ;
"RTN","DGRP61",11,0)
HDR ;Header code
"RTN","DGRP61",12,0)
 N DGPREFNM,X,VA,VAERR
"RTN","DGRP61",13,0)
 S VALMHDR(1)=$J("",25)_"MILITARY SERVICE DATA, SCREEN <6.1>"
"RTN","DGRP61",14,0)
 D PID^VADPT
"RTN","DGRP61",15,0)
 S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
"RTN","DGRP61",16,0)
 S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")"
"RTN","DGRP61",17,0)
 S X="PATIENT TYPE UNKNOWN"
"RTN","DGRP61",18,0)
 I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
"RTN","DGRP61",19,0)
 S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80)
"RTN","DGRP61",20,0)
 S VALMHDR(3)=$J("",4)_"Service Branch/Component  Service #"
"RTN","DGRP61",21,0)
 S VALMHDR(3)=VALMHDR(3)_"        Entered    Separated   Discharge"
"RTN","DGRP61",22,0)
 Q
"RTN","DGRP61",23,0)
 ;
"RTN","DGRP61",24,0)
INIT ;Build patient MSDS screen
"RTN","DGRP61",25,0)
 D CLEAN^VALM10
"RTN","DGRP61",26,0)
 K ^TMP("DGRP61",$J),DGSEL
"RTN","DGRP61",27,0)
 ;
"RTN","DGRP61",28,0)
 N GLBL
"RTN","DGRP61",29,0)
 S GLBL=$NA(^TMP("DGRP61",$J))
"RTN","DGRP61",30,0)
 D GETMSE(DFN,GLBL,1)
"RTN","DGRP61",31,0)
 ;Check if any old MSEs didn't copy and display warning message
"RTN","DGRP61",32,0)
 I $$WARNMSG^DGMSEUTL(DFN) D
"RTN","DGRP61",33,0)
 .S VALMSG="**More MSEs available to view on History Screen**"
"RTN","DGRP61",34,0)
 .D MSG^VALM10(VALMSG)
"RTN","DGRP61",35,0)
 Q
"RTN","DGRP61",36,0)
 ;
"RTN","DGRP61",37,0)
GETMSE(DFN,GLBL,NUM) ;Load service episodes from .3216 array
"RTN","DGRP61",38,0)
 ; INPUT: DFN = Patient IEN
"RTN","DGRP61",39,0)
 ;        GLBL = ^TMP global ref
"RTN","DGRP61",40,0)
 ;        NUM = 1 - display line numbers
"RTN","DGRP61",41,0)
 N DGDATA,DGDATE,DGSUB
"RTN","DGRP61",42,0)
 S VALMCNT=0,DGDATE=""
"RTN","DGRP61",43,0)
 F  S DGDATE=$O(^DPT(DFN,.3216,"B",DGDATE),-1) Q:'DGDATE  D
"RTN","DGRP61",44,0)
 .S DGSUB=$O(^DPT(DFN,.3216,"B",DGDATE,"")) Q:'DGSUB
"RTN","DGRP61",45,0)
 .S DGDATA=$G(^DPT(DFN,.3216,DGSUB,0)) Q:DGDATA=""
"RTN","DGRP61",46,0)
 .D EPISODE(DGDATA,GLBL,NUM)
"RTN","DGRP61",47,0)
 Q
"RTN","DGRP61",48,0)
 ;
"RTN","DGRP61",49,0)
EPISODE(DGDATA,GLBL,NUM) ;Format individual service episode
"RTN","DGRP61",50,0)
 N Z,DGRPSB,DGRPSC,DGRPSD,DGRPSE,DGRPSN,DGRPSS
"RTN","DGRP61",51,0)
 S DGRPSB=+$P(DGDATA,U,3),DGRPSC=$P(DGDATA,U,4),DGRPSN=$P(DGDATA,U,5)
"RTN","DGRP61",52,0)
 ;Service Branch/Component
"RTN","DGRP61",53,0)
 S Z=$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:"UNKNOWN")
"RTN","DGRP61",54,0)
 I DGRPSC'="" D
"RTN","DGRP61",55,0)
 . N Z0
"RTN","DGRP61",56,0)
 . S Z0=$$SVCCOMP^DGRP6CL(DGRPSC) Q:Z0=""
"RTN","DGRP61",57,0)
 . S Z=Z_"/"_Z0
"RTN","DGRP61",58,0)
 ;Filipino vet proof
"RTN","DGRP61",59,0)
 I $$FV^DGRPMS(DGRPSB)=1 S Z=$E(Z_$J("",21),1,21)_"("_$P($G(^DPT(DFN,.321)),U,14)_")"
"RTN","DGRP61",60,0)
 ;Service Number
"RTN","DGRP61",61,0)
 S Z=Z_$J("",26-$L(Z))_$S(DGRPSN]"":DGRPSN,1:"UNKNOWN")
"RTN","DGRP61",62,0)
 S Z=Z_$J("",42-$L(Z))
"RTN","DGRP61",63,0)
 ;Entry and separation dates
"RTN","DGRP61",64,0)
 S DGRPSE=$P(DGDATA,U,1),DGRPSS=$P(DGDATA,U,2)
"RTN","DGRP61",65,0)
 S X=$S(DGRPSE]"":$$FMTE^XLFDT(DGRPSE,"5DZ"),1:"UNKNOWN   ")
"RTN","DGRP61",66,0)
 S Z=Z_$E(X,1,10)_"  "
"RTN","DGRP61",67,0)
 S X=$S(DGRPSS]"":$$FMTE^XLFDT(DGRPSS,"5DZ"),1:"UNKNOWN   ")
"RTN","DGRP61",68,0)
 S Z=Z_$E(X,1,10)_"  "
"RTN","DGRP61",69,0)
 ;Discharge type
"RTN","DGRP61",70,0)
 S DGRPSD=+$P(DGDATA,U,6)
"RTN","DGRP61",71,0)
 I 'DGRPSD S Z=Z_"UNKNOWN"
"RTN","DGRP61",72,0)
 E  S Z=Z_$S($D(^DIC(25,+DGRPSD)):$E($P(^DIC(25,DGRPSD,0),"^",1),1,9),1:"UNKNOWN")
"RTN","DGRP61",73,0)
 S VALMCNT=VALMCNT+1
"RTN","DGRP61",74,0)
 ;Add line numbers if NUM=1
"RTN","DGRP61",75,0)
 I $G(NUM) D
"RTN","DGRP61",76,0)
 .I $G(DGRPV)!($P(DGDATA,U,7)]"") S Z="<"_VALMCNT_"> "_Z Q
"RTN","DGRP61",77,0)
 .S Z="["_VALMCNT_"] "_Z,DGSEL(VALMCNT)=DGRPSE
"RTN","DGRP61",78,0)
 ;Save to List Manager array for display
"RTN","DGRP61",79,0)
 S @GLBL@(VALMCNT,0)=$S($G(NUM):Z,1:$J("",4)_Z)
"RTN","DGRP61",80,0)
 Q
"RTN","DGRP61",81,0)
 ;
"RTN","DGRP61",82,0)
HELP ;Help code
"RTN","DGRP61",83,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","DGRP61",84,0)
 Q
"RTN","DGRP61",85,0)
 ;
"RTN","DGRP61",86,0)
EXIT ;Exit code
"RTN","DGRP61",87,0)
 D CLEAN^VALM10
"RTN","DGRP61",88,0)
 D CLEAR^VALM1
"RTN","DGRP61",89,0)
 K ^TMP("DGRP61",$J)
"RTN","DGRP61",90,0)
 Q
"RTN","DGRP61",91,0)
 ;
"RTN","DGRP61",92,0)
PEXIT ;DGEN MSDS MENU protocol exit code
"RTN","DGRP61",93,0)
 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
"RTN","DGRP61",94,0)
 ;Reset after page up or down
"RTN","DGRP61",95,0)
 ;D XQORM
"RTN","DGRP61",96,0)
 Q
"RTN","DGRP61",97,0)
 ;
"RTN","DGRP61",98,0)
ACT(DGACT) ; Entry point for menu action selection
"RTN","DGRP61",99,0)
 ; INPUT: DGACT = "A" - Add - DGEN MSDS ADD protocol
"RTN","DGRP61",100,0)
 ;              = "E" - Edit - DGEN MSDS EDIT protocol
"RTN","DGRP61",101,0)
 ;              = "D" - Delete - DGEN MSDS DELETE protocol
"RTN","DGRP61",102,0)
 N DGX,DA,DIE,DIC,DIK,DIPA,DR,X,Y
"RTN","DGRP61",103,0)
 I $G(DGACT)="" G ACTQ
"RTN","DGRP61",104,0)
 I $G(DGRPV) W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ
"RTN","DGRP61",105,0)
 D FULL^VALM1
"RTN","DGRP61",106,0)
 I DGACT="A" D ADD G ACTQ
"RTN","DGRP61",107,0)
 I '$D(DGSEL) D  G ACTQ
"RTN","DGRP61",108,0)
 .W !,"There are no episodes to ",$S(DGACT="E":"edit.",1:"delete.")
"RTN","DGRP61",109,0)
 .I $G(VALMCNT) D HECHLP
"RTN","DGRP61",110,0)
 .D PAUSE^VALM1
"RTN","DGRP61",111,0)
 S DGX=$$SEL(DGACT) I 'DGX G ACTQ
"RTN","DGRP61",112,0)
 S DGX=$G(DGSEL(DGX)) I 'DGX G ACTQ
"RTN","DGRP61",113,0)
 S DA(1)=DFN,DIC="^DPT("_DA(1)_",.3216,",DIC(0)="BX",X=DGX
"RTN","DGRP61",114,0)
 D ^DIC I Y<0 W !,"This episode is not in the patient's record." D PAUSE^VALM1 G ACTQ
"RTN","DGRP61",115,0)
 S DIPA("DA")=+Y
"RTN","DGRP61",116,0)
 I DGACT="E" K DA,DIC,DGFRDT S DIE="^DPT(",DA=DFN D SETDR1 D ^DIE
"RTN","DGRP61",117,0)
 I DGACT="D" D
"RTN","DGRP61",118,0)
 .I '$$RUSURE Q
"RTN","DGRP61",119,0)
 .S DIK=DIC,DA(1)=DFN,DA=DIPA("DA") D ^DIK K DIK
"RTN","DGRP61",120,0)
ACTQ D INIT S VALMBCK="R" Q
"RTN","DGRP61",121,0)
 ;
"RTN","DGRP61",122,0)
ADD ; Add new MSE to #2.3216 sub-file
"RTN","DGRP61",123,0)
 N X,Y,DIK,DA,DR,DIE,NEXT,DGFRDT
"RTN","DGRP61",124,0)
 ; Get next record number in sub-file
"RTN","DGRP61",125,0)
 S NEXT=$O(^DPT(DFN,.3216,"A"),-1),NEXT=NEXT+1
"RTN","DGRP61",126,0)
 D ZNODE(1)
"RTN","DGRP61",127,0)
 ; Prompt for MSE fields
"RTN","DGRP61",128,0)
 S DIE="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D SETDR2 D ^DIE
"RTN","DGRP61",129,0)
 ; Check if new record is missing or incomplete
"RTN","DGRP61",130,0)
 I '$D(^DPT(DFN,.3216,NEXT)) D ZNODE(-1) Q
"RTN","DGRP61",131,0)
 I '$P(^DPT(DFN,.3216,NEXT,0),U) D  Q
"RTN","DGRP61",132,0)
 .S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK
"RTN","DGRP61",133,0)
 ; File FILIPINO VET PROOF, if set
"RTN","DGRP61",134,0)
 I $G(DIPA("FVP"))]"" D
"RTN","DGRP61",135,0)
 .K DA,DR S DIE="^DPT(",DA=DFN,DR=".3214///^S X=DIPA(""FVP"")"
"RTN","DGRP61",136,0)
 .D ^DIE
"RTN","DGRP61",137,0)
 Q
"RTN","DGRP61",138,0)
SEL(ACT) ; Prompt for episode to edit/delete
"RTN","DGRP61",139,0)
 N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",140,0)
 S DIR(0)="NAO^1:"_VALMCNT_"^K:'$D(DGSEL(X)) X"
"RTN","DGRP61",141,0)
 S DIR("A")="Select Episode: "
"RTN","DGRP61",142,0)
 S DIR("?")="^D SELHLP^DGRP61(ACT)"
"RTN","DGRP61",143,0)
 D ^DIR I 'Y Q 0
"RTN","DGRP61",144,0)
 Q Y
"RTN","DGRP61",145,0)
SELHLP(ACT) ; Help message for episode prompt
"RTN","DGRP61",146,0)
 W !,"Select an episode to ",$S(ACT="E":"edit.",1:"delete.")
"RTN","DGRP61",147,0)
 W !,"Only numbers in square brackets [ ] are selectable."
"RTN","DGRP61",148,0)
 D HECHLP
"RTN","DGRP61",149,0)
 N DIR D PAUSE^VALM1
"RTN","DGRP61",150,0)
 Q
"RTN","DGRP61",151,0)
HECHLP ; Help message for episodes that can only be changed by HEC
"RTN","DGRP61",152,0)
 W !,"Angled brackets < > indicate episodes that cannot be changed in VistA."
"RTN","DGRP61",153,0)
 W !,"Please contact the HECAlert mail group or the HEC if you need to update"
"RTN","DGRP61",154,0)
 W !,"this information."
"RTN","DGRP61",155,0)
 Q
"RTN","DGRP61",156,0)
 ;
"RTN","DGRP61",157,0)
ZNODE(VAL) ; Update zero node of MSE multiple .3216
"RTN","DGRP61",158,0)
 Q:'$G(VAL)  Q:'$G(DFN)
"RTN","DGRP61",159,0)
 N ZNODE
"RTN","DGRP61",160,0)
 S ZNODE=$G(^DPT(DFN,.3216,0))
"RTN","DGRP61",161,0)
 S ^DPT(DFN,.3216,0)="^2.3216D^"_($P(ZNODE,U,3)+VAL)_U_($P(ZNODE,U,4)+VAL)
"RTN","DGRP61",162,0)
 Q
"RTN","DGRP61",163,0)
SETDR1 ; Set DR array to edit MSE fields
"RTN","DGRP61",164,0)
 S DR="I '$G(DIPA(""DA"")) S Y=0;.3216////^S X=""`""_DIPA(""DA"");.3214///^S X=$G(DIPA(""FVP""))"
"RTN","DGRP61",165,0)
 S DR(2,2.3216)="D SET0^DGRP61(.DA,.DIPA);@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61"
"RTN","DGRP61",166,0)
 S DR(2,2.3216,1)="I DIPA(""FVP"")=""^"" K DIPA(""FVP"") S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";S Y=""@63"""
"RTN","DGRP61",167,0)
 S DR(2,2.3216,2)="@62;D:DIPA(""X"")]"""" WARN^DGRP61(.DIPA,.Y);.04;@63;.05;.01;.02;.06"
"RTN","DGRP61",168,0)
 Q
"RTN","DGRP61",169,0)
SETDR2 ; Set DR array to add MSE fields
"RTN","DGRP61",170,0)
 S DR="@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61;I DIPA(""FVP"")=""^"" S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";@62;S:'$$CMP^DGRP61(DIPA(""X"")) Y=""@63"";.04;@63;.05;.01;.02;.06"
"RTN","DGRP61",171,0)
 Q
"RTN","DGRP61",172,0)
FVP() ; Prompt for FILIPINO VET PROOF
"RTN","DGRP61",173,0)
 N DA,X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",174,0)
 S DIR(0)="2,.3214",DA=DFN
"RTN","DGRP61",175,0)
 D ^DIR I Y=""!(Y="^") Q Y
"RTN","DGRP61",176,0)
 Q Y
"RTN","DGRP61",177,0)
 ;
"RTN","DGRP61",178,0)
SET0(DA,DIPA) ; Set DIPA(0) to values of Service Branch and Service Component
"RTN","DGRP61",179,0)
 K DIPA(0)
"RTN","DGRP61",180,0)
 S DIPA(0)=$P($G(^DPT(DA(1),.3216,DA,0)),U,3,4)
"RTN","DGRP61",181,0)
 Q
"RTN","DGRP61",182,0)
 ;
"RTN","DGRP61",183,0)
WARN(DIPA,Y) ;Warns that the Service Branch was changed so the
"RTN","DGRP61",184,0)
 ; Service Component was deleted
"RTN","DGRP61",185,0)
 ; Returns Y to skip component if the component should not be asked
"RTN","DGRP61",186,0)
 ;   for this branch of service
"RTN","DGRP61",187,0)
 I '$$CMP($G(DIPA("X"))) S Y="@63"
"RTN","DGRP61",188,0)
 I $P($G(DIPA(0)),U,2)=""!($P($G(DIPA(0)),U)="") Q
"RTN","DGRP61",189,0)
 I $P(DIPA(0),U)=DIPA("X") Q   ;Service Branch didn't change
"RTN","DGRP61",190,0)
 ;
"RTN","DGRP61",191,0)
 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
"RTN","DGRP61",192,0)
 Q
"RTN","DGRP61",193,0)
 ;
"RTN","DGRP61",194,0)
CMP(X) ; Function to determine if service component is valid for
"RTN","DGRP61",195,0)
 ; branch of service ien in X   0 = invalid  1 = valid  
"RTN","DGRP61",196,0)
 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
"RTN","DGRP61",197,0)
 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
"RTN","DGRP61",198,0)
 ;
"RTN","DGRP61",199,0)
RUSURE() ; Confirmation prompt for deleting episode
"RTN","DGRP61",200,0)
 N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",201,0)
 S DIR(0)="YA",DIR("B")="NO"
"RTN","DGRP61",202,0)
 S DIR("A")="Are you sure you want to delete this military service episode? "
"RTN","DGRP61",203,0)
 D ^DIR I 'Y W !,"<< NOTHING DELETED >>" Q 0
"RTN","DGRP61",204,0)
 Q 1
"RTN","DGRP62")
0^12^B4564085
"RTN","DGRP62",1,0)
DGRP62 ;ALB/PJH,LBD - Patient MSDS History - List Manager Screen;12 JUN 1997 10:00 am ; 6/23/09 3:48pm
"RTN","DGRP62",2,0)
 ;;5.3;Registration;**797**;08/13/93;Build 24
"RTN","DGRP62",3,0)
 ;
"RTN","DGRP62",4,0)
EN(DFN) ;Main entry point to invoke the DGEN PATIENT MSDS VIEW list
"RTN","DGRP62",5,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGRP62",6,0)
 ;
"RTN","DGRP62",7,0)
 D WAIT^DICD
"RTN","DGRP62",8,0)
 D EN^VALM("DGEN MSDS PATIENT VIEW")
"RTN","DGRP62",9,0)
 Q
"RTN","DGRP62",10,0)
 ;
"RTN","DGRP62",11,0)
HDR ;Header code
"RTN","DGRP62",12,0)
 N DGPREFNM,X,VA,VAERR
"RTN","DGRP62",13,0)
 S VALMHDR(1)=$J("",18)_"VISTA MILITARY SERVICE DATA, SCREEN <6.2>"
"RTN","DGRP62",14,0)
 D PID^VADPT
"RTN","DGRP62",15,0)
 S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
"RTN","DGRP62",16,0)
 S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")"
"RTN","DGRP62",17,0)
 S X="PATIENT TYPE UNKNOWN"
"RTN","DGRP62",18,0)
 I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
"RTN","DGRP62",19,0)
 S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80)
"RTN","DGRP62",20,0)
 S VALMHDR(3)=$J("",4)_"Service Branch/Component  Service #"
"RTN","DGRP62",21,0)
 S VALMHDR(3)=VALMHDR(3)_"        Entered    Separated   Discharge"
"RTN","DGRP62",22,0)
 Q
"RTN","DGRP62",23,0)
 ;
"RTN","DGRP62",24,0)
INIT ;Build patient MSDS screen
"RTN","DGRP62",25,0)
 D CLEAN^VALM10
"RTN","DGRP62",26,0)
 K ^TMP("DGRP62",$J)
"RTN","DGRP62",27,0)
 ;
"RTN","DGRP62",28,0)
 N GLBL
"RTN","DGRP62",29,0)
 S GLBL=$NA(^TMP("DGRP62",$J))
"RTN","DGRP62",30,0)
 D GETMSE(DFN,GLBL,0)
"RTN","DGRP62",31,0)
 Q
"RTN","DGRP62",32,0)
 ;
"RTN","DGRP62",33,0)
GETMSE(DFN,GLBL,NUM) ;Get old format MSE data from node .32
"RTN","DGRP62",34,0)
 N DGDATA
"RTN","DGRP62",35,0)
 S VALMCNT=0
"RTN","DGRP62",36,0)
 S:'$D(DGRP(.32)) DGRP(.32)=$G(^DPT(DFN,.32))
"RTN","DGRP62",37,0)
 S:'$D(DGRP(.3291)) DGRP(.3291)=$G(^DPT(DFN,.3291))
"RTN","DGRP62",38,0)
 ;Last service episode (SL)
"RTN","DGRP62",39,0)
 S DGDATA=$$SETDAT(.DGRP,4)
"RTN","DGRP62",40,0)
 D EPISODE^DGRP61(DGDATA,GLBL,NUM)
"RTN","DGRP62",41,0)
 ;Next to last service episode (SNL)
"RTN","DGRP62",42,0)
 Q:$P(DGRP(.32),U,19)'="Y"
"RTN","DGRP62",43,0)
 S DGDATA=$$SETDAT(.DGRP,9)
"RTN","DGRP62",44,0)
 D EPISODE^DGRP61(DGDATA,GLBL,NUM)
"RTN","DGRP62",45,0)
 ;Prior episode (SNNL)
"RTN","DGRP62",46,0)
 Q:$P(DGRP(.32),U,20)'="Y"
"RTN","DGRP62",47,0)
 S DGDATA=$$SETDAT(.DGRP,14)
"RTN","DGRP62",48,0)
 D EPISODE^DGRP61(DGDATA,GLBL,NUM)
"RTN","DGRP62",49,0)
 Q
"RTN","DGRP62",50,0)
 ;
"RTN","DGRP62",51,0)
SETDAT(DGRP,FLD) ;Set MSE data into DGDATA
"RTN","DGRP62",52,0)
 N DGX,DGY
"RTN","DGRP62",53,0)
 Q:'$G(FLD) ""
"RTN","DGRP62",54,0)
 S DGX=$G(DGRP(.32)) I DGX="" Q ""
"RTN","DGRP62",55,0)
 S DGY=$G(DGRP(.3291))
"RTN","DGRP62",56,0)
 Q $P(DGX,U,FLD+2)_U_$P(DGX,U,FLD+3)_U_$P(DGX,U,FLD+1)_U_$P(DGY,U,FLD+1/5)_U_$P(DGX,U,FLD+4)_U_$P(DGX,U,FLD)
"RTN","DGRP62",57,0)
 ;
"RTN","DGRP62",58,0)
 ;
"RTN","DGRP62",59,0)
HELP ;Help code
"RTN","DGRP62",60,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","DGRP62",61,0)
 Q
"RTN","DGRP62",62,0)
 ;
"RTN","DGRP62",63,0)
EXIT ;Exit code
"RTN","DGRP62",64,0)
 D CLEAN^VALM10
"RTN","DGRP62",65,0)
 D CLEAR^VALM1
"RTN","DGRP62",66,0)
 K ^TMP("DGRP62",$J)
"RTN","DGRP62",67,0)
 Q
"RTN","DGRP6CL")
0^18^B70196214
"RTN","DGRP6CL",1,0)
DGRP6CL ;ALB/TMK,LBD - REGISTRATION SCREEN 6 FIELDS Conflict locations ; 6/23/09 4:08pm
"RTN","DGRP6CL",2,0)
 ;;5.3;Registration;**689,751,764,797**;Aug 13, 1993;Build 24
"RTN","DGRP6CL",3,0)
 ;
"RTN","DGRP6CL",4,0)
CLLST(DFN,DGCONF,DGPOSS,DGMSE) ;
"RTN","DGRP6CL",5,0)
 ; For patient DFN:
"RTN","DGRP6CL",6,0)
 ; Returns DGCONF array: DGCONF(conf loc)= Start dt^End dt
"RTN","DGRP6CL",7,0)
 ;  or, for multiple OEF/OIF/ UNKNOWN OEF/OIF: DGCONF(conf loc-ien) =
"RTN","DGRP6CL",8,0)
 ;                    Start dt ^ End dt ^ Site source ^ Lock flag
"RTN","DGRP6CL",9,0)
 ;    DGCONF(conflict loc,1)=1 if dts inconsistent w/mse dts
"RTN","DGRP6CL",10,0)
 ; DGPOSS = array of possible conflict locations, based on service
"RTN","DGRP6CL",11,0)
 ;          episode dts DGPOSS(conf loc)=""
"RTN","DGRP6CL",12,0)
 ; DGMSE = array of military svc episodes
"RTN","DGRP6CL",13,0)
 ;          DGMSE(1-n)=fr dt^to dt^branch ien^comp code
"RTN","DGRP6CL",14,0)
 ;
"RTN","DGRP6CL",15,0)
 N DGZ,DGZ0,DIQUIET,FRTO
"RTN","DGRP6CL",16,0)
 S DIQUIET=1 K DGCONF,DGPOSS
"RTN","DGRP6CL",17,0)
 ; Get Military Service Episodes and store in DGMSE array (DG*5.3*797)
"RTN","DGRP6CL",18,0)
 D GETMSE
"RTN","DGRP6CL",19,0)
 ;
"RTN","DGRP6CL",20,0)
 ; Must chk all possible/on-file conf locs for valid mil svc pd
"RTN","DGRP6CL",21,0)
 ; Extract OEF/OIF data
"RTN","DGRP6CL",22,0)
 F DGZ="OEF","OIF","UNK" S DGCONF(DGZ)=""
"RTN","DGRP6CL",23,0)
 D GET^DGENOEIF(DFN,.DGZ,0,"","")
"RTN","DGRP6CL",24,0)
 S DGZ0=0 F  S DGZ0=$O(DGZ("IEN",DGZ0)) Q:'DGZ0  S DGZ=$G(DGZ("IEN",DGZ0)) D
"RTN","DGRP6CL",25,0)
 . N DGCONFX
"RTN","DGRP6CL",26,0)
 . Q:'$G(DGZ("FR",DGZ0))&'$G(DGZ("TO",DGZ0))
"RTN","DGRP6CL",27,0)
 . S DGCONFX=$P("OIF^OEF^UNK",U,+$G(DGZ("LOC",DGZ0)))_"-"_DGZ,DGCONF=DGCONFX,DGCONF($P(DGCONFX,"-"))=$G(DGCONF($P(DGCONFX,"-")))_DGZ_";"
"RTN","DGRP6CL",28,0)
 . F FRTO=1,0 S $P(DGCONF(DGCONFX),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONFX,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
"RTN","DGRP6CL",29,0)
 . S $P(DGCONF(DGCONFX),U,3)=$G(DGZ("SITE",DGZ0))
"RTN","DGRP6CL",30,0)
 . S $P(DGCONF(DGCONFX),U,4)=$G(DGZ("LOCK",DGZ0))
"RTN","DGRP6CL",31,0)
 F DGCONF="OEF","OIF","UNK" D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
"RTN","DGRP6CL",32,0)
 F DGCONF="VIET","LEB","GREN","PAN","GULF","SOM","YUG" F FRTO=1,0 S $P(DGCONF(DGCONF),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONF,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
"RTN","DGRP6CL",33,0)
 Q
"RTN","DGRP6CL",34,0)
 ;
"RTN","DGRP6CL",35,0)
GETMSE ;Get Military Service Data and store in DGMSE array (DG*5.3*797)
"RTN","DGRP6CL",36,0)
 ;DGMSE(1-3)=fr dt^to dt^branch ien^comp code
"RTN","DGRP6CL",37,0)
 ;Get MSE data from MSE sub-file #2.3216, if it's populated
"RTN","DGRP6CL",38,0)
 N MSE,DGZ,DGZ0,DGZ1,DG32,DG3291
"RTN","DGRP6CL",39,0)
 I $D(^DPT(DFN,.3216)) D  Q
"RTN","DGRP6CL",40,0)
 . D GETMSE^DGMSEUTL(DFN,.MSE)
"RTN","DGRP6CL",41,0)
 . S (MSE,DGZ)=0
"RTN","DGRP6CL",42,0)
 . F  S MSE=$O(MSE(MSE)) Q:'MSE  S DGZ=DGZ+1,DGMSE(DGZ)=$P(MSE(MSE),U,1,4)
"RTN","DGRP6CL",43,0)
 ;Else get MSE data from .32 and .3291 nodes of Patient file #2
"RTN","DGRP6CL",44,0)
 S DG32=$G(^DPT(DFN,.32)),DG3291=$G(^(.3291))
"RTN","DGRP6CL",45,0)
 S DGZ1=0
"RTN","DGRP6CL",46,0)
 F DGZ=1:1:3 S DGZ0=$S(DGZ=1:"5^5^6^7",DGZ=2:"19^10^11^12",1:"20^15^16^17") D
"RTN","DGRP6CL",47,0)
 . Q:$S($P(DG32,U,+DGZ0)="Y":0,1:'$P(DG32,U,+DGZ0))
"RTN","DGRP6CL",48,0)
 . S DGZ1=DGZ1+1,DGMSE(DGZ1)=$P(DG32,U,$P(DGZ0,U,3))_U_$P(DG32,U,$P(DGZ0,U,4))_U_$P(DG32,U,$P(DGZ0,U,2))_U_$P(DG3291,U,DGZ)
"RTN","DGRP6CL",49,0)
 Q
"RTN","DGRP6CL",50,0)
 ;
"RTN","DGRP6CL",51,0)
YN(DGRPX,X) ;Format Yes/No fld in $P(DGRPX,U,X)
"RTN","DGRP6CL",52,0)
 Q $S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO ",$P(DGRPX,"^",X)="U":"UNK",1:"   ")
"RTN","DGRP6CL",53,0)
 ;
"RTN","DGRP6CL",54,0)
DAT(DGRPX,X,Z1) ; Format dt in $P(DGRPX,U,X) for a length of Z1
"RTN","DGRP6CL",55,0)
 N Z
"RTN","DGRP6CL",56,0)
 S Z=$P(DGRPX,U,X)
"RTN","DGRP6CL",57,0)
 I Z'="" S Z=$$FMTE^XLFDT(Z,"5DZ")
"RTN","DGRP6CL",58,0)
 S:$L(Z)<Z1 Z=$E(Z_$J("",Z1),1,Z1)
"RTN","DGRP6CL",59,0)
 Q Z
"RTN","DGRP6CL",60,0)
 ;
"RTN","DGRP6CL",61,0)
EN(DFN,QUIT) ; Entry from reg screen 6
"RTN","DGRP6CL",62,0)
 N DIPA,DGCONF,DGCONFS,DGCONF1,DGMSE,DGMSG,DGPOSS,DIR,DIE,DR,DA
"RTN","DGRP6CL",63,0)
 ;
"RTN","DGRP6CL",64,0)
 ; Return QUIT=1 if ^ entered
"RTN","DGRP6CL",65,0)
EN1 ; Entry from conf subscreen off reg screen 6
"RTN","DGRP6CL",66,0)
 ; Routine loops until exit/quit from subscreen
"RTN","DGRP6CL",67,0)
 D CLEAR^VALM1
"RTN","DGRP6CL",68,0)
 K DGCONF,DGCONFS,DGPOSS,DGMSE,DGMSG,DGDISP
"RTN","DGRP6CL",69,0)
 N DIR,DTOUT,DUOUT,Z,Z0,Z1,Z2,X,Y,LOOP,DG,DGM,DGZ,DGEG,DGEGS,DGX,DGX1,DG321,DG322,DGCT,DGY,DGY1,DGCTX,SSN
"RTN","DGRP6CL",70,0)
 D CLLST(DFN,.DGCONF,.DGPOSS,.DGMSE)
"RTN","DGRP6CL",71,0)
 I $G(DGRPV) S $E(DGRPVV(6),2,3)="00",DGRPVV(6,"NOEDIT")=1
"RTN","DGRP6CL",72,0)
 I '$G(DGRPV),$E(DGRPVV(6),2,3)="11" S $E(DGRPVV(6),2,3)="00",DGRPVV(6,"NOEDIT")=1
"RTN","DGRP6CL",73,0)
 S DGMSG=0,DGCTX=0
"RTN","DGRP6CL",74,0)
 F Z="OEF","OIF","UNK" D  ; Sort OEF/OIF/ UNKNOWN OEF/OIF
"RTN","DGRP6CL",75,0)
 . ; by reverse from dt within each conf
"RTN","DGRP6CL",76,0)
 . S Z0=Z F  S Z0=$O(DGCONF(Z0)) Q:Z0=""!(Z0'[Z)  S Z2=Z_"-"_(9999999-DGCONF(Z0)) S DGCONFS(Z2)=$P(Z0,"-",2) I 'DGMSG,$G(DGCONF(Z0,1)) S DGMSG=1
"RTN","DGRP6CL",77,0)
 S DG321=$G(^DPT(DFN,.321)),DG322=$G(^(.322))
"RTN","DGRP6CL",78,0)
 ;
"RTN","DGRP6CL",79,0)
 S DIR(0)="SA^",DGCT=0
"RTN","DGRP6CL",80,0)
 S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
"RTN","DGRP6CL",81,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=$$SSNNM^DGRPU(DFN)
"RTN","DGRP6CL",82,0)
 S DGCT=DGCT+1,DIR("A",DGCT)="",$P(DIR("A",DGCT),"=",81)=""
"RTN","DGRP6CL",83,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=$S($O(DGMSE(0)):"MILITARY SERVICE PERIODS:",1:"NO SERVICE PERIODS FOR THIS PATIENT - NO CONFLICT LOC CAN BE ENTERED")
"RTN","DGRP6CL",84,0)
 S Z=0 F  S Z=$O(DGMSE(Z)) Q:'Z!(Z>4)  D
"RTN","DGRP6CL",85,0)
 . I Z=4 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",3)_"<more episodes>" Q
"RTN","DGRP6CL",86,0)
 . S DGCT=DGCT+1,DIR("A",DGCT)=$J("",3)_$E($$EXTERNAL^DILFD(2,.325,"",$P(DGMSE(Z),U,3))_$S($P(DGMSE(Z),U,4)'="":"/"_$$SVCCOMP($P(DGMSE(Z),U,4)),1:"")_$J("",30),1,30)
"RTN","DGRP6CL",87,0)
 . S DIR("A",DGCT)=DIR("A",DGCT)_"  ("_$S($P(DGMSE(Z),U):$$FMTE^XLFDT($P(DGMSE(Z),U),"5DZ"),1:"missing")_"-"_$S($P(DGMSE(Z),U,2):$$FMTE^XLFDT($P(DGMSE(Z),U,2),"5DZ"),1:"missing")_")"
"RTN","DGRP6CL",88,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=" "
"RTN","DGRP6CL",89,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",24)_"---- CONFLICT LOCATIONS ----"
"RTN","DGRP6CL",90,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",34)_"FROM"_$J("",9)_"TO"_$J("",7)_"SOURCE (FOR OEF/OIF)"
"RTN","DGRP6CL",91,0)
 ; DGCONF(DGCONF,"OK")=# entries for OEF/OIF/ UNKNOWN OEF/OIF
"RTN","DGRP6CL",92,0)
 ;                     that are site-entered
"RTN","DGRP6CL",93,0)
 ; DGCONF(DGCONF,"OK",entry ien)=display #^formatted from dt^
"RTN","DGRP6CL",94,0)
 ;       formatted to dt^inconsistent flag (valid entries for editing)
"RTN","DGRP6CL",95,0)
 S DGEG=0
"RTN","DGRP6CL",96,0)
 F DGEGS=2,1,3 D
"RTN","DGRP6CL",97,0)
 . S DGCONF=$P("OIF^OEF^UNK",U,DGEGS),DGM=0
"RTN","DGRP6CL",98,0)
 . S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
"RTN","DGRP6CL",99,0)
 . S DGEG=DGEG+1
"RTN","DGRP6CL",100,0)
 . S DGDISP=$S(DGCONF'="UNK":$J("",8),1:"OEF/OIF ")_DGCONF_": "
"RTN","DGRP6CL",101,0)
 . S DGCT=DGCT+1,DGCTX=DGCT S DIR("A",DGCT)="   "_$E(DG,1)_DGEG_$E(DG,2)_"  -"_DGDISP_$$YN($S(DGCONF(DGCONF):"Y",'$D(^DPT(DFN,.3215,0)):"",1:"N"),1)
"RTN","DGRP6CL",102,0)
 . I $G(DGCONF(DGCONF))!$D(DGPOSS(DGCONF)) I '$G(DGRPV),$G(DGCONF(DGCONF,"VEDIT"))'=2,'$G(DGCONF(DGCONF,"NOEDIT")) S:DGCONF'="UNK" DIR(0)=DIR(0)_DGEG_":"_DGCONF_";"
"RTN","DGRP6CL",103,0)
 . S (DGZ,DGCONFS)=DGCONF F  S DGCONFS=$O(DGCONFS(DGCONFS)) Q:DGCONFS=""!(DGCONFS'[DGZ)  D
"RTN","DGRP6CL",104,0)
 .. N DGUN,DGIEN,STA
"RTN","DGRP6CL",105,0)
 .. S DGIEN=DGCONFS(DGCONFS),DGCONF=DGZ_"-"_DGIEN,DGCONF1=DGZ,DGM=DGM+1
"RTN","DGRP6CL",106,0)
 .. I $G(DGCONF(DGCONF,1)),DGCTX S $E(DIR("A",DGCTX),1,3)="***"
"RTN","DGRP6CL",107,0)
 .. S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
"RTN","DGRP6CL",108,0)
 .. S DGUN=$S($G(DGCONF(DGCONF,"NOEDIT")):1,1:0)
"RTN","DGRP6CL",109,0)
 .. I 'DGUN S DGCONF(DGCONF1,"OK")=$G(DGCONF(DGCONF1,"OK"))+1,DGCONF(DGCONF1,"OK",DGIEN)=DGM_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U),"5DZ")_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U,2),"5DZ")
"RTN","DGRP6CL",110,0)
 .. I DGM>1 S DGCT=DGCT+1
"RTN","DGRP6CL",111,0)
 .. S DIR("A",DGCT)=$S(DGM>1:$J("",27-$L(DGM)),1:DIR("A",DGCT)_" ")_"("_DGM_")  "_$E($$DAT(DGCONF(DGCONF),1,13)_$J("",12),1,12)_$E($$DAT(DGCONF(DGCONF),2,11)_$J("",10),1,10)_"   "
"RTN","DGRP6CL",112,0)
 .. S STA=$P(DGCONF(DGCONF),U,3)
"RTN","DGRP6CL",113,0)
 .. S:STA STA=$P($G(^DIC(4,+STA,99)),U)
"RTN","DGRP6CL",114,0)
 .. S DIR("A",DGCT)=DIR("A",DGCT)_$S($P(DGCONF(DGCONF),U,3)="CEV":"",1:"Station #")_$E(STA_$J("",$S('DGUN:6,1:3)),1,$S('DGUN:6,1:3))
"RTN","DGRP6CL",115,0)
 .. I DGUN S DIR("A",DGCT)=DIR("A",DGCT)_" (No Edit)"
"RTN","DGRP6CL",116,0)
 D LOOPCNF^DGRP6CL1(.DGCONF,.DGPOSS,.DIR)
"RTN","DGRP6CL",117,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=" "
"RTN","DGRP6CL",118,0)
 I $G(DGMSG) S DGCT=DGCT+1,DIR("A",DGCT)="*** ==>OEF/OIF Dates are inconsistent with veteran's military service episodes"
"RTN","DGRP6CL",119,0)
 S DIR("A")="SELECT THE NUMBER OF A CONFLICT LOCATION OR (Q)UIT: "
"RTN","DGRP6CL",120,0)
 S DIR(0)=DIR(0)_"Q:QUIT"
"RTN","DGRP6CL",121,0)
 S DIR("?")="^D HELP^DGRP6CL1($P(DIR(0),U,2))"
"RTN","DGRP6CL",122,0)
 S DIR("B")="QUIT"
"RTN","DGRP6CL",123,0)
 D ^DIR K DIR
"RTN","DGRP6CL",124,0)
 I $D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT
"RTN","DGRP6CL",125,0)
 S DGY=Y,DGY1=$S(Y=2:1,Y=1:2,1:Y)
"RTN","DGRP6CL",126,0)
 I DGY<4 S DGCONF=""
"RTN","DGRP6CL",127,0)
 I DGY'<4 D
"RTN","DGRP6CL",128,0)
 . S DGCONF=$P("OEF^OIF^UNK^VIET^LEB^GREN^PAN^GULF^SOM^YUG",U,DGY)
"RTN","DGRP6CL",129,0)
 . I $G(DGCONF(DGCONF,1)) W !!,"WARNING - THIS CONFLICT IS INCONSISTENT WITH MILITARY SERVICE DATA",!
"RTN","DGRP6CL",130,0)
 . S DIE=2,DA=DFN,DR=$P($T(@DGCONF),";;",2) D:DR'="" ^DIE K DIE,DA,DR
"RTN","DGRP6CL",131,0)
 I DGY=1!(DGY=2) D
"RTN","DGRP6CL",132,0)
 . S DGCONF=$P("OEF^OIF",U,DGY)
"RTN","DGRP6CL",133,0)
 . I '$G(DGCONF(DGCONF,"OK")),$G(DGCONF(DGCONF,"VEDIT"))'=2 D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q  ; Add new only valid action
"RTN","DGRP6CL",134,0)
 . I $G(DGCONF(DGCONF,"VEDIT"))=1 S DIR("A")="DO YOU WANT TO (A)DD OR (E)DIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="SA^A:ADD;E:EDIT",DIR("B")="ADD" D ^DIR K DIR
"RTN","DGRP6CL",135,0)
 . I $G(DGCONF(DGCONF,"VEDIT"))=2,$G(DGCONF(DGCONF,"OK")) S DIR("A")="DO YOU WANT TO EDIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="YA",DIR("B")="YES" D ^DIR K DIR S Y=$S(Y=1:"E",1:Y)
"RTN","DGRP6CL",136,0)
 . Q:$D(DTOUT)!$D(DUOUT)
"RTN","DGRP6CL",137,0)
 . I Y="A" D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q
"RTN","DGRP6CL",138,0)
 . I Y="E" D
"RTN","DGRP6CL",139,0)
 .. N DGXREF,IEN,DIR,X,Y
"RTN","DGRP6CL",140,0)
 .. I DGCONF(DGCONF,"OK")=1 S IEN=+$O(DGCONF(DGCONF,"OK",0)) I IEN D EDCFL^DGRP6CL1(DFN,IEN,$G(DGCONF(DGCONF,"VEDIT"))) Q
"RTN","DGRP6CL",141,0)
 .. S DIR(0)="SA^",DIR("A")="SELECT THE # OF THE "_DGCONF_" CONFLICT PERIOD TO EDIT: ",DIR("A",1)=" "
"RTN","DGRP6CL",142,0)
 .. S Z=0 F  S Z=$O(DGCONF(DGCONF,"OK",Z)) Q:'Z  S Z0=DGCONF(DGCONF,"OK",Z),DIR(0)=DIR(0)_+Z0_":"_$P(Z0,U,2)_$S($P(Z0,U,3)'="":"-"_$P(Z0,U,3),1:"")_";",DGXREF(+Z0)=Z
"RTN","DGRP6CL",143,0)
 .. S DIR(0)=DIR(0)_"Q:QUIT"
"RTN","DGRP6CL",144,0)
 .. D ^DIR K DIR
"RTN","DGRP6CL",145,0)
 .. I Y D EDCFL^DGRP6CL1(DFN,+$G(DGXREF(+Y)),$G(DGCONF(DGCONF,"VEDIT")))
"RTN","DGRP6CL",146,0)
 G EN1
"RTN","DGRP6CL",147,0)
 ;
"RTN","DGRP6CL",148,0)
QUIT Q
"RTN","DGRP6CL",149,0)
 ;
"RTN","DGRP6CL",150,0)
EN2 ; Consistency checker re-edit entrypoint for OEF/OIF data
"RTN","DGRP6CL",151,0)
 N DGOEIF,DGZ,DGQUIT,Z,Z0,Y
"RTN","DGRP6CL",152,0)
 D GET^DGENOEIF(DFN,.DGOEIF,2,"",1)
"RTN","DGRP6CL",153,0)
 I $G(DGOEIF("COUNT"))&($O(DGOEIF("OIF",0))!$O(DGOEIF("OEF",0))) D
"RTN","DGRP6CL",154,0)
 . F Z="OEF","OIF" S Z0=0 F  S Z0=$O(DGOEIF(Z,Z0)) Q:'Z0  I $G(DGOEIF(Z,Z0,"IEN")) S DGZ(DGOEIF(Z,Z0,"IEN"))=""
"RTN","DGRP6CL",155,0)
 . S (DGQUIT,DGZ)=0 F  S DGZ=$O(DGZ(DGZ)) Q:'DGZ  D  Q:DGQUIT
"RTN","DGRP6CL",156,0)
 .. N DGX,DA,DIE,DR,X
"RTN","DGRP6CL",157,0)
 .. S DGX=$G(^DPT(DFN,.3215,DGZ,0))
"RTN","DGRP6CL",158,0)
 .. W !!,"OEF/OIF CONFLICT: ",$$EXTERNAL^DILFD(2.3215,.01,"",$P(DGX,U)),"  FROM: "_$$EXTERNAL^DILFD(2.3215,.02,"",$P(DGX,U,2)),"  TO: "_$$EXTERNAL^DILFD(2.3215,.03,"",$P(DGX,U,3))
"RTN","DGRP6CL",159,0)
 .. S DA=DGZ,DA(1)=DFN,DIE="^DPT("_DA(1)_",.3215,",DR=".01;.02R;.03R" D ^DIE I $D(Y) S DGQUIT=1
"RTN","DGRP6CL",160,0)
 Q
"RTN","DGRP6CL",161,0)
 ;
"RTN","DGRP6CL",162,0)
SVCCOMP(X) ; Returns display text for service component
"RTN","DGRP6CL",163,0)
 Q $S(X="R":"REGULAR",X="V":"RESERVE",X="G":"GUARD",1:"")
"RTN","DGRP6CL",164,0)
 ;
"RTN","DGRP6CL",165,0)
VIET ;;.32101//NO;S:X'="Y" Y="@64";.32104;.32105;@64;
"RTN","DGRP6CL",166,0)
LEB ;;.3221//NO;S:X'="Y" Y="@67";.3222;Q;.3223;@67;
"RTN","DGRP6CL",167,0)
GREN ;;.3224//NO;S:X'="Y" Y="@68";.3225;Q;.3226;@68;
"RTN","DGRP6CL",168,0)
PAN ;;.3227//NO;S:X'="Y" Y="@69";.3228;Q;.3229;@69;
"RTN","DGRP6CL",169,0)
GULF ;;.32201//NO;S:X'="Y" Y="@610";.322011;Q;.322012;@610;
"RTN","DGRP6CL",170,0)
SOM ;;.322016//NO;S:X'="Y" Y="@611";.322017;Q;.322018;@611;
"RTN","DGRP6CL",171,0)
YUG ;;.322019//NO;S:X'="Y" Y="@615";.32202;Q;.322021;@615;
"RTN","DGRP6CL",172,0)
OEF ;;
"RTN","DGRP6CL",173,0)
OIF ;;
"RTN","DGRP6CL",174,0)
UNK ;;
"RTN","DGRP6CL",175,0)
 ;;
"RTN","DGRPC")
0^25^B28027409
"RTN","DGRPC",1,0)
DGRPC ;ALB/MRL/PJR/PHH/EG/BAJ,TDM,LBD - CHECK CONSISTENCY OF PATIENT DATA ; 6/29/11 3:50pm
"RTN","DGRPC",2,0)
 ;;5.3;Registration;**108,121,314,301,470,489,505,451,568,585,641,653,688,754,797**;Aug 13, 1993;Build 24
"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,DGPMSE
"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 MSEs from MSE sub-file #2.3216 (DG*5.3*797)
"RTN","DGRPC",22,0)
 I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN)
"RTN","DGRPC",23,0)
 D GETMSE^DGMSEUTL(DFN,.DGPMSE)
"RTN","DGRPC",24,0)
 ;get old inconsistencies
"RTN","DGRPC",25,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",26,0)
 ;find consistencies to check/not check
"RTN","DGRPC",27,0)
 ; DG*5.3*653 modified to exclude checks numbered>99  BAJ  10/25/2005
"RTN","DGRPC",28,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",29,0)
 S OVER99=",301,303,304,306,307,308,402,403,406,407,501,502,503,504,505,506,507,516,517,"
"RTN","DGRPC",30,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",31,0)
 S DGLST=+$P(DGCHK,",",2) G @DGLST
"RTN","DGRPC",32,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",33,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",34,0)
 I I1 S X=1 D COMB
"RTN","DGRPC",35,0)
 D NEXT I +DGLST'=2 G @DGLST
"RTN","DGRPC",36,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",37,0)
 I I1 S X=2 D COMB
"RTN","DGRPC",38,0)
 D NEXT I +DGLST>7!('DGLST) G @DGLST
"RTN","DGRPC",39,0)
3 ;
"RTN","DGRPC",40,0)
4 ;
"RTN","DGRPC",41,0)
5 ;
"RTN","DGRPC",42,0)
6 ;
"RTN","DGRPC",43,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",44,0)
 S DGLST=7 G:DGCHK'[",7," FIND^DGRPC2 D NEXT I +DGLST'=8 G @DGLST
"RTN","DGRPC",45,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",46,0)
 I '$D(^HL(779.004,$P(DGD,"^",10))) S I1=1,X=8 D COMB,NEXT G @DGLST
"RTN","DGRPC",47,0)
 N STR8 S STR8="1,4,5,6,7" I $$FORIEN^DGADDUTL($P(DGD,"^",10)) S STR8="1,4"
"RTN","DGRPC",48,0)
 F T=1:1:$L(STR8,",") S I=$P(STR8,",",T) Q:I1  I $P(DGD,"^",I)="" S I1=1
"RTN","DGRPC",49,0)
 I I1 S X=8 D COMB
"RTN","DGRPC",50,0)
 D NEXT I +DGLST'=9 G @DGLST
"RTN","DGRPC",51,0)
9 I DGP("VET")="" S X=9,DGNCK=1 D COMB
"RTN","DGRPC",52,0)
 D NEXT I +DGLST'=10 G @DGLST
"RTN","DGRPC",53,0)
10 I $P(DGP(.3),"^",1)="" S X=10,DGNCK=1 D COMB
"RTN","DGRPC",54,0)
 D NEXT I +DGLST'=11 G @DGLST
"RTN","DGRPC",55,0)
11 I 'DGVT,DGSC S X=11 D COMB
"RTN","DGRPC",56,0)
 D NEXT I +DGLST'=12 G @DGLST
"RTN","DGRPC",57,0)
12 I DGSC,DGVT,$P(DGP(.3),"^",2)="" S X=12 D COMB
"RTN","DGRPC",58,0)
 D NEXT I +DGLST'=13 G @DGLST
"RTN","DGRPC",59,0)
13 I '$D(^DIC(21,+$P(DGP(.32),"^",3),0)) S X=13,DGNCK=1 D COMB
"RTN","DGRPC",60,0)
 D NEXT I +DGLST'=14 G @DGLST
"RTN","DGRPC",61,0)
14 I $P(DGCD,"^",1)="" S X=14,DGNCK=1 D COMB
"RTN","DGRPC",62,0)
 ;
"RTN","DGRPC",63,0)
 ;Check Patient Eligibilities multiple if Primary Elig Code defined
"RTN","DGRPC",64,0)
 I DGP(.36),'$D(^DPT(DFN,"E",+DGP(.36),0)) D PRI^VADPT60 ;5.3*301
"RTN","DGRPC",65,0)
 ;
"RTN","DGRPC",66,0)
 D NEXT I +DGLST'=15 G FIND^DGRPC2:+DGLST=35,@DGLST
"RTN","DGRPC",67,0)
15 I $P($G(^DPT(DFN,.15)),"^",2)]"",$P(DGP(.3),"^",7)="" S X=15 D COMB
"RTN","DGRPC",68,0)
 D NEXT I +DGLST'=16 G FIND^DGRPC2:+DGLST=35,@DGLST
"RTN","DGRPC",69,0)
16 D H^DGUTL I +DGP(.35)>DGTIME S X=16 D COMB
"RTN","DGRPC",70,0)
 D NEXT I +DGLST'=17 G FIND^DGRPC2:+DGLST=35,@DGLST
"RTN","DGRPC",71,0)
17 K DGDATE,DGTIME
"RTN","DGRPC",72,0)
 N SDARRAY,SDCLIEN,SDDATE
"RTN","DGRPC",73,0)
 S I1=0,DGD=DT
"RTN","DGRPC",74,0)
 S SDARRAY("FLDS")=3
"RTN","DGRPC",75,0)
 S SDARRAY(4)=DFN
"RTN","DGRPC",76,0)
 I +DGP(.35),$$SDAPI^SDAMA301(.SDARRAY) D
"RTN","DGRPC",77,0)
 .;if there is data hanging from the 101 subscript,
"RTN","DGRPC",78,0)
 .;then this is a valid appointment
"RTN","DGRPC",79,0)
 .;otherwise it is an error eg 01/21/2005
"RTN","DGRPC",80,0)
 .I $D(^TMP($J,"SDAMA301",101))=1 Q
"RTN","DGRPC",81,0)
 .S SDCLIEN=0
"RTN","DGRPC",82,0)
 .F  S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(I1)  D
"RTN","DGRPC",83,0)
 ..S SDDATE=0
"RTN","DGRPC",84,0)
 ..F  S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(I1)  D
"RTN","DGRPC",85,0)
 ...S X=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";")
"RTN","DGRPC",86,0)
 ...I X=""!(X="I") S I1=1
"RTN","DGRPC",87,0)
 K ^TMP($J,"SDAMA301")
"RTN","DGRPC",88,0)
 I I1 S X=17 D COMB
"RTN","DGRPC",89,0)
 ;
"RTN","DGRPC",90,0)
END ; end of routine...find next check to execute (or goto end)
"RTN","DGRPC",91,0)
 S:DGNCK DGLST=35 G:DGCHK'[",35,"&(DGNCK) FIND^DGRPC2 D NEXT G @DGLST
"RTN","DGRPC",92,0)
 ;
"RTN","DGRPC",93,0)
COMB ;record inconsistency
"RTN","DGRPC",94,0)
 S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
"RTN","DGRPC",95,0)
 Q
"RTN","DGRPC",96,0)
 ;
"RTN","DGRPC",97,0)
NEXT ; find the next consistency check to check (goto end if can't process further)
"RTN","DGRPC",98,0)
 S I=$F(DGCHK,(","_DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,DGLST<18 Q
"RTN","DGRPC",99,0)
 I +DGLST,DGNCK,+DGLST>17,+DGLST<36 S DGLST=35 Q:DGCHK'[",35,"  G NEXT
"RTN","DGRPC",100,0)
 S:'+DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC"_$S(+DGLST<43:1,+DGLST<79:2,1:3)
"RTN","DGRPC",101,0)
 Q
"RTN","DGRPC",102,0)
 ;
"RTN","DGRPC",103,0)
PAT ;check inconsistencies for a selected patient
"RTN","DGRPC",104,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",105,0)
 ;
"RTN","DGRPC",106,0)
START ;record start time for checker
"RTN","DGRPC",107,0)
 S DGSTART=$H Q
"RTN","DGRPC",108,0)
 ;
"RTN","DGRPC",109,0)
TIME ;record end time for checker
"RTN","DGRPC",110,0)
 Q:'$D(DGSTART)#2  S DGEND=$H,X=$P(DGSTART,",",2),X1=$P(DGEND,",",2)
"RTN","DGRPC",111,0)
 I +DGSTART=+DGEND S DGTIME=X1-X
"RTN","DGRPC",112,0)
 E  S DGTIME=(5184000-X)+X1
"RTN","DGRPC",113,0)
 I $S(DGCT:0,DGCON=1:1,1:0) G TIMEQ
"RTN","DGRPC",114,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",115,0)
TIMEQ K DGSTART,DGEND,DGTIME,X,X1,DGCON Q
"RTN","DGRPC",116,0)
 ;
"RTN","DGRPC",117,0)
ON ;check if checker is on
"RTN","DGRPC",118,0)
 S DGER=0 I $S('$D(^DG(43,1,0)):1,'$P(^(0),"^",37):1,1:0) S DGER=1
"RTN","DGRPC",119,0)
 S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER TURNED OFF!!",$C(7) Q
"RTN","DGRPC2")
0^26^B70981451
"RTN","DGRPC2",1,0)
DGRPC2 ;ALB/MRL/SCK/PJR/BAJ/LBD - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 10/14/10 9:56am
"RTN","DGRPC2",2,0)
 ;;5.3;Registration;**45,69,108,121,205,218,342,387,470,467,489,505,507,528,451,564,570,657,688,780,797**;Aug 13, 1993;Build 24
"RTN","DGRPC2",3,0)
 ;
"RTN","DGRPC2",4,0)
43 ;off
"RTN","DGRPC2",5,0)
44 ;off
"RTN","DGRPC2",6,0)
45 ;off
"RTN","DGRPC2",7,0)
46 ;off
"RTN","DGRPC2",8,0)
47 ;off
"RTN","DGRPC2",9,0)
 S DGLST=$S(DGCHK[",47,":47,DGCHK[",46,":46,DGCHK[",45,":45,DGCHK[",44,":44,1:DGLST)
"RTN","DGRPC2",10,0)
 D NEXT G @DGLST
"RTN","DGRPC2",11,0)
48 I DGVT S DGD=DGP(.362) I DGCHK[(",48,"),($P(DGD,"^",17)="Y"),($P(DGD,"^",6)="") S X=48 D COMB
"RTN","DGRPC2",12,0)
 D NEXT G @DGLST
"RTN","DGRPC2",13,0)
49 ;
"RTN","DGRPC2",14,0)
50 ; insurance checks
"RTN","DGRPC2",15,0)
 I DGCHK[",49,"!(DGCHK[",50,") D  S DGLST=$S(DGCHK["50":50,1:49)
"RTN","DGRPC2",16,0)
 . N COV,INS,X
"RTN","DGRPC2",17,0)
 . S X=0,COV=$S($P(DGP(.31),"^",11)="Y":1,1:0)
"RTN","DGRPC2",18,0)
 . S INS=$$INSUR^IBBAPI(DFN,DT,"R")
"RTN","DGRPC2",19,0)
 . I COV,'INS S X=49 ; yes, but none
"RTN","DGRPC2",20,0)
 . I 'COV,INS S X=50 ; not yes, but some
"RTN","DGRPC2",21,0)
 . I DGCHK[(","_X_",") D COMB
"RTN","DGRPC2",22,0)
 D NEXT G @DGLST
"RTN","DGRPC2",23,0)
51 D NEXT G @DGLST ; 51 disabled
"RTN","DGRPC2",24,0)
 S X=$S($D(^DIC(21,+$P(DGP(.32),"^",3),0)):$P(^(0),"^",3),1:"")
"RTN","DGRPC2",25,0)
 I X="Z"&($P(DGP(.32),"^",5)'=7)&($P(DGP(.32),"^",10)'=7)&($P(DGP(.32),"^",15)'=7)!($P(DGP(.32),"^",5)=7&(X'="Z")) S X=51 D COMB
"RTN","DGRPC2",26,0)
 ;
"RTN","DGRPC2",27,0)
52 I $P(DGP(.31),"^",11)']"" S X=52 D COMB ;automatically on
"RTN","DGRPC2",28,0)
 D NEXT G @DGLST
"RTN","DGRPC2",29,0)
53 I $P(DGP(.311),"^",15)']"" S X=53 D COMB ;automatically on
"RTN","DGRPC2",30,0)
 D NEXT G @DGLST
"RTN","DGRPC2",31,0)
54 ;
"RTN","DGRPC2",32,0)
55 ;BELOW IS USED BY BOTH 54 & 55
"RTN","DGRPC2",33,0)
 N DGMT
"RTN","DGRPC2",34,0)
 S DGLST=$S(DGCHK["55":55,1:54)
"RTN","DGRPC2",35,0)
 I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) D NEXT G @DGLST ; patient died before current year
"RTN","DGRPC2",36,0)
 N DGE S DGE=+$O(^DIC(8.1,"B","SERVICE CONNECTED 50% to 100%",0))
"RTN","DGRPC2",37,0)
 I $P($G(^DPT(DFN,.3)),U,2)'<50!($P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),U,9)=DGE) D NEXT G @DGLST ;50-100% SC
"RTN","DGRPC2",38,0)
 S DGPTYP=$G(^DG(391,+DGP("TYPE"),"S")),DGISYR=$E(DT,1,3)-1_"0000" I '$P(DGPTYP,"^",8)&('$P(DGPTYP,"^",9)) K DGPTYP,DGISYR D NEXT G @DGLST ; screens 8 and 9 off
"RTN","DGRPC2",39,0)
 ; If current/not outdated means test exits, pass to income retrieval
"RTN","DGRPC2",40,0)
 ; Patch 780
"RTN","DGRPC2",41,0)
 S DGMT=$$LST^DGMTU(DFN)
"RTN","DGRPC2",42,0)
 I DGMT,$$OLD^DGMTU4($P(DGMT,U,2)) S DGMT=""
"RTN","DGRPC2",43,0)
 D ALL^DGMTU21(DFN,"VSD",$S(DGMT:$P(DGMT,U,2),1:DT),"IP",$S(DGMT:DGMT,1:""))
"RTN","DGRPC2",44,0)
 I '$P(DGPTYP,"^",8)!(DGCHK'["54") G JUST55 ; screen 8 off OR JUST 55 IN CHK
"RTN","DGRPC2",45,0)
 S DGFL=0 I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") S DGFL=1
"RTN","DGRPC2",46,0)
 I 'DGFL F I=0:0 S I=$O(DGREL("D",I)) Q:'I  I $$SSN^DGMTU1(+DGREL("D",I))']"" S DGFL=1 Q
"RTN","DGRPC2",47,0)
 I DGFL S X=54 D COMB
"RTN","DGRPC2",48,0)
JUST55 I DGCHK'["55" D NEXT G @DGLST
"RTN","DGRPC2",49,0)
 S DGLST=55
"RTN","DGRPC2",50,0)
 I '$P(DGPTYP,"^",9) D NEXT G @DGLST ; screen 9 off
"RTN","DGRPC2",51,0)
 D TOT^DGRP9(.DGINC) S DGFL=0
"RTN","DGRPC2",52,0)
 F DGD="V","S","D" I $D(DGTOT(DGD)) F I=8:1:17 I $P(DGTOT(DGD),"^",I)]"" S DGFL=1 Q
"RTN","DGRPC2",53,0)
 I 'DGFL N DGAPD,DG55 D  I 'DGAPD&('DG55)  S X=55 D COMB
"RTN","DGRPC2",54,0)
 . S DGAPD=+$$LST^DGMTU(DFN),DGAPD=+$P($G(^DGMT(408.31,+DGAPD,0)),U,11)
"RTN","DGRPC2",55,0)
 . S DG55=$$CHECK55(DFN) ; **507, Additional Income Checks
"RTN","DGRPC2",56,0)
 D NEXT G @DGLST
"RTN","DGRPC2",57,0)
56 I DGVT S DGD=DGP(.3) I DGCHK[(",56,"),($P(DGD,"^",11)="Y"),($P(DGP(.362),"^",20)="") S X=56 D COMB
"RTN","DGRPC2",58,0)
 D NEXT G END^DGRPC3:$S('+DGLST:1,+DGLST=99:1,1:0) G @DGLST
"RTN","DGRPC2",59,0)
57 I $P(DGP(.38),U,1) D
"RTN","DGRPC2",60,0)
 .N X1,X2
"RTN","DGRPC2",61,0)
 .S X1=$P(DGP(.38),U,2)
"RTN","DGRPC2",62,0)
 .S X=$P($G(^DG(43,1,0)),U,46) S X2=$S(X:X,1:365) D C^%DTC
"RTN","DGRPC2",63,0)
 .I X<DT S X=57 D COMB
"RTN","DGRPC2",64,0)
 D NEXT G @DGLST
"RTN","DGRPC2",65,0)
58 ;58 - EC Claim - No Gulf/Som Svc
"RTN","DGRPC2",66,0)
 ;off
"RTN","DGRPC2",67,0)
 ;DG*5.3*688 changed the wording of Environmental Contaminants
"RTN","DGRPC2",68,0)
 ;so if this cc is ever activated the text in ^DGIN(38.6,58 
"RTN","DGRPC2",69,0)
 ;needs to be changed to Southwest Asia Conditions.
"RTN","DGRPC2",70,0)
 D NEXT G @DGLST
"RTN","DGRPC2",71,0)
59 ;59 - incomplete Catastrophic Disability info
"RTN","DGRPC2",72,0)
 I $$HASCAT^DGENCDA(DFN) D
"RTN","DGRPC2",73,0)
 .I '$P(DGP(.39),"^",2) S X=59 D COMB
"RTN","DGRPC2",74,0)
 D NEXT G @DGLST
"RTN","DGRPC2",75,0)
60 ;60 - Location of agent orange exposure unanswered
"RTN","DGRPC2",76,0)
 I DGVT,$P(DGP(.321),"^",2)="Y",$P(DGP(.321),"^",13)="" S X=60 D COMB
"RTN","DGRPC2",77,0)
 D NEXT G @DGLST
"RTN","DGRPC2",78,0)
61 ;61 - Incomplete Phone Number
"RTN","DGRPC2",79,0)
 ; DG*5.3*657 BAJ Phone number check modified
"RTN","DGRPC2",80,0)
 ; Home phone check is disabled
"RTN","DGRPC2",81,0)
 ; Work phone is required only if pt is employed
"RTN","DGRPC2",82,0)
 N EMPST
"RTN","DGRPC2",83,0)
 S EMPST=","_$P($G(^DPT(DFN,.311)),U,15)_","
"RTN","DGRPC2",84,0)
 I ",1,2,4,"[EMPST,($P(DGP(.13),"^",2)="") S X=61 D COMB
"RTN","DGRPC2",85,0)
 D NEXT G @DGLST
"RTN","DGRPC2",86,0)
62 ;62 - Missing Emergency Contact Name
"RTN","DGRPC2",87,0)
 I $P(DGP(.33),"^")="" S X=62 D COMB
"RTN","DGRPC2",88,0)
 D NEXT G @DGLST
"RTN","DGRPC2",89,0)
63 ;Confidential Address check
"RTN","DGRPC2",90,0)
 N STR63,J,DGI,DGERR
"RTN","DGRPC2",91,0)
 S DGERR=0
"RTN","DGRPC2",92,0)
 I $P(DGP(.141),U,9)="Y",$P($$CAACT^DGRPCADD(DFN),U) D
"RTN","DGRPC2",93,0)
 . ; country is either NULL or non-numeric
"RTN","DGRPC2",94,0)
 . I '$P(DGP(.141),U,16) S DGERR=1 Q
"RTN","DGRPC2",95,0)
 . ; country is not in Country file
"RTN","DGRPC2",96,0)
 . I '$D(^HL(779.004,$P(DGP(.141),"^",16))) S DGERR=1 Q
"RTN","DGRPC2",97,0)
 . S STR63="1,4,5,6" I $$FORIEN^DGADDUTL($P(DGP(.141),"^",16)) S STR63="1,4"
"RTN","DGRPC2",98,0)
 . F J=1:1:$L(STR63,",") S DGI=$P(STR63,",",J) Q:DGERR  I $P(DGP(.141),U,DGI)="" S DGERR=1
"RTN","DGRPC2",99,0)
 I DGERR S X=63 D COMB
"RTN","DGRPC2",100,0)
 D NEXT G @DGLST
"RTN","DGRPC2",101,0)
64 ;64 - Place of Birth City/State Missing ;**505
"RTN","DGRPC2",102,0)
 I $P(DGP(0),"^",11)=""!($P(DGP(0),"^",12)="") S X=64 D COMB
"RTN","DGRPC2",103,0)
 D NEXT G @DGLST
"RTN","DGRPC2",104,0)
65 ;65 - Mother's Maiden Name Missing ;**505
"RTN","DGRPC2",105,0)
 I $P(DGP(.24),"^",3)="" S X=65 D COMB
"RTN","DGRPC2",106,0)
 D NEXT G @DGLST
"RTN","DGRPC2",107,0)
66 ;66 - Pseudo SSN in use ;**505
"RTN","DGRPC2",108,0)
 ; DG*5.3*657 BAJ 11/20/2005 Removed from CC.  Pseudo notice appears in Patient List
"RTN","DGRPC2",109,0)
 ;I $P(DGP(0),"^",9)["P" S X=66 D COMB
"RTN","DGRPC2",110,0)
 ; off
"RTN","DGRPC2",111,0)
 D NEXT G @DGLST
"RTN","DGRPC2",112,0)
67 ;67 - Serv Sep Date [Last] missing or imprecise, patch 528
"RTN","DGRPC2",113,0)
 N DGG
"RTN","DGRPC2",114,0)
 S DGG=$$CVELIG^DGCV(DFN)
"RTN","DGRPC2",115,0)
 I $G(DGG)["A"!($G(DGG)["F") S X=67 D COMB
"RTN","DGRPC2",116,0)
 D NEXT G @DGLST
"RTN","DGRPC2",117,0)
68 ;used for 68-71, for Combat Vet, DG*5.3*528
"RTN","DGRPC2",118,0)
69 ;
"RTN","DGRPC2",119,0)
70 ;
"RTN","DGRPC2",120,0)
71 ;
"RTN","DGRPC2",121,0)
 ;68 - Combat To Date missing or imprecise, patch 528
"RTN","DGRPC2",122,0)
 ;69 - Yugoslavia To Date missing or imprecise, patch 528
"RTN","DGRPC2",123,0)
 ;70 - Somalia To Date missing or imprecise, patch 528
"RTN","DGRPC2",124,0)
 ;71 - Persian Gulf To Date missing or imprecise, patch 528
"RTN","DGRPC2",125,0)
 N DGG
"RTN","DGRPC2",126,0)
 S DGG=$$CVELIG^DGCV(DFN)
"RTN","DGRPC2",127,0)
 I DGG["B"!(DGG["G") S X=68 D COMB
"RTN","DGRPC2",128,0)
 I DGG["C"!(DGG["H") S X=69 D COMB
"RTN","DGRPC2",129,0)
 I DGG["D"!(DGG["I") S X=70 D COMB
"RTN","DGRPC2",130,0)
 I DGG["E"!(DGG["J") S X=71 D COMB
"RTN","DGRPC2",131,0)
 S DGLST=71
"RTN","DGRPC2",132,0)
 D NEXT G @DGLST
"RTN","DGRPC2",133,0)
72 ;; MSE - Required Fields
"RTN","DGRPC2",134,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSERR S X=72 D COMB
"RTN","DGRPC2",135,0)
 D NEXT G @DGLST
"RTN","DGRPC2",136,0)
73 ;; An MSE FROM date precedes an MSE TO date
"RTN","DGRPC2",137,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR D NEXT G @DGLST
"RTN","DGRPC2",138,0)
 N I1
"RTN","DGRPC2",139,0)
 ;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
"RTN","DGRPC2",140,0)
 I $D(DGPMSE) D  D NEXT G @DGLST
"RTN","DGRPC2",141,0)
 .N OUT S I1=0 F  S I1=$O(DGPMSE(I1)) Q:'I1!($G(OUT))  D
"RTN","DGRPC2",142,0)
 ..I $P(DGPMSE(I1),U,7) Q  ;Don't check MSE verified by HEC
"RTN","DGRPC2",143,0)
 ..I '$$B4^DGRPDT($P(DGPMSE(I1),U),$P(DGPMSE(I1),U,2),1) S X=73 D COMB S (MSERR,MSDATERR,OUT)=1 Q
"RTN","DGRPC2",144,0)
 ;Otherwise, use MSE data in DGP(.32)
"RTN","DGRPC2",145,0)
 F I1=6,11,16 I '$$B4^DGRPDT($P(DGP(.32),"^",I1),$P(DGP(.32),"^",I1+1),1) S X=73 D COMB S (MSERR,MSDATERR)=1 Q
"RTN","DGRPC2",146,0)
 D NEXT G @DGLST
"RTN","DGRPC2",147,0)
74 ;; Conflict Date Missing or Incomplete
"RTN","DGRPC2",148,0)
 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK I CONERR S X=74 D COMB
"RTN","DGRPC2",149,0)
 D NEXT G @DGLST
"RTN","DGRPC2",150,0)
75 ;; Conflict TO date precedes FROM date
"RTN","DGRPC2",151,0)
76 ;; Conflict Date out of range for conflict
"RTN","DGRPC2",152,0)
 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
"RTN","DGRPC2",153,0)
 S LOC="",(I5,I6)=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC=""  I CONARR(LOC)=1 D
"RTN","DGRPC2",154,0)
 .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
"RTN","DGRPC2",155,0)
 .S DATA=CONSPEC(LOC)
"RTN","DGRPC2",156,0)
 .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
"RTN","DGRPC2",157,0)
 .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
"RTN","DGRPC2",158,0)
 .I '$$B4^DGRPDT(FROMDAT,TODAT,1) S X=75 D COMB:'I5&(DGCHK[(",75,")) S CONARR(LOC)=2,I5=1 Q
"RTN","DGRPC2",159,0)
 .I DGCHK'[(",76,") Q
"RTN","DGRPC2",160,0)
 .S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
"RTN","DGRPC2",161,0)
 .I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),FROMDAT,TODAT) S X=76 D COMB:'I6 S CONARR(LOC)=2,I6=1
"RTN","DGRPC2",162,0)
 .Q
"RTN","DGRPC2",163,0)
 S DGLST=76 D NEXT G @DGLST
"RTN","DGRPC2",164,0)
77 ;; Date out of range for POW Location
"RTN","DGRPC2",165,0)
 ;; Check turned off by EVC project (DG*5.3*688)
"RTN","DGRPC2",166,0)
 D NEXT G @DGLST
"RTN","DGRPC2",167,0)
78 ;; Date out of range for Combat Location
"RTN","DGRPC2",168,0)
 S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
"RTN","DGRPC2",169,0)
 ;; Don't check if Combat Data Incomplete or if Combat TO precedes FROM
"RTN","DGRPC2",170,0)
 I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
"RTN","DGRPC2",171,0)
 I $P(DGP(.52),"^",11)'="Y" D NEXT G @DGLST ;; Don't check if no COMBAT
"RTN","DGRPC2",172,0)
 S LOC=$$COMPOW^DGRPMS($P(DGP(.52),"^",12)) I LOC="" D NEXT G @DGLST
"RTN","DGRPC2",173,0)
 I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=78 D COMB
"RTN","DGRPC2",174,0)
 D NEXT G @DGLST
"RTN","DGRPC2",175,0)
COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
"RTN","DGRPC2",176,0)
 ;
"RTN","DGRPC2",177,0)
NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,+DGLST<79 Q
"RTN","DGRPC2",178,0)
 S:'DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC3"
"RTN","DGRPC2",179,0)
 Q
"RTN","DGRPC2",180,0)
FIND F I=DGLST:1:99 I DGCHK[(","_I_",") Q
"RTN","DGRPC2",181,0)
 I DGNCK,(I>17),(I<36) S DGLST=36 G FIND
"RTN","DGRPC2",182,0)
 I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>78:"^DGRPC3",DGLST>42:"",DGLST>17:"^DGRPC1",1:"^DGRPC"))
"RTN","DGRPC2",183,0)
 G END^DGRPC3
"RTN","DGRPC2",184,0)
 ;
"RTN","DGRPC2",185,0)
CHECK55(DFN) ;Business rules for additional 55-INCOME DATA MISSING checks
"RTN","DGRPC2",186,0)
 ;  Modeled from DGMTR checks.
"RTN","DGRPC2",187,0)
 ;  Input  DFN - IEN from PATIENT File #2
"RTN","DGRPC2",188,0)
 ;
"RTN","DGRPC2",189,0)
 ;  Output 1 - If Income check passes additional business rules
"RTN","DGRPC2",190,0)
 ;         0 - If Income check fails additional business rules
"RTN","DGRPC2",191,0)
 ;
"RTN","DGRPC2",192,0)
 N VAMB,VASV,VA,VADMVT,VAEL,VAINDT,DGRTN,DGMED,DG,DG1,DGWARD,DGSRVC
"RTN","DGRPC2",193,0)
 ;
"RTN","DGRPC2",194,0)
 S DGRTN=0
"RTN","DGRPC2",195,0)
 D MB^VADPT I +VAMB(7) S DGRTN=1 G Q55  ; Check if receiving VA Disability
"RTN","DGRPC2",196,0)
 D SVC^VADPT I +VASV(4) S DGRTN=1 G Q55  ; check if POW status indicated
"RTN","DGRPC2",197,0)
 I +VASV(9),(+VASV(9,1)=3) S DGRTN=1 G Q55  ; Check if Purple Heart Status is Confirmed
"RTN","DGRPC2",198,0)
 D GETS^DIQ(2,DFN_",",".381:.383","I","DGMED")
"RTN","DGRPC2",199,0)
 I $G(DGMED(2,DFN_",",.381,"I")) S DGRTN=1 G Q55  ; Check if eligible for Medicaid
"RTN","DGRPC2",200,0)
 D ADM^VADPT2 ; Check for current admission to DOM ward 
"RTN","DGRPC2",201,0)
 I +$G(VADMVT) D  G:DGRTN Q55
"RTN","DGRPC2",202,0)
 . Q:'$$GET1^DIQ(43,1,16,"I")  ; Has Dom wards?
"RTN","DGRPC2",203,0)
 . S DGWARD=$$GET1^DIQ(405,VADMVT,.06,"I") ; Get ward location
"RTN","DGRPC2",204,0)
 . S DGSRVC=$$GET1^DIQ(42,DGWARD,.03,"I") ; Get ward service
"RTN","DGRPC2",205,0)
 . S:DGSRVC="D" DGRTN=1 ; If ward service is 'D', then return 1
"RTN","DGRPC2",206,0)
 ;
"RTN","DGRPC2",207,0)
 ; Additional checks for 0% SC
"RTN","DGRPC2",208,0)
 D ELIG^VADPT
"RTN","DGRPC2",209,0)
 I +VAEL(3),'$P(VAEL(3),U,2) D  ; Check if service connected with % of zero
"RTN","DGRPC2",210,0)
 . I +VAMB(4) S DGRTN=1 Q  ; Check if receiving a VA pension
"RTN","DGRPC2",211,0)
 . S DG=0 ; Check for secondary eligibilities
"RTN","DGRPC2",212,0)
 . F  S DG=$O(VAEL(1,DG)) Q:'DG  D  Q:DGRTN
"RTN","DGRPC2",213,0)
 . . F DG1=2,4,15,16,17,18 I DG=DG1 S DGRTN=1 Q
"RTN","DGRPC2",214,0)
 ; DG*5.3*657 BAJ
"RTN","DGRPC2",215,0)
 ; Additional business rules
"RTN","DGRPC2",216,0)
 ; Do NOT file inconsistency for the following:
"RTN","DGRPC2",217,0)
 ; 1. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, A&A = "YES"
"RTN","DGRPC2",218,0)
 ; 2. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, VA Pension = "YES"
"RTN","DGRPC2",219,0)
 ; 3. Patient Type is "NSC Veteran" and A&A = "YES"
"RTN","DGRPC2",220,0)
 ; 4. Patient Type is "NSC Veteran" and VA Pension = "YES"
"RTN","DGRPC2",221,0)
 ; Arrays elements used:
"RTN","DGRPC2",222,0)
 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
"RTN","DGRPC2",223,0)
 ; .. VAEL(6) $P 2 = PATIENT TYPE, "B" INDEX VALUE
"RTN","DGRPC2",224,0)
 ; .. VAMB(1) $P 1 = RECEIVING A&A
"RTN","DGRPC2",225,0)
 ; .. VAMB(4) $P 1 = RECEIVING VA PENSION
"RTN","DGRPC2",226,0)
 I $P(VAEL(1),"^",2)="SC LESS THAN 50%",+VAEL(3) S PCNT=$P(VAEL(3),"^",2) I PCNT'<10,PCNT'>50 S DGRTN=$S(+VAMB(1):1,VAMB(4):1,1:DGRTN)
"RTN","DGRPC2",227,0)
 I $P($G(VAEL(6)),"^",2)="NSC VETERAN" S DGRTN=$S(+VAMB(1):1,VAMB(4):1,1:DGRTN)
"RTN","DGRPC2",228,0)
 ;
"RTN","DGRPC2",229,0)
Q55 D KVAR^VADPT
"RTN","DGRPC2",230,0)
 Q $G(DGRTN)
"RTN","DGRPC3")
0^24^B40710915
"RTN","DGRPC3",1,0)
DGRPC3 ;ALB/PJR,LBD,BAJ,TDM - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 10/20/10 3:40pm
"RTN","DGRPC3",2,0)
 ;;5.3;Registration;**451,632,673,657,688,754,797**;Aug 13, 1993;Build 24
"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)
 ;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
"RTN","DGRPC3",9,0)
 I $D(DGPMSE) D  D NEXT G @DGLST
"RTN","DGRPC3",10,0)
 .N MS,MSE,OUT S MS=0 F  S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT))  D
"RTN","DGRPC3",11,0)
 ..I $P(DGPMSE(MS),U,7) Q  ;Don't check MSE verified by HEC
"RTN","DGRPC3",12,0)
 ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE
"RTN","DGRPC3",13,0)
 ..I '$$OVRLPCHK^DGRPDT(DFN,$P(DGPMSE(MS),U),$P(DGPMSE(MS),U,2),1,"","",MSE) S X=79 D COMB S (MSERR,OUT)=1 Q
"RTN","DGRPC3",14,0)
 ;Otherwise, use MSE data in DGP(.32)
"RTN","DGRPC3",15,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",16,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",17,0)
 D NEXT G @DGLST
"RTN","DGRPC3",18,0)
80 ;; POW Dates not within MSE
"RTN","DGRPC3",19,0)
 ;; Check turned off by EVC project (DG*5.3*688)
"RTN","DGRPC3",20,0)
 D NEXT G @DGLST
"RTN","DGRPC3",21,0)
81 ;; Combat Dates not within MSE
"RTN","DGRPC3",22,0)
 I '$P(DGP(.52),"^",12) D NEXT G @DGLST ;; Don't check if no COMBAT Data
"RTN","DGRPC3",23,0)
 ;; Don't check if COMBAT Data Incomplete or if COMBAT TO precedes FROM
"RTN","DGRPC3",24,0)
 I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
"RTN","DGRPC3",25,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
"RTN","DGRPC3",26,0)
 ;; If COMBAT, but no MSE, then Range is NOT within MSE
"RTN","DGRPC3",27,0)
 I 'ANYMSE S X=81 D COMB D NEXT G @DGLST
"RTN","DGRPC3",28,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",29,0)
 D NEXT G @DGLST
"RTN","DGRPC3",30,0)
82 ;; Conflict Dates not within MSE
"RTN","DGRPC3",31,0)
 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
"RTN","DGRPC3",32,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
"RTN","DGRPC3",33,0)
 S LOC="",I2=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC=""  I CONARR(LOC)=1 D
"RTN","DGRPC3",34,0)
 .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
"RTN","DGRPC3",35,0)
 .S DATA=CONSPEC(LOC)
"RTN","DGRPC3",36,0)
 .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
"RTN","DGRPC3",37,0)
 .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
"RTN","DGRPC3",38,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",39,0)
 .Q
"RTN","DGRPC3",40,0)
 ; Check OIF/OEF conflict dates
"RTN","DGRPC3",41,0)
 N DGOEIF D GET^DGENOEIF(DFN,.DGOEIF,0,"",0)
"RTN","DGRPC3",42,0)
 I $G(DGOEIF("COUNT")),DGER'[",82," D
"RTN","DGRPC3",43,0)
 . N Z
"RTN","DGRPC3",44,0)
 . S Z=0 F  S Z=$O(DGOEIF("IEN",Z)) Q:'Z  D  Q:DGER[",82,"
"RTN","DGRPC3",45,0)
 .. S FROMDAT=$G(DGOEIF("FR",Z)),TODAT=$G(DGOEIF("TO",Z)),LOC=$G(DGOEIF("LOC",Z))
"RTN","DGRPC3",46,0)
 .. I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB S I2=1
"RTN","DGRPC3",47,0)
 D NEXT G @DGLST
"RTN","DGRPC3",48,0)
83 ;Merchant Seaman or Filipino Vet BOS requires service dates during WWII
"RTN","DGRPC3",49,0)
 N BOS,BOSN,MS,MSE,OUT
"RTN","DGRPC3",50,0)
 ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
"RTN","DGRPC3",51,0)
 I $D(DGPMSE) D  D NEXT G @DGLST
"RTN","DGRPC3",52,0)
 .S MS=0 F  S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT))  D
"RTN","DGRPC3",53,0)
 ..I $P(DGPMSE(MS),U,7) Q  ;Don't check MSE if verified by HEC
"RTN","DGRPC3",54,0)
 ..S BOS=$P(DGPMSE(MS),U,3) Q:'BOS  S BOSN=$P(^DIC(23,BOS,0),U)
"RTN","DGRPC3",55,0)
 ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE  S MSE="MSE-"_MSE
"RTN","DGRPC3",56,0)
 ..I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
"RTN","DGRPC3",57,0)
 ;Otherwise, get MSE data from DGP(.32)
"RTN","DGRPC3",58,0)
 F MS=1:1:3 D  Q:$G(OUT)
"RTN","DGRPC3",59,0)
 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
"RTN","DGRPC3",60,0)
 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
"RTN","DGRPC3",61,0)
 .S BOS=$P(DGP(.32),U,(5*MS)) Q:'BOS  S BOSN=$P($G(^DIC(23,BOS,0)),U)
"RTN","DGRPC3",62,0)
 .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
"RTN","DGRPC3",63,0)
 .I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
"RTN","DGRPC3",64,0)
 D NEXT G @DGLST
"RTN","DGRPC3",65,0)
84 ;Filipino Vet BOS requires Filipino Vet Proof
"RTN","DGRPC3",66,0)
 N MS,BOS,OUT,MSE
"RTN","DGRPC3",67,0)
 ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
"RTN","DGRPC3",68,0)
 I $D(DGPMSE) D  D NEXT G @DGLST
"RTN","DGRPC3",69,0)
 .S MS=0 F  S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT))  D
"RTN","DGRPC3",70,0)
 ..I $P(DGPMSE(MS),U,7) Q  ;Don't check MSE if verified by HEC
"RTN","DGRPC3",71,0)
 ..S BOS=$P(DGPMSE(MS),U,3) Q:'BOS
"RTN","DGRPC3",72,0)
 ..I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
"RTN","DGRPC3",73,0)
 ;Otherwise use MSE data in DGP(.32)
"RTN","DGRPC3",74,0)
 F MS=1:1:3 D  Q:$G(OUT)
"RTN","DGRPC3",75,0)
 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
"RTN","DGRPC3",76,0)
 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
"RTN","DGRPC3",77,0)
 .S BOS=$P(DGP(.32),U,(5*MS))
"RTN","DGRPC3",78,0)
 .I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
"RTN","DGRPC3",79,0)
 D NEXT G @DGLST
"RTN","DGRPC3",80,0)
85 ;Eligible Filipino Vet should have Veteran status = 'YES'
"RTN","DGRPC3",81,0)
86 ;Ineligible Filipino Vet should have Veteran status = 'NO'
"RTN","DGRPC3",82,0)
 N MS,BOS,FV,FILV,NOTFV,MSE,OUT
"RTN","DGRPC3",83,0)
 ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
"RTN","DGRPC3",84,0)
 I $D(DGPMSE) D
"RTN","DGRPC3",85,0)
 .S MS=0 F  S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT))  D
"RTN","DGRPC3",86,0)
 ..I $P(DGPMSE(MS),U,7) Q  ;Don't check MSE if verified by HEC
"RTN","DGRPC3",87,0)
 ..S BOS=$P(DGPMSE(MS),U,3),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
"RTN","DGRPC3",88,0)
 ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE  S MSE="MSE-"_MSE
"RTN","DGRPC3",89,0)
 ..I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
"RTN","DGRPC3",90,0)
 ..I FV=2 S FILV("E")="" Q
"RTN","DGRPC3",91,0)
 ..I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
"RTN","DGRPC3",92,0)
 ..S FILV("E")=""
"RTN","DGRPC3",93,0)
 ;Otherwise, get MSE data from DGP(.32)
"RTN","DGRPC3",94,0)
 E  F MS=1:1:3 D  Q:$G(OUT)
"RTN","DGRPC3",95,0)
 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
"RTN","DGRPC3",96,0)
 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
"RTN","DGRPC3",97,0)
 .S BOS=$P(DGP(.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
"RTN","DGRPC3",98,0)
 .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
"RTN","DGRPC3",99,0)
 .I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
"RTN","DGRPC3",100,0)
 .I FV=2 S FILV("E")="" Q
"RTN","DGRPC3",101,0)
 .I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
"RTN","DGRPC3",102,0)
 .S FILV("E")=""
"RTN","DGRPC3",103,0)
 I $D(FILV) D
"RTN","DGRPC3",104,0)
 .I DGVT'=1,$D(FILV("E")) S X=85 D COMB Q
"RTN","DGRPC3",105,0)
 .I DGCHK'[(",86,") Q
"RTN","DGRPC3",106,0)
 .I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S X=86 D COMB
"RTN","DGRPC3",107,0)
 S DGLST=86
"RTN","DGRPC3",108,0)
 D NEXT G @DGLST
"RTN","DGRPC3",109,0)
87 ; DG*5.3*657 BAJ 11/24/2005 CC #87 added
"RTN","DGRPC3",110,0)
 ; SC Eligibility but no rated Disability Codes
"RTN","DGRPC3",111,0)
 ; 1. Svc Connected is answered "YES"
"RTN","DGRPC3",112,0)
 ; 2. Eligibility code is either SC < 50% or SC 50-100%
"RTN","DGRPC3",113,0)
 ; 3. Svc connected %-age is 0 or greater
"RTN","DGRPC3",114,0)
 ; 4. Patient has no rated disabilities
"RTN","DGRPC3",115,0)
 ; .. VAEL(1) $P 1 = Primary Eligibility Code  $p 2 = Primary Elig External Value
"RTN","DGRPC3",116,0)
 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
"RTN","DGRPC3",117,0)
 ; .. Rated Disabilities : ^DPT(DFN,.372,0) $P 4 is number of records  '($P($G(^DPT(DFN,.372,0)),"^",4)) is TRUE
"RTN","DGRPC3",118,0)
 ;
"RTN","DGRPC3",119,0)
 ; Get Eligibility info
"RTN","DGRPC3",120,0)
 D ELIG^VADPT
"RTN","DGRPC3",121,0)
 ;
"RTN","DGRPC3",122,0)
 ; If not svc connected, don't check
"RTN","DGRPC3",123,0)
 I '$G(VAEL(3)) D NEXT G @DGLST
"RTN","DGRPC3",124,0)
 ;
"RTN","DGRPC3",125,0)
 I +VAEL(3)=1!(+VAEL(3)=3) D
"RTN","DGRPC3",126,0)
 . Q:$P(VAEL(3),"^",2)<0
"RTN","DGRPC3",127,0)
 . Q:$P(VAEL(3),"^",2)=""
"RTN","DGRPC3",128,0)
 . I '($P($G(^DPT(DFN,.372,0)),"^",4)) S X=87 D COMB
"RTN","DGRPC3",129,0)
 D NEXT G @DGLST
"RTN","DGRPC3",130,0)
 ;
"RTN","DGRPC3",131,0)
88 ;Temporary Address check
"RTN","DGRPC3",132,0)
 N STR88,J,DGI,DGERR,START,END
"RTN","DGRPC3",133,0)
 S DGERR=0
"RTN","DGRPC3",134,0)
 I $P(DGP(.121),U,9)="Y" D
"RTN","DGRPC3",135,0)
 . ;check only if current date is within effective range
"RTN","DGRPC3",136,0)
 . S START=$P(DGP(.121),U,7),END=$P(DGP(.121),U,8)
"RTN","DGRPC3",137,0)
 . Q:START=""  I END="" S END=9999999
"RTN","DGRPC3",138,0)
 . ; quit if current date is not within range
"RTN","DGRPC3",139,0)
 . I '(DT'<START&(DT'>END)) Q
"RTN","DGRPC3",140,0)
 . ; country is either NULL or non-numeric
"RTN","DGRPC3",141,0)
 . I '$P(DGP(.122),U,3) S DGERR=1 Q
"RTN","DGRPC3",142,0)
 . ; country is not in Country file
"RTN","DGRPC3",143,0)
 . I '$D(^HL(779.004,$P(DGP(.122),U,3))) S DGERR=1 Q
"RTN","DGRPC3",144,0)
 . S STR88="1,4,5,6" I $$FORIEN^DGADDUTL($P(DGP(.122),"^",3)) S STR88="1,4"
"RTN","DGRPC3",145,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",146,0)
 I DGERR S X=88 D COMB
"RTN","DGRPC3",147,0)
 D NEXT G @DGLST
"RTN","DGRPC3",148,0)
99 ; synonymous with END
"RTN","DGRPC3",149,0)
END I DGNCK S X=99 D COMB
"RTN","DGRPC3",150,0)
 D OVER99CK
"RTN","DGRPC3",151,0)
 I DGEDCN S DGCON=0 D TIME^DGRPC
"RTN","DGRPC3",152,0)
 K C,C1,C2,DGCD,DGD,DGD1,DGD2,DGDATE,DGDEP,DGCHK,DGFL,DGINC,DGISYR,DGLST,DGMS,DGNCK,DGP,DGPMSE,DGPTYP,DGREL,DGSCT,DGT,DGTIME,DGTOT,DGVT,I,I2,I2,J,VAIN,X,X1
"RTN","DGRPC3",153,0)
 G ^DGRPCF
"RTN","DGRPC3",154,0)
 ;
"RTN","DGRPC3",155,0)
COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
"RTN","DGRPC3",156,0)
 ;;
"RTN","DGRPC3",157,0)
NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) S:'DGLST DGLST="END"
"RTN","DGRPC3",158,0)
 Q
"RTN","DGRPC3",159,0)
 ;
"RTN","DGRPC3",160,0)
OVER99CK N DGP,DGSD,RULE,FILERR
"RTN","DGRPC3",161,0)
 D LOADPT^IVMZ07C(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD)
"RTN","DGRPC3",162,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",163,0)
 F RULE=402,403,406,407 S DGLST=RULE_"^IVMZ7CE" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
"RTN","DGRPC3",164,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",165,0)
 S DGLST="END"
"RTN","DGRPC3",166,0)
 Q
"RTN","DGRPCE")
0^27^B37126023
"RTN","DGRPCE",1,0)
DGRPCE ;ALB/MRL,KV,PJR,BRM,ERC,TDM,LBD - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 10/20/10 3:52pm
"RTN","DGRPCE",2,0)
 ;;5.3;Registration;**121,122,175,297,342,451,626,689,653,754,797**;Aug 13, 1993;Build 24
"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)
 ;Use Screen 6.1 to edit inconsistencies with MSE data (DG*5.3*797)
"RTN","DGRPCE",31,0)
 I $$MSERR^DGRPCE1,$$NEWMSE^DGRPCE1(DFN) D EN^DGRP61(DFN)
"RTN","DGRPCE",32,0)
 ;
"RTN","DGRPCE",33,0)
 I (DGER[301)!(DGER[303)!(DGER[304)!(DGER[307) D
"RTN","DGRPCE",34,0)
 . N DEPFLD
"RTN","DGRPCE",35,0)
 . S DEPFLD=""
"RTN","DGRPCE",36,0)
 . I DGER[301 S DEPFLD=".01;"
"RTN","DGRPCE",37,0)
 . I (DGER[303)!(DGER[304) S DEPFLD=DEPFLD_".02;"
"RTN","DGRPCE",38,0)
 . I DGER[307 S DEPFLD=DEPFLD_".1;"
"RTN","DGRPCE",39,0)
 . D GETREL^DGMTU11(DFN,"SD",$$LYR^DGMTSCU1(DT))
"RTN","DGRPCE",40,0)
 . I $D(DGREL("S")) D DEPEDT(DGREL("S"),DEPFLD)
"RTN","DGRPCE",41,0)
 . F DGDEP=0:0 S DGDEP=$O(DGREL("D",DGDEP)) Q:'DGDEP  D DEPEDT(DGREL("D",DGDEP),DEPFLD)
"RTN","DGRPCE",42,0)
 ;
"RTN","DGRPCE",43,0)
 K DGREL,DGDEP
"RTN","DGRPCE",44,0)
KVAR K DR,DGEDCN,DGCT,DGER,DGINC55,DGRPADI,DGRPOUT,DGVTYN
"RTN","DGRPCE",45,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",46,0)
 K DGCOMLOC,DGCOMBR,FRDT,DGFRDT,DGCTZ7
"RTN","DGRPCE",47,0)
 D KVAR^VADPT
"RTN","DGRPCE",48,0)
 Q
"RTN","DGRPCE",49,0)
SASK I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=$P($T(@I),";;",2,999),DGASK=DGASK_I_",",DGCCF=1 D SAVE
"RTN","DGRPCE",50,0)
 Q
"RTN","DGRPCE",51,0)
SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q
"RTN","DGRPCE",52,0)
 S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
"RTN","DGRPCE",53,0)
ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38,"
"RTN","DGRPCE",54,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",55,0)
 I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
"RTN","DGRPCE",56,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",57,0)
 I 'DGKEY(1) D ELIG^DGRPCE1
"RTN","DGRPCE",58,0)
 Q
"RTN","DGRPCE",59,0)
MON I $S(I<40:1,I=56:1,1:0) D SAVE Q
"RTN","DGRPCE",60,0)
 I $S(I<46:1,1:0),DGASK'[(","_(I-14)_",") D SAVE Q
"RTN","DGRPCE",61,0)
 I DGASK'[(","_(I-15)_",") D SAVE
"RTN","DGRPCE",62,0)
 Q
"RTN","DGRPCE",63,0)
 ;
"RTN","DGRPCE",64,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",65,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",66,0)
25 ;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25;
"RTN","DGRPCE",67,0)
26 ;;
"RTN","DGRPCE",68,0)
27 ;;
"RTN","DGRPCE",69,0)
28 ;;
"RTN","DGRPCE",70,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",71,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",72,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",73,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",74,0)
33 ;;
"RTN","DGRPCE",75,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",76,0)
35 ;;
"RTN","DGRPCE",77,0)
37 ;;.525;S:X'="Y" Y="@37";.526:.528;@37;
"RTN","DGRPCE",78,0)
38 ;;.525;S:X'="Y" Y="@38";.526:.528;@38;
"RTN","DGRPCE",79,0)
39 ;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39;
"RTN","DGRPCE",80,0)
40 ;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40;
"RTN","DGRPCE",81,0)
41 ;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41;
"RTN","DGRPCE",82,0)
42 ;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42;
"RTN","DGRPCE",83,0)
43 ;;
"RTN","DGRPCE",84,0)
44 ;;
"RTN","DGRPCE",85,0)
45 ;;
"RTN","DGRPCE",86,0)
46 ;;
"RTN","DGRPCE",87,0)
47 ;;
"RTN","DGRPCE",88,0)
48 ;;.36265;S:X'="Y" Y="@48";.3626;@48;
"RTN","DGRPCE",89,0)
51 ;;I DGVTYN'="Y" S Y="@51";.324:.328;@51;
"RTN","DGRPCE",90,0)
56 ;;.3025;S:X'="Y" Y="@56";.36295;@56;
"RTN","DGRPCE",91,0)
60 ;;.32102;S:X'="Y" Y="@60";.32107;.3211;.32109;.3213;@60;
"RTN","DGRPCE",92,0)
 ;
"RTN","DGRPCE",93,0)
 ; NOTE: #46 & 47 REMOVED WITH PIMS5.3
"RTN","DGRPCE",94,0)
 ;
"RTN","DGRPCE",95,0)
ASKSSN(DEP) ;edit ssns if missing
"RTN","DGRPCE",96,0)
 ;
"RTN","DGRPCE",97,0)
 ; input:  DEP as string for dependent (from GETREL)
"RTN","DGRPCE",98,0)
 ;
"RTN","DGRPCE",99,0)
 W !,$$NAME^DGMTU1(+DEP)
"RTN","DGRPCE",100,0)
 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
"RTN","DGRPCE",101,0)
PS ;
"RTN","DGRPCE",102,0)
 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
"RTN","DGRPCE",103,0)
 I $$GET1^DIQ(408.13,DA_",",.09)["P" D
"RTN","DGRPCE",104,0)
 . S DR=.1,DA=$P(DA,";") D ^DIE
"RTN","DGRPCE",105,0)
 . I X']"" W !,"If SSN is a Pseudo SSN, the Pseudo SSN Reason field is required." G PS
"RTN","DGRPCE",106,0)
 K DA,DR,DIE
"RTN","DGRPCE",107,0)
 Q
"RTN","DGRPCE",108,0)
 ;
"RTN","DGRPCE",109,0)
CATDIB ;
"RTN","DGRPCE",110,0)
 ;Could be inconsistent because there is the catastrophic disability
"RTN","DGRPCE",111,0)
 ;code without supporting information, or visa versa
"RTN","DGRPCE",112,0)
 ;
"RTN","DGRPCE",113,0)
 N DGCDIS,CODE,INFO
"RTN","DGRPCE",114,0)
 S (INFO,CODE)=0
"RTN","DGRPCE",115,0)
 I $$GET^DGENCDA(DFN,.DGCDIS),DGCDIS("DATE") S INFO=1
"RTN","DGRPCE",116,0)
 S CODE=$$HASCAT^DGENCDA(DFN)
"RTN","DGRPCE",117,0)
 I CODE D  Q
"RTN","DGRPCE",118,0)
 .W !!,">>> Catastrophically Disabled eligibilty requires additional information <<<"
"RTN","DGRPCE",119,0)
 .D EDITCD^DGENCD(DFN)
"RTN","DGRPCE",120,0)
 I INFO D
"RTN","DGRPCE",121,0)
 . ;KV;11/15/00;DG*5.3*297;Start of modifications
"RTN","DGRPCE",122,0)
 . W !!,"The patient record indicates that a  determination was made "
"RTN","DGRPCE",123,0)
 . W "that the patient",!,"is catastrophically disabled."
"RTN","DGRPCE",124,0)
 . W !!,"To add Catastrophic Disability Eligibility Code(s), please use "
"RTN","DGRPCE",125,0)
 . W "the menu option",!,"DGEN PATIENT ENROLLMENT.",!!
"RTN","DGRPCE",126,0)
 .I $$ASKDEL() D
"RTN","DGRPCE",127,0)
 .. I $$DELETE^DGENCDA1(DFN) D
"RTN","DGRPCE",128,0)
 ...W !,">>> Determination Deleted <<<"
"RTN","DGRPCE",129,0)
 ..;
"RTN","DGRPCE",130,0)
 ..;could fail if lock could not be obtained
"RTN","DGRPCE",131,0)
 ..E  W !,"Catastrophic disability determination can not be deleted at this time.",!,"Please try again later."
"RTN","DGRPCE",132,0)
 ;KV;11/15/00;DG*5.3*297;End of modifications
"RTN","DGRPCE",133,0)
 Q
"RTN","DGRPCE",134,0)
 ;
"RTN","DGRPCE",135,0)
ASKDEL() ;
"RTN","DGRPCE",136,0)
 ;ask whether to delete catastrphic disability determination
"RTN","DGRPCE",137,0)
 N DIR
"RTN","DGRPCE",138,0)
 S DIR(0)="Y"
"RTN","DGRPCE",139,0)
 ;KV;11/15/00;DG*5.3*297;Cosmetic change for DIR("A")
"RTN","DGRPCE",140,0)
 S DIR("A")="Do you want to delete the determination showing that patient is catastrophically disabled"
"RTN","DGRPCE",141,0)
 S DIR("B")="YES"
"RTN","DGRPCE",142,0)
 D ^DIR
"RTN","DGRPCE",143,0)
 Q:$D(DIRUT) 0
"RTN","DGRPCE",144,0)
 Q $S(Y=1:1,1:0)
"RTN","DGRPCE",145,0)
 ;
"RTN","DGRPCE",146,0)
DEPEDT(DEP,FLD) ;edit dependent fields if missing or invalid
"RTN","DGRPCE",147,0)
 ;
"RTN","DGRPCE",148,0)
 ; input:  DEP as string for dependent (from GETREL)
"RTN","DGRPCE",149,0)
 ;         FLD as 408.13 field(s) to edit (separated by ';')
"RTN","DGRPCE",150,0)
 ;
"RTN","DGRPCE",151,0)
 Q:$G(FLD)=""
"RTN","DGRPCE",152,0)
 W !!,$$NAME^DGMTU1(+DEP)
"RTN","DGRPCE",153,0)
 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=FLD D ^DIE
"RTN","DGRPCE",154,0)
 K DA,DR,DIE
"RTN","DGRPCE",155,0)
 Q
"RTN","DGRPCE1")
0^28^B64356482
"RTN","DGRPCE1",1,0)
DGRPCE1 ;ALB/MIR/BRM/LBD,BAJ,TDM - CONSISTENCY CHECKER EDIT ; 10/20/10 4:16pm
"RTN","DGRPCE1",2,0)
 ;;5.3;Registration;**108,226,470,454,489,505,522,451,632,689,657,688,804,754,797**;Aug 13, 1993;Build 24
"RTN","DGRPCE1",3,0)
 N DGMSERR S DGMSERR="" I $$NEWMSE(DFN) S DGMSERR=",67,72,73,79,81,83,"
"RTN","DGRPCE1",4,0)
 N I,J F I=1:1:8,16,53,57,58,61:1:88 D SASK
"RTN","DGRPCE1",5,0)
 F I=301,303,304,306:1:308,402,403,406,407,501:1:507,516,517 D SASK
"RTN","DGRPCE1",6,0)
 ;F I=49,50,52 D SASK ;BELOW REPLACED WITH ^IBCNSP2 CALL
"RTN","DGRPCE1",7,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",8,0)
 Q
"RTN","DGRPCE1",9,0)
SASK I DGER[(","_I_","),DGASK'[(","_I_","),DGMSERR'[(","_I_",") F J=I,I*1000:1 Q:'$T(@J)  S DGD=DGD_$P($T(@J),";;",2,999) D SAVE
"RTN","DGRPCE1",10,0)
 S DGASK=DGASK_I_","
"RTN","DGRPCE1",11,0)
 Q
"RTN","DGRPCE1",12,0)
SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q
"RTN","DGRPCE1",13,0)
 S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
"RTN","DGRPCE1",14,0)
 ;
"RTN","DGRPCE1",15,0)
 ;
"RTN","DGRPCE1",16,0)
ELIG ;eligibility code...if M11+, use compiled template, otherwise DR string
"RTN","DGRPCE1",17,0)
 I ^%ZOSF("OS")'["M/11+" S DGD=$P($T(14),";;",2,999) D SAVE Q
"RTN","DGRPCE1",18,0)
 N DA,DIE,DR S DIE="^DPT(",DA=DFN,DR="[DG CONSISTENCY CHECKER]" D ^DIE
"RTN","DGRPCE1",19,0)
 Q
"RTN","DGRPCE1",20,0)
 ;
"RTN","DGRPCE1",21,0)
 ;
"RTN","DGRPCE1",22,0)
1 ;;.01;
"RTN","DGRPCE1",23,0)
2 ;;1;
"RTN","DGRPCE1",24,0)
3 ;;.02;
"RTN","DGRPCE1",25,0)
4 ;;.03;
"RTN","DGRPCE1",26,0)
5 ;;.05;
"RTN","DGRPCE1",27,0)
6 ;;.08;
"RTN","DGRPCE1",28,0)
7 ;;.09;
"RTN","DGRPCE1",29,0)
8 ;;N FLG S FLG(2)=1 S:$G(DGER)[",61," FLG(1)=1 D EN^DGREGAED(DFN,.FLG);
"RTN","DGRPCE1",30,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",31,0)
16 ;;.351;
"RTN","DGRPCE1",32,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",33,0)
57 ;;.381;.382///NOW;
"RTN","DGRPCE1",34,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",35,0)
61 ;;S:$G(DGER)[",8," Y="@619";.132;@619;
"RTN","DGRPCE1",36,0)
62 ;;.331;
"RTN","DGRPCE1",37,0)
63 ;;D EN^DGREGTED(DFN,"CONF");
"RTN","DGRPCE1",38,0)
64 ;;.092;.093;
"RTN","DGRPCE1",39,0)
65 ;;.2403;
"RTN","DGRPCE1",40,0)
66 ;;.09;
"RTN","DGRPCE1",41,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",42,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",43,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",44,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",45,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",46,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",47,0)
 ;
"RTN","DGRPCE1",48,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",49,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",50,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",51,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",52,0)
74002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7407";.32201;S:X'="Y" Y="@7407";.322011;.322012;@7407;
"RTN","DGRPCE1",53,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",54,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",55,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",56,0)
75002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7507";.32201;S:X'="Y" Y="@7507";.322011;.322012;@7507;
"RTN","DGRPCE1",57,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",58,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",59,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",60,0)
76002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7607";.32201;S:X'="Y" Y="@7607";.322011;.322012;@7607;
"RTN","DGRPCE1",61,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",62,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",63,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",64,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",65,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",66,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",67,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",68,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",69,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",70,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",71,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",72,0)
82003 ;;S:$$NEWMSE^DGRPCE1(DFN) Y="@8209";.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",73,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",74,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",75,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",76,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",77,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",78,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",79,0)
84 ;;.3214;
"RTN","DGRPCE1",80,0)
85 ;;1901;
"RTN","DGRPCE1",81,0)
86 ;;1901;
"RTN","DGRPCE1",82,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",83,0)
88 ;;D EN^DGREGTED(DFN,"TEMP");
"RTN","DGRPCE1",84,0)
301 ;;.01;
"RTN","DGRPCE1",85,0)
303 ;;.02;
"RTN","DGRPCE1",86,0)
304 ;;.02;
"RTN","DGRPCE1",87,0)
306 ;;.09;
"RTN","DGRPCE1",88,0)
307 ;;.0906;
"RTN","DGRPCE1",89,0)
308 ;;.351;
"RTN","DGRPCE1",90,0)
402 ;;.381;
"RTN","DGRPCE1",91,0)
403 ;;.382;
"RTN","DGRPCE1",92,0)
406 ;;.313;
"RTN","DGRPCE1",93,0)
407 ;;.3611;
"RTN","DGRPCE1",94,0)
501 ;;.525;
"RTN","DGRPCE1",95,0)
502 ;;.3602;
"RTN","DGRPCE1",96,0)
503 ;;.3603;
"RTN","DGRPCE1",97,0)
504 ;;.32102;
"RTN","DGRPCE1",98,0)
505 ;;.32103;
"RTN","DGRPCE1",99,0)
506 ;;.322013;
"RTN","DGRPCE1",100,0)
507 ;;.32103;.3212;
"RTN","DGRPCE1",101,0)
516 ;;.03;
"RTN","DGRPCE1",102,0)
517 ;;.03;
"RTN","DGRPCE1",103,0)
 ;
"RTN","DGRPCE1",104,0)
YN(FLD,DFN,FILE) ; return binary for YES/NO flds in the Patient (#2) file
"RTN","DGRPCE1",105,0)
 N RTN
"RTN","DGRPCE1",106,0)
 Q:$G(FLD)']"" ""
"RTN","DGRPCE1",107,0)
 S:$G(FILE)="" FILE=2 S:$G(DFN)="" DFN=$G(DA) Q:$G(DFN)']"" ""
"RTN","DGRPCE1",108,0)
 S RTN=$$GET1^DIQ(FILE,DFN_",",FLD,"I")
"RTN","DGRPCE1",109,0)
 Q $S(RTN=1:1,RTN=0:0,RTN="Y":1,RTN="N":0,1:"")
"RTN","DGRPCE1",110,0)
 ;
"RTN","DGRPCE1",111,0)
DGERCK(STR,DGER) ;do any of the STR errors exist in DGER?
"RTN","DGRPCE1",112,0)
 N RTN,X
"RTN","DGRPCE1",113,0)
 Q:$G(STR)']"" 0  Q:$G(DGER)']"" 0
"RTN","DGRPCE1",114,0)
 S RTN=0 F X=1:1 Q:RTN!($P(STR,"^",X)="")  I DGER[(","_$P(STR,"^",X)_",") S RTN=1
"RTN","DGRPCE1",115,0)
 Q RTN
"RTN","DGRPCE1",116,0)
 ;
"RTN","DGRPCE1",117,0)
NEWMSE(DFN) ;Is there data in the new MSE sub-file #2.3216?
"RTN","DGRPCE1",118,0)
 I $G(DFN)="" S DFN=$G(DA)
"RTN","DGRPCE1",119,0)
 Q:$G(DFN)="" 0
"RTN","DGRPCE1",120,0)
 I $O(^DPT(DFN,.3216,0)) Q 1
"RTN","DGRPCE1",121,0)
 Q 0
"RTN","DGRPCE1",122,0)
 ;
"RTN","DGRPCE1",123,0)
MSERR() ;Are there MSE data inconsistencies?
"RTN","DGRPCE1",124,0)
 N ERR,RTN
"RTN","DGRPCE1",125,0)
 S RTN=0
"RTN","DGRPCE1",126,0)
 F ERR=67,72,73,79,81,82,83 I DGER[ERR S RTN=1
"RTN","DGRPCE1",127,0)
 Q RTN
"RTN","DGRPDD1")
0^9^B31264129
"RTN","DGRPDD1",1,0)
DGRPDD1 ;ALB/JDS,LBD - INPUT SYNTAX CHECKS - FORMERLY DGINP ; 3/3/09 4:23pm
"RTN","DGRPDD1",2,0)
 ;;5.3;Registration;**72,136,244,621,797**;AUG 13, 1993;Build 24
"RTN","DGRPDD1",3,0)
 ;
"RTN","DGRPDD1",4,0)
 ;  NOTE: THIS USED TO BE NAMED 'DGINP'
"RTN","DGRPDD1",5,0)
 ;                               -----
"RTN","DGRPDD1",6,0)
 ;
"RTN","DGRPDD1",7,0)
INPUT ; from 7.5 node to massage input before input transform
"RTN","DGRPDD1",8,0)
 I X?.N1"/"1N.ANP D BCDFN^RTDPA Q  ; check for RT label scan
"RTN","DGRPDD1",9,0)
 Q
"RTN","DGRPDD1",10,0)
 ;
"RTN","DGRPDD1",11,0)
SSN I X'?.AN F %=1:1:$L(X) I $E(X,%)?1P S X=$E(X,0,%-1)_$E(X,%+1,999),%=%-1
"RTN","DGRPDD1",12,0)
 I X="P"!(X="p") D PSEU S X=L K L W:'$D(ZTQUEUED) "  ",X G SSNQ
"RTN","DGRPDD1",13,0)
 I X["P",'$D(DPTZNV) D PSEU I X'=L K X,L W:'$D(ZTQUEUED) *7,"  Invalid pseudo SSN.",!,"Type 'P' for the valid one" Q
"RTN","DGRPDD1",14,0)
 I X["P",$D(DPTZNV) D PSEU I X'=L S X=L W:'$D(ZTQUEUED) !!,$C(7),"Pseudo SSN adjusted to match edited name value ==> ",X,!
"RTN","DGRPDD1",15,0)
 G SSNQ:X["P" I X'?9N K X Q
"RTN","DGRPDD1",16,0)
 I $G(DIUTIL)'="VERIFY FIELDS" S DGY=$O(^DPT("SSN",X,0)) I DGY>0,$D(^DPT(DGY,0)) W:'$D(ZTQUEUED) *7,"  Already used by patient '",$P(^(0),"^",1),"'." K X Q
"RTN","DGRPDD1",17,0)
 I $D(X) S L=$E(X,1) I L=9 W:'$D(ZTQUEUED) *7,!,"  The SSN must not begin with 9." K X Q
"RTN","DGRPDD1",18,0)
 I $D(X),$E(X,1,3)="000",$E(X,1,5)'="00000" W:'$D(ZTQUEUED) *7,!,"   First three digits cannot be zeros." K X Q
"RTN","DGRPDD1",19,0)
 I $D(X) S L=$E(X,1,3) I (L>699)&(L<729) W:'$D(ZTQUEUED) !,*7,!,"      Note: This is a RR Retirement SSN."
"RTN","DGRPDD1",20,0)
 I $D(X),$E(X,1,5)="00000" W:'$D(ZTQUEUED) !,*7,!,"      Note: This is a Test Patient SSN."
"RTN","DGRPDD1",21,0)
SSNQ D:$D(X) S^DGPATN Q
"RTN","DGRPDD1",22,0)
C I $D(X) S L=$P(^DPT(DA,0),U,9) I $L(L)=9,X'=L S Y=L_"00" D COL
"RTN","DGRPDD1",23,0)
 K L Q:'$D(X)  Q:X'?11N!(X["P")  S L=0 F Y=0:0 S Y=$O(^DPT("BS",$E(X,6,9),Y)) Q:Y'>0  I Y-DA,$D(^DPT(Y,0)),$P(^(0),U,9)=$E(X,1,9) S L=1 Q
"RTN","DGRPDD1",24,0)
 I L W:'$D(ZTQUEUED) " Collateral of ",$P(^DPT(Y,0),U,1) K L Q
"RTN","DGRPDD1",25,0)
 W:'$D(ZTQUEUED) !,"Must have same SSN to be collateral" K X,L Q
"RTN","DGRPDD1",26,0)
PSEU I $D(DPTIDS(.03)),$D(DPTX) S NAM=DPTX,DOB=DPTIDS(.03)
"RTN","DGRPDD1",27,0)
 E  S L=^DPT(DA,0),DOB=$P(L,"^",3),NAM=$P(L,"^",1)
"RTN","DGRPDD1",28,0)
 ; DG*5.3*621
"RTN","DGRPDD1",29,0)
 I DOB="" S DOB=2000000
"RTN","DGRPDD1",30,0)
 S L1=$E($P(NAM," ",2),1),L3=$E(NAM,1),NAM=$P(NAM,",",2),L2=$E(NAM,1)
"RTN","DGRPDD1",31,0)
 S Z=L1 D CON S L1=Z,Z=L2 D CON S L2=Z,Z=L3 D CON S L3=Z S L=L2_L1_L3_$E(DOB,4,7)_$E(DOB,2,3)_"P"
"RTN","DGRPDD1",32,0)
 K L1,L2,L3,Z,DOB,NAM Q
"RTN","DGRPDD1",33,0)
COL S Y=$O(^DPT("SSN",Y)) Q:$E(Y,1,9)'=L  I $L(Y)=11,$E(Y,1,9)=L S Z=$O(^(Y,0)) I $D(^DPT(Z,0)) W:'$D(ZTQUEUED) !,"Has collateral ",$P(^(0),U,1)," be sure to change SSN" K Z G COL
"RTN","DGRPDD1",34,0)
 Q
"RTN","DGRPDD1",35,0)
CON S Z=$A(Z)-65\3+1 S:Z<0 Z=0 Q
"RTN","DGRPDD1",36,0)
 ;
"RTN","DGRPDD1",37,0)
CAT S L=^DPT(DA,0),DOB=+$P(L,"^",3),AGE=DT-DOB\10000,X1=^DIC(45.82,+Y,0),EDB=+$P(X1,U,4),LDB=+$P(X1,U,5),EAG=+$P(X1,U,6)
"RTN","DGRPDD1",38,0)
 I EDB>0,DOB<EDB W:'$D(ZTQUEUED) !!,"The date of birth is too early for the selected category of beneficiary",!,"Make another selection or correct the date of birth.",!!,*7 K X G CATQ
"RTN","DGRPDD1",39,0)
 I LDB>0,DOB>LDB W:'$D(ZTQUEUED) !!,"The date of birth is too late for the selected category of beneficiary.",!,"Make another selection or correct the date of birth.",!!,*7 K X G CATQ
"RTN","DGRPDD1",40,0)
 I EAG>0,AGE<EAG W:'$D(ZTQUEUED) !!,"The patient's age is too young for the selected category of beneficiary.",!,"Make another selection or correct the date of birth.",!!,*7 K X G CATQ
"RTN","DGRPDD1",41,0)
CATQ K EAG,AGE,DOB,LDB,EDB,X1 Q
"RTN","DGRPDD1",42,0)
 ;
"RTN","DGRPDD1",43,0)
VIET Q
"RTN","DGRPDD1",44,0)
POS S L=^DPT(DA,0),Y=+$P(L,"^",3) I X-Y\10000<15 X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service entry date would make the patient too young for service.",!,"DOB ",Y,!,*7 K X G POSQ
"RTN","DGRPDD1",45,0)
 G POSQ:SD1=1!'$D(^DPT(DA,.32)) S L1=^(.32) I $P(L1,"^",SD1-1*5+1)="" W:'$D(ZTQUEUED) !?5,"Previous service entry date is not on file",*7 G POSQ
"RTN","DGRPDD1",46,0)
 S Y=$P(L1,U,6) I SD1=2,X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service entry date must be before than the first service entry date ",Y,!!,*7 K X G POSQ
"RTN","DGRPDD1",47,0)
 S Y=$P(L1,U,11) I SD1=3,X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service entry date must be less than the second service entry date ",Y,!!,*7 K X G POSQ
"RTN","DGRPDD1",48,0)
POSQ K L1,L,DOB,AGE,SD1 Q
"RTN","DGRPDD1",49,0)
 ;
"RTN","DGRPDD1",50,0)
PS S L1=$S($D(^DPT(DA,.32)):^(.32),1:"") G PS2:SD1=2,PS3:SD1=3 S Y=$P(L1,U,6) I X'>Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be after the entry date ",Y,!!,*7 K X G PSQ
"RTN","DGRPDD1",51,0)
 ;
"RTN","DGRPDD1",52,0)
 G PSQ
"RTN","DGRPDD1",53,0)
PS2 S Y=$P(L1,U,11) I X'>Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be after the service entry date ",Y,!!,*7 K X G PSQ
"RTN","DGRPDD1",54,0)
 S Y=$P(L1,U,6) I Y,X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service separation date must be before the next service entry date ",Y,!!,*7 K X G PSQ
"RTN","DGRPDD1",55,0)
 G PSQ
"RTN","DGRPDD1",56,0)
PS3 S Y=$P(L1,U,16) I X'>Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be after the service entry date ",Y,!!,*7 K X G PSQ
"RTN","DGRPDD1",57,0)
 S Y=$P(L1,U,11) I X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be before the next service entry date ",Y,!!,*7 K X G POSQ
"RTN","DGRPDD1",58,0)
PSQ K L1,SD1 Q
"RTN","DGRPDD1",59,0)
CAT1 S DDA=DA,DA=+^DGPT(DA,0) D CAT S DA=DDA K DDA Q
"RTN","DGRPDD1",60,0)
 ;
"RTN","DGRPDD1",61,0)
AGE(DFN,X) ;Called from input transform of SERVICE ENTRY field (#.01) of the
"RTN","DGRPDD1",62,0)
 ;MILITARY SERVICE EPISODE sub-file #2.3216. Added for DG*5.3*797.
"RTN","DGRPDD1",63,0)
 N DOB,MSG
"RTN","DGRPDD1",64,0)
 Q:'$G(DFN) 0 Q:'$G(X) 0
"RTN","DGRPDD1",65,0)
 S DOB=+$P($G(^DPT(DFN,0)),U,3)
"RTN","DGRPDD1",66,0)
 I X-DOB\10000<15 D  Q 0
"RTN","DGRPDD1",67,0)
 .S MSG(1)="This service entry date would make the patient too young for service."
"RTN","DGRPDD1",68,0)
 .S MSG(1,"F")="!!"
"RTN","DGRPDD1",69,0)
 .S MSG(2)="DOB "_$$FMTE^XLFDT(DOB)
"RTN","DGRPDD1",70,0)
 .D EN^DDIOL(.MSG)
"RTN","DGRPDD1",71,0)
 Q 1
"RTN","DGRPDT")
0^8^B77027156
"RTN","DGRPDT",1,0)
DGRPDT ;ALB/BRM,LBD - MILITARY SERVICE DATE UTILITIES ; 6/30/09 2:21pm
"RTN","DGRPDT",2,0)
 ;;5.3;Registration;**562,603,626,673,731,797**;Aug 13, 1993;Build 24
"RTN","DGRPDT",3,0)
 ;
"RTN","DGRPDT",4,0)
DTUTIL(DGNEWDT,DGOLDDT,MYFLG) ; Date precision comparision API
"RTN","DGRPDT",5,0)
 S:$G(DGOLDDT)="" DGOLDDT="0000000"
"RTN","DGRPDT",6,0)
 Q:'$$VALID(.DGNEWDT) "0^INVALID DATE PARAMETER"
"RTN","DGRPDT",7,0)
 I $L(DGOLDDT)<7 S DGOLDDT=DGOLDDT_$E("0000000",$L(DGOLDDT)+1,7)
"RTN","DGRPDT",8,0)
 N X,Y,EXACTO,EXACTN,I,RTN,MSDATE,MSG
"RTN","DGRPDT",9,0)
 S RTN="",EXACTO=$$CHKEXC(DGOLDDT),EXACTN=$$CHKEXC(DGNEWDT)
"RTN","DGRPDT",10,0)
 I $G(MYFLG) Q:'$$MNTHYR(DGNEWDT) "0^Date must contain month and year"
"RTN","DGRPDT",11,0)
 Q:EXACTO=EXACTN "1^Same Precision"
"RTN","DGRPDT",12,0)
 F I=1:1:3  Q:RTN'=""  D
"RTN","DGRPDT",13,0)
 .S:$E(EXACTN,I)<$E(EXACTO,I) RTN="0^ is Less Precise Than Previously Entered "
"RTN","DGRPDT",14,0)
 .S:$E(EXACTN,I)>$E(EXACTO,I) RTN="1^ is More Precise Than Previously Entered "
"RTN","DGRPDT",15,0)
 .S MSG=$S(I=1:"Year",I=2:"Month",I=3:"Day",1:"")
"RTN","DGRPDT",16,0)
 .S:RTN'="" $P(RTN,"^",2)=MSG_$P(RTN,"^",2)_MSG
"RTN","DGRPDT",17,0)
 Q $S($G(RTN)'="":RTN,1:"0^Unknown Precision")
"RTN","DGRPDT",18,0)
CHKEXC(MSDATE) ; construct precision string (3 digit return value - YMD)
"RTN","DGRPDT",19,0)
 Q ($E(MSDATE,1,3)'="000")_($E(MSDATE,4,5)'="00")_($E(MSDATE,6,7)'="00")
"RTN","DGRPDT",20,0)
MNTHYR(MSDATE) ; ensure month and year are not imprecise (binary return value)
"RTN","DGRPDT",21,0)
 Q ($E(MSDATE,1,3)'="000")&($E(MSDATE,4,5)'="00")
"RTN","DGRPDT",22,0)
WITHIN(FRDT,TODT,CHKDT) ; is CHKDT within FRDT and TODT?
"RTN","DGRPDT",23,0)
 N DGRPB41,DGRPB42
"RTN","DGRPDT",24,0)
 Q:'$$VALID($G(CHKDT)) "0^Invalid Date"
"RTN","DGRPDT",25,0)
 Q:('$G(FRDT))!('$G(TODT)) "0^Missing Required Date Range"
"RTN","DGRPDT",26,0)
 Q:('$$VALID(FRDT)!'$$VALID(TODT)!'$$B4(FRDT,TODT,1)) "0^Invalid Date Range"
"RTN","DGRPDT",27,0)
 S DGRPB41=$$B4(FRDT,CHKDT,1),DGRPB42=$$B4(CHKDT,TODT,1)
"RTN","DGRPDT",28,0)
 I 'DGRPB41!'DGRPB42 Q "0^Not Within Valid Date Range"
"RTN","DGRPDT",29,0)
 Q "1^Date is Within Date Range"_$S($P(DGRPB41,"^",2):"^1",$P(DGRPB42,"^",2):"^1",1:"")  ;add same flag if they are the same
"RTN","DGRPDT",30,0)
VALID(DATE) ; is this a valid Fileman date? (limits are from FR^XLFDT)
"RTN","DGRPDT",31,0)
 Q:'$D(DATE) 0
"RTN","DGRPDT",32,0)
 Q (1410102'>DATE)&(DATE'>4141015.235959)
"RTN","DGRPDT",33,0)
B4(DATE1,DATE2,SAME) ;is DATE1 before DATE2?
"RTN","DGRPDT",34,0)
 N IMPRDT,IDT,IRTN,CDATE1,CDATE2
"RTN","DGRPDT",35,0)
 S DATE1=$P($G(DATE1),"."),DATE2=$P($G(DATE2),".")
"RTN","DGRPDT",36,0)
 Q:DATE1=""!DATE2="" 1
"RTN","DGRPDT",37,0)
 I $G(SAME),DATE1=DATE2 Q "1^1"
"RTN","DGRPDT",38,0)
 I $$CHKEXC(DATE1)'=111!$$CHKEXC(DATE2)'=111 D  Q:$G(IRTN) IRTN
"RTN","DGRPDT",39,0)
 .S (CDATE1,CDATE2)="0000000"
"RTN","DGRPDT",40,0)
 .I $E(DATE1,1,3),$E(DATE2,1,3) F I=1:1:2 S $E(@("CDATE"_I),1,3)=$E(@("DATE"_I),1,3)
"RTN","DGRPDT",41,0)
 .I $E(DATE1,4,5),$E(DATE2,4,5) F I=1:1:2 S $E(@("CDATE"_I),4,5)=$E(@("DATE"_I),4,5)
"RTN","DGRPDT",42,0)
 .I $E(DATE1,6,7),$E(DATE2,6,7) F I=1:1:2 S $E(@("CDATE"_I),6,7)=$E(@("DATE"_I),6,7)
"RTN","DGRPDT",43,0)
 .I CDATE1<CDATE2 S IRTN=1 Q
"RTN","DGRPDT",44,0)
 .I CDATE1=CDATE2 S IRTN="1^1" Q
"RTN","DGRPDT",45,0)
 Q DATE1<DATE2
"RTN","DGRPDT",46,0)
RWITHIN(FRDT,TODT,CHKDT1,CHKDT2) ;are CHKDT1 and CHKDT2 within FRDT and TODT?
"RTN","DGRPDT",47,0)
 N CHK1,CHK2
"RTN","DGRPDT",48,0)
 S CHK1=$$WITHIN(.FRDT,.TODT,.CHKDT1) Q:'CHK1 CHK1
"RTN","DGRPDT",49,0)
 S CHK2=$$WITHIN(.FRDT,.TODT,.CHKDT2) Q:'CHK2 CHK2
"RTN","DGRPDT",50,0)
 Q "1^Both Date are Within Date Range"_$S(($P(CHK1,"^",3)!$P(CHK2,"^",3)):"^1",1:"")
"RTN","DGRPDT",51,0)
COVRLP2(DFN,FRDT,TODT,IGNORE,OEFOIF) ; check conflict with type 0 and 2 (see below)
"RTN","DGRPDT",52,0)
 Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
"RTN","DGRPDT",53,0)
 S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,-1,$G(IGNORE),.OEFOIF)
"RTN","DGRPDT",54,0)
 Q:$P(RTN,"^")=0 RTN
"RTN","DGRPDT",55,0)
 S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,2,$G(IGNORE),.OEFOIF)
"RTN","DGRPDT",56,0)
 Q RTN
"RTN","DGRPDT",57,0)
OVRLPCHK(DFN,FRDT,TODT,TYPE,IGNORE,OEFOIF,MSE) ;check for overlapping date ranges
"RTN","DGRPDT",58,0)
 ; pass OEFOIF by ref - return OEFOIF(1)=1: OEF/OIF "cnflct not within MSE
"RTN","DGRPDT",59,0)
 N RTN1,DATA,NODE,RTN,FRDT1,MSG,SUBRNG,TODT1,DGW1,DGW2,DGRW1,DGRW2,DGZ
"RTN","DGRPDT",60,0)
 Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
"RTN","DGRPDT",61,0)
 I TYPE<2 D
"RTN","DGRPDT",62,0)
 . ; If data in MSE sub-file #2.3216, do not use old MSE fields
"RTN","DGRPDT",63,0)
 . I $G(MSE)!($D(^DPT(DFN,.3216))) S NODE(2.3216)=".01,.02" K IGNORE Q
"RTN","DGRPDT",64,0)
 . S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
"RTN","DGRPDT",65,0)
 E  D
"RTN","DGRPDT",66,0)
 . ; If checking an OEF/OIF period, only check against OEF/OIF
"RTN","DGRPDT",67,0)
 . I $G(OEFOIF) S NODE(2.3215)=".02,.03" K IGNORE Q
"RTN","DGRPDT",68,0)
 . S NODE(.321)=".32104,.32105",NODE(.322)=".3222,.3223,.3225,.3226,.3228,.3229,.322011,.322012,.322017,.322018,.32202,.322021",NODE(.52)=".5293,.5294"
"RTN","DGRPDT",69,0)
 D:$G(IGNORE)]"" IGNORE(.NODE,.IGNORE)
"RTN","DGRPDT",70,0)
 D GETDAT(DFN,.NODE,.DATA) Q:'$D(DATA) "1^CANNOT FIND PATIENT DATA"
"RTN","DGRPDT",71,0)
 I $G(MSE) K DATA("MSE-"_MSE)  ;MSE entry to exclude (used instead of IGNORE) - DG*5.3*797
"RTN","DGRPDT",72,0)
 I $G(OEFOIF),$P(OEFOIF,U,2)'="" K DATA($P(OEFOIF,U,2)) ; OEF/OIF entry to exclude (used instead of IGNORE)
"RTN","DGRPDT",73,0)
 I TYPE<0 S DGZ=$$MSEONLY(.DATA,FRDT,TODT) S:'DGZ&$G(OEFOIF) OEFOIF(1)=1 Q DGZ
"RTN","DGRPDT",74,0)
 S SUBRNG="" F  S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG=""!($D(RTN))  D
"RTN","DGRPDT",75,0)
 .S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
"RTN","DGRPDT",76,0)
 .I FRDT1="",TODT1="" Q
"RTN","DGRPDT",77,0)
 .I 'TYPE S:$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT) RTN1=$G(RTN1)+1 Q
"RTN","DGRPDT",78,0)
 .S MSG=$S(TYPE=1:"Military Service Episode",1:"Conflict")
"RTN","DGRPDT",79,0)
 . ; For OEF/OIF only - dates must be totally non-overlapping
"RTN","DGRPDT",80,0)
 .S DGW1=$$WITHIN(FRDT1,TODT1,.FRDT),DGW2=$$WITHIN(FRDT1,TODT1,.TODT)
"RTN","DGRPDT",81,0)
 .I DGW1,$S($G(OEFOIF):'$P(DGW1,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
"RTN","DGRPDT",82,0)
 .I DGW2,$S($G(OEFOIF):'$P(DGW2,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
"RTN","DGRPDT",83,0)
 .S DGRW1=$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT),DGRW2=$$RWITHIN(.FRDT,.TODT,FRDT1,TODT1)
"RTN","DGRPDT",84,0)
 .I '$G(OEFOIF),DGRW1,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^This "_MSG_" is within another "_MSG
"RTN","DGRPDT",85,0)
 .I '$G(OEFOIF),DGRW2,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^Another "_MSG_" is within another "_MSG
"RTN","DGRPDT",86,0)
 .I $E($P($G(OEFOIF),U,2),1,3)="UNK"!($E(SUBRNG,1,3)="UNK") D
"RTN","DGRPDT",87,0)
 .. I FRDT,TODT,'(DGRW1!DGRW2),DGW1!DGW2 S RTN="0^This "_MSG_" is within another "_MSG
"RTN","DGRPDT",88,0)
 .I (DGRW1!(DGRW2)),$S($E($P($G(OEFOIF),U,2),1,3)'="UNK"&($E(SUBRNG,1,3)'="UNK"):'$$SAME(FRDT1,TODT1,FRDT,TODT),1:$E(SUBRNG,1,3)="UNK"&(FRDT'=FRDT1!(TODT'=TODT1))) S RTN="0^This "_MSG_" is within another "_MSG
"RTN","DGRPDT",89,0)
 I ('TYPE),'$D(RTN1) S:$G(OEFOIF) OEFOIF(1)=1 Q "0^This conflict is not within a Military Service Episode"
"RTN","DGRPDT",90,0)
 Q:$D(RTN) RTN
"RTN","DGRPDT",91,0)
 Q "1^OK"
"RTN","DGRPDT",92,0)
SAME(FRDT1,TODT1,FRDT,TODT) ;
"RTN","DGRPDT",93,0)
 N DGS1,DGS2,DGS3,DGS4
"RTN","DGRPDT",94,0)
 S DGS1=$$B4(FRDT,TODT1,1),DGS2=$$B4(FRDT1,TODT,1)
"RTN","DGRPDT",95,0)
 S DGS3=$$B4(TODT,FRDT1,1),DGS4=$$B4(TODT1,FRDT,1)
"RTN","DGRPDT",96,0)
 Q:$P(DGS1,"^",3) 1
"RTN","DGRPDT",97,0)
 Q:$P(DGS2,"^",3) 1
"RTN","DGRPDT",98,0)
 Q:$P(DGS3,"^",3) 1
"RTN","DGRPDT",99,0)
 Q:$P(DGS4,"^",3) 1
"RTN","DGRPDT",100,0)
 Q 0
"RTN","DGRPDT",101,0)
GETDAT(DFN,NODE,DATA) ;get data from the Patient (#2) file
"RTN","DGRPDT",102,0)
 N LOOP,SUB,SUB1,Z,Z0,TMPDAT,DATA1,ERR,DR,SUBND,X,X1
"RTN","DGRPDT",103,0)
 Q:('$D(NODE))!('$D(DFN))
"RTN","DGRPDT",104,0)
 S SUB="",Z=1
"RTN","DGRPDT",105,0)
 F  S SUB=$O(NODE(SUB)) Q:SUB=""  D
"RTN","DGRPDT",106,0)
 .S SUBND=$P(SUB,".")
"RTN","DGRPDT",107,0)
 .S DR=$TR(NODE(SUB),",",";") Q:DR=""
"RTN","DGRPDT",108,0)
 .I 'SUBND D  Q
"RTN","DGRPDT",109,0)
 ..D GETS^DIQ(2,DFN_",",DR,"I","TMPDAT","ERR")
"RTN","DGRPDT",110,0)
 ..S LOOP="F X="_$G(NODE(SUB))_" S DATA1(X)=$G(TMPDAT(2,DFN_"","",X,""I"")),Z=Z+1"
"RTN","DGRPDT",111,0)
 ..X LOOP
"RTN","DGRPDT",112,0)
 .I SUB-2=.3216 D  Q
"RTN","DGRPDT",113,0)
 ..; Extract data from MSE sub-file #2.3216 (DG*5.3*797)
"RTN","DGRPDT",114,0)
 ..S Z0=0 F  S Z0=$O(^DPT(DFN,.3216,Z0)) Q:'Z0  D GETS^DIQ(SUB,Z0_","_DFN_",",DR,"I","TMPDAT","ERR")
"RTN","DGRPDT",115,0)
 ..S X="" F  S X=$O(TMPDAT(SUB,X)) Q:X=""  S X1="" F  S X1=$O(TMPDAT(SUB,X,X1)) Q:X1=""  S DATA1("MSE-"_$P(X,","),X1)=TMPDAT(SUB,X,X1,"I")
"RTN","DGRPDT",116,0)
 . ; Extract dates from OIF OEF multiple too
"RTN","DGRPDT",117,0)
 . S Z0=0 F  S Z0=$O(^DPT(DFN,SUB-2,Z0)) Q:'Z0  S SUB1(Z0)=+$G(^(Z0,0)) D GETS^DIQ(SUB,Z0_","_DFN_",",DR,"I","TMPDAT","ERR")
"RTN","DGRPDT",118,0)
 .S LOOP="F X="_$G(NODE(SUB))_" F X1=0:0 S X1=$O(SUB1(X1)) Q:'X1  S DATA1($S(SUB1(X1)=3:""UNK"",1:$$EXTERNAL^DILFD(SUB,.01,,SUB1(X1)))_""-""_X1,X)=$G(TMPDAT(SUB,X1_"",""_DFN_"","",X,""I"")),Z=Z+1" X LOOP
"RTN","DGRPDT",119,0)
 S DATA("MSL")=$G(DATA1(.326))_"^"_$G(DATA1(.327))
"RTN","DGRPDT",120,0)
 S DATA("MSNTL")=$S($G(DATA1(.3285))="Y":$G(DATA1(.3292))_"^"_$G(DATA1(.3293)),1:"^")
"RTN","DGRPDT",121,0)
 S DATA("MSNNTL")=$S($G(DATA1(.32945))="Y":$G(DATA1(.3297))_"^"_$G(DATA1(.3298)),1:"^")
"RTN","DGRPDT",122,0)
 S DATA("VIET")=$G(DATA1(.32104))_"^"_$G(DATA1(.32105))
"RTN","DGRPDT",123,0)
 S DATA("LEB")=$G(DATA1(.3222))_"^"_$G(DATA1(.3223))
"RTN","DGRPDT",124,0)
 S DATA("GREN")=$G(DATA1(.3225))_"^"_$G(DATA1(.3226))
"RTN","DGRPDT",125,0)
 S DATA("PAN")=$G(DATA1(.3228))_"^"_$G(DATA1(.3229))
"RTN","DGRPDT",126,0)
 S DATA("GULF")=$G(DATA1(.322011))_"^"_$G(DATA1(.322012))
"RTN","DGRPDT",127,0)
 S DATA("SOM")=$G(DATA1(.322017))_"^"_$G(DATA1(.322018))
"RTN","DGRPDT",128,0)
 S DATA("YUG")=$G(DATA1(.32202))_"^"_$G(DATA1(.322021))
"RTN","DGRPDT",129,0)
 S DATA("COMBAT")=$G(DATA1(.5293))_"^"_$G(DATA1(.5294))
"RTN","DGRPDT",130,0)
 ; Set the MSE nodes (DG*5.3*797)
"RTN","DGRPDT",131,0)
 S Z="MSE" F  S Z=$O(DATA1(Z)) Q:Z'["MSE"  S DATA(Z)=$G(DATA1(Z,.01))_"^"_$G(DATA1(Z,.02))
"RTN","DGRPDT",132,0)
 ; Pick up the OEF/OIF nodes here - subscript is not numeric
"RTN","DGRPDT",133,0)
 S Z="O" F  S Z=$O(DATA1(Z)) Q:Z=""  S DATA(Z)=$G(DATA1(Z,.02))_"^"_$G(DATA1(Z,.03))
"RTN","DGRPDT",134,0)
 Q
"RTN","DGRPDT",135,0)
MSEONLY(DATA,FRDT,TODT) ; are these dates within the whole MSE period?
"RTN","DGRPDT",136,0)
 N TO,FROM,SUBRNG,FRDT1,TODT1,MSEFR,MSETO
"RTN","DGRPDT",137,0)
 S SUBRNG="" F  S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG=""  D
"RTN","DGRPDT",138,0)
 .S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
"RTN","DGRPDT",139,0)
 .S:FRDT1 FROM(FRDT1)="" S:TODT1 TO(TODT1)=""
"RTN","DGRPDT",140,0)
 S MSEFR=$O(FROM("")),MSETO=$O(TO(""),-1)
"RTN","DGRPDT",141,0)
 I FRDT,(('$$B4(MSEFR,FRDT,1))!'$$B4(FRDT,MSETO,1)) Q "0^Conflict From Date is Not Within Military Service Episode Dates"
"RTN","DGRPDT",142,0)
 I TODT,(('$$B4(TODT,MSETO,1))!'$$B4(MSEFR,TODT,1)) Q "0^Conflict End Date is Not Within Military Service Episode Dates"
"RTN","DGRPDT",143,0)
 Q "1^OK"
"RTN","DGRPDT",144,0)
CNFLCTDT(FRDT,TODT,CNFLCT) ;are these dates valid for this conflict?
"RTN","DGRPDT",145,0)
 Q:'$D(CNFLCT) "0^INVALID CONFLICT"
"RTN","DGRPDT",146,0)
 N CRNG
"RTN","DGRPDT",147,0)
 S CRNG=$$GETCNFDT($P(CNFLCT,"-")) Q:$TR(CRNG,"^")="" "0^INVALID CONFLICT"
"RTN","DGRPDT",148,0)
 Q:$P(CRNG,"^")=0 CRNG
"RTN","DGRPDT",149,0)
 I $G(TODT)'="",TODT<$P(CRNG,U,3) Q "0^Not Within Valid Date Range"
"RTN","DGRPDT",150,0)
 I $G(FRDT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
"RTN","DGRPDT",151,0)
 I $G(TODT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
"RTN","DGRPDT",152,0)
 Q $$RWITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT,.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
"RTN","DGRPDT",153,0)
GETCNFDT(CNFLCT) ; get the date range for input conflict
"RTN","DGRPDT",154,0)
 Q:'$D(CNFLCT) "0^INVALID CONFLICT"
"RTN","DGRPDT",155,0)
 N CRNG,CNFLCT1
"RTN","DGRPDT",156,0)
 S CNFLCT1=$P(CNFLCT,"-")
"RTN","DGRPDT",157,0)
 S CRNG=$T(@(CNFLCT1)) Q:CRNG']"" "0^INVALID CONFLICT"
"RTN","DGRPDT",158,0)
 S CRNG=$P(CRNG,";;",2) S:$P(CRNG,"^",2)="" $P(CRNG,"^",2)=$$DT^XLFDT
"RTN","DGRPDT",159,0)
 S:$P(CRNG,"^")="" $P(CRNG,"^")=1410102
"RTN","DGRPDT",160,0)
 S:$P(CRNG,U,3)="" $P(CRNG,U,3)=$P(CRNG,U)
"RTN","DGRPDT",161,0)
 Q CRNG
"RTN","DGRPDT",162,0)
IGNORE(NODE,IFLD) ; extract top-level field to ignore when comparing
"RTN","DGRPDT",163,0)
 N LOOP,QLOOP,RVAL,LSTPC,PC
"RTN","DGRPDT",164,0)
 S LOOP="",IFLD="^"_IFLD_"^"
"RTN","DGRPDT",165,0)
 F  S LOOP=$O(NODE(LOOP)) Q:LOOP=""  D
"RTN","DGRPDT",166,0)
 .I IFLD[("^"_$P(NODE(LOOP),",")_"^") S NODE(LOOP)=$P(NODE(LOOP),",",2,99),LOOP="" Q
"RTN","DGRPDT",167,0)
 .S LSTPC=$L($TR(NODE(LOOP),".0123456789"))+1
"RTN","DGRPDT",168,0)
 .I IFLD[("^"_$P(NODE(LOOP),",",LSTPC)_"^") S NODE(LOOP)=$P(NODE(LOOP),",",1,LSTPC-1),LOOP="" Q
"RTN","DGRPDT",169,0)
 .F PC=1:1:LSTPC Q:$G(QLOOP)  I IFLD[("^"_$P(NODE(LOOP),",",PC)_"^") S NODE(LOOP)=$P(NODE(LOOP),",",1,PC-1)_","_$P(NODE(LOOP),",",PC+1,99),LOOP="" Q
"RTN","DGRPDT",170,0)
 Q
"RTN","DGRPDT",171,0)
CNFLCT ;; ***  DO NOT REMOVE OR CHANGE BELOW CONFLICT VALUES  ***
"RTN","DGRPDT",172,0)
 ;;
"RTN","DGRPDT",173,0)
 ;'fr dt'^'to dt'^minimum 'to dt'
"RTN","DGRPDT",174,0)
WWI ;;2170406^2181111
"RTN","DGRPDT",175,0)
WWIIE ;;2411207^2461231
"RTN","DGRPDT",176,0)
WWIIP ;;2411207^2461231
"RTN","DGRPDT",177,0)
KOR ;;2500627^2550131
"RTN","DGRPDT",178,0)
VIET ;;2610228^2750507
"RTN","DGRPDT",179,0)
LEB ;;2831001^
"RTN","DGRPDT",180,0)
GREN ;;2831023^2831121
"RTN","DGRPDT",181,0)
PAN ;;2891220^2900131
"RTN","DGRPDT",182,0)
GULF ;;2900802^
"RTN","DGRPDT",183,0)
SOM ;;2920928^
"RTN","DGRPDT",184,0)
YUG ;;2920622^
"RTN","DGRPDT",185,0)
OTHER ;;^
"RTN","DGRPDT",186,0)
OIF ;;3030301^^3030319
"RTN","DGRPDT",187,0)
OEF ;;3010901^^3010911
"RTN","DGRPDT",188,0)
UNK ;;3010901^^3010911
"RTN","DGRPE")
0^13^B52635716
"RTN","DGRPE",1,0)
DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ - REGISTRATIONS EDITS ; 6/24/09 3:03pm
"RTN","DGRPE",2,0)
 ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,688,797**;Aug 13, 1993;Build 24
"RTN","DGRPE",3,0)
 ;
"RTN","DGRPE",4,0)
 ;DGDR contains a string of edits; edit=screen*10+item #
"RTN","DGRPE",5,0)
 ;
"RTN","DGRPE",6,0)
 ;line tag screen*10+item*1000 = continuation line
"RTN","DGRPE",7,0)
 ;
"RTN","DGRPE",8,0)
 I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
"RTN","DGRPE",9,0)
 I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
"RTN","DGRPE",10,0)
 I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
"RTN","DGRPE",11,0)
 I DGRPS=5,DGDR["501," D
"RTN","DGRPE",12,0)
 .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
"RTN","DGRPE",13,0)
 .D REG^IBCNBME(DFN)
"RTN","DGRPE",14,0)
 .Q
"RTN","DGRPE",15,0)
 N QUIT S QUIT=0
"RTN","DGRPE",16,0)
 I DGRPS=6,$S(DGDR["601,"!(DGDR["602,")!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
"RTN","DGRPE",17,0)
 .;Use new ListMan screen for Military Service Episodes (DG*5.3*797)
"RTN","DGRPE",18,0)
 . I DGDR["601," D EN^DGRP61(DFN)   ; MSEs
"RTN","DGRPE",19,0)
 . ; D SETDR("601,",.DR)
"RTN","DGRPE",20,0)
 . ; S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",21,0)
 . ; D ^DIE I $D(Y) S QUIT=1
"RTN","DGRPE",22,0)
 . ; S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
"RTN","DGRPE",23,0)
 . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
"RTN","DGRPE",24,0)
 . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
"RTN","DGRPE",25,0)
 ;-- Tricare screen #15
"RTN","DGRPE",26,0)
 I DGRPS=15 D EDIT^DGRP15,Q Q
"RTN","DGRPE",27,0)
 ;
"RTN","DGRPE",28,0)
 N DGPH,DGPHFLG
"RTN","DGRPE",29,0)
 K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",30,0)
 G ^DGRPE1:DGRPS>6
"RTN","DGRPE",31,0)
 I DGRPS=4 D ^DGRPE4
"RTN","DGRPE",32,0)
 D SETDR(DGDR,.DR)
"RTN","DGRPE",33,0)
 S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",34,0)
 D ^DIE
"RTN","DGRPE",35,0)
 ;check for Combat Vet status
"RTN","DGRPE",36,0)
 I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
"RTN","DGRPE",37,0)
 . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
"RTN","DGRPE",38,0)
 . S DIR(0)="EA" D ^DIR K DIR
"RTN","DGRPE",39,0)
 I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
"RTN","DGRPE",40,0)
Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
"RTN","DGRPE",41,0)
 Q
"RTN","DGRPE",42,0)
 ;
"RTN","DGRPE",43,0)
SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected
"RTN","DGRPE",44,0)
 N DGCT,DGDRS,J1,J2
"RTN","DGRPE",45,0)
 K DR S DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",46,0)
 F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
"RTN","DGRPE",47,0)
 . S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",48,0)
 . N J2
"RTN","DGRPE",49,0)
 . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",50,0)
 Q
"RTN","DGRPE",51,0)
 ;
"RTN","DGRPE",52,0)
S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
"RTN","DGRPE",53,0)
 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
"RTN","DGRPE",54,0)
 Q
"RTN","DGRPE",55,0)
 ;
"RTN","DGRPE",56,0)
SETFLDS(DGDR) ; Set up fields to edit
"RTN","DGRPE",57,0)
 Q
"RTN","DGRPE",58,0)
 ;
"RTN","DGRPE",59,0)
101 ;;
"RTN","DGRPE",60,0)
102 ;;1;
"RTN","DGRPE",61,0)
103 ;;.091;
"RTN","DGRPE",62,0)
104 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
"RTN","DGRPE",63,0)
105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;
"RTN","DGRPE",64,0)
105000 ;;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET Y=.12105;@15;K DIE("NO^");
"RTN","DGRPE",65,0)
109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
"RTN","DGRPE",66,0)
111 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
"RTN","DGRPE",67,0)
111000 ;;K DR(2,2.141);N RET S RET=1 D EN^DGREGTED(DFN,"CONF",.RET) S:'RET Y=.14105;@111;K DIE("NO^");
"RTN","DGRPE",68,0)
112 ;;.134;.135;.133
"RTN","DGRPE",69,0)
201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;
"RTN","DGRPE",70,0)
202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
"RTN","DGRPE",71,0)
203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
"RTN","DGRPE",72,0)
205 ;;.181;
"RTN","DGRPE",73,0)
301 ;;.211;S:X']"" Y="@31";.212;D DR301^DGRPE S:DG4=1 Y=.213;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;K DG4;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31;
"RTN","DGRPE",74,0)
302 ;;.2191;S:X']"" Y="@32";.2192;D DR301^DGRPE S:DG4=1 Y=.2193;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
"RTN","DGRPE",75,0)
302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
"RTN","DGRPE",76,0)
303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34;
"RTN","DGRPE",77,0)
303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
"RTN","DGRPE",78,0)
303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35;
"RTN","DGRPE",79,0)
303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2;
"RTN","DGRPE",80,0)
304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;        
"RTN","DGRPE",81,0)
305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371;
"RTN","DGRPE",82,0)
305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
"RTN","DGRPE",83,0)
305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
"RTN","DGRPE",84,0)
305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
"RTN","DGRPE",85,0)
401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
"RTN","DGRPE",86,0)
402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
"RTN","DGRPE",87,0)
501 ;;
"RTN","DGRPE",88,0)
502 ;;.381;.382///NOW;
"RTN","DGRPE",89,0)
503 ;;.383;
"RTN","DGRPE",90,0)
601 ;;Q;
"RTN","DGRPE",91,0)
602 ;;Q;
"RTN","DGRPE",92,0)
603 ;;Q;
"RTN","DGRPE",93,0)
604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
"RTN","DGRPE",94,0)
605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
"RTN","DGRPE",95,0)
606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
"RTN","DGRPE",96,0)
607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
"RTN","DGRPE",97,0)
608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
"RTN","DGRPE",98,0)
AD N DGZ4,DGPC
"RTN","DGRPE",99,0)
 S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10)
"RTN","DGRPE",100,0)
 I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4
"RTN","DGRPE",101,0)
 K DGADD,DGPHONE Q
"RTN","DGRPE",102,0)
DR109 ;Drop through (use same logic as DR203)
"RTN","DGRPE",103,0)
DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;"
"RTN","DGRPE",104,0)
 S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;"
"RTN","DGRPE",105,0)
 Q
"RTN","DGRPE",106,0)
DR111 ;Set DR string for Confidential Address categories
"RTN","DGRPE",107,0)
 S DR(2,2.141)=".01;1//YES;"
"RTN","DGRPE",108,0)
 Q
"RTN","DGRPE",109,0)
DR301 ;set up variables for foreign address
"RTN","DGRPE",110,0)
 N DG3,DG33
"RTN","DGRPE",111,0)
 S DG4=0
"RTN","DGRPE",112,0)
 S DG3=$P($G(^DPT(DFN,.11)),U,10)
"RTN","DGRPE",113,0)
 S DG33=$O(^HL(779.004,"B","USA",""))
"RTN","DGRPE",114,0)
 I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1
"RTN","DGRPE",115,0)
 Q
"RTN","DGRPE",116,0)
PRF ; Write Proof needed for FV
"RTN","DGRPE",117,0)
 W !?4,$C(7),"Proof is required for Filipino vet."
"RTN","DGRPE",118,0)
 Q
"RTN","DGRPE",119,0)
 ;
"RTN","DGRPE",120,0)
SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA
"RTN","DGRPE",121,0)
 ; array with the BOS and component data for the SEQ military service
"RTN","DGRPE",122,0)
 ; episode (1-3)
"RTN","DGRPE",123,0)
 N I,Q,Z
"RTN","DGRPE",124,0)
 K DIPA(32,SEQ)
"RTN","DGRPE",125,0)
 S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
"RTN","DGRPE",126,0)
 S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U)
"RTN","DGRPE",127,0)
 Q
"RTN","DGRPE",128,0)
 ;
"RTN","DGRPE",129,0)
WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will
"RTN","DGRPE",130,0)
 ; be deleted
"RTN","DGRPE",131,0)
 ; Returns Y to skip component if the component should not be asked
"RTN","DGRPE",132,0)
 ;   for this branch of service
"RTN","DGRPE",133,0)
 N Z
"RTN","DGRPE",134,0)
 I '$$CMP(X) S Y="@601"_SEQ
"RTN","DGRPE",135,0)
 S Z=$G(DIPA(32,SEQ))
"RTN","DGRPE",136,0)
 Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
"RTN","DGRPE",137,0)
 ;
"RTN","DGRPE",138,0)
 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
"RTN","DGRPE",139,0)
 Q
"RTN","DGRPE",140,0)
 ;
"RTN","DGRPE",141,0)
CMP(X) ; Function to determine if service component is valid for
"RTN","DGRPE",142,0)
 ; branch of service ien in X   0 = invalid  1 = valid  
"RTN","DGRPE",143,0)
 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
"RTN","DGRPE",144,0)
 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
"RTN","DGRPE",145,0)
 ;
"RTN","DGRPMS")
0^7^B64725384
"RTN","DGRPMS",1,0)
DGRPMS ;ALB/BRM,LBD - MILITARY SERVICE APIS ; 1/31/12 11:14am
"RTN","DGRPMS",2,0)
 ;;5.3;Registration;**451,626,646,673,689,688,797**;Aug 13, 1993;Build 24
"RTN","DGRPMS",3,0)
 ;
"RTN","DGRPMS",4,0)
VALCON1(DFN,IEN,CDATE,FRTO) ; Valid conflict input for OIF/OEF/UNKNOWN OEF/OIF?
"RTN","DGRPMS",5,0)
 ; Need to send the ien of the multiple as well as the DFN and
"RTN","DGRPMS",6,0)
 ; determine the specific conflict area
"RTN","DGRPMS",7,0)
 N Z
"RTN","DGRPMS",8,0)
 S Z=$P("OIF^OEF^UNK",U,+$G(^DPT(DFN,.3215,+IEN,0)))
"RTN","DGRPMS",9,0)
 ;Q:Z="UNK" 1  ; Never need to check this - only entered through HEC
"RTN","DGRPMS",10,0)
 Q $$VALCON(DFN,Z_"-"_IEN,CDATE,FRTO)
"RTN","DGRPMS",11,0)
 ;
"RTN","DGRPMS",12,0)
VALCON(DFN,CNFLCT,CDATE,FRTO,OEIFAIL) ;is this a valid conflict input?
"RTN","DGRPMS",13,0)
 ;
"RTN","DGRPMS",14,0)
 ;INPUT:
"RTN","DGRPMS",15,0)
 ;      FRTO - 0=FRDT 1=TODT  (defaults to FRDT if FRTO="")
"RTN","DGRPMS",16,0)
 ;OUTPUT:
"RTN","DGRPMS",17,0)
 ;      OEIFAIL = 1 for not within MSE for OIF/OEF data (pass by ref)
"RTN","DGRPMS",18,0)
 ;
"RTN","DGRPMS",19,0)
 N RTN,X,Y,FRDT,TODT,CNFLCTV,IGNORE,COMPOW,MSG,DTCHK,CNFLCT2,OEFOIF
"RTN","DGRPMS",20,0)
 S OEIFAIL=0
"RTN","DGRPMS",21,0)
 Q:'$D(DFN) "0^INVALID PATIENT"
"RTN","DGRPMS",22,0)
 Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
"RTN","DGRPMS",23,0)
 Q:'$$VALID^DGRPDT(.CDATE) "0^INVALID DATE"
"RTN","DGRPMS",24,0)
 S FRTO=+$G(FRTO)
"RTN","DGRPMS",25,0)
 I 'FRTO S TODT=$$GETDT(DFN,.CNFLCT),FRDT=CDATE K DGFRDT
"RTN","DGRPMS",26,0)
 E  S FRDT=$$GETDT(DFN,.CNFLCT,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=CDATE K DGFRDT
"RTN","DGRPMS",27,0)
 S DTCHK=$$DTUTIL^DGRPDT(CDATE,$$GETDT(DFN,.CNFLCT,'FRTO),1)
"RTN","DGRPMS",28,0)
 I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) Q DTCHK
"RTN","DGRPMS",29,0)
 I CNFLCT="COMB"!(CNFLCT="POW") D
"RTN","DGRPMS",30,0)
 .S COMPOW=$S(CNFLCT="COMB":1,1:2)
"RTN","DGRPMS",31,0)
 .S CNFLCT2=CNFLCT
"RTN","DGRPMS",32,0)
 .S CNFLCT=$$COMPOW($S($G(DGCOMLOC):$P(DGCOMLOC,"^"),1:$$GETDT(DFN,CNFLCT,3)))
"RTN","DGRPMS",33,0)
 S CNFLCTV=""
"RTN","DGRPMS",34,0)
 I CNFLCT]"" S CNFLCTV=$$CNFLCTDT^DGRPDT(FRDT,$S(FRTO:TODT,1:""),.CNFLCT)
"RTN","DGRPMS",35,0)
 I ('CNFLCTV) D MSG($P(CNFLCTV,"^",2),2,1) Q CNFLCTV  ;dates are not within conflict
"RTN","DGRPMS",36,0)
 ;
"RTN","DGRPMS",37,0)
 S MSG=$S('$G(COMPOW):"Conflict",$G(COMPOW)=2:"POW",1:"Combat")
"RTN","DGRPMS",38,0)
 I FRDT,TODT,'$$B4^DGRPDT(FRDT,TODT,0) D MSG((MSG_" From Date is not Before "_MSG_" To Date"),2,1) Q "0^"_MSG_" From Date is not Before "_MSG_" To Date"
"RTN","DGRPMS",39,0)
 S IGNORE=$S('$P(CNFLCT,"-",2):$P($P($T(@($P(CNFLCT,"-"))),";;",2),"^",FRTO+1),1:"")
"RTN","DGRPMS",40,0)
 S:$G(COMPOW) IGNORE=$P($P($T(@(CNFLCT2)),";;",2),"^",FRTO+1)
"RTN","DGRPMS",41,0)
 ; 
"RTN","DGRPMS",42,0)
 ; Check for overlaps and dates w/in MSE's, except for POW DG*5.3*688
"RTN","DGRPMS",43,0)
 S RTN=1
"RTN","DGRPMS",44,0)
 I $G(COMPOW)'=2 D
"RTN","DGRPMS",45,0)
 . S OEFOIF=$S($P(CNFLCT,"-",2):$P(CNFLCT,"-",2)_U_CNFLCT,1:""),RTN=$$COVRLP2^DGRPDT(DFN,FRDT,TODT,IGNORE,.OEFOIF)
"RTN","DGRPMS",46,0)
 . I 'RTN,$G(OEFOIF),$G(OEFOIF(1)) S OEIFAIL=1
"RTN","DGRPMS",47,0)
 Q:RTN RTN
"RTN","DGRPMS",48,0)
 D MSG($P(RTN,"^",2),2,1)
"RTN","DGRPMS",49,0)
 Q RTN
"RTN","DGRPMS",50,0)
 ;
"RTN","DGRPMS",51,0)
VALMSE(DFN,MDATE,FRTO,FLD) ;is this a valid Military Service Episode date?
"RTN","DGRPMS",52,0)
 ;
"RTN","DGRPMS",53,0)
 ;INPUT:
"RTN","DGRPMS",54,0)
 ;      FRTO - 0=FRDT 1=TODT  (defaults to FRDT if FRTO="")
"RTN","DGRPMS",55,0)
 ;       FLD - MSE field being edited/added (MSL,MSNTL,MSNNTL)
"RTN","DGRPMS",56,0)
 ;             "MSE-"_IEN of MSE in sub-file #2.3216 (DG*5.3*797)
"RTN","DGRPMS",57,0)
 ;
"RTN","DGRPMS",58,0)
 N RTN,X,Y,FRDT,TODT,IGNORE,DTCHK,DUPCHK
"RTN","DGRPMS",59,0)
 Q:'$D(DFN) "0^INVALID PATIENT"
"RTN","DGRPMS",60,0)
 Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
"RTN","DGRPMS",61,0)
 Q:'$$VALID^DGRPDT(.MDATE) "0^INVALID DATE"
"RTN","DGRPMS",62,0)
 S FRTO=+$G(FRTO)
"RTN","DGRPMS",63,0)
 I 'FRTO S FRDT=MDATE,TODT=$$GETDT(DFN,.FLD,FRTO) K DGFRDT
"RTN","DGRPMS",64,0)
 E  S FRDT=$$GETDT(DFN,.FLD,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=MDATE K DGFRDT
"RTN","DGRPMS",65,0)
 S DTCHK=$$DTUTIL^DGRPDT(MDATE,$$GETDT(DFN,.FLD,'FRTO),1)
"RTN","DGRPMS",66,0)
 I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) K DGCOMBR Q DTCHK
"RTN","DGRPMS",67,0)
 ;Check for duplicate Service Entry Date
"RTN","DGRPMS",68,0)
 I 'FRTO,FRDT S DUPCHK=$$DUPCHK(DFN,.FRDT,.FLD) I 'DUPCHK D MSG($P(DUPCHK,"^",2),2,2) Q DUPCHK
"RTN","DGRPMS",69,0)
 I FRTO,FRDT,TODT,'$$B4^DGRPDT(.FRDT,.TODT,0) D MSG("Service Entry Date is not before Service Separation Date",2,1) K DGCOMBR Q "0^Service Entry Date is not before Service Separation Date"
"RTN","DGRPMS",70,0)
 S IGNORE=$P($P($T(@($P(FLD,"-"))),";;",2),"^",FRTO+1)
"RTN","DGRPMS",71,0)
 S RTN=$$OVRLPCHK^DGRPDT(.DFN,.FRDT,.TODT,1,.IGNORE,,$P(FLD,"MSE-",2))
"RTN","DGRPMS",72,0)
 I $G(DGCOMBR)']"" S DGCOMBR=$$GETDT(DFN,.FLD,4)
"RTN","DGRPMS",73,0)
 I RTN,FRTO,$$BRANCH(.DGCOMBR),('$$WWII(DFN,TODT,.FLD)) D MSG("Branch of Service Requires WWII Dates of Service",2,1) K DGCOMBR Q "0^BOS Requires WWII Dates"
"RTN","DGRPMS",74,0)
 K DGCOMBR
"RTN","DGRPMS",75,0)
 Q:RTN RTN
"RTN","DGRPMS",76,0)
 D MSG($P(RTN,"^",2),2,1)
"RTN","DGRPMS",77,0)
 Q RTN
"RTN","DGRPMS",78,0)
 ;
"RTN","DGRPMS",79,0)
BRANCH(DGCOMBR) ;branches of service that require WWII service dates
"RTN","DGRPMS",80,0)
 N BRANCH
"RTN","DGRPMS",81,0)
 Q:'$G(DGCOMBR) 0
"RTN","DGRPMS",82,0)
 S BRANCH=$P(DGCOMBR,"^",2)
"RTN","DGRPMS",83,0)
 Q:BRANCH="MERCHANT SEAMAN" 1
"RTN","DGRPMS",84,0)
 Q:BRANCH="F.COMMONWEALTH" 1
"RTN","DGRPMS",85,0)
 Q:BRANCH="F.GUERILLA" 1
"RTN","DGRPMS",86,0)
 Q:BRANCH="F.SCOUTS NEW" 1
"RTN","DGRPMS",87,0)
 Q:BRANCH="F.SCOUTS OLD" 1
"RTN","DGRPMS",88,0)
 Q 0
"RTN","DGRPMS",89,0)
 ;
"RTN","DGRPMS",90,0)
VALCOMP(DFN,CODE,DGEPI) ; Verify component is consistent with the corresponding
"RTN","DGRPMS",91,0)
 ;  branch of service  Also, branch of service must be entered before
"RTN","DGRPMS",92,0)
 ;  component.
"RTN","DGRPMS",93,0)
 ;  ACTIVATED NATIONAL GUARD (G) only valid for ARMY or AIR FORCE branch
"RTN","DGRPMS",94,0)
 ;  ACTIVATED RESERVE (V) only valid for ARMY, AIR FORCE, MARINES, NAVY
"RTN","DGRPMS",95,0)
 ;                    or COAST GUARD branch
"RTN","DGRPMS",96,0)
 ; DFN = ien of patient in file 2
"RTN","DGRPMS",97,0)
 ; DGEPI = episode # to check (1=LAST, 2=NTL, 3=NNTL)
"RTN","DGRPMS",98,0)
 ; CODE = the component code
"RTN","DGRPMS",99,0)
 ; OUTPUT: 1 if valid component
"RTN","DGRPMS",100,0)
 ;         0 if invalid component or branch of serv missing
"RTN","DGRPMS",101,0)
 N Z
"RTN","DGRPMS",102,0)
 ;Get BOS from MSE multiple .3216 if DGEPI contains "MSE" (DG*5.3*797)
"RTN","DGRPMS",103,0)
 I $G(DGEPI)["MSE" S Z=+$P($G(^DPT(DFN,.3216,+DGEPI,0)),U,3)
"RTN","DGRPMS",104,0)
 E  S Z=+$P($G(^DPT(DFN,.32)),U,DGEPI*5)
"RTN","DGRPMS",105,0)
 I 'Z Q 0  ; Require bos
"RTN","DGRPMS",106,0)
 I CODE="R" Q 1  ; Regular is valid for all
"RTN","DGRPMS",107,0)
 Q:Z=1!(Z=2) 1  ; Army (1)/air force (2) valid for guard and reserves
"RTN","DGRPMS",108,0)
 ; reserves also include navy (3), marines (4), coast guard (5)
"RTN","DGRPMS",109,0)
 I CODE="V" Q $S(Z>2&(Z<6):1,1:0)
"RTN","DGRPMS",110,0)
 ;
"RTN","DGRPMS",111,0)
 Q 0
"RTN","DGRPMS",112,0)
 ;
"RTN","DGRPMS",113,0)
GETDT(DFN,CNFLCT,FRTO) ; get from date, to date, or location from patient file
"RTN","DGRPMS",114,0)
 ;
"RTN","DGRPMS",115,0)
 N CFLDS,CFLD,CNF1,CNF2,RTN1,IENS,FILE
"RTN","DGRPMS",116,0)
 Q:'$D(DFN) ""
"RTN","DGRPMS",117,0)
 Q:'$D(^DPT(DFN)) ""
"RTN","DGRPMS",118,0)
 Q:$G(CNFLCT)="" ""
"RTN","DGRPMS",119,0)
 S:$G(FRTO)="" FRTO=0
"RTN","DGRPMS",120,0)
 S CNF1=$P(CNFLCT,"-"),CNF2=+$P(CNFLCT,"-",2)
"RTN","DGRPMS",121,0)
 ; OEF/OIF/ UNKNOWN OEF/OIF data without a supplied entry in the
"RTN","DGRPMS",122,0)
 ;   multiple cannot be retrieved  OEF-1 indicates an OEF location
"RTN","DGRPMS",123,0)
 ;   stored at the '1' subscript of the .3215 multiple
"RTN","DGRPMS",124,0)
 I "^OEF^OIF^UNK^"[(U_CNF1_U),'CNF2 Q ""
"RTN","DGRPMS",125,0)
 ; MSE data retrieved from .3216 multiple (DG*5.3*797)
"RTN","DGRPMS",126,0)
 I CNF1="MSE",'CNF2 Q ""
"RTN","DGRPMS",127,0)
 S CFLDS=$P($T(@(CNF1)),";;",2) Q:CFLDS']"" ""
"RTN","DGRPMS",128,0)
 S CFLD=$S('FRTO:$P(CFLDS,"^",2),FRTO=1:$P(CFLDS,"^"),1:$P(CFLDS,"^",3))
"RTN","DGRPMS",129,0)
 Q:'CFLD ""
"RTN","DGRPMS",130,0)
 S IENS=DFN_",",FILE=2
"RTN","DGRPMS",131,0)
 ; For MSE set ref to sub-file 2.3216 (DG*5.3*797)
"RTN","DGRPMS",132,0)
 ; For OIF/OEF set ref to sub-file 2.3215
"RTN","DGRPMS",133,0)
 S:CNF2 IENS=CNF2_","_IENS,FILE=$S(CNF1="MSE":2.3216,1:2.3215)
"RTN","DGRPMS",134,0)
 S RTN1=$$GET1^DIQ(FILE,IENS,CFLD,"I")
"RTN","DGRPMS",135,0)
 I FRTO=4 S RTN1=RTN1_"^"_$$EXTERNAL^DILFD(FILE,CFLD,"",RTN1)
"RTN","DGRPMS",136,0)
 Q RTN1
"RTN","DGRPMS",137,0)
 ;
"RTN","DGRPMS",138,0)
WWII(DFN,TODT,FLD) ; was this patient in WWII?
"RTN","DGRPMS",139,0)
 ;  this API assumes the WWII period to be from 12/07/41-12/31/46
"RTN","DGRPMS",140,0)
 ;
"RTN","DGRPMS",141,0)
 N OK,NODE,DATA,WWIIS,WWIIE,PATDT,PATE,PATS
"RTN","DGRPMS",142,0)
 Q:'$G(DFN) "-1^UNKNOWN"
"RTN","DGRPMS",143,0)
 ; Use MSE data from sub-file #2.3216 (DG*5.3*797)
"RTN","DGRPMS",144,0)
 I $G(FLD)["MSE" S NODE(2.3216)=".01,.02"
"RTN","DGRPMS",145,0)
 E  S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
"RTN","DGRPMS",146,0)
 S WWIIS=2411207,WWIIE=2461231
"RTN","DGRPMS",147,0)
 D GETDAT^DGRPDT(DFN,.NODE,.DATA)
"RTN","DGRPMS",148,0)
 S PATDT=$G(FLD) Q:PATDT']"" 0
"RTN","DGRPMS",149,0)
 S PATS=$P($G(DATA(PATDT)),"^"),PATE=$P($G(DATA(PATDT)),"^",2)
"RTN","DGRPMS",150,0)
 S:'$G(TODT) TODT=PATE
"RTN","DGRPMS",151,0)
 S OK=0
"RTN","DGRPMS",152,0)
 S OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,PATS)
"RTN","DGRPMS",153,0)
 S:'OK OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,TODT)
"RTN","DGRPMS",154,0)
 S:'OK OK=$$RWITHIN^DGRPDT(PATS,TODT,WWIIS,WWIIE)
"RTN","DGRPMS",155,0)
 Q $G(OK)
"RTN","DGRPMS",156,0)
DELMSE(DFN,TYPE) ; delete MSE from patient
"RTN","DGRPMS",157,0)
 ;
"RTN","DGRPMS",158,0)
 ; Input: DFN - Internal entry number for the Patient File (#2)
"RTN","DGRPMS",159,0)
 ;       TYPE - 1=Last MSE  2=Next to Last MSE  3=Next to Next to Last
"RTN","DGRPMS",160,0)
 ;
"RTN","DGRPMS",161,0)
 Q:'$G(TYPE)
"RTN","DGRPMS",162,0)
 Q:(('$G(DFN))!'$D(^DPT(DFN)))
"RTN","DGRPMS",163,0)
 N IENS,FDA,X,X1,X2,Y,ZZ,ROOT
"RTN","DGRPMS",164,0)
 S IENS=DFN_",",ROOT="FDA(2,IENS)",X=""
"RTN","DGRPMS",165,0)
 I TYPE=1 F ZZ=.324,.326,.327,.328 S @ROOT@(ZZ)=X
"RTN","DGRPMS",166,0)
 I TYPE=2 F ZZ=.329,.3292,.3293,.3294 S @ROOT@(ZZ)=X
"RTN","DGRPMS",167,0)
 I TYPE=3 F ZZ=.3295,.3297,.3298,.3299 S @ROOT@(ZZ)=X
"RTN","DGRPMS",168,0)
 D FILE^DIE("K","FDA","ERR")
"RTN","DGRPMS",169,0)
 Q
"RTN","DGRPMS",170,0)
 ;
"RTN","DGRPMS",171,0)
COMPOW(VAL) ;convert POW and Combat Location fields
"RTN","DGRPMS",172,0)
 ;
"RTN","DGRPMS",173,0)
 N ABRV
"RTN","DGRPMS",174,0)
 Q:'$G(VAL) ""
"RTN","DGRPMS",175,0)
 S ABRV=$$GET1^DIQ(22,VAL_",",1,"I")
"RTN","DGRPMS",176,0)
 Q:ABRV="WWI" "WWI"
"RTN","DGRPMS",177,0)
 Q:ABRV="WWII-EUROPE" "WWIIE"
"RTN","DGRPMS",178,0)
 Q:ABRV="WWII-PACIFIC" "WWIIP"
"RTN","DGRPMS",179,0)
 Q:ABRV="KOREAN" "KOR"
"RTN","DGRPMS",180,0)
 Q:ABRV="VIETNAM" "VIET"
"RTN","DGRPMS",181,0)
 Q:ABRV="OTHER" "OTHER"
"RTN","DGRPMS",182,0)
 Q:ABRV="PERSIAN GULF" "GULF"
"RTN","DGRPMS",183,0)
 Q:ABRV="YUGOSLAVIA" "YUG"
"RTN","DGRPMS",184,0)
 Q:ABRV="SOMALIA" "SOM"
"RTN","DGRPMS",185,0)
 Q ""
"RTN","DGRPMS",186,0)
 ;
"RTN","DGRPMS",187,0)
FV(X) ;Is this a Filipino Vet branch of service?
"RTN","DGRPMS",188,0)
 ;Added for HVE II (DG*5.3*451)
"RTN","DGRPMS",189,0)
 ;INPUT:  X = IEN Branch of Service file #23
"RTN","DGRPMS",190,0)
 ;OUTPUT: 1 = Filipino Vet BOS (F.COMMONWEALTH, F.GUERILLA, F.SCOUTS NEW)
"RTN","DGRPMS",191,0)
 ;        2 = Filipino Vet BOS (F.SCOUTS OLD)
"RTN","DGRPMS",192,0)
 ;        0 = Not Filipino Vet BOS
"RTN","DGRPMS",193,0)
 N FV
"RTN","DGRPMS",194,0)
 I '$G(X) Q 0
"RTN","DGRPMS",195,0)
 S FV=$P($G(^DIC(23,X,0)),U,1)
"RTN","DGRPMS",196,0)
 Q $S(FV="F.SCOUTS OLD":2,$E(FV,1,2)="F.":1,1:0)
"RTN","DGRPMS",197,0)
 ;
"RTN","DGRPMS",198,0)
FVP ;MUMPS cross-reference "AFV1" on Service Branch [Last] (#.325), "AFV2"
"RTN","DGRPMS",199,0)
 ;on Service Branch [NTL] (#.3291), and "AFV3" on Service Branch [NNTL]
"RTN","DGRPMS",200,0)
 ;(#.3296) in the Patient file #2.  If the Service Branch fields do not
"RTN","DGRPMS",201,0)
 ;contain a Filipino Veteran branch of service, the Filipino Vet Proof
"RTN","DGRPMS",202,0)
 ;field (#.3214) will be deleted.
"RTN","DGRPMS",203,0)
 Q:'$G(DA)
"RTN","DGRPMS",204,0)
 N BOS,MS,FV,IENS,FDA
"RTN","DGRPMS",205,0)
 S MS=$G(^DPT(DA,.32))
"RTN","DGRPMS",206,0)
 F BOS=5,10,15 S FV=$$FV($P(MS,U,BOS)) Q:FV=1
"RTN","DGRPMS",207,0)
 I FV=1 Q  ;Filipino Vet BOS found, quit
"RTN","DGRPMS",208,0)
 ;Delete Filipino Vet Proof
"RTN","DGRPMS",209,0)
 S IENS=DA_",",FDA(2,IENS,.3214)="@"
"RTN","DGRPMS",210,0)
 D FILE^DIE("","FDA")
"RTN","DGRPMS",211,0)
 Q
"RTN","DGRPMS",212,0)
 ;
"RTN","DGRPMS",213,0)
FVP1 ;MUMPS cross-reference "AFV3216" on the Service Branch field (#.03)
"RTN","DGRPMS",214,0)
 ;in the Military Service Episode sub-file (#2.3216) of the Patient
"RTN","DGRPMS",215,0)
 ;file (#2).  If none of the Service Branch fields in the multiple
"RTN","DGRPMS",216,0)
 ;contain a Filipino Veteran branch of service, the Filipino Vet Proof
"RTN","DGRPMS",217,0)
 ;field (#.3214) will be deleted.
"RTN","DGRPMS",218,0)
 ;Added for DG*5.3*797
"RTN","DGRPMS",219,0)
 Q:'$G(DA(1))
"RTN","DGRPMS",220,0)
 N BOS,MS,FV,IENS,FDA
"RTN","DGRPMS",221,0)
 S (FV,MS)=0
"RTN","DGRPMS",222,0)
 F  S MS=$O(^DPT(DA(1),.3216,MS)) Q:'MS!(FV=1)  D
"RTN","DGRPMS",223,0)
 .I $G(DA)=MS Q
"RTN","DGRPMS",224,0)
 .S BOS=$P($G(^DPT(DA(1),.3216,MS,0)),U,3)
"RTN","DGRPMS",225,0)
 .S FV=$$FV(BOS)
"RTN","DGRPMS",226,0)
 I FV=1 Q  ;Filipino Vet BOS found, quit
"RTN","DGRPMS",227,0)
 ;Delete Filipino Vet Proof
"RTN","DGRPMS",228,0)
 S IENS=DA(1)_",",FDA(2,IENS,.3214)="@"
"RTN","DGRPMS",229,0)
 D FILE^DIE("","FDA")
"RTN","DGRPMS",230,0)
 Q
"RTN","DGRPMS",231,0)
 ;
"RTN","DGRPMS",232,0)
DUPCHK(DFN,FRDT,FLD) ; Check for duplicate Service Entry Date
"RTN","DGRPMS",233,0)
 ;INPUT:   DFN = Patient file IEN
"RTN","DGRPMS",234,0)
 ;        FRDT = Service Entry Date being checked
"RTN","DGRPMS",235,0)
 ;         FLD = "MSE-"_IEN of 2.3216 sub-file record
"RTN","DGRPMS",236,0)
 ;OUTPUT:  DUP = Error message if duplicate found
"RTN","DGRPMS",237,0)
 ;           1 = No duplicate found
"RTN","DGRPMS",238,0)
 N MSEIEN,IEN,MSE,DUP
"RTN","DGRPMS",239,0)
 I '$G(DFN) Q 1
"RTN","DGRPMS",240,0)
 I '$G(FRDT) Q 1
"RTN","DGRPMS",241,0)
 S MSEIEN=$P($G(FLD),"MSE-",2) I 'MSEIEN Q 1
"RTN","DGRPMS",242,0)
 ; Get MSE data
"RTN","DGRPMS",243,0)
 D GETMSE^DGMSEUTL(DFN,.MSE) I '$D(MSE) Q 1
"RTN","DGRPMS",244,0)
 S IEN=0 F  S IEN=$O(MSE(IEN)) Q:'IEN  D
"RTN","DGRPMS",245,0)
 .I FRDT=$P(MSE(IEN),"^"),'$D(MSE(IEN,MSEIEN)) S DUP="0^Duplicate Service Entry Date not allowed"
"RTN","DGRPMS",246,0)
 I $D(DUP) Q DUP
"RTN","DGRPMS",247,0)
 Q 1
"RTN","DGRPMS",248,0)
 ;
"RTN","DGRPMS",249,0)
MSG(MSGTXT,LF1,LF2) ; This api will format the output text in order to utilize
"RTN","DGRPMS",250,0)
 ; the EN^DDIOL utility.
"RTN","DGRPMS",251,0)
 ;INPUT:  MSGTXT = Message text to display
"RTN","DGRPMS",252,0)
 ;           LF1 = Number of line feeds to preceed the message
"RTN","DGRPMS",253,0)
 ;           L2F = Number of line feeds to follow the message
"RTN","DGRPMS",254,0)
 ;        
"RTN","DGRPMS",255,0)
 N MSGARY,LFSTR
"RTN","DGRPMS",256,0)
 S $P(LFSTR,"!",50)="!"
"RTN","DGRPMS",257,0)
 S:$G(LF1)'="" MSGARY(.5,"F")=$E(LFSTR,1,(LF1-1))
"RTN","DGRPMS",258,0)
 S MSGARY(1)=MSGTXT
"RTN","DGRPMS",259,0)
 S:$G(LF2)'="" MSGARY(2,"F")=$E(LFSTR,1,LF2)
"RTN","DGRPMS",260,0)
 D EN^DDIOL(.MSGARY)
"RTN","DGRPMS",261,0)
 Q
"RTN","DGRPMS",262,0)
 ;
"RTN","DGRPMS",263,0)
CNFLCT ;; ***  DO NOT REMOVE BELOW CONFLICT FIELD LOCATIONS  ***
"RTN","DGRPMS",264,0)
 ;; FROM DATE^TO DATE
"RTN","DGRPMS",265,0)
WWI ;;
"RTN","DGRPMS",266,0)
WWIIE ;;
"RTN","DGRPMS",267,0)
WWIIP ;;
"RTN","DGRPMS",268,0)
KOR ;;
"RTN","DGRPMS",269,0)
VIET ;;.32104^.32105
"RTN","DGRPMS",270,0)
LEB ;;.3222^.3223
"RTN","DGRPMS",271,0)
GREN ;;.3225^.3226
"RTN","DGRPMS",272,0)
PAN ;;.3228^.3229
"RTN","DGRPMS",273,0)
GULF ;;.322011^.322012
"RTN","DGRPMS",274,0)
SOM ;;.322017^.322018
"RTN","DGRPMS",275,0)
YUG ;;.32202^.322021
"RTN","DGRPMS",276,0)
OEF ;;.02^.03
"RTN","DGRPMS",277,0)
OIF ;;.02^.03
"RTN","DGRPMS",278,0)
UNK ;;.02^.03
"RTN","DGRPMS",279,0)
 ;;
"RTN","DGRPMS",280,0)
 ;;  **BELOW VALUES ARE USED FOR MSE CHECKS - DO NOT REMOVE ***
"RTN","DGRPMS",281,0)
 ;; ENTRY DATE^SEPARATION DATE
"RTN","DGRPMS",282,0)
MSE ;;.01^.02^.03
"RTN","DGRPMS",283,0)
MSL ;;.326^.327^.325
"RTN","DGRPMS",284,0)
MSNTL ;;.3292^.3293^.3291
"RTN","DGRPMS",285,0)
MSNNTL ;;.3297^.3298^.3296
"RTN","DGRPMS",286,0)
 ;;
"RTN","DGRPMS",287,0)
 ;;  **BELOW VALUES ARE USED FOR POW AND COMBAT CHECKS - DO NOT REMOVE
"RTN","DGRPMS",288,0)
 ;; FROM DATE^TO DATE^LOCATION
"RTN","DGRPMS",289,0)
COMB ;;.5293^.5294^.5292
"RTN","DGRPMS",290,0)
POW ;;.527^.528^.526
"RTN","DGRPMS",291,0)
 ;;
"RTN","DGRPP")
0^16^B19131336
"RTN","DGRPP",1,0)
DGRPP ;ALB/MRL,AEG,LBD - REGISTRATION SCREEN PROCESSOR ; 10/21/10 3:55pm
"RTN","DGRPP",2,0)
 ;;5.3;Registration;**92,147,343,404,397,489,689,688,828,797**;Aug 13, 1993;Build 24
"RTN","DGRPP",3,0)
 ;
"RTN","DGRPP",4,0)
 ;DGRPS    : Screen to edit
"RTN","DGRPP",5,0)
 ;DGRPSEL  : If screen 9 (income screening) set to allowable selections
"RTN","DGRPP",6,0)
 ;           (V=Veteran, S=Spouse, D=Dependents)
"RTN","DGRPP",7,0)
 ;DGRPSELT : If screen 9, type selected (V, S, or D or all if none specified)
"RTN","DGRPP",8,0)
 ;DGRPAN   : Selectable items on screen for edit (user input)
"RTN","DGRPP",9,0)
 ;DGRPANP  : Selectable items for print on page footer - i.e. 1-3
"RTN","DGRPP",10,0)
 ;DGRPANN  : Selected item(s) extrapolated (screen_item)
"RTN","DGRPP",11,0)
 ;
"RTN","DGRPP",12,0)
 ;
"RTN","DGRPP",13,0)
EN ;
"RTN","DGRPP",14,0)
 D:'$$BEGUPLD^DGENUPL3(DFN)
"RTN","DGRPP",15,0)
 .D UNLOCK^DGENPTA1(DFN)
"RTN","DGRPP",16,0)
 .D CKUPLOAD^DGENUPL3(DFN)
"RTN","DGRPP",17,0)
 .I $$LOCK^DGENPTA1(DFN)
"RTN","DGRPP",18,0)
 D ENDUPLD^DGENUPL3(DFN)
"RTN","DGRPP",19,0)
 D Q1,WHICH^DGRPP1 W ! K DGRP S DGRPAN="" F I=1:1:$L(DGRPVV(DGRPS)) I $S('DGRPV:1,DGRPS=6:I=1!(I=2)!(I=3),1:0) S:'$E(DGRPVV(DGRPS),I) DGRPAN=DGRPAN_I_","
"RTN","DGRPP",20,0)
 D STR^DGRPP1 F I=$Y:1:20 W !
"RTN","DGRPP",21,0)
 ; remove COPY option DG*5.3*688
"RTN","DGRPP",22,0)
 I ("8^9"[DGRPS),($G(DGEFDT)'=DT) S Z="E" D W W "=ENTER new "_(DGISYR+1)_" data,"
"RTN","DGRPP",23,0)
 S Z="<RET>" D W W " to ",$S(DGRPS<DGRPLAST:"CONTINUE",1:"QUIT"),", "
"RTN","DGRPP",24,0)
 I DGRPAN]"" S Z=DGRPANP D W D
"RTN","DGRPP",25,0)
 . I '$G(DGRPV) W " or " S Z="ALL" D W
"RTN","DGRPP",26,0)
 . W " to "_$S('$G(DGRPV):"EDIT, ",DGRPS=6:"EXPAND, ",1:"")
"RTN","DGRPP",27,0)
 S DGRPOUT=0,Z="^N" D W W " for screen N or " S Z="'^'" D W W " to QUIT" I DGRPSEL=""!(DGRPVV(9)'["0")!+$G(DGRPV) W ": "
"RTN","DGRPP",28,0)
 I DGRPSEL]"" D MOREHLP^DGRPP1
"RTN","DGRPP",29,0)
 G:$E(IOST,1,2)="P-" NEXT  ;RGB/VM 4/28/10 Just go to next screen for non-interactive jobs
"RTN","DGRPP",30,0)
 R DGRPANN:DTIME S:'$T DGRPOUT=1 I DGRPANN']"",'DGRPOUT G NEXT
"RTN","DGRPP",31,0)
 I $E(DGRPANN)="E",$G(DGNOBUCK),("8^9"[DGRPS) D
"RTN","DGRPP",32,0)
 .S DGNOCOPY=1
"RTN","DGRPP",33,0)
 . ; remove COPY option DG*5.3*688
"RTN","DGRPP",34,0)
 .S DGRPANN=U_DGRPS,DGRPVV(9)="000",DGRPVV(8)="00",DGIAINEW=1
"RTN","DGRPP",35,0)
JUMP G JUMP^DGRPP1:DGRPANN?1"^"1N.".".1N I DGRPOUT!(DGRPANN?1"^".E) G Q
"RTN","DGRPP",36,0)
 S (DGRPANN,X)=$$UPPER^DGUTL(DGRPANN)
"RTN","DGRPP",37,0)
 I $E(DGRPANN)="A" S X=DGRPANN,Z="^ALL" D IN^DGHELP I %'=-1 S DGRPANN=DGRPANP
"RTN","DGRPP",38,0)
 I DGRPANN]"",(DGRPSEL[$E(DGRPANN)) S DGRPSELT=$E(DGRPANN),DGRPANN=$P(DGRPANN,DGRPSELT,2) ; save off type, run through all other checks
"RTN","DGRPP",39,0)
 I DGRPANN'?1N.E D ^DGRPH G:DGRPS'=1.1 @("^DGRP"_DGRPS) G:DGRPS=1.1 ^DGRPCADD
"RTN","DGRPP",40,0)
 S DGDR="" F I=1:1 S DGCH=$P(DGRPANN,",",I) Q:DGCH']""!($L(DGCH)>5)  D CHOICE
"RTN","DGRPP",41,0)
 I DGDR']"" D ^DGRPH S X=DGRPS G SCRX
"RTN","DGRPP",42,0)
 D ^DGRPE G QQ:'$D(^DPT(DFN,0)) S X=DGRPS G SCRX
"RTN","DGRPP",43,0)
Q I 'DGELVER D:$S(DGRPOUT:0,'$D(DGRPV):0,'DGRPV:1,1:0) LT^DGRPP1
"RTN","DGRPP",44,0)
 K DGDEP,DGINC,DGINR,DGMTC,DGMTED,DGREL,DGTOT,DGSP
"RTN","DGRPP",45,0)
 K DGCH,DGGTOT,DGIRI,DGPRI,DGRPSE1,DGNOCOPY
"RTN","DGRPP",46,0)
 D SENSCHK
"RTN","DGRPP",47,0)
 I 'DGRPV S DGEDCN=1 D ^DGRPC K DGEDCN
"RTN","DGRPP",48,0)
QQ K DGRPNA,DGRPS,DGRPTYPE,DGRPU,DGRPV,DGRPVV,DGRPW,DGVI,DGVO,DGRPCM,DGELVER,DGRPLAST
"RTN","DGRPP",49,0)
Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGDR,DGRP,DGRPAG,DGRPAN,DGRPANN,DGRPANP,DGRPD,DGRPSEL,DGRPSELT,DGRPVR,DGRPX,DGAAC
"RTN","DGRPP",50,0)
 K DIRUT,DUOUT,DTOUT
"RTN","DGRPP",51,0)
 K DIC,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1 I $D(DFN)#2,DFN]"" S:$D(^DPT(DFN,0)) DA=DFN
"RTN","DGRPP",52,0)
 Q
"RTN","DGRPP",53,0)
 ;
"RTN","DGRPP",54,0)
SENSCHK ; check whether patient record should be made sensitive
"RTN","DGRPP",55,0)
 N ELIG,FLAG,X
"RTN","DGRPP",56,0)
 S ELIG=0,FLAG=0
"RTN","DGRPP",57,0)
 I '$D(^DPT($G(DFN),0)) Q  ; patient not defined
"RTN","DGRPP",58,0)
 I $D(^DGSL(38.1,DFN,0)) Q  ; patient already in dg security log file
"RTN","DGRPP",59,0)
 S X=$S($D(^DPT(DFN,"TYPE")):+^("TYPE"),1:"") I $D(^DG(391,+X,0)),$P(^(0),"^",4) D SEC Q:FLAG
"RTN","DGRPP",60,0)
 F  S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:'ELIG  D  Q:FLAG
"RTN","DGRPP",61,0)
 . S X=$G(^DIC(8,ELIG,0))
"RTN","DGRPP",62,0)
 . I $P(X,"^",12) D SEC
"RTN","DGRPP",63,0)
 Q
"RTN","DGRPP",64,0)
 ;
"RTN","DGRPP",65,0)
SEC ;if patient type says make record sensitive, add to security log file
"RTN","DGRPP",66,0)
 K DD,DO S DIC="^DGSL(38.1,",(X,DINUM)=DFN,DIC(0)="L",DIC("DR")="2///1;3////"_DUZ_";4///NOW;" D FILE^DICN
"RTN","DGRPP",67,0)
 I $D(^DGSL(38.1,DFN,0)) W !!,"===> Record has been classified as sensitive." S FLAG=1
"RTN","DGRPP",68,0)
 K DIC,X,DINUM,DA,DD,DO,Y
"RTN","DGRPP",69,0)
 Q
"RTN","DGRPP",70,0)
 ;
"RTN","DGRPP",71,0)
CHOICE ;parse out which items were selected for edit
"RTN","DGRPP",72,0)
 ;
"RTN","DGRPP",73,0)
 ;DGCH=choice to be parsed (either number or number-number)
"RTN","DGRPP",74,0)
 ;
"RTN","DGRPP",75,0)
 N DGFL S DGFL=0
"RTN","DGRPP",76,0)
 I DGCH["-" Q:DGCH'?1.2N1"-"1.2N!($P(DGCH,"-",2)>17)  F J=$P(DGCH,"-",1):1:$P(DGCH,"-",2) I DGRPAN[(J_",") D:(DGRPS=9) SCR9 I 'DGFL S DGDR=DGDR_(DGRPS*100+J)_","
"RTN","DGRPP",77,0)
 I DGCH'["-",DGCH?1.2N,(DGRPAN[(DGCH_",")) S DGDR=DGDR_(DGRPS*100+DGCH)_","
"RTN","DGRPP",78,0)
 Q
"RTN","DGRPP",79,0)
 ;
"RTN","DGRPP",80,0)
NEXT ;find next available screen...goto
"RTN","DGRPP",81,0)
 I DGRPS=DGRPLAST G Q ;last screen and return...quit
"RTN","DGRPP",82,0)
 S X=DGRPLAST
"RTN","DGRPP",83,0)
 F I=DGRPS+1:1 S J=$E(DGRPVV,I) Q:J']""  I 'J S X=I Q
"RTN","DGRPP",84,0)
 I DGRPS=1 S X=1.1
"RTN","DGRPP",85,0)
SCRX ;goto screen X
"RTN","DGRPP",86,0)
 ;I DGRPLAST=DGRPS,DGRPLAST=X G Q
"RTN","DGRPP",87,0)
 I X[".",X'=1.1 S X=$P(X,".",1)
"RTN","DGRPP",88,0)
 G:X=1.1 ^DGRPCADD
"RTN","DGRPP",89,0)
 G:X'=1.1 @("^DGRP"_X) ;goto next available screen
"RTN","DGRPP",90,0)
 ;
"RTN","DGRPP",91,0)
W ;write highlighted text on screen (if parameter on)
"RTN","DGRPP",92,0)
 I IOST="C-QUME",$L(DGVI)'=2 W Z
"RTN","DGRPP",93,0)
 E  W @DGVI,Z,@DGVO
"RTN","DGRPP",94,0)
 Q
"RTN","DGRPP",95,0)
 ;
"RTN","DGRPP",96,0)
SCR9 ; see if MT is completed.  Allow only selective editing if so
"RTN","DGRPP",97,0)
 I 'DGMTC Q
"RTN","DGRPP",98,0)
 I '$D(DGRPSELT) S:DGMTC=1 DGFL=1 Q  ;if no non-mt dependents
"RTN","DGRPP",99,0)
 I DGRPSELT="S",$D(DGMTC("S")) Q
"RTN","DGRPP",100,0)
 I DGRPSELT="D",$D(DGMTC("D")) Q
"RTN","DGRPP",101,0)
 S DGFL=1
"RTN","DGRPP",102,0)
 Q
"RTN","DGRPV")
0^14^B18200549
"RTN","DGRPV",1,0)
DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD - REGISTRATION DEFINE VARIABLES ON ENTRY ; 6/18/09 6:53pm
"RTN","DGRPV",2,0)
 ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797**;Aug 13, 1993;Build 24
"RTN","DGRPV",3,0)
 ;
"RTN","DGRPV",4,0)
 ;
"RTN","DGRPV",5,0)
 ;set up variables for registration screen processing
"RTN","DGRPV",6,0)
 ;
"RTN","DGRPV",7,0)
 ;DGRPVV   :string of 15 ones and zeros each character corresponding to
"RTN","DGRPV",8,0)
 ;          a particular screen (0 means allow edit, 1 means don't)
"RTN","DGRPV",9,0)
 ;
"RTN","DGRPV",10,0)
 ;DGRPVV(n):where n=screen number.  String of x ones and zeros where
"RTN","DGRPV",11,0)
 ;          x is the number of elements on screen n (0=edit, 1=don't)
"RTN","DGRPV",12,0)
 ;
"RTN","DGRPV",13,0)
 ;DGVI     :Turn on high intensity
"RTN","DGRPV",14,0)
 ;DGVO     :Turn off high intensity
"RTN","DGRPV",15,0)
 ;
"RTN","DGRPV",16,0)
EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS
"RTN","DGRPV",17,0)
 S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity
"RTN","DGRPV",18,0)
 I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X)
"RTN","DGRPV",19,0)
M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
"RTN","DGRPV",20,0)
 S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1)
"RTN","DGRPV",21,0)
MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2
"RTN","DGRPV",22,0)
 ;DG*5.3*797
"RTN","DGRPV",23,0)
 I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN)
"RTN","DGRPV",24,0)
SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",25,0)
 S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",26,0)
 I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10"))
"RTN","DGRPV",27,0)
 ;
"RTN","DGRPV",28,0)
 S DGPH=$P($G(^DPT(DFN,.53)),U)  ;Purple Heart Indicator
"RTN","DGRPV",29,0)
 I $G(DGPRFLG)=1 D
"RTN","DGRPV",30,0)
 . S DGRPVV="000001111111111"
"RTN","DGRPV",31,0)
 E  D
"RTN","DGRPV",32,0)
 . S DGRPVV="000000000000000"
"RTN","DGRPV",33,0)
 S X="5^3^5^2^3^8^4^2^3^2^4^5^5^2^1"
"RTN","DGRPV",34,0)
 F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J))
"RTN","DGRPV",35,0)
 S DGRPVV(1.1)="00"
"RTN","DGRPV",36,0)
 S DGRPVV(2)="00010"
"RTN","DGRPV",37,0)
 I $P($G(^DPT(DFN,.52)),U,9)'="" S $E(DGRPVV(6),4)=1  ;POW status verified, no editing (DG*5.3*688)
"RTN","DGRPV",38,0)
 I $G(DGPH)]"" S $E(DGRPVV(6),8)=1
"RTN","DGRPV",39,0)
 ;
"RTN","DGRPV",40,0)
 F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
"RTN","DGRPV",41,0)
 ;
"RTN","DGRPV",42,0)
 ;-- if patient type is TRICARE then turn off screens 2,4
"RTN","DGRPV",43,0)
 ;
"RTN","DGRPV",44,0)
 ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 
"RTN","DGRPV",45,0)
 ;-- commented the line to allow screens 2 & 4 to display for Tricare
"RTN","DGRPV",46,0)
 ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
"RTN","DGRPV",47,0)
 ;
"RTN","DGRPV",48,0)
 F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
"RTN","DGRPV",49,0)
 I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99)
"RTN","DGRPV",50,0)
 K DIRUT,DUOUT,DTOUT
"RTN","DGRPV",51,0)
 ;
"RTN","DGRPV",52,0)
 ;Fields are numbered screen_item and put in that piece position.
"RTN","DGRPV",53,0)
 ;Because FM does not allow more than 100 pieces on a node, it was
"RTN","DGRPV",54,0)
 ;necessary to start a new node E10 for fields on screens 10 or higher.
"RTN","DGRPV",55,0)
 ;In these instances, the piece position will be screen_item-100 so,
"RTN","DGRPV",56,0)
 ;for example, screen 11, item 2 would be field 112, but piece 12.
"RTN","DGRPV",57,0)
 ;Items on screens <10 will be found on node E.
"RTN","DGRPV",58,0)
 ;
"RTN","DGRPV",59,0)
 F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
"RTN","DGRPV",60,0)
 ;
"RTN","DGRPV",61,0)
 I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip
"RTN","DGRPV",62,0)
 F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPV",63,0)
 S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob
"RTN","DGRPV",64,0)
 I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
"RTN","DGRPV",65,0)
 I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
"RTN","DGRPV",66,0)
 ;
"RTN","DGRPV",67,0)
ELVER ;set up variables for eligibility verification
"RTN","DGRPV",68,0)
 ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
"RTN","DGRPV",69,0)
 ;   and 11 if they're turned on).
"RTN","DGRPV",70,0)
 ;
"RTN","DGRPV",71,0)
 S DGRP(.361)=$G(^DPT(DFN,.361))
"RTN","DGRPV",72,0)
 I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10
"RTN","DGRPV",73,0)
 I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=1000
"RTN","DGRPV",74,0)
 S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
"RTN","DGRPV",75,0)
 I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I
"RTN","DGRPV",76,0)
Q K DGRPSC,DGRPSCE
"RTN","DGRPV",77,0)
 Q
"RTN","DGRPV",78,0)
 ;
"RTN","DGRPV",79,0)
WW ;Write number on screens for display and/or edit (Z=number)
"RTN","DGRPV",80,0)
 W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
"RTN","DGRPV",81,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",82,0)
 I 'DGRPCM&($E(Z)'="[") W Z
"RTN","DGRPV",83,0)
 Q
"RTN","DGRPV",84,0)
 ;
"RTN","DGRPV",85,0)
WW1 ;spacing for screen display (Z=item to print)
"RTN","DGRPV",86,0)
 F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
"RTN","DGRPV",87,0)
 W Z K Z2
"RTN","DGRPV",88,0)
 Q
"RTN","DGRPV",89,0)
 ;
"RTN","DGRPV",90,0)
WW2 ; Write number on screen for fields always selectable
"RTN","DGRPV",91,0)
 W:DGRPW ! S Z="["_Z_"]"
"RTN","DGRPV",92,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",93,0)
 Q
"RTN","VADPT4")
0^5^B42853987
"RTN","VADPT4",1,0)
VADPT4 ;ALB/MRL/MJK,ERC - PATIENT VARIABLES; 12 DEC 1988 ; 10/13/10 4:43pm
"RTN","VADPT4",2,0)
 ;;5.3;Registration;**343,342,528,689,688,790,797**;Aug 13, 1993;Build 24
"RTN","VADPT4",3,0)
7 ;Eligibility [ELIG]
"RTN","VADPT4",4,0)
 F I=.15,.3,.31,.32,.36,.361,"INE","TYPE","VET" S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","VADPT4",5,0)
 S VAZ=$P(VAX(.36),"^",1) S:$D(^DIC(8,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",1))=VAZ
"RTN","VADPT4",6,0)
 S VAX=0 F I=0:0 S VAX=$O(^DPT(DFN,"E",VAX)) Q:VAX'>0  S VAZ=VAX I $D(^DIC(8,+VAZ,0)),+@VAV@($P(VAS,"^"))'=VAZ S VAZ=VAZ_"^"_$P(^DIC(8,+VAZ,0),"^") S @VAV@($P(VAS,"^",1),VAX)=VAZ
"RTN","VADPT4",7,0)
 S VAZ=$P(VAX(.32),"^",3) S:$D(^DIC(21,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",2))=VAZ
"RTN","VADPT4",8,0)
 S VAZ=$S($P(VAX(.3),"^",1)="Y":1,1:0) S:VAZ VAZ=VAZ_"^"_$P(VAX(.3),"^",2) S @VAV@($P(VAS,"^",3))=VAZ
"RTN","VADPT4",9,0)
 S @VAV@($P(VAS,"^",4))=$S(VAX("VET")="Y":1,1:0),VAZ=$S(+$P(VAX(.15),"^",2):0,1:1),@VAV@($P(VAS,"^",5))=VAZ
"RTN","VADPT4",10,0)
 I VAZ F I=1:1:6 S @VAV@($P(VAS,"^",5),I)="" G 71
"RTN","VADPT4",11,0)
 S VAZ=$P(VAX(.15),"^",2),Y=VAZ X ^DD("DD") S @VAV@($P(VAS,"^",5),1)=VAZ_"^"_Y,VAZ=$P(VAX("INE"),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$P("VAMC^REGIONAL OFFICE^RPC","^",VAZ) S @VAV@($P(VAS,"^",5),2)=VAZ
"RTN","VADPT4",12,0)
 S @VAV@($P(VAS,"^",5),3)=$P(VAX("INE"),"^",3),VAZ=$P(VAX("INE"),"^",4) S:$D(^DIC(5,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",5),4)=VAZ
"RTN","VADPT4",13,0)
 S @VAV@($P(VAS,"^",5),5)=$P(VAX("INE"),"^",6),@VAV@($P(VAS,"^",5),6)=$P(VAX(.3),"^",7)
"RTN","VADPT4",14,0)
71 S VAZ=VAX("TYPE") S:$D(^DG(391,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",6))=VAZ
"RTN","VADPT4",15,0)
 S @VAV@($P(VAS,"^",7))=$P(VAX(.31),"^",3),VAZ=$P(VAX(.361),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$S(VAZ="V":"VERIFIED",VAZ="P":"PENDING VERIFICATION",VAZ="R":"PENDING RE-VERIFICATION",1:"") S @VAV@($P(VAS,"^",8))=VAZ
"RTN","VADPT4",16,0)
 I $D(^DPT(DFN,0)) S VAX=$P(^(0),"^",14),VAX=$G(^DG(408.32,+VAX,0)) I VAX]"" S @VAV@($P(VAS,"^",9))=$P(VAX,"^",2)_"^"_$P(VAX,"^",1)
"RTN","VADPT4",17,0)
 Q
"RTN","VADPT4",18,0)
 ;
"RTN","VADPT4",19,0)
8 ;Monetary Benefits [MB]
"RTN","VADPT4",20,0)
 N DGTOTVA
"RTN","VADPT4",21,0)
 S @VAV@($P(VAS,"^",6))=0 ; SSI no longer supported
"RTN","VADPT4",22,0)
 D ALL^DGMTU21(DFN,"V",DT,"I")
"RTN","VADPT4",23,0)
 S VAX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) F I=8,11,13 S @VAV@($S(I=8:$P(VAS,"^",3),I=11:$P(VAS,"^",5),1:$P(VAS,"^",8)))=$S($P(VAX,"^",I)'="":"1^"_$P(VAX,"^",I),1:0)
"RTN","VADPT4",24,0)
 S VAX=$G(^DPT(DFN,.362))
"RTN","VADPT4",25,0)
 S DGTOTVA=$P(VAX,U,20)
"RTN","VADPT4",26,0)
 F I=12,13,14 S @VAV@($S(I=12:$P(VAS,"^",1),(I=13):$P(VAS,"^",2),1:$P(VAS,"^",4)))=$S($P(VAX,"^",I)="Y":1_U_DGTOTVA,1:0)
"RTN","VADPT4",27,0)
 S I=17 S @VAV@($P(VAS,"^",9))=$S($P(VAX,"^",17)="Y":1_U_$P(VAX,U,6),1:0)
"RTN","VADPT4",28,0)
 S VAX=$G(^DPT(DFN,.3)) S @VAV@($P(VAS,"^",7))=$S($P(VAX,"^",11)="Y":1_U_DGTOTVA,1:0)
"RTN","VADPT4",29,0)
 K DGDEP,DGREL,DGINC,DGINR Q
"RTN","VADPT4",30,0)
 ;
"RTN","VADPT4",31,0)
9 ;Service information
"RTN","VADPT4",32,0)
 F I=.32,.321,.3291,.52,.53 S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","VADPT4",33,0)
 D:$D(^DPT(DFN,.3216)) MSDS
"RTN","VADPT4",34,0)
 S VAX("N")=.321 F I=1,2,3 S VAX(3)=I,VAZ=$S($P(VAX(.321),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(1)=$S(I=1:"4^5",I=2:"7^9^8",1:11),VAX(4)=0 D 91
"RTN","VADPT4",35,0)
 S VAX("N")=.52 F I=5,11 S VAX(3)=$S(I=5:4,1:5),VAX(1)=$S(I=5:"7^8",1:"13^14"),VAZ=$S($P(VAX(.52),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91
"RTN","VADPT4",36,0)
 ;Combat Vet
"RTN","VADPT4",37,0)
 S VAX(3)=10,VAX(1)="15",VAZ=$S($P(VAX(.52),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91
"RTN","VADPT4",38,0)
 F I=6,7,8 S @VAV@($P(VAS,"^",I))="" F VAX(1)=1:1:6 S @VAV@($P(VAS,"^",I),VAX(1))=""
"RTN","VADPT4",39,0)
 S VAX("N")=.32,VAZ=$S($P(VAX(.32),"^",5)]"":1,1:0),@VAV@($P(VAS,"^",6))=VAZ I VAZ,$P(VAX(.32),"^",19)="Y" S VAZ=1,@VAV@($P(VAS,"^",7))=VAZ I VAZ,$P(VAX(.32),"^",20)="Y" S @VAV@($P(VAS,"^",8))=1
"RTN","VADPT4",40,0)
 F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=$S(I=6:"6^7",I=7:"11^12",1:"16^17"),VAX(4)=3 D 91
"RTN","VADPT4",41,0)
 S VAX("N")=.3291
"RTN","VADPT4",42,0)
 F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=I-5,VAX(4)=6 D 94
"RTN","VADPT4",43,0)
 S VAX("N")=.53,VAX(3)=9,VAX(1)="2^3",VAZ=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":1,1:0),@VAV@($P(VAS,U,VAX(3)))=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":0,1:"") I VAZ S VAX(4)=0 D 93
"RTN","VADPT4",44,0)
 S VAX("N")=.3215,VAZ=$$GET^DGENOEIF(DFN,.VAZ,1)
"RTN","VADPT4",45,0)
 ;OEF/OIF
"RTN","VADPT4",46,0)
 F I=11,12,13 S @VAV@(I)=+$G(VAZ($P("OIF^OEF^UNK",U,I-10),"COUNT"))
"RTN","VADPT4",47,0)
 S VAX(2)=11
"RTN","VADPT4",48,0)
 F I="OIF","OEF","UNK" S VAX=0 F  S VAX=$O(VAZ(I,VAX)) S:'VAX VAX(2)=VAX(2)+1 Q:'VAX  S VAX(3)=0 D
"RTN","VADPT4",49,0)
 . N Z
"RTN","VADPT4",50,0)
 . F VAX(1)="LOC","FR","TO" S VAX(3)=VAX(3)+1,Z=$G(VAZ(I,VAX,VAX(1))),@VAV@(VAX(2),VAX,VAX(3))=Z D 95
"RTN","VADPT4",51,0)
 ;SHAD - added with DG*5.3*688
"RTN","VADPT4",52,0)
 S VAX(3)=14,VAZ=$S($P(VAX(.321),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S @VAV@($P(VAS,U,VAX(3)),1)=$S($P(VAX(.321),U,15)=1:"1^YES",1:"0^NO")
"RTN","VADPT4",53,0)
 Q
"RTN","VADPT4",54,0)
 ;
"RTN","VADPT4",55,0)
91 ;date fields
"RTN","VADPT4",56,0)
 F VAX(2)=1:1 S VAX(4)=VAX(4)+1,X=+$P(VAX(1),"^",VAX(2)) Q:'X  S X=$P(VAX(VAX("N")),"^",X),VAZ=X,Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$S(VAZ]"":VAZ_"^"_Y,1:"")
"RTN","VADPT4",57,0)
 Q:VAX(3)=1!(VAX(3)=9)!(VAX(3)=10)
"RTN","VADPT4",58,0)
 ;some sets of codes
"RTN","VADPT4",59,0)
 I VAX(3)=2 S @VAV@($P(VAS,"^",2),4)=$P(VAX(.321),"^",10) S (X,VAZ)=$P(VAX(.321),"^",13) S:X]"" VAZ=VAZ_"^"_$S(X="K":"KOREAN DMZ",1:"VIETNAM") S @VAV@($P(VAS,"^",2),5)=VAZ Q
"RTN","VADPT4",60,0)
 I VAX(3)<4 S X=$P(VAX(.321),"^",12),VAZ=X D
"RTN","VADPT4",61,0)
 .S:X]"" VAZ=VAZ_"^"_$S(X="2":"HIROSHIMA/NAGASAKI",X="3":"ATMOSPHERIC NUCLEAR TESTING",X="4":"H/N AND ATMOSPHERIC TESTING",X="5":"UNDERGROUND NUCLEAR TESTING",X="6":"EXPOSURE AT NUCLEAR FACILITY",1:"OTHER")
"RTN","VADPT4",62,0)
 .S @VAV@($P(VAS,"^",3),2)=VAZ Q
"RTN","VADPT4",63,0)
 ;POW, combat locations
"RTN","VADPT4",64,0)
 I VAX(3)<6 S X=$P(VAX(VAX("N")),"^",$S(VAX(3)=4:6,1:12)),VAZ=X S:$D(^DIC(22,+X,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",VAX(3)),3)=VAZ Q
"RTN","VADPT4",65,0)
 ;service episodes
"RTN","VADPT4",66,0)
 S X=$S(VAX(3)=6:5,VAX(3)=7:10,1:15),VAX(2)=0 F VAX(5)=X,X+3,X-1 S VAX(2)=VAX(2)+1,VAZ=$P(VAX(VAX("N")),"^",VAX(5)),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=VAZ I "^4^5^9^10^14^15^"[("^"_VAX(5)_"^"),+VAZ D 92
"RTN","VADPT4",67,0)
 Q
"RTN","VADPT4",68,0)
92 ;pointers to Branch of Service (23) and Type Discharge (25)
"RTN","VADPT4",69,0)
 S VAX(6)="^DIC("_$S('(VAX(5)#5):23,1:25)_","_+VAZ_",0)" I $D(@(VAX(6))) S VAZ=$P(^(0),"^",1),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=@VAV@($P(VAS,"^",VAX(3)),VAX(2))_"^"_VAZ
"RTN","VADPT4",70,0)
 Q
"RTN","VADPT4",71,0)
93 ;Purple Heart
"RTN","VADPT4",72,0)
 NEW VAFILE,VAIENS,VAFLDS,VAARR,VAI
"RTN","VADPT4",73,0)
 S VAFILE=2,VAIENS=DFN_",",VAFLDS=".532;.533"
"RTN","VADPT4",74,0)
 D GETS^DIQ(VAFILE,VAIENS,VAFLDS,"IEN","VAARR")
"RTN","VADPT4",75,0)
 F VAI=1:1 S VAFLDS(VAI)=$P(VAFLDS,";",VAI) Q:VAFLDS(VAI)=""  D
"RTN","VADPT4",76,0)
 . I '$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I")),'$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E")) S @VAV@($P(VAS,"^",VAX(3)),VAI)=""
"RTN","VADPT4",77,0)
 . E  S @VAV@($P(VAS,U,VAX(3)),VAI)=$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I"))_"^"_$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E"))
"RTN","VADPT4",78,0)
 Q
"RTN","VADPT4",79,0)
94 ;more military service
"RTN","VADPT4",80,0)
 N VAARR,VAIENS,VAFLDS
"RTN","VADPT4",81,0)
 S VAIENS=DFN_",",VAFLDS=".3291"_VAX(1)
"RTN","VADPT4",82,0)
 D GETS^DIQ(2,VAIENS,VAFLDS,"IEN","VAARR")
"RTN","VADPT4",83,0)
 I $G(VAARR(2,VAIENS,VAFLDS,"I"))'="" D
"RTN","VADPT4",84,0)
 . S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$G(VAARR(2,VAIENS,VAFLDS,"I"))_"^"_$G(VAARR(2,VAIENS,VAFLDS,"E"))
"RTN","VADPT4",85,0)
 Q
"RTN","VADPT4",86,0)
 ;
"RTN","VADPT4",87,0)
95 ;OEF/OIF
"RTN","VADPT4",88,0)
 N X,Y
"RTN","VADPT4",89,0)
 I VAX(3)=1 S $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=$$EXTERNAL^DILFD(2.3215,.01,"",Z)
"RTN","VADPT4",90,0)
 I VAX(3)=2!(VAX(3)=3) S Y=Z X ^DD("DD") S:Y'="" $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=Y
"RTN","VADPT4",91,0)
 Q
"RTN","VADPT4",92,0)
 ;
"RTN","VADPT4",93,0)
MSDS ;Returns latest service episodes from ESR sourced data
"RTN","VADPT4",94,0)
 N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB
"RTN","VADPT4",95,0)
 S COUNT=0,EDATE=""
"RTN","VADPT4",96,0)
 ;Clear military service discharge, branch, start, end and number info
"RTN","VADPT4",97,0)
 F I=4:1:20 S $P(VAX(.32),U,I)=""
"RTN","VADPT4",98,0)
 ;Clear military service component info
"RTN","VADPT4",99,0)
 F I=1:1:3 S $P(VAX(.3291),U,I)=""
"RTN","VADPT4",100,0)
 ;Scan back for three most recent service episodes
"RTN","VADPT4",101,0)
 F  S EDATE=$O(^DPT(DFN,.3216,"B",EDATE),-1) Q:'EDATE  D  Q:COUNT'<3
"RTN","VADPT4",102,0)
 .S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
"RTN","VADPT4",103,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
"RTN","VADPT4",104,0)
 .S COUNT=COUNT+1,SDATE=$P(EDATA,U,2)
"RTN","VADPT4",105,0)
 .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
"RTN","VADPT4",106,0)
 .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
"RTN","VADPT4",107,0)
 .;SL = 4, SNL = 9 or SNNL = 14
"RTN","VADPT4",108,0)
 .S SUB=(COUNT*5)-1
"RTN","VADPT4",109,0)
 .S $P(VAX(.32),U,SUB)=DTYP
"RTN","VADPT4",110,0)
 .S $P(VAX(.32),U,SUB+1)=BRANCH
"RTN","VADPT4",111,0)
 .S $P(VAX(.32),U,SUB+2)=EDATE
"RTN","VADPT4",112,0)
 .S $P(VAX(.32),U,SUB+3)=SDATE
"RTN","VADPT4",113,0)
 .S $P(VAX(.32),U,SUB+4)=SERVNO
"RTN","VADPT4",114,0)
 .S $P(VAX(.3291),U,COUNT)=COMP
"RTN","VADPT4",115,0)
 .S:SUB=9 $P(VAX(.32),U,19)="Y"
"RTN","VADPT4",116,0)
 .S:SUB=14 $P(VAX(.32),U,20)="Y"
"RTN","VADPT4",117,0)
 Q
"RTN","VAFCPDT2")
0^34^B26407080
"RTN","VAFCPDT2",1,0)
VAFCPDT2 ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ; 1/6/11 3:57pm
"RTN","VAFCPDT2",2,0)
 ;;5.3;Registration;**414,505,627,697,797**;Aug 13, 1993;Build 24
"RTN","VAFCPDT2",3,0)
 ;Reference to ^MPIF(984.9,"C" supported by IA #3298
"RTN","VAFCPDT2",4,0)
 ;
"RTN","VAFCPDT2",5,0)
CMORHIS ;Find CMOR History
"RTN","VAFCPDT2",6,0)
 I '$O(^DPT(DFN,"MPICMOR",0)) G CMORCHG
"RTN","VAFCPDT2",7,0)
 I $Y+4>IOSL&($E(IOST,1,2)="C-") D  Q:QFLG
"RTN","VAFCPDT2",8,0)
 .S LNQ=22 D SS^VAFCPDAT Q:QFLG
"RTN","VAFCPDT2",9,0)
 .W @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2
"RTN","VAFCPDT2",10,0)
 D CHISHDR
"RTN","VAFCPDT2",11,0)
 S HIS=0 F  S HIS=$O(^DPT(DFN,"MPICMOR",HIS)) Q:'HIS  D  Q:QFLG
"RTN","VAFCPDT2",12,0)
 .S DIC=2,DR="993",DR(2.0993)=".01;3",DA=DFN,DA(2.0993)=HIS
"RTN","VAFCPDT2",13,0)
 .S DIQ(0)="E",DIQ="CMORNODE"
"RTN","VAFCPDT2",14,0)
 .D EN^DIQ1 K DIC,DR,DA,DIQ
"RTN","VAFCPDT2",15,0)
 .S HISCMOR=$G(CMORNODE(2.0993,HIS,.01,"E"))
"RTN","VAFCPDT2",16,0)
 .I +HISCMOR S HISCMOR=$$GET1^DIQ(4,HISCMOR,.01)
"RTN","VAFCPDT2",17,0)
 .S CHGDT=$G(CMORNODE(2.0993,HIS,3,"E"))
"RTN","VAFCPDT2",18,0)
 .I $Y+3>IOSL&($E(IOST,1,2)="C-") D  Q:QFLG
"RTN","VAFCPDT2",19,0)
 ..S LNQ=22 D SS^VAFCPDAT Q:QFLG
"RTN","VAFCPDT2",20,0)
 ..W @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2 D CHISHDR
"RTN","VAFCPDT2",21,0)
 .W !,$P(CHGDT,"@"),?12," - CMOR changed from ",HISCMOR
"RTN","VAFCPDT2",22,0)
 ;
"RTN","VAFCPDT2",23,0)
CMORCHG ;Find CMOR change request
"RTN","VAFCPDT2",24,0)
 I '$O(^MPIF(984.9,"C",DFN,0)) G EXT
"RTN","VAFCPDT2",25,0)
 I $Y+4>IOSL&($E(IOST,1,2)="C-") D  Q:QFLG
"RTN","VAFCPDT2",26,0)
 .S LNQ=22 D SS^VAFCPDAT Q:QFLG
"RTN","VAFCPDT2",27,0)
 .W @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2
"RTN","VAFCPDT2",28,0)
 D CCHGHDR
"RTN","VAFCPDT2",29,0)
 S CHG=0 F  S CHG=$O(^MPIF(984.9,"C",DFN,CHG)) Q:'CHG  D  Q:QFLG
"RTN","VAFCPDT2",30,0)
 .S DIC=984.9,DA=CHG,DR=".01;.03;.06;.07;.08;1.03",DIQ="CHGNODE"
"RTN","VAFCPDT2",31,0)
 .S DIQ(0)="EI" D EN^DIQ1 K DIC,DA,DR,DIQ
"RTN","VAFCPDT2",32,0)
 .S CHGNUM=$G(CHGNODE(984.9,CHG,.01,"E"))
"RTN","VAFCPDT2",33,0)
 .S CHGDT=$G(CHGNODE(984.9,CHG,.03,"E"))
"RTN","VAFCPDT2",34,0)
 .S TMSG=$G(CHGNODE(984.9,CHG,.08,"E"))
"RTN","VAFCPDT2",35,0)
 .S TREQ=$G(CHGNODE(984.9,CHG,1.03,"E"))
"RTN","VAFCPDT2",36,0)
 .S SITE=$G(CHGNODE(984.9,CHG,.07,"E"))
"RTN","VAFCPDT2",37,0)
 .S STATUS=$G(CHGNODE(984.9,CHG,.06,"E"))
"RTN","VAFCPDT2",38,0)
 .I $Y+4>IOSL&($E(IOST,1,2)="C-") D  Q:QFLG
"RTN","VAFCPDT2",39,0)
 ..S LNQ=22 D SS^VAFCPDAT Q:QFLG
"RTN","VAFCPDT2",40,0)
 ..W @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2 D CCHGHDR
"RTN","VAFCPDT2",41,0)
 .W !,"REQUEST #",CHGNUM," - ",TMSG," ",CHGDT
"RTN","VAFCPDT2",42,0)
 .W !?4,"Type of Request: ",TREQ," ",SITE
"RTN","VAFCPDT2",43,0)
 .W !?4,"Status : ",STATUS,!
"RTN","VAFCPDT2",44,0)
 ;
"RTN","VAFCPDT2",45,0)
EXT ;Extended patient demographic data
"RTN","VAFCPDT2",46,0)
 I $E(IOST,1,2)="C-" D  Q:QFLG
"RTN","VAFCPDT2",47,0)
 .S LNQ=22 D SS^VAFCPDAT Q:QFLG
"RTN","VAFCPDT2",48,0)
 .W @IOF
"RTN","VAFCPDT2",49,0)
 I QFLG=1 G QUIT^VAFCPDAT
"RTN","VAFCPDT2",50,0)
 W !!,"Additional DPT Data for: ",NAME,"  (DFN #",DFN,")",!,LN2
"RTN","VAFCPDT2",51,0)
 S DA=DFN,DIC=2,DIQ="XDATA",DIQ(0)="EI"
"RTN","VAFCPDT2",52,0)
 S DR=".05;.08;.092;.093;.219;.2401;.2402;.2403;.211;.302;.323;.341;.331;.361;1901;.325;.328;.326;.327;.097;.525"
"RTN","VAFCPDT2",53,0)
 N COB,SOB,FNM,MNM,MMNM,NOK,NOKN,DESIG,EMER,ELIG,VET,SRVBR,SRVNUM,SRVEDT,SRVSDT,SRVCPCT,POSRVC,FILEDT,MARS,RELP,POW,NODE,MSD
"RTN","VAFCPDT2",54,0)
 D EN^DIQ1 K DIC,DA,DR,DIQ
"RTN","VAFCPDT2",55,0)
 S COB=$G(XDATA(2,DFN,.092,"E")),SOB=$G(XDATA(2,DFN,.093,"E"))
"RTN","VAFCPDT2",56,0)
 S FILEDT=$G(XDATA(2,DFN,.097,"E")),FNM=$G(XDATA(2,DFN,.2401,"E"))
"RTN","VAFCPDT2",57,0)
 S MNM=$G(XDATA(2,DFN,.2402,"E")),MMNM=$G(XDATA(2,DFN,.2403,"E"))
"RTN","VAFCPDT2",58,0)
 S NOK=$G(XDATA(2,DFN,.211,"E")),DESIG=$G(XDATA(2,DFN,.341,"E"))
"RTN","VAFCPDT2",59,0)
 S EMER=$G(XDATA(2,DFN,.331,"E"))
"RTN","VAFCPDT2",60,0)
 S ELIG=$G(XDATA(2,DFN,.361,"E")),VET=$G(XDATA(2,DFN,1901,"E"))
"RTN","VAFCPDT2",61,0)
 S SRVBR=$G(XDATA(2,DFN,.325,"E")),SRVNUM=$G(XDATA(2,DFN,.328,"E"))
"RTN","VAFCPDT2",62,0)
 S SRVEDT=$G(XDATA(2,DFN,.326,"E")),SRVSDT=$G(XDATA(2,DFN,.327,"E"))
"RTN","VAFCPDT2",63,0)
 S MARS=$G(XDATA(2,DFN,.05,"E")),RELP=$G(XDATA(2,DFN,.08,"E"))
"RTN","VAFCPDT2",64,0)
 S POSRVC=$G(XDATA(2,DFN,.323,"E")),SRVCPCT=$G(XDATA(2,DFN,.302,"E"))
"RTN","VAFCPDT2",65,0)
 S NOKN=$G(XDATA(2,DFN,.219,"E")),POW=$G(XDATA(2,DFN,.525,"E"))
"RTN","VAFCPDT2",66,0)
 ;
"RTN","VAFCPDT2",67,0)
 W !,"PLACE OF BIRTH [CITY]",?31,": ",COB
"RTN","VAFCPDT2",68,0)
 W !,"PLACE OF BIRTH [STATE]",?31,": ",SOB
"RTN","VAFCPDT2",69,0)
 W !,"FATHER'S NAME",?31,": ",FNM
"RTN","VAFCPDT2",70,0)
 W !,"MOTHER'S NAME",?31,": ",MNM
"RTN","VAFCPDT2",71,0)
 W !,"MOTHER'S MAIDEN NAME",?31,": ",MMNM
"RTN","VAFCPDT2",72,0)
 W !,"NAME OF PRIMARY NEXT OF KIN",?31,": ",NOK
"RTN","VAFCPDT2",73,0)
 W !,"NEXT OF KIN PHONE NUMBER",?31,": ",NOKN
"RTN","VAFCPDT2",74,0)
 W !,"NAME OF DESIGNEE",?31,": ",DESIG
"RTN","VAFCPDT2",75,0)
 W !,"EMERGENCY NAME",?31,": ",EMER
"RTN","VAFCPDT2",76,0)
 W !,"MARITAL STATUS",?31,": ",MARS
"RTN","VAFCPDT2",77,0)
 W !,"RELIGIOUS PREFERENCE",?31,": ",RELP
"RTN","VAFCPDT2",78,0)
 ;
"RTN","VAFCPDT2",79,0)
 D DEM^VADPT
"RTN","VAFCPDT2",80,0)
 ;ETHNICITY info
"RTN","VAFCPDT2",81,0)
 I $G(VADM(11,1)) W !,"ETHNICITY INFORMATION",?31,": ",$P(VADM(11,1),"^",2)
"RTN","VAFCPDT2",82,0)
 ;
"RTN","VAFCPDT2",83,0)
 ;RACE multiple
"RTN","VAFCPDT2",84,0)
 I $O(VADM(12,0)) D
"RTN","VAFCPDT2",85,0)
 .W !,"RACE INFORMATION (multiple):"
"RTN","VAFCPDT2",86,0)
 .S RACEMUL=0 F  S RACEMUL=$O(VADM(12,RACEMUL)) Q:'RACEMUL  W !?3,$P(VADM(12,RACEMUL),"^",2)
"RTN","VAFCPDT2",87,0)
 ;
"RTN","VAFCPDT2",88,0)
 W !,"PRIMARY ELIGIBILITY CODE",?31,": ",ELIG
"RTN","VAFCPDT2",89,0)
 W !,"VETERAN (Y/N)?",?31,": ",VET
"RTN","VAFCPDT2",90,0)
 W !,"SERVICE CONNECTED PERCENT",?31,": ",SRVCPCT
"RTN","VAFCPDT2",91,0)
 W !,"PERIOD OF SERVICE",?31,": ",POSRVC
"RTN","VAFCPDT2",92,0)
 W !,"POW STATUS INDICATED?",?31,": ",POW
"RTN","VAFCPDT2",93,0)
 ;
"RTN","VAFCPDT2",94,0)
 ;Military Service Data multiple
"RTN","VAFCPDT2",95,0)
 I $O(^DPT(DFN,.3216,0)) D
"RTN","VAFCPDT2",96,0)
 .W !,"MILITARY SERVICE (multiple):"
"RTN","VAFCPDT2",97,0)
 .W !,"Service Branch   Service #   Entry DT       Separation DT"
"RTN","VAFCPDT2",98,0)
 .W !,"---------------------------------------------------------"
"RTN","VAFCPDT2",99,0)
 .K MSDARR
"RTN","VAFCPDT2",100,0)
 .S MSD=0 F  S MSD=$O(^DPT(DFN,.3216,MSD)) Q:'MSD  D
"RTN","VAFCPDT2",101,0)
 ..S NODE=^DPT(DFN,.3216,MSD,0)
"RTN","VAFCPDT2",102,0)
 ..S SRVEDT=$P(NODE,"^"),SRVSDT=$P(NODE,"^",2),SRVNUM=$P(NODE,"^",5),SRVBR=$$GET1^DIQ(23,$P(NODE,"^",3),.01)
"RTN","VAFCPDT2",103,0)
 ..S MSDARR(-SRVEDT)=SRVSDT_"^"_SRVNUM_"^"_SRVBR
"RTN","VAFCPDT2",104,0)
 .S SRVEDT="" F  S SRVEDT=$O(MSDARR(SRVEDT)) Q:'SRVEDT  D
"RTN","VAFCPDT2",105,0)
 ..W !?0,$P(MSDARR(SRVEDT),"^",3),?17,$P(MSDARR(SRVEDT),"^",2),?29,$$FMTE^XLFDT($P(SRVEDT,"-",2)),?44,$$FMTE^XLFDT(+MSDARR(SRVEDT))
"RTN","VAFCPDT2",106,0)
 ;
"RTN","VAFCPDT2",107,0)
 ;ALIAS multiple
"RTN","VAFCPDT2",108,0)
 I $O(^DPT(DFN,.01,0)) D 
"RTN","VAFCPDT2",109,0)
 .W !,"ALIAS (multiple):"
"RTN","VAFCPDT2",110,0)
 .S ALIAS=0 F  S ALIAS=$O(^DPT(DFN,.01,ALIAS)) Q:'ALIAS  W !?3,$E($P(^DPT(DFN,.01,ALIAS,0),"^"),1,30),?35,"SSN: "_$P($G(^DPT(DFN,.01,ALIAS,0)),"^",2)
"RTN","VAFCPDT2",111,0)
 ;
"RTN","VAFCPDT2",112,0)
 W !,"DATE ENTERED IN PATIENT FILE",?31,": ",FILEDT
"RTN","VAFCPDT2",113,0)
 ;
"RTN","VAFCPDT2",114,0)
 K ALIAS,XDATA,CHG,CHGNUM,CHGDT,TMSG,TREQ,SITE,STATUS,HIS,HISCMOR,CMORNODE,CHGNODE,RACEMUL,VADM,MSDARR
"RTN","VAFCPDT2",115,0)
 Q
"RTN","VAFCPDT2",116,0)
 ;
"RTN","VAFCPDT2",117,0)
CHISHDR W !!,"CMOR History:",!,"--------------"
"RTN","VAFCPDT2",118,0)
 Q
"RTN","VAFCPDT2",119,0)
CCHGHDR W !!,"CMOR Change Request History:",!,"----------------------------"
"RTN","VAFCPDT2",120,0)
 Q
"RTN","VAFHLZM1")
0^2^B67564189
"RTN","VAFHLZM1",1,0)
VAFHLZM1 ;BAY/JAT,PJH - Create HL7 Military History segment (ZMH) Cont ; 2/3/09 3:49pm
"RTN","VAFHLZM1",2,0)
 ;;5.3;Registration;**314,673,797**;Aug 13, 1993;Build 24
"RTN","VAFHLZM1",3,0)
 ;
"RTN","VAFHLZM1",4,0)
 ; This routine creates HL7 VA-specific Military History ("ZMH") segments
"RTN","VAFHLZM1",5,0)
 ; It is a continuation of VAFHLZMH and uses those variables.
"RTN","VAFHLZM1",6,0)
 ;
"RTN","VAFHLZM1",7,0)
 Q
"RTN","VAFHLZM1",8,0)
ENTER ;
"RTN","VAFHLZM1",9,0)
 N VAFSETID  ;seg setid
"RTN","VAFHLZM1",10,0)
 S VAFSETID=0
"RTN","VAFHLZM1",11,0)
 N VAFNUM
"RTN","VAFHLZM1",12,0)
 ;build segments as requested in VAFTYPE         
"RTN","VAFHLZM1",13,0)
 F VAFX=1:1 S VAFZ=$P(VAFTYPE,",",VAFX) Q:VAFZ=""  D
"RTN","VAFHLZM1",14,0)
 .S VAFY=""
"RTN","VAFHLZM1",15,0)
 .S VAFINDX=(VAFINDX\1)+1
"RTN","VAFHLZM1",16,0)
 .S VAFSETID=VAFSETID+1
"RTN","VAFHLZM1",17,0)
 .S $P(VAFY,VAFHLS,1)=VAFSETID
"RTN","VAFHLZM1",18,0)
 .S VAFTAG=$S(VAFZ="*":"MSDS",VAFZ=1:"SL",VAFZ=2:"SNL",VAFZ=3:"SNNL",VAFZ=4:"POW",VAFZ=5:"COMB",VAFZ=6:"VIET",VAFZ=7:"LEBA",VAFZ=8:"GREN",VAFZ=9:"PANA",VAFZ=10:"GULF",VAFZ=11:"SOMA",VAFZ=12:"YUGO",VAFZ=13:"PH",VAFZ=14:"OEIF",1:"NOSEG")
"RTN","VAFHLZM1",19,0)
 .D @VAFTAG
"RTN","VAFHLZM1",20,0)
 .;if mult episodes, add decimal to output array subscript (Ex: 14.001)
"RTN","VAFHLZM1",21,0)
 .I $D(VAFY(2)) D
"RTN","VAFHLZM1",22,0)
 ..S VAFNUM=0
"RTN","VAFHLZM1",23,0)
 ..F  S VAFNUM=$O(VAFY(VAFNUM)) Q:'$G(VAFNUM)  D
"RTN","VAFHLZM1",24,0)
 ...S VAFINDX=VAFINDX+.001
"RTN","VAFHLZM1",25,0)
 ...;if >1 conflict then increment seg setid
"RTN","VAFHLZM1",26,0)
 ...I VAFNUM>1 S VAFSETID=VAFSETID+1 S $P(VAFY(VAFNUM),VAFHLS,1)=VAFSETID
"RTN","VAFHLZM1",27,0)
 ...S @VAFARRAY@(VAFINDX,0)="ZMH"_VAFHLS_$G(VAFY(VAFNUM))
"RTN","VAFHLZM1",28,0)
 .;if not mult episodes
"RTN","VAFHLZM1",29,0)
 .I '$D(VAFY(2)) S @VAFARRAY@(VAFINDX,0)="ZMH"_VAFHLS_$G(VAFY)
"RTN","VAFHLZM1",30,0)
 .K VAFY
"RTN","VAFHLZM1",31,0)
 Q
"RTN","VAFHLZM1",32,0)
SL ; last Service branch
"RTN","VAFHLZM1",33,0)
 S $P(VAFY,VAFHLS,2)="SL"
"RTN","VAFHLZM1",34,0)
 N VAF325,VAF328,VAF324,VAF326,VAF327,VAFSCL
"RTN","VAFHLZM1",35,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",36,0)
 .S VAF325=$P(VAF32N,U,5) S VAF325=$S(VAF325:$P($G(^DIC(23,VAF325,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",37,0)
 .S VAF328=$P(VAF32N,U,8) I VAF328="" S VAF328=VAFHLQ
"RTN","VAFHLZM1",38,0)
 .S VAF324=$P(VAF32N,U,4) S VAF324=$S(VAF324:$P($G(^DIC(25,VAF324,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",39,0)
 .; Service branch~Service number~Service discharge type
"RTN","VAFHLZM1",40,0)
 .S $P(VAFY,VAFHLS,3)=VAF325_$E(VAFHLC)_VAF328_$E(VAFHLC)_VAF324
"RTN","VAFHLZM1",41,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",42,0)
 .S VAF326=$P(VAF32N,U,6) S VAF326=$S(VAF326:$$HLDATE^HLFNC(VAF326),1:VAFHLQ)
"RTN","VAFHLZM1",43,0)
 .S VAF327=$P(VAF32N,U,7) S VAF327=$S(VAF327:$$HLDATE^HLFNC(VAF327),1:VAFHLQ)
"RTN","VAFHLZM1",44,0)
 .; Service entry date~Service separation date
"RTN","VAFHLZM1",45,0)
 .S $P(VAFY,VAFHLS,4)=VAF326_$E(VAFHLC)_VAF327
"RTN","VAFHLZM1",46,0)
 I VAFSTR[",5," D
"RTN","VAFHLZM1",47,0)
 .; Service Component [L]
"RTN","VAFHLZM1",48,0)
 .S VAFSCL=$P(VAF3291N,U,1) I VAFSCL="" S VAFSCL=VAFHLQ
"RTN","VAFHLZM1",49,0)
 .S $P(VAFY,VAFHLS,5)=VAFSCL
"RTN","VAFHLZM1",50,0)
 Q
"RTN","VAFHLZM1",51,0)
SNL ; next to last Service branch
"RTN","VAFHLZM1",52,0)
 S $P(VAFY,VAFHLS,2)="SNL"
"RTN","VAFHLZM1",53,0)
 N VAF3291,VAF3294,VAF329,VAF3292,VAF3293,VAFSCNL
"RTN","VAFHLZM1",54,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",55,0)
 .S VAF3291=$P(VAF32N,U,10) S VAF3291=$S(VAF3291:$P($G(^DIC(23,VAF3291,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",56,0)
 .S VAF3294=$P(VAF32N,U,13) I VAF3294="" S VAF3294=VAFHLQ
"RTN","VAFHLZM1",57,0)
 .S VAF329=$P(VAF32N,U,9) S VAF329=$S(VAF329:$P($G(^DIC(25,VAF329,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",58,0)
 .S $P(VAFY,VAFHLS,3)=VAF3291_$E(VAFHLC)_VAF3294_$E(VAFHLC)_VAF329
"RTN","VAFHLZM1",59,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",60,0)
 .S VAF3292=$P(VAF32N,U,11) S VAF3292=$S(VAF3292:$$HLDATE^HLFNC(VAF3292),1:VAFHLQ)
"RTN","VAFHLZM1",61,0)
 .S VAF3293=$P(VAF32N,U,12) S VAF3293=$S(VAF3293:$$HLDATE^HLFNC(VAF3293),1:VAFHLQ)
"RTN","VAFHLZM1",62,0)
 .S $P(VAFY,VAFHLS,4)=VAF3292_$E(VAFHLC)_VAF3293
"RTN","VAFHLZM1",63,0)
 I VAFSTR[",5," D
"RTN","VAFHLZM1",64,0)
 .; Service Component [NL]
"RTN","VAFHLZM1",65,0)
 .S VAFSCNL=$P(VAF3291N,U,2) I VAFSCNL="" S VAFSCNL=VAFHLQ
"RTN","VAFHLZM1",66,0)
 .S $P(VAFY,VAFHLS,5)=VAFSCNL
"RTN","VAFHLZM1",67,0)
 Q
"RTN","VAFHLZM1",68,0)
SNNL ; next to next to last Service branch
"RTN","VAFHLZM1",69,0)
 S $P(VAFY,VAFHLS,2)="SNNL"
"RTN","VAFHLZM1",70,0)
 N VAF3296,VAF3299,VAF3295,VAF3297,VAF3298,VAFSCNNL
"RTN","VAFHLZM1",71,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",72,0)
 .S VAF3296=$P(VAF32N,U,15) S VAF3296=$S(VAF3296:$P($G(^DIC(23,VAF3296,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",73,0)
 .S VAF3299=$P(VAF32N,U,18) I VAF3299="" S VAF3299=VAFHLQ
"RTN","VAFHLZM1",74,0)
 .S VAF3295=$P(VAF32N,U,14) S VAF3295=$S(VAF3295:$P($G(^DIC(25,VAF3295,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",75,0)
 .S $P(VAFY,VAFHLS,3)=VAF3296_$E(VAFHLC)_VAF3299_$E(VAFHLC)_VAF3295
"RTN","VAFHLZM1",76,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",77,0)
 .S VAF3297=$P(VAF32N,U,16) S VAF3297=$S(VAF3297:$$HLDATE^HLFNC(VAF3297),1:VAFHLQ)
"RTN","VAFHLZM1",78,0)
 .S VAF3298=$P(VAF32N,U,17) S VAF3298=$S(VAF3298:$$HLDATE^HLFNC(VAF3298),1:VAFHLQ)
"RTN","VAFHLZM1",79,0)
 .S $P(VAFY,VAFHLS,4)=VAF3297_$E(VAFHLC)_VAF3298
"RTN","VAFHLZM1",80,0)
 I VAFSTR[",5," D
"RTN","VAFHLZM1",81,0)
 .; Service Component [NNL]
"RTN","VAFHLZM1",82,0)
 .S VAFSCNNL=$P(VAF3291N,U,3) I VAFSCNNL="" S VAFSCNNL=VAFHLQ
"RTN","VAFHLZM1",83,0)
 .S $P(VAFY,VAFHLS,5)=VAFSCNNL
"RTN","VAFHLZM1",84,0)
 Q
"RTN","VAFHLZM1",85,0)
POW ; Prisoner of War
"RTN","VAFHLZM1",86,0)
 S $P(VAFY,VAFHLS,2)="POW"
"RTN","VAFHLZM1",87,0)
 N VAF525,VAF526,VAF527,VAF528
"RTN","VAFHLZM1",88,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",89,0)
 .S VAF525=$P(VAF52N,U,5) I VAF525="" S VAF525=VAFHLQ
"RTN","VAFHLZM1",90,0)
 .;S VAF526=$P(VAF52N,U,6) S VAF526=$S(VAF526:$P($G(^DIC(22,VAF526,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",91,0)
 .; translate pointer to coded value for VA0023 table
"RTN","VAFHLZM1",92,0)
 .S VAF526=$P(VAF52N,U,6) S VAF526=$S(VAF526>0&(VAF526<7):VAF526+3,VAF526>6&(VAF526<9):$C(VAF526+58),1:VAFHLQ)
"RTN","VAFHLZM1",93,0)
 .S $P(VAFY,VAFHLS,3)=VAF525_$E(VAFHLC)_VAF526
"RTN","VAFHLZM1",94,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",95,0)
 .S VAF527=$P(VAF52N,U,7) S VAF527=$S(VAF527:$$HLDATE^HLFNC(VAF527),1:VAFHLQ)
"RTN","VAFHLZM1",96,0)
 .S VAF528=$P(VAF52N,U,8) S VAF528=$S(VAF528:$$HLDATE^HLFNC(VAF528),1:VAFHLQ)
"RTN","VAFHLZM1",97,0)
 .S $P(VAFY,VAFHLS,4)=VAF527_$E(VAFHLC)_VAF528
"RTN","VAFHLZM1",98,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",99,0)
 Q
"RTN","VAFHLZM1",100,0)
COMB ; Combat
"RTN","VAFHLZM1",101,0)
 S $P(VAFY,VAFHLS,2)="COMB"
"RTN","VAFHLZM1",102,0)
 N VAF5291,VAF5292,VAF5293,VAF5294
"RTN","VAFHLZM1",103,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",104,0)
 .S VAF5291=$P(VAF52N,U,11) I VAF5291="" S VAF5291=VAFHLQ
"RTN","VAFHLZM1",105,0)
 .S VAF5292=$P(VAF52N,U,12) S VAF5292=$S(VAF5292:$P($G(^DIC(22,VAF5292,0)),U),1:VAFHLQ)
"RTN","VAFHLZM1",106,0)
 .S $P(VAFY,VAFHLS,3)=VAF5291_$E(VAFHLC)_VAF5292
"RTN","VAFHLZM1",107,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",108,0)
 .S VAF5293=$P(VAF52N,U,13) S VAF5293=$S(VAF5293:$$HLDATE^HLFNC(VAF5293),1:VAFHLQ)
"RTN","VAFHLZM1",109,0)
 .S VAF5294=$P(VAF52N,U,14) S VAF5294=$S(VAF5294:$$HLDATE^HLFNC(VAF5294),1:VAFHLQ)
"RTN","VAFHLZM1",110,0)
 .S $P(VAFY,VAFHLS,4)=VAF5293_$E(VAFHLC)_VAF5294
"RTN","VAFHLZM1",111,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",112,0)
 Q
"RTN","VAFHLZM1",113,0)
VIET ; Vietnam
"RTN","VAFHLZM1",114,0)
 S $P(VAFY,VAFHLS,2)="VIET"
"RTN","VAFHLZM1",115,0)
 N VAF32101,VAF32104,VAF32105
"RTN","VAFHLZM1",116,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",117,0)
 .S VAF32101=$P(VAF321N,U) I VAF32101="" S VAF32101=VAFHLQ
"RTN","VAFHLZM1",118,0)
 .S $P(VAFY,VAFHLS,3)=VAF32101
"RTN","VAFHLZM1",119,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",120,0)
 .S VAF32104=$P(VAF321N,U,4) S VAF32104=$S(VAF32104:$$HLDATE^HLFNC(VAF32104),1:VAFHLQ)
"RTN","VAFHLZM1",121,0)
 .S VAF32105=$P(VAF321N,U,5) S VAF32105=$S(VAF32105:$$HLDATE^HLFNC(VAF32105),1:VAFHLQ)
"RTN","VAFHLZM1",122,0)
 .S $P(VAFY,VAFHLS,4)=VAF32104_$E(VAFHLC)_VAF32105
"RTN","VAFHLZM1",123,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",124,0)
 Q
"RTN","VAFHLZM1",125,0)
LEBA ; Lebanon
"RTN","VAFHLZM1",126,0)
 S $P(VAFY,VAFHLS,2)="LEBA"
"RTN","VAFHLZM1",127,0)
 N VAF3221,VAF3222,VAF3223
"RTN","VAFHLZM1",128,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",129,0)
 .S VAF3221=$P(VAF322N,U) I VAF3221="" S VAF3221=VAFHLQ
"RTN","VAFHLZM1",130,0)
 .S $P(VAFY,VAFHLS,3)=VAF3221
"RTN","VAFHLZM1",131,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",132,0)
 .S VAF3222=$P(VAF322N,U,2) S VAF3222=$S(VAF3222:$$HLDATE^HLFNC(VAF3222),1:VAFHLQ)
"RTN","VAFHLZM1",133,0)
 .S VAF3223=$P(VAF322N,U,3) S VAF3223=$S(VAF3223:$$HLDATE^HLFNC(VAF3223),1:VAFHLQ)
"RTN","VAFHLZM1",134,0)
 .S $P(VAFY,VAFHLS,4)=VAF3222_$E(VAFHLC)_VAF3223
"RTN","VAFHLZM1",135,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",136,0)
 Q
"RTN","VAFHLZM1",137,0)
GREN ; Grenada
"RTN","VAFHLZM1",138,0)
 S $P(VAFY,VAFHLS,2)="GREN"
"RTN","VAFHLZM1",139,0)
 N VAF3224,VAF3225,VAF3226
"RTN","VAFHLZM1",140,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",141,0)
 .S VAF3224=$P(VAF322N,U,4) I VAF3224="" S VAF3224=VAFHLQ
"RTN","VAFHLZM1",142,0)
 .S $P(VAFY,VAFHLS,3)=VAF3224
"RTN","VAFHLZM1",143,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",144,0)
 .S VAF3225=$P(VAF322N,U,5) S VAF3225=$S(VAF3225:$$HLDATE^HLFNC(VAF3225),1:VAFHLQ)
"RTN","VAFHLZM1",145,0)
 .S VAF3226=$P(VAF322N,U,6) S VAF3226=$S(VAF3226:$$HLDATE^HLFNC(VAF3226),1:VAFHLQ)
"RTN","VAFHLZM1",146,0)
 .S $P(VAFY,VAFHLS,4)=VAF3225_$E(VAFHLC)_VAF3226
"RTN","VAFHLZM1",147,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",148,0)
 Q
"RTN","VAFHLZM1",149,0)
PANA ; Panama
"RTN","VAFHLZM1",150,0)
 S $P(VAFY,VAFHLS,2)="PANA"
"RTN","VAFHLZM1",151,0)
 N VAF3227,VAF3228,VAF3229
"RTN","VAFHLZM1",152,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",153,0)
 .S VAF3227=$P(VAF322N,U,7) I VAF3227="" S VAF3227=VAFHLQ
"RTN","VAFHLZM1",154,0)
 .S $P(VAFY,VAFHLS,3)=VAF3227
"RTN","VAFHLZM1",155,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",156,0)
 .S VAF3228=$P(VAF322N,U,8) S VAF3228=$S(VAF3228:$$HLDATE^HLFNC(VAF3228),1:VAFHLQ)
"RTN","VAFHLZM1",157,0)
 .S VAF3229=$P(VAF322N,U,9) S VAF3229=$S(VAF3229:$$HLDATE^HLFNC(VAF3229),1:VAFHLQ)
"RTN","VAFHLZM1",158,0)
 .S $P(VAFY,VAFHLS,4)=VAF3228_$E(VAFHLC)_VAF3229
"RTN","VAFHLZM1",159,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",160,0)
 Q
"RTN","VAFHLZM1",161,0)
GULF ; Persian Gulf
"RTN","VAFHLZM1",162,0)
 S $P(VAFY,VAFHLS,2)="GULF"
"RTN","VAFHLZM1",163,0)
 N VAF32201,VA322011,VA322012
"RTN","VAFHLZM1",164,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",165,0)
 .S VAF32201=$P(VAF322N,U,10) I VAF32201="" S VAF32201=VAFHLQ
"RTN","VAFHLZM1",166,0)
 .S $P(VAFY,VAFHLS,3)=VAF32201
"RTN","VAFHLZM1",167,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",168,0)
 .S VA322011=$P(VAF322N,U,11) S VA322011=$S(VA322011:$$HLDATE^HLFNC(VA322011),1:VAFHLQ)
"RTN","VAFHLZM1",169,0)
 .S VA322012=$P(VAF322N,U,12) S VA322012=$S(VA322012:$$HLDATE^HLFNC(VA322012),1:VAFHLQ)
"RTN","VAFHLZM1",170,0)
 .S $P(VAFY,VAFHLS,4)=VA322011_$E(VAFHLC)_VA322012
"RTN","VAFHLZM1",171,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",172,0)
 Q
"RTN","VAFHLZM1",173,0)
SOMA ; Somalia
"RTN","VAFHLZM1",174,0)
 S $P(VAFY,VAFHLS,2)="SOMA"
"RTN","VAFHLZM1",175,0)
 N VA322016,VA322017,VA322018
"RTN","VAFHLZM1",176,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",177,0)
 .S VA322016=$P(VAF322N,U,16) I VA322016="" S VA322016=VAFHLQ
"RTN","VAFHLZM1",178,0)
 .S $P(VAFY,VAFHLS,3)=VA322016
"RTN","VAFHLZM1",179,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",180,0)
 .S VA322017=$P(VAF322N,U,17) S VA322017=$S(VA322017:$$HLDATE^HLFNC(VA322017),1:VAFHLQ)
"RTN","VAFHLZM1",181,0)
 .S VA322018=$P(VAF322N,U,18) S VA322018=$S(VA322018:$$HLDATE^HLFNC(VA322018),1:VAFHLQ)
"RTN","VAFHLZM1",182,0)
 .S $P(VAFY,VAFHLS,4)=VA322017_$E(VAFHLC)_VA322018
"RTN","VAFHLZM1",183,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",184,0)
 Q
"RTN","VAFHLZM1",185,0)
YUGO ; Yugoslavia
"RTN","VAFHLZM1",186,0)
 S $P(VAFY,VAFHLS,2)="YUGO"
"RTN","VAFHLZM1",187,0)
 N VA322019,VA32202,VA322021
"RTN","VAFHLZM1",188,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",189,0)
 .S VA322019=$P(VAF322N,U,19) I VA322019="" S VA322019=VAFHLQ
"RTN","VAFHLZM1",190,0)
 .S $P(VAFY,VAFHLS,3)=VA322019
"RTN","VAFHLZM1",191,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",192,0)
 .S VA32202=$P(VAF322N,U,20) S VA32202=$S(VA32202:$$HLDATE^HLFNC(VA32202),1:VAFHLQ)
"RTN","VAFHLZM1",193,0)
 .S VA322021=$P(VAF322N,U,21) S VA322021=$S(VA322021:$$HLDATE^HLFNC(VA322021),1:VAFHLQ)
"RTN","VAFHLZM1",194,0)
 .S $P(VAFY,VAFHLS,4)=VA32202_$E(VAFHLC)_VA322021
"RTN","VAFHLZM1",195,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",196,0)
 Q
"RTN","VAFHLZM1",197,0)
PH ; Purple Heart Recipent
"RTN","VAFHLZM1",198,0)
 S $P(VAFY,VAFHLS,2)="PH"
"RTN","VAFHLZM1",199,0)
 N VAF531,VAF532,VAF533
"RTN","VAFHLZM1",200,0)
 I VAFSTR[",3," D
"RTN","VAFHLZM1",201,0)
 .S VAF531=$P(VAF53N,U,1) I VAF531="" S VAF531=VAFHLQ
"RTN","VAFHLZM1",202,0)
 .S VAF532=$P(VAF53N,U,2) I VAF532="" S VAF532=VAFHLQ
"RTN","VAFHLZM1",203,0)
 .S VAF533=$P(VAF53N,U,3) I VAF533="" S VAF533=VAFHLQ
"RTN","VAFHLZM1",204,0)
 .S $P(VAFY,VAFHLS,3)=VAF531_$E(VAFHLC)_VAF532_$E(VAFHLC)_VAF533
"RTN","VAFHLZM1",205,0)
 I VAFSTR[",4," D
"RTN","VAFHLZM1",206,0)
 .S $P(VAFY,VAFHLS,4)=VAFHLQ
"RTN","VAFHLZM1",207,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM1",208,0)
 Q
"RTN","VAFHLZM1",209,0)
OEIF ;build Operation Enduring/Iraqi Freedom segments
"RTN","VAFHLZM1",210,0)
 D OEIF^VAFHLZM2
"RTN","VAFHLZM1",211,0)
 Q
"RTN","VAFHLZM1",212,0)
NOSEG ;
"RTN","VAFHLZM1",213,0)
 D NOSEG^VAFHLZM2
"RTN","VAFHLZM1",214,0)
 Q
"RTN","VAFHLZM1",215,0)
 ;
"RTN","VAFHLZM1",216,0)
MSDS ;build new ZMH format for MSDS records
"RTN","VAFHLZM1",217,0)
 D MSDS^VAFHLZM2
"RTN","VAFHLZM1",218,0)
 Q
"RTN","VAFHLZM2")
0^3^B10489371
"RTN","VAFHLZM2",1,0)
VAFHLZM2 ;ALB/KCL,PJH,LBD - Create HL7 Military History segment (ZMH) Cont ; 6/8/09 4:42pm
"RTN","VAFHLZM2",2,0)
 ;;5.3;Registration;**673,797**;Aug 13, 1993;Build 24
"RTN","VAFHLZM2",3,0)
 ;
"RTN","VAFHLZM2",4,0)
 ;--------------------------------------------------------------------------------
"RTN","VAFHLZM2",5,0)
 ;This routine creates HL7 VA-specific Military History ("ZMH") segments. It is a
"RTN","VAFHLZM2",6,0)
 ;continuation of VAFHLZM1 and uses variables from both VAFHLZMH and VAFHLZM1.
"RTN","VAFHLZM2",7,0)
 ;--------------------------------------------------------------------------------
"RTN","VAFHLZM2",8,0)
 ;
"RTN","VAFHLZM2",9,0)
 ;no direct entry
"RTN","VAFHLZM2",10,0)
 Q
"RTN","VAFHLZM2",11,0)
 ;
"RTN","VAFHLZM2",12,0)
 ;
"RTN","VAFHLZM2",13,0)
OEIF ;Build Operation Enduring/Iraqi Freedom segments
"RTN","VAFHLZM2",14,0)
 ;
"RTN","VAFHLZM2",15,0)
 N VAFDATA,VAFFROM,VAFIDX,VAFNODE,VAFSITE,VAFTO,VAFTYPE
"RTN","VAFHLZM2",16,0)
 ;
"RTN","VAFHLZM2",17,0)
 ;need to build segment even if no data in OEIF array 
"RTN","VAFHLZM2",18,0)
 S $P(VAFY,VAFHLS,2)="OEIF"
"RTN","VAFHLZM2",19,0)
 I VAFSTR[",3," S $P(VAFY,VAFHLS,3)=VAFHLQ_$E(VAFHLC)_VAFHLQ
"RTN","VAFHLZM2",20,0)
 I VAFSTR[",4," S $P(VAFY,VAFHLS,4)=VAFHLQ_$E(VAFHLC)_VAFHLQ
"RTN","VAFHLZM2",21,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM2",22,0)
 Q:'$D(VAFOPS)
"RTN","VAFHLZM2",23,0)
 ;
"RTN","VAFHLZM2",24,0)
 ;if data in OEIF array, build segment for each episode
"RTN","VAFHLZM2",25,0)
 S (VAFNODE,VAFIDX)=0
"RTN","VAFHLZM2",26,0)
 F  S VAFNODE=$O(VAFOPS(VAFNODE)) Q:'$G(VAFNODE)  D
"RTN","VAFHLZM2",27,0)
 .;
"RTN","VAFHLZM2",28,0)
 .S VAFDATA=$G(VAFOPS(VAFNODE))
"RTN","VAFHLZM2",29,0)
 .;
"RTN","VAFHLZM2",30,0)
 .I VAFSTR[",3," D
"RTN","VAFHLZM2",31,0)
 ..S VAFTYPE=$$EXTERNAL^DILFD(2.3215,.01,"F",$P(VAFDATA,U,1)) I VAFTYPE']"" S VAFTYPE=VAFHLQ
"RTN","VAFHLZM2",32,0)
 ..S VAFSITE=$$STATION^VAFHLFNC($P(VAFDATA,U,6)) I VAFSITE="" S VAFSITE=VAFHLQ
"RTN","VAFHLZM2",33,0)
 ..S $P(VAFY,VAFHLS,3)=VAFTYPE_$E(VAFHLC)_VAFSITE
"RTN","VAFHLZM2",34,0)
 .;
"RTN","VAFHLZM2",35,0)
 .I VAFSTR[",4," D
"RTN","VAFHLZM2",36,0)
 ..S VAFFROM=$P(VAFDATA,U,2) S VAFFROM=$S(VAFFROM:$$HLDATE^HLFNC(VAFFROM),1:VAFHLQ)
"RTN","VAFHLZM2",37,0)
 ..S VAFTO=$P(VAFDATA,U,3) S VAFTO=$S(VAFTO:$$HLDATE^HLFNC(VAFTO),1:VAFHLQ)
"RTN","VAFHLZM2",38,0)
 ..S $P(VAFY,VAFHLS,4)=VAFFROM_$E(VAFHLC)_VAFTO
"RTN","VAFHLZM2",39,0)
 .;
"RTN","VAFHLZM2",40,0)
 .I VAFSTR[",5," D
"RTN","VAFHLZM2",41,0)
 ..S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM2",42,0)
 .;
"RTN","VAFHLZM2",43,0)
 .;put segment into array
"RTN","VAFHLZM2",44,0)
 .S VAFIDX=VAFIDX+1
"RTN","VAFHLZM2",45,0)
 .S VAFY(VAFIDX)=$G(VAFY)
"RTN","VAFHLZM2",46,0)
 ;
"RTN","VAFHLZM2",47,0)
 Q
"RTN","VAFHLZM2",48,0)
 ;
"RTN","VAFHLZM2",49,0)
 ;
"RTN","VAFHLZM2",50,0)
NOSEG ;
"RTN","VAFHLZM2",51,0)
 Q
"RTN","VAFHLZM2",52,0)
 ;
"RTN","VAFHLZM2",53,0)
MSDS ;Returns all service episodes from ESR sourced data
"RTN","VAFHLZM2",54,0)
 ;
"RTN","VAFHLZM2",55,0)
 N BRANCH,COMP,DA,DATE,DONE,DTYP,EDATA,EDATE,NUM,SDATE,SERVNO,VAFIDX
"RTN","VAFHLZM2",56,0)
 S DATE="",(NUM,VAFIDX)=0
"RTN","VAFHLZM2",57,0)
 ;Scan back through entry dates for service episodes
"RTN","VAFHLZM2",58,0)
 F  S DATE=$O(^DPT(DFN,.3216,"B",DATE),-1) Q:'DATE  D
"RTN","VAFHLZM2",59,0)
 .S DA=$O(^DPT(DFN,.3216,"B",DATE,0)) Q:'DA
"RTN","VAFHLZM2",60,0)
 .S NUM=NUM+1
"RTN","VAFHLZM2",61,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
"RTN","VAFHLZM2",62,0)
 .S SDATE=$P(EDATA,U,2),EDATE=DATE
"RTN","VAFHLZM2",63,0)
 .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
"RTN","VAFHLZM2",64,0)
 .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
"RTN","VAFHLZM2",65,0)
 .S $P(VAFY,VAFHLS,2)=$S(NUM=1:"SL",NUM=2:"SNL",NUM=3:"SNNL",1:"MSD")
"RTN","VAFHLZM2",66,0)
 .I VAFSTR[",3," D
"RTN","VAFHLZM2",67,0)
 ..S BRANCH=$S(BRANCH:$P($G(^DIC(23,BRANCH,0)),U),1:VAFHLQ)
"RTN","VAFHLZM2",68,0)
 ..I SERVNO="" S SERVNO=VAFHLQ
"RTN","VAFHLZM2",69,0)
 ..S DTYP=$S(DTYP:$P($G(^DIC(25,DTYP,0)),U),1:VAFHLQ)
"RTN","VAFHLZM2",70,0)
 ..; Service branch~Service number~Service discharge type
"RTN","VAFHLZM2",71,0)
 ..S $P(VAFY,VAFHLS,3)=BRANCH_$E(VAFHLC)_SERVNO_$E(VAFHLC)_DTYP
"RTN","VAFHLZM2",72,0)
 .I VAFSTR[",4," D
"RTN","VAFHLZM2",73,0)
 ..S EDATE=$S(EDATE:$$HLDATE^HLFNC(EDATE),1:VAFHLQ)
"RTN","VAFHLZM2",74,0)
 ..S SDATE=$S(SDATE:$$HLDATE^HLFNC(SDATE),1:VAFHLQ)
"RTN","VAFHLZM2",75,0)
 ..; Service entry date~Service separation date
"RTN","VAFHLZM2",76,0)
 ..S $P(VAFY,VAFHLS,4)=EDATE_$E(VAFHLC)_SDATE
"RTN","VAFHLZM2",77,0)
 .I VAFSTR[",5," D
"RTN","VAFHLZM2",78,0)
 ..; Service Component [L]
"RTN","VAFHLZM2",79,0)
 ..I COMP="" S COMP=VAFHLQ
"RTN","VAFHLZM2",80,0)
 ..S $P(VAFY,VAFHLS,5)=COMP
"RTN","VAFHLZM2",81,0)
 .;
"RTN","VAFHLZM2",82,0)
 .;put segment into array
"RTN","VAFHLZM2",83,0)
 .S VAFIDX=VAFIDX+1
"RTN","VAFHLZM2",84,0)
 .S VAFY(VAFIDX)=$G(VAFY)
"RTN","VAFHLZM2",85,0)
 Q
"RTN","VAFHLZMH")
0^1^B30066508
"RTN","VAFHLZMH",1,0)
VAFHLZMH ;BAY/JAT,PJH - Create HL7 Military History seg. (ZMH) ; 8/14/09 3:14pm
"RTN","VAFHLZMH",2,0)
 ;;5.3;Registration;**190,314,673,797**;Aug 13, 1993;Build 24
"RTN","VAFHLZMH",3,0)
 ;
"RTN","VAFHLZMH",4,0)
 ; This routine creates HL7 VA-specific Military History ("ZMH") segments
"RTN","VAFHLZMH",5,0)
 Q
"RTN","VAFHLZMH",6,0)
 ;
"RTN","VAFHLZMH",7,0)
EN(DFN,VAFHMIEN,VAFSTR) ; RAI/MDS Reserved entry point!!
"RTN","VAFHLZMH",8,0)
 ; !!!!!!!!!! don't enter here !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
"RTN","VAFHLZMH",9,0)
 ;DFN - Patient Internal Entry Number
"RTN","VAFHLZMH",10,0)
 ;VAFHMIEN - Patient Movement Internal Entry Number
"RTN","VAFHLZMH",11,0)
 ;VAFSTR - Sequence numbers to be included
"RTN","VAFHLZMH",12,0)
 ;
"RTN","VAFHLZMH",13,0)
 N VAFHLREC,VAFHA,VAFHSUB,VAFHADD,VAFHLOC S VAFHSUB="" ;Initialize variables
"RTN","VAFHLZMH",14,0)
 S $P(VAFHLREC,HL("FS"))="ZMH" ;Set segment ID to ZMH
"RTN","VAFHLZMH",15,0)
 S $P(VAFHLREC,HL("FS"),2)=1 ;Set Set ID to 1
"RTN","VAFHLZMH",16,0)
 I VAFSTR[",4," D
"RTN","VAFHLZMH",17,0)
 .N EDATE,SDATE
"RTN","VAFHLZMH",18,0)
 .I '$D(^DPT(DFN,.3216)) D
"RTN","VAFHLZMH",19,0)
 ..S EDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".326","I"))
"RTN","VAFHLZMH",20,0)
 ..S SDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".327","I"))
"RTN","VAFHLZMH",21,0)
 .E  D MSDSD
"RTN","VAFHLZMH",22,0)
 .S $P(VAFHLREC,HL("FS"),5)=EDATE_$E(HL("ECH"))_SDATE
"RTN","VAFHLZMH",23,0)
 Q VAFHLREC ;Quit and return formatted segment
"RTN","VAFHLZMH",24,0)
 ;
"RTN","VAFHLZMH",25,0)
MSDSD ;Returns last service separation date from ESR sourced data 
"RTN","VAFHLZMH",26,0)
 N DA,DONE,EDATA
"RTN","VAFHLZMH",27,0)
 S EDATE="",SDATE="",DONE=0
"RTN","VAFHLZMH",28,0)
 F  S EDATE=$O(^DPT(DFN,.3216,"B",""),-1) Q:'EDATE  D  Q:DONE
"RTN","VAFHLZMH",29,0)
 .S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
"RTN","VAFHLZMH",30,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
"RTN","VAFHLZMH",31,0)
 .S DONE=1
"RTN","VAFHLZMH",32,0)
 ;
"RTN","VAFHLZMH",33,0)
 Q:'DONE
"RTN","VAFHLZMH",34,0)
 S EDATE=$$HLDATE^HLFNC(EDATE)
"RTN","VAFHLZMH",35,0)
 S SDATE=$$HLDATE^HLFNC($P(EDATA,U,2))
"RTN","VAFHLZMH",36,0)
 Q
"RTN","VAFHLZMH",37,0)
 ;
"RTN","VAFHLZMH",38,0)
ENTER(DFN,VAFARRAY,VAFTYPE,VAFSTR,VAFHLS,VAFHLC,VAFHLQ)       ;
"RTN","VAFHLZMH",39,0)
 ; DFN is the only required parameter.  Defaults are used if no
"RTN","VAFHLZMH",40,0)
 ; values are passed for the other parameters.
"RTN","VAFHLZMH",41,0)
 ; Output:
"RTN","VAFHLZMH",42,0)
 ; VAFARRAY = array name to hold the "ZMH" segments.
"RTN","VAFHLZMH",43,0)
 ;            Default is ^TMP("VAFHLZMH",$J)
"RTN","VAFHLZMH",44,0)
 ; Input:
"RTN","VAFHLZMH",45,0)
 ; DFN = internal entry number (IEN) of Patient (#2) file
"RTN","VAFHLZMH",46,0)
 ; VAFTYPE = Military History type desired (separated by commas) where
"RTN","VAFHLZMH",47,0)
 ;            1=Last Service branch (SL)
"RTN","VAFHLZMH",48,0)
 ;            2=Next to last Service branch (SNL)
"RTN","VAFHLZMH",49,0)
 ;            3=Next to next to last Service branch (SNNL)
"RTN","VAFHLZMH",50,0)
 ;            4=Prisoner of War Status indicated? (POW)
"RTN","VAFHLZMH",51,0)
 ;            5=Combat Service indicated? (COMB)
"RTN","VAFHLZMH",52,0)
 ;            6=Vietnam Service indicated? (VIET)
"RTN","VAFHLZMH",53,0)
 ;            7=Lebanon Service indicated? (LEBA)
"RTN","VAFHLZMH",54,0)
 ;            8=Grenada Service indicated? (GREN)
"RTN","VAFHLZMH",55,0)
 ;            9=Panama Service indicated? (PANA)
"RTN","VAFHLZMH",56,0)
 ;           10=Persian Gulf Service indicated? (GULF)
"RTN","VAFHLZMH",57,0)
 ;           11=Somalia Service indicated? (SOMA)    
"RTN","VAFHLZMH",58,0)
 ;           12=Yugoslavia Service indicated? (YUGO)
"RTN","VAFHLZMH",59,0)
 ;           13=Purple Heart Receipient? (PH)
"RTN","VAFHLZMH",60,0)
 ;           14=Operation Enduring/Iraqi Freedom (OEIF)
"RTN","VAFHLZMH",61,0)
 ;          A range of numbers separated by colons can be sent 
"RTN","VAFHLZMH",62,0)
 ;                  (e.g. 1:4,8,10:12) 
"RTN","VAFHLZMH",63,0)
 ;          Default is all(1,2,3...)
"RTN","VAFHLZMH",64,0)
 ;
"RTN","VAFHLZMH",65,0)
 ;          OR  
"RTN","VAFHLZMH",66,0)
 ;
"RTN","VAFHLZMH",67,0)
 ;          If value '*' is passed into the routine then the default 
"RTN","VAFHLZMH",68,0)
 ;          is to return all military history and all military service
"RTN","VAFHLZMH",69,0)
 ;          episodes for the vet. Rather than using SL, SNL AND SNNL
"RTN","VAFHLZMH",70,0)
 ;          the ZMH type will be 'MSD'.
"RTN","VAFHLZMH",71,0)
 ;
"RTN","VAFHLZMH",72,0)
 ;
"RTN","VAFHLZMH",73,0)
 ; VAFSTR = Fields (sequence numbers) desired (separated by comma) where
"RTN","VAFHLZMH",74,0)
 ;          3=qualifier #1 (Service branch if VAFTYPE is 1,2 or 3
"RTN","VAFHLZMH",75,0)
 ;                         or Yes/No response if VAFTYPE is 4 thru 13)
"RTN","VAFHLZMH",76,0)
 ;            qualifier #2 (Service number if VAFTYPE is 1,2 or 3
"RTN","VAFHLZMH",77,0)
 ;                         or Location if VAFTYPE is 4 or 5)
"RTN","VAFHLZMH",78,0)
 ;                         or 
"RTN","VAFHLZMH",79,0)
 ;            qualifier #3 (Service discharge type if VAFTYPE is 1,2
"RTN","VAFHLZMH",80,0)
 ;                          or 3)
"RTN","VAFHLZMH",81,0)
 ;          4=From/To Date range for each VAFTYPE
"RTN","VAFHLZMH",82,0)
 ;          5=Service Component
"RTN","VAFHLZMH",83,0)
 ;          Default is 3,4,5
"RTN","VAFHLZMH",84,0)
 ; VAFHLS = HL7 field separator (1 character)
"RTN","VAFHLZMH",85,0)
 ;          Default is ^ (carrot)
"RTN","VAFHLZMH",86,0)
 ; VAFHLC = HL7 encoding characters (4 characters must be supplied)
"RTN","VAFHLZMH",87,0)
 ;          Default is ~|\& (tilde bar backslash ampersand)
"RTN","VAFHLZMH",88,0)
 ; VAFHLQ = HL7 null designation 
"RTN","VAFHLZMH",89,0)
 ;          Default is "" (quote quote)
"RTN","VAFHLZMH",90,0)
 ; 
"RTN","VAFHLZMH",91,0)
 ; Check input and apply default values as needed
"RTN","VAFHLZMH",92,0)
 S VAFARRAY=$G(VAFARRAY) I VAFARRAY="" S VAFARRAY=$NA(^TMP("VAFHLZMH",$J))
"RTN","VAFHLZMH",93,0)
 K @VAFARRAY
"RTN","VAFHLZMH",94,0)
 S VAFTYPE=$G(VAFTYPE)
"RTN","VAFHLZMH",95,0)
 I VAFTYPE="" S VAFTYPE="1,2,3,4,5,6,7,8,9,10,11,12,13,14"
"RTN","VAFHLZMH",96,0)
 S VAFSTR=$G(VAFSTR) I VAFSTR="" S VAFSTR="3,4,5"
"RTN","VAFHLZMH",97,0)
 S VAFHLS=$G(VAFHLS) I VAFHLS="" S VAFHLS="^"
"RTN","VAFHLZMH",98,0)
 S:($L(VAFHLS)'=1) VAFHLS="^"
"RTN","VAFHLZMH",99,0)
 S VAFHLC=$G(VAFHLC) I VAFHLC="" S VAFHLC="~|\&"
"RTN","VAFHLZMH",100,0)
 S:($L(VAFHLC)'=4) VAFHLC="~|\&"
"RTN","VAFHLZMH",101,0)
 S:('$D(VAFHLQ)) VAFHLQ=$C(34,34)
"RTN","VAFHLZMH",102,0)
 I '$G(DFN) D NOGO Q
"RTN","VAFHLZMH",103,0)
 I '$D(^DPT(DFN,0)) D NOGO Q
"RTN","VAFHLZMH",104,0)
 S VAFSTR=$TR(VAFSTR,":",",")
"RTN","VAFHLZMH",105,0)
 I VAFSTR'=3,VAFSTR'=4,VAFSTR'=5,VAFSTR'="3,4",VAFSTR'="3,5",VAFSTR'="4,5",VAFSTR'="3,4,5" D NOGO Q
"RTN","VAFHLZMH",106,0)
 S VAFSTR=","_VAFSTR_","
"RTN","VAFHLZMH",107,0)
 I VAFTYPE="*" S VAFTYPE="*,4,5,6,7,8,9,10,11,12,13,14"
"RTN","VAFHLZMH",108,0)
 E  I '$$EDIT(VAFTYPE) D NOGO Q
"RTN","VAFHLZMH",109,0)
 I VAFTYPE[":" D UNCRUNCH
"RTN","VAFHLZMH",110,0)
 ; it's a Go
"RTN","VAFHLZMH",111,0)
 N VAFY,VAFX,VAFZ,VAFINDX,VAFTAG
"RTN","VAFHLZMH",112,0)
 S VAFINDX=0
"RTN","VAFHLZMH",113,0)
 ; set all the Patient file nodes that may be needed
"RTN","VAFHLZMH",114,0)
 N VAF32N,VAF321N,VAF322N,VAF52N,VAF53N,VAF3291N
"RTN","VAFHLZMH",115,0)
 S VAF321N=$G(^DPT(DFN,.321)) ; used for Vietnam
"RTN","VAFHLZMH",116,0)
 S VAF322N=$G(^DPT(DFN,.322)) ; used for minor skirmishes
"RTN","VAFHLZMH",117,0)
 S VAF52N=$G(^DPT(DFN,.52)) ; used for POW and Combat
"RTN","VAFHLZMH",118,0)
 S VAF53N=$G(^DPT(DFN,.53)) ;used for Purple Heart
"RTN","VAFHLZMH",119,0)
 I '$D(^DPT(DFN,.3216)) D
"RTN","VAFHLZMH",120,0)
 .S VAF32N=$G(^DPT(DFN,.32)) ; used for Service branches
"RTN","VAFHLZMH",121,0)
 .S VAF3291N=$G(^DPT(DFN,.3291)) ;used for service component
"RTN","VAFHLZMH",122,0)
 I $D(^DPT(DFN,.3216)),VAFTYPE'["*" D MSDS
"RTN","VAFHLZMH",123,0)
 ;used for Operation Enduring/Iraqi Freedom
"RTN","VAFHLZMH",124,0)
 N VAFOPS,VAFREC,VAFSUB
"RTN","VAFHLZMH",125,0)
 S (VAFREC,VAFSUB)=0
"RTN","VAFHLZMH",126,0)
 ;set operations into local array since there may be mult OEIF episodes
"RTN","VAFHLZMH",127,0)
 F  S VAFREC=$O(^DPT(DFN,.3215,VAFREC)) Q:'$G(VAFREC)  D
"RTN","VAFHLZMH",128,0)
 . S VAFSUB=VAFSUB+1
"RTN","VAFHLZMH",129,0)
 . S VAFOPS(VAFSUB)=$G(^DPT(DFN,.3215,VAFREC,0))
"RTN","VAFHLZMH",130,0)
 ;
"RTN","VAFHLZMH",131,0)
 D ENTER^VAFHLZM1
"RTN","VAFHLZMH",132,0)
 ;
"RTN","VAFHLZMH",133,0)
 Q
"RTN","VAFHLZMH",134,0)
 ;
"RTN","VAFHLZMH",135,0)
MSDS ;Returns latest service episodes from ESR sourced data
"RTN","VAFHLZMH",136,0)
 ;
"RTN","VAFHLZMH",137,0)
 ;*** the number of episodes is unlimited ****
"RTN","VAFHLZMH",138,0)
 ;
"RTN","VAFHLZMH",139,0)
 N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,SDATE,SERVNO,SUB
"RTN","VAFHLZMH",140,0)
 S COUNT=0,EDATE="",VAF32N="",VAF3291N=""
"RTN","VAFHLZMH",141,0)
 ;Scan back for three most recent service episodes
"RTN","VAFHLZMH",142,0)
 F  S EDATE=$O(^DPT(DFN,.3216,"B",EDATE),-1) Q:'EDATE  D  Q:COUNT'<3
"RTN","VAFHLZMH",143,0)
 .S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
"RTN","VAFHLZMH",144,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
"RTN","VAFHLZMH",145,0)
 .S COUNT=COUNT+1,SDATE=$P(EDATA,U,2)
"RTN","VAFHLZMH",146,0)
 .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
"RTN","VAFHLZMH",147,0)
 .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
"RTN","VAFHLZMH",148,0)
 .;SL = 4, SNL = 9 or SNNL = 14
"RTN","VAFHLZMH",149,0)
 .S SUB=(COUNT*5)-1
"RTN","VAFHLZMH",150,0)
 .S $P(VAF32N,U,SUB)=DTYP
"RTN","VAFHLZMH",151,0)
 .S $P(VAF32N,U,SUB+1)=BRANCH
"RTN","VAFHLZMH",152,0)
 .S $P(VAF32N,U,SUB+2)=EDATE
"RTN","VAFHLZMH",153,0)
 .S $P(VAF32N,U,SUB+3)=SDATE
"RTN","VAFHLZMH",154,0)
 .S $P(VAF32N,U,SUB+4)=SERVNO
"RTN","VAFHLZMH",155,0)
 .S $P(VAF3291N,U,COUNT)=COMP
"RTN","VAFHLZMH",156,0)
 Q
"RTN","VAFHLZMH",157,0)
 ;
"RTN","VAFHLZMH",158,0)
EDIT(X)  ; function validates VAFTYP (returns 1 if valid)        
"RTN","VAFHLZMH",159,0)
 N P,Q,R,CNT,Z,Z1,Z2,ERR S ERR=0
"RTN","VAFHLZMH",160,0)
 S X=$G(X)
"RTN","VAFHLZMH",161,0)
 I X>0,X<15,X?.N Q 1 ; only 1 number and between 1-14
"RTN","VAFHLZMH",162,0)
 I X'[":",X'["," Q 0 ; comma not used as separator
"RTN","VAFHLZMH",163,0)
 I X'?.NP Q 0 ; contains letters or control characters
"RTN","VAFHLZMH",164,0)
 ; contains punctuation other than comma/colon
"RTN","VAFHLZMH",165,0)
 S P="!#$%&'()*+-./;<=>?@[\]^_`{|]~"
"RTN","VAFHLZMH",166,0)
 F CNT=1:1 S Z=$E(X,CNT) Q:Z=""  I P[Z S ERR=1 Q
"RTN","VAFHLZMH",167,0)
 I ERR=1 Q 0
"RTN","VAFHLZMH",168,0)
 S Q="",R=""""
"RTN","VAFHLZMH",169,0)
 I Q[X!R[X Q 0
"RTN","VAFHLZMH",170,0)
 ; checks that numbers are >0<15
"RTN","VAFHLZMH",171,0)
 F CNT=1:1 S Z=$P(X,",",CNT) Q:Z=""  D
"RTN","VAFHLZMH",172,0)
 .I Z'[":",Z>0,Z<15 Q
"RTN","VAFHLZMH",173,0)
 .S Z1=$P(Z,":",1),Z2=$P(Z,":",2)
"RTN","VAFHLZMH",174,0)
 .I Z1>0,Z1<15,Z2>0,Z2<15 Q
"RTN","VAFHLZMH",175,0)
 .S ERR=1
"RTN","VAFHLZMH",176,0)
 I ERR=1 Q 0
"RTN","VAFHLZMH",177,0)
 Q 1
"RTN","VAFHLZMH",178,0)
 ;
"RTN","VAFHLZMH",179,0)
UNCRUNCH ; reformat VAFTYPE by translating any range of numbers,
"RTN","VAFHLZMH",180,0)
 ; for example replace "1:3,6,9:11" by "1,2,3,6,9,10,11,"
"RTN","VAFHLZMH",181,0)
 N X,Y,Z,A,B S Y=""
"RTN","VAFHLZMH",182,0)
 F X=1:1 S Z=$P(VAFTYPE,",",X) Q:Z=""  D
"RTN","VAFHLZMH",183,0)
 .I Z'[":" S Y=Y_Z_"," Q
"RTN","VAFHLZMH",184,0)
 .S A=$P(Z,":",1),B=$P(Z,":",2)
"RTN","VAFHLZMH",185,0)
 .S Y=Y_A_","
"RTN","VAFHLZMH",186,0)
 .F  S A=A+1 Q:A>B  S Y=Y_A_","
"RTN","VAFHLZMH",187,0)
 S VAFTYPE=Y
"RTN","VAFHLZMH",188,0)
 Q
"RTN","VAFHLZMH",189,0)
NOGO ;
"RTN","VAFHLZMH",190,0)
 S @VAFARRAY@(1,0)="ZMH"_VAFHLS_1
"RTN","VAFHLZMH",191,0)
 Q
"SEC","^DIC",25,25,0,"DD")
@
"SEC","^DIC",25,25,0,"DEL")
@
"SEC","^DIC",25,25,0,"LAYGO")
@
"SEC","^DIC",25,25,0,"RD")
d
"SEC","^DIC",25,25,0,"WR")
@
"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")
@
"UP",2,2.3215,-1)
2^.3215
"UP",2,2.3215,0)
2.3215
"UP",2,2.3216,-1)
2^.3216
"UP",2,2.3216,0)
2.3216
"VER")
8.0^22.0
"^DD",2,2,.3216,0)
MILITARY SERVICE EPISODE^2.3216D^^.3216;0
"^DD",2,2,.3216,21,0)
^.001^4^4^3090226^^^^
"^DD",2,2,.3216,21,1,0)
This contains the definitive military service episode history for the 
"^DD",2,2,.3216,21,2,0)
patient and is updated from the Health Eligibility Center (HEC) system.  
"^DD",2,2,.3216,21,3,0)
HEC is the authoritative source for this data and it may not be edited in
"^DD",2,2,.3216,21,4,0)
VistA except to add new episodes.
"^DD",2,2,.327,0)
SERVICE SEPARATION DATE [LAST]^RDX^^.32;7^S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SV^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSL") X I $D(X),$D(^DG(43,1)) S SD1=1 D PS^DGINP
"^DD",2,2,.327,.1)
SEPARATION DATE-SERVICE [LAST]
"^DD",2,2,.327,1,0)
^.1
"^DD",2,2,.327,1,1,0)
2^AENR327^MUMPS
"^DD",2,2,.327,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.327,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.327,1,1,"%D",0)
^^2^2^3040610^
"^DD",2,2,.327,1,1,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of changes to the
"^DD",2,2,.327,1,1,"%D",2,0)
SERVICE SEPARATION DATE [LAST] field.
"^DD",2,2,.327,1,1,"DT")
3040610
"^DD",2,2,.327,1,992,0)
2^ADGRU327^MUMPS
"^DD",2,2,.327,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.327,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.327,1,992,"%D",0)
^^9^9^2990921^
"^DD",2,2,.327,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.327,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.327,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.327,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.327,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.327,1,992,"%D",6,0)
interface.
"^DD",2,2,.327,1,992,"%D",7,0)
 
"^DD",2,2,.327,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.327,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.327,1,992,"DT")
2990921
"^DD",2,2,.327,3)
Enter the date on which this patient was separated from his last episode of military service.
"^DD",2,2,.327,20,0)
^.3LA^1^1
"^DD",2,2,.327,20,1,0)
SVC
"^DD",2,2,.327,21,0)
^.001^7^7^3061003^^
"^DD",2,2,.327,21,1,0)
For this veteran applicant enter the date s/he ended his/her
"^DD",2,2,.327,21,2,0)
most recent episode of military service. If the military
"^DD",2,2,.327,21,3,0)
service component is ACTIVATED NATIONAL GUARD or ACTIVATED
"^DD",2,2,.327,21,4,0)
RESERVE, the period entered should be the period of activation,
"^DD",2,2,.327,21,5,0)
so this date is their last day of active duty for this episode.
"^DD",2,2,.327,21,6,0)
Once the service record is verified only those users who hold
"^DD",2,2,.327,21,7,0)
the designated security key may enter/edit this field.
"^DD",2,2,.327,"DEL",1,0)
S DFN=DA D SV^DGLOCK I '$D(X)
"^DD",2,2,.327,"DT")
3090623
"^DD",2,2.3215,.03,0)
OEF/OIF TO DATE^DX^^0;3^S %DT="E" D ^%DT S X=Y I $D(X) K:'$$VALCON1^DGRPMS(DA(1),DA,X,1) X I $D(X) S DFN=DA(1) D OEIF^DGLOCK
"^DD",2,2.3215,.03,1,0)
^.1
"^DD",2,2.3215,.03,1,1,0)
2.3215^AENR321503^MUMPS
"^DD",2,2.3215,.03,1,1,1)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3215,.03,1,1,2)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3215,.03,1,1,"%D",0)
^^2^2^3060123^
"^DD",2,2.3215,.03,1,1,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of changes to the
"^DD",2,2.3215,.03,1,1,"%D",2,0)
OEF/OIF TO DATE field.
"^DD",2,2.3215,.03,1,1,"DT")
3060123
"^DD",2,2.3215,.03,3)
Enter the date the patient left the OEF/OIF area if known.  Otherwise, enter the end date of military pay for this OEF/OIF deployment.
"^DD",2,2.3215,.03,4)

"^DD",2,2.3215,.03,21,0)
^.001^9^9^3060322^^^^
"^DD",2,2.3215,.03,21,1,0)
If the service indicated is OEF or UNKNOWN OEF/OIF, this date must be on
"^DD",2,2.3215,.03,21,2,0)
or after 9/11/2001. If the service indicated is OIF, this date must be on
"^DD",2,2.3215,.03,21,3,0)
or after 3/19/2003.
"^DD",2,2.3215,.03,21,4,0)
 
"^DD",2,2.3215,.03,21,5,0)
The meaning of this date depends on where the information was obtained
"^DD",2,2.3215,.03,21,6,0)
from.  If the data came from the VIS, Environmental Medicine or FHIE
"^DD",2,2.3215,.03,21,7,0)
systems, this is the military pay end date for the assignment to
"^DD",2,2.3215,.03,21,8,0)
the OEF/OIF operation.  If it came from any other source, it is the date
"^DD",2,2.3215,.03,21,9,0)
the patient actually left the OEF/OIF area.
"^DD",2,2.3215,.03,"DT")
3090622
"^DD",2,2.3216,0)
MILITARY SERVICE EPISODE SUB-FIELD^^.07^7
"^DD",2,2.3216,0,"DT")
3090126
"^DD",2,2.3216,0,"IX","ADGRU321601",2.3216,.01)

"^DD",2,2.3216,0,"IX","ADGRU321602",2.3216,.02)

"^DD",2,2.3216,0,"IX","AENR321601",2.3216,.01)

"^DD",2,2.3216,0,"IX","AENR321602",2.3216,.02)

"^DD",2,2.3216,0,"IX","AENR321603",2.3216,.03)

"^DD",2,2.3216,0,"IX","AENR321604",2.3216,.04)

"^DD",2,2.3216,0,"IX","AENR321605",2.3216,.05)

"^DD",2,2.3216,0,"IX","AENR321606",2.3216,.06)

"^DD",2,2.3216,0,"IX","AFV3216",2.3216,.03)

"^DD",2,2.3216,0,"IX","B",2.3216,.01)

"^DD",2,2.3216,0,"NM","MILITARY SERVICE EPISODE")

"^DD",2,2.3216,0,"UP")
2
"^DD",2,2.3216,.01,0)
SERVICE ENTRY DATE^MRDX^^0;1^S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA(1) K:'$$AGE^DGRPDD1(DFN,X) X I $D(X),$G(DA) D MSE^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSE-"_DA) X I $D(X) S DGFRDT=X
"^DD",2,2.3216,.01,1,0)
^.1
"^DD",2,2.3216,.01,1,1,0)
2.3216^B
"^DD",2,2.3216,.01,1,1,1)
S ^DPT(DA(1),.3216,"B",$E(X,1,30),DA)=""
"^DD",2,2.3216,.01,1,1,2)
K ^DPT(DA(1),.3216,"B",$E(X,1,30),DA)
"^DD",2,2.3216,.01,1,2,0)
2.3216^AENR321601^MUMPS
"^DD",2,2.3216,.01,1,2,1)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.01,1,2,2)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.01,1,2,"%D",0)
^^2^2^3090219^
"^DD",2,2.3216,.01,1,2,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of any changes to the
"^DD",2,2.3216,.01,1,2,"%D",2,0)
SERVICE ENTRY DATE field.
"^DD",2,2.3216,.01,1,2,"DT")
3090219
"^DD",2,2.3216,.01,1,3,0)
2.3216^ADGRU321601^MUMPS
"^DD",2,2.3216,.01,1,3,1)
D:($T(ADGRU^DGRUDD01)'="")&($G(X)=$P($$LAST^DGMSEUTL(DA(1)),U)) ADGRU^DGRUDD01(DA(1))
"^DD",2,2.3216,.01,1,3,2)
D:($T(ADGRU^DGRUDD01)'="")&($G(X)=$P($$LAST^DGMSEUTL(DA(1)),U)) ADGRU^DGRUDD01(DA(1))
"^DD",2,2.3216,.01,1,3,"%D",0)
^^9^9^3090622^
"^DD",2,2.3216,.01,1,3,"%D",1,0)
This cross reference is used to remember that changes were made to a
"^DD",2,2.3216,.01,1,3,"%D",2,0)
monitored data field in the PATIENT file (#2) required for a vendor
"^DD",2,2.3216,.01,1,3,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2.3216,.01,1,3,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2.3216,.01,1,3,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2.3216,.01,1,3,"%D",6,0)
interface.
"^DD",2,2.3216,.01,1,3,"%D",7,0)
 
"^DD",2,2.3216,.01,1,3,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2.3216,.01,1,3,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2.3216,.01,1,3,"DT")
3090622
"^DD",2,2.3216,.01,3)
Enter the date the patient entered this episode of military service.
"^DD",2,2.3216,.01,21,0)
^.001^8^8^3090126^^
"^DD",2,2.3216,.01,21,1,0)
For this veteran applicant, enter the date s/he commenced this episode of
"^DD",2,2.3216,.01,21,2,0)
military service.  If the military service component is ACTIVATED NATIONAL
"^DD",2,2.3216,.01,21,3,0)
GUARD or ACTIVATED RESERVE, the period entered should be the period of
"^DD",2,2.3216,.01,21,4,0)
activation, so this date is their first day of active duty for the
"^DD",2,2.3216,.01,21,5,0)
episode. 
"^DD",2,2.3216,.01,21,6,0)
                                 
"^DD",2,2.3216,.01,21,7,0)
If the military service episode has been sent from the Health Eligibility
"^DD",2,2.3216,.01,21,8,0)
Center (HEC), the data will be locked and cannot be edited or deleted.
"^DD",2,2.3216,.01,"DT")
3090622
"^DD",2,2.3216,.02,0)
SERVICE SEPARATION DATE^RDX^^0;2^S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA(1) D MSE^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSE-"_DA) X
"^DD",2,2.3216,.02,1,0)
^.1
"^DD",2,2.3216,.02,1,1,0)
2.3216^AENR321602^MUMPS
"^DD",2,2.3216,.02,1,1,1)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.02,1,1,2)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.02,1,1,"%D",0)
^^2^2^3090219^
"^DD",2,2.3216,.02,1,1,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of any changes to the
"^DD",2,2.3216,.02,1,1,"%D",2,0)
SERVICE SEPARATION DATE field.
"^DD",2,2.3216,.02,1,1,"DT")
3090219
"^DD",2,2.3216,.02,1,2,0)
2.3216^ADGRU321602^MUMPS
"^DD",2,2.3216,.02,1,2,1)
D:($T(ADGRU^DGRUDD01)'="")&($G(X)=$P($$LAST^DGMSEUTL(DA(1)),U,2)) ADGRU^DGRUDD01(DA(1))
"^DD",2,2.3216,.02,1,2,2)
D:($T(ADGRU^DGRUDD01)'="")&($G(X)=$P($$LAST^DGMSEUTL(DA(1)),U,2)) ADGRU^DGRUDD01(DA(1))
"^DD",2,2.3216,.02,1,2,"%D",0)
^^9^9^3090622^
"^DD",2,2.3216,.02,1,2,"%D",1,0)
This cross reference is used to remember that changes were made to a
"^DD",2,2.3216,.02,1,2,"%D",2,0)
monitored data field in the PATIENT file (#2) required for a vendor
"^DD",2,2.3216,.02,1,2,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2.3216,.02,1,2,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2.3216,.02,1,2,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2.3216,.02,1,2,"%D",6,0)
interface.
"^DD",2,2.3216,.02,1,2,"%D",7,0)
 
"^DD",2,2.3216,.02,1,2,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2.3216,.02,1,2,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2.3216,.02,1,2,"DT")
3090622
"^DD",2,2.3216,.02,3)
Enter the date on which this patient was separated from this episode of military service.
"^DD",2,2.3216,.02,21,0)
^^8^8^3090126^
"^DD",2,2.3216,.02,21,1,0)
For this veteran applicant, enter the date s/he ended this episode of
"^DD",2,2.3216,.02,21,2,0)
military service. If the military service component is ACTIVATED NATIONAL
"^DD",2,2.3216,.02,21,3,0)
GUARD or ACTIVATED RESERVE, the period entered should be the period of
"^DD",2,2.3216,.02,21,4,0)
activation, so this date is their last day of active duty for this
"^DD",2,2.3216,.02,21,5,0)
episode.  
"^DD",2,2.3216,.02,21,6,0)
                                 
"^DD",2,2.3216,.02,21,7,0)
If the military service episode has been sent from the Health Eligibility
"^DD",2,2.3216,.02,21,8,0)
Center (HEC), the data will be locked and cannot be edited or deleted.
"^DD",2,2.3216,.02,"DT")
3090623
"^DD",2,2.3216,.03,0)
SERVICE BRANCH^RP23'X^DIC(23,^0;3^S DFN=DA(1) K:X=$O(^DIC(23,"B","B.E.C.","")) X I $D(X) D MSE^DGLOCK S DGCOMBR=$G(Y) Q
"^DD",2,2.3216,.03,1,0)
^.1
"^DD",2,2.3216,.03,1,1,0)
2.3216^AENR321603^MUMPS
"^DD",2,2.3216,.03,1,1,1)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.03,1,1,2)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.03,1,1,"%D",0)
^^2^2^3090219^
"^DD",2,2.3216,.03,1,1,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of any changes to the
"^DD",2,2.3216,.03,1,1,"%D",2,0)
SERVICE BRANCH field.
"^DD",2,2.3216,.03,1,1,"DT")
3090219
"^DD",2,2.3216,.03,1,2,0)
2.3216^AFV3216^MUMPS
"^DD",2,2.3216,.03,1,2,1)
Q
"^DD",2,2.3216,.03,1,2,2)
I $P($G(^DPT(DA(1),.321)),U,14)]"" D FVP1^DGRPMS
"^DD",2,2.3216,.03,1,2,"%D",0)
^^4^4^3090226^
"^DD",2,2.3216,.03,1,2,"%D",1,0)
This MUMPS cross-reference acts like a trigger cross-reference.  If the
"^DD",2,2.3216,.03,1,2,"%D",2,0)
Service Branch fields in the Military Service Episode multiple do not
"^DD",2,2.3216,.03,1,2,"%D",3,0)
contain a Filipino Veteran branch of service, the Filipino Vet Proof field
"^DD",2,2.3216,.03,1,2,"%D",4,0)
(#.3214) is deleted.
"^DD",2,2.3216,.03,1,2,"DT")
3090226
"^DD",2,2.3216,.03,1,3,0)
^^TRIGGER^2.3216^.04
"^DD",2,2.3216,.03,1,3,1)
Q
"^DD",2,2.3216,.03,1,3,2)
K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DPT(D0,.3216,D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.3216,DIV(1),0)),DIV=X S $P(^(0),U,4)=DIV,DIH=2.3216,DIG=.04 D ^DICR
"^DD",2,2.3216,.03,1,3,"%D",0)
^^2^2^3090618^
"^DD",2,2.3216,.03,1,3,"%D",1,0)
This trigger will delete the SERVICE COMPONENT sub-field #.04
"^DD",2,2.3216,.03,1,3,"%D",2,0)
when the SERVICE BRANCH sub-field #.03 is changed or deleted.
"^DD",2,2.3216,.03,1,3,"CREATE VALUE")
NO EFFECT
"^DD",2,2.3216,.03,1,3,"DELETE VALUE")
@
"^DD",2,2.3216,.03,1,3,"DT")
3090618
"^DD",2,2.3216,.03,1,3,"FIELD")
SERVICE COMP
"^DD",2,2.3216,.03,3)
Enter the branch of service in which the patient served for this episode of military service.
"^DD",2,2.3216,.03,21,0)
^^4^4^3090126^
"^DD",2,2.3216,.03,21,1,0)
Enter the service branch for this episode of military service.
"^DD",2,2.3216,.03,21,2,0)
                                 
"^DD",2,2.3216,.03,21,3,0)
If the military service episode has been sent from the Health Eligibility
"^DD",2,2.3216,.03,21,4,0)
Center (HEC), the data will be locked and cannot be edited or deleted.
"^DD",2,2.3216,.03,"DT")
3090618
"^DD",2,2.3216,.04,0)
SERVICE COMPONENT^*S^R:REGULAR;V:ACTIVATED RESERVE;G:ACTIVATED NG;^0;4^Q
"^DD",2,2.3216,.04,1,0)
^.1
"^DD",2,2.3216,.04,1,1,0)
2.3216^AENR321604^MUMPS
"^DD",2,2.3216,.04,1,1,1)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.04,1,1,2)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.04,1,1,"%D",0)
^^2^2^3090219^
"^DD",2,2.3216,.04,1,1,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of any changes to the
"^DD",2,2.3216,.04,1,1,"%D",2,0)
SERVICE COMPONENT field.
"^DD",2,2.3216,.04,1,1,"DT")
3090219
"^DD",2,2.3216,.04,3)
Enter the military service component of the patient for this military service episode.
"^DD",2,2.3216,.04,5,1,0)
2.3216^.03^3
"^DD",2,2.3216,.04,12)
Component must be consistent with branch of service. Branch of service is required to enter component.
"^DD",2,2.3216,.04,12.1)
S DIC("S")="I $$VALCOMP^DGRPMS(DA(1),Y,DA_""^MSE"")"
"^DD",2,2.3216,.04,21,0)
^.001^7^7^3090226^^^^
"^DD",2,2.3216,.04,21,1,0)
For this veteran applicant, enter the military service component for this
"^DD",2,2.3216,.04,21,2,0)
episode of military service.
"^DD",2,2.3216,.04,21,3,0)
                                                                 
"^DD",2,2.3216,.04,21,4,0)
If the military service episode has been sent from the Health Eligibility
"^DD",2,2.3216,.04,21,5,0)
Center (HEC), the data will be locked and cannot be edited or deleted.
"^DD",2,2.3216,.04,21,6,0)
                                 
"^DD",2,2.3216,.04,21,7,0)
NATIONAL GUARD IS ONLY VALID FOR BRANCH OF SERVICE ARMY AND AIR FORCE.
"^DD",2,2.3216,.04,"DT")
3090226
"^DD",2,2.3216,.05,0)
SERVICE NUMBER^FX^^0;5^S DFN=DA(1) D MSE^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA(1),0)):$P(^(0),U,9),1:X) D:X?1"SS".E EN^DDIOL(" "_L,"","?$X+2") S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X
"^DD",2,2.3216,.05,1,0)
^.1
"^DD",2,2.3216,.05,1,1,0)
2.3216^AENR321605^MUMPS
"^DD",2,2.3216,.05,1,1,1)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.05,1,1,2)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.05,1,1,"%D",0)
^^2^2^3090219^
"^DD",2,2.3216,.05,1,1,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of any changes to the
"^DD",2,2.3216,.05,1,1,"%D",2,0)
SERVICE NUMBER field.
"^DD",2,2.3216,.05,1,1,"DT")
3090219
"^DD",2,2.3216,.05,3)
Enter the service number assigned to this patient during this episode of military service or 'SS' if it's the same as the SSN. Answer must be 1-15 characters in length.
"^DD",2,2.3216,.05,21,0)
^^1^1^3090126^
"^DD",2,2.3216,.05,21,1,0)
Enter the service number for this episode of military service.
"^DD",2,2.3216,.05,"DT")
3090811
"^DD",2,2.3216,.06,0)
SERVICE DISCHARGE TYPE^RP25'X^DIC(25,^0;6^S DFN=DA(1) D MSE^DGLOCK Q
"^DD",2,2.3216,.06,1,0)
^.1
"^DD",2,2.3216,.06,1,1,0)
2.3216^AENR321606^MUMPS
"^DD",2,2.3216,.06,1,1,1)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.06,1,1,2)
D EVENT^IVMPLOG(DA(1))
"^DD",2,2.3216,.06,1,1,"%D",0)
^^2^2^3090219^
"^DD",2,2.3216,.06,1,1,"%D",1,0)
This MUMPS cross-reference is used to notify HEC of any changes to the
"^DD",2,2.3216,.06,1,1,"%D",2,0)
SERVICE DISCHARGE TYPE field.
"^DD",2,2.3216,.06,1,1,"DT")
3090219
"^DD",2,2.3216,.06,3)
Select from the list the discharge type for this episode of military service.
"^DD",2,2.3216,.06,21,0)
^^5^5^3090126^
"^DD",2,2.3216,.06,21,1,0)
For this veteran applicant, select from the available list the discharge
"^DD",2,2.3216,.06,21,2,0)
type which s/he received for this episode of military service.
"^DD",2,2.3216,.06,21,3,0)
                                 
"^DD",2,2.3216,.06,21,4,0)
If the military service episode has been sent from the Health Eligibility
"^DD",2,2.3216,.06,21,5,0)
Center (HEC), the data will be locked and cannot be edited or deleted.
"^DD",2,2.3216,.06,"DT")
3090224
"^DD",2,2.3216,.07,0)
DATA LOCKED^SX^0:NO;1:YES;^0;7^S DFN=DA(1) D MSE^DGLOCK Q
"^DD",2,2.3216,.07,3)
This field is set to '1' (YES) when the military service episode data can no longer be changed or deleted.
"^DD",2,2.3216,.07,21,0)
^.001^3^3^3090127^^
"^DD",2,2.3216,.07,21,1,0)
When a military service episode is sent from HEC, the Data Locked field
"^DD",2,2.3216,.07,21,2,0)
will be set to '1' (YES).  The data in the military service episode can no
"^DD",2,2.3216,.07,21,3,0)
longer be changed or deleted.
"^DD",2,2.3216,.07,"DT")
3090224
"^DD",25,25,0)
FIELD^NL^1^3
"^DD",25,25,0,"IX","B",25,.01)

"^DD",25,25,0,"NM","TYPE OF DISCHARGE")

"^DD",25,25,0,"PT",2,.324)

"^DD",25,25,0,"PT",2,.329)

"^DD",25,25,0,"PT",2,.3295)

"^DD",25,25,0,"PT",2.3216,.06)

"^DD",25,25,0,"VRPK")
DG
"^DD",25,25,.001,0)
NUMBER^NJ2,0^^ ^K:+X'=X!(X>10)!(X<1)!(X?.E1"."1N.N) X
"^DD",25,25,.001,3)
TYPE A WHOLE NUMBER BETWEEN 1 AND 10
"^DD",25,25,.001,21,0)
^^4^4^2911222^
"^DD",25,25,.001,21,1,0)
This field contains the internal entry number of this type of discharge
"^DD",25,25,.001,21,2,0)
as determined by VA FileMan and the MAS software package.  This number
"^DD",25,25,.001,21,3,0)
may be used by various software modules throughout DHCP.  It must not
"^DD",25,25,.001,21,4,0)
be altered nor should entries be added or removed from this file.
"^DD",25,25,.001,"DT")
2840228
"^DD",25,25,.01,0)
NAME^RF^^0;1^K:$L(X)>20!($L(X)<1)!'(X'?1P.E)!(X'?.ANP) X
"^DD",25,25,.01,1,0)
^.1
"^DD",25,25,.01,1,1,0)
25^B
"^DD",25,25,.01,1,1,1)
S ^DIC(25,"B",$E(X,1,30),DA)=""
"^DD",25,25,.01,1,1,2)
K ^DIC(25,"B",$E(X,1,30),DA)
"^DD",25,25,.01,3)
ANSWER MUST BE 1-20 CHARACTERS IN LENGTH
"^DD",25,25,.01,21,0)
^^4^4^2911222^
"^DD",25,25,.01,21,1,0)
This field contains the name of all allowable military discharge types as
"^DD",25,25,.01,21,2,0)
determined by VACO.  This information is maintained by the MAS software
"^DD",25,25,.01,21,3,0)
package through frequent releases and should not be edited at the site
"^DD",25,25,.01,21,4,0)
level.
"^DD",25,25,.01,"DT")
2840320
"^DD",25,25,1,0)
ABBREVIATION^F^^0;2^K:$L(X)>12!($L(X)<1) X
"^DD",25,25,1,3)
ANSWER MUST BE 1-12 CHARACTERS IN LENGTH
"^DD",25,25,1,21,0)
^^3^3^2911222^
"^DD",25,25,1,21,1,0)
This field contains an abbreviate for this military discharge type.  On
"^DD",25,25,1,21,2,0)
outputs or displays where the full name of the discharge may not fit, this
"^DD",25,25,1,21,3,0)
abbreviation will be displayed instead.
"^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
"^DIC",25,25,0)
TYPE OF DISCHARGE^25
"^DIC",25,25,0,"GL")
^DIC(25,
"^DIC",25,25,"%D",0)
^^4^4^2911222^^
"^DIC",25,25,"%D",1,0)
This file contains the various types of discharge a person who served
"^DIC",25,25,"%D",2,0)
in military service may have been given from that military service.
"^DIC",25,25,"%D",3,0)
This file is maintained by the MAS software package as directed by MAS
"^DIC",25,25,"%D",4,0)
VACO.  This file should not be altered in any way.
"^DIC",25,"B","TYPE OF DISCHARGE",25)

"^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**
EAS*1.0*92
"BLD",8579,0)
EAS*1.0*92^ENROLLMENT APPLICATION SYSTEM^0^3120206^y
"BLD",8579,1,0)
^^1^1^3101026^^^
"BLD",8579,1,1,0)
1010EZ changes for the Military Service Data Sharing (MSDS) project.
"BLD",8579,4,0)
^9.64PA^^
"BLD",8579,6.3)
20
"BLD",8579,"INIT")
EN^EAS1092P
"BLD",8579,"KRN",0)
^9.67PA^8989.52^19
"BLD",8579,"KRN",.4,0)
.4
"BLD",8579,"KRN",.401,0)
.401
"BLD",8579,"KRN",.402,0)
.402
"BLD",8579,"KRN",.403,0)
.403
"BLD",8579,"KRN",.5,0)
.5
"BLD",8579,"KRN",.84,0)
.84
"BLD",8579,"KRN",3.6,0)
3.6
"BLD",8579,"KRN",3.8,0)
3.8
"BLD",8579,"KRN",9.2,0)
9.2
"BLD",8579,"KRN",9.8,0)
9.8
"BLD",8579,"KRN",9.8,"NM",0)
^9.68A^7^6
"BLD",8579,"KRN",9.8,"NM",2,0)
EAS1092P^^0^B3221774
"BLD",8579,"KRN",9.8,"NM",3,0)
EASEZPVD^^0^B31942470
"BLD",8579,"KRN",9.8,"NM",4,0)
EASEZC1^^0^B44574624
"BLD",8579,"KRN",9.8,"NM",5,0)
EASEZC3^^0^B28318349
"BLD",8579,"KRN",9.8,"NM",6,0)
EASEZU3^^0^B72715564
"BLD",8579,"KRN",9.8,"NM",7,0)
EASEZF1^^0^B94302027
"BLD",8579,"KRN",9.8,"NM","B","EAS1092P",2)

"BLD",8579,"KRN",9.8,"NM","B","EASEZC1",4)

"BLD",8579,"KRN",9.8,"NM","B","EASEZC3",5)

"BLD",8579,"KRN",9.8,"NM","B","EASEZF1",7)

"BLD",8579,"KRN",9.8,"NM","B","EASEZPVD",3)

"BLD",8579,"KRN",9.8,"NM","B","EASEZU3",6)

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

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

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

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

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

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

"BLD",8579,"KRN","B",3.6,3.6)

"BLD",8579,"KRN","B",3.8,3.8)

"BLD",8579,"KRN","B",9.2,9.2)

"BLD",8579,"KRN","B",9.8,9.8)

"BLD",8579,"KRN","B",19,19)

"BLD",8579,"KRN","B",19.1,19.1)

"BLD",8579,"KRN","B",101,101)

"BLD",8579,"KRN","B",409.61,409.61)

"BLD",8579,"KRN","B",771,771)

"BLD",8579,"KRN","B",870,870)

"BLD",8579,"KRN","B",8989.51,8989.51)

"BLD",8579,"KRN","B",8989.52,8989.52)

"BLD",8579,"KRN","B",8994,8994)

"BLD",8579,"QUES",0)
^9.62^^0
"BLD",8579,"REQB",0)
^9.611^2^2
"BLD",8579,"REQB",1,0)
EAS*1.0*81^2
"BLD",8579,"REQB",2,0)
EAS*1.0*93^2
"BLD",8579,"REQB","B","EAS*1.0*81",1)

"BLD",8579,"REQB","B","EAS*1.0*93",2)

"INIT")
EN^EAS1092P
"MBREQ")
0
"PKG",187,-1)
1^1
"PKG",187,0)
ENROLLMENT APPLICATION SYSTEM^EAS^ENROLLMENT
"PKG",187,20,0)
^9.402P^1^1
"PKG",187,20,1,0)
2^^EASXDR
"PKG",187,20,1,1)
 
"PKG",187,20,"B",2,1)

"PKG",187,22,0)
^9.49I^1^1
"PKG",187,22,1,0)
1.0^3010315^3010321^66481
"PKG",187,22,1,"PAH",1,0)
92^3120206^123457000
"PKG",187,22,1,"PAH",1,1,0)
^^1^1^3120206
"PKG",187,22,1,"PAH",1,1,1,0)
1010EZ changes for the Military Service Data Sharing (MSDS) project.
"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")
6
"RTN","EAS1092P")
0^2^B3221774
"RTN","EAS1092P",1,0)
EAS1092P ;ALB/LBD - Patch Post-Install functions ; 9/26/11 4:18pm
"RTN","EAS1092P",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**92**;15-MAR-01;Build 20
"RTN","EAS1092P",3,0)
 Q
"RTN","EAS1092P",4,0)
 ;
"RTN","EAS1092P",5,0)
 ;Update fields in 1010EZ MAPPING file #711
"RTN","EAS1092P",6,0)
 ;
"RTN","EAS1092P",7,0)
EN ;Post Install entry point
"RTN","EAS1092P",8,0)
 ; Update fields in 1010EZ MAPPING file #711
"RTN","EAS1092P",9,0)
 D UPD711
"RTN","EAS1092P",10,0)
 Q
"RTN","EAS1092P",11,0)
 ;
"RTN","EAS1092P",12,0)
UPD711 ;Update fields in the 1010EZ MAPPING file #711
"RTN","EAS1092P",13,0)
 ;For the records related to the Last Service Episode, change the
"RTN","EAS1092P",14,0)
 ;data dictionary locations in the fields MAP-TO SUB-FILE (#3) and
"RTN","EAS1092P",15,0)
 ;MAP-TO FIELD (#4) to the new Military Service Episode sub-file
"RTN","EAS1092P",16,0)
 ;#2.3216
"RTN","EAS1092P",17,0)
 N RECNAM,FLD,NUM,LINE,IEN,DATA,ERROR,STOP
"RTN","EAS1092P",18,0)
 D BMES^XPDUTL("Updating records in 1010EZ MAPPING file #711")
"RTN","EAS1092P",19,0)
 F NUM=1:1 S LINE=$T(REC711+NUM) Q:LINE=""!($P(LINE,";",3)="END")  D  Q:$G(STOP)
"RTN","EAS1092P",20,0)
 .S RECNAM=$P(LINE,";",3),FLD=$P(LINE,";",4)
"RTN","EAS1092P",21,0)
 .S IEN=$O(^EAS(711,"B",RECNAM,"")) I 'IEN D ERR711(RECNAM) Q
"RTN","EAS1092P",22,0)
 .S DATA(3)=2.3216,DATA(4)=FLD
"RTN","EAS1092P",23,0)
 .D UPD^DGENDBS(711,IEN,.DATA,.ERROR) I $G(ERROR)]"" D ERR711(RECNAM) Q
"RTN","EAS1092P",24,0)
 .D MES^XPDUTL("  "_RECNAM_"  -- Updated")
"RTN","EAS1092P",25,0)
 Q
"RTN","EAS1092P",26,0)
 ;
"RTN","EAS1092P",27,0)
ERR711(RECNAM) ;Display error message and set STOP=1
"RTN","EAS1092P",28,0)
 ;
"RTN","EAS1092P",29,0)
 N ARR
"RTN","EAS1092P",30,0)
 S STOP=1
"RTN","EAS1092P",31,0)
 S ARR(1)="===================================================="
"RTN","EAS1092P",32,0)
 S ARR(2)="=                   ERROR                          ="
"RTN","EAS1092P",33,0)
 S ARR(3)="===================================================="
"RTN","EAS1092P",34,0)
 S ARR(4)="Unable to update record "_RECNAM
"RTN","EAS1092P",35,0)
 S ARR(5)="===================================================="
"RTN","EAS1092P",36,0)
 ;
"RTN","EAS1092P",37,0)
 D BMES^XPDUTL(.ARR)
"RTN","EAS1092P",38,0)
 ;
"RTN","EAS1092P",39,0)
 Q
"RTN","EAS1092P",40,0)
REC711 ;;RECORD NAME;NEW FIELD NUMBER
"RTN","EAS1092P",41,0)
 ;;LAST BRANCH OF SERVICE;.03
"RTN","EAS1092P",42,0)
 ;;LAST ENTRY DATE;.01
"RTN","EAS1092P",43,0)
 ;;LAST DISCHARGE DATE;.02
"RTN","EAS1092P",44,0)
 ;;LAST DISCHARGE TYPE;.06
"RTN","EAS1092P",45,0)
 ;;SERVICE NUMBER;.05
"RTN","EAS1092P",46,0)
 ;;END
"RTN","EASEZC1")
0^4^B44574624
"RTN","EASEZC1",1,0)
EASEZC1 ;ALB/jap/pjh - Compare 1010EZ Data with VistA Database ; 11/5/09 5:46pm
"RTN","EASEZC1",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51,92**;Mar 15, 2001;Build 20
"RTN","EASEZC1",3,0)
 ;
"RTN","EASEZC1",4,0)
EN(EASAPP,EASDFN) ;this entry point is called as soon as user has selected an Application
"RTN","EASEZC1",5,0)
 ;
"RTN","EASEZC1",6,0)
 ;input  
"RTN","EASEZC1",7,0)
 ;  EASAPP = application ien in file #712
"RTN","EASEZC1",8,0)
 ;  EASDFN = ien in file #2; if 0, then application not yet linked to file #2
"RTN","EASEZC1",9,0)
 ;output
"RTN","EASEZC1",10,0)
 ;  ^TMP("EZDATA"  where
"RTN","EASEZC1",11,0)
 ;  ^TMP("EZDATA",$J,ien_file711)=file#^subfile#^field#^data_id
"RTN","EASEZC1",12,0)
 ;  ^TMP("EZDATA",$J,ien_file711,multiple,1)=ezdata^accept_flag^subien_subfile712.01
"RTN","EASEZC1",13,0)
 ;  ^TMP("EZDATA",$J,ien_file711,multiple,2)=vista_data^link_ien
"RTN","EASEZC1",14,0)
 ;
"RTN","EASEZC1",15,0)
 N IEN,KEY,SUBIEN,ACCEPT,FFF,LINK,MULTIPLE,ORIG,UPD,X,Y,C2711KEY
"RTN","EASEZC1",16,0)
 ;don't continue if passed in dfn doesn't match link
"RTN","EASEZC1",17,0)
 I $G(EASDFN),$P($G(^EAS(712,EASAPP,0)),U,10)'=EASDFN S EASDFN="" Q
"RTN","EASEZC1",18,0)
 ;don't continue if link to file #2 not available
"RTN","EASEZC1",19,0)
 I '$G(EASDFN) S EASDFN=+$P($G(^EAS(712,EASAPP,0)),U,10)
"RTN","EASEZC1",20,0)
 ;if applicant is new to database, user accept/not accept of data elements is constrained 
"RTN","EASEZC1",21,0)
 S EASEZNEW=$P(^EAS(712,EASAPP,0),U,11)
"RTN","EASEZC1",22,0)
 ;display/file/print varies with version
"RTN","EASEZC1",23,0)
 S EASVRSN=$$VERSION^EASEZU4(EASAPP)  ;alb/cmf/51
"RTN","EASEZC1",24,0)
 ;
"RTN","EASEZC1",25,0)
 ; setup local mapping array
"RTN","EASEZC1",26,0)
 D LOCAL711^EASEZU2
"RTN","EASEZC1",27,0)
 ;need this for later
"RTN","EASEZC1",28,0)
 S C2711KEY=+$$KEY711^EASEZU1("TYPE OF BENEFIT-ENROLLMENT")
"RTN","EASEZC1",29,0)
 ;correlate #712 data with tmp mapping array
"RTN","EASEZC1",30,0)
 S SUBIEN=0 F  S SUBIEN=$O(^EAS(712,EASAPP,10,SUBIEN)) Q:'SUBIEN  D
"RTN","EASEZC1",31,0)
 .S X=^EAS(712,EASAPP,10,SUBIEN,0)
"RTN","EASEZC1",32,0)
 .S (IEN,KEY)=$P(X,U,1),MULTIPLE=$P(X,U,2),ACCEPT=$P(X,U,3),FFF=$P(^TMP("EZDATA",$J,IEN),U,1,3)
"RTN","EASEZC1",33,0)
 .S X=$G(^EAS(712,EASAPP,10,SUBIEN,1)),ORIG=$P(X,U,1),UPD=$P(X,U,2)
"RTN","EASEZC1",34,0)
 .;if link exists, it is pointer to Vista database record for an existing patient
"RTN","EASEZC1",35,0)
 .;  or possibly a 'new' patient (i.e., this applicant's data), if this is done post filing
"RTN","EASEZC1",36,0)
 .S LINK=$P($G(^EAS(712,EASAPP,10,SUBIEN,2)),U,2)
"RTN","EASEZC1",37,0)
 .;eliminate some garbage from web app
"RTN","EASEZC1",38,0)
 .I (ORIG="-")!(ORIG="--")!(ORIG="//") S ORIG=""
"RTN","EASEZC1",39,0)
 .Q:((ORIG="")&(UPD=""))
"RTN","EASEZC1",40,0)
 .I UPD="" S ^TMP("EZDATA",$J,IEN,MULTIPLE,1)=ORIG_U_ACCEPT_U_SUBIEN
"RTN","EASEZC1",41,0)
 .E  S ^TMP("EZDATA",$J,IEN,MULTIPLE,1)=UPD_U_ACCEPT_U_SUBIEN
"RTN","EASEZC1",42,0)
 .;if this applicant is new to VistA database, there is no existing patient data for comparison
"RTN","EASEZC1",43,0)
 .;just pickup name,ssn,dob anyway;
"RTN","EASEZC1",44,0)
 .I EASEZNEW,EASDFN D
"RTN","EASEZC1",45,0)
 ..S F=$P(FFF,U,1),SF=$P(FFF,U,2),FD=$P(FFF,U,3)
"RTN","EASEZC1",46,0)
 ..I F=2,SF=2 I (FD=.01)!(FD=.02)!(FD=.03)!(FD=.09) S LINK=EASDFN
"RTN","EASEZC1",47,0)
 ..K F,SF,FD
"RTN","EASEZC1",48,0)
 .;if link to database exists then get VistA data into tmp array
"RTN","EASEZC1",49,0)
 .I 'LINK,$P(FFF,U,1)=2 S LINK=EASDFN
"RTN","EASEZC1",50,0)
 .I LINK D
"RTN","EASEZC1",51,0)
 ..S X=$$GET(LINK,FFF) S:X=-1 X="" S ^TMP("EZDATA",$J,IEN,MULTIPLE,2)=X_U_LINK
"RTN","EASEZC1",52,0)
 ..;special for file #27.11 (Enrollment) data
"RTN","EASEZC1",53,0)
 ..I KEY=C2711KEY D 
"RTN","EASEZC1",54,0)
 ...S CUR=$P($G(^EAS(712,EASAPP,10,SUBIEN,2)),U,2)
"RTN","EASEZC1",55,0)
 ...D ENR(CUR,.VDATA) K CUR
"RTN","EASEZC1",56,0)
 ...S ^TMP("EZDATA",$J,IEN,MULTIPLE,2)=VDATA_U_LINK K VDATA
"RTN","EASEZC1",57,0)
 ..I $G(^TMP("EZDATA",$J,IEN,MULTIPLE,1))="" S ^TMP("EZDATA",$J,IEN,MULTIPLE,1)=U_ACCEPT_U_SUBIEN
"RTN","EASEZC1",58,0)
 D C206^EASEZC3  ;alb/cmf/51 special for ethnicity multiple
"RTN","EASEZC1",59,0)
 D C202^EASEZC3  ;alb/cmf/51 special for race multiple
"RTN","EASEZC1",60,0)
 D C3216^EASEZC3  ;pjh special for military service multiple
"RTN","EASEZC1",61,0)
 ;set 'transformed' data into ^TMP("EZDISP" array
"RTN","EASEZC1",62,0)
 D SORT^EASEZC3(EASAPP)
"RTN","EASEZC1",63,0)
 Q
"RTN","EASEZC1",64,0)
 ;
"RTN","EASEZC1",65,0)
GET(EASLINK,EASFFF) ;get data from existing Patient database
"RTN","EASEZC1",66,0)
 ;input EASLINK  = IEN(s) needed
"RTN","EASEZC1",67,0)
 ;              format: file_ien;subfile_ien
"RTN","EASEZC1",68,0)
 ;       EASFFF = field # for file or subfile
"RTN","EASEZC1",69,0)
 ;              format: file#^subfile#^field#
"RTN","EASEZC1",70,0)
 ;output RTR = data obtained from Patient database; external format;
"RTN","EASEZC1",71,0)
 ;             OR -1 if invalid input
"RTN","EASEZC1",72,0)
 ;
"RTN","EASEZC1",73,0)
 N FILE,SUBFILE,FIELD,RTR,ARRAY,DA,DR,DIC,DIQ,X,Y
"RTN","EASEZC1",74,0)
 S FILE=$P(EASFFF,U,1),SUBFILE=$P(EASFFF,U,2),FIELD=$P(EASFFF,U,3)
"RTN","EASEZC1",75,0)
 I ('FILE)!('FIELD) Q -1
"RTN","EASEZC1",76,0)
 I SUBFILE,SUBFILE'=FILE,EASLINK'[";" Q -1
"RTN","EASEZC1",77,0)
 I EASLINK[";",SUBFILE="" Q -1
"RTN","EASEZC1",78,0)
 ;
"RTN","EASEZC1",79,0)
 I (SUBFILE="")!(SUBFILE=FILE) D
"RTN","EASEZC1",80,0)
 .;data in main file
"RTN","EASEZC1",81,0)
 .S DIQ="ARRAY",DIQ(0)="E",DA=EASLINK,DR=FIELD,DIC=FILE
"RTN","EASEZC1",82,0)
 .D EN^DIQ1
"RTN","EASEZC1",83,0)
 .S RTR=$G(ARRAY(FILE,EASLINK,FIELD,"E"))
"RTN","EASEZC1",84,0)
 I SUBFILE'="",SUBFILE'=FILE D
"RTN","EASEZC1",85,0)
 .;data in subfile
"RTN","EASEZC1",86,0)
 .;in this case EASLINK = file_ien;subfile_ien
"RTN","EASEZC1",87,0)
 .S DIQ="ARRAY",DIQ(0)="E",DA=$P(EASLINK,";",1),DIC=FILE
"RTN","EASEZC1",88,0)
 .;get field # for subfile
"RTN","EASEZC1",89,0)
 .S DR=$O(^DD(FILE,"SB",SUBFILE,0))
"RTN","EASEZC1",90,0)
 .S DR(SUBFILE)=FIELD,DA(SUBFILE)=$P(EASLINK,";",2)
"RTN","EASEZC1",91,0)
 .D EN^DIQ1
"RTN","EASEZC1",92,0)
 .S RTR=$G(ARRAY(SUBFILE,$P(EASLINK,";",2),FIELD,"E"))
"RTN","EASEZC1",93,0)
 Q RTR
"RTN","EASEZC1",94,0)
 ;
"RTN","EASEZC1",95,0)
 ;
"RTN","EASEZC1",96,0)
C2 ;get data from file #2 into local array L711
"RTN","EASEZC1",97,0)
 ;there are alot of fields; quickest just to order thru local mapping file
"RTN","EASEZC1",98,0)
 ;
"RTN","EASEZC1",99,0)
 N KEY,MAP,VDATA,EASAEL
"RTN","EASEZC1",100,0)
 ;2nd subscript for array is always 1 (no multiples)
"RTN","EASEZC1",101,0)
 S KEY=0 F  S KEY=$O(^TMP("EZDATA",$J,KEY)) Q:'KEY  S MAP=^TMP("EZDATA",$J,KEY) I ($P(MAP,U,1)=2)&($P(MAP,U,2)=2) D
"RTN","EASEZC1",102,0)
 .S EASAEL=$P($G(^TMP("EZDATA",$J,KEY,1,1)),U,3)
"RTN","EASEZC1",103,0)
 .S VDATA=$$GET(EASDFN,MAP)
"RTN","EASEZC1",104,0)
 .Q:VDATA=-1  Q:VDATA=""
"RTN","EASEZC1",105,0)
 .;special handling for field #.362
"RTN","EASEZC1",106,0)
 .I ($P(MAP,U,1)=5)="I;14D3." D
"RTN","EASEZC1",107,0)
 ..I VDATA["IN LIEU OF VA COMP" S VDATA="YES"
"RTN","EASEZC1",108,0)
 ..I VDATA="YES, RECEIVING MILITARY RETIREMENT" S VDATA="NO"
"RTN","EASEZC1",109,0)
 .;ien to #711 is 1st subscript of local array is 
"RTN","EASEZC1",110,0)
 .S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC1",111,0)
 .;if data exists in 1010EZ then insert link to file #2
"RTN","EASEZC1",112,0)
 .I EASAEL D LINKUP^EASEZU1(EASAPP,EASAEL,EASDFN)
"RTN","EASEZC1",113,0)
 .;if data does not exist in 1010EZ add subrecord to hold link
"RTN","EASEZC1",114,0)
 .I 'EASAEL D ADD71201^EASEZU1(EASAPP,KEY,EASDFN,1)
"RTN","EASEZC1",115,0)
 Q
"RTN","EASEZC1",116,0)
 ;
"RTN","EASEZC1",117,0)
C201 ;get data in Alias subfile #2.01 into local array L711
"RTN","EASEZC1",118,0)
 ;  using ien(s) local array ALIAS
"RTN","EASEZC1",119,0)
 ;
"RTN","EASEZC1",120,0)
 ;for Alias name(s) - if other name on 1010EZ doesn't match any on file
"RTN","EASEZC1",121,0)
 ;   then it will be auto-accepted; comparision only with matching name if any.
"RTN","EASEZC1",122,0)
 N X,M,B,ADATA,VDATA,KEY,EASAEL
"RTN","EASEZC1",123,0)
 S KEY=+$$KEY711^EASEZU1("APPLICANT OTHER NAME")
"RTN","EASEZC1",124,0)
 S M=0 F  S M=$O(^TMP("EZDATA",$J,KEY,M)) Q:'M  D
"RTN","EASEZC1",125,0)
 .S ADATA=$P(^TMP("EZDATA",$J,KEY,M,1),U,1)
"RTN","EASEZC1",126,0)
 .S B=0 F  S B=$O(ALIAS(B)) Q:'B  D
"RTN","EASEZC1",127,0)
 ..S VDATA=$$GET(ALIAS(B),^TMP("EZDATA",$J,KEY)) Q:VDATA=-1
"RTN","EASEZC1",128,0)
 ..I VDATA=ADATA D
"RTN","EASEZC1",129,0)
 ...S ^TMP("EZDATA",$J,KEY,M,2)=VDATA
"RTN","EASEZC1",130,0)
 ...S EASAEL=$P(^TMP("EZDATA",$J,KEY,M,1),U,3)
"RTN","EASEZC1",131,0)
 ...;only insert link if data exists in 1010EZ
"RTN","EASEZC1",132,0)
 ...I EASAEL D LINKUP^EASEZU1(EASAPP,EASAEL,ALIAS(B))
"RTN","EASEZC1",133,0)
 Q
"RTN","EASEZC1",134,0)
 ;
"RTN","EASEZC1",135,0)
C2101 ;get data in Disposition subfile #2.101 into local array L711
"RTN","EASEZC1",136,0)
 ;  using ien(s) local array DISPOS
"RTN","EASEZC1",137,0)
 ;
"RTN","EASEZC1",138,0)
 ;display data on most recent registration if any
"RTN","EASEZC1",139,0)
 ;2nd subscript of local array always 1 (no multiples)
"RTN","EASEZC1",140,0)
 N B,X,FLD,KEY,ADATA,VDATA,EASAEL
"RTN","EASEZC1",141,0)
 S FLD=0 F  S FLD=$O(^TMP("EZINDEX","A",2,2.101,FLD)) Q:FLD=""  D
"RTN","EASEZC1",142,0)
 .S KEY=$O(^TMP("EZINDEX","A",2,2.101,FLD,0))
"RTN","EASEZC1",143,0)
 .S ADATA=$G(^TMP("EZDATA",$J,KEY,1,1))
"RTN","EASEZC1",144,0)
 .S VDATA=$$GET(DISPOS(1),^TMP("EZDATA",$J,KEY))
"RTN","EASEZC1",145,0)
 .Q:VDATA=-1  Q:VDATA=""
"RTN","EASEZC1",146,0)
 .S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC1",147,0)
 .S EASAEL=$P($G(^TMP("EZDATA",$J,KEY,1,1)),U,3)
"RTN","EASEZC1",148,0)
 .;if data exists in 1010EZ then insert link
"RTN","EASEZC1",149,0)
 .I EASAEL D LINKUP^EASEZU1(EASAPP,EASAEL,DISPOS(1)) Q
"RTN","EASEZC1",150,0)
 .;if data does not exist in 1010EZ add subrecord to hold link
"RTN","EASEZC1",151,0)
 .I 'EASAEL D ADD71201^EASEZU1(EASAPP,KEY,DISPOS(1),1)
"RTN","EASEZC1",152,0)
 Q
"RTN","EASEZC1",153,0)
 ;
"RTN","EASEZC1",154,0)
C2711 ;get data in Current Enrollment #27.11 into local array L711
"RTN","EASEZC1",155,0)
 ;  using ien(s) local array ENROLL
"RTN","EASEZC1",156,0)
 ;
"RTN","EASEZC1",157,0)
 ;2nd subscript of local array always 1 (no multiples)
"RTN","EASEZC1",158,0)
 N X,M,B,ADATA,CUR,DGENR,VDATA,KEY,EASAEL
"RTN","EASEZC1",159,0)
 S KEY=+$$KEY711^EASEZU1("TYPE OF BENEFIT-ENROLLMENT")
"RTN","EASEZC1",160,0)
 S CUR=$G(ENROLL(1)),VDATA=""
"RTN","EASEZC1",161,0)
 Q:CUR=-1
"RTN","EASEZC1",162,0)
 Q:CUR=""
"RTN","EASEZC1",163,0)
 D ENR(CUR,.VDATA)
"RTN","EASEZC1",164,0)
 S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC1",165,0)
 S EASAEL=$P($G(^TMP("EZDATA",$J,KEY,1,1)),U,3)
"RTN","EASEZC1",166,0)
 ;if data exists in 1010EZ then insert link
"RTN","EASEZC1",167,0)
 I EASAEL D LINKUP^EASEZU1(EASAPP,EASAEL,CUR)
"RTN","EASEZC1",168,0)
 ;if data does not exist in 1010EZ add subrecord to hold link
"RTN","EASEZC1",169,0)
 I 'EASAEL D ADD71201^EASEZU1(EASAPP,KEY,CUR,1)
"RTN","EASEZC1",170,0)
 Q
"RTN","EASEZC1",171,0)
 ;
"RTN","EASEZC1",172,0)
ENR(CUR,VDATA) ;get data for current enrollment from VistA database
"RTN","EASEZC1",173,0)
 ;input CUR = pointer to file #27.11
"RTN","EASEZC1",174,0)
 N DGENCAT
"RTN","EASEZC1",175,0)
 S VDATA=""
"RTN","EASEZC1",176,0)
 I $$GET^DGENA(CUR,.DGENR) D
"RTN","EASEZC1",177,0)
 .I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS"))=20) D  Q
"RTN","EASEZC1",178,0)
 ..S VDATA=$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"")
"RTN","EASEZC1",179,0)
 .S DGENCAT=$$CATEGORY^DGENA4(+EASDFN)
"RTN","EASEZC1",180,0)
 .S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
"RTN","EASEZC1",181,0)
 .S VDATA=$S($G(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:"")
"RTN","EASEZC1",182,0)
 .S VDATA=VDATA_$S($G(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP"))))
"RTN","EASEZC1",183,0)
 .S VDATA=VDATA_" | "_DGENCAT
"RTN","EASEZC1",184,0)
 Q
"RTN","EASEZC1",185,0)
 ;
"RTN","EASEZC1",186,0)
C408 ;get data from financial files into tmp mapping array
"RTN","EASEZC1",187,0)
 ;  using ien(s) local array INCREL
"RTN","EASEZC1",188,0)
 ;if no iens for veteran then nothing at all; exit
"RTN","EASEZC1",189,0)
 I $G(INCREL(408,"V",1))="" Q
"RTN","EASEZC1",190,0)
 ;link EZ applicant to veteran data
"RTN","EASEZC1",191,0)
 D A408^EASEZC2
"RTN","EASEZC1",192,0)
 ;link EZ spouse to spouse data
"RTN","EASEZC1",193,0)
 D SP408^EASEZC2
"RTN","EASEZC1",194,0)
 ;link EZ child to child/dependent data
"RTN","EASEZC1",195,0)
 D C1N408^EASEZC2
"RTN","EASEZC1",196,0)
 Q
"RTN","EASEZC3")
0^5^B28318349
"RTN","EASEZC3",1,0)
EASEZC3 ;ALB/jap/pjh - Compare 1010EZ Data with VistA Database (cont.) ; 11/5/09 4:49pm
"RTN","EASEZC3",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**51,92**;Mar 15, 2001;Build 20
"RTN","EASEZC3",3,0)
 ;
"RTN","EASEZC3",4,0)
SORT(EASAPP) ;resort ^TMP("EZDATA", to prepare for screen display
"RTN","EASEZC3",5,0)
 N KEYIEN,DATAKEY,ALL,EZDATA,DISPNM,PTDATA,EASMULT,TRNSFORM,QUES,Q1,QQ,QX,NQ,SECT,FFF,XNAME,MULT
"RTN","EASEZC3",6,0)
 K ^TMP("EZTEMP",$J),^TMP("EZDISP",$J)
"RTN","EASEZC3",7,0)
 S KEYIEN=.1 F  S KEYIEN=$O(^TMP("EZDATA",$J,KEYIEN)) Q:'KEYIEN  I $D(^(KEYIEN))>1 D
"RTN","EASEZC3",8,0)
 .S DATAKEY=$P(^TMP("EZDATA",$J,KEYIEN),U,4),SECT=$P(DATAKEY,";",1),QUES=$P(DATAKEY,";",2)
"RTN","EASEZC3",9,0)
 .;must use variable name EASMULT,EASRTR for any Transform
"RTN","EASEZC3",10,0)
 .S EASMULT=0 F  S EASMULT=$O(^TMP("EZDATA",$J,KEYIEN,EASMULT)) Q:'EASMULT  D
"RTN","EASEZC3",11,0)
 ..;here ALL=ezdata^accept^712.01ien
"RTN","EASEZC3",12,0)
 ..S ALL=$G(^TMP("EZDATA",$J,KEYIEN,EASMULT,1)),EZDATA=$P(ALL,U,1)
"RTN","EASEZC3",13,0)
 ..;ez data conversion for display
"RTN","EASEZC3",14,0)
 ..K EASRTR S TRNSFORM=$G(^EAS(711,KEYIEN,"T")) I TRNSFORM'="" X TRNSFORM S EZDATA=$G(EASRTR)
"RTN","EASEZC3",15,0)
 ..S PTDATA=$P($G(^TMP("EZDATA",$J,KEYIEN,EASMULT,2)),U,1)
"RTN","EASEZC3",16,0)
 ..I EZDATA="" S $P(^TMP("EZDATA",$J,KEYIEN,EASMULT,1),U,1)=""
"RTN","EASEZC3",17,0)
 ..Q:(EZDATA="")&(PTDATA="")
"RTN","EASEZC3",18,0)
 ..S DISPNM=$P($G(^TMP("EZDATA",$J,KEYIEN)),U,5)
"RTN","EASEZC3",19,0)
 ..S ^TMP("EZTEMP",$J,SECT,EASMULT,QUES)=KEYIEN_U_EZDATA_U_$P(ALL,U,2)_U_$P(ALL,U,3)_U_PTDATA
"RTN","EASEZC3",20,0)
 ..Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,0,EASVRSN)  ;alb/cmf/51
"RTN","EASEZC3",21,0)
 ..;set another array so questions fall in proper display order
"RTN","EASEZC3",22,0)
 ..I QUES=+QUES D  Q
"RTN","EASEZC3",23,0)
 ...S ^TMP("EZDISP",$J,SECT,EASMULT,QUES,0)=^TMP("EZTEMP",$J,SECT,EASMULT,QUES)_U_DISPNM
"RTN","EASEZC3",24,0)
 ..S Q1=$E(QUES,1) I Q1=+QUES D  Q
"RTN","EASEZC3",25,0)
 ...S QX=$E(QUES,2,99) S:QX="." QX=0
"RTN","EASEZC3",26,0)
 ...S ^TMP("EZDISP",$J,SECT,EASMULT,Q1,QX)=^TMP("EZTEMP",$J,SECT,EASMULT,QUES)_U_DISPNM
"RTN","EASEZC3",27,0)
 ..S Q1=$E(QUES,1,2) I Q1=+QUES D
"RTN","EASEZC3",28,0)
 ...S QX=$E(QUES,3,99) S:QX="." QX=0
"RTN","EASEZC3",29,0)
 ...S ^TMP("EZDISP",$J,SECT,EASMULT,Q1,QX)=^TMP("EZTEMP",$J,SECT,EASMULT,QUES)_U_DISPNM
"RTN","EASEZC3",30,0)
 ;rearrange Section IIA
"RTN","EASEZC3",31,0)
 S SECT="IIA",MULT=1,QQ="" F  S QQ=$O(^TMP("EZDISP",$J,SECT,MULT,QQ)) Q:QQ>99  Q:QQ=""  D
"RTN","EASEZC3",32,0)
 .S XNAME=$P(^TMP("EZDISP",$J,SECT,MULT,QQ,0),U,6),NQ=$S(XNAME["Sp.":100,1:200)
"RTN","EASEZC3",33,0)
 .S ^TMP("EZDISP",$J,SECT,MULT,NQ,QQ)=^TMP("EZDISP",$J,SECT,MULT,QQ,0)
"RTN","EASEZC3",34,0)
 .K ^TMP("EZDISP",$J,SECT,MULT,QQ,0)
"RTN","EASEZC3",35,0)
 Q
"RTN","EASEZC3",36,0)
 ;
"RTN","EASEZC3",37,0)
OUT ;output current contents of ^TMP("EZTEMP",
"RTN","EASEZC3",38,0)
 ;only used for development from programmer mode
"RTN","EASEZC3",39,0)
 N S,M,OLDM,QUES,Q1,QX,KEYIEN,DISPNM,EZDATA,PTDATA,X
"RTN","EASEZC3",40,0)
 S S="" F  S S=$O(^TMP("EZDISP",$J,S)) Q:S=""  D
"RTN","EASEZC3",41,0)
 .W !!!,"SECTION "_S
"RTN","EASEZC3",42,0)
 .S M=0,OLDM=0 F  S M=$O(^TMP("EZDISP",$J,S,M)) Q:'M  D
"RTN","EASEZC3",43,0)
 ..I M'=OLDM W !
"RTN","EASEZC3",44,0)
 ..S OLDM=M
"RTN","EASEZC3",45,0)
 ..S Q1="" F  S Q1=$O(^TMP("EZDISP",$J,S,M,Q1)) Q:Q1=""  S QX="" F  S QX=$O(^TMP("EZDISP",$J,S,M,Q1,QX)) Q:QX=""  D
"RTN","EASEZC3",46,0)
 ...S (EZDATA,PTDATA)=""
"RTN","EASEZC3",47,0)
 ...S X=^TMP("EZDISP",$J,S,M,Q1,QX),KEYIEN=$P(X,U,1),EZDATA=$P(X,U,2),PTDATA=$P(X,U,5),DISPNM=$P(X,U,6)
"RTN","EASEZC3",48,0)
 ...I Q1>99 S QUES=QX_"."
"RTN","EASEZC3",49,0)
 ...E  S QUES=Q1_$S(QX=0:".",1:QX)
"RTN","EASEZC3",50,0)
 ...W !,"QUESTION "_QUES_"  "_DISPNM
"RTN","EASEZC3",51,0)
 ...W !,?3,"1010EZ : "_EZDATA
"RTN","EASEZC3",52,0)
 ...W !,?3,"VistA  : "_PTDATA
"RTN","EASEZC3",53,0)
 Q
"RTN","EASEZC3",54,0)
 ;
"RTN","EASEZC3",55,0)
C202 ;alb/cmf/51 place race info into local711 array
"RTN","EASEZC3",56,0)
 N M,B,VDATA,KEY,RAC
"RTN","EASEZC3",57,0)
 D GETS^DIQ(2,EASDFN_",","2*","","RAC")
"RTN","EASEZC3",58,0)
 Q:'$D(RAC)
"RTN","EASEZC3",59,0)
 D D202("APPLICANT RACE - AMERICAN INDIAN OR ALASKA NATIVE","AMERI")
"RTN","EASEZC3",60,0)
 D D202("APPLICANT RACE - BLACK OR AFRICAN AMERICAN","BLACK")
"RTN","EASEZC3",61,0)
 D D202("APPLICANT RACE - HAWAIIAN OR PAC ISLANDER","NATIV")
"RTN","EASEZC3",62,0)
 D D202("APPLICANT RACE - ASIAN","ASIAN")
"RTN","EASEZC3",63,0)
 D D202("APPLICANT RACE - WHITE","WHITE")
"RTN","EASEZC3",64,0)
 D D202("APPLICANT RACE - UNANSWERED","UNKNO")
"RTN","EASEZC3",65,0)
 Q
"RTN","EASEZC3",66,0)
 ;
"RTN","EASEZC3",67,0)
D202(AKEY,ARACE) ;
"RTN","EASEZC3",68,0)
 S KEY=+$$KEY711^EASEZU1(AKEY)
"RTN","EASEZC3",69,0)
 S M=0 F  S M=$O(^TMP("EZDATA",$J,KEY,M)) Q:'M  D
"RTN","EASEZC3",70,0)
 .S VDATA=""
"RTN","EASEZC3",71,0)
 .S B=$$Q202(ARACE) I +B S VDATA="YES"_$P(B,U,2)
"RTN","EASEZC3",72,0)
 .S $P(^TMP("EZDATA",$J,KEY,M,2),U,1)=VDATA
"RTN","EASEZC3",73,0)
 Q
"RTN","EASEZC3",74,0)
 ;
"RTN","EASEZC3",75,0)
Q202(X) ;
"RTN","EASEZC3",76,0)
 N I,FLAG
"RTN","EASEZC3",77,0)
 S FLAG=0
"RTN","EASEZC3",78,0)
 Q:'$D(RAC) FLAG
"RTN","EASEZC3",79,0)
 D:'$D(RAC("B"))
"RTN","EASEZC3",80,0)
 .S I=""
"RTN","EASEZC3",81,0)
 .F  S I=$O(RAC(2.02,I)) Q:I=""  D
"RTN","EASEZC3",82,0)
 ..S RAC("B",$E(RAC(2.02,I,.01),1,5))=$E(RAC(2.02,I,.02),1)
"RTN","EASEZC3",83,0)
 I $D(RAC("B",X)) S FLAG=1_U_" ("_RAC("B",X)_")"
"RTN","EASEZC3",84,0)
 ;S I=""
"RTN","EASEZC3",85,0)
 ;F  S I=$O(RAC(2.02,I)) Q:(I="")!(+FLAG)  D
"RTN","EASEZC3",86,0)
 ;.I $E(RAC(2.02,I,.01),1,5)=X S FLAG=1_U_" ("_$E(RAC(2.02,I,.02),1)_")"
"RTN","EASEZC3",87,0)
 Q FLAG
"RTN","EASEZC3",88,0)
 ;              
"RTN","EASEZC3",89,0)
C206 ;alb/cmf/51 place ethnicity info into local711 array
"RTN","EASEZC3",90,0)
 N X,M,B,VDATA,KEY,ETH
"RTN","EASEZC3",91,0)
 D GETS^DIQ(2,EASDFN_",","6*","","ETH")
"RTN","EASEZC3",92,0)
 Q:'$D(ETH)
"RTN","EASEZC3",93,0)
 S KEY=+$$KEY711^EASEZU1("APPLICANT SPANISH, HISPANIC, OR LATIN")
"RTN","EASEZC3",94,0)
 S M=0 F  S M=$O(^TMP("EZDATA",$J,KEY,M)) Q:'M  D
"RTN","EASEZC3",95,0)
 .S VDATA="",B=""
"RTN","EASEZC3",96,0)
 .D  S $P(^TMP("EZDATA",$J,KEY,M,2),U,1)=VDATA
"RTN","EASEZC3",97,0)
 ..S B=$$Q206("NOT") I +B S VDATA="NO"_$P(B,U,2) Q
"RTN","EASEZC3",98,0)
 ..S B=$$Q206("HIS") I +B S VDATA="YES"_$P(B,U,2) Q
"RTN","EASEZC3",99,0)
 ..S B=$$Q206("DEC") I +B S VDATA="DECLINED"_$P(B,U,2) Q
"RTN","EASEZC3",100,0)
 ..S B=$$Q206("UNK") I +B S VDATA="UNKNOWN"_$P(B,U,2) Q
"RTN","EASEZC3",101,0)
 ..Q
"RTN","EASEZC3",102,0)
 .Q
"RTN","EASEZC3",103,0)
 Q
"RTN","EASEZC3",104,0)
 ;
"RTN","EASEZC3",105,0)
Q206(X) ;
"RTN","EASEZC3",106,0)
 N I,FLAG
"RTN","EASEZC3",107,0)
 S FLAG=0
"RTN","EASEZC3",108,0)
 Q:'$D(ETH) FLAG
"RTN","EASEZC3",109,0)
 D:'$D(ETH("B")) 
"RTN","EASEZC3",110,0)
 .S I=""
"RTN","EASEZC3",111,0)
 .F  S I=$O(ETH(2.06,I)) Q:I=""  D 
"RTN","EASEZC3",112,0)
 ..S ETH("B",$E(ETH(2.06,I,.01),1,3))=$E(ETH(2.06,I,.02),1)
"RTN","EASEZC3",113,0)
 I $D(ETH("B",X)) S FLAG=1_U_" ("_ETH("B",X)_")"
"RTN","EASEZC3",114,0)
 ;S I=""
"RTN","EASEZC3",115,0)
 ;F  S I=$O(ETH(2.06,I)) Q:(I="")!(+FLAG)  D
"RTN","EASEZC3",116,0)
 ;.I $E(ETH(2.06,I,.01),1,3)=X S FLAG=1_U_" ("_$E(ETH(2.06,I,.02),1)_")"
"RTN","EASEZC3",117,0)
 Q FLAG
"RTN","EASEZC3",118,0)
 ;
"RTN","EASEZC3",119,0)
C3216 ;Military Service
"RTN","EASEZC3",120,0)
 ;
"RTN","EASEZC3",121,0)
 ;Use old VistA data if no new format data present
"RTN","EASEZC3",122,0)
 I '$D(^DPT(EASDFN,.3216)) D MOVMSE^DGMSEUTL(EASDFN)
"RTN","EASEZC3",123,0)
 ;Get most recent episode
"RTN","EASEZC3",124,0)
 S X=$O(^DPT(EASDFN,.3216,"B",""),-1) Q:'X
"RTN","EASEZC3",125,0)
 S X=$O(^DPT(EASDFN,.3216,"B",X,"")) Q:'X
"RTN","EASEZC3",126,0)
 ;Extract fields from most recent episode as [LAST]
"RTN","EASEZC3",127,0)
 S KEY=+$$KEY711^EASEZU1("LAST ENTRY DATE")
"RTN","EASEZC3",128,0)
 S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.01")
"RTN","EASEZC3",129,0)
 I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZC3",130,0)
 S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC3",131,0)
 S KEY=+$$KEY711^EASEZU1("LAST DISCHARGE DATE")
"RTN","EASEZC3",132,0)
 S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.02")
"RTN","EASEZC3",133,0)
 I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZC3",134,0)
 S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC3",135,0)
 S KEY=+$$KEY711^EASEZU1("LAST BRANCH OF SERVICE")
"RTN","EASEZC3",136,0)
 S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.03")
"RTN","EASEZC3",137,0)
 I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZC3",138,0)
 S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC3",139,0)
 S KEY=+$$KEY711^EASEZU1("SERVICE NUMBER")
"RTN","EASEZC3",140,0)
 S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.05")
"RTN","EASEZC3",141,0)
 I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZC3",142,0)
 S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC3",143,0)
 S KEY=+$$KEY711^EASEZU1("LAST DISCHARGE TYPE")
"RTN","EASEZC3",144,0)
 S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.06")
"RTN","EASEZC3",145,0)
 I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZC3",146,0)
 S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZC3",147,0)
 Q
"RTN","EASEZF1")
0^7^B94302027
"RTN","EASEZF1",1,0)
EASEZF1 ;ALB/jap,TM - Filing 1010EZ Data to Patient Database ; 8/16/11 4:04pm
"RTN","EASEZF1",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51,57,62,70,93,92**;Mar 15, 2001;Build 20
"RTN","EASEZF1",3,0)
 ;
"RTN","EASEZF1",4,0)
F2(EASAPP,EASDFN) ;file to Patient record in #2
"RTN","EASEZF1",5,0)
 ;input EASDFN = ien to #2
"RTN","EASEZF1",6,0)
 N KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,SECT,QUES,SUBIEN,ACCEPT,EZDATA,PTDATA,LINK,EROOT,EAS,ERR,IENS,ARRAY,ELIGVER
"RTN","EASEZF1",7,0)
 N DIC,DIQ,DA,DR,X,Y,EZSTRG
"RTN","EASEZF1",8,0)
 Q:'$G(EASDFN)
"RTN","EASEZF1",9,0)
 ;L +^DPT(EASDFN) ;Handling locking in EASEZFM - EAS*1*93
"RTN","EASEZF1",10,0)
 I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP)
"RTN","EASEZF1",11,0)
 ;EAS*1.0*70 - Special handling for Foreign Address
"RTN","EASEZF1",12,0)
 S KEYIEN=+$$KEY711^EASEZU1("APPLICANT COUNTRY")
"RTN","EASEZF1",13,0)
 S DATAKEY=$P(^TMP("EZDATA",$J,KEYIEN),U,4)
"RTN","EASEZF1",14,0)
 S SECT=$P(DATAKEY,";"),QUES=$P(DATAKEY,";",2)
"RTN","EASEZF1",15,0)
 S EZDATA=$P($G(^TMP("EZTEMP",$J,SECT,1,QUES)),U,2)
"RTN","EASEZF1",16,0)
 I EZDATA="UNITED STATES" S EZSTRG="APPLICANT PROVINCE^APPLICANT POSTAL CODE"
"RTN","EASEZF1",17,0)
 E  S EZSTRG="APPLICANT COUNTY^APPLICANT STATE^APPLICANT ZIP"
"RTN","EASEZF1",18,0)
 F X=1:1 S DATANM=$P(EZSTRG,U,X) Q:DATANM=""  D
"RTN","EASEZF1",19,0)
 . S KEYIEN=+$$KEY711^EASEZU1(DATANM) Q:(KEYIEN=.1)
"RTN","EASEZF1",20,0)
 . S DATAKEY=$P(^TMP("EZDATA",$J,KEYIEN),U,4)
"RTN","EASEZF1",21,0)
 . S SECT=$P(DATAKEY,";"),QUES=$P(DATAKEY,";",2)
"RTN","EASEZF1",22,0)
 . K ^TMP("EZDATA",$J,KEYIEN),^TMP("EZTEMP",$J,SECT,1,QUES)
"RTN","EASEZF1",23,0)
 ;
"RTN","EASEZF1",24,0)
 S KEYIEN=0
"RTN","EASEZF1",25,0)
 F  S KEYIEN=$O(^TMP("EZDATA",$J,KEYIEN)) Q:'KEYIEN  D
"RTN","EASEZF1",26,0)
 . S LN=^TMP("EZDATA",$J,KEYIEN),FILE=$P(LN,U,1)
"RTN","EASEZF1",27,0)
 . Q:FILE'=2
"RTN","EASEZF1",28,0)
 . S SUBFILE=$P(LN,U,2),FLD=$P(LN,U,3),DATAKEY=$P(LN,U,4)
"RTN","EASEZF1",29,0)
 . S SECT=$P(DATAKEY,";",1),QUES=$P(DATAKEY,";",2)
"RTN","EASEZF1",30,0)
 . ;call to suppress may be redundant
"RTN","EASEZF1",31,0)
 . Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN)
"RTN","EASEZF1",32,0)
 . ;in file #2, multiple is always 1
"RTN","EASEZF1",33,0)
 . S MULTIPLE=1
"RTN","EASEZF1",34,0)
 . Q:'$D(^TMP("EZDATA",$J,KEYIEN,MULTIPLE,1))
"RTN","EASEZF1",35,0)
 . S X=$G(^TMP("EZTEMP",$J,SECT,MULTIPLE,QUES))
"RTN","EASEZF1",36,0)
 . Q:$P(X,U,1)'=KEYIEN
"RTN","EASEZF1",37,0)
 . S EZDATA=$P(X,U,2),ACCEPT=$P(X,U,3),SUBIEN=$P(X,U,4),PTDATA=$P(X,U,5)
"RTN","EASEZF1",38,0)
 . Q:EZDATA=""
"RTN","EASEZF1",39,0)
 . Q:'SUBIEN
"RTN","EASEZF1",40,0)
 . ;special handling for Designee
"RTN","EASEZF1",41,0)
 . I FLD=.3405 S EZDATA=$S(EZDATA="NEXT OF KIN":"YES",1:"NO")
"RTN","EASEZF1",42,0)
 . ;strip off code display from county
"RTN","EASEZF1",43,0)
 . I SECT="I",QUES="9E." S EZDATA=$P(EZDATA," (",1)
"RTN","EASEZF1",44,0)
 . ;get file #2 ien; always same as EASDFN
"RTN","EASEZF1",45,0)
 . S LINK=EASDFN
"RTN","EASEZF1",46,0)
 . ;don't continue if data item not accepted
"RTN","EASEZF1",47,0)
 . Q:ACCEPT<1
"RTN","EASEZF1",48,0)
 . ;process subfile data elsewhere
"RTN","EASEZF1",49,0)
 . I SUBFILE=2.01 Q
"RTN","EASEZF1",50,0)
 . I SUBFILE=2.101 Q
"RTN","EASEZF1",51,0)
 . I SUBFILE=2.02 D F202^EASEZF1(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) Q
"RTN","EASEZF1",52,0)
 . I SUBFILE=2.06 D F206^EASEZF1(SUBFILE,DATAKEY,EZDATA,SUBIEN) Q
"RTN","EASEZF1",53,0)
 . ;Special for Military Service Episodes
"RTN","EASEZF1",54,0)
 . I SUBFILE=2.3216 D:KEYIEN=28  Q
"RTN","EASEZF1",55,0)
 . . D F23216(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN)
"RTN","EASEZF1",56,0)
 . ;special conversion to file data to field #.328
"RTN","EASEZF1",57,0)
 . I FLD=.328 D
"RTN","EASEZF1",58,0)
 . . S X=$$UC^EASEZT1(EZDATA) I X="SSN" D
"RTN","EASEZF1",59,0)
 . . . ;allow SSN as Service Number only if field #.328 in patient record is null;
"RTN","EASEZF1",60,0)
 . . . S PTSSN=$$GETANY^EASEZU1(EASAPP,EASDFN,SUBIEN)
"RTN","EASEZF1",61,0)
 . . . I PTSSN="" S EZDATA="SS" Q
"RTN","EASEZF1",62,0)
 . . . ;otherwise Applicant SSN must match Patient SSN
"RTN","EASEZF1",63,0)
 . . . S KK=$$KEY711^EASEZU1("APPLICANT SOCIAL SECURITY NUMBER")
"RTN","EASEZF1",64,0)
 . . . S EZSSN=$P($G(^TMP("EZDATA",$J,KK,1,1)),U,1),EZSSN=$TR(EZSSN,"-","")
"RTN","EASEZF1",65,0)
 . . . I EZSSN=PTSSN S EZDATA="SS" Q
"RTN","EASEZF1",66,0)
 . . . S EZDATA="ssn"
"RTN","EASEZF1",67,0)
 . . K KK,PTSSN,EZSSN
"RTN","EASEZF1",68,0)
 . ;special for fields #.092 & #.093
"RTN","EASEZF1",69,0)
 . I FILE=2,((FLD=.092)!(FLD=.093)) D FPOB(DATAKEY,EZDATA,SUBIEN,PTDATA) Q
"RTN","EASEZF1",70,0)
 . ;don't need these lines after 672
"RTN","EASEZF1",71,0)
 . ;special for field #.362
"RTN","EASEZF1",72,0)
 . ;I FILE=2,FLD=.362,EASVRSN>5.99 I (EZDATA="Y")!(EZDATA="YES") S EZDATA="YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA COMPENSATION"
"RTN","EASEZF1",73,0)
 . Q:EZDATA=PTDATA
"RTN","EASEZF1",74,0)
 . ;repeat check for verified eligibility;
"RTN","EASEZF1",75,0)
 . ;do not file certain fields if eligibility verified
"RTN","EASEZF1",76,0)
 . K ARRAY
"RTN","EASEZF1",77,0)
 . S DA=EASDFN,DIC="^DPT(",DR=".3611;.3613",DIQ(0)="I",DIQ="ARRAY"
"RTN","EASEZF1",78,0)
 . D EN^DIQ1 K DA,DIC,DIQ,DR
"RTN","EASEZF1",79,0)
 . I $G(ARRAY(2,EASDFN,.3611,"I"))="V",$G(ARRAY(2,EASDFN,.3613,"I"))="H" S ELIGVER=1
"RTN","EASEZF1",80,0)
 . I FLD=.313,$G(ARRAY(2,EASDFN,.3611,"I"))="V" Q
"RTN","EASEZF1",81,0)
 . I $G(ELIGVER),((FLD=.301)!(FLD=.302)!(FLD=.36235)) Q
"RTN","EASEZF1",82,0)
 . ;special for field #.32102 - Agent Orange Exposure . DATAKEY = I;14F
"RTN","EASEZF1",83,0)
 . I FLD=.32102 D F32102^EASEZF1A(EASAPP,EASDFN,EZDATA)
"RTN","EASEZF1",84,0)
 . ;setup to call FM database server using EASDFN as file #2 record
"RTN","EASEZF1",85,0)
 . K EAS,ERR
"RTN","EASEZF1",86,0)
 . S IENS=EASDFN_","
"RTN","EASEZF1",87,0)
 . S EROOT="EAS("_EASAPP_")"
"RTN","EASEZF1",88,0)
 . D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
"RTN","EASEZF1",89,0)
 . ;try to resolve possible invalid input for free text fields due to length
"RTN","EASEZF1",90,0)
 . I $D(ERR) D RESOLVE
"RTN","EASEZF1",91,0)
 . I $D(ERR) D ERROR^EASEZF2("AP",MULTIPLE,.ERR,"LINK")
"RTN","EASEZF1",92,0)
 . ;file to database if input is valid
"RTN","EASEZF1",93,0)
 . I '$D(ERR) D
"RTN","EASEZF1",94,0)
 . . ;2/1/2001 - don't attempt to file Name, SSN, DOB; too many complications;
"RTN","EASEZF1",95,0)
 . . ;  example: if system assigns pseudo-SSN to new patient, user could overwrite;
"RTN","EASEZF1",96,0)
 . . ;  example: if applicant matched to existing patient, all critical identifying
"RTN","EASEZF1",97,0)
 . . ;           data could be overwritten; could impact HEC as well
"RTN","EASEZF1",98,0)
 . . D FILE^DIE("S",EROOT,"ERR")
"RTN","EASEZF1",99,0)
 . . ;set any replaced data into subfile #712.01 for audit
"RTN","EASEZF1",100,0)
 . . S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
"RTN","EASEZF1",101,0)
 ;
"RTN","EASEZF1",102,0)
 ;L -^DPT(EASDFN) ;Handling locking in EASEZFM - EAS*1*93
"RTN","EASEZF1",103,0)
 Q
"RTN","EASEZF1",104,0)
 ;
"RTN","EASEZF1",105,0)
RESOLVE ;try to resolve invalid input for free text fields only
"RTN","EASEZF1",106,0)
 ;see if mapped to free text field
"RTN","EASEZF1",107,0)
 N FDEF,FTYPE,MAX
"RTN","EASEZF1",108,0)
 I (SUBFILE=FILE)!(SUBFILE="") S FDEF=FILE
"RTN","EASEZF1",109,0)
 E  S FDEF=SUBFILE
"RTN","EASEZF1",110,0)
 S FTYPE=$$GET1^DID(FDEF,FLD,"","TYPE")
"RTN","EASEZF1",111,0)
 Q:FTYPE'="FREE TEXT"
"RTN","EASEZF1",112,0)
 S MAX=$$GET1^DID(FDEF,FLD,"","FIELD LENGTH")
"RTN","EASEZF1",113,0)
 S EZDATA=$E(EZDATA,1,MAX)
"RTN","EASEZF1",114,0)
 K ERR
"RTN","EASEZF1",115,0)
 D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
"RTN","EASEZF1",116,0)
 ;if still sets ERR array then won't be filed to database
"RTN","EASEZF1",117,0)
 Q
"RTN","EASEZF1",118,0)
 ;
"RTN","EASEZF1",119,0)
F202(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) ;add or edit subrecord in subfile #2.02
"RTN","EASEZF1",120,0)
 ;input SUBFILE = 2.02
"RTN","EASEZF1",121,0)
 ;      DATAKEY = data item identifier, e.g., I;4B.
"RTN","EASEZF1",122,0)
 ;      EZDATA  = in these cases, either "N(o)" or "Y(es)"
"RTN","EASEZF1",123,0)
 ;      SUBIEN  = subrecord # for data in #712/#10
"RTN","EASEZF1",124,0)
 ;      KEYIEN  = record # for data element in #711
"RTN","EASEZF1",125,0)
 N X,N,DATANM,EROOT,EAS,EIEN,ERR,FLD,IENS,EASARRAY,LINK,OUT,K1,K3
"RTN","EASEZF1",126,0)
 Q:EZDATA'["Y"
"RTN","EASEZF1",127,0)
 Q:SUBFILE'=2.02
"RTN","EASEZF1",128,0)
 ;covert data to corresponding file #10 pointer
"RTN","EASEZF1",129,0)
 S X=$$KEY711^EASEZU1(DATAKEY)
"RTN","EASEZF1",130,0)
 S K1=$P(X,U,1),DATANM=$P(X,U,2),K3=$P(X,U,3)
"RTN","EASEZF1",131,0)
 Q:(DATANM="")
"RTN","EASEZF1",132,0)
 Q:(K1'=KEYIEN)
"RTN","EASEZF1",133,0)
 Q:(K3'=DATAKEY)
"RTN","EASEZF1",134,0)
 S DATANM=$P(DATANM," - ",2),DATANM=$E(DATANM,1,30)
"RTN","EASEZF1",135,0)
 I DATANM["UNANSWERED" S DATANM="UNKNOWN BY PATIENT"
"RTN","EASEZF1",136,0)
 S EZDATA=$O(^DIC(10,"B",DATANM,0))
"RTN","EASEZF1",137,0)
 Q:EZDATA=""
"RTN","EASEZF1",138,0)
 D I202^EASEZI(EASDFN,.EASARRAY)
"RTN","EASEZF1",139,0)
 ;if matching race already exists, edit method only
"RTN","EASEZF1",140,0)
 S OUT=0,N=0 F  S N=$O(EASARRAY(N)) Q:'N  D
"RTN","EASEZF1",141,0)
 . Q:($P(EASARRAY(N),";",2)'=EZDATA)
"RTN","EASEZF1",142,0)
 . K EAS,ERR
"RTN","EASEZF1",143,0)
 . S IENS=EZDATA_","_EASDFN_","
"RTN","EASEZF1",144,0)
 . S EROOT="EAS("_EASAPP_")"
"RTN","EASEZF1",145,0)
 . S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=1
"RTN","EASEZF1",146,0)
 . D FILE^DIE("S",EROOT,"ERR")
"RTN","EASEZF1",147,0)
 . S OUT=1
"RTN","EASEZF1",148,0)
 ;no matching race in patient record, add new subrecord
"RTN","EASEZF1",149,0)
 I 'OUT D
"RTN","EASEZF1",150,0)
 . K ERR
"RTN","EASEZF1",151,0)
 . S EROOT="EAS("_EASAPP_")"
"RTN","EASEZF1",152,0)
 . S IENS="+1,"_EASDFN_",",EIEN(1)=EZDATA
"RTN","EASEZF1",153,0)
 . S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA
"RTN","EASEZF1",154,0)
 . S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=1
"RTN","EASEZF1",155,0)
 . D UPDATE^DIE("S",EROOT,"EIEN","ERR")
"RTN","EASEZF1",156,0)
 . I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
"RTN","EASEZF1",157,0)
 . S LINK=EASDFN_";"_EZDATA
"RTN","EASEZF1",158,0)
 . S ^EAS(712,EASAPP,10,SUBIEN,2)=U_LINK
"RTN","EASEZF1",159,0)
 Q
"RTN","EASEZF1",160,0)
 ;
"RTN","EASEZF1",161,0)
F206(SUBFILE,DATAKEY,EZDATA,SUBIEN) ;add subrecord in subfile #2.06 
"RTN","EASEZF1",162,0)
 ;input SUBFILE = 2.06
"RTN","EASEZF1",163,0)
 ;      DATAKEY = data item identifier, e.g., I;4A.
"RTN","EASEZF1",164,0)
 ;      EZDATA  = in these cases, either "N(o)" or "Y(es)"
"RTN","EASEZF1",165,0)
 N X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,PTDATA
"RTN","EASEZF1",166,0)
 Q:SUBFILE'=2.06
"RTN","EASEZF1",167,0)
 D I206^EASEZI(EASDFN,.EASARRAY)
"RTN","EASEZF1",168,0)
 S LINK=$P($G(EASARRAY(1)),";",2),PTDATA="" I LINK S PTDATA=$P(^DPT(EASDFN,.06,LINK,0),U,1)
"RTN","EASEZF1",169,0)
 I DATAKEY="I;4A." S EZDATA=$S(EZDATA["Y":"H",$E(EZDATA,1)="N":"N",1:"U") D
"RTN","EASEZF1",170,0)
 . S EROOT="EAS("_EASAPP_")"
"RTN","EASEZF1",171,0)
 . S IENS="+1,"_EASDFN_","
"RTN","EASEZF1",172,0)
 . S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA
"RTN","EASEZF1",173,0)
 . S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)="SELF IDENTIFICATION"
"RTN","EASEZF1",174,0)
 . D UPDATE^DIE("ES",EROOT,"EIEN","ERR")
"RTN","EASEZF1",175,0)
 . S LINK=EASDFN_";"_$G(EIEN(1))
"RTN","EASEZF1",176,0)
 . S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
"RTN","EASEZF1",177,0)
 Q
"RTN","EASEZF1",178,0)
 ;
"RTN","EASEZF1",179,0)
FPOB(DATAKEY,EZDATA,SUBIEN,PTDATA) ;add or edit pob city & state
"RTN","EASEZF1",180,0)
 ;input DATAKEY = data item identifier, either, I;8A. or I;8B.
"RTN","EASEZF1",181,0)
 ;      EZDATA  = free text if city or 
"RTN","EASEZF1",182,0)
 ;                state abbrv if state
"RTN","EASEZF1",183,0)
 ;filing for both city & state only done when datakey=I;8A.
"RTN","EASEZF1",184,0)
 N X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,SECT,QUES,XIEN,XDATA
"RTN","EASEZF1",185,0)
 Q:(DATAKEY'="I;8A.")
"RTN","EASEZF1",186,0)
 Q:(EZDATA="")
"RTN","EASEZF1",187,0)
 Q:(EZDATA=PTDATA)
"RTN","EASEZF1",188,0)
 ;file pob city
"RTN","EASEZF1",189,0)
 K EAS,ERR
"RTN","EASEZF1",190,0)
 S FLD=.092,LINK=EASDFN
"RTN","EASEZF1",191,0)
 S IENS=EASDFN_","
"RTN","EASEZF1",192,0)
 S EROOT="EAS("_EASAPP_")"
"RTN","EASEZF1",193,0)
 D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
"RTN","EASEZF1",194,0)
 I $D(ERR) D RESOLVE
"RTN","EASEZF1",195,0)
 I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
"RTN","EASEZF1",196,0)
 D FILE^DIE("ES",EROOT,"ERR")
"RTN","EASEZF1",197,0)
 ;set any replaced data into subfile #712.01 for audit
"RTN","EASEZF1",198,0)
 S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
"RTN","EASEZF1",199,0)
 ;file pob state
"RTN","EASEZF1",200,0)
 S (EZDATA,XDATA)=""
"RTN","EASEZF1",201,0)
 S DATAKEY="I;8B.",SECT=$P(DATAKEY,";",1),QUES=$P(DATAKEY,";",2)
"RTN","EASEZF1",202,0)
 S X=$G(^TMP("EZTEMP",$J,SECT,1,QUES)),EZDATA=$P(X,U,2),XIEN=$P(X,U,4),XDATA=$P(X,U,5)
"RTN","EASEZF1",203,0)
 Q:(EZDATA="")
"RTN","EASEZF1",204,0)
 Q:(EZDATA=XDATA)
"RTN","EASEZF1",205,0)
 I (EZDATA["FOREIGN")!(EZDATA="FC")!(EZDATA="FG") S EZDATA="FOREIGN"
"RTN","EASEZF1",206,0)
 K EAS,ERR
"RTN","EASEZF1",207,0)
 S FLD=.093
"RTN","EASEZF1",208,0)
 S IENS=EASDFN_","
"RTN","EASEZF1",209,0)
 S EROOT="EAS("_EASAPP_")"
"RTN","EASEZF1",210,0)
 D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
"RTN","EASEZF1",211,0)
 I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
"RTN","EASEZF1",212,0)
 D FILE^DIE("ES",EROOT,"ERR")
"RTN","EASEZF1",213,0)
 S ^EAS(712,EASAPP,10,XIEN,2)=XDATA_U_LINK
"RTN","EASEZF1",214,0)
 Q
"RTN","EASEZF1",215,0)
 ;
"RTN","EASEZF1",216,0)
F23216(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) ;add subrecord in subfile #2.3216
"RTN","EASEZF1",217,0)
 ;input SUBFILE = 2.3216
"RTN","EASEZF1",218,0)
 ;      DATAKEY = data item identifier, e.g., I;13A.
"RTN","EASEZF1",219,0)
 ;      EZDATA  = data value in external format
"RTN","EASEZF1",220,0)
 ;      KEYIEN  = record # for data element in #711
"RTN","EASEZF1",221,0)
 ;
"RTN","EASEZF1",222,0)
 ;Values for KEYIEN                     DATAKEY
"RTN","EASEZF1",223,0)
 ;           28 - Branch of Service     I;13A
"RTN","EASEZF1",224,0)
 ;           29 - Last Entry Date       I;13B
"RTN","EASEZF1",225,0)
 ;           30 - Last Separation Date  I;13C
"RTN","EASEZF1",226,0)
 ;           31 - Last Discharge Type   I;13D
"RTN","EASEZF1",227,0)
 ;           32 - Last Service Number   I;13E
"RTN","EASEZF1",228,0)
 ;
"RTN","EASEZF1",229,0)
 Q:SUBFILE'=2.3216
"RTN","EASEZF1",230,0)
 ;
"RTN","EASEZF1",231,0)
 N X,EAS,EASARRAY,LINK,PTDATA,SUBIEN
"RTN","EASEZF1",232,0)
 ;Get episodes from VistA into EASARRAY
"RTN","EASEZF1",233,0)
 D GETMSE^DGMSEUTL(EASDFN,.EASARRAY)
"RTN","EASEZF1",234,0)
 ;Move last VistA episode into PDATA (for future use in edit option)
"RTN","EASEZF1",235,0)
 S LINK=$G(EASARRAY(1,"IEN")),PTDATA=""
"RTN","EASEZF1",236,0)
 I LINK S PTDATA=$G(^DPT(EASDFN,2.3216,LINK,0))
"RTN","EASEZF1",237,0)
 ;
"RTN","EASEZF1",238,0)
 ;Only proceed to add new subrecord if no .3216 data exists
"RTN","EASEZF1",239,0)
 Q:PTDATA'=""
"RTN","EASEZF1",240,0)
 ;
"RTN","EASEZF1",241,0)
TBD1 ;if this is entirely new and later than VistA episodes, allow add?
"RTN","EASEZF1",242,0)
 ;
"RTN","EASEZF1",243,0)
 ; (compare EDATE to last episode in PDATA and allow addition if it is;  a date later than last separation date)
"RTN","EASEZF1",244,0)
 ;
"RTN","EASEZF1",245,0)
TBD2 ;if matching episode already exists, allow update?
"RTN","EASEZF1",246,0)
 ;
"RTN","EASEZF1",247,0)
 ; (see code in F202^EASEZF1 for update, get last IENS from EASARRAY)
"RTN","EASEZF1",248,0)
 ;
"RTN","EASEZF1",249,0)
 ;Get last episode 1010EZ fields from ^TMP("EZDATA"
"RTN","EASEZF1",250,0)
 N BOS,EDATE,SDATE,DTYPE,SERVNO
"RTN","EASEZF1",251,0)
 S BOS=$P($G(^TMP("EZDATA",$J,28,1,1)),U) Q:BOS=""
"RTN","EASEZF1",252,0)
 S EDATE=$P($G(^TMP("EZDATA",$J,29,1,1)),U) Q:EDATE=""
"RTN","EASEZF1",253,0)
 S SDATE=$P($G(^TMP("EZDATA",$J,30,1,1)),U) Q:SDATE=""
"RTN","EASEZF1",254,0)
 S DTYPE=$P($G(^TMP("EZDATA",$J,31,1,1)),U) Q:DTYPE=""
"RTN","EASEZF1",255,0)
 S SERVNO=$P($G(^TMP("EZDATA",$J,32,1,1)),U)
"RTN","EASEZF1",256,0)
 ;
"RTN","EASEZF1",257,0)
 ;Special conversion of service number (see code in EASEZF1)
"RTN","EASEZF1",258,0)
 I $$UC^EASEZT1(SERVNO)="SSN" D
"RTN","EASEZF1",259,0)
 .N EZSSN,KK,PTSSN
"RTN","EASEZF1",260,0)
 .;allow SSN as Service Number if service number in patient last
"RTN","EASEZF1",261,0)
 .;.3216 record is null. Always case if no .3216 data exists
"RTN","EASEZF1",262,0)
 .S PTSSN=$P(PTDATA,U,5)
"RTN","EASEZF1",263,0)
 .I PTSSN="" S SERVNO="SS" Q
"RTN","EASEZF1",264,0)
 .;alternatively Applicant SSN must match service number
"RTN","EASEZF1",265,0)
 .S KK=$$KEY711^EASEZU1("APPLICANT SOCIAL SECURITY NUMBER")
"RTN","EASEZF1",266,0)
 .S EZSSN=$P($G(^TMP("EZDATA",$J,KK,1,1)),U,1)
"RTN","EASEZF1",267,0)
 .S EZSSN=$TR(EZSSN,"-","")
"RTN","EASEZF1",268,0)
 .I EZSSN=PTSSN S SERVNO="SS" Q
"RTN","EASEZF1",269,0)
 .S SERVNO="ssn"
"RTN","EASEZF1",270,0)
 ;
"RTN","EASEZF1",271,0)
 ;File 1010EZ data to .3216
"RTN","EASEZF1",272,0)
 N X,Y,EROOT,ERR,FLD,IENS,EIEN
"RTN","EASEZF1",273,0)
 S EROOT="EAS("_EASAPP_")"
"RTN","EASEZF1",274,0)
 S IENS="+1,"_EASDFN_","
"RTN","EASEZF1",275,0)
 S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EDATE
"RTN","EASEZF1",276,0)
 S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=SDATE
"RTN","EASEZF1",277,0)
 S FLD=.03,EAS(EASAPP,SUBFILE,IENS,FLD)=BOS
"RTN","EASEZF1",278,0)
 S FLD=.05,EAS(EASAPP,SUBFILE,IENS,FLD)=SERVNO
"RTN","EASEZF1",279,0)
 S FLD=.06,EAS(EASAPP,SUBFILE,IENS,FLD)=DTYPE
"RTN","EASEZF1",280,0)
 D UPDATE^DIE("ES",EROOT,"EIEN","ERR")
"RTN","EASEZF1",281,0)
 I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
"RTN","EASEZF1",282,0)
 ;
"RTN","EASEZF1",283,0)
 S SUBIEN=$O(^EAS(712,EASAPP,10,"B",28,""))
"RTN","EASEZF1",284,0)
 S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
"RTN","EASEZF1",285,0)
 S SUBIEN=$O(^EAS(712,EASAPP,10,"B",29,""))
"RTN","EASEZF1",286,0)
 S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
"RTN","EASEZF1",287,0)
 S SUBIEN=$O(^EAS(712,EASAPP,10,"B",30,""))
"RTN","EASEZF1",288,0)
 S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
"RTN","EASEZF1",289,0)
 S SUBIEN=$O(^EAS(712,EASAPP,10,"B",31,""))
"RTN","EASEZF1",290,0)
 S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
"RTN","EASEZF1",291,0)
 S SUBIEN=$O(^EAS(712,EASAPP,10,"B",32,""))
"RTN","EASEZF1",292,0)
 S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
"RTN","EASEZF1",293,0)
 Q
"RTN","EASEZPVD")
0^3^B31942470
"RTN","EASEZPVD",1,0)
EASEZPVD ;ALB/AMA/CMF,LBD - GATHER VISTA DATA TO PRINT FROM DG OPTIONS ; 10/13/10 4:05pm
"RTN","EASEZPVD",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**57,66,70,81,92**;Mar 15, 2001;Build 20
"RTN","EASEZPVD",3,0)
 ;
"RTN","EASEZPVD",4,0)
VISTA(EASDFN,EASMTIEN) ;GATHER VISTA DATA -- CALLED FROM EN^EASEZPDG
"RTN","EASEZPVD",5,0)
 ;   INPUT:
"RTN","EASEZPVD",6,0)
 ;      EASDFN - POINTER TO PATIENT FILE (#2)
"RTN","EASEZPVD",7,0)
 ;      EASMTIEN - MeansTestIEN (408.31)
"RTN","EASEZPVD",8,0)
 ;
"RTN","EASEZPVD",9,0)
 N X,KEY,VDATA,DISPOS,DGNT,ENROLL,RACE,ETHNC
"RTN","EASEZPVD",10,0)
 ;
"RTN","EASEZPVD",11,0)
 ;GET LAST ALIAS NAME
"RTN","EASEZPVD",12,0)
 S X=$O(^DPT(EASDFN,.01,""),-1)
"RTN","EASEZPVD",13,0)
 I +X D
"RTN","EASEZPVD",14,0)
 . S KEY=+$$KEY711^EASEZU1("APPLICANT OTHER NAME")
"RTN","EASEZPVD",15,0)
 . S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.01^.01")
"RTN","EASEZPVD",16,0)
 . Q:VDATA=-1  Q:VDATA=""
"RTN","EASEZPVD",17,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",18,0)
 ;
"RTN","EASEZPVD",19,0)
 ;GATHER MOST RECENT DISPOSITION DATA, IF IT EXISTS
"RTN","EASEZPVD",20,0)
 ;OTHERWISE, PRINT "UNKNOWN" FOR THE FOLLOWING FIELDS
"RTN","EASEZPVD",21,0)
 D I2101^EASEZI(EASDFN,.DISPOS)
"RTN","EASEZPVD",22,0)
 I $D(DISPOS),$D(DISPOS(1)) I DISPOS(1)="NO DISPOSITION" Q
"RTN","EASEZPVD",23,0)
 I $D(DISPOS)>1 D  I 1
"RTN","EASEZPVD",24,0)
 . ;GET TYPE OF BENEFIT
"RTN","EASEZPVD",25,0)
 . S VDATA=$$GET^EASEZC1(DISPOS(1),"2^2.101^2")
"RTN","EASEZPVD",26,0)
 . I (VDATA'=-1),(VDATA'="") D
"RTN","EASEZPVD",27,0)
 . . I (VDATA="HOSPITAL")!(VDATA="OUTPATIENT MEDICAL") S VDATA="HEALTH SERVICES"
"RTN","EASEZPVD",28,0)
 . . I VDATA["DENTAL" S VDATA="DENTAL"
"RTN","EASEZPVD",29,0)
 . . I VDATA["NURSING" S VDATA="NURSING HOME"
"RTN","EASEZPVD",30,0)
 . . S KEY=+$$KEY711^EASEZU1("TYPE OF BENEFIT-"_VDATA)
"RTN","EASEZPVD",31,0)
 . . S ^TMP("EZDATA",$J,KEY,1,2)="YES"
"RTN","EASEZPVD",32,0)
 . ;GET FACILITY APPLYING TO
"RTN","EASEZPVD",33,0)
 . S KEY=+$$KEY711^EASEZU1("FACILITY TO RECEIVE 1010EZ")
"RTN","EASEZPVD",34,0)
 . S VDATA=$$GET^EASEZC1(DISPOS(1),"2^2.101^3")
"RTN","EASEZPVD",35,0)
 . I (VDATA'=-1),(VDATA'="") S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",36,0)
 . ;
"RTN","EASEZPVD",37,0)
 . ;GET NEED RELATED TO JOB INJURY OR ACCIDENT
"RTN","EASEZPVD",38,0)
 . S KEY=+$$KEY711^EASEZU1("NEED RELATED TO JOB INJURY")
"RTN","EASEZPVD",39,0)
 . S VDATA=$$GET^EASEZC1(DISPOS(1),"2^2.101^20")
"RTN","EASEZPVD",40,0)
 . I (VDATA'=-1),(VDATA'="") S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",41,0)
 . S KEY=+$$KEY711^EASEZU1("NEED RELATED TO ACCIDENT")
"RTN","EASEZPVD",42,0)
 . S VDATA=$$GET^EASEZC1(DISPOS(1),"2^2.101^23")
"RTN","EASEZPVD",43,0)
 . I (VDATA'=-1),(VDATA'="") S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",44,0)
 E  D
"RTN","EASEZPVD",45,0)
 . ;IF NO DISPOSITION DATA, PRINT "UNKNOWN" FOR ABOVE FIELDS
"RTN","EASEZPVD",46,0)
 . S KEY=+$$KEY711^EASEZU1("TYPE OF BENEFIT-HEALTH SERVICES")
"RTN","EASEZPVD",47,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)="UNKNOWN"
"RTN","EASEZPVD",48,0)
 . S KEY=+$$KEY711^EASEZU1("FACILITY TO RECEIVE 1010EZ")
"RTN","EASEZPVD",49,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)="UNKNOWN"
"RTN","EASEZPVD",50,0)
 . S KEY=+$$KEY711^EASEZU1("NEED RELATED TO JOB INJURY")
"RTN","EASEZPVD",51,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)="UNKNOWN"
"RTN","EASEZPVD",52,0)
 . S KEY=+$$KEY711^EASEZU1("NEED RELATED TO ACCIDENT")
"RTN","EASEZPVD",53,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)="UNKNOWN"
"RTN","EASEZPVD",54,0)
 ;
"RTN","EASEZPVD",55,0)
 ;GET DATA FROM FILE #2
"RTN","EASEZPVD",56,0)
 S KEY=0 F  S KEY=$O(^TMP("EZDATA",$J,KEY)) Q:'KEY  D
"RTN","EASEZPVD",57,0)
 . S X=^TMP("EZDATA",$J,KEY)
"RTN","EASEZPVD",58,0)
 . I $P(X,U,1,2)="2^2" D
"RTN","EASEZPVD",59,0)
 . . S VDATA=$$GET^EASEZC1(EASDFN,X)
"RTN","EASEZPVD",60,0)
 . . Q:VDATA=-1  Q:VDATA=""
"RTN","EASEZPVD",61,0)
 . . I $P(X,U,3)=.09 S VDATA=$$SSNOUT^EASEZT1(VDATA)
"RTN","EASEZPVD",62,0)
 . . I $P(X,U,3)=.117 D
"RTN","EASEZPVD",63,0)
 . . . N ST,CNTY,CNAME
"RTN","EASEZPVD",64,0)
 . . . S ST=$$GET1^DIQ(2,EASDFN,.115,"I")
"RTN","EASEZPVD",65,0)
 . . . S CNTY=$$GET1^DIQ(2,EASDFN,.117,"I")
"RTN","EASEZPVD",66,0)
 . . . S CNAME=$$GET1^DIQ(5.01,CNTY_","_ST,.01)
"RTN","EASEZPVD",67,0)
 . . . S VDATA=CNAME_" ("_VDATA_")"
"RTN","EASEZPVD",68,0)
 . . ;EAS*1.0*70
"RTN","EASEZPVD",69,0)
 . . I $P(X,U,3)=.1173 S VDATA=$$COUNTRY^EASEZT1(VDATA) Q:VDATA=-1
"RTN","EASEZPVD",70,0)
 . . I $P(X,U,3)=.3405 D
"RTN","EASEZPVD",71,0)
 . . . I VDATA="N" S VDATA="EMERGENCY CONTACT"
"RTN","EASEZPVD",72,0)
 . . . E  S VDATA="NEXT OF KIN"
"RTN","EASEZPVD",73,0)
 . . I $P(X,U,3)=.362 D
"RTN","EASEZPVD",74,0)
 . . . I VDATA'["IN LIEU OF" S VDATA="NO"
"RTN","EASEZPVD",75,0)
 . . . E  S VDATA="YES"
"RTN","EASEZPVD",76,0)
 . . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",77,0)
 ;CONVERT ANSWERS FOR SPINAL CORD INJURY
"RTN","EASEZPVD",78,0)
 S KEY=+$$KEY711^EASEZU1("SPINAL CORD INJURY")
"RTN","EASEZPVD",79,0)
 S VDATA=$$GET^EASEZC1(EASDFN,"2^2^57.4") D
"RTN","EASEZPVD",80,0)
 . I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN" Q
"RTN","EASEZPVD",81,0)
 . I VDATA="NOT APPLICABLE" S VDATA="NO" Q
"RTN","EASEZPVD",82,0)
 . S VDATA="YES"
"RTN","EASEZPVD",83,0)
 S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",84,0)
 ;IF PURPLE HEART OR NOSE/THROAT RADIUM UNANSWERED, SET TO "UNKNOWN"
"RTN","EASEZPVD",85,0)
 S KEY=+$$KEY711^EASEZU1("PURPLE HEART")
"RTN","EASEZPVD",86,0)
 S VDATA=$G(^TMP("EZDATA",$J,KEY,1,2))
"RTN","EASEZPVD",87,0)
 I (VDATA=-1)!(VDATA="") S ^TMP("EZDATA",$J,KEY,1,2)="UNKNOWN"
"RTN","EASEZPVD",88,0)
 S KEY=+$$KEY711^EASEZU1("NOSE/THROAT RADIUM")
"RTN","EASEZPVD",89,0)
 S X=$$GETCUR^DGNTAPI(EASDFN,"DGNT")
"RTN","EASEZPVD",90,0)
 S VDATA=$E($G(DGNT("INTRP")))
"RTN","EASEZPVD",91,0)
 I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZPVD",92,0)
 I (VDATA'=-1),(VDATA'="") S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",93,0)
 ;
"RTN","EASEZPVD",94,0)
 ;GET LAST MILITARY SERVICE EPISODE DATA FROM MSE SUB-FILE #2.3216
"RTN","EASEZPVD",95,0)
 ;DG*5.3*797
"RTN","EASEZPVD",96,0)
 I '$D(^DPT(EASDFN,.3216)) D MOVMSE^DGMSEUTL(EASDFN)
"RTN","EASEZPVD",97,0)
 S X=$O(^DPT(EASDFN,.3216,"B",""),-1) S:X X=$O(^DPT(EASDFN,.3216,"B",X,""))
"RTN","EASEZPVD",98,0)
 I +X D
"RTN","EASEZPVD",99,0)
 . S KEY=+$$KEY711^EASEZU1("LAST ENTRY DATE")
"RTN","EASEZPVD",100,0)
 . S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.01")
"RTN","EASEZPVD",101,0)
 . I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZPVD",102,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",103,0)
 . S KEY=+$$KEY711^EASEZU1("LAST DISCHARGE DATE")
"RTN","EASEZPVD",104,0)
 . S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.02")
"RTN","EASEZPVD",105,0)
 . I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZPVD",106,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",107,0)
 . S KEY=+$$KEY711^EASEZU1("LAST BRANCH OF SERVICE")
"RTN","EASEZPVD",108,0)
 . S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.03")
"RTN","EASEZPVD",109,0)
 . I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZPVD",110,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",111,0)
 . S KEY=+$$KEY711^EASEZU1("SERVICE NUMBER")
"RTN","EASEZPVD",112,0)
 . S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.05")
"RTN","EASEZPVD",113,0)
 . I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZPVD",114,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",115,0)
 . S KEY=+$$KEY711^EASEZU1("LAST DISCHARGE TYPE")
"RTN","EASEZPVD",116,0)
 . S VDATA=$$GET^EASEZC1(EASDFN_";"_+X,"2^2.3216^.06")
"RTN","EASEZPVD",117,0)
 . I (VDATA=-1)!(VDATA="") S VDATA="UNKNOWN"
"RTN","EASEZPVD",118,0)
 . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",119,0)
 ;
"RTN","EASEZPVD",120,0)
 ;GET ENROLLMENT DATA
"RTN","EASEZPVD",121,0)
 D I2711^EASEZI(EASDFN,.ENROLL)
"RTN","EASEZPVD",122,0)
 I $D(ENROLL)>1 D
"RTN","EASEZPVD",123,0)
 . S VDATA="" D ENR^EASEZC1(ENROLL(1),.VDATA)
"RTN","EASEZPVD",124,0)
 . Q:VDATA=-1  Q:VDATA=""
"RTN","EASEZPVD",125,0)
 . S ^TMP("EZDATA",$J,C2711,1,2)=VDATA
"RTN","EASEZPVD",126,0)
 ;
"RTN","EASEZPVD",127,0)
 ;GET DATA FROM FILES 408.12, 408.13, 408.21, AND 408.22
"RTN","EASEZPVD",128,0)
 D V408^EASEZPV2(EASDFN,EASMTIEN)
"RTN","EASEZPVD",129,0)
 ;
"RTN","EASEZPVD",130,0)
 ;GET RACE DATA
"RTN","EASEZPVD",131,0)
 D I202^EASEZI(EASDFN,.RACE)
"RTN","EASEZPVD",132,0)
 I $D(RACE)>1 D
"RTN","EASEZPVD",133,0)
 . N SBIEN
"RTN","EASEZPVD",134,0)
 . S X=0 F  S X=$O(RACE(X)) Q:'X  D
"RTN","EASEZPVD",135,0)
 . . S SBIEN=$P(RACE(X),";",2)
"RTN","EASEZPVD",136,0)
 . . S VDATA=$$GET1^DIQ(2.02,SBIEN_","_EASDFN,.01)
"RTN","EASEZPVD",137,0)
 . . Q:VDATA=-1  Q:VDATA=""
"RTN","EASEZPVD",138,0)
 . . S KEY=+$$KEY711^EASEZU1("APPLICANT RACE - "_VDATA)
"RTN","EASEZPVD",139,0)
 . . S ^TMP("EZDATA",$J,KEY,1,2)="YES"
"RTN","EASEZPVD",140,0)
 ;
"RTN","EASEZPVD",141,0)
 ;GET ETHNICITY DATA
"RTN","EASEZPVD",142,0)
 D I206^EASEZI(EASDFN,.ETHNC)
"RTN","EASEZPVD",143,0)
 I $D(ETHNC)>1 D
"RTN","EASEZPVD",144,0)
 . N SBIEN
"RTN","EASEZPVD",145,0)
 . S X=0 F  S X=$O(ETHNC(X)) Q:'X  D
"RTN","EASEZPVD",146,0)
 . . S SBIEN=$P(ETHNC(X),";",2)
"RTN","EASEZPVD",147,0)
 . . S VDATA=$$GET1^DIQ(2.06,SBIEN_","_EASDFN,.01)
"RTN","EASEZPVD",148,0)
 . . Q:VDATA=-1  Q:VDATA=""
"RTN","EASEZPVD",149,0)
 . . Q:$E(VDATA,1,8)="DECLINED"
"RTN","EASEZPVD",150,0)
 . . I VDATA="HISPANIC OR LATINO" S VDATA="YES"
"RTN","EASEZPVD",151,0)
 . . I $E(VDATA,1,3)="NOT" S VDATA="NO"
"RTN","EASEZPVD",152,0)
 . . I $E(VDATA,1,3)="UNK" S VDATA="UNKNOWN"
"RTN","EASEZPVD",153,0)
 . . S KEY=+$$KEY711^EASEZU1("APPLICANT SPANISH, HISPANIC, OR LATIN")
"RTN","EASEZPVD",154,0)
 . . S ^TMP("EZDATA",$J,KEY,1,2)=VDATA
"RTN","EASEZPVD",155,0)
 ;
"RTN","EASEZPVD",156,0)
 ;GET INSURANCE DATA
"RTN","EASEZPVD",157,0)
 D INSUR^EASEZPVI(EASDFN)
"RTN","EASEZPVD",158,0)
 Q
"RTN","EASEZU3")
0^6^B72715564
"RTN","EASEZU3",1,0)
EASEZU3 ;ALB/jap - Utilities for 1010EZ Processing ; 11/6/09 1:25pm
"RTN","EASEZU3",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,57,92**;Mar 15, 2001;Build 20
"RTN","EASEZU3",3,0)
 ;
"RTN","EASEZU3",4,0)
NSD(EASAPP,TYPE,MULTIPLE) ;get name, ssn, dob for person of interest
"RTN","EASEZU3",5,0)
 ;input  EASAPP = application ien in file #712
"RTN","EASEZU3",6,0)
 ;         TYPE = "APPLICANT", "SPOUSE", "CHILD1", or "CHILD(N)"
"RTN","EASEZU3",7,0)
 ;     MULTIPLE = default to 1, unless TYPE="CHILD(N)"
"RTN","EASEZU3",8,0)
 ;output  RTR   =  name^ssn^dob
"RTN","EASEZU3",9,0)
 N RTR,KEY,EASNAME,EASSSN,EASDOB,LAST,FIRST,MDL,SUFF
"RTN","EASEZU3",10,0)
 S RTR="",EASNAME="",EASSSN="",EASDOB=""
"RTN","EASEZU3",11,0)
 S KEY=+$$KEY711^EASEZU1(TYPE_" LAST NAME") I KEY S LAST=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1)
"RTN","EASEZU3",12,0)
 S KEY=+$$KEY711^EASEZU1(TYPE_" FIRST NAME") I KEY S FIRST=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1)
"RTN","EASEZU3",13,0)
 S KEY=+$$KEY711^EASEZU1(TYPE_" MIDDLE NAME") I KEY S MDL=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1)
"RTN","EASEZU3",14,0)
 S KEY=+$$KEY711^EASEZU1(TYPE_" SUFFIX NAME") I KEY S SUFF=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1)
"RTN","EASEZU3",15,0)
 I (LAST="")!(FIRST="") Q RTR
"RTN","EASEZU3",16,0)
 S EASNAME=LAST_","_FIRST
"RTN","EASEZU3",17,0)
 I $L(EASNAME)+$L(MDL)>45 S MDL=$E(MDL,1)
"RTN","EASEZU3",18,0)
 I MDL'="" S EASNAME=EASNAME_" "_MDL
"RTN","EASEZU3",19,0)
 I SUFF'="" S EASNAME=EASNAME_" "_SUFF
"RTN","EASEZU3",20,0)
 S EASNAME=$$UC^EASEZT1($E(EASNAME,1,45))
"RTN","EASEZU3",21,0)
 S KEY=+$$KEY711^EASEZU1(TYPE_" SOCIAL SECURITY NUMBER")
"RTN","EASEZU3",22,0)
 I KEY S EASSSN=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1),EASSSN=$$SSNOUT^EASEZT1(EASSSN)
"RTN","EASEZU3",23,0)
 S KEY=+$$KEY711^EASEZU1(TYPE_" DATE OF BIRTH")
"RTN","EASEZU3",24,0)
 I KEY S EASDOB=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1)
"RTN","EASEZU3",25,0)
 S RTR=EASNAME_U_EASSSN_U_EASDOB
"RTN","EASEZU3",26,0)
 Q RTR
"RTN","EASEZU3",27,0)
 ;
"RTN","EASEZU3",28,0)
LINK ;
"RTN","EASEZU3",29,0)
 ;link applicant to file #2 as new or existing patient
"RTN","EASEZU3",30,0)
 Q:EASVIEW'=1
"RTN","EASEZU3",31,0)
 S EASPSTAT="NEW"
"RTN","EASEZU3",32,0)
 D DFN^EASEZI(EASAPP,.EASDFN)
"RTN","EASEZU3",33,0)
 I $G(EASDFN)>0 D
"RTN","EASEZU3",34,0)
 .D SETDATE^EASEZU2(EASAPP,"REV") S EASPSTAT="REV"
"RTN","EASEZU3",35,0)
 .D BLD^EASEZLM
"RTN","EASEZU3",36,0)
 .W ! D WAIT^DICD,EN^VALM("EAS EZ 1010EZ REVIEW2")
"RTN","EASEZU3",37,0)
 .S VALMBCK="Q"
"RTN","EASEZU3",38,0)
 I '$G(EASDFN) S VALMBCK="R"
"RTN","EASEZU3",39,0)
 Q
"RTN","EASEZU3",40,0)
 ;
"RTN","EASEZU3",41,0)
ACCFLD ;accept a single 1010EZ data element 
"RTN","EASEZU3",42,0)
 ;if data element was previously accepted, this action returns to non-accepted status
"RTN","EASEZU3",43,0)
 ;input  EASAPP   = pointer to file #712 for 1010EZ
"RTN","EASEZU3",44,0)
 ;       EASPSTAT = current processing status of Application;
"RTN","EASEZU3",45,0)
 ;result ACCEPT = 1, if toggled to accepted
"RTN","EASEZU3",46,0)
 ;                0, if toggled to non-accepted
"RTN","EASEZU3",47,0)
 N J,LN,SUBIEN,KEYIEN,MULTIPLE,ACCEPT,ACTION,LINK,ONE
"RTN","EASEZU3",48,0)
 Q:'EASAPP  Q:EASPSTAT=""
"RTN","EASEZU3",49,0)
 Q:'EASLN
"RTN","EASEZU3",50,0)
 S ACTION="'Accept Field'"
"RTN","EASEZU3",51,0)
 I EASPSTAT="PRT" D NOACT^EASEZLM("Printed",ACTION) Q
"RTN","EASEZU3",52,0)
 I EASPSTAT="SIG" D NOACT^EASEZLM("Signed",ACTION) Q
"RTN","EASEZU3",53,0)
 I EASPSTAT="FIL" D NOACT^EASEZLM("Filed",ACTION) Q
"RTN","EASEZU3",54,0)
 I EASPSTAT="CLS" D NOACT^EASEZLM("Inactivated",ACTION) Q
"RTN","EASEZU3",55,0)
 ;select data item to toggle
"RTN","EASEZU3",56,0)
 S VALMBCK=""
"RTN","EASEZU3",57,0)
 S ONE=0
"RTN","EASEZU3",58,0)
 S VALM("ENTITY")="Line Item" D SELRNGE^EASEZLM
"RTN","EASEZU3",59,0)
 Q:$G(EASERR)
"RTN","EASEZU3",60,0)
 Q:'$G(EASSEL("BG"))
"RTN","EASEZU3",61,0)
 ;
"RTN","EASEZU3",62,0)
 I EASSEL("BG")=EASSEL("LST") S ONE=1
"RTN","EASEZU3",63,0)
 ;
"RTN","EASEZU3",64,0)
 S J=0 F  S J=$O(EASSEL(J)) Q:'J  S EASLN=J D
"RTN","EASEZU3",65,0)
 .S LN=$G(^TMP("EASEXP",$J,"IDX",EASLN))
"RTN","EASEZU3",66,0)
 .Q:LN=""
"RTN","EASEZU3",67,0)
 .S SUBIEN=$P(LN,U,1),MULTIPLE=$P(LN,U,2),KEYIEN=$P(LN,U,3)
"RTN","EASEZU3",68,0)
 .S EZDATA=$P($G(^TMP("EZDATA",$J,KEYIEN,MULTIPLE,1)),U,1),XFILE=$P($G(^TMP("EZDATA",$J,KEYIEN)),U,1)
"RTN","EASEZU3",69,0)
 .Q:EZDATA=""
"RTN","EASEZU3",70,0)
 .Q:'SUBIEN
"RTN","EASEZU3",71,0)
 .S ACCEPT=$P($G(^EAS(712,EASAPP,10,SUBIEN,0)),U,3)
"RTN","EASEZU3",72,0)
 .;provide info to user only if exactly one line item being 'accepted'
"RTN","EASEZU3",73,0)
 .I ONE D FULL^VALM1
"RTN","EASEZU3",74,0)
 .;
"RTN","EASEZU3",75,0)
 .;Block acceptance of Military Service fields if ESR data exists
"RTN","EASEZU3",76,0)
 .I ONE,KEYIEN>27,KEYIEN<33,$$ESRDATA^DGMSEUTL(EASDFN) D  Q
"RTN","EASEZU3",77,0)
 ..W !!,?5
"RTN","EASEZU3",78,0)
 ..W "Sorry, that data element cannot be 'Accepted' for 'Filing'."
"RTN","EASEZU3",79,0)
 ..W !!,?5
"RTN","EASEZU3",80,0)
 ..W "Authoritative ESR data for military service exists."
"RTN","EASEZU3",81,0)
 ..W !!,?5
"RTN","EASEZU3",82,0)
 ..W "After filing this Application to VistA, use Register a Patient "
"RTN","EASEZU3",83,0)
 ..W !,?5,"or Patient Enrollment to enter/update data as needed.",!
"RTN","EASEZU3",84,0)
 ..K DIR D PAUSE^VALM1 S VALMBCK="R"
"RTN","EASEZU3",85,0)
 .;
"RTN","EASEZU3",86,0)
 .;don't allow accept of data which cannot be filed
"RTN","EASEZU3",87,0)
 .I ((XFILE=0)!(ACCEPT=-1)) D:ONE  Q
"RTN","EASEZU3",88,0)
 ..W !!,?5,"Sorry, that data element cannot be 'Accepted' for 'Filing'."
"RTN","EASEZU3",89,0)
 ..W !!,?5,"After filing this Application to VistA, use Register a Patient "
"RTN","EASEZU3",90,0)
 ..W !,?5,"or Patient Enrollment to enter/update data as needed.",!
"RTN","EASEZU3",91,0)
 ..K DIR D PAUSE^VALM1 S VALMBCK="R"
"RTN","EASEZU3",92,0)
 .;if an 'always' accept data element, don't allow user to toggle off;
"RTN","EASEZU3",93,0)
 .I ACCEPT=2 D:ONE  Q
"RTN","EASEZU3",94,0)
 ..W !!,?5,"Sorry, that data element must be 'Accepted' for this Applicant."
"RTN","EASEZU3",95,0)
 ..I XFILE'=355.33 D
"RTN","EASEZU3",96,0)
 ...W !!,?5,"After filing this Application to VistA, the Registration options"
"RTN","EASEZU3",97,0)
 ...W !,?5,"can be used to modify data as needed.",!
"RTN","EASEZU3",98,0)
 ..I XFILE=355.33 D
"RTN","EASEZU3",99,0)
 ...W !!,?5,"After filing this Application to VistA, Integrated Billing users"
"RTN","EASEZU3",100,0)
 ...W !,?5,"can modify the data using the 'Process Insurance Buffer' option.",!
"RTN","EASEZU3",101,0)
 ..K DIR D PAUSE^VALM1 S VALMBCK="R"
"RTN","EASEZU3",102,0)
 .;don't allow 'updated' element to be toggled off;
"RTN","EASEZU3",103,0)
 .S UPD=$P($G(^EAS(712,EASAPP,10,SUBIEN,1)),U,2) I UPD'="" D:ONE  Q
"RTN","EASEZU3",104,0)
 ..W !!,?5,"Sorry, that data element has been Updated and must be 'Accepted'"
"RTN","EASEZU3",105,0)
 ..W !,?5,"for this Applicant."
"RTN","EASEZU3",106,0)
 ..K DIR D PAUSE^VALM1 S VALMBCK="R"
"RTN","EASEZU3",107,0)
 .;toggle 'accept' indicator for line itme
"RTN","EASEZU3",108,0)
 .S ACCEPT=$$ATOGGLE(EASLN,SUBIEN,ACCEPT)
"RTN","EASEZU3",109,0)
 ;
"RTN","EASEZU3",110,0)
 Q
"RTN","EASEZU3",111,0)
 ;
"RTN","EASEZU3",112,0)
ATOGGLE(EASLN,SUBIEN,ACCEPT) ;toggle 'accept' on line item
"RTN","EASEZU3",113,0)
 S ACCEPT='ACCEPT
"RTN","EASEZU3",114,0)
 S $P(^EAS(712,EASAPP,10,SUBIEN,0),U,3)=ACCEPT
"RTN","EASEZU3",115,0)
 ;highlight data on screen
"RTN","EASEZU3",116,0)
 I ACCEPT D CNTRL^VALM10(EASLN,27,25,IORVON,IORVOFF)
"RTN","EASEZU3",117,0)
 I 'ACCEPT D CNTRL^VALM10(EASLN,27,25,IORVOFF,IORVOFF)
"RTN","EASEZU3",118,0)
 D WRITE^VALM10(EASLN)
"RTN","EASEZU3",119,0)
 S VALMBCK="R"
"RTN","EASEZU3",120,0)
 Q ACCEPT
"RTN","EASEZU3",121,0)
 ;
"RTN","EASEZU3",122,0)
ACCALL ;accept all non-null 1010EZ data elements
"RTN","EASEZU3",123,0)
 ;prevously accepted data elements are not toggled to non-accepted
"RTN","EASEZU3",124,0)
 ;input  EASAPP   = pointer to file #712 for 1010EZ
"RTN","EASEZU3",125,0)
 ;       EASPSTAT = current processing status of Application; 
"RTN","EASEZU3",126,0)
 N EASLN,ACTION,XFILE
"RTN","EASEZU3",127,0)
 Q:'EASAPP  Q:EASPSTAT=""
"RTN","EASEZU3",128,0)
 S ACTION="'Accept All'"
"RTN","EASEZU3",129,0)
 I EASPSTAT="PRT" D NOACT^EASEZLM("Printed",ACTION) Q
"RTN","EASEZU3",130,0)
 I EASPSTAT="SIG" D NOACT^EASEZLM("Signed",ACTION) Q
"RTN","EASEZU3",131,0)
 I EASPSTAT="FIL" D NOACT^EASEZLM("Filed",ACTION) Q
"RTN","EASEZU3",132,0)
 I EASPSTAT="CLS" D NOACT^EASEZLM("Inactivated",ACTION) Q
"RTN","EASEZU3",133,0)
 ;
"RTN","EASEZU3",134,0)
 S EASLN=0 F  S EASLN=$O(^TMP("EASEXP",$J,"IDX",EASLN)) Q:'EASLN  D
"RTN","EASEZU3",135,0)
 .S SUBIEN=$P(^TMP("EASEXP",$J,"IDX",EASLN),U,1),MULTIPLE=$P(^(EASLN),U,2),KEYIEN=$P(^(EASLN),U,3)
"RTN","EASEZU3",136,0)
 .S XFILE=$P(^TMP("EZDATA",$J,KEYIEN),U,1)
"RTN","EASEZU3",137,0)
 .Q:XFILE=0
"RTN","EASEZU3",138,0)
 .;Military service data excluded from accept all if ESR data exists
"RTN","EASEZU3",139,0)
 .I KEYIEN>27,KEYIEN<33,$$ESRDATA^DGMSEUTL(EASDFN) Q
"RTN","EASEZU3",140,0)
 .S EZDATA=$P($G(^TMP("EZDATA",$J,KEYIEN,MULTIPLE,1)),U,1) I EZDATA'="" D
"RTN","EASEZU3",141,0)
 ..I $P(^EAS(712,EASAPP,10,SUBIEN,0),U,3)="" S $P(^(0),U,3)=1
"RTN","EASEZU3",142,0)
 ..D FLDCTRL^VALM10(EASLN,"EZDATA",IORVON,IORVOFF)
"RTN","EASEZU3",143,0)
 ..Q:(EASLN<VALMBG)!(EASLN>VALMLST)
"RTN","EASEZU3",144,0)
 ..D CNTRL^VALM10(EASLN,27,25,IORVON,IORVOFF)
"RTN","EASEZU3",145,0)
 ..D WRITE^VALM10(EASLN)
"RTN","EASEZU3",146,0)
 ;
"RTN","EASEZU3",147,0)
 ;update processing status if necessary
"RTN","EASEZU3",148,0)
 I EASPSTAT="NEW" D
"RTN","EASEZU3",149,0)
 .D SETDATE^EASEZU2(EASAPP,"REV") S EASPSTAT="REV"
"RTN","EASEZU3",150,0)
 .D BLD^EASEZLM,HDR2^EASEZL1
"RTN","EASEZU3",151,0)
 S VALMBCK="R"
"RTN","EASEZU3",152,0)
 Q
"RTN","EASEZU3",153,0)
 ;
"RTN","EASEZU3",154,0)
CLEAR ;clear all accept indicators from subfile #712.01 & LM array
"RTN","EASEZU3",155,0)
 ;input EASAPP   = ien to #712 for Application
"RTN","EASEZU3",156,0)
 ;      EASPSTAT = current processing status of Application; 
"RTN","EASEZU3",157,0)
 N BB,EASLN,ACTION
"RTN","EASEZU3",158,0)
 Q:'EASAPP  Q:EASPSTAT=""
"RTN","EASEZU3",159,0)
 S ACTION="'Clear All'"
"RTN","EASEZU3",160,0)
 I EASPSTAT="PRT" D NOACT^EASEZLM("Printed",ACTION) Q
"RTN","EASEZU3",161,0)
 I EASPSTAT="SIG" D NOACT^EASEZLM("Signed",ACTION) Q
"RTN","EASEZU3",162,0)
 I EASPSTAT="FIL" D NOACT^EASEZLM("Filed",ACTION) Q
"RTN","EASEZU3",163,0)
 I EASPSTAT="CLS" D NOACT^EASEZLM("Inactivated",ACTION) Q
"RTN","EASEZU3",164,0)
 ;
"RTN","EASEZU3",165,0)
 ;if a new patient, don't allow user to reset all accept
"RTN","EASEZU3",166,0)
 I $G(EASEZNEW) D  Q
"RTN","EASEZU3",167,0)
 .D FULL^VALM1
"RTN","EASEZU3",168,0)
 .W !!,?5,"Sorry, the 'Clear All' action cannot be used for this new patient."
"RTN","EASEZU3",169,0)
 .W !,?5,"It is recommended that all data elements be 'Accepted' for 'Filing'."
"RTN","EASEZU3",170,0)
 .W !!,?5,"After filing the Application to VistA, the Registration options"
"RTN","EASEZU3",171,0)
 .W !,?5,"can be used to modify data.",!
"RTN","EASEZU3",172,0)
 .D PAUSE^VALM1 S VALMBCK="R"
"RTN","EASEZU3",173,0)
 ;
"RTN","EASEZU3",174,0)
 ;clear accept flags and updates
"RTN","EASEZU3",175,0)
 ;remove accept indicators from List Manager display array
"RTN","EASEZU3",176,0)
 S EASLN=0 F  S EASLN=$O(^TMP("EASEXP",$J,"IDX",EASLN)) Q:'EASLN  D
"RTN","EASEZU3",177,0)
 .S SUBIEN=$P(^TMP("EASEXP",$J,"IDX",EASLN),U,1)
"RTN","EASEZU3",178,0)
 .;don't clear if updated
"RTN","EASEZU3",179,0)
 .Q:'SUBIEN
"RTN","EASEZU3",180,0)
 .I $P($G(^EAS(712,EASAPP,10,SUBIEN,0)),U,3)=1 D
"RTN","EASEZU3",181,0)
 ..F P=3,4,5 S $P(^EAS(712,EASAPP,10,SUBIEN,0),U,P)=""
"RTN","EASEZU3",182,0)
 ..S $P(^EAS(712,EASAPP,10,SUBIEN,1),U,2)=""
"RTN","EASEZU3",183,0)
 ..S $P(^EAS(712,EASAPP,10,SUBIEN,2),U,1)=""
"RTN","EASEZU3",184,0)
 ..D FLDCTRL^VALM10(EASLN,"EZDATA",IORVOFF,IORVOFF)
"RTN","EASEZU3",185,0)
 ..Q:(EASLN<VALMBG)!(EASLN>VALMLST)
"RTN","EASEZU3",186,0)
 ..D CNTRL^VALM10(EASLN,27,25,IORVOFF,IORVOFF) D WRITE^VALM10(EASLN)
"RTN","EASEZU3",187,0)
 S VALMBCK=""
"RTN","EASEZU3",188,0)
 Q
"RTN","EASEZU3",189,0)
 ;
"RTN","EASEZU3",190,0)
RESET ;reset 1010EZ Application to 'new' processing status
"RTN","EASEZU3",191,0)
 ;input  EASAPP  = pointer to file #712 for 1010EZ
"RTN","EASEZU3",192,0)
 ;      EASPSTAT = current processing status of Application; 
"RTN","EASEZU3",193,0)
 ;this action must be follwed by an 'exit' action from the List Manager screen
"RTN","EASEZU3",194,0)
 N ACTION,NEWDATE
"RTN","EASEZU3",195,0)
 Q:'EASAPP  Q:EASPSTAT=""
"RTN","EASEZU3",196,0)
 S ACTION="'Reset to New'"
"RTN","EASEZU3",197,0)
 I EASPSTAT="SIG" D NOACT^EASEZLM("Signed",ACTION) Q
"RTN","EASEZU3",198,0)
 I EASPSTAT="FIL" D NOACT^EASEZLM("Filed",ACTION) Q
"RTN","EASEZU3",199,0)
 I EASPSTAT="CLS" D NOACT^EASEZLM("Inactivated",ACTION) Q
"RTN","EASEZU3",200,0)
 ;
"RTN","EASEZU3",201,0)
 D OKRESET
"RTN","EASEZU3",202,0)
 ;update to 'New' status
"RTN","EASEZU3",203,0)
 S EASPSTAT="NEW",NEWDATE=$P(^EAS(712,EASAPP,0),U,6)
"RTN","EASEZU3",204,0)
 D REINDEX^EASEZU2(EASAPP,EASPSTAT,NEWDATE)
"RTN","EASEZU3",205,0)
 ;rebuild selection list since this application is removed from list
"RTN","EASEZU3",206,0)
 D BLD^EASEZLM
"RTN","EASEZU3",207,0)
 I 'VALMCNT D NOLINES^EASEZLM
"RTN","EASEZU3",208,0)
 W !,"Application has been Reset to New...",!
"RTN","EASEZU3",209,0)
 D PAUSE^VALM1
"RTN","EASEZU3",210,0)
 S VALMBCK="Q"
"RTN","EASEZU3",211,0)
 Q
"RTN","EASEZU3",212,0)
 ;
"RTN","EASEZU3",213,0)
OKRESET ;perform all housekeeping to for 'reset to new' or 'inactivate'
"RTN","EASEZU3",214,0)
 N BB,DA,DR,DIE,REM
"RTN","EASEZU3",215,0)
 ;remove status indicator fields from file #712 record
"RTN","EASEZU3",216,0)
 S DA=EASAPP,DIE="^EAS(712,"
"RTN","EASEZU3",217,0)
 S DR="5.1///^S X=""@"";5.2///^S X=""@"";6.1///^S X=""@"";6.2///^S X=""@"";8.1///^S X=""@"";8.2///^S X=""@"";"
"RTN","EASEZU3",218,0)
 D ^DIE
"RTN","EASEZU3",219,0)
 ;
"RTN","EASEZU3",220,0)
 ;delete link to file #2
"RTN","EASEZU3",221,0)
 I '$G(EASDFN) S EASDFN=$P(^EAS(712,EASAPP,0),U,10)
"RTN","EASEZU3",222,0)
 S $P(^EAS(712,EASAPP,0),U,10)=""
"RTN","EASEZU3",223,0)
 I $G(EASDFN) K ^EAS(712,"AC",EASDFN,EASAPP)
"RTN","EASEZU3",224,0)
 ;remove all links to VistA datbase
"RTN","EASEZU3",225,0)
 ;delete link, delete updated data, remove accept in each subfile #712.01 record
"RTN","EASEZU3",226,0)
 S BB=0 F  S BB=$O(^EAS(712,EASAPP,10,BB)) Q:'BB  D
"RTN","EASEZU3",227,0)
 .F P=3,4,5 S $P(^EAS(712,EASAPP,10,BB,0),U,P)=""
"RTN","EASEZU3",228,0)
 .S $P(^EAS(712,EASAPP,10,BB,1),U,2)=""
"RTN","EASEZU3",229,0)
 .F P=1,2 S $P(^EAS(712,EASAPP,10,BB,2),U,P)=""
"RTN","EASEZU3",230,0)
 ;
"RTN","EASEZU3",231,0)
 ;clear new patient indicator since applicant must be re-matched to VistA;
"RTN","EASEZU3",232,0)
 ;but if this applicant is matched again with same new stub record in VistA,
"RTN","EASEZU3",233,0)
 ;  there's a comment in file #2/field #.091 to indicate the record was previously
"RTN","EASEZU3",234,0)
 ;  added by 1010EZ process
"RTN","EASEZU3",235,0)
 ;update 'new patient' remark
"RTN","EASEZU3",236,0)
 I '$G(EASEZNEW) S EASEZNEW=$P(^EAS(712,EASAPP,0),U,11)
"RTN","EASEZU3",237,0)
 S $P(^EAS(712,EASAPP,0),U,11)=""
"RTN","EASEZU3",238,0)
 I EASEZNEW,EASDFN D
"RTN","EASEZU3",239,0)
 .S REM="New Patient record added by ELECTRONIC 10-10EZ."
"RTN","EASEZU3",240,0)
 .S DA=EASDFN,DIE="^DPT(",DR=".091///^S X=REM"
"RTN","EASEZU3",241,0)
 .D ^DIE
"RTN","EASEZU3",242,0)
 Q
"VER")
8.0^22.0
**INSTALL NAME**
IVM*2.0*141
"BLD",8580,0)
IVM*2.0*141^INCOME VERIFICATION MATCH^0^3120206^y
"BLD",8580,1,0)
^^1^1^3101026^^^
"BLD",8580,1,1,0)
MILITARY SERVICE DATA SHARING (MSDS) PROJECT
"BLD",8580,4,0)
^9.64PA^^
"BLD",8580,6.3)
18
"BLD",8580,"ABPKG")
n
"BLD",8580,"KRN",0)
^9.67PA^8989.52^19
"BLD",8580,"KRN",.4,0)
.4
"BLD",8580,"KRN",.401,0)
.401
"BLD",8580,"KRN",.402,0)
.402
"BLD",8580,"KRN",.403,0)
.403
"BLD",8580,"KRN",.5,0)
.5
"BLD",8580,"KRN",.84,0)
.84
"BLD",8580,"KRN",3.6,0)
3.6
"BLD",8580,"KRN",3.8,0)
3.8
"BLD",8580,"KRN",9.2,0)
9.2
"BLD",8580,"KRN",9.8,0)
9.8
"BLD",8580,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",8580,"KRN",9.8,"NM",1,0)
IVMPTRN8^^0^B75232806
"BLD",8580,"KRN",9.8,"NM","B","IVMPTRN8",1)

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

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

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

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

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

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

"BLD",8580,"KRN","B",3.6,3.6)

"BLD",8580,"KRN","B",3.8,3.8)

"BLD",8580,"KRN","B",9.2,9.2)

"BLD",8580,"KRN","B",9.8,9.8)

"BLD",8580,"KRN","B",19,19)

"BLD",8580,"KRN","B",19.1,19.1)

"BLD",8580,"KRN","B",101,101)

"BLD",8580,"KRN","B",409.61,409.61)

"BLD",8580,"KRN","B",771,771)

"BLD",8580,"KRN","B",870,870)

"BLD",8580,"KRN","B",8989.51,8989.51)

"BLD",8580,"KRN","B",8989.52,8989.52)

"BLD",8580,"KRN","B",8994,8994)

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

"MBREQ")
0
"PKG",120,-1)
1^1
"PKG",120,0)
INCOME VERIFICATION MATCH^IVM^IVM Software for interface with the IVM Center
"PKG",120,20,0)
^9.402P^^
"PKG",120,22,0)
^9.49I^1^1
"PKG",120,22,1,0)
2.0^2941021^2960823
"PKG",120,22,1,"PAH",1,0)
141^3120206^123457000
"PKG",120,22,1,"PAH",1,1,0)
^^1^1^3120206
"PKG",120,22,1,"PAH",1,1,1,0)
MILITARY SERVICE DATA SHARING (MSDS) PROJECT
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

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

"BLD",8581,"KRN",.401,0)
.401
"BLD",8581,"KRN",.402,0)
.402
"BLD",8581,"KRN",.402,"NM",0)
^9.68A^1^1
"BLD",8581,"KRN",.402,"NM",1,0)
DVBHINQ UPDATE    FILE #2^2^0
"BLD",8581,"KRN",.402,"NM","B","DVBHINQ UPDATE    FILE #2",1)

"BLD",8581,"KRN",.403,0)
.403
"BLD",8581,"KRN",.5,0)
.5
"BLD",8581,"KRN",.84,0)
.84
"BLD",8581,"KRN",3.6,0)
3.6
"BLD",8581,"KRN",3.8,0)
3.8
"BLD",8581,"KRN",9.2,0)
9.2
"BLD",8581,"KRN",9.8,0)
9.8
"BLD",8581,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",8581,"KRN",9.8,"NM",1,0)
DVBHQZ6^^0^B37429398
"BLD",8581,"KRN",9.8,"NM",2,0)
DVBHS4^^0^B19622289
"BLD",8581,"KRN",9.8,"NM","B","DVBHQZ6",1)

"BLD",8581,"KRN",9.8,"NM","B","DVBHS4",2)

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

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

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

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

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

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

"BLD",8581,"KRN","B",3.6,3.6)

"BLD",8581,"KRN","B",3.8,3.8)

"BLD",8581,"KRN","B",9.2,9.2)

"BLD",8581,"KRN","B",9.8,9.8)

"BLD",8581,"KRN","B",19,19)

"BLD",8581,"KRN","B",19.1,19.1)

"BLD",8581,"KRN","B",101,101)

"BLD",8581,"KRN","B",409.61,409.61)

"BLD",8581,"KRN","B",771,771)

"BLD",8581,"KRN","B",870,870)

"BLD",8581,"KRN","B",8989.51,8989.51)

"BLD",8581,"KRN","B",8989.52,8989.52)

"BLD",8581,"KRN","B",8994,8994)

"BLD",8581,"QUES",0)
^9.62^^
"BLD",8581,"REQB",0)
^9.611^2^1
"BLD",8581,"REQB",2,0)
DVB*4.0*57^2
"BLD",8581,"REQB","B","DVB*4.0*57",2)

"KRN",.4,513,-1)
0^1
"KRN",.4,513,0)
DVBHINQ PAT-HINQ COMP^3090519.1826^^2^^^3090519
"KRN",.4,513,"DXS")
10
"KRN",.4,513,"DXS",1,9)
W ?30,"Patient File vs. HINQ",!,?17,"Patient",?55,"HINQ",!,"--------------------------------------------------------------------------------"
"KRN",.4,513,"DXS",2,9)
I $D(DVBDOB),DVBDOB S M=$E(DVBDOB,1,2) D MM^DVBHQM11 W ?50,M_" "_$E(DVBDOB,3,4)_", "_$E(DVBDOB,5,8) K M
"KRN",.4,513,"DXS",3,9)
I $D(DVBP(6)),(+$P(DVBP(6),U)) S M=$E(DVBP(6),1,2) D MM^DVBHQM11 W ?50,M_" "_$E(DVBP(6),3,4)_", "_$E(DVBP(6),5,8) K M
"KRN",.4,513,"DXS",4,9)
I $P(DVBP(6),U,7)'[" " W ?50 W:$P(DVBP(6),U,7)="Y" "YES" W:$P(DVBP(6),U,7)="N" "NO" W:$P(DVBP(6),U,7)="I" "YES"
"KRN",.4,513,"DXS",5,9)
I $D(DVBPOW) W ?50,$S(DVBPOW=0:"No period of rec.",DVBPOW=1:"Less than 30 days",DVBPOW=2:"30 days or more",DVBPOW=" ":"Not applicable",1:DVBPOW)
"KRN",.4,513,"DXS",6,9)
I '$D(ZTSK),(IO=IO(0)) W !!,?35,"** Pausing **" H 3 W @$S('$D(IOF):"#",IOF="":"#",1:IOF)
"KRN",.4,513,"DXS",7,9)
W !,?1,"Rated Disab. (HINQ) - Comb. SC%: ",+$G(DVBDXPCT),"  Eff. Date Comb. Eval.: ",$G(DVBEDT)
"KRN",.4,513,"DXS",8,9)
I $D(DVBEOD(1)),DVBEOD(1)?8N S M=$E(DVBEOD(1),1,2) D MM^DVBHQM11 W M," ",$E(DVBEOD(1),3,4),",",$E(DVBEOD(1),5,8)
"KRN",.4,513,"DXS",9,9)
I $D(DVBRAD(1)),DVBRAD(1)?8N S M=$E(DVBRAD(1),1,2) D MM^DVBHQM11 W ?15,M," ",$E(DVBRAD(1),3,4),",",$E(DVBRAD(1),5,8)
"KRN",.4,513,"DXS",10,0)
NO
"KRN",.4,513,"DXS",10,1)
YES
"KRN",.4,513,"DXS",11,"N")
NO
"KRN",.4,513,"DXS",11,"U")
UNKNOWN
"KRN",.4,513,"DXS",11,"Y")
YES
"KRN",.4,513,"DXS",12,"N")
NO
"KRN",.4,513,"DXS",12,"U")
UNKNOWN
"KRN",.4,513,"DXS",12,"Y")
YES
"KRN",.4,513,"F",1)
W @$S('$D(IOF):"#",IOF="":"#",1:IOF);Z;"W @$S('$D(IOF):"#",IOF="":"#",1:IOF)"~
"KRN",.4,513,"F",2)
X DXS(1,9);X;Z;"W ?30,"Patient File vs. HINQ",!,?17,"Patient",?55,"HINQ",!,"--------------------------------------------------------------------------------""~
"KRN",.4,513,"F",3)
"Name:";C1~.01;C20~I $D(DVBADR(1)) W ?56,DVBADR(1);Z;"I $D(DVBADR(1)) W ?56,DVBADR(1)"~
"KRN",.4,513,"F",4)
I '$D(DVBADR(1)),$D(DVBNAME) W ?56,DVBNAME;Z;"I '$D(DVBADR(1)),$D(DVBNAME) W ?56,DVBNAME"~"Address:";C1~.111;C20~
"KRN",.4,513,"F",5)
I $D(DVBADR(1)) W ?56,DVBADR(1);Z;"I $D(DVBADR(1)) W ?56,DVBADR(1)"~.112;C20~I $D(DVBADR(2)) W ?56,DVBADR(2);Z;"I $D(DVBADR(2)) W ?56,DVBADR(2)"~
"KRN",.4,513,"F",6)
.113;C20~I $D(DVBADR(3)) W ?56,DVBADR(3);Z;"I $D(DVBADR(3)) W ?56,DVBADR(3)"~"SSN:";C1~.09;C20~I $D(DVBSSN) W ?50,DVBSSN;Z;"I $D(DVBSSN) W ?50,DVBSSN"~
"KRN",.4,513,"F",7)
"Claim number:";C1~.313;C20;L9;X~I $D(DVBCN),DVBCN>0 W ?50,DVBCN;X;Z;"I $D(DVBCN),DVBCN>0 W ?50,DVBCN"~"Date of Birth:";C1~.03;C20;X~
"KRN",.4,513,"F",8)
X DXS(2,9);Z;"I $D(DVBDOB),DVBDOB S M=$E(DVBDOB,1,2) D MM^DVBHQM11 W ?50,M_" "_$E(DVBDOB,3,4)_", "_$E(DVBDOB,5,8) K M"~"Date of Death:";C1~.351;C20;X~
"KRN",.4,513,"F",9)
X DXS(3,9);Z;"I $D(DVBP(6)),(+$P(DVBP(6),U)) S M=$E(DVBP(6),1,2) D MM^DVBHQM11 W ?50,M_" "_$E(DVBP(6),3,4)_", "_$E(DVBP(6),5,8) K M"~
"KRN",.4,513,"F",10)
"Rated Incompetent:";C1~.293;C20;X~
"KRN",.4,513,"F",11)
X DXS(4,9);Z;"I $P(DVBP(6),U,7)'[" " W ?50 W:$P(DVBP(6),U,7)="Y" "YES" W:$P(DVBP(6),U,7)="N" "NO" W:$P(DVBP(6),U,7)="I" "YES""~"POW";C1~.525;C20;X~
"KRN",.4,513,"F",12)
X DXS(5,9);Z;"I $D(DVBPOW) W ?50,$S(DVBPOW=0:"No period of rec.",DVBPOW=1:"Less than 30 days",DVBPOW=2:"30 days or more",DVBPOW=" ":"Not applicable",1:DVBPOW)"~
"KRN",.4,513,"F",13)
"Folder Location:";C1~.314;C20;L27;X~I $D(DVBFL) W ?50,$E(DVBFL,1,27);Z;"I $D(DVBFL) W ?50,$E(DVBFL,1,27)"~"Verified SVC:";C1~.322;C20;X~
"KRN",.4,513,"F",14)
I $P(DVBP(6),U,8)'[" " W ?50 W:$P(DVBP(6),U,8)="Y" "YES" W:$P(DVBP(6),U,8)="N" "NO";Z;"I $P(DVBP(6),U,8)'[" " W ?50 W:$P(DVBP(6),U,8)="Y" "YES" W:$P(DVBP(6),U,8)="N" "NO""~
"KRN",.4,513,"F",15)
"Vietnam Service:";C1~.32101;C20;X~
"KRN",.4,513,"F",16)
I $P(DVBP(6),U,4)'[" " W ?50 W:$P(DVBP(6),U,4)="Y" "YES" W:$P(DVBP(6),U,4)="N" "NO";Z;"I $P(DVBP(6),U,4)'[" " W ?50 W:$P(DVBP(6),U,4)="Y" "YES" W:$P(DVBP(6),U,4)="N" "NO""~
"KRN",.4,513,"F",17)
X DXS(6,9);Z;"I '$D(ZTSK),(IO=IO(0)) W !!,?35,"** Pausing **" H 3 W @$S('$D(IOF):"#",IOF="":"#",1:IOF)"~"Rated Disab. (Patient file)";S1;C1~
"KRN",.4,513,"F",18)
D LSTR^DVBHQUP;Z;"D LSTR^DVBHQUP"~X DXS(7,9);Z;"W !,?1,"Rated Disab. (HINQ) - Comb. SC%: ",+$G(DVBDXPCT),"  Eff. Date Comb. Eval.: ",$G(DVBEDT)"~
"KRN",.4,513,"F",19)
I $D(DVBDXNO),DVBDXNO'=0 D S1^DVBHQZ6;Z;"I $D(DVBDXNO),DVBDXNO'=0 D S1^DVBHQZ6"~W !,?34,"HINQ Data";X;Z;"W !,?34,"HINQ Data""~
"KRN",.4,513,"F",20)
W !,?6,"EOD",?20,"RAD",?34,"Bran. Ser.",?48,"Char. Ser.",?62,"Ser Num.";X;Z;"W !,?6,"EOD",?20,"RAD",?34,"Bran. Ser.",?48,"Char. Ser.",?62,"Ser Num.""~
"KRN",.4,513,"F",21)
W !,"--------------------------------------------------------------------------------";Z;"W !,"--------------------------------------------------------------------------------""~
"KRN",.4,513,"F",22)
I +$G(DVBEOD(2))>0 K DVBEOD(1);Z;"I +$G(DVBEOD(2))>0 K DVBEOD(1)"~I +$G(DVBRAD(2))>0 K DVBRAD(1);Z;"I +$G(DVBRAD(2))>0 K DVBRAD(1)"~
"KRN",.4,513,"F",23)
I $G(DVBCSVC(2))]"" K DVBCSVC(1);Z;"I $G(DVBCSVC(2))]"" K DVBCSVC(1)"~I $G(DVBSN(2))]"" K DVBSN(1);Z;"I $G(DVBSN(2))]"" K DVBSN(1)"~
"KRN",.4,513,"F",24)
I $G(DVBBOS(2))]"" K DVBBOS(1);Z;"I $G(DVBBOS(2))]"" K DVBBOS(1)"~
"KRN",.4,513,"F",25)
X DXS(8,9);X;Z;"I $D(DVBEOD(1)),DVBEOD(1)?8N S M=$E(DVBEOD(1),1,2) D MM^DVBHQM11 W M," ",$E(DVBEOD(1),3,4),",",$E(DVBEOD(1),5,8)"~
"KRN",.4,513,"F",26)
X DXS(9,9);X;Z;"I $D(DVBRAD(1)),DVBRAD(1)?8N S M=$E(DVBRAD(1),1,2) D MM^DVBHQM11 W ?15,M," ",$E(DVBRAD(1),3,4),",",$E(DVBRAD(1),5,8)"~
"KRN",.4,513,"F",27)
I $D(DVBBOS(1)) S Y=DVBBOS(1) D XBOS^DVBHQM12 W ?34,$E(Y,1,16) K Y;X;Z;"I $D(DVBBOS(1)) S Y=DVBBOS(1) D XBOS^DVBHQM12 W ?34,$E(Y,1,16) K Y"~
"KRN",.4,513,"F",28)
I $D(DVBCSVC(1)) S I=1,Y=DVBCSVC(1) D DISCHG^DVBHQM1 W ?48,Y K Y;X;Z;"I $D(DVBCSVC(1)) S I=1,Y=DVBCSVC(1) D DISCHG^DVBHQM1 W ?48,Y K Y"~
"KRN",.4,513,"F",29)
I $D(DVBSN(1)) W ?62,DVBSN(1);X;Z;"I $D(DVBSN(1)) W ?62,DVBSN(1)"~
"KRN",.4,513,"F",30)
W ! I $D(DVBEOD(2)),DVBEOD(2)?7N S Y=DVBEOD(2) X ^DD("DD") W ?1,Y K Y;X;Z;"W ! I $D(DVBEOD(2)),DVBEOD(2)?7N S Y=DVBEOD(2) X ^DD("DD") W ?1,Y K Y"~
"KRN",.4,513,"F",31)
I $D(DVBRAD(2)),DVBRAD(2)?7N S Y=DVBRAD(2) X ^DD("DD") W ?15,Y K Y;X;Z;"I $D(DVBRAD(2)),DVBRAD(2)?7N S Y=DVBRAD(2) X ^DD("DD") W ?15,Y K Y"~
"KRN",.4,513,"F",32)
I $D(DVBBOS(2)) W ?34,DVBBOS(2);X;Z;"I $D(DVBBOS(2)) W ?34,DVBBOS(2)"~I $D(DVBCSVC(2)) W ?48,DVBCSVC(2);X;Z;"I $D(DVBCSVC(2)) W ?48,DVBCSVC(2)"~
"KRN",.4,513,"F",33)
I $D(DVBSN(2)) W ?62,DVBSN(2);X;Z;"I $D(DVBSN(2)) W ?62,DVBSN(2)"~
"KRN",.4,513,"F",34)
W ! I $D(DVBEOD(3)),DVBEOD(3)?7N S Y=DVBEOD(3) X ^DD("DD") W ?1,Y K Y;X;Z;"W ! I $D(DVBEOD(3)),DVBEOD(3)?7N S Y=DVBEOD(3) X ^DD("DD") W ?1,Y K Y"~
"KRN",.4,513,"F",35)
I $D(DVBRAD(3)),DVBRAD(3)?7N S Y=DVBRAD(3) X ^DD("DD") W ?15,Y K Y;X;Z;"I $D(DVBRAD(3)),DVBRAD(3)?7N S Y=DVBRAD(3) X ^DD("DD") W ?15,Y K Y"~
"KRN",.4,513,"F",36)
I $D(DVBBOS(3)) W ?34,DVBBOS(3);X;Z;"I $D(DVBBOS(3)) W ?34,DVBBOS(3)"~I $D(DVBCSVC(3)) W ?48,DVBCSVC(3);X;Z;"I $D(DVBCSVC(3)) W ?48,DVBCSVC(3)"~
"KRN",.4,513,"F",37)
I $D(DVBSN(3)) W ?62,DVBSN(3);X;Z;"I $D(DVBSN(3)) W ?62,DVBSN(3)"~
"KRN",.4,513,"F",38)
W ! I $D(DVBEOD(4)),DVBEOD(4)?7N S Y=DVBEOD(4) X ^DD("DD") W ?1,Y K Y;X;Z;"W ! I $D(DVBEOD(4)),DVBEOD(4)?7N S Y=DVBEOD(4) X ^DD("DD") W ?1,Y K Y"~
"KRN",.4,513,"F",39)
I $D(DVBRAD(4)),DVBRAD(4)?7N S Y=DVBRAD(4) X ^DD("DD") W ?15,Y K Y;X;Z;"I $D(DVBRAD(4)),DVBRAD(4)?7N S Y=DVBRAD(4) X ^DD("DD") W ?15,Y K Y"~
"KRN",.4,513,"F",40)
I $D(DVBBOS(4)) W ?34,DVBBOS(4);X;Z;"I $D(DVBBOS(4)) W ?34,DVBBOS(4)"~I $D(DVBCSVC(4)) W ?48,DVBCSVC(4);X;Z;"I $D(DVBCSVC(4)) W ?48,DVBCSVC(4)"~
"KRN",.4,513,"F",41)
I $D(DVBSN(4)) W ?62,DVBSN(4);X;Z;"I $D(DVBSN(4)) W ?62,DVBSN(4)"~W !!,?34,"Patient File";X;Z;"W !!,?34,"Patient File""~
"KRN",.4,513,"F",42)
W !,"-------------------------------------------------------------------------------";Z;"W !,"-------------------------------------------------------------------------------""~
"KRN",.4,513,"F",43)
D DISP^DVBHQZ6(DFN);Z;"D DISP^DVBHQZ6(DFN)"~
"KRN",.4,513,"H")
@
"KRN",.4,513,"IOM")
80
"KRN",.4,513,"LAST")

"KRN",.4,513,"ROU")
^DVBHCG
"KRN",.4,513,"ROUOLD")
DVBHCG
"KRN",.4,513,"SUB")
1
"KRN",.402,960,-1)
0^1
"KRN",.402,960,0)
DVBHINQ UPDATE^3090520.1826^^2^^^3090520
"KRN",.402,960,"AR",2,280)
1^DVBHCE33
"KRN",.402,960,"AR",2,680)
2^DVBHCE33
"KRN",.402,960,"AR",2,681)
3^DVBHCE33
"KRN",.402,960,"AR",2,682)
4^DVBHCE33
"KRN",.402,960,"DIAB",1,0,2,10)
SERVICE THIRD EPISODE?;Service NNTL Episode
"KRN",.402,960,"DIAB",1,0,2,12)
MONETARY BEN. VERIFY DATE//"TODAY"
"KRN",.402,960,"DIAB",2,0,2,2)
SERVICE ENTRY DATE [LAST];"L-EOD"
"KRN",.402,960,"DIAB",2,0,2,6)
SERVICE ENTRY DATE [NTL];"NTL-EOD"
"KRN",.402,960,"DIAB",3,0,2,2)
SERVICE SEPARATION DATE [LAST];"L-RAD";C15
"KRN",.402,960,"DIAB",3,0,2,5)
SERVICE SECOND EPISODE?;Service NTL Episode
"KRN",.402,960,"DIAB",3,0,2,6)
SERVICE SEPARATION DATE [NTL];"NTL-RAD"
"KRN",.402,960,"DIAB",3,0,2,10)
SERVICE ENTRY DATE [NNTL];"NNTL-EOD"
"KRN",.402,960,"DIAB",4,0,2,2)
SERVICE BRANCH [LAST];L-Bran.. Ser.
"KRN",.402,960,"DIAB",4,0,2,6)
SERVICE BRANCH [NTL];"NTL-Bran. Ser."
"KRN",.402,960,"DIAB",4,0,2,10)
SERVICE SEPARATION DATE [NNTL];"NNTL-RAD"
"KRN",.402,960,"DIAB",5,0,2,6)
SERVICE DISCHARGE TYPE [NTL];"NTL-Char. Ser."
"KRN",.402,960,"DIAB",5,0,2,10)
SERVICE BRANCH [NNTL];"NNTL-Bran. Ser."
"KRN",.402,960,"DIAB",6,0,2,2)
SERVICE DISCHARGE TYPE [LAST];L-Char. Ser.
"KRN",.402,960,"DIAB",6,0,2,6)
SERVICE NUMBER [NTL];"NTL-Ser. Num."
"KRN",.402,960,"DIAB",6,0,2,10)
SERVICE DISCHARGE TYPE [NNTL];"NNTL-Char. Ser."
"KRN",.402,960,"DIAB",7,0,2,2)
SERVICE NUMBER [LAST];L-Ser. Num.
"KRN",.402,960,"DIAB",7,0,2,10)
SERVICE NUMBER [NNTL];"NNTL-Ser. Num."
"KRN",.402,960,"DIAB",13,0,2,11)
ELIGIBILITY STATUS DATE//"TODAY"
"KRN",.402,960,"DR",1,2)
@101;W @$S('$D(IOF):"#",IOF="":"#",1:IOF),! K ^UTILITY($J) D ^DVBHSVER;@7;D Q^DVBHUTIL;S DIE("NO^")="";@1001;D ^DVBHS1 S Y="@5";@1;D ^DVBHS2 S Y="@5" W !;@2;D ^DVBHS3 S Y="@5";@3;D ^DVBHS4 S Y="@5";@1006;@30;I Z2'[1 S Y="@32";
"KRN",.402,960,"DR",1,2,1)
I $O(^DPT(D0,.3216,"B",0)) W !!,*7,?17,DVBON,"Authoritative data, can't edit   <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33";S DVBSCR=1 D ^DVBHS4 W !,?34,DVBON,"[LAST]",DVBOFF X DVBLIT1;
"KRN",.402,960,"DR",1,2,2)
S DVBJC=$S('$D(^DPT(DFN,.32)):"",1:$P(^(0),U,5));.326L-EOD~;.327C15~L-RAD~;.325L-Bran.. Ser.~;I X'=DVBJC S DVBJ2=1;.324L-Char. Ser.~;.328L-Ser. Num.~;@32;I Z2'[2 S Y="@31";
"KRN",.402,960,"DR",1,2,3)
I $O(^DPT(D0,.3216,"B",0)) W !!,*7,?17,DVBON,"Authoritative data, can't edit   <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33";
"KRN",.402,960,"DR",1,2,4)
I '$D(^DPT(D0,.32)) W !!,*7,?17,DVBON,"No Last episode can't edit NTLast   <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33";
"KRN",.402,960,"DR",1,2,5)
I $P(^DPT(D0,.32),U,6)="" W !!,*7,?17,DVBON,"No last episode can't edit NTLast   <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33";S DVBSCR=1 D ^DVBHS4 W !,?34,DVBON,"[NTLAST]",DVBOFF X DVBLIT1;.3285Service NTL Episode~;
"KRN",.402,960,"DR",1,2,6)
I $P(^DPT(D0,.32),U,19)'="Y" S Y="@31";.3292NTL-EOD~;.3293NTL-RAD~;.3291NTL-Bran. Ser.~;.329NTL-Char. Ser.~;.3294NTL-Ser. Num.~;@31;I Z2'[3 S Y="@33";
"KRN",.402,960,"DR",1,2,7)
I $O(^DPT(D0,.3216,"B",0)) W !!,*7,?17,DVBON,"Authoritative data, can't edit   <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33";
"KRN",.402,960,"DR",1,2,8)
I '$D(^DPT(D0,.32)) W !!,*7,?17,DVBON,"No NTLast episode can't edit NNTLast   <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33";
"KRN",.402,960,"DR",1,2,9)
I $P(^DPT(D0,.32),U,19)'="Y" W !!,*7,?17,DVBON,"No NTLast episode can't edit NNTLast   <RET>.",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33";S DVBSCR=1 D ^DVBHS4 W !,?34,DVBON,"[NNTLAST]",DVBOFF X DVBLIT1;
"KRN",.402,960,"DR",1,2,10)
.32945Service NNTL Episode~;I $P(^DPT(D0,.32),U,20)'="Y" S Y="@33";.3297NNTL-EOD~;.3298NNTL-RAD~;.3296NNTL-Bran. Ser.~;.3295NNTL-Char. Ser.~;.3299NNTL-Ser. Num.~;@33;I Z2'[4 S Y="@3";S DVBSCR=1 D ^DVBHS4;
"KRN",.402,960,"DR",1,2,11)
S DVBJC2=$S($D(^DPT(D0,.32)):$P(^(.32),U,3),1:"");.323;I X'=DVBJC2 S DVBJ2=1;K DVBJC2;S Y="@3";@104;D ^DVBHS5 S Y="@5" K DXS;@204;I Z2'[1 S Y="@205";S DVBSCR=1 D ^DVBHS5 S DVBJ2=1;.3611;Q;.3612//^S X="TODAY";.3615//^S X="HINQ";Q;
"KRN",.402,960,"DR",1,2,12)
.306//^S X="TODAY";361;@205;I Z2'[2 S Y="@206";S DVBSCR=1 D ^DVBHS5 S DVBJ2=1;391;1901;.301;I X="N" S Y="@2063";@2063;.361;@206;I Z2'[3 S Y="@104";S DVBSCR=1 D ^DVBHS5 S DVBJ2=1;.36205;.36215;.36235;.3025;.36295;@2062;S Y="@104";
"KRN",.402,960,"DR",1,2,13)
@11;S DVBJ2=1;.111;.112;.113;.114;.115;.1112;.117;S Y="@1001";@5;D SCRQ^DVBHUTIL;@6;D B^DVBHQEDT R AA:DTIME K AA S Y=$S(DVBJS=11:"@1001",DVBJS=28:"@1",DVBJS=35:"@2",DVBJS=44:"@3",DVBJS=53:"@104",1:"@10");@8;
"KRN",.402,960,"DR",1,2,14)
S Y=$S(ANS="^0":"@101",ANS="^1":"@1001",ANS="^2":"@1",ANS="^3":"@2",ANS="^4":"@3",ANS="^5":"@104",1:Y) I Y["@" W @$S('$D(IOF):"#",IOF="":"#",1:IOF);
"KRN",.402,960,"DR",1,2,15)
D A^DVBHQEDT S Z2=Z I ERROR K ERROR S Y=$S(DVBJS=11:"@1001",DVBJS=28:"@1",DVBJS=35:"@2",DVBJS=44:"@3",DVBJS=53:"@104",1:"@10");@20;S JP=1,Y=$S(DVBJS=11:"@11",DVBJS=35:"@40",DVBJS=44:"@30",DVBJS=53:"@204",1:Y);@21;
"KRN",.402,960,"DR",1,2,16)
I $P(Z2,U,JP)'=1 S Y="@22";I '$D(DVBCN) S Y="@22",JP=JP+1;I 'DVBCN S Y="@22",JP=JP+1;S DVBCN=$TR(DVBCN," ");
"KRN",.402,960,"DR",1,2,17)
I $L(DVBCN)=9,(DVBCN?9N),(DVBCN'=$P(^DPT(D0,0),U,9)) W !!,*7,"HINQ claim # is a SSN, does not match patient file SSN  NO UPDATING claim #" R !,?25,"<RET to continue>",DVBQ:DTIME K DVBQ S Y="@22",JP=JP+1;.313///^S X=DVBCN;
"KRN",.402,960,"DR",1,2,18)
W "." S JP=JP+1,DVBJ2=1;@22;I $P(Z2,U,JP)'=2 S Y="@225";W !,"Date of Birth cannot be edited with this option.";H 1;W "." S JP=JP+1,DVBJ2=1;@225;I $P(Z2,U,JP)'=3 S Y="@23";W !,"Sex cannot be edited with this option.";H 1;
"KRN",.402,960,"DR",1,2,19)
W "." S JP=JP+1,DVBJ2=1;@23;I $P(Z2,U,JP)'=4 S Y="@24";K Z1 I $D(DVBP(6)),+$P(DVBP(6),U) S Z1=$P(DVBP(6),U),Z1=$E(Z1,1,2)_" "_$E(Z1,3,4)_" "_$E(Z1,5,8);
"KRN",.402,960,"DR",1,2,20)
I $D(DVBVET),$P(DVBVET,U,1)="B",+$P(DVBVET,U,12) S Z1=$P(DVBVET,U,12),Z1=$E(Z1,5,6)_" "_$E(Z1,7,8)_" "_$E(Z1,1,4);I '$D(Z1) S Y="@24",JP=JP+1;I 'Z1 S Y="@24",JP=JP+1;
"KRN",.402,960,"DR",1,2,21)
I $D(^DPT(D0,.105)) W !!,"Patient is currently in-house." W !,"Discharge patient with a discharge type of DEATH." R !,?25,"<RET to continue>",DVBQ:DTIME K DVBQ S Y="@24",JP=JP+1;.351///^S X=Z1;W "." S JP=JP+1,DVBJ2=1;@24;
"KRN",.402,960,"DR",1,2,22)
I $P(Z2,U,JP)'=5 S Y="@25";K DVBSICK I $D(DVBP(6)) S DVBSICK=$P(DVBP(6),U,7);I $D(DVBCI) S DVBSICK=DVBCI;I '$D(DVBSICK) S Y="@25",JP=JP+1;.293///^S X=$S((DVBSICK="I")!(DVBSICK="Y"):1,1:0);W "." S JP=JP+1,DVBJ2=1 K DVBSICK;@25;
"KRN",.402,960,"DR",1,2,23)
I $P(Z2,U,JP)'=6 S Y="@26";I '$D(DVBPOW),'$D(DVBPOWD) S Y="@26",JP=JP+1;I '$D(DVBPOW),$D(DVBPOWD),+DVBPOWD W !!,*7,?17,DVBON,"POW Indicator Discrepancy!  <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26";
"KRN",.402,960,"DR",1,2,24)
I '$D(DVBPOW),'+DVBPOWD S Y="@26",JP=JP+1;I '$D(DVBPOWD),$D(DVBPOW),DVBPOW>0 W !!,*7,?17,DVBON,"POW Indicator Discrepancy!  <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26";
"KRN",.402,960,"DR",1,2,25)
I $D(DVBPOWD),$D(DVBPOW),DVBPOWD=0,DVBPOW>0 W !!,*7,?17,DVBON,"POW Indicator Discrepancy!  <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26";
"KRN",.402,960,"DR",1,2,26)
I $D(DVBPOWD),$D(DVBPOW),+DVBPOW<1,+DVBPOWD W !!,*7,?17,DVBON,"POW Indicator Discrepancy!  <RET>",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26";D POW^DVBHUTIL;.525///^S X=DVBPOW1;K DVBPOW1 W "." S JP=JP+1,DVBJ2=1;@26;
"KRN",.402,960,"DR",1,2,27)
I $P(Z2,U,JP)'=7 S Y="@27";I '$D(DVBFL) S Y="@27",JP=JP+1;I DVBFL']"" S Y="@27",JP=JP+1;I DVBFL'?3N1" - "1U.E S Y="@27",JP=JP+1;.314///^S X=+DVBFL;W "." S JP=JP+1,DVBJ2=1;@27;I $P(Z2,U,JP)'=8 S Y="@50";
"KRN",.402,960,"DR",1,2,28)
I '$D(DVBEI) S Y="@50",JP=JP+1;.305///^S X=$S(DVBEI="Y":"Y",1:"N");W "." S JP=JP+1,DVBJ2=1;S Y="@50";@40;I $P(Z2,U,JP)'=1 S Y="@42";I '$D(DVBP(6)) S Y="@42",JP=JP+1;
"KRN",.402,960,"DR",1,2,29)
I $S($P(DVBP(6),U,8)'="Y":1,'$D(^DPT(DFN,.32)):1,+$P(^(0),U,2):1,1:0) S Y="@42",JP=JP+1;.322///^S X="T";W "." S JP=JP+1,DVBJ2=1;@42;I $P(Z2,U,JP)'=2 S Y="@45";I '$D(DVBP(6)) S Y="@45",JP=JP+1;
"KRN",.402,960,"DR",1,2,30)
I $P(DVBP(6),U,4)[" " S Y="@45",JP=JP+1;.32101///^S X=$P(DVBP(6),U,4);W "." S JP=JP+1,DVBJ2=1;@45;I $P(Z2,U,JP)'=3!('$D(DVBDX(1))) S Y="@50";S:'$D(DVBFL) DVBFL="UNKNOWN";
"KRN",.402,960,"DR",1,2,31)
I $D(DVBCAP),DVBCAP["No C&P",$P(DVBBIR,U,5)'="Y" D CHK^DVBHUTIL;@47;
"KRN",.402,960,"DR",1,2,32)
S DVB4=$S($D(^DPT(DFN,.3))>0:$P(^(.3),U),1:0),DVB5=$S($D(^DPT(DFN,.36))>0:$P(^(.36),U),1:0),DVB6=$S($D(^DPT(DFN,"VET"))>0:^("VET"),1:0),DVB7=$S($D(^DPT(DFN,"TYPE"))>0:^("TYPE"),1:0);
"KRN",.402,960,"DR",1,2,33)
S DVB8=$O(^DIC(8,"B","SERVICE CONNECTED 50% to 100%",0)),DVB9=$O(^DIC(8,"B","SC LESS THAN 50%",0));I DVBDXNO I ((DVB8'=DVB5&(DVB9'=DVB5))!(DVB4'="Y")!(DVB6'="Y")!(DVB7'=1)) S Y="@70";
"KRN",.402,960,"DR",1,2,34)
W ! K ^DPT(DFN,.372),JP4,JP6 S ^DPT(DFN,.372,0)="^2.04P^^0",JP=0;S $P(^DPT(DFN,.3),U,2)="",$P(^DPT(DFN,.3),U,14)="";.302///^S X=+$G(DVBDXPCT);.3014///^S X=$G(DVBEFF);@46;S JP=$O(DVBDX(JP)) I 'JP S Y="@50";
"KRN",.402,960,"DR",1,2,35)
S JPP=+$P(DVBDX(JP),U,2) I JPP'>0 S Y="@46";I '$D(^DIC(31,JPP)) D CHKDIS^DVBHS3 S Y="@46";.3721///^S X="""`"_$P(DVBDX(JP),U,2)_"""";W "." S DVBJ2=1;S Y="@46";@61;S Y="@4";I Z2'[1 S Y="@62";I '$D(DVBSSA) S Y="@62",JP=JP+1;
"KRN",.402,960,"DR",1,2,36)
I DVBSSA S DVBYN="Y",DVBXYN=DVBSSA;I 'DVBSSA S DVBYN="N",DVBXYN="";.36225///^S X=DVBYN;W "." S JP=JP+1,DVBJ2=1 K DVBYN,DVBXYN;@62;I Z2'[2 S Y="@63";I '$D(DVBRETT) S Y="@63",JP=JP+1;
"KRN",.402,960,"DR",1,2,37)
I DVBRETT=""!("BMCROX"'[DVBRETT) S Y="@63",JP=JP+1;.36285///^S X=DVBRETT;W "." S JP=JP+1,DVBJ2=1;@63;I Z2'[3 S Y="@64";I '$D(DVBRETO) S Y="@64",JP=JP+1;S X=DVBRETO I X=""!(X=0) S X="@";.3628///^S X=X;W "." S JP=JP+1,DVBJ2=1;@64;
"KRN",.402,960,"DR",1,2,38)
I Z2'[4 S Y="@1006";I '$D(DVBOINC) S Y="@1006",JP=JP+1;S X=DVBOINC I X=""!(X=0) S X="@";.3629///^S X=X;W "." S JP=JP+1,DVBJ2=1,Y="@1006";@4;S Y=$S(DVBJS=11:"@1",DVBJS=28:"@2",DVBJS=35:"@3",DVBJS=44:"@104",1:"@10");@70;
"KRN",.402,960,"DR",1,2,39)
W !!,*7,"HINQ contains SC disabilities, Patient is NSC no updating allowed.  Check       patient's SERVICE CONNECTION, ELIGIBILITY CODE, VET STATUS, or PATIENT TYPE.     Screen 5 contains this.";
"KRN",.402,960,"DR",1,2,40)
R !!,?25,"<RET> to continue.",ZZ:DTIME K ZZ,JP3,JP4;@50;K DVBJX,JP,JPP S Y=$S(DVBJS=28:"@1",DVBJS=35:"@2",1:"@10");@10;I $G(DVBRADL)]"" D DX^DVBHQEDT(DVBRADL);K DVBRADL;
"KRN",.402,960,"DR",2,2.0361)
.01;
"KRN",.402,960,"DR",2,2.04)
2///^S X=$S($P(DVBDX(JP),U,3)="X0":100,1:+$P(DVBDX(JP),U,3));3///^S X=1;4///^S X=$P($G(DVBDX(JP)),U,4);5///^S X=$P($G(DVBDX(JP)),U,5);6///^S X=$P($G(DVBDX(JP)),U,6);
"KRN",.402,960,"ROU")
^DVBHCE
"KRN",.402,960,"ROUOLD")
DVBHCE
"MBREQ")
0
"ORD",5,.4)
.4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%)
"ORD",5,.4,0)
PRINT TEMPLATE
"ORD",7,.402)
.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%)
"ORD",7,.402,0)
INPUT TEMPLATE
"PKG",91,-1)
1^1
"PKG",91,0)
HINQ^DVB^HINQ(Hospital Inquiry)
"PKG",91,20,0)
^9.402P^^
"PKG",91,22,0)
^9.49I^1^1
"PKG",91,22,1,0)
4.0^2920325^2960819
"PKG",91,22,1,"PAH",1,0)
62^3120206^123457000
"PKG",91,22,1,"PAH",1,1,0)
^^1^1^3120206
"PKG",91,22,1,"PAH",1,1,1,0)
HINQ changes for the Military Service Data Sharing (MSDS) project
"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")
2
"RTN","DVBHQZ6")
0^1^B37429398
"RTN","DVBHQZ6",1,0)
DVBHQZ6 ;ISC-ALBANY/JLU/PHH/PJH-print message ; 9/26/11 4:31pm
"RTN","DVBHQZ6",2,0)
 ;;4.0;HINQ;**28,49,57,62**;03/25/92 ;Build 17
"RTN","DVBHQZ6",3,0)
1 W @$S('$D(IOF):"#",IOF="":"#",1:IOF),!!!
"RTN","DVBHQZ6",4,0)
2 D 2^DVBHUTIL
"RTN","DVBHQZ6",5,0)
3 W !!!,?5,"Printout by (M)ultiple patients, (R)equestor, (D)ate/time?   Multiple//"
"RTN","DVBHQZ6",6,0)
 R DVBA:DTIME G:DVBA="^"!('$T) K S:DVBA="" DVBA="M"
"RTN","DVBHQZ6",7,0)
 S (DVBMM2,DVBMM)=1 D M:"Mm"[DVBA,R:"Rr"[DVBA,D:"Dd"[DVBA
"RTN","DVBHQZ6",8,0)
 I "MRDmrd"'[DVBA W !!,*7,?10,"Answer with an 'M', 'R', 'D', <RET> for 'M', or '^' to quit." G 3
"RTN","DVBHQZ6",9,0)
K K DVBI,R1,DVBLEN,DVBMM2,X,POP,DVBMM1,DVBA,DVBLP,DVB,DVBMM,DVBLP1,DIC,%,DFN,ZTRTN,ZTSAVE,ZTDESC,ZTIO,DVBJIO,POP,Y,ZTSK,DVBDXSC,DVBIXMZ,DVBUSER,R,DVBCS,%DT,DVBTO,DVBFR
"RTN","DVBHQZ6",10,0)
K1 K DVBAL,DVBLP2,DVBIO,DVBLP1,DVBLP1,DVB,DVBMM,DVBJIO I '$D(ZTSK) X ^%ZIS("C")
"RTN","DVBHQZ6",11,0)
 Q
"RTN","DVBHQZ6",12,0)
M S DVB="",DIC="^DVB(395.5,",DIC(0)="AEMZQ"
"RTN","DVBHQZ6",13,0)
 S DIC("S")="I $D(^(""RS"",0))",DIC("A")="Select patient from ""HINQ Suspense file"":"
"RTN","DVBHQZ6",14,0)
 F DVBLP=1:1 D ^DIC Q:Y'>0  S DVB=DVB_+Y_"^"
"RTN","DVBHQZ6",15,0)
 K DIC I Y'>0,DVB="" Q
"RTN","DVBHQZ6",16,0)
 W ! S ZTRTN="M1^DVBHQZ6",ZTSAVE("DVB")=DVB,ZTSAVE("DVBLP")=DVBLP S:$D(DVBMM2) ZTSAVE("DVBMM2")=DVBMM2 S:$D(DVBMM) ZTSAVE("DVBMM")=DVBMM D LD:'$D(DVBMM1) Q:$D(IO("Q"))!(POP)
"RTN","DVBHQZ6",17,0)
M1 F DVBLP1=1:1:DVBLP-1 S DFN=$P(DVB,U,DVBLP1),DVBJIO=$S(IO'=IO(0):IO,1:IO(0)) I $D(^DVB(395.5,DFN,0)),($D(^("RS"))) D TEM^DVBHIQR D:'$D(DVBERCS) EN^DVBHIQM,WRT1^DVBHQD1:'$D(DVBMM1) W:$D(DVBMM1) "." Q:X="^"
"RTN","DVBHQZ6",18,0)
 Q
"RTN","DVBHQZ6",19,0)
 ;
"RTN","DVBHQZ6",20,0)
DT S %DT="TAEP",%DT("A")="From:" D ^%DT Q:Y<0  S DVBFR=Y,%DT("A")="To:" D ^%DT Q:Y<0  I DVBFR>Y W !,*7,*7,"TO date cannot be earlier than FROM date." G DT
"RTN","DVBHQZ6",21,0)
 S DVBTO=9999999-(Y+.2400),DVBFR=9999999-(DVBFR-.000001) K %DT Q
"RTN","DVBHQZ6",22,0)
 ;
"RTN","DVBHQZ6",23,0)
R S DIC(0)="AQME",DIC=200 D ^DIC Q:Y<0  S DVBAL=+Y
"RTN","DVBHQZ6",24,0)
 D DT Q:'$D(DVBFR)!('$D(DVBTO))
"RTN","DVBHQZ6",25,0)
 S ZTSAVE("DVBMM2")=DVBMM2,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBAL")=DVBAL,ZTSAVE("DVBFR")=DVBFR,ZTSAVE("DVBTO")=DVBTO,ZTRTN="R1^DVBHQZ6" D LD Q:$D(IO("Q"))!(POP)
"RTN","DVBHQZ6",26,0)
R1 S X="" F DVBLP=DVBTO:0:9999999 S DVBLP=$O(^DVB(395.5,"C",DVBLP)) Q:DVBLP>DVBFR!(X="^")!('DVBLP)  F DFN=0:0 S DFN=$O(^DVB(395.5,"C",DVBLP,DFN)) Q:'DFN!(X="^")  I $D(^DVB(395.5,"D",DVBAL,DFN,DVBAL)),$D(^DVB(395.5,DFN,0)),$D(^("RS")) D R3
"RTN","DVBHQZ6",27,0)
 Q
"RTN","DVBHQZ6",28,0)
 ;
"RTN","DVBHQZ6",29,0)
R3 S DVBJIO=$S(IO'=IO(0):IO,1:IO(0)) D TEM^DVBHIQR D:'$D(DVBERCS) EN^DVBHIQM,WRT1^DVBHQD1 Q
"RTN","DVBHQZ6",30,0)
 ;
"RTN","DVBHQZ6",31,0)
D D DT Q:'$D(DVBFR)!('$D(DVBTO))
"RTN","DVBHQZ6",32,0)
 S ZTSAVE("DVBMM2")=DVBMM2,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBFR")=DVBFR,ZTSAVE("DVBTO")=DVBTO,ZTRTN="D1^DVBHQZ6" D LD Q:$D(IO("Q"))!(POP)
"RTN","DVBHQZ6",33,0)
D1 S X="" F DVBLP=DVBTO:0:9999999 S DVBLP=$O(^DVB(395.5,"C",DVBLP)) Q:DVBLP>DVBFR!(X="^")!('DVBLP)  F DFN=0:0 S DFN=$O(^DVB(395.5,"C",DVBLP,DFN)) Q:'DFN!(X="^")  I $D(^DVB(395.5,DFN,0)),$D(^("RS")) D R3
"RTN","DVBHQZ6",34,0)
 Q
"RTN","DVBHQZ6",35,0)
 ;
"RTN","DVBHQZ6",36,0)
EM W !!,"Do you wish to create a mail message, to be sent to the requestors" S %=2 D YN^DICN I %=0 W *7,!,"'YES' to create a mail message  'NO' will not" G EM
"RTN","DVBHQZ6",37,0)
 I %=1 S DVBMM1=1,POP=0 D M W:$D(DVBLP1) !,"Mail Sent."
"RTN","DVBHQZ6",38,0)
 D K Q
"RTN","DVBHQZ6",39,0)
 ;
"RTN","DVBHQZ6",40,0)
LD S %IS="MQ" D ^%ZIS Q:POP  I $D(IO("Q")) S ZTDESC="This is the HINQ Print/Mail option.",ZTIO=ION D ^%ZTLOAD X ^%ZIS("C")
"RTN","DVBHQZ6",41,0)
 Q
"RTN","DVBHQZ6",42,0)
 ;
"RTN","DVBHQZ6",43,0)
S1 ;
"RTN","DVBHQZ6",44,0)
 I $D(DVBDX) D LABELS^DVBHS3
"RTN","DVBHQZ6",45,0)
 F JU=0:0 S JU=$O(DVBDX(JU)) Q:'JU  I +DVBDX(JU),DVBDX(JU)'["-" D S2
"RTN","DVBHQZ6",46,0)
 Q
"RTN","DVBHQZ6",47,0)
S2 I ($Y+5)>IOSL,$E(IOST,1,2)="C-" D PAUSE^DVBHS3
"RTN","DVBHQZ6",48,0)
 I $G(QUIT)=1 Q
"RTN","DVBHQZ6",49,0)
 W !,$S($P(DVBDX(JU),U,2)="":$P(DVBDX(JU),U),$D(^DIC(31,$P(DVBDX(JU),U,2),0)):$E($P(^(0),U),1,40),1:"")
"RTN","DVBHQZ6",50,0)
 W ?42,$S($P(DVBDX(JU),U,3)="X0":100,1:+$P(DVBDX(JU),U,3))
"RTN","DVBHQZ6",51,0)
 W ?50,$P($G(DVBDX(JU)),U,4)
"RTN","DVBHQZ6",52,0)
 ;DVB*4*54 - format date fields
"RTN","DVBHQZ6",53,0)
 N DVBF,DVBFF
"RTN","DVBHQZ6",54,0)
 F DVBF=5,6 S DVBFF=$P($G(DVBDX(JU)),U,DVBF) D
"RTN","DVBHQZ6",55,0)
 . I $G(DVBFF)?8N D
"RTN","DVBHQZ6",56,0)
 . . S M=$E(DVBFF,1,2)
"RTN","DVBHQZ6",57,0)
 . . D MM^DVBHQM11
"RTN","DVBHQZ6",58,0)
 . . S DVBF(DVBF)=M_" "_$S($E(DVBFF,3,4)]"":$E(DVBFF,3,4),1:"  ")_","_$E(DVBFF,5,8)
"RTN","DVBHQZ6",59,0)
 W ?55,$G(DVBF(5)),?68,$G(DVBF(6))
"RTN","DVBHQZ6",60,0)
 K QUIT
"RTN","DVBHQZ6",61,0)
 Q
"RTN","DVBHQZ6",62,0)
 ;
"RTN","DVBHQZ6",63,0)
QB S %=2 W !!,"Would you like a HINQ message printed out " D YN^DICN I %<0!(%=2) Q
"RTN","DVBHQZ6",64,0)
 I '% W !!,"A YES will result in a HINQ printout queued to the device you select." G QB
"RTN","DVBHQZ6",65,0)
 W !,"I will queue all messages!"
"RTN","DVBHQZ6",66,0)
 K IOP S %IS="NMQ",%IS("B")="" D ^%ZIS K %IS I POP W !,"No printout queued!" G EX
"RTN","DVBHQZ6",67,0)
 S IOP=ION_";"_IOST_$S($D(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL)
"RTN","DVBHQZ6",68,0)
 I IO=IO(0) W !,"Can not queue to your HOME device." G QB
"RTN","DVBHQZ6",69,0)
 I IO'=IO(0),'$D(IO("Q")) W !,"I am QUEUEING this report to run now." S IO("Q")=1,ZTDTH=$H
"RTN","DVBHQZ6",70,0)
 S DVBMM2=1,ZTRTN="M1^DVBHQZ6",ZTIO=IOP,ZTSAVE("DVB")=DVB,ZTSAVE("DVBLP")=DVBLP,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBMM2")=DVBMM2,ZTDESC="This is the HINQ report." K IO("Q") D ^%ZTLOAD
"RTN","DVBHQZ6",71,0)
EX S IOP="HOME" D ^%ZIS K DVB,DVBLP,DVBMM,DVBMM2,ZTRTN,ZTIO,ZTSAVE,ZTDESC,IOP Q
"RTN","DVBHQZ6",72,0)
 ;
"RTN","DVBHQZ6",73,0)
 ;APIs added for MSDS (DVB*4*62)
"RTN","DVBHQZ6",74,0)
 ;------------------------------
"RTN","DVBHQZ6",75,0)
 ;
"RTN","DVBHQZ6",76,0)
DISP(DFN) ;Display episodes for [DVBHINQ PAT-HINQ COMP] template
"RTN","DVBHQZ6",77,0)
 ;
"RTN","DVBHQZ6",78,0)
 N ARRAY,MORE
"RTN","DVBHQZ6",79,0)
 ;If no data exists in .3216 nodes display old data
"RTN","DVBHQZ6",80,0)
 I '$O(^DPT(DFN,.3216,"B",0)) D OLD(DFN,.ARRAY)
"RTN","DVBHQZ6",81,0)
 ;Otherwise use .3216 multiple
"RTN","DVBHQZ6",82,0)
 E  D NEW(DFN,.ARRAY)
"RTN","DVBHQZ6",83,0)
 ;
"RTN","DVBHQZ6",84,0)
 ;Display MSE data
"RTN","DVBHQZ6",85,0)
 N BOS,COMP,DATA,DISCH,EODATE,IEN,RADATE,SERVN
"RTN","DVBHQZ6",86,0)
 S CNT=0
"RTN","DVBHQZ6",87,0)
 F  S CNT=$O(ARRAY(CNT)) Q:'CNT  D
"RTN","DVBHQZ6",88,0)
 .S DATA=$G(ARRAY(CNT)) Q:DATA=""
"RTN","DVBHQZ6",89,0)
 .S DISCH=$P(DATA,U,6) ;Discharge
"RTN","DVBHQZ6",90,0)
 .S:DISCH]"" DISCH=$P($G(^DIC(25,DISCH,0)),U)
"RTN","DVBHQZ6",91,0)
 .S BOS=$P(DATA,U,3) ;Branch
"RTN","DVBHQZ6",92,0)
 .S:BOS]"" BOS=$P($G(^DIC(23,BOS,0)),U)
"RTN","DVBHQZ6",93,0)
 .S RADATE=$P(DATA,U) ;Entry Date
"RTN","DVBHQZ6",94,0)
 .S RADATE=$$FMTE^XLFDT(RADATE)
"RTN","DVBHQZ6",95,0)
 .S EODATE=$P(DATA,U,2) ;Separation Date
"RTN","DVBHQZ6",96,0)
 .S EODATE=$$FMTE^XLFDT(EODATE)
"RTN","DVBHQZ6",97,0)
 .S SERVN=$P(DATA,U,5) ;Service Number
"RTN","DVBHQZ6",98,0)
 .I CNT=1 W !,?1,"Last episode"
"RTN","DVBHQZ6",99,0)
 .I CNT=2 W !,?1,"NTL episode"
"RTN","DVBHQZ6",100,0)
 .I CNT=3 W !,?1,"NNTL episode"
"RTN","DVBHQZ6",101,0)
 .;Note that Service Component is not displayed
"RTN","DVBHQZ6",102,0)
 .W !,?1,RADATE,?15,EODATE,?34,BOS,?48,DISCH,?62,SERVN
"RTN","DVBHQZ6",103,0)
 .I CNT=3,$G(MORE) W !,?1,"<more episodes>"
"RTN","DVBHQZ6",104,0)
 Q
"RTN","DVBHQZ6",105,0)
 ;
"RTN","DVBHQZ6",106,0)
NEW(DFN,ARRAY) ;Check for new MSE format data
"RTN","DVBHQZ6",107,0)
 N CNT,SDAT
"RTN","DVBHQZ6",108,0)
 S CNT=0,SDAT="A"
"RTN","DVBHQZ6",109,0)
 F  S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT  D  Q:CNT>2
"RTN","DVBHQZ6",110,0)
 .S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
"RTN","DVBHQZ6",111,0)
 .S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
"RTN","DVBHQZ6",112,0)
 .S CNT=CNT+1,ARRAY(CNT)=DATA
"RTN","DVBHQZ6",113,0)
 .I CNT=3,$O(^DPT(DFN,.3216,"B",SDAT),-1) S MORE=1
"RTN","DVBHQZ6",114,0)
 Q
"RTN","DVBHQZ6",115,0)
 ;
"RTN","DVBHQZ6",116,0)
OLD(DFN,ARRAY) ;Get old format VistA data
"RTN","DVBHQZ6",117,0)
 N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
"RTN","DVBHQZ6",118,0)
 S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
"RTN","DVBHQZ6",119,0)
 ;Last service episode (SL)
"RTN","DVBHQZ6",120,0)
 D EPISODE(1,4,8)
"RTN","DVBHQZ6",121,0)
 ;Next to last service episode (SNL)
"RTN","DVBHQZ6",122,0)
 Q:$P(DGRP(.32),"^",19)'="Y"  D EPISODE(2,9,13)
"RTN","DVBHQZ6",123,0)
 ;Prior episode (SNNL)
"RTN","DVBHQZ6",124,0)
 I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
"RTN","DVBHQZ6",125,0)
 Q
"RTN","DVBHQZ6",126,0)
 ;
"RTN","DVBHQZ6",127,0)
EPISODE(SUB,P1,P2) ;Get old VistA data and save
"RTN","DVBHQZ6",128,0)
 S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
"RTN","DVBHQZ6",129,0)
 S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
"RTN","DVBHQZ6",130,0)
 S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
"RTN","DVBHQZ6",131,0)
 ;Save in format of new .3216 multiple (no lock flag)
"RTN","DVBHQZ6",132,0)
 S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U
"RTN","DVBHQZ6",133,0)
 Q
"RTN","DVBHS4")
0^2^B19622289
"RTN","DVBHS4",1,0)
DVBHS4 ; ALB/JLU/PJH;Routine for HINQ screen 4 ; 9/26/11 4:33pm
"RTN","DVBHS4",2,0)
 ;;4.0;HINQ;**4,49,62**;03/25/92;Build 17
"RTN","DVBHS4",3,0)
 ;
"RTN","DVBHS4",4,0)
 N Y
"RTN","DVBHS4",5,0)
 K DVBX(1)
"RTN","DVBHS4",6,0)
 F LP2=.323,.324,.328,.329,.3291,.3299 S X="DVBDIQ(2,"_DFN_","_LP2_")" K @X
"RTN","DVBHS4",7,0)
 I $D(X(1)) S DVBX(1)=X(1)
"RTN","DVBHS4",8,0)
 S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="DVBDIQ("
"RTN","DVBHS4",9,0)
 S DR=".323;.324:.328;.329;.3291:.3299"
"RTN","DVBHS4",10,0)
 D EN^DIQ1
"RTN","DVBHS4",11,0)
 I $D(DVBX(1)) S X(1)=DVBX(1) K DVBX(1)
"RTN","DVBHS4",12,0)
 ;
"RTN","DVBHS4",13,0)
 S DVBSCRN=4 D SCRHD^DVBHUTIL
"RTN","DVBHS4",14,0)
 S DVBJS=44
"RTN","DVBHS4",15,0)
 W ?325,DVBON,"HINQ Data",DVBOFF
"RTN","DVBHS4",16,0)
 W !,?5,"EOD",?17,"RAD",?27,"Bran. Ser.",?44,"Char. Ser.",?69,"Ser. Num."
"RTN","DVBHS4",17,0)
 D LINE
"RTN","DVBHS4",18,0)
 ;
"RTN","DVBHS4",19,0)
 ;DVB*4*49 - all MS data should be in the BIRLS segment, so if second 
"RTN","DVBHS4",20,0)
 ;node of all these arrays is populated, kill the first node
"RTN","DVBHS4",21,0)
 I +$G(DVBEOD(2))>0 K DVBEOD(1)
"RTN","DVBHS4",22,0)
 I +$G(DVBRAD(2))>0 K DVBRAD(1)
"RTN","DVBHS4",23,0)
 I $G(DVBBOS(2))]"" K DVBBOS(1)
"RTN","DVBHS4",24,0)
 I $G(DVBCSVC(2))]"" K DVBCSVC(1)
"RTN","DVBHS4",25,0)
 I $G(DVBSN(2))]"" K DVBSN(1)
"RTN","DVBHS4",26,0)
 W ! I $D(DVBEOD(1)),DVBEOD(1)?8N S M=$E(DVBEOD(1),1,2) D MM^DVBHQM11 W M," ",$E(DVBEOD(1),3,4),",",$E(DVBEOD(1),5,8)
"RTN","DVBHS4",27,0)
 I $D(DVBRAD(1)),DVBRAD(1)?8N S M=$E(DVBRAD(1),1,2) D MM^DVBHQM11 W ?14,M," ",$E(DVBRAD(1),3,4),",",$E(DVBRAD(1),5,8)
"RTN","DVBHS4",28,0)
 I $D(DVBBOS(1)) S Y=DVBBOS(1) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
"RTN","DVBHS4",29,0)
 I $D(DVBCSVC(1)) S I=1,Y=DVBCSVC(1) D DISCHG^DVBHQM1 W ?44,Y K Y
"RTN","DVBHS4",30,0)
 I $D(DVBSN(1)) W ?69,DVBSN(1)
"RTN","DVBHS4",31,0)
 W ! I $D(DVBEOD(2)),DVBEOD(2)?7N S Y=DVBEOD(2) X ^DD("DD") W ?1,Y K Y
"RTN","DVBHS4",32,0)
 I $D(DVBRAD(2)),DVBRAD(2)?7N S Y=DVBRAD(2) X ^DD("DD") W ?14,Y K Y
"RTN","DVBHS4",33,0)
 I $D(DVBBOS(2)) S Y=DVBBOS(2) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
"RTN","DVBHS4",34,0)
 I $D(DVBCSVC(2)) S Y=$$DISCH2^DVBHQM1(DVBCSVC(2)) W ?44,Y K Y
"RTN","DVBHS4",35,0)
 I $D(DVBSN(2)) W ?69,DVBSN(2)
"RTN","DVBHS4",36,0)
 W ! I $D(DVBEOD(3)),DVBEOD(3)?7N S Y=DVBEOD(3) X ^DD("DD") W ?1,Y K Y
"RTN","DVBHS4",37,0)
 I $D(DVBRAD(3)),DVBRAD(3)?7N S Y=DVBRAD(3) X ^DD("DD") W ?14,Y K Y
"RTN","DVBHS4",38,0)
 I $D(DVBBOS(3)) S Y=DVBBOS(3) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
"RTN","DVBHS4",39,0)
 I $D(DVBCSVC(3)) S Y=$$DISCH2^DVBHQM1(DVBCSVC(3)) W ?44,Y K Y
"RTN","DVBHS4",40,0)
 I $D(DVBSN(3)) W ?69,DVBSN(3)
"RTN","DVBHS4",41,0)
 W ! I $D(DVBEOD(4)),DVBEOD(4)?7N S Y=DVBEOD(4) X ^DD("DD") W ?1,Y K Y
"RTN","DVBHS4",42,0)
 I $D(DVBRAD(4)),DVBRAD(4)?7N S Y=DVBRAD(4) X ^DD("DD") W ?14,Y K Y
"RTN","DVBHS4",43,0)
 I $D(DVBBOS(4)) S Y=DVBBOS(4) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
"RTN","DVBHS4",44,0)
 I $D(DVBCSVC(4)) S Y=$$DISCH2^DVBHQM1(DVBCSVC(4)) W ?44,Y K Y
"RTN","DVBHS4",45,0)
 I $D(DVBSN(4)) W ?69,DVBSN(4)
"RTN","DVBHS4",46,0)
 I $D(DVBSCR) K DVBSCR D LINE W ! Q
"RTN","DVBHS4",47,0)
 W !,?34,DVBON,"Patient File",DVBOFF
"RTN","DVBHS4",48,0)
 D LINE,MSE(DFN)
"RTN","DVBHS4",49,0)
 W !,DVBON,"(4)",DVBOFF X DVBLIT1
"RTN","DVBHS4",50,0)
 W ?4,"Per. of Ser.:",?18,$E(DVBDIQ(2,DFN,.323,"E"),1,25)
"RTN","DVBHS4",51,0)
 Q
"RTN","DVBHS4",52,0)
LINE W !,"-------------------------------------------------------------------------------"
"RTN","DVBHS4",53,0)
 Q
"RTN","DVBHS4",54,0)
 ;
"RTN","DVBHS4",55,0)
 ;APIs added for MSDS (DVB*4*62)
"RTN","DVBHS4",56,0)
 ;------------------------------
"RTN","DVBHS4",57,0)
 ;
"RTN","DVBHS4",58,0)
MSE(DFN) ;Display episodes for [DVBHINQ PAT-HINQ COMP] template
"RTN","DVBHS4",59,0)
 ;
"RTN","DVBHS4",60,0)
 N ARRAY,MORE,SOURCE
"RTN","DVBHS4",61,0)
 ;If no data exists in .3216 nodes display old data
"RTN","DVBHS4",62,0)
 S MORE=0,SOURCE=.32 I $O(^DPT(DFN,.3216,"B",0)) S SOURCE=.3216
"RTN","DVBHS4",63,0)
 ;
"RTN","DVBHS4",64,0)
 ;Collect old data from .32
"RTN","DVBHS4",65,0)
 I SOURCE=.32 D OLD(DFN,.ARRAY)
"RTN","DVBHS4",66,0)
 ;Collect last three episodes from .3216 multiple
"RTN","DVBHS4",67,0)
 I SOURCE=.3216 D NEW(DFN,.ARRAY)
"RTN","DVBHS4",68,0)
 ;
"RTN","DVBHS4",69,0)
 ;Display MSE data
"RTN","DVBHS4",70,0)
 N BOS,COMP,DATA,DISCH,EODATE,IEN,RADATE,SERVN
"RTN","DVBHS4",71,0)
 S CNT=0
"RTN","DVBHS4",72,0)
 F  S CNT=$O(ARRAY(CNT)) Q:'CNT  D
"RTN","DVBHS4",73,0)
 .S DATA=$G(ARRAY(CNT)) Q:DATA=""
"RTN","DVBHS4",74,0)
 .S DISCH=$P(DATA,U,6) ;Discharge
"RTN","DVBHS4",75,0)
 .S:DISCH]"" DISCH=$P($G(^DIC(25,DISCH,0)),U)
"RTN","DVBHS4",76,0)
 .S BOS=$P(DATA,U,3) ;Branch
"RTN","DVBHS4",77,0)
 .S:BOS]"" BOS=$P($G(^DIC(23,BOS,0)),U)
"RTN","DVBHS4",78,0)
 .S RADATE=$P(DATA,U) ;Entry Date
"RTN","DVBHS4",79,0)
 .S RADATE=$$FMTE^XLFDT(RADATE)
"RTN","DVBHS4",80,0)
 .S EODATE=$P(DATA,U,2) ;Separation Date
"RTN","DVBHS4",81,0)
 .S EODATE=$$FMTE^XLFDT(EODATE)
"RTN","DVBHS4",82,0)
 .S SERVN=$P(DATA,U,5) ;Service Number
"RTN","DVBHS4",83,0)
 .I SOURCE=.32 W !,DVBON,"("_CNT_")",DVBOFF
"RTN","DVBHS4",84,0)
 .I SOURCE=.3216 W !,"<"_CNT_">"
"RTN","DVBHS4",85,0)
 .W $S(CNT=1:" Last",CNT=2:" NTL",1:" NNTL")_" episode"
"RTN","DVBHS4",86,0)
 .;Note that Service Component is not displayed
"RTN","DVBHS4",87,0)
 .W !,?1,RADATE,?15,EODATE,?34,BOS,?48,DISCH,?62,SERVN
"RTN","DVBHS4",88,0)
 .I CNT=3,MORE W !,?1,"<more episodes>"
"RTN","DVBHS4",89,0)
 Q
"RTN","DVBHS4",90,0)
 ;
"RTN","DVBHS4",91,0)
NEW(DFN,ARRAY) ;Check for new MSE format data
"RTN","DVBHS4",92,0)
 N CNT,SDAT
"RTN","DVBHS4",93,0)
 S CNT=0,SDAT="A"
"RTN","DVBHS4",94,0)
 F  S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT  D  Q:CNT>2
"RTN","DVBHS4",95,0)
 .S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
"RTN","DVBHS4",96,0)
 .S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
"RTN","DVBHS4",97,0)
 .S CNT=CNT+1,ARRAY(CNT)=DATA
"RTN","DVBHS4",98,0)
 .I CNT=3,$O(^DPT(DFN,.3216,"B",SDAT),-1) S MORE=1
"RTN","DVBHS4",99,0)
 Q
"RTN","DVBHS4",100,0)
 ;
"RTN","DVBHS4",101,0)
OLD(DFN,ARRAY) ;Get old format VistA data
"RTN","DVBHS4",102,0)
 N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
"RTN","DVBHS4",103,0)
 S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
"RTN","DVBHS4",104,0)
 ;Last service episode (SL)
"RTN","DVBHS4",105,0)
 D EPISODE(1,4,8)
"RTN","DVBHS4",106,0)
 ;Next to last service episode (SNL)
"RTN","DVBHS4",107,0)
 Q:$P(DGRP(.32),"^",19)'="Y"  D EPISODE(2,9,13)
"RTN","DVBHS4",108,0)
 ;Prior episode (SNNL)
"RTN","DVBHS4",109,0)
 I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
"RTN","DVBHS4",110,0)
 Q
"RTN","DVBHS4",111,0)
 ;
"RTN","DVBHS4",112,0)
EPISODE(SUB,P1,P2) ;Get old VistA data and save
"RTN","DVBHS4",113,0)
 S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
"RTN","DVBHS4",114,0)
 S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
"RTN","DVBHS4",115,0)
 S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
"RTN","DVBHS4",116,0)
 ;Save in format of new .3216 multiple (no lock flag)
"RTN","DVBHS4",117,0)
 S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U
"RTN","DVBHS4",118,0)
 Q
"VER")
8.0^22.0
**INSTALL NAME**
PXRM*2.0*21
"BLD",8582,0)
PXRM*2.0*21^CLINICAL REMINDERS^0^3120206^y
"BLD",8582,1,0)
^^1^1^3110609^
"BLD",8582,1,1,0)
DG API Updates.
"BLD",8582,4,0)
^9.64PA^811.4^1
"BLD",8582,4,811.4,0)
811.4
"BLD",8582,4,811.4,222)
n^n^f^^n^^y^o^n
"BLD",8582,4,811.4,223)

"BLD",8582,4,811.4,224)
I $$CFINC^PXRMP21I(Y)
"BLD",8582,4,"B",811.4,811.4)

"BLD",8582,6.3)
152
"BLD",8582,"ABPKG")
n
"BLD",8582,"INI")
PRE^PXRMP21I
"BLD",8582,"INIT")
POST^PXRMP21I
"BLD",8582,"KRN",0)
^9.67PA^779.2^20
"BLD",8582,"KRN",.4,0)
.4
"BLD",8582,"KRN",.401,0)
.401
"BLD",8582,"KRN",.402,0)
.402
"BLD",8582,"KRN",.403,0)
.403
"BLD",8582,"KRN",.5,0)
.5
"BLD",8582,"KRN",.84,0)
.84
"BLD",8582,"KRN",3.6,0)
3.6
"BLD",8582,"KRN",3.8,0)
3.8
"BLD",8582,"KRN",9.2,0)
9.2
"BLD",8582,"KRN",9.8,0)
9.8
"BLD",8582,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",8582,"KRN",9.8,"NM",1,0)
PXRMMSER^^0^B106196572
"BLD",8582,"KRN",9.8,"NM",2,0)
PXRMP21I^^0^B4139737
"BLD",8582,"KRN",9.8,"NM","B","PXRMMSER",1)

"BLD",8582,"KRN",9.8,"NM","B","PXRMP21I",2)

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

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

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

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

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

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

"BLD",8582,"KRN","B",3.6,3.6)

"BLD",8582,"KRN","B",3.8,3.8)

"BLD",8582,"KRN","B",9.2,9.2)

"BLD",8582,"KRN","B",9.8,9.8)

"BLD",8582,"KRN","B",19,19)

"BLD",8582,"KRN","B",19.1,19.1)

"BLD",8582,"KRN","B",101,101)

"BLD",8582,"KRN","B",409.61,409.61)

"BLD",8582,"KRN","B",771,771)

"BLD",8582,"KRN","B",779.2,779.2)

"BLD",8582,"KRN","B",870,870)

"BLD",8582,"KRN","B",8989.51,8989.51)

"BLD",8582,"KRN","B",8989.52,8989.52)

"BLD",8582,"KRN","B",8994,8994)

"BLD",8582,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",8582,"QUES",0)
^9.62^^
"BLD",8582,"REQB",0)
^9.611^3^2
"BLD",8582,"REQB",2,0)
PXRM*2.0*17^2
"BLD",8582,"REQB",3,0)
DG*5.3*797^2
"BLD",8582,"REQB","B","DG*5.3*797",3)

"BLD",8582,"REQB","B","PXRM*2.0*17",2)

"DATA",811.4,7,0)
VA-SERVICE BRANCH^PXRMMSER^SBRANCH^VA-Service Branch^M^^
"DATA",811.4,7,1,0)
^811.41^13^13^3120201^^^^
"DATA",811.4,7,1,1,0)
This multiple occurrence computed finding will return service branch
"DATA",811.4,7,1,2,0)
information for one or more service periods in the date range.
"DATA",811.4,7,1,3,0)
 
"DATA",811.4,7,1,4,0)
CSUB data that can be used in a Condition are:
"DATA",811.4,7,1,5,0)
 "BRANCH"
"DATA",811.4,7,1,6,0)
 "DISCHARGE TYPE"
"DATA",811.4,7,1,7,0)
 "ENTRY DATE"
"DATA",811.4,7,1,8,0)
 "SEPARATION DATE"
"DATA",811.4,7,1,9,0)
 "SERVICE COMPONENT"
"DATA",811.4,7,1,10,0)
 
"DATA",811.4,7,1,11,0)
The default value is "BRANCH".
"DATA",811.4,7,1,12,0)

"DATA",811.4,7,1,13,0)

"DATA",811.4,7,100)
N
"DATA",811.4,81,0)
VA-OEF/OIF SERVICE (LIST)^PXRMMSER^OEIF^VA-OEF/OIF Service List Patient List^L^^
"DATA",811.4,81,1,0)
^811.41^29^29^3110715^^^^
"DATA",811.4,81,1,1,0)
This list type computed finding builds a list of patients who have
"DATA",811.4,81,1,2,0)
been deployed in Operation Enduring Freedom (OEF) or Operation Iraqi
"DATA",811.4,81,1,3,0)
Freedom (OIF). If the location was either OEF or OIF, but cannot be
"DATA",811.4,81,1,4,0)
disclosed/determined, then it is listed as unknown (UNK).
"DATA",811.4,81,1,5,0)
  
"DATA",811.4,81,1,6,0)
Date range searching is done by looking for an overlap in the
"DATA",811.4,81,1,7,0)
period defined by Beginning Date/Time (BDT) and Ending Date/Time
"DATA",811.4,81,1,8,0)
(EDT), with the period defined by OEF/OIF From and To Dates. In order
"DATA",811.4,81,1,9,0)
for a patient to be included on the list, there must be an overlap of
"DATA",811.4,81,1,10,0)
these two time periods. In other words, if patients had service
"DATA",811.4,81,1,11,0)
at any time in the date range specified by BDT and EDT, they will be
"DATA",811.4,81,1,12,0)
included.
"DATA",811.4,81,1,13,0)
 
"DATA",811.4,81,1,14,0)
The Computed Finding Parameter can be used to include only patients
"DATA",811.4,81,1,15,0)
who had service at a specific location. The locations can be OEF,
"DATA",811.4,81,1,16,0)
OIF, or ANY. The value ANY, which is the default, will include all
"DATA",811.4,81,1,17,0)
locations. Each location is separated by the "^" character. For
"DATA",811.4,81,1,18,0)
example, to include patients who had OEF, service the Computed
"DATA",811.4,81,1,19,0)
Finding Parameter is:
"DATA",811.4,81,1,20,0)
 OEF
"DATA",811.4,81,1,21,0)
To include patients who had either OEF or OIF service, the Computed
"DATA",811.4,81,1,22,0)
Finding Parameter is:
"DATA",811.4,81,1,23,0)
 OEF^OIF
"DATA",811.4,81,1,24,0)
To include patients who had UNK, service the Computed Finding Parameter is:
"DATA",811.4,81,1,25,0)
 UNK
"DATA",811.4,81,1,26,0)

"DATA",811.4,81,1,27,0)

"DATA",811.4,81,1,28,0)

"DATA",811.4,81,1,29,0)

"DATA",811.4,81,100)
N
"DATA",811.4,578006,0)
VA-SERVICE SEPARATION DATES^PXRMMSER^DISCHDT^VA-Service Separation Date(s)^M^^
"DATA",811.4,578006,1,0)
^811.41^12^12^3120201^^^^
"DATA",811.4,578006,1,1,0)
This multiple occurrence computed finding returns service separation
"DATA",811.4,578006,1,2,0)
information. The date of the finding is the separation date.
"DATA",811.4,578006,1,3,0)
 
"DATA",811.4,578006,1,4,0)
CSUB data that can be used in a Condition are: 
"DATA",811.4,578006,1,5,0)
  "BRANCH" 
"DATA",811.4,578006,1,6,0)
  "DISCHARGE TYPE" 
"DATA",811.4,578006,1,7,0)
  "ENTRY DATE" 
"DATA",811.4,578006,1,8,0)
  "SEPARATION DATE" 
"DATA",811.4,578006,1,9,0)
  "SERVICE COMPONENT" 
"DATA",811.4,578006,1,10,0)
  
"DATA",811.4,578006,1,11,0)
 The default value is the separation date.
"DATA",811.4,578006,1,12,0)

"DATA",811.4,578006,100)
N^15
"DATA",811.4,578006,110,0)
^811.42D^3^3
"DATA",811.4,578006,110,1,0)
3081022.132437^66481
"DATA",811.4,578006,110,1,1,0)
^^1^1^3081022
"DATA",811.4,578006,110,1,1,1,0)
Exchange Install
"DATA",811.4,578006,110,2,0)
3110418.141839^254
"DATA",811.4,578006,110,2,1,0)
^811.422^1^1^3110428^
"DATA",811.4,578006,110,2,1,1,0)
Exchange Install
"DATA",811.4,578006,110,3,0)
3110428^254
"DATA",811.4,578006,110,3,1,0)
^811.422^1^1^3110608^^^^
"DATA",811.4,578006,110,3,1,1,0)
Changed to multiple
"FIA",811.4)
REMINDER COMPUTED FINDINGS
"FIA",811.4,0)
^PXRMD(811.4,
"FIA",811.4,0,0)
811.4OI
"FIA",811.4,0,1)
n^n^f^^n^^y^o^n
"FIA",811.4,0,10)

"FIA",811.4,0,11)
I $$CFINC^PXRMP21I(Y)
"FIA",811.4,0,"RLRO")

"FIA",811.4,0,"VR")
2.0^PXRM
"FIA",811.4,811.4)
0
"FIA",811.4,811.41)
0
"FIA",811.4,811.42)
0
"FIA",811.4,811.422)
0
"INI")
PRE^PXRMP21I
"INIT")
POST^PXRMP21I
"IX",811.4,811.4,"B",0)
811.4^B^New style B cross-reference^R^^F^IR^I^811.4^^^^^LS
"IX",811.4,811.4,"B",1)
S ^PXRMD(811.4,"B",$E(X,1,64),DA)=""
"IX",811.4,811.4,"B",2)
K ^PXRMD(811.4,"B",$E(X,1,64),DA)
"IX",811.4,811.4,"B",2.5)
K ^PXRMD(811.4,"B")
"IX",811.4,811.4,"B",11.1,0)
^.114IA^1^1
"IX",811.4,811.4,"B",11.1,1,0)
1^F^811.4^.01^64^1^F
"KEY",811.4,811.4,"A",0)
811.4^A^P^791
"KEY",811.4,811.4,"A",2,0)
^.312IA^1^1
"KEY",811.4,811.4,"A",2,1,0)
.01^811.4^1
"KEYPTR",811.4,811.4,"A")
811.4^B
"MBREQ")
0
"PKG",186,-1)
1^1
"PKG",186,0)
CLINICAL REMINDERS^PXRM^Clinical Reminders^^^3000614
"PKG",186,22,0)
^9.49I^1^1
"PKG",186,22,1,0)
2.0^3050204^3050216^66481
"PKG",186,22,1,"PAH",1,0)
21^3120206^123457024
"PKG",186,22,1,"PAH",1,1,0)
^^1^1^3120206
"PKG",186,22,1,"PAH",1,1,1,0)
DG API Updates.
"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")
2
"RTN","PXRMMSER")
0^1^B106196572
"RTN","PXRMMSER",1,0)
PXRMMSER ;SLC/PKR,AJB - Computed findings for military service information. ;02/01/2012
"RTN","PXRMMSER",2,0)
 ;;2.0;CLINICAL REMINDERS;**11,12,21**;Feb 04, 2005;Build 152
"RTN","PXRMMSER",3,0)
 ;
"RTN","PXRMMSER",4,0)
 ;======================================================
"RTN","PXRMMSER",5,0)
AORANGE(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed
"RTN","PXRMMSER",6,0)
 ;finding will be true if the agent orange exposure registration
"RTN","PXRMMSER",7,0)
 ;date is in the date range specified by Beginning Date/Time
"RTN","PXRMMSER",8,0)
 ;and Ending Date/Time. VA-AGENT ORANGE EXPOSURE.
"RTN","PXRMMSER",9,0)
 N RDATE
"RTN","PXRMMSER",10,0)
 S NFOUND=0
"RTN","PXRMMSER",11,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",12,0)
 S TEST=^TMP($J,"SVC",DFN,2)
"RTN","PXRMMSER",13,0)
 I 'TEST Q
"RTN","PXRMMSER",14,0)
 S RDATE=+$P(^TMP($J,"SVC",DFN,2,1),U,1)
"RTN","PXRMMSER",15,0)
 I (RDATE=0)!(RDATE<BDT)!(RDATE>EDT) S TEST=0 Q
"RTN","PXRMMSER",16,0)
 S NFOUND=1
"RTN","PXRMMSER",17,0)
 S TEST(NFOUND)=1,DATE(NFOUND)=RDATE
"RTN","PXRMMSER",18,0)
 S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"LOCATION"))=$P(^TMP($J,"SVC",DFN,2,5),U,2)
"RTN","PXRMMSER",19,0)
 S TEXT(NFOUND)="Agent orange exposure registration date: "_$$FMTE^XLFDT(RDATE,"5Z")_"; location: "_DATA(NFOUND,"LOCATION")
"RTN","PXRMMSER",20,0)
 Q
"RTN","PXRMMSER",21,0)
 ;
"RTN","PXRMMSER",22,0)
 ;======================================================
"RTN","PXRMMSER",23,0)
COMBAT(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed
"RTN","PXRMMSER",24,0)
 ;finding will be true if combat service is found in the
"RTN","PXRMMSER",25,0)
 ;date range the date range specified by Beginning Date/Time
"RTN","PXRMMSER",26,0)
 ;and Ending Date/Time. VA-COMBAT SERVICE.
"RTN","PXRMMSER",27,0)
 N FDATE,TDATE
"RTN","PXRMMSER",28,0)
 S NFOUND=0
"RTN","PXRMMSER",29,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",30,0)
 S TEST=^TMP($J,"SVC",DFN,5)
"RTN","PXRMMSER",31,0)
 I 'TEST Q
"RTN","PXRMMSER",32,0)
 S FDATE=$P(^TMP($J,"SVC",DFN,5,1),U,1)
"RTN","PXRMMSER",33,0)
 S TDATE=$P(^TMP($J,"SVC",DFN,5,2),U,1)
"RTN","PXRMMSER",34,0)
 I $$OVERLAP^PXRMINDX(FDATE,TDATE,BDT,EDT)'="O" S TEST=0 Q
"RTN","PXRMMSER",35,0)
 S NFOUND=1
"RTN","PXRMMSER",36,0)
 S TEST(NFOUND)=1,DATE(NFOUND)=FDATE
"RTN","PXRMMSER",37,0)
 S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"LOCATION"))=$P(^TMP($J,"SVC",DFN,5,3),U,2)
"RTN","PXRMMSER",38,0)
 S TEXT(NFOUND)="Combat service from "_$$FMTE^XLFDT(FDATE,"5Z")_" to "_$$FMTE^XLFDT(TDATE,"5Z")_"; location: "_DATA(NFOUND,"LOCATION")
"RTN","PXRMMSER",39,0)
 Q
"RTN","PXRMMSER",40,0)
 ;
"RTN","PXRMMSER",41,0)
 ;======================================================
"RTN","PXRMMSER",42,0)
CVELIG(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
"RTN","PXRMMSER",43,0)
 ;combat vet eligiblity data. VA-COMBAT VET ELIGIBILITY.
"RTN","PXRMMSER",44,0)
 N CV,EDATE,ELIG,RESULT
"RTN","PXRMMSER",45,0)
 ;DBIA #4156
"RTN","PXRMMSER",46,0)
 S RESULT=$$CVEDT^DGCV(DFN,$$NOW^PXRMDATE)
"RTN","PXRMMSER",47,0)
 ;RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
"RTN","PXRMMSER",48,0)
 ;      (piece 1)  1 - qualifies as a CV
"RTN","PXRMMSER",49,0)
 ;                 0 - does not qualify as a CV
"RTN","PXRMMSER",50,0)
 ;                -1 - bad DFN or date
"RTN","PXRMMSER",51,0)
 ;      (piece 3)  1 - vet was eligible on date specified (or DT)      
"RTN","PXRMMSER",52,0)
 ;                 0 - vet was not eligible on date specified (or DT)
"RTN","PXRMMSER",53,0)
 S CV=$P(RESULT,U,1),EDATE=$P(RESULT,U,2),ELIG=$P(RESULT,U,3)
"RTN","PXRMMSER",54,0)
 I 'CV S NFOUND=0 Q
"RTN","PXRMMSER",55,0)
 S NFOUND=1
"RTN","PXRMMSER",56,0)
 S TEST(NFOUND)=CV,DATE(NFOUND)=$$NOW^PXRMDATE
"RTN","PXRMMSER",57,0)
 S TEXT(NFOUND)="End date is "_$$FMTE^XLFDT(EDATE,"5Z")
"RTN","PXRMMSER",58,0)
 S DATA(NFOUND,"END DATE")=EDATE
"RTN","PXRMMSER",59,0)
 S DATA(NFOUND,"VALUE")=$S(ELIG:"ELIGIBLE",1:"EXPIRED")
"RTN","PXRMMSER",60,0)
 S DATA(NFOUND,"STATUS")=DATA(NFOUND,"VALUE")
"RTN","PXRMMSER",61,0)
 Q
"RTN","PXRMMSER",62,0)
 ;
"RTN","PXRMMSER",63,0)
 ;======================================================
"RTN","PXRMMSER",64,0)
DISCHDT(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
"RTN","PXRMMSER",65,0)
 ; This computed finding returns the service separation date.
"RTN","PXRMMSER",66,0)
 ; CF.VA-SERVICE SEPARATION DATES
"RTN","PXRMMSER",67,0)
 N IND
"RTN","PXRMMSER",68,0)
 D MSDATA(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT,1)
"RTN","PXRMMSER",69,0)
 F IND=1:1:NFOUND S DATA(IND,"VALUE")=DATE(IND)
"RTN","PXRMMSER",70,0)
 Q
"RTN","PXRMMSER",71,0)
 ;
"RTN","PXRMMSER",72,0)
 ;======================================================
"RTN","PXRMMSER",73,0)
GETSVCD(DFN) ;Get the SVC^VADPT service data.
"RTN","PXRMMSER",74,0)
 I $D(^TMP($J,"SVC",DFN)) Q
"RTN","PXRMMSER",75,0)
 N VAERR,VAROOT
"RTN","PXRMMSER",76,0)
 S VAROOT="^TMP($J,""SVC"",DFN)"
"RTN","PXRMMSER",77,0)
 D SVC^VADPT
"RTN","PXRMMSER",78,0)
 Q
"RTN","PXRMMSER",79,0)
 ;
"RTN","PXRMMSER",80,0)
 ;======================================================
"RTN","PXRMMSER",81,0)
MSDATA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT,SEPDTR) ;This computed
"RTN","PXRMMSER",82,0)
 ;finding will return service branch information.
"RTN","PXRMMSER",83,0)
 ;CF.VA-SERVICE BRANCH.
"RTN","PXRMMSER",84,0)
 ;DBIA #5354
"RTN","PXRMMSER",85,0)
 N ENTRYDTA,MSDATA,NEPS
"RTN","PXRMMSER",86,0)
 D MSDATA^DGMSE(DFN,.NEPS,.ENTRYDTA,.MSDATA)
"RTN","PXRMMSER",87,0)
 I NEPS=0 S NFOUND=0 Q
"RTN","PXRMMSER",88,0)
 N BRANCH,DISTYPE,ENTRYDT,ENTRYDTO,IND,NOW
"RTN","PXRMMSER",89,0)
 N SCOMP,SDIR,SEPDT,SEPDTC,SEPDTCO
"RTN","PXRMMSER",90,0)
 S NOW=$$NOW^PXRMDATE
"RTN","PXRMMSER",91,0)
 S SDIR=$S(NGET>0:-1,1:1)
"RTN","PXRMMSER",92,0)
 S NGET=$S(NGET<0:-NGET,1:NGET)
"RTN","PXRMMSER",93,0)
 S NFOUND=0,ENTRYDT=""
"RTN","PXRMMSER",94,0)
 F  S ENTRYDT=$O(ENTRYDTA(ENTRYDT),SDIR) Q:(ENTRYDT="")!(NFOUND=NGET)  D
"RTN","PXRMMSER",95,0)
 . S IND=ENTRYDTA(ENTRYDT)
"RTN","PXRMMSER",96,0)
 . S SEPDT=MSDATA(IND,"SEPARATION DATE")
"RTN","PXRMMSER",97,0)
 .;Check for separation date required.
"RTN","PXRMMSER",98,0)
 . I SEPDTR,SEPDT="" Q
"RTN","PXRMMSER",99,0)
 .;If there is no Separation Date use the evaluation date and time.
"RTN","PXRMMSER",100,0)
 . S SEPDTC=$S(SEPDT'="":SEPDT,1:NOW)
"RTN","PXRMMSER",101,0)
 . I $$OVERLAP^PXRMINDX(ENTRYDT,SEPDTC,BDT,EDT)'="O" Q
"RTN","PXRMMSER",102,0)
 . S NFOUND=NFOUND+1
"RTN","PXRMMSER",103,0)
 . S TEST(NFOUND)=1
"RTN","PXRMMSER",104,0)
 . S DATE(NFOUND)=MSDATA(IND,"DATE")
"RTN","PXRMMSER",105,0)
 . S BRANCH=MSDATA(IND,"BRANCH")
"RTN","PXRMMSER",106,0)
 . I BRANCH="" S BRANCH="<NO DATA>"
"RTN","PXRMMSER",107,0)
 . S DATA(NFOUND,"BRANCH")=BRANCH
"RTN","PXRMMSER",108,0)
 . S SCOMP=MSDATA(IND,"SERVICE COMPONENT")
"RTN","PXRMMSER",109,0)
 . S SCOMP=$S(SCOMP="":"<NO DATA>",1:SCOMP)
"RTN","PXRMMSER",110,0)
 . S DATA(NFOUND,"SERVICE COMPONENT")=SCOMP
"RTN","PXRMMSER",111,0)
 . S DISTYPE=MSDATA(IND,"DISCHARGE TYPE")
"RTN","PXRMMSER",112,0)
 . S DISTYPE=$S(DISTYPE="":"<NO DATA>",1:DISTYPE)
"RTN","PXRMMSER",113,0)
 . S DATA(NFOUND,"DISCHARGE TYPE")=DISTYPE
"RTN","PXRMMSER",114,0)
 . S ENTRYDTO=$$FMTE^XLFDT(ENTRYDT,"5Z")
"RTN","PXRMMSER",115,0)
 . S SEPDTO=$S(SEPDT="":"<NO DATA>",1:$$FMTE^XLFDT(SEPDT,"5Z"))
"RTN","PXRMMSER",116,0)
 . S TEXT(NFOUND)="Service from "_ENTRYDTO_" to "_SEPDTO_" in "_BRANCH_"; service component "_SCOMP_"; discharge "_DISTYPE_"."
"RTN","PXRMMSER",117,0)
 Q
"RTN","PXRMMSER",118,0)
 ;
"RTN","PXRMMSER",119,0)
 ;======================================================
"RTN","PXRMMSER",120,0)
OEF(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed
"RTN","PXRMMSER",121,0)
 ;finding will return OEF service information in the date range
"RTN","PXRMMSER",122,0)
 ;specified by Beginning Date/Time and Ending Date/Time.
"RTN","PXRMMSER",123,0)
 ;VA-OEF SERVICE.
"RTN","PXRMMSER",124,0)
 N FDATE,IND,SDIR,TDATE,TEMP
"RTN","PXRMMSER",125,0)
 S NFOUND=0
"RTN","PXRMMSER",126,0)
 S SDIR=$S(NGET<0:1,1:-1)
"RTN","PXRMMSER",127,0)
 S NGET=$S(NGET<0:-NGET,1:NGET)
"RTN","PXRMMSER",128,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",129,0)
 I ^TMP($J,"SVC",DFN,12)=0 Q
"RTN","PXRMMSER",130,0)
 S IND=""
"RTN","PXRMMSER",131,0)
 F  S IND=$O(^TMP($J,"SVC",DFN,12,IND)) Q:IND=""  D
"RTN","PXRMMSER",132,0)
 . S FDATE=$P(^TMP($J,"SVC",DFN,12,IND,2),U,1)
"RTN","PXRMMSER",133,0)
 . I FDATE="" Q
"RTN","PXRMMSER",134,0)
 . S TDATE=$P(^TMP($J,"SVC",DFN,12,IND,3),U,1)
"RTN","PXRMMSER",135,0)
 . I $$OVERLAP^PXRMINDX(FDATE,TDATE,BDT,EDT)'="O" Q
"RTN","PXRMMSER",136,0)
 . S TEMP(FDATE,"TEST")=1
"RTN","PXRMMSER",137,0)
 . S TEMP(FDATE,"DATA","LOCATION")=$P(^TMP($J,"SVC",DFN,12,IND,1),U,2)
"RTN","PXRMMSER",138,0)
 . S TEMP(FDATE,"TEXT")="OEF service from "_$$FMTE^XLFDT(FDATE,"5Z")_" to "_$$FMTE^XLFDT(TDATE,"5Z")_"; location: "_TEMP(FDATE,"DATA","LOCATION")
"RTN","PXRMMSER",139,0)
 S FDATE=""
"RTN","PXRMMSER",140,0)
 F  S FDATE=$O(TEMP(FDATE),SDIR) Q:(FDATE="")!(NFOUND=NGET)  D
"RTN","PXRMMSER",141,0)
 . S NFOUND=NFOUND+1
"RTN","PXRMMSER",142,0)
 . S TEST(NFOUND)=TEMP(FDATE,"TEST"),DATE(NFOUND)=FDATE
"RTN","PXRMMSER",143,0)
 . S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"LOCATION"))=TEMP(FDATE,"DATA","LOCATION")
"RTN","PXRMMSER",144,0)
 . S TEXT(NFOUND)=TEMP(FDATE,"TEXT")
"RTN","PXRMMSER",145,0)
 Q
"RTN","PXRMMSER",146,0)
 ;
"RTN","PXRMMSER",147,0)
 ;======================================================
"RTN","PXRMMSER",148,0)
OEIF(NGET,BDT,EDT,TGLIST,PARAM) ;List computed finding to build patient
"RTN","PXRMMSER",149,0)
 ;list based on OEF/OIF/UNK data.
"RTN","PXRMMSER",150,0)
 ;VA-OEF/OIF
"RTN","PXRMMSER",151,0)
 N DA,DATE,DFN,FDATE,LOC,LOCATION,NFOUND,TDATE
"RTN","PXRMMSER",152,0)
 K ^TMP($J,TGLIST)
"RTN","PXRMMSER",153,0)
 ;DBIA #5354
"RTN","PXRMMSER",154,0)
 D OEIF^DGMSE(BDT,EDT,"OEIF")
"RTN","PXRMMSER",155,0)
 S DATE=$$NOW^PXRMDATE
"RTN","PXRMMSER",156,0)
 S NGET=$S(NGET<0:-NGET,1:NGET)
"RTN","PXRMMSER",157,0)
 S LOCATION=$G(PARAM)
"RTN","PXRMMSER",158,0)
 I LOCATION="" S LOCATION="ANY"
"RTN","PXRMMSER",159,0)
 S DFN=""
"RTN","PXRMMSER",160,0)
 F  S DFN=$O(^TMP($J,"OEIF",DFN)) Q:DFN=""  D
"RTN","PXRMMSER",161,0)
 . S FDATE=""
"RTN","PXRMMSER",162,0)
 . F  S FDATE=$O(^TMP($J,"OEIF",DFN,FDATE)) Q:FDATE=""  D
"RTN","PXRMMSER",163,0)
 .. S TDATE=""
"RTN","PXRMMSER",164,0)
 .. F  S TDATE=$O(^TMP($J,"OEIF",DFN,FDATE,TDATE)) Q:TDATE=""  D
"RTN","PXRMMSER",165,0)
 ... S LOC=""
"RTN","PXRMMSER",166,0)
 ... F  S LOC=$O(^TMP($J,"OEIF",DFN,FDATE,TDATE,LOC)) Q:LOC=""  D
"RTN","PXRMMSER",167,0)
 .... S NFOUND=+$O(^TMP($J,TGLIST,DFN,""))
"RTN","PXRMMSER",168,0)
 .... I NFOUND=NGET Q
"RTN","PXRMMSER",169,0)
 .... I (LOCATION["ANY")!(LOCATION[LOC) D
"RTN","PXRMMSER",170,0)
 ..... S DA=""
"RTN","PXRMMSER",171,0)
 ..... F  S DA=$O(^TMP($J,"OEIF",DFN,FDATE,TDATE,LOC,DA)) Q:DA=""  D
"RTN","PXRMMSER",172,0)
 ...... S NFOUND=NFOUND+1
"RTN","PXRMMSER",173,0)
 ...... S ^TMP($J,TGLIST,DFN,NFOUND)=DFN_";"_DA_U_DATE_U_2_U_LOC_U_TDATE_";"_FDATE
"RTN","PXRMMSER",174,0)
 K ^TMP($J,"OEIF")
"RTN","PXRMMSER",175,0)
 Q
"RTN","PXRMMSER",176,0)
 ;
"RTN","PXRMMSER",177,0)
 ;======================================================
"RTN","PXRMMSER",178,0)
OIF(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed
"RTN","PXRMMSER",179,0)
 ;finding will return OIF service information in the date range
"RTN","PXRMMSER",180,0)
 ;specified by Beginning Date/Time and Ending Date/Time.
"RTN","PXRMMSER",181,0)
 ;VA-OIF SERVICE.
"RTN","PXRMMSER",182,0)
 N FDATE,IND,SDIR,TDATE,TEMP
"RTN","PXRMMSER",183,0)
 S NFOUND=0
"RTN","PXRMMSER",184,0)
 S SDIR=$S(NGET<0:1,1:-1)
"RTN","PXRMMSER",185,0)
 S NGET=$S(NGET<0:-NGET,1:NGET)
"RTN","PXRMMSER",186,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",187,0)
 I ^TMP($J,"SVC",DFN,11)=0 Q
"RTN","PXRMMSER",188,0)
 S IND=""
"RTN","PXRMMSER",189,0)
 F  S IND=$O(^TMP($J,"SVC",DFN,11,IND)) Q:IND=""  D
"RTN","PXRMMSER",190,0)
 . S FDATE=$P(^TMP($J,"SVC",DFN,11,IND,2),U,1)
"RTN","PXRMMSER",191,0)
 . I FDATE="" Q
"RTN","PXRMMSER",192,0)
 . S TDATE=$P(^TMP($J,"SVC",DFN,11,IND,3),U,1)
"RTN","PXRMMSER",193,0)
 . I $$OVERLAP^PXRMINDX(FDATE,TDATE,BDT,EDT)'="O" Q
"RTN","PXRMMSER",194,0)
 . S TEMP(FDATE,"TEST")=1
"RTN","PXRMMSER",195,0)
 . S TEMP(FDATE,"DATA","LOCATION")=$P(^TMP($J,"SVC",DFN,11,IND,1),U,2)
"RTN","PXRMMSER",196,0)
 . S TEMP(FDATE,"TEXT")="OIFF service from "_$$FMTE^XLFDT(FDATE,"5Z")_" to "_$$FMTE^XLFDT(TDATE,"5Z")_"; location: "_TEMP(FDATE,"DATA","LOCATION")
"RTN","PXRMMSER",197,0)
 S FDATE=""
"RTN","PXRMMSER",198,0)
 F  S FDATE=$O(TEMP(FDATE),SDIR) Q:(FDATE="")!(NFOUND=NGET)  D
"RTN","PXRMMSER",199,0)
 . S NFOUND=NFOUND+1
"RTN","PXRMMSER",200,0)
 . S TEST(NFOUND)=TEMP(FDATE,"TEST"),DATE(NFOUND)=FDATE
"RTN","PXRMMSER",201,0)
 . S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"LOCATION"))=TEMP(FDATE,"DATA","LOCATION")
"RTN","PXRMMSER",202,0)
 . S TEXT(NFOUND)=TEMP(FDATE,"TEXT")
"RTN","PXRMMSER",203,0)
 Q
"RTN","PXRMMSER",204,0)
 ;
"RTN","PXRMMSER",205,0)
 ;======================================================
"RTN","PXRMMSER",206,0)
PHEART(DFN,TEST,DATE,VALUE,TEXT) ;Single value computed finding for
"RTN","PXRMMSER",207,0)
 ;purple heart data. VA-PURPLE HEART.
"RTN","PXRMMSER",208,0)
 N CV,EDATE,ELIG,RESULT
"RTN","PXRMMSER",209,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",210,0)
 S TEST=^TMP($J,"SVC",DFN,9)
"RTN","PXRMMSER",211,0)
 I 'TEST Q
"RTN","PXRMMSER",212,0)
 S DATE=$$NOW^PXRMDATE
"RTN","PXRMMSER",213,0)
 S VALUE=""
"RTN","PXRMMSER",214,0)
 S TEXT="Patient is a Purple Heart recipient."
"RTN","PXRMMSER",215,0)
 Q
"RTN","PXRMMSER",216,0)
 ;
"RTN","PXRMMSER",217,0)
 ;======================================================
"RTN","PXRMMSER",218,0)
POW(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed
"RTN","PXRMMSER",219,0)
 ;finding will be true if the patient was a POW in the date range
"RTN","PXRMMSER",220,0)
 ;specified by Beginning Date/Time and Ending Date/Time.
"RTN","PXRMMSER",221,0)
 ;VA-POW.
"RTN","PXRMMSER",222,0)
 N FDATE,TDATE
"RTN","PXRMMSER",223,0)
 S NFOUND=0
"RTN","PXRMMSER",224,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",225,0)
 S TEST=^TMP($J,"SVC",DFN,4)
"RTN","PXRMMSER",226,0)
 I 'TEST Q
"RTN","PXRMMSER",227,0)
 S FDATE=$P(^TMP($J,"SVC",DFN,4,1),U,1)
"RTN","PXRMMSER",228,0)
 S TDATE=$P(^TMP($J,"SVC",DFN,4,2),U,1)
"RTN","PXRMMSER",229,0)
 I $$OVERLAP^PXRMINDX(FDATE,TDATE,BDT,EDT)'="O" S TEST=0 Q
"RTN","PXRMMSER",230,0)
 S NFOUND=1
"RTN","PXRMMSER",231,0)
 S TEST(NFOUND)=1,DATE(NFOUND)=FDATE
"RTN","PXRMMSER",232,0)
 S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"LOCATION"))=$P(^TMP($J,"SVC",DFN,4,3),U,2)
"RTN","PXRMMSER",233,0)
 S TEXT(NFOUND)="Patient was a POW from "_$$FMTE^XLFDT(FDATE,"5Z")_" to "_$$FMTE^XLFDT(TDATE,"5Z")_"; location: "_DATA(NFOUND,"LOCATION")
"RTN","PXRMMSER",234,0)
 Q
"RTN","PXRMMSER",235,0)
 ;
"RTN","PXRMMSER",236,0)
 ;======================================================
"RTN","PXRMMSER",237,0)
RADEXP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;;This computed
"RTN","PXRMMSER",238,0)
 ;finding will be true if the radiation exposure registration
"RTN","PXRMMSER",239,0)
 ;date is in the date range specified by Beginning Date/Time
"RTN","PXRMMSER",240,0)
 ;and Ending Date/Time. DVA-RADIATION EXPOSURE.
"RTN","PXRMMSER",241,0)
 N RDATE
"RTN","PXRMMSER",242,0)
 S NFOUND=0
"RTN","PXRMMSER",243,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",244,0)
 S TEST=^TMP($J,"SVC",DFN,3)
"RTN","PXRMMSER",245,0)
 I 'TEST Q
"RTN","PXRMMSER",246,0)
 S RDATE=$P(^TMP($J,"SVC",DFN,3,1),U,1)
"RTN","PXRMMSER",247,0)
 I (RDATE<BDT)!(RDATE>EDT) S TEST=0 Q
"RTN","PXRMMSER",248,0)
 S NFOUND=1
"RTN","PXRMMSER",249,0)
 S TEST(NFOUND)=1,DATE(NFOUND)=RDATE
"RTN","PXRMMSER",250,0)
 S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"EXPOSURE METHOD"))=$P(^TMP($J,"SVC",DFN,3,2),U,2)
"RTN","PXRMMSER",251,0)
 S TEXT(NFOUND)="Radiation exposure registration date: "_$$FMTE^XLFDT(RDATE,"5Z")_"; exposure method: "_DATA(NFOUND,"EXPOSURE METHOD")
"RTN","PXRMMSER",252,0)
 Q
"RTN","PXRMMSER",253,0)
 ;
"RTN","PXRMMSER",254,0)
 ;======================================================
"RTN","PXRMMSER",255,0)
SBRANCH(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed
"RTN","PXRMMSER",256,0)
 ;finding will return service branch information.
"RTN","PXRMMSER",257,0)
 ;CF.VA-SERVICE BRANCH.
"RTN","PXRMMSER",258,0)
 N IND
"RTN","PXRMMSER",259,0)
 D MSDATA(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT,0)
"RTN","PXRMMSER",260,0)
 F IND=1:1:NFOUND S DATA(IND,"VALUE")=DATA(IND,"BRANCH")
"RTN","PXRMMSER",261,0)
 Q
"RTN","PXRMMSER",262,0)
 ;
"RTN","PXRMMSER",263,0)
 ;======================================================
"RTN","PXRMMSER",264,0)
UNKOEIF(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed
"RTN","PXRMMSER",265,0)
 ;finding will return unknown OEF/OIF service information in the date
"RTN","PXRMMSER",266,0)
 ;range specified by Beginning Date/Time and Ending Date/Time.
"RTN","PXRMMSER",267,0)
 ;VA-UNKNOWN OEF/OIF SERVICE.
"RTN","PXRMMSER",268,0)
 N FDATE,IND,SDIR,TDATE,TEMP
"RTN","PXRMMSER",269,0)
 S NFOUND=0
"RTN","PXRMMSER",270,0)
 S SDIR=$S(NGET<0:1,1:-1)
"RTN","PXRMMSER",271,0)
 S NGET=$S(NGET<0:-NGET,1:NGET)
"RTN","PXRMMSER",272,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",273,0)
 I ^TMP($J,"SVC",DFN,13)=0 Q
"RTN","PXRMMSER",274,0)
 S IND=""
"RTN","PXRMMSER",275,0)
 F  S IND=$O(^TMP($J,"SVC",DFN,13,IND)) Q:IND=""  D
"RTN","PXRMMSER",276,0)
 . S FDATE=$P(^TMP($J,"SVC",DFN,13,IND,2),U,1)
"RTN","PXRMMSER",277,0)
 . I FDATE="" Q
"RTN","PXRMMSER",278,0)
 . S TDATE=$P(^TMP($J,"SVC",DFN,13,IND,3),U,1)
"RTN","PXRMMSER",279,0)
 . I $$OVERLAP^PXRMINDX(FDATE,TDATE,BDT,EDT)'="O" Q
"RTN","PXRMMSER",280,0)
 . S TEMP(FDATE,"TEST")=1
"RTN","PXRMMSER",281,0)
 . S TEMP(FDATE,"DATA","LOCATION")=$P(^TMP($J,"SVC",DFN,13,IND,1),U,2)
"RTN","PXRMMSER",282,0)
 . S TEMP(FDATE,"TEXT")="OEF/OIF service from "_$$FMTE^XLFDT(FDATE,"5Z")_" to "_$$FMTE^XLFDT(TDATE,"5Z")_"; location: "_TEMP(FDATE,"DATA","LOCATION")
"RTN","PXRMMSER",283,0)
 S FDATE=""
"RTN","PXRMMSER",284,0)
 F  S FDATE=$O(TEMP(FDATE),SDIR) Q:(FDATE="")!(NFOUND=NGET)  D
"RTN","PXRMMSER",285,0)
 . S NFOUND=NFOUND+1
"RTN","PXRMMSER",286,0)
 . S TEST(NFOUND)=TEMP(FDATE,"TEST"),DATE(NFOUND)=FDATE
"RTN","PXRMMSER",287,0)
 . S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"LOCATION"))=TEMP(FDATE,"DATA","LOCATION")
"RTN","PXRMMSER",288,0)
 . S TEXT(NFOUND)=TEMP(FDATE,"TEXT")
"RTN","PXRMMSER",289,0)
 Q
"RTN","PXRMMSER",290,0)
 ;
"RTN","PXRMMSER",291,0)
 ;======================================================
"RTN","PXRMMSER",292,0)
VETERAN(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking if a
"RTN","PXRMMSER",293,0)
 ;patient is a veteran. VA-VETERAN.
"RTN","PXRMMSER",294,0)
 N VAEL
"RTN","PXRMMSER",295,0)
 S DATE=$$NOW^PXRMDATE
"RTN","PXRMMSER",296,0)
 D ELIG^VADPT
"RTN","PXRMMSER",297,0)
 S TEST=VAEL(4)
"RTN","PXRMMSER",298,0)
 S VALUE=""
"RTN","PXRMMSER",299,0)
 D KVA^VADPT
"RTN","PXRMMSER",300,0)
 Q
"RTN","PXRMMSER",301,0)
 ;
"RTN","PXRMMSER",302,0)
 ;======================================================
"RTN","PXRMMSER",303,0)
VIET(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;This computed will be
"RTN","PXRMMSER",304,0)
 ;true if Vietnam service in the date range specified by BDT and EDT
"RTN","PXRMMSER",305,0)
 ;is found. Note even though it is a multi structure it can only
"RTN","PXRMMSER",306,0)
 ;return one occurrence. VA-VIETNAM SERVICE.
"RTN","PXRMMSER",307,0)
 N FDATE,TDATE
"RTN","PXRMMSER",308,0)
 S NFOUND=0
"RTN","PXRMMSER",309,0)
 D GETSVCD(DFN)
"RTN","PXRMMSER",310,0)
 S TEST=^TMP($J,"SVC",DFN,1)
"RTN","PXRMMSER",311,0)
 I 'TEST Q
"RTN","PXRMMSER",312,0)
 S FDATE=$P(^TMP($J,"SVC",DFN,1,1),U,1)
"RTN","PXRMMSER",313,0)
 S TDATE=$P(^TMP($J,"SVC",DFN,1,2),U,1)
"RTN","PXRMMSER",314,0)
 I $$OVERLAP^PXRMINDX(FDATE,TDATE,BDT,EDT)'="O" S TEST=0 Q
"RTN","PXRMMSER",315,0)
 S NFOUND=1
"RTN","PXRMMSER",316,0)
 S TEST(NFOUND)=1,DATE(NFOUND)=FDATE
"RTN","PXRMMSER",317,0)
 S TEXT(NFOUND)="Vietnam service from "_$$FMTE^XLFDT(FDATE,"5Z")_" to "_$$FMTE^XLFDT(TDATE,"5Z")
"RTN","PXRMMSER",318,0)
 Q
"RTN","PXRMMSER",319,0)
 ;
"RTN","PXRMP21I")
0^2^B4139737
"RTN","PXRMP21I",1,0)
PXRMP21I ;SLC/PKR,AJB - Inits for PXRM*2.0*21;12/14/2011
"RTN","PXRMP21I",2,0)
 ;;2.0;CLINICAL REMINDERS;**21**;Feb 04, 2005;Build 152
"RTN","PXRMP21I",3,0)
 Q
"RTN","PXRMP21I",4,0)
 ;
"RTN","PXRMP21I",5,0)
CFINC(Y) ;List of computed findings to include in the build.
"RTN","PXRMP21I",6,0)
 N CFLIST,CFNAME
"RTN","PXRMP21I",7,0)
 S CFLIST("VA-OEF/OIF SERVICE (LIST)")=""
"RTN","PXRMP21I",8,0)
 S CFLIST("VA-SERVICE BRANCH")=""
"RTN","PXRMP21I",9,0)
 S CFLIST("VA-SERVICE SEPARATION DATES")=""
"RTN","PXRMP21I",10,0)
 S CFNAME=$P($G(^PXRMD(811.4,Y,0)),U)
"RTN","PXRMP21I",11,0)
 Q $S($D(CFLIST(CFNAME)):1,1:0)
"RTN","PXRMP21I",12,0)
 ;
"RTN","PXRMP21I",13,0)
PRE ;Pre-init
"RTN","PXRMP21I",14,0)
 ;Disable options and protocols
"RTN","PXRMP21I",15,0)
 D OPTION^PXRMUTIL("DISABLE")
"RTN","PXRMP21I",16,0)
 D PROTOCOL^PXRMUTIL("DISABLE")
"RTN","PXRMP21I",17,0)
 I $D(^PXRMD(811.4,"B","VA-LAST SERVICE SEPARATION DATE")) D
"RTN","PXRMP21I",18,0)
 . N PXRMINST
"RTN","PXRMP21I",19,0)
 . S PXRMINST=1
"RTN","PXRMP21I",20,0)
 . D BMES^XPDUTL("Renaming CF VA-LAST SERVICE SEPARATION DATE to VA-SERVICE SEPARATION DATES")
"RTN","PXRMP21I",21,0)
 . D RENAME^PXRMUTIL(811.4,"VA-LAST SERVICE SEPARATION DATE","VA-SERVICE SEPARATION DATES")
"RTN","PXRMP21I",22,0)
 Q
"RTN","PXRMP21I",23,0)
 ;
"RTN","PXRMP21I",24,0)
POST ;Post-init
"RTN","PXRMP21I",25,0)
 ;Enable options and protocols
"RTN","PXRMP21I",26,0)
 D OPTION^PXRMUTIL("ENABLE")
"RTN","PXRMP21I",27,0)
 D PROTOCOL^PXRMUTIL("ENABLE")
"RTN","PXRMP21I",28,0)
 D SETPVER^PXRMUTIL("2.0P21")
"RTN","PXRMP21I",29,0)
 D SENDIM
"RTN","PXRMP21I",30,0)
 Q
"RTN","PXRMP21I",31,0)
 ;
"RTN","PXRMP21I",32,0)
SENDIM ;Send install message.
"RTN","PXRMP21I",33,0)
 N FROM,NODE,PARAM,SYSTEM,SUBJECT,TO,VALUE
"RTN","PXRMP21I",34,0)
 S NODE="PXRM*2.0*21"
"RTN","PXRMP21I",35,0)
 K ^TMP(NODE,$J)
"RTN","PXRMP21I",36,0)
 ;DBIA #1131 for ^XMB("NETNAME")
"RTN","PXRMP21I",37,0)
 S FROM="PXRM*2.0*21 Install@"_^XMB("NETNAME")
"RTN","PXRMP21I",38,0)
 ;DBIA #2541
"RTN","PXRMP21I",39,0)
 S SYSTEM=$$KSP^XUPARAM("WHERE")
"RTN","PXRMP21I",40,0)
 I $$PROD^XUPROD(1) S TO("G.CLINICAL REMINDERS SUPPORT@FORUM.VA.GOV")=""
"RTN","PXRMP21I",41,0)
 E  D
"RTN","PXRMP21I",42,0)
 . N MGIEN,MGROUP
"RTN","PXRMP21I",43,0)
 . S MGIEN=$G(^PXRM(800,1,"MGFE"))
"RTN","PXRMP21I",44,0)
 . S MGROUP=$S(MGIEN'="":"G."_$$GET1^DIQ(3.8,MGIEN,.01),1:DUZ)
"RTN","PXRMP21I",45,0)
 . S TO(MGROUP)=""
"RTN","PXRMP21I",46,0)
 S SUBJECT="Install of PXRM*2.0*21"
"RTN","PXRMP21I",47,0)
 S ^TMP(NODE,$J,1,0)="PXRM*2.0*21 has been installed."
"RTN","PXRMP21I",48,0)
 S ^TMP(NODE,$J,2,0)="System is "_SYSTEM
"RTN","PXRMP21I",49,0)
 D SEND^PXRMMSG(NODE,SUBJECT,.TO,FROM)
"RTN","PXRMP21I",50,0)
 Q
"VER")
8.0^22.0
"^DD",811.4,811.4,0)
FIELD^^5^10
"^DD",811.4,811.4,0,"DDA")
N
"^DD",811.4,811.4,0,"DT")
3110614
"^DD",811.4,811.4,0,"ID",100)
W:$D(^(100)) "   ",@("$P($P($C(59)_$S($D(^DD(811.4,100,0)):$P(^(0),U,3),1:0)_$E("_DIC_"Y,0),0),$C(59)_$P(^(100),U,1)_"":"",2),$C(59),1)")
"^DD",811.4,811.4,0,"NM","REMINDER COMPUTED FINDINGS")

"^DD",811.4,811.4,0,"PT",810.31,.04)

"^DD",811.4,811.4,0,"PT",810.32,.01)

"^DD",811.4,811.4,0,"PT",811.52,.01)

"^DD",811.4,811.4,0,"PT",811.902,.01)

"^DD",811.4,811.4,0,"VRPK")
PXRM
"^DD",811.4,811.4,.01,0)
NAME^RFX^^0;1^K:$L(X)>64!($L(X)<3)!'(X'?1P.E)!('$$VNAME^PXRMINTR(.X)) X
"^DD",811.4,811.4,.01,1,0)
^.1^^0
"^DD",811.4,811.4,.01,3)
Answer must be 3-64 characters in length.
"^DD",811.4,811.4,.01,21,0)
^.001^2^2^3050117^^^^
"^DD",811.4,811.4,.01,21,1,0)
This is the name of the computed finding and is the name the User will
"^DD",811.4,811.4,.01,21,2,0)
use when adding a computed finding to a reminder definition or a term.
"^DD",811.4,811.4,.01,"DT")
3090529
"^DD",811.4,811.4,.02,0)
ROUTINE^F^^0;2^K:$L(X)>8!($L(X)<3) X
"^DD",811.4,811.4,.02,3)
Enter the M routine name.
"^DD",811.4,811.4,.02,8.5)
@
"^DD",811.4,811.4,.02,9)
@
"^DD",811.4,811.4,.02,21,0)
^.001^3^3^3050117^^^^
"^DD",811.4,811.4,.02,21,1,0)
This is the name of an M routine that contains the code for the
"^DD",811.4,811.4,.02,21,2,0)
computed finding. The entry point to use is specified in the ENTRY
"^DD",811.4,811.4,.02,21,3,0)
POINT field.
"^DD",811.4,811.4,.02,"DT")
2990526
"^DD",811.4,811.4,.03,0)
ENTRY POINT^F^^0;3^K:$L(X)>8!($L(X)<2) X
"^DD",811.4,811.4,.03,3)
Enter the entry point, must be 2-8 characters in length.
"^DD",811.4,811.4,.03,8.5)
@
"^DD",811.4,811.4,.03,9)
@
"^DD",811.4,811.4,.03,21,0)
^.001^2^2^3050117^^^^
"^DD",811.4,811.4,.03,21,1,0)
This is the entry point in the routine specified in the ROUTINE
"^DD",811.4,811.4,.03,21,2,0)
field.
"^DD",811.4,811.4,.03,"DT")
2990527
"^DD",811.4,811.4,.04,0)
PRINT NAME^F^^0;4^K:$L(X)>64!($L(X)<1) X
"^DD",811.4,811.4,.04,3)
Answer must be 1-64 characters in length.
"^DD",811.4,811.4,.04,21,0)
^.001^2^2^3100820^^^^
"^DD",811.4,811.4,.04,21,1,0)
The PRINT NAME will be displayed in the Clinical Maintenance output for
"^DD",811.4,811.4,.04,21,2,0)
computed findings.
"^DD",811.4,811.4,.04,"DT")
3100820
"^DD",811.4,811.4,1,0)
DESCRIPTION^811.41^^1;0
"^DD",811.4,811.4,1,21,0)
^.001^3^3^3110624^^^^
"^DD",811.4,811.4,1,21,1,0)
This is the description of the computed finding. It should explain its
"^DD",811.4,811.4,1,21,2,0)
purpose and how it is to be used including what data is returned for
"^DD",811.4,811.4,1,21,3,0)
use in a Condition.
"^DD",811.4,811.4,5,0)
TYPE^S^M:MULTIPLE;L:LIST;S:SINGLE;^0;5^Q
"^DD",811.4,811.4,5,21,0)
^^4^4^3050117^
"^DD",811.4,811.4,5,21,1,0)
This is the type of computed finding; the possible values are "S" for
"^DD",811.4,811.4,5,21,2,0)
single, "M" for multiple, and "L" for list. The default value is "S".
"^DD",811.4,811.4,5,21,3,0)
For a detailed explanation of the computed finding types see the
"^DD",811.4,811.4,5,21,4,0)
Clinical Reminder Manager manual.
"^DD",811.4,811.4,5,"DT")
3030129
"^DD",811.4,811.4,100,0)
CLASS^RSX^N:NATIONAL;V:VISN;L:LOCAL;^100;1^K:'$$VCLASS^PXRMINTR(X) X
"^DD",811.4,811.4,100,3)
Enter the class.
"^DD",811.4,811.4,100,21,0)
^.001^4^4^3050117^^^^
"^DD",811.4,811.4,100,21,1,0)
This is the class of computed finding. Possible values are "N" for
"^DD",811.4,811.4,100,21,2,0)
national, "V" for VISN, and "L" for local. National computed findings
"^DD",811.4,811.4,100,21,3,0)
will be  prefixed with VA- and cannot be edited. Local or VISN entry
"^DD",811.4,811.4,100,21,4,0)
names cannot  start with VA-.
"^DD",811.4,811.4,100,"DT")
3010518
"^DD",811.4,811.4,101,0)
SPONSOR^P811.6^PXRMD(811.6,^100;2^Q
"^DD",811.4,811.4,101,3)
Enter the sponsor.
"^DD",811.4,811.4,101,21,0)
^.001^1^1^3050117^^
"^DD",811.4,811.4,101,21,1,0)
This is the organization or group that sponsors this computed finding.
"^DD",811.4,811.4,101,"DT")
3010419
"^DD",811.4,811.4,102,0)
REVIEW DATE^D^^100;3^S %DT="E" D ^%DT S X=Y K:Y<1 X
"^DD",811.4,811.4,102,3)
Enter the review date.
"^DD",811.4,811.4,102,21,0)
^.001^4^4^3050117^^
"^DD",811.4,811.4,102,21,1,0)
The REVIEW DATE is used to determine when the computed finding should
"^DD",811.4,811.4,102,21,2,0)
be reviewed to verify that it is current with the latest standards and
"^DD",811.4,811.4,102,21,3,0)
guidelines. You can find all computed findings whose review date has
"^DD",811.4,811.4,102,21,4,0)
passed using the Reminder Review Date report.
"^DD",811.4,811.4,102,"DT")
3010419
"^DD",811.4,811.4,110,0)
EDIT HISTORY^811.42D^^110;0
"^DD",811.4,811.4,110,21,0)
^.001^2^2^3050117^^^^
"^DD",811.4,811.4,110,21,1,0)
This multiple is used to record a history of changes made to the
"^DD",811.4,811.4,110,21,2,0)
computed finding.
"^DD",811.4,811.41,0)
DESCRIPTION SUB-FIELD^^.01^1
"^DD",811.4,811.41,0,"DT")
3000405
"^DD",811.4,811.41,0,"NM","DESCRIPTION")

"^DD",811.4,811.41,0,"UP")
811.4
"^DD",811.4,811.41,.01,0)
DESCRIPTION^W^^0;1^Q
"^DD",811.4,811.41,.01,3)
Enter a description for this computed finding.
"^DD",811.4,811.41,.01,"DT")
3000405
"^DD",811.4,811.42,0)
EDIT HISTORY SUB-FIELD^^2^3
"^DD",811.4,811.42,0,"DT")
3010419
"^DD",811.4,811.42,0,"IX","B",811.42,.01)

"^DD",811.4,811.42,0,"NM","EDIT HISTORY")

"^DD",811.4,811.42,0,"UP")
811.4
"^DD",811.4,811.42,.01,0)
EDIT DATE^D^^0;1^S %DT="ESTX" D ^%DT S X=Y K:Y<1 X
"^DD",811.4,811.42,.01,1,0)
^.1
"^DD",811.4,811.42,.01,1,1,0)
811.42^B
"^DD",811.4,811.42,.01,1,1,1)
S ^PXRMD(811.4,DA(1),110,"B",$E(X,1,30),DA)=""
"^DD",811.4,811.42,.01,1,1,2)
K ^PXRMD(811.4,DA(1),110,"B",$E(X,1,30),DA)
"^DD",811.4,811.42,.01,21,0)
^.001^2^2^3050117^^
"^DD",811.4,811.42,.01,21,1,0)
This is the date and time when editing was done. This field is set
"^DD",811.4,811.42,.01,21,2,0)
automatically and should not be changed by the user.
"^DD",811.4,811.42,.01,"DT")
3010419
"^DD",811.4,811.42,1,0)
EDIT BY^P200'^VA(200,^0;2^Q
"^DD",811.4,811.42,1,21,0)
^.001^2^2^3050117^^
"^DD",811.4,811.42,1,21,1,0)
This is the person who did the editing. This field is set automatically
"^DD",811.4,811.42,1,21,2,0)
and should not be changed by the user.
"^DD",811.4,811.42,1,"DT")
3010419
"^DD",811.4,811.42,2,0)
EDIT COMMENTS^811.422^^1;0
"^DD",811.4,811.42,2,21,0)
^.001^2^2^3050117^^^
"^DD",811.4,811.42,2,21,1,0)
This word-processing field can be used to record the changes made
"^DD",811.4,811.42,2,21,2,0)
during the editing session.
"^DD",811.4,811.42,2,"DT")
3010425
"^DD",811.4,811.422,0)
EDIT COMMENTS SUB-FIELD^^.01^1
"^DD",811.4,811.422,0,"DT")
3010419
"^DD",811.4,811.422,0,"NM","EDIT COMMENTS")

"^DD",811.4,811.422,0,"UP")
811.42
"^DD",811.4,811.422,.01,0)
EDIT COMMENTS^W^^0;1^Q
"^DD",811.4,811.422,.01,3)
Enter your edit comments.
"^DD",811.4,811.422,.01,"DT")
3010425
"^DIC",811.4,811.4,0)
REMINDER COMPUTED FINDINGS^811.4
"^DIC",811.4,811.4,0,"GL")
^PXRMD(811.4,
"^DIC",811.4,811.4,"%",0)
^1.005^^0
"^DIC",811.4,811.4,"%D",0)
^1.001^28^28^3110614^^^^
"^DIC",811.4,811.4,"%D",1,0)
When none of the standard Clinical Reminder finding types will work, a
"^DIC",811.4,811.4,"%D",2,0)
computed finding can be created. There are two steps in creating a
"^DIC",811.4,811.4,"%D",3,0)
computed finding. First a MUMPS routine must be written. Information
"^DIC",811.4,811.4,"%D",4,0)
about how to do this can be found in the Clinical Reminders Manager
"^DIC",811.4,811.4,"%D",5,0)
Manual. The second step is to make an entry in this file, which
"^DIC",811.4,811.4,"%D",6,0)
contains a list of reminder computed findings. There are four fields
"^DIC",811.4,811.4,"%D",7,0)
for each entry; they are:
"^DIC",811.4,811.4,"%D",8,0)
 
"^DIC",811.4,811.4,"%D",9,0)
NAME - this is the name of the computed finding. When adding a computed
"^DIC",811.4,811.4,"%D",10,0)
finding as finding to a reminder definition or term, it is done using
"^DIC",811.4,811.4,"%D",11,0)
the name. For example, you would type CF.VA-BMI to add the exported
"^DIC",811.4,811.4,"%D",12,0)
VA-BMI computed finding to your reminder definition.
"^DIC",811.4,811.4,"%D",13,0)
 
"^DIC",811.4,811.4,"%D",14,0)
ROUTINE - this is the name of the MUMPS routine.
"^DIC",811.4,811.4,"%D",15,0)
 
"^DIC",811.4,811.4,"%D",16,0)
ENTRY - this is the entry point in the MUMPS routine.
"^DIC",811.4,811.4,"%D",17,0)
 
"^DIC",811.4,811.4,"%D",18,0)
PRINT NAME - this will be displayed on the Clinical Maintenance
"^DIC",811.4,811.4,"%D",19,0)
component as the name of the computed finding. If it is blank, then NAME
"^DIC",811.4,811.4,"%D",20,0)
will be used.
"^DIC",811.4,811.4,"%D",21,0)

"^DIC",811.4,811.4,"%D",22,0)
TYPE - this is a set of codes that specifies what type of computed
"^DIC",811.4,811.4,"%D",23,0)
finding this is. "S" stands for single occurrence, "M" for multiple occurrence,
"^DIC",811.4,811.4,"%D",24,0)
and "L" for list. If it is blank, single will be assumed.
"^DIC",811.4,811.4,"%D",25,0)

"^DIC",811.4,811.4,"%D",26,0)
This file contains a combination of nationally distributed and local
"^DIC",811.4,811.4,"%D",27,0)
entries. Nationally distributed entries have their name prefixed with
"^DIC",811.4,811.4,"%D",28,0)
VA-. Local entry names cannot start with VA-.
"^DIC",811.4,"B","REMINDER COMPUTED FINDINGS",811.4)

**END**
**END**