DG_53_P851.KID

KIDS Distribution saved on Oct 17, 2012@15:33:02
Permanent Address Verification VistA changes.
**KIDS**:DG*5.3*851^IVM*2.0*152^

**INSTALL NAME**
DG*5.3*851
"BLD",8404,0)
DG*5.3*851^REGISTRATION^0^3121017^y
"BLD",8404,1,0)
^^3^3^3120124^
"BLD",8404,1,1,0)
This patch contains VistA changes to support technology and business
"BLD",8404,1,2,0)
changes that are occurring with the implementation of Permanent
"BLD",8404,1,3,0)
Address Verification.
"BLD",8404,4,0)
^9.64PA^2^1
"BLD",8404,4,2,0)
2
"BLD",8404,4,2,2,0)
^9.641^2^1
"BLD",8404,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",8404,4,2,2,2,1,0)
^9.6411^.1323^4
"BLD",8404,4,2,2,2,1,.131,0)
PHONE NUMBER [RESIDENCE]
"BLD",8404,4,2,2,2,1,.1321,0)
RESIDENCE NUMBER CHANGE DT/TM
"BLD",8404,4,2,2,2,1,.1322,0)
RESIDENCE NUMBER CHANGE SOURCE
"BLD",8404,4,2,2,2,1,.1323,0)
RESIDENCE NUMBER CHANGE SITE
"BLD",8404,4,2,222)
y^n^p^^^^n^^n
"BLD",8404,4,2,224)

"BLD",8404,4,"APDD",2,2)

"BLD",8404,4,"APDD",2,2,.131)

"BLD",8404,4,"APDD",2,2,.1321)

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

"BLD",8404,4,"APDD",2,2,.1323)

"BLD",8404,4,"B",2,2)

"BLD",8404,6.3)
10
"BLD",8404,"ABPKG")
n
"BLD",8404,"KRN",0)
^9.67PA^779.2^20
"BLD",8404,"KRN",.4,0)
.4
"BLD",8404,"KRN",.401,0)
.401
"BLD",8404,"KRN",.402,0)
.402
"BLD",8404,"KRN",.403,0)
.403
"BLD",8404,"KRN",.5,0)
.5
"BLD",8404,"KRN",.84,0)
.84
"BLD",8404,"KRN",3.6,0)
3.6
"BLD",8404,"KRN",3.8,0)
3.8
"BLD",8404,"KRN",9.2,0)
9.2
"BLD",8404,"KRN",9.8,0)
9.8
"BLD",8404,"KRN",9.8,"NM",0)
^9.68A^6^6
"BLD",8404,"KRN",9.8,"NM",1,0)
DGREGTE2^^0^B21210063
"BLD",8404,"KRN",9.8,"NM",2,0)
DGREGTED^^0^B30516214
"BLD",8404,"KRN",9.8,"NM",3,0)
DGREGTZL^^0^B49877397
"BLD",8404,"KRN",9.8,"NM",4,0)
DGRP1^^0^B35716153
"BLD",8404,"KRN",9.8,"NM",5,0)
DGADDUTL^^0^B57638537
"BLD",8404,"KRN",9.8,"NM",6,0)
DGADDUT2^^0^B7090344
"BLD",8404,"KRN",9.8,"NM","B","DGADDUT2",6)

"BLD",8404,"KRN",9.8,"NM","B","DGADDUTL",5)

"BLD",8404,"KRN",9.8,"NM","B","DGREGTE2",1)

"BLD",8404,"KRN",9.8,"NM","B","DGREGTED",2)

"BLD",8404,"KRN",9.8,"NM","B","DGREGTZL",3)

"BLD",8404,"KRN",9.8,"NM","B","DGRP1",4)

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

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

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

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

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

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

"BLD",8404,"KRN","B",3.6,3.6)

"BLD",8404,"KRN","B",3.8,3.8)

"BLD",8404,"KRN","B",9.2,9.2)

"BLD",8404,"KRN","B",9.8,9.8)

"BLD",8404,"KRN","B",19,19)

"BLD",8404,"KRN","B",19.1,19.1)

"BLD",8404,"KRN","B",101,101)

"BLD",8404,"KRN","B",409.61,409.61)

"BLD",8404,"KRN","B",771,771)

"BLD",8404,"KRN","B",779.2,779.2)

"BLD",8404,"KRN","B",870,870)

"BLD",8404,"KRN","B",8989.51,8989.51)

"BLD",8404,"KRN","B",8989.52,8989.52)

"BLD",8404,"KRN","B",8994,8994)

"BLD",8404,"QUES",0)
^9.62^^
"BLD",8404,"REQB",0)
^9.611^3^3
"BLD",8404,"REQB",1,0)
DG*5.3*750^2
"BLD",8404,"REQB",2,0)
DG*5.3*754^2
"BLD",8404,"REQB",3,0)
DG*5.3*808^2
"BLD",8404,"REQB","B","DG*5.3*750",1)

"BLD",8404,"REQB","B","DG*5.3*754",2)

"BLD",8404,"REQB","B","DG*5.3*808",3)

"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,.131)

"FIA",2,2,.1321)

"FIA",2,2,.1322)

"FIA",2,2,.1323)

"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)
851^3121017
"PKG",47,22,1,"PAH",1,1,0)
^^3^3^3121017
"PKG",47,22,1,"PAH",1,1,1,0)
This patch contains VistA changes to support technology and business
"PKG",47,22,1,"PAH",1,1,2,0)
changes that are occurring with the implementation of Permanent
"PKG",47,22,1,"PAH",1,1,3,0)
Address Verification.
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
6
"RTN","DGADDUT2")
0^6^B7090344
"RTN","DGADDUT2",1,0)
DGADDUT2 ;ALB/ERC,CKN,LBD - CONTINUATION OF ADDRESS UTILITIES ; 2/27/12 4:26pm
"RTN","DGADDUT2",2,0)
 ;;5.3;Registration;**688,851**; AUG 13, 1993;Build 10
"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,FOR
"RTN","DGADDUT2",60,0)
 ;Get current address & phone data
"RTN","DGADDUT2",61,0)
 S DGRP(.11)=$G(^DPT(DFN,.11)),DGRP(.13)=$G(^DPT(DFN,.13))
"RTN","DGADDUT2",62,0)
 S DGUN="UNANSWERED"
"RTN","DGADDUT2",63,0)
 ;Format address data
"RTN","DGADDUT2",64,0)
 S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU
"RTN","DGADDUT2",65,0)
 ;Display address
"RTN","DGADDUT2",66,0)
 W !!," Permanent Address: "
"RTN","DGADDUT2",67,0)
 W !,?11,$S($D(DGA(1)):DGA(1),1:"NONE ON FILE")
"RTN","DGADDUT2",68,0)
 S DGI=1 F  S DGI=$O(DGA(DGI)) Q:'DGI  W !,?11,DGA(DGI)
"RTN","DGADDUT2",69,0)
 ; only print county info if it's a US address
"RTN","DGADDUT2",70,0)
 I '$$FORIEN^DGADDUTL($P(DGRP(.11),U,10)) D
"RTN","DGADDUT2",71,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",72,0)
 S DGCC=$S($G(DGCC)]"":"County: "_DGCC,1:"")
"RTN","DGADDUT2",73,0)
 W !?3,DGCC
"RTN","DGADDUT2",74,0)
 ;Display phone numbers
"RTN","DGADDUT2",75,0)
 W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGUN)
"RTN","DGADDUT2",76,0)
 W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGUN)
"RTN","DGADDUT2",77,0)
 ;Display Bad Address Indicator
"RTN","DGADDUT2",78,0)
 W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
"RTN","DGADDUT2",79,0)
 Q
"RTN","DGADDUTL")
0^5^B57638537
"RTN","DGADDUTL",1,0)
DGADDUTL ;ALB/PHH,EG,BAJ,ERC,CKN,TDM,LBD-PATIENT ADDRESS ; 2/27/12 4:15pm
"RTN","DGADDUTL",2,0)
 ;;5.3;Registration;**658,695,730,688,808,851**;Aug 13, 1993;Build 10
"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)
 .W !!,"Do you want to update the (P)ermanent Address, (T)emporary Address, or (B)oth? "
"RTN","DGADDUTL",17,0)
 .R USERSEL:300
"RTN","DGADDUTL",18,0)
 .I '$T S USERSEL="^"
"RTN","DGADDUTL",19,0)
 .I USERSEL["^"!(USERSEL="") S QUIT=1 Q
"RTN","DGADDUTL",20,0)
 .S USERSEL=$TR(USERSEL,"ptb","PTB")
"RTN","DGADDUTL",21,0)
 .I USERSEL'="P",USERSEL'="T",USERSEL'="B" D  Q
"RTN","DGADDUTL",22,0)
 ..W !,"Invalid selection!"
"RTN","DGADDUTL",23,0)
 .I USERSEL="P"!(USERSEL="B") W ! D UPDATE(DFN,"PERM")
"RTN","DGADDUTL",24,0)
 .I USERSEL="T"!(USERSEL="B") D UPDATE(DFN,"TEMP")
"RTN","DGADDUTL",25,0)
 .S QUIT=1
"RTN","DGADDUTL",26,0)
 L -^DPT(DFN)
"RTN","DGADDUTL",27,0)
 G ADDRLOOP
"RTN","DGADDUTL",28,0)
ADD(DFN) ; validate/edit Patient address (entry point for routine DGREG)
"RTN","DGADDUTL",29,0)
 ;         Input  -- DFN
"RTN","DGADDUTL",30,0)
 ;
"RTN","DGADDUTL",31,0)
 N RETVAL,ADDYN
"RTN","DGADDUTL",32,0)
 ;Display the permanent address (DG*5.3*851)
"RTN","DGADDUTL",33,0)
 D DISPADD^DGADDUT2(DFN)
"RTN","DGADDUTL",34,0)
 S (RETVAL,ADDYN)=0
"RTN","DGADDUTL",35,0)
 F  D  Q:ADDYN
"RTN","DGADDUTL",36,0)
 .S ADDYN=$$ADDYN("Do you want to edit the Patient's Address")
"RTN","DGADDUTL",37,0)
 .S RETVAL=ADDYN
"RTN","DGADDUTL",38,0)
 .I ADDYN'=1,ADDYN'=2 S (ADDYN,RETVAL)=0
"RTN","DGADDUTL",39,0)
 .I 'ADDYN W !?5,"Enter 'YES' to edit Patient's Address or 'NO' to continue."
"RTN","DGADDUTL",40,0)
 I ADDYN=1,$G(DFN)'="",$D(^DPT(DFN,0)) D
"RTN","DGADDUTL",41,0)
 .D UPDATE(DFN,"PERM")
"RTN","DGADDUTL",42,0)
 .S RETVAL=1
"RTN","DGADDUTL",43,0)
 Q RETVAL
"RTN","DGADDUTL",44,0)
ADDYN(PROMPT) ; Yes/No Prompt to Edit/Validate Address
"RTN","DGADDUTL",45,0)
 ;         Input  -- None
"RTN","DGADDUTL",46,0)
 ;         Output --  1 = YES
"RTN","DGADDUTL",47,0)
 ;                    2 = NO
"RTN","DGADDUTL",48,0)
 ;                   -1 = Aborted
"RTN","DGADDUTL",49,0)
 ;
"RTN","DGADDUTL",50,0)
 N %
"RTN","DGADDUTL",51,0)
 W !,PROMPT
"RTN","DGADDUTL",52,0)
 D YN^DICN
"RTN","DGADDUTL",53,0)
 Q %
"RTN","DGADDUTL",54,0)
UPDATE(DFN,TYPE) ; Update the Address
"RTN","DGADDUTL",55,0)
 ;         Input  -- TYPE = "PERM" for Permanent Address
"RTN","DGADDUTL",56,0)
 ;                        = "TEMP" for Temporary Address
"RTN","DGADDUTL",57,0)
 ;         Output -- None
"RTN","DGADDUTL",58,0)
 ;         
"RTN","DGADDUTL",59,0)
 I TYPE'="PERM",TYPE'="TEMP" Q
"RTN","DGADDUTL",60,0)
 I TYPE="PERM" D
"RTN","DGADDUTL",61,0)
 .W !
"RTN","DGADDUTL",62,0)
 .N FLG S (FLG(1),FLG(2))=1
"RTN","DGADDUTL",63,0)
 .D ADDRED(DFN,.FLG)
"RTN","DGADDUTL",64,0)
 ;
"RTN","DGADDUTL",65,0)
 I TYPE="TEMP" D
"RTN","DGADDUTL",66,0)
 .D EDITTADR(DFN)
"RTN","DGADDUTL",67,0)
 Q
"RTN","DGADDUTL",68,0)
UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time
"RTN","DGADDUTL",69,0)
 ;
"RTN","DGADDUTL",70,0)
 D UPDDTTM^DGADDUT2(DFN,TYPE)
"RTN","DGADDUTL",71,0)
 Q
"RTN","DGADDUTL",72,0)
ADDRED(DFN,FLG) ; Address Edit (Code copied from DGREGAED and modified)
"RTN","DGADDUTL",73,0)
 ;Input:
"RTN","DGADDUTL",74,0)
 ;  DFN (required) - Internal Entry # of Patient File (#2)
"RTN","DGADDUTL",75,0)
 ;  FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
"RTN","DGADDUTL",76,0)
 ;    FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
"RTN","DGADDUTL",77,0)
 ;    FLG(2) - if 1, display before & after address for user confirmation
"RTN","DGADDUTL",78,0)
 N SRC,%,DGINPUT,I,X,Y
"RTN","DGADDUTL",79,0)
 S SRC="ADDUTL"
"RTN","DGADDUTL",80,0)
 D EN^DGREGAED(DFN,.FLG,SRC)
"RTN","DGADDUTL",81,0)
 ;
"RTN","DGADDUTL",82,0)
 ; Update the Date/Time Stamp
"RTN","DGADDUTL",83,0)
 ;The next line was disabled to fix problem of Date/Time stamp being
"RTN","DGADDUTL",84,0)
 ;updated even if no changes were made (DG*5.3*851).
"RTN","DGADDUTL",85,0)
 ;D UPDDTTM(DFN,TYPE)
"RTN","DGADDUTL",86,0)
 Q
"RTN","DGADDUTL",87,0)
GETPRIOR(DFN,DGPRIOR) ; Get prior address fields.
"RTN","DGADDUTL",88,0)
 N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
"RTN","DGADDUTL",89,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",90,0)
 F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121,.118,.119,.12,.122,.1171,.1172,.1173 D
"RTN","DGADDUTL",91,0)
 . S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
"RTN","DGADDUTL",92,0)
 M DGPRIOR=DGARRY("OLD")
"RTN","DGADDUTL",93,0)
 Q
"RTN","DGADDUTL",94,0)
GETUPDTS(DFN,DGINPUT) ; Get current address fields.
"RTN","DGADDUTL",95,0)
 N DGCURR,DGN,DGARRY
"RTN","DGADDUTL",96,0)
 D GETS^DIQ(2,DFN_",",".118;.119;.12;.122","I","DGCURR")
"RTN","DGADDUTL",97,0)
 F DGN=.118,.119,.12,.122 D
"RTN","DGADDUTL",98,0)
 . S DGARRY("NEW",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
"RTN","DGADDUTL",99,0)
 M DGINPUT=DGARRY("NEW")
"RTN","DGADDUTL",100,0)
 Q
"RTN","DGADDUTL",101,0)
FILEYN(DGOLD,DGNEW) ; Determine whether or not to file to #301.7
"RTN","DGADDUTL",102,0)
 N RETVAL
"RTN","DGADDUTL",103,0)
 S RETVAL=0
"RTN","DGADDUTL",104,0)
 D
"RTN","DGADDUTL",105,0)
 .I DGOLD(.111)'=$G(DGNEW(.111)) S RETVAL=1 Q
"RTN","DGADDUTL",106,0)
 .I DGOLD(.112)'=$G(DGNEW(.112)) S RETVAL=1 Q
"RTN","DGADDUTL",107,0)
 .I DGOLD(.113)'=$G(DGNEW(.113)) S RETVAL=1 Q
"RTN","DGADDUTL",108,0)
 .I DGOLD(.114)'=$G(DGNEW(.114)) S RETVAL=1 Q
"RTN","DGADDUTL",109,0)
 .I DGOLD(.115)'=$P($G(DGNEW(.115)),"^",2) S RETVAL=1 Q
"RTN","DGADDUTL",110,0)
 .I DGOLD(.1112)'=$G(DGNEW(.1112)) S RETVAL=1 Q
"RTN","DGADDUTL",111,0)
 .I DGOLD(.117)'=$P($G(DGNEW(.117)),"^",2) S RETVAL=1 Q
"RTN","DGADDUTL",112,0)
 .I DGOLD(.131)'=$G(DGNEW(.131)) S RETVAL=1 Q
"RTN","DGADDUTL",113,0)
 .I DGOLD(.1171)'=$G(DGNEW(.1171)) S RETVAL=1 Q
"RTN","DGADDUTL",114,0)
 .I DGOLD(.1172)'=$G(DGNEW(.1172)) S RETVAL=1 Q
"RTN","DGADDUTL",115,0)
 .I DGOLD(.1173)'=$P($G(DGNEW(.1173)),"^",2) S RETVAL=1 Q
"RTN","DGADDUTL",116,0)
 .I DGOLD(.121)'=$G(DGNEW(.121)) S RETVAL=1 Q
"RTN","DGADDUTL",117,0)
 Q RETVAL
"RTN","DGADDUTL",118,0)
FOREIGN(DFN,CIEN,FILE,FIELD,COUNTRY) ;
"RTN","DGADDUTL",119,0)
 ; ** NOTE we have to default the value for "US" into the prompt if it is blank
"RTN","DGADDUTL",120,0)
 N FORGN,DA,DIR,DTOUT,DUOUT,DIROUT,DONE,INDX
"RTN","DGADDUTL",121,0)
 S:'$G(FILE) FILE=2  I '$G(FIELD) S FIELD=.1173
"RTN","DGADDUTL",122,0)
 S DIR(0)=FILE_","_FIELD,DA=DFN,DONE=0
"RTN","DGADDUTL",123,0)
 S DIR("B")=$E($$CNTRYI^DGADDUTL(CIEN),1,19) I DIR("B")=-1 S DIR("B")="UNKNOWN COUNTRY"
"RTN","DGADDUTL",124,0)
 F  D  Q:DONE
"RTN","DGADDUTL",125,0)
 . D ^DIR
"RTN","DGADDUTL",126,0)
 . I $D(DTOUT) S DONE=1,FORGN=-1 Q
"RTN","DGADDUTL",127,0)
 . I $D(DUOUT)!$D(DIROUT) W !,"EXIT NOT ALLOWED" Q
"RTN","DGADDUTL",128,0)
 . I $D(DIRUT) W !,"This is a required response." Q
"RTN","DGADDUTL",129,0)
 . S COUNTRY=$P($G(Y),"^",2),FORGN=$$FORIEN($P($G(Y),"^")),DONE=1
"RTN","DGADDUTL",130,0)
 Q FORGN
"RTN","DGADDUTL",131,0)
UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7
"RTN","DGADDUTL",132,0)
 ;
"RTN","DGADDUTL",133,0)
 D UPDADDLG^DGADDUT2(DFN,.DGPRIOR,.DGINPUT)
"RTN","DGADDUTL",134,0)
 Q
"RTN","DGADDUTL",135,0)
EDITTADR(DFN) ; Edit Temporary Address
"RTN","DGADDUTL",136,0)
 N DGPRIOR,DGCH,DGRPAN,DGDR,DGRPS
"RTN","DGADDUTL",137,0)
 I $G(DFN)="" Q
"RTN","DGADDUTL",138,0)
 ;I ($G(DFN)'?.N) Q
"RTN","DGADDUTL",139,0)
 ;
"RTN","DGADDUTL",140,0)
 ; Get the current Temporary Address and display it
"RTN","DGADDUTL",141,0)
 D GETTADR(DFN,.DGPRIOR)
"RTN","DGADDUTL",142,0)
 D DISPTADR(DFN,.DGPRIOR)
"RTN","DGADDUTL",143,0)
 W !!
"RTN","DGADDUTL",144,0)
 ;
"RTN","DGADDUTL",145,0)
 S DGCH=5,DGRPAN="1,2,3,4,5,",DGDR="",DGRPS=1
"RTN","DGADDUTL",146,0)
 D CHOICE^DGRPP
"RTN","DGADDUTL",147,0)
 D ^DGRPE
"RTN","DGADDUTL",148,0)
 ; Update the Date/Time Stamp
"RTN","DGADDUTL",149,0)
 D UPDDTTM(DFN,TYPE)
"RTN","DGADDUTL",150,0)
 Q
"RTN","DGADDUTL",151,0)
GETTADR(DFN,DGPRIOR) ; Get prior temporary address fields.
"RTN","DGADDUTL",152,0)
 N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
"RTN","DGADDUTL",153,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",154,0)
 F DGN=.1211,.1212,.1213,.1214,.1215,.1216,.1217,.1218,.12105,.1219,.12111,.12112,.12113,.12114,.1221,.1222,.1223 D
"RTN","DGADDUTL",155,0)
 .S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
"RTN","DGADDUTL",156,0)
 M DGPRIOR=DGARRY("OLD")
"RTN","DGADDUTL",157,0)
 Q
"RTN","DGADDUTL",158,0)
DISPTADR(DFN,DGARRY) ; Display Temporary Address
"RTN","DGADDUTL",159,0)
 N DGADRACT,DGADR1,DGADR2,DGADR3,DGCITY,DGSTATE,DGZIP
"RTN","DGADDUTL",160,0)
 N DGCOUNTY,DGPHONE,DGFROMDT,DGTODT,DGPROV,DGPCODE,DGCNTRY,DGFORN
"RTN","DGADDUTL",161,0)
 ;
"RTN","DGADDUTL",162,0)
 S DGADRACT=$G(DGARRY(.12105))
"RTN","DGADDUTL",163,0)
 S DGADR1=$G(DGARRY(.1211))
"RTN","DGADDUTL",164,0)
 S DGADR2=$G(DGARRY(.1212))
"RTN","DGADDUTL",165,0)
 S DGADR3=$G(DGARRY(.1213))
"RTN","DGADDUTL",166,0)
 S DGCITY=$G(DGARRY(.1214))
"RTN","DGADDUTL",167,0)
 S DGSTATE=$G(DGARRY(.1215))
"RTN","DGADDUTL",168,0)
 S DGZIP=$G(DGARRY(.1216))
"RTN","DGADDUTL",169,0)
 S DGCOUNTY=$G(DGARRY(.12111))
"RTN","DGADDUTL",170,0)
 I DGCOUNTY'="",DGSTATE'="",$D(^DIC(5,DGSTATE,1,DGCOUNTY,0)) D
"RTN","DGADDUTL",171,0)
 .S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_" ("_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)_")"
"RTN","DGADDUTL",172,0)
 I DGADRACT'="Y" S DGCOUNTY="NOT APPLICABLE"
"RTN","DGADDUTL",173,0)
 I DGSTATE'="",$D(^DIC(5,DGSTATE,0)) S DGSTATE=$P(^DIC(5,DGSTATE,0),"^",2)
"RTN","DGADDUTL",174,0)
 S DGPROV=$G(DGARRY(.1221))
"RTN","DGADDUTL",175,0)
 S DGPCODE=$G(DGARRY(.1222))
"RTN","DGADDUTL",176,0)
 S DGCNTRY=$G(DGARRY(.1223))
"RTN","DGADDUTL",177,0)
 S DGFORN=$$FORIEN(DGCNTRY)
"RTN","DGADDUTL",178,0)
 I DGCNTRY]"" S DGCNTRY=$$CNTRYI(DGCNTRY)
"RTN","DGADDUTL",179,0)
 S DGPHONE=$G(DGARRY(.1219))
"RTN","DGADDUTL",180,0)
 S DGFROMDT=$$FMTE^XLFDT($G(DGARRY(.1217)))
"RTN","DGADDUTL",181,0)
 S DGTODT=$$FMTE^XLFDT($G(DGARRY(.1218)))
"RTN","DGADDUTL",182,0)
 ;
"RTN","DGADDUTL",183,0)
 W !!,"Temporary Address: "
"RTN","DGADDUTL",184,0)
 I DGADRACT="Y" D
"RTN","DGADDUTL",185,0)
 .W:DGADR1'="" !?9,DGADR1
"RTN","DGADDUTL",186,0)
 .W:DGADR2'="" !?9,DGADR2
"RTN","DGADDUTL",187,0)
 .W:DGADR3'="" !?9,DGADR3
"RTN","DGADDUTL",188,0)
 .I DGFORN=0 D
"RTN","DGADDUTL",189,0)
 ..W !?9,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
"RTN","DGADDUTL",190,0)
 .I DGFORN W !?9,$S(DGPCODE'="":DGPCODE,1:"")_" "_$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"")
"RTN","DGADDUTL",191,0)
 .W !?9,$S(DGCITY'="":DGCITY,1:"")_","_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
"RTN","DGADDUTL",192,0)
 .W !," County: "_DGCOUNTY
"RTN","DGADDUTL",193,0)
 .W !,"  Phone: "_DGPHONE
"RTN","DGADDUTL",194,0)
 .W !,"From/To: "_$P(DGFROMDT,",")_","_$P(DGFROMDT,", ",2)_"-"_$P(DGTODT,",")_","_$P(DGTODT,", ",2)
"RTN","DGADDUTL",195,0)
 ;
"RTN","DGADDUTL",196,0)
 I $G(DGARRY(.12105))="N" D
"RTN","DGADDUTL",197,0)
 .W:$G(DGARRY(.1211))="" !?9,"NO TEMPORARY ADDRESS"
"RTN","DGADDUTL",198,0)
 .W:$G(DGARRY(.1212))="" !?9,""
"RTN","DGADDUTL",199,0)
 .W !," County: NOT APPLICABLE"
"RTN","DGADDUTL",200,0)
 .W !,"  Phone: NOT APPLICABLE"
"RTN","DGADDUTL",201,0)
 .W !,"From/To: NOT APPLICABLE"
"RTN","DGADDUTL",202,0)
 Q
"RTN","DGADDUTL",203,0)
COUNTRY(DGC) ;
"RTN","DGADDUTL",204,0)
 ;where DGC is the external value of the country
"RTN","DGADDUTL",205,0)
 ;return value is in upper case display mode
"RTN","DGADDUTL",206,0)
 ;if DGC is invalid, return -1
"RTN","DGADDUTL",207,0)
 N DGCC,DGIEN
"RTN","DGADDUTL",208,0)
 ; if input is NULL change to US
"RTN","DGADDUTL",209,0)
 I $G(DGC)="" S DGC="USA"
"RTN","DGADDUTL",210,0)
 ; Get IEN from B index, error if not found
"RTN","DGADDUTL",211,0)
 S DGIEN=$O(^HL(779.004,"B",DGC,"")) Q:DGIEN']"" -1
"RTN","DGADDUTL",212,0)
 ; xlate IEN to POSTAL NAME
"RTN","DGADDUTL",213,0)
 S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
"RTN","DGADDUTL",214,0)
 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
"RTN","DGADDUTL",215,0)
 I DGCC="<NULL>" D
"RTN","DGADDUTL",216,0)
 . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
"RTN","DGADDUTL",217,0)
 Q DGCC
"RTN","DGADDUTL",218,0)
FOR(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is not valid
"RTN","DGADDUTL",219,0)
 ; DGC is the external value of the country (.01 field of file 779.004)
"RTN","DGADDUTL",220,0)
 N DGFOR
"RTN","DGADDUTL",221,0)
 S DGFOR=0
"RTN","DGADDUTL",222,0)
 I $G(DGC)="" Q DGFOR
"RTN","DGADDUTL",223,0)
 I '$D(^HL(779.004,"B",DGC)) Q -1
"RTN","DGADDUTL",224,0)
 I DGC'="USA" S DGFOR=1
"RTN","DGADDUTL",225,0)
 Q DGFOR
"RTN","DGADDUTL",226,0)
CNTRYI(DGIEN) ;where DGC is the internal value of the country
"RTN","DGADDUTL",227,0)
 ;return DGC as the display value for the country
"RTN","DGADDUTL",228,0)
 ;if the input value is not a valid IEN, return -1
"RTN","DGADDUTL",229,0)
 ;if the input value is null, return null
"RTN","DGADDUTL",230,0)
 N DGCC
"RTN","DGADDUTL",231,0)
 I $G(DGIEN)="" Q ""
"RTN","DGADDUTL",232,0)
 I '$D(^HL(779.004,DGIEN,0)) Q -1
"RTN","DGADDUTL",233,0)
 ; xlate IEN to POSTAL NAME
"RTN","DGADDUTL",234,0)
 S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
"RTN","DGADDUTL",235,0)
 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
"RTN","DGADDUTL",236,0)
 I DGCC="<NULL>" D
"RTN","DGADDUTL",237,0)
 . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
"RTN","DGADDUTL",238,0)
 Q DGCC
"RTN","DGADDUTL",239,0)
FORIEN(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is invalid
"RTN","DGADDUTL",240,0)
 ;DGC is the IEN of the country file (#779.004)
"RTN","DGADDUTL",241,0)
 N DGFOR
"RTN","DGADDUTL",242,0)
 S DGFOR=0
"RTN","DGADDUTL",243,0)
 I $G(DGC)="" Q DGFOR
"RTN","DGADDUTL",244,0)
 I DGC'?1.3N Q -1
"RTN","DGADDUTL",245,0)
 I '$D(^HL(779.004,DGC,0)) Q -1
"RTN","DGADDUTL",246,0)
 I DGC]"",(DGC'=$O(^HL(779.004,"B","USA",""))) S DGFOR=1
"RTN","DGADDUTL",247,0)
 Q DGFOR
"RTN","DGREGTE2")
0^1^B21210063
"RTN","DGREGTE2",1,0)
DGREGTE2 ;ALB/BAJ,TDM,BDB - Temporary & Confidential Address Support Routine; 02/27/2006 ; 12/24/08 12:12pm
"RTN","DGREGTE2",2,0)
 ;;5.3;Registration;**688,754,851**;Aug 13, 1993;Build 10
"RTN","DGREGTE2",3,0)
 ;
"RTN","DGREGTE2",4,0)
 Q
"RTN","DGREGTE2",5,0)
 ;
"RTN","DGREGTE2",6,0)
GETOLD(DGCMP,DFN,TYPE) ;populate array with existing address info
"RTN","DGREGTE2",7,0)
 N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,FDESC,FNODE,FPECE,CCNTRY,COUNTRY
"RTN","DGREGTE2",8,0)
 S CFORGN=0,FDESC=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTRY",1:"CONFIDENTIAL ADDR COUNTRY")
"RTN","DGREGTE2",9,0)
 ; get current country
"RTN","DGREGTE2",10,0)
 S FNODE=$S(TYPE="TEMP":.122,TYPE="CONF":.141,1:.11)
"RTN","DGREGTE2",11,0)
 S FPECE=$S(TYPE="TEMP":3,TYPE="CONF":16,1:10)
"RTN","DGREGTE2",12,0)
 S CCIEN=$P($G(^DPT(DFN,FNODE)),U,FPECE)
"RTN","DGREGTE2",13,0)
 I CCIEN="" S CCNTRY=$O(^HL(779.004,"D","UNITED STATES",""))
"RTN","DGREGTE2",14,0)
 S CFORGN=$$FORIEN^DGADDUTL(CCIEN)
"RTN","DGREGTE2",15,0)
 ;get current address fields and xlate to ^DIQ format
"RTN","DGREGTE2",16,0)
 S CFSTR=$$INPT1(DFN,CFORGN),CFSTR=$TR(CFSTR,",",";")
"RTN","DGREGTE2",17,0)
 ; Domestic data needs some extra fields
"RTN","DGREGTE2",18,0)
 ; add country field before lookup
"RTN","DGREGTE2",19,0)
 D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR")
"RTN","DGREGTE2",20,0)
 F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E"))
"RTN","DGREGTE2",21,0)
 S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY"
"RTN","DGREGTE2",22,0)
 S DGCMP("OLD",FCNTRY)=COUNTRY
"RTN","DGREGTE2",23,0)
 I 'CFORGN D
"RTN","DGREGTE2",24,0)
 . S DGCIEN=$G(DGCURR(2,DFN_",",FCOUNTY,"I"))
"RTN","DGREGTE2",25,0)
 . S DGST=$G(DGCURR(2,DFN_",",FSTATE,"I"))
"RTN","DGREGTE2",26,0)
 . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
"RTN","DGREGTE2",27,0)
 . I DGCNTY=-1 S DGCNTY=""
"RTN","DGREGTE2",28,0)
 . S DGCMP("OLD",FCOUNTY)="" I DGCNTY]"" S DGCMP("OLD",FCOUNTY)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3)
"RTN","DGREGTE2",29,0)
 Q
"RTN","DGREGTE2",30,0)
INPT1(DFN,FORGN,PSTR) ; address input prompts
"RTN","DGREGTE2",31,0)
 N FSTR
"RTN","DGREGTE2",32,0)
 ; PSTR contains the full list of address fields to be modified
"RTN","DGREGTE2",33,0)
 ; FSTR contains the field list based on country
"RTN","DGREGTE2",34,0)
 S PSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPROV_","_FPSTAL_","_FCNTRY_","_FPHONE
"RTN","DGREGTE2",35,0)
 ;S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPHONE
"RTN","DGREGTE2",36,0)
 S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FZIP_","_FPHONE ;DG*5.3*851
"RTN","DGREGTE2",37,0)
 I FORGN S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FPROV_","_FPSTAL_","_FPHONE
"RTN","DGREGTE2",38,0)
 Q FSTR
"RTN","DGREGTE2",39,0)
 ;
"RTN","DGREGTE2",40,0)
SURE() ; Are you sure prompt
"RTN","DGREGTE2",41,0)
 N DIR,X,Y,DUOUT,DTOUT,DIRUT
"RTN","DGREGTE2",42,0)
 S DIR(0)="Y"
"RTN","DGREGTE2",43,0)
 S DIR("B")="NO"
"RTN","DGREGTE2",44,0)
 S DIR("A")="   SURE YOU WANT TO DELETE"
"RTN","DGREGTE2",45,0)
 D ^DIR
"RTN","DGREGTE2",46,0)
 Q Y
"RTN","DGREGTE2",47,0)
SKIP(DGN,DGINPUT) ; determine whether or not to skip the prompt
"RTN","DGREGTE2",48,0)
 N SKIP,NULL
"RTN","DGREGTE2",49,0)
 S SKIP=0
"RTN","DGREGTE2",50,0)
 S NULL=($G(DGINPUT(FSLINE1))="")!(($G(DGINPUT(FSLINE1))="@"))
"RTN","DGREGTE2",51,0)
 I NULL,(DGN=FSLINE2) S SKIP=1
"RTN","DGREGTE2",52,0)
 S NULL=($G(DGINPUT(FSLINE2))="")!(($G(DGINPUT(FSLINE2))="@"))
"RTN","DGREGTE2",53,0)
 I NULL,(DGN=FSLINE3) S SKIP=1
"RTN","DGREGTE2",54,0)
 Q SKIP
"RTN","DGREGTE2",55,0)
 ;
"RTN","DGREGTE2",56,0)
INIT ; initialize variables
"RTN","DGREGTE2",57,0)
 ; This tag reads the table at FLDDAT (below) to set relationship between
"RTN","DGREGTE2",58,0)
 ; variables and Field numbers.
"RTN","DGREGTE2",59,0)
 ; 
"RTN","DGREGTE2",60,0)
 ; Set up array of fields needed
"RTN","DGREGTE2",61,0)
 N I,T,FTYPE,VNAME,FNUM,RFLD
"RTN","DGREGTE2",62,0)
 F I=1:1 S T=$P($T(FLDDAT+I^DGREGTE2),";;",3) Q:T="QUIT"  D
"RTN","DGREGTE2",63,0)
 . S FTYPE=$P(T,";",1),VNAME=$P(T,";",2),FNUM=$P(T,";",3)
"RTN","DGREGTE2",64,0)
 . I FTYPE=TYPE S @VNAME=FNUM
"RTN","DGREGTE2",65,0)
 ; Set up array of field and prompting rules
"RTN","DGREGTE2",66,0)
 K T,I
"RTN","DGREGTE2",67,0)
 F I=1:1 S T=$P($T(FLDPRMPT+I^DGREGTE2),";;",2) Q:T="QUIT"  D
"RTN","DGREGTE2",68,0)
 . S RFLD=$P(T,";",1) I RFLD'="ALL" S RFLD=@RFLD
"RTN","DGREGTE2",69,0)
 . S RPROC(RFLD,$P(T,";",2),$P(T,";",3))=$P(T,";",4)
"RTN","DGREGTE2",70,0)
 Q
"RTN","DGREGTE2",71,0)
FLDDAT ; Table of field values STRUCTURE --> Description;;Type;Variable Name;Field Number
"RTN","DGREGTE2",72,0)
 ;;Street Line 1;;TEMP;FSLINE1;.1211
"RTN","DGREGTE2",73,0)
 ;;Street Line 2;;TEMP;FSLINE2;.1212
"RTN","DGREGTE2",74,0)
 ;;Street Line 3;;TEMP;FSLINE3;.1213
"RTN","DGREGTE2",75,0)
 ;;City;;TEMP;FCITY;.1214
"RTN","DGREGTE2",76,0)
 ;;State;;TEMP;FSTATE;.1215
"RTN","DGREGTE2",77,0)
 ;;County;;TEMP;FCOUNTY;.12111
"RTN","DGREGTE2",78,0)
 ;;Zip;;TEMP;FZIP;.12112
"RTN","DGREGTE2",79,0)
 ;;Phone;;TEMP;FPHONE;.1219
"RTN","DGREGTE2",80,0)
 ;;Province;;TEMP;FPROV;.1221
"RTN","DGREGTE2",81,0)
 ;;Postal Code;;TEMP;FPSTAL;.1222
"RTN","DGREGTE2",82,0)
 ;;Country;;TEMP;FCNTRY;.1223
"RTN","DGREGTE2",83,0)
 ;;Address Node 1;;TEMP;FNODE1;.121
"RTN","DGREGTE2",84,0)
 ;;Address Node 2;;TEMP;FNODE2;.122
"RTN","DGREGTE2",85,0)
 ;;Country data piece;;TEMP;CPEICE;3
"RTN","DGREGTE2",86,0)
 ;;Street Line 1;;CONF;FSLINE1;.1411
"RTN","DGREGTE2",87,0)
 ;;Street Line 2;;CONF;FSLINE2;.1412
"RTN","DGREGTE2",88,0)
 ;;Street Line 3;;CONF;FSLINE3;.1413
"RTN","DGREGTE2",89,0)
 ;;City;;CONF;FCITY;.1414
"RTN","DGREGTE2",90,0)
 ;;State;;CONF;FSTATE;.1415
"RTN","DGREGTE2",91,0)
 ;;County;;CONF;FCOUNTY;.14111
"RTN","DGREGTE2",92,0)
 ;;Zip;;CONF;FZIP;.1416
"RTN","DGREGTE2",93,0)
 ;;Phone;;CONF;FPHONE;.1315
"RTN","DGREGTE2",94,0)
 ;;Province;;CONF;FPROV;.14114
"RTN","DGREGTE2",95,0)
 ;;Postal Code;;CONF;FPSTAL;.14115
"RTN","DGREGTE2",96,0)
 ;;Country;;CONF;FCNTRY;.14116
"RTN","DGREGTE2",97,0)
 ;;Address Node 1;;CONF;FNODE1;.141
"RTN","DGREGTE2",98,0)
 ;;Address Node 2;;CONF;FNODE2;.141
"RTN","DGREGTE2",99,0)
 ;;Country data piece;;CONF;CPEICE;16
"RTN","DGREGTE2",100,0)
 ;;QUIT;;QUIT
"RTN","DGREGTE2",101,0)
 ;;
"RTN","DGREGTE2",102,0)
FLDPRMPT ;Table of prompts and responses STRUCTURE --> Description;;Field;Old Value;New Value;Response Code
"RTN","DGREGTE2",103,0)
 ;;ALL;NULL;UPCAR;REPEAT
"RTN","DGREGTE2",104,0)
 ;;ALL;NULL;DELETE;QUES
"RTN","DGREGTE2",105,0)
 ;;ALL;NULL;VALUE;OK
"RTN","DGREGTE2",106,0)
 ;;ALL;VALUE;UPCAR;REPEAT
"RTN","DGREGTE2",107,0)
 ;;ALL;VALUE;NULL;OK
"RTN","DGREGTE2",108,0)
 ;;ALL;VALUE;VALUE;OK
"RTN","DGREGTE2",109,0)
 ;;FSLINE1;NULL;NULL;REVERSE
"RTN","DGREGTE2",110,0)
 ;;FSLINE2;NULL;NULL;OK
"RTN","DGREGTE2",111,0)
 ;;FSLINE3;NULL;NULL;OK
"RTN","DGREGTE2",112,0)
 ;;FCITY;NULL;NULL;REVERSE
"RTN","DGREGTE2",113,0)
 ;;FSTATE;NULL;NULL;REVERSE
"RTN","DGREGTE2",114,0)
 ;;FZIP;NULL;NULL;REVERSE
"RTN","DGREGTE2",115,0)
 ;;FCOUNTY;NULL;NULL;REVERSE
"RTN","DGREGTE2",116,0)
 ;;FPROV;NULL;NULL;OK
"RTN","DGREGTE2",117,0)
 ;;FPSTAL;NULL;NULL;OK
"RTN","DGREGTE2",118,0)
 ;;FCNTRY;NULL;NULL;REVERSE
"RTN","DGREGTE2",119,0)
 ;;FSLINE1;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",120,0)
 ;;FSLINE2;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",121,0)
 ;;FSLINE3;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",122,0)
 ;;FCITY;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",123,0)
 ;;FSTATE;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",124,0)
 ;;FZIP;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",125,0)
 ;;FCOUNTY;VALUE;DELETE;INSTRUCT
"RTN","DGREGTE2",126,0)
 ;;FPROV;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",127,0)
 ;;FPSTAL;VALUE;DELETE;CONFIRM
"RTN","DGREGTE2",128,0)
 ;;FCNTRY;VALUE;DELETE;REVERSE
"RTN","DGREGTE2",129,0)
 ;;QUIT
"RTN","DGREGTE2",130,0)
 ;;
"RTN","DGREGTED")
0^2^B30516214
"RTN","DGREGTED",1,0)
DGREGTED ;ALB/BAJ,BDB - Temporary & Confidential Address Edits API ; 8/1/08 1:22pm
"RTN","DGREGTED",2,0)
 ;;5.3;Registration;**688,851**;Aug 13, 1993;Build 10
"RTN","DGREGTED",3,0)
EN(DFN,TYPE,RET) ;Entry point
"RTN","DGREGTED",4,0)
 ; This routine controls Edits to Temporary & Confidential addresses
"RTN","DGREGTED",5,0)
 ; 
"RTN","DGREGTED",6,0)
 ; Input
"RTN","DGREGTED",7,0)
 ;       DFN  = Patient DFN
"RTN","DGREGTED",8,0)
 ;       TYPE = Type of address: "TEMP" or "CONF"
"RTN","DGREGTED",9,0)
 ;       RET  = Flag to signal return to first prompt
"RTN","DGREGTED",10,0)
 ;       
"RTN","DGREGTED",11,0)
 ; Output
"RTN","DGREGTED",12,0)
 ;       RET  0 = Return to first prompt
"RTN","DGREGTED",13,0)
 ;            1 = Do not return
"RTN","DGREGTED",14,0)
 ;       
"RTN","DGREGTED",15,0)
 N DGINPUT,FORGN,FSTR,ICNTRY,CNTRY,PSTR,DGCMP,DGOLD
"RTN","DGREGTED",16,0)
 N FSLINE1,FSLINE2,FSLINE3,FCITY,FSTATE,FCOUNTY,FZIP,FPHONE
"RTN","DGREGTED",17,0)
 N FPROV,FPSTAL,FCNTRY,FNODE1,FNODE2,CPEICE,OLDC,RPROC
"RTN","DGREGTED",18,0)
 N I,X,Y
"RTN","DGREGTED",19,0)
 I $G(DFN)="" Q
"RTN","DGREGTED",20,0)
 ;I ($G(DFN)'?.N) Q
"RTN","DGREGTED",21,0)
 D INIT^DGREGTE2  I $P($G(^DPT(DFN,FNODE1)),U,9)="N" Q
"RTN","DGREGTED",22,0)
 D GETOLD^DGREGTE2(.DGCMP,DFN,TYPE) M DGOLD=DGCMP("OLD") K DGCMP
"RTN","DGREGTED",23,0)
 S CNTRY="",ICNTRY=$P($G(^DPT(DFN,FNODE2)),"^",CPEICE) I ICNTRY="" S ICNTRY=1    ;default US if NULL
"RTN","DGREGTED",24,0)
 S FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,FCNTRY,.CNTRY) Q:$G(CNTRY)=""  I FORGN=-1 S RET=0 Q
"RTN","DGREGTED",25,0)
 S FSTR=$$INPT1^DGREGTE2(DFN,FORGN,.PSTR),DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR)
"RTN","DGREGTED",26,0)
 I $G(DGINPUT)=-1 S RET=0 Q
"RTN","DGREGTED",27,0)
 D SAVE(.DGINPUT,DFN,FSTR,CNTRY)
"RTN","DGREGTED",28,0)
 Q
"RTN","DGREGTED",29,0)
 ;
"RTN","DGREGTED",30,0)
INPUT(DGINPUT,DFN,FSTR) ;Let user input address changes
"RTN","DGREGTED",31,0)
 ; Input:
"RTN","DGREGTED",32,0)
 ;       DGINPUT - Array to hold field values DGINPUT(field#)
"RTN","DGREGTED",33,0)
 ;       DFN     - Patient DFN
"RTN","DGREGTED",34,0)
 ;       FSTR    - String of fields (foreign or domestic) to work with
"RTN","DGREGTED",35,0)
 ;       
"RTN","DGREGTED",36,0)
 ; Output: 
"RTN","DGREGTED",37,0)
 ;       DGINPUT(field#)=external^internal(if any)
"RTN","DGREGTED",38,0)
 ; 
"RTN","DGREGTED",39,0)
 N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L,SUCCESS,REP
"RTN","DGREGTED",40,0)
 F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) Q:DGINPUT=-1  D
"RTN","DGREGTED",41,0)
 . S REP=0
"RTN","DGREGTED",42,0)
 . I $$SKIP^DGREGTE2(DGN,.DGINPUT) Q
"RTN","DGREGTED",43,0)
 . I DGN=FZIP D ZIPINP(.DGINPUT,DFN) Q  ;DG*5.3*851
"RTN","DGREGTED",44,0)
 . S SUCCESS=$$READ(DFN,.DGOLD,DGN,.Y,.REP) I 'SUCCESS D  Q
"RTN","DGREGTED",45,0)
 . . I 'REP S DGINPUT=-1 Q
"RTN","DGREGTED",46,0)
 . . ; repeat the question so we have to set the counter back
"RTN","DGREGTED",47,0)
 . . S L=L-1
"RTN","DGREGTED",48,0)
 . S DGINPUT(DGN)=$G(Y)
"RTN","DGREGTED",49,0)
 Q
"RTN","DGREGTED",50,0)
 ;
"RTN","DGREGTED",51,0)
READ(DFN,DGOLD,DGN,Y,REP) ;Read input, return success
"RTN","DGREGTED",52,0)
 ; Input:
"RTN","DGREGTED",53,0)
 ;       DFN   - Patient DFN
"RTN","DGREGTED",54,0)
 ;       DGOLD - Array of current field values.
"RTN","DGREGTED",55,0)
 ;       DGN   - Current field to read
"RTN","DGREGTED",56,0)
 ;       Y     - Current Field value
"RTN","DGREGTED",57,0)
 ;       REP   - Flag -- should prompt be repeated
"RTN","DGREGTED",58,0)
 ;       
"RTN","DGREGTED",59,0)
 ; Output
"RTN","DGREGTED",60,0)
 ;       SUCCESS 1 = Input successful go to next prompt
"RTN","DGREGTED",61,0)
 ;               0 = Input unsuccessful Repeat or Abort as indicated by REP variable
"RTN","DGREGTED",62,0)
 ;       REP     1 = Error - Repeat prompt
"RTN","DGREGTED",63,0)
 ;               0 = Error - Do not repeat
"RTN","DGREGTED",64,0)
 ;       Y       New field value
"RTN","DGREGTED",65,0)
 ;       
"RTN","DGREGTED",66,0)
 N SUCCESS,DIR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,L,T,POP,DGST,CNTYFLD,REVERSE
"RTN","DGREGTED",67,0)
 S SUCCESS=1,(POP,REVERSE)=0,CNTYFLD=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTY",1:"CONFIDENTIAL ADDRESS COUNTY")
"RTN","DGREGTED",68,0)
 S DIR(0)=2_","_DGN,DIR("B")=$G(DGOLD(DGN))
"RTN","DGREGTED",69,0)
 S DA=DFN
"RTN","DGREGTED",70,0)
 F  D  Q:POP
"RTN","DGREGTED",71,0)
 . K DTOUT,DUOUT,DIROUT
"RTN","DGREGTED",72,0)
 . S MSG=""
"RTN","DGREGTED",73,0)
 . I ($G(DGINPUT(FSTATE))="")&(DGN=FCOUNTY) S POP=1 Q
"RTN","DGREGTED",74,0)
 . S DIR("B")=$S($D(DGINPUT(DGN)):DGINPUT(DGN),$G(DGOLD(DGN))]"":DGOLD(DGN),1:"")
"RTN","DGREGTED",75,0)
 . I DGN=FCOUNTY D 
"RTN","DGREGTED",76,0)
 . . S DIR(0)="POA^DIC(5,"_$P(DGINPUT(FSTATE),U)_",1,:AEMQ"
"RTN","DGREGTED",77,0)
 . . S DIR("A")=CNTYFLD_": "
"RTN","DGREGTED",78,0)
 . . ; we can't prompt if there's no previous entry
"RTN","DGREGTED",79,0)
 . . I $D(DGOLD(DGN)) S T=$L(DGOLD(DGN)," "),DIR("B")=$P($G(DGOLD(DGN))," ",1,T-1)
"RTN","DGREGTED",80,0)
 . D ^DIR
"RTN","DGREGTED",81,0)
 . I $D(DTOUT) S POP=1,SUCCESS=0 Q
"RTN","DGREGTED",82,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",83,0)
 . I REVERSE S (REP,SUCCESS)=0
"RTN","DGREGTED",84,0)
 . S POP=1
"RTN","DGREGTED",85,0)
 Q SUCCESS
"RTN","DGREGTED",86,0)
 ;
"RTN","DGREGTED",87,0)
SAVE(DGINPUT,DFN,FSTR,CNTRY) ;Save changes
"RTN","DGREGTED",88,0)
 N DATA,DGENDA,L,T,FILE,ERROR
"RTN","DGREGTED",89,0)
 S DGENDA=DFN,FILE=2
"RTN","DGREGTED",90,0)
 ; need to get the country code into the DGINPUT array
"RTN","DGREGTED",91,0)
 S DGINPUT(FCNTRY)=$O(^HL(779.004,"B",CNTRY,""))
"RTN","DGREGTED",92,0)
 S FSTR=FSTR_","_FCNTRY
"RTN","DGREGTED",93,0)
 I (TYPE="TEMP")!(TYPE="CONF") S FSTR=FSTR_","_FCITY_","_FSTATE_","_FCOUNTY ;DG*5.3*851
"RTN","DGREGTED",94,0)
 F L=1:1:$L(FSTR,",") S T=$P(FSTR,",",L) S DATA(T)=$P($G(DGINPUT(T)),U)
"RTN","DGREGTED",95,0)
 Q $$UPD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR)
"RTN","DGREGTED",96,0)
 ;
"RTN","DGREGTED",97,0)
ANSW(YIN,DGOLD,DGN,MSG,YOUT,REP,RET,REVERSE) ;analyze input commands
"RTN","DGREGTED",98,0)
 ; This API will process reads and set bits, messages and flags accordingly.
"RTN","DGREGTED",99,0)
 ; Because there is different behavior depending on prompt and input, the input
"RTN","DGREGTED",100,0)
 ; of each field needs to be evaluated separately at the time of input and before
"RTN","DGREGTED",101,0)
 ; deciding to continue the edit.  Input rules are loaded into array RPROC at the
"RTN","DGREGTED",102,0)
 ; beginning of this routine in call to INIT^DGREGTE2.
"RTN","DGREGTED",103,0)
 ; 
"RTN","DGREGTED",104,0)
 ; Input
"RTN","DGREGTED",105,0)
 ;       N       - User input "Y" value
"RTN","DGREGTED",106,0)
 ;       DGOLD   - Array of current values
"RTN","DGREGTED",107,0)
 ;       DGN     - Current field
"RTN","DGREGTED",108,0)
 ;       MSG     - Variable for Text message
"RTN","DGREGTED",109,0)
 ;       YOUT    - User input ("Y") value
"RTN","DGREGTED",110,0)
 ;       REP     - Flag to repeat prompt
"RTN","DGREGTED",111,0)
 ;       RET     - Flag to return success or failure to calling module
"RTN","DGREGTED",112,0)
 ;       REVERSE - Flag to revert to first prompt in sequence
"RTN","DGREGTED",113,0)
 ; 
"RTN","DGREGTED",114,0)
 ; Output
"RTN","DGREGTED",115,0)
 ;       MSG     - Text message (for incorrect entries)
"RTN","DGREGTED",116,0)
 ;       REP     - Repeat current prompt
"RTN","DGREGTED",117,0)
 ;       REVERSE - Revert to first prompt in sequence
"RTN","DGREGTED",118,0)
 ; 
"RTN","DGREGTED",119,0)
 N X,Y,DTOUT,DIRUT,DUOUT,PRMPT,RMSG,TDGN,ACT
"RTN","DGREGTED",120,0)
 N OLDVAL,NEWVAL
"RTN","DGREGTED",121,0)
 ;
"RTN","DGREGTED",122,0)
 S PRMPT=$S(TYPE="TEMP":"TEMPORARY",1:"CONFIDENTIAL")
"RTN","DGREGTED",123,0)
 S RMSG("LINE")="BUT I NEED AT LEAST ONE LINE OF A "_PRMPT_" ADDRESS"
"RTN","DGREGTED",124,0)
 S RMSG("REVERSE")="This is a required response."
"RTN","DGREGTED",125,0)
 S RMSG("REPEAT")="EXIT NOT ALLOWED ??"
"RTN","DGREGTED",126,0)
 S RMSG("QUES")="??"
"RTN","DGREGTED",127,0)
 S RMSG("INSTRUCT")=$S(TYPE="TEMP":"TADD^DGLOCK1",TYPE="CONF":"CADD1^DGLOCK3",1:"OK")
"RTN","DGREGTED",128,0)
 S OLDVAL=$G(DGOLD(DGN)),OLDVAL=$$PROC(OLDVAL),NEWVAL=$$PROC(YIN)
"RTN","DGREGTED",129,0)
 S TDGN=$S($D(RPROC(DGN,OLDVAL,NEWVAL)):DGN,1:"ALL")
"RTN","DGREGTED",130,0)
 I '$D(RPROC(TDGN,OLDVAL,NEWVAL)) S RPROC(TDGN,OLDVAL,NEWVAL)="OK"
"RTN","DGREGTED",131,0)
 S ACT=RPROC(TDGN,OLDVAL,NEWVAL)
"RTN","DGREGTED",132,0)
 D @ACT
"RTN","DGREGTED",133,0)
 Q
"RTN","DGREGTED",134,0)
REVERSE ;
"RTN","DGREGTED",135,0)
 N MSUB
"RTN","DGREGTED",136,0)
 S MSUB=$S(DGN=FSLINE1:"LINE",1:"REVERSE")
"RTN","DGREGTED",137,0)
 W !,RMSG(MSUB)
"RTN","DGREGTED",138,0)
 S REVERSE=1
"RTN","DGREGTED",139,0)
 Q
"RTN","DGREGTED",140,0)
REPEAT ;
"RTN","DGREGTED",141,0)
 W !,RMSG("REPEAT")
"RTN","DGREGTED",142,0)
 S REP=1
"RTN","DGREGTED",143,0)
 Q
"RTN","DGREGTED",144,0)
OK ;
"RTN","DGREGTED",145,0)
 Q
"RTN","DGREGTED",146,0)
QUES ;
"RTN","DGREGTED",147,0)
 W RMSG("QUES")
"RTN","DGREGTED",148,0)
 S REP=1
"RTN","DGREGTED",149,0)
 Q
"RTN","DGREGTED",150,0)
CONFIRM ;
"RTN","DGREGTED",151,0)
 I '$$SURE^DGREGTE2 S YOUT=DGOLD(DGN),REP=1 Q
"RTN","DGREGTED",152,0)
 S YOUT=YIN,REP=0
"RTN","DGREGTED",153,0)
 Q
"RTN","DGREGTED",154,0)
INSTRUCT ;
"RTN","DGREGTED",155,0)
 D @RMSG("INSTRUCT")
"RTN","DGREGTED",156,0)
 S REP=1
"RTN","DGREGTED",157,0)
 Q
"RTN","DGREGTED",158,0)
PROC(VAL) ;process the input and return a type of value
"RTN","DGREGTED",159,0)
 ; input
"RTN","DGREGTED",160,0)
 ;   VAL - The value to examine
"RTN","DGREGTED",161,0)
 ;       
"RTN","DGREGTED",162,0)
 ; output
"RTN","DGREGTED",163,0)
 ;   a value type
"RTN","DGREGTED",164,0)
 ;     VALUE  = input - validation is a separate task and is not done here
"RTN","DGREGTED",165,0)
 ;     NULL   = NULL input
"RTN","DGREGTED",166,0)
 ;     UPCAR  = the "^" character
"RTN","DGREGTED",167,0)
 ;     DELETE = the "@" character
"RTN","DGREGTED",168,0)
 Q $S(VAL="":"NULL",$E(VAL)="^":"UPCAR",$E(VAL)="@":"DELETE",1:"VALUE")
"RTN","DGREGTED",169,0)
EOP ;End of page prompt
"RTN","DGREGTED",170,0)
 N DIR,DTOUT,DUOUT,DIROUT,X,Y
"RTN","DGREGTED",171,0)
 S DIR(0)="E"
"RTN","DGREGTED",172,0)
 S DIR("A")="Press ENTER to continue"
"RTN","DGREGTED",173,0)
 D ^DIR
"RTN","DGREGTED",174,0)
 Q
"RTN","DGREGTED",175,0)
  ; DG*5.3*851
"RTN","DGREGTED",176,0)
ZIPINP(DGINPUT,DFN) ;get ZIP+4 input
"RTN","DGREGTED",177,0)
 N DGR,DGX
"RTN","DGREGTED",178,0)
 D EN^DGREGTZL(.DGR,DFN)
"RTN","DGREGTED",179,0)
 I $G(DGR)=-1 Q
"RTN","DGREGTED",180,0)
 M DGINPUT=DGR
"RTN","DGREGTED",181,0)
 S DGX=DGINPUT(FCOUNTY),DGINPUT(FCOUNTY)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1)
"RTN","DGREGTED",182,0)
 S DGX=DGINPUT(FSTATE),DGINPUT(FSTATE)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1)
"RTN","DGREGTED",183,0)
 Q
"RTN","DGREGTED",184,0)
SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step
"RTN","DGREGTED",185,0)
 N SKIP
"RTN","DGREGTED",186,0)
 S SKIP=0
"RTN","DGREGTED",187,0)
 I ($G(DGINPUT(FSLINE1))="")&((DGN=FSLINE2)!(DGN=FSLINE3)) S SKIP=1
"RTN","DGREGTED",188,0)
 I ($G(DGINPUT(FSLINE2))="")&(DGN=FSLINE3) S SKIP=1
"RTN","DGREGTED",189,0)
 I ($G(FLG(1))'=1)&((DGN=FPHONE)) S SKIP=1
"RTN","DGREGTED",190,0)
 Q SKIP
"RTN","DGREGTED",191,0)
UPCT ;Indicate "^" or "^^" are unacceptable inputs.
"RTN","DGREGTED",192,0)
 W !,"EXIT NOT ALLOWED ??"
"RTN","DGREGTED",193,0)
 Q
"RTN","DGREGTZL")
0^3^B49877397
"RTN","DGREGTZL",1,0)
DGREGTZL ;ALB/BDB - Temporary & Confidential Address Edits API ; 11/30/11 10:00am
"RTN","DGREGTZL",2,0)
 ;;5.3;Registration;**851**;Aug 13, 1993;Build 10
"RTN","DGREGTZL",3,0)
EN(RESULT,DFN) ;Let user edit zip+4, city, state, county based on zip-linking
"RTN","DGREGTZL",4,0)
 ; Output: RESULT(field#) = User Input External ^ Internal
"RTN","DGREGTZL",5,0)
 K RESULT
"RTN","DGREGTZL",6,0)
 N DGIND,DGTOT
"RTN","DGREGTZL",7,0)
 I $G(DFN)="" S RESULT=-1 Q
"RTN","DGREGTZL",8,0)
 N DGR,DGDFLT,DGALW,DGZIP,DGN
"RTN","DGREGTZL",9,0)
 S DGN=""
"RTN","DGREGTZL",10,0)
 I $$FOREIGN() D  Q
"RTN","DGREGTZL",11,0)
 . D FRGNEDT(.DGR,DFN)
"RTN","DGREGTZL",12,0)
 . I $G(DGR)=-1 S RESULT=-1 Q
"RTN","DGREGTZL",13,0)
 . F DGN=FZIP,FCITY,FSTATE,FCOUNTY S RESULT(DGN)=$G(DGR(DGN))
"RTN","DGREGTZL",14,0)
 S DGZIP=$$ZIP(DFN)
"RTN","DGREGTZL",15,0)
 I DGZIP=-1 S RESULT=-1 Q
"RTN","DGREGTZL",16,0)
 S RESULT(FZIP)=DGZIP
"RTN","DGREGTZL",17,0)
 S DGIND=$$CITY(.DGR,DGZIP,DFN)
"RTN","DGREGTZL",18,0)
 I DGIND=$G(DGTOT)+1 S DGIND=""
"RTN","DGREGTZL",19,0)
 I $G(DGR)=-1 S RESULT=-1 Q
"RTN","DGREGTZL",20,0)
 S RESULT(FCITY)=$G(DGR)
"RTN","DGREGTZL",21,0)
 ;S DGALW=$$ALWEDT^DGREGDD1($G(DUZ),DGZIP
"RTN","DGREGTZL",22,0)
 S DGALW=$$ALWEDTTC($G(DUZ),DGZIP)
"RTN","DGREGTZL",23,0)
 I DGALW=1 D
"RTN","DGREGTZL",24,0)
 . K DGR D STCNTY(.DGR,DGZIP,DFN,DGIND)
"RTN","DGREGTZL",25,0)
 . I $G(DGR)=-1 S RESULT=-1 Q
"RTN","DGREGTZL",26,0)
 . S RESULT(FSTATE)=$G(DGR(FSTATE))
"RTN","DGREGTZL",27,0)
 . S RESULT(FCOUNTY)=$G(DGR(FCOUNTY))
"RTN","DGREGTZL",28,0)
 I DGALW=0 D
"RTN","DGREGTZL",29,0)
 . I DGZIP'="" D LINK(.DGDFLT,DGZIP,1)
"RTN","DGREGTZL",30,0)
 . S RESULT(FSTATE)=$G(DGDFLT(FSTATE))
"RTN","DGREGTZL",31,0)
 . S RESULT(FCOUNTY)=$G(DGDFLT(FCOUNTY))
"RTN","DGREGTZL",32,0)
 Q
"RTN","DGREGTZL",33,0)
ZIP(DFN) ;Let user input zip+4
"RTN","DGREGTZL",34,0)
ZAGN N DIR,DTOUT,DUOUT,DIROUT,DGDATA
"RTN","DGREGTZL",35,0)
 S DIR(0)="2,"_FZIP
"RTN","DGREGTZL",36,0)
 S DA=DFN
"RTN","DGREGTZL",37,0)
 D ^DIR
"RTN","DGREGTZL",38,0)
 I $D(DTOUT) Q -1
"RTN","DGREGTZL",39,0)
 I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGTED G ZAGN
"RTN","DGREGTZL",40,0)
 S DGZIP=$G(Y)
"RTN","DGREGTZL",41,0)
 ;allow bogus zip:
"RTN","DGREGTZL",42,0)
 I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q DGZIP
"RTN","DGREGTZL",43,0)
 I DGZIP="" Q DGZIP
"RTN","DGREGTZL",44,0)
 D POSTALB^XIPUTIL(DGZIP,.DGDATA)
"RTN","DGREGTZL",45,0)
  ;DG*730 - later commented out by DG*760
"RTN","DGREGTZL",46,0)
 ;I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
"RTN","DGREGTZL",47,0)
 I $D(DGDATA("ERROR")) D  G ZAGN
"RTN","DGREGTZL",48,0)
 . W $C(7)," ??"
"RTN","DGREGTZL",49,0)
 Q DGZIP
"RTN","DGREGTZL",50,0)
CITY(RESULT,ZIP,DFN) ;Base on zip, let user input city(#FCITY)
"RTN","DGREGTZL",51,0)
 ; Input:
"RTN","DGREGTZL",52,0)
 ;   ZIP - user input zip for the patient primary address
"RTN","DGREGTZL",53,0)
 ;   DFN - Interal entry number of Patient File (#2)
"RTN","DGREGTZL",54,0)
 ; Output:RESULT=-1 (input error or timed or ^ out) 
"RTN","DGREGTZL",55,0)
 ;        or    =user input city
"RTN","DGREGTZL",56,0)
 ;        Array index # of selected city.
"RTN","DGREGTZL",57,0)
 K RESULT
"RTN","DGREGTZL",58,0)
 N DGDATA,DIR,DA,Y,DTOUT,DUOUT,DIROUT,DGIND
"RTN","DGREGTZL",59,0)
 N DGCITY,DGST,DGCNTY,DGABRV,DGN,DGECH,DGSOC
"RTN","DGREGTZL",60,0)
 N DOLDCITY,DGSAME,DGELEVEN
"RTN","DGREGTZL",61,0)
 N DGCITI
"RTN","DGREGTZL",62,0)
 S DGIND=""
"RTN","DGREGTZL",63,0)
 D POSTALB^XIPUTIL(ZIP,.DGDATA)
"RTN","DGREGTZL",64,0)
 D FIELD^DID(2,FCITY,"N","LABEL","DGCITY")
"RTN","DGREGTZL",65,0)
 S DGN=""
"RTN","DGREGTZL",66,0)
 I '$D(DGDATA("ERROR")) D
"RTN","DGREGTZL",67,0)
 . S DOLDCITY=$$GET1^DIQ(2,DFN_",",FCITY)
"RTN","DGREGTZL",68,0)
 . S DGSAME=0
"RTN","DGREGTZL",69,0)
 . F  S DGN=$O(DGDATA(DGN)) Q:DGN=""  D
"RTN","DGREGTZL",70,0)
 .. S DGCITI=$P($G(DGDATA(DGN,"CITY")),"*",1)
"RTN","DGREGTZL",71,0)
 .. S DGABRV=$G(DGDATA(DGN,"CITY ABBREVIATION"))
"RTN","DGREGTZL",72,0)
 .. I DOLDCITY'="",DGCITI=DOLDCITY!(DGABRV=DOLDCITY) S DGSAME=1
"RTN","DGREGTZL",73,0)
 .. I $G(DGDATA(DGN,"CITY"))["*" S DGCITI=DGCITI_"*"
"RTN","DGREGTZL",74,0)
 .. S DGECH=DGN_":"_DGCITI
"RTN","DGREGTZL",75,0)
 .. S DGSOC=$S($G(DGSOC)="":DGECH,1:DGSOC_";"_DGECH)
"RTN","DGREGTZL",76,0)
 .. S DGTOT=DGN
"RTN","DGREGTZL",77,0)
 .I 'DGSAME S DGELEVEN=$G(^DPT(DFN,.11)) D
"RTN","DGREGTZL",78,0)
 ..Q:$P(DGELEVEN,U,6)'=$G(DGDATA(DGTOT,"POSTAL CODE"))
"RTN","DGREGTZL",79,0)
 ..Q:$P(DGELEVEN,U,14)'="VAMC"
"RTN","DGREGTZL",80,0)
 ..Q:$P(DGELEVEN,U,15)'=$$GETSITE^DGMTU4($G(DUZ))
"RTN","DGREGTZL",81,0)
 ..Q:$P(DGELEVEN,U,17)'>.5
"RTN","DGREGTZL",82,0)
 ..S DGN=DGTOT+1,DGECH=DGN_":"_DOLDCITY,DGSOC=DGSOC_";"_DGECH
"RTN","DGREGTZL",83,0)
 .;
"RTN","DGREGTZL",84,0)
 . I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) D
"RTN","DGREGTZL",85,0)
 .. S DGSOC=$G(DGSOC)_";"_99_":"_"FREE TEXT"
"RTN","DGREGTZL",86,0)
 . S DIR(0)="SO^"_$G(DGSOC)
"RTN","DGREGTZL",87,0)
 . S DIR("B")=$$GET1^DIQ(2,DFN_",",FCITY)
"RTN","DGREGTZL",88,0)
 . S DIR("A")=$G(DGCITY("LABEL"))
"RTN","DGREGTZL",89,0)
CAGN1 . D ^DIR
"RTN","DGREGTZL",90,0)
 . I $D(DTOUT) S RESULT=-1 Q
"RTN","DGREGTZL",91,0)
 . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGTED G CAGN1
"RTN","DGREGTZL",92,0)
 . S RESULT=$P($G(Y(0)),"*")
"RTN","DGREGTZL",93,0)
 . S DGIND=$G(Y)
"RTN","DGREGTZL",94,0)
 I ($G(Y)=99)!($D(DGDATA("ERROR"))) D
"RTN","DGREGTZL",95,0)
CAGN2 . I '$D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q
"RTN","DGREGTZL",96,0)
 . N DIR,X,Y
"RTN","DGREGTZL",97,0)
 . S DIR(0)="2,"_FCITY
"RTN","DGREGTZL",98,0)
 . S DA=DFN
"RTN","DGREGTZL",99,0)
 . D ^DIR
"RTN","DGREGTZL",100,0)
 . I $D(DTOUT) S RESULT=-1 Q
"RTN","DGREGTZL",101,0)
 . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGTED G CAGN2
"RTN","DGREGTZL",102,0)
 . S RESULT=$G(Y)
"RTN","DGREGTZL",103,0)
 I $L($G(RESULT))>15 D
"RTN","DGREGTZL",104,0)
 . S DGN=Y
"RTN","DGREGTZL",105,0)
 . S RESULT=$G(DGDATA(DGN,"CITY ABBREVIATION"))
"RTN","DGREGTZL",106,0)
 Q DGIND
"RTN","DGREGTZL",107,0)
 ;
"RTN","DGREGTZL",108,0)
LINK(RESULT,ZIP,DGN) ;From zip, get the linked state,county
"RTN","DGREGTZL",109,0)
 K RESULT
"RTN","DGREGTZL",110,0)
 N DGDATA,CNTYIEN
"RTN","DGREGTZL",111,0)
 S CNTYIEN=""
"RTN","DGREGTZL",112,0)
 S DGN=$G(DGN)
"RTN","DGREGTZL",113,0)
 I (DGN="")&($$MLT^DGREGDD1(ZIP)) S DGN=1
"RTN","DGREGTZL",114,0)
 I (DGN=99)&($$MLT^DGREGDD1(ZIP)) S DGN=1
"RTN","DGREGTZL",115,0)
 I (DGN="")!(DGN=99) Q
"RTN","DGREGTZL",116,0)
 D POSTALB^XIPUTIL(ZIP,.DGDATA)
"RTN","DGREGTZL",117,0)
 S:$G(DGDATA(DGN,"STATE POINTER"))'="" CNTYIEN=$$FIND1^DIC(5.01,","_$G(DGDATA(DGN,"STATE POINTER"))_",","MOXQ",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),"C")
"RTN","DGREGTZL",118,0)
 D:'CNTYIEN  ;could be duplicate county codes in subfile #5.01
"RTN","DGREGTZL",119,0)
 .Q:'$D(^DIC(5,+$G(DGDATA(DGN,"STATE POINTER")),1))
"RTN","DGREGTZL",120,0)
 .Q:$E($G(DGDATA(DGN,"FIPS CODE")),3,5)=""
"RTN","DGREGTZL",121,0)
 .S CNTYIEN=$O(^DIC(5,$G(DGDATA(DGN,"STATE POINTER")),1,"C",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),""))
"RTN","DGREGTZL",122,0)
 S RESULT(FSTATE)=$G(DGDATA(DGN,"STATE"))_U_$G(DGDATA(DGN,"STATE POINTER"))
"RTN","DGREGTZL",123,0)
 S RESULT(FCOUNTY)=$G(DGDATA(DGN,"COUNTY"))_U_$G(CNTYIEN)_U_$E($G(DGDATA(DGN,"FIPS CODE")),3,5)
"RTN","DGREGTZL",124,0)
 Q
"RTN","DGREGTZL",125,0)
 ;
"RTN","DGREGTZL",126,0)
STCNTY(RESULT,ZIP,DFN,DGNUM) ;Based on zip,input state (#FSTATE) and county (#FCOUNTY)
"RTN","DGREGTZL",127,0)
 K RESULT
"RTN","DGREGTZL",128,0)
 S DGNUM=$G(DGNUM)
"RTN","DGREGTZL",129,0)
 N DGN,DGDFLT,DGST,POP,DIR,X,Y,DTOUT,DUOUT,DIROUT
"RTN","DGREGTZL",130,0)
 S POP=0
"RTN","DGREGTZL",131,0)
 D LINK(.DGDFLT,ZIP,DGNUM)
"RTN","DGREGTZL",132,0)
 F DGN=FSTATE,FCOUNTY Q:POP  D
"RTN","DGREGTZL",133,0)
SCAGN . I DGN=FSTATE S DIR(0)=2_","_DGN
"RTN","DGREGTZL",134,0)
 . I ($G(DGST)="")&(DGN=FCOUNTY) Q
"RTN","DGREGTZL",135,0)
 . I DGN=FCOUNTY S DIR(0)="POA^DIC(5,DGST,1,:AEMQ"
"RTN","DGREGTZL",136,0)
 . S DIR("B")=$P($G(DGDFLT(DGN)),U)
"RTN","DGREGTZL",137,0)
 . D ^DIR
"RTN","DGREGTZL",138,0)
 . I $D(DTOUT) S POP=1 Q
"RTN","DGREGTZL",139,0)
 . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G SCAGN
"RTN","DGREGTZL",140,0)
 . S RESULT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U)
"RTN","DGREGTZL",141,0)
 . I DGN=FSTATE S DGST=$P($G(Y),U)
"RTN","DGREGTZL",142,0)
 . I DGN=FCOUNTY S RESULT(FCOUNTY)=$$CNTY(DGST,$P($G(RESULT(FCOUNTY)),U,2))
"RTN","DGREGTZL",143,0)
 I POP=1 S RESULT=-1
"RTN","DGREGTZL",144,0)
 Q
"RTN","DGREGTZL",145,0)
CNTY(DGST,DGCIEN) ;Return county name and code
"RTN","DGREGTZL",146,0)
 ;Input:state number and county IEN
"RTN","DGREGTZL",147,0)
 ;Output: CountyName^CountyIEN^CountyCode
"RTN","DGREGTZL",148,0)
 I ($G(DGST)="")!($G(DGCIEN)="") S RESULT=-1 Q RESULT
"RTN","DGREGTZL",149,0)
 N DGR,RESULT
"RTN","DGREGTZL",150,0)
 S DGR=$G(^DIC(5,DGST,1,DGCIEN,0))
"RTN","DGREGTZL",151,0)
 S RESULT=$P($G(DGR),U)_U_DGCIEN_U_$P($G(DGR),U,3)
"RTN","DGREGTZL",152,0)
 Q RESULT
"RTN","DGREGTZL",153,0)
FOREIGN() ;Manila (Philippines) doesn't need zip linking.
"RTN","DGREGTZL",154,0)
 ;Output: 1 - area need no zip linking
"RTN","DGREGTZL",155,0)
 ;        0 - zip-linking area
"RTN","DGREGTZL",156,0)
 I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=358 Q 1
"RTN","DGREGTZL",157,0)
 ;;;I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=500 Q 1 ;;HERE TEST
"RTN","DGREGTZL",158,0)
 Q 0
"RTN","DGREGTZL",159,0)
FRGNEDT(DGINPUT,DFN) ;Edit zip+4, city, state, county for no zip-linking area
"RTN","DGREGTZL",160,0)
 K DGINPUT
"RTN","DGREGTZL",161,0)
 N DGN,DIR,DTOUT,DUOUT,DIROUT,X,Y,POP,DGST
"RTN","DGREGTZL",162,0)
 S POP=0
"RTN","DGREGTZL",163,0)
 F DGN=FZIP,FCITY,FSTATE,FCOUNTY Q:POP  D
"RTN","DGREGTZL",164,0)
FAGN . I ($G(DGST)="")&(DGN=FCOUNTY) Q
"RTN","DGREGTZL",165,0)
 . S DIR(0)=2_","_DGN
"RTN","DGREGTZL",166,0)
 . I DGN=FCOUNTY D
"RTN","DGREGTZL",167,0)
 .. S DIR(0)="POA^DIC(5,DGST,1,:AEMQ"
"RTN","DGREGTZL",168,0)
 .. S DIR("B")=$$GET1^DIQ(2,DFN_",",FCOUNTY)
"RTN","DGREGTZL",169,0)
 . I DGN'=FCOUNTY S DA=DFN
"RTN","DGREGTZL",170,0)
 . D ^DIR
"RTN","DGREGTZL",171,0)
 . I $D(DTOUT) S POP=1 Q
"RTN","DGREGTZL",172,0)
 . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G FAGN
"RTN","DGREGTZL",173,0)
 . I (DGN=FCITY)!(DGN=FZIP) S DGINPUT(DGN)=$G(Y)
"RTN","DGREGTZL",174,0)
 . I (DGN=FSTATE) D
"RTN","DGREGTZL",175,0)
 .. S DGST=$P($G(Y),U)
"RTN","DGREGTZL",176,0)
 .. I DGST=$$GET1^DIQ(2,DFN_",",FSTATE,"I") D
"RTN","DGREGTZL",177,0)
 ... S DGINPUT(FSTATE)=$$GET1^DIQ(2,DFN_",",FSTATE)_U_DGST
"RTN","DGREGTZL",178,0)
 .. I DGST'=$$GET1^DIQ(2,DFN_",",FSTATE,"I") D
"RTN","DGREGTZL",179,0)
 ... S DGINPUT(FSTATE)=$P($G(Y(0)),U)_U_DGST
"RTN","DGREGTZL",180,0)
 . I DGN=FCOUNTY S DGINPUT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U)
"RTN","DGREGTZL",181,0)
 I POP=1 S RESULT=-1
"RTN","DGREGTZL",182,0)
 Q
"RTN","DGREGTZL",183,0)
 ;
"RTN","DGREGTZL",184,0)
ALWEDTTC(DUZ,ZIP) ; determine if a security key is necessary for editing
"RTN","DGREGTZL",185,0)
 ; Input: zip code
"RTN","DGREGTZL",186,0)
 ; Output: 1: allow edit state and county
"RTN","DGREGTZL",187,0)
 ;         0: don't allow edit state and county
"RTN","DGREGTZL",188,0)
 N EASDATA
"RTN","DGREGTZL",189,0)
 I $G(ZIP)="" Q 0
"RTN","DGREGTZL",190,0)
 I '$D(DUZ) Q 0
"RTN","DGREGTZL",191,0)
 I '$$MLT^DGREGDD1(ZIP) Q 1 ; > 1 state or county for the zip - allow edit
"RTN","DGREGTZL",192,0)
 I $$FOREIGN^DGREGAZL() Q 1 ; Foreign location - allow edit
"RTN","DGREGTZL",193,0)
 D POSTAL^XIPUTIL(ZIP,.EASDATA)
"RTN","DGREGTZL",194,0)
 Q:$D(EASDATA("ERROR")) 1  ;zip code does not exist - allow editing
"RTN","DGREGTZL",195,0)
 Q:'$D(EASDATA("FIPS CODE")) 1  ;cnty code does not exist - allow edit
"RTN","DGREGTZL",196,0)
 Q:'$D(EASDATA("STATE")) 1  ;state does not exist - allow editing
"RTN","DGREGTZL",197,0)
 Q:$D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) 1  ;user holds security key
"RTN","DGREGTZL",198,0)
 W !,$S(TYPE="TEMP":"TEMPORARY ",TYPE="CONF":"CONFIDENTIAL ",1:"")_"STATE: ",$G(EASDATA("STATE"))
"RTN","DGREGTZL",199,0)
 W !,$S(TYPE="TEMP":"TEMPORARY ",TYPE="CONF":"CONFIDENTIAL ",1:"")_"COUNTY: ",$G(EASDATA("COUNTY"))
"RTN","DGREGTZL",200,0)
 Q 0
"RTN","DGRP1")
0^4^B35716153
"RTN","DGRP1",1,0)
DGRP1 ;ALB/MRL,ERC,BAJ,PWC - DEMOGRAPHIC DATA ; 8/15/08 11:30am
"RTN","DGRP1",2,0)
 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,688,750,851**;Aug 13, 1993;Build 10
"RTN","DGRP1",3,0)
 ;
"RTN","DGRP1",4,0)
EN ;
"RTN","DGRP1",5,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",6,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",7,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",8,0)
 ;Retrieve SSN Verification status DG*5.3*688 BAJ 11/22/2005
"RTN","DGRP1",9,0)
 N SSNV D GETSTAT(.SSNV)
"RTN","DGRP1",10,0)
 W ! S Z=1 D WW^DGRPV W "    Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
"RTN","DGRP1",11,0)
 ;Display SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
"RTN","DGRP1",12,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",13,0)
 W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
"RTN","DGRP1",14,0)
 ;add Pseuso SSN Reason - DG*5.3*653, ERC
"RTN","DGRP1",15,0)
 I $P(DGRP(0),U,9)["P" D
"RTN","DGRP1",16,0)
 . N DGSPACE
"RTN","DGRP1",17,0)
 . S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen
"RTN","DGRP1",18,0)
 . S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: "
"RTN","DGRP1",19,0)
 . I $P(DGRP(0),U,9)["P" D
"RTN","DGRP1",20,0)
 . . N DGREAS D SSNREAS(.DGREAS)
"RTN","DGRP1",21,0)
 . . Q:$G(DGREAS)']""
"RTN","DGRP1",22,0)
 . . W DGREAS
"RTN","DGRP1",23,0)
 D GETNCAL  ;Display name component, sex, and alias information
"RTN","DGRP1",24,0)
 S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") 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","DGRP1",25,0)
 S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
"RTN","DGRP1",26,0)
 D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: "
"RTN","DGRP1",27,0)
 W !?9
"RTN","DGRP1",28,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 TEMPORARY ADDRESS")
"RTN","DGRP1",29,0)
 ; loop through DGA array beginning with DGA(2) and print data at ?9 (odds) and ?48 (evens)
"RTN","DGRP1",30,0)
 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>50) !?9 W:'(I#2) ?48 W DGA(I)
"RTN","DGRP1",31,0)
 D COUNTY(.DGRP)  ; print County if applicable
"RTN","DGRP1",32,0)
 W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
"RTN","DGRP1",33,0)
 S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
"RTN","DGRP1",34,0)
 W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
"RTN","DGRP1",35,0)
 W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
"RTN","DGRP1",36,0)
 ;
"RTN","DGRP1",37,0)
 ; ***  Additional displays added for Pre-Registration
"RTN","DGRP1",38,0)
 I $G(DGPRFLG)=1 D
"RTN","DGRP1",39,0)
 . W !
"RTN","DGRP1",40,0)
 . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1,ADDRDTTM
"RTN","DGRP1",41,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",42,0)
 . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
"RTN","DGRP1",43,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",44,0)
 . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
"RTN","DGRP1",45,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",46,0)
 . S ADDRDTTM=$P($G(^DPT(DFN,.11)),"^",13)
"RTN","DGRP1",47,0)
 . I ADDRDTTM'="" W !," [PERMANENT ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(ADDRDTTM,"5D")
"RTN","DGRP1",48,0)
 . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
"RTN","DGRP1",49,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",50,0)
 . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
"RTN","DGRP1",51,0)
 . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
"RTN","DGRP1",52,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",53,0)
 .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
"RTN","DGRP1",54,0)
 .. W "  EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D"),"  EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
"RTN","DGRP1",55,0)
 ;
"RTN","DGRP1",56,0)
 G ^DGRPP
"RTN","DGRP1",57,0)
 ;
"RTN","DGRP1",58,0)
GETNCAL ;Get name component values
"RTN","DGRP1",59,0)
 N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
"RTN","DGRP1",60,0)
 S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
"RTN","DGRP1",61,0)
 S DGCOMP=+$G(^DPT(DFN,"NAME"))_","
"RTN","DGRP1",62,0)
 I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
"RTN","DGRP1",63,0)
 ;Get alias values
"RTN","DGRP1",64,0)
 S DGA=0 F DGI=1:1:5 D  Q:'$D(DGALIAS(DGI))
"RTN","DGRP1",65,0)
A2 .S DGA=$O(^DPT(DFN,.01,DGA))
"RTN","DGRP1",66,0)
 .I 'DGA D:DGI=1  Q
"RTN","DGRP1",67,0)
 ..S DGALIAS(DGI)="< No alias entries on file >" Q
"RTN","DGRP1",68,0)
 .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q
"RTN","DGRP1",69,0)
 .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2
"RTN","DGRP1",70,0)
 .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)
"RTN","DGRP1",71,0)
 .I $L(DGX) D
"RTN","DGRP1",72,0)
 ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)
"RTN","DGRP1",73,0)
 ..; BAJ DG*5.2*700 retrofit 06/22/06
"RTN","DGRP1",74,0)
 ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)
"RTN","DGRP1",75,0)
 ..S $E(DGALIAS(DGI),20)=DGX Q
"RTN","DGRP1",76,0)
 .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)
"RTN","DGRP1",77,0)
 .Q
"RTN","DGRP1",78,0)
 ;Display name component, sex, multiple birth indicator and alias data
"RTN","DGRP1",79,0)
 F DGI=1:1:6 D
"RTN","DGRP1",80,0)
 .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:28,1:27))
"RTN","DGRP1",81,0)
 .; BAJ DG*5.3*700 retrofit 06/22/06
"RTN","DGRP1",82,0)
 .I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV
"RTN","DGRP1",83,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",84,0)
 .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "
"RTN","DGRP1",85,0)
 .I DGI>1 W ?47,$G(DGALIAS(DGI-1))
"RTN","DGRP1",86,0)
 .Q
"RTN","DGRP1",87,0)
 Q
"RTN","DGRP1",88,0)
GETSTAT(SSNV) ;get SSN VERIFIED STATUS DG*5.3*688 BAJ 11/22/2005
"RTN","DGRP1",89,0)
 N T
"RTN","DGRP1",90,0)
 S T=$P($G(^DPT(DFN,"SSN")),"^",2)
"RTN","DGRP1",91,0)
 S SSNV=$S(T=2:"INVALID",T=4:"VERIFIED",1:"")
"RTN","DGRP1",92,0)
 Q
"RTN","DGRP1",93,0)
 ;
"RTN","DGRP1",94,0)
SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
"RTN","DGRP1",95,0)
 S DGREAS=$P(DGRP("SSN"),U)
"RTN","DGRP1",96,0)
 I $G(DGREAS)']"" Q
"RTN","DGRP1",97,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",98,0)
 Q
"RTN","DGRP1",99,0)
COUNTY(DGRP) ;retrieve and print County info if a US address
"RTN","DGRP1",100,0)
 N DGCC,CNODE,FNODE,FPCE,FILE,IEN,CNTRY,PLINE
"RTN","DGRP1",101,0)
 ; data location of Permanent Address County info
"RTN","DGRP1",102,0)
 S FNODE=.11,FPCE=10,DGCC=""
"RTN","DGRP1",103,0)
 ; only print county info if it's a US address
"RTN","DGRP1",104,0)
 S IEN=$P(DGRP(FNODE),U,FPCE) I '$$FORIEN^DGADDUTL(IEN) D
"RTN","DGRP1",105,0)
 . S DGCC=$S($D(^DIC(5,+$P(DGRP(FNODE),U,5),1,+$P(DGRP(FNODE),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU)
"RTN","DGRP1",106,0)
 S PLINE=$S(DGCC]"":"County: "_DGCC,1:"")
"RTN","DGRP1",107,0)
 W !?3,PLINE
"RTN","DGRP1",108,0)
 S DGCC=""
"RTN","DGRP1",109,0)
 ; data location of Temporary address County info
"RTN","DGRP1",110,0)
 S CNODE=.121,FNODE=.122,FPCE=3
"RTN","DGRP1",111,0)
 ; only print county info if it's a US address
"RTN","DGRP1",112,0)
 S IEN=$P(DGRP(FNODE),U,FPCE) I '$$FORIEN^DGADDUTL(IEN) D
"RTN","DGRP1",113,0)
 . S DGCC=$S($P(DGRP(CNODE),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(CNODE),U,5),1,+$P(DGRP(CNODE),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU)
"RTN","DGRP1",114,0)
 S PLINE=$S(DGCC]"":"County: "_DGCC,1:"")
"RTN","DGRP1",115,0)
 W ?43,PLINE
"RTN","DGRP1",116,0)
 Q
"RTN","DGRP1",117,0)
 ;
"VER")
8.0^22.0
"^DD",2,2,.131,0)
PHONE NUMBER [RESIDENCE]^Fa^^.13;1^K:$L(X)>20!($L(X)<4) X
"^DD",2,2,.131,.1)

"^DD",2,2,.131,1,0)
^.1
"^DD",2,2,.131,1,1,0)
2^AENR131^MUMPS
"^DD",2,2,.131,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.131,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.131,1,1,3)
DO NOT DELETE
"^DD",2,2,.131,1,1,"%D",0)
^.101^2^2^3120127^^^^
"^DD",2,2,.131,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.131,1,1,"%D",2,0)
enrollment. 
"^DD",2,2,.131,1,1,"DT")
2971007
"^DD",2,2,.131,1,2,0)
2^F
"^DD",2,2,.131,1,2,1)
S ^DPT("F",$E(X,1,30),DA)=""
"^DD",2,2,.131,1,2,2)
K ^DPT("F",$E(X,1,30),DA)
"^DD",2,2,.131,1,2,"%D",0)
^^1^1^3120127^
"^DD",2,2,.131,1,2,"%D",1,0)
This cross reference will update the PHONE NUMBER CHANGE DT/TM field with current date and time stamp each time this field is changed.
"^DD",2,2,.131,1,2,"DT")
3120127
"^DD",2,2,.131,1,3,0)
^^TRIGGER^2^.1321
"^DD",2,2,.131,1,3,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.132)):^(.132),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.132)),DIV=X S $P(^(.132),U,1)=DIV,DIH=2,DIG=.1321 D ^DICR
"^DD",2,2,.131,1,3,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.132)):^(.132),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.132)),DIV=X S $P(^(.132),U,1)=DIV,DIH=2,DIG=.1321 D ^DICR
"^DD",2,2,.131,1,3,"%D",0)
^^3^3^3120131^
"^DD",2,2,.131,1,3,"%D",1,0)
This cross reference will update the RESIDENCE
"^DD",2,2,.131,1,3,"%D",2,0)
NUMBER CHANGE DT/TM field with the current date and
"^DD",2,2,.131,1,3,"%D",3,0)
time stamp each time this field is changed.
"^DD",2,2,.131,1,3,"CREATE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.131,1,3,"DELETE VALUE")
S X=$$NOW^XLFDT()
"^DD",2,2,.131,1,3,"DT")
3120131
"^DD",2,2,.131,1,3,"FIELD")
RESIDENCE NUMBER CHANGE DT/TM
"^DD",2,2,.131,1,301,0)
2^IVM131^MUMPS
"^DD",2,2,.131,1,301,1)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.131,1,301,2)
S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
"^DD",2,2,.131,1,301,"%D",0)
^^5^5^2930605^
"^DD",2,2,.131,1,301,"%D",1,0)
This cross-reference will check the IVM PATIENT file to see if a change
"^DD",2,2,.131,1,301,"%D",2,0)
to this field will require transmission to the IVM Center.  If it does,
"^DD",2,2,.131,1,301,"%D",3,0)
the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
"^DD",2,2,.131,1,301,"%D",4,0)
the nightly background job will transmit the updated information.
"^DD",2,2,.131,1,301,"DT")
2930605
"^DD",2,2,.131,1,991,0)
2^AVAFC131^MUMPS
"^DD",2,2,.131,1,991,1)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.131,1,991,2)
I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
"^DD",2,2,.131,1,991,"%D",0)
^^15^15^2990204^^^^
"^DD",2,2,.131,1,991,"%D",1,0)
This cross reference is used to remember that changes were made to the
"^DD",2,2,.131,1,991,"%D",2,0)
PATIENT file (#2) outside of the Registration process.  Execution of this
"^DD",2,2,.131,1,991,"%D",3,0)
cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
"^DD",2,2,.131,1,991,"%D",4,0)
and mark it as requiring transmission of an HL7 ADT-A08 message.
"^DD",2,2,.131,1,991,"%D",5,0)
 
"^DD",2,2,.131,1,991,"%D",6,0)
The local variable VAFCFLG will be set to 1 if the cross reference is
"^DD",2,2,.131,1,991,"%D",7,0)
not executed because the change is being made from within the Registration
"^DD",2,2,.131,1,991,"%D",8,0)
process.
"^DD",2,2,.131,1,991,"%D",9,0)
 
"^DD",2,2,.131,1,991,"%D",10,0)
Execution of this cross reference can be prevented by setting the local
"^DD",2,2,.131,1,991,"%D",11,0)
variable VAFCA08 equal to 1.
"^DD",2,2,.131,1,991,"%D",12,0)
  
"^DD",2,2,.131,1,991,"%D",13,0)
The local variable VAFCF is used to identify the field edited.
"^DD",2,2,.131,1,991,"%D",14,0)
This data is stored in the FIELD(S) EDITED (#2.1) field in the 
"^DD",2,2,.131,1,991,"%D",15,0)
ADT/HL7 PIVOT file (#391.71).
"^DD",2,2,.131,1,991,"DT")
2970825
"^DD",2,2,.131,1,992,0)
2^ADGRU131^MUMPS
"^DD",2,2,.131,1,992,1)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.131,1,992,2)
D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
"^DD",2,2,.131,1,992,"%D",0)
^^9^9^2990920^
"^DD",2,2,.131,1,992,"%D",1,0)
This cross reference is used to remember that changes were made to a 
"^DD",2,2,.131,1,992,"%D",2,0)
monitored data field in the PATIENT File (#2) required for a vendor
"^DD",2,2,.131,1,992,"%D",3,0)
RAI/MDS COTS system.  Execution of this cross reference will create
"^DD",2,2,.131,1,992,"%D",4,0)
an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
"^DD",2,2,.131,1,992,"%D",5,0)
transmission of an HL7 demographic A08 update message to the COTS
"^DD",2,2,.131,1,992,"%D",6,0)
interface.
"^DD",2,2,.131,1,992,"%D",7,0)
 
"^DD",2,2,.131,1,992,"%D",8,0)
The local variable DGRUGA08 will be set to 1 if the cross reference is
"^DD",2,2,.131,1,992,"%D",9,0)
not to be executed as part of a re-indexing.
"^DD",2,2,.131,1,992,"DT")
2990920
"^DD",2,2,.131,3)
Enter the patients home telephone number [4-20 characters].
"^DD",2,2,.131,20,0)
^.3LA^1^1
"^DD",2,2,.131,20,1,0)
DEMOG
"^DD",2,2,.131,21,0)
^.001^2^2^3041006^^^
"^DD",2,2,.131,21,1,0)
Enter the telephone number [4-20 characters] to this applicant's
"^DD",2,2,.131,21,2,0)
place of residence.
"^DD",2,2,.131,"AUDIT")
y
"^DD",2,2,.131,"DT")
3120131
"^DD",2,2,.1321,0)
RESIDENCE NUMBER CHANGE DT/TM^D^^.132;1^S %DT="ESTX" D ^%DT S X=Y K:Y<1 X
"^DD",2,2,.1321,1,0)
^.1
"^DD",2,2,.1321,1,1,0)
^^TRIGGER^2^.1322
"^DD",2,2,.1321,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.132)):^(.132),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.132)),DIV=X S $P(^(.132),U,2)=DIV,DIH=2,DIG=.1322 D ^DICR
"^DD",2,2,.1321,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.132)):^(.132),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X="VAMC" S DIH=$G(^DPT(DIV(0),.132)),DIV=X S $P(^(.132),U,2)=DIV,DIH=2,DIG=.1322 D ^DICR
"^DD",2,2,.1321,1,1,"CREATE VALUE")
S X="VAMC"
"^DD",2,2,.1321,1,1,"DELETE VALUE")
S X="VAMC"
"^DD",2,2,.1321,1,1,"FIELD")
RESIDENCE NUMBER CHANGE SOURCE
"^DD",2,2,.1321,3)
Please enter the date and time of the Residence phone number change.
"^DD",2,2,.1321,5,1,0)
2^.131^3
"^DD",2,2,.1321,9)
^
"^DD",2,2,.1321,21,0)
^.001^2^2^3120424^^^^
"^DD",2,2,.1321,21,1,0)
This field will contain the date and time of
"^DD",2,2,.1321,21,2,0)
the last Residence phone number update.
"^DD",2,2,.1321,"DT")
3120424
"^DD",2,2,.1322,0)
RESIDENCE NUMBER CHANGE SOURCE^S^HEC:HEC;VAMC:VAMC;HBSC:HBSC;VOA:VOA;^.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")
3120424
"^DD",2,2,.1323,0)
RESIDENCE NUMBER CHANGE SITE^P4'^DIC(4,^.132;3^Q
"^DD",2,2,.1323,3)
Please enter the site that last changed this patient's Residence phone number.
"^DD",2,2,.1323,5,1,0)
2^.1322^1
"^DD",2,2,.1323,9)
^
"^DD",2,2,.1323,21,0)
^^4^4^3120201^
"^DD",2,2,.1323,21,1,0)
This field will hold the site that last changed
"^DD",2,2,.1323,21,2,0)
this patient's Residence phone number.  This
"^DD",2,2,.1323,21,3,0)
field is only populated when the Residence
"^DD",2,2,.1323,21,4,0)
Number Change Source is listed as VAMC.
"^DD",2,2,.1323,"DT")
3120424
**INSTALL NAME**
IVM*2.0*152
"BLD",8405,0)
IVM*2.0*152^INCOME VERIFICATION MATCH^0^3121017^y
"BLD",8405,1,0)
^^1^1^3120214^^
"BLD",8405,1,1,0)
Permanent Address Verification
"BLD",8405,4,0)
^9.64PA^^
"BLD",8405,6.3)
4
"BLD",8405,"INI")

"BLD",8405,"INID")
^n^
"BLD",8405,"INIT")
EP^IVM2152P
"BLD",8405,"KRN",0)
^9.67PA^779.2^20
"BLD",8405,"KRN",.4,0)
.4
"BLD",8405,"KRN",.401,0)
.401
"BLD",8405,"KRN",.402,0)
.402
"BLD",8405,"KRN",.403,0)
.403
"BLD",8405,"KRN",.5,0)
.5
"BLD",8405,"KRN",.84,0)
.84
"BLD",8405,"KRN",3.6,0)
3.6
"BLD",8405,"KRN",3.8,0)
3.8
"BLD",8405,"KRN",9.2,0)
9.2
"BLD",8405,"KRN",9.8,0)
9.8
"BLD",8405,"KRN",9.8,"NM",0)
^9.68A^9^9
"BLD",8405,"KRN",9.8,"NM",1,0)
IVMPTRN9^^0^B53346875
"BLD",8405,"KRN",9.8,"NM",2,0)
IVMPTRNA^^0^B15638011
"BLD",8405,"KRN",9.8,"NM",3,0)
IVM2152P^^0^B8144502
"BLD",8405,"KRN",9.8,"NM",4,0)
IVMPREC8^^0^B230918624
"BLD",8405,"KRN",9.8,"NM",5,0)
IVMLDEM6^^0^B88291633
"BLD",8405,"KRN",9.8,"NM",6,0)
IVMLDEM9^^0^B62902959
"BLD",8405,"KRN",9.8,"NM",7,0)
IVMPREC6^^0^B147269412
"BLD",8405,"KRN",9.8,"NM",8,0)
IVMLDEM7^^0^B19787743
"BLD",8405,"KRN",9.8,"NM",9,0)
IVMLDEM4^^0^B36894677
"BLD",8405,"KRN",9.8,"NM","B","IVM2152P",3)

"BLD",8405,"KRN",9.8,"NM","B","IVMLDEM4",9)

"BLD",8405,"KRN",9.8,"NM","B","IVMLDEM6",5)

"BLD",8405,"KRN",9.8,"NM","B","IVMLDEM7",8)

"BLD",8405,"KRN",9.8,"NM","B","IVMLDEM9",6)

"BLD",8405,"KRN",9.8,"NM","B","IVMPREC6",7)

"BLD",8405,"KRN",9.8,"NM","B","IVMPREC8",4)

"BLD",8405,"KRN",9.8,"NM","B","IVMPTRN9",1)

"BLD",8405,"KRN",9.8,"NM","B","IVMPTRNA",2)

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

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

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

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

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

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

"BLD",8405,"KRN","B",3.6,3.6)

"BLD",8405,"KRN","B",3.8,3.8)

"BLD",8405,"KRN","B",9.2,9.2)

"BLD",8405,"KRN","B",9.8,9.8)

"BLD",8405,"KRN","B",19,19)

"BLD",8405,"KRN","B",19.1,19.1)

"BLD",8405,"KRN","B",101,101)

"BLD",8405,"KRN","B",409.61,409.61)

"BLD",8405,"KRN","B",771,771)

"BLD",8405,"KRN","B",779.2,779.2)

"BLD",8405,"KRN","B",870,870)

"BLD",8405,"KRN","B",8989.51,8989.51)

"BLD",8405,"KRN","B",8989.52,8989.52)

"BLD",8405,"KRN","B",8994,8994)

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

"BLD",8405,"REQB","B","IVM*2.0*151",2)

"INIT")
EP^IVM2152P
"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)
152^3121017
"PKG",120,22,1,"PAH",1,1,0)
^^1^1^3121017
"PKG",120,22,1,"PAH",1,1,1,0)
Permanent Address Verification
"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")
9
"RTN","IVM2152P")
0^3^B8144502
"RTN","IVM2152P",1,0)
IVM2152P ;ALB/LBD - Patch IVM*2*152 Post-Install Routine ; 3/28/12 1:36pm
"RTN","IVM2152P",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**152**;21-OCT-94;Build 4
"RTN","IVM2152P",3,0)
 ;
"RTN","IVM2152P",4,0)
 ;This routine will add new entries to the IVM DEMOGRAPHIC UPLOAD
"RTN","IVM2152P",5,0)
 ;FIELDS file #301.92
"RTN","IVM2152P",6,0)
 Q
"RTN","IVM2152P",7,0)
 ;
"RTN","IVM2152P",8,0)
EP ;Entry point - Driver
"RTN","IVM2152P",9,0)
 N ABORT,FILE,I,ELEMNT,EXIST,IVMDATA,DATA,SUB,J,VALUE,FILEFLG,DIERR,ERROR
"RTN","IVM2152P",10,0)
 ;
"RTN","IVM2152P",11,0)
 S (ABORT,FILEFLG)=0,FILE=301.92
"RTN","IVM2152P",12,0)
 F I=1:1 S ELEMNT=$P($T(TEXT+I),";;",2) Q:ELEMNT="QUIT"!(ABORT)  D
"RTN","IVM2152P",13,0)
 . S EXIST=0
"RTN","IVM2152P",14,0)
 . K IVMDATA S (DATA,SUB)="" F J=1:1:$L(ELEMNT,";") S DATA=$P(ELEMNT,";",J) D  Q:EXIST
"RTN","IVM2152P",15,0)
 . . S SUB=$P(DATA,"~",1),VALUE=$P(DATA,"~",2),IVMDATA(SUB)=VALUE
"RTN","IVM2152P",16,0)
 . . I SUB=.01 S EXIST=$$FIND1^DIC(FILE,,,IVMDATA(.01))
"RTN","IVM2152P",17,0)
 . I 'EXIST D
"RTN","IVM2152P",18,0)
 . . S FILEFLG=$$ADD(FILE,.IVMDATA)
"RTN","IVM2152P",19,0)
 . . I FILEFLG D MES^XPDUTL("Added - "_$G(IVMDATA(.01)))
"RTN","IVM2152P",20,0)
 . . I 'FILEFLG D
"RTN","IVM2152P",21,0)
 . . . S ABORT=1,XPDABORT=2
"RTN","IVM2152P",22,0)
 . . . D BMES^XPDUTL("Install process could not add an entry in file for "_$G(IVMDATA(.01)))
"RTN","IVM2152P",23,0)
 . . . D BMES^XPDUTL("                        <<<< INSTALLATION ABORTED >>>>")
"RTN","IVM2152P",24,0)
 I 'ABORT D BMES^XPDUTL("<<<< Post Install Successful >>>>")
"RTN","IVM2152P",25,0)
 Q
"RTN","IVM2152P",26,0)
 ;
"RTN","IVM2152P",27,0)
ADD(FILE,DATA) ;
"RTN","IVM2152P",28,0)
 ;Description: Creates a new record and files the data.
"RTN","IVM2152P",29,0)
 ; Input:
"RTN","IVM2152P",30,0)
 ;   FILE - File or sub-file number
"RTN","IVM2152P",31,0)
 ;   DATA - Data array to file, pass by reference
"RTN","IVM2152P",32,0)
 ;          Format: DATA(<field #>)=<value>
"RTN","IVM2152P",33,0)
 ;
"RTN","IVM2152P",34,0)
 ; Output:
"RTN","IVM2152P",35,0)
 ;   Function Value - If no error then it returns the ien of the created record, else returns NULL.
"RTN","IVM2152P",36,0)
 ;
"RTN","IVM2152P",37,0)
 N FDA,FIELD,IEN,IENA,IENS,IVMDA,ERRORS
"RTN","IVM2152P",38,0)
 ;
"RTN","IVM2152P",39,0)
 ;IENS - Internal Entry Number String defined by FM
"RTN","IVM2152P",40,0)
 ;IENA - the Internal Entry Number Array defined by FM
"RTN","IVM2152P",41,0)
 ;FDA - the FDA array defined by FM
"RTN","IVM2152P",42,0)
 ;IEN - the ien of the new record
"RTN","IVM2152P",43,0)
 ;
"RTN","IVM2152P",44,0)
 S IVMDA="+1"
"RTN","IVM2152P",45,0)
 S IENS=$$IENS^DILF(.IVMDA)
"RTN","IVM2152P",46,0)
 S FIELD=0
"RTN","IVM2152P",47,0)
 F  S FIELD=$O(DATA(FIELD)) Q:'FIELD  D
"RTN","IVM2152P",48,0)
 .S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
"RTN","IVM2152P",49,0)
 I $G(IEN) S IENA(1)=IEN
"RTN","IVM2152P",50,0)
 D UPDATE^DIE("","FDA","IENA","ERRORS(1)")
"RTN","IVM2152P",51,0)
 I +$G(DIERR) D
"RTN","IVM2152P",52,0)
 .S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
"RTN","IVM2152P",53,0)
 .S IEN=""
"RTN","IVM2152P",54,0)
 E  D
"RTN","IVM2152P",55,0)
 .S IEN=IENA(1)
"RTN","IVM2152P",56,0)
 .S ERROR=""
"RTN","IVM2152P",57,0)
 D CLEAN^DILF
"RTN","IVM2152P",58,0)
 Q IEN
"RTN","IVM2152P",59,0)
 ;
"RTN","IVM2152P",60,0)
TEXT ;;FIELD#~VALUE;FIELD#~VALUE;FIELD#~VALUE.....
"RTN","IVM2152P",61,0)
 ;;.01~RESIDENCE NUMBER CHANGE DT/TM;.02~RF171P;.03~1;.04~2;.05~.1321;.06~1;.07~1;.08~1;10~S DR=.1321 D LOOK^IVMPREC9;20~S DR=.1321 D LOOK^IVMPREC9
"RTN","IVM2152P",62,0)
 ;;.01~RESIDENCE NUMBER CHANGE SOURCE;.02~RF162P;.03~1;.04~2;.05~.1322;.06~1;.07~1;.08~1;10~S DR=.1322 D LOOK^IVMPREC9;20~S DR=.1322 D LOOK^IVMPREC9
"RTN","IVM2152P",63,0)
 ;;.01~RESIDENCE NUMBER CHANGE SITE;.02~RF161P;.03~1;.04~2;.05~.1323;.06~1;.07~1;.08~1;10~S DR=.1323 D LOOK^IVMPREC9;20~S DR=.1323 D LOOK^IVMPREC9
"RTN","IVM2152P",64,0)
 ;;QUIT
"RTN","IVMLDEM4")
0^9^B36894677
"RTN","IVMLDEM4",1,0)
IVMLDEM4 ;ALB/KCL,PJR,LBD - IVM DEMOGRAPHIC UPLOAD/DELETE FIELDS ; 3/27/12 4:05pm
"RTN","IVMLDEM4",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**5,10,56,102,152**; 21-OCT-94;Build 4
"RTN","IVMLDEM4",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMLDEM4",4,0)
 ;
"RTN","IVMLDEM4",5,0)
 ;
"RTN","IVMLDEM4",6,0)
UF ; - (action) select uploadable demographic fields for filing
"RTN","IVMLDEM4",7,0)
 ;
"RTN","IVMLDEM4",8,0)
 ;  Input:  IVMWHERE  --  as where the action is coming from 
"RTN","IVMLDEM4",9,0)
 ;
"RTN","IVMLDEM4",10,0)
 ;                    --  If action from UPLOADABLE list:
"RTN","IVMLDEM4",11,0)
 ;                          array of uploadable fields as
"RTN","IVMLDEM4",12,0)
 ;                          ^TMP("IVMUPLOAD",$J,"IDX",CTR,CTR)=dfn^da(2)^da(1)^da^ivm field value^pointer to file (#1)^dhcp field number^dhcp field name
"RTN","IVMLDEM4",13,0)
 ;
"RTN","IVMLDEM4",14,0)
 ;
"RTN","IVMLDEM4",15,0)
 ; - generic seletor used within list manager action
"RTN","IVMLDEM4",16,0)
 N VALMY,IVMDOD S IVMDOD=0
"RTN","IVMLDEM4",17,0)
 D EN^VALM2($G(XQORNOD(0)))
"RTN","IVMLDEM4",18,0)
 Q:'$D(VALMY)
"RTN","IVMLDEM4",19,0)
 ;
"RTN","IVMLDEM4",20,0)
 N IVMPKDOD D CHECKS,CHECKDOD
"RTN","IVMLDEM4",21,0)
 ;
"RTN","IVMLDEM4",22,0)
 S IVMENT4=0 F  S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4  D
"RTN","IVMLDEM4",23,0)
 .;
"RTN","IVMLDEM4",24,0)
 .S IVMINDEX=$G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4)) I IVMINDEX']"" Q
"RTN","IVMLDEM4",25,0)
 .;
"RTN","IVMLDEM4",26,0)
 .; - check to see if selection is an address field
"RTN","IVMLDEM4",27,0)
 .S IVMADDR=$$ADDR^IVMLDEM6(+IVMINDEX,$P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4),IVMPPICK)
"RTN","IVMLDEM4",28,0)
 .;
"RTN","IVMLDEM4",29,0)
 .Q:IVMADDR
"RTN","IVMLDEM4",30,0)
 .;
"RTN","IVMLDEM4",31,0)
 .; - check to see if selection is a Date of Death field
"RTN","IVMLDEM4",32,0)
 .I IVMPKDOD S IVMDOD=$$DOD^IVMLDEMD(+IVMINDEX,$P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4))
"RTN","IVMLDEM4",33,0)
 .;
"RTN","IVMLDEM4",34,0)
 .Q:IVMDOD
"RTN","IVMLDEM4",35,0)
 .;
"RTN","IVMLDEM4",36,0)
 .; - ask user if they are sure they want to update field
"RTN","IVMLDEM4",37,0)
 .D RUSURE^IVMLDEMU($P(IVMINDEX,"^",8),"update") I IVMOUT!'IVMSURE Q
"RTN","IVMLDEM4",38,0)
 .;
"RTN","IVMLDEM4",39,0)
 .W !,"Updating "_$P(IVMINDEX,"^",8)_" field... "
"RTN","IVMLDEM4",40,0)
 .;
"RTN","IVMLDEM4",41,0)
 .; - upload value received from IVM into DHCP field
"RTN","IVMLDEM4",42,0)
 .D UPLOAD^IVMLDEMU(DFN,$P(IVMINDEX,"^",6),$P(IVMINDEX,"^",7),$P(IVMINDEX,"^",5))
"RTN","IVMLDEM4",43,0)
 .;
"RTN","IVMLDEM4",44,0)
 .; - remove entry from file (#301.5)
"RTN","IVMLDEM4",45,0)
 .D DELENT^IVMLDEMU($P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4)) W "completed."
"RTN","IVMLDEM4",46,0)
 .;
"RTN","IVMLDEM4",47,0)
 ;
"RTN","IVMLDEM4",48,0)
 ; - hold display before building list
"RTN","IVMLDEM4",49,0)
 D PAUSE^VALM1
"RTN","IVMLDEM4",50,0)
 ;
"RTN","IVMLDEM4",51,0)
 ; - init the list and re-display to the user
"RTN","IVMLDEM4",52,0)
 D INIT^IVMLDEM2
"RTN","IVMLDEM4",53,0)
 ;
"RTN","IVMLDEM4",54,0)
DEQ ; clean-up variables
"RTN","IVMLDEM4",55,0)
 D QACTION
"RTN","IVMLDEM4",56,0)
 Q
"RTN","IVMLDEM4",57,0)
 ;
"RTN","IVMLDEM4",58,0)
 ;
"RTN","IVMLDEM4",59,0)
DF ; - (action) select uploadable/non-uploadable demographic fields for deletion
"RTN","IVMLDEM4",60,0)
 ;
"RTN","IVMLDEM4",61,0)
 ;  Input:  IVMWHERE  --  as where the action is coming from 
"RTN","IVMLDEM4",62,0)
 ;
"RTN","IVMLDEM4",63,0)
 ;                    --  If action from UPLOADABLE list:
"RTN","IVMLDEM4",64,0)
 ;                          array of uploadable fields as
"RTN","IVMLDEM4",65,0)
 ;                          ^TMP("IVMUPLOAD",$J,"IDX",CTR,CTR)=dfn^da(2)^da(1)^da^ivm field value^pointer to file (#1)^dhcp field number^dhcp field name
"RTN","IVMLDEM4",66,0)
 ;
"RTN","IVMLDEM4",67,0)
 ;                        OR
"RTN","IVMLDEM4",68,0)
 ;
"RTN","IVMLDEM4",69,0)
 ;                    --  If action from NON-UPLOADABLE list:
"RTN","IVMLDEM4",70,0)
 ;                          array of non-uploadable fields as
"RTN","IVMLDEM4",71,0)
 ;                          ^TMP("IVMNONUP",$J,"IDX",CTR,CTR)=dfn^da(2)^da(1)^da^ivm field value^pointer to file (#1)^dhcp field number^dhcp field name
"RTN","IVMLDEM4",72,0)
 ;
"RTN","IVMLDEM4",73,0)
 ;
"RTN","IVMLDEM4",74,0)
 ; Output:  None
"RTN","IVMLDEM4",75,0)
 ;
"RTN","IVMLDEM4",76,0)
 ; - generic seletor used within list manager action
"RTN","IVMLDEM4",77,0)
 N VALMY
"RTN","IVMLDEM4",78,0)
 D EN^VALM2($G(XQORNOD(0)))
"RTN","IVMLDEM4",79,0)
 Q:'$D(VALMY)
"RTN","IVMLDEM4",80,0)
 ;
"RTN","IVMLDEM4",81,0)
 ; - determine array depending on variable IVMWHERE
"RTN","IVMLDEM4",82,0)
 S IVMARRAY=$S(IVMWHERE="UP":"IVMUPLOAD",1:"IVMNONUP")
"RTN","IVMLDEM4",83,0)
 ;
"RTN","IVMLDEM4",84,0)
 N IVMPKDOD D CHECKS,CHECKDOD
"RTN","IVMLDEM4",85,0)
 ;
"RTN","IVMLDEM4",86,0)
 S IVMENT4=0 F  S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4  D
"RTN","IVMLDEM4",87,0)
 .;
"RTN","IVMLDEM4",88,0)
 .I IVMWHERE="NON" D DF^IVMLDEM8 Q  ; non-uploadable fields
"RTN","IVMLDEM4",89,0)
 .;
"RTN","IVMLDEM4",90,0)
 .; - get selected entry for uploadable fields
"RTN","IVMLDEM4",91,0)
 .S IVMINDEX=$G(^TMP(IVMARRAY,$J,"IDX",IVMENT4,IVMENT4)) Q:IVMINDEX']""
"RTN","IVMLDEM4",92,0)
 .;
"RTN","IVMLDEM4",93,0)
 .; - check to see if selection is an address field
"RTN","IVMLDEM4",94,0)
 .S IVMADDR=$$ADDR^IVMLDEM7(+IVMINDEX,$P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4),IVMPPICK)
"RTN","IVMLDEM4",95,0)
 .;
"RTN","IVMLDEM4",96,0)
 .Q:IVMADDR
"RTN","IVMLDEM4",97,0)
 .;
"RTN","IVMLDEM4",98,0)
 .; - ask user if they are sure they want to delete field
"RTN","IVMLDEM4",99,0)
 .D RUSURE^IVMLDEMU($P(IVMINDEX,"^",8),"delete") I IVMOUT!'IVMSURE Q
"RTN","IVMLDEM4",100,0)
 .;
"RTN","IVMLDEM4",101,0)
 .W !,"Deleting "_$P(IVMINDEX,"^",8)_" field from the list... "
"RTN","IVMLDEM4",102,0)
 .;
"RTN","IVMLDEM4",103,0)
 .;if Date of Death is Deleted, send bulletin
"RTN","IVMLDEM4",104,0)
 .I IVMPKDOD D BULLETIN S IVMPKDOD=0
"RTN","IVMLDEM4",105,0)
 .;- remove entry from file (#301.5)
"RTN","IVMLDEM4",106,0)
 .D DELENT^IVMLDEMU($P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4)) W "completed."
"RTN","IVMLDEM4",107,0)
 ;
"RTN","IVMLDEM4",108,0)
 ; - hold display before re-building list
"RTN","IVMLDEM4",109,0)
 D PAUSE^VALM1
"RTN","IVMLDEM4",110,0)
 ;
"RTN","IVMLDEM4",111,0)
 ; - init the list and re-display to the user
"RTN","IVMLDEM4",112,0)
 D @$S(IVMWHERE="UP":"INIT^IVMLDEM2",1:"INIT^IVMLDEM3")
"RTN","IVMLDEM4",113,0)
 ;
"RTN","IVMLDEM4",114,0)
DFQ ; clean-up variables
"RTN","IVMLDEM4",115,0)
 D QACTION
"RTN","IVMLDEM4",116,0)
 Q
"RTN","IVMLDEM4",117,0)
 ;
"RTN","IVMLDEM4",118,0)
 ;
"RTN","IVMLDEM4",119,0)
CHECKS ; check if residence phone number selected
"RTN","IVMLDEM4",120,0)
 ; check if another address field selected
"RTN","IVMLDEM4",121,0)
 ; IVMPPICK=0 phone or an address field not selected
"RTN","IVMLDEM4",122,0)
 ;          1 address field(s) selected
"RTN","IVMLDEM4",123,0)
 ;          2 phone selected
"RTN","IVMLDEM4",124,0)
 ;          3 both address field(s) and phone selected
"RTN","IVMLDEM4",125,0)
 ;
"RTN","IVMLDEM4",126,0)
 N IVMPPIC1,IVMPPIC2
"RTN","IVMLDEM4",127,0)
 S (IVMPPICK,IVMPPIC2)=0
"RTN","IVMLDEM4",128,0)
 Q:IVMWHERE'="UP"
"RTN","IVMLDEM4",129,0)
 S IVMENT4=0 F  S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4  D
"RTN","IVMLDEM4",130,0)
 .I $G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4))["PHONE NUMBER [RESIDENCE]" S IVMPPICK=2 Q
"RTN","IVMLDEM4",131,0)
 .I $G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4))["RESIDENCE NUMBER CHANGE" S IVMPPICK=2 Q
"RTN","IVMLDEM4",132,0)
 .S IVMINDEX=$G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4)) I IVMINDEX']"" Q
"RTN","IVMLDEM4",133,0)
 .S IVMPPIC1=+$G(^IVM(301.5,+$P(IVMINDEX,"^",2),"IN",+$P(IVMINDEX,"^",3),"DEM",+$P(IVMINDEX,"^",4),0)) Q:'IVMPPIC1
"RTN","IVMLDEM4",134,0)
 .S:$D(^IVM(301.92,"AD",+IVMPPIC1)) IVMPPIC2=1
"RTN","IVMLDEM4",135,0)
 .Q
"RTN","IVMLDEM4",136,0)
 S IVMPPICK=IVMPPICK+IVMPPIC2
"RTN","IVMLDEM4",137,0)
 Q
"RTN","IVMLDEM4",138,0)
 ;
"RTN","IVMLDEM4",139,0)
CHECKDOD ; check if date of death was selected
"RTN","IVMLDEM4",140,0)
 ; IVMPKDOD=0 date of death not selected
"RTN","IVMLDEM4",141,0)
 ;          1 date of death selected
"RTN","IVMLDEM4",142,0)
 ;
"RTN","IVMLDEM4",143,0)
 N IVMPPIC1,IVMPPIC2,CKST
"RTN","IVMLDEM4",144,0)
 S (IVMPKDOD,IVMPPIC2)=0
"RTN","IVMLDEM4",145,0)
 Q:IVMWHERE'="UP"
"RTN","IVMLDEM4",146,0)
 S IVMENT4=0 F  S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4  D
"RTN","IVMLDEM4",147,0)
 .S CKST=$G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4))
"RTN","IVMLDEM4",148,0)
 .I CKST["DATE OF DEATH"!(CKST["SOURCE OF NOTIFICATION")!(CKST["DATE OF DEATH LAST UPDATED") S IVMPKDOD=1 Q
"RTN","IVMLDEM4",149,0)
 Q
"RTN","IVMLDEM4",150,0)
BULLETIN ; Non-Acceptance of Date of Death Data Bulletin
"RTN","IVMLDEM4",151,0)
 N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
"RTN","IVMLDEM4",152,0)
 S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))
"RTN","IVMLDEM4",153,0)
 Q:'DGMGRP
"RTN","IVMLDEM4",154,0)
 D XMY^DGMTUTL(DGMGRP,0,1)
"RTN","IVMLDEM4",155,0)
 S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9)
"RTN","IVMLDEM4",156,0)
 S XMTEXT="DGBULL("
"RTN","IVMLDEM4",157,0)
 S XMSUB="NON-ACCEPTANCE OF DATE OF DEATH DATA"
"RTN","IVMLDEM4",158,0)
 S DGLINE=0
"RTN","IVMLDEM4",159,0)
 D LINE^DGEN("Patient: "_DGNAME,.DGLINE)
"RTN","IVMLDEM4",160,0)
 D LINE^DGEN("SSN: "_DGSSN,.DGLINE)
"RTN","IVMLDEM4",161,0)
 D LINE^DGEN("",.DGLINE)
"RTN","IVMLDEM4",162,0)
 D LINE^DGEN("This Veteran's Enrollment Record contains a Date of Death,",.DGLINE)
"RTN","IVMLDEM4",163,0)
 D LINE^DGEN("however, you did not upload this information into VistA.",.DGLINE)
"RTN","IVMLDEM4",164,0)
 D LINE^DGEN("Contact the HEC by phone or by fax with the reason for",.DGLINE)
"RTN","IVMLDEM4",165,0)
 D LINE^DGEN("non-acceptance.  The HEC will delete erroneous Date of Death",.DGLINE)
"RTN","IVMLDEM4",166,0)
 D LINE^DGEN("information and update the veteran's enrollment record.",.DGLINE)
"RTN","IVMLDEM4",167,0)
 D ^XMD
"RTN","IVMLDEM4",168,0)
 Q
"RTN","IVMLDEM4",169,0)
QACTION ; - kill variables used from all protocols
"RTN","IVMLDEM4",170,0)
 S VALMBCK="R"
"RTN","IVMLDEM4",171,0)
 K IVMADDR,IVMARRAY,IVMENT4,IVMINDEX,IVMOUT,IVMPPICK,IVMSURE
"RTN","IVMLDEM4",172,0)
 Q
"RTN","IVMLDEM6")
0^5^B88291633
"RTN","IVMLDEM6",1,0)
IVMLDEM6 ;ALB/KCL/BRM/PHH/CKN/LBD - IVM DEMOGRAPHIC UPLOAD FILE ADDRESS ; 3/10/12 8:24pm
"RTN","IVMLDEM6",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**10,58,73,79,108,106,105,124,115,152**; 21-OCT-94;Build 4
"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
"RTN","IVMLDEM6",146,0)
 S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
"RTN","IVMLDEM6",147,0)
 D ^DIE K DA,DIE,DR
"RTN","IVMLDEM6",148,0)
 ;
"RTN","IVMLDEM6",149,0)
 ; - delete inaccurate Addr Change Site data if Source is not VAMC
"RTN","IVMLDEM6",150,0)
 ;   (trigger x-ref does not fire with 4 slash stuff)
"RTN","IVMLDEM6",151,0)
 I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMLDEM6",152,0)
 ;
"RTN","IVMLDEM6",153,0)
 Q
"RTN","IVMLDEM6",154,0)
 ;
"RTN","IVMLDEM6",155,0)
 ;
"RTN","IVMLDEM6",156,0)
PHONE ; - ask user to delete phone # [Residence] from Patient (#2) file
"RTN","IVMLDEM6",157,0)
 D PHONE^IVMPREC9 ;Moved this tag to IVMPREC9 due to routine size limit.
"RTN","IVMLDEM6",158,0)
 Q
"RTN","IVMLDEM6",159,0)
 ;
"RTN","IVMLDEM6",160,0)
AUTOADDR(DFN,IVMPPICK,NOUPDT,NOPHUP) ;
"RTN","IVMLDEM6",161,0)
 ; this functionality is copied from above and modified to allow
"RTN","IVMLDEM6",162,0)
 ; an automated upload of patient address information as stipulated
"RTN","IVMLDEM6",163,0)
 ; in the business requirements for Address Indexing to support GMT
"RTN","IVMLDEM6",164,0)
 ;
"RTN","IVMLDEM6",165,0)
 ;  Input:      DFN  -  as patient IEN
"RTN","IVMLDEM6",166,0)
 ;         IVMPPICK  -  residence phone number and/or another address
"RTN","IVMLDEM6",167,0)
 ;                        field selected
"RTN","IVMLDEM6",168,0)
 ;                      1 - address field(s) selected
"RTN","IVMLDEM6",169,0)
 ;                      3 - both address field(s) and phone selected
"RTN","IVMLDEM6",170,0)
 ;           NOUPDT  -  (optional) this flag is set when the incoming
"RTN","IVMLDEM6",171,0)
 ;                      address data is older than the existing
"RTN","IVMLDEM6",172,0)
 ;                      address in the Patient (#2) file
"RTN","IVMLDEM6",173,0)
 ;           NOPHUP  -  (optional) this flag is set when the incoming
"RTN","IVMLDEM6",174,0)
 ;                      home phone number is older than the existing
"RTN","IVMLDEM6",175,0)
 ;                      home phone number in the Patient (#2) file
"RTN","IVMLDEM6",176,0)
 ; Output: IVMFLAG   -  1 if address fields updated
"RTN","IVMLDEM6",177,0)
 ;                      0 if address fields not updated
"RTN","IVMLDEM6",178,0)
 ;
"RTN","IVMLDEM6",179,0)
 ;
"RTN","IVMLDEM6",180,0)
 ;
"RTN","IVMLDEM6",181,0)
 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,IVMAFLD,IVMAVAL,DELFLG
"RTN","IVMLDEM6",182,0)
 ;
"RTN","IVMLDEM6",183,0)
 ; - initialize flags
"RTN","IVMLDEM6",184,0)
 S IVMFLAG=0,DELFLG=1
"RTN","IVMLDEM6",185,0)
 S:'$G(NOUPDT) NOUPDT=0
"RTN","IVMLDEM6",186,0)
 S:'$G(NOPHUP) NOPHUP=0   ;Added for IVM*2*152
"RTN","IVMLDEM6",187,0)
 ;
"RTN","IVMLDEM6",188,0)
 ; - check for required parameters
"RTN","IVMLDEM6",189,0)
 Q:'$G(DFN) IVMFLAG
"RTN","IVMLDEM6",190,0)
 ;
"RTN","IVMLDEM6",191,0)
 N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
"RTN","IVMLDEM6",192,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",193,0)
 I ('NOUPDT),$$PHARM(+DFN),'$$BADADR^DGUTL3(+DFN) S DELFLG=0
"RTN","IVMLDEM6",194,0)
 I 'NOUPDT,DELFLG D EN^DGCLEAR(DFN,"PERM") ;Deleting existing address before updating
"RTN","IVMLDEM6",195,0)
 ;
"RTN","IVMLDEM6",196,0)
 S IVMDA2=$G(IVM3015)
"RTN","IVMLDEM6",197,0)
 Q:'$G(IVMDA2) IVMFLAG
"RTN","IVMLDEM6",198,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMLDEM6",199,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
"RTN","IVMLDEM6",200,0)
 Q:'IVMDA1 IVMFLAG
"RTN","IVMLDEM6",201,0)
 ;
"RTN","IVMLDEM6",202,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']""  D
"RTN","IVMLDEM6",203,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMLDEM6",204,0)
 ..;
"RTN","IVMLDEM6",205,0)
 ..; - check for data node in (#301.511) sub-file
"RTN","IVMLDEM6",206,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMLDEM6",207,0)
 ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
"RTN","IVMLDEM6",208,0)
 ..;
"RTN","IVMLDEM6",209,0)
 ..; - check if residence phone number -> do not auto-upload
"RTN","IVMLDEM6",210,0)
 ..;   If NOPHUP=1 delete entry from #301.511 sub-file, otherwise quit
"RTN","IVMLDEM6",211,0)
 ..;   (IVM*2*152)
"RTN","IVMLDEM6",212,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",213,0)
 ...I NOPHUP D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMLDEM6",214,0)
 ..;
"RTN","IVMLDEM6",215,0)
 ..; don't auto-update if there is an active Prescription record and
"RTN","IVMLDEM6",216,0)
 ..; the Bad Address Indicator is null
"RTN","IVMLDEM6",217,0)
 ..I 'DELFLG D DEMBULL^IVMPREC6 Q
"RTN","IVMLDEM6",218,0)
 ..;Store Address change Date/time, source and site in ^TMP to file at the end of process.
"RTN","IVMLDEM6",219,0)
 ..S IVMAFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMAVAL=$P(IVMNODE,"^",2)
"RTN","IVMLDEM6",220,0)
 ..I 'NOUPDT,((IVMAFLD=.118)!(IVMAFLD=.119)!(IVMAFLD=.12)) S ^TMP($J,"CHANGE UPDATE",IVMAFLD)=IVMAVAL
"RTN","IVMLDEM6",221,0)
 ..;
"RTN","IVMLDEM6",222,0)
 ..; - load addr field rec'd from IVM into DHCP (#2) file
"RTN","IVMLDEM6",223,0)
 ..I 'NOUPDT D UPLOAD(+DFN,IVMAFLD,IVMAVAL) S IVMFLAG=1
"RTN","IVMLDEM6",224,0)
 ..;
"RTN","IVMLDEM6",225,0)
 ..; - remove entry from (#301.511) sub-file
"RTN","IVMLDEM6",226,0)
 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMLDEM6",227,0)
 ..; - if no display or uploadable fields left, then delete the PID
"RTN","IVMLDEM6",228,0)
 ..;   segment
"RTN","IVMLDEM6",229,0)
 ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
"RTN","IVMLDEM6",230,0)
 ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
"RTN","IVMLDEM6",231,0)
 D ADDRCHNG^IVMPREC6(DFN) ;Update Address change date/time,source,site if necessary
"RTN","IVMLDEM6",232,0)
 I IVMFLAG D
"RTN","IVMLDEM6",233,0)
 .N DGCURR
"RTN","IVMLDEM6",234,0)
 .D GETUPDTS^DGADDUTL(DFN,.DGCURR)
"RTN","IVMLDEM6",235,0)
 .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR)
"RTN","IVMLDEM6",236,0)
 Q IVMFLAG
"RTN","IVMLDEM6",237,0)
 ;
"RTN","IVMLDEM6",238,0)
ADDRDT(DFN,IVMDA2,IVMDA1) ;
"RTN","IVMLDEM6",239,0)
 ; - validate Address Change Dt/Tm before filing
"RTN","IVMLDEM6",240,0)
 ;   if incoming address is accepted and the change date is older
"RTN","IVMLDEM6",241,0)
 ;   than what's on file, then use today's date for Addr Chg Dt/Tm
"RTN","IVMLDEM6",242,0)
 ;
"RTN","IVMLDEM6",243,0)
 Q:'$$ADRDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1)
"RTN","IVMLDEM6",244,0)
 N FDA,IEN92,IVMDA,IENS,ERR
"RTN","IVMLDEM6",245,0)
 S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92
"RTN","IVMLDEM6",246,0)
 Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92))
"RTN","IVMLDEM6",247,0)
 S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA
"RTN","IVMLDEM6",248,0)
 S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
"RTN","IVMLDEM6",249,0)
 S FDA(301.511,IENS,.02)=$$NOW^XLFDT
"RTN","IVMLDEM6",250,0)
 D FILE^DIE("","FDA","ERR")
"RTN","IVMLDEM6",251,0)
 Q
"RTN","IVMLDEM6",252,0)
 ;
"RTN","IVMLDEM6",253,0)
PHONDT(DFN,IVMDA2,IVMDA1) ;
"RTN","IVMLDEM6",254,0)
 ; - validate Residence Number Change Dt/Tm before filing
"RTN","IVMLDEM6",255,0)
 ;   if incoming phone number is accepted and the change date is
"RTN","IVMLDEM6",256,0)
 ;   older than what's on file, then use today's date for
"RTN","IVMLDEM6",257,0)
 ;   Residence Number Change Dt/Tm (IVM*2*152)
"RTN","IVMLDEM6",258,0)
 ;
"RTN","IVMLDEM6",259,0)
 Q:'$$PHNDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1)
"RTN","IVMLDEM6",260,0)
 N FDA,IEN92,IVMDA,IENS,ERR
"RTN","IVMLDEM6",261,0)
 S IEN92=$O(^IVM(301.92,"C","RF171P","")) Q:'IEN92
"RTN","IVMLDEM6",262,0)
 Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92))
"RTN","IVMLDEM6",263,0)
 S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA
"RTN","IVMLDEM6",264,0)
 S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
"RTN","IVMLDEM6",265,0)
 S FDA(301.511,IENS,.02)=$$NOW^XLFDT
"RTN","IVMLDEM6",266,0)
 D FILE^DIE("","FDA","ERR")
"RTN","IVMLDEM6",267,0)
 Q
"RTN","IVMLDEM6",268,0)
 ;
"RTN","IVMLDEM6",269,0)
PHARM(DFN) ;does this patient have active pharmacy prescriptions?
"RTN","IVMLDEM6",270,0)
 ;
"RTN","IVMLDEM6",271,0)
 ;External reference to $$EN^PSSRXACT supported by IA #4237
"RTN","IVMLDEM6",272,0)
 ;
"RTN","IVMLDEM6",273,0)
 Q $S('$G(DFN):0,1:$$EN^PSSRXACT(DFN))
"RTN","IVMLDEM7")
0^8^B19787743
"RTN","IVMLDEM7",1,0)
IVMLDEM7 ;ALB/KCL,LBD - IVM DEMOGRAPHIC UPLOAD - DELETE ADDRESS ; 3/11/12 2:39pm
"RTN","IVMLDEM7",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**10,79,152**; 21-OCT-94;Build 4
"RTN","IVMLDEM7",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMLDEM7",4,0)
 ;
"RTN","IVMLDEM7",5,0)
 ;
"RTN","IVMLDEM7",6,0)
ADDR(DFN,IVMDA2,IVMDA1,IVMDA,IVMPPICK) ; - function to check if the delete field
"RTN","IVMLDEM7",7,0)
 ;                          is an address field and return a flag.
"RTN","IVMLDEM7",8,0)
 ;
"RTN","IVMLDEM7",9,0)
 ;
"RTN","IVMLDEM7",10,0)
 ;  Input:      DFN  -  as patient IEN
"RTN","IVMLDEM7",11,0)
 ;           IVMDA2  -  pointer to case record in (#301.5) file
"RTN","IVMLDEM7",12,0)
 ;           IVMDA1  -  pointer to PID msg in (#301.501) sub-file
"RTN","IVMLDEM7",13,0)
 ;            IVMDA  -  pointer to record in (#301.511) sub-file
"RTN","IVMLDEM7",14,0)
 ;         IVMPPICK  -  residence phone number and/or another address
"RTN","IVMLDEM7",15,0)
 ;                        field selected
"RTN","IVMLDEM7",16,0)
 ;                      0 - phone or an address field not selected 
"RTN","IVMLDEM7",17,0)
 ;                      1 - address field(s) selected
"RTN","IVMLDEM7",18,0)
 ;                      2 - phone selected
"RTN","IVMLDEM7",19,0)
 ;                      3 - both address field(s) and phone selected
"RTN","IVMLDEM7",20,0)
 ;
"RTN","IVMLDEM7",21,0)
 ; Output: IVMFLAG   -  1 if field is an address field
"RTN","IVMLDEM7",22,0)
 ;                      0 if field is not an address field
"RTN","IVMLDEM7",23,0)
 ;
"RTN","IVMLDEM7",24,0)
 ;
"RTN","IVMLDEM7",25,0)
 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,IVMFNAM
"RTN","IVMLDEM7",26,0)
 ;
"RTN","IVMLDEM7",27,0)
 ; - initialize flag
"RTN","IVMLDEM7",28,0)
 S IVMFLAG=0
"RTN","IVMLDEM7",29,0)
 ;
"RTN","IVMLDEM7",30,0)
 ; - check for required parameters
"RTN","IVMLDEM7",31,0)
 I '$G(DFN)!('$G(IVMDA))!('$G(IVMDA1))!'($G(IVMDA2)) G ADDRQ
"RTN","IVMLDEM7",32,0)
 ;
"RTN","IVMLDEM7",33,0)
 ; - get pointer to (#301.92) file from (#301.511) sub-file
"RTN","IVMLDEM7",34,0)
 S IVMPTR=+$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)) G ADDRQ:'IVMPTR
"RTN","IVMLDEM7",35,0)
 ;
"RTN","IVMLDEM7",36,0)
 ;
"RTN","IVMLDEM7",37,0)
ASK I '$D(^IVM(301.92,"AD",+IVMPTR)) G ADDRQ
"RTN","IVMLDEM7",38,0)
 I IVMPPICK=2 G ASK1
"RTN","IVMLDEM7",39,0)
 W ! S DIR("A")="Do you wish to proceed with this action"
"RTN","IVMLDEM7",40,0)
 S DIR("A",1)="You have selected to delete an address field."
"RTN","IVMLDEM7",41,0)
 S DIR("A",2)="You will be required to delete the entire address."
"RTN","IVMLDEM7",42,0)
 S DIR("?")="Enter 'YES' to continue or 'NO' to abort."
"RTN","IVMLDEM7",43,0)
 S DIR(0)="Y",DIR("B")="NO"
"RTN","IVMLDEM7",44,0)
 D ^DIR K DIR
"RTN","IVMLDEM7",45,0)
 S IVMFLAG=1
"RTN","IVMLDEM7",46,0)
 I 'Y,IVMPPICK=1 G ADDRQ    ;only address selected so quit
"RTN","IVMLDEM7",47,0)
 I 'Y S IVMPPICK=2 G ASK1   ;check if phone should be deleted
"RTN","IVMLDEM7",48,0)
 W ! S DIR("A")="Are you sure that you want to delete the complete address"
"RTN","IVMLDEM7",49,0)
 S DIR("A",1)="If you delete this address, then the previously filed address"
"RTN","IVMLDEM7",50,0)
 S DIR("A",2)="will be transmitted to HEC and all sites visited by this patient."
"RTN","IVMLDEM7",51,0)
 S DIR("?",1)="Enter 'YES' to delete the complete address that was received from"
"RTN","IVMLDEM7",52,0)
 S DIR("?")="HEC.  Enter 'NO' to quit."
"RTN","IVMLDEM7",53,0)
 S DIR(0)="Y",DIR("B")="NO"
"RTN","IVMLDEM7",54,0)
 D ^DIR K DIR
"RTN","IVMLDEM7",55,0)
 S IVMFLAG=1
"RTN","IVMLDEM7",56,0)
 I 'Y,IVMPPICK=1 G ADDRQ    ;only address selected so quit
"RTN","IVMLDEM7",57,0)
 I 'Y S IVMPPICK=2 G ASK1   ;check if phone # should be deleted
"RTN","IVMLDEM7",58,0)
 ;
"RTN","IVMLDEM7",59,0)
 ; file new Address Change Date/Time
"RTN","IVMLDEM7",60,0)
 N FDA,ERRMSG
"RTN","IVMLDEM7",61,0)
 S FDA(2,DFN_",",.118)=$$FMTE^XLFDT($$NOW^XLFDT)
"RTN","IVMLDEM7",62,0)
 D FILE^DIE("E","FDA","ERRMSG")
"RTN","IVMLDEM7",63,0)
 ;
"RTN","IVMLDEM7",64,0)
 I IVMPPICK=3 G ASK1   ;check if phone # should be deleted
"RTN","IVMLDEM7",65,0)
 ;
"RTN","IVMLDEM7",66,0)
LOOP ; - loop thru fields in ^IVM(301.92,"AD" x-ref
"RTN","IVMLDEM7",67,0)
 I IVMPPICK'=2 W !,"Deleting address fields... "
"RTN","IVMLDEM7",68,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']""  D
"RTN","IVMLDEM7",69,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMLDEM7",70,0)
 ..;
"RTN","IVMLDEM7",71,0)
 ..; - check for data node in (#301.511) sub-file
"RTN","IVMLDEM7",72,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:IVMNODE']""
"RTN","IVMLDEM7",73,0)
 ..Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
"RTN","IVMLDEM7",74,0)
 ..;
"RTN","IVMLDEM7",75,0)
 ..S IVMFNAM=$P($G(^IVM(301.92,+IVMNODE,0)),U) Q:IVMFNAM=""
"RTN","IVMLDEM7",76,0)
 ..; - check if residence phone number and not selected to delete
"RTN","IVMLDEM7",77,0)
 ..I IVMPPICK=1&(IVMFNAM="PHONE NUMBER [RESIDENCE]"!(IVMFNAM["RESIDENCE NUMBER CHANGE")) Q
"RTN","IVMLDEM7",78,0)
 ..; - check if not residence phone number and only phone selected to delete
"RTN","IVMLDEM7",79,0)
 ..I IVMPPICK=2&(IVMFNAM'="PHONE NUMBER [RESIDENCE]"&(IVMFNAM'["RESIDENCE NUMBER CHANGE")) Q
"RTN","IVMLDEM7",80,0)
 ..;
"RTN","IVMLDEM7",81,0)
 ..; - remove entry from (#301.511) sub-file
"RTN","IVMLDEM7",82,0)
 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMLDEM7",83,0)
 ..S IVMFLAG=1
"RTN","IVMLDEM7",84,0)
 ;
"RTN","IVMLDEM7",85,0)
 I IVMFLAG S VALMBCK="R" W "completed.",!
"RTN","IVMLDEM7",86,0)
 ;
"RTN","IVMLDEM7",87,0)
ADDRQ ; - return  -->  1 if delete field is an address field
"RTN","IVMLDEM7",88,0)
 ;           -->  0 if delete field is not an address field
"RTN","IVMLDEM7",89,0)
 ;
"RTN","IVMLDEM7",90,0)
 I IVMFLAG D RESET^IVMLDEMU
"RTN","IVMLDEM7",91,0)
 Q IVMFLAG
"RTN","IVMLDEM7",92,0)
 ;
"RTN","IVMLDEM7",93,0)
ASK1 ; - phone selected to be deleted - address fields not selected
"RTN","IVMLDEM7",94,0)
 W ! S DIR("A")="Okay to delete the PHONE NUMBER [RESIDENCE] field"
"RTN","IVMLDEM7",95,0)
 S DIR("?",1)="Enter 'YES' to delete the patient's Phone Number [Residence] that was"
"RTN","IVMLDEM7",96,0)
 S DIR("?",2)="received from HEC.  Enter 'NO' to quit."
"RTN","IVMLDEM7",97,0)
 S DIR(0)="Y",DIR("B")="YES"
"RTN","IVMLDEM7",98,0)
 D ^DIR K DIR
"RTN","IVMLDEM7",99,0)
 S IVMFLAG=1
"RTN","IVMLDEM7",100,0)
 I 'Y,IVMPPICK=2 G ADDRQ   ;no phone or address deletions, just quit
"RTN","IVMLDEM7",101,0)
 I 'Y S IVMPPICK=1 G LOOP  ;address still needs to be deleted
"RTN","IVMLDEM7",102,0)
 ;
"RTN","IVMLDEM7",103,0)
 W !,"Deleting PHONE NUMBER [RESIDENCE] field from the list... "
"RTN","IVMLDEM7",104,0)
 G LOOP
"RTN","IVMLDEM9")
0^6^B62902959
"RTN","IVMLDEM9",1,0)
IVMLDEM9 ;ALB/BRM/PHH/LBD - IVM ADDRESS UPDATES PENDING REVIEW RPT ; 4/18/12 4:43pm
"RTN","IVMLDEM9",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**79,93,119,126,133,152**; 21-OCT-94;Build 4
"RTN","IVMLDEM9",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMLDEM9",4,0)
 ;
"RTN","IVMLDEM9",5,0)
 Q
"RTN","IVMLDEM9",6,0)
 ;
"RTN","IVMLDEM9",7,0)
EN2 ;entry point for IVM ADDR UPDT PENDING REVIEW menu option
"RTN","IVMLDEM9",8,0)
 K ^TMP("IVMLDEM9",$J)
"RTN","IVMLDEM9",9,0)
 K ^TMP($J,"IVMLDEM9")
"RTN","IVMLDEM9",10,0)
 ;If mail group has no member or remote-member
"RTN","IVMLDEM9",11,0)
 I '$$MEMBER() D  Q
"RTN","IVMLDEM9",12,0)
 . I '$D(ZTQUEUED) W !!,"IVM ADDR UPDT REPORT does not have a member. Report not sent." K DIR S DIR(0)="E" D ^DIR K DIR
"RTN","IVMLDEM9",13,0)
 I +$G(ZTSK) D PRINT,EXIT Q  ;started by Taskman job
"RTN","IVMLDEM9",14,0)
 ;User runs the option
"RTN","IVMLDEM9",15,0)
 I '$D(ZTQUEUED) D
"RTN","IVMLDEM9",16,0)
 . W !!,"The report will be sent to mail group IVM ADDR UPDT REPORT"
"RTN","IVMLDEM9",17,0)
 . D QUE
"RTN","IVMLDEM9",18,0)
 . D EXIT
"RTN","IVMLDEM9",19,0)
 . K DIR S DIR(0)="E" D ^DIR K DIR
"RTN","IVMLDEM9",20,0)
 Q
"RTN","IVMLDEM9",21,0)
 ;
"RTN","IVMLDEM9",22,0)
LOOP(DTPARAM,FILDAT) ;main loop
"RTN","IVMLDEM9",23,0)
 N DFN,IVMDT,IVMDA,IVMDA1,IVMDA2,RF171,TODAY,AUTODT,DTDIFF,NAME,UPLDT
"RTN","IVMLDEM9",24,0)
 N X1,X2,Y,SSN,DFN
"RTN","IVMLDEM9",25,0)
 D DT^DILF("X","T"_$G(DTPARAM),.AUTODT)
"RTN","IVMLDEM9",26,0)
 S TODAY=$$DT^XLFDT S:'$G(FILDAT) FILDAT=0
"RTN","IVMLDEM9",27,0)
 Q:'$G(AUTODT)  ;this should never occur, but just in case
"RTN","IVMLDEM9",28,0)
 S RF171=$O(^IVM(301.92,"C","RF171","")),IVMDA2=""
"RTN","IVMLDEM9",29,0)
 Q:'RF171
"RTN","IVMLDEM9",30,0)
 F  S IVMDA2=$O(^IVM(301.5,IVMDA2)) Q:IVMDA2=""  D
"RTN","IVMLDEM9",31,0)
 .S DFN=$P($G(^IVM(301.5,IVMDA2,0)),"^"),IVMDA1=""
"RTN","IVMLDEM9",32,0)
 .Q:('DFN)!('$D(^DPT(+DFN)))!('$D(^IVM(301.5,IVMDA2,"IN")))
"RTN","IVMLDEM9",33,0)
 .F  S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1)) Q:IVMDA1=""  D
"RTN","IVMLDEM9",34,0)
 ..Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171))
"RTN","IVMLDEM9",35,0)
 ..S IVMDA=""
"RTN","IVMLDEM9",36,0)
 ..F  S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171,IVMDA)) Q:'IVMDA  D
"RTN","IVMLDEM9",37,0)
 ...S IVMDT=$P($G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)),"^",3)
"RTN","IVMLDEM9",38,0)
 ...Q:('IVMDT)!(IVMDT>AUTODT)
"RTN","IVMLDEM9",39,0)
 ...; report addresses that will be auto-uploaded in DTDIFF days
"RTN","IVMLDEM9",40,0)
 ...S X1=TODAY,X2=IVMDT D ^%DTC S DTDIFF=+$G(X)
"RTN","IVMLDEM9",41,0)
 ...S NAME=$P($G(^DPT(DFN,0)),"^"),SSN=$P($G(^DPT(DFN,0)),"^",9)
"RTN","IVMLDEM9",42,0)
 ...S X1=IVMDT,X2=14 D C^%DTC S UPLDT=$G(X)
"RTN","IVMLDEM9",43,0)
 ...I '$D(^IVM(301.5,"ASEG","PID",IVMDA2)) Q
"RTN","IVMLDEM9",44,0)
 ...S ^TMP("IVMLDEM9",$J,DTDIFF,SSN,IVMDA)=$G(NAME)_"^"_$P(IVMDT,".")_"^"_$P(UPLDT,".")_"^"_DFN_"^"_IVMDA2_"^"_IVMDA1
"RTN","IVMLDEM9",45,0)
 Q
"RTN","IVMLDEM9",46,0)
 ;
"RTN","IVMLDEM9",47,0)
AUTOLOAD(DFN,IVMDA2,IVMDA1) ;auto-upload records that not been reviewed
"RTN","IVMLDEM9",48,0)
 ; this tag is called from ^IVMLDEMC
"RTN","IVMLDEM9",49,0)
 ;
"RTN","IVMLDEM9",50,0)
 Q:('$G(DFN))!('$G(IVMDA2))!('$G(IVMDA1))
"RTN","IVMLDEM9",51,0)
 N IVMI,IVMJ,IVMFIELD,IVMVALUE,IVMNODE,IVMFLAG,DUZ
"RTN","IVMLDEM9",52,0)
 S DUZ=.5
"RTN","IVMLDEM9",53,0)
 ;
"RTN","IVMLDEM9",54,0)
 ; determine appropriate address change dt/tm to be used
"RTN","IVMLDEM9",55,0)
 D ADDRDT^IVMLDEM6(DFN,IVMDA2,IVMDA1)
"RTN","IVMLDEM9",56,0)
 ;
"RTN","IVMLDEM9",57,0)
 N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
"RTN","IVMLDEM9",58,0)
 ;
"RTN","IVMLDEM9",59,0)
 ; loop through the record to be uploaded
"RTN","IVMLDEM9",60,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']""  D
"RTN","IVMLDEM9",61,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMLDEM9",62,0)
 ..;
"RTN","IVMLDEM9",63,0)
 ..; check for data node in (#301.511) sub-file
"RTN","IVMLDEM9",64,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMLDEM9",65,0)
 ..Q:('+IVMNODE)!($P(IVMNODE,"^",2)']"")
"RTN","IVMLDEM9",66,0)
 ..;
"RTN","IVMLDEM9",67,0)
 ..; check for residence phone number -> do not auto-upload
"RTN","IVMLDEM9",68,0)
 ..Q:(+IVMNODE=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0)))
"RTN","IVMLDEM9",69,0)
 ..;
"RTN","IVMLDEM9",70,0)
 ..; do not auto-upload if there is an active prescription
"RTN","IVMLDEM9",71,0)
 ..I $$PHARM^IVMLDEM6(+DFN) D REJTADD Q
"RTN","IVMLDEM9",72,0)
 ..;
"RTN","IVMLDEM9",73,0)
 ..; set upload parameters
"RTN","IVMLDEM9",74,0)
 ..S IVMFIELD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5)
"RTN","IVMLDEM9",75,0)
 ..S IVMVALUE=$P(IVMNODE,"^",2)
"RTN","IVMLDEM9",76,0)
 ..;
"RTN","IVMLDEM9",77,0)
 ..; load addr field into the Patient (#2) file
"RTN","IVMLDEM9",78,0)
 ..D UPLOAD^IVMLDEM6(DFN,IVMFIELD,IVMVALUE) S IVMFLAG=1
"RTN","IVMLDEM9",79,0)
 ..;
"RTN","IVMLDEM9",80,0)
 ..; remove entry from (#301.511) sub-file
"RTN","IVMLDEM9",81,0)
 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMLDEM9",82,0)
 ..;
"RTN","IVMLDEM9",83,0)
 ..; if no display or uploadable fields, delete PID segment
"RTN","IVMLDEM9",84,0)
 ..I ('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0))&('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)) D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ")
"RTN","IVMLDEM9",85,0)
 ;
"RTN","IVMLDEM9",86,0)
 I +$G(IVMFLAG) D
"RTN","IVMLDEM9",87,0)
 .N DGCURR
"RTN","IVMLDEM9",88,0)
 .D GETUPDTS^DGADDUTL(DFN,.DGCURR)
"RTN","IVMLDEM9",89,0)
 .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR)
"RTN","IVMLDEM9",90,0)
 Q
"RTN","IVMLDEM9",91,0)
REJTADD ;Reject the address
"RTN","IVMLDEM9",92,0)
 ; update the ADDRESS CHANGE DT/TM field #.118 in PATIENT file #2
"RTN","IVMLDEM9",93,0)
 D UPDDTTM^DGADDUTL(DFN,"PERM")
"RTN","IVMLDEM9",94,0)
 ;
"RTN","IVMLDEM9",95,0)
 ; trigger the record to transmit the existing address on file to HEC
"RTN","IVMLDEM9",96,0)
 N DGENUPLD   ; Used in SETSTAT^IVMPLOG to prevent filing.
"RTN","IVMLDEM9",97,0)
 N DA,X,IVMX
"RTN","IVMLDEM9",98,0)
 S (DA,X)=DFN
"RTN","IVMLDEM9",99,0)
 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX
"RTN","IVMLDEM9",100,0)
 Q
"RTN","IVMLDEM9",101,0)
PRINT ;report output
"RTN","IVMLDEM9",102,0)
 N DAYS,SSN,DATA,EX,PAGE,IVMDA,DATA,IVMLN,XMY,XMSUB,XMDUZ,XMTEXT
"RTN","IVMLDEM9",103,0)
 D LOOP("",0)
"RTN","IVMLDEM9",104,0)
 D HDR
"RTN","IVMLDEM9",105,0)
 D DISPLAY
"RTN","IVMLDEM9",106,0)
 D EMAIL
"RTN","IVMLDEM9",107,0)
 Q
"RTN","IVMLDEM9",108,0)
DISPLAY ;Display the report
"RTN","IVMLDEM9",109,0)
 S DAYS=""
"RTN","IVMLDEM9",110,0)
 I '$D(^TMP("IVMLDEM9",$J)) Q
"RTN","IVMLDEM9",111,0)
 F  S DAYS=$O(^TMP("IVMLDEM9",$J,DAYS),-1) Q:DAYS=""!($G(EX))  D
"RTN","IVMLDEM9",112,0)
 .S SSN=""
"RTN","IVMLDEM9",113,0)
 .F  S SSN=$O(^TMP("IVMLDEM9",$J,DAYS,SSN)) Q:SSN=""!($G(EX))  D
"RTN","IVMLDEM9",114,0)
 ..S IVMDA=""
"RTN","IVMLDEM9",115,0)
 ..F  S IVMDA=$O(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) Q:(IVMDA="")!($G(EX))  D
"RTN","IVMLDEM9",116,0)
 ...S DATA=$G(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA))
"RTN","IVMLDEM9",117,0)
 ... D LNPLUS
"RTN","IVMLDEM9",118,0)
 ... S ^TMP($J,"IVMLDEM9",IVMLN)="       "_$$FMTE^XLFDT($P(DATA,"^",3))_"      "_$$FMTE^XLFDT($P(DATA,"^",2))_"      "_SSN_"     "_$P(DATA,"^")
"RTN","IVMLDEM9",119,0)
 ... S ^TMP($J,"IVMLDEM9","TOTAL")=$G(^TMP($J,"IVMLDEM9","TOTAL"))+1
"RTN","IVMLDEM9",120,0)
 D TOTAL
"RTN","IVMLDEM9",121,0)
 D
"RTN","IVMLDEM9",122,0)
 . D LNPLUS
"RTN","IVMLDEM9",123,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)=""
"RTN","IVMLDEM9",124,0)
 . D LNPLUS
"RTN","IVMLDEM9",125,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)="                    <<END OF REPORT>>"
"RTN","IVMLDEM9",126,0)
 I $E(IOST)="C" W ! K DIR S DIR(0)="E" D ^DIR K DIR
"RTN","IVMLDEM9",127,0)
 Q
"RTN","IVMLDEM9",128,0)
HDR ;print header
"RTN","IVMLDEM9",129,0)
 N IVMDT,Y,DLINE
"RTN","IVMLDEM9",130,0)
 I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,EX)=1 Q
"RTN","IVMLDEM9",131,0)
 S Y=DT X ^DD("DD") S IVMDT=Y
"RTN","IVMLDEM9",132,0)
 D
"RTN","IVMLDEM9",133,0)
 . D LNPLUS
"RTN","IVMLDEM9",134,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)=""
"RTN","IVMLDEM9",135,0)
 . D LNPLUS
"RTN","IVMLDEM9",136,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)=" IVM ADDRESS UPDATES PENDING REVIEW          "_IVMDT
"RTN","IVMLDEM9",137,0)
 . D LNPLUS
"RTN","IVMLDEM9",138,0)
 . S $P(^TMP($J,"IVMLDEM9",IVMLN),"=",78)=""
"RTN","IVMLDEM9",139,0)
 . D LNPLUS
"RTN","IVMLDEM9",140,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)=""
"RTN","IVMLDEM9",141,0)
 . D LNPLUS
"RTN","IVMLDEM9",142,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)="     Auto-Upload Date    Date Received        SSN        Patient Name"
"RTN","IVMLDEM9",143,0)
 . D LNPLUS
"RTN","IVMLDEM9",144,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)="     ----------------    -------------     ---------     ------------"
"RTN","IVMLDEM9",145,0)
 Q
"RTN","IVMLDEM9",146,0)
EXIT D ^%ZISC,HOME^%ZIS Q
"RTN","IVMLDEM9",147,0)
 K ^TMP($J,"IVMLDEM9")
"RTN","IVMLDEM9",148,0)
 K ^TMP("IVMLDEM9",$J)
"RTN","IVMLDEM9",149,0)
 ;
"RTN","IVMLDEM9",150,0)
ADRDTCK(DFN,IVMDA2,IVMDA1) ;is the incoming address older than #2 address?
"RTN","IVMLDEM9",151,0)
 Q:'$G(DFN)!('$G(IVMDA2))!('$G(IVMDA1)) "0^MISSING INPUT PARAMETER"
"RTN","IVMLDEM9",152,0)
 N OADDRDT,NADDRDT,ERR,IVMDA,IEN92,IENS
"RTN","IVMLDEM9",153,0)
 S OADDRDT=$$GET1^DIQ(2,DFN_",",.118,"I","","ERR") Q:$D(ERR) "0^OLD ADDR ERROR"
"RTN","IVMLDEM9",154,0)
 S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92 "0^BAD #301.92 ENTRY FOR RF171"
"RTN","IVMLDEM9",155,0)
 I '$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) Q "0^ADDR DT NOT PRESENT"
"RTN","IVMLDEM9",156,0)
 S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA "0^MISSING ADDR DT IN 301.5"
"RTN","IVMLDEM9",157,0)
 S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
"RTN","IVMLDEM9",158,0)
 S NADDRDT=$$GET1^DIQ(301.511,IENS,.02,"I","","ERR") Q:$D(ERR) "0^NEW ADDR ERROR"
"RTN","IVMLDEM9",159,0)
 Q:(OADDRDT="")&(NADDRDT="") 0
"RTN","IVMLDEM9",160,0)
 Q:(NADDRDT="")!(OADDRDT'<NADDRDT) 1
"RTN","IVMLDEM9",161,0)
 Q "0^INCOMING ADDRESS IS NEWER THAN PATIENT FILE ADDR"
"RTN","IVMLDEM9",162,0)
 ;
"RTN","IVMLDEM9",163,0)
PHNDTCK(DFN,IVMDA2,IVMDA1) ;is the incoming phone # older than #2 phone #?
"RTN","IVMLDEM9",164,0)
 Q:'$G(DFN)!('$G(IVMDA2))!('$G(IVMDA1)) "0^MISSING INPUT PARAMETER"
"RTN","IVMLDEM9",165,0)
 N OPHNDT,NPHNDT,ERR,IVMDA,IEN92,IENS
"RTN","IVMLDEM9",166,0)
 S OPHNDT=$$GET1^DIQ(2,DFN_",",.1321,"I","","ERR") Q:$D(ERR) "0^OLD PHN ERROR"
"RTN","IVMLDEM9",167,0)
 S IEN92=$O(^IVM(301.92,"C","RF171P","")) Q:'IEN92 "0^BAD #301.92 ENTRY FOR RF171P"
"RTN","IVMLDEM9",168,0)
 I '$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) Q "0^PHN DT NOT PRESENT"
"RTN","IVMLDEM9",169,0)
 S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA "0^MISSING PHN DT IN 301.5"
"RTN","IVMLDEM9",170,0)
 S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
"RTN","IVMLDEM9",171,0)
 S NPHNDT=$$GET1^DIQ(301.511,IENS,.02,"I","","ERR") Q:$D(ERR) "0^NEW PHN ERROR"
"RTN","IVMLDEM9",172,0)
 Q:(OPHNDT="")&(NPHNDT="") 0
"RTN","IVMLDEM9",173,0)
 Q:(NPHNDT="")!(OPHNDT'<NPHNDT) 1
"RTN","IVMLDEM9",174,0)
 Q "0^INCOMING PHONE # IS NEWER THAN PATIENT FILE PHONE #"
"RTN","IVMLDEM9",175,0)
 ;
"RTN","IVMLDEM9",176,0)
MEMBER() ;Return 0 if mail group has no local or remote member
"RTN","IVMLDEM9",177,0)
 N RESULT,IVMIEN,IVMRMT
"RTN","IVMLDEM9",178,0)
 S RESULT=1
"RTN","IVMLDEM9",179,0)
 S IVMIEN=$$FIND1^DIC(3.8,"","X","IVM ADDR UPDT REPORT")
"RTN","IVMLDEM9",180,0)
 D LIST^DIC(3.812,","_IVMIEN_",",.01,"P","","","","","","","IVMRMT")
"RTN","IVMLDEM9",181,0)
 I ($P($G(IVMRMT("DILIST",0)),U)'>0),('$$GOTLOCAL^XMXAPIG("IVM ADDR UPDT REPORT")) S RESULT=0
"RTN","IVMLDEM9",182,0)
 Q RESULT
"RTN","IVMLDEM9",183,0)
EMAIL ;Set up parameters to email the report
"RTN","IVMLDEM9",184,0)
 ;If called within a task, protect variables
"RTN","IVMLDEM9",185,0)
 I $D(ZTQUEUED) N %,DIFROM
"RTN","IVMLDEM9",186,0)
 N RDT
"RTN","IVMLDEM9",187,0)
 D NOW^%DTC S Y=% X ^DD("DD")
"RTN","IVMLDEM9",188,0)
 S RDT=$P(Y,"@",1)_"@"_$P($P(Y,"@",2),":",1,2)
"RTN","IVMLDEM9",189,0)
 S XMSUB="IVM Address Pending Review ("_RDT_")"
"RTN","IVMLDEM9",190,0)
 S XMY("G.IVM ADDR UPDT REPORT")=""
"RTN","IVMLDEM9",191,0)
 I $G(^TMP($J,"IVMLDEM9","TOTAL"))<1 D
"RTN","IVMLDEM9",192,0)
 . D LNPLUS
"RTN","IVMLDEM9",193,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)=""
"RTN","IVMLDEM9",194,0)
 . D LNPLUS
"RTN","IVMLDEM9",195,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)="*** NO RECORDS TO PRINT ***"
"RTN","IVMLDEM9",196,0)
 S XMTEXT="^TMP($J,""IVMLDEM9"","
"RTN","IVMLDEM9",197,0)
 D ^XMD
"RTN","IVMLDEM9",198,0)
 Q
"RTN","IVMLDEM9",199,0)
QUE ;Que the task if user invokes option
"RTN","IVMLDEM9",200,0)
 N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP
"RTN","IVMLDEM9",201,0)
 W !
"RTN","IVMLDEM9",202,0)
 S ZTIO=""
"RTN","IVMLDEM9",203,0)
 S ZTRTN="PRINT^IVMLDEM9"
"RTN","IVMLDEM9",204,0)
 S ZTDESC="IVM AUTO ADDRESS UPLOAD RPT"
"RTN","IVMLDEM9",205,0)
 D ^%ZTLOAD
"RTN","IVMLDEM9",206,0)
 D ^%ZISC,HOME^%ZIS
"RTN","IVMLDEM9",207,0)
 W !,$S($D(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!")
"RTN","IVMLDEM9",208,0)
 Q
"RTN","IVMLDEM9",209,0)
TOTAL ;Display record total on the report
"RTN","IVMLDEM9",210,0)
 N IVMTOTAL
"RTN","IVMLDEM9",211,0)
 S IVMTOTAL=$G(^TMP($J,"IVMLDEM9","TOTAL"))
"RTN","IVMLDEM9",212,0)
 D
"RTN","IVMLDEM9",213,0)
 . D LNPLUS
"RTN","IVMLDEM9",214,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)=""
"RTN","IVMLDEM9",215,0)
 . D LNPLUS
"RTN","IVMLDEM9",216,0)
 . S ^TMP($J,"IVMLDEM9",IVMLN)="TOTAL RECORD(S): "_$G(IVMTOTAL)
"RTN","IVMLDEM9",217,0)
 Q
"RTN","IVMLDEM9",218,0)
LNPLUS ;Increase line number for the email text
"RTN","IVMLDEM9",219,0)
 S IVMLN=$G(IVMLN)+1
"RTN","IVMLDEM9",220,0)
 Q
"RTN","IVMPREC6")
0^7^B147269412
"RTN","IVMPREC6",1,0)
IVMPREC6 ;ALB/KCL/BRM/CKN,TDM,PWC,LBD - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ; 3/10/12 4:06pm
"RTN","IVMPREC6",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**3,4,12,17,34,58,79,102,115,140,144,121,151,152**;21-OCT-94;Build 4
"RTN","IVMPREC6",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMPREC6",4,0)
 ;
"RTN","IVMPREC6",5,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC6",6,0)
 ; messages received from the IVM center.  Format of HL7 batch message:
"RTN","IVMPREC6",7,0)
 ;
"RTN","IVMPREC6",8,0)
 ;       BHS
"RTN","IVMPREC6",9,0)
 ;       {MSH
"RTN","IVMPREC6",10,0)
 ;        PID
"RTN","IVMPREC6",11,0)
 ;        ZPD
"RTN","IVMPREC6",12,0)
 ;        ZTA
"RTN","IVMPREC6",13,0)
 ;        ZGD
"RTN","IVMPREC6",14,0)
 ;        ZCT (1 episode required, multiple possible)
"RTN","IVMPREC6",15,0)
 ;        ZEM (Veteran)
"RTN","IVMPREC6",16,0)
 ;        ZEM (Spouse - Optional)
"RTN","IVMPREC6",17,0)
 ;        RF1 (optional, multiple possible)
"RTN","IVMPREC6",18,0)
 ;       }
"RTN","IVMPREC6",19,0)
 ;       BTS
"RTN","IVMPREC6",20,0)
 ;
"RTN","IVMPREC6",21,0)
 ;
"RTN","IVMPREC6",22,0)
EN ; - entry point to process HL7 patient demographic message 
"RTN","IVMPREC6",23,0)
 ;
"RTN","IVMPREC6",24,0)
 N DGENUPLD,VAFCA08,DGRUGA08,COMP,DODSEG,GUARSEG
"RTN","IVMPREC6",25,0)
 ;N MULTDONE,XREP
"RTN","IVMPREC6",26,0)
 N XIVMA,IVMALADT,MULTIDONE
"RTN","IVMPREC6",27,0)
 ;
"RTN","IVMPREC6",28,0)
 ; Setup array to hold all the Allowed Address Types
"RTN","IVMPREC6",29,0)
 ;F XIVMA="N","P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
"RTN","IVMPREC6",30,0)
 F XIVMA="P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
"RTN","IVMPREC6",31,0)
 ; Define the Confidential Address Categories
"RTN","IVMPREC6",32,0)
 ;S IVMALADT("VACAE")="CA^1"      ; ELIGIBILITY/ENROLLMENT
"RTN","IVMPREC6",33,0)
 ;S IVMALADT("VACAA")="CA^2"      ; APPOINTMENT/SCHEDULING
"RTN","IVMPREC6",34,0)
 ;S IVMALADT("VACAC")="CA^3"      ; COPAYMENTS/VETERAN BILLING
"RTN","IVMPREC6",35,0)
 ;S IVMALADT("VACAM")="CA^4"      ; MEDICAL RECORDS
"RTN","IVMPREC6",36,0)
 ;S IVMALADT("VACAO")="CA^5"      ; ALL OTHERS
"RTN","IVMPREC6",37,0)
 ; prevent a return Z07 when uploading a Z05 (Patient file triggers)
"RTN","IVMPREC6",38,0)
 S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
"RTN","IVMPREC6",39,0)
 ;
"RTN","IVMPREC6",40,0)
 ; prevent MPI A08 message when uploading Z05 (Patient file triggers)
"RTN","IVMPREC6",41,0)
 S VAFCA08=1  ;MPI/CIRN A08 suppression flag
"RTN","IVMPREC6",42,0)
 ;
"RTN","IVMPREC6",43,0)
 S IVMFLG=0,IVMADFLG=0
"RTN","IVMPREC6",44,0)
 ; - get incoming HL7 message from HL7 Transmission (#772) file
"RTN","IVMPREC6",45,0)
 F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA  S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D
"RTN","IVMPREC6",46,0)
 .K HLERR,ZEMADRUP
"RTN","IVMPREC6",47,0)
 .S IVMTSTPT=""                          ;Initialize Temp Addr County
"RTN","IVMPREC6",48,0)
 .;
"RTN","IVMPREC6",49,0)
 .; - message control id from MSH segment
"RTN","IVMPREC6",50,0)
 .S MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID
"RTN","IVMPREC6",51,0)
 .;
"RTN","IVMPREC6",52,0)
 .; - perform demographics message consistency check
"RTN","IVMPREC6",53,0)
 .D EN^IVMPRECA Q:$D(HLERR)
"RTN","IVMPREC6",54,0)
 .;
"RTN","IVMPREC6",55,0)
 .;Set array of Email, Cell, Pager fields
"RTN","IVMPREC6",56,0)
 .D EPCFLDS(.EPCFARY,.EPCDEL)
"RTN","IVMPREC6",57,0)
 .D AUPBLD(.AUPFARY,.UPDAUPG)
"RTN","IVMPREC6",58,0)
 .; - get next msg segment
"RTN","IVMPREC6",59,0)
 .D NEXT I $E(IVMSEG,1,3)'="PID" D  Q
"RTN","IVMPREC6",60,0)
 ..S HLERR="Missing PID segment" D ACK^IVMPREC
"RTN","IVMPREC6",61,0)
 .;
"RTN","IVMPREC6",62,0)
 .F I=1:1 D NEXT Q:$E(IVMSEG,1,4)="ZPD^"  ;Go through all PID
"RTN","IVMPREC6",63,0)
 .; - patient IEN (DFN) from PID segment
"RTN","IVMPREC6",64,0)
 .;Use IVMPID array created in IVMPRECA while performing consistency
"RTN","IVMPREC6",65,0)
 .;to process PID segment
"RTN","IVMPREC6",66,0)
 .;
"RTN","IVMPREC6",67,0)
 .;I '$G(IVMDFN) S HLERR="Invalid DFN" D ACK^IVMPREC  Q
"RTN","IVMPREC6",68,0)
 .S DFN=$G(IVMDFN)
"RTN","IVMPREC6",69,0)
 .;I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D  Q
"RTN","IVMPREC6",70,0)
 .;.S HLERR="Invalid DFN" D ACK^IVMPREC
"RTN","IVMPREC6",71,0)
 .;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) D  Q
"RTN","IVMPREC6",72,0)
 .;.S HLERR="Couldn't match HEC SSN with DHCP SSN" D ACK^IVMPREC
"RTN","IVMPREC6",73,0)
 .;
"RTN","IVMPREC6",74,0)
 .; - check for entry in IVM PATIENT file, otherwise create stub entry
"RTN","IVMPREC6",75,0)
 .S IVM3015=$O(^IVM(301.5,"B",DFN,0))
"RTN","IVMPREC6",76,0)
 .I 'IVM3015 S IVM3015=$$LOG^IVMPLOG(DFN,DT)
"RTN","IVMPREC6",77,0)
 .I 'IVM3015 D  Q
"RTN","IVMPREC6",78,0)
 ..S HLERR="Failed to create entry in IVM PATIENT file"
"RTN","IVMPREC6",79,0)
 ..D ACK^IVMPREC
"RTN","IVMPREC6",80,0)
 .;
"RTN","IVMPREC6",81,0)
 .; - compare PID segment fields with DHCP fields
"RTN","IVMPREC6",82,0)
 .S IVMSEG="PID"  ;Setting IVMSEG to PID before it calls COMPARE
"RTN","IVMPREC6",83,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) Q:$D(HLERR)
"RTN","IVMPREC6",84,0)
 .;
"RTN","IVMPREC6",85,0)
 .; - get next msg segment -decrement the counter so it can pickup ZPD
"RTN","IVMPREC6",86,0)
 .S IVMDA=IVMDA-1 D NEXT I $E(IVMSEG,1,3)'="ZPD" D  Q
"RTN","IVMPREC6",87,0)
 ..S HLERR="Missing ZPD segment" D ACK^IVMPREC
"RTN","IVMPREC6",88,0)
 .;Convert "" to null in ZPD segment except seq. 8,9, 31 and 32
"RTN","IVMPREC6",89,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",9,10,32,33,")
"RTN","IVMPREC6",90,0)
 .;
"RTN","IVMPREC6",91,0)
 .; - compare ZPD segment fields with DHCP fields
"RTN","IVMPREC6",92,0)
 .D COMPARE(IVMSEG)
"RTN","IVMPREC6",93,0)
 .;
"RTN","IVMPREC6",94,0)
 .; - get next msg segment
"RTN","IVMPREC6",95,0)
 .D NEXT I $E(IVMSEG,1,3)="ZEL" D  Q
"RTN","IVMPREC6",96,0)
 ..S HLERR="ZEL segment should not be sent in Z05 message" D ACK^IVMPREC
"RTN","IVMPREC6",97,0)
 .;
"RTN","IVMPREC6",98,0)
 .I $E(IVMSEG,1,3)'="ZTA" D  Q
"RTN","IVMPREC6",99,0)
 ..S HLERR="Missing ZTA segment" D ACK^IVMPREC
"RTN","IVMPREC6",100,0)
 .;Convert "" to null in ZTA segment seq. 7
"RTN","IVMPREC6",101,0)
 .I $P(IVMSEG,HLFS,8)=HLQ S $P(IVMSEG,HLFS,8)=""
"RTN","IVMPREC6",102,0)
 .;
"RTN","IVMPREC6",103,0)
 .; - compare ZTA segment fields with DHCP fields
"RTN","IVMPREC6",104,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",105,0)
 .D NEXT
"RTN","IVMPREC6",106,0)
 .;
"RTN","IVMPREC6",107,0)
 .; - get next msg segment
"RTN","IVMPREC6",108,0)
 .I $E(IVMSEG,1,3)'="ZGD" D  Q
"RTN","IVMPREC6",109,0)
 ..S HLERR="Missing ZGD segment" D ACK^IVMPREC
"RTN","IVMPREC6",110,0)
 .;
"RTN","IVMPREC6",111,0)
 .; - compare ZGD segment fields with DHCP fields
"RTN","IVMPREC6",112,0)
 .; convert "" to null for ZGD segment
"RTN","IVMPREC6",113,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
"RTN","IVMPREC6",114,0)
 .; convert seq. 6 separately
"RTN","IVMPREC6",115,0)
 .S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
"RTN","IVMPREC6",116,0)
 .D COMPARE(IVMSEG)
"RTN","IVMPREC6",117,0)
 .;S IVMFLG=0
"RTN","IVMPREC6",118,0)
 .;
"RTN","IVMPREC6",119,0)
 .;S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Skip ZCT & ZEM -coming later
"RTN","IVMPREC6",120,0)
 .;.D NEXT
"RTN","IVMPREC6",121,0)
 .;.I ($E(IVMSEG,1,3)'="ZCT")&($E(IVMSEG,1,3)'="ZEM") S MULTDONE=1 Q
"RTN","IVMPREC6",122,0)
 .;S IVMDA=IVMDA-1
"RTN","IVMPREC6",123,0)
 .;
"RTN","IVMPREC6",124,0)
 .; - get next msg segment
"RTN","IVMPREC6",125,0)
 .D NEXT
"RTN","IVMPREC6",126,0)
 .I $E(IVMSEG,1,3)'="ZCT" D  Q
"RTN","IVMPREC6",127,0)
 ..S HLERR="Missing ZCT segment" D ACK^IVMPREC
"RTN","IVMPREC6",128,0)
 .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",129,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)   ;Process 1st ZCT
"RTN","IVMPREC6",130,0)
 .S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Handle possible mult ZCTs
"RTN","IVMPREC6",131,0)
 ..D NEXT I $E(IVMSEG,1,3)'="ZCT" S MULTDONE=1 Q
"RTN","IVMPREC6",132,0)
 ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC6",133,0)
 ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",134,0)
 .;
"RTN","IVMPREC6",135,0)
 .S IVMDA=IVMDA-1 D NEXT
"RTN","IVMPREC6",136,0)
 .I $E(IVMSEG,1,3)'="ZEM" D  Q
"RTN","IVMPREC6",137,0)
 ..S HLERR="Missing ZEM segment" D ACK^IVMPREC
"RTN","IVMPREC6",138,0)
 .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)   ;Process 1st ZEM
"RTN","IVMPREC6",139,0)
 .S MULTDONE=0 F XREP=1:1 D  Q:MULTDONE  ;Handle possible mult ZEMs
"RTN","IVMPREC6",140,0)
 ..D NEXT I $E(IVMSEG,1,3)'="ZEM" S MULTDONE=1 Q
"RTN","IVMPREC6",141,0)
 ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
"RTN","IVMPREC6",142,0)
 .S IVMDA=IVMDA-1
"RTN","IVMPREC6",143,0)
 .;
"RTN","IVMPREC6",144,0)
 .; - check for RF1 segment and get segment if it exists
"RTN","IVMPREC6",145,0)
 .;     This process will automatically update patient address data
"RTN","IVMPREC6",146,0)
 .;     in the Patient (#2) file if the incoming address is more
"RTN","IVMPREC6",147,0)
 .;     recent than the existing one.
"RTN","IVMPREC6",148,0)
 .;Modified code to handle multiple RF1 segment - IVM*2*115
"RTN","IVMPREC6",149,0)
 .S (UPDEPC("SAD"),UPDEPC("CPH"),UPDEPC("PNO"),UPDEPC("EAD"),UPDEPC("PHH"))=0
"RTN","IVMPREC6",150,0)
 .S QFLG=0 I $$RF1CHK(IVMRTN,IVMDA) F I=1:1 D  Q:QFLG
"RTN","IVMPREC6",151,0)
 ..D NEXT
"RTN","IVMPREC6",152,0)
 ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
"RTN","IVMPREC6",153,0)
 ..S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
"RTN","IVMPREC6",154,0)
 ..I $P(IVMSEG,HLFS,4)="" S QFLG=1 Q  ;Quit if RF1 is blank
"RTN","IVMPREC6",155,0)
 ..D COMPARE(IVMSEG)
"RTN","IVMPREC6",156,0)
 ..I '$$RF1CHK(IVMRTN,IVMDA) S QFLG=1
"RTN","IVMPREC6",157,0)
 .D AUTOAUP^IVMPREC9(DFN,.UPDAUP,.UPDAUPG)
"RTN","IVMPREC6",158,0)
 .S IVMFLG=0
"RTN","IVMPREC6",159,0)
 ;
"RTN","IVMPREC6",160,0)
 ; - send mail message if necessary
"RTN","IVMPREC6",161,0)
 ; This bulletin has been disabled.  IVM*2*140
"RTN","IVMPREC6",162,0)
 ;I IVMCNTR D MAIL^IVMUFNC()
"RTN","IVMPREC6",163,0)
 ; Cleanup variables if no msg necessary
"RTN","IVMPREC6",164,0)
 I 'IVMCNTR K IVMTEXT,XMSUB
"RTN","IVMPREC6",165,0)
 ;
"RTN","IVMPREC6",166,0)
ENQ ; - cleanup variables
"RTN","IVMPREC6",167,0)
 K DA,DFN,IVMADDR,IVMADFLG,IVMDA,IVMDHCP,IVMFLAG,IVMFLD,IVMPIECE,IVMSEG,IVMSTART,IVMXREF,DGENUPLD,IVMPID,PIDSTR,ADDRESS,TELECOM,UPDEPC,EPCFARY,IVMDFN,DODSEG,EPCDEL,GUARSEG,UPDAUP,IVMRACE,IVMTSTPT
"RTN","IVMPREC6",168,0)
 Q
"RTN","IVMPREC6",169,0)
 ;
"RTN","IVMPREC6",170,0)
 ;
"RTN","IVMPREC6",171,0)
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
"RTN","IVMPREC6",172,0)
 ;
"RTN","IVMPREC6",173,0)
 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
"RTN","IVMPREC6",174,0)
 Q
"RTN","IVMPREC6",175,0)
 ;
"RTN","IVMPREC6",176,0)
 ;
"RTN","IVMPREC6",177,0)
COMPARE(IVMSEG) ; - compare incoming HL7 segment/fields with DHCP fields
"RTN","IVMPREC6",178,0)
 ;
"RTN","IVMPREC6",179,0)
 ;  Input:  IVMSEG  --  as the text of the incoming HL7 message
"RTN","IVMPREC6",180,0)
 ;
"RTN","IVMPREC6",181,0)
 ; Output:  None
"RTN","IVMPREC6",182,0)
 ;
"RTN","IVMPREC6",183,0)
 ; - get 3 letter HL7 segment name
"RTN","IVMPREC6",184,0)
 S IVMXREF=$P(IVMSEG,HLFS,1),IVMSTART=IVMXREF
"RTN","IVMPREC6",185,0)
 ;
"RTN","IVMPREC6",186,0)
 ; - strip off HL7 segment name
"RTN","IVMPREC6",187,0)
 S IVMSEG=$P(IVMSEG,HLFS,2,99)
"RTN","IVMPREC6",188,0)
 ;
"RTN","IVMPREC6",189,0)
 ; - roll through "C" x-ref in IVM Demographic Upload Fields (#301.92) file
"RTN","IVMPREC6",190,0)
 F  S IVMXREF=$O(^IVM(301.92,"C",IVMXREF)) Q:IVMXREF']""  D
"RTN","IVMPREC6",191,0)
 .S IVMDEMDA=$O(^IVM(301.92,"C",IVMXREF,"")) Q:IVMDEMDA']""
"RTN","IVMPREC6",192,0)
 .I $$INACTIVE(IVMDEMDA) Q
"RTN","IVMPREC6",193,0)
 .;
"RTN","IVMPREC6",194,0)
 .; - compare incoming HL7 segment fields with DHCP fields
"RTN","IVMPREC6",195,0)
 .I IVMXREF["PID",(IVMSTART["PID") D PID^IVMPREC8
"RTN","IVMPREC6",196,0)
 .I IVMXREF["ZPD",(IVMSTART["ZPD") D ZPD^IVMPREC8
"RTN","IVMPREC6",197,0)
 .I IVMXREF["ZTA",(IVMSTART["ZTA") D ZTA^IVMPREC8
"RTN","IVMPREC6",198,0)
 .I IVMXREF["ZGD",(IVMSTART["ZGD") D ZGD^IVMPREC8
"RTN","IVMPREC6",199,0)
 .I IVMXREF["ZCT",(IVMSTART["ZCT") D ZCT^IVMPREC8
"RTN","IVMPREC6",200,0)
 .I IVMXREF["ZEM",(IVMSTART["ZEM") D ZEM^IVMPREC8
"RTN","IVMPREC6",201,0)
 .I IVMXREF["RF1",(IVMSTART["RF1") D RF1^IVMPREC8
"RTN","IVMPREC6",202,0)
 Q
"RTN","IVMPREC6",203,0)
 ;
"RTN","IVMPREC6",204,0)
 ;
"RTN","IVMPREC6",205,0)
DEMBULL ; -  build mail message for transmission to IVM mail group notifying
"RTN","IVMPREC6",206,0)
 ;    them that patients with updated demographic data has been received
"RTN","IVMPREC6",207,0)
 ;    from the IVM Center and may now be uploaded into DHCP.
"RTN","IVMPREC6",208,0)
 ;
"RTN","IVMPREC6",209,0)
 ; If record is auto uploaded, don't add veteran to bulletin
"RTN","IVMPREC6",210,0)
 I $$CKAUTO Q
"RTN","IVMPREC6",211,0)
 ;
"RTN","IVMPREC6",212,0)
 S IVMPTID=$$PT^IVMUFNC4(DFN)
"RTN","IVMPREC6",213,0)
 S XMSUB="IVM - DEMOGRAPHIC UPLOAD for "_$P($P(IVMPTID,"^"),",")_" ("_$P(IVMPTID,"^",3)_")"
"RTN","IVMPREC6",214,0)
 S IVMTEXT(1)="Updated demographic information has been received from the"
"RTN","IVMPREC6",215,0)
 S IVMTEXT(2)="Health Eligibilty Center.  Please select the 'Demographic Upload'"
"RTN","IVMPREC6",216,0)
 S IVMTEXT(3)="option from the IVM Upload Menu in order to take action on this"
"RTN","IVMPREC6",217,0)
 S IVMTEXT(4)="demographic information.  If you have any questions concerning the"
"RTN","IVMPREC6",218,0)
 S IVMTEXT(5)="information received, please contact the Health Eligibility Center."
"RTN","IVMPREC6",219,0)
 S IVMTEXT(7)=""
"RTN","IVMPREC6",220,0)
 S IVMTEXT(8)="The Health Eligibilty Center has identified the following"
"RTN","IVMPREC6",221,0)
 S IVMTEXT(9)="patients as having updated demographic information:"
"RTN","IVMPREC6",222,0)
 S IVMTEXT(10)=""
"RTN","IVMPREC6",223,0)
 S IVMCNTR=IVMCNTR+1
"RTN","IVMPREC6",224,0)
 S IVMTEXT(IVMCNTR+10)=$J(IVMCNTR_")",5)_"  "_$P(IVMPTID,"^")_" ("_$P(IVMPTID,"^",3)_")"
"RTN","IVMPREC6",225,0)
 Q
"RTN","IVMPREC6",226,0)
 ;
"RTN","IVMPREC6",227,0)
INACTIVE(IVMDEMDA) ;Check if field is inactive in Demographic Upload
"RTN","IVMPREC6",228,0)
 ; Input  -- IVMDEMDA IVM Demographic Upload Fields IEN
"RTN","IVMPREC6",229,0)
 ; Output -- 1=Yes and 0=No
"RTN","IVMPREC6",230,0)
 Q +$P($G(^IVM(301.92,IVMDEMDA,0)),U,9)
"RTN","IVMPREC6",231,0)
 ;
"RTN","IVMPREC6",232,0)
RF1CHK(IVMRTN,IVMDA) ;does an RF1 segment exist in this message?
"RTN","IVMPREC6",233,0)
 N RF1
"RTN","IVMPREC6",234,0)
 S RF1=$O(^TMP($J,IVMRTN,IVMDA))
"RTN","IVMPREC6",235,0)
 I $E($G(^(+RF1,0)),1,3)'="RF1" Q 0
"RTN","IVMPREC6",236,0)
 Q 1
"RTN","IVMPREC6",237,0)
 ;
"RTN","IVMPREC6",238,0)
CKAUTO() ;
"RTN","IVMPREC6",239,0)
 ; Chect if message qualifies for an auto upload.
"RTN","IVMPREC6",240,0)
 N AUTO,IVMI,DOD
"RTN","IVMPREC6",241,0)
 S AUTO=0,IVMI=$O(^IVM(301.92,"C","ZPD09",""))
"RTN","IVMPREC6",242,0)
 I IVMI=IVMDEMDA  D
"RTN","IVMPREC6",243,0)
 .I +IVMFLD'>0 S AUTO=1 Q
"RTN","IVMPREC6",244,0)
 .S DOD=$P($G(^DPT(DFN,.35)),U)
"RTN","IVMPREC6",245,0)
 .I DOD=IVMFLD S AUTO=1 Q
"RTN","IVMPREC6",246,0)
 ;
"RTN","IVMPREC6",247,0)
 Q AUTO
"RTN","IVMPREC6",248,0)
BLDPID(PIDTMP,IVMPID) ;Build IVMPID subscripted by sequence number
"RTN","IVMPREC6",249,0)
 N STR,X1,X2,N,TEXT,C,L
"RTN","IVMPREC6",250,0)
 S STR="",X1=1,(N,X2)=0
"RTN","IVMPREC6",251,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",252,0)
 . I C="^" D  Q
"RTN","IVMPREC6",253,0)
 . . I X2 S X2=X2+1,IVMPID(X1,X2)=STR
"RTN","IVMPREC6",254,0)
 . . E  S IVMPID(X1)=STR
"RTN","IVMPREC6",255,0)
 . . S STR="",X1=X1+1,X2=0
"RTN","IVMPREC6",256,0)
 . I C="|" D  Q
"RTN","IVMPREC6",257,0)
 . . S X2=X2+1,IVMPID(X1,X2)=STR,STR=""
"RTN","IVMPREC6",258,0)
 . S STR=STR_C
"RTN","IVMPREC6",259,0)
 I $G(C)'="",$G(C)'="^",$G(C)'="|" D
"RTN","IVMPREC6",260,0)
 . I X2 S X2=X2+1,IVMPID(X1,X2)=STR Q
"RTN","IVMPREC6",261,0)
 . S IVMPID(X1)=STR
"RTN","IVMPREC6",262,0)
 Q
"RTN","IVMPREC6",263,0)
ADDRCHNG(DFN) ;Store Address Change Date/time, Source and site if necessary
"RTN","IVMPREC6",264,0)
 ;Store Residence Number Change Date/Time, Source and Site (IVM*2*152)
"RTN","IVMPREC6",265,0)
 N IVMVALUE,IVMFIELD
"RTN","IVMPREC6",266,0)
 I '$D(^TMP($J,"CHANGE UPDATE")) Q
"RTN","IVMPREC6",267,0)
 S IVMFIELD=0 F  S IVMFIELD=$O(^TMP($J,"CHANGE UPDATE",IVMFIELD)) Q:IVMFIELD=""  D
"RTN","IVMPREC6",268,0)
 . S IVMVALUE=$G(^TMP($J,"CHANGE UPDATE",IVMFIELD))
"RTN","IVMPREC6",269,0)
 . S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
"RTN","IVMPREC6",270,0)
 . D ^DIE K DA,DIE,DR
"RTN","IVMPREC6",271,0)
 .; - delete inaccurate Addr Change Site data if Source is not VAMC
"RTN","IVMPREC6",272,0)
 . I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMPREC6",273,0)
 .; - delete inaccurate Residence Number Change Site data if Source
"RTN","IVMPREC6",274,0)
 .;   is not VAMC (IVM*2*152)
"RTN","IVMPREC6",275,0)
 . I IVMFIELD=.1322,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.1323)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMPREC6",276,0)
 K ^TMP($J,"CHANGE UPDATE")
"RTN","IVMPREC6",277,0)
 Q
"RTN","IVMPREC6",278,0)
EPCFLDS(EPCFARY,EPCDEL) ;
"RTN","IVMPREC6",279,0)
 ;EPCFARY - Contains IENs of Pager, email and Cell phone records in 301.92 File - Passed by reference
"RTN","IVMPREC6",280,0)
 ;EPCDEL - Contains field # of Pager, Email and Cell phone fields in Patient(#2) file. - Passed by reference
"RTN","IVMPREC6",281,0)
 I (DODSEG)!(GUARSEG) Q
"RTN","IVMPREC6",282,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",283,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",284,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",285,0)
 S EPCDEL("PNO")=".135^.1312^.1313^.1314"
"RTN","IVMPREC6",286,0)
 S EPCDEL("CPH")=".134^.139^.1311^.13111"
"RTN","IVMPREC6",287,0)
 S EPCDEL("EAD")=".133^.136^.137^.138"
"RTN","IVMPREC6",288,0)
 Q
"RTN","IVMPREC6",289,0)
 ;
"RTN","IVMPREC6",290,0)
AUPBLD(AUPFARY,UPDAUPG) ; Set up array containing fields for auto upload.
"RTN","IVMPREC6",291,0)
 ;AUPFARY - Contains fields in 301.92 File-Passed by reference
"RTN","IVMPREC6",292,0)
 ;UPDAUPG - Contains all groups initialized to '0'
"RTN","IVMPREC6",293,0)
 N AUPSTR,AUPGRP,AUPFLST,AUPPCE,AUPSGSQ,AUPDA
"RTN","IVMPREC6",294,0)
 F I=3:1 S AUPSTR=$P($T(AUPLST+I),";;",2,3) Q:$P(AUPSTR,";")="QUIT"  D
"RTN","IVMPREC6",295,0)
 .S AUPGRP=$P(AUPSTR,";"),AUPFLST=$P(AUPSTR,";",2)
"RTN","IVMPREC6",296,0)
 .F AUPPCE=1:1:$L(AUPFLST,"^") D
"RTN","IVMPREC6",297,0)
 ..S AUPSGSQ=$P(AUPFLST,"^",AUPPCE) Q:AUPSGSQ=""
"RTN","IVMPREC6",298,0)
 ..S AUPDA=$O(^IVM(301.92,"C",AUPSGSQ,0)) Q:AUPDA=""
"RTN","IVMPREC6",299,0)
 ..S AUPFARY(AUPDA)=AUPGRP
"RTN","IVMPREC6",300,0)
 ..S:AUPGRP'="" UPDAUPG(AUPGRP)=0  ; Default group update flags to '0'
"RTN","IVMPREC6",301,0)
 Q
"RTN","IVMPREC6",302,0)
 ;
"RTN","IVMPREC6",303,0)
AUPLST ; P1;P2
"RTN","IVMPREC6",304,0)
 ; P1 = Group Name (treat all entries as this group if present)
"RTN","IVMPREC6",305,0)
 ; P2 = .01 field(s) from 301.92 seperated by '^'
"RTN","IVMPREC6",306,0)
 ;;D1;ZCT03D1^ZCT04D1^ZCT051D1^ZCT052D1^ZCT053D1^ZCT054D1^ZCT055D1^ZCT06D1^ZCT07D1^ZCT10D1
"RTN","IVMPREC6",307,0)
 ;;E1;ZCT03E1^ZCT04E1^ZCT051E1^ZCT052E1^ZCT053E1^ZCT054E1^ZCT055E1^ZCT06E1^ZCT07E1^ZCT10E1
"RTN","IVMPREC6",308,0)
 ;;E2;ZCT03E2^ZCT04E2^ZCT051E2^ZCT052E2^ZCT053E2^ZCT054E2^ZCT055E2^ZCT06E2^ZCT07E2^ZCT10E2
"RTN","IVMPREC6",309,0)
 ;;K1;ZCT03K1^ZCT04K1^ZCT051K1^ZCT052K1^ZCT053K1^ZCT054K1^ZCT055K1^ZCT06K1^ZCT07K1^ZCT10K1
"RTN","IVMPREC6",310,0)
 ;;K2;ZCT03K2^ZCT04K2^ZCT051K2^ZCT052K2^ZCT053K2^ZCT054K2^ZCT055K2^ZCT06K2^ZCT07K2^ZCT10K2
"RTN","IVMPREC6",311,0)
 ;;TA;ZTA02^ZTA03^ZTA04^ZTA051^ZTA052^ZTA053^ZTA054^ZTA055^ZTA056^ZTA058^ZTA059^ZTA07^ZTA08^ZTA09^ZTA054F^ZTA055F
"RTN","IVMPREC6",312,0)
 ;;;ZEM03^ZEM04^ZEM05^ZEM061^ZEM062^ZEM063^ZEM064^ZEM065^ZEM068^ZEM07^ZEM09
"RTN","IVMPREC6",313,0)
 ;;;ZEM03S^ZEM04S^ZEM05S^ZEM061S^ZEM062S^ZEM063S^ZEM064S^ZEM065S^ZEM068S^ZEM07S^ZEM09S
"RTN","IVMPREC6",314,0)
 ;;;PID06^PID10^PID16^PID17^PID22^ZPD30^ZPD06^ZPD07
"RTN","IVMPREC6",315,0)
 ;;QUIT
"RTN","IVMPREC6",316,0)
 ;;
"RTN","IVMPREC6",317,0)
 ;;The following have been disabled until further notice
"RTN","IVMPREC6",318,0)
 ;;;PID113N^PID114N^PID24^PID13W
"RTN","IVMPREC6",319,0)
 ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1112C1^PID1112C2^PID13CA^RF161CA^RF171CA
"RTN","IVMPREC8")
0^4^B230918624
"RTN","IVMPREC8",1,0)
IVMPREC8 ;ALB/KCL/BRM/PJR/CKN,TDM,PWC,LBD - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ; 10/16/12 4:14pm
"RTN","IVMPREC8",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,58,73,79,102,115,121,148,151,152**;21-OCT-94;Build 4
"RTN","IVMPREC8",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMPREC8",4,0)
 ;
"RTN","IVMPREC8",5,0)
 ; This routine is called from IVMPREC6.
"RTN","IVMPREC8",6,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC8",7,0)
 ; messages received from the IVM center.
"RTN","IVMPREC8",8,0)
 ;
"RTN","IVMPREC8",9,0)
 ;
"RTN","IVMPREC8",10,0)
 ;
"RTN","IVMPREC8",11,0)
PID ; - compare PID segment fields with DHCP fields
"RTN","IVMPREC8",12,0)
 N COMPPH1,COMPPH2,COUNTRY
"RTN","IVMPREC8",13,0)
 ;
"RTN","IVMPREC8",14,0)
 S IVMFLD=""
"RTN","IVMPREC8",15,0)
 ; - strip off segment name
"RTN","IVMPREC8",16,0)
 S IVMPIECE=$E(IVMXREF,4,9)
"RTN","IVMPREC8",17,0)
 ;Only process if value exist - also handles multiple address
"RTN","IVMPREC8",18,0)
 I $G(IVMPID(+$E(IVMPIECE,1,2)))'=""!($O(IVMPID(+$E(IVMPIECE,1,2),""))) D
"RTN","IVMPREC8",19,0)
 .;
"RTN","IVMPREC8",20,0)
 .; - if PID field is the address field - parse address
"RTN","IVMPREC8",21,0)
 .S IVMADFLG=0
"RTN","IVMPREC8",22,0)
 .I IVMXREF["PID11",'$G(DODSEG) D  Q:IVMFLD=""
"RTN","IVMPREC8",23,0)
 ..;
"RTN","IVMPREC8",24,0)
 ..; - Process Place of Birth City & State
"RTN","IVMPREC8",25,0)
 ..;I (IVMXREF="PID113N")!(IVMXREF="PID114N") D  Q
"RTN","IVMPREC8",26,0)
 ..;.Q:'$D(ADDRESS("N"))
"RTN","IVMPREC8",27,0)
 ..;.S IVMADDR=ADDRESS("N")
"RTN","IVMPREC8",28,0)
 ..;.S IVMPIECE=$E(IVMPIECE,3,4),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",29,0)
 ..;.Q:IVMFLD=""
"RTN","IVMPREC8",30,0)
 ..;.I IVMPIECE="4N" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",31,0)
 ..;
"RTN","IVMPREC8",32,0)
 ..; - get PID address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",33,0)
 ..;I $G(AUPFARY(IVMDEMDA))="CA" S IVMADDR=$G(ADDRESS("CA")) ;Conf Addr
"RTN","IVMPREC8",34,0)
 ..I $G(AUPFARY(IVMDEMDA))'="CA" D
"RTN","IVMPREC8",35,0)
 ...S IVMADDR=$S($D(ADDRESS("P")):ADDRESS("P"),$D(ADDRESS("VAB1")):ADDRESS("VAB1"),$D(ADDRESS("VAB2")):ADDRESS("VAB2"),$D(ADDRESS("VAB3")):ADDRESS("VAB3"),$D(ADDRESS("VAB4")):ADDRESS("VAB4"),1:"")
"RTN","IVMPREC8",36,0)
 ..I IVMADDR="" Q
"RTN","IVMPREC8",37,0)
 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)
"RTN","IVMPREC8",38,0)
 ..S FORADDR=$S(COUNTRY="USA":0,1:1)
"RTN","IVMPREC8",39,0)
 ..; - get piece of address field, and set IVMFLD
"RTN","IVMPREC8",40,0)
 ..S IVMPIECE=$E(IVMPIECE,3,6),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",41,0)
 ..;I (IVMPIECE="2C")!(IVMPIECE="8C") S:IVMFLD="" IVMFLD="@"
"RTN","IVMPREC8",42,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",43,0)
 ..; - convert state abbrev. to pointer
"RTN","IVMPREC8",44,0)
 ..I (IVMPIECE=4)!(IVMPIECE="4C") D
"RTN","IVMPREC8",45,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")
"RTN","IVMPREC8",46,0)
 ...I IVMFLD'="" S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",47,0)
 ..I (IVMPIECE=5)!(IVMPIECE="5C") D
"RTN","IVMPREC8",48,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"")
"RTN","IVMPREC8",49,0)
 ...I IVMFLD'="" S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=X
"RTN","IVMPREC8",50,0)
 ..I (IVMPIECE="4F")!(IVMPIECE="4CF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;PROVINCE
"RTN","IVMPREC8",51,0)
 ..I (IVMPIECE="5F")!(IVMPIECE="5CF") S IVMFLD=$S(FORADDR:IVMFLD,1:"") ;POSTAL CODE
"RTN","IVMPREC8",52,0)
 ..I (IVMPIECE=6)!(IVMPIECE="6C") S IVMFLD=$$CNTRCONV(COUNTRY) ;COUNTRY
"RTN","IVMPREC8",53,0)
 ..I IVMPIECE=7 S IVMFLD=$$BAICONV(IVMFLD) ;Bad Address Indicator
"RTN","IVMPREC8",54,0)
 ..I IVMPIECE="7C" S IVMFLD=CONFADCT  ;CONFADCT set in PID11^IVMPRECA
"RTN","IVMPREC8",55,0)
 ..I IVMPIECE="9C" D
"RTN","IVMPREC8",56,0)
 ...S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""
"RTN","IVMPREC8",57,0)
 ...S IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",IVMFLD,0))  ;CONF ADDR COUNTY
"RTN","IVMPREC8",58,0)
 ..I $E(IVMPIECE,1,3)="12C" S IVMFLD=$$FMDATE^HLFNC($P(IVMFLD,$E(HLECH,4),$E(IVMPIECE,4)))
"RTN","IVMPREC8",59,0)
 ..S IVMADFLG=1
"RTN","IVMPREC8",60,0)
 .;
"RTN","IVMPREC8",61,0)
 .I IVMXREF["PID12",'$G(DODSEG) D
"RTN","IVMPREC8",62,0)
 ..I 'FORADDR S IVMADFLG=1,IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",IVMPID(12),0))  ;Process county only if not foreign address
"RTN","IVMPREC8",63,0)
 .; line remove so that the phone number is compared 
"RTN","IVMPREC8",64,0)
 .; before saving to 301.5.
"RTN","IVMPREC8",65,0)
 .I IVMXREF["PID13",$D(TELECOM),'$G(DODSEG) D
"RTN","IVMPREC8",66,0)
 ..;Confidential Phone Number
"RTN","IVMPREC8",67,0)
 ..;I IVMXREF="PID13CA",$D(TELECOM("VACPN")) D
"RTN","IVMPREC8",68,0)
 ..;.S IVMFLD=$$CONVPH($P($G(TELECOM("VACPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",69,0)
 ..;Phone Number [Work]
"RTN","IVMPREC8",70,0)
 ..;I IVMXREF="PID13W",$D(TELECOM("WPN")) D
"RTN","IVMPREC8",71,0)
 ..;.S IVMFLD=$$CONVPH($P($G(TELECOM("WPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",72,0)
 ..;Pager Number
"RTN","IVMPREC8",73,0)
 ..I IVMXREF="PID13B",$D(TELECOM("BPN")) D
"RTN","IVMPREC8",74,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("BPN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",75,0)
 ..;Cell Phone Number
"RTN","IVMPREC8",76,0)
 ..I IVMXREF="PID13C",$D(TELECOM("ORN")) D
"RTN","IVMPREC8",77,0)
 ...S IVMFLD=$$CONVPH($P($G(TELECOM("ORN")),$E(HLECH))),IVMADFLG=1
"RTN","IVMPREC8",78,0)
 ..;Email Address
"RTN","IVMPREC8",79,0)
 ..I IVMXREF="PID13E",$D(TELECOM("NET")) D
"RTN","IVMPREC8",80,0)
 ...S IVMFLD=$P($G(TELECOM("NET")),$E(HLECH),4)
"RTN","IVMPREC8",81,0)
 ...S IVMFLD=$S($$CHKEMAIL(IVMFLD):IVMFLD,1:""),IVMADFLG=1
"RTN","IVMPREC8",82,0)
 .; - file address fields and quit
"RTN","IVMPREC8",83,0)
 .I IVMADFLG D STORE^IVMPREC9 Q
"RTN","IVMPREC8",84,0)
 .;
"RTN","IVMPREC8",85,0)
 .; - otherwise, set IVMFLD to field rec'd from IVM
"RTN","IVMPREC8",86,0)
 .;   for comparison with DHCP field
"RTN","IVMPREC8",87,0)
 .;I (IVMXREF'="PID113N")&(IVMXREF'="PID114N")&($E(IVMXREF,1,5)'="PID13") S IVMFLD=$G(IVMPID(+IVMPIECE))
"RTN","IVMPREC8",88,0)
 .I $E(IVMXREF,1,5)'="PID13" S IVMFLD=$G(IVMPID(+IVMPIECE))
"RTN","IVMPREC8",89,0)
 .;
"RTN","IVMPREC8",90,0)
 .; - if HL7 date convert to FM date and set IVMFLD
"RTN","IVMPREC8",91,0)
 .I IVMXREF["PID07" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",92,0)
 .;
"RTN","IVMPREC8",93,0)
 .; - if HL7 code convert to VistA and set IVMFLD
"RTN","IVMPREC8",94,0)
 .I IVMXREF["PID16" D  ;Marital Status
"RTN","IVMPREC8",95,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",96,0)
 ..S IVMFLD=$O(^DIC(11,"B",IVMFLD,0))
"RTN","IVMPREC8",97,0)
 .;
"RTN","IVMPREC8",98,0)
 .I IVMXREF["PID17" S IVMFLD=$O(^DIC(13,"C",IVMFLD,0))  ;Religion
"RTN","IVMPREC8",99,0)
 .;
"RTN","IVMPREC8",100,0)
 .I IVMXREF["PID22" D  ;Ethnicity
"RTN","IVMPREC8",101,0)
 ..S IVMFLD=$$CODE2PTR^DGUTL4($P($G(IVMPID(22)),$E(HLECH),4),2,2)
"RTN","IVMPREC8",102,0)
 .;
"RTN","IVMPREC8",103,0)
 .I IVMXREF="PID10",'$G(DODSEG),$D(IVMRACE) D  Q
"RTN","IVMPREC8",104,0)
 ..N XVAL,IVMLST,DHCPLST
"RTN","IVMPREC8",105,0)
 ..S (XVAL,IVMLST,DHCPLST)=""
"RTN","IVMPREC8",106,0)
 ..F  S XVAL=$O(^DPT(DFN,.02,"B",XVAL)) Q:XVAL=""  S IVMLST=IVMLST_XVAL_U
"RTN","IVMPREC8",107,0)
 ..S XVAL="" F  S XVAL=$O(IVMRACE(2,XVAL)) Q:XVAL=""  S DHCPLST=DHCPLST_XVAL_U
"RTN","IVMPREC8",108,0)
 ..Q:IVMLST=DHCPLST
"RTN","IVMPREC8",109,0)
 ..F XVAL=1:1:($L(DHCPLST,U)-1) S IVMFLD=$P(DHCPLST,U,XVAL) D
"RTN","IVMPREC8",110,0)
 ...D STORE^IVMPREC9
"RTN","IVMPREC8",111,0)
 .;
"RTN","IVMPREC8",112,0)
 .; - call VADPT routine to return DHCP demographics
"RTN","IVMPREC8",113,0)
 .D DEM^VADPT,ADD^VADPT,OPD^VADPT
"RTN","IVMPREC8",114,0)
 .;
"RTN","IVMPREC8",115,0)
 .; - execute code on the 1 node and get DHCP field for comparison
"RTN","IVMPREC8",116,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",117,0)
 .;
"RTN","IVMPREC8",118,0)
 .; - special logic for phone number processing
"RTN","IVMPREC8",119,0)
 .; - if different, then store the actual value received, then quit
"RTN","IVMPREC8",120,0)
 .;
"RTN","IVMPREC8",121,0)
 .I IVMXREF="PID13",$D(TELECOM("PRN")),'$G(DODSEG) D  Q
"RTN","IVMPREC8",122,0)
 ..S IVMFLD=$P($G(TELECOM("PRN")),$E(HLECH))
"RTN","IVMPREC8",123,0)
 ..I IVMFLD]"" D
"RTN","IVMPREC8",124,0)
 ...K UPPHN
"RTN","IVMPREC8",125,0)
 ...S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
"RTN","IVMPREC8",126,0)
 ...I COMPPH1'=COMPPH2 D STORE^IVMPREC9 S UPPHN=1
"RTN","IVMPREC8",127,0)
 .;
"RTN","IVMPREC8",128,0)
 .; - if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",129,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",130,0)
 Q
"RTN","IVMPREC8",131,0)
 ;
"RTN","IVMPREC8",132,0)
 ;
"RTN","IVMPREC8",133,0)
ZPD ; - compare ZPD segment fields with DHCP fields
"RTN","IVMPREC8",134,0)
 N STFLG
"RTN","IVMPREC8",135,0)
 S STFLG=0
"RTN","IVMPREC8",136,0)
 S IVMPIECE=$E(IVMXREF,4,5)
"RTN","IVMPREC8",137,0)
 I IVMXREF="ZPD09"!(IVMXREF="ZPD31")!(IVMXREF="ZPD32") Q:$$DODCK(DFN)
"RTN","IVMPREC8",138,0)
 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
"RTN","IVMPREC8",139,0)
 .;
"RTN","IVMPREC8",140,0)
 .; - set var to HL7 field
"RTN","IVMPREC8",141,0)
 .S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
"RTN","IVMPREC8",142,0)
 .;
"RTN","IVMPREC8",143,0)
 .; - if HL7 name format convert to FM
"RTN","IVMPREC8",144,0)
 .I (IVMXREF["ZPD06")!(IVMXREF["ZPD07") S IVMFLD=$$FMNAME^HLFNC(IVMFLD)
"RTN","IVMPREC8",145,0)
 .;
"RTN","IVMPREC8",146,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",147,0)
 .I IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",148,0)
 .;
"RTN","IVMPREC8",149,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",150,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",151,0)
 .;
"RTN","IVMPREC8",152,0)
 .; - if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",153,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) S STFLG=1 D STORE^IVMPREC9 Q
"RTN","IVMPREC8",154,0)
 .I $P(IVMSEG,"^",IVMPIECE)'="""""" D
"RTN","IVMPREC8",155,0)
 ..I IVMXREF["ZPD09" D STORE^IVMPREC9
"RTN","IVMPREC8",156,0)
 ..;I IVMXREF["ZPD09"!(IVMXREF["ZPD31")!(IVMXREF["ZPD32") D STORE^IVMPREC9
"RTN","IVMPREC8",157,0)
 I IVMXREF["ZPD08",STFLG,$$AUTORINC^IVMPREC9(DFN) Q
"RTN","IVMPREC8",158,0)
 I IVMXREF["ZPD32",$$AUTODOD^IVMLDEMD(DFN)
"RTN","IVMPREC8",159,0)
 Q
"RTN","IVMPREC8",160,0)
 ;
"RTN","IVMPREC8",161,0)
 ;
"RTN","IVMPREC8",162,0)
DODCK(DFN) ;this will check if Date of Death information needs to be uploaded or not.
"RTN","IVMPREC8",163,0)
 ;2 requirements are:
"RTN","IVMPREC8",164,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",165,0)
 ;     VistA DOD is null or empty then VistA will upload the Date of Death from ESR
"RTN","IVMPREC8",166,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",167,0)
 ;     will not create an entry in the IVM demographic upload option.
"RTN","IVMPREC8",168,0)
 ;
"RTN","IVMPREC8",169,0)
 ; Inputs: DFN for ^DPT
"RTN","IVMPREC8",170,0)
 ;         IVMXREF (must be ZPD09, ZPD31 and ZPD32)
"RTN","IVMPREC8",171,0)
 ;         IVMSEG (the ZPD data)
"RTN","IVMPREC8",172,0)
 ;         IVMFLD (the field number in ^DPT(DFN)
"RTN","IVMPREC8",173,0)
 ;         IVMPIECE (the piece number of IVMSEG)
"RTN","IVMPREC8",174,0)
 ;         IVMDHCP (the data from ^DPT(DFN)
"RTN","IVMPREC8",175,0)
 ;
"RTN","IVMPREC8",176,0)
 ;
"RTN","IVMPREC8",177,0)
 N DODARRAY,QUIT
"RTN","IVMPREC8",178,0)
 ;
"RTN","IVMPREC8",179,0)
 S (CKDEL,QUIT)=0
"RTN","IVMPREC8",180,0)
 ;
"RTN","IVMPREC8",181,0)
 I $P(IVMSEG,"^",9)="""""" Q 0
"RTN","IVMPREC8",182,0)
 D GETS^DIQ(2,DFN,".351:.355","","DODARRAY")
"RTN","IVMPREC8",183,0)
 S DOD=DODARRAY(2,DFN_",",.351)
"RTN","IVMPREC8",184,0)
 I DOD'="" Q 1
"RTN","IVMPREC8",185,0)
 I $P(IVMSEG,"^",31)=3,DOD="" S QUIT=0    ;Death Certificate not on File
"RTN","IVMPREC8",186,0)
 I $P(IVMSEG,"^",31)=3,DOD'="" S QUIT=1
"RTN","IVMPREC8",187,0)
 ;
"RTN","IVMPREC8",188,0)
 Q QUIT ;
"RTN","IVMPREC8",189,0)
 ;
"RTN","IVMPREC8",190,0)
ZTA ; - compare ZTA segment fields with DHCP fields
"RTN","IVMPREC8",191,0)
 N COMPPH1,COMPPH2,COUNTRY
"RTN","IVMPREC8",192,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",193,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",194,0)
 .;
"RTN","IVMPREC8",195,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",196,0)
 .S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",197,0)
 .;
"RTN","IVMPREC8",198,0)
 .; - ZTA05 as the ZTA address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",199,0)
 .I IVMXREF["ZTA05" D
"RTN","IVMPREC8",200,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)) Q:IVMADDR=""
"RTN","IVMPREC8",201,0)
 ..S COUNTRY=$P(IVMADDR,$E(HLECH),6)
"RTN","IVMPREC8",202,0)
 ..S FORADDR=$S(COUNTRY="USA":0,1:1)
"RTN","IVMPREC8",203,0)
 ..; - get piece of address field, and set IVMFLD
"RTN","IVMPREC8",204,0)
 ..S IVMPIECE=$E(IVMPIECE,3,4)
"RTN","IVMPREC8",205,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
"RTN","IVMPREC8",206,0)
 ..I (IVMPIECE=2)!(IVMPIECE=8) S:IVMFLD="" IVMFLD="@"
"RTN","IVMPREC8",207,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",208,0)
 ..I (IVMPIECE=4)!(IVMPIECE=5)!(IVMPIECE=9) S IVMFLD=$S('FORADDR:IVMFLD,1:"") Q:IVMFLD=""
"RTN","IVMPREC8",209,0)
 ..I IVMPIECE=4 S (IVMTSTPT,IVMFLD)=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",210,0)
 ..I IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",211,0)
 ..I IVMPIECE="4F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;PROVINCE
"RTN","IVMPREC8",212,0)
 ..I IVMPIECE="5F" S IVMFLD=$S(FORADDR:IVMFLD,1:"")  ;POSTAL CODE
"RTN","IVMPREC8",213,0)
 ..I IVMPIECE=6 S IVMFLD=$$CNTRCONV(COUNTRY)         ;COUNTRY
"RTN","IVMPREC8",214,0)
 ..I IVMPIECE=9 S IVMFLD=+$O(^DIC(5,+IVMTSTPT,1,"C",IVMFLD,0))  ;COUNTY
"RTN","IVMPREC8",215,0)
 .Q:IVMFLD=""
"RTN","IVMPREC8",216,0)
 .;
"RTN","IVMPREC8",217,0)
 .; - if HL7 data convert to Y/N value
"RTN","IVMPREC8",218,0)
 .I IVMXREF["ZTA02" S IVMFLD=$S(IVMFLD=0:"N",IVMFLD=1:"Y",1:"")
"RTN","IVMPREC8",219,0)
 .;
"RTN","IVMPREC8",220,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",221,0)
 .I (IVMXREF["ZTA03")!(IVMXREF["ZTA04")!(IVMXREF["ZTA08") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",222,0)
 .;
"RTN","IVMPREC8",223,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",224,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",225,0)
 .;
"RTN","IVMPREC8",226,0)
 .; - special logic for phone number processing
"RTN","IVMPREC8",227,0)
 .; - if different, then store the actual value received, then quit
"RTN","IVMPREC8",228,0)
 .I IVMXREF["ZTA07" D  Q
"RTN","IVMPREC8",229,0)
 ..S COMPPH1=$$CONVPH(IVMFLD),COMPPH2=$$CONVPH(IVMDHCP)
"RTN","IVMPREC8",230,0)
 ..I COMPPH1'=COMPPH2 D STORE^IVMPREC9
"RTN","IVMPREC8",231,0)
 .;
"RTN","IVMPREC8",232,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",233,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",234,0)
 .;
"RTN","IVMPREC8",235,0)
 .I IVMXREF["ZTA08" D
"RTN","IVMPREC8",236,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("TA")=1
"RTN","IVMPREC8",237,0)
 Q
"RTN","IVMPREC8",238,0)
 ;
"RTN","IVMPREC8",239,0)
ZGD ; - compare ZGD segment fields with DHCP fields
"RTN","IVMPREC8",240,0)
 S IVMADFLG=0
"RTN","IVMPREC8",241,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",242,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",243,0)
 .;
"RTN","IVMPREC8",244,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",245,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
"RTN","IVMPREC8",246,0)
 .;
"RTN","IVMPREC8",247,0)
 .; - ZGD06 as the ZGD address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",248,0)
 .I IVMXREF["ZGD06" D
"RTN","IVMPREC8",249,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",250,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
"RTN","IVMPREC8",251,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",252,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",253,0)
 .;
"RTN","IVMPREC8",254,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",255,0)
 .I IVMXREF["ZGD08" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",256,0)
 .;
"RTN","IVMPREC8",257,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",258,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",259,0)
 .;
"RTN","IVMPREC8",260,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",261,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",262,0)
 Q
"RTN","IVMPREC8",263,0)
 ;
"RTN","IVMPREC8",264,0)
ZCT ; - compare ZCT segment fields with DHCP fields
"RTN","IVMPREC8",265,0)
 N ZCTTYP
"RTN","IVMPREC8",266,0)
 S IVMADFLG=0
"RTN","IVMPREC8",267,0)
 S IVMPIECE=$E(IVMXREF,4,8)
"RTN","IVMPREC8",268,0)
 S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC8",269,0)
 S ZCTTYP=$E(IVMPIECE,$L(IVMPIECE)-1,$L(IVMPIECE))
"RTN","IVMPREC8",270,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",271,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",272,0)
 .;
"RTN","IVMPREC8",273,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",274,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",275,0)
 .;
"RTN","IVMPREC8",276,0)
 .; - if HL7 name format convert to FM
"RTN","IVMPREC8",277,0)
 .I IVMXREF["ZCT03" S IVMFLD=$$FMNAME^HLFNC(IVMFLD)
"RTN","IVMPREC8",278,0)
 .;
"RTN","IVMPREC8",279,0)
 .; - ZCT05 as the ZCT address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",280,0)
 .I IVMXREF["ZCT05" D
"RTN","IVMPREC8",281,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",282,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
"RTN","IVMPREC8",283,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",284,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",285,0)
 .;
"RTN","IVMPREC8",286,0)
 .I IVMADFLG D STORE^IVMPREC9 Q
"RTN","IVMPREC8",287,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",288,0)
 .I IVMXREF["ZCT10" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",289,0)
 .;
"RTN","IVMPREC8",290,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",291,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",292,0)
 .;
"RTN","IVMPREC8",293,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",294,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",295,0)
 .;
"RTN","IVMPREC8",296,0)
 .I IVMXREF["ZCT10" D
"RTN","IVMPREC8",297,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG(ZCTTYP)=1
"RTN","IVMPREC8",298,0)
 Q
"RTN","IVMPREC8",299,0)
 ;
"RTN","IVMPREC8",300,0)
ZEM ; - compare ZEM segment fields with DHCP fields
"RTN","IVMPREC8",301,0)
 S IVMADFLG=0
"RTN","IVMPREC8",302,0)
 S IVMPIECE=$E(IVMXREF,4,7)
"RTN","IVMPREC8",303,0)
 S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
"RTN","IVMPREC8",304,0)
 Q:$P(IVMSEG,HLFS,2)'=$S($E(IVMXREF,$L(IVMXREF))="S":2,1:1)
"RTN","IVMPREC8",305,0)
 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
"RTN","IVMPREC8",306,0)
 .;
"RTN","IVMPREC8",307,0)
 .; - set var IVMFLD to incoming HL7 field
"RTN","IVMPREC8",308,0)
 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
"RTN","IVMPREC8",309,0)
 .;
"RTN","IVMPREC8",310,0)
 .; - ZEM06 as the ZEM address field containing 5 pieces seperated by HLECH (~)
"RTN","IVMPREC8",311,0)
 .I IVMXREF["ZEM06" D
"RTN","IVMPREC8",312,0)
 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
"RTN","IVMPREC8",313,0)
 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)    ;,IVMADFLG=1
"RTN","IVMPREC8",314,0)
 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
"RTN","IVMPREC8",315,0)
 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
"RTN","IVMPREC8",316,0)
 .;
"RTN","IVMPREC8",317,0)
 .; - if HL7 date convert to FM date
"RTN","IVMPREC8",318,0)
 .I IVMXREF["ZEM09" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
"RTN","IVMPREC8",319,0)
 .;
"RTN","IVMPREC8",320,0)
 .; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",321,0)
 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",322,0)
 .;
"RTN","IVMPREC8",323,0)
 .; if field from IVM does not equal DHCP field - store for uploading
"RTN","IVMPREC8",324,0)
 .I $E(IVMXREF,1,6)="ZEM062",IVMFLD'=IVMDHCP S ZEMADRUP(IVMXREF)=1 D STORE^IVMPREC9 Q
"RTN","IVMPREC8",325,0)
 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
"RTN","IVMPREC8",326,0)
 Q
"RTN","IVMPREC8",327,0)
 ;
"RTN","IVMPREC8",328,0)
RF1 ; - compare RF1 segment fields with DHCP fields
"RTN","IVMPREC8",329,0)
 S IVMPIECE=$E(IVMXREF,4),IVMADFLG=1,RF1TYPE=$P(IVMSEG,HLFS,3)
"RTN","IVMPREC8",330,0)
 ;As per requirements, delete the communication data (Email, Cell and Pager) if it is not received in Z05.
"RTN","IVMPREC8",331,0)
 ;Hence, remove it from EPCDEL (deletion array) if Data exist in Z05. Comm. fields contained in EPCDEL will be deleted after updating all incoming communication data.
"RTN","IVMPREC8",332,0)
 K EPCDEL(RF1TYPE)
"RTN","IVMPREC8",333,0)
 ;if RF1 field is SEQ6, then parse subcomponents
"RTN","IVMPREC8",334,0)
 I RF1TYPE="SAD",((IVMXREF="RF161")!(IVMXREF="RF162")!(IVMXREF="RF171")) D RF1PROC
"RTN","IVMPREC8",335,0)
 ;I RF1TYPE="CAD",((IVMXREF="RF161CA")!(IVMXREF="RF171CA")) D RF1PROC
"RTN","IVMPREC8",336,0)
 I RF1TYPE="CPH",((IVMXREF="RF161C")!(IVMXREF="RF162C")!(IVMXREF="RF171C")) D RF1PROC
"RTN","IVMPREC8",337,0)
 I RF1TYPE="PNO",((IVMXREF="RF161B")!(IVMXREF="RF162B")!(IVMXREF="RF171B")) D RF1PROC
"RTN","IVMPREC8",338,0)
 I RF1TYPE="EAD",((IVMXREF="RF161E")!(IVMXREF="RF162E")!(IVMXREF="RF171E")) D RF1PROC
"RTN","IVMPREC8",339,0)
 I RF1TYPE="PHH",((IVMXREF="RF161P")!(IVMXREF="RF162P")!(IVMXREF="RF171P")) D RF1PROC     ;Added for IVM*2*152
"RTN","IVMPREC8",340,0)
 I '$$RF1CHK^IVMPREC6(IVMRTN,IVMDA),IVMXREF="RF171P" D  ;Last RF1
"RTN","IVMPREC8",341,0)
 . I $$AUTOEPC^IVMPREC9(DFN,.UPDEPC)
"RTN","IVMPREC8",342,0)
 . N NOUPDT,NOPHUP S (NOUPDT,NOPHUP)=0   ;Added for IVM*2*152
"RTN","IVMPREC8",343,0)
 . I 'UPDEPC("SAD") S NOUPDT=1
"RTN","IVMPREC8",344,0)
 . ;Set the NOPHUP flag = 1 if Home Phone Change Dt/Tm not more recent, or
"RTN","IVMPREC8",345,0)
 . ;if Home Phone Change Dt/Tm more recent, but phone # the same
"RTN","IVMPREC8",346,0)
 . ;Added for IVM*2*152
"RTN","IVMPREC8",347,0)
 . I 'UPDEPC("PHH") S NOPHUP=1
"RTN","IVMPREC8",348,0)
 . I UPDEPC("PHH"),'$G(UPPHN) S NOPHUP=1
"RTN","IVMPREC8",349,0)
 . K UPPHN
"RTN","IVMPREC8",350,0)
 . I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT,NOPHUP)
"RTN","IVMPREC8",351,0)
 Q
"RTN","IVMPREC8",352,0)
 ;
"RTN","IVMPREC8",353,0)
RF1PROC ;
"RTN","IVMPREC8",354,0)
 N IVMEPC
"RTN","IVMPREC8",355,0)
 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
"RTN","IVMPREC8",356,0)
 .;if RF1 field is SEQ6, then parse subcomponents
"RTN","IVMPREC8",357,0)
 .I IVMXREF["RF16" D  Q
"RTN","IVMPREC8",358,0)
 ..;- get data containing 4 pieces seperated by HLECH (~)
"RTN","IVMPREC8",359,0)
 ..S IVMRFDAT=$P(IVMSEG,HLFS,6)
"RTN","IVMPREC8",360,0)
 ..S IVMPIECE=$E(IVMXREF,5),IVMFLD=$P(IVMRFDAT,"~",IVMPIECE)
"RTN","IVMPREC8",361,0)
 ..;get 6th character of IVMXREF to determine if value is for Address
"RTN","IVMPREC8",362,0)
 ..;OR Email, Cell and Pager
"RTN","IVMPREC8",363,0)
 ..S IVMEPC=$E(IVMXREF,6)
"RTN","IVMPREC8",364,0)
 ..;Convert Change Source for Address, Email, Cell and Pager
"RTN","IVMPREC8",365,0)
 ..I IVMPIECE=2 S IVMFLD=$S(IVMEPC'="":$$EPCSRCC(IVMFLD),1:$$ADDRCNV(IVMFLD))
"RTN","IVMPREC8",366,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",367,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",368,0)
 .I IVMXREF["RF17" D  Q
"RTN","IVMPREC8",369,0)
 ..;get address/telecomm change date/tm field
"RTN","IVMPREC8",370,0)
 ..S IVMFLD=$$FMDATE^HLFNC($P(IVMSEG,HLFS,7))
"RTN","IVMPREC8",371,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",372,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",373,0)
 ..;
"RTN","IVMPREC8",374,0)
 ..;I RF1TYPE="CAD",$P($G(ADDRESS("CA")),HLFS)]"" D  Q
"RTN","IVMPREC8",375,0)
 ..;.; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",376,0)
 ..;.S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",377,0)
 ..;.I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("CA")=1
"RTN","IVMPREC8",378,0)
 ..;
"RTN","IVMPREC8",379,0)
 ..; check for auto-upload
"RTN","IVMPREC8",380,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",381,0)
 ..I IVMDHCP="" S IVMDHCP=$S(RF1TYPE="PHH":$P($G(^DPT(DFN,.132)),HLFS,1),1:"")     ;Added for IVM*2*152
"RTN","IVMPREC8",382,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) D
"RTN","IVMPREC8",383,0)
 ...S UPDEPC(RF1TYPE)=$G(EPCFARY(RF1TYPE))
"RTN","IVMPREC8",384,0)
 ...I RF1TYPE="SAD" S UPDEPC("SAD")=1
"RTN","IVMPREC8",385,0)
 ...I RF1TYPE="PHH" S UPDEPC("PHH")=1   ;Added for IVM*2*152
"RTN","IVMPREC8",386,0)
 Q
"RTN","IVMPREC8",387,0)
ADDRCNV(ADDRSRC) ;convert Address Source from HL7 to DHCP format
"RTN","IVMPREC8",388,0)
 ;
"RTN","IVMPREC8",389,0)
 Q:$G(ADDRSRC)']"" ""
"RTN","IVMPREC8",390,0)
 Q:ADDRSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",391,0)
 Q:ADDRSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",392,0)
 Q:ADDRSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",393,0)
 Q:ADDRSRC="USNCOA" "NCOA"
"RTN","IVMPREC8",394,0)
 Q:ADDRSRC="USVABVA" "BVA"
"RTN","IVMPREC8",395,0)
 Q:ADDRSRC="USVAINS" "VAINS"
"RTN","IVMPREC8",396,0)
 Q:ADDRSRC="USPS" "USPS"
"RTN","IVMPREC8",397,0)
 Q:ADDRSRC="LACS" "LACS"
"RTN","IVMPREC8",398,0)
 Q:ADDRSRC="USVOA" "VOA"
"RTN","IVMPREC8",399,0)
 Q ""
"RTN","IVMPREC8",400,0)
EPCSRCC(EPCSRC) ;Convert Email, Cell, Pager Change Source from HL7 to DHCP
"RTN","IVMPREC8",401,0)
 ;
"RTN","IVMPREC8",402,0)
 Q:$G(EPCSRC)']"" ""
"RTN","IVMPREC8",403,0)
 Q:EPCSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",404,0)
 Q:EPCSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",405,0)
 Q:EPCSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",406,0)
 Q ""
"RTN","IVMPREC8",407,0)
BAICONV(BAISRC) ;Convert Bad address source from HL7 to DHCP format
"RTN","IVMPREC8",408,0)
 Q:$G(BAISRC)']"" ""
"RTN","IVMPREC8",409,0)
 Q:BAISRC="VAB1" 1
"RTN","IVMPREC8",410,0)
 Q:BAISRC="VAB2" 2
"RTN","IVMPREC8",411,0)
 Q:BAISRC="VAB3" 3
"RTN","IVMPREC8",412,0)
 Q:BAISRC="VAB4" 4
"RTN","IVMPREC8",413,0)
 Q ""
"RTN","IVMPREC8",414,0)
CONVPH(PH) ;remove special chars/spaces from Phone number
"RTN","IVMPREC8",415,0)
 Q $TR(PH," )(/#\-","")
"RTN","IVMPREC8",416,0)
CNTRCONV(COUNTRY) ;Check if valid country
"RTN","IVMPREC8",417,0)
 I COUNTRY="" Q 0
"RTN","IVMPREC8",418,0)
 Q $O(^HL(779.004,"B",COUNTRY,""))
"RTN","IVMPREC8",419,0)
CHKEMAIL(EMAIL) ;Check for Valid Email
"RTN","IVMPREC8",420,0)
 I $G(EMAIL)="" Q 0
"RTN","IVMPREC8",421,0)
 I '(EMAIL?1.E1"@"1.E1"."1.E) Q 0
"RTN","IVMPREC8",422,0)
 Q 1
"RTN","IVMPTRN9")
0^1^B53346875
"RTN","IVMPTRN9",1,0)
IVMPTRN9 ;ALB/KCL/CN/BRM,TDM,EG,LBD - HL7 FULL DATA TRANSMISSION (Z07) BUILDER (CONTINUED) ; 2/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**; 21-OCT-94;Build 4
"RTN","IVMPTRN9",3,0)
 ;
"RTN","IVMPTRN9",4,0)
 ;
"RTN","IVMPTRN9",5,0)
GOTO ; place to break up the routine
"RTN","IVMPTRN9",6,0)
 ;
"RTN","IVMPTRN9",7,0)
 ; create (ZIO) Inpatient/Outpatient segment for veteran
"RTN","IVMPTRN9",8,0)
 S N101015=$G(^DPT(DFN,1010.15))
"RTN","IVMPTRN9",9,0)
 S ZIOSEG="ZIO^1^"_$$EN^IVMUFNC1(DFN,IVMMTDT,.IVMQUERY)  ;seq 1-3
"RTN","IVMPTRN9",10,0)
 S ZIOSEG=ZIOSEG_"^"_$$LTD^IVMUFNC(DFN,.IVMQUERY)        ;seq 4
"RTN","IVMPTRN9",11,0)
 S X=$P(N101015,"^",9),$P(ZIOSEG,U,6)=$S(X=0:"N",X=1:"Y",1:HLQ)   ;Appt Request
"RTN","IVMPTRN9",12,0)
 S X=$P(N101015,"^",11),$P(ZIOSEG,U,7)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) ;Appt Request Date
"RTN","IVMPTRN9",13,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZIOSEG
"RTN","IVMPTRN9",14,0)
 ;
"RTN","IVMPTRN9",15,0)
 ; create (NTE) Notes and Comments segment
"RTN","IVMPTRN9",16,0)
 D NTE^IVMUFNC4(DFN,.IVMNTE,IVMMTDT)
"RTN","IVMPTRN9",17,0)
 I '$D(IVMNTE) D
"RTN","IVMPTRN9",18,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="NTE^1"
"RTN","IVMPTRN9",19,0)
 I $D(IVMNTE) D
"RTN","IVMPTRN9",20,0)
 . ; - get notes and comments
"RTN","IVMPTRN9",21,0)
 . F IVMSUB=0:0 S IVMSUB=$O(IVMNTE(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",22,0)
 . . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMNTE(IVMSUB)
"RTN","IVMPTRN9",23,0)
 ;
"RTN","IVMPTRN9",24,0)
 ; create (IN1) Insurance segment(s) for all active insurance
"RTN","IVMPTRN9",25,0)
 K ^TMP("VAFIN1",$J)
"RTN","IVMPTRN9",26,0)
 D EN^VAFHLIN1(DFN,"1,4,5,7,8,9,12,13,15,16,17,28,36")
"RTN","IVMPTRN9",27,0)
 F IVMSUB=0:0 S IVMSUB=$O(^TMP("VAFIN1",$J,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",28,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=^TMP("VAFIN1",$J,+IVMSUB,0)
"RTN","IVMPTRN9",29,0)
 ;
"RTN","IVMPTRN9",30,0)
 ;find if the deletion flags were set in the IVM Patient file, and if so, should the deletion indicators be sent?
"RTN","IVMPTRN9",31,0)
 F I="RX","MT","HARDSHIP","DATE OF TEST","LTC" S DELETE(I)=""
"RTN","IVMPTRN9",32,0)
 S IVMPIEN=$$FIND^IVMPLOG(DFN,($E(IVMMTDT,1,3)-1))
"RTN","IVMPTRN9",33,0)
 I IVMPIEN D
"RTN","IVMPTRN9",34,0)
 . S IVMPNODE=$G(^IVM(301.5,IVMPIEN,0))
"RTN","IVMPTRN9",35,0)
 . I $P(IVMPNODE,"^",8)!$P(IVMPNODE,"^",9)!$P(IVMPNODE,"^",10)!$P(IVMPNODE,"^",11) S DELETE("SET")=1
"RTN","IVMPTRN9",36,0)
 . ;was the MT deletion flag set, and if so verify that there is no completed MT
"RTN","IVMPTRN9",37,0)
 . I $P(IVMPNODE,"^",8),(TESTTYPE'=1)!(TESTCODE="")!("ACGP"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",8),DELETE("MT")=1
"RTN","IVMPTRN9",38,0)
 . ;
"RTN","IVMPTRN9",39,0)
 . ;was the hardship deletion flag set, and if so verify that there is no completed hardship
"RTN","IVMPTRN9",40,0)
 . I $P(IVMPNODE,"^",10),'HARDSHIP D
"RTN","IVMPTRN9",41,0)
 . . S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",10)
"RTN","IVMPTRN9",42,0)
 . . S DELETE("HARDSHIP")=1
"RTN","IVMPTRN9",43,0)
 ;
"RTN","IVMPTRN9",44,0)
 ; create (ZMT) Means Test segment 
"RTN","IVMPTRN9",45,0)
 ;
"RTN","IVMPTRN9",46,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",1:"1,17")
"RTN","IVMPTRN9",47,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,1,1,.DELETE,1)
"RTN","IVMPTRN9",48,0)
 ;
"RTN","IVMPTRN9",49,0)
 ; create (ZMT) Rx-Copay Test segment
"RTN","IVMPTRN9",50,0)
 I IVMPIEN D
"RTN","IVMPTRN9",51,0)
 . ;was the RX deletion flag set, and if so verify that there is no completed test
"RTN","IVMPTRN9",52,0)
 . I $P(IVMPNODE,"^",9),(TESTTYPE'=2)!(TESTCODE="")!("EM"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",9),DELETE("RX")=1
"RTN","IVMPTRN9",53,0)
 ;
"RTN","IVMPTRN9",54,0)
 N IVMCPDT,CPTST,LINK,CPDATE
"RTN","IVMPTRN9",55,0)
 ;should be ok to get the last co-pay test for this year vs. looking from the IVMMTDT backwards
"RTN","IVMPTRN9",56,0)
 ;as long as the means test date is in the current year
"RTN","IVMPTRN9",57,0)
 S CPTST=$$LST^DGMTU(DFN,$E(IVMIY,1,3)+1_1231,2)
"RTN","IVMPTRN9",58,0)
 I CPTST D
"RTN","IVMPTRN9",59,0)
 . S CPDATE=$P(CPTST,U,2)
"RTN","IVMPTRN9",60,0)
 . S LINK=$P($G(^DGMT(408.31,+CPTST,2)),U,6)
"RTN","IVMPTRN9",61,0)
 . I TESTTYPE=1,$E(CPDATE,1,3)=$E(IVMMTDT,1,3) D
"RTN","IVMPTRN9",62,0)
 . . ;if you have a means test and a linked co-pay test then send both (the means test
"RTN","IVMPTRN9",63,0)
 . . ;was already sent from above)
"RTN","IVMPTRN9",64,0)
 . . ;if means and copay are not linked, don't send the co-pay test (the means test
"RTN","IVMPTRN9",65,0)
 . . ;was already sent from above)
"RTN","IVMPTRN9",66,0)
 . . I LINK=+$$LST^DGMTU(DFN,IVMMTDT,1) S TESTTYPE=2,(IVMCPDT,IVMMTDT)=CPDATE
"RTN","IVMPTRN9",67,0)
 . . Q
"RTN","IVMPTRN9",68,0)
 . Q
"RTN","IVMPTRN9",69,0)
 ;always send the 2nd ZMT segment
"RTN","IVMPTRN9",70,0)
 S SEQS="1,17"
"RTN","IVMPTRN9",71,0)
 ;can also send a co-pay test if there is no means test (see module GETTYPE)
"RTN","IVMPTRN9",72,0)
 I TESTTYPE=2 D
"RTN","IVMPTRN9",73,0)
 . S SEQS="1,2,3,4,5,6,7,9,10,12,15,16,17,18,21,22,25,26,30"
"RTN","IVMPTRN9",74,0)
 . Q
"RTN","IVMPTRN9",75,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,2,2,.DELETE,1)
"RTN","IVMPTRN9",76,0)
 ;
"RTN","IVMPTRN9",77,0)
 ; create (ZMT) Long Term Care Copay Exemption Test segment
"RTN","IVMPTRN9",78,0)
 I IVMPIEN D
"RTN","IVMPTRN9",79,0)
 . ; set deletion indicators if LTC test deletion should be transmitted
"RTN","IVMPTRN9",80,0)
 . I $P(IVMPNODE,"^",11) S DELETE("LTC")=1 S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",11)
"RTN","IVMPTRN9",81,0)
 ;
"RTN","IVMPTRN9",82,0)
 S SEQS="1,2,3,4,5,7,9,10,12,16,17,18,22,25,30"
"RTN","IVMPTRN9",83,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,4,4,.DELETE,1)
"RTN","IVMPTRN9",84,0)
 ;
"RTN","IVMPTRN9",85,0)
 ;if the deletion flags were set in the IVM Patient file, unset them
"RTN","IVMPTRN9",86,0)
 I $G(DELETE("SET")) D
"RTN","IVMPTRN9",87,0)
 . N DATA
"RTN","IVMPTRN9",88,0)
 . S DATA(.08)="",DATA(.09)="",DATA(.1)="",DATA(.11)=""
"RTN","IVMPTRN9",89,0)
 . I $$UPD^DGENDBS(301.5,IVMPIEN,.DATA)
"RTN","IVMPTRN9",90,0)
 ;
"RTN","IVMPTRN9",91,0)
 ; create (ZBT) Beneficiary Travel segment based on last BT Claim
"RTN","IVMPTRN9",92,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZBT($$BTCLM^IVMUFNC4(DFN),"1,2,3,4,7")
"RTN","IVMPTRN9",93,0)
 ;
"RTN","IVMPTRN9",94,0)
 ; create (ZFE) Fee Basis segment(s)
"RTN","IVMPTRN9",95,0)
 D EN^FBHLZFE(DFN,"1,2,3,4,5")
"RTN","IVMPTRN9",96,0)
 F IVMSUB=0:0 S IVMSUB=+$O(FBZFE(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",97,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(FBZFE(+IVMSUB))
"RTN","IVMPTRN9",98,0)
 ;
"RTN","IVMPTRN9",99,0)
 ; create (ZSP) Service Period segment
"RTN","IVMPTRN9",100,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZSP(DFN,1,1)
"RTN","IVMPTRN9",101,0)
 ;
"RTN","IVMPTRN9",102,0)
 ; optionally create (OBX) segment for Patient Sensitivity Flag
"RTN","IVMPTRN9",103,0)
 K OBXTMP
"RTN","IVMPTRN9",104,0)
 S OBXCNT=0,GETCUR=$$FINDSEC^DGENSEC(DFN)
"RTN","IVMPTRN9",105,0)
 I GETCUR,$$GET^DGENSEC(GETCUR,.DGSEC) D
"RTN","IVMPTRN9",106,0)
 . Q:(DGSEC("LEVEL")'=1)&(DGSEC("LEVEL")'=0)
"RTN","IVMPTRN9",107,0)
 . S OBXTMP(2)="CE",OBXTMP(3)="38.1"_$E(HL("ECH"))_"SECURITY LOG"
"RTN","IVMPTRN9",108,0)
 . S:DGSEC("LEVEL") OBXTMP(5)="Y"_$E(HL("ECH"))_"YES"_$E(HL("ECH"))_"HL70136"
"RTN","IVMPTRN9",109,0)
 . S:'DGSEC("LEVEL") OBXTMP(5)="N"_$E(HL("ECH"))_"NO"_$E(HL("ECH"))_"HL70136"
"RTN","IVMPTRN9",110,0)
 . S OBXTMP(11)="R",OBXTMP(14)=DGSEC("DATETIME")
"RTN","IVMPTRN9",111,0)
 . S OBXTMP(16)="" I $G(DGSEC("SOURCE"))'="" D
"RTN","IVMPTRN9",112,0)
 . . S $P(OBXTMP(16),$E(HL("ECH")),14)=$E(HL("ECH"),4)_DGSEC("SOURCE")
"RTN","IVMPTRN9",113,0)
 . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
"RTN","IVMPTRN9",114,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.OBXTMP,OBXCNT,"2,3,5,11,14,16")
"RTN","IVMPTRN9",115,0)
 . I $G(OBXTMP(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(OBXTMP(16))
"RTN","IVMPTRN9",116,0)
 ;
"RTN","IVMPTRN9",117,0)
 ; create (OBX) segment for NTR
"RTN","IVMPTRN9",118,0)
 ; CALL PIMS API TO GET NTRARRY OF NTR DATA
"RTN","IVMPTRN9",119,0)
 S GETCUR=$$ENRGET^DGNTAPI1(DFN)
"RTN","IVMPTRN9",120,0)
 I GETCUR D NTROBX^IVMPTRNA(.DGNTARR)
"RTN","IVMPTRN9",121,0)
 I $D(NTROBX) D
"RTN","IVMPTRN9",122,0)
 . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
"RTN","IVMPTRN9",123,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.NTROBX,OBXCNT,"2,3,5,11,12,14,15,16,17")
"RTN","IVMPTRN9",124,0)
 . I $G(NTROBX(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(NTROBX(16))
"RTN","IVMPTRN9",125,0)
 . K NTROBX
"RTN","IVMPTRN9",126,0)
 ;
"RTN","IVMPTRN9",127,0)
 ; create (RF1) segment
"RTN","IVMPTRN9",128,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$RF1^IVMPTRNA(DFN,"SAD")
"RTN","IVMPTRN9",129,0)
 F RF1TYP="CAD","CPH","PNO","EAD","PHH" D   ;Create Optional RF1 Segments
"RTN","IVMPTRN9",130,0)
 . S RF1SEG=$$RF1^IVMPTRNA(DFN,RF1TYP) Q:RF1SEG=""
"RTN","IVMPTRN9",131,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=RF1SEG
"RTN","IVMPTRN9",132,0)
 ;
"RTN","IVMPTRN9",133,0)
 Q
"RTN","IVMPTRN9",134,0)
 ;
"RTN","IVMPTRN9",135,0)
GETTYPE(DFN,IVMMTDT,CODE,HARDSHIP,ACTVIEN)      ;
"RTN","IVMPTRN9",136,0)
 ;Determines the type of test to include in the Z10.  HEC wants only the
"RTN","IVMPTRN9",137,0)
 ;test that they would consider primary,i.e., preference given to a comptleted means test, even if not currently in effect.
"RTN","IVMPTRN9",138,0)
 ;
"RTN","IVMPTRN9",139,0)
 ;Input:
"RTN","IVMPTRN9",140,0)
 ;  DFN
"RTN","IVMPTRN9",141,0)
 ;  IVMMTDT -date to be the search for the test
"RTN","IVMPTRN9",142,0)
 ;Output:
"RTN","IVMPTRN9",143,0)
 ;  Function value - type of test to send in Z10
"RTN","IVMPTRN9",144,0)
 ;  CODE - status code of test (pass by reference)
"RTN","IVMPTRN9",145,0)
 ;  HARDSHIP - hardship indicator (pass by reference)
"RTN","IVMPTRN9",146,0)
 ;  ACTVIEN - ien of test that should have the associated Income Relations (pass by reference)
"RTN","IVMPTRN9",147,0)
 ;
"RTN","IVMPTRN9",148,0)
 N TESTTYPE,MTNODE,RXNODE,NODE0,NODE2
"RTN","IVMPTRN9",149,0)
 S TESTTYPE=1
"RTN","IVMPTRN9",150,0)
 S (HARDSHIP,CODE,ACTVIEN)=""
"RTN","IVMPTRN9",151,0)
 Q:'$G(IVMMTDT) TESTTYPE
"RTN","IVMPTRN9",152,0)
 Q:'$G(DFN) TESTTYPE
"RTN","IVMPTRN9",153,0)
 ;
"RTN","IVMPTRN9",154,0)
 S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
"RTN","IVMPTRN9",155,0)
 S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
"RTN","IVMPTRN9",156,0)
 ;
"RTN","IVMPTRN9",157,0)
 I MTNODE="" S MTNODE=$$FUT^DGMTU(DFN,"",1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
"RTN","IVMPTRN9",158,0)
 I RXNODE="" S RXNODE=$$FUT^DGMTU(DFN,"",2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
"RTN","IVMPTRN9",159,0)
 D
"RTN","IVMPTRN9",160,0)
 . ;determine which test has the associated income relations
"RTN","IVMPTRN9",161,0)
 . ;
"RTN","IVMPTRN9",162,0)
 . I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
"RTN","IVMPTRN9",163,0)
 . I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
"RTN","IVMPTRN9",164,0)
 . I +MTNODE S ACTVIEN=+MTNODE Q
"RTN","IVMPTRN9",165,0)
 . I +RXNODE S ACTVIEN=+RXNODE Q
"RTN","IVMPTRN9",166,0)
 I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
"RTN","IVMPTRN9",167,0)
 ;
"RTN","IVMPTRN9",168,0)
 ;now find the primary test
"RTN","IVMPTRN9",169,0)
 I '(+MTNODE) G CHKCOPAY
"RTN","IVMPTRN9",170,0)
 S CODE=$P(MTNODE,"^",4)
"RTN","IVMPTRN9",171,0)
 S HARDSHIP=$P($G(^DGMT(408.31,+MTNODE,0)),"^",20)
"RTN","IVMPTRN9",172,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",173,0)
 ;
"RTN","IVMPTRN9",174,0)
 G QGETTYPE
"RTN","IVMPTRN9",175,0)
 ;
"RTN","IVMPTRN9",176,0)
CHKCOPAY        ;
"RTN","IVMPTRN9",177,0)
 I '(+RXNODE) G QGETTYPE
"RTN","IVMPTRN9",178,0)
 S CODE=$P(RXNODE,"^",4)
"RTN","IVMPTRN9",179,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",180,0)
 S TESTTYPE=2
"RTN","IVMPTRN9",181,0)
 ;
"RTN","IVMPTRN9",182,0)
QGETTYPE        ;
"RTN","IVMPTRN9",183,0)
 Q TESTTYPE
"RTN","IVMPTRN9",184,0)
 ;
"RTN","IVMPTRN9",185,0)
FILTER(DFN)     ; address transmission filter
"RTN","IVMPTRN9",186,0)
 ; Check Bad Address Indicator for a known bad address and
"RTN","IVMPTRN9",187,0)
 ; Scrutinize the Street Address line 1 field for known bad address
"RTN","IVMPTRN9",188,0)
 ; strings based on functionality currently in place in HEC Legacy.
"RTN","IVMPTRN9",189,0)
 ;
"RTN","IVMPTRN9",190,0)
 ;  Input: DFN - ien of the Patient (#2) file
"RTN","IVMPTRN9",191,0)
 ; Output:   0 - filter passed (ok to transmit address)
"RTN","IVMPTRN9",192,0)
 ;           1 - filter failed (do not transmit address)
"RTN","IVMPTRN9",193,0)
 ;
"RTN","IVMPTRN9",194,0)
 N VAPA
"RTN","IVMPTRN9",195,0)
 Q:'$G(DFN) 1  ;DFN missing
"RTN","IVMPTRN9",196,0)
 Q:$$BADADR^DGUTL3(DFN) 1  ;check Bad Address Indicator
"RTN","IVMPTRN9",197,0)
 D ADD^VADPT  ;get patient address
"RTN","IVMPTRN9",198,0)
 ; Street Address Line 1 or Zip Code is <null>
"RTN","IVMPTRN9",199,0)
 Q:($G(VAPA(1))="")!($P($G(VAPA(11)),"^")="") 1
"RTN","IVMPTRN9",200,0)
 ; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or 'ADDRESS'
"RTN","IVMPTRN9",201,0)
 Q:(VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)["ADDRESS") 1
"RTN","IVMPTRN9",202,0)
 ; The first two characters of the address is equal to '**'
"RTN","IVMPTRN9",203,0)
 Q:$E(VAPA(1),1,2)="**" 1
"RTN","IVMPTRN9",204,0)
 ; passed all address filters - ok to send
"RTN","IVMPTRN9",205,0)
 Q 0
"RTN","IVMPTRNA")
0^2^B15638011
"RTN","IVMPTRNA",1,0)
IVMPTRNA ;ALB/CKN/BRM,TDM,LBD - HL7 FULL DATA TRANSMISSION (Z07) BUILDER(CONTINUED);30 AUG 2001 ; 2/7/12 3:01pm
"RTN","IVMPTRNA",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**46,58,76,105,152**; 21-OCT-94;Build 4
"RTN","IVMPTRNA",3,0)
 Q
"RTN","IVMPTRNA",4,0)
NTROBX(DGNTARR) ;
"RTN","IVMPTRNA",5,0)
 N NTRTEMP,I,CS,RS,SS
"RTN","IVMPTRNA",6,0)
 I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
"RTN","IVMPTRNA",7,0)
 I $G(HLFS)'="^" N HLFS S HLFS="^"
"RTN","IVMPTRNA",8,0)
 S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
"RTN","IVMPTRNA",9,0)
 S NTRTEMP("NTR","Y")="1"_CS_"Received NTR Trmt"_CS_"VA0053"
"RTN","IVMPTRNA",10,0)
 S NTRTEMP("AVI","Y")="2"_CS_"Aviator Pre 1955"_CS_"VA0053"
"RTN","IVMPTRNA",11,0)
 S NTRTEMP("SUB","Y")="3"_CS_"Sub Trainee pre 1965"_CS_"VA0053"
"RTN","IVMPTRNA",12,0)
 S NTRTEMP("HNC","Y")="4"_CS_"Dx With Head Neck Cancer"_CS_"VA0053"
"RTN","IVMPTRNA",13,0)
 S NTRTEMP("NTR","N")="5"_CS_"No NTR Trmt"_CS_"VA0053"
"RTN","IVMPTRNA",14,0)
 S NTRTEMP("AVI","N")="6"_CS_"Not Aviator Pre 1955"_CS_"VA0053"
"RTN","IVMPTRNA",15,0)
 S NTRTEMP("SUB","N")="7"_CS_"Not Sub Trainee pre 1965"_CS_"VA0053"
"RTN","IVMPTRNA",16,0)
 S NTRTEMP("HNC","N")="8"_CS_"Not Dx With Head Neck Cancer"_CS_"VA0053"
"RTN","IVMPTRNA",17,0)
 S NTRTEMP("NTR","U")="9"_CS_"NTR Trmt Unknown"_CS_"VA0053"
"RTN","IVMPTRNA",18,0)
 S NTRTEMP("VER","M")="M"_CS_"Military Med Rec"_CS_"VA0052"
"RTN","IVMPTRNA",19,0)
 S NTRTEMP("VER","S")="S"_CS_"Qual Military Srvc"_CS_"VA0052"
"RTN","IVMPTRNA",20,0)
 S NTRTEMP("VER","N")="N"_CS_"Not Qualified"_CS_"VA0052"
"RTN","IVMPTRNA",21,0)
 S NTROBX(2)="CE",NTROBX(3)="VISTA"_CS_"28.11"
"RTN","IVMPTRNA",22,0)
 S NTROBX(5)=""
"RTN","IVMPTRNA",23,0)
 F I="NTR","AVI","SUB","HNC" D
"RTN","IVMPTRNA",24,0)
 . I $G(DGNTARR(I))="" Q
"RTN","IVMPTRNA",25,0)
 . I NTROBX(5)'="" S NTROBX(5)=$G(NTROBX(5))_RS
"RTN","IVMPTRNA",26,0)
 . S NTROBX(5)=$G(NTROBX(5))_$G(NTRTEMP(I,$G(DGNTARR(I))))
"RTN","IVMPTRNA",27,0)
 S NTROBX(11)="F"
"RTN","IVMPTRNA",28,0)
 S NTROBX(12)=$G(DGNTARR("HDT"))
"RTN","IVMPTRNA",29,0)
 S NTROBX(14)=$G(DGNTARR("VDT"))
"RTN","IVMPTRNA",30,0)
 I $G(DGNTARR("VSIT"))'="" D
"RTN","IVMPTRNA",31,0)
 . S NTROBX(15)=$P($G(^DIC(4,DGNTARR("VSIT"),99)),"^")
"RTN","IVMPTRNA",32,0)
 S NTROBX(16)=""
"RTN","IVMPTRNA",33,0)
 I $G(DGNTARR("HSIT"))'="" D
"RTN","IVMPTRNA",34,0)
 . S $P(NTROBX(16),CS,14)=SS_$P($G(^DIC(4,DGNTARR("HSIT"),99)),"^")
"RTN","IVMPTRNA",35,0)
 I $G(DGNTARR("VER"))'="" S NTROBX(17)=$G(NTRTEMP("VER",$G(DGNTARR("VER"))))
"RTN","IVMPTRNA",36,0)
 Q
"RTN","IVMPTRNA",37,0)
RF1(DFN,RF1TYP) ; create RF1 segment
"RTN","IVMPTRNA",38,0)
 ;  Input:
"RTN","IVMPTRNA",39,0)
 ;        DFN - Patient IEN
"RTN","IVMPTRNA",40,0)
 ;     RF1TYP - RF1 Type
"RTN","IVMPTRNA",41,0)
 ;              SAD = Street Address Change (Default)
"RTN","IVMPTRNA",42,0)
 ;              CAD = Confidential Address Change
"RTN","IVMPTRNA",43,0)
 ;              CPH = Cell Phone Number Change
"RTN","IVMPTRNA",44,0)
 ;              PNO = Pager Number Change
"RTN","IVMPTRNA",45,0)
 ;              EAD = E-Mail Address Change
"RTN","IVMPTRNA",46,0)
 ;              PHH = Home Phone Number Change
"RTN","IVMPTRNA",47,0)
 ;
"RTN","IVMPTRNA",48,0)
 ;  Output: RF1 segment
"RTN","IVMPTRNA",49,0)
 ;
"RTN","IVMPTRNA",50,0)
 N X,Y,ADDRSRC,ADRSRC,ADRSIT,ADTDT,I,CS,RS,SS,HLQ,RETURN,RFDAT,ERR
"RTN","IVMPTRNA",51,0)
 I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
"RTN","IVMPTRNA",52,0)
 I $G(HLFS)'="^" N HLFS S HLFS="^"
"RTN","IVMPTRNA",53,0)
 S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2),HLQ=""""
"RTN","IVMPTRNA",54,0)
 S:$G(RF1TYP)="" RF1TYP="SAD"   ;Set type to 'SAD' if no value passed
"RTN","IVMPTRNA",55,0)
 ; initialize the RETURN variable
"RTN","IVMPTRNA",56,0)
 S RETURN="RF1",$P(RETURN,HLFS,4)=RF1TYP,$P(RETURN,HLFS,11)=""
"RTN","IVMPTRNA",57,0)
 Q:'$G(DFN) RETURN
"RTN","IVMPTRNA",58,0)
 ;I RF1TYP="SAD",$$BADADR^DGUTL3(DFN) Q RETURN
"RTN","IVMPTRNA",59,0)
 D RF1LOAD(RF1TYP) Q:$D(ERR) RETURN
"RTN","IVMPTRNA",60,0)
 I RF1TYP'="SAD",$G(ADRDT)="" Q ""
"RTN","IVMPTRNA",61,0)
 ; RF1 SEQ 1-2 are not currently used
"RTN","IVMPTRNA",62,0)
 ; RF1 SEQ 3
"RTN","IVMPTRNA",63,0)
 S $P(RETURN,HLFS,4)=RF1TYP
"RTN","IVMPTRNA",64,0)
 ; RF1 SEQ 4-5 are not currently used
"RTN","IVMPTRNA",65,0)
 ; RF1 SEQ 6
"RTN","IVMPTRNA",66,0)
 S $P(RETURN,HLFS,7)=$G(ADRSIT)
"RTN","IVMPTRNA",67,0)
 S:$G(ADRSRC)'="" $P(RETURN,HLFS,7)=$P(RETURN,HLFS,7)_CS_ADRSRC
"RTN","IVMPTRNA",68,0)
 ; RF1 SEQ 7
"RTN","IVMPTRNA",69,0)
 S $P(RETURN,HLFS,8)=$G(ADRDT)
"RTN","IVMPTRNA",70,0)
 ; RF1 SEQ 8-11 are not currently used
"RTN","IVMPTRNA",71,0)
 ; quit with completed RF1 segment
"RTN","IVMPTRNA",72,0)
 Q RETURN
"RTN","IVMPTRNA",73,0)
 ;
"RTN","IVMPTRNA",74,0)
ADDRCNV(ADDRSRC) ;convert Address Source to HL7 format
"RTN","IVMPTRNA",75,0)
 Q:$G(ADDRSRC)']"" ""
"RTN","IVMPTRNA",76,0)
 Q:ADDRSRC="HEC" "USVAHEC"
"RTN","IVMPTRNA",77,0)
 Q:ADDRSRC="VAMC" "USVAMC"
"RTN","IVMPTRNA",78,0)
 Q:ADDRSRC="HBSC" "USVAHBSC"
"RTN","IVMPTRNA",79,0)
 Q:ADDRSRC="NCOA" "USNCOA"
"RTN","IVMPTRNA",80,0)
 Q:ADDRSRC="BVA" "USVABVA"
"RTN","IVMPTRNA",81,0)
 Q:ADDRSRC="VAINS" "USVAINS"
"RTN","IVMPTRNA",82,0)
 Q:ADDRSRC="USPS" "USPS"
"RTN","IVMPTRNA",83,0)
 Q:ADDRSRC="LACS" "LACS"
"RTN","IVMPTRNA",84,0)
 Q ""
"RTN","IVMPTRNA",85,0)
 ;
"RTN","IVMPTRNA",86,0)
RF1LOAD(RF1TYP) ;
"RTN","IVMPTRNA",87,0)
 N RFDT,RFSRC,RFSIT,GETFLDS,RFDAT,ERR
"RTN","IVMPTRNA",88,0)
 K ADRDT,ADRSRC,ADRSIT
"RTN","IVMPTRNA",89,0)
 I RF1TYP="SAD" S RFDT=.118,RFSRC=.119,RFSIT=.12
"RTN","IVMPTRNA",90,0)
 I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14113
"RTN","IVMPTRNA",91,0)
 I RF1TYP="CPH" S RFDT=.139,RFSRC=.1311,RFSIT=.13111
"RTN","IVMPTRNA",92,0)
 I RF1TYP="PNO" S RFDT=.1312,RFSRC=.1313,RFSIT=.1314
"RTN","IVMPTRNA",93,0)
 I RF1TYP="EAD" S RFDT=.136,RFSRC=.137,RFSIT=.138
"RTN","IVMPTRNA",94,0)
 I RF1TYP="PHH" S RFDT=.1321,RFSRC=.1322,RFSIT=.1323
"RTN","IVMPTRNA",95,0)
 S GETFLDS=RFDT S:RFSRC'="" GETFLDS=GETFLDS_";"_RFSRC S GETFLDS=GETFLDS_";"_RFSIT
"RTN","IVMPTRNA",96,0)
 D GETS^DIQ(2,DFN_",",GETFLDS,"IE","RFDAT","ERR") Q:$D(ERR)
"RTN","IVMPTRNA",97,0)
 S ADRDT=$$FMTHL7^XLFDT($G(RFDAT(2,DFN_",",RFDT,"I")))
"RTN","IVMPTRNA",98,0)
 S:RFSRC'="" ADRSRC=$$EXTERNAL^DILFD(2,RFSRC,"",$G(RFDAT(2,DFN_",",RFSRC,"I")))
"RTN","IVMPTRNA",99,0)
 ; only populate Change Site if Source=VAMC or NO Source Field
"RTN","IVMPTRNA",100,0)
 I ($G(ADRSRC)="VAMC")!(RFSRC="") D
"RTN","IVMPTRNA",101,0)
 . S ADRSIT=$G(RFDAT(2,DFN_",",RFSIT,"I"))
"RTN","IVMPTRNA",102,0)
 . S:ADRSIT]"" ADRSIT=$$GET1^DIQ(4,ADRSIT_",",99)
"RTN","IVMPTRNA",103,0)
 S ADRSRC=$$ADDRCNV($G(ADRSRC))  ;convert source to HL7 format
"RTN","IVMPTRNA",104,0)
 Q
"VER")
8.0^22.0
**END**
**END**