DG_5_3_P909.KID

KIDS Distribution saved on Aug 31, 2015@18:43:25
DG*5.3*909 & IVM*2.0*161 Test v12
**KIDS**:DG*5.3*909^IVM*2.0*161^

**INSTALL NAME**
DG*5.3*909
"BLD",9243,0)
DG*5.3*909^REGISTRATION^0^3150831^y
"BLD",9243,1,0)
^^4^4^3141205^
"BLD",9243,1,1,0)
DG*5.3*909 will update the Registration application to allow for the 
"BLD",9243,1,2,0)
entering and maintenance of the Camp Lejeune Eligibility related data.
"BLD",9243,1,3,0)
 
"BLD",9243,1,4,0)
Please refer to Forum for a complete description of the updates.
"BLD",9243,4,0)
^9.64PA^27.11^2
"BLD",9243,4,2,0)
2
"BLD",9243,4,2,2,0)
^9.641^2^1
"BLD",9243,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",9243,4,2,2,2,1,0)
^9.6411^.32171^5
"BLD",9243,4,2,2,2,1,.321701,0)
CAMP LEJEUNE
"BLD",9243,4,2,2,2,1,.321702,0)
CAMP LEJEUNE DATE
"BLD",9243,4,2,2,2,1,.321703,0)
CAMP LEJEUNE CHANGE SITE
"BLD",9243,4,2,2,2,1,.321704,0)
CAMP LEJEUNE SOURCE
"BLD",9243,4,2,2,2,1,.32171,0)
CAMP LEJEUNE DATA ENTRY LOCKED
"BLD",9243,4,2,222)
y^y^p^^^^n^^n
"BLD",9243,4,2,224)

"BLD",9243,4,27.11,0)
27.11
"BLD",9243,4,27.11,2,0)
^9.641^27.11^1
"BLD",9243,4,27.11,2,27.11,0)
PATIENT ENROLLMENT  (File-top level)
"BLD",9243,4,27.11,2,27.11,1,0)
^9.6411^50.27^4
"BLD",9243,4,27.11,2,27.11,1,50.24,0)
CAMP LEJEUNE INDICATED?
"BLD",9243,4,27.11,2,27.11,1,50.25,0)
CAMP LEJEUNE DATE
"BLD",9243,4,27.11,2,27.11,1,50.26,0)
CAMP LEJEUNE CHANGE SITE
"BLD",9243,4,27.11,2,27.11,1,50.27,0)
CAMP LEJEUNE SOURCE
"BLD",9243,4,27.11,222)
y^y^p^^^^n^^n
"BLD",9243,4,27.11,224)

"BLD",9243,4,"APDD",2,2)

"BLD",9243,4,"APDD",2,2,.321701)

"BLD",9243,4,"APDD",2,2,.321702)

"BLD",9243,4,"APDD",2,2,.321703)

"BLD",9243,4,"APDD",2,2,.321704)

"BLD",9243,4,"APDD",2,2,.32171)

"BLD",9243,4,"APDD",27.11,27.11)

"BLD",9243,4,"APDD",27.11,27.11,50.24)

"BLD",9243,4,"APDD",27.11,27.11,50.25)

"BLD",9243,4,"APDD",27.11,27.11,50.26)

"BLD",9243,4,"APDD",27.11,27.11,50.27)

"BLD",9243,4,"B",2,2)

"BLD",9243,4,"B",27.11,27.11)

"BLD",9243,6.3)
32
"BLD",9243,"ABPKG")
n
"BLD",9243,"KRN",0)
^9.67PA^779.2^20
"BLD",9243,"KRN",.4,0)
.4
"BLD",9243,"KRN",.4,"NM",0)
^9.68A^^
"BLD",9243,"KRN",.401,0)
.401
"BLD",9243,"KRN",.401,"NM",0)
^9.68A^^
"BLD",9243,"KRN",.402,0)
.402
"BLD",9243,"KRN",.403,0)
.403
"BLD",9243,"KRN",.5,0)
.5
"BLD",9243,"KRN",.84,0)
.84
"BLD",9243,"KRN",3.6,0)
3.6
"BLD",9243,"KRN",3.8,0)
3.8
"BLD",9243,"KRN",9.2,0)
9.2
"BLD",9243,"KRN",9.8,0)
9.8
"BLD",9243,"KRN",9.8,"NM",0)
^9.68A^14^14
"BLD",9243,"KRN",9.8,"NM",1,0)
VAFHLZE1^^0^B28799443
"BLD",9243,"KRN",9.8,"NM",2,0)
DGENU^^0^B47398135
"BLD",9243,"KRN",9.8,"NM",3,0)
DGENA^^0^B24665348
"BLD",9243,"KRN",9.8,"NM",4,0)
DGENELA^^0^B30590661
"BLD",9243,"KRN",9.8,"NM",5,0)
DGENELA4^^0^B73347795
"BLD",9243,"KRN",9.8,"NM",6,0)
DGENA1A^^0^B18101095
"BLD",9243,"KRN",9.8,"NM",7,0)
DGRP6EF^^0^B28412625
"BLD",9243,"KRN",9.8,"NM",8,0)
DGENCLEA^^0^B22892557
"BLD",9243,"KRN",9.8,"NM",9,0)
DGRP61^^0^B47311723
"BLD",9243,"KRN",9.8,"NM",10,0)
DGENL1^^0^B71896061
"BLD",9243,"KRN",9.8,"NM",11,0)
DGENUPL^^0^B47824624
"BLD",9243,"KRN",9.8,"NM",12,0)
DGENUPLA^^0^B71424515
"BLD",9243,"KRN",9.8,"NM",13,0)
DGENELA1^^0^B84040190
"BLD",9243,"KRN",9.8,"NM",14,0)
DGRPE1^^0^B10060954
"BLD",9243,"KRN",9.8,"NM","B","DGENA",3)

"BLD",9243,"KRN",9.8,"NM","B","DGENA1A",6)

"BLD",9243,"KRN",9.8,"NM","B","DGENCLEA",8)

"BLD",9243,"KRN",9.8,"NM","B","DGENELA",4)

"BLD",9243,"KRN",9.8,"NM","B","DGENELA1",13)

"BLD",9243,"KRN",9.8,"NM","B","DGENELA4",5)

"BLD",9243,"KRN",9.8,"NM","B","DGENL1",10)

"BLD",9243,"KRN",9.8,"NM","B","DGENU",2)

"BLD",9243,"KRN",9.8,"NM","B","DGENUPL",11)

"BLD",9243,"KRN",9.8,"NM","B","DGENUPLA",12)

"BLD",9243,"KRN",9.8,"NM","B","DGRP61",9)

"BLD",9243,"KRN",9.8,"NM","B","DGRP6EF",7)

"BLD",9243,"KRN",9.8,"NM","B","DGRPE1",14)

"BLD",9243,"KRN",9.8,"NM","B","VAFHLZE1",1)

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

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

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

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

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

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

"BLD",9243,"KRN","B",3.6,3.6)

"BLD",9243,"KRN","B",3.8,3.8)

"BLD",9243,"KRN","B",9.2,9.2)

"BLD",9243,"KRN","B",9.8,9.8)

"BLD",9243,"KRN","B",19,19)

"BLD",9243,"KRN","B",19.1,19.1)

"BLD",9243,"KRN","B",101,101)

"BLD",9243,"KRN","B",409.61,409.61)

"BLD",9243,"KRN","B",771,771)

"BLD",9243,"KRN","B",779.2,779.2)

"BLD",9243,"KRN","B",870,870)

"BLD",9243,"KRN","B",8989.51,8989.51)

"BLD",9243,"KRN","B",8989.52,8989.52)

"BLD",9243,"KRN","B",8994,8994)

"BLD",9243,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",9243,"QUES",0)
^9.62^^
"BLD",9243,"REQB",0)
^9.611^5^5
"BLD",9243,"REQB",1,0)
DG*5.3*841^1
"BLD",9243,"REQB",2,0)
DG*5.3*804^1
"BLD",9243,"REQB",3,0)
DG*5.3*797^1
"BLD",9243,"REQB",4,0)
DG*5.3*891^1
"BLD",9243,"REQB",5,0)
DG*5.3*871^1
"BLD",9243,"REQB","B","DG*5.3*797",3)

"BLD",9243,"REQB","B","DG*5.3*804",2)

"BLD",9243,"REQB","B","DG*5.3*841",1)

"BLD",9243,"REQB","B","DG*5.3*871",5)

"BLD",9243,"REQB","B","DG*5.3*891",4)

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

"FIA",2,2,.321702)

"FIA",2,2,.321703)

"FIA",2,2,.321704)

"FIA",2,2,.32171)

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

"FIA",27.11,0,11)

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

"FIA",27.11,0,"VR")
5.3^DG
"FIA",27.11,27.11)
1
"FIA",27.11,27.11,50.24)

"FIA",27.11,27.11,50.25)

"FIA",27.11,27.11,50.26)

"FIA",27.11,27.11,50.27)

"MBREQ")
0
"PKG",114,-1)
1^1
"PKG",114,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",114,22,0)
^9.49I^1^1
"PKG",114,22,1,0)
5.3^2930813^2930821
"PKG",114,22,1,"PAH",1,0)
909^3150831^11933
"PKG",114,22,1,"PAH",1,1,0)
^^4^4^3150831
"PKG",114,22,1,"PAH",1,1,1,0)
DG*5.3*909 will update the Registration application to allow for the 
"PKG",114,22,1,"PAH",1,1,2,0)
entering and maintenance of the Camp Lejeune Eligibility related data.
"PKG",114,22,1,"PAH",1,1,3,0)
 
"PKG",114,22,1,"PAH",1,1,4,0)
Please refer to Forum for a complete description of the updates.
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
14
"RTN","DGENA")
0^3^B24665348
"RTN","DGENA",1,0)
DGENA ;ALB/CJM,ISA/KWP,Zoltan,LBD,CKN,EG,ERC,TDM,JLS - Enrollment API - Retrieve Data ;03 Mar 2015  10:25 AM
"RTN","DGENA",2,0)
 ;;5.3;Registration;**121,122,147,232,314,564,672,659,653,688,841,909**;Aug 13, 1993;Build 32
"RTN","DGENA",3,0)
 ;
"RTN","DGENA",4,0)
FINDCUR(DFN) ;
"RTN","DGENA",5,0)
 ;Description: Used to find a patients current enrollment.
"RTN","DGENA",6,0)
 ;Input :
"RTN","DGENA",7,0)
 ;  DFN - Patient IEN
"RTN","DGENA",8,0)
 ;Output:
"RTN","DGENA",9,0)
 ;  Function Value - returns the internal entry number of the patient's
"RTN","DGENA",10,0)
 ;     current enrollment if there is one, NULL otherwise. Checks that
"RTN","DGENA",11,0)
 ;     current enrollment actually belongs to the patient.
"RTN","DGENA",12,0)
 ;
"RTN","DGENA",13,0)
 Q:'$G(DFN) ""
"RTN","DGENA",14,0)
 ;
"RTN","DGENA",15,0)
 N CUR
"RTN","DGENA",16,0)
 S CUR=$P($G(^DPT(DFN,"ENR")),"^")
"RTN","DGENA",17,0)
 I CUR,$P($G(^DGEN(27.11,CUR,0)),"^",2)'=DFN S CUR=""
"RTN","DGENA",18,0)
 Q CUR
"RTN","DGENA",19,0)
 ;
"RTN","DGENA",20,0)
FINDPRI(DGENRIEN) ;
"RTN","DGENA",21,0)
 ;Description: Used to obtain a patient's  enrollment record that was
"RTN","DGENA",22,0)
 ;     prior to the enrollment identified by DGENRIEN.
"RTN","DGENA",23,0)
 ;Input :
"RTN","DGENA",24,0)
 ;  DGENRIEN - this is the internal entry number of a PATIENT ENROLLMENT
"RTN","DGENA",25,0)
 ;     record
"RTN","DGENA",26,0)
 ;Output:
"RTN","DGENA",27,0)
 ;  Function Value - returns the internal entry number of the prior
"RTN","DGENA",28,0)
 ;     enrollment for the patient if there is one, NULL otherwise.
"RTN","DGENA",29,0)
 ;
"RTN","DGENA",30,0)
 Q:'$G(DGENRIEN) ""
"RTN","DGENA",31,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",9)
"RTN","DGENA",32,0)
 ;
"RTN","DGENA",33,0)
ENROLLED(DFN) ;
"RTN","DGENA",34,0)
 ;Description: Returns whether the patient is currently enrolled.
"RTN","DGENA",35,0)
 ;Input:
"RTN","DGENA",36,0)
 ;  DFN - Patient IEN
"RTN","DGENA",37,0)
 ;Output:
"RTN","DGENA",38,0)
 ;  Function Value - returns 1 if the patient is currently enrolled with
"RTN","DGENA",39,0)
 ;     a status of VERIFIED, 0 otherwise
"RTN","DGENA",40,0)
 ;
"RTN","DGENA",41,0)
 N STATUS
"RTN","DGENA",42,0)
 S STATUS=$$STATUS($G(DFN))
"RTN","DGENA",43,0)
 I (STATUS=2) Q 1
"RTN","DGENA",44,0)
 Q 0
"RTN","DGENA",45,0)
 ;
"RTN","DGENA",46,0)
STATUS(DFN) ;
"RTN","DGENA",47,0)
 ;Description: Returns ENROLLMENT STATUS from the patient's current
"RTN","DGENA",48,0)
 ;     enrollment.
"RTN","DGENA",49,0)
 ;Input:
"RTN","DGENA",50,0)
 ;  DFN -  Patient IEN
"RTN","DGENA",51,0)
 ;Output:
"RTN","DGENA",52,0)
 ;  Function Value - If the patient has a current ENROLLMENT STATUS this
"RTN","DGENA",53,0)
 ;     function will return its value, otherwise it returns NULL.
"RTN","DGENA",54,0)
 N DGENRIEN
"RTN","DGENA",55,0)
 S DGENRIEN=$$FINDCUR($G(DFN))
"RTN","DGENA",56,0)
 Q:'DGENRIEN ""
"RTN","DGENA",57,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",4)
"RTN","DGENA",58,0)
 ;
"RTN","DGENA",59,0)
PRIORITY(DFN) ;
"RTN","DGENA",60,0)
 ;Description: Returns ENROLLMENT PRIORITY from the patient's current
"RTN","DGENA",61,0)
 ;     enrollment.
"RTN","DGENA",62,0)
 ;Input:
"RTN","DGENA",63,0)
 ;  DFN -  Patient IEN
"RTN","DGENA",64,0)
 ;Output:
"RTN","DGENA",65,0)
 ;  Function Value - If the patient has a current ENROLLMENT PRIORITY
"RTN","DGENA",66,0)
 ;     this function will return its value, otherwise it returns NULL.
"RTN","DGENA",67,0)
 N DGENRIEN
"RTN","DGENA",68,0)
 S DGENRIEN=$$FINDCUR($G(DFN))
"RTN","DGENA",69,0)
 Q:'DGENRIEN ""
"RTN","DGENA",70,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",7)
"RTN","DGENA",71,0)
 ;
"RTN","DGENA",72,0)
SOURCE(DFN) ;
"RTN","DGENA",73,0)
 ;Description: Returns SOURCE OF ENROLLMENT from the patient's current
"RTN","DGENA",74,0)
 ;     enrollment.
"RTN","DGENA",75,0)
 ;Input:
"RTN","DGENA",76,0)
 ;  DFN -  Patient IEN
"RTN","DGENA",77,0)
 ;Output:
"RTN","DGENA",78,0)
 ;  Function Value - If the patient has a current ENROLLMENT 
"RTN","DGENA",79,0)
 ;     this function will return the SOURCE OF ENROLLMENT, otherwise
"RTN","DGENA",80,0)
 ;     it returns NULL.
"RTN","DGENA",81,0)
 ;
"RTN","DGENA",82,0)
 N DGENRIEN
"RTN","DGENA",83,0)
 S DGENRIEN=$$FINDCUR($G(DFN))
"RTN","DGENA",84,0)
 Q:'DGENRIEN ""
"RTN","DGENA",85,0)
 Q $P($G(^DGEN(27.11,DGENRIEN,0)),"^",3)
"RTN","DGENA",86,0)
 ;
"RTN","DGENA",87,0)
GET(DGENRIEN,DGENR) ;
"RTN","DGENA",88,0)
 ;Description: Used to obtain a record from the Patient Enrollment file
"RTN","DGENA",89,0)
 ;     into the local DGENR array.
"RTN","DGENA",90,0)
 ;Input :
"RTN","DGENA",91,0)
 ;  DGENRIEN - this is the internal entry number of a PATIENT ENROLLMENT record
"RTN","DGENA",92,0)
 ;Output:
"RTN","DGENA",93,0)
 ;  Function  Value - returns 1 on success, 0 on failure.
"RTN","DGENA",94,0)
 ;  DGENR - this is the name of  a local array, it should be passed by
"RTN","DGENA",95,0)
 ;     reference. If the function is successful this array will
"RTN","DGENA",96,0)
 ;     contain the enrollment.
"RTN","DGENA",97,0)
 ;
"RTN","DGENA",98,0)
 ;      subscript      field name
"RTN","DGENA",99,0)
 ;     "APP"           Enrollment Application Date
"RTN","DGENA",100,0)
 ;     "DATE"          Enrollment Date
"RTN","DGENA",101,0)
 ;     "END"          Enrollment End Date
"RTN","DGENA",102,0)
 ;     "DFN"           Patient IEN
"RTN","DGENA",103,0)
 ;     "SOURCE"        Enrollment Source
"RTN","DGENA",104,0)
 ;     "STATUS"        Enrollment Status
"RTN","DGENA",105,0)
 ;     "REASON"        Reason Canceled/Declined
"RTN","DGENA",106,0)
 ;     "REMARKS"       Canceled/Declined Remarks
"RTN","DGENA",107,0)
 ;     "FACREC"        Facility Received
"RTN","DGENA",108,0)
 ;     "PRIORITY"      Enrollment Priority
"RTN","DGENA",109,0)
 ;     "SUBGRP"        Enrollment Sub-Group
"RTN","DGENA",110,0)
 ;     "EFFDATE"       Effective Date
"RTN","DGENA",111,0)
 ;     "PRIORREC"      Prior Enrollment Record
"RTN","DGENA",112,0)
 ;     "ELIG","CODE"            Primary Eligibility Code
"RTN","DGENA",113,0)
 ;     "ELIG","CODE",<code ien> Eligibility Codes
"RTN","DGENA",114,0)
 ;     "ELIG","SC"              Service Connected
"RTN","DGENA",115,0)
 ;     "ELIG","SCPER"           Service Connected Percentage
"RTN","DGENA",116,0)
 ;     "ELIG","POW"             POW Status Indicated
"RTN","DGENA",117,0)
 ;     "ELIG","A&A"             Receiving A&A Benefits
"RTN","DGENA",118,0)
 ;     "ELIG","HB"              Receiving Housebound Benefits
"RTN","DGENA",119,0)
 ;     "ELIG","VAPEN"           Receiving a VA Pension
"RTN","DGENA",120,0)
 ;     "ELIG","VACKAMT"         Total Annual VA Check Amount
"RTN","DGENA",121,0)
 ;     "ELIG","DISRET"          Military Disability Retirement
"RTN","DGENA",122,0)
 ;     "ELIG","DISLOD"          Discharged Due to Disability
"RTN","DGENA",123,0)
 ;     "ELIG","MEDICAID"        Medicaid
"RTN","DGENA",124,0)
 ;     "ELIG","AO"              Exposed to Agent Orange
"RTN","DGENA",125,0)
 ;     "ELIG","AOEXPLOC"        Agent Orange Exposure Location
"RTN","DGENA",126,0)
 ;     "ELIG","IR"              Radiation Exposure Indicated
"RTN","DGENA",127,0)
 ;     "ELIG","RADEXPM"         Radiation Exposure Method
"RTN","DGENA",128,0)
 ;     "ELIG","EC"              SW Asia Cond - was Env Con, DG*5.3*688
"RTN","DGENA",129,0)
 ;     "ELIG","MTSTA"           Means Test Status
"RTN","DGENA",130,0)
 ;     "ELIG","VCD"             Veteran Catastrophically Disabled?
"RTN","DGENA",131,0)
 ;     "ELIG","PH"              Purple Heart Indicated?
"RTN","DGENA",132,0)
 ;     "ELIG","UNEMPLOY"        Unemployable
"RTN","DGENA",133,0)
 ;     "ELIG","CVELEDT"         Combat Veteran End Date
"RTN","DGENA",134,0)
 ;     "ELIG","SHAD"            SHAD Indicated
"RTN","DGENA",135,0)
 ;     "ELIG","MOH"             Medal of Honor Indicated
"RTN","DGENA",136,0)
 ;     "ELIG","CLE"             Camp Lejeune Indicated?    DG*5.3*909
"RTN","DGENA",137,0)
 ;     "ELIG","CLEDT"           Camp Lejeune Date          DG*5.3*909
"RTN","DGENA",138,0)
 ;     "ELIG","CLEST"           Camp Lejeune Change Site   DG*5.3*909
"RTN","DGENA",139,0)
 ;     "ELIG","CLESOR"          Camp Lejeune Source        DG*5.3*909
"RTN","DGENA",140,0)
 ;     "DATETIME"      Date/Time Entered
"RTN","DGENA",141,0)
 ;     "USER"          Entered By
"RTN","DGENA",142,0)
 ;    
"RTN","DGENA",143,0)
 N SUB,NODE
"RTN","DGENA",144,0)
 I '$G(DGENRIEN) Q 0
"RTN","DGENA",145,0)
 I '$D(^DGEN(27.11,DGENRIEN,0)) Q 0
"RTN","DGENA",146,0)
 K DGENR
"RTN","DGENA",147,0)
 S DGENR=""
"RTN","DGENA",148,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,0))
"RTN","DGENA",149,0)
 S DGENR("APP")=$P(NODE,"^")
"RTN","DGENA",150,0)
 S DGENR("DATE")=$P(NODE,"^",10)
"RTN","DGENA",151,0)
 S DGENR("END")=$P(NODE,"^",11)
"RTN","DGENA",152,0)
 S DGENR("DFN")=$P(NODE,"^",2)
"RTN","DGENA",153,0)
 S DGENR("SOURCE")=$P(NODE,"^",3)
"RTN","DGENA",154,0)
 S DGENR("STATUS")=$P(NODE,"^",4)
"RTN","DGENA",155,0)
 S DGENR("REASON")=$P(NODE,"^",5)
"RTN","DGENA",156,0)
 S DGENR("FACREC")=$P(NODE,"^",6)
"RTN","DGENA",157,0)
 S DGENR("PRIORITY")=$P(NODE,"^",7)
"RTN","DGENA",158,0)
 S DGENR("EFFDATE")=$P(NODE,"^",8)
"RTN","DGENA",159,0)
 S DGENR("PRIORREC")=$P(NODE,"^",9)
"RTN","DGENA",160,0)
 ;Phase II Get enrollment sub-grp (SRS 6.4)
"RTN","DGENA",161,0)
 S DGENR("SUBGRP")=$P(NODE,"^",12)
"RTN","DGENA",162,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,"R"))
"RTN","DGENA",163,0)
 S DGENR("REMARKS")=$P(NODE,"^")
"RTN","DGENA",164,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,"E"))
"RTN","DGENA",165,0)
 S DGENR("ELIG","CODE")=$P(NODE,"^")
"RTN","DGENA",166,0)
 S DGENR("ELIG","SC")=$P(NODE,"^",2)
"RTN","DGENA",167,0)
 S DGENR("ELIG","SCPER")=$P(NODE,"^",3)
"RTN","DGENA",168,0)
 S DGENR("ELIG","POW")=$P(NODE,"^",4)
"RTN","DGENA",169,0)
 S DGENR("ELIG","A&A")=$P(NODE,"^",5)
"RTN","DGENA",170,0)
 S DGENR("ELIG","HB")=$P(NODE,"^",6)
"RTN","DGENA",171,0)
 S DGENR("ELIG","VAPEN")=$P(NODE,"^",7)
"RTN","DGENA",172,0)
 S DGENR("ELIG","VACKAMT")=$P(NODE,"^",8)
"RTN","DGENA",173,0)
 S DGENR("ELIG","DISRET")=$P(NODE,"^",9)
"RTN","DGENA",174,0)
 S DGENR("ELIG","DISLOD")=$P(NODE,"^",20)  ;added with DG*5.3*672
"RTN","DGENA",175,0)
 S DGENR("ELIG","MEDICAID")=$P(NODE,"^",10)
"RTN","DGENA",176,0)
 S DGENR("ELIG","AO")=$P(NODE,"^",11)
"RTN","DGENA",177,0)
 S DGENR("ELIG","AOEXPLOC")=$P(NODE,"^",22)  ;added with DG*5.3*688
"RTN","DGENA",178,0)
 S DGENR("ELIG","IR")=$P(NODE,"^",12)
"RTN","DGENA",179,0)
 S DGENR("ELIG","EC")=$P(NODE,"^",13)
"RTN","DGENA",180,0)
 S DGENR("ELIG","MTSTA")=$P(NODE,"^",14)
"RTN","DGENA",181,0)
 S DGENR("ELIG","VCD")=$P(NODE,"^",15)
"RTN","DGENA",182,0)
 S DGENR("ELIG","PH")=$P(NODE,"^",16)
"RTN","DGENA",183,0)
 S DGENR("ELIG","UNEMPLOY")=$P(NODE,"^",17)
"RTN","DGENA",184,0)
 S DGENR("ELIG","CVELEDT")=$P(NODE,"^",18)
"RTN","DGENA",185,0)
 S DGENR("ELIG","SHAD")=$P(NODE,"^",19)
"RTN","DGENA",186,0)
 S DGENR("ELIG","RADEXPM")=$P(NODE,"^",21)
"RTN","DGENA",187,0)
 S DGENR("ELIG","MOH")=$P(NODE,"^",23)
"RTN","DGENA",188,0)
 S DGENR("ELIG","CLE")=$P(NODE,"^",24)      ;added with DG*5.3*909
"RTN","DGENA",189,0)
 S DGENR("ELIG","CLEDT")=$P(NODE,"^",25)    ;added with DG*5.3*909
"RTN","DGENA",190,0)
 S DGENR("ELIG","CLEST")=$P(NODE,"^",26)    ;added with DG*5.3*909
"RTN","DGENA",191,0)
 S DGENR("ELIG","CLESOR")=$P(NODE,"^",27)   ;added with DG*5.3*909
"RTN","DGENA",192,0)
 ;S DGENCDZZ=1 ; for CD Testing (disabled).
"RTN","DGENA",193,0)
 S NODE=$G(^DGEN(27.11,DGENRIEN,"U"))
"RTN","DGENA",194,0)
 S DGENR("DATETIME")=$P(NODE,"^")
"RTN","DGENA",195,0)
 S DGENR("USER")=$P(NODE,"^",2)
"RTN","DGENA",196,0)
 Q 1
"RTN","DGENA",197,0)
 ;
"RTN","DGENA1A")
0^6^B18101095
"RTN","DGENA1A",1,0)
DGENA1A ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN,ERC,TDM,JLS - Enrollment API - File Data Continued ;5/10/11 12:03pm
"RTN","DGENA1A",2,0)
 ;;5.3;Registration;**121,147,232,314,564,672,659,653,688,841,909**;Aug 13,1993;Build 32
"RTN","DGENA1A",3,0)
 ;
"RTN","DGENA1A",4,0)
KILLALL(DGENRIEN) ;
"RTN","DGENA1A",5,0)
 ;kills all x-refs on the record in the Patient Enrollment file
"RTN","DGENA1A",6,0)
 ;pointed to by DGENRIEN
"RTN","DGENA1A",7,0)
 ;
"RTN","DGENA1A",8,0)
 N DGENR,SUB,VALUE
"RTN","DGENA1A",9,0)
 Q:'$G(DGENRIEN)
"RTN","DGENA1A",10,0)
 Q:'$$GET^DGENA(DGENRIEN,.DGENR)
"RTN","DGENA1A",11,0)
 S SUB=""
"RTN","DGENA1A",12,0)
 F  S SUB=$O(DGENR(SUB)) Q:SUB=""  D
"RTN","DGENA1A",13,0)
 .Q:(SUB="ELIG")
"RTN","DGENA1A",14,0)
 .Q:DGENR(SUB)=""
"RTN","DGENA1A",15,0)
 .D KILL(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR(SUB))
"RTN","DGENA1A",16,0)
 S SUB=""
"RTN","DGENA1A",17,0)
 F  S SUB=$O(DGENR("ELIG",SUB)) Q:SUB=""  D
"RTN","DGENA1A",18,0)
 .Q:DGENR("ELIG",SUB)=""
"RTN","DGENA1A",19,0)
 .D KILL(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR("ELIG",SUB))
"RTN","DGENA1A",20,0)
 Q
"RTN","DGENA1A",21,0)
 ;
"RTN","DGENA1A",22,0)
SETALL(DGENRIEN,DGENR) ;
"RTN","DGENA1A",23,0)
 ;Sets all x-refs on the record in the Patient Enrollment file.
"RTN","DGENA1A",24,0)
 ;Inputs:
"RTN","DGENA1A",25,0)
 ;  DGENRIEN - pointer to PATIENT ENROLLMENT file
"RTN","DGENA1A",26,0)
 ;  DGENR - array containing the record, pass by reference
"RTN","DGENA1A",27,0)
 ;
"RTN","DGENA1A",28,0)
 N SUB,VALUE
"RTN","DGENA1A",29,0)
 Q:'$G(DGENRIEN)
"RTN","DGENA1A",30,0)
 Q:'$D(DGENR)
"RTN","DGENA1A",31,0)
 ;
"RTN","DGENA1A",32,0)
 S SUB=""
"RTN","DGENA1A",33,0)
 F  S SUB=$O(DGENR(SUB)) Q:SUB=""  D
"RTN","DGENA1A",34,0)
 .Q:(SUB="ELIG")
"RTN","DGENA1A",35,0)
 .Q:DGENR(SUB)=""
"RTN","DGENA1A",36,0)
 .D SET(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR(SUB))
"RTN","DGENA1A",37,0)
 S SUB=""
"RTN","DGENA1A",38,0)
 F  S SUB=$O(DGENR("ELIG",SUB)) Q:SUB=""  D
"RTN","DGENA1A",39,0)
 .Q:DGENR("ELIG",SUB)=""
"RTN","DGENA1A",40,0)
 .D SET(27.11,DGENRIEN,$$FIELD^DGENU(SUB),DGENR("ELIG",SUB))
"RTN","DGENA1A",41,0)
 Q
"RTN","DGENA1A",42,0)
 ;
"RTN","DGENA1A",43,0)
KILL(FILE,IEN,FIELD,VALUE) ;
"RTN","DGENA1A",44,0)
 ;executes all the kill logic for x-refs on the field=FIELD for the
"RTN","DGENA1A",45,0)
 ;record=DGENRIEN for the file=FILE for the field value=VALUE
"RTN","DGENA1A",46,0)
 ;
"RTN","DGENA1A",47,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGENA1A",48,0)
 S DA=IEN,X=VALUE,DGIX=0
"RTN","DGENA1A",49,0)
 F  S DGIX=$O(^DD(FILE,FIELD,1,DGIX)) Q:'DGIX  X ^(DGIX,2) S X=VALUE
"RTN","DGENA1A",50,0)
 Q
"RTN","DGENA1A",51,0)
 ;
"RTN","DGENA1A",52,0)
SET(FILE,IEN,FIELD,VALUE) ;
"RTN","DGENA1A",53,0)
 ;executes all the set logic for x-refs on the field=FIELD for the
"RTN","DGENA1A",54,0)
 ;record=DGENRIEN for the file=FILE for the field value=VALUE
"RTN","DGENA1A",55,0)
 ;
"RTN","DGENA1A",56,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGENA1A",57,0)
 S DA=IEN,X=VALUE,DGIX=0
"RTN","DGENA1A",58,0)
 F  S DGIX=$O(^DD(FILE,FIELD,1,DGIX)) Q:'DGIX  X ^(DGIX,1)
"RTN","DGENA1A",59,0)
 Q
"RTN","DGENA1A",60,0)
 ;
"RTN","DGENA1A",61,0)
EDIT(DA,DGENR) ;
"RTN","DGENA1A",62,0)
 ;Description: Overlays a currently existing record, ien=DA, with values
"RTN","DGENA1A",63,0)
 ;     from DGENR array
"RTN","DGENA1A",64,0)
 ;Input -
"RTN","DGENA1A",65,0)
 ;  DA - ien of record in Patient Enrollment file
"RTN","DGENA1A",66,0)
 ;  DGENR - array containing an enrollment, pass by reference
"RTN","DGENA1A",67,0)
 ;Output - 1 on success, 0 on failure
"RTN","DGENA1A",68,0)
 ;
"RTN","DGENA1A",69,0)
 ; *** NOTE: This is called from within FM.  There is a problem in ***
"RTN","DGENA1A",70,0)
 ; *** that ^DIE cannot be used.  Instead, the fields              ***
"RTN","DGENA1A",71,0)
 ; *** are hard-set and cross-referenced.                          ***
"RTN","DGENA1A",72,0)
 ;
"RTN","DGENA1A",73,0)
 N NODE
"RTN","DGENA1A",74,0)
 Q:'$G(DA) 0
"RTN","DGENA1A",75,0)
 S NODE=$G(^DGEN(27.11,$G(DA),0))
"RTN","DGENA1A",76,0)
 Q:NODE="" 0
"RTN","DGENA1A",77,0)
 ;
"RTN","DGENA1A",78,0)
 ;kill off all the cross-references (FM doesn't have an API to do this)
"RTN","DGENA1A",79,0)
 D KILLALL(DA)
"RTN","DGENA1A",80,0)
 ;
"RTN","DGENA1A",81,0)
 ;now hand-set all the fields
"RTN","DGENA1A",82,0)
 ;Phase II Add subgroup to the 12 piece (SRS 6.4)
"RTN","DGENA1A",83,0)
 S NODE=DGENR("APP")_U_DGENR("DFN")_U_DGENR("SOURCE")_U_DGENR("STATUS")_U_DGENR("REASON")_U_DGENR("FACREC")_U_DGENR("PRIORITY")_U_DGENR("EFFDATE")_U_DGENR("PRIORREC")_U_DGENR("DATE")_U_DGENR("END")_U_DGENR("SUBGRP")
"RTN","DGENA1A",84,0)
 S ^DGEN(27.11,DA,0)=NODE
"RTN","DGENA1A",85,0)
 S ^DGEN(27.11,DA,"R")=DGENR("REMARKS")
"RTN","DGENA1A",86,0)
 S NODE=DGENR("ELIG","CODE")
"RTN","DGENA1A",87,0)
 S NODE=NODE_U_DGENR("ELIG","SC")
"RTN","DGENA1A",88,0)
 S NODE=NODE_U_DGENR("ELIG","SCPER")
"RTN","DGENA1A",89,0)
 S NODE=NODE_U_DGENR("ELIG","POW")
"RTN","DGENA1A",90,0)
 S NODE=NODE_U_DGENR("ELIG","A&A")
"RTN","DGENA1A",91,0)
 S NODE=NODE_U_DGENR("ELIG","HB")
"RTN","DGENA1A",92,0)
 S NODE=NODE_U_DGENR("ELIG","VAPEN")
"RTN","DGENA1A",93,0)
 S NODE=NODE_U_DGENR("ELIG","VACKAMT")
"RTN","DGENA1A",94,0)
 S NODE=NODE_U_DGENR("ELIG","DISRET")
"RTN","DGENA1A",95,0)
 S NODE=NODE_U_DGENR("ELIG","MEDICAID")
"RTN","DGENA1A",96,0)
 S NODE=NODE_U_DGENR("ELIG","AO")
"RTN","DGENA1A",97,0)
 S NODE=NODE_U_DGENR("ELIG","IR")
"RTN","DGENA1A",98,0)
 S NODE=NODE_U_DGENR("ELIG","EC")  ;changed to SW Asia Cond - DG*5.3*688
"RTN","DGENA1A",99,0)
 S NODE=NODE_U_DGENR("ELIG","MTSTA")
"RTN","DGENA1A",100,0)
 S NODE=NODE_U_DGENR("ELIG","VCD")
"RTN","DGENA1A",101,0)
 S NODE=NODE_U_DGENR("ELIG","PH")
"RTN","DGENA1A",102,0)
 S NODE=NODE_U_DGENR("ELIG","UNEMPLOY")
"RTN","DGENA1A",103,0)
 S NODE=NODE_U_DGENR("ELIG","CVELEDT")
"RTN","DGENA1A",104,0)
 S NODE=NODE_U_DGENR("ELIG","SHAD") ;field added with DG*5.3*653
"RTN","DGENA1A",105,0)
 S NODE=NODE_U_DGENR("ELIG","DISLOD") ;field added with DG*5.3*672
"RTN","DGENA1A",106,0)
 S NODE=NODE_U_DGENR("ELIG","RADEXPM")
"RTN","DGENA1A",107,0)
 S NODE=NODE_U_DGENR("ELIG","AOEXPLOC") ;field added with DG*5.3*688
"RTN","DGENA1A",108,0)
 S NODE=NODE_U_DGENR("ELIG","MOH") ;field added with DG*5.3*841
"RTN","DGENA1A",109,0)
 S NODE=NODE_U_DGENR("ELIG","CLE")     ;field added with DG*5.3*909
"RTN","DGENA1A",110,0)
 S NODE=NODE_U_DGENR("ELIG","CLEDT")   ;field added with DG*5.3*909
"RTN","DGENA1A",111,0)
 S NODE=NODE_U_DGENR("ELIG","CLEST")   ;field added with DG*5.3*909
"RTN","DGENA1A",112,0)
 S NODE=NODE_U_DGENR("ELIG","CLESOR")  ;field added with DG*5.3*909
"RTN","DGENA1A",113,0)
 S ^DGEN(27.11,DA,"E")=NODE
"RTN","DGENA1A",114,0)
 S ^DGEN(27.11,DA,"U")=DGENR("DATETIME")_U_DGENR("USER")
"RTN","DGENA1A",115,0)
 ;
"RTN","DGENA1A",116,0)
 ;set the x-refs
"RTN","DGENA1A",117,0)
 D SETALL(DA,.DGENR)
"RTN","DGENA1A",118,0)
 Q 1
"RTN","DGENCLEA")
0^8^B22892557
"RTN","DGENCLEA",1,0)
DGENCLEA ;ALB/JLS - Camp Lejeune Eligibility API - Retrieve Eligibility ;11/28/14 4:25pm
"RTN","DGENCLEA",2,0)
 ;;5.3;Registration;**909**;Aug 13,1993;Build 32
"RTN","DGENCLEA",3,0)
 ;
"RTN","DGENCLEA",4,0)
 ; Business Rules to determine Camp Lejeune Eligibility:
"RTN","DGENCLEA",5,0)
 ;. Person is a Veteran AND
"RTN","DGENCLEA",6,0)
 ;  . Either ("Rule 1") 
"RTN","DGENCLEA",7,0)
 ;    . Has one Military Service Episode (DGMSE) between, and inclusive of, Aug 1, 1953 and Dec 31, 1987 and 
"RTN","DGENCLEA",8,0)
 ;    . The identified DGMSE has a character of discharge other than
"RTN","DGENCLEA",9,0)
 ;      . Dishonorable
"RTN","DGENCLEA",10,0)
 ;      . Other Than Honorable
"RTN","DGENCLEA",11,0)
 ;      . Undesirable
"RTN","DGENCLEA",12,0)
 ;      . Bad Conduct
"RTN","DGENCLEA",13,0)
 ;      . Dishonorable-VA
"RTN","DGENCLEA",14,0)
 ;AND
"RTN","DGENCLEA",15,0)
 ;    . The identified DGMSE is at least 30 days in duration
"RTN","DGENCLEA",16,0)
 ;  . OR ("Rule 2"; perform this check only if "Rule 1" was not met)
"RTN","DGENCLEA",17,0)
 ;    . Has more than one Military Service Episodes (DGMSEs) between, and inclusive of, Aug 1, 1953 and Dec 31, 1987 AND 
"RTN","DGENCLEA",18,0)
 ;    . All of the identified DGMSEs have a character of discharge other than 
"RTN","DGENCLEA",19,0)
 ;      . Dishonorable
"RTN","DGENCLEA",20,0)
 ;      . Other Than Honorable 
"RTN","DGENCLEA",21,0)
 ;      . Undesirable
"RTN","DGENCLEA",22,0)
 ;      . Bad Conduct
"RTN","DGENCLEA",23,0)
 ;      . Dishonorable-VA
"RTN","DGENCLEA",24,0)
 ;AND
"RTN","DGENCLEA",25,0)
 ;    . The sum of two or more of the identified DGMSEs add up to at least 30 days in duration (meaning that it does not have to be consecutive days)
"RTN","DGENCLEA",26,0)
 ;
"RTN","DGENCLEA",27,0)
 ;  Inputs: DFN
"RTN","DGENCLEA",28,0)
 ; Outputs: CLE returns 1 if patient is camp lejeune eligible, returns 0 if not camp lejeune eligible
"RTN","DGENCLEA",29,0)
 ;  0 - CLE "Not Eligible"
"RTN","DGENCLEA",30,0)
 ;  1 - CLE "Eligible"
"RTN","DGENCLEA",31,0)
 ;
"RTN","DGENCLEA",32,0)
CLE(DFN) ;
"RTN","DGENCLEA",33,0)
 K DGMSE
"RTN","DGENCLEA",34,0)
 ; Is patient a veteran VET1 Is the patient an eligible veteran VET
"RTN","DGENCLEA",35,0)
 I '$$VET^DGENPTA(DFN) Q 0
"RTN","DGENCLEA",36,0)
 ; If primary eligibility code exists it must be a Veteran Type Eligibility Code from File 8 
"RTN","DGENCLEA",37,0)
 N DGPRIEL
"RTN","DGENCLEA",38,0)
 S DGPRIEL=$P($G(^DPT(DFN,.36)),U,1)
"RTN","DGENCLEA",39,0)
 I DGPRIEL]"",$P($G(^DIC(8,DGPRIEL,0)),U,5)="N" Q 0
"RTN","DGENCLEA",40,0)
 ; Get DGMSE data from DGMSE sub-file #2.3216 first, if that does not exist get DGMSE data from .32 node
"RTN","DGENCLEA",41,0)
 N DGMSE
"RTN","DGENCLEA",42,0)
 I $D(^DPT(DFN,.3216)) D GETMSE^DGMSEUTL(DFN,.DGMSE)
"RTN","DGENCLEA",43,0)
 I $G(DGMSE)="" S DGMSE=$G(^DPT(DFN,.32))
"RTN","DGENCLEA",44,0)
 I '$D(DGMSE) Q 0
"RTN","DGENCLEA",45,0)
 ; Loop through DGMSE to find at least 1 qualifying DGMSE  (CLE=1)
"RTN","DGENCLEA",46,0)
 N DGENTDT,DGEXITDT,DGTYPE,DGLOOP,DGCLE,DGCLSRDT,X1,X2
"RTN","DGENCLEA",47,0)
 S (DGCLE,DGCLSRDT)=0
"RTN","DGENCLEA",48,0)
 S DGLOOP="" F  S DGLOOP=$O(DGMSE(DGLOOP)) Q:(DGLOOP="")!(DGCLE=1)  D
"RTN","DGENCLEA",49,0)
 . S (DGENTDT,DGEXITDT,DGTYPE,X1,X2)=""
"RTN","DGENCLEA",50,0)
 . S DGENTDT=$$FMTH^XLFDT($P(DGMSE(DGLOOP),"^",1),1),DGEXITDT=$$FMTH^XLFDT($P(DGMSE(DGLOOP),"^",2),1),DGTYPE=$P(DGMSE(DGLOOP),"^",6)
"RTN","DGENCLEA",51,0)
 . ;automatically quit out of this DGMSE if Discharge is 2,4,5,6,8 or null
"RTN","DGENCLEA",52,0)
 . ;File #25 (Dishonorable,Other Than Dishonorable,Undesirable,Bad Conduct,Dishonorable-VA
"RTN","DGENCLEA",53,0)
 . Q:(DGTYPE=2)!(DGTYPE=4)!(DGTYPE=5)!(DGTYPE=6)!(DGTYPE=8)!(DGTYPE="")
"RTN","DGENCLEA",54,0)
 . ;automatically quit out if DGMSE is NOT within date range
"RTN","DGENCLEA",55,0)
 . ;08011953 and 12311987
"RTN","DGENCLEA",56,0)
 . ;$H 41120(subtracted +1 to be 'inclusive') and 53690(added +1 to be 'inclusive')
"RTN","DGENCLEA",57,0)
 . ;FM 2530801 and 2871231
"RTN","DGENCLEA",58,0)
 . Q:(DGENTDT>53690)!(DGEXITDT<41120)   ;if either date is out of CLE date range do not continue (ineligible)
"RTN","DGENCLEA",59,0)
 . I DGENTDT<41120 S DGENTDT=41120  ;only include Entry Dates starting from CLE date range
"RTN","DGENCLEA",60,0)
 . I DGEXITDT>53690 S DGEXITDT=53690    ;only include Exit Dates ending at CLE date range
"RTN","DGENCLEA",61,0)
 . S X1=$$HTFM^XLFDT($G(DGEXITDT)),X2=$$HTFM^XLFDT($G(DGENTDT)) D ^%DTC S DGCLSRDT=DGCLSRDT+(X+1)
"RTN","DGENCLEA",62,0)
 . ;automatically quit out if DGMSE is NOT greater than 30 days
"RTN","DGENCLEA",63,0)
 . Q:DGCLSRDT<30
"RTN","DGENCLEA",64,0)
 . S DGCLE=1
"RTN","DGENCLEA",65,0)
 Q DGCLE
"RTN","DGENCLEA",66,0)
 ;
"RTN","DGENCLEA",67,0)
ADDEDTCL(DFN) ; DG*5.3*909 Enter/Edit Camp Lejeune Indicator
"RTN","DGENCLEA",68,0)
 ;
"RTN","DGENCLEA",69,0)
AECL2 N DGCLIND,DGCLOLD,DGSITE,X,Y
"RTN","DGENCLEA",70,0)
 K DIR S DIR(0)="YO"
"RTN","DGENCLEA",71,0)
 S DIR("A")="CAMP LEJEUNE WATER CONTAMINANT EXPOSURE INDICATED"
"RTN","DGENCLEA",72,0)
 S DGCLOLD=$P($G(^DPT(DFN,.3217)),U,1)
"RTN","DGENCLEA",73,0)
 S DIR("B")=$S(DGCLOLD="Y":"YES",DGCLOLD="N":"NO",1:"")
"RTN","DGENCLEA",74,0)
 K:DIR("B")="" DIR("B")
"RTN","DGENCLEA",75,0)
 S DIR("?",1)="Enter "_$C(34)_"Y"_$C(34)_" if veteran claims need "
"RTN","DGENCLEA",76,0)
 S DIR("?",1)=DIR("?",1)_"for care of conditions related to exposure of"
"RTN","DGENCLEA",77,0)
 S DIR("?",2)=$C(34)_"Water Contamination at Camp Lejeune"_$C(34)
"RTN","DGENCLEA",78,0)
 S DIR("?",2)=DIR("?",2)_". Enter "_$C(34)_"N"_$C(34)_" if veteran "
"RTN","DGENCLEA",79,0)
 S DIR("?",2)=DIR("?",2)_"was not assigned to"
"RTN","DGENCLEA",80,0)
 S DIR("?",3)="Camp Lejeune between August 1, 1953 and December 31, "
"RTN","DGENCLEA",81,0)
 S DIR("?",3)=DIR("?",3)_"1987 or does not claim need"
"RTN","DGENCLEA",82,0)
 S DIR("?",4)="for care of conditions related to exposure of "_$C(34)
"RTN","DGENCLEA",83,0)
 S DIR("?",4)=DIR("?",4)_"Water Contamination at Camp"
"RTN","DGENCLEA",84,0)
 S DIR("?",5)="Lejeune"_$C(34)_"."
"RTN","DGENCLEA",85,0)
 S DIR("?",6)="Choose from:",DIR("?",7)="Y YES",DIR("?",8)="N NO"
"RTN","DGENCLEA",86,0)
 S DIR("?")="Null "_$C(34)_"Blank"_$C(34)
"RTN","DGENCLEA",87,0)
 D ^DIR K DIR
"RTN","DGENCLEA",88,0)
 I X="@" D  G AECL2
"RTN","DGENCLEA",89,0)
 . W !!,"Camp Lejeune indicator cannot be deleted if already "
"RTN","DGENCLEA",90,0)
 . W "indicated.",!,"Enter '^' to exit.",!
"RTN","DGENCLEA",91,0)
 S DGCLIND=$S(Y=1:"Y",Y=0:"N",1:Y)
"RTN","DGENCLEA",92,0)
 Q:DGCLIND="^"  Q:"^Y^N^"'[(U_DGCLIND_U) 
"RTN","DGENCLEA",93,0)
 S DGSITE=$P($$SITE^VASITE,U,3)
"RTN","DGENCLEA",94,0)
 D SAVECL(DFN,DGCLIND,$P($$NOW^XLFDT,".",1),DGSITE,"VAMC")
"RTN","DGENCLEA",95,0)
 Q
"RTN","DGENCLEA",96,0)
 ;
"RTN","DGENCLEA",97,0)
SAVECL(DFN,DGCLIND,DGCLDAT,DGSITE,DGSOURCE) ; DG*5.3*909 Save CL-V info
"RTN","DGENCLEA",98,0)
 ; Check if CL-V Indicator already No or Yes, then use old date.
"RTN","DGENCLEA",99,0)
 N DGCLVREC S DGCLVREC=$G(^DPT(DFN,.3217))
"RTN","DGENCLEA",100,0)
 I "^Y^N^"[(U_$P(DGCLVREC,U)_U),$P(DGCLVREC,U,2)]"" D
"RTN","DGENCLEA",101,0)
 . S DGCLDAT=$P(DGCLVREC,U,2)
"RTN","DGENCLEA",102,0)
 S ^DPT(DFN,.3217)=DGCLIND_U_DGCLDAT_U_DGSITE_U_DGSOURCE
"RTN","DGENCLEA",103,0)
 Q
"RTN","DGENCLEA",104,0)
 ;
"RTN","DGENCLEA",105,0)
SETCLNO ; DG*5.3*909 Set Camp Lejeune to No when no longer CL Eligible
"RTN","DGENCLEA",106,0)
 Q:$P($G(^DPT(DFN,.3217)),U,1)'="Y"
"RTN","DGENCLEA",107,0)
 Q:$G(^DPT(DFN,.32171))=1    ; if Locked then don't chg YES to NO
"RTN","DGENCLEA",108,0)
 N DGCLE S DGCLE=$$CLE(DFN) Q:DGCLE
"RTN","DGENCLEA",109,0)
 D SAVECL(DFN,"N",$P($$NOW^XLFDT,".",1),$P($$SITE^VASITE,U,3),"VAMC")
"RTN","DGENCLEA",110,0)
 D AUTOUPD^DGENA2(DFN)
"RTN","DGENCLEA",111,0)
 Q
"RTN","DGENCLEA",112,0)
 ;
"RTN","DGENELA")
0^4^B30590661
"RTN","DGENELA",1,0)
DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN,ERC,TDM,JLS - Patient Eligibility API ;3/3/11 3:40pm
"RTN","DGENELA",2,0)
 ;;5.3;Registration;**121,147,232,314,451,564,631,672,659,583,653,688,841,909**;Aug 13,1993;Build 32
"RTN","DGENELA",3,0)
 ;
"RTN","DGENELA",4,0)
GET(DFN,DGELG) ;
"RTN","DGENELA",5,0)
 ;Description: Used to obtain the patient eligibility data.
"RTN","DGENELA",6,0)
 ;  The data is placed in the local DGELG array.
"RTN","DGENELA",7,0)
 ;Input:
"RTN","DGENELA",8,0)
 ;  DFN - internal entry number of a record in the PATIENT file
"RTN","DGENELA",9,0)
 ;Output:
"RTN","DGENELA",10,0)
 ;  Function Value - returns 1 on success, 0 on failure
"RTN","DGENELA",11,0)
 ;  DGELG - this is  a local array that will be used to return patient eligibility data. The array subscripts and the fields mapped to are defined below. (pass by reference)
"RTN","DGENELA",12,0)
 ;
"RTN","DGENELA",13,0)
 ;subscript             field name
"RTN","DGENELA",14,0)
 ;"DFN"                ien Patient record
"RTN","DGENELA",15,0)
 ;"ELIG","CODE"        Primary Eligibility Code
"RTN","DGENELA",16,0)
 ;"ELIG","CODE",<ien>  Patient Eligibilities
"RTN","DGENELA",17,0)
 ;"SC"                 Service Connected
"RTN","DGENELA",18,0)
 ;"SCPER"              Service Connected Percentage
"RTN","DGENELA",19,0)
 ;"EFFDT"              SC Combined Effective Date
"RTN","DGENELA",20,0)
 ;"POW"                POW Status Indicated
"RTN","DGENELA",21,0)
 ;"A&A"                Receiving A&A Benefits
"RTN","DGENELA",22,0)
 ;"HB"                 Receiving Housebound Benefits
"RTN","DGENELA",23,0)
 ;"VAPEN"              Receiving a VA Pension
"RTN","DGENELA",24,0)
 ;"VACKAMT"            Total Annual VA Check Amount
"RTN","DGENELA",25,0)
 ;"DISRET"             Military Disability Retirement
"RTN","DGENELA",26,0)
 ;"DISLOD"             Discharge Due to Disability (added with DG 672)
"RTN","DGENELA",27,0)
 ;"MEDICAID"           Medicaid
"RTN","DGENELA",28,0)
 ;"MEDASKDT"           Date Medicaid Last Asked
"RTN","DGENELA",29,0)
 ;"AO"                 Exposed to Agent Orange
"RTN","DGENELA",30,0)
 ;"IR"                 Radiation Exposure Indicated
"RTN","DGENELA",31,0)
 ;"RADEXPM"            Radiation Exposure Method
"RTN","DGENELA",32,0)
 ;"EC"                 SW Asia Cond - change from Env Con, DG*5.3*688
"RTN","DGENELA",33,0)
 ;"MTSTA"              Means Test Status
"RTN","DGENELA",34,0)
 ;P&T                  P&T
"RTN","DGENELA",35,0)
 ;P&TDT                P&T EFFECTIVE DATE (added with DG 688)
"RTN","DGENELA",36,0)
 ;POS                  PERIOD OF SERVICE
"RTN","DGENELA",37,0)
 ;UNEMPLOY             UNEMPLOYABLE
"RTN","DGENELA",38,0)
 ;SCAWDATE             SC AWARD DATE
"RTN","DGENELA",39,0)
 ;RATEINC              RATED INCOMPETENT
"RTN","DGENELA",40,0)
 ;CLAIMNUM             CLAIM NUMBER
"RTN","DGENELA",41,0)
 ;CLAIMLOC             CLAIM FOLDER LOCATION
"RTN","DGENELA",42,0)
 ;VADISAB              RECEIVING VA DISABILITY?
"RTN","DGENELA",43,0)
 ;ELIGSTA              ELIGIBILITY STATUS
"RTN","DGENELA",44,0)
 ;ELIGSTADATE          ELIGIBILITY STATUS DATE
"RTN","DGENELA",45,0)
 ;ELIGVERIF            ELIGIBILITY VERIF. METHOD
"RTN","DGENELA",46,0)
 ;ELIGVSITE            ELIGIBILITY VERIFICATION SITE
"RTN","DGENELA",47,0)
 ;ELIGENTBY            ELIGIBILITY STATUS ENTERED BY
"RTN","DGENELA",48,0)
 ;RATEDIS
"RTN","DGENELA",49,0)
 ;  <COUNT>,"RD"      RATED DISABILITY
"RTN","DGENELA",50,0)
 ;  <COUNT>,"PER"      DISABILITY %
"RTN","DGENELA",51,0)
 ;  <COUNT>,"RDSC"     SERVICE CONNECTED
"RTN","DGENELA",52,0)
 ;  <COUNT>,"RDEXT"    EXTREMITY
"RTN","DGENELA",53,0)
 ;  <COUNT>,"RDORIG"   ORIGINAL RD EFFECTIVE DATE
"RTN","DGENELA",54,0)
 ;  <COUNT>."RDCURR"   CURRENT RD EFFECTIVE DATE
"RTN","DGENELA",55,0)
 ;"VCD"               Veteran Catastrophically Disabled? (#.39)
"RTN","DGENELA",56,0)
 ;"PH"                PURPLE HEART INDICATED
"RTN","DGENELA",57,0)
 ;"AOEXPLOC"          AGENT ORANGE EXPOSURE LOCATION
"RTN","DGENELA",58,0)
 ;"CVELEDT"           COMBAT VETERAN END DATE
"RTN","DGENELA",59,0)
 ;"SHAD"              SHAD EXPOSURE
"RTN","DGENELA",60,0)
 ;"MOH"               MEDAL OF HONOR
"RTN","DGENELA",61,0)
 ;"CLE"                CAMP LEJEUNE INDICATED?
"RTN","DGENELA",62,0)
 ;"CLEDT"              CAMP LEJEUNE DATE
"RTN","DGENELA",63,0)
 ;"CLEST"              CAMP LEJEUNE CHANGE SITE
"RTN","DGENELA",64,0)
 ;"CLESOR"             CAMP LEJEUNE SOURCE
"RTN","DGENELA",65,0)
 ;
"RTN","DGENELA",66,0)
 K DGELG
"RTN","DGENELA",67,0)
 S DGELG=""
"RTN","DGENELA",68,0)
 Q:'$D(^DPT(DFN)) 0
"RTN","DGENELA",69,0)
 N NODE,SUBREC,COUNT,CODE,IEN
"RTN","DGENELA",70,0)
 ;
"RTN","DGENELA",71,0)
 S DGELG("DFN")=DFN
"RTN","DGENELA",72,0)
 S DGELG("VCD")=$$VCD^DGENA5(DFN)
"RTN","DGENELA",73,0)
 ;
"RTN","DGENELA",74,0)
 ;
"RTN","DGENELA",75,0)
 S NODE=$G(^DPT(DFN,.29))
"RTN","DGENELA",76,0)
 S DGELG("RATEINC")=$P(NODE,"^",12)
"RTN","DGENELA",77,0)
 ;
"RTN","DGENELA",78,0)
 S NODE=$G(^DPT(DFN,.3))
"RTN","DGENELA",79,0)
 S DGELG("SC")=$P(NODE,"^")
"RTN","DGENELA",80,0)
 S DGELG("SCPER")=$P(NODE,"^",2)
"RTN","DGENELA",81,0)
 S DGELG("P&T")=$P(NODE,"^",4)
"RTN","DGENELA",82,0)
 S DGELG("P&TDT")=$P(NODE,"^",13)
"RTN","DGENELA",83,0)
 S DGELG("UNEMPLOY")=$P(NODE,"^",5)
"RTN","DGENELA",84,0)
 S DGELG("SCAWDATE")=$P(NODE,"^",12)
"RTN","DGENELA",85,0)
 S DGELG("VADISAB")=$P(NODE,"^",11)
"RTN","DGENELA",86,0)
 S DGELG("EFFDT")=$P(NODE,"^",14)
"RTN","DGENELA",87,0)
 ;
"RTN","DGENELA",88,0)
 S NODE=$G(^DPT(DFN,.31))
"RTN","DGENELA",89,0)
 S DGELG("CLAIMNUM")=$P(NODE,"^",3)
"RTN","DGENELA",90,0)
 S DGELG("CLAIMLOC")=$P(NODE,"^",4)
"RTN","DGENELA",91,0)
 ;
"RTN","DGENELA",92,0)
 S NODE=$G(^DPT(DFN,.32))
"RTN","DGENELA",93,0)
 S DGELG("POS")=$P(NODE,"^",3)
"RTN","DGENELA",94,0)
 ;
"RTN","DGENELA",95,0)
 S NODE=$G(^DPT(DFN,.36))
"RTN","DGENELA",96,0)
 S DGELG("ELIG","CODE")=$P(NODE,"^") ;primary eligibility
"RTN","DGENELA",97,0)
 S DGELG("DISRET")=$P(NODE,"^",12)
"RTN","DGENELA",98,0)
 S DGELG("DISLOD")=$P(NODE,"^",13)
"RTN","DGENELA",99,0)
 ;
"RTN","DGENELA",100,0)
 S NODE=$G(^DPT(DFN,.38))
"RTN","DGENELA",101,0)
 S DGELG("MEDICAID")=$P(NODE,"^")
"RTN","DGENELA",102,0)
 S DGELG("MEDASKDT")=$P(NODE,"^",2) ;Date Medicaid Last Asked
"RTN","DGENELA",103,0)
 ;
"RTN","DGENELA",104,0)
 S NODE=$G(^DPT(DFN,.361))
"RTN","DGENELA",105,0)
 S DGELG("ELIGSTA")=$P(NODE,"^")
"RTN","DGENELA",106,0)
 S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
"RTN","DGENELA",107,0)
 S DGELG("ELIGVERIF")=$P(NODE,"^",5)
"RTN","DGENELA",108,0)
 S DGELG("ELIGENTBY")=$P(NODE,"^",6)
"RTN","DGENELA",109,0)
 ;
"RTN","DGENELA",110,0)
 S NODE=$G(^DPT(DFN,.362))
"RTN","DGENELA",111,0)
 S DGELG("VACKAMT")=$P(NODE,"^",20)
"RTN","DGENELA",112,0)
 S DGELG("VAPEN")=$P(NODE,"^",14)
"RTN","DGENELA",113,0)
 S DGELG("A&A")=$P(NODE,"^",12)
"RTN","DGENELA",114,0)
 S DGELG("HB")=$P(NODE,"^",13)
"RTN","DGENELA",115,0)
 ;
"RTN","DGENELA",116,0)
 ;
"RTN","DGENELA",117,0)
 S NODE=$G(^DPT(DFN,.321))
"RTN","DGENELA",118,0)
 S DGELG("AO")=$P(NODE,"^",2)
"RTN","DGENELA",119,0)
 S DGELG("IR")=$P(NODE,"^",3)
"RTN","DGENELA",120,0)
 S DGELG("RADEXPM")=$P(NODE,"^",12)
"RTN","DGENELA",121,0)
 S DGELG("AOEXPLOC")=$P(NODE,"^",13)
"RTN","DGENELA",122,0)
 S DGELG("SHAD")=$P(NODE,"^",15)  ;added with DG*5.3*653
"RTN","DGENELA",123,0)
 ;
"RTN","DGENELA",124,0)
 S NODE=$G(^DPT(DFN,.322))
"RTN","DGENELA",125,0)
 S DGELG("EC")=$P(NODE,"^",13)
"RTN","DGENELA",126,0)
 ;
"RTN","DGENELA",127,0)
 S NODE=$G(^DPT(DFN,.52))
"RTN","DGENELA",128,0)
 S DGELG("POW")=$P(NODE,"^",5)
"RTN","DGENELA",129,0)
 S DGELG("CVELEDT")=$P(NODE,"^",15)
"RTN","DGENELA",130,0)
 ;
"RTN","DGENELA",131,0)
 ; Purple Heart Indicator
"RTN","DGENELA",132,0)
 S NODE=$G(^DPT(DFN,.53))
"RTN","DGENELA",133,0)
 S DGELG("PH")=$P(NODE,"^")
"RTN","DGENELA",134,0)
 ;
"RTN","DGENELA",135,0)
 ; Medal of Honor Indicator
"RTN","DGENELA",136,0)
 S NODE=$G(^DPT(DFN,.54))
"RTN","DGENELA",137,0)
 S DGELG("MOH")=$P(NODE,"^")
"RTN","DGENELA",138,0)
 ;
"RTN","DGENELA",139,0)
 ; Camp Lejeune Eligibility Indicator  DG*5.3*909
"RTN","DGENELA",140,0)
 S NODE=$G(^DPT(DFN,.3217))
"RTN","DGENELA",141,0)
 S DGELG("CLE")=$P(NODE,"^",1)
"RTN","DGENELA",142,0)
 S DGELG("CLEDT")=$P(NODE,"^",2)
"RTN","DGENELA",143,0)
 S DGELG("CLEST")=$P(NODE,"^",3)
"RTN","DGENELA",144,0)
 S DGELG("CLESOR")=$P(NODE,"^",4)
"RTN","DGENELA",145,0)
 ;
"RTN","DGENELA",146,0)
 ;means test category
"RTN","DGENELA",147,0)
 S DGELG("MTSTA")=""
"RTN","DGENELA",148,0)
 S IEN=$P($$LST^DGMTU(DFN),"^")
"RTN","DGENELA",149,0)
 I IEN S DGELG("MTSTA")=$P($G(^DGMT(408.31,IEN,0)),"^",3)
"RTN","DGENELA",150,0)
 ;
"RTN","DGENELA",151,0)
 ;get the other eligibilities multiple
"RTN","DGENELA",152,0)
 S SUBREC=0
"RTN","DGENELA",153,0)
 F  S SUBREC=$O(^DPT(DFN,"E",SUBREC)) Q:'SUBREC  D
"RTN","DGENELA",154,0)
 .S CODE=+$G(^DPT(DFN,"E",SUBREC,0))
"RTN","DGENELA",155,0)
 .;
"RTN","DGENELA",156,0)
 .;need to check the "B" x-ref, because when a code is deleted from the multiple, the kill logic is executed BEFORE the data is actually removed - but the "B" x-ref has been deleted at this point
"RTN","DGENELA",157,0)
 .I CODE,$D(^DPT(DFN,"E","B",CODE)) S DGELG("ELIG","CODE",CODE)=SUBREC
"RTN","DGENELA",158,0)
 ;
"RTN","DGENELA",159,0)
 ;rated disability multiple
"RTN","DGENELA",160,0)
 S SUBREC=0,COUNT=0
"RTN","DGENELA",161,0)
 F  S SUBREC=$O(^DPT(DFN,.372,SUBREC)) Q:'SUBREC  D
"RTN","DGENELA",162,0)
 .S NODE=$G(^DPT(DFN,.372,SUBREC,0))
"RTN","DGENELA",163,0)
 .Q:'$P(NODE,"^")
"RTN","DGENELA",164,0)
 .S COUNT=COUNT+1
"RTN","DGENELA",165,0)
 .S DGELG("RATEDIS",COUNT,"RD")=$P(NODE,"^")
"RTN","DGENELA",166,0)
 .S DGELG("RATEDIS",COUNT,"PER")=$P(NODE,"^",2)
"RTN","DGENELA",167,0)
 .S DGELG("RATEDIS",COUNT,"RDSC")=$P(NODE,"^",3)
"RTN","DGENELA",168,0)
 .S DGELG("RATEDIS",COUNT,"RDEXT")=$P(NODE,"^",4)
"RTN","DGENELA",169,0)
 .S DGELG("RATEDIS",COUNT,"RDORIG")=$P(NODE,"^",5)
"RTN","DGENELA",170,0)
 .S DGELG("RATEDIS",COUNT,"RDCURR")=$P(NODE,"^",6)
"RTN","DGENELA",171,0)
 ;
"RTN","DGENELA",172,0)
 Q 1
"RTN","DGENELA",173,0)
 ;
"RTN","DGENELA",174,0)
NATNAME(CODE) ;
"RTN","DGENELA",175,0)
 ;Description: Given an entry in file #8, Eligibility Code file,
"RTN","DGENELA",176,0)
 ;  finds the corresponding entry in file 8.1, MAS Eligibility Code file,
"RTN","DGENELA",177,0)
 ;  and returns the name
"RTN","DGENELA",178,0)
 ;Input:
"RTN","DGENELA",179,0)
 ;  CODE - pointer to file #8
"RTN","DGENELA",180,0)
 ;Output:
"RTN","DGENELA",181,0)
 ;  Function Value - name of corresponding code in file #8.1
"RTN","DGENELA",182,0)
 ;
"RTN","DGENELA",183,0)
 Q:'$G(CODE) ""
"RTN","DGENELA",184,0)
 Q $$CODENAME($P($G(^DIC(8,CODE,0)),"^",9))
"RTN","DGENELA",185,0)
 ;
"RTN","DGENELA",186,0)
NATCODE(CODE) ;
"RTN","DGENELA",187,0)
 ;Description: Given an entry in file #8, Eligibility Code file,
"RTN","DGENELA",188,0)
 ;  finds the corresponding entry in file 8.1, MAS Eligibility Code file
"RTN","DGENELA",189,0)
 ;Input:
"RTN","DGENELA",190,0)
 ;  CODE - pointer to file #8
"RTN","DGENELA",191,0)
 ;Output:
"RTN","DGENELA",192,0)
 ;  Function Value - pointer to file #8.1
"RTN","DGENELA",193,0)
 ;
"RTN","DGENELA",194,0)
 Q:'$G(CODE) ""
"RTN","DGENELA",195,0)
 Q $P($G(^DIC(8,CODE,0)),"^",9)
"RTN","DGENELA",196,0)
 ;
"RTN","DGENELA",197,0)
CODENAME(CODE) ;
"RTN","DGENELA",198,0)
 ;Description: Given a pointer to file #8.1, MAS Eligibility Code file,
"RTN","DGENELA",199,0)
 ;  it returns the name of the code 
"RTN","DGENELA",200,0)
 ;Input:
"RTN","DGENELA",201,0)
 ;  CODE - pointer to file #8.1
"RTN","DGENELA",202,0)
 ;Output:
"RTN","DGENELA",203,0)
 ;  Function Value - name of the code pointed to
"RTN","DGENELA",204,0)
 ;
"RTN","DGENELA",205,0)
 Q:'$G(CODE) ""
"RTN","DGENELA",206,0)
 Q $P($G(^DIC(8.1,CODE,0)),"^")
"RTN","DGENELA",207,0)
 ;
"RTN","DGENELA",208,0)
ELIGSTAT(DFN,DGELG) ;
"RTN","DGENELA",209,0)
 ;Description: Used to get the ELIGIBILITY STATUS and the 
"RTN","DGENELA",210,0)
 ;ELIGIBILITY STATUS DATE of the patient.
"RTN","DGENELA",211,0)
 ;
"RTN","DGENELA",212,0)
 ;Input:
"RTN","DGENELA",213,0)
 ;  DFN - ien of patient record
"RTN","DGENELA",214,0)
 ;
"RTN","DGENELA",215,0)
 ;Output:
"RTN","DGENELA",216,0)
 ;  Function Value - 1 on success, 0 on failure
"RTN","DGENELA",217,0)
 ;  DGELG array (pass by reference)
"RTN","DGENELA",218,0)
 ;    "ELIGSTA" - ELIGIBILITY STATUS
"RTN","DGENELA",219,0)
 ;    "ELIGSTADATE" - ELIGIBILITY STATUS DATE
"RTN","DGENELA",220,0)
 ;
"RTN","DGENELA",221,0)
 N NODE,SUCCESS
"RTN","DGENELA",222,0)
 D
"RTN","DGENELA",223,0)
 .S SUCCESS=1
"RTN","DGENELA",224,0)
 .I '$G(DFN) S SUCCESS=0 Q
"RTN","DGENELA",225,0)
 .S NODE=$G(^DPT(DFN,.361))
"RTN","DGENELA",226,0)
 .S DGELG("ELIGSTA")=$P(NODE,"^")
"RTN","DGENELA",227,0)
 .S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
"RTN","DGENELA",228,0)
 Q SUCCESS
"RTN","DGENELA1")
0^13^B84040190
"RTN","DGENELA1",1,0)
DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD,EG,TMK,CKN,ERC - Patient Eligibility API ;20 Jan 2015  3:27 PM
"RTN","DGENELA1",2,0)
 ;;5.3;Registration;**147,327,314,367,497,451,564,631,672,659,583,746,653,688,841,909**;Aug 13,1993;Build 32
"RTN","DGENELA1",3,0)
 ;
"RTN","DGENELA1",4,0)
CHECK(DGELG,DGPAT,DGCDIS,ERRMSG) ;
"RTN","DGENELA1",5,0)
 ;Does validation checks on the eligibility contained in the DGELG array.
"RTN","DGENELA1",6,0)
 ;
"RTN","DGENELA1",7,0)
 ;Input:
"RTN","DGENELA1",8,0)
 ;  DGELG - array containing eligibility data (pass by reference)
"RTN","DGENELA1",9,0)
 ;  DGPAT - array containing patient data (pass by reference)
"RTN","DGENELA1",10,0)
 ;  DGCDIS - array containing catastrophic disability determination (pass by reference)
"RTN","DGENELA1",11,0)
 ;
"RTN","DGENELA1",12,0)
 ;Output:
"RTN","DGENELA1",13,0)
 ;  Function Value - returns 1 if all validation checks passed, 0 otherwise
"RTN","DGENELA1",14,0)
 ;  ERRMSG - returns a message if validations fail (pass by reference)
"RTN","DGENELA1",15,0)
 ;
"RTN","DGENELA1",16,0)
 N SUCCESS,NATCODE,BAD,SUB,CODE,DGONV,DGTEXT,INELDATE
"RTN","DGENELA1",17,0)
 S SUCCESS=0
"RTN","DGENELA1",18,0)
 S ERRMSG=""
"RTN","DGENELA1",19,0)
 ;
"RTN","DGENELA1",20,0)
 D  ;drops out of block on failure
"RTN","DGENELA1",21,0)
 .;
"RTN","DGENELA1",22,0)
 .;get optional arrays if not there
"RTN","DGENELA1",23,0)
 .I '$D(DGPAT),'$$GET^DGENPTA(DGELG("DFN"),.DGPAT) S ERRMSG="PATIENT NOT FOUND" Q
"RTN","DGENELA1",24,0)
 .I '$D(DGCDIS),'$$GET^DGENCDA(DGELG("DFN"),.DGCDIS) S ERRMSG="PATIENT NOT FOUND" Q
"RTN","DGENELA1",25,0)
 .;
"RTN","DGENELA1",26,0)
 .;do field level checks
"RTN","DGENELA1",27,0)
 .S SUB="" F  S SUB=$O(DGELG(SUB)) Q:(SUB="")  I SUB'="ELIG",SUB'="RATEDIS",'$$CHKFIELD(SUB,DGELG(SUB)) S ERRMSG="BAD VALUE, FIELD = "_$$GET1^DID(2,$$FIELD(SUB),"","LABEL") Q
"RTN","DGENELA1",28,0)
 .;
"RTN","DGENELA1",29,0)
 .Q:(SUB'="")  ;didn't finish the loop
"RTN","DGENELA1",30,0)
 .;
"RTN","DGENELA1",31,0)
 .;also check SC % field of Rated Disabilities
"RTN","DGENELA1",32,0)
 .S SUB="" F  S SUB=$O(DGELG("RATEDIS",SUB)) Q:(SUB="")  I '$$CHKFIELD("PER",DGELG("RATEDIS",SUB,"PER")) S ERRMSG="BAD VALUE, FIELD = DISABILITY % OF THE RATED DISABILITIES MULTIPLE" Q
"RTN","DGENELA1",33,0)
 .Q:(SUB'="")  ;didn't finish the loop
"RTN","DGENELA1",34,0)
 .;
"RTN","DGENELA1",35,0)
 .I DGELG("SC")="Y",DGELG("SCPER")="" S ERRMSG="SC% UNSPECIFIED FOR SC VET" Q
"RTN","DGENELA1",36,0)
 .;
"RTN","DGENELA1",37,0)
 .;!! put this check back when POS is added to the Z11 message
"RTN","DGENELA1",38,0)
 .;I DGPAT("VETERAN")="Y",'DGELG("POS") S ERRMSG="POS UNSPECIFIED" Q 
"RTN","DGENELA1",39,0)
 .;
"RTN","DGENELA1",40,0)
 .I 'DGELG("ELIG","CODE") S ERRMSG="PRIMARY ELIGIBILITY IS UNSPECIFIED" Q
"RTN","DGENELA1",41,0)
 .;
"RTN","DGENELA1",42,0)
 .I (DGELG("VACKAMT")>0),(DGELG("A&A")_DGELG("HB")_DGELG("VAPEN")_DGELG("VADISAB")'["Y") S ERRMSG="VA CHECK AMOUNT > 0 BUT INCOME INDICATORS ALL SHOW 'NO'" Q
"RTN","DGENELA1",43,0)
 .;
"RTN","DGENELA1",44,0)
 .;
"RTN","DGENELA1",45,0)
 .;
"RTN","DGENELA1",46,0)
 .I (DGELG("SC")="N"),(DGELG("VADISAB")="Y") S ERRMSG="NSC VETERANS CAN NOT BE RECEIVING VA DISABILITY BENEFITS" Q
"RTN","DGENELA1",47,0)
 .;
"RTN","DGENELA1",48,0)
 .S BAD=1 D  Q:BAD  ;check primary eligibility
"RTN","DGENELA1",49,0)
 ..S NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
"RTN","DGENELA1",50,0)
 ..Q:'NATCODE
"RTN","DGENELA1",51,0)
 ..;
"RTN","DGENELA1",52,0)
 ..I NATCODE=21 S ERRMSG="CATASTROPHICALLY DISABLED NOT ALLOWED AS PRIMARY ELIGIBILITY" Q
"RTN","DGENELA1",53,0)
 ..;
"RTN","DGENELA1",54,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")<50),(NATCODE'=3) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
"RTN","DGENELA1",55,0)
 ..;
"RTN","DGENELA1",56,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")>49),(NATCODE'=1) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
"RTN","DGENELA1",57,0)
 ..;
"RTN","DGENELA1",58,0)
 ..S DGONV=$O(^DIC(21,"B","OTHER NON-VETERANS","")),INELDATE=$P($G(^DPT(DFN,.15)),"^",2)
"RTN","DGENELA1",59,0)
 ..I INELDATE'="",DGPAT("INELDATE")'>0,DGELG("POS"),DGELG("POS")=DGONV,'$D(^DIC(21,DGELG("POS"),"E",DGELG("ELIG","CODE"))) D
"RTN","DGENELA1",60,0)
 ...S DGTEXT="Patient was previously determined to be ineligible for VA health care.  Upon review, the individual is determined to be eligible for "
"RTN","DGENELA1",61,0)
 ...S DGTEXT=DGTEXT_"VA care.  Please update period of service and other eligibility data as needed.."
"RTN","DGENELA1",62,0)
 ...D ADDMSG^DGENUPL3(.MSGS,DGTEXT,0)
"RTN","DGENELA1",63,0)
 ..;
"RTN","DGENELA1",64,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(NATCODE=1)!(NATCODE=3) S BAD=0 Q  ;primary eligibility OK
"RTN","DGENELA1",65,0)
 ..;
"RTN","DGENELA1",66,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE'=18 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PRISONER OF WAR" Q
"RTN","DGENELA1",67,0)
 ..;
"RTN","DGENELA1",68,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE=18 S BAD=0 Q
"RTN","DGENELA1",69,0)
 ..;
"RTN","DGENELA1",70,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE'=22 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PURPLE HEART RECIPIENT" Q
"RTN","DGENELA1",71,0)
 ..;
"RTN","DGENELA1",72,0)
 ..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE=22 S BAD=0 Q
"RTN","DGENELA1",73,0)
 ..;
"RTN","DGENELA1",74,0)
 ..; disabled DG*5.3*367, for Inel
"RTN","DGENELA1",75,0)
 ..;I (DGPAT("VETERAN")'=$P($G(^DIC(8.1,NATCODE,0)),"^",5)) S ERRMSG="PRIMARY ELIGIBILTY NOT CONSISTENT WITH VETERAN STATUS" Q
"RTN","DGENELA1",76,0)
 ..;
"RTN","DGENELA1",77,0)
 ..I DGELG("A&A")'="Y",NATCODE=2 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH A&A INDICATOR" Q
"RTN","DGENELA1",78,0)
 ..;
"RTN","DGENELA1",79,0)
 ..I DGELG("HB")'="Y",NATCODE=15 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH HOUSEBOUND INDICATOR" Q
"RTN","DGENELA1",80,0)
 ..;
"RTN","DGENELA1",81,0)
 ..I DGELG("VAPEN")'="Y",NATCODE=4 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH VA PENSION INDICATOR" Q
"RTN","DGENELA1",82,0)
 ..;
"RTN","DGENELA1",83,0)
 ..I DGELG("SC")="Y",((NATCODE=4)!(NATCODE=5)) S ERRMSG="NSC ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTION INDICATOR" Q
"RTN","DGENELA1",84,0)
 ..;
"RTN","DGENELA1",85,0)
 ..I (DGPAT("DOB")>2061231),(NATCODE=16) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR" Q
"RTN","DGENELA1",86,0)
 ..;
"RTN","DGENELA1",87,0)
 ..I (DGPAT("DOB")>2071231),(NATCODE=17) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I" Q
"RTN","DGENELA1",88,0)
 ..;
"RTN","DGENELA1",89,0)
 ..;primary eligibility is good
"RTN","DGENELA1",90,0)
 ..S BAD=0
"RTN","DGENELA1",91,0)
 .;
"RTN","DGENELA1",92,0)
 .S SUCCESS=1
"RTN","DGENELA1",93,0)
 .;check eligibilities multiple
"RTN","DGENELA1",94,0)
 .S CODE=0 F  S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:'CODE  D  Q:('SUCCESS)
"RTN","DGENELA1",95,0)
 ..S NATCODE=$$NATCODE^DGENELA(CODE)
"RTN","DGENELA1",96,0)
 ..Q:'NATCODE
"RTN","DGENELA1",97,0)
 ..I NATCODE=21,'DGCDIS("DATE") S SUCCESS=0,ERRMSG="CATASTROPHICALLY DISABLED ELIGIBILITY REQUIRES CATASTROPHICALLY DISABLED DETERMINATION DATE" Q
"RTN","DGENELA1",98,0)
 .;
"RTN","DGENELA1",99,0)
 Q SUCCESS
"RTN","DGENELA1",100,0)
 ;
"RTN","DGENELA1",101,0)
STORE(DGELG,DGPAT,DGCDIS,ERROR,SKIPCHK) ;
"RTN","DGENELA1",102,0)
 ;Stores an eligibility record for a patient. The patient record must
"RTN","DGENELA1",103,0)
 ;already exist. A lock on the Patient record is required, and is
"RTN","DGENELA1",104,0)
 ;released upon completion.
"RTN","DGENELA1",105,0)
 ;
"RTN","DGENELA1",106,0)
 ;Input:
"RTN","DGENELA1",107,0)
 ;  DGELG - eligibility array (pass by reference)
"RTN","DGENELA1",108,0)
 ;  DGPAT - patient array (optional, pass by reference)
"RTN","DGENELA1",109,0)
 ;  DGCDIS - array containing the catastrophic disability determination (optional, pass by reference)
"RTN","DGENELA1",110,0)
 ;  SKIPCHK - flag, set to 1 means that the consistency checks
"RTN","DGENELA1",111,0)
 ;            were already done & should be skipped
"RTN","DGENELA1",112,0)
 ;
"RTN","DGENELA1",113,0)
 ;Output:
"RTN","DGENELA1",114,0)
 ;  Function Value - returns 1 if successful, otherwise 0
"RTN","DGENELA1",115,0)
 ;  ERROR - in event of failure returns an error message (pass by reference, optional)
"RTN","DGENELA1",116,0)
 ;
"RTN","DGENELA1",117,0)
 N SUCCESS,DATA,FIELD,DA,DFN,COUNT
"RTN","DGENELA1",118,0)
 S DFN=$G(DGELG("DFN"))
"RTN","DGENELA1",119,0)
 S SUCCESS=0
"RTN","DGENELA1",120,0)
 S ERROR=""
"RTN","DGENELA1",121,0)
 ;
"RTN","DGENELA1",122,0)
 D  ;drops out of block on failure
"RTN","DGENELA1",123,0)
 .I '$$LOCK^DGENPTA1(DFN) S ERROR="UNABLE TO LOCK PATIENT RECORD" Q
"RTN","DGENELA1",124,0)
 .I $G(SKIPCHK)'=1,'$$CHECK(.DGELG,.DGPAT,.DGCDIS,.ERROR) Q
"RTN","DGENELA1",125,0)
 .S SUB="" F  S SUB=$O(DGELG(SUB)) Q:SUB=""  D
"RTN","DGENELA1",126,0)
 ..I SUB'="ELIG",SUB'="RATEDIS",SUB'="DFN" S FIELD=$$FIELD(SUB) I FIELD S DATA(FIELD)=DGELG(SUB)
"RTN","DGENELA1",127,0)
 .;lock Camp Lejeune when it comes over from HEC in Z11 - DG*5.3*909
"RTN","DGENELA1",128,0)
 .I "^Y^N^"[("^"_$G(DATA(.321701))_"^") S DATA(.32171)=1
"RTN","DGENELA1",129,0)
 .;
"RTN","DGENELA1",130,0)
 .;don't add the Primary Eligibility unless different, so as to not
"RTN","DGENELA1",131,0)
 .;fire off x-refs unless necessary
"RTN","DGENELA1",132,0)
 .I $P($G(^DPT(DFN,.36)),"^")'=DGELG("ELIG","CODE") S DATA(.361)=DGELG("ELIG","CODE")
"RTN","DGENELA1",133,0)
 .;
"RTN","DGENELA1",134,0)
 .; Only update User Enrollee fields if the incoming UE status is
"RTN","DGENELA1",135,0)
 .; greater than the USER ENROLLEE VALID THROUGH on file.
"RTN","DGENELA1",136,0)
 .I $G(DATA(.3617))<$P($G(^DPT(DFN,.361)),"^",7) K DATA(.3617),DATA(.3618)
"RTN","DGENELA1",137,0)
 .;
"RTN","DGENELA1",138,0)
 .;update Patient file record with data from Z11
"RTN","DGENELA1",139,0)
 .D UPDZ11^DGENELA2
"RTN","DGENELA1",140,0)
 .;
"RTN","DGENELA1",141,0)
 .;delete eligibilities that do not belong
"RTN","DGENELA1",142,0)
 .D DELELIG^DGENELA2(DFN,.DGELG)
"RTN","DGENELA1",143,0)
 .;
"RTN","DGENELA1",144,0)
 .;overlay Rated Disabilities
"RTN","DGENELA1",145,0)
 .Q:'$$OVERLAY()
"RTN","DGENELA1",146,0)
 .;
"RTN","DGENELA1",147,0)
 .;Add the new Patient Eligibilities
"RTN","DGENELA1",148,0)
 .;Don't add the an eligibility unless different - so as to not
"RTN","DGENELA1",149,0)
 .;fire off the x-refs unless necessary.
"RTN","DGENELA1",150,0)
 .;Also, try to assign ien = the code (see input transform of the field).
"RTN","DGENELA1",151,0)
 .K DA,DATA
"RTN","DGENELA1",152,0)
 .S DA(1)=DFN
"RTN","DGENELA1",153,0)
 .S DATA(.01)=0
"RTN","DGENELA1",154,0)
 .F  S DATA(.01)=$O(DGELG("ELIG","CODE",DATA(.01))) Q:'DATA(.01)  I '$D(^DPT(DFN,"E","B",DATA(.01))) I '$$ADD^DGENDBS(2.0361,.DA,.DATA,,$S($D(^DPT(DFN,"E",DATA(.01))):0,1:DATA(.01))) S ERROR="FILEMAN FAILED TO ADD PATIENT ELIGIBILITY" Q
"RTN","DGENELA1",155,0)
 .;
"RTN","DGENELA1",156,0)
 .S SUCCESS=1
"RTN","DGENELA1",157,0)
 ;
"RTN","DGENELA1",158,0)
 D UNLOCK^DGENPTA1(DFN)
"RTN","DGENELA1",159,0)
 Q SUCCESS
"RTN","DGENELA1",160,0)
 ;
"RTN","DGENELA1",161,0)
FIELD(SUB) ;
"RTN","DGENELA1",162,0)
 ;given a subscript from the ELIGIBILITY array, returns the field number
"RTN","DGENELA1",163,0)
 ;
"RTN","DGENELA1",164,0)
 Q:SUB="CODE" .361
"RTN","DGENELA1",165,0)
 Q:SUB="SC" .301
"RTN","DGENELA1",166,0)
 Q:SUB="SCPER" .302
"RTN","DGENELA1",167,0)
 Q:SUB="EFFDT" .3014
"RTN","DGENELA1",168,0)
 Q:SUB="POW" .525
"RTN","DGENELA1",169,0)
 Q:SUB="PH" .531
"RTN","DGENELA1",170,0)
 Q:SUB="A&A" .36205
"RTN","DGENELA1",171,0)
 Q:SUB="HB" .36215
"RTN","DGENELA1",172,0)
 Q:SUB="VAPEN" .36235
"RTN","DGENELA1",173,0)
 Q:SUB="VACKAMT" .36295
"RTN","DGENELA1",174,0)
 Q:SUB="DISRET" .3602
"RTN","DGENELA1",175,0)
 Q:SUB="DISLOD" .3603
"RTN","DGENELA1",176,0)
 Q:SUB="MEDICAID" .381
"RTN","DGENELA1",177,0)
 Q:SUB="MEDASKDT" .382 ;EVC - DG*5.3*653
"RTN","DGENELA1",178,0)
 Q:SUB="AO" .32102
"RTN","DGENELA1",179,0)
 Q:SUB="IR" .32103
"RTN","DGENELA1",180,0)
 Q:SUB="EC" .322013  ;name change from Env Con, DG*5.3*688
"RTN","DGENELA1",181,0)
 Q:SUB="MTSTA" ""  ;don't map Means Test Category
"RTN","DGENELA1",182,0)
 Q:SUB="P&T" .304
"RTN","DGENELA1",183,0)
 Q:SUB="P&TDT" .3013  ;field added with DG*5.3*688
"RTN","DGENELA1",184,0)
 Q:SUB="POS" .323
"RTN","DGENELA1",185,0)
 Q:SUB="UNEMPLOY" .305
"RTN","DGENELA1",186,0)
 Q:SUB="SCAWDATE" .3012
"RTN","DGENELA1",187,0)
 Q:SUB="RATEINC" .293
"RTN","DGENELA1",188,0)
 Q:SUB="CLAIMNUM" .313
"RTN","DGENELA1",189,0)
 Q:SUB="CLAIMLOC" .314
"RTN","DGENELA1",190,0)
 Q:SUB="VADISAB" .3025
"RTN","DGENELA1",191,0)
 Q:SUB="ELIGSTA" .3611
"RTN","DGENELA1",192,0)
 Q:SUB="ELIGSTADATE" .3612
"RTN","DGENELA1",193,0)
 Q:SUB="ELIGVERIF" .3615
"RTN","DGENELA1",194,0)
 Q:SUB="ELIGENTBY" .3616
"RTN","DGENELA1",195,0)
 Q:SUB="RD" .01
"RTN","DGENELA1",196,0)
 Q:SUB="PER" 2
"RTN","DGENELA1",197,0)
 Q:SUB="RDSC" 3
"RTN","DGENELA1",198,0)
 Q:SUB="RDEXT" 4
"RTN","DGENELA1",199,0)
 Q:SUB="RDORIG" 5
"RTN","DGENELA1",200,0)
 Q:SUB="RDCURR" 6
"RTN","DGENELA1",201,0)
 Q:SUB="UEYEAR" .3617
"RTN","DGENELA1",202,0)
 Q:SUB="UESITE" .3618
"RTN","DGENELA1",203,0)
 Q:SUB="AOEXPLOC" .3213
"RTN","DGENELA1",204,0)
 Q:SUB="CVELEDT" .5295
"RTN","DGENELA1",205,0)
 Q:SUB="SHAD" .32115
"RTN","DGENELA1",206,0)
 Q:SUB="MOH" .541
"RTN","DGENELA1",207,0)
 Q:SUB="CLE" .321701     ; Added for Camp Lejeune - DG*5.3*909
"RTN","DGENELA1",208,0)
 Q:SUB="CLEDT" .321702   ; Added for Camp Lejeune - DG*5.3*909
"RTN","DGENELA1",209,0)
 Q:SUB="CLEST" .321703   ; Added for Camp Lejeune - DG*5.3*909
"RTN","DGENELA1",210,0)
 Q:SUB="CLESOR" .321704  ; Added for Camp Lejeune - DG*5.3*909
"RTN","DGENELA1",211,0)
 ;
"RTN","DGENELA1",212,0)
 Q ""
"RTN","DGENELA1",213,0)
 ;
"RTN","DGENELA1",214,0)
CHKFIELD(SUB,VAL) ;
"RTN","DGENELA1",215,0)
 ;Description: Does field level validation of the value. Returns 1
"RTN","DGENELA1",216,0)
 ;if the value is good, 0 otherwise.
"RTN","DGENELA1",217,0)
 ;
"RTN","DGENELA1",218,0)
 Q:($G(VAL)="") 1  ;for now, all NULL values assumed okay
"RTN","DGENELA1",219,0)
 ;
"RTN","DGENELA1",220,0)
 N BAD S BAD=0
"RTN","DGENELA1",221,0)
 I (SUB="SCPER")!(SUB="PER"),(+VAL'=VAL)!(VAL>100)!(VAL<0)!(VAL?.E1"."1N.N) S BAD=1
"RTN","DGENELA1",222,0)
 I SUB="VACKAMT",+VAL'=VAL&(VAL'?.N1"."2N)!(VAL>99999)!(VAL<0) S BAD=1
"RTN","DGENELA1",223,0)
 I SUB="DISRET",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",224,0)
 I SUB="DISLOD",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",225,0)
 I SUB="MEDICAID",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",226,0)
 I SUB="RATEINC",VAL'=0,VAL'=1 S BAD=1
"RTN","DGENELA1",227,0)
 I SUB="ELIGSTA",VAL'="P",VAL'="R",VAL'="V" S BAD=1
"RTN","DGENELA1",228,0)
 I SUB="POW",VAL'="Y",VAL'="N",VAL'="U" S BAD=1
"RTN","DGENELA1",229,0)
 Q 'BAD
"RTN","DGENELA1",230,0)
 ;
"RTN","DGENELA1",231,0)
 ;
"RTN","DGENELA1",232,0)
OVERLAY() ;
"RTN","DGENELA1",233,0)
 ;Description: Overlay the local Rated Disabilities with whatever HEC
"RTN","DGENELA1",234,0)
 ;sent.
"RTN","DGENELA1",235,0)
 ;
"RTN","DGENELA1",236,0)
 N SUCCESS S SUCCESS=1
"RTN","DGENELA1",237,0)
 ;
"RTN","DGENELA1",238,0)
 ;delete the rated disabilities multiple
"RTN","DGENELA1",239,0)
 D DELRDIS^DGENELA2(DFN)
"RTN","DGENELA1",240,0)
 ;
"RTN","DGENELA1",241,0)
 ;add the rated disabilities
"RTN","DGENELA1",242,0)
 K DATA,DA
"RTN","DGENELA1",243,0)
 S DA(1)=DFN
"RTN","DGENELA1",244,0)
 S COUNT=0
"RTN","DGENELA1",245,0)
 F  S COUNT=$O(DGELG("RATEDIS",COUNT)) Q:'COUNT  D
"RTN","DGENELA1",246,0)
 .S DATA(.01)=DGELG("RATEDIS",COUNT,"RD")
"RTN","DGENELA1",247,0)
 .I DATA(.01) D
"RTN","DGENELA1",248,0)
 ..S DATA(2)=DGELG("RATEDIS",COUNT,"PER")
"RTN","DGENELA1",249,0)
 ..S DATA(3)=DGELG("RATEDIS",COUNT,"RDSC")
"RTN","DGENELA1",250,0)
 ..S DATA(4)=DGELG("RATEDIS",COUNT,"RDEXT")
"RTN","DGENELA1",251,0)
 ..S DATA(5)=DGELG("RATEDIS",COUNT,"RDORIG")
"RTN","DGENELA1",252,0)
 ..S DATA(6)=DGELG("RATEDIS",COUNT,"RDCURR")
"RTN","DGENELA1",253,0)
 ..I '$$ADD^DGENDBS(2.04,.DA,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILTIES",SUCCESS=0
"RTN","DGENELA1",254,0)
 Q SUCCESS
"RTN","DGENELA4")
0^5^B73347795
"RTN","DGENELA4",1,0)
DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN,DLF,TDM,JLS - Patient Eligibility API ;5/10/11 12:03pm
"RTN","DGENELA4",2,0)
 ;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653,688,803,754,841,909**;Aug 13,1993;Build 32
"RTN","DGENELA4",3,0)
 ;
"RTN","DGENELA4",4,0)
 ;
"RTN","DGENELA4",5,0)
PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE) ;
"RTN","DGENELA4",6,0)
 ; Description: Used to compute the priority group and subgroup for a
"RTN","DGENELA4",7,0)
 ; patient, also returning the subset of the eligibility data on which 
"RTN","DGENELA4",8,0)
 ; the priority subgroup is based.
"RTN","DGENELA4",9,0)
 ;
"RTN","DGENELA4",10,0)
 ;Input:
"RTN","DGENELA4",11,0)
 ;      DFN - ien of patient
"RTN","DGENELA4",12,0)
 ;    DGELG - ELIGIBILITY object array (optional, pass by reference)
"RTN","DGENELA4",13,0)
 ;  ENRDATE - The Enrollment Date. This date is used in the priority
"RTN","DGENELA4",14,0)
 ;            determination only if the application date is not passed.
"RTN","DGENELA4",15,0)
 ;  APPDATE - The Enrollment Application Date.  This date is used
"RTN","DGENELA4",16,0)
 ;            to determine the priority. If the application date
"RTN","DGENELA4",17,0)
 ;            is not passed then the enrollment date (ENRDATE) is used.
"RTN","DGENELA4",18,0)
 ;
"RTN","DGENELA4",19,0)
 ;Output:
"RTN","DGENELA4",20,0)
 ;  Function Value - returns the priority and subgroup computed by the
"RTN","DGENELA4",21,0)
 ;    function as a 2 piece string 'PRIORITY^SUBGROUP'
"RTN","DGENELA4",22,0)
 ;  DGELGSUB - this local array will contain the eligibility data on
"RTN","DGENELA4",23,0)
 ;    which the priority determination was based, pass by reference
"RTN","DGENELA4",24,0)
 ;    if needed.
"RTN","DGENELA4",25,0)
 ;
"RTN","DGENELA4",26,0)
 N CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
"RTN","DGENELA4",27,0)
 K DGELGSUB S DGELGSUB=""
"RTN","DGENELA4",28,0)
 S (HICODE,HIPRI,SUBGRP,HISUB)=""
"RTN","DGENELA4",29,0)
 D
"RTN","DGENELA4",30,0)
 .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q  ;cannot proceed with eligibility
"RTN","DGENELA4",31,0)
 .; can't proceed without an Enrollment Date or Application Date
"RTN","DGENELA4",32,0)
 .I '$G(ENRDATE),'$G(APPDATE) Q
"RTN","DGENELA4",33,0)
 .I $$GET^DGENPTA(DFN,.DGPAT)
"RTN","DGENELA4",34,0)
 .; determine priority/subgroup based on primary eligibility
"RTN","DGENELA4",35,0)
 .S HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
"RTN","DGENELA4",36,0)
 .S PRIORITY=$$PRI(HICODE,.DGELG,$G(ENRDATE),$G(APPDATE))
"RTN","DGENELA4",37,0)
 .S HIPRI=$P(PRIORITY,"^"),HISUB=$P(PRIORITY,"^",2)
"RTN","DGENELA4",38,0)
 .S CODE=""
"RTN","DGENELA4",39,0)
 .;
"RTN","DGENELA4",40,0)
 .; determine if other eligibilities result in higher priority/subgroup
"RTN","DGENELA4",41,0)
 .F  S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:('CODE!(HIPRI=1))  D
"RTN","DGENELA4",42,0)
 ..S PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$G(ENRDATE),$G(APPDATE))
"RTN","DGENELA4",43,0)
 ..S PRI=$P(PRIORITY,"^"),SUB=$P(PRIORITY,"^",2)
"RTN","DGENELA4",44,0)
 ..S:((PRI>0)&((PRI<HIPRI)!(HIPRI=""))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
"RTN","DGENELA4",45,0)
 ..S:((PRI=HIPRI)&((SUB>0)&(SUB<HISUB))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
"RTN","DGENELA4",46,0)
 .;
"RTN","DGENELA4",47,0)
 .;set the DGELGSUB() array with the eligibility information used in the
"RTN","DGENELA4",48,0)
 .;priority determination
"RTN","DGENELA4",49,0)
 .S DGELGSUB("CODE")=HICODE,DGELGSUB("SC")=DGELG("SC"),DGELGSUB("SCPER")=DGELG("SCPER"),DGELGSUB("POW")=DGELG("POW"),DGELGSUB("A&A")=DGELG("A&A"),DGELGSUB("HB")=DGELG("HB")
"RTN","DGENELA4",50,0)
 .S DGELGSUB("VAPEN")=DGELG("VAPEN"),DGELGSUB("VACKAMT")=DGELG("VACKAMT"),DGELGSUB("DISRET")=DGELG("DISRET"),DGELGSUB("DISLOD")=DGELG("DISLOD")
"RTN","DGENELA4",51,0)
 .S DGELGSUB("MEDICAID")=DGELG("MEDICAID"),DGELGSUB("AO")=DGELG("AO"),DGELGSUB("IR")=DGELG("IR"),DGELGSUB("EC")=DGELG("EC"),DGELGSUB("MTSTA")=DGELG("MTSTA")
"RTN","DGENELA4",52,0)
 .;Purple Heart Added to DGELGSUB
"RTN","DGENELA4",53,0)
 .S DGELGSUB("VCD")=DGELG("VCD"),DGELGSUB("PH")=DGELG("PH")
"RTN","DGENELA4",54,0)
 .;Added for HVE Phase III (DG*5.3*564)
"RTN","DGENELA4",55,0)
 .S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("CVELEDT")=DGELG("CVELEDT"),DGELGSUB("SHAD")=DGELG("SHAD")
"RTN","DGENELA4",56,0)
 .;added dg*5.3*659
"RTN","DGENELA4",57,0)
 .S DGELGSUB("RADEXPM")=DGELG("RADEXPM")
"RTN","DGENELA4",58,0)
 .S DGELGSUB("AOEXPLOC")=DGELG("AOEXPLOC")
"RTN","DGENELA4",59,0)
 .S DGELGSUB("MOH")=DGELG("MOH")
"RTN","DGENELA4",60,0)
 .S DGELGSUB("CLE")=DGELG("CLE")         ;added with DG*5.3*909
"RTN","DGENELA4",61,0)
 .S DGELGSUB("CLEDT")=DGELG("CLEDT")     ;added with DG*5.3*909
"RTN","DGENELA4",62,0)
 .S DGELGSUB("CLEST")=DGELG("CLEST")     ;added with DG*5.3*909
"RTN","DGENELA4",63,0)
 .S DGELGSUB("CLESOR")=DGELG("CLESOR")   ;added with DG*5.3*909
"RTN","DGENELA4",64,0)
 .I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)=""
"RTN","DGENELA4",65,0)
 ;
"RTN","DGENELA4",66,0)
 Q HIPRI_$S(HIPRI:"^"_HISUB,1:"")
"RTN","DGENELA4",67,0)
 ;
"RTN","DGENELA4",68,0)
 ;
"RTN","DGENELA4",69,0)
PRI(CODE,DGELG,ENRDATE,APPDATE) ;
"RTN","DGENELA4",70,0)
 ; Description: Returns the priority group and subgroup based on a
"RTN","DGENELA4",71,0)
 ; single eligibility code.
"RTN","DGENELA4",72,0)
 ;Input -
"RTN","DGENELA4",73,0)
 ;  CODE - pointer to file #8.1, MAS Eligibility Code
"RTN","DGENELA4",74,0)
 ;  DGELG - local array obtained by calling $$GET, pass by reference
"RTN","DGENELA4",75,0)
 ;  ENRDATE - The Enrollment Date. This date is used in the priority
"RTN","DGENELA4",76,0)
 ;            determination only if the application date is not passed.
"RTN","DGENELA4",77,0)
 ;  APPDATE - The Enrollment Application Date.  This date is used
"RTN","DGENELA4",78,0)
 ;            to determine the priority. If the application date
"RTN","DGENELA4",79,0)
 ;            is not passed then the enrollment date (ENRDATE) is used.
"RTN","DGENELA4",80,0)
 ;
"RTN","DGENELA4",81,0)
 ;Output -
"RTN","DGENELA4",82,0)
 ;  Function Value - returns the priority and subgroup computed by the
"RTN","DGENELA4",83,0)
 ;   function as a 2 piece string 'PRIORITY^SUBGROUP'
"RTN","DGENELA4",84,0)
 ;
"RTN","DGENELA4",85,0)
 N CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR,STAEXP
"RTN","DGENELA4",86,0)
 N NODE2,DGNCM,DGNETW,DGMEDEX,DGEDEX,DGASSTS,DGMTYR,MTTEST1,MTTEST2
"RTN","DGENELA4",87,0)
 S SUBGRP=""
"RTN","DGENELA4",88,0)
 ;
"RTN","DGENELA4",89,0)
 ; use the Application Date when determining the priority, otherwise use
"RTN","DGENELA4",90,0)
 ; the Enrollment Date (ESP DG*5,3*491)
"RTN","DGENELA4",91,0)
 S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE))
"RTN","DGENELA4",92,0)
 ;
"RTN","DGENELA4",93,0)
 ;get the name of the national eligibility code
"RTN","DGENELA4",94,0)
 S CODENAME=$$CODENAME^DGENELA(CODE)
"RTN","DGENELA4",95,0)
 ;
"RTN","DGENELA4",96,0)
 ;get the means test code
"RTN","DGENELA4",97,0)
 S MTSTA=""
"RTN","DGENELA4",98,0)
 I DGELG("MTSTA") S MTSTA=$P($G(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
"RTN","DGENELA4",99,0)
 ;
"RTN","DGENELA4",100,0)
 ;get MT and GMT thresholds
"RTN","DGENELA4",101,0)
 S DGMTI=$P($$LST^DGMTU(DFN),"^")
"RTN","DGENELA4",102,0)
 S MTTHR=$$GET1^DIQ(408.31,+DGMTI,.12,"I")
"RTN","DGENELA4",103,0)
 S GMTTHR=$$GET1^DIQ(408.31,+DGMTI,.27,"I")
"RTN","DGENELA4",104,0)
 S DGNCM=$$GET1^DIQ(408.31,+DGMTI,.04,"I")
"RTN","DGENELA4",105,0)
 S DGNETW=$$GET1^DIQ(408.31,+DGMTI,.05,"I")
"RTN","DGENELA4",106,0)
 D ALL^DGMTU21(DFN,"V",DT,"I",+DGMTI)
"RTN","DGENELA4",107,0)
 S DGAICM=0
"RTN","DGENELA4",108,0)
 S:$G(DGINC("V")) DGAICM=+DGINC("V")
"RTN","DGENELA4",109,0)
 S (DGMEDEX,DGEDEX,DGASSTS)=0
"RTN","DGENELA4",110,0)
 S DGMTYR=$$GET1^DIQ(408.21,+DGAICM,.01,"E")
"RTN","DGENELA4",111,0)
 I $D(^DGMT(408.21,DGAICM,2))  D
"RTN","DGENELA4",112,0)
 .S NODE2=^DGMT(408.21,DGAICM,2)
"RTN","DGENELA4",113,0)
 .S DGASSTS=DGASSTS+$P(NODE2,U,1)+$P(NODE2,U,2)+$P(NODE2,U,3)+$P(NODE2,U,4)-$P(NODE2,U,5)
"RTN","DGENELA4",114,0)
 .S DGASSTS=DGASSTS+$P(NODE2,U,6)+$P(NODE2,U,7)+$P(NODE2,U,8)+$P(NODE2,U,9)
"RTN","DGENELA4",115,0)
 S:$D(^DGMT(408.21,DGAICM,1)) DGMEDEX=$P(^DGMT(408.21,DGAICM,1),"^",12)
"RTN","DGENELA4",116,0)
 S:$D(^DGMT(408.21,DGAICM,1)) DGEDEX=$P(^DGMT(408.21,DGAICM,1),"^",3)
"RTN","DGENELA4",117,0)
 ;
"RTN","DGENELA4",118,0)
 ; get expiration dates for Special Treatment Authority
"RTN","DGENELA4",119,0)
 S STAEXP("AO")=$$STAEXP^DGENELA4("AO")
"RTN","DGENELA4",120,0)
 S STAEXP("EC")=$$STAEXP^DGENELA4("EC")
"RTN","DGENELA4",121,0)
 ;
"RTN","DGENELA4",122,0)
 ;get the Enrollment Group Threshold (EGT) setting
"RTN","DGENELA4",123,0)
 S DGEGT=""
"RTN","DGENELA4",124,0)
 I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
"RTN","DGENELA4",125,0)
 I '$G(DGELG("RADEXPM")) S DGELG("RADEXPM")=""
"RTN","DGENELA4",126,0)
 I '$G(DGELG("SHAD")) S DGELG("SHAD")=""
"RTN","DGENELA4",127,0)
 ;
"RTN","DGENELA4",128,0)
 D  ;drops out when priority determined
"RTN","DGENELA4",129,0)
 .S PRIORITY=""
"RTN","DGENELA4",130,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q
"RTN","DGENELA4",131,0)
 .I (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMPLOY")="Y")&(DGELG("VACKAMT")>0)&(DGELG("VAPEN")'="Y")&(DGELG("A&A")'="Y")&(DGELG("HB")'="Y") S PRIORITY=1 Q
"RTN","DGENELA4",132,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q
"RTN","DGENELA4",133,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>9)&(CODENAME="SC LESS THAN 50%"))!(DGELG("POW")="Y")!(CODENAME="PRISONER OF WAR")!(DGELG("DISRET")=1)!(DGELG("DISLOD")=1)!(CODENAME="PURPLE HEART RECIPIENT")!(DGELG("PH")="Y") S PRIORITY=3 Q
"RTN","DGENELA4",134,0)
 .I DGELG("MOH")="Y" S PRIORITY=3 Q   ;Added for DG*5.3*841
"RTN","DGENELA4",135,0)
 .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q
"RTN","DGENELA4",136,0)
 .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q
"RTN","DGENELA4",137,0)
 .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1) S PRIORITY=6 Q
"RTN","DGENELA4",138,0)
 .I DGELG("EC")="Y" I (STAEXP("EC")<1)!($$DT^XLFDT<STAEXP("EC")) S PRIORITY=6 Q
"RTN","DGENELA4",139,0)
 .I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
"RTN","DGENELA4",140,0)
 .I (DGELG("AO")="Y"),(DGELG("AOEXPLOC"))="V" I (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO")) S PRIORITY=6 Q
"RTN","DGENELA4",141,0)
 .I DGELG("CLE")="Y" S PRIORITY=6 Q  ; Added for DG*5.3*909 Camp Lejeune
"RTN","DGENELA4",142,0)
 .I (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR)) S PRIORITY=7 D  Q
"RTN","DGENELA4",143,0)
 ..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
"RTN","DGENELA4",144,0)
 ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
"RTN","DGENELA4",145,0)
 .S MTTEST1=MTTHR
"RTN","DGENELA4",146,0)
 .I GMTTHR>MTTHR S MTTEST1=GMTTHR
"RTN","DGENELA4",147,0)
 .S MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01 ; Add 10% to the test threshold
"RTN","DGENELA4",148,0)
 .I $$SC^DGMTR(DFN),DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
"RTN","DGENELA4",149,0)
 .I $$SC^DGMTR(DFN),DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
"RTN","DGENELA4",150,0)
 .I DGELG("SC")="N",DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
"RTN","DGENELA4",151,0)
 .I DGELG("SC")="N",DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
"RTN","DGENELA4",152,0)
 .I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
"RTN","DGENELA4",153,0)
 .I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q
"RTN","DGENELA4",154,0)
 ;
"RTN","DGENELA4",155,0)
 Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"")
"RTN","DGENELA4",156,0)
 ;
"RTN","DGENELA4",157,0)
SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT
"RTN","DGENELA4",158,0)
 ;
"RTN","DGENELA4",159,0)
 N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X
"RTN","DGENELA4",160,0)
 Q:'$G(DFN)
"RTN","DGENELA4",161,0)
 S U="^"
"RTN","DGENELA4",162,0)
 S:$G(PRIORITY)="" PRIORITY=""
"RTN","DGENELA4",163,0)
 S:$G(SUBGRP)="" SUBGRP=""
"RTN","DGENELA4",164,0)
 D NOW^%DTC S TODAY=X
"RTN","DGENELA4",165,0)
 Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP  ;EGT isn't set
"RTN","DGENELA4",166,0)
 Q:TODAY<EGT("EFFDATE") SUBGRP  ;EGT is not in effect
"RTN","DGENELA4",167,0)
 I "^1^3^"[(U_EGT("TYPE")_U) Q SUBGRP
"RTN","DGENELA4",168,0)
 I EGT("TYPE")=2,(PRIORITY+(SUBGRP*.01))<(EGT("PRIORITY")+(EGT("SUBGRP")*.01)) Q SUBGRP
"RTN","DGENELA4",169,0)
 I EGT("TYPE")=4 Q:(PRIORITY<EGT("PRIORITY")) SUBGRP  Q:(PRIORITY>EGT("PRIORITY")) $$SUBCNV(SUBGRP)
"RTN","DGENELA4",170,0)
 ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP
"RTN","DGENELA4",171,0)
 S DGENRIEN=$$FINDCUR^DGENA(DFN)
"RTN","DGENELA4",172,0)
 I 'DGENRIEN,$G(ENRDATE),ENRDATE<EGT("EFFDATE") Q SUBGRP
"RTN","DGENELA4",173,0)
 S DONE=0
"RTN","DGENELA4",174,0)
 F  Q:DONE  D
"RTN","DGENELA4",175,0)
 .I 'DGENRIEN S DONE=2 Q
"RTN","DGENELA4",176,0)
 .I '$$GET^DGENA(DGENRIEN,.DGENRC) S DONE=2 Q
"RTN","DGENELA4",177,0)
 .S DGENRIEN=$$FINDPRI^DGENA(DGENRIEN)
"RTN","DGENELA4",178,0)
 .Q:DGENRC("STATUS")=6   ;deceased
"RTN","DGENELA4",179,0)
 .I $P($G(^DGEN(27.15,+DGENRC("STATUS"),0)),"^",2)="N" S DONE=2 Q
"RTN","DGENELA4",180,0)
 .S ENRDT=$G(DGENRC("APP")) S:'ENRDT ENRDT=$G(DGENRC("EFFDATE"))
"RTN","DGENELA4",181,0)
 .I ENRDT,ENRDT<EGT("EFFDATE") S DONE=1 Q
"RTN","DGENELA4",182,0)
 .; HEC is the authoritative source on continuous enrollment
"RTN","DGENELA4",183,0)
 .I $$OVRRIDE^DGENEGT1(DFN,.EGT) S DONE=1
"RTN","DGENELA4",184,0)
 ;
"RTN","DGENELA4",185,0)
 Q $S(DONE=2:$$SUBCNV(SUBGRP),1:SUBGRP)
"RTN","DGENELA4",186,0)
 ;
"RTN","DGENELA4",187,0)
SUBCNV(SUBGRP) ;return new subgrp
"RTN","DGENELA4",188,0)
 I SUBGRP=1 Q 5
"RTN","DGENELA4",189,0)
 I SUBGRP=3 Q 7
"RTN","DGENELA4",190,0)
 Q SUBGRP
"RTN","DGENELA4",191,0)
 ;
"RTN","DGENELA4",192,0)
STAEXP(STATYP) ;return expiration date for Special Treatment Authority (STA)
"RTN","DGENELA4",193,0)
 ;Input -
"RTN","DGENELA4",194,0)
 ;  STATYP - STA Type (Only AO & EC (SWAC) currently supported)
"RTN","DGENELA4",195,0)
 ;
"RTN","DGENELA4",196,0)
 ;Output -
"RTN","DGENELA4",197,0)
 ;  Function Value - returns the requested expiration date from the
"RTN","DGENELA4",198,0)
 ;                   MAS PARAMETERS file (#43), otherwise returns 0
"RTN","DGENELA4",199,0)
 ;
"RTN","DGENELA4",200,0)
 I STATYP="AO" Q +$P($G(^DG(43,1,"ENR")),U,1)  ;AO Exp Dt
"RTN","DGENELA4",201,0)
 I STATYP="EC" Q +$P($G(^DG(43,1,"ENR")),U,2)  ;EC (SWAC) Exp Dt
"RTN","DGENELA4",202,0)
 Q 0
"RTN","DGENL1")
0^10^B71896061
"RTN","DGENL1",1,0)
DGENL1 ;ALB/RMO,ISA/KWP,Zoltan,ALB/BRM,LBD,ERC,EG,CKN,BAJ,JLS - Patient Enrollment - Build List Area ;5/12/11 3:53pm
"RTN","DGENL1",2,0)
 ;;5.3;Registration;**121,147,232,266,343,564,672,659,653,688,838,841,909**;Aug 13,1993;Build 32
"RTN","DGENL1",3,0)
 ;
"RTN","DGENL1",4,0)
EN(DGARY,DFN,DGENRIEN,DGCNT) ;Entry point to build list area
"RTN","DGENL1",5,0)
 ; for patient enrollment and patient enrollment history
"RTN","DGENL1",6,0)
 ; Input  -- DGARY    Global array subscript
"RTN","DGENL1",7,0)
 ;           DFN      Patient IEN
"RTN","DGENL1",8,0)
 ;           DGENRIEN Enrollment IEN
"RTN","DGENL1",9,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGENL1",10,0)
 N DGENCAT,DGENR,DGLINE
"RTN","DGENL1",11,0)
 I DGENRIEN,$$GET^DGENA(DGENRIEN,.DGENR) ;set-up enrollment array
"RTN","DGENL1",12,0)
 S DGENCAT=$$CATEGORY^DGENA4(,$G(DGENR("STATUS")))  ;enrollment category
"RTN","DGENL1",13,0)
 S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
"RTN","DGENL1",14,0)
 S DGLINE=1,DGCNT=0
"RTN","DGENL1",15,0)
 D ENR(DGARY,DFN,.DGENR,.DGLINE,.DGCNT) ;enrollment
"RTN","DGENL1",16,0)
 D PF(DGARY,DFN,.DGENR,.DGLINE,.DGCNT) ;priority factors
"RTN","DGENL1",17,0)
 D HIS^DGENL2(DGARY,DFN,DGENRIEN,.DGLINE,.DGCNT) ;history
"RTN","DGENL1",18,0)
 Q
"RTN","DGENL1",19,0)
 ;
"RTN","DGENL1",20,0)
ENR(DGARY,DFN,DGENR,DGLINE,DGCNT) ;Enrollment 
"RTN","DGENL1",21,0)
 ; Input  -- DGARY    Global array subscript
"RTN","DGENL1",22,0)
 ;           DFN      Patient IEN
"RTN","DGENL1",23,0)
 ;           DGENR    Enrollment array
"RTN","DGENL1",24,0)
 ;           DGLINE   Line number
"RTN","DGENL1",25,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGENL1",26,0)
 N DGSTART
"RTN","DGENL1",27,0)
 ;
"RTN","DGENL1",28,0)
 S DGSTART=DGLINE ; starting line number
"RTN","DGENL1",29,0)
 D SET(DGARY,DGLINE,"Enrollment",31,IORVON,IORVOFF,,,,.DGCNT)
"RTN","DGENL1",30,0)
 ;
"RTN","DGENL1",31,0)
 ;Enrollment Date
"RTN","DGENL1",32,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",33,0)
 D SET(DGARY,DGLINE,"Enrollment Date: "_$S($G(DGENR("DATE")):$$EXT^DGENU("DATE",DGENR("DATE")),1:""),11,,,,,,.DGCNT)
"RTN","DGENL1",34,0)
 ;
"RTN","DGENL1",35,0)
 ;
"RTN","DGENL1",36,0)
 ;Enrollment End Date
"RTN","DGENL1",37,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",38,0)
 D SET(DGARY,DGLINE,"Enrollment End Date: "_$S($G(DGENR("END")):$$EXT^DGENU("END",DGENR("END")),1:""),7,,,,,,.DGCNT)
"RTN","DGENL1",39,0)
 ;
"RTN","DGENL1",40,0)
 ;Enrollment Application Date
"RTN","DGENL1",41,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",42,0)
 D SET(DGARY,DGLINE,"Application Date: "_$S($G(DGENR("APP")):$$EXT^DGENU("APP",DGENR("APP")),1:""),10,,,,,,.DGCNT)
"RTN","DGENL1",43,0)
 ;
"RTN","DGENL1",44,0)
 ;Source
"RTN","DGENL1",45,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",46,0)
 D SET(DGARY,DGLINE,"Source of Enrollment: "_$S($G(DGENR("SOURCE")):$$EXT^DGENU("SOURCE",DGENR("SOURCE")),1:""),6,,,,,,.DGCNT)
"RTN","DGENL1",47,0)
 ;
"RTN","DGENL1",48,0)
 ;Category
"RTN","DGENL1",49,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",50,0)
 D SET(DGARY,DGLINE,"Enrollment Category: "_DGENCAT,7,IORVON,IORVOFF,,,,.DGCNT)
"RTN","DGENL1",51,0)
 ;
"RTN","DGENL1",52,0)
 ;Status
"RTN","DGENL1",53,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",54,0)
 D SET(DGARY,DGLINE,"Enrollment Status: "_$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:""),9,,,,,,.DGCNT)
"RTN","DGENL1",55,0)
 ;
"RTN","DGENL1",56,0)
 ;Priority
"RTN","DGENL1",57,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",58,0)
 D SET(DGARY,DGLINE,"Enrollment Priority: "_$S($G(DGENR("PRIORITY")):DGENR("PRIORITY"),1:"")_$S($G(DGENR("SUBGRP")):$$EXT^DGENU("SUBGRP",DGENR("SUBGRP")),1:""),7,,,,,,.DGCNT)
"RTN","DGENL1",59,0)
 ;
"RTN","DGENL1",60,0)
 ;
"RTN","DGENL1",61,0)
 ;Effective date
"RTN","DGENL1",62,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",63,0)
 D SET(DGARY,DGLINE,"Effective Date: "_$S($G(DGENR("EFFDATE")):$$EXT^DGENU("EFFDATE",DGENR("EFFDATE")),1:""),12,,,,,,.DGCNT)
"RTN","DGENL1",64,0)
 ;
"RTN","DGENL1",65,0)
 ;Reason canceled/declined
"RTN","DGENL1",66,0)
 ; Removed blank line to fix format after screen header was increased
"RTN","DGENL1",67,0)
 ; to 3 lines (DG*5.3*838).
"RTN","DGENL1",68,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",69,0)
 D SET(DGARY,DGLINE,"Reason Canceled/Declined: "_$S($G(DGENR("REASON")):$$EXT^DGENU("REASON",DGENR("REASON")),1:""),2,,,,,,.DGCNT)
"RTN","DGENL1",70,0)
 ;
"RTN","DGENL1",71,0)
 ;Canceled/declined remarks
"RTN","DGENL1",72,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",73,0)
 D SET(DGARY,DGLINE,"Canceled/Declined Remarks: "_$S($G(DGENR("REASON"))'="":$$EXT^DGENU("REMARKS",DGENR("REMARKS")),1:""),1,,,,,,.DGCNT)
"RTN","DGENL1",74,0)
 ;
"RTN","DGENL1",75,0)
 ;Entered by
"RTN","DGENL1",76,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",77,0)
 D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",78,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",79,0)
 D SET(DGARY,DGLINE,"Entered By: "_$S($G(DGENR("USER")):$$EXT^DGENU("USER",DGENR("USER")),1:""),16,,,,,,.DGCNT)
"RTN","DGENL1",80,0)
 ;
"RTN","DGENL1",81,0)
 ;Date/time entered
"RTN","DGENL1",82,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",83,0)
 D SET(DGARY,DGLINE,"Date/Time Entered: "_$S($G(DGENR("DATETIME")):$$EXT^DGENU("DATETIME",DGENR("DATETIME")),1:""),9,,,,,,.DGCNT)
"RTN","DGENL1",84,0)
 ;
"RTN","DGENL1",85,0)
 ;Set line to start on next page
"RTN","DGENL1",86,0)
 F DGLINE=DGLINE+1:1:DGSTART+VALM("LINES") D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",87,0)
 Q
"RTN","DGENL1",88,0)
 ;
"RTN","DGENL1",89,0)
PF(DGARY,DFN,DGENR,DGLINE,DGCNT) ;Priority factors 
"RTN","DGENL1",90,0)
 ; Input  -- DGARY    Global array subscript
"RTN","DGENL1",91,0)
 ;           DFN      Patient IEN
"RTN","DGENL1",92,0)
 ;           DGENR    Enrollment array
"RTN","DGENL1",93,0)
 ;           DGLINE   Line number
"RTN","DGENL1",94,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGENL1",95,0)
 N DGSTART
"RTN","DGENL1",96,0)
 ;
"RTN","DGENL1",97,0)
 S DGSTART=DGLINE ; starting line number
"RTN","DGENL1",98,0)
 D SET(DGARY,DGLINE,"Priority Factors",31,IORVON,IORVOFF,,,,.DGCNT)
"RTN","DGENL1",99,0)
 ;
"RTN","DGENL1",100,0)
 ;POW
"RTN","DGENL1",101,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",102,0)
 D SET(DGARY,DGLINE,"POW: "_$S($G(DGENR("ELIG","POW"))'="":$$EXT^DGENU("POW",DGENR("ELIG","POW")),1:""),19,,,,,,.DGCNT)
"RTN","DGENL1",103,0)
 ;
"RTN","DGENL1",104,0)
 ;Medal of Honor (DG*5.3*841)
"RTN","DGENL1",105,0)
 I $G(DGENR("ELIG","MOH"))="Y" D
"RTN","DGENL1",106,0)
 .D SET(DGARY,DGLINE,"Medal of Honor: YES",48,,,,,,.DGCNT)
"RTN","DGENL1",107,0)
 ;
"RTN","DGENL1",108,0)
 ;Purple Heart - added for patch 343;brm;10/23/00
"RTN","DGENL1",109,0)
 N PHDAT
"RTN","DGENL1",110,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",111,0)
 S PHDAT=$$PHEART(DFN,$G(DGENRIEN),$G(DGENR("DATETIME")))
"RTN","DGENL1",112,0)
 D SET(DGARY,DGLINE,"Purple Hrt: "_$P(PHDAT,U),12,,,,,,.DGCNT)
"RTN","DGENL1",113,0)
 D:$P(PHDAT,U)="YES" SET(DGARY,DGLINE,"Status: "_$P(PHDAT,U,2),32,,,,,,.DGCNT)
"RTN","DGENL1",114,0)
 D:$P(PHDAT,U)="NO" SET(DGARY,DGLINE,"Remarks: "_$P(PHDAT,U,3),31,,,,,,.DGCNT)
"RTN","DGENL1",115,0)
 ;
"RTN","DGENL1",116,0)
 ;Agent orange
"RTN","DGENL1",117,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",118,0)
 D SET(DGARY,DGLINE,"A/O Exp.: "_$S($G(DGENR("ELIG","AO"))'="":$$EXT^DGENU("AO",DGENR("ELIG","AO")),1:""),14,,,,,,.DGCNT)
"RTN","DGENL1",119,0)
 D SET(DGARY,DGLINE,"A/O Exp Loc: "_$S($G(DGENR("ELIG","AOEXPLOC"))'="":$$EXT^DGENU("AOEXPLOC",DGENR("ELIG","AOEXPLOC")),1:""),51,,,,,,.DGCNT)
"RTN","DGENL1",120,0)
 ;
"RTN","DGENL1",121,0)
 ;Ionizing radiation
"RTN","DGENL1",122,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",123,0)
 D SET(DGARY,DGLINE,"ION Rad.: "_$S($G(DGENR("ELIG","IR"))'="":$$EXT^DGENU("IR",DGENR("ELIG","IR")),1:""),14,,,,,,.DGCNT)
"RTN","DGENL1",124,0)
 ;
"RTN","DGENL1",125,0)
 ;Radiation Exposure Method
"RTN","DGENL1",126,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",127,0)
 D SET(DGARY,DGLINE,"Rad Exp Method: "_$S($G(DGENR("ELIG","RADEXPM"))'="":$$EXT^DGENU("RADEXPM",DGENR("ELIG","RADEXPM")),1:""),8,,,,,,.DGCNT)
"RTN","DGENL1",128,0)
 ;
"RTN","DGENL1",129,0)
 ;SW Asia Conditions - name change from Env con DG*5.3*688
"RTN","DGENL1",130,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",131,0)
 D SET(DGARY,DGLINE,"SW Asia Cond: "_$S($G(DGENR("ELIG","EC"))'="":$$EXT^DGENU("EC",DGENR("ELIG","EC")),1:""),10,,,,,,.DGCNT)
"RTN","DGENL1",132,0)
 ;
"RTN","DGENL1",133,0)
 ;Camp Lejeune Eligibility Indicator - new fields added with DG*5.3*909
"RTN","DGENL1",134,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",135,0)
 D SET(DGARY,DGLINE,"Camp Lejeune: "_$S($G(DGENR("ELIG","CLE"))'="":$$EXT^DGENU("CLE",DGENR("ELIG","CLE")),1:""),10,,,,,,.DGCNT)
"RTN","DGENL1",136,0)
 ;
"RTN","DGENL1",137,0)
 ;Military retirement - new fields added with DG*5.3*672
"RTN","DGENL1",138,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",139,0)
 S DGRET=$G(DGENR("ELIG","DISRET"))
"RTN","DGENL1",140,0)
 D SET(DGARY,DGLINE,"Mil Disab Retirement: "_$S($G(DGRET)=0:"NO",$G(DGRET)=1:"YES",$G(DGRET)=2:"YES",$G(DGRET)=3:"UNK",1:""),2,,,,,,.DGCNT)
"RTN","DGENL1",141,0)
 D SET(DGARY,DGLINE,"Dischrg Due to Disab: "_$S($G(DGENR("ELIG","DISLOD"))'="":$$EXT^DGENU("DISLOD",DGENR("ELIG","DISLOD")),1:""),42,,,,,,.DGCNT)
"RTN","DGENL1",142,0)
 ;
"RTN","DGENL1",143,0)
 ;Combat Vet End Date (added for DG*5.3*564 - HVE Phase III)
"RTN","DGENL1",144,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",145,0)
 D SET(DGARY,DGLINE,"Combat Vet End Date: "_$S($G(DGENR("ELIG","CVELEDT"))'="":$$EXT^DGENU("CVELEDT",DGENR("ELIG","CVELEDT")),1:""),3,,,,,,.DGCNT)
"RTN","DGENL1",146,0)
 ;
"RTN","DGENL1",147,0)
 ;Eligible for medicaid
"RTN","DGENL1",148,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",149,0)
 D SET(DGARY,DGLINE,"Eligible for MEDICAID: "_$S($G(DGENR("ELIG","MEDICAID"))'="":$$EXT^DGENU("MEDICAID",DGENR("ELIG","MEDICAID")),1:""),1,,,,,,.DGCNT)
"RTN","DGENL1",150,0)
 ;
"RTN","DGENL1",151,0)
 ;Service connected and percentage
"RTN","DGENL1",152,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",153,0)
 D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",154,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",155,0)
 D SET(DGARY,DGLINE,"Svc Connected: "_$S($G(DGENR("ELIG","SC"))'="":$$EXT^DGENU("SC",DGENR("ELIG","SC")),1:""),9,,,,,,.DGCNT)
"RTN","DGENL1",156,0)
 D SET(DGARY,DGLINE,"SC Percent: "_$S($G(DGENR("ELIG","SCPER"))'="":$$EXT^DGENU("SCPER",DGENR("ELIG","SCPER"))_"%",1:""),52,,,,,,.DGCNT)
"RTN","DGENL1",157,0)
 ;
"RTN","DGENL1",158,0)
 ;Aid & attendance and housebound
"RTN","DGENL1",159,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",160,0)
 D SET(DGARY,DGLINE,"Aid & Attendance: "_$S($G(DGENR("ELIG","A&A"))'="":$$EXT^DGENU("A&A",DGENR("ELIG","A&A")),1:""),6,,,,,,.DGCNT)
"RTN","DGENL1",161,0)
 D SET(DGARY,DGLINE,"Housebound: "_$S($G(DGENR("ELIG","HB"))'="":$$EXT^DGENU("HB",DGENR("ELIG","HB")),1:""),52,,,,,,.DGCNT)
"RTN","DGENL1",162,0)
 ;
"RTN","DGENL1",163,0)
 ;VA Pension
"RTN","DGENL1",164,0)
 ;Unemployable (added for DG*5.3*564 - HVE Phase III)
"RTN","DGENL1",165,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",166,0)
 D SET(DGARY,DGLINE,"VA Pension: "_$S($G(DGENR("ELIG","VAPEN"))'="":$$EXT^DGENU("VAPEN",DGENR("ELIG","VAPEN")),1:""),12,,,,,,.DGCNT)
"RTN","DGENL1",167,0)
 D SET(DGARY,DGLINE,"Unemployable: "_$S($G(DGENR("ELIG","UNEMPLOY"))'="":$$EXT^DGENU("UNEMPLOY",DGENR("ELIG","UNEMPLOY")),1:""),50,,,,,,.DGCNT)
"RTN","DGENL1",168,0)
 ;
"RTN","DGENL1",169,0)
 ;Total check amount
"RTN","DGENL1",170,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",171,0)
 D SET(DGARY,DGLINE,"Total Check Amount: "_$S($G(DGENR("ELIG","VACKAMT"))'="":$$EXT^DGENU("VACKAMT",DGENR("ELIG","VACKAMT")),1:""),4,,,,,,.DGCNT)
"RTN","DGENL1",172,0)
 ;
"RTN","DGENL1",173,0)
 ;PROJ 112/SHAD - DG*5.3*653
"RTN","DGENL1",174,0)
 I $G(DGENR("ELIG","SHAD"))=1 D
"RTN","DGENL1",175,0)
 .D SET(DGARY,DGLINE,"Proj 112/SHAD: "_$$EXT^DGENU("SHAD",DGENR("ELIG","SHAD")),49,,,,,,.DGCNT)
"RTN","DGENL1",176,0)
 ;
"RTN","DGENL1",177,0)
 ;Eligibility code
"RTN","DGENL1",178,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",179,0)
 D SET(DGARY,DGLINE,"Eligibility Code: "_$S($G(DGENR("ELIG","CODE"))'="":$$EXT^DGENU("CODE",DGENR("ELIG","CODE")),1:""),6,,,,,,.DGCNT)
"RTN","DGENL1",180,0)
 ;
"RTN","DGENL1",181,0)
 ;Means test
"RTN","DGENL1",182,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",183,0)
 D SET(DGARY,DGLINE,"Means Test Status: "_$S($G(DGENR("ELIG","MTSTA"))'="":$$EXT^DGENU("MTSTA",DGENR("ELIG","MTSTA")),1:""),5,,,,,,.DGCNT)
"RTN","DGENL1",184,0)
 ;
"RTN","DGENL1",185,0)
 ;Veteran Catastrophically Disabled
"RTN","DGENL1",186,0)
 S DGLINE=DGLINE+1
"RTN","DGENL1",187,0)
 D SET(DGARY,DGLINE,"Veteran CD Status: "_$S($G(DGENR("ELIG","VCD"))'="":$$EXT^DGENU("VCD",DGENR("ELIG","VCD")),1:""),5,,,,,,.DGCNT)
"RTN","DGENL1",188,0)
 ;
"RTN","DGENL1",189,0)
 ;Set line to start on next page
"RTN","DGENL1",190,0)
 F DGLINE=DGLINE+1:1:DGSTART+VALM("LINES") D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT)
"RTN","DGENL1",191,0)
 Q
"RTN","DGENL1",192,0)
 ;
"RTN","DGENL1",193,0)
SET(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGSUB,DGNUM,DGDATA,DGCNT) ; moved to
"RTN","DGENL1",194,0)
 ;DGENL2 as DGENL1 was getting too big
"RTN","DGENL1",195,0)
 I $G(DGCOL)']"" S DGCOL=""
"RTN","DGENL1",196,0)
 I $G(DGON)']"" S DGON=""
"RTN","DGENL1",197,0)
 I $G(DGOFF)']"" S DGOFF=""
"RTN","DGENL1",198,0)
 I $G(DGSUB)']"" S DGSUB=""
"RTN","DGENL1",199,0)
 I $G(DGNUM)']"" S DGNUM=""
"RTN","DGENL1",200,0)
 I $G(DGDATA)']"" S DGDATA=""
"RTN","DGENL1",201,0)
 D SET^DGENL2(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGSUB,DGNUM,DGDATA,.DGCNT)
"RTN","DGENL1",202,0)
 Q
"RTN","DGENL1",203,0)
PHEART(DFN,DGENRIEN,PHENRDT) ;move to DGENL2
"RTN","DGENL1",204,0)
 N PHI,PHST,PHRR,PHDAT
"RTN","DGENL1",205,0)
 S PHDAT=$$PHEART^DGENL2(DFN,$G(DGENRIEN),$G(DGENR("DATETIME")))
"RTN","DGENL1",206,0)
 S PHI=$P(PHDAT,U),PHST=$P(PHDAT,U,2),PHRR=$P(PHDAT,U,3)
"RTN","DGENL1",207,0)
 I ($G(PHI)]""!($G(PHST)]"")!($G(PHRR)]"")) Q $G(PHI)_"^"_$G(PHST)_"^"_$G(PHRR)
"RTN","DGENL1",208,0)
 Q ""
"RTN","DGENU")
0^2^B47398135
"RTN","DGENU",1,0)
DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN,ERC,TMK,PWC,TDM,JLS - Enrollment Utilities ;04/24/2006 9:20 AM
"RTN","DGENU",2,0)
 ;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653,688,536,838,841,909**;Aug 13,1993;Build 32
"RTN","DGENU",3,0)
 ;
"RTN","DGENU",4,0)
DISPLAY(DFN) ;
"RTN","DGENU",5,0)
 ;Description: Display status message, current enrollment and
"RTN","DGENU",6,0)
 ;     preferred facility information
"RTN","DGENU",7,0)
 ;Input:
"RTN","DGENU",8,0)
 ;  DFN - Patient IEN
"RTN","DGENU",9,0)
 ;  Output:     none
"RTN","DGENU",10,0)
 ;
"RTN","DGENU",11,0)
 N STATUS
"RTN","DGENU",12,0)
 S STATUS=$$STATUS^DGENA(DFN)
"RTN","DGENU",13,0)
 I 'STATUS W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
"RTN","DGENU",14,0)
 E  I STATUS=2 D
"RTN","DGENU",15,0)
 .W !!,"Patient is enrolled in the VA Patient Enrollment System..."
"RTN","DGENU",16,0)
 ; Purple Heart added status 21
"RTN","DGENU",17,0)
 E  I (STATUS=9)!(STATUS=1)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21) D
"RTN","DGENU",18,0)
 .W !!,"Application is pending for enrollment in the VA Patient Enrollment System..."
"RTN","DGENU",19,0)
 E  D
"RTN","DGENU",20,0)
 .W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
"RTN","DGENU",21,0)
 D CUR(DFN)
"RTN","DGENU",22,0)
 Q
"RTN","DGENU",23,0)
 ;
"RTN","DGENU",24,0)
CUR(DFN) ;
"RTN","DGENU",25,0)
 ;Description - displays current enrollment, category, enrollment
"RTN","DGENU",26,0)
 ;  group threshold, preferred facility and source designation
"RTN","DGENU",27,0)
 ;
"RTN","DGENU",28,0)
 N FACNAME,PREFAC,PFSRC,DGEGT,DGEGTIEN,DGENCAT,DGENR,IORVON,IORVOFF
"RTN","DGENU",29,0)
 I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR)
"RTN","DGENU",30,0)
 ;Get enrollment category
"RTN","DGENU",31,0)
 S DGENCAT=$$CATEGORY^DGENA4(DFN)
"RTN","DGENU",32,0)
 ;Display Category in reverse video
"RTN","DGENU",33,0)
 D REV
"RTN","DGENU",34,0)
 ;Get enrollment group threshold
"RTN","DGENU",35,0)
 S DGEGTIEN=$$FINDCUR^DGENEGT
"RTN","DGENU",36,0)
 S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
"RTN","DGENU",37,0)
 ;Preferred facility
"RTN","DGENU",38,0)
 S PREFAC=$$PREF^DGENPTA(DFN,.FACNAME)
"RTN","DGENU",39,0)
 ;Source Designation
"RTN","DGENU",40,0)
 S PFSRC=$$GET1^DIQ(2,DFN_",",27.03)
"RTN","DGENU",41,0)
 W !?3,"Enrollment Date",?35,": ",$S('$G(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE")))
"RTN","DGENU",42,0)
 W !?3,"Enrollment Application Date",?35,": ",$S('$G(DGENR("APP")):"-none-",1:$$EXT^DGENU("DATE",DGENR("APP")))
"RTN","DGENU",43,0)
 W !?3,IORVON,"Enrollment Category             : ",$S($G(DGENCAT)="":"-none-",1:$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)),IORVOFF
"RTN","DGENU",44,0)
 W !?3,"Enrollment Status",?35,": ",$S($G(DGENR("STATUS"))="":"-none-",1:$$EXT^DGENU("STATUS",DGENR("STATUS")))
"RTN","DGENU",45,0)
 W !?3,"Enrollment Priority",?35,": ",$S($G(DGENR("PRIORITY"))="":"-none-",1:DGENR("PRIORITY")),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT("SUBGRP",DGENR("SUBGRP")))
"RTN","DGENU",46,0)
 W !?3,"Preferred Facility",?35,": ",$S($G(FACNAME)'="":FACNAME,1:"-none-")
"RTN","DGENU",47,0)
 W !?3,"Preferred Facility Source",?35,": ",$S($G(PFSRC)'="":PFSRC,1:"-none-")
"RTN","DGENU",48,0)
 W !?3,"Enrollment Group Threshold",?35,": ",$S($G(DGEGT("PRIORITY"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"",$G(DGEGT("PRIORITY")))),$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"",$G(DGEGT("SUBGRP"))))
"RTN","DGENU",49,0)
 W !
"RTN","DGENU",50,0)
 Q
"RTN","DGENU",51,0)
REV ;Get variables to display text in reverse video
"RTN","DGENU",52,0)
 N X
"RTN","DGENU",53,0)
 S X="IORVON;IORVOFF"
"RTN","DGENU",54,0)
 D ENDR^%ZISS
"RTN","DGENU",55,0)
 Q
"RTN","DGENU",56,0)
PATID(DFN) ;
"RTN","DGENU",57,0)
 ;Description - Called by FileMan as an identifier for the Patient file.
"RTN","DGENU",58,0)
 ;Displays current enrollment status, priority, and preferred facility.
"RTN","DGENU",59,0)
 ;
"RTN","DGENU",60,0)
 ;Input:
"RTN","DGENU",61,0)
 ;  DFN - ien to Patient file
"RTN","DGENU",62,0)
 ;
"RTN","DGENU",63,0)
 N PREFAC,DGENR,OUTPUT
"RTN","DGENU",64,0)
 I '$$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR) D
"RTN","DGENU",65,0)
 .S OUTPUT="NO ENROLLMENT APPLICATION ON FILE "
"RTN","DGENU",66,0)
 E  D
"RTN","DGENU",67,0)
 .S OUTPUT=$E("PRIORITY:"_DGENR("PRIORITY")_"   ",1,12)_$E("STATUS:"_$$EXT^DGENU("STATUS",DGENR("STATUS"))_"         ",1,26)
"RTN","DGENU",68,0)
 S PREFAC=$$PREF^DGENPTA(DFN)
"RTN","DGENU",69,0)
 S:PREFAC OUTPUT=OUTPUT_"PREFERRED FACILITY:"_$P($G(^DIC(4,PREFAC,99)),"^")
"RTN","DGENU",70,0)
 I $G(IOM) I ($X#$G(IOM))<6 D
"RTN","DGENU",71,0)
 .D EN^DDIOL(OUTPUT,,"?($X+(10-($X#IOM)))")
"RTN","DGENU",72,0)
 E  D
"RTN","DGENU",73,0)
 .D EN^DDIOL(OUTPUT,,"!?10")
"RTN","DGENU",74,0)
 Q
"RTN","DGENU",75,0)
 ;
"RTN","DGENU",76,0)
EXT(SUB,VAL) ;
"RTN","DGENU",77,0)
 ;Description: Given the subscript used in the PATIENT ENROLLMENT array,
"RTN","DGENU",78,0)
 ;     and a field value, returns the external representation of the
"RTN","DGENU",79,0)
 ;     value, as defined in the fields output transform of the PATIENT
"RTN","DGENU",80,0)
 ;     ENROLLMENT file.
"RTN","DGENU",81,0)
 ;Input: 
"RTN","DGENU",82,0)
 ;  SUB - subscript in the array defined by the PATIENT ENROLLMENT object
"RTN","DGENU",83,0)
 ;  VAL - value of the PATIENT ENROLLMENT object attribute named by SUB
"RTN","DGENU",84,0)
 ;Output:
"RTN","DGENU",85,0)
 ;  Function Value - returns the external value of the attribute as
"RTN","DGENU",86,0)
 ;     defined by the PATIENT ENROLLMENT file
"RTN","DGENU",87,0)
 ;
"RTN","DGENU",88,0)
 Q:(($G(SUB)="")!($G(VAL)="")) ""
"RTN","DGENU",89,0)
 ;
"RTN","DGENU",90,0)
 N FLD
"RTN","DGENU",91,0)
 S FLD=$$FIELD(SUB)
"RTN","DGENU",92,0)
 ;
"RTN","DGENU",93,0)
 Q:(FLD="") ""
"RTN","DGENU",94,0)
 Q $$EXTERNAL^DILFD(27.11,FLD,"F",VAL)
"RTN","DGENU",95,0)
 ;
"RTN","DGENU",96,0)
FIELD(SUB) ;
"RTN","DGENU",97,0)
 ;Description: given a subscript in the enrollment array, returns the
"RTN","DGENU",98,0)
 ;     corresponding field number
"RTN","DGENU",99,0)
 N FLD S FLD=""
"RTN","DGENU",100,0)
 D  ;drops out of block once SUB is determined
"RTN","DGENU",101,0)
 .I SUB="APP" S FLD=.01 Q
"RTN","DGENU",102,0)
 .I SUB="DATE" S FLD=.1 Q
"RTN","DGENU",103,0)
 .I SUB="END" S FLD=.11 Q
"RTN","DGENU",104,0)
 .I SUB="DFN" S FLD=.02 Q
"RTN","DGENU",105,0)
 .I SUB="SOURCE" S FLD=.03 Q
"RTN","DGENU",106,0)
 .I SUB="STATUS" S FLD=.04 Q
"RTN","DGENU",107,0)
 .I SUB="REASON" S FLD=.05 Q
"RTN","DGENU",108,0)
 .I SUB="REMARKS" S FLD=25 Q
"RTN","DGENU",109,0)
 .I SUB="FACREC" S FLD=.06 Q
"RTN","DGENU",110,0)
 .I SUB="PRIORITY" S FLD=.07 Q
"RTN","DGENU",111,0)
 .I SUB="EFFDATE" S FLD=.08 Q
"RTN","DGENU",112,0)
 .I SUB="PRIORREC" S FLD=.09 Q
"RTN","DGENU",113,0)
 .I SUB="SUBGRP" S FLD=.12 Q
"RTN","DGENU",114,0)
 .I SUB="CODE" S FLD=50.01 Q
"RTN","DGENU",115,0)
 .I SUB="SC" S FLD=50.02 Q
"RTN","DGENU",116,0)
 .I SUB="SCPER" S FLD=50.03 Q
"RTN","DGENU",117,0)
 .I SUB="POW" S FLD=50.04 Q
"RTN","DGENU",118,0)
 .I SUB="A&A" S FLD=50.05 Q
"RTN","DGENU",119,0)
 .I SUB="HB" S FLD=50.06 Q
"RTN","DGENU",120,0)
 .I SUB="VAPEN" S FLD=50.07 Q
"RTN","DGENU",121,0)
 .I SUB="VACKAMT" S FLD=50.08 Q
"RTN","DGENU",122,0)
 .I SUB="DISRET" S FLD=50.09 Q
"RTN","DGENU",123,0)
 .I SUB="DISLOD" S FLD=50.2 Q  ;field added with DG*5.3*672
"RTN","DGENU",124,0)
 .I SUB="MEDICAID" S FLD=50.1 Q
"RTN","DGENU",125,0)
 .I SUB="AO" S FLD=50.11 Q
"RTN","DGENU",126,0)
 .I SUB="AOEXPLOC" S FLD=50.22 Q  ;field added with DG*5.3*688
"RTN","DGENU",127,0)
 .I SUB="IR" S FLD=50.12 Q
"RTN","DGENU",128,0)
 .I SUB="EC" S FLD=50.13 Q    ;name now SW Asia Con, was Env Con DG*5.3*688
"RTN","DGENU",129,0)
 .I SUB="MTSTA" S FLD=50.14 Q
"RTN","DGENU",130,0)
 .I SUB="VCD" S FLD=50.15 Q
"RTN","DGENU",131,0)
 .I SUB="PH" S FLD=50.16 Q
"RTN","DGENU",132,0)
 .I SUB="UNEMPLOY" S FLD=50.17 Q
"RTN","DGENU",133,0)
 .I SUB="CVELEDT" S FLD=50.18 Q
"RTN","DGENU",134,0)
 .I SUB="SHAD" S FLD=50.19 Q  ;field added with DG*5.3*653
"RTN","DGENU",135,0)
 .I SUB="MOH" S FLD=50.23 Q
"RTN","DGENU",136,0)
 .I SUB="CLE" S FLD=50.24 Q      ;field added with DG*5.3*909
"RTN","DGENU",137,0)
 .I SUB="CLEDT" S FLD=50.25 Q    ;field added with DG*5.3*909
"RTN","DGENU",138,0)
 .I SUB="CLEST" S FLD=50.26 Q    ;field added with DG*5.3*909
"RTN","DGENU",139,0)
 .I SUB="CLESOR" S FLD=50.27 Q   ;field added with DG*5.3*909
"RTN","DGENU",140,0)
 .I SUB="DATETIME" S FLD=75.01 Q
"RTN","DGENU",141,0)
 .I SUB="USER" S FLD=75.02 Q
"RTN","DGENU",142,0)
 .I SUB="RADEXPM" S FLD=76 Q
"RTN","DGENU",143,0)
 Q FLD
"RTN","DGENU",144,0)
 ;
"RTN","DGENU",145,0)
PROMPT(FILE,FIELD,DEFAULT,RESPONSE,REQUIRE,PRMPTNM) ;
"RTN","DGENU",146,0)
 ;Description: requests user to enter a single field value.
"RTN","DGENU",147,0)
 ;Input:
"RTN","DGENU",148,0)
 ;  FILE - the file #
"RTN","DGENU",149,0)
 ;  FIELD - the field #
"RTN","DGENU",150,0)
 ;  DEFAULT - default value, internal form
"RTN","DGENU",151,0)
 ;  REQUIRE - a flag, (+value)'=0 means to require a value to be
"RTN","DGENU",152,0)
 ;            entered and to return failure otherwise (optional)
"RTN","DGENU",153,0)
 ;  PRMPTNM - Optional
"RTN","DGENU",154,0)
 ;             0 - display field LABEL
"RTN","DGENU",155,0)
 ;             1 - Prompt field TITLE
"RTN","DGENU",156,0)
 ;Output:
"RTN","DGENU",157,0)
 ;  Function Value - 0 on failure, 1 on success
"RTN","DGENU",158,0)
 ;  RESPONSE - value entered by user, pass by reference
"RTN","DGENU",159,0)
 ;
"RTN","DGENU",160,0)
 Q:(('$G(FILE))!('$G(FIELD))) 0
"RTN","DGENU",161,0)
 S REQUIRE=$G(REQUIRE)
"RTN","DGENU",162,0)
 S PRMPTNM=$G(PRMPTNM)
"RTN","DGENU",163,0)
 N DIR,DA,QUIT,AGAIN
"RTN","DGENU",164,0)
 ;
"RTN","DGENU",165,0)
 S DIR(0)=FILE_","_FIELD_$S($G(REQUIRE):"",1:"O")_"AO"
"RTN","DGENU",166,0)
 I $G(DEFAULT)'="" DO
"RTN","DGENU",167,0)
 . S:+$G(PRMPTNM)=0 DIR("A")=$$GET1^DID(FILE,FIELD,"","LABEL")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
"RTN","DGENU",168,0)
 . S:+$G(PRMPTNM)>0 DIR("A")=$$GET1^DID(FILE,FIELD,"","TITLE")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
"RTN","DGENU",169,0)
 S QUIT=0
"RTN","DGENU",170,0)
 F  D  Q:QUIT
"RTN","DGENU",171,0)
 . D ^DIR
"RTN","DGENU",172,0)
 . I $D(DTOUT)!$D(DUOUT) S QUIT=1 Q
"RTN","DGENU",173,0)
 . I X="@" D  Q:AGAIN
"RTN","DGENU",174,0)
 . . S AGAIN=0
"RTN","DGENU",175,0)
 . . I 'REQUIRE,"Yy"'[$E($$YN^DGENCD1("  Are you sure")_"X") S AGAIN=1 Q
"RTN","DGENU",176,0)
 . . S RESPONSE="" ; This might trigger the "required" message below.
"RTN","DGENU",177,0)
 . E  I X="" S RESPONSE=$G(DEFAULT)
"RTN","DGENU",178,0)
 . E  S RESPONSE=$P(Y,"^")
"RTN","DGENU",179,0)
 . ;
"RTN","DGENU",180,0)
 . ; quit this loop if the user entered value OR value not required
"RTN","DGENU",181,0)
 . I RESPONSE'="" S QUIT=1 Q
"RTN","DGENU",182,0)
 . I 'REQUIRE S QUIT=1 Q
"RTN","DGENU",183,0)
 . W !,"This is a required response. Enter '^' to exit"
"RTN","DGENU",184,0)
 I $D(DTOUT)!$D(DUOUT) Q 0
"RTN","DGENU",185,0)
 Q 1
"RTN","DGENU",186,0)
 ;
"RTN","DGENU",187,0)
INST(VADUZ,VACHK) ;
"RTN","DGENU",188,0)
 ; Description: Determine the institution affiliation associated with a
"RTN","DGENU",189,0)
 ;              user.
"RTN","DGENU",190,0)
 ;
"RTN","DGENU",191,0)
 ;  Input:
"RTN","DGENU",192,0)
 ;     VADUZ =  array if passed by reference:
"RTN","DGENU",193,0)
 ;           VADUZ = DUZ
"RTN","DGENU",194,0)
 ;           VADUZ(2) =  
"RTN","DGENU",195,0)
 ;              o  if this value is null: DUZ(2) (institution affiliated
"RTN","DGENU",196,0)
 ;                    with user, prompted at Kernel sign-on)
"RTN","DGENU",197,0)
 ;              o  if value is not null: site to check as valid for the
"RTN","DGENU",198,0)
 ;                    user (Pointer to INSTITUTION (#4) file)
"RTN","DGENU",199,0)
 ; Output:
"RTN","DGENU",200,0)
 ;   Function Value - Returns pointer to the INSTITUTION (#4) file
"RTN","DGENU",201,0)
 ;    entry that is associated with the user, otherwise the pointer
"RTN","DGENU",202,0)
 ;    to the INSTITUTION (#4) file entry of the primary VA Medical
"RTN","DGENU",203,0)
 ;    Center division is returned.
"RTN","DGENU",204,0)
 ;
"RTN","DGENU",205,0)
 ;    VACHK = passed by reference, returned as:
"RTN","DGENU",206,0)
 ;         null if the value in VADUZ(2) is null
"RTN","DGENU",207,0)
 ;            0 if the value in VADUZ(2) is not null and is not a valid
"RTN","DGENU",208,0)
 ;              site for the user
"RTN","DGENU",209,0)
 ;            1 if the value in VADUZ(2) is not null and is a valid site
"RTN","DGENU",210,0)
 ;              for the user
"RTN","DGENU",211,0)
 ;
"RTN","DGENU",212,0)
 S VACHK=$S($G(VADUZ(2))="":"",1:0)
"RTN","DGENU",213,0)
 I $G(VADUZ(2)) D
"RTN","DGENU",214,0)
 . N X,ZZ
"RTN","DGENU",215,0)
 . Q:'$G(VADUZ)
"RTN","DGENU",216,0)
 . S X=$$DIV4^XUSER(.ZZ,VADUZ)
"RTN","DGENU",217,0)
 . I X,$D(ZZ(VADUZ(2))) S VACHK=1
"RTN","DGENU",218,0)
 I '$G(VADUZ(2)) S VADUZ(2)=$G(DUZ(2))
"RTN","DGENU",219,0)
 Q $S($G(VADUZ(2)):VADUZ(2),1:$P($$SITE^VASITE(),"^"))
"RTN","DGENU",220,0)
 ;
"RTN","DGENU",221,0)
GETINST(DGPREFAC,DGINST) ;Get Institution file data
"RTN","DGENU",222,0)
 ; Input  -- DGPREFAC Institution file IEN
"RTN","DGENU",223,0)
 ; Output -- 1=Successful and 0=Failure
"RTN","DGENU",224,0)
 ;           DGINST - Institution file Array
"RTN","DGENU",225,0)
 N DGINST0,DGINST99,DGOKF
"RTN","DGENU",226,0)
 S DGINST0=$G(^DIC(4,DGPREFAC,0)) G GETQ:DGINST0=""
"RTN","DGENU",227,0)
 S DGINST("NAME")=$P(DGINST0,U)
"RTN","DGENU",228,0)
 S DGINST99=$G(^DIC(4,DGPREFAC,99))
"RTN","DGENU",229,0)
 S DGINST("STANUM")=$P(DGINST99,U)
"RTN","DGENU",230,0)
 S DGOKF=1
"RTN","DGENU",231,0)
GETQ Q +$G(DGOKF)
"RTN","DGENUPL")
0^11^B47824624
"RTN","DGENUPL",1,0)
DGENUPL ;ALB/CJM,ISA,KWP,TDM,CKN,BAJ,LMD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;8/15/08 12:40pm
"RTN","DGENUPL",2,0)
 ;;5.3;REGISTRATION;**147,222,232,363,472,497,564,677,672,688,871,909**;Aug 13,1993;Build 32
"RTN","DGENUPL",3,0)
 ;
"RTN","DGENUPL",4,0)
 ;Phase II Moved Z11 to DGENUPL7
"RTN","DGENUPL",5,0)
ORUZ11(MSGIEN,ERRCOUNT) ;
"RTN","DGENUPL",6,0)
 ;Description:  This procedure is used to process a batch of ORU~Z11
"RTN","DGENUPL",7,0)
 ;messages or a single ORU~Z11 message. The processing consists of
"RTN","DGENUPL",8,0)
 ;uploading the patient enrollment and eligibility data.
"RTN","DGENUPL",9,0)
 ;
"RTN","DGENUPL",10,0)
 ;Input:
"RTN","DGENUPL",11,0)
 ;  MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file
"RTN","DGENUPL",12,0)
 ;Output:
"RTN","DGENUPL",13,0)
 ;  ERRCOUNT - count of messages that were not processed due to
"RTN","DGENUPL",14,0)
 ;    errors encountered  (pass by reference)
"RTN","DGENUPL",15,0)
 ;
"RTN","DGENUPL",16,0)
 N CURLINE,SSN,DOB,SEX,SEG,MSGID,DFN,ERRMSG,TMPARRY,ICN
"RTN","DGENUPL",17,0)
 ;
"RTN","DGENUPL",18,0)
 K ^TMP("IVM","HLS",$J)
"RTN","DGENUPL",19,0)
 ;
"RTN","DGENUPL",20,0)
 ;initialize HL7 variable
"RTN","DGENUPL",21,0)
 S HLSDT="IVMQ" ;location of error message
"RTN","DGENUPL",22,0)
 ;
"RTN","DGENUPL",23,0)
 S CURLINE=1
"RTN","DGENUPL",24,0)
 D ADVANCE(MSGIEN,.CURLINE)
"RTN","DGENUPL",25,0)
 Q:'CURLINE
"RTN","DGENUPL",26,0)
 F  Q:'CURLINE  D  D ADVANCE(MSGIEN,.CURLINE)
"RTN","DGENUPL",27,0)
 .D GETSEG(MSGIEN,CURLINE,.SEG)
"RTN","DGENUPL",28,0)
 .S MSHDT=SEG(7)
"RTN","DGENUPL",29,0)
 .S MSGID=SEG(10)
"RTN","DGENUPL",30,0)
 .D NXTSEG(MSGIEN,CURLINE,.SEG)
"RTN","DGENUPL",31,0)
 .I SEG("TYPE")'="PID" D ADDERROR(MSGID,,"PID SEGMENT MISSING",.ERRCOUNT) Q
"RTN","DGENUPL",32,0)
 .;S DFN=$$LOOKUP^DGENPTA(SEG(19),$$FMDATE^HLFNC(SEG(7)),SEG(8),.ERRMSG)
"RTN","DGENUPL",33,0)
 .M TMPARY(3)=SEG(3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
"RTN","DGENUPL",34,0)
 .S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
"RTN","DGENUPL",35,0)
 .K TMPARY,PID3ARY
"RTN","DGENUPL",36,0)
 .I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) D ADDERROR(MSGID,SEG(19),ERRMSG,.ERRCOUNT) Q
"RTN","DGENUPL",37,0)
 .;I 'DFN D ADDERROR(MSGID,SEG(19),ERRMSG,.ERRCOUNT) Q
"RTN","DGENUPL",38,0)
 .D Z11^DGENUPL7(MSGIEN,MSGID,.CURLINE,DFN,.ERRCOUNT)
"RTN","DGENUPL",39,0)
 S HLEVN=+$G(ERRCOUNT) ;# of events included in the reply
"RTN","DGENUPL",40,0)
 M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J)                     ;DG*5.3*472
"RTN","DGENUPL",41,0)
 K ^TMP("IVM","HLS",$J)
"RTN","DGENUPL",42,0)
 Q
"RTN","DGENUPL",43,0)
 ;
"RTN","DGENUPL",44,0)
ORFZ11(MSGIEN,MSGID) ;
"RTN","DGENUPL",45,0)
 ;Description:  This procedure is used to process an ORF~Z11 message
"RTN","DGENUPL",46,0)
 ;It uploads the patient enrollment and eligibility data.
"RTN","DGENUPL",47,0)
 ;An acknowledgment is returned.
"RTN","DGENUPL",48,0)
 ;
"RTN","DGENUPL",49,0)
 ;Input:
"RTN","DGENUPL",50,0)
 ;  MSGIEN - the internal entry number of the HL7 message in the HL7 MESSAGE TEXT file (772)
"RTN","DGENUPL",51,0)
 ;  MSGID - the message control id from the MSH segment
"RTN","DGENUPL",52,0)
 ;
"RTN","DGENUPL",53,0)
 ;Output: none
"RTN","DGENUPL",54,0)
 ;
"RTN","DGENUPL",55,0)
 N CURLINE,DFN,QUERYIEN,QARRAY,QRYMSGID,ERRCOUNT,HECERROR,SEG,DGRESENT
"RTN","DGENUPL",56,0)
 N TMPARRY,PID3ARRY,ICN
"RTN","DGENUPL",57,0)
 ;CURLINE tracks current line in the message
"RTN","DGENUPL",58,0)
 ;QUERYIEN  the ien of query in the ENROLLMENT QUERY LOG
"RTN","DGENUPL",59,0)
 ;QRYMSGID  the Message Control ID of the query
"RTN","DGENUPL",60,0)
 ;QARRAY  array containing the ENROLLMENT QUERY LOG record
"RTN","DGENUPL",61,0)
 ;HECERROR  error message returned by HEC in response to query
"RTN","DGENUPL",62,0)
 ;DGRESENT  flag=1 if query was resent
"RTN","DGENUPL",63,0)
 ;
"RTN","DGENUPL",64,0)
 S (QUERYIEN,ERRCOUNT)=0
"RTN","DGENUPL",65,0)
 ;
"RTN","DGENUPL",66,0)
 ;initialize HL7 variable
"RTN","DGENUPL",67,0)
 S HLSDT="IVMQ" ;subscript in ^TMP( global for ACK message
"RTN","DGENUPL",68,0)
 ;
"RTN","DGENUPL",69,0)
 K ^TMP("IVM","HLS",$J)
"RTN","DGENUPL",70,0)
 ;
"RTN","DGENUPL",71,0)
 S CURLINE=1
"RTN","DGENUPL",72,0)
 S HECERROR=""
"RTN","DGENUPL",73,0)
 D GETSEG(MSGIEN,CURLINE,.SEG)  ; DG*5.3*871
"RTN","DGENUPL",74,0)
 S MSHDT=SEG(7)                 ; DG*5.3*871
"RTN","DGENUPL",75,0)
 S MSGID=SEG(10)                ; DG*5.3*871
"RTN","DGENUPL",76,0)
 ;
"RTN","DGENUPL",77,0)
 D  ;drops out on error
"RTN","DGENUPL",78,0)
 .D NXTSEG(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL",79,0)
 .I SEG("TYPE")'="MSA" D ADDERROR(MSGID,,"MISSING MSA SEGMENT",.ERRCOUNT) Q
"RTN","DGENUPL",80,0)
 .;trace the reply back to the query
"RTN","DGENUPL",81,0)
 .S QRYMSGID=SEG(2)
"RTN","DGENUPL",82,0)
 .S QUERYIEN=$$FINDMSG^DGENQRY(QRYMSGID)
"RTN","DGENUPL",83,0)
 .I 'QUERYIEN D ADDERROR(MSGID,,"NO RECORD OF QUERY",.ERRCOUNT) Q
"RTN","DGENUPL",84,0)
 .I QUERYIEN,'$$GET^DGENQRY(QUERYIEN,.QARRAY) D ADDERROR(MSGID,,"NO RECORD OF QUERY",.ERRCOUNT) Q
"RTN","DGENUPL",85,0)
 .S DFN=QARRAY("DFN")
"RTN","DGENUPL",86,0)
 .I (SEG(1)="AR")!(SEG(1)="AE") D  Q
"RTN","DGENUPL",87,0)
 ..;HEC was unable to reply to the query. If due to incorrect patient
"RTN","DGENUPL",88,0)
 ..;info, then resend the query, otherwise just log it as unsuccessful
"RTN","DGENUPL",89,0)
 ..N SSN,DOB,SEX,DGPAT,HECMSG
"RTN","DGENUPL",90,0)
 ..S HECMSG=SEG(3)
"RTN","DGENUPL",91,0)
 ..D NXTSEG(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL",92,0)
 ..Q:(SEG("TYPE")'="QRD")
"RTN","DGENUPL",93,0)
 ..S SSN=SEG(8)
"RTN","DGENUPL",94,0)
 ..D NXTSEG(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL",95,0)
 ..Q:(SEG("TYPE")'="QRF")
"RTN","DGENUPL",96,0)
 ..S DOB=$$FMDATE^HLFNC(SEG(4))
"RTN","DGENUPL",97,0)
 ..S SEX=SEG(5)
"RTN","DGENUPL",98,0)
 ..;if patient id info incorrect, resend the query
"RTN","DGENUPL",99,0)
 ..I $$GET^DGENPTA(DFN,.DGPAT),((DOB'=DGPAT("DOB"))!(SEX'=DGPAT("SEX"))) I $$RESEND^DGENQRY1(QUERYIEN) S DGRESENT=1 Q
"RTN","DGENUPL",100,0)
 ..S HECERROR="HEC UNABLE TO RESPOND TO QUERY- "_HECMSG Q
"RTN","DGENUPL",101,0)
 .;
"RTN","DGENUPL",102,0)
 .F SEG="QRD","QRF" D NXTSEG(MSGIEN,.CURLINE,.SEG) I SEG("TYPE")'=SEG D ADDERROR(MSGID,,SEG_" SEGMENT MISSING",.ERRCOUNT) Q
"RTN","DGENUPL",103,0)
 .S SEG="PID" D NXTSEG(MSGIEN,CURLINE,.SEG) I SEG("TYPE")'=SEG D ADDERROR(MSGID,,SEG_" SEGMENT MISSING",.ERRCOUNT) Q
"RTN","DGENUPL",104,0)
 .;S CURLINE=CURLINE-1 ;should point to line before PID
"RTN","DGENUPL",105,0)
 .;I $$SSN^DGENPTA(DFN)'=SEG(19) D ADDERROR(MSGID,,"SSN DOES NOT MATCH",.ERRCOUNT) Q
"RTN","DGENUPL",106,0)
 .M TMPARY(3)=SEG(3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
"RTN","DGENUPL",107,0)
 .S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
"RTN","DGENUPL",108,0)
 .K TMPARY,PID3ARY
"RTN","DGENUPL",109,0)
 .I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) D ADDERROR(MSGID,,ERRMSG,.ERRCOUNT) Q
"RTN","DGENUPL",110,0)
 .D Z11^DGENUPL7(MSGIEN,MSGID,.CURLINE,DFN,.ERRCOUNT)
"RTN","DGENUPL",111,0)
 ;
"RTN","DGENUPL",112,0)
 ;update the query log
"RTN","DGENUPL",113,0)
 I $G(HECERROR)="",ERRCOUNT S HECERROR="UPLOAD FAILED DUE TO CONSISTENCY CHECKS"
"RTN","DGENUPL",114,0)
 I '$G(DGRESENT),$$RECEIVE^DGENQRY1(QUERYIEN,HECERROR,MSGID)
"RTN","DGENUPL",115,0)
 ;
"RTN","DGENUPL",116,0)
 S HLEVN=+$G(ERRCOUNT) ;# of events included in the reply
"RTN","DGENUPL",117,0)
 ;
"RTN","DGENUPL",118,0)
 ;if there was no error, create an 'AA' ack
"RTN","DGENUPL",119,0)
 ;I 'ERRCOUNT D ACCEPT^DGENUPL1(MSGID)                  ;DG*5.3*472
"RTN","DGENUPL",120,0)
 ;D MVERRORS^DGENUPL1                                   ;DG*5.3*472
"RTN","DGENUPL",121,0)
 ;transmit the ack
"RTN","DGENUPL",122,0)
 ;********************************************************
"RTN","DGENUPL",123,0)
 ;7.12.01;KSD; COMMENTED OUT. DON'T SEND ACK TO ORF
"RTN","DGENUPL",124,0)
 ;I $D(HLTRANS) S HLARYTYP="GB",HLFORMAT=1 D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESLTA,HLMTIEN)
"RTN","DGENUPL",125,0)
 ;
"RTN","DGENUPL",126,0)
 Q
"RTN","DGENUPL",127,0)
 ;
"RTN","DGENUPL",128,0)
ADDERROR(MSGID,SSN,ERRMSG,ERRCOUNT) ;
"RTN","DGENUPL",129,0)
 ;Description - writes an error message to a global. It will be
"RTN","DGENUPL",130,0)
 ;transmitted in the ack later.
"RTN","DGENUPL",131,0)
 ;
"RTN","DGENUPL",132,0)
 ;Inputs:
"RTN","DGENUPL",133,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL",134,0)
 ;  SSN - patient social security number
"RTN","DGENUPL",135,0)
 ;  ERRMSG - the error message
"RTN","DGENUPL",136,0)
 ;  ERRCOUNT - count of errors written so far
"RTN","DGENUPL",137,0)
 ;
"RTN","DGENUPL",138,0)
 ;Outputs: none
"RTN","DGENUPL",139,0)
 ;
"RTN","DGENUPL",140,0)
 S ERRCOUNT=+$G(ERRCOUNT)
"RTN","DGENUPL",141,0)
 ;
"RTN","DGENUPL",142,0)
 I (ERRCOUNT*2)+1=1 D
"RTN","DGENUPL",143,0)
 . K HL,HLMID,HLMTIEN,HLDT,HLDT1
"RTN","DGENUPL",144,0)
 . D INIT^HLFNC2(HLEID,.HL)
"RTN","DGENUPL",145,0)
 . D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
"RTN","DGENUPL",146,0)
 K HLRES
"RTN","DGENUPL",147,0)
 S MID=HLMID_"-"_((ERRCOUNT*2)+1)
"RTN","DGENUPL",148,0)
 D MSH^HLFNC2(.HL,MID,.HLRES)
"RTN","DGENUPL",149,0)
 S ^TMP("IVM","HLS",$J,(ERRCOUNT*2)+1)=HLRES
"RTN","DGENUPL",150,0)
 S ^TMP("IVM","HLS",$J,(ERRCOUNT*2)+2)="MSA"_HLFS_"AE"_HLFS_MSGID_HLFS_ERRMSG_" - SSN "_$S($L($G(SSN)):SSN,1:"NOT FOUND")
"RTN","DGENUPL",151,0)
 S ERRCOUNT=ERRCOUNT+1
"RTN","DGENUPL",152,0)
 ;Put in error message in HECERROR to be included in the NOTIFY message for a solicited query
"RTN","DGENUPL",153,0)
 I $D(HECERROR) S HECERROR=ERRMSG
"RTN","DGENUPL",154,0)
 Q
"RTN","DGENUPL",155,0)
 ;
"RTN","DGENUPL",156,0)
NXTSEG(MSGIEN,CURLINE,SEG) ;
"RTN","DGENUPL",157,0)
 ;Description: Returns the next segment
"RTN","DGENUPL",158,0)
 ;
"RTN","DGENUPL",159,0)
 ;Input:
"RTN","DGENUPL",160,0)
 ;  MSGIEN - ien in HL7 MESSAGE TEXT file
"RTN","DGENUPL",161,0)
 ;  CURLINE - subscript of the current segment
"RTN","DGENUPL",162,0)
 ;
"RTN","DGENUPL",163,0)
 ;Output:
"RTN","DGENUPL",164,0)
 ;  SEG - an array with the fields of the segment (pass by reference)
"RTN","DGENUPL",165,0)
 ;  CURLINE - upon exiting, will be the subscript of the next segment
"RTN","DGENUPL",166,0)
 ;
"RTN","DGENUPL",167,0)
 S CURLINE=CURLINE+1
"RTN","DGENUPL",168,0)
 D GETSEG(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL",169,0)
 Q
"RTN","DGENUPL",170,0)
 ;
"RTN","DGENUPL",171,0)
GETSEG(MSGIEN,CURLINE,SEG) ;
"RTN","DGENUPL",172,0)
 ;returns the current segment
"RTN","DGENUPL",173,0)
 ;
"RTN","DGENUPL",174,0)
 ;Input:
"RTN","DGENUPL",175,0)
 ;  MSGIEN - ien in HL7 MESSAGE TEXT file
"RTN","DGENUPL",176,0)
 ;  CURLINE - subscript of the current segment
"RTN","DGENUPL",177,0)
 ;
"RTN","DGENUPL",178,0)
 ;Output:
"RTN","DGENUPL",179,0)
 ;  SEG - an array with the fields of the segment (pass by reference)
"RTN","DGENUPL",180,0)
 ;
"RTN","DGENUPL",181,0)
 N SEGMENT,I,CNTR,NOPID,PIDSTR,IVMPID,SEGHLD,CNTR2
"RTN","DGENUPL",182,0)
 I $G(SEG)'="" S SEGHLD=SEG
"RTN","DGENUPL",183,0)
 K SEG
"RTN","DGENUPL",184,0)
 S SEG=$G(SEGHLD)
"RTN","DGENUPL",185,0)
 S CNTR=1,NOPID=0
"RTN","DGENUPL",186,0)
 S:$G(HLFS)="" HLFS=$G(HL("FS")) S:HLFS="" HLFS="^"
"RTN","DGENUPL",187,0)
 S SEGMENT=$G(^TMP($J,IVMRTN,CURLINE,0))
"RTN","DGENUPL",188,0)
 S SEG("TYPE")=$E(SEGMENT,1,3)
"RTN","DGENUPL",189,0)
 ;Strip double quotes from the following segments.  DG*5.3*688
"RTN","DGENUPL",190,0)
 I SEG("TYPE")="ZRD" D
"RTN","DGENUPL",191,0)
 .S SEGMENT=$$CLEARF^IVMPRECA(SEGMENT,HLFS)
"RTN","DGENUPL",192,0)
 I SEG("TYPE")="PID" D  Q
"RTN","DGENUPL",193,0)
 .S PIDSTR(CNTR)=$P(SEGMENT,HLFS,2,99)
"RTN","DGENUPL",194,0)
 .F I=1:1 D  Q:NOPID
"RTN","DGENUPL",195,0)
 ..S CURLINE=CURLINE+1,SEGMENT=$G(^TMP($J,IVMRTN,CURLINE,0))
"RTN","DGENUPL",196,0)
 ..I $E(SEGMENT,1,4)="ZPD^" S NOPID=1,CURLINE=CURLINE-1 Q
"RTN","DGENUPL",197,0)
 ..S CNTR=CNTR+1,PIDSTR(CNTR)=SEGMENT
"RTN","DGENUPL",198,0)
 .D BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
"RTN","DGENUPL",199,0)
 .;convert "" to null for PID segment
"RTN","DGENUPL",200,0)
 .S CNTR="" F  S CNTR=$O(IVMPID(CNTR)) Q:CNTR=""  D
"RTN","DGENUPL",201,0)
 ..I $O(IVMPID(CNTR,"")) D  Q
"RTN","DGENUPL",202,0)
 ...S CNTR2="" F  S CNTR2=$O(IVMPID(CNTR,CNTR2)) Q:CNTR2=""  D
"RTN","DGENUPL",203,0)
 ....S IVMPID(CNTR,CNTR2)=$$CLEARF^IVMPRECA(IVMPID(CNTR,CNTR2),$E(HLECH))
"RTN","DGENUPL",204,0)
 ..I IVMPID(CNTR)="""""" S IVMPID(CNTR)=""
"RTN","DGENUPL",205,0)
 .M SEG=IVMPID
"RTN","DGENUPL",206,0)
 ;
"RTN","DGENUPL",207,0)
 ;the MSH & BHS segs contain as their first piece the field separator, which makes breaking the segment into fields a bit different
"RTN","DGENUPL",208,0)
 I (SEG("TYPE")="MSH")!(SEG("TYPE")="BHS") D
"RTN","DGENUPL",209,0)
 .S SEG(1)=$E(SEGMENT,4)
"RTN","DGENUPL",210,0)
 .F I=2:1:30 S SEG(I)=$P(SEGMENT,HLFS,I)
"RTN","DGENUPL",211,0)
 E  D
"RTN","DGENUPL",212,0)
 .; Expanded to 45 from 41 to allow for Camp Lejeune flds - DG*5.3*909
"RTN","DGENUPL",213,0)
 .F I=2:1:45 S SEG(I-1)=$P(SEGMENT,HLFS,I)
"RTN","DGENUPL",214,0)
 Q
"RTN","DGENUPL",215,0)
 ;
"RTN","DGENUPL",216,0)
ADVANCE(MSGIEN,CURLINE) ;
"RTN","DGENUPL",217,0)
 ;Description: Used to find the beginning of the next message in the batch.
"RTN","DGENUPL",218,0)
 ;
"RTN","DGENUPL",219,0)
 ;Input:
"RTN","DGENUPL",220,0)
 ;  MSGIEN - ien of message in the HL7 MESSAGE TEXT file.
"RTN","DGENUPL",221,0)
 ;  CURLINE - current position in the message
"RTN","DGENUPL",222,0)
 ;Output:
"RTN","DGENUPL",223,0)
 ;  CURLINE - starting position of next message in the batch, or 0 if 
"RTN","DGENUPL",224,0)
 ;    the end of the message is reached
"RTN","DGENUPL",225,0)
 ;
"RTN","DGENUPL",226,0)
 Q:'CURLINE
"RTN","DGENUPL",227,0)
 F  S CURLINE=$O(^TMP($J,IVMRTN,CURLINE)) Q:'CURLINE  Q:$E($G(^TMP($J,IVMRTN,CURLINE,0)),1,3)="MSH"
"RTN","DGENUPL",228,0)
 S CURLINE=+CURLINE
"RTN","DGENUPL",229,0)
 Q
"RTN","DGENUPLA")
0^12^B71424515
"RTN","DGENUPLA",1,0)
DGENUPLA ;ALB/CKN,TDM,PJR,RGL,EG,TMK,CKN,TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;15 Jan 2015  4:35 PM
"RTN","DGENUPLA",2,0)
 ;;5.3;REGISTRATION;**397,379,497,451,564,672,659,583,653,688,754,909**;Aug 13,1993;Build 32
"RTN","DGENUPLA",3,0)
 ;
"RTN","DGENUPLA",4,0)
 ;***************************************************************
"RTN","DGENUPLA",5,0)
 ; This routine was created because DGENUPL2 had reached it's
"RTN","DGENUPLA",6,0)
 ; maximum size, therefore no new code could not be added.  All
"RTN","DGENUPLA",7,0)
 ; code that existed in the ZEL and OBX tags of DGENUPL2 has
"RTN","DGENUPLA",8,0)
 ; been moved to the ZEL,ZPD and OBX tags of DGENUPLA.  A line of code
"RTN","DGENUPLA",9,0)
 ; was placed in ZEL^DGENUPL2 to call ZEL^DGENUPLA.  A line of
"RTN","DGENUPLA",10,0)
 ; code was placed in OBX^DGENUPL2 to call OBX^DGENUPLA.
"RTN","DGENUPLA",11,0)
 ; Any routine that calls ZEL,ZPD or OBX^DGENUPL2 will not
"RTN","DGENUPLA",12,0)
 ; be affected by this change.
"RTN","DGENUPLA",13,0)
 ;***************************************************************
"RTN","DGENUPLA",14,0)
 ;
"RTN","DGENUPLA",15,0)
 ;***************************************************************
"RTN","DGENUPLA",16,0)
 ;The following procedures parse particular segment types.
"RTN","DGENUPLA",17,0)
 ;Input:SEG(),MSGID
"RTN","DGENUPLA",18,0)
 ;Output:DGPAT(),DGELG(),DGENR(),DGNTR(),DGMST(),ERROR
"RTN","DGENUPLA",19,0)
 ;***************************************************************
"RTN","DGENUPLA",20,0)
 ;
"RTN","DGENUPLA",21,0)
 ;
"RTN","DGENUPLA",22,0)
ZEL(COUNT) ;
"RTN","DGENUPLA",23,0)
 N CODE,SEQ
"RTN","DGENUPLA",24,0)
 S CODE=$$CONVERT^DGENUPL1(SEG(2),"ELIGIBILITY",.ERROR)
"RTN","DGENUPLA",25,0)
 I ERROR D  Q
"RTN","DGENUPLA",26,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ELIGIBILITY CODE "_SEG(2)_" NOT FOUND IN ELIGIBILTIY CODE FILE",.ERRCOUNT)
"RTN","DGENUPLA",27,0)
 I COUNT=1 D
"RTN","DGENUPLA",28,0)
 .S DGELG("ELIG","CODE")=CODE
"RTN","DGENUPLA",29,0)
 .S DGELG("DISRET")=$$CONVERT^DGENUPL1(SEG(5),"1/0",.ERROR)
"RTN","DGENUPLA",30,0)
 .I ERROR D  Q
"RTN","DGENUPLA",31,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 5",.ERRCOUNT)
"RTN","DGENUPLA",32,0)
 .S DGELG("CLAIMNUM")=$$CONVERT^DGENUPL1(SEG(6))
"RTN","DGENUPLA",33,0)
 .S DGELG("CLAIMLOC")=$$SITECNV(SEG(7))
"RTN","DGENUPLA",34,0)
 .;
"RTN","DGENUPLA",35,0)
 .S DGPAT("VETERAN")=$$CONVERT^DGENUPL1(SEG(8),"Y/N",.ERROR)
"RTN","DGENUPLA",36,0)
 .I ERROR D  Q
"RTN","DGENUPLA",37,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 8",.ERRCOUNT)
"RTN","DGENUPLA",38,0)
 .S DGELG("ELIGSTA")=$$CONVERT^DGENUPL1(SEG(10))
"RTN","DGENUPLA",39,0)
 .S DGELG("ELIGSTADATE")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
"RTN","DGENUPLA",40,0)
 .I ERROR D  Q
"RTN","DGENUPLA",41,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 11",.ERRCOUNT)
"RTN","DGENUPLA",42,0)
 .S DGELG("ELIGVERIF")=$$CONVERT^DGENUPL1(SEG(13))
"RTN","DGENUPLA",43,0)
 .S DGELG("A&A")=$$CONVERT^DGENUPL1(SEG(14),"Y/N",.ERROR)
"RTN","DGENUPLA",44,0)
 .I ERROR D  Q
"RTN","DGENUPLA",45,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 14",.ERRCOUNT)
"RTN","DGENUPLA",46,0)
 .S DGELG("HB")=$$CONVERT^DGENUPL1(SEG(15),"Y/N",.ERROR)
"RTN","DGENUPLA",47,0)
 .I ERROR D  Q
"RTN","DGENUPLA",48,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 15",.ERRCOUNT)
"RTN","DGENUPLA",49,0)
 .S DGELG("VAPEN")=$$CONVERT^DGENUPL1(SEG(16),"Y/N",.ERROR)
"RTN","DGENUPLA",50,0)
 .I ERROR D  Q
"RTN","DGENUPLA",51,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 16",.ERRCOUNT)
"RTN","DGENUPLA",52,0)
 .S DGELG("VADISAB")=$$CONVERT^DGENUPL1(SEG(17),"Y/N",.ERROR)
"RTN","DGENUPLA",53,0)
 .I ERROR D  Q
"RTN","DGENUPLA",54,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 17",.ERRCOUNT)
"RTN","DGENUPLA",55,0)
 .S DGELG("AO")=$$CONVERT^DGENUPL1(SEG(18),"Y/N",.ERROR)
"RTN","DGENUPLA",56,0)
 .N AOERR S AOERR=ERROR            ;  See SEG(29) below.
"RTN","DGENUPLA",57,0)
 .I ERROR D  Q
"RTN","DGENUPLA",58,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 18",.ERRCOUNT)
"RTN","DGENUPLA",59,0)
 .S (DGPAT("IR"),DGELG("IR"))=$$CONVERT^DGENUPL1(SEG(19),"Y/N",.ERROR)
"RTN","DGENUPLA",60,0)
 .I ERROR D  Q
"RTN","DGENUPLA",61,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 19",.ERRCOUNT)
"RTN","DGENUPLA",62,0)
 .S DGELG("EC")=$$CONVERT^DGENUPL1(SEG(20),"Y/N",.ERROR)
"RTN","DGENUPLA",63,0)
 .I ERROR D  Q
"RTN","DGENUPLA",64,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 20",.ERRCOUNT)
"RTN","DGENUPLA",65,0)
 .S (DGPAT("RADEXPM"),DGELG("RADEXPM"))=$$CONVERT^DGENUPL1($G(SEG(22)))
"RTN","DGENUPLA",66,0)
 .S ERROR=$S(DGELG("RADEXPM")="":0,",2,3,4,5,6,7,"[(","_DGELG("RADEXPM")_","):0,DGELG("RADEXPM")="@":0,1:1)
"RTN","DGENUPLA",67,0)
 .I ERROR D  Q
"RTN","DGENUPLA",68,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 22",.ERRCOUNT)
"RTN","DGENUPLA",69,0)
 .;
"RTN","DGENUPLA",70,0)
 .S DGELG("VACKAMT")=$$CONVERT^DGENUPL1(SEG(21))
"RTN","DGENUPLA",71,0)
 .;
"RTN","DGENUPLA",72,0)
 .;Parse MST data into DGMST array from sequences 23, 24, 25 of ZEL segment
"RTN","DGENUPLA",73,0)
 . F SEQ=23,24,25 S:SEG(SEQ)=HLQ SEG(SEQ)=""
"RTN","DGENUPLA",74,0)
 . S DGMST("MSTSTAT")=$$CONVERT^DGENUPL1(SEG(23))
"RTN","DGENUPLA",75,0)
 . S DGMST("MSTDT")=$$CONVERT^DGENUPL1(SEG(24),"TS",.ERROR)
"RTN","DGENUPLA",76,0)
 . I ERROR D  Q
"RTN","DGENUPLA",77,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 24",.ERRCOUNT)
"RTN","DGENUPLA",78,0)
 . S DGMST("MSTST")=$$CONVERT^DGENUPL1(SEG(25),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",79,0)
 . I ERROR D  Q
"RTN","DGENUPLA",80,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 25",.ERRCOUNT)
"RTN","DGENUPLA",81,0)
 .;
"RTN","DGENUPLA",82,0)
 . S DGELG("AOEXPLOC")=$$CONVERT^DGENUPL1(SEG(29))
"RTN","DGENUPLA",83,0)
 .; Logic enhanced during SQA of patch 451.  AOERR from SEG(18) above.
"RTN","DGENUPLA",84,0)
 . I 'AOERR,DGELG("AO")'="Y",DGELG("AOEXPLOC")="" S DGELG("AOEXPLOC")="@"
"RTN","DGENUPLA",85,0)
 . S DGELG("UEYEAR")=$$CONVERT^DGENUPL1(SEG(34),"DATE",.ERROR)
"RTN","DGENUPLA",86,0)
 . I ERROR D  Q
"RTN","DGENUPLA",87,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 34",.ERRCOUNT)
"RTN","DGENUPLA",88,0)
 . S DGELG("UESITE")=$$CONVERT^DGENUPL1(SEG(35),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",89,0)
 . I ERROR D  Q
"RTN","DGENUPLA",90,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 35",.ERRCOUNT)
"RTN","DGENUPLA",91,0)
 . S DGELG("CVELEDT")=$$CONVERT^DGENUPL1(SEG(38),"DATE",.ERROR)
"RTN","DGENUPLA",92,0)
 . I ERROR D  Q
"RTN","DGENUPLA",93,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 38",.ERRCOUNT)
"RTN","DGENUPLA",94,0)
 . I $G(DGELG("DISLOD"))="" S DGELG("DISLOD")=$$CONVERT^DGENUPL1(SEG(39),"1/0",.ERROR) ;Discharge due to Disability - DG*5.3*653
"RTN","DGENUPLA",95,0)
 . I ERROR D  Q
"RTN","DGENUPLA",96,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 39",.ERRCOUNT)
"RTN","DGENUPLA",97,0)
 . S DGELG("SHAD")=$$CONVERT^DGENUPL1(SEG(40),"1/0",.ERROR) ;Proj 112/SHAD - DG*5.3*653
"RTN","DGENUPLA",98,0)
 . I ERROR D  Q
"RTN","DGENUPLA",99,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 40 - SHAD Indicator",.ERRCOUNT)
"RTN","DGENUPLA",100,0)
 .; Camp Lejeune data checking added - DG*5.3*909
"RTN","DGENUPLA",101,0)
 . S DGELG("CLE")=$$CONVERT^DGENUPL1(SEG(41),"Y/N",.ERROR)
"RTN","DGENUPLA",102,0)
 . I ERROR D  Q
"RTN","DGENUPLA",103,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 41",.ERRCOUNT)
"RTN","DGENUPLA",104,0)
 . S DGELG("CLEDT")=$$CONVERT^DGENUPL1(SEG(42),"DATE",.ERROR)
"RTN","DGENUPLA",105,0)
 . I ERROR D  Q
"RTN","DGENUPLA",106,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 42",.ERRCOUNT)
"RTN","DGENUPLA",107,0)
 . S DGELG("CLEST")=$$CONVERT^DGENUPL1(SEG(43))
"RTN","DGENUPLA",108,0)
 . S DGELG("CLESOR")=$$CONVERT^DGENUPL1(SEG(44))
"RTN","DGENUPLA",109,0)
 ;
"RTN","DGENUPLA",110,0)
 I COUNT>1 D
"RTN","DGENUPLA",111,0)
 .S DGELG("ELIG","CODE",CODE)=""
"RTN","DGENUPLA",112,0)
 Q
"RTN","DGENUPLA",113,0)
 ;
"RTN","DGENUPLA",114,0)
OBX ;
"RTN","DGENUPLA",115,0)
 N OBXPCE,OBXVAL,OBXTBL,I,CS,SS,RS
"RTN","DGENUPLA",116,0)
 I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
"RTN","DGENUPLA",117,0)
 I $G(HLFS)="" N HLFS S HLFS="^"
"RTN","DGENUPLA",118,0)
 S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
"RTN","DGENUPLA",119,0)
 I $G(SEG(3))=("38.1"_$E(HLECH)_"SECURITY LOG") D
"RTN","DGENUPLA",120,0)
 . N LEVEL
"RTN","DGENUPLA",121,0)
 . S LEVEL=$P(SEG(5),$E(HLECH))
"RTN","DGENUPLA",122,0)
 . S DGSEC("LEVEL")=$$CONVERT^DGENUPL1(LEVEL,"1/0",.ERROR)
"RTN","DGENUPLA",123,0)
 . I ERROR D  Q
"RTN","DGENUPLA",124,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, OBX SEGMENT, SEQ 5",.ERRCOUNT)
"RTN","DGENUPLA",125,0)
 . S DGSEC("DATETIME")=$$CONVERT^DGENUPL1(SEG(14),"TS",.ERROR)
"RTN","DGENUPLA",126,0)
 . I ERROR D  Q
"RTN","DGENUPLA",127,0)
 . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, OBX SEGMENT, SEQ 14, Patient Sensitivity Date/Time",.ERRCOUNT) ;DG*5.3*653
"RTN","DGENUPLA",128,0)
 . S DGSEC("SOURCE")=$$CONVERT^DGENUPL1(SEG(16))
"RTN","DGENUPLA",129,0)
 ;
"RTN","DGENUPLA",130,0)
 I $G(SEG(3))=("VISTA"_CS_"28.11") D
"RTN","DGENUPLA",131,0)
 . S OBXTBL(1)="NTR^Y",OBXTBL(2)="AVI^Y",OBXTBL(3)="SUB^Y"
"RTN","DGENUPLA",132,0)
 . S OBXTBL(4)="HNC^Y",OBXTBL(5)="NTR^N",OBXTBL(6)="AVI^N"
"RTN","DGENUPLA",133,0)
 . S OBXTBL(7)="SUB^N",OBXTBL(8)="HNC^N",OBXTBL(9)="NTR^U"
"RTN","DGENUPLA",134,0)
 . F I=1:1:$L($G(SEG(5)),RS) D
"RTN","DGENUPLA",135,0)
 . . S OBXPCE=$P($G(SEG(5)),RS,I),OBXVAL=$P($G(OBXPCE),CS)
"RTN","DGENUPLA",136,0)
 . . S DGNTR($P($G(OBXTBL(OBXVAL)),"^"))=$P($G(OBXTBL(OBXVAL)),"^",2)
"RTN","DGENUPLA",137,0)
 . I $G(SEG(12))'="" S DGNTR("HDT")=$$CONVERT^DGENUPL1(SEG(12),"TS",.ERROR)
"RTN","DGENUPLA",138,0)
 . S DGNTR("VDT")=$$CONVERT^DGENUPL1(SEG(14),"TS",.ERROR)
"RTN","DGENUPLA",139,0)
 . S DGNTR("VSIT")=$$CONVERT^DGENUPL1(SEG(15),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",140,0)
 . S DGNTR("HSIT")=$P($P($G(SEG(16)),CS,14),SS,2)
"RTN","DGENUPLA",141,0)
 . I DGNTR("HSIT")'="" S DGNTR("HSIT")=$$CONVERT^DGENUPL1($G(DGNTR("HSIT")),"INSTITUTION",.ERROR)
"RTN","DGENUPLA",142,0)
 . S DGNTR("VER")=$$CONVERT^DGENUPL1($P($G(SEG(17)),CS))
"RTN","DGENUPLA",143,0)
 Q
"RTN","DGENUPLA",144,0)
 ;
"RTN","DGENUPLA",145,0)
ZIO ;New segment - DG*5.3*653
"RTN","DGENUPLA",146,0)
 S DGPAT("APPREQ")=$$CONVERT^DGENUPL1(SEG(5),"1/0",.ERROR)
"RTN","DGENUPLA",147,0)
 I ERROR D  Q
"RTN","DGENUPLA",148,0)
 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIO SEGMENT, SEQ 5, APPOINTMENT REQUEST ON 1010EZ",.ERRCOUNT)
"RTN","DGENUPLA",149,0)
 S DGPAT("APPREQDT")=$$CONVERT^DGENUPL1(SEG(6),"DATE",.ERROR)
"RTN","DGENUPLA",150,0)
 I ERROR D  Q
"RTN","DGENUPLA",151,0)
 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIO SEGMENT, SEQ 6, APPOINTMENT REQUEST DATE",.ERRCOUNT)
"RTN","DGENUPLA",152,0)
 Q
"RTN","DGENUPLA",153,0)
 ;
"RTN","DGENUPLA",154,0)
ZPD ;
"RTN","DGENUPLA",155,0)
 S DGELG("RATEINC")=$$CONVERT^DGENUPL1(SEG(8))
"RTN","DGENUPLA",156,0)
 S DGPAT("DEATH")=$$CONVERT^DGENUPL1(SEG(9),"TS",.ERROR)
"RTN","DGENUPLA",157,0)
 I ERROR D  Q
"RTN","DGENUPLA",158,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 9",.ERRCOUNT)
"RTN","DGENUPLA",159,0)
 S DGELG("MEDICAID")=$$CONVERT^DGENUPL1(SEG(12))
"RTN","DGENUPLA",160,0)
 S DGELG("MEDASKDT")=$$CONVERT^DGENUPL1(SEG(13),"TS",.ERROR)
"RTN","DGENUPLA",161,0)
 I ERROR D  Q
"RTN","DGENUPLA",162,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 13",.ERRCOUNT)
"RTN","DGENUPLA",163,0)
 S DGELG("POW")=$$CONVERT^DGENUPL1(SEG(17))
"RTN","DGENUPLA",164,0)
 S DGPAT("SPININJ")=$$CONVERT^DGENUPL1(SEG(30))
"RTN","DGENUPLA",165,0)
 S ERROR=$S(DGPAT("SPININJ")="":0,",1,2,3,4,X,"[(","_DGPAT("SPININJ")_","):0,DGPAT("SPININJ")="@":0,1:1)
"RTN","DGENUPLA",166,0)
 I ERROR D  Q
"RTN","DGENUPLA",167,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 30",.ERRCOUNT)
"RTN","DGENUPLA",168,0)
 ;DG*5.3*688
"RTN","DGENUPLA",169,0)
 S DGPAT("AG/ALLY")=$$CONVERT^DGENUPL1(SEG(35),"AGENCY",.ERROR)
"RTN","DGENUPLA",170,0)
 I ERROR D
"RTN","DGENUPLA",171,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 35",.ERRCOUNT)
"RTN","DGENUPLA",172,0)
 S DGPAT("EMGRES")=$$CONVERT^DGENUPL1(SEG(40)) ;DG*5.3*677
"RTN","DGENUPLA",173,0)
 Q
"RTN","DGENUPLA",174,0)
 ;
"RTN","DGENUPLA",175,0)
SITECNV(STRING) ; Convert claim folder loc (site # or site # and name) to
"RTN","DGENUPLA",176,0)
 ; pointer to file 4
"RTN","DGENUPLA",177,0)
 N SITE
"RTN","DGENUPLA",178,0)
 S SITE=""
"RTN","DGENUPLA",179,0)
 I STRING'="" D
"RTN","DGENUPLA",180,0)
 . N SUB,START,END
"RTN","DGENUPLA",181,0)
 . ; Find site ien if only site # is returned
"RTN","DGENUPLA",182,0)
 . I $O(^DIC(4,"D",STRING,0)) S SITE=$O(^DIC(4,"D",STRING,0)) Q
"RTN","DGENUPLA",183,0)
 . ; Check if name is concatenated onto site # to find site ien
"RTN","DGENUPLA",184,0)
 . S SUB=""
"RTN","DGENUPLA",185,0)
 . F  S SUB=$O(^DIC(4,"D",SUB)) Q:SUB=""  I $E(SUB,1,3)=$E(STRING,1,3),$$CHK(SUB,STRING) S SITE=$O(^DIC(4,"D",SUB,0)) Q
"RTN","DGENUPLA",186,0)
 ; SITE is the pointer to file 4 or null for site not found
"RTN","DGENUPLA",187,0)
 Q SITE
"RTN","DGENUPLA",188,0)
 ;
"RTN","DGENUPLA",189,0)
CHK(SUB,STRING) ;
"RTN","DGENUPLA",190,0)
 N IEN,X,STN,RET
"RTN","DGENUPLA",191,0)
 I SUB=STRING Q 1
"RTN","DGENUPLA",192,0)
 S RET=0
"RTN","DGENUPLA",193,0)
 S IEN=+$O(^DIC(4,"D",SUB,""))
"RTN","DGENUPLA",194,0)
 I IEN D
"RTN","DGENUPLA",195,0)
 . S X=$P($G(^DIC(4,IEN,0)),U),STN=$P($G(^(99)),U)
"RTN","DGENUPLA",196,0)
 . ; assume institution file names will be the same on HEC and VistA
"RTN","DGENUPLA",197,0)
 . I STN=SUB,X'="",$E($P(STRING,SUB,2,999),1,40)=X S RET=1
"RTN","DGENUPLA",198,0)
 Q RET
"RTN","DGENUPLA",199,0)
 ;
"RTN","DGRP61")
0^9^B47311723
"RTN","DGRP61",1,0)
DGRP61 ;ALB/PJH,LBD - Patient MSDS History - List Manager Screen ;12 JUN 1997 10:00 am
"RTN","DGRP61",2,0)
 ;;5.3;Registration;**797,909**;Aug 13,1993;Build 32
"RTN","DGRP61",3,0)
 ;
"RTN","DGRP61",4,0)
EN(DFN) ;Main entry point to invoke the DGEN MSDS PATIENT list
"RTN","DGRP61",5,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGRP61",6,0)
 ;
"RTN","DGRP61",7,0)
 D WAIT^DICD
"RTN","DGRP61",8,0)
 D EN^VALM("DGEN MSDS PATIENT")
"RTN","DGRP61",9,0)
 Q
"RTN","DGRP61",10,0)
 ;
"RTN","DGRP61",11,0)
HDR ;Header code
"RTN","DGRP61",12,0)
 N DGPREFNM,X,VA,VAERR
"RTN","DGRP61",13,0)
 S VALMHDR(1)=$J("",25)_"MILITARY SERVICE DATA, SCREEN <6.1>"
"RTN","DGRP61",14,0)
 D PID^VADPT
"RTN","DGRP61",15,0)
 S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
"RTN","DGRP61",16,0)
 S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")"
"RTN","DGRP61",17,0)
 S X="PATIENT TYPE UNKNOWN"
"RTN","DGRP61",18,0)
 I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
"RTN","DGRP61",19,0)
 S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80)
"RTN","DGRP61",20,0)
 S VALMHDR(3)=$J("",4)_"Service Branch/Component  Service #"
"RTN","DGRP61",21,0)
 S VALMHDR(3)=VALMHDR(3)_"        Entered    Separated   Discharge"
"RTN","DGRP61",22,0)
 Q
"RTN","DGRP61",23,0)
 ;
"RTN","DGRP61",24,0)
INIT ;Build patient MSDS screen
"RTN","DGRP61",25,0)
 D CLEAN^VALM10
"RTN","DGRP61",26,0)
 K ^TMP("DGRP61",$J),DGSEL
"RTN","DGRP61",27,0)
 ;
"RTN","DGRP61",28,0)
 N GLBL
"RTN","DGRP61",29,0)
 S GLBL=$NA(^TMP("DGRP61",$J))
"RTN","DGRP61",30,0)
 D GETMSE(DFN,GLBL,1)
"RTN","DGRP61",31,0)
 ;Check if any old MSEs didn't copy and display warning message
"RTN","DGRP61",32,0)
 I $$WARNMSG^DGMSEUTL(DFN) D
"RTN","DGRP61",33,0)
 .S VALMSG="**More MSEs available to view on History Screen**"
"RTN","DGRP61",34,0)
 .D MSG^VALM10(VALMSG)
"RTN","DGRP61",35,0)
 Q
"RTN","DGRP61",36,0)
 ;
"RTN","DGRP61",37,0)
GETMSE(DFN,GLBL,NUM) ;Load service episodes from .3216 array
"RTN","DGRP61",38,0)
 ; INPUT: DFN = Patient IEN
"RTN","DGRP61",39,0)
 ;        GLBL = ^TMP global ref
"RTN","DGRP61",40,0)
 ;        NUM = 1 - display line numbers
"RTN","DGRP61",41,0)
 N DGDATA,DGDATE,DGSUB
"RTN","DGRP61",42,0)
 S VALMCNT=0,DGDATE=""
"RTN","DGRP61",43,0)
 F  S DGDATE=$O(^DPT(DFN,.3216,"B",DGDATE),-1) Q:'DGDATE  D
"RTN","DGRP61",44,0)
 .S DGSUB=$O(^DPT(DFN,.3216,"B",DGDATE,"")) Q:'DGSUB
"RTN","DGRP61",45,0)
 .S DGDATA=$G(^DPT(DFN,.3216,DGSUB,0)) Q:DGDATA=""
"RTN","DGRP61",46,0)
 .D EPISODE(DGDATA,GLBL,NUM)
"RTN","DGRP61",47,0)
 Q
"RTN","DGRP61",48,0)
 ;
"RTN","DGRP61",49,0)
EPISODE(DGDATA,GLBL,NUM) ;Format individual service episode
"RTN","DGRP61",50,0)
 N Z,DGRPSB,DGRPSC,DGRPSD,DGRPSE,DGRPSN,DGRPSS
"RTN","DGRP61",51,0)
 S DGRPSB=+$P(DGDATA,U,3),DGRPSC=$P(DGDATA,U,4),DGRPSN=$P(DGDATA,U,5)
"RTN","DGRP61",52,0)
 ;Service Branch/Component
"RTN","DGRP61",53,0)
 S Z=$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:"UNKNOWN")
"RTN","DGRP61",54,0)
 I DGRPSC'="" D
"RTN","DGRP61",55,0)
 . N Z0
"RTN","DGRP61",56,0)
 . S Z0=$$SVCCOMP^DGRP6CL(DGRPSC) Q:Z0=""
"RTN","DGRP61",57,0)
 . S Z=Z_"/"_Z0
"RTN","DGRP61",58,0)
 ;Filipino vet proof
"RTN","DGRP61",59,0)
 I $$FV^DGRPMS(DGRPSB)=1 S Z=$E(Z_$J("",21),1,21)_"("_$P($G(^DPT(DFN,.321)),U,14)_")"
"RTN","DGRP61",60,0)
 ;Service Number
"RTN","DGRP61",61,0)
 S Z=Z_$J("",26-$L(Z))_$S(DGRPSN]"":DGRPSN,1:"UNKNOWN")
"RTN","DGRP61",62,0)
 S Z=Z_$J("",42-$L(Z))
"RTN","DGRP61",63,0)
 ;Entry and separation dates
"RTN","DGRP61",64,0)
 S DGRPSE=$P(DGDATA,U,1),DGRPSS=$P(DGDATA,U,2)
"RTN","DGRP61",65,0)
 S X=$S(DGRPSE]"":$$FMTE^XLFDT(DGRPSE,"5DZ"),1:"UNKNOWN   ")
"RTN","DGRP61",66,0)
 S Z=Z_$E(X,1,10)_"  "
"RTN","DGRP61",67,0)
 S X=$S(DGRPSS]"":$$FMTE^XLFDT(DGRPSS,"5DZ"),1:"UNKNOWN   ")
"RTN","DGRP61",68,0)
 S Z=Z_$E(X,1,10)_"  "
"RTN","DGRP61",69,0)
 ;Discharge type
"RTN","DGRP61",70,0)
 S DGRPSD=+$P(DGDATA,U,6)
"RTN","DGRP61",71,0)
 I 'DGRPSD S Z=Z_"UNKNOWN"
"RTN","DGRP61",72,0)
 E  S Z=Z_$S($D(^DIC(25,+DGRPSD)):$E($P(^DIC(25,DGRPSD,0),"^",1),1,9),1:"UNKNOWN")
"RTN","DGRP61",73,0)
 S VALMCNT=VALMCNT+1
"RTN","DGRP61",74,0)
 ;Add line numbers if NUM=1
"RTN","DGRP61",75,0)
 I $G(NUM) D
"RTN","DGRP61",76,0)
 .I $G(DGRPV)!($P(DGDATA,U,7)]"") S Z="<"_VALMCNT_"> "_Z Q
"RTN","DGRP61",77,0)
 .S Z="["_VALMCNT_"] "_Z,DGSEL(VALMCNT)=DGRPSE
"RTN","DGRP61",78,0)
 ;Save to List Manager array for display
"RTN","DGRP61",79,0)
 S @GLBL@(VALMCNT,0)=$S($G(NUM):Z,1:$J("",4)_Z)
"RTN","DGRP61",80,0)
 Q
"RTN","DGRP61",81,0)
 ;
"RTN","DGRP61",82,0)
HELP ;Help code
"RTN","DGRP61",83,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","DGRP61",84,0)
 Q
"RTN","DGRP61",85,0)
 ;
"RTN","DGRP61",86,0)
EXIT ;Exit code
"RTN","DGRP61",87,0)
 D CLEAN^VALM10
"RTN","DGRP61",88,0)
 D CLEAR^VALM1
"RTN","DGRP61",89,0)
 K ^TMP("DGRP61",$J)
"RTN","DGRP61",90,0)
 Q
"RTN","DGRP61",91,0)
 ;
"RTN","DGRP61",92,0)
PEXIT ;DGEN MSDS MENU protocol exit code
"RTN","DGRP61",93,0)
 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
"RTN","DGRP61",94,0)
 ;Reset after page up or down
"RTN","DGRP61",95,0)
 ;D XQORM
"RTN","DGRP61",96,0)
 Q
"RTN","DGRP61",97,0)
 ;
"RTN","DGRP61",98,0)
ACT(DGACT) ; Entry point for menu action selection
"RTN","DGRP61",99,0)
 ; INPUT: DGACT = "A" - Add - DGEN MSDS ADD protocol
"RTN","DGRP61",100,0)
 ;              = "E" - Edit - DGEN MSDS EDIT protocol
"RTN","DGRP61",101,0)
 ;              = "D" - Delete - DGEN MSDS DELETE protocol
"RTN","DGRP61",102,0)
 N DGX,DA,DIE,DIC,DIK,DIPA,DR,X,Y
"RTN","DGRP61",103,0)
 I $G(DGACT)="" G ACTQ
"RTN","DGRP61",104,0)
 I $G(DGRPV) W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ
"RTN","DGRP61",105,0)
 D FULL^VALM1
"RTN","DGRP61",106,0)
 I DGACT="A" D ADD G ACTQ
"RTN","DGRP61",107,0)
 I '$D(DGSEL) D  G ACTQ
"RTN","DGRP61",108,0)
 .W !,"There are no episodes to ",$S(DGACT="E":"edit.",1:"delete.")
"RTN","DGRP61",109,0)
 .I $G(VALMCNT) D HECHLP
"RTN","DGRP61",110,0)
 .D PAUSE^VALM1
"RTN","DGRP61",111,0)
 S DGX=$$SEL(DGACT) I 'DGX G ACTQ
"RTN","DGRP61",112,0)
 S DGX=$G(DGSEL(DGX)) I 'DGX G ACTQ
"RTN","DGRP61",113,0)
 S DA(1)=DFN,DIC="^DPT("_DA(1)_",.3216,",DIC(0)="BX",X=DGX
"RTN","DGRP61",114,0)
 D ^DIC I Y<0 W !,"This episode is not in the patient's record." D PAUSE^VALM1 G ACTQ
"RTN","DGRP61",115,0)
 S DIPA("DA")=+Y
"RTN","DGRP61",116,0)
 I DGACT="E" K DA,DIC,DGFRDT S DIE="^DPT(",DA=DFN D SETDR1 D ^DIE
"RTN","DGRP61",117,0)
 I DGACT="D" D
"RTN","DGRP61",118,0)
 .I '$$RUSURE Q
"RTN","DGRP61",119,0)
 .S DIK=DIC,DA(1)=DFN,DA=DIPA("DA") D ^DIK K DIK
"RTN","DGRP61",120,0)
 ; DG*5.3*909 Potentially change Camp Lejeune to No with MSE changes
"RTN","DGRP61",121,0)
ACTQ D INIT S VALMBCK="R" D SETCLNO^DGENCLEA Q
"RTN","DGRP61",122,0)
 ;
"RTN","DGRP61",123,0)
ADD ; Add new MSE to #2.3216 sub-file
"RTN","DGRP61",124,0)
 N X,Y,DIK,DA,DR,DIE,NEXT,DGFRDT
"RTN","DGRP61",125,0)
 ; Get next record number in sub-file
"RTN","DGRP61",126,0)
 S NEXT=$O(^DPT(DFN,.3216,"A"),-1),NEXT=NEXT+1
"RTN","DGRP61",127,0)
 D ZNODE(1)
"RTN","DGRP61",128,0)
 ; Prompt for MSE fields
"RTN","DGRP61",129,0)
 S DIE="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D SETDR2 D ^DIE
"RTN","DGRP61",130,0)
 ; Check if new record is missing or incomplete
"RTN","DGRP61",131,0)
 I '$D(^DPT(DFN,.3216,NEXT)) D ZNODE(-1) Q
"RTN","DGRP61",132,0)
 I '$P(^DPT(DFN,.3216,NEXT,0),U) D  Q
"RTN","DGRP61",133,0)
 .S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK
"RTN","DGRP61",134,0)
 ; File FILIPINO VET PROOF, if set
"RTN","DGRP61",135,0)
 I $G(DIPA("FVP"))]"" D
"RTN","DGRP61",136,0)
 .K DA,DR S DIE="^DPT(",DA=DFN,DR=".3214///^S X=DIPA(""FVP"")"
"RTN","DGRP61",137,0)
 .D ^DIE
"RTN","DGRP61",138,0)
 Q
"RTN","DGRP61",139,0)
SEL(ACT) ; Prompt for episode to edit/delete
"RTN","DGRP61",140,0)
 N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",141,0)
 S DIR(0)="NAO^1:"_VALMCNT_"^K:'$D(DGSEL(X)) X"
"RTN","DGRP61",142,0)
 S DIR("A")="Select Episode: "
"RTN","DGRP61",143,0)
 S DIR("?")="^D SELHLP^DGRP61(ACT)"
"RTN","DGRP61",144,0)
 D ^DIR I 'Y Q 0
"RTN","DGRP61",145,0)
 Q Y
"RTN","DGRP61",146,0)
SELHLP(ACT) ; Help message for episode prompt
"RTN","DGRP61",147,0)
 W !,"Select an episode to ",$S(ACT="E":"edit.",1:"delete.")
"RTN","DGRP61",148,0)
 W !,"Only numbers in square brackets [ ] are selectable."
"RTN","DGRP61",149,0)
 D HECHLP
"RTN","DGRP61",150,0)
 N DIR D PAUSE^VALM1
"RTN","DGRP61",151,0)
 Q
"RTN","DGRP61",152,0)
HECHLP ; Help message for episodes that can only be changed by HEC
"RTN","DGRP61",153,0)
 W !,"Angled brackets < > indicate episodes that cannot be changed in VistA."
"RTN","DGRP61",154,0)
 W !,"Please contact the HECAlert mail group or the HEC if you need to update"
"RTN","DGRP61",155,0)
 W !,"this information."
"RTN","DGRP61",156,0)
 Q
"RTN","DGRP61",157,0)
 ;
"RTN","DGRP61",158,0)
ZNODE(VAL) ; Update zero node of MSE multiple .3216
"RTN","DGRP61",159,0)
 Q:'$G(VAL)  Q:'$G(DFN)
"RTN","DGRP61",160,0)
 N ZNODE
"RTN","DGRP61",161,0)
 S ZNODE=$G(^DPT(DFN,.3216,0))
"RTN","DGRP61",162,0)
 S ^DPT(DFN,.3216,0)="^2.3216D^"_($P(ZNODE,U,3)+VAL)_U_($P(ZNODE,U,4)+VAL)
"RTN","DGRP61",163,0)
 Q
"RTN","DGRP61",164,0)
SETDR1 ; Set DR array to edit MSE fields
"RTN","DGRP61",165,0)
 S DR="I '$G(DIPA(""DA"")) S Y=0;.3216////^S X=""`""_DIPA(""DA"");.3214///^S X=$G(DIPA(""FVP""))"
"RTN","DGRP61",166,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",167,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",168,0)
 S DR(2,2.3216,2)="@62;D:DIPA(""X"")]"""" WARN^DGRP61(.DIPA,.Y);.04;@63;.05;.01;.02;.06"
"RTN","DGRP61",169,0)
 Q
"RTN","DGRP61",170,0)
SETDR2 ; Set DR array to add MSE fields
"RTN","DGRP61",171,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",172,0)
 Q
"RTN","DGRP61",173,0)
FVP() ; Prompt for FILIPINO VET PROOF
"RTN","DGRP61",174,0)
 N DA,X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",175,0)
 S DIR(0)="2,.3214",DA=DFN
"RTN","DGRP61",176,0)
 D ^DIR I Y=""!(Y="^") Q Y
"RTN","DGRP61",177,0)
 Q Y
"RTN","DGRP61",178,0)
 ;
"RTN","DGRP61",179,0)
SET0(DA,DIPA) ; Set DIPA(0) to values of Service Branch and Service Component
"RTN","DGRP61",180,0)
 K DIPA(0)
"RTN","DGRP61",181,0)
 S DIPA(0)=$P($G(^DPT(DA(1),.3216,DA,0)),U,3,4)
"RTN","DGRP61",182,0)
 Q
"RTN","DGRP61",183,0)
 ;
"RTN","DGRP61",184,0)
WARN(DIPA,Y) ;Warns that the Service Branch was changed so the
"RTN","DGRP61",185,0)
 ; Service Component was deleted
"RTN","DGRP61",186,0)
 ; Returns Y to skip component if the component should not be asked
"RTN","DGRP61",187,0)
 ;   for this branch of service
"RTN","DGRP61",188,0)
 I '$$CMP($G(DIPA("X"))) S Y="@63"
"RTN","DGRP61",189,0)
 I $P($G(DIPA(0)),U,2)=""!($P($G(DIPA(0)),U)="") Q
"RTN","DGRP61",190,0)
 I $P(DIPA(0),U)=DIPA("X") Q   ;Service Branch didn't change
"RTN","DGRP61",191,0)
 ;
"RTN","DGRP61",192,0)
 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
"RTN","DGRP61",193,0)
 Q
"RTN","DGRP61",194,0)
 ;
"RTN","DGRP61",195,0)
CMP(X) ; Function to determine if service component is valid for
"RTN","DGRP61",196,0)
 ; branch of service ien in X   0 = invalid  1 = valid  
"RTN","DGRP61",197,0)
 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
"RTN","DGRP61",198,0)
 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
"RTN","DGRP61",199,0)
 ;
"RTN","DGRP61",200,0)
RUSURE() ; Confirmation prompt for deleting episode
"RTN","DGRP61",201,0)
 N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT
"RTN","DGRP61",202,0)
 S DIR(0)="YA",DIR("B")="NO"
"RTN","DGRP61",203,0)
 S DIR("A")="Are you sure you want to delete this military service episode? "
"RTN","DGRP61",204,0)
 D ^DIR I 'Y W !,"<< NOTHING DELETED >>" Q 0
"RTN","DGRP61",205,0)
 Q 1
"RTN","DGRP6EF")
0^7^B28412625
"RTN","DGRP6EF",1,0)
DGRP6EF ;ALB/TMK,EG,BAJ,JLS - REGISTRATION SCREEN 6 FIELDS FOR EXPOSURE FACTORS ;05 Feb 2015  11:06 AM
"RTN","DGRP6EF",2,0)
 ;;5.3;Registration;**689,659,737,688,909**;Aug 13,1993;Build 32
"RTN","DGRP6EF",3,0)
 ;
"RTN","DGRP6EF",4,0)
EN(DFN,QUIT) ; Display Environmental exposure factors/allow to edit
"RTN","DGRP6EF",5,0)
 N I,IND,DG321,DG322,DGCT,DIR,Z,X,Y,DIE,DR,DA,DGNONT
"RTN","DGRP6EF",6,0)
 ; Returns QUIT=1 if ^ entered
"RTN","DGRP6EF",7,0)
 ;
"RTN","DGRP6EF",8,0)
EN1 D CLEAR^VALM1
"RTN","DGRP6EF",9,0)
 N DTOUT,DUOUT,TYPE,SEL,L,S,L1,L2,L3
"RTN","DGRP6EF",10,0)
 S DG321=$G(^DPT(DFN,.321)),DG322=$G(^DPT(DFN,.322))
"RTN","DGRP6EF",11,0)
 ;
"RTN","DGRP6EF",12,0)
 S DIR(0)="SA^",DGCT=0
"RTN","DGRP6EF",13,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=$$SSNNM^DGRPU(DFN)
"RTN","DGRP6EF",14,0)
 S DGCT=DGCT+1,DIR("A",DGCT)="",$P(DIR("A",DGCT),"=",81)=""
"RTN","DGRP6EF",15,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",23)_"**** ENVIRONMENTAL FACTORS ****",DGCT=DGCT+1,DIR("A",DGCT)=" "
"RTN","DGRP6EF",16,0)
 S IND=$S('$G(DGRPV):"[]",1:"<>")
"RTN","DGRP6EF",17,0)
 S DGCT=DGCT+1
"RTN","DGRP6EF",18,0)
 S Z=$E(IND)_"1"_$E(IND,2)
"RTN","DGRP6EF",19,0)
 ; "OTHER" choice added DG*5.3*688
"RTN","DGRP6EF",20,0)
 ; variables S,L1,L2, & L3 used for dynamic spacing
"RTN","DGRP6EF",21,0)
 S SEL=$P(DG321,U,13),S=$C(32),($P(L1,S,6),$P(L2,S,$S(SEL="O":3,1:2)),$P(L3,S,3))=""
"RTN","DGRP6EF",22,0)
 S TYPE=$S(SEL="K":" (DMZ) ",SEL="V":" (VIET)",SEL="O":" (OTH)",1:$J("",7))
"RTN","DGRP6EF",23,0)
 S DIR("A",DGCT)=Z_L1_"A/O Exp.: "_$$YN^DGRP6CL(DG321,2)_TYPE_L2_"Reg: "_$$DAT^DGRP6CL(DG321,7,12)_L3_"Exam: "_$$DAT^DGRP6CL(DG321,9,12)_"A/O#: "_$P(DG321,U,10)
"RTN","DGRP6EF",24,0)
 S Z=$E(IND)_"2"_$E(IND,2)
"RTN","DGRP6EF",25,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=Z_"     ION Rad.: "_$$YN^DGRP6CL(DG321,3)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG321,11,12)_"Method: "
"RTN","DGRP6EF",26,0)
 S:$P(DG321,U,12)>7 $P(DG321,U,12)="" S DIR("A",DGCT)=DIR("A",DGCT)_$P($T(SELTBL+$P(DG321,U,12)),";;",2)
"RTN","DGRP6EF",27,0)
 S Z=$E(IND)_"3"_$E(IND,2)
"RTN","DGRP6EF",28,0)
 ;Env Contam name changed to SW Asia Conditions, DG*5.3*688
"RTN","DGRP6EF",29,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=Z_" SW Asia Cond: "_$$YN^DGRP6CL(DG322,13)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG322,14,12)_"  Exam: "_$$DAT^DGRP6CL(DG322,15,11)
"RTN","DGRP6EF",30,0)
 S DGNONT=0 I $$GETSTAT^DGNTAPI1(DFN)>2,'$D(^XUSEC("DGNT VERIFY",DUZ)) S DGNONT=1
"RTN","DGRP6EF",31,0)
 I $G(DGRPV) S DGNONT=1
"RTN","DGRP6EF",32,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=$S(DGNONT:"<",1:"[")_"4"_$S(DGNONT:">",1:"]")_"   N/T Radium: " N DGNT S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") S DIR("A",DGCT)=DIR("A",DGCT)_$G(DGNT("INTRP"))
"RTN","DGRP6EF",33,0)
 ;
"RTN","DGRP6EF",34,0)
 ; DG*5.3*909 Display Camp Lejeune info in entirety
"RTN","DGRP6EF",35,0)
 N DG3217CL S DG3217CL=$G(^DPT(DFN,.3217))
"RTN","DGRP6EF",36,0)
 N DGCLE S DGCLE=$$CLE^DGENCLEA(DFN)
"RTN","DGRP6EF",37,0)
 I DGCLE=1,$G(^DPT(DFN,.32171))=1 S DGCLE=0
"RTN","DGRP6EF",38,0)
 S IND=$S('DGCLE:"<>",1:IND)
"RTN","DGRP6EF",39,0)
 S Z=$E(IND)_"5"_$E(IND,2)
"RTN","DGRP6EF",40,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=Z_" Camp Lejeune: "
"RTN","DGRP6EF",41,0)
 S DIR("A",DGCT)=DIR("A",DGCT)_$$YN^DGRP6CL(DG3217CL,1)
"RTN","DGRP6EF",42,0)
 ;
"RTN","DGRP6EF",43,0)
 S DGCT=DGCT+1,DIR("A",DGCT)=" "
"RTN","DGRP6EF",44,0)
 N DGENDTXT S DGENDTXT=$S(DGNONT&DGCLE:"3,5",DGNONT&'DGCLE:"3",'DGNONT&DGCLE:"5",1:"4")  ; DG*5.3*909 Determine available choices based also on Camp Lejeune eligibility
"RTN","DGRP6EF",45,0)
 S DIR("A")=$S('$G(DGRPV):"SELECT AN ENVIRONMENTAL FACTOR (1-"_DGENDTXT_") OR (Q)UIT: ",1:"PRESS RETURN TO CONTINUE ")  ;DG*5.3*909 Camp Lejeune choice added
"RTN","DGRP6EF",46,0)
 ;Env Contam name changed to SW Asia Conditions, DG*5.3*688
"RTN","DGRP6EF",47,0)
 S DIR(0)=$S('$G(DGRPV):"SA^1:A/O Exp;2:ION Rad;3:SW Asia Cond;"_$S(DGNONT:"",1:"4:N/T Radium;")_$S(DGCLE:"5:Camp Lejeune;",1:"")_"Q:QUIT",1:"EA")  ; DG*5.3*909 Camp Lejeune choice added
"RTN","DGRP6EF",48,0)
 I '$G(DGRPV) S DIR("B")="QUIT"
"RTN","DGRP6EF",49,0)
 I 'DGCLE,$G(^DPT(DFN,.32171))=1,$P($G(XQY0),U)'="DG REGISTRATION VIEW" D
"RTN","DGRP6EF",50,0)
 . S DGHECMSG(1)="Camp Lejeune data has been verified by HEC, please "
"RTN","DGRP6EF",51,0)
 . S DGHECMSG(1)=DGHECMSG(1)_"notify the HEC via"
"RTN","DGRP6EF",52,0)
 . S DGHECMSG(2)="the HEC Alert process if changes are required."
"RTN","DGRP6EF",53,0)
 . S DGHECMSG(3)="Press Return key to continue"
"RTN","DGRP6EF",54,0)
 . S DIR("PRE")="I X=5 W !!,DGHECMSG(1),!,DGHECMSG(2),!!,DGHECMSG(3)"
"RTN","DGRP6EF",55,0)
 . S DIR("PRE")=DIR("PRE")_" R *DGANSWER S X="""""
"RTN","DGRP6EF",56,0)
 D ^DIR K DIR,DGANSWER,DGHECMSG
"RTN","DGRP6EF",57,0)
 I $G(DGRPV)!$D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT
"RTN","DGRP6EF",58,0)
 S Z="603"_$E("0",2-$L(+Y))_+Y
"RTN","DGRP6EF",59,0)
 S DIE=2,DA=DFN,DR=$P($T(@Z),";;",2)
"RTN","DGRP6EF",60,0)
 ;
"RTN","DGRP6EF",61,0)
 ; DG*5.3*909 Camp Lejeune logic added
"RTN","DGRP6EF",62,0)
 I Y'=5 D:DR'="" ^DIE
"RTN","DGRP6EF",63,0)
 E  X DR D AUTOUPD^DGENA2(DFN)
"RTN","DGRP6EF",64,0)
 K DIE,DA,DR
"RTN","DGRP6EF",65,0)
 G EN1
"RTN","DGRP6EF",66,0)
 ;
"RTN","DGRP6EF",67,0)
QUIT Q
"RTN","DGRP6EF",68,0)
 ;
"RTN","DGRP6EF",69,0)
EF(DFN,LIN) ;
"RTN","DGRP6EF",70,0)
 N DG321,DG322,LENGTH,Z,SEQ
"RTN","DGRP6EF",71,0)
 K LIN S (LENGTH,LIN)=0
"RTN","DGRP6EF",72,0)
 S DG321=$G(^DPT(DFN,.321)),DG322=$G(^(.322))
"RTN","DGRP6EF",73,0)
 I $P(DG321,U,2)="Y" D
"RTN","DGRP6EF",74,0)
 . S Z="A/O Exp.",SEQ=1
"RTN","DGRP6EF",75,0)
 . ;S:'$P(DG321,U,7)!'$P(DG321,U,9)!($P(DG321,U,10)="") Z=Z_"(Incomplete)"
"RTN","DGRP6EF",76,0)
 . S:'$P(DG321,U,7)!('$P(DG321,U,9))="" Z=Z_"(Incomplete)"
"RTN","DGRP6EF",77,0)
 . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
"RTN","DGRP6EF",78,0)
 ;
"RTN","DGRP6EF",79,0)
 I $P(DG321,U,3)="Y" D
"RTN","DGRP6EF",80,0)
 . S Z="Ion Rad.",SEQ=2
"RTN","DGRP6EF",81,0)
 . S:'$P(DG321,U,11)!($P(DG321,U,12)="") Z=Z_"(Incomplete)"
"RTN","DGRP6EF",82,0)
 . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
"RTN","DGRP6EF",83,0)
 ;
"RTN","DGRP6EF",84,0)
 I $P(DG322,U,13)="Y" D
"RTN","DGRP6EF",85,0)
 . I 'LIN S LIN=LIN+1,LIN(LIN)=""
"RTN","DGRP6EF",86,0)
 . ;Env Contam name changed to SW Asia Conditions, DG*5.3*688
"RTN","DGRP6EF",87,0)
 . S Z="SW Asia Cond.",SEQ=3
"RTN","DGRP6EF",88,0)
 . S:'$P(DG322,U,14)!'$P(DG322,U,15) Z=Z_"(Incomplete)"
"RTN","DGRP6EF",89,0)
 . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
"RTN","DGRP6EF",90,0)
 ; N/T Radium Exposure
"RTN","DGRP6EF",91,0)
 N DGNT,DGRPX S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT")
"RTN","DGRP6EF",92,0)
 I "NO"'[$G(DGNT("INTRP")) D
"RTN","DGRP6EF",93,0)
 . I 'LIN S LIN=LIN+1,LIN(LIN)=""
"RTN","DGRP6EF",94,0)
 . S SEQ=4 D SETLNEX^DGRP6("N/T Radium ("_$P(DGNT("INTRP"),"YES,",2)_")",SEQ,.LIN,.LENGTH)
"RTN","DGRP6EF",95,0)
 ; DG*5.3*909 Get latest Camp Lejeune information from PATIENT file
"RTN","DGRP6EF",96,0)
 N DG3217CL
"RTN","DGRP6EF",97,0)
 S DG3217CL=$G(^DPT(DFN,.3217))
"RTN","DGRP6EF",98,0)
 I $P(DG3217CL,U,1)="Y" D
"RTN","DGRP6EF",99,0)
 . I 'LIN S LIN=LIN+1,LIN(LIN)=""
"RTN","DGRP6EF",100,0)
 . S Z="Camp Lejeune",SEQ=5
"RTN","DGRP6EF",101,0)
 . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
"RTN","DGRP6EF",102,0)
  Q
"RTN","DGRP6EF",103,0)
  ; The following tag is a table of values.  Do not change location of values including null at SELTBL+0
"RTN","DGRP6EF",104,0)
SELTBL ;;
"RTN","DGRP6EF",105,0)
 ;;NO VALUE
"RTN","DGRP6EF",106,0)
 ;;HIROSHIMA/NAGASAKI
"RTN","DGRP6EF",107,0)
 ;;ATMOSPHERIC NUCLEAR TEST
"RTN","DGRP6EF",108,0)
 ;;H/N AND ATMOSPHERIC TEST
"RTN","DGRP6EF",109,0)
 ;;UNDERGROUND NUCLEAR TEST
"RTN","DGRP6EF",110,0)
 ;;EXP. AT NUCLEAR FACILITY
"RTN","DGRP6EF",111,0)
 ;;OTHER
"RTN","DGRP6EF",112,0)
60301 ;;.32102//NO;S:X'="Y" Y="@65";.3213;.32107;.32109;.3211;@65;
"RTN","DGRP6EF",113,0)
60302 ;;.32103//NO;S:X'="Y" Y="@66";.3212;.32111;@66;
"RTN","DGRP6EF",114,0)
60303 ;;.322013//NO;S:X'="Y" Y="@612";.322014;Q;.322015;@612;
"RTN","DGRP6EF",115,0)
60304 ;;D REG^DGNTQ(DFN)
"RTN","DGRP6EF",116,0)
60305 ;;D ADDEDTCL^DGENCLEA(DFN)
"RTN","DGRP6EF",117,0)
 ;;
"RTN","DGRPE1")
0^14^B10060954
"RTN","DGRPE1",1,0)
DGRPE1 ;ALB/MRL,RTK,BRM,RGL,ERC,TDM - REGISTRATIONS EDITS (CONTINUED) ;4/2/09 11:26am
"RTN","DGRPE1",2,0)
 ;;5.3;Registration;**114,327,451,631,688,808,804,909**;Aug 13, 1993;Build 32
"RTN","DGRPE1",3,0)
 ;
"RTN","DGRPE1",4,0)
 ;***CONTAINS ISM SPECIFIC CODE TO AVOID STORE ERRORS WITH ELIG.***
"RTN","DGRPE1",5,0)
 ;
"RTN","DGRPE1",6,0)
 I DGRPS'=7 F I=1:1 S J=$P(DGDR,",",I) Q:J=""  F J1=J,J*1000 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE1",7,0)
 I DGRPS=7 S DR="[DG LOAD EDIT SCREEN 7]"
"RTN","DGRPE1",8,0)
 ;S DR(2,2.0361)=".01"
"RTN","DGRPE1",9,0)
 D ^DIE K DIE,DR,DGCT,DGDR,DGDRD,DGDRS,I,J,J1
"RTN","DGRPE1",10,0)
 ; rbd DG*5.3*909 Update Camp Lejeune potentially to No based on
"RTN","DGRPE1",11,0)
 ;  Veteran changing to No or Primary Elig Code becoming a Non-Veteran
"RTN","DGRPE1",12,0)
 ;  Type.
"RTN","DGRPE1",13,0)
 D SETCLNO^DGENCLEA
"RTN","DGRPE1",14,0)
 ;update/set ELIGIBILITY VERIF. SOURCE field (327/Ineligible Project)
"RTN","DGRPE1",15,0)
 I $D(^DPT(DFN,.361)) S DGELG=^DPT(DFN,.361) D
"RTN","DGRPE1",16,0)
 .N DGXEL
"RTN","DGRPE1",17,0)
 .S DGXEL=$P(DGELG,U,5),DATA(.3613)="V"
"RTN","DGRPE1",18,0)
 .I $S($G(DGXEL)["CEV":1,$G(DGXEL)["VBA":1,$G(DGXEL)["VIVA":1,1:0),$P(DGELG,U,6)=.5 S DATA(.3613)="H"
"RTN","DGRPE1",19,0)
 .I '$$UPD^DGENDBS(2,DFN,.DATA)
"RTN","DGRPE1",20,0)
 Q
"RTN","DGRPE1",21,0)
S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
"RTN","DGRPE1",22,0)
 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
"RTN","DGRPE1",23,0)
701 ;;391;D SC7^DGRPV;1901;.301;S:X'="Y" Y=.313;.302;.313;.312;
"RTN","DGRPE1",24,0)
702 ;;.361;D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361;.309;361;.323;D ^DGYZODS;S:'DGODS Y=.36265;11500.02;11500.03;.36265;S:X='"Y" Y="@72";.3626;@72;
"RTN","DGRPE1",25,0)
703 ;;.3731;
"RTN","DGRPE1",26,0)
1001 ;;.152;S:X="" Y="@101";.1651;.1653;.1654;.307;.1656;@101;
"RTN","DGRPE1",27,0)
1002 ;;.153;S:X="" Y="@102";.1657:.1659;.16;@102;
"RTN","DGRPE1",28,0)
1101 ;;.3611;.3612;.3614;.3615;
"RTN","DGRPE1",29,0)
1102 ;;.306;
"RTN","DGRPE1",30,0)
1103 ;;.322;
"RTN","DGRPE1",31,0)
1104 ;;D VETTYPE^DGRPE1;D MSG^DGRPE1 S Y=0;@114;K DGRDCHG;D DR^DGRPE1;.302;.3721;D EFF^DGRPE1;D:$G(DGRDCHG) BULL^DGRPE1;K DGRDCHG;
"RTN","DGRPE1",32,0)
MSG W !,"Patient is not a veteran.  Can't enter rated disabilities",! Q
"RTN","DGRPE1",33,0)
 ;
"RTN","DGRPE1",34,0)
BULL ; Rated Disabilities update bulletin
"RTN","DGRPE1",35,0)
 ;
"RTN","DGRPE1",36,0)
 Q        ; This bulletin has been disabled.  DG*5.3*808
"RTN","DGRPE1",37,0)
 ;
"RTN","DGRPE1",38,0)
 N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
"RTN","DGRPE1",39,0)
 S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))
"RTN","DGRPE1",40,0)
 Q:'DGMGRP
"RTN","DGRPE1",41,0)
 D XMY^DGMTUTL(DGMGRP,0,1)
"RTN","DGRPE1",42,0)
 S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9)
"RTN","DGRPE1",43,0)
 S XMTEXT="DGBULL("
"RTN","DGRPE1",44,0)
 S XMSUB="RATED DISABILITY UPDATED"
"RTN","DGRPE1",45,0)
 S DGLINE=0
"RTN","DGRPE1",46,0)
 D LINE^DGEN("Patient: "_DGNAME,.DGLINE)
"RTN","DGRPE1",47,0)
 D LINE^DGEN("SSN: "_DGSSN,.DGLINE)
"RTN","DGRPE1",48,0)
 D LINE^DGEN("",.DGLINE)
"RTN","DGRPE1",49,0)
 D LINE^DGEN("Send updates to SC Disabilities to HEC via fax or HECAlert",.DGLINE)
"RTN","DGRPE1",50,0)
 D LINE^DGEN("Outlook mail group so that they can be entered into VHA's",.DGLINE)
"RTN","DGRPE1",51,0)
 D LINE^DGEN("Authoritative Database.  SC Disability information entered directly",.DGLINE)
"RTN","DGRPE1",52,0)
 D LINE^DGEN("into VistA may be overlaid.",.DGLINE)
"RTN","DGRPE1",53,0)
 D ^XMD
"RTN","DGRPE1",54,0)
 Q
"RTN","DGRPE1",55,0)
DR ;
"RTN","DGRPE1",56,0)
 K DGSCPC
"RTN","DGRPE1",57,0)
 S DGSCPC=$P($G(^DPT(DFN,.3)),U,2)
"RTN","DGRPE1",58,0)
 S DR(2,2.04)=".01;2;3"
"RTN","DGRPE1",59,0)
 Q
"RTN","DGRPE1",60,0)
EFF ;
"RTN","DGRPE1",61,0)
 I $G(DGSCPC)=$P($G(^DPT(DFN,.3)),U,2) Q
"RTN","DGRPE1",62,0)
 S DGFDA(2,DFN_",",.3014)="@"
"RTN","DGRPE1",63,0)
 D FILE^DIE("","DGFDA","DGERR")
"RTN","DGRPE1",64,0)
 K DGFDA,DGSCPC
"RTN","DGRPE1",65,0)
 Q
"RTN","DGRPE1",66,0)
VETTYPE ;
"RTN","DGRPE1",67,0)
 S:$S('$D(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0) Y="@114" Q
"RTN","DGRPE1",68,0)
 S:'$S('$D(^("TYPE")):1,'$D(^DG(391,+^("TYPE"),0)):1,$P(^(0),"^",2):0,1:1) Y="@114"
"RTN","DGRPE1",69,0)
 Q
"RTN","VAFHLZE1")
0^1^B28799443
"RTN","VAFHLZE1",1,0)
VAFHLZE1 ;BPFO/JRP,TDM,JLS - Data extractor for ZEL segment ;5/24/06 3:43pm
"RTN","VAFHLZE1",2,0)
 ;;5.3;Registration;**342,497,602,672,653,909**;Aug 13,1993;Build 32
"RTN","VAFHLZE1",3,0)
 ;
"RTN","VAFHLZE1",4,0)
GETDATA ;Get information needed to build ZEL  segment
"RTN","VAFHLZE1",5,0)
 ;Input: Existence of the following variables is assumed
"RTN","VAFHLZE1",6,0)
 ;   DFN - Pointer to Patient (#2) file
"RTN","VAFHLZE1",7,0)
 ;   VAFPELIG - Primary Eligibility string (.36 node)
"RTN","VAFHLZE1",8,0)
 ;   VAFSTR - Fields to extract (padded with commas)
"RTN","VAFHLZE1",9,0)
 ;   VAFNODE - Eligibility Node (node from Elig. ["E"] mult)
"RTN","VAFHLZE1",10,0)
 ;   VAFMSTDT - Date to use when getting MST status (optional)
"RTN","VAFHLZE1",11,0)
 ;   VAFSETID - Value to use for Set ID (optional)
"RTN","VAFHLZE1",12,0)
 ;   HL7 encoding characters (HLFS, HLENC, HLQ)
"RTN","VAFHLZE1",13,0)
 ;
"RTN","VAFHLZE1",14,0)
 ;Output: VAFHLZEL(SeqNum) = Value
"RTN","VAFHLZE1",15,0)
 ;
"RTN","VAFHLZE1",16,0)
 ;Notes: VAFHLZEL is initialized (KILLed) on entry
"RTN","VAFHLZE1",17,0)
 ;     : If not passed, sequence 1 (Set ID) will have a value of '1'
"RTN","VAFHLZE1",18,0)
 ;       if getting data for the primary eligibility and '2' if getting
"RTN","VAFHLZE1",19,0)
 ;       data for other eligibility
"RTN","VAFHLZE1",20,0)
 ;     : All requested fields will be returned with the primary
"RTN","VAFHLZE1",21,0)
 ;       eligibility.  The Set ID (seq 1), eligibility code (seq 2)
"RTN","VAFHLZE1",22,0)
 ;       long ID (seq 3), and short ID (seq 4) will be the only fields
"RTN","VAFHLZE1",23,0)
 ;       returned for all other eligibilities.
"RTN","VAFHLZE1",24,0)
 ;
"RTN","VAFHLZE1",25,0)
 N PRIME,VAF,VAFMST,X
"RTN","VAFHLZE1",26,0)
 K VAFHLZEL
"RTN","VAFHLZE1",27,0)
 ;If true, primary eligibility (return all fields)
"RTN","VAFHLZE1",28,0)
 S PRIME=+VAFNODE=+VAFPELIG
"RTN","VAFHLZE1",29,0)
 ;Set ID
"RTN","VAFHLZE1",30,0)
 I VAFSTR[",1," S VAFHLZEL(1)=$S($G(VAFSETID):VAFSETID,PRIME:1,1:2)
"RTN","VAFHLZE1",31,0)
 ;Eligibility Code
"RTN","VAFHLZE1",32,0)
 I VAFSTR[",2," S X=$P($G(^DIC(8,+VAFNODE,0)),"^",9),VAFHLZEL(2)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",33,0)
 ;Long ID
"RTN","VAFHLZE1",34,0)
 I VAFSTR[",3," S X=$P(VAFNODE,"^",3),VAFHLZEL(3)=$S(X]"":$$M10^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",35,0)
 ;Short ID
"RTN","VAFHLZE1",36,0)
 I VAFSTR[",4," S X=$P(VAFNODE,"^",4),VAFHLZEL(4)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",37,0)
 ;Done if not getting primary eligibility information
"RTN","VAFHLZE1",38,0)
 I 'PRIME D  Q
"RTN","VAFHLZE1",39,0)
 .N Y,Z
"RTN","VAFHLZE1",40,0)
 .S Y=$L(VAFSTR,",")
"RTN","VAFHLZE1",41,0)
 .F X=1:1:Y S Z=$P(VAFSTR,",",X) I Z S:(Z>4) VAFHLZEL(Z)=HLQ
"RTN","VAFHLZE1",42,0)
 ;Get needed nodes in Patient file (#2)
"RTN","VAFHLZE1",43,0)
 N VAF
"RTN","VAFHLZE1",44,0)
 F X=.3,.31,.321,.3217,.322,.362,.361 S VAF(X)=$G(^DPT(DFN,X))
"RTN","VAFHLZE1",45,0)
 ;Military Disability Retirement
"RTN","VAFHLZE1",46,0)
 I VAFSTR[",5," S X=$P(VAFPELIG,"^",12),VAFHLZEL(5)=$S(X=0:"N",X=1:"Y",1:HLQ)
"RTN","VAFHLZE1",47,0)
 ;Claim Number
"RTN","VAFHLZE1",48,0)
 I VAFSTR[",6," S X=$P(VAF(.31),"^",3),VAFHLZEL(6)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",49,0)
 ;Claim Folder Loc
"RTN","VAFHLZE1",50,0)
 I VAFSTR[",7," S X=$P(VAF(.31),"^",2),VAFHLZEL(7)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",51,0)
 ;Veteran?
"RTN","VAFHLZE1",52,0)
 I VAFSTR[",8," S X=$P($G(^DPT(DFN,"VET")),"^"),VAFHLZEL(8)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",53,0)
 ;Type
"RTN","VAFHLZE1",54,0)
 I VAFSTR[",9," S X=$P($G(^DG(391,+$P($G(^DPT(DFN,"TYPE")),"^"),0)),"^"),VAFHLZEL(9)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",55,0)
 ;Elig Status
"RTN","VAFHLZE1",56,0)
 I VAFSTR[10 S X=$P(VAF(.361),"^",1),VAFHLZEL(10)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",57,0)
 ;Elig Status Date
"RTN","VAFHLZE1",58,0)
 I VAFSTR[11 S X=$P(VAF(.361),"^",2),VAFHLZEL(11)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",59,0)
 ;Elig Interim Response
"RTN","VAFHLZE1",60,0)
 I VAFSTR[12 S X=$P(VAF(.361),"^",4),VAFHLZEL(12)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",61,0)
 ;Elig Verif. Method
"RTN","VAFHLZE1",62,0)
 I VAFSTR[13 S X=$P(VAF(.361),"^",5),VAFHLZEL(13)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",63,0)
 ;Rec A&A Benefits?
"RTN","VAFHLZE1",64,0)
 I VAFSTR[14 S X=$P(VAF(.362),"^",12),VAFHLZEL(14)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",65,0)
 ;Rec Housebound Benefits?
"RTN","VAFHLZE1",66,0)
 I VAFSTR[15 S X=$P(VAF(.362),"^",13),VAFHLZEL(15)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",67,0)
 ;Rec VA Pension?
"RTN","VAFHLZE1",68,0)
 I VAFSTR[16 S X=$P(VAF(.362),"^",14),VAFHLZEL(16)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",69,0)
 ;Rec VA Disability?
"RTN","VAFHLZE1",70,0)
 I VAFSTR[17 S X=$P(VAF(.3),"^",11),VAFHLZEL(17)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",71,0)
 ;Agent Orange Expos. Indicated?
"RTN","VAFHLZE1",72,0)
 I VAFSTR[18 S X=$P(VAF(.321),"^",2),VAFHLZEL(18)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",73,0)
 ;Radiation Expos. Indicated?
"RTN","VAFHLZE1",74,0)
 I VAFSTR[19 S X=$P(VAF(.321),"^",3),VAFHLZEL(19)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",75,0)
 ;Environmental Contaminants?
"RTN","VAFHLZE1",76,0)
 I VAFSTR[20 S X=$P(VAF(.322),"^",13),VAFHLZEL(20)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",77,0)
 ;Total Annual VA Check Amount
"RTN","VAFHLZE1",78,0)
 I VAFSTR[21 S X=$P(VAF(.362),"^",20),VAFHLZEL(21)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",79,0)
 ;Radiation Exposure Method
"RTN","VAFHLZE1",80,0)
 I (VAFSTR[22) D
"RTN","VAFHLZE1",81,0)
 .S X=$P(VAF(.321),"^",12)
"RTN","VAFHLZE1",82,0)
 .S:(X="")!($L(X)>1) X=HLQ
"RTN","VAFHLZE1",83,0)
 .S:(X'=HLQ) X=$TR(X,"NTB","234")
"RTN","VAFHLZE1",84,0)
 .S VAFHLZEL(22)=X
"RTN","VAFHLZE1",85,0)
 ;Call MST status API
"RTN","VAFHLZE1",86,0)
 S VAFMST=$$GETSTAT^DGMSTAPI(DFN,$G(VAFMSTDT))
"RTN","VAFHLZE1",87,0)
 I $P(VAFMST,"^",1)<0 D  I 1
"RTN","VAFHLZE1",88,0)
 .F J=23,24,25 I VAFSTR[J S VAFHLZEL(J)=HLQ
"RTN","VAFHLZE1",89,0)
 E  D
"RTN","VAFHLZE1",90,0)
 .;Current MST status
"RTN","VAFHLZE1",91,0)
 .I VAFSTR[23 S X=$P(VAFMST,"^",2),VAFHLZEL(23)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",92,0)
 .;MST status change date
"RTN","VAFHLZE1",93,0)
 .I VAFSTR[24 S X=$P(VAFMST,"^",3),VAFHLZEL(24)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",94,0)
 .;Site determining MST status
"RTN","VAFHLZE1",95,0)
 .I VAFSTR[25 S X=$P(VAFMST,"^",7) S X=$$GET1^DIQ(4,(+X)_",",99) S VAFHLZEL(25)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",96,0)
 ;Agent Orange Registration Date
"RTN","VAFHLZE1",97,0)
 I VAFSTR[26 S X=$P(VAF(.321),"^",7),VAFHLZEL(26)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",98,0)
 ;Agent Orange Exam Date
"RTN","VAFHLZE1",99,0)
 I VAFSTR[27 S X=$P(VAF(.321),"^",9),VAFHLZEL(27)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",100,0)
 ;Agent Orange Registration #
"RTN","VAFHLZE1",101,0)
 I VAFSTR[28 S X=$P(VAF(.321),"^",10),VAFHLZEL(28)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",102,0)
 ;Agent Orange Exposure Location
"RTN","VAFHLZE1",103,0)
 ;I VAFSTR[29 S X=$P(VAF(.321),"^",13),VAFHLZEL(29)=$S(X]"":X,$P(VAF(.321),U,2)="Y":"U",1:HLQ)
"RTN","VAFHLZE1",104,0)
 I VAFSTR[29 S X=$P(VAF(.321),"^",13),VAFHLZEL(29)=$S(",K,V,O,"[(","_X_","):X,1:HLQ)
"RTN","VAFHLZE1",105,0)
 ;Radiation Registration Date
"RTN","VAFHLZE1",106,0)
 I VAFSTR[30 S X=$P(VAF(.321),"^",11),VAFHLZEL(30)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",107,0)
 ;Envir. Cont. Exam Date
"RTN","VAFHLZE1",108,0)
 I VAFSTR[31 S X=$P(VAF(.322),"^",15),VAFHLZEL(31)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",109,0)
 ;Envir. Cont. Registration date
"RTN","VAFHLZE1",110,0)
 I VAFSTR[32 S X=$P(VAF(.322),"^",14),VAFHLZEL(32)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",111,0)
 ;Monetary Ben. Verify Date
"RTN","VAFHLZE1",112,0)
 I VAFSTR[33 S X=$P(VAF(.3),"^",6),VAFHLZEL(33)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",113,0)
 ;User Enrollee Valid Through
"RTN","VAFHLZE1",114,0)
 I VAFSTR[34 S X=$P(VAF(.361),"^",7),VAFHLZEL(34)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",115,0)
 ;User Enrollee Site
"RTN","VAFHLZE1",116,0)
 I VAFSTR[35 S X=$P(VAF(.361),"^",8),X=$$GET1^DIQ(4,+X,99),VAFHLZEL(35)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",117,0)
 ;Combat Vet
"RTN","VAFHLZE1",118,0)
 I (VAFSTR[37)!(VAFSTR[38) D
"RTN","VAFHLZE1",119,0)
 .N CVET
"RTN","VAFHLZE1",120,0)
 .S CVET=$$CVEDT^DGCV(DFN)
"RTN","VAFHLZE1",121,0)
 .;Eligible
"RTN","VAFHLZE1",122,0)
 .I VAFSTR[37 D
"RTN","VAFHLZE1",123,0)
 ..S X=+CVET
"RTN","VAFHLZE1",124,0)
 ..S:X<0 X=""
"RTN","VAFHLZE1",125,0)
 ..S VAFHLZEL(37)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ)
"RTN","VAFHLZE1",126,0)
 .;End Date
"RTN","VAFHLZE1",127,0)
 .I VAFSTR[38 D
"RTN","VAFHLZE1",128,0)
 ..S X=+$P(CVET,"^",2)
"RTN","VAFHLZE1",129,0)
 ..S VAFHLZEL(38)=$S(X:$$HLDATE^HLFNC(X),1:HLQ)
"RTN","VAFHLZE1",130,0)
 ;Discharge Due To Disability
"RTN","VAFHLZE1",131,0)
 I VAFSTR[39 S X=$P(VAFPELIG,"^",13),VAFHLZEL(39)=$S(X=0:"N",X=1:"Y",1:HLQ)
"RTN","VAFHLZE1",132,0)
 ;SHAD Indicator
"RTN","VAFHLZE1",133,0)
 I VAFSTR[40 S X=$P(VAF(.321),"^",15),VAFHLZEL(40)=$S(X=0:"N",X=1:"Y",1:HLQ)
"RTN","VAFHLZE1",134,0)
 ;CAMP LEJEUNE ELIGIBILITY INDICATOR DG*5.3*909 
"RTN","VAFHLZE1",135,0)
 S X=$P(VAF(.3217),"^",1),VAFHLZEL(41)=$S(X="Y":1,X="N":0,1:HLQ)
"RTN","VAFHLZE1",136,0)
 ;CAMP LEJEUNE ELIGIBILITY DATE REGISTERED
"RTN","VAFHLZE1",137,0)
 I VAFSTR[42 S X=$P(VAF(.3217),"^",2),VAFHLZEL(42)=$S(X]"":$P($$HLDATE^HLFNC(X,"DT"),"^",1),1:HLQ)
"RTN","VAFHLZE1",138,0)
 ;CAMP LEJEUNE ELIGIBILITY CHANGE SITE
"RTN","VAFHLZE1",139,0)
 I VAFSTR[43 S X=$P(VAF(.3217),"^",3),VAFHLZEL(43)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",140,0)
 ;CAMP LEJEUNE ELIGIBILITY SOURCE OF CHANGE 
"RTN","VAFHLZE1",141,0)
 I VAFSTR[44 S X=$P(VAF(.3217),"^",4),VAFHLZEL(44)=$S(X]"":X,1:HLQ)
"RTN","VAFHLZE1",142,0)
 ;Done
"RTN","VAFHLZE1",143,0)
 Q
"VER")
8.0^22.0
"^DD",2,2,.321701,0)
CAMP LEJEUNE^S^Y:YES;N:NO;^.3217;1^Q
"^DD",2,2,.321701,.1)
CAMP LEJEUNE ELIGIBILITY INDICATOR
"^DD",2,2,.321701,3)
Enter "Y" if there is sufficient evidence that the Veteran was housed at Camp Lejeune for a minimum of 30 days between and inclusive of August 1, 1953 and December 31, 1987.  Otherwise, enter "N".
"^DD",2,2,.321701,21,0)
^^6^6^3150313^
"^DD",2,2,.321701,21,1,0)
This field should be set to Yes if the Patient is housed at Camp Lejeune,
"^DD",2,2,.321701,21,2,0)
was a Veteran, and has 1 or more Military Service Episodes (MSEs) with a
"^DD",2,2,.321701,21,3,0)
Character of Discharge other than Dishonorable, Other Than Honorable,
"^DD",2,2,.321701,21,4,0)
Undesirable, Bad Conduct, or Dishonorable-VA and these MSEs were between
"^DD",2,2,.321701,21,5,0)
August 1, 1953 and December 31, 1987, adding up to 30 days of service
"^DD",2,2,.321701,21,6,0)
or greater.
"^DD",2,2,.321701,23,0)
^.001^2^2^3150311^^^^
"^DD",2,2,.321701,23,1,0)
This field is a SET OF CODES field which can be Y - YES or N - NO and
"^DD",2,2,.321701,23,2,0)
represents whether the Patient is Camp Lejeune eligible or not.
"^DD",2,2,.321701,"DT")
3150313
"^DD",2,2,.321702,0)
CAMP LEJEUNE DATE^DI^^.3217;2^S %DT="EX" D ^%DT S X=Y K:Y<1 X
"^DD",2,2,.321702,.1)
CAMP LEJEUNE ELIGIBILITY DATE REGISTERED
"^DD",2,2,.321702,3)
This is the date when the CAMP LEJEUNE ELIGIBILITY INDICATOR field was last changed.
"^DD",2,2,.321702,21,0)
^^2^2^3150313^
"^DD",2,2,.321702,21,1,0)
This is the system generated date noting when the CAMP LEJEUNE
"^DD",2,2,.321702,21,2,0)
ELIGIBILITY INDICATOR field was last changed.
"^DD",2,2,.321702,23,0)
^.001^1^1^3150303^^^^
"^DD",2,2,.321702,23,1,0)
This field is System Generated and should never be entered in by a user.
"^DD",2,2,.321702,"DT")
3150313
"^DD",2,2,.321703,0)
CAMP LEJEUNE CHANGE SITE^FI^^.3217;3^K:$L(X)>10!($L(X)<3) X
"^DD",2,2,.321703,.1)
CAMP LEJEUNE ELIGIBILITY CHANGE SITE
"^DD",2,2,.321703,3)
Answer must be 3-10 characters in length.
"^DD",2,2,.321703,21,0)
^^2^2^3150313^
"^DD",2,2,.321703,21,1,0)
The System Generated point-of-entry site that last changed the CAMP LEJEUNE
"^DD",2,2,.321703,21,2,0)
ELIGIBILITY INDICATOR field.
"^DD",2,2,.321703,23,0)
^.001^1^1^3150123^^
"^DD",2,2,.321703,23,1,0)
This field is System Generated and should never be entered in by a user.
"^DD",2,2,.321703,"DT")
3150313
"^DD",2,2,.321704,0)
CAMP LEJEUNE SOURCE^FI^^.3217;4^K:$L(X)>10!($L(X)<3) X
"^DD",2,2,.321704,.1)
CAMP LEJEUNE ELIGIBILITY SOURCE OF CHANGE
"^DD",2,2,.321704,3)
Answer must be 3-10 characters in length.
"^DD",2,2,.321704,21,0)
^^2^2^3150313^
"^DD",2,2,.321704,21,1,0)
The System Generated source that last affected a change to the CAMP LEJEUNE
"^DD",2,2,.321704,21,2,0)
ELIGIBILITY INDICATOR field.
"^DD",2,2,.321704,23,0)
^.001^1^1^3150123^^
"^DD",2,2,.321704,23,1,0)
This field is System Generated and should never be entered in by a user.
"^DD",2,2,.321704,"DT")
3150313
"^DD",2,2,.32171,0)
CAMP LEJEUNE DATA ENTRY LOCKED^SI^1:LOCKED;0:NOT LOCKED;^.32171;1^Q
"^DD",2,2,.32171,3)
Enter 1 to Lock or 0 to unlock Camp Lejeune data entry.
"^DD",2,2,.32171,21,0)
^^3^3^3150313^
"^DD",2,2,.32171,21,1,0)
This is the master field to control entry of Camp Lejeune data into the
"^DD",2,2,.32171,21,2,0)
Patient record.  If 1 then CAMP LEJEUNE ELIGIBILITY data cannot be
"^DD",2,2,.32171,21,3,0)
entered.  If 0, it can.
"^DD",2,2,.32171,23,0)
3^.001^3^3^3141204^
"^DD",2,2,.32171,23,1,0)
This is the master field to control entry of Camp Lejeune data into the
"^DD",2,2,.32171,23,2,0)
.3217 node.  If 1 then CAMP LEJEUNE ELIGIBILITY data cannot be entered
"^DD",2,2,.32171,23,3,0)
into this node. If 0, then it can.
"^DD",2,2,.32171,"DT")
3150313
"^DD",27.11,27.11,50.24,0)
CAMP LEJEUNE INDICATED?^S^Y:YES;N:NO;^E;24^Q
"^DD",27.11,27.11,50.24,.1)
CAMP LEJEUNE ELIGIBILITY INDICATOR
"^DD",27.11,27.11,50.24,3)
Enter "Y" if there is sufficient evidence that the Veteran was housed at Camp Lejeune for a minimum of 30 days between and inclusive of August 1, 1953 and December 31, 1987.  Otherwise, enter "N".
"^DD",27.11,27.11,50.24,21,0)
^^3^3^3150313^
"^DD",27.11,27.11,50.24,21,1,0)
This field corresponds to the CAMP LEJEUNE (#.321701) field in the PATIENT
"^DD",27.11,27.11,50.24,21,2,0)
File #2.  It can be set by setting the Camp Lejeune Eligibility Indicator
"^DD",27.11,27.11,50.24,21,3,0)
on the Registration Screens, or by the Z11 Upload from the HEC.
"^DD",27.11,27.11,50.24,"DT")
3150313
"^DD",27.11,27.11,50.25,0)
CAMP LEJEUNE DATE^DI^^E;25^S %DT="EX" D ^%DT S X=Y K:Y<1 X
"^DD",27.11,27.11,50.25,.1)
CAMP LEJEUNE ELIGIBILITY DATE REGISTERED
"^DD",27.11,27.11,50.25,3)
This is the date when the CAMP LEJEUNE ELIGIBILITY INDICATOR field was last changed.
"^DD",27.11,27.11,50.25,21,0)
^^2^2^3150313^
"^DD",27.11,27.11,50.25,21,1,0)
This is the system generated date noting when the CAMP LEJEUNE
"^DD",27.11,27.11,50.25,21,2,0)
ELIGIBILITY INDICATOR field was last changed.
"^DD",27.11,27.11,50.25,23,0)
^^1^1^3150303^
"^DD",27.11,27.11,50.25,23,1,0)
This field is System Generated and should never be entered in by a user.
"^DD",27.11,27.11,50.25,"DT")
3150313
"^DD",27.11,27.11,50.26,0)
CAMP LEJEUNE CHANGE SITE^FI^^E;26^K:$L(X)>10!($L(X)<3) X
"^DD",27.11,27.11,50.26,.1)
CAMP LEJEUNE ELIGIBILITY CHANGE SITE
"^DD",27.11,27.11,50.26,3)
Answer must be 3-10 characters in length.
"^DD",27.11,27.11,50.26,21,0)
^^2^2^3150313^
"^DD",27.11,27.11,50.26,21,1,0)
The System Generated point-of-entry site that last changed the CAMP
"^DD",27.11,27.11,50.26,21,2,0)
LEJEUNE ELIGIBILITY INDICATOR field.
"^DD",27.11,27.11,50.26,23,0)
^.001^1^1^3150123^^^
"^DD",27.11,27.11,50.26,23,1,0)
This field is System Generated and should never be entered in by a user.
"^DD",27.11,27.11,50.26,"DT")
3150313
"^DD",27.11,27.11,50.27,0)
CAMP LEJEUNE SOURCE^FI^^E;27^K:$L(X)>10!($L(X)<3) X
"^DD",27.11,27.11,50.27,.1)
CAMP LEJEUNE ELIGIBILITY SOURCE OF CHANGE
"^DD",27.11,27.11,50.27,3)
Answer must be 3-10 characters in length.
"^DD",27.11,27.11,50.27,21,0)
^.001^2^2^3150123^^^^
"^DD",27.11,27.11,50.27,21,1,0)
The System Generated source that last affected a change to the CAMP 
"^DD",27.11,27.11,50.27,21,2,0)
LEJEUNE ELIGIBILITY INDICATOR field.
"^DD",27.11,27.11,50.27,23,0)
^.001^1^1^3150123^^
"^DD",27.11,27.11,50.27,23,1,0)
This field is System Generated and should never be entered in by a user.
"^DD",27.11,27.11,50.27,"DT")
3150123
**INSTALL NAME**
IVM*2.0*161
"BLD",9244,0)
IVM*2.0*161^INCOME VERIFICATION MATCH^0^3150831^y
"BLD",9244,1,0)
^^3^3^3150126^
"BLD",9244,1,1,0)
Related to DG*5.3*909
"BLD",9244,1,2,0)
IVM*2.0*161 will update the Registration application to allow for the
"BLD",9244,1,3,0)
entering and maintenance of the Camp Lejeune Eligibility related data.
"BLD",9244,4,0)
^9.64PA^^
"BLD",9244,6.3)
24
"BLD",9244,"ABPKG")
n
"BLD",9244,"KRN",0)
^9.67PA^779.2^20
"BLD",9244,"KRN",.4,0)
.4
"BLD",9244,"KRN",.401,0)
.401
"BLD",9244,"KRN",.402,0)
.402
"BLD",9244,"KRN",.403,0)
.403
"BLD",9244,"KRN",.5,0)
.5
"BLD",9244,"KRN",.84,0)
.84
"BLD",9244,"KRN",3.6,0)
3.6
"BLD",9244,"KRN",3.8,0)
3.8
"BLD",9244,"KRN",9.2,0)
9.2
"BLD",9244,"KRN",9.8,0)
9.8
"BLD",9244,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",9244,"KRN",9.8,"NM",1,0)
IVMPTRN8^^0^B78004542
"BLD",9244,"KRN",9.8,"NM","B","IVMPTRN8",1)

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

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

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

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

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

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

"BLD",9244,"KRN","B",3.6,3.6)

"BLD",9244,"KRN","B",3.8,3.8)

"BLD",9244,"KRN","B",9.2,9.2)

"BLD",9244,"KRN","B",9.8,9.8)

"BLD",9244,"KRN","B",19,19)

"BLD",9244,"KRN","B",19.1,19.1)

"BLD",9244,"KRN","B",101,101)

"BLD",9244,"KRN","B",409.61,409.61)

"BLD",9244,"KRN","B",771,771)

"BLD",9244,"KRN","B",779.2,779.2)

"BLD",9244,"KRN","B",870,870)

"BLD",9244,"KRN","B",8989.51,8989.51)

"BLD",9244,"KRN","B",8989.52,8989.52)

"BLD",9244,"KRN","B",8994,8994)

"BLD",9244,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9244,"QUES",0)
^9.62^^
"BLD",9244,"REQB",0)
^9.611^3^3
"BLD",9244,"REQB",1,0)
DG*5.3*909^2
"BLD",9244,"REQB",2,0)
IVM*2.0*160^2
"BLD",9244,"REQB",3,0)
DG*5.3*891^2
"BLD",9244,"REQB","B","DG*5.3*891",3)

"BLD",9244,"REQB","B","DG*5.3*909",1)

"BLD",9244,"REQB","B","IVM*2.0*160",2)

"MBREQ")
0
"PKG",312,-1)
1^1
"PKG",312,0)
INCOME VERIFICATION MATCH^IVM^IVM Software for interface with the IVM Center
"PKG",312,22,0)
^9.49I^1^1
"PKG",312,22,1,0)
2.0^2941021^2941102
"PKG",312,22,1,"PAH",1,0)
161^3150831^11933
"PKG",312,22,1,"PAH",1,1,0)
^^3^3^3150831
"PKG",312,22,1,"PAH",1,1,1,0)
Related to DG*5.3*909
"PKG",312,22,1,"PAH",1,1,2,0)
IVM*2.0*161 will update the Registration application to allow for the
"PKG",312,22,1,"PAH",1,1,3,0)
entering and maintenance of the Camp Lejeune Eligibility related data.
"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")
1
"RTN","IVMPTRN8")
0^1^B78004542
"RTN","IVMPTRN8",1,0)
IVMPTRN8 ;ALB/RKS/PDJ/BRM,TDM,PJH,TDM,PWC,LBD - HL7 FULL DATA TRANSMISSION (Z07) BUILDER ; 8/11/11 5:27pm
"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**; 21-OCT-94;Build 24
"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)
 S (ZMHSQ,SETID)=0
"RTN","IVMPTRN8",108,0)
 I $D(IVMZMH) F  S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ=""  D
"RTN","IVMPTRN8",109,0)
 . Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")=""
"RTN","IVMPTRN8",110,0)
 . S SETID=SETID+1,IVMCT=IVMCT+1
"RTN","IVMPTRN8",111,0)
 . S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6)
"RTN","IVMPTRN8",112,0)
 ;
"RTN","IVMPTRN8",113,0)
 ; create (ZRD) Rated Disabilities segment(s)
"RTN","IVMPTRN8",114,0)
 D EN^VAFHLZRD(DFN,"1,2,3,4,12,13,14,",HLQ,HLFS,"IVMZRD")
"RTN","IVMPTRN8",115,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",116,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0))
"RTN","IVMPTRN8",117,0)
 ;
"RTN","IVMPTRN8",118,0)
 ; create (ZCT) Emergency Contact segment
"RTN","IVMPTRN8",119,0)
 ;S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1)
"RTN","IVMPTRN8",120,0)
 K ZCTARY F ZCTTYP=1:1:5 D   ;Create Optional ZCT Segments
"RTN","IVMPTRN8",121,0)
 . S ZCTARY(ZCTTYP)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",ZCTTYP,1)
"RTN","IVMPTRN8",122,0)
 S (ZCTTYP,ZCTSQ)=0
"RTN","IVMPTRN8",123,0)
 I $D(ZCTARY) F  S ZCTTYP=$O(ZCTARY(ZCTTYP)) Q:ZCTTYP=""  D
"RTN","IVMPTRN8",124,0)
 . Q:$P(ZCTARY(ZCTTYP),HLFS,11)=HLQ
"RTN","IVMPTRN8",125,0)
 . S ZCTSQ=ZCTSQ+1,$P(ZCTARY(ZCTTYP),HLFS,2)=ZCTSQ
"RTN","IVMPTRN8",126,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(ZCTTYP)
"RTN","IVMPTRN8",127,0)
 I ZCTSQ=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(1)
"RTN","IVMPTRN8",128,0)
 ;
"RTN","IVMPTRN8",129,0)
 ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse
"RTN","IVMPTRN8",130,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7")
"RTN","IVMPTRN8",131,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7",2,2)
"RTN","IVMPTRN8",132,0)
 ;
"RTN","IVMPTRN8",133,0)
 ; create (ZGD) Guardian segment for (1) VA & (2) Civil 
"RTN","IVMPTRN8",134,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1)
"RTN","IVMPTRN8",135,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2)
"RTN","IVMPTRN8",136,0)
 ;
"RTN","IVMPTRN8",137,0)
 ; Income Year requiring transmission from IVM Patient File (301.5)
"RTN","IVMPTRN8",138,0)
 S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000))
"RTN","IVMPTRN8",139,0)
 N MTINFO S MTINFO=$$FUT^DGMTU(DFN)
"RTN","IVMPTRN8",140,0)
 I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2)
"RTN","IVMPTRN8",141,0)
 ;get the primary test for the income year
"RTN","IVMPTRN8",142,0)
 S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN)
"RTN","IVMPTRN8",143,0)
 ;
"RTN","IVMPTRN8",144,0)
 ; The following function call returns:
"RTN","IVMPTRN8",145,0)
 ;   - Patient Relation IEN array in DGREL
"RTN","IVMPTRN8",146,0)
 ;   - Individual Annual Income IEN array in DGINC
"RTN","IVMPTRN8",147,0)
 ;   - Income Relation IEN array in DGINR
"RTN","IVMPTRN8",148,0)
 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN)
"RTN","IVMPTRN8",149,0)
 ;
"RTN","IVMPTRN8",150,0)
 S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1
"RTN","IVMPTRN8",151,0)
 ; create (ZIC) Income segment for veteran
"RTN","IVMPTRN8",152,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",153,0)
 ;IVM*2.0*115 -- Check for Means Test Version Indicator
"RTN","IVMPTRN8",154,0)
 N MTVERS S MTVERS=$S(+$G(ACTVIEN):+$P($G(^DGMT(408.31,ACTVIEN,2)),"^",11),1:0)
"RTN","IVMPTRN8",155,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",156,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",157,0)
 E  D
"RTN","IVMPTRN8",158,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,9,12,13,14,15,16,18,19")
"RTN","IVMPTRN8",159,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",160,0)
 ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct
"RTN","IVMPTRN8",161,0)
 S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY)
"RTN","IVMPTRN8",162,0)
 ;
"RTN","IVMPTRN8",163,0)
 ; create (ZIR) Income Relation segment for veteran
"RTN","IVMPTRN8",164,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",165,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1"
"RTN","IVMPTRN8",166,0)
 ;
"RTN","IVMPTRN8",167,0)
 ; create (ZDP) Patient Dependent Info. segment for spouse
"RTN","IVMPTRN8",168,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",169,0)
 I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",170,0)
 . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",171,0)
 . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",172,0)
 ;
"RTN","IVMPTRN8",173,0)
 ; create (ZIC) Income segment for spouse
"RTN","IVMPTRN8",174,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",175,0)
 ;IVM*2.0*115
"RTN","IVMPTRN8",176,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",177,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",178,0)
 E  D
"RTN","IVMPTRN8",179,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,9,12,16,18,19")
"RTN","IVMPTRN8",180,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",181,0)
 ;
"RTN","IVMPTRN8",182,0)
 ; create (ZIR) Income Relation segment for spouse
"RTN","IVMPTRN8",183,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3")
"RTN","IVMPTRN8",184,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",185,0)
 ;
"RTN","IVMPTRN8",186,0)
 ;
"RTN","IVMPTRN8",187,0)
 ; create ZDP, ZIC, and ZIR segments for all Means Test dependents
"RTN","IVMPTRN8",188,0)
 F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",189,0)
 . ;
"RTN","IVMPTRN8",190,0)
 . ; - create (ZDP) Dependent Info. segment for dependent child
"RTN","IVMPTRN8",191,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",192,0)
 . I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",193,0)
 . . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",194,0)
 . . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",195,0)
 . ;
"RTN","IVMPTRN8",196,0)
 . ; - create (ZIC) Income segment for dependent child
"RTN","IVMPTRN8",197,0)
 . S IVMCT=IVMCT+1
"RTN","IVMPTRN8",198,0)
 . ;IVM*2.0*115
"RTN","IVMPTRN8",199,0)
 . I MTVERS=0 D  I 1
"RTN","IVMPTRN8",200,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",201,0)
 . E  D
"RTN","IVMPTRN8",202,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,9,12,15,16,18,19")
"RTN","IVMPTRN8",203,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",204,0)
 . ;
"RTN","IVMPTRN8",205,0)
 . ; - create (ZIR) Income Relation segment for dependent child
"RTN","IVMPTRN8",206,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",207,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",208,0)
 . ;
"RTN","IVMPTRN8",209,0)
 ; Send INACTIVE spouse/dependents.
"RTN","IVMPTRN8",210,0)
 D GETINACD^DGMTU11(DFN,.DGREL)
"RTN","IVMPTRN8",211,0)
 F I="S","C" D
"RTN","IVMPTRN8",212,0)
 . F IVMSUB=0:0 S IVMSUB=$O(DGIREL(I,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",213,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",214,0)
 ;
"RTN","IVMPTRN8",215,0)
 D GOTO^IVMPTRN9
"RTN","IVMPTRN8",216,0)
 Q
"RTN","IVMPTRN8",217,0)
 ;
"RTN","IVMPTRN8",218,0)
STRIP11 N APID,ZPID,ASQ,ATYP,SSQ
"RTN","IVMPTRN8",219,0)
 ;Extract PID segment
"RTN","IVMPTRN8",220,0)
 S IVMPID(1)=$E(IVMPID(1),5,$L(IVMPID(1)))
"RTN","IVMPTRN8",221,0)
 D BLDPID^IVMPREC6(.IVMPID,.APID)
"RTN","IVMPTRN8",222,0)
 ;
"RTN","IVMPTRN8",223,0)
 S CAFLG=0
"RTN","IVMPTRN8",224,0)
 I $D(APID(11)) D
"RTN","IVMPTRN8",225,0)
 .I $O(APID(11,"")) D  Q
"RTN","IVMPTRN8",226,0)
 ..M ZPID(11)=APID(11) K APID(11)
"RTN","IVMPTRN8",227,0)
 ..S (ASQ,SSQ)=0 F  S ASQ=$O(ZPID(11,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",228,0)
 ...S ATYP=$P($G(ZPID(11,ASQ)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",229,0)
 ...I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") Q
"RTN","IVMPTRN8",230,0)
 ...I ATYP="VACAE" S CAFLG=1
"RTN","IVMPTRN8",231,0)
 ...S SSQ=SSQ+1,APID(11,SSQ)=ZPID(11,ASQ)
"RTN","IVMPTRN8",232,0)
 .Q:$G(APID(11))=""
"RTN","IVMPTRN8",233,0)
 .S ATYP=$P($G(APID(11)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",234,0)
 .I ATYP="VACAE" S CAFLG=1 Q
"RTN","IVMPTRN8",235,0)
 .I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") K APID(11)
"RTN","IVMPTRN8",236,0)
 ;
"RTN","IVMPTRN8",237,0)
 I 'CAFLG,$D(APID(13)) D
"RTN","IVMPTRN8",238,0)
 .I $O(APID(13,"")) D  Q
"RTN","IVMPTRN8",239,0)
 ..S ASQ=0 F  S ASQ=$O(APID(13,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",240,0)
 ...Q:$G(APID(13,ASQ))=""
"RTN","IVMPTRN8",241,0)
 ...S ATYP=$P($G(APID(13,ASQ)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",242,0)
 ...I ATYP="VACPN" K APID(13,ASQ) Q
"RTN","IVMPTRN8",243,0)
 .Q:$G(APID(13))=""
"RTN","IVMPTRN8",244,0)
 .S ATYP=$P($G(APID(13)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",245,0)
 .I ATYP="VACPN" K APID(13) Q
"RTN","IVMPTRN8",246,0)
 ;
"RTN","IVMPTRN8",247,0)
 ;Rebuild PID
"RTN","IVMPTRN8",248,0)
 D KVA^VADPT
"RTN","IVMPTRN8",249,0)
 D MAKEIT^VAFHLU("PID",.APID,.VAFPID,.VAFPID)
"RTN","IVMPTRN8",250,0)
 S VAFPID(0)=VAFPID
"RTN","IVMPTRN8",251,0)
 Q
"VER")
8.0^22.0
**END**
**END**