DG_53_P935.KIDs

KIDS Distribution saved on Nov 06, 2017@11:05:45
Enrollment System Modernization Build
**KIDS**:DG*5.3*935^IVM*2.0*167^

**INSTALL NAME**
DG*5.3*935
"BLD",9964,0)
DG*5.3*935^REGISTRATION^0^3171106^y
"BLD",9964,1,0)
^^2^2^3171031^^^
"BLD",9964,1,1,0)
Enrollment System Modernization Project VistA DG_53_P935.KID Build
"BLD",9964,1,2,0)
enhancements; see the patch description for more information.
"BLD",9964,4,0)
^9.64PA^2^1
"BLD",9964,4,2,0)
2
"BLD",9964,4,2,2,0)
^9.641^2.3216^1
"BLD",9964,4,2,2,2.3216,0)
MILITARY SERVICE EPISODE  (sub-file)
"BLD",9964,4,2,2,2.3216,1,0)
^9.6411^.08^1
"BLD",9964,4,2,2,2.3216,1,.08,0)
FUTURE DISCHARGE DATE
"BLD",9964,4,2,222)
y^y^p^^^^n^^n
"BLD",9964,4,2,224)

"BLD",9964,4,25.11,2,25.11,1,.01,0)
NAME 
"BLD",9964,4,"APDD",2,2.3216)

"BLD",9964,4,"APDD",2,2.3216,.08)

"BLD",9964,4,"APDD",25.11,25.11,.01)

"BLD",9964,4,"B",2,2)

"BLD",9964,6.3)
53
"BLD",9964,"ABPKG")
n
"BLD",9964,"INID")
^
"BLD",9964,"INIT")
POST^DG53P935
"BLD",9964,"KRN",0)
^9.67PA^779.2^20
"BLD",9964,"KRN",.4,0)
.4
"BLD",9964,"KRN",.4,"NM",0)
^9.68A^^
"BLD",9964,"KRN",.401,0)
.401
"BLD",9964,"KRN",.401,"NM",0)
^9.68A^^
"BLD",9964,"KRN",.402,0)
.402
"BLD",9964,"KRN",.402,"NM",0)
^9.68A^^
"BLD",9964,"KRN",.403,0)
.403
"BLD",9964,"KRN",.403,"NM",0)
^9.68A^^
"BLD",9964,"KRN",.5,0)
.5
"BLD",9964,"KRN",.5,"NM",0)
^9.68A^^
"BLD",9964,"KRN",.84,0)
.84
"BLD",9964,"KRN",.84,"NM",0)
^9.68A^^
"BLD",9964,"KRN",3.6,0)
3.6
"BLD",9964,"KRN",3.6,"NM",0)
^9.68A^^
"BLD",9964,"KRN",3.8,0)
3.8
"BLD",9964,"KRN",3.8,"NM",0)
^9.68A^^
"BLD",9964,"KRN",9.2,0)
9.2
"BLD",9964,"KRN",9.2,"NM",0)
^9.68A^^
"BLD",9964,"KRN",9.8,0)
9.8
"BLD",9964,"KRN",9.8,"NM",0)
^9.68A^14^12
"BLD",9964,"KRN",9.8,"NM",1,0)
DGRPU^^0^B88766469
"BLD",9964,"KRN",9.8,"NM",2,0)
DGRPD1^^0^B7682498
"BLD",9964,"KRN",9.8,"NM",3,0)
DGRPCF^^0^B26225283
"BLD",9964,"KRN",9.8,"NM",5,0)
DGENUPL3^^0^B89567535
"BLD",9964,"KRN",9.8,"NM",6,0)
DGMSEUTL^^0^B17883475
"BLD",9964,"KRN",9.8,"NM",7,0)
DGENUPL1^^0^B54858665
"BLD",9964,"KRN",9.8,"NM",8,0)
DGRP61^^0^B57864374
"BLD",9964,"KRN",9.8,"NM",9,0)
VAFHLZM2^^0^B11134578
"BLD",9964,"KRN",9.8,"NM",10,0)
VADPT4^^0^B43698033
"BLD",9964,"KRN",9.8,"NM",11,0)
DGRPMS^^0^B68853041
"BLD",9964,"KRN",9.8,"NM",13,0)
DGNOZMH^^0^B1893168
"BLD",9964,"KRN",9.8,"NM",14,0)
VAFHLZMH^^0^B31266014
"BLD",9964,"KRN",9.8,"NM","B","DGENUPL1",7)

"BLD",9964,"KRN",9.8,"NM","B","DGENUPL3",5)

"BLD",9964,"KRN",9.8,"NM","B","DGMSEUTL",6)

"BLD",9964,"KRN",9.8,"NM","B","DGNOZMH",13)

"BLD",9964,"KRN",9.8,"NM","B","DGRP61",8)

"BLD",9964,"KRN",9.8,"NM","B","DGRPCF",3)

"BLD",9964,"KRN",9.8,"NM","B","DGRPD1",2)

"BLD",9964,"KRN",9.8,"NM","B","DGRPMS",11)

"BLD",9964,"KRN",9.8,"NM","B","DGRPU",1)

"BLD",9964,"KRN",9.8,"NM","B","VADPT4",10)

"BLD",9964,"KRN",9.8,"NM","B","VAFHLZM2",9)

"BLD",9964,"KRN",9.8,"NM","B","VAFHLZMH",14)

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

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

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

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

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

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

"BLD",9964,"KRN","B",3.6,3.6)

"BLD",9964,"KRN","B",3.8,3.8)

"BLD",9964,"KRN","B",9.2,9.2)

"BLD",9964,"KRN","B",9.8,9.8)

"BLD",9964,"KRN","B",19,19)

"BLD",9964,"KRN","B",19.1,19.1)

"BLD",9964,"KRN","B",101,101)

"BLD",9964,"KRN","B",409.61,409.61)

"BLD",9964,"KRN","B",771,771)

"BLD",9964,"KRN","B",779.2,779.2)

"BLD",9964,"KRN","B",870,870)

"BLD",9964,"KRN","B",8989.51,8989.51)

"BLD",9964,"KRN","B",8989.52,8989.52)

"BLD",9964,"KRN","B",8994,8994)

"BLD",9964,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9964,"QUES",0)
^9.62^^
"BLD",9964,"REQB",0)
^9.611^6^6
"BLD",9964,"REQB",1,0)
DG*5.3*863^1
"BLD",9964,"REQB",2,0)
DG*5.3*867^1
"BLD",9964,"REQB",3,0)
DG*5.3*936^1
"BLD",9964,"REQB",4,0)
DG*5.3*909^1
"BLD",9964,"REQB",5,0)
DG*5.3*928^1
"BLD",9964,"REQB",6,0)
DG*5.3*871^1
"BLD",9964,"REQB","B","DG*5.3*863",1)

"BLD",9964,"REQB","B","DG*5.3*867",2)

"BLD",9964,"REQB","B","DG*5.3*871",6)

"BLD",9964,"REQB","B","DG*5.3*909",4)

"BLD",9964,"REQB","B","DG*5.3*928",5)

"BLD",9964,"REQB","B","DG*5.3*936",3)

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

"FIA",2,0,11)

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

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

"FIA",25.11)
HEALTH BENEFIT PLAN
"FIA",25.11,0)
^DGHBP(25.11,
"FIA",25.11,0,0)
25.11I
"FIA",25.11,0,1)
^^f
"FIA",25.11,0,10)

"FIA",25.11,0,11)

"FIA",25.11,0,"RLRO")

"FIA",25.11,0,"VR")
5.3^DG
"FIA",25.11,25.11)
0
"FIA",25.11,25.13)
0
"FIA",25.11,25.14)
0
"INIT")
POST^DG53P935
"IX",25.11,25.11,"B",0)
25.11^B^Contains all the Health Benefit Plans in alphabetical order.^R^^F^IR^I^25.11^^^^^LS
"IX",25.11,25.11,"B",1)
S ^DGHBP(25.11,"B",$E(X,1,64),DA)=""
"IX",25.11,25.11,"B",2)
K ^DGHBP(25.11,"B",$E(X,1,64),DA)
"IX",25.11,25.11,"B",2.5)
K ^DGHBP(25.11,"B")
"IX",25.11,25.11,"B",11.1,0)
^.114IA^1^1
"IX",25.11,25.11,"B",11.1,1,0)
1^F^25.11^.01^64^1^F
"IX",25.11,25.11,"B",11.1,1,3)

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

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
YES
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
13
"RTN","DG53P935")
0^^B4540001
"RTN","DG53P935",1,0)
DG53P935 ;ALB/KUM - DG*5.3*935 POST INSTALL ;8/30/17 9:18am
"RTN","DG53P935",2,0)
 ;;5.3;Registration;**935**;Aug 13, 1993;Build 53
"RTN","DG53P935",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","DG53P935",4,0)
 ;
"RTN","DG53P935",5,0)
 ; DG*5.3*935 Post Install routine to correct Veteran Plan - Veterans Choice Wait Time
"RTN","DG53P935",6,0)
 ;  Integration Agreements:
"RTN","DG53P935",7,0)
 ;        10141 : BMES^XPDUTL
"RTN","DG53P935",8,0)
 ;              : MES^XPDUTL
"RTN","DG53P935",9,0)
 ;        2053  : FILE^DIE
"RTN","DG53P935",10,0)
 ;        2051  : FIND1^DIC
"RTN","DG53P935",11,0)
 ;
"RTN","DG53P935",12,0)
 Q
"RTN","DG53P935",13,0)
 ;
"RTN","DG53P935",14,0)
POST ;Update Health Benefit Plan
"RTN","DG53P935",15,0)
 ;
"RTN","DG53P935",16,0)
 D BMES^XPDUTL("    Checking Entry in HEALTH BENEFIT PLAN File - Veteran Plan - Veterans Choice Wait Time   ")
"RTN","DG53P935",17,0)
 D UPDREQ
"RTN","DG53P935",18,0)
 Q
"RTN","DG53P935",19,0)
 ;
"RTN","DG53P935",20,0)
UPDREQ ; Update entry in the HEALTH BENEFIT PLAN File (25.11)
"RTN","DG53P935",21,0)
 ;
"RTN","DG53P935",22,0)
 N IEN,ERR,NAME,FDA,IEN1,NAME1
"RTN","DG53P935",23,0)
 S ERR=""
"RTN","DG53P935",24,0)
 S NAME="Veteran Plan - Veterans Choice Wait Time"
"RTN","DG53P935",25,0)
 ; Check if entry exists, use it if it does
"RTN","DG53P935",26,0)
 S IEN=$$FIND1^DIC(25.11,,"B",NAME)
"RTN","DG53P935",27,0)
 I 'IEN D BMES^XPDUTL("    "_NAME_" does not exist, no action is taken.  ") Q
"RTN","DG53P935",28,0)
 L +^DGHBP(25.11,IEN):10 I '$T D BMES^XPDUTL("    "_NAME_" is locked by another user. Try later.   ") Q
"RTN","DG53P935",29,0)
 S IEN1=IEN
"RTN","DG53P935",30,0)
 S IEN=IEN_","
"RTN","DG53P935",31,0)
 ;
"RTN","DG53P935",32,0)
 S FDA(25.11,IEN,.01)="Veteran Plan - Veterans Choice Wait-Time"
"RTN","DG53P935",33,0)
  ; file new Address Change Date/Time
"RTN","DG53P935",34,0)
 ;
"RTN","DG53P935",35,0)
 D FILE^DIE("E","FDA","ERR")
"RTN","DG53P935",36,0)
 L -^DGHBP(25.11,IEN1)
"RTN","DG53P935",37,0)
 I ERR'="" D
"RTN","DG53P935",38,0)
 . D BMES^XPDUTL("     *** An Error occurred during updating Plan: Veteran Plan - Veterans Choice Wait Time")
"RTN","DG53P935",39,0)
 . D MES^XPDUTL("     Please log CA SDM ticket.")
"RTN","DG53P935",40,0)
 . Q
"RTN","DG53P935",41,0)
 ;
"RTN","DG53P935",42,0)
 I ERR="" D
"RTN","DG53P935",43,0)
 . S NAME1=$P(^DGHBP(25.11,IEN1,0),"^",1)
"RTN","DG53P935",44,0)
 . D BMES^XPDUTL("    "_NAME_" is corrected in HEALTH BENEFIT PLAN File to "_NAME1_".")
"RTN","DG53P935",45,0)
 Q
"RTN","DG53P935",46,0)
 ;
"RTN","DGENUPL1")
0^7^B54858665
"RTN","DGENUPL1",1,0)
DGENUPL1 ;ALB/CJM,ISA,KWP,CKN,LBD,LMD,TDM,TGH,DJS - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;30 Oct 2017  7:32PM
"RTN","DGENUPL1",2,0)
 ;;5.3;REGISTRATION;**147,222,232,314,397,379,407,363,673,653,688,797,842,894,871,935**;Aug 13,1993;Build 53
"RTN","DGENUPL1",3,0)
 ;
"RTN","DGENUPL1",4,0)
PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE,DGHBP) ;
"RTN","DGENUPL1",5,0)
 ;
"RTN","DGENUPL1",6,0)
 ;Description:  This function parses the HL7 segments.  It creates arrays
"RTN","DGENUPL1",7,0)
 ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY,
"RTN","DGENUPL1",8,0)
 ;OEF/OIF CONFLICT objects.
"RTN","DGENUPL1",9,0)
 ;Field values are put in DHCP format and the validity at the
"RTN","DGENUPL1",10,0)
 ;field level is tested.  Fields to be deleted are set to "@".
"RTN","DGENUPL1",11,0)
 ;
"RTN","DGENUPL1",12,0)
 ;Input:
"RTN","DGENUPL1",13,0)
 ;  MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772)
"RTN","DGENUPL1",14,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",15,0)
 ;  CURLINE - the subscript of the PID segment of the current message (pass by reference)
"RTN","DGENUPL1",16,0)
 ;  ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref)
"RTN","DGENUPL1",17,0)
 ;
"RTN","DGENUPL1",18,0)
 ;Output:
"RTN","DGENUPL1",19,0)
 ;  Function Value: Returns 1 on success, 0 on failure.
"RTN","DGENUPL1",20,0)
 ;  CURLINE - upon leaving the procedure this parameter should be set to the end of the current message.
"RTN","DGENUPL1",21,0)
 ;  ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref)
"RTN","DGENUPL1",22,0)
 ;  DGPAT - array defined by the PATIENT object. (pass by ref)
"RTN","DGENUPL1",23,0)
 ;  DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref)
"RTN","DGENUPL1",24,0)
 ;  DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref)
"RTN","DGENUPL1",25,0)
 ;  DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref)
"RTN","DGENUPL1",26,0)
 ;  DGSEC - array defined by the PATIENT SECURITY object. (pass by ref)
"RTN","DGENUPL1",27,0)
 ;  DGOEIF - array defined by the OEF/OIF CONFLICT object.  (pass by ref)
"RTN","DGENUPL1",28,0)
 ;  DGNTR - array defined for NTR data.
"RTN","DGENUPL1",29,0)
 ;  DGMST - array defined for MST data.
"RTN","DGENUPL1",30,0)
 ;  DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref)
"RTN","DGENUPL1",31,0)
 ;  DGHBP - array define for HEALTH BENEFIT PLAN data (pass by ref) DG*5.3*871
"RTN","DGENUPL1",32,0)
 ;
"RTN","DGENUPL1",33,0)
 N SEG,ERROR,COUNT,QFLG,NFLG
"RTN","DGENUPL1",34,0)
 ;
"RTN","DGENUPL1",35,0)
 ;DJS, Set TMP global to track the presence of ZMH segment; DG*5.3*935
"RTN","DGENUPL1",36,0)
 K ^TMP($J,"DGENUPL") S ^TMP($J,"DGENUPL","ZMH",0)=0
"RTN","DGENUPL1",37,0)
 ;
"RTN","DGENUPL1",38,0)
 K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST
"RTN","DGENUPL1",39,0)
 ;
"RTN","DGENUPL1",40,0)
 S ERROR=0,NFLG=1
"RTN","DGENUPL1",41,0)
 F SEG="PID","ZPD","ZIE","ZIO","ZEL"  D  Q:ERROR
"RTN","DGENUPL1",42,0)
 .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",43,0)
 .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q
"RTN","DGENUPL1",44,0)
 .I SEG("TYPE")=SEG D  Q
"RTN","DGENUPL1",45,0)
 ..I SEG'="ZEL" N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN      ; DG*5.3*894
"RTN","DGENUPL1",46,0)
 ..D:(SEG="ZEL") ZEL^DGENUPL2(1)
"RTN","DGENUPL1",47,0)
 ..S NFLG=1
"RTN","DGENUPL1",48,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",49,0)
 .S ERROR=1
"RTN","DGENUPL1",50,0)
 .;
"RTN","DGENUPL1",51,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",52,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",53,0)
 ;
"RTN","DGENUPL1",54,0)
 ;DJS, Set segment before processing possible multiple segments; DG*5.3*935
"RTN","DGENUPL1",55,0)
 I 'ERROR S SEG="ZEL" F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL")  D  Q:ERROR
"RTN","DGENUPL1",56,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",57,0)
 .D ZEL^DGENUPL2(COUNT)
"RTN","DGENUPL1",58,0)
 ;
"RTN","DGENUPL1",59,0)
 ;ZE2 is optional, If no ZE2 segment delete pension data
"RTN","DGENUPL1",60,0)
 I 'ERROR D
"RTN","DGENUPL1",61,0)
 .I SEG("TYPE")="ZE2" D ZE2^DGENUPLB S CURLINE=CURLINE+1 Q
"RTN","DGENUPL1",62,0)
 .I SEG("TYPE")'="ZE2" D
"RTN","DGENUPL1",63,0)
 ..Q:$$GET1^DIQ(2,DFN,.3852,"I")=$O(^DG(27.18,"C","00",""))
"RTN","DGENUPL1",64,0)
 ..N PSUB
"RTN","DGENUPL1",65,0)
 ..F PSUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S DGPAT(PSUB)="@"
"RTN","DGENUPL1",66,0)
 ;
"RTN","DGENUPL1",67,0)
 ;ZHP is optional & can repeat. DG*5.3*871
"RTN","DGENUPL1",68,0)
 K DGHBP
"RTN","DGENUPL1",69,0)
 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
"RTN","DGENUPL1",70,0)
 I 'ERROR S SEG="ZHP" I $$CHKNXT(CURLINE+1,SEG) D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",71,0)
 . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",72,0)
 . S QFLG=0 F  D  Q:QFLG
"RTN","DGENUPL1",73,0)
 . . I SEG("TYPE")'="ZHP" S QFLG=1,CURLINE=CURLINE-1 Q
"RTN","DGENUPL1",74,0)
 . . D ZHP^DGENUPLB
"RTN","DGENUPL1",75,0)
 . . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",76,0)
 ;
"RTN","DGENUPL1",77,0)
 ;Phase II Add the capability to accept more than 1 ZCD
"RTN","DGENUPL1",78,0)
 I 'ERROR F SEG="ZEN","ZMT","ZCD" D  Q:ERROR
"RTN","DGENUPL1",79,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",80,0)
 .I SEG("TYPE")=SEG D
"RTN","DGENUPL1",81,0)
 ..N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN     ; DG*5.3*894
"RTN","DGENUPL1",82,0)
 .E  D
"RTN","DGENUPL1",83,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",84,0)
 ..S ERROR=1
"RTN","DGENUPL1",85,0)
 ..;
"RTN","DGENUPL1",86,0)
 ..;possible that in a bad message we are now past the end
"RTN","DGENUPL1",87,0)
 ..S CURLINE=CURLINE-1
"RTN","DGENUPL1",88,0)
 ;
"RTN","DGENUPL1",89,0)
 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
"RTN","DGENUPL1",90,0)
 I 'ERROR S SEG="ZCD" I $$CHKNXT(CURLINE+1,SEG) F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZCD")  D  Q:ERROR
"RTN","DGENUPL1",91,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",92,0)
 .D ZCD^DGENUPL2
"RTN","DGENUPL1",93,0)
 ;
"RTN","DGENUPL1",94,0)
 ; Purple Heart/OEF-OIF  Addition of optional ZMH segment
"RTN","DGENUPL1",95,0)
 ;              Modified handling of ZSP and ZRD to accomodate ZMH
"RTN","DGENUPL1",96,0)
 ;
"RTN","DGENUPL1",97,0)
 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
"RTN","DGENUPL1",98,0)
 I 'ERROR S SEG="ZSP" I $$CHKNXT(CURLINE+1,SEG) D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",99,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",100,0)
 .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q
"RTN","DGENUPL1",101,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",102,0)
 .S ERROR=1
"RTN","DGENUPL1",103,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",104,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",105,0)
 ;
"RTN","DGENUPL1",106,0)
 ;Modified following code to receive multiple ZMH segment for
"RTN","DGENUPL1",107,0)
 ;Military service information - DG*5.3*653
"RTN","DGENUPL1",108,0)
 ;
"RTN","DGENUPL1",109,0)
 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
"RTN","DGENUPL1",110,0)
 I 'ERROR S SEG="ZMH" D  Q:ERROR
"RTN","DGENUPL1",111,0)
 .;DJS, No ZMH segment present, so branch to DGNOZMH; DG*5.3*935
"RTN","DGENUPL1",112,0)
 .I '$$CHKNXT(CURLINE+1,SEG) I ^TMP($J,"DGENUPL","ZMH",0)=0 D EN^DGNOZMH(DFN) K ^TMP($J,"DGENUPL") Q
"RTN","DGENUPL1",113,0)
 .S QFLG=0 F  D  Q:QFLG!(ERROR)
"RTN","DGENUPL1",114,0)
 ..I '$$CHKNXT(CURLINE+1,SEG) S QFLG=1 Q
"RTN","DGENUPL1",115,0)
 ..D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",116,0)
 ..D ZMH^DGENUPL2
"RTN","DGENUPL1",117,0)
 ..Q
"RTN","DGENUPL1",118,0)
 .Q
"RTN","DGENUPL1",119,0)
 ;
"RTN","DGENUPL1",120,0)
 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
"RTN","DGENUPL1",121,0)
 I 'ERROR S SEG="ZRD" I $$CHKNXT(CURLINE+1,SEG) F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZRD")  D  Q:ERROR
"RTN","DGENUPL1",122,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",123,0)
 .D ZRD^DGENUPL2
"RTN","DGENUPL1",124,0)
 ;
"RTN","DGENUPL1",125,0)
 ;DJS, Added call to extrinsic function to determine if multiple segments are present ; DG*5.3*935
"RTN","DGENUPL1",126,0)
 I 'ERROR S SEG="OBX" F  D  Q:(ERROR!('$$CHKNXT(CURLINE+1,SEG)))
"RTN","DGENUPL1",127,0)
 .;possible if OBX segment not present that we are now past the end
"RTN","DGENUPL1",128,0)
 .Q:'$$CHKNXT(CURLINE+1,SEG)
"RTN","DGENUPL1",129,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",130,0)
 .D OBX^DGENUPL2
"RTN","DGENUPL1",131,0)
 .Q
"RTN","DGENUPL1",132,0)
 ;
"RTN","DGENUPL1",133,0)
 Q $S(ERROR:0,1:1)
"RTN","DGENUPL1",134,0)
 ;
"RTN","DGENUPL1",135,0)
CONVERT(VAL,DATATYPE,ERROR) ;
"RTN","DGENUPL1",136,0)
 ;Description: Converts the value found in the HL7 segment to DHCP format
"RTN","DGENUPL1",137,0)
 ;
"RTN","DGENUPL1",138,0)
 ;Input:
"RTN","DGENUPL1",139,0)
 ;  VAL - value parsed from the HL7 segment
"RTN","DGENUPL1",140,0)
 ;  DATATYPE: indicates the type of conversion necessary
"RTN","DGENUPL1",141,0)
 ;      "DATE" - needs to be converted to FM format
"RTN","DGENUPL1",142,0)
 ;      "TS" - time stamp, needs to be converted to FM format
"RTN","DGENUPL1",143,0)
 ;      "Y/N" - 0->"N",1->"Y"
"RTN","DGENUPL1",144,0)
 ;      "1/0" - "Y"->1,"N"->0
"RTN","DGENUPL1",145,0)
 ;      "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file
"RTN","DGENUPL1",146,0)
 ;      "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8)
"RTN","DGENUPL1",147,0)
 ;
"RTN","DGENUPL1",148,0)
 ;      "MT" - VAL  is a Means Test Status code, it needs to be converted
"RTN","DGENUPL1",149,0)
 ;             to a pointer to the Means Test Status file
"RTN","DGENUPL1",150,0)
 ;       Phase II convert code to RSN IEN for DGCDIS object
"RTN","DGENUPL1",151,0)
 ;       "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5)
"RTN","DGENUPL1",152,0)
 ;       "CDDSCR" data type converts the codes descriptor(s) to DSCR IEN. (HL7TODSC^DGENA5)   DG*5.3*894
"RTN","DGENUPL1",153,0)
 ;       "EXT" convert from code to abbreviation
"RTN","DGENUPL1",154,0)
 ;       "POS" convert from Period of Service code to a point to Period of Service file
"RTN","DGENUPL1",155,0)
 ;       "AGENCY" convert Agency/Allied Country code from file 35
"RTN","DGENUPL1",156,0)
 ;       "PENSIONCD" convert Pension Award/Termination Reason code from file 27.18
"RTN","DGENUPL1",157,0)
 ;       "HBP" convert from code to file 25.11 ien DG*5.3*871
"RTN","DGENUPL1",158,0)
 ;OUTPUT:
"RTN","DGENUPL1",159,0)
 ;  Function Value - the result of the conversion
"RTN","DGENUPL1",160,0)
 ;  ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref)
"RTN","DGENUPL1",161,0)
 S ERROR=0
"RTN","DGENUPL1",162,0)
 D
"RTN","DGENUPL1",163,0)
 .I VAL="" Q
"RTN","DGENUPL1",164,0)
 .I VAL="""""" S VAL="@" Q
"RTN","DGENUPL1",165,0)
 .I $G(DATATYPE)="EXT" D  Q
"RTN","DGENUPL1",166,0)
 ..S VAL=$$HLTOLIMB^DGENA5(VAL)
"RTN","DGENUPL1",167,0)
 .I $G(DATATYPE)="CDRSN" D  Q
"RTN","DGENUPL1",168,0)
 ..S VAL=$$HL7TORSN^DGENA5(VAL)
"RTN","DGENUPL1",169,0)
 .; * check the new DESCRIPTOR seq  -  DG*5.3*894
"RTN","DGENUPL1",170,0)
 .I $G(DATATYPE)="CDDSCR" D  Q
"RTN","DGENUPL1",171,0)
 ..S VAL=$$HL7TODSC^DGENA5(VAL)
"RTN","DGENUPL1",172,0)
 .I ($G(DATATYPE)="MT") D  Q
"RTN","DGENUPL1",173,0)
 ..S VAL=$O(^DG(408.32,"AC",1,VAL,0))
"RTN","DGENUPL1",174,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",175,0)
 .I ($G(DATATYPE)="DATE") D  Q
"RTN","DGENUPL1",176,0)
 ..I $L(VAL)'=8 S ERROR=1 Q
"RTN","DGENUPL1",177,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",178,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",179,0)
 .I ($G(DATATYPE)="TS") D  Q
"RTN","DGENUPL1",180,0)
 ..I $L(VAL)<8 S ERROR=1 Q
"RTN","DGENUPL1",181,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",182,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",183,0)
 .I ($G(DATATYPE)="Y/N") D  Q
"RTN","DGENUPL1",184,0)
 ..I VAL=0 S VAL="N" Q
"RTN","DGENUPL1",185,0)
 ..I VAL=1 S VAL="Y" Q
"RTN","DGENUPL1",186,0)
 ..S ERROR=1
"RTN","DGENUPL1",187,0)
 .I ($G(DATATYPE)="1/0") D  Q
"RTN","DGENUPL1",188,0)
 ..I VAL="N" S VAL=0 Q
"RTN","DGENUPL1",189,0)
 ..I VAL="Y" S VAL=1 Q
"RTN","DGENUPL1",190,0)
 ..S ERROR=1
"RTN","DGENUPL1",191,0)
 .I ($G(DATATYPE)="ELIGIBILITY") D  Q
"RTN","DGENUPL1",192,0)
 ..S VAL=$$MAP(VAL)
"RTN","DGENUPL1",193,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",194,0)
 .I ($G(DATATYPE)="INSTITUTION") D  Q
"RTN","DGENUPL1",195,0)
 ..N OLDVAL
"RTN","DGENUPL1",196,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",197,0)
 ..S VAL=$O(^DIC(4,"D",OLDVAL,0))
"RTN","DGENUPL1",198,0)
 ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0))
"RTN","DGENUPL1",199,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",200,0)
 .I ($G(DATATYPE)="POS") D  Q
"RTN","DGENUPL1",201,0)
 ..N OLDVAL
"RTN","DGENUPL1",202,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",203,0)
 ..S VAL=$O(^DIC(21,"D",OLDVAL,0))
"RTN","DGENUPL1",204,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",205,0)
 .I ($G(DATATYPE)="AGENCY") D  Q
"RTN","DGENUPL1",206,0)
 ..N OLDVAL
"RTN","DGENUPL1",207,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",208,0)
 ..S VAL=$O(^DIC(35,"C",OLDVAL,0))
"RTN","DGENUPL1",209,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",210,0)
 .I ($G(DATATYPE)="PENSIONCD") D  Q
"RTN","DGENUPL1",211,0)
 ..N OLDVAL
"RTN","DGENUPL1",212,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",213,0)
 ..S VAL=$O(^DG(27.18,"C",OLDVAL,0))
"RTN","DGENUPL1",214,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",215,0)
 .I ($G(DATATYPE)="HBP") D  Q    ; DG*5.3*871
"RTN","DGENUPL1",216,0)
 ..N OLDVAL
"RTN","DGENUPL1",217,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",218,0)
 ..S VAL=$O(^DGHBP(25.11,"C",OLDVAL,0))
"RTN","DGENUPL1",219,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",220,0)
 Q VAL
"RTN","DGENUPL1",221,0)
 ;
"RTN","DGENUPL1",222,0)
MAP(VALUE) ;
"RTN","DGENUPL1",223,0)
 ;Description: Tries to map an eligibility code from file #8.1 (the national MAS ELIGIBILITY CODE file) to file #8 (the local ELIGIBILITY CODE file)
"RTN","DGENUPL1",224,0)
 ;
"RTN","DGENUPL1",225,0)
 ;Input: VALUE - ien of an entry in file #8.1
"RTN","DGENUPL1",226,0)
 ;
"RTN","DGENUPL1",227,0)
 ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8
"RTN","DGENUPL1",228,0)
 ;
"RTN","DGENUPL1",229,0)
 N ECODE,NODE,COUNT,NAME
"RTN","DGENUPL1",230,0)
 ;try to choose a code from file 8 to use that is appropriate
"RTN","DGENUPL1",231,0)
 S (COUNT,ECODE)=0
"RTN","DGENUPL1",232,0)
 ;
"RTN","DGENUPL1",233,0)
 F  S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE  D
"RTN","DGENUPL1",234,0)
 .S NODE=$G(^DIC(8,ECODE,0))
"RTN","DGENUPL1",235,0)
 .;put code on list if active
"RTN","DGENUPL1",236,0)
 .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1
"RTN","DGENUPL1",237,0)
 ;
"RTN","DGENUPL1",238,0)
 ;only one match found, so use it
"RTN","DGENUPL1",239,0)
 Q:COUNT=1 $O(ECODE(0))
"RTN","DGENUPL1",240,0)
 ;
"RTN","DGENUPL1",241,0)
 ;no match found
"RTN","DGENUPL1",242,0)
 Q:'COUNT ""
"RTN","DGENUPL1",243,0)
 ;
"RTN","DGENUPL1",244,0)
 ;multiple matches found, try to match by name
"RTN","DGENUPL1",245,0)
 I COUNT>1 D
"RTN","DGENUPL1",246,0)
 .S ECODE=0
"RTN","DGENUPL1",247,0)
 .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^")
"RTN","DGENUPL1",248,0)
 .F  S ECODE=$O(ECODE(ECODE)) Q:'ECODE  Q:ECODE(ECODE)=NAME
"RTN","DGENUPL1",249,0)
 Q ECODE
"RTN","DGENUPL1",250,0)
 ;
"RTN","DGENUPL1",251,0)
ACCEPT(MSGID) ;
"RTN","DGENUPL1",252,0)
 ;Description: Writes an ack (AA) to a global to be transmitted later.
"RTN","DGENUPL1",253,0)
 ;
"RTN","DGENUPL1",254,0)
 ;Inputs:
"RTN","DGENUPL1",255,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",256,0)
 ;
"RTN","DGENUPL1",257,0)
 ;Outputs: none
"RTN","DGENUPL1",258,0)
 ;
"RTN","DGENUPL1",259,0)
 K HL,HLMID,HLMTIEN,HLDT,HLDT1
"RTN","DGENUPL1",260,0)
 D INIT^HLFNC2(HLEID,.HL)
"RTN","DGENUPL1",261,0)
 D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
"RTN","DGENUPL1",262,0)
 S HLEVN=1
"RTN","DGENUPL1",263,0)
 S MID=HLMID_"-"_HLEVN
"RTN","DGENUPL1",264,0)
 D MSH^HLFNC2(.HL,MID,.HLRES)
"RTN","DGENUPL1",265,0)
 S ^TMP("HLS",$J,1)=HLRES
"RTN","DGENUPL1",266,0)
 ;
"RTN","DGENUPL1",267,0)
 ;it seems HLFS sometimes disappears upon reaching this point
"RTN","DGENUPL1",268,0)
 I $G(HLFS)="" S HLFS="^"
"RTN","DGENUPL1",269,0)
 ;
"RTN","DGENUPL1",270,0)
 S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID
"RTN","DGENUPL1",271,0)
 Q
"RTN","DGENUPL1",272,0)
 ;
"RTN","DGENUPL1",273,0)
MVERRORS ;
"RTN","DGENUPL1",274,0)
 ;Error messages were being deleted from ^TMP("HLS",$J by another package
"RTN","DGENUPL1",275,0)
 ;during the upload.  To fix this, errors are written to another
"RTN","DGENUPL1",276,0)
 ;subscript, then moved when the error list is complete.
"RTN","DGENUPL1",277,0)
 ;
"RTN","DGENUPL1",278,0)
 M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",279,0)
 K ^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",280,0)
 Q
"RTN","DGENUPL1",281,0)
 ;
"RTN","DGENUPL1",282,0)
 ;DJS, Added Extrinsic Function to determine if multiple segments are present ; DG*5.3*935
"RTN","DGENUPL1",283,0)
CHKNXT(DGNVAL,DGNSEG) ; Check the SEG in the next segment manually
"RTN","DGENUPL1",284,0)
 ; DGNVAL = CURLINE or CURLINE+1
"RTN","DGENUPL1",285,0)
 ; DGNSEG = SEG (3 character SEG)
"RTN","DGENUPL1",286,0)
 ; Returns 1 if there is a match or 0 if there is no match
"RTN","DGENUPL1",287,0)
 ;
"RTN","DGENUPL1",288,0)
 Q $S($E($G(^TMP($J,IVMRTN,+DGNVAL,0)),1,3)=DGNSEG:1,1:0)
"RTN","DGENUPL3")
0^5^B89567535
"RTN","DGENUPL3",1,0)
DGENUPL3 ;ALB/CJM,ISA,KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD,DJS - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;28 Sep 2017  5:35PM
"RTN","DGENUPL3",2,0)
 ;;5.3;REGISTRATION;**147,230,232,377,404,451,653,688,793,797,841,928,935**;Aug 13,1993;Build 53
"RTN","DGENUPL3",3,0)
 ;
"RTN","DGENUPL3",4,0)
 ;
"RTN","DGENUPL3",5,0)
ADDMSG(MSGS,MESSAGE,TOHEC) ;
"RTN","DGENUPL3",6,0)
 ;Description: Used to add a message to an array of messages to be sent.
"RTN","DGENUPL3",7,0)
 ;
"RTN","DGENUPL3",8,0)
 ;Input:
"RTN","DGENUPL3",9,0)
 ;  MSGS - the array to store the message (pass by reference)
"RTN","DGENUPL3",10,0)
 ;  MESSAGE - the message to store
"RTN","DGENUPL3",11,0)
 ;  TOHEC - a flag, if set to 1 it means that HEC should also receive notification
"RTN","DGENUPL3",12,0)
 ;
"RTN","DGENUPL3",13,0)
 ;Output: none
"RTN","DGENUPL3",14,0)
 ;
"RTN","DGENUPL3",15,0)
 I MESSAGE["DATE OF DEATH" Q
"RTN","DGENUPL3",16,0)
 S MSGS(0)=($G(MSGS(0))+1)
"RTN","DGENUPL3",17,0)
 S MSGS(MSGS(0))=MESSAGE
"RTN","DGENUPL3",18,0)
 I ($G(TOHEC)=1) S MSGS("HEC")=1
"RTN","DGENUPL3",19,0)
 Q
"RTN","DGENUPL3",20,0)
 ;
"RTN","DGENUPL3",21,0)
 ;
"RTN","DGENUPL3",22,0)
NOTIFY(DGPAT,MSGS) ;
"RTN","DGENUPL3",23,0)
 ;Description: This is used to send a message to the local mail group
"RTN","DGENUPL3",24,0)
 ;defined by the MAS Parameter ELIGIBILITY UPLOAD MAIL GROUP.The
"RTN","DGENUPL3",25,0)
 ;notification is to be used when specific problems or conditions
"RTN","DGENUPL3",26,0)
 ;regarding the upload of the enrollment or eligibility data.
"RTN","DGENUPL3",27,0)
 ;
"RTN","DGENUPL3",28,0)
 ;Input: 
"RTN","DGENUPL3",29,0)
 ;  OLDPAT -used if the DGPAT elements have not been built
"RTN","DGENUPL3",30,0)
 ;  DGPAT - patient array (pass by reference)
"RTN","DGENUPL3",31,0)
 ;  MSGS - the an array of messages that should be included in the
"RTN","DGENUPL3",32,0)
 ;         notification (pass by reference). If MSGS("HEC")=1
"RTN","DGENUPL3",33,0)
 ;         it means that HEC should also receive notification.
"RTN","DGENUPL3",34,0)
 ;
"RTN","DGENUPL3",35,0)
 ;Output:   none
"RTN","DGENUPL3",36,0)
 ;
"RTN","DGENUPL3",37,0)
 N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT
"RTN","DGENUPL3",38,0)
 N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD,DGFDD
"RTN","DGENUPL3",39,0)
 ;
"RTN","DGENUPL3",40,0)
 ;if there are no alerts, then quit
"RTN","DGENUPL3",41,0)
 Q:'$G(MSGS(0))
"RTN","DGENUPL3",42,0)
 ;
"RTN","DGENUPL3",43,0)
 ;Get reason for alert.  If there is more than one reason decide which 
"RTN","DGENUPL3",44,0)
 ;reason to display.  'NON-SERVICE' alerts have a higher priority than
"RTN","DGENUPL3",45,0)
 ;other alerts and are therefore displayed before other alerts in the 
"RTN","DGENUPL3",46,0)
 ;subject line, followed by 'POW' alerts in priority.
"RTN","DGENUPL3",47,0)
 S (ELIG,NSC,POW,CD)=0
"RTN","DGENUPL3",48,0)
 S COUNT=0 F  S COUNT=$O(MSGS(COUNT)) Q:'COUNT!NSC  D
"RTN","DGENUPL3",49,0)
 .I MSGS(COUNT)["PREVIOUSLY ELIGIBLE" S ELIG=1 Q
"RTN","DGENUPL3",50,0)
 .I MSGS(COUNT)["NON-SERVICE" S NSC=1 Q
"RTN","DGENUPL3",51,0)
 .I MSGS(COUNT)["POW" S POW=1 Q
"RTN","DGENUPL3",52,0)
 .I MSGS(COUNT)["CD EVALUATION" S CD=1 Q
"RTN","DGENUPL3",53,0)
 .S HEADER=MSGS(COUNT)
"RTN","DGENUPL3",54,0)
 .Q
"RTN","DGENUPL3",55,0)
 D
"RTN","DGENUPL3",56,0)
 .I ELIG S HEADER="Ineligibility Alert: " Q
"RTN","DGENUPL3",57,0)
 .I NSC S HEADER="NSC Alert: " Q
"RTN","DGENUPL3",58,0)
 .I POW&'NSC S HEADER="POW Alert: " Q
"RTN","DGENUPL3",59,0)
 .I CD S HEADER="CD Alert: " Q
"RTN","DGENUPL3",60,0)
 .Q
"RTN","DGENUPL3",61,0)
 ;
"RTN","DGENUPL3",62,0)
 S XMDF=""
"RTN","DGENUPL3",63,0)
 S (XMDUN,XMDUZ)="Registration Enrollment Module"
"RTN","DGENUPL3",64,0)
 ;Phase II Re-Enrollment
"RTN","DGENUPL3",65,0)
 ;DGPAT("SSN") is built by the parser.  DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT.
"RTN","DGENUPL3",66,0)
 ;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge. 
"RTN","DGENUPL3",67,0)
 I '$D(DGPAT("NAME")) S DGPAT("NAME")=$G(OLDPAT("NAME"))
"RTN","DGENUPL3",68,0)
 I '$D(DGPAT("SEX")) S DGPAT("SEX")=$G(OLDPAT("SEX"))
"RTN","DGENUPL3",69,0)
 I '$D(DGPAT("DOB")) S DGPAT("DOB")=$G(OLDPAT("DOB"))
"RTN","DGENUPL3",70,0)
 S TMPSTR=" ("_$E(DGPAT("NAME"),1,1)
"RTN","DGENUPL3",71,0)
 S TMPSTR=TMPSTR_$E(DGPAT("SSN"),$L(DGPAT("SSN"))-3,1000)_")"
"RTN","DGENUPL3",72,0)
 S XMSUB=$E(HEADER,1,30)_$E(DGPAT("NAME"),1,25)_TMPSTR
"RTN","DGENUPL3",73,0)
 ;
"RTN","DGENUPL3",74,0)
 ; send msg to local mail group specified in IVM SITE PARAMETER file
"RTN","DGENUPL3",75,0)
 S MAILGRP=+$P($G(^IVM(301.9,1,0)),"^",9)
"RTN","DGENUPL3",76,0)
 S MAILGRP=$$EXTERNAL^DILFD(301.9,.09,"F",MAILGRP)
"RTN","DGENUPL3",77,0)
 I MAILGRP]"" S XMY("G."_MAILGRP)=""
"RTN","DGENUPL3",78,0)
 ;
"RTN","DGENUPL3",79,0)
 ;Patch DG*5.3*928 is removing ability to send emails to remote email group. Emails have been decommissioned and no longer required.
"RTN","DGENUPL3",80,0)
 ;if flag is set, send msg to remote mail group specified in
"RTN","DGENUPL3",81,0)
 ;the IVM SITE PARAMETER file
"RTN","DGENUPL3",82,0)
 ;I $G(MSGS("HEC"))=1 D
"RTN","DGENUPL3",83,0)
 ;.S MAILGRP=$P($G(^IVM(301.9,1,0)),"^",10)
"RTN","DGENUPL3",84,0)
 ;.S MAILGRP=$$EXTERNAL^DILFD(301.9,.10,"F",MAILGRP)
"RTN","DGENUPL3",85,0)
 ;.I MAILGRP]"" S XMY("G."_MAILGRP)=""
"RTN","DGENUPL3",86,0)
 ;
"RTN","DGENUPL3",87,0)
 ;
"RTN","DGENUPL3",88,0)
 S XMTEXT="TEXT("
"RTN","DGENUPL3",89,0)
 S TEXT(1)="The enrollment/eligibility upload produced the following alerts:"
"RTN","DGENUPL3",90,0)
 S TEXT(2)="  "
"RTN","DGENUPL3",91,0)
 S TEXT(3)="Patient Name   :     "_DGPAT("NAME")
"RTN","DGENUPL3",92,0)
 S TEXT(4)="SSN            :     "_DGPAT("SSN")
"RTN","DGENUPL3",93,0)
 S TEXT(5)="DOB            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB"))
"RTN","DGENUPL3",94,0)
 S TEXT(6)="SEX            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX"))
"RTN","DGENUPL3",95,0)
 S TEXT(7)=" "
"RTN","DGENUPL3",96,0)
 ;
"RTN","DGENUPL3",97,0)
 S TEXT(8)=" ** Alerts **"
"RTN","DGENUPL3",98,0)
 S TEXT(9)=" "
"RTN","DGENUPL3",99,0)
 S COUNT=0 F  S COUNT=$O(MSGS(COUNT)) Q:'COUNT  S TEXT(10+COUNT)=COUNT_") "_MSGS(COUNT)
"RTN","DGENUPL3",100,0)
 ;
"RTN","DGENUPL3",101,0)
 D ^XMD
"RTN","DGENUPL3",102,0)
 Q
"RTN","DGENUPL3",103,0)
 ;
"RTN","DGENUPL3",104,0)
BEGUPLD(DFN) ;
"RTN","DGENUPL3",105,0)
 ;Description: Sets a lock used to determine if an eligibility/enrollment
"RTN","DGENUPL3",106,0)
 ;upload is in progress. 
"RTN","DGENUPL3",107,0)
 ;
"RTN","DGENUPL3",108,0)
 ;Input:
"RTN","DGENUPL3",109,0)
 ;   DFN - ien, Patient record
"RTN","DGENUPL3",110,0)
 ;
"RTN","DGENUPL3",111,0)
 ;Output:
"RTN","DGENUPL3",112,0)
 ;  Function value - returns 1 if the lock was obtained, 0 otherwise.
"RTN","DGENUPL3",113,0)
 ;
"RTN","DGENUPL3",114,0)
 Q:'$G(DFN) 1
"RTN","DGENUPL3",115,0)
 L +^DGEN("ELIGIBILITY UPLOAD",DFN):3
"RTN","DGENUPL3",116,0)
 Q $T
"RTN","DGENUPL3",117,0)
 ;
"RTN","DGENUPL3",118,0)
ENDUPLD(DFN) ;
"RTN","DGENUPL3",119,0)
 ;Description: Releases the lock obtained by calling $$BEGUPLD(DFN)
"RTN","DGENUPL3",120,0)
 ;
"RTN","DGENUPL3",121,0)
 Q:'$G(DFN)
"RTN","DGENUPL3",122,0)
 L -^DGEN("ELIGIBILITY UPLOAD",DFN)
"RTN","DGENUPL3",123,0)
 Q
"RTN","DGENUPL3",124,0)
 ;
"RTN","DGENUPL3",125,0)
CKUPLOAD(DFN) ;
"RTN","DGENUPL3",126,0)
 ;Description: Checks if an upload is in progress.  If so, it pauses
"RTN","DGENUPL3",127,0)
 ;until it is completed.
"RTN","DGENUPL3",128,0)
 ;The enrollment/eligibility upload can take a while to accomplish.
"RTN","DGENUPL3",129,0)
 ;If the lock is not obtained initially, it is assumed that the upload
"RTN","DGENUPL3",130,0)
 ;is in progress, and a message is displayed to the user.
"RTN","DGENUPL3",131,0)
 ;
"RTN","DGENUPL3",132,0)
 ;Input: DFN
"RTN","DGENUPL3",133,0)
 ;Output: none
"RTN","DGENUPL3",134,0)
 ;
"RTN","DGENUPL3",135,0)
 N I
"RTN","DGENUPL3",136,0)
 I '$$BEGUPLD(DFN) D
"RTN","DGENUPL3",137,0)
 .W !!,"Upload of patient enrollment/eligibility data is in progress ..."
"RTN","DGENUPL3",138,0)
 .D UNLOCK^DGENPTA1(DFN)
"RTN","DGENUPL3",139,0)
 .F I=1:1:50 Q:$$BEGUPLD(DFN)  W "."
"RTN","DGENUPL3",140,0)
 .W !,"Upload of patient enrollment/eligibility data is completed.",!
"RTN","DGENUPL3",141,0)
 D ENDUPLD(DFN)
"RTN","DGENUPL3",142,0)
 Q
"RTN","DGENUPL3",143,0)
SCVET ;moved from DGENUPL4 - DG*5.3*688
"RTN","DGENUPL3",144,0)
 I DGPAT3("VETERAN")'="N" D
"RTN","DGENUPL3",145,0)
 . I DGELG3("SC")="N" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","NSC VETERAN",0))
"RTN","DGENUPL3",146,0)
 . I DGELG3("SC")="Y" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","SC VETERAN",0))
"RTN","DGENUPL3",147,0)
 I DGPAT3("VETERAN")="N" S DGPAT3("PATYPE")=$$NONVET(DGELG("ELIG","CODE"))
"RTN","DGENUPL3",148,0)
 Q
"RTN","DGENUPL3",149,0)
 ;
"RTN","DGENUPL3",150,0)
NONVET(DGCODE) ;map Patient Type from Primary Elig (and POS)
"RTN","DGENUPL3",151,0)
 ;added with DG*5.3*688 - ERC
"RTN","DGENUPL3",152,0)
 ; input:         DGCODE is the Primary Eligibility code
"RTN","DGENUPL3",153,0)
 ; output:        DGTPYE is returned as the value for Patient Type
"RTN","DGENUPL3",154,0)
 N PTELG,DGTYPE
"RTN","DGENUPL3",155,0)
 S (PTELG,DGTYPE)=""
"RTN","DGENUPL3",156,0)
 Q:$G(DGCODE)']"" ""
"RTN","DGENUPL3",157,0)
 S PTELG=$$NATNAME^DGENELA(DGCODE)
"RTN","DGENUPL3",158,0)
 Q:$G(PTELG)']"" ""
"RTN","DGENUPL3",159,0)
 I "CHAMPVA^OTHER FEDERAL AGENCY^REIMBURSABLE INSURANCE^SHARING AGREEMENT"[PTELG S DGTYPE=$$POS(.DGTYPE) Q:DGTYPE DGTYPE
"RTN","DGENUPL3",160,0)
 S DGTYPE=$S(PTELG["ALLIED":"ALLIED VETERAN",PTELG["COLLATERAL":"COLLATERAL",PTELG["EMPLOYEE":"EMPLOYEE",PTELG["TRICARE":"TRICARE",1:"")
"RTN","DGENUPL3",161,0)
 I DGTYPE']"" S DGTYPE="NON-VETERAN (OTHER)" ;default Pat Type
"RTN","DGENUPL3",162,0)
 S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
"RTN","DGENUPL3",163,0)
 Q DGTYPE
"RTN","DGENUPL3",164,0)
POS(DGTYPE) ;for these Elig Codes, check POS to determine Patient Type
"RTN","DGENUPL3",165,0)
 S DGPOS=DGELG("POS")
"RTN","DGENUPL3",166,0)
 I $G(DGPOS)']"" Q ""
"RTN","DGENUPL3",167,0)
 I '$D(^DIC(21,DGPOS,0)) Q ""
"RTN","DGENUPL3",168,0)
 S DGPOS=$P(^DIC(21,DGPOS,0),U)
"RTN","DGENUPL3",169,0)
 S DGTYPE=$S(DGPOS["ACTIVE":"ACTIVE DUTY",DGPOS["OPERAT":"ACTIVE DUTY",DGPOS["RETIR":"MILITARY RETIREE",1:"")
"RTN","DGENUPL3",170,0)
 I $G(DGTYPE)]"" S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
"RTN","DGENUPL3",171,0)
 Q DGTYPE
"RTN","DGENUPL3",172,0)
 ;
"RTN","DGENUPL3",173,0)
 ;ZMH code moved here from DGENUPL2 - DG*5.3*653
"RTN","DGENUPL3",174,0)
ZMH ;Purple Heart, POW, OEF/OIF Conflict Loc, Military Service Episodes, Medal of Honor
"RTN","DGENUPL3",175,0)
 ;PROCESS PH, OEF/OIF, MH & POW FROM ZMH
"RTN","DGENUPL3",176,0)
 ;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797
"RTN","DGENUPL3",177,0)
 ;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Future Discharge Date Added DG*5.3*935
"RTN","DGENUPL3",178,0)
 ;DJS, Indicate if the ZMH segment exists in this message; DG*5.3*935
"RTN","DGENUPL3",179,0)
 N DGNEW
"RTN","DGENUPL3",180,0)
 S ^TMP($J,"DGENUPL","ZMH",0)=1
"RTN","DGENUPL3",181,0)
 I "^SL^SNL^SNNL^MSD^FDD^"[("^"_SEG(2)_"^") D  Q
"RTN","DGENUPL3",182,0)
 . ;DJS, Store the Future Discharge Date (FDD); DG*5.3*935
"RTN","DGENUPL3",183,0)
 . I SEG(2)="FDD"&($L(SEG(8))<5) S SEG(8)="",I=0 D  Q
"RTN","DGENUPL3",184,0)
 . . S DGNEW=0 F  S I=$O(^DPT(DFN,.3216,I)) Q:I'?.N!($G(I)="")  S DA(1)=DFN,DA=I,DIE="^DPT("_DA(1)_","_.3216_",",DIE(0)="",DR=".08///@" D ^DIE D ID1^DGNOZMH(DFN,I,DGNEW) S I=DA  ;Delete an incomplete MSE ;DG*5.3*935
"RTN","DGENUPL3",185,0)
 . . K DGNEW Q 
"RTN","DGENUPL3",186,0)
 . N BOS,SN,DIS,SED,SSD,COM,DGFDD,DIE,DA,DR S ERROR=""
"RTN","DGENUPL3",187,0)
 . S BOS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))  ;Service Branch
"RTN","DGENUPL3",188,0)
 . S:BOS]"" BOS=$O(^DIC(23,"B",BOS,""))
"RTN","DGENUPL3",189,0)
 . S SN=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))  ;Service Number
"RTN","DGENUPL3",190,0)
 . S DIS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3))  ;Discharge Type
"RTN","DGENUPL3",191,0)
 . S:DIS]"" DIS=$O(^DIC(25,"B",DIS,""))
"RTN","DGENUPL3",192,0)
 . S SED=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE")  ;Entry Date
"RTN","DGENUPL3",193,0)
 . I 'SED!ERROR D  Q
"RTN","DGENUPL3",194,0)
 . . Q:SEG(2)="FDD"&(SEG(8)="")  D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SERVICE ENTRY DATE",.ERRCOUNT)
"RTN","DGENUPL3",195,0)
 . S SSD=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE")  ;Sep. Date
"RTN","DGENUPL3",196,0)
 . S COM=$$CONVERT^DGENUPL1($P(SEG(5),$E(HLECH)))  ;Service Component
"RTN","DGENUPL3",197,0)
 . ;DJS, Create variable DGFDD for storage in Military Service Episode (MSE); DG*5.3*935
"RTN","DGENUPL3",198,0)
 . ;DJS, Create MSE whether or not FDD exists & is a valid date; DG*5.3*935
"RTN","DGENUPL3",199,0)
 . I SEG(2)="FDD" D
"RTN","DGENUPL3",200,0)
 . . S DGFDD=$$CONVERT^DGENUPL1($P(SEG(8),$E(HLECH)),"DATE")
"RTN","DGENUPL3",201,0)
 . . I $$VALID^DGRPDT(.DGFDD)=1 D
"RTN","DGENUPL3",202,0)
 . . .S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1_U_DGFDD
"RTN","DGENUPL3",203,0)
 . E  S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1
"RTN","DGENUPL3",204,0)
 ;
"RTN","DGENUPL3",205,0)
 I SEG(2)="PH" D  Q  ;Process Purple Heart from ZMH
"RTN","DGENUPL3",206,0)
 . S DGPAT("PHI")=$P(SEG(3),$E(HLECH))
"RTN","DGENUPL3",207,0)
 . S DGELG("PH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",208,0)
 . S DGPAT("PHST")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
"RTN","DGENUPL3",209,0)
 . S DGPAT("PHRR")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3))
"RTN","DGENUPL3",210,0)
 ;
"RTN","DGENUPL3",211,0)
 I SEG(2)="OEIF" D  Q
"RTN","DGENUPL3",212,0)
 . N OEIFLOC
"RTN","DGENUPL3",213,0)
 . S OEIFLOC=$P(SEG(3),$E(HLECH))
"RTN","DGENUPL3",214,0)
 . I OEIFLOC="Conflict Unspecified" Q   ;Ignore these entries
"RTN","DGENUPL3",215,0)
 . I OEIFLOC="Unknown OEF/OIF" S OEIFLOC="UNK"
"RTN","DGENUPL3",216,0)
 . S OEIFLOC=$E(OEIFLOC,1,3)
"RTN","DGENUPL3",217,0)
 . Q:((OEIFLOC'="OIF")&(OEIFLOC'="OEF")&(OEIFLOC'="UNK"))
"RTN","DGENUPL3",218,0)
 . S DGOEIF("COUNT")=$G(DGOEIF("COUNT"))+1
"RTN","DGENUPL3",219,0)
 . S DGOEIF("LOC",DGOEIF("COUNT"))=OEIFLOC
"RTN","DGENUPL3",220,0)
 . S DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2),"INSTITUTION")
"RTN","DGENUPL3",221,0)
 . S DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE")
"RTN","DGENUPL3",222,0)
 . S DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE")
"RTN","DGENUPL3",223,0)
 . S DGOEIF("LOCK",DGOEIF("COUNT"))=1
"RTN","DGENUPL3",224,0)
 ;
"RTN","DGENUPL3",225,0)
 I SEG(2)="POW" D  ;Process POW from ZMH
"RTN","DGENUPL3",226,0)
 . S DGPAT("POWI")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;POW STATUS INDICATED
"RTN","DGENUPL3",227,0)
 . S DGELG("POW")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",228,0)
 . S DGPAT("POWLOC")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
"RTN","DGENUPL3",229,0)
 . I DGPAT("POWLOC")'="@" S DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR) ;POW CONFINEMENT LOCATION
"RTN","DGENUPL3",230,0)
 . I ERROR D  Q
"RTN","DGENUPL3",231,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT)
"RTN","DGENUPL3",232,0)
 . S DGPAT("POWFDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE",.ERROR) ;POW FROM DATE
"RTN","DGENUPL3",233,0)
 . I ERROR D  Q
"RTN","DGENUPL3",234,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT)
"RTN","DGENUPL3",235,0)
 . S DGPAT("POWTDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;POW TO DATE
"RTN","DGENUPL3",236,0)
 . I ERROR D  Q
"RTN","DGENUPL3",237,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT)
"RTN","DGENUPL3",238,0)
 ;
"RTN","DGENUPL3",239,0)
 I SEG(2)="MH" D  ;Process Medal of Honor from ZMH
"RTN","DGENUPL3",240,0)
 . S DGPAT("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;MH STATUS INDICATED
"RTN","DGENUPL3",241,0)
 . S DGELG("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
"RTN","DGENUPL3",242,0)
 Q
"RTN","DGENUPL3",243,0)
POWLOC(LOC,ERROR) ;POW Confinement Location mapping with HL7 table VA023
"RTN","DGENUPL3",244,0)
 ;  Input: LOC - HL7 code for location
"RTN","DGENUPL3",245,0)
 ; Output: ERROR - Return error 1 on failure
"RTN","DGENUPL3",246,0)
 ;         IEN22 - IEN of file 22
"RTN","DGENUPL3",247,0)
 N TBL023
"RTN","DGENUPL3",248,0)
 S ERROR=0
"RTN","DGENUPL3",249,0)
 I LOC="" S ERROR=1 Q ""
"RTN","DGENUPL3",250,0)
 S TBL023(4)="WWI",TBL023(5)="WWII-EUROPE",TBL023(6)="WWII-PACIFIC"
"RTN","DGENUPL3",251,0)
 S TBL023(7)="KOREAN",TBL023(8)="VIETNAM",TBL023(9)="OTHER"
"RTN","DGENUPL3",252,0)
 S TBL023("A")="PERSIAN GULF",TBL023("B")="YUGOSLAVIA"
"RTN","DGENUPL3",253,0)
 S IEN22=$O(^DIC(22,"C",TBL023(LOC),""))
"RTN","DGENUPL3",254,0)
 I IEN22="" S ERROR=1
"RTN","DGENUPL3",255,0)
 Q IEN22
"RTN","DGENUPL3",256,0)
 ;
"RTN","DGMSEUTL")
0^6^B17883475
"RTN","DGMSEUTL",1,0)
DGMSEUTL ;ALB/PJH,LBD,DJS - MSDS Utility Routine ;28 Sep 2017  5:36PM
"RTN","DGMSEUTL",2,0)
 ;;5.3;Registration;**797,935**;08/13/93;Build 53
"RTN","DGMSEUTL",3,0)
 ;
"RTN","DGMSEUTL",4,0)
 ;
"RTN","DGMSEUTL",5,0)
MOVMSE(DFN) ;Move MSE data from .32 node to .3216 multiple in Patient file #2
"RTN","DGMSEUTL",6,0)
 Q:'$G(DFN)  Q:$O(^DPT(DFN,.3216,0))
"RTN","DGMSEUTL",7,0)
 N ARRAY
"RTN","DGMSEUTL",8,0)
 D ARRAY(DFN,.ARRAY)
"RTN","DGMSEUTL",9,0)
 I $D(ARRAY) D MSE(DFN,.ARRAY)
"RTN","DGMSEUTL",10,0)
 Q
"RTN","DGMSEUTL",11,0)
 ;
"RTN","DGMSEUTL",12,0)
ARRAY(DFN,ARRAY) ;Get old format VistA data
"RTN","DGMSEUTL",13,0)
 N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
"RTN","DGMSEUTL",14,0)
 S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
"RTN","DGMSEUTL",15,0)
 ;Last service episode (SL)
"RTN","DGMSEUTL",16,0)
 D EPISODE(1,4,8)
"RTN","DGMSEUTL",17,0)
 ;Next to last service episode (SNL)
"RTN","DGMSEUTL",18,0)
 Q:$P(DGRP(.32),"^",19)'="Y"  D EPISODE(2,9,13)
"RTN","DGMSEUTL",19,0)
 ;Prior episode (SNNL)
"RTN","DGMSEUTL",20,0)
 I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
"RTN","DGMSEUTL",21,0)
 Q
"RTN","DGMSEUTL",22,0)
 ;
"RTN","DGMSEUTL",23,0)
EPISODE(SUB,P1,P2) ;Get old VistA data and save
"RTN","DGMSEUTL",24,0)
 S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
"RTN","DGMSEUTL",25,0)
 S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
"RTN","DGMSEUTL",26,0)
 S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
"RTN","DGMSEUTL",27,0)
 ;DJS, Save Future Discharge Date; DG*5.3*935
"RTN","DGMSEUTL",28,0)
 ;Save in format of new .3216 multiple (no lock flag)
"RTN","DGMSEUTL",29,0)
 S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U_U_$G(DGFDD)  ; DG*5.3*935
"RTN","DGMSEUTL",30,0)
 Q
"RTN","DGMSEUTL",31,0)
 ;
"RTN","DGMSEUTL",32,0)
MSE(DFN,ARRAY,DEL) ;Copy old VistA data to new .3216 multiple
"RTN","DGMSEUTL",33,0)
 N ECNT,DA,DIK,SUB,X,Y,DIC,DLAYGO,FLDS,DGFDD,DGNEW
"RTN","DGMSEUTL",34,0)
 S ECNT=0
"RTN","DGMSEUTL",35,0)
 ;Delete existing entries
"RTN","DGMSEUTL",36,0)
 I $G(DEL) F  S ECNT=$O(^DPT(DFN,.3216,ECNT)) Q:+ECNT'>0  D
"RTN","DGMSEUTL",37,0)
 .S DA(1)=DFN,DA=ECNT,DIK="^DPT("_DA(1)_",.3216," D ^DIK
"RTN","DGMSEUTL",38,0)
 ;Add service episodes
"RTN","DGMSEUTL",39,0)
 S SUB=""
"RTN","DGMSEUTL",40,0)
 F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D
"RTN","DGMSEUTL",41,0)
 .;Ignore if Service Entry Date is null
"RTN","DGMSEUTL",42,0)
 .Q:'+ARRAY(SUB)
"RTN","DGMSEUTL",43,0)
 .N DA,DIC,DD,DO,DLAYGO,FLDS,X
"RTN","DGMSEUTL",44,0)
 .S FLDS=ARRAY(SUB)
"RTN","DGMSEUTL",45,0)
 .S DIC="^DPT(DFN,.3216,"
"RTN","DGMSEUTL",46,0)
 .S DIC(0)="L",DLAYGO=2
"RTN","DGMSEUTL",47,0)
 .S DA(1)=DFN
"RTN","DGMSEUTL",48,0)
 .S X=$P(FLDS,U) ;Entry Date
"RTN","DGMSEUTL",49,0)
 .S DIC("DR")=".02////"_$P(FLDS,U,2) ;Separation Date
"RTN","DGMSEUTL",50,0)
 .S DIC("DR")=DIC("DR")_";.03////"_$P(FLDS,U,3) ;Service Branch
"RTN","DGMSEUTL",51,0)
 .S DIC("DR")=DIC("DR")_";.04////"_$P(FLDS,U,4) ;Service Component
"RTN","DGMSEUTL",52,0)
 .S DIC("DR")=DIC("DR")_";.05////"_$P(FLDS,U,5) ;Service Number
"RTN","DGMSEUTL",53,0)
 .S DIC("DR")=DIC("DR")_";.06////"_$P(FLDS,U,6) ;Discharge type
"RTN","DGMSEUTL",54,0)
 .S DIC("DR")=DIC("DR")_";.07////"_$P(FLDS,U,7) ;Locked
"RTN","DGMSEUTL",55,0)
 . ;DJS, Store FUTURE DISCHARGE DATE; DG*5.3*935
"RTN","DGMSEUTL",56,0)
 .S DIC("DR")=DIC("DR")_";.08///"_$P(FLDS,U,8) ;Future Discharge Date
"RTN","DGMSEUTL",57,0)
 .D FILE^DICN
"RTN","DGMSEUTL",58,0)
 Q
"RTN","DGMSEUTL",59,0)
 ;
"RTN","DGMSEUTL",60,0)
GETMSE(DFN,MSE) ;Return all records in MSE sub-file #2.3216 in MSE array
"RTN","DGMSEUTL",61,0)
 ;Records are sorted in reverse chronological order and the second
"RTN","DGMSEUTL",62,0)
 ;subscript is the MSE IEN in the multiple  e.g. MSE(1,4)=last
"RTN","DGMSEUTL",63,0)
 I '$G(DFN) Q
"RTN","DGMSEUTL",64,0)
 N I,SDT,IEN
"RTN","DGMSEUTL",65,0)
 S SDT=""
"RTN","DGMSEUTL",66,0)
 F I=1:1 S SDT=$O(^DPT(DFN,.3216,"B",SDT),-1) Q:'SDT  D
"RTN","DGMSEUTL",67,0)
 .S IEN=0 F  S IEN=$O(^DPT(DFN,.3216,"B",SDT,IEN)) Q:'IEN  D
"RTN","DGMSEUTL",68,0)
 ..I '$D(^DPT(DFN,.3216,IEN,0)) Q
"RTN","DGMSEUTL",69,0)
 ..S MSE(I)=^DPT(DFN,.3216,IEN,0)
"RTN","DGMSEUTL",70,0)
 ..S MSE(I,IEN)=""
"RTN","DGMSEUTL",71,0)
 Q
"RTN","DGMSEUTL",72,0)
 ;
"RTN","DGMSEUTL",73,0)
LAST(DFN) ;Return last (most recent) MSE
"RTN","DGMSEUTL",74,0)
 I '$G(DFN) Q ""
"RTN","DGMSEUTL",75,0)
 N MSE
"RTN","DGMSEUTL",76,0)
 D GETMSE(DFN,.MSE)
"RTN","DGMSEUTL",77,0)
 S MSE=$O(MSE(0))
"RTN","DGMSEUTL",78,0)
 Q $G(MSE(+MSE))
"RTN","DGMSEUTL",79,0)
 ;
"RTN","DGMSEUTL",80,0)
UPDMSE(DFN,DGNMSE) ;File MSE data from the HEC Z11 message
"RTN","DGMSEUTL",81,0)
 Q:'$G(DFN)  Q:'$D(DGNMSE)
"RTN","DGMSEUTL",82,0)
 N DGOMSE,DGTOT,DGCHG,DGN,DGO,I
"RTN","DGMSEUTL",83,0)
 S DGTOT=0,DGN="" F  S DGN=$O(DGNMSE(DGN)) Q:'DGN  S DGTOT=DGTOT+1
"RTN","DGMSEUTL",84,0)
 ;Get current MSE data for patient from MSE sub-file #2.3216
"RTN","DGMSEUTL",85,0)
 D GETMSE(DFN,.DGOMSE)
"RTN","DGMSEUTL",86,0)
 I $D(DGOMSE) D  Q:'DGCHG
"RTN","DGMSEUTL",87,0)
 .;Compare the old and new data.  If they match, no update is needed.
"RTN","DGMSEUTL",88,0)
 .S DGCHG=0
"RTN","DGMSEUTL",89,0)
 .I DGTOT'=$O(DGOMSE(""),-1) S DGCHG=1 Q
"RTN","DGMSEUTL",90,0)
 .S (DGO,DGN)=""
"RTN","DGMSEUTL",91,0)
 .F I=1:1:DGTOT S DGO=$O(DGOMSE(DGO)),DGN=$O(DGNMSE(DGN)) D  Q:DGCHG
"RTN","DGMSEUTL",92,0)
 ..I DGOMSE(DGO)'=DGNMSE(DGN) S DGCHG=1 Q
"RTN","DGMSEUTL",93,0)
 ;File the new MSE data from HEC, delete old data first if it exists
"RTN","DGMSEUTL",94,0)
 D MSE(DFN,.DGNMSE,$D(DGOMSE))
"RTN","DGMSEUTL",95,0)
 Q
"RTN","DGMSEUTL",96,0)
 ;
"RTN","DGMSEUTL",97,0)
ESRDATA(DFN) ;Check if any records in .3216 are from ESR
"RTN","DGMSEUTL",98,0)
 N IEN,LOCKED
"RTN","DGMSEUTL",99,0)
 S IEN=0,LOCKED=0
"RTN","DGMSEUTL",100,0)
 F  S IEN=$O(^DPT(DFN,.3216,IEN)) Q:'IEN  D  Q:LOCKED
"RTN","DGMSEUTL",101,0)
 .;Check if record is locked
"RTN","DGMSEUTL",102,0)
 .S LOCKED=$P($G(^DPT(DFN,.3216,IEN,0)),U,7)
"RTN","DGMSEUTL",103,0)
 ;Return LOCKED indicating ESR data found
"RTN","DGMSEUTL",104,0)
 Q LOCKED
"RTN","DGMSEUTL",105,0)
 ;
"RTN","DGMSEUTL",106,0)
WARNMSG(DFN) ;Warning Message if some episodes did not copy
"RTN","DGMSEUTL",107,0)
 N DATA32,OLDMSE,NEWMSE,DATA
"RTN","DGMSEUTL",108,0)
 ;If ESR data exists quit
"RTN","DGMSEUTL",109,0)
 Q:$$ESRDATA(DFN) 0
"RTN","DGMSEUTL",110,0)
 ;Count number of old episodes
"RTN","DGMSEUTL",111,0)
 N LBRANCH,LDATE,SDAT,NODT
"RTN","DGMSEUTL",112,0)
 S DATA32=$G(^DPT(DFN,.32))
"RTN","DGMSEUTL",113,0)
 S LDATE=$P(DATA32,U,6),LBRANCH=$P(DATA32,U,5),OLDMSE=0,NODT=0
"RTN","DGMSEUTL",114,0)
 ;If entry date or branch assume last episode exists
"RTN","DGMSEUTL",115,0)
 I LDATE!LBRANCH S OLDMSE=OLDMSE+1 S:'LDATE NODT=1
"RTN","DGMSEUTL",116,0)
 ;Check for second episode
"RTN","DGMSEUTL",117,0)
 I $P(DATA32,U,19)="Y" D
"RTN","DGMSEUTL",118,0)
 .S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,11) NODT=1
"RTN","DGMSEUTL",119,0)
 .;and third episode
"RTN","DGMSEUTL",120,0)
 .I $P(DATA32,U,20)="Y" S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,16) NODT=1
"RTN","DGMSEUTL",121,0)
 ;
"RTN","DGMSEUTL",122,0)
 ;If no old episodes no message is necessary
"RTN","DGMSEUTL",123,0)
 Q:'OLDMSE 0
"RTN","DGMSEUTL",124,0)
 ;
"RTN","DGMSEUTL",125,0)
 ;Count number of new episodes
"RTN","DGMSEUTL",126,0)
 S NEWMSE=0,SDAT=""
"RTN","DGMSEUTL",127,0)
 F  S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT  D
"RTN","DGMSEUTL",128,0)
 .S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
"RTN","DGMSEUTL",129,0)
 .S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
"RTN","DGMSEUTL",130,0)
 .S NEWMSE=NEWMSE+1
"RTN","DGMSEUTL",131,0)
 ;
"RTN","DGMSEUTL",132,0)
 ;If number old MSEs greater than new MSEs, and service entry date
"RTN","DGMSEUTL",133,0)
 ;is missing, return 1
"RTN","DGMSEUTL",134,0)
 I OLDMSE>NEWMSE,NODT Q 1
"RTN","DGMSEUTL",135,0)
 ;Otherwise, return 0
"RTN","DGMSEUTL",136,0)
 Q 0
"RTN","DGNOZMH")
0^13^B1893168
"RTN","DGNOZMH",1,0)
DGNOZMH ;ALB/CLT - NO ZMH SEGMENT IN Z11 HL7 MESSAGE AND CLEAN UP INCOMPLETE MILITARY SERVICE EPISODES ;21 Jul 2017  9:05 AM
"RTN","DGNOZMH",2,0)
 ;;5.3;REGISTRATION;**935**;AUG 13, 1993;Build 53
"RTN","DGNOZMH",3,0)
 ;
"RTN","DGNOZMH",4,0)
 ;The primary purpose of this routine is to delete all HEC
"RTN","DGNOZMH",5,0)
 ;issued military service episodes (MSE).
"RTN","DGNOZMH",6,0)
 ;
"RTN","DGNOZMH",7,0)
EN(DFN) ;Primary entry point
"RTN","DGNOZMH",8,0)
 Q:'$D(^DPT(DFN,.3216))
"RTN","DGNOZMH",9,0)
 N DGMSE,DGMSEDT,DIK,S
"RTN","DGNOZMH",10,0)
 S DGMSEDT=""
"RTN","DGNOZMH",11,0)
 F  S DGMSEDT=$O(^DPT(DFN,.3216,"B",DGMSEDT),-1) Q:DGMSEDT=""  D
"RTN","DGNOZMH",12,0)
 . S DGMSE="",DGMSE=$O(^DPT(DFN,.3216,"B",DGMSEDT,DGMSE))
"RTN","DGNOZMH",13,0)
 . Q:$P(^DPT(DFN,.3216,DGMSE,0),U,7)'=1
"RTN","DGNOZMH",14,0)
 . S DA=DGMSE,DA(1)=DFN
"RTN","DGNOZMH",15,0)
 . S DIK="^DPT("_DA(1)_","_.3216_"," D ^DIK
"RTN","DGNOZMH",16,0)
 . Q
"RTN","DGNOZMH",17,0)
 D INCDEL(DFN)
"RTN","DGNOZMH",18,0)
 Q
"RTN","DGNOZMH",19,0)
INCDEL(DFN) ;DELETE LAST MSE IF INCOMPLETE
"RTN","DGNOZMH",20,0)
 Q:'$D(^DPT(DFN,.3216))
"RTN","DGNOZMH",21,0)
 Q:$P(^DPT(DFN,.3216,0),U,4)=0
"RTN","DGNOZMH",22,0)
 Q:$P(^DPT(DFN,.3216,$P(^DPT(DFN,.3216,0),U,3),0),U,2)'=""
"RTN","DGNOZMH",23,0)
 Q:$P(^DPT(DFN,.3216,$P(^DPT(DFN,.3216,0),U,3),0),U,8)'=""
"RTN","DGNOZMH",24,0)
 S DA(1)=DFN,DA=$P(^DPT(DFN,.3216,0),U,3) S DIK="^DPT("_DA(1)_","_.3216_"," D ^DIK
"RTN","DGNOZMH",25,0)
 Q
"RTN","DGNOZMH",26,0)
ID1(DFN,DA,DGNEW) ;DELETE AN MSE IF INCOMPLETE
"RTN","DGNOZMH",27,0)
 Q:$G(DGNEW)=1
"RTN","DGNOZMH",28,0)
 G:$G(DA)="" IDQ
"RTN","DGNOZMH",29,0)
 Q:$L($P($G(^DPT(DFN,.3216,DA,0)),U,2))>4
"RTN","DGNOZMH",30,0)
 Q:$P(^DPT(DFN,.3216,DA,0),U,8)'=""
"RTN","DGNOZMH",31,0)
 S DA(1)=DFN,DIK="^DPT("_DA(1)_","_.3216_"," D ^DIK K DIK
"RTN","DGNOZMH",32,0)
IDQ ;
"RTN","DGNOZMH",33,0)
 Q
"RTN","DGRP61")
0^8^B57864374
"RTN","DGRP61",1,0)
DGRP61 ;ALB/PJH,LBD,DJS - Patient MSDS History - List Manager Screen ;16 Oct 2017 16:04:16
"RTN","DGRP61",2,0)
 ;;5.3;Registration;**797,909,935**;Aug 13,1993;Build 53
"RTN","DGRP61",3,0)
 ;
"RTN","DGRP61",4,0)
EN(DFN) ;Main entry point to invoke the DGEN MSDS PATIENT list
"RTN","DGRP61",5,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGRP61",6,0)
 ;
"RTN","DGRP61",7,0)
 D WAIT^DICD
"RTN","DGRP61",8,0)
 D EN^VALM("DGEN MSDS PATIENT")
"RTN","DGRP61",9,0)
 Q
"RTN","DGRP61",10,0)
 ;
"RTN","DGRP61",11,0)
HDR ;Header code
"RTN","DGRP61",12,0)
 N DGPREFNM,X,VA,VAERR
"RTN","DGRP61",13,0)
 S VALMHDR(1)=$J("",25)_"MILITARY SERVICE DATA, SCREEN <6.1>"
"RTN","DGRP61",14,0)
 D PID^VADPT
"RTN","DGRP61",15,0)
 S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
"RTN","DGRP61",16,0)
 S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")"
"RTN","DGRP61",17,0)
 S X="PATIENT TYPE UNKNOWN"
"RTN","DGRP61",18,0)
 I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
"RTN","DGRP61",19,0)
 S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80)
"RTN","DGRP61",20,0)
 S VALMHDR(3)=$J("",4)_"Service Branch/Component  Service #"
"RTN","DGRP61",21,0)
 S VALMHDR(3)=VALMHDR(3)_"        Entered    Separated   Discharge"
"RTN","DGRP61",22,0)
 Q
"RTN","DGRP61",23,0)
 ;
"RTN","DGRP61",24,0)
INIT ;Build patient MSDS screen
"RTN","DGRP61",25,0)
 D CLEAN^VALM10
"RTN","DGRP61",26,0)
 K ^TMP("DGRP61",$J),DGSEL
"RTN","DGRP61",27,0)
 ;
"RTN","DGRP61",28,0)
 N GLBL
"RTN","DGRP61",29,0)
 S GLBL=$NA(^TMP("DGRP61",$J))
"RTN","DGRP61",30,0)
 D GETMSE(DFN,GLBL,1)
"RTN","DGRP61",31,0)
 ;Check if any old MSEs didn't copy and display warning message
"RTN","DGRP61",32,0)
 I $$WARNMSG^DGMSEUTL(DFN) D
"RTN","DGRP61",33,0)
 .S VALMSG="**More MSEs available to view on History Screen**"
"RTN","DGRP61",34,0)
 .D MSG^VALM10(VALMSG)
"RTN","DGRP61",35,0)
 Q
"RTN","DGRP61",36,0)
 ;
"RTN","DGRP61",37,0)
GETMSE(DFN,GLBL,NUM) ;Load service episodes from .3216 array
"RTN","DGRP61",38,0)
 ; INPUT: DFN = Patient IEN
"RTN","DGRP61",39,0)
 ;        GLBL = ^TMP global ref
"RTN","DGRP61",40,0)
 ;        NUM = 1 - display line numbers
"RTN","DGRP61",41,0)
 N DGDATA,DGDATE,DGSUB,X1,X2,X
"RTN","DGRP61",42,0)
 ; DGSEL - selectable items, DGSEL("episode count") - episode count for DGSEL
"RTN","DGRP61",43,0)
 ; not all items may be selectable
"RTN","DGRP61",44,0)
 K DGSEL S VALMCNT=0,DGDATE="",DGSEL("episode count")=0
"RTN","DGRP61",45,0)
 F  S DGDATE=$O(^DPT(DFN,.3216,"B",DGDATE),-1) Q:'DGDATE  D
"RTN","DGRP61",46,0)
 . S DGSUB=$O(^DPT(DFN,.3216,"B",DGDATE,"")) Q:'DGSUB
"RTN","DGRP61",47,0)
 . S DGDATA=$G(^DPT(DFN,.3216,DGSUB,0)) Q:DGDATA=""
"RTN","DGRP61",48,0)
 . D EPISODE(DGDATA,GLBL,NUM)
"RTN","DGRP61",49,0)
 Q
"RTN","DGRP61",50,0)
 ;
"RTN","DGRP61",51,0)
EPISODE(DGDATA,GLBL,NUM) ;Format individual service episode
"RTN","DGRP61",52,0)
 N DGFDD,DGRPSB,DGRPSC,DGRPSD,DGRPSE,DGRPSN,DGRPSS,Z
"RTN","DGRP61",53,0)
 ; increment episode count
"RTN","DGRP61",54,0)
 S DGSEL("episode count")=DGSEL("episode count")+1
"RTN","DGRP61",55,0)
 S DGRPSB=+$P(DGDATA,U,3),DGRPSC=$P(DGDATA,U,4),DGRPSN=$P(DGDATA,U,5)
"RTN","DGRP61",56,0)
 ;Service Branch/Component
"RTN","DGRP61",57,0)
 S Z=$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:"UNKNOWN")
"RTN","DGRP61",58,0)
 I DGRPSC'="" D
"RTN","DGRP61",59,0)
 . N Z0
"RTN","DGRP61",60,0)
 . S Z0=$$SVCCOMP^DGRP6CL(DGRPSC) Q:Z0=""
"RTN","DGRP61",61,0)
 . S Z=Z_"/"_Z0
"RTN","DGRP61",62,0)
 ;Filipino vet proof
"RTN","DGRP61",63,0)
 I $$FV^DGRPMS(DGRPSB)=1 S Z=$E(Z_$J("",21),1,21)_"("_$P($G(^DPT(DFN,.321)),U,14)_")"
"RTN","DGRP61",64,0)
 ;Service Number
"RTN","DGRP61",65,0)
 S Z=Z_$J("",26-$L(Z))_$S(DGRPSN]"":DGRPSN,1:"UNKNOWN")
"RTN","DGRP61",66,0)
 S Z=Z_$J("",42-$L(Z))
"RTN","DGRP61",67,0)
 ;Entry and separation dates
"RTN","DGRP61",68,0)
 S DGRPSE=$P(DGDATA,U,1),DGRPSS=$P(DGDATA,U,2)
"RTN","DGRP61",69,0)
 S X=$S(DGRPSE]"":$$FMTE^XLFDT(DGRPSE,"5DZ"),1:"UNKNOWN   ")
"RTN","DGRP61",70,0)
 S Z=Z_$E(X,1,10)_"  "
"RTN","DGRP61",71,0)
 S X=$S(DGRPSS]"":$$FMTE^XLFDT(DGRPSS,"5DZ"),1:"UNKNOWN   ")
"RTN","DGRP61",72,0)
 S Z=Z_$E(X,1,10)_"  "
"RTN","DGRP61",73,0)
 ;DJS, Add FUTURE DISCHARGE DATE; DG*5.3*935
"RTN","DGRP61",74,0)
 ;DGFDD = FUTURE DISCHARGE DATE (internal)
"RTN","DGRP61",75,0)
 ;DGFDD("DISP") = FUTURE DISCHARGE DATE (display)
"RTN","DGRP61",76,0)
 S DGFDD=$P(DGDATA,U,8),DGFDD("DISP")=$S(DGFDD]"":$$FMTE^XLFDT(DGFDD,"5DZ"),1:"")
"RTN","DGRP61",77,0)
 ;Discharge type
"RTN","DGRP61",78,0)
 S DGRPSD=+$P(DGDATA,U,6)
"RTN","DGRP61",79,0)
 I 'DGRPSD S Z=Z_"UNKNOWN"
"RTN","DGRP61",80,0)
 E  S Z=Z_$S($D(^DIC(25,+DGRPSD)):$E($P(^DIC(25,DGRPSD,0),"^",1),1,9),1:"UNKNOWN")
"RTN","DGRP61",81,0)
 ;
"RTN","DGRP61",82,0)
 S VALMCNT=VALMCNT+1
"RTN","DGRP61",83,0)
 ; Add line numbers if NUM true
"RTN","DGRP61",84,0)
 I $G(NUM) D
"RTN","DGRP61",85,0)
 . ;DJS, Indicate MSE episode with FDD not editable or deletable; DG*5.3*935
"RTN","DGRP61",86,0)
 . ; not selectable, put < > around number, stop
"RTN","DGRP61",87,0)
 . I $G(DGRPV)!($P(DGDATA,U,7)]"")!($P(DGDATA,U,8)]"") S Z="<"_DGSEL("episode count")_"> "_Z Q
"RTN","DGRP61",88,0)
 . ; item is selectable, put into DGSEL, [ ] around number
"RTN","DGRP61",89,0)
 . S Z="["_DGSEL("episode count")_"] "_Z,DGSEL(DGSEL("episode count"))=DGRPSE
"RTN","DGRP61",90,0)
 ;
"RTN","DGRP61",91,0)
 ; Save to List Manager array for display
"RTN","DGRP61",92,0)
 S @GLBL@(VALMCNT,0)=$S($G(NUM):Z,1:$J("",4)_Z)
"RTN","DGRP61",93,0)
 D:DGFDD  ; if FDD found, add to display
"RTN","DGRP61",94,0)
 . S VALMCNT=VALMCNT+1,@GLBL@(VALMCNT,0)="    Future Discharge Date: "_DGFDD("DISP")
"RTN","DGRP61",95,0)
 Q
"RTN","DGRP61",96,0)
 ;
"RTN","DGRP61",97,0)
HELP ;Help code
"RTN","DGRP61",98,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","DGRP61",99,0)
 Q
"RTN","DGRP61",100,0)
 ;
"RTN","DGRP61",101,0)
EXIT ;Exit code
"RTN","DGRP61",102,0)
 D CLEAN^VALM10
"RTN","DGRP61",103,0)
 D CLEAR^VALM1
"RTN","DGRP61",104,0)
 K ^TMP("DGRP61",$J)
"RTN","DGRP61",105,0)
 Q
"RTN","DGRP61",106,0)
 ;
"RTN","DGRP61",107,0)
PEXIT ;DGEN MSDS MENU protocol exit code
"RTN","DGRP61",108,0)
 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
"RTN","DGRP61",109,0)
 ;Reset after page up or down
"RTN","DGRP61",110,0)
 ;D XQORM
"RTN","DGRP61",111,0)
 Q
"RTN","DGRP61",112,0)
 ;
"RTN","DGRP61",113,0)
ACT(DGACT) ; Entry point for menu action selection
"RTN","DGRP61",114,0)
 ; INPUT: DGACT = "A" - Add - DGEN MSDS ADD protocol
"RTN","DGRP61",115,0)
 ;              = "E" - Edit - DGEN MSDS EDIT protocol
"RTN","DGRP61",116,0)
 ;              = "D" - Delete - DGEN MSDS DELETE protocol
"RTN","DGRP61",117,0)
 N DGX,DA,DIE,DIC,DIK,DIPA,DR,X,Y
"RTN","DGRP61",118,0)
 I $G(DGACT)="" G ACTQ
"RTN","DGRP61",119,0)
 I $G(DGRPV) W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ
"RTN","DGRP61",120,0)
 D FULL^VALM1
"RTN","DGRP61",121,0)
 I DGACT="A" D ADD G ACTQ
"RTN","DGRP61",122,0)
 I '$O(DGSEL(0)) D  G ACTQ
"RTN","DGRP61",123,0)
 . W !,"There are no episodes to "_$S(DGACT="E":"edit.",1:"delete.")
"RTN","DGRP61",124,0)
 . I $G(VALMCNT) D HECHLP
"RTN","DGRP61",125,0)
 . D PAUSE^VALM1
"RTN","DGRP61",126,0)
 S DGX=$$SEL(DGACT) I 'DGX G ACTQ
"RTN","DGRP61",127,0)
 S DGX=$G(DGSEL(DGX)) I 'DGX G ACTQ
"RTN","DGRP61",128,0)
 S DA(1)=DFN,DIC="^DPT("_DA(1)_",.3216,",DIC(0)="BX",X=DGX
"RTN","DGRP61",129,0)
 D ^DIC I Y<0 W !,"This episode is not in the patient's record." D PAUSE^VALM1 G ACTQ
"RTN","DGRP61",130,0)
 S DIPA("DA")=+Y
"RTN","DGRP61",131,0)
 I DGACT="E" K DA,DIC,DGFRDT S DIE="^DPT(",DA=DFN D SETDR1 D ^DIE G ACTQ
"RTN","DGRP61",132,0)
 ; deletion, ask user first
"RTN","DGRP61",133,0)
 I DGACT="D",$$RUSURE S DIK=DIC,DA(1)=DFN,DA=DIPA("DA") D ^DIK K DA,DIK
"RTN","DGRP61",134,0)
 ;
"RTN","DGRP61",135,0)
 ; DG*5.3*909 Potentially change Camp Lejeune to No with MSE changes
"RTN","DGRP61",136,0)
ACTQ ; menu action exit point 
"RTN","DGRP61",137,0)
 D INIT S VALMBCK="R" D SETCLNO^DGENCLEA Q
"RTN","DGRP61",138,0)
 ;
"RTN","DGRP61",139,0)
ADD ; Add new MSE to #2.3216 sub-file
"RTN","DGRP61",140,0)
 N X,Y,DIK,DA,DR,DIE,NEXT,DGFRDT
"RTN","DGRP61",141,0)
 ; Get next record number in sub-file
"RTN","DGRP61",142,0)
 S NEXT=$O(^DPT(DFN,.3216,"A"),-1),NEXT=NEXT+1
"RTN","DGRP61",143,0)
 D ZNODE(1)
"RTN","DGRP61",144,0)
 ; Prompt for MSE fields
"RTN","DGRP61",145,0)
 S DIE="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D SETDR2 D ^DIE
"RTN","DGRP61",146,0)
 I X["BAD" S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK
"RTN","DGRP61",147,0)
 ; Check if new record is missing or incomplete
"RTN","DGRP61",148,0)
 I '$D(^DPT(DFN,.3216,NEXT)) D ZNODE(-1) Q
"RTN","DGRP61",149,0)
 I '$P(^DPT(DFN,.3216,NEXT,0),U) D  Q
"RTN","DGRP61",150,0)
 .S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK D ZNODE(-1)
"RTN","DGRP61",151,0)
 ;
"RTN","DGRP61",152,0)
 ; File FILIPINO VET PROOF, if set
"RTN","DGRP61",153,0)
 I $G(DIPA("FVP"))]"" D
"RTN","DGRP61",154,0)
 .K DA,DR S DIE="^DPT(",DA=DFN,DR=".3214///^S X=DIPA(""FVP"")"
"RTN","DGRP61",155,0)
 .D ^DIE
"RTN","DGRP61",156,0)
 Q
"RTN","DGRP61",157,0)
 ;
"RTN","DGRP61",158,0)
SEL(ACT) ; function, prompt for episode to edit/delete
"RTN","DGRP61",159,0)
 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
"RTN","DGRP61",160,0)
 ; range is 1 to episode count, must be in DGSEL to be selectable
"RTN","DGRP61",161,0)
 S DIR(0)="NAO^1:"_DGSEL("episode count")_"^K:'$D(DGSEL(X)) X"
"RTN","DGRP61",162,0)
 S DIR("A")="Select Episode: "
"RTN","DGRP61",163,0)
 S DIR("?")="^D SELHLP^DGRP61(ACT)"
"RTN","DGRP61",164,0)
 D ^DIR I 'Y Q 0
"RTN","DGRP61",165,0)
 Q Y
"RTN","DGRP61",166,0)
 ;
"RTN","DGRP61",167,0)
SELHLP(ACT) ; Help message for episode prompt
"RTN","DGRP61",168,0)
 W !,"Select an episode to ",$S(ACT="E":"edit.",1:"delete.")
"RTN","DGRP61",169,0)
 W !,"Only numbers in square brackets [ ] are selectable."
"RTN","DGRP61",170,0)
 D HECHLP
"RTN","DGRP61",171,0)
 N DIR D PAUSE^VALM1
"RTN","DGRP61",172,0)
 Q
"RTN","DGRP61",173,0)
HECHLP ; Help message for episodes that can only be changed by HEC
"RTN","DGRP61",174,0)
 W !,"Angled brackets < > indicate episodes that cannot be changed in VistA."
"RTN","DGRP61",175,0)
 W !,"Please contact the HECAlert mail group or the HEC if you need to update"
"RTN","DGRP61",176,0)
 W !,"this information."
"RTN","DGRP61",177,0)
 Q
"RTN","DGRP61",178,0)
 ;
"RTN","DGRP61",179,0)
ZNODE(VAL) ; Update zero node of MSE multiple .3216
"RTN","DGRP61",180,0)
 Q:'$G(VAL)  Q:'$G(DFN)
"RTN","DGRP61",181,0)
 N ZNODE
"RTN","DGRP61",182,0)
 S ZNODE=$G(^DPT(DFN,.3216,0))
"RTN","DGRP61",183,0)
 S ^DPT(DFN,.3216,0)="^2.3216D^"_($P(ZNODE,U,3)+VAL)_U_($P(ZNODE,U,4)+VAL)
"RTN","DGRP61",184,0)
 Q
"RTN","DGRP61",185,0)
SETDR1 ; Set DR array to edit MSE fields
"RTN","DGRP61",186,0)
 S DR="I '$G(DIPA(""DA"")) S Y=0;.3216////^S X=""`""_DIPA(""DA"");.3214///^S X=$G(DIPA(""FVP""))"
"RTN","DGRP61",187,0)
 S DR(2,2.3216)="D SET0^DGRP61(.DA,.DIPA);@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61"
"RTN","DGRP61",188,0)
 S DR(2,2.3216,1)="I DIPA(""FVP"")=""^"" K DIPA(""FVP"") S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";S Y=""@63"""
"RTN","DGRP61",189,0)
 S DR(2,2.3216,2)="@62;D:DIPA(""X"")]"""" WARN^DGRP61(.DIPA,.Y);.04;@63;.05;.01;.02;.06"
"RTN","DGRP61",190,0)
 Q
"RTN","DGRP61",191,0)
SETDR2 ; Set DR array to add MSE fields
"RTN","DGRP61",192,0)
 S DR="@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61;I DIPA(""FVP"")=""^"" S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";@62;S:'$$CMP^DGRP61(DIPA(""X"")) Y=""@63"";.04;@63;.05;.01;.02;.06"
"RTN","DGRP61",193,0)
 Q
"RTN","DGRP61",194,0)
FVP() ; Prompt for FILIPINO VET PROOF
"RTN","DGRP61",195,0)
 N DA,X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",196,0)
 S DIR(0)="2,.3214",DA=DFN
"RTN","DGRP61",197,0)
 D ^DIR I Y=""!(Y="^") Q Y
"RTN","DGRP61",198,0)
 Q Y
"RTN","DGRP61",199,0)
 ;
"RTN","DGRP61",200,0)
SET0(DA,DIPA) ; Set DIPA(0) to values of Service Branch and Service Component
"RTN","DGRP61",201,0)
 K DIPA(0)
"RTN","DGRP61",202,0)
 S DIPA(0)=$P($G(^DPT(DA(1),.3216,DA,0)),U,3,4)
"RTN","DGRP61",203,0)
 Q
"RTN","DGRP61",204,0)
 ;
"RTN","DGRP61",205,0)
WARN(DIPA,Y) ;Warns that the Service Branch was changed so the
"RTN","DGRP61",206,0)
 ; Service Component was deleted
"RTN","DGRP61",207,0)
 ; Returns Y to skip component if the component should not be asked
"RTN","DGRP61",208,0)
 ;   for this branch of service
"RTN","DGRP61",209,0)
 I '$$CMP($G(DIPA("X"))) S Y="@63"
"RTN","DGRP61",210,0)
 I $P($G(DIPA(0)),U,2)=""!($P($G(DIPA(0)),U)="") Q
"RTN","DGRP61",211,0)
 I $P(DIPA(0),U)=DIPA("X") Q   ;Service Branch didn't change
"RTN","DGRP61",212,0)
 ;
"RTN","DGRP61",213,0)
 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
"RTN","DGRP61",214,0)
 Q
"RTN","DGRP61",215,0)
 ;
"RTN","DGRP61",216,0)
CMP(X) ; Function to determine if service component is valid for
"RTN","DGRP61",217,0)
 ; branch of service ien in X   0 = invalid  1 = valid  
"RTN","DGRP61",218,0)
 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
"RTN","DGRP61",219,0)
 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
"RTN","DGRP61",220,0)
 ;
"RTN","DGRP61",221,0)
RUSURE() ; Confirmation prompt for deleting episode
"RTN","DGRP61",222,0)
 N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",223,0)
 S DIR(0)="YA",DIR("B")="NO"
"RTN","DGRP61",224,0)
 S DIR("A")="Are you sure you want to delete this military service episode? "
"RTN","DGRP61",225,0)
 D ^DIR I 'Y W !,"<< NOTHING DELETED >>" Q 0
"RTN","DGRP61",226,0)
 Q 1
"RTN","DGRP61",227,0)
 ;
"RTN","DGRPCF")
0^3^B26225283
"RTN","DGRPCF",1,0)
DGRPCF ;ALB/MRL,BAJ,TDM,DJE - CONSISTENCY OF PATIENT DATA (FILE/EDIT) ;Sep 28, 2017  5:35PM
"RTN","DGRPCF",2,0)
 ;;5.3;Registration;**250,653,786,754,867,935**;Aug 13, 1993;Build 53
"RTN","DGRPCF",3,0)
 ;
"RTN","DGRPCF",4,0)
 ; file new inconsistencies or update file entries for patient
"RTN","DGRPCF",5,0)
 ;
"RTN","DGRPCF",6,0)
 ; DGCT = count of inconsistencies found (passed in from checker)
"RTN","DGRPCF",7,0)
 ; DGCT1= count of inconsistencies which can't be edited because
"RTN","DGRPCF",8,0)
 ;        user does not hold appropriate key
"RTN","DGRPCF",9,0)
 ; DGCT2= count of already filed inconsistencies
"RTN","DGRPCF",10,0)
 ; DGCT3= count of inconsistencies which are uneditable through
"RTN","DGRPCF",11,0)
 ;        checker options
"RTN","DGRPCF",12,0)
 ; DGCTZ7= count of inconsistencies found that will prevent Z07
"RTN","DGRPCF",13,0)
 ;
"RTN","DGRPCF",14,0)
 ;
"RTN","DGRPCF",15,0)
 ; 
"RTN","DGRPCF",16,0)
EN I '$D(DGCT) G KVAR^DGRPCE
"RTN","DGRPCF",17,0)
 ; DG*5.3*653 BAJ modified to delete only inconsistencies numbered 99 or less
"RTN","DGRPCF",18,0)
 N DGADD S DGADD=0 ;786 corrects problem with incorrect header
"RTN","DGRPCF",19,0)
 ;I 'DGCT,$O(^DGIN(38.5,DFN,"I",""),-1)>99 D DELETE G KVAR^DGRPCE
"RTN","DGRPCF",20,0)
 I 'DGCT D DELETE G KVAR^DGRPCE
"RTN","DGRPCF",21,0)
 S DGEDCN=+$G(DGEDCN),DGRPOUT=+$G(DGRPOUT),DGCON=1 D:DGEDCN START^DGRPC I 'DGCT D ^DGRPCF1,TIMEQ^DGRPC G KVAR^DGRPCE
"RTN","DGRPCF",22,0)
 S:'$D(^DGIN(38.5,DFN,0)) ^(0)=DFN_"^"_DT_"^"_$S(('$D(DUZ)#2):"",1:DUZ),DGADD=1 S X=$P(^(0),"^",4),^DGIN(38.5,DFN,0)=$P(^(0),"^",1,3)_"^"_DT_"^"_$S(('$D(DUZ)#2):"",1:DUZ)_"^"_$P(^(0),"^",6) K ^DGIN(38.5,"AC",9999999-X,DFN)
"RTN","DGRPCF",23,0)
 S ^DGIN(38.5,"B",DFN,DFN)="",^DGIN(38.5,"AC",9999999-DT,DFN)="",^DGIN(38.5,0)=$P(^DGIN(38.5,0),"^",1,2)_"^"_DFN_"^"_($P(^(0),"^",4)+DGADD) ;786 corrected for incorrect header
"RTN","DGRPCF",24,0)
 I $D(^DGIN(38.5,DFN,"I")) D DELETE
"RTN","DGRPCF",25,0)
 S DGD2=0 F DGD=1:1 S DGD1=$P(DGER,",",DGD) Q:DGD1=""  I $D(^DGIN(38.6,DGD1,0)) S DGD2=DGD1 S ^DGIN(38.5,DFN,"I",DGD1,0)=DGD1
"RTN","DGRPCF",26,0)
 S ^DGIN(38.5,DFN,"I",0)="^38.51PA^"_DGD2_"^"_DGCT I DGCT,DGEDCN G DIS
"RTN","DGRPCF",27,0)
 G KVAR^DGRPCE
"RTN","DGRPCF",28,0)
 ;
"RTN","DGRPCF",29,0)
 ;DJE DG*5.3*935 - Add Member ID To Vista Registration Banner - RM#879322 (added SSNNM call)
"RTN","DGRPCF",30,0)
DIS D TIME^DGRPC S DGRPE=$S($D(DGRPE):DGRPE+1,1:0) D KEY S IOP="HOME" D ^%ZIS K IOP W @IOF,! D DEM^VADPT W $$SSNNM^DGRPU(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",79)="" W !,X
"RTN","DGRPCF",31,0)
 S (C,DGCT1,DGCT2,DGCT3,DGCTZ7)=0,DGEDIT="0000000011111110011111113333222223313333332222220030000" F I=1:1 S J=$P(DGER,",",I) Q:J=""  I $D(^DGIN(38.6,J,0)) S X2=$P(^(0),"^",1) D WRIT
"RTN","DGRPCF",32,0)
 I DGCT1!DGCT3 W ! D NOEDIT
"RTN","DGRPCF",33,0)
 I DGCTZ7 W !!,"Inconsistencies followed by [+] will prevent a Z07"
"RTN","DGRPCF",34,0)
 S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1)
"RTN","DGRPCF",35,0)
EDIT G:DGRPOUT BUL I DGCT1+DGCT3'=DGCT W !!,"DO YOU WANT TO UPDATE THESE INCONSISTENCIES NOW" S %=1 D YN^DICN I %=1 D  G ^DGRPC
"RTN","DGRPCF",36,0)
 . S DGINC55=$S(DGER'[55:0,($G(DGRPVV(9))'["0"):0,1:1)
"RTN","DGRPCF",37,0)
 . L +^DPT(DFN):3 E  W *7,!!,"Patient is being edited. Try again later."  S DGEDCN=0 Q
"RTN","DGRPCF",38,0)
 . D ^DGRPCE
"RTN","DGRPCF",39,0)
 . L -^DPT(DFN)
"RTN","DGRPCF",40,0)
 . S DGEDCN=1
"RTN","DGRPCF",41,0)
 I $S(($G(DGRETURN)>10):0,$G(DGINC55):1,1:0) D
"RTN","DGRPCF",42,0)
 .N DIR
"RTN","DGRPCF",43,0)
 .S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? ",DIR("B")="YES" D ^DIR
"RTN","DGRPCF",44,0)
 .S:Y>0 DGRPV=0
"RTN","DGRPCF",45,0)
 .S:Y>0 DGRETURN=$G(DGRETURN)+1
"RTN","DGRPCF",46,0)
 I $S($G(Y)'>0:0,(DGRETURN>11):0,1:1) D ^DGRPV G ^DGRP9
"RTN","DGRPCF",47,0)
 I DGCT1+DGCT3'=DGCT,'% W !!?4,"YES - To correct inconsistencies to unrestricted fields immediately.",!?4,"NO  - To abort this process immediately." G EDIT
"RTN","DGRPCF",48,0)
 I DGER[313 D
"RTN","DGRPCF",49,0)
 . N DIR
"RTN","DGRPCF",50,0)
 . S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #15 to enter Sponsor information? ",DIR("B")="YES" D ^DIR
"RTN","DGRPCF",51,0)
 . S:Y>0 DGRPV=0
"RTN","DGRPCF",52,0)
 . S:Y>0 DGRETURN=$G(DGRETURN)+1
"RTN","DGRPCF",53,0)
 I $G(Y)>0&(DGER[313) D ^DGRPV G ^DGRP15
"RTN","DGRPCF",54,0)
BUL K DGRETURN,X,Y D ^DGRPCB G KVAR^DGRPCE
"RTN","DGRPCF",55,0)
 ;
"RTN","DGRPCF",56,0)
WRIT ;S C=C+1 W:(C#2) ! S X1=$S((C#2):0,1:40) W ?X1,$E(J_"  ",1,3),"- ",X2 I DGKEY(+$E(DGEDIT,J)) W "*" S DGCT1=DGCT1+1
"RTN","DGRPCF",57,0)
 S C=C+1 W:(C#2) ! S X1=$S((C#2):0,1:40) W ?X1,$E(J_"  ",1,3),"- "
"RTN","DGRPCF",58,0)
 W X2 I DGKEY(+$E(DGEDIT,J))!(J=407) W "*" S DGCT1=DGCT1+1
"RTN","DGRPCF",59,0)
 I "^17^55^313^314^"[("^"_+J_"^") W "**" S DGCT3=DGCT3+1
"RTN","DGRPCF",60,0)
 I +$P(DGRPCOLD,",",2),DGRPCOLD'[(","_J_",") S DGCT2=DGCT2+1
"RTN","DGRPCF",61,0)
 I $P($G(^DGIN(38.6,J,0)),"^",6) W "+" S DGCTZ7=DGCTZ7+1
"RTN","DGRPCF",62,0)
 Q
"RTN","DGRPCF",63,0)
KEY S X=$S(('$D(DUZ)#2):1,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):1,1:0) F I=.3,.32,.361 S DGP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPCF",64,0)
 F I=0:1:4 S DGKEY(I)=""
"RTN","DGRPCF",65,0)
 I $P(DGP(.361),"^",1)="V",X S DGKEY(1)=1
"RTN","DGRPCF",66,0)
 I $P(DGP(.3),"^",6)]"",X S DGKEY(2)=1
"RTN","DGRPCF",67,0)
 I $P(DGP(.32),"^",2)]"",X S DGKEY(3)=1
"RTN","DGRPCF",68,0)
 S:'X DGKEY(4)=1 K DGP Q
"RTN","DGRPCF",69,0)
 ;
"RTN","DGRPCF",70,0)
DELETE ; Delete all Registration inconsistencies from INCONSISTENT DATA file (#38.5).
"RTN","DGRPCF",71,0)
 ; 
"RTN","DGRPCF",72,0)
 ;
"RTN","DGRPCF",73,0)
 N RULE,DIK,DA
"RTN","DGRPCF",74,0)
 ;
"RTN","DGRPCF",75,0)
 S RULE=0,DA=""
"RTN","DGRPCF",76,0)
 S DIK="^DGIN(38.5,"_DFN_","_"""I"""_","
"RTN","DGRPCF",77,0)
 ;F  S RULE=$O(^DGIN(38.5,DFN,"I",RULE)) Q:RULE=""  Q:RULE>99  S DA=RULE D ^DIK
"RTN","DGRPCF",78,0)
 F  S RULE=$O(^DGIN(38.5,DFN,"I",RULE)) Q:RULE=""  D
"RTN","DGRPCF",79,0)
 . I RULE>99,OVER99'[(","_RULE_",") Q
"RTN","DGRPCF",80,0)
 . S DA=RULE D ^DIK
"RTN","DGRPCF",81,0)
 Q
"RTN","DGRPCF",82,0)
 ;
"RTN","DGRPCF",83,0)
NOEDIT ; write explanation of non-editable items
"RTN","DGRPCF",84,0)
 I DGCT1 W !,"You will not be able to edit inconsistencies followed by an asterisk [*]",!,"as you do not hold the appropriate ""DG ELIGIBILITY"" security key."
"RTN","DGRPCF",85,0)
 I DGCT3 W !,"Inconsistencies followed by two (2) asterisks [**] must be corrected by",!,"using the appropriate MAS menu option(s)."
"RTN","DGRPCF",86,0)
 I DGCT1+DGCT3'=DGCT W !!,"All items not followed by an asterisk can be edited at this time.  If these",!,"items are not corrected at this time, a bulletin will be sent to the",!,"appropriate hospital personnel."
"RTN","DGRPCF",87,0)
 ;;QUIT
"RTN","DGRPD1")
0^2^B7682498
"RTN","DGRPD1",1,0)
DGRPD1 ;BPFO/JRC,BAJ,DJE - PATIENT INQUIRY (NEW) ;Sep 28, 2017  5:35PM
"RTN","DGRPD1",2,0)
 ;;5.3;Registration;**703,730,688,863,935**;Aug 13, 1993;Build 53
"RTN","DGRPD1",3,0)
 ; DG*5.3*688 BAJ
"RTN","DGRPD1",4,0)
 ; tags HDR & OKLINE moved as is from DGRPD for size considerations
"RTN","DGRPD1",5,0)
 Q
"RTN","DGRPD1",6,0)
EC ;display emergency contact information
"RTN","DGRPD1",7,0)
 N DGEC1,DGEC2
"RTN","DGRPD1",8,0)
 Q:'$G(DFN)
"RTN","DGRPD1",9,0)
 S VAOA("A")=1,VAROOT="DGEC1"  D OAD^VADPT ; Get Primary EC
"RTN","DGRPD1",10,0)
 S VAOA("A")=4,VAROOT="DGEC2"  D OAD^VADPT ; Get Secondary EC
"RTN","DGRPD1",11,0)
 I DGEC1(9)]"" D
"RTN","DGRPD1",12,0)
 . W !,"Emergency Contact Information:"
"RTN","DGRPD1",13,0)
 . ;Contacts name and realtionship
"RTN","DGRPD1",14,0)
 . W !?5,"E-Cont.: ",DGEC1(9)
"RTN","DGRPD1",15,0)
 . I DGEC2(9)]"" W ?40,"E2-Cont.: ",DGEC2(9)
"RTN","DGRPD1",16,0)
 . W !,"Relationship: ",DGEC1(10)
"RTN","DGRPD1",17,0)
 . I DGEC2(9)]"" W ?36,"Relationship: ",DGEC2(10)
"RTN","DGRPD1",18,0)
 . ;ECs address lines 1, 2 and 3
"RTN","DGRPD1",19,0)
 . I DGEC1(1)]"" W !?14,DGEC1(1)
"RTN","DGRPD1",20,0)
 . I DGEC1(1)']"",DGEC2(1)]"" W !
"RTN","DGRPD1",21,0)
 . I DGEC2(1)]"" W ?50,DGEC2(1)
"RTN","DGRPD1",22,0)
 . I DGEC1(2)]"" W !?14,DGEC1(2)
"RTN","DGRPD1",23,0)
 . I DGEC1(2)']"",DGEC2(2)]"" W !
"RTN","DGRPD1",24,0)
 . I DGEC2(2)]"" W ?50,DGEC2(2)
"RTN","DGRPD1",25,0)
 . I DGEC1(3)]"" W !?14,DGEC1(3)
"RTN","DGRPD1",26,0)
 . I DGEC1(3)']"",DGEC2(3)]"" W !
"RTN","DGRPD1",27,0)
 . I DGEC2(3)]"" W ?50,DGEC2(3)
"RTN","DGRPD1",28,0)
 . ;Emergency Contact 1 City, State an Zip+4
"RTN","DGRPD1",29,0)
 . I DGEC1(4)]"" D
"RTN","DGRPD1",30,0)
 . . W !?14,DGEC1(4)
"RTN","DGRPD1",31,0)
 . . I DGEC1(5)]"" W ", "_$$GET1^DIQ(5,+DGEC1(5),1)
"RTN","DGRPD1",32,0)
 . . W "  ",$P(DGEC1(11),"^",2)
"RTN","DGRPD1",33,0)
 . ;Emergency Contact 2 City State and Zip+4
"RTN","DGRPD1",34,0)
 . I DGEC2(4)]"" D
"RTN","DGRPD1",35,0)
 . . I DGEC1(4)']"" W !
"RTN","DGRPD1",36,0)
 . . W ?50,DGEC2(4)
"RTN","DGRPD1",37,0)
 . . I DGEC2(5)]"" W ", "_$$GET1^DIQ(5,+DGEC2(5),1)
"RTN","DGRPD1",38,0)
 . . W "  ",$P(DGEC2(11),"^",2)
"RTN","DGRPD1",39,0)
 .;Home and work phones
"RTN","DGRPD1",40,0)
 . W !,?7,"Phone: ",$S(DGEC1(8)]"":DGEC1(8),1:"UNSPECIFIED")
"RTN","DGRPD1",41,0)
 . I DGEC2(9)]"" W ?43,"Phone: ",$S(DGEC2(8)]"":DGEC2(8),1:"UNSPECIFIED")
"RTN","DGRPD1",42,0)
 . W !?2,"Work Phone: ",$S($P(^DPT(DFN,.33),U,11)]"":$P(^DPT(DFN,.33),U,11),1:"UNSPECIFIED")
"RTN","DGRPD1",43,0)
 . I DGEC2(9)]"" W ?38,"Work Phone: ",$S($P(^DPT(DFN,.331),U,11)]"":$P(^DPT(DFN,.331),U,11),1:"UNSPECIFIED")
"RTN","DGRPD1",44,0)
 D KVAR^VADPT
"RTN","DGRPD1",45,0)
 Q
"RTN","DGRPD1",46,0)
 ;
"RTN","DGRPD1",47,0)
CATDIS ;
"RTN","DGRPD1",48,0)
 ;displays catastrophic disabity review date if there is one
"RTN","DGRPD1",49,0)
 N DGCDIS
"RTN","DGRPD1",50,0)
 Q:'$G(DFN)
"RTN","DGRPD1",51,0)
 I $$GET^DGENCDA(DFN,.DGCDIS) D
"RTN","DGRPD1",52,0)
 .Q:'DGCDIS("REVDTE")
"RTN","DGRPD1",53,0)
 .W !!,"Catastrophically Disabled Review Date: ",$$FMTE^XLFDT(DGCDIS("REVDTE"),1)
"RTN","DGRPD1",54,0)
 Q
"RTN","DGRPD1",55,0)
HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
"RTN","DGRPD1",56,0)
 ;MPI/PD CHANGE
"RTN","DGRPD1",57,0)
 ;DJE DG*5.3*935 - Add Member ID To Vista Registration Banner - RM#879322 (added SSNNM call)
"RTN","DGRPD1",58,0)
 W @IOF,!,$$SSNNM^DGRPU(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,! Q  ;**863 - MVI_2351 (ptd) 
"RTN","DGRPD1",59,0)
 ;END MPI/PD CHANGE
"RTN","DGRPD1",60,0)
OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
"RTN","DGRPD1",61,0)
 ;
"RTN","DGRPD1",62,0)
 ;IN:   DGLINE --MAX LINE COUNT W/O PAUSE
"RTN","DGRPD1",63,0)
 ;OUT:  DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
"RTN","DGRPD1",64,0)
 ;      DGRPOUT[SET]     -- 1 IF "
"RTN","DGRPD1",65,0)
 N X,Y  ;**286** MLR 09/25/00  Newing X & Y variables prior to ^DIR
"RTN","DGRPD1",66,0)
 I $G(IOST)["P-" Q DGLINE ; if printer, quit
"RTN","DGRPD1",67,0)
 I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0
"RTN","DGRPD1",68,0)
 Q DGLINE
"RTN","DGRPD1",69,0)
 ;
"RTN","DGRPMS")
0^11^B68853041
"RTN","DGRPMS",1,0)
DGRPMS ;ALB/BRM,LBD,DJS - MILITARY SERVICE APIS ;11 Oct 2017  11:14am
"RTN","DGRPMS",2,0)
 ;;5.3;Registration;**451,626,646,673,689,688,797,935**;Aug 13, 1993;Build 53
"RTN","DGRPMS",3,0)
 ;
"RTN","DGRPMS",4,0)
VALCON1(DFN,IEN,CDATE,FRTO) ; Valid conflict input for OIF/OEF/UNKNOWN OEF/OIF?
"RTN","DGRPMS",5,0)
 ; Need to send the ien of the multiple as well as the DFN and
"RTN","DGRPMS",6,0)
 ; determine the specific conflict area
"RTN","DGRPMS",7,0)
 N Z
"RTN","DGRPMS",8,0)
 S Z=$P("OIF^OEF^UNK",U,+$G(^DPT(DFN,.3215,+IEN,0)))
"RTN","DGRPMS",9,0)
 ;Q:Z="UNK" 1  ; Never need to check this - only entered through HEC
"RTN","DGRPMS",10,0)
 Q $$VALCON(DFN,Z_"-"_IEN,CDATE,FRTO)
"RTN","DGRPMS",11,0)
 ;
"RTN","DGRPMS",12,0)
VALCON(DFN,CNFLCT,CDATE,FRTO,OEIFAIL) ;is this a valid conflict input?
"RTN","DGRPMS",13,0)
 ;
"RTN","DGRPMS",14,0)
 ;INPUT:
"RTN","DGRPMS",15,0)
 ;      FRTO - 0=FRDT 1=TODT  (defaults to FRDT if FRTO="")
"RTN","DGRPMS",16,0)
 ;OUTPUT:
"RTN","DGRPMS",17,0)
 ;      OEIFAIL = 1 for not within MSE for OIF/OEF data (pass by ref)
"RTN","DGRPMS",18,0)
 ;
"RTN","DGRPMS",19,0)
 N RTN,X,Y,FRDT,TODT,CNFLCTV,IGNORE,COMPOW,MSG,DTCHK,CNFLCT2,OEFOIF
"RTN","DGRPMS",20,0)
 S OEIFAIL=0
"RTN","DGRPMS",21,0)
 Q:'$D(DFN) "0^INVALID PATIENT"
"RTN","DGRPMS",22,0)
 Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
"RTN","DGRPMS",23,0)
 Q:'$$VALID^DGRPDT(.CDATE) "0^INVALID DATE"
"RTN","DGRPMS",24,0)
 S FRTO=+$G(FRTO)
"RTN","DGRPMS",25,0)
 I 'FRTO S TODT=$$GETDT(DFN,.CNFLCT),FRDT=CDATE K DGFRDT
"RTN","DGRPMS",26,0)
 E  S FRDT=$$GETDT(DFN,.CNFLCT,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=CDATE K DGFRDT
"RTN","DGRPMS",27,0)
 S DTCHK=$$DTUTIL^DGRPDT(CDATE,$$GETDT(DFN,.CNFLCT,'FRTO),1)
"RTN","DGRPMS",28,0)
 I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) Q DTCHK
"RTN","DGRPMS",29,0)
 I CNFLCT="COMB"!(CNFLCT="POW") D
"RTN","DGRPMS",30,0)
 .S COMPOW=$S(CNFLCT="COMB":1,1:2)
"RTN","DGRPMS",31,0)
 .S CNFLCT2=CNFLCT
"RTN","DGRPMS",32,0)
 .S CNFLCT=$$COMPOW($S($G(DGCOMLOC):$P(DGCOMLOC,"^"),1:$$GETDT(DFN,CNFLCT,3)))
"RTN","DGRPMS",33,0)
 S CNFLCTV=""
"RTN","DGRPMS",34,0)
 I CNFLCT]"" S CNFLCTV=$$CNFLCTDT^DGRPDT(FRDT,$S(FRTO:TODT,1:""),.CNFLCT)
"RTN","DGRPMS",35,0)
 I ('CNFLCTV) D MSG($P(CNFLCTV,"^",2),2,1) Q CNFLCTV  ;dates are not within conflict
"RTN","DGRPMS",36,0)
 ;
"RTN","DGRPMS",37,0)
 S MSG=$S('$G(COMPOW):"Conflict",$G(COMPOW)=2:"POW",1:"Combat")
"RTN","DGRPMS",38,0)
 I FRDT,TODT,'$$B4^DGRPDT(FRDT,TODT,0) D MSG((MSG_" From Date is not Before "_MSG_" To Date"),2,1) Q "0^"_MSG_" From Date is not Before "_MSG_" To Date"
"RTN","DGRPMS",39,0)
 S IGNORE=$S('$P(CNFLCT,"-",2):$P($P($T(@($P(CNFLCT,"-"))),";;",2),"^",FRTO+1),1:"")
"RTN","DGRPMS",40,0)
 S:$G(COMPOW) IGNORE=$P($P($T(@(CNFLCT2)),";;",2),"^",FRTO+1)
"RTN","DGRPMS",41,0)
 ; 
"RTN","DGRPMS",42,0)
 ; Check for overlaps and dates w/in MSE's, except for POW DG*5.3*688
"RTN","DGRPMS",43,0)
 S RTN=1
"RTN","DGRPMS",44,0)
 I $G(COMPOW)'=2 D
"RTN","DGRPMS",45,0)
 . S OEFOIF=$S($P(CNFLCT,"-",2):$P(CNFLCT,"-",2)_U_CNFLCT,1:""),RTN=$$COVRLP2^DGRPDT(DFN,FRDT,TODT,IGNORE,.OEFOIF)
"RTN","DGRPMS",46,0)
 . I 'RTN,$G(OEFOIF),$G(OEFOIF(1)) S OEIFAIL=1
"RTN","DGRPMS",47,0)
 Q:RTN RTN
"RTN","DGRPMS",48,0)
 D MSG($P(RTN,"^",2),2,1)
"RTN","DGRPMS",49,0)
 Q RTN
"RTN","DGRPMS",50,0)
 ;
"RTN","DGRPMS",51,0)
VALMSE(DFN,MDATE,FRTO,FLD) ;is this a valid Military Service Episode date?
"RTN","DGRPMS",52,0)
 ;
"RTN","DGRPMS",53,0)
 ;INPUT:
"RTN","DGRPMS",54,0)
 ;      FRTO - 0=FRDT 1=TODT  (defaults to FRDT if FRTO="")
"RTN","DGRPMS",55,0)
 ;       FLD - MSE field being edited/added (MSL,MSNTL,MSNNTL)
"RTN","DGRPMS",56,0)
 ;             "MSE-"_IEN of MSE in sub-file #2.3216 (DG*5.3*797)
"RTN","DGRPMS",57,0)
 ;
"RTN","DGRPMS",58,0)
 N DTCHK,DUPCHK,FDDFLAG,FRDT,IGNORE,RTN,TODT,X,Y
"RTN","DGRPMS",59,0)
 ; DGCOMBR - branch of service, from input transforms
"RTN","DGRPMS",60,0)
 ; FDDFLAG - boolean for FDD overlap
"RTN","DGRPMS",61,0)
 Q:'$D(DFN) "0^INVALID PATIENT"
"RTN","DGRPMS",62,0)
 Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
"RTN","DGRPMS",63,0)
 Q:'$$VALID^DGRPDT(.MDATE) "0^INVALID DATE"
"RTN","DGRPMS",64,0)
 ; DJS, Check for Future Discharge Date overlap; DG*5.3*935
"RTN","DGRPMS",65,0)
 S (FDDFLAG,X)=0 F  S X=$O(^DPT(DFN,.3216,X)) Q:'X!FDDFLAG  S Y=$G(^(X,0)) I $P(Y,U,8),'(MDATE>$P(Y,U,8))&'(MDATE<$P(Y,U)) S FDDFLAG=1
"RTN","DGRPMS",66,0)
 I FDDFLAG D  Q "0^FDD date overlap"
"RTN","DGRPMS",67,0)
 . D MSG("Date overlaps with a record that has a Future Discharge Date.",2,1)
"RTN","DGRPMS",68,0)
 ;
"RTN","DGRPMS",69,0)
 S FRTO=+$G(FRTO)
"RTN","DGRPMS",70,0)
 I 'FRTO S FRDT=MDATE,TODT=$$GETDT(DFN,.FLD,FRTO) K DGFRDT
"RTN","DGRPMS",71,0)
 E  S FRDT=$$GETDT(DFN,.FLD,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=MDATE K DGFRDT
"RTN","DGRPMS",72,0)
 S DTCHK=$$DTUTIL^DGRPDT(MDATE,$$GETDT(DFN,.FLD,'FRTO),1)
"RTN","DGRPMS",73,0)
 I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) K DGCOMBR Q DTCHK
"RTN","DGRPMS",74,0)
 ;Check for duplicate Service Entry Date
"RTN","DGRPMS",75,0)
 I 'FRTO,FRDT S DUPCHK=$$DUPCHK(DFN,.FRDT,.FLD) I 'DUPCHK D MSG($P(DUPCHK,"^",2),2,2) Q DUPCHK
"RTN","DGRPMS",76,0)
 I FRTO,FRDT,TODT,'$$B4^DGRPDT(.FRDT,.TODT,0) D MSG("Service Entry Date is not before Service Separation Date",2,1) K DGCOMBR Q "0^Service Entry Date is not before Service Separation Date"
"RTN","DGRPMS",77,0)
 S IGNORE=$P($P($T(@($P(FLD,"-"))),";;",2),"^",FRTO+1)
"RTN","DGRPMS",78,0)
 S RTN=$$OVRLPCHK^DGRPDT(.DFN,.FRDT,.TODT,1,.IGNORE,,$P(FLD,"MSE-",2))
"RTN","DGRPMS",79,0)
 I $G(DGCOMBR)']"" S DGCOMBR=$$GETDT(DFN,.FLD,4)
"RTN","DGRPMS",80,0)
 I RTN,FRTO,$$BRANCH(.DGCOMBR),('$$WWII(DFN,TODT,.FLD)) D MSG("Branch of Service Requires WWII Dates of Service",2,1) K DGCOMBR Q "0^BOS Requires WWII Dates"
"RTN","DGRPMS",81,0)
 K DGCOMBR
"RTN","DGRPMS",82,0)
 Q:RTN RTN
"RTN","DGRPMS",83,0)
 D MSG($P(RTN,"^",2),2,1)
"RTN","DGRPMS",84,0)
 Q RTN
"RTN","DGRPMS",85,0)
 ;
"RTN","DGRPMS",86,0)
BRANCH(DGCOMBR) ;branches of service that require WWII service dates
"RTN","DGRPMS",87,0)
 N BRANCH
"RTN","DGRPMS",88,0)
 Q:'$G(DGCOMBR) 0
"RTN","DGRPMS",89,0)
 S BRANCH=$P(DGCOMBR,"^",2)
"RTN","DGRPMS",90,0)
 Q:BRANCH="MERCHANT SEAMAN" 1
"RTN","DGRPMS",91,0)
 Q:BRANCH="F.COMMONWEALTH" 1
"RTN","DGRPMS",92,0)
 Q:BRANCH="F.GUERILLA" 1
"RTN","DGRPMS",93,0)
 Q:BRANCH="F.SCOUTS NEW" 1
"RTN","DGRPMS",94,0)
 Q:BRANCH="F.SCOUTS OLD" 1
"RTN","DGRPMS",95,0)
 Q 0
"RTN","DGRPMS",96,0)
 ;
"RTN","DGRPMS",97,0)
VALCOMP(DFN,CODE,DGEPI) ; Verify component is consistent with the corresponding
"RTN","DGRPMS",98,0)
 ;  branch of service  Also, branch of service must be entered before
"RTN","DGRPMS",99,0)
 ;  component.
"RTN","DGRPMS",100,0)
 ;  ACTIVATED NATIONAL GUARD (G) only valid for ARMY or AIR FORCE branch
"RTN","DGRPMS",101,0)
 ;  ACTIVATED RESERVE (V) only valid for ARMY, AIR FORCE, MARINES, NAVY
"RTN","DGRPMS",102,0)
 ;                    or COAST GUARD branch
"RTN","DGRPMS",103,0)
 ; DFN = ien of patient in file 2
"RTN","DGRPMS",104,0)
 ; DGEPI = episode # to check (1=LAST, 2=NTL, 3=NNTL)
"RTN","DGRPMS",105,0)
 ; CODE = the component code
"RTN","DGRPMS",106,0)
 ; OUTPUT: 1 if valid component
"RTN","DGRPMS",107,0)
 ;         0 if invalid component or branch of serv missing
"RTN","DGRPMS",108,0)
 N Z
"RTN","DGRPMS",109,0)
 ;Get BOS from MSE multiple .3216 if DGEPI contains "MSE" (DG*5.3*797)
"RTN","DGRPMS",110,0)
 I $G(DGEPI)["MSE" S Z=+$P($G(^DPT(DFN,.3216,+DGEPI,0)),U,3)
"RTN","DGRPMS",111,0)
 E  S Z=+$P($G(^DPT(DFN,.32)),U,DGEPI*5)
"RTN","DGRPMS",112,0)
 I 'Z Q 0  ; Require bos
"RTN","DGRPMS",113,0)
 I CODE="R" Q 1  ; Regular is valid for all
"RTN","DGRPMS",114,0)
 Q:Z=1!(Z=2) 1  ; Army (1)/air force (2) valid for guard and reserves
"RTN","DGRPMS",115,0)
 ; reserves also include navy (3), marines (4), coast guard (5)
"RTN","DGRPMS",116,0)
 I CODE="V" Q $S(Z>2&(Z<6):1,1:0)
"RTN","DGRPMS",117,0)
 ;
"RTN","DGRPMS",118,0)
 Q 0
"RTN","DGRPMS",119,0)
 ;
"RTN","DGRPMS",120,0)
GETDT(DFN,CNFLCT,FRTO) ; get from date, to date, or location from patient file
"RTN","DGRPMS",121,0)
 ;
"RTN","DGRPMS",122,0)
 N CFLDS,CFLD,CNF1,CNF2,RTN1,IENS,FILE
"RTN","DGRPMS",123,0)
 Q:'$D(DFN) ""
"RTN","DGRPMS",124,0)
 Q:'$D(^DPT(DFN)) ""
"RTN","DGRPMS",125,0)
 Q:$G(CNFLCT)="" ""
"RTN","DGRPMS",126,0)
 S:$G(FRTO)="" FRTO=0
"RTN","DGRPMS",127,0)
 S CNF1=$P(CNFLCT,"-"),CNF2=+$P(CNFLCT,"-",2)
"RTN","DGRPMS",128,0)
 ; OEF/OIF/ UNKNOWN OEF/OIF data without a supplied entry in the
"RTN","DGRPMS",129,0)
 ;   multiple cannot be retrieved  OEF-1 indicates an OEF location
"RTN","DGRPMS",130,0)
 ;   stored at the '1' subscript of the .3215 multiple
"RTN","DGRPMS",131,0)
 I "^OEF^OIF^UNK^"[(U_CNF1_U),'CNF2 Q ""
"RTN","DGRPMS",132,0)
 ; MSE data retrieved from .3216 multiple (DG*5.3*797)
"RTN","DGRPMS",133,0)
 I CNF1="MSE",'CNF2 Q ""
"RTN","DGRPMS",134,0)
 S CFLDS=$P($T(@(CNF1)),";;",2) Q:CFLDS']"" ""
"RTN","DGRPMS",135,0)
 S CFLD=$S('FRTO:$P(CFLDS,"^",2),FRTO=1:$P(CFLDS,"^"),1:$P(CFLDS,"^",3))
"RTN","DGRPMS",136,0)
 Q:'CFLD ""
"RTN","DGRPMS",137,0)
 S IENS=DFN_",",FILE=2
"RTN","DGRPMS",138,0)
 ; For MSE set ref to sub-file 2.3216 (DG*5.3*797)
"RTN","DGRPMS",139,0)
 ; For OIF/OEF set ref to sub-file 2.3215
"RTN","DGRPMS",140,0)
 S:CNF2 IENS=CNF2_","_IENS,FILE=$S(CNF1="MSE":2.3216,1:2.3215)
"RTN","DGRPMS",141,0)
 S RTN1=$$GET1^DIQ(FILE,IENS,CFLD,"I")
"RTN","DGRPMS",142,0)
 I FRTO=4 S RTN1=RTN1_"^"_$$EXTERNAL^DILFD(FILE,CFLD,"",RTN1)
"RTN","DGRPMS",143,0)
 Q RTN1
"RTN","DGRPMS",144,0)
 ;
"RTN","DGRPMS",145,0)
WWII(DFN,TODT,FLD) ; was this patient in WWII?
"RTN","DGRPMS",146,0)
 ;  this API assumes the WWII period to be from 12/07/41-12/31/46
"RTN","DGRPMS",147,0)
 ;
"RTN","DGRPMS",148,0)
 N OK,NODE,DATA,WWIIS,WWIIE,PATDT,PATE,PATS
"RTN","DGRPMS",149,0)
 Q:'$G(DFN) "-1^UNKNOWN"
"RTN","DGRPMS",150,0)
 ; Use MSE data from sub-file #2.3216 (DG*5.3*797)
"RTN","DGRPMS",151,0)
 I $G(FLD)["MSE" S NODE(2.3216)=".01,.02"
"RTN","DGRPMS",152,0)
 E  S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
"RTN","DGRPMS",153,0)
 S WWIIS=2411207,WWIIE=2461231
"RTN","DGRPMS",154,0)
 D GETDAT^DGRPDT(DFN,.NODE,.DATA)
"RTN","DGRPMS",155,0)
 S PATDT=$G(FLD) Q:PATDT']"" 0
"RTN","DGRPMS",156,0)
 S PATS=$P($G(DATA(PATDT)),"^"),PATE=$P($G(DATA(PATDT)),"^",2)
"RTN","DGRPMS",157,0)
 S:'$G(TODT) TODT=PATE
"RTN","DGRPMS",158,0)
 S OK=0
"RTN","DGRPMS",159,0)
 S OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,PATS)
"RTN","DGRPMS",160,0)
 S:'OK OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,TODT)
"RTN","DGRPMS",161,0)
 S:'OK OK=$$RWITHIN^DGRPDT(PATS,TODT,WWIIS,WWIIE)
"RTN","DGRPMS",162,0)
 Q $G(OK)
"RTN","DGRPMS",163,0)
DELMSE(DFN,TYPE) ; delete MSE from patient
"RTN","DGRPMS",164,0)
 ;
"RTN","DGRPMS",165,0)
 ; Input: DFN - Internal entry number for the Patient File (#2)
"RTN","DGRPMS",166,0)
 ;       TYPE - 1=Last MSE  2=Next to Last MSE  3=Next to Next to Last
"RTN","DGRPMS",167,0)
 ;
"RTN","DGRPMS",168,0)
 Q:'$G(TYPE)
"RTN","DGRPMS",169,0)
 Q:(('$G(DFN))!'$D(^DPT(DFN)))
"RTN","DGRPMS",170,0)
 N IENS,FDA,X,X1,X2,Y,ZZ,ROOT
"RTN","DGRPMS",171,0)
 S IENS=DFN_",",ROOT="FDA(2,IENS)",X=""
"RTN","DGRPMS",172,0)
 I TYPE=1 F ZZ=.324,.326,.327,.328 S @ROOT@(ZZ)=X
"RTN","DGRPMS",173,0)
 I TYPE=2 F ZZ=.329,.3292,.3293,.3294 S @ROOT@(ZZ)=X
"RTN","DGRPMS",174,0)
 I TYPE=3 F ZZ=.3295,.3297,.3298,.3299 S @ROOT@(ZZ)=X
"RTN","DGRPMS",175,0)
 D FILE^DIE("K","FDA","ERR")
"RTN","DGRPMS",176,0)
 Q
"RTN","DGRPMS",177,0)
 ;
"RTN","DGRPMS",178,0)
COMPOW(VAL) ;convert POW and Combat Location fields
"RTN","DGRPMS",179,0)
 ;
"RTN","DGRPMS",180,0)
 N ABRV
"RTN","DGRPMS",181,0)
 Q:'$G(VAL) ""
"RTN","DGRPMS",182,0)
 S ABRV=$$GET1^DIQ(22,VAL_",",1,"I")
"RTN","DGRPMS",183,0)
 Q:ABRV="WWI" "WWI"
"RTN","DGRPMS",184,0)
 Q:ABRV="WWII-EUROPE" "WWIIE"
"RTN","DGRPMS",185,0)
 Q:ABRV="WWII-PACIFIC" "WWIIP"
"RTN","DGRPMS",186,0)
 Q:ABRV="KOREAN" "KOR"
"RTN","DGRPMS",187,0)
 Q:ABRV="VIETNAM" "VIET"
"RTN","DGRPMS",188,0)
 Q:ABRV="OTHER" "OTHER"
"RTN","DGRPMS",189,0)
 Q:ABRV="PERSIAN GULF" "GULF"
"RTN","DGRPMS",190,0)
 Q:ABRV="YUGOSLAVIA" "YUG"
"RTN","DGRPMS",191,0)
 Q:ABRV="SOMALIA" "SOM"
"RTN","DGRPMS",192,0)
 Q ""
"RTN","DGRPMS",193,0)
 ;
"RTN","DGRPMS",194,0)
FV(X) ;Is this a Filipino Vet branch of service?
"RTN","DGRPMS",195,0)
 ;Added for HVE II (DG*5.3*451)
"RTN","DGRPMS",196,0)
 ;INPUT:  X = IEN Branch of Service file #23
"RTN","DGRPMS",197,0)
 ;OUTPUT: 1 = Filipino Vet BOS (F.COMMONWEALTH, F.GUERILLA, F.SCOUTS NEW)
"RTN","DGRPMS",198,0)
 ;        2 = Filipino Vet BOS (F.SCOUTS OLD)
"RTN","DGRPMS",199,0)
 ;        0 = Not Filipino Vet BOS
"RTN","DGRPMS",200,0)
 N FV
"RTN","DGRPMS",201,0)
 I '$G(X) Q 0
"RTN","DGRPMS",202,0)
 S FV=$P($G(^DIC(23,X,0)),U,1)
"RTN","DGRPMS",203,0)
 Q $S(FV="F.SCOUTS OLD":2,$E(FV,1,2)="F.":1,1:0)
"RTN","DGRPMS",204,0)
 ;
"RTN","DGRPMS",205,0)
FVP ;MUMPS cross-reference "AFV1" on Service Branch [Last] (#.325), "AFV2"
"RTN","DGRPMS",206,0)
 ;on Service Branch [NTL] (#.3291), and "AFV3" on Service Branch [NNTL]
"RTN","DGRPMS",207,0)
 ;(#.3296) in the Patient file #2.  If the Service Branch fields do not
"RTN","DGRPMS",208,0)
 ;contain a Filipino Veteran branch of service, the Filipino Vet Proof
"RTN","DGRPMS",209,0)
 ;field (#.3214) will be deleted.
"RTN","DGRPMS",210,0)
 Q:'$G(DA)
"RTN","DGRPMS",211,0)
 N BOS,MS,FV,IENS,FDA
"RTN","DGRPMS",212,0)
 S MS=$G(^DPT(DA,.32))
"RTN","DGRPMS",213,0)
 F BOS=5,10,15 S FV=$$FV($P(MS,U,BOS)) Q:FV=1
"RTN","DGRPMS",214,0)
 I FV=1 Q  ;Filipino Vet BOS found, quit
"RTN","DGRPMS",215,0)
 ;Delete Filipino Vet Proof
"RTN","DGRPMS",216,0)
 S IENS=DA_",",FDA(2,IENS,.3214)="@"
"RTN","DGRPMS",217,0)
 D FILE^DIE("","FDA")
"RTN","DGRPMS",218,0)
 Q
"RTN","DGRPMS",219,0)
 ;
"RTN","DGRPMS",220,0)
FVP1 ;MUMPS cross-reference "AFV3216" on the Service Branch field (#.03)
"RTN","DGRPMS",221,0)
 ;in the Military Service Episode sub-file (#2.3216) of the Patient
"RTN","DGRPMS",222,0)
 ;file (#2).  If none of the Service Branch fields in the multiple
"RTN","DGRPMS",223,0)
 ;contain a Filipino Veteran branch of service, the Filipino Vet Proof
"RTN","DGRPMS",224,0)
 ;field (#.3214) will be deleted.
"RTN","DGRPMS",225,0)
 ;Added for DG*5.3*797
"RTN","DGRPMS",226,0)
 Q:'$G(DA(1))
"RTN","DGRPMS",227,0)
 N BOS,MS,FV,IENS,FDA
"RTN","DGRPMS",228,0)
 S (FV,MS)=0
"RTN","DGRPMS",229,0)
 F  S MS=$O(^DPT(DA(1),.3216,MS)) Q:'MS!(FV=1)  D
"RTN","DGRPMS",230,0)
 .I $G(DA)=MS Q
"RTN","DGRPMS",231,0)
 .S BOS=$P($G(^DPT(DA(1),.3216,MS,0)),U,3)
"RTN","DGRPMS",232,0)
 .S FV=$$FV(BOS)
"RTN","DGRPMS",233,0)
 I FV=1 Q  ;Filipino Vet BOS found, quit
"RTN","DGRPMS",234,0)
 ;Delete Filipino Vet Proof
"RTN","DGRPMS",235,0)
 S IENS=DA(1)_",",FDA(2,IENS,.3214)="@"
"RTN","DGRPMS",236,0)
 D FILE^DIE("","FDA")
"RTN","DGRPMS",237,0)
 Q
"RTN","DGRPMS",238,0)
 ;
"RTN","DGRPMS",239,0)
DUPCHK(DFN,FRDT,FLD) ; Check for duplicate Service Entry Date
"RTN","DGRPMS",240,0)
 ;INPUT:   DFN = Patient file IEN
"RTN","DGRPMS",241,0)
 ;        FRDT = Service Entry Date being checked
"RTN","DGRPMS",242,0)
 ;         FLD = "MSE-"_IEN of 2.3216 sub-file record
"RTN","DGRPMS",243,0)
 ;OUTPUT:  DUP = Error message if duplicate found
"RTN","DGRPMS",244,0)
 ;           1 = No duplicate found
"RTN","DGRPMS",245,0)
 N MSEIEN,IEN,MSE,DUP
"RTN","DGRPMS",246,0)
 I '$G(DFN) Q 1
"RTN","DGRPMS",247,0)
 I '$G(FRDT) Q 1
"RTN","DGRPMS",248,0)
 S MSEIEN=$P($G(FLD),"MSE-",2) I 'MSEIEN Q 1
"RTN","DGRPMS",249,0)
 ; Get MSE data
"RTN","DGRPMS",250,0)
 D GETMSE^DGMSEUTL(DFN,.MSE) I '$D(MSE) Q 1
"RTN","DGRPMS",251,0)
 S IEN=0 F  S IEN=$O(MSE(IEN)) Q:'IEN  D
"RTN","DGRPMS",252,0)
 .I FRDT=$P(MSE(IEN),"^"),'$D(MSE(IEN,MSEIEN)) S DUP="0^Duplicate Service Entry Date not allowed"
"RTN","DGRPMS",253,0)
 I $D(DUP) Q DUP
"RTN","DGRPMS",254,0)
 Q 1
"RTN","DGRPMS",255,0)
 ;
"RTN","DGRPMS",256,0)
MSG(MSGTXT,LF1,LF2) ; This api will format the output text in order to utilize
"RTN","DGRPMS",257,0)
 ; the EN^DDIOL utility.
"RTN","DGRPMS",258,0)
 ;INPUT:  MSGTXT = Message text to display
"RTN","DGRPMS",259,0)
 ;           LF1 = Number of line feeds to preceed the message
"RTN","DGRPMS",260,0)
 ;           L2F = Number of line feeds to follow the message
"RTN","DGRPMS",261,0)
 ;        
"RTN","DGRPMS",262,0)
 N MSGARY,LFSTR
"RTN","DGRPMS",263,0)
 S $P(LFSTR,"!",50)="!"
"RTN","DGRPMS",264,0)
 S:$G(LF1)'="" MSGARY(.5,"F")=$E(LFSTR,1,(LF1-1))
"RTN","DGRPMS",265,0)
 S MSGARY(1)=MSGTXT
"RTN","DGRPMS",266,0)
 S:$G(LF2)'="" MSGARY(2,"F")=$E(LFSTR,1,LF2)
"RTN","DGRPMS",267,0)
 D EN^DDIOL(.MSGARY)
"RTN","DGRPMS",268,0)
 Q
"RTN","DGRPMS",269,0)
 ;
"RTN","DGRPMS",270,0)
CNFLCT ;; ***  DO NOT REMOVE BELOW CONFLICT FIELD LOCATIONS  ***
"RTN","DGRPMS",271,0)
 ;; FROM DATE^TO DATE
"RTN","DGRPMS",272,0)
WWI ;;
"RTN","DGRPMS",273,0)
WWIIE ;;
"RTN","DGRPMS",274,0)
WWIIP ;;
"RTN","DGRPMS",275,0)
KOR ;;
"RTN","DGRPMS",276,0)
VIET ;;.32104^.32105
"RTN","DGRPMS",277,0)
LEB ;;.3222^.3223
"RTN","DGRPMS",278,0)
GREN ;;.3225^.3226
"RTN","DGRPMS",279,0)
PAN ;;.3228^.3229
"RTN","DGRPMS",280,0)
GULF ;;.322011^.322012
"RTN","DGRPMS",281,0)
SOM ;;.322017^.322018
"RTN","DGRPMS",282,0)
YUG ;;.32202^.322021
"RTN","DGRPMS",283,0)
OEF ;;.02^.03
"RTN","DGRPMS",284,0)
OIF ;;.02^.03
"RTN","DGRPMS",285,0)
UNK ;;.02^.03
"RTN","DGRPMS",286,0)
 ;;
"RTN","DGRPMS",287,0)
 ;;  **BELOW VALUES ARE USED FOR MSE CHECKS - DO NOT REMOVE ***
"RTN","DGRPMS",288,0)
 ;; ENTRY DATE^SEPARATION DATE
"RTN","DGRPMS",289,0)
MSE ;;.01^.02^.03
"RTN","DGRPMS",290,0)
MSL ;;.326^.327^.325
"RTN","DGRPMS",291,0)
MSNTL ;;.3292^.3293^.3291
"RTN","DGRPMS",292,0)
MSNNTL ;;.3297^.3298^.3296
"RTN","DGRPMS",293,0)
 ;;
"RTN","DGRPMS",294,0)
 ;;  **BELOW VALUES ARE USED FOR POW AND COMBAT CHECKS - DO NOT REMOVE
"RTN","DGRPMS",295,0)
 ;; FROM DATE^TO DATE^LOCATION
"RTN","DGRPMS",296,0)
COMB ;;.5293^.5294^.5292
"RTN","DGRPMS",297,0)
POW ;;.527^.528^.526
"RTN","DGRPMS",298,0)
 ;;
"RTN","DGRPU")
0^1^B88766469
"RTN","DGRPU",1,0)
DGRPU ;ALB/MRL,TMK,BAJ,DJE - REGISTRATION UTILITY ROUTINE ;Sep 28, 2017  5:35PM
"RTN","DGRPU",2,0)
 ;;5.3;Registration;**33,114,489,624,672,689,688,935**;Aug 13, 1993;Build 53
"RTN","DGRPU",3,0)
H ;Screen Header
"RTN","DGRPU",4,0)
 I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
"RTN","DGRPU",5,0)
 I DGRPS=1.1 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
"RTN","DGRPU",6,0)
 S X=$$SSNNM(DFN)
"RTN","DGRPU",7,0)
 I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
"RTN","DGRPU",8,0)
 S X="",$P(X,"=",80)="" W !,X Q
"RTN","DGRPU",9,0)
 Q
"RTN","DGRPU",10,0)
AL(DGLEN) ;DGLEN= Available length of line
"RTN","DGRPU",11,0)
A ;Format address(es)
"RTN","DGRPU",12,0)
 ; DG*5.3*688 BAJ 12/20/2005 modified for foreign address
"RTN","DGRPU",13,0)
 I '$D(DGLEN) N DGLEN S DGLEN=29
"RTN","DGRPU",14,0)
 N I,DGX,FILE,IEN,CNTRY,TMP,FNODE,FPCE,ROU
"RTN","DGRPU",15,0)
 ; set up variables
"RTN","DGRPU",16,0)
 S FNODE=$S(DGAD=.121:.122,1:DGAD),FPCE=$S(DGAD=.121:3,DGAD=.141:16,1:10)
"RTN","DGRPU",17,0)
 ; collect Street Address info
"RTN","DGRPU",18,0)
 F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S TMP(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2
"RTN","DGRPU",19,0)
 I DGA2=1 S TMP(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2
"RTN","DGRPU",20,0)
 ; retrieve country info -- PERM country is piece 10 of node .11
"RTN","DGRPU",21,0)
 S FOR=0
"RTN","DGRPU",22,0)
 I DGA1=1 D
"RTN","DGRPU",23,0)
 . S FILE=779.004,IEN=$P(DGRP(FNODE),U,FPCE),CNTRY=$E($$CNTRYI^DGADDUTL(IEN),1,25) I CNTRY=-1 S CNTRY="UNKNOWN COUNTRY"
"RTN","DGRPU",24,0)
 . ; assemble (US) CITY, STATE ZIP or (FOREIGN) CITY PROVINCE POSTAL CODE
"RTN","DGRPU",25,0)
 . S FOR=$$FORIEN^DGADDUTL(IEN) I FOR=-1 S FOR=1
"RTN","DGRPU",26,0)
 S ROU=$S(FOR=1:"FOREIGN",1:"US")_"(DGAD,.TMP,DGA1,.DGA2)" D @ROU
"RTN","DGRPU",27,0)
 ; append COUNTRY to address
"RTN","DGRPU",28,0)
 S DGA2=DGA2+2,TMP(DGA2)=$S($G(CNTRY)="":"",1:CNTRY)
"RTN","DGRPU",29,0)
 M DGA=TMP
"RTN","DGRPU",30,0)
 K DGA1
"RTN","DGRPU",31,0)
 Q
"RTN","DGRPU",32,0)
 ;
"RTN","DGRPU",33,0)
US(DGAD,TMP,DGA1,DGA2) ;process US addresses and format in DGA array
"RTN","DGRPU",34,0)
 ; DG*5.3*688 BAJ this is the code for all addresses prior to the addition of Foreign address logic.
"RTN","DGRPU",35,0)
 ; Modifications for Foreign address are in Tag FOREIGN
"RTN","DGRPU",36,0)
 N DGX,I,J
"RTN","DGRPU",37,0)
 ; format STATE field and merge with CITY & ZIP
"RTN","DGRPU",38,0)
 S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),TMP(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
"RTN","DGRPU",39,0)
 ; zip code capture
"RTN","DGRPU",40,0)
 I ".33^.34^.211^.331^.311^.25^.21"[DGAD D
"RTN","DGRPU",41,0)
 .F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I)
"RTN","DGRPU",42,0)
 E  D
"RTN","DGRPU",43,0)
 .I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q
"RTN","DGRPU",44,0)
 .S DGX=$P(DGRP(DGAD),U,DGA1+11)
"RTN","DGRPU",45,0)
 ; format ZIP+4 with hyphen
"RTN","DGRPU",46,0)
 S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9)
"RTN","DGRPU",47,0)
 ;combine CITY,STATE and ZIP fields on a single line
"RTN","DGRPU",48,0)
 S TMP(DGA2)=$E($P(TMP(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(TMP(DGA2),",",2)):",",1:"")_$P(TMP(DGA2),",",2)_" "_DGX
"RTN","DGRPU",49,0)
 F I=0:0 S I=$O(TMP(I)) Q:'I  S TMP(I)=$E(TMP(I),1,DGLEN)
"RTN","DGRPU",50,0)
 Q
"RTN","DGRPU",51,0)
 ;
"RTN","DGRPU",52,0)
FOREIGN(DGAD,TMP,DGA1,DGA2) ;process FOREIGN addresses and format in DGA array
"RTN","DGRPU",53,0)
 N I,J,CITY,PRVNCE,PSTCD,FNODE
"RTN","DGRPU",54,0)
 F I=1:1 S J=$P($T(FNPCS+I),";;",3) Q:J="QUIT"  D
"RTN","DGRPU",55,0)
 . I DGAD=$P(J,";",1) S FNODE=$P(J,";",2),CITY=$P(J,";",3),PRVNCE=$P(J,";",4),PSTCD=$P(J,";",5)
"RTN","DGRPU",56,0)
 ; assemble CITY PROVINCE and POSTAL CODE on the same line
"RTN","DGRPU",57,0)
 ; NOTE CITY is sometimes on a different node than the PROVINCE & POSTAL CODE
"RTN","DGRPU",58,0)
 S TMP(DGA2)=$P(DGRP(FNODE),U,PSTCD)_" "_$P(DGRP(DGAD),U,CITY)_" "_$P(DGRP(FNODE),U,PRVNCE)
"RTN","DGRPU",59,0)
 F I=0:0 S I=$O(TMP(I)) Q:'I  S TMP(I)=$E(TMP(I),1,DGLEN)
"RTN","DGRPU",60,0)
 Q
"RTN","DGRPU",61,0)
 ;
"RTN","DGRPU",62,0)
W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q
"RTN","DGRPU",63,0)
 W ?X,@DGVI,Z,@DGVO
"RTN","DGRPU",64,0)
 Q
"RTN","DGRPU",65,0)
 ;
"RTN","DGRPU",66,0)
FNPCS ; Foreign data pieces.  Structure-->Description;;Main Node;Data Node;City;Province;Postal code.
"RTN","DGRPU",67,0)
 ;;Permanent;;.11;.11;4;8;9
"RTN","DGRPU",68,0)
 ;;Temporary;;.121;.122;4;1;2
"RTN","DGRPU",69,0)
 ;;Confidential;;.141;.141;4;14;15
"RTN","DGRPU",70,0)
 ;;QUIT;;QUIT
"RTN","DGRPU",71,0)
 ;
"RTN","DGRPU",72,0)
H1 ;
"RTN","DGRPU",73,0)
 ;;PATIENT DEMOGRAPHIC DATA
"RTN","DGRPU",74,0)
 ;;PATIENT DATA
"RTN","DGRPU",75,0)
 ;;EMERGENCY CONTACT DATA
"RTN","DGRPU",76,0)
 ;;APPLICANT/SPOUSE EMPLOYMENT DATA
"RTN","DGRPU",77,0)
 ;;INSURANCE DATA
"RTN","DGRPU",78,0)
 ;;MILITARY SERVICE DATA
"RTN","DGRPU",79,0)
 ;;ELIGIBILITY STATUS DATA
"RTN","DGRPU",80,0)
 ;;FAMILY DEMOGRAPHIC DATA
"RTN","DGRPU",81,0)
 ;;INCOME SCREENING DATA
"RTN","DGRPU",82,0)
 ;;INELIGIBLE/MISSING DATA
"RTN","DGRPU",83,0)
 ;;ELIGIBILITY VERIFICATION DATA
"RTN","DGRPU",84,0)
 ;;ADMISSION INFORMATION
"RTN","DGRPU",85,0)
 ;;APPLICATION INFORMATION
"RTN","DGRPU",86,0)
 ;;APPOINTMENT INFORMATION
"RTN","DGRPU",87,0)
 ;;SPONSOR DEMOGRAPHIC INFORMATION
"RTN","DGRPU",88,0)
 ;
"RTN","DGRPU",89,0)
 ;
"RTN","DGRPU",90,0)
INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data
"RTN","DGRPU",91,0)
 ; (called by PTF)
"RTN","DGRPU",92,0)
 ;
"RTN","DGRPU",93,0)
 ;
"RTN","DGRPU",94,0)
 ;  Input:  DFN as IEN of PATIENT file
"RTN","DGRPU",95,0)
 ;          DGDT as date to return income as of
"RTN","DGRPU",96,0)
 ;
"RTN","DGRPU",97,0)
 ; Output:  total income (computed function)
"RTN","DGRPU",98,0)
 ;          (from 408.21 if available...otherwise from file 2)
"RTN","DGRPU",99,0)
 ;
"RTN","DGRPU",100,0)
 ;
"RTN","DGRPU",101,0)
 N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0
"RTN","DGRPU",102,0)
 D ALL^DGMTU21(DFN,"V",DGDT,"I")
"RTN","DGRPU",103,0)
 S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I)
"RTN","DGRPU",104,0)
 I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20)
"RTN","DGRPU",105,0)
 Q DGTOT
"RTN","DGRPU",106,0)
 ;
"RTN","DGRPU",107,0)
 ;
"RTN","DGRPU",108,0)
MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete?
"RTN","DGRPU",109,0)
 ;
"RTN","DGRPU",110,0)
 ;  Input:  DFN as IEN of PATIENT file
"RTN","DGRPU",111,0)
 ;          DGDT as 'as of' date
"RTN","DGRPU",112,0)
 ;
"RTN","DGRPU",113,0)
 ; Output:  1 if means test/COPAY for year prior to DT passed is complete
"RTN","DGRPU",114,0)
 ;          0 otherwise
"RTN","DGRPU",115,0)
 ;          DGMTYPT 1=MT;2=CP;0=NONE
"RTN","DGRPU",116,0)
 ;
"RTN","DGRPU",117,0)
 N COMP,MT,X,YR
"RTN","DGRPU",118,0)
 S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT)
"RTN","DGRPU",119,0)
 S DGMTYPT=+$P(MT,U,5)
"RTN","DGRPU",120,0)
 S COMP=1
"RTN","DGRPU",121,0)
 I DGMTYPT=1 D  ;MT
"RTN","DGRPU",122,0)
 .I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
"RTN","DGRPU",123,0)
 I DGMTYPT=2 D  ;CP
"RTN","DGRPU",124,0)
 .I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
"RTN","DGRPU",125,0)
 S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*10000<YR S COMP=0
"RTN","DGRPU",126,0)
 Q COMP
"RTN","DGRPU",127,0)
 ;
"RTN","DGRPU",128,0)
HLP1010 ;* This is called by the Executable Help for Patient field #1010.159
"RTN","DGRPU",129,0)
 ;   (APPOINTMENT REQUEST ON 1010EZ)
"RTN","DGRPU",130,0)
 W !!,"    Enter a 'Y' if the veteran applicant has requested an"
"RTN","DGRPU",131,0)
 W !,"    appointment with a VA doctor or provider and wants to be"
"RTN","DGRPU",132,0)
 W !,"    seen as soon as one becomes available  Enter a 'N'"
"RTN","DGRPU",133,0)
 W !,"    if the veteran applicant has not requested an appointment."
"RTN","DGRPU",134,0)
 W !!,"    This question may ONLY be entered ONCE for the veteran."
"RTN","DGRPU",135,0)
 W !,"    The answer to this question CANNOT be changed after the"
"RTN","DGRPU",136,0)
 W !,"    initial entry.",!
"RTN","DGRPU",137,0)
 Q
"RTN","DGRPU",138,0)
 ;
"RTN","DGRPU",139,0)
HLPCS ; * This is called by the Executable Help for Income Relation field #.1
"RTN","DGRPU",140,0)
 Q:X="?"
"RTN","DGRPU",141,0)
 N DIR,DGRDVAR
"RTN","DGRPU",142,0)
 W !?8,"Enter in this field a Yes or No to indicate whether the veteran"
"RTN","DGRPU",143,0)
 W !?8,"contributed any dollar amount to the child's support last calendar"
"RTN","DGRPU",144,0)
 W !?8,"year.  The contributions do not have to be in regular set amounts."
"RTN","DGRPU",145,0)
 W !?8,"For example, a veteran who paid a child's school tuition or"
"RTN","DGRPU",146,0)
 W !?8,"medical bills would be contributing to the child's support.",!
"RTN","DGRPU",147,0)
 W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
"RTN","DGRPU",148,0)
 Q
"RTN","DGRPU",149,0)
 ;
"RTN","DGRPU",150,0)
HLP1823 ;*This is called by the Executable Help for Patient Relation field #.18
"RTN","DGRPU",151,0)
 N DIR,DGRDVAR
"RTN","DGRPU",152,0)
 W !?7,"Enter 'Y' if the child is currently 18 to 23 years old and the child"
"RTN","DGRPU",153,0)
 W !?7,"attended school last calendar year.  Enter 'N' if the child is currently"
"RTN","DGRPU",154,0)
 W !?7,"18 to 23 years old but the child did not attend school last calendar"
"RTN","DGRPU",155,0)
 W !?7,"year.  Enter 'N' if the child is not currently 18 to 23 years old.",!
"RTN","DGRPU",156,0)
 I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
"RTN","DGRPU",157,0)
 Q
"RTN","DGRPU",158,0)
 ;
"RTN","DGRPU",159,0)
HLPMLDS ;* This is called by the Executable Help for Patient field #.362
"RTN","DGRPU",160,0)
 ;   (DISABILITY RET. FROM MILITARY?)
"RTN","DGRPU",161,0)
 N X,Y,DIR
"RTN","DGRPU",162,0)
 W !!,"  Enter '0' or 'NO' if the veteran:"
"RTN","DGRPU",163,0)
 W !,"    -- Is NOT retired from the military OR"
"RTN","DGRPU",164,0)
 W !,"    -- Is retired from the military due to length of service AND"
"RTN","DGRPU",165,0)
 W !,"       does NOT have a disability confirmed by the Military Branch"
"RTN","DGRPU",166,0)
 W !,"       to have been incurred in or aggravated while on active duty."
"RTN","DGRPU",167,0)
 W !!,"  Enter '1' or 'YES, RECEIVING MILITARY RETIREMENT' if the veteran:"
"RTN","DGRPU",168,0)
 W !,"    -- Is confirmed by the Military Branch to have been discharged"
"RTN","DGRPU",169,0)
 W !,"       or released due to a disability incurred in or aggravated"
"RTN","DGRPU",170,0)
 W !,"       while on active duty AND"
"RTN","DGRPU",171,0)
 W !,"       -- Has NOT filed a claim for VA compensation benefits OR"
"RTN","DGRPU",172,0)
 W !,"       -- Has been rated by the VA to be NSC OR"
"RTN","DGRPU",173,0)
 W !,"       -- Has been rated by the VA to have noncompensable 0%"
"RTN","DGRPU",174,0)
 W !,"          SC conditions."
"RTN","DGRPU",175,0)
 S DIR(0)="E" D ^DIR Q:+Y<1
"RTN","DGRPU",176,0)
 W !!,"  Enter '2' or 'YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA"
"RTN","DGRPU",177,0)
 W !,"                COMPENSATION' if the veteran:"
"RTN","DGRPU",178,0)
 W !,"       -- Is confirmed by the Military Branch to have been discharged"
"RTN","DGRPU",179,0)
 W !,"          or released due to a disability incurred in or aggravated"
"RTN","DGRPU",180,0)
 W !,"          while on active duty AND"
"RTN","DGRPU",181,0)
 W !,"       -- Is receiving military disability retirement pay AND"
"RTN","DGRPU",182,0)
 W !,"       -- Has been rated by VA to have compensable SC conditions"
"RTN","DGRPU",183,0)
 W !,"          but is NOT receiving compensation from the VA"
"RTN","DGRPU",184,0)
 W !!,"          Once eligibility has been verified, this field will no longer"
"RTN","DGRPU",185,0)
 W !,"          be editable to any user who does not hold the designated security"
"RTN","DGRPU",186,0)
 W !,"          key."
"RTN","DGRPU",187,0)
 Q
"RTN","DGRPU",188,0)
HLP3602 ;help text for field .3602, Rec'ing Disability in Lieu of VA Comp
"RTN","DGRPU",189,0)
 W !,"     Enter 'Y' if this veteran applicant is receiving disability"
"RTN","DGRPU",190,0)
 W !,"     retirement pay from the Military instead of VA compensation."
"RTN","DGRPU",191,0)
 W !,"     Enter 'N' if this veteran applicant is not receiving disability"
"RTN","DGRPU",192,0)
 W !,"     retirement pay from the Military instead of VA compensation."
"RTN","DGRPU",193,0)
 W !,"     Once eligibility has been verified by HEC this field will no longer "
"RTN","DGRPU",194,0)
 W !,"     be editable by VistA users. Send updates and/or requests to HEC."
"RTN","DGRPU",195,0)
 Q
"RTN","DGRPU",196,0)
HLP3603 ;help text for field .3603, Discharge Due to LOD Disability
"RTN","DGRPU",197,0)
 W !,"     Enter 'Y' if this veteran applicant was discharged from the"
"RTN","DGRPU",198,0)
 W !,"     military for a disability incurred or aggravated in the line "
"RTN","DGRPU",199,0)
 W !,"     of duty.  Enter 'N' if this veteran applicant was not discharged"
"RTN","DGRPU",200,0)
 W !,"     from the military for a disability incurred or aggravated in the"
"RTN","DGRPU",201,0)
 W !,"     line of duty. Once eligibility has been verified by HEC this field"
"RTN","DGRPU",202,0)
 W !,"     will no longer be editable by VistA users. Send updates and/or requests"
"RTN","DGRPU",203,0)
 W !,"     to HEC."
"RTN","DGRPU",204,0)
 Q
"RTN","DGRPU",205,0)
SSNNM(DFN) ; SSN, EDIPI and name on first line of screen
"RTN","DGRPU",206,0)
 ;DJE - DG*5.3*935 - Add Member ID To Vista Registration Banner
"RTN","DGRPU",207,0)
 N X,SSN,EDIPI,IDSTAT,J,ASFC,LIST,PT,STK
"RTN","DGRPU",208,0)
 S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
"RTN","DGRPU",209,0)
 ;
"RTN","DGRPU",210,0)
 S PT=DFN_"^PI^USVHA^"_$P($$SITE^VASITE(),U,3)
"RTN","DGRPU",211,0)
 D TFL^VAFCTFU2(.LIST,PT)
"RTN","DGRPU",212,0)
 S EDIPI="",IDSTAT="",J=1
"RTN","DGRPU",213,0)
 S STK="" F  S STK=$O(LIST(STK)) D  Q:STK=""
"RTN","DGRPU",214,0)
 .Q:STK=""
"RTN","DGRPU",215,0)
 .S ASFC=$P(LIST(STK),U,3)
"RTN","DGRPU",216,0)
 .Q:ASFC'="USDOD"
"RTN","DGRPU",217,0)
 .S IDSTAT=$P(LIST(STK),U,5)
"RTN","DGRPU",218,0)
 .S EDIPI=$P(LIST(STK),U,1)
"RTN","DGRPU",219,0)
 .I (IDSTAT="A"),(EDIPI>1) S STK=""  Q  ;First active EDIPI
"RTN","DGRPU",220,0)
 .I IDSTAT="H" S EDIPI(J)=EDIPI S J=J+1
"RTN","DGRPU",221,0)
 .S EDIPI=""
"RTN","DGRPU",222,0)
 I IDSTAT="H" S EDIPI=EDIPI(1) ; First inactive EDIPI
"RTN","DGRPU",223,0)
 S X=$P(X,U)_";  "_EDIPI_"  "_SSN
"RTN","DGRPU",224,0)
 Q X
"RTN","VADPT4")
0^10^B43698033
"RTN","VADPT4",1,0)
VADPT4 ;ALB/MRL,MJK,ERC,DJS - PATIENT VARIABLES ;16 Sep 2017  11:38AM
"RTN","VADPT4",2,0)
 ;;5.3;Registration;**343,342,528,689,688,790,797,935**;Aug 13, 1993;Build 53
"RTN","VADPT4",3,0)
7 ;Eligibility [ELIG]
"RTN","VADPT4",4,0)
 F I=.15,.3,.31,.32,.36,.361,"INE","TYPE","VET" S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","VADPT4",5,0)
 S VAZ=$P(VAX(.36),"^",1) S:$D(^DIC(8,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",1))=VAZ
"RTN","VADPT4",6,0)
 S VAX=0 F I=0:0 S VAX=$O(^DPT(DFN,"E",VAX)) Q:VAX'>0  S VAZ=VAX I $D(^DIC(8,+VAZ,0)),+@VAV@($P(VAS,"^"))'=VAZ S VAZ=VAZ_"^"_$P(^DIC(8,+VAZ,0),"^") S @VAV@($P(VAS,"^",1),VAX)=VAZ
"RTN","VADPT4",7,0)
 S VAZ=$P(VAX(.32),"^",3) S:$D(^DIC(21,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",2))=VAZ
"RTN","VADPT4",8,0)
 S VAZ=$S($P(VAX(.3),"^",1)="Y":1,1:0) S:VAZ VAZ=VAZ_"^"_$P(VAX(.3),"^",2) S @VAV@($P(VAS,"^",3))=VAZ
"RTN","VADPT4",9,0)
 S @VAV@($P(VAS,"^",4))=$S(VAX("VET")="Y":1,1:0),VAZ=$S(+$P(VAX(.15),"^",2):0,1:1),@VAV@($P(VAS,"^",5))=VAZ
"RTN","VADPT4",10,0)
 I VAZ F I=1:1:6 S @VAV@($P(VAS,"^",5),I)="" G 71
"RTN","VADPT4",11,0)
 S VAZ=$P(VAX(.15),"^",2),Y=VAZ X ^DD("DD") S @VAV@($P(VAS,"^",5),1)=VAZ_"^"_Y,VAZ=$P(VAX("INE"),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$P("VAMC^REGIONAL OFFICE^RPC","^",VAZ) S @VAV@($P(VAS,"^",5),2)=VAZ
"RTN","VADPT4",12,0)
 S @VAV@($P(VAS,"^",5),3)=$P(VAX("INE"),"^",3),VAZ=$P(VAX("INE"),"^",4) S:$D(^DIC(5,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",5),4)=VAZ
"RTN","VADPT4",13,0)
 S @VAV@($P(VAS,"^",5),5)=$P(VAX("INE"),"^",6),@VAV@($P(VAS,"^",5),6)=$P(VAX(.3),"^",7)
"RTN","VADPT4",14,0)
71 S VAZ=VAX("TYPE") S:$D(^DG(391,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",6))=VAZ
"RTN","VADPT4",15,0)
 S @VAV@($P(VAS,"^",7))=$P(VAX(.31),"^",3),VAZ=$P(VAX(.361),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$S(VAZ="V":"VERIFIED",VAZ="P":"PENDING VERIFICATION",VAZ="R":"PENDING RE-VERIFICATION",1:"") S @VAV@($P(VAS,"^",8))=VAZ
"RTN","VADPT4",16,0)
 I $D(^DPT(DFN,0)) S VAX=$P(^(0),"^",14),VAX=$G(^DG(408.32,+VAX,0)) I VAX]"" S @VAV@($P(VAS,"^",9))=$P(VAX,"^",2)_"^"_$P(VAX,"^",1)
"RTN","VADPT4",17,0)
 Q
"RTN","VADPT4",18,0)
 ;
"RTN","VADPT4",19,0)
8 ;Monetary Benefits [MB]
"RTN","VADPT4",20,0)
 N DGTOTVA
"RTN","VADPT4",21,0)
 S @VAV@($P(VAS,"^",6))=0 ; SSI no longer supported
"RTN","VADPT4",22,0)
 D ALL^DGMTU21(DFN,"V",DT,"I")
"RTN","VADPT4",23,0)
 S VAX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) F I=8,11,13 S @VAV@($S(I=8:$P(VAS,"^",3),I=11:$P(VAS,"^",5),1:$P(VAS,"^",8)))=$S($P(VAX,"^",I)'="":"1^"_$P(VAX,"^",I),1:0)
"RTN","VADPT4",24,0)
 S VAX=$G(^DPT(DFN,.362))
"RTN","VADPT4",25,0)
 S DGTOTVA=$P(VAX,U,20)
"RTN","VADPT4",26,0)
 F I=12,13,14 S @VAV@($S(I=12:$P(VAS,"^",1),(I=13):$P(VAS,"^",2),1:$P(VAS,"^",4)))=$S($P(VAX,"^",I)="Y":1_U_DGTOTVA,1:0)
"RTN","VADPT4",27,0)
 S I=17 S @VAV@($P(VAS,"^",9))=$S($P(VAX,"^",17)="Y":1_U_$P(VAX,U,6),1:0)
"RTN","VADPT4",28,0)
 S VAX=$G(^DPT(DFN,.3)) S @VAV@($P(VAS,"^",7))=$S($P(VAX,"^",11)="Y":1_U_DGTOTVA,1:0)
"RTN","VADPT4",29,0)
 K DGDEP,DGREL,DGINC,DGINR Q
"RTN","VADPT4",30,0)
 ;
"RTN","VADPT4",31,0)
9 ;Service information
"RTN","VADPT4",32,0)
 F I=.32,.321,.3291,.52,.53 S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","VADPT4",33,0)
 D:$D(^DPT(DFN,.3216)) MSDS
"RTN","VADPT4",34,0)
 S VAX("N")=.321 F I=1,2,3 S VAX(3)=I,VAZ=$S($P(VAX(.321),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(1)=$S(I=1:"4^5",I=2:"7^9^8",1:11),VAX(4)=0 D 91
"RTN","VADPT4",35,0)
 S VAX("N")=.52 F I=5,11 S VAX(3)=$S(I=5:4,1:5),VAX(1)=$S(I=5:"7^8",1:"13^14"),VAZ=$S($P(VAX(.52),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91
"RTN","VADPT4",36,0)
 ;Combat Vet
"RTN","VADPT4",37,0)
 S VAX(3)=10,VAX(1)="15",VAZ=$S($P(VAX(.52),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91
"RTN","VADPT4",38,0)
 F I=6,7,8 S @VAV@($P(VAS,"^",I))="" F VAX(1)=1:1:6 S @VAV@($P(VAS,"^",I),VAX(1))=""
"RTN","VADPT4",39,0)
 S VAX("N")=.32,VAZ=$S($P(VAX(.32),"^",5)]"":1,1:0),@VAV@($P(VAS,"^",6))=VAZ I VAZ,$P(VAX(.32),"^",19)="Y" S VAZ=1,@VAV@($P(VAS,"^",7))=VAZ I VAZ,$P(VAX(.32),"^",20)="Y" S @VAV@($P(VAS,"^",8))=1
"RTN","VADPT4",40,0)
 F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=$S(I=6:"6^7",I=7:"11^12",1:"16^17"),VAX(4)=3 D 91
"RTN","VADPT4",41,0)
 S VAX("N")=.3291
"RTN","VADPT4",42,0)
 F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=I-5,VAX(4)=6 D 94
"RTN","VADPT4",43,0)
 S VAX("N")=.53,VAX(3)=9,VAX(1)="2^3",VAZ=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":1,1:0),@VAV@($P(VAS,U,VAX(3)))=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":0,1:"") I VAZ S VAX(4)=0 D 93
"RTN","VADPT4",44,0)
 S VAX("N")=.3215,VAZ=$$GET^DGENOEIF(DFN,.VAZ,1)
"RTN","VADPT4",45,0)
 ;OEF/OIF
"RTN","VADPT4",46,0)
 F I=11,12,13 S @VAV@(I)=+$G(VAZ($P("OIF^OEF^UNK",U,I-10),"COUNT"))
"RTN","VADPT4",47,0)
 S VAX(2)=11
"RTN","VADPT4",48,0)
 F I="OIF","OEF","UNK" S VAX=0 F  S VAX=$O(VAZ(I,VAX)) S:'VAX VAX(2)=VAX(2)+1 Q:'VAX  S VAX(3)=0 D
"RTN","VADPT4",49,0)
 . N Z
"RTN","VADPT4",50,0)
 . F VAX(1)="LOC","FR","TO" S VAX(3)=VAX(3)+1,Z=$G(VAZ(I,VAX,VAX(1))),@VAV@(VAX(2),VAX,VAX(3))=Z D 95
"RTN","VADPT4",51,0)
 ;SHAD - added with DG*5.3*688
"RTN","VADPT4",52,0)
 S VAX(3)=14,VAZ=$S($P(VAX(.321),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S @VAV@($P(VAS,U,VAX(3)),1)=$S($P(VAX(.321),U,15)=1:"1^YES",1:"0^NO")
"RTN","VADPT4",53,0)
 Q
"RTN","VADPT4",54,0)
 ;
"RTN","VADPT4",55,0)
91 ;date fields
"RTN","VADPT4",56,0)
 F VAX(2)=1:1 S VAX(4)=VAX(4)+1,X=+$P(VAX(1),"^",VAX(2)) Q:'X  S X=$P(VAX(VAX("N")),"^",X),VAZ=X,Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$S(VAZ]"":VAZ_"^"_Y,1:"")
"RTN","VADPT4",57,0)
 Q:VAX(3)=1!(VAX(3)=9)!(VAX(3)=10)
"RTN","VADPT4",58,0)
 ;some sets of codes
"RTN","VADPT4",59,0)
 I VAX(3)=2 S @VAV@($P(VAS,"^",2),4)=$P(VAX(.321),"^",10) S (X,VAZ)=$P(VAX(.321),"^",13) S:X]"" VAZ=VAZ_"^"_$S(X="K":"KOREAN DMZ",1:"VIETNAM") S @VAV@($P(VAS,"^",2),5)=VAZ Q
"RTN","VADPT4",60,0)
 I VAX(3)<4 S X=$P(VAX(.321),"^",12),VAZ=X D
"RTN","VADPT4",61,0)
 .S:X]"" VAZ=VAZ_"^"_$S(X="2":"HIROSHIMA/NAGASAKI",X="3":"ATMOSPHERIC NUCLEAR TESTING",X="4":"H/N AND ATMOSPHERIC TESTING",X="5":"UNDERGROUND NUCLEAR TESTING",X="6":"EXPOSURE AT NUCLEAR FACILITY",1:"OTHER")
"RTN","VADPT4",62,0)
 .S @VAV@($P(VAS,"^",3),2)=VAZ Q
"RTN","VADPT4",63,0)
 ;POW, combat locations
"RTN","VADPT4",64,0)
 I VAX(3)<6 S X=$P(VAX(VAX("N")),"^",$S(VAX(3)=4:6,1:12)),VAZ=X S:$D(^DIC(22,+X,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",VAX(3)),3)=VAZ Q
"RTN","VADPT4",65,0)
 ;service episodes
"RTN","VADPT4",66,0)
 S X=$S(VAX(3)=6:5,VAX(3)=7:10,1:15),VAX(2)=0 F VAX(5)=X,X+3,X-1 S VAX(2)=VAX(2)+1,VAZ=$P(VAX(VAX("N")),"^",VAX(5)),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=VAZ I "^4^5^9^10^14^15^"[("^"_VAX(5)_"^"),+VAZ D 92
"RTN","VADPT4",67,0)
 Q
"RTN","VADPT4",68,0)
92 ;pointers to Branch of Service (23) and Type Discharge (25)
"RTN","VADPT4",69,0)
 S VAX(6)="^DIC("_$S('(VAX(5)#5):23,1:25)_","_+VAZ_",0)" I $D(@(VAX(6))) S VAZ=$P(^(0),"^",1),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=@VAV@($P(VAS,"^",VAX(3)),VAX(2))_"^"_VAZ
"RTN","VADPT4",70,0)
 Q
"RTN","VADPT4",71,0)
93 ;Purple Heart
"RTN","VADPT4",72,0)
 NEW VAFILE,VAIENS,VAFLDS,VAARR,VAI
"RTN","VADPT4",73,0)
 S VAFILE=2,VAIENS=DFN_",",VAFLDS=".532;.533"
"RTN","VADPT4",74,0)
 D GETS^DIQ(VAFILE,VAIENS,VAFLDS,"IEN","VAARR")
"RTN","VADPT4",75,0)
 F VAI=1:1 S VAFLDS(VAI)=$P(VAFLDS,";",VAI) Q:VAFLDS(VAI)=""  D
"RTN","VADPT4",76,0)
 . I '$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I")),'$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E")) S @VAV@($P(VAS,"^",VAX(3)),VAI)=""
"RTN","VADPT4",77,0)
 . E  S @VAV@($P(VAS,U,VAX(3)),VAI)=$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I"))_"^"_$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E"))
"RTN","VADPT4",78,0)
 Q
"RTN","VADPT4",79,0)
94 ;more military service
"RTN","VADPT4",80,0)
 N VAARR,VAIENS,VAFLDS
"RTN","VADPT4",81,0)
 S VAIENS=DFN_",",VAFLDS=".3291"_VAX(1)
"RTN","VADPT4",82,0)
 D GETS^DIQ(2,VAIENS,VAFLDS,"IEN","VAARR")
"RTN","VADPT4",83,0)
 I $G(VAARR(2,VAIENS,VAFLDS,"I"))'="" D
"RTN","VADPT4",84,0)
 . S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$G(VAARR(2,VAIENS,VAFLDS,"I"))_"^"_$G(VAARR(2,VAIENS,VAFLDS,"E"))
"RTN","VADPT4",85,0)
 Q
"RTN","VADPT4",86,0)
 ;
"RTN","VADPT4",87,0)
95 ;OEF/OIF
"RTN","VADPT4",88,0)
 N X,Y
"RTN","VADPT4",89,0)
 I VAX(3)=1 S $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=$$EXTERNAL^DILFD(2.3215,.01,"",Z)
"RTN","VADPT4",90,0)
 I VAX(3)=2!(VAX(3)=3) S Y=Z X ^DD("DD") S:Y'="" $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=Y
"RTN","VADPT4",91,0)
 Q
"RTN","VADPT4",92,0)
 ;
"RTN","VADPT4",93,0)
MSDS ;Returns latest service episodes from ESR sourced data
"RTN","VADPT4",94,0)
 N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB
"RTN","VADPT4",95,0)
 S COUNT=0,EDATE=""
"RTN","VADPT4",96,0)
 ;Clear military service discharge, branch, start, end and number info
"RTN","VADPT4",97,0)
 F I=4:1:20 S $P(VAX(.32),U,I)=""
"RTN","VADPT4",98,0)
 ;Clear military service component info
"RTN","VADPT4",99,0)
 F I=1:1:3 S $P(VAX(.3291),U,I)=""
"RTN","VADPT4",100,0)
 ;Scan back for three most recent service episodes
"RTN","VADPT4",101,0)
 F  S EDATE=$O(^DPT(DFN,.3216,"B",EDATE),-1) Q:'EDATE  D  Q:COUNT'<3
"RTN","VADPT4",102,0)
 .S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
"RTN","VADPT4",103,0)
 .;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
"RTN","VADPT4",104,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""!($P(EDATA,U,8)'="")
"RTN","VADPT4",105,0)
 .S COUNT=COUNT+1,SDATE=$P(EDATA,U,2)
"RTN","VADPT4",106,0)
 .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
"RTN","VADPT4",107,0)
 .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
"RTN","VADPT4",108,0)
 .;SL = 4, SNL = 9 or SNNL = 14
"RTN","VADPT4",109,0)
 .S SUB=(COUNT*5)-1
"RTN","VADPT4",110,0)
 .S $P(VAX(.32),U,SUB)=DTYP
"RTN","VADPT4",111,0)
 .S $P(VAX(.32),U,SUB+1)=BRANCH
"RTN","VADPT4",112,0)
 .S $P(VAX(.32),U,SUB+2)=EDATE
"RTN","VADPT4",113,0)
 .S $P(VAX(.32),U,SUB+3)=SDATE
"RTN","VADPT4",114,0)
 .S $P(VAX(.32),U,SUB+4)=SERVNO
"RTN","VADPT4",115,0)
 .S $P(VAX(.3291),U,COUNT)=COMP
"RTN","VADPT4",116,0)
 .S:SUB=9 $P(VAX(.32),U,19)="Y"
"RTN","VADPT4",117,0)
 .S:SUB=14 $P(VAX(.32),U,20)="Y"
"RTN","VADPT4",118,0)
 Q
"RTN","VAFHLZM2")
0^9^B11134578
"RTN","VAFHLZM2",1,0)
VAFHLZM2 ;ALB/KCL,PJH,LBD,DJS - Create HL7 Military History segment (ZMH) Cont ;11 Oct 2017 2:45pm
"RTN","VAFHLZM2",2,0)
 ;;5.3;Registration;**673,797,935**;Aug 13, 1993;Build 53
"RTN","VAFHLZM2",3,0)
 ;
"RTN","VAFHLZM2",4,0)
 ;--------------------------------------------------------------------------------
"RTN","VAFHLZM2",5,0)
 ;This routine creates HL7 VA-specific Military History ("ZMH") segments. It is a
"RTN","VAFHLZM2",6,0)
 ;continuation of VAFHLZM1 and uses variables from both VAFHLZMH and VAFHLZM1.
"RTN","VAFHLZM2",7,0)
 ;--------------------------------------------------------------------------------
"RTN","VAFHLZM2",8,0)
 ;
"RTN","VAFHLZM2",9,0)
 ;no direct entry
"RTN","VAFHLZM2",10,0)
 Q
"RTN","VAFHLZM2",11,0)
 ;
"RTN","VAFHLZM2",12,0)
 ;
"RTN","VAFHLZM2",13,0)
OEIF ;Build Operation Enduring/Iraqi Freedom segments
"RTN","VAFHLZM2",14,0)
 ;
"RTN","VAFHLZM2",15,0)
 N VAFDATA,VAFFROM,VAFIDX,VAFNODE,VAFSITE,VAFTO,VAFTYPE
"RTN","VAFHLZM2",16,0)
 ;
"RTN","VAFHLZM2",17,0)
 ;need to build segment even if no data in OEIF array 
"RTN","VAFHLZM2",18,0)
 S $P(VAFY,VAFHLS,2)="OEIF"
"RTN","VAFHLZM2",19,0)
 I VAFSTR[",3," S $P(VAFY,VAFHLS,3)=VAFHLQ_$E(VAFHLC)_VAFHLQ
"RTN","VAFHLZM2",20,0)
 I VAFSTR[",4," S $P(VAFY,VAFHLS,4)=VAFHLQ_$E(VAFHLC)_VAFHLQ
"RTN","VAFHLZM2",21,0)
 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM2",22,0)
 Q:'$D(VAFOPS)
"RTN","VAFHLZM2",23,0)
 ;
"RTN","VAFHLZM2",24,0)
 ;if data in OEIF array, build segment for each episode
"RTN","VAFHLZM2",25,0)
 S (VAFNODE,VAFIDX)=0
"RTN","VAFHLZM2",26,0)
 F  S VAFNODE=$O(VAFOPS(VAFNODE)) Q:'$G(VAFNODE)  D
"RTN","VAFHLZM2",27,0)
 .;
"RTN","VAFHLZM2",28,0)
 .S VAFDATA=$G(VAFOPS(VAFNODE))
"RTN","VAFHLZM2",29,0)
 .;
"RTN","VAFHLZM2",30,0)
 .I VAFSTR[",3," D
"RTN","VAFHLZM2",31,0)
 ..S VAFTYPE=$$EXTERNAL^DILFD(2.3215,.01,"F",$P(VAFDATA,U,1)) I VAFTYPE']"" S VAFTYPE=VAFHLQ
"RTN","VAFHLZM2",32,0)
 ..S VAFSITE=$$STATION^VAFHLFNC($P(VAFDATA,U,6)) I VAFSITE="" S VAFSITE=VAFHLQ
"RTN","VAFHLZM2",33,0)
 ..S $P(VAFY,VAFHLS,3)=VAFTYPE_$E(VAFHLC)_VAFSITE
"RTN","VAFHLZM2",34,0)
 .;
"RTN","VAFHLZM2",35,0)
 .I VAFSTR[",4," D
"RTN","VAFHLZM2",36,0)
 ..S VAFFROM=$P(VAFDATA,U,2) S VAFFROM=$S(VAFFROM:$$HLDATE^HLFNC(VAFFROM),1:VAFHLQ)
"RTN","VAFHLZM2",37,0)
 ..S VAFTO=$P(VAFDATA,U,3) S VAFTO=$S(VAFTO:$$HLDATE^HLFNC(VAFTO),1:VAFHLQ)
"RTN","VAFHLZM2",38,0)
 ..S $P(VAFY,VAFHLS,4)=VAFFROM_$E(VAFHLC)_VAFTO
"RTN","VAFHLZM2",39,0)
 .;
"RTN","VAFHLZM2",40,0)
 .I VAFSTR[",5," D
"RTN","VAFHLZM2",41,0)
 ..S $P(VAFY,VAFHLS,5)=VAFHLQ
"RTN","VAFHLZM2",42,0)
 .;
"RTN","VAFHLZM2",43,0)
 .;put segment into array
"RTN","VAFHLZM2",44,0)
 .S VAFIDX=VAFIDX+1
"RTN","VAFHLZM2",45,0)
 .S VAFY(VAFIDX)=$G(VAFY)
"RTN","VAFHLZM2",46,0)
 ;
"RTN","VAFHLZM2",47,0)
 Q
"RTN","VAFHLZM2",48,0)
 ;
"RTN","VAFHLZM2",49,0)
 ;
"RTN","VAFHLZM2",50,0)
NOSEG ;
"RTN","VAFHLZM2",51,0)
 Q
"RTN","VAFHLZM2",52,0)
 ;
"RTN","VAFHLZM2",53,0)
MSDS ;Returns all service episodes from ESR sourced data
"RTN","VAFHLZM2",54,0)
 ;
"RTN","VAFHLZM2",55,0)
 N BRANCH,COMP,DA,DATE,DONE,DTYP,EDATA,EDATE,NUM,SDATE,SERVNO,VAFIDX
"RTN","VAFHLZM2",56,0)
 S DATE="",(NUM,VAFIDX)=0
"RTN","VAFHLZM2",57,0)
 ;Scan back through entry dates for service episodes
"RTN","VAFHLZM2",58,0)
 F  S DATE=$O(^DPT(DFN,.3216,"B",DATE),-1) Q:'DATE  D
"RTN","VAFHLZM2",59,0)
 .S DA=$O(^DPT(DFN,.3216,"B",DATE,0)) Q:'DA
"RTN","VAFHLZM2",60,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
"RTN","VAFHLZM2",61,0)
 .;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
"RTN","VAFHLZM2",62,0)
 .Q:$P(EDATA,U,8)'=""
"RTN","VAFHLZM2",63,0)
 .S NUM=NUM+1
"RTN","VAFHLZM2",64,0)
 .S SDATE=$P(EDATA,U,2),EDATE=DATE
"RTN","VAFHLZM2",65,0)
 .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
"RTN","VAFHLZM2",66,0)
 .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
"RTN","VAFHLZM2",67,0)
 .S $P(VAFY,VAFHLS,2)=$S(NUM=1:"SL",NUM=2:"SNL",NUM=3:"SNNL",1:"MSD")
"RTN","VAFHLZM2",68,0)
 .I VAFSTR[",3," D
"RTN","VAFHLZM2",69,0)
 ..S BRANCH=$S(BRANCH:$P($G(^DIC(23,BRANCH,0)),U),1:VAFHLQ)
"RTN","VAFHLZM2",70,0)
 ..I SERVNO="" S SERVNO=VAFHLQ
"RTN","VAFHLZM2",71,0)
 ..S DTYP=$S(DTYP:$P($G(^DIC(25,DTYP,0)),U),1:VAFHLQ)
"RTN","VAFHLZM2",72,0)
 ..; Service branch~Service number~Service discharge type
"RTN","VAFHLZM2",73,0)
 ..S $P(VAFY,VAFHLS,3)=BRANCH_$E(VAFHLC)_SERVNO_$E(VAFHLC)_DTYP
"RTN","VAFHLZM2",74,0)
 .I VAFSTR[",4," D
"RTN","VAFHLZM2",75,0)
 ..S EDATE=$S(EDATE:$$HLDATE^HLFNC(EDATE),1:VAFHLQ)
"RTN","VAFHLZM2",76,0)
 ..S SDATE=$S(SDATE:$$HLDATE^HLFNC(SDATE),1:VAFHLQ)
"RTN","VAFHLZM2",77,0)
 ..; Service entry date~Service separation date
"RTN","VAFHLZM2",78,0)
 ..S $P(VAFY,VAFHLS,4)=EDATE_$E(VAFHLC)_SDATE
"RTN","VAFHLZM2",79,0)
 .I VAFSTR[",5," D
"RTN","VAFHLZM2",80,0)
 ..; Service Component [L]
"RTN","VAFHLZM2",81,0)
 ..I COMP="" S COMP=VAFHLQ
"RTN","VAFHLZM2",82,0)
 ..S $P(VAFY,VAFHLS,5)=COMP
"RTN","VAFHLZM2",83,0)
 .;
"RTN","VAFHLZM2",84,0)
 .;put segment into array
"RTN","VAFHLZM2",85,0)
 .S VAFIDX=VAFIDX+1
"RTN","VAFHLZM2",86,0)
 .S VAFY(VAFIDX)=$G(VAFY)
"RTN","VAFHLZM2",87,0)
 Q
"RTN","VAFHLZMH")
0^14^B31266014
"RTN","VAFHLZMH",1,0)
VAFHLZMH ;BAY/JAT,PJH,DJS - Create HL7 Military History seg. (ZMH) ;2 Nov 2017  7:16pm
"RTN","VAFHLZMH",2,0)
 ;;5.3;Registration;**190,314,673,797,935**;Aug 13, 1993;Build 53
"RTN","VAFHLZMH",3,0)
 ;
"RTN","VAFHLZMH",4,0)
 ; This routine creates HL7 VA-specific Military History ("ZMH") segments
"RTN","VAFHLZMH",5,0)
 Q
"RTN","VAFHLZMH",6,0)
 ;
"RTN","VAFHLZMH",7,0)
EN(DFN,VAFHMIEN,VAFSTR) ; RAI/MDS Reserved entry point!!
"RTN","VAFHLZMH",8,0)
 ; !!!!!!!!!! don't enter here !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
"RTN","VAFHLZMH",9,0)
 ;DFN - Patient Internal Entry Number
"RTN","VAFHLZMH",10,0)
 ;VAFHMIEN - Patient Movement Internal Entry Number
"RTN","VAFHLZMH",11,0)
 ;VAFSTR - Sequence numbers to be included
"RTN","VAFHLZMH",12,0)
 ;
"RTN","VAFHLZMH",13,0)
 N VAFHLREC,VAFHA,VAFHSUB,VAFHADD,VAFHLOC S VAFHSUB="" ;Initialize variables
"RTN","VAFHLZMH",14,0)
 S $P(VAFHLREC,HL("FS"))="ZMH" ;Set segment ID to ZMH
"RTN","VAFHLZMH",15,0)
 S $P(VAFHLREC,HL("FS"),2)=1 ;Set Set ID to 1
"RTN","VAFHLZMH",16,0)
 I VAFSTR[",4," D
"RTN","VAFHLZMH",17,0)
 .N EDATE,SDATE
"RTN","VAFHLZMH",18,0)
 .I '$D(^DPT(DFN,.3216)) D
"RTN","VAFHLZMH",19,0)
 ..S EDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".326","I"))
"RTN","VAFHLZMH",20,0)
 ..S SDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".327","I"))
"RTN","VAFHLZMH",21,0)
 .E  D MSDSD
"RTN","VAFHLZMH",22,0)
 .S $P(VAFHLREC,HL("FS"),5)=EDATE_$E(HL("ECH"))_SDATE
"RTN","VAFHLZMH",23,0)
 Q VAFHLREC ;Quit and return formatted segment
"RTN","VAFHLZMH",24,0)
 ;
"RTN","VAFHLZMH",25,0)
MSDSD ;Returns last service separation date from ESR sourced data 
"RTN","VAFHLZMH",26,0)
 N DA,DONE,EDATA
"RTN","VAFHLZMH",27,0)
 S EDATE="",SDATE="",DONE=0
"RTN","VAFHLZMH",28,0)
 F  S EDATE=$O(^DPT(DFN,.3216,"B",""),-1) Q:'EDATE  D  Q:DONE
"RTN","VAFHLZMH",29,0)
 .S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
"RTN","VAFHLZMH",30,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
"RTN","VAFHLZMH",31,0)
 .S DONE=1
"RTN","VAFHLZMH",32,0)
 ;
"RTN","VAFHLZMH",33,0)
 Q:'DONE
"RTN","VAFHLZMH",34,0)
 S EDATE=$$HLDATE^HLFNC(EDATE)
"RTN","VAFHLZMH",35,0)
 S SDATE=$$HLDATE^HLFNC($P(EDATA,U,2))
"RTN","VAFHLZMH",36,0)
 Q
"RTN","VAFHLZMH",37,0)
 ;
"RTN","VAFHLZMH",38,0)
ENTER(DFN,VAFARRAY,VAFTYPE,VAFSTR,VAFHLS,VAFHLC,VAFHLQ)       ;
"RTN","VAFHLZMH",39,0)
 ; DFN is the only required parameter.  Defaults are used if no
"RTN","VAFHLZMH",40,0)
 ; values are passed for the other parameters.
"RTN","VAFHLZMH",41,0)
 ; Output:
"RTN","VAFHLZMH",42,0)
 ; VAFARRAY = array name to hold the "ZMH" segments.
"RTN","VAFHLZMH",43,0)
 ;            Default is ^TMP("VAFHLZMH",$J)
"RTN","VAFHLZMH",44,0)
 ; Input:
"RTN","VAFHLZMH",45,0)
 ; DFN = internal entry number (IEN) of Patient (#2) file
"RTN","VAFHLZMH",46,0)
 ; VAFTYPE = Military History type desired (separated by commas) where
"RTN","VAFHLZMH",47,0)
 ;            1=Last Service branch (SL)
"RTN","VAFHLZMH",48,0)
 ;            2=Next to last Service branch (SNL)
"RTN","VAFHLZMH",49,0)
 ;            3=Next to next to last Service branch (SNNL)
"RTN","VAFHLZMH",50,0)
 ;            4=Prisoner of War Status indicated? (POW)
"RTN","VAFHLZMH",51,0)
 ;            5=Combat Service indicated? (COMB)
"RTN","VAFHLZMH",52,0)
 ;            6=Vietnam Service indicated? (VIET)
"RTN","VAFHLZMH",53,0)
 ;            7=Lebanon Service indicated? (LEBA)
"RTN","VAFHLZMH",54,0)
 ;            8=Grenada Service indicated? (GREN)
"RTN","VAFHLZMH",55,0)
 ;            9=Panama Service indicated? (PANA)
"RTN","VAFHLZMH",56,0)
 ;           10=Persian Gulf Service indicated? (GULF)
"RTN","VAFHLZMH",57,0)
 ;           11=Somalia Service indicated? (SOMA)    
"RTN","VAFHLZMH",58,0)
 ;           12=Yugoslavia Service indicated? (YUGO)
"RTN","VAFHLZMH",59,0)
 ;           13=Purple Heart Receipient? (PH)
"RTN","VAFHLZMH",60,0)
 ;           14=Operation Enduring/Iraqi Freedom (OEIF)
"RTN","VAFHLZMH",61,0)
 ;          A range of numbers separated by colons can be sent 
"RTN","VAFHLZMH",62,0)
 ;                  (e.g. 1:4,8,10:12) 
"RTN","VAFHLZMH",63,0)
 ;          Default is all(1,2,3...)
"RTN","VAFHLZMH",64,0)
 ;
"RTN","VAFHLZMH",65,0)
 ;          OR  
"RTN","VAFHLZMH",66,0)
 ;
"RTN","VAFHLZMH",67,0)
 ;          If value '*' is passed into the routine then the default 
"RTN","VAFHLZMH",68,0)
 ;          is to return all military history and all military service
"RTN","VAFHLZMH",69,0)
 ;          episodes for the vet. Rather than using SL, SNL AND SNNL
"RTN","VAFHLZMH",70,0)
 ;          the ZMH type will be 'MSD'.
"RTN","VAFHLZMH",71,0)
 ;
"RTN","VAFHLZMH",72,0)
 ;
"RTN","VAFHLZMH",73,0)
 ; VAFSTR = Fields (sequence numbers) desired (separated by comma) where
"RTN","VAFHLZMH",74,0)
 ;          3=qualifier #1 (Service branch if VAFTYPE is 1,2 or 3
"RTN","VAFHLZMH",75,0)
 ;                         or Yes/No response if VAFTYPE is 4 thru 13)
"RTN","VAFHLZMH",76,0)
 ;            qualifier #2 (Service number if VAFTYPE is 1,2 or 3
"RTN","VAFHLZMH",77,0)
 ;                         or Location if VAFTYPE is 4 or 5)
"RTN","VAFHLZMH",78,0)
 ;                         or 
"RTN","VAFHLZMH",79,0)
 ;            qualifier #3 (Service discharge type if VAFTYPE is 1,2
"RTN","VAFHLZMH",80,0)
 ;                          or 3)
"RTN","VAFHLZMH",81,0)
 ;          4=From/To Date range for each VAFTYPE
"RTN","VAFHLZMH",82,0)
 ;          5=Service Component
"RTN","VAFHLZMH",83,0)
 ;          Default is 3,4,5
"RTN","VAFHLZMH",84,0)
 ; VAFHLS = HL7 field separator (1 character)
"RTN","VAFHLZMH",85,0)
 ;          Default is ^ (carrot)
"RTN","VAFHLZMH",86,0)
 ; VAFHLC = HL7 encoding characters (4 characters must be supplied)
"RTN","VAFHLZMH",87,0)
 ;          Default is ~|\& (tilde bar backslash ampersand)
"RTN","VAFHLZMH",88,0)
 ; VAFHLQ = HL7 null designation 
"RTN","VAFHLZMH",89,0)
 ;          Default is "" (quote quote)
"RTN","VAFHLZMH",90,0)
 ; 
"RTN","VAFHLZMH",91,0)
 ; Check input and apply default values as needed
"RTN","VAFHLZMH",92,0)
 S VAFARRAY=$G(VAFARRAY) I VAFARRAY="" S VAFARRAY=$NA(^TMP("VAFHLZMH",$J))
"RTN","VAFHLZMH",93,0)
 K @VAFARRAY
"RTN","VAFHLZMH",94,0)
 S VAFTYPE=$G(VAFTYPE)
"RTN","VAFHLZMH",95,0)
 I VAFTYPE="" S VAFTYPE="1,2,3,4,5,6,7,8,9,10,11,12,13,14"
"RTN","VAFHLZMH",96,0)
 S VAFSTR=$G(VAFSTR) I VAFSTR="" S VAFSTR="3,4,5"
"RTN","VAFHLZMH",97,0)
 S VAFHLS=$G(VAFHLS) I VAFHLS="" S VAFHLS="^"
"RTN","VAFHLZMH",98,0)
 S:($L(VAFHLS)'=1) VAFHLS="^"
"RTN","VAFHLZMH",99,0)
 S VAFHLC=$G(VAFHLC) I VAFHLC="" S VAFHLC="~|\&"
"RTN","VAFHLZMH",100,0)
 S:($L(VAFHLC)'=4) VAFHLC="~|\&"
"RTN","VAFHLZMH",101,0)
 S:('$D(VAFHLQ)) VAFHLQ=$C(34,34)
"RTN","VAFHLZMH",102,0)
 I '$G(DFN) D NOGO Q
"RTN","VAFHLZMH",103,0)
 I '$D(^DPT(DFN,0)) D NOGO Q
"RTN","VAFHLZMH",104,0)
 S VAFSTR=$TR(VAFSTR,":",",")
"RTN","VAFHLZMH",105,0)
 I VAFSTR'=3,VAFSTR'=4,VAFSTR'=5,VAFSTR'="3,4",VAFSTR'="3,5",VAFSTR'="4,5",VAFSTR'="3,4,5" D NOGO Q
"RTN","VAFHLZMH",106,0)
 S VAFSTR=","_VAFSTR_","
"RTN","VAFHLZMH",107,0)
 I VAFTYPE="*" S VAFTYPE="*,4,5,6,7,8,9,10,11,12,13,14"
"RTN","VAFHLZMH",108,0)
 E  I '$$EDIT(VAFTYPE) D NOGO Q
"RTN","VAFHLZMH",109,0)
 I VAFTYPE[":" D UNCRUNCH
"RTN","VAFHLZMH",110,0)
 ; it's a Go
"RTN","VAFHLZMH",111,0)
 N VAFY,VAFX,VAFZ,VAFINDX,VAFTAG
"RTN","VAFHLZMH",112,0)
 S VAFINDX=0
"RTN","VAFHLZMH",113,0)
 ; set all the Patient file nodes that may be needed
"RTN","VAFHLZMH",114,0)
 N VAF32N,VAF321N,VAF322N,VAF52N,VAF53N,VAF3291N
"RTN","VAFHLZMH",115,0)
 S VAF321N=$G(^DPT(DFN,.321)) ; used for Vietnam
"RTN","VAFHLZMH",116,0)
 S VAF322N=$G(^DPT(DFN,.322)) ; used for minor skirmishes
"RTN","VAFHLZMH",117,0)
 S VAF52N=$G(^DPT(DFN,.52)) ; used for POW and Combat
"RTN","VAFHLZMH",118,0)
 S VAF53N=$G(^DPT(DFN,.53)) ;used for Purple Heart
"RTN","VAFHLZMH",119,0)
 I '$D(^DPT(DFN,.3216)) D
"RTN","VAFHLZMH",120,0)
 .S VAF32N=$G(^DPT(DFN,.32)) ; used for Service branches
"RTN","VAFHLZMH",121,0)
 .S VAF3291N=$G(^DPT(DFN,.3291)) ;used for service component
"RTN","VAFHLZMH",122,0)
 I $D(^DPT(DFN,.3216)),VAFTYPE'["*" D MSDS
"RTN","VAFHLZMH",123,0)
 ;used for Operation Enduring/Iraqi Freedom
"RTN","VAFHLZMH",124,0)
 N VAFOPS,VAFREC,VAFSUB
"RTN","VAFHLZMH",125,0)
 S (VAFREC,VAFSUB)=0
"RTN","VAFHLZMH",126,0)
 ;set operations into local array since there may be mult OEIF episodes
"RTN","VAFHLZMH",127,0)
 F  S VAFREC=$O(^DPT(DFN,.3215,VAFREC)) Q:'$G(VAFREC)  D
"RTN","VAFHLZMH",128,0)
 . S VAFSUB=VAFSUB+1
"RTN","VAFHLZMH",129,0)
 . S VAFOPS(VAFSUB)=$G(^DPT(DFN,.3215,VAFREC,0))
"RTN","VAFHLZMH",130,0)
 ;
"RTN","VAFHLZMH",131,0)
 D ENTER^VAFHLZM1
"RTN","VAFHLZMH",132,0)
 ;
"RTN","VAFHLZMH",133,0)
 Q
"RTN","VAFHLZMH",134,0)
 ;
"RTN","VAFHLZMH",135,0)
MSDS ;Returns latest service episodes from ESR sourced data
"RTN","VAFHLZMH",136,0)
 ;
"RTN","VAFHLZMH",137,0)
 ;*** the number of episodes is unlimited ****
"RTN","VAFHLZMH",138,0)
 ;
"RTN","VAFHLZMH",139,0)
 N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,SDATE,SERVNO,SUB
"RTN","VAFHLZMH",140,0)
 S COUNT=0,EDATE="",VAF32N="",VAF3291N=""
"RTN","VAFHLZMH",141,0)
 ;Scan back for three most recent service episodes
"RTN","VAFHLZMH",142,0)
 F  S EDATE=$O(^DPT(DFN,.3216,"B",EDATE),-1) Q:'EDATE  D  Q:COUNT'<3
"RTN","VAFHLZMH",143,0)
 .S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
"RTN","VAFHLZMH",144,0)
 .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
"RTN","VAFHLZMH",145,0)
 .;DJS, skip an MSE that has a Future Discharge Date; DG*5.3*935
"RTN","VAFHLZMH",146,0)
 .Q:$P(EDATA,U,8)'=""
"RTN","VAFHLZMH",147,0)
 .S COUNT=COUNT+1,SDATE=$P(EDATA,U,2)
"RTN","VAFHLZMH",148,0)
 .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
"RTN","VAFHLZMH",149,0)
 .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
"RTN","VAFHLZMH",150,0)
 .;SL = 4, SNL = 9 or SNNL = 14
"RTN","VAFHLZMH",151,0)
 .S SUB=(COUNT*5)-1
"RTN","VAFHLZMH",152,0)
 .S $P(VAF32N,U,SUB)=DTYP
"RTN","VAFHLZMH",153,0)
 .S $P(VAF32N,U,SUB+1)=BRANCH
"RTN","VAFHLZMH",154,0)
 .S $P(VAF32N,U,SUB+2)=EDATE
"RTN","VAFHLZMH",155,0)
 .S $P(VAF32N,U,SUB+3)=SDATE
"RTN","VAFHLZMH",156,0)
 .S $P(VAF32N,U,SUB+4)=SERVNO
"RTN","VAFHLZMH",157,0)
 .S $P(VAF3291N,U,COUNT)=COMP
"RTN","VAFHLZMH",158,0)
 Q
"RTN","VAFHLZMH",159,0)
 ;
"RTN","VAFHLZMH",160,0)
EDIT(X)  ; function validates VAFTYP (returns 1 if valid)        
"RTN","VAFHLZMH",161,0)
 N P,Q,R,CNT,Z,Z1,Z2,ERR S ERR=0
"RTN","VAFHLZMH",162,0)
 S X=$G(X)
"RTN","VAFHLZMH",163,0)
 I X>0,X<15,X?.N Q 1 ; only 1 number and between 1-14
"RTN","VAFHLZMH",164,0)
 I X'[":",X'["," Q 0 ; comma not used as separator
"RTN","VAFHLZMH",165,0)
 I X'?.NP Q 0 ; contains letters or control characters
"RTN","VAFHLZMH",166,0)
 ; contains punctuation other than comma/colon
"RTN","VAFHLZMH",167,0)
 S P="!#$%&'()*+-./;<=>?@[\]^_`{|]~"
"RTN","VAFHLZMH",168,0)
 F CNT=1:1 S Z=$E(X,CNT) Q:Z=""  I P[Z S ERR=1 Q
"RTN","VAFHLZMH",169,0)
 I ERR=1 Q 0
"RTN","VAFHLZMH",170,0)
 S Q="",R=""""
"RTN","VAFHLZMH",171,0)
 I Q[X!R[X Q 0
"RTN","VAFHLZMH",172,0)
 ; checks that numbers are >0<15
"RTN","VAFHLZMH",173,0)
 F CNT=1:1 S Z=$P(X,",",CNT) Q:Z=""  D
"RTN","VAFHLZMH",174,0)
 .I Z'[":",Z>0,Z<15 Q
"RTN","VAFHLZMH",175,0)
 .S Z1=$P(Z,":",1),Z2=$P(Z,":",2)
"RTN","VAFHLZMH",176,0)
 .I Z1>0,Z1<15,Z2>0,Z2<15 Q
"RTN","VAFHLZMH",177,0)
 .S ERR=1
"RTN","VAFHLZMH",178,0)
 I ERR=1 Q 0
"RTN","VAFHLZMH",179,0)
 Q 1
"RTN","VAFHLZMH",180,0)
 ;
"RTN","VAFHLZMH",181,0)
UNCRUNCH ; reformat VAFTYPE by translating any range of numbers,
"RTN","VAFHLZMH",182,0)
 ; for example replace "1:3,6,9:11" by "1,2,3,6,9,10,11,"
"RTN","VAFHLZMH",183,0)
 N X,Y,Z,A,B S Y=""
"RTN","VAFHLZMH",184,0)
 F X=1:1 S Z=$P(VAFTYPE,",",X) Q:Z=""  D
"RTN","VAFHLZMH",185,0)
 .I Z'[":" S Y=Y_Z_"," Q
"RTN","VAFHLZMH",186,0)
 .S A=$P(Z,":",1),B=$P(Z,":",2)
"RTN","VAFHLZMH",187,0)
 .S Y=Y_A_","
"RTN","VAFHLZMH",188,0)
 .F  S A=A+1 Q:A>B  S Y=Y_A_","
"RTN","VAFHLZMH",189,0)
 S VAFTYPE=Y
"RTN","VAFHLZMH",190,0)
 Q
"RTN","VAFHLZMH",191,0)
NOGO ;
"RTN","VAFHLZMH",192,0)
 S @VAFARRAY@(1,0)="ZMH"_VAFHLS_1
"RTN","VAFHLZMH",193,0)
 Q
"UP",2,2.3216,-1)
2^.3216
"UP",2,2.3216,0)
2.3216
"VER")
8.0^22.2
"^DD",2,2.3216,.08,0)
FUTURE DISCHARGE DATE^DX^^0;8^S %DT="EX" D ^%DT S X=Y K:Y<1 X
"^DD",2,2.3216,.08,3)
Enter the date that an active duty service member is expected to be discharged.
"^DD",2,2.3216,.08,21,0)
^^3^3^3171013^
"^DD",2,2.3216,.08,21,1,0)
The Future Discharge Date (FDD) is the date that an active duty service
"^DD",2,2.3216,.08,21,2,0)
member is expected to be discharged. This date is controlled in VistA by
"^DD",2,2.3216,.08,21,3,0)
the Enrollment Service (ES) and cannot be edited within VistA.
"^DD",2,2.3216,.08,"DT")
3171020
"^DD",25.11,25.11,0)
FIELD^NL^.05^5
"^DD",25.11,25.11,0,"DDA")
N
"^DD",25.11,25.11,0,"DT")
3170817
"^DD",25.11,25.11,0,"IX","C",25.11,.02)

"^DD",25.11,25.11,0,"NM","HEALTH BENEFIT PLAN")

"^DD",25.11,25.11,0,"PT",2.2511,.01)

"^DD",25.11,25.11,0,"PT",2.2512,1)

"^DD",25.11,25.11,0,"VRPK")
DG
"^DD",25.11,25.11,.01,0)
NAME ^RF^^0;1^K:$L(X)>200!($L(X)<3)!'(X'?1P.E) X
"^DD",25.11,25.11,.01,1,0)
^.1^^0
"^DD",25.11,25.11,.01,3)
Answer must be 3-200 characters in length.
"^DD",25.11,25.11,.01,21,0)
^.001^1^1^3130306^^^^
"^DD",25.11,25.11,.01,21,1,0)
This field contains the Health Benefit Plan name.
"^DD",25.11,25.11,.01,"DT")
3130326
"^DD",25.11,25.11,.02,0)
PLAN CODE^RNJ3,0^^0;2^K:+X'=X!(X>999)!(X<100)!(X?.E1"."1N.N) X
"^DD",25.11,25.11,.02,1,0)
^.1
"^DD",25.11,25.11,.02,1,1,0)
25.11^C
"^DD",25.11,25.11,.02,1,1,1)
S ^DGHBP(25.11,"C",$E(X,1,30),DA)=""
"^DD",25.11,25.11,.02,1,1,2)
K ^DGHBP(25.11,"C",$E(X,1,30),DA)
"^DD",25.11,25.11,.02,1,1,"%D",0)
^^2^2^3130307^
"^DD",25.11,25.11,.02,1,1,"%D",1,0)
This will contain the cross-reference plan code to its corresponding 
"^DD",25.11,25.11,.02,1,1,"%D",2,0)
Health Benefit Plan.
"^DD",25.11,25.11,.02,1,1,"DT")
3130307
"^DD",25.11,25.11,.02,3)
Type a number between 100 and 999, 0 decimal digits.
"^DD",25.11,25.11,.02,21,0)
^.001^1^1^3130307^^
"^DD",25.11,25.11,.02,21,1,0)
This field contains the Plan Code associated with the Health Benefit Plan.
"^DD",25.11,25.11,.02,"DT")
3130307
"^DD",25.11,25.11,.03,0)
SHORT DESCRIPTION^25.13^^1;0
"^DD",25.11,25.11,.03,21,0)
^^2^2^3130307^
"^DD",25.11,25.11,.03,21,1,0)
This field contains the short description associated with the Health 
"^DD",25.11,25.11,.03,21,2,0)
Benefit Plan.
"^DD",25.11,25.11,.04,0)
LONG DESCRIPTION^25.14^^2;0
"^DD",25.11,25.11,.04,21,0)
^^2^2^3130307^
"^DD",25.11,25.11,.04,21,1,0)
This field contains the detailed long description associated with the 
"^DD",25.11,25.11,.04,21,2,0)
Health Benefit Plan.
"^DD",25.11,25.11,.05,0)
COVERAGE CODE^F^^0;3^K:$L(X)>30!($L(X)<1) X
"^DD",25.11,25.11,.05,3)
Answer must be 1-30 characters in length.
"^DD",25.11,25.11,.05,21,0)
^^1^1^3170117^
"^DD",25.11,25.11,.05,21,1,0)
This field contains the Coverage Code associated with the Health Benefit Plan.
"^DD",25.11,25.11,.05,"DT")
3170117
"^DD",25.11,25.13,0)
SHORT DESCRIPTION SUB-FIELD^^.01^1
"^DD",25.11,25.13,0,"DT")
3130307
"^DD",25.11,25.13,0,"NM","SHORT DESCRIPTION")

"^DD",25.11,25.13,0,"UP")
25.11
"^DD",25.11,25.13,.01,0)
SHORT DESCRIPTION^Wx^^0;1^Q
"^DD",25.11,25.13,.01,3)
Enter the short description for the Health Benefit Plan.
"^DD",25.11,25.13,.01,21,0)
^.001^2^2^3130307^^
"^DD",25.11,25.13,.01,21,1,0)
This field contains the short description associated with the Health 
"^DD",25.11,25.13,.01,21,2,0)
Benefit Plan.
"^DD",25.11,25.13,.01,"DT")
3130307
"^DD",25.11,25.14,0)
LONG DESCRIPTION SUB-FIELD^^.01^1
"^DD",25.11,25.14,0,"DT")
3130307
"^DD",25.11,25.14,0,"NM","LONG DESCRIPTION")

"^DD",25.11,25.14,0,"UP")
25.11
"^DD",25.11,25.14,.01,0)
LONG DESCRIPTION^Wx^^0;1^Q
"^DD",25.11,25.14,.01,3)
Enter the detailed description for the Health Benefit Plan.
"^DD",25.11,25.14,.01,21,0)
^.001^2^2^3130307^^
"^DD",25.11,25.14,.01,21,1,0)
This field contains the detailed long description associated with the 
"^DD",25.11,25.14,.01,21,2,0)
Health Benefit Plan.
"^DD",25.11,25.14,.01,"DT")
3130307
"^DIC",25.11,25.11,0)
HEALTH BENEFIT PLAN^25.11
"^DIC",25.11,25.11,0,"GL")
^DGHBP(25.11,
"^DIC",25.11,25.11,"%",0)
^1.005^^0
"^DIC",25.11,25.11,"%D",0)
^1.001^2^2^3150209^^^^
"^DIC",25.11,25.11,"%D",1,0)
This file contains the Health Benefit Plan names and their short and long 
"^DIC",25.11,25.11,"%D",2,0)
descriptions.
"^DIC",25.11,"B","HEALTH BENEFIT PLAN",25.11)

**INSTALL NAME**
IVM*2.0*167
"BLD",10212,0)
IVM*2.0*167^INCOME VERIFICATION MATCH^0^3171106^y
"BLD",10212,1,0)
^^2^2^3171031^^
"BLD",10212,1,1,0)
ENROLLMENT SYSTEM COMMUNITY CARE (ESCC) HOME PHONE AND FUTURE DISCHARGE 
"BLD",10212,1,2,0)
DATE UPDATES
"BLD",10212,4,0)
^9.64PA^^
"BLD",10212,6)
1^
"BLD",10212,6.3)
39
"BLD",10212,"ABPKG")
n
"BLD",10212,"KRN",0)
^9.67PA^779.2^20
"BLD",10212,"KRN",.4,0)
.4
"BLD",10212,"KRN",.401,0)
.401
"BLD",10212,"KRN",.402,0)
.402
"BLD",10212,"KRN",.403,0)
.403
"BLD",10212,"KRN",.5,0)
.5
"BLD",10212,"KRN",.84,0)
.84
"BLD",10212,"KRN",3.6,0)
3.6
"BLD",10212,"KRN",3.8,0)
3.8
"BLD",10212,"KRN",9.2,0)
9.2
"BLD",10212,"KRN",9.8,0)
9.8
"BLD",10212,"KRN",9.8,"NM",0)
^9.68A^5^4
"BLD",10212,"KRN",9.8,"NM",2,0)
IVMPREC6^^0^B155161380
"BLD",10212,"KRN",9.8,"NM",3,0)
IVMPREC8^^0^B242938145
"BLD",10212,"KRN",9.8,"NM",4,0)
IVMPREC9^^0^B75404695
"BLD",10212,"KRN",9.8,"NM",5,0)
IVMPTRN8^^0^B86571271
"BLD",10212,"KRN",9.8,"NM","B","IVMPREC6",2)

"BLD",10212,"KRN",9.8,"NM","B","IVMPREC8",3)

"BLD",10212,"KRN",9.8,"NM","B","IVMPREC9",4)

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

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

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

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

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

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

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

"BLD",10212,"KRN","B",3.6,3.6)

"BLD",10212,"KRN","B",3.8,3.8)

"BLD",10212,"KRN","B",9.2,9.2)

"BLD",10212,"KRN","B",9.8,9.8)

"BLD",10212,"KRN","B",19,19)

"BLD",10212,"KRN","B",19.1,19.1)

"BLD",10212,"KRN","B",101,101)

"BLD",10212,"KRN","B",409.61,409.61)

"BLD",10212,"KRN","B",771,771)

"BLD",10212,"KRN","B",779.2,779.2)

"BLD",10212,"KRN","B",870,870)

"BLD",10212,"KRN","B",8989.51,8989.51)

"BLD",10212,"KRN","B",8989.52,8989.52)

"BLD",10212,"KRN","B",8994,8994)

"BLD",10212,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",10212,"QUES",0)
^9.62^^
"BLD",10212,"REQB",0)
^9.611^3^3
"BLD",10212,"REQB",1,0)
IVM*2.0*159^1
"BLD",10212,"REQB",2,0)
IVM*2.0*165^1
"BLD",10212,"REQB",3,0)
IVM*2.0*168^1
"BLD",10212,"REQB","B","IVM*2.0*159",1)

"BLD",10212,"REQB","B","IVM*2.0*165",2)

"BLD",10212,"REQB","B","IVM*2.0*168",3)

"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)
167^3171106^101100
"PKG",120,22,1,"PAH",1,1,0)
^^2^2^3171106
"PKG",120,22,1,"PAH",1,1,1,0)
ENROLLMENT SYSTEM COMMUNITY CARE (ESCC) HOME PHONE AND FUTURE DISCHARGE 
"PKG",120,22,1,"PAH",1,1,2,0)
DATE UPDATES
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
YES
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
4
"RTN","IVMPREC6")
0^2^B155161380
"RTN","IVMPREC6",1,0)
IVMPREC6 ;ALB/KCL,BRM,CKN,TDM,PWC,LBD,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ;09-05-2017 8:06AM
"RTN","IVMPREC6",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**3,4,12,17,34,58,79,102,115,140,144,121,151,152,165,167**;21-OCT-94;Build 39
"RTN","IVMPREC6",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","IVMPREC6",4,0)
 ;
"RTN","IVMPREC6",5,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC6",6,0)
 ; messages received from the IVM center.  Format of HL7 batch message:
"RTN","IVMPREC6",7,0)
 ;
"RTN","IVMPREC6",8,0)
 ;       BHS
"RTN","IVMPREC6",9,0)
 ;       {MSH
"RTN","IVMPREC6",10,0)
 ;        PID
"RTN","IVMPREC6",11,0)
 ;        ZPD
"RTN","IVMPREC6",12,0)
 ;        ZTA
"RTN","IVMPREC6",13,0)
 ;        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 DGENUPLD="",IVM3015=$$LOG^IVMPLOG(DFN,DT),DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS" ;IVM*2.0*165
"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, Cell phone and Home phone records in 301.92 File - Passed by reference
"RTN","IVMPREC6",280,0)
 ;EPCDEL - Contains field # of Pager, Email, Cell phone and Home 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)
 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC6",286,0)
 S EPCFARY("PHH")=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SOURCE",0))
"RTN","IVMPREC6",287,0)
 S EPCDEL("PNO")=".135^.1312^.1313^.1314"
"RTN","IVMPREC6",288,0)
 S EPCDEL("CPH")=".134^.139^.1311^.13111"
"RTN","IVMPREC6",289,0)
 S EPCDEL("EAD")=".133^.136^.137^.138"
"RTN","IVMPREC6",290,0)
 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC6",291,0)
 S EPCDEL("PHH")=".131^.1321^.1322^.1323"
"RTN","IVMPREC6",292,0)
 Q
"RTN","IVMPREC6",293,0)
 ;
"RTN","IVMPREC6",294,0)
AUPBLD(AUPFARY,UPDAUPG) ; Set up array containing fields for auto upload.
"RTN","IVMPREC6",295,0)
 ;AUPFARY - Contains fields in 301.92 File-Passed by reference
"RTN","IVMPREC6",296,0)
 ;UPDAUPG - Contains all groups initialized to '0'
"RTN","IVMPREC6",297,0)
 N AUPSTR,AUPGRP,AUPFLST,AUPPCE,AUPSGSQ,AUPDA
"RTN","IVMPREC6",298,0)
 F I=3:1 S AUPSTR=$P($T(AUPLST+I),";;",2,3) Q:$P(AUPSTR,";")="QUIT"  D
"RTN","IVMPREC6",299,0)
 .S AUPGRP=$P(AUPSTR,";"),AUPFLST=$P(AUPSTR,";",2)
"RTN","IVMPREC6",300,0)
 .F AUPPCE=1:1:$L(AUPFLST,"^") D
"RTN","IVMPREC6",301,0)
 ..S AUPSGSQ=$P(AUPFLST,"^",AUPPCE) Q:AUPSGSQ=""
"RTN","IVMPREC6",302,0)
 ..S AUPDA=$O(^IVM(301.92,"C",AUPSGSQ,0)) Q:AUPDA=""
"RTN","IVMPREC6",303,0)
 ..S AUPFARY(AUPDA)=AUPGRP
"RTN","IVMPREC6",304,0)
 ..S:AUPGRP'="" UPDAUPG(AUPGRP)=0  ; Default group update flags to '0'
"RTN","IVMPREC6",305,0)
 Q
"RTN","IVMPREC6",306,0)
 ;
"RTN","IVMPREC6",307,0)
AUPLST ; P1;P2
"RTN","IVMPREC6",308,0)
 ; P1 = Group Name (treat all entries as this group if present)
"RTN","IVMPREC6",309,0)
 ; P2 = .01 field(s) from 301.92 seperated by '^'
"RTN","IVMPREC6",310,0)
 ;;D1;ZCT03D1^ZCT04D1^ZCT051D1^ZCT052D1^ZCT053D1^ZCT054D1^ZCT055D1^ZCT06D1^ZCT07D1^ZCT10D1
"RTN","IVMPREC6",311,0)
 ;;E1;ZCT03E1^ZCT04E1^ZCT051E1^ZCT052E1^ZCT053E1^ZCT054E1^ZCT055E1^ZCT06E1^ZCT07E1^ZCT10E1
"RTN","IVMPREC6",312,0)
 ;;E2;ZCT03E2^ZCT04E2^ZCT051E2^ZCT052E2^ZCT053E2^ZCT054E2^ZCT055E2^ZCT06E2^ZCT07E2^ZCT10E2
"RTN","IVMPREC6",313,0)
 ;;K1;ZCT03K1^ZCT04K1^ZCT051K1^ZCT052K1^ZCT053K1^ZCT054K1^ZCT055K1^ZCT06K1^ZCT07K1^ZCT10K1
"RTN","IVMPREC6",314,0)
 ;;K2;ZCT03K2^ZCT04K2^ZCT051K2^ZCT052K2^ZCT053K2^ZCT054K2^ZCT055K2^ZCT06K2^ZCT07K2^ZCT10K2
"RTN","IVMPREC6",315,0)
 ;;TA;ZTA02^ZTA03^ZTA04^ZTA051^ZTA052^ZTA053^ZTA054^ZTA055^ZTA056^ZTA058^ZTA059^ZTA07^ZTA08^ZTA09^ZTA054F^ZTA055F
"RTN","IVMPREC6",316,0)
 ;;;ZEM03^ZEM04^ZEM05^ZEM061^ZEM062^ZEM063^ZEM064^ZEM065^ZEM068^ZEM07^ZEM09
"RTN","IVMPREC6",317,0)
 ;;;ZEM03S^ZEM04S^ZEM05S^ZEM061S^ZEM062S^ZEM063S^ZEM064S^ZEM065S^ZEM068S^ZEM07S^ZEM09S
"RTN","IVMPREC6",318,0)
 ;;;PID06^PID10^PID16^PID17^PID22^ZPD30^ZPD06^ZPD07
"RTN","IVMPREC6",319,0)
 ;;QUIT
"RTN","IVMPREC6",320,0)
 ;;
"RTN","IVMPREC6",321,0)
 ;;The following have been disabled until further notice
"RTN","IVMPREC6",322,0)
 ;;;PID113N^PID114N^PID24^PID13W
"RTN","IVMPREC6",323,0)
 ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1112C1^PID1112C2^PID13CA^RF161CA^RF171CA
"RTN","IVMPREC8")
0^3^B242938145
"RTN","IVMPREC8",1,0)
IVMPREC8 ;ALB/KCL,BRM,PJR,CKN,TDM,PWC,LBD,DPR,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;05 Sep 2017  8:56 AM
"RTN","IVMPREC8",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**5,6,12,58,73,79,102,115,121,148,151,152,168,167**;21-OCT-94;Build 39
"RTN","IVMPREC8",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","IVMPREC8",4,0)
 ;
"RTN","IVMPREC8",5,0)
 ; This routine is called from IVMPREC6.
"RTN","IVMPREC8",6,0)
 ; This routine will process batch ORU demographic (event type Z05) HL7
"RTN","IVMPREC8",7,0)
 ; messages received from the IVM center.
"RTN","IVMPREC8",8,0)
 ;
"RTN","IVMPREC8",9,0)
 ;
"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)
 . ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC8",348,0)
 . ; Always keep NOPHUP = 0 so Home phone number data is not handled here    
"RTN","IVMPREC8",349,0)
 . ;I 'UPDEPC("PHH") S NOPHUP=1
"RTN","IVMPREC8",350,0)
 . ;I UPDEPC("PHH"),'$G(UPPHN) S NOPHUP=1
"RTN","IVMPREC8",351,0)
 . K UPPHN
"RTN","IVMPREC8",352,0)
 . I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT,NOPHUP)
"RTN","IVMPREC8",353,0)
 Q
"RTN","IVMPREC8",354,0)
 ;
"RTN","IVMPREC8",355,0)
RF1PROC ;
"RTN","IVMPREC8",356,0)
 N IVMEPC
"RTN","IVMPREC8",357,0)
 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
"RTN","IVMPREC8",358,0)
 .;if RF1 field is SEQ6, then parse subcomponents
"RTN","IVMPREC8",359,0)
 .I IVMXREF["RF16" D  Q
"RTN","IVMPREC8",360,0)
 ..;- get data containing 4 pieces seperated by HLECH (~)
"RTN","IVMPREC8",361,0)
 ..S IVMRFDAT=$P(IVMSEG,HLFS,6)
"RTN","IVMPREC8",362,0)
 ..S IVMPIECE=$E(IVMXREF,5),IVMFLD=$P(IVMRFDAT,"~",IVMPIECE)
"RTN","IVMPREC8",363,0)
 ..;get 6th character of IVMXREF to determine if value is for Address
"RTN","IVMPREC8",364,0)
 ..;OR Email, Cell and Pager
"RTN","IVMPREC8",365,0)
 ..S IVMEPC=$E(IVMXREF,6)
"RTN","IVMPREC8",366,0)
 ..;Convert Change Source for Address, Email, Cell and Pager
"RTN","IVMPREC8",367,0)
 ..I IVMPIECE=2 S IVMFLD=$S(IVMEPC'="":$$EPCSRCC(IVMFLD),1:$$ADDRCNV(IVMFLD))
"RTN","IVMPREC8",368,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",369,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",370,0)
 .I IVMXREF["RF17" D  Q
"RTN","IVMPREC8",371,0)
 ..;get address/telecomm change date/tm field
"RTN","IVMPREC8",372,0)
 ..S IVMFLD=$$FMDATE^HLFNC($P(IVMSEG,HLFS,7))
"RTN","IVMPREC8",373,0)
 ..Q:IVMFLD=""
"RTN","IVMPREC8",374,0)
 ..D STORE^IVMPREC9
"RTN","IVMPREC8",375,0)
 ..;
"RTN","IVMPREC8",376,0)
 ..;I RF1TYPE="CAD",$P($G(ADDRESS("CA")),HLFS)]"" D  Q
"RTN","IVMPREC8",377,0)
 ..;.; - execute code on the 1 node and get DHCP field
"RTN","IVMPREC8",378,0)
 ..;.S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
"RTN","IVMPREC8",379,0)
 ..;.I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG("CA")=1
"RTN","IVMPREC8",380,0)
 ..;
"RTN","IVMPREC8",381,0)
 ..; check for auto-upload
"RTN","IVMPREC8",382,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",383,0)
 ..I IVMDHCP="" S IVMDHCP=$S(RF1TYPE="PHH":$P($G(^DPT(DFN,.132)),HLFS,1),1:"")     ;Added for IVM*2*152
"RTN","IVMPREC8",384,0)
 ..I IVMFLD]"",(IVMFLD>IVMDHCP) D
"RTN","IVMPREC8",385,0)
 ...S UPDEPC(RF1TYPE)=$G(EPCFARY(RF1TYPE))
"RTN","IVMPREC8",386,0)
 ...I RF1TYPE="SAD" S UPDEPC("SAD")=1
"RTN","IVMPREC8",387,0)
 ...; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC8",388,0)
 ...; Keep UPDEPC("PHH") value as Home phone record IENs of #301.92 file
"RTN","IVMPREC8",389,0)
 ...;I RF1TYPE="PHH" S UPDEPC("PHH")=1   ; Added for IVM*2*152
"RTN","IVMPREC8",390,0)
 Q
"RTN","IVMPREC8",391,0)
ADDRCNV(ADDRSRC) ;convert Address Source from HL7 to DHCP format
"RTN","IVMPREC8",392,0)
 ;
"RTN","IVMPREC8",393,0)
 Q:$G(ADDRSRC)']"" ""
"RTN","IVMPREC8",394,0)
 Q:ADDRSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",395,0)
 Q:ADDRSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",396,0)
 Q:ADDRSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",397,0)
 Q:ADDRSRC="USNCOA" "NCOA"
"RTN","IVMPREC8",398,0)
 Q:ADDRSRC="USVABVA" "BVA"
"RTN","IVMPREC8",399,0)
 Q:ADDRSRC="USVAINS" "VAINS"
"RTN","IVMPREC8",400,0)
 Q:ADDRSRC="USPS" "USPS"
"RTN","IVMPREC8",401,0)
 Q:ADDRSRC="LACS" "LACS"
"RTN","IVMPREC8",402,0)
 Q:ADDRSRC="USVOA" "VOA"
"RTN","IVMPREC8",403,0)
 Q ""
"RTN","IVMPREC8",404,0)
EPCSRCC(EPCSRC) ;Convert Email, Cell, Pager Change Source from HL7 to DHCP
"RTN","IVMPREC8",405,0)
 ;
"RTN","IVMPREC8",406,0)
 Q:$G(EPCSRC)']"" ""
"RTN","IVMPREC8",407,0)
 Q:EPCSRC="USVAHEC" "HEC"
"RTN","IVMPREC8",408,0)
 Q:EPCSRC="USVAMC" "VAMC"
"RTN","IVMPREC8",409,0)
 Q:EPCSRC="USVAHBSC" "HBSC"
"RTN","IVMPREC8",410,0)
 Q ""
"RTN","IVMPREC8",411,0)
BAICONV(BAISRC) ;Convert Bad address source from HL7 to DHCP format
"RTN","IVMPREC8",412,0)
 Q:$G(BAISRC)']"" ""
"RTN","IVMPREC8",413,0)
 Q:BAISRC="VAB1" 1
"RTN","IVMPREC8",414,0)
 Q:BAISRC="VAB2" 2
"RTN","IVMPREC8",415,0)
 Q:BAISRC="VAB3" 3
"RTN","IVMPREC8",416,0)
 Q:BAISRC="VAB4" 4
"RTN","IVMPREC8",417,0)
 Q ""
"RTN","IVMPREC8",418,0)
CONVPH(PH) ;remove special chars/spaces from Phone number
"RTN","IVMPREC8",419,0)
 ;*168 Check format, quit if OK else strip and return if not 10 numeric
"RTN","IVMPREC8",420,0)
 ;Format if 10 numeric.
"RTN","IVMPREC8",421,0)
 Q:PH?1"(".3N.1")".3N.1"-".4N PH
"RTN","IVMPREC8",422,0)
 S PH=$TR(PH," )(/#\-","")
"RTN","IVMPREC8",423,0)
 Q:PH'?10N PH
"RTN","IVMPREC8",424,0)
 Q "("_$E(PH,1,3)_")"_$E(PH,4,6)_"-"_$E(PH,7,10)
"RTN","IVMPREC8",425,0)
 ;
"RTN","IVMPREC8",426,0)
CNTRCONV(COUNTRY) ;Check if valid country
"RTN","IVMPREC8",427,0)
 I COUNTRY="" Q 0
"RTN","IVMPREC8",428,0)
 Q $O(^HL(779.004,"B",COUNTRY,""))
"RTN","IVMPREC8",429,0)
CHKEMAIL(EMAIL) ;Check for Valid Email
"RTN","IVMPREC8",430,0)
 I $G(EMAIL)="" Q 0
"RTN","IVMPREC8",431,0)
 I '(EMAIL?1.E1"@"1.E1"."1.E) Q 0
"RTN","IVMPREC8",432,0)
 Q 1
"RTN","IVMPREC9")
0^4^B75404695
"RTN","IVMPREC9",1,0)
IVMPREC9 ;ALB/KCL,BRM,CKN,TDM,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;09-05-2017 10:03am
"RTN","IVMPREC9",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**34,58,115,121,151,159,167**; 21-OCT-94;Build 39
"RTN","IVMPREC9",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","IVMPREC9",4,0)
 ;
"RTN","IVMPREC9",5,0)
 ;
"RTN","IVMPREC9",6,0)
 ;
"RTN","IVMPREC9",7,0)
STORE ; - store HL7 fields that have a different value than DHCP fields in
"RTN","IVMPREC9",8,0)
 ;   the IVM Patient (#301.5) file (#301.511) multiple for uploading
"RTN","IVMPREC9",9,0)
 ;
"RTN","IVMPREC9",10,0)
 S:$D(AUPFARY(IVMDEMDA)) UPDAUP(IVMDEMDA)=""
"RTN","IVMPREC9",11,0)
 G:IVMFLG STORE2
"RTN","IVMPREC9",12,0)
 S X=$$IEN^IVMUFNC4("PID")
"RTN","IVMPREC9",13,0)
 ;
"RTN","IVMPREC9",14,0)
 K DIC("DR")
"RTN","IVMPREC9",15,0)
 S DA(1)=IVM3015
"RTN","IVMPREC9",16,0)
 I $G(^IVM(301.5,DA(1),"IN",0))']"" S ^(0)="^301.501PA^^"
"RTN","IVMPREC9",17,0)
 S DIC="^IVM(301.5,"_DA(1)_",""IN"",",DIC(0)="L",DLAYGO=301.501
"RTN","IVMPREC9",18,0)
 K DD,DO D FILE^DICN
"RTN","IVMPREC9",19,0)
 K DIC,DLAYGO,X,Y
"RTN","IVMPREC9",20,0)
 ;
"RTN","IVMPREC9",21,0)
 ; - build mail message if SUPRESS DEMOGRAPHIC NOTIFICATION field is
"RTN","IVMPREC9",22,0)
 ;   not set in the IVM Site Parameter (#301.9) file
"RTN","IVMPREC9",23,0)
 ;
"RTN","IVMPREC9",24,0)
 I '$P($G(^IVM(301.9,1,0)),"^",5),'IVMADFLG D DEMBULL^IVMPREC6
"RTN","IVMPREC9",25,0)
 ;
"RTN","IVMPREC9",26,0)
 ; - set flag in order to not repeat STORE tag for one msg
"RTN","IVMPREC9",27,0)
 S IVMFLG=1
"RTN","IVMPREC9",28,0)
 ;
"RTN","IVMPREC9",29,0)
 S DA(2)=DA(1)
"RTN","IVMPREC9",30,0)
 S DA(1)=$P(^IVM(301.5,DA(1),"IN",0),"^",3)
"RTN","IVMPREC9",31,0)
 ;
"RTN","IVMPREC9",32,0)
STORE2 ;
"RTN","IVMPREC9",33,0)
 ; - X as the record in the IVM Demo Upload Fields (#301.92) file
"RTN","IVMPREC9",34,0)
 S X=+IVMDEMDA
"RTN","IVMPREC9",35,0)
 I $G(^IVM(301.5,DA(2),"IN",DA(1),"DEM",0))']"" S ^(0)="^301.511PA^^"
"RTN","IVMPREC9",36,0)
 S DIC="^IVM(301.5,"_DA(2)_",""IN"",DA(1),""DEM"",",DIC(0)="L"
"RTN","IVMPREC9",37,0)
 S DIC("DR")=".02////^S X=IVMFLD",DLAYGO=301.511
"RTN","IVMPREC9",38,0)
 K DD,DO D FILE^DICN
"RTN","IVMPREC9",39,0)
 K DIC,DLAYGO,X,Y
"RTN","IVMPREC9",40,0)
 ;
"RTN","IVMPREC9",41,0)
 Q
"RTN","IVMPREC9",42,0)
 ;
"RTN","IVMPREC9",43,0)
 ;
"RTN","IVMPREC9",44,0)
LOOK ; Find the current DHCP field value.
"RTN","IVMPREC9",45,0)
 ;  Input:   DR  --   Field number of the field in file #2
"RTN","IVMPREC9",46,0)
 ;          DFN  --   Pointer to the patient in file #2
"RTN","IVMPREC9",47,0)
 ;  Output:   Y  --   Internal value of field
"RTN","IVMPREC9",48,0)
 ;
"RTN","IVMPREC9",49,0)
 N IVMOUTTY,I
"RTN","IVMPREC9",50,0)
 ;S DIC="^DPT(",DA=DFN,DIQ="IVM",DIQ(0)="I" D EN^DIQ1
"RTN","IVMPREC9",51,0)
 S DIQ(0)=$S($G(DIQ(0))="":"I",$G(DIQ(0))="E":"E",1:"I")
"RTN","IVMPREC9",52,0)
 S IVMOUTTY=DIQ(0)
"RTN","IVMPREC9",53,0)
 S DIC="^DPT(",DA=DFN,DIQ="IVM" D EN^DIQ1
"RTN","IVMPREC9",54,0)
 ;S Y=$G(IVM(2,DFN,DR,"I"))
"RTN","IVMPREC9",55,0)
 S Y=$G(IVM(2,DFN,DR,IVMOUTTY))
"RTN","IVMPREC9",56,0)
 K DIC,DIQ,DR,IVM
"RTN","IVMPREC9",57,0)
 Q
"RTN","IVMPREC9",58,0)
AUTOEPC(DFN,UPDEPC) ;
"RTN","IVMPREC9",59,0)
 ; this functionality is copied from IVMLDEM6 and modified to allow
"RTN","IVMPREC9",60,0)
 ; an automated upload of patient communications information
"RTN","IVMPREC9",61,0)
 ;  Input:     DFN  -  as patient IEN
"RTN","IVMPREC9",62,0)
 ;          UPDEPC  -  array contains flag for update/noupdate for all
"RTN","IVMPREC9",63,0)
 ;                     communication types.
"RTN","IVMPREC9",64,0)
 ; Output: IVMFLAG  -  1 if communications fields updated
"RTN","IVMPREC9",65,0)
 ;                     0 if communications fields not updated
"RTN","IVMPREC9",66,0)
 ;
"RTN","IVMPREC9",67,0)
 N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,UPDT,IVMCVAL,IVMCFLD,SITEFLD,DFLG,CTYP,UPDT
"RTN","IVMPREC9",68,0)
 S IVMFLAG=0  ;initialize flags
"RTN","IVMPREC9",69,0)
 ; - check for required parameters
"RTN","IVMPREC9",70,0)
 Q:'$G(DFN) IVMFLAG
"RTN","IVMPREC9",71,0)
 S IVMDA2=$G(IVM3015)
"RTN","IVMPREC9",72,0)
 Q:'$G(IVMDA2) IVMFLAG
"RTN","IVMPREC9",73,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMPREC9",74,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
"RTN","IVMPREC9",75,0)
 Q:'IVMDA1 IVMFLAG
"RTN","IVMPREC9",76,0)
 ;
"RTN","IVMPREC9",77,0)
 S IVMI=0 F  S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']""  D
"RTN","IVMPREC9",78,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMPREC9",79,0)
 ..S (UPDT,DFLG)=0
"RTN","IVMPREC9",80,0)
 ..; - check for data node in (#301.511) sub-file
"RTN","IVMPREC9",81,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMPREC9",82,0)
 ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
"RTN","IVMPREC9",83,0)
 ..;Check if fields needs to be updated for particular comm. Type.
"RTN","IVMPREC9",84,0)
 ..S CTYP=0 F  S CTYP=$O(UPDEPC(CTYP)) Q:CTYP=""!UPDT  D
"RTN","IVMPREC9",85,0)
 ...I ("^"_$G(UPDEPC(CTYP))_"^")[("^"_+IVMNODE_"^") S UPDT=1
"RTN","IVMPREC9",86,0)
 ..S IVMCFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMCVAL=$P(IVMNODE,"^",2)
"RTN","IVMPREC9",87,0)
 ..; - load communications fields rec'd from IVM into DHCP (#2) file
"RTN","IVMPREC9",88,0)
 ..I UPDT D UPLOAD^IVMLDEM6(+DFN,IVMCFLD,IVMCVAL) S IVMFLAG=1
"RTN","IVMPREC9",89,0)
 ..; delete inaccurate Addr Change Site data if Source is not VAMC
"RTN","IVMPREC9",90,0)
 ..; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC9",91,0)
 ..;I UPDT,((IVMCFLD=.1311)!(IVMCFLD=.1313)!(IVMCFLD=.137)) D
"RTN","IVMPREC9",92,0)
 ..I UPDT,((IVMCFLD=.1311)!(IVMCFLD=.1313)!(IVMCFLD=.137)!(IVMCFLD=.1322)) D
"RTN","IVMPREC9",93,0)
 ...I IVMCVAL="VAMC" Q
"RTN","IVMPREC9",94,0)
 ...; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
"RTN","IVMPREC9",95,0)
 ...; S SITEFLD=$S(IVMCFLD=.1311:.13111,IVMCFLD=.1313:.1314,IVMCFLD=.137:.138)
"RTN","IVMPREC9",96,0)
 ...S SITEFLD=$S(IVMCFLD=.1311:.13111,IVMCFLD=.1313:.1314,IVMCFLD=.137:.138,IVMCFLD=.1322:.1323)
"RTN","IVMPREC9",97,0)
 ...S FDA(2,+DFN_",",SITEFLD)="@" D UPDATE^DIE("E","FDA")
"RTN","IVMPREC9",98,0)
 ..; - remove entry only for Email, Cell, Home phone and Pager from (#301.511) sub-file
"RTN","IVMPREC9",99,0)
 ..S CTYP=0 F  S CTYP=$O(EPCFARY(CTYP)) Q:CTYP=""!DFLG  D
"RTN","IVMPREC9",100,0)
 ...I ("^"_$G(EPCFARY(CTYP))_"^")[("^"_+IVMNODE_"^") S DFLG=1
"RTN","IVMPREC9",101,0)
 ..I DFLG D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMPREC9",102,0)
 ;Delete all communication data (Email, Cell phone, Pager, Home phone) if they are not received in Z05.
"RTN","IVMPREC9",103,0)
 I $D(EPCDEL) D
"RTN","IVMPREC9",104,0)
 . N CTYPE,DIE,DR,DA,CNTR,VAL
"RTN","IVMPREC9",105,0)
 . S DR="",CNTR=0,VAL="@"
"RTN","IVMPREC9",106,0)
 . S CTYPE="" F  S CTYPE=$O(EPCDEL(CTYPE)) Q:CTYPE=""  D
"RTN","IVMPREC9",107,0)
 . . F I=1:1:$L(EPCDEL(CTYPE),"^") S CNTR=CNTR+1,$P(DR,";",CNTR)=$P(EPCDEL(CTYPE),"^",I)_"////^S X=VAL"
"RTN","IVMPREC9",108,0)
 . S DIE="^DPT(",DA=DFN
"RTN","IVMPREC9",109,0)
 . D ^DIE K DIE,DA,DR
"RTN","IVMPREC9",110,0)
 Q IVMFLAG
"RTN","IVMPREC9",111,0)
 ;
"RTN","IVMPREC9",112,0)
AUTORINC(DFN) ;
"RTN","IVMPREC9",113,0)
 ; application to automatically upload Rated Incompetent data
"RTN","IVMPREC9",114,0)
 ; Input:     DFN   -   Patient IEN
"RTN","IVMPREC9",115,0)
 N IVMI,IVMJ,IVMDA1,IVMDA2,IVMNODE,IVMFLAG,IVMRIVAL,IVMRIFLD
"RTN","IVMPREC9",116,0)
 S IVMFLAG=0
"RTN","IVMPREC9",117,0)
 S IVMDA2=$G(IVM3015)
"RTN","IVMPREC9",118,0)
 I 'IVMDA2 Q IVMFLAG
"RTN","IVMPREC9",119,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMPREC9",120,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
"RTN","IVMPREC9",121,0)
 S IVMI=$O(^IVM(301.92,"C","ZPD08","")) I IVMI="" Q IVMFLAG
"RTN","IVMPREC9",122,0)
 S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
"RTN","IVMPREC9",123,0)
 I IVMJ']"" Q IVMFLAG
"RTN","IVMPREC9",124,0)
 ; - check for data node in (#301.511) sub-file
"RTN","IVMPREC9",125,0)
 S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMPREC9",126,0)
 I '(+IVMNODE)!($P(IVMNODE,"^",2)']"") Q IVMFLAG
"RTN","IVMPREC9",127,0)
 S IVMRIFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMRIVAL=$P(IVMNODE,"^",2)
"RTN","IVMPREC9",128,0)
 I IVMRIVAL="""""" S IVMRIVAL="@"
"RTN","IVMPREC9",129,0)
 D UPLOAD^IVMLDEM6(DFN,IVMRIFLD,IVMRIVAL) S IVMFLAG=1
"RTN","IVMPREC9",130,0)
 ; - remove entry from (#301.511) sub-file
"RTN","IVMPREC9",131,0)
 D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
"RTN","IVMPREC9",132,0)
 Q IVMFLAG
"RTN","IVMPREC9",133,0)
PHONE ; - ask user to delete phone # [Residence] from Patient (#2) file
"RTN","IVMPREC9",134,0)
 ; This tag is moved here from IVMLDEM6 due to routine size limit
"RTN","IVMPREC9",135,0)
 D FULL^VALM1
"RTN","IVMPREC9",136,0)
 W ! S DIR("A")="Is it okay to delete the patient's Phone Number [Residence]"
"RTN","IVMPREC9",137,0)
 W ! S DIR("A",1)="The patient's address has been updated and the phonenumber"
"RTN","IVMPREC9",138,0)
 S DIR("A",2)="remains on file."
"RTN","IVMPREC9",139,0)
 S DIR("A",3)=" "
"RTN","IVMPREC9",140,0)
 S DIR("A",4)="Patient Name: "_$P($$PT^IVMUFNC4(+DFN),"^")_" ("_$P($$PT^IVMUFNC4(+DFN),"^",3)_")"
"RTN","IVMPREC9",141,0)
 S DIR("A",5)="Phone Number [Residence]: "_$P($G(^DPT(+DFN,.13)),"^")
"RTN","IVMPREC9",142,0)
 S DIR("A",6)=" "
"RTN","IVMPREC9",143,0)
 S DIR("?",1)="Enter 'YES' to delete the patient's Phone Number [Residence] that is"
"RTN","IVMPREC9",144,0)
 S DIR("?",2)="currently on file.  Enter 'NO' to quit without deleting the patient's"
"RTN","IVMPREC9",145,0)
 S DIR("?")="Phone Number [Residence]."
"RTN","IVMPREC9",146,0)
 S DIR(0)="Y",DIR("B")="NO"
"RTN","IVMPREC9",147,0)
 D ^DIR K DIR
"RTN","IVMPREC9",148,0)
 S:Y $P(^DPT(DFN,.13),"^")="" W !!,"Patient's Phone Number [Residence] has ",$S(Y:"",1:"not "),"been deleted."
"RTN","IVMPREC9",149,0)
 Q
"RTN","IVMPREC9",150,0)
 ;
"RTN","IVMPREC9",151,0)
AUTOAUP(DFN,UPDAUP,UPDAUPG) ;
"RTN","IVMPREC9",152,0)
 ; automated upload of misc information
"RTN","IVMPREC9",153,0)
 ;  Input:     DFN  -  patient IEN
"RTN","IVMPREC9",154,0)
 ;          UPDAUP  -  array contains fields for auto-upload
"RTN","IVMPREC9",155,0)
 ;         UPDAUPG  -  array contains field group flag for auto-upload
"RTN","IVMPREC9",156,0)
 ;
"RTN","IVMPREC9",157,0)
 N IVMDA2,IVMDA1,IVMI,MULTFLG,IVMXREF,UFLG,IVMJ,IVMNODE,IVMCFLD,IVMCVAL,Y,IVM30192,MULFIL
"RTN","IVMPREC9",158,0)
 Q:'$G(DFN)
"RTN","IVMPREC9",159,0)
 S IVMDA2=$G(IVM3015) Q:'IVMDA2
"RTN","IVMPREC9",160,0)
 S IVMDA1=$O(^HL(771.3,"B","PID",""))
"RTN","IVMPREC9",161,0)
 S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1) Q:'IVMDA1
"RTN","IVMPREC9",162,0)
 ;
"RTN","IVMPREC9",163,0)
 S IVMI="" F  S IVMI=$O(UPDAUP(IVMI)) Q:IVMI=""  D
"RTN","IVMPREC9",164,0)
 .;
"RTN","IVMPREC9",165,0)
 .;If DHCP field is a multiple set multiple flag for special filing
"RTN","IVMPREC9",166,0)
 .S MULTFLG=0
"RTN","IVMPREC9",167,0)
 .S IVM30192=$G(^IVM(301.92,IVMI,0)),IVMXREF=$P(IVM30192,"^",2)
"RTN","IVMPREC9",168,0)
 .I IVMXREF="PID10" S MULTFLG=1       ;Race
"RTN","IVMPREC9",169,0)
 .I IVMXREF="PID117C" S MULTFLG=1     ;Conf Addr Category
"RTN","IVMPREC9",170,0)
 .I IVMXREF="PID22" S MULTFLG=1       ;Ethnicity
"RTN","IVMPREC9",171,0)
 .;
"RTN","IVMPREC9",172,0)
 .;Don't file if part of a group & group update flag not set
"RTN","IVMPREC9",173,0)
 .S UFLG=1 I AUPFARY(IVMI)'="",'UPDAUPG(AUPFARY(IVMI)) S UFLG=0
"RTN","IVMPREC9",174,0)
 .;
"RTN","IVMPREC9",175,0)
 .S IVMJ=0 F  S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']""  D
"RTN","IVMPREC9",176,0)
 ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
"RTN","IVMPREC9",177,0)
 ..I $G(AUPFARY(+$P(IVMNODE,"^")))'="",(($P(IVMNODE,"^",2)="")!($P(IVMNODE,"^",2)="""""")) S $P(IVMNODE,"^",2)="@"
"RTN","IVMPREC9",178,0)
 ..I +$G(ZEMADRUP(IVMXREF)),$P(IVMNODE,"^",2)="" S $P(IVMNODE,"^",2)="@"
"RTN","IVMPREC9",179,0)
 ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
"RTN","IVMPREC9",180,0)
 ..S IVMCFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5)
"RTN","IVMPREC9",181,0)
 ..S IVMCVAL=$P(IVMNODE,"^",2)
"RTN","IVMPREC9",182,0)
 ..;
"RTN","IVMPREC9",183,0)
 ..I UFLG D
"RTN","IVMPREC9",184,0)
 ...I MULTFLG D AUTOAUPM(+DFN,IVM30192,IVMCVAL)         ;file mult fld
"RTN","IVMPREC9",185,0)
 ...I 'MULTFLG D UPLOAD^IVMLDEM6(+DFN,IVMCFLD,IVMCVAL)  ;file non-mult
"RTN","IVMPREC9",186,0)
 ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)          ;remove from 301.511
"RTN","IVMPREC9",187,0)
 ..; - if no display or uploadable fields left, delete the PID segment
"RTN","IVMPREC9",188,0)
 ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
"RTN","IVMPREC9",189,0)
 ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
"RTN","IVMPREC9",190,0)
 Q
"RTN","IVMPREC9",191,0)
 ;
"RTN","IVMPREC9",192,0)
AUTOAUPM(DFN,IVM30192,IVMVALUE) ;
"RTN","IVMPREC9",193,0)
 ;  Input:       DFN  -  as patient IEN
"RTN","IVMPREC9",194,0)
 ;          IVM30192  -  as '0' node of the 301.92 entry
"RTN","IVMPREC9",195,0)
 ;          IVMVALUE  -  as the value of the field
"RTN","IVMPREC9",196,0)
 ;
"RTN","IVMPREC9",197,0)
 ; Output: None
"RTN","IVMPREC9",198,0)
 ;
"RTN","IVMPREC9",199,0)
 N MFIL,MFLD,DDINFO,DDMNOD,DDMFLD,DA,DIK,DGENDA,MULFIL,DATA,SUB
"RTN","IVMPREC9",200,0)
 S MFIL=$P(IVM30192,"^",4),MFLD=$P(IVM30192,"^",5)
"RTN","IVMPREC9",201,0)
 S DDINFO=$G(^DD(MFIL,MFLD,0))
"RTN","IVMPREC9",202,0)
 S DDMNOD=$P($P(DDINFO,"^",4),";"),DDMFLD=+$P(DDINFO,"^",2)
"RTN","IVMPREC9",203,0)
 ;
"RTN","IVMPREC9",204,0)
 ; - delete values currently in the multiple field
"RTN","IVMPREC9",205,0)
 S DA(1)=DFN,DIK="^DPT("_DFN_","""_DDMNOD_""","
"RTN","IVMPREC9",206,0)
 S DA=0 F  S DA=$O(^DPT(DFN,DDMNOD,DA)) Q:'DA  D ^DIK
"RTN","IVMPREC9",207,0)
 ;
"RTN","IVMPREC9",208,0)
 ; - add new values to multiple field
"RTN","IVMPREC9",209,0)
 S DGENDA(1)=DFN
"RTN","IVMPREC9",210,0)
 ;
"RTN","IVMPREC9",211,0)
 I DDMFLD=2.02 D
"RTN","IVMPREC9",212,0)
 .S DATA(.02)=$$FIND1^DIC(10.3,,,"SELF IDENTIFICATION")
"RTN","IVMPREC9",213,0)
 .S SUB="" F  S SUB=$O(IVMRACE(2,SUB)) Q:SUB=""  D
"RTN","IVMPREC9",214,0)
 ..S DATA(.01)=SUB
"RTN","IVMPREC9",215,0)
 ..; Changed FileMan call for processing of DINUM recs IVM*2.0*159
"RTN","IVMPREC9",216,0)
 ..;I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
"RTN","IVMPREC9",217,0)
 ..S (X,DINUM)=DATA(.01),DIC="^DPT(DFN,.02,",DA(1)=DFN,DIC(0)="L"
"RTN","IVMPREC9",218,0)
 ..K DO D FILE^DICN K DIC,X,DINUM,DA
"RTN","IVMPREC9",219,0)
 ;
"RTN","IVMPREC9",220,0)
 I DDMFLD=2.06 D
"RTN","IVMPREC9",221,0)
 .S DATA(.01)=IVMVALUE
"RTN","IVMPREC9",222,0)
 .S DATA(.02)=$$FIND1^DIC(10.3,,,"SELF IDENTIFICATION")
"RTN","IVMPREC9",223,0)
 .;Changed Fileman call for processing of Dinum recs IVM*2.0*159-BG
"RTN","IVMPREC9",224,0)
 .;I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
"RTN","IVMPREC9",225,0)
 .S (X,DINUM)=DATA(.01),DIC="^DPT(DFN,.06,",DA(1)=DFN,DIC(0)="L"
"RTN","IVMPREC9",226,0)
 .K DO D FILE^DICN K DIC,X,DINUM,DA
"RTN","IVMPREC9",227,0)
 ;
"RTN","IVMPREC9",228,0)
 I DDMFLD=2.141 D
"RTN","IVMPREC9",229,0)
 .S DATA(1)="Y"
"RTN","IVMPREC9",230,0)
 .S SUB="" F  S SUB=$O(CONFADCT(SUB)) Q:SUB=""  D
"RTN","IVMPREC9",231,0)
 ..S DATA(.01)=SUB
"RTN","IVMPREC9",232,0)
 ..I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
"RTN","IVMPREC9",233,0)
 Q
"RTN","IVMPTRN8")
0^5^B86571271
"RTN","IVMPTRN8",1,0)
IVMPTRN8 ;ALB/RKS,PDJ,BRM,TDM,PJH,TDM,PWC,LBD,DRP,DJS - HL7 FULL DATA TRANSMISSION (Z07) BUILDER ;27 Oct 2017  8:56 AM
"RTN","IVMPTRN8",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,24,36,37,47,48,42,34,77,76,75,79,85,89,98,56,97,104,113,109,114,105,115,121,151,141,150,160,161,168,167**;21-OCT-94;Build 39
"RTN","IVMPTRN8",3,0)
 ;
"RTN","IVMPTRN8",4,0)
 ;
"RTN","IVMPTRN8",5,0)
BUILD(DFN,IVMMTDT,IVMCT,IVMQUERY) ; --
"RTN","IVMPTRN8",6,0)
 ;  Description: This entry point will be used to create an HL7 
"RTN","IVMPTRN8",7,0)
 ;  "Full Data Transmission" message for a patient.
"RTN","IVMPTRN8",8,0)
 ;
"RTN","IVMPTRN8",9,0)
 ;  Input:
"RTN","IVMPTRN8",10,0)
 ;        DFN - Patient IEN
"RTN","IVMPTRN8",11,0)
 ;    IVMMTDT - date of the patient's Means Test or Copay Test
"RTN","IVMPTRN8",12,0)
 ;      IVMCT - count of hl7 segments transmitted, pass by reference
"RTN","IVMPTRN8",13,0)
 ;   IVMQUERY - array passed in by reference where
"RTN","IVMPTRN8",14,0)
 ;    IVMQUERY("LTD") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",15,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",16,0)
 ;                last treatment date
"RTN","IVMPTRN8",17,0)
 ;    IVMQUERY("OVIS") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",18,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",19,0)
 ;                finding outpatient visits
"RTN","IVMPTRN8",20,0)
 ;
"RTN","IVMPTRN8",21,0)
 ;  HL7 variables as defined by call to INIT^IVMUFNC:
"RTN","IVMPTRN8",22,0)
 ;      HLEVN - HL7 message event counter 
"RTN","IVMPTRN8",23,0)
 ;      HLSDT - a flag that indicates that the data to be sent is
"RTN","IVMPTRN8",24,0)
 ;              stored in the ^TMP("HLS") global array.
"RTN","IVMPTRN8",25,0)
 ;
"RTN","IVMPTRN8",26,0)
 ;  The following variables returned by the INIT^HLTRANS entry point:
"RTN","IVMPTRN8",27,0)
 ;    HLNDAP - Non-DHCP Application Pointer from file 770
"RTN","IVMPTRN8",28,0)
 ;   HLNDAP0 - Zero node from file 770 corresponding to HLNDAP
"RTN","IVMPTRN8",29,0)
 ;     HLDAP - DHCP Application Pointer from file 771
"RTN","IVMPTRN8",30,0)
 ;     HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP
"RTN","IVMPTRN8",31,0)
 ;     HLPID - HL7 processing ID from file 770
"RTN","IVMPTRN8",32,0)
 ;     HLVER - HL7 version number from file 770
"RTN","IVMPTRN8",33,0)
 ;      HLFS - HL7 Field Separator from the 'FS' node of file 771
"RTN","IVMPTRN8",34,0)
 ;     HLECH - HL7 Encoding Characters from the 'EC' node of file 771
"RTN","IVMPTRN8",35,0)
 ;       HLQ - Double quotes ("") for use in building HL7 segments
"RTN","IVMPTRN8",36,0)
 ;     HLERR - if an error is encountered, an error message is returned
"RTN","IVMPTRN8",37,0)
 ;             in the HLERR variable.
"RTN","IVMPTRN8",38,0)
 ;      HLDA - the internal entry number for the entry created in
"RTN","IVMPTRN8",39,0)
 ;             file #772.
"RTN","IVMPTRN8",40,0)
 ;      HLDT - transmission date/time (associated with the entry in file
"RTN","IVMPTRN8",41,0)
 ;             #772 identified by HLDA) in internal VA FileMan format.
"RTN","IVMPTRN8",42,0)
 ;     HLDT1 - the same transmission date/time as the HLDT variable, 
"RTN","IVMPTRN8",43,0)
 ;             only in HL7 format.
"RTN","IVMPTRN8",44,0)
 ;
"RTN","IVMPTRN8",45,0)
 ; Output:
"RTN","IVMPTRN8",46,0)
 ;  ^TMP("HLS",$J,IVMCT) - global array containing all segments of the HL7 message that the VistA application wishes to send.  The HLSDT variable is defined above and the IVMCT variable is a sequential number incremented by 1.
"RTN","IVMPTRN8",47,0)
 ;
"RTN","IVMPTRN8",48,0)
 ;
"RTN","IVMPTRN8",49,0)
 N DGINC,DGIR,DGREL,I,IVMNTE,IVMPID,IVMSUB,IVMZRD,VAFPID,VAFZEL,FBZFE,IVMZCD,DELETE,NODE,IVMPIEN,TEST,IVMPNODE,TESTTYPE,SEQS,TESTCODE,HARDSHIP,ACTVIEN,IVMZMH,IVMSEQ
"RTN","IVMPTRN8",50,0)
 N EDBMTZ06,ZMHSQ,SETID,OBXCNT,OBXTMP,DGSEC,SEGOCC,ZIOSEG,N101015,RF1SEG,ZCTTYP,ZCTARY,ZCTSQ,VAFPID,CAFLG
"RTN","IVMPTRN8",51,0)
 ;
"RTN","IVMPTRN8",52,0)
 ; create (PID) Patient Identification segment
"RTN","IVMPTRN8",53,0)
 ; **** Add ICN to 2nd piece PID segment for MPI@HEC.
"RTN","IVMPTRN8",54,0)
 S IVMCMOR="1,2",IVMSEQ=1
"RTN","IVMPTRN8",55,0)
 ; check to see if site is a legacy site.  If not add ICN to PID segment.
"RTN","IVMPTRN8",56,0)
 I '$D(^PPP(1020.128,"AC",$P($$SITE^VASITE,"^",3))) D
"RTN","IVMPTRN8",57,0)
 . I +$$GETICN^MPIF001(DFN)>0,($$IFLOCAL^MPIF001(DFN)=0) S IVMSEQ=IVMSEQ_",2",IVMCMOR="1,2,3"  ;add SEQ 1 and 2 for PID
"RTN","IVMPTRN8",58,0)
 ;
"RTN","IVMPTRN8",59,0)
 ; send SSN indicating pseudo
"RTN","IVMPTRN8",60,0)
 ; I $P(IVMPID_$G(IVMPID(1)),HLFS,20)["P" D PSEUDO^IVMPTRN1  ; strip 'P' from pseudo SSNs
"RTN","IVMPTRN8",61,0)
 S IVMSEQ=IVMSEQ_",3,5,6,7,8,10,11,12,13,14,16,17,19,22,24"
"RTN","IVMPTRN8",62,0)
 K IVMPID D BLDPID^VAFCQRY1(DFN,1,IVMSEQ,.IVMPID,.HL,.ERROR)
"RTN","IVMPTRN8",63,0)
 K VAFPID D STRIP11
"RTN","IVMPTRN8",64,0)
 S SEGOCC="" F  S SEGOCC=$O(VAFPID(SEGOCC)) Q:SEGOCC=""  D
"RTN","IVMPTRN8",65,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFPID(SEGOCC)
"RTN","IVMPTRN8",66,0)
 ;
"RTN","IVMPTRN8",67,0)
 ; **** create (PD1) Patient CMOR segment for MPI@HEC.
"RTN","IVMPTRN8",68,0)
 S:'$D(HL("FS")) HL("FS")=HLFS
"RTN","IVMPTRN8",69,0)
 S:'$D(HL("ECH")) HL("ECH")=HLECH
"RTN","IVMPTRN8",70,0)
 S:'$D(HL("Q")) HL("Q")=HLQ
"RTN","IVMPTRN8",71,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLPD1(DFN,IVMCMOR)
"RTN","IVMPTRN8",72,0)
 ;
"RTN","IVMPTRN8",73,0)
 ; create (ZPD) Patient Dependent Info. segment
"RTN","IVMPTRN8",74,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN1^VAFHLZPD(DFN,"1,6,7,8,9,11,12,13,17,19,30,31,32,33,34,35,40"),IVMINS=$P(^(IVMCT),HLFS,12)
"RTN","IVMPTRN8",75,0)
 I $D(VAFZPD(1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFZPD(1) K VAFZPD(1)
"RTN","IVMPTRN8",76,0)
 ;
"RTN","IVMPTRN8",77,0)
 ; create (ZTA) Temporary Address segment
"RTN","IVMPTRN8",78,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,8,9",,.HL)
"RTN","IVMPTRN8",79,0)
 ;
"RTN","IVMPTRN8",80,0)
 ; create (ZIE) Ineligible segment
"RTN","IVMPTRN8",81,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIE(DFN,"1,2,3",1)
"RTN","IVMPTRN8",82,0)
 ;
"RTN","IVMPTRN8",83,0)
 ; create (ZEL) Eligibility segment(s) 
"RTN","IVMPTRN8",84,0)
 ; **** Add 5th piece to ZEL to correct consistency check
"RTN","IVMPTRN8",85,0)
 ; added 41-44 for CLV IVM*2.0*161
"RTN","IVMPTRN8",86,0)
 D EN1^VAFHLZEL(DFN,"1,2,5,6,7,8,10,11,13,14,15,16,17,18,19,20,21,22,23,24,25,29,34,35,37,38,39,40,41,42,43,44",2,.VAFZEL)
"RTN","IVMPTRN8",87,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1))  ; Primary Eligibility
"RTN","IVMPTRN8",88,0)
 I $D(VAFZEL(1,1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1,1))
"RTN","IVMPTRN8",89,0)
 ; - other entitled eligibilities
"RTN","IVMPTRN8",90,0)
 F IVMSUB=1:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",91,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(+IVMSUB))
"RTN","IVMPTRN8",92,0)
 ;
"RTN","IVMPTRN8",93,0)
 ; create ZE2 segment (Optional)
"RTN","IVMPTRN8",94,0)
 I $P($G(^DPT(DFN,.385)),U)'="" S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZE2(DFN,"1,2")
"RTN","IVMPTRN8",95,0)
 ;
"RTN","IVMPTRN8",96,0)
 ; create (ZEN) Enrollment segment
"RTN","IVMPTRN8",97,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEN(DFN)
"RTN","IVMPTRN8",98,0)
 ;
"RTN","IVMPTRN8",99,0)
 ; create (ZCD) Catastrophic Disability segment(s)
"RTN","IVMPTRN8",100,0)
 D BUILD^VAFHLZCD(.IVMZCD,DFN,,HLQ,HLFS)
"RTN","IVMPTRN8",101,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZCD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",102,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZCD(+IVMSUB))
"RTN","IVMPTRN8",103,0)
 ;
"RTN","IVMPTRN8",104,0)
 ; Optionally create (ZMH) Military History segments
"RTN","IVMPTRN8",105,0)
 ; Pass "*" as parameter to send unlimited MSEs in Z07 (IVM*2*141)
"RTN","IVMPTRN8",106,0)
 D ENTER^VAFHLZMH(DFN,"IVMZMH","*")
"RTN","IVMPTRN8",107,0)
 ;DJS, Don't create ZMH segment if array entry is an FDD MSE; IVM*2.0*167
"RTN","IVMPTRN8",108,0)
 N ZMHED,MSESUB,DONEMSE
"RTN","IVMPTRN8",109,0)
 S (ZMHSQ,SETID,DONEMSE)=0
"RTN","IVMPTRN8",110,0)
 I $D(IVMZMH) F  S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ=""  D
"RTN","IVMPTRN8",111,0)
 . Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")=""
"RTN","IVMPTRN8",112,0)
 . ;If no Service Entry Date, QUIT
"RTN","IVMPTRN8",113,0)
 . S ZMHED=$P(IVMZMH(ZMHSQ,0),U,5),ZMHED=$P(ZMHED,"~",1) Q:ZMHED=""
"RTN","IVMPTRN8",114,0)
 . S ZMHED=$$HL7TFM^XLFDT(ZMHED)
"RTN","IVMPTRN8",115,0)
 . ;Get MSE, if no more MSEs, process Conflict Information, if present
"RTN","IVMPTRN8",116,0)
 . I 'DONEMSE S MSESUB="",MSESUB=$O(^DPT(DFN,.3216,"B",ZMHED,MSESUB)) S:MSESUB="" DONEMSE=1
"RTN","IVMPTRN8",117,0)
 . ;Do not create ZMH segment if FDD MSE
"RTN","IVMPTRN8",118,0)
 . I 'DONEMSE,$P(^DPT(DFN,.3216,MSESUB,0),U,8)'="" Q  ;Only check for FDD if MSE entry
"RTN","IVMPTRN8",119,0)
 . S SETID=SETID+1,IVMCT=IVMCT+1
"RTN","IVMPTRN8",120,0)
 . S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6)
"RTN","IVMPTRN8",121,0)
 ;
"RTN","IVMPTRN8",122,0)
 ; create (ZRD) Rated Disabilities segment(s)
"RTN","IVMPTRN8",123,0)
 D EN^VAFHLZRD(DFN,"1,2,3,4,12,13,14,",HLQ,HLFS,"IVMZRD")
"RTN","IVMPTRN8",124,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",125,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0))
"RTN","IVMPTRN8",126,0)
 ;
"RTN","IVMPTRN8",127,0)
 ; create (ZCT) Emergency Contact segment
"RTN","IVMPTRN8",128,0)
 ;S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1)
"RTN","IVMPTRN8",129,0)
 K ZCTARY F ZCTTYP=1:1:5 D   ;Create Optional ZCT Segments
"RTN","IVMPTRN8",130,0)
 . S ZCTARY(ZCTTYP)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",ZCTTYP,1)
"RTN","IVMPTRN8",131,0)
 S (ZCTTYP,ZCTSQ)=0
"RTN","IVMPTRN8",132,0)
 I $D(ZCTARY) F  S ZCTTYP=$O(ZCTARY(ZCTTYP)) Q:ZCTTYP=""  D
"RTN","IVMPTRN8",133,0)
 . Q:$P(ZCTARY(ZCTTYP),HLFS,11)=HLQ
"RTN","IVMPTRN8",134,0)
 . S ZCTSQ=ZCTSQ+1,$P(ZCTARY(ZCTTYP),HLFS,2)=ZCTSQ
"RTN","IVMPTRN8",135,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(ZCTTYP)
"RTN","IVMPTRN8",136,0)
 I ZCTSQ=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(1)
"RTN","IVMPTRN8",137,0)
 ;
"RTN","IVMPTRN8",138,0)
 ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse
"RTN","IVMPTRN8",139,0)
 ;*168 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7")
"RTN","IVMPTRN8",140,0)
 ;*168 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7",2,2)
"RTN","IVMPTRN8",141,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7,9") ;re-enable imprecise date.
"RTN","IVMPTRN8",142,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7,9",2,2)
"RTN","IVMPTRN8",143,0)
 ;
"RTN","IVMPTRN8",144,0)
 ; create (ZGD) Guardian segment for (1) VA & (2) Civil 
"RTN","IVMPTRN8",145,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1)
"RTN","IVMPTRN8",146,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2)
"RTN","IVMPTRN8",147,0)
 ;
"RTN","IVMPTRN8",148,0)
 ; Income Year requiring transmission from IVM Patient File (301.5)
"RTN","IVMPTRN8",149,0)
 S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000))
"RTN","IVMPTRN8",150,0)
 N MTINFO S MTINFO=$$FUT^DGMTU(DFN)
"RTN","IVMPTRN8",151,0)
 I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2)
"RTN","IVMPTRN8",152,0)
 ;get the primary test for the income year
"RTN","IVMPTRN8",153,0)
 S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN)
"RTN","IVMPTRN8",154,0)
 ;
"RTN","IVMPTRN8",155,0)
 ; The following function call returns:
"RTN","IVMPTRN8",156,0)
 ;   - Patient Relation IEN array in DGREL
"RTN","IVMPTRN8",157,0)
 ;   - Individual Annual Income IEN array in DGINC
"RTN","IVMPTRN8",158,0)
 ;   - Income Relation IEN array in DGINR
"RTN","IVMPTRN8",159,0)
 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN)
"RTN","IVMPTRN8",160,0)
 ;
"RTN","IVMPTRN8",161,0)
 S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1
"RTN","IVMPTRN8",162,0)
 ; create (ZIC) Income segment for veteran
"RTN","IVMPTRN8",163,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",164,0)
 ;IVM*2.0*115 -- Check for Means Test Version Indicator
"RTN","IVMPTRN8",165,0)
 N MTVERS S MTVERS=$S(+$G(ACTVIEN):+$P($G(^DGMT(408.31,ACTVIEN,2)),"^",11),1:0)
"RTN","IVMPTRN8",166,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",167,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20")
"RTN","IVMPTRN8",168,0)
 E  D
"RTN","IVMPTRN8",169,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,9,12,13,14,15,16,18,19")
"RTN","IVMPTRN8",170,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",171,0)
 ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct
"RTN","IVMPTRN8",172,0)
 S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY)
"RTN","IVMPTRN8",173,0)
 ;
"RTN","IVMPTRN8",174,0)
 ; create (ZIR) Income Relation segment for veteran
"RTN","IVMPTRN8",175,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("V")),"1,2,3,4,5,10,15")  ;IVM * 2.0 *160
"RTN","IVMPTRN8",176,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1"
"RTN","IVMPTRN8",177,0)
 ;
"RTN","IVMPTRN8",178,0)
 ; create (ZDP) Patient Dependent Info. segment for spouse
"RTN","IVMPTRN8",179,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGREL("S")),"1,2,3,4,5,6,7,8,9,10,13,14")
"RTN","IVMPTRN8",180,0)
 I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",181,0)
 . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",182,0)
 . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",183,0)
 ;
"RTN","IVMPTRN8",184,0)
 ; create (ZIC) Income segment for spouse
"RTN","IVMPTRN8",185,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",186,0)
 ;IVM*2.0*115
"RTN","IVMPTRN8",187,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",188,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,4,5,6,7,8,9,10,11,12,16,17,18,19,20")
"RTN","IVMPTRN8",189,0)
 E  D
"RTN","IVMPTRN8",190,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,9,12,16,18,19")
"RTN","IVMPTRN8",191,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",192,0)
 ;
"RTN","IVMPTRN8",193,0)
 ; create (ZIR) Income Relation segment for spouse
"RTN","IVMPTRN8",194,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3")
"RTN","IVMPTRN8",195,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",196,0)
 ;
"RTN","IVMPTRN8",197,0)
 ;
"RTN","IVMPTRN8",198,0)
 ; create ZDP, ZIC, and ZIR segments for all Means Test dependents
"RTN","IVMPTRN8",199,0)
 F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",200,0)
 . ;
"RTN","IVMPTRN8",201,0)
 . ; - create (ZDP) Dependent Info. segment for dependent child
"RTN","IVMPTRN8",202,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGREL("C",IVMSUB)),"1,2,3,4,5,6,7,9,10")
"RTN","IVMPTRN8",203,0)
 . I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",204,0)
 . . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",205,0)
 . . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",206,0)
 . ;
"RTN","IVMPTRN8",207,0)
 . ; - create (ZIC) Income segment for dependent child
"RTN","IVMPTRN8",208,0)
 . S IVMCT=IVMCT+1
"RTN","IVMPTRN8",209,0)
 . ;IVM*2.0*115
"RTN","IVMPTRN8",210,0)
 . I MTVERS=0 D  I 1
"RTN","IVMPTRN8",211,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,4,5,6,7,8,9,10,11,12,15")
"RTN","IVMPTRN8",212,0)
 . E  D
"RTN","IVMPTRN8",213,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,9,12,15,16,18,19")
"RTN","IVMPTRN8",214,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",215,0)
 . ;
"RTN","IVMPTRN8",216,0)
 . ; - create (ZIR) Income Relation segment for dependent child
"RTN","IVMPTRN8",217,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("C",IVMSUB)),"1,2,3,4,6,7,8,9,14,15")  ;IVM * 2.0 *160
"RTN","IVMPTRN8",218,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",219,0)
 . ;
"RTN","IVMPTRN8",220,0)
 ; Send INACTIVE spouse/dependents.
"RTN","IVMPTRN8",221,0)
 D GETINACD^DGMTU11(DFN,.DGREL)
"RTN","IVMPTRN8",222,0)
 F I="S","C" D
"RTN","IVMPTRN8",223,0)
 . F IVMSUB=0:0 S IVMSUB=$O(DGIREL(I,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",224,0)
 . . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZDP(+$G(DGIREL(I,IVMSUB)),"1,2,3,4,5,6,7,9,10,11",,,$P(DGIREL(I,IVMSUB),U,3))
"RTN","IVMPTRN8",225,0)
 ;
"RTN","IVMPTRN8",226,0)
 D GOTO^IVMPTRN9
"RTN","IVMPTRN8",227,0)
 Q
"RTN","IVMPTRN8",228,0)
 ;
"RTN","IVMPTRN8",229,0)
STRIP11 N APID,ZPID,ASQ,ATYP,SSQ
"RTN","IVMPTRN8",230,0)
 ;Extract PID segment
"RTN","IVMPTRN8",231,0)
 S IVMPID(1)=$E(IVMPID(1),5,$L(IVMPID(1)))
"RTN","IVMPTRN8",232,0)
 D BLDPID^IVMPREC6(.IVMPID,.APID)
"RTN","IVMPTRN8",233,0)
 ;
"RTN","IVMPTRN8",234,0)
 S CAFLG=0
"RTN","IVMPTRN8",235,0)
 I $D(APID(11)) D
"RTN","IVMPTRN8",236,0)
 .I $O(APID(11,"")) D  Q
"RTN","IVMPTRN8",237,0)
 ..M ZPID(11)=APID(11) K APID(11)
"RTN","IVMPTRN8",238,0)
 ..S (ASQ,SSQ)=0 F  S ASQ=$O(ZPID(11,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",239,0)
 ...S ATYP=$P($G(ZPID(11,ASQ)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",240,0)
 ...I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") Q
"RTN","IVMPTRN8",241,0)
 ...I ATYP="VACAE" S CAFLG=1
"RTN","IVMPTRN8",242,0)
 ...S SSQ=SSQ+1,APID(11,SSQ)=ZPID(11,ASQ)
"RTN","IVMPTRN8",243,0)
 .Q:$G(APID(11))=""
"RTN","IVMPTRN8",244,0)
 .S ATYP=$P($G(APID(11)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",245,0)
 .I ATYP="VACAE" S CAFLG=1 Q
"RTN","IVMPTRN8",246,0)
 .I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") K APID(11)
"RTN","IVMPTRN8",247,0)
 ;
"RTN","IVMPTRN8",248,0)
 I 'CAFLG,$D(APID(13)) D
"RTN","IVMPTRN8",249,0)
 .I $O(APID(13,"")) D  Q
"RTN","IVMPTRN8",250,0)
 ..S ASQ=0 F  S ASQ=$O(APID(13,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",251,0)
 ...Q:$G(APID(13,ASQ))=""
"RTN","IVMPTRN8",252,0)
 ...S ATYP=$P($G(APID(13,ASQ)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",253,0)
 ...I ATYP="VACPN" K APID(13,ASQ) Q
"RTN","IVMPTRN8",254,0)
 .Q:$G(APID(13))=""
"RTN","IVMPTRN8",255,0)
 .S ATYP=$P($G(APID(13)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",256,0)
 .I ATYP="VACPN" K APID(13) Q
"RTN","IVMPTRN8",257,0)
 ;
"RTN","IVMPTRN8",258,0)
 ;Rebuild PID
"RTN","IVMPTRN8",259,0)
 D KVA^VADPT
"RTN","IVMPTRN8",260,0)
 D MAKEIT^VAFHLU("PID",.APID,.VAFPID,.VAFPID)
"RTN","IVMPTRN8",261,0)
 S VAFPID(0)=VAFPID
"RTN","IVMPTRN8",262,0)
 Q
"VER")
8.0^22.2
**END**
**END**