DG_53_P941.KIDs

KIDS Distribution saved on Nov 05, 2018@15:54:30
Enrollment System Modernization Project - Build 7
**KIDS**:DG*5.3*941^IVM*2.0*164^EAS*1.0*151^

**INSTALL NAME**
DG*5.3*941
"BLD",10210,0)
DG*5.3*941^REGISTRATION^0^3181105^y
"BLD",10210,1,0)
^^2^2^3180317^^^^
"BLD",10210,1,1,0)
Please see the DG*5.3*941 patch description for detailed information 
"BLD",10210,1,2,0)
regarding this patch.
"BLD",10210,4,0)
^9.64PA^2^1
"BLD",10210,4,2,0)
2
"BLD",10210,4,2,2,0)
^9.641^2^1
"BLD",10210,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",10210,4,2,2,2,1,0)
^9.6411^.14114^38
"BLD",10210,4,2,2,2,1,.111,0)
STREET ADDRESS [LINE 1]
"BLD",10210,4,2,2,2,1,.1118,0)
STREET ADDRESS CASS IND
"BLD",10210,4,2,2,2,1,.113,0)
STREET ADDRESS [LINE 3]
"BLD",10210,4,2,2,2,1,.114,0)
CITY
"BLD",10210,4,2,2,2,1,.1151,0)
RESIDENTIAL ADDRESS [LINE 1]
"BLD",10210,4,2,2,2,1,.1152,0)
RESIDENTIAL ADDRESS [LINE 2]
"BLD",10210,4,2,2,2,1,.1153,0)
RESIDENTIAL ADDRESS [LINE 3]
"BLD",10210,4,2,2,2,1,.1154,0)
RESIDENTIAL CITY
"BLD",10210,4,2,2,2,1,.1155,0)
RESIDENTIAL STATE
"BLD",10210,4,2,2,2,1,.1156,0)
RESIDENTIAL ZIP+4
"BLD",10210,4,2,2,2,1,.1157,0)
RESIDENTIAL COUNTY
"BLD",10210,4,2,2,2,1,.11571,0)
RESIDENTIAL PROVINCE
"BLD",10210,4,2,2,2,1,.11572,0)
RESIDENTIAL POSTAL CODE
"BLD",10210,4,2,2,2,1,.11573,0)
RESIDENTIAL COUNTRY
"BLD",10210,4,2,2,2,1,.1158,0)
RESIDENTIAL ADDR CHANGE DT/TM
"BLD",10210,4,2,2,2,1,.11581,0)
RESIDENTIAL ADDR CHANGE SITE
"BLD",10210,4,2,2,2,1,.11582,0)
RESIDENTIAL ADDR CHANGE SOURCE
"BLD",10210,4,2,2,2,1,.1159,0)
RESIDENTIAL ADDR CASS IND
"BLD",10210,4,2,2,2,1,.1171,0)
PROVINCE
"BLD",10210,4,2,2,2,1,.1172,0)
POSTAL CODE
"BLD",10210,4,2,2,2,1,.119,0)
ADDRESS CHANGE SOURCE
"BLD",10210,4,2,2,2,1,.1211,0)
TEMPORARY STREET [LINE 1]
"BLD",10210,4,2,2,2,1,.12115,0)
TEMPORARY ADDR CASS IND
"BLD",10210,4,2,2,2,1,.1212,0)
TEMPORARY STREET [LINE 2]
"BLD",10210,4,2,2,2,1,.1213,0)
TEMPORARY STREET [LINE 3]
"BLD",10210,4,2,2,2,1,.1214,0)
TEMPORARY CITY
"BLD",10210,4,2,2,2,1,.1221,0)
TEMPORARY ADDRESS PROVINCE
"BLD",10210,4,2,2,2,1,.1222,0)
TEMPORARY ADDRESS POSTAL CODE
"BLD",10210,4,2,2,2,1,.1311,0)
CELLULAR NUMBER CHANGE SOURCE
"BLD",10210,4,2,2,2,1,.1322,0)
RESIDENCE NUMBER CHANGE SOURCE
"BLD",10210,4,2,2,2,1,.137,0)
EMAIL ADDRESS CHANGE SOURCE
"BLD",10210,4,2,2,2,1,.1411,0)
CONFIDENTIAL STREET [LINE 1]
"BLD",10210,4,2,2,2,1,.14114,0)
CONFIDENTIAL ADDR PROVINCE
"BLD",10210,4,2,2,2,1,.14115,0)
CONFIDENTIAL ADDR POSTAL CODE
"BLD",10210,4,2,2,2,1,.14117,0)
CONFIDENTIAL ADDR CASS IND
"BLD",10210,4,2,2,2,1,.1412,0)
CONFIDENTIAL STREET [LINE 2]
"BLD",10210,4,2,2,2,1,.1413,0)
CONFIDENTIAL STREET [LINE 3]
"BLD",10210,4,2,2,2,1,.1414,0)
CONFIDENTIAL ADDRESS CITY
"BLD",10210,4,2,222)
y^n^p^^^^n^^n
"BLD",10210,4,2,224)

"BLD",10210,4,"APDD",2,2)

"BLD",10210,4,"APDD",2,2,.111)

"BLD",10210,4,"APDD",2,2,.1118)

"BLD",10210,4,"APDD",2,2,.113)

"BLD",10210,4,"APDD",2,2,.114)

"BLD",10210,4,"APDD",2,2,.1151)

"BLD",10210,4,"APDD",2,2,.1152)

"BLD",10210,4,"APDD",2,2,.1153)

"BLD",10210,4,"APDD",2,2,.1154)

"BLD",10210,4,"APDD",2,2,.1155)

"BLD",10210,4,"APDD",2,2,.1156)

"BLD",10210,4,"APDD",2,2,.1157)

"BLD",10210,4,"APDD",2,2,.11571)

"BLD",10210,4,"APDD",2,2,.11572)

"BLD",10210,4,"APDD",2,2,.11573)

"BLD",10210,4,"APDD",2,2,.1158)

"BLD",10210,4,"APDD",2,2,.11581)

"BLD",10210,4,"APDD",2,2,.11582)

"BLD",10210,4,"APDD",2,2,.1159)

"BLD",10210,4,"APDD",2,2,.1171)

"BLD",10210,4,"APDD",2,2,.1172)

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

"BLD",10210,4,"APDD",2,2,.1211)

"BLD",10210,4,"APDD",2,2,.12115)

"BLD",10210,4,"APDD",2,2,.1212)

"BLD",10210,4,"APDD",2,2,.1213)

"BLD",10210,4,"APDD",2,2,.1214)

"BLD",10210,4,"APDD",2,2,.1221)

"BLD",10210,4,"APDD",2,2,.1222)

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

"BLD",10210,4,"APDD",2,2,.1322)

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

"BLD",10210,4,"APDD",2,2,.1411)

"BLD",10210,4,"APDD",2,2,.14114)

"BLD",10210,4,"APDD",2,2,.14115)

"BLD",10210,4,"APDD",2,2,.14117)

"BLD",10210,4,"APDD",2,2,.1412)

"BLD",10210,4,"APDD",2,2,.1413)

"BLD",10210,4,"APDD",2,2,.1414)

"BLD",10210,4,"B",2,2)

"BLD",10210,6.3)
73
"BLD",10210,"ABPKG")
n
"BLD",10210,"INID")
^n
"BLD",10210,"INIT")
POST^DG53P941
"BLD",10210,"KRN",0)
^9.67PA^779.2^20
"BLD",10210,"KRN",.4,0)
.4
"BLD",10210,"KRN",.4,"NM",0)
^9.68A^^
"BLD",10210,"KRN",.401,0)
.401
"BLD",10210,"KRN",.401,"NM",0)
^9.68A^^
"BLD",10210,"KRN",.402,0)
.402
"BLD",10210,"KRN",.402,"NM",0)
^9.68A^^0
"BLD",10210,"KRN",.403,0)
.403
"BLD",10210,"KRN",.403,"NM",0)
^9.68A^^
"BLD",10210,"KRN",.5,0)
.5
"BLD",10210,"KRN",.84,0)
.84
"BLD",10210,"KRN",3.6,0)
3.6
"BLD",10210,"KRN",3.8,0)
3.8
"BLD",10210,"KRN",9.2,0)
9.2
"BLD",10210,"KRN",9.8,0)
9.8
"BLD",10210,"KRN",9.8,"NM",0)
^9.68A^21^21
"BLD",10210,"KRN",9.8,"NM",1,0)
DGRPCADD^^0^B22281332
"BLD",10210,"KRN",9.8,"NM",2,0)
DGRPU^^0^B89347012
"BLD",10210,"KRN",9.8,"NM",3,0)
DGRPV^^0^B19689062
"BLD",10210,"KRN",9.8,"NM",4,0)
DGRPE^^0^B78319537
"BLD",10210,"KRN",9.8,"NM",5,0)
DGADDUT2^^0^B6214510
"BLD",10210,"KRN",9.8,"NM",6,0)
DGADDUTL^^0^B62220802
"BLD",10210,"KRN",9.8,"NM",7,0)
DGRPD^^0^B102167809
"BLD",10210,"KRN",9.8,"NM",8,0)
DGRP1^^0^B36820867
"BLD",10210,"KRN",9.8,"NM",9,0)
DGREGCP1^^0^B29343646
"BLD",10210,"KRN",9.8,"NM",10,0)
DGREGCP2^^0^B3251423
"BLD",10210,"KRN",9.8,"NM",11,0)
DGREGCOP^^0^B2145529
"BLD",10210,"KRN",9.8,"NM",12,0)
DGREGAED^^0^B43930519
"BLD",10210,"KRN",9.8,"NM",13,0)
DGREGTED^^0^B31206434
"BLD",10210,"KRN",9.8,"NM",14,0)
VADPT1^^0^B57593585
"BLD",10210,"KRN",9.8,"NM",15,0)
DGDDDTTM^^0^B7898513
"BLD",10210,"KRN",9.8,"NM",16,0)
VAFCQRY3^^0^B101601272
"BLD",10210,"KRN",9.8,"NM",17,0)
VAFHLZAV^^0^B4403961
"BLD",10210,"KRN",9.8,"NM",18,0)
DGRPU1^^0^B6546031
"BLD",10210,"KRN",9.8,"NM",19,0)
DGRPH^^0^B27215074
"BLD",10210,"KRN",9.8,"NM",20,0)
DGCNTRY^^0^B4455344
"BLD",10210,"KRN",9.8,"NM",21,0)
DGREGRED^^0^B55962900
"BLD",10210,"KRN",9.8,"NM","B","DGADDUT2",5)

"BLD",10210,"KRN",9.8,"NM","B","DGADDUTL",6)

"BLD",10210,"KRN",9.8,"NM","B","DGCNTRY",20)

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

"BLD",10210,"KRN",9.8,"NM","B","DGREGAED",12)

"BLD",10210,"KRN",9.8,"NM","B","DGREGCOP",11)

"BLD",10210,"KRN",9.8,"NM","B","DGREGCP1",9)

"BLD",10210,"KRN",9.8,"NM","B","DGREGCP2",10)

"BLD",10210,"KRN",9.8,"NM","B","DGREGRED",21)

"BLD",10210,"KRN",9.8,"NM","B","DGREGTED",13)

"BLD",10210,"KRN",9.8,"NM","B","DGRP1",8)

"BLD",10210,"KRN",9.8,"NM","B","DGRPCADD",1)

"BLD",10210,"KRN",9.8,"NM","B","DGRPD",7)

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

"BLD",10210,"KRN",9.8,"NM","B","DGRPH",19)

"BLD",10210,"KRN",9.8,"NM","B","DGRPU",2)

"BLD",10210,"KRN",9.8,"NM","B","DGRPU1",18)

"BLD",10210,"KRN",9.8,"NM","B","DGRPV",3)

"BLD",10210,"KRN",9.8,"NM","B","VADPT1",14)

"BLD",10210,"KRN",9.8,"NM","B","VAFCQRY3",16)

"BLD",10210,"KRN",9.8,"NM","B","VAFHLZAV",17)

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

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

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

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

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

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

"BLD",10210,"KRN","B",3.6,3.6)

"BLD",10210,"KRN","B",3.8,3.8)

"BLD",10210,"KRN","B",9.2,9.2)

"BLD",10210,"KRN","B",9.8,9.8)

"BLD",10210,"KRN","B",19,19)

"BLD",10210,"KRN","B",19.1,19.1)

"BLD",10210,"KRN","B",101,101)

"BLD",10210,"KRN","B",409.61,409.61)

"BLD",10210,"KRN","B",771,771)

"BLD",10210,"KRN","B",779.2,779.2)

"BLD",10210,"KRN","B",870,870)

"BLD",10210,"KRN","B",8989.51,8989.51)

"BLD",10210,"KRN","B",8989.52,8989.52)

"BLD",10210,"KRN","B",8994,8994)

"BLD",10210,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",10210,"QUES",0)
^9.62^^
"BLD",10210,"REQB",0)
^9.611^4^4
"BLD",10210,"REQB",1,0)
DG*5.3*935^1
"BLD",10210,"REQB",2,0)
DG*5.3*664^1
"BLD",10210,"REQB",3,0)
DG*5.3*940^1
"BLD",10210,"REQB",4,0)
DG*5.3*944^1
"BLD",10210,"REQB","B","DG*5.3*664",2)

"BLD",10210,"REQB","B","DG*5.3*935",1)

"BLD",10210,"REQB","B","DG*5.3*940",3)

"BLD",10210,"REQB","B","DG*5.3*944",4)

"FIA",2)
PATIENT
"FIA",2,0)
^DPT(
"FIA",2,0,0)
2I
"FIA",2,0,1)
y^n^p^^^^n^^n
"FIA",2,0,10)

"FIA",2,0,11)

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

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

"FIA",2,2,.1118)

"FIA",2,2,.113)

"FIA",2,2,.114)

"FIA",2,2,.1151)

"FIA",2,2,.1152)

"FIA",2,2,.1153)

"FIA",2,2,.1154)

"FIA",2,2,.1155)

"FIA",2,2,.1156)

"FIA",2,2,.1157)

"FIA",2,2,.11571)

"FIA",2,2,.11572)

"FIA",2,2,.11573)

"FIA",2,2,.1158)

"FIA",2,2,.11581)

"FIA",2,2,.11582)

"FIA",2,2,.1159)

"FIA",2,2,.1171)

"FIA",2,2,.1172)

"FIA",2,2,.119)

"FIA",2,2,.1211)

"FIA",2,2,.12115)

"FIA",2,2,.1212)

"FIA",2,2,.1213)

"FIA",2,2,.1214)

"FIA",2,2,.1221)

"FIA",2,2,.1222)

"FIA",2,2,.1311)

"FIA",2,2,.1322)

"FIA",2,2,.137)

"FIA",2,2,.1411)

"FIA",2,2,.14114)

"FIA",2,2,.14115)

"FIA",2,2,.14117)

"FIA",2,2,.1412)

"FIA",2,2,.1413)

"FIA",2,2,.1414)

"INIT")
POST^DG53P941
"IX",2,2,"ADGFMD111",0)
2^ADGFMD111^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD111",.1,0)
^^5^5^3030609
"IX",2,2,"ADGFMD111",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD111",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD111",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD111",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD111",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD111",1)
D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD111",2)
D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD111",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD111",11.1,1,0)
1^F^2^.111^^^F
"IX",2,2,"ADGFMD113",0)
2^ADGFMD113^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD113",.1,0)
^^5^5^3030609
"IX",2,2,"ADGFMD113",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD113",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD113",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD113",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD113",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD113",1)
D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD113",2)
D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD113",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD113",11.1,1,0)
1^F^2^.113^^^F
"IX",2,2,"ADGFMD114",0)
2^ADGFMD114^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD114",.1,0)
^^5^5^3030609
"IX",2,2,"ADGFMD114",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD114",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD114",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD114",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD114",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD114",1)
D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD114",2)
D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD114",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD114",11.1,1,0)
1^F^2^.114^^^F
"IX",2,2,"ADGFMD1411",0)
2^ADGFMD1411^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD1411",.1,0)
^^5^5^3030702
"IX",2,2,"ADGFMD1411",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD1411",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD1411",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD1411",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD1411",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD1411",1)
D FC^DGFCPROT(.DA,2,.1411,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1411",2)
D FC^DGFCPROT(.DA,2,.1411,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1411",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD1411",11.1,1,0)
1^F^2^.1411^^^F
"IX",2,2,"ADGFMD1412",0)
2^ADGFMD1412^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD1412",.1,0)
^^5^5^3030702
"IX",2,2,"ADGFMD1412",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD1412",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD1412",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD1412",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD1412",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD1412",1)
D FC^DGFCPROT(.DA,2,.1412,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1412",2)
D FC^DGFCPROT(.DA,2,.1412,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1412",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD1412",11.1,1,0)
1^F^2^.1412^^^F
"IX",2,2,"ADGFMD1413",0)
2^ADGFMD1413^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD1413",.1,0)
^^5^5^3030702
"IX",2,2,"ADGFMD1413",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD1413",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD1413",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD1413",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD1413",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD1413",1)
D FC^DGFCPROT(.DA,2,.1413,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1413",2)
D FC^DGFCPROT(.DA,2,.1413,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1413",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD1413",11.1,1,0)
1^F^2^.1413^^^F
"IX",2,2,"ADGFMD1414",0)
2^ADGFMD1414^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
"IX",2,2,"ADGFMD1414",.1,0)
^^5^5^3030702
"IX",2,2,"ADGFMD1414",.1,1,0)
This cross reference activates the DG FIELD MONITOR event point.
"IX",2,2,"ADGFMD1414",.1,2,0)
Applications that wish to monitor edit activity related to this field may
"IX",2,2,"ADGFMD1414",.1,3,0)
subscribe to that event point and take action as indicated by the changes
"IX",2,2,"ADGFMD1414",.1,4,0)
that occur.  Refer to the DG FIELD MONITOR protocol for a description of
"IX",2,2,"ADGFMD1414",.1,5,0)
the information available at the time of the event.
"IX",2,2,"ADGFMD1414",1)
D FC^DGFCPROT(.DA,2,.1414,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1414",2)
D FC^DGFCPROT(.DA,2,.1414,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
"IX",2,2,"ADGFMD1414",11.1,0)
^.114IA^1^1
"IX",2,2,"ADGFMD1414",11.1,1,0)
1^F^2^.1414^^^F
"IX",2,2,"ADTTM1",0)
2^ADTTM1^TEMPORARY ADDRESS Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM1",.1,0)
^^2^2^3050810
"IX",2,2,"ADTTM1",.1,1,0)
This cross-reference will update the TEMPORARY ADDRESS CHANGE DT/TM field
"IX",2,2,"ADTTM1",.1,2,0)
when the Temporary Address data changes for a patient.
"IX",2,2,"ADTTM1",1)
D TEMP^DGDDDTTM
"IX",2,2,"ADTTM1",2)
D TEMP^DGDDDTTM
"IX",2,2,"ADTTM1",11.1,0)
^.114IA^13^13
"IX",2,2,"ADTTM1",11.1,1,0)
1^F^2^.1211^^^F
"IX",2,2,"ADTTM1",11.1,2,0)
2^F^2^.1212^^^F
"IX",2,2,"ADTTM1",11.1,3,0)
3^F^2^.1213^^^F
"IX",2,2,"ADTTM1",11.1,4,0)
4^F^2^.1214^^^F
"IX",2,2,"ADTTM1",11.1,5,0)
5^F^2^.1215^^^F
"IX",2,2,"ADTTM1",11.1,6,0)
6^F^2^.1216^^^F
"IX",2,2,"ADTTM1",11.1,7,0)
7^F^2^.1217^^^F
"IX",2,2,"ADTTM1",11.1,8,0)
8^F^2^.1218^^^F
"IX",2,2,"ADTTM1",11.1,9,0)
9^F^2^.12105^^^F
"IX",2,2,"ADTTM1",11.1,10,0)
10^F^2^.12112^^^F
"IX",2,2,"ADTTM1",11.1,11,0)
11^F^2^.1221^^^F
"IX",2,2,"ADTTM1",11.1,11,3)

"IX",2,2,"ADTTM1",11.1,12,0)
12^F^2^.1222^^^F
"IX",2,2,"ADTTM1",11.1,12,3)

"IX",2,2,"ADTTM1",11.1,13,0)
13^F^2^.1223^^^F
"IX",2,2,"ADTTM1",11.1,13,3)

"IX",2,2,"ADTTM2",0)
2^ADTTM2^CONFIDENTIAL ADDRESS Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM2",.1,0)
^^2^2^3080811^^
"IX",2,2,"ADTTM2",.1,1,0)
This cross-reference will update the CONFIDENTIAL ADDR CHANGE DT/TM field
"IX",2,2,"ADTTM2",.1,2,0)
when the confidential address data changes for a patient.
"IX",2,2,"ADTTM2",1)
D CONF^DGDDDTTM
"IX",2,2,"ADTTM2",2)
D CONF^DGDDDTTM
"IX",2,2,"ADTTM2",11.1,0)
^.114IA^14^14
"IX",2,2,"ADTTM2",11.1,1,0)
1^F^2^.1411^^^F
"IX",2,2,"ADTTM2",11.1,2,0)
2^F^2^.1412^^^F
"IX",2,2,"ADTTM2",11.1,3,0)
3^F^2^.1413^^^F
"IX",2,2,"ADTTM2",11.1,4,0)
4^F^2^.1414^^^F
"IX",2,2,"ADTTM2",11.1,5,0)
5^F^2^.1415^^^F
"IX",2,2,"ADTTM2",11.1,6,0)
6^F^2^.1416^^^F
"IX",2,2,"ADTTM2",11.1,7,0)
7^F^2^.1417^^^F
"IX",2,2,"ADTTM2",11.1,8,0)
8^F^2^.1418^^^F
"IX",2,2,"ADTTM2",11.1,9,0)
9^F^2^.14105^^^F
"IX",2,2,"ADTTM2",11.1,10,0)
10^F^2^.14114^^^F
"IX",2,2,"ADTTM2",11.1,11,0)
11^F^2^.14115^^^F
"IX",2,2,"ADTTM2",11.1,12,0)
12^F^2^.14116^^^F
"IX",2,2,"ADTTM2",11.1,13,0)
13^F^2^.14111^^^F
"IX",2,2,"ADTTM2",11.1,14,0)
14^F^2^.1315^^^F
"IX",2,2,"ADTTM2",11.1,14,3)

"IX",2,2,"ADTTM8",0)
2^ADTTM8^RESIDENTIAL ADDRESS Cross-Reference^MU^^R^^I^2^^^^^A
"IX",2,2,"ADTTM8",.1,0)
^^2^2^3170731^^
"IX",2,2,"ADTTM8",.1,1,0)
This cross-reference will update the RESIDENTIAL ADDR CHANGE DT/TM field
"IX",2,2,"ADTTM8",.1,2,0)
when the Residential Address data changes for a patient.
"IX",2,2,"ADTTM8",1)
D RES^DGDDDTTM
"IX",2,2,"ADTTM8",2)
D RES^DGDDDTTM
"IX",2,2,"ADTTM8",11.1,0)
^.114IA^9^9
"IX",2,2,"ADTTM8",11.1,1,0)
1^F^2^.1151^^^F
"IX",2,2,"ADTTM8",11.1,1,3)

"IX",2,2,"ADTTM8",11.1,2,0)
2^F^2^.1152^^^F
"IX",2,2,"ADTTM8",11.1,2,3)

"IX",2,2,"ADTTM8",11.1,3,0)
3^F^2^.1153^^^F
"IX",2,2,"ADTTM8",11.1,3,3)

"IX",2,2,"ADTTM8",11.1,4,0)
4^F^2^.1154^^^F
"IX",2,2,"ADTTM8",11.1,4,3)

"IX",2,2,"ADTTM8",11.1,5,0)
5^F^2^.1155^^^F
"IX",2,2,"ADTTM8",11.1,5,3)

"IX",2,2,"ADTTM8",11.1,6,0)
6^F^2^.1156^^^F
"IX",2,2,"ADTTM8",11.1,6,3)

"IX",2,2,"ADTTM8",11.1,7,0)
7^F^2^.11571^^^F
"IX",2,2,"ADTTM8",11.1,7,3)

"IX",2,2,"ADTTM8",11.1,8,0)
8^F^2^.11572^^^F
"IX",2,2,"ADTTM8",11.1,8,3)

"IX",2,2,"ADTTM8",11.1,9,0)
9^F^2^.11573^^^F
"IX",2,2,"ADTTM8",11.1,9,3)

"IX",2,2,"AX1171",0)
2^AX1171^This cross-reference is used to notify HEC of changes^MU^^F^R^I^2^^^^^A
"IX",2,2,"AX1171",.1,0)
^^4^4^3060213^
"IX",2,2,"AX1171",.1,1,0)
This cross-reference is used to notify HEC of changes that may affect
"IX",2,2,"AX1171",.1,2,0)
enrollment.  This cross reference is needed on this field because the 
"IX",2,2,"AX1171",.1,3,0)
update to the ADDRESS CHANGE DT/TM field does NOT trigger a message to 
"IX",2,2,"AX1171",.1,4,0)
the HEC.
"IX",2,2,"AX1171",1)
D EVENT^IVMPLOG(DA)
"IX",2,2,"AX1171",2)
D EVENT^IVMPLOG(DA)
"IX",2,2,"AX1171",11.1,0)
^.114IA^1^1
"IX",2,2,"AX1171",11.1,1,0)
1^F^2^.1171^^^F
"IX",2,2,"AX1172",0)
2^AX1172^This cross-reference is used to notify HEC of changes.^MU^^F^R^I^2^^^^^A
"IX",2,2,"AX1172",.1,0)
^^3^3^3060210^
"IX",2,2,"AX1172",.1,1,0)
 This cross-reference is used to notify HEC of changes that may affect
"IX",2,2,"AX1172",.1,2,0)
enrollment.  This cross reference is necessary because the update of 
"IX",2,2,"AX1172",.1,3,0)
ADDRESS CHANGE DT/TM field does NOT trigger a message to the HEC.
"IX",2,2,"AX1172",1)
D EVENT^IVMPLOG(DA)
"IX",2,2,"AX1172",2)
D EVENT^IVMPLOG(DA)
"IX",2,2,"AX1172",11.1,0)
^.114IA^1^1
"IX",2,2,"AX1172",11.1,1,0)
1^F^2^.1172^^^F
"IX",2,2,"AXRCTNRY",0)
2^AXRCTNRY^Clear Residential Addr fields when country changes^MU^^F^R^I^2^^^^^A
"IX",2,2,"AXRCTNRY",.1,0)
^^9^9^3180215^
"IX",2,2,"AXRCTNRY",.1,1,0)
This cross reference is fired whenever the field RESIDENTIAL ADDRESS
"IX",2,2,"AXRCTNRY",.1,2,0)
COUNTRY is changed.  It will clear data in fields associated with whether 
"IX",2,2,"AXRCTNRY",.1,3,0)
the COUNTRY value is domestic or foreign.  In the case of a foreign 
"IX",2,2,"AXRCTNRY",.1,4,0)
address, this cross reference will clear the RESIDENTIAL ADDRESS STATE, 
"IX",2,2,"AXRCTNRY",.1,5,0)
RESIDENTIAL ADDRESS COUNTY and RESIDENTIAL ADDRESS ZIP+4 fields.  For a 
"IX",2,2,"AXRCTNRY",.1,6,0)
domestic residential address, this cross reference will clear the 
"IX",2,2,"AXRCTNRY",.1,7,0)
RESIDENTIAL PROVINCE and RESIDENTIAL POSTAL CODE fields.  
"IX",2,2,"AXRCTNRY",.1,8,0)
See routine ^DGCNTRY for modifying which fields are cleared by this cross
"IX",2,2,"AXRCTNRY",.1,9,0)
reference.
"IX",2,2,"AXRCTNRY",1)
D EN^DGCNTRY(2,"RESI",.11573)
"IX",2,2,"AXRCTNRY",2)
Q
"IX",2,2,"AXRCTNRY",11.1,0)
^.114IA^1^1
"IX",2,2,"AXRCTNRY",11.1,1,0)
1^F^2^.11573^^^F
"IX",2,2,"AXRCTNRY",11.1,1,3)

"MBREQ")
0
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
941^3181105^101100
"PKG",47,22,1,"PAH",1,1,0)
^^2^2^3181105
"PKG",47,22,1,"PAH",1,1,1,0)
Please see the DG*5.3*941 patch description for detailed information 
"PKG",47,22,1,"PAH",1,1,2,0)
regarding this patch.
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
YES
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
22
"RTN","DG53P941")
0^^B4792773
"RTN","DG53P941",1,0)
DG53P941 ;ALB/DJS - DG*5.3*941 POST INSTALL ;10/30/17  9:18am
"RTN","DG53P941",2,0)
 ;;5.3;Registration;**941**;Aug 13, 1993;Build 73
"RTN","DG53P941",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","DG53P941",4,0)
 ;
"RTN","DG53P941",5,0)
 ; DG*5.3*941 Post Install routine to correct Veteran Plan - VC Unusual and Excessive Burden
"RTN","DG53P941",6,0)
 ;  Integration Agreements:
"RTN","DG53P941",7,0)
 ;        10141 : BMES^XPDUTL
"RTN","DG53P941",8,0)
 ;              : MES^XPDUTL
"RTN","DG53P941",9,0)
 ;        2053  : FILE^DIE
"RTN","DG53P941",10,0)
 ;        2051  : FIND1^DIC
"RTN","DG53P941",11,0)
 ;
"RTN","DG53P941",12,0)
 Q
"RTN","DG53P941",13,0)
 ;
"RTN","DG53P941",14,0)
POST ;Update Health Benefit Plan
"RTN","DG53P941",15,0)
 ;
"RTN","DG53P941",16,0)
 D BMES^XPDUTL("    Checking Entry in HEALTH BENEFIT PLAN File - Veteran Plan - VC Unusual and Excessive Burden   ")
"RTN","DG53P941",17,0)
 D UPDREQ
"RTN","DG53P941",18,0)
 Q
"RTN","DG53P941",19,0)
 ;
"RTN","DG53P941",20,0)
UPDREQ ; Update entry in the HEALTH BENEFIT PLAN File (25.11)
"RTN","DG53P941",21,0)
 ;
"RTN","DG53P941",22,0)
 N IEN,ERR,NAME,FDA,IEN1,NAME1
"RTN","DG53P941",23,0)
 S ERR=""
"RTN","DG53P941",24,0)
 S NAME="Veteran Plan - VC Unusual and Excessive Burden"
"RTN","DG53P941",25,0)
 ; Check if entry exists, use it if it does
"RTN","DG53P941",26,0)
 S IEN=$$FIND1^DIC(25.11,,"B",NAME)
"RTN","DG53P941",27,0)
 I 'IEN D BMES^XPDUTL("    "_NAME_" does not exist, no action is taken.  ") Q
"RTN","DG53P941",28,0)
 L +^DGHBP(25.11,IEN):10 I '$T D BMES^XPDUTL("    "_NAME_" is locked by another user. Try later.   ") Q
"RTN","DG53P941",29,0)
 S IEN1=IEN
"RTN","DG53P941",30,0)
 S IEN=IEN_","
"RTN","DG53P941",31,0)
 ;
"RTN","DG53P941",32,0)
 S FDA(25.11,IEN,.01)="Veteran Plan - VC Unusual or Excessive Burden"
"RTN","DG53P941",33,0)
  ; file new Health Benefit Plan name
"RTN","DG53P941",34,0)
 ;
"RTN","DG53P941",35,0)
 D FILE^DIE("E","FDA","ERR")
"RTN","DG53P941",36,0)
 L -^DGHBP(25.11,IEN1)
"RTN","DG53P941",37,0)
 I ERR'="" D
"RTN","DG53P941",38,0)
 . D BMES^XPDUTL("     *** An Error occurred during updating Plan: Veteran Plan - VC Unusual and Excessive Burden")
"RTN","DG53P941",39,0)
 . D MES^XPDUTL("     Please log CA SDM ticket.")
"RTN","DG53P941",40,0)
 . Q
"RTN","DG53P941",41,0)
 ;
"RTN","DG53P941",42,0)
 I ERR="" D
"RTN","DG53P941",43,0)
 . S NAME1=$P(^DGHBP(25.11,IEN1,0),"^",1)
"RTN","DG53P941",44,0)
 . D BMES^XPDUTL("    "_NAME_" is corrected in HEALTH BENEFIT PLAN File to "_NAME1_".")
"RTN","DG53P941",45,0)
 Q
"RTN","DG53P941",46,0)
 ;
"RTN","DGADDUT2")
0^5^B6214510
"RTN","DGADDUT2",1,0)
DGADDUT2 ;ALB/ERC,CKN,LBD,JAM - CONTINUATION OF ADDRESS UTILITIES ;19 Jul 2017  3:03 PM
"RTN","DGADDUT2",2,0)
 ;;5.3;Registration;**688,851,925,941**;AUG 13, 1993;Build 73
"RTN","DGADDUT2",3,0)
 ;a continuation of utilities from DGADDUTL
"RTN","DGADDUT2",4,0)
 ;
"RTN","DGADDUT2",5,0)
UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time
"RTN","DGADDUT2",6,0)
 ;
"RTN","DGADDUT2",7,0)
 N %H,%,X,%Y,%D,%M,%I,ADDDTTM,DIE,DA,DR
"RTN","DGADDUT2",8,0)
 D NOW^%DTC
"RTN","DGADDUT2",9,0)
 S ADDDTTM=%,DIE="^DPT(",DA=DFN
"RTN","DGADDUT2",10,0)
 ;
"RTN","DGADDUT2",11,0)
 ; If it's the Temporary Address, the field is .12113
"RTN","DGADDUT2",12,0)
 ; If not, it should be the Permanent Address and the default field is .118
"RTN","DGADDUT2",13,0)
 S DR=$S(TYPE="TEMP":".12113///^S X=ADDDTTM",1:".118///^S X=ADDDTTM")
"RTN","DGADDUT2",14,0)
 D ^DIE
"RTN","DGADDUT2",15,0)
 Q
"RTN","DGADDUT2",16,0)
UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7
"RTN","DGADDUT2",17,0)
 ;
"RTN","DGADDUT2",18,0)
 N DGDATA
"RTN","DGADDUT2",19,0)
 ; Zero node:
"RTN","DGADDUT2",20,0)
 S DGDATA(.01)=DGINPUT(.118)
"RTN","DGADDUT2",21,0)
 S DGDATA(1)=DFN
"RTN","DGADDUT2",22,0)
 S DGDATA(2)=DGINPUT(.122)
"RTN","DGADDUT2",23,0)
 S DGDATA(3)=DGINPUT(.119)
"RTN","DGADDUT2",24,0)
 S DGDATA(3.5)=DGINPUT(.12)
"RTN","DGADDUT2",25,0)
 ;
"RTN","DGADDUT2",26,0)
 ; One node:
"RTN","DGADDUT2",27,0)
 S DGDATA(4)=DGPRIOR(.118)
"RTN","DGADDUT2",28,0)
 S DGDATA(5)=DGPRIOR(.122)
"RTN","DGADDUT2",29,0)
 S DGDATA(6)=DGPRIOR(.12)
"RTN","DGADDUT2",30,0)
 S DGDATA(7)=DGPRIOR(.119)
"RTN","DGADDUT2",31,0)
 S DGDATA(8)=DGPRIOR(.131)
"RTN","DGADDUT2",32,0)
 S DGDATA(9)=DGPRIOR(.111)
"RTN","DGADDUT2",33,0)
 S DGDATA(10)=DGPRIOR(.112)
"RTN","DGADDUT2",34,0)
 S DGDATA(11)=DGPRIOR(.114)
"RTN","DGADDUT2",35,0)
 S DGDATA(12)=DGPRIOR(.117)
"RTN","DGADDUT2",36,0)
 S DGDATA(13)=DGPRIOR(.115)
"RTN","DGADDUT2",37,0)
 S DGDATA(14)=DGPRIOR(.1112)
"RTN","DGADDUT2",38,0)
 S DGDATA(15)=DGPRIOR(.1171)
"RTN","DGADDUT2",39,0)
 S DGDATA(16)=DGPRIOR(.1172)
"RTN","DGADDUT2",40,0)
 S DGDATA(17)=DGPRIOR(.1173)
"RTN","DGADDUT2",41,0)
 S DGDATA(18)=DGPRIOR(.121)
"RTN","DGADDUT2",42,0)
 S DGDATA(19)=DGPRIOR(.113)
"RTN","DGADDUT2",43,0)
 ;
"RTN","DGADDUT2",44,0)
 I $$ADD^DGENDBS(301.7,,.DGDATA) ;
"RTN","DGADDUT2",45,0)
 Q
"RTN","DGADDUT2",46,0)
CNTRY(DGARR) ;
"RTN","DGADDUT2",47,0)
 ;where DGARR is an array of values which includes a node for "CNTRY"
"RTN","DGADDUT2",48,0)
 ;DGARR("CNTRY") is returned in upper case display mode
"RTN","DGADDUT2",49,0)
 ;called from DGREGARP
"RTN","DGADDUT2",50,0)
 N DGC
"RTN","DGADDUT2",51,0)
 S DGC=$G(DGARR("CNTRY"))
"RTN","DGADDUT2",52,0)
 I '$D(^HL(779.004,"B",DGC)) Q ""
"RTN","DGADDUT2",53,0)
 S DGC=$$COUNTRY^DGADDUTL(DGC)
"RTN","DGADDUT2",54,0)
 S DGARR("CNTRY")=DGC
"RTN","DGADDUT2",55,0)
 Q
"RTN","DGADDUT2",56,0)
 ;
"RTN","DGADDUT2",57,0)
DISPADD(DFN) ;Display Permanent Address (DG*5.3*851)
"RTN","DGADDUT2",58,0)
 Q:'$G(DFN)
"RTN","DGADDUT2",59,0)
 N DGRP,DGA1,DGA2,DGA,DGAD,DGI,DGCC,DGUN
"RTN","DGADDUT2",60,0)
 ;Get current address
"RTN","DGADDUT2",61,0)
 ;JAM Patch DG*5.3*941 Home and office phone now associated with Residential Address - remove retrieval of those fields 
"RTN","DGADDUT2",62,0)
 S DGRP(.11)=$G(^DPT(DFN,.11))
"RTN","DGADDUT2",63,0)
 S DGUN="UNANSWERED"
"RTN","DGADDUT2",64,0)
 ;Format address data
"RTN","DGADDUT2",65,0)
 S DGAD=.11,(DGA1,DGA2)=1 D AL^DGRPU(35)
"RTN","DGADDUT2",66,0)
 ;Display address
"RTN","DGADDUT2",67,0)
 ;jam DG*5.3*925 RM#788099 Add/Edit Residential Address - change label to Permanent Mailing Address:
"RTN","DGADDUT2",68,0)
 W !!," Permanent Mailing Address: "
"RTN","DGADDUT2",69,0)
 W !,?11,$S($D(DGA(1)):DGA(1),1:"NONE ON FILE")
"RTN","DGADDUT2",70,0)
 S DGI=1 F  S DGI=$O(DGA(DGI)) Q:'DGI  W !,?11,DGA(DGI)
"RTN","DGADDUT2",71,0)
 ; only print county info if it's a US address
"RTN","DGADDUT2",72,0)
 I '$$FORIEN^DGADDUTL($P(DGRP(.11),U,10)) D
"RTN","DGADDUT2",73,0)
 . S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGUN)
"RTN","DGADDUT2",74,0)
 S DGCC=$S($G(DGCC)]"":"County: "_DGCC,1:"")
"RTN","DGADDUT2",75,0)
 W !?3,DGCC
"RTN","DGADDUT2",76,0)
 ;Display phone numbers
"RTN","DGADDUT2",77,0)
 ;JAM Patch DG*5.3*941 Home and office phone now associated with Residential Address - not shown with Permanent. 
"RTN","DGADDUT2",78,0)
 ; - remove from being displayed here 
"RTN","DGADDUT2",79,0)
 ;W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGUN)
"RTN","DGADDUT2",80,0)
 ;W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGUN)
"RTN","DGADDUT2",81,0)
 ;Display Bad Address Indicator
"RTN","DGADDUT2",82,0)
 W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
"RTN","DGADDUT2",83,0)
 Q
"RTN","DGADDUTL")
0^6^B62220802
"RTN","DGADDUTL",1,0)
DGADDUTL ;ALB/PHH,EG,BAJ,ERC,CKN,TDM,LBD,JAM - PATIENT ADDRESS ;19 Jul 2017  3:03 PM
"RTN","DGADDUTL",2,0)
 ;;5.3;Registration;**658,695,730,688,808,851,872,915,925,941**;Aug 13, 1993;Build 73
"RTN","DGADDUTL",3,0)
 Q
"RTN","DGADDUTL",4,0)
ADDR ; validate/edit Patient address (entry for DG ADDRESS UPDATE option)
"RTN","DGADDUTL",5,0)
 N %,QUIT,DIC,Y,DFN,USERSEL
"RTN","DGADDUTL",6,0)
ADDRLOOP ;
"RTN","DGADDUTL",7,0)
 W !!
"RTN","DGADDUTL",8,0)
 K DIC,Y,DFN,USERSEL
"RTN","DGADDUTL",9,0)
 S DIC="^DPT(",DIC(0)="AEMZQ",DIC("A")="Veteran Name/SSN: " D ^DIC
"RTN","DGADDUTL",10,0)
 I $D(DTOUT)!($D(DUOUT)) Q
"RTN","DGADDUTL",11,0)
 Q:Y'>0
"RTN","DGADDUTL",12,0)
 ;
"RTN","DGADDUTL",13,0)
 S DFN=+Y,QUIT=0
"RTN","DGADDUTL",14,0)
 L +^DPT(DFN):3 E  W !!,"Patient is being edited. Try again later."  G ADDR
"RTN","DGADDUTL",15,0)
 F  D  Q:QUIT
"RTN","DGADDUTL",16,0)
 .; JAM - Patch DG*5.3*941 Modify prompt to add "Mailing"
"RTN","DGADDUTL",17,0)
 .W !!,"Do you want to update the (P)ermanent Mailing Address, (T)emporary Mailing Address, or (B)oth? "
"RTN","DGADDUTL",18,0)
 .R USERSEL:300
"RTN","DGADDUTL",19,0)
 .I '$T S USERSEL="^"
"RTN","DGADDUTL",20,0)
 .I USERSEL["^"!(USERSEL="") S QUIT=1 Q
"RTN","DGADDUTL",21,0)
 .S USERSEL=$TR(USERSEL,"ptb","PTB")
"RTN","DGADDUTL",22,0)
 .I USERSEL'="P",USERSEL'="T",USERSEL'="B" D  Q
"RTN","DGADDUTL",23,0)
 ..W !,"Invalid selection!"
"RTN","DGADDUTL",24,0)
 .I USERSEL="P"!(USERSEL="B") W ! D UPDATE(DFN,"PERM")
"RTN","DGADDUTL",25,0)
 .I USERSEL="T"!(USERSEL="B") D UPDATE(DFN,"TEMP")
"RTN","DGADDUTL",26,0)
 .S QUIT=1
"RTN","DGADDUTL",27,0)
 L -^DPT(DFN)
"RTN","DGADDUTL",28,0)
 G ADDRLOOP
"RTN","DGADDUTL",29,0)
ADD(DFN) ; validate/edit Patient address (entry point for routine DGREG)
"RTN","DGADDUTL",30,0)
 ;         Input  -- DFN
"RTN","DGADDUTL",31,0)
 ;
"RTN","DGADDUTL",32,0)
 N RETVAL,ADDYN
"RTN","DGADDUTL",33,0)
 ;Display the permanent address (DG*5.3*851)
"RTN","DGADDUTL",34,0)
 D DISPADD^DGADDUT2(DFN)
"RTN","DGADDUTL",35,0)
 S (RETVAL,ADDYN)=0
"RTN","DGADDUTL",36,0)
 F  D  Q:ADDYN
"RTN","DGADDUTL",37,0)
 .;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change prompt to Permanent Mailing Address:
"RTN","DGADDUTL",38,0)
 .S ADDYN=$$ADDYN("Do you want to edit the Patient's Permanent Mailing Address")
"RTN","DGADDUTL",39,0)
 .S RETVAL=ADDYN
"RTN","DGADDUTL",40,0)
 .I ADDYN'=1,ADDYN'=2 S (ADDYN,RETVAL)=0
"RTN","DGADDUTL",41,0)
 .I 'ADDYN W !?5,"Enter 'YES' to edit Patient's Address or 'NO' to continue."
"RTN","DGADDUTL",42,0)
 I ADDYN=1,$G(DFN)'="",$D(^DPT(DFN,0)) D
"RTN","DGADDUTL",43,0)
 .D UPDATE(DFN,"PERM")
"RTN","DGADDUTL",44,0)
 .S RETVAL=1
"RTN","DGADDUTL",45,0)
 Q RETVAL
"RTN","DGADDUTL",46,0)
ADDYN(PROMPT) ; Yes/No Prompt to Edit/Validate Address
"RTN","DGADDUTL",47,0)
 ;         Input  -- None
"RTN","DGADDUTL",48,0)
 ;         Output --  1 = YES
"RTN","DGADDUTL",49,0)
 ;                    2 = NO
"RTN","DGADDUTL",50,0)
 ;                   -1 = Aborted
"RTN","DGADDUTL",51,0)
 ;
"RTN","DGADDUTL",52,0)
 N %
"RTN","DGADDUTL",53,0)
 W !,PROMPT
"RTN","DGADDUTL",54,0)
 D YN^DICN
"RTN","DGADDUTL",55,0)
 Q %
"RTN","DGADDUTL",56,0)
UPDATE(DFN,TYPE) ; Update the Address
"RTN","DGADDUTL",57,0)
 ;         Input  -- TYPE = "PERM" for Permanent Address
"RTN","DGADDUTL",58,0)
 ;                        = "TEMP" for Temporary Address
"RTN","DGADDUTL",59,0)
 ;         Output -- None
"RTN","DGADDUTL",60,0)
 ;         
"RTN","DGADDUTL",61,0)
 I TYPE'="PERM",TYPE'="TEMP" Q
"RTN","DGADDUTL",62,0)
 I TYPE="PERM" D
"RTN","DGADDUTL",63,0)
 .W !
"RTN","DGADDUTL",64,0)
 .; JAM DG*5.3*941, Home and Office phone numbers not associated with Perm Address, so set FLG(1)=0 so we don't edit these fields here
"RTN","DGADDUTL",65,0)
 .N FLG S FLG(1)=0,FLG(2)=1
"RTN","DGADDUTL",66,0)
 .D ADDRED(DFN,.FLG)
"RTN","DGADDUTL",67,0)
 ;
"RTN","DGADDUTL",68,0)
 I TYPE="TEMP" D
"RTN","DGADDUTL",69,0)
 .D EDITTADR(DFN)
"RTN","DGADDUTL",70,0)
 ;
"RTN","DGADDUTL",71,0)
 Q
"RTN","DGADDUTL",72,0)
UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time
"RTN","DGADDUTL",73,0)
 ;
"RTN","DGADDUTL",74,0)
 D UPDDTTM^DGADDUT2(DFN,TYPE)
"RTN","DGADDUTL",75,0)
 Q
"RTN","DGADDUTL",76,0)
ADDRED(DFN,FLG) ; Address Edit (Code copied from DGREGAED and modified)
"RTN","DGADDUTL",77,0)
 ;Input:
"RTN","DGADDUTL",78,0)
 ;  DFN (required) - Internal Entry # of Patient File (#2)
"RTN","DGADDUTL",79,0)
 ;  FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
"RTN","DGADDUTL",80,0)
 ;    FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
"RTN","DGADDUTL",81,0)
 ;    FLG(2) - if 1, display before & after address for user confirmation
"RTN","DGADDUTL",82,0)
 N SRC,%,DGINPUT,I,X,Y
"RTN","DGADDUTL",83,0)
 S SRC="ADDUTL"
"RTN","DGADDUTL",84,0)
 D EN^DGREGAED(DFN,.FLG,SRC)
"RTN","DGADDUTL",85,0)
 ;
"RTN","DGADDUTL",86,0)
 ; Update the Date/Time Stamp
"RTN","DGADDUTL",87,0)
 ;The next line was disabled to fix problem of Date/Time stamp being
"RTN","DGADDUTL",88,0)
 ;updated even if no changes were made (DG*5.3*851).
"RTN","DGADDUTL",89,0)
 ;D UPDDTTM(DFN,TYPE)
"RTN","DGADDUTL",90,0)
 Q
"RTN","DGADDUTL",91,0)
GETPRIOR(DFN,DGPRIOR) ; Get prior address fields.
"RTN","DGADDUTL",92,0)
 N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
"RTN","DGADDUTL",93,0)
 D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121;.118;.119;.12;.122;.1171:.1173","I","DGCURR")
"RTN","DGADDUTL",94,0)
 F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121,.118,.119,.12,.122,.1171,.1172,.1173 D
"RTN","DGADDUTL",95,0)
 . S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
"RTN","DGADDUTL",96,0)
 M DGPRIOR=DGARRY("OLD")
"RTN","DGADDUTL",97,0)
 Q
"RTN","DGADDUTL",98,0)
GETUPDTS(DFN,DGINPUT) ; Get current address fields.
"RTN","DGADDUTL",99,0)
 N DGCURR,DGN,DGARRY
"RTN","DGADDUTL",100,0)
 D GETS^DIQ(2,DFN_",",".118;.119;.12;.122","I","DGCURR")
"RTN","DGADDUTL",101,0)
 F DGN=.118,.119,.12,.122 D
"RTN","DGADDUTL",102,0)
 . S DGARRY("NEW",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
"RTN","DGADDUTL",103,0)
 M DGINPUT=DGARRY("NEW")
"RTN","DGADDUTL",104,0)
 Q
"RTN","DGADDUTL",105,0)
FILEYN(DGOLD,DGNEW) ; Determine whether or not to file to #301.7
"RTN","DGADDUTL",106,0)
 N RETVAL
"RTN","DGADDUTL",107,0)
 S RETVAL=0
"RTN","DGADDUTL",108,0)
 D
"RTN","DGADDUTL",109,0)
 .I DGOLD(.111)'=$G(DGNEW(.111)) S RETVAL=1 Q
"RTN","DGADDUTL",110,0)
 .I DGOLD(.112)'=$G(DGNEW(.112)) S RETVAL=1 Q
"RTN","DGADDUTL",111,0)
 .I DGOLD(.113)'=$G(DGNEW(.113)) S RETVAL=1 Q
"RTN","DGADDUTL",112,0)
 .I DGOLD(.114)'=$G(DGNEW(.114)) S RETVAL=1 Q
"RTN","DGADDUTL",113,0)
 .I DGOLD(.115)'=$P($G(DGNEW(.115)),"^",2) S RETVAL=1 Q
"RTN","DGADDUTL",114,0)
 .I DGOLD(.1112)'=$G(DGNEW(.1112)) S RETVAL=1 Q
"RTN","DGADDUTL",115,0)
 .I DGOLD(.117)'=$P($G(DGNEW(.117)),"^",2) S RETVAL=1 Q
"RTN","DGADDUTL",116,0)
 .I DGOLD(.131)'=$G(DGNEW(.131)) S RETVAL=1 Q
"RTN","DGADDUTL",117,0)
 .I DGOLD(.1171)'=$G(DGNEW(.1171)) S RETVAL=1 Q
"RTN","DGADDUTL",118,0)
 .I DGOLD(.1172)'=$G(DGNEW(.1172)) S RETVAL=1 Q
"RTN","DGADDUTL",119,0)
 .I DGOLD(.1173)'=$P($G(DGNEW(.1173)),"^",2) S RETVAL=1 Q
"RTN","DGADDUTL",120,0)
 .I DGOLD(.121)'=$G(DGNEW(.121)) S RETVAL=1 Q
"RTN","DGADDUTL",121,0)
 Q RETVAL
"RTN","DGADDUTL",122,0)
FOREIGN(DFN,CIEN,FILE,FIELD,COUNTRY) ;
"RTN","DGADDUTL",123,0)
 ; ** NOTE we have to default the value for "US" into the prompt if it is blank
"RTN","DGADDUTL",124,0)
 N FORGN,DA,DIR,DTOUT,DUOUT,DIROUT,DONE,INDX
"RTN","DGADDUTL",125,0)
 S:'$G(FILE) FILE=2  I '$G(FIELD) S FIELD=.1173
"RTN","DGADDUTL",126,0)
 S DIR(0)=FILE_","_FIELD,DONE=0 S:DFN DA=DFN
"RTN","DGADDUTL",127,0)
 S DIR("B")=$E($$CNTRYI^DGADDUTL(CIEN),1,19) I DIR("B")=-1 S DIR("B")="UNKNOWN COUNTRY"
"RTN","DGADDUTL",128,0)
 F  D  Q:DONE
"RTN","DGADDUTL",129,0)
 . D ^DIR
"RTN","DGADDUTL",130,0)
 . I $D(DTOUT) S DONE=1,FORGN=-1 Q
"RTN","DGADDUTL",131,0)
 . I $D(DUOUT)!$D(DIROUT) W !,"EXIT NOT ALLOWED" Q
"RTN","DGADDUTL",132,0)
 . I $D(DIRUT) W !,"This is a required response." Q
"RTN","DGADDUTL",133,0)
 . S COUNTRY=$P($G(Y),"^",2),FORGN=$$FORIEN($P($G(Y),"^")),DONE=1
"RTN","DGADDUTL",134,0)
 Q FORGN
"RTN","DGADDUTL",135,0)
UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7
"RTN","DGADDUTL",136,0)
 ;
"RTN","DGADDUTL",137,0)
 D UPDADDLG^DGADDUT2(DFN,.DGPRIOR,.DGINPUT)
"RTN","DGADDUTL",138,0)
 Q
"RTN","DGADDUTL",139,0)
EDITTADR(DFN) ; Edit Temporary Address
"RTN","DGADDUTL",140,0)
 N DGPRIOR,DGCH,DGRPAN,DGDR,DGRPS
"RTN","DGADDUTL",141,0)
 I $G(DFN)="" Q
"RTN","DGADDUTL",142,0)
 ;I ($G(DFN)'?.N) Q
"RTN","DGADDUTL",143,0)
 ;
"RTN","DGADDUTL",144,0)
 ; Get the current Temporary Address and display it
"RTN","DGADDUTL",145,0)
 D GETTADR(DFN,.DGPRIOR)
"RTN","DGADDUTL",146,0)
 D DISPTADR(DFN,.DGPRIOR)
"RTN","DGADDUTL",147,0)
 W !!
"RTN","DGADDUTL",148,0)
 ;
"RTN","DGADDUTL",149,0)
 ; JAM - Patch DG*5.3*941 - Temporary Mailing Address is editable via screen 1.1 group 3 (from screen 1 group 5)
"RTN","DGADDUTL",150,0)
 ;S DGCH=5,DGRPAN="1,2,3,4,5,",DGDR="",DGRPS=1
"RTN","DGADDUTL",151,0)
 S DGCH=3,DGRPAN="1,2,3,4,5",DGDR="",DGRPS=1.1
"RTN","DGADDUTL",152,0)
 D CHOICE^DGRPP
"RTN","DGADDUTL",153,0)
 D ^DGRPE
"RTN","DGADDUTL",154,0)
 ; Update the Date/Time Stamp
"RTN","DGADDUTL",155,0)
 D UPDDTTM(DFN,TYPE)
"RTN","DGADDUTL",156,0)
 Q
"RTN","DGADDUTL",157,0)
GETTADR(DFN,DGPRIOR) ; Get prior temporary address fields.
"RTN","DGADDUTL",158,0)
 N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
"RTN","DGADDUTL",159,0)
 D GETS^DIQ(2,DFN_",",".1211;.1212;.1213;.1214;.1215;.1216;.1217;.1218;.12105;.1219;.12111;.12112;.12113;.12114;.1221:.1223","I","DGCURR")
"RTN","DGADDUTL",160,0)
 F DGN=.1211,.1212,.1213,.1214,.1215,.1216,.1217,.1218,.12105,.1219,.12111,.12112,.12113,.12114,.1221,.1222,.1223 D
"RTN","DGADDUTL",161,0)
 .S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
"RTN","DGADDUTL",162,0)
 M DGPRIOR=DGARRY("OLD")
"RTN","DGADDUTL",163,0)
 Q
"RTN","DGADDUTL",164,0)
DISPTADR(DFN,DGARRY) ; Display Temporary Address
"RTN","DGADDUTL",165,0)
 N DGADRACT,DGADR1,DGADR2,DGADR3,DGCITY,DGSTATE,DGZIP
"RTN","DGADDUTL",166,0)
 N DGCOUNTY,DGPHONE,DGFROMDT,DGTODT,DGPROV,DGPCODE,DGCNTRY,DGFORN
"RTN","DGADDUTL",167,0)
 ;
"RTN","DGADDUTL",168,0)
 S DGADRACT=$G(DGARRY(.12105))
"RTN","DGADDUTL",169,0)
 S DGADR1=$G(DGARRY(.1211))
"RTN","DGADDUTL",170,0)
 S DGADR2=$G(DGARRY(.1212))
"RTN","DGADDUTL",171,0)
 S DGADR3=$G(DGARRY(.1213))
"RTN","DGADDUTL",172,0)
 S DGCITY=$G(DGARRY(.1214))
"RTN","DGADDUTL",173,0)
 S DGSTATE=$G(DGARRY(.1215))
"RTN","DGADDUTL",174,0)
 S DGZIP=$G(DGARRY(.1216))
"RTN","DGADDUTL",175,0)
 S DGCOUNTY=$G(DGARRY(.12111))
"RTN","DGADDUTL",176,0)
 I DGCOUNTY'="",DGSTATE'="",$D(^DIC(5,DGSTATE,1,DGCOUNTY,0)) D
"RTN","DGADDUTL",177,0)
 .S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_$S($P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)'="":"("_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)_")",1:"")
"RTN","DGADDUTL",178,0)
 ;changing to remove display of empty (), will only display if a code is in the 4th piece of the state file-Patch 872
"RTN","DGADDUTL",179,0)
 ;S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_"( "_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)
"RTN","DGADDUTL",180,0)
 I DGADRACT'="Y" S DGCOUNTY="NOT APPLICABLE"
"RTN","DGADDUTL",181,0)
 I DGSTATE'="",$D(^DIC(5,DGSTATE,0)) S DGSTATE=$P(^DIC(5,DGSTATE,0),"^",2)
"RTN","DGADDUTL",182,0)
 S DGPROV=$G(DGARRY(.1221))
"RTN","DGADDUTL",183,0)
 S DGPCODE=$G(DGARRY(.1222))
"RTN","DGADDUTL",184,0)
 S DGCNTRY=$G(DGARRY(.1223))
"RTN","DGADDUTL",185,0)
 S DGFORN=$$FORIEN(DGCNTRY)
"RTN","DGADDUTL",186,0)
 I DGCNTRY]"" S DGCNTRY=$$CNTRYI(DGCNTRY)
"RTN","DGADDUTL",187,0)
 S DGPHONE=$G(DGARRY(.1219))
"RTN","DGADDUTL",188,0)
 S DGFROMDT=$$FMTE^XLFDT($G(DGARRY(.1217)))
"RTN","DGADDUTL",189,0)
 S DGTODT=$$FMTE^XLFDT($G(DGARRY(.1218)))
"RTN","DGADDUTL",190,0)
 ;
"RTN","DGADDUTL",191,0)
 ;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change field label to Temporary Mailing Address:
"RTN","DGADDUTL",192,0)
 W !!,"Temporary Mailing Address: "
"RTN","DGADDUTL",193,0)
 I DGADRACT="Y" D
"RTN","DGADDUTL",194,0)
 .W:DGADR1'="" !?9,DGADR1
"RTN","DGADDUTL",195,0)
 .W:DGADR2'="" !?9,DGADR2
"RTN","DGADDUTL",196,0)
 .W:DGADR3'="" !?9,DGADR3
"RTN","DGADDUTL",197,0)
 .I DGFORN=0 D
"RTN","DGADDUTL",198,0)
 ..W !?9,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
"RTN","DGADDUTL",199,0)
 .I DGFORN W !?8,$S(DGPCODE'="":DGPCODE,1:"")_" "_$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"")
"RTN","DGADDUTL",200,0)
 ;commenting out, causes address to print 2x. Patch 872
"RTN","DGADDUTL",201,0)
 ;W !?9,$S(DGCITY'="":DGCITY,1:"")_","_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
"RTN","DGADDUTL",202,0)
 ;Removing lines from dot structure Patch 872
"RTN","DGADDUTL",203,0)
 W !," County: "_DGCOUNTY
"RTN","DGADDUTL",204,0)
 W !,"  Phone: "_DGPHONE
"RTN","DGADDUTL",205,0)
 W !,"From/To: "_$P(DGFROMDT,",")_","_$P(DGFROMDT,", ",2)_"-"_$P(DGTODT,",")_","_$P(DGTODT,", ",2)
"RTN","DGADDUTL",206,0)
 ;
"RTN","DGADDUTL",207,0)
 I $G(DGARRY(.12105))="N" D
"RTN","DGADDUTL",208,0)
 .W:$G(DGARRY(.1211))="" !?9,"NO TEMPORARY ADDRESS"
"RTN","DGADDUTL",209,0)
 .W:$G(DGARRY(.1212))="" !?9,""
"RTN","DGADDUTL",210,0)
 .W !," County: NOT APPLICABLE"
"RTN","DGADDUTL",211,0)
 .W !,"  Phone: NOT APPLICABLE"
"RTN","DGADDUTL",212,0)
 .W !,"From/To: NOT APPLICABLE"
"RTN","DGADDUTL",213,0)
 Q
"RTN","DGADDUTL",214,0)
COUNTRY(DGC) ;
"RTN","DGADDUTL",215,0)
 ;where DGC is the external value of the country
"RTN","DGADDUTL",216,0)
 ;return value is in upper case display mode
"RTN","DGADDUTL",217,0)
 ;if DGC is invalid, return -1
"RTN","DGADDUTL",218,0)
 N DGCC,DGIEN
"RTN","DGADDUTL",219,0)
 ; if input is NULL change to US
"RTN","DGADDUTL",220,0)
 I $G(DGC)="" S DGC="USA"
"RTN","DGADDUTL",221,0)
 ; Get IEN from B index, error if not found
"RTN","DGADDUTL",222,0)
 S DGIEN=$O(^HL(779.004,"B",DGC,"")) Q:DGIEN']"" -1
"RTN","DGADDUTL",223,0)
 ; xlate IEN to POSTAL NAME
"RTN","DGADDUTL",224,0)
 S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
"RTN","DGADDUTL",225,0)
 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
"RTN","DGADDUTL",226,0)
 I DGCC="<NULL>" D
"RTN","DGADDUTL",227,0)
 . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
"RTN","DGADDUTL",228,0)
 Q DGCC
"RTN","DGADDUTL",229,0)
FOR(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is not valid
"RTN","DGADDUTL",230,0)
 ; DGC is the external value of the country (.01 field of file 779.004)
"RTN","DGADDUTL",231,0)
 N DGFOR
"RTN","DGADDUTL",232,0)
 S DGFOR=0
"RTN","DGADDUTL",233,0)
 I $G(DGC)="" Q DGFOR
"RTN","DGADDUTL",234,0)
 I '$D(^HL(779.004,"B",DGC)) Q -1
"RTN","DGADDUTL",235,0)
 I DGC'="USA" S DGFOR=1
"RTN","DGADDUTL",236,0)
 Q DGFOR
"RTN","DGADDUTL",237,0)
CNTRYI(DGIEN) ;where DGC is the internal value of the country
"RTN","DGADDUTL",238,0)
 ;return DGC as the display value for the country
"RTN","DGADDUTL",239,0)
 ;if the input value is not a valid IEN, return -1
"RTN","DGADDUTL",240,0)
 ;if the input value is null, return null
"RTN","DGADDUTL",241,0)
 N DGCC
"RTN","DGADDUTL",242,0)
 I $G(DGIEN)="" Q ""
"RTN","DGADDUTL",243,0)
 I '$D(^HL(779.004,DGIEN,0)) Q -1
"RTN","DGADDUTL",244,0)
 ; xlate IEN to POSTAL NAME
"RTN","DGADDUTL",245,0)
 S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
"RTN","DGADDUTL",246,0)
 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
"RTN","DGADDUTL",247,0)
 I DGCC="<NULL>" D
"RTN","DGADDUTL",248,0)
 . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
"RTN","DGADDUTL",249,0)
 Q DGCC
"RTN","DGADDUTL",250,0)
FORIEN(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is invalid
"RTN","DGADDUTL",251,0)
 ;DGC is the IEN of the country file (#779.004)
"RTN","DGADDUTL",252,0)
 N DGFOR
"RTN","DGADDUTL",253,0)
 S DGFOR=0
"RTN","DGADDUTL",254,0)
 I $G(DGC)="" Q DGFOR
"RTN","DGADDUTL",255,0)
 I DGC'?1.3N Q -1
"RTN","DGADDUTL",256,0)
 I '$D(^HL(779.004,DGC,0)) Q -1
"RTN","DGADDUTL",257,0)
 I DGC]"",(DGC'=$O(^HL(779.004,"B","USA",""))) S DGFOR=1
"RTN","DGADDUTL",258,0)
 Q DGFOR
"RTN","DGCNTRY")
0^20^B4455344
"RTN","DGCNTRY",1,0)
DGCNTRY ;BAJ,JAM - REGISTRATION SCREEN 7/CROSS REFERENCE CLEANUP ;15 Feb 2018  4:03 PM
"RTN","DGCNTRY",2,0)
 ;;5.3;Registration;**688,941**;Aug 13, 1993;Build 73
"RTN","DGCNTRY",3,0)
 ;
"RTN","DGCNTRY",4,0)
 ; This routine is called by a New style MUMPS index named AXCNTRY
"RTN","DGCNTRY",5,0)
 ; The purpose of this routine is to clear certain fields when the Country field is changed
"RTN","DGCNTRY",6,0)
 ; Values:       X1(#) contains the OLD values
"RTN","DGCNTRY",7,0)
 ;                       X2(#) contains the NEW values
"RTN","DGCNTRY",8,0)
 ;               
"RTN","DGCNTRY",9,0)
 ; DG*5.3*941 - JAM - Updated for Residential Address fields - see tag DTABLE. Related to index AXRCNTRY.
"RTN","DGCNTRY",10,0)
 ;
"RTN","DGCNTRY",11,0)
EN(FILE,ATYPE,FIELD) ; entry point
"RTN","DGCNTRY",12,0)
 ;
"RTN","DGCNTRY",13,0)
 ; Code to TRIGGER deletion of field data.
"RTN","DGCNTRY",14,0)
 N DGENDA,DATA,FORGN,ERROR
"RTN","DGCNTRY",15,0)
 Q:X=""
"RTN","DGCNTRY",16,0)
 S DGENDA=DA,ERROR=""
"RTN","DGCNTRY",17,0)
 S FORGN=$$FORGN(.X2) D SETARR(.DATA,FORGN,FILE,ATYPE,FIELD)
"RTN","DGCNTRY",18,0)
 Q $$UPD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR)
"RTN","DGCNTRY",19,0)
 ;
"RTN","DGCNTRY",20,0)
SETARR(DATA,FORGN,FILE,ATYPE,FIELD) ;set up data array
"RTN","DGCNTRY",21,0)
 N CNT,CURFILE,CTRYFLD,FDFLG,ADDTYPE,T,FTYPE,CURFTYPE
"RTN","DGCNTRY",22,0)
 ; If foreign kill domestic fields and vice versa
"RTN","DGCNTRY",23,0)
 S FTYPE=$S(FORGN:"D",1:"F")
"RTN","DGCNTRY",24,0)
 F CNT=1:1 S T=$P($T(DTABLE+CNT),";;",3) Q:T="QUIT"  D
"RTN","DGCNTRY",25,0)
 . S CURFTYPE=$P(T,";",1),ADDTYPE=$P(T,";",2),CURFILE=$P(T,";",3),CTRYFLD=$P(T,";",4),CURFLD=$P(T,";",5)
"RTN","DGCNTRY",26,0)
 . I CURFTYPE=FTYPE,CURFILE=FILE,ADDTYPE=ATYPE,CTRYFLD=FIELD S DATA(CURFLD)="@"
"RTN","DGCNTRY",27,0)
 Q
"RTN","DGCNTRY",28,0)
FORGN(X2)  ; logic to determine if COUNTRY is US or Foreign
"RTN","DGCNTRY",29,0)
 Q $$FORIEN^DGADDUTL(X2(1))
"RTN","DGCNTRY",30,0)
 ;
"RTN","DGCNTRY",31,0)
DTABLE ;TABLE of Foreign and Domestic fields: structure -->>;;DESCRIPTION;;(F)OREIGN/(D)OMESTIC;FILE;COUNTRY FIELD;FIELD
"RTN","DGCNTRY",32,0)
 ;;PROVINCE;;F;PERM;2;.1173;.1171
"RTN","DGCNTRY",33,0)
 ;;POSTAL CODE;;F;PERM;2;.1173;.1172
"RTN","DGCNTRY",34,0)
 ;;STATE;;D;PERM;2;.1173;.115
"RTN","DGCNTRY",35,0)
 ;;COUNTY;;D;PERM;2;.1173;.1117
"RTN","DGCNTRY",36,0)
 ;;ZIP+4;;D;PERM;2;.1173;.1112
"RTN","DGCNTRY",37,0)
 ;;PROVINCE;;F;TEMP;2;.1223;.1221
"RTN","DGCNTRY",38,0)
 ;;POSTAL CODE;;F;TEMP;2;.1223;.1222
"RTN","DGCNTRY",39,0)
 ;;STATE;;D;TEMP;2;.1223;.1215
"RTN","DGCNTRY",40,0)
 ;;COUNTY;;D;TEMP;2;.1223;.12111
"RTN","DGCNTRY",41,0)
 ;;ZIP+4;;D;TEMP;2;.1223;.12112
"RTN","DGCNTRY",42,0)
 ;;PROVINCE;;F;CONF;2;.14116;.14114
"RTN","DGCNTRY",43,0)
 ;;POSTAL CODE;;F;CONF;2;.14116;.14115
"RTN","DGCNTRY",44,0)
 ;;STATE;;D;CONF;2;.14116;.1415
"RTN","DGCNTRY",45,0)
 ;;COUNTY;;D;CONF;2;.14116;.14111
"RTN","DGCNTRY",46,0)
 ;;ZIP+4;;D;CONF;2;.14116;.1416
"RTN","DGCNTRY",47,0)
 ;;PROVINCE;;F;RESI;2;.11573;.11571
"RTN","DGCNTRY",48,0)
 ;;POSTAL CODE;;F;RESI;2;.11573;.11572
"RTN","DGCNTRY",49,0)
 ;;STATE;;D;RESI;2;.11573;.1155
"RTN","DGCNTRY",50,0)
 ;;COUNTY;;D;RESI;2;.11573;.1157
"RTN","DGCNTRY",51,0)
 ;;ZIP+4;;D;RESI;2;.11573;.1156
"RTN","DGCNTRY",52,0)
 ;;QUIT;;QUIT
"RTN","DGDDDTTM")
0^15^B7898513
"RTN","DGDDDTTM",1,0)
DGDDDTTM ;ALB/MRL,BAJ,TDM,JAM - TRIGGER DT/TM CROSS REFERENCES [PATIENT] ;18 Sept 2017  12:54 PM
"RTN","DGDDDTTM",2,0)
 ;;5.3;Registration;**665,653,688,754,941**;Aug 13, 1993;Build 73
"RTN","DGDDDTTM",3,0)
 ;
"RTN","DGDDDTTM",4,0)
 ; This routine contains the code for new style cross-reference record
"RTN","DGDDDTTM",5,0)
 ; triggers for the PATIENT File #2.
"RTN","DGDDDTTM",6,0)
 ;
"RTN","DGDDDTTM",7,0)
TEMP ; PATIENT File #2 Record Index: ADTTM1
"RTN","DGDDDTTM",8,0)
 ; 
"RTN","DGDDDTTM",9,0)
 ; This code updates the TEMPORARY ADDRESS CHANGE DT/TM field when any 
"RTN","DGDDDTTM",10,0)
 ; of the following Temporary Address related data changes for a patient:
"RTN","DGDDDTTM",11,0)
 ;    
"RTN","DGDDDTTM",12,0)
 ;    TEMPORARY STREET [LINE 1]    (#.1211)
"RTN","DGDDDTTM",13,0)
 ;    TEMPORARY STREET [LINE 2]    (#.1212)
"RTN","DGDDDTTM",14,0)
 ;    TEMPORARY STREET [LINE 3]    (#.1213)
"RTN","DGDDDTTM",15,0)
 ;    TEMPORARY CITY               (#.1214)
"RTN","DGDDDTTM",16,0)
 ;    TEMPORARY STATE              (#.1215)
"RTN","DGDDDTTM",17,0)
 ;    TEMPORARY ZIP CODE           (#.1216)
"RTN","DGDDDTTM",18,0)
 ;    TEMPORARY ADDRESS START DATE (#.1217)
"RTN","DGDDDTTM",19,0)
 ;    TEMPORARY ADDRESS END DATE   (#.1218)
"RTN","DGDDDTTM",20,0)
 ;    TEMPORARY ADDRESS ACTIVE?    (#.12105)
"RTN","DGDDDTTM",21,0)
 ;    TEMPORARY ZIP+4              (#.12112)
"RTN","DGDDDTTM",22,0)
 ;    TEMPORARY ADDRESS COUNTY     (#.12111)
"RTN","DGDDDTTM",23,0)
 ;    TEMPORARY ADDRESS PROVINCE   (#.1221)
"RTN","DGDDDTTM",24,0)
 ;    TEMPORARY ADDRESS POSTAL CODE (#.1222)
"RTN","DGDDDTTM",25,0)
 ;    TEMPORARY ADDRESS COUNTRY     (#.1223)
"RTN","DGDDDTTM",26,0)
 ;
"RTN","DGDDDTTM",27,0)
 Q:$G(DGRONUPD)=1  ;Suppress update for ROM (set in routine DGROHLR1)
"RTN","DGDDDTTM",28,0)
 N DGIEN,DATA S DATA(.12113)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",29,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",30,0)
 Q
"RTN","DGDDDTTM",31,0)
 ;
"RTN","DGDDDTTM",32,0)
CONF ; PATIENT File #2 Record Index: ADTTM2
"RTN","DGDDDTTM",33,0)
 ;
"RTN","DGDDDTTM",34,0)
 ; This code updates the CONFIDENTIAL ADDR CHANGE DT/TM field when any
"RTN","DGDDDTTM",35,0)
 ; of the following Confidential Address related data changes for a
"RTN","DGDDDTTM",36,0)
 ; patient:
"RTN","DGDDDTTM",37,0)
 ;
"RTN","DGDDDTTM",38,0)
 ;    CONFIDENTIAL STREET [LINE 1]  (#.1411)
"RTN","DGDDDTTM",39,0)
 ;    CONFIDENTIAL STREET [LINE 2]  (#.1412)
"RTN","DGDDDTTM",40,0)
 ;    CONFIDENTIAL STREET [LINE 3]  (#.1413)
"RTN","DGDDDTTM",41,0)
 ;    CONFIDENTIAL ADDRESS CITY     (#.1414)
"RTN","DGDDDTTM",42,0)
 ;    CONFIDENTIAL ADDRESS STATE    (#.1415)
"RTN","DGDDDTTM",43,0)
 ;    CONFIDENTIAL ADDRESS ZIP CODE (#.1416)
"RTN","DGDDDTTM",44,0)
 ;    CONFIDENTIAL START DATE       (#.1417)
"RTN","DGDDDTTM",45,0)
 ;    CONFIDENTIAL END DATE         (#.1418)
"RTN","DGDDDTTM",46,0)
 ;    CONFIDENTIAL ADDRESS ACTIVE?  (#.14105)
"RTN","DGDDDTTM",47,0)
 ;    CONFIDENTIAL ADDRESS COUNTY   (#.14111)
"RTN","DGDDDTTM",48,0)
 ;    CONFIDENTIAL ADDR PROVINCE    (#.14114)
"RTN","DGDDDTTM",49,0)
 ;    CONFIDENTIAL ADDR POSTAL CODE (#.14115)
"RTN","DGDDDTTM",50,0)
 ;    CONFIDENTIAL ADDR COUNTRY     (#.14116)
"RTN","DGDDDTTM",51,0)
 ;    CONFIDENTIAL PHONE NUMBER     (#.1315)
"RTN","DGDDDTTM",52,0)
 ;
"RTN","DGDDDTTM",53,0)
 Q:$G(DGRONUPD)=1  ;Suppress update for ROM (set in routine DGROHLR1)
"RTN","DGDDDTTM",54,0)
 N DGIEN,DATA S DATA(.14112)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",55,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",56,0)
 Q
"RTN","DGDDDTTM",57,0)
 ;
"RTN","DGDDDTTM",58,0)
PNOK ; PATIENT File #2 Record Index: ADTTM3
"RTN","DGDDDTTM",59,0)
 ;
"RTN","DGDDDTTM",60,0)
 ; This code updates the PRIMARY NOK CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",61,0)
 ; of the following Primary Next of Kin related data changes for a
"RTN","DGDDDTTM",62,0)
 ; patient:
"RTN","DGDDDTTM",63,0)
 ;
"RTN","DGDDDTTM",64,0)
 ;    K-NAME OF PRIMARY NOK        (#.211)
"RTN","DGDDDTTM",65,0)
 ;    K-RELATIONSHIP TO PATIENT    (#.212)
"RTN","DGDDDTTM",66,0)
 ;    K-STREET ADDRESS [LINE 1]    (#.213)
"RTN","DGDDDTTM",67,0)
 ;    K-STREET ADDRESS [LINE 2]    (#.214)
"RTN","DGDDDTTM",68,0)
 ;    K-STREET ADDRESS [LINE 3]    (#.215)
"RTN","DGDDDTTM",69,0)
 ;    K-CITY                       (#.216)
"RTN","DGDDDTTM",70,0)
 ;    K-STATE                      (#.217)
"RTN","DGDDDTTM",71,0)
 ;    K-ZIP CODE                   (#.218)
"RTN","DGDDDTTM",72,0)
 ;    K-ADDRESS SAME AS PATIENT'S? (#.2125)
"RTN","DGDDDTTM",73,0)
 ;    K-ZIP+4                      (#.2207)
"RTN","DGDDDTTM",74,0)
 ;    K-PHONE NUMBER               (#.219)
"RTN","DGDDDTTM",75,0)
 ;    K-WORK PHONE NUMBER          (#.21011)
"RTN","DGDDDTTM",76,0)
 ;
"RTN","DGDDDTTM",77,0)
 N DGIEN,DATA S DATA(.21012)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",78,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",79,0)
 Q
"RTN","DGDDDTTM",80,0)
 ;
"RTN","DGDDDTTM",81,0)
SNOK ; PATIENT File #2 Record Index: ADTTM4
"RTN","DGDDDTTM",82,0)
 ;
"RTN","DGDDDTTM",83,0)
 ; This code updates the SECONDARY NOK CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",84,0)
 ; of the following Secondary Next of Kin related data changes for a
"RTN","DGDDDTTM",85,0)
 ; patient:
"RTN","DGDDDTTM",86,0)
 ;
"RTN","DGDDDTTM",87,0)
 ;    K2-NAME OF SECONDARY NOK      (#.2191)
"RTN","DGDDDTTM",88,0)
 ;    K2-RELATIONSHIP TO PATIENT    (#.2192)
"RTN","DGDDDTTM",89,0)
 ;    K2-STREET ADDRESS [LINE 1]    (#.2193)
"RTN","DGDDDTTM",90,0)
 ;    K2-STREET ADDRESS [LINE 2]    (#.2194)
"RTN","DGDDDTTM",91,0)
 ;    K2-STREET ADDRESS [LINE 3]    (#.2195)
"RTN","DGDDDTTM",92,0)
 ;    K2-CITY                       (#.2196)
"RTN","DGDDDTTM",93,0)
 ;    K2-STATE                      (#.2197)
"RTN","DGDDDTTM",94,0)
 ;    K2-ZIP CODE                   (#.2198)
"RTN","DGDDDTTM",95,0)
 ;    K2-ADDRESS SAME AS PATIENT'S? (#.21925)
"RTN","DGDDDTTM",96,0)
 ;    K2-ZIP+4                      (#.2203)
"RTN","DGDDDTTM",97,0)
 ;    K2-PHONE NUMBER               (#.2199)
"RTN","DGDDDTTM",98,0)
 ;    K2-WORK PHONE NUMBER          (#.211011)
"RTN","DGDDDTTM",99,0)
 ;
"RTN","DGDDDTTM",100,0)
 N DGIEN,DATA S DATA(.211012)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",101,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",102,0)
 Q
"RTN","DGDDDTTM",103,0)
 ;
"RTN","DGDDDTTM",104,0)
ECON ; PATIENT File #2 Record Index: ADTTM5
"RTN","DGDDDTTM",105,0)
 ;
"RTN","DGDDDTTM",106,0)
 ; This code updates the E-CONTACT CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",107,0)
 ; of the following Emergency Contact related data changes for a
"RTN","DGDDDTTM",108,0)
 ; patient:
"RTN","DGDDDTTM",109,0)
 ;
"RTN","DGDDDTTM",110,0)
 ;    E-NAME (#.331)
"RTN","DGDDDTTM",111,0)
 ;    E-RELATIONSHIP TO PATIENT    (#.332)
"RTN","DGDDDTTM",112,0)
 ;    E-STREET ADDRESS [LINE 1]    (#.333)
"RTN","DGDDDTTM",113,0)
 ;    E-STREET ADDRESS [LINE 2]    (#.334)
"RTN","DGDDDTTM",114,0)
 ;    E-STREET ADDRESS [LINE 3]    (#.335)
"RTN","DGDDDTTM",115,0)
 ;    E-CITY                       (#.336)
"RTN","DGDDDTTM",116,0)
 ;    E-STATE                      (#.337)
"RTN","DGDDDTTM",117,0)
 ;    E-ZIP CODE                   (#.338)
"RTN","DGDDDTTM",118,0)
 ;    E-EMER. CONTACT SAME AS NOK? (#.3305)
"RTN","DGDDDTTM",119,0)
 ;    E-ZIP+4                      (#.2201)
"RTN","DGDDDTTM",120,0)
 ;    E-PHONE NUMBER               (#.339)
"RTN","DGDDDTTM",121,0)
 ;    E-WORK PHONE NUMBER          (#.33011)
"RTN","DGDDDTTM",122,0)
 ;
"RTN","DGDDDTTM",123,0)
 N DGIEN,DATA S DATA(.33012)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",124,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",125,0)
 Q
"RTN","DGDDDTTM",126,0)
 ;
"RTN","DGDDDTTM",127,0)
ECON2 ; PATIENT File #2 Record Index: ADTTM6
"RTN","DGDDDTTM",128,0)
 ;
"RTN","DGDDDTTM",129,0)
 ; This code updates the E2-CONTACT CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",130,0)
 ; of the following Secondary Emergency Contact related data changes
"RTN","DGDDDTTM",131,0)
 ; for a patient:
"RTN","DGDDDTTM",132,0)
 ;
"RTN","DGDDDTTM",133,0)
 ;    E2-NAME OF SECONDARY CONTACT (#.3311)
"RTN","DGDDDTTM",134,0)
 ;    E2-RELATIONSHIP TO PATIENT   (#.3312)
"RTN","DGDDDTTM",135,0)
 ;    E2-STREET ADDRESS [LINE 1]   (#.3313)
"RTN","DGDDDTTM",136,0)
 ;    E2-STREET ADDRESS [LINE 2]   (#.3314)
"RTN","DGDDDTTM",137,0)
 ;    E2-STREET ADDRESS [LINE 3]   (#.3315)
"RTN","DGDDDTTM",138,0)
 ;    E2-CITY                      (#.3316)
"RTN","DGDDDTTM",139,0)
 ;    E2-STATE                     (#.3317)
"RTN","DGDDDTTM",140,0)
 ;    E2-ZIP CODE                  (#.3318)
"RTN","DGDDDTTM",141,0)
 ;    E2-ZIP+4                     (#.2204)
"RTN","DGDDDTTM",142,0)
 ;    E2-PHONE NUMBER              (#.3319)
"RTN","DGDDDTTM",143,0)
 ;    E2-WORK PHONE NUMBER         (#.331011)
"RTN","DGDDDTTM",144,0)
 ;
"RTN","DGDDDTTM",145,0)
 N DGIEN,DATA S DATA(.33112)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",146,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",147,0)
 Q
"RTN","DGDDDTTM",148,0)
 ;
"RTN","DGDDDTTM",149,0)
DESIG ; PATIENT File #2 Record Index: ADTTM7
"RTN","DGDDDTTM",150,0)
 ;
"RTN","DGDDDTTM",151,0)
 ; This code updates the DESIGNEE CHANGE DATE/TIME field when any
"RTN","DGDDDTTM",152,0)
 ; of the following Designee related data changes for a patient:
"RTN","DGDDDTTM",153,0)
 ;
"RTN","DGDDDTTM",154,0)
 ;    D-NAME OF DESIGNEE        (#.341)
"RTN","DGDDDTTM",155,0)
 ;    D-RELATIONSHIP TO PATIENT (#.342)
"RTN","DGDDDTTM",156,0)
 ;    D-STREET ADDRESS [LINE 1] (#.343)
"RTN","DGDDDTTM",157,0)
 ;    D-STREET ADDRESS [LINE 2] (#.344)
"RTN","DGDDDTTM",158,0)
 ;    D-STREET ADDRESS [LINE 3] (#.345)
"RTN","DGDDDTTM",159,0)
 ;    D-CITY                    (#.346)
"RTN","DGDDDTTM",160,0)
 ;    D-STATE                   (#.347)
"RTN","DGDDDTTM",161,0)
 ;    D-ZIP CODE                (#.348)
"RTN","DGDDDTTM",162,0)
 ;    D-DESIGNEE SAME AS NOK?   (#.3405)
"RTN","DGDDDTTM",163,0)
 ;    D-ZIP+4                   (#.2202)
"RTN","DGDDDTTM",164,0)
 ;    D-PHONE NUMBER            (#.349)
"RTN","DGDDDTTM",165,0)
 ;    D-WORK PHONE NUMBER       (#.34011)
"RTN","DGDDDTTM",166,0)
 ;
"RTN","DGDDDTTM",167,0)
 N DGIEN,DATA S DATA(.3412)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",168,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",169,0)
 Q
"RTN","DGDDDTTM",170,0)
 ;
"RTN","DGDDDTTM",171,0)
 ; DG*5.3*941; JAM; Added tag RES for Residential Address 
"RTN","DGDDDTTM",172,0)
RES ; PATIENT File #2 Record Index: ADTTM8
"RTN","DGDDDTTM",173,0)
 ; 
"RTN","DGDDDTTM",174,0)
 ; This code updates the RESIDENTIAL ADDR CHANGE DT/TM field when any
"RTN","DGDDDTTM",175,0)
 ; of the following Residential Address related data changes for a
"RTN","DGDDDTTM",176,0)
 ; patient:
"RTN","DGDDDTTM",177,0)
 ;
"RTN","DGDDDTTM",178,0)
 ;    RESIDENTIAL STREET [LINE 1]  (#.1151)
"RTN","DGDDDTTM",179,0)
 ;    RESIDENTIAL STREET [LINE 2]  (#.1152)
"RTN","DGDDDTTM",180,0)
 ;    RESIDENTIAL STREET [LINE 3]  (#.1153)
"RTN","DGDDDTTM",181,0)
 ;    RESIDENTIAL CITY             (#.1154)
"RTN","DGDDDTTM",182,0)
 ;    RESIDENTIAL STATE            (#.1155)
"RTN","DGDDDTTM",183,0)
 ;    RESIDENTIAL ZIP+4            (#.1156)
"RTN","DGDDDTTM",184,0)
 ;    RESIDENTIAL PROVINCE         (#.11571)
"RTN","DGDDDTTM",185,0)
 ;    RESIDENTIAL POSTAL CODE      (#.11572)
"RTN","DGDDDTTM",186,0)
 ;    RESIDENTIAL COUNTRY          (#.11573)
"RTN","DGDDDTTM",187,0)
 ;
"RTN","DGDDDTTM",188,0)
 Q:$G(DGRONUPD)=1  ;Suppress update for ROM (set in routine DGROHLR1)
"RTN","DGDDDTTM",189,0)
 N DGIEN,DATA S DATA(.1158)=$$NOW^XLFDT(),DGIEN=DA
"RTN","DGDDDTTM",190,0)
 I $$UPD^DGENDBS(2,.DGIEN,.DATA)
"RTN","DGDDDTTM",191,0)
 Q
"RTN","DGREGAED")
0^12^B43930519
"RTN","DGREGAED",1,0)
DGREGAED ;ALB/DW/PHH,BAJ,TDM,JAM - Address Edit API ;02 May 2017  8:33 AM
"RTN","DGREGAED",2,0)
 ;;5.3;Registration;**522,560,658,730,688,808,915,941**;Aug 13, 1993;Build 73
"RTN","DGREGAED",3,0)
 ;;
"RTN","DGREGAED",4,0)
 ;; **688** Modifications for Country and Foreign address
"RTN","DGREGAED",5,0)
 ;; **915** Make DFN optional in case one is not established yet
"RTN","DGREGAED",6,0)
 ;
"RTN","DGREGAED",7,0)
EN(DFN,FLG,SRC,DGRET) ;Entry point
"RTN","DGREGAED",8,0)
 ;Input: 
"RTN","DGREGAED",9,0)
 ;  DFN (optional) - Internal Entry # of Patient File (#2)
"RTN","DGREGAED",10,0)
 ;                   If not supplied then nothing filed or defaulted
"RTN","DGREGAED",11,0)
 ;  FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
"RTN","DGREGAED",12,0)
 ;    FLG(1) - if 1 let user edit phone numbers (field #.131 and #.132)
"RTN","DGREGAED",13,0)
 ;    FLG(2) - if 1 display before & after address for user confirmation
"RTN","DGREGAED",14,0)
 ;  DGRET - if passed by reference will contain address info array
"RTN","DGREGAED",15,0)
 K EASZIPLK,DGRET
"RTN","DGREGAED",16,0)
 N DGINPUT,DGCMP,ICNTRY,CNTRY,FORGN,PSTR,OLDC
"RTN","DGREGAED",17,0)
 N I,X,Y
"RTN","DGREGAED",18,0)
 S DFN=+$G(DFN)
"RTN","DGREGAED",19,0)
 ;I ($G(DFN)'?.N) Q
"RTN","DGREGAED",20,0)
 S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2))
"RTN","DGREGAED",21,0)
 D GETOLD(.DGCMP,DFN)
"RTN","DGREGAED",22,0)
 S CNTRY="",ICNTRY=$S(DFN:$P($G(^DPT(DFN,.11)),"^",10),1:"")
"RTN","DGREGAED",23,0)
 I ICNTRY="" S ICNTRY=1  ;default country is USA if NULL
"RTN","DGREGAED",24,0)
 S OLDC=DGCMP("OLD",.1173),FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,.1173,.CNTRY) I FORGN=-1 Q
"RTN","DGREGAED",25,0)
 S FSTR=$$INPT1(FORGN,.PSTR)      ;set up field string of address prompts
"RTN","DGREGAED",26,0)
 S DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR,CNTRY) I $G(DGINPUT)=-1 Q
"RTN","DGREGAED",27,0)
 I 'DFN M DGRET=DGINPUT Q
"RTN","DGREGAED",28,0)
 I $G(FLG(2))=1 D COMPARE(.DGINPUT,.DGCMP,.FLG)
"RTN","DGREGAED",29,0)
 I '$$CONFIRM() W !,"Change aborted." D EOP Q
"RTN","DGREGAED",30,0)
 N DGPRIOR
"RTN","DGREGAED",31,0)
 D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
"RTN","DGREGAED",32,0)
 D SAVE(.DGINPUT,DFN,FSTR,FORGN) I $G(SRC)="",+$G(DGNEW) Q
"RTN","DGREGAED",33,0)
 Q:'$$FILEYN^DGADDUTL(.DGPRIOR,.DGINPUT)
"RTN","DGREGAED",34,0)
 D GETUPDTS^DGADDUTL(DFN,.DGINPUT)
"RTN","DGREGAED",35,0)
 D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGINPUT)
"RTN","DGREGAED",36,0)
 Q
"RTN","DGREGAED",37,0)
INPUT(DGINPUT,DFN,FSTR,CNTRY) ;Let user input address changes
"RTN","DGREGAED",38,0)
 ;Output: DGINPUT(field#)=external^internal(if any)
"RTN","DGREGAED",39,0)
 N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L
"RTN","DGREGAED",40,0)
 F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L),DGINPUT(DGN)="" Q:DGINPUT=-1  D
"RTN","DGREGAED",41,0)
 . I $$SKIP(DGN,.DGINPUT,.FLG) Q
"RTN","DGREGAED",42,0)
 . I DGN=.1112 D ZIPINP(.DGINPUT,DFN) Q
"RTN","DGREGAED",43,0)
 . I '$$READ(DFN,DGN,.Y) S DGINPUT=-1 Q
"RTN","DGREGAED",44,0)
 . I DGN=.121 S Y=$G(Y) D  Q
"RTN","DGREGAED",45,0)
 .. I Y="",DGINPUT(DGN)="" Q
"RTN","DGREGAED",46,0)
 .. I DFN,$P(Y,U)=$$GET1^DIQ(2,DFN_",",DGN,"I") S DGINPUT(DGN)=$$GET1^DIQ(2,DFN_",",DGN)_U_$P(Y,U) Q
"RTN","DGREGAED",47,0)
 .. S DGINPUT(DGN)=$P(Y(0),U)_U_Y
"RTN","DGREGAED",48,0)
 . S DGINPUT(DGN)=$G(Y)
"RTN","DGREGAED",49,0)
 I DGINPUT'=-1 S DGINPUT(.1173)=CNTRY_"^"_$O(^HL(779.004,"B",CNTRY,""))
"RTN","DGREGAED",50,0)
 Q
"RTN","DGREGAED",51,0)
GETOLD(DGCMP,DFN) ;populate array with existing address info
"RTN","DGREGAED",52,0)
 N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,COUNTRY
"RTN","DGREGAED",53,0)
 S CFORGN=0
"RTN","DGREGAED",54,0)
 ; get current country
"RTN","DGREGAED",55,0)
 ; If current country is NULL it is old data
"RTN","DGREGAED",56,0)
 ; Leave it NULL here because this is not an edit funtion
"RTN","DGREGAED",57,0)
 S CCIEN=$S(DFN:$$GET1^DIQ(2,DFN_",","COUNTRY","I"),1:"")
"RTN","DGREGAED",58,0)
 ;I CCIEN="" S CCIEN=$O(^HL(779.004,"D","UNITED STATES",""))
"RTN","DGREGAED",59,0)
 S CFORGN=$$FORIEN^DGADDUTL(CCIEN)
"RTN","DGREGAED",60,0)
 ;get current address fields and xlate to ^DIQ format
"RTN","DGREGAED",61,0)
 S CFSTR=$$INPT1(CFORGN),CFSTR=$TR(CFSTR,",",";")
"RTN","DGREGAED",62,0)
 ; Domestic data needs some extra fields
"RTN","DGREGAED",63,0)
 I 'CFORGN S CFSTR=CFSTR_";.114;.115;.117"
"RTN","DGREGAED",64,0)
 I DFN D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR")
"RTN","DGREGAED",65,0)
 F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E"))
"RTN","DGREGAED",66,0)
 S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY"
"RTN","DGREGAED",67,0)
 S DGCMP("OLD",.1173)=COUNTRY_"^"_CCIEN
"RTN","DGREGAED",68,0)
 I 'CFORGN D
"RTN","DGREGAED",69,0)
 . S DGCIEN=$G(DGCURR(2,DFN_",",.117,"I"))
"RTN","DGREGAED",70,0)
 . S DGST=$G(DGCURR(2,DFN_",",.115,"I"))
"RTN","DGREGAED",71,0)
 . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
"RTN","DGREGAED",72,0)
 . I DGCNTY=-1 S DGCNTY=""
"RTN","DGREGAED",73,0)
 . S DGCMP("OLD",.117)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3)
"RTN","DGREGAED",74,0)
 Q
"RTN","DGREGAED",75,0)
 ;
"RTN","DGREGAED",76,0)
COMPARE(DGINPUT,DGCMP,FLG) ;Display before & after address fields.
"RTN","DGREGAED",77,0)
 N DGM
"RTN","DGREGAED",78,0)
 M DGCMP("NEW")=DGINPUT
"RTN","DGREGAED",79,0)
 F DGM="OLD","NEW" D
"RTN","DGREGAED",80,0)
 . I DGCMP(DGM,.1173)]"",$$FORIEN^DGADDUTL($P(DGCMP(DGM,.1173),U,2)) D DISPFGN(.DGCMP,DGM,.FLG) Q
"RTN","DGREGAED",81,0)
 . I DGM="NEW" D
"RTN","DGREGAED",82,0)
 . . S DGCNTY=$P($G(DGCMP("NEW",.117)),U)_" "_$P($G(DGCMP("NEW",.117)),U,3)
"RTN","DGREGAED",83,0)
 . . S DGCMP("NEW",.117)=DGCNTY
"RTN","DGREGAED",84,0)
 . . I ($L(DGCMP("NEW",.1112))>5)&($P(DGCMP("NEW",.1112),"-",2)="") S DGCMP("NEW",.1112)=$E(DGCMP("NEW",.1112),1,5)_"-"_$E(DGCMP("NEW",.1112),6,9)
"RTN","DGREGAED",85,0)
 . D DISPUS(.DGCMP,DGM,.FLG)
"RTN","DGREGAED",86,0)
 Q
"RTN","DGREGAED",87,0)
 ;
"RTN","DGREGAED",88,0)
DISPUS(DGCMP,DGM,FLG) ;tag to display US data
"RTN","DGREGAED",89,0)
 N DGCNTRY
"RTN","DGREGAED",90,0)
 W !,?2,"[",DGM," ADDRESS]"
"RTN","DGREGAED",91,0)
 W ?16,$P($G(DGCMP(DGM,.111)),U)
"RTN","DGREGAED",92,0)
 I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U)
"RTN","DGREGAED",93,0)
 I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U)
"RTN","DGREGAED",94,0)
 W !,?16,$P($G(DGCMP(DGM,.114)),U)
"RTN","DGREGAED",95,0)
 W:($P($G(DGCMP(DGM,.114)),U)'="")!($P($G(DGCMP(DGM,.115)),U)'="") ","
"RTN","DGREGAED",96,0)
 W $P($G(DGCMP(DGM,.115)),U)
"RTN","DGREGAED",97,0)
 W " ",$G(DGCMP(DGM,.1112))
"RTN","DGREGAED",98,0)
 S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.1173)),U,2))
"RTN","DGREGAED",99,0)
 I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY
"RTN","DGREGAED",100,0)
 I $P($G(DGCMP(DGM,.117)),U)'="" W !,?6,"  County: ",$P($G(DGCMP(DGM,.117)),U)
"RTN","DGREGAED",101,0)
 I $G(FLG(1))=1 D
"RTN","DGREGAED",102,0)
 . W !,?6,"   Phone: ",?16,$P($G(DGCMP(DGM,.131)),U)
"RTN","DGREGAED",103,0)
 . W !,?6,"  Office: ",?16,$P($G(DGCMP(DGM,.132)),U)
"RTN","DGREGAED",104,0)
 W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U)
"RTN","DGREGAED",105,0)
 W !
"RTN","DGREGAED",106,0)
 Q
"RTN","DGREGAED",107,0)
 ;
"RTN","DGREGAED",108,0)
DISPFGN(DGCMP,DGM,FLG) ;tag to display Foreign data
"RTN","DGREGAED",109,0)
 N DGCNTRY
"RTN","DGREGAED",110,0)
 W !,?2,"[",DGM," ADDRESS]"
"RTN","DGREGAED",111,0)
 W ?16,$P($G(DGCMP(DGM,.111)),U)
"RTN","DGREGAED",112,0)
 I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U)
"RTN","DGREGAED",113,0)
 I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U)
"RTN","DGREGAED",114,0)
 W !,?16,$P($G(DGCMP(DGM,.1172)),U)_" "_$P($G(DGCMP(DGM,.114)),U)_" "_$P($G(DGCMP(DGM,.1171)),U)
"RTN","DGREGAED",115,0)
 S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.1173)),U,2))
"RTN","DGREGAED",116,0)
 S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY)
"RTN","DGREGAED",117,0)
 I DGCNTRY]"" W !?16,DGCNTRY
"RTN","DGREGAED",118,0)
 I $G(FLG(1))=1 D
"RTN","DGREGAED",119,0)
 . W !,?6,"   Phone: ",?16,$P($G(DGCMP(DGM,.131)),U)
"RTN","DGREGAED",120,0)
 . W !,?6,"  Office: ",?16,$P($G(DGCMP(DGM,.132)),U)
"RTN","DGREGAED",121,0)
 W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U)
"RTN","DGREGAED",122,0)
 W !
"RTN","DGREGAED",123,0)
 Q
"RTN","DGREGAED",124,0)
 ;
"RTN","DGREGAED",125,0)
CONFIRM() ;Confirm if user wants to save the change
"RTN","DGREGAED",126,0)
 N DIR,X,Y,DTOUT,DUOUT,DIROUT
"RTN","DGREGAED",127,0)
 S DIR(0)="Y"
"RTN","DGREGAED",128,0)
 S DIR("A")="Are you sure that you want to save the above changes"
"RTN","DGREGAED",129,0)
 S DIR("?")="Please answer Y for YES or N for NO."
"RTN","DGREGAED",130,0)
 D ^DIR
"RTN","DGREGAED",131,0)
 I $D(DTOUT)!($G(Y)=0) Q 0
"RTN","DGREGAED",132,0)
 I $D(DUOUT)!$D(DIROUT) Q 0
"RTN","DGREGAED",133,0)
 Q 1
"RTN","DGREGAED",134,0)
SAVE(DGINPUT,DFN,FSTR,FORGN) ;Save changes
"RTN","DGREGAED",135,0)
 N DGN,DGER,DGM,L,DATA
"RTN","DGREGAED",136,0)
 S DGER=0
"RTN","DGREGAED",137,0)
 ; need to get the country code into the DGINPUT array
"RTN","DGREGAED",138,0)
 ; if it's a domestic address, we have to add in CITY,STATE & COUNTY
"RTN","DGREGAED",139,0)
 S FSTR=FSTR_$S('FORGN:",.114,.115,.117,.1173",1:",.1173")
"RTN","DGREGAED",140,0)
 F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) D
"RTN","DGREGAED",141,0)
 . I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) Q
"RTN","DGREGAED",142,0)
 . N DGCODE,DGNAME,FDA,MSG
"RTN","DGREGAED",143,0)
 . S DGCODE=$P($G(DGINPUT(DGN)),U,2)
"RTN","DGREGAED",144,0)
 . S DGNAME=$P($G(DGINPUT(DGN)),U)
"RTN","DGREGAED",145,0)
 . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME)
"RTN","DGREGAED",146,0)
 . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG")
"RTN","DGREGAED",147,0)
 . I $D(MSG) D
"RTN","DGREGAED",148,0)
 .. S DGM="",DGER=1
"RTN","DGREGAED",149,0)
 .. W !,"Please review the saved changes!!",!
"RTN","DGREGAED",150,0)
 .. F  S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM=""  D
"RTN","DGREGAED",151,0)
 ... W $G(MSG("DIERR",1,"TEXT",DGM))
"RTN","DGREGAED",152,0)
 I $G(DGER)=0 W !,"Change saved." D
"RTN","DGREGAED",153,0)
 .;JAM, Set the CASS value for Perm Mailing Address ;DG*5.3*941
"RTN","DGREGAED",154,0)
 . S DATA(.1118)="NC"
"RTN","DGREGAED",155,0)
 . I $$UPD^DGENDBS(2,DFN,.DATA)
"RTN","DGREGAED",156,0)
 D EOP
"RTN","DGREGAED",157,0)
 Q
"RTN","DGREGAED",158,0)
READ(DFN,DGN,Y) ;Read input, return success
"RTN","DGREGAED",159,0)
 N SUCCESS,DIR,DA,DTOUT,DUOUT,DIROUT,L,POP
"RTN","DGREGAED",160,0)
 S SUCCESS=1,POP=0
"RTN","DGREGAED",161,0)
 F L=0:0 D  Q:POP
"RTN","DGREGAED",162,0)
 . S DIR(0)=2_","_DGN
"RTN","DGREGAED",163,0)
 . I DFN S DA=DFN
"RTN","DGREGAED",164,0)
 . D ^DIR
"RTN","DGREGAED",165,0)
 . I $D(DTOUT) S POP=1,SUCCESS=0 Q
"RTN","DGREGAED",166,0)
 . I $D(DUOUT)!$D(DIROUT) D UPCT Q
"RTN","DGREGAED",167,0)
 . S POP=1
"RTN","DGREGAED",168,0)
 Q SUCCESS
"RTN","DGREGAED",169,0)
INPT1(FORGN,PSTR) ; first address input prompts
"RTN","DGREGAED",170,0)
 N FSTR
"RTN","DGREGAED",171,0)
 ; PSTR is the full set of fields domestic & foreign combined
"RTN","DGREGAED",172,0)
 ; FSTR is the set of fields depending on Country code
"RTN","DGREGAED",173,0)
 S PSTR=".111,.112,.113,.114,.115,.117,.1112,.1171,.1172,.1173,.131,.132,.121"
"RTN","DGREGAED",174,0)
 S FSTR=".111,.112,.113,.1112,.131,.132,.121"
"RTN","DGREGAED",175,0)
 I FORGN S FSTR=".111,.112,.113,.114,.1171,.1172,.131,.132,.121"
"RTN","DGREGAED",176,0)
 Q FSTR
"RTN","DGREGAED",177,0)
ZIPINP(DGINPUT,DFN) ; get ZIP+4 input
"RTN","DGREGAED",178,0)
 N DGR
"RTN","DGREGAED",179,0)
 D EN^DGREGAZL(.DGR,DFN)
"RTN","DGREGAED",180,0)
 I $G(DGR)=-1 Q
"RTN","DGREGAED",181,0)
 M DGINPUT=DGR
"RTN","DGREGAED",182,0)
 Q
"RTN","DGREGAED",183,0)
SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step
"RTN","DGREGAED",184,0)
 N SKIP
"RTN","DGREGAED",185,0)
 S SKIP=0
"RTN","DGREGAED",186,0)
 I ($G(DGINPUT(.111))="")&((DGN=.112)!(DGN=.113)) S SKIP=1
"RTN","DGREGAED",187,0)
 I ($G(DGINPUT(.112))="")&(DGN=.113) S SKIP=1
"RTN","DGREGAED",188,0)
 I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) S SKIP=1
"RTN","DGREGAED",189,0)
 Q SKIP
"RTN","DGREGAED",190,0)
EOP ;End of page prompt
"RTN","DGREGAED",191,0)
 N DIR,DTOUT,DUOUT,DIROUT,X,Y
"RTN","DGREGAED",192,0)
 S DIR(0)="E"
"RTN","DGREGAED",193,0)
 S DIR("A")="Press ENTER to continue"
"RTN","DGREGAED",194,0)
 D ^DIR
"RTN","DGREGAED",195,0)
 Q
"RTN","DGREGAED",196,0)
UPCT ;Indicate "^" or "^^" are unacceptable inputs.
"RTN","DGREGAED",197,0)
 W !,"EXIT NOT ALLOWED ??"
"RTN","DGREGAED",198,0)
 Q
"RTN","DGREGCOP")
0^11^B2145529
"RTN","DGREGCOP",1,0)
DGREGCOP ;ALB/CLT - COPY RESIDENTIAL TO PERM AND PERM TO RESIDENTIAL ADDRESS ;23 May 2017  1:38 PM
"RTN","DGREGCOP",2,0)
 ;;5.3;Registration;**941**;Aug 13, 1993;Build 73
"RTN","DGREGCOP",3,0)
 ;
"RTN","DGREGCOP",4,0)
EN(DFN) ;PRIMARY ENTRY POINT
"RTN","DGREGCOP",5,0)
R2P(DFN) ;RESIDENTIAL TO PERMANENT ADDRESS COPY
"RTN","DGREGCOP",6,0)
 N DGAR,I,DGZIP,IENS,FDA
"RTN","DGREGCOP",7,0)
 S DGAR=^DPT(DFN,.115)
"RTN","DGREGCOP",8,0)
 F I=1:1:10,19 S DGAR(I)=$P(^DPT(DFN,.115),U,I)
"RTN","DGREGCOP",9,0)
 K ^DPT(DFN,.11)
"RTN","DGREGCOP",10,0)
 S DGZIP=$E(DGAR(6),1,5)
"RTN","DGREGCOP",11,0)
 S IENS=DFN_","
"RTN","DGREGCOP",12,0)
 S FDA(2,IENS,.111)=DGAR(1)
"RTN","DGREGCOP",13,0)
 S FDA(2,IENS,.112)=DGAR(2)
"RTN","DGREGCOP",14,0)
 S FDA(2,IENS,.113)=DGAR(3)
"RTN","DGREGCOP",15,0)
 S FDA(2,IENS,.114)=DGAR(4)
"RTN","DGREGCOP",16,0)
 S FDA(2,IENS,.115)=DGAR(5)
"RTN","DGREGCOP",17,0)
 S FDA(2,IENS,.116)=DGZIP
"RTN","DGREGCOP",18,0)
 S FDA(2,IENS,.1112)=DGAR(6)
"RTN","DGREGCOP",19,0)
 S FDA(2,IENS,.117)=DGAR(7)
"RTN","DGREGCOP",20,0)
 S FDA(2,IENS,.1171)=DGAR(8)
"RTN","DGREGCOP",21,0)
 S FDA(2,IENS,.1172)=DGAR(9)
"RTN","DGREGCOP",22,0)
 S FDA(2,IENS,.1173)=DGAR(10)
"RTN","DGREGCOP",23,0)
 S FDA(2,IENS,.1118)=DGAR(19)
"RTN","DGREGCOP",24,0)
 D FILE^DIE("","FDA")
"RTN","DGREGCOP",25,0)
 Q
"RTN","DGREGCOP",26,0)
P2R(DFN) ;PERMANENT TO RESIDENTIAL ADDRESS COPY
"RTN","DGREGCOP",27,0)
 N DGAR,I,IENS,FDA
"RTN","DGREGCOP",28,0)
 S DGAR=^DPT(DFN,.11)
"RTN","DGREGCOP",29,0)
 F I=1:1:12,18 S DGAR(I)=$P(DGAR,U,I)
"RTN","DGREGCOP",30,0)
 K ^DPT(DFN,.115)
"RTN","DGREGCOP",31,0)
 S IENS=DFN_","
"RTN","DGREGCOP",32,0)
 S FDA(2,IENS,.1151)=DGAR(1)
"RTN","DGREGCOP",33,0)
 S FDA(2,IENS,.1152)=DGAR(2)
"RTN","DGREGCOP",34,0)
 S FDA(2,IENS,.1153)=DGAR(3)
"RTN","DGREGCOP",35,0)
 S FDA(2,IENS,.1154)=DGAR(4)
"RTN","DGREGCOP",36,0)
 S FDA(2,IENS,.1155)=DGAR(5)
"RTN","DGREGCOP",37,0)
 S FDA(2,IENS,.1156)=DGAR(12)
"RTN","DGREGCOP",38,0)
 S FDA(2,IENS,.1157)=DGAR(7)
"RTN","DGREGCOP",39,0)
 S FDA(2,IENS,.11571)=DGAR(8)
"RTN","DGREGCOP",40,0)
 S FDA(2,IENS,.11572)=DGAR(9)
"RTN","DGREGCOP",41,0)
 S FDA(2,IENS,.11573)=DGAR(10)
"RTN","DGREGCOP",42,0)
 S FDA(2,IENS,.1159)=DGAR(18)
"RTN","DGREGCOP",43,0)
 D FILE^DIE("","FDA")
"RTN","DGREGCOP",44,0)
 Q
"RTN","DGREGCP1")
0^9^B29343646
"RTN","DGREGCP1",1,0)
DGREGCP1 ;ALB/CLT - ADDRESS COPY UTILITIES ;18 May 2017  2:54 PM
"RTN","DGREGCP1",2,0)
 ;;5.3;Registration;**941**;Aug 13, 1993;Build 73
"RTN","DGREGCP1",3,0)
 ;
"RTN","DGREGCP1",4,0)
RESDISP(DFN) ;DISPLAY THE RESIDENTIAL ADDRESS
"RTN","DGREGCP1",5,0)
 N DGA1,DGA2,DGA3,DGA4,DGA9,DGA10,DGA1315,DGZIP
"RTN","DGREGCP1",6,0)
 N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
"RTN","DGREGCP1",7,0)
 W !,"Residential Address to copy to the Permanent Mailing Address:",!
"RTN","DGREGCP1",8,0)
 I $G(^DPT(DFN,.115))="" D  Q
"RTN","DGREGCP1",9,0)
 .W !?5,"NO RESIDENTIAL ADDRESS"
"RTN","DGREGCP1",10,0)
 ;DISPLAY THE CURRENT RESIDENTIAL ADDRESS
"RTN","DGREGCP1",11,0)
 S DGXX=^DPT(DFN,.115),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4)
"RTN","DGREGCP1",12,0)
 S DGA9=$P(DGXX,"^",9)
"RTN","DGREGCP1",13,0)
 S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10=""
"RTN","DGREGCP1",14,0)
 S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10)
"RTN","DGREGCP1",15,0)
 I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
"RTN","DGREGCP1",16,0)
 W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3
"RTN","DGREGCP1",17,0)
 ;FORDISP ;DISPLAY FOREIGN ADDRESS
"RTN","DGREGCP1",18,0)
 I DGA1="" W !
"RTN","DGREGCP1",19,0)
 I 'DGFORGN D
"RTN","DGREGCP1",20,0)
 . W ?43,"County: "
"RTN","DGREGCP1",21,0)
 . I $P(DGXX,U,5)=""!($P(DGXX,U,7)="") W "UNKNOWN" Q
"RTN","DGREGCP1",22,0)
 . I $P(DGXX,U,7)'="" I $D(^DIC(5,$P(DGXX,U,5),1,$P(DGXX,U,7),0)) D
"RTN","DGREGCP1",23,0)
 .. S DGST=$P(DGXX,U,5),DGCIEN=$P(DGXX,U,7)
"RTN","DGREGCP1",24,0)
 .. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")"
"RTN","DGREGCP1",25,0)
 E  D
"RTN","DGREGCP1",26,0)
 . W ?43,"Province: "
"RTN","DGREGCP1",27,0)
 . W $S($P(DGXX,U,8)'="":$P(DGXX,U,8),1:"UNKNOWN")
"RTN","DGREGCP1",28,0)
 I DGFORGN W !?3,DGA9_" "_DGA4
"RTN","DGREGCP1",29,0)
 I 'DGFORGN W !?3,DGA4 D
"RTN","DGREGCP1",30,0)
 . I $D(^DIC(5,+$P(^DPT(DFN,.115),"^",5),0)) W ",",$P(^DIC(5,+$P(^DPT(DFN,.115),"^",5),0),"^",2)
"RTN","DGREGCP1",31,0)
 . S DGZIP=$P(^DPT(DFN,.115),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
"RTN","DGREGCP1",32,0)
 . W "  ",DGZIP
"RTN","DGREGCP1",33,0)
 W !?3,DGCNTRY,!
"RTN","DGREGCP1",34,0)
 Q
"RTN","DGREGCP1",35,0)
 ;
"RTN","DGREGCP1",36,0)
PERMDISP(DFN) ;DISPLAY PERMANENT MAILING ADDRESS
"RTN","DGREGCP1",37,0)
 N DGA1,DGA9,DGA10,DGA1315,DGA2,DGA3,DGA4,DGZIP
"RTN","DGREGCP1",38,0)
 N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
"RTN","DGREGCP1",39,0)
 W !,"Permanent Mailing Address to copy to Residential Address:",!
"RTN","DGREGCP1",40,0)
 I $G(^DPT(DFN,.11))="" D  Q
"RTN","DGREGCP1",41,0)
 .W !?5,"NO PERMANENT MAILING ADDRESS"
"RTN","DGREGCP1",42,0)
 ;DISPLAY THE CURRENT PERMANENT MAILING ADDRESS
"RTN","DGREGCP1",43,0)
 S DGXX=^DPT(DFN,.11),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4)
"RTN","DGREGCP1",44,0)
 S DGA9=$P(DGXX,"^",9)
"RTN","DGREGCP1",45,0)
 S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10=""
"RTN","DGREGCP1",46,0)
 S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10)
"RTN","DGREGCP1",47,0)
 I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
"RTN","DGREGCP1",48,0)
 W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3
"RTN","DGREGCP1",49,0)
 ;FORGNCHK ;CHECK FOR FOREIGN ADDRESS
"RTN","DGREGCP1",50,0)
 I DGA1="" W !
"RTN","DGREGCP1",51,0)
 I 'DGFORGN D
"RTN","DGREGCP1",52,0)
 . W ?43,"County: "
"RTN","DGREGCP1",53,0)
 . I $P(DGXX,U,5)=""!($P(DGXX,U,7)="") W "UNKNOWN" Q
"RTN","DGREGCP1",54,0)
 . I $P(DGXX,U,7)'="" I $D(^DIC(5,$P(DGXX,U,5),1,$P(DGXX,U,7),0)) D
"RTN","DGREGCP1",55,0)
 .. S DGST=$P(DGXX,U,5),DGCIEN=$P(DGXX,U,7)
"RTN","DGREGCP1",56,0)
 .. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")"
"RTN","DGREGCP1",57,0)
 E  D
"RTN","DGREGCP1",58,0)
 . W ?43,"Province: "
"RTN","DGREGCP1",59,0)
 . W $S($P(DGXX,U,8)'="":$P(DGXX,U,8),1:"UNKNOWN")
"RTN","DGREGCP1",60,0)
 I DGFORGN W !?3,DGA9_" "_DGA4
"RTN","DGREGCP1",61,0)
 I 'DGFORGN W !?3,DGA4 D
"RTN","DGREGCP1",62,0)
 . I $D(^DIC(5,+$P(^DPT(DFN,.11),"^",5),0)) W ",",$P(^DIC(5,+$P(^DPT(DFN,.11),"^",5),0),"^",2)
"RTN","DGREGCP1",63,0)
 . S DGZIP=$P(^DPT(DFN,.11),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
"RTN","DGREGCP1",64,0)
 . W "  ",DGZIP
"RTN","DGREGCP1",65,0)
 W !?3,DGCNTRY,!
"RTN","DGREGCP1",66,0)
 Q
"RTN","DGREGCP1",67,0)
 ;
"RTN","DGREGCP1",68,0)
RESMVQ(DFN) ;DISPLAY RESIDENTIAL ADDRESS AND QUESTION IF COPY TO PERM IS DESIRED
"RTN","DGREGCP1",69,0)
 I $G(^DPT(DFN,.115))="" Q
"RTN","DGREGCP1",70,0)
 N DIR,X,Y,DTOUT,DUOUT
"RTN","DGREGCP1",71,0)
 S DIR(0)="Y",DIR("A")="Copy the Residential Address to the Permanent Mailing Address",DIR("B")="NO"
"RTN","DGREGCP1",72,0)
 S DIR("?",1)="Enter 'YES' to copy the Residential Address ",DIR("?")="to the Permanent Mailing Address."
"RTN","DGREGCP1",73,0)
 D ^DIR
"RTN","DGREGCP1",74,0)
 I $G(Y)=1 D
"RTN","DGREGCP1",75,0)
 . W !
"RTN","DGREGCP1",76,0)
 . D RESDISP(DFN)
"RTN","DGREGCP1",77,0)
 . S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")=""
"RTN","DGREGCP1",78,0)
 . S DIR("?",1)="If you answer 'YES' the current Residential Address will be copied",DIR("?")="to the Permanent Mailing Address."
"RTN","DGREGCP1",79,0)
 . D ^DIR
"RTN","DGREGCP1",80,0)
 . I $D(DTOUT)!($G(Y)=0) Q
"RTN","DGREGCP1",81,0)
 . I $D(DUOUT)!$D(DIROUT) Q
"RTN","DGREGCP1",82,0)
 . D R2P^DGREGCOP(DFN)
"RTN","DGREGCP1",83,0)
 . W !,"Copy completed."
"RTN","DGREGCP1",84,0)
 . D EOP
"RTN","DGREGCP1",85,0)
 Q
"RTN","DGREGCP1",86,0)
 ;
"RTN","DGREGCP1",87,0)
PERMMVQ(DFN) ;DISPLAY PERMANENT ADDRESS AND QUESTION IF COPY TO RESIDENTIAL IS DESIRED
"RTN","DGREGCP1",88,0)
 ; First check for a valid Permanent Address that can be copied to residential address
"RTN","DGREGCP1",89,0)
 N DGXX,DGA10,DFORGN
"RTN","DGREGCP1",90,0)
 S DGXX=$G(^DPT(DFN,.11))
"RTN","DGREGCP1",91,0)
 ; Quit if nothing in Perm address line 1 field
"RTN","DGREGCP1",92,0)
 I $P(DGXX,"^",1)="" Q
"RTN","DGREGCP1",93,0)
 ; Quit if nothing in Perm address City field
"RTN","DGREGCP1",94,0)
 I $P(DGXX,"^",4)="" Q
"RTN","DGREGCP1",95,0)
 ; Quit if no Perm address zipcode defined for a domestic address
"RTN","DGREGCP1",96,0)
 S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10=""
"RTN","DGREGCP1",97,0)
 S DGFORGN=$$FORIEN^DGADDUTL(DGA10)
"RTN","DGREGCP1",98,0)
 I 'DGFORGN&($P(DGXX,"^",6)="") Q
"RTN","DGREGCP1",99,0)
 ; required address fields exist for copying to Residential address
"RTN","DGREGCP1",100,0)
 ; now check for PO Box or General Delivery address and notify user if not valid address and quit
"RTN","DGREGCP1",101,0)
 N DGADD,DIR,X,Y,DGRESADD,DGRESX
"RTN","DGREGCP1",102,0)
 K DIRUT
"RTN","DGREGCP1",103,0)
 I $$POBOXPM^DGREGCP2(DFN) D  Q
"RTN","DGREGCP1",104,0)
 . W !!?3,*7,"P.O. Box and GENERAL DELIVERY cannot be used in residential address." W !
"RTN","DGREGCP1",105,0)
 . W !,"Because the Permanent Mailing Address line 1 contains P.O. Box"
"RTN","DGREGCP1",106,0)
 . W " or General",!,"Delivery the Permanent Mailing Address cannot be copied to"
"RTN","DGREGCP1",107,0)
 . W !,"the Residential Address."
"RTN","DGREGCP1",108,0)
 . D EOP
"RTN","DGREGCP1",109,0)
 ; Perm address is valid for use as a Residential address
"RTN","DGREGCP1",110,0)
ASK ; 
"RTN","DGREGCP1",111,0)
 W !
"RTN","DGREGCP1",112,0)
 S DIR(0)="Y",DIR("A")="Copy the Permanent Mailing Address to the Residential Address"
"RTN","DGREGCP1",113,0)
 S DIR("?",1)="Answer 'YES' or 'NO'. 'YES' will copy the current Permanent Mailing Address",DIR("?")="to the Residential Address."
"RTN","DGREGCP1",114,0)
 D ^DIR
"RTN","DGREGCP1",115,0)
 I X="Y"!(X="YES") S Y=1,Y(0)="YES"
"RTN","DGREGCP1",116,0)
 I $D(DTOUT)!($G(Y)=0) Q
"RTN","DGREGCP1",117,0)
 I $D(DUOUT)!$D(DIROUT) Q
"RTN","DGREGCP1",118,0)
 I $D(DIRUT) G ASK
"RTN","DGREGCP1",119,0)
 I Y=1 D
"RTN","DGREGCP1",120,0)
 . W !
"RTN","DGREGCP1",121,0)
 . D PERMDISP(DFN) ;; W !! D RESDISP(DFN) W !
"RTN","DGREGCP1",122,0)
 . S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")=""
"RTN","DGREGCP1",123,0)
 . S DIR("?",1)="If you answer 'YES' the current Permanent Mailing Address will be copied",DIR("?")="to the Residential Address."
"RTN","DGREGCP1",124,0)
 . D ^DIR
"RTN","DGREGCP1",125,0)
 . I $D(DTOUT)!($G(Y)=0) Q
"RTN","DGREGCP1",126,0)
 . I $D(DUOUT)!$D(DIROUT) Q
"RTN","DGREGCP1",127,0)
 . D P2R^DGREGCOP(DFN)
"RTN","DGREGCP1",128,0)
 . W !,"Copy completed."
"RTN","DGREGCP1",129,0)
 . D EOP
"RTN","DGREGCP1",130,0)
 Q
"RTN","DGREGCP1",131,0)
EOP ;End of page prompt
"RTN","DGREGCP1",132,0)
 N DIR,DTOUT,DUOUT,DIROUT,X,Y
"RTN","DGREGCP1",133,0)
 S DIR(0)="E"
"RTN","DGREGCP1",134,0)
 S DIR("A")="Press ENTER to continue"
"RTN","DGREGCP1",135,0)
 D ^DIR
"RTN","DGREGCP1",136,0)
 Q
"RTN","DGREGCP2")
0^10^B3251423
"RTN","DGREGCP2",1,0)
DGREGCP2 ;ALB/CLT - ADDRESS UTILITIES ;23 May 2017  1:33 PM
"RTN","DGREGCP2",2,0)
 ;;5.3;Registration;**941**;Aug 13, 1993;Build 73
"RTN","DGREGCP2",3,0)
 ;
"RTN","DGREGCP2",4,0)
POBOXRES(DGADDL1,STATE,CNTRY) ;TEST FOR UNALLOWED PO BOX AND GENERAL DELIVERY FOR RESIDENTIAL ADDRESS
"RTN","DGREGCP2",5,0)
 ; DGADDL1 - The address [LINE 1] text
"RTN","DGREGCP2",6,0)
 ; STATE - Internal State Code
"RTN","DGREGCP2",7,0)
 ; CNTRY - Internal Country Code
"RTN","DGREGCP2",8,0)
 ; returns 1 if PO box/general delivery not allowed for this address
"RTN","DGREGCP2",9,0)
 ; called from DGREGRED for validation of residential address on screen 1.1
"RTN","DGREGCP2",10,0)
 N DGCCHK
"RTN","DGREGCP2",11,0)
 ;  If country/state are allowed to have PO box, quit 0
"RTN","DGREGCP2",12,0)
 I $$OKPO(STATE,CNTRY) Q 0
"RTN","DGREGCP2",13,0)
 S DGCCHK=0
"RTN","DGREGCP2",14,0)
 ; Get result from checking for PO/General Delivery
"RTN","DGREGCP2",15,0)
 I $$ISPO(DGADDL1) S DGCCHK=1
"RTN","DGREGCP2",16,0)
 Q DGCCHK
"RTN","DGREGCP2",17,0)
 ;
"RTN","DGREGCP2",18,0)
POBOXPM(DFN) ;Check for PO Box/General Delivery in Permanent Mailing Address
"RTN","DGREGCP2",19,0)
 ; Returns 1 if Perm address contains PO Box or General delivery (allowing for exceptions)
"RTN","DGREGCP2",20,0)
 I '$D(^DPT(DFN,.11)) Q 0
"RTN","DGREGCP2",21,0)
 N DGRESADD,DGADDL1
"RTN","DGREGCP2",22,0)
 S DGRESADD=^DPT(DFN,.11)
"RTN","DGREGCP2",23,0)
 ; allow certain exceptions for countries/states that allow PO Box
"RTN","DGREGCP2",24,0)
 I $$OKPO($P(DGRESADD,U,5),$P(DGRESADD,U,10)) Q 0
"RTN","DGREGCP2",25,0)
 ; get address line 1
"RTN","DGREGCP2",26,0)
 S DGADDL1=$P(DGRESADD,U,1)
"RTN","DGREGCP2",27,0)
 ; return result from checking for PO/General Delivery
"RTN","DGREGCP2",28,0)
 Q $$ISPO(DGADDL1)
"RTN","DGREGCP2",29,0)
 ;
"RTN","DGREGCP2",30,0)
OKPO(STATE,CNTRY) ;PO BOX CHECK FOR CERTAIN COUNTRIES AND STATES
"RTN","DGREGCP2",31,0)
 ; Returns 1 if the country/state allows for PO box/general delivery
"RTN","DGREGCP2",32,0)
 ; Pass in the state and country codes to check
"RTN","DGREGCP2",33,0)
 ;PO Box and general delivery allowed for:  Veteran's Residential address is Alaska(2) or Hawaii (15)
"RTN","DGREGCP2",34,0)
 ;Veteran resides in one of the United States territories (Guam (state 66), American Samoa (state 60), CNMI (Mariana Islands state 69), 
"RTN","DGREGCP2",35,0)
 ; U.S. Virgin Islands (state 78), and Philippines (country code 167))
"RTN","DGREGCP2",36,0)
 ; Philippines check 
"RTN","DGREGCP2",37,0)
 I CNTRY=167 Q 1
"RTN","DGREGCP2",38,0)
 N DGSTATES
"RTN","DGREGCP2",39,0)
 S DGSTATES="^AS^AK^HI^GU^VI^MP^PH^"
"RTN","DGREGCP2",40,0)
 S STATE="^"_$$GET1^DIQ(5,STATE,1)_"^"
"RTN","DGREGCP2",41,0)
 ; If country=USA, check for allowed states/territories
"RTN","DGREGCP2",42,0)
 I CNTRY=1 I DGSTATES[STATE Q 1
"RTN","DGREGCP2",43,0)
 Q 0
"RTN","DGREGCP2",44,0)
ISPO(DGADDL1) ; check address line for presence of PO Box or General Delivery
"RTN","DGREGCP2",45,0)
 ; Returns 1 if the address line DGADDL1 contains PO/General Delivery
"RTN","DGREGCP2",46,0)
 N DGCCHK
"RTN","DGREGCP2",47,0)
 S DGCCHK=0
"RTN","DGREGCP2",48,0)
 ; strip out leading spaces
"RTN","DGREGCP2",49,0)
 F  QUIT:$E(DGADDL1,1)'=" "  S DGADDL1=$E(DGADDL1,2,$L(DGADDL1))
"RTN","DGREGCP2",50,0)
 ; translate to UPPERCASE and strip out any '.' chars (eg as in P.O. Box)
"RTN","DGREGCP2",51,0)
 S DGADDL1=$TR(DGADDL1,"abcdefghijklmnopqrstuvwxyz.","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
"RTN","DGREGCP2",52,0)
 I $E(DGADDL1,1,3)="PO "!($E(DGADDL1,1,11)="POST OFFICE")!(DGADDL1["GENERAL DELIVERY")!(DGADDL1?1"BOX "1N.ANP)!($E(DGADDL1,1,4)="P O ") S DGCCHK=1
"RTN","DGREGCP2",53,0)
 Q DGCCHK
"RTN","DGREGRED")
0^21^B55962900
"RTN","DGREGRED",1,0)
DGREGRED ;ALB/JAM - Residential Address Edit API ;23 Feb 2018  1:33 PM
"RTN","DGREGRED",2,0)
 ;;5.3;Registration;**941**;Aug 13, 1993;Build 73
"RTN","DGREGRED",3,0)
 ;;
"RTN","DGREGRED",4,0)
 ;
"RTN","DGREGRED",5,0)
EN(DFN,FLG) ;Entry point
"RTN","DGREGRED",6,0)
 ;Input: 
"RTN","DGREGRED",7,0)
 ;  DFN (required) - Internal Entry # of Patient File (#2)
"RTN","DGREGRED",8,0)
 ;  FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
"RTN","DGREGRED",9,0)
 ;    FLG(1) - if 1 let user edit phone numbers (field #.131 and #.132)
"RTN","DGREGRED",10,0)
 ;    FLG(2) - if 1 display before & after address (and phone if FLG(1)=1) for user confirmation
"RTN","DGREGRED",11,0)
 N DGINPUT,DGCMP,ICNTRY,CNTRY,FORGN,PSTR,OLDC,FSTR,BAD
"RTN","DGREGRED",12,0)
 N I,X,Y
"RTN","DGREGRED",13,0)
 I $G(DFN)="" Q
"RTN","DGREGRED",14,0)
 S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2))
"RTN","DGREGRED",15,0)
RETRY  ; Entry point if address must be re-entered
"RTN","DGREGRED",16,0)
 D GETOLD(.DGCMP,DFN)
"RTN","DGREGRED",17,0)
 S CNTRY="",ICNTRY=$S(DFN:$P($G(^DPT(DFN,.115)),"^",10),1:"")
"RTN","DGREGRED",18,0)
 I ICNTRY="" S ICNTRY=1  ;default country is USA if NULL
"RTN","DGREGRED",19,0)
 S OLDC=DGCMP("OLD",.11573),FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,.11573,.CNTRY) I FORGN=-1 Q
"RTN","DGREGRED",20,0)
 K FSTR,PSTR S FSTR=$$INPT1(FORGN,.PSTR)      ;set up field string of address prompts
"RTN","DGREGRED",21,0)
 K DGINPUT S DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR,CNTRY) I $G(DGINPUT)=-1 Q
"RTN","DGREGRED",22,0)
 ; initialize valid address flag
"RTN","DGREGRED",23,0)
 S BAD=0
"RTN","DGREGRED",24,0)
 ; if flag is set, show old and new address 
"RTN","DGREGRED",25,0)
 I FLG(2)=1 D COMPARE(.DGINPUT,.DGCMP)
"RTN","DGREGRED",26,0)
 I '$$CONFIRM("ADDRESS") W !,"Address change aborted." G PHONE    ;Not saving address - go to phone saving process
"RTN","DGREGRED",27,0)
 ; Validate the address fields and set BAD=1 if not valid
"RTN","DGREGRED",28,0)
 I DGINPUT(.1151)=""!(DGINPUT(.1154)="") D  S BAD=1
"RTN","DGREGRED",29,0)
 . I 'FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1], ZIP CODE and CITY fields are required."
"RTN","DGREGRED",30,0)
 . I FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1] and CITY fields are required."
"RTN","DGREGRED",31,0)
 ; If address is valid, next check is for PO Box and General Delivery - 
"RTN","DGREGRED",32,0)
 ;    Pass in LINE 1, State and Country codes
"RTN","DGREGRED",33,0)
 I 'BAD I $$POBOXRES^DGREGCP2(DGINPUT(.1151),$P($G(DGINPUT(.1155)),"^",2),$P(DGINPUT(.11573),"^",2)) D  S BAD=1
"RTN","DGREGRED",34,0)
 . W !!?3,*7,"You cannot enter 'P. O. Box' or 'General Delivery' for a Residential Address."
"RTN","DGREGRED",35,0)
 ; If all Validations passed - save the address
"RTN","DGREGRED",36,0)
 I 'BAD D SAVE(.DGINPUT,DFN,FSTR,FORGN)
"RTN","DGREGRED",37,0)
PHONE ; Process the phone number changes IF FLG(1) = 1
"RTN","DGREGRED",38,0)
 I $G(FLG(1))=1 D
"RTN","DGREGRED",39,0)
 . ; if compare flag is set, display old/new values
"RTN","DGREGRED",40,0)
 . I $G(FLG(2))=1 D COMPAREP(.DGINPUT,.DGCMP)
"RTN","DGREGRED",41,0)
 . I '$$CONFIRM("PHONE") W !,"Phone changes aborted." D EOP
"RTN","DGREGRED",42,0)
 . E  D SAVEPH(.DGINPUT,DFN)
"RTN","DGREGRED",43,0)
 ; Phone number process is completed - go to RETRY if address validation failed
"RTN","DGREGRED",44,0)
 I BAD G RETRY
"RTN","DGREGRED",45,0)
 Q
"RTN","DGREGRED",46,0)
INPUT(DGINPUT,DFN,FSTR,CNTRY) ;Let user input address changes
"RTN","DGREGRED",47,0)
 ; Output: DGINPUT(field#)=external^internal(if any)
"RTN","DGREGRED",48,0)
 N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L
"RTN","DGREGRED",49,0)
 F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L),DGINPUT(DGN)="" Q:DGINPUT=-1  D
"RTN","DGREGRED",50,0)
 . I $$SKIP(DGN,.DGINPUT,.FLG) Q
"RTN","DGREGRED",51,0)
 . I DGN=.1156 D ZIPINP(.DGINPUT,DFN) Q
"RTN","DGREGRED",52,0)
 . I '$$READ(DFN,DGN,.Y) S DGINPUT=-1 Q
"RTN","DGREGRED",53,0)
 . S DGINPUT(DGN)=$G(Y)
"RTN","DGREGRED",54,0)
 I DGINPUT'=-1 S DGINPUT(.11573)=CNTRY_"^"_$O(^HL(779.004,"B",CNTRY,""))
"RTN","DGREGRED",55,0)
 Q
"RTN","DGREGRED",56,0)
GETOLD(DGCMP,DFN) ;populate array with existing address info
"RTN","DGREGRED",57,0)
 K DGCMP
"RTN","DGREGRED",58,0)
 N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,COUNTRY
"RTN","DGREGRED",59,0)
 S CFORGN=0
"RTN","DGREGRED",60,0)
 ; get current country
"RTN","DGREGRED",61,0)
 S CCIEN=$S(DFN:$$GET1^DIQ(2,DFN_",",.11573,"I"),1:"")
"RTN","DGREGRED",62,0)
 S CFORGN=$$FORIEN^DGADDUTL(CCIEN)
"RTN","DGREGRED",63,0)
 ; get current address fields and xlate to ^DIQ format
"RTN","DGREGRED",64,0)
 S CFSTR=$$INPT1(CFORGN),CFSTR=$TR(CFSTR,",",";")
"RTN","DGREGRED",65,0)
 ; Domestic data needs some extra fields
"RTN","DGREGRED",66,0)
 I 'CFORGN S CFSTR=CFSTR_";.1154;.1155;.1157"
"RTN","DGREGRED",67,0)
 I DFN D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR")
"RTN","DGREGRED",68,0)
 F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E"))
"RTN","DGREGRED",69,0)
 S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY"
"RTN","DGREGRED",70,0)
 S DGCMP("OLD",.11573)=COUNTRY_"^"_CCIEN
"RTN","DGREGRED",71,0)
 I 'CFORGN D
"RTN","DGREGRED",72,0)
 . S DGCIEN=$G(DGCURR(2,DFN_",",.1157,"I"))
"RTN","DGREGRED",73,0)
 . S DGST=$G(DGCURR(2,DFN_",",.1155,"I"))
"RTN","DGREGRED",74,0)
 . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
"RTN","DGREGRED",75,0)
 . I DGCNTY=-1 S DGCNTY=""
"RTN","DGREGRED",76,0)
 . S DGCMP("OLD",.1157)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3)
"RTN","DGREGRED",77,0)
 Q
"RTN","DGREGRED",78,0)
 ;
"RTN","DGREGRED",79,0)
COMPARE(DGINPUT,DGCMP) ;Display before & after address fields.
"RTN","DGREGRED",80,0)
 N DGM,DGCNTY
"RTN","DGREGRED",81,0)
 M DGCMP("NEW")=DGINPUT
"RTN","DGREGRED",82,0)
 W !
"RTN","DGREGRED",83,0)
 F DGM="OLD","NEW" D
"RTN","DGREGRED",84,0)
 . I DGCMP(DGM,.11573)]"",$$FORIEN^DGADDUTL($P(DGCMP(DGM,.11573),U,2)) D DISPFGN(.DGCMP,DGM) Q
"RTN","DGREGRED",85,0)
 . I DGM="NEW" D
"RTN","DGREGRED",86,0)
 . . S DGCNTY=$P($G(DGCMP("NEW",.1157)),U)_" "_$P($G(DGCMP("NEW",.1157)),U,3)
"RTN","DGREGRED",87,0)
 . . S DGCMP("NEW",.1157)=DGCNTY
"RTN","DGREGRED",88,0)
 . . I ($L(DGCMP("NEW",.1156))>5)&($P(DGCMP("NEW",.1156),"-",2)="") S DGCMP("NEW",.1156)=$E(DGCMP("NEW",.1156),1,5)_"-"_$E(DGCMP("NEW",.1156),6,9)
"RTN","DGREGRED",89,0)
 . D DISPUS(.DGCMP,DGM)
"RTN","DGREGRED",90,0)
 Q
"RTN","DGREGRED",91,0)
 ;
"RTN","DGREGRED",92,0)
COMPAREP(DGINPUT,DGCMP) ;Display before & after phone fields.
"RTN","DGREGRED",93,0)
 N DGM
"RTN","DGREGRED",94,0)
 M DGCMP("NEW")=DGINPUT
"RTN","DGREGRED",95,0)
 W !
"RTN","DGREGRED",96,0)
 F DGM="OLD","NEW" D
"RTN","DGREGRED",97,0)
 . W !,?2,"[",DGM," PHONE NUMBERS]"
"RTN","DGREGRED",98,0)
 . W !,?6,"   Phone: ",?16,$P($G(DGCMP(DGM,.131)),U)
"RTN","DGREGRED",99,0)
 . W !,?6,"  Office: ",?16,$P($G(DGCMP(DGM,.132)),U)
"RTN","DGREGRED",100,0)
 . W !
"RTN","DGREGRED",101,0)
 Q
"RTN","DGREGRED",102,0)
 ;
"RTN","DGREGRED",103,0)
DISPUS(DGCMP,DGM) ;tag to display US data
"RTN","DGREGRED",104,0)
 N DGCNTRY
"RTN","DGREGRED",105,0)
 W !,?2,"[",DGM," RESIDENTIAL ADDRESS]"
"RTN","DGREGRED",106,0)
 W !?16,$P($G(DGCMP(DGM,.1151)),U)
"RTN","DGREGRED",107,0)
 I $P($G(DGCMP(DGM,.1152)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1152)),U)
"RTN","DGREGRED",108,0)
 I $P($G(DGCMP(DGM,.1153)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1153)),U)
"RTN","DGREGRED",109,0)
 W !,?16,$P($G(DGCMP(DGM,.1154)),U)
"RTN","DGREGRED",110,0)
 W:($P($G(DGCMP(DGM,.1154)),U)'="")!($P($G(DGCMP(DGM,.1155)),U)'="") ","
"RTN","DGREGRED",111,0)
 W $P($G(DGCMP(DGM,.1155)),U)
"RTN","DGREGRED",112,0)
 W " ",$G(DGCMP(DGM,.1156))
"RTN","DGREGRED",113,0)
 S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.11573)),U,2))
"RTN","DGREGRED",114,0)
 I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY
"RTN","DGREGRED",115,0)
 I $P($G(DGCMP(DGM,.1157)),U)'="" W !,?6,"  County: ",$P($G(DGCMP(DGM,.1157)),U)
"RTN","DGREGRED",116,0)
 W !
"RTN","DGREGRED",117,0)
 Q
"RTN","DGREGRED",118,0)
 ;
"RTN","DGREGRED",119,0)
DISPFGN(DGCMP,DGM) ;tag to display Foreign data
"RTN","DGREGRED",120,0)
 N DGCNTRY
"RTN","DGREGRED",121,0)
 W !,?2,"[",DGM," RESIDENTIAL ADDRESS]"
"RTN","DGREGRED",122,0)
 W !?16,$P($G(DGCMP(DGM,.1151)),U)
"RTN","DGREGRED",123,0)
 I $P($G(DGCMP(DGM,.1152)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1152)),U)
"RTN","DGREGRED",124,0)
 I $P($G(DGCMP(DGM,.1153)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1153)),U)
"RTN","DGREGRED",125,0)
 W !,?16,$P($G(DGCMP(DGM,.11572)),U)_" "_$P($G(DGCMP(DGM,.1154)),U)_" "_$P($G(DGCMP(DGM,.11571)),U)
"RTN","DGREGRED",126,0)
 S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.11573)),U,2))
"RTN","DGREGRED",127,0)
 S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY)
"RTN","DGREGRED",128,0)
 I DGCNTRY]"" W !?16,DGCNTRY
"RTN","DGREGRED",129,0)
 W !
"RTN","DGREGRED",130,0)
 Q
"RTN","DGREGRED",131,0)
 ;
"RTN","DGREGRED",132,0)
CONFIRM(TYPE) ;Confirm if user wants to save the changes 
"RTN","DGREGRED",133,0)
 ; TYPE - used for the query message displayed to the user: "address" or "phone number"
"RTN","DGREGRED",134,0)
 N DIR,X,Y,DTOUT,DUOUT,DIROUT
"RTN","DGREGRED",135,0)
 S DIR(0)="Y"
"RTN","DGREGRED",136,0)
 S DIR("A")="Are you sure that you want to save the "_TYPE_" changes"
"RTN","DGREGRED",137,0)
 S DIR("?")="Please answer Y for YES or N for NO."
"RTN","DGREGRED",138,0)
 D ^DIR
"RTN","DGREGRED",139,0)
 I $D(DTOUT)!($G(Y)=0) Q 0
"RTN","DGREGRED",140,0)
 I $D(DUOUT)!$D(DIROUT) Q 0
"RTN","DGREGRED",141,0)
 Q 1
"RTN","DGREGRED",142,0)
 ;
"RTN","DGREGRED",143,0)
SAVE(DGINPUT,DFN,FSTR,FORGN) ;Save changes
"RTN","DGREGRED",144,0)
 N DGN,DGER,DGM,L,DATA
"RTN","DGREGRED",145,0)
 S DGER=0
"RTN","DGREGRED",146,0)
 ; need to get the country code into the DGINPUT array
"RTN","DGREGRED",147,0)
 ; if it's a domestic address, we have to add in CITY,STATE & COUNTY
"RTN","DGREGRED",148,0)
 S FSTR=FSTR_$S('FORGN:",.1154,.1155,.1157,.11573",1:",.11573")
"RTN","DGREGRED",149,0)
 F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) D
"RTN","DGREGRED",150,0)
 . ; Phone numbers saved separately - skip over here
"RTN","DGREGRED",151,0)
 . I (DGN=.131)!(DGN=.132) Q
"RTN","DGREGRED",152,0)
 . N DGCODE,DGNAME,FDA,MSG
"RTN","DGREGRED",153,0)
 . S DGCODE=$P($G(DGINPUT(DGN)),U,2)
"RTN","DGREGRED",154,0)
 . S DGNAME=$P($G(DGINPUT(DGN)),U)
"RTN","DGREGRED",155,0)
 . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME)
"RTN","DGREGRED",156,0)
 . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG")
"RTN","DGREGRED",157,0)
 . I $D(MSG) D
"RTN","DGREGRED",158,0)
 .. S DGM="",DGER=1
"RTN","DGREGRED",159,0)
 .. W !,"Please review the saved changes!!",!
"RTN","DGREGRED",160,0)
 .. F  S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM=""  D
"RTN","DGREGRED",161,0)
 ... W $G(MSG("DIERR",1,"TEXT",DGM))
"RTN","DGREGRED",162,0)
 I $G(DGER)=0 W !,"Change saved." D
"RTN","DGREGRED",163,0)
 . ; Set the CASS IND field 
"RTN","DGREGRED",164,0)
 . S DATA(.1159)="NC"
"RTN","DGREGRED",165,0)
 . I $$UPD^DGENDBS(2,DFN,.DATA)
"RTN","DGREGRED",166,0)
 D EOP
"RTN","DGREGRED",167,0)
 Q
"RTN","DGREGRED",168,0)
 ;
"RTN","DGREGRED",169,0)
SAVEPH(DGINPUT,DFN) ;Save phone changes
"RTN","DGREGRED",170,0)
 N DGN,DGER,DGM,DATA
"RTN","DGREGRED",171,0)
 S DGER=0
"RTN","DGREGRED",172,0)
 F DGN=.131,.132 D
"RTN","DGREGRED",173,0)
 . N DGCODE,DGNAME,FDA,MSG
"RTN","DGREGRED",174,0)
 . S DGCODE=$P($G(DGINPUT(DGN)),U,2)
"RTN","DGREGRED",175,0)
 . S DGNAME=$P($G(DGINPUT(DGN)),U)
"RTN","DGREGRED",176,0)
 . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME)
"RTN","DGREGRED",177,0)
 . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG")
"RTN","DGREGRED",178,0)
 . I $D(MSG) D
"RTN","DGREGRED",179,0)
 .. S DGM="",DGER=1
"RTN","DGREGRED",180,0)
 .. W !,"Please review the saved changes!!",!
"RTN","DGREGRED",181,0)
 .. F  S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM=""  D
"RTN","DGREGRED",182,0)
 ... W $G(MSG("DIERR",1,"TEXT",DGM))
"RTN","DGREGRED",183,0)
 I $G(DGER)=0 W !,"Change saved."
"RTN","DGREGRED",184,0)
 D EOP
"RTN","DGREGRED",185,0)
 Q
"RTN","DGREGRED",186,0)
 ;
"RTN","DGREGRED",187,0)
READ(DFN,DGN,Y) ;Read input, return success
"RTN","DGREGRED",188,0)
 N SUCCESS,DIR,DA,DTOUT,DUOUT,DIROUT,L,POP
"RTN","DGREGRED",189,0)
 S SUCCESS=1,POP=0
"RTN","DGREGRED",190,0)
 F L=0:0 D  Q:POP
"RTN","DGREGRED",191,0)
 . S DIR(0)=2_","_DGN
"RTN","DGREGRED",192,0)
 . I DFN S DA=DFN
"RTN","DGREGRED",193,0)
 . D ^DIR
"RTN","DGREGRED",194,0)
 . I $D(DTOUT) S POP=1,SUCCESS=0 Q
"RTN","DGREGRED",195,0)
 . I $D(DUOUT)!$D(DIROUT) D UPCT Q
"RTN","DGREGRED",196,0)
 . S POP=1
"RTN","DGREGRED",197,0)
 Q SUCCESS
"RTN","DGREGRED",198,0)
INPT1(FORGN,PSTR) ; first address input prompts
"RTN","DGREGRED",199,0)
 N FSTR
"RTN","DGREGRED",200,0)
 ; PSTR is the full set of fields domestic & foreign combined
"RTN","DGREGRED",201,0)
 ; FSTR is the set of fields depending on Country code
"RTN","DGREGRED",202,0)
 S PSTR=".1151,.1152,.1153,.1154,.1155,.1157,.1156,.11571,.11572,.11573,.131,.132"
"RTN","DGREGRED",203,0)
 S FSTR=".1151,.1152,.1153,.1156,.131,.132"
"RTN","DGREGRED",204,0)
 I FORGN S FSTR=".1151,.1152,.1153,.1154,.11571,.11572,.131,.132"
"RTN","DGREGRED",205,0)
 Q FSTR
"RTN","DGREGRED",206,0)
ZIPINP(DGINPUT,DFN) ; get ZIP+4 input
"RTN","DGREGRED",207,0)
 ; This subroutine calls existing code to prompt for zip code and return corresponding city, state and county
"RTN","DGREGRED",208,0)
 ; DFN must be the patient internal ID.  
"RTN","DGREGRED",209,0)
 ; DGINPUT - passed by reference - the array containing the resulting county, city, and state for the zipcode.
"RTN","DGREGRED",210,0)
 N FCITY,FZIP,FSTATE,FCOUNTY,TYPE,DGR
"RTN","DGREGRED",211,0)
 ; Set the necessary variables for the Residential Address
"RTN","DGREGRED",212,0)
 ; The variable TYPE is used for Confidential and temporary address types. 
"RTN","DGREGRED",213,0)
 ; Here for the Residential Address we clear this variable.
"RTN","DGREGRED",214,0)
 S FZIP=".1156",FCITY=".1154",FSTATE=".1155",FCOUNTY=".1157",TYPE=""
"RTN","DGREGRED",215,0)
 D EN^DGREGTZL(.DGR,DFN)
"RTN","DGREGRED",216,0)
 M DGINPUT=DGR
"RTN","DGREGRED",217,0)
 Q
"RTN","DGREGRED",218,0)
SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step
"RTN","DGREGRED",219,0)
 N SKIP
"RTN","DGREGRED",220,0)
 S SKIP=0
"RTN","DGREGRED",221,0)
 I ($G(DGINPUT(.1151))="")&((DGN=.1152)!(DGN=.1153)) S SKIP=1
"RTN","DGREGRED",222,0)
 I ($G(DGINPUT(.1152))="")&(DGN=.1153) S SKIP=1
"RTN","DGREGRED",223,0)
 I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) S SKIP=1
"RTN","DGREGRED",224,0)
 Q SKIP
"RTN","DGREGRED",225,0)
EOP ;End of page prompt
"RTN","DGREGRED",226,0)
 N DIR,DTOUT,DUOUT,DIROUT,X,Y
"RTN","DGREGRED",227,0)
 S DIR(0)="E"
"RTN","DGREGRED",228,0)
 S DIR("A")="Press ENTER to continue"
"RTN","DGREGRED",229,0)
 D ^DIR
"RTN","DGREGRED",230,0)
 Q
"RTN","DGREGRED",231,0)
UPCT ;Indicate "^" or "^^" are unacceptable inputs.
"RTN","DGREGRED",232,0)
 W !,"EXIT NOT ALLOWED"
"RTN","DGREGRED",233,0)
 Q
"RTN","DGREGTED")
0^13^B31206434
"RTN","DGREGTED",1,0)
DGREGTED ;ALB/BAJ,BDB,JAM - Temporary & Confidential Address Edits API ;23 May 2017  12:48 PM
"RTN","DGREGTED",2,0)
 ;;5.3;Registration;**688,851,941**;Aug 13, 1993;Build 73
"RTN","DGREGTED",3,0)
 ;
"RTN","DGREGTED",4,0)
EN(DFN,TYPE,RET) ;Entry point
"RTN","DGREGTED",5,0)
 ; This routine controls Edits to Temporary & Confidential addresses
"RTN","DGREGTED",6,0)
 ; 
"RTN","DGREGTED",7,0)
 ; Input
"RTN","DGREGTED",8,0)
 ;       DFN  = Patient DFN
"RTN","DGREGTED",9,0)
 ;       TYPE = Type of address: "TEMP" or "CONF"
"RTN","DGREGTED",10,0)
 ;       RET  = Flag to signal return to first prompt
"RTN","DGREGTED",11,0)
 ;       
"RTN","DGREGTED",12,0)
 ; Output
"RTN","DGREGTED",13,0)
 ;       RET  0 = Return to first prompt
"RTN","DGREGTED",14,0)
 ;            1 = Do not return
"RTN","DGREGTED",15,0)
 ;       
"RTN","DGREGTED",16,0)
 N DGINPUT,FORGN,FSTR,ICNTRY,CNTRY,PSTR,DGCMP,DGOLD,DR,DIE
"RTN","DGREGTED",17,0)
 N FSLINE1,FSLINE2,FSLINE3,FCITY,FSTATE,FCOUNTY,FZIP,FPHONE
"RTN","DGREGTED",18,0)
 N FPROV,FPSTAL,FCNTRY,FNODE1,FNODE2,CPEICE,OLDC,RPROC
"RTN","DGREGTED",19,0)
 N I,X,Y
"RTN","DGREGTED",20,0)
 I $G(DFN)="" Q
"RTN","DGREGTED",21,0)
 ;I ($G(DFN)'?.N) Q
"RTN","DGREGTED",22,0)
 D INIT^DGREGTE2  I $P($G(^DPT(DFN,FNODE1)),U,9)="N" Q
"RTN","DGREGTED",23,0)
 D GETOLD^DGREGTE2(.DGCMP,DFN,TYPE) M DGOLD=DGCMP("OLD") K DGCMP
"RTN","DGREGTED",24,0)
 S CNTRY="",ICNTRY=$P($G(^DPT(DFN,FNODE2)),"^",CPEICE) I ICNTRY="" S ICNTRY=1    ;default US if NULL
"RTN","DGREGTED",25,0)
 S FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,FCNTRY,.CNTRY) Q:$G(CNTRY)=""  I FORGN=-1 S RET=0 Q
"RTN","DGREGTED",26,0)
 S FSTR=$$INPT1^DGREGTE2(DFN,FORGN,.PSTR),DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR)
"RTN","DGREGTED",27,0)
 I $G(DGINPUT)=-1 S RET=0 Q
"RTN","DGREGTED",28,0)
 D SAVE(.DGINPUT,DFN,FSTR,CNTRY)
"RTN","DGREGTED",29,0)
 Q
"RTN","DGREGTED",30,0)
 ;
"RTN","DGREGTED",31,0)
INPUT(DGINPUT,DFN,FSTR) ;Let user input address changes
"RTN","DGREGTED",32,0)
 ; Input:
"RTN","DGREGTED",33,0)
 ;       DGINPUT - Array to hold field values DGINPUT(field#)
"RTN","DGREGTED",34,0)
 ;       DFN     - Patient DFN
"RTN","DGREGTED",35,0)
 ;       FSTR    - String of fields (foreign or domestic) to work with
"RTN","DGREGTED",36,0)
 ;       
"RTN","DGREGTED",37,0)
 ; Output: 
"RTN","DGREGTED",38,0)
 ;       DGINPUT(field#)=external^internal(if any)
"RTN","DGREGTED",39,0)
 ; 
"RTN","DGREGTED",40,0)
 N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L,SUCCESS,REP
"RTN","DGREGTED",41,0)
 F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) Q:DGINPUT=-1  D
"RTN","DGREGTED",42,0)
 . S REP=0
"RTN","DGREGTED",43,0)
 . I $$SKIP^DGREGTE2(DGN,.DGINPUT) Q
"RTN","DGREGTED",44,0)
 . I DGN=FZIP D ZIPINP(.DGINPUT,DFN) Q  ;DG*5.3*851
"RTN","DGREGTED",45,0)
 . S SUCCESS=$$READ(DFN,.DGOLD,DGN,.Y,.REP) I 'SUCCESS D  Q
"RTN","DGREGTED",46,0)
 . . I 'REP S DGINPUT=-1 Q
"RTN","DGREGTED",47,0)
 . . ; repeat the question so we have to set the counter back
"RTN","DGREGTED",48,0)
 . . S L=L-1
"RTN","DGREGTED",49,0)
 . S DGINPUT(DGN)=$G(Y)
"RTN","DGREGTED",50,0)
READ(DFN,DGOLD,DGN,Y,REP) ;Read input, return success
"RTN","DGREGTED",51,0)
 ; Input:
"RTN","DGREGTED",52,0)
 ;       DFN   - Patient DFN
"RTN","DGREGTED",53,0)
 ;       DGOLD - Array of current field values.
"RTN","DGREGTED",54,0)
 ;       DGN   - Current field to read
"RTN","DGREGTED",55,0)
 ;       Y     - Current Field value
"RTN","DGREGTED",56,0)
 ;       REP   - Flag -- should prompt be repeated
"RTN","DGREGTED",57,0)
 ;       
"RTN","DGREGTED",58,0)
 ; Output
"RTN","DGREGTED",59,0)
 ;       SUCCESS 1 = Input successful go to next prompt
"RTN","DGREGTED",60,0)
 ;               0 = Input unsuccessful Repeat or Abort as indicated by REP variable
"RTN","DGREGTED",61,0)
 ;       REP     1 = Error - Repeat prompt
"RTN","DGREGTED",62,0)
 ;               0 = Error - Do not repeat
"RTN","DGREGTED",63,0)
 ;       Y       New field value
"RTN","DGREGTED",64,0)
 ;       
"RTN","DGREGTED",65,0)
 N SUCCESS,DIR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,L,T,POP,DGST,CNTYFLD,REVERSE
"RTN","DGREGTED",66,0)
 S SUCCESS=1,(POP,REVERSE)=0,CNTYFLD=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTY",1:"CONFIDENTIAL ADDRESS COUNTY")
"RTN","DGREGTED",67,0)
 S DIR(0)=2_","_DGN,DIR("B")=$G(DGOLD(DGN))
"RTN","DGREGTED",68,0)
 S DA=DFN
"RTN","DGREGTED",69,0)
 F  D  Q:POP
"RTN","DGREGTED",70,0)
 . K DTOUT,DUOUT,DIROUT
"RTN","DGREGTED",71,0)
 . S MSG=""
"RTN","DGREGTED",72,0)
 . I ($G(DGINPUT(FSTATE))="")&(DGN=FCOUNTY) S POP=1 Q
"RTN","DGREGTED",73,0)
 . S DIR("B")=$S($D(DGINPUT(DGN)):DGINPUT(DGN),$G(DGOLD(DGN))]"":DGOLD(DGN),1:"")
"RTN","DGREGTED",74,0)
 . I DGN=FCOUNTY D 
"RTN","DGREGTED",75,0)
 . . S DIR(0)="POA^DIC(5,"_$P(DGINPUT(FSTATE),U)_",1,:AEMQ"
"RTN","DGREGTED",76,0)
 . . S DIR("A")=CNTYFLD_": "
"RTN","DGREGTED",77,0)
 . . ; we can't prompt if there's no previous entry
"RTN","DGREGTED",78,0)
 . . I $D(DGOLD(DGN)) S T=$L(DGOLD(DGN)," "),DIR("B")=$P($G(DGOLD(DGN))," ",1,T-1)
"RTN","DGREGTED",79,0)
 . D ^DIR
"RTN","DGREGTED",80,0)
 . I $D(DTOUT) S POP=1,SUCCESS=0 Q
"RTN","DGREGTED",81,0)
 . I $D(DIRUT) S MSG="",REVERSE=0 D ANSW(X,.DGOLD,DGN,.MSG,.Y,.REP,$G(RET),.REVERSE) S:REP SUCCESS=0 W:MSG]"" !,MSG
"RTN","DGREGTED",82,0)
 . I REVERSE S (REP,SUCCESS)=0
"RTN","DGREGTED",83,0)
 . S POP=1
"RTN","DGREGTED",84,0)
 Q SUCCESS
"RTN","DGREGTED",85,0)
 ;
"RTN","DGREGTED",86,0)
SAVE(DGINPUT,DFN,FSTR,CNTRY) ;Save changes
"RTN","DGREGTED",87,0)
 N DATA,DGENDA,L,T,FILE,ERROR,LOOP,LOOP1,LOOP2
"RTN","DGREGTED",88,0)
 S DGENDA=DFN,FILE=2
"RTN","DGREGTED",89,0)
 ; need to get the country code into the DGINPUT array
"RTN","DGREGTED",90,0)
 S DGINPUT(FCNTRY)=$O(^HL(779.004,"B",CNTRY,""))
"RTN","DGREGTED",91,0)
 S FSTR=FSTR_","_FCNTRY
"RTN","DGREGTED",92,0)
 I (TYPE="TEMP")!(TYPE="CONF") S FSTR=FSTR_","_FCITY_","_FSTATE_","_FCOUNTY ;DG*5.3*851
"RTN","DGREGTED",93,0)
 F L=1:1:$L(FSTR,",") S T=$P(FSTR,",",L) S DATA(T)=$P($G(DGINPUT(T)),U)
"RTN","DGREGTED",94,0)
 ;JAM; Set the CASS field for Temp and Confidential;  DG*5.3*941
"RTN","DGREGTED",95,0)
 I TYPE="TEMP" S DATA(.12115)="NC"
"RTN","DGREGTED",96,0)
 I TYPE="CONF" S DATA(.14117)="NC"
"RTN","DGREGTED",97,0)
 Q $$UPD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR)
"RTN","DGREGTED",98,0)
 ;
"RTN","DGREGTED",99,0)
ANSW(YIN,DGOLD,DGN,MSG,YOUT,REP,RET,REVERSE) ;analyze input commands
"RTN","DGREGTED",100,0)
 ; This API will process reads and set bits, messages and flags accordingly.
"RTN","DGREGTED",101,0)
 ; Because there is different behavior depending on prompt and input, the input
"RTN","DGREGTED",102,0)
 ; of each field needs to be evaluated separately at the time of input and before
"RTN","DGREGTED",103,0)
 ; deciding to continue the edit.  Input rules are loaded into array RPROC at the
"RTN","DGREGTED",104,0)
 ; beginning of this routine in call to INIT^DGREGTE2.
"RTN","DGREGTED",105,0)
 ; 
"RTN","DGREGTED",106,0)
 ; Input
"RTN","DGREGTED",107,0)
 ;       N       - User input "Y" value
"RTN","DGREGTED",108,0)
 ;       DGOLD   - Array of current values
"RTN","DGREGTED",109,0)
 ;       DGN     - Current field
"RTN","DGREGTED",110,0)
 ;       MSG     - Variable for Text message
"RTN","DGREGTED",111,0)
 ;       YOUT    - User input ("Y") value
"RTN","DGREGTED",112,0)
 ;       REP     - Flag to repeat prompt
"RTN","DGREGTED",113,0)
 ;       RET     - Flag to return success or failure to calling module
"RTN","DGREGTED",114,0)
 ;       REVERSE - Flag to revert to first prompt in sequence
"RTN","DGREGTED",115,0)
 ; 
"RTN","DGREGTED",116,0)
 ; Output
"RTN","DGREGTED",117,0)
 ;       MSG     - Text message (for incorrect entries)
"RTN","DGREGTED",118,0)
 ;       REP     - Repeat current prompt
"RTN","DGREGTED",119,0)
 ;       REVERSE - Revert to first prompt in sequence
"RTN","DGREGTED",120,0)
 ; 
"RTN","DGREGTED",121,0)
 N X,Y,DTOUT,DIRUT,DUOUT,PRMPT,RMSG,TDGN,ACT
"RTN","DGREGTED",122,0)
 N OLDVAL,NEWVAL
"RTN","DGREGTED",123,0)
 ;
"RTN","DGREGTED",124,0)
 S PRMPT=$S(TYPE="TEMP":"TEMPORARY",1:"CONFIDENTIAL")
"RTN","DGREGTED",125,0)
 S RMSG("LINE")="BUT I NEED AT LEAST ONE LINE OF A "_PRMPT_" ADDRESS"
"RTN","DGREGTED",126,0)
 S RMSG("REVERSE")="This is a required response."
"RTN","DGREGTED",127,0)
 S RMSG("REPEAT")="EXIT NOT ALLOWED ??"
"RTN","DGREGTED",128,0)
 S RMSG("QUES")="??"
"RTN","DGREGTED",129,0)
 S RMSG("INSTRUCT")=$S(TYPE="TEMP":"TADD^DGLOCK1",TYPE="CONF":"CADD1^DGLOCK3",1:"OK")
"RTN","DGREGTED",130,0)
 S OLDVAL=$G(DGOLD(DGN)),OLDVAL=$$PROC(OLDVAL),NEWVAL=$$PROC(YIN)
"RTN","DGREGTED",131,0)
 S TDGN=$S($D(RPROC(DGN,OLDVAL,NEWVAL)):DGN,1:"ALL")
"RTN","DGREGTED",132,0)
 I '$D(RPROC(TDGN,OLDVAL,NEWVAL)) S RPROC(TDGN,OLDVAL,NEWVAL)="OK"
"RTN","DGREGTED",133,0)
 S ACT=RPROC(TDGN,OLDVAL,NEWVAL)
"RTN","DGREGTED",134,0)
 D @ACT
"RTN","DGREGTED",135,0)
 Q
"RTN","DGREGTED",136,0)
REVERSE ;
"RTN","DGREGTED",137,0)
 N MSUB
"RTN","DGREGTED",138,0)
 S MSUB=$S(DGN=FSLINE1:"LINE",1:"REVERSE")
"RTN","DGREGTED",139,0)
 W !,RMSG(MSUB)
"RTN","DGREGTED",140,0)
 S REVERSE=1
"RTN","DGREGTED",141,0)
 Q
"RTN","DGREGTED",142,0)
REPEAT ;
"RTN","DGREGTED",143,0)
 W !,RMSG("REPEAT")
"RTN","DGREGTED",144,0)
 S REP=1
"RTN","DGREGTED",145,0)
 Q
"RTN","DGREGTED",146,0)
OK ;
"RTN","DGREGTED",147,0)
 Q
"RTN","DGREGTED",148,0)
QUES ;
"RTN","DGREGTED",149,0)
 W RMSG("QUES")
"RTN","DGREGTED",150,0)
 S REP=1
"RTN","DGREGTED",151,0)
 Q
"RTN","DGREGTED",152,0)
CONFIRM ;
"RTN","DGREGTED",153,0)
 I '$$SURE^DGREGTE2 S YOUT=DGOLD(DGN),REP=1 Q
"RTN","DGREGTED",154,0)
 S YOUT=YIN,REP=0
"RTN","DGREGTED",155,0)
 Q
"RTN","DGREGTED",156,0)
INSTRUCT ;
"RTN","DGREGTED",157,0)
 D @RMSG("INSTRUCT")
"RTN","DGREGTED",158,0)
 S REP=1
"RTN","DGREGTED",159,0)
 Q
"RTN","DGREGTED",160,0)
PROC(VAL) ;process the input and return a type of value
"RTN","DGREGTED",161,0)
 ; input
"RTN","DGREGTED",162,0)
 ;   VAL - The value to examine
"RTN","DGREGTED",163,0)
 ;       
"RTN","DGREGTED",164,0)
 ; output
"RTN","DGREGTED",165,0)
 ;   a value type
"RTN","DGREGTED",166,0)
 ;     VALUE  = input - validation is a separate task and is not done here
"RTN","DGREGTED",167,0)
 ;     NULL   = NULL input
"RTN","DGREGTED",168,0)
 ;     UPCAR  = the "^" character
"RTN","DGREGTED",169,0)
 ;     DELETE = the "@" character
"RTN","DGREGTED",170,0)
 Q $S(VAL="":"NULL",$E(VAL)="^":"UPCAR",$E(VAL)="@":"DELETE",1:"VALUE")
"RTN","DGREGTED",171,0)
EOP ;End of page prompt
"RTN","DGREGTED",172,0)
 N DIR,DTOUT,DUOUT,DIROUT,X,Y
"RTN","DGREGTED",173,0)
 S DIR(0)="E"
"RTN","DGREGTED",174,0)
 S DIR("A")="Press ENTER to continue"
"RTN","DGREGTED",175,0)
 D ^DIR
"RTN","DGREGTED",176,0)
 Q
"RTN","DGREGTED",177,0)
 ; DG*5.3*851
"RTN","DGREGTED",178,0)
ZIPINP(DGINPUT,DFN) ;get ZIP+4 input
"RTN","DGREGTED",179,0)
 N DGR,DGX
"RTN","DGREGTED",180,0)
 D EN^DGREGTZL(.DGR,DFN)
"RTN","DGREGTED",181,0)
 I $G(DGR)=-1 Q
"RTN","DGREGTED",182,0)
 M DGINPUT=DGR
"RTN","DGREGTED",183,0)
 S DGX=DGINPUT(FCOUNTY),DGINPUT(FCOUNTY)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1)
"RTN","DGREGTED",184,0)
 S DGX=DGINPUT(FSTATE),DGINPUT(FSTATE)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1)
"RTN","DGREGTED",185,0)
 Q
"RTN","DGREGTED",186,0)
SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step
"RTN","DGREGTED",187,0)
 N SKIP
"RTN","DGREGTED",188,0)
 S SKIP=0
"RTN","DGREGTED",189,0)
 I ($G(DGINPUT(FSLINE1))="")&((DGN=FSLINE2)!(DGN=FSLINE3)) S SKIP=1
"RTN","DGREGTED",190,0)
 I ($G(DGINPUT(FSLINE2))="")&(DGN=FSLINE3) S SKIP=1
"RTN","DGREGTED",191,0)
 I ($G(FLG(1))'=1)&((DGN=FPHONE)) S SKIP=1
"RTN","DGREGTED",192,0)
 Q SKIP
"RTN","DGREGTED",193,0)
UPCT ;Indicate "^" or "^^" are unacceptable inputs.
"RTN","DGREGTED",194,0)
 W !,"EXIT NOT ALLOWED ??"
"RTN","DGREGTED",195,0)
 Q
"RTN","DGRP1")
0^8^B36820867
"RTN","DGRP1",1,0)
DGRP1 ;ALB/MRL,ERC,BAJ,PWC,JAM - DEMOGRAPHIC DATA ;19 Jul 2017  3:02 PM
"RTN","DGRP1",2,0)
 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,688,750,851,907,925,941**;Aug 13, 1993;Build 73
"RTN","DGRP1",3,0)
 ;
"RTN","DGRP1",4,0)
EN ;
"RTN","DGRP1",5,0)
 ; JAM - Patch DG*5.3*941, Reformatting Registration screen 1.  New field layout.
"RTN","DGRP1",6,0)
 ;S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.122,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP1",7,0)
 N DGRP
"RTN","DGRP1",8,0)
 S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.13,.15,.24,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP1",9,0)
 I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
"RTN","DGRP1",10,0)
 ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'.  NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
"RTN","DGRP1",11,0)
 ;Retrieve SSN Verification status DG*5.3*688 BAJ 11/22/2005
"RTN","DGRP1",12,0)
 N SSNV D GETSTAT(.SSNV)
"RTN","DGRP1",13,0)
 S Z=1 D WW^DGRPV W "    Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
"RTN","DGRP1",14,0)
 ;Display SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
"RTN","DGRP1",15,0)
 W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV W SSNV
"RTN","DGRP1",16,0)
 W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
"RTN","DGRP1",17,0)
 ;add Pseuso SSN Reason - DG*5.3*653, ERC
"RTN","DGRP1",18,0)
 I $P(DGRP(0),U,9)["P" D
"RTN","DGRP1",19,0)
 . N DGSPACE
"RTN","DGRP1",20,0)
 . S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen
"RTN","DGRP1",21,0)
 . S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: "
"RTN","DGRP1",22,0)
 . I $P(DGRP(0),U,9)["P" D
"RTN","DGRP1",23,0)
 . . N DGREAS D SSNREAS(.DGREAS)
"RTN","DGRP1",24,0)
 . . Q:$G(DGREAS)']""
"RTN","DGRP1",25,0)
 . . W DGREAS
"RTN","DGRP1",26,0)
 D GETNCAL  ;Display name component, sex, and alias information
"RTN","DGRP1",27,0)
 S Z=3,DGRPX=DGRP(0) W ! D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT")
"RTN","DGRP1",28,0)
 ;JAM - Patch DG*5.3*941 registration screen changes - remove addresses from screen and Cell/pager/email now in group 3 and Preferred Lang in group 4
"RTN","DGRP1",29,0)
 S Z=4,DGRPW=1.1 W ! D WW^DGRPV W "    Cell Phone: "  ;DG*5.3*941
"RTN","DGRP1",30,0)
 ;
"RTN","DGRP1",31,0)
 ;* Output Cell phone
"RTN","DGRP1",32,0)
 I $P(DGRP(.13),U,4)'="" W ?19,$P(DGRP(.13),U,4)
"RTN","DGRP1",33,0)
 I $P(DGRP(.13),U,4)="" W ?19,"UNANSWERED"
"RTN","DGRP1",34,0)
 ;
"RTN","DGRP1",35,0)
 ;* Output Pager
"RTN","DGRP1",36,0)
 W !,"          Pager #: "
"RTN","DGRP1",37,0)
 I $P(DGRP(.13),U,5)'="" W ?19,$P(DGRP(.13),U,5)
"RTN","DGRP1",38,0)
 I $P(DGRP(.13),U,5)="" W ?19,"UNANSWERED"
"RTN","DGRP1",39,0)
 ;
"RTN","DGRP1",40,0)
 ;* Output Email Address
"RTN","DGRP1",41,0)
 W !,"    Email Address: "
"RTN","DGRP1",42,0)
 I $P(DGRP(.13),U,3)'="" W ?19,$P(DGRP(.13),U,3)
"RTN","DGRP1",43,0)
 I $P(DGRP(.13),U,3)="" W ?19,"UNANSWERED"
"RTN","DGRP1",44,0)
 ;
"RTN","DGRP1",45,0)
LANGUAGE ;Get language data *///*
"RTN","DGRP1",46,0)
 S DGLANGDT=9999999,(DGPRFLAN,DGLANG0,DGRP(1),DGRP(2))=""
"RTN","DGRP1",47,0)
 S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1)
"RTN","DGRP1",48,0)
 I DGLANGDT="" G L1
"RTN","DGRP1",49,0)
 S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0)) I DGLANGDA="" S DGRP(2)="" G L1
"RTN","DGRP1",50,0)
 S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2)
"RTN","DGRP1",51,0)
 S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y
"RTN","DGRP1",52,0)
 S DGRP(1)=DGLANGDT,DGRP(2)=DGPRFLAN
"RTN","DGRP1",53,0)
 K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA
"RTN","DGRP1",54,0)
 ;
"RTN","DGRP1",55,0)
L1 W ! S Z=5,DGRPW=1.1 D WW^DGRPV ;*///*  ;DG*5.3*941 - remove extra line feed
"RTN","DGRP1",56,0)
 W ?4,"Language Date/Time: ",$S(DGRP(1)="":"UNANSWERED",1:DGRP(1))
"RTN","DGRP1",57,0)
 W !?5,"Preferred Language: ",$S(DGRP(2)="":"UNANSWERED",1:DGRP(2))
"RTN","DGRP1",58,0)
 ;
"RTN","DGRP1",59,0)
 ; ***  Additional displays added for Pre-Registration
"RTN","DGRP1",60,0)
 I $G(DGPRFLG)=1 D
"RTN","DGRP1",61,0)
 . W !
"RTN","DGRP1",62,0)
 . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1,ADDRDTTM
"RTN","DGRP1",63,0)
 . I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1  I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2)
"RTN","DGRP1",64,0)
 . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
"RTN","DGRP1",65,0)
 . I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1  S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2)
"RTN","DGRP1",66,0)
 . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
"RTN","DGRP1",67,0)
 . I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1  S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2)
"RTN","DGRP1",68,0)
 . S ADDRDTTM=$P($G(^DPT(DFN,.11)),"^",13)
"RTN","DGRP1",69,0)
 . I ADDRDTTM'="" W !," [PERMANENT ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(ADDRDTTM,"5D")
"RTN","DGRP1",70,0)
 . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
"RTN","DGRP1",71,0)
 . I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1  S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2)
"RTN","DGRP1",72,0)
 . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
"RTN","DGRP1",73,0)
 . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
"RTN","DGRP1",74,0)
 . I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI  D
"RTN","DGRP1",75,0)
 .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
"RTN","DGRP1",76,0)
 .. W "  EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D"),"  EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
"RTN","DGRP1",77,0)
 ;
"RTN","DGRP1",78,0)
 W !
"RTN","DGRP1",79,0)
 G ^DGRPP
"RTN","DGRP1",80,0)
 ;
"RTN","DGRP1",81,0)
GETNCAL ;Get name component values
"RTN","DGRP1",82,0)
 N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
"RTN","DGRP1",83,0)
 S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
"RTN","DGRP1",84,0)
 S DGCOMP=+$G(^DPT(DFN,"NAME"))_","
"RTN","DGRP1",85,0)
 I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
"RTN","DGRP1",86,0)
 ;Get alias values
"RTN","DGRP1",87,0)
 S DGA=0 F DGI=1:1:5 D  Q:'$D(DGALIAS(DGI))
"RTN","DGRP1",88,0)
A2 .S DGA=$O(^DPT(DFN,.01,DGA))
"RTN","DGRP1",89,0)
 .I 'DGA D:DGI=1  Q
"RTN","DGRP1",90,0)
 ..S DGALIAS(DGI)="< No alias entries on file >" Q
"RTN","DGRP1",91,0)
 .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q
"RTN","DGRP1",92,0)
 .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2
"RTN","DGRP1",93,0)
 .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)
"RTN","DGRP1",94,0)
 .I $L(DGX) D
"RTN","DGRP1",95,0)
 ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)
"RTN","DGRP1",96,0)
 ..; BAJ DG*5.2*700 retrofit 06/22/06
"RTN","DGRP1",97,0)
 ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)
"RTN","DGRP1",98,0)
 ..S $E(DGALIAS(DGI),20)=DGX Q
"RTN","DGRP1",99,0)
 .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)
"RTN","DGRP1",100,0)
 .Q  ;
"RTN","DGRP1",101,0)
 ;Display name component, sex, multiple birth indicator and alias data
"RTN","DGRP1",102,0)
 F DGI=1:1:6 D
"RTN","DGRP1",103,0)
 .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:28,1:27))
"RTN","DGRP1",104,0)
 .; BAJ DG*5.3*700 retrofit 06/22/06
"RTN","DGRP1",105,0)
 .; ob - 10/22/14 added "Birth" on the next line
"RTN","DGRP1",106,0)
 .I DGI=1 S (Z,DGRPW)=1 W ?37,"Birth Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV ;DG*5.3*907
"RTN","DGRP1",107,0)
 .I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV
"RTN","DGRP1",108,0)
 .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "
"RTN","DGRP1",109,0)
 .I DGI>1 W ?47,$G(DGALIAS(DGI-1))
"RTN","DGRP1",110,0)
 .Q
"RTN","DGRP1",111,0)
 ;*** display Self-Identified Gender Identity DG*5.3*907
"RTN","DGRP1",112,0)
 ;Get node with SIGI in it already done at EN+1
"RTN","DGRP1",113,0)
 W !?5,"Self-Identified Gender Identity: "
"RTN","DGRP1",114,0)
 S X=$P(DGRP(.24),"^",4),Z=$S(X="M":"MALE",X="F":"FEMALE",X="TM":"TRANSMALE/TRANSMAN/FEMALE-TO-MALE",X="TF":"TRANSFEMALE/TRANSWOMAN/MALE-TO-FEMALE",X="O":"OTHER",X="N":"INDIVIDUAL CHOOSES NOT TO ANSWER",1:DGRPU) W Z ;D WW1^DGRPV
"RTN","DGRP1",115,0)
 ; *** end of change 
"RTN","DGRP1",116,0)
 Q
"RTN","DGRP1",117,0)
GETSTAT(SSNV) ;get SSN VERIFIED STATUS DG*5.3*688 BAJ 11/22/2005
"RTN","DGRP1",118,0)
 N T
"RTN","DGRP1",119,0)
 S T=$P($G(^DPT(DFN,"SSN")),"^",2)
"RTN","DGRP1",120,0)
 S SSNV=$S(T=2:"INVALID",T=4:"VERIFIED",1:"")
"RTN","DGRP1",121,0)
 Q
"RTN","DGRP1",122,0)
 ;
"RTN","DGRP1",123,0)
SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
"RTN","DGRP1",124,0)
 S DGREAS=$P(DGRP("SSN"),U)
"RTN","DGRP1",125,0)
 I $G(DGREAS)']"" Q
"RTN","DGRP1",126,0)
 S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >")
"RTN","DGRP1",127,0)
 Q
"RTN","DGRPCADD")
0^1^B22281332
"RTN","DGRPCADD",1,0)
DGRPCADD ;ALB/MRL,BAJ,TDM,JAM - REGISTRATION SCREEN 1.1/CONFIDENTIAL ADDRESS INFORMATION ;19 Jul 2017  3:05 PM
"RTN","DGRPCADD",2,0)
 ;;5.3;Registration;**489,624,688,754,887,941**;Aug 13, 1993;Build 73
"RTN","DGRPCADD",3,0)
 ;
"RTN","DGRPCADD",4,0)
 ;;**688 BAJ Jan 17,2006 Modifications to support Foreign addresses
"RTN","DGRPCADD",5,0)
 ;;**941 JAM Apr 18,2017 Reformat of screen 1.1 - new field layouts
"RTN","DGRPCADD",6,0)
 ;
"RTN","DGRPCADD",7,0)
 N DGA,DGA1,DGA2,DGRP,DGAD,DGCAN,DGRPS,DGRPW,Z,Z1,DGZ,DGX,DGACT,DGCAT,DGI,DGTYP,DGTYPNAM,DGXX,CNT,DGBEG,DGEND,X,Y,I,I1
"RTN","DGRPCADD",8,0)
 S DGRPS=1.1 D H^DGRPU
"RTN","DGRPCADD",9,0)
 W ! S Z=1,DGRPW=0 D WW^DGRPV W " Residential Address: " S Z=" ",Z1=17
"RTN","DGRPCADD",10,0)
 D WW1^DGRPV S Z=2,DGRPW=0 D WW^DGRPV W " Permanent Mailing Address: "
"RTN","DGRPCADD",11,0)
 F I=.11,.121,.122,.13,.115,.141 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPCADD",12,0)
 ;S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
"RTN","DGRPCADD",13,0)
 S DGAD=.115,(DGA1,DGA2)=1 D AL^DGRPU(35) S DGAD=.11,DGA1=1,DGA2=2 D AL^DGRPU(35)
"RTN","DGRPCADD",14,0)
 W !?5
"RTN","DGRPCADD",15,0)
 S Z1=39,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO PERMANENT MAILING ADDRESS")
"RTN","DGRPCADD",16,0)
 ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
"RTN","DGRPCADD",17,0)
 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>40) !?5 W:'(I#2) ?44 W DGA(I)
"RTN","DGRPCADD",18,0)
 N DGCC
"RTN","DGRPCADD",19,0)
 S DGCC=$$COUNTY(.DGRP,.115)  ; print County if applicable
"RTN","DGRPCADD",20,0)
 W !?5,"County: "_DGCC
"RTN","DGRPCADD",21,0)
 S DGCC=$$COUNTY(.DGRP,.11)  ; print County if applicable
"RTN","DGRPCADD",22,0)
 W ?44,"County: "_DGCC
"RTN","DGRPCADD",23,0)
 W !?6,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU)
"RTN","DGRPCADD",24,0)
 W ?42,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
"RTN","DGRPCADD",25,0)
 W !?5,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
"RTN","DGRPCADD",26,0)
 W !!
"RTN","DGRPCADD",27,0)
 K DGA,DGA1,DGA2
"RTN","DGRPCADD",28,0)
 I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,(DGA1,DGA2)=1 D AL^DGRPU(30)
"RTN","DGRPCADD",29,0)
 I $P(DGRP(.141),"^",9)="Y" I $P($$CAACT(DFN),U) S DGAD=.141,DGA1=1,DGA2=2 D AL^DGRPU(30)
"RTN","DGRPCADD",30,0)
 S Z=3 D WW^DGRPV W " Temporary Mailing Address: " S Z=" ",Z1=11
"RTN","DGRPCADD",31,0)
 D WW1^DGRPV S Z=4,DGRPW=0 D WW^DGRPV W " Confidential Mailing Address: "
"RTN","DGRPCADD",32,0)
 W !?5
"RTN","DGRPCADD",33,0)
 S Z1=39,Z=$S($D(DGA(1)):DGA(1),1:"NO TEMPORARY MAILING ADDRESS") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NONE ON FILE")
"RTN","DGRPCADD",34,0)
 ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
"RTN","DGRPCADD",35,0)
 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>40) !?5 W:'(I#2) ?44 W DGA(I)
"RTN","DGRPCADD",36,0)
 W !
"RTN","DGRPCADD",37,0)
 I $D(DGA(1)) D
"RTN","DGRPCADD",38,0)
 .S DGCC=$$COUNTY(.DGRP,.121)  ; print County if applicable
"RTN","DGRPCADD",39,0)
 .W ?5,"County: "_DGCC
"RTN","DGRPCADD",40,0)
 I $D(DGA(2)) I $P($$CAACT(DFN),U) D
"RTN","DGRPCADD",41,0)
 .S DGCC=$$COUNTY(.DGRP,.141)  ; print County if applicable
"RTN","DGRPCADD",42,0)
 .W ?44,"County: "_DGCC
"RTN","DGRPCADD",43,0)
 W !?6,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
"RTN","DGRPCADD",44,0)
 W ?45,"Phone: ",$S($P(DGRP(.141),U,9)'="Y":"NOT APPLICABLE",'$P($$CAACT(DFN),U):"NOT APPLICABLE",$P(DGRP(.13),U,15)]"":$P(DGRP(.13),U,15),1:DGRPU)
"RTN","DGRPCADD",45,0)
 S X="NOT APPLICABLE"
"RTN","DGRPCADD",46,0)
 I $P(DGRP(.121),U,9)="Y" D
"RTN","DGRPCADD",47,0)
 .S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD")
"RTN","DGRPCADD",48,0)
 .S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD")
"RTN","DGRPCADD",49,0)
 .S X=X_$S(Y]"":Y,1:DGRPU)
"RTN","DGRPCADD",50,0)
 W !?2,"From/To: ",X
"RTN","DGRPCADD",51,0)
 S DGX="NOT APPLICABLE"
"RTN","DGRPCADD",52,0)
 I $P(DGRP(.141),U,9)="Y" I $P($$CAACT(DFN),U) D
"RTN","DGRPCADD",53,0)
 .S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D
"RTN","DGRPCADD",54,0)
 ..I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y
"RTN","DGRPCADD",55,0)
 ..I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED")
"RTN","DGRPCADD",56,0)
 W ?43,"From/To: "_DGX
"RTN","DGRPCADD",57,0)
 W !?38,"Categories: " I $D(^DPT(DFN,.14)) D
"RTN","DGRPCADD",58,0)
 .; if Confidential Address not active, don't display categories
"RTN","DGRPCADD",59,0)
 .I $P(DGRP(.141),U,9)'="Y" Q
"RTN","DGRPCADD",60,0)
 .I '$P($$CAACT(DFN),U) Q
"RTN","DGRPCADD",61,0)
 .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
"RTN","DGRPCADD",62,0)
 .S DGX="",DGCAN="" F  S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN=""  D
"RTN","DGRPCADD",63,0)
 ..Q:'$D(^DPT(DFN,.14,DGCAN,0))
"RTN","DGRPCADD",64,0)
 ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2)
"RTN","DGRPCADD",65,0)
 ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
"RTN","DGRPCADD",66,0)
 ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM=""  D
"RTN","DGRPCADD",67,0)
 ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
"RTN","DGRPCADD",68,0)
 S DGXX="",CNT=0 F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX=""  D
"RTN","DGRPCADD",69,0)
 .W:CNT>0 !
"RTN","DGRPCADD",70,0)
 .W ?38,DGXX
"RTN","DGRPCADD",71,0)
 .S CNT=CNT+1
"RTN","DGRPCADD",72,0)
 ; line feed before continuing
"RTN","DGRPCADD",73,0)
 W !
"RTN","DGRPCADD",74,0)
 G ^DGRPP
"RTN","DGRPCADD",75,0)
CAACT(DFN,ACTDT) ;Determines if the Confidential Address is active
"RTN","DGRPCADD",76,0)
 ;Input:  DFN - Patient (#2) file internal entry number (Required)
"RTN","DGRPCADD",77,0)
 ;        ACTDT - Date used to determine if address is active 
"RTN","DGRPCADD",78,0)
 ;                (Optional) Defaults to DT if not defined. 
"RTN","DGRPCADD",79,0)
 ;
"RTN","DGRPCADD",80,0)
 ;Output:
"RTN","DGRPCADD",81,0)
 ;   1st piece 0 inactive based on start/stop dates
"RTN","DGRPCADD",82,0)
 ;             1 active based on start/stop dates
"RTN","DGRPCADD",83,0)
 ;   2nd piece 0 - no active correspondence types
"RTN","DGRPCADD",84,0)
 ;             1 - at least one active correspondence type
"RTN","DGRPCADD",85,0)
 ;
"RTN","DGRPCADD",86,0)
 N DGCA,DGCABEG,DGCAEND,DGSTAT,DGIEN,DGTYP,DGFLG
"RTN","DGRPCADD",87,0)
 S DGSTAT="0^0"
"RTN","DGRPCADD",88,0)
 I '$D(DFN) Q DGSTAT
"RTN","DGRPCADD",89,0)
 I '$D(ACTDT) S ACTDT=DT
"RTN","DGRPCADD",90,0)
 S DGCA=$G(^DPT(DFN,.141)) D
"RTN","DGRPCADD",91,0)
 .I DGCA="" Q
"RTN","DGRPCADD",92,0)
 .S DGCABEG=$P(DGCA,U,7)
"RTN","DGRPCADD",93,0)
 .S DGCAEND=$P(DGCA,U,8)
"RTN","DGRPCADD",94,0)
 .I 'DGCABEG!(DGCABEG>ACTDT)!(DGCAEND&(DGCAEND<ACTDT)) Q
"RTN","DGRPCADD",95,0)
 .S DGSTAT="1^0"
"RTN","DGRPCADD",96,0)
 ;Build array of correspondence types
"RTN","DGRPCADD",97,0)
 S (DGIEN,DGFLG)=0
"RTN","DGRPCADD",98,0)
 F  S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN  D  Q:DGFLG
"RTN","DGRPCADD",99,0)
 .S DGTYP=$G(^DPT(DFN,.14,+DGIEN,0))
"RTN","DGRPCADD",100,0)
 .I $P(DGTYP,U,2)="Y" S DGFLG=1
"RTN","DGRPCADD",101,0)
 S $P(DGSTAT,U,2)=$S(DGFLG=1:1,1:0)
"RTN","DGRPCADD",102,0)
 Q DGSTAT
"RTN","DGRPCADD",103,0)
 ;JAM - Patch DG*5.3*941 - return county
"RTN","DGRPCADD",104,0)
COUNTY(DGRP,FNODE) ;retrieve County info if a US address
"RTN","DGRPCADD",105,0)
 N CNODE,FCPE,IEN,DGCC,PIECE
"RTN","DGRPCADD",106,0)
 S DGCC=""
"RTN","DGRPCADD",107,0)
 ; default data location of address County info
"RTN","DGRPCADD",108,0)
 S PIECE=7,FCPE=10,CNODE=FNODE
"RTN","DGRPCADD",109,0)
 ; data location of Temporary address County info
"RTN","DGRPCADD",110,0)
 I FNODE=.121 S FCPE=3,PIECE=11,CNODE=.122
"RTN","DGRPCADD",111,0)
 ; data location of Confidential address County info
"RTN","DGRPCADD",112,0)
 I FNODE=.141 S PIECE=11,FCPE=16
"RTN","DGRPCADD",113,0)
 S IEN=$P(DGRP(CNODE),U,FCPE)
"RTN","DGRPCADD",114,0)
 I '$$FORIEN^DGADDUTL(IEN) D
"RTN","DGRPCADD",115,0)
 .S DGCC=$S($D(^DIC(5,+$P(DGRP(FNODE),U,5),1,+$P(DGRP(FNODE),U,PIECE),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU)
"RTN","DGRPCADD",116,0)
 E  S DGCC="NOT APPLICABLE"
"RTN","DGRPCADD",117,0)
 Q DGCC
"RTN","DGRPD")
0^7^B102167809
"RTN","DGRPD",1,0)
DGRPD ;ALB/MRL,MLR,JAN,LBD,EG,BRM,JRC,BAJ,JAM-PATIENT INQUIRY (NEW) ;July 09, 2014  12:16pm
"RTN","DGRPD",2,0)
 ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,688,887,907,925,936,940,941**;Aug 13, 1993;Build 73
"RTN","DGRPD",3,0)
 ; *286* Newing variables X,Y in OKLINE subroutine
"RTN","DGRPD",4,0)
 ; *358* If a patient is on a domiciliary ward, don't display MEANS
"RTN","DGRPD",5,0)
 ; TEST required/Medication Copayment Exemption messages
"RTN","DGRPD",6,0)
 ; *436* If an inpatient is not on a domiciliary ward, don't display
"RTN","DGRPD",7,0)
 ; Medication Copayment Exemption message
"RTN","DGRPD",8,0)
 ; *545* Add death information near the remarks field
"RTN","DGRPD",9,0)
 ; *677* Added Emergency Response
"RTN","DGRPD",10,0)
 ; *688* Modified to display Country and Foreign Address
"RTN","DGRPD",11,0)
 ; *936* Modified to display Health Benefit Plans
"RTN","DGRPD",12,0)
 ; *940* #879316,#879318 - Display Permanent & Total Disabled Status
"RTN","DGRPD",13,0)
 ; *941* #887088 - Redesign of Inquiry Screen layout for displaying the addresses 
"RTN","DGRPD",14,0)
 ;
"RTN","DGRPD",15,0)
 ; Integration Agreements:
"RTN","DGRPD",16,0)
 ; 6138 - DGHBPUTL API
"RTN","DGRPD",17,0)
 ;
"RTN","DGRPD",18,0)
SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL
"RTN","DGRPD",19,0)
EN ;call to display patient inquiry - input DFN
"RTN","DGRPD",20,0)
 ;MPI/PD CHANGE
"RTN","DGRPD",21,0)
 S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
"RTN","DGRPD",22,0)
 K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR^DGRPD1
"RTN","DGRPD",23,0)
 ;JAM begin changes Patch DG*5.3*941 add .115 and new address fields layout
"RTN","DGRPD",24,0)
 F I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3,.115 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPD",25,0)
 ;jam DG*5.3*925 RM#788099 change labels to "Permanent Mailing Address" and "Temporary Mailing Address"
"RTN","DGRPD",26,0)
 ;
"RTN","DGRPD",27,0)
 W " Residential Address: "
"RTN","DGRPD",28,0)
 W ?40,"Permanent Mailing Address: "
"RTN","DGRPD",29,0)
 S DGAD=.115,(DGA1,DGA2)=1 D AL^DGRPU(35) S DGAD=.11,DGA1=1,DGA2=2 D AL^DGRPU(35)
"RTN","DGRPD",30,0)
 W !?5
"RTN","DGRPD",31,0)
 N Z,Z1
"RTN","DGRPD",32,0)
 S Z1=39,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO PERMANENT MAILING ADDRESS")
"RTN","DGRPD",33,0)
 ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
"RTN","DGRPD",34,0)
 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>40) !?5 W:'(I#2) ?44 W DGA(I)
"RTN","DGRPD",35,0)
 N DGCC
"RTN","DGRPD",36,0)
 S DGCC=$$COUNTY^DGRPCADD(.DGRP,.115) ; print County if applicable
"RTN","DGRPD",37,0)
 W !?5,"County: "_DGCC
"RTN","DGRPD",38,0)
 S DGCC=$$COUNTY^DGRPCADD(.DGRP,.11) ; print County if applicable
"RTN","DGRPD",39,0)
 W ?44,"County: "_DGCC
"RTN","DGRPD",40,0)
 W !?6,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU)
"RTN","DGRPD",41,0)
 W ?42,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
"RTN","DGRPD",42,0)
 W !?5,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
"RTN","DGRPD",43,0)
 W ?46,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)
"RTN","DGRPD",44,0)
 W !?44,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)
"RTN","DGRPD",45,0)
 W !!
"RTN","DGRPD",46,0)
 K DGA,DGA1,DGA2
"RTN","DGRPD",47,0)
 I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,(DGA1,DGA2)=1 D AL^DGRPU(30)
"RTN","DGRPD",48,0)
 N CONACT
"RTN","DGRPD",49,0)
 ; set Confidential Active Flag
"RTN","DGRPD",50,0)
 S CONACT=$P(DGRP(.141),"^",9)
"RTN","DGRPD",51,0)
 I CONACT="Y" D
"RTN","DGRPD",52,0)
 .; check the begin/end dates, set active flag to NO and do not display if outside the date range 
"RTN","DGRPD",53,0)
 .N DGCABEG,DGCAEND,DGI
"RTN","DGRPD",54,0)
 .S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
"RTN","DGRPD",55,0)
 .I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) S CONACT="N" Q
"RTN","DGRPD",56,0)
 .S DGAD=.141,DGA1=1,DGA2=2 D AL^DGRPU(30)
"RTN","DGRPD",57,0)
 W " Temporary Mailing Address: "
"RTN","DGRPD",58,0)
 W ?40,"Confidential Mailing Address: "
"RTN","DGRPD",59,0)
 W !?5
"RTN","DGRPD",60,0)
 W $S($D(DGA(1)):DGA(1),1:"NO TEMPORARY MAILING ADDRESS") W ?44,$S($D(DGA(2)):DGA(2),1:"NONE ON FILE")
"RTN","DGRPD",61,0)
 ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
"RTN","DGRPD",62,0)
 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>40) !?5 W:'(I#2) ?44 W DGA(I)
"RTN","DGRPD",63,0)
 W !
"RTN","DGRPD",64,0)
 I $D(DGA(1)) D
"RTN","DGRPD",65,0)
 .S DGCC=$$COUNTY^DGRPCADD(.DGRP,.121) ; print County if applicable 
"RTN","DGRPD",66,0)
 .W ?5,"County: "_DGCC
"RTN","DGRPD",67,0)
 I $D(DGA(2)) D
"RTN","DGRPD",68,0)
 .S DGCC=$$COUNTY^DGRPCADD(.DGRP,.141) ; print County if applicable
"RTN","DGRPD",69,0)
 .W ?44,"County: "_DGCC
"RTN","DGRPD",70,0)
 ;W !?2,"CASS Cert: "_$S($P(DGRP(.121),U,15)="Y":"Certified",$P(DGRP(.121),U,15)="F":"Failed",1:"NC")
"RTN","DGRPD",71,0)
 ;W ?41,"CASS Cert: "_$S($P(DGRP(.141),U,17)="Y":"Certified",$P(DGRP(.141),U,17)="F":"Failed",1:"NC")
"RTN","DGRPD",72,0)
 W !?6,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
"RTN","DGRPD",73,0)
 W ?45,"Phone: ",$S($P(DGRP(.141),U,9)'="Y":"NOT APPLICABLE",CONACT'="Y":"NOT APPLICABLE",$P(DGRP(.13),U,15)]"":$P(DGRP(.13),U,15),1:DGRPU)
"RTN","DGRPD",74,0)
 S X="NOT APPLICABLE"
"RTN","DGRPD",75,0)
 I $P(DGRP(.121),U,9)="Y" D
"RTN","DGRPD",76,0)
 .S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD")
"RTN","DGRPD",77,0)
 .S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD")
"RTN","DGRPD",78,0)
 .S X=X_$S(Y]"":Y,1:DGRPU)
"RTN","DGRPD",79,0)
 N DGACT,DGTYP,DGCAN,DGBEG,DGEND,DGZ,DGXX,DGX,DGTYPNAM,DGCAT
"RTN","DGRPD",80,0)
 W !?2,"From/To: ",X
"RTN","DGRPD",81,0)
 S DGX="NOT APPLICABLE"
"RTN","DGRPD",82,0)
 I CONACT="Y" D
"RTN","DGRPD",83,0)
 .S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D
"RTN","DGRPD",84,0)
 ..I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y
"RTN","DGRPD",85,0)
 ..I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED")
"RTN","DGRPD",86,0)
 W ?43,"From/To: "_DGX
"RTN","DGRPD",87,0)
 W !?41,"Confidential Address Categories: " I $D(^DPT(DFN,.14)) D
"RTN","DGRPD",88,0)
 .; If not active, do not display categories
"RTN","DGRPD",89,0)
 .I CONACT'="Y" Q
"RTN","DGRPD",90,0)
 .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
"RTN","DGRPD",91,0)
 .S DGX="",DGCAN="" F  S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN=""  D
"RTN","DGRPD",92,0)
 ..Q:'$D(^DPT(DFN,.14,DGCAN,0))
"RTN","DGRPD",93,0)
 ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2)
"RTN","DGRPD",94,0)
 ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
"RTN","DGRPD",95,0)
 ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM=""  D
"RTN","DGRPD",96,0)
 ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
"RTN","DGRPD",97,0)
 S DGXX="" F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX=""  D
"RTN","DGRPD",98,0)
 .W !?42,DGXX
"RTN","DGRPD",99,0)
 ;
"RTN","DGRPD",100,0)
 I '$$OKLINE^DGRPD1(16) G Q
"RTN","DGRPD",101,0)
 N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))
"RTN","DGRPD",102,0)
 W:DGEMER]"" !?32,"Emergency Response: ",DGEMER
"RTN","DGRPD",103,0)
 I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED")
"RTN","DGRPD",104,0)
 I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Birth Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED") ; DG*5.3*907
"RTN","DGRPD",105,0)
 I 'DGABBRV W ! D
"RTN","DGRPD",106,0)
 .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
"RTN","DGRPD",107,0)
 .K ^UTILITY($J,"W")
"RTN","DGRPD",108,0)
 .S PTR=0 F  S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR  D
"RTN","DGRPD",109,0)
 ..S VAL=+$G(^DPT(DFN,.02,PTR,0))
"RTN","DGRPD",110,0)
 ..Q:$$INACTIVE^DGUTL4(VAL,1)
"RTN","DGRPD",111,0)
 ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
"RTN","DGRPD",112,0)
 ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
"RTN","DGRPD",113,0)
 .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
"RTN","DGRPD",114,0)
 .K ^UTILITY($J,"W")
"RTN","DGRPD",115,0)
 .S PTR=0 F  S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR  D
"RTN","DGRPD",116,0)
 ..S VAL=+$G(^DPT(DFN,.06,PTR,0))
"RTN","DGRPD",117,0)
 ..Q:$$INACTIVE^DGUTL4(VAL,2)
"RTN","DGRPD",118,0)
 ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
"RTN","DGRPD",119,0)
 ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
"RTN","DGRPD",120,0)
 .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
"RTN","DGRPD",121,0)
 .K ^UTILITY($J,"W")
"RTN","DGRPD",122,0)
 .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
"RTN","DGRPD",123,0)
 .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0))  W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
"RTN","DGRPD",124,0)
 I '$$OKLINE^DGRPD1(16) G Q
"RTN","DGRPD",125,0)
 D LANGUAGE
"RTN","DGRPD",126,0)
 I '$$OKLINE^DGRPD1(10) G Q
"RTN","DGRPD",127,0)
 ;display cv status #4156
"RTN","DGRPD",128,0)
 N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
"RTN","DGRPD",129,0)
 W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
"RTN","DGRPD",130,0)
 ;display primary eligibility
"RTN","DGRPD",131,0)
 S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
"RTN","DGRPD",132,0)
 W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I  I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X
"RTN","DGRPD",133,0)
 I '$$OKLINE^DGRPD1(16) G Q
"RTN","DGRPD",134,0)
 ;employability status
"RTN","DGRPD",135,0)
 W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")
"RTN","DGRPD",136,0)
 I '$$OKLINE^DGRPD1(19) G Q
"RTN","DGRPD",137,0)
 ; KUM DG*5.3*940 RM #879316,#879318 - Display Permanent & Total Disabled status
"RTN","DGRPD",138,0)
 W !?6,"Permanent & Total Disabled: ",$S($P(DGRP(.3),U,4)="Y":"YES",1:"NO")
"RTN","DGRPD",139,0)
 I '$$OKLINE^DGRPD1(19) G Q
"RTN","DGRPD",140,0)
 ;display the catastrophic disability review date if there is one
"RTN","DGRPD",141,0)
 D CATDIS^DGRPD1
"RTN","DGRPD",142,0)
 I $G(DGPRFLG)=1 G Q:'$$OKLINE^DGRPD1(19) D
"RTN","DGRPD",143,0)
 . N DGPDT,DGPTM
"RTN","DGRPD",144,0)
 . W !,$$REPEAT^XLFSTR("-",78)
"RTN","DGRPD",145,0)
 . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
"RTN","DGRPD",146,0)
 . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
"RTN","DGRPD",147,0)
 . S DGPTM=$$PCTEAM^DGSDUTL(DFN)
"RTN","DGRPD",148,0)
 . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
"RTN","DGRPD",149,0)
 . W !,$$REPEAT^XLFSTR("-",78)
"RTN","DGRPD",150,0)
 ; Check if patient is an inpatient and on a DOM ward
"RTN","DGRPD",151,0)
 ; If inpatient is on a DOM ward, don't display MT or CP messages
"RTN","DGRPD",152,0)
 ; If inpatient is NOT on a DOM ward, don't display CP message
"RTN","DGRPD",153,0)
 N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
"RTN","DGRPD",154,0)
 G Q:'$$OKLINE^DGRPD1(16)
"RTN","DGRPD",155,0)
 D DOM^DGMTR
"RTN","DGRPD",156,0)
 I '$G(DGDOM) D
"RTN","DGRPD",157,0)
 .D DIS^DGMTU(DFN)
"RTN","DGRPD",158,0)
 .D IN5^VADPT
"RTN","DGRPD",159,0)
 .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
"RTN","DGRPD",160,0)
 ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
"RTN","DGRPD",161,0)
 D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518)
"RTN","DGRPD",162,0)
 S VAIP("L")=""
"RTN","DGRPD",163,0)
 I $$OKLINE^DGRPD1(14) D INP
"RTN","DGRPD",164,0)
 I '$G(DGRPOUT),($$OKLINE^DGRPD1(10)) D SA ;*KNR*
"RTN","DGRPD",165,0)
 ;MPI/PD CHANGE
"RTN","DGRPD",166,0)
Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q
"RTN","DGRPD",167,0)
 ;
"RTN","DGRPD",168,0)
INP S VAIP("D")="L" D INP^DGPMV10
"RTN","DGRPD",169,0)
 S DGPMT=0
"RTN","DGRPD",170,0)
 D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
"RTN","DGRPD",171,0)
SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE^DGRPD1(17) SAA Q:$G(DGRPOUT)
"RTN","DGRPD",172,0)
 Q
"RTN","DGRPD",173,0)
SAA ;Scheduled Admit Data
"RTN","DGRPD",174,0)
 W !!?14,"Scheduled Admit"
"RTN","DGRPD",175,0)
 W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
"RTN","DGRPD",176,0)
 W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
"RTN","DGRPD",177,0)
 W " on "_$$FMTE^XLFDT(L,"5DZ")
"RTN","DGRPD",178,0)
 Q  ;SAA
"RTN","DGRPD",179,0)
 ;
"RTN","DGRPD",180,0)
CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I  I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")
"RTN","DGRPD",181,0)
 ;
"RTN","DGRPD",182,0)
FA ;
"RTN","DGRPD",183,0)
 N DGARRAY,SDCNT
"RTN","DGRPD",184,0)
 S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
"RTN","DGRPD",185,0)
 S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "
"RTN","DGRPD",186,0)
 ;if there is lower subscripts hanging from the 101 node,
"RTN","DGRPD",187,0)
 ;then it is a valid appointment, otherwise it is
"RTN","DGRPD",188,0)
 ;an error eg 01/20/2005
"RTN","DGRPD",189,0)
 ;G:'$$OKLINE^DGRPD1(13) RMK ;*///*
"RTN","DGRPD",190,0)
 I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK
"RTN","DGRPD",191,0)
 I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK
"RTN","DGRPD",192,0)
 ;
"RTN","DGRPD",193,0)
 W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
"RTN","DGRPD",194,0)
 F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D  Q:CT>5
"RTN","DGRPD",195,0)
 .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")
"RTN","DGRPD",196,0)
 .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D
"RTN","DGRPD",197,0)
 ..D COV
"RTN","DGRPD",198,0)
 ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
"RTN","DGRPD",199,0)
 ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)
"RTN","DGRPD",200,0)
 ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
"RTN","DGRPD",201,0)
 ..Q
"RTN","DGRPD",202,0)
 I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."
"RTN","DGRPD",203,0)
RMK I '$G(DGRPOUT),($$OKLINE^DGRPD1(15)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) ;*///*
"RTN","DGRPD",204,0)
 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
"RTN","DGRPD",205,0)
 W !!
"RTN","DGRPD",206,0)
 W "Date of Death Information"
"RTN","DGRPD",207,0)
 W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
"RTN","DGRPD",208,0)
 W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
"RTN","DGRPD",209,0)
 W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
"RTN","DGRPD",210,0)
 W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
"RTN","DGRPD",211,0)
 I $$OKLINE^DGRPD1(14) D EC^DGRPD1
"RTN","DGRPD",212,0)
 ; KUM DG*5.3*936 Call tag to display Health Benefit Plans assigned to Veteran
"RTN","DGRPD",213,0)
 D HBP
"RTN","DGRPD",214,0)
 K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
"RTN","DGRPD",215,0)
 Q
"RTN","DGRPD",216,0)
 ; KUM DG*5.3*936 Display Health Benefit Plans assigned to Veteran
"RTN","DGRPD",217,0)
HBP W !!,"Health Benefit Plans Currently Assigned to Veteran:"
"RTN","DGRPD",218,0)
 N DGHBP,HBP,DGCOUNT
"RTN","DGRPD",219,0)
 S DGCOUNT=0
"RTN","DGRPD",220,0)
 D GETHBP^DGHBPUTL(DFN)
"RTN","DGRPD",221,0)
 S DGHBP="" F  S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP=""  D
"RTN","DGRPD",222,0)
 .W !,?3,DGHBP
"RTN","DGRPD",223,0)
 .S DGCOUNT=DGCOUNT+1
"RTN","DGRPD",224,0)
 I DGCOUNT=0 W !,?3,"None"
"RTN","DGRPD",225,0)
 Q
"RTN","DGRPD",226,0)
 ;
"RTN","DGRPD",227,0)
COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
"RTN","DGRPD",228,0)
 S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q
"RTN","DGRPD",229,0)
 Q
"RTN","DGRPD",230,0)
 ;
"RTN","DGRPD",231,0)
OREN S XQORQUIT=1 Q:'$D(ORVP)  S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
"RTN","DGRPD",232,0)
 Q
"RTN","DGRPD",233,0)
LANGUAGE ; Get language data *///*
"RTN","DGRPD",234,0)
 S DGLANGDT=9999999,(DGPRFLAN,DGLANG0)=""
"RTN","DGRPD",235,0)
 S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1)
"RTN","DGRPD",236,0)
 I DGLANGDT="" G L1
"RTN","DGRPD",237,0)
 S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0))
"RTN","DGRPD",238,0)
 S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2)
"RTN","DGRPD",239,0)
 S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y
"RTN","DGRPD",240,0)
L1 W !!,"Language Date/Time: ",$S(DGLANGDT="":"UNANSWERED",1:DGLANGDT),!
"RTN","DGRPD",241,0)
 W ?1,"Preferred Language: ",$S(DGPRFLAN="":"UNANSWERED",1:DGPRFLAN)
"RTN","DGRPD",242,0)
 K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA
"RTN","DGRPD",243,0)
 Q
"RTN","DGRPE")
0^4^B78319537
"RTN","DGRPE",1,0)
DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ,PWC,JAM - REGISTRATIONS EDITS ;23 May 2017  1:51 PM
"RTN","DGRPE",2,0)
 ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,688,797,842,865,871,887,941**;Aug 13, 1993;Build 73
"RTN","DGRPE",3,0)
 ;
"RTN","DGRPE",4,0)
 ;DGDR contains a string of edits; edit=screen*10+item #
"RTN","DGRPE",5,0)
 ;
"RTN","DGRPE",6,0)
 ;line tag screen*10+item*1000 = continuation line
"RTN","DGRPE",7,0)
 ;
"RTN","DGRPE",8,0)
 I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
"RTN","DGRPE",9,0)
 I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
"RTN","DGRPE",10,0)
 I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
"RTN","DGRPE",11,0)
 I DGRPS=5,DGDR["501," D
"RTN","DGRPE",12,0)
 .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
"RTN","DGRPE",13,0)
 .D REG^IBCNBME(DFN)
"RTN","DGRPE",14,0)
 .Q
"RTN","DGRPE",15,0)
 N QUIT S QUIT=0
"RTN","DGRPE",16,0)
 I DGRPS=6,$S(DGDR["601,"!(DGDR["602,")!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
"RTN","DGRPE",17,0)
 .;Use new ListMan screen for Military Service Episodes (DG*5.3*797)
"RTN","DGRPE",18,0)
 . I DGDR["601," D EN^DGRP61(DFN)   ; MSEs
"RTN","DGRPE",19,0)
 . ; D SETDR("601,",.DR)
"RTN","DGRPE",20,0)
 . ; S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",21,0)
 . ; D ^DIE I $D(Y) S QUIT=1
"RTN","DGRPE",22,0)
 . ; S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
"RTN","DGRPE",23,0)
 . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
"RTN","DGRPE",24,0)
 . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
"RTN","DGRPE",25,0)
 I DGRPS=7,(DGDR["702,") D EN^DGRP7CP(DFN,.QUIT) I QUIT D Q Q  ;DG*5.3*842 screen 7 cp subscreen
"RTN","DGRPE",26,0)
 I DGRPS=11,(DGDR["1105,") D EN^DGR111(DFN) ;DG*5.3*871 screen 11 HBP subscreen
"RTN","DGRPE",27,0)
 ;-- Tricare screen #15
"RTN","DGRPE",28,0)
 I DGRPS=15 D EDIT^DGRP15,Q Q
"RTN","DGRPE",29,0)
 ;
"RTN","DGRPE",30,0)
 N DGPH,DGPHFLG
"RTN","DGRPE",31,0)
 K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",32,0)
 G ^DGRPE1:DGRPS>6
"RTN","DGRPE",33,0)
 I DGRPS=4 D ^DGRPE4
"RTN","DGRPE",34,0)
 D SETDR(DGDR,.DR)
"RTN","DGRPE",35,0)
 S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",36,0)
 D ^DIE
"RTN","DGRPE",37,0)
 ;check for Combat Vet status
"RTN","DGRPE",38,0)
 I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
"RTN","DGRPE",39,0)
 . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
"RTN","DGRPE",40,0)
 . S DIR(0)="EA" D ^DIR K DIR
"RTN","DGRPE",41,0)
 I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
"RTN","DGRPE",42,0)
Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
"RTN","DGRPE",43,0)
 Q
"RTN","DGRPE",44,0)
 ;
"RTN","DGRPE",45,0)
SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected
"RTN","DGRPE",46,0)
 N DGCT,DGDRS,J1,J2
"RTN","DGRPE",47,0)
 K DR S DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",48,0)
 F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
"RTN","DGRPE",49,0)
 . S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",50,0)
 . N J2
"RTN","DGRPE",51,0)
 . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",52,0)
 Q
"RTN","DGRPE",53,0)
 ;
"RTN","DGRPE",54,0)
S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
"RTN","DGRPE",55,0)
 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
"RTN","DGRPE",56,0)
 Q
"RTN","DGRPE",57,0)
 ;
"RTN","DGRPE",58,0)
SETFLDS(DGDR) ; Set up fields to edit
"RTN","DGRPE",59,0)
 Q
"RTN","DGRPE",60,0)
 ;
"RTN","DGRPE",61,0)
 ;DG*5.3*941 - JAM - Reg Screens 1 and 1.1 new formats - Lines below updated for new field locations
"RTN","DGRPE",62,0)
101 ;;
"RTN","DGRPE",63,0)
102 ;;1;
"RTN","DGRPE",64,0)
103 ;;.091;
"RTN","DGRPE",65,0)
104 ;;.134;.135;@21;S X=$$YN1316^DGRPE(DFN);S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)="") Y="@25";S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)]"") Y="@24";.133;S:($P($G(^DPT(DFN,.13)),U,16)="Y")&($G(X)="") Y="@21";S Y="@25";@24;.133///@;@25;.1317///NOW;
"RTN","DGRPE",66,0)
105 ;;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE;
"RTN","DGRPE",67,0)
 ;JAM; DG*5.3*941 - Tag 108 added for QUES^DGRPU1 (ICR 413) to edit the perm address with the home/office phone numbers since patch 941 removed these fields from the Perm Address edit logic
"RTN","DGRPE",68,0)
108 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
"RTN","DGRPE",69,0)
109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
"RTN","DGRPE",70,0)
111 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGRED(DFN,.FLG);D RESMVQ^DGREGCP1(DFN);
"RTN","DGRPE",71,0)
 ;JAM, DG*5.3*941, Home and Office phone numbers not associated with Perm Address - set flg(1)=0 so we don't edit phone numbers with permanent address
"RTN","DGRPE",72,0)
 ;CLT, Copy Permanent Mailing Address to Residential Address ;DG*5.3*941
"RTN","DGRPE",73,0)
 ; If Perm address is not null, go to update of address. Otherwise give user option to copy residential address to perm.
"RTN","DGRPE",74,0)
 ;  and if address is copied quit, otherwise continue with entering in a perm address. 
"RTN","DGRPE",75,0)
112 ;;S:$G(^DPT(DFN,.11))'="" Y="@30";D DR11^DGRPE S:$G(^DPT(DFN,.11))'="" Y="@31";
"RTN","DGRPE",76,0)
112000 ;;@30;N FLG S FLG(1)=0,FLG(2)=1 D EN^DGREGAED(DFN,.FLG) D PERMMVQ^DGREGCP1(DFN);@31;
"RTN","DGRPE",77,0)
113 ;;.12105TEMP MAILING ADDRESS ACTIVE;S:X="N" Y="@15";S DIE("NO^")="";.1217TEMP MAILING ADDRESS START DATE;.1218TEMP MAILING ADDRESS END DATE;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET Y=.12105;@15;K DIE("NO^");
"RTN","DGRPE",78,0)
114 ;;.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",79,0)
114000 ;;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",80,0)
201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;
"RTN","DGRPE",81,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",82,0)
203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
"RTN","DGRPE",83,0)
205 ;;.181;
"RTN","DGRPE",84,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",85,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",86,0)
302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
"RTN","DGRPE",87,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",88,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",89,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",90,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",91,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",92,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",93,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",94,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",95,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",96,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",97,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",98,0)
501 ;;
"RTN","DGRPE",99,0)
502 ;;.381;.382///NOW;
"RTN","DGRPE",100,0)
503 ;;.383;
"RTN","DGRPE",101,0)
601 ;;Q;
"RTN","DGRPE",102,0)
602 ;;Q;
"RTN","DGRPE",103,0)
603 ;;Q;
"RTN","DGRPE",104,0)
604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
"RTN","DGRPE",105,0)
605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
"RTN","DGRPE",106,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",107,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",108,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",109,0)
AD N DGZ4,DGPC
"RTN","DGRPE",110,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",111,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",112,0)
 K DGADD,DGPHONE Q
"RTN","DGRPE",113,0)
DR109 ;Drop through (use same logic as DR203)
"RTN","DGRPE",114,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",115,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",116,0)
 Q
"RTN","DGRPE",117,0)
DR11 ;clt; DG*5.3*941 - Called from line tag 112 if Perm address is empty
"RTN","DGRPE",118,0)
 Q:$G(^DPT(DFN,.115))=""
"RTN","DGRPE",119,0)
 ; If Residential Address exists, give user the option of copying residential to permanent address
"RTN","DGRPE",120,0)
 W !,"The Patient has no Permanent Mailing Address."
"RTN","DGRPE",121,0)
 D RESMVQ^DGREGCP1(DFN)
"RTN","DGRPE",122,0)
 Q
"RTN","DGRPE",123,0)
DR111 ; Set DR string for Confidential Address categories
"RTN","DGRPE",124,0)
 S DR(2,2.141)=".01;1//YES;"
"RTN","DGRPE",125,0)
 ;S DR(2,2.14)=".01;1//"_"YES"
"RTN","DGRPE",126,0)
 Q
"RTN","DGRPE",127,0)
DR207 ; DR string for preferred language ;*///*
"RTN","DGRPE",128,0)
 S DR(2,2.07)=".01;.02//ENGLISH;D LANGDEL^DGRPE"
"RTN","DGRPE",129,0)
 Q
"RTN","DGRPE",130,0)
DR301 ; set up variables for foreign address
"RTN","DGRPE",131,0)
 N DG3,DG33
"RTN","DGRPE",132,0)
 S DG4=0
"RTN","DGRPE",133,0)
 S DG3=$P($G(^DPT(DFN,.11)),U,10)
"RTN","DGRPE",134,0)
 S DG33=$O(^HL(779.004,"B","USA",""))
"RTN","DGRPE",135,0)
 I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1
"RTN","DGRPE",136,0)
 Q
"RTN","DGRPE",137,0)
PRF ; Write Proof needed for FV
"RTN","DGRPE",138,0)
 W !?4,$C(7),"Proof is required for Filipino vet."
"RTN","DGRPE",139,0)
 Q
"RTN","DGRPE",140,0)
 ;
"RTN","DGRPE",141,0)
SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA
"RTN","DGRPE",142,0)
 ; array with the BOS and component data for the SEQ military service
"RTN","DGRPE",143,0)
 ; episode (1-3)
"RTN","DGRPE",144,0)
 N I,Q,Z
"RTN","DGRPE",145,0)
 K DIPA(32,SEQ)
"RTN","DGRPE",146,0)
 S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
"RTN","DGRPE",147,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",148,0)
 Q
"RTN","DGRPE",149,0)
 ;
"RTN","DGRPE",150,0)
WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will
"RTN","DGRPE",151,0)
 ; be deleted
"RTN","DGRPE",152,0)
 ; Returns Y to skip component if the component should not be asked
"RTN","DGRPE",153,0)
 ;   for this branch of service
"RTN","DGRPE",154,0)
 N Z
"RTN","DGRPE",155,0)
 I '$$CMP(X) S Y="@601"_SEQ
"RTN","DGRPE",156,0)
 S Z=$G(DIPA(32,SEQ))
"RTN","DGRPE",157,0)
 Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
"RTN","DGRPE",158,0)
 ;
"RTN","DGRPE",159,0)
 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
"RTN","DGRPE",160,0)
 Q
"RTN","DGRPE",161,0)
 ;
"RTN","DGRPE",162,0)
CMP(X) ; Function to determine if service component is valid for
"RTN","DGRPE",163,0)
 ; branch of service ien in X   0 = invalid  1 = valid  
"RTN","DGRPE",164,0)
 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
"RTN","DGRPE",165,0)
 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
"RTN","DGRPE",166,0)
 ;
"RTN","DGRPE",167,0)
YN1316(DFN) ;Email address indicator - DG*5.3*865
"RTN","DGRPE",168,0)
 N %,RSLT
"RTN","DGRPE",169,0)
 S DIE("NO^")=""
"RTN","DGRPE",170,0)
P1316 ;
"RTN","DGRPE",171,0)
 S %=0
"RTN","DGRPE",172,0)
 W !,"DOES THE PATIENT HAVE AN EMAIL ADDRESS? Y/N"
"RTN","DGRPE",173,0)
 D YN^DICN
"RTN","DGRPE",174,0)
 I %=0 W !,"    If the patient has a valid Email Address, please answer with 'Yes'.",!,"    If no Email Address please answer with 'No'." G P1316
"RTN","DGRPE",175,0)
 I %=-1 W !,"    EXIT NOT ALLOWED ??" G P1316
"RTN","DGRPE",176,0)
 S RSLT=$S(%=1:"Y",%=2:"N")
"RTN","DGRPE",177,0)
 N FDA,IENS
"RTN","DGRPE",178,0)
 Q:'$G(DFN)
"RTN","DGRPE",179,0)
 S IENS=DFN_",",FDA(2,IENS,.1316)=RSLT
"RTN","DGRPE",180,0)
 D FILE^DIE("","FDA")
"RTN","DGRPE",181,0)
 Q RSLT
"RTN","DGRPE",182,0)
 ;
"RTN","DGRPE",183,0)
INPXF207 ; Input transform for field 7 in file ;*///*
"RTN","DGRPE",184,0)
 I $L(X)>60!($L(X)<1) K X Q
"RTN","DGRPE",185,0)
 I X="*" S X="DECLINED TO ANSWER",FMT="?($X+3)" D EN^DDIOL(X,"",FMT) Q
"RTN","DGRPE",186,0)
 I $D(X) DO
"RTN","DGRPE",187,0)
 .N DIC S DIC(0)="EQMN",DIC="^DI(.85,",DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]"""""
"RTN","DGRPE",188,0)
 .D ^DIC S:+Y>0 X=$P(^DI(.85,+Y,0),U) I +Y<0 K X
"RTN","DGRPE",189,0)
 Q
"RTN","DGRPE",190,0)
 ;
"RTN","DGRPE",191,0)
XHELP207 ; This is a screen to be sure the language is a 'living' language, i.e.in use today and that it has the required 2-character code. ;*///*
"RTN","DGRPE",192,0)
 N X S X="?" N DIC S DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]""""" S DIC(0)="EQM",DIC="^DI(.85," D ^DIC
"RTN","DGRPE",193,0)
 Q
"RTN","DGRPE",194,0)
 ;
"RTN","DGRPE",195,0)
LANGDEL ; If no language entered, remove the stub record ;*///*
"RTN","DGRPE",196,0)
 Q:'$G(D1)
"RTN","DGRPE",197,0)
 N X S X=$G(^DPT(DFN,.207,D1,0)) Q:X=""
"RTN","DGRPE",198,0)
 I $P(X,U,2)="" DO
"RTN","DGRPE",199,0)
 .W $C(7),!!,"No language was entered. Record deleted!",! H 3
"RTN","DGRPE",200,0)
 .S DIK="^DPT(DFN,.207,",DA=D1 D ^DIK K DIK
"RTN","DGRPE",201,0)
 Q
"RTN","DGRPH")
0^19^B27215074
"RTN","DGRPH",1,0)
DGRPH ;ALB/MRL,TMK,JAM - REGISTRATION HELP ROUTINE ;30 Oct 2017  3:03 PM
"RTN","DGRPH",2,0)
 ;;5.3;Registration;**114,343,397,415,489,545,638,624,689,842,941**;Aug 13, 1993;Build 73
"RTN","DGRPH",3,0)
 ;
"RTN","DGRPH",4,0)
 S DGRPH="" D H^DGRPU K DGRPH W !,"Enter '^' to stop the display ",$S(DGRPV:"",1:"and edit "),"of data, '^N' to jump to screen #N (see",!,"listing below), <RET> to continue on to the next available screen" I DGRPV W "." G M
"RTN","DGRPH",5,0)
 W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters.  Those groups enclosed in brackets ""[]"" are editable while those",!,"enclosed in arrows ""<>"" are not."
"RTN","DGRPH",6,0)
 W "  Enter 'ALL' to edit all editable data",!,"elements on the screen."
"RTN","DGRPH",7,0)
M I DGRPS=9,DGRPSEL="V" W !!,"You may precede your selection with 'V' to denote veteran."
"RTN","DGRPH",8,0)
 I DGRPS=9,DGRPSEL]"V" W !!,"To edit a specific column, enter 'V'",$S($D(DGREL("S")):", 'S'",1:""),$S($D(DGREL("D")):", 'D'",1:"")," in front of the selected items."
"RTN","DGRPH",9,0)
 S Z="DATA GROUPS ON SCREEN "_DGRPS,DGRPCM=1 W ! D WW^DGRPV S DGRPCM=0 D:DGRPS=1.1 A1 D:DGRPS'=1.1 @DGRPS D:$S(DGRPS<11:1,DGRPS=14:1,1:0) W D S W ! F I=$Y:1:20 W !
"RTN","DGRPH",10,0)
 ;S Z="Press RETURN key",DGRPCM=1 D WW^DGRPV S DGRPCM=0 W " to EXIT Screen ",DGRPS," HELP " R X:DTIME S X="" Q
"RTN","DGRPH",11,0)
 S DGRPW=0 W "Press " S Z="<RETURN>",DGRPCM=1 D WW^DGRPV W " KEY " S Z="TO EXIT" D WW^DGRPV W " SCREEN ",DGRPS," " S Z="HELP" D WW^DGRPV W " " R X:DTIME S (DGRPCM,DGRPW)=0 Q
"RTN","DGRPH",12,0)
 ;JAM; DG*5.3*941; Groups on screen 1 and 1.1 have changed so update help text to reflect new locations
"RTN","DGRPH",13,0)
1 S X="Name, SSN, DOB, Sex^Alias Name & SSN (if applicable)^Remarks concerning this patient^Cell Phone, Pager, E-Mail^Date & Time, Preferred Language" Q
"RTN","DGRPH",14,0)
A1 S X="Residential Address^Permanent Mailing Address^Temporary Mailing Address^Confidential Mailing Address" Q
"RTN","DGRPH",15,0)
2 S X="POB, Parents, etc.^Dates/Locations of Previous Care^Race and Ethnicity^Date of Death Information" Q
"RTN","DGRPH",16,0)
3 S X="Primary Next-of-Kin^Secondary Next-of-Kin^Primary Emergency Contact^Secondary Emergency Contact^Designee to receive personal effects" Q
"RTN","DGRPH",17,0)
4 S X="Applicant Employer, Address^Spouses Employer, Address" Q
"RTN","DGRPH",18,0)
5 S X="Unexpired Insurance Policies^Eligibile for Medicaid" Q
"RTN","DGRPH",19,0)
6 S X="Service History^Conflict Locations^Exposure Factors^Prisoner of War^Combat^Military Retirement/Disability^Dental History^Purple Heart Recipient^Medal of Honor^Class II Dental Indicator" Q
"RTN","DGRPH",20,0)
7 S X="Patient Type, SC Data, Claim Info^VA Monetary Benefits^POS, Eligibility Code(s)^SC Conditions relayed by applicant" Q
"RTN","DGRPH",21,0)
8 S X="Spouse's Demographic Info^Dependents' Demographic Info" Q
"RTN","DGRPH",22,0)
9 S X="Social Security^U.S. Civil Service^U.S. Railroad Retirement^Military Retirement^Unemployment^Other Retirement^Total Employment Income^Interest,Dividend,Annuity^Workers Comp or Black Lung^Other Income" Q
"RTN","DGRPH",23,0)
10 S X="Ineligible Patient Information^Missing Patient Information" Q
"RTN","DGRPH",24,0)
11 S X="Eligibility Verification^Monetary Benefits Verification^Service Record Verification^Rated Disabilities (VA)" Q
"RTN","DGRPH",25,0)
12 W !,"Four most recent admission episodes on file for this applicant are displayed",!,"in inverse order." Q
"RTN","DGRPH",26,0)
13 W !,"Four most recent applications for care (registrations) are displayed in",!,"inverse order." Q
"RTN","DGRPH",27,0)
14 S X="Clinics in which actively enrolled^Pending (future) appointments" Q
"RTN","DGRPH",28,0)
15 W !,"Sponsor information is displayed for patients."
"RTN","DGRPH",29,0)
S W ! S Z="AVAILABLE SCREENS",DGRPCM=1 D WW^DGRPV S DGRPCM=0
"RTN","DGRPH",30,0)
 ;jam; DG*5.3*941; New wording for screens 1 and 1.1
"RTN","DGRPH",31,0)
 S X="Patient Demographic^Additional Patient Demographic^Patient^Contact^Employment^Insurance^Service Record^Eligibility^Family Demographic^Income Screening^Missing/Ineligible^Eligibility Verification^"
"RTN","DGRPH",32,0)
 S X=X_"Admission Info^Application Info^Appointment Info^Sponsor Demographics"
"RTN","DGRPH",33,0)
 ;S C=0 F I=1:1 S J=$P(X,"^",I) Q:J=""  I '$E(DGRPVV,I) S C=C+1,Z="^"_I,DGRPW=(C#2) D WW^DGRPV S Z=$S(I?1N:"  ",1:" ")_J_" Data",Z1=$S((C#2)&(I?1N):36,(C#2):35,1:1) D WW1^DGRPV:(C#2) I '(C#2) W Z
"RTN","DGRPH",34,0)
 N DGJ
"RTN","DGRPH",35,0)
 S DGJ=""
"RTN","DGRPH",36,0)
 S C=0 F I=1:1 S DGJ=$O(DGRPVV(DGJ)) Q:DGJ=""  I '$E(DGRPVV,DGJ) D
"RTN","DGRPH",37,0)
 .S C=C+1,Z="^"_DGJ,DGRPW=(C#2)
"RTN","DGRPH",38,0)
 .D WW^DGRPV
"RTN","DGRPH",39,0)
 .;jam; DG*5.3*941; Change column position to fit the text of the new wording for screens 1 and 1.1
"RTN","DGRPH",40,0)
 .S Z1=$S((C#2)&(DGJ?1N):33,(C#2):32,1:1)
"RTN","DGRPH",41,0)
 .S Z=$S(DGJ?1N:"  ",1:" ")_$P(X,U,I)_" Data"
"RTN","DGRPH",42,0)
 .D WW1^DGRPV:(C#2)
"RTN","DGRPH",43,0)
 .I '(C#2) W Z
"RTN","DGRPH",44,0)
 Q
"RTN","DGRPH",45,0)
W F I=1:1 S J=$P(X,"^",I) Q:J=""  S Z=I,DGRPW=(I#2) D WW^DGRPV S Z=$S(I<10:"  ",1:" ")_J,Z1=$S((I#2)&(I>10):36,(I#2):37,1:1) D WW1^DGRPV
"RTN","DGRPH",46,0)
 W:'((I-1)#2) ! Q
"RTN","DGRPU")
0^2^B89347012
"RTN","DGRPU",1,0)
DGRPU ;ALB/MRL,TMK,BAJ,DJE,JAM - REGISTRATION UTILITY ROUTINE ;12/20/2005  5:37PM
"RTN","DGRPU",2,0)
 ;;5.3;Registration;**33,114,489,624,672,689,688,935,941**;Aug 13, 1993;Build 73
"RTN","DGRPU",3,0)
 ;
"RTN","DGRPU",4,0)
H ;Screen Header
"RTN","DGRPU",5,0)
 I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
"RTN","DGRPU",6,0)
 I DGRPS=1.1 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
"RTN","DGRPU",7,0)
 S X=$$SSNNM(DFN)
"RTN","DGRPU",8,0)
 I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
"RTN","DGRPU",9,0)
 S X="",$P(X,"=",80)="" W !,X Q
"RTN","DGRPU",10,0)
 Q
"RTN","DGRPU",11,0)
AL(DGLEN) ;DGLEN= Available length of line
"RTN","DGRPU",12,0)
A ;Format address(es)
"RTN","DGRPU",13,0)
 ; DG*5.3*688 BAJ 12/20/2005 modified for foreign address
"RTN","DGRPU",14,0)
 I '$D(DGLEN) N DGLEN S DGLEN=29
"RTN","DGRPU",15,0)
 N I,DGX,FILE,IEN,CNTRY,TMP,FNODE,FPCE,ROU
"RTN","DGRPU",16,0)
 ; set up variables
"RTN","DGRPU",17,0)
 S FNODE=$S(DGAD=.121:.122,1:DGAD),FPCE=$S(DGAD=.121:3,DGAD=.141:16,1:10)
"RTN","DGRPU",18,0)
 ; collect Street Address info
"RTN","DGRPU",19,0)
 F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S TMP(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2
"RTN","DGRPU",20,0)
 I DGA2=1 S TMP(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2
"RTN","DGRPU",21,0)
 ; retrieve country info -- PERM country is piece 10 of node .11
"RTN","DGRPU",22,0)
 S FOR=0
"RTN","DGRPU",23,0)
 I DGA1=1 D
"RTN","DGRPU",24,0)
 . S FILE=779.004,IEN=$P(DGRP(FNODE),U,FPCE),CNTRY=$E($$CNTRYI^DGADDUTL(IEN),1,25) I CNTRY=-1 S CNTRY="UNKNOWN COUNTRY"
"RTN","DGRPU",25,0)
 . ; assemble (US) CITY, STATE ZIP or (FOREIGN) CITY PROVINCE POSTAL CODE
"RTN","DGRPU",26,0)
 . S FOR=$$FORIEN^DGADDUTL(IEN) I FOR=-1 S FOR=1
"RTN","DGRPU",27,0)
 S ROU=$S(FOR=1:"FOREIGN",1:"US")_"(DGAD,.TMP,DGA1,.DGA2)" D @ROU
"RTN","DGRPU",28,0)
 ; append COUNTRY to address
"RTN","DGRPU",29,0)
 S DGA2=DGA2+2,TMP(DGA2)=$S($G(CNTRY)="":"",1:CNTRY)
"RTN","DGRPU",30,0)
 M DGA=TMP
"RTN","DGRPU",31,0)
 K DGA1
"RTN","DGRPU",32,0)
 Q
"RTN","DGRPU",33,0)
 ;
"RTN","DGRPU",34,0)
US(DGAD,TMP,DGA1,DGA2) ;process US addresses and format in DGA array
"RTN","DGRPU",35,0)
 ; DG*5.3*688 BAJ this is the code for all addresses prior to the addition of Foreign address logic.
"RTN","DGRPU",36,0)
 ; Modifications for Foreign address are in Tag FOREIGN
"RTN","DGRPU",37,0)
 N DGX,I,J
"RTN","DGRPU",38,0)
 ; format STATE field and merge with CITY & ZIP
"RTN","DGRPU",39,0)
 S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),TMP(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
"RTN","DGRPU",40,0)
 ; zip code capture
"RTN","DGRPU",41,0)
 I ".33^.34^.211^.331^.311^.25^.21"[DGAD D
"RTN","DGRPU",42,0)
 .F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I)
"RTN","DGRPU",43,0)
 E  D
"RTN","DGRPU",44,0)
 .I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q
"RTN","DGRPU",45,0)
 .; JAM - Patch DG*5.3*941, Residential address, zip code is piece 6
"RTN","DGRPU",46,0)
 .I DGAD=.115 S DGX=$P(DGRP(.115),U,6) Q
"RTN","DGRPU",47,0)
 .S DGX=$P(DGRP(DGAD),U,DGA1+11)
"RTN","DGRPU",48,0)
 ; format ZIP+4 with hyphen
"RTN","DGRPU",49,0)
 S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9)
"RTN","DGRPU",50,0)
 ;combine CITY,STATE and ZIP fields on a single line
"RTN","DGRPU",51,0)
 S TMP(DGA2)=$E($P(TMP(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(TMP(DGA2),",",2)):",",1:"")_$P(TMP(DGA2),",",2)_" "_DGX
"RTN","DGRPU",52,0)
 F I=0:0 S I=$O(TMP(I)) Q:'I  S TMP(I)=$E(TMP(I),1,DGLEN)
"RTN","DGRPU",53,0)
 Q
"RTN","DGRPU",54,0)
 ;
"RTN","DGRPU",55,0)
FOREIGN(DGAD,TMP,DGA1,DGA2) ;process FOREIGN addresses and format in DGA array
"RTN","DGRPU",56,0)
 N I,J,CITY,PRVNCE,PSTCD,FNODE
"RTN","DGRPU",57,0)
 F I=1:1 S J=$P($T(FNPCS+I),";;",3) Q:J="QUIT"  D
"RTN","DGRPU",58,0)
 . I DGAD=$P(J,";",1) S FNODE=$P(J,";",2),CITY=$P(J,";",3),PRVNCE=$P(J,";",4),PSTCD=$P(J,";",5)
"RTN","DGRPU",59,0)
 ; assemble CITY PROVINCE and POSTAL CODE on the same line
"RTN","DGRPU",60,0)
 ; NOTE CITY is sometimes on a different node than the PROVINCE & POSTAL CODE
"RTN","DGRPU",61,0)
 S TMP(DGA2)=$P(DGRP(FNODE),U,PSTCD)_" "_$P(DGRP(DGAD),U,CITY)_" "_$P(DGRP(FNODE),U,PRVNCE)
"RTN","DGRPU",62,0)
 F I=0:0 S I=$O(TMP(I)) Q:'I  S TMP(I)=$E(TMP(I),1,DGLEN)
"RTN","DGRPU",63,0)
 Q
"RTN","DGRPU",64,0)
 ;
"RTN","DGRPU",65,0)
W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q
"RTN","DGRPU",66,0)
 W ?X,@DGVI,Z,@DGVO
"RTN","DGRPU",67,0)
 Q
"RTN","DGRPU",68,0)
 ;
"RTN","DGRPU",69,0)
 ; JAM - Patch DG*5.3*941, Add Residential address type
"RTN","DGRPU",70,0)
FNPCS ; Foreign data pieces. Structure-->Description;;Main Node;Data Node;City;Province;Postal code.
"RTN","DGRPU",71,0)
 ;;Permanent;;.11;.11;4;8;9
"RTN","DGRPU",72,0)
 ;;Temporary;;.121;.122;4;1;2
"RTN","DGRPU",73,0)
 ;;Confidential;;.141;.141;4;14;15
"RTN","DGRPU",74,0)
 ;;Residential;;.115;.115;4;8;9
"RTN","DGRPU",75,0)
 ;;QUIT;;QUIT
"RTN","DGRPU",76,0)
 ;
"RTN","DGRPU",77,0)
H1 ;
"RTN","DGRPU",78,0)
 ;;PATIENT DEMOGRAPHIC DATA
"RTN","DGRPU",79,0)
 ;;PATIENT DATA
"RTN","DGRPU",80,0)
 ;;EMERGENCY CONTACT DATA
"RTN","DGRPU",81,0)
 ;;APPLICANT/SPOUSE EMPLOYMENT DATA
"RTN","DGRPU",82,0)
 ;;INSURANCE DATA
"RTN","DGRPU",83,0)
 ;;MILITARY SERVICE DATA
"RTN","DGRPU",84,0)
 ;;ELIGIBILITY STATUS DATA
"RTN","DGRPU",85,0)
 ;;FAMILY DEMOGRAPHIC DATA
"RTN","DGRPU",86,0)
 ;;INCOME SCREENING DATA
"RTN","DGRPU",87,0)
 ;;INELIGIBLE/MISSING DATA
"RTN","DGRPU",88,0)
 ;;ELIGIBILITY VERIFICATION DATA
"RTN","DGRPU",89,0)
 ;;ADMISSION INFORMATION
"RTN","DGRPU",90,0)
 ;;APPLICATION INFORMATION
"RTN","DGRPU",91,0)
 ;;APPOINTMENT INFORMATION
"RTN","DGRPU",92,0)
 ;;SPONSOR DEMOGRAPHIC INFORMATION
"RTN","DGRPU",93,0)
 ;
"RTN","DGRPU",94,0)
 ;
"RTN","DGRPU",95,0)
INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data
"RTN","DGRPU",96,0)
 ; (called by PTF)
"RTN","DGRPU",97,0)
 ;
"RTN","DGRPU",98,0)
 ;
"RTN","DGRPU",99,0)
 ; Input: DFN as IEN of PATIENT file
"RTN","DGRPU",100,0)
 ; DGDT as date to return income as of
"RTN","DGRPU",101,0)
 ;
"RTN","DGRPU",102,0)
 ; Output: total income (computed function)
"RTN","DGRPU",103,0)
 ; (from 408.21 if available...otherwise from file 2)
"RTN","DGRPU",104,0)
 ;
"RTN","DGRPU",105,0)
 ;
"RTN","DGRPU",106,0)
 N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0
"RTN","DGRPU",107,0)
 D ALL^DGMTU21(DFN,"V",DGDT,"I")
"RTN","DGRPU",108,0)
 S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I)
"RTN","DGRPU",109,0)
 I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20)
"RTN","DGRPU",110,0)
 Q DGTOT
"RTN","DGRPU",111,0)
 ;
"RTN","DGRPU",112,0)
 ;
"RTN","DGRPU",113,0)
MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete?
"RTN","DGRPU",114,0)
 ;
"RTN","DGRPU",115,0)
 ; Input: DFN as IEN of PATIENT file
"RTN","DGRPU",116,0)
 ; DGDT as 'as of' date
"RTN","DGRPU",117,0)
 ;
"RTN","DGRPU",118,0)
 ; Output: 1 if means test/COPAY for year prior to DT passed is complete
"RTN","DGRPU",119,0)
 ; 0 otherwise
"RTN","DGRPU",120,0)
 ; DGMTYPT 1=MT;2=CP;0=NONE
"RTN","DGRPU",121,0)
 ;
"RTN","DGRPU",122,0)
 N COMP,MT,X,YR
"RTN","DGRPU",123,0)
 S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT)
"RTN","DGRPU",124,0)
 S DGMTYPT=+$P(MT,U,5)
"RTN","DGRPU",125,0)
 S COMP=1
"RTN","DGRPU",126,0)
 I DGMTYPT=1 D  ;MT
"RTN","DGRPU",127,0)
 .I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
"RTN","DGRPU",128,0)
 I DGMTYPT=2 D  ;CP
"RTN","DGRPU",129,0)
 .I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
"RTN","DGRPU",130,0)
 S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*10000<YR S COMP=0
"RTN","DGRPU",131,0)
 Q COMP
"RTN","DGRPU",132,0)
 ;
"RTN","DGRPU",133,0)
HLP1010 ;* This is called by the Executable Help for Patient field #1010.159
"RTN","DGRPU",134,0)
 ; (APPOINTMENT REQUEST ON 1010EZ)
"RTN","DGRPU",135,0)
 W !!," Enter a 'Y' if the veteran applicant has requested an"
"RTN","DGRPU",136,0)
 W !," appointment with a VA doctor or provider and wants to be"
"RTN","DGRPU",137,0)
 W !," seen as soon as one becomes available Enter a 'N'"
"RTN","DGRPU",138,0)
 W !," if the veteran applicant has not requested an appointment."
"RTN","DGRPU",139,0)
 W !!," This question may ONLY be entered ONCE for the veteran."
"RTN","DGRPU",140,0)
 W !," The answer to this question CANNOT be changed after the"
"RTN","DGRPU",141,0)
 W !," initial entry.",!
"RTN","DGRPU",142,0)
 Q
"RTN","DGRPU",143,0)
 ;
"RTN","DGRPU",144,0)
HLPCS ; * This is called by the Executable Help for Income Relation field #.1
"RTN","DGRPU",145,0)
 Q:X="?"
"RTN","DGRPU",146,0)
 N DIR,DGRDVAR
"RTN","DGRPU",147,0)
 W !?8,"Enter in this field a Yes or No to indicate whether the veteran"
"RTN","DGRPU",148,0)
 W !?8,"contributed any dollar amount to the child's support last calendar"
"RTN","DGRPU",149,0)
 W !?8,"year. The contributions do not have to be in regular set amounts."
"RTN","DGRPU",150,0)
 W !?8,"For example, a veteran who paid a child's school tuition or"
"RTN","DGRPU",151,0)
 W !?8,"medical bills would be contributing to the child's support.",!
"RTN","DGRPU",152,0)
 W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
"RTN","DGRPU",153,0)
 Q
"RTN","DGRPU",154,0)
 ;
"RTN","DGRPU",155,0)
HLP1823 ;*This is called by the Executable Help for Patient Relation field #.18
"RTN","DGRPU",156,0)
 N DIR,DGRDVAR
"RTN","DGRPU",157,0)
 W !?7,"Enter 'Y' if the child is currently 18 to 23 years old and the child"
"RTN","DGRPU",158,0)
 W !?7,"attended school last calendar year. Enter 'N' if the child is currently"
"RTN","DGRPU",159,0)
 W !?7,"18 to 23 years old but the child did not attend school last calendar"
"RTN","DGRPU",160,0)
 W !?7,"year. Enter 'N' if the child is not currently 18 to 23 years old.",!
"RTN","DGRPU",161,0)
 I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
"RTN","DGRPU",162,0)
 Q
"RTN","DGRPU",163,0)
 ;
"RTN","DGRPU",164,0)
HLPMLDS ;* This is called by the Executable Help for Patient field #.362
"RTN","DGRPU",165,0)
 ; (DISABILITY RET. FROM MILITARY?)
"RTN","DGRPU",166,0)
 N X,Y,DIR
"RTN","DGRPU",167,0)
 W !!," Enter '0' or 'NO' if the veteran:"
"RTN","DGRPU",168,0)
 W !," -- Is NOT retired from the military OR"
"RTN","DGRPU",169,0)
 W !," -- Is retired from the military due to length of service AND"
"RTN","DGRPU",170,0)
 W !," does NOT have a disability confirmed by the Military Branch"
"RTN","DGRPU",171,0)
 W !," to have been incurred in or aggravated while on active duty."
"RTN","DGRPU",172,0)
 W !!," Enter '1' or 'YES, RECEIVING MILITARY RETIREMENT' if the veteran:"
"RTN","DGRPU",173,0)
 W !," -- Is confirmed by the Military Branch to have been discharged"
"RTN","DGRPU",174,0)
 W !," or released due to a disability incurred in or aggravated"
"RTN","DGRPU",175,0)
 W !," while on active duty AND"
"RTN","DGRPU",176,0)
 W !," -- Has NOT filed a claim for VA compensation benefits OR"
"RTN","DGRPU",177,0)
 W !," -- Has been rated by the VA to be NSC OR"
"RTN","DGRPU",178,0)
 W !," -- Has been rated by the VA to have noncompensable 0%"
"RTN","DGRPU",179,0)
 W !," SC conditions."
"RTN","DGRPU",180,0)
 S DIR(0)="E" D ^DIR Q:+Y<1
"RTN","DGRPU",181,0)
 W !!," Enter '2' or 'YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA"
"RTN","DGRPU",182,0)
 W !," COMPENSATION' if the veteran:"
"RTN","DGRPU",183,0)
 W !," -- Is confirmed by the Military Branch to have been discharged"
"RTN","DGRPU",184,0)
 W !," or released due to a disability incurred in or aggravated"
"RTN","DGRPU",185,0)
 W !," while on active duty AND"
"RTN","DGRPU",186,0)
 W !," -- Is receiving military disability retirement pay AND"
"RTN","DGRPU",187,0)
 W !," -- Has been rated by VA to have compensable SC conditions"
"RTN","DGRPU",188,0)
 W !," but is NOT receiving compensation from the VA"
"RTN","DGRPU",189,0)
 W !!," Once eligibility has been verified, this field will no longer"
"RTN","DGRPU",190,0)
 W !," be editable to any user who does not hold the designated security"
"RTN","DGRPU",191,0)
 W !," key."
"RTN","DGRPU",192,0)
 Q
"RTN","DGRPU",193,0)
HLP3602 ;help text for field .3602, Rec'ing Disability in Lieu of VA Comp
"RTN","DGRPU",194,0)
 W !," Enter 'Y' if this veteran applicant is receiving disability"
"RTN","DGRPU",195,0)
 W !," retirement pay from the Military instead of VA compensation."
"RTN","DGRPU",196,0)
 W !," Enter 'N' if this veteran applicant is not receiving disability"
"RTN","DGRPU",197,0)
 W !," retirement pay from the Military instead of VA compensation."
"RTN","DGRPU",198,0)
 W !," Once eligibility has been verified by HEC this field will no longer "
"RTN","DGRPU",199,0)
 W !," be editable by VistA users. Send updates and/or requests to HEC."
"RTN","DGRPU",200,0)
 Q
"RTN","DGRPU",201,0)
HLP3603 ;help text for field .3603, Discharge Due to LOD Disability
"RTN","DGRPU",202,0)
 W !," Enter 'Y' if this veteran applicant was discharged from the"
"RTN","DGRPU",203,0)
 W !," military for a disability incurred or aggravated in the line "
"RTN","DGRPU",204,0)
 W !," of duty. Enter 'N' if this veteran applicant was not discharged"
"RTN","DGRPU",205,0)
 W !," from the military for a disability incurred or aggravated in the"
"RTN","DGRPU",206,0)
 W !," line of duty. Once eligibility has been verified by HEC this field"
"RTN","DGRPU",207,0)
 W !," will no longer be editable by VistA users. Send updates and/or requests"
"RTN","DGRPU",208,0)
 W !," to HEC."
"RTN","DGRPU",209,0)
 Q
"RTN","DGRPU",210,0)
SSNNM(DFN) ; SSN, EDIPI and name on first line of screen
"RTN","DGRPU",211,0)
 ;DJE - DG*5.3*935 - Add Member ID To Vista Registration Banner
"RTN","DGRPU",212,0)
 N X,SSN,EDIPI,IDSTAT,J,ASFC,LIST,PT,STK
"RTN","DGRPU",213,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","DGRPU",214,0)
 ;
"RTN","DGRPU",215,0)
 S PT=DFN_"^PI^USVHA^"_$P($$SITE^VASITE(),U,3)
"RTN","DGRPU",216,0)
 D TFL^VAFCTFU2(.LIST,PT)
"RTN","DGRPU",217,0)
 S EDIPI="",IDSTAT="",J=1
"RTN","DGRPU",218,0)
 S STK="" F  S STK=$O(LIST(STK)) D  Q:STK=""
"RTN","DGRPU",219,0)
 .Q:STK=""
"RTN","DGRPU",220,0)
 .S ASFC=$P(LIST(STK),U,3)
"RTN","DGRPU",221,0)
 .Q:ASFC'="USDOD"
"RTN","DGRPU",222,0)
 .S IDSTAT=$P(LIST(STK),U,5)
"RTN","DGRPU",223,0)
 .S EDIPI=$P(LIST(STK),U,1)
"RTN","DGRPU",224,0)
 .I (IDSTAT="A"),(EDIPI>1) S STK=""  Q  ;First active EDIPI
"RTN","DGRPU",225,0)
 .I IDSTAT="H" S EDIPI(J)=EDIPI S J=J+1
"RTN","DGRPU",226,0)
 .S EDIPI=""
"RTN","DGRPU",227,0)
 I IDSTAT="H" S EDIPI=EDIPI(1) ; First inactive EDIPI
"RTN","DGRPU",228,0)
 S X=$P(X,U)_"; "_EDIPI_" "_SSN
"RTN","DGRPU",229,0)
 Q X
"RTN","DGRPU1")
0^18^B6546031
"RTN","DGRPU1",1,0)
DGRPU1 ;ALB/REW,JAM - CUSTOM LOAD/EDIT SCREEN UTILITIES ;19 Oct 2017  3:02 PM
"RTN","DGRPU1",2,0)
 ;;5.3;Registration;**139,169,415,527,508,664,941**;Aug 13, 1993;Build 73
"RTN","DGRPU1",3,0)
 ;
"RTN","DGRPU1",4,0)
 ; *941* - JAM; 1. Tag QNUM modified for new field reference numbers used in ^DGRPE due to redesign of Screen layouts for screen 1 and 1.1
"RTN","DGRPU1",5,0)
 ;           Previous values:   ^104^105^109,105,112^109,105,111^111^
"RTN","DGRPU1",6,0)
 ;           New values:        ^108^113^109,113,104^109,113,114^114^
"RTN","DGRPU1",7,0)
 ;
"RTN","DGRPU1",8,0)
QUES(DFN,DGQCODE) ; EDIT SPECIFIC PORTIONS OF REGISTRATION DATA
"RTN","DGRPU1",9,0)
 ;
"RTN","DGRPU1",10,0)
 ;  INPUT:
"RTN","DGRPU1",11,0)
 ;     DFN
"RTN","DGRPU1",12,0)
 ;     DGQCODE = Code for question(s) to be asked
"RTN","DGRPU1",13,0)
 ;  OUTPUT:
"RTN","DGRPU1",14,0)
 ;     DGERR   = ERROR VARIABLE
"RTN","DGRPU1",15,0)
 ;     DGCHANGE= 1 IF DATA MODIFIED 0 O/W
"RTN","DGRPU1",16,0)
 ;  USED:
"RTN","DGRPU1",17,0)
 ;     DGPTND  = Prior value(s) of Patient File node(s) [array]
"RTN","DGRPU1",18,0)
 ;     DGQNODES= Node(s) used above
"RTN","DGRPU1",19,0)
 ;     DGNODE  = Single node
"RTN","DGRPU1",20,0)
 ;     DGDR    = edit=screen*10+item #
"RTN","DGRPU1",21,0)
 ;     DGRPS   = Screen #
"RTN","DGRPU1",22,0)
 ;     DGCODE  = CODE used by ^DGRPE
"RTN","DGRPU1",23,0)
 ;     DGQ     = String of ^DGCODE^DGCODE etc.
"RTN","DGRPU1",24,0)
 ;     DGPC    = Piece Number
"RTN","DGRPU1",25,0)
 ;     DGX     = Line Tag offset
"RTN","DGRPU1",26,0)
 ;
"RTN","DGRPU1",27,0)
 N D,D0,DI,DIC,DGCODE,DGDR,DGNODE,DGQNODES,DGPC,DGPTND,DGRPS,DGQ,DGX
"RTN","DGRPU1",28,0)
 N DQ,N,X,Y,%Y,DGPTNDM
"RTN","DGRPU1",29,0)
 S (DGERR,DGRPS,DGCHANGE)=0
"RTN","DGRPU1",30,0)
 I '($G(DFN)&$D(DGQCODE)) G QTE
"RTN","DGRPU1",31,0)
 F DGX=1:1 S DGQ=$T(QDES+DGX) Q:DGQ[(U_DGQCODE_U)!(DGQ']"")
"RTN","DGRPU1",32,0)
 F DGPC=2:1 S DGCODE=$P(DGQ,U,DGPC) Q:(DGCODE']"")!(DGCODE=DGQCODE)
"RTN","DGRPU1",33,0)
 G:DGCODE']"" QTE
"RTN","DGRPU1",34,0)
 S DGDR=$P($T(QNUM+DGX),U,DGPC)
"RTN","DGRPU1",35,0)
 S DGRPS=DGDR\100
"RTN","DGRPU1",36,0)
 S DGQNODES=$P($T(QNODE+DGX),U,DGPC)
"RTN","DGRPU1",37,0)
 F N=1:1 S DGNODE=$P(DGQNODES,"~",N) Q:DGNODE']""  S DGPTND(DGNODE)=$G(^DPT(DFN,DGNODE))
"RTN","DGRPU1",38,0)
 S DGQNODES=$P($T(MNODE+DGX),U,DGPC)
"RTN","DGRPU1",39,0)
 F N=1:1 S DGNODE=$P(DGQNODES,"~",N) Q:DGNODE']""  M DGPTNDM(DGNODE)=^DPT(DFN,DGNODE) S DGPTNDM(DGNODE)=""
"RTN","DGRPU1",40,0)
 D ^DGRPE
"RTN","DGRPU1",41,0)
 F DGNODE=0:0 S DGNODE=$O(DGPTND(DGNODE)) Q:DGNODE']""  S:$G(^DPT(DFN,DGNODE))'=(DGPTND(DGNODE)) DGCHANGE=1
"RTN","DGRPU1",42,0)
 S DGNODE="" F  S DGNODE=$O(DGPTNDM(DGNODE)) Q:DGNODE']""  D  Q:DGCHANGE
"RTN","DGRPU1",43,0)
 .S X=0 F  S X=$O(DGPTNDM(DGNODE,X)) Q:'X  D  Q:DGCHANGE
"RTN","DGRPU1",44,0)
 ..S Y="" F  S Y=$O(DGPTNDM(DGNODE,X,Y)) Q:Y']""  D  Q:DGCHANGE
"RTN","DGRPU1",45,0)
 ...I $G(^DPT(DFN,DGNODE,X,Y))'=DGPTNDM(DGNODE,X,Y) S DGCHANGE=1
"RTN","DGRPU1",46,0)
 .Q:DGCHANGE
"RTN","DGRPU1",47,0)
 .S X=0 F  S X=$O(^DPT(DGNODE,X)) Q:'X  D  Q:DGCHANGE
"RTN","DGRPU1",48,0)
 ..S Y="" F  S Y=$O(^DPT(DGNODE,X,Y)) Q:Y']""  D  Q:DGCHANGE
"RTN","DGRPU1",49,0)
 ...I $G(^DPT(DFN,DGNODE,X,Y))'=DGPTNDM(DGNODE,X,Y) S DGCHANGE=1
"RTN","DGRPU1",50,0)
QTE I 'DGRPS S DGERR=1
"RTN","DGRPU1",51,0)
QTQ Q
"RTN","DGRPU1",52,0)
QDES ;MNEMONIC - DGQCODE should match with one of these
"RTN","DGRPU1",53,0)
 ;;^ADD1^ADD2^ADD^ADD3^ADD4^
"RTN","DGRPU1",54,0)
QNUM ;REFERENCE NUMBERS USED TO SET DGDR FOR USE BY ^DGRPE
"RTN","DGRPU1",55,0)
 ;;^108^113^109,113,104^109,113,114^114^
"RTN","DGRPU1",56,0)
QNODE ;;NODES OF THE PATIENT FILE
"RTN","DGRPU1",57,0)
 ;;^.11~.13^.121^.11~.121~.13^.11~.121~.13~.141^.141^
"RTN","DGRPU1",58,0)
 ;;
"RTN","DGRPU1",59,0)
MNODE ;;MULTIPLES OF THE PATIENT FILE
"RTN","DGRPU1",60,0)
 ;;^^^.02~.06^.02~.06~.14^.14^
"RTN","DGRPV")
0^3^B19689062
"RTN","DGRPV",1,0)
DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD,TDM,PWC,JAM - REGISTRATION DEFINE VARIABLES ON ENTRY ;19 Jul 2017  3:03 PM
"RTN","DGRPV",2,0)
 ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797,842,871,887,941**;Aug 13, 1993;Build 73
"RTN","DGRPV",3,0)
 ;
"RTN","DGRPV",4,0)
 ;
"RTN","DGRPV",5,0)
 ;set up variables for registration screen processing
"RTN","DGRPV",6,0)
 ;
"RTN","DGRPV",7,0)
 ;DGRPVV   :string of 15 ones and zeros each character corresponding to
"RTN","DGRPV",8,0)
 ;          a particular screen (0 means allow edit, 1 means don't)
"RTN","DGRPV",9,0)
 ;
"RTN","DGRPV",10,0)
 ;DGRPVV(n):where n=screen number.  String of x ones and zeros where
"RTN","DGRPV",11,0)
 ;          x is the number of elements on screen n (0=edit, 1=don't)
"RTN","DGRPV",12,0)
 ;
"RTN","DGRPV",13,0)
 ;DGVI     :Turn on high intensity
"RTN","DGRPV",14,0)
 ;DGVO     :Turn off high intensity
"RTN","DGRPV",15,0)
 ;
"RTN","DGRPV",16,0)
EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS
"RTN","DGRPV",17,0)
 S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity
"RTN","DGRPV",18,0)
 I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X)
"RTN","DGRPV",19,0)
M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
"RTN","DGRPV",20,0)
 S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1)
"RTN","DGRPV",21,0)
MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2
"RTN","DGRPV",22,0)
 ;DG*5.3*797
"RTN","DGRPV",23,0)
 I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN)
"RTN","DGRPV",24,0)
SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",25,0)
 S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",26,0)
 I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10"))
"RTN","DGRPV",27,0)
 ;
"RTN","DGRPV",28,0)
 S DGPH=$P($G(^DPT(DFN,.53)),U)  ;Purple Heart Indicator
"RTN","DGRPV",29,0)
 I $G(DGPRFLG)=1 D
"RTN","DGRPV",30,0)
 . S DGRPVV="000001111111111"
"RTN","DGRPV",31,0)
 E  D
"RTN","DGRPV",32,0)
 . S DGRPVV="000000000000000"
"RTN","DGRPV",33,0)
 S X="5^3^5^2^3^10^4^2^3^2^5^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)
 ;JAM - patch DG*5.3*941 - Screen 1.1 reformat - 4 groups
"RTN","DGRPV",36,0)
 S DGRPVV(1.1)="0000"
"RTN","DGRPV",37,0)
 S DGRPVV(2)="00010"
"RTN","DGRPV",38,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",39,0)
 I $G(DGPH)]"" S $E(DGRPVV(6),8)=1
"RTN","DGRPV",40,0)
 S $E(DGRPVV(6),9,10)="11"
"RTN","DGRPV",41,0)
 ;
"RTN","DGRPV",42,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",43,0)
 ;
"RTN","DGRPV",44,0)
 ;-- if patient type is TRICARE then turn off screens 2,4
"RTN","DGRPV",45,0)
 ;
"RTN","DGRPV",46,0)
 ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 
"RTN","DGRPV",47,0)
 ;-- commented the line to allow screens 2 & 4 to display for Tricare
"RTN","DGRPV",48,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",49,0)
 ;
"RTN","DGRPV",50,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",51,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",52,0)
 K DIRUT,DUOUT,DTOUT
"RTN","DGRPV",53,0)
 ;
"RTN","DGRPV",54,0)
 ;Fields are numbered screen_item and put in that piece position.
"RTN","DGRPV",55,0)
 ;Because FM does not allow more than 100 pieces on a node, it was
"RTN","DGRPV",56,0)
 ;necessary to start a new node E10 for fields on screens 10 or higher.
"RTN","DGRPV",57,0)
 ;In these instances, the piece position will be screen_item-100 so,
"RTN","DGRPV",58,0)
 ;for example, screen 11, item 2 would be field 112, but piece 12.
"RTN","DGRPV",59,0)
 ;Items on screens <10 will be found on node E.
"RTN","DGRPV",60,0)
 ;
"RTN","DGRPV",61,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",62,0)
 ;
"RTN","DGRPV",63,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",64,0)
 F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPV",65,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",66,0)
 I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
"RTN","DGRPV",67,0)
 I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
"RTN","DGRPV",68,0)
 S DGRPVV(11)=$E(DGRPVV(11),1,4)_"0"   ; turn on HBP to get to next screen where edit on/off will be controlled
"RTN","DGRPV",69,0)
 ;
"RTN","DGRPV",70,0)
ELVER ;set up variables for eligibility verification
"RTN","DGRPV",71,0)
 ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
"RTN","DGRPV",72,0)
 ;   and 11 if they're turned on).
"RTN","DGRPV",73,0)
 ;
"RTN","DGRPV",74,0)
 S DGRP(.361)=$G(^DPT(DFN,.361))
"RTN","DGRPV",75,0)
 I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10
"RTN","DGRPV",76,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)=10000
"RTN","DGRPV",77,0)
 S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
"RTN","DGRPV",78,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",79,0)
Q K DGRPSC,DGRPSCE
"RTN","DGRPV",80,0)
 Q
"RTN","DGRPV",81,0)
 ;
"RTN","DGRPV",82,0)
WW ;Write number on screens for display and/or edit (Z=number)
"RTN","DGRPV",83,0)
 W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
"RTN","DGRPV",84,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",85,0)
 I 'DGRPCM&($E(Z)'="[") W Z
"RTN","DGRPV",86,0)
 Q
"RTN","DGRPV",87,0)
 ;
"RTN","DGRPV",88,0)
WW1 ;spacing for screen display (Z=item to print)
"RTN","DGRPV",89,0)
 F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
"RTN","DGRPV",90,0)
 W Z K Z2
"RTN","DGRPV",91,0)
 Q
"RTN","DGRPV",92,0)
 ;
"RTN","DGRPV",93,0)
WW2 ; Write number on screen for fields always selectable
"RTN","DGRPV",94,0)
 W:DGRPW ! S Z="["_Z_"]"
"RTN","DGRPV",95,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",96,0)
 Q
"RTN","VADPT1")
0^14^B57593585
"RTN","VADPT1",1,0)
VADPT1 ;ALB/MRL,MJK,ERC,TDM,CLT - PATIENT VARIABLES ;05 May 2017  1:41 PM
"RTN","VADPT1",2,0)
 ;;5.3;Registration;**415,489,516,614,688,754,887,941**;Aug 13, 1993;Build 73
"RTN","VADPT1",3,0)
 ;
"RTN","VADPT1",4,0)
1 ;Demographic [DEM]
"RTN","VADPT1",5,0)
 N W,Z,NODE
"RTN","VADPT1",6,0)
 ;
"RTN","VADPT1",7,0)
 ; -- name [1 - NM]
"RTN","VADPT1",8,0)
 S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^")
"RTN","VADPT1",9,0)
 ;
"RTN","VADPT1",10,0)
 ; -- ssn [2 - SS]
"RTN","VADPT1",11,0)
 S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"")
"RTN","VADPT1",12,0)
 ;
"RTN","VADPT1",13,0)
 ; -- date of birth [2 - DB]
"RTN","VADPT1",14,0)
 S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y
"RTN","VADPT1",15,0)
 ;
"RTN","VADPT1",16,0)
 ; -- age [4 - AG]
"RTN","VADPT1",17,0)
 S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
"RTN","VADPT1",18,0)
 ;
"RTN","VADPT1",19,0)
 ; -- expired date [6 - EX]
"RTN","VADPT1",20,0)
 S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y
"RTN","VADPT1",21,0)
 ;
"RTN","VADPT1",22,0)
 ; -- sex [5 - SX]
"RTN","VADPT1",23,0)
 S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z
"RTN","VADPT1",24,0)
 ;
"RTN","VADPT1",25,0)
 ; -- remarks [7 - RE]
"RTN","VADPT1",26,0)
 S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10)
"RTN","VADPT1",27,0)
 ;
"RTN","VADPT1",28,0)
 ; -- historic race [8 - RA]
"RTN","VADPT1",29,0)
 S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"")
"RTN","VADPT1",30,0)
 ;
"RTN","VADPT1",31,0)
 ; -- religion [9 - RP]
"RTN","VADPT1",32,0)
 S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"")
"RTN","VADPT1",33,0)
 ;
"RTN","VADPT1",34,0)
 ; -- marital status [10 - MS]
"RTN","VADPT1",35,0)
 S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"")
"RTN","VADPT1",36,0)
 ;
"RTN","VADPT1",37,0)
 ; -- ethnicity [11 - ET]
"RTN","VADPT1",38,0)
 S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X  D
"RTN","VADPT1",39,0)
 .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D
"RTN","VADPT1",40,0)
 ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1)
"RTN","VADPT1",41,0)
 ..; -- collection method
"RTN","VADPT1",42,0)
 ..S Z=$P(NODE,"^",2) I Z D
"RTN","VADPT1",43,0)
 ...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
"RTN","VADPT1",44,0)
 S @VAV@($P(VAS,"^",11))=Y-1
"RTN","VADPT1",45,0)
 ;
"RTN","VADPT1",46,0)
 ; -- race [12 - RC]
"RTN","VADPT1",47,0)
 S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X  D
"RTN","VADPT1",48,0)
 .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D
"RTN","VADPT1",49,0)
 ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1)
"RTN","VADPT1",50,0)
 ..; -- collection method
"RTN","VADPT1",51,0)
 ..S Z=$P(NODE,"^",2) I Z D
"RTN","VADPT1",52,0)
 ...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
"RTN","VADPT1",53,0)
 S @VAV@($P(VAS,"^",12))=Y-1
"RTN","VADPT1",54,0)
 ;
"RTN","VADPT1",55,0)
 ; -- current pt preferred language [13 - LG]
"RTN","VADPT1",56,0)
 N VALANGDT,VAPRFLAN,VALANG0,VAY,VALANGDA,X,Y
"RTN","VADPT1",57,0)
 S VALANGDT=9999999,(VAPRFLAN,VALANG0)=""
"RTN","VADPT1",58,0)
 S VALANGDT=$O(^DPT(DFN,.207,"B",VALANGDT),-1)
"RTN","VADPT1",59,0)
 I VALANGDT="" DO  Q
"RTN","VADPT1",60,0)
 .S @VAV@($P(VAS,"^",13))="",@VAV@($P(VAS,"^",13),1)=""
"RTN","VADPT1",61,0)
 S VALANGDA=$O(^DPT(DFN,.207,"B",VALANGDT,0))
"RTN","VADPT1",62,0)
 S VALANG0=$G(^DPT(DFN,.207,VALANGDA,0)),Y=$P(VALANG0,U),VAPRFLAN=$P(VALANG0,U,2)
"RTN","VADPT1",63,0)
 S (VAY,Y)=VALANGDT X ^DD("DD") S VALANGDT=Y
"RTN","VADPT1",64,0)
 S @VAV@($P(VAS,"^",13))=VAY_"^"_VALANGDT ; FM version^human readable
"RTN","VADPT1",65,0)
 S @VAV@($P(VAS,"^",13),1)=VALANGDA_"^"_VAPRFLAN ; Pointer^human readable
"RTN","VADPT1",66,0)
 Q
"RTN","VADPT1",67,0)
 ;
"RTN","VADPT1",68,0)
2 ;Other Patient Variables [OPD]
"RTN","VADPT1",69,0)
 N W,Z
"RTN","VADPT1",70,0)
 S VAX=^DPT(DFN,0)
"RTN","VADPT1",71,0)
 ;
"RTN","VADPT1",72,0)
 ; -- city of birth [1 - BC]
"RTN","VADPT1",73,0)
 S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11)
"RTN","VADPT1",74,0)
 ;
"RTN","VADPT1",75,0)
 ; -- state of birth [2 - BS]
"RTN","VADPT1",76,0)
 S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"")
"RTN","VADPT1",77,0)
 ;
"RTN","VADPT1",78,0)
 ; -- occupation [6 - OC]
"RTN","VADPT1",79,0)
 S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7)
"RTN","VADPT1",80,0)
 ;
"RTN","VADPT1",81,0)
 ; -- names
"RTN","VADPT1",82,0)
 S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"")
"RTN","VADPT1",83,0)
 S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's        [3 - FN]
"RTN","VADPT1",84,0)
 S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's        [4 - MN]
"RTN","VADPT1",85,0)
 S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM]
"RTN","VADPT1",86,0)
 ;
"RTN","VADPT1",87,0)
 ; -- employment status [7 - ES]
"RTN","VADPT1",88,0)
 S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
"RTN","VADPT1",89,0)
 S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"")
"RTN","VADPT1",90,0)
 ;
"RTN","VADPT1",91,0)
 ; -- PHONE NUMBER [WORK] [8 - WP]
"RTN","VADPT1",92,0)
 I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",2)
"RTN","VADPT1",93,0)
 Q
"RTN","VADPT1",94,0)
 ;
"RTN","VADPT1",95,0)
3 ;Address [ADD]
"RTN","VADPT1",96,0)
 N VAFOR
"RTN","VADPT1",97,0)
 S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
"RTN","VADPT1",98,0)
 I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)<VAEND) S VAX=$S($D(^DPT(DFN,.11)):^(.11),1:""),VAX(1)=0
"RTN","VADPT1",99,0)
 E  S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""),VAX(1)=1
"RTN","VADPT1",100,0)
 ;set the foreign address fields into local variables for later
"RTN","VADPT1",101,0)
 I 'VAX(1) S VAFOR=$P(VAX,U,8,10)
"RTN","VADPT1",102,0)
 I VAX(1) D
"RTN","VADPT1",103,0)
 . I '$D(^DPT(DFN,.122)) S VAFOR="" Q
"RTN","VADPT1",104,0)
 . S VAFOR=$P(^DPT(DFN,.122),U,1,3)
"RTN","VADPT1",105,0)
 F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I))=VAZ I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",5))=@VAV@($P(VAS,"^",5))_"^"_VAZ
"RTN","VADPT1",106,0)
 S VAZ=$S('VAX(1):$P(VAX,"^",7),1:$P(VAX,"^",11)) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",7))=VAZ
"RTN","VADPT1",107,0)
 S VAZIP4=$P(VAX,U,12)
"RTN","VADPT1",108,0)
 S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
"RTN","VADPT1",109,0)
 ;DG*5.3*516
"RTN","VADPT1",110,0)
 I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",1)
"RTN","VADPT1",111,0)
 ;foreign address fields
"RTN","VADPT1",112,0)
 F I=1:1:3 S VAZ=$P(VAFOR,U,I) S @VAV@($P(VAS,U,I+22))=VAZ
"RTN","VADPT1",113,0)
 ;
"RTN","VADPT1",114,0)
 I $P($G(VAFOR),U,3)]"" D
"RTN","VADPT1",115,0)
 . S VACNTRY=$P(VAFOR,U,3)
"RTN","VADPT1",116,0)
 . S VACNTRY=$$CNTRYI^DGADDUTL(VACNTRY)
"RTN","VADPT1",117,0)
 . S $P(@VAV@($P(VAS,U,25)),U,2)=VACNTRY
"RTN","VADPT1",118,0)
 I 'VAX(1) G CA
"RTN","VADPT1",119,0)
 S @VAV@($P(VAS,"^",8))=$P(VAX,"^",10)
"RTN","VADPT1",120,0)
 F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+2))=VAZ_"^"_Y
"RTN","VADPT1",121,0)
CA ;Confidential Address
"RTN","VADPT1",122,0)
 ; JAM, Go to Residential Address if no Conf address- VADPT ICR 10061 ;DG*5.3*941
"RTN","VADPT1",123,0)
 I '$D(^DPT(DFN,.141)) G RES
"RTN","VADPT1",124,0)
 N VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
"RTN","VADPT1",125,0)
 S VAX=$S($D(^DPT(DFN,.141)):^(.141),1:"")
"RTN","VADPT1",126,0)
 S VAACTDT=$S($D(VAPA("CD")):VAPA("CD"),1:DT)
"RTN","VADPT1",127,0)
 F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I+12))=VAZ D
"RTN","VADPT1",128,0)
 .I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_VAZ Q
"RTN","VADPT1",129,0)
 .I I=6,($G(VAZ)]"") S @VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_$S(($L(VAZ)=5):VAZ,1:$E(VAZ,1,5)_"-"_$E(VAZ,6,9))
"RTN","VADPT1",130,0)
 S VAZ=$P(VAX,"^",11) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",19))=VAZ
"RTN","VADPT1",131,0)
 F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+13))=VAZ_"^"_Y
"RTN","VADPT1",132,0)
 S VABEG=$P(VAX,"^",7),VAEND=$P(VAX,"^",8)
"RTN","VADPT1",133,0)
 S @VAV@($P(VAS,"^",12))=1
"RTN","VADPT1",134,0)
 I 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT)) S @VAV@($P(VAS,"^",12))=0
"RTN","VADPT1",135,0)
 I $D(^DPT(DFN,.14)) D
"RTN","VADPT1",136,0)
 .S VACAN="" F  S VACAN=$O(^DPT(DFN,.14,VACAN)) Q:VACAN=""  D
"RTN","VADPT1",137,0)
 ..Q:'$D(^DPT(DFN,.14,VACAN,0))
"RTN","VADPT1",138,0)
 ..S VATYP=$P(^DPT(DFN,.14,VACAN,0),"^",1),VAACT=$P(^DPT(DFN,.14,VACAN,0),"^",2)
"RTN","VADPT1",139,0)
 ..S VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
"RTN","VADPT1",140,0)
 ..S VATYPNAM="" F I=1:1 S VATYPNAM=$P(VACAT,";",I) Q:VATYPNAM=""  D
"RTN","VADPT1",141,0)
 ...I +VATYPNAM[VATYP S VATYPNAM=$P(VATYPNAM,":",2),@VAV@($P(VAS,"^",22),VATYP)=VATYP_"^"_VATYPNAM_"^"_VAACT
"RTN","VADPT1",142,0)
 ;foreign address fields for the confidential address
"RTN","VADPT1",143,0)
 F I=1:1:3 S @VAV@($P(VAS,U,I+25))=$P(VAX,U,I+13)
"RTN","VADPT1",144,0)
 I @VAV@($P(VAS,U,28))]"" D
"RTN","VADPT1",145,0)
 . I '$D(^HL(779.004,$P(VAX,U,16),0)) Q
"RTN","VADPT1",146,0)
 . S $P(@VAV@($P(VAS,U,28)),U,2)=$$CNTRYI^DGADDUTL($P(VAX,U,16))
"RTN","VADPT1",147,0)
 ; -- CONFIDENTIAL PHONE NUMBER [29 - CPN]
"RTN","VADPT1",148,0)
 I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",29))=$P(^(.13),"^",15)
"RTN","VADPT1",149,0)
RES ;Residential address
"RTN","VADPT1",150,0)
 ;CLT, Add Residential Address to VADPT ICR 10061 ;DG*5.3*941
"RTN","VADPT1",151,0)
 I '$D(^DPT(DFN,.115)) G Q3
"RTN","VADPT1",152,0)
 N DGAR
"RTN","VADPT1",153,0)
 S DGAR=$G(^DPT(DFN,.115))
"RTN","VADPT1",154,0)
 F I=1:1:7 S @VAV@(29+I)=$P(DGAR,U,I)
"RTN","VADPT1",155,0)
 I @VAV@(34)'="",@VAV@(36)'="" I $D(^DIC(5,@VAV@(34),1,@VAV@(36),0)) S VAZ=$P(^DIC(5,@VAV@(34),1,@VAV@(36),0),"^",1),@VAV@(36)=@VAV@(36)_"^"_VAZ
"RTN","VADPT1",156,0)
 I @VAV@(34)'="" S:$D(^DIC(5,@VAV@(34),0)) @VAV@(34)=@VAV@(34)_"^"_$P(^DIC(5,@VAV@(34),0),U,1)
"RTN","VADPT1",157,0)
 S @VAV@(37)=$P(DGAR,"^",10)
"RTN","VADPT1",158,0)
 I @VAV@(37)'="" D
"RTN","VADPT1",159,0)
 . S VACNTRY=@VAV@(37)
"RTN","VADPT1",160,0)
 . S VACNTRY=$$CNTRYI^DGADDUTL(VACNTRY)
"RTN","VADPT1",161,0)
 . S $P(@VAV@(37),U,2)=VACNTRY
"RTN","VADPT1",162,0)
 S @VAV@(38)=$P(DGAR,"^",8)
"RTN","VADPT1",163,0)
 S @VAV@(39)=$P(DGAR,"^",9)
"RTN","VADPT1",164,0)
 ;
"RTN","VADPT1",165,0)
Q3 K VABEG,VAEND,VAZIP4 Q
"RTN","VADPT1",166,0)
 ;
"RTN","VADPT1",167,0)
4 ;Other Address [OAD]
"RTN","VADPT1",168,0)
 N VAZIP4
"RTN","VADPT1",169,0)
 I $S('$D(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0) S VAX=.21,VAOA("A")=7
"RTN","VADPT1",170,0)
 E  S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A"))
"RTN","VADPT1",171,0)
 S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99)
"RTN","VADPT1",172,0)
 S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
"RTN","VADPT1",173,0)
 S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8
"RTN","VADPT1",174,0)
 F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
"RTN","VADPT1",175,0)
 I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))=""
"RTN","VADPT1",176,0)
 S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1)
"RTN","VADPT1",177,0)
 S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A"))
"RTN","VADPT1",178,0)
 S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
"RTN","VADPT1",179,0)
 Q
"RTN","VAFCQRY3")
0^16^B101601272
"RTN","VAFCQRY3",1,0)
VAFCQRY3 ;ALB/CMC,CKN,KUM - CONT TO BLD PID 2.4 SEGMENT ; 5/4/18 4:45pm
"RTN","VAFCQRY3",2,0)
 ;;5.3;Registration;**575,707,754,944,941**;Aug 13, 1993;Build 73
"RTN","VAFCQRY3",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","VAFCQRY3",4,0)
 ;
"RTN","VAFCQRY3",5,0)
 ; *941* #858271 - Sending Residential Address Fields 
"RTN","VAFCQRY3",6,0)
 ;
"RTN","VAFCQRY3",7,0)
CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP,SSN,VAFCMN) ; continue to bld pid segment
"RTN","VAFCQRY3",8,0)
ADDR ;had to split routine
"RTN","VAFCQRY3",9,0)
 N LVL1,LNGTH1
"RTN","VAFCQRY3",10,0)
 S LVL1=0
"RTN","VAFCQRY3",11,0)
 S LNGTH1=0
"RTN","VAFCQRY3",12,0)
 I $D(SARY(11))!(SEQ="ALL") S APID(12)="" D
"RTN","VAFCQRY3",13,0)
 .I $D(^DPT(DFN,0)) D
"RTN","VAFCQRY3",14,0)
 ..;address info
"RTN","VAFCQRY3",15,0)
 ..N COUNTY K HL7STRG
"RTN","VAFCQRY3",16,0)
 ..S HL7STRG=$$GET1^DIQ(2,DFN_",",.111) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
"RTN","VAFCQRY3",17,0)
 ..S $P(APID(12),COMP)=HL7STRG I $P(APID(12),COMP)="" S $P(APID(12),COMP)=HL("Q") K HL7STRG
"RTN","VAFCQRY3",18,0)
 ..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.112) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
"RTN","VAFCQRY3",19,0)
 ..S $P(APID(12),COMP,2)=HL7STRG I $P(APID(12),COMP,2)="" S $P(APID(12),COMP,2)=HL("Q")
"RTN","VAFCQRY3",20,0)
 ..K HL7STRG S HL7STRG=$$GET1^DIQ(2,DFN_",",.113) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) ;**707 add HL7TXT call
"RTN","VAFCQRY3",21,0)
 ..S $P(APID(12),COMP,8)=HL7STRG I $P(APID(12),COMP,8)="" S $P(APID(12),COMP,8)=HL("Q")
"RTN","VAFCQRY3",22,0)
 ..K HL7STRG
"RTN","VAFCQRY3",23,0)
 ..; **707 changes to include foreign address
"RTN","VAFCQRY3",24,0)
 ..N CNTRY S CNTRY=$$GET1^DIQ(2,DFN_",",.1173) ;RETURN EXTERNAL VALUE from country code file #779.004 field .01
"RTN","VAFCQRY3",25,0)
 ..I CNTRY="US" S CNTRY="USA"
"RTN","VAFCQRY3",26,0)
 ..S HL7STRG=$$GET1^DIQ(2,DFN_",",.114) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(APID(12),COMP,3)=HL7STRG  I $P(APID(12),COMP,3)="" S $P(APID(12),COMP,3)=HL("Q")
"RTN","VAFCQRY3",27,0)
 ..I CNTRY=""!(CNTRY="USA") D
"RTN","VAFCQRY3",28,0)
 ...;have USA address
"RTN","VAFCQRY3",29,0)
 ...S STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I") S $P(APID(12),COMP,4)=$$GET1^DIQ(5,+STATEIEN_",",1)
"RTN","VAFCQRY3",30,0)
 ...I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q")
"RTN","VAFCQRY3",31,0)
 ...S $P(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q")
"RTN","VAFCQRY3",32,0)
 ...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;country
"RTN","VAFCQRY3",33,0)
 ..I CNTRY'="",(CNTRY'="USA") D
"RTN","VAFCQRY3",34,0)
 ...;Check for foreign address fields
"RTN","VAFCQRY3",35,0)
 ...S $P(APID(12),COMP,4)=$P($G(^DPT(DFN,.11)),"^",8) I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q") ;province
"RTN","VAFCQRY3",36,0)
 ...S $P(APID(12),COMP,5)=$P($G(^DPT(DFN,.11)),"^",9) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q") ;postal code
"RTN","VAFCQRY3",37,0)
 ...S $P(APID(12),COMP,6)=CNTRY I CNTRY="" S $P(APID(12),COMP,6)=HL("Q") ;COUNTRY
"RTN","VAFCQRY3",38,0)
 ...; ***707 end of code
"RTN","VAFCQRY3",39,0)
 ..S $P(APID(12),COMP,7)="P"
"RTN","VAFCQRY3",40,0)
BADADDR ..;BAD ADDRESS INDICATOR (if present overwrite the "P" ermanent type with the Bad Address type
"RTN","VAFCQRY3",41,0)
 ..I $D(^DPT(DFN,.11)) N BADADR S BADADR=$P(^DPT(DFN,.11),"^",16) I BADADR'="" S $P(APID(12),COMP,7)="VAB"_BADADR
"RTN","VAFCQRY3",42,0)
 ..S COUNTY=$$GET1^DIQ(2,DFN_",",.117) I COUNTY="" S COUNTY=HL("Q") ;**648 add COUNTY Code to PID-11, retained in PID-12 also
"RTN","VAFCQRY3",43,0)
 ..S $P(APID(12),COMP,9)=COUNTY ;county code
"RTN","VAFCQRY3",44,0)
 ..;place of birth information
"RTN","VAFCQRY3",45,0)
 ..S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG D
"RTN","VAFCQRY3",46,0)
 ...N X,POBPROV,POBCONT
"RTN","VAFCQRY3",47,0)
 ...I $G(CITY)'="" S $P(X,COMP,3)=CITY
"RTN","VAFCQRY3",48,0)
 ...I $G(CITY)="" S $P(X,COMP,3)=HL("Q")
"RTN","VAFCQRY3",49,0)
 ...; Story 513045 (elz) use pob provence if it's there vs state
"RTN","VAFCQRY3",50,0)
 ...S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I"),STATE=$$GET1^DIQ(5,+STATEIEN_",",1),POBPROV=$$GET1^DIQ(2,DFN_",",.0932,"E") D
"RTN","VAFCQRY3",51,0)
 ....I $L(POBPROV) S HL7STRG=POBPROV D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(X,COMP,4)=HL7STRG
"RTN","VAFCQRY3",52,0)
 ....I $G(STATE)'="",'$L(POBPROV) S $P(X,COMP,4)=STATE
"RTN","VAFCQRY3",53,0)
 ....I $G(STATE)="",'$L(POBPROV) S $P(X,COMP,4)=HL("Q")
"RTN","VAFCQRY3",54,0)
 ...; Story 513045 (elz) include pob country
"RTN","VAFCQRY3",55,0)
 ...S POBCONT=$$GET1^DIQ(2,DFN_",",.0931) D
"RTN","VAFCQRY3",56,0)
 ....I POBCONT="US" S POBCONT="USA"
"RTN","VAFCQRY3",57,0)
 ....I POBCONT'="" S $P(X,COMP,6)=POBCONT
"RTN","VAFCQRY3",58,0)
 ....I POBCONT="" S $P(X,COMP,6)=HL("Q")
"RTN","VAFCQRY3",59,0)
 ... S $P(X,COMP,7)="N",APID(12)=$G(APID(12))_REP_X
"RTN","VAFCQRY3",60,0)
CONF .;CONFIDENTIAL ADDRESS
"RTN","VAFCQRY3",61,0)
 .I $D(^DPT(DFN,.141)) N CNFADD S CNFADD=$$GET1^DIQ(2,DFN_",",.14105) D
"RTN","VAFCQRY3",62,0)
 ..N LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,CNFEND,CNFSTRT,SUBCOMP,CNTY,CITY
"RTN","VAFCQRY3",63,0)
 ..S SUBCOMP=$E(HL("ECH"),4)
"RTN","VAFCQRY3",64,0)
 ..S LINE1=$$GET1^DIQ(2,DFN_",",.1411) S HL7STRG=LINE1 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE1=HL7STRG
"RTN","VAFCQRY3",65,0)
 ..S LINE2=$$GET1^DIQ(2,DFN_",",.1412) S HL7STRG=LINE2 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE2=HL7STRG
"RTN","VAFCQRY3",66,0)
 ..S LINE3=$$GET1^DIQ(2,DFN_",",.1413) S HL7STRG=LINE3 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE3=HL7STRG
"RTN","VAFCQRY3",67,0)
 ..S CNFSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1417,"I")),CNFEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1418,"I"))
"RTN","VAFCQRY3",68,0)
 ..S CITY=$$GET1^DIQ(2,DFN_",",.1414) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
"RTN","VAFCQRY3",69,0)
 ..S CNTRY=$$GET1^DIQ(2,DFN_",",.14116)
"RTN","VAFCQRY3",70,0)
 ..;if foriegn address
"RTN","VAFCQRY3",71,0)
 ..I CNTRY=""!(CNTRY="USA")!(CNTRY="US") S:CNTRY="US" CNTRY="USA" S STATEIEN=$$GET1^DIQ(2,DFN_",",.1415,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1),CNTY=$$GET1^DIQ(2,DFN_",",.14111),ZIP=$$GET1^DIQ(2,DFN_",",.1416)
"RTN","VAFCQRY3",72,0)
 ..E  S STATE=$$GET1^DIQ(2,DFN_",",.14114),ZIP=$$GET1^DIQ(2,DFN_",",.14115)  ;if USA address or null assume USA address
"RTN","VAFCQRY3",73,0)
 ..S LVL=0,LNGTH=$L(APID(12))
"RTN","VAFCQRY3",74,0)
 ..I $D(^DPT(DFN,.14,0)) N CNFTYP S CNFTYP=0 F  S CNFTYP=$O(^DPT(DFN,.14,CNFTYP)) Q:'CNFTYP  N CNFTYPA S CNFTYPA=$P(^DPT(DFN,.14,CNFTYP,0),"^",2) I CNFTYPA="Y" S CNFTYPA=$P(^DPT(DFN,.14,CNFTYP,0),"^") D
"RTN","VAFCQRY3",75,0)
 ...S NXT=""
"RTN","VAFCQRY3",76,0)
 ...S $P(NXT,COMP)=$S(LINE1'="":LINE1,1:HL("Q"))
"RTN","VAFCQRY3",77,0)
 ...S $P(NXT,COMP,2)=$S(LINE2'="":LINE2,1:HL("Q"))
"RTN","VAFCQRY3",78,0)
 ...S $P(NXT,COMP,8)=$S(LINE3'="":LINE3,1:HL("Q"))
"RTN","VAFCQRY3",79,0)
 ...S $P(NXT,COMP,3)=$S(CITY'="":CITY,1:HL("Q"))
"RTN","VAFCQRY3",80,0)
 ...S $P(NXT,COMP,4)=$S($G(STATE)'="":STATE,1:HL("Q"))
"RTN","VAFCQRY3",81,0)
 ...S $P(NXT,COMP,5)=$S(ZIP'="":ZIP,1:HL("Q"))
"RTN","VAFCQRY3",82,0)
 ...S $P(NXT,COMP,6)=$S(CNTRY'="":CNTRY,1:HL("Q"))
"RTN","VAFCQRY3",83,0)
 ...S $P(NXT,COMP,7)=$S(CNFTYPA=1:"VACAE",CNFTYPA=2:"VACAA",CNFTYPA=3:"VACAC",CNFTYPA=4:"VACAM",CNFTYPA=5:"VACAO",1:HL("Q"))
"RTN","VAFCQRY3",84,0)
 ...S $P(NXT,COMP,9)=$S($G(CNTY)'="":CNTY,1:HL("Q"))
"RTN","VAFCQRY3",85,0)
 ...S $P(NXT,COMP,12)=CNFSTRT_SUBCOMP_CNFEND
"RTN","VAFCQRY3",86,0)
 ...S NXT=REP_NXT
"RTN","VAFCQRY3",87,0)
 ...I LVL=0 D
"RTN","VAFCQRY3",88,0)
 ....I $L(APID(12)_NXT)'>244 S APID(12)=APID(12)_NXT Q
"RTN","VAFCQRY3",89,0)
 ....I $L(APID(12)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(12)),APID(12)=APID(12)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT))
"RTN","VAFCQRY3",90,0)
 ...I LVL>0 D
"RTN","VAFCQRY3",91,0)
 ....I $L($G(APID(12,LVL))_NXT)'>245 S APID(12,LVL)=$G(APID(12,LVL))_NXT Q
"RTN","VAFCQRY3",92,0)
 ....I $L($G(APID(12,LVL))_NXT)>245 S LNGTH=244-$L(APID(12,LVL)),APID(12,LVL)=APID(12,LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(12,LVL)=NXT
"RTN","VAFCQRY3",93,0)
 ..S LVL1=LVL
"RTN","VAFCQRY3",94,0)
 ..S LNGTH1=LNGTH
"RTN","VAFCQRY3",95,0)
RESI .;KUM - 941 - TRANSMIT RESIDENTIAL ADDRESS
"RTN","VAFCQRY3",96,0)
 .;jam; patch 941 - get current option and include RES Address in PID if not ambulatory care transmit
"RTN","VAFCQRY3",97,0)
 .N XQOPT
"RTN","VAFCQRY3",98,0)
 .D OP^XQCHK
"RTN","VAFCQRY3",99,0)
 .I $D(^DPT(DFN,.115)),$P(XQOPT,"^",1)'["SCDX AMBCAR" D 
"RTN","VAFCQRY3",100,0)
 ..N RESADD,LVL,LNGTH,RESDTA
"RTN","VAFCQRY3",101,0)
 ..S RESDTA=0
"RTN","VAFCQRY3",102,0)
 ..N LINE1,LINE2,LINE3,STATEIEN,STATE,CNTRY,ZIP,LVL,LNGTH,NXT,NXT1,RESEND,RESSTRT,SUBCOMP,CNTY,CITY
"RTN","VAFCQRY3",103,0)
 ..S SUBCOMP=$E(HL("ECH"),4)
"RTN","VAFCQRY3",104,0)
 ..S LINE1=$$GET1^DIQ(2,DFN_",",.1151) S HL7STRG=LINE1 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE1=HL7STRG
"RTN","VAFCQRY3",105,0)
 ..S LINE2=$$GET1^DIQ(2,DFN_",",.1152) S HL7STRG=LINE2 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE2=HL7STRG
"RTN","VAFCQRY3",106,0)
 ..S LINE3=$$GET1^DIQ(2,DFN_",",.1153) S HL7STRG=LINE3 D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S LINE3=HL7STRG
"RTN","VAFCQRY3",107,0)
 ..;S RESSTRT=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1161,"I")),RESEND=$$FMTHL7^XLFDT($$GET1^DIQ(2,DFN_",",.1162,"I"))
"RTN","VAFCQRY3",108,0)
 ..S CITY=$$GET1^DIQ(2,DFN_",",.1154) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
"RTN","VAFCQRY3",109,0)
 ..S CNTRY=$$GET1^DIQ(2,DFN_",",.11573)
"RTN","VAFCQRY3",110,0)
 ..;if foriegn address
"RTN","VAFCQRY3",111,0)
 ..I CNTRY=""!(CNTRY="USA")!(CNTRY="US") S:CNTRY="US" CNTRY="USA" S STATEIEN=$$GET1^DIQ(2,DFN_",",.1155,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1),CNTY=$$GET1^DIQ(2,DFN_",",.1157),ZIP=$$GET1^DIQ(2,DFN_",",.1156)
"RTN","VAFCQRY3",112,0)
 ..E  S STATE=$$GET1^DIQ(2,DFN_",",.11571),ZIP=$$GET1^DIQ(2,DFN_",",.11572)  ;if USA address or null assume USA address
"RTN","VAFCQRY3",113,0)
 ..I '$G(LNGTH1) S LNGTH1=0
"RTN","VAFCQRY3",114,0)
 ..S LNGTH=LNGTH1
"RTN","VAFCQRY3",115,0)
 ..S LVL=LVL1
"RTN","VAFCQRY3",116,0)
 ..S NXT=""
"RTN","VAFCQRY3",117,0)
 ..I ($G(LINE1)'="")!($G(LINE2)'="")!($G(LINE3)'="")!($G(CITY)'="")!($G(STATE)'="")!($G(ZIP)'="")!($G(CNTRY)'="")!($G(CNTY)'="") S RESDTA=1
"RTN","VAFCQRY3",118,0)
 ..S $P(NXT,COMP)=$S(LINE1'="":LINE1,1:HL("Q"))
"RTN","VAFCQRY3",119,0)
 ..S $P(NXT,COMP,2)=$S(LINE2'="":LINE2,1:HL("Q"))
"RTN","VAFCQRY3",120,0)
 ..S $P(NXT,COMP,8)=$S(LINE3'="":LINE3,1:HL("Q"))
"RTN","VAFCQRY3",121,0)
 ..S $P(NXT,COMP,3)=$S(CITY'="":CITY,1:HL("Q"))
"RTN","VAFCQRY3",122,0)
 ..S $P(NXT,COMP,4)=$S($G(STATE)'="":STATE,1:HL("Q"))
"RTN","VAFCQRY3",123,0)
 ..S $P(NXT,COMP,5)=$S(ZIP'="":ZIP,1:HL("Q"))
"RTN","VAFCQRY3",124,0)
 ..S $P(NXT,COMP,6)=$S(CNTRY'="":CNTRY,1:HL("Q"))
"RTN","VAFCQRY3",125,0)
 ..S $P(NXT,COMP,7)="R"
"RTN","VAFCQRY3",126,0)
 ..S $P(NXT,COMP,9)=$S($G(CNTY)'="":CNTY,1:HL("Q"))
"RTN","VAFCQRY3",127,0)
 ..;S $P(NXT,COMP,10)=HL("Q")
"RTN","VAFCQRY3",128,0)
 ..;S $P(NXT,COMP,12)=RESSTRT_SUBCOMP_RESEND
"RTN","VAFCQRY3",129,0)
 ..S NXT=REP_NXT
"RTN","VAFCQRY3",130,0)
 ..I RESDTA D
"RTN","VAFCQRY3",131,0)
 ...I LVL=0 D
"RTN","VAFCQRY3",132,0)
 ....I $L(APID(12)_NXT)'>244 S APID(12)=APID(12)_NXT Q
"RTN","VAFCQRY3",133,0)
 ....I $L(APID(12)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(12)),APID(12)=APID(12)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT))
"RTN","VAFCQRY3",134,0)
 ...I LVL>0 D
"RTN","VAFCQRY3",135,0)
 ....I $L($G(APID(12,LVL))_NXT)'>245 S APID(12,LVL)=$G(APID(12,LVL))_NXT Q
"RTN","VAFCQRY3",136,0)
 ....I $L($G(APID(12,LVL))_NXT)>245 S LNGTH=244-$L(APID(12,LVL)),APID(12,LVL)=APID(12,LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(12,LVL)=NXT
"RTN","VAFCQRY3",137,0)
 I $D(SARY(12))!(SEQ="ALL") S APID(13)=$$GET1^DIQ(2,DFN_",",.117) I APID(13)="" S APID(13)=HL("Q")  ;county code **648 backwards compatibility only
"RTN","VAFCQRY3",138,0)
PHONE I $D(SARY(13))!($D(SARY(14)))!(SEQ="ALL") D
"RTN","VAFCQRY3",139,0)
 .;**707 change PID-13 to have home and work phones, cell, pager and e-mail address with the components ; **754 add confidential phone number to PID-13
"RTN","VAFCQRY3",140,0)
 .N PHONEN,HNUM,WNUM,EMAIL,CELL,PAGER,CONFNUM ;**754
"RTN","VAFCQRY3",141,0)
 .S PHONEN=$G(^DPT(DFN,.13))
"RTN","VAFCQRY3",142,0)
 .; **707 change to ensure that null doesn't end up for any of these fields cmc 12/7/06
"RTN","VAFCQRY3",143,0)
 .S HNUM=$P(PHONEN,"^") I HNUM'="" S HNUM=$$HLPHONE^HLFNC(HNUM) I HNUM'="" S HL7STRG=HNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S HNUM=HL7STRG_COMP_"PRN"_COMP_"PH"
"RTN","VAFCQRY3",144,0)
 .S WNUM=$P(PHONEN,"^",2) I WNUM'="" S WNUM=$$HLPHONE^HLFNC(WNUM) I WNUM'="" S HL7STRG=WNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S WNUM=HL7STRG_COMP_"WPN"_COMP_"PH"
"RTN","VAFCQRY3",145,0)
 .S CELL=$P(PHONEN,"^",4) I CELL'="" S CELL=$$HLPHONE^HLFNC(CELL) I CELL'="" S HL7STRG=CELL D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CELL=HL7STRG_COMP_"ORN"_COMP_"CP"
"RTN","VAFCQRY3",146,0)
 .S PAGER=$P(PHONEN,"^",5) I PAGER'="" S PAGER=$$HLPHONE^HLFNC(PAGER) I PAGER'="" S HL7STRG=PAGER D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S PAGER=HL7STRG_COMP_"BPN"_COMP_"BP"
"RTN","VAFCQRY3",147,0)
 .S EMAIL=$P(PHONEN,"^",3) I EMAIL'="" S HL7STRG=EMAIL D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S EMAIL=COMP_"NET"_COMP_"INTERNET"_COMP_HL7STRG
"RTN","VAFCQRY3",148,0)
 .S CONFNUM=$P(PHONEN,"^",15) I CONFNUM'="" S CONFNUM=$$HLPHONE^HLFNC(CONFNUM) I CONFNUM'="" S HL7STRG=CONFNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CONFNUM=HL7STRG_COMP_"VACPN"_COMP_"PH" ;**574
"RTN","VAFCQRY3",149,0)
 .I HNUM'="" S APID(14)=HNUM
"RTN","VAFCQRY3",150,0)
 .I WNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_WNUM
"RTN","VAFCQRY3",151,0)
 .I WNUM'="",APID(14)="" S APID(14)=WNUM
"RTN","VAFCQRY3",152,0)
 .I CELL'="",APID(14)'="" S APID(14)=APID(14)_REP_CELL
"RTN","VAFCQRY3",153,0)
 .I CELL'="",APID(14)="" S APID(14)=CELL
"RTN","VAFCQRY3",154,0)
 .I PAGER'="",APID(14)'="" S APID(14)=APID(14)_REP_PAGER
"RTN","VAFCQRY3",155,0)
 .I PAGER'="",APID(14)="" S APID(14)=PAGER
"RTN","VAFCQRY3",156,0)
 .I EMAIL'="",APID(14)'="" S APID(14)=APID(14)_REP_EMAIL
"RTN","VAFCQRY3",157,0)
 .I EMAIL'="",APID(14)="" S APID(14)=EMAIL
"RTN","VAFCQRY3",158,0)
 .I CONFNUM'="",APID(14)'="" S APID(14)=APID(14)_REP_CONFNUM ;**754
"RTN","VAFCQRY3",159,0)
 .I CONFNUM'="",APID(14)="" S APID(14)=CONFNUM ;**754
"RTN","VAFCQRY3",160,0)
 .I APID(14)="" S APID(14)=HL("Q")
"RTN","VAFCQRY3",161,0)
 I $D(SARY(14))!(SEQ="ALL") N WNUM S WNUM=$P($G(^DPT(DFN,.13)),"^",2) S WNUM=$$HLPHONE^HLFNC(WNUM) S HL7STRG=WNUM D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S APID(15)=HL7STRG I APID(15)="" S APID(15)=HL("Q")
"RTN","VAFCQRY3",162,0)
 ;**707 keep work# in PID-14 for backwards compatability but should use PID-13 to get work#
"RTN","VAFCQRY3",163,0)
 I $D(SARY(19))!(SEQ="ALL") S APID(20)=SSN  ;ssn passed in PID-3
"RTN","VAFCQRY3",164,0)
 I $D(SARY(23))!(SEQ="ALL") D
"RTN","VAFCQRY3",165,0)
 .S CITY=$$GET1^DIQ(2,DFN_",",.092) S HL7STRG=CITY D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S CITY=HL7STRG
"RTN","VAFCQRY3",166,0)
 .S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
"RTN","VAFCQRY3",167,0)
 .I CITY'=""&(STATE'="") S APID(24)=CITY_" "_STATE  ;place of birth (not used) use PID-11 with an 'N' instead
"RTN","VAFCQRY3",168,0)
 .I CITY=""&(STATE="") S APID(24)=HL("Q")
"RTN","VAFCQRY3",169,0)
 D CONT^VAFCQRY4(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERROR,REP,COMP)
"RTN","VAFCQRY3",170,0)
 ;**707 had to break routine
"RTN","VAFCQRY3",171,0)
 Q
"RTN","VAFHLZAV")
0^17^B4403961
"RTN","VAFHLZAV",1,0)
VAFHLZAV ;ALB/KUM - Create HL7 ZAV segment ;11/26/17 3:34PM
"RTN","VAFHLZAV",2,0)
 ;;5.3;Registration;**941**;Aug 13, 1993;Build 73
"RTN","VAFHLZAV",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","VAFHLZAV",4,0)
 ;
"RTN","VAFHLZAV",5,0)
 ; This generic extrinsic function is designed to return the
"RTN","VAFHLZAV",6,0)
 ; HL7 ZAV segment(s).
"RTN","VAFHLZAV",7,0)
 ;
"RTN","VAFHLZAV",8,0)
EN(DFN,VAFSTR,VAFHLQ,VAFHLFS,IVMZAV,IVMZAVA) ; --
"RTN","VAFHLZAV",9,0)
 ; Entry point for creating HL7 ZAV segment.
"RTN","VAFHLZAV",10,0)
 ;
"RTN","VAFHLZAV",11,0)
 ;Variables Required to use this routine:
"RTN","VAFHLZAV",12,0)
 ; HL - array that contains the necessary HL variables (init^hlsub)
"RTN","VAFHLZAV",13,0)
 ;
"RTN","VAFHLZAV",14,0)
 ; Input(s):
"RTN","VAFHLZAV",15,0)
 ; DFN - internal entry number of Patient (#2) file
"RTN","VAFHLZAV",16,0)
 ; VAFSTR - (optional) string of fields requested, separated by
"RTN","VAFHLZAV",17,0)
 ; commas. If not passed, return all data fields.
"RTN","VAFHLZAV",18,0)
 ; VAFHLQ - (optional) HL7 null variable.
"RTN","VAFHLZAV",19,0)
 ; VAFHLFS - (optional) HL7 field separator.
"RTN","VAFHLZAV",20,0)
 ;
"RTN","VAFHLZAV",21,0)
 ; Output(s):
"RTN","VAFHLZAV",22,0)
 ; IVMZAV() - array containing the HL7 ZAV segment(s)
"RTN","VAFHLZAV",23,0)
 ;
"RTN","VAFHLZAV",24,0)
 N VAFY,VAFHLSC,SUB,SUB1,SID,VAFHLC
"RTN","VAFHLZAV",25,0)
 ;
"RTN","VAFHLZAV",26,0)
 I VAFHLFS="" S VAFHLFS="^"
"RTN","VAFHLZAV",27,0)
 S:($L(VAFHLFS)'=1) VAFHLFS="^"
"RTN","VAFHLZAV",28,0)
 S VAFHLC=$G(VAFHLC) I VAFHLC="" S VAFHLC="~|\&"
"RTN","VAFHLZAV",29,0)
 S:($L(VAFHLC)'=4) VAFHLC="~|\&"
"RTN","VAFHLZAV",30,0)
 S:('$D(VAFHLQ)) VAFHLQ=$C(34,34)
"RTN","VAFHLZAV",31,0)
 S VAFHLSC=$E(VAFHLC,1)
"RTN","VAFHLZAV",32,0)
 ;
"RTN","VAFHLZAV",33,0)
 ; if DFN not passed, exit
"RTN","VAFHLZAV",34,0)
 I '$G(DFN) S VAFY=1 G ENQ
"RTN","VAFHLZAV",35,0)
 ;
"RTN","VAFHLZAV",36,0)
 ; if VAFSTR not passed, return all data fields
"RTN","VAFHLZAV",37,0)
 ; Address Types - Permanent (P), Residential (R), Temporary (C), Confidential (CNF)
"RTN","VAFHLZAV",38,0)
 I $G(VAFSTR)']"" S VAFSTR="1,2,3"
"RTN","VAFHLZAV",39,0)
 ;
"RTN","VAFHLZAV",40,0)
 ; initialize output string and requested data fields
"RTN","VAFHLZAV",41,0)
 S $P(VAFY,VAFHLFS,2)="",VAFSTR=","_VAFSTR_","
"RTN","VAFHLZAV",42,0)
 ;
"RTN","VAFHLZAV",43,0)
 ; get Address Types from Patient (#2) file
"RTN","VAFHLZAV",44,0)
 ; .1159 RESIDENTIAL ADDR CASS IND (S), [.115;19]
"RTN","VAFHLZAV",45,0)
 ; .12115 TEMPORARY ADDR CASS IND (S), [.121;15]
"RTN","VAFHLZAV",46,0)
 ; .123 STREET ADDRESS CASS IND (S), [.11;18]
"RTN","VAFHLZAV",47,0)
 ; .14117 CONFIDENTIAL ADDR CASS IND (S), [.141;17]
"RTN","VAFHLZAV",48,0)
 K ADT
"RTN","VAFHLZAV",49,0)
 S SUB1=""
"RTN","VAFHLZAV",50,0)
 F  S SUB1=$O(IVMZAVA(SUB1)) Q:SUB1=""  D
"RTN","VAFHLZAV",51,0)
 .I SUB1="R" S ADT("R")=$$GET1^DIQ(2,DFN,".1159","I")
"RTN","VAFHLZAV",52,0)
 .I SUB1="C" S ADT("C")=$$GET1^DIQ(2,DFN,".12115","I")
"RTN","VAFHLZAV",53,0)
 .I SUB1="P" S ADT("P")=$$GET1^DIQ(2,DFN,".123","I")
"RTN","VAFHLZAV",54,0)
 .I SUB1="CNF" S ADT("CNF")=$$GET1^DIQ(2,DFN,".14117","I")
"RTN","VAFHLZAV",55,0)
 I $D(ADT) D
"RTN","VAFHLZAV",56,0)
 .S SID=0
"RTN","VAFHLZAV",57,0)
 .S SUB=""
"RTN","VAFHLZAV",58,0)
 .F  S SUB=$O(ADT(SUB)) Q:SUB=""  D
"RTN","VAFHLZAV",59,0)
 ..I $D(ADT(SUB)) D
"RTN","VAFHLZAV",60,0)
 ...I VAFSTR[",1," S SID=SID+1,$P(VAFY,VAFHLFS)=SID       ;Set ID
"RTN","VAFHLZAV",61,0)
 ...I VAFSTR[",2," S $P(VAFY,VAFHLFS,2)=SUB ; Address Type
"RTN","VAFHLZAV",62,0)
 ...I ADT(SUB)="" S ADT(SUB)="NC"
"RTN","VAFHLZAV",63,0)
 ...I VAFSTR[",3," S $P(VAFY,VAFHLFS,3)=ADT(SUB) ;Address Validation Indicator
"RTN","VAFHLZAV",64,0)
 ...S IVMZAV("HL7",SID)="ZAV"_VAFHLFS_VAFY
"RTN","VAFHLZAV",65,0)
 ;
"RTN","VAFHLZAV",66,0)
ENQ Q
"VER")
8.0^22.2
"^DD",2,2,.111,0)
STREET ADDRESS [LINE 1]^FaXJ35^^.11;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X D:$D(X) UP^DGHELP
"^DD",2,2,.111,.1)

"^DD",2,2,.111,1,0)
^.1
"^DD",2,2,.111,1,1,0)
2^AXR29^MUMPS
"^DD",2,2,.111,1,1,1)
Q
"^DD",2,2,.111,1,1,2)
S DGXRF=.111 D ^DGDDC Q
"^DD",2,2,.111,1,2,0)
2^AODS111^MUMPS
"^DD",2,2,.111,1,2,1)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.111,1,2,2)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.111,1,3,0)
2^AENR111^MUMPS
"^DD",2,2,.111,1,3,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.111,1,3,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.111,1,3,3)
DO NOT DELETE
"^DD",2,2,.111,1,3,"%D",0)
^.101^2^2^3171219^^^^
"^DD",2,2,.111,1,3,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.111,1,3,"%D",2,0)
enrollment. 
"^DD",2,2,.111,1,3,"DT")
2971007
"^DD",2,2,.111,1,4,0)
^^TRIGGER^2^.118
"^DD",2,2,.111,1,4,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.111,1,4,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.111,1,4,"%D",0)
^^2^2^3020703^
"^DD",2,2,.111,1,4,"%D",1,0)
This cross-reference will be used to update the Date/Time stamp for an 
"^DD",2,2,.111,1,4,"%D",2,0)
Address Change.
"^DD",2,2,.111,1,4,"CREATE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.111,1,4,"DELETE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.111,1,4,"DT")
3020703
"^DD",2,2,.111,1,4,"FIELD")
ADDRESS CHANGE DT/TM
"^DD",2,2,.111,1,301,0)
2^IVM111^MUMPS
"^DD",2,2,.111,1,301,1)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.111,1,301,2)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.111,1,301,"%D",0)
^.101^4^4^3171220^^^^
"^DD",2,2,.111,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.111,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.111,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.111,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.111,1,301,"DT")
2930605
"^DD",2,2,.111,1,991,0)
2^AVAFC111^MUMPS
"^DD",2,2,.111,1,991,1)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.111,1,991,2)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.111,1,991,"%D",0)
^.101^15^15^3171220^^^^
"^DD",2,2,.111,1,991,"%D",1,0)
This cross reference is used to remember that changes were made to the
"^DD",2,2,.111,1,991,"%D",2,0)
PATIENT file (#2) outside of the Registration process.  Execution of this
"^DD",2,2,.111,1,991,"%D",3,0)
cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
"^DD",2,2,.111,1,991,"%D",4,0)
and mark it as requiring transmission of an HL7 ADT-A08 message.
"^DD",2,2,.111,1,991,"%D",5,0)
 
"^DD",2,2,.111,1,991,"%D",6,0)
The local variable VAFCFLG will be set to 1 if the cross reference is
"^DD",2,2,.111,1,991,"%D",7,0)
not executed because the change is being made from within the Registration
"^DD",2,2,.111,1,991,"%D",8,0)
process.
"^DD",2,2,.111,1,991,"%D",9,0)
 
"^DD",2,2,.111,1,991,"%D",10,0)
Execution of this cross reference can be prevented by setting the local
"^DD",2,2,.111,1,991,"%D",11,0)
variable VAFCA08 equal to 1.
"^DD",2,2,.111,1,991,"%D",12,0)
  
"^DD",2,2,.111,1,991,"%D",13,0)
The local variable VAFCF is used to identify the field edited.
"^DD",2,2,.111,1,991,"%D",14,0)
This data is stored in the FIELD(S) EDITED (#2.1) field in the 
"^DD",2,2,.111,1,991,"%D",15,0)
ADT/HL7 PIVOT file (#391.71).
"^DD",2,2,.111,1,991,"DT")
2970825
"^DD",2,2,.111,1,992,0)
2^ADGRU111^MUMPS
"^DD",2,2,.111,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.111,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.111,1,992,"%D",0)
^.101^9^9^3171219^^^
"^DD",2,2,.111,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.111,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.111,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.111,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.111,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.111,1,992,"%D",6,0)
interface.
"^DD",2,2,.111,1,992,"%D",7,0)
 
"^DD",2,2,.111,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.111,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.111,1,992,"DT")
2990917
"^DD",2,2,.111,3)
Enter the first line of this applicant's residence street address [3-35 characters].
"^DD",2,2,.111,20,0)
^.3LA^2^1
"^DD",2,2,.111,20,1,0)
ADR^
"^DD",2,2,.111,20,2,0)
DEMOG^
"^DD",2,2,.111,21,0)
^^2^2^2910501^^^^
"^DD",2,2,.111,21,1,0)
Enter the first line of this applicant's residence street address
"^DD",2,2,.111,21,2,0)
[3-35 characters].
"^DD",2,2,.111,"AUDIT")
y
"^DD",2,2,.111,"DT")
3180227
"^DD",2,2,.1118,0)
STREET ADDRESS CASS IND^S^Y:CERTIFIED BY CASS;F:FAILED CASS CERTIFICATION;NC:NOT CHECKED AGAINST CASS;PV:PROCESSING;^.11;18^Q
"^DD",2,2,.1118,3)
Select the CASS status for the street address. 
"^DD",2,2,.1118,21,0)
^^2^2^3180122^
"^DD",2,2,.1118,21,1,0)
The Street Address CASS Indicator is used to determine whether the street
"^DD",2,2,.1118,21,2,0)
address has been certified by CASS.
"^DD",2,2,.1118,"DT")
3180213
"^DD",2,2,.113,0)
STREET ADDRESS [LINE 3]^FaXJ30^^.11;3^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP
"^DD",2,2,.113,.1)

"^DD",2,2,.113,1,0)
^.1
"^DD",2,2,.113,1,1,0)
2^AODS113^MUMPS
"^DD",2,2,.113,1,1,1)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.113,1,1,2)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.113,1,2,0)
2^AENR113^MUMPS
"^DD",2,2,.113,1,2,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.113,1,2,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.113,1,2,3)
DO NOT DELETE
"^DD",2,2,.113,1,2,"%D",0)
^.101^2^2^3171219^^^^
"^DD",2,2,.113,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.113,1,2,"%D",2,0)
enrollment. 
"^DD",2,2,.113,1,2,"DT")
2971007
"^DD",2,2,.113,1,3,0)
^^TRIGGER^2^.118
"^DD",2,2,.113,1,3,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.113,1,3,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.113,1,3,"%D",0)
^^2^2^3020703^
"^DD",2,2,.113,1,3,"%D",1,0)
This cross-reference will update the Address Change DT/TM field when 
"^DD",2,2,.113,1,3,"%D",2,0)
address data changes for a patient.
"^DD",2,2,.113,1,3,"CREATE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.113,1,3,"DELETE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.113,1,3,"DT")
3020703
"^DD",2,2,.113,1,3,"FIELD")
ADDRESS CHANGE DT
"^DD",2,2,.113,1,301,0)
2^IVM113^MUMPS
"^DD",2,2,.113,1,301,1)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.113,1,301,2)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.113,1,301,"%D",0)
^^5^5^2930605^
"^DD",2,2,.113,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.113,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.113,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.113,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.113,1,301,"DT")
2930605
"^DD",2,2,.113,1,991,0)
2^AVAFC113^MUMPS
"^DD",2,2,.113,1,991,1)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.113,1,991,2)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.113,1,991,"%D",0)
^.101^15^15^3171219^^^^
"^DD",2,2,.113,1,991,"%D",1,0)
This cross reference is used to remember that changes were made to the
"^DD",2,2,.113,1,991,"%D",2,0)
PATIENT file (#2) outside of the Registration process.  Execution of this
"^DD",2,2,.113,1,991,"%D",3,0)
cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
"^DD",2,2,.113,1,991,"%D",4,0)
and mark it as requiring transmission of an HL7 ADT-A08 message.
"^DD",2,2,.113,1,991,"%D",5,0)
 
"^DD",2,2,.113,1,991,"%D",6,0)
The local variable VAFCFLG will be set to 1 if the cross reference is
"^DD",2,2,.113,1,991,"%D",7,0)
not executed because the change is being made from within the Registration
"^DD",2,2,.113,1,991,"%D",8,0)
process.
"^DD",2,2,.113,1,991,"%D",9,0)
 
"^DD",2,2,.113,1,991,"%D",10,0)
Execution of this cross reference can be prevented by setting the local
"^DD",2,2,.113,1,991,"%D",11,0)
variable VAFCA08 equal to 1.
"^DD",2,2,.113,1,991,"%D",12,0)
  
"^DD",2,2,.113,1,991,"%D",13,0)
The local variable VAFCF is used to identify the field edited.
"^DD",2,2,.113,1,991,"%D",14,0)
This data is stored in the FIELD(S) EDITED (#2.1) field in the 
"^DD",2,2,.113,1,991,"%D",15,0)
ADT/HL7 PIVOT file (#391.71).
"^DD",2,2,.113,1,991,"DT")
2970825
"^DD",2,2,.113,1,992,0)
2^ADGRU113^MUMPS
"^DD",2,2,.113,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.113,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.113,1,992,"%D",0)
^^9^9^2990920^
"^DD",2,2,.113,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.113,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.113,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.113,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.113,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.113,1,992,"%D",6,0)
interface.
"^DD",2,2,.113,1,992,"%D",7,0)
 
"^DD",2,2,.113,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.113,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.113,1,992,"DT")
2990920
"^DD",2,2,.113,3)
If necessary, enter a third line of this applicant's street address [3-30 characters].
"^DD",2,2,.113,20,0)
^.3LA^1^1
"^DD",2,2,.113,20,1,0)
DEMOG
"^DD",2,2,.113,21,0)
^^3^3^2861007^
"^DD",2,2,.113,21,1,0)
Enter the third line of this applicant's residence street address
"^DD",2,2,.113,21,2,0)
[3-30 characters] if the space provided in 'street address' and
"^DD",2,2,.113,21,3,0)
'street address 2' was not sufficient.
"^DD",2,2,.113,"AUDIT")
y
"^DD",2,2,.113,"DT")
3180227
"^DD",2,2,.114,0)
CITY^FaXJ15^^.11;4^K:$L(X)>15!($L(X)<2) X D:$D(X) UP^DGHELP
"^DD",2,2,.114,1,0)
^.1
"^DD",2,2,.114,1,1,0)
2^AODS114^MUMPS
"^DD",2,2,.114,1,1,1)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.114,1,1,2)
S A1B2TAG="PAT" D ^A1B2XFR
"^DD",2,2,.114,1,2,0)
2^AENR114^MUMPS
"^DD",2,2,.114,1,2,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.114,1,2,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.114,1,2,3)
DO NOT DELETE
"^DD",2,2,.114,1,2,"%D",0)
^.101^2^2^3171219^^^^
"^DD",2,2,.114,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.114,1,2,"%D",2,0)
enrollment. 
"^DD",2,2,.114,1,2,"DT")
2971007
"^DD",2,2,.114,1,3,0)
^^TRIGGER^2^.118
"^DD",2,2,.114,1,3,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.114,1,3,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.114,1,3,"%D",0)
^^2^2^3020703^
"^DD",2,2,.114,1,3,"%D",1,0)
This cross-reference will update the Address Change DT/TM field when 
"^DD",2,2,.114,1,3,"%D",2,0)
address data changes for a patient.
"^DD",2,2,.114,1,3,"CREATE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.114,1,3,"DELETE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.114,1,3,"DT")
3020703
"^DD",2,2,.114,1,3,"FIELD")
ADDRESS CHANGE DT
"^DD",2,2,.114,1,301,0)
2^IVM114^MUMPS
"^DD",2,2,.114,1,301,1)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.114,1,301,2)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.114,1,301,"%D",0)
^.101^4^4^3171219^^^
"^DD",2,2,.114,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.114,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.114,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.114,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.114,1,301,"DT")
2930605
"^DD",2,2,.114,1,991,0)
2^AVAFC114^MUMPS
"^DD",2,2,.114,1,991,1)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.114,1,991,2)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.114,1,991,"%D",0)
^.101^15^15^3171219^^^^
"^DD",2,2,.114,1,991,"%D",1,0)
This cross reference is used to remember that changes were made to the
"^DD",2,2,.114,1,991,"%D",2,0)
PATIENT file (#2) outside of the Registration process.  Execution of this
"^DD",2,2,.114,1,991,"%D",3,0)
cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
"^DD",2,2,.114,1,991,"%D",4,0)
and mark it as requiring transmission of an HL7 ADT-A08 message.
"^DD",2,2,.114,1,991,"%D",5,0)
 
"^DD",2,2,.114,1,991,"%D",6,0)
The local variable VAFCFLG will be set to 1 if the cross reference is
"^DD",2,2,.114,1,991,"%D",7,0)
not executed because the change is being made from within the Registration
"^DD",2,2,.114,1,991,"%D",8,0)
process.
"^DD",2,2,.114,1,991,"%D",9,0)
 
"^DD",2,2,.114,1,991,"%D",10,0)
Execution of this cross reference can be prevented by setting the local
"^DD",2,2,.114,1,991,"%D",11,0)
variable VAFCA08 equal to 1.
"^DD",2,2,.114,1,991,"%D",12,0)
  
"^DD",2,2,.114,1,991,"%D",13,0)
The local variable VAFCF is used to identify the field edited.
"^DD",2,2,.114,1,991,"%D",14,0)
This data is stored in the FIELD(S) EDITED (#2.1) field in the 
"^DD",2,2,.114,1,991,"%D",15,0)
ADT/HL7 PIVOT file (#391.71).
"^DD",2,2,.114,1,991,"DT")
2970825
"^DD",2,2,.114,1,992,0)
2^ADGRU114^MUMPS
"^DD",2,2,.114,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.114,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.114,1,992,"%D",0)
^.101^9^9^3171219^^
"^DD",2,2,.114,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.114,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.114,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.114,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.114,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.114,1,992,"%D",6,0)
interface.
"^DD",2,2,.114,1,992,"%D",7,0)
 
"^DD",2,2,.114,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.114,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.114,1,992,"DT")
2990920
"^DD",2,2,.114,3)
Answer must be 2-15 characters in length
"^DD",2,2,.114,20,0)
^.3LA^1^1
"^DD",2,2,.114,20,1,0)
DEMOG
"^DD",2,2,.114,21,0)
^.001^3^3^3170214^^^
"^DD",2,2,.114,21,1,0)
Enter the city in which this applicant resides [2-15 characters].
"^DD",2,2,.114,21,2,0)
If the space provided is not sufficient please abbreviate the
"^DD",2,2,.114,21,3,0)
city to the best of your ability.
"^DD",2,2,.114,"AUDIT")
y
"^DD",2,2,.114,"DT")
3180227
"^DD",2,2,.1151,0)
RESIDENTIAL ADDRESS [LINE 1]^FJ35Xa^^.115;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X D:$D(X) UP^DGHELP
"^DD",2,2,.1151,1,0)
^.1
"^DD",2,2,.1151,1,1,0)
^^TRIGGER^2^.1152
"^DD",2,2,.1151,1,1,1)
Q
"^DD",2,2,.1151,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.1151,1,1,2.4)
"^DD",2,2,.1151,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.115)),DIV=X S $P(^(.115),U,2)=DIV,DIH=2,DIG=.1152 D ^DICR
"^DD",2,2,.1151,1,1,"%D",0)
^^2^2^3180216^
"^DD",2,2,.1151,1,1,"%D",1,0)
This cross-reference will delete the contents of RESIDENTIAL ADDRESS 
"^DD",2,2,.1151,1,1,"%D",2,0)
[LINE 2] whenever this field is deleted.
"^DD",2,2,.1151,1,1,"CREATE VALUE")
NO EFFECT
"^DD",2,2,.1151,1,1,"DELETE CONDITION")
RESIDENTIAL ADDRESS [LINE 1]=""
"^DD",2,2,.1151,1,1,"DELETE VALUE")
@
"^DD",2,2,.1151,1,1,"DT")
3180216
"^DD",2,2,.1151,1,1,"FIELD")
RESIDENTIAL ADDRESS [LINE 2]
"^DD",2,2,.1151,1,2,0)
2^AENR1151^MUMPS
"^DD",2,2,.1151,1,2,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1151,1,2,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1151,1,2,3)
DO NOT DELETE
"^DD",2,2,.1151,1,2,"%D",0)
^.101^2^2^3180215^^^
"^DD",2,2,.1151,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.1151,1,2,"%D",2,0)
enrollment. 
"^DD",2,2,.1151,1,2,"DT")
3171219
"^DD",2,2,.1151,1,301,0)
2^AIVM1151^MUMPS
"^DD",2,2,.1151,1,301,1)
D DPT^IVMPXFR
"^DD",2,2,.1151,1,301,2)
D DPT^IVMPXFR
"^DD",2,2,.1151,1,301,"%D",0)
^.101^4^4^3171226^^^
"^DD",2,2,.1151,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.1151,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.1151,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.1151,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.1151,1,301,"DT")
3171226
"^DD",2,2,.1151,3)
Answer must be 3-35 characters in length.
"^DD",2,2,.1151,21,0)
^.001^1^1^3180420^^^^
"^DD",2,2,.1151,21,1,0)
This is the first line of this applicant's residential address
"^DD",2,2,.1151,"AUDIT")
y
"^DD",2,2,.1151,"DT")
3180420
"^DD",2,2,.1152,0)
RESIDENTIAL ADDRESS [LINE 2]^FJ30aX^^.115;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP
"^DD",2,2,.1152,1,0)
^.1
"^DD",2,2,.1152,1,1,0)
2^AENR1152^MUMPS
"^DD",2,2,.1152,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1152,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1152,1,1,3)
DO NOT DELETE
"^DD",2,2,.1152,1,1,"%D",0)
^.101^2^2^3171219^^
"^DD",2,2,.1152,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.1152,1,1,"%D",2,0)
enrollment.
"^DD",2,2,.1152,1,1,"DT")
3171219
"^DD",2,2,.1152,1,2,0)
^^TRIGGER^2^.1153
"^DD",2,2,.1152,1,2,1)
Q
"^DD",2,2,.1152,1,2,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.1152,1,2,2.4)
"^DD",2,2,.1152,1,2,2.4)
S DIH=$G(^DPT(DIV(0),.115)),DIV=X S $P(^(.115),U,3)=DIV,DIH=2,DIG=.1153 D ^DICR
"^DD",2,2,.1152,1,2,"%D",0)
^^2^2^3180216^
"^DD",2,2,.1152,1,2,"%D",1,0)
This cross-reference will delete the contents of RESIDENTIAL ADDRESS
"^DD",2,2,.1152,1,2,"%D",2,0)
[LINE 3] whenever this field is deleted.
"^DD",2,2,.1152,1,2,"CREATE VALUE")
NO EFFECT
"^DD",2,2,.1152,1,2,"DELETE CONDITION")
RESIDENTIAL ADDRESS [LINE 2]=""
"^DD",2,2,.1152,1,2,"DELETE VALUE")
@
"^DD",2,2,.1152,1,2,"DT")
3180216
"^DD",2,2,.1152,1,2,"FIELD")
RESIDENTIAL ADDRESS [LINE 3]
"^DD",2,2,.1152,1,301,0)
2^AIVM1152^MUMPS
"^DD",2,2,.1152,1,301,1)
D DPT^IVMPXFR
"^DD",2,2,.1152,1,301,2)
D DPT^IVMPXFR
"^DD",2,2,.1152,1,301,"%D",0)
^.101^4^4^3171226^^
"^DD",2,2,.1152,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.1152,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.1152,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.1152,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.1152,1,301,"DT")
3171226
"^DD",2,2,.1152,3)
Answer must be 3-30 characters in length.
"^DD",2,2,.1152,5,1,0)
2^.1151^1
"^DD",2,2,.1152,21,0)
^.001^3^3^3180212^^
"^DD",2,2,.1152,21,1,0)
This is the second line of this applicant's residential address [3-30
"^DD",2,2,.1152,21,2,0)
characters] if the space provided in 'residential address [Line 1]' was 
"^DD",2,2,.1152,21,3,0)
not sufficient.
"^DD",2,2,.1152,"AUDIT")
y
"^DD",2,2,.1152,"DT")
3180227
"^DD",2,2,.1153,0)
RESIDENTIAL ADDRESS [LINE 3]^FJ30aX^^.115;3^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP
"^DD",2,2,.1153,1,0)
^.1
"^DD",2,2,.1153,1,1,0)
2^AENR1153^MUMPS
"^DD",2,2,.1153,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1153,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1153,1,1,3)
DO NOT DELETE
"^DD",2,2,.1153,1,1,"%D",0)
^^2^2^3171219^
"^DD",2,2,.1153,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.1153,1,1,"%D",2,0)
enrollment. 
"^DD",2,2,.1153,1,1,"DT")
3171219
"^DD",2,2,.1153,1,301,0)
2^AIVM1153^MUMPS
"^DD",2,2,.1153,1,301,1)
D DPT^IVMPXFR
"^DD",2,2,.1153,1,301,2)
D DPT^IVMPXFR
"^DD",2,2,.1153,1,301,"%D",0)
^.101^4^4^3171226^^
"^DD",2,2,.1153,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.1153,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.1153,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.1153,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.1153,1,301,"DT")
3171226
"^DD",2,2,.1153,3)
Answer must be 3-30 characters in length.
"^DD",2,2,.1153,5,1,0)
2^.1152^2
"^DD",2,2,.1153,21,0)
^^3^3^3180201^
"^DD",2,2,.1153,21,1,0)
This is the third line of this applicant's residential address
"^DD",2,2,.1153,21,2,0)
[3-30 characters] if the space provided in 'residential address [Line 1]' 
"^DD",2,2,.1153,21,3,0)
and 'residential address [Line 2]' was not sufficient.
"^DD",2,2,.1153,"AUDIT")
y
"^DD",2,2,.1153,"DT")
3180227
"^DD",2,2,.1154,0)
RESIDENTIAL CITY^FJ15aX^^.115;4^K:$L(X)>15!($L(X)<2) X D:$D(X) UP^DGHELP
"^DD",2,2,.1154,1,0)
^.1
"^DD",2,2,.1154,1,1,0)
2^AENR1154^MUMPS
"^DD",2,2,.1154,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1154,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1154,1,1,3)
DO NOT DELETE
"^DD",2,2,.1154,1,1,"%D",0)
^^2^2^3171219^
"^DD",2,2,.1154,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.1154,1,1,"%D",2,0)
enrollment. 
"^DD",2,2,.1154,1,1,"DT")
3171219
"^DD",2,2,.1154,1,301,0)
2^AIVM1154^MUMPS
"^DD",2,2,.1154,1,301,1)
D DPT^IVMPXFR
"^DD",2,2,.1154,1,301,2)
D DPT^IVMPXFR
"^DD",2,2,.1154,1,301,"%D",0)
^.101^4^4^3180215^^^
"^DD",2,2,.1154,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.1154,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.1154,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.1154,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.1154,1,301,"DT")
3180215
"^DD",2,2,.1154,3)
Answer must be 2-15 characters in length.
"^DD",2,2,.1154,21,0)
^.001^1^1^3180213^^^^
"^DD",2,2,.1154,21,1,0)
This is the city in which this applicant resides
"^DD",2,2,.1154,"AUDIT")
y
"^DD",2,2,.1154,"DT")
3180227
"^DD",2,2,.1155,0)
RESIDENTIAL STATE^P5'a^DIC(5,^.115;5^Q
"^DD",2,2,.1155,1,0)
^.1
"^DD",2,2,.1155,1,1,0)
2^AENR1155^MUMPS
"^DD",2,2,.1155,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1155,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1155,1,1,3)
DO NOT DELETE
"^DD",2,2,.1155,1,1,"%D",0)
^^2^2^3171219^
"^DD",2,2,.1155,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.1155,1,1,"%D",2,0)
enrollment. 
"^DD",2,2,.1155,1,1,"DT")
3171219
"^DD",2,2,.1155,1,301,0)
2^AIVM1155^MUMPS
"^DD",2,2,.1155,1,301,1)
D DPT^IVMPXFR
"^DD",2,2,.1155,1,301,2)
D DPT^IVMPXFR
"^DD",2,2,.1155,1,301,"%D",0)
^.101^4^4^3171226^^
"^DD",2,2,.1155,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.1155,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.1155,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.1155,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.1155,1,301,"DT")
3171226
"^DD",2,2,.1155,3)
Select from the available listing the state in which this applicant resides.
"^DD",2,2,.1155,21,0)
^.001^1^1^3180213^^^^
"^DD",2,2,.1155,21,1,0)
This is the state in which this applicant resides
"^DD",2,2,.1155,"AUDIT")
y
"^DD",2,2,.1155,"DT")
3180213
"^DD",2,2,.1156,0)
RESIDENTIAL ZIP+4^FaXJ20O^^.115;6^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
"^DD",2,2,.1156,1,0)
^.1
"^DD",2,2,.1156,1,1,0)
2^AENR1156^MUMPS
"^DD",2,2,.1156,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1156,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1156,1,1,3)
DO NOT DELETE
"^DD",2,2,.1156,1,1,"%D",0)
^^2^2^3171219^
"^DD",2,2,.1156,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.1156,1,1,"%D",2,0)
enrollment. 
"^DD",2,2,.1156,1,1,"DT")
3171219
"^DD",2,2,.1156,1,301,0)
2^AIVM1156^MUMPS
"^DD",2,2,.1156,1,301,1)
D DPT^IVMPXFR
"^DD",2,2,.1156,1,301,2)
D DPT^IVMPXFR
"^DD",2,2,.1156,1,301,"%D",0)
^.101^4^4^3171226^^
"^DD",2,2,.1156,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.1156,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.1156,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.1156,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.1156,1,301,"DT")
3171226
"^DD",2,2,.1156,2)
S Y(0)=Y D ZIPOUT^VAFADDR
"^DD",2,2,.1156,2.1)
D ZIPOUT^VAFADDR
"^DD",2,2,.1156,3)
Answer with either 5 digit or 9 digit zip code.
"^DD",2,2,.1156,20,0)
^.3LA^1^1
"^DD",2,2,.1156,20,1,0)
DEMOG
"^DD",2,2,.1156,21,0)
^.001^1^1^3180213^^^^
"^DD",2,2,.1156,21,1,0)
This is the zip code for the city in which this applicant resides
"^DD",2,2,.1156,"AUDIT")
y
"^DD",2,2,.1156,"DT")
3180213
"^DD",2,2,.1157,0)
RESIDENTIAL COUNTY^NJ1,0aXO^^.115;7^S Z0=$S($D(^DPT(D0,.115)):+$P(^(.115),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0))  S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC
"^DD",2,2,.1157,1,0)
^.1
"^DD",2,2,.1157,1,1,0)
2^AENR1157^MUMPS
"^DD",2,2,.1157,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1157,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.1157,1,1,3)
DO NOT DELETE
"^DD",2,2,.1157,1,1,"%D",0)
^^2^2^3180124^
"^DD",2,2,.1157,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect 
"^DD",2,2,.1157,1,1,"%D",2,0)
enrollment. 
"^DD",2,2,.1157,1,1,"DT")
3180124
"^DD",2,2,.1157,1,2,0)
2^AIVM1157^MUMPS
"^DD",2,2,.1157,1,2,1)
D DPT^IVMPXFR
"^DD",2,2,.1157,1,2,2)
D DPT^IVMPXFR
"^DD",2,2,.1157,1,2,"%D",0)
^^4^4^3180124^
"^DD",2,2,.1157,1,2,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change 
"^DD",2,2,.1157,1,2,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does, 
"^DD",2,2,.1157,1,2,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and the 
"^DD",2,2,.1157,1,2,"%D",4,0)
nightly background job will transmit the updated information. 
"^DD",2,2,.1157,1,2,"DT")
3180124
"^DD",2,2,.1157,2)
S Y(0)=Y Q:Y']""  S Z0=$S($D(^DPT(D0,.115)):+$P(^(.115),"^",5),1:"") Q:'Z0  S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""),"^",3)
"^DD",2,2,.1157,2.1)
Q:Y']""  S Z0=$S($D(^DPT(D0,.115)):+$P(^(.115),"^",5),1:"") Q:'Z0  S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""),"^",3)
"^DD",2,2,.1157,3)
Enter the county in which this applicant resides.
"^DD",2,2,.1157,4)
S ZD=D,X="?",Z0=$S($D(^DPT(D0,.115)):+$P(^(.115),U,5),1:0) Q:'Z0!'$D(^DIC(5,Z0,1,0))  S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S DIC=DIE,D=ZD K ZD
"^DD",2,2,.1157,21,0)
^.001^3^3^3180213^^^^
"^DD",2,2,.1157,21,1,0)
If a state of residence is entered select from the available listing the 
"^DD",2,2,.1157,21,2,0)
county in which this applicant resides.  If no state (or a non-state) is 
"^DD",2,2,.1157,21,3,0)
entered no selection is possible. 
"^DD",2,2,.1157,"AUDIT")
y
"^DD",2,2,.1157,"DT")
3180124
"^DD",2,2,.11571,0)
RESIDENTIAL PROVINCE^FaXJ20^^.115;8^K:$L(X)>20!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.11571,3)
Answer must be 1-20 characters in length.
"^DD",2,2,.11571,21,0)
^.001^1^1^3151218^^
"^DD",2,2,.11571,21,1,0)
This is the Province for a foreign residential address
"^DD",2,2,.11571,"AUDIT")
y
"^DD",2,2,.11571,"DT")
3180227
"^DD",2,2,.11572,0)
RESIDENTIAL POSTAL CODE^FaXJ10^^.115;9^K:$L(X)>10!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.11572,3)
Answer must be 1-10 characters in length.
"^DD",2,2,.11572,21,0)
^.001^1^1^3151218^^
"^DD",2,2,.11572,21,1,0)
This is the Postal Code for a patient which has a foreign address.
"^DD",2,2,.11572,"AUDIT")
y
"^DD",2,2,.11572,"DT")
3180227
"^DD",2,2,.11573,0)
RESIDENTIAL COUNTRY^P779.004'a^HL(779.004,^.115;10^Q
"^DD",2,2,.11573,3)
Enter the country where the patient's residential address is located.  If entering an Army/Air Force Post Office (APO) or a Fleet Post Office (FPO) address select United States as the country.
"^DD",2,2,.11573,21,0)
^.001^1^1^3180215^^^^
"^DD",2,2,.11573,21,1,0)
This is the country where the patient's residential address is located.
"^DD",2,2,.11573,"AUDIT")
y
"^DD",2,2,.11573,"DT")
3180215
"^DD",2,2,.1158,0)
RESIDENTIAL ADDR CHANGE DT/TM^DX^^.115;11^S %DT="ESTX" D ^%DT S X=Y K:Y<1 X
"^DD",2,2,.1158,1,0)
^.1
"^DD",2,2,.1158,1,1,0)
^^TRIGGER^2^.11581
"^DD",2,2,.1158,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1158,1,1,1.4)
"^DD",2,2,.1158,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.115)),DIV=X S $P(^(.115),U,15)=DIV,DIH=2,DIG=.11581 D ^DICR
"^DD",2,2,.1158,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1158,1,1,2.4)
"^DD",2,2,.1158,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.115)),DIV=X S $P(^(.115),U,15)=DIV,DIH=2,DIG=.11581 D ^DICR
"^DD",2,2,.1158,1,1,"%D",0)
^.101^2^2^3171208^^
"^DD",2,2,.1158,1,1,"%D",1,0)
This cross-reference will trigger the population of the RESIDENTIAL ADDR 
"^DD",2,2,.1158,1,1,"%D",2,0)
CHANGE SITE field with the appropriate station number.  
"^DD",2,2,.1158,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.1158,1,1,"DELETE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.1158,1,1,"DT")
3170731
"^DD",2,2,.1158,1,1,"FIELD")
RESIDENTIAL ADDR CHANGE SITE
"^DD",2,2,.1158,1,2,0)
^^TRIGGER^2^.11582
"^DD",2,2,.1158,1,2,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.115)),DIV=X S $P(^(.115),U,12)=DIV,DIH=2,DIG=.11582 D ^DICR
"^DD",2,2,.1158,1,2,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.115)):^(.115),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.115)),DIV=X S $P(^(.115),U,12)=DIV,DIH=2,DIG=.11582 D ^DICR
"^DD",2,2,.1158,1,2,"%D",0)
^^4^4^3180102^
"^DD",2,2,.1158,1,2,"%D",1,0)
This cross-reference will update the Residential Addr Source field when 
"^DD",2,2,.1158,1,2,"%D",2,0)
address data changes for a patient.  The source will be set to 'VAMC', 
"^DD",2,2,.1158,1,2,"%D",3,0)
and should be overwritten for instances where the Address source is 
"^DD",2,2,.1158,1,2,"%D",4,0)
something different.
"^DD",2,2,.1158,1,2,"CREATE VALUE")
S X="VAMC"
"^DD",2,2,.1158,1,2,"DELETE VALUE")
S X="VAMC"
"^DD",2,2,.1158,1,2,"DT")
3180102
"^DD",2,2,.1158,1,2,"FIELD")
RESIDENTIAL ADDR CHANGE SOURCE
"^DD",2,2,.1158,3)

"^DD",2,2,.1158,21,0)
^.001^2^2^3180102^^
"^DD",2,2,.1158,21,1,0)
This field will hold the date and time of the last Residential
"^DD",2,2,.1158,21,2,0)
Address update.
"^DD",2,2,.1158,"DT")
3180102
"^DD",2,2,.11581,0)
RESIDENTIAL ADDR CHANGE SITE^P4'^DIC(4,^.115;15^Q
"^DD",2,2,.11581,3)
Please enter the site that last changed this patient's residential address. 
"^DD",2,2,.11581,5,1,0)
2^.1158^1
"^DD",2,2,.11581,21,0)
^.001^2^2^3170814^^^^
"^DD",2,2,.11581,21,1,0)
This field will hold the Site that last changed this patient's 
"^DD",2,2,.11581,21,2,0)
residential address.
"^DD",2,2,.11581,"DT")
3170814
"^DD",2,2,.11582,0)
RESIDENTIAL ADDR CHANGE SOURCE^Sa^HEC:HEC;VAMC:VAMC;HBSC:HBSC;NCOA:NCOA;BVA:BVA;USPS:USPS;LACS:LACS;VOA:VOA;VET360:VET360;VAINS:VAINS;^.115;12^Q
"^DD",2,2,.11582,3)
Please enter the source of the address change.
"^DD",2,2,.11582,5,1,0)
2^.1158^2
"^DD",2,2,.11582,21,0)
^.001^1^1^3180213^^^
"^DD",2,2,.11582,21,1,0)
This field will hold the source of the last Residential Address change.
"^DD",2,2,.11582,"AUDIT")
y
"^DD",2,2,.11582,"DT")
3180213
"^DD",2,2,.1159,0)
RESIDENTIAL ADDR CASS IND^Sa^Y:CERTIFIED BY CASS;F:FAILED CASS CERTIFICATION;NC:NOT CHECKED AGAINST CASS;PV:PROCESSING;^.115;19^Q
"^DD",2,2,.1159,3)
Select the CASS status for the residential address
"^DD",2,2,.1159,21,0)
^.001^2^2^3170419^^^
"^DD",2,2,.1159,21,1,0)
The Residential Addr CASS Indicator is used to determine whether the 
"^DD",2,2,.1159,21,2,0)
residential address has been certified by CASS.
"^DD",2,2,.1159,"AUDIT")
y
"^DD",2,2,.1159,"DT")
3180213
"^DD",2,2,.1171,0)
PROVINCE^FaXJ20^^.11;8^K:$L(X)>20!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.1171,1,0)
^.1
"^DD",2,2,.1171,1,1,0)
^^TRIGGER^2^.118
"^DD",2,2,.1171,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.1171,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.1171,1,1,"%D",0)
^^2^2^3060117^
"^DD",2,2,.1171,1,1,"%D",1,0)
This cross-reference will be used to update the Date/Time stamp for an 
"^DD",2,2,.1171,1,1,"%D",2,0)
Address Change.
"^DD",2,2,.1171,1,1,"CREATE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.1171,1,1,"DELETE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.1171,1,1,"FIELD")
#.118
"^DD",2,2,.1171,3)
Answer must be 1-20 characters in length.
"^DD",2,2,.1171,21,0)
^^4^4^3060405^
"^DD",2,2,.1171,21,1,0)
Enter a Province if the patient has provided one for his/her foreign
"^DD",2,2,.1171,21,2,0)
address.  
"^DD",2,2,.1171,21,3,0)
 
"^DD",2,2,.1171,21,4,0)
The entry can be alphanumeric and up to 20 characters in length.
"^DD",2,2,.1171,"AUDIT")
y
"^DD",2,2,.1171,"DT")
3180227
"^DD",2,2,.1172,0)
POSTAL CODE^FaXJ10^^.11;9^K:$L(X)>10!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.1172,1,0)
^.1
"^DD",2,2,.1172,1,1,0)
^^TRIGGER^2^.118
"^DD",2,2,.1172,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.1172,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
"^DD",2,2,.1172,1,1,"%D",0)
^^2^2^3060117^
"^DD",2,2,.1172,1,1,"%D",1,0)
This cross-reference will be used to update the Date/Time stamp for an 
"^DD",2,2,.1172,1,1,"%D",2,0)
Address Change.
"^DD",2,2,.1172,1,1,"CREATE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.1172,1,1,"DELETE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.1172,1,1,"FIELD")
#.118
"^DD",2,2,.1172,3)
Answer must be 1-10 characters in length.
"^DD",2,2,.1172,21,0)
^^4^4^3060405^
"^DD",2,2,.1172,21,1,0)
Enter with patient's postal code if the patient has provided one for
"^DD",2,2,.1172,21,2,0)
his/her foreign address.
"^DD",2,2,.1172,21,3,0)
 
"^DD",2,2,.1172,21,4,0)
The entry can be alphanumeric and up to 10 characters in length.
"^DD",2,2,.1172,"AUDIT")
y
"^DD",2,2,.1172,"DT")
3180227
"^DD",2,2,.119,0)
ADDRESS CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;NCOA:NCOA;BVA:BVA;VAINS:VAINS;USPS:USPS;LACS:LACS;VOA:VOA;VET360:VET360;^.11;14^Q
"^DD",2,2,.119,1,0)
^.1
"^DD",2,2,.119,1,1,0)
^^TRIGGER^2^.12
"^DD",2,2,.119,1,1,1)
X ^DD(2,.119,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.119,1,1,1.4)
"^DD",2,2,.119,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.119,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="VAMC"
"^DD",2,2,.119,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,15)=DIV,DIH=2,DIG=.12 D ^DICR
"^DD",2,2,.119,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.119,0)),U,3) S X=$P($P(Y(1),$C(59)_X_":",2),$C(59))="VAMC" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" X ^DD(2,.119,1,1,2.4)
"^DD",2,2,.119,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,15)=DIV,DIH=2,DIG=.12 D ^DICR
"^DD",2,2,.119,1,1,"%D",0)
^.101^5^5^3170814^^
"^DD",2,2,.119,1,1,"%D",1,0)
This cross-reference will trigger the population of the 
"^DD",2,2,.119,1,1,"%D",2,0)
ADDRESS CHANGE SITE field with the appropriate station 
"^DD",2,2,.119,1,1,"%D",3,0)
number if the ADDRESS CHANGE SOURCE equals "VAMC".  The 
"^DD",2,2,.119,1,1,"%D",4,0)
ADDRESS CHANGE SITE field should be overwritten for cases 
"^DD",2,2,.119,1,1,"%D",5,0)
where the site would be incorrect (i.e. uploading Z05 message).
"^DD",2,2,.119,1,1,"CREATE CONDITION")
ADDRESS CHANGE SOURCE="VAMC"
"^DD",2,2,.119,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.119,1,1,"DELETE CONDITION")
OLD ADDRESS CHANGE SOURCE="VAMC"
"^DD",2,2,.119,1,1,"DELETE VALUE")
@
"^DD",2,2,.119,1,1,"DT")
3130514
"^DD",2,2,.119,1,1,"FIELD")
ADDRESS CHANGE SITE
"^DD",2,2,.119,3)
Please enter the source of the address change.
"^DD",2,2,.119,5,1,0)
2^.118^1
"^DD",2,2,.119,9)
^
"^DD",2,2,.119,21,0)
^.001^1^1^3170814^^^^
"^DD",2,2,.119,21,1,0)
This field will hold the source of the Last address change.
"^DD",2,2,.119,"DT")
3171208
"^DD",2,2,.1211,0)
TEMPORARY STREET [LINE 1]^FXJ30^^.121;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D TAD^DGLOCK
"^DD",2,2,.1211,.1)

"^DD",2,2,.1211,1,0)
^.1
"^DD",2,2,.1211,1,1,0)
2^AXR12^MUMPS
"^DD",2,2,.1211,1,1,1)
Q
"^DD",2,2,.1211,1,1,2)
S DGXRF=.1211 D ^DGDDC Q
"^DD",2,2,.1211,3)
Enter the first line of this applicants temporary address [2-30 characters].
"^DD",2,2,.1211,20,0)
^.3LA^1^1
"^DD",2,2,.1211,20,1,0)
TAD
"^DD",2,2,.1211,21,0)
^^5^5^2870728^^^^
"^DD",2,2,.1211,21,1,0)
If the WANT TO ENTER A TEMPORARY ADDRESS prompt is answered YES
"^DD",2,2,.1211,21,2,0)
enter the first line of the temporary street address for this
"^DD",2,2,.1211,21,3,0)
applicant [2-30 characters] otherwise nothing may be entered.  This
"^DD",2,2,.1211,21,4,0)
field cannot be deleted as long as the need for a temporary address
"^DD",2,2,.1211,21,5,0)
is indicated.
"^DD",2,2,.1211,"DEL",1,0)
S DFN=DA D TADD^DGLOCK1 I '$D(X)
"^DD",2,2,.1211,"DT")
3180227
"^DD",2,2,.12115,0)
TEMPORARY ADDR CASS IND^S^Y:CERTIFIED BY CASS;F:FAILED CASS CERTIFICATION;NC:NOT CHECKED AGAINST CASS;PV:PROCESSING;^.121;15^Q
"^DD",2,2,.12115,3)
Select the CASS status for the temporary address
"^DD",2,2,.12115,21,0)
^.001^2^2^3170501^^^^
"^DD",2,2,.12115,21,1,0)
The Temporary Addr CASS Indicator is used to determine whether the 
"^DD",2,2,.12115,21,2,0)
 temporary address has been certified by CASS.
"^DD",2,2,.12115,"DT")
3180213
"^DD",2,2,.1212,0)
TEMPORARY STREET [LINE 2]^FXJ30^^.121;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D TAD^DGLOCK
"^DD",2,2,.1212,.1)

"^DD",2,2,.1212,1,0)
^.1
"^DD",2,2,.1212,1,1,0)
2^AXR13^MUMPS
"^DD",2,2,.1212,1,1,1)
Q
"^DD",2,2,.1212,1,1,2)
S DGXRF=.1212 D ^DGDDC Q
"^DD",2,2,.1212,3)
Enter, if necessary, the second line of this applicants temporary address [2-30 characters].
"^DD",2,2,.1212,20,0)
^.3LA^1^1
"^DD",2,2,.1212,20,1,0)
TAD
"^DD",2,2,.1212,21,0)
^.001^5^5^3180411^^^^
"^DD",2,2,.1212,21,1,0)
If the WANT TO ENTER A TEMPORARY ADDRESS prompt is answered YES
"^DD",2,2,.1212,21,2,0)
enter the second line of the temporary street address [2-30
"^DD",2,2,.1212,21,3,0)
characters], if necessary, otherwise nothing may be entered.  This
"^DD",2,2,.1212,21,4,0)
field may not be deleted as long as the need for a temporary
"^DD",2,2,.1212,21,5,0)
address is indicated.
"^DD",2,2,.1212,"DT")
3180411
"^DD",2,2,.1213,0)
TEMPORARY STREET [LINE 3]^FXJ30^^.121;3^K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D TAD^DGLOCK
"^DD",2,2,.1213,.1)

"^DD",2,2,.1213,1,0)
^.1^^0
"^DD",2,2,.1213,3)
Enter, if necessary, the third line of this applicants temporary address [2-30 characters].
"^DD",2,2,.1213,20,0)
^.3LA^1^1
"^DD",2,2,.1213,20,1,0)
TAD
"^DD",2,2,.1213,21,0)
^^5^5^2861007^^
"^DD",2,2,.1213,21,1,0)
If the WANT TO ENTER A TEMPORARY ADDRESS prompt is answered YES
"^DD",2,2,.1213,21,2,0)
enter the third line of the temporary street address [2-30
"^DD",2,2,.1213,21,3,0)
characters], if necessary, otherwise nothing may be entered.
"^DD",2,2,.1213,21,4,0)
This field may not be deleted as long as the need for a temporary
"^DD",2,2,.1213,21,5,0)
address is indicated.
"^DD",2,2,.1213,"DT")
3180227
"^DD",2,2,.1214,0)
TEMPORARY CITY^FXJ30^^.121;4^K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D TAD^DGLOCK
"^DD",2,2,.1214,.1)

"^DD",2,2,.1214,1,0)
^.1^^0
"^DD",2,2,.1214,3)
Enter the city in which this applicant is temporarily residing [2-30 characters].
"^DD",2,2,.1214,20,0)
^.3LA^1^1
"^DD",2,2,.1214,20,1,0)
TAD
"^DD",2,2,.1214,21,0)
^^4^4^2861007^^^^
"^DD",2,2,.1214,21,1,0)
If the WANT TO ENTER A TEMPORARY ADDRESS prompt is answered YES
"^DD",2,2,.1214,21,2,0)
enter the city in which the temporary address lies [2-30 characters],
"^DD",2,2,.1214,21,3,0)
otherwise nothing may be entered.  This field may not be deleted as
"^DD",2,2,.1214,21,4,0)
long as the need for a temporary address is indicated.
"^DD",2,2,.1214,"DEL",1,0)
S DFN=DA D TADD^DGLOCK1 I '$D(X)
"^DD",2,2,.1214,"DT")
3180227
"^DD",2,2,.1221,0)
TEMPORARY ADDRESS PROVINCE^FXJ20^^.122;1^K:$L(X)>20!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.1221,1,0)
^.1^^0
"^DD",2,2,.1221,3)
Answer must be 1-20 characters in length.
"^DD",2,2,.1221,21,0)
^^4^4^3060405^
"^DD",2,2,.1221,21,1,0)
Enter a Province if the patient has provided one for his/her foreign
"^DD",2,2,.1221,21,2,0)
address.  
"^DD",2,2,.1221,21,3,0)
 
"^DD",2,2,.1221,21,4,0)
The entry can be alphanumeric and up to 20 characters in length.
"^DD",2,2,.1221,"DT")
3180227
"^DD",2,2,.1222,0)
TEMPORARY ADDRESS POSTAL CODE^FXJ10^^.122;2^K:$L(X)>10!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.1222,1,0)
^.1^^0
"^DD",2,2,.1222,3)
Answer must be 1-10 characters in length.
"^DD",2,2,.1222,21,0)
^^4^4^3060405^
"^DD",2,2,.1222,21,1,0)
Enter with patient's postal code if the patient has provided one for
"^DD",2,2,.1222,21,2,0)
his/her foreign address.
"^DD",2,2,.1222,21,3,0)
 
"^DD",2,2,.1222,21,4,0)
The entry can be alphanumeric and up to 10 characters in length.
"^DD",2,2,.1222,"DT")
3180227
"^DD",2,2,.1311,0)
CELLULAR NUMBER CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;VOA:VOA;VET360:VET360;^.13;10^Q
"^DD",2,2,.1311,1,0)
^.1
"^DD",2,2,.1311,1,1,0)
^^TRIGGER^2^.13111
"^DD",2,2,.1311,1,1,1)
X ^DD(2,.1311,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.1311,1,1,1.4)
"^DD",2,2,.1311,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.1311,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="VAMC"
"^DD",2,2,.1311,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,11)=DIV,DIH=2,DIG=.13111 D ^DICR
"^DD",2,2,.1311,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.1311,0)),U,3) S X=$P($P(Y(1),$C(59)_X_":",2),$C(59))="VAMC" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(2,.1311,1,1,2.4)
"^DD",2,2,.1311,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,11)=DIV,DIH=2,DIG=.13111 D ^DICR
"^DD",2,2,.1311,1,1,"%D",0)
^^5^5^3130522^
"^DD",2,2,.1311,1,1,"%D",1,0)
This cross-reference will trigger the population of the CELLULAR NUMBER 
"^DD",2,2,.1311,1,1,"%D",2,0)
CHANGE SITE field with the appropriate station number if the CELLULAR 
"^DD",2,2,.1311,1,1,"%D",3,0)
NUMBER CHANGE SOURCE equals "VAMC".  The CELLULAR NUMBER CHANGE SITE field
"^DD",2,2,.1311,1,1,"%D",4,0)
should be overwritten for cases where the site would be incorrect (i.e. 
"^DD",2,2,.1311,1,1,"%D",5,0)
uploading Z05 message).
"^DD",2,2,.1311,1,1,"CREATE CONDITION")
CELLULAR NUMBER CHANGE SOURCE="VAMC"
"^DD",2,2,.1311,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.1311,1,1,"DELETE CONDITION")
OLD CELLULAR NUMBER CHANGE SOU="VAMC"
"^DD",2,2,.1311,1,1,"DELETE VALUE")
@
"^DD",2,2,.1311,1,1,"DT")
3130522
"^DD",2,2,.1311,1,1,"FIELD")
CELLULAR NUMBER CHANGE SITE
"^DD",2,2,.1311,3)
Please enter the source of the Cellular number change.
"^DD",2,2,.1311,5,1,0)
2^.139^1
"^DD",2,2,.1311,21,0)
^^2^2^3060410^
"^DD",2,2,.1311,21,1,0)
This field will hold the source of the last Cellular number
"^DD",2,2,.1311,21,2,0)
change.
"^DD",2,2,.1311,"DT")
3171208
"^DD",2,2,.1322,0)
RESIDENCE NUMBER CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;VOA:VOA;VET360:VET360;^.132;2^Q
"^DD",2,2,.1322,1,0)
^.1
"^DD",2,2,.1322,1,1,0)
^^TRIGGER^2^.1323
"^DD",2,2,.1322,1,1,1)
X ^DD(2,.1322,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.132)):^(.132),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(2,.1322,1,1,1.1) S DIH=$G(^DPT(DIV(0),.132)),DIV=X S $P(^(.132),U,3)=DIV,DIH=2,DIG=.1323 D ^DICR
"^DD",2,2,.1322,1,1,1.1)
S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$$FIND1^DIC(4,"","QX",X,"D","","^TMP(""DGSTAERR"",$J)")
"^DD",2,2,.1322,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.1322,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="VAMC"
"^DD",2,2,.1322,1,1,2)
X ^DD(2,.1322,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.132)):^(.132),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(2,.1322,1,1,2.1) S DIH=$G(^DPT(DIV(0),.132)),DIV=X S $P(^(.132),U,3)=DIV,DIH=2,DIG=.1323 D ^DICR
"^DD",2,2,.1322,1,1,2.1)
S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$$FIND1^DIC(4,"","QX",X,"D","","^TMP(""DGSTAERR"",$J)")
"^DD",2,2,.1322,1,1,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(2,.1322,0)),U,3),Y(1)=$S($D(^DPT(D0,.132)):^(.132),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,2)_":",2),$C(59))="VAMC"
"^DD",2,2,.1322,1,1,"%D",0)
^^8^8^3120326^
"^DD",2,2,.1322,1,1,"%D",1,0)
This cross-reference will trigger the
"^DD",2,2,.1322,1,1,"%D",2,0)
population of the RESIDENCE NUMBER CHANGE SITE
"^DD",2,2,.1322,1,1,"%D",3,0)
field with the appropriate station number if
"^DD",2,2,.1322,1,1,"%D",4,0)
the RESIDENCE NUMBER CHANGE SOURCE equals
"^DD",2,2,.1322,1,1,"%D",5,0)
"VAMC".  The RESIDENCE NUMBER CHANGE SITE field
"^DD",2,2,.1322,1,1,"%D",6,0)
should be overwritten for the cases where the
"^DD",2,2,.1322,1,1,"%D",7,0)
site would be incorrect (i.e. uploading Z05
"^DD",2,2,.1322,1,1,"%D",8,0)
message).
"^DD",2,2,.1322,1,1,"CREATE CONDITION")
RESIDENCE NUMBER CHANGE SOURCE="VAMC"
"^DD",2,2,.1322,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$$FIND1^DIC(4,"","QX",X,"D","","^TMP(""DGSTAERR"",$J)")
"^DD",2,2,.1322,1,1,"DELETE CONDITION")
RESIDENCE NUMBER CHANGE SOURCE="VAMC"
"^DD",2,2,.1322,1,1,"DELETE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$$FIND1^DIC(4,"","QX",X,"D","","^TMP(""DGSTAERR"",$J)")
"^DD",2,2,.1322,1,1,"DT")
3120326
"^DD",2,2,.1322,1,1,"FIELD")
RESIDENCE NUMBER CHANGE SITE
"^DD",2,2,.1322,3)
Please enter the source of the Residence phone number change.
"^DD",2,2,.1322,5,1,0)
2^.1321^1
"^DD",2,2,.1322,9)
^
"^DD",2,2,.1322,21,0)
^.001^2^2^3120201^^
"^DD",2,2,.1322,21,1,0)
This field will hold the source of the last
"^DD",2,2,.1322,21,2,0)
Residence phone number change.
"^DD",2,2,.1322,"DT")
3171208
"^DD",2,2,.137,0)
EMAIL ADDRESS CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;VOA:VOA;VET360:VET360;^.13;7^Q
"^DD",2,2,.137,1,0)
^.1
"^DD",2,2,.137,1,1,0)
^^TRIGGER^2^.138
"^DD",2,2,.137,1,1,1)
X ^DD(2,.137,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,"")) X ^DD(2,.137,1,1,1.4)
"^DD",2,2,.137,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.137,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="VAMC"
"^DD",2,2,.137,1,1,1.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,8)=DIV,DIH=2,DIG=.138 D ^DICR
"^DD",2,2,.137,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.137,0)),U,3) S X=$P($P(Y(1),$C(59)_X_":",2),$C(59))="VAMC" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.13)):^(.13),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(2,.137,1,1,2.4)
"^DD",2,2,.137,1,1,2.4)
S DIH=$G(^DPT(DIV(0),.13)),DIV=X S $P(^(.13),U,8)=DIV,DIH=2,DIG=.138 D ^DICR
"^DD",2,2,.137,1,1,"%D",0)
^^5^5^3130522^
"^DD",2,2,.137,1,1,"%D",1,0)
This cross-reference will trigger the population of the EMAIL ADDRESS 
"^DD",2,2,.137,1,1,"%D",2,0)
CHANGE SITE field with the appropriate station number if the EMAIL ADDRESS 
"^DD",2,2,.137,1,1,"%D",3,0)
CHANGE SOURCE equals "VAMC". The EMAIL ADDRESS CHANGE SITE field should be 
"^DD",2,2,.137,1,1,"%D",4,0)
overwritten for cases where the site would be incorrect (i.e. uploading 
"^DD",2,2,.137,1,1,"%D",5,0)
Z05 message).
"^DD",2,2,.137,1,1,"CREATE CONDITION")
EMAIL ADDRESS CHANGE SOURCE="VAMC"
"^DD",2,2,.137,1,1,"CREATE VALUE")
S X=$$GETSITE^DGMTU4($G(DUZ)) I X S X=$O(^DIC(4,"D",X,""))
"^DD",2,2,.137,1,1,"DELETE CONDITION")
OLD EMAIL ADDRESS CHANGE SOURC="VAMC"
"^DD",2,2,.137,1,1,"DELETE VALUE")
@
"^DD",2,2,.137,1,1,"DT")
3130522
"^DD",2,2,.137,1,1,"FIELD")
EMAIL ADDRESS CHANGE SITE
"^DD",2,2,.137,3)
Please enter the source of the EMAIL address change.
"^DD",2,2,.137,5,1,0)
2^.136^1
"^DD",2,2,.137,21,0)
^.001^1^1^3171122^^^
"^DD",2,2,.137,21,1,0)
This field will hold the source of the last EMAIL address change.
"^DD",2,2,.137,"DT")
3171208
"^DD",2,2,.1411,0)
CONFIDENTIAL STREET [LINE 1]^FXJ30^^.141;1^K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D CAD^DGLOCK3
"^DD",2,2,.1411,1,0)
^.1^^-1
"^DD",2,2,.1411,1,1,0)
2^AXR32^MUMPS
"^DD",2,2,.1411,1,1,1)
Q
"^DD",2,2,.1411,1,1,2)
S DGXRF=.1411 D ^DGDDC Q
"^DD",2,2,.1411,1,1,"DT")
3030113
"^DD",2,2,.1411,3)
Enter the first line of the applicant's confidential street address [2-30 characters].
"^DD",2,2,.1411,21,0)
^.001^4^4^3170721^^
"^DD",2,2,.1411,21,1,0)
If the 'Confidential Address Active' prompt is answered YES, the
"^DD",2,2,.1411,21,2,0)
user will be prompted for the first line of the confidential street
"^DD",2,2,.1411,21,3,0)
address.  This field cannot be deleted as long as the need for a
"^DD",2,2,.1411,21,4,0)
confidential address is indicated.
"^DD",2,2,.1411,"DEL",1,0)
S DFN=DA D CADD1^DGLOCK3 I '$D(X)
"^DD",2,2,.1411,"DT")
3180227
"^DD",2,2,.14114,0)
CONFIDENTIAL ADDR PROVINCE^FXJ20^^.141;14^K:$L(X)>20!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.14114,1,0)
^.1^^0
"^DD",2,2,.14114,3)
Answer must be 1-20 characters in length.
"^DD",2,2,.14114,21,0)
^^4^4^3060405^
"^DD",2,2,.14114,21,1,0)
Enter a Province if the patient has provided one for his/her foreign
"^DD",2,2,.14114,21,2,0)
address.  
"^DD",2,2,.14114,21,3,0)
 
"^DD",2,2,.14114,21,4,0)
The entry can be alphanumeric and up to 20 characters in length.
"^DD",2,2,.14114,"DT")
3180227
"^DD",2,2,.14115,0)
CONFIDENTIAL ADDR POSTAL CODE^FXJ10^^.141;15^K:$L(X)>10!($L(X)<1) X D:$D(X) UP^DGHELP
"^DD",2,2,.14115,1,0)
^.1^^0
"^DD",2,2,.14115,3)
Answer must be 1-10 characters in length.
"^DD",2,2,.14115,21,0)
^^4^4^3060405^
"^DD",2,2,.14115,21,1,0)
Enter with patient's postal code if the patient has provided one for
"^DD",2,2,.14115,21,2,0)
his/her foreign address.
"^DD",2,2,.14115,21,3,0)
 
"^DD",2,2,.14115,21,4,0)
The entry can be alphanumeric and up to 10 characters in length.
"^DD",2,2,.14115,"DT")
3180227
"^DD",2,2,.14117,0)
CONFIDENTIAL ADDR CASS IND^S^Y:CERTIFIED BY CASS;F:FAILED CASS CERTIFICATION;NC:NOT CHECKED AGAINST CASS;PV:PROCESSING;^.141;17^Q
"^DD",2,2,.14117,3)
Select the CASS status for the confidential address
"^DD",2,2,.14117,21,0)
^.001^2^2^3170419^^^^
"^DD",2,2,.14117,21,1,0)
The Confidential Addr CASS Indicator is used to determine whether the 
"^DD",2,2,.14117,21,2,0)
 confidential address has been certified by CASS.
"^DD",2,2,.14117,"DT")
3180213
"^DD",2,2,.1412,0)
CONFIDENTIAL STREET [LINE 2]^FXJ30^^.141;2^K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D CAD^DGLOCK3
"^DD",2,2,.1412,1,0)
^.1^^-1
"^DD",2,2,.1412,1,1,0)
2^AXR33^MUMPS
"^DD",2,2,.1412,1,1,1)
Q
"^DD",2,2,.1412,1,1,2)
S DGXRF=.1412 D ^DGDDC Q
"^DD",2,2,.1412,1,1,"DT")
3030113
"^DD",2,2,.1412,3)
If necessary, enter the second line of this applicant's confidential address [2-30 characters].
"^DD",2,2,.1412,21,0)
^^4^4^3030311^
"^DD",2,2,.1412,21,1,0)
If the 'Confidential Address Active' prompt is answered YES,
"^DD",2,2,.1412,21,2,0)
the user will be prompted for the second line of the confidential 
"^DD",2,2,.1412,21,3,0)
street address [2-30 characters].  The second line of the street
"^DD",2,2,.1412,21,4,0)
address is optional and may be left blank.
"^DD",2,2,.1412,"DT")
3180227
"^DD",2,2,.1413,0)
CONFIDENTIAL STREET [LINE 3]^FXJ30^^.141;3^K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D CAD^DGLOCK3
"^DD",2,2,.1413,1,0)
^.1^^0
"^DD",2,2,.1413,3)
If necessary, enter the third line of this applicant's confidential street address [2-30 characters]
"^DD",2,2,.1413,21,0)
^^4^4^3030312^
"^DD",2,2,.1413,21,1,0)
If the 'Confidential Address Active' prompt is answered YES,
"^DD",2,2,.1413,21,2,0)
the user will be prompted for the third line of the confidential        
"^DD",2,2,.1413,21,3,0)
street address.  The third line of the street address is optional
"^DD",2,2,.1413,21,4,0)
and may be left blank.
"^DD",2,2,.1413,"DT")
3180227
"^DD",2,2,.1414,0)
CONFIDENTIAL ADDRESS CITY^FXJ30^^.141;4^K:$L(X)>30!($L(X)<2) X D:$D(X) UP^DGHELP I $D(X) S DFN=DA D CAD^DGLOCK3
"^DD",2,2,.1414,1,0)
^.1^^0
"^DD",2,2,.1414,3)
Enter the city for the applicant's confidential address [2-30 characters].
"^DD",2,2,.1414,21,0)
^^4^4^3030311^
"^DD",2,2,.1414,21,1,0)
If the 'Confidential Address Active' prompt is answered YES, enter
"^DD",2,2,.1414,21,2,0)
the confidential address city for this applicant [2-30 characters].  
"^DD",2,2,.1414,21,3,0)
This field may not be deleted as long as the need for a confidential
"^DD",2,2,.1414,21,4,0)
address is indicated.
"^DD",2,2,.1414,"DEL",1,0)
S DFN=DA D CADD1^DGLOCK3 I '$D(X)
"^DD",2,2,.1414,"DT")
3180227
**INSTALL NAME**
IVM*2.0*164
"BLD",10131,0)
IVM*2.0*164^INCOME VERIFICATION MATCH^0^3181105^y
"BLD",10131,1,0)
^^2^2^3180206^^
"BLD",10131,1,1,0)
Please see the IVM*2.0*164 patch description for detailed information
"BLD",10131,1,2,0)
regarding this patch.  
"BLD",10131,4,0)
^9.64PA^^
"BLD",10131,6.3)
98
"BLD",10131,"ABPKG")
n
"BLD",10131,"INID")
n^n^n
"BLD",10131,"INIT")
EP^IVM2164P
"BLD",10131,"KRN",0)
^9.67PA^779.2^20
"BLD",10131,"KRN",.4,0)
.4
"BLD",10131,"KRN",.401,0)
.401
"BLD",10131,"KRN",.402,0)
.402
"BLD",10131,"KRN",.403,0)
.403
"BLD",10131,"KRN",.5,0)
.5
"BLD",10131,"KRN",.84,0)
.84
"BLD",10131,"KRN",3.6,0)
3.6
"BLD",10131,"KRN",3.8,0)
3.8
"BLD",10131,"KRN",9.2,0)
9.2
"BLD",10131,"KRN",9.8,0)
9.8
"BLD",10131,"KRN",9.8,"NM",0)
^9.68A^9^7
"BLD",10131,"KRN",9.8,"NM",1,0)
IVMPTRNA^^0^B16853619
"BLD",10131,"KRN",9.8,"NM",2,0)
IVMPREC8^^0^B300675114
"BLD",10131,"KRN",9.8,"NM",3,0)
IVMPRECA^^0^B93390034
"BLD",10131,"KRN",9.8,"NM",5,0)
IVMPTRN8^^0^B103984771
"BLD",10131,"KRN",9.8,"NM",6,0)
IVMPREC6^^0^B190620030
"BLD",10131,"KRN",9.8,"NM",8,0)
IVMPTRN9^^0^B54344683
"BLD",10131,"KRN",9.8,"NM",9,0)
IVMLDEM6^^0^B100336132
"BLD",10131,"KRN",9.8,"NM","B","IVMLDEM6",9)

"BLD",10131,"KRN",9.8,"NM","B","IVMPREC6",6)

"BLD",10131,"KRN",9.8,"NM","B","IVMPREC8",2)

"BLD",10131,"KRN",9.8,"NM","B","IVMPRECA",3)

"BLD",10131,"KRN",9.8,"NM","B","IVMPTRN8",5)

"BLD",10131,"KRN",9.8,"NM","B","IVMPTRN9",8)

"BLD",10131,"KRN",9.8,"NM","B","IVMPTRNA",1)

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

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

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

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

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

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

"BLD",10131,"KRN","B",3.6,3.6)

"BLD",10131,"KRN","B",3.8,3.8)

"BLD",10131,"KRN","B",9.2,9.2)

"BLD",10131,"KRN","B",9.8,9.8)

"BLD",10131,"KRN","B",19,19)

"BLD",10131,"KRN","B",19.1,19.1)

"BLD",10131,"KRN","B",101,101)

"BLD",10131,"KRN","B",409.61,409.61)

"BLD",10131,"KRN","B",771,771)

"BLD",10131,"KRN","B",779.2,779.2)

"BLD",10131,"KRN","B",870,870)

"BLD",10131,"KRN","B",8989.51,8989.51)

"BLD",10131,"KRN","B",8989.52,8989.52)

"BLD",10131,"KRN","B",8994,8994)

"BLD",10131,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",10131,"QUES",0)
^9.62^^
"BLD",10131,"REQB",0)
^9.611^3^3
"BLD",10131,"REQB",1,0)
IVM*2.0*167^1
"BLD",10131,"REQB",2,0)
IVM*2.0*145^1
"BLD",10131,"REQB",3,0)
IVM*2.0*171^1
"BLD",10131,"REQB","B","IVM*2.0*145",2)

"BLD",10131,"REQB","B","IVM*2.0*167",1)

"BLD",10131,"REQB","B","IVM*2.0*171",3)

"INIT")
EP^IVM2164P
"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)
164^3181105^101100
"PKG",120,22,1,"PAH",1,1,0)
^^2^2^3181105
"PKG",120,22,1,"PAH",1,1,1,0)
Please see the IVM*2.0*164 patch description for detailed information
"PKG",120,22,1,"PAH",1,1,2,0)
regarding this patch.  
"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")
8
"RTN","IVM2164P")
0^^B55645928
"RTN","IVM2164P",1,0)
IVM2164P ;ALB/KUM - Patch IVM*2*164 Post-Install Routine ;01/23/18 8:36AM
"RTN","IVM2164P",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**164**;21-OCT-94;Build 98
"RTN","IVM2164P",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","IVM2164P",4,0)
 ;
"RTN","IVM2164P",5,0)
 ;This routine will add new entries to the IVM DEMOGRAPHIC UPLOAD
"RTN","IVM2164P",6,0)
 ;FIELDS file #301.92
"RTN","IVM2164P",7,0)
 Q
"RTN","IVM2164P",8,0)
 ;
"RTN","IVM2164P",9,0)
EP ;Entry point - Driver
"RTN","IVM2164P",10,0)
 N IVMABRT,IVMFIL,I,IVMELE,EXIST,IVMDATA,DATA,SUB,J,VALUE,FILEFLG,DIERR,IVMERR,IEN,NAME,ERR,IVMCT
"RTN","IVM2164P",11,0)
 ;
"RTN","IVM2164P",12,0)
 S (IVMABRT,FILEFLG)=0,IVMFIL=301.92,IVMCT=0
"RTN","IVM2164P",13,0)
 D MES^XPDUTL("Adding entries into the IVM DEMOGRAPHIC UPLOAD FIELDS (#301.92) file:")
"RTN","IVM2164P",14,0)
 F I=1:1 S IVMELE=$P($T(TEXT+I),";;",2) Q:IVMELE="QUIT"!(IVMABRT)  D
"RTN","IVM2164P",15,0)
 . S EXIST=0
"RTN","IVM2164P",16,0)
 . K IVMDATA S (DATA,SUB)="" F J=1:1:$L(IVMELE,";") S DATA=$P(IVMELE,";",J) D
"RTN","IVM2164P",17,0)
 . . S SUB=$P(DATA,"~",1),VALUE=$P(DATA,"~",2),IVMDATA(SUB)=VALUE
"RTN","IVM2164P",18,0)
 . . I SUB=.01 S EXIST=$$FIND1^DIC(IVMFIL,,,IVMDATA(.01))
"RTN","IVM2164P",19,0)
 . I EXIST D
"RTN","IVM2164P",20,0)
 . . S NAME=IVMDATA(.01)
"RTN","IVM2164P",21,0)
 . . S IEN=EXIST_","
"RTN","IVM2164P",22,0)
 . . S FDA(301.92,IEN,.01)="@"
"RTN","IVM2164P",23,0)
 . . D UPDATE^DIE("E","FDA","","ERR")
"RTN","IVM2164P",24,0)
 . . I $D(ERR("DIERR")) D BMES^XPDUTL("    Error in deleting field "_NAME) Q
"RTN","IVM2164P",25,0)
 . . D BMES^XPDUTL(NAME_" deleted to recreate with correct field values  ")
"RTN","IVM2164P",26,0)
 . . S EXIST=0
"RTN","IVM2164P",27,0)
 . . Q
"RTN","IVM2164P",28,0)
 . I 'EXIST D
"RTN","IVM2164P",29,0)
 . . S FILEFLG=$$ADD(IVMFIL,.IVMDATA)
"RTN","IVM2164P",30,0)
 . . I FILEFLG D MES^XPDUTL("Added - "_$G(IVMDATA(.01)))
"RTN","IVM2164P",31,0)
 . . I 'FILEFLG D
"RTN","IVM2164P",32,0)
 . . . S IVMABRT=1
"RTN","IVM2164P",33,0)
 . . . D BMES^XPDUTL("Install process could not add an entry in file for "_$G(IVMDATA(.01)))
"RTN","IVM2164P",34,0)
 . . . D BMES^XPDUTL("                        <<<< INSTALLATION ABORTED >>>>")
"RTN","IVM2164P",35,0)
 I 'IVMABRT D BMES^XPDUTL("<<<< Post Install Successful >>>>")
"RTN","IVM2164P",36,0)
 Q
"RTN","IVM2164P",37,0)
 ;
"RTN","IVM2164P",38,0)
ADD(IVMFIL,DATA) ;
"RTN","IVM2164P",39,0)
 ;Description: Creates a new record and files the data.
"RTN","IVM2164P",40,0)
 ; Input:
"RTN","IVM2164P",41,0)
 ;   IVMFIL - File or sub-file number
"RTN","IVM2164P",42,0)
 ;   DATA - Data array to file, pass by reference
"RTN","IVM2164P",43,0)
 ;          Format: DATA(<field #>)=<value>
"RTN","IVM2164P",44,0)
 ;
"RTN","IVM2164P",45,0)
 ; Output:
"RTN","IVM2164P",46,0)
 ;   Function Value - If no error then it returns the ien of the created record, else returns NULL.
"RTN","IVM2164P",47,0)
 ;
"RTN","IVM2164P",48,0)
 N FDA,FIELD,IEN,IENA,IENS,IVMDA,IVMERRS
"RTN","IVM2164P",49,0)
 ;
"RTN","IVM2164P",50,0)
 ;IENS - Internal Entry Number String defined by FM
"RTN","IVM2164P",51,0)
 ;IENA - the Internal Entry Number Array defined by FM
"RTN","IVM2164P",52,0)
 ;FDA - the FDA array defined by FM
"RTN","IVM2164P",53,0)
 ;IEN - the ien of the new record
"RTN","IVM2164P",54,0)
 ;
"RTN","IVM2164P",55,0)
 S IVMDA="+1"
"RTN","IVM2164P",56,0)
 S IENS=$$IENS^DILF(.IVMDA)
"RTN","IVM2164P",57,0)
 S FIELD=0
"RTN","IVM2164P",58,0)
 F  S FIELD=$O(DATA(FIELD)) Q:'FIELD  D
"RTN","IVM2164P",59,0)
 .S FDA(IVMFIL,IENS,FIELD)=$G(DATA(FIELD))
"RTN","IVM2164P",60,0)
 I $G(IEN) S IENA(1)=IEN
"RTN","IVM2164P",61,0)
 D UPDATE^DIE("","FDA","IENA","IVMERRS(1)")
"RTN","IVM2164P",62,0)
 I +$G(DIERR) D
"RTN","IVM2164P",63,0)
 .S IVMERR=$G(IVMERRS(1,"DIERR",1,"TEXT",1))
"RTN","IVM2164P",64,0)
 .S IEN=""
"RTN","IVM2164P",65,0)
 E  D
"RTN","IVM2164P",66,0)
 .S IEN=IENA(1)
"RTN","IVM2164P",67,0)
 .S IVMERR=""
"RTN","IVM2164P",68,0)
 D CLEAN^DILF
"RTN","IVM2164P",69,0)
 Q IEN
"RTN","IVM2164P",70,0)
 ;
"RTN","IVM2164P",71,0)
TEXT ;;FIELD#~VALUE;FIELD#~VALUE;FIELD#~VALUE.....
"RTN","IVM2164P",72,0)
 ;;.01~STREET ADDR CASS;.02~ZAV03;.03~1;.04~2;.05~.1118;.06~1;.07~1;.08~1;10~S DR=.1118 D LOOK^IVMPREC9;20~S DR=.1118 D LOOK^IVMPREC9
"RTN","IVM2164P",73,0)
 ;;.01~TEMPORARY ADDR CASS;.02~ZAV04;.03~1;.04~2;.05~.12115;.06~1;.07~1;.08~0;10~S DR=.12115 D LOOK^IVMPREC9;20~S DR=.12115 D LOOK^IVMPREC9
"RTN","IVM2164P",74,0)
 ;;.01~CONFIDENTIAL ADDR CASS;.02~ZAV02;.03~1;.04~2;.05~.14117;.06~1;.07~1;.08~0;10~S DR=.14117 D LOOK^IVMPREC9;20~S DR=.14117 D LOOK^IVMPREC9
"RTN","IVM2164P",75,0)
 ;;.01~RESIDENTIAL ADDR CASS;.02~ZAV01;.03~1;.04~2;.05~.1159;.06~1;.07~1;.08~0;10~S DR=.1159 D LOOK^IVMPREC9;20~S DR=.1159 D LOOK^IVMPREC9
"RTN","IVM2164P",76,0)
 ;;.01~CONFIDENTIAL ADDRESS CATEGORY;.02~PID117C;.03~1;.04~2;.05~.141;.06~0;.07~0;.08~0;10~S DA(1)=DFN,DA=IEN,DIC="^DPT(DA(1),.141,IEN," D ^DIC;20~S DA(1)=DFN,DA=IEN,DIC="^DPT(DA(1),.141,IEN," D ^DIC
"RTN","IVM2164P",77,0)
 ;;.01~CONFIDENTIAL STREET [LINE 1];.02~PID111C;.03~1;.04~2;.05~.1411;.06~1;.07~1;.08~0;10~S DR=.1411 D LOOK^IVMPREC9;20~S DR=.1411 D LOOK^IVMPREC9
"RTN","IVM2164P",78,0)
 ;;.01~CONFIDENTIAL STREET [LINE 2];.02~PID112C;.03~1;.04~2;.05~.1412;.06~1;.07~1;.08~0;10~S DR=.1412 D LOOK^IVMPREC9;20~S DR=.1412 D LOOK^IVMPREC9
"RTN","IVM2164P",79,0)
 ;;.01~CONFIDENTIAL STREET [LINE 3];.02~PID118C;.03~1;.04~2;.05~.1413;.06~1;.07~1;.08~0;10~S DR=.1413 D LOOK^IVMPREC9;20~S DR=.1413 D LOOK^IVMPREC9
"RTN","IVM2164P",80,0)
 ;;.01~CONFIDENTIAL ADDRESS CITY;.02~PID113C;.03~1;.04~2;.05~.1414;.06~1;.07~1;.08~0;10~S DR=.1414 D LOOK^IVMPREC9;20~S DR=.1414 D LOOK^IVMPREC9
"RTN","IVM2164P",81,0)
 ;;.01~CONFIDENTIAL ADDRESS STATE;.02~PID114C;.03~1;.04~2;.05~.1415;.06~1;.07~1;.08~0;10~S DR=.1415 D LOOK^IVMPREC9;20~S DR=.1415 D LOOK^IVMPREC9
"RTN","IVM2164P",82,0)
 ;;.01~CONFIDENTIAL ADDRESS ZIP CODE;.02~PID115C;.03~1;.04~2;.05~.1416;.06~1;.07~1;.08~0;10~S DR=.1416 D LOOK^IVMPREC9;20~S DR=.1416 D LOOK^IVMPREC9
"RTN","IVM2164P",83,0)
 ;;.01~CONFIDENTIAL ADDR COUNTRY;.02~PID116C;.03~1;.04~2;.05~.14116;.06~1;.07~1;.08~0;10~S DR=.14116 D LOOK^IVMPREC9;20~S DR=.14116 D LOOK^IVMPREC9
"RTN","IVM2164P",84,0)
 ;;.01~CONFIDENTIAL ADDR PROVINCE;.02~PID114CF;.03~1;.04~2;.05~.14114;.06~1;.07~1;.08~0;10~S DR=.14114 D LOOK^IVMPREC9;20~S DR=.14114 D LOOK^IVMPREC9
"RTN","IVM2164P",85,0)
 ;;.01~CONFIDENTIAL ADDR POSTAL CODE;.02~PID115CF;.03~1;.04~2;.05~.14115;.06~1;.07~1;.08~0;10~S DR=.14115 D LOOK^IVMPREC9;20~S DR=.14115 D LOOK^IVMPREC9
"RTN","IVM2164P",86,0)
 ;;.01~CONFIDENTIAL ADDRESS COUNTY;.02~PID119C;.03~1;.04~2;.05~.14111;.06~1;.07~1;.08~0;10~S DR=.14111 D LOOK^IVMPREC9;20~S DR=.14111 D LOOK^IVMPREC9
"RTN","IVM2164P",87,0)
 ;;.01~CONFIDENTIAL PHONE NUMBER;.02~PID13CA;.03~1;.04~2;.05~.1315;.06~1;.07~1;.08~0;10~S DR=.1315 D LOOK^IVMPREC9;20~S DR=.1315 D LOOK^IVMPREC9
"RTN","IVM2164P",88,0)
 ;;.01~CONFIDENTIAL START DATE;.02~PID1112C;.03~1;.04~2;.05~.1417;.06~1;.07~1;.08~0;10~S DR=.1417 D LOOK^IVMPREC9;20~S DR=.1417 D LOOK^IVMPREC9
"RTN","IVM2164P",89,0)
 ;;.01~CONFIDENTIAL END DATE;.02~PID1113C;.03~1;.04~2;.05~.1418;.06~1;.07~1;.08~0;10~S DR=.1418 D LOOK^IVMPREC9;20~S DR=.1418 D LOOK^IVMPREC9
"RTN","IVM2164P",90,0)
 ;;.01~CONFIDENTIAL ADDR CHANGE DT/TM;.02~RF171CA;.03~1;.04~2;.05~.14112;.06~1;.07~1;.08~0;10~S DR=.14112 D LOOK^IVMPREC9;20~S DR=.14112 D LOOK^IVMPREC9
"RTN","IVM2164P",91,0)
 ;;.01~CONFIDENTIAL ADDR CHANGE SITE;.02~RF161CA;.03~1;.04~2;.05~.14113;.06~1;.07~1;.08~0;10~S DR=.14113 D LOOK^IVMPREC9;20~S DR=.14113 D LOOK^IVMPREC9
"RTN","IVM2164P",92,0)
 ;;.01~RESIDENTIAL ADDRESS [LINE 1];.02~PID111R;.03~1;.04~2;.05~.1151;.08~0;10~S DR=.1151 D LOOK^IVMPREC9;20~S DR=.1151 D LOOK^IVMPREC9
"RTN","IVM2164P",93,0)
 ;;.01~RESIDENTIAL ADDRESS [LINE 2];.02~PID112R;.03~1;.04~2;.05~.1152;.08~0;10~S DR=.1152 D LOOK^IVMPREC9;20~S DR=.1152 D LOOK^IVMPREC9
"RTN","IVM2164P",94,0)
 ;;.01~RESIDENTIAL ADDRESS [LINE 3];.02~PID118R;.03~1;.04~2;.05~.1153;.08~0;10~S DR=.1153 D LOOK^IVMPREC9;20~S DR=.1153 D LOOK^IVMPREC9
"RTN","IVM2164P",95,0)
 ;;.01~RESIDENTIAL CITY;.02~PID113R;.03~1;.04~2;.05~.1154;.08~0;10~S DR=.1154 D LOOK^IVMPREC9;20~S DR=.1154 D LOOK^IVMPREC9
"RTN","IVM2164P",96,0)
 ;;.01~RESIDENTIAL STATE;.02~PID114R;.03~1;.04~2;.05~.1155;.06~1;.08~0;10~S DR=.1155 D LOOK^IVMPREC9;20~S DR=.1155 D LOOK^IVMPREC9
"RTN","IVM2164P",97,0)
 ;;.01~RESIDENTIAL ZIP+4;.02~PID115R;.03~1;.04~2;.05~.1156;.06~1;.08~0;10~S DR=.1156 D LOOK^IVMPREC9;20~S DR=.1156 D LOOK^IVMPREC9
"RTN","IVM2164P",98,0)
 ;;.01~RESIDENTIAL COUNTRY;.02~PID116R;.03~1;.04~2;.05~.11573;.08~0;10~S DR=.11573 D LOOK^IVMPREC9;20~S DR=.11573 D LOOK^IVMPREC9
"RTN","IVM2164P",99,0)
 ;;.01~RESIDENTIAL PROVINCE;.02~PID114RF;.03~1;.04~2;.05~.11571;.08~0;10~S DR=.11571 D LOOK^IVMPREC9;20~S DR=.11571 D LOOK^IVMPREC9
"RTN","IVM2164P",100,0)
 ;;.01~RESIDENTIAL POSTAL CODE;.02~PID115RF;.03~1;.04~2;.05~.11572;.08~0;10~S DR=.11572 D LOOK^IVMPREC9;20~S DR=.11572 D LOOK^IVMPREC9
"RTN","IVM2164P",101,0)
 ;;.01~RESIDENTIAL COUNTY;.02~PID119R;.03~1;.04~2;.05~.1157;.08~0;10~S DR=.1157 D LOOK^IVMPREC9;20~S DR=.1157 D LOOK^IVMPREC9
"RTN","IVM2164P",102,0)
 ;;.01~RESIDENTIAL ADDR CHANGE DT/TM;.02~RF171RA;.03~1;.04~2;.05~.1158;.06~1;.07~1;.08~0;10~S DR=.1158 D LOOK^IVMPREC9;20~S DR=.1158 D LOOK^IVMPREC9
"RTN","IVM2164P",103,0)
 ;;.01~RESIDENTIAL ADDR CHANGE SITE;.02~RF161RA;.03~1;.04~2;.05~.11581;.06~1;.07~1;.08~0;10~S DR=.11581 D LOOK^IVMPREC9;20~S DR=.11581 D LOOK^IVMPREC9
"RTN","IVM2164P",104,0)
 ;;.01~RESIDENTIAL ADDR CHANGE SOURCE;.02~RF162RA;.03~1;.04~2;.05~.11582;.06~1;.07~1;.08~0;10~S DR=.11582 D LOOK^IVMPREC9;20~S DR=.11582 D LOOK^IVMPREC9
"RTN","IVM2164P",105,0)
 ;;QUIT
"RTN","IVMLDEM6")
0^9^B100336132
"RTN","IVMLDEM6",1,0)
IVMLDEM6 ;ALB/KCL,BRM,PHH,CKN,LBD,KUM - IVM DEMOGRAPHIC UPLOAD FILE ADDRESS ;6/27/18 8:24pm
"RTN","IVMLDEM6",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**10,58,73,79,108,106,105,124,115,152,164**;21-OCT-94;Build 98
"RTN","IVMLDEM6",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMLDEM6",4,0)
 ;
"RTN","IVMLDEM6",5,0)
 ;
"RTN","IVMLDEM6",6,0)
ADDR(DFN,IVMDA2,IVMDA1,IVMDA,IVMPPICK) ; - function to check if uploadable field
"RTN","IVMLDEM6",7,0)
 ;                          is an address field and return a flag
"RTN","IVMLDEM6",8,0)
 ;
"RTN","IVMLDEM6",9,0)
 ;  Input:      DFN  -  as patient IEN
"RTN","IVMLDEM6",10,0)
 ;           IVMDA2  -  pointer to case record in (#301.5) file
"RTN","IVMLDEM6",11,0)
 ;           IVMDA1  -  pointer to PID msg in (#301.501) sub-file
"RTN","IVMLDEM6",12,0)
 ;            IVMDA  -  pointer to record in (#301.511) sub-file
"RTN","IVMLDEM6",13,0)
 ;         IVMPPICK  -  residence phone number and/or another address
"RTN","IVMLDEM6",14,0)
 ;                        field selected
"RTN","IVMLDEM6",15,0)
 ;                      0 - phone or an address field not selected 
"RTN","IVMLDEM6",16,0)
 ;                      1 - address field(s) selected
"RTN","IVMLDEM6",17,0)
 ;                      2 - phone selected
"RTN","IVMLDEM6",18,0)
 ;                      3 - both address field(s) and phone selected
"RTN","IVMLDEM6",19,0)
 ;
"RTN","IVMLDEM6",20,0)
 ; Output: IVMFLAG   -  1 if address field
"RTN","IVMLDEM6",21,0)
 ;                      0 if not an address field
"RTN","IVMLDEM6",22,0)
 ;
"RTN","IVMLDEM6",23,0)
 ;
"RTN","IVMLDEM6",24,0)
 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,IVMAFLD,IVMAVAL,IVMFNAM
"RTN","IVMLDEM6",25,0)
 ;
"RTN","IVMLDEM6",26,0)
 ; - initialize flags
"RTN","IVMLDEM6",27,0)
 S IVMFLAG=0
"RTN","IVMLDEM6",28,0)
 ;
"RTN","IVMLDEM6",29,0)
 ; - check for required parameters
"RTN","IVMLDEM6",30,0)
 I '$G(DFN)!('$G(IVMDA))!('$G(IVMDA1))!'($G(IVMDA2)) G ADDRQ
"RTN","IVMLDEM6",31,0)
 ;
"RTN","IVMLDEM6",32,0)
 ; - get pointer to (#301.92) file from (#301.511) sub-file
"RTN","IVMLDEM6",33,0)
 S IVMPTR=+$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)) G ADDRQ:'IVMPTR
"RTN","IVMLDEM6",34,0)
 ;
"RTN","IVMLDEM6",35,0)
ASK I '$D(^IVM(301.92,"AD",+IVMPTR)) G ADDRQ
"RTN","IVMLDEM6",36,0)
 I IVMPPICK=2 G ASK1
"RTN","IVMLDEM6",37,0)
 W ! S DIR("A")="Do you wish to proceed with this action"
"RTN","IVMLDEM6",38,0)
 S DIR("A",1)="You have selected to update an address field."
"RTN","IVMLDEM6",39,0)
 S DIR("A",2)="You will be required to upload the entire address."
"RTN","IVMLDEM6",40,0)
 S DIR("?")="Enter 'YES' to continue or 'NO' to abort."
"RTN","IVMLDEM6",41,0)
 S DIR(0)="Y",DIR("B")="NO"
"RTN","IVMLDEM6",42,0)
 D ^DIR K DIR
"RTN","IVMLDEM6",43,0)
 S IVMFLAG=1
"RTN","IVMLDEM6",44,0)
 I 'Y,IVMPPICK=1 G ADDRQ    ;only address selected so quit
"RTN","IVMLDEM6",45,0)
 I 'Y S IVMPPICK=2 G ASK1   ;check if phone should be updated
"RTN","IVMLDEM6",46,0)
 W ! S DIR("A")="Are you sure that you want to update the complete address"
"RTN","IVMLDEM6",47,0)
 S:$$PHARM(+$G(DFN)) DIR("A",1)="*** WARNING: This patient has ACTIVE PRESCRIPTIONS on file."
"RTN","IVMLDEM6",48,0)
 S DIR("A",2)=""
"RTN","IVMLDEM6",49,0)
 I $$ADRDTCK^IVMLDEM9(+$G(DFN),IVMDA2,IVMDA1) S DIR("A",2)="*** WARNING: The address that you are attempting to file is OLDER than",DIR("A",3)="             the address on file.",DIR("A",4)=""
"RTN","IVMLDEM6",50,0)
 S DIR("?",1)="Enter 'YES' to update the complete address that was received from"
"RTN","IVMLDEM6",51,0)
 S DIR("?")="HEC.  Enter 'NO' to quit."
"RTN","IVMLDEM6",52,0)
 S DIR(0)="Y",DIR("B")="NO"
"RTN","IVMLDEM6",53,0)
 D ^DIR K DIR
"RTN","IVMLDEM6",54,0)
 S IVMFLAG=1
"RTN","IVMLDEM6",55,0)
 I 'Y,IVMPPICK=1 G ADDRQ     ;only address selected so quit
"RTN","IVMLDEM6",56,0)
 I 'Y S IVMPPICK=2 G ASK1    ;check if phone should be updated
"RTN","IVMLDEM6",57,0)
 ;
"RTN","IVMLDEM6",58,0)
 ; determine correct address change date/time to use
"RTN","IVMLDEM6",59,0)
 D ADDRDT(DFN,IVMDA2,IVMDA1)
"RTN","IVMLDEM6",60,0)
 ;
"RTN","IVMLDEM6",61,0)
 I IVMPPICK=3 G ASK1   ;phone number also selected
"RTN","IVMLDEM6",62,0)
 ;
"RTN","IVMLDEM6",63,0)
 G LOOP  ;only address selected, proceed to filing
"RTN","IVMLDEM6",64,0)
 ;
"RTN","IVMLDEM6",65,0)
ASK1 ; - phone selected to be uploaded
"RTN","IVMLDEM6",66,0)
 W !! S DIR("A")="OK to update"
"RTN","IVMLDEM6",67,0)
 S DIR("A",1)="You have selected to update the PHONE NUMBER [RESIDENCE] field."
"RTN","IVMLDEM6",68,0)
 I $$PHNDTCK^IVMLDEM9(+$G(DFN),IVMDA2,IVMDA1) D
"RTN","IVMLDEM6",69,0)
 .S DIR("A",2)="*** WARNING: The phone number that you are attempting to file is OLDER than"
"RTN","IVMLDEM6",70,0)
 .S DIR("A",3)="             the phone number on file."
"RTN","IVMLDEM6",71,0)
 .S DIR("A",4)=""
"RTN","IVMLDEM6",72,0)
 S DIR("?",1)="Enter 'YES' to update the patient's Phone Number [Residence] that was"
"RTN","IVMLDEM6",73,0)
 S DIR("?",2)="received from HEC.  Enter 'NO' to quit."
"RTN","IVMLDEM6",74,0)
 S DIR(0)="Y",DIR("B")="YES"
"RTN","IVMLDEM6",75,0)
 D ^DIR K DIR
"RTN","IVMLDEM6",76,0)
 S IVMFLAG=1
"RTN","IVMLDEM6",77,0)
 I 'Y,IVMPPICK=2 G ADDRQ   ;no phone or address updates, just quit
"RTN","IVMLDEM6",78,0)
 I 'Y S IVMPPICK=1 G LOOP  ;address still needs to be filed
"RTN","IVMLDEM6",79,0)
 ;
"RTN","IVMLDEM6",80,0)
 ; determine correct phone # change date/time to use
"RTN","IVMLDEM6",81,0)
 D PHONDT(DFN,IVMDA2,IVMDA1)
"RTN","IVMLDEM6",82,0)
 ;
"RTN","IVMLDEM6",83,0)
 W !,"Filing PHONE NUMBER [RESIDENCE] field... "
"RTN","IVMLDEM6",84,0)
 ;
"RTN","IVMLDEM6",85,0)
LOOP ;
"RTN","IVMLDEM6",86,0)
 N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
"RTN","IVMLDEM6",87,0)
 ;
"RTN","IVMLDEM6",88,0)
 I IVMPPICK'=2 D
"RTN","IVMLDEM6",89,0)
 .W !,"Filing address fields... "
"RTN","IVMLDEM6",90,0)
 .D EN^DGCLEAR(DFN,"PERM") ;Deleting existing address before updating
"RTN","IVMLDEM6",91,0)
 ; - loop thru fields in ^IVM(301.92,"AD" x-ref
"RTN","IVMLDEM6",92,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']""  D
"RTN","IVMLDEM6",93,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMLDEM6",94,0)
 ..;
"RTN","IVMLDEM6",95,0)
 ..; - check for data node in (#301.511) sub-file
"RTN","IVMLDEM6",96,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:IVMNODE']""
"RTN","IVMLDEM6",97,0)
 ..Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
"RTN","IVMLDEM6",98,0)
 ..;
"RTN","IVMLDEM6",99,0)
 ..S IVMFNAM=$P($G(^IVM(301.92,+IVMNODE,0)),U) Q:IVMFNAM=""
"RTN","IVMLDEM6",100,0)
 ..; - check if residence phone number and not selected to upload
"RTN","IVMLDEM6",101,0)
 ..I IVMPPICK=1&(IVMFNAM="PHONE NUMBER [RESIDENCE]"!(IVMFNAM["RESIDENCE NUMBER CHANGE")) Q
"RTN","IVMLDEM6",102,0)
 ..; - check if not residence phone number and only phone selected to upload
"RTN","IVMLDEM6",103,0)
 ..I IVMPPICK=2&(IVMFNAM'="PHONE NUMBER [RESIDENCE]"&(IVMFNAM'["RESIDENCE NUMBER CHANGE")) Q
"RTN","IVMLDEM6",104,0)
 ..;
"RTN","IVMLDEM6",105,0)
 ..;Store Address change Date/time, source and site in ^TMP to file at the end of process.
"RTN","IVMLDEM6",106,0)
 ..S IVMAFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMAVAL=$P(IVMNODE,"^",2)
"RTN","IVMLDEM6",107,0)
 ..I ((IVMAFLD=.118)!(IVMAFLD=.119)!(IVMAFLD=.12)) S ^TMP($J,"CHANGE UPDATE",IVMAFLD)=IVMAVAL
"RTN","IVMLDEM6",108,0)
 ..;Store Residence Number change Date/time, source and site in ^TMP to file at the end of process.
"RTN","IVMLDEM6",109,0)
 ..I ((IVMAFLD=.1321)!(IVMAFLD=.1322)!(IVMAFLD=.1323)) S ^TMP($J,"CHANGE UPDATE",IVMAFLD)=IVMAVAL
"RTN","IVMLDEM6",110,0)
 ..; - perform any necessary address field manipulation and
"RTN","IVMLDEM6",111,0)
 ..;   load addr field rec'd from IVM into DHCP (#2) file
"RTN","IVMLDEM6",112,0)
 ..D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1
"RTN","IVMLDEM6",113,0)
 ..;
"RTN","IVMLDEM6",114,0)
 ..; - remove entry from (#301.511) sub-file
"RTN","IVMLDEM6",115,0)
 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMLDEM6",116,0)
 ;
"RTN","IVMLDEM6",117,0)
 D ADDRCHNG^IVMPREC6(DFN) ;Update Address change date/time,source,site if necessary
"RTN","IVMLDEM6",118,0)
 I IVMFLAG W "completed.",! D
"RTN","IVMLDEM6",119,0)
 .N DGCURR
"RTN","IVMLDEM6",120,0)
 .D GETUPDTS^DGADDUTL(DFN,.DGCURR)
"RTN","IVMLDEM6",121,0)
 .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR)
"RTN","IVMLDEM6",122,0)
 ;
"RTN","IVMLDEM6",123,0)
 ; - if addr is uploaded and phone # is not - ask user delete phone
"RTN","IVMLDEM6",124,0)
 ;I IVMFLAG,$P($G(^DPT(+DFN,.13)),"^")]"",(2>IVMPPICK) D PHONE
"RTN","IVMLDEM6",125,0)
 S VALMBCK="R"
"RTN","IVMLDEM6",126,0)
 ;
"RTN","IVMLDEM6",127,0)
 ;
"RTN","IVMLDEM6",128,0)
ADDRQ ; - return  -->  1 if uploadable field is an address field
"RTN","IVMLDEM6",129,0)
 ;           -->  0 if uploadable field is not an address field
"RTN","IVMLDEM6",130,0)
 ;
"RTN","IVMLDEM6",131,0)
 I IVMFLAG D RESET^IVMLDEMU
"RTN","IVMLDEM6",132,0)
 Q IVMFLAG
"RTN","IVMLDEM6",133,0)
 ;
"RTN","IVMLDEM6",134,0)
 ;
"RTN","IVMLDEM6",135,0)
UPLOAD(DFN,IVMFIELD,IVMVALUE) ; - file address fields received from IVM
"RTN","IVMLDEM6",136,0)
 ;
"RTN","IVMLDEM6",137,0)
 ;  Input:       DFN  -  as patient IEN
"RTN","IVMLDEM6",138,0)
 ;          IVMFIELD  -  as the field number to be updated
"RTN","IVMLDEM6",139,0)
 ;          IVMVALUE  -  as the value of the field
"RTN","IVMLDEM6",140,0)
 ;
"RTN","IVMLDEM6",141,0)
 ; Output: None
"RTN","IVMLDEM6",142,0)
 ;
"RTN","IVMLDEM6",143,0)
 ;
"RTN","IVMLDEM6",144,0)
 ; - update specified address field in the Patient (#2) file
"RTN","IVMLDEM6",145,0)
 N DIE,DA,DR,IENS,FDA
"RTN","IVMLDEM6",146,0)
 ; KUM - IVM*2.0*164 
"RTN","IVMLDEM6",147,0)
 ; To bypass DELETE TEST node test in DD for TEMP ADDRESS LINE2 AND TEMP ADDRESS LINE3
"RTN","IVMLDEM6",148,0)
 ; In Some production accounts, DELETE TEST node is set for .1212 and .1213
"RTN","IVMLDEM6",149,0)
 I ((IVMFIELD=.1212)!(IVMFIELD=.1213)),(IVMVALUE="@") D  Q
"RTN","IVMLDEM6",150,0)
 .S IENS=DFN_","
"RTN","IVMLDEM6",151,0)
 .S FDA(2,IENS,IVMFIELD)="@"
"RTN","IVMLDEM6",152,0)
 .D FILE^DIE("","FDA")
"RTN","IVMLDEM6",153,0)
 ; IVM*2.0*164 - Allow updating null values in Confidential start and end dates
"RTN","IVMLDEM6",154,0)
 I ((IVMFIELD=.1417)!(IVMFIELD=.1418)) D
"RTN","IVMLDEM6",155,0)
 .S IENS=DFN_","
"RTN","IVMLDEM6",156,0)
 .S FDA(2,IENS,IVMCAFG)="Y"
"RTN","IVMLDEM6",157,0)
 .D FILE^DIE("","FDA")
"RTN","IVMLDEM6",158,0)
 I ((IVMFIELD=.1417)!(IVMFIELD=.1418)),(IVMVALUE="@") D  Q
"RTN","IVMLDEM6",159,0)
 .S IENS=DFN_","
"RTN","IVMLDEM6",160,0)
 .S FDA(2,IENS,IVMFIELD)="@"
"RTN","IVMLDEM6",161,0)
 .D FILE^DIE("","FDA")
"RTN","IVMLDEM6",162,0)
 I IVMFIELD=.14112 D  Q
"RTN","IVMLDEM6",163,0)
 .S IENS=DFN_","
"RTN","IVMLDEM6",164,0)
 .S FDA(2,IENS,IVMCAFG)=IVMCAVL
"RTN","IVMLDEM6",165,0)
 .D FILE^DIE("","FDA")
"RTN","IVMLDEM6",166,0)
 .S IENS=DFN_","
"RTN","IVMLDEM6",167,0)
 .S FDA(2,IENS,IVMFIELD)=IVMVALUE
"RTN","IVMLDEM6",168,0)
 .D FILE^DIE("","FDA")
"RTN","IVMLDEM6",169,0)
 S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
"RTN","IVMLDEM6",170,0)
 D ^DIE K DA,DIE,DR
"RTN","IVMLDEM6",171,0)
 ;
"RTN","IVMLDEM6",172,0)
 ; - delete inaccurate Addr Change Site data if Source is not VAMC
"RTN","IVMLDEM6",173,0)
 ;   (trigger x-ref does not fire with 4 slash stuff)
"RTN","IVMLDEM6",174,0)
 I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMLDEM6",175,0)
 ; KUM - IVM*2.0*164 
"RTN","IVMLDEM6",176,0)
 ; If Source is not VAMC, delete the Site
"RTN","IVMLDEM6",177,0)
 I IVMFIELD=.11582,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.11581)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMLDEM6",178,0)
 Q
"RTN","IVMLDEM6",179,0)
 ;
"RTN","IVMLDEM6",180,0)
 ;
"RTN","IVMLDEM6",181,0)
PHONE ; - ask user to delete phone # [Residence] from Patient (#2) file
"RTN","IVMLDEM6",182,0)
 D PHONE^IVMPREC9 ;Moved this tag to IVMPREC9 due to routine size limit.
"RTN","IVMLDEM6",183,0)
 Q
"RTN","IVMLDEM6",184,0)
 ;
"RTN","IVMLDEM6",185,0)
AUTOADDR(DFN,IVMPPICK,NOUPDT,NOPHUP) ;
"RTN","IVMLDEM6",186,0)
 ; this functionality is copied from above and modified to allow
"RTN","IVMLDEM6",187,0)
 ; an automated upload of patient address information as stipulated
"RTN","IVMLDEM6",188,0)
 ; in the business requirements for Address Indexing to support GMT
"RTN","IVMLDEM6",189,0)
 ;
"RTN","IVMLDEM6",190,0)
 ;  Input:      DFN  -  as patient IEN
"RTN","IVMLDEM6",191,0)
 ;         IVMPPICK  -  residence phone number and/or another address
"RTN","IVMLDEM6",192,0)
 ;                        field selected
"RTN","IVMLDEM6",193,0)
 ;                      1 - address field(s) selected
"RTN","IVMLDEM6",194,0)
 ;                      3 - both address field(s) and phone selected
"RTN","IVMLDEM6",195,0)
 ;           NOUPDT  -  (optional) this flag is set when the incoming
"RTN","IVMLDEM6",196,0)
 ;                      address data is older than the existing
"RTN","IVMLDEM6",197,0)
 ;                      address in the Patient (#2) file
"RTN","IVMLDEM6",198,0)
 ;           NOPHUP  -  (optional) this flag is set when the incoming
"RTN","IVMLDEM6",199,0)
 ;                      home phone number is older than the existing
"RTN","IVMLDEM6",200,0)
 ;                      home phone number in the Patient (#2) file
"RTN","IVMLDEM6",201,0)
 ; Output: IVMFLAG   -  1 if address fields updated
"RTN","IVMLDEM6",202,0)
 ;                      0 if address fields not updated
"RTN","IVMLDEM6",203,0)
 ;
"RTN","IVMLDEM6",204,0)
 ;
"RTN","IVMLDEM6",205,0)
 ;
"RTN","IVMLDEM6",206,0)
 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,IVMAFLD,IVMAVAL,DELFLG
"RTN","IVMLDEM6",207,0)
 ;
"RTN","IVMLDEM6",208,0)
 ; - initialize flags
"RTN","IVMLDEM6",209,0)
 S IVMFLAG=0,DELFLG=1
"RTN","IVMLDEM6",210,0)
 S:'$G(NOUPDT) NOUPDT=0
"RTN","IVMLDEM6",211,0)
 S:'$G(NOPHUP) NOPHUP=0   ;Added for IVM*2*152
"RTN","IVMLDEM6",212,0)
 ;
"RTN","IVMLDEM6",213,0)
 ; - check for required parameters
"RTN","IVMLDEM6",214,0)
 Q:'$G(DFN) IVMFLAG
"RTN","IVMLDEM6",215,0)
 ;
"RTN","IVMLDEM6",216,0)
 N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
"RTN","IVMLDEM6",217,0)
 ; Set the flag to don't auto-update if there is an active Prescription record and the Bad Address Indicator is null
"RTN","IVMLDEM6",218,0)
 I ('NOUPDT),$$PHARM(+DFN),'$$BADADR^DGUTL3(+DFN) S DELFLG=0
"RTN","IVMLDEM6",219,0)
 I 'NOUPDT,DELFLG D EN^DGCLEAR(DFN,"PERM") ;Deleting existing address before updating
"RTN","IVMLDEM6",220,0)
 ;
"RTN","IVMLDEM6",221,0)
 S IVMDA2=$G(IVM3015)
"RTN","IVMLDEM6",222,0)
 Q:'$G(IVMDA2) IVMFLAG
"RTN","IVMLDEM6",223,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMLDEM6",224,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
"RTN","IVMLDEM6",225,0)
 Q:'IVMDA1 IVMFLAG
"RTN","IVMLDEM6",226,0)
 ;
"RTN","IVMLDEM6",227,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']""  D
"RTN","IVMLDEM6",228,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMLDEM6",229,0)
 ..;
"RTN","IVMLDEM6",230,0)
 ..; - check for data node in (#301.511) sub-file
"RTN","IVMLDEM6",231,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMLDEM6",232,0)
 ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
"RTN","IVMLDEM6",233,0)
 ..;
"RTN","IVMLDEM6",234,0)
 ..; - check if residence phone number -> do not auto-upload
"RTN","IVMLDEM6",235,0)
 ..;   If NOPHUP=1 delete entry from #301.511 sub-file, otherwise quit
"RTN","IVMLDEM6",236,0)
 ..;   (IVM*2*152)
"RTN","IVMLDEM6",237,0)
 ..I $P($G(^IVM(301.92,+IVMNODE,0)),U)="PHONE NUMBER [RESIDENCE]"!($P($G(^IVM(301.92,+IVMNODE,0)),U)["RESIDENCE NUMBER CHANGE") D  Q
"RTN","IVMLDEM6",238,0)
 ...I NOPHUP D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMLDEM6",239,0)
 ..;
"RTN","IVMLDEM6",240,0)
 ..; don't auto-update if there is an active Prescription record and
"RTN","IVMLDEM6",241,0)
 ..; the Bad Address Indicator is null
"RTN","IVMLDEM6",242,0)
 ..I 'DELFLG D DEMBULL^IVMPREC6 Q
"RTN","IVMLDEM6",243,0)
 ..;Store Address change Date/time, source and site in ^TMP to file at the end of process.
"RTN","IVMLDEM6",244,0)
 ..S IVMAFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMAVAL=$P(IVMNODE,"^",2)
"RTN","IVMLDEM6",245,0)
 ..I 'NOUPDT,((IVMAFLD=.118)!(IVMAFLD=.119)!(IVMAFLD=.12)) S ^TMP($J,"CHANGE UPDATE",IVMAFLD)=IVMAVAL
"RTN","IVMLDEM6",246,0)
 ..;
"RTN","IVMLDEM6",247,0)
 ..; - load addr field rec'd from IVM into DHCP (#2) file
"RTN","IVMLDEM6",248,0)
 ..I 'NOUPDT D UPLOAD(+DFN,IVMAFLD,IVMAVAL) S IVMFLAG=1
"RTN","IVMLDEM6",249,0)
 ..;
"RTN","IVMLDEM6",250,0)
 ..; - remove entry from (#301.511) sub-file
"RTN","IVMLDEM6",251,0)
 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMLDEM6",252,0)
 ..; - if no display or uploadable fields left, then delete the PID
"RTN","IVMLDEM6",253,0)
 ..;   segment
"RTN","IVMLDEM6",254,0)
 ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
"RTN","IVMLDEM6",255,0)
 ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
"RTN","IVMLDEM6",256,0)
 D ADDRCHNG^IVMPREC6(DFN) ;Update Address change date/time,source,site if necessary
"RTN","IVMLDEM6",257,0)
 I IVMFLAG D
"RTN","IVMLDEM6",258,0)
 .N DGCURR
"RTN","IVMLDEM6",259,0)
 .D GETUPDTS^DGADDUTL(DFN,.DGCURR)
"RTN","IVMLDEM6",260,0)
 .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR)
"RTN","IVMLDEM6",261,0)
 Q IVMFLAG
"RTN","IVMLDEM6",262,0)
 ;
"RTN","IVMLDEM6",263,0)
ADDRDT(DFN,IVMDA2,IVMDA1) ;
"RTN","IVMLDEM6",264,0)
 ; - validate Address Change Dt/Tm before filing
"RTN","IVMLDEM6",265,0)
 ;   if incoming address is accepted and the change date is older
"RTN","IVMLDEM6",266,0)
 ;   than what's on file, then use today's date for Addr Chg Dt/Tm
"RTN","IVMLDEM6",267,0)
 ;
"RTN","IVMLDEM6",268,0)
 Q:'$$ADRDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1)
"RTN","IVMLDEM6",269,0)
 N FDA,IEN92,IVMDA,IENS,ERR
"RTN","IVMLDEM6",270,0)
 S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92
"RTN","IVMLDEM6",271,0)
 Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92))
"RTN","IVMLDEM6",272,0)
 S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA
"RTN","IVMLDEM6",273,0)
 S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
"RTN","IVMLDEM6",274,0)
 S FDA(301.511,IENS,.02)=$$NOW^XLFDT
"RTN","IVMLDEM6",275,0)
 D FILE^DIE("","FDA","ERR")
"RTN","IVMLDEM6",276,0)
 Q
"RTN","IVMLDEM6",277,0)
 ;
"RTN","IVMLDEM6",278,0)
PHONDT(DFN,IVMDA2,IVMDA1) ;
"RTN","IVMLDEM6",279,0)
 ; - validate Residence Number Change Dt/Tm before filing
"RTN","IVMLDEM6",280,0)
 ;   if incoming phone number is accepted and the change date is
"RTN","IVMLDEM6",281,0)
 ;   older than what's on file, then use today's date for
"RTN","IVMLDEM6",282,0)
 ;   Residence Number Change Dt/Tm (IVM*2*152)
"RTN","IVMLDEM6",283,0)
 ;
"RTN","IVMLDEM6",284,0)
 Q:'$$PHNDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1)
"RTN","IVMLDEM6",285,0)
 N FDA,IEN92,IVMDA,IENS,ERR
"RTN","IVMLDEM6",286,0)
 S IEN92=$O(^IVM(301.92,"C","RF171P","")) Q:'IEN92
"RTN","IVMLDEM6",287,0)
 Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92))
"RTN","IVMLDEM6",288,0)
 S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA
"RTN","IVMLDEM6",289,0)
 S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
"RTN","IVMLDEM6",290,0)
 S FDA(301.511,IENS,.02)=$$NOW^XLFDT
"RTN","IVMLDEM6",291,0)
 D FILE^DIE("","FDA","ERR")
"RTN","IVMLDEM6",292,0)
 Q
"RTN","IVMLDEM6",293,0)
 ;
"RTN","IVMLDEM6",294,0)
PHARM(DFN) ;does this patient have active pharmacy prescriptions?
"RTN","IVMLDEM6",295,0)
 ;
"RTN","IVMLDEM6",296,0)
 ;External reference to $$EN^PSSRXACT supported by IA #4237
"RTN","IVMLDEM6",297,0)
 ;
"RTN","IVMLDEM6",298,0)
 Q $S('$G(DFN):0,1:$$EN^PSSRXACT(DFN))
"RTN","IVMPREC6")
0^6^B190620030
"RTN","IVMPREC6",1,0)
IVMPREC6 ;ALB/KCL,BRM,CKN,TDM,PWC,LBD,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ;11-02-2018 8:06AM
"RTN","IVMPREC6",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**3,4,12,17,34,58,79,102,115,140,144,121,151,152,165,167,171,164**;21-OCT-94;Build 98
"RTN","IVMPREC6",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","IVMPREC6",4,0)
 ;
"RTN","IVMPREC6",5,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC6",6,0)
 ; messages received from the IVM center.  Format of HL7 batch message:
"RTN","IVMPREC6",7,0)
 ;
"RTN","IVMPREC6",8,0)
 ;       BHS
"RTN","IVMPREC6",9,0)
 ;       {MSH
"RTN","IVMPREC6",10,0)
 ;        PID
"RTN","IVMPREC6",11,0)
 ;        ZPD
"RTN","IVMPREC6",12,0)
 ;        ZTA
"RTN","IVMPREC6",13,0)
 ;        ZAV
"RTN","IVMPREC6",14,0)
 ;        ZGD
"RTN","IVMPREC6",15,0)
 ;        ZCT (1 episode required, multiple possible)
"RTN","IVMPREC6",16,0)
 ;        ZEM (Veteran)
"RTN","IVMPREC6",17,0)
 ;        ZEM (Spouse - Optional)
"RTN","IVMPREC6",18,0)
 ;        RF1 (optional, multiple possible)
"RTN","IVMPREC6",19,0)
 ;       }
"RTN","IVMPREC6",20,0)
 ;       BTS
"RTN","IVMPREC6",21,0)
 ;
"RTN","IVMPREC6",22,0)
 ;
"RTN","IVMPREC6",23,0)
EN ; - entry point to process HL7 patient demographic message 
"RTN","IVMPREC6",24,0)
 ;
"RTN","IVMPREC6",25,0)
 N DGENUPLD,VAFCA08,DGRUGA08,COMP,DODSEG,GUARSEG,IVMCSDT,IVMCEDT,IVMCAFG,IVMCAVL,IVMPMAST,IVMCMAST
"RTN","IVMPREC6",26,0)
 ;N MULTDONE,XREP
"RTN","IVMPREC6",27,0)
 N XIVMA,IVMALADT,MULTIDONE
"RTN","IVMPREC6",28,0)
 N IVMPHDFG S IVMPHDFG=0 ; IVM*2*171 - add new variable IVMPHDFG to check for PHH deletion
"RTN","IVMPREC6",29,0)
 S IVMPMAST=""
"RTN","IVMPREC6",30,0)
 ;
"RTN","IVMPREC6",31,0)
 ; Setup array to hold all the Allowed Address Types
"RTN","IVMPREC6",32,0)
 ;F XIVMA="N","P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
"RTN","IVMPREC6",33,0)
 ; IVM*2.0*164 - Allow Residential and Confidential Addresses
"RTN","IVMPREC6",34,0)
 F XIVMA="P","R","CA","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
"RTN","IVMPREC6",35,0)
 ; Define the Confidential Address Categories
"RTN","IVMPREC6",36,0)
 ; IVM*2.0*164 - Uncomment below five lines to enable all confidential address categories
"RTN","IVMPREC6",37,0)
 S IVMALADT("VACAE")="CA^1"      ; ELIGIBILITY/ENROLLMENT
"RTN","IVMPREC6",38,0)
 S IVMALADT("VACAA")="CA^2"      ; APPOINTMENT/SCHEDULING
"RTN","IVMPREC6",39,0)
 S IVMALADT("VACAC")="CA^3"      ; COPAYMENTS/VETERAN BILLING
"RTN","IVMPREC6",40,0)
 S IVMALADT("VACAM")="CA^4"      ; MEDICAL RECORDS
"RTN","IVMPREC6",41,0)
 S IVMALADT("VACAO")="CA^5"      ; ALL OTHERS
"RTN","IVMPREC6",42,0)
 ; prevent a return Z07 when uploading a Z05 (Patient file triggers)
"RTN","IVMPREC6",43,0)
 S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
"RTN","IVMPREC6",44,0)
 ;
"RTN","IVMPREC6",45,0)
 ; prevent MPI A08 message when uploading Z05 (Patient file triggers)
"RTN","IVMPREC6",46,0)
 S VAFCA08=1  ;MPI/CIRN A08 suppression flag
"RTN","IVMPREC6",47,0)
 ;
"RTN","IVMPREC6",48,0)
 S IVMFLG=0,IVMADFLG=0
"RTN","IVMPREC6",49,0)
 ; - get incoming HL7 message from HL7 Transmission (#772) file
"RTN","IVMPREC6",50,0)
 F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA  S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D
"RTN","IVMPREC6",51,0)
 .K HLERR,ZEMADRUP
"RTN","IVMPREC6",52,0)
 .S IVMTSTPT=""                          ;Initialize Temp Addr County
"RTN","IVMPREC6",53,0)
 .;
"RTN","IVMPREC6",54,0)
 .; - message control id from MSH segment
"RTN","IVMPREC6",55,0)
 .S MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID
"RTN","IVMPREC6",56,0)
 .;
"RTN","IVMPREC6",57,0)
 .; - perform demographics message consistency check
"RTN","IVMPREC6",58,0)
 .D EN^IVMPRECA Q:$D(HLERR)
"RTN","IVMPREC6",59,0)
 .;
"RTN","IVMPREC6",60,0)
 .;Set array of Email, Cell, Pager fields
"RTN","IVMPREC6",61,0)
 .D EPCFLDS(.EPCFARY,.EPCDEL)
"RTN","IVMPREC6",62,0)
 .D AUPBLD(.AUPFARY,.UPDAUPG)
"RTN","IVMPREC6",63,0)
 .; - get next msg segment
"RTN","IVMPREC6",64,0)
 .D NEXT I $E(IVMSEG,1,3)'="PID" D  Q
"RTN","IVMPREC6",65,0)
 ..S HLERR="Missing PID segment" D ACK^IVMPREC
"RTN","IVMPREC6",66,0)
 .;
"RTN","IVMPREC6",67,0)
 .F I=1:1 D NEXT Q:$E(IVMSEG,1,4)="ZPD^"  ;Go through all PID
"RTN","IVMPREC6",68,0)
 .; - patient IEN (DFN) from PID segment
"RTN","IVMPREC6",69,0)
 .;Use IVMPID array created in IVMPRECA while performing consistency
"RTN","IVMPREC6",70,0)
 .;to process PID segment
"RTN","IVMPREC6",71,0)
 .;
"RTN","IVMPREC6",72,0)
 .;I '$G(IVMDFN) S HLERR="Invalid DFN" D ACK^IVMPREC  Q
"RTN","IVMPREC6",73,0)
 .S DFN=$G(IVMDFN)
"RTN","IVMPREC6",74,0)
 .;I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D  Q
"RTN","IVMPREC6",75,0)
 .;.S HLERR="Invalid DFN" D ACK^IVMPREC
"RTN","IVMPREC6",76,0)
 .;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) D  Q
"RTN","IVMPREC6",77,0)
 .;.S HLERR="Couldn't match HEC SSN with DHCP SSN" D ACK^IVMPREC
"RTN","IVMPREC6",78,0)
 .;
"RTN","IVMPREC6",79,0)
 .; - check for entry in IVM PATIENT file, otherwise create stub entry
"RTN","IVMPREC6",80,0)
 .S IVM3015=$O(^IVM(301.5,"B",DFN,0))
"RTN","IVMPREC6",81,0)
 .I 'IVM3015 S DGENUPLD="",IVM3015=$$LOG^IVMPLOG(DFN,DT),DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS" ;IVM*2.0*165
"RTN","IVMPREC6",82,0)
 .I 'IVM3015 D  Q
"RTN","IVMPREC6",83,0)
 ..S HLERR="Failed to create entry in IVM PATIENT file"
"RTN","IVMPREC6",84,0)
 ..D ACK^IVMPREC
"RTN","IVMPREC6",85,0)
 .;
"RTN","IVMPREC6",86,0)
 .; - compare PID segment fields with DHCP fields
"RTN","IVMPREC6",87,0)
 .S IVMSEG="PID"  ;Setting IVMSEG to PID before it calls COMPARE
"RTN","IVMPREC6",88,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) Q:$D(HLERR)
"RTN","IVMPREC6",89,0)
 .;
"RTN","IVMPREC6",90,0)
 .; - get next msg segment -decrement the counter so it can pickup ZPD
"RTN","IVMPREC6",91,0)
 .S IVMDA=IVMDA-1 D NEXT I $E(IVMSEG,1,3)'="ZPD" D  Q
"RTN","IVMPREC6",92,0)
 ..S HLERR="Missing ZPD segment" D ACK^IVMPREC
"RTN","IVMPREC6",93,0)
 .;Convert "" to null in ZPD segment except seq. 8,9, 31 and 32
"RTN","IVMPREC6",94,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",9,10,32,33,")
"RTN","IVMPREC6",95,0)
 .;
"RTN","IVMPREC6",96,0)
 .; - compare ZPD segment fields with DHCP fields
"RTN","IVMPREC6",97,0)
 .D COMPARE(IVMSEG)
"RTN","IVMPREC6",98,0)
 .;
"RTN","IVMPREC6",99,0)
 .; - get next msg segment
"RTN","IVMPREC6",100,0)
 .D NEXT I $E(IVMSEG,1,3)="ZEL" D  Q
"RTN","IVMPREC6",101,0)
 ..S HLERR="ZEL segment should not be sent in Z05 message" D ACK^IVMPREC
"RTN","IVMPREC6",102,0)
 .;
"RTN","IVMPREC6",103,0)
 .I $E(IVMSEG,1,3)'="ZTA" D  Q
"RTN","IVMPREC6",104,0)
 ..S HLERR="Missing ZTA segment" D ACK^IVMPREC
"RTN","IVMPREC6",105,0)
 .;Convert "" to null in ZTA segment seq. 7
"RTN","IVMPREC6",106,0)
 .I $P(IVMSEG,HLFS,8)=HLQ S $P(IVMSEG,HLFS,8)=""
"RTN","IVMPREC6",107,0)
 .;
"RTN","IVMPREC6",108,0)
 .; - compare ZTA segment fields with DHCP fields
"RTN","IVMPREC6",109,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",110,0)
 .;
"RTN","IVMPREC6",111,0)
 .; - get next msg segment
"RTN","IVMPREC6",112,0)
 .; KUM - ZAV Segment Processing (CASS field) 
"RTN","IVMPREC6",113,0)
 .D NEXT
"RTN","IVMPREC6",114,0)
 .I $E(IVMSEG,1,3)'="ZAV" D  Q
"RTN","IVMPREC6",115,0)
 ..S HLERR="Missing ZAV segment" D ACK^IVMPREC
"RTN","IVMPREC6",116,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",117,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) ;Process 1st ZAV
"RTN","IVMPREC6",118,0)
 .S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Handle possible mult ZAVs
"RTN","IVMPREC6",119,0)
 ..D NEXT I $E(IVMSEG,1,3)'="ZAV" S MULTDONE=1 Q
"RTN","IVMPREC6",120,0)
 ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",121,0)
 ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",122,0)
 .;D NEXT
"RTN","IVMPREC6",123,0)
 .;
"RTN","IVMPREC6",124,0)
 .; - get next msg segment
"RTN","IVMPREC6",125,0)
 .I $E(IVMSEG,1,3)'="ZGD" D  Q
"RTN","IVMPREC6",126,0)
 ..S HLERR="Missing ZGD segment" D ACK^IVMPREC
"RTN","IVMPREC6",127,0)
 .;
"RTN","IVMPREC6",128,0)
 .; - compare ZGD segment fields with DHCP fields
"RTN","IVMPREC6",129,0)
 .; convert "" to null for ZGD segment
"RTN","IVMPREC6",130,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
"RTN","IVMPREC6",131,0)
 .; convert seq. 6 separately
"RTN","IVMPREC6",132,0)
 .S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
"RTN","IVMPREC6",133,0)
 .D COMPARE(IVMSEG)
"RTN","IVMPREC6",134,0)
 .;S IVMFLG=0
"RTN","IVMPREC6",135,0)
 .;
"RTN","IVMPREC6",136,0)
 .;S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Skip ZCT & ZEM -coming later
"RTN","IVMPREC6",137,0)
 .;.D NEXT
"RTN","IVMPREC6",138,0)
 .;.I ($E(IVMSEG,1,3)'="ZCT")&($E(IVMSEG,1,3)'="ZEM") S MULTDONE=1 Q
"RTN","IVMPREC6",139,0)
 .;S IVMDA=IVMDA-1
"RTN","IVMPREC6",140,0)
 .;
"RTN","IVMPREC6",141,0)
 .; - get next msg segment
"RTN","IVMPREC6",142,0)
 .D NEXT
"RTN","IVMPREC6",143,0)
 .I $E(IVMSEG,1,3)'="ZCT" D  Q
"RTN","IVMPREC6",144,0)
 ..S HLERR="Missing ZCT segment" D ACK^IVMPREC
"RTN","IVMPREC6",145,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",146,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)   ;Process 1st ZCT
"RTN","IVMPREC6",147,0)
 .S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Handle possible mult ZCTs
"RTN","IVMPREC6",148,0)
 ..D NEXT I $E(IVMSEG,1,3)'="ZCT" S MULTDONE=1 Q
"RTN","IVMPREC6",149,0)
 ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",150,0)
 ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",151,0)
 .;
"RTN","IVMPREC6",152,0)
 .S IVMDA=IVMDA-1 D NEXT
"RTN","IVMPREC6",153,0)
 .I $E(IVMSEG,1,3)'="ZEM" D  Q
"RTN","IVMPREC6",154,0)
 ..S HLERR="Missing ZEM segment" D ACK^IVMPREC
"RTN","IVMPREC6",155,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)   ;Process 1st ZEM
"RTN","IVMPREC6",156,0)
 .S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Handle possible mult ZEMs
"RTN","IVMPREC6",157,0)
 ..D NEXT I $E(IVMSEG,1,3)'="ZEM" S MULTDONE=1 Q
"RTN","IVMPREC6",158,0)
 ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",159,0)
 .S IVMDA=IVMDA-1
"RTN","IVMPREC6",160,0)
 .;
"RTN","IVMPREC6",161,0)
 .; - check for RF1 segment and get segment if it exists
"RTN","IVMPREC6",162,0)
 .;     This process will automatically update patient address data
"RTN","IVMPREC6",163,0)
 .;     in the Patient (#2) file if the incoming address is more
"RTN","IVMPREC6",164,0)
 .;     recent than the existing one.
"RTN","IVMPREC6",165,0)
 .;Modified code to handle multiple RF1 segment - IVM*2*115
"RTN","IVMPREC6",166,0)
 .S (UPDEPC("SAD"),UPDEPC("CPH"),UPDEPC("PNO"),UPDEPC("EAD"),UPDEPC("PHH"))=0
"RTN","IVMPREC6",167,0)
 .S QFLG=0 I $$RF1CHK(IVMRTN,IVMDA) F I=1:1 D  Q:QFLG
"RTN","IVMPREC6",168,0)
 ..D NEXT
"RTN","IVMPREC6",169,0)
 ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
"RTN","IVMPREC6",170,0)
 ..S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
"RTN","IVMPREC6",171,0)
 ..I $P(IVMSEG,HLFS,4)="" S QFLG=1 Q  ;Quit if RF1 is blank
"RTN","IVMPREC6",172,0)
 ..D COMPARE(IVMSEG)
"RTN","IVMPREC6",173,0)
 ..I '$$RF1CHK(IVMRTN,IVMDA) S QFLG=1
"RTN","IVMPREC6",174,0)
 .; KUM - IVM*2.0*164 - Set Confidential Active flag
"RTN","IVMPREC6",175,0)
 .S IVMCSDT="",IVMCEDT="",IVMCAFG=.14105,IVMCAVL="Y"
"RTN","IVMPREC6",176,0)
 .S IVMCSDT=$P($P($G(ADDRESS("CA")),"~",12),"&",1)
"RTN","IVMPREC6",177,0)
 .S IVMCSDT=$$FMDATE^HLFNC(IVMCSDT)
"RTN","IVMPREC6",178,0)
 .S IVMCEDT=$P($P($G(ADDRESS("CA")),"~",12),"&",2)
"RTN","IVMPREC6",179,0)
 .S IVMCEDT=$$FMDATE^HLFNC(IVMCEDT)
"RTN","IVMPREC6",180,0)
 .I IVMCSDT="" D
"RTN","IVMPREC6",181,0)
 ..;I $G(UPDAUPG("CA"))'=1 Q
"RTN","IVMPREC6",182,0)
 ..S IVMCAVL="N"
"RTN","IVMPREC6",183,0)
 .D AUTOAUP^IVMPREC9(DFN,.UPDAUP,.UPDAUPG)
"RTN","IVMPREC6",184,0)
 .S IVMFLG=0
"RTN","IVMPREC6",185,0)
 ; - send mail message if necessary
"RTN","IVMPREC6",186,0)
 ; This bulletin has been disabled.  IVM*2*140
"RTN","IVMPREC6",187,0)
 ;I IVMCNTR D MAIL^IVMUFNC()
"RTN","IVMPREC6",188,0)
 ; Cleanup variables if no msg necessary
"RTN","IVMPREC6",189,0)
 I 'IVMCNTR K IVMTEXT,XMSUB
"RTN","IVMPREC6",190,0)
 ;
"RTN","IVMPREC6",191,0)
ENQ ; - cleanup variables
"RTN","IVMPREC6",192,0)
 K DA,DR,DFN,IVMADDR,IVMADFLG,IVMDA,IVMDHCP,IVMFLAG,IVMFLD,IVMPHDFG,IVMPIECE,IVMSEG,IVMSTART,IVMXREF,DGENUPLD,IVMPID,PIDSTR,ADDRESS,TELECOM,UPDEPC,EPCFARY,IVMDFN,DODSEG,EPCDEL,GUARSEG,UPDAUP,IVMRACE,IVMTSTPT,IVMPMAST
"RTN","IVMPREC6",193,0)
 Q
"RTN","IVMPREC6",194,0)
 ;
"RTN","IVMPREC6",195,0)
 ;
"RTN","IVMPREC6",196,0)
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
"RTN","IVMPREC6",197,0)
 ;
"RTN","IVMPREC6",198,0)
 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
"RTN","IVMPREC6",199,0)
 Q
"RTN","IVMPREC6",200,0)
 ;
"RTN","IVMPREC6",201,0)
 ;
"RTN","IVMPREC6",202,0)
COMPARE(IVMSEG) ; - compare incoming HL7 segment/fields with DHCP fields
"RTN","IVMPREC6",203,0)
 ;
"RTN","IVMPREC6",204,0)
 ;  Input:  IVMSEG  --  as the text of the incoming HL7 message
"RTN","IVMPREC6",205,0)
 ;
"RTN","IVMPREC6",206,0)
 ; Output:  None
"RTN","IVMPREC6",207,0)
 ;
"RTN","IVMPREC6",208,0)
 ; - get 3 letter HL7 segment name
"RTN","IVMPREC6",209,0)
 S IVMXREF=$P(IVMSEG,HLFS,1),IVMSTART=IVMXREF
"RTN","IVMPREC6",210,0)
 ;
"RTN","IVMPREC6",211,0)
 ; - strip off HL7 segment name
"RTN","IVMPREC6",212,0)
 S IVMSEG=$P(IVMSEG,HLFS,2,99)
"RTN","IVMPREC6",213,0)
 ;
"RTN","IVMPREC6",214,0)
 ; - roll through "C" x-ref in IVM Demographic Upload Fields (#301.92) file
"RTN","IVMPREC6",215,0)
 F  S IVMXREF=$O(^IVM(301.92,"C",IVMXREF)) Q:IVMXREF']""  D
"RTN","IVMPREC6",216,0)
 .S IVMDEMDA=$O(^IVM(301.92,"C",IVMXREF,"")) Q:IVMDEMDA']""
"RTN","IVMPREC6",217,0)
 .I $$INACTIVE(IVMDEMDA) Q
"RTN","IVMPREC6",218,0)
 .;
"RTN","IVMPREC6",219,0)
 .; - compare incoming HL7 segment fields with DHCP fields
"RTN","IVMPREC6",220,0)
 .I IVMXREF["PID",(IVMSTART["PID") D PID^IVMPREC8
"RTN","IVMPREC6",221,0)
 .I IVMXREF["ZPD",(IVMSTART["ZPD") D ZPD^IVMPREC8
"RTN","IVMPREC6",222,0)
 .I IVMXREF["ZTA",(IVMSTART["ZTA") D ZTA^IVMPREC8
"RTN","IVMPREC6",223,0)
 .; KUM IVM*2.0*164 - ZAV Segment Processing
"RTN","IVMPREC6",224,0)
 .I IVMXREF["ZAV",(IVMSTART["ZAV") D ZAV^IVMPREC8
"RTN","IVMPREC6",225,0)
 .;
"RTN","IVMPREC6",226,0)
 .I IVMXREF["ZGD",(IVMSTART["ZGD") D ZGD^IVMPREC8
"RTN","IVMPREC6",227,0)
 .I IVMXREF["ZCT",(IVMSTART["ZCT") D ZCT^IVMPREC8
"RTN","IVMPREC6",228,0)
 .I IVMXREF["ZEM",(IVMSTART["ZEM") D ZEM^IVMPREC8
"RTN","IVMPREC6",229,0)
 .I IVMXREF["RF1",(IVMSTART["RF1") D RF1^IVMPREC8
"RTN","IVMPREC6",230,0)
 Q
"RTN","IVMPREC6",231,0)
 ;
"RTN","IVMPREC6",232,0)
 ;
"RTN","IVMPREC6",233,0)
DEMBULL ; -  build mail message for transmission to IVM mail group notifying
"RTN","IVMPREC6",234,0)
 ;    them that patients with updated demographic data has been received
"RTN","IVMPREC6",235,0)
 ;    from the IVM Center and may now be uploaded into DHCP.
"RTN","IVMPREC6",236,0)
 ;
"RTN","IVMPREC6",237,0)
 ; If record is auto uploaded, don't add veteran to bulletin
"RTN","IVMPREC6",238,0)
 I $$CKAUTO Q
"RTN","IVMPREC6",239,0)
 ;
"RTN","IVMPREC6",240,0)
 S IVMPTID=$$PT^IVMUFNC4(DFN)
"RTN","IVMPREC6",241,0)
 S XMSUB="IVM - DEMOGRAPHIC UPLOAD for "_$P($P(IVMPTID,"^"),",")_" ("_$P(IVMPTID,"^",3)_")"
"RTN","IVMPREC6",242,0)
 S IVMTEXT(1)="Updated demographic information has been received from the"
"RTN","IVMPREC6",243,0)
 S IVMTEXT(2)="Health Eligibilty Center.  Please select the 'Demographic Upload'"
"RTN","IVMPREC6",244,0)
 S IVMTEXT(3)="option from the IVM Upload Menu in order to take action on this"
"RTN","IVMPREC6",245,0)
 S IVMTEXT(4)="demographic information.  If you have any questions concerning the"
"RTN","IVMPREC6",246,0)
 S IVMTEXT(5)="information received, please contact the Health Eligibility Center."
"RTN","IVMPREC6",247,0)
 S IVMTEXT(7)=""
"RTN","IVMPREC6",248,0)
 S IVMTEXT(8)="The Health Eligibilty Center has identified the following"
"RTN","IVMPREC6",249,0)
 S IVMTEXT(9)="patients as having updated demographic information:"
"RTN","IVMPREC6",250,0)
 S IVMTEXT(10)=""
"RTN","IVMPREC6",251,0)
 S IVMCNTR=IVMCNTR+1
"RTN","IVMPREC6",252,0)
 S IVMTEXT(IVMCNTR+10)=$J(IVMCNTR_")",5)_"  "_$P(IVMPTID,"^")_" ("_$P(IVMPTID,"^",3)_")"
"RTN","IVMPREC6",253,0)
 Q
"RTN","IVMPREC6",254,0)
 ;
"RTN","IVMPREC6",255,0)
INACTIVE(IVMDEMDA) ;Check if field is inactive in Demographic Upload
"RTN","IVMPREC6",256,0)
 ; Input  -- IVMDEMDA IVM Demographic Upload Fields IEN
"RTN","IVMPREC6",257,0)
 ; Output -- 1=Yes and 0=No
"RTN","IVMPREC6",258,0)
 Q +$P($G(^IVM(301.92,IVMDEMDA,0)),U,9)
"RTN","IVMPREC6",259,0)
 ;
"RTN","IVMPREC6",260,0)
RF1CHK(IVMRTN,IVMDA) ;does an RF1 segment exist in this message?
"RTN","IVMPREC6",261,0)
 N RF1
"RTN","IVMPREC6",262,0)
 S RF1=$O(^TMP($J,IVMRTN,IVMDA))
"RTN","IVMPREC6",263,0)
 I $E($G(^(+RF1,0)),1,3)'="RF1" Q 0
"RTN","IVMPREC6",264,0)
 Q 1
"RTN","IVMPREC6",265,0)
 ;
"RTN","IVMPREC6",266,0)
CKAUTO() ;
"RTN","IVMPREC6",267,0)
 ; Chect if message qualifies for an auto upload.
"RTN","IVMPREC6",268,0)
 N AUTO,IVMI,DOD
"RTN","IVMPREC6",269,0)
 S AUTO=0,IVMI=$O(^IVM(301.92,"C","ZPD09",""))
"RTN","IVMPREC6",270,0)
 I IVMI=IVMDEMDA  D
"RTN","IVMPREC6",271,0)
 .I +IVMFLD'>0 S AUTO=1 Q
"RTN","IVMPREC6",272,0)
 .S DOD=$P($G(^DPT(DFN,.35)),U)
"RTN","IVMPREC6",273,0)
 .I DOD=IVMFLD S AUTO=1 Q
"RTN","IVMPREC6",274,0)
 ;
"RTN","IVMPREC6",275,0)
 Q AUTO
"RTN","IVMPREC6",276,0)
BLDPID(PIDTMP,IVMPID) ;Build IVMPID subscripted by sequence number
"RTN","IVMPREC6",277,0)
 N STR,X1,X2,N,TEXT,C,L
"RTN","IVMPREC6",278,0)
 S STR="",X1=1,(N,X2)=0
"RTN","IVMPREC6",279,0)
 F  S N=$O(PIDTMP(N)) Q:N=""  S TEXT=PIDTMP(N) F L=1:1:$L(TEXT) S C=$E(TEXT,L) D
"RTN","IVMPREC6",280,0)
 . I C="^" D  Q
"RTN","IVMPREC6",281,0)
 . . I X2 S X2=X2+1,IVMPID(X1,X2)=STR
"RTN","IVMPREC6",282,0)
 . . E  S IVMPID(X1)=STR
"RTN","IVMPREC6",283,0)
 . . S STR="",X1=X1+1,X2=0
"RTN","IVMPREC6",284,0)
 . I C="|" D  Q
"RTN","IVMPREC6",285,0)
 . . S X2=X2+1,IVMPID(X1,X2)=STR,STR=""
"RTN","IVMPREC6",286,0)
 . S STR=STR_C
"RTN","IVMPREC6",287,0)
 I $G(C)'="",$G(C)'="^",$G(C)'="|" D
"RTN","IVMPREC6",288,0)
 . I X2 S X2=X2+1,IVMPID(X1,X2)=STR Q
"RTN","IVMPREC6",289,0)
 . S IVMPID(X1)=STR
"RTN","IVMPREC6",290,0)
 Q
"RTN","IVMPREC6",291,0)
ADDRCHNG(DFN) ;Store Address Change Date/time, Source and site if necessary
"RTN","IVMPREC6",292,0)
 ;Store Residence Number Change Date/Time, Source and Site (IVM*2*152)
"RTN","IVMPREC6",293,0)
 N IVMVALUE,IVMFIELD
"RTN","IVMPREC6",294,0)
 I '$D(^TMP($J,"CHANGE UPDATE")) Q
"RTN","IVMPREC6",295,0)
 S IVMFIELD=0 F  S IVMFIELD=$O(^TMP($J,"CHANGE UPDATE",IVMFIELD)) Q:IVMFIELD=""  D
"RTN","IVMPREC6",296,0)
 . S IVMVALUE=$G(^TMP($J,"CHANGE UPDATE",IVMFIELD))
"RTN","IVMPREC6",297,0)
 . S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
"RTN","IVMPREC6",298,0)
 . D ^DIE K DA,DIE,DR
"RTN","IVMPREC6",299,0)
 .; - delete inaccurate Addr Change Site data if Source is not VAMC
"RTN","IVMPREC6",300,0)
 . I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMPREC6",301,0)
 .; - delete inaccurate Residence Number Change Site data if Source
"RTN","IVMPREC6",302,0)
 .;   is not VAMC (IVM*2*152)
"RTN","IVMPREC6",303,0)
 . I IVMFIELD=.1322,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.1323)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMPREC6",304,0)
 K ^TMP($J,"CHANGE UPDATE")
"RTN","IVMPREC6",305,0)
 Q
"RTN","IVMPREC6",306,0)
EPCFLDS(EPCFARY,EPCDEL) ;
"RTN","IVMPREC6",307,0)
 ;EPCFARY - Contains IENs of Pager, email, Cell phone and Home phone records in 301.92 File - Passed by reference
"RTN","IVMPREC6",308,0)
 ;EPCDEL - Contains field # of Pager, Email, Cell phone and Home phone fields in Patient(#2) file. - Passed by reference
"RTN","IVMPREC6",309,0)
 I (DODSEG)!(GUARSEG) Q
"RTN","IVMPREC6",310,0)
 S EPCFARY("PNO")=$O(^IVM(301.92,"B","PAGER NUMBER",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE SOURCE",0))
"RTN","IVMPREC6",311,0)
 S EPCFARY("CPH")=$O(^IVM(301.92,"B","CELLULAR NUMBER",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE SOURCE",0))
"RTN","IVMPREC6",312,0)
 S EPCFARY("EAD")=$O(^IVM(301.92,"B","EMAIL ADDRESS",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE SOURCE",0))
"RTN","IVMPREC6",313,0)
 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC6",314,0)
 S EPCFARY("PHH")=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SOURCE",0))
"RTN","IVMPREC6",315,0)
 S EPCDEL("PNO")=".135^.1312^.1313^.1314"
"RTN","IVMPREC6",316,0)
 S EPCDEL("CPH")=".134^.139^.1311^.13111"
"RTN","IVMPREC6",317,0)
 S EPCDEL("EAD")=".133^.136^.137^.138"
"RTN","IVMPREC6",318,0)
 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC6",319,0)
 ; IVM*2.0*171 - Comment out line to fix the home phone deletion issue
"RTN","IVMPREC6",320,0)
 ;S EPCDEL("PHH")=".131^.1321^.1322^.1323"
"RTN","IVMPREC6",321,0)
 Q
"RTN","IVMPREC6",322,0)
 ;
"RTN","IVMPREC6",323,0)
AUPBLD(AUPFARY,UPDAUPG) ; Set up array containing fields for auto upload.
"RTN","IVMPREC6",324,0)
 ;AUPFARY - Contains fields in 301.92 File-Passed by reference
"RTN","IVMPREC6",325,0)
 ;UPDAUPG - Contains all groups initialized to '0'
"RTN","IVMPREC6",326,0)
 N AUPSTR,AUPGRP,AUPFLST,AUPPCE,AUPSGSQ,AUPDA
"RTN","IVMPREC6",327,0)
 F I=3:1 S AUPSTR=$P($T(AUPLST+I),";;",2,3) Q:$P(AUPSTR,";")="QUIT"  D
"RTN","IVMPREC6",328,0)
 .S AUPGRP=$P(AUPSTR,";"),AUPFLST=$P(AUPSTR,";",2)
"RTN","IVMPREC6",329,0)
 .F AUPPCE=1:1:$L(AUPFLST,"^") D
"RTN","IVMPREC6",330,0)
 ..S AUPSGSQ=$P(AUPFLST,"^",AUPPCE) Q:AUPSGSQ=""
"RTN","IVMPREC6",331,0)
 ..S AUPDA=$O(^IVM(301.92,"C",AUPSGSQ,0)) Q:AUPDA=""
"RTN","IVMPREC6",332,0)
 ..S AUPFARY(AUPDA)=AUPGRP
"RTN","IVMPREC6",333,0)
 ..S:AUPGRP'="" UPDAUPG(AUPGRP)=0  ; Default group update flags to '0'
"RTN","IVMPREC6",334,0)
 Q
"RTN","IVMPREC6",335,0)
 ;
"RTN","IVMPREC6",336,0)
 ; IVM*2.0*164 - ZAV01,ZAV02 AND ZAV04 are added for Auto Upload.  
"RTN","IVMPREC6",337,0)
 ; Residential Address (RA) group is added
"RTN","IVMPREC6",338,0)
 ; Confidential Address (CA) group is uncommented
"RTN","IVMPREC6",339,0)
AUPLST ; P1;P2
"RTN","IVMPREC6",340,0)
 ; P1 = Group Name (treat all entries as this group if present)
"RTN","IVMPREC6",341,0)
 ; P2 = .01 field(s) from 301.92 seperated by '^'
"RTN","IVMPREC6",342,0)
 ;;D1;ZCT03D1^ZCT04D1^ZCT051D1^ZCT052D1^ZCT053D1^ZCT054D1^ZCT055D1^ZCT06D1^ZCT07D1^ZCT10D1
"RTN","IVMPREC6",343,0)
 ;;E1;ZCT03E1^ZCT04E1^ZCT051E1^ZCT052E1^ZCT053E1^ZCT054E1^ZCT055E1^ZCT06E1^ZCT07E1^ZCT10E1
"RTN","IVMPREC6",344,0)
 ;;E2;ZCT03E2^ZCT04E2^ZCT051E2^ZCT052E2^ZCT053E2^ZCT054E2^ZCT055E2^ZCT06E2^ZCT07E2^ZCT10E2
"RTN","IVMPREC6",345,0)
 ;;K1;ZCT03K1^ZCT04K1^ZCT051K1^ZCT052K1^ZCT053K1^ZCT054K1^ZCT055K1^ZCT06K1^ZCT07K1^ZCT10K1
"RTN","IVMPREC6",346,0)
 ;;K2;ZCT03K2^ZCT04K2^ZCT051K2^ZCT052K2^ZCT053K2^ZCT054K2^ZCT055K2^ZCT06K2^ZCT07K2^ZCT10K2
"RTN","IVMPREC6",347,0)
 ;;TA;ZTA02^ZTA03^ZTA04^ZTA051^ZTA052^ZTA053^ZTA054^ZTA055^ZTA056^ZTA058^ZTA059^ZTA07^ZTA08^ZTA09^ZTA054F^ZTA055F^ZAV04
"RTN","IVMPREC6",348,0)
 ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1110C^PID1112C^PID1113C^PID13CA^RF161CA^RF171CA^ZAV02
"RTN","IVMPREC6",349,0)
 ;;RA;PID111R^PID112R^PID113R^PID114R^PID114RF^PID115R^PID115RF^PID116R^PID117R^PID118R^PID119R^PID1110R^PID1112R^PID1113R^PID13RA^RF161RA^RF162RA^RF171RA^ZAV01
"RTN","IVMPREC6",350,0)
 ;;;ZEM03^ZEM04^ZEM05^ZEM061^ZEM062^ZEM063^ZEM064^ZEM065^ZEM068^ZEM07^ZEM09
"RTN","IVMPREC6",351,0)
 ;;;ZEM03S^ZEM04S^ZEM05S^ZEM061S^ZEM062S^ZEM063S^ZEM064S^ZEM065S^ZEM068S^ZEM07S^ZEM09S
"RTN","IVMPREC6",352,0)
 ;;;PID06^PID10^PID16^PID17^PID22^ZPD30^ZPD06^ZPD07
"RTN","IVMPREC6",353,0)
 ;;QUIT
"RTN","IVMPREC6",354,0)
 ;;
"RTN","IVMPREC6",355,0)
 ;;The following have been disabled until further notice
"RTN","IVMPREC6",356,0)
 ;;;PID113N^PID114N^PID24^PID13W
"RTN","IVMPREC6",357,0)
 ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1112C1^PID1112C2^PID13CA^RF161CA^RF171CA
"RTN","IVMPREC8")
0^2^B300675114
"RTN","IVMPREC8",1,0)
IVMPREC8 ;ALB/KCL,BRM,PJR,CKN,TDM,PWC,LBD,DPR,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;02 NOV 2018  8:56 AM
"RTN","IVMPREC8",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,58,73,79,102,115,121,148,151,152,168,167,171,164**;21-OCT-94;Build 98
"RTN","IVMPREC8",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","IVMPREC8",4,0)
 ;
"RTN","IVMPREC8",5,0)
 ; This routine is called from IVMPREC6.
"RTN","IVMPREC8",6,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC8",7,0)
 ; messages received from the IVM center.
"RTN","IVMPREC8",8,0)
 ;
"RTN","IVMPREC8",9,0)
PID ;-compare PID fields with DHCP fields
"RTN","IVMPREC8",10,0)
 N COMPPH1,COMPPH2,COUNTRY
"RTN","IVMPREC8",11,0)
 ;
"RTN","IVMPREC8",12,0)
 S IVMFLD=""
"RTN","IVMPREC8",13,0)
 ; - strip off seg name
"RTN","IVMPREC8",14,0)
 S IVMPIECE=$E(IVMXREF,4,9)
"RTN","IVMPREC8",15,0)
 ;Only process if value exist-also handles multiple addr
"RTN","IVMPREC8",16,0)
 I $G(IVMPID(+$E(IVMPIECE,1,2)))'=""!($O(IVMPID(+$E(IVMPIECE,1,2),""))) D
"RTN","IVMPREC8",17,0)
 .;
"RTN","IVMPREC8",18,0)
 .; -if PID field is the addr field-parse addr
"RTN","IVMPREC8",19,0)
 .S IVMADFLG=0
"RTN","IVMPREC8",20,0)
 .I IVMXREF["PID11",'$G(DODSEG) D  Q:IVMFLD=""
"RTN","IVMPREC8",21,0)
 ..;
"RTN","IVMPREC8",22,0)
 ..;-Process Place of Birth City&State
"RTN","IVMPREC8",23,0)
 ..;I (IVMXREF="PID113N")!(IVMXREF="PID114N") D  Q
"RTN","IVMPREC8",24,0)
 ..;.Q:'$D(ADDRESS("N"))
"RTN","IVMPREC8",25,0)
 ..;.S IVMADDR=ADDRESS("N")
"RTN","IVMPREC8",26,0)
 ..;.S IVMPIECE=$E(IVMPIECE,3,4),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",27,0)
 ..;.Q:IVMFLD=""
"RTN","IVMPREC8",28,0)
 ..;.I IVMPIECE="4N" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",29,0)
 ..; IVM*2.0*164-Uncomment Conf and Add Res
"RTN","IVMPREC8",30,0)
 ..I $G(AUPFARY(IVMDEMDA))="CA" S IVMADDR=$G(ADDRESS("CA")) ;Conf Addr
"RTN","IVMPREC8",31,0)
 ..I $G(AUPFARY(IVMDEMDA))'="CA" D
"RTN","IVMPREC8",32,0)
 ...S IVMADDR=$S($D(ADDRESS("P")):ADDRESS("P"),$D(ADDRESS("VAB1")):ADDRESS("VAB1"),$D(ADDRESS("VAB2")):ADDRESS("VAB2"),$D(ADDRESS("VAB3")):ADDRESS("VAB3"),$D(ADDRESS("VAB4")):ADDRESS("VAB4"),1:"")
"RTN","IVMPREC8",33,0)
 ...I $G(AUPFARY(IVMDEMDA))="RA" S IVMADDR=$G(ADDRESS("R"))
"RTN","IVMPREC8",34,0)
 ..I IVMADDR="" Q
"RTN","IVMPREC8",35,0)
 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)
"RTN","IVMPREC8",36,0)
 ..S FORADDR=$S(COUNTRY="USA":0,1:1)
"RTN","IVMPREC8",37,0)
 ..;-get piece of addr field, and set IVMFLD
"RTN","IVMPREC8",38,0)
 ..S IVMPIECE=$E(IVMPIECE,3,6),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",39,0)
 ..;Enable del of Addr2,Addr3-164-Fix End dt
"RTN","IVMPREC8",40,0)
 ..I (IVMPIECE="2C")!(IVMPIECE="8C")!(IVMPIECE="2R")!(IVMPIECE="8R") S:IVMFLD="" IVMFLD="@"
"RTN","IVMPREC8",41,0)
 ..I $E(IVMPIECE,1,3)="13C" D
"RTN","IVMPREC8",42,0)
 ...S IVMFLD=$P(IVMADDR,$E(HLECH),12)
"RTN","IVMPREC8",43,0)
 ...S IVMFLD=$$FMDATE^HLFNC($P(IVMFLD,$E(HLECH,4),2))
"RTN","IVMPREC8",44,0)
 ...S:IVMFLD="" IVMFLD="@"
"RTN","IVMPREC8",45,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",46,0)
 ..;convert st abbrev. to pointer
"RTN","IVMPREC8",47,0)
 ..I (IVMPIECE=4)!(IVMPIECE="4C")!(IVMPIECE="4R") D
"RTN","IVMPREC8",48,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")
"RTN","IVMPREC8",49,0)
 ...I IVMFLD'="" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",50,0)
 ...;IVM*2.0*164-PMA State Pointer
"RTN","IVMPREC8",51,0)
 ...I IVMPIECE=4 S IVMPMAST=$G(IVMSTPTR)
"RTN","IVMPREC8",52,0)
 ...I IVMPIECE="4C" S IVMCMAST=$G(IVMSTPTR)
"RTN","IVMPREC8",53,0)
 ..I (IVMPIECE=5)!(IVMPIECE="5C")!(IVMPIECE="5R") D
"RTN","IVMPREC8",54,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")
"RTN","IVMPREC8",55,0)
 ...I IVMFLD'="" S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=X
"RTN","IVMPREC8",56,0)
 ..I (IVMPIECE="4F")!(IVMPIECE="4CF")!(IVMPIECE="4RF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;PROVINCE
"RTN","IVMPREC8",57,0)
 ..I (IVMPIECE="5F")!(IVMPIECE="5CF")!(IVMPIECE="5RF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;POSTAL CODE
"RTN","IVMPREC8",58,0)
 ..I (IVMPIECE=6)!(IVMPIECE="6C")!(IVMPIECE="6R") S IVMFLD=$$CNTRCONV(COUNTRY) ;COUNTRY
"RTN","IVMPREC8",59,0)
 ..I IVMPIECE=7 S IVMFLD=$$BAICONV(IVMFLD) ;Bad Address Indicator
"RTN","IVMPREC8",60,0)
 ..I IVMPIECE="7C" S IVMFLD=CONFADCT  ;CONFADCT set in PID11^IVMPRECA
"RTN","IVMPREC8",61,0)
 ..;County for Conf
"RTN","IVMPREC8",62,0)
 ..I IVMPIECE="9C" D
"RTN","IVMPREC8",63,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""
"RTN","IVMPREC8",64,0)
 ...I IVMCMAST'="" S IVMFLD=+$O(^DIC(5,IVMCMAST,1,"C",IVMFLD,0))
"RTN","IVMPREC8",65,0)
 ..;County for Res
"RTN","IVMPREC8",66,0)
 ..I IVMPIECE="9R" D
"RTN","IVMPREC8",67,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""
"RTN","IVMPREC8",68,0)
 ...I IVMSTPTR'="" S IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",IVMFLD,0))
"RTN","IVMPREC8",69,0)
 ..I $E(IVMPIECE,1,3)="12C" D
"RTN","IVMPREC8",70,0)
 ...S IVMFLD=$$FMDATE^HLFNC($P(IVMFLD,$E(HLECH,4),1))
"RTN","IVMPREC8",71,0)
 ...;IVM*2.0*164-Allow del of start dt
"RTN","IVMPREC8",72,0)
 ...S:IVMFLD="" IVMFLD="@"
"RTN","IVMPREC8",73,0)
 ..S IVMADFLG=1
"RTN","IVMPREC8",74,0)
 .;
"RTN","IVMPREC8",75,0)
 .I IVMXREF["PID12",'$G(DODSEG) D
"RTN","IVMPREC8",76,0)
 ..;IVM*2.0*164-County from PMA St
"RTN","IVMPREC8",77,0)
 ..;I 'FORADDR S IVMADFLG=1,IVMFLD=+$O(^DIC(5,IVMPMAST,1,"C",IVMPID(12),0))
"RTN","IVMPREC8",78,0)
 ..I 'FORADDR D
"RTN","IVMPREC8",79,0)
 ...S IVMADFLG=1
"RTN","IVMPREC8",80,0)
 ...I IVMPMAST'="" S IVMFLD=+$O(^DIC(5,IVMPMAST,1,"C",IVMPID(12),0))
"RTN","IVMPREC8",81,0)
 .;line remove so that the ph is compared 
"RTN","IVMPREC8",82,0)
 .;before saving to 301.5.
"RTN","IVMPREC8",83,0)
 .I IVMXREF["PID13",$D(TELECOM),'$G(DODSEG) D
"RTN","IVMPREC8",84,0)
 ..;Conf Ph
"RTN","IVMPREC8",85,0)
 ..I IVMXREF="PID13CA",$D(TELECOM("VACPN")) D
"RTN","IVMPREC8",86,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("VACPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",87,0)
 ..;Ph Num [Work]
"RTN","IVMPREC8",88,0)
 ..I IVMXREF="PID13W",$D(TELECOM("WPN")) D
"RTN","IVMPREC8",89,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("WPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",90,0)
 ..;Pager Num
"RTN","IVMPREC8",91,0)
 ..I IVMXREF="PID13B",$D(TELECOM("BPN")) D
"RTN","IVMPREC8",92,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("BPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",93,0)
 ..;Cell Ph Num
"RTN","IVMPREC8",94,0)
 ..I IVMXREF="PID13C",$D(TELECOM("ORN")) D
"RTN","IVMPREC8",95,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("ORN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",96,0)
 ..;Email Addr
"RTN","IVMPREC8",97,0)
 ..I IVMXREF="PID13E",$D(TELECOM("NET")) D
"RTN","IVMPREC8",98,0)
 ...S IVMFLD=$P($G(TELECOM("NET")),$E(HLECH),4)
"RTN","IVMPREC8",99,0)
 ...S IVMFLD=$S($$CHKEMAIL(IVMFLD):IVMFLD,1:""),IVMADFLG=1
"RTN","IVMPREC8",100,0)
 .; - file addr fields and quit
"RTN","IVMPREC8",101,0)
 .I IVMADFLG D STORE^IVMPREC9 Q
"RTN","IVMPREC8",102,0)
 .;
"RTN","IVMPREC8",103,0)
 .;-otherwise, set IVMFLD to field rec'd from IVM for comparison with DHCP
"RTN","IVMPREC8",104,0)
 .;I (IVMXREF'="PID113N")&(IVMXREF'="PID114N")&($E(IVMXREF,1,5)'="PID13") S IVMFLD=$G(IVMPID(+IVMPIECE))
"RTN","IVMPREC8",105,0)
 .I $E(IVMXREF,1,5)'="PID13" S IVMFLD=$G(IVMPID(+IVMPIECE))
"RTN","IVMPREC8",106,0)
 .;
"RTN","IVMPREC8",107,0)
 .; -if HL7 date convert to FM date,set IVMFLD
"RTN","IVMPREC8",108,0)
 .I IVMXREF["PID07" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",109,0)
 .;
"RTN","IVMPREC8",110,0)
 .; - if HL7 code convert to VistA, set IVMFLD
"RTN","IVMPREC8",111,0)
 .I IVMXREF["PID16" D  ;Marital Status
"RTN","IVMPREC8",112,0)
 ..S IVMFLD=$S(IVMFLD="D":"DIVORCED",IVMFLD="M":"MARRIED",IVMFLD="W":"WIDOWED",IVMFLD="A":"SEPARATED",IVMFLD="S":"NEVER MARRIED",IVMFLD="U":"UNKNOWN")
"RTN","IVMPREC8",113,0)
 ..S IVMFLD=$O(^DIC(11,"B",IVMFLD,0))
"RTN","IVMPREC8",114,0)
 .;
"RTN","IVMPREC8",115,0)
 .I IVMXREF["PID17" S IVMFLD=$O(^DIC(13,"C",IVMFLD,0))  ;Religion
"RTN","IVMPREC8",116,0)
 .;
"RTN","IVMPREC8",117,0)
 .I IVMXREF["PID22" D  ;Ethnicity
"RTN","IVMPREC8",118,0)
 ..S IVMFLD=$$CODE2PTR^DGUTL4($P($G(IVMPID(22)),$E(HLECH),4),2,2)
"RTN","IVMPREC8",119,0)
 .;
"RTN","IVMPREC8",120,0)
 .I IVMXREF="PID10",'$G(DODSEG),$D(IVMRACE) D  Q
"RTN","IVMPREC8",121,0)
 ..N XVAL,IVMLST,DHCPLST
"RTN","IVMPREC8",122,0)
 ..S (XVAL,IVMLST,DHCPLST)=""
"RTN","IVMPREC8",123,0)
 ..F  S XVAL=$O(^DPT(DFN,.02,"B",XVAL)) Q:XVAL=""  S IVMLST=IVMLST_XVAL_U
"RTN","IVMPREC8",124,0)
 ..S XVAL="" F  S XVAL=$O(IVMRACE(2,XVAL)) Q:XVAL=""  S DHCPLST=DHCPLST_XVAL_U
"RTN","IVMPREC8",125,0)
 ..Q:IVMLST=DHCPLST
"RTN","IVMPREC8",126,0)
 ..F XVAL=1:1:($L(DHCPLST,U)-1) S IVMFLD=$P(DHCPLST,U,XVAL) D
"RTN","IVMPREC8",127,0)
 ...D STORE^IVMPREC9
"RTN","IVMPREC8",128,0)
 .;
"RTN","IVMPREC8",129,0)
 .; -call VADPT to return DHCP demographics
"RTN","IVMPREC8",130,0)
 .D DEM^VADPT,ADD^VADPT,OPD^VADPT
"RTN","IVMPREC8",131,0)
 .;
"RTN","IVMPREC8",132,0)
 .; -execute code on the 1 node and get DHCP field for compare
"RTN","IVMPREC8",133,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",134,0)
 .;
"RTN","IVMPREC8",135,0)
 .; - special logic for ph processing
"RTN","IVMPREC8",136,0)
 .; - if different, then store the actual value received, then quit
"RTN","IVMPREC8",137,0)
 .;
"RTN","IVMPREC8",138,0)
 .I IVMXREF="PID13",$D(TELECOM("PRN")),'$G(DODSEG) D  Q
"RTN","IVMPREC8",139,0)
 ..S IVMFLD=$P($G(TELECOM("PRN")),$E(HLECH))
"RTN","IVMPREC8",140,0)
 ..I IVMFLD]"" D
"RTN","IVMPREC8",141,0)
 ...K UPPHN
"RTN","IVMPREC8",142,0)
 ...S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
"RTN","IVMPREC8",143,0)
 ...I COMPPH1'=COMPPH2 D STORE^IVMPREC9 S UPPHN=1
"RTN","IVMPREC8",144,0)
 .;
"RTN","IVMPREC8",145,0)
 .; -if field from IVM does not equal DHCP-store for uploading
"RTN","IVMPREC8",146,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",147,0)
 Q
"RTN","IVMPREC8",148,0)
 ;
"RTN","IVMPREC8",149,0)
ZPD ; - compare ZPD fields with DHCP fields
"RTN","IVMPREC8",150,0)
 N STFLG
"RTN","IVMPREC8",151,0)
 S STFLG=0
"RTN","IVMPREC8",152,0)
 S IVMPIECE=$E(IVMXREF,4,5)
"RTN","IVMPREC8",153,0)
 I IVMXREF="ZPD09"!(IVMXREF="ZPD31")!(IVMXREF="ZPD32") Q:$$DODCK(DFN)
"RTN","IVMPREC8",154,0)
 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
"RTN","IVMPREC8",155,0)
 .;
"RTN","IVMPREC8",156,0)
 .; - set var to HL7 field
"RTN","IVMPREC8",157,0)
 .S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
"RTN","IVMPREC8",158,0)
 .;
"RTN","IVMPREC8",159,0)
 .; - if HL7 name format convert to FM
"RTN","IVMPREC8",160,0)
 .I (IVMXREF["ZPD06")!(IVMXREF["ZPD07") S IVMFLD=$$FMNAME^HLFNC(IVMFLD)
"RTN","IVMPREC8",161,0)
 .;
"RTN","IVMPREC8",162,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",163,0)
 .I IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",164,0)
 .;
"RTN","IVMPREC8",165,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",166,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",167,0)
 .;
"RTN","IVMPREC8",168,0)
 .; - if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",169,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) S STFLG=1 D STORE^IVMPREC9 Q
"RTN","IVMPREC8",170,0)
 .I $P(IVMSEG,"^",IVMPIECE)'="""""" D
"RTN","IVMPREC8",171,0)
 ..I IVMXREF["ZPD09" D STORE^IVMPREC9
"RTN","IVMPREC8",172,0)
 ..;I IVMXREF["ZPD09"!(IVMXREF["ZPD31")!(IVMXREF["ZPD32") D STORE^IVMPREC9
"RTN","IVMPREC8",173,0)
 I IVMXREF["ZPD08",STFLG,$$AUTORINC^IVMPREC9(DFN) Q
"RTN","IVMPREC8",174,0)
 I IVMXREF["ZPD32",$$AUTODOD^IVMLDEMD(DFN)
"RTN","IVMPREC8",175,0)
 Q
"RTN","IVMPREC8",176,0)
 ;
"RTN","IVMPREC8",177,0)
 ;
"RTN","IVMPREC8",178,0)
DODCK(DFN) ;this will check if Date of Death information needs to be uploaded or not.
"RTN","IVMPREC8",179,0)
 ;2 requirements are:
"RTN","IVMPREC8",180,0)
 ;  1. When the DOD is received from ESR with a Source of Death Notification equal to "Death Certificate on file and the
"RTN","IVMPREC8",181,0)
 ;     VistA DOD is null or empty then VistA will upload the Date of Death from ESR
"RTN","IVMPREC8",182,0)
 ;  2. When DOD is Received from ESR and VistA DOD is already populated then Vista will ignore the DOD from ESR and VistA
"RTN","IVMPREC8",183,0)
 ;     will not create an entry in the IVM demographic upload option.
"RTN","IVMPREC8",184,0)
 ;
"RTN","IVMPREC8",185,0)
 ; Inputs: DFN for ^DPT
"RTN","IVMPREC8",186,0)
 ;         IVMXREF (must be ZPD09, ZPD31 and ZPD32)
"RTN","IVMPREC8",187,0)
 ;         IVMSEG (the ZPD data)
"RTN","IVMPREC8",188,0)
 ;         IVMFLD (the field number in ^DPT(DFN)
"RTN","IVMPREC8",189,0)
 ;         IVMPIECE (the piece number of IVMSEG)
"RTN","IVMPREC8",190,0)
 ;         IVMDHCP (the data from ^DPT(DFN)
"RTN","IVMPREC8",191,0)
 ;
"RTN","IVMPREC8",192,0)
 N DODARRAY,QUIT
"RTN","IVMPREC8",193,0)
 ;
"RTN","IVMPREC8",194,0)
 S (CKDEL,QUIT)=0
"RTN","IVMPREC8",195,0)
 ;
"RTN","IVMPREC8",196,0)
 I $P(IVMSEG,"^",9)="""""" Q 0
"RTN","IVMPREC8",197,0)
 D GETS^DIQ(2,DFN,".351:.355","","DODARRAY")
"RTN","IVMPREC8",198,0)
 S DOD=DODARRAY(2,DFN_",",.351)
"RTN","IVMPREC8",199,0)
 I DOD'="" Q 1
"RTN","IVMPREC8",200,0)
 I $P(IVMSEG,"^",31)=3,DOD="" S QUIT=0    ;Death Certificate not on File
"RTN","IVMPREC8",201,0)
 I $P(IVMSEG,"^",31)=3,DOD'="" S QUIT=1
"RTN","IVMPREC8",202,0)
 ;
"RTN","IVMPREC8",203,0)
 Q QUIT ;
"RTN","IVMPREC8",204,0)
 ;
"RTN","IVMPREC8",205,0)
ZTA ; -compare ZTA fields with DHCP fields
"RTN","IVMPREC8",206,0)
 N COMPPH1,COMPPH2,COUNTRY
"RTN","IVMPREC8",207,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",208,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",209,0)
 .;
"RTN","IVMPREC8",210,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",211,0)
 .S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",212,0)
 .;
"RTN","IVMPREC8",213,0)
 .; - ZTA05 as the ZTA addr field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",214,0)
 .I IVMXREF["ZTA05" D
"RTN","IVMPREC8",215,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)) Q:IVMADDR=""
"RTN","IVMPREC8",216,0)
 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)
"RTN","IVMPREC8",217,0)
 ..S FORADDR=$S(COUNTRY="USA":0,1:1)
"RTN","IVMPREC8",218,0)
 ..; - get piece of address field, and set IVMFLD
"RTN","IVMPREC8",219,0)
 ..S IVMPIECE=$E(IVMPIECE,3,4)
"RTN","IVMPREC8",220,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",221,0)
 ..I (IVMPIECE=2)!(IVMPIECE=8) S:IVMFLD="" IVMFLD="@"
"RTN","IVMPREC8",222,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",223,0)
 ..I (IVMPIECE=4)!(IVMPIECE=5)!(IVMPIECE=9) S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""
"RTN","IVMPREC8",224,0)
 ..I IVMPIECE=4 S (IVMTSTPT,IVMFLD)=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",225,0)
 ..I IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",226,0)
 ..I IVMPIECE="4F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;PROVINCE
"RTN","IVMPREC8",227,0)
 ..I IVMPIECE="5F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;POSTAL CODE
"RTN","IVMPREC8",228,0)
 ..I IVMPIECE=6 S IVMFLD=$$CNTRCONV(COUNTRY)         ;COUNTRY
"RTN","IVMPREC8",229,0)
 ..I IVMPIECE=9 S IVMFLD=+$O(^DIC(5,+IVMTSTPT,1,"C",IVMFLD,0))  ;COUNTY
"RTN","IVMPREC8",230,0)
 .Q:IVMFLD=""
"RTN","IVMPREC8",231,0)
 .;
"RTN","IVMPREC8",232,0)
 .; - if HL7 data convert to Y/N val
"RTN","IVMPREC8",233,0)
 .I IVMXREF["ZTA02" S IVMFLD=$S(IVMFLD=0:"N",IVMFLD=1:"Y",1:"")
"RTN","IVMPREC8",234,0)
 .;
"RTN","IVMPREC8",235,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",236,0)
 .I (IVMXREF["ZTA03")!(IVMXREF["ZTA04")!(IVMXREF["ZTA08") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",237,0)
 .;
"RTN","IVMPREC8",238,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",239,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",240,0)
 .;
"RTN","IVMPREC8",241,0)
 .; -special logic for phone
"RTN","IVMPREC8",242,0)
 .; -if different, then store the actual value received, then quit
"RTN","IVMPREC8",243,0)
 .I IVMXREF["ZTA07" D  Q
"RTN","IVMPREC8",244,0)
 ..S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
"RTN","IVMPREC8",245,0)
 ..I COMPPH1'=COMPPH2 D STORE^IVMPREC9
"RTN","IVMPREC8",246,0)
 .;
"RTN","IVMPREC8",247,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",248,0)
 .;
"RTN","IVMPREC8",249,0)
 .I IVMXREF["ZTA08" D
"RTN","IVMPREC8",250,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("TA")=1
"RTN","IVMPREC8",251,0)
 Q
"RTN","IVMPREC8",252,0)
 ;
"RTN","IVMPREC8",253,0)
ZAV ; compare ZAV with DHCP
"RTN","IVMPREC8",254,0)
 N IVMATYP
"RTN","IVMPREC8",255,0)
 S IVMFLD=""
"RTN","IVMPREC8",256,0)
 S IVMATYP=""
"RTN","IVMPREC8",257,0)
 S IVMATYP=$P(IVMSEG,HLFS,2)
"RTN","IVMPREC8",258,0)
 S IVMFLD=$P(IVMSEG,HLFS,3)
"RTN","IVMPREC8",259,0)
 I IVMXREF=$S(IVMATYP="P":"ZAV03",IVMATYP="CNF":"ZAV02",IVMATYP="R":"ZAV01",IVMATYP="C":"ZAV04",1:"") D 
"RTN","IVMPREC8",260,0)
 .; Execute 1 node and get DHCP field
"RTN","IVMPREC8",261,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",262,0)
 .; field from IVM is not equal DHCP-store
"RTN","IVMPREC8",263,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",264,0)
 ;
"RTN","IVMPREC8",265,0)
 Q
"RTN","IVMPREC8",266,0)
 ;
"RTN","IVMPREC8",267,0)
ZGD ; - compare ZGD with DHCP
"RTN","IVMPREC8",268,0)
 S IVMADFLG=0
"RTN","IVMPREC8",269,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",270,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",271,0)
 .;
"RTN","IVMPREC8",272,0)
 .; - set var IVMFLD to incoming HL7
"RTN","IVMPREC8",273,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
"RTN","IVMPREC8",274,0)
 .;
"RTN","IVMPREC8",275,0)
 .; - ZGD06 as the ZGD address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",276,0)
 .I IVMXREF["ZGD06" D
"RTN","IVMPREC8",277,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",278,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
"RTN","IVMPREC8",279,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",280,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",281,0)
 .;
"RTN","IVMPREC8",282,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",283,0)
 .I IVMXREF["ZGD08" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",284,0)
 .;
"RTN","IVMPREC8",285,0)
 .; - execute code on the 1 node and get DHCP
"RTN","IVMPREC8",286,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",287,0)
 .;
"RTN","IVMPREC8",288,0)
 .; if field from IVM does not equal DHCP-store for uploading
"RTN","IVMPREC8",289,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",290,0)
 Q
"RTN","IVMPREC8",291,0)
 ;
"RTN","IVMPREC8",292,0)
ZCT ; - compare ZCT with DHCP
"RTN","IVMPREC8",293,0)
 N ZCTTYP
"RTN","IVMPREC8",294,0)
 S IVMADFLG=0
"RTN","IVMPREC8",295,0)
 S IVMPIECE=$E(IVMXREF,4,8)
"RTN","IVMPREC8",296,0)
 S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC8",297,0)
 S ZCTTYP=$E(IVMPIECE,$L(IVMPIECE)-1,$L(IVMPIECE))
"RTN","IVMPREC8",298,0)
 Q:$P(IVMSEG,HLFS,2)'=$S(ZCTTYP="K1":1,ZCTTYP="K2":2,ZCTTYP="E1":3,ZCTTYP="E2":4,ZCTTYP="D1":5,1:"")
"RTN","IVMPREC8",299,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",300,0)
 .;
"RTN","IVMPREC8",301,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",302,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",303,0)
 .;
"RTN","IVMPREC8",304,0)
 .; - if HL7 name format convert to FM
"RTN","IVMPREC8",305,0)
 .I IVMXREF["ZCT03" S IVMFLD=$$FMNAME^HLFNC(IVMFLD)
"RTN","IVMPREC8",306,0)
 .;
"RTN","IVMPREC8",307,0)
 .; - ZCT05 as the ZCT address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",308,0)
 .I IVMXREF["ZCT05" D
"RTN","IVMPREC8",309,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",310,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
"RTN","IVMPREC8",311,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",312,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",313,0)
 .;
"RTN","IVMPREC8",314,0)
 .I IVMADFLG D STORE^IVMPREC9 Q
"RTN","IVMPREC8",315,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",316,0)
 .I IVMXREF["ZCT10" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",317,0)
 .;
"RTN","IVMPREC8",318,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",319,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",320,0)
 .;
"RTN","IVMPREC8",321,0)
 .; if field from IVM does not equal DHCP-store for upload
"RTN","IVMPREC8",322,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",323,0)
 .;
"RTN","IVMPREC8",324,0)
 .I IVMXREF["ZCT10" D
"RTN","IVMPREC8",325,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG(ZCTTYP)=1
"RTN","IVMPREC8",326,0)
 Q
"RTN","IVMPREC8",327,0)
 ;
"RTN","IVMPREC8",328,0)
ZEM ; - compare ZEM fields with DHCP
"RTN","IVMPREC8",329,0)
 S IVMADFLG=0
"RTN","IVMPREC8",330,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",331,0)
 S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC8",332,0)
 Q:$P(IVMSEG,HLFS,2)'=$S($E(IVMXREF,$L(IVMXREF))="S":2,1:1)
"RTN","IVMPREC8",333,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",334,0)
 .;
"RTN","IVMPREC8",335,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",336,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",337,0)
 .;
"RTN","IVMPREC8",338,0)
 .; - ZEM06 as the ZEM addr containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",339,0)
 .I IVMXREF["ZEM06" D
"RTN","IVMPREC8",340,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",341,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)    ;,IVMADFLG=1
"RTN","IVMPREC8",342,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",343,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",344,0)
 .;
"RTN","IVMPREC8",345,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",346,0)
 .I IVMXREF["ZEM09" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",347,0)
 .;
"RTN","IVMPREC8",348,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",349,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",350,0)
 .;
"RTN","IVMPREC8",351,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",352,0)
 .I $E(IVMXREF,1,6)="ZEM062",IVMFLD'=IVMDHCP S ZEMADRUP(IVMXREF)=1 D STORE^IVMPREC9 Q
"RTN","IVMPREC8",353,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",354,0)
 Q
"RTN","IVMPREC8",355,0)
 ;
"RTN","IVMPREC8",356,0)
RF1 ; - compare RF1 segment fields with DHCP
"RTN","IVMPREC8",357,0)
 S IVMPIECE=$E(IVMXREF,4),IVMADFLG=1,RF1TYPE=$P(IVMSEG,HLFS,3)
"RTN","IVMPREC8",358,0)
 ;Delete the communication data (Email, Cell and Pager) if it is not received in Z05.
"RTN","IVMPREC8",359,0)
 ;Hence, remove it from EPCDEL if Data exist in Z05. Comm. fields contained in EPCDEL will be deleted after updating all incoming data.
"RTN","IVMPREC8",360,0)
 ;IVM*2.0*164-Don't Kill if PHH
"RTN","IVMPREC8",361,0)
 I RF1TYPE'="PHH" K EPCDEL(RF1TYPE)
"RTN","IVMPREC8",362,0)
 ;K EPCDEL(RF1TYPE)
"RTN","IVMPREC8",363,0)
 ;if RF1 field is SEQ6, then parse subcomponents
"RTN","IVMPREC8",364,0)
 I RF1TYPE="SAD",((IVMXREF="RF161")!(IVMXREF="RF162")!(IVMXREF="RF171")) D RF1PROC
"RTN","IVMPREC8",365,0)
 ;IVM*2.0*164-Uncomment Conf and Add Res
"RTN","IVMPREC8",366,0)
 I RF1TYPE="CAD",((IVMXREF="RF161CA")!(IVMXREF="RF162CA")!(IVMXREF="RF171CA")) D RF1PROC
"RTN","IVMPREC8",367,0)
 I RF1TYPE="RAD",((IVMXREF="RF161RA")!(IVMXREF="RF162RA")!(IVMXREF="RF171RA")) D RF1PROC
"RTN","IVMPREC8",368,0)
 ;
"RTN","IVMPREC8",369,0)
 I RF1TYPE="CPH",((IVMXREF="RF161C")!(IVMXREF="RF162C")!(IVMXREF="RF171C")) D RF1PROC
"RTN","IVMPREC8",370,0)
 I RF1TYPE="PNO",((IVMXREF="RF161B")!(IVMXREF="RF162B")!(IVMXREF="RF171B")) D RF1PROC
"RTN","IVMPREC8",371,0)
 I RF1TYPE="EAD",((IVMXREF="RF161E")!(IVMXREF="RF162E")!(IVMXREF="RF171E")) D RF1PROC
"RTN","IVMPREC8",372,0)
 I RF1TYPE="PHH",((IVMXREF="RF161P")!(IVMXREF="RF162P")!(IVMXREF="RF171P")) D RF1PROC     ;Added for IVM*2*152
"RTN","IVMPREC8",373,0)
 ;IVM*2.0*164-LAST RF1 change
"RTN","IVMPREC8",374,0)
 ;I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171P" D
"RTN","IVMPREC8",375,0)
 I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171RA" D  ;Last RF1
"RTN","IVMPREC8",376,0)
 . I $$AUTOEPC^IVMPREC9(DFN,.UPDEPC)
"RTN","IVMPREC8",377,0)
 . N NOUPDT,NOPHUP S (NOUPDT,NOPHUP)=0   ;Added for IVM*2*152
"RTN","IVMPREC8",378,0)
 . I 'UPDEPC("SAD") S NOUPDT=1
"RTN","IVMPREC8",379,0)
 . ;Set the NOPHUP flag = 1 if Home Phone Change Dt/Tm not more recent, or
"RTN","IVMPREC8",380,0)
 . ;if Home Phone Change Dt/Tm more recent, but phone # the same
"RTN","IVMPREC8",381,0)
 . ;Added for IVM*2*152
"RTN","IVMPREC8",382,0)
 . ;IVM*2.0*167-Make Home phone auto-upload
"RTN","IVMPREC8",383,0)
 . ;Always keep NOPHUP = 0 so Home phone data is not handled here    
"RTN","IVMPREC8",384,0)
 . ;I 'UPDEPC("PHH") S NOPHUP=1
"RTN","IVMPREC8",385,0)
 . ;I UPDEPC("PHH"),'$G(UPPHN) S NOPHUP=1
"RTN","IVMPREC8",386,0)
 . K UPPHN
"RTN","IVMPREC8",387,0)
 . I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT,NOPHUP)
"RTN","IVMPREC8",388,0)
 Q
"RTN","IVMPREC8",389,0)
 ;
"RTN","IVMPREC8",390,0)
RF1PROC ;
"RTN","IVMPREC8",391,0)
 N IVMEPC
"RTN","IVMPREC8",392,0)
 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
"RTN","IVMPREC8",393,0)
 .;if RF1 field is SEQ6, then parse subcomponents
"RTN","IVMPREC8",394,0)
 .I IVMXREF["RF16" D  Q
"RTN","IVMPREC8",395,0)
 ..;- get data containing 4 pieces seperated by HLECH (~)
"RTN","IVMPREC8",396,0)
 ..S IVMRFDAT=$P(IVMSEG,HLFS,6)
"RTN","IVMPREC8",397,0)
 ..S IVMPIECE=$E(IVMXREF,5),IVMFLD=$P(IVMRFDAT,"~",IVMPIECE)
"RTN","IVMPREC8",398,0)
 ..;KUM-164-SET IVMEPC TO NONBLANK 
"RTN","IVMPREC8",399,0)
 ..;S IVMEPC=$E(IVMXREF,6)
"RTN","IVMPREC8",400,0)
 ..S IVMEPC=""
"RTN","IVMPREC8",401,0)
 ..I (IVMXREF="RF162E")!(IVMXREF="RF162C")!(IVMXREF="RF162B")!(IVMXREF="RF162P") S IVMEPC="2"
"RTN","IVMPREC8",402,0)
 ..;Convert Change Source for Address, Email, Cell and Pager
"RTN","IVMPREC8",403,0)
 ..I IVMPIECE=2 S IVMFLD=$S(IVMEPC'="":$$EPCSRCC(IVMFLD),1:$$ADDRCNV(IVMFLD))
"RTN","IVMPREC8",404,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",405,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",406,0)
 .I IVMXREF["RF17" D  Q
"RTN","IVMPREC8",407,0)
 ..;get address/telecomm change date/tm field
"RTN","IVMPREC8",408,0)
 ..S IVMFLD=$$FMDATE^HLFNC($P(IVMSEG,HLFS,7))
"RTN","IVMPREC8",409,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",410,0)
 ..;
"RTN","IVMPREC8",411,0)
 ..;IVM*2*171 - If RF1 type is PHH,home phone is null in PID (IVMPHDFG)
"RTN","IVMPREC8",412,0)
 ..;and RESIDENCE NUMBER CHANGE DT/TM in Patient record exists then SET EPCDEL(PHH) for phone number 
"RTN","IVMPREC8",413,0)
 ..;deletion IF incoming number change dt/tm is greater than the change dt/tm in Patient record
"RTN","IVMPREC8",414,0)
 ..;Check if PID13 home ph is null
"RTN","IVMPREC8",415,0)
 ..S:$P($G(TELECOM("PRN")),"~",1)="" IVMPHDFG=1
"RTN","IVMPREC8",416,0)
 ..I RF1TYPE="PHH",+IVMPHDFG,+$$GET1^DIQ(2,DFN_",",.1321,"I") D
"RTN","IVMPREC8",417,0)
 ...S:+$$GET1^DIQ(2,DFN_",",.1321,"I")<IVMFLD EPCDEL("PHH")=".131^.1321^.1322^.1323"
"RTN","IVMPREC8",418,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",419,0)
 ..;
"RTN","IVMPREC8",420,0)
 ..;164-Uncomment Conf and Add Res
"RTN","IVMPREC8",421,0)
 ..I RF1TYPE="CAD",$P($G(ADDRESS("CA")),HLFS)]"" D  Q
"RTN","IVMPREC8",422,0)
 ...; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",423,0)
 ...S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",424,0)
 ...I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("CA")=1
"RTN","IVMPREC8",425,0)
 ..;
"RTN","IVMPREC8",426,0)
 ..I RF1TYPE="RAD",$P($G(ADDRESS("R")),HLFS)]"" D  Q
"RTN","IVMPREC8",427,0)
 ...S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",428,0)
 ...I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("RA")=1
"RTN","IVMPREC8",429,0)
 ..;
"RTN","IVMPREC8",430,0)
 ..; End - IVM*2.0*164
"RTN","IVMPREC8",431,0)
 ..; check for auto-upload
"RTN","IVMPREC8",432,0)
 ..S IVMDHCP=$S(RF1TYPE="SAD":$P($G(^DPT(DFN,.11)),HLFS,13),RF1TYPE="CPH":$P($G(^DPT(DFN,.13)),HLFS,9),RF1TYPE="PNO":$P($G(^DPT(DFN,.13)),HLFS,12),RF1TYPE="EAD":$P($G(^DPT(DFN,.13)),HLFS,6),1:"")
"RTN","IVMPREC8",433,0)
 ..I IVMDHCP="" S IVMDHCP=$S(RF1TYPE="PHH":$P($G(^DPT(DFN,.132)),HLFS,1),RF1TYPE="RAD":$P($G(^DPT(DFN,.115)),HLFS,11),1:"")     ;Added for IVM*2*152
"RTN","IVMPREC8",434,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) D
"RTN","IVMPREC8",435,0)
 ...S UPDEPC(RF1TYPE)=$G(EPCFARY(RF1TYPE))
"RTN","IVMPREC8",436,0)
 ...I RF1TYPE="SAD" S UPDEPC("SAD")=1
"RTN","IVMPREC8",437,0)
 ...; 167-Make Home phone rec auto-upload to Patient
"RTN","IVMPREC8",438,0)
 ...; Keep UPDEPC("PHH") value as Home phone record IENs of #301.92
"RTN","IVMPREC8",439,0)
 ...;I RF1TYPE="PHH" S UPDEPC("PHH")=1 ; Added for IVM*2*152
"RTN","IVMPREC8",440,0)
 Q
"RTN","IVMPREC8",441,0)
ADDRCNV(ADDRSRC) ;convert Addr Source from HL7 to DHCP format
"RTN","IVMPREC8",442,0)
 ;
"RTN","IVMPREC8",443,0)
 Q:$G(ADDRSRC)']"" ""
"RTN","IVMPREC8",444,0)
 Q:ADDRSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",445,0)
 Q:ADDRSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",446,0)
 Q:ADDRSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",447,0)
 Q:ADDRSRC="USNCOA" "NCOA"
"RTN","IVMPREC8",448,0)
 Q:ADDRSRC="USVABVA" "BVA"
"RTN","IVMPREC8",449,0)
 Q:ADDRSRC="USVAINS" "VAINS"
"RTN","IVMPREC8",450,0)
 Q:ADDRSRC="USPS" "USPS"
"RTN","IVMPREC8",451,0)
 Q:ADDRSRC="LACS" "LACS"
"RTN","IVMPREC8",452,0)
 Q:ADDRSRC="USVOA" "VOA"
"RTN","IVMPREC8",453,0)
 Q:ADDRSRC="VET360" "VET360"
"RTN","IVMPREC8",454,0)
 Q ""
"RTN","IVMPREC8",455,0)
EPCSRCC(EPCSRC) ;Convert Email, Cell, Pager Change Source from HL7 to DHCP
"RTN","IVMPREC8",456,0)
 ;
"RTN","IVMPREC8",457,0)
 Q:$G(EPCSRC)']"" ""
"RTN","IVMPREC8",458,0)
 Q:EPCSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",459,0)
 Q:EPCSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",460,0)
 Q:EPCSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",461,0)
 Q:EPCSRC="USVOA" "VOA"
"RTN","IVMPREC8",462,0)
 Q:EPCSRC="VET360" "VET360"
"RTN","IVMPREC8",463,0)
 Q ""
"RTN","IVMPREC8",464,0)
BAICONV(BAISRC) ;Convert Bad addr source from HL7 to DHCP format
"RTN","IVMPREC8",465,0)
 Q:$G(BAISRC)']"" ""
"RTN","IVMPREC8",466,0)
 Q:BAISRC="VAB1" 1
"RTN","IVMPREC8",467,0)
 Q:BAISRC="VAB2" 2
"RTN","IVMPREC8",468,0)
 Q:BAISRC="VAB3" 3
"RTN","IVMPREC8",469,0)
 Q:BAISRC="VAB4" 4
"RTN","IVMPREC8",470,0)
 Q ""
"RTN","IVMPREC8",471,0)
CONVPH(PH) ;remove special chars/spaces from Ph
"RTN","IVMPREC8",472,0)
 ;*168 Check format, quit if OK else strip and return if not 10 num
"RTN","IVMPREC8",473,0)
 ;Format if 10 numeric.
"RTN","IVMPREC8",474,0)
 Q:PH?1"(".3N.1")".3N.1"-".4N PH
"RTN","IVMPREC8",475,0)
 S PH=$TR(PH," )(/#\-","")
"RTN","IVMPREC8",476,0)
 Q:PH'?10N PH
"RTN","IVMPREC8",477,0)
 Q "("_$E(PH,1,3)_")"_$E(PH,4,6)_"-"_$E(PH,7,10)
"RTN","IVMPREC8",478,0)
 ;
"RTN","IVMPREC8",479,0)
CNTRCONV(COUNTRY) ;Check if valid country
"RTN","IVMPREC8",480,0)
 I COUNTRY="" Q 0
"RTN","IVMPREC8",481,0)
 Q $O(^HL(779.004,"B",COUNTRY,""))
"RTN","IVMPREC8",482,0)
CHKEMAIL(EMAIL) ;Check for Valid Email
"RTN","IVMPREC8",483,0)
 I $G(EMAIL)="" Q 0
"RTN","IVMPREC8",484,0)
 I '(EMAIL?1.E1"@"1.E1"."1.E) Q 0
"RTN","IVMPREC8",485,0)
 Q 1
"RTN","IVMPRECA")
0^3^B93390034
"RTN","IVMPRECA",1,0)
IVMPRECA ;ALB/KCL,BRM,PJR,RGL,CKN,TDM,KUM - DEMOGRAPHICS MESSAGE CONSISTENCY CHECK ;1/06/18 11:16AM
"RTN","IVMPRECA",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,34,58,56,115,144,121,151,145,164**;21-OCT-94;Build 98
"RTN","IVMPRECA",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IVMPRECA",4,0)
 ;
"RTN","IVMPRECA",5,0)
 ; This routine will perform data validation checks on uploadable
"RTN","IVMPRECA",6,0)
 ; demographic fields received from the IVM Center to ensure they
"RTN","IVMPRECA",7,0)
 ; are accurate prior to their upload into DHCP.
"RTN","IVMPRECA",8,0)
 ;
"RTN","IVMPRECA",9,0)
 ;
"RTN","IVMPRECA",10,0)
 ; Called from routine IVMPREC6 before uploadable demographic fields
"RTN","IVMPRECA",11,0)
 ; are stored in DHCP.
"RTN","IVMPRECA",12,0)
 ;
"RTN","IVMPRECA",13,0)
 ;
"RTN","IVMPRECA",14,0)
EN ; - Entry point to create temp array and perform msg consistency checks
"RTN","IVMPRECA",15,0)
 ;
"RTN","IVMPRECA",16,0)
 N DFN,IVMCNTY,IVMCR,IVMEG,IVMFLAG,IVMFLD,IVMNUM,IVMSTR,IVMSTPTR,X,IVMSEG
"RTN","IVMPRECA",17,0)
 N COMP,CNTR,NOPID,ADDRTYPE,ADDSEQ,TELESEQ,COMMTYPE,TCFLG,TMPARRY,PID3ARRY,CNTR2
"RTN","IVMPRECA",18,0)
 N MULTDONE
"RTN","IVMPRECA",19,0)
 K IVMRACE
"RTN","IVMPRECA",20,0)
 S IVMNUM=IVMDA ; 'current' line in ^HL(772,"IN",...
"RTN","IVMPRECA",21,0)
 S DODSEG=0 ;Initialize flag for DOD information
"RTN","IVMPRECA",22,0)
 S GUARSEG=0 ;Initialize flag for Guardian information
"RTN","IVMPRECA",23,0)
 ;
"RTN","IVMPRECA",24,0)
 ; - check the format of the HL7 demographic message
"RTN","IVMPRECA",25,0)
 D NEXT I $E(IVMSTR,1,3)'="PID" S HLERR="Missing PID segment" G ENQ
"RTN","IVMPRECA",26,0)
 S CNTR=1,NOPID=0,PIDSTR(CNTR)=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",27,0)
 ;Handle wrapped PID segment
"RTN","IVMPRECA",28,0)
 F I=1:1 D  Q:NOPID
"RTN","IVMPRECA",29,0)
 . D NEXT I $E(IVMSTR,1,4)="ZPD^" S NOPID=1 Q
"RTN","IVMPRECA",30,0)
 . S CNTR=CNTR+1,PIDSTR(CNTR)=IVMSTR
"RTN","IVMPRECA",31,0)
 D BLDPID^IVMPREC6(.PIDSTR,.IVMPID)  ;Create IVMPID subscript by seq #
"RTN","IVMPRECA",32,0)
 ;convert "" to null for PID segment
"RTN","IVMPRECA",33,0)
 S CNTR="" F  S CNTR=$O(IVMPID(CNTR)) Q:CNTR=""  D
"RTN","IVMPRECA",34,0)
 . I $O(IVMPID(CNTR,"")) D  Q
"RTN","IVMPRECA",35,0)
 . . S CNTR2="" F  S CNTR2=$O(IVMPID(CNTR,CNTR2)) Q:CNTR2=""  D
"RTN","IVMPRECA",36,0)
 . . . S IVMPID(CNTR,CNTR2)=$$CLEARF(IVMPID(CNTR,CNTR2),$E(HLECH))
"RTN","IVMPRECA",37,0)
 . I CNTR=11 S IVMPID(CNTR)=$$CLEARF(IVMPID(CNTR),$E(HLECH)) Q
"RTN","IVMPRECA",38,0)
 . I IVMPID(CNTR)=HLQ S IVMPID(CNTR)=""
"RTN","IVMPRECA",39,0)
 I $E(IVMSTR,1,3)'="ZPD" S HLERR="Missing ZPD segment" G ENQ
"RTN","IVMPRECA",40,0)
 S IVMSTR("ZPD")=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",41,0)
 I $P(IVMSTR("ZPD"),HLFS,8)'="" S GUARSEG=1
"RTN","IVMPRECA",42,0)
 I $P(IVMSTR("ZPD"),HLFS,9)'="" S DODSEG=1
"RTN","IVMPRECA",43,0)
 D NEXT I $E(IVMSTR,1,3)="ZEL" S HLERR="ZEL segment should not be sent in Z05 message" G ENQ
"RTN","IVMPRECA",44,0)
 ;I $E(IVMSTR,1,3)="ZTA" D NEXT  ;Skip ZTA -coming later
"RTN","IVMPRECA",45,0)
 I $E(IVMSTR,1,3)'="ZTA" S HLERR="Missing ZTA segment" G ENQ
"RTN","IVMPRECA",46,0)
 S IVMSTR("ZTA")=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",47,0)
 ; IVM*2.0*164 - ADD LOGIC FOR ZAV SEGMENTS
"RTN","IVMPRECA",48,0)
 D NEXT
"RTN","IVMPRECA",49,0)
 S IVMSEG="" F  S IVMSEG=$E(IVMSTR,1,3) Q:IVMSEG="ZGD"  D
"RTN","IVMPRECA",50,0)
 . D NEXT
"RTN","IVMPRECA",51,0)
 ; 
"RTN","IVMPRECA",52,0)
 ; D NEXT
"RTN","IVMPRECA",53,0)
 I $E(IVMSTR,1,3)'="ZGD" S HLERR="Missing ZGD segment" G ENQ
"RTN","IVMPRECA",54,0)
 S IVMSTR("ZGD")=$P(IVMSTR,HLFS,2,999)
"RTN","IVMPRECA",55,0)
 ;
"RTN","IVMPRECA",56,0)
 ; - perform field validation checks for PID segment
"RTN","IVMPRECA",57,0)
 M TMPARRY(3)=IVMPID(3) D PARSPID3^IVMUFNC(.TMPARRY,.PID3ARY)
"RTN","IVMPRECA",58,0)
 S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
"RTN","IVMPRECA",59,0)
 K TMPARRY,PID3ARY
"RTN","IVMPRECA",60,0)
 I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) S HLERR=ERRMSG G ENQ
"RTN","IVMPRECA",61,0)
 S IVMDFN=DFN  ;Store DFN in temp variable to use later
"RTN","IVMPRECA",62,0)
 ;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVM SSN with DHCP SSN" G ENQ
"RTN","IVMPRECA",63,0)
 ;
"RTN","IVMPRECA",64,0)
 S X=IVMPID(7) I X]"",($$FMDATE^HLFNC(X)>DT) S HLERR="Date of Birth greater than current date" G ENQ
"RTN","IVMPRECA",65,0)
 ;
"RTN","IVMPRECA",66,0)
 S X=IVMPID(8) I X]"",X'="M",X'="F" S HLERR="Invalid code sent for Patient sex" G ENQ
"RTN","IVMPRECA",67,0)
 ;
"RTN","IVMPRECA",68,0)
 ; Marital Status
"RTN","IVMPRECA",69,0)
 S X=$G(IVMPID(16)) I (X'="")&(X'="D")&(X'="M")&(X'="W")&(X'="U")&(X'="A")&(X'="S") D  G ENQ
"RTN","IVMPRECA",70,0)
 . S HLERR="Invalid code sent for Patient Marital Status" G ENQ
"RTN","IVMPRECA",71,0)
 ; Religion
"RTN","IVMPRECA",72,0)
 S X=$G(IVMPID(17)) I X'="" S X=$O(^DIC(13,"C",+X,"")) I X="" D  G ENQ
"RTN","IVMPRECA",73,0)
 . S HLERR="Invalid code sent for Patient Religion"
"RTN","IVMPRECA",74,0)
 ; Ethnicity
"RTN","IVMPRECA",75,0)
 S X=$P($G(IVMPID(22)),$E(HLECH),4) I X]"" S X=$O(^DIC(10.2,"AHL7",X,"")) I X="" D  G ENQ
"RTN","IVMPRECA",76,0)
 . S HLERR="Invalid code sent for Patient Ethnicity" G ENQ
"RTN","IVMPRECA",77,0)
 ;
"RTN","IVMPRECA",78,0)
 ; - if address - perform validation checks on addr fields
"RTN","IVMPRECA",79,0)
 ;Get all address from seq. 11 of PID segment
"RTN","IVMPRECA",80,0)
 I 'DODSEG,'GUARSEG D
"RTN","IVMPRECA",81,0)
 . D PID11 Q:$D(HLERR)
"RTN","IVMPRECA",82,0)
 . D PID10 Q:$D(HLERR)
"RTN","IVMPRECA",83,0)
 . D PID13
"RTN","IVMPRECA",84,0)
 G ENQ:$D(HLERR)
"RTN","IVMPRECA",85,0)
 ;
"RTN","IVMPRECA",86,0)
 ; - perform field validation check for ZPD and ZGD segment
"RTN","IVMPRECA",87,0)
 ; - I X]"" was changed to I X below for IVM*2*56
"RTN","IVMPRECA",88,0)
 S X=$P(IVMSTR("ZPD"),HLFS,9) I X,($$FMDATE^HLFNC(X)<$P($G(^DPT(+DFN,0)),"^",3))!($$FMDATE^HLFNC(X)>$$NOW^XLFDT) S HLERR="Invalid date of death" G ENQ
"RTN","IVMPRECA",89,0)
 ; IVM*2*121 - Added new check for ZGD
"RTN","IVMPRECA",90,0)
 N ZGD3
"RTN","IVMPRECA",91,0)
 S ZGD3=$P(IVMSTR("ZGD"),HLFS,3)
"RTN","IVMPRECA",92,0)
 S X=$P(IVMSTR("ZGD"),HLFS,2)
"RTN","IVMPRECA",93,0)
 I X=HLQ S HLERR="Invalid Guardian Type" G ENQ
"RTN","IVMPRECA",94,0)
 I X,X'=1 S HLERR="Invalid Guardian Type" G ENQ
"RTN","IVMPRECA",95,0)
 I X=1,((ZGD3=HLQ)!(ZGD3="")) S HLERR="Invalid Guardian Type" G ENQ
"RTN","IVMPRECA",96,0)
 ;
"RTN","IVMPRECA",97,0)
 ;
"RTN","IVMPRECA",98,0)
ENQ ; - send acknowledgement (ACK) 'AE' msg to the IVM Center
"RTN","IVMPRECA",99,0)
 I $D(HLERR) D ACK^IVMPREC
"RTN","IVMPRECA",100,0)
 Q
"RTN","IVMPRECA",101,0)
 ;
"RTN","IVMPRECA",102,0)
 ;
"RTN","IVMPRECA",103,0)
ADDRCHK ; - validate address fields sent by IVM Center
"RTN","IVMPRECA",104,0)
 N HLERRDEF
"RTN","IVMPRECA",105,0)
 ;I ADDRTYPE="N" D  Q   ;Birth City & State
"RTN","IVMPRECA",106,0)
 ;. I $P(X,$E(HLECH),3)']"" S HLERR="Invalid address - Missing birth city" Q
"RTN","IVMPRECA",107,0)
 ;. I $P(X,$E(HLECH),4)']"" S HLERR="Invalid address - Missing birth state abbreviation" Q
"RTN","IVMPRECA",108,0)
 ;. S IVMSTPTR=+$O(^DIC(5,"C",$P(X,$E(HLECH),4),0))
"RTN","IVMPRECA",109,0)
 ;. I 'IVMSTPTR S HLERR="Invalid birth state abbreviation" Q
"RTN","IVMPRECA",110,0)
 ;
"RTN","IVMPRECA",111,0)
 S HLERRDEF="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"address - "
"RTN","IVMPRECA",112,0)
 S CNTRY=$P(X,$E(HLECH),6) I CNTRY']"" S HLERR=HLERRDEF_"Missing Country" Q
"RTN","IVMPRECA",113,0)
 I '$$CNTRCONV^IVMPREC8(CNTRY) S HLERR=HLERRDEF_"Invalid Country" Q
"RTN","IVMPRECA",114,0)
 S FORFLG=$S(CNTRY="USA":0,1:1)
"RTN","IVMPRECA",115,0)
 I $P(X,$E(HLECH),1)']"" S HLERR=HLERRDEF_"Missing street address [line 1]" Q
"RTN","IVMPRECA",116,0)
 I $P(X,$E(HLECH),3)']"" S HLERR=HLERRDEF_"Missing city" Q
"RTN","IVMPRECA",117,0)
 ;I $P(X,$E(HLECH),4)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"state abbreviation",1:"province") Q
"RTN","IVMPRECA",118,0)
 ;I $P(X,$E(HLECH),5)']"" S HLERR=HLERRDEF_"Missing "_$S('FORFLG:"zip code",1:"postal code") Q
"RTN","IVMPRECA",119,0)
 I $P(X,$E(HLECH),4)']"",'FORFLG S HLERR=HLERRDEF_"Missing State abbreviation" Q
"RTN","IVMPRECA",120,0)
 I $P(X,$E(HLECH),5)']"",'FORFLG S HLERR=HLERRDEF_"Missing Zip Code" Q
"RTN","IVMPRECA",121,0)
 I 'FORFLG D  Q:$D(HLERR)
"RTN","IVMPRECA",122,0)
 . S IVMCNTY=$P(X,$E(HLECH),9)
"RTN","IVMPRECA",123,0)
 . I IVMCNTY']"" S HLERR=HLERRDEF_"Missing county code" Q
"RTN","IVMPRECA",124,0)
 I $L($P(X,$E(HLECH),1))>35!($L($P(X,$E(HLECH),1))<3) S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 1]" Q
"RTN","IVMPRECA",125,0)
 I $P(X,$E(HLECH),2)]"",(($L($P(X,$E(HLECH),2))>30)!($L($P(X,$E(HLECH),2))<3)) S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"street address [line 2]" Q
"RTN","IVMPRECA",126,0)
 I ADDRTYPE'="CA" I $L($P(X,$E(HLECH),3))>15!($L($P(X,$E(HLECH),3))<2) S HLERR="Invalid city" Q
"RTN","IVMPRECA",127,0)
 ; IVM*2.0*164 - Uncomment below
"RTN","IVMPRECA",128,0)
 I ADDRTYPE="CA" I $L($P(X,$E(HLECH),3))>30!($L($P(X,$E(HLECH),3))<2) S HLERR="Invalid Confidential city" Q
"RTN","IVMPRECA",129,0)
 ;
"RTN","IVMPRECA",130,0)
 ; - save state pointer for county code validation only if not foreign address
"RTN","IVMPRECA",131,0)
 I 'FORFLG D  Q:$D(HLERR)
"RTN","IVMPRECA",132,0)
 .S IVMSTPTR=+$O(^DIC(5,"C",$P(X,$E(HLECH),4),0))
"RTN","IVMPRECA",133,0)
 .I 'IVMSTPTR S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"state abbreviation" Q
"RTN","IVMPRECA",134,0)
 .I '$O(^DIC(5,IVMSTPTR,1,"C",IVMCNTY,0)) D  Q:$G(HLERR)]""
"RTN","IVMPRECA",135,0)
 ..N STFIPS
"RTN","IVMPRECA",136,0)
 ..S STFIPS=IVMSTPTR
"RTN","IVMPRECA",137,0)
 ..S:$L(STFIPS)<2 STFIPS="0"_STFIPS
"RTN","IVMPRECA",138,0)
 ..Q:$$FIPSCHK^XIPUTIL(STFIPS_IVMCNTY)  ;county code is valid
"RTN","IVMPRECA",139,0)
 ..S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"county code"
"RTN","IVMPRECA",140,0)
 .S X=$P(X,$E(HLECH),5) D ZIPIN^VAFADDR I $D(X)[0 S HLERR="Invalid "_$S(ADDRTYPE="CA":"Confidential ",1:"")_"zip code" Q
"RTN","IVMPRECA",141,0)
 Q
"RTN","IVMPRECA",142,0)
 ;
"RTN","IVMPRECA",143,0)
 ;
"RTN","IVMPRECA",144,0)
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
"RTN","IVMPRECA",145,0)
 S IVMNUM=$O(^TMP($J,IVMRTN,IVMNUM)),IVMSTR=$G(^(+IVMNUM,0))
"RTN","IVMPRECA",146,0)
 Q
"RTN","IVMPRECA",147,0)
 ;
"RTN","IVMPRECA",148,0)
PID10 ; Perform consistency checks for seq. 10
"RTN","IVMPRECA",149,0)
 ; Get all Race data from seq. 10 of PID segment
"RTN","IVMPRECA",150,0)
 N RACEVAL,RACEDA,RACEFLG,RACESQ
"RTN","IVMPRECA",151,0)
 S RACEFLG=1 ;Flag to check if Race data exist.
"RTN","IVMPRECA",152,0)
 I $D(IVMPID(10)) D
"RTN","IVMPRECA",153,0)
 . I $O(IVMPID(10,"")) D  Q
"RTN","IVMPRECA",154,0)
 . . S RACESQ=0 F  S RACESQ=$O(IVMPID(10,RACESQ)) Q:((RACESQ="")!($D(HLERR))!('RACEFLG))  D
"RTN","IVMPRECA",155,0)
 . . . I $G(IVMPID(10,RACESQ))="" S RACEFLG=0 Q
"RTN","IVMPRECA",156,0)
 . . . S RACEVAL=$P($P(IVMPID(10,RACESQ),$E(HLECH),1),"-",1,2)
"RTN","IVMPRECA",157,0)
 . . . I RACEVAL="" S HLERR="Missing Race Value - PID Seq 10" Q
"RTN","IVMPRECA",158,0)
 . . . S IVMRACE(1,RACEVAL)=IVMPID(10,RACESQ)
"RTN","IVMPRECA",159,0)
 . I $G(IVMPID(10))="" S RACEFLG=0 Q
"RTN","IVMPRECA",160,0)
 . I $P($P(IVMPID(10),$E(HLECH),1),"-",1,2)="" S HLERR="Missing Race Value - PID Seq 10" Q
"RTN","IVMPRECA",161,0)
 . S RACEVAL=$P($P(IVMPID(10),$E(HLECH),1),"-",1,2)
"RTN","IVMPRECA",162,0)
 . I RACEVAL="" S HLERR="Missing Race Value - PID Seq 10" Q
"RTN","IVMPRECA",163,0)
 . S IVMRACE(1,RACEVAL)=IVMPID(10)
"RTN","IVMPRECA",164,0)
 Q:$D(HLERR)
"RTN","IVMPRECA",165,0)
 ;perform consistency checks on Race
"RTN","IVMPRECA",166,0)
 I RACEFLG D
"RTN","IVMPRECA",167,0)
 . S RACEVAL="" F  S RACEVAL=$O(IVMRACE(1,RACEVAL)) Q:RACEVAL=""!$D(HLERR)  D
"RTN","IVMPRECA",168,0)
 . . S RACEDA=$$CODE2PTR^DGUTL4(RACEVAL,1,2)
"RTN","IVMPRECA",169,0)
 . . I RACEVAL="UNK-SLF" S RACEDA=$$CODE2PTR^DGUTL4("9999-4",1,2)
"RTN","IVMPRECA",170,0)
 . . I RACEDA<1 S HLERR="Invalid Race Value - PID Seq 10" Q
"RTN","IVMPRECA",171,0)
 . . S IVMRACE(2,RACEDA)=IVMRACE(1,RACEVAL)
"RTN","IVMPRECA",172,0)
 Q
"RTN","IVMPRECA",173,0)
 ;
"RTN","IVMPRECA",174,0)
PID11 ; Perform consistency check for seq. 11
"RTN","IVMPRECA",175,0)
 S CONFADCT=""
"RTN","IVMPRECA",176,0)
 I $D(IVMPID(11)) D
"RTN","IVMPRECA",177,0)
 . I $O(IVMPID(11,"")) D  Q
"RTN","IVMPRECA",178,0)
 . . S ADDSEQ=0 F  S ADDSEQ=$O(IVMPID(11,ADDSEQ)) Q:ADDSEQ=""!($D(HLERR))  D
"RTN","IVMPRECA",179,0)
 . . . I $G(IVMPID(11,ADDSEQ))="" S HLERR="Invalid Address - Missing Address information" Q
"RTN","IVMPRECA",180,0)
 . . . S ADDRTYPE=$P($G(IVMPID(11,ADDSEQ)),$E(HLECH),7)
"RTN","IVMPRECA",181,0)
 . . . I ADDRTYPE="" S HLERR="Invalid Address - Missing Address Type" Q
"RTN","IVMPRECA",182,0)
 . . . ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
"RTN","IVMPRECA",183,0)
 . . . Q:'$D(IVMALADT(ADDRTYPE))
"RTN","IVMPRECA",184,0)
 . . . I IVMALADT(ADDRTYPE)="" S ADDRESS(ADDRTYPE)=IVMPID(11,ADDSEQ)
"RTN","IVMPRECA",185,0)
 . . . ;IVM*2.0*164 - Uncomment below to enable confidentail address processing
"RTN","IVMPRECA",186,0)
 . . . I $P(IVMALADT(ADDRTYPE),"^")="CA" D
"RTN","IVMPRECA",187,0)
 . . . . S ADDRESS("CA")=IVMPID(11,ADDSEQ)
"RTN","IVMPRECA",188,0)
 . . . . S CONFADCT=$P(IVMALADT(ADDRTYPE),"^",2)
"RTN","IVMPRECA",189,0)
 . . . . S CONFADCT(CONFADCT)=""
"RTN","IVMPRECA",190,0)
 . I $G(IVMPID(11))="" S HLERR="Invalid Address - Missing Address information" Q
"RTN","IVMPRECA",191,0)
 . S ADDRTYPE=$P($G(IVMPID(11)),$E(HLECH),7)
"RTN","IVMPRECA",192,0)
 . I ADDRTYPE="" S HLERR="Invalid Address - Missing Address Type" Q
"RTN","IVMPRECA",193,0)
 . ; I ADDRTYPE="P"!(ADDRTYPE="VAB1")!(ADDRTYPE="VAB2")!(ADDRTYPE="VAB3")!(ADDRTYPE="VAB4") S ADDRESS(ADDRTYPE)=IVMPID(11)
"RTN","IVMPRECA",194,0)
 . Q:'$D(IVMALADT(ADDRTYPE))
"RTN","IVMPRECA",195,0)
 . I IVMALADT(ADDRTYPE)="" S ADDRESS(ADDRTYPE)=IVMPID(11)
"RTN","IVMPRECA",196,0)
 . I $P(IVMALADT(ADDRTYPE),"^")="CA" D
"RTN","IVMPRECA",197,0)
 . . S ADDRESS("CA")=IVMPID(11)
"RTN","IVMPRECA",198,0)
 . . S CONFADCT=$P(IVMALADT(ADDRTYPE),"^",2)
"RTN","IVMPRECA",199,0)
 . . S CONFADCT(CONFADCT)=""
"RTN","IVMPRECA",200,0)
 Q:$D(HLERR)
"RTN","IVMPRECA",201,0)
 ;perform consistency checks on Permanent and all bad address
"RTN","IVMPRECA",202,0)
 I '$D(ADDRESS) S HLERR="Invalid Address - Invalid Address Type" Q
"RTN","IVMPRECA",203,0)
 S ADDRTYPE="" F  S ADDRTYPE=$O(ADDRESS(ADDRTYPE)) Q:((ADDRTYPE="")!($G(HLERR)'=""))  S X=$G(ADDRESS(ADDRTYPE)) D ADDRCHK
"RTN","IVMPRECA",204,0)
 Q
"RTN","IVMPRECA",205,0)
 ;
"RTN","IVMPRECA",206,0)
PID13 ; Perform consistency checks for seq. 13
"RTN","IVMPRECA",207,0)
 ;Get communication data for all types from seq. 13 or PID segment
"RTN","IVMPRECA",208,0)
 S TCFLG=1 ;Flag to check if Telecom data exist.
"RTN","IVMPRECA",209,0)
 I $D(IVMPID(13)) D
"RTN","IVMPRECA",210,0)
 . I $O(IVMPID(13,"")) D  Q
"RTN","IVMPRECA",211,0)
 . . S TELESEQ=0 F  S TELESEQ=$O(IVMPID(13,TELESEQ)) Q:((TELESEQ="")!($D(HLERR))!('TCFLG))  D
"RTN","IVMPRECA",212,0)
 . . . I $G(IVMPID(13,TELESEQ))="" S TCFLG=0 Q
"RTN","IVMPRECA",213,0)
 . . . I $P(IVMPID(13,TELESEQ),$E(HLECH),2)="" S HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13" Q
"RTN","IVMPRECA",214,0)
 . . . S TELECOM($P(IVMPID(13,TELESEQ),$E(HLECH),2))=IVMPID(13,TELESEQ)
"RTN","IVMPRECA",215,0)
 . I $G(IVMPID(13))="" S TCFLG=0 Q
"RTN","IVMPRECA",216,0)
 . I $P(IVMPID(13),$E(HLECH),2)="" S HLERR="Invalid Communication Data - Missing Communication Type - PID Seq 13" Q
"RTN","IVMPRECA",217,0)
 . S TELECOM($P(IVMPID(13),$E(HLECH),2))=IVMPID(13)
"RTN","IVMPRECA",218,0)
 Q:$D(HLERR)
"RTN","IVMPRECA",219,0)
 ;perform consistency checks on all types of communication data.
"RTN","IVMPRECA",220,0)
 I TCFLG D
"RTN","IVMPRECA",221,0)
 . S COMMTYPE="" F  S COMMTYPE=$O(TELECOM(COMMTYPE)) Q:COMMTYPE=""!$D(HLERR)  D
"RTN","IVMPRECA",222,0)
 . . I COMMTYPE="NET" D  Q
"RTN","IVMPRECA",223,0)
 . . . S X=$P(TELECOM(COMMTYPE),$E(HLECH),4)
"RTN","IVMPRECA",224,0)
 . . . I X]"",'$$CHKEMAIL^IVMPREC8(X) S HLERR="Invalid Email address"
"RTN","IVMPRECA",225,0)
 . . S X=$P(TELECOM(COMMTYPE),$E(HLECH)) I X]"",(($L(X)>20)!($L(X)<4)) S HLERR="Invalid phone number"
"RTN","IVMPRECA",226,0)
 Q
"RTN","IVMPRECA",227,0)
 ;
"RTN","IVMPRECA",228,0)
CLEARF(NODE,DEL,IGNORE) ;
"RTN","IVMPRECA",229,0)
 ; Input:       NODE    - SEGMENT/SEQ.
"RTN","IVMPRECA",230,0)
 ;               DEL    - Delimiter (optional - default is ^)
"RTN","IVMPRECA",231,0)
 ;            IGNORE    - String of seq # to avoid (optional)
"RTN","IVMPRECA",232,0)
 N I
"RTN","IVMPRECA",233,0)
 I $G(DEL)="" S DEL=HLFS
"RTN","IVMPRECA",234,0)
 F I=1:1:$L(NODE,DEL) D
"RTN","IVMPRECA",235,0)
 . I $G(IGNORE)[(","_I_",") Q  ;Ignore this seq. to convert
"RTN","IVMPRECA",236,0)
 . I $P(NODE,DEL,I)=HLQ S $P(NODE,DEL,I)=""
"RTN","IVMPRECA",237,0)
 Q NODE
"RTN","IVMPTRN8")
0^5^B103984771
"RTN","IVMPTRN8",1,0)
IVMPTRN8 ;ALB/RKS,PDJ,BRM,TDM,PJH,TDM,PWC,LBD,DRP,DJS,KUM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER ;27 Nov 2017  8:56 AM
"RTN","IVMPTRN8",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,24,36,37,47,48,42,34,77,76,75,79,85,89,98,56,97,104,113,109,114,105,115,121,151,141,150,160,161,168,167,164**;21-OCT-94;Build 98
"RTN","IVMPTRN8",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IVMPTRN8",4,0)
 ;
"RTN","IVMPTRN8",5,0)
 ; *164* #858271 - Sending ZAV Segment with CASS field value for all Address types 
"RTN","IVMPTRN8",6,0)
 ;
"RTN","IVMPTRN8",7,0)
BUILD(DFN,IVMMTDT,IVMCT,IVMQUERY) ; --
"RTN","IVMPTRN8",8,0)
 ;  Description: This entry point will be used to create an HL7 
"RTN","IVMPTRN8",9,0)
 ;  "Full Data Transmission" message for a patient.
"RTN","IVMPTRN8",10,0)
 ;
"RTN","IVMPTRN8",11,0)
 ;  Input:
"RTN","IVMPTRN8",12,0)
 ;        DFN - Patient IEN
"RTN","IVMPTRN8",13,0)
 ;    IVMMTDT - date of the patient's Means Test or Copay Test
"RTN","IVMPTRN8",14,0)
 ;      IVMCT - count of hl7 segments transmitted, pass by reference
"RTN","IVMPTRN8",15,0)
 ;   IVMQUERY - array passed in by reference where
"RTN","IVMPTRN8",16,0)
 ;    IVMQUERY("LTD") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",17,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",18,0)
 ;                last treatment date
"RTN","IVMPTRN8",19,0)
 ;    IVMQUERY("OVIS") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",20,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",21,0)
 ;                finding outpatient visits
"RTN","IVMPTRN8",22,0)
 ;
"RTN","IVMPTRN8",23,0)
 ;  HL7 variables as defined by call to INIT^IVMUFNC:
"RTN","IVMPTRN8",24,0)
 ;      HLEVN - HL7 message event counter 
"RTN","IVMPTRN8",25,0)
 ;      HLSDT - a flag that indicates that the data to be sent is
"RTN","IVMPTRN8",26,0)
 ;              stored in the ^TMP("HLS") global array.
"RTN","IVMPTRN8",27,0)
 ;
"RTN","IVMPTRN8",28,0)
 ;  The following variables returned by the INIT^HLTRANS entry point:
"RTN","IVMPTRN8",29,0)
 ;    HLNDAP - Non-DHCP Application Pointer from file 770
"RTN","IVMPTRN8",30,0)
 ;   HLNDAP0 - Zero node from file 770 corresponding to HLNDAP
"RTN","IVMPTRN8",31,0)
 ;     HLDAP - DHCP Application Pointer from file 771
"RTN","IVMPTRN8",32,0)
 ;     HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP
"RTN","IVMPTRN8",33,0)
 ;     HLPID - HL7 processing ID from file 770
"RTN","IVMPTRN8",34,0)
 ;     HLVER - HL7 version number from file 770
"RTN","IVMPTRN8",35,0)
 ;      HLFS - HL7 Field Separator from the 'FS' node of file 771
"RTN","IVMPTRN8",36,0)
 ;     HLECH - HL7 Encoding Characters from the 'EC' node of file 771
"RTN","IVMPTRN8",37,0)
 ;       HLQ - Double quotes ("") for use in building HL7 segments
"RTN","IVMPTRN8",38,0)
 ;     HLERR - if an error is encountered, an error message is returned
"RTN","IVMPTRN8",39,0)
 ;             in the HLERR variable.
"RTN","IVMPTRN8",40,0)
 ;      HLDA - the internal entry number for the entry created in
"RTN","IVMPTRN8",41,0)
 ;             file #772.
"RTN","IVMPTRN8",42,0)
 ;      HLDT - transmission date/time (associated with the entry in file
"RTN","IVMPTRN8",43,0)
 ;             #772 identified by HLDA) in internal VA FileMan format.
"RTN","IVMPTRN8",44,0)
 ;     HLDT1 - the same transmission date/time as the HLDT variable, 
"RTN","IVMPTRN8",45,0)
 ;             only in HL7 format.
"RTN","IVMPTRN8",46,0)
 ;
"RTN","IVMPTRN8",47,0)
 ; Output:
"RTN","IVMPTRN8",48,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",49,0)
 ;
"RTN","IVMPTRN8",50,0)
 ;
"RTN","IVMPTRN8",51,0)
 N DGINC,DGIR,DGREL,I,IVMNTE,IVMPID,IVMSUB,IVMZRD,IVMZAV,VAFPID,VAFZEL,FBZFE,IVMZCD,DELETE,NODE,IVMPIEN,TEST,IVMPNODE,TESTTYPE,SEQS,TESTCODE,HARDSHIP,ACTVIEN,IVMZMH,IVMSEQ
"RTN","IVMPTRN8",52,0)
 N EDBMTZ06,ZMHSQ,SETID,OBXCNT,OBXTMP,DGSEC,SEGOCC,ZIOSEG,N101015,RF1SEG,ZCTTYP,ZCTARY,ZCTSQ,VAFPID,CAFLG,IVMZAVA
"RTN","IVMPTRN8",53,0)
 S IVMZAVA=""
"RTN","IVMPTRN8",54,0)
 ;
"RTN","IVMPTRN8",55,0)
 ; create (PID) Patient Identification segment
"RTN","IVMPTRN8",56,0)
 ; **** Add ICN to 2nd piece PID segment for MPI@HEC.
"RTN","IVMPTRN8",57,0)
 S IVMCMOR="1,2",IVMSEQ=1
"RTN","IVMPTRN8",58,0)
 ; check to see if site is a legacy site.  If not add ICN to PID segment.
"RTN","IVMPTRN8",59,0)
 I '$D(^PPP(1020.128,"AC",$P($$SITE^VASITE,"^",3))) D
"RTN","IVMPTRN8",60,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",61,0)
 ;
"RTN","IVMPTRN8",62,0)
 ; send SSN indicating pseudo
"RTN","IVMPTRN8",63,0)
 ; I $P(IVMPID_$G(IVMPID(1)),HLFS,20)["P" D PSEUDO^IVMPTRN1  ; strip 'P' from pseudo SSNs
"RTN","IVMPTRN8",64,0)
 S IVMSEQ=IVMSEQ_",3,5,6,7,8,10,11,12,13,14,16,17,19,22,24"
"RTN","IVMPTRN8",65,0)
 K IVMPID D BLDPID^VAFCQRY1(DFN,1,IVMSEQ,.IVMPID,.HL,.ERROR)
"RTN","IVMPTRN8",66,0)
 K VAFPID D STRIP11
"RTN","IVMPTRN8",67,0)
 S SEGOCC="" F  S SEGOCC=$O(VAFPID(SEGOCC)) Q:SEGOCC=""  D
"RTN","IVMPTRN8",68,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFPID(SEGOCC)
"RTN","IVMPTRN8",69,0)
 ;
"RTN","IVMPTRN8",70,0)
 ; **** create (PD1) Patient CMOR segment for MPI@HEC.
"RTN","IVMPTRN8",71,0)
 S:'$D(HL("FS")) HL("FS")=HLFS
"RTN","IVMPTRN8",72,0)
 S:'$D(HL("ECH")) HL("ECH")=HLECH
"RTN","IVMPTRN8",73,0)
 S:'$D(HL("Q")) HL("Q")=HLQ
"RTN","IVMPTRN8",74,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLPD1(DFN,IVMCMOR)
"RTN","IVMPTRN8",75,0)
 ;
"RTN","IVMPTRN8",76,0)
 ; create (ZPD) Patient Dependent Info. segment
"RTN","IVMPTRN8",77,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",78,0)
 I $D(VAFZPD(1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFZPD(1) K VAFZPD(1)
"RTN","IVMPTRN8",79,0)
 ;
"RTN","IVMPTRN8",80,0)
 ; create (ZTA) Temporary Address segment
"RTN","IVMPTRN8",81,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,8,9",,.HL)
"RTN","IVMPTRN8",82,0)
 ; KUM IVM*2.0*164 - Set Flag to determine if Temporary address is in Message
"RTN","IVMPTRN8",83,0)
 I $TR($P(^TMP("HLS",$J,IVMCT),HLFS,6),"~""""^","")'="" S IVMZAVA("C")=""
"RTN","IVMPTRN8",84,0)
 ;
"RTN","IVMPTRN8",85,0)
 ; KUM - IVM*2.0*164 - Send CASS field value for all Address Types
"RTN","IVMPTRN8",86,0)
 ; create (ZAV) Rated Disabilities segment(s)
"RTN","IVMPTRN8",87,0)
 D EN^VAFHLZAV(DFN,"1,2,3,",HLQ,HLFS,.IVMZAV,.IVMZAVA)
"RTN","IVMPTRN8",88,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZAV("HL7",IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",89,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZAV("HL7",+IVMSUB))
"RTN","IVMPTRN8",90,0)
 ;
"RTN","IVMPTRN8",91,0)
 ; create (ZIE) Ineligible segment
"RTN","IVMPTRN8",92,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIE(DFN,"1,2,3",1)
"RTN","IVMPTRN8",93,0)
 ;
"RTN","IVMPTRN8",94,0)
 ; create (ZEL) Eligibility segment(s) 
"RTN","IVMPTRN8",95,0)
 ; **** Add 5th piece to ZEL to correct consistency check
"RTN","IVMPTRN8",96,0)
 ; added 41-44 for CLV IVM*2.0*161
"RTN","IVMPTRN8",97,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,41,42,43,44",2,.VAFZEL)
"RTN","IVMPTRN8",98,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1))  ; Primary Eligibility
"RTN","IVMPTRN8",99,0)
 I $D(VAFZEL(1,1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1,1))
"RTN","IVMPTRN8",100,0)
 ; - other entitled eligibilities
"RTN","IVMPTRN8",101,0)
 F IVMSUB=1:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",102,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(+IVMSUB))
"RTN","IVMPTRN8",103,0)
 ;
"RTN","IVMPTRN8",104,0)
 ; create ZE2 segment (Optional)
"RTN","IVMPTRN8",105,0)
 I $P($G(^DPT(DFN,.385)),U)'="" S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZE2(DFN,"1,2")
"RTN","IVMPTRN8",106,0)
 ;
"RTN","IVMPTRN8",107,0)
 ; create (ZEN) Enrollment segment
"RTN","IVMPTRN8",108,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEN(DFN)
"RTN","IVMPTRN8",109,0)
 ;
"RTN","IVMPTRN8",110,0)
 ; create (ZCD) Catastrophic Disability segment(s)
"RTN","IVMPTRN8",111,0)
 D BUILD^VAFHLZCD(.IVMZCD,DFN,,HLQ,HLFS)
"RTN","IVMPTRN8",112,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZCD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",113,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZCD(+IVMSUB))
"RTN","IVMPTRN8",114,0)
 ;
"RTN","IVMPTRN8",115,0)
 ; Optionally create (ZMH) Military History segments
"RTN","IVMPTRN8",116,0)
 ; Pass "*" as parameter to send unlimited MSEs in Z07 (IVM*2*141)
"RTN","IVMPTRN8",117,0)
 D ENTER^VAFHLZMH(DFN,"IVMZMH","*")
"RTN","IVMPTRN8",118,0)
 ;DJS, Don't create ZMH segment if array entry is an FDD MSE; IVM*2.0*167
"RTN","IVMPTRN8",119,0)
 N ZMHED,MSESUB,DONEMSE
"RTN","IVMPTRN8",120,0)
 S (ZMHSQ,SETID,DONEMSE)=0
"RTN","IVMPTRN8",121,0)
 I $D(IVMZMH) F  S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ=""  D
"RTN","IVMPTRN8",122,0)
 . Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")=""
"RTN","IVMPTRN8",123,0)
 . ;If no Service Entry Date, QUIT
"RTN","IVMPTRN8",124,0)
 . S ZMHED=$P(IVMZMH(ZMHSQ,0),U,5),ZMHED=$P(ZMHED,"~",1) Q:ZMHED=""
"RTN","IVMPTRN8",125,0)
 . S ZMHED=$$HL7TFM^XLFDT(ZMHED)
"RTN","IVMPTRN8",126,0)
 . ;Get MSE, if no more MSEs, process Conflict Information, if present
"RTN","IVMPTRN8",127,0)
 . I 'DONEMSE S MSESUB="",MSESUB=$O(^DPT(DFN,.3216,"B",ZMHED,MSESUB)) S:MSESUB="" DONEMSE=1
"RTN","IVMPTRN8",128,0)
 . ;Do not create ZMH segment if FDD MSE
"RTN","IVMPTRN8",129,0)
 . I 'DONEMSE,$P(^DPT(DFN,.3216,MSESUB,0),U,8)'="" Q  ;Only check for FDD if MSE entry
"RTN","IVMPTRN8",130,0)
 . S SETID=SETID+1,IVMCT=IVMCT+1
"RTN","IVMPTRN8",131,0)
 . S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6)
"RTN","IVMPTRN8",132,0)
 ;
"RTN","IVMPTRN8",133,0)
 ; create (ZRD) Rated Disabilities segment(s)
"RTN","IVMPTRN8",134,0)
 D EN^VAFHLZRD(DFN,"1,2,3,4,12,13,14,",HLQ,HLFS,"IVMZRD")
"RTN","IVMPTRN8",135,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",136,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0))
"RTN","IVMPTRN8",137,0)
 ;
"RTN","IVMPTRN8",138,0)
 ; create (ZCT) Emergency Contact segment
"RTN","IVMPTRN8",139,0)
 ;S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1)
"RTN","IVMPTRN8",140,0)
 K ZCTARY F ZCTTYP=1:1:5 D   ;Create Optional ZCT Segments
"RTN","IVMPTRN8",141,0)
 . S ZCTARY(ZCTTYP)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",ZCTTYP,1)
"RTN","IVMPTRN8",142,0)
 S (ZCTTYP,ZCTSQ)=0
"RTN","IVMPTRN8",143,0)
 I $D(ZCTARY) F  S ZCTTYP=$O(ZCTARY(ZCTTYP)) Q:ZCTTYP=""  D
"RTN","IVMPTRN8",144,0)
 . Q:$P(ZCTARY(ZCTTYP),HLFS,11)=HLQ
"RTN","IVMPTRN8",145,0)
 . S ZCTSQ=ZCTSQ+1,$P(ZCTARY(ZCTTYP),HLFS,2)=ZCTSQ
"RTN","IVMPTRN8",146,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(ZCTTYP)
"RTN","IVMPTRN8",147,0)
 I ZCTSQ=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(1)
"RTN","IVMPTRN8",148,0)
 ;
"RTN","IVMPTRN8",149,0)
 ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse
"RTN","IVMPTRN8",150,0)
 ;*168 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7")
"RTN","IVMPTRN8",151,0)
 ;*168 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7",2,2)
"RTN","IVMPTRN8",152,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7,9") ;re-enable imprecise date.
"RTN","IVMPTRN8",153,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7,9",2,2)
"RTN","IVMPTRN8",154,0)
 ;
"RTN","IVMPTRN8",155,0)
 ; create (ZGD) Guardian segment for (1) VA & (2) Civil 
"RTN","IVMPTRN8",156,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1)
"RTN","IVMPTRN8",157,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2)
"RTN","IVMPTRN8",158,0)
 ;
"RTN","IVMPTRN8",159,0)
 ; Income Year requiring transmission from IVM Patient File (301.5)
"RTN","IVMPTRN8",160,0)
 S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000))
"RTN","IVMPTRN8",161,0)
 N MTINFO S MTINFO=$$FUT^DGMTU(DFN)
"RTN","IVMPTRN8",162,0)
 I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2)
"RTN","IVMPTRN8",163,0)
 ;get the primary test for the income year
"RTN","IVMPTRN8",164,0)
 S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN)
"RTN","IVMPTRN8",165,0)
 ;
"RTN","IVMPTRN8",166,0)
 ; The following function call returns:
"RTN","IVMPTRN8",167,0)
 ;   - Patient Relation IEN array in DGREL
"RTN","IVMPTRN8",168,0)
 ;   - Individual Annual Income IEN array in DGINC
"RTN","IVMPTRN8",169,0)
 ;   - Income Relation IEN array in DGINR
"RTN","IVMPTRN8",170,0)
 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN)
"RTN","IVMPTRN8",171,0)
 ;
"RTN","IVMPTRN8",172,0)
 S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1
"RTN","IVMPTRN8",173,0)
 ; create (ZIC) Income segment for veteran
"RTN","IVMPTRN8",174,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",175,0)
 ;IVM*2.0*115 -- Check for Means Test Version Indicator
"RTN","IVMPTRN8",176,0)
 N MTVERS S MTVERS=$S(+$G(ACTVIEN):+$P($G(^DGMT(408.31,ACTVIEN,2)),"^",11),1:0)
"RTN","IVMPTRN8",177,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",178,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",179,0)
 E  D
"RTN","IVMPTRN8",180,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,9,12,13,14,15,16,18,19")
"RTN","IVMPTRN8",181,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",182,0)
 ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct
"RTN","IVMPTRN8",183,0)
 S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY)
"RTN","IVMPTRN8",184,0)
 ;
"RTN","IVMPTRN8",185,0)
 ; create (ZIR) Income Relation segment for veteran
"RTN","IVMPTRN8",186,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("V")),"1,2,3,4,5,10,15")  ;IVM * 2.0 *160
"RTN","IVMPTRN8",187,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1"
"RTN","IVMPTRN8",188,0)
 ;
"RTN","IVMPTRN8",189,0)
 ; create (ZDP) Patient Dependent Info. segment for spouse
"RTN","IVMPTRN8",190,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",191,0)
 I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",192,0)
 . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",193,0)
 . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",194,0)
 ;
"RTN","IVMPTRN8",195,0)
 ; create (ZIC) Income segment for spouse
"RTN","IVMPTRN8",196,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",197,0)
 ;IVM*2.0*115
"RTN","IVMPTRN8",198,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",199,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,4,5,6,7,8,9,10,11,12,16,17,18,19,20")
"RTN","IVMPTRN8",200,0)
 E  D
"RTN","IVMPTRN8",201,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,9,12,16,18,19")
"RTN","IVMPTRN8",202,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",203,0)
 ;
"RTN","IVMPTRN8",204,0)
 ; create (ZIR) Income Relation segment for spouse
"RTN","IVMPTRN8",205,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3")
"RTN","IVMPTRN8",206,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",207,0)
 ;
"RTN","IVMPTRN8",208,0)
 ;
"RTN","IVMPTRN8",209,0)
 ; create ZDP, ZIC, and ZIR segments for all Means Test dependents
"RTN","IVMPTRN8",210,0)
 F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",211,0)
 . ;
"RTN","IVMPTRN8",212,0)
 . ; - create (ZDP) Dependent Info. segment for dependent child
"RTN","IVMPTRN8",213,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",214,0)
 . I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",215,0)
 . . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",216,0)
 . . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",217,0)
 . ;
"RTN","IVMPTRN8",218,0)
 . ; - create (ZIC) Income segment for dependent child
"RTN","IVMPTRN8",219,0)
 . S IVMCT=IVMCT+1
"RTN","IVMPTRN8",220,0)
 . ;IVM*2.0*115
"RTN","IVMPTRN8",221,0)
 . I MTVERS=0 D  I 1
"RTN","IVMPTRN8",222,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",223,0)
 . E  D
"RTN","IVMPTRN8",224,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,9,12,15,16,18,19")
"RTN","IVMPTRN8",225,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",226,0)
 . ;
"RTN","IVMPTRN8",227,0)
 . ; - create (ZIR) Income Relation segment for dependent child
"RTN","IVMPTRN8",228,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("C",IVMSUB)),"1,2,3,4,6,7,8,9,14,15")  ;IVM * 2.0 *160
"RTN","IVMPTRN8",229,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",230,0)
 . ;
"RTN","IVMPTRN8",231,0)
 ; Send INACTIVE spouse/dependents.
"RTN","IVMPTRN8",232,0)
 D GETINACD^DGMTU11(DFN,.DGREL)
"RTN","IVMPTRN8",233,0)
 F I="S","C" D
"RTN","IVMPTRN8",234,0)
 . F IVMSUB=0:0 S IVMSUB=$O(DGIREL(I,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",235,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",236,0)
 ;
"RTN","IVMPTRN8",237,0)
 D GOTO^IVMPTRN9
"RTN","IVMPTRN8",238,0)
 Q
"RTN","IVMPTRN8",239,0)
 ;
"RTN","IVMPTRN8",240,0)
STRIP11 N APID,ZPID,ASQ,ATYP,SSQ
"RTN","IVMPTRN8",241,0)
 ;Extract PID segment
"RTN","IVMPTRN8",242,0)
 S IVMPID(1)=$E(IVMPID(1),5,$L(IVMPID(1)))
"RTN","IVMPTRN8",243,0)
 D BLDPID^IVMPREC6(.IVMPID,.APID)
"RTN","IVMPTRN8",244,0)
 ;
"RTN","IVMPTRN8",245,0)
 S CAFLG=0
"RTN","IVMPTRN8",246,0)
 I $D(APID(11)) D
"RTN","IVMPTRN8",247,0)
 .I $O(APID(11,"")) D  Q
"RTN","IVMPTRN8",248,0)
 ..M ZPID(11)=APID(11) K APID(11)
"RTN","IVMPTRN8",249,0)
 ..S (ASQ,SSQ)=0 F  S ASQ=$O(ZPID(11,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",250,0)
 ...S ATYP=$P($G(ZPID(11,ASQ)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",251,0)
 ...;KUM - IVM*2.0*164 - Comment below 2 lines and Add line to enable all categories of Confidential Address
"RTN","IVMPTRN8",252,0)
 ...;I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") Q
"RTN","IVMPTRN8",253,0)
 ...;I ATYP="VACAE" S CAFLG=1
"RTN","IVMPTRN8",254,0)
 ...I (ATYP="VACAE")!(ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") S CAFLG=1
"RTN","IVMPTRN8",255,0)
 ...I (CAFLG=1) S IVMZAVA("CNF")=""
"RTN","IVMPTRN8",256,0)
 ...I (ATYP="P") S IVMZAVA("P")=""
"RTN","IVMPTRN8",257,0)
 ...I (ATYP="R") S IVMZAVA("R")=""
"RTN","IVMPTRN8",258,0)
 ...S SSQ=SSQ+1,APID(11,SSQ)=ZPID(11,ASQ)
"RTN","IVMPTRN8",259,0)
 .Q:$G(APID(11))=""
"RTN","IVMPTRN8",260,0)
 .S ATYP=$P($G(APID(11)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",261,0)
 .;KUM - IVM*2.0*164 - Comment below 2 lines and Add line to enable all categories of Confidential Address
"RTN","IVMPTRN8",262,0)
 .;I ATYP="VACAE" S CAFLG=1 Q
"RTN","IVMPTRN8",263,0)
 .;I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") K APID(11)
"RTN","IVMPTRN8",264,0)
 .I (ATYP="VACAE")!(ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") S CAFLG=1 Q
"RTN","IVMPTRN8",265,0)
 ;
"RTN","IVMPTRN8",266,0)
 I 'CAFLG,$D(APID(13)) D
"RTN","IVMPTRN8",267,0)
 .I $O(APID(13,"")) D  Q
"RTN","IVMPTRN8",268,0)
 ..S ASQ=0 F  S ASQ=$O(APID(13,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",269,0)
 ...Q:$G(APID(13,ASQ))=""
"RTN","IVMPTRN8",270,0)
 ...S ATYP=$P($G(APID(13,ASQ)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",271,0)
 ...I ATYP="VACPN" K APID(13,ASQ) Q
"RTN","IVMPTRN8",272,0)
 .Q:$G(APID(13))=""
"RTN","IVMPTRN8",273,0)
 .S ATYP=$P($G(APID(13)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",274,0)
 .I ATYP="VACPN" K APID(13) Q
"RTN","IVMPTRN8",275,0)
 ;
"RTN","IVMPTRN8",276,0)
 ;Rebuild PID
"RTN","IVMPTRN8",277,0)
 D KVA^VADPT
"RTN","IVMPTRN8",278,0)
 D MAKEIT^VAFHLU("PID",.APID,.VAFPID,.VAFPID)
"RTN","IVMPTRN8",279,0)
 S VAFPID(0)=VAFPID
"RTN","IVMPTRN8",280,0)
 Q
"RTN","IVMPTRN9")
0^8^B54344683
"RTN","IVMPTRN9",1,0)
IVMPTRN9 ;ALB/KCL,CN,BRM,TDM,EG,LBD,TGH,KUM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER (CONTINUED) ;12/7/12 2:56pm
"RTN","IVMPTRN9",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46,50,53,34,49,58,79,99,116,105,115,152,160,164**;21-OCT-94;Build 98
"RTN","IVMPTRN9",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IVMPTRN9",4,0)
 ;
"RTN","IVMPTRN9",5,0)
 ;
"RTN","IVMPTRN9",6,0)
GOTO ; place to break up the routine
"RTN","IVMPTRN9",7,0)
 ;
"RTN","IVMPTRN9",8,0)
 ; create (ZIO) Inpatient/Outpatient segment for veteran
"RTN","IVMPTRN9",9,0)
 S N101015=$G(^DPT(DFN,1010.15))
"RTN","IVMPTRN9",10,0)
 S ZIOSEG="ZIO^1^"_$$EN^IVMUFNC1(DFN,IVMMTDT,.IVMQUERY)  ;seq 1-3
"RTN","IVMPTRN9",11,0)
 S ZIOSEG=ZIOSEG_"^"_$$LTD^IVMUFNC(DFN,.IVMQUERY)        ;seq 4
"RTN","IVMPTRN9",12,0)
 S X=$P(N101015,"^",9),$P(ZIOSEG,U,6)=$S(X=0:"N",X=1:"Y",1:HLQ)   ;Appt Request
"RTN","IVMPTRN9",13,0)
 S X=$P(N101015,"^",11),$P(ZIOSEG,U,7)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) ;Appt Request Date
"RTN","IVMPTRN9",14,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZIOSEG
"RTN","IVMPTRN9",15,0)
 ;
"RTN","IVMPTRN9",16,0)
 ; create (NTE) Notes and Comments segment
"RTN","IVMPTRN9",17,0)
 D NTE^IVMUFNC4(DFN,.IVMNTE,IVMMTDT)
"RTN","IVMPTRN9",18,0)
 I '$D(IVMNTE) D
"RTN","IVMPTRN9",19,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="NTE^1"
"RTN","IVMPTRN9",20,0)
 I $D(IVMNTE) D
"RTN","IVMPTRN9",21,0)
 . ; - get notes and comments
"RTN","IVMPTRN9",22,0)
 . F IVMSUB=0:0 S IVMSUB=$O(IVMNTE(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",23,0)
 . . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMNTE(IVMSUB)
"RTN","IVMPTRN9",24,0)
 ;
"RTN","IVMPTRN9",25,0)
 ; create (IN1) Insurance segment(s) for all active insurance
"RTN","IVMPTRN9",26,0)
 K ^TMP("VAFIN1",$J)
"RTN","IVMPTRN9",27,0)
 D EN^VAFHLIN1(DFN,"1,4,5,7,8,9,12,13,15,16,17,28,36")
"RTN","IVMPTRN9",28,0)
 F IVMSUB=0:0 S IVMSUB=$O(^TMP("VAFIN1",$J,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",29,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=^TMP("VAFIN1",$J,+IVMSUB,0)
"RTN","IVMPTRN9",30,0)
 ;
"RTN","IVMPTRN9",31,0)
 ;find if the deletion flags were set in the IVM Patient file, and if so, should the deletion indicators be sent?
"RTN","IVMPTRN9",32,0)
 F I="RX","MT","HARDSHIP","DATE OF TEST","LTC" S DELETE(I)=""
"RTN","IVMPTRN9",33,0)
 S IVMPIEN=$$FIND^IVMPLOG(DFN,($E(IVMMTDT,1,3)-1))
"RTN","IVMPTRN9",34,0)
 I IVMPIEN D
"RTN","IVMPTRN9",35,0)
 . S IVMPNODE=$G(^IVM(301.5,IVMPIEN,0))
"RTN","IVMPTRN9",36,0)
 . I $P(IVMPNODE,"^",8)!$P(IVMPNODE,"^",9)!$P(IVMPNODE,"^",10)!$P(IVMPNODE,"^",11) S DELETE("SET")=1
"RTN","IVMPTRN9",37,0)
 . ;was the MT deletion flag set, and if so verify that there is no completed MT
"RTN","IVMPTRN9",38,0)
 . I $P(IVMPNODE,"^",8),(TESTTYPE'=1)!(TESTCODE="")!("ACGP"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",8),DELETE("MT")=1
"RTN","IVMPTRN9",39,0)
 . ;
"RTN","IVMPTRN9",40,0)
 . ;was the hardship deletion flag set, and if so verify that there is no completed hardship
"RTN","IVMPTRN9",41,0)
 . I $P(IVMPNODE,"^",10),'HARDSHIP D
"RTN","IVMPTRN9",42,0)
 . . S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",10)
"RTN","IVMPTRN9",43,0)
 . . S DELETE("HARDSHIP")=1
"RTN","IVMPTRN9",44,0)
 ;
"RTN","IVMPTRN9",45,0)
 ; create (ZMT) Means Test segment 
"RTN","IVMPTRN9",46,0)
 ;
"RTN","IVMPTRN9",47,0)
 S SEQS=$S(TESTTYPE=1:"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,21,22,23,24,25,26,28,29,30,31",1:"1,17")  ;IVM*2.0*160
"RTN","IVMPTRN9",48,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,1,1,.DELETE,1)
"RTN","IVMPTRN9",49,0)
 ;
"RTN","IVMPTRN9",50,0)
 ; create (ZMT) Rx-Copay Test segment
"RTN","IVMPTRN9",51,0)
 I IVMPIEN D
"RTN","IVMPTRN9",52,0)
 . ;was the RX deletion flag set, and if so verify that there is no completed test
"RTN","IVMPTRN9",53,0)
 . I $P(IVMPNODE,"^",9),(TESTTYPE'=2)!(TESTCODE="")!("EM"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",9),DELETE("RX")=1
"RTN","IVMPTRN9",54,0)
 ;
"RTN","IVMPTRN9",55,0)
 N IVMCPDT,CPTST,LINK,CPDATE
"RTN","IVMPTRN9",56,0)
 ;should be ok to get the last co-pay test for this year vs. looking from the IVMMTDT backwards
"RTN","IVMPTRN9",57,0)
 ;as long as the means test date is in the current year
"RTN","IVMPTRN9",58,0)
 S CPTST=$$LST^DGMTU(DFN,$E(IVMIY,1,3)+1_1231,2)
"RTN","IVMPTRN9",59,0)
 I CPTST D
"RTN","IVMPTRN9",60,0)
 . S CPDATE=$P(CPTST,U,2)
"RTN","IVMPTRN9",61,0)
 . S LINK=$P($G(^DGMT(408.31,+CPTST,2)),U,6)
"RTN","IVMPTRN9",62,0)
 . I TESTTYPE=1,$E(CPDATE,1,3)=$E(IVMMTDT,1,3) D
"RTN","IVMPTRN9",63,0)
 . . ;if you have a means test and a linked co-pay test then send both (the means test
"RTN","IVMPTRN9",64,0)
 . . ;was already sent from above)
"RTN","IVMPTRN9",65,0)
 . . ;if means and copay are not linked, don't send the co-pay test (the means test
"RTN","IVMPTRN9",66,0)
 . . ;was already sent from above)
"RTN","IVMPTRN9",67,0)
 . . I LINK=+$$LST^DGMTU(DFN,IVMMTDT,1) S TESTTYPE=2,(IVMCPDT,IVMMTDT)=CPDATE
"RTN","IVMPTRN9",68,0)
 . . Q
"RTN","IVMPTRN9",69,0)
 . Q
"RTN","IVMPTRN9",70,0)
 ;always send the 2nd ZMT segment
"RTN","IVMPTRN9",71,0)
 S SEQS="1,17"
"RTN","IVMPTRN9",72,0)
 ;can also send a co-pay test if there is no means test (see module GETTYPE)
"RTN","IVMPTRN9",73,0)
 I TESTTYPE=2 D
"RTN","IVMPTRN9",74,0)
 . S SEQS="1,2,3,4,5,6,7,9,10,12,15,16,17,18,21,22,25,26,30,31"  ;IVM*2.0*160
"RTN","IVMPTRN9",75,0)
 . Q
"RTN","IVMPTRN9",76,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,2,2,.DELETE,1)
"RTN","IVMPTRN9",77,0)
 ;
"RTN","IVMPTRN9",78,0)
 ; create (ZMT) Long Term Care Copay Exemption Test segment
"RTN","IVMPTRN9",79,0)
 I IVMPIEN D
"RTN","IVMPTRN9",80,0)
 . ; set deletion indicators if LTC test deletion should be transmitted
"RTN","IVMPTRN9",81,0)
 . I $P(IVMPNODE,"^",11) S DELETE("LTC")=1 S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",11)
"RTN","IVMPTRN9",82,0)
 ;
"RTN","IVMPTRN9",83,0)
 S SEQS="1,2,3,4,5,7,9,10,12,16,17,18,22,25,30,31"  ;IVM*2.0*160
"RTN","IVMPTRN9",84,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,4,4,.DELETE,1)
"RTN","IVMPTRN9",85,0)
 ;
"RTN","IVMPTRN9",86,0)
 ;if the deletion flags were set in the IVM Patient file, unset them
"RTN","IVMPTRN9",87,0)
 I $G(DELETE("SET")) D
"RTN","IVMPTRN9",88,0)
 . N DATA
"RTN","IVMPTRN9",89,0)
 . S DATA(.08)="",DATA(.09)="",DATA(.1)="",DATA(.11)=""
"RTN","IVMPTRN9",90,0)
 . I $$UPD^DGENDBS(301.5,IVMPIEN,.DATA)
"RTN","IVMPTRN9",91,0)
 ;
"RTN","IVMPTRN9",92,0)
 ; create (ZBT) Beneficiary Travel segment based on last BT Claim
"RTN","IVMPTRN9",93,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZBT($$BTCLM^IVMUFNC4(DFN),"1,2,3,4,7")
"RTN","IVMPTRN9",94,0)
 ;
"RTN","IVMPTRN9",95,0)
 ; create (ZFE) Fee Basis segment(s)
"RTN","IVMPTRN9",96,0)
 D EN^FBHLZFE(DFN,"1,2,3,4,5")
"RTN","IVMPTRN9",97,0)
 F IVMSUB=0:0 S IVMSUB=+$O(FBZFE(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",98,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(FBZFE(+IVMSUB))
"RTN","IVMPTRN9",99,0)
 ;
"RTN","IVMPTRN9",100,0)
 ; create (ZSP) Service Period segment
"RTN","IVMPTRN9",101,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZSP(DFN,1,1)
"RTN","IVMPTRN9",102,0)
 ;
"RTN","IVMPTRN9",103,0)
 ; optionally create (OBX) segment for Patient Sensitivity Flag
"RTN","IVMPTRN9",104,0)
 K OBXTMP
"RTN","IVMPTRN9",105,0)
 S OBXCNT=0,GETCUR=$$FINDSEC^DGENSEC(DFN)
"RTN","IVMPTRN9",106,0)
 I GETCUR,$$GET^DGENSEC(GETCUR,.DGSEC) D
"RTN","IVMPTRN9",107,0)
 . Q:(DGSEC("LEVEL")'=1)&(DGSEC("LEVEL")'=0)
"RTN","IVMPTRN9",108,0)
 . S OBXTMP(2)="CE",OBXTMP(3)="38.1"_$E(HL("ECH"))_"SECURITY LOG"
"RTN","IVMPTRN9",109,0)
 . S:DGSEC("LEVEL") OBXTMP(5)="Y"_$E(HL("ECH"))_"YES"_$E(HL("ECH"))_"HL70136"
"RTN","IVMPTRN9",110,0)
 . S:'DGSEC("LEVEL") OBXTMP(5)="N"_$E(HL("ECH"))_"NO"_$E(HL("ECH"))_"HL70136"
"RTN","IVMPTRN9",111,0)
 . S OBXTMP(11)="R",OBXTMP(14)=DGSEC("DATETIME")
"RTN","IVMPTRN9",112,0)
 . S OBXTMP(16)="" I $G(DGSEC("SOURCE"))'="" D
"RTN","IVMPTRN9",113,0)
 . . S $P(OBXTMP(16),$E(HL("ECH")),14)=$E(HL("ECH"),4)_DGSEC("SOURCE")
"RTN","IVMPTRN9",114,0)
 . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
"RTN","IVMPTRN9",115,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.OBXTMP,OBXCNT,"2,3,5,11,14,16")
"RTN","IVMPTRN9",116,0)
 . I $G(OBXTMP(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(OBXTMP(16))
"RTN","IVMPTRN9",117,0)
 ;
"RTN","IVMPTRN9",118,0)
 ; create (OBX) segment for NTR
"RTN","IVMPTRN9",119,0)
 ; CALL PIMS API TO GET NTRARRY OF NTR DATA
"RTN","IVMPTRN9",120,0)
 S GETCUR=$$ENRGET^DGNTAPI1(DFN)
"RTN","IVMPTRN9",121,0)
 I GETCUR D NTROBX^IVMPTRNA(.DGNTARR)
"RTN","IVMPTRN9",122,0)
 I $D(NTROBX) D
"RTN","IVMPTRN9",123,0)
 . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
"RTN","IVMPTRN9",124,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.NTROBX,OBXCNT,"2,3,5,11,12,14,15,16,17")
"RTN","IVMPTRN9",125,0)
 . I $G(NTROBX(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(NTROBX(16))
"RTN","IVMPTRN9",126,0)
 . K NTROBX
"RTN","IVMPTRN9",127,0)
 ;
"RTN","IVMPTRN9",128,0)
 ; create (RF1) segment
"RTN","IVMPTRN9",129,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$RF1^IVMPTRNA(DFN,"SAD")
"RTN","IVMPTRN9",130,0)
 ; IVM*2.0*164 - Add Residential Address Change
"RTN","IVMPTRN9",131,0)
 F RF1TYP="CAD","CPH","PNO","EAD","PHH","RAD" D   ;Create Optional RF1 Segments
"RTN","IVMPTRN9",132,0)
 . S RF1SEG=$$RF1^IVMPTRNA(DFN,RF1TYP) Q:RF1SEG=""
"RTN","IVMPTRN9",133,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=RF1SEG
"RTN","IVMPTRN9",134,0)
 ;
"RTN","IVMPTRN9",135,0)
 Q
"RTN","IVMPTRN9",136,0)
 ;
"RTN","IVMPTRN9",137,0)
GETTYPE(DFN,IVMMTDT,CODE,HARDSHIP,ACTVIEN)      ;
"RTN","IVMPTRN9",138,0)
 ;Determines the type of test to include in the Z10.  HEC wants only the
"RTN","IVMPTRN9",139,0)
 ;test that they would consider primary,i.e., preference given to a comptleted means test, even if not currently in effect.
"RTN","IVMPTRN9",140,0)
 ;
"RTN","IVMPTRN9",141,0)
 ;Input:
"RTN","IVMPTRN9",142,0)
 ;  DFN
"RTN","IVMPTRN9",143,0)
 ;  IVMMTDT -date to be the search for the test
"RTN","IVMPTRN9",144,0)
 ;Output:
"RTN","IVMPTRN9",145,0)
 ;  Function value - type of test to send in Z10
"RTN","IVMPTRN9",146,0)
 ;  CODE - status code of test (pass by reference)
"RTN","IVMPTRN9",147,0)
 ;  HARDSHIP - hardship indicator (pass by reference)
"RTN","IVMPTRN9",148,0)
 ;  ACTVIEN - ien of test that should have the associated Income Relations (pass by reference)
"RTN","IVMPTRN9",149,0)
 ;
"RTN","IVMPTRN9",150,0)
 N TESTTYPE,MTNODE,RXNODE,NODE0,NODE2
"RTN","IVMPTRN9",151,0)
 S TESTTYPE=1
"RTN","IVMPTRN9",152,0)
 S (HARDSHIP,CODE,ACTVIEN)=""
"RTN","IVMPTRN9",153,0)
 Q:'$G(IVMMTDT) TESTTYPE
"RTN","IVMPTRN9",154,0)
 Q:'$G(DFN) TESTTYPE
"RTN","IVMPTRN9",155,0)
 ;
"RTN","IVMPTRN9",156,0)
 S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
"RTN","IVMPTRN9",157,0)
 S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
"RTN","IVMPTRN9",158,0)
 ;
"RTN","IVMPTRN9",159,0)
 I MTNODE="" S MTNODE=$$FUT^DGMTU(DFN,"",1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
"RTN","IVMPTRN9",160,0)
 I RXNODE="" S RXNODE=$$FUT^DGMTU(DFN,"",2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
"RTN","IVMPTRN9",161,0)
 D
"RTN","IVMPTRN9",162,0)
 . ;determine which test has the associated income relations
"RTN","IVMPTRN9",163,0)
 . ;
"RTN","IVMPTRN9",164,0)
 . I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
"RTN","IVMPTRN9",165,0)
 . I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
"RTN","IVMPTRN9",166,0)
 . I +MTNODE S ACTVIEN=+MTNODE Q
"RTN","IVMPTRN9",167,0)
 . I +RXNODE S ACTVIEN=+RXNODE Q
"RTN","IVMPTRN9",168,0)
 I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
"RTN","IVMPTRN9",169,0)
 ;
"RTN","IVMPTRN9",170,0)
 ;now find the primary test
"RTN","IVMPTRN9",171,0)
 I '(+MTNODE) G CHKCOPAY
"RTN","IVMPTRN9",172,0)
 S CODE=$P(MTNODE,"^",4)
"RTN","IVMPTRN9",173,0)
 S HARDSHIP=$P($G(^DGMT(408.31,+MTNODE,0)),"^",20)
"RTN","IVMPTRN9",174,0)
 I (CODE="")!("ACGP"'[CODE) S NODE2=$G(^DGMT(408.31,+MTNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("ACGP"'[CODE) G CHKCOPAY
"RTN","IVMPTRN9",175,0)
 ;
"RTN","IVMPTRN9",176,0)
 G QGETTYPE
"RTN","IVMPTRN9",177,0)
 ;
"RTN","IVMPTRN9",178,0)
CHKCOPAY        ;
"RTN","IVMPTRN9",179,0)
 I '(+RXNODE) G QGETTYPE
"RTN","IVMPTRN9",180,0)
 S CODE=$P(RXNODE,"^",4)
"RTN","IVMPTRN9",181,0)
 I (CODE="")!("EM"'[CODE) S NODE2=$G(^DGMT(408.31,+RXNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("EM"'[CODE) G QGETTYPE
"RTN","IVMPTRN9",182,0)
 S TESTTYPE=2
"RTN","IVMPTRN9",183,0)
 ;
"RTN","IVMPTRN9",184,0)
QGETTYPE        ;
"RTN","IVMPTRN9",185,0)
 Q TESTTYPE
"RTN","IVMPTRN9",186,0)
 ;
"RTN","IVMPTRN9",187,0)
FILTER(DFN)     ; address transmission filter
"RTN","IVMPTRN9",188,0)
 ; Check Bad Address Indicator for a known bad address and
"RTN","IVMPTRN9",189,0)
 ; Scrutinize the Street Address line 1 field for known bad address
"RTN","IVMPTRN9",190,0)
 ; strings based on functionality currently in place in HEC Legacy.
"RTN","IVMPTRN9",191,0)
 ;
"RTN","IVMPTRN9",192,0)
 ;  Input: DFN - ien of the Patient (#2) file
"RTN","IVMPTRN9",193,0)
 ; Output:   0 - filter passed (ok to transmit address)
"RTN","IVMPTRN9",194,0)
 ;           1 - filter failed (do not transmit address)
"RTN","IVMPTRN9",195,0)
 ;
"RTN","IVMPTRN9",196,0)
 N VAPA
"RTN","IVMPTRN9",197,0)
 Q:'$G(DFN) 1  ;DFN missing
"RTN","IVMPTRN9",198,0)
 Q:$$BADADR^DGUTL3(DFN) 1  ;check Bad Address Indicator
"RTN","IVMPTRN9",199,0)
 D ADD^VADPT  ;get patient address
"RTN","IVMPTRN9",200,0)
 ; Street Address Line 1 or Zip Code is <null>
"RTN","IVMPTRN9",201,0)
 Q:($G(VAPA(1))="")!($P($G(VAPA(11)),"^")="") 1
"RTN","IVMPTRN9",202,0)
 ; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or 'ADDRESS'
"RTN","IVMPTRN9",203,0)
 Q:(VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)["ADDRESS") 1
"RTN","IVMPTRN9",204,0)
 ; The first two characters of the address is equal to '**'
"RTN","IVMPTRN9",205,0)
 Q:$E(VAPA(1),1,2)="**" 1
"RTN","IVMPTRN9",206,0)
 ; passed all address filters - ok to send
"RTN","IVMPTRN9",207,0)
 Q 0
"RTN","IVMPTRNA")
0^1^B16853619
"RTN","IVMPTRNA",1,0)
IVMPTRNA ;ALB/CKN,BRM,TDM,LBD,KUM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER(CONTINUED) ;15 Dec 2017  9:13 AM
"RTN","IVMPTRNA",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**46,58,76,105,152,164**;21-OCT-94;Build 98
"RTN","IVMPTRNA",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IVMPTRNA",4,0)
 ;
"RTN","IVMPTRNA",5,0)
 Q
"RTN","IVMPTRNA",6,0)
NTROBX(DGNTARR) ;
"RTN","IVMPTRNA",7,0)
 N NTRTEMP,I,CS,RS,SS
"RTN","IVMPTRNA",8,0)
 I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
"RTN","IVMPTRNA",9,0)
 I $G(HLFS)'="^" N HLFS S HLFS="^"
"RTN","IVMPTRNA",10,0)
 S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
"RTN","IVMPTRNA",11,0)
 S NTRTEMP("NTR","Y")="1"_CS_"Received NTR Trmt"_CS_"VA0053"
"RTN","IVMPTRNA",12,0)
 S NTRTEMP("AVI","Y")="2"_CS_"Aviator Pre 1955"_CS_"VA0053"
"RTN","IVMPTRNA",13,0)
 S NTRTEMP("SUB","Y")="3"_CS_"Sub Trainee pre 1965"_CS_"VA0053"
"RTN","IVMPTRNA",14,0)
 S NTRTEMP("HNC","Y")="4"_CS_"Dx With Head Neck Cancer"_CS_"VA0053"
"RTN","IVMPTRNA",15,0)
 S NTRTEMP("NTR","N")="5"_CS_"No NTR Trmt"_CS_"VA0053"
"RTN","IVMPTRNA",16,0)
 S NTRTEMP("AVI","N")="6"_CS_"Not Aviator Pre 1955"_CS_"VA0053"
"RTN","IVMPTRNA",17,0)
 S NTRTEMP("SUB","N")="7"_CS_"Not Sub Trainee pre 1965"_CS_"VA0053"
"RTN","IVMPTRNA",18,0)
 S NTRTEMP("HNC","N")="8"_CS_"Not Dx With Head Neck Cancer"_CS_"VA0053"
"RTN","IVMPTRNA",19,0)
 S NTRTEMP("NTR","U")="9"_CS_"NTR Trmt Unknown"_CS_"VA0053"
"RTN","IVMPTRNA",20,0)
 S NTRTEMP("VER","M")="M"_CS_"Military Med Rec"_CS_"VA0052"
"RTN","IVMPTRNA",21,0)
 S NTRTEMP("VER","S")="S"_CS_"Qual Military Srvc"_CS_"VA0052"
"RTN","IVMPTRNA",22,0)
 S NTRTEMP("VER","N")="N"_CS_"Not Qualified"_CS_"VA0052"
"RTN","IVMPTRNA",23,0)
 S NTROBX(2)="CE",NTROBX(3)="VISTA"_CS_"28.11"
"RTN","IVMPTRNA",24,0)
 S NTROBX(5)=""
"RTN","IVMPTRNA",25,0)
 F I="NTR","AVI","SUB","HNC" D
"RTN","IVMPTRNA",26,0)
 . I $G(DGNTARR(I))="" Q
"RTN","IVMPTRNA",27,0)
 . I NTROBX(5)'="" S NTROBX(5)=$G(NTROBX(5))_RS
"RTN","IVMPTRNA",28,0)
 . S NTROBX(5)=$G(NTROBX(5))_$G(NTRTEMP(I,$G(DGNTARR(I))))
"RTN","IVMPTRNA",29,0)
 S NTROBX(11)="F"
"RTN","IVMPTRNA",30,0)
 S NTROBX(12)=$G(DGNTARR("HDT"))
"RTN","IVMPTRNA",31,0)
 S NTROBX(14)=$G(DGNTARR("VDT"))
"RTN","IVMPTRNA",32,0)
 I $G(DGNTARR("VSIT"))'="" D
"RTN","IVMPTRNA",33,0)
 . S NTROBX(15)=$P($G(^DIC(4,DGNTARR("VSIT"),99)),"^")
"RTN","IVMPTRNA",34,0)
 S NTROBX(16)=""
"RTN","IVMPTRNA",35,0)
 I $G(DGNTARR("HSIT"))'="" D
"RTN","IVMPTRNA",36,0)
 . S $P(NTROBX(16),CS,14)=SS_$P($G(^DIC(4,DGNTARR("HSIT"),99)),"^")
"RTN","IVMPTRNA",37,0)
 I $G(DGNTARR("VER"))'="" S NTROBX(17)=$G(NTRTEMP("VER",$G(DGNTARR("VER"))))
"RTN","IVMPTRNA",38,0)
 Q
"RTN","IVMPTRNA",39,0)
RF1(DFN,RF1TYP) ; create RF1 segment
"RTN","IVMPTRNA",40,0)
 ;  Input:
"RTN","IVMPTRNA",41,0)
 ;        DFN - Patient IEN
"RTN","IVMPTRNA",42,0)
 ;     RF1TYP - RF1 Type
"RTN","IVMPTRNA",43,0)
 ;              SAD = Street Address Change (Default)
"RTN","IVMPTRNA",44,0)
 ;              CAD = Confidential Address Change
"RTN","IVMPTRNA",45,0)
 ;              CPH = Cell Phone Number Change
"RTN","IVMPTRNA",46,0)
 ;              PNO = Pager Number Change
"RTN","IVMPTRNA",47,0)
 ;              EAD = E-Mail Address Change
"RTN","IVMPTRNA",48,0)
 ;              PHH = Home Phone Number Change
"RTN","IVMPTRNA",49,0)
 ;              RAD   Residential Address Change
"RTN","IVMPTRNA",50,0)
 ;
"RTN","IVMPTRNA",51,0)
 ;  Output: RF1 segment
"RTN","IVMPTRNA",52,0)
 ;
"RTN","IVMPTRNA",53,0)
 N X,Y,ADDRSRC,ADRSRC,ADRSIT,ADTDT,I,CS,RS,SS,HLQ,RETURN,RFDAT,ERR
"RTN","IVMPTRNA",54,0)
 I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
"RTN","IVMPTRNA",55,0)
 I $G(HLFS)'="^" N HLFS S HLFS="^"
"RTN","IVMPTRNA",56,0)
 S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2),HLQ=""""
"RTN","IVMPTRNA",57,0)
 S:$G(RF1TYP)="" RF1TYP="SAD"   ;Set type to 'SAD' if no value passed
"RTN","IVMPTRNA",58,0)
 ; initialize the RETURN variable
"RTN","IVMPTRNA",59,0)
 S RETURN="RF1",$P(RETURN,HLFS,4)=RF1TYP,$P(RETURN,HLFS,11)=""
"RTN","IVMPTRNA",60,0)
 Q:'$G(DFN) RETURN
"RTN","IVMPTRNA",61,0)
 ;I RF1TYP="SAD",$$BADADR^DGUTL3(DFN) Q RETURN
"RTN","IVMPTRNA",62,0)
 D RF1LOAD(RF1TYP) Q:$D(ERR) RETURN
"RTN","IVMPTRNA",63,0)
 I RF1TYP'="SAD",$G(ADRDT)="" Q ""
"RTN","IVMPTRNA",64,0)
 ; RF1 SEQ 1-2 are not currently used
"RTN","IVMPTRNA",65,0)
 ; RF1 SEQ 3
"RTN","IVMPTRNA",66,0)
 S $P(RETURN,HLFS,4)=RF1TYP
"RTN","IVMPTRNA",67,0)
 ; RF1 SEQ 4-5 are not currently used
"RTN","IVMPTRNA",68,0)
 ; RF1 SEQ 6
"RTN","IVMPTRNA",69,0)
 S $P(RETURN,HLFS,7)=$G(ADRSIT)
"RTN","IVMPTRNA",70,0)
 S:$G(ADRSRC)'="" $P(RETURN,HLFS,7)=$P(RETURN,HLFS,7)_CS_ADRSRC
"RTN","IVMPTRNA",71,0)
 ; RF1 SEQ 7
"RTN","IVMPTRNA",72,0)
 S $P(RETURN,HLFS,8)=$G(ADRDT)
"RTN","IVMPTRNA",73,0)
 ; RF1 SEQ 8-11 are not currently used
"RTN","IVMPTRNA",74,0)
 ; quit with completed RF1 segment
"RTN","IVMPTRNA",75,0)
 Q RETURN
"RTN","IVMPTRNA",76,0)
 ;
"RTN","IVMPTRNA",77,0)
ADDRCNV(ADDRSRC) ;convert Address Source to HL7 format
"RTN","IVMPTRNA",78,0)
 Q:$G(ADDRSRC)']"" ""
"RTN","IVMPTRNA",79,0)
 Q:ADDRSRC="HEC" "USVAHEC"
"RTN","IVMPTRNA",80,0)
 Q:ADDRSRC="VAMC" "USVAMC"
"RTN","IVMPTRNA",81,0)
 Q:ADDRSRC="HBSC" "USVAHBSC"
"RTN","IVMPTRNA",82,0)
 Q:ADDRSRC="NCOA" "USNCOA"
"RTN","IVMPTRNA",83,0)
 Q:ADDRSRC="BVA" "USVABVA"
"RTN","IVMPTRNA",84,0)
 Q:ADDRSRC="VAINS" "USVAINS"
"RTN","IVMPTRNA",85,0)
 Q:ADDRSRC="USPS" "USPS"
"RTN","IVMPTRNA",86,0)
 Q:ADDRSRC="LACS" "LACS"
"RTN","IVMPTRNA",87,0)
 Q:ADDRSRC="VET360" "VET360"
"RTN","IVMPTRNA",88,0)
 Q ""
"RTN","IVMPTRNA",89,0)
 ;
"RTN","IVMPTRNA",90,0)
RF1LOAD(RF1TYP) ;
"RTN","IVMPTRNA",91,0)
 N RFDT,RFSRC,RFSIT,GETFLDS,RFDAT,ERR
"RTN","IVMPTRNA",92,0)
 K ADRDT,ADRSRC,ADRSIT
"RTN","IVMPTRNA",93,0)
 I RF1TYP="SAD" S RFDT=.118,RFSRC=.119,RFSIT=.12
"RTN","IVMPTRNA",94,0)
 I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14113
"RTN","IVMPTRNA",95,0)
 I RF1TYP="CPH" S RFDT=.139,RFSRC=.1311,RFSIT=.13111
"RTN","IVMPTRNA",96,0)
 I RF1TYP="PNO" S RFDT=.1312,RFSRC=.1313,RFSIT=.1314
"RTN","IVMPTRNA",97,0)
 I RF1TYP="EAD" S RFDT=.136,RFSRC=.137,RFSIT=.138
"RTN","IVMPTRNA",98,0)
 I RF1TYP="PHH" S RFDT=.1321,RFSRC=.1322,RFSIT=.1323
"RTN","IVMPTRNA",99,0)
 ; IVM*2.0*164 - Add Residential Address Change
"RTN","IVMPTRNA",100,0)
 I RF1TYP="RAD" S RFDT=.1158,RFSRC=.11582,RFSIT=.11581
"RTN","IVMPTRNA",101,0)
 S GETFLDS=RFDT S:RFSRC'="" GETFLDS=GETFLDS_";"_RFSRC S GETFLDS=GETFLDS_";"_RFSIT
"RTN","IVMPTRNA",102,0)
 D GETS^DIQ(2,DFN_",",GETFLDS,"IE","RFDAT","ERR") Q:$D(ERR)
"RTN","IVMPTRNA",103,0)
 S ADRDT=$$FMTHL7^XLFDT($G(RFDAT(2,DFN_",",RFDT,"I")))
"RTN","IVMPTRNA",104,0)
 S:RFSRC'="" ADRSRC=$$EXTERNAL^DILFD(2,RFSRC,"",$G(RFDAT(2,DFN_",",RFSRC,"I")))
"RTN","IVMPTRNA",105,0)
 ; only populate Change Site if Source=VAMC or NO Source Field
"RTN","IVMPTRNA",106,0)
 I ($G(ADRSRC)="VAMC")!(RFSRC="") D
"RTN","IVMPTRNA",107,0)
 . S ADRSIT=$G(RFDAT(2,DFN_",",RFSIT,"I"))
"RTN","IVMPTRNA",108,0)
 . S:ADRSIT]"" ADRSIT=$$GET1^DIQ(4,ADRSIT_",",99)
"RTN","IVMPTRNA",109,0)
 S ADRSRC=$$ADDRCNV($G(ADRSRC))  ;convert source to HL7 format
"RTN","IVMPTRNA",110,0)
 Q
"VER")
8.0^22.2
**INSTALL NAME**
EAS*1.0*151
"BLD",10224,0)
EAS*1.0*151^ENROLLMENT APPLICATION SYSTEM^0^3181105^y
"BLD",10224,1,0)
^^2^2^3180213^
"BLD",10224,1,1,0)
Please see the EAS*1.0*151 patch description for detailed information 
"BLD",10224,1,2,0)
regarding this patch.
"BLD",10224,4,0)
^9.64PA^^
"BLD",10224,6.3)
70
"BLD",10224,"ABPKG")
n
"BLD",10224,"KRN",0)
^9.67PA^779.2^20
"BLD",10224,"KRN",.4,0)
.4
"BLD",10224,"KRN",.401,0)
.401
"BLD",10224,"KRN",.402,0)
.402
"BLD",10224,"KRN",.402,"NM",0)
^9.68A^^0
"BLD",10224,"KRN",.403,0)
.403
"BLD",10224,"KRN",.5,0)
.5
"BLD",10224,"KRN",.84,0)
.84
"BLD",10224,"KRN",3.6,0)
3.6
"BLD",10224,"KRN",3.6,"NM",0)
^9.68A^^0
"BLD",10224,"KRN",3.8,0)
3.8
"BLD",10224,"KRN",3.8,"NM",0)
^9.68A^^0
"BLD",10224,"KRN",9.2,0)
9.2
"BLD",10224,"KRN",9.2,"NM",0)
^9.68A^^0
"BLD",10224,"KRN",9.8,0)
9.8
"BLD",10224,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",10224,"KRN",9.8,"NM",1,0)
EASAILK1^^0^B76310280
"BLD",10224,"KRN",9.8,"NM","B","EASAILK1",1)

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

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

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

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

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

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

"BLD",10224,"KRN","B",3.6,3.6)

"BLD",10224,"KRN","B",3.8,3.8)

"BLD",10224,"KRN","B",9.2,9.2)

"BLD",10224,"KRN","B",9.8,9.8)

"BLD",10224,"KRN","B",19,19)

"BLD",10224,"KRN","B",19.1,19.1)

"BLD",10224,"KRN","B",101,101)

"BLD",10224,"KRN","B",409.61,409.61)

"BLD",10224,"KRN","B",771,771)

"BLD",10224,"KRN","B",779.2,779.2)

"BLD",10224,"KRN","B",870,870)

"BLD",10224,"KRN","B",8989.51,8989.51)

"BLD",10224,"KRN","B",8989.52,8989.52)

"BLD",10224,"KRN","B",8994,8994)

"BLD",10224,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",10224,"QUES",0)
^9.62^^
"BLD",10224,"REQB",0)
^9.611^2^1
"BLD",10224,"REQB",2,0)
EAS*1.0*70^1
"BLD",10224,"REQB","B","EAS*1.0*70",2)

"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)
151^3181105^101100
"PKG",187,22,1,"PAH",1,1,0)
^^2^2^3181105
"PKG",187,22,1,"PAH",1,1,1,0)
Please see the EAS*1.0*151 patch description for detailed information 
"PKG",187,22,1,"PAH",1,1,2,0)
regarding this patch.
"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","EASAILK1")
0^1^B76310280
"RTN","EASAILK1",1,0)
EASAILK1 ;ALB/BRM,ERC,JAM - Patient Address Inquiry ;18 Jul 2017  4:03 PM
"RTN","EASAILK1",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**13,29,39,70,151**;Mar 15, 2001;Build 70
"RTN","EASAILK1",3,0)
 ;
"RTN","EASAILK1",4,0)
 ;*151*; JAM - Add Residential Address and modify Permanent, Confidential, and Temporary address field labels and reformat the output
"RTN","EASAILK1",5,0)
 ;
"RTN","EASAILK1",6,0)
PATADDR ;view patient address
"RTN","EASAILK1",7,0)
 ;
"RTN","EASAILK1",8,0)
 N PATNAM,IENS,ZTSAVE
"RTN","EASAILK1",9,0)
 N DTOUT,DUOUT,DIRUT,DIROUT,%ZIS,DIC,DA,DIQ,DLAYGO,Y,X
"RTN","EASAILK1",10,0)
 ;
"RTN","EASAILK1",11,0)
 ; prompt user for patient name and device
"RTN","EASAILK1",12,0)
 S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC
"RTN","EASAILK1",13,0)
 Q:($D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!(Y=-1))
"RTN","EASAILK1",14,0)
 S %ZIS="Q"
"RTN","EASAILK1",15,0)
 S IENS=+Y_",",PATNAM=$P(Y,"^",2)
"RTN","EASAILK1",16,0)
 S ZTSAVE("IENS")="",ZTSAVE("PATNAM")=""
"RTN","EASAILK1",17,0)
 D EN^XUTMDEVQ("QUE^EASAILK1","PATIENT ADDRESS INQUIRY",.ZTSAVE,.%ZIS)
"RTN","EASAILK1",18,0)
 Q
"RTN","EASAILK1",19,0)
QUE ;
"RTN","EASAILK1",20,0)
 N DGC,CONOK,PATOK,TMPOK,FLD,CONARR,TMPARR,PATARR,CONERR,TMPERR,PATERR
"RTN","EASAILK1",21,0)
 N CONSTR,TMPSTR,PATSTR,TYPE,CONFARR,TEMPARR
"RTN","EASAILK1",22,0)
 ;
"RTN","EASAILK1",23,0)
PAT ;patient address
"RTN","EASAILK1",24,0)
 N PATOK
"RTN","EASAILK1",25,0)
 D GETS^DIQ(2,IENS,".111:.121","E","PATARR","PATERR")
"RTN","EASAILK1",26,0)
 W !?23,"Patient Name: ",?37,PATNAM
"RTN","EASAILK1",27,0)
 ; exit if error occurs during DIQ call
"RTN","EASAILK1",28,0)
 ; EAS*1.0*151; JAM; Change label to Permanent Mailing Address 
"RTN","EASAILK1",29,0)
 I $D(PATERR) W !!?11,"There is invalid data in the Permanent Mailing Address",!?11,"Please use Registration options to edit",!! G CON
"RTN","EASAILK1",30,0)
 ;
"RTN","EASAILK1",31,0)
 ; exit if there is no address for patient
"RTN","EASAILK1",32,0)
 S FLD="",PATOK=0
"RTN","EASAILK1",33,0)
 D OK(.PATARR,.PATOK)
"RTN","EASAILK1",34,0)
 ; EAS*1.0*151; JAM; Change label to Permanent Mailing Address 
"RTN","EASAILK1",35,0)
 I 'PATOK W !!?11,"*** No Permanent Mailing Address On File For This Patient ***",!! G CON
"RTN","EASAILK1",36,0)
 ;set a string of the field numbers needed for the patient address
"RTN","EASAILK1",37,0)
 S PATSTR=".111^.112^.113^.114^.115^.1112^.1173^.121^.118^.119^.12^^^.1171^.1172"
"RTN","EASAILK1",38,0)
 N STRARR
"RTN","EASAILK1",39,0)
 D STRG(PATSTR,.STRARR) ;place the fld numbers into an array
"RTN","EASAILK1",40,0)
 ; EAS*1.0*151; JAM; Change TYPE to "Permanent Mailing" (from "Patient")  
"RTN","EASAILK1",41,0)
 S TYPE="Permanent Mailing"
"RTN","EASAILK1",42,0)
 S DGC=1
"RTN","EASAILK1",43,0)
 ;display the patient address information
"RTN","EASAILK1",44,0)
 D DISP(TYPE,.PATARR,.STRARR)
"RTN","EASAILK1",45,0)
 ;
"RTN","EASAILK1",46,0)
CON ;confidential address
"RTN","EASAILK1",47,0)
 N CONARR,CONERR,CONOK,DGJ
"RTN","EASAILK1",48,0)
 S CONOK=0
"RTN","EASAILK1",49,0)
 D GETS^DIQ(2,IENS,".141*;.14105;.1411:.142","IE","CONARR","CONERR")
"RTN","EASAILK1",50,0)
 I $D(CONERR) S CONOK=-1 G TMP
"RTN","EASAILK1",51,0)
 S FLD=""
"RTN","EASAILK1",52,0)
 D OK(.CONARR,.CONOK) ;checking for presence of confid address array
"RTN","EASAILK1",53,0)
 I $G(CONARR(2,IENS,.14105,"E"))'="YES" S CONOK=0 G TMP
"RTN","EASAILK1",54,0)
 ;treat null end date as if in the future
"RTN","EASAILK1",55,0)
 I DT'<$G(CONARR(2,IENS,.1417,"I")),$G(CONARR(2,IENS,.1418,"I"))']"" G CON2
"RTN","EASAILK1",56,0)
 I DT>$G(CONARR(2,IENS,.1418,"I")) S CONOK=0 G TMP ;if date range in the past, don't display
"RTN","EASAILK1",57,0)
 I DT<$G(CONARR(2,IENS,.1417,"I")) S CONOK=0 G TMP ;if date range in the future, dont display
"RTN","EASAILK1",58,0)
CON2 ;
"RTN","EASAILK1",59,0)
 S DGJ=""
"RTN","EASAILK1",60,0)
 S CONOK=0 ;now check for active E/E confid address
"RTN","EASAILK1",61,0)
 F  S DGJ=$O(CONARR(2.141,DGJ)) Q:DGJ']""  D
"RTN","EASAILK1",62,0)
 . I CONARR(2.141,DGJ,.01,"E")["ELIG" D
"RTN","EASAILK1",63,0)
 . . I CONARR(2.141,DGJ,1,"E")="YES" S CONOK=1
"RTN","EASAILK1",64,0)
 I 'CONOK G TMP
"RTN","EASAILK1",65,0)
 ;set string of the field numbers needed for the confidential address
"RTN","EASAILK1",66,0)
 S CONSTR=".1411^.1412^.1413^.1414^.1415^.1416^.14116^^.14112^^.14113^.1417^.1418^.14114^.14115"
"RTN","EASAILK1",67,0)
 N CONFARR
"RTN","EASAILK1",68,0)
 D STRG(.CONSTR,.CONFARR) ;place field numbers into an array
"RTN","EASAILK1",69,0)
 ;
"RTN","EASAILK1",70,0)
TMP ;temporary address
"RTN","EASAILK1",71,0)
 N TMPARR,TMPERR,TMPOK
"RTN","EASAILK1",72,0)
 S TMPOK=0
"RTN","EASAILK1",73,0)
 D GETS^DIQ(2,IENS,".12105;.1211:.1219;.1221:.1223","IE","TMPARR","TMPERR")
"RTN","EASAILK1",74,0)
 ; EAS*1.0*151; JAM; Add Residential Address
"RTN","EASAILK1",75,0)
 I $D(TMPERR) S TMPOK=-1 G RES
"RTN","EASAILK1",76,0)
 S FLD=""
"RTN","EASAILK1",77,0)
 D OK(.TMPARR,.TMPOK) ;check for presence of temp address array
"RTN","EASAILK1",78,0)
 I 'TMPOK G RES
"RTN","EASAILK1",79,0)
 I $G(TMPARR(2,IENS,.12105,"E"))'="YES" S TMPOK=0 G RES
"RTN","EASAILK1",80,0)
 ;treat null end date as if in the future
"RTN","EASAILK1",81,0)
 I DT'<$G(TMPARR(2,IENS,.1217,"I")),($G(TMPARR(2,IENS,.1218,"I")))']"" G TMP2
"RTN","EASAILK1",82,0)
 I DT>$G(TMPARR(2,IENS,.1218,"I")) S TMPOK=0 ;if date range in the past, don't display
"RTN","EASAILK1",83,0)
TMP2 ;
"RTN","EASAILK1",84,0)
 ; EAS*1.0*151; JAM; Add Residential Address
"RTN","EASAILK1",85,0)
 I 'TMPOK G RES
"RTN","EASAILK1",86,0)
 N TEMPARR
"RTN","EASAILK1",87,0)
 ;set string of the field numbers needed for the temporary address
"RTN","EASAILK1",88,0)
 S TMPSTR=".1211^.1212^.1213^.1214^.1215^.12112^.1223^^.12113^^.12114^.1217^.1218^.1221^.1222"
"RTN","EASAILK1",89,0)
 D STRG(.TMPSTR,.TEMPARR) ;place field numbers into an array
"RTN","EASAILK1",90,0)
 ;
"RTN","EASAILK1",91,0)
 ; EAS*1.0*151; JAM; Add Residential Address 
"RTN","EASAILK1",92,0)
RES ;gather residential address
"RTN","EASAILK1",93,0)
 N RESARR,RESERR,RESOK,RESSTR
"RTN","EASAILK1",94,0)
 S RESOK=0
"RTN","EASAILK1",95,0)
 D GETS^DIQ(2,IENS,".1151:.11582","IE","RESARR","RESERR")
"RTN","EASAILK1",96,0)
 ;D GETS^DIQ(2,IENS,".115*;.14105;.1411:.142","IE","CONARR","CONERR")
"RTN","EASAILK1",97,0)
 I $D(RESERR) S RESOK=-1 G OPT
"RTN","EASAILK1",98,0)
 S FLD=""
"RTN","EASAILK1",99,0)
 D OK(.RESARR,.RESOK) ;checking for presence of residential address array
"RTN","EASAILK1",100,0)
 ;treat null end date as if in the future
"RTN","EASAILK1",101,0)
 I DT'<$G(RESARR(2,IENS,.1161,"I")),$G(RESARR(2,IENS,.1162,"I"))']"" G RES2
"RTN","EASAILK1",102,0)
 I DT>$G(RESARR(2,IENS,.1162,"I")) S RESOK=0 G OPT ;if date range in the past, don't display
"RTN","EASAILK1",103,0)
 I DT<$G(RESARR(2,IENS,.1161,"I")) S RESOK=0 G OPT ;if date range in the future, dont display
"RTN","EASAILK1",104,0)
RES2 ;
"RTN","EASAILK1",105,0)
 I 'RESOK G OPT
"RTN","EASAILK1",106,0)
 ;set string of the field numbers needed for the residential address
"RTN","EASAILK1",107,0)
 S RESSTR=".1151^.1152^.1153^.1154^.1155^.1156^.11573^^.1158^.11582^.11581^.1161^.1162^.11571^.11572"
"RTN","EASAILK1",108,0)
 N RESIDARR
"RTN","EASAILK1",109,0)
 D STRG(.RESSTR,.RESIDARR) ;place field numbers into an array
"RTN","EASAILK1",110,0)
 ;
"RTN","EASAILK1",111,0)
OPT ;let user decide to see confid. a/o temp address, residential address if disp. on screen
"RTN","EASAILK1",112,0)
 N DGELIG,DGEND,DGOPT,DGPROMPT,DIR,DGRET
"RTN","EASAILK1",113,0)
 S DGEND=0
"RTN","EASAILK1",114,0)
 ; EAS*1.0*151; JAM; Add Residential Address to address choices
"RTN","EASAILK1",115,0)
 I RESOK'=1 D
"RTN","EASAILK1",116,0)
 .S DGOPT=$S(CONOK=1&(TMPOK=1):3,CONOK=1&(TMPOK=0):2,TMPOK=1&(CONOK=0):1,1:"")
"RTN","EASAILK1",117,0)
 E  D
"RTN","EASAILK1",118,0)
 .S DGOPT=$S(CONOK=1&(TMPOK=1):4,CONOK=1&(TMPOK=0):5,TMPOK=1&(CONOK=0):6,1:7)
"RTN","EASAILK1",119,0)
 I DGOPT']"" S DGOPT=$S(CONOK=-1&(TMPOK=-1):8,CONOK=-1:9,TMPOK=-1:10,1:"")
"RTN","EASAILK1",120,0)
 ; EAS*1.0*151; JAM; Change label to Confidential and add Residential Address 
"RTN","EASAILK1",121,0)
 I $G(DGOPT)="" W !?5,PATNAM_" has no Temporary, Confidential or ",!?5,"Residential Address." W !! G END
"RTN","EASAILK1",122,0)
 I $G(DGOPT)>7 D
"RTN","EASAILK1",123,0)
 . W !?11,"There is invalid data in the "_$S(DGOPT=8:"Temporary and Confidential ",DGOPT=9:"Confidential ",10:"Temporary ")_"address"_$S(DGOPT=8:"es.",1:".")
"RTN","EASAILK1",124,0)
 . W !?11,"Please use Registration options to edit.",!!
"RTN","EASAILK1",125,0)
 I $E(IOST,1,2)["C-" D
"RTN","EASAILK1",126,0)
 . S DIR(0)="YAO",DIR("B")="Yes"
"RTN","EASAILK1",127,0)
 . ; EAS*1.0*151; JAM; - change labels from "Elig/Enroll Confidential" to "Conf Mailing" and "Temporary" to "Temp Mailing"
"RTN","EASAILK1",128,0)
 . ;  and add Residential Address (add logic to test for residential address and add to prompt)
"RTN","EASAILK1",129,0)
 . S DGELIG="Conf Mailing"
"RTN","EASAILK1",130,0)
 . S DGPROMPT=$S(DGOPT=3:DGELIG_" and Temp Mailing",DGOPT=2:DGELIG,DGOPT=1:"Temporary Mailing",DGOPT=4:DGELIG_", Temp Mailing and Residential",DGOPT=5:DGELIG_" and Residential",1:"")
"RTN","EASAILK1",131,0)
 . I $G(DGPROMPT)="" S DGPROMPT=$S(DGOPT=6:"Temporary Mailing and Residential",DGOPT=7:"Residential",1:"")
"RTN","EASAILK1",132,0)
 . I $G(DGPROMPT)="" S DGEND=1 Q
"RTN","EASAILK1",133,0)
 . S DIR("A")="Would you like to view the "_DGPROMPT_" Address"_$S((DGOPT>2&(DGOPT<7)):"es",1:"")_"? "
"RTN","EASAILK1",134,0)
 . D ^DIR K DIR
"RTN","EASAILK1",135,0)
 . I Y'=1 S DGEND=1
"RTN","EASAILK1",136,0)
 I DGEND=1 G END
"RTN","EASAILK1",137,0)
 S DGC=2
"RTN","EASAILK1",138,0)
 ;
"RTN","EASAILK1",139,0)
 ;if displayed on screen offer to show addresses and do a page break for readability.
"RTN","EASAILK1",140,0)
 I DGC>1 D
"RTN","EASAILK1",141,0)
 . I $E(IOST,1,2)["C-" W @IOF
"RTN","EASAILK1",142,0)
 . W !!?23,"Patient Name: ",?37,PATNAM
"RTN","EASAILK1",143,0)
 ;display the addresses that are populated
"RTN","EASAILK1",144,0)
 ; EAS*1.0*151; JAM; Modify address labels to Confid Mailing and Temp Mailing and add Residential address
"RTN","EASAILK1",145,0)
 I CONOK=1 S TYPE="   Confid Mailing" D DISP(TYPE,.CONARR,.CONFARR)
"RTN","EASAILK1",146,0)
 I TMPOK=1 S TYPE="     Temp Mailing" D DISP(TYPE,.TMPARR,.TEMPARR)
"RTN","EASAILK1",147,0)
 ; DGOPT=4 means all 3 addresses are present, so we should paginate the display prior to displaying residential address
"RTN","EASAILK1",148,0)
 I DGOPT=4 I $G(IOST)["C-" R !,"Enter <RETURN> to continue.",DGRET:DTIME W !
"RTN","EASAILK1",149,0)
 I RESOK=1 S TYPE="      Residential" D DISP(TYPE,.RESARR,.RESIDARR)
"RTN","EASAILK1",150,0)
 ; EAS*1.0*151; JAM; Modify messages to "Confidential Mailing Address" and "Temporary Mailing" and add Residential Address message
"RTN","EASAILK1",151,0)
 I 'CONOK W !?8,"Patient "_PATNAM_" has no Confidential Mailing Address."
"RTN","EASAILK1",152,0)
 I 'TMPOK W !?8,"Patient "_PATNAM_" has no Temporary Mailing Address."
"RTN","EASAILK1",153,0)
 I 'RESOK W !?8,"Patient "_PATNAM_" has no Residential Address."
"RTN","EASAILK1",154,0)
 W !
"RTN","EASAILK1",155,0)
 G END
"RTN","EASAILK1",156,0)
 ;
"RTN","EASAILK1",157,0)
OK(ARR,OK) ;check for presence of an array
"RTN","EASAILK1",158,0)
 F  S FLD=$O(ARR(2,IENS,FLD)) Q:'FLD!(OK)  S:$G(ARR(2,IENS,FLD,"E"))]"" OK=1
"RTN","EASAILK1",159,0)
 Q
"RTN","EASAILK1",160,0)
 ;
"RTN","EASAILK1",161,0)
STRG(STR,STRARR) ;set the field string into an array
"RTN","EASAILK1",162,0)
 N DGD
"RTN","EASAILK1",163,0)
 F DGD=1:1:15  S STRARR(DGD)=$P(STR,U,DGD)
"RTN","EASAILK1",164,0)
 Q
"RTN","EASAILK1",165,0)
 ;
"RTN","EASAILK1",166,0)
 ;display address information
"RTN","EASAILK1",167,0)
DISP(TYPE,ARR,STR) ;
"RTN","EASAILK1",168,0)
 N DGCNTRY,DGUSA
"RTN","EASAILK1",169,0)
 S DGUSA=0 ;I country=USA or "" display state/zip, E prov/postal code
"RTN","EASAILK1",170,0)
 S:$G(ARR(2,IENS,$G(STR(7)),"E"))="USA" DGUSA=1
"RTN","EASAILK1",171,0)
 S:$G(ARR(2,IENS,$G(STR(7)),"E"))']"" DGUSA=1
"RTN","EASAILK1",172,0)
 W !?10,TYPE_" Address: ",?37,$S($G(ARR(2,IENS,$G(STR(1)),"E"))]"":ARR(2,IENS,STR(1),"E"),1:"UNKNOWN STREET ADDRESS")
"RTN","EASAILK1",173,0)
 W:$G(ARR(2,IENS,$G(STR(2)),"E"))]"" !?37,ARR(2,IENS,STR(2),"E")
"RTN","EASAILK1",174,0)
 W:$G(ARR(2,IENS,STR(3),"E"))]"" !?37,ARR(2,IENS,STR(3),"E")
"RTN","EASAILK1",175,0)
 I DGUSA D  ;US address or null country which defaults to US
"RTN","EASAILK1",176,0)
 . W !?37,$S($G(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
"RTN","EASAILK1",177,0)
 . W $S($G(ARR(2,IENS,STR(5),"E"))]"":ARR(2,IENS,STR(5),"E"),1:"UNKNOWN STATE")_" "
"RTN","EASAILK1",178,0)
 . W:$G(ARR(2,IENS,STR(6),"E"))]"" ARR(2,IENS,STR(6),"E")
"RTN","EASAILK1",179,0)
 I 'DGUSA D  ;foreign address
"RTN","EASAILK1",180,0)
 . W !?37,""
"RTN","EASAILK1",181,0)
 . W:$G(ARR(2,IENS,STR(15),"E"))]"" ARR(2,IENS,STR(15),"E")_" "
"RTN","EASAILK1",182,0)
 . W $S($G(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
"RTN","EASAILK1",183,0)
 . W $S($G(ARR(2,IENS,STR(14),"E"))]"":ARR(2,IENS,STR(14),"E"),1:"UNKNOWN PROVINCE")_" "
"RTN","EASAILK1",184,0)
 I $G(ARR(2,IENS,STR(7),"E"))]"" D
"RTN","EASAILK1",185,0)
 . S DGCNTRY=ARR(2,IENS,STR(7),"E")
"RTN","EASAILK1",186,0)
 . S DGCNTRY=$$COUNTRY^DGADDUTL(.DGCNTRY)
"RTN","EASAILK1",187,0)
 . W !?37,DGCNTRY
"RTN","EASAILK1",188,0)
 ; EAS*1.0*151; JAM; TYPE is modified from "Patient" to "Permanent Mailing" and new address type "Residential"
"RTN","EASAILK1",189,0)
 I TYPE["Permanent" W !?14,"Bad Address Indicator: ",?37,$G(ARR(2,IENS,STR(8),"E"))
"RTN","EASAILK1",190,0)
 W !?2,TYPE_" Add Change Date: ",?37,$G(ARR(2,IENS,STR(9),"E"))
"RTN","EASAILK1",191,0)
 I TYPE["Permanent" W !,"Permanent Mailing Add Change Source: ",?37,$G(ARR(2,IENS,STR(10),"E"))
"RTN","EASAILK1",192,0)
 I TYPE["Residential" W !,TYPE_" Add Change Source: ",?37,$G(ARR(2,IENS,STR(10),"E"))
"RTN","EASAILK1",193,0)
 I TYPE["Permanent" W:$G(ARR(2,IENS,STR(10),"E"))="VAMC" !?2,TYPE_" Add Change Site: ",?37,$G(ARR(2,IENS,STR(11),"E"))
"RTN","EASAILK1",194,0)
 I TYPE'["Permanent" W:$G(ARR(2,IENS,STR(11),"E"))]"" !?2,TYPE_" Add Change Site: ",?37,$G(ARR(2,IENS,STR(11),"E"))
"RTN","EASAILK1",195,0)
 I TYPE'["Permanent",TYPE'["Residential" W !?3,TYPE_" Add Start Date: ",?37,$G(ARR(2,IENS,STR(12),"E"))
"RTN","EASAILK1",196,0)
 I TYPE'["Permanent",TYPE'["Residential" W !?5,TYPE_" Add End Date: ",?37,$G(ARR(2,IENS,STR(13),"E"))
"RTN","EASAILK1",197,0)
 W !
"RTN","EASAILK1",198,0)
 Q
"RTN","EASAILK1",199,0)
 ;
"RTN","EASAILK1",200,0)
END ; common exit point - reset device and prompt user for another name
"RTN","EASAILK1",201,0)
 K %ZIS D ^%ZISC,HOME^%ZIS
"RTN","EASAILK1",202,0)
 G PATADDR
"RTN","EASAILK1",203,0)
 Q
"VER")
8.0^22.2
**END**
**END**