DG_53_P891.KIDs

KIDS Distribution saved on Apr 24, 2015@13:21:04
Enhance Means Test and other Patches
**KIDS**:DG*5.3*891^DG*5.3*871^DG*5.3*890^DG*5.3*904^EAS*1.0*113^IVM*2.0*160^DG*5.3*901^DG*5.3*906^

**INSTALL NAME**
DG*5.3*891
"BLD",9527,0)
DG*5.3*891^REGISTRATION^0^3150424^y
"BLD",9527,1,0)
^^19^19^3140626^^^
"BLD",9527,1,1,0)
The Health Eligibility Center (HEC) requested modifications to the 
"BLD",9527,1,2,0)
Enrollment System (ES) and VistA Registration, Enrollment and Eligibility 
"BLD",9527,1,3,0)
(VistA REE) software to support the requirements of the Means Test Report 
"BLD",9527,1,4,0)
for ES project 4.0.  
"BLD",9527,1,5,0)
 
"BLD",9527,1,6,0)
The new requirements check whether the patient means test is current or  
"BLD",9527,1,7,0)
not.  If the means test is current than the patient record is not 
"BLD",9527,1,8,0)
displayed.  
"BLD",9527,1,9,0)
 
"BLD",9527,1,10,0)
The following are the new guidelines on whether a patient means test is 
"BLD",9527,1,11,0)
current.
"BLD",9527,1,12,0)
 
"BLD",9527,1,13,0)
1. The Means Test Effective Date is between (inclusive): 1/2/2012 and 
"BLD",9527,1,14,0)
   12/31/2012
"BLD",9527,1,15,0)
2. The Mean Test Effective Date is greater than 1/1/2013 AND has a MT
"BLD",9527,1,16,0)
   Status of MT Copay Exempt, GMT Copay Required, or Pending Adjudication
"BLD",9527,1,17,0)
3. The MT Status equals MT Copay Required
"BLD",9527,1,18,0)
4. The MT Status equals No Longer Required
"BLD",9527,1,19,0)
5. The Means Test Effective Date is not a future date
"BLD",9527,4,0)
^9.64PA^^
"BLD",9527,6.3)
14
"BLD",9527,"ABPKG")
n
"BLD",9527,"KRN",0)
^9.67PA^779.2^20
"BLD",9527,"KRN",.4,0)
.4
"BLD",9527,"KRN",.401,0)
.401
"BLD",9527,"KRN",.402,0)
.402
"BLD",9527,"KRN",.403,0)
.403
"BLD",9527,"KRN",.5,0)
.5
"BLD",9527,"KRN",.84,0)
.84
"BLD",9527,"KRN",3.6,0)
3.6
"BLD",9527,"KRN",3.8,0)
3.8
"BLD",9527,"KRN",9.2,0)
9.2
"BLD",9527,"KRN",9.8,0)
9.8
"BLD",9527,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",9527,"KRN",9.8,"NM",1,0)
DGMTOFA^^0^B29409617
"BLD",9527,"KRN",9.8,"NM","B","DGMTOFA",1)

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

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

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

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

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

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

"BLD",9527,"KRN","B",3.6,3.6)

"BLD",9527,"KRN","B",3.8,3.8)

"BLD",9527,"KRN","B",9.2,9.2)

"BLD",9527,"KRN","B",9.8,9.8)

"BLD",9527,"KRN","B",19,19)

"BLD",9527,"KRN","B",19.1,19.1)

"BLD",9527,"KRN","B",101,101)

"BLD",9527,"KRN","B",409.61,409.61)

"BLD",9527,"KRN","B",771,771)

"BLD",9527,"KRN","B",779.2,779.2)

"BLD",9527,"KRN","B",870,870)

"BLD",9527,"KRN","B",8989.51,8989.51)

"BLD",9527,"KRN","B",8989.52,8989.52)

"BLD",9527,"KRN","B",8994,8994)

"BLD",9527,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",9527,"QUES",0)
^9.62^^
"BLD",9527,"REQB",0)
^9.611^3^1
"BLD",9527,"REQB",3,0)
DG*5.3*830^2
"BLD",9527,"REQB","B","DG*5.3*830",3)

"MBREQ")
0
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
891^3150424
"PKG",47,22,1,"PAH",1,1,0)
^^19^19^3150424
"PKG",47,22,1,"PAH",1,1,1,0)
The Health Eligibility Center (HEC) requested modifications to the 
"PKG",47,22,1,"PAH",1,1,2,0)
Enrollment System (ES) and VistA Registration, Enrollment and Eligibility 
"PKG",47,22,1,"PAH",1,1,3,0)
(VistA REE) software to support the requirements of the Means Test Report 
"PKG",47,22,1,"PAH",1,1,4,0)
for ES project 4.0.  
"PKG",47,22,1,"PAH",1,1,5,0)
 
"PKG",47,22,1,"PAH",1,1,6,0)
The new requirements check whether the patient means test is current or  
"PKG",47,22,1,"PAH",1,1,7,0)
not.  If the means test is current than the patient record is not 
"PKG",47,22,1,"PAH",1,1,8,0)
displayed.  
"PKG",47,22,1,"PAH",1,1,9,0)
 
"PKG",47,22,1,"PAH",1,1,10,0)
The following are the new guidelines on whether a patient means test is 
"PKG",47,22,1,"PAH",1,1,11,0)
current.
"PKG",47,22,1,"PAH",1,1,12,0)
 
"PKG",47,22,1,"PAH",1,1,13,0)
1. The Means Test Effective Date is between (inclusive): 1/2/2012 and 
"PKG",47,22,1,"PAH",1,1,14,0)
   12/31/2012
"PKG",47,22,1,"PAH",1,1,15,0)
2. The Mean Test Effective Date is greater than 1/1/2013 AND has a MT
"PKG",47,22,1,"PAH",1,1,16,0)
   Status of MT Copay Exempt, GMT Copay Required, or Pending Adjudication
"PKG",47,22,1,"PAH",1,1,17,0)
3. The MT Status equals MT Copay Required
"PKG",47,22,1,"PAH",1,1,18,0)
4. The MT Status equals No Longer Required
"PKG",47,22,1,"PAH",1,1,19,0)
5. The Means Test Effective Date is not a future date
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
1
"RTN","DGMTOFA")
0^1^B29409617
"RTN","DGMTOFA",1,0)
DGMTOFA ;ALB/CAW/AEG/PWC/DHS - Future Appointments who will require MT ; 4/21/11 10:57am
"RTN","DGMTOFA",2,0)
 ;;5.3;Registration;**3,50,182,326,426,568,725,830,891**;Aug 13, 1993;Build 14
"RTN","DGMTOFA",3,0)
 ;
"RTN","DGMTOFA",4,0)
EN ; 
"RTN","DGMTOFA",5,0)
 I '$$RANGE^DGMTUTL("F") G ENQ
"RTN","DGMTOFA",6,0)
 I '$$DIV^DGMTUTL G ENQ
"RTN","DGMTOFA",7,0)
 I '$$CLINIC^DGMTUTL G ENQ
"RTN","DGMTOFA",8,0)
 ;I '$$LETTER G ENQ
"RTN","DGMTOFA",9,0)
 W !! S %ZIS="PMQ" D ^%ZIS I POP G ENQ
"RTN","DGMTOFA",10,0)
 I '$D(IO("Q")) D MAIN G ENQ
"RTN","DGMTOFA",11,0)
 S Y=$$QUE
"RTN","DGMTOFA",12,0)
ENQ ;
"RTN","DGMTOFA",13,0)
 D:'$D(ZTQUEUED) ^%ZISC
"RTN","DGMTOFA",14,0)
 K DFN,DGAPT,DGBEG,DGCLN,DGDATE,DGDFN,DGDIV,DGEND,DGFLG,DGINFO,DGLINE,DGLST,DGMT,DGMT1,DGPAGE,DGSTOP,DGTMP,DGTMP1,DGTMP2,DGMTYPT,DGYN,DIW,DIWF,DIWR,DIWT,DN,SDFORM,SDLET,VA,VAERR,VAUTC,VAUTD,^TMP("DGMTO",$J),^TMP("DGMTL",$J)
"RTN","DGMTOFA",15,0)
 K DGARRAY,CLNARRAY,^TMP($J,"SDAMA"),I,DGTMP,SDCNT
"RTN","DGMTOFA",16,0)
 Q
"RTN","DGMTOFA",17,0)
 ;
"RTN","DGMTOFA",18,0)
QUE() ; -- que job
"RTN","DGMTOFA",19,0)
 ; return: did job que [ 1|yes   0|no ]
"RTN","DGMTOFA",20,0)
 ;
"RTN","DGMTOFA",21,0)
 K ZTSK,IO("Q")
"RTN","DGMTOFA",22,0)
 S ZTDESC="Future Appt. w/ Means Test",ZTRTN="MAIN^DGMTOFA"
"RTN","DGMTOFA",23,0)
 F X="DGBEG","DGEND","DGYN","DGMTYPT","SDFORM","SDLET","VAUTC","VAUTD","VAUTC(","VAUTD(" S ZTSAVE(X)=""
"RTN","DGMTOFA",24,0)
 D ^%ZTLOAD W:$D(ZTSK) "   (Task: ",ZTSK,")"
"RTN","DGMTOFA",25,0)
 Q $D(ZTSK)
"RTN","DGMTOFA",26,0)
 ;
"RTN","DGMTOFA",27,0)
MAIN ; 
"RTN","DGMTOFA",28,0)
 K ^TMP("DGMTO",$J) S I=1
"RTN","DGMTOFA",29,0)
 I VAUTC=1,VAUTD=1 S DGCLN=0 F  S DGCLN=$O(^SC(DGCLN)) Q:'DGCLN  I $P(^(DGCLN,0),U,3)="C" D CBLD3(DGCLN)
"RTN","DGMTOFA",30,0)
 ;
"RTN","DGMTOFA",31,0)
 I VAUTC=1,VAUTD=0 S DGDIV="" F  S DGDIV=$O(VAUTD(DGDIV)) Q:'DGDIV  S DGCLN=0 F  S DGCLN=$O(^SC(DGCLN)) Q:'DGCLN  I $P(^SC(DGCLN,0),U,3)="C",$P(^SC(DGCLN,0),U,15)=DGDIV D CBLD3(DGCLN)
"RTN","DGMTOFA",32,0)
 I VAUTC=0 S DGCLN="" F  S DGCLN=$O(VAUTC(DGCLN)) Q:'DGCLN  D CBLD3(DGCLN)
"RTN","DGMTOFA",33,0)
 D SDAM,CLN1
"RTN","DGMTOFA",34,0)
 D ^DGMTOFA1
"RTN","DGMTOFA",35,0)
 D CLOSE^DGMTUTL
"RTN","DGMTOFA",36,0)
 Q
"RTN","DGMTOFA",37,0)
 ;
"RTN","DGMTOFA",38,0)
CBLD3(DGCLN) ; Build array of specified Clinics for specified Divisions
"RTN","DGMTOFA",39,0)
 S CLNARRAY(I)=$G(CLNARRAY(I))_DGCLN_";"
"RTN","DGMTOFA",40,0)
 I $L(CLNARRAY(I))>120 S I=I+1
"RTN","DGMTOFA",41,0)
 Q
"RTN","DGMTOFA",42,0)
 ;
"RTN","DGMTOFA",43,0)
SDAM ; Build TMP Global with Appointment API Data for Report
"RTN","DGMTOFA",44,0)
 S DGARRAY(1)=DGBEG_";"_DGEND
"RTN","DGMTOFA",45,0)
 S DGARRAY("FLDS")="1;3;10"
"RTN","DGMTOFA",46,0)
 F I=1:1 Q:'$D(CLNARRAY(I))  D
"RTN","DGMTOFA",47,0)
 .S DGARRAY(2)=CLNARRAY(I)
"RTN","DGMTOFA",48,0)
 .I $$SDAPI^SDAMA301(.DGARRAY)>0 M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301")
"RTN","DGMTOFA",49,0)
 .K ^TMP($J,"SDAMA301")
"RTN","DGMTOFA",50,0)
 Q
"RTN","DGMTOFA",51,0)
 ;
"RTN","DGMTOFA",52,0)
CLN1 ; Loop through appointments
"RTN","DGMTOFA",53,0)
 ;
"RTN","DGMTOFA",54,0)
 N DGTMP S DGDATE=DGBEG-.1,DGLST=DGEND+.9
"RTN","DGMTOFA",55,0)
 S DGCLN=0 F  S DGCLN=$O(^TMP($J,"SDAMA",DGCLN)) Q:'DGCLN  D
"RTN","DGMTOFA",56,0)
 .S DGDFN=0 F  S DGDFN=$O(^TMP($J,"SDAMA",DGCLN,DGDFN)) Q:'DGDFN  D
"RTN","DGMTOFA",57,0)
 ..S DGDATE=0 F  S DGDATE=$O(^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE)) Q:'DGDATE  D
"RTN","DGMTOFA",58,0)
 ...S DGTMP=^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE)
"RTN","DGMTOFA",59,0)
 ...Q:$$DOM(DGDFN,DGDATE)
"RTN","DGMTOFA",60,0)
 ...Q:"^NS^NSR^CC^CCR^CP^CPR^"[(U_$P($P(DGTMP,U,3),";")_U)
"RTN","DGMTOFA",61,0)
 ...D MT
"RTN","DGMTOFA",62,0)
 Q
"RTN","DGMTOFA",63,0)
MT ; Is patient going to need to complete a MT/Copay by appt?
"RTN","DGMTOFA",64,0)
  S DGMT=$$LST^DGMTU(DGDFN,$P(DGDATE,"."),DGMTYPT),DGMT1=$P($G(^DGMT(408.31,+DGMT,0)),U,3) I DGMT1,"^3^10^"'[("^"_DGMT1_"^") D
"RTN","DGMTOFA",65,0)
 . N MTQ,X S MTQ=0  ; only do the following for RX Co-pay tests
"RTN","DGMTOFA",66,0)
 .I DGMTYPT=2 D  Q:MTQ=1
"RTN","DGMTOFA",67,0)
 .. ;Exclude from report the following:
"RTN","DGMTOFA",68,0)
 .. ;Existing RX Copay Test with Source of Test = IVM AND
"RTN","DGMTOFA",69,0)
 .. ;Primary eligibility code = NSC OR Primary eligibility code =
"RTN","DGMTOFA",70,0)
 .. ; SC Less than 50% and percentage is 0 and Total VA check amt = 0
"RTN","DGMTOFA",71,0)
 .. ;  DG*5.3*830
"RTN","DGMTOFA",72,0)
 .. I $P($G(^DGMT(408.31,+DGMT,0)),U,23)'=2 Q  ; quit if not IVM
"RTN","DGMTOFA",73,0)
 .. S X=$P($G(^DPT(DGDFN,.36)),"^",1)
"RTN","DGMTOFA",74,0)
 .. I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DGDFN)) S MTQ=1
"RTN","DGMTOFA",75,0)
 .S X1=$P(DGMT,U,2),X2=365 D C^%DTC I $P(DGDATE,".")<X,$S(DGMT1=1:0,DGMT1=9:0,1:1) Q
"RTN","DGMTOFA",76,0)
 .;Check to see if Cat C/Pend Adj agreed to pay with test date >10/5/99
"RTN","DGMTOFA",77,0)
 .I $P(DGMT,U,2)>2991005,$P($G(^DGMT(408.31,+DGMT,0)),U,11)=1,((DGMT1=6)!(DGMT1=2)) Q
"RTN","DGMTOFA",78,0)
 .;Check to see if Cat C, declined to provide income info but agreed to
"RTN","DGMTOFA",79,0)
 .;pay -- no date restrictions on these types.
"RTN","DGMTOFA",80,0)
 .I $G(DGMT1)=6,+$P($G(^DGMT(408.31,+DGMT,0)),U,14),+$P($G(^DGMT(408.31,+DGMT,0)),U,11) Q
"RTN","DGMTOFA",81,0)
 .; checking for future means test based on DT
"RTN","DGMTOFA",82,0)
 .;
"RTN","DGMTOFA",83,0)
 .; DG*5.3*891 - test whether patient is current
"RTN","DGMTOFA",84,0)
 .I $P(DGMT,U,2)>3120101&($P(DGMT,U,2)<3130101) Q  ; test effective date range   1 or 9 value
"RTN","DGMTOFA",85,0)
 .I $P(DGMT,U,2)>3121231,"^4^11^16^"[("^"_DGMT1_"^") Q  ; MT status = Copay exempt,GMT Copay requred,Pending Adjudication
"RTN","DGMTOFA",86,0)
 .I DGMT1=6!(DGMT1=3) Q  ;MT Copay required and and No longer required
"RTN","DGMTOFA",87,0)
 .;
"RTN","DGMTOFA",88,0)
 .N DGNXTMT
"RTN","DGMTOFA",89,0)
 .S DGNXTMT=$O(^IVM(301.5,"AE",DGDFN,DT))
"RTN","DGMTOFA",90,0)
 .I 'DGNXTMT S DGNXTMT=""
"RTN","DGMTOFA",91,0)
 .S ^TMP("DGMTO",$J,$S(+$P(^SC(DGCLN,0),U,15):$P(^(0),U,15),1:$O(^DG(40.8,0))),$P(^SC(DGCLN,0),U),$P(^DPT(DGDFN,0),U),DGDATE)=DGDFN_U_$P(DGMT,U,1,4)_U_$P($P(DGTMP,U,10),";")_U_DGNXTMT,^TMP("DGMTL",$J,$P(^DPT(DGDFN,0),U),DGDFN)=""
"RTN","DGMTOFA",92,0)
 Q
"RTN","DGMTOFA",93,0)
 ;
"RTN","DGMTOFA",94,0)
SC(DFN) ; Check if patient is SC 0% non-compensable
"RTN","DGMTOFA",95,0)
 ; Input -- DFN       Patient IEN
"RTN","DGMTOFA",96,0)
 ; Output -- 1=Yes and 0=No
"RTN","DGMTOFA",97,0)
 N Y
"RTN","DGMTOFA",98,0)
 S Y=0
"RTN","DGMTOFA",99,0)
 ; Primary eligibility is SC LESS THAN 50%
"RTN","DGMTOFA",100,0)
 I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
"RTN","DGMTOFA",101,0)
 G:'Y SCQ
"RTN","DGMTOFA",102,0)
 ; Service connected percentage is zero
"RTN","DGMTOFA",103,0)
 I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
"RTN","DGMTOFA",104,0)
 ; No Total annual VA check amount
"RTN","DGMTOFA",105,0)
 I $P($G(^DPT(DFN,.362)),"^",20) S Y=0
"RTN","DGMTOFA",106,0)
SCQ Q +$G(Y)
"RTN","DGMTOFA",107,0)
 ;
"RTN","DGMTOFA",108,0)
LETTER() ;
"RTN","DGMTOFA",109,0)
 ;   Input - none
"RTN","DGMTOFA",110,0)
 ;  Output - DGYN - yes/no
"RTN","DGMTOFA",111,0)
 ;
"RTN","DGMTOFA",112,0)
 N %
"RTN","DGMTOFA",113,0)
LTR W !!,"Do you want to generate letters" S %=2 D YN^DICN
"RTN","DGMTOFA",114,0)
 ;I %=1 D START^DGMTLTR S DGYN=$S('$D(DGFLG):1,1:0)
"RTN","DGMTOFA",115,0)
 I %=2 S DGYN=0
"RTN","DGMTOFA",116,0)
 I %=0 W !!,"Enter 'Y'es to generate letters from the listing or",!,"Enter 'N'o to produce the listing, but not the letters." G LTR
"RTN","DGMTOFA",117,0)
 Q $D(DGYN)
"RTN","DGMTOFA",118,0)
 ;
"RTN","DGMTOFA",119,0)
DOM(DFN,DGT) ; Screen out dom patient
"RTN","DGMTOFA",120,0)
 ;         Input:   DFN - Patient IEN
"RTN","DGMTOFA",121,0)
 ;                  DGT - Date of visit
"RTN","DGMTOFA",122,0)
 ;
"RTN","DGMTOFA",123,0)
 N Y,DGI,DGXFR0,DGA1,DGINP
"RTN","DGMTOFA",124,0)
 S Y=0
"RTN","DGMTOFA",125,0)
 D ^DGINPW I DG1 I $P(^DG(43,1,0),U,21),$D(^DIC(42,+DG1,0)),$P(^(0),U,3)="D" S Y=1
"RTN","DGMTOFA",126,0)
 Q Y
"VER")
8.0^22.0
**INSTALL NAME**
DG*5.3*871
"BLD",9510,0)
DG*5.3*871^REGISTRATION^0^3150424^y
"BLD",9510,1,0)
^^30^30^3150127^
"BLD",9510,1,1,0)
 *************************************************************************
"BLD",9510,1,2,0)
 Note:  This patch is being released in support of the Enrollment System
"BLD",9510,1,3,0)
        Re-design (ESR) Health Benefit Plans project.  DG*5.3*871 is
"BLD",9510,1,4,0)
        released in host file DG_53_P891.KID along with several other
"BLD",9510,1,5,0)
        patches.
"BLD",9510,1,6,0)
  
"BLD",9510,1,7,0)
        It is imperative that this patch be installed no later than the
"BLD",9510,1,8,0)
        compliance date.  Your understanding and support is appreciated.
"BLD",9510,1,9,0)
 
"BLD",9510,1,10,0)
 *************************************************************************
"BLD",9510,1,11,0)
  
"BLD",9510,1,12,0)
 The Health Eligibility Center (HEC) requested modifications to the 
"BLD",9510,1,13,0)
 Enrollment System Redesign (ESR) and VistA Registration, Enrollment and
"BLD",9510,1,14,0)
 Eligibility (Vista REE) software to support the requirements of the
"BLD",9510,1,15,0)
 Health Benefit Plans project.
"BLD",9510,1,16,0)
  
"BLD",9510,1,17,0)
 This patch modifies the Registration v5.3 application as described below:
"BLD",9510,1,18,0)
  
"BLD",9510,1,19,0)
   --   Create a new file containing the Health Benefit Plans and their
"BLD",9510,1,20,0)
        expanded descriptions.
"BLD",9510,1,21,0)
   --   Modify Register a Patient [DG REGISTER PATIENT], 
"BLD",9510,1,22,0)
        Load/Edit Patient Data [DG LOAD PATIENT DATA] and 
"BLD",9510,1,23,0)
        View Registration Data [DG REGISTRATION VIEW]
"BLD",9510,1,24,0)
        to allow user to view HBP profile for a veteran.
"BLD",9510,1,25,0)
   --   Display expanded help text for HBP
"BLD",9510,1,26,0)
   --   Store all history of assignments for HBP and be able to view
"BLD",9510,1,27,0)
   --   Store data from the Z11 message when received from ES
"BLD",9510,1,28,0)
   --   Create an API that will provide HBP information to Vista 
"BLD",9510,1,29,0)
        downstream applications to include the HBP Name and HBP
"BLD",9510,1,30,0)
        Description.
"BLD",9510,4,0)
^9.64PA^2^2
"BLD",9510,4,2,0)
2
"BLD",9510,4,2,2,0)
^9.641^2.2512^2
"BLD",9510,4,2,2,2.2511,0)
CURRENT HEALTH BENEFIT PLAN  (sub-file)
"BLD",9510,4,2,2,2.2511,1,0)
^9.6411^^0
"BLD",9510,4,2,2,2.2512,0)
HISTORY HEALTH BENEFIT PLAN  (sub-file)
"BLD",9510,4,2,2,2.2512,1,0)
^9.6411^^0
"BLD",9510,4,2,222)
y^y^p^^^^n^^n
"BLD",9510,4,2,224)

"BLD",9510,4,25.11,0)
25.11
"BLD",9510,4,25.11,222)
y^y^f^^n^^y^a^n
"BLD",9510,4,"APDD",2,2.2511)

"BLD",9510,4,"APDD",2,2.2512)

"BLD",9510,4,"B",2,2)

"BLD",9510,4,"B",25.11,25.11)

"BLD",9510,6)
2^
"BLD",9510,6.3)
84
"BLD",9510,"ABPKG")
n
"BLD",9510,"KRN",0)
^9.67PA^779.2^20
"BLD",9510,"KRN",.4,0)
.4
"BLD",9510,"KRN",.4,"NM",0)
^9.68A^^
"BLD",9510,"KRN",.401,0)
.401
"BLD",9510,"KRN",.402,0)
.402
"BLD",9510,"KRN",.403,0)
.403
"BLD",9510,"KRN",.5,0)
.5
"BLD",9510,"KRN",.84,0)
.84
"BLD",9510,"KRN",3.6,0)
3.6
"BLD",9510,"KRN",3.8,0)
3.8
"BLD",9510,"KRN",9.2,0)
9.2
"BLD",9510,"KRN",9.8,0)
9.8
"BLD",9510,"KRN",9.8,"NM",0)
^9.68A^19^12
"BLD",9510,"KRN",9.8,"NM",2,0)
DGRPV^^0^B19556232
"BLD",9510,"KRN",9.8,"NM",3,0)
DGRPE^^0^B61970869
"BLD",9510,"KRN",9.8,"NM",4,0)
DGRP11^^0^B13083153
"BLD",9510,"KRN",9.8,"NM",8,0)
DGR111^^0^B7250700
"BLD",9510,"KRN",9.8,"NM",10,0)
DGR113^^0^B3780049
"BLD",9510,"KRN",9.8,"NM",11,0)
DGR114^^0^B5179815
"BLD",9510,"KRN",9.8,"NM",12,0)
DGHBPUTL^^0^B37209374
"BLD",9510,"KRN",9.8,"NM",15,0)
DGRPP^^0^B19338452
"BLD",9510,"KRN",9.8,"NM",16,0)
DGENUPL^^0^B46472506
"BLD",9510,"KRN",9.8,"NM",17,0)
DGENUPL1^^0^B49545010
"BLD",9510,"KRN",9.8,"NM",18,0)
DGENUPL7^^0^B34918538
"BLD",9510,"KRN",9.8,"NM",19,0)
DGENUPLB^^0^B15063968
"BLD",9510,"KRN",9.8,"NM","B","DGENUPL",16)

"BLD",9510,"KRN",9.8,"NM","B","DGENUPL1",17)

"BLD",9510,"KRN",9.8,"NM","B","DGENUPL7",18)

"BLD",9510,"KRN",9.8,"NM","B","DGENUPLB",19)

"BLD",9510,"KRN",9.8,"NM","B","DGHBPUTL",12)

"BLD",9510,"KRN",9.8,"NM","B","DGR111",8)

"BLD",9510,"KRN",9.8,"NM","B","DGR113",10)

"BLD",9510,"KRN",9.8,"NM","B","DGR114",11)

"BLD",9510,"KRN",9.8,"NM","B","DGRP11",4)

"BLD",9510,"KRN",9.8,"NM","B","DGRPE",3)

"BLD",9510,"KRN",9.8,"NM","B","DGRPP",15)

"BLD",9510,"KRN",9.8,"NM","B","DGRPV",2)

"BLD",9510,"KRN",19,0)
19
"BLD",9510,"KRN",19,"NM",0)
^9.68A^^0
"BLD",9510,"KRN",19.1,0)
19.1
"BLD",9510,"KRN",101,0)
101
"BLD",9510,"KRN",101,"NM",0)
^9.68A^8^4
"BLD",9510,"KRN",101,"NM",1,0)
DGEN HBP 11.1 MENU^^0
"BLD",9510,"KRN",101,"NM",4,0)
DGEN HBP VIEW^^0
"BLD",9510,"KRN",101,"NM",5,0)
DGEN HBP DETAIL^^0
"BLD",9510,"KRN",101,"NM",8,0)
DGEN HBP 11.1A MENU^^0
"BLD",9510,"KRN",101,"NM","B","DGEN HBP 11.1 MENU",1)

"BLD",9510,"KRN",101,"NM","B","DGEN HBP 11.1A MENU",8)

"BLD",9510,"KRN",101,"NM","B","DGEN HBP DETAIL",5)

"BLD",9510,"KRN",101,"NM","B","DGEN HBP VIEW",4)

"BLD",9510,"KRN",409.61,0)
409.61
"BLD",9510,"KRN",409.61,"NM",0)
^9.68A^5^4
"BLD",9510,"KRN",409.61,"NM",1,0)
DGEN HBP PATIENT^^0
"BLD",9510,"KRN",409.61,"NM",3,0)
DGEN HBP VIEW^^0
"BLD",9510,"KRN",409.61,"NM",4,0)
DGEN HBP DETAIL^^0
"BLD",9510,"KRN",409.61,"NM",5,0)
DGEN HBP PAT NO AD^^0
"BLD",9510,"KRN",409.61,"NM","B","DGEN HBP DETAIL",4)

"BLD",9510,"KRN",409.61,"NM","B","DGEN HBP PAT NO AD",5)

"BLD",9510,"KRN",409.61,"NM","B","DGEN HBP PATIENT",1)

"BLD",9510,"KRN",409.61,"NM","B","DGEN HBP VIEW",3)

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

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

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

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

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

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

"BLD",9510,"KRN","B",3.6,3.6)

"BLD",9510,"KRN","B",3.8,3.8)

"BLD",9510,"KRN","B",9.2,9.2)

"BLD",9510,"KRN","B",9.8,9.8)

"BLD",9510,"KRN","B",19,19)

"BLD",9510,"KRN","B",19.1,19.1)

"BLD",9510,"KRN","B",101,101)

"BLD",9510,"KRN","B",409.61,409.61)

"BLD",9510,"KRN","B",771,771)

"BLD",9510,"KRN","B",779.2,779.2)

"BLD",9510,"KRN","B",870,870)

"BLD",9510,"KRN","B",8989.51,8989.51)

"BLD",9510,"KRN","B",8989.52,8989.52)

"BLD",9510,"KRN","B",8994,8994)

"BLD",9510,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9510,"QUES",0)
^9.62^^
"BLD",9510,"REQB",0)
^9.611^3^3
"BLD",9510,"REQB",1,0)
DG*5.3*709^1
"BLD",9510,"REQB",2,0)
DG*5.3*865^1
"BLD",9510,"REQB",3,0)
DG*5.3*894^1
"BLD",9510,"REQB","B","DG*5.3*709",1)

"BLD",9510,"REQB","B","DG*5.3*865",2)

"BLD",9510,"REQB","B","DG*5.3*894",3)

"DATA",25.11,2,0)
Veteran Beneficiary Plan - Newborn^102
"DATA",25.11,2,2,0)
^^11^11^3130308^
"DATA",25.11,2,2,1,0)
Newborn Plan provides health care services to a newborn child of a woman 
"DATA",25.11,2,2,2,0)
veteran who is receiving maternity care furnished by the Department for 
"DATA",25.11,2,2,3,0)
not more than seven days after the birth of the child if the veteran 
"DATA",25.11,2,2,4,0)
delivered the child in-(1) a facility of the Department; or (2) another 
"DATA",25.11,2,2,5,0)
facility pursuant to a Department contract for services relating to such 
"DATA",25.11,2,2,6,0)
delivery.
"DATA",25.11,2,2,7,0)
COVERED HEALTH CARE SERVICES are all post-delivery care services,
"DATA",25.11,2,2,8,0)
including routine care services, that a newborn child requires.(38 USC §
"DATA",25.11,2,2,9,0)
1786 - Care for newborn children of women veterans receiving maternity
"DATA",25.11,2,2,10,0)
care ) (Added Public Law 111-163, title II, 206(a), May 5, 2010, 124
"DATA",25.11,2,2,11,0)
Stat.1145)
"DATA",25.11,3,0)
Veteran Plan - State Home Veteran Plans^103
"DATA",25.11,3,2,0)
^25.14^5^5^3130312^^^^
"DATA",25.11,3,2,1,0)
State Home Plan provides Nursing home care and medications for veterans 
"DATA",25.11,3,2,2,0)
with service-connected disabilities.
"DATA",25.11,3,2,3,0)
The Secretary shall pay each State home for nursing home care at the rate
"DATA",25.11,3,2,4,0)
determined under paragraph (2), in any case in which such care is provided
"DATA",25.11,3,2,5,0)
to any veteran. (Public Law 109-461) (38 USC 1745)
"DATA",25.11,4,0)
Veteran Plan - Medical Benefits Package (Basic plan coverage for SC, NSC, etc.)^104
"DATA",25.11,4,2,0)
^^7^7^3130307^
"DATA",25.11,4,2,1,0)
Medical Benefits Package Plan provides a full spectrum of medically 
"DATA",25.11,4,2,2,0)
necessary services, based on the judgment of your VA primary care 
"DATA",25.11,4,2,3,0)
provider and in accordance with generally accepted standards of clinical 
"DATA",25.11,4,2,4,0)
practice. These services include: Primary Care, Health Promotion, Disease 
"DATA",25.11,4,2,5,0)
Prevention, Diagnosis, Palliative Care, Surgery, Prescriptions for 
"DATA",25.11,4,2,6,0)
Medications, Prosthetics, Critical Care, Mental Health Care, Women's 
"DATA",25.11,4,2,7,0)
Health Care, Orthopedics, Radiology, Physical Therapy, Rehabilitation.
"DATA",25.11,5,0)
Veteran Plan - Co-Pay Responsibilities (Special medical coverage based on 'Qualifying Factors' such as CV,AO,SWAC,SHAD,Camp Lejeune,etc.)^105
"DATA",25.11,5,2,0)
^25.14^7^7^3130308^^^
"DATA",25.11,5,2,1,0)
Co-Pay Responsibilities Plan  provides Veterans qualify for free 
"DATA",25.11,5,2,2,0)
healthcare services based on a VA compensable service-connected condition 
"DATA",25.11,5,2,3,0)
or other qualifying factor, most Veterans are asked to complete an annual 
"DATA",25.11,5,2,4,0)
financial assessment, to determine if they qualify for free services. 
"DATA",25.11,5,2,5,0)
Veterans whose income exceed the established VA Income Thresholds as well 
"DATA",25.11,5,2,6,0)
as those who choose not to complete the financial assessment must agree 
"DATA",25.11,5,2,7,0)
to pay required copays to become eligible for VA healthcare services.
"DATA",25.11,6,0)
Veteran Plan - Beneficiary Travel^106
"DATA",25.11,6,2,0)
^^4^4^3130307^
"DATA",25.11,6,2,1,0)
Beneficiary Travel Plan provides a mechanism under 38 U.S.C. 111 for the 
"DATA",25.11,6,2,2,0)
Veterans Health Administration (VHA) to make payments for travel expense 
"DATA",25.11,6,2,3,0)
incurred in the United States to help veterans and other persons obtain 
"DATA",25.11,6,2,4,0)
care or services from VHA.
"DATA",25.11,7,0)
Veteran Plan - Dental^107
"DATA",25.11,7,2,0)
^^8^8^3130308^
"DATA",25.11,7,2,1,0)
Dental Plan provides: Outpatient dental services and treatment, and 
"DATA",25.11,7,2,2,0)
related dental appliances, shall be furnished under this section only for 
"DATA",25.11,7,2,3,0)
a dental condition or disability.  Inpatient dental services that are 
"DATA",25.11,7,2,4,0)
professionally determined by a VA dentist, in consultation with the 
"DATA",25.11,7,2,5,0)
referring physician, to be essential to the management of the patient's 
"DATA",25.11,7,2,6,0)
medical condition under active treatment while receiving hospital, 
"DATA",25.11,7,2,7,0)
nursing home or domiciliary care.
"DATA",25.11,7,2,8,0)
(38 USC 1712)
"DATA",25.11,8,0)
Veteran Beneficiary Plan - CHAMPVA^108
"DATA",25.11,8,2,0)
^^12^12^3130307^
"DATA",25.11,8,2,1,0)
CHAMPVA plan provides health care to dependents who may qualify for VA's 
"DATA",25.11,8,2,2,0)
Civilian Health and Medical Program of the Department of Veteran Affairs 
"DATA",25.11,8,2,3,0)
(CHAMPVA).  They must not have eligibility under TRICARE and must be 
"DATA",25.11,8,2,4,0)
dependents of a:
"DATA",25.11,8,2,5,0)
 - Veteran who is rated Permanently and Totally disabled due to a 
"DATA",25.11,8,2,6,0)
Service-connected condition.
"DATA",25.11,8,2,7,0)
 - Veteran who died from VA rated Service-connected condition, or who, at 
"DATA",25.11,8,2,8,0)
the time of death, was rated Permanently and Totally disabled.
"DATA",25.11,8,2,9,0)
 - Veteran who died on active duty and in the line of duty (not due to 
"DATA",25.11,8,2,10,0)
misconduct).
"DATA",25.11,8,2,11,0)
For more information, call 1-800-733-8387 or go to 
"DATA",25.11,8,2,12,0)
http://www4.domain.ext/hac/forbeneficiaries/champva/champva.asp.
"DATA",25.11,9,0)
Veteran Beneficiary Plan - Spina Bifida (SB)^109
"DATA",25.11,9,2,0)
^^8^8^3130308^
"DATA",25.11,9,2,1,0)
Spina Bifida (SB) Plan provides monetary allowances, vocational training 
"DATA",25.11,9,2,2,0)
and rehabilitation, and VA-financed health care benefits to certain 
"DATA",25.11,9,2,3,0)
Korean and Vietnam Veterans' birth children who have been diagnosed with 
"DATA",25.11,9,2,4,0)
spina bifida.  For the purpose of the program, spina bifida is defined as 
"DATA",25.11,9,2,5,0)
all forms or manifestations of spina bifida (except spina bifida 
"DATA",25.11,9,2,6,0)
occulta).  For more information, call 1-888-820-1756 or go to 
"DATA",25.11,9,2,7,0)
http://www4.domain.ext/hac/forbeneficiaries/spina/spina.asp. (38 USC 
"DATA",25.11,9,2,8,0)
1802-1806, 1821)
"DATA",25.11,10,0)
Veteran Beneficiary Plan - Children of Women Vietnam Veterans (CWVV)^110
"DATA",25.11,10,2,0)
^^4^4^3130307^
"DATA",25.11,10,2,1,0)
Children of Women Vietnam Veterans (CWVV) Plan provides "NEEDED CARE" 
"DATA",25.11,10,2,2,0)
to an eligible child such health care as the Secretary determines is 
"DATA",25.11,10,2,3,0)
needed by the child for that child's covered birth defects or any 
"DATA",25.11,10,2,4,0)
disability that is associated with those birth defects. (38 USC 1811-1816)
"DATA",25.11,11,0)
Veteran Plan - Women's Programs^111
"DATA",25.11,11,2,0)
^^18^18^3130307^
"DATA",25.11,11,2,1,0)
Women's Programs Plan provides a variety of services, including: 
"DATA",25.11,11,2,2,0)
 - Women's gender-specific health care (menopause evaluation and symptom 
"DATA",25.11,11,2,3,0)
management, osteoporosis, incontinence, birth control, breast and 
"DATA",25.11,11,2,4,0)
gynecological care, maternity and limited infertility services).  
"DATA",25.11,11,2,5,0)
 - Screening and disease prevention programs (for example, mammograms,
"DATA",25.11,11,2,6,0)
bone density screening, and cervical cancer screening)
"DATA",25.11,11,2,7,0)
Routine gynecologic services are available at VA facilities and include:
"DATA",25.11,11,2,8,0)
 - Human Papilloma Virus (HPV) vaccinations
"DATA",25.11,11,2,9,0)
 - Pelvic exams, ultrasounds 
"DATA",25.11,11,2,10,0)
 - Birth control counseling and management (medical and surgical)
"DATA",25.11,11,2,11,0)
 - Pre-pregnancy care
"DATA",25.11,11,2,12,0)
 - Treatment and prevention of sexually transmitted infections
"DATA",25.11,11,2,13,0)
A provider can assist with routine exams, diagnosis, and management of:
"DATA",25.11,11,2,14,0)
 - Pelvic/abdominal pain; Abnormal vaginal bleeding; Vaginal symptoms
"DATA",25.11,11,2,15,0)
(dryness/infections); Breast and other women's cancers; Abnormal cervical 
"DATA",25.11,11,2,16,0)
screening results; Infertility evaluation, including intrauterine 
"DATA",25.11,11,2,17,0)
insemination (IUI).  VA is not authorized to provide or cover the cost of 
"DATA",25.11,11,2,18,0)
in-vitro fertilization (IVF).; Sexual dysfunction
"DATA",25.11,12,0)
Veteran Plan - Nursing Home/Community Living Centers (CLC)^113
"DATA",25.11,12,2,0)
^^23^23^3140602^
"DATA",25.11,12,2,1,0)
Nursing Home/Community Living Centers Plan provides placement in nursing 
"DATA",25.11,12,2,2,0)
homes, when clinically indicated, may be available either through VA's 
"DATA",25.11,12,2,3,0)
Community Living Centers (CLC) or contract nursing homes. The mission of 
"DATA",25.11,12,2,4,0)
the VA Community Living Centers (VACLC) program (formerly known as VA 
"DATA",25.11,12,2,5,0)
Nursing Home Care Units) is to provide compassionate care to Veterans 
"DATA",25.11,12,2,6,0)
with chronic stable conditions - those who suffer from dementia, who 
"DATA",25.11,12,2,7,0)
require rehabilitation or short-term specialized services (such as 
"DATA",25.11,12,2,8,0)
respite or intravenous therapy), or who need comfort and care at the end 
"DATA",25.11,12,2,9,0)
of life. A Veteran is eligible for VA nursing home care if he or she is: 
"DATA",25.11,12,2,10,0)
 - Have a Service-connected disability rating of 70 percent or more; 
"DATA",25.11,12,2,11,0)
 - Are unemployable or have an official rating of "permanent and total
"DATA",25.11,12,2,12,0)
disabled;" 
"DATA",25.11,12,2,13,0)
 - Have a service-connected disability that is clinically determined to
"DATA",25.11,12,2,14,0)
require nursing home care; 
"DATA",25.11,12,2,15,0)
 - Are a Nonservice-connected veteran or a ""zero percent, noncompensable,
"DATA",25.11,12,2,16,0)
Service-connected"" veteran who requires nursing home care for any
"DATA",25.11,12,2,17,0)
Nonservice-connected disability and who meets income and asset criteria;
"DATA",25.11,12,2,18,0)
or  
"DATA",25.11,12,2,19,0)
 - Need care, if space and resources are available. Other Veterans are
"DATA",25.11,12,2,20,0)
evaluated on a case-by-case basis, with priority given to
"DATA",25.11,12,2,21,0)
Service-connected veterans and those who need care for post-acute
"DATA",25.11,12,2,22,0)
rehabilitation, respite, hospice, geriatric evaluation and management, or
"DATA",25.11,12,2,23,0)
spinal cord injury.
"DATA",25.11,13,0)
Veteran Plan - Home Health^114
"DATA",25.11,13,2,0)
^^13^13^3130307^
"DATA",25.11,13,2,1,0)
Home Health Plan provides home health services VA's Skilled Home Health 
"DATA",25.11,13,2,2,0)
Care Services (SHHC) and Homemaker and Home Health Aid Services 
"DATA",25.11,13,2,3,0)
(H/HHA).
"DATA",25.11,13,2,4,0)
Skilled Home Health Care (SHHC) Services 
"DATA",25.11,13,2,5,0)
SHHC services are in-home services provided by specially trained
"DATA",25.11,13,2,6,0)
personnel, including nurses, physical therapists, occupational therapists,
"DATA",25.11,13,2,7,0)
speech therapists, and social workers. Care includes clinical assessment,
"DATA",25.11,13,2,8,0)
treatment planning, treatment provision, health status monitoring, patient
"DATA",25.11,13,2,9,0)
and family education, reassessment, referral, and follow-up.
"DATA",25.11,13,2,10,0)
Homemaker/Home Health Aide (H/HHA) Services
"DATA",25.11,13,2,11,0)
H/HHA services are personal care and related support services that enable
"DATA",25.11,13,2,12,0)
frail or disabled Veterans to live at home. 
"DATA",25.11,13,2,13,0)
(38 USC § 1717)
"DATA",25.11,14,0)
Veteran Plan - Eye Glasses^115
"DATA",25.11,14,2,0)
^^10^10^3130307^
"DATA",25.11,14,2,1,0)
Eye Glasses Plan provides service-connected Veterans receiving 
"DATA",25.11,14,2,2,0)
compensation, former Prisoners of War, Purple Heart Recipients, or 
"DATA",25.11,14,2,3,0)
Veterans in receipt of VA's Aid and Attendance or Housebound benefits and 
"DATA",25.11,14,2,4,0)
receiving VA care or services, are provided eyeglasses based on clinical 
"DATA",25.11,14,2,5,0)
need. 
"DATA",25.11,14,2,6,0)
Otherwise, VA provides eyeglasses only in special circumstances. However,
"DATA",25.11,14,2,7,0)
Veterans otherwise receiving VA care or services may be eligible because
"DATA",25.11,14,2,8,0)
of medically compelling reasons, as determined by a VA eye care 
"DATA",25.11,14,2,9,0)
practitioner. 
"DATA",25.11,14,2,10,0)
(38 CFR §17.149)
"DATA",25.11,15,0)
Veteran Plan - Clothing Allowance^116
"DATA",25.11,15,2,0)
^^4^4^3130307^
"DATA",25.11,15,2,1,0)
Clothing Allowance Plan provides service-connected Veterans who must wear 
"DATA",25.11,15,2,2,0)
a prescribed device that causes their clothing to wear or tear, or if 
"DATA",25.11,15,2,3,0)
clothing is damaged due to use of a topical ointment,  may receive an 
"DATA",25.11,15,2,4,0)
annual Clothing Allowance payment.  (38 USC § 1162)
"DATA",25.11,16,0)
Veteran Plan - Hearing Aid^117
"DATA",25.11,16,2,0)
^^9^9^3130307^
"DATA",25.11,16,2,1,0)
Hearing Aid Plan provides service-connected Veterans receiving 
"DATA",25.11,16,2,2,0)
compensation, former Prisoners of War, Purple Heart Recipients, or 
"DATA",25.11,16,2,3,0)
Veterans in receipt of VA's Aid and Attendance or Housebound benefits and 
"DATA",25.11,16,2,4,0)
receiving VA care or services, are provided hearing aids based on 
"DATA",25.11,16,2,5,0)
clinical need. 
"DATA",25.11,16,2,6,0)
Otherwise, VA provides hearing aids only in special circumstances.
"DATA",25.11,16,2,7,0)
However, Veterans otherwise receiving VA care or services may be eligible
"DATA",25.11,16,2,8,0)
because of medically compelling reasons, as determined by a VA
"DATA",25.11,16,2,9,0)
audiologist. (38 CFR §17.149)
"DATA",25.11,17,0)
Veteran Plan - Non VA Emergency Care^118
"DATA",25.11,17,2,0)
^^4^4^3130307^
"DATA",25.11,17,2,1,0)
In case of emergencies, Veterans should always call 911.  VA does not 
"DATA",25.11,17,2,2,0)
have to be contacted in advance. Veterans should always go to the nearest 
"DATA",25.11,17,2,3,0)
emergency room whether it's a VA or private facility.  If transported by 
"DATA",25.11,17,2,4,0)
ambulance, the paramedics generally will go to the closest emergency room.
"DATA",25.11,18,0)
Veteran Plan - Medication and Supplies^119
"DATA",25.11,18,2,0)
^^3^3^3130307^
"DATA",25.11,18,2,1,0)
Medication and Supplies Plan provides safe, effective, and medically 
"DATA",25.11,18,2,2,0)
necessary medications to ensure the highest quality care for our nation's 
"DATA",25.11,18,2,3,0)
Veterans.
"DATA",25.11,19,0)
Veteran Plan - Home Improvements^120
"DATA",25.11,19,2,0)
^^3^3^3130307^
"DATA",25.11,19,2,1,0)
Home Improvement Plan provides a Home Improvement and Structural 
"DATA",25.11,19,2,2,0)
Alteration Grant may be awarded for improvements or structural 
"DATA",25.11,19,2,3,0)
alterations needed to access home or essential bathroom facilities. 
"DATA",25.11,20,0)
Veteran Plan - Automobile Adaptive Equipment^121
"DATA",25.11,20,2,0)
^^7^7^3130307^
"DATA",25.11,20,2,1,0)
VA's Automobile Adaptive Equipment program Plan provides equipment and 
"DATA",25.11,20,2,2,0)
training to enter, exit, or operate a motor vehicle for Service-connected 
"DATA",25.11,20,2,3,0)
Veterans whose Primary Care Provider decides that it is necessary to 
"DATA",25.11,20,2,4,0)
drive safely and comply with State licensing laws. Please note that only 
"DATA",25.11,20,2,5,0)
certain Service-connected conditions qualify.  Veterans may also be 
"DATA",25.11,20,2,6,0)
eligible for financial assistance, in the form of a grant, to purchase a 
"DATA",25.11,20,2,7,0)
new or used automobile (or other conveyance). 
"DATA",25.11,21,0)
Veteran Plan - Foreign Medical Program^122
"DATA",25.11,21,2,0)
^^12^12^3130307^
"DATA",25.11,21,2,1,0)
Foreign Medical Program Plan provides pay for medical services for 
"DATA",25.11,21,2,2,0)
treating your service-connected disabilities, or any disability that is 
"DATA",25.11,21,2,3,0)
associated with and aggravates a service-connected disability if you live 
"DATA",25.11,21,2,4,0)
or travel outside the United States.  This program will also reimburse 
"DATA",25.11,21,2,5,0)
you for certain treatment of medical services while you are outside the 
"DATA",25.11,21,2,6,0)
United States, if needed as part of your VA-approved vocational 
"DATA",25.11,21,2,7,0)
rehabilitation program. 
"DATA",25.11,21,2,8,0)
If you are living or planning to travel outside the U.S. (other than in
"DATA",25.11,21,2,9,0)
the Philippines), you need to register with VA's Foreign Medical Program
"DATA",25.11,21,2,10,0)
office, P.O. Box 469061, Denver, CO 80246-9061, USA: telephone
"DATA",25.11,21,2,11,0)
303-331-7590. For information, visit: 
"DATA",25.11,21,2,12,0)
http://www.domain.ext/hac/forbeneficiaries/fmp/fmp.asp.
"DATA",25.11,22,0)
Veteran Plan - Non-Vet Plans^123
"DATA",25.11,23,0)
VA/DoD Plan - TRICARE^124
"DATA",25.11,23,2,0)
^^6^6^3130307^
"DATA",25.11,23,2,1,0)
TRICARE Plan is a regionally managed health care program for active duty 
"DATA",25.11,23,2,2,0)
and retired members of the uniformed services, their families and 
"DATA",25.11,23,2,3,0)
survivors. VA bills TRICARE for Nonservice-connected medical treatment. 
"DATA",25.11,23,2,4,0)
There are four options for health care: TRICARE Prime, TRICARE Extra, 
"DATA",25.11,23,2,5,0)
TRICARE Standard and TRICARE for Life. Each of these options has specific 
"DATA",25.11,23,2,6,0)
benefits, exclusions, copayment and deductible requirements.
"DATA",25.11,24,0)
VA/DoD Plan - Retiree^125
"DATA",25.11,25,0)
VA/DoD Plan - Active Duty Sponsor^126
"DATA",25.11,26,0)
VA/DoD Plan - Active Duty Dependent^127
"DATA",25.11,27,0)
VA/DoD Plan - Former Non-Remarried Spouse^128
"DATA",25.11,28,0)
VA/DoD Plan - Retiree Sponsor^129
"DATA",25.11,29,0)
VA/DoD Plan - Retiree Dependent^130
"DATA",25.11,30,0)
VA/DoD Plan - Reservist Sponsor^131
"DATA",25.11,31,0)
VA/DoD Plan - Recruit Sponsor^132
"DATA",25.11,32,0)
VA/DoD Plan - Temporary Disability Retirement List (TDRL) Sponsor^133
"DATA",25.11,33,0)
VA/DoD Plan - Tricare for Life (TFL)^134
"DATA",25.11,34,0)
Veteran Plan - Long term Care ^112
"DATA",25.11,35,0)
Presumptive (38 USC 1702-38 CFR 17.109)^135
"DATA",25.11,35,2,0)
^^43^43^3140515^
"DATA",25.11,35,2,1,0)
Presumptive (38 USC 1702- 38 CFR 17.109) Plan provides certain Veterans who 
"DATA",25.11,35,2,2,0)
experience psychosis within a specified time-frame are to have their psychosis
"DATA",25.11,35,2,3,0)
presumed to be service-connected for purposes of Department of Veterans 
"DATA",25.11,35,2,4,0)
Affairs (VA) medical benefits. In addition, VA will presume that Persian 
"DATA",25.11,35,2,5,0)
Gulf War Veterans are service-connected for purposes of VA medical
"DATA",25.11,35,2,6,0)
benefits if such Veterans develop mental illness other than psychosis
"DATA",25.11,35,2,7,0)
within two years after discharge or release from service and before the
"DATA",25.11,35,2,8,0)
end of the 2-year period beginning on the last day of the Persian Gulf War
"DATA",25.11,35,2,9,0)
(end date not yet determined).  (Public Law 110-181; 38 United States Code
"DATA",25.11,35,2,10,0)
(U.S.C.) 1702 and the implementing regulation, 38 CFR 17.109)
"DATA",25.11,35,2,11,0)
  
"DATA",25.11,35,2,12,0)
1. Psychosis. Eligibility for benefits under title 38 Code of Federal
"DATA",25.11,35,2,13,0)
Regulations (CFR) 17.109(a) is established for treatment of psychosis, and
"DATA",25.11,35,2,14,0)
such condition is exempted from copayments under 38 CFR 17.108, 17.110, and
"DATA",25.11,35,2,15,0)
17.111 for any Veteran who served in the United States active duty military,
"DATA",25.11,35,2,16,0)
naval, or air service and developed such psychosis within 2 years after
"DATA",25.11,35,2,17,0)
discharge or release from the active duty military, naval or air service; and 
"DATA",25.11,35,2,18,0)
before the following date associated with the war or conflict in which the
"DATA",25.11,35,2,19,0)
Veteran served:
"DATA",25.11,35,2,20,0)
  
"DATA",25.11,35,2,21,0)
==============================================================================
"DATA",25.11,35,2,22,0)
| Veteran Served During             | Date:                                  |
"DATA",25.11,35,2,23,0)
==============================================================================
"DATA",25.11,35,2,24,0)
| World War II                      | July 26, 1949                          |
"DATA",25.11,35,2,25,0)
------------------------------------------------------------------------------
"DATA",25.11,35,2,26,0)
| Korean Conflict                   | February 1, 1957                       |
"DATA",25.11,35,2,27,0)
------------------------------------------------------------------------------
"DATA",25.11,35,2,28,0)
| Vietnam Era                       | May 8, 1977                            |
"DATA",25.11,35,2,29,0)
------------------------------------------------------------------------------
"DATA",25.11,35,2,30,0)
| Persian Gulf War                  | End of the 2-year period beginning on  |
"DATA",25.11,35,2,31,0)
|                                   | the last day of the Persian Gulf War   |
"DATA",25.11,35,2,32,0)
|                                   | (end date not yet determined)          |
"DATA",25.11,35,2,33,0)
==============================================================================
"DATA",25.11,35,2,34,0)
  
"DATA",25.11,35,2,35,0)
2. Mental Illness (other than Psychosis). Eligibility for benefits under 38 
"DATA",25.11,35,2,36,0)
CFR 17.109(b) is established for treatment of an active mental illness (other 
"DATA",25.11,35,2,37,0)
than psychosis), and such condition is exempted from copayments under 38 CFR 
"DATA",25.11,35,2,38,0)
17.108, 17.110, and 17.111 for any Veteran of the Persian Gulf War who
"DATA",25.11,35,2,39,0)
developed such mental illness:
"DATA",25.11,35,2,40,0)
a. Within 2 years after discharge or release from the active duty military, 
"DATA",25.11,35,2,41,0)
naval, or air service; and
"DATA",25.11,35,2,42,0)
b. Before the end of the 2-year period beginning on the last day of the
"DATA",25.11,35,2,43,0)
Persian Gulf War (end date not yet determined).
"DATA",25.11,36,0)
Vocational Rehabilitation (Chapter 31)^136
"DATA",25.11,36,2,0)
^^20^20^3130312^
"DATA",25.11,36,2,1,0)
The Vocational Rehabilitation and Employment (VR&E) Program is 
"DATA",25.11,36,2,2,0)
authorized by Congress under Title 38, USC, Chapter 31 and Code of 
"DATA",25.11,36,2,3,0)
Federal Regulations, Part 21. It is sometimes referred to as the Chapter 
"DATA",25.11,36,2,4,0)
31 program. This program assists Veterans with service-connected 
"DATA",25.11,36,2,5,0)
disabilities to prepare for, find, and keep suitable jobs. Services that 
"DATA",25.11,36,2,6,0)
may be provided by the VR&E Program include:  Comprehensive 
"DATA",25.11,36,2,7,0)
rehabilitation evaluation to determine abilities, skills, and interests 
"DATA",25.11,36,2,8,0)
for employment   Vocational counseling and rehabilitation planning for 
"DATA",25.11,36,2,9,0)
employment services   Employment services such as job-training, 
"DATA",25.11,36,2,10,0)
job-seeking skills, resume development, and other work readiness 
"DATA",25.11,36,2,11,0)
assistance   Assistance eligible Veterans with finding and keeping a job, 
"DATA",25.11,36,2,12,0)
including the use of special employer incentives and job accommodations   
"DATA",25.11,36,2,13,0)
On the Job Training (OJT), apprenticeships, and non-paid work 
"DATA",25.11,36,2,14,0)
experiences   Post-secondary training at a college, vocational, technical 
"DATA",25.11,36,2,15,0)
or business school   Supportive rehabilitation services including case 
"DATA",25.11,36,2,16,0)
management, counseling, and medical referrals   Independent living 
"DATA",25.11,36,2,17,0)
services for Veterans unable to work due to the severity of their 
"DATA",25.11,36,2,18,0)
disabilities   For Veterans with service-connected disabilities so severe 
"DATA",25.11,36,2,19,0)
that they cannot immediately consider work, this program offers services 
"DATA",25.11,36,2,20,0)
to improve their ability to live as independently as possible.+C21
"DATA",25.11,37,0)
Veteran Beneficiary Plan - Caregiver (Primary Family Caregiver)^101
"DATA",25.11,37,2,0)
^25.14^16^16^3140514^^^^
"DATA",25.11,37,2,1,0)
Primary Family Caregiver Plan provides support and assistance to Primary
"DATA",25.11,37,2,2,0)
Family Caregivers of eligible post 9/11 Veterans and Service Members
"DATA",25.11,37,2,3,0)
undergoing medical discharge, who incurred or aggravated a serious injury
"DATA",25.11,37,2,4,0)
in the line of duty on or after September 11, 2001 under the Program of
"DATA",25.11,37,2,5,0)
Comprehensive Assistance for Family Caregivers.
"DATA",25.11,37,2,6,0)
   
"DATA",25.11,37,2,7,0)
Eligible Primary Family Caregivers may receive a stipend, education and
"DATA",25.11,37,2,8,0)
training, mental health services, respite care services, travel, lodging
"DATA",25.11,37,2,9,0)
and subsistence when receiving initial training and during the Veterans'
"DATA",25.11,37,2,10,0)
medical appointments, as well as access to VA's Civilian Health and Medical
"DATA",25.11,37,2,11,0)
Program (CHAMPVA) if not already entitled to care or services under 
"DATA",25.11,37,2,12,0)
another health plan contract including TRICARE.  More information can be
"DATA",25.11,37,2,13,0)
obtained from a Caregiver Support Coordinator at the nearest VA medical
"DATA",25.11,37,2,14,0)
center, by visiting http://www.domain.ext, or by calling 
"DATA",25.11,37,2,15,0)
1-877-222-VETS (8387).  The VA's Caregiver Support Line is also available 
"DATA",25.11,37,2,16,0)
for Caregiver related information and support at 1-855-260-3274.
"DATA",25.11,38,0)
Veteran Beneficiary Plan - Caregiver (Secondary Family Caregiver)^137
"DATA",25.11,38,2,0)
^25.14^16^16^3140529^^
"DATA",25.11,38,2,1,0)
Secondary Family Caregiver Plan provides support and assistance to
"DATA",25.11,38,2,2,0)
Secondary Family Caregivers of post 9/11 Veterans and Service Members
"DATA",25.11,38,2,3,0)
undergoing medical discharge, who incurred or aggravated a serious
"DATA",25.11,38,2,4,0)
injury in the line of duty on or after September 11, 2001 under the 
"DATA",25.11,38,2,5,0)
Program of Comprehensive Assistance for Family Caregivers.  Secondary
"DATA",25.11,38,2,6,0)
Family Caregivers serve primarily in support of or in place of
"DATA",25.11,38,2,7,0)
the Primary Family Caregiver as a back-up.  An eligible Veteran may
"DATA",25.11,38,2,8,0)
appoint up to 2 Secondary Caregivers at any one time.  Eligible Secondary
"DATA",25.11,38,2,9,0)
Family Caregivers may receive education and training, travel, lodging
"DATA",25.11,38,2,10,0)
and subsistence when receiving initial training and during the Veteran's
"DATA",25.11,38,2,11,0)
medical appointments, respite care services, and ongoing technical
"DATA",25.11,38,2,12,0)
support and counseling.  More information can be obtained from a 
"DATA",25.11,38,2,13,0)
Caregiver Support Coordinator at the nearest VA medical center, by 
"DATA",25.11,38,2,14,0)
visiting http://www.domain.ext, or by calling 1-877-222-VETS (8387).
"DATA",25.11,38,2,15,0)
The VA Caregivers Support line is also available for Caregiver related
"DATA",25.11,38,2,16,0)
information and support at 1-855-260-3274.
"DATA",25.11,39,0)
Veteran Beneficiary Plan - Caregivers (General Caregiver)^138
"DATA",25.11,39,2,0)
^25.14^9^9^3140513^^^
"DATA",25.11,39,2,1,0)
General Caregiver Plan provides support to General Caregivers caring for
"DATA",25.11,39,2,2,0)
veterans of all eras under the Program of General Caregiver Support
"DATA",25.11,39,2,3,0)
Services.  Eligible General Caregivers may receive education and 
"DATA",25.11,39,2,4,0)
training on caring for an enrolled Veteran; respite care as well as 
"DATA",25.11,39,2,5,0)
counseling and other services.  More information can be obtained from
"DATA",25.11,39,2,6,0)
a Caregiver Support Coordinator at the nearest VA medical center, by 
"DATA",25.11,39,2,7,0)
visiting http://www.domain.ext, or by calling 1-855-222-VETS (8387).
"DATA",25.11,39,2,8,0)
The VA's Caregiver Support Line is also available for Caregiver related
"DATA",25.11,39,2,9,0)
information and support at 1-855-260-3274.
"DATA",25.11,40,0)
Veteran Beneficiary Plan - Camp Lejeune Family^139
"DATA",25.11,41,0)
Veteran Plan - Airborne Hazard and Open Burn Pit^140
"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,25.01)

"FIA",2,2,25.02)

"FIA",2,2.2511)
0
"FIA",2,2.2512)
0
"FIA",25.11)
HEALTH BENEFIT PLAN
"FIA",25.11,0)
^DGHBP(25.11,
"FIA",25.11,0,0)
25.11I
"FIA",25.11,0,1)
y^y^f^^n^^y^a^n
"FIA",25.11,0,10)

"FIA",25.11,0,11)

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

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

"KRN",101,4557,-1)
0^1
"KRN",101,4557,0)
DGEN HBP 11.1 MENU^Patient 11.1 HBP Menu^^M^^^^^^^^REGISTRATION
"KRN",101,4557,1,0)
^101.06^2^2^3130410^^^^
"KRN",101,4557,1,1,0)
This protocol menu contains all the activities for patient Health Benefit 
"KRN",101,4557,1,2,0)
Plan data display and edit.
"KRN",101,4557,4)
25^4^^menu
"KRN",101,4557,10,0)
^101.01PA^4^2
"KRN",101,4557,10,3,0)
4560^VH^30^
"KRN",101,4557,10,3,"^")
DGEN HBP VIEW
"KRN",101,4557,10,4,0)
4563^VD^40^
"KRN",101,4557,10,4,"^")
DGEN HBP DETAIL
"KRN",101,4557,15)
D PEXIT^DGR111
"KRN",101,4557,26)
D SHOW^VALM
"KRN",101,4557,28)
Select Action:
"KRN",101,4557,99)
63617,59206
"KRN",101,4560,-1)
0^4
"KRN",101,4560,0)
DGEN HBP VIEW^View History^^A^^^^^^^^REGISTRATION
"KRN",101,4560,1,0)
^101.06^2^2^3130408^^
"KRN",101,4560,1,1,0)
This protocol action allows the user to view the Health Benefit Plan(s) 
"KRN",101,4560,1,2,0)
which have been added to or deleted from a patient's profile.
"KRN",101,4560,20)
D ACT^DGR111("VH")
"KRN",101,4560,99)
63334,41599
"KRN",101,4563,-1)
0^5
"KRN",101,4563,0)
DGEN HBP DETAIL^View All HBP Detail^^A^^^^^^^^
"KRN",101,4563,1,0)
^101.06^2^2^3150306^^
"KRN",101,4563,1,1,0)
This protocol action allows the user to view the detailed description of 
"KRN",101,4563,1,2,0)
the Health Benefit Plan(s) available for assigning to a patient's profile.
"KRN",101,4563,20)
D ACT^DGR111("VD")
"KRN",101,4563,99)
63617,59151
"KRN",101,4564,-1)
0^8
"KRN",101,4564,0)
DGEN HBP 11.1A MENU^Patient 11.1A HBP Menu^^A^^^^^^^^REGISTRATION
"KRN",101,4564,4)
25^4
"KRN",101,4564,10,0)
^101.01PA^2^2
"KRN",101,4564,10,1,0)
4560^VH^10^
"KRN",101,4564,10,1,"^")
DGEN HBP VIEW
"KRN",101,4564,10,2,0)
4563^VD^20^IBDF VIEW FORM W/WO DATA^^View all HBP Detail
"KRN",101,4564,10,2,"^")
DGEN HBP DETAIL
"KRN",101,4564,15)
D PEXIT^DGR111
"KRN",101,4564,26)
D SHOW^VALM
"KRN",101,4564,28)
VD
"KRN",101,4564,99)
63617,59151
"KRN",409.61,727,-1)
0^1
"KRN",409.61,727,0)
DGEN HBP PATIENT^1^^240^5^15^1^1^^DGEN HBP 11.1 MENU^HEALTH BENEFIT PLAN <11.1>^1^^1
"KRN",409.61,727,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,727,"COL",0)
^409.621^1^1
"KRN",409.61,727,"COL",1,0)
1^4^30^Current Health Benefit Plans
"KRN",409.61,727,"COL","B",1,1)

"KRN",409.61,727,"FNL")
D EXIT^DGR111
"KRN",409.61,727,"HDR")
D HDR^DGR111
"KRN",409.61,727,"HLP")
D HELP^DGR111
"KRN",409.61,727,"INIT")
D INIT^DGR111
"KRN",409.61,728,-1)
0^3
"KRN",409.61,728,0)
DGEN HBP VIEW^2^^240^5^20^1^1^^^HEALTH BENEFIT PLAN <11.3>^1^^1
"KRN",409.61,728,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,728,"COL",0)
^409.621^3^3
"KRN",409.61,728,"COL",1,0)
PLAN NAME^23^80^Plan Name
"KRN",409.61,728,"COL",2,0)
ACTION^1^7^ Action
"KRN",409.61,728,"COL",3,0)
DATE/TIME^10^11^Date
"KRN",409.61,728,"COL","B","ACTION",2)

"KRN",409.61,728,"COL","B","DATE/TIME",3)

"KRN",409.61,728,"COL","B","PLAN NAME",1)

"KRN",409.61,728,"FNL")
D EXIT^DGR113
"KRN",409.61,728,"HDR")
D HDR^DGR113
"KRN",409.61,728,"HLP")
D HELP^DGR113
"KRN",409.61,728,"INIT")
D INIT^DGR113
"KRN",409.61,730,-1)
0^4
"KRN",409.61,730,0)
DGEN HBP DETAIL^2^^240^5^20^1^1^^^HEALTH BENEFIT PLAN <11.4>^1^^1
"KRN",409.61,730,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,730,"COL",0)
^409.621^1^1
"KRN",409.61,730,"COL",1,0)
1^4^35^Health Benefit Plan View All Detail
"KRN",409.61,730,"COL","B",1,1)

"KRN",409.61,730,"EXP")
D EXPND^DGR114
"KRN",409.61,730,"FNL")
D EXIT^DGR114
"KRN",409.61,730,"HDR")
D HDR^DGR114
"KRN",409.61,730,"HLP")
D HELP^DGR114
"KRN",409.61,730,"INIT")
D INIT^DGR114
"KRN",409.61,731,-1)
0^5
"KRN",409.61,731,0)
DGEN HBP PAT NO AD^1^^240^5^15^1^1^^DGEN HBP 11.1A MENU^HEALTH BENEFIT PLAN <11.1A>^1^^1
"KRN",409.61,731,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,731,"COL",0)
^409.621^1^1
"KRN",409.61,731,"COL",1,0)
1^4^30^Current Health Benefit Plans
"KRN",409.61,731,"COL","B",1,1)

"KRN",409.61,731,"FNL")
D EXIT^DGR111
"KRN",409.61,731,"HDR")
D HDR^DGR111
"KRN",409.61,731,"HLP")
D HELP^DGR111
"KRN",409.61,731,"INIT")
D INIT^DGR111
"MBREQ")
0
"ORD",15,101)
101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA
"ORD",15,101,0)
PROTOCOL
"ORD",17,409.61)
409.61;17;1;;;;LME1^XPDIA1;;;LMDEL^XPDIA1
"ORD",17,409.61,0)
LIST TEMPLATE
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
871^3150424^66481
"PKG",47,22,1,"PAH",1,1,0)
^^30^30^3150424
"PKG",47,22,1,"PAH",1,1,1,0)
 *************************************************************************
"PKG",47,22,1,"PAH",1,1,2,0)
 Note:  This patch is being released in support of the Enrollment System
"PKG",47,22,1,"PAH",1,1,3,0)
        Re-design (ESR) Health Benefit Plans project.  DG*5.3*871 is
"PKG",47,22,1,"PAH",1,1,4,0)
        released in host file DG_53_P891.KID along with several other
"PKG",47,22,1,"PAH",1,1,5,0)
        patches.
"PKG",47,22,1,"PAH",1,1,6,0)
  
"PKG",47,22,1,"PAH",1,1,7,0)
        It is imperative that this patch be installed no later than the
"PKG",47,22,1,"PAH",1,1,8,0)
        compliance date.  Your understanding and support is appreciated.
"PKG",47,22,1,"PAH",1,1,9,0)
 
"PKG",47,22,1,"PAH",1,1,10,0)
 *************************************************************************
"PKG",47,22,1,"PAH",1,1,11,0)
  
"PKG",47,22,1,"PAH",1,1,12,0)
 The Health Eligibility Center (HEC) requested modifications to the 
"PKG",47,22,1,"PAH",1,1,13,0)
 Enrollment System Redesign (ESR) and VistA Registration, Enrollment and
"PKG",47,22,1,"PAH",1,1,14,0)
 Eligibility (Vista REE) software to support the requirements of the
"PKG",47,22,1,"PAH",1,1,15,0)
 Health Benefit Plans project.
"PKG",47,22,1,"PAH",1,1,16,0)
  
"PKG",47,22,1,"PAH",1,1,17,0)
 This patch modifies the Registration v5.3 application as described below:
"PKG",47,22,1,"PAH",1,1,18,0)
  
"PKG",47,22,1,"PAH",1,1,19,0)
   --   Create a new file containing the Health Benefit Plans and their
"PKG",47,22,1,"PAH",1,1,20,0)
        expanded descriptions.
"PKG",47,22,1,"PAH",1,1,21,0)
   --   Modify Register a Patient [DG REGISTER PATIENT], 
"PKG",47,22,1,"PAH",1,1,22,0)
        Load/Edit Patient Data [DG LOAD PATIENT DATA] and 
"PKG",47,22,1,"PAH",1,1,23,0)
        View Registration Data [DG REGISTRATION VIEW]
"PKG",47,22,1,"PAH",1,1,24,0)
        to allow user to view HBP profile for a veteran.
"PKG",47,22,1,"PAH",1,1,25,0)
   --   Display expanded help text for HBP
"PKG",47,22,1,"PAH",1,1,26,0)
   --   Store all history of assignments for HBP and be able to view
"PKG",47,22,1,"PAH",1,1,27,0)
   --   Store data from the Z11 message when received from ES
"PKG",47,22,1,"PAH",1,1,28,0)
   --   Create an API that will provide HBP information to Vista 
"PKG",47,22,1,"PAH",1,1,29,0)
        downstream applications to include the HBP Name and HBP
"PKG",47,22,1,"PAH",1,1,30,0)
        Description.
"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")
12
"RTN","DGENUPL")
0^16^B46472506
"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**;Aug 13,1993;Build 84
"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)
 .F I=2:1:41 S SEG(I-1)=$P(SEGMENT,HLFS,I)
"RTN","DGENUPL",213,0)
 Q
"RTN","DGENUPL",214,0)
 ;
"RTN","DGENUPL",215,0)
ADVANCE(MSGIEN,CURLINE) ;
"RTN","DGENUPL",216,0)
 ;Description: Used to find the beginning of the next message in the batch.
"RTN","DGENUPL",217,0)
 ;
"RTN","DGENUPL",218,0)
 ;Input:
"RTN","DGENUPL",219,0)
 ;  MSGIEN - ien of message in the HL7 MESSAGE TEXT file.
"RTN","DGENUPL",220,0)
 ;  CURLINE - current position in the message
"RTN","DGENUPL",221,0)
 ;Output:
"RTN","DGENUPL",222,0)
 ;  CURLINE - starting position of next message in the batch, or 0 if 
"RTN","DGENUPL",223,0)
 ;    the end of the message is reached
"RTN","DGENUPL",224,0)
 ;
"RTN","DGENUPL",225,0)
 Q:'CURLINE
"RTN","DGENUPL",226,0)
 F  S CURLINE=$O(^TMP($J,IVMRTN,CURLINE)) Q:'CURLINE  Q:$E($G(^TMP($J,IVMRTN,CURLINE,0)),1,3)="MSH"
"RTN","DGENUPL",227,0)
 S CURLINE=+CURLINE
"RTN","DGENUPL",228,0)
 Q
"RTN","DGENUPL1")
0^17^B49545010
"RTN","DGENUPL1",1,0)
DGENUPL1 ;ALB/CJM,ISA,KWP,CKN,LBD,LMD,TDM,TGH - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;13 Nov 2014  4:47 PM
"RTN","DGENUPL1",2,0)
 ;;5.3;REGISTRATION;**147,222,232,314,397,379,407,363,673,653,688,797,842,894,871**;Aug 13,1993;Build 84
"RTN","DGENUPL1",3,0)
 ;
"RTN","DGENUPL1",4,0)
PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGPAT,DGELG,DGENR,DGCDIS,DGOEIF,DGSEC,DGNTR,DGMST,DGNMSE,DGHBP) ;
"RTN","DGENUPL1",5,0)
 ;
"RTN","DGENUPL1",6,0)
 ;Description:  This function parses the HL7 segments.  It creates arrays
"RTN","DGENUPL1",7,0)
 ;defined by the PATIENT, ENROLLMENT, ELIGIBILY, CATASTROPHIC DISABILITY,
"RTN","DGENUPL1",8,0)
 ;OEF/OIF CONFLICT objects.
"RTN","DGENUPL1",9,0)
 ;Field values are put in DHCP format and the validity at the
"RTN","DGENUPL1",10,0)
 ;field level is tested.  Fields to be deleted are set to "@".
"RTN","DGENUPL1",11,0)
 ;
"RTN","DGENUPL1",12,0)
 ;Input:
"RTN","DGENUPL1",13,0)
 ;  MSGIEN - the ien of the HL7 message in the HL7 MESSAGE TEXT file (772)
"RTN","DGENUPL1",14,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",15,0)
 ;  CURLINE - the subscript of the PID segment of the current message (pass by reference)
"RTN","DGENUPL1",16,0)
 ;  ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by ref)
"RTN","DGENUPL1",17,0)
 ;
"RTN","DGENUPL1",18,0)
 ;Output:
"RTN","DGENUPL1",19,0)
 ;  Function Value: Returns 1 on success, 0 on failure.
"RTN","DGENUPL1",20,0)
 ;  CURLINE - upon leaving the procedure this parameter should be set to the end of the current message.
"RTN","DGENUPL1",21,0)
 ;  ERRCOUNT - set to count of messages that were not processed due to errors encountered. (pass by ref)
"RTN","DGENUPL1",22,0)
 ;  DGPAT - array defined by the PATIENT object. (pass by ref)
"RTN","DGENUPL1",23,0)
 ;  DGENR - array defined by the PATIENT ENROLLMENT object. (pass by ref)
"RTN","DGENUPL1",24,0)
 ;  DGELG - array defined by the PATIENT ELIGIBILITY object. (pass by ref)
"RTN","DGENUPL1",25,0)
 ;  DGCDIS - array defined by the CATASTROPHIC DISABILITY object. (pass by ref)
"RTN","DGENUPL1",26,0)
 ;  DGSEC - array defined by the PATIENT SECURITY object. (pass by ref)
"RTN","DGENUPL1",27,0)
 ;  DGOEIF - array defined by the OEF/OIF CONFLICT object.  (pass by ref)
"RTN","DGENUPL1",28,0)
 ;  DGNTR - array defined for NTR data.
"RTN","DGENUPL1",29,0)
 ;  DGMST - array defined for MST data.
"RTN","DGENUPL1",30,0)
 ;  DGNMSE - array define for MILITARY SERVICE EPISODE data (pass by ref)
"RTN","DGENUPL1",31,0)
 ;  DGHBP - array define for HEALTH BENEFIT PLAN data (pass by ref) DG*5.3*871
"RTN","DGENUPL1",32,0)
 N SEG,ERROR,COUNT,QFLG,NFLG
"RTN","DGENUPL1",33,0)
 ;
"RTN","DGENUPL1",34,0)
 K DGEN,DGPAT,DGELG,DGCDIS,DGNTR,DGMST
"RTN","DGENUPL1",35,0)
 ;
"RTN","DGENUPL1",36,0)
 S ERROR=0,NFLG=1
"RTN","DGENUPL1",37,0)
 F SEG="PID","ZPD","ZIE","ZIO","ZEL"  D  Q:ERROR
"RTN","DGENUPL1",38,0)
 .D:NFLG NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",39,0)
 .I SEG="ZIO",SEG("TYPE")'="ZIO" S NFLG=0 Q
"RTN","DGENUPL1",40,0)
 .I SEG("TYPE")=SEG D  Q
"RTN","DGENUPL1",41,0)
 ..I SEG'="ZEL" N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN      ; DG*5.3*894
"RTN","DGENUPL1",42,0)
 ..D:(SEG="ZEL") ZEL^DGENUPL2(1)
"RTN","DGENUPL1",43,0)
 ..S NFLG=1
"RTN","DGENUPL1",44,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",45,0)
 .S ERROR=1
"RTN","DGENUPL1",46,0)
 .;
"RTN","DGENUPL1",47,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",48,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",49,0)
 ;
"RTN","DGENUPL1",50,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZEL")  D  Q:ERROR
"RTN","DGENUPL1",51,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",52,0)
 .D ZEL^DGENUPL2(COUNT)
"RTN","DGENUPL1",53,0)
 ;
"RTN","DGENUPL1",54,0)
 ;ZE2 is optional, If no ZE2 segment delete pension data
"RTN","DGENUPL1",55,0)
 I 'ERROR D
"RTN","DGENUPL1",56,0)
 .I SEG("TYPE")="ZE2" D ZE2^DGENUPLB S CURLINE=CURLINE+1 Q
"RTN","DGENUPL1",57,0)
 .I SEG("TYPE")'="ZE2" D
"RTN","DGENUPL1",58,0)
 ..Q:$$GET1^DIQ(2,DFN,.3852,"I")=$O(^DG(27.18,"C","00",""))
"RTN","DGENUPL1",59,0)
 ..N PSUB
"RTN","DGENUPL1",60,0)
 ..F PSUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S DGPAT(PSUB)="@"
"RTN","DGENUPL1",61,0)
 ;
"RTN","DGENUPL1",62,0)
 ;ZHP is optional & can repeat. DG*5.3*871
"RTN","DGENUPL1",63,0)
 K DGHBP
"RTN","DGENUPL1",64,0)
 I 'ERROR D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",65,0)
 . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",66,0)
 . S QFLG=0 F  D  Q:QFLG
"RTN","DGENUPL1",67,0)
 . . I SEG("TYPE")'="ZHP" S QFLG=1,CURLINE=CURLINE-1 Q
"RTN","DGENUPL1",68,0)
 . . D ZHP^DGENUPLB
"RTN","DGENUPL1",69,0)
 . . D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",70,0)
 ;
"RTN","DGENUPL1",71,0)
 ;Phase II Add the capability to accept more than 1 ZCD
"RTN","DGENUPL1",72,0)
 I 'ERROR F SEG="ZEN","ZMT","ZCD" D  Q:ERROR
"RTN","DGENUPL1",73,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",74,0)
 .I SEG("TYPE")=SEG D
"RTN","DGENUPL1",75,0)
 ..N DGRTN S DGRTN=SEG_"^DGENUPL2" D @DGRTN      ; DG*5.3*894
"RTN","DGENUPL1",76,0)
 .E  D
"RTN","DGENUPL1",77,0)
 ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",78,0)
 ..S ERROR=1
"RTN","DGENUPL1",79,0)
 ..;
"RTN","DGENUPL1",80,0)
 ..;possible that in a bad message we are now past the end
"RTN","DGENUPL1",81,0)
 ..S CURLINE=CURLINE-1
"RTN","DGENUPL1",82,0)
 ;
"RTN","DGENUPL1",83,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZCD")  D  Q:ERROR
"RTN","DGENUPL1",84,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",85,0)
 .D ZCD^DGENUPL2
"RTN","DGENUPL1",86,0)
 ;
"RTN","DGENUPL1",87,0)
 ; Purple Heart/OEF-OIF  Addition of optional ZMH segment
"RTN","DGENUPL1",88,0)
 ;              Modified handling of ZSP and ZRD to accomodate ZMH
"RTN","DGENUPL1",89,0)
 ;
"RTN","DGENUPL1",90,0)
 I 'ERROR D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",91,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",92,0)
 .I SEG("TYPE")="ZSP" D ZSP^DGENUPL2 Q
"RTN","DGENUPL1",93,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",94,0)
 .S ERROR=1
"RTN","DGENUPL1",95,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",96,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",97,0)
 ;
"RTN","DGENUPL1",98,0)
 ;Modified following code to receive multiple ZMH segment for
"RTN","DGENUPL1",99,0)
 ;Military service information - DG*5.3*653
"RTN","DGENUPL1",100,0)
 I 'ERROR D  Q:ERROR $S(ERROR:0,1:1)
"RTN","DGENUPL1",101,0)
 .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",102,0)
 .S QFLG=0 F  D  Q:QFLG
"RTN","DGENUPL1",103,0)
 . . I SEG("TYPE")'="ZMH" S QFLG=1 Q
"RTN","DGENUPL1",104,0)
 . . D ZMH^DGENUPL2,NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG)
"RTN","DGENUPL1",105,0)
 .I SEG("TYPE")="ZRD" D ZRD^DGENUPL2 Q 
"RTN","DGENUPL1",106,0)
 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),SEG_" SEGMENT MISSING OR OUT OF ORDER",.ERRCOUNT)
"RTN","DGENUPL1",107,0)
 .S ERROR=1
"RTN","DGENUPL1",108,0)
 .;possible that in a bad message we are now past the end
"RTN","DGENUPL1",109,0)
 .S CURLINE=CURLINE-1
"RTN","DGENUPL1",110,0)
 ;
"RTN","DGENUPL1",111,0)
 I 'ERROR F COUNT=2:1 D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG) Q:(SEG("TYPE")'="ZRD")  D  Q:ERROR
"RTN","DGENUPL1",112,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",113,0)
 .D ZRD^DGENUPL2
"RTN","DGENUPL1",114,0)
 ;
"RTN","DGENUPL1",115,0)
 I 'ERROR F  D  Q:(ERROR!(SEG("TYPE")'="OBX"))
"RTN","DGENUPL1",116,0)
 .;possible if OBX segment not present that we are now past the end
"RTN","DGENUPL1",117,0)
 .I SEG("TYPE")'="OBX" S CURLINE=CURLINE-1 Q
"RTN","DGENUPL1",118,0)
 .D OBX^DGENUPL2
"RTN","DGENUPL1",119,0)
 .S CURLINE=CURLINE+1
"RTN","DGENUPL1",120,0)
 .D NXTSEG^DGENUPL(MSGIEN,CURLINE,.SEG)
"RTN","DGENUPL1",121,0)
 ;
"RTN","DGENUPL1",122,0)
 Q $S(ERROR:0,1:1)
"RTN","DGENUPL1",123,0)
 ;
"RTN","DGENUPL1",124,0)
CONVERT(VAL,DATATYPE,ERROR) ;
"RTN","DGENUPL1",125,0)
 ;Description: Converts the value found in the HL7 segment to DHCP format
"RTN","DGENUPL1",126,0)
 ;
"RTN","DGENUPL1",127,0)
 ;Input:
"RTN","DGENUPL1",128,0)
 ;  VAL - value parsed from the HL7 segment
"RTN","DGENUPL1",129,0)
 ;  DATATYPE: indicates the type of conversion necessary
"RTN","DGENUPL1",130,0)
 ;      "DATE" - needs to be converted to FM format
"RTN","DGENUPL1",131,0)
 ;      "TS" - time stamp, needs to be converted to FM format
"RTN","DGENUPL1",132,0)
 ;      "Y/N" - 0->"N",1->"Y"
"RTN","DGENUPL1",133,0)
 ;      "1/0" - "Y"->1,"N"->0
"RTN","DGENUPL1",134,0)
 ;      "INSTITUTION" - needs to convert the station number with suffix to a point to the INSTITUTION file
"RTN","DGENUPL1",135,0)
 ;      "ELIGIBILITY" - VAL is a pointer to the national eligibility code file (#8.1), needs to be converted to a local eligibility code (file #8)
"RTN","DGENUPL1",136,0)
 ;
"RTN","DGENUPL1",137,0)
 ;      "MT" - VAL  is a Means Test Status code, it needs to be converted
"RTN","DGENUPL1",138,0)
 ;             to a pointer to the Means Test Status file
"RTN","DGENUPL1",139,0)
 ;       Phase II convert code to RSN IEN for DGCDIS object
"RTN","DGENUPL1",140,0)
 ;       "CDRSN" data type converts the codes diagnosis,procedure,condition to RSN IEN. (HL7TORSN^DGENA5)
"RTN","DGENUPL1",141,0)
 ;       "CDDSCR" data type converts the codes descriptor(s) to DSCR IEN. (HL7TODSC^DGENA5)   DG*5.3*894
"RTN","DGENUPL1",142,0)
 ;       "EXT" convert from code to abbreviation
"RTN","DGENUPL1",143,0)
 ;       "POS" convert from Period of Service code to a point to Period of Service file
"RTN","DGENUPL1",144,0)
 ;       "AGENCY" convert Agency/Allied Country code from file 35
"RTN","DGENUPL1",145,0)
 ;       "PENSIONCD" convert Pension Award/Termination Reason code from file 27.18
"RTN","DGENUPL1",146,0)
 ;       "HBP" convert from code to file 25.11 ien DG*5.3*871
"RTN","DGENUPL1",147,0)
 ;OUTPUT:
"RTN","DGENUPL1",148,0)
 ;  Function Value - the result of the conversion
"RTN","DGENUPL1",149,0)
 ;  ERROR - set to 1 if an error is detected, 0 otherwise (optional,pass by ref)
"RTN","DGENUPL1",150,0)
 S ERROR=0
"RTN","DGENUPL1",151,0)
 D
"RTN","DGENUPL1",152,0)
 .I VAL="" Q
"RTN","DGENUPL1",153,0)
 .I VAL="""""" S VAL="@" Q
"RTN","DGENUPL1",154,0)
 .I $G(DATATYPE)="EXT" D  Q
"RTN","DGENUPL1",155,0)
 ..S VAL=$$HLTOLIMB^DGENA5(VAL)
"RTN","DGENUPL1",156,0)
 .I $G(DATATYPE)="CDRSN" D  Q
"RTN","DGENUPL1",157,0)
 ..S VAL=$$HL7TORSN^DGENA5(VAL)
"RTN","DGENUPL1",158,0)
 .; * check the new DESCRIPTOR seq  -  DG*5.3*894
"RTN","DGENUPL1",159,0)
 .I $G(DATATYPE)="CDDSCR" D  Q
"RTN","DGENUPL1",160,0)
 ..S VAL=$$HL7TODSC^DGENA5(VAL)
"RTN","DGENUPL1",161,0)
 .I ($G(DATATYPE)="MT") D  Q
"RTN","DGENUPL1",162,0)
 ..S VAL=$O(^DG(408.32,"AC",1,VAL,0))
"RTN","DGENUPL1",163,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",164,0)
 .I ($G(DATATYPE)="DATE") D  Q
"RTN","DGENUPL1",165,0)
 ..I $L(VAL)'=8 S ERROR=1 Q
"RTN","DGENUPL1",166,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",167,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",168,0)
 .I ($G(DATATYPE)="TS") D  Q
"RTN","DGENUPL1",169,0)
 ..I $L(VAL)<8 S ERROR=1 Q
"RTN","DGENUPL1",170,0)
 ..S VAL=$$FMDATE^HLFNC(VAL)
"RTN","DGENUPL1",171,0)
 ..I ((VAL'=+VAL)!($L($P(VAL,"."))<7)) S ERROR=1
"RTN","DGENUPL1",172,0)
 .I ($G(DATATYPE)="Y/N") D  Q
"RTN","DGENUPL1",173,0)
 ..I VAL=0 S VAL="N" Q
"RTN","DGENUPL1",174,0)
 ..I VAL=1 S VAL="Y" Q
"RTN","DGENUPL1",175,0)
 ..S ERROR=1
"RTN","DGENUPL1",176,0)
 .I ($G(DATATYPE)="1/0") D  Q
"RTN","DGENUPL1",177,0)
 ..I VAL="N" S VAL=0 Q
"RTN","DGENUPL1",178,0)
 ..I VAL="Y" S VAL=1 Q
"RTN","DGENUPL1",179,0)
 ..S ERROR=1
"RTN","DGENUPL1",180,0)
 .I ($G(DATATYPE)="ELIGIBILITY") D  Q
"RTN","DGENUPL1",181,0)
 ..S VAL=$$MAP(VAL)
"RTN","DGENUPL1",182,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",183,0)
 .I ($G(DATATYPE)="INSTITUTION") D  Q
"RTN","DGENUPL1",184,0)
 ..N OLDVAL
"RTN","DGENUPL1",185,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",186,0)
 ..S VAL=$O(^DIC(4,"D",OLDVAL,0))
"RTN","DGENUPL1",187,0)
 ..I 'VAL S VAL=$O(^DIC(4,"D",(+OLDVAL),0))
"RTN","DGENUPL1",188,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",189,0)
 .I ($G(DATATYPE)="POS") D  Q
"RTN","DGENUPL1",190,0)
 ..N OLDVAL
"RTN","DGENUPL1",191,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",192,0)
 ..S VAL=$O(^DIC(21,"D",OLDVAL,0))
"RTN","DGENUPL1",193,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",194,0)
 .I ($G(DATATYPE)="AGENCY") D  Q
"RTN","DGENUPL1",195,0)
 ..N OLDVAL
"RTN","DGENUPL1",196,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",197,0)
 ..S VAL=$O(^DIC(35,"C",OLDVAL,0))
"RTN","DGENUPL1",198,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",199,0)
 .I ($G(DATATYPE)="PENSIONCD") D  Q
"RTN","DGENUPL1",200,0)
 ..N OLDVAL
"RTN","DGENUPL1",201,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",202,0)
 ..S VAL=$O(^DG(27.18,"C",OLDVAL,0))
"RTN","DGENUPL1",203,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",204,0)
 .I ($G(DATATYPE)="HBP") D  Q    ; DG*5.3*871
"RTN","DGENUPL1",205,0)
 ..N OLDVAL
"RTN","DGENUPL1",206,0)
 ..S OLDVAL=VAL
"RTN","DGENUPL1",207,0)
 ..S VAL=$O(^DGHBP(25.11,"C",OLDVAL,0))
"RTN","DGENUPL1",208,0)
 ..I 'VAL S ERROR=1
"RTN","DGENUPL1",209,0)
 Q VAL
"RTN","DGENUPL1",210,0)
 ;
"RTN","DGENUPL1",211,0)
MAP(VALUE) ;
"RTN","DGENUPL1",212,0)
 ;Description: Tries to map an eligibility code from file #8.1 (the national MAS ELIGIBILITY CODE file) to file #8 (the local ELIGIBILITY CODE file)
"RTN","DGENUPL1",213,0)
 ;
"RTN","DGENUPL1",214,0)
 ;Input: VALUE - ien of an entry in file #8.1
"RTN","DGENUPL1",215,0)
 ;
"RTN","DGENUPL1",216,0)
 ;Output: Function value - NULL if mapping is not found, otherwise returns an ien of entry in file #8
"RTN","DGENUPL1",217,0)
 ;
"RTN","DGENUPL1",218,0)
 N ECODE,NODE,COUNT,NAME
"RTN","DGENUPL1",219,0)
 ;try to choose a code from file 8 to use that is appropriate
"RTN","DGENUPL1",220,0)
 S (COUNT,ECODE)=0
"RTN","DGENUPL1",221,0)
 ;
"RTN","DGENUPL1",222,0)
 F  S ECODE=$O(^DIC(8,"D",VALUE,ECODE)) Q:'ECODE  D
"RTN","DGENUPL1",223,0)
 .S NODE=$G(^DIC(8,ECODE,0))
"RTN","DGENUPL1",224,0)
 .;put code on list if active
"RTN","DGENUPL1",225,0)
 .I (NODE'=""),'$P(NODE,"^",7) S ECODE(ECODE)=$P(NODE,"^"),COUNT=COUNT+1
"RTN","DGENUPL1",226,0)
 ;
"RTN","DGENUPL1",227,0)
 ;only one match found, so use it
"RTN","DGENUPL1",228,0)
 Q:COUNT=1 $O(ECODE(0))
"RTN","DGENUPL1",229,0)
 ;
"RTN","DGENUPL1",230,0)
 ;no match found
"RTN","DGENUPL1",231,0)
 Q:'COUNT ""
"RTN","DGENUPL1",232,0)
 ;
"RTN","DGENUPL1",233,0)
 ;multiple matches found, try to match by name
"RTN","DGENUPL1",234,0)
 I COUNT>1 D
"RTN","DGENUPL1",235,0)
 .S ECODE=0
"RTN","DGENUPL1",236,0)
 .S NAME=$P($G(^DIC(8.1,VALUE,0)),"^")
"RTN","DGENUPL1",237,0)
 .F  S ECODE=$O(ECODE(ECODE)) Q:'ECODE  Q:ECODE(ECODE)=NAME
"RTN","DGENUPL1",238,0)
 Q ECODE
"RTN","DGENUPL1",239,0)
 ;
"RTN","DGENUPL1",240,0)
ACCEPT(MSGID) ;
"RTN","DGENUPL1",241,0)
 ;Description: Writes an ack (AA) to a global to be transmitted later.
"RTN","DGENUPL1",242,0)
 ;
"RTN","DGENUPL1",243,0)
 ;Inputs:
"RTN","DGENUPL1",244,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL1",245,0)
 ;
"RTN","DGENUPL1",246,0)
 ;Outputs: none
"RTN","DGENUPL1",247,0)
 ;
"RTN","DGENUPL1",248,0)
 K HL,HLMID,HLMTIEN,HLDT,HLDT1
"RTN","DGENUPL1",249,0)
 D INIT^HLFNC2(HLEID,.HL)
"RTN","DGENUPL1",250,0)
 D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
"RTN","DGENUPL1",251,0)
 S HLEVN=1
"RTN","DGENUPL1",252,0)
 S MID=HLMID_"-"_HLEVN
"RTN","DGENUPL1",253,0)
 D MSH^HLFNC2(.HL,MID,.HLRES)
"RTN","DGENUPL1",254,0)
 S ^TMP("HLS",$J,1)=HLRES
"RTN","DGENUPL1",255,0)
 ;
"RTN","DGENUPL1",256,0)
 ;it seems HLFS sometimes disappears upon reaching this point
"RTN","DGENUPL1",257,0)
 I $G(HLFS)="" S HLFS="^"
"RTN","DGENUPL1",258,0)
 ;
"RTN","DGENUPL1",259,0)
 S ^TMP("HLS",$J,2)="MSA"_HLFS_"AA"_HLFS_MSGID
"RTN","DGENUPL1",260,0)
 Q
"RTN","DGENUPL1",261,0)
 ;
"RTN","DGENUPL1",262,0)
MVERRORS ;
"RTN","DGENUPL1",263,0)
 ;Error messages were being deleted from ^TMP("HLS",$J by another package
"RTN","DGENUPL1",264,0)
 ;during the upload.  To fix this, errors are written to another
"RTN","DGENUPL1",265,0)
 ;subscript, then moved when the error list is complete.
"RTN","DGENUPL1",266,0)
 ;
"RTN","DGENUPL1",267,0)
 M ^TMP("HLS",$J)=^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",268,0)
 K ^TMP("IVM","HLS",$J)
"RTN","DGENUPL1",269,0)
 Q
"RTN","DGENUPL7")
0^18^B34918538
"RTN","DGENUPL7",1,0)
DGENUPL7 ;ISA/KWP,CKN,TMK,TDM,LBD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;6/17/13 5:48pm
"RTN","DGENUPL7",2,0)
 ;;5.3;REGISTRATION;**232,367,397,417,379,431,513,628,673,653,742,688,797,871**;Aug 13,1993;Build 84
"RTN","DGENUPL7",3,0)
 ;
"RTN","DGENUPL7",4,0)
 ;Phase II split from DGENUPL
"RTN","DGENUPL7",5,0)
Z11(MSGIEN,MSGID,CURLINE,DFN,ERRCOUNT) ;
"RTN","DGENUPL7",6,0)
 ;Description:  This is used to process a single ORU~Z11 or ORF~Z11 msg. 
"RTN","DGENUPL7",7,0)
 ;Input:
"RTN","DGENUPL7",8,0)
 ;  MSGIEN - the internal entry number of the HL7 message in the
"RTN","DGENUPL7",9,0)
 ;      HL7 MESSAGE TEXT file (772)
"RTN","DGENUPL7",10,0)
 ;  MSGID -message control id of HL7 msg in the MSH segment
"RTN","DGENUPL7",11,0)
 ;  CURLINE - the subscript of the MSH segment of the current message (pass by reference)
"RTN","DGENUPL7",12,0)
 ;  DFN - identifies the patient, is the ien of a record in the PATIENT file.
"RTN","DGENUPL7",13,0)
 ;  ERRCOUNT - is a count of the number of messages in the batch that can not be processed (pass by reference)
"RTN","DGENUPL7",14,0)
 ;
"RTN","DGENUPL7",15,0)
 ;Output:
"RTN","DGENUPL7",16,0)
 ;  CURLINE - upon leaving the procedure this parameter should be set to the end of the current message. (pass by reference)
"RTN","DGENUPL7",17,0)
 ;  ERRCOUNT - set to count of messages that were not processed due to errors encountered  (pass by reference)
"RTN","DGENUPL7",18,0)
 ;
"RTN","DGENUPL7",19,0)
 N DGELG,DGENR,DGPAT,DGCDIS,DGOEIF,ERROR,ERRMSG,MSGS,DGELGSUB,DGENUPLD,DGCON,DGNMSE
"RTN","DGENUPL7",20,0)
 N DGNEWVAL,DIV,SUB,OLDELG,OLDPAT,OLDDCDIS,OLDEIF,DGSEC,OLDSEC,DGNTR,DGMST,DGPHINC,DGHBP
"RTN","DGENUPL7",21,0)
 ;
"RTN","DGENUPL7",22,0)
 ;some process is killing these HL7 variables, so need to protect them
"RTN","DGENUPL7",23,0)
 S SUB=HLFS
"RTN","DGENUPL7",24,0)
 S DIV=HLECH
"RTN","DGENUPL7",25,0)
 N HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLECH,HLFS,HLNDAP,HLNDAP0,HLPID,HLQ,HLVER,HLERR,HLMTN,HLSDT
"RTN","DGENUPL7",26,0)
 S HLFS=SUB
"RTN","DGENUPL7",27,0)
 S HLECH=DIV
"RTN","DGENUPL7",28,0)
 S HLQ=""""""
"RTN","DGENUPL7",29,0)
 K DIV,SUB
"RTN","DGENUPL7",30,0)
 ;
"RTN","DGENUPL7",31,0)
 ;drops out of block on error
"RTN","DGENUPL7",32,0)
 D
"RTN","DGENUPL7",33,0)
 .Q:'$$PARSE^DGENUPL1(MSGIEN,MSGID,.CURLINE,.ERRCOUNT,.DGPAT,.DGELG,.DGENR,.DGCDIS,.DGOEIF,.DGSEC,.DGNTR,.DGMST,.DGNMSE,.DGHBP)
"RTN","DGENUPL7",34,0)
 .D GETLOCKS^DGENUPL5(DFN)
"RTN","DGENUPL7",35,0)
 .;
"RTN","DGENUPL7",36,0)
 .;Used by cross-references to determine if an upload is in progress.
"RTN","DGENUPL7",37,0)
 .S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
"RTN","DGENUPL7",38,0)
 .;
"RTN","DGENUPL7",39,0)
 .;Update the PATIENT, ELIGIBILITY, CATASTROPHIC DISABILITY objects in memory
"RTN","DGENUPL7",40,0)
 .Q:'$$UOBJECTS^DGENUPL4(DFN,.DGPAT,.DGELG,.DGCDIS,.DGOEIF,MSGID,.ERRCOUNT,.MSGS,.OLDPAT,.OLDELG,.OLDCDIS,.OLDEIF)
"RTN","DGENUPL7",41,0)
 .S ERROR=0
"RTN","DGENUPL7",42,0)
 .;if the msg contains patient security, process it
"RTN","DGENUPL7",43,0)
 .I $D(DGSEC) D  Q:ERROR
"RTN","DGENUPL7",44,0)
 ..S DGSEC("DFN")=DFN
"RTN","DGENUPL7",45,0)
 ..S DGSEC("USER")=.5
"RTN","DGENUPL7",46,0)
 ..I DGSEC("LEVEL")'="" D
"RTN","DGENUPL7",47,0)
 ...I DGSEC("DATETIME")="" S DGSEC("DATETIME")=$$NOW^XLFDT ;DG*5.3*653 
"RTN","DGENUPL7",48,0)
 ..;
"RTN","DGENUPL7",49,0)
 ..; check consistency of patient security record
"RTN","DGENUPL7",50,0)
 ..I '$$CHECK^DGENSEC(.DGSEC,.ERRMSG) D  Q
"RTN","DGENUPL7",51,0)
 ...S ERROR=1
"RTN","DGENUPL7",52,0)
 ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL7",53,0)
 ..;
"RTN","DGENUPL7",54,0)
 ..; upload patient security, consistency checks passed
"RTN","DGENUPL7",55,0)
 ..D SECUPLD^DGENUPL5(DFN,.DGSEC,.OLDSEC)
"RTN","DGENUPL7",56,0)
 .;
"RTN","DGENUPL7",57,0)
 .;if the msg has an enrollment process it
"RTN","DGENUPL7",58,0)
 .I DGENR("STATUS")!DGENR("APP") D  Q:ERROR
"RTN","DGENUPL7",59,0)
 ..;use $$PRIORITY to get the eligibility data used to compute priority
"RTN","DGENUPL7",60,0)
 ..I $$PRIORITY^DGENELA4(DFN,.DGELG,.DGELGSUB,DGENR("DATE"),DGENR("APP"))
"RTN","DGENUPL7",61,0)
 ..;
"RTN","DGENUPL7",62,0)
 ..;store the eligibility data in the enrollment record and other missing fields
"RTN","DGENUPL7",63,0)
 ..M DGENR("ELIG")=DGELGSUB
"RTN","DGENUPL7",64,0)
 ..S DGENR("DFN")=DFN
"RTN","DGENUPL7",65,0)
 ..S DGENR("PRIORREC")=""
"RTN","DGENUPL7",66,0)
 ..S DGENR("USER")=.5
"RTN","DGENUPL7",67,0)
 ..S DGENR("DATETIME")=$$NOW^XLFDT
"RTN","DGENUPL7",68,0)
 ..;
"RTN","DGENUPL7",69,0)
 ..;Allow null overwrites of Ineligible data (Ineligible Project):
"RTN","DGENUPL7",70,0)
 ..I $D(DGENR("DATE")),DGENR("DATE")="" S DGENR("DATE")="@"
"RTN","DGENUPL7",71,0)
 ..I $D(DGENR("FACREC")),DGENR("FACREC")="" S DGENR("FACREC")="@"
"RTN","DGENUPL7",72,0)
 ..;
"RTN","DGENUPL7",73,0)
 ..;check the consistency of the enrollment record
"RTN","DGENUPL7",74,0)
 ..I '$$CHECK^DGENA3(.DGENR,.DGPAT,.ERRMSG) D  Q
"RTN","DGENUPL7",75,0)
 ...S ERROR=1
"RTN","DGENUPL7",76,0)
 ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL7",77,0)
 ..;
"RTN","DGENUPL7",78,0)
 ..; removed EGT consistency check with DG*5.3*628
"RTN","DGENUPL7",79,0)
 ..;Phase II EGT consistency checks (SRS 6.5.1.3)
"RTN","DGENUPL7",80,0)
 ..;Only do the EGT consistency checks for Rejected-Fiscal Year (11),Rejected-Mid Cycle (12),Rejected-Stop enrolling new apps (13),Rejected-Initil App by VAMC (14),Rejected below EGT threshold (22)
"RTN","DGENUPL7",81,0)
 ..;I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$ABOVE^DGENEGT1(DGENR("DFN"),DGENR("PRIORITY"),DGENR("SUBGRP"),"","",1) D  Q
"RTN","DGENUPL7",82,0)
 ..;.S ERROR=1
"RTN","DGENUPL7",83,0)
 ..;.S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE EGT CONSISTENCY CHECKS."
"RTN","DGENUPL7",84,0)
 ..;.D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
"RTN","DGENUPL7",85,0)
 ..;
"RTN","DGENUPL7",86,0)
 ..;Allow null overwrites for Ineligible vets (Ineligible Project):
"RTN","DGENUPL7",87,0)
 ..I $G(DGPAT("INELDATE"))'="" S (DGENR("PRIORITY"),DGENR("SUBGRP"))=""
"RTN","DGENUPL7",88,0)
 ..I DGENR("DATE")="@" S DGENR("DATE")=""
"RTN","DGENUPL7",89,0)
 ..I DGENR("FACREC")="@" S DGENR("FACREC")=""
"RTN","DGENUPL7",90,0)
 ..;
"RTN","DGENUPL7",91,0)
 ..D ENRUPLD^DGENUPL8(.DGENR,.DGPAT)
"RTN","DGENUPL7",92,0)
 .;
"RTN","DGENUPL7",93,0)
 .;Store the PATIENT, ELIGIBILITY, & CAT. DISB. objects
"RTN","DGENUPL7",94,0)
 .I $$STORE^DGENPTA1(.DGPAT,,1)
"RTN","DGENUPL7",95,0)
 .I $$STORE^DGENELA1(.DGELG,.DGPAT,.DGCDIS,,1)
"RTN","DGENUPL7",96,0)
 .I $G(DGCDIS("VCD"))'="",$$STORE^DGENCDA2(DFN,.DGCDIS) ;checks first if there is catastrophic disability information
"RTN","DGENUPL7",97,0)
 .;
"RTN","DGENUPL7",98,0)
 .;Call PIMS api to file NTR data.
"RTN","DGENUPL7",99,0)
 .I $D(DGNTR),$$ENRUPD^DGNTAPI1(DFN,.DGNTR)
"RTN","DGENUPL7",100,0)
 .;
"RTN","DGENUPL7",101,0)
 .;Call PIMS api to file MST data.
"RTN","DGENUPL7",102,0)
 .I DGMST("MSTSTAT")'="",DGMST("MSTDT")'="",DGMST("MSTST")'="" D
"RTN","DGENUPL7",103,0)
 ..I $$NEWSTAT^DGMSTAPI(DFN,DGMST("MSTSTAT"),DGMST("MSTDT"),".5",DGMST("MSTST"),0)
"RTN","DGENUPL7",104,0)
 .;
"RTN","DGENUPL7",105,0)
 .;Since HEC is authoritative source, If no OEF/OIF data in Z11, set count to 0 so existing data in VistA will be deleted.
"RTN","DGENUPL7",106,0)
 .I '$D(DGOEIF) S DGOEIF("COUNT")=0
"RTN","DGENUPL7",107,0)
 .;Call PIMS api to file OEF/OIF data.
"RTN","DGENUPL7",108,0)
 .I $D(DGOEIF) D OEIFUPD^DGCLAPI1(DFN,.DGOEIF)
"RTN","DGENUPL7",109,0)
 .;
"RTN","DGENUPL7",110,0)
 .;File the Military Service Episode (MSE) data (DG*5.3*797)
"RTN","DGENUPL7",111,0)
 .I $D(DGNMSE) D UPDMSE^DGMSEUTL(DFN,.DGNMSE)
"RTN","DGENUPL7",112,0)
 .;
"RTN","DGENUPL7",113,0)
 .;File the Health Benefit Plan (HBP) data
"RTN","DGENUPL7",114,0)
 .D HL7UPD^DGHBPUTL(DFN,.DGHBP,MSHDT)
"RTN","DGENUPL7",115,0)
 .;
"RTN","DGENUPL7",116,0)
 .;if the current enrollment is a local then log patient for transmission
"RTN","DGENUPL7",117,0)
 .I $$SOURCE^DGENA(DFN)=1!$G(DGPHINC) K DGENUPLD,DGPHINC D EVENT^IVMPLOG(DFN)
"RTN","DGENUPL7",118,0)
 .;
"RTN","DGENUPL7",119,0)
 .;create the audit trail
"RTN","DGENUPL7",120,0)
 .I $$AUDIT^DGENUPA1(,MSGID,.OLDPAT,.DGPAT,.OLDELG,.DGELG,.OLDCDIS,.DGCDIS,.DGSEC,.OLDSEC)
"RTN","DGENUPL7",121,0)
 .;send notifications
"RTN","DGENUPL7",122,0)
 .D NOTIFY^DGENUPL3(.DGPAT,.MSGS)
"RTN","DGENUPL7",123,0)
 .;
"RTN","DGENUPL7",124,0)
 .;invoke registration consistency checker
"RTN","DGENUPL7",125,0)
 .D REGCHECK^DGENUPL2(DFN)
"RTN","DGENUPL7",126,0)
 ;
"RTN","DGENUPL7",127,0)
 D UNLOCK^DGENUPL5(DFN)
"RTN","DGENUPL7",128,0)
 Q
"RTN","DGENUPLB")
0^19^B15063968
"RTN","DGENUPLB",1,0)
DGENUPLB ;ALB/TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;4/10/13 6:53pm
"RTN","DGENUPLB",2,0)
 ;;5.3;REGISTRATION;**625,763,842,871**;Aug 13,1993;Build 84
"RTN","DGENUPLB",3,0)
 ;
"RTN","DGENUPLB",4,0)
EP N MSGARY
"RTN","DGENUPLB",5,0)
 D CHECK
"RTN","DGENUPLB",6,0)
 Q
"RTN","DGENUPLB",7,0)
 ;
"RTN","DGENUPLB",8,0)
CHECK ;Check for Rated Disability Changes
"RTN","DGENUPLB",9,0)
 Q:'$D(DGELG)
"RTN","DGENUPLB",10,0)
 N RDOCC,TMPARY,RD,RDOCC1,RDOCC2,RDFLG,RDNOD
"RTN","DGENUPLB",11,0)
 ;
"RTN","DGENUPLB",12,0)
 ;Change in Rated Disabilities
"RTN","DGENUPLB",13,0)
 I $D(OLDELG("RATEDIS")) D
"RTN","DGENUPLB",14,0)
 .S RDOCC=0 F  S RDOCC=$O(OLDELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
"RTN","DGENUPLB",15,0)
 ..S RD=$P(OLDELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
"RTN","DGENUPLB",16,0)
 ..S TMPARY(RD)=RDOCC
"RTN","DGENUPLB",17,0)
 ;
"RTN","DGENUPLB",18,0)
 I $D(DGELG("RATEDIS")) D
"RTN","DGENUPLB",19,0)
 .S RDOCC=0 F  S RDOCC=$O(DGELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
"RTN","DGENUPLB",20,0)
 ..S RD=$P(DGELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
"RTN","DGENUPLB",21,0)
 ..S $P(TMPARY(RD),"^",2)=RDOCC
"RTN","DGENUPLB",22,0)
 ;
"RTN","DGENUPLB",23,0)
 I $D(TMPARY) D
"RTN","DGENUPLB",24,0)
 .S RD=""
"RTN","DGENUPLB",25,0)
 .F  S RD=$O(TMPARY(RD)) Q:RD=""  D
"RTN","DGENUPLB",26,0)
 ..S RDOCC2=+$P(TMPARY(RD),"^",2) Q:'RDOCC2
"RTN","DGENUPLB",27,0)
 ..S RDOCC1=+$P(TMPARY(RD),"^")
"RTN","DGENUPLB",28,0)
 ..I 'RDOCC1 D STOR390 Q
"RTN","DGENUPLB",29,0)
 ..S RDFLG=0
"RTN","DGENUPLB",30,0)
 ..F RDNOD="RD","PER","RDSC","RDEXT","RDORIG","RDCURR" D  Q:RDFLG
"RTN","DGENUPLB",31,0)
 ...I $G(OLDELG("RATEDIS",RDOCC1,RDNOD))'=$G(DGELG("RATEDIS",RDOCC2,RDNOD)) D STOR390
"RTN","DGENUPLB",32,0)
 Q
"RTN","DGENUPLB",33,0)
 ;
"RTN","DGENUPLB",34,0)
STOR390 ;Store Data in file# 390
"RTN","DGENUPLB",35,0)
 S RDFLG=1
"RTN","DGENUPLB",36,0)
 N DATA,DA
"RTN","DGENUPLB",37,0)
 S DATA(.01)=$$NOW^XLFDT
"RTN","DGENUPLB",38,0)
 S DATA(2)=DFN
"RTN","DGENUPLB",39,0)
 S DATA(3)=DGELG("RATEDIS",RDOCC2,"RD")
"RTN","DGENUPLB",40,0)
 S DATA(4)=DGELG("RATEDIS",RDOCC2,"PER")
"RTN","DGENUPLB",41,0)
 S DATA(5)=DGELG("RATEDIS",RDOCC2,"RDEXT")
"RTN","DGENUPLB",42,0)
 S DATA(6)=DGELG("RATEDIS",RDOCC2,"RDORIG")
"RTN","DGENUPLB",43,0)
 S DATA(7)=DGELG("RATEDIS",RDOCC2,"RDCURR")
"RTN","DGENUPLB",44,0)
 I '$$ADD^DGENDBS(390,,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILITY UPLOAD AUDIT"
"RTN","DGENUPLB",45,0)
 Q
"RTN","DGENUPLB",46,0)
 ;
"RTN","DGENUPLB",47,0)
ZE2 ; Process ZE2 segment
"RTN","DGENUPLB",48,0)
 N HL7REP,HL7SC,SUB
"RTN","DGENUPLB",49,0)
 S HL7SC=$E(HLECH,1)
"RTN","DGENUPLB",50,0)
 S DGPAT("PENAEFDT")=$$CONVERT^DGENUPL1($P(SEG(1),HL7SC),"DATE",.ERROR)
"RTN","DGENUPLB",51,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 1-1",.ERRCOUNT) Q
"RTN","DGENUPLB",52,0)
 S DGPAT("PENTRMDT")=$$CONVERT^DGENUPL1($P(SEG(1),HL7SC,2),"DATE",.ERROR)
"RTN","DGENUPLB",53,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 1-2",.ERRCOUNT) Q
"RTN","DGENUPLB",54,0)
 S DGPAT("PENAREAS")=$$CONVERT^DGENUPL1($P(SEG(2),HL7SC),"PENSIONCD",.ERRCOUNT)
"RTN","DGENUPLB",55,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 2",.ERRCOUNT) Q
"RTN","DGENUPLB",56,0)
 F HL7REP=1:1:4 D  Q:ERROR
"RTN","DGENUPLB",57,0)
 .Q:$P($P(SEG(3),"|",HL7REP),HL7SC)=""
"RTN","DGENUPLB",58,0)
 .S SUB="PENTRMR"_HL7REP
"RTN","DGENUPLB",59,0)
 .S DGPAT(SUB)=$$CONVERT^DGENUPL1($P($P(SEG(3),"|",HL7REP),HL7SC),"PENSIONCD",.ERRCOUNT)
"RTN","DGENUPLB",60,0)
 .I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZE2 SEGMENT , SEQ 3",.ERRCOUNT)
"RTN","DGENUPLB",61,0)
 ;
"RTN","DGENUPLB",62,0)
 ; Convert to deletion indicator if null
"RTN","DGENUPLB",63,0)
 N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" S:$G(DGPAT(SUB))="" DGPAT(SUB)="@"
"RTN","DGENUPLB",64,0)
 Q
"RTN","DGENUPLB",65,0)
 ;
"RTN","DGENUPLB",66,0)
ZHP ;Process ZHP segment
"RTN","DGENUPLB",67,0)
 N CTR
"RTN","DGENUPLB",68,0)
 S CTR=$O(DGHBP(""),-1)+1
"RTN","DGENUPLB",69,0)
 S $P(DGHBP(CTR),U)=$$CONVERT^DGENUPL1(SEG(2),"HBP",.ERROR)
"RTN","DGENUPLB",70,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 2",.ERRCOUNT) Q
"RTN","DGENUPLB",71,0)
 S $P(DGHBP(CTR),U,2)=$$CONVERT^DGENUPL1(SEG(3),"TS",.ERROR)
"RTN","DGENUPLB",72,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 3",.ERRCOUNT) Q
"RTN","DGENUPLB",73,0)
 S $P(DGHBP(CTR),U,3)=.5                          ;Postmaster
"RTN","DGENUPLB",74,0)
 S $P(DGHBP(CTR),U,4)=$$CONVERT^DGENUPL1(SEG(5),"INSTITUTION",.ERROR)
"RTN","DGENUPLB",75,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 5",.ERRCOUNT) Q
"RTN","DGENUPLB",76,0)
 S $P(DGHBP(CTR),U,5)=$$CONVERT^DGENUPL1(SEG(4),,.ERROR)
"RTN","DGENUPLB",77,0)
 I (($P(DGHBP(CTR),U,5)'="V")&($P(DGHBP(CTR),U,5)'="E")) S ERROR=1
"RTN","DGENUPLB",78,0)
 I ERROR D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZHP SEGMENT , SEQ 4",.ERRCOUNT) Q
"RTN","DGENUPLB",79,0)
 Q
"RTN","DGHBPUTL")
0^12^B37209374
"RTN","DGHBPUTL",1,0)
DGHBPUTL ;ALB/PWC - Health Benefit Plan Utility Routine ;5/22/13 11:50am
"RTN","DGHBPUTL",2,0)
 ;;5.3;Registration;**871**;08/13/93;Build 84
"RTN","DGHBPUTL",3,0)
 ;
"RTN","DGHBPUTL",4,0)
 ;
"RTN","DGHBPUTL",5,0)
GETHBP(DFN) ;Return all records in HBP sub-file #25.01 in HBP array
"RTN","DGHBPUTL",6,0)
 ; returns current information in HBP("CUR",PLAN NAME)=ENTIRE DATA FROM 25.01 DA
"RTN","DGHBPUTL",7,0)
 ; returns current information in HBP("CUR",PLAN NAME,"IEN")=PLAN CODE
"RTN","DGHBPUTL",8,0)
 ; returns history information in HBP("HIS",DA,DTTM)=PLAN NAME^ENTIRE DATA FROM 25.02 DA
"RTN","DGHBPUTL",9,0)
 I '$G(DFN) Q
"RTN","DGHBPUTL",10,0)
 N SDT,HBDATA,HBCODE,HBNAME K HBP("CUR"),HBP("HIS")
"RTN","DGHBPUTL",11,0)
 S SDT=0,(HBDATA,HBCODE)=""
"RTN","DGHBPUTL",12,0)
 F  S SDT=$O(^DPT(DFN,"HBP",SDT)) Q:SDT<1  D
"RTN","DGHBPUTL",13,0)
 . S HBDATA=$G(^DPT(DFN,"HBP",SDT,0)),HBCODE=$P(HBDATA,"^",1)
"RTN","DGHBPUTL",14,0)
 . S HBNAME=$P($G(^DGHBP(25.11,HBCODE,0)),"^",1) Q:HBNAME=""
"RTN","DGHBPUTL",15,0)
 . S HBP("CUR",HBNAME)=HBDATA
"RTN","DGHBPUTL",16,0)
 . S HBP("CUR",HBNAME,"IEN")=HBCODE
"RTN","DGHBPUTL",17,0)
HBP1 S SDT=0,(HBDATA,HBCODE)=""
"RTN","DGHBPUTL",18,0)
 F  S SDT=$O(^DPT(DFN,"HBP1",SDT)) Q:SDT<1  D
"RTN","DGHBPUTL",19,0)
 . S HBDATA=$G(^DPT(DFN,"HBP1",SDT,0)),HBCODE=$P(HBDATA,"^",2)
"RTN","DGHBPUTL",20,0)
 . S HBNAME=$P($G(^DGHBP(25.11,HBCODE,0)),"^",1) Q:HBNAME=""
"RTN","DGHBPUTL",21,0)
 . S HBP("HIS",SDT,$P(HBDATA,"^",1))=HBNAME_"^"_$P(HBDATA,"^",2,99)
"RTN","DGHBPUTL",22,0)
 Q
"RTN","DGHBPUTL",23,0)
 ;
"RTN","DGHBPUTL",24,0)
GETDETL(HBPNUM) ;Return detail for each HBP in an array for display purposes
"RTN","DGHBPUTL",25,0)
 I $G(HBPNUM)="" Q 
"RTN","DGHBPUTL",26,0)
 N DATA,CNT,LAST K HBP("DETAIL")
"RTN","DGHBPUTL",27,0)
 S HBP("DETAIL",0)=$G(^DGHBP(25.11,HBPNUM,2,0))
"RTN","DGHBPUTL",28,0)
 I HBP("DETAIL",0)="" S HBP("DETAIL",0)="0^No Detail Available." Q
"RTN","DGHBPUTL",29,0)
 S LAST=$P(HBP("DETAIL",0),"^",4)
"RTN","DGHBPUTL",30,0)
 M DATA=^DGHBP(25.11,HBPNUM,2)
"RTN","DGHBPUTL",31,0)
 F CNT=1:1:LAST S HBP("DETAIL",HBPNUM,CNT)=DATA(CNT,0)
"RTN","DGHBPUTL",32,0)
 Q
"RTN","DGHBPUTL",33,0)
 ;
"RTN","DGHBPUTL",34,0)
GETPLAN ; Return all Health Benefit Plans from file #25.11 in array
"RTN","DGHBPUTL",35,0)
 N HBPLAN,HBIEN,PLAN S HBPLAN="" K HBP("PLAN")
"RTN","DGHBPUTL",36,0)
 F  S HBPLAN=$O(^DGHBP(25.11,"B",HBPLAN)) Q:HBPLAN=""  D
"RTN","DGHBPUTL",37,0)
 . S HBIEN=$O(^DGHBP(25.11,"B",HBPLAN,0)) Q:HBIEN=""  D
"RTN","DGHBPUTL",38,0)
 . S PLAN=$P(^DGHBP(25.11,HBIEN,0),"^",1)
"RTN","DGHBPUTL",39,0)
 . S HBP("PLAN",PLAN)=HBIEN
"RTN","DGHBPUTL",40,0)
 Q
"RTN","DGHBPUTL",41,0)
 ;
"RTN","DGHBPUTL",42,0)
SETPLAN(DFN,PLAN,SITE) ;Set Health Benefit Plan and History into file 25.01 and 25.02 for input DFN
"RTN","DGHBPUTL",43,0)
 ; Current data plans will also be filed into the history so that history will contain all
"RTN","DGHBPUTL",44,0)
 ; additions and deletions for the patient
"RTN","DGHBPUTL",45,0)
 ;
"RTN","DGHBPUTL",46,0)
 N DATETIME,DGENDA,DATA,SUCCESS
"RTN","DGHBPUTL",47,0)
 ; Gather and save DATETIME for both files
"RTN","DGHBPUTL",48,0)
 D NOW^%DTC S DATETIME=%
"RTN","DGHBPUTL",49,0)
 S DGENDA(1)=DFN
"RTN","DGHBPUTL",50,0)
 S DATA(.01)=PLAN                                            ;Current HBP Code
"RTN","DGHBPUTL",51,0)
 S DATA(1)=DATETIME                                          ;Assigned Date/Time
"RTN","DGHBPUTL",52,0)
 S DATA(2)=DUZ                                               ;Assigned Entered By
"RTN","DGHBPUTL",53,0)
 S DATA(3)=$S($G(SITE)="":$P($$SITE^VASITE(),"^",1),1:SITE)  ;Assigned Entered Site
"RTN","DGHBPUTL",54,0)
 S DATA(4)=$S($G(SITE)="":"V",1:"E")                         ;Current Source
"RTN","DGHBPUTL",55,0)
 ; Update Current Health Benefit Plan into DB
"RTN","DGHBPUTL",56,0)
 S SUCCESS=$$ADD^DGENDBS(2.2511,.DGENDA,.DATA)               ;DG*5.3*871 modified 25.01 to 2.511
"RTN","DGHBPUTL",57,0)
 I SUCCESS D EVENT^IVMPLOG(DFN)                              ;trigger for HL7
"RTN","DGHBPUTL",58,0)
 ;
"RTN","DGHBPUTL",59,0)
 ; Reset Data for History - DGENDA remains unchanged
"RTN","DGHBPUTL",60,0)
 N DGENDA,DATA,SUCCESS
"RTN","DGHBPUTL",61,0)
 S DGENDA(1)=DFN
"RTN","DGHBPUTL",62,0)
 S DATA(.01)=DATETIME                                        ;History HBP Date/Time
"RTN","DGHBPUTL",63,0)
 S DATA(1)=PLAN                                              ;History HBP Code
"RTN","DGHBPUTL",64,0)
 S DATA(2)=DUZ                                               ;Assigned Entered By
"RTN","DGHBPUTL",65,0)
 S DATA(3)=$S($G(SITE)="":$P($$SITE^VASITE(),"^",1),1:SITE)  ;Assigned Entered Site
"RTN","DGHBPUTL",66,0)
 S DATA(4)="A"                                               ;History Assignment
"RTN","DGHBPUTL",67,0)
 S DATA(5)=$S($G(SITE)="":"V",1:"E")                         ;History Source
"RTN","DGHBPUTL",68,0)
 ; Update History into DB
"RTN","DGHBPUTL",69,0)
 S SUCCESS=$$ADD^DGENDBS(2.2512,.DGENDA,.DATA)               ;DG*5.3*871 modified 25.02 to 2.512
"RTN","DGHBPUTL",70,0)
 Q
"RTN","DGHBPUTL",71,0)
 ;
"RTN","DGHBPUTL",72,0)
DELPLAN(DFN,PLAN,SITE) ;Delete Health Benefit Plan and set History into file 25.01 and 25.02 for input DFN
"RTN","DGHBPUTL",73,0)
 N DATETIME,DGENDA,DA,DIK,DATA,SUCCESS
"RTN","DGHBPUTL",74,0)
 ; Gather and save DATETIME for both files
"RTN","DGHBPUTL",75,0)
 D NOW^%DTC S DATETIME=%
"RTN","DGHBPUTL",76,0)
 S (DGENDA(1),DA(1))=DFN
"RTN","DGHBPUTL",77,0)
 S DA=$O(^DPT(DA(1),"HBP","B",PLAN,""))
"RTN","DGHBPUTL",78,0)
 ; Delete Health Benefit Plan from DB
"RTN","DGHBPUTL",79,0)
 S DIK="^DPT("_DA(1)_","_"""HBP"""_","
"RTN","DGHBPUTL",80,0)
 D ^DIK K DIK
"RTN","DGHBPUTL",81,0)
 ;
"RTN","DGHBPUTL",82,0)
 ; Reset Data for History - DGENDA remains unchanged
"RTN","DGHBPUTL",83,0)
 S DATA(.01)=DATETIME                                        ;History HBP Date/Time
"RTN","DGHBPUTL",84,0)
 S DATA(1)=PLAN                                              ;History HBP Code
"RTN","DGHBPUTL",85,0)
 S DATA(2)=DUZ                                               ;History Entered By
"RTN","DGHBPUTL",86,0)
 S DATA(3)=$S($G(SITE)="":$P($$SITE^VASITE(),"^",1),1:SITE)  ;History Entered Site
"RTN","DGHBPUTL",87,0)
 S DATA(4)="U"                                               ;History Assignment - CCR 13614 - Change D to U
"RTN","DGHBPUTL",88,0)
 S DATA(5)=$S($G(SITE)="":"V",1:"E")                         ;History Source
"RTN","DGHBPUTL",89,0)
 ; Update History into DB
"RTN","DGHBPUTL",90,0)
 ; DG*5.3*871
"RTN","DGHBPUTL",91,0)
 S SUCCESS=$$ADD^DGENDBS(2.2512,.DGENDA,.DATA)               ;DG*5.3*871 modified 25.02 to 2.512
"RTN","DGHBPUTL",92,0)
 Q
"RTN","DGHBPUTL",93,0)
 ;
"RTN","DGHBPUTL",94,0)
HL7UPD(DFN,DGHBP,MSHDATE) ; Store HL7 Health Benefit Plan (HBP) data in PATIENT file (#2)
"RTN","DGHBPUTL",95,0)
 N OCC,HBPNOD,HL7DATA,ADDHBP
"RTN","DGHBPUTL",96,0)
 ;
"RTN","DGHBPUTL",97,0)
 ; Build an array of HBP codes to be added or retained in VistA - saving the date/time for storage
"RTN","DGHBPUTL",98,0)
 S OCC=0 F  S OCC=$O(DGHBP(OCC)) Q:OCC=""  S ADDHBP($P(DGHBP(OCC),U,1))=""
"RTN","DGHBPUTL",99,0)
 ;
"RTN","DGHBPUTL",100,0)
 S OCC=0 F  S OCC=$O(^DPT(DFN,"HBP",OCC)) Q:OCC<1  D
"RTN","DGHBPUTL",101,0)
 . S HBPNOD=$G(^DPT(DFN,"HBP",OCC,0))
"RTN","DGHBPUTL",102,0)
 . ; If HBP code exists on Z11 and VistA, Source to "E", and do not delete or store history
"RTN","DGHBPUTL",103,0)
 . I $D(ADDHBP($P(HBPNOD,U,1))) S $P(^DPT(DFN,"HBP",OCC,0),U,5)="E" Q
"RTN","DGHBPUTL",104,0)
 . ; Change Date/Time for deletion History to MSHDATE
"RTN","DGHBPUTL",105,0)
 . I $G(MSHDATE)'="" S $P(HBPNOD,U,2)=$$FMDATE^HLFNC(MSHDATE)
"RTN","DGHBPUTL",106,0)
 . D STORHIS(DFN,HBPNOD,"U")                                 ;CCR 13614 - Change D to U (delete to unassigned)            
"RTN","DGHBPUTL",107,0)
 . D DELCUR(DFN,$P(HBPNOD,U))
"RTN","DGHBPUTL",108,0)
 ;
"RTN","DGHBPUTL",109,0)
 ; Add Z11 HBP data to PATIENT file (#2)
"RTN","DGHBPUTL",110,0)
 I $D(DGHBP) D
"RTN","DGHBPUTL",111,0)
 . S OCC=0 F  S OCC=$O(DGHBP(OCC)) Q:OCC=""  D
"RTN","DGHBPUTL",112,0)
 . . S HL7DATA=DGHBP(OCC)
"RTN","DGHBPUTL",113,0)
 . . ; Quit if the HBP Code is already set for patient (would have been set by loop above)
"RTN","DGHBPUTL",114,0)
 . . I $D(^DPT(DFN,"HBP","B",$P(HL7DATA,U,1))) Q
"RTN","DGHBPUTL",115,0)
 . . D STORCUR(DFN,HL7DATA)
"RTN","DGHBPUTL",116,0)
 . . D STORHIS(DFN,HL7DATA,"A")
"RTN","DGHBPUTL",117,0)
 Q
"RTN","DGHBPUTL",118,0)
 ;
"RTN","DGHBPUTL",119,0)
STORCUR(DFN,STORDATA) ; Store Current data
"RTN","DGHBPUTL",120,0)
 N DGENDA,DATA,SUCCESS
"RTN","DGHBPUTL",121,0)
 S DGENDA(1)=DFN                               ;Patient DFN
"RTN","DGHBPUTL",122,0)
 S DATA(.01)=$P(STORDATA,U)                    ;Current HBP Code
"RTN","DGHBPUTL",123,0)
 S DATA(1)=$P(STORDATA,U,2)                    ;Assigned Date/Time
"RTN","DGHBPUTL",124,0)
 S DATA(2)=$P(STORDATA,U,3)                    ;Assigned Entered By
"RTN","DGHBPUTL",125,0)
 S DATA(3)=$P(STORDATA,U,4)                    ;Assigned Entered Site
"RTN","DGHBPUTL",126,0)
 S DATA(4)=$P(STORDATA,U,5)                    ;Current Source
"RTN","DGHBPUTL",127,0)
 S SUCCESS=$$ADD^DGENDBS(2.2511,.DGENDA,.DATA) ;DG*5.3*871 modified 25.01 to 2.511
"RTN","DGHBPUTL",128,0)
 Q
"RTN","DGHBPUTL",129,0)
 ;
"RTN","DGHBPUTL",130,0)
STORHIS(DFN,STORDATA,ACTION) ; Store History data
"RTN","DGHBPUTL",131,0)
 N DGENDA,DATA,SUCCESS
"RTN","DGHBPUTL",132,0)
 S DGENDA(1)=DFN                               ;Patient DFN
"RTN","DGHBPUTL",133,0)
 S DATA(.01)=$P(STORDATA,U,2)                  ;History HBP Date/Time
"RTN","DGHBPUTL",134,0)
 S DATA(1)=$P(STORDATA,U)                      ;History HBP Code
"RTN","DGHBPUTL",135,0)
 S DATA(2)=$P(STORDATA,U,3)                    ;History Entered By
"RTN","DGHBPUTL",136,0)
 S DATA(3)=$P(STORDATA,U,4)                    ;History Entered Site
"RTN","DGHBPUTL",137,0)
 S DATA(4)=$G(ACTION)                          ;History Assignment
"RTN","DGHBPUTL",138,0)
 S DATA(5)=$P(STORDATA,U,5)                    ;History Source
"RTN","DGHBPUTL",139,0)
 S SUCCESS=$$ADD^DGENDBS(2.2512,.DGENDA,.DATA) ;DG*5.3*871 modified 25.02 to 2.512
"RTN","DGHBPUTL",140,0)
 Q
"RTN","DGHBPUTL",141,0)
 ;
"RTN","DGHBPUTL",142,0)
DELCUR(DFN,HBPCODE) ; Delete entry from Current data
"RTN","DGHBPUTL",143,0)
 N DGENDA,DA,DIK
"RTN","DGHBPUTL",144,0)
 S (DGENDA(1),DA(1))=DFN
"RTN","DGHBPUTL",145,0)
 S DA=$O(^DPT(DA(1),"HBP","B",HBPCODE,""))
"RTN","DGHBPUTL",146,0)
 S DIK="^DPT("_DA(1)_","_"""HBP"""_","
"RTN","DGHBPUTL",147,0)
 D ^DIK K DIK
"RTN","DGHBPUTL",148,0)
 Q
"RTN","DGR111")
0^8^B7250700
"RTN","DGR111",1,0)
DGR111 ;ALB/TGH,LMD - Health Benefit Plan Main Menu - List Manager Screen ;4/11/13 10:56am 
"RTN","DGR111",2,0)
 ;;5.3;Registration;**871**;Aug 13, 1993;Build 84
"RTN","DGR111",3,0)
 ;
"RTN","DGR111",4,0)
EN(DFN) ;Main entry point to invoke the DGEN HBP PATIENT list
"RTN","DGR111",5,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGR111",6,0)
 ;
"RTN","DGR111",7,0)
 ; Set up to use two ListMan Menus dependent upon HBP source
"RTN","DGR111",8,0)
 N HBP,DGHBP,HBPSRC,MENU
"RTN","DGR111",9,0)
 D GETHBP^DGHBPUTL(DFN)
"RTN","DGR111",10,0)
 S MENU="DGEN HBP PATIENT"
"RTN","DGR111",11,0)
 D WAIT^DICD
"RTN","DGR111",12,0)
 D EN^VALM(MENU)
"RTN","DGR111",13,0)
 Q
"RTN","DGR111",14,0)
 ;
"RTN","DGR111",15,0)
HDR ;Header code
"RTN","DGR111",16,0)
 N X
"RTN","DGR111",17,0)
 D PID^VADPT
"RTN","DGR111",18,0)
 S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
"RTN","DGR111",19,0)
 S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")"
"RTN","DGR111",20,0)
 S X="PATIENT TYPE UNKNOWN"
"RTN","DGR111",21,0)
 I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
"RTN","DGR111",22,0)
 S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80)
"RTN","DGR111",23,0)
 I '$D(^DPT(DFN,"HBP")) S VALMHDR(2)="No Currently Stored HBP Data"
"RTN","DGR111",24,0)
 Q
"RTN","DGR111",25,0)
 ; 
"RTN","DGR111",26,0)
INIT ;Build patient HBP current screen
"RTN","DGR111",27,0)
 D CLEAN^VALM10
"RTN","DGR111",28,0)
 D CLEAR^VALM1
"RTN","DGR111",29,0)
 D GETHBP(DFN)
"RTN","DGR111",30,0)
 Q
"RTN","DGR111",31,0)
 ;
"RTN","DGR111",32,0)
GETHBP(DFN) ;Load HBPs from HBP array into TMP(VALMAR global for display
"RTN","DGR111",33,0)
 ; INPUT:    DFN = Patient IEN
"RTN","DGR111",34,0)
 N DGHBP,DGSEL,DGDATA,Z,HBPSRC,BRACKET
"RTN","DGR111",35,0)
 S VALMCNT=0,(DGDATA,HBPSRC)=""
"RTN","DGR111",36,0)
 D GETHBP^DGHBPUTL(DFN)
"RTN","DGR111",37,0)
 S DGHBP=""
"RTN","DGR111",38,0)
 F  S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP=""  D
"RTN","DGR111",39,0)
 . S HBPSRC=$S(HBPSRC="E":"E",1:$P(HBP("CUR",DGHBP),"^",5))
"RTN","DGR111",40,0)
 S BRACKET=$S(HBPSRC="E":"<>",1:"[]")
"RTN","DGR111",41,0)
 F  S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP=""  D
"RTN","DGR111",42,0)
 . S DGDATA=HBP("CUR",DGHBP)
"RTN","DGR111",43,0)
 . S VALMCNT=VALMCNT+1
"RTN","DGR111",44,0)
 . S Z=$E(BRACKET)_VALMCNT_$E(BRACKET,2)_"  "_DGHBP
"RTN","DGR111",45,0)
 . S DGSEL(VALMCNT)=DGHBP
"RTN","DGR111",46,0)
 . D SET^VALM10(VALMCNT,Z,VALMCNT)
"RTN","DGR111",47,0)
 Q
"RTN","DGR111",48,0)
 ;
"RTN","DGR111",49,0)
HELP ;Help code
"RTN","DGR111",50,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","DGR111",51,0)
 Q
"RTN","DGR111",52,0)
 ;
"RTN","DGR111",53,0)
EXIT ;Exit code
"RTN","DGR111",54,0)
 D CLEAN^VALM10
"RTN","DGR111",55,0)
 D CLEAR^VALM1
"RTN","DGR111",56,0)
 ;K ^TMP("DGRP111",$J)
"RTN","DGR111",57,0)
 Q
"RTN","DGR111",58,0)
 ; 
"RTN","DGR111",59,0)
PEXIT ;DGEN MSDS MENU protocol exit code
"RTN","DGR111",60,0)
 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
"RTN","DGR111",61,0)
 Q
"RTN","DGR111",62,0)
 ;
"RTN","DGR111",63,0)
ACT(DGACT) ; Entry point for menu action selection
"RTN","DGR111",64,0)
 ;              = "VH" - View History - DGEN HBP View History protocol
"RTN","DGR111",65,0)
 ;              = "VD" - View Detail of HBP
"RTN","DGR111",66,0)
 N DGACTU,DA,DIE,DIC,DIK,DIPA,DR,X,Y,DGHBP,HPSRC,HBP
"RTN","DGR111",67,0)
 I $G(DGACT)="" G ACTQ
"RTN","DGR111",68,0)
 I $G(DGACT)="Q" Q
"RTN","DGR111",69,0)
 ; Determine if any HBPs were processed by ESR
"RTN","DGR111",70,0)
 S (DGDATA,HBPSRC)=""
"RTN","DGR111",71,0)
 D GETHBP^DGHBPUTL(DFN)
"RTN","DGR111",72,0)
 S DGHBP=""
"RTN","DGR111",73,0)
 F  S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP=""  D
"RTN","DGR111",74,0)
 . S HBPSRC=$S(HBPSRC="E":"E",1:$P(HBP("CUR",DGHBP),"^",5))
"RTN","DGR111",75,0)
 ;
"RTN","DGR111",76,0)
 D FULL^VALM1
"RTN","DGR111",77,0)
 ; If action is a VH then View History display screen (DGR113) then return to main screen
"RTN","DGR111",78,0)
 I DGACT="VH" D EN^DGR113(DFN) G ACTQ
"RTN","DGR111",79,0)
 ; If action is a VD then View Detail display screen (DGR114) then return to main screen
"RTN","DGR111",80,0)
 I DGACT="VD" D EN^DGR114(DFN) G ACTQ
"RTN","DGR111",81,0)
 ; If user does not choose VH or VD return to main screen
"RTN","DGR111",82,0)
 W !,"Health Benefit Plan Profiles can only be edited/modified by an ESC user,"
"RTN","DGR111",83,0)
 W !,"please contact HEC to request changes/edits."
"RTN","DGR111",84,0)
 D PAUSE^VALM1
"RTN","DGR111",85,0)
 ;
"RTN","DGR111",86,0)
ACTQ D INIT S VALMBCK="R" Q
"RTN","DGR111",87,0)
 ;
"RTN","DGR111",88,0)
EXPND ; -- expand code
"RTN","DGR111",89,0)
 Q
"RTN","DGR111",90,0)
 ;
"RTN","DGR113")
0^10^B3780049
"RTN","DGR113",1,0)
DGR113 ;ALB/TGH - Health Benefit Plan View History - List Manager Screen ;4/11/13 10:56am 
"RTN","DGR113",2,0)
 ;;5.3;Registration;**871**;Aug 13, 1993;Build 84
"RTN","DGR113",3,0)
 ;
"RTN","DGR113",4,0)
EN(DFN) ;Main entry point to invoke the DGEN HBP VIEW list
"RTN","DGR113",5,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGR113",6,0)
 ;
"RTN","DGR113",7,0)
 D WAIT^DICD
"RTN","DGR113",8,0)
 D EN^VALM("DGEN HBP VIEW")
"RTN","DGR113",9,0)
 Q
"RTN","DGR113",10,0)
 ;
"RTN","DGR113",11,0)
HDR ;Header code
"RTN","DGR113",12,0)
 N X
"RTN","DGR113",13,0)
 D PID^VADPT
"RTN","DGR113",14,0)
 S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
"RTN","DGR113",15,0)
 S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")"
"RTN","DGR113",16,0)
 S X="PATIENT TYPE UNKNOWN"
"RTN","DGR113",17,0)
 I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
"RTN","DGR113",18,0)
 S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80)
"RTN","DGR113",19,0)
 Q
"RTN","DGR113",20,0)
 ;
"RTN","DGR113",21,0)
INIT ;Build patient HBP View History screen
"RTN","DGR113",22,0)
 N DGPLAN
"RTN","DGR113",23,0)
 D CLEAN^VALM10
"RTN","DGR113",24,0)
 D CLEAR^VALM1
"RTN","DGR113",25,0)
 D GETPLAN
"RTN","DGR113",26,0)
 Q
"RTN","DGR113",27,0)
 ;
"RTN","DGR113",28,0)
GETPLAN ;Load History from HBP array into TMP(VALMAR global for display
"RTN","DGR113",29,0)
 N DTTIME,CNT,LINEVAR
"RTN","DGR113",30,0)
 S VALMCNT=0
"RTN","DGR113",31,0)
 S LINEVAR="HISTORY"
"RTN","DGR113",32,0)
 D GETHBP^DGHBPUTL
"RTN","DGR113",33,0)
 ; Go thru History and set individual values into Global for display
"RTN","DGR113",34,0)
 S CNT=0
"RTN","DGR113",35,0)
 F  S CNT=$O(HBP("HIS",CNT)) Q:CNT=""  D
"RTN","DGR113",36,0)
 . S DTTIME=""
"RTN","DGR113",37,0)
 . F  S DTTIME=$O(HBP("HIS",CNT,DTTIME)) Q:DTTIME=""  D
"RTN","DGR113",38,0)
 . . N DATA,Y
"RTN","DGR113",39,0)
 . . S DATA=HBP("HIS",CNT,DTTIME)
"RTN","DGR113",40,0)
 . . S Y=DTTIME X ^DD("DD")
"RTN","DGR113",41,0)
 . . S VALMCNT=VALMCNT+1
"RTN","DGR113",42,0)
 . . S LINEVAR=$$SETFLD^VALM1($S($P(DATA,"^",5)="A":" ADD",1:" DELETE"),LINEVAR,"ACTION")
"RTN","DGR113",43,0)
 . . S LINEVAR=$$SETFLD^VALM1($P($TR(Y,"@"," ")," ",1,2),LINEVAR,"DATE/TIME")
"RTN","DGR113",44,0)
 . . S LINEVAR=$$SETSTR^VALM1($P(DATA,"^",1),LINEVAR,23,139)
"RTN","DGR113",45,0)
 . . ;S LINEVAR=$$SETFLD^VALM1($E($$GET1^DIQ(200,$P(DATA,"^",3)_",",.01),1,20),LINEVAR,"USER")
"RTN","DGR113",46,0)
 . . D SET^VALM10(VALMCNT,LINEVAR)
"RTN","DGR113",47,0)
 Q
"RTN","DGR113",48,0)
 ;
"RTN","DGR113",49,0)
HELP ;Help code
"RTN","DGR113",50,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","DGR113",51,0)
 Q
"RTN","DGR113",52,0)
 ;
"RTN","DGR113",53,0)
EXIT ;Exit code
"RTN","DGR113",54,0)
 D CLEAN^VALM10
"RTN","DGR113",55,0)
 D CLEAR^VALM1
"RTN","DGR113",56,0)
 Q
"RTN","DGR113",57,0)
 ;
"RTN","DGR113",58,0)
EXPND ; -- expand code
"RTN","DGR113",59,0)
 Q
"RTN","DGR113",60,0)
 ;
"RTN","DGR114")
0^11^B5179815
"RTN","DGR114",1,0)
DGR114 ;ALB/TGH - Health Benefit Plan View Detail - List Manager Screen ;4/11/13 10:56am 
"RTN","DGR114",2,0)
 ;;5.3;Registration;**871**;Aug 13, 1993;Build 84
"RTN","DGR114",3,0)
 ;
"RTN","DGR114",4,0)
EN(DFN) ;Main entry point to invoke the DGEN HBP DETAIL list
"RTN","DGR114",5,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGR114",6,0)
 ;
"RTN","DGR114",7,0)
 D WAIT^DICD
"RTN","DGR114",8,0)
 D EN^VALM("DGEN HBP DETAIL")
"RTN","DGR114",9,0)
 Q
"RTN","DGR114",10,0)
 ;
"RTN","DGR114",11,0)
HDR ;Header code
"RTN","DGR114",12,0)
 N X
"RTN","DGR114",13,0)
 D PID^VADPT
"RTN","DGR114",14,0)
 S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
"RTN","DGR114",15,0)
 S VALMHDR(1)=VALMHDR(1)_" ("_VA("BID")_")"
"RTN","DGR114",16,0)
 S X="PATIENT TYPE UNKNOWN"
"RTN","DGR114",17,0)
 I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
"RTN","DGR114",18,0)
 S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80)
"RTN","DGR114",19,0)
 Q
"RTN","DGR114",20,0)
 ;
"RTN","DGR114",21,0)
INIT ;Build patient HBP current screen
"RTN","DGR114",22,0)
 D CLEAN^VALM10
"RTN","DGR114",23,0)
 D CLEAR^VALM1
"RTN","DGR114",24,0)
 D GETPLAN
"RTN","DGR114",25,0)
 Q
"RTN","DGR114",26,0)
 ;
"RTN","DGR114",27,0)
GETPLAN ;Load Plans from HBP array into TMP(VALMAR global for display
"RTN","DGR114",28,0)
 N DGPLAN,Z
"RTN","DGR114",29,0)
 D GETPLAN^DGHBPUTL
"RTN","DGR114",30,0)
 S DGPLAN="",VALMCNT=0
"RTN","DGR114",31,0)
 F  S DGPLAN=$O(HBP("PLAN",DGPLAN)) Q:DGPLAN=""  D
"RTN","DGR114",32,0)
 . S VALMCNT=VALMCNT+1
"RTN","DGR114",33,0)
 . S Z="["_VALMCNT_"]"_"  "_DGPLAN
"RTN","DGR114",34,0)
 . D SET^VALM10(VALMCNT,Z,VALMCNT)
"RTN","DGR114",35,0)
 Q
"RTN","DGR114",36,0)
 ;
"RTN","DGR114",37,0)
HELP ;Help code
"RTN","DGR114",38,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","DGR114",39,0)
 Q
"RTN","DGR114",40,0)
 ;
"RTN","DGR114",41,0)
ACTION ; Get users entered data and process entry to add HBP
"RTN","DGR114",42,0)
 N I,VALMY,VALMNOD
"RTN","DGR114",43,0)
 D FULL^VALM1
"RTN","DGR114",44,0)
 S VALMNOD="3^4450^Select HBP^1-36"
"RTN","DGR114",45,0)
 D EN^VALM2(VALMNOD,"S")
"RTN","DGR114",46,0)
 S I=""
"RTN","DGR114",47,0)
 F  S I=$O(VALMY(I)) Q:I=""  D
"RTN","DGR114",48,0)
 . S ACT=$O(@VALMAR@("IDX",I,""))
"RTN","DGR114",49,0)
 . S DGNAME=$P(@VALMAR@(ACT,0)," ",3,99)
"RTN","DGR114",50,0)
 . S DGACT=HBP("PLAN",DGNAME)
"RTN","DGR114",51,0)
 . D ACT(DGACT)
"RTN","DGR114",52,0)
 Q
"RTN","DGR114",53,0)
 ;
"RTN","DGR114",54,0)
ACT(DGACT) ; Entry point for menu action selection
"RTN","DGR114",55,0)
 ; INPUT: DGACT = Plan number to be assigned
"RTN","DGR114",56,0)
 I $G(DGACT)="" Q
"RTN","DGR114",57,0)
 ; Gather data and send to print in EXPND
"RTN","DGR114",58,0)
 D GETDETL^DGHBPUTL(DGACT)
"RTN","DGR114",59,0)
 Q
"RTN","DGR114",60,0)
 ;
"RTN","DGR114",61,0)
EXIT ;Exit code
"RTN","DGR114",62,0)
 D CLEAN^VALM10
"RTN","DGR114",63,0)
 D CLEAR^VALM1
"RTN","DGR114",64,0)
 Q
"RTN","DGR114",65,0)
 ;
"RTN","DGR114",66,0)
PEXIT ; MENU protocol exit code
"RTN","DGR114",67,0)
 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
"RTN","DGR114",68,0)
 Q
"RTN","DGR114",69,0)
 ;
"RTN","DGR114",70,0)
EXPND ; -- expand code
"RTN","DGR114",71,0)
 N CNT,LST,ACT,DGNAME,DGACT
"RTN","DGR114",72,0)
 D ACTION
"RTN","DGR114",73,0)
 S VALMBCK="R"   ; CCR 13613 - fix
"RTN","DGR114",74,0)
 I $G(DGACT)="" Q
"RTN","DGR114",75,0)
 S LST=$P(HBP("DETAIL",0),"^",4)
"RTN","DGR114",76,0)
 I LST="" W !,"No detail description is available for this Health Benefit Plan"
"RTN","DGR114",77,0)
 F CNT=1:1:LST W !,HBP("DETAIL",DGACT,CNT)
"RTN","DGR114",78,0)
 S VALMBCK="R"
"RTN","DGR114",79,0)
 D PAUSE^VALM1
"RTN","DGR114",80,0)
 Q
"RTN","DGR114",81,0)
 ;
"RTN","DGRP11")
0^4^B13083153
"RTN","DGRP11",1,0)
DGRP11 ;ALB/MRL,RTK,PHH,PWC - REGISTRATION SCREEN 11/VERIFICATION INFORMATION ;3/23/06 8:10am
"RTN","DGRP11",2,0)
 ;;5.3;Registration;**327,631,709,871**;Aug 13, 1993;Build 84
"RTN","DGRP11",3,0)
 ;
"RTN","DGRP11",4,0)
 S DGRPS=11 D H^DGRPU F I=.3,.32,.36,.361,"TYPE","VET" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRP11",5,0)
 S (DGRPW,Z)=1 D WW^DGRPV W " Eligibility Status: " S DGRPX=DGRP(.361),X=$P(DGRPX,"^",1),Z=$S(X']"":"NOT VERIFIED",X="V":"VERIFIED",X="R":"PENDING RE-VERIFICATION",1:"PENDING VERIFICATION"),Z1=28 D WW1^DGRPV S DGRPVR=$S(X]"":1,1:0)
"RTN","DGRP11",6,0)
 W "Status Date: " S Y=$P(DGRPX,"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,DGRPVR:DGRPU,1:DGRPNA),!?5,"Status Entered By: ",$S($D(^VA(200,+$P(DGRPX,"^",6),0)):$P(^(0),"^",1)_" (#"_+$P(DGRPX,"^",6)_")",DGRPVR:DGRPU,1:DGRPNA)
"RTN","DGRP11",7,0)
 W !?6,"Interim Response: " S Y=$P(DGRPX,"^",4) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:DGRPU_" (NOT REQUIRED)"),!?9,"Verif. Method: ",$S($P(DGRPX,"^",5)]"":$P(DGRPX,"^",5),DGRPVR:DGRPU,1:DGRPNA)
"RTN","DGRP11",8,0)
 ;Added display of ELIGIBILITY VERIF. SOURCE for Ineligible Project:
"RTN","DGRP11",9,0)
 W !?9,"Verif. Source: ",$S($P(DGRPX,"^",3)="H":"HEC",$P(DGRPX,"^",3)="V":"VISTA",1:"NOT AVAILABLE")
"RTN","DGRP11",10,0)
 S Z=2 D WW^DGRPV W "     Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED") S Z=3 D WW^DGRPV W "   Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
"RTN","DGRP11",11,0)
 S Z=4 D WW^DGRPV W " Rated Disabilities: " I $P(DGRP("VET"),"^",1)'="Y",$S('$D(^DG(391,+DGRP("TYPE"),0)):1,$P(^(0),"^",2):0,1:1) W DGRPNA," - NOT A VETERAN" G HBP
"RTN","DGRP11",12,0)
 N DGEC,DGEFF
"RTN","DGRP11",13,0)
 S DGEC=$P($G(DGRP(.36)),U)
"RTN","DGRP11",14,0)
 I $G(DGEC) I $D(^DIC(8,DGEC)) S DGEC=$P(^DIC(8,DGEC,0),U)
"RTN","DGRP11",15,0)
 W " SC%: ",$S($G(DGEC)="NSC":"",$P($G(DGRP(.3)),U,2)="":"",1:$P($G(DGRP(.3)),U,2))
"RTN","DGRP11",16,0)
 S DGEFF=$P($G(DGRP(.3)),U,14)
"RTN","DGRP11",17,0)
 I $G(DGEFF)]"" S Y=DGEFF X ^DD("DD") S DGEFF=Y
"RTN","DGRP11",18,0)
 W "    EFF. DATE OF COMBINED SC%: "_$G(DGEFF),!
"RTN","DGRP11",19,0)
 N DGQUIT
"RTN","DGRP11",20,0)
 W ?55,"Orig",?70,"Curr"
"RTN","DGRP11",21,0)
 W !?3,"Rated Disability",?46,"Extr",?55,"Eff Dt",?70,"Eff Dt"
"RTN","DGRP11",22,0)
 S I3=0
"RTN","DGRP11",23,0)
 I '$$RDIS^DGRPDB(DFN,.DGARR) W !,"NONE STATED" G HBP
"RTN","DGRP11",24,0)
 F DGC=0:0 S DGC=$O(DGARR(DGC)) Q:'DGC  D
"RTN","DGRP11",25,0)
 . S I3=I3+1
"RTN","DGRP11",26,0)
 . N DGCURR,DGORIG,DG0,DG1,DG2,DG4,DG5
"RTN","DGRP11",27,0)
 . I $G(DGARR(DGC))']"" Q
"RTN","DGRP11",28,0)
 . S DGZERO=+DGARR(DGC)
"RTN","DGRP11",29,0)
 . I '$D(^DIC(31,DGZERO,0)) Q
"RTN","DGRP11",30,0)
 . S DG0=$P(^DIC(31,DGZERO,0),U,3)
"RTN","DGRP11",31,0)
 . S DG1=$P(^DIC(31,DGZERO,0),U)
"RTN","DGRP11",32,0)
 . S DG2="("_$S($P(DGARR(DGC),U,3)=1:$P(DGARR(DGC),U,2)_"% SC",$P(DGARR(DGC),U,3)]"":$P(DGARR(DGC),U,2)_"% NSC",1:"unspec")_")"
"RTN","DGRP11",33,0)
 . S DG4=$P(DGARR(DGC),U,4),DG5=$P(DGARR(DGC),U,5),DG6=$P(DGARR(DGC),U,6)
"RTN","DGRP11",34,0)
 . I DG5]"" S Y=DG5 X ^DD("DD") S DGORIG=Y
"RTN","DGRP11",35,0)
 . I DG6]"" S Y=DG6 X ^DD("DD") S DGCURR=Y
"RTN","DGRP11",36,0)
 . I $Y>(IOSL-3) D PAUSE^DGRPDB I $G(DGQUIT)=0 W @IOF
"RTN","DGRP11",37,0)
 . I $G(DGQUIT)=1 Q
"RTN","DGRP11",38,0)
 . W !,$G(DG0)_"-",DG1,DG2,?47,$G(DG4),?50," - ",?53,$G(DGORIG),?64," - ",?68,$G(DGCURR)
"RTN","DGRP11",39,0)
 W:'I3 !,"NONE STATED"
"RTN","DGRP11",40,0)
HBP ; LINE FOR HEALTH BENEFIT PLAN (DG*53*871)
"RTN","DGRP11",41,0)
 W ! S Z=5
"RTN","DGRP11",42,0)
 W:DGRPW ! S Z="["_Z_"]"
"RTN","DGRP11",43,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRP11",44,0)
 I 'DGRPCM&($E(Z)'="[") W Z
"RTN","DGRP11",45,0)
 ; D WW^DGRPV     Removed to always have #5 selectable then sub screens of 11 will control edit and view capabilities
"RTN","DGRP11",46,0)
 W " Health Benefit Plan: " N CNT,PLN D
"RTN","DGRP11",47,0)
 . S (CNT,PLN)=0 F  S PLN=$O(^DPT(DFN,"HBP",PLN)) Q:PLN<1  S CNT=CNT+1
"RTN","DGRP11",48,0)
 W $S(CNT>0:" ("_CNT_" Plan"_$S(CNT=1:"",1:"s")_" on file)",1:" (None Specified)")
"RTN","DGRP11",49,0)
Q G ^DGRPP
"RTN","DGRPE")
0^3^B61970869
"RTN","DGRPE",1,0)
DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ,PWC - REGISTRATIONS EDITS ;6/24/09 3:03pm
"RTN","DGRPE",2,0)
 ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,688,797,842,865,871**;Aug 13, 1993;Build 84
"RTN","DGRPE",3,0)
 ;
"RTN","DGRPE",4,0)
 ;DGDR contains a string of edits; edit=screen*10+item #
"RTN","DGRPE",5,0)
 ;
"RTN","DGRPE",6,0)
 ;line tag screen*10+item*1000 = continuation line
"RTN","DGRPE",7,0)
 ;
"RTN","DGRPE",8,0)
 I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
"RTN","DGRPE",9,0)
 I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
"RTN","DGRPE",10,0)
 I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
"RTN","DGRPE",11,0)
 I DGRPS=5,DGDR["501," D
"RTN","DGRPE",12,0)
 .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
"RTN","DGRPE",13,0)
 .D REG^IBCNBME(DFN)
"RTN","DGRPE",14,0)
 .Q
"RTN","DGRPE",15,0)
 N QUIT S QUIT=0
"RTN","DGRPE",16,0)
 I DGRPS=6,$S(DGDR["601,"!(DGDR["602,")!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
"RTN","DGRPE",17,0)
 .;Use new ListMan screen for Military Service Episodes (DG*5.3*797)
"RTN","DGRPE",18,0)
 . I DGDR["601," D EN^DGRP61(DFN)   ; MSEs
"RTN","DGRPE",19,0)
 . ; D SETDR("601,",.DR)
"RTN","DGRPE",20,0)
 . ; S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",21,0)
 . ; D ^DIE I $D(Y) S QUIT=1
"RTN","DGRPE",22,0)
 . ; S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
"RTN","DGRPE",23,0)
 . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
"RTN","DGRPE",24,0)
 . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
"RTN","DGRPE",25,0)
 I DGRPS=7,(DGDR["702,") D EN^DGRP7CP(DFN,.QUIT) I QUIT D Q Q  ;DG*5.3*842 screen 7 cp subscreen
"RTN","DGRPE",26,0)
 I DGRPS=11,(DGDR["1105,") D EN^DGR111(DFN) ;DG*5.3*871 screen 11 HBP subscreen
"RTN","DGRPE",27,0)
 ;-- Tricare screen #15
"RTN","DGRPE",28,0)
 I DGRPS=15 D EDIT^DGRP15,Q Q
"RTN","DGRPE",29,0)
 ;
"RTN","DGRPE",30,0)
 N DGPH,DGPHFLG
"RTN","DGRPE",31,0)
 K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",32,0)
 G ^DGRPE1:DGRPS>6
"RTN","DGRPE",33,0)
 I DGRPS=4 D ^DGRPE4
"RTN","DGRPE",34,0)
 D SETDR(DGDR,.DR)
"RTN","DGRPE",35,0)
 S (DA,Y)=DFN,DIE="^DPT("
"RTN","DGRPE",36,0)
 D ^DIE
"RTN","DGRPE",37,0)
 ;check for Combat Vet status
"RTN","DGRPE",38,0)
 I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
"RTN","DGRPE",39,0)
 . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
"RTN","DGRPE",40,0)
 . S DIR(0)="EA" D ^DIR K DIR
"RTN","DGRPE",41,0)
 I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
"RTN","DGRPE",42,0)
Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
"RTN","DGRPE",43,0)
 Q
"RTN","DGRPE",44,0)
 ;
"RTN","DGRPE",45,0)
SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected
"RTN","DGRPE",46,0)
 N DGCT,DGDRS,J1,J2
"RTN","DGRPE",47,0)
 K DR S DR="",DGDRS="DR",DGCT=0
"RTN","DGRPE",48,0)
 F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
"RTN","DGRPE",49,0)
 . S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",50,0)
 . N J2
"RTN","DGRPE",51,0)
 . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
"RTN","DGRPE",52,0)
 Q
"RTN","DGRPE",53,0)
 ;
"RTN","DGRPE",54,0)
S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
"RTN","DGRPE",55,0)
 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
"RTN","DGRPE",56,0)
 Q
"RTN","DGRPE",57,0)
 ;
"RTN","DGRPE",58,0)
SETFLDS(DGDR) ; Set up fields to edit
"RTN","DGRPE",59,0)
 Q
"RTN","DGRPE",60,0)
 ;
"RTN","DGRPE",61,0)
101 ;;
"RTN","DGRPE",62,0)
102 ;;1;
"RTN","DGRPE",63,0)
103 ;;.091;
"RTN","DGRPE",64,0)
104 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
"RTN","DGRPE",65,0)
105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;
"RTN","DGRPE",66,0)
105000 ;;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET Y=.12105;@15;K DIE("NO^");
"RTN","DGRPE",67,0)
109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
"RTN","DGRPE",68,0)
111 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
"RTN","DGRPE",69,0)
111000 ;;K DR(2,2.141);N RET S RET=1 D EN^DGREGTED(DFN,"CONF",.RET) S:'RET Y=.14105;@111;K DIE("NO^");
"RTN","DGRPE",70,0)
112 ;;.134;.135;@21;S X=$$YN1316^DGRPE(DFN);S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)="") Y="@25";S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)]"") Y="@24";.133;S:($P($G(^DPT(DFN,.13)),U,16)="Y")&($G(X)="") Y="@21";S Y="@25";@24;.133///@;@25;.1317///NOW;
"RTN","DGRPE",71,0)
201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;
"RTN","DGRPE",72,0)
202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
"RTN","DGRPE",73,0)
203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
"RTN","DGRPE",74,0)
205 ;;.181;
"RTN","DGRPE",75,0)
301 ;;.211;S:X']"" Y="@31";.212;D DR301^DGRPE S:DG4=1 Y=.213;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;K DG4;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31;
"RTN","DGRPE",76,0)
302 ;;.2191;S:X']"" Y="@32";.2192;D DR301^DGRPE S:DG4=1 Y=.2193;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
"RTN","DGRPE",77,0)
302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
"RTN","DGRPE",78,0)
303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34;
"RTN","DGRPE",79,0)
303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
"RTN","DGRPE",80,0)
303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35;
"RTN","DGRPE",81,0)
303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2;
"RTN","DGRPE",82,0)
304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;        
"RTN","DGRPE",83,0)
305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371;
"RTN","DGRPE",84,0)
305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
"RTN","DGRPE",85,0)
305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
"RTN","DGRPE",86,0)
305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
"RTN","DGRPE",87,0)
401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
"RTN","DGRPE",88,0)
402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
"RTN","DGRPE",89,0)
501 ;;
"RTN","DGRPE",90,0)
502 ;;.381;.382///NOW;
"RTN","DGRPE",91,0)
503 ;;.383;
"RTN","DGRPE",92,0)
601 ;;Q;
"RTN","DGRPE",93,0)
602 ;;Q;
"RTN","DGRPE",94,0)
603 ;;Q;
"RTN","DGRPE",95,0)
604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
"RTN","DGRPE",96,0)
605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
"RTN","DGRPE",97,0)
606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
"RTN","DGRPE",98,0)
607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
"RTN","DGRPE",99,0)
608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
"RTN","DGRPE",100,0)
AD N DGZ4,DGPC
"RTN","DGRPE",101,0)
 S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10)
"RTN","DGRPE",102,0)
 I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4
"RTN","DGRPE",103,0)
 K DGADD,DGPHONE Q
"RTN","DGRPE",104,0)
DR109 ;Drop through (use same logic as DR203)
"RTN","DGRPE",105,0)
DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;"
"RTN","DGRPE",106,0)
 S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;"
"RTN","DGRPE",107,0)
 Q
"RTN","DGRPE",108,0)
DR111 ;Set DR string for Confidential Address categories
"RTN","DGRPE",109,0)
 S DR(2,2.141)=".01;1//YES;"
"RTN","DGRPE",110,0)
 Q
"RTN","DGRPE",111,0)
DR301 ;set up variables for foreign address
"RTN","DGRPE",112,0)
 N DG3,DG33
"RTN","DGRPE",113,0)
 S DG4=0
"RTN","DGRPE",114,0)
 S DG3=$P($G(^DPT(DFN,.11)),U,10)
"RTN","DGRPE",115,0)
 S DG33=$O(^HL(779.004,"B","USA",""))
"RTN","DGRPE",116,0)
 I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1
"RTN","DGRPE",117,0)
 Q
"RTN","DGRPE",118,0)
PRF ; Write Proof needed for FV
"RTN","DGRPE",119,0)
 W !?4,$C(7),"Proof is required for Filipino vet."
"RTN","DGRPE",120,0)
 Q
"RTN","DGRPE",121,0)
 ;
"RTN","DGRPE",122,0)
SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA
"RTN","DGRPE",123,0)
 ; array with the BOS and component data for the SEQ military service
"RTN","DGRPE",124,0)
 ; episode (1-3)
"RTN","DGRPE",125,0)
 N I,Q,Z
"RTN","DGRPE",126,0)
 K DIPA(32,SEQ)
"RTN","DGRPE",127,0)
 S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
"RTN","DGRPE",128,0)
 S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U)
"RTN","DGRPE",129,0)
 Q
"RTN","DGRPE",130,0)
 ;
"RTN","DGRPE",131,0)
WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will
"RTN","DGRPE",132,0)
 ; be deleted
"RTN","DGRPE",133,0)
 ; Returns Y to skip component if the component should not be asked
"RTN","DGRPE",134,0)
 ;   for this branch of service
"RTN","DGRPE",135,0)
 N Z
"RTN","DGRPE",136,0)
 I '$$CMP(X) S Y="@601"_SEQ
"RTN","DGRPE",137,0)
 S Z=$G(DIPA(32,SEQ))
"RTN","DGRPE",138,0)
 Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
"RTN","DGRPE",139,0)
 ;
"RTN","DGRPE",140,0)
 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
"RTN","DGRPE",141,0)
 Q
"RTN","DGRPE",142,0)
 ;
"RTN","DGRPE",143,0)
CMP(X) ; Function to determine if service component is valid for
"RTN","DGRPE",144,0)
 ; branch of service ien in X   0 = invalid  1 = valid  
"RTN","DGRPE",145,0)
 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
"RTN","DGRPE",146,0)
 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
"RTN","DGRPE",147,0)
 ;
"RTN","DGRPE",148,0)
YN1316(DFN) ;Email address indicator - DG*5.3*865
"RTN","DGRPE",149,0)
 N %,RSLT
"RTN","DGRPE",150,0)
 S DIE("NO^")=""
"RTN","DGRPE",151,0)
P1316 ;
"RTN","DGRPE",152,0)
 S %=0
"RTN","DGRPE",153,0)
 W !,"DOES THE PATIENT HAVE AN EMAIL ADDRESS? Y/N"
"RTN","DGRPE",154,0)
 D YN^DICN
"RTN","DGRPE",155,0)
 I %=0 W !,"    If the patient has a valid Email Address, please answer with 'Yes'.",!,"    If no Email Address please answer with 'No'." G P1316
"RTN","DGRPE",156,0)
 I %=-1 W !,"    EXIT NOT ALLOWED ??" G P1316
"RTN","DGRPE",157,0)
 S RSLT=$S(%=1:"Y",%=2:"N")
"RTN","DGRPE",158,0)
 N FDA,IENS
"RTN","DGRPE",159,0)
 Q:'$G(DFN)
"RTN","DGRPE",160,0)
 S IENS=DFN_",",FDA(2,IENS,.1316)=RSLT
"RTN","DGRPE",161,0)
 D FILE^DIE("","FDA")
"RTN","DGRPE",162,0)
 Q RSLT
"RTN","DGRPP")
0^15^B19338452
"RTN","DGRPP",1,0)
DGRPP ;ALB/MRL,AEG,LBD - REGISTRATION SCREEN PROCESSOR ;10/21/10 3:55pm
"RTN","DGRPP",2,0)
 ;;5.3;Registration;**92,147,343,404,397,489,689,688,828,797,871**;Aug 13, 1993;Build 84
"RTN","DGRPP",3,0)
 ;
"RTN","DGRPP",4,0)
 ;DGRPS    : Screen to edit
"RTN","DGRPP",5,0)
 ;DGRPSEL  : If screen 9 (income screening) set to allowable selections
"RTN","DGRPP",6,0)
 ;           (V=Veteran, S=Spouse, D=Dependents)
"RTN","DGRPP",7,0)
 ;DGRPSELT : If screen 9, type selected (V, S, or D or all if none specified)
"RTN","DGRPP",8,0)
 ;DGRPAN   : Selectable items on screen for edit (user input)
"RTN","DGRPP",9,0)
 ;DGRPANP  : Selectable items for print on page footer - i.e. 1-3
"RTN","DGRPP",10,0)
 ;DGRPANN  : Selected item(s) extrapolated (screen_item)
"RTN","DGRPP",11,0)
 ;
"RTN","DGRPP",12,0)
 ;
"RTN","DGRPP",13,0)
EN ;
"RTN","DGRPP",14,0)
 D:'$$BEGUPLD^DGENUPL3(DFN)
"RTN","DGRPP",15,0)
 .D UNLOCK^DGENPTA1(DFN)
"RTN","DGRPP",16,0)
 .D CKUPLOAD^DGENUPL3(DFN)
"RTN","DGRPP",17,0)
 .I $$LOCK^DGENPTA1(DFN)
"RTN","DGRPP",18,0)
 D ENDUPLD^DGENUPL3(DFN)
"RTN","DGRPP",19,0)
 D Q1,WHICH^DGRPP1 W ! K DGRP S DGRPAN="" F I=1:1:$L(DGRPVV(DGRPS)) I $S('DGRPV:1,DGRPS=6:I=1!(I=2)!(I=3),DGRPS=11:I=5,1:0) S:'$E(DGRPVV(DGRPS),I) DGRPAN=DGRPAN_I_","
"RTN","DGRPP",20,0)
 D STR^DGRPP1 F I=$Y:1:20 W !
"RTN","DGRPP",21,0)
 ; remove COPY option DG*5.3*688
"RTN","DGRPP",22,0)
 I ("8^9"[DGRPS),($G(DGEFDT)'=DT) S Z="E" D W W "=ENTER new "_(DGISYR+1)_" data,"
"RTN","DGRPP",23,0)
 S Z="<RET>" D W W " to ",$S(DGRPS<DGRPLAST:"CONTINUE",1:"QUIT"),", "
"RTN","DGRPP",24,0)
 I DGRPAN]"" S Z=DGRPANP D W D
"RTN","DGRPP",25,0)
 . I '$G(DGRPV) W " or " S Z="ALL" D W
"RTN","DGRPP",26,0)
 . W " to "_$S('$G(DGRPV):"EDIT, ",DGRPS=6!(DGRPS=11):"EXPAND, ",1:"")
"RTN","DGRPP",27,0)
 S DGRPOUT=0,Z="^N" D W W " for screen N or " S Z="'^'" D W W " to QUIT" I DGRPSEL=""!(DGRPVV(9)'["0")!+$G(DGRPV) W ": "
"RTN","DGRPP",28,0)
 I DGRPSEL]"" D MOREHLP^DGRPP1
"RTN","DGRPP",29,0)
 G:$E(IOST,1,2)="P-" NEXT  ;RGB/VM 4/28/10 Just go to next screen for non-interactive jobs
"RTN","DGRPP",30,0)
 R DGRPANN:DTIME S:'$T DGRPOUT=1 I DGRPANN']"",'DGRPOUT G NEXT
"RTN","DGRPP",31,0)
 I $E(DGRPANN)="E",$G(DGNOBUCK),("8^9"[DGRPS) D
"RTN","DGRPP",32,0)
 .S DGNOCOPY=1
"RTN","DGRPP",33,0)
 . ; remove COPY option DG*5.3*688
"RTN","DGRPP",34,0)
 .S DGRPANN=U_DGRPS,DGRPVV(9)="000",DGRPVV(8)="00",DGIAINEW=1
"RTN","DGRPP",35,0)
JUMP G JUMP^DGRPP1:DGRPANN?1"^"1N.".".1N I DGRPOUT!(DGRPANN?1"^".E) G Q
"RTN","DGRPP",36,0)
 S (DGRPANN,X)=$$UPPER^DGUTL(DGRPANN)
"RTN","DGRPP",37,0)
 I $E(DGRPANN)="A" S X=DGRPANN,Z="^ALL" D IN^DGHELP I %'=-1 S DGRPANN=DGRPANP
"RTN","DGRPP",38,0)
 I DGRPANN]"",(DGRPSEL[$E(DGRPANN)) S DGRPSELT=$E(DGRPANN),DGRPANN=$P(DGRPANN,DGRPSELT,2) ; save off type, run through all other checks
"RTN","DGRPP",39,0)
 I DGRPANN'?1N.E D ^DGRPH G:DGRPS'=1.1 @("^DGRP"_DGRPS) G:DGRPS=1.1 ^DGRPCADD
"RTN","DGRPP",40,0)
 S DGDR="" F I=1:1 S DGCH=$P(DGRPANN,",",I) Q:DGCH']""!($L(DGCH)>5)  D CHOICE
"RTN","DGRPP",41,0)
 I DGDR']"" D ^DGRPH S X=DGRPS G SCRX
"RTN","DGRPP",42,0)
 D ^DGRPE G QQ:'$D(^DPT(DFN,0)) S X=DGRPS G SCRX
"RTN","DGRPP",43,0)
Q I 'DGELVER D:$S(DGRPOUT:0,'$D(DGRPV):0,'DGRPV:1,1:0) LT^DGRPP1
"RTN","DGRPP",44,0)
 K DGDEP,DGINC,DGINR,DGMTC,DGMTED,DGREL,DGTOT,DGSP
"RTN","DGRPP",45,0)
 K DGCH,DGGTOT,DGIRI,DGPRI,DGRPSE1,DGNOCOPY
"RTN","DGRPP",46,0)
 D SENSCHK
"RTN","DGRPP",47,0)
 I 'DGRPV S DGEDCN=1 D ^DGRPC K DGEDCN
"RTN","DGRPP",48,0)
QQ K DGRPNA,DGRPS,DGRPTYPE,DGRPU,DGRPV,DGRPVV,DGRPW,DGVI,DGVO,DGRPCM,DGELVER,DGRPLAST
"RTN","DGRPP",49,0)
Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGDR,DGRP,DGRPAG,DGRPAN,DGRPANN,DGRPANP,DGRPD,DGRPSEL,DGRPSELT,DGRPVR,DGRPX,DGAAC
"RTN","DGRPP",50,0)
 K DIRUT,DUOUT,DTOUT
"RTN","DGRPP",51,0)
 K DIC,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1 I $D(DFN)#2,DFN]"" S:$D(^DPT(DFN,0)) DA=DFN
"RTN","DGRPP",52,0)
 Q
"RTN","DGRPP",53,0)
 ;
"RTN","DGRPP",54,0)
SENSCHK ; check whether patient record should be made sensitive
"RTN","DGRPP",55,0)
 N ELIG,FLAG,X
"RTN","DGRPP",56,0)
 S ELIG=0,FLAG=0
"RTN","DGRPP",57,0)
 I '$D(^DPT($G(DFN),0)) Q  ; patient not defined
"RTN","DGRPP",58,0)
 I $D(^DGSL(38.1,DFN,0)) Q  ; patient already in dg security log file
"RTN","DGRPP",59,0)
 S X=$S($D(^DPT(DFN,"TYPE")):+^("TYPE"),1:"") I $D(^DG(391,+X,0)),$P(^(0),"^",4) D SEC Q:FLAG
"RTN","DGRPP",60,0)
 F  S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:'ELIG  D  Q:FLAG
"RTN","DGRPP",61,0)
 . S X=$G(^DIC(8,ELIG,0))
"RTN","DGRPP",62,0)
 . I $P(X,"^",12) D SEC
"RTN","DGRPP",63,0)
 Q
"RTN","DGRPP",64,0)
 ;
"RTN","DGRPP",65,0)
SEC ;if patient type says make record sensitive, add to security log file
"RTN","DGRPP",66,0)
 K DD,DO S DIC="^DGSL(38.1,",(X,DINUM)=DFN,DIC(0)="L",DIC("DR")="2///1;3////"_DUZ_";4///NOW;" D FILE^DICN
"RTN","DGRPP",67,0)
 I $D(^DGSL(38.1,DFN,0)) W !!,"===> Record has been classified as sensitive." S FLAG=1
"RTN","DGRPP",68,0)
 K DIC,X,DINUM,DA,DD,DO,Y
"RTN","DGRPP",69,0)
 Q
"RTN","DGRPP",70,0)
 ;
"RTN","DGRPP",71,0)
CHOICE ;parse out which items were selected for edit
"RTN","DGRPP",72,0)
 ;
"RTN","DGRPP",73,0)
 ;DGCH=choice to be parsed (either number or number-number)
"RTN","DGRPP",74,0)
 ;
"RTN","DGRPP",75,0)
 N DGFL S DGFL=0
"RTN","DGRPP",76,0)
 I DGCH["-" Q:DGCH'?1.2N1"-"1.2N!($P(DGCH,"-",2)>17)  F J=$P(DGCH,"-",1):1:$P(DGCH,"-",2) I DGRPAN[(J_",") D:(DGRPS=9) SCR9 I 'DGFL S DGDR=DGDR_(DGRPS*100+J)_","
"RTN","DGRPP",77,0)
 I DGCH'["-",DGCH?1.2N,(DGRPAN[(DGCH_",")) S DGDR=DGDR_(DGRPS*100+DGCH)_","
"RTN","DGRPP",78,0)
 Q
"RTN","DGRPP",79,0)
 ;
"RTN","DGRPP",80,0)
NEXT ;find next available screen...goto
"RTN","DGRPP",81,0)
 I DGRPS=DGRPLAST G Q ;last screen and return...quit
"RTN","DGRPP",82,0)
 S X=DGRPLAST
"RTN","DGRPP",83,0)
 F I=DGRPS+1:1 S J=$E(DGRPVV,I) Q:J']""  I 'J S X=I Q
"RTN","DGRPP",84,0)
 I DGRPS=1 S X=1.1
"RTN","DGRPP",85,0)
SCRX ;goto screen X
"RTN","DGRPP",86,0)
 ;I DGRPLAST=DGRPS,DGRPLAST=X G Q
"RTN","DGRPP",87,0)
 I X[".",X'=1.1 S X=$P(X,".",1)
"RTN","DGRPP",88,0)
 G:X=1.1 ^DGRPCADD
"RTN","DGRPP",89,0)
 G:X'=1.1 @("^DGRP"_X) ;goto next available screen
"RTN","DGRPP",90,0)
 ;
"RTN","DGRPP",91,0)
W ;write highlighted text on screen (if parameter on)
"RTN","DGRPP",92,0)
 I IOST="C-QUME",$L(DGVI)'=2 W Z
"RTN","DGRPP",93,0)
 E  W @DGVI,Z,@DGVO
"RTN","DGRPP",94,0)
 Q
"RTN","DGRPP",95,0)
 ;
"RTN","DGRPP",96,0)
SCR9 ; see if MT is completed.  Allow only selective editing if so
"RTN","DGRPP",97,0)
 I 'DGMTC Q
"RTN","DGRPP",98,0)
 I '$D(DGRPSELT) S:DGMTC=1 DGFL=1 Q  ;if no non-mt dependents
"RTN","DGRPP",99,0)
 I DGRPSELT="S",$D(DGMTC("S")) Q
"RTN","DGRPP",100,0)
 I DGRPSELT="D",$D(DGMTC("D")) Q
"RTN","DGRPP",101,0)
 S DGFL=1
"RTN","DGRPP",102,0)
 Q
"RTN","DGRPV")
0^2^B19556232
"RTN","DGRPV",1,0)
DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD,TDM,PWC - REGISTRATION DEFINE VARIABLES ON ENTRY ;12/15/11 1:47pm
"RTN","DGRPV",2,0)
 ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797,842,871**;Aug 13, 1993;Build 84
"RTN","DGRPV",3,0)
 ;
"RTN","DGRPV",4,0)
 ;
"RTN","DGRPV",5,0)
 ;set up variables for registration screen processing
"RTN","DGRPV",6,0)
 ;
"RTN","DGRPV",7,0)
 ;DGRPVV   :string of 15 ones and zeros each character corresponding to
"RTN","DGRPV",8,0)
 ;          a particular screen (0 means allow edit, 1 means don't)
"RTN","DGRPV",9,0)
 ;
"RTN","DGRPV",10,0)
 ;DGRPVV(n):where n=screen number.  String of x ones and zeros where
"RTN","DGRPV",11,0)
 ;          x is the number of elements on screen n (0=edit, 1=don't)
"RTN","DGRPV",12,0)
 ;
"RTN","DGRPV",13,0)
 ;DGVI     :Turn on high intensity
"RTN","DGRPV",14,0)
 ;DGVO     :Turn off high intensity
"RTN","DGRPV",15,0)
 ;
"RTN","DGRPV",16,0)
EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS
"RTN","DGRPV",17,0)
 S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity
"RTN","DGRPV",18,0)
 I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X)
"RTN","DGRPV",19,0)
M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
"RTN","DGRPV",20,0)
 S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1)
"RTN","DGRPV",21,0)
MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2
"RTN","DGRPV",22,0)
 ;DG*5.3*797
"RTN","DGRPV",23,0)
 I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN)
"RTN","DGRPV",24,0)
SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",25,0)
 S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0
"RTN","DGRPV",26,0)
 I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10"))
"RTN","DGRPV",27,0)
 ;
"RTN","DGRPV",28,0)
 S DGPH=$P($G(^DPT(DFN,.53)),U)  ;Purple Heart Indicator
"RTN","DGRPV",29,0)
 I $G(DGPRFLG)=1 D
"RTN","DGRPV",30,0)
 . S DGRPVV="000001111111111"
"RTN","DGRPV",31,0)
 E  D
"RTN","DGRPV",32,0)
 . S DGRPVV="000000000000000"
"RTN","DGRPV",33,0)
 S X="5^3^5^2^3^10^4^2^3^2^5^5^5^2^1"
"RTN","DGRPV",34,0)
 F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J))
"RTN","DGRPV",35,0)
 S DGRPVV(1.1)="00"
"RTN","DGRPV",36,0)
 S DGRPVV(2)="00010"
"RTN","DGRPV",37,0)
 I $P($G(^DPT(DFN,.52)),U,9)'="" S $E(DGRPVV(6),4)=1  ;POW status verified, no editing (DG*5.3*688)
"RTN","DGRPV",38,0)
 I $G(DGPH)]"" S $E(DGRPVV(6),8)=1
"RTN","DGRPV",39,0)
 S $E(DGRPVV(6),9,10)="11"
"RTN","DGRPV",40,0)
 ;
"RTN","DGRPV",41,0)
 F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
"RTN","DGRPV",42,0)
 ;
"RTN","DGRPV",43,0)
 ;-- if patient type is TRICARE then turn off screens 2,4
"RTN","DGRPV",44,0)
 ;
"RTN","DGRPV",45,0)
 ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 
"RTN","DGRPV",46,0)
 ;-- commented the line to allow screens 2 & 4 to display for Tricare
"RTN","DGRPV",47,0)
 ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
"RTN","DGRPV",48,0)
 ;
"RTN","DGRPV",49,0)
 F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
"RTN","DGRPV",50,0)
 I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99)
"RTN","DGRPV",51,0)
 K DIRUT,DUOUT,DTOUT
"RTN","DGRPV",52,0)
 ;
"RTN","DGRPV",53,0)
 ;Fields are numbered screen_item and put in that piece position.
"RTN","DGRPV",54,0)
 ;Because FM does not allow more than 100 pieces on a node, it was
"RTN","DGRPV",55,0)
 ;necessary to start a new node E10 for fields on screens 10 or higher.
"RTN","DGRPV",56,0)
 ;In these instances, the piece position will be screen_item-100 so,
"RTN","DGRPV",57,0)
 ;for example, screen 11, item 2 would be field 112, but piece 12.
"RTN","DGRPV",58,0)
 ;Items on screens <10 will be found on node E.
"RTN","DGRPV",59,0)
 ;
"RTN","DGRPV",60,0)
 F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
"RTN","DGRPV",61,0)
 ;
"RTN","DGRPV",62,0)
 I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip
"RTN","DGRPV",63,0)
 F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
"RTN","DGRPV",64,0)
 S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob
"RTN","DGRPV",65,0)
 I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
"RTN","DGRPV",66,0)
 I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
"RTN","DGRPV",67,0)
 S DGRPVV(11)=$E(DGRPVV(11),1,4)_"0"   ; turn on HBP to get to next screen where edit on/off will be controlled
"RTN","DGRPV",68,0)
 ;
"RTN","DGRPV",69,0)
ELVER ;set up variables for eligibility verification
"RTN","DGRPV",70,0)
 ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
"RTN","DGRPV",71,0)
 ;   and 11 if they're turned on).
"RTN","DGRPV",72,0)
 ;
"RTN","DGRPV",73,0)
 S DGRP(.361)=$G(^DPT(DFN,.361))
"RTN","DGRPV",74,0)
 I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10
"RTN","DGRPV",75,0)
 I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=10000
"RTN","DGRPV",76,0)
 S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
"RTN","DGRPV",77,0)
 I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I
"RTN","DGRPV",78,0)
Q K DGRPSC,DGRPSCE
"RTN","DGRPV",79,0)
 Q
"RTN","DGRPV",80,0)
 ;
"RTN","DGRPV",81,0)
WW ;Write number on screens for display and/or edit (Z=number)
"RTN","DGRPV",82,0)
 W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
"RTN","DGRPV",83,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",84,0)
 I 'DGRPCM&($E(Z)'="[") W Z
"RTN","DGRPV",85,0)
 Q
"RTN","DGRPV",86,0)
 ;
"RTN","DGRPV",87,0)
WW1 ;spacing for screen display (Z=item to print)
"RTN","DGRPV",88,0)
 F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
"RTN","DGRPV",89,0)
 W Z K Z2
"RTN","DGRPV",90,0)
 Q
"RTN","DGRPV",91,0)
 ;
"RTN","DGRPV",92,0)
WW2 ; Write number on screen for fields always selectable
"RTN","DGRPV",93,0)
 W:DGRPW ! S Z="["_Z_"]"
"RTN","DGRPV",94,0)
 I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
"RTN","DGRPV",95,0)
 Q
"SEC","^DIC",25.11,25.11,0,"AUDIT")
@
"SEC","^DIC",25.11,25.11,0,"DD")
@
"SEC","^DIC",25.11,25.11,0,"DEL")
@
"SEC","^DIC",25.11,25.11,0,"LAYGO")
@
"SEC","^DIC",25.11,25.11,0,"RD")
@
"SEC","^DIC",25.11,25.11,0,"WR")
@
"UP",2,2.2511,-1)
2^HBP
"UP",2,2.2511,0)
2.2511
"UP",2,2.2512,-1)
2^HBP1
"UP",2,2.2512,0)
2.2512
"VER")
8.0^22.0
"^DD",2,2,25.01,0)
CURRENT HEALTH BENEFIT PLAN^2.2511PA^^HBP;0
"^DD",2,2,25.01,21,0)
^.001^2^2^3141217^^^^
"^DD",2,2,25.01,21,1,0)
This multiple contains all the information related to the current Health 
"^DD",2,2,25.01,21,2,0)
Benefit Plan(s) for the patient. 
"^DD",2,2,25.02,0)
HISTORY HEALTH BENEFIT PLAN^2.2512DA^^HBP1;0
"^DD",2,2,25.02,21,0)
^.001^2^2^3140711^^^
"^DD",2,2,25.02,21,1,0)
This multiple contains the history of the Health Benefit Plans that are 
"^DD",2,2,25.02,21,2,0)
assigned or unassigned to a patient.
"^DD",2,2.2511,0)
CURRENT HEALTH BENEFIT PLAN SUB-FIELD^^4^5
"^DD",2,2.2511,0,"DT")
3140711
"^DD",2,2.2511,0,"IX","B",2.2511,.01)

"^DD",2,2.2511,0,"NM","CURRENT HEALTH BENEFIT PLAN")

"^DD",2,2.2511,0,"UP")
2
"^DD",2,2.2511,.01,0)
CURRENT HBP CODE^P25.11'I^DGHBP(25.11,^0;1^Q
"^DD",2,2.2511,.01,1,0)
^.1
"^DD",2,2.2511,.01,1,1,0)
2.2511^B
"^DD",2,2.2511,.01,1,1,1)
S ^DPT(DA(1),"HBP","B",$E(X,1,30),DA)=""
"^DD",2,2.2511,.01,1,1,2)
K ^DPT(DA(1),"HBP","B",$E(X,1,30),DA)
"^DD",2,2.2511,.01,3)
Enter the Health Benefit Plan for the patient.
"^DD",2,2.2511,.01,21,0)
^.001^1^1^3141217^^
"^DD",2,2.2511,.01,21,1,0)
This field contains the Health Benefit Plan that is assigned to a patient.
"^DD",2,2.2511,.01,"DT")
3140717
"^DD",2,2.2511,1,0)
ASSIGNED DATE AND TIME^DIX^^0;2^S %DT="EXT" D ^%DT S X=Y K:DT>X X
"^DD",2,2.2511,1,3)
Type a date not earlier than CURRENT DATE.
"^DD",2,2.2511,1,21,0)
^^2^2^3140711^
"^DD",2,2.2511,1,21,1,0)
This field contains the date and time the Health Benefit Plan was 
"^DD",2,2.2511,1,21,2,0)
assigned for the patient.  It is automatically set by the system.
"^DD",2,2.2511,1,"DT")
3140723
"^DD",2,2.2511,2,0)
ASSIGNED ENTERED BY^P200'I^VA(200,^0;3^Q
"^DD",2,2.2511,2,3)
Enter the person who is assigning the Health Benefit Plan to the patient.
"^DD",2,2.2511,2,21,0)
^^2^2^3140711^
"^DD",2,2.2511,2,21,1,0)
This field contains the person who assigned the Health Benefit Plan for 
"^DD",2,2.2511,2,21,2,0)
the patient.  It is automatically set by the system.
"^DD",2,2.2511,2,"DT")
3140717
"^DD",2,2.2511,3,0)
ASSIGNED ENTERED SITE^P4'I^DIC(4,^0;4^Q
"^DD",2,2.2511,3,3)
Enter the facility that is assigning the Health Benefit plan to the patient.
"^DD",2,2.2511,3,21,0)
^^2^2^3140711^
"^DD",2,2.2511,3,21,1,0)
This field contains the site that assigned a Health Benefit Plan to the 
"^DD",2,2.2511,3,21,2,0)
patient.  It is automatically set by the system.
"^DD",2,2.2511,3,"DT")
3140717
"^DD",2,2.2511,4,0)
CURRENT SOURCE^SI^E:ESR;V:VISTA;^0;5^Q
"^DD",2,2.2511,4,3)
Choose the source of the plan assignment.
"^DD",2,2.2511,4,21,0)
^^4^4^3140711^
"^DD",2,2.2511,4,21,1,0)
This field contains the source of the Health Benefit plan assignment.  
"^DD",2,2.2511,4,21,2,0)
Current Source is automatically set by the system.  The VistA system can 
"^DD",2,2.2511,4,21,3,0)
only assign a health benefit plan code if the existing Current Source is 
"^DD",2,2.2511,4,21,4,0)
VistA or blank, which is not assigned yet.
"^DD",2,2.2511,4,"DT")
3140717
"^DD",2,2.2512,0)
HISTORY HEALTH BENEFIT PLAN SUB-FIELD^^5^6
"^DD",2,2.2512,0,"DT")
3140711
"^DD",2,2.2512,0,"IX","B",2.2512,.01)

"^DD",2,2.2512,0,"NM","HISTORY HEALTH BENEFIT PLAN")

"^DD",2,2.2512,0,"UP")
2
"^DD",2,2.2512,.01,0)
HISTORY HBP DATE/TIME^DIX^^0;1^S %DT="EXT" D ^%DT S X=Y K:DT>X X
"^DD",2,2.2512,.01,1,0)
^.1
"^DD",2,2.2512,.01,1,1,0)
2.2512^B
"^DD",2,2.2512,.01,1,1,1)
S ^DPT(DA(1),"HBP1","B",$E(X,1,30),DA)=""
"^DD",2,2.2512,.01,1,1,2)
K ^DPT(DA(1),"HBP1","B",$E(X,1,30),DA)
"^DD",2,2.2512,.01,3)
Type a date not earlier than CURRENT DATE. 
"^DD",2,2.2512,.01,21,0)
^.001^3^3^3140711^^
"^DD",2,2.2512,.01,21,1,0)
This field contains the date and time the Health Benefit Plan was 
"^DD",2,2.2512,.01,21,2,0)
assigned or unassigned for the patient.  It is automatically set by the 
"^DD",2,2.2512,.01,21,3,0)
system.
"^DD",2,2.2512,.01,"DT")
3140723
"^DD",2,2.2512,1,0)
HISTORY HBP CODE^P25.11'I^DGHBP(25.11,^0;2^Q
"^DD",2,2.2512,1,3)
Enter the Health Benefit Plan for the patient.
"^DD",2,2.2512,1,21,0)
^^2^2^3140711^
"^DD",2,2.2512,1,21,1,0)
This field contains the Health Benefit Plan that is either assigned or 
"^DD",2,2.2512,1,21,2,0)
unassigned to the patient.  
"^DD",2,2.2512,1,"DT")
3140717
"^DD",2,2.2512,2,0)
HISTORY ENTERED BY^P200'I^VA(200,^0;3^Q
"^DD",2,2.2512,2,3)
Enter the user who assigned or unassigned the Health Benefit Plan to the patient. 
"^DD",2,2.2512,2,21,0)
^^2^2^3140722^
"^DD",2,2.2512,2,21,1,0)
This field contains the person who assigned or unassigned the Health 
"^DD",2,2.2512,2,21,2,0)
Benefit Plan to the patient.  It is automatically set by the system.
"^DD",2,2.2512,2,"DT")
3140722
"^DD",2,2.2512,3,0)
HISTORY ENTERED SITE^P4'I^DIC(4,^0;4^Q
"^DD",2,2.2512,3,3)
Enter the facility that assigned or unassigned the Health Benefit plan to the patient. 
"^DD",2,2.2512,3,21,0)
^^2^2^3140722^^
"^DD",2,2.2512,3,21,1,0)
This field contains the site that assigned or unassigned the Health 
"^DD",2,2.2512,3,21,2,0)
Benefit Plan to the patient.  It is automatically set by the system.
"^DD",2,2.2512,3,"DT")
3140722
"^DD",2,2.2512,4,0)
HISTORY ASSIGNMENT^SI^A:Assign;U:Unassign;^0;5^Q
"^DD",2,2.2512,4,3)
Enter A to Assign or U to Unassign a Health Benefit Plan.
"^DD",2,2.2512,4,21,0)
^.001^2^2^3140711^^
"^DD",2,2.2512,4,21,1,0)
This field indicates whether the user Assigned or Unassigned the Health 
"^DD",2,2.2512,4,21,2,0)
Benefit Plan to the patient. This is automatically set by the system.
"^DD",2,2.2512,4,"DT")
3140717
"^DD",2,2.2512,5,0)
HISTORY SOURCE^SI^E:ESR;V:VISTA;^0;6^Q
"^DD",2,2.2512,5,3)
Choose the source of the plan assignment.
"^DD",2,2.2512,5,21,0)
^^2^2^3140722^
"^DD",2,2.2512,5,21,1,0)
This field contains the source of the Health Benefit plan assignment.  
"^DD",2,2.2512,5,21,2,0)
This is automatically set by the system.
"^DD",2,2.2512,5,"DT")
3140722
"^DD",25.11,25.11,0)
FIELD^^.04^4
"^DD",25.11,25.11,0,"DDA")
N
"^DD",25.11,25.11,0,"DT")
3130307
"^DD",25.11,25.11,0,"IX","C",25.11,.02)

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

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

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

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

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

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

**INSTALL NAME**
DG*5.3*890
"BLD",9603,0)
DG*5.3*890^REGISTRATION^0^3150424^y
"BLD",9603,1,0)
^^32^32^3150127^
"BLD",9603,1,1,0)
*************************************************************************
"BLD",9603,1,2,0)
 Note:  This patch is being released in support of the Enrollment System
"BLD",9603,1,3,0)
        (ES) 4.0 project.  DG*5.3*890 is released in host file
"BLD",9603,1,4,0)
        DG_53_P891.KID along with several other patches.
"BLD",9603,1,5,0)
  
"BLD",9603,1,6,0)
        It is imperative that this patch be installed no later than the
"BLD",9603,1,7,0)
        compliance date.  Your understanding and support is appreciated.
"BLD",9603,1,8,0)
 
"BLD",9603,1,9,0)
 *************************************************************************
"BLD",9603,1,10,0)
 
"BLD",9603,1,11,0)
This patch modifies the Registration v5.3 application as described below:
"BLD",9603,1,12,0)
 
"BLD",9603,1,13,0)
Create a new data dictionary question for Contributed to Spousal Support.
"BLD",9603,1,14,0)
Create a new data dictionary question for Contributed to Child Support.
"BLD",9603,1,15,0)
 
"BLD",9603,1,16,0)
--  Health Eligibility Center (HEC) requested the Contributed to 
"BLD",9603,1,17,0)
    Spouse and Contributed to Child field be converted to accept a True
"BLD",9603,1,18,0)
    (Yes) or False (No) response instead of a dollar amount. This field  
"BLD",9603,1,19,0)
    will be available to the user if the Lived with Patient Indicator
"BLD",9603,1,20,0)
    is populated with a False (No) response. 
"BLD",9603,1,21,0)
--  This patch will decommission the AMOUNT CONTRIBUTED TO SPOUSE (Field 
"BLD",9603,1,22,0)
    #.07) and AMOUNT CONTRIBUTED TO CHILD (Field #.19) in the Income 
"BLD",9603,1,23,0)
    Relation (File #408.22). The Means Test and Rx Copay Test will no 
"BLD",9603,1,24,0)
    longer prompt for entry to these two fields.
"BLD",9603,1,25,0)
--  This patch will add a new CONTRIBUTED TO SPOUSAL SUPPORT (Field #.21) 
"BLD",9603,1,26,0)
    to the Income Relation File (File #408.22). The field will be a Y/N  
"BLD",9603,1,27,0)
    or Null set. This patch will prompt for entry of this new field at 
"BLD",9603,1,28,0)
    the appropriate point in the Means Test and Rx Copay test process.
"BLD",9603,1,29,0)
--  Modified Z07 message builder to include the Contributed to Spouse
"BLD",9603,1,30,0)
    indicator on the ORU Z07 ZIR segment.
"BLD",9603,1,31,0)
    Added a trigger for an ORF Z07 message when a change is made to
"BLD",9603,1,32,0)
    the Contributed to Spouse indicator.
"BLD",9603,4,0)
^9.64PA^408.22^1
"BLD",9603,4,408.22,0)
408.22
"BLD",9603,4,408.22,2,0)
^9.641^408.22^1
"BLD",9603,4,408.22,2,408.22,0)
INCOME RELATION  (File-top level)
"BLD",9603,4,408.22,2,408.22,1,0)
^9.6411^^
"BLD",9603,4,408.22,222)
y^n^p^^^^n^^n
"BLD",9603,4,408.22,224)

"BLD",9603,4,"APDD",408.22,408.22)

"BLD",9603,4,"B",408.22,408.22)

"BLD",9603,6.3)
40
"BLD",9603,"ABPKG")
n
"BLD",9603,"INID")
n^n^n
"BLD",9603,"INIT")
RCMP^DG53890P
"BLD",9603,"KRN",0)
^9.67PA^779.2^20
"BLD",9603,"KRN",.4,0)
.4
"BLD",9603,"KRN",.4,"NM",0)
^9.68A^^
"BLD",9603,"KRN",.401,0)
.401
"BLD",9603,"KRN",.402,0)
.402
"BLD",9603,"KRN",.402,"NM",0)
^9.68A^3^3
"BLD",9603,"KRN",.402,"NM",1,0)
DGMT V1 ENTER/EDIT DEPENDENTS    FILE #408.22^408.22^0
"BLD",9603,"KRN",.402,"NM",2,0)
DGMT ENTER/EDIT DEPENDENTS    FILE #408.22^408.22^0
"BLD",9603,"KRN",.402,"NM",3,0)
DGMT ENTER/EDIT MARITAL STATUS    FILE #408.22^408.22^0
"BLD",9603,"KRN",.402,"NM","B","DGMT ENTER/EDIT DEPENDENTS    FILE #408.22",2)

"BLD",9603,"KRN",.402,"NM","B","DGMT ENTER/EDIT MARITAL STATUS    FILE #408.22",3)

"BLD",9603,"KRN",.402,"NM","B","DGMT V1 ENTER/EDIT DEPENDENTS    FILE #408.22",1)

"BLD",9603,"KRN",.403,0)
.403
"BLD",9603,"KRN",.403,"NM",0)
^9.68A^^
"BLD",9603,"KRN",.5,0)
.5
"BLD",9603,"KRN",.84,0)
.84
"BLD",9603,"KRN",3.6,0)
3.6
"BLD",9603,"KRN",3.8,0)
3.8
"BLD",9603,"KRN",9.2,0)
9.2
"BLD",9603,"KRN",9.8,0)
9.8
"BLD",9603,"KRN",9.8,"NM",0)
^9.68A^8^5
"BLD",9603,"KRN",9.8,"NM",4,0)
VAFHLZIR^^0^B15600256
"BLD",9603,"KRN",9.8,"NM",5,0)
DGMTSCC^^0^B36202206
"BLD",9603,"KRN",9.8,"NM",6,0)
DGMTSCU2^^0^B12374485
"BLD",9603,"KRN",9.8,"NM",7,0)
DGDEP3^^0^B45148199
"BLD",9603,"KRN",9.8,"NM",8,0)
DGMTUTL2^^0^B25559255
"BLD",9603,"KRN",9.8,"NM","B","DGDEP3",7)

"BLD",9603,"KRN",9.8,"NM","B","DGMTSCC",5)

"BLD",9603,"KRN",9.8,"NM","B","DGMTSCU2",6)

"BLD",9603,"KRN",9.8,"NM","B","DGMTUTL2",8)

"BLD",9603,"KRN",9.8,"NM","B","VAFHLZIR",4)

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

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

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

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

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

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

"BLD",9603,"KRN","B",3.6,3.6)

"BLD",9603,"KRN","B",3.8,3.8)

"BLD",9603,"KRN","B",9.2,9.2)

"BLD",9603,"KRN","B",9.8,9.8)

"BLD",9603,"KRN","B",19,19)

"BLD",9603,"KRN","B",19.1,19.1)

"BLD",9603,"KRN","B",101,101)

"BLD",9603,"KRN","B",409.61,409.61)

"BLD",9603,"KRN","B",771,771)

"BLD",9603,"KRN","B",779.2,779.2)

"BLD",9603,"KRN","B",870,870)

"BLD",9603,"KRN","B",8989.51,8989.51)

"BLD",9603,"KRN","B",8989.52,8989.52)

"BLD",9603,"KRN","B",8994,8994)

"BLD",9603,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9603,"QUES",0)
^9.62^^
"BLD",9603,"REQB",0)
^9.611^8^5
"BLD",9603,"REQB",4,0)
DG*5.3*754^2
"BLD",9603,"REQB",5,0)
DG*5.3*611^2
"BLD",9603,"REQB",6,0)
DG*5.3*490^2
"BLD",9603,"REQB",7,0)
DG*5.3*867^2
"BLD",9603,"REQB",8,0)
DG*5.3*655^2
"BLD",9603,"REQB","B","DG*5.3*490",6)

"BLD",9603,"REQB","B","DG*5.3*611",5)

"BLD",9603,"REQB","B","DG*5.3*655",8)

"BLD",9603,"REQB","B","DG*5.3*754",4)

"BLD",9603,"REQB","B","DG*5.3*867",7)

"FIA",408.22)
INCOME RELATION
"FIA",408.22,0)
^DGMT(408.22,
"FIA",408.22,0,0)
408.22IP
"FIA",408.22,0,1)
y^n^f^^^^n^^n
"FIA",408.22,0,10)

"FIA",408.22,0,11)

"FIA",408.22,0,"RLRO")

"FIA",408.22,0,"VR")
5.3^DG
"FIA",408.22,408.22)
0
"INIT")
RCMP^DG53890P
"KRN",.402,467,-1)
0^3
"KRN",.402,467,0)
DGMT ENTER/EDIT MARITAL STATUS^3141218.1039^^408.22^^^3150205^
"KRN",.402,467,"DIAB",2,0,408.22,1)
.06;REQ;"DID YOU LIVE WITH YOUR SPOUSE LAST YEAR"
"KRN",.402,467,"DIAB",2,0,408.22,2)
.08//^S X=$S($D(DGREL("C")):"YES",1:"");REQ;T
"KRN",.402,467,"DIAB",4,0,408.22,1)
.21;REQ;"IF YOUR SPOUSE DID NOT LIVE WITH YOU LAST YEAR, DID YOU PROVIDE SUPPORT"
"KRN",.402,467,"DIAB",5,0,408.22,0)
.05//^S X=$S("^2^5^"[(U_$S($D(^DPT(DFN,0)):$P(^(0),U,5),1:"")_U)!($D(DGREL("S"))):"YES",1:"NO");REQ;T
"KRN",.402,467,"DR",1,408.22)
K DGFIN;I '$D(DFN)!('$D(DGDR)) W !,*7,"Variables DFN and DGDR must be defined!" S Y="@999";S:DGDR'["101" Y="@102";@101;.05T~R~//^S X=$S("^2^5^"[(U_$S($D(^DPT(DFN,0)):$P(^(0),U,5),1:"")_U)!($D(DGREL("S"))):"YES",1:"NO");
"KRN",.402,467,"DR",1,408.22,1)
S:'X Y="@102";.06DID YOU LIVE WITH YOUR SPOUSE LAST YEAR~R~;S:X Y="@102";.21IF YOUR SPOUSE DID NOT LIVE WITH YOU LAST YEAR, DID YOU PROVIDE SUPPORT~R~;S:'X Y="@102";S X=$S($P(^DGMT(408.22,DA,0),U,20)=1:"YES",1:"NO");@102;
"KRN",.402,467,"DR",1,408.22,2)
S:DGDR'["102" Y="@998";.08T~R~//^S X=$S($D(DGREL("C")):"YES",1:"");@998;S DGFIN="";@999;
"KRN",.402,467,"ROU")
^DGMTXM
"KRN",.402,467,"ROUOLD")
DGMTXM
"KRN",.402,468,-1)
0^2
"KRN",.402,468,0)
DGMT ENTER/EDIT DEPENDENTS^3141212.084^^408.22^^^3141210
"KRN",.402,468,"DIAB",2,0,408.22,2)
CONTRIBUTED TO SUPPORT;T
"KRN",.402,468,"DIAB",5,0,408.22,1)
INCAPABLE OF SELF-SUPPORT;T
"KRN",.402,468,"DIAB",6,0,408.22,2)
CHILD HAD INCOME;"DID CHILD HAVE ANY INCOME/NET WORTH"
"KRN",.402,468,"DIAB",7,0,408.22,1)
CHILD 18-23 IN SCHOOL//YES;T
"KRN",.402,468,"DIAB",8,0,408.22,2)
INCOME AVAILABLE TO YOU;"WAS THE CHILD'S INCOME/NET WORTH AVAILABLE TO YOU"
"KRN",.402,468,"DIAB",10,0,408.22,1)
CHILD 18-23 IN SCHOOL//NO;T
"KRN",.402,468,"DIAB",12,0,408.22,1)
LIVED WITH PATIENT;"DID THE CHILD LIVE WITH YOU"
"KRN",.402,468,"DR",1,408.22)
K DGFIN;N IAIPTR,PRPTR,PFILE,PIEN,PREC;N DOB,AGE,PREF;S IAIPTR=$P(^DGMT(408.22,DA,0),"^",2);S PRPTR=$P(^DGMT(408.21,IAIPTR,0),"^",2);S PREF=$P(^DGPR(408.12,PRPTR,0),"^",3);S PFILE="^"_$P(PREF,$CHAR(59),2);
"KRN",.402,468,"DR",1,408.22,1)
S PIEN=$P(PREF,$CHAR(59),1);S PREC=PFILE_PIEN_",0)";S DOB=$P(@PREC,"^",3);S AGE=($$FMDIFF^XLFDT(DT,DOB)/365.25);.09T~;I (AGE<18)!(AGE>23.99999) S Y="@1";.18T~//YES;S Y="@2";@1;.18T~//NO;@2;.06DID THE CHILD LIVE WITH YOU~;
"KRN",.402,468,"DR",1,408.22,2)
S:X Y="@10";.1T~;S:'X Y="@10";@10;S DGNFLD="@10";.11DID CHILD HAVE ANY INCOME/NET WORTH~;S:'X Y="@998";.12WAS THE CHILD'S INCOME/NET WORTH AVAILABLE TO YOU~;@998;K IAIPTR,PRPTR,PFILE,PIEN,PREC,DOB,AGE,PREF S Y=DGNFLD;S DGFIN="";
"KRN",.402,468,"ROU")
^DGMTXD
"KRN",.402,468,"ROUOLD")
DGMTXD
"KRN",.402,1755,-1)
0^1
"KRN",.402,1755,0)
DGMT V1 ENTER/EDIT DEPENDENTS^3141212.0729^^408.22^^^3150126
"KRN",.402,1755,"DIAB",2,0,408.22,2)
CONTRIBUTED TO SUPPORT;T
"KRN",.402,1755,"DIAB",5,0,408.22,1)
INCAPABLE OF SELF-SUPPORT;T
"KRN",.402,1755,"DIAB",5,0,408.22,2)
CHILD HAD INCOME;"DID CHILD HAVE ANY INCOME/NET WORTH"
"KRN",.402,1755,"DIAB",7,0,408.22,1)
CHILD 18-23 IN SCHOOL//YES;T
"KRN",.402,1755,"DIAB",7,0,408.22,2)
INCOME AVAILABLE TO YOU;" WAS THE CHILD'S INCOME/NET WORTH AVAILABLE TO YOU"
"KRN",.402,1755,"DIAB",10,0,408.22,1)
CHILD 18-23 IN SCHOOL//NO;T
"KRN",.402,1755,"DIAB",12,0,408.22,1)
LIVED WITH PATIENT;"DID THE CHILD LIVE WITH YOU"
"KRN",.402,1755,"DR",1,408.22)
K DGFIN;N IAIPTR,PRPTR,PFILE,PIEN,PREC;N PDOB,AGE,PREF;S IAIPTR=$P(^DGMT(408.22,DA,0),"^",2);S PRPTR=$P(^DGMT(408.21,IAIPTR,0),"^",2);S PREF=$P(^DGPR(408.12,PRPTR,0),"^",3);S PFILE="^"_$P(PREF,$CHAR(59),2);
"KRN",.402,1755,"DR",1,408.22,1)
S PIEN=$P(PREF,$CHAR(59),1);S PREC=PFILE_PIEN_",0)";S DOB=$P(@PREC,"^",3);S AGE=($$FMDIFF^XLFDT(DT,DOB)/365.25);.09T~;I (AGE<18)!(AGE>23.99999) S Y="@1";.18T~//YES;S Y="@2";@1;.18T~//NO;@2;.06DID THE CHILD LIVE WITH YOU~;
"KRN",.402,1755,"DR",1,408.22,2)
S:X Y="@10";.1T~;S:'X Y="@10";@10;.11DID CHILD HAVE ANY INCOME/NET WORTH~;S:'X Y="@998";.12 WAS THE CHILD'S INCOME/NET WORTH AVAILABLE TO YOU~;@998;S DGFIN="";
"KRN",.402,1755,"ROU")
^DGMTXT
"KRN",.402,1755,"ROUOLD")
DGMTXT
"MBREQ")
0
"ORD",7,.402)
.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%)
"ORD",7,.402,0)
INPUT TEMPLATE
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
890^3150424
"PKG",47,22,1,"PAH",1,1,0)
^^32^32^3150424
"PKG",47,22,1,"PAH",1,1,1,0)
*************************************************************************
"PKG",47,22,1,"PAH",1,1,2,0)
 Note:  This patch is being released in support of the Enrollment System
"PKG",47,22,1,"PAH",1,1,3,0)
        (ES) 4.0 project.  DG*5.3*890 is released in host file
"PKG",47,22,1,"PAH",1,1,4,0)
        DG_53_P891.KID along with several other patches.
"PKG",47,22,1,"PAH",1,1,5,0)
  
"PKG",47,22,1,"PAH",1,1,6,0)
        It is imperative that this patch be installed no later than the
"PKG",47,22,1,"PAH",1,1,7,0)
        compliance date.  Your understanding and support is appreciated.
"PKG",47,22,1,"PAH",1,1,8,0)
 
"PKG",47,22,1,"PAH",1,1,9,0)
 *************************************************************************
"PKG",47,22,1,"PAH",1,1,10,0)
 
"PKG",47,22,1,"PAH",1,1,11,0)
This patch modifies the Registration v5.3 application as described below:
"PKG",47,22,1,"PAH",1,1,12,0)
 
"PKG",47,22,1,"PAH",1,1,13,0)
Create a new data dictionary question for Contributed to Spousal Support.
"PKG",47,22,1,"PAH",1,1,14,0)
Create a new data dictionary question for Contributed to Child Support.
"PKG",47,22,1,"PAH",1,1,15,0)
 
"PKG",47,22,1,"PAH",1,1,16,0)
--  Health Eligibility Center (HEC) requested the Contributed to 
"PKG",47,22,1,"PAH",1,1,17,0)
    Spouse and Contributed to Child field be converted to accept a True
"PKG",47,22,1,"PAH",1,1,18,0)
    (Yes) or False (No) response instead of a dollar amount. This field  
"PKG",47,22,1,"PAH",1,1,19,0)
    will be available to the user if the Lived with Patient Indicator
"PKG",47,22,1,"PAH",1,1,20,0)
    is populated with a False (No) response. 
"PKG",47,22,1,"PAH",1,1,21,0)
--  This patch will decommission the AMOUNT CONTRIBUTED TO SPOUSE (Field 
"PKG",47,22,1,"PAH",1,1,22,0)
    #.07) and AMOUNT CONTRIBUTED TO CHILD (Field #.19) in the Income 
"PKG",47,22,1,"PAH",1,1,23,0)
    Relation (File #408.22). The Means Test and Rx Copay Test will no 
"PKG",47,22,1,"PAH",1,1,24,0)
    longer prompt for entry to these two fields.
"PKG",47,22,1,"PAH",1,1,25,0)
--  This patch will add a new CONTRIBUTED TO SPOUSAL SUPPORT (Field #.21) 
"PKG",47,22,1,"PAH",1,1,26,0)
    to the Income Relation File (File #408.22). The field will be a Y/N  
"PKG",47,22,1,"PAH",1,1,27,0)
    or Null set. This patch will prompt for entry of this new field at 
"PKG",47,22,1,"PAH",1,1,28,0)
    the appropriate point in the Means Test and Rx Copay test process.
"PKG",47,22,1,"PAH",1,1,29,0)
--  Modified Z07 message builder to include the Contributed to Spouse
"PKG",47,22,1,"PAH",1,1,30,0)
    indicator on the ORU Z07 ZIR segment.
"PKG",47,22,1,"PAH",1,1,31,0)
    Added a trigger for an ORF Z07 message when a change is made to
"PKG",47,22,1,"PAH",1,1,32,0)
    the Contributed to Spouse indicator.
"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")
6
"RTN","DG53890P")
0^^B2816394
"RTN","DG53890P",1,0)
DG53890P ;ALB/DHS/DRP - CONTRIBUTE SPOUSE POST-INIT ;12/09/14
"RTN","DG53890P",2,0)
 ;;5.3;Registration;**890**;Aug 13, 1993;Build 40
"RTN","DG53890P",3,0)
 ;
"RTN","DG53890P",4,0)
 Q
"RTN","DG53890P",5,0)
 ;
"RTN","DG53890P",6,0)
RCMP ; -- re-compile all compiled input templates.
"RTN","DG53890P",7,0)
 N X,Y,DA,DMAX,DGERR,DGDUZSV,DGINTP
"RTN","DG53890P",8,0)
 I $G(DUZ)="" W !,"Your DUZ is not defined.  It must be defined to run this routine." Q
"RTN","DG53890P",9,0)
 S DGDUZSV=DUZ(0),DUZ(0)="@"
"RTN","DG53890P",10,0)
 ;
"RTN","DG53890P",11,0)
 D BMES^XPDUTL("Compiling Input Templates....")
"RTN","DG53890P",12,0)
 ;
"RTN","DG53890P",13,0)
 F DGINTP="DGMT ENTER/EDIT DEPENDENTS","DGMT V1 ENTER/EDIT DEPENDENTS","DGMT ENTER/EDIT MARITAL STATUS" S Y=$O(^DIE("B",DGINTP,0)) S DGERR=0 D  I DGERR D BMES^XPDUTL("** "_DGINTP_" input template could not be updated")
"RTN","DG53890P",14,0)
 .I 'Y S DGERR=1 Q
"RTN","DG53890P",15,0)
 .S X=$P($G(^DIE(Y,"ROU")),U,2) I X="" S DGERR=1 Q
"RTN","DG53890P",16,0)
 .S DMAX=$$ROUSIZE^DILF D EN^DIEZ
"RTN","DG53890P",17,0)
 ;
"RTN","DG53890P",18,0)
 S DUZ(0)=DGDUZSV
"RTN","DG53890P",19,0)
 Q
"RTN","DGDEP3")
0^7^B45148199
"RTN","DGDEP3",1,0)
DGDEP3 ;ALB/CAW,BAJ,ERC,PWC - Dependents display ;11/22/2005
"RTN","DGDEP3",2,0)
 ;;5.3;Registration;**45,624,653,688,867,890**;Aug 13, 1993;Build 40
"RTN","DGDEP3",3,0)
 ;
"RTN","DGDEP3",4,0)
SELF(INCPER,NAME,RELATE,ACT,DGMTI,CNT) ; Display information concerning veteran
"RTN","DGDEP3",5,0)
 ;
"RTN","DGDEP3",6,0)
 S DGX="",DGX=$$SETSTR^VALM1(CNT,DGX,3,3)
"RTN","DGDEP3",7,0)
 I $G(DGMTI),INCPER,($P($G(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI) S DGX=$$SETSTR^VALM1("*",DGX,5,1)
"RTN","DGDEP3",8,0)
 S DGX=$$SETSTR^VALM1(NAME,DGX,9,22)
"RTN","DGDEP3",9,0)
 S DGX=$$SETSTR^VALM1($P($G(^DG(408.11,RELATE,0)),U),DGX,32,30)
"RTN","DGDEP3",10,0)
 S DGX=$$SETSTR^VALM1($S($P(ACT,U,2)=1:"*",1:""),DGX,65,1)
"RTN","DGDEP3",11,0)
 S:RELATE=2 DGX=$$SETSTR^VALM1($S(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1)
"RTN","DGDEP3",12,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",13,0)
 ;
"RTN","DGDEP3",14,0)
 ; Display spouse SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
"RTN","DGDEP3",15,0)
 I RELATE=2 D
"RTN","DGDEP3",16,0)
 . S DGX="",DGX=$$SETSTR^VALM1($P(DGDEP,"^",5),DGX,9,14)
"RTN","DGDEP3",17,0)
 . S DGX=$$SETSTR^VALM1($P(DGDEP,"^",9),DGX,23,10)
"RTN","DGDEP3",18,0)
 . ;if a Pseudo SSN need Pseudo SSN Reason - DG*5.3*653, ERC
"RTN","DGDEP3",19,0)
 . I $P(DGDEP,U,5)["P" D
"RTN","DGDEP3",20,0)
 . . S DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15)
"RTN","DGDEP3",21,0)
 . . S DGX=$$SETSTR^VALM1($P(DGDEP,U,10),DGX,45,30)
"RTN","DGDEP3",22,0)
 . . ;D SET^DGDEP(DGX)
"RTN","DGDEP3",23,0)
 . D SET^DGDEP(DGX)
"RTN","DGDEP3",24,0)
 ;
"RTN","DGDEP3",25,0)
 Q:RELATE=2
"RTN","DGDEP3",26,0)
 D NEWB
"RTN","DGDEP3",27,0)
DISPLAY ;
"RTN","DGDEP3",28,0)
 ;  MARRIED LAST YEAR = PIECE 5
"RTN","DGDEP3",29,0)
 ;  LIVED WITH SPOUSE = PIECE 6
"RTN","DGDEP3",30,0)
 ;  AMOUNT CONTRIBUTED = PIECE 7
"RTN","DGDEP3",31,0)
 ;  CONTRIBUTED TO SPOUSE = PIECE 20
"RTN","DGDEP3",32,0)
 ;  DG*5.3*890 Amount Contributed Decommissioned.  Display only historical information
"RTN","DGDEP3",33,0)
 S INCPER=^DGMT(408.22,INCPER,0)
"RTN","DGDEP3",34,0)
 S DGX="",DGX=$$SETSTR^VALM1("Married Last Year: ",DGX,18,19)
"RTN","DGDEP3",35,0)
 S DGX=$$SETSTR^VALM1($S($P(INCPER,U,5):"Yes",$P(INCPER,U,5)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",36,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",37,0)
 ;
"RTN","DGDEP3",38,0)
 Q:'$G(DGMTI)
"RTN","DGDEP3",39,0)
 I $P(INCPER,U,5)=1 D
"RTN","DGDEP3",40,0)
 . S DGX="",DGX=$$SETSTR^VALM1("Lived with Spouse: ",DGX,18,19)
"RTN","DGDEP3",41,0)
 . S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6):"Yes",$P(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",42,0)
 . D SET^DGDEP(DGX)
"RTN","DGDEP3",43,0)
 Q:$P(INCPER,U,5)=1&($P(INCPER,U,6)=1)    ;quit if Lived with Spouse and Married Last Year both equal YES
"RTN","DGDEP3",44,0)
 ;
"RTN","DGDEP3",45,0)
 I $P(INCPER,U,20)'="" D  ; new contributed to spouse question was answered
"RTN","DGDEP3",46,0)
 . S DGX="",DGX=$$SETSTR^VALM1("Contributed to Spouse: ",DGX,14,22)
"RTN","DGDEP3",47,0)
 . S DGX=$$SETSTR^VALM1($S($P(INCPER,U,20):"Yes",$P(INCPER,U,20)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",48,0)
 . D SET^DGDEP(DGX)
"RTN","DGDEP3",49,0)
 ;
"RTN","DGDEP3",50,0)
 Q:$P(INCPER,U,20)'=""   ;no need for old code because new question was answered
"RTN","DGDEP3",51,0)
 Q:$P(INCPER,U,6)=""     ;Lived with Spouse is Unanswered, no need to go further
"RTN","DGDEP3",52,0)
 ;
"RTN","DGDEP3",53,0)
 I $P(INCPER,U,7)'="" D  Q   ;new question has not been answered yet, but amount has value, historical information will display
"RTN","DGDEP3",54,0)
 . S DGX="",DGX=$$SETSTR^VALM1("Amount Contributed: ",DGX,17,19)
"RTN","DGDEP3",55,0)
 . S DGX=$$SETSTR^VALM1($S($P(INCPER,U,7)]"":$P(INCPER,U,7),1:"Unanswered"),DGX,38,10)
"RTN","DGDEP3",56,0)
 . D SET^DGDEP(DGX)
"RTN","DGDEP3",57,0)
 ;
"RTN","DGDEP3",58,0)
 Q:$P(INCPER,U,6)=1   ;Lived with Spouse is YES, so no need to go further
"RTN","DGDEP3",59,0)
 ;
"RTN","DGDEP3",60,0)
 I $P(INCPER,U,7)="" D    ;new question not answered yet but no value is entered
"RTN","DGDEP3",61,0)
 . S DGX="",DGX=$$SETSTR^VALM1("Contributed to Spouse: ",DGX,14,22)
"RTN","DGDEP3",62,0)
 . S DGX=$$SETSTR^VALM1($S($P(INCPER,U,20):"Yes",$P(INCPER,U,20)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",63,0)
 . D SET^DGDEP(DGX)
"RTN","DGDEP3",64,0)
 Q
"RTN","DGDEP3",65,0)
 ;
"RTN","DGDEP3",66,0)
CHILD(INCPER,NAME,RELATE,ACT,DGMTI,DGMTACT,CNT) ; Display information concerning dependents
"RTN","DGDEP3",67,0)
 ;
"RTN","DGDEP3",68,0)
 ;** DG*5.3*688 - GTS Get MT Version
"RTN","DGDEP3",69,0)
 ;** DG*5.3*890 - Amount Contributed Decommissioned.  Display only historical information
"RTN","DGDEP3",70,0)
 N MTVER
"RTN","DGDEP3",71,0)
 S:(+$G(DGMTI)>0) MTVER=$P($G(^DGMT(408.31,DGMTI,2)),"^",11)
"RTN","DGDEP3",72,0)
 I (+$G(DGMTI)'>0) DO
"RTN","DGDEP3",73,0)
 . N DGINC,DGREL,DGINR,DGDEP
"RTN","DGDEP3",74,0)
 . D ALL^DGMTU21(DFN,"VSD",DT,"I")
"RTN","DGDEP3",75,0)
 . S MTVER=$$VER^DGMTUTL3(.DGINC)
"RTN","DGDEP3",76,0)
 S DGX="",DGX=$$SETSTR^VALM1(CNT,DGX,3,3)
"RTN","DGDEP3",77,0)
 I $G(DGMTI),INCPER,($P($G(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI) S DGX=$$SETSTR^VALM1("*",DGX,5,1)
"RTN","DGDEP3",78,0)
 S DGX=$$SETSTR^VALM1(NAME,DGX,9,22)
"RTN","DGDEP3",79,0)
 S DGX=$$SETSTR^VALM1($P($G(^DG(408.11,RELATE,0)),U),DGX,32,30)
"RTN","DGDEP3",80,0)
 S DGX=$$SETSTR^VALM1($S($P(ACT,U,2)=1:"*",1:""),DGX,65,1)
"RTN","DGDEP3",81,0)
 S DGX=$$SETSTR^VALM1($S(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1)
"RTN","DGDEP3",82,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",83,0)
 ;
"RTN","DGDEP3",84,0)
 ;display dependent SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
"RTN","DGDEP3",85,0)
 S DGX="",DGX=$$SETSTR^VALM1($P(DGDEP,"^",5),DGX,9,14)
"RTN","DGDEP3",86,0)
 S DGX=$$SETSTR^VALM1($P(DGDEP,"^",9),DGX,23,10)
"RTN","DGDEP3",87,0)
 I $P(DGDEP,U,5)["P" D
"RTN","DGDEP3",88,0)
 . S DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15)
"RTN","DGDEP3",89,0)
 . S DGX=$$SETSTR^VALM1($P(DGDEP,U,10),DGX,45,30)
"RTN","DGDEP3",90,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",91,0)
 ;
"RTN","DGDEP3",92,0)
 Q:'$G(DGMTI)!('$P($G(^DG(408.11,RELATE,0)),U,4))
"RTN","DGDEP3",93,0)
 S INCPER=^DGMT(408.22,INCPER,0)
"RTN","DGDEP3",94,0)
 S DGX="",DGX=$$SETSTR^VALM1("Incapable of Self-support: ",DGX,10,27)
"RTN","DGDEP3",95,0)
 S DGX=$$SETSTR^VALM1($S($P(INCPER,U,9):"Yes",$P(INCPER,U,9)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",96,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",97,0)
 ;
"RTN","DGDEP3",98,0)
 ;* DG*5.3*624
"RTN","DGDEP3",99,0)
 S DGX="",DGX=$$SETSTR^VALM1("Child 18 to 23. Attended School: ",DGX,4,33)
"RTN","DGDEP3",100,0)
 S DGX=$$SETSTR^VALM1($S($P(INCPER,U,18):"Yes",$P(INCPER,U,18)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",101,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",102,0)
 ;
"RTN","DGDEP3",103,0)
 S DGX="",DGX=$$SETSTR^VALM1("Child lived with you: ",DGX,15,22)
"RTN","DGDEP3",104,0)
 S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6):"Yes",$P(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",105,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",106,0)
 ;
"RTN","DGDEP3",107,0)
 S DGX="",DGX=$$SETSTR^VALM1("Child Support: ",DGX,22,15)
"RTN","DGDEP3",108,0)
 S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6)=1:"N/A",$P(INCPER,U,10)=1:"Yes",$P(INCPER,U,10)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",109,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",110,0)
 ;
"RTN","DGDEP3",111,0)
 ;* DG*5.3*624
"RTN","DGDEP3",112,0)
 ;* DG*5.3*890   only display amount contributed if value already exists in field
"RTN","DGDEP3",113,0)
 I $P(INCPER,U,19)'="" D
"RTN","DGDEP3",114,0)
 . S DGX="",DGX=$$SETSTR^VALM1("Amount contributed: ",DGX,17,20)
"RTN","DGDEP3",115,0)
 . S DGX=$$SETSTR^VALM1($S($P(INCPER,U,10)'=1:"N/A",($P(INCPER,U,19)'="0")&($P(INCPER,U,19)'=""):$P(INCPER,U,19),$P(INCPER,U,19)="":"Unanswered",1:"0"),DGX,38,10)
"RTN","DGDEP3",116,0)
 . D SET^DGDEP(DGX)
"RTN","DGDEP3",117,0)
 ;
"RTN","DGDEP3",118,0)
 ;** DG*5.3*688 - GTS Chk MT Version and output correct data
"RTN","DGDEP3",119,0)
 S DGX=""
"RTN","DGDEP3",120,0)
 S:(+MTVER<1) DGX=$$SETSTR^VALM1("Child Has Income: ",DGX,19,18)
"RTN","DGDEP3",121,0)
 S:(+MTVER=1) DGX=$$SETSTR^VALM1("Child Has Income/Net Worth: ",DGX,9,28)
"RTN","DGDEP3",122,0)
 S DGX=$$SETSTR^VALM1($S($P(INCPER,U,11)=1:"Yes",$P(INCPER,U,11)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",123,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",124,0)
 ;
"RTN","DGDEP3",125,0)
 ;** DG*5.3*688 - GTS Chk MT Version and output correct data
"RTN","DGDEP3",126,0)
 S DGX=""
"RTN","DGDEP3",127,0)
 S:(+MTVER<1) DGX=$$SETSTR^VALM1("Income Available: ",DGX,19,18)
"RTN","DGDEP3",128,0)
 S:(+MTVER=1) DGX=$$SETSTR^VALM1("Income/Net Worth Available: ",DGX,9,28)
"RTN","DGDEP3",129,0)
 S DGX=$$SETSTR^VALM1($S($P(INCPER,U,11)=0:"N/A",$P(INCPER,U,12)=1:"Yes",$P(INCPER,U,12)="":"Unanswered",1:"No"),DGX,38,10)
"RTN","DGDEP3",130,0)
 D SET^DGDEP(DGX)
"RTN","DGDEP3",131,0)
CHILDQ Q
"RTN","DGDEP3",132,0)
 ;
"RTN","DGDEP3",133,0)
ADDCHK(INCPER) ; Indicates existence of any dependent address
"RTN","DGDEP3",134,0)
 ; Input:
"RTN","DGDEP3",135,0)
 ;      INCPER - Pointer to dep. entry in Income Relation file (408.22)
"RTN","DGDEP3",136,0)
 ;
"RTN","DGDEP3",137,0)
 ; Output: 
"RTN","DGDEP3",138,0)
 ;   both address and phone^address^phone
"RTN","DGDEP3",139,0)
 ;      KEY:
"RTN","DGDEP3",140,0)
 ;        0 - No data exists for the dependent in 408.13
"RTN","DGDEP3",141,0)
 ;        1 - Data exists for the dependent in 408.13
"RTN","DGDEP3",142,0)
 ;
"RTN","DGDEP3",143,0)
 ;    1^1^1 - Address and Phone data exist for dependent
"RTN","DGDEP3",144,0)
 ;    0^1^0 - Address only exists for dependent
"RTN","DGDEP3",145,0)
 ;    0^0^1 - Phone only exists for dependent
"RTN","DGDEP3",146,0)
 ;    0^0^0 - Neither Phone nor Address data exists for dependent
"RTN","DGDEP3",147,0)
 ;
"RTN","DGDEP3",148,0)
 N ADDCKVAL,INDAIIEN,PRIEN,IPIEN
"RTN","DGDEP3",149,0)
 S ADDCKVAL="0^0^0"
"RTN","DGDEP3",150,0)
 S INDAIIEN=$P($G(^DGMT(408.22,INCPER,0)),"^",2)
"RTN","DGDEP3",151,0)
 S PRIEN=$P($G(^DGMT(408.21,INDAIIEN,0)),"^",2)
"RTN","DGDEP3",152,0)
 S IPIEN=$P($G(^DGPR(408.12,PRIEN,0)),"^",3)
"RTN","DGDEP3",153,0)
 I IPIEN["DGPR(408.13" DO
"RTN","DGDEP3",154,0)
 . S IPIEN=$P(IPIEN,";",1)
"RTN","DGDEP3",155,0)
 . I $P($G(^DGPR(408.13,IPIEN,1)),"^",2)]"" S $P(ADDCKVAL,U,1,2)="1^1"
"RTN","DGDEP3",156,0)
 . I $P($G(^DGPR(408.13,IPIEN,1)),"^",3)]"" S $P(ADDCKVAL,U,1,2)="1^1"
"RTN","DGDEP3",157,0)
 . I $P($G(^DGPR(408.13,IPIEN,1)),"^",4)]"" S $P(ADDCKVAL,U,1,2)="1^1"
"RTN","DGDEP3",158,0)
 . I $P($G(^DGPR(408.13,IPIEN,1)),"^",5)]"" S $P(ADDCKVAL,U,1,2)="1^1"
"RTN","DGDEP3",159,0)
 . I $P($G(^DGPR(408.13,IPIEN,1)),"^",6)]"" S $P(ADDCKVAL,U,1,2)="1^1"
"RTN","DGDEP3",160,0)
 . I $P($G(^DGPR(408.13,IPIEN,1)),"^",7)]"" S $P(ADDCKVAL,U,1,2)="1^1"
"RTN","DGDEP3",161,0)
 . I $P($G(^DGPR(408.13,IPIEN,1)),"^",8)]"" S $P(ADDCKVAL,U,3)="1"
"RTN","DGDEP3",162,0)
 Q ADDCKVAL
"RTN","DGDEP3",163,0)
 ;
"RTN","DGDEP3",164,0)
NEWB ; check dob and if newborn, default "married last year" to be no
"RTN","DGDEP3",165,0)
 N DOB,NOW
"RTN","DGDEP3",166,0)
 S XY=""
"RTN","DGDEP3",167,0)
 S DOB=$P(^DPT(DFN,0),"^",3)
"RTN","DGDEP3",168,0)
 D NOW^%DTC S NOW=X
"RTN","DGDEP3",169,0)
 I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q  ;patient not a newborn
"RTN","DGDEP3",170,0)
 S XY=$O(^DGMT(408.22,"B",DFN,XY))
"RTN","DGDEP3",171,0)
 S $P(^DGMT(408.22,XY,0),"^",5)=0
"RTN","DGDEP3",172,0)
 Q
"RTN","DGMTSCC")
0^5^B36202206
"RTN","DGMTSCC",1,0)
DGMTSCC ;ALB/RMO,CAW,LBD,EG,LMD - Means Test Screen Completion ;03/24/2006
"RTN","DGMTSCC",2,0)
 ;;5.3;Registration;**33,45,130,438,332,433,462,456,610,624,611,890**;Aug 13, 1993;Build 40
"RTN","DGMTSCC",3,0)
 ;
"RTN","DGMTSCC",4,0)
 ; Input  -- DFN      Patient IEN
"RTN","DGMTSCC",5,0)
 ;           DGMTACT  Means Test Action
"RTN","DGMTSCC",6,0)
 ;           DGMTDT   Date of Test
"RTN","DGMTSCC",7,0)
 ;           DGMTYPT  Type of Test 1=MT 2=COPAY
"RTN","DGMTSCC",8,0)
 ;           DGMTPAR  Annual Means Test Parameters
"RTN","DGMTSCC",9,0)
 ;           DGVINI   Veteran Individual Annual Income IEN
"RTN","DGMTSCC",10,0)
 ;           DGVIRI   Veteran Income Relation IEN
"RTN","DGMTSCC",11,0)
 ;           DGVPRI   Veteran Patient Relation IEN
"RTN","DGMTSCC",12,0)
 ;           DGMTNWC  Net Worth Calculation flag
"RTN","DGMTSCC",13,0)
 ; Output -- DGERR    1=INCOMPLETE and 0=COMPLETE
"RTN","DGMTSCC",14,0)
 ;
"RTN","DGMTSCC",15,0)
EN N DGCAT,DGCOMF,DGDC,DGDET,DGIN0,DGIN1,DGIN2,DGINT,DGINTF,DGMTS,DGNC,DGND,DGNWT,DGNWTF,DGREF1,DGSP,DGTYC,DGTHA,DGTHB,DGVIR0,DGCOPS,DGCOST,DGTHG
"RTN","DGMTSCC",16,0)
 S DGERR=0
"RTN","DGMTSCC",17,0)
 I DGMTACT="ADD" D COM I 'Y!($D(DTOUT))!($D(DUOUT)) G Q
"RTN","DGMTSCC",18,0)
 S DGCOMF=1 D DEP^DGMTSCU2,INC^DGMTSCU3
"RTN","DGMTSCC",19,0)
 ;if ANSPFIN="Y" user already answered to provide financial information (module DISC^DGMTSC)
"RTN","DGMTSCC",20,0)
 I $G(ANSPFIN)="Y",$D(DGREF) D
"RTN","DGMTSCC",21,0)
 . S (DGINTF,DGNWTF)=""
"RTN","DGMTSCC",22,0)
 . W !,"DECLINES TO GIVE INCOME INFORMATION: YES"
"RTN","DGMTSCC",23,0)
 . S DGREF1=""
"RTN","DGMTSCC",24,0)
 . Q
"RTN","DGMTSCC",25,0)
 I ($G(DGINTF)=0),($G(DGNWTF)=0) S DGREF1="" D REF G Q:$D(DTOUT)!($D(DUOUT))
"RTN","DGMTSCC",26,0)
 D CAT^DGMTSCU2,STA^DGMTSCU2
"RTN","DGMTSCC",27,0)
 ;don't try to run validation checks if declining to provide financial information
"RTN","DGMTSCC",28,0)
 I '$D(DGREF) D CHK I DGERR W !?3,*7,$S(DGMTYPT=1:"Means",1:"Copay")_" test cannot be completed." G Q
"RTN","DGMTSCC",29,0)
 I DGMTYPT=1,DGTYC="M",(DGNWT-DGDET)+$S(DGMTNWC:0,1:DGINT)'<$P(DGMTPAR,"^",8) D ADJ G Q:$D(DTOUT)!($D(DUOUT))
"RTN","DGMTSCC",30,0)
 I DGMTYPT=2,DGCAT="P" D ADJ G Q:$D(DTOUT)!($D(DUOUT))
"RTN","DGMTSCC",31,0)
 S DA=DGMTI,DIE="^DGMT(408.31,",DIE("NO^")="",DR="[DGMT ENTER/EDIT COMPLETION]" D ^DIE K DA,DIE,DR I '$D(DGFIN) S DGERR=1 G Q
"RTN","DGMTSCC",32,0)
 I DGMTACT="EDT",DGMTDT>DT D
"RTN","DGMTSCC",33,0)
 . N DATA S (DATA(.01),DATA(.07))=DT,DATA(2)=1 I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
"RTN","DGMTSCC",34,0)
 W:DGMTYPT=1 !?3,"...means test status is ",$P($$MTS^DGMTU(DFN,DGMTS),"^"),"..."
"RTN","DGMTSCC",35,0)
 W:DGMTYPT=2 !?3,"...copay test status is ",$S(DGCAT="E":"EXEMPT",DGCAT="M":"NON-EXEMPT",DGCAT="P":"PENDING ADJUDICATION",1:"INCOMPLETE"),"..."
"RTN","DGMTSCC",36,0)
 D PRT
"RTN","DGMTSCC",37,0)
 ;
"RTN","DGMTSCC",38,0)
Q K DGFIN,DTOUT,DUOUT,Y
"RTN","DGMTSCC",39,0)
 Q
"RTN","DGMTSCC",40,0)
 ;
"RTN","DGMTSCC",41,0)
COM ;Check if user wants to complete the means test
"RTN","DGMTSCC",42,0)
 N DIR
"RTN","DGMTSCC",43,0)
 S DIR("A")="Do you wish to complete the "_$S(DGMTYPT=1:"means",1:"copay exemption")_" test"
"RTN","DGMTSCC",44,0)
 S DIR("B")="YES",DIR(0)="Y" D ^DIR
"RTN","DGMTSCC",45,0)
 ; The following was added for LTC Copay Phase II (DG*5.3*433)
"RTN","DGMTSCC",46,0)
 I DGMTYPT=4,'Y D
"RTN","DGMTSCC",47,0)
 . W !,"NOTE: If you do not complete the LTC copay exemption test, the incomplete test",!?6,"will be deleted."
"RTN","DGMTSCC",48,0)
 . S DIR("A")="Do you wish to complete the copay exemption test"
"RTN","DGMTSCC",49,0)
 . S DIR("B")="YES",DIR(0)="Y" D ^DIR
"RTN","DGMTSCC",50,0)
 Q
"RTN","DGMTSCC",51,0)
 ;
"RTN","DGMTSCC",52,0)
REF ;Check if patient declines to provide income information
"RTN","DGMTSCC",53,0)
 ;ANSPFIN      Y - user already answer this question (see program DGMTSC)       
"RTN","DGMTSCC",54,0)
 N DIR,Y,U
"RTN","DGMTSCC",55,0)
 S U="^"
"RTN","DGMTSCC",56,0)
 S DIR("A")="DECLINES TO GIVE INCOME INFORMATION"
"RTN","DGMTSCC",57,0)
 I $P($G(^DGMT(408.31,DGMTI,0)),"^",14)]"" S DIR("B")=$$YN^DGMTSCU1($P(^(0),"^",14))
"RTN","DGMTSCC",58,0)
 I '$D(DIR("B")),$G(ANSPFIN)'="Y" S DIR("B")="NO"
"RTN","DGMTSCC",59,0)
 ;user answered Y to provide income initially, but didn't provide income information
"RTN","DGMTSCC",60,0)
 I $G(ANSPFIN)="Y" S DIR("B")="YES"
"RTN","DGMTSCC",61,0)
 I $G(DGINTF)=0,$G(DGNWTF)=0 S DIR("B")="YES"
"RTN","DGMTSCC",62,0)
 S DIR(0)="408.31,.14" D ^DIR K DIR G REFQ:$D(DTOUT)!($D(DUOUT))
"RTN","DGMTSCC",63,0)
 S:Y DGREF="" Q:'$D(DGREF)!($D(DGREF1))!(DGMTYPT'=1)  S DGCAT="C" D STA^DGMTSCU2
"RTN","DGMTSCC",64,0)
 S ANSPFIN="Y"
"RTN","DGMTSCC",65,0)
REFQ Q
"RTN","DGMTSCC",66,0)
 ;
"RTN","DGMTSCC",67,0)
CHK ;Check if means test can be completed
"RTN","DGMTSCC",68,0)
 N DGA,DGD,DGDEP,DGREL,DGL,DGM,I
"RTN","DGMTSCC",69,0)
 D GETREL^DGMTU11(DFN,"CS",$$LYR^DGMTSCU1(DGMTDT),$S($G(DGMTI):DGMTI,1:""))
"RTN","DGMTSCC",70,0)
 S DGM=$P(DGVIR0,"^",5),DGL=$P(DGVIR0,"^",6),DGA=$P(DGVIR0,"^",20),DGD=$P(DGVIR0,"^",8)   ;DG*5.3*890
"RTN","DGMTSCC",71,0)
 I DGM']""!(DGM&(DGL']""))!(DGM&('DGL)&(DGA']"")) W !?3,"Marital section must be completed." S DGERR=1
"RTN","DGMTSCC",72,0)
 I DGM,'$D(DGREL("S")),'$D(DGREF) W !?3,"Married is 'YES'.  An active spouse for this means test does not exist." S DGERR=1
"RTN","DGMTSCC",73,0)
 I 'DGM,$D(DGREL("S")) W !?3,"An active spouse exists for this means test. Married should be 'YES'." S DGERR=1
"RTN","DGMTSCC",74,0)
 I DGD']"" W !?3,"Dependent Children section must be completed." S DGERR=1
"RTN","DGMTSCC",75,0)
 I DGD,'$D(DGREL("C")) W !?3,"Dependent Children is 'YES'.  No active children exist." S DGERR=1
"RTN","DGMTSCC",76,0)
 I 'DGD,$D(DGREL("C")) W !?3,"Active children exist.  Dependent Children should be 'YES'." S DGERR=1
"RTN","DGMTSCC",77,0)
 I DGMTYPT=1,'$D(DGREF),DGTYC="M",'DGNWTF W !?3,"A status of ",$$GETNAME^DGMTH(DGMTS)," requires property information." S DGERR=1
"RTN","DGMTSCC",78,0)
 I DGMTYPT=2,'DGNWTF,DGCAT="E",$$ASKNW^DGMTCOU W !?3,"Patient is in an 'EXEMPT' status and requires property information." S DGERR=1
"RTN","DGMTSCC",79,0)
 I DGDET>DGINT W !?3,"Patient's deductible expenses cannot exceed income." S DGERR=1
"RTN","DGMTSCC",80,0)
 Q:$G(DGERR)
"RTN","DGMTSCC",81,0)
 N CNT,ACT,DGDEP,FLAG,DGINCP
"RTN","DGMTSCC",82,0)
 D INIT^DGDEP S CNT=0 D
"RTN","DGMTSCC",83,0)
 . F  S CNT=$O(DGDEP(CNT)) Q:'CNT  I $P(DGDEP(CNT),U,2)="SPOUSE" D  Q:$G(DGERR)
"RTN","DGMTSCC",84,0)
 . . D GETIENS^DGMTU2(DFN,$P(DGDEP(CNT),U,20),DGMTDT)
"RTN","DGMTSCC",85,0)
 . . S DGINCP=$G(^DGMT(408.22,+DGIRI,"MT")) S:DGINCP FLAG=$G(FLAG)+1
"RTN","DGMTSCC",86,0)
 . . I $G(FLAG)>1 W !?3,"Patient has more than one spouse for this means test." S DGERR=1
"RTN","DGMTSCC",87,0)
 Q
"RTN","DGMTSCC",88,0)
 ;
"RTN","DGMTSCC",89,0)
ADJ ;Adjudicate the means test
"RTN","DGMTSCC",90,0)
 N DIR,Y
"RTN","DGMTSCC",91,0)
 S DIR("?",1)="Since assets exceed the threshold, the "_$S(DGMTYPT=1:"means",1:"copay")_" test can"
"RTN","DGMTSCC",92,0)
 S DIR("?",2)="be sent to adjudication.  If the "_$S(DGMTYPT=1:"means",1:"copay")_" test is not"
"RTN","DGMTSCC",93,0)
 S DIR("?")="adjudicated, the patient will be placed in "_$S(DGMTYPT=1&(DGTHG>DGTHA):"GMT Copay Required",DGMTYPT=1:"MT Copay Required",1:"Non-exempt")_" status."
"RTN","DGMTSCC",94,0)
 S DIR("A")="Do you wish to send this case to adjudication"
"RTN","DGMTSCC",95,0)
 S DIR("B")="YES",DIR(0)="Y" D ^DIR G ADJQ:$D(DTOUT)!($D(DUOUT))
"RTN","DGMTSCC",96,0)
 S DGCAT=$S(Y:"P",DGMTYPT=1&(DGTHG>DGTHA):"G",DGMTYPT=1:"C",1:"N") D STA^DGMTSCU2
"RTN","DGMTSCC",97,0)
ADJQ Q
"RTN","DGMTSCC",98,0)
 ;
"RTN","DGMTSCC",99,0)
 ;DG*5.3*624 - REMOVE 10-10F AND REPLACE WITH 10-10EZ/EZR
"RTN","DGMTSCC",100,0)
PRT ;Print the 10-10EZR or 10-10EZ
"RTN","DGMTSCC",101,0)
 N EZFLAG
"RTN","DGMTSCC",102,0)
 I $D(DGFINOP) DO
"RTN","DGMTSCC",103,0)
 .W !!,"Options for printing financial assessment information will follow."
"RTN","DGMTSCC",104,0)
 .W !,"Generally, you should answer 'YES' to 'PRINT 10-10EZR?' after updating"
"RTN","DGMTSCC",105,0)
 .W !,"patient demographic or financial information.  Answer 'YES' to 'PRINT"
"RTN","DGMTSCC",106,0)
 .W !,"10-10EZ?' after entering new patient demographic and financial information."
"RTN","DGMTSCC",107,0)
 S EZFLAG=$$SEL1010^DG1010P("EZR/EZ")
"RTN","DGMTSCC",108,0)
 Q:(EZFLAG=-1)
"RTN","DGMTSCC",109,0)
 D QUE
"RTN","DGMTSCC",110,0)
 ;
"RTN","DGMTSCC",111,0)
PRTQ Q
"RTN","DGMTSCC",112,0)
 ;
"RTN","DGMTSCC",113,0)
 ;DG*5.3*624 - REMOVE 10-10F AND REPLACE WITH 10-10EZ/EZR
"RTN","DGMTSCC",114,0)
QUE ;
"RTN","DGMTSCC",115,0)
 N X
"RTN","DGMTSCC",116,0)
 I $G(EZFLAG)="EZ" S X=$$ENEZ^EASEZPDG(DFN,DGMTI)
"RTN","DGMTSCC",117,0)
 I $G(EZFLAG)="EZR" S X=$$ENEZR^EASEZPDG(DFN,DGMTI)
"RTN","DGMTSCC",118,0)
 Q
"RTN","DGMTSCU2")
0^6^B12374485
"RTN","DGMTSCU2",1,0)
DGMTSCU2 ;ALB/RMO,CAW,LBD,CKN,LMD - Means Test Screen Variable Utilities ;6 FEB 1992 7:45 am
"RTN","DGMTSCU2",2,0)
 ;;5.3;Registration;**45,130,433,460,456,490,890**;Aug 13, 1993;Build 40
"RTN","DGMTSCU2",3,0)
 ;
"RTN","DGMTSCU2",4,0)
SET ;Set required means test variables
"RTN","DGMTSCU2",5,0)
 ; Input  -- DFN      Patient file IEN
"RTN","DGMTSCU2",6,0)
 ;           DGMTDT   Date of Test
"RTN","DGMTSCU2",7,0)
 ;           DGMTYPT  Type of Test 1=MT 2=COPAY
"RTN","DGMTSCU2",8,0)
 ;           DGMTI    Annual Means Test IEN
"RTN","DGMTSCU2",9,0)
 ;           DGMTPAR  Annual Means Test Parameters
"RTN","DGMTSCU2",10,0)
 ;           DGVIRI   Veteran Income Relation IEN
"RTN","DGMTSCU2",11,0)
 ;           DGVINI   Veteran Individual Annual Income IEN
"RTN","DGMTSCU2",12,0)
 ; Output -- All output variables in tags DEP, INC^DGMTSCU3, CAT and STA
"RTN","DGMTSCU2",13,0)
 D DEP,INC^DGMTSCU3,CAT,STA
"RTN","DGMTSCU2",14,0)
 Q
"RTN","DGMTSCU2",15,0)
 ;
"RTN","DGMTSCU2",16,0)
DEP ;Determine dependent data
"RTN","DGMTSCU2",17,0)
 ; Input  -- DFN     Patient file IEN
"RTN","DGMTSCU2",18,0)
 ;           DGMTDT  Date of Test
"RTN","DGMTSCU2",19,0)
 ;           DGVIRI  Veteran Income Relation IEN
"RTN","DGMTSCU2",20,0)
 ; Output -- DGVIR0  Veteran Income Relation 0th node
"RTN","DGMTSCU2",21,0)
 ;           DGSP    Spouse 1=YES and 0=NO (mt income)
"RTN","DGMTSCU2",22,0)
 ;           DGDC    Dependent children 1=YES and 0=NO (mt income)
"RTN","DGMTSCU2",23,0)
 ;           DGNC    Number of dependent children
"RTN","DGMTSCU2",24,0)
 ;           DGND    Total number of dependents
"RTN","DGMTSCU2",25,0)
 N DGCNT,DGDEP,DGINR,DGREL,Y
"RTN","DGMTSCU2",26,0)
 S DGVIR0=$G(^DGMT(408.22,DGVIRI,0)) D ALL^DGMTU21(DFN,"SC",DGMTDT,"PR",$S($G(DGMTI):DGMTI,1:""))
"RTN","DGMTSCU2",27,0)
 S DGSP=$S('$P(DGVIR0,"^",5)!('$G(DGREL("S"))):0,$P(DGVIR0,"^",6):1,$P(DGVIR0,"^",20)=1:1,1:0)   ;DG*5.3*890 Field change to a Y/N response
"RTN","DGMTSCU2",28,0)
 S DGDC=+$P(DGVIR0,"^",8) I DGDC S (DGDC,DGCNT)=0 F  S DGCNT=$O(DGINR("C",DGCNT)) Q:'DGCNT!(DGDC)  D CHK S:Y DGDC=1
"RTN","DGMTSCU2",29,0)
 S DGNC=+$P(DGVIR0,"^",13)
"RTN","DGMTSCU2",30,0)
 S DGND=DGSP+DGNC
"RTN","DGMTSCU2",31,0)
 Q
"RTN","DGMTSCU2",32,0)
 ;
"RTN","DGMTSCU2",33,0)
CHK ;Check if child has income which is available to the veteran
"RTN","DGMTSCU2",34,0)
 S Y=0
"RTN","DGMTSCU2",35,0)
 I $D(^DGMT(408.22,+$G(DGINR("C",DGCNT)),0)),$P(^(0),"^",11),$P(^(0),"^",12) S Y=1
"RTN","DGMTSCU2",36,0)
 Q
"RTN","DGMTSCU2",37,0)
 ;
"RTN","DGMTSCU2",38,0)
CAT ;Determine means test thresholds and category
"RTN","DGMTSCU2",39,0)
 ; Input  -- DGMTDT   Date of Test
"RTN","DGMTSCU2",40,0)
 ;           DGND     Total number of dependents
"RTN","DGMTSCU2",41,0)
 ;           DGINT    Total income
"RTN","DGMTSCU2",42,0)
 ;           DGDET    Total deductible expenses
"RTN","DGMTSCU2",43,0)
 ;           DGMTPAR  Annual Means Test Parameters
"RTN","DGMTSCU2",44,0)
 ;           DGMTGMT  GMT Thresholds
"RTN","DGMTSCU2",45,0)
 ; Output -- DGTHA    MT threshold
"RTN","DGMTSCU2",46,0)
 ;           DGTHB    Category B threshold (NO LONGER USED)
"RTN","DGMTSCU2",47,0)
 ;           DGTHG    GMT threshold
"RTN","DGMTSCU2",48,0)
 ;           DGCAT    Means/Copay test category code
"RTN","DGMTSCU2",49,0)
 N DGCOST,DGCOPS,PCT S DGCAT=""
"RTN","DGMTSCU2",50,0)
 ;  Added for LTC Copay Phase II - DG*5.3*433
"RTN","DGMTSCU2",51,0)
 I DGMTYPT=4 D  Q
"RTN","DGMTSCU2",52,0)
 .N Y S DGTHA=""
"RTN","DGMTSCU2",53,0)
 .I $D(DGREF1),$D(DGREF) S DGCAT=1 Q  ;Vet declined to give income info
"RTN","DGMTSCU2",54,0)
 .S Y=$$THRES^EASECMT(DFN,DGMTDT) Q:Y=-1
"RTN","DGMTSCU2",55,0)
 .S DGCAT=$S(Y:0,1:1)
"RTN","DGMTSCU2",56,0)
 I $$ACT^DGMTDD(4,DGMTDT) S DGTHA=$P(DGMTPAR,"^",2)+$S(DGND:$P(DGMTPAR,"^",3),1:0)+$S((DGND-1)>0:($P(DGMTPAR,"^",4)*(DGND-1)),1:0) S:(DGINT-DGDET)'>DGTHA DGCAT="A"
"RTN","DGMTSCU2",57,0)
 I $$ACT^DGMTDD(5,DGMTDT) S DGTHB=$P(DGMTPAR,"^",5)+$S(DGND:$P(DGMTPAR,"^",6),1:0)+$S((DGND-1)>0:($P(DGMTPAR,"^",7)*(DGND-1)),1:0) I DGCAT']"",(DGINT-DGDET)'>DGTHB S DGCAT="B"
"RTN","DGMTSCU2",58,0)
 ; Determine the GMT Threshold
"RTN","DGMTSCU2",59,0)
 ; The DGMTGMT variable stores the GMT Thresholds for households of
"RTN","DGMTSCU2",60,0)
 ; 1-8 persons.  If a household (veteran + dependents) has more than 8
"RTN","DGMTSCU2",61,0)
 ; the GMT Threshold will be calculated.  For each person in excess of
"RTN","DGMTSCU2",62,0)
 ; 8, 8% of the base (4-person household) will be added to the 8-person 
"RTN","DGMTSCU2",63,0)
 ; income limit.  Income limits are rounded to the next $50.
"RTN","DGMTSCU2",64,0)
 S DGTHG=""
"RTN","DGMTSCU2",65,0)
 I $$ACT^DGMTDD(16,DGMTDT) D
"RTN","DGMTSCU2",66,0)
 .I '$G(DGMTGMT) S DGTHG=0 Q
"RTN","DGMTSCU2",67,0)
 .;If GMT Threshold already calculated, don't recalculate
"RTN","DGMTSCU2",68,0)
 .S DGTHG="" I $G(DGMTI) S DGTHG=$P($G(^DGMT(408.31,DGMTI,0)),"^",27)
"RTN","DGMTSCU2",69,0)
 .I 'DGTHG D
"RTN","DGMTSCU2",70,0)
 ..I DGND+1<9 S DGTHG=$P(DGMTGMT,"^",(DGND+1))
"RTN","DGMTSCU2",71,0)
 ..E  S PCT=((DGND+1)-8)*8+132/100,DGTHG=$P(DGMTGMT,"^",4)*PCT,DGTHG=$S(DGTHG#50=0:DGTHG,1:DGTHG+(50-(DGTHG#50)))
"RTN","DGMTSCU2",72,0)
 .I DGTHG<DGTHA Q
"RTN","DGMTSCU2",73,0)
 .I DGCAT="",(DGINT-DGDET)'>DGTHG S DGCAT="G"
"RTN","DGMTSCU2",74,0)
 I DGCAT="",$$ACT^DGMTDD(6,DGMTDT) S DGCAT="C"
"RTN","DGMTSCU2",75,0)
 I $D(DGREF),DGMTYPT=1,$D(DGREF1) S DGCAT="C"
"RTN","DGMTSCU2",76,0)
 I DGMTYPT=2 D
"RTN","DGMTSCU2",77,0)
 .S DGCOST=DGMTDT_U_DFN_U_U_DGINT_U_DGNWT,$P(DGCOST,U,14)=$S($D(DGREF):1,1:0),$P(DGCOST,U,15)=DGDET,$P(DGCOST,U,18)=DGND,$P(DGCOST,U,19)=2
"RTN","DGMTSCU2",78,0)
 .S DGCOPS=$$INCDT^IBARXEU1(DGCOST)
"RTN","DGMTSCU2",79,0)
 .S DGCAT=$S(+DGCOPS=1:"E",+DGCOPS=2:"M",+DGCOPS=3:"P",1:"I")
"RTN","DGMTSCU2",80,0)
 .S (DGTHA,DGTHB)=""
"RTN","DGMTSCU2",81,0)
 Q
"RTN","DGMTSCU2",82,0)
 ;
"RTN","DGMTSCU2",83,0)
STA ;Determine means test status and type of care
"RTN","DGMTSCU2",84,0)
 ; Input  -- DGCAT   Means test category code
"RTN","DGMTSCU2",85,0)
 ;           DGMTYPT Type of Test 1=MT 2=COPAY
"RTN","DGMTSCU2",86,0)
 ; Output -- DGMTS   Means test status IEN
"RTN","DGMTSCU2",87,0)
 ;           DGTYC   Type of care
"RTN","DGMTSCU2",88,0)
 S DGMTS=+$O(^DG(408.32,"AC",DGMTYPT,DGCAT,0))
"RTN","DGMTSCU2",89,0)
 S DGTYC=$P($G(^DG(408.32,DGMTS,0)),"^",3)
"RTN","DGMTSCU2",90,0)
 Q
"RTN","DGMTUTL2")
0^8^B25559255
"RTN","DGMTUTL2",1,0)
DGMTUTL2 ;ALB/RMM,TGH - Means Test Consistency Checker ; 04/28/2005
"RTN","DGMTUTL2",2,0)
 ;;5.3;Registration;**463,655,890**;Aug 13, 1993;Build 40
"RTN","DGMTUTL2",3,0)
 ;
"RTN","DGMTUTL2",4,0)
 ; This routine sets the data strings used in the Income Test
"RTN","DGMTUTL2",5,0)
 ; Inconsistency Checks.
"RTN","DGMTUTL2",6,0)
 Q
"RTN","DGMTUTL2",7,0)
 ;
"RTN","DGMTUTL2",8,0)
ZIC(VAFIEN,DEPIEN) ; Build ZIC the data string for the veteran
"RTN","DGMTUTL2",9,0)
 ;
"RTN","DGMTUTL2",10,0)
 N NODE0,NODE1,NODE2,ZIC
"RTN","DGMTUTL2",11,0)
 S NODE0=$G(^DGMT(408.21,VAFIEN,0))
"RTN","DGMTUTL2",12,0)
 S NODE1=$G(^DGMT(408.21,VAFIEN,1))
"RTN","DGMTUTL2",13,0)
 S NODE2=$G(^DGMT(408.21,VAFIEN,2))
"RTN","DGMTUTL2",14,0)
 S ZIC="ZIC"
"RTN","DGMTUTL2",15,0)
 S $P(ZIC,U,2)=$P(NODE0,U,1)         ;Income Year
"RTN","DGMTUTL2",16,0)
 S $P(ZIC,U,3)=$P(NODE0,U,8)         ;Social Security
"RTN","DGMTUTL2",17,0)
 S $P(ZIC,U,4)=$P(NODE0,U,9)         ;U.S. Civil Service
"RTN","DGMTUTL2",18,0)
 S $P(ZIC,U,5)=$P(NODE0,U,10)        ;U.S. Railroad Retirement
"RTN","DGMTUTL2",19,0)
 S $P(ZIC,U,6)=$P(NODE0,U,11)        ;Military Retirement
"RTN","DGMTUTL2",20,0)
 S $P(ZIC,U,7)=$P(NODE0,U,12)        ;Unemployment Compensation
"RTN","DGMTUTL2",21,0)
 S $P(ZIC,U,9)=$P(NODE0,U,14)        ;Total Income from Employment
"RTN","DGMTUTL2",22,0)
 S $P(ZIC,U,10)=$P(NODE0,U,15)       ;Interest,Dividend,Annuity
"RTN","DGMTUTL2",23,0)
 S $P(ZIC,U,11)=$P(NODE0,U,16)       ;Workers Comp. or Black Lung
"RTN","DGMTUTL2",24,0)
 S $P(ZIC,U,12)=$P(NODE0,U,17)       ;All Other Income
"RTN","DGMTUTL2",25,0)
 S $P(ZIC,U,13)=$P(NODE1,U,1)        ;Medical Expenses
"RTN","DGMTUTL2",26,0)
 S $P(ZIC,U,14)=$P(NODE1,U,2)        ;Funeral And Burial Expenses
"RTN","DGMTUTL2",27,0)
 S $P(ZIC,U,15)=$P(NODE1,U,3)        ;Educational Expenses
"RTN","DGMTUTL2",28,0)
 S $P(ZIC,U,16)=$P(NODE2,U,1)        ;Cash, Amount In Bank Accounts
"RTN","DGMTUTL2",29,0)
 S $P(ZIC,U,17)=$P(NODE2,U,2)        ;Stocks And Bonds
"RTN","DGMTUTL2",30,0)
 S $P(ZIC,U,18)=$P(NODE2,U,3)        ;Real Property
"RTN","DGMTUTL2",31,0)
 S $P(ZIC,U,19)=$P(NODE2,U,4)        ;Other Property or Assets
"RTN","DGMTUTL2",32,0)
 S $P(ZIC,U,20)=$P(NODE2,U,5)        ;Debts
"RTN","DGMTUTL2",33,0)
 ;
"RTN","DGMTUTL2",34,0)
 ; Adjust date field to correct format
"RTN","DGMTUTL2",35,0)
 S $P(ZIC,U,2)=$E($P(ZIC,U,2),1,3)+1700_$E($P(ZIC,U,2),4,7)
"RTN","DGMTUTL2",36,0)
 ;
"RTN","DGMTUTL2",37,0)
 Q ZIC
"RTN","DGMTUTL2",38,0)
 ;
"RTN","DGMTUTL2",39,0)
ZIR(VAFIEN,DEPIEN) ; Build ZIR the data string for the veteran
"RTN","DGMTUTL2",40,0)
 N NODE0,ZIR
"RTN","DGMTUTL2",41,0)
 S NODE0=$G(^DGMT(408.22,VAFIEN,0)),ZIR="ZIR"
"RTN","DGMTUTL2",42,0)
 S $P(ZIR,U,2)=$P(NODE0,U,5)         ;Married Last Year
"RTN","DGMTUTL2",43,0)
 S $P(ZIR,U,3)=$P(NODE0,U,6)         ;Lived With Patient
"RTN","DGMTUTL2",44,0)
 S $P(ZIR,U,4)=$P(NODE0,U,7)         ;Amount Contributed to Spouse
"RTN","DGMTUTL2",45,0)
 S $P(ZIR,U,8)=$P(NODE0,U,11)        ;Child Had Income
"RTN","DGMTUTL2",46,0)
 S $P(ZIR,U,9)=$P(NODE0,U,12)        ;Income Available to You
"RTN","DGMTUTL2",47,0)
 S $P(ZIR,U,15)=$P(NODE0,U,20)       ;Contributed to Spouse DG*5.3*890
"RTN","DGMTUTL2",48,0)
 Q ZIR
"RTN","DGMTUTL2",49,0)
 ;
"RTN","DGMTUTL2",50,0)
ZMT(DGMTI) ; Build ZMT the data string for the veteran
"RTN","DGMTUTL2",51,0)
 ;
"RTN","DGMTUTL2",52,0)
 N NODE0,NODE2,ZMT
"RTN","DGMTUTL2",53,0)
 S NODE0=$G(^DGMT(408.31,DGMTI,0))
"RTN","DGMTUTL2",54,0)
 S NODE2=$G(^DGMT(408.31,DGMTI,2)),ZMT="ZMT"
"RTN","DGMTUTL2",55,0)
 S $P(ZMT,U,2)=$P(NODE0,U,1)         ;Means Test Date
"RTN","DGMTUTL2",56,0)
 S $P(ZMT,U,3)=$P(NODE0,U,3)         ;Means Test Status
"RTN","DGMTUTL2",57,0)
 S $P(ZMT,U,4)=$P(NODE0,U,4)         ;Income
"RTN","DGMTUTL2",58,0)
 S $P(ZMT,U,5)=$P(NODE0,U,5)         ;Net Worth
"RTN","DGMTUTL2",59,0)
 S $P(ZMT,U,6)=$P(NODE0,U,10)        ;Date/Time of Adjudication
"RTN","DGMTUTL2",60,0)
 S $P(ZMT,U,7)=$P(NODE0,U,11)        ;Agreed to Pay Deductible
"RTN","DGMTUTL2",61,0)
 S $P(ZMT,U,8)=$P(NODE0,U,12)        ;Threshold A
"RTN","DGMTUTL2",62,0)
 S $P(ZMT,U,9)=$P(NODE0,U,15)        ;Deductible Expenses
"RTN","DGMTUTL2",63,0)
 S $P(ZMT,U,10)=$P(NODE0,U,7)        ;Date/Time MT Completed
"RTN","DGMTUTL2",64,0)
 S $P(ZMT,U,11)=$P(NODE0,U,16)       ;Previous Yr MT Threshold Flag
"RTN","DGMTUTL2",65,0)
 S $P(ZMT,U,12)=$P(NODE0,U,18)       ;Total Dependents
"RTN","DGMTUTL2",66,0)
 S $P(ZMT,U,13)=$P(NODE0,U,20)       ;Hardship
"RTN","DGMTUTL2",67,0)
 S $P(ZMT,U,14)=$P(NODE0,U,21)       ;Hardship Review Date
"RTN","DGMTUTL2",68,0)
 S $P(ZMT,U,15)=$P(NODE0,U,24)       ;Date Veteran Signed Test
"RTN","DGMTUTL2",69,0)
 S $P(ZMT,U,16)=$P(NODE0,U,14)       ;Declines to Give Income Info
"RTN","DGMTUTL2",70,0)
 S $P(ZMT,U,17)=$P(NODE0,U,19)       ;Type of Test
"RTN","DGMTUTL2",71,0)
 S $P(ZMT,U,18)=$P(NODE0,U,23)       ;Source of Income Test
"RTN","DGMTUTL2",72,0)
 S $P(ZMT,U,19)=$P($G(^DGMT(408.31,DGMTI,"PRIM")),U,1)  ;Primary Test?
"RTN","DGMTUTL2",73,0)
 S $P(ZMT,U,20)=$P(NODE0,U,25)       ;Date IVM Verif. MT Completed
"RTN","DGMTUTL2",74,0)
 S $P(ZMT,U,21)=$P(NODE0,U,26)       ;Refused To Sign
"RTN","DGMTUTL2",75,0)
 S $P(ZMT,U,22)=$P(NODE2,U,5)        ;Site Conducting Test
"RTN","DGMTUTL2",76,0)
 S $P(ZMT,U,23)=$P(NODE2,U,4)        ;Hardship Review Site
"RTN","DGMTUTL2",77,0)
 S $P(ZMT,U,24)=$P(NODE2,U,1)        ;Hardship Effective Date
"RTN","DGMTUTL2",78,0)
 S $P(ZMT,U,25)=$P(NODE2,U,2)        ;Date/Time Test Last Edited
"RTN","DGMTUTL2",79,0)
 S $P(ZMT,U,26)=$P(NODE2,U,3)        ;Test Determined Status
"RTN","DGMTUTL2",80,0)
 S $P(ZMT,U,28)=$P(NODE0,U,27)       ;GMT Threshold
"RTN","DGMTUTL2",81,0)
 ;
"RTN","DGMTUTL2",82,0)
 ; Adjust date fields to correct format
"RTN","DGMTUTL2",83,0)
 S $P(ZMT,U,2)=$E($P(ZMT,U,2),1,3)+1700_$E($P(ZMT,U,2),4,7)
"RTN","DGMTUTL2",84,0)
 S $P(ZMT,U,10)=$E($P(ZMT,U,10),1,3)+1700_$E($P(ZMT,U,10),4,7)
"RTN","DGMTUTL2",85,0)
 S $P(ZMT,U,25)=$E($P(ZMT,U,25),1,3)+1700_$E($P(ZMT,U,25),4,7)_$P($P(ZMT,U,25),".",2)_"-400"
"RTN","DGMTUTL2",86,0)
 ;
"RTN","DGMTUTL2",87,0)
 ; Change Status IENs to Codes
"RTN","DGMTUTL2",88,0)
 S:$P(ZMT,U,26)="" $P(ZMT,U,26)=$P(ZMT,U,3)
"RTN","DGMTUTL2",89,0)
 S $P(ZMT,U,3)=$P(^DG(408.32,$P(ZMT,U,3),0),U,2)
"RTN","DGMTUTL2",90,0)
 S $P(ZMT,U,26)=$P(^DG(408.32,$P(ZMT,U,26),0),U,2)
"RTN","DGMTUTL2",91,0)
 ;
"RTN","DGMTUTL2",92,0)
 Q ZMT
"RTN","DGMTUTL2",93,0)
 ;
"RTN","DGMTUTL2",94,0)
ZDP(VAFIEN,DEPIEN) ; Build ZDP the data string for the veteran
"RTN","DGMTUTL2",95,0)
 ;
"RTN","DGMTUTL2",96,0)
 N NODE0,NODER,DGPR,ZDP,LIEN
"RTN","DGMTUTL2",97,0)
 S NODE0=$G(^DGPR(408.12,+VAFIEN,0)),ZDP="ZDP"
"RTN","DGMTUTL2",98,0)
 S DGPR=+$P(NODE0,U,3),NODER=^DGPR(408.13,DGPR,0)
"RTN","DGMTUTL2",99,0)
 S $P(ZDP,U,2)=$P(NODER,U,1)         ;Name
"RTN","DGMTUTL2",100,0)
 S $P(ZDP,U,3)=$P(NODER,U,2)         ;Sex
"RTN","DGMTUTL2",101,0)
 S $P(ZDP,U,4)=$P(NODER,U,3)         ;Date of Birth
"RTN","DGMTUTL2",102,0)
 S $P(ZDP,U,5)=$P(NODER,U,9)         ;Social Security Number
"RTN","DGMTUTL2",103,0)
 S $P(ZDP,U,6)=$P(NODE0,U,2)         ;Relationship To Patient
"RTN","DGMTUTL2",104,0)
 S $P(ZDP,U,7)=+VAFIEN               ;Internal Entry Number
"RTN","DGMTUTL2",105,0)
 S LIEN=$O(^DGPR(408.12,+VAFIEN,"E","AID"),-1)
"RTN","DGMTUTL2",106,0)
 S $P(ZDP,U,9)=+^DGPR(408.12,+VAFIEN,"E",LIEN,0)
"RTN","DGMTUTL2",107,0)
 ;
"RTN","DGMTUTL2",108,0)
 ; Change format to match CC format
"RTN","DGMTUTL2",109,0)
 S $P(ZDP,U,2)=$TR($P(ZDP,U,2),",","~")
"RTN","DGMTUTL2",110,0)
 S $P(ZDP,U,4)=$E($P(ZDP,U,4),1,3)+1700_$E($P(ZDP,U,4),4,7)
"RTN","DGMTUTL2",111,0)
 S $P(ZDP,U,9)=$E($P(ZDP,U,9),1,3)+1700_$E($P(ZDP,U,9),4,7)
"RTN","DGMTUTL2",112,0)
 ;
"RTN","DGMTUTL2",113,0)
 Q ZDP
"RTN","DGMTUTL2",114,0)
                                                                                
"RTN","VAFHLZIR")
0^4^B15600256
"RTN","VAFHLZIR",1,0)
VAFHLZIR ;ALB/SEK,TDM,MNH - Create generic HL7 ZIR segment ;6/3/10 9:43am
"RTN","VAFHLZIR",2,0)
 ;;5.3;Registration;**33,94,151,466,653,754,890**;Aug 13, 1993;Build 40
"RTN","VAFHLZIR",3,0)
 ;
"RTN","VAFHLZIR",4,0)
 ;
"RTN","VAFHLZIR",5,0)
EN(VAFIEN,VAFSTR,VAFNUM,VAFENC) ; This generic extrinsic function was designed to
"RTN","VAFHLZIR",6,0)
 ;          return the HL7 ZIR segment.  This segment contains
"RTN","VAFHLZIR",7,0)
 ;          VA-specific information pertaining to income relation type
"RTN","VAFHLZIR",8,0)
 ;          data for a veteran and any applicable relations.
"RTN","VAFHLZIR",9,0)
 ;
"RTN","VAFHLZIR",10,0)
 ;  Input - VAFIEN as internal entry number of the INCOME RELATION file.
"RTN","VAFHLZIR",11,0)
 ;          VAFSTR as the string of fields requested separated by commas.
"RTN","VAFHLZIR",12,0)
 ;          VAFNUM as the number desired for the SET ID (default = 1)
"RTN","VAFHLZIR",13,0)
 ;          VAFENC as Outpatient Encounter IEN (from file #409.68)
"RTN","VAFHLZIR",14,0)
 ;
"RTN","VAFHLZIR",15,0)
 ;  NOTE:   Input variable VAFENC was added as part of the Ambulatory
"RTN","VAFHLZIR",16,0)
 ;          Care Reporting project.
"RTN","VAFHLZIR",17,0)
 ;
"RTN","VAFHLZIR",18,0)
 ;     *****Also assumes all HL7 variables returned from*****
"RTN","VAFHLZIR",19,0)
 ;          INIT^HLTRANS are defined.
"RTN","VAFHLZIR",20,0)
 ;
"RTN","VAFHLZIR",21,0)
 ; Output - String of data forming the ZIR segment.
"RTN","VAFHLZIR",22,0)
 ;
"RTN","VAFHLZIR",23,0)
 ;
"RTN","VAFHLZIR",24,0)
 N VAFDFN,VAFERR,VAFENODE,VAFNODE,VAFY,X,RELTYP,DCHILD
"RTN","VAFHLZIR",25,0)
 I $G(VAFSTR)']"" G QUIT
"RTN","VAFHLZIR",26,0)
 S VAFENC=+$G(VAFENC)
"RTN","VAFHLZIR",27,0)
 I '$G(VAFIEN)&('VAFENC) G QUIT
"RTN","VAFHLZIR",28,0)
 S $P(VAFY,HLFS,14)="",VAFSTR=","_VAFSTR_","
"RTN","VAFHLZIR",29,0)
 S VAFNODE=$G(^DGMT(408.22,+$G(VAFIEN),0))
"RTN","VAFHLZIR",30,0)
 I $G(VAFNODE)']""&('VAFENC) G QUIT
"RTN","VAFHLZIR",31,0)
 S $P(VAFY,HLFS,1)=$S($G(VAFNUM):VAFNUM,1:1)
"RTN","VAFHLZIR",32,0)
 S RELTYP=+$P($G(^DGPR(408.12,+$P($G(^DGMT(408.21,+$P(VAFNODE,"^",2),0)),"^",2),0)),"^",2)
"RTN","VAFHLZIR",33,0)
 S DCHILD=$S(((RELTYP>2)&(RELTYP<7)):1,1:0)
"RTN","VAFHLZIR",34,0)
 I VAFSTR[",2," S $P(VAFY,HLFS,2)=$$YN^VAFHLFNC($P(VAFNODE,"^",5)) ; Married last calendar year
"RTN","VAFHLZIR",35,0)
 I VAFSTR[",3," S $P(VAFY,HLFS,3)=$$YN^VAFHLFNC($P(VAFNODE,"^",6)) ; Lived with patient
"RTN","VAFHLZIR",36,0)
 ;I VAFSTR[",4," S X=$P(VAFNODE,"^",7),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Amount contributed to spouse
"RTN","VAFHLZIR",37,0)
 I VAFSTR[",4," S X=$P(VAFNODE,"^",$S(DCHILD:19,1:7)),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Amount contributed to spouse/child
"RTN","VAFHLZIR",38,0)
 I VAFSTR[",5," S $P(VAFY,HLFS,5)=$$YN^VAFHLFNC($P(VAFNODE,"^",8)) ; Dependent children (y/n)
"RTN","VAFHLZIR",39,0)
 I VAFSTR[",6," S $P(VAFY,HLFS,6)=$$YN^VAFHLFNC($P(VAFNODE,"^",9)) ; Incapable of self-support
"RTN","VAFHLZIR",40,0)
 I VAFSTR[",7," S $P(VAFY,HLFS,7)=$$YN^VAFHLFNC($P(VAFNODE,"^",10)) ; Contributed to support
"RTN","VAFHLZIR",41,0)
 I VAFSTR[",8," S $P(VAFY,HLFS,8)=$$YN^VAFHLFNC($P(VAFNODE,"^",11)) ; Child had income
"RTN","VAFHLZIR",42,0)
 I VAFSTR[",9," S $P(VAFY,HLFS,9)=$$YN^VAFHLFNC($P(VAFNODE,"^",12)) ; Income available to you
"RTN","VAFHLZIR",43,0)
 I VAFSTR[",10," S X=$P(VAFNODE,"^",13),$P(VAFY,HLFS,10)=$S(X]"":X,1:HLQ) ; Number of dependent children
"RTN","VAFHLZIR",44,0)
 I VAFSTR[",15," S X=$P(VAFNODE,"^",20),$P(VAFY,HLFS,15)=$S(X]"":X,1:HLQ) ;Contribute spouse  DG*5.3*890
"RTN","VAFHLZIR",45,0)
 ;
"RTN","VAFHLZIR",46,0)
 ; ALB/ESD - Data elements 11,12,13 added as part of Ambulatory Care
"RTN","VAFHLZIR",47,0)
 ;           Reporting Project requirements.
"RTN","VAFHLZIR",48,0)
 ;
"RTN","VAFHLZIR",49,0)
 I VAFSTR[",11,"!(VAFSTR[",12,")!(VAFSTR[",13,") D
"RTN","VAFHLZIR",50,0)
 . ;
"RTN","VAFHLZIR",51,0)
 . ;- If no encounter pointer, encounter node or DFN elements 11 - 13 = HLQ
"RTN","VAFHLZIR",52,0)
 . I ('VAFENC) S VAFERR=1 Q
"RTN","VAFHLZIR",53,0)
 . S VAFENODE=$$SCE^DGSDU(VAFENC) I VAFENODE']"" S VAFERR=1 Q
"RTN","VAFHLZIR",54,0)
 . S VAFDFN=$P(VAFENODE,"^",2) S:VAFDFN="" VAFERR=1 Q
"RTN","VAFHLZIR",55,0)
 I VAFSTR[",11," S $P(VAFY,HLFS,11)=$S('$G(VAFERR):+$$DEP^VAFMON(VAFDFN,$P(VAFENODE,"^")),1:HLQ) ;Total Dependents
"RTN","VAFHLZIR",56,0)
 I VAFSTR[",12," S $P(VAFY,HLFS,12)=$S('$G(VAFERR):+$$INCOME^VAFMON(VAFDFN,$P(VAFENODE,"^")),1:HLQ) ;Patient Income
"RTN","VAFHLZIR",57,0)
 ;
"RTN","VAFHLZIR",58,0)
 ;- If outpatient encounter node exists, get appointment type &
"RTN","VAFHLZIR",59,0)
 ;  eligibility of encounter and make call to get means test indicator
"RTN","VAFHLZIR",60,0)
 I VAFSTR[",13," S $P(VAFY,HLFS,13)=$S('$G(VAFERR):$$MTI^SCDXUTL0(VAFDFN,$P(VAFENODE,"^"),$P(VAFENODE,"^",13),$P(VAFENODE,"^",10),VAFENC),1:HLQ) ;Means Test Indicator
"RTN","VAFHLZIR",61,0)
 ;
"RTN","VAFHLZIR",62,0)
 ;- If MT Indicator not = code AN, C, or G, change number of dependents
"RTN","VAFHLZIR",63,0)
 ;  to XX (not applicable)
"RTN","VAFHLZIR",64,0)
 I VAFSTR[",11," I '$G(VAFERR) D
"RTN","VAFHLZIR",65,0)
 . I $P(VAFY,HLFS,13)'="AN"&($P(VAFY,HLFS,13)'="C")&($P(VAFY,HLFS,13)'="G") S $P(VAFY,HLFS,11)="XX" ;Total Dependents not applicable for MT indicators AS,N,X,U
"RTN","VAFHLZIR",66,0)
 ;
"RTN","VAFHLZIR",67,0)
 I VAFSTR[",14," S X=$P(VAFNODE,"^",18),$P(VAFY,HLFS,14)=$S(X=0:"N",X=1:"Y",1:HLQ) ; Dependent child school indicator
"RTN","VAFHLZIR",68,0)
 ;
"RTN","VAFHLZIR",69,0)
QUIT Q "ZIR"_HLFS_$G(VAFY)
"VER")
8.0^22.0
"^DD",408.22,408.22,0)
FIELD^^.21^19
"^DD",408.22,408.22,0,"DDA")
N
"^DD",408.22,408.22,0,"DIK")
DGMTXX2
"^DD",408.22,408.22,0,"DIKOLD")
DGMTXX2
"^DD",408.22,408.22,0,"DT")
3140611
"^DD",408.22,408.22,0,"ID",.02)
W ""
"^DD",408.22,408.22,0,"ID","WRITE")
D ID^DGMTDD2
"^DD",408.22,408.22,0,"IX","AD",408.22,.21)

"^DD",408.22,408.22,0,"IX","AENR05",408.22,.05)

"^DD",408.22,408.22,0,"IX","AENR06",408.22,.06)

"^DD",408.22,408.22,0,"IX","AENR07",408.22,.07)

"^DD",408.22,408.22,0,"IX","AENR08",408.22,.08)

"^DD",408.22,408.22,0,"IX","AENR09",408.22,.09)

"^DD",408.22,408.22,0,"IX","AENR1",408.22,.1)

"^DD",408.22,408.22,0,"IX","AENR11",408.22,.11)

"^DD",408.22,408.22,0,"IX","AENR12",408.22,.12)

"^DD",408.22,408.22,0,"IX","AENR13",408.22,.13)

"^DD",408.22,408.22,0,"IX","AENR18",408.22,.18)

"^DD",408.22,408.22,0,"IX","AIND",408.22,.02)

"^DD",408.22,408.22,0,"IX","AIX",408.22,.21)

"^DD",408.22,408.22,0,"IX","AIX11",408.22,.11)

"^DD",408.22,408.22,0,"IX","AIX12",408.22,.12)

"^DD",408.22,408.22,0,"IX","AIX5",408.22,.05)

"^DD",408.22,408.22,0,"IX","AIX7",408.22,.07)

"^DD",408.22,408.22,0,"IX","AIX8",408.22,.08)

"^DD",408.22,408.22,0,"IX","AMT",408.22,31)

"^DD",408.22,408.22,0,"IX","AMT1",408.22,.01)

"^DD",408.22,408.22,0,"IX","AMT2",408.22,.02)

"^DD",408.22,408.22,0,"IX","B",408.22,.01)

"^DD",408.22,408.22,0,"NM","INCOME RELATION")

"^DD",408.22,408.22,.01,0)
PATIENT^RP2'^DPT(^0;1^Q
"^DD",408.22,408.22,.01,1,0)
^.1
"^DD",408.22,408.22,.01,1,1,0)
408.22^B
"^DD",408.22,408.22,.01,1,1,1)
S ^DGMT(408.22,"B",$E(X,1,30),DA)=""
"^DD",408.22,408.22,.01,1,1,2)
K ^DGMT(408.22,"B",$E(X,1,30),DA)
"^DD",408.22,408.22,.01,1,1,"%D",0)
^^1^1^2920326^
"^DD",408.22,408.22,.01,1,1,"%D",1,0)
This cross-reference allows look-up by patient.
"^DD",408.22,408.22,.01,1,2,0)
408.22^AMT1^MUMPS
"^DD",408.22,408.22,.01,1,2,1)
S:$P(^DGMT(408.22,DA,0),U,2)&($P($G(^DGMT(408.22,DA,"MT")),U)) ^DGMT(408.22,"AMT",$P(^DGMT(408.22,DA,"MT"),U),X,$P(^DGMT(408.22,DA,0),U,2),DA)=""
"^DD",408.22,408.22,.01,1,2,2)
K ^DGMT(408.22,"AMT",+$P($G(^DGMT(408.22,DA,"MT")),U),X,+$P(^DGMT(408.22,DA,0),U,2),DA)
"^DD",408.22,408.22,.01,1,2,"%D",0)
^^2^2^2980805^^^^
"^DD",408.22,408.22,.01,1,2,"%D",1,0)
This cross reference is for the means test. It is indexed by means test,
"^DD",408.22,408.22,.01,1,2,"%D",2,0)
patient, individual annual income pointer, IFN.
"^DD",408.22,408.22,.01,1,2,"DT")
2980805
"^DD",408.22,408.22,.01,3)
Enter in this field the patient associated with this income relation.
"^DD",408.22,408.22,.01,21,0)
^^1^1^2920323^
"^DD",408.22,408.22,.01,21,1,0)
Enter in this field the patient associated with this income relation.
"^DD",408.22,408.22,.01,"DT")
2980805
"^DD",408.22,408.22,.02,0)
INDIVIDUAL ANNUAL INCOME^RP408.21'IO^DGMT(408.21,^0;2^Q
"^DD",408.22,408.22,.02,1,0)
^.1
"^DD",408.22,408.22,.02,1,1,0)
408.22^AIND
"^DD",408.22,408.22,.02,1,1,1)
S ^DGMT(408.22,"AIND",$E(X,1,30),DA)=""
"^DD",408.22,408.22,.02,1,1,2)
K ^DGMT(408.22,"AIND",$E(X,1,30),DA)
"^DD",408.22,408.22,.02,1,1,"%D",0)
^^2^2^2920326^
"^DD",408.22,408.22,.02,1,1,"%D",1,0)
This cross-reference can be used to sort by individual annual
"^DD",408.22,408.22,.02,1,1,"%D",2,0)
income by internal entry number.
"^DD",408.22,408.22,.02,1,1,"DT")
2920128
"^DD",408.22,408.22,.02,1,2,0)
408.22^AMT2^MUMPS
"^DD",408.22,408.22,.02,1,2,1)
S:$P($G(^DGMT(408.22,DA,"MT")),U) ^DGMT(408.22,"AMT",$P(^DGMT(408.22,DA,"MT"),U),+$P(^DGMT(408.22,DA,0),U),X,DA)=""
"^DD",408.22,408.22,.02,1,2,2)
K ^DGMT(408.22,"AMT",+$P($G(^DGMT(408.22,DA,"MT")),U),+$P(^DGMT(408.22,DA,0),U),X,DA)
"^DD",408.22,408.22,.02,1,2,"%D",0)
^^2^2^2980805^^^^
"^DD",408.22,408.22,.02,1,2,"%D",1,0)
This cross reference is for the means test. It is indexed by means test,
"^DD",408.22,408.22,.02,1,2,"%D",2,0)
patient, individual annual income pointer, IFN.
"^DD",408.22,408.22,.02,1,2,"DT")
2980805
"^DD",408.22,408.22,.02,2)
S Y(0)=Y D NAM^DGMTDD2
"^DD",408.22,408.22,.02,2.1)
D NAM^DGMTDD2
"^DD",408.22,408.22,.02,3)
Enter in this field the individual whose income is associated with this income relation.
"^DD",408.22,408.22,.02,21,0)
^^2^2^2920324^
"^DD",408.22,408.22,.02,21,1,0)
Enter in this field the individual whose income is associated
"^DD",408.22,408.22,.02,21,2,0)
with this income relation.
"^DD",408.22,408.22,.02,"DT")
2980805
"^DD",408.22,408.22,.05,0)
MARRIED LAST CALENDAR YEAR^RSX^1:YES;0:NO;^0;5^D MAR^DGMTDD2:'X
"^DD",408.22,408.22,.05,.1)
WAS YOUR MARITAL STATUS EITHER MARRIED OR SEPARATED ON DEC 31ST LAST YEAR
"^DD",408.22,408.22,.05,1,0)
^.1
"^DD",408.22,408.22,.05,1,1,0)
^^TRIGGER^408.22^.06
"^DD",408.22,408.22,.05,1,1,1)
X ^DD(408.22,.05,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(408.22,.05,1,1,1.4)
"^DD",408.22,408.22,.05,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$S($D(^DD(408.22,.05,0)):$P(^(0),U,3),1:"") S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="NO"
"^DD",408.22,408.22,.05,1,1,1.4)
S DIH=$S($D(^DGMT(408.22,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,6)=DIV,DIH=408.22,DIG=.06 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
"^DD",408.22,408.22,.05,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.05,1,1,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(408.22,.05,1,1,2.4)
"^DD",408.22,408.22,.05,1,1,2.4)
S DIH=$S($D(^DGMT(408.22,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,6)=DIV,DIH=408.22,DIG=.06 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
"^DD",408.22,408.22,.05,1,1,79.2)
S Y(2)=$C(59)_$S($D(^DD(408.22,.05,0)):$P(^(0),U,3),1:""),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,5)_":",2),$C(59),1)
"^DD",408.22,408.22,.05,1,1,"%D",0)
^^3^3^2920402^^^^
"^DD",408.22,408.22,.05,1,1,"%D",1,0)
This triggered cross-reference will update the 'Lived With Patient'
"^DD",408.22,408.22,.05,1,1,"%D",2,0)
field (#.06).  If the patient is not married, the 'Lived With Patient'
"^DD",408.22,408.22,.05,1,1,"%D",3,0)
field is deleted for the patient.
"^DD",408.22,408.22,.05,1,1,"CREATE CONDITION")
MARRIED="NO"
"^DD",408.22,408.22,.05,1,1,"CREATE VALUE")
@
"^DD",408.22,408.22,.05,1,1,"DELETE CONDITION")
MARRIED=""
"^DD",408.22,408.22,.05,1,1,"DELETE VALUE")
@
"^DD",408.22,408.22,.05,1,1,"FIELD")
LIVES WITH PATIENT
"^DD",408.22,408.22,.05,1,2,0)
408.22^AIX5^MUMPS
"^DD",408.22,408.22,.05,1,2,1)
I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,5) D FUN^DGMTDD2:'$P(^(0),U,8),SP^DGMTDD2
"^DD",408.22,408.22,.05,1,2,2)
I $D(^DGMT(408.22,DA,0)),$P(^(0),U,5)="" D FUN^DGMTDD2:'$P(^(0),U,8),SP^DGMTDD2
"^DD",408.22,408.22,.05,1,2,"%D",0)
^^6^6^2970702^^^^
"^DD",408.22,408.22,.05,1,2,"%D",1,0)
This mumps cross-reference work like a "trigger" cross-reference.
"^DD",408.22,408.22,.05,1,2,"%D",2,0)
If the patient was not married and did not have any dependent
"^DD",408.22,408.22,.05,1,2,"%D",3,0)
children, any corresponding funeral and burial expenses on file for
"^DD",408.22,408.22,.05,1,2,"%D",4,0)
the year are deleted.  Also, if the veteran is no longer married the
"^DD",408.22,408.22,.05,1,2,"%D",5,0)
spouse's corresponding income and net worth on file for the year will
"^DD",408.22,408.22,.05,1,2,"%D",6,0)
be deleted.
"^DD",408.22,408.22,.05,1,2,"DT")
2970702
"^DD",408.22,408.22,.05,1,3,0)
408.22^AENR05^MUMPS
"^DD",408.22,408.22,.05,1,3,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.05,1,3,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.05,1,3,3)
 DO NOT DELETE
"^DD",408.22,408.22,.05,1,3,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.05,1,3,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.05,1,3,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.05,1,3,"DT")
3050913
"^DD",408.22,408.22,.05,3)
Enter 'YES' in this field if the veteran's marital status was either married or separated on Dec 31st last year.  Otherwise, enter 'NO'.
"^DD",408.22,408.22,.05,21,0)
^^3^3^2920429^^^^
"^DD",408.22,408.22,.05,21,1,0)
Enter 'YES' in this field if the veteran's marital status was either
"^DD",408.22,408.22,.05,21,2,0)
married or separated on Dec 31st of last calendar year.  Otherwise,
"^DD",408.22,408.22,.05,21,3,0)
enter 'NO'.
"^DD",408.22,408.22,.05,"DT")
3050913
"^DD",408.22,408.22,.06,0)
LIVED WITH PATIENT^SX^1:YES;0:NO;^0;6^D LIV^DGMTDD2
"^DD",408.22,408.22,.06,.1)

"^DD",408.22,408.22,.06,1,0)
^.1
"^DD",408.22,408.22,.06,1,1,0)
^^TRIGGER^408.22^.07
"^DD",408.22,408.22,.06,1,1,1)
X ^DD(408.22,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X="" X ^DD(408.22,.06,1,1,1.4)
"^DD",408.22,408.22,.06,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$S($D(^DD(408.22,.06,0)):$P(^(0),U,3),1:"") S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="YES"
"^DD",408.22,408.22,.06,1,1,1.4)
S DIH=$S($D(^DGMT(408.22,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,7)=DIV,DIH=408.22,DIG=.07 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
"^DD",408.22,408.22,.06,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.06,1,1,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X="" X ^DD(408.22,.06,1,1,2.4)
"^DD",408.22,408.22,.06,1,1,2.4)
S DIH=$S($D(^DGMT(408.22,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,7)=DIV,DIH=408.22,DIG=.07 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
"^DD",408.22,408.22,.06,1,1,79.2)
S Y(2)=$C(59)_$S($D(^DD(408.22,.06,0)):$P(^(0),U,3),1:""),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,6)_":",2),$C(59),1)
"^DD",408.22,408.22,.06,1,1,"%D",0)
^^4^4^2920402^^^^
"^DD",408.22,408.22,.06,1,1,"%D",1,0)
This triggered cross-reference will update the 'Amount Contributed to
"^DD",408.22,408.22,.06,1,1,"%D",2,0)
Spouse' field (#.07).  If the patient is married and lived with his
"^DD",408.22,408.22,.06,1,1,"%D",3,0)
or her spouse, the 'Amount Contributed to Spouse' field is deleted
"^DD",408.22,408.22,.06,1,1,"%D",4,0)
for the patient.
"^DD",408.22,408.22,.06,1,1,"CREATE CONDITION")
LIVES WITH PATIENT="YES"
"^DD",408.22,408.22,.06,1,1,"CREATE VALUE")
@
"^DD",408.22,408.22,.06,1,1,"DELETE CONDITION")
LIVES WITH PATIENT=""
"^DD",408.22,408.22,.06,1,1,"DELETE VALUE")
@
"^DD",408.22,408.22,.06,1,1,"FIELD")
AMOUNT CONTRIBUTED TO SPOUSE
"^DD",408.22,408.22,.06,1,2,0)
^^TRIGGER^408.22^.1
"^DD",408.22,408.22,.06,1,2,1)
X ^DD(408.22,.06,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(408.22,.06,1,2,1.4)
"^DD",408.22,408.22,.06,1,2,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$S($D(^DD(408.22,.06,0)):$P(^(0),U,3),1:"") S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="YES"
"^DD",408.22,408.22,.06,1,2,1.4)
S DIH=$S($D(^DGMT(408.22,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,10)=DIV,DIH=408.22,DIG=.1 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
"^DD",408.22,408.22,.06,1,2,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.06,1,2,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(408.22,.06,1,2,2.4)
"^DD",408.22,408.22,.06,1,2,2.4)
S DIH=$S($D(^DGMT(408.22,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,10)=DIV,DIH=408.22,DIG=.1 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
"^DD",408.22,408.22,.06,1,2,79.2)
S Y(2)=$C(59)_$S($D(^DD(408.22,.06,0)):$P(^(0),U,3),1:""),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,6)_":",2),$C(59),1)
"^DD",408.22,408.22,.06,1,2,"%D",0)
^^4^4^2920402^^^
"^DD",408.22,408.22,.06,1,2,"%D",1,0)
This triggered cross-reference will update the 'Contribute to Support'
"^DD",408.22,408.22,.06,1,2,"%D",2,0)
field (#.1).  If the patient had a dependent child which lived with
"^DD",408.22,408.22,.06,1,2,"%D",3,0)
him or her, the 'Contributed to Support' field is deleted for the
"^DD",408.22,408.22,.06,1,2,"%D",4,0)
child.
"^DD",408.22,408.22,.06,1,2,"CREATE CONDITION")
LIVES WITH PATIENT="YES"
"^DD",408.22,408.22,.06,1,2,"CREATE VALUE")
@
"^DD",408.22,408.22,.06,1,2,"DELETE CONDITION")
LIVES WITH PATIENT=""
"^DD",408.22,408.22,.06,1,2,"DELETE VALUE")
@
"^DD",408.22,408.22,.06,1,2,"DT")
2920205
"^DD",408.22,408.22,.06,1,2,"FIELD")
CONTRIBUTE TO SUPPORT
"^DD",408.22,408.22,.06,1,3,0)
408.22^AENR06^MUMPS
"^DD",408.22,408.22,.06,1,3,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.06,1,3,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.06,1,3,3)
 DO NOT DELETE
"^DD",408.22,408.22,.06,1,3,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.06,1,3,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.06,1,3,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.06,1,3,"DT")
3050913
"^DD",408.22,408.22,.06,4)
D LIVHLP^DGMTDD2
"^DD",408.22,408.22,.06,5,1,0)
408.22^.05^1
"^DD",408.22,408.22,.06,21,0)
^^1^1^2920402^^^^
"^DD",408.22,408.22,.06,21,1,0)
Enter whether the veteran and relation lived together last calendar year.
"^DD",408.22,408.22,.06,22)

"^DD",408.22,408.22,.06,"DT")
3050913
"^DD",408.22,408.22,.07,0)
AMOUNT CONTRIBUTED TO SPOUSE^NJ8,2X^^0;7^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X D AMT^DGMTDD2:$D(X)
"^DD",408.22,408.22,.07,.1)
IF YOU DID NOT LIVE WITH SPOUSE, AMOUNT CONTRIBUTED TO SPOUSE LAST YEAR
"^DD",408.22,408.22,.07,1,0)
^.1
"^DD",408.22,408.22,.07,1,1,0)
408.22^AIX7^MUMPS
"^DD",408.22,408.22,.07,1,1,1)
I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,6),$P(^(0),U,7)<600 D SP^DGMTDD2
"^DD",408.22,408.22,.07,1,1,2)
I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,6),$P(^(0),U,7)="" D SP^DGMTDD2
"^DD",408.22,408.22,.07,1,1,"%D",0)
^^4^4^2920723^^^^
"^DD",408.22,408.22,.07,1,1,"%D",1,0)
This mumps cross-reference works like a "trigger" cross-reference.
"^DD",408.22,408.22,.07,1,1,"%D",2,0)
If the patient did not contribute at least $600 to the spouse,
"^DD",408.22,408.22,.07,1,1,"%D",3,0)
any corresponding income and net worth on file for the year
"^DD",408.22,408.22,.07,1,1,"%D",4,0)
are deleted.
"^DD",408.22,408.22,.07,1,1,"DT")
2920723
"^DD",408.22,408.22,.07,1,2,0)
408.22^AENR07^MUMPS
"^DD",408.22,408.22,.07,1,2,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.07,1,2,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.07,1,2,3)
 DO NOT DELETE
"^DD",408.22,408.22,.07,1,2,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.07,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.07,1,2,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.07,1,2,"DT")
3050913
"^DD",408.22,408.22,.07,3)
Type a Dollar Amount between 0 and 99999, 2 Decimal Digits
"^DD",408.22,408.22,.07,5,1,0)
408.22^.06^1
"^DD",408.22,408.22,.07,21,0)
^^8^8^3050111^
"^DD",408.22,408.22,.07,21,1,0)
This response must be a number.
"^DD",408.22,408.22,.07,21,2,0)
 
"^DD",408.22,408.22,.07,21,3,0)
If the veteran did not live with his or her spouse, enter in this
"^DD",408.22,408.22,.07,21,4,0)
field the amount the veteran contributed to his or her spouse last
"^DD",408.22,408.22,.07,21,5,0)
calendar year.
"^DD",408.22,408.22,.07,21,6,0)
 
"^DD",408.22,408.22,.07,21,7,0)
If the amount the veteran contributed is less than $600, then the
"^DD",408.22,408.22,.07,21,8,0)
spouse will not be considered a dependent for financial assessment.
"^DD",408.22,408.22,.07,"DT")
3050913
"^DD",408.22,408.22,.08,0)
DEPENDENT CHILDREN^SX^1:YES;0:NO;^0;8^D DEP^DGMTDD2:'X
"^DD",408.22,408.22,.08,.1)
DID YOU HAVE ANY DEPENDENT CHILDREN
"^DD",408.22,408.22,.08,1,0)
^.1
"^DD",408.22,408.22,.08,1,1,0)
408.22^AIX8^MUMPS
"^DD",408.22,408.22,.08,1,1,1)
I $D(^DGMT(408.22,DA,0)),$P(^(0),U,8)=0,'$P(^(0),U,5) D FUN^DGMTDD2
"^DD",408.22,408.22,.08,1,1,2)
I $D(^DGMT(408.22,DA,0)),$P(^(0),U,8)="",'$P(^(0),U,5) D FUN^DGMTDD2
"^DD",408.22,408.22,.08,1,1,"%D",0)
^^4^4^2920403^^^
"^DD",408.22,408.22,.08,1,1,"%D",1,0)
This mumps cross-reference works like a "trigger" cross-reference.
"^DD",408.22,408.22,.08,1,1,"%D",2,0)
If the patient did not have any dependent children and was not married,
"^DD",408.22,408.22,.08,1,1,"%D",3,0)
any corresponding funeral and burial expenses on file for the year are
"^DD",408.22,408.22,.08,1,1,"%D",4,0)
deleted.
"^DD",408.22,408.22,.08,1,1,"DT")
2920403
"^DD",408.22,408.22,.08,1,2,0)
408.22^AENR08^MUMPS
"^DD",408.22,408.22,.08,1,2,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.08,1,2,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.08,1,2,3)
 DO NOT DELETE
"^DD",408.22,408.22,.08,1,2,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.08,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.08,1,2,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.08,1,2,"DT")
3050913
"^DD",408.22,408.22,.08,3)
Enter in this field whether the veteran had dependent children last calendar year.
"^DD",408.22,408.22,.08,4)

"^DD",408.22,408.22,.08,21,0)
^^16^16^2920721^^^^
"^DD",408.22,408.22,.08,21,1,0)
Enter in this field whether the veteran had any UNMARRIED children or
"^DD",408.22,408.22,.08,21,2,0)
stepchildren under the age of 18 or between the ages of 18 and 23 and
"^DD",408.22,408.22,.08,21,3,0)
attending school, or any unmarried children over the age of 17 who
"^DD",408.22,408.22,.08,21,4,0)
became permanently incapable of self-support before reaching the age of 18
"^DD",408.22,408.22,.08,21,5,0)
last calendar year.
"^DD",408.22,408.22,.08,21,6,0)
 
"^DD",408.22,408.22,.08,21,7,0)
School attendance does not have to be full-time but it should be regular.  
"^DD",408.22,408.22,.08,21,8,0)
The child can be enrolled in high school, college, or vocational school.  
"^DD",408.22,408.22,.08,21,9,0)
If the worksheet is being completed during a break between regular school
"^DD",408.22,408.22,.08,21,10,0)
terms, consider the child to be attending school if the veteran indicates
"^DD",408.22,408.22,.08,21,11,0)
that the child plans to enroll in the next regular term (excluding summer
"^DD",408.22,408.22,.08,21,12,0)
sessions).  If the child is under the age of 18, the child does not have to
"^DD",408.22,408.22,.08,21,13,0)
be attending school.  DO NOT INCLUDE FOSTER CHILDREN.
"^DD",408.22,408.22,.08,21,14,0)
 
"^DD",408.22,408.22,.08,21,15,0)
If the veteran says 'YES', all dependent children must be entered
"^DD",408.22,408.22,.08,21,16,0)
for the means test thresholds to be properly determined.
"^DD",408.22,408.22,.08,"DT")
3050913
"^DD",408.22,408.22,.09,0)
INCAPABLE OF SELF-SUPPORT^S^1:YES;0:NO;^0;9^Q
"^DD",408.22,408.22,.09,.1)
PERMANENTLY INCAPABLE OF SELF-SUPPORT
"^DD",408.22,408.22,.09,1,0)
^.1
"^DD",408.22,408.22,.09,1,1,0)
408.22^AENR09^MUMPS
"^DD",408.22,408.22,.09,1,1,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.09,1,1,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.09,1,1,3)
 DO NOT DELETE
"^DD",408.22,408.22,.09,1,1,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.09,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.09,1,1,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.09,1,1,"DT")
3050913
"^DD",408.22,408.22,.09,3)
Enter in this field whether the child is unmarried, over the age of 17, and became permanently incapable of self-support before reaching the age of 18.
"^DD",408.22,408.22,.09,21,0)
^^3^3^2920323^
"^DD",408.22,408.22,.09,21,1,0)
Enter in this field whether the child is unmarried, over the age of 17,
"^DD",408.22,408.22,.09,21,2,0)
and became permanently incapable of self-support before reaching in age
"^DD",408.22,408.22,.09,21,3,0)
of 18.
"^DD",408.22,408.22,.09,"DT")
3050913
"^DD",408.22,408.22,.1,0)
CONTRIBUTED TO SUPPORT^SX^1:YES;0:NO;^0;10^D CON^DGMTDD2
"^DD",408.22,408.22,.1,.1)
DID YOU CONTRIBUTE TO THE CHILD'S SUPPORT
"^DD",408.22,408.22,.1,1,0)
^.1
"^DD",408.22,408.22,.1,1,1,0)
408.22^AENR1^MUMPS
"^DD",408.22,408.22,.1,1,1,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.1,1,1,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.1,1,1,3)
 DO NOT DELETE
"^DD",408.22,408.22,.1,1,1,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.1,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.1,1,1,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.1,1,1,"DT")
3050913
"^DD",408.22,408.22,.1,3)
Enter in this field a Yes or No to indicate whether the veteran contributed any dollar amount to the child's support last calendar year.
"^DD",408.22,408.22,.1,4)
D HLPCS^DGRPU
"^DD",408.22,408.22,.1,5,1,0)
408.22^.06^2
"^DD",408.22,408.22,.1,21,0)
^.001^5^5^3141106^^^^
"^DD",408.22,408.22,.1,21,1,0)
Enter in this field a Yes or No to indicate whether the veteran
"^DD",408.22,408.22,.1,21,2,0)
contributed any dollar amount to the child's support last calendar
"^DD",408.22,408.22,.1,21,3,0)
year.  The contributions do not have to be in regular set amounts.
"^DD",408.22,408.22,.1,21,4,0)
For example, a veteran who paid a child's school tuition or
"^DD",408.22,408.22,.1,21,5,0)
medical bills would be contributing to the child's support.
"^DD",408.22,408.22,.1,"DT")
3050913
"^DD",408.22,408.22,.11,0)
CHILD HAD INCOME^SX^1:YES;0:NO;^0;11^Q
"^DD",408.22,408.22,.11,.1)
DID CHILD HAVE ANY INCOME
"^DD",408.22,408.22,.11,1,0)
^.1
"^DD",408.22,408.22,.11,1,1,0)
^^TRIGGER^408.22^.12
"^DD",408.22,408.22,.11,1,1,1)
X ^DD(408.22,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,12)=DIV,DIH=408.22,DIG=.12 D ^DICR
"^DD",408.22,408.22,.11,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(408.22,.11,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="NO"
"^DD",408.22,408.22,.11,1,1,2)
X ^DD(408.22,.11,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,12)=DIV,DIH=408.22,DIG=.12 D ^DICR
"^DD",408.22,408.22,.11,1,1,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(408.22,.11,0)),U,3),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,11)_":",2),$C(59))=""
"^DD",408.22,408.22,.11,1,1,"%D",0)
^.101^3^3^3080422^^
"^DD",408.22,408.22,.11,1,1,"%D",1,0)
This triggered cross-reference will update the 'Income Available to You' 
"^DD",408.22,408.22,.11,1,1,"%D",2,0)
field (#.12).  If the  patient has a dependent child whose income is not 
"^DD",408.22,408.22,.11,1,1,"%D",3,0)
available to him or her, the 'Income Avaliable to You' field is deleted.
"^DD",408.22,408.22,.11,1,1,"CREATE CONDITION")
#.11="NO"
"^DD",408.22,408.22,.11,1,1,"CREATE VALUE")
@
"^DD",408.22,408.22,.11,1,1,"DELETE CONDITION")
#.11=""
"^DD",408.22,408.22,.11,1,1,"DELETE VALUE")
@
"^DD",408.22,408.22,.11,1,1,"DT")
3080422
"^DD",408.22,408.22,.11,1,1,"FIELD")
#.12
"^DD",408.22,408.22,.11,1,2,0)
408.22^AIX11^MUMPS
"^DD",408.22,408.22,.11,1,2,1)
I $D(^DGMT(408.22,DA,0)),$P(^(0),U,11)=0 D INC^DGMTDD2
"^DD",408.22,408.22,.11,1,2,2)
I $D(^DGMT(408.22,DA,0)),$P(^(0),U,11)="" D INC^DGMTDD2
"^DD",408.22,408.22,.11,1,2,"%D",0)
^^3^3^2920402^^^^
"^DD",408.22,408.22,.11,1,2,"%D",1,0)
This mumps cross-reference works like a "trigger" cross-reference.
"^DD",408.22,408.22,.11,1,2,"%D",2,0)
If the patient had a child with no income, any corresponding income
"^DD",408.22,408.22,.11,1,2,"%D",3,0)
or educational expenses on file for the year are deleted.
"^DD",408.22,408.22,.11,1,2,"DT")
2920323
"^DD",408.22,408.22,.11,1,3,0)
408.22^AENR11^MUMPS
"^DD",408.22,408.22,.11,1,3,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.11,1,3,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.11,1,3,3)
 DO NOT DELETE
"^DD",408.22,408.22,.11,1,3,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.11,1,3,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.11,1,3,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.11,1,3,"DT")
3050913
"^DD",408.22,408.22,.11,3)

"^DD",408.22,408.22,.11,4)
D CHLDINNW^DGMTHLP
"^DD",408.22,408.22,.11,"DT")
3080422
"^DD",408.22,408.22,.12,0)
INCOME AVAILABLE TO YOU^SX^1:YES;0:NO;^0;12^D AVL^DGMTDD2
"^DD",408.22,408.22,.12,.1)
WAS THE CHILD'S INCOME AVAILABLE TO YOU
"^DD",408.22,408.22,.12,1,0)
^.1
"^DD",408.22,408.22,.12,1,1,0)
408.22^AIX12^MUMPS
"^DD",408.22,408.22,.12,1,1,1)
I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)=0,$P(^(0),U,11) D INC^DGMTDD2
"^DD",408.22,408.22,.12,1,1,2)
I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)="",$P(^(0),U,11) D INC^DGMTDD2
"^DD",408.22,408.22,.12,1,1,"%D",0)
^.101^4^4^3080421^^^^
"^DD",408.22,408.22,.12,1,1,"%D",1,0)
This mumps cross-reference works like a "trigger" cross-reference.
"^DD",408.22,408.22,.12,1,1,"%D",2,0)
If the patient had a child whose income was not available to him or her,
"^DD",408.22,408.22,.12,1,1,"%D",3,0)
any corresponding income or educational expenses on file for the year
"^DD",408.22,408.22,.12,1,1,"%D",4,0)
are deleted.
"^DD",408.22,408.22,.12,1,1,"DT")
2920323
"^DD",408.22,408.22,.12,1,2,0)
408.22^AENR12^MUMPS
"^DD",408.22,408.22,.12,1,2,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.12,1,2,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.12,1,2,3)
 DO NOT DELETE
"^DD",408.22,408.22,.12,1,2,"%D",0)
^.101^2^2^3080421^^^^
"^DD",408.22,408.22,.12,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.12,1,2,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.12,1,2,"DT")
3050913
"^DD",408.22,408.22,.12,3)

"^DD",408.22,408.22,.12,4)
D INNWAVAL^DGMTHLP
"^DD",408.22,408.22,.12,5,1,0)
408.22^.11^1
"^DD",408.22,408.22,.12,"DT")
3050913
"^DD",408.22,408.22,.13,0)
NUMBER OF DEPENDENT CHILDREN^NJ2,0^^0;13^K:+X'=X!(X>30)!(X<0)!(X?.E1"."1N.N) X
"^DD",408.22,408.22,.13,1,0)
^.1
"^DD",408.22,408.22,.13,1,1,0)
408.22^AENR13^MUMPS
"^DD",408.22,408.22,.13,1,1,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.13,1,1,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.13,1,1,3)
 DO NOT DELETE
"^DD",408.22,408.22,.13,1,1,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.13,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.13,1,1,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.13,1,1,"DT")
3050913
"^DD",408.22,408.22,.13,3)
Type a Number between 0 and 30, 0 Decimal Digits
"^DD",408.22,408.22,.13,21,0)
^.001^5^5^3141105^^^^
"^DD",408.22,408.22,.13,21,1,0)
This field is computed by the system.  Dependent children
"^DD",408.22,408.22,.13,21,2,0)
include any unmarried children or stepchildren who are under
"^DD",408.22,408.22,.13,21,3,0)
the age of 18 or between the ages of 18 and 23 and attending
"^DD",408.22,408.22,.13,21,4,0)
school, or any unmarried children over the age of 17 who became
"^DD",408.22,408.22,.13,21,5,0)
permanently incapable of self-support before reaching the age of 18.
"^DD",408.22,408.22,.13,"DT")
3050913
"^DD",408.22,408.22,.14,0)
MARRIED THIS YEAR^S^1:YES;0:NO;^0;14^Q
"^DD",408.22,408.22,.14,.1)
IS YOUR MARITAL STATUS EITHER MARRIED OR SEPARATED
"^DD",408.22,408.22,.14,1,0)
^.1
"^DD",408.22,408.22,.14,1,1,0)
^^TRIGGER^408.22^.15
"^DD",408.22,408.22,.14,1,1,1)
X ^DD(408.22,.14,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=408.22,DIG=.15 D ^DICR
"^DD",408.22,408.22,.14,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(408.22,.14,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="NO"
"^DD",408.22,408.22,.14,1,1,2)
X ^DD(408.22,.14,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=408.22,DIG=.15 D ^DICR
"^DD",408.22,408.22,.14,1,1,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(408.22,.14,0)),U,3),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,14)_":",2),$C(59),1)=""
"^DD",408.22,408.22,.14,1,1,"%D",0)
^^3^3^3010822^
"^DD",408.22,408.22,.14,1,1,"%D",1,0)
This triggered cross-reference will update the Living With Patient field
"^DD",408.22,408.22,.14,1,1,"%D",2,0)
(#.15).  If Married This Year="NO", the Living With Patient field will be
"^DD",408.22,408.22,.14,1,1,"%D",3,0)
deleted.
"^DD",408.22,408.22,.14,1,1,"CREATE CONDITION")
#.14="NO"
"^DD",408.22,408.22,.14,1,1,"CREATE VALUE")
@
"^DD",408.22,408.22,.14,1,1,"DELETE CONDITION")
#.14=""
"^DD",408.22,408.22,.14,1,1,"DELETE VALUE")
@
"^DD",408.22,408.22,.14,1,1,"FIELD")
#.15
"^DD",408.22,408.22,.14,1,2,0)
^^TRIGGER^408.22^.16
"^DD",408.22,408.22,.14,1,2,1)
X ^DD(408.22,.14,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR
"^DD",408.22,408.22,.14,1,2,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(408.22,.14,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="NO"
"^DD",408.22,408.22,.14,1,2,2)
X ^DD(408.22,.14,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR
"^DD",408.22,408.22,.14,1,2,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(408.22,.14,0)),U,3),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,14)_":",2),$C(59),1)=""
"^DD",408.22,408.22,.14,1,2,"%D",0)
^^3^3^3010822^
"^DD",408.22,408.22,.14,1,2,"%D",1,0)
This trigger cross-reference will update the Residing In The Community
"^DD",408.22,408.22,.14,1,2,"%D",2,0)
field (#.16).  If Married This Year="NO", the Residing In The Community
"^DD",408.22,408.22,.14,1,2,"%D",3,0)
field will be deleted.
"^DD",408.22,408.22,.14,1,2,"CREATE CONDITION")
#.14="NO"
"^DD",408.22,408.22,.14,1,2,"CREATE VALUE")
@
"^DD",408.22,408.22,.14,1,2,"DELETE CONDITION")
#.14=""
"^DD",408.22,408.22,.14,1,2,"DELETE VALUE")
@
"^DD",408.22,408.22,.14,1,2,"DT")
3010822
"^DD",408.22,408.22,.14,1,2,"FIELD")
#.16
"^DD",408.22,408.22,.14,1,3,0)
^^TRIGGER^408.22^.17
"^DD",408.22,408.22,.14,1,3,1)
X ^DD(408.22,.14,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,17)=DIV,DIH=408.22,DIG=.17 D ^DICR
"^DD",408.22,408.22,.14,1,3,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(408.22,.14,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="NO"
"^DD",408.22,408.22,.14,1,3,2)
X ^DD(408.22,.14,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,17)=DIV,DIH=408.22,DIG=.17 D ^DICR
"^DD",408.22,408.22,.14,1,3,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(408.22,.14,0)),U,3),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,14)_":",2),$C(59))=""
"^DD",408.22,408.22,.14,1,3,"%D",0)
^^3^3^3030902^
"^DD",408.22,408.22,.14,1,3,"%D",1,0)
This trigger cross-reference will update the Legally Separated field
"^DD",408.22,408.22,.14,1,3,"%D",2,0)
(#.17).  If Married This Year="NO", the Legally Separated field will be
"^DD",408.22,408.22,.14,1,3,"%D",3,0)
deleted.
"^DD",408.22,408.22,.14,1,3,"CREATE CONDITION")
#.14="NO"
"^DD",408.22,408.22,.14,1,3,"CREATE VALUE")
@
"^DD",408.22,408.22,.14,1,3,"DELETE CONDITION")
#.14=""
"^DD",408.22,408.22,.14,1,3,"DELETE VALUE")
@
"^DD",408.22,408.22,.14,1,3,"DT")
3030902
"^DD",408.22,408.22,.14,1,3,"FIELD")
#.17
"^DD",408.22,408.22,.14,21,0)
^.001^2^2^3010822^^
"^DD",408.22,408.22,.14,21,1,0)
Enter 'YES' in this field if the veteran's marital status currently is
"^DD",408.22,408.22,.14,21,2,0)
either married or separated.  Otherwise, enter 'NO'.
"^DD",408.22,408.22,.14,"DT")
3030902
"^DD",408.22,408.22,.15,0)
LIVING WITH PATIENT^S^1:YES;0:NO;^0;15^Q
"^DD",408.22,408.22,.15,5,1,0)
408.22^.14^1
"^DD",408.22,408.22,.15,5,2,0)
408.22^.16^1
"^DD",408.22,408.22,.15,21,0)
^.001^1^1^3010822^^
"^DD",408.22,408.22,.15,21,1,0)
Enter whether the veteran and relation are living together.
"^DD",408.22,408.22,.15,"DT")
3010822
"^DD",408.22,408.22,.16,0)
RESIDING IN THE COMMUNITY^S^1:YES;0:NO;^0;16^Q
"^DD",408.22,408.22,.16,1,0)
^.1
"^DD",408.22,408.22,.16,1,1,0)
^^TRIGGER^408.22^.15
"^DD",408.22,408.22,.16,1,1,1)
X ^DD(408.22,.16,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X="NO" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=408.22,DIG=.15 D ^DICR
"^DD",408.22,408.22,.16,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(408.22,.16,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="NO"
"^DD",408.22,408.22,.16,1,1,2)
X ^DD(408.22,.16,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=408.22,DIG=.15 D ^DICR
"^DD",408.22,408.22,.16,1,1,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(408.22,.16,0)),U,3),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,16)_":",2),$C(59),1)=""
"^DD",408.22,408.22,.16,1,1,"%D",0)
^^2^2^3010822^
"^DD",408.22,408.22,.16,1,1,"%D",1,0)
This trigger cross-reference will update the Living With Patient field
"^DD",408.22,408.22,.16,1,1,"%D",2,0)
(#.15). If Residing in the Community="NO", then Living With Patient="NO".
"^DD",408.22,408.22,.16,1,1,"CREATE CONDITION")
RESIDING IN THE COMMUNITY="NO"
"^DD",408.22,408.22,.16,1,1,"CREATE VALUE")
"NO"
"^DD",408.22,408.22,.16,1,1,"DELETE CONDITION")
RESIDING IN THE COMMUNITY=""
"^DD",408.22,408.22,.16,1,1,"DELETE VALUE")
@
"^DD",408.22,408.22,.16,1,1,"FIELD")
#.15
"^DD",408.22,408.22,.16,5,1,0)
408.22^.14^2
"^DD",408.22,408.22,.16,5,2,0)
408.22^.17^1
"^DD",408.22,408.22,.16,21,0)
^.001^2^2^3010822^^
"^DD",408.22,408.22,.16,21,1,0)
Enter 'YES' if the spouse or dependent is residing in the community.
"^DD",408.22,408.22,.16,21,2,0)
Enter 'NO' if the spouse or dependent is institutionalized.
"^DD",408.22,408.22,.16,"DT")
3010822
"^DD",408.22,408.22,.17,0)
LEGALLY SEPARATED^S^1:YES;0:NO;^0;17^Q
"^DD",408.22,408.22,.17,1,0)
^.1
"^DD",408.22,408.22,.17,1,1,0)
^^TRIGGER^408.22^.16
"^DD",408.22,408.22,.17,1,1,1)
X ^DD(408.22,.17,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR
"^DD",408.22,408.22,.17,1,1,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(408.22,.17,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="YES"
"^DD",408.22,408.22,.17,1,1,2)
X ^DD(408.22,.17,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR
"^DD",408.22,408.22,.17,1,1,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(2)=$C(59)_$P($G(^DD(408.22,.17,0)),U,3),Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P($P(Y(2),$C(59)_$P(Y(1),U,17)_":",2),$C(59))="YES"
"^DD",408.22,408.22,.17,1,1,"%D",0)
^^3^3^3030902^
"^DD",408.22,408.22,.17,1,1,"%D",1,0)
This trigger cross-reference will update the Residing in the Community
"^DD",408.22,408.22,.17,1,1,"%D",2,0)
field (#.16).  If Legally Separated="YES", the Residing in the Community
"^DD",408.22,408.22,.17,1,1,"%D",3,0)
field will be deleted.
"^DD",408.22,408.22,.17,1,1,"CREATE CONDITION")
#.17="YES"
"^DD",408.22,408.22,.17,1,1,"CREATE VALUE")
@
"^DD",408.22,408.22,.17,1,1,"DELETE CONDITION")
#.17="YES"
"^DD",408.22,408.22,.17,1,1,"DELETE VALUE")
@
"^DD",408.22,408.22,.17,1,1,"DT")
3030902
"^DD",408.22,408.22,.17,1,1,"FIELD")
#.16
"^DD",408.22,408.22,.17,5,1,0)
408.22^.14^3
"^DD",408.22,408.22,.17,21,0)
^^2^2^3030902^
"^DD",408.22,408.22,.17,21,1,0)
Enter 'YES' in this field if the veteran and spouse are legally
"^DD",408.22,408.22,.17,21,2,0)
separated.
"^DD",408.22,408.22,.17,23,0)
^^4^4^3030902^
"^DD",408.22,408.22,.17,23,1,0)
This field will be used to determine how the veteran's LTC copayment is 
"^DD",408.22,408.22,.17,23,2,0)
calculated. If LEGALLY SEPARATED = "YES", then the calculation used will 
"^DD",408.22,408.22,.17,23,3,0)
be the same as an unmarried veteran. This question will be asked if the 
"^DD",408.22,408.22,.17,23,4,0)
field MARRIED THIS YEAR (#.14) = "YES".
"^DD",408.22,408.22,.17,"DT")
3030902
"^DD",408.22,408.22,.18,0)
CHILD 18-23 IN SCHOOL^S^0:NO;1:YES;^0;18^Q
"^DD",408.22,408.22,.18,.1)
CHILD IS 18-23 YRS AND CHILD ATTENDED SCHOOL LAST YR
"^DD",408.22,408.22,.18,1,0)
^.1
"^DD",408.22,408.22,.18,1,1,0)
408.22^AENR18^MUMPS
"^DD",408.22,408.22,.18,1,1,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.18,1,1,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.18,1,1,3)
 DO NOT DELETE
"^DD",408.22,408.22,.18,1,1,"%D",0)
^.101^2^2^3050913^^^^
"^DD",408.22,408.22,.18,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",408.22,408.22,.18,1,1,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.18,1,1,"DT")
3050913
"^DD",408.22,408.22,.18,3)

"^DD",408.22,408.22,.18,4)
D HLP1823^DGRPU
"^DD",408.22,408.22,.18,"DT")
3050913
"^DD",408.22,408.22,.19,0)
AMOUNT CONTRIBUTED TO CHILD^NJ8,2^^0;19^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X
"^DD",408.22,408.22,.19,.1)
IF YOU DID NOT LIVE WITH CHILD, AMOUNT CONTRIBUTED TO CHILD LAST YEAR
"^DD",408.22,408.22,.19,3)
Type a Dollar Amount between 0 and 99999, 2 Decimal Digits
"^DD",408.22,408.22,.19,21,0)
^.001^5^5^3141106^^^^
"^DD",408.22,408.22,.19,21,1,0)
Enter in this field the dollar amount that the veteran contributed
"^DD",408.22,408.22,.19,21,2,0)
to the child's support last calendar year.  The contributions do not 
"^DD",408.22,408.22,.19,21,3,0)
have to be in regular set amounts.  For example, a veteran who paid
"^DD",408.22,408.22,.19,21,4,0)
a child's school tuition or medical bills would be contributing to
"^DD",408.22,408.22,.19,21,5,0)
the child's support. 
"^DD",408.22,408.22,.19,"DT")
3050124
"^DD",408.22,408.22,.21,0)
CONTRIBUTED TO SPOUSAL SUPPORT^S^1:YES;0:NO;^0;20^Q
"^DD",408.22,408.22,.21,.1)
IF YOUR SPOUSE DID NOT LIVE WITH YOU LAST YEAR, DID YOU PROVIDE SUPPORT:
"^DD",408.22,408.22,.21,1,0)
^.1
"^DD",408.22,408.22,.21,1,1,0)
408.22^AIX^MUMPS
"^DD",408.22,408.22,.21,1,1,1)
I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,6),'$P(^(0),U,20) D SP^DGMTDD2
"^DD",408.22,408.22,.21,1,1,2)
I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,6),'$P(^(0),U,20) D SP^DGMTDD2
"^DD",408.22,408.22,.21,1,1,"%D",0)
^.101^3^3^3140616^^^^
"^DD",408.22,408.22,.21,1,1,"%D",1,0)
This mumps cross-reference works like a "trigger" cross-reference.  If 
"^DD",408.22,408.22,.21,1,1,"%D",2,0)
the patient did not contribute to the spouse, any corresponding income and
"^DD",408.22,408.22,.21,1,1,"%D",3,0)
net worth on file for the year are deleted.
"^DD",408.22,408.22,.21,1,1,"DT")
3140616
"^DD",408.22,408.22,.21,1,2,0)
408.22^AD^MUMPS
"^DD",408.22,408.22,.21,1,2,1)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.21,1,2,2)
D E40822^DGRTRIG(DA)
"^DD",408.22,408.22,.21,1,2,3)
DO NOT DELETE
"^DD",408.22,408.22,.21,1,2,"%D",0)
^^2^2^3140616^
"^DD",408.22,408.22,.21,1,2,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect 
"^DD",408.22,408.22,.21,1,2,"%D",2,0)
enrollment.
"^DD",408.22,408.22,.21,1,2,"DT")
3140616
"^DD",408.22,408.22,.21,3)
Enter 'YES' if the Veteran contributed to their spouse's support and 'NO' if he or she did not contribute to their spouse's support.
"^DD",408.22,408.22,.21,21,0)
^.001^8^8^3141203^^^^
"^DD",408.22,408.22,.21,21,1,0)
This response must be a 'YES' or 'NO' 
"^DD",408.22,408.22,.21,21,2,0)
 
"^DD",408.22,408.22,.21,21,3,0)
If the veteran did not live with his or her spouse, enter in this field
"^DD",408.22,408.22,.21,21,4,0)
the veteran's statement as to whether he or she contributed to his or her
"^DD",408.22,408.22,.21,21,5,0)
spouse's support last calendar year.  
"^DD",408.22,408.22,.21,21,6,0)
                                                                 
"^DD",408.22,408.22,.21,21,7,0)
If the veteran did not contribute to the spouse, then the spouse will not
"^DD",408.22,408.22,.21,21,8,0)
be considered a dependent for financial assessment.  
"^DD",408.22,408.22,.21,"DT")
3141203
"^DD",408.22,408.22,31,0)
ANNUAL MEANS TEST^P408.31'^DGMT(408.31,^MT;1^Q
"^DD",408.22,408.22,31,1,0)
^.1
"^DD",408.22,408.22,31,1,1,0)
408.22^AMT^MUMPS
"^DD",408.22,408.22,31,1,1,1)
S:$P(^DGMT(408.22,DA,0),U,2) ^DGMT(408.22,"AMT",X,+$P(^DGMT(408.22,DA,0),U),+$P(^DGMT(408.22,DA,0),U,2),DA)=""
"^DD",408.22,408.22,31,1,1,2)
K ^DGMT(408.22,"AMT",X,+$P(^DGMT(408.22,DA,0),U),+$P($G(^DGMT(408.22,DA,0)),U,2),DA)
"^DD",408.22,408.22,31,1,1,"%D",0)
^^2^2^2950302^^
"^DD",408.22,408.22,31,1,1,"%D",1,0)
This cross reference is for the means test.  It is indexed by means test, 
"^DD",408.22,408.22,31,1,1,"%D",2,0)
patient, individual annual income pointer, IFN.
"^DD",408.22,408.22,31,1,1,"DT")
2950302
"^DD",408.22,408.22,31,"DT")
2950302
"^DIC",408.22,408.22,0)
INCOME RELATION^408.22IP
"^DIC",408.22,408.22,0,"GL")
^DGMT(408.22,
"^DIC",408.22,408.22,"%D",0)
^1.001^3^3^3141219^^^^
"^DIC",408.22,408.22,"%D",1,0)
This file contains the income relation type data for a veteran
"^DIC",408.22,408.22,"%D",2,0)
and any applicable relations.  This relation type information is
"^DIC",408.22,408.22,"%D",3,0)
used in registration and means test.
"^DIC",408.22,"B","INCOME RELATION",408.22)

**INSTALL NAME**
DG*5.3*904
"BLD",9599,0)
DG*5.3*904^REGISTRATION^0^3150424^y
"BLD",9599,1,0)
^^11^11^3141124^^
"BLD",9599,1,1,0)
This patch modifies the Registration v5.3 application as described below:
"BLD",9599,1,2,0)
 
"BLD",9599,1,3,0)
--   This patch will display a new Beneficiary Travel Financial Indicator
"BLD",9599,1,4,0)
     on the Means Test and Copay Test overview screens. The BT Financial
"BLD",9599,1,5,0)
     indicator will be sent from the Enrollment System and share with all
"BLD",9599,1,6,0)
     sites of record when the Income Verification Matching (IVM)
"BLD",9599,1,7,0)
     application has performed a Conversion and/or Reversal on an income
"BLD",9599,1,8,0)
     test where the Veteran had a BT award prior to the IVM action. A
"BLD",9599,1,9,0)
     bulletin will be generated and sent to the BT CLAIMS PROCESSING
"BLD",9599,1,10,0)
     Mailgroup to notify select members that there has been a change in
"BLD",9599,1,11,0)
     the Veteran's BT Financial Indicator status.
"BLD",9599,4,0)
^9.64PA^408.31^1
"BLD",9599,4,408.31,0)
408.31
"BLD",9599,4,408.31,2,0)
^9.641^408.31^1
"BLD",9599,4,408.31,2,408.31,0)
ANNUAL MEANS TEST  (File-top level)
"BLD",9599,4,408.31,2,408.31,1,0)
^9.6411^4^1
"BLD",9599,4,408.31,2,408.31,1,4,0)
BT FINANCIAL INDICATOR
"BLD",9599,4,408.31,222)
y^n^p^^^^n^^n
"BLD",9599,4,408.31,224)

"BLD",9599,4,"APDD",408.31,408.31)

"BLD",9599,4,"APDD",408.31,408.31,4)

"BLD",9599,4,"B",408.31,408.31)

"BLD",9599,6.3)
26
"BLD",9599,"ABPKG")
n
"BLD",9599,"INID")
^^
"BLD",9599,"KRN",0)
^9.67PA^779.2^20
"BLD",9599,"KRN",.4,0)
.4
"BLD",9599,"KRN",.4,"NM",0)
^9.68A^^
"BLD",9599,"KRN",.401,0)
.401
"BLD",9599,"KRN",.401,"NM",0)
^9.68A^^
"BLD",9599,"KRN",.402,0)
.402
"BLD",9599,"KRN",.402,"NM",0)
^9.68A^^
"BLD",9599,"KRN",.403,0)
.403
"BLD",9599,"KRN",.403,"NM",0)
^9.68A^^
"BLD",9599,"KRN",.5,0)
.5
"BLD",9599,"KRN",.84,0)
.84
"BLD",9599,"KRN",3.6,0)
3.6
"BLD",9599,"KRN",3.8,0)
3.8
"BLD",9599,"KRN",9.2,0)
9.2
"BLD",9599,"KRN",9.8,0)
9.8
"BLD",9599,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",9599,"KRN",9.8,"NM",1,0)
DGMTU23^^0^B32516892
"BLD",9599,"KRN",9.8,"NM","B","DGMTU23",1)

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

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

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

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

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

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

"BLD",9599,"KRN","B",3.6,3.6)

"BLD",9599,"KRN","B",3.8,3.8)

"BLD",9599,"KRN","B",9.2,9.2)

"BLD",9599,"KRN","B",9.8,9.8)

"BLD",9599,"KRN","B",19,19)

"BLD",9599,"KRN","B",19.1,19.1)

"BLD",9599,"KRN","B",101,101)

"BLD",9599,"KRN","B",409.61,409.61)

"BLD",9599,"KRN","B",771,771)

"BLD",9599,"KRN","B",779.2,779.2)

"BLD",9599,"KRN","B",870,870)

"BLD",9599,"KRN","B",8989.51,8989.51)

"BLD",9599,"KRN","B",8989.52,8989.52)

"BLD",9599,"KRN","B",8994,8994)

"BLD",9599,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9599,"QUES",0)
^9.62^^
"BLD",9599,"REQB",0)
^9.611^2^1
"BLD",9599,"REQB",2,0)
DG*5.3*624^2
"BLD",9599,"REQB","B","DG*5.3*624",2)

"FIA",408.31)
ANNUAL MEANS TEST
"FIA",408.31,0)
^DGMT(408.31,
"FIA",408.31,0,0)
408.31ID
"FIA",408.31,0,1)
y^n^p^^^^n^^n
"FIA",408.31,0,10)

"FIA",408.31,0,11)

"FIA",408.31,0,"RLRO")

"FIA",408.31,0,"VR")
5.3^DG
"FIA",408.31,408.31)
1
"FIA",408.31,408.31,4)

"MBREQ")
0
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
904^3150424
"PKG",47,22,1,"PAH",1,1,0)
^^11^11^3150424
"PKG",47,22,1,"PAH",1,1,1,0)
This patch modifies the Registration v5.3 application as described below:
"PKG",47,22,1,"PAH",1,1,2,0)
 
"PKG",47,22,1,"PAH",1,1,3,0)
--   This patch will display a new Beneficiary Travel Financial Indicator
"PKG",47,22,1,"PAH",1,1,4,0)
     on the Means Test and Copay Test overview screens. The BT Financial
"PKG",47,22,1,"PAH",1,1,5,0)
     indicator will be sent from the Enrollment System and share with all
"PKG",47,22,1,"PAH",1,1,6,0)
     sites of record when the Income Verification Matching (IVM)
"PKG",47,22,1,"PAH",1,1,7,0)
     application has performed a Conversion and/or Reversal on an income
"PKG",47,22,1,"PAH",1,1,8,0)
     test where the Veteran had a BT award prior to the IVM action. A
"PKG",47,22,1,"PAH",1,1,9,0)
     bulletin will be generated and sent to the BT CLAIMS PROCESSING
"PKG",47,22,1,"PAH",1,1,10,0)
     Mailgroup to notify select members that there has been a change in
"PKG",47,22,1,"PAH",1,1,11,0)
     the Veteran's BT Financial Indicator status.
"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","DGMTU23")
0^1^B32516892
"RTN","DGMTU23",1,0)
DGMTU23 ;ALB/CAW,LD,LBD,LMD - Display means test information ;12/20/01
"RTN","DGMTU23",2,0)
 ;;5.3;Registration;**33,182,254,272,420,435,456,624,904**;Aug 13, 1993;Build 26
"RTN","DGMTU23",3,0)
 ;
"RTN","DGMTU23",4,0)
 ;
"RTN","DGMTU23",5,0)
DISPLAY(DGMTI,DGMTYPT) ;Display means test data
"RTN","DGMTU23",6,0)
 ;          Input:  DGMTI - IEN of MT
"RTN","DGMTU23",7,0)
 ;                  DGMTYPT - Type of Test
"RTN","DGMTU23",8,0)
 ;         Output:  None
"RTN","DGMTU23",9,0)
 N DGFCOL,DGSCOL,DGMTDIS,DGMTDI2,DGMTWP,WP,X,X1,Y,Y1,Z,DGSOURCE,DGMTI4    ;DG*503*904
"RTN","DGMTU23",10,0)
 S (DGMTWP,WP)=0,DGFCOL=24,DGSCOL=65
"RTN","DGMTU23",11,0)
 I $D(^DGMT(408.31,DGMTI,4)) S DGMTI4=^DGMT(408.31,DGMTI,4)    ;DG*503*904
"RTN","DGMTU23",12,0)
 S DGMTDIS=^DGMT(408.31,DGMTI,0) I $D(^("C")) F  S DGMTWP=$O(^DGMT(408.31,DGMTI,"C",DGMTWP)) Q:'DGMTWP  S DGMTDIS(DGMTWP)=^(DGMTWP,0)
"RTN","DGMTU23",13,0)
 S X="",X=$$SETSTR^VALM1("Patient:",X,15,8)
"RTN","DGMTU23",14,0)
 S X=$$SETSTR^VALM1($P(^DPT($P(DGMTDIS,U,2),0),U),X,DGFCOL,25)
"RTN","DGMTU23",15,0)
 S X=$$SETSTR^VALM1("Date of Test:",X,51,13)
"RTN","DGMTU23",16,0)
 S X=$$SETSTR^VALM1($$FTIME^DGMTUTL($P(DGMTDIS,U)),X,DGSCOL,15)
"RTN","DGMTU23",17,0)
 W !!,X
"RTN","DGMTU23",18,0)
 S X="",X=$$SETSTR^VALM1("Total Dependents:",X,6,17)
"RTN","DGMTU23",19,0)
 S X=$$SETSTR^VALM1($P(DGMTDIS,U,18),X,DGFCOL,25)
"RTN","DGMTU23",20,0)
 S X=$$SETSTR^VALM1("Type Of Test:",X,51,13)
"RTN","DGMTU23",21,0)
 S X=$$SETSTR^VALM1($P($G(^DG(408.33,+$P(DGMTDIS,U,19),0)),U),X,DGSCOL,15)
"RTN","DGMTU23",22,0)
 W !,X
"RTN","DGMTU23",23,0)
 S X="",X=$$SETSTR^VALM1("Status:",X,16,7)
"RTN","DGMTU23",24,0)
 S X=$$SETSTR^VALM1($P(^DG(408.32,$P(DGMTDIS,U,3),0),U),X,DGFCOL,25)
"RTN","DGMTU23",25,0)
 S X=$$SETSTR^VALM1("Date/Time Completed:",X,44,20)
"RTN","DGMTU23",26,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,7)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,7)),1:""),X,DGSCOL,15)
"RTN","DGMTU23",27,0)
 W !,X
"RTN","DGMTU23",28,0)
 S X="",X=$$SETSTR^VALM1("Primary Test For Year:",X,1,22)
"RTN","DGMTU23",29,0)
 S X1=$G(^DGMT(408.31,DGMTI,"PRIM")),X=$$SETSTR^VALM1($S(X1=1:"YES",X1=0:"NO",1:"UNKNOWN"),X,DGFCOL,25)
"RTN","DGMTU23",30,0)
 S X=$$SETSTR^VALM1("Source Of Test:",X,49,15)
"RTN","DGMTU23",31,0)
 S DGSOURCE=$$SR^DGMTAUD1(DGMTDIS)
"RTN","DGMTU23",32,0)
 I DGSOURCE="OTHER FACILITY" S DGSOURCE=$P($G(^DGMT(408.31,DGMTI,2)),"^",5)
"RTN","DGMTU23",33,0)
 S X=$$SETSTR^VALM1(DGSOURCE,X,DGSCOL,15)
"RTN","DGMTU23",34,0)
 W !,X
"RTN","DGMTU23",35,0)
 S X="",X=$$SETSTR^VALM1("Income:",X,16,7)
"RTN","DGMTU23",36,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,4)'="":"$"_$P(DGMTDIS,U,4),1:""),X,DGFCOL,25)
"RTN","DGMTU23",37,0)
 S X=$$SETSTR^VALM1("Completed By:",X,51,13)
"RTN","DGMTU23",38,0)
 S X=$$SETSTR^VALM1($P($G(^VA(200,+$P(DGMTDIS,U,6),0)),U),X,DGSCOL,15)
"RTN","DGMTU23",39,0)
 W !,X
"RTN","DGMTU23",40,0)
 S X=""
"RTN","DGMTU23",41,0)
 I DGMTYPT=1 D
"RTN","DGMTU23",42,0)
 .S X=$$SETSTR^VALM1("Net Worth:",X,13,10)
"RTN","DGMTU23",43,0)
 .S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,5)'="":"$"_$P(DGMTDIS,U,5),1:""),X,DGFCOL,25)
"RTN","DGMTU23",44,0)
 .S X=$$SETSTR^VALM1("Date/Time Category Changed:",X,37,28)
"RTN","DGMTU23",45,0)
 .S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,9)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,9)),1:""),X,DGSCOL,15)
"RTN","DGMTU23",46,0)
 .W !,X
"RTN","DGMTU23",47,0)
 S X=""
"RTN","DGMTU23",48,0)
 S X=$$SETSTR^VALM1("Deductible Expenses:",X,3,20)
"RTN","DGMTU23",49,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,15)'="":$$AMT^DGMTSCU1($P(DGMTDIS,U,15)),1:""),X,DGFCOL,25)
"RTN","DGMTU23",50,0)
 I DGMTYPT=1 D
"RTN","DGMTU23",51,0)
 .S X=$$SETSTR^VALM1("Category Changed By:",X,44,25)
"RTN","DGMTU23",52,0)
 .S X=$$SETSTR^VALM1($P($G(^VA(200,+$P(DGMTDIS,U,8),0)),U),X,DGSCOL,15)
"RTN","DGMTU23",53,0)
 W !,X
"RTN","DGMTU23",54,0)
 S X=""
"RTN","DGMTU23",55,0)
 I DGMTYPT=1 D
"RTN","DGMTU23",56,0)
 .S X=$$SETSTR^VALM1("Agreed to Pay Deduct.:",X,1,22)
"RTN","DGMTU23",57,0)
 .S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,11)=1:"YES",$P(DGMTDIS,U,11)=0:"NO",1:""),X,DGFCOL,25)
"RTN","DGMTU23",58,0)
 .S X=$$SETSTR^VALM1("Adjudicated Date/Time:",X,42,28)
"RTN","DGMTU23",59,0)
 .S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,10)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,10)),1:""),X,DGSCOL,15)
"RTN","DGMTU23",60,0)
 .W !,X
"RTN","DGMTU23",61,0)
 S X=""
"RTN","DGMTU23",62,0)
 S X=$$SETSTR^VALM1("Declines Income Info:",X,2,21)
"RTN","DGMTU23",63,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,14)=1:"YES",$P(DGMTDIS,U,14)=0:"NO",1:""),X,DGFCOL,25)
"RTN","DGMTU23",64,0)
 S Y=$S(DGMTYPT=1:"No Longer Required Date:",1:"No Longer Applicable Date:"),Z=$S(DGMTYPT=1:40,1:38)
"RTN","DGMTU23",65,0)
 S X=$$SETSTR^VALM1(Y,X,Z,28)
"RTN","DGMTU23",66,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,17)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,17)),1:""),X,DGSCOL,15)
"RTN","DGMTU23",67,0)
 W !,X
"RTN","DGMTU23",68,0)
 S (X,Y)=""
"RTN","DGMTU23",69,0)
 I DGMTYPT=1 D
"RTN","DGMTU23",70,0)
 .S X=$$SETSTR^VALM1("MT Threshold:",X,10,13)
"RTN","DGMTU23",71,0)
 .S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,12)'="":"$"_$P(DGMTDIS,U,12),1:""),X,DGFCOL,25)
"RTN","DGMTU23",72,0)
 .I $P(DGMTDIS,U,20) D
"RTN","DGMTU23",73,0)
 ..S X=$$SETSTR^VALM1("Hardship Review Date:",X,43,21)
"RTN","DGMTU23",74,0)
 ..S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,21)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,21)),1:""),X,DGSCOL,15)
"RTN","DGMTU23",75,0)
 .W !,X
"RTN","DGMTU23",76,0)
 ;
"RTN","DGMTU23",77,0)
 S X=""
"RTN","DGMTU23",78,0)
 S X=$$SETSTR^VALM1("GMT Threshold:",X,9,14)
"RTN","DGMTU23",79,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,27)'="":"$"_$P(DGMTDIS,U,27),1:""),X,DGFCOL,25)
"RTN","DGMTU23",80,0)
 S X=$$SETSTR^VALM1("BT Financial Indicator:",X,41,23)      ;DG*5.3*904
"RTN","DGMTU23",81,0)
 I $D(DGMTI4) S X=$$SETSTR^VALM1($S($P(DGMTI4,U,1)=1:"YES",$P(DGMTI4,U,1)=0:"NO",1:""),X,DGSCOL,3)   ;DG*503*904
"RTN","DGMTU23",82,0)
 W !,X
"RTN","DGMTU23",83,0)
 ;
"RTN","DGMTU23",84,0)
 S X=""
"RTN","DGMTU23",85,0)
 S X=$$SETSTR^VALM1("Date Vet Signed Test:",X,2,21)
"RTN","DGMTU23",86,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,24)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,24)),1:""),X,DGFCOL,25)
"RTN","DGMTU23",87,0)
 I $G(^DGMT(408.31,DGMTI,"PURGE"))'="" D
"RTN","DGMTU23",88,0)
 .S X=$$SETSTR^VALM1("Income Data Purged:",X,45,19)
"RTN","DGMTU23",89,0)
 .S X1=^DGMT(408.31,DGMTI,"PURGE")
"RTN","DGMTU23",90,0)
 .S X=$$SETSTR^VALM1($$FTIME^DGMTUTL(X1),X,DGSCOL,15)
"RTN","DGMTU23",91,0)
 W !,X
"RTN","DGMTU23",92,0)
 ;
"RTN","DGMTU23",93,0)
 S X=""
"RTN","DGMTU23",94,0)
 S X=$$SETSTR^VALM1("Means Test Signed?:",X,4,19)
"RTN","DGMTU23",95,0)
 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,29)=1:"YES",$P(DGMTDIS,U,29)=0:"NO",$P(DGMTDIS,U,29)=9:"DELETED",1:""),X,DGFCOL,25)
"RTN","DGMTU23",96,0)
 W !,X
"RTN","DGMTU23",97,0)
 ;
"RTN","DGMTU23",98,0)
 S (X,Y,Y1,Z)=""
"RTN","DGMTU23",99,0)
 I DGMTYPT=1 D
"RTN","DGMTU23",100,0)
 .I $P($G(^DG(408.34,+$P(DGMTDIS,U,23),0)),U)="IVM" D
"RTN","DGMTU23",101,0)
 ..;S X=$$SETSTR^VALM1("Date Vet Signed Test:",X,2,21)
"RTN","DGMTU23",102,0)
 ..;S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,24)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,24)),1:""),X,DGFCOL,25)
"RTN","DGMTU23",103,0)
 ..S Y=$$SETSTR^VALM1("Refused to Sign:",Y,7,16)
"RTN","DGMTU23",104,0)
 ..S Y=$$SETSTR^VALM1($S($P(DGMTDIS,U,26)=1:"YES",$P(DGMTDIS,U,26)=0:"NO",1:""),Y,DGFCOL,25)
"RTN","DGMTU23",105,0)
 ..S Z=$$SETSTR^VALM1("Date IVM MT Completed:",Z,1,22)
"RTN","DGMTU23",106,0)
 ..S Z=$$SETSTR^VALM1($S($P(DGMTDIS,U,25)'="":$$FTIME^DGMTUTL($P(DGMTDIS,U,25)),1:""),Z,DGFCOL,25)
"RTN","DGMTU23",107,0)
 .I $P(DGMTDIS,U,21) D
"RTN","DGMTU23",108,0)
 ..S DGMTDI2=$G(^DGMT(408.31,DGMTI,2))
"RTN","DGMTU23",109,0)
 ..S X=$$SETSTR^VALM1("Hardship Approved By:",X,43,21)
"RTN","DGMTU23",110,0)
 ..I +$P(DGMTDI2,U,4)=$$INST^DGENU() D
"RTN","DGMTU23",111,0)
 ...S X=$$SETSTR^VALM1($P($G(^VA(200,+$P(DGMTDIS,U,22),0)),U),X,DGSCOL,15)
"RTN","DGMTU23",112,0)
 ..E  S X=$$SETSTR^VALM1("OTHER VAMC",X,DGSCOL,15)
"RTN","DGMTU23",113,0)
 ..S Y=$$SETSTR^VALM1("Hardship Review Site:",Y,43,21)
"RTN","DGMTU23",114,0)
 ..S Y=$$SETSTR^VALM1($P($G(^DIC(4,+$P(DGMTDI2,"^",4),0)),"^"),Y,DGSCOL,15)
"RTN","DGMTU23",115,0)
 ..S Y1=$$SETSTR^VALM1("Hardship Reason:",Y1,7,16)
"RTN","DGMTU23",116,0)
 ..S Y1=$$SETSTR^VALM1($P(DGMTDI2,U,9),Y1,DGFCOL,80)
"RTN","DGMTU23",117,0)
 .W !,X,!,Y,!,Y1,!,Z
"RTN","DGMTU23",118,0)
 W !,"COMMENT(S):" F  S WP=$O(DGMTDIS(WP)) Q:'WP  D
"RTN","DGMTU23",119,0)
 .W !,DGMTDIS(WP)
"RTN","DGMTU23",120,0)
 Q
"VER")
8.0^22.0
"^DD",408.31,408.31,4,0)
BT FINANCIAL INDICATOR^SI^0:NO;1:YES;^4;1^Q
"^DD",408.31,408.31,4,3)
Enter a 'Y' to indicate financially eligible for Beneficiary Travel, 'N' for not financially eligible for Beneficiary Travel.
"^DD",408.31,408.31,4,21,0)
^^2^2^3140930^
"^DD",408.31,408.31,4,21,1,0)
This indicator states a Veteran's eligibility for Beneficiary Travel based
"^DD",408.31,408.31,4,21,2,0)
on their income.
"^DD",408.31,408.31,4,"DT")
3141002
**INSTALL NAME**
EAS*1.0*113
"BLD",9597,0)
EAS*1.0*113^ENROLLMENT APPLICATION SYSTEM^0^3150424^y
"BLD",9597,1,0)
^^58^58^3150205^
"BLD",9597,1,1,0)
  The Health Eligibility Center (HEC) requested modifications to the 
"BLD",9597,1,2,0)
  Enrollment System (ES) and VistA Registration, Enrollment and
"BLD",9597,1,3,0)
  Eligibility (VistA REE) software to support the requirements of the
"BLD",9597,1,4,0)
  Veterans Financial Assessment (VFA) projects.
"BLD",9597,1,5,0)
 
"BLD",9597,1,6,0)
  This patch modifies the Enrollment Application System V1.0 application
"BLD",9597,1,7,0)
  as described below:
"BLD",9597,1,8,0)
 
"BLD",9597,1,9,0)
     Add a Beneficiary Travel Bulletin.
"BLD",9597,1,10,0)
  ----------------------------------------------------------
"BLD",9597,1,11,0)
  Due to the Income Verification Match (IVM) process, the BT CLAIMS
"BLD",9597,1,12,0)
  PROCESSING Mailgroup will be automatically created in VistA with the
"BLD",9597,1,13,0)
  installation of this patch at each VistA Site. VistA users are
"BLD",9597,1,14,0)
  responsible for adding the appropriate members to the Mailgroup.  The
"BLD",9597,1,15,0)
  appropriate VistA staff are added to the Mailgroup when they want to be
"BLD",9597,1,16,0)
  notified of a change in the Veteran's BT Financial Indicator status.
"BLD",9597,1,17,0)
  The bulletin that will be loaded with this patch is called EAS BT CLAIMS
"BLD",9597,1,18,0)
  PROCESSING.
"BLD",9597,1,19,0)
 
"BLD",9597,1,20,0)
  The bulletin will be sent to each member of the Mailgroup and will
"BLD",9597,1,21,0)
  contain the following information:
"BLD",9597,1,22,0)
 
"BLD",9597,1,23,0)
  Mail Message From: Health EligibilityCenter    Date: MM/DD/YYYY HH:MM
"BLD",9597,1,24,0)
  Subject: IVM-Beneficiary Travel Financial Indicator upload FOR<DFN>
"BLD",9597,1,25,0)
 
"BLD",9597,1,26,0)
  An Income Verification Match verified Beneficiary Travel information
"BLD",9597,1,27,0)
  has been uploaded for the following patient.
"BLD",9597,1,28,0)
 
"BLD",9597,1,29,0)
  Patient Name:
"BLD",9597,1,30,0)
  LAST 4 OF SSN:  
"BLD",9597,1,31,0)
  ICN:
"BLD",9597,1,32,0)
  DFN:
"BLD",9597,1,33,0)
  STATION NUMBER:
"BLD",9597,1,34,0)
  Prev Category:
"BLD",9597,1,35,0)
  New Category:
"BLD",9597,1,36,0)
  Date of Test:
"BLD",9597,1,37,0)
  Income Year of Conversion:
"BLD",9597,1,38,0)
 
"BLD",9597,1,39,0)
  - When a converted/reversal Rx Copay Test is received from IVM, a
"BLD",9597,1,40,0)
    check will be done to see if the new copay exemption status is
"BLD",9597,1,41,0)
    different than the old copay exemption status (e.g. the new status is
"BLD",9597,1,42,0)
    NON-EXEMPT and the old status is EXEMPT, or the new status is EXEMPT
"BLD",9597,1,43,0)
    and the old status is NON-EXEMPT).
"BLD",9597,1,44,0)
  - If the status has changed, a check will be done to see if the 
"BLD",9597,1,45,0)
    Beneficiary Travel indicator has changed.  If indicator changed, a
"BLD",9597,1,46,0)
    a bulletin will be sent to the BT CLAIMS PROCESSING Mailgroup.
"BLD",9597,1,47,0)
 
"BLD",9597,1,48,0)
   HL7 Changes
"BLD",9597,1,49,0)
  ----------------------------------------------------------
"BLD",9597,1,50,0)
  This patch supports HL7 enhancements that sends BT Financial Indicator 
"BLD",9597,1,51,0)
  Z06 ZMT-32 and Contributed to Spouse Z10 ZIR-2 and stores them in the 
"BLD",9597,1,52,0)
  database. Supports HL7 Z07 ZIR-15 that sends VistA Contributed to Spouse
"BLD",9597,1,53,0)
  changes to ES. Patch DG*5.3*890 will be released in conjunction with
"BLD",9597,1,54,0)
  this EAS patch.
"BLD",9597,1,55,0)
  Modified Z07 message builder to include the Contributed to Spouse 
"BLD",9597,1,56,0)
  indicator on the ORU Z07 ZIR segment.
"BLD",9597,1,57,0)
  Added a trigger for an ORF Z07 message when a change is made to 
"BLD",9597,1,58,0)
  the Contributed to Spouse indicator.
"BLD",9597,4,0)
^9.64PA^^
"BLD",9597,6.3)
53
"BLD",9597,"ABPKG")
n
"BLD",9597,"INID")
n^n^n
"BLD",9597,"INIT")
EAS1113P
"BLD",9597,"KRN",0)
^9.67PA^779.2^20
"BLD",9597,"KRN",.4,0)
.4
"BLD",9597,"KRN",.4,"NM",0)
^9.68A^^
"BLD",9597,"KRN",.401,0)
.401
"BLD",9597,"KRN",.402,0)
.402
"BLD",9597,"KRN",.403,0)
.403
"BLD",9597,"KRN",.5,0)
.5
"BLD",9597,"KRN",.84,0)
.84
"BLD",9597,"KRN",3.6,0)
3.6
"BLD",9597,"KRN",3.6,"NM",0)
^9.68A^1^1
"BLD",9597,"KRN",3.6,"NM",1,0)
EAS BT CLAIMS PROCESSING^^0
"BLD",9597,"KRN",3.6,"NM","B","EAS BT CLAIMS PROCESSING",1)

"BLD",9597,"KRN",3.8,0)
3.8
"BLD",9597,"KRN",3.8,"NM",0)
^9.68A^1^1
"BLD",9597,"KRN",3.8,"NM",1,0)
BT CLAIMS PROCESSING^^0
"BLD",9597,"KRN",3.8,"NM","B","BT CLAIMS PROCESSING",1)

"BLD",9597,"KRN",9.2,0)
9.2
"BLD",9597,"KRN",9.2,"NM",0)
^9.68A^^
"BLD",9597,"KRN",9.8,0)
9.8
"BLD",9597,"KRN",9.8,"NM",0)
^9.68A^9^8
"BLD",9597,"KRN",9.8,"NM",1,0)
EASPREC6^^0^B95603593
"BLD",9597,"KRN",9.8,"NM",2,0)
EASUM6^^0^B31577950
"BLD",9597,"KRN",9.8,"NM",3,0)
EASBTBUL^^0^B5431051
"BLD",9597,"KRN",9.8,"NM",5,0)
EASPREC3^^0^B11588856
"BLD",9597,"KRN",9.8,"NM",6,0)
EASUM1^^0^B30155239
"BLD",9597,"KRN",9.8,"NM",7,0)
EASUM5^^0^B16512870
"BLD",9597,"KRN",9.8,"NM",8,0)
EASPREC7^^0^B79134294
"BLD",9597,"KRN",9.8,"NM",9,0)
EAS1113P^^0^B5460770
"BLD",9597,"KRN",9.8,"NM","B","EAS1113P",9)

"BLD",9597,"KRN",9.8,"NM","B","EASBTBUL",3)

"BLD",9597,"KRN",9.8,"NM","B","EASPREC3",5)

"BLD",9597,"KRN",9.8,"NM","B","EASPREC6",1)

"BLD",9597,"KRN",9.8,"NM","B","EASPREC7",8)

"BLD",9597,"KRN",9.8,"NM","B","EASUM1",6)

"BLD",9597,"KRN",9.8,"NM","B","EASUM5",7)

"BLD",9597,"KRN",9.8,"NM","B","EASUM6",2)

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

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

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

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

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

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

"BLD",9597,"KRN","B",3.6,3.6)

"BLD",9597,"KRN","B",3.8,3.8)

"BLD",9597,"KRN","B",9.2,9.2)

"BLD",9597,"KRN","B",9.8,9.8)

"BLD",9597,"KRN","B",19,19)

"BLD",9597,"KRN","B",19.1,19.1)

"BLD",9597,"KRN","B",101,101)

"BLD",9597,"KRN","B",409.61,409.61)

"BLD",9597,"KRN","B",771,771)

"BLD",9597,"KRN","B",779.2,779.2)

"BLD",9597,"KRN","B",870,870)

"BLD",9597,"KRN","B",8989.51,8989.51)

"BLD",9597,"KRN","B",8989.52,8989.52)

"BLD",9597,"KRN","B",8994,8994)

"BLD",9597,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9597,"QUES",0)
^9.62^^
"BLD",9597,"REQB",0)
^9.611^5^4
"BLD",9597,"REQB",1,0)
EAS*1.0*111^2
"BLD",9597,"REQB",4,0)
DG*5.3*890^2
"BLD",9597,"REQB",5,0)
EAS*1.0*86^2
"BLD",9597,"REQB","B","DG*5.3*890",4)

"BLD",9597,"REQB","B","EAS*1.0*111",1)

"BLD",9597,"REQB","B","EAS*1.0*86",5)

"INIT")
EAS1113P
"KRN",3.6,209,-1)
0^1
"KRN",3.6,209,0)
EAS BT CLAIMS PROCESSING^IVM - Beneficiary Travel Financial Indicator UPLOAD FOR |10|^7^0
"KRN",3.6,209,1,0)
^3.61A^23^23^3150223^^^^
"KRN",3.6,209,1,1,0)
 
"KRN",3.6,209,1,2,0)
 
"KRN",3.6,209,1,3,0)
An Income Verification Match verified Beneficiary Travel Information has 
"KRN",3.6,209,1,4,0)
been uploaded for the following patient.
"KRN",3.6,209,1,5,0)
 
"KRN",3.6,209,1,6,0)
 
"KRN",3.6,209,1,7,0)
Patient Name:  |1|
"KRN",3.6,209,1,8,0)
 
"KRN",3.6,209,1,9,0)
Last 4 of SSN:  |2|
"KRN",3.6,209,1,10,0)
 
"KRN",3.6,209,1,11,0)
ICN:  |3|    
"KRN",3.6,209,1,12,0)
 
"KRN",3.6,209,1,13,0)
DFN:  |4|
"KRN",3.6,209,1,14,0)
 
"KRN",3.6,209,1,15,0)
STATION NUMBER:  |5|
"KRN",3.6,209,1,16,0)
 
"KRN",3.6,209,1,17,0)
Prev Category:  |6|
"KRN",3.6,209,1,18,0)
 
"KRN",3.6,209,1,19,0)
New Category:  |7|
"KRN",3.6,209,1,20,0)
 
"KRN",3.6,209,1,21,0)
Date of Test:  |8|
"KRN",3.6,209,1,22,0)
 
"KRN",3.6,209,1,23,0)
Income Year of Conversion:  |9|
"KRN",3.6,209,3,0)
^3.63^5^5^3150223^^^^
"KRN",3.6,209,3,1,0)
The VistA System will trigger a BT Bulletin so that the appropriate VistA 
"KRN",3.6,209,3,2,0)
staff will be notified of a change in the BT Financial Indicator. A 
"KRN",3.6,209,3,3,0)
bulletin will be triggered in VistA and sent to the BT Claims Processing
"KRN",3.6,209,3,4,0)
mail group when there is a change to the BT Financial Indicator received
"KRN",3.6,209,3,5,0)
from the Enrollment System.
"KRN",3.6,209,4,0)
^3.64A^6^6
"KRN",3.6,209,4,1,0)
1
"KRN",3.6,209,4,2,0)
2
"KRN",3.6,209,4,3,0)
3
"KRN",3.6,209,4,4,0)
4
"KRN",3.6,209,4,5,0)
5
"KRN",3.6,209,4,6,0)
6
"KRN",3.8,316,-1)
0^1
"KRN",3.8,316,0)
BT CLAIMS PROCESSING^PU^n^^^^
"KRN",3.8,316,2,0)
^3.801^6^6^3150223^^^
"KRN",3.8,316,2,1,0)
The BT Claims Processing mail group is established to provide a
"KRN",3.8,316,2,2,0)
central source of information on Veterans identified during the IVM
"KRN",3.8,316,2,3,0)
process to meet BT administrative eligibility for payment based on income
"KRN",3.8,316,2,4,0)
that is determined to be inaccurate.   Members of the mail group when
"KRN",3.8,316,2,5,0)
notified will review the BT claim database for any payments provided based
"KRN",3.8,316,2,6,0)
on inaccurate income during the identified period.
"KRN",3.8,316,3)

"MBREQ")
0
"ORD",2,3.6)
3.6;2;1;;BUL^XPDTA1;;BULE1^XPDIA1;;;BULDEL^XPDIA1
"ORD",2,3.6,0)
BULLETIN
"ORD",11,3.8)
3.8;11;;;MAILG^XPDTA1;MAILGF1^XPDIA1;MAILGE1^XPDIA1;MAILGF2^XPDIA1;;MAILGDEL^XPDIA1(%)
"ORD",11,3.8,0)
MAIL GROUP
"PKG",187,-1)
1^1
"PKG",187,0)
ENROLLMENT APPLICATION SYSTEM^EAS^ENROLLMENT
"PKG",187,20,0)
^9.402P^1^1
"PKG",187,20,1,0)
2^^EASXDR
"PKG",187,20,1,1)
 
"PKG",187,20,"B",2,1)

"PKG",187,22,0)
^9.49I^1^1
"PKG",187,22,1,0)
1.0^3010315^3010321^66481
"PKG",187,22,1,"PAH",1,0)
113^3150424
"PKG",187,22,1,"PAH",1,1,0)
^^58^58^3150424
"PKG",187,22,1,"PAH",1,1,1,0)
  The Health Eligibility Center (HEC) requested modifications to the 
"PKG",187,22,1,"PAH",1,1,2,0)
  Enrollment System (ES) and VistA Registration, Enrollment and
"PKG",187,22,1,"PAH",1,1,3,0)
  Eligibility (VistA REE) software to support the requirements of the
"PKG",187,22,1,"PAH",1,1,4,0)
  Veterans Financial Assessment (VFA) projects.
"PKG",187,22,1,"PAH",1,1,5,0)
 
"PKG",187,22,1,"PAH",1,1,6,0)
  This patch modifies the Enrollment Application System V1.0 application
"PKG",187,22,1,"PAH",1,1,7,0)
  as described below:
"PKG",187,22,1,"PAH",1,1,8,0)
 
"PKG",187,22,1,"PAH",1,1,9,0)
     Add a Beneficiary Travel Bulletin.
"PKG",187,22,1,"PAH",1,1,10,0)
  ----------------------------------------------------------
"PKG",187,22,1,"PAH",1,1,11,0)
  Due to the Income Verification Match (IVM) process, the BT CLAIMS
"PKG",187,22,1,"PAH",1,1,12,0)
  PROCESSING Mailgroup will be automatically created in VistA with the
"PKG",187,22,1,"PAH",1,1,13,0)
  installation of this patch at each VistA Site. VistA users are
"PKG",187,22,1,"PAH",1,1,14,0)
  responsible for adding the appropriate members to the Mailgroup.  The
"PKG",187,22,1,"PAH",1,1,15,0)
  appropriate VistA staff are added to the Mailgroup when they want to be
"PKG",187,22,1,"PAH",1,1,16,0)
  notified of a change in the Veteran's BT Financial Indicator status.
"PKG",187,22,1,"PAH",1,1,17,0)
  The bulletin that will be loaded with this patch is called EAS BT CLAIMS
"PKG",187,22,1,"PAH",1,1,18,0)
  PROCESSING.
"PKG",187,22,1,"PAH",1,1,19,0)
 
"PKG",187,22,1,"PAH",1,1,20,0)
  The bulletin will be sent to each member of the Mailgroup and will
"PKG",187,22,1,"PAH",1,1,21,0)
  contain the following information:
"PKG",187,22,1,"PAH",1,1,22,0)
 
"PKG",187,22,1,"PAH",1,1,23,0)
  Mail Message From: Health EligibilityCenter    Date: MM/DD/YYYY HH:MM
"PKG",187,22,1,"PAH",1,1,24,0)
  Subject: IVM-Beneficiary Travel Financial Indicator upload FOR<DFN>
"PKG",187,22,1,"PAH",1,1,25,0)
 
"PKG",187,22,1,"PAH",1,1,26,0)
  An Income Verification Match verified Beneficiary Travel information
"PKG",187,22,1,"PAH",1,1,27,0)
  has been uploaded for the following patient.
"PKG",187,22,1,"PAH",1,1,28,0)
 
"PKG",187,22,1,"PAH",1,1,29,0)
  Patient Name:
"PKG",187,22,1,"PAH",1,1,30,0)
  LAST 4 OF SSN:  
"PKG",187,22,1,"PAH",1,1,31,0)
  ICN:
"PKG",187,22,1,"PAH",1,1,32,0)
  DFN:
"PKG",187,22,1,"PAH",1,1,33,0)
  STATION NUMBER:
"PKG",187,22,1,"PAH",1,1,34,0)
  Prev Category:
"PKG",187,22,1,"PAH",1,1,35,0)
  New Category:
"PKG",187,22,1,"PAH",1,1,36,0)
  Date of Test:
"PKG",187,22,1,"PAH",1,1,37,0)
  Income Year of Conversion:
"PKG",187,22,1,"PAH",1,1,38,0)
 
"PKG",187,22,1,"PAH",1,1,39,0)
  - When a converted/reversal Rx Copay Test is received from IVM, a
"PKG",187,22,1,"PAH",1,1,40,0)
    check will be done to see if the new copay exemption status is
"PKG",187,22,1,"PAH",1,1,41,0)
    different than the old copay exemption status (e.g. the new status is
"PKG",187,22,1,"PAH",1,1,42,0)
    NON-EXEMPT and the old status is EXEMPT, or the new status is EXEMPT
"PKG",187,22,1,"PAH",1,1,43,0)
    and the old status is NON-EXEMPT).
"PKG",187,22,1,"PAH",1,1,44,0)
  - If the status has changed, a check will be done to see if the 
"PKG",187,22,1,"PAH",1,1,45,0)
    Beneficiary Travel indicator has changed.  If indicator changed, a
"PKG",187,22,1,"PAH",1,1,46,0)
    a bulletin will be sent to the BT CLAIMS PROCESSING Mailgroup.
"PKG",187,22,1,"PAH",1,1,47,0)
 
"PKG",187,22,1,"PAH",1,1,48,0)
   HL7 Changes
"PKG",187,22,1,"PAH",1,1,49,0)
  ----------------------------------------------------------
"PKG",187,22,1,"PAH",1,1,50,0)
  This patch supports HL7 enhancements that sends BT Financial Indicator 
"PKG",187,22,1,"PAH",1,1,51,0)
  Z06 ZMT-32 and Contributed to Spouse Z10 ZIR-2 and stores them in the 
"PKG",187,22,1,"PAH",1,1,52,0)
  database. Supports HL7 Z07 ZIR-15 that sends VistA Contributed to Spouse
"PKG",187,22,1,"PAH",1,1,53,0)
  changes to ES. Patch DG*5.3*890 will be released in conjunction with
"PKG",187,22,1,"PAH",1,1,54,0)
  this EAS patch.
"PKG",187,22,1,"PAH",1,1,55,0)
  Modified Z07 message builder to include the Contributed to Spouse 
"PKG",187,22,1,"PAH",1,1,56,0)
  indicator on the ORU Z07 ZIR segment.
"PKG",187,22,1,"PAH",1,1,57,0)
  Added a trigger for an ORF Z07 message when a change is made to 
"PKG",187,22,1,"PAH",1,1,58,0)
  the Contributed to Spouse indicator.
"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")
8
"RTN","EAS1113P")
0^9^B5460770
"RTN","EAS1113P",1,0)
EAS1113P  ;ALB/TGH - Patch EAS*1.0*113 Post Install ;02/20/2015 8:43am
"RTN","EAS1113P",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**113**;FEB 20, 2015;Build 53
"RTN","EAS1113P",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EAS1113P",4,0)
 ;
"RTN","EAS1113P",5,0)
 ; EAS*1*113 Post Install will add BT CLAIMS PROCESSING Mail Group to 
"RTN","EAS1113P",6,0)
 ; EAS BT CLAIMS PROCESSING Bulletin 
"RTN","EAS1113P",7,0)
 ;
"RTN","EAS1113P",8,0)
EN  ;
"RTN","EAS1113P",9,0)
 ; If the BT CLAIMS PROCESSING Mail Group is already set up for the EAS 
"RTN","EAS1113P",10,0)
 ; BT CLAIMS PROCESSING Bulletin, Quit and write message to screen and do
"RTN","EAS1113P",11,0)
 ; not continue
"RTN","EAS1113P",12,0)
 N BUL,MG
"RTN","EAS1113P",13,0)
 S MG=$$FIND1^DIC(3.8,,"BX","BT CLAIMS PROCESSING")
"RTN","EAS1113P",14,0)
 S BUL=$$FIND1^DIC(3.6,,"BX","EAS BT CLAIMS PROCESSING")
"RTN","EAS1113P",15,0)
 I $D(^XMB(3.6,BUL,2,"B",MG)) D  Q
"RTN","EAS1113P",16,0)
 . N ARR
"RTN","EAS1113P",17,0)
 . S ARR(1)="========================================================"
"RTN","EAS1113P",18,0)
 . S ARR(2)="Mail Group already set. Update of Bulletin Not Required."
"RTN","EAS1113P",19,0)
 . S ARR(3)="========================================================"
"RTN","EAS1113P",20,0)
 . D BMES^XPDUTL(.ARR)
"RTN","EAS1113P",21,0)
 ;
"RTN","EAS1113P",22,0)
 ; Otherwise, set Mail Group into Bulletin
"RTN","EAS1113P",23,0)
 N IENS,FDA,ERROR,ERR,TXT
"RTN","EAS1113P",24,0)
 S IENS="+1,"_BUL_","
"RTN","EAS1113P",25,0)
 S FDA(3.62,IENS,.01)=MG
"RTN","EAS1113P",26,0)
 D UPDATE^DIE("","FDA","","ERROR")
"RTN","EAS1113P",27,0)
 ;
"RTN","EAS1113P",28,0)
 ; Process errors if any exist and display to screen
"RTN","EAS1113P",29,0)
 S ERR="" F  S ERR=$O(ERROR("DIERR",ERR)) Q:ERR=""  D
"RTN","EAS1113P",30,0)
 . S TXT="" F  S TXT=$O(ERROR("DIERR",ERR,"TEXT",TXT)) Q:TXT=""  D
"RTN","EAS1113P",31,0)
 . . D ERROR(ERROR("DIERR",ERR,"TEXT",TXT))
"RTN","EAS1113P",32,0)
 ;
"RTN","EAS1113P",33,0)
 ; Print success message to screen if no Errors
"RTN","EAS1113P",34,0)
 I '$D(ERROR("DIERR")) D
"RTN","EAS1113P",35,0)
 . N ARR
"RTN","EAS1113P",36,0)
 . S ARR(1)="========================================================"
"RTN","EAS1113P",37,0)
 . S ARR(2)="BT CLAIMS PROCESSING Mail Group has been successfully"
"RTN","EAS1113P",38,0)
 . S ARR(3)="added to EAS BT CLAIMS PROCESSING Bulletin."
"RTN","EAS1113P",39,0)
 . S ARR(4)="========================================================"
"RTN","EAS1113P",40,0)
 . D BMES^XPDUTL(.ARR)
"RTN","EAS1113P",41,0)
 ;
"RTN","EAS1113P",42,0)
 Q  ; EN
"RTN","EAS1113P",43,0)
 ;
"RTN","EAS1113P",44,0)
ERROR(ERRMSG) ;Display error message
"RTN","EAS1113P",45,0)
 ;
"RTN","EAS1113P",46,0)
 N ARR
"RTN","EAS1113P",47,0)
 S ARR(1)="===================================================="
"RTN","EAS1113P",48,0)
 S ARR(2)="= ERROR ="
"RTN","EAS1113P",49,0)
 S ARR(3)="===================================================="
"RTN","EAS1113P",50,0)
 S ARR(4)="While updating Bulletin with Mail Group"
"RTN","EAS1113P",51,0)
 S ARR(5)="===================================================="
"RTN","EAS1113P",52,0)
 S ARR(6)="**ERROR MSG: "_ERRMSG
"RTN","EAS1113P",53,0)
 ;
"RTN","EAS1113P",54,0)
 D BMES^XPDUTL(.ARR)
"RTN","EAS1113P",55,0)
 ;
"RTN","EAS1113P",56,0)
 Q
"RTN","EASBTBUL")
0^3^B5431051
"RTN","EASBTBUL",1,0)
EASBTBUL  ;ALB/DHS,LMD - Beneficiary Travel Bulletin - Create and Send ;10/30/2014 8:43am
"RTN","EASBTBUL",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**113**;OCT 31, 2014;Build 53
"RTN","EASBTBUL",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EASBTBUL",4,0)
 ;
"RTN","EASBTBUL",5,0)
 ; EAS*1*113 Send Bulletin if BTFI is different than what is on file
"RTN","EASBTBUL",6,0)
 ;
"RTN","EASBTBUL",7,0)
 ; this routine will send the Beneficiary Travel Bulletin for the specified conditions:
"RTN","EASBTBUL",8,0)
 ; When a converted/reversal Rx Copay Test is received from IVM, a check will be done to
"RTN","EASBTBUL",9,0)
 ; see if the new copay exemption status is different than the old copay exemption status.
"RTN","EASBTBUL",10,0)
 ; If the status has changed, Beneficiary Travel Eligible indicator a bulletin will be sent
"RTN","EASBTBUL",11,0)
 ; to the BT CLAIMS PROCESSING mail group.
"RTN","EASBTBUL",12,0)
 ;
"RTN","EASBTBUL",13,0)
 ; This routine is called from EASPREC6 and EASPREC7 at the end of ORU-Z06 processing ;EASPREC6
"RTN","EASBTBUL",14,0)
 ;
"RTN","EASBTBUL",15,0)
SET(DFN,DT,DGCAT,IVMCEB,IVM10) ; Create and Send BT Bulletin
"RTN","EASBTBUL",16,0)
 ;
"RTN","EASBTBUL",17,0)
 ; Input:
"RTN","EASBTBUL",18,0)
 ; DFN = IEN of Patient
"RTN","EASBTBUL",19,0)
 ; DT = Today's Date
"RTN","EASBTBUL",20,0)
 ; DGCAT = Current Means Test Status
"RTN","EASBTBUL",21,0)
 ; IVMCEB = Previous Means Test Status
"RTN","EASBTBUL",22,0)
 ; IVM10 = Date/Time Test Completed
"RTN","EASBTBUL",23,0)
 ;
"RTN","EASBTBUL",24,0)
 N IFN,DATA,SSN,X
"RTN","EASBTBUL",25,0)
 ;
"RTN","EASBTBUL",26,0)
 ;SSN
"RTN","EASBTBUL",27,0)
 I $D(^DPT(DFN,.36)) S X=^DPT(DFN,.36) I +X S SSN=$P(X,"^",4)
"RTN","EASBTBUL",28,0)
 I SSN="" S X=$P(^DPT(DFN,0),"^",9) I X]"" S SSN=$E(X,6,10)
"RTN","EASBTBUL",29,0)
 ;
"RTN","EASBTBUL",30,0)
 ; External Reference to ^DGBT(392.2 supported by DBIA #6015  ;DS THIS FILE DATA DOESNT EXIST
"RTN","EASBTBUL",31,0)
 S IFN=$$FIND1^DIC(392.2,"","MXQ",DFN,"","","ERR")
"RTN","EASBTBUL",32,0)
 ; Check if Beneficiary Travel Date Certified is within the last year
"RTN","EASBTBUL",33,0)
 ;I $$GET1^DIQ(392.2,IFN,"DATE CERTIFIED","I")<($P(DT,".",1)-10000) Q
"RTN","EASBTBUL",34,0)
 ;
"RTN","EASBTBUL",35,0)
 ; Input raw data into DATA array to set variables in Bulletin
"RTN","EASBTBUL",36,0)
 ;
"RTN","EASBTBUL",37,0)
 ; Patient DFN number
"RTN","EASBTBUL",38,0)
 S DATA(10)=DFN
"RTN","EASBTBUL",39,0)
 ; Patient Name
"RTN","EASBTBUL",40,0)
 S DATA(1)=$$GET1^DIQ(2,DFN,"NAME","I")
"RTN","EASBTBUL",41,0)
 ; Last 4 of SSN
"RTN","EASBTBUL",42,0)
 S DATA(2)=SSN
"RTN","EASBTBUL",43,0)
 ; Patient VPID
"RTN","EASBTBUL",44,0)
 S DATA(3)=$$GETICN^MPIF001(DFN)
"RTN","EASBTBUL",45,0)
 ; Patient IEN
"RTN","EASBTBUL",46,0)
 S DATA(4)=DFN
"RTN","EASBTBUL",47,0)
 ; Station Number
"RTN","EASBTBUL",48,0)
 S DATA(5)=$P($$SITE^VASITE(),"^",3)
"RTN","EASBTBUL",49,0)
 ; Previous Category
"RTN","EASBTBUL",50,0)
 S DATA(6)=IVMCEB
"RTN","EASBTBUL",51,0)
 ; New Category
"RTN","EASBTBUL",52,0)
 S DATA(7)=DGCAT
"RTN","EASBTBUL",53,0)
 ; Date of Test
"RTN","EASBTBUL",54,0)
 S Y=$P(IVM10,".") X ^DD("DD")
"RTN","EASBTBUL",55,0)
 S DATA(8)=Y
"RTN","EASBTBUL",56,0)
 ; Converted Income Year
"RTN","EASBTBUL",57,0)
 S Y=$$LYR^DGMTSCU1(IVM10) X ^DD("DD")
"RTN","EASBTBUL",58,0)
 S DATA(9)=Y
"RTN","EASBTBUL",59,0)
 ;
"RTN","EASBTBUL",60,0)
 D SENDBUL
"RTN","EASBTBUL",61,0)
 ;
"RTN","EASBTBUL",62,0)
 Q
"RTN","EASBTBUL",63,0)
 ;
"RTN","EASBTBUL",64,0)
KILL ; Remove RX Bulletin - Not used at this time
"RTN","EASBTBUL",65,0)
 ;
"RTN","EASBTBUL",66,0)
 ; This is a placeholder should it be found in the future that any data from the SET
"RTN","EASBTBUL",67,0)
 ; needs cleaned up.
"RTN","EASBTBUL",68,0)
 ;
"RTN","EASBTBUL",69,0)
 Q
"RTN","EASBTBUL",70,0)
 ;
"RTN","EASBTBUL",71,0)
SENDBUL ; transmit bulletin
"RTN","EASBTBUL",72,0)
 ;
"RTN","EASBTBUL",73,0)
 ; Protect Fileman from Mailman call
"RTN","EASBTBUL",74,0)
 N DIC,DIX,DIY,DO,DD,DFN,VSITE,XMINSTR
"RTN","EASBTBUL",75,0)
 N DICRREC,DIDATA,DIEFAR,DIEFCNOD,DIEFDAS,DIEFECNT,DIEFF,DIEFFLAG
"RTN","EASBTBUL",76,0)
 N DIEFFLD,DIEFFLST,DIEFFREF,DIEFFVAL,DIEFFXR,DIEFI,DIEFIEN,DIEFLEV
"RTN","EASBTBUL",77,0)
 N DIEFNODE,DIEFNVAL,DIEFOUT,DIEFOVAL,DIEFRFLD,DIEFRLST,DIEFSORK
"RTN","EASBTBUL",78,0)
 N DIEFSPOT,DIEFTMP,DIEFTREF,DIFLD,DIFM,DIQUIET,DISYS,D,D0,DA
"RTN","EASBTBUL",79,0)
 ;
"RTN","EASBTBUL",80,0)
 ; Set From Line of Email
"RTN","EASBTBUL",81,0)
 S XMINSTR("FROM")=.5
"RTN","EASBTBUL",82,0)
 ;
"RTN","EASBTBUL",83,0)
 ; Send email
"RTN","EASBTBUL",84,0)
 ;D SENDBULL^XMXAPI(DUZ,"RX COPAY TEST",.DATA,,,.XMINSTR)
"RTN","EASBTBUL",85,0)
 D SENDBULL^XMXAPI(DUZ,"EAS BT CLAIMS PROCESSING",.DATA,,,.XMINSTR)  ;EAS BT CLAIMS PROCESSING
"RTN","EASBTBUL",86,0)
 ;
"RTN","EASBTBUL",87,0)
 ;
"RTN","EASBTBUL",88,0)
 Q
"RTN","EASBTBUL",89,0)
 ;
"RTN","EASPREC3")
0^5^B11588856
"RTN","EASPREC3",1,0)
EASPREC3 ;ALB/PJH,BDB,MNH - PROCESS INCOMING HL7 (QRY) MESSAGES ;11/27/07 3:04pm
"RTN","EASPREC3",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71,111,113**;15-MAR-01;Build 53
"RTN","EASPREC3",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EASPREC3",4,0)
 ;
"RTN","EASPREC3",5,0)
 ; CLONED FROM IVMPREC2 (ESR EVENT DRIVER)
"RTN","EASPREC3",6,0)
 ;
"RTN","EASPREC3",7,0)
 ; This routine will process (ORU) HL7 messages received from the
"RTN","EASPREC3",8,0)
 ; IVM center. Event type code indicating type of transmission is
"RTN","EASPREC3",9,0)
 ; in the BHS segment. Routines based on type will be called to
"RTN","EASPREC3",10,0)
 ; process these messages. For each batch an ACK will be sent to
"RTN","EASPREC3",11,0)
 ; the IVM Center indicating errors found. If any errors are found
"RTN","EASPREC3",12,0)
 ; a batch message with AE(indicating error(s)) is sent. If no errors
"RTN","EASPREC3",13,0)
 ; only a MSH and MSA with AA(no errors) is sent. The following event
"RTN","EASPREC3",14,0)
 ; type codes are processed in the following routines:
"RTN","EASPREC3",15,0)
 ;
"RTN","EASPREC3",16,0)
 ; EVENT CODE TRANSMISSION TYPE PROCESSING ROUTINE
"RTN","EASPREC3",17,0)
 ; ==============================================================
"RTN","EASPREC3",18,0)
 ; Z03 SSN TRANSMISSIONS IVMPREC5
"RTN","EASPREC3",19,0)
 ; Z04 INSURANCE TRANSMISSIONS IVMPREC3
"RTN","EASPREC3",20,0)
 ; Z05 DEMOGRAPHIC TRANSMISSIONS IVMPREC6
"RTN","EASPREC3",21,0)
 ; Z06 MEANS TEST TRANSMISSIONS EASPREC6
"RTN","EASPREC3",22,0)
 ; Z08 CASE STATUS TRANSMISSIONS IVMPREC4
"RTN","EASPREC3",23,0)
 ; Z10 INCOME TEST TRANSMISSIONS IVMCM
"RTN","EASPREC3",24,0)
 ; Z11 ENROLLMENT/ELIGIBILTY ORUZ11^DGENUPL
"RTN","EASPREC3",25,0)
 ;
"RTN","EASPREC3",26,0)
 ;
"RTN","EASPREC3",27,0)
ORU ; - Receive Observational Results Unsolicited Message
"RTN","EASPREC3",28,0)
 ;
"RTN","EASPREC3",29,0)
 N DIC,%,%H,%I D NOW^%DTC S HLDT=%
"RTN","EASPREC3",30,0)
 K HLERR,IVMSEG1,IVMSEG2,IVMSEG3
"RTN","EASPREC3",31,0)
 S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0
"RTN","EASPREC3",32,0)
 ; Make sure POSTMASTER DUZ instead of DUZ of Person who
"RTN","EASPREC3",33,0)
 ; started Incoming Logical Link
"RTN","EASPREC3",34,0)
 S DUZ=.5
"RTN","EASPREC3",35,0)
 ;
"RTN","EASPREC3",36,0)
 ; - get incoming segment from HL7 (#772) file
"RTN","EASPREC3",37,0)
 N IVMRTN,SEGCNT,CNT,STATION,HLEID,HLEIDS
"RTN","EASPREC3",38,0)
 S IVMRTN="IVMPREC2" K ^TMP($J,IVMRTN),^TMP("HLA",$J),^TMP("HLS",$J)
"RTN","EASPREC3",39,0)
 F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0  D
"RTN","EASPREC3",40,0)
 . S CNT=0
"RTN","EASPREC3",41,0)
 . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE
"RTN","EASPREC3",42,0)
 . F  S CNT=$O(HLNODE(CNT)) Q:'CNT  S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT)
"RTN","EASPREC3",43,0)
 ;
"RTN","EASPREC3",44,0)
 S HLDA=HLMTIEN
"RTN","EASPREC3",45,0)
 S IVMSEG=$G(^TMP($J,IVMRTN,1,0)) I IVMSEG']"" G ORUQ
"RTN","EASPREC3",46,0)
 ;
"RTN","EASPREC3",47,0)
 ; - check for BHS 
"RTN","EASPREC3",48,0)
 I $E(IVMSEG,1,3)'="BHS" G ORUQ
"RTN","EASPREC3",49,0)
 ;
"RTN","EASPREC3",50,0)
 ; - get batch control id
"RTN","EASPREC3",51,0)
 S HLFS=HL("FS")
"RTN","EASPREC3",52,0)
 S HLECH=HL("ECH")
"RTN","EASPREC3",53,0)
 S HLQ=$G(HL("HLQ")) S:HLQ="" HLQ=""""""
"RTN","EASPREC3",54,0)
 S IVMHLMID=$P(IVMSEG,HLFS,11)
"RTN","EASPREC3",55,0)
 S STATION=$P(IVMSEG,HLFS,6)
"RTN","EASPREC3",56,0)
 ;
"RTN","EASPREC3",57,0)
 ; - get event type code
"RTN","EASPREC3",58,0)
 S IVMETC=$P($P(IVMSEG,HLFS,9),$E(HLECH),3)
"RTN","EASPREC3",59,0)
 S IVMETC=$P(IVMETC,$E(HLECH,2),2)
"RTN","EASPREC3",60,0)
 S HLEID="EAS ESR "_STATION_" ORU-"_IVMETC_" SERVER"
"RTN","EASPREC3",61,0)
 I IVMETC="Z04" S HLEID=HLEID_" H"  ;HEC TO VAMC
"RTN","EASPREC3",62,0)
 S HLEID=$O(^ORD(101,"B",HLEID,0)),HLEIDS=""
"RTN","EASPREC3",63,0)
 I HLEID]"" S HLEIDS=$O(^ORD(101,HLEID,775,"B",0))
"RTN","EASPREC3",64,0)
 ;
"RTN","EASPREC3",65,0)
 ; - process the message according to the event type code
"RTN","EASPREC3",66,0)
 ;ADD Z06 EAS*1.0*111
"RTN","EASPREC3",67,0)
 ;S IVMDO=$S(IVMETC="Z03":"EN^IVMPREC5",IVMETC="Z04":"EN^IVMPREC3",IVMETC="Z05":"EN^IVMPREC6",IVMETC="Z06":"EN^EASPREC6",IVMETC="Z08":"EN^IVMPREC4",IVMETC="Z10":"ORU^IVMCM",IVMETC="Z11":"ORUZ11^DGENUPL",1:"ORUQ")
"RTN","EASPREC3",68,0)
 S IVMDO=$S(IVMETC="Z03":"EN^IVMPREC5",IVMETC="Z04":"EN^IVMPREC3",IVMETC="Z05":"EN^IVMPREC6",IVMETC="Z06":"EN^EASPREC6",IVMETC="Z08":"EN^IVMPREC4",IVMETC="Z10":"ORU^EASCM",IVMETC="Z11":"ORUZ11^DGENUPL",1:"ORUQ") ;EAS*1*113
"RTN","EASPREC3",69,0)
 I IVMETC="Z11" D
"RTN","EASPREC3",70,0)
 .D ORUZ11^DGENUPL(HLDA,.IVMERROR)
"RTN","EASPREC3",71,0)
 .S IVMCT=2*IVMERROR
"RTN","EASPREC3",72,0)
 .S HLEVN=IVMERROR
"RTN","EASPREC3",73,0)
 I IVMETC'="Z11" D
"RTN","EASPREC3",74,0)
 .D @IVMDO
"RTN","EASPREC3",75,0)
 Q:IVMDO="ORUQ" 
"RTN","EASPREC3",76,0)
 ;
"RTN","EASPREC3",77,0)
 ; - if no error send ACK 'AA' message
"RTN","EASPREC3",78,0)
 S HLMTN="ACK"
"RTN","EASPREC3",79,0)
 K HLARYTYP,HLMTIENA,HLRESLTA,HLP
"RTN","EASPREC3",80,0)
 I 'IVMERROR S HLMID=IVMHLMID D ACK^IVMPREC S HLARYTYP="GM",HLMTIENA=""
"RTN","EASPREC3",81,0)
 I IVMERROR S HLARYTYP="GB",HLMTIENA=HLMTIEN  ;HLMTIEN comes from ACK^IVMPREC
"RTN","EASPREC3",82,0)
 K ^TMP("HLA",$J) M ^TMP("HLA",$J)=^TMP("HLS",$J) K ^TMP("HLS",$J)
"RTN","EASPREC3",83,0)
 D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,1,.HLRESLTA,HLMTIENA,.HLP)
"RTN","EASPREC3",84,0)
 ; The following line is added for PFSS Registration. This line will ensure any patient 
"RTN","EASPREC3",85,0)
 ; registration updates received from the HEC are forwarded to a COTS billing application
"RTN","EASPREC3",86,0)
 ; See DBIA#4780 - this line will need re enabling if PFSS is active 
"RTN","EASPREC3",87,0)
 ;S X="DGPFSS1" X ^%ZOSF("TEST") I $T D SEND^DGPFSS1(DFN,0)
"RTN","EASPREC3",88,0)
 ;
"RTN","EASPREC3",89,0)
ORUQ ;
"RTN","EASPREC3",90,0)
 ;
"RTN","EASPREC3",91,0)
 K DFN,IVMCNTR,IVMCT,IVMDA,IVMERR,IVMERROR,IVMHLMID,IVMNDE,IVMPTID
"RTN","EASPREC3",92,0)
 K IVMSEG,IVMSEG1,IVMSEG2,IVMSEG3,IVMTEXT,XMSUB
"RTN","EASPREC3",93,0)
 K HLARYTYP,HLMTIENA,HLRESLTA,HLP
"RTN","EASPREC3",94,0)
 K ^TMP($J,IVMRTN),^TMP("HLA",$J),^TMP("HLS",$J)
"RTN","EASPREC3",95,0)
 Q
"RTN","EASPREC6")
0^1^B95603593
"RTN","EASPREC6",1,0)
EASPREC6 ;ALB/BD,MNH,LMD - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ;6/16/04 9:28am
"RTN","EASPREC6",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**111,113**;21-OCT-94;Build 53
"RTN","EASPREC6",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EASPREC6",4,0)
 ;
"RTN","EASPREC6",5,0)
 ;** Warning ** currently only one ZMT seg per Z06 can be processed.
"RTN","EASPREC6",6,0)
 ;
"RTN","EASPREC6",7,0)
 ;EAS*1*113 Send Bulletin if BTFI is different than what is on file
"RTN","EASPREC6",8,0)
 ; - added DGMTYPT and passed down thru all calls that need.
"RTN","EASPREC6",9,0)
 ; o DGMTYPT = 1 (Means Test, MT)
"RTN","EASPREC6",10,0)
 ; o DGMTYPT = 2 (RX Copay Test, CT)
"RTN","EASPREC6",11,0)
 ;
"RTN","EASPREC6",12,0)
 ; This routine will process (validate) batch ORU Means Test(event type
"RTN","EASPREC6",13,0)
 ; Z06) HL7 messages received from the IVM center. Format of batch:
"RTN","EASPREC6",14,0)
 ; BHS
"RTN","EASPREC6",15,0)
 ; {MSH
"RTN","EASPREC6",16,0)
 ; PID
"RTN","EASPREC6",17,0)
 ; ZIC
"RTN","EASPREC6",18,0)
 ; ZIR
"RTN","EASPREC6",19,0)
 ; {ZDP
"RTN","EASPREC6",20,0)
 ; ZIC
"RTN","EASPREC6",21,0)
 ; ZIR
"RTN","EASPREC6",22,0)
 ; }
"RTN","EASPREC6",23,0)
 ; ZMT
"RTN","EASPREC6",24,0)
 ; ZIV
"RTN","EASPREC6",25,0)
 ; }
"RTN","EASPREC6",26,0)
 ; BTS
"RTN","EASPREC6",27,0)
 ;
"RTN","EASPREC6",28,0)
EN ; entry point to validate Means Test messages 
"RTN","EASPREC6",29,0)
 ;
"RTN","EASPREC6",30,0)
 N DEPFLG,EDB,CANCFLG,CASEFLG,SEGSTR,SEGMENTS,MISSING,ERRFLG,Z06COM
"RTN","EASPREC6",31,0)
 N IVM2,IVM3,IVM7,IVM8,IVM10,IVM12,IVM17,IVM18,IVM20,IVM25,IVM26,IVM32,IVMIY   ;Add BT indicator EAS*1*113
"RTN","EASPREC6",32,0)
 N IVMDA,IVMPAT,IVMMTSTS,MTFND,UPMTS,MTDATE,TYPE,EASMTDT,EASZ06,EXPIRED
"RTN","EASPREC6",33,0)
 N IVM5,EASZ06D,DGMTYPT
"RTN","EASPREC6",34,0)
 S SEGSTR="00000000000"      ;One byte for each segment in message
"RTN","EASPREC6",35,0)
 S SEGMENTS="BHS,MSH,PID,PID,ZIC,ZIR,ZDP,ZIC,ZIR,ZMT,ZIV,BTS"
"RTN","EASPREC6",36,0)
 S Z06COM="Z06 MT via Edb"
"RTN","EASPREC6",37,0)
 S (CASEFLG,DEPFLG,ERRFLG,HLERR,IVMDA,IVMFLGC,MTFND,UPMTS)=0
"RTN","EASPREC6",38,0)
EN1 F  S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA  D  I $D(HLERR) D ACK^IVMPREC S ERRFLG=1 Q 
"RTN","EASPREC6",39,0)
 .K HLERR
"RTN","EASPREC6",40,0)
 .D GET
"RTN","EASPREC6",41,0)
 .D @IVMSEG1                            ;process each segment type
"RTN","EASPREC6",42,0)
 Q:ERRFLG                               ;Error detected do not continue
"RTN","EASPREC6",43,0)
 S MISSING=$F(SEGSTR,0) ;Ensure all required segments
"RTN","EASPREC6",44,0)
 I MISSING D  I $D(HLERR) D ACK^IVMPREC,CLEANUP Q
"RTN","EASPREC6",45,0)
 . S TYPE=$S(MISSING=3!(MISSING=4):"Veteran's",MISSING>4&(MISSING<8):"Spouse's",1:"")
"RTN","EASPREC6",46,0)
 . S HLERR="Missing "_TYPE_" "_$P(SEGMENTS,",",(MISSING-1))_" Segment"
"RTN","EASPREC6",47,0)
 D PROCESS
"RTN","EASPREC6",48,0)
 I $D(HLERR) D ACK^IVMPREC
"RTN","EASPREC6",49,0)
 ; cleanup
"RTN","EASPREC6",50,0)
CLEANUP K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,CANCFLG,IVMFLGC,IVMMT31
"RTN","EASPREC6",51,0)
 K IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,HLERR,CLOSFLG
"RTN","EASPREC6",52,0)
 K IVMZ10,IVMDAV,ZIVSEG,ZMTSEG
"RTN","EASPREC6",53,0)
 Q
"RTN","EASPREC6",54,0)
 ;
"RTN","EASPREC6",55,0)
 ;Dependent upon type of Z06 sent perform the following;
"RTN","EASPREC6",56,0)
 ;IVM Case Status:
"RTN","EASPREC6",57,0)
 ; Value of 1 = Create/Update Z06 MT/CT, Close Case & Mark REASON CODE
"RTN","EASPREC6",58,0)
 ; as 'Converted'
"RTN","EASPREC6",59,0)
 ; Value of 0 = Cancel Z06 MT/CT and Mark REASON CODE as 'Not Convert'
"RTN","EASPREC6",60,0)
 ;
"RTN","EASPREC6",61,0)
 ; If Z06 MT/CT and IVM Case Status is 1 and Z06 MT/CT doesn't exist then
"RTN","EASPREC6",62,0)
 ; Create new Z06 MT/CT (new Z06 MT/CT becomes primary and existing
"RTN","EASPREC6",63,0)
 ; MT/CT becomes non-primary)
"RTN","EASPREC6",64,0)
 ; Assign REASON CODE of 'Converted' in #301.5
"RTN","EASPREC6",65,0)
 ; If Z06 MT/CT already exists then
"RTN","EASPREC6",66,0)
 ; If IVM Case Status is 0 Then
"RTN","EASPREC6",67,0)
 ; Delete Z06 MT/CT for income year and return old MT/CT to primary
"RTN","EASPREC6",68,0)
 ; Change REASON CODE from 'Converted' to 'Not Converted' in #301.5
"RTN","EASPREC6",69,0)
 ; If IVM Case Status is 1 Then
"RTN","EASPREC6",70,0)
 ; Update MT/CT Z06 and Close/Convert Case
"RTN","EASPREC6",71,0)
 ; Else (Z06 MT/CT, IVM Case Status=0 and Z06 MT/CT does not exist)
"RTN","EASPREC6",72,0)
 ; Send back 'AE' to Edb indicating MT/CT Z06 not available for 
"RTN","EASPREC6",73,0)
 ; cancellation
"RTN","EASPREC6",74,0)
 ;
"RTN","EASPREC6",75,0)
PROCESS N DIC,%,%H,%I,IVMDATE
"RTN","EASPREC6",76,0)
 D NOW^%DTC
"RTN","EASPREC6",77,0)
 S IVMDATE=%
"RTN","EASPREC6",78,0)
 I '$D(ZMTSEG) S HLERR="ZMT Segment is Missing" Q
"RTN","EASPREC6",79,0)
 S EASZ06=1,EXPIRED=0
"RTN","EASPREC6",80,0)
 S:DGMTYPT=2 IVMCEB=$P($$RXST^IBARXEU(DFN),"^",2) ;prev RX sts
"RTN","EASPREC6",81,0)
 I $G(IVMMTIEN)="" D  ; Find any primary for the same year/test type
"RTN","EASPREC6",82,0)
 . S CURMT=$$LST^DGMTU(DFN,IVMMTDT,DGMTYPT)
"RTN","EASPREC6",83,0)
 . I $E($P(CURMT,U,2),1,3)'=$E(IVMMTDT,1,3) Q  ;TMK
"RTN","EASPREC6",84,0)
 . S IVMMTIEN=$P(CURMT,"^",1)
"RTN","EASPREC6",85,0)
 . S IVMMTDT=$P(CURMT,"^",2)
"RTN","EASPREC6",86,0)
 . S IVMMTSTS=$P(CURMT,"^",3)
"RTN","EASPREC6",87,0)
 I $G(IVMMTIEN)]"" D                   ;dgmtp is event driver variable
"RTN","EASPREC6",88,0)
 . S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0))
"RTN","EASPREC6",89,0)
 ;
"RTN","EASPREC6",90,0)
 ; EAS*1*113
"RTN","EASPREC6",91,0)
 ; Send BT Bulletin if BTFI is different than what is on file
"RTN","EASPREC6",92,0)
 ;
"RTN","EASPREC6",93,0)
 ; Input:
"RTN","EASPREC6",94,0)
 ; DFN = IEN of Patient
"RTN","EASPREC6",95,0)
 N DT,DGCAT,FININD
"RTN","EASPREC6",96,0)
 ; DFN = IEN of Patient
"RTN","EASPREC6",97,0)
 ; DT = Today's Date
"RTN","EASPREC6",98,0)
 S DT=IVMDATE
"RTN","EASPREC6",99,0)
 ; DGCAT = Current Means Test Status
"RTN","EASPREC6",100,0)
 S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1)
"RTN","EASPREC6",101,0)
 ; IVMCEB = Previous Means Test Status
"RTN","EASPREC6",102,0)
 ; IVM10 = Date/Time Test Completed
"RTN","EASPREC6",103,0)
 S FININD="" I $D(IVMMTIEN) S FININD=$G(^DGMT(408.31,IVMMTIEN,4)) ;financial indicator EAS*1*113
"RTN","EASPREC6",104,0)
 ;
"RTN","EASPREC6",105,0)
 I IVM32'=FININD D SET^EASBTBUL(DFN,DT,DGCAT,$G(IVMCEB),$G(IVM10))
"RTN","EASPREC6",106,0)
 ;
"RTN","EASPREC6",107,0)
 ;
"RTN","EASPREC6",108,0)
 ; No previous 408.31 test on file
"RTN","EASPREC6",109,0)
 I 'MTFND D  Q
"RTN","EASPREC6",110,0)
 . I CASEFLG D                                ;Case=1 Close/Converted
"RTN","EASPREC6",111,0)
 . . ;change old MT/CT to non-primary
"RTN","EASPREC6",112,0)
 . . I $G(IVMMTIEN)>0 D
"RTN","EASPREC6",113,0)
 . . . S DA=IVMMTIEN,DIE="^DGMT(408.31,",DR="2////0;"
"RTN","EASPREC6",114,0)
 . . . D ^DIE K DA,DIE,DR
"RTN","EASPREC6",115,0)
 . . ;
"RTN","EASPREC6",116,0)
 . . S IVMMTDT=EASMTDT
"RTN","EASPREC6",117,0)
 . . D ^EASUM6 ;Copied from EASUM1 Create New Z06 MT/CT
"RTN","EASPREC6",118,0)
 . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
"RTN","EASPREC6",119,0)
 . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
"RTN","EASPREC6",120,0)
 . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
"RTN","EASPREC6",121,0)
 . . D CLOSE(IVMIY,DFN,1,6) ;Close Case/Converted
"RTN","EASPREC6",122,0)
 . ;
"RTN","EASPREC6",123,0)
 . I 'CASEFLG D  Q
"RTN","EASPREC6",124,0)
 . . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
"RTN","EASPREC6",125,0)
 . . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
"RTN","EASPREC6",126,0)
 ;
"RTN","EASPREC6",127,0)
 ; Previous 408.31 test on file
"RTN","EASPREC6",128,0)
 I MTFND D
"RTN","EASPREC6",129,0)
 . I 'CASEFLG D                             ;Case=0 Close/Not Convert
"RTN","EASPREC6",130,0)
 . . ; Check to see if MT/CT Z06 exists prior to trying to delete
"RTN","EASPREC6",131,0)
 . . ; If NOT defined then send an AE back to Edb
"RTN","EASPREC6",132,0)
 . . I 'UPMTS D  Q                          ;Existing Z06 not found
"RTN","EASPREC6",133,0)
 . . . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
"RTN","EASPREC6",134,0)
 . . . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
"RTN","EASPREC6",135,0)
 . . I UPMTS D  Q
"RTN","EASPREC6",136,0)
 . . . N CURMT,IVMMTI,IVMDFN,DGCAT
"RTN","EASPREC6",137,0)
 . . . S IVMDFN=DFN                         ;Save off DFN
"RTN","EASPREC6",138,0)
 . . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
"RTN","EASPREC6",139,0)
 . . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
"RTN","EASPREC6",140,0)
 . . . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
"RTN","EASPREC6",141,0)
 . . . S EASZ06D=1 ;Set del flag for IB event
"RTN","EASPREC6",142,0)
 . . . D ^EASUM9 ;Delete Z06 MT/CT
"RTN","EASPREC6",143,0)
 . . . S DFN=IVMDFN
"RTN","EASPREC6",144,0)
 . . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
"RTN","EASPREC6",145,0)
 . . . D CLOSE(IVMIY,DFN,1,7) ;Close Case/Not Converted
"RTN","EASPREC6",146,0)
 . ;
"RTN","EASPREC6",147,0)
 . I CASEFLG D                              ;Case=1 Close/Converted
"RTN","EASPREC6",148,0)
 . . Q:$G(IVMMTIEN)<1
"RTN","EASPREC6",149,0)
 . . S DA=IVMMTIEN,DIE="^DGMT(408.31,"
"RTN","EASPREC6",150,0)
 . . S DR=".03////^S X=IVM3;.12////^S X=IVM8;.07////^S X=IVM10;"
"RTN","EASPREC6",151,0)
 . . S DR=DR_".09////^S X=IVM25;.11////^S X=IVM7;.18////^S X=IVM12;"
"RTN","EASPREC6",152,0)
 . . S DR=DR_".23////^S X=IVM18;.25////^S X=IVM20;"
"RTN","EASPREC6",153,0)
 . . S DR=DR_"2.02////^S X=IVMDATE;2.03////^S X=IVM26;"
"RTN","EASPREC6",154,0)
 . . S DR=DR_"4////^S X=IVM32;" ;BT Financial Indicator EAS*1*113
"RTN","EASPREC6",155,0)
 . . D ^DIE K DA,DIE,DR                     ;Update existing Z06
"RTN","EASPREC6",156,0)
 . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
"RTN","EASPREC6",157,0)
 . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
"RTN","EASPREC6",158,0)
 . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
"RTN","EASPREC6",159,0)
 . . D CLOSE(IVMIY,DFN,1,6) ;Close Case/Converted
"RTN","EASPREC6",160,0)
 . . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
"RTN","EASPREC6",161,0)
 . . D MTBULL^EASUM9,MAIL^IVMUFNC() ;Send Bulletin
"RTN","EASPREC6",162,0)
 Q
"RTN","EASPREC6",163,0)
 ;
"RTN","EASPREC6",164,0)
MSH S (HLMID,MSGID)=$P(IVMSEG,HLFS,10) ;Message control id from MSH
"RTN","EASPREC6",165,0)
 Q
"RTN","EASPREC6",166,0)
PID ;Handle wrapped PID segment
"RTN","EASPREC6",167,0)
 N I,IVMPID,PIDSTR,COMP,CNTR,NOPID,TMPARY,PID3ARY,CNTR2
"RTN","EASPREC6",168,0)
 S CNTR=1,NOPID=0,PIDSTR(CNTR)=$P(IVMSEG,"^",2,999)
"RTN","EASPREC6",169,0)
 F  D  Q:NOPID
"RTN","EASPREC6",170,0)
 .S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
"RTN","EASPREC6",171,0)
 .I $E(IVMSEG,1,4)="ZIC^" S NOPID=1,IVMDA=IVMDA-1 Q
"RTN","EASPREC6",172,0)
 .S CNTR=CNTR+1,PIDSTR(CNTR)=IVMSEG
"RTN","EASPREC6",173,0)
 .S SEGSTR=$E(SEGSTR,1,IVMDA-1)_"1"_$E(SEGSTR,IVMDA,$L(SEGSTR)) ;Extend SEGSTR for wrapped PID
"RTN","EASPREC6",174,0)
 D BLDPID^IVMPREC6(.PIDSTR,.IVMPID) ;Create IVMPID subscripted by seq #
"RTN","EASPREC6",175,0)
 ;convert "" to null for PID segment
"RTN","EASPREC6",176,0)
 S CNTR="" F  S CNTR=$O(IVMPID(CNTR)) Q:CNTR=""  D
"RTN","EASPREC6",177,0)
 .I $O(IVMPID(CNTR,"")) D  Q
"RTN","EASPREC6",178,0)
 ..S CNTR2="" F  S CNTR2=$O(IVMPID(CNTR,CNTR2)) Q:CNTR2=""  D
"RTN","EASPREC6",179,0)
 ...S IVMPID(CNTR,CNTR2)=$$CLEARF^IVMPRECA(IVMPID(CNTR,CNTR2),$E(HLECH))
"RTN","EASPREC6",180,0)
 .I IVMPID(CNTR)=HLQ S IVMPID(CNTR)=""
"RTN","EASPREC6",181,0)
 M TMPARY(3)=IVMPID(3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
"RTN","EASPREC6",182,0)
 S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
"RTN","EASPREC6",183,0)
 K TMPARY,PID3ARY
"RTN","EASPREC6",184,0)
 I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) S HLERR=ERRMSG Q
"RTN","EASPREC6",185,0)
 S IVMDAP=IVMDA ;Save IVMDA for veteran PID segment
"RTN","EASPREC6",186,0)
 Q
"RTN","EASPREC6",187,0)
ZIC I 'DEPFLG S IVMDGLY=$P(IVMSEG,"^",3) ;Income year
"RTN","EASPREC6",188,0)
 Q
"RTN","EASPREC6",189,0)
ZIR Q
"RTN","EASPREC6",190,0)
ZDP S DEPFLG=1
"RTN","EASPREC6",191,0)
 Q
"RTN","EASPREC6",192,0)
 ;Get primary means test
"RTN","EASPREC6",193,0)
 ; IVMMTDT - means test date
"RTN","EASPREC6",194,0)
 ; DGLY - income year
"RTN","EASPREC6",195,0)
 ; If Means Test not in DHCP, don't upload IVM Means Test 
"RTN","EASPREC6",196,0)
 ;
"RTN","EASPREC6",197,0)
ZMT N IVMIEN,MTCODE                                             ;EAS*1*42
"RTN","EASPREC6",198,0)
 S IVMDAZ=IVMDA,ZMTSEG=IVMSEG            ;ZMT segment ivmda
"RTN","EASPREC6",199,0)
 D PARSEZMT(ZMTSEG) ;Retrieve ZMT Values
"RTN","EASPREC6",200,0)
 ;Means test date from ZMT segment
"RTN","EASPREC6",201,0)
 S (EASMTDT,IVMMTDT)=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3))
"RTN","EASPREC6",202,0)
 S DGMTYPT=$G(IVM17) ;int type of test
"RTN","EASPREC6",203,0)
 S:DGMTYPT="" DGMTYPT=1 ;insure type defined
"RTN","EASPREC6",204,0)
 S DGLY=$$LYR^DGMTSCU1(IVMMTDT) ;Get means test to be updated
"RTN","EASPREC6",205,0)
 S MTDATE=-IVMMTDT
"RTN","EASPREC6",206,0)
 S IVMIEN=""
"RTN","EASPREC6",207,0)
 S MTFND=0
"RTN","EASPREC6",208,0)
 F  S IVMIEN=$O(^DGMT(408.31,"AID",DGMTYPT,DFN,MTDATE,IVMIEN)) Q:MTFND!(IVMIEN="")  D
"RTN","EASPREC6",209,0)
 . S IVMMTIEN=IVMIEN
"RTN","EASPREC6",210,0)
 . ; match to MT Z06 from Edb
"RTN","EASPREC6",211,0)
 . S MTCODE=$P($G(^DGMT(408.31,IVMIEN,0)),"^",3)
"RTN","EASPREC6",212,0)
 . I (MTCODE=6)!(MTCODE=16)!(MTCODE=8) D  ;Previous Converted MT/CT - EAS*1.0*111 
"RTN","EASPREC6",213,0)
 . . S UPMTS=IVMIEN
"RTN","EASPREC6",214,0)
 . . S MTFND=1
"RTN","EASPREC6",215,0)
 I IVM7="" S (UPMTS,MTFND)=1  ;- EAS*1.0*111 need override for reversal.
"RTN","EASPREC6",216,0)
 Q
"RTN","EASPREC6",217,0)
ZIV S IVMDAV=IVMDA,ZIVSEG=IVMSEG
"RTN","EASPREC6",218,0)
 S IVMIY=$P(IVMSEG,HLFS,3)
"RTN","EASPREC6",219,0)
 S IVMIY=$$FMDATE^HLFNC(IVMIY)
"RTN","EASPREC6",220,0)
 I $E(IVMIY,4,7)'="0000"!($E(IVMIY,1,3)<292) D  Q
"RTN","EASPREC6",221,0)
 . S HLERR="Invalid Income Year"
"RTN","EASPREC6",222,0)
 I "01"'[$P(IVMSEG,HLFS,9) D  Q
"RTN","EASPREC6",223,0)
 . S HLERR="Case Status not 0 or 1"
"RTN","EASPREC6",224,0)
 I $P(IVMSEG,HLFS,9)=1 S CASEFLG=1 ;Close/Convert Case Flag
"RTN","EASPREC6",225,0)
 I $P(IVMSEG,HLFS,9)=0 S CASEFLG=0 ;Delete/Not Converted MT Flag
"RTN","EASPREC6",226,0)
BHS Q
"RTN","EASPREC6",227,0)
BTS Q
"RTN","EASPREC6",228,0)
 ;
"RTN","EASPREC6",229,0)
GET ; get HL7 segment from ^TMP
"RTN","EASPREC6",230,0)
 ;S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA))
"RTN","EASPREC6",231,0)
 S IVMSEG=$G(^TMP($J,IVMRTN,+IVMDA,0))
"RTN","EASPREC6",232,0)
 S IVMSEG1=$E(IVMSEG,1,3)
"RTN","EASPREC6",233,0)
 S $E(SEGSTR,IVMDA)=1
"RTN","EASPREC6",234,0)
 Q
"RTN","EASPREC6",235,0)
 ;
"RTN","EASPREC6",236,0)
 ;Parse ZMT Segment for MT Data
"RTN","EASPREC6",237,0)
 ;
"RTN","EASPREC6",238,0)
PARSEZMT(ZSEG) ;
"RTN","EASPREC6",239,0)
 N CMPDATE
"RTN","EASPREC6",240,0)
 S IVM2=$$FMDATE^HLFNC($P(ZSEG,"^",3)) ;Means Test Date
"RTN","EASPREC6",241,0)
 S IVM3=$O(^DG(408.32,"C",$P(ZSEG,"^",4),"")) ;Means Test Status 
"RTN","EASPREC6",242,0)
 ;S IVM7=$S($P(ZSEG,"^",8)="Y":1,$P(ZSEG,"^",8)=1:1,$P(ZSEG,"^",8)="":"",1:0) ;Agrees To Deductible
"RTN","EASPREC6",243,0)
 S IVM7=$S($P(ZSEG,"^",8)]"Yy":1,$P(ZSEG,"^",8)=1:1,$P(ZSEG,"^",8)="":"",1:0) ;Agrees To Deductible
"RTN","EASPREC6",244,0)
 S IVM8=$P(ZSEG,"^",9) ;Threshold A
"RTN","EASPREC6",245,0)
 S CMPDATE=$P(ZSEG,"^",11) S:$E($G(CMPDATE),9,14)="000000" CMPDATE=$E(CMPDATE,1,8) S:+CMPDATE=0 CMPDATE="" S IVM10=$$FMDATE^HLFNC(CMPDATE) ;Date/Time Completed
"RTN","EASPREC6",246,0)
 S IVM12=$P(ZSEG,"^",13) ;Number of Dependents
"RTN","EASPREC6",247,0)
 S IVM17=$P(ZSEG,"^",18) ;Type of Test
"RTN","EASPREC6",248,0)
 S IVM18=$P(ZSEG,"^",19) ;Source of Test
"RTN","EASPREC6",249,0)
 S IVM20=$$FMDATE^HLFNC($P(ZSEG,"^",21)) ;IVM Verified MT
"RTN","EASPREC6",250,0)
 S IVM25=$$FMDATE^HLFNC($P(ZSEG,"^",26)) ;D/T Last Changed
"RTN","EASPREC6",251,0)
 S IVM26=$O(^DG(408.32,"C",$P(ZSEG,"^",27),"")) ;Test Determined Status
"RTN","EASPREC6",252,0)
 S IVM32=$P(ZSEG,"^",32) ;EAS*1*113
"RTN","EASPREC6",253,0)
 ;S IVM32=$S(IVM32="Y":1,IVM32="N":0,1:IVM32) ;BT Financial Indicator EAS*1*113
"RTN","EASPREC6",254,0)
 S IVM32=$S(IVM32["""":"",1:IVM32) ;BT Financial Indicator
"RTN","EASPREC6",255,0)
 Q
"RTN","EASPREC6",256,0)
 ;
"RTN","EASPREC6",257,0)
CLOSE(IVMIY,DFN,IVMCS,IVMCR) ; Close IVM case record for a patient
"RTN","EASPREC6",258,0)
 ; Input: DFN -- Pointer to the patient in file #2
"RTN","EASPREC6",259,0)
 ; IVMIY -- Income year of the closed case
"RTN","EASPREC6",260,0)
 ; IVMCS -- Closure source [1=IVM | 2=DHCP]
"RTN","EASPREC6",261,0)
 ; IVMCR -- Pointer to the closure reason in file #301.93
"RTN","EASPREC6",262,0)
 ;
"RTN","EASPREC6",263,0)
 N DA,DIE,DR,X,Y,EVENTS,STATUS,EAEVENT,IVEVENT
"RTN","EASPREC6",264,0)
 I '$G(IVMIY)!'$G(DFN)!'$G(IVMCS)!'$G(IVMCR) G CLOSEQ
"RTN","EASPREC6",265,0)
 S IVMDELMT=1 ; flag indicates deletion
"RTN","EASPREC6",266,0)
 S DA=$O(^IVM(301.5,"APT",+DFN,+IVMIY,0))
"RTN","EASPREC6",267,0)
 I $G(^IVM(301.5,+DA,0))']"" G CLOSEQ
"RTN","EASPREC6",268,0)
 ;
"RTN","EASPREC6",269,0)
 ;don't want closing a case to stop transmission of an enrollment event
"RTN","EASPREC6",270,0)
 S STATUS=1
"RTN","EASPREC6",271,0)
 I ($$STATUS^IVMPLOG(+DA,.EVENTS)=0),EVENTS("ENROLL")=1 S STATUS=0
"RTN","EASPREC6",272,0)
 ;
"RTN","EASPREC6",273,0)
 ; If previous years event make sure Enrollment Event does not get 
"RTN","EASPREC6",274,0)
 ; updated, and the IVM Event does
"RTN","EASPREC6",275,0)
 ;
"RTN","EASPREC6",276,0)
 ;S EAEVENT=1,IVEVENT=2
"RTN","EASPREC6",277,0)
 ;I $G(EXPIRED)=1 S EAEVENT=2,STATUS=0,IVEVENT=1
"RTN","EASPREC6",278,0)
 ;I $G(EXPIRED)=0 S EAEVENT=1,STATUS=0
"RTN","EASPREC6",279,0)
 D NOW^%DTC S DR=".03////"_STATUS_";.04////1;1.01////"_IVMCR_";1.02////"_IVMCS_";1.03////"_%_";30.01////2;30.02////2"
"RTN","EASPREC6",280,0)
 S DIE="^IVM(301.5," D ^DIE
"RTN","EASPREC6",281,0)
CLOSEQ Q
"RTN","EASPREC6",282,0)
 ;
"RTN","EASPREC7")
0^8^B79134294
"RTN","EASPREC7",1,0)
EASPREC7 ;ALB/SEK,RTK,GN,MNH,LMD - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ;6/16/04 9:28am
"RTN","EASPREC7",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**23,30,35,52,42,86,113**;21-OCT-94;Build 53
"RTN","EASPREC7",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EASPREC7",4,0)
 ;
"RTN","EASPREC7",5,0)
 ;** Warning **  currently only one ZMT seg per Z06 can be processed.
"RTN","EASPREC7",6,0)
 ;
"RTN","EASPREC7",7,0)
 ;;EAS*1*113 Send Bulletin if BTFI is different than what is on files
"RTN","EASPREC7",8,0)
 ; - added DGMTYPT and passed down thru all calls that need.
"RTN","EASPREC7",9,0)
 ; o DGMTYPT = 1 (Means Test, MT)
"RTN","EASPREC7",10,0)
 ; o DGMTYPT = 2 (RX Copay Test, CT)
"RTN","EASPREC7",11,0)
 ;EAS*1*52 call PARSEZMT within tag ZMT to define all ZMT variables
"RTN","EASPREC7",12,0)
 ;EAS*1*42 add RX Copay Testing Upload and Delete to this routine.
"RTN","EASPREC7",13,0)
 ;         - added DGMTYPT and passed down thru all calls that need.
"RTN","EASPREC7",14,0)
 ;         o DGMTYPT = 1 (Means Test, MT)
"RTN","EASPREC7",15,0)
 ;         o DGMTYPT = 2 (RX Copay Test, CT)
"RTN","EASPREC7",16,0)
 ;
"RTN","EASPREC7",17,0)
 ; This routine will process (validate) batch ORU Means Test(event type
"RTN","EASPREC7",18,0)
 ; Z06) HL7 messages received from the IVM center.  Format of batch:
"RTN","EASPREC7",19,0)
 ;       BHS
"RTN","EASPREC7",20,0)
 ;       {MSH
"RTN","EASPREC7",21,0)
 ;        PID
"RTN","EASPREC7",22,0)
 ;        ZIC
"RTN","EASPREC7",23,0)
 ;        ZIR
"RTN","EASPREC7",24,0)
 ;        {ZDP
"RTN","EASPREC7",25,0)
 ;         ZIC
"RTN","EASPREC7",26,0)
 ;         ZIR
"RTN","EASPREC7",27,0)
 ;        }
"RTN","EASPREC7",28,0)
 ;        ZMT
"RTN","EASPREC7",29,0)
 ;        ZIV
"RTN","EASPREC7",30,0)
 ;       }
"RTN","EASPREC7",31,0)
 ;       BTS
"RTN","EASPREC7",32,0)
 ;
"RTN","EASPREC7",33,0)
EN ; entry point to validate Means Test messages 
"RTN","EASPREC7",34,0)
 ;
"RTN","EASPREC7",35,0)
 N DEPFLG,EDB,CANCFLG,CASEFLG,SEGSTR,SEGMENTS,MISSING,ERRFLG,Z06COM
"RTN","EASPREC7",36,0)
 N IVM2,IVM3,IVM7,IVM8,IVM10,IVM12,IVM17,IVM18,IVM20,IVM25,IVM26,IVM32,IVMIY   ;Add BT indicator EAS*1*113
"RTN","EASPREC7",37,0)
 N IVM2,IVM3,IVM7,IVM8,IVM10,IVM12,IVM17,IVM18,IVM20,IVM25,IVM26,IVM32,IVMIY  ; Add ivm32 BT indicator
"RTN","EASPREC7",38,0)
 N IVMDA,IVMPAT,IVMMTSTS,MTFND,UPMTS,MTDATE,TYPE,EASMTDT,EASZ06,EXPIRED
"RTN","EASPREC7",39,0)
 N IVM5,EASZ06D,DGMTYPT
"RTN","EASPREC7",40,0)
 S SEGSTR="00000000000"      ;One byte for each segment in message
"RTN","EASPREC7",41,0)
 S SEGMENTS="BHS,MSH,PID,ZIC,ZIR,ZDP,ZIC,ZIR,ZMT,ZIV,BTS"
"RTN","EASPREC7",42,0)
 S EDB="EDB-EAS"
"RTN","EASPREC7",43,0)
 S Z06COM="Z06 MT via Edb"
"RTN","EASPREC7",44,0)
 S (CASEFLG,DEPFLG,ERRFLG,HLERR,IVMDA,IVMFLGC,MTFND,UPMTS)=0
"RTN","EASPREC7",45,0)
EN1 F  S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA  D  I $D(HLERR) D ACK^IVMPREC S ERRFLG=1 Q 
"RTN","EASPREC7",46,0)
 .K HLERR
"RTN","EASPREC7",47,0)
 .D GET
"RTN","EASPREC7",48,0)
 .D @IVMSEG1                            ;process each segment type
"RTN","EASPREC7",49,0)
 Q:ERRFLG                               ;Error detected do not continue
"RTN","EASPREC7",50,0)
 S MISSING=$F(SEGSTR,0)                 ;Ensure all required segments
"RTN","EASPREC7",51,0)
 I MISSING D  I $D(HLERR) D ACK^IVMPREC,CLEANUP Q
"RTN","EASPREC7",52,0)
 . S TYPE=$S(MISSING=3!(MISSING=4):"Veteran's",MISSING>4&(MISSING<8):"Spouse's",1:"")
"RTN","EASPREC7",53,0)
 . S HLERR="Missing "_TYPE_" "_$P(SEGMENTS,",",(MISSING-1))_" Segment"
"RTN","EASPREC7",54,0)
 D PROCESS
"RTN","EASPREC7",55,0)
 I $D(HLERR) D ACK^IVMPREC
"RTN","EASPREC7",56,0)
 ;
"RTN","EASPREC7",57,0)
 ; cleanup
"RTN","EASPREC7",58,0)
CLEANUP K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,CANCFLG,IVMFLGC,IVMMT31
"RTN","EASPREC7",59,0)
 K IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,HLERR,CLOSFLG
"RTN","EASPREC7",60,0)
 K IVMZ10,IVMDAV,ZIVSEG,ZMTSEG
"RTN","EASPREC7",61,0)
 Q
"RTN","EASPREC7",62,0)
 ;
"RTN","EASPREC7",63,0)
 ;Dependent upon type of Z06 sent perform the following;
"RTN","EASPREC7",64,0)
 ;IVM Case Status:
"RTN","EASPREC7",65,0)
 ;  Value of 1 = Create/Update Z06 MT/CT, Close Case & Mark REASON CODE
"RTN","EASPREC7",66,0)
 ;               as 'Converted'
"RTN","EASPREC7",67,0)
 ;  Value of 0 = Cancel Z06 MT/CT and Mark REASON CODE as 'Not Convert'
"RTN","EASPREC7",68,0)
 ;
"RTN","EASPREC7",69,0)
 ; If Z06 MT/CT and IVM Case Status is 1 and Z06 MT/CT doesn't exist then
"RTN","EASPREC7",70,0)
 ;   Create new Z06 MT/CT (new Z06 MT/CT becomes primary and existing
"RTN","EASPREC7",71,0)
 ;     MT/CT becomes non-primary)
"RTN","EASPREC7",72,0)
 ;   Assign REASON CODE of 'Converted' in #301.5
"RTN","EASPREC7",73,0)
 ; If Z06 MT/CT already exists then
"RTN","EASPREC7",74,0)
 ;   If IVM Case Status is 0 Then
"RTN","EASPREC7",75,0)
 ;     Delete Z06 MT/CT for income year and return old MT/CT to primary
"RTN","EASPREC7",76,0)
 ;    Change REASON CODE from 'Converted' to 'Not Converted' in #301.5
"RTN","EASPREC7",77,0)
 ;   If IVM Case Status is 1 Then
"RTN","EASPREC7",78,0)
 ;     Update MT/CT Z06 and Close/Convert Case
"RTN","EASPREC7",79,0)
 ; Else  (Z06 MT/CT, IVM Case Status=0 and Z06 MT/CT does not exist)
"RTN","EASPREC7",80,0)
 ;   Send back 'AE' to Edb indicating MT/CT Z06 not available for 
"RTN","EASPREC7",81,0)
 ;   cancellation
"RTN","EASPREC7",82,0)
 ;
"RTN","EASPREC7",83,0)
PROCESS N DIC,%,%H,%I,IVMDATE
"RTN","EASPREC7",84,0)
 D NOW^%DTC
"RTN","EASPREC7",85,0)
 S IVMDATE=%
"RTN","EASPREC7",86,0)
 I '$D(ZMTSEG) S HLERR="ZMT Segment is Missing" Q
"RTN","EASPREC7",87,0)
 S EASZ06=1,EXPIRED=0
"RTN","EASPREC7",88,0)
 S:DGMTYPT=2 IVMCEB=$P($$RXST^IBARXEU(DFN),"^",2)    ;prev RX sts
"RTN","EASPREC7",89,0)
 I $G(IVMMTIEN)="" D  ; Find any primary for the same year/test type
"RTN","EASPREC7",90,0)
 . S CURMT=$$LST^DGMTU(DFN,IVMMTDT,DGMTYPT)
"RTN","EASPREC7",91,0)
 . I $E($P(CURMT,U,2),1,3)'=$E(IVMMTDT,1,3) Q  ;TMK
"RTN","EASPREC7",92,0)
 . S IVMMTIEN=$P(CURMT,"^",1)
"RTN","EASPREC7",93,0)
 . S IVMMTDT=$P(CURMT,"^",2)
"RTN","EASPREC7",94,0)
 . S IVMMTSTS=$P(CURMT,"^",3)
"RTN","EASPREC7",95,0)
 I $G(IVMMTIEN)]"" D                   ;dgmtp is event driver variable
"RTN","EASPREC7",96,0)
 . S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0))
"RTN","EASPREC7",97,0)
 ;
"RTN","EASPREC7",98,0)
 ; EAS*1*113
"RTN","EASPREC7",99,0)
 ; Send BT Bulletin if Current Means Test Status does not eqaul Previous Means Test Status
"RTN","EASPREC7",100,0)
 ;
"RTN","EASPREC7",101,0)
 ; Input:
"RTN","EASPREC7",102,0)
 ; DFN = IEN of Patient
"RTN","EASPREC7",103,0)
 N DT,DGCAT,FININD
"RTN","EASPREC7",104,0)
 ; DFN = IEN of Patient
"RTN","EASPREC7",105,0)
 ; DT = Today's Date
"RTN","EASPREC7",106,0)
 S DT=IVMDATE
"RTN","EASPREC7",107,0)
 ; DGCAT = Current Means Test Status
"RTN","EASPREC7",108,0)
 S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1)
"RTN","EASPREC7",109,0)
 ; IVMCEB = Previous Means Test Status
"RTN","EASPREC7",110,0)
 ; IVM10 = Date/Time Test Completed
"RTN","EASPREC7",111,0)
 S FININD="" I $D(IVMMTIEN) S FININD=$G(^DGMT(408.31,IVMMTIEN,4)) ;financial indicator EAS*1*113
"RTN","EASPREC7",112,0)
 ;
"RTN","EASPREC7",113,0)
 I IVM32'=FININD D SET^EASBTBUL(DFN,DT,DGCAT,$G(IVMCEB),$G(IVM10))
"RTN","EASPREC7",114,0)
 ; EAS*1*113 Only send when BTFI changes
"RTN","EASPREC7",115,0)
 ; Main loop to process the IVM income test just received.
"RTN","EASPREC7",116,0)
 ;
"RTN","EASPREC7",117,0)
 ; No previous 408.31 test on file
"RTN","EASPREC7",118,0)
 I 'MTFND D  Q
"RTN","EASPREC7",119,0)
 . I CASEFLG D                                ;Case=1 Close/Converted
"RTN","EASPREC7",120,0)
 . . ;change old MT/CT to non-primary
"RTN","EASPREC7",121,0)
 . . I $G(IVMMTIEN)>0 D
"RTN","EASPREC7",122,0)
 . . . S DA=IVMMTIEN,DIE="^DGMT(408.31,",DR="2////0;"
"RTN","EASPREC7",123,0)
 . . . D ^DIE K DA,DIE,DR
"RTN","EASPREC7",124,0)
 . . ;
"RTN","EASPREC7",125,0)
 . . S IVMMTDT=EASMTDT
"RTN","EASPREC7",126,0)
 . . D ^EASUM1                                ;Create New Z06 MT/CT
"RTN","EASPREC7",127,0)
 . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
"RTN","EASPREC7",128,0)
 . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
"RTN","EASPREC7",129,0)
 . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
"RTN","EASPREC7",130,0)
 . . D CLOSE^EASPTRN1(IVMIY,DFN,1,6)          ;Close Case/Converted
"RTN","EASPREC7",131,0)
 . ;
"RTN","EASPREC7",132,0)
 . I 'CASEFLG D  Q
"RTN","EASPREC7",133,0)
 . . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
"RTN","EASPREC7",134,0)
 . . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
"RTN","EASPREC7",135,0)
 ;
"RTN","EASPREC7",136,0)
 ; Previous 408.31 test on file
"RTN","EASPREC7",137,0)
 I MTFND D
"RTN","EASPREC7",138,0)
 . I 'CASEFLG D                             ;Case=0 Close/Not Convert
"RTN","EASPREC7",139,0)
 . . ; Check to see if MT/CT Z06 exists prior to trying to delete
"RTN","EASPREC7",140,0)
 . . ; If NOT defined then send an AE back to Edb
"RTN","EASPREC7",141,0)
 . . I 'UPMTS D  Q                          ;Existing Z06 not found
"RTN","EASPREC7",142,0)
 . . . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
"RTN","EASPREC7",143,0)
 . . . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
"RTN","EASPREC7",144,0)
 . . I UPMTS D  Q
"RTN","EASPREC7",145,0)
 . . . N CURMT,IVMMTI,IVMDFN,DGCAT
"RTN","EASPREC7",146,0)
 . . . S IVMDFN=DFN                         ;Save off DFN
"RTN","EASPREC7",147,0)
 . . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
"RTN","EASPREC7",148,0)
 . . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
"RTN","EASPREC7",149,0)
 . . . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
"RTN","EASPREC7",150,0)
 . . . S EASZ06D=1                          ;Set del flag for IB event
"RTN","EASPREC7",151,0)
 . . . D ^EASUM7                            ;Delete Z06 MT/CT
"RTN","EASPREC7",152,0)
 . . . S DFN=IVMDFN
"RTN","EASPREC7",153,0)
 . . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
"RTN","EASPREC7",154,0)
 . . . D CLOSE^EASPTRN1(IVMIY,DFN,1,7)      ;Close Case/Not Converted
"RTN","EASPREC7",155,0)
 . ;
"RTN","EASPREC7",156,0)
 . I CASEFLG D                              ;Case=1 Close/Converted
"RTN","EASPREC7",157,0)
 . . Q:$G(IVMMTIEN)<1
"RTN","EASPREC7",158,0)
 . . S DA=IVMMTIEN,DIE="^DGMT(408.31,"
"RTN","EASPREC7",159,0)
 . . S DR=".03////^S X=IVM3;.12////^S X=IVM8;.07////^S X=IVM10;"
"RTN","EASPREC7",160,0)
 . . S DR=DR_".09////^S X=IVM25;.11////^S X=IVM7;.18////^S X=IVM12;"
"RTN","EASPREC7",161,0)
 . . S DR=DR_".23////^S X=IVM18;.25////^S X=IVM20;"
"RTN","EASPREC7",162,0)
 . . S DR=DR_"2.02////^S X=IVMDATE;2.03////^S X=IVM26;"
"RTN","EASPREC7",163,0)
 . . S DR=DR_"4////^S X=IVM32"   ; *EAS*1*113 BT Financial Indicator
"RTN","EASPREC7",164,0)
 . . D ^DIE K DA,DIE,DR                     ;Update existing Z06
"RTN","EASPREC7",165,0)
 . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
"RTN","EASPREC7",166,0)
 . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
"RTN","EASPREC7",167,0)
 . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
"RTN","EASPREC7",168,0)
 . . D CLOSE^EASPTRN1(IVMIY,DFN,1,6)        ;Close Case/Converted
"RTN","EASPREC7",169,0)
 . . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
"RTN","EASPREC7",170,0)
 . . D MTBULL^EASUM7,MAIL^IVMUFNC()         ;Send Bulletin
"RTN","EASPREC7",171,0)
 Q
"RTN","EASPREC7",172,0)
 ;
"RTN","EASPREC7",173,0)
MSH S (HLMID,MSGID)=$P(IVMSEG,HLFS,10)         ;Message control id from MSH
"RTN","EASPREC7",174,0)
 Q
"RTN","EASPREC7",175,0)
PID S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
"RTN","EASPREC7",176,0)
 I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D  Q
"RTN","EASPREC7",177,0)
 . S HLERR="Invalid DFN"
"RTN","EASPREC7",178,0)
 I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) D  Q
"RTN","EASPREC7",179,0)
 . S HLERR="Couldn't match IVM SSN with DHCP SSN"
"RTN","EASPREC7",180,0)
 S IVMDAP=IVMDA                  ;Save IVMDA for veteran PID segment
"RTN","EASPREC7",181,0)
 Q
"RTN","EASPREC7",182,0)
ZIC I 'DEPFLG S IVMDGLY=$P(IVMSEG,"^",3)           ;Income year
"RTN","EASPREC7",183,0)
 Q
"RTN","EASPREC7",184,0)
ZIR Q
"RTN","EASPREC7",185,0)
ZDP S DEPFLG=1
"RTN","EASPREC7",186,0)
 Q
"RTN","EASPREC7",187,0)
 ;Get primary means test
"RTN","EASPREC7",188,0)
 ; IVMMTDT - means test date
"RTN","EASPREC7",189,0)
 ; DGLY - income year
"RTN","EASPREC7",190,0)
 ; If Means Test not in DHCP, don't upload IVM Means Test 
"RTN","EASPREC7",191,0)
 ;
"RTN","EASPREC7",192,0)
ZMT N IVMIEN,MTCODE                                             ;EAS*1*42
"RTN","EASPREC7",193,0)
 S IVMDAZ=IVMDA,ZMTSEG=IVMSEG            ;ZMT segment ivmda
"RTN","EASPREC7",194,0)
 D PARSEZMT(ZMTSEG)                      ;Retrieve ZMT Values
"RTN","EASPREC7",195,0)
 ;Means test date from ZMT segment
"RTN","EASPREC7",196,0)
 S (EASMTDT,IVMMTDT)=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3))
"RTN","EASPREC7",197,0)
 S DGMTYPT=$G(IVM17)                     ;int type of test
"RTN","EASPREC7",198,0)
 S:DGMTYPT="" DGMTYPT=1                  ;insure type defined
"RTN","EASPREC7",199,0)
 S DGLY=$$LYR^DGMTSCU1(IVMMTDT)          ;Get means test to be updated
"RTN","EASPREC7",200,0)
 S MTDATE=-IVMMTDT
"RTN","EASPREC7",201,0)
 S IVMIEN=""
"RTN","EASPREC7",202,0)
 S MTFND=0
"RTN","EASPREC7",203,0)
 F  S IVMIEN=$O(^DGMT(408.31,"AID",DGMTYPT,DFN,MTDATE,IVMIEN)) Q:MTFND!(IVMIEN="")  D
"RTN","EASPREC7",204,0)
 . S IVMMTIEN=IVMIEN
"RTN","EASPREC7",205,0)
 . ; match to MT Z06 from Edb
"RTN","EASPREC7",206,0)
 . S MTCODE=$P($G(^DGMT(408.31,IVMIEN,0)),"^",3)
"RTN","EASPREC7",207,0)
 . I (MTCODE=6)!(MTCODE=16)!(MTCODE=8) D    ;Previous Converted MT/CT?
"RTN","EASPREC7",208,0)
 . . S UPMTS=IVMIEN
"RTN","EASPREC7",209,0)
 . . S MTFND=1
"RTN","EASPREC7",210,0)
 Q
"RTN","EASPREC7",211,0)
ZIV S IVMDAV=IVMDA,ZIVSEG=IVMSEG
"RTN","EASPREC7",212,0)
 S IVMIY=$P(IVMSEG,HLFS,3)
"RTN","EASPREC7",213,0)
 S IVMIY=$$FMDATE^HLFNC(IVMIY)
"RTN","EASPREC7",214,0)
 I $E(IVMIY,4,7)'="0000"!($E(IVMIY,1,3)<292) D  Q
"RTN","EASPREC7",215,0)
 . S HLERR="Invalid Income Year"
"RTN","EASPREC7",216,0)
 I "01"'[$P(IVMSEG,HLFS,9) D  Q
"RTN","EASPREC7",217,0)
 . S HLERR="Case Status not 0 or 1"
"RTN","EASPREC7",218,0)
 I $P(IVMSEG,HLFS,9)=1 S CASEFLG=1         ;Close/Convert Case Flag
"RTN","EASPREC7",219,0)
 I $P(IVMSEG,HLFS,9)=0 S CASEFLG=0         ;Delete/Not Converted MT Flag
"RTN","EASPREC7",220,0)
BHS Q
"RTN","EASPREC7",221,0)
BTS Q
"RTN","EASPREC7",222,0)
 ;
"RTN","EASPREC7",223,0)
GET ; get HL7 segment from ^TMP
"RTN","EASPREC7",224,0)
 ;S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA))
"RTN","EASPREC7",225,0)
 S IVMSEG=$G(^TMP($J,IVMRTN,+IVMDA,0))
"RTN","EASPREC7",226,0)
 S IVMSEG1=$E(IVMSEG,1,3)
"RTN","EASPREC7",227,0)
 S $E(SEGSTR,IVMDA)=1
"RTN","EASPREC7",228,0)
 Q
"RTN","EASPREC7",229,0)
 ;
"RTN","EASPREC7",230,0)
 ;Parse ZMT Segment for MT Data
"RTN","EASPREC7",231,0)
 ;
"RTN","EASPREC7",232,0)
PARSEZMT(ZSEG) ; PARSE THE SEGMEMT
"RTN","EASPREC7",233,0)
 S IVM2=$$FMDATE^HLFNC($P(ZSEG,"^",3))  ;Means Test Date
"RTN","EASPREC7",234,0)
 S IVM3=$O(^DG(408.32,"C",$P(ZSEG,"^",4),""))   ;Means Test Status 
"RTN","EASPREC7",235,0)
 S IVM7=$S($P(ZSEG,"^",8)="Y":1,1:0)            ;Agrees To Deductible
"RTN","EASPREC7",236,0)
 S IVM8=$P(ZSEG,"^",9)                          ;Threshold A
"RTN","EASPREC7",237,0)
 S IVM10=$$FMDATE^HLFNC($P(ZSEG,"^",11))        ;Date/Time Completed
"RTN","EASPREC7",238,0)
 S IVM12=$P(ZSEG,"^",13)                        ;Number of Dependents
"RTN","EASPREC7",239,0)
 S IVM17=$P(ZSEG,"^",18)                        ;Type of Test
"RTN","EASPREC7",240,0)
 S IVM18=$P(ZSEG,"^",19)                        ;Source of Test
"RTN","EASPREC7",241,0)
 S IVM20=$$FMDATE^HLFNC($P(ZSEG,"^",21))        ;IVM Verified MT
"RTN","EASPREC7",242,0)
 S IVM25=$$FMDATE^HLFNC($P(ZSEG,"^",26))        ;D/T Last Changed
"RTN","EASPREC7",243,0)
 S IVM26=$O(^DG(408.32,"C",$P(ZSEG,"^",27),"")) ;Test Determined Status
"RTN","EASPREC7",244,0)
 S IVM32=$P(ZSEG,"^",32)                        ;EAS*1*113 
"RTN","EASPREC7",245,0)
 ;S IVM32=$S(IVM32="Y":1,IVM32="N":0,1:IVM32)    ;BT Financial Indicator
"RTN","EASPREC7",246,0)
 S IVM32=$S(IVM32["""":"",1:IVM32) ;BT Financial Indicator
"RTN","EASPREC7",247,0)
 Q
"RTN","EASPREC7",248,0)
 ;
"RTN","EASUM1")
0^6^B30155239
"RTN","EASUM1",1,0)
EASUM1 ;ALB/SEK,GN,MNH - IVM MEANS/COPAY TEST UPLOAD DRIVER ;7/6/04 1:23pm
"RTN","EASUM1",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**23,30,35,42,86,113**;21-OCT-94;Build 53
"RTN","EASUM1",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EASUM1",4,0)
 ;
"RTN","EASUM1",5,0)
 ;EAS*1*42 add RX Copay to Z06 Upload/Delete
"RTN","EASUM1",6,0)
 ;
"RTN","EASUM1",7,0)
EN ; this routine will call routines to upload means tests sent by the IVM
"RTN","EASUM1",8,0)
 ; Center in HL7 segments.  the required sequence of these segments were
"RTN","EASUM1",9,0)
 ; validated in the calling routine IVMPREC7.  this routine will call
"RTN","EASUM1",10,0)
 ; IVMUCHK to ensure that the data is consistent with DHCP means test
"RTN","EASUM1",11,0)
 ; file and software requirements.
"RTN","EASUM1",12,0)
 ;
"RTN","EASUM1",13,0)
 ; entries will be added/modified in the following means test and
"RTN","EASUM1",14,0)
 ; patient files:
"RTN","EASUM1",15,0)
 ;
"RTN","EASUM1",16,0)
 ;       PATIENT RELATION (#408.12)
"RTN","EASUM1",17,0)
 ;       INCOME PERSON (#408.13)
"RTN","EASUM1",18,0)
 ;       INDIVIDUAL ANNUAL INCOME (#408.21)
"RTN","EASUM1",19,0)
 ;       INCOME RELATION (#408.22)
"RTN","EASUM1",20,0)
 ;       ANNUAL MEANS TEST (#408.31)
"RTN","EASUM1",21,0)
 ;       MEANS TEST CHANGES (#408.41)
"RTN","EASUM1",22,0)
 ;       PATIENT (#2)
"RTN","EASUM1",23,0)
 ;
"RTN","EASUM1",24,0)
 ; current year is date of means test.
"RTN","EASUM1",25,0)
 ; income year is calendar year before date of means test.
"RTN","EASUM1",26,0)
 ; meant test status is based on income year data.
"RTN","EASUM1",27,0)
 ;
"RTN","EASUM1",28,0)
 ; IVMDAP is pointer to the PID HL7 segment in file #772
"RTN","EASUM1",29,0)
 ; IVMDAZ is pointer to the ZMT segment
"RTN","EASUM1",30,0)
 ;
"RTN","EASUM1",31,0)
 S:'$D(DUZ) DUZ=.5 ; if no DUZ set to postmaster
"RTN","EASUM1",32,0)
 ;
"RTN","EASUM1",33,0)
 ; get copay exemption status (IVMCEB) and means test status (IVMMTB)
"RTN","EASUM1",34,0)
 ; before upload
"RTN","EASUM1",35,0)
 S IVMCEB=$P($$RXST^IBARXEU(DFN),"^",2)
"RTN","EASUM1",36,0)
 S IVMMTB=$P($$LST^DGMTU(DFN),"^",3)
"RTN","EASUM1",37,0)
 ;
"RTN","EASUM1",38,0)
 ; subscript of array IVMAR is ien of 408.12 transmitted by IVM Center
"RTN","EASUM1",39,0)
 ; or created by upload.
"RTN","EASUM1",40,0)
 ;K IVMAR
"RTN","EASUM1",41,0)
 ;S IVMX=$$EN^IVMUCHK() I IVMX]"" S HLERR=IVMX K IVMX Q  ; error found in MT data
"RTN","EASUM1",42,0)
 ;
"RTN","EASUM1",43,0)
ADD ; add new annual means test file (408.31) stub
"RTN","EASUM1",44,0)
 ; input   DGMTDT (.01) dt of test
"RTN","EASUM1",45,0)
 ;         DFN (.02) Patient IEN
"RTN","EASUM1",46,0)
 ;         DGMTYPT (.19) type of test (1-means test, 2-Rx Copay test)
"RTN","EASUM1",47,0)
 ; output  DGMTI annual means test IEN
"RTN","EASUM1",48,0)
 S DGMTDT=IVMMTDT
"RTN","EASUM1",49,0)
 D ADD^DGMTA
"RTN","EASUM1",50,0)
 I $G(IVMMTIEN)="" S IVMMTIEN=$G(DGMTI) ;Set IEN if only MT on file is Z06 MT
"RTN","EASUM1",51,0)
 ;
"RTN","EASUM1",52,0)
 ;Create new Z06 IVM Means Test
"RTN","EASUM1",53,0)
 ; Make STUB MT primary, add comment that it was created by Edb
"RTN","EASUM1",54,0)
 S DGCOM="Z06 MT via Edb"
"RTN","EASUM1",55,0)
 D PARSEZMT^EASPREC7(ZMTSEG)              ;Parse ZMT Segment for MT Data
"RTN","EASUM1",56,0)
 I $$EXPIRED^EASPTRN1(DFN,$G(IVM2)) S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"    ;If MT expired then do not update Enrollment record
"RTN","EASUM1",57,0)
 S DA=DGMTI,DIE="^DGMT(408.31,"
"RTN","EASUM1",58,0)
 S DR=".03////^S X=IVM3;.12////^S X=IVM8;.07////^S X=IVM10;.09////^S X=IVM25;.11////^S X=IVM7;.18////^S X=IVM12;.23////^S X=IVM18;.25////^S X=IVM20;2////1;2.02////^S X=IVMDATE;2.03////^S X=IVM26;50///^S X=DGCOM"
"RTN","EASUM1",59,0)
 ;
"RTN","EASUM1",60,0)
 ; Linking logic for MT & CT, conditionally set link field 2.06 
"RTN","EASUM1",61,0)
 ;   Link the CT to MT (if MT found), or MT to CT (if CT found)
"RTN","EASUM1",62,0)
 ;   don't link tests older than Oct. 1999 or not same Year
"RTN","EASUM1",63,0)
 N LNKDAT,LNKMT,LNKDTE,LNKCAT,CURIEN
"RTN","EASUM1",64,0)
 S CURIEN=DGMTI,LNKMT=""
"RTN","EASUM1",65,0)
 S LNKDAT=$$LST^DGMTU(DFN,DGMTDT,$S(DGMTYPT=1:2,1:1)),DGMTI=CURIEN
"RTN","EASUM1",66,0)
 S:LNKDAT LNKMT=+LNKDAT,LNKDTE=$P(LNKDAT,"^",2),LNKCAT=$P(LNKDAT,"^",4)
"RTN","EASUM1",67,0)
 ; set LNKMT off if either of two scenarios below
"RTN","EASUM1",68,0)
 I LNKMT D
"RTN","EASUM1",69,0)
 . I $E(LNKDTE,1,3)'=$E(DGMTDT,1,3) S LNKMT="@" Q
"RTN","EASUM1",70,0)
 . I DGMTDT<2991001 S LNKMT="" Q
"RTN","EASUM1",71,0)
 S:LNKMT'="" DR=DR_";2.06////^S X=LNKMT"
"RTN","EASUM1",72,0)
 ;
"RTN","EASUM1",73,0)
 D ^DIE K DA,DIE,DR                            ;update new 408.31 test
"RTN","EASUM1",74,0)
 ;
"RTN","EASUM1",75,0)
 ; Update other 408.31 related Test, Link field, if link scenario true
"RTN","EASUM1",76,0)
 I LNKMT S DA=LNKMT,DIE="^DGMT(408.31,",DR="2.06////^S X=CURIEN" D ^DIE K DA,DIE,DR
"RTN","EASUM1",77,0)
 ;
"RTN","EASUM1",78,0)
 ;Variables needed for Bulletins
"RTN","EASUM1",79,0)
 ;
"RTN","EASUM1",80,0)
 S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1)
"RTN","EASUM1",81,0)
 I '$D(IVM5) S IVM5=""
"RTN","EASUM1",82,0)
 ;
"RTN","EASUM1",83,0)
 D GETREL^DGMTU11(DFN,"V",DGLY,IVMMTIEN)
"RTN","EASUM1",84,0)
 I EASZ06 S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0)) ;dgmtp is event driver variable
"RTN","EASUM1",85,0)
 D COMPLETE
"RTN","EASUM1",86,0)
 Q
"RTN","EASUM1",87,0)
 ;
"RTN","EASUM1",88,0)
 ; add dependent(s) to income person file (408.13)
"RTN","EASUM1",89,0)
 ;
"RTN","EASUM1",90,0)
 ; add spouse if not in 408.13
"RTN","EASUM1",91,0)
 S IVMSPCHV="S" ; spouse/child/vet indicator
"RTN","EASUM1",92,0)
 S IVMDA1=IVMDAP+3 D GET ; spouse ZDP segment
"RTN","EASUM1",93,0)
 D INPIEN^IVMUM2
"RTN","EASUM1",94,0)
 Q:$D(IVMFERR)
"RTN","EASUM1",95,0)
 ;
"RTN","EASUM1",96,0)
 I IVMFLG5 G ADDCHILD ; entry not added - goto add children
"RTN","EASUM1",97,0)
 ;
"RTN","EASUM1",98,0)
 ; add entry to patient relation file (408.12)
"RTN","EASUM1",99,0)
 D EN^IVMUM3
"RTN","EASUM1",100,0)
 Q:$D(IVMFERR)
"RTN","EASUM1",101,0)
 ;
"RTN","EASUM1",102,0)
ADDS21 ; add spouse entry to individual annual income file (408.21)
"RTN","EASUM1",103,0)
 S IVMDA1=IVMDAP+4 D GET ; spouse ZIC segment
"RTN","EASUM1",104,0)
 D EN^IVMUM4
"RTN","EASUM1",105,0)
 Q:$D(IVMFERR)
"RTN","EASUM1",106,0)
 ;
"RTN","EASUM1",107,0)
 ; add spouse entry to income relation file (408.22)
"RTN","EASUM1",108,0)
 S IVMDA1=IVMDAP+5 D GET ; spouse ZIR segment
"RTN","EASUM1",109,0)
 D EN^EASUM5  ;EAS*1*113
"RTN","EASUM1",110,0)
 Q:$D(IVMFERR)
"RTN","EASUM1",111,0)
 ;
"RTN","EASUM1",112,0)
ADDCHILD ; add children if not in 408.13
"RTN","EASUM1",113,0)
 S IVMSPCHV="C" ; spouse/child/vet indicator
"RTN","EASUM1",114,0)
 I 'IVMFLGC G ADDV21 ; no dependent children 
"RTN","EASUM1",115,0)
 S IVMCTR2=5
"RTN","EASUM1",116,0)
 F IVMCTR3=1:1:IVMFLGC D  Q:$D(IVMFERR)
"RTN","EASUM1",117,0)
 .S IVMCTR2=IVMCTR2+1
"RTN","EASUM1",118,0)
 .S IVMDA1=IVMDAP+IVMCTR2 D GET ; child ZDP segment
"RTN","EASUM1",119,0)
 .D INPIEN^IVMUM2
"RTN","EASUM1",120,0)
 .Q:$D(IVMFERR)
"RTN","EASUM1",121,0)
 .;
"RTN","EASUM1",122,0)
 .; add child entry to patient relation file (408.12)
"RTN","EASUM1",123,0)
 .D EN^IVMUM3
"RTN","EASUM1",124,0)
 .Q:$D(IVMFERR)
"RTN","EASUM1",125,0)
 .;
"RTN","EASUM1",126,0)
ADDC21 .; add child entry to individual annual income file (408.21)
"RTN","EASUM1",127,0)
 .S IVMCTR2=IVMCTR2+1
"RTN","EASUM1",128,0)
 .S IVMDA1=IVMDAP+IVMCTR2 D GET ; child ZIC segment
"RTN","EASUM1",129,0)
 .D EN^IVMUM4
"RTN","EASUM1",130,0)
 .Q:$D(IVMFERR)
"RTN","EASUM1",131,0)
 .;
"RTN","EASUM1",132,0)
 .; add entry to income relation file (408.22)
"RTN","EASUM1",133,0)
 .S IVMCTR2=IVMCTR2+1
"RTN","EASUM1",134,0)
 .S IVMDA1=IVMDAP+IVMCTR2 D GET ; child ZIR segment
"RTN","EASUM1",135,0)
 .D EN^EASUM5   ;EAS*1*113
"RTN","EASUM1",136,0)
 .Q:$D(IVMFERR)
"RTN","EASUM1",137,0)
 .Q
"RTN","EASUM1",138,0)
 Q:$D(IVMFERR)
"RTN","EASUM1",139,0)
 ;
"RTN","EASUM1",140,0)
ADDV21 ; add vet entry to individual annual income file (408.21)
"RTN","EASUM1",141,0)
 ; get vet patient relation ien
"RTN","EASUM1",142,0)
 S DGPRI=+$G(DGREL("V"))
"RTN","EASUM1",143,0)
 S IVMDA1=IVMDAP+1 D GET ; vet ZIC segment
"RTN","EASUM1",144,0)
 S IVMSPCHV="V" ; spouse/child/vet indicator
"RTN","EASUM1",145,0)
 D EN^IVMUM4
"RTN","EASUM1",146,0)
 Q:$D(IVMFERR)
"RTN","EASUM1",147,0)
 S DGVINI=DGINI ; vet individual annual income ien
"RTN","EASUM1",148,0)
 ;
"RTN","EASUM1",149,0)
 ; add vet entry to income relation file (408.22)
"RTN","EASUM1",150,0)
 S IVMDA1=IVMDAP+2 D GET ; vet ZIR segment
"RTN","EASUM1",151,0)
 D EN^EASUM5   ;EAS*1*113
"RTN","EASUM1",152,0)
 Q:$D(IVMFERR)
"RTN","EASUM1",153,0)
 S DGVIRI=DGIRI ; vet income relation ien
"RTN","EASUM1",154,0)
 ;
"RTN","EASUM1",155,0)
COMPLETE ; complete means test
"RTN","EASUM1",156,0)
 ;
"RTN","EASUM1",157,0)
 ;D EN^IVMUM6
"RTN","EASUM1",158,0)
 ;Call Means Test Event Driver to complete processing
"RTN","EASUM1",159,0)
 ;
"RTN","EASUM1",160,0)
 S DGMTACT="UPL"
"RTN","EASUM1",161,0)
 D AFTER^DGMTEVT
"RTN","EASUM1",162,0)
 S DGMTINF=1                                    ;Non-Interactive Flag
"RTN","EASUM1",163,0)
 D EN^DGMTEVT
"RTN","EASUM1",164,0)
 D MTBULL^EASUM7,MAIL^IVMUFNC()               ;Build Mail Message
"RTN","EASUM1",165,0)
 ;
"RTN","EASUM1",166,0)
 ; cleanup                                  ;EAS*1*42   remove Dgmtypt
"RTN","EASUM1",167,0)
 K DGINI,DGIRI,DGLY,DGMTDT,DGPRI,DGREL,DGVINI,DGVIRI,DGENUPLD
"RTN","EASUM1",168,0)
 K DGCAT,IVMAR,IVMCEB,IVMCTR2,IVMCTR3,IVMDA1,IVMDAP,IVMFERR
"RTN","EASUM1",169,0)
 K IVMFLG2,IVMFLG5,IVMFLGC,IVMMTB,IVMPRN
"RTN","EASUM1",170,0)
 K IVMRELN,IVMRELO,IVMSEG,IVMSPCHV,IVMX
"RTN","EASUM1",171,0)
 Q
"RTN","EASUM1",172,0)
 ; 
"RTN","EASUM1",173,0)
GET ; get HL7 segment from ^HL
"RTN","EASUM1",174,0)
 S IVMSEG=$P($G(^TMP($J,IVMRTN,IVMDA1,0)),"^",2,999)
"RTN","EASUM1",175,0)
 Q
"RTN","EASUM5")
0^7^B16512870
"RTN","EASUM5",1,0)
EASUM5 ;ALB/SEK,MNH - ADD NEW INCOME RELATION FILE ENTRIES ;19 MAY 94 9:30am
"RTN","EASUM5",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**113**;21-OCT-94 ;Build 53
"RTN","EASUM5",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EASUM5",4,0)
 ;
"RTN","EASUM5",5,0)
 ;CLONED FROM IVMUM5
"RTN","EASUM5",6,0)
 ;
"RTN","EASUM5",7,0)
EN ; this routine will add entries to INCOME RELATION file (408.22) 
"RTN","EASUM5",8,0)
 ; will also inactivate VAMC dependents (spouse & children) who are not
"RTN","EASUM5",9,0)
 ; IVM dependents, by adding an inactivate entry into the EFFECTIVE DATE
"RTN","EASUM5",10,0)
 ; sub-file (multiple-408.1275) of the PATIENT RELATION file (#408.12)
"RTN","EASUM5",11,0)
 ;
"RTN","EASUM5",12,0)
 ; DFN    Patient file IEN
"RTN","EASUM5",13,0)
 ; DGINI  Individual Annual Income IEN
"RTN","EASUM5",14,0)
 ; DGIRI  Income Relation IEN
"RTN","EASUM5",15,0)
 ; IVMSEG ZIR record for veteran or spouse or dependent
"RTN","EASUM5",16,0)
 ; IVM0   408.22 0 node pieces 5-7
"RTN","EASUM5",17,0)
 ; IVM01         0 node pieces 9-12
"RTN","EASUM5",18,0)
 ; IVM02         0 node piece  6
"RTN","EASUM5",19,0)
 ; IVM03         0 node piece 20 EAS*1*113
"RTN","EASUM5",20,0)
 ;
"RTN","EASUM5",21,0)
 N IVM0,IVM01,IVM02,IVM03
"RTN","EASUM5",22,0)
 S DGIRI=$$ADDIR^DGMTU2(DFN,DGINI)
"RTN","EASUM5",23,0)
 ;
"RTN","EASUM5",24,0)
 ; if can't create stub notify site & IVM Center
"RTN","EASUM5",25,0)
 I DGIRI'>0 D  Q
"RTN","EASUM5",26,0)
 .S (IVMTEXT(6),HLERR)="Can't create stub for file 408.22"
"RTN","EASUM5",27,0)
 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
"RTN","EASUM5",28,0)
 .S IVMFERR=""
"RTN","EASUM5",29,0)
 ;
"RTN","EASUM5",30,0)
 ; set "mt" node to annual means test ien
"RTN","EASUM5",31,0)
 D MT^DGMTSCU3(DGIRI,DGMTI)
"RTN","EASUM5",32,0)
 Q:IVMSPCHV="S"
"RTN","EASUM5",33,0)
 ;
"RTN","EASUM5",34,0)
 ; set number of dependent children (#.13) and dependent children(#.08)
"RTN","EASUM5",35,0)
 ; in income relation file (#408.22) based on active child dependents
"RTN","EASUM5",36,0)
 ; in patient relation file (#408.12).
"RTN","EASUM5",37,0)
 ; make IVM means test primary income test for year
"RTN","EASUM5",38,0)
 I IVMSPCHV="V" D  Q:$D(IVMFERR)
"RTN","EASUM5",39,0)
 .S DA=IVMMTIEN,DIE="^DGMT(408.31,",DR="2////0" D ^DIE ; vamc mt
"RTN","EASUM5",40,0)
 .S DA=DGMTI,DIE="^DGMT(408.31,",DR="2////1" D ^DIE ; ivm mt
"RTN","EASUM5",41,0)
 .;S DR=DR_"0////^S X=IVM03;21"    ;EAS*1*113
"RTN","EASUM5",42,0)
 .;
"RTN","EASUM5",43,0)
 .; inactivate VAMC dependents who are not IVM dependents
"RTN","EASUM5",44,0)
 .K DGREL("V")
"RTN","EASUM5",45,0)
 .I $D(DGREL) D INACTIVE Q:$D(IVMFERR)
"RTN","EASUM5",46,0)
 .;
"RTN","EASUM5",47,0)
 .D RESET^DGMTU11(DFN,DGLY,DGMTI)
"RTN","EASUM5",48,0)
 .I $P($G(^DGMT(408.22,DGIRI,0)),"^",8)="" D
"RTN","EASUM5",49,0)
 ..S DA=DGIRI,DR=".08////0;.13////@",DIE="^DGMT(408.22," D ^DIE
"RTN","EASUM5",50,0)
 ..K DA,DR,DIE
"RTN","EASUM5",51,0)
 .S IVM0=$P(IVMSEG,"^",2,4)
"RTN","EASUM5",52,0)
 I IVMSPCHV="C" S IVM01=$P(IVMSEG,"^",6,9),IVM02=$P(IVMSEG,"^",3),IVM02=$P(IVMSEG,"^",30),IVM03=$P(IVMSEG,"^",15)  ; EAS*1*113
"RTN","EASUM5",53,0)
 S DIK="^DGMT(408.22,"
"RTN","EASUM5",54,0)
 L +^DGMT(408.22,DGIRI):5 S:IVMSPCHV="V" $P(^DGMT(408.22,DGIRI,0),"^",5,7)=IVM0 S:IVMSPCHV="C" $P(^DGMT(408.22,DGIRI,0),"^",9,12)=IVM01,$P(^(0),"^",6)=IVM02,$P(^(0),"^",20)=IVM03 S DA=DGIRI D IX1^DIK L -^DGMT(408.22,DGIRI)  ;EAS*1*113
"RTN","EASUM5",55,0)
 K DA,DIK
"RTN","EASUM5",56,0)
 Q
"RTN","EASUM5",57,0)
 ;
"RTN","EASUM5",58,0)
INACTIVE ; inactivate dependents not in IVM means test and kill
"RTN","EASUM5",59,0)
 ; corresponding dgrel
"RTN","EASUM5",60,0)
 I $D(DGREL("S")) S DA(1)=+DGREL("S") D  K DGREL("S")
"RTN","EASUM5",61,0)
 .D CHKINACT
"RTN","EASUM5",62,0)
 .Q:IVMFLG6!($D(IVMFERR))
"RTN","EASUM5",63,0)
 .; if spouse was active before income year, add record with date
"RTN","EASUM5",64,0)
 .; of 12/31 of year before income year with active code 0
"RTN","EASUM5",65,0)
 .S X=$E(DGLY,1,3)-1_1231
"RTN","EASUM5",66,0)
 .D INACT1
"RTN","EASUM5",67,0)
 Q:'$D(DGREL)!($D(IVMFERR))
"RTN","EASUM5",68,0)
 S IVMACTR=0
"RTN","EASUM5",69,0)
 F  S IVMACTR=$O(DGREL("C",IVMACTR)) Q:'IVMACTR  S DA(1)=+DGREL("C",IVMACTR) D  K DGREL("C",IVMACTR)
"RTN","EASUM5",70,0)
 .D CHKINACT
"RTN","EASUM5",71,0)
 .Q:IVMFLG6!($D(IVMFERR))
"RTN","EASUM5",72,0)
 .; if child was active before income year, add record with date
"RTN","EASUM5",73,0)
 .; of 12/31 of year before income year with active code 0
"RTN","EASUM5",74,0)
 .S X=$E(DGLY,1,3)-1_1231
"RTN","EASUM5",75,0)
 .D INACT1
"RTN","EASUM5",76,0)
 ;
"RTN","EASUM5",77,0)
 K IVMACTR,IVMDGLY,IVMFLG6,IVMYEAR
"RTN","EASUM5",78,0)
 Q
"RTN","EASUM5",79,0)
 ;
"RTN","EASUM5",80,0)
CHKINACT ; if dependent was made active during income year
"RTN","EASUM5",81,0)
 ; add record for same date (add .08 time) with active code 0
"RTN","EASUM5",82,0)
 ;
"RTN","EASUM5",83,0)
 S IVMFLG6=0
"RTN","EASUM5",84,0)
 S IVMDGLY="" F  S IVMDGLY=$O(^DGPR(408.12,DA(1),"E","B",IVMDGLY)) Q:IVMDGLY']""  D  Q:IVMFLG6!($D(IVMFERR))
"RTN","EASUM5",85,0)
 .Q:$E(IVMDGLY,1,3)'=$E(DGLY,1,3)
"RTN","EASUM5",86,0)
 .S IVMYEAR=0 F  S IVMYEAR=$O(^(IVMDGLY,IVMYEAR)) Q:IVMYEAR']""  D  Q:IVMFLG6!($D(IVMFERR))
"RTN","EASUM5",87,0)
 ..I $P($G(^DGPR(408.12,DA(1),"E",IVMYEAR,0)),"^",2) D
"RTN","EASUM5",88,0)
 ...S X=IVMDGLY_.08 D INACT1 S IVMFLG6=1
"RTN","EASUM5",89,0)
 ...Q
"RTN","EASUM5",90,0)
 Q
"RTN","EASUM5",91,0)
 ;
"RTN","EASUM5",92,0)
INACT1 ; add inactivate entry to 408.1275
"RTN","EASUM5",93,0)
 ;
"RTN","EASUM5",94,0)
 K DINUM
"RTN","EASUM5",95,0)
 S (DIK,DIC)="^DGPR(408.12,DA(1),""E"",",DIC(0)="L",DLAYGO=408.1275 K DD,DO D FILE^DICN S DA=+Y K DLAYGO
"RTN","EASUM5",96,0)
 ;
"RTN","EASUM5",97,0)
 ; if can't create stub notify site & IVM Center
"RTN","EASUM5",98,0)
 I DA'>0 D  Q
"RTN","EASUM5",99,0)
 .S (IVMTEXT(6),HLERR)="Can't create stub for file 408.1275"
"RTN","EASUM5",100,0)
 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
"RTN","EASUM5",101,0)
 .S IVMFERR=""
"RTN","EASUM5",102,0)
 L +^DGPR(408.12,+DGPRI):5 S $P(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=0_"^"_1_"^"_DGMTI D IX1^DIK L -^DGPR(408.12,+DGPRI)
"RTN","EASUM5",103,0)
 K DA,DIC,DIK
"RTN","EASUM5",104,0)
 Q
"RTN","EASUM6")
0^2^B31577950
"RTN","EASUM6",1,0)
EASUM6 ;ALB/BDB,MNH - IVM MEANS/COPAY TEST UPLOAD DRIVER ;7/6/04 1:23pm
"RTN","EASUM6",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**111,113**;21-OCT-94;Build 53
"RTN","EASUM6",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","EASUM6",4,0)
 ;
"RTN","EASUM6",5,0)
 ;Cloned from EASUM1
"RTN","EASUM6",6,0)
 ;
"RTN","EASUM6",7,0)
EN ; this routine will call routines to upload means tests sent by the IVM
"RTN","EASUM6",8,0)
 ; Center in HL7 segments. the required sequence of these segments were
"RTN","EASUM6",9,0)
 ; validated in the calling routine IVMPREC7. this routine will call
"RTN","EASUM6",10,0)
 ; IVMUCHK to ensure that the data is consistent with DHCP means test
"RTN","EASUM6",11,0)
 ; file and software requirements.
"RTN","EASUM6",12,0)
 ;
"RTN","EASUM6",13,0)
 ; entries will be added/modified in the following means test and
"RTN","EASUM6",14,0)
 ; patient files:
"RTN","EASUM6",15,0)
 ;
"RTN","EASUM6",16,0)
 ; PATIENT RELATION (#408.12)
"RTN","EASUM6",17,0)
 ; INCOME PERSON (#408.13)
"RTN","EASUM6",18,0)
 ; INDIVIDUAL ANNUAL INCOME (#408.21)
"RTN","EASUM6",19,0)
 ; INCOME RELATION (#408.22)
"RTN","EASUM6",20,0)
 ; ANNUAL MEANS TEST (#408.31)
"RTN","EASUM6",21,0)
 ; MEANS TEST CHANGES (#408.41)
"RTN","EASUM6",22,0)
 ; PATIENT (#2)
"RTN","EASUM6",23,0)
 ;
"RTN","EASUM6",24,0)
 ; current year is date of means test.
"RTN","EASUM6",25,0)
 ; income year is calendar year before date of means test.
"RTN","EASUM6",26,0)
 ; meant test status is based on income year data.
"RTN","EASUM6",27,0)
 ;
"RTN","EASUM6",28,0)
 ; IVMDAP is pointer to the PID HL7 segment in file #772
"RTN","EASUM6",29,0)
 ; IVMDAZ is pointer to the ZMT segment
"RTN","EASUM6",30,0)
 ;
"RTN","EASUM6",31,0)
 S:'$D(DUZ) DUZ=.5 ; if no DUZ set to postmaster
"RTN","EASUM6",32,0)
 ;
"RTN","EASUM6",33,0)
 ; get copay exemption status (IVMCEB) and means test status (IVMMTB)
"RTN","EASUM6",34,0)
 ; before upload
"RTN","EASUM6",35,0)
 S IVMCEB=$P($$RXST^IBARXEU(DFN),"^",2)
"RTN","EASUM6",36,0)
 S IVMMTB=$P($$LST^DGMTU(DFN),"^",3)
"RTN","EASUM6",37,0)
 ;
"RTN","EASUM6",38,0)
 ; subscript of array IVMAR is ien of 408.12 transmitted by IVM Center
"RTN","EASUM6",39,0)
 ; or created by upload.
"RTN","EASUM6",40,0)
 ;K IVMAR
"RTN","EASUM6",41,0)
 ;S IVMX=$$EN^IVMUCHK() I IVMX]"" S HLERR=IVMX K IVMX Q ; error found in MT data
"RTN","EASUM6",42,0)
 ;
"RTN","EASUM6",43,0)
ADD ; add new annual means test file (408.31) stub
"RTN","EASUM6",44,0)
 ; input DGMTDT (.01) dt of test
"RTN","EASUM6",45,0)
 ; DFN (.02) Patient IEN
"RTN","EASUM6",46,0)
 ; DGMTYPT (.19) type of test (1-means test, 2-Rx Copay test)
"RTN","EASUM6",47,0)
 ; output DGMTI annual means test IEN
"RTN","EASUM6",48,0)
 S DGMTDT=IVMMTDT
"RTN","EASUM6",49,0)
 D ADD^DGMTA
"RTN","EASUM6",50,0)
 I $G(IVMMTIEN)="" S IVMMTIEN=$G(DGMTI) ;Set IEN if only MT on file is Z06 MT
"RTN","EASUM6",51,0)
 ;
"RTN","EASUM6",52,0)
 ;Create new Z06 IVM Means Test
"RTN","EASUM6",53,0)
 ; Make STUB MT primary, add comment that it was created by Edb
"RTN","EASUM6",54,0)
 S DGCOM="Z06 MT via Edb"
"RTN","EASUM6",55,0)
 D PARSEZMT^EASPREC6(ZMTSEG) ;Parse ZMT Segment for MT Data
"RTN","EASUM6",56,0)
 I $$EXPIRED^EASPTRN1(DFN,$G(IVM2)) S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"    ;If MT expired then do not update Enrollment record
"RTN","EASUM6",57,0)
 S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS" ;EAS*1.0*111 Do not update Enrollment record.
"RTN","EASUM6",58,0)
 S DA=DGMTI,DIE="^DGMT(408.31,"
"RTN","EASUM6",59,0)
 S DR=".03////^S X=IVM3;.12////^S X=IVM8;.07////^S X=IVM10;.09////^S X=IVM25;.11////^S X=IVM7;.18////^S X=IVM12;"
"RTN","EASUM6",60,0)
 S DR=DR_".23////^S X=IVM18;.25////^S X=IVM20;2////1;2.02////^S X=IVMDATE;2.03////^S X=IVM26;2////1;4////^S X=IVM32;50///^S X=DGCOM;" ;BT Financial Indicator EAS*1*113
"RTN","EASUM6",61,0)
 ;
"RTN","EASUM6",62,0)
 ; Linking logic for MT & CT, conditionally set link field 2.06 
"RTN","EASUM6",63,0)
 ; Link the CT to MT (if MT found), or MT to CT (if CT found)
"RTN","EASUM6",64,0)
 ; don't link tests older than Oct. 1999 or not same Year
"RTN","EASUM6",65,0)
 N LNKDAT,LNKMT,LNKDTE,LNKCAT,CURIEN
"RTN","EASUM6",66,0)
 S CURIEN=DGMTI,LNKMT=""
"RTN","EASUM6",67,0)
 S LNKDAT=$$LST^DGMTU(DFN,DGMTDT,$S(DGMTYPT=1:2,1:1)),DGMTI=CURIEN
"RTN","EASUM6",68,0)
 S:LNKDAT LNKMT=+LNKDAT,LNKDTE=$P(LNKDAT,"^",2),LNKCAT=$P(LNKDAT,"^",4)
"RTN","EASUM6",69,0)
 ; set LNKMT off if either of two scenarios below
"RTN","EASUM6",70,0)
 I LNKMT D
"RTN","EASUM6",71,0)
 . I $E(LNKDTE,1,3)'=$E(DGMTDT,1,3) S LNKMT="@" Q
"RTN","EASUM6",72,0)
 . I DGMTDT<2991001 S LNKMT="" Q
"RTN","EASUM6",73,0)
 S:LNKMT'="" DR=DR_";2.06////^S X=LNKMT"
"RTN","EASUM6",74,0)
 ;
"RTN","EASUM6",75,0)
 D ^DIE K DA,DIE,DR                            ;update new 408.31 test
"RTN","EASUM6",76,0)
 ;
"RTN","EASUM6",77,0)
 ; Update other 408.31 related Test, Link field, if link scenario true
"RTN","EASUM6",78,0)
 I LNKMT S DA=LNKMT,DIE="^DGMT(408.31,",DR="2.06////^S X=CURIEN" D ^DIE K DA,DIE,DR
"RTN","EASUM6",79,0)
 ;
"RTN","EASUM6",80,0)
 ;Variables needed for Bulletins
"RTN","EASUM6",81,0)
 ;
"RTN","EASUM6",82,0)
 S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1)
"RTN","EASUM6",83,0)
 I '$D(IVM5) S IVM5=""
"RTN","EASUM6",84,0)
 ;
"RTN","EASUM6",85,0)
 D GETREL^DGMTU11(DFN,"V",DGLY,IVMMTIEN)
"RTN","EASUM6",86,0)
 I EASZ06 S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0)) ;dgmtp is event driver variable
"RTN","EASUM6",87,0)
 D COMPLETE
"RTN","EASUM6",88,0)
 Q
"RTN","EASUM6",89,0)
 ;
"RTN","EASUM6",90,0)
 ; add dependent(s) to income person file (408.13)
"RTN","EASUM6",91,0)
 ;
"RTN","EASUM6",92,0)
 ; add spouse if not in 408.13
"RTN","EASUM6",93,0)
 S IVMSPCHV="S" ; spouse/child/vet indicator
"RTN","EASUM6",94,0)
 S IVMDA1=IVMDAP+3 D GET ; spouse ZDP segment
"RTN","EASUM6",95,0)
 D INPIEN^IVMUM2
"RTN","EASUM6",96,0)
 Q:$D(IVMFERR)
"RTN","EASUM6",97,0)
 ;
"RTN","EASUM6",98,0)
 I IVMFLG5 G ADDCHILD ; entry not added - goto add children
"RTN","EASUM6",99,0)
 ;
"RTN","EASUM6",100,0)
 ; add entry to patient relation file (408.12)
"RTN","EASUM6",101,0)
 D EN^IVMUM3
"RTN","EASUM6",102,0)
 ;
"RTN","EASUM6",103,0)
 Q:$D(IVMFERR)
"RTN","EASUM6",104,0)
 ;
"RTN","EASUM6",105,0)
ADDS21 ; add spouse entry to individual annual income file (408.21)
"RTN","EASUM6",106,0)
 S IVMDA1=IVMDAP+4 D GET ; spouse ZIC segment
"RTN","EASUM6",107,0)
 D EN^IVMUM4
"RTN","EASUM6",108,0)
 Q:$D(IVMFERR)
"RTN","EASUM6",109,0)
 ;
"RTN","EASUM6",110,0)
 ; add spouse entry to income relation file (408.22)
"RTN","EASUM6",111,0)
 S IVMDA1=IVMDAP+5 D GET ; spouse ZIR segment
"RTN","EASUM6",112,0)
 ;D EN^IVMUM5
"RTN","EASUM6",113,0)
 D EN^EASUM5  ;EAS*1*113
"RTN","EASUM6",114,0)
 Q:$D(IVMFERR)
"RTN","EASUM6",115,0)
 ;
"RTN","EASUM6",116,0)
ADDCHILD ; add children if not in 408.13
"RTN","EASUM6",117,0)
 S IVMSPCHV="C" ; spouse/child/vet indicator
"RTN","EASUM6",118,0)
 I 'IVMFLGC G ADDV21 ; no dependent children 
"RTN","EASUM6",119,0)
 S IVMCTR2=5
"RTN","EASUM6",120,0)
 F IVMCTR3=1:1:IVMFLGC D  Q:$D(IVMFERR)
"RTN","EASUM6",121,0)
 .S IVMCTR2=IVMCTR2+1
"RTN","EASUM6",122,0)
 .S IVMDA1=IVMDAP+IVMCTR2 D GET ; child ZDP segment
"RTN","EASUM6",123,0)
 .D INPIEN^IVMUM2
"RTN","EASUM6",124,0)
 .Q:$D(IVMFERR)
"RTN","EASUM6",125,0)
 .;
"RTN","EASUM6",126,0)
 .; add child entry to patient relation file (408.12)
"RTN","EASUM6",127,0)
 .D EN^IVMUM3
"RTN","EASUM6",128,0)
 .Q:$D(IVMFERR)
"RTN","EASUM6",129,0)
 .;
"RTN","EASUM6",130,0)
ADDC21 .; add child entry to individual annual income file (408.21)
"RTN","EASUM6",131,0)
 .S IVMCTR2=IVMCTR2+1
"RTN","EASUM6",132,0)
 .S IVMDA1=IVMDAP+IVMCTR2 D GET ; child ZIC segment
"RTN","EASUM6",133,0)
 .D EN^IVMUM4
"RTN","EASUM6",134,0)
 .Q:$D(IVMFERR)
"RTN","EASUM6",135,0)
 .;
"RTN","EASUM6",136,0)
 .; add entry to income relation file (408.22)
"RTN","EASUM6",137,0)
 .S IVMCTR2=IVMCTR2+1
"RTN","EASUM6",138,0)
 .S IVMDA1=IVMDAP+IVMCTR2 D GET ; child ZIR segment
"RTN","EASUM6",139,0)
 .;D EN^IVMUM5
"RTN","EASUM6",140,0)
 .D EN^EASUM5   ;EAS*1*113
"RTN","EASUM6",141,0)
 .Q:$D(IVMFERR)
"RTN","EASUM6",142,0)
 .Q
"RTN","EASUM6",143,0)
 Q:$D(IVMFERR)
"RTN","EASUM6",144,0)
 ;
"RTN","EASUM6",145,0)
ADDV21 ; add vet entry to individual annual income file (408.21)
"RTN","EASUM6",146,0)
 ; get vet patient relation ien
"RTN","EASUM6",147,0)
 S DGPRI=+$G(DGREL("V"))
"RTN","EASUM6",148,0)
 S IVMDA1=IVMDAP+1 D GET ; vet ZIC segment
"RTN","EASUM6",149,0)
 S IVMSPCHV="V" ; spouse/child/vet indicator
"RTN","EASUM6",150,0)
 D EN^IVMUM4
"RTN","EASUM6",151,0)
 Q:$D(IVMFERR)
"RTN","EASUM6",152,0)
 S DGVINI=DGINI ; vet individual annual income ien
"RTN","EASUM6",153,0)
 ;
"RTN","EASUM6",154,0)
 ; add vet entry to income relation file (408.22)
"RTN","EASUM6",155,0)
 S IVMDA1=IVMDAP+2 D GET ; vet ZIR segment
"RTN","EASUM6",156,0)
 ;D EN^IVMUM5
"RTN","EASUM6",157,0)
 D EN^EASUM5  ;EAS*1*113
"RTN","EASUM6",158,0)
 Q:$D(IVMFERR)
"RTN","EASUM6",159,0)
 S DGVIRI=DGIRI ; vet income relation ien
"RTN","EASUM6",160,0)
 ;
"RTN","EASUM6",161,0)
COMPLETE ; complete means test
"RTN","EASUM6",162,0)
 ;
"RTN","EASUM6",163,0)
 ;D EN^IVMUM6
"RTN","EASUM6",164,0)
 ;Call Means Test Event Driver to complete processing
"RTN","EASUM6",165,0)
 ;
"RTN","EASUM6",166,0)
 S DGMTACT="UPL"
"RTN","EASUM6",167,0)
 D AFTER^DGMTEVT
"RTN","EASUM6",168,0)
 S DGMTINF=1 ;Non-Interactive Flag
"RTN","EASUM6",169,0)
 D EN^DGMTEVT
"RTN","EASUM6",170,0)
 D MTBULL^EASUM7,MAIL^IVMUFNC() ;Build Mail Message
"RTN","EASUM6",171,0)
 ;
"RTN","EASUM6",172,0)
 ; cleanup ;EAS*1*42 remove Dgmtypt
"RTN","EASUM6",173,0)
 K DGINI,DGIRI,DGLY,DGMTDT,DGPRI,DGREL,DGVINI,DGVIRI,DGENUPLD
"RTN","EASUM6",174,0)
 K DGCAT,IVMAR,IVMCEB,IVMCTR2,IVMCTR3,IVMDA1,IVMDAP,IVMFERR
"RTN","EASUM6",175,0)
 K IVMFLG2,IVMFLG5,IVMFLGC,IVMMTB,IVMPRN
"RTN","EASUM6",176,0)
 K IVMRELN,IVMRELO,IVMSEG,IVMSPCHV,IVMX
"RTN","EASUM6",177,0)
 Q
"RTN","EASUM6",178,0)
 ; 
"RTN","EASUM6",179,0)
GET ; get HL7 segment from ^HL
"RTN","EASUM6",180,0)
 S IVMSEG=$P($G(^TMP($J,IVMRTN,IVMDA1,0)),"^",2,999)
"RTN","EASUM6",181,0)
 Q
"VER")
8.0^22.0
**INSTALL NAME**
IVM*2.0*160
"BLD",9604,0)
IVM*2.0*160^INCOME VERIFICATION MATCH^0^3150424^y
"BLD",9604,1,0)
^^17^17^3150312^
"BLD",9604,1,1,0)
  The Health Eligibility Center (HEC) requested modifications to the 
"BLD",9604,1,2,0)
  Enrollment System Redesign (ESR) and VistA Registration, Enrollment 
"BLD",9604,1,3,0)
  and Eligibility (Vista REE) software to support the requirements of   
"BLD",9604,1,4,0)
  the Veterans Financial Assessment (VFA) projects.
"BLD",9604,1,5,0)
 
"BLD",9604,1,6,0)
  This patch modifies the Enrollment Application System V2.0 application
"BLD",9604,1,7,0)
  as described below:
"BLD",9604,1,8,0)
 
"BLD",9604,1,9,0)
   HL7 Changes
"BLD",9604,1,10,0)
  ----------------------------------------------------------
"BLD",9604,1,11,0)
  This patch supports HL7 enhancements that sends Contributed To 
"BLD",9604,1,12,0)
  Spouse and Contributed to Child Z10 ZIR-15 and stores them in the      
"BLD",9604,1,13,0)
  database. Patch DG*5.3*890 will be released in conjunction with
"BLD",9604,1,14,0)
  this EAS patch.
"BLD",9604,1,15,0)
 
"BLD",9604,1,16,0)
  This patch also adds the Beneficiary Travel Financial Indicator (BTFI) 
"BLD",9604,1,17,0)
  to the Z07 ZMT-31 to send the BTFI back to the Enrollment System.
"BLD",9604,4,0)
^9.64PA^^
"BLD",9604,6.3)
19
"BLD",9604,"ABPKG")
n
"BLD",9604,"KRN",0)
^9.67PA^779.2^20
"BLD",9604,"KRN",.4,0)
.4
"BLD",9604,"KRN",.401,0)
.401
"BLD",9604,"KRN",.402,0)
.402
"BLD",9604,"KRN",.403,0)
.403
"BLD",9604,"KRN",.5,0)
.5
"BLD",9604,"KRN",.84,0)
.84
"BLD",9604,"KRN",3.6,0)
3.6
"BLD",9604,"KRN",3.8,0)
3.8
"BLD",9604,"KRN",9.2,0)
9.2
"BLD",9604,"KRN",9.8,0)
9.8
"BLD",9604,"KRN",9.8,"NM",0)
^9.68A^6^5
"BLD",9604,"KRN",9.8,"NM",2,0)
IVMPTRN8^^0^B77554356
"BLD",9604,"KRN",9.8,"NM",3,0)
IVMCM5^^0^B20605798
"BLD",9604,"KRN",9.8,"NM",4,0)
IVMCMF1^^0^B12600805
"BLD",9604,"KRN",9.8,"NM",5,0)
IVMPTRN9^^0^B53734874
"BLD",9604,"KRN",9.8,"NM",6,0)
IVMCZMT^^0^B60732106
"BLD",9604,"KRN",9.8,"NM","B","IVMCM5",3)

"BLD",9604,"KRN",9.8,"NM","B","IVMCMF1",4)

"BLD",9604,"KRN",9.8,"NM","B","IVMCZMT",6)

"BLD",9604,"KRN",9.8,"NM","B","IVMPTRN8",2)

"BLD",9604,"KRN",9.8,"NM","B","IVMPTRN9",5)

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

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

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

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

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

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

"BLD",9604,"KRN","B",3.6,3.6)

"BLD",9604,"KRN","B",3.8,3.8)

"BLD",9604,"KRN","B",9.2,9.2)

"BLD",9604,"KRN","B",9.8,9.8)

"BLD",9604,"KRN","B",19,19)

"BLD",9604,"KRN","B",19.1,19.1)

"BLD",9604,"KRN","B",101,101)

"BLD",9604,"KRN","B",409.61,409.61)

"BLD",9604,"KRN","B",771,771)

"BLD",9604,"KRN","B",779.2,779.2)

"BLD",9604,"KRN","B",870,870)

"BLD",9604,"KRN","B",8989.51,8989.51)

"BLD",9604,"KRN","B",8989.52,8989.52)

"BLD",9604,"KRN","B",8994,8994)

"BLD",9604,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9604,"QUES",0)
^9.62^^
"BLD",9604,"REQB",0)
^9.611^4^4
"BLD",9604,"REQB",1,0)
DG*5.3*890^2
"BLD",9604,"REQB",2,0)
EAS*1.0*113^2
"BLD",9604,"REQB",3,0)
IVM*2.0*150^2
"BLD",9604,"REQB",4,0)
IVM*2.0*152^2
"BLD",9604,"REQB","B","DG*5.3*890",1)

"BLD",9604,"REQB","B","EAS*1.0*113",2)

"BLD",9604,"REQB","B","IVM*2.0*150",3)

"BLD",9604,"REQB","B","IVM*2.0*152",4)

"MBREQ")
0
"PKG",120,-1)
1^1
"PKG",120,0)
INCOME VERIFICATION MATCH^IVM^IVM Software for interface with the IVM Center
"PKG",120,20,0)
^9.402P^^
"PKG",120,22,0)
^9.49I^1^1
"PKG",120,22,1,0)
2.0^2941021^2960823
"PKG",120,22,1,"PAH",1,0)
160^3150424
"PKG",120,22,1,"PAH",1,1,0)
^^17^17^3150424
"PKG",120,22,1,"PAH",1,1,1,0)
  The Health Eligibility Center (HEC) requested modifications to the 
"PKG",120,22,1,"PAH",1,1,2,0)
  Enrollment System Redesign (ESR) and VistA Registration, Enrollment 
"PKG",120,22,1,"PAH",1,1,3,0)
  and Eligibility (Vista REE) software to support the requirements of   
"PKG",120,22,1,"PAH",1,1,4,0)
  the Veterans Financial Assessment (VFA) projects.
"PKG",120,22,1,"PAH",1,1,5,0)
 
"PKG",120,22,1,"PAH",1,1,6,0)
  This patch modifies the Enrollment Application System V2.0 application
"PKG",120,22,1,"PAH",1,1,7,0)
  as described below:
"PKG",120,22,1,"PAH",1,1,8,0)
 
"PKG",120,22,1,"PAH",1,1,9,0)
   HL7 Changes
"PKG",120,22,1,"PAH",1,1,10,0)
  ----------------------------------------------------------
"PKG",120,22,1,"PAH",1,1,11,0)
  This patch supports HL7 enhancements that sends Contributed To 
"PKG",120,22,1,"PAH",1,1,12,0)
  Spouse and Contributed to Child Z10 ZIR-15 and stores them in the      
"PKG",120,22,1,"PAH",1,1,13,0)
  database. Patch DG*5.3*890 will be released in conjunction with
"PKG",120,22,1,"PAH",1,1,14,0)
  this EAS patch.
"PKG",120,22,1,"PAH",1,1,15,0)
 
"PKG",120,22,1,"PAH",1,1,16,0)
  This patch also adds the Beneficiary Travel Financial Indicator (BTFI) 
"PKG",120,22,1,"PAH",1,1,17,0)
  to the Z07 ZMT-31 to send the BTFI back to the Enrollment System.
"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")
5
"RTN","IVMCM5")
0^3^B20605798
"RTN","IVMCM5",1,0)
IVMCM5 ;ALB/SEK,BRM,CKN,PWC - ADD NEW DCD INCOME RELATION FILE ENTRIES ;2/8/06 2:01pm
"RTN","IVMCM5",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**17,49,105,160**;21-OCT-94;Build 19
"RTN","IVMCM5",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IVMCM5",4,0)
 ;
"RTN","IVMCM5",5,0)
EN ; this routine will add entries to INCOME RELATION file (408.22).
"RTN","IVMCM5",6,0)
 ; will inactivate dependents (spouse & children) who are not
"RTN","IVMCM5",7,0)
 ; dependents of the test being uploaded, by adding an inactivate
"RTN","IVMCM5",8,0)
 ; entry into the EFFECTIVE DATE sub-file (multiple-408.1275) of
"RTN","IVMCM5",9,0)
 ; the PATIENT RELATION file (#408.12).
"RTN","IVMCM5",10,0)
 ;
"RTN","IVMCM5",11,0)
 ; exceptions to above:
"RTN","IVMCM5",12,0)
 ;   . income screening:
"RTN","IVMCM5",13,0)
 ;       . "mt" node not set to annual means test ien
"RTN","IVMCM5",14,0)
 ;       . no replaced test to change primary test for income year
"RTN","IVMCM5",15,0)
 ;         field to 0
"RTN","IVMCM5",16,0)
 ;
"RTN","IVMCM5",17,0)
 ;
"RTN","IVMCM5",18,0)
 ; DFN    Patient file IEN
"RTN","IVMCM5",19,0)
 ; DGINI  Individual Annual Income IEN
"RTN","IVMCM5",20,0)
 ; DGIRI  Income Relation IEN
"RTN","IVMCM5",21,0)
 ; IVMSEG ZIR record for veteran or spouse or dependent
"RTN","IVMCM5",22,0)
 ; IVM0   408.22 0 node pieces 5-7
"RTN","IVMCM5",23,0)
 ; IVM01         0 node pieces 9-12
"RTN","IVMCM5",24,0)
 ; IVM02         0 node piece  6
"RTN","IVMCM5",25,0)
 ; IVM03         0 node piece  18
"RTN","IVMCM5",26,0)
 ;
"RTN","IVMCM5",27,0)
 N IVM0,IVM01,IVM02,IVM03,IVM04
"RTN","IVMCM5",28,0)
 S DGIRI=$$ADDIR^DGMTU2(DFN,DGINI)
"RTN","IVMCM5",29,0)
 ;
"RTN","IVMCM5",30,0)
 ; if can't create stub notify site & IVM Center
"RTN","IVMCM5",31,0)
 I DGIRI'>0 D  Q
"RTN","IVMCM5",32,0)
 .S (IVMTEXT(6))="Can't create stub for file 408.22"
"RTN","IVMCM5",33,0)
 .D PROB^IVMCMC(IVMTEXT(6))
"RTN","IVMCM5",34,0)
 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
"RTN","IVMCM5",35,0)
 .S IVMFERR=""
"RTN","IVMCM5",36,0)
 ;
"RTN","IVMCM5",37,0)
 ; set "mt" node to annual means test ien
"RTN","IVMCM5",38,0)
 I "^1^2^4^"[("^"_IVMTYPE_"^") D MT^DGMTSCU3(DGIRI,DGMTI)
"RTN","IVMCM5",39,0)
 ;
"RTN","IVMCM5",40,0)
 Q:IVMSPCHV="S"
"RTN","IVMCM5",41,0)
 ;
"RTN","IVMCM5",42,0)
 ; set number of dependent children (#.13) and dependent children(#.08)
"RTN","IVMCM5",43,0)
 ; in income relation file (#408.22) based on active child dependents
"RTN","IVMCM5",44,0)
 ; in patient relation file (#408.12).
"RTN","IVMCM5",45,0)
 ; make DCD means test or copay test primary income test for year
"RTN","IVMCM5",46,0)
 I IVMSPCHV="V" D  Q:$D(IVMFERR)
"RTN","IVMCM5",47,0)
 .;
"RTN","IVMCM5",48,0)
 .; inactivate dependents who are not dependents of the test
"RTN","IVMCM5",49,0)
 .; being uploaded.
"RTN","IVMCM5",50,0)
 .K DGREL("V")
"RTN","IVMCM5",51,0)
 .I $D(DGREL) D INACTIVE Q:$D(IVMFERR)
"RTN","IVMCM5",52,0)
 .;
"RTN","IVMCM5",53,0)
 .D RESET^DGMTU11(DFN,DGLY,$S($G(DGMTI):DGMTI,1:0))
"RTN","IVMCM5",54,0)
 .I $P($G(^DGMT(408.22,DGIRI,0)),"^",8)="" D
"RTN","IVMCM5",55,0)
 ..S DA=DGIRI,DR=".08////0;.13////@",DIE="^DGMT(408.22," D ^DIE
"RTN","IVMCM5",56,0)
 ..K DA,DR,DIE
"RTN","IVMCM5",57,0)
 .S IVM0=$P(IVMSEG,"^",2,4),IVM04=$P(IVMSEG,"^",15) ;Begin IVM*2.0*160 Added contrib to spouse for VET record
"RTN","IVMCM5",58,0)
 I IVMSPCHV="C" S IVM01=$P(IVMSEG,"^",6,9),IVM02=$P(IVMSEG,"^",3),IVM03=$$CONVERT($P(IVMSEG,"^",14),"1/0")
"RTN","IVMCM5",59,0)
 S DIK="^DGMT(408.22,"
"RTN","IVMCM5",60,0)
 I IVMSPCHV="C" L +^DGMT(408.22,DGIRI):5 S $P(^DGMT(408.22,DGIRI,0),"^",9,12)=IVM01,$P(^(0),"^",6)=IVM02,$P(^(0),"^",18)=IVM03 S DA=DGIRI D IX1^DIK L -^DGMT(408.22,DGIRI)
"RTN","IVMCM5",61,0)
 I IVMSPCHV="V" L +^DGMT(408.22,DGIRI):5 S $P(^DGMT(408.22,DGIRI,0),"^",5,7)=IVM0,$P(^(0),"^",20)=IVM04 S DA=DGIRI D IX1^DIK L -^DGMT(408.22,DGIRI)
"RTN","IVMCM5",62,0)
 ;End IVM*2.0*160 changes
"RTN","IVMCM5",63,0)
 K DA,DIK
"RTN","IVMCM5",64,0)
 Q
"RTN","IVMCM5",65,0)
 ;
"RTN","IVMCM5",66,0)
INACTIVE ; inactivate dependents not in DCD means test or copay test and
"RTN","IVMCM5",67,0)
 ; kill corresponding dgrel
"RTN","IVMCM5",68,0)
 N X,Y
"RTN","IVMCM5",69,0)
 I $D(DGREL("S")) S DA(1)=+DGREL("S") D  K DGREL("S")
"RTN","IVMCM5",70,0)
 .D CHKINACT
"RTN","IVMCM5",71,0)
 .Q:IVMFLG6!($D(IVMFERR))
"RTN","IVMCM5",72,0)
 .; if spouse was active before income year, add record with date
"RTN","IVMCM5",73,0)
 .; of 12/31 of year before income year with active code 0
"RTN","IVMCM5",74,0)
 .S X=$E(DGLY,1,3)-1_1231
"RTN","IVMCM5",75,0)
 .D INACT1
"RTN","IVMCM5",76,0)
 Q:'$D(DGREL)!($D(IVMFERR))
"RTN","IVMCM5",77,0)
 S IVMACTR=0
"RTN","IVMCM5",78,0)
 F  S IVMACTR=$O(DGREL("C",IVMACTR)) Q:'IVMACTR  S DA(1)=+DGREL("C",IVMACTR) D  K DGREL("C",IVMACTR)
"RTN","IVMCM5",79,0)
 .D CHKINACT
"RTN","IVMCM5",80,0)
 .Q:IVMFLG6!($D(IVMFERR))
"RTN","IVMCM5",81,0)
 .; if child was active before income year, add record with date
"RTN","IVMCM5",82,0)
 .; of 12/31 of year before income year with active code 0
"RTN","IVMCM5",83,0)
 .S X=$E(DGLY,1,3)-1_1231
"RTN","IVMCM5",84,0)
 .D INACT1
"RTN","IVMCM5",85,0)
 ;
"RTN","IVMCM5",86,0)
 K IVMACTR,IVMDGLY,IVMFLG6,IVMYEAR
"RTN","IVMCM5",87,0)
 Q
"RTN","IVMCM5",88,0)
 ;
"RTN","IVMCM5",89,0)
CHKINACT ; if dependent was made active during income year
"RTN","IVMCM5",90,0)
 ; add record for same date (add .08 time) with active code 0
"RTN","IVMCM5",91,0)
 ;
"RTN","IVMCM5",92,0)
 S IVMFLG6=0
"RTN","IVMCM5",93,0)
 S IVMDGLY="" F  S IVMDGLY=$O(^DGPR(408.12,DA(1),"E","B",IVMDGLY)) Q:IVMDGLY']""  D  Q:IVMFLG6!($D(IVMFERR))
"RTN","IVMCM5",94,0)
 .Q:$E(IVMDGLY,1,3)'=$E(DGLY,1,3)
"RTN","IVMCM5",95,0)
 .S IVMYEAR=0 F  S IVMYEAR=$O(^DGPR(408.12,DA(1),"E","B",IVMDGLY,IVMYEAR)) Q:IVMYEAR']""  D  Q:IVMFLG6!($D(IVMFERR))
"RTN","IVMCM5",96,0)
 ..I $P($G(^DGPR(408.12,DA(1),"E",IVMYEAR,0)),"^",2) D
"RTN","IVMCM5",97,0)
 ...S X=IVMDGLY_.08 D INACT1 S IVMFLG6=1
"RTN","IVMCM5",98,0)
 ...Q
"RTN","IVMCM5",99,0)
 Q
"RTN","IVMCM5",100,0)
 ;
"RTN","IVMCM5",101,0)
INACT1 ; add inactivate entry to 408.1275
"RTN","IVMCM5",102,0)
 ;
"RTN","IVMCM5",103,0)
 K DINUM
"RTN","IVMCM5",104,0)
 S (DIK,DIC)="^DGPR(408.12,DA(1),""E"",",DIC(0)="L",DLAYGO=408.1275 K DD,DO D FILE^DICN S DA=+Y K DLAYGO
"RTN","IVMCM5",105,0)
 ;
"RTN","IVMCM5",106,0)
 ; if can't create stub notify site & IVM Center
"RTN","IVMCM5",107,0)
 I DA'>0 D  Q
"RTN","IVMCM5",108,0)
 .S (IVMTEXT(6))="Can't create stub for file 408.1275"
"RTN","IVMCM5",109,0)
 .D PROB^IVMCMC(IVMTEXT(6))
"RTN","IVMCM5",110,0)
 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
"RTN","IVMCM5",111,0)
 .S IVMFERR=""
"RTN","IVMCM5",112,0)
 L +^DGPR(408.12,+DGPRI):5 S $P(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=0_"^"_1_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI)
"RTN","IVMCM5",113,0)
 K DA,DIC,DIK
"RTN","IVMCM5",114,0)
 Q
"RTN","IVMCM5",115,0)
CONVERT(VAL,DATATYPE) ;Data Conversion
"RTN","IVMCM5",116,0)
 ; Description: Converts the value found in the HL7 segment to DHCP format
"RTN","IVMCM5",117,0)
 ;Input:
"RTN","IVMCM5",118,0)
 ;        VAL - value parsed from HL7 segment
"RTN","IVMCM5",119,0)
 ;   DATATYPE - indicates the type of conversion necessary
"RTN","IVMCM5",120,0)
 ;              "1/0" - "Y"->1,"N"->0
"RTN","IVMCM5",121,0)
 ;Currently only one type needs to be converted but new data types can
"RTN","IVMCM5",122,0)
 ;be added for other conversion
"RTN","IVMCM5",123,0)
 I VAL="" Q VAL
"RTN","IVMCM5",124,0)
 I VAL="""""" S VAL="@" Q VAL
"RTN","IVMCM5",125,0)
 I ($G(DATATYPE)="1/0") D
"RTN","IVMCM5",126,0)
 .I VAL="N" S VAL=0 Q
"RTN","IVMCM5",127,0)
 .I VAL="Y" S VAL=1 Q
"RTN","IVMCM5",128,0)
 .S VAL=""
"RTN","IVMCM5",129,0)
 Q VAL
"RTN","IVMCMF1")
0^4^B12600805
"RTN","IVMCMF1",1,0)
IVMCMF1 ;ALB/RMM,CKN,PWC - CHECK ANNUAL INCOME DATA ;11/8/05 3:27pm
"RTN","IVMCMF1",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**71,82,107,105,160**;21-OCT-94;Build 19
"RTN","IVMCMF1",3,0)
 ;
"RTN","IVMCMF1",4,0)
 ; This routine is called from IVMCMF.
"RTN","IVMCMF1",5,0)
 ;
"RTN","IVMCMF1",6,0)
 ;
"RTN","IVMCMF1",7,0)
ZIC(STRING,DEPIEN) ; Check validity of ZIC segment
"RTN","IVMCMF1",8,0)
 ;
"RTN","IVMCMF1",9,0)
 ; Input:  STRING as ZIC segment
"RTN","IVMCMF1",10,0)
 ;         DEPIEN as the IEN of the dependent in the array, if applicable
"RTN","IVMCMF1",11,0)
 ;
"RTN","IVMCMF1",12,0)
 N X S X=$P(STRING,HLFS,2)
"RTN","IVMCMF1",13,0)
 I $G(DEPIEN) I DEPIEN'=SPOUSE D
"RTN","IVMCMF1",14,0)
 .I $P(STRING,HLFS,15)>0 S X=$P(^DG(43,1,"MT",(X-17000000),0),U,17) I X'<$P(STRING,HLFS,9) S CNT=CNT+1,IVMERR(CNT)="Income does not exceed child exclusion amount-educational expense not allowed"
"RTN","IVMCMF1",15,0)
ZICQ Q
"RTN","IVMCMF1",16,0)
 ;
"RTN","IVMCMF1",17,0)
ZIR(STRING,DEPIEN) ; Check validity of ZIR segment
"RTN","IVMCMF1",18,0)
 ;
"RTN","IVMCMF1",19,0)
 ; Input:  STRING as ZIR segment
"RTN","IVMCMF1",20,0)
 ;         DEPIEN as the IEN of the dependent in the array, if applicable
"RTN","IVMCMF1",21,0)
 ;
"RTN","IVMCMF1",22,0)
 N I,FND1,X
"RTN","IVMCMF1",23,0)
 S X=$P(STRING,HLFS,14)
"RTN","IVMCMF1",24,0)
 I X]"",(X'="Y"),(X'="N") S CNT=CNT+1,FND1=1,IVMERR(CNT)="DEPENDENT CHILD SCHOOL INDICATOR contains unacceptable value."
"RTN","IVMCMF1",25,0)
 I '$G(DEPIEN) D
"RTN","IVMCMF1",26,0)
 .I X]"" S CNT=CNT+1,FND1=1,IVMERR(CNT)="DEPENDENT CHILD SCHOOL INDICATOR should not be filled in for Veteran."
"RTN","IVMCMF1",27,0)
 .;IVM*2.0*160
"RTN","IVMCMF1",28,0)
 .; for historical data that has Married Last Year = Y, Lived With Spouse = N, SPOUSE has data, Amount Contributed with value
"RTN","IVMCMF1",29,0)
 .I $P(STRING,U,15)="",$P(STRING,HLFS,2),'$P(STRING,HLFS,3),SPOUSE,($P(STRING,HLFS,4)<600) D  Q  ;don't go further since amount contributed had value - IVM*2*160
"RTN","IVMCMF1",30,0)
 ..S FND1=0 F I=3:1:20 Q:FND1  I $P(ARRAY(SPOUSE,"ZIC"),HLFS,I) S FND1=1,CNT=CNT+1,IVMERR(CNT)="No income data allowed if spouse didn't live w/vet & amt contributed <$600"
"RTN","IVMCMF1",31,0)
 .; Married Last Year = Y, Lived with Spouse = N, SPOUSE has data, Contributed to Spouse = N
"RTN","IVMCMF1",32,0)
 .I $P(STRING,HLFS,2),'$P(STRING,HLFS,3),SPOUSE,($P(STRING,U,15)=0) S FND1=0 F I=3:1:20 Q:FND1  D
"RTN","IVMCMF1",33,0)
 ..I $P(ARRAY(SPOUSE,"ZIC"),HLFS,I) S FND1=1,CNT=CNT+1,IVMERR(CNT)="No income data allowed if spouse didn't live w/vet & vet did not contribute to spousal support"
"RTN","IVMCMF1",34,0)
 I $G(DEPIEN)=SPOUSE D
"RTN","IVMCMF1",35,0)
 . I X]"" S CNT=CNT+1,FND1=1,IVMERR(CNT)="DEPENDENT CHILD SCHOOL INDICATOR should not be filled in for spouse ZIR."
"RTN","IVMCMF1",36,0)
 I $G(DEPIEN),(DEPIEN'=SPOUSE) D
"RTN","IVMCMF1",37,0)
 .I '$P(STRING,HLFS,8) S FND1=0 F I=3:1:20 Q:FND1  I $P(ARRAY(DEPIEN,"ZIC"),HLFS,I) S CNT=CNT+1,IVMERR(CNT)="Shouldn't have income data if Child Had Income is NO",FND1=1
"RTN","IVMCMF1",38,0)
ZIRQ Q
"RTN","IVMCZMT")
0^6^B60732106
"RTN","IVMCZMT",1,0)
IVMCZMT ;ALB/MLI/LD/CKN,TDM,EG,TDM,TGH - Creation of  HL7 ZMT (means test) segment ; 7/19/06 4:41pm
"RTN","IVMCZMT",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**17,53,49,58,81,89,104,105,160**;21-OCT-94;Build 19
"RTN","IVMCZMT",3,0)
 ;
"RTN","IVMCZMT",4,0)
 ; This routine returns the ZMT segment which contains means test
"RTN","IVMCZMT",5,0)
 ; data for a selected patient. It differs from the standard segment
"RTN","IVMCZMT",6,0)
 ; builder in that it will add default values where needed for
"RTN","IVMCZMT",7,0)
 ; fields added by means test sharing - these fields may not have
"RTN","IVMCZMT",8,0)
 ; values for old tests, though for new tests the values should be there.
"RTN","IVMCZMT",9,0)
 ;
"RTN","IVMCZMT",10,0)
 ;
"RTN","IVMCZMT",11,0)
 ;
"RTN","IVMCZMT",12,0)
EN(DFN,VAFSTR,VAFMTDT,VAFTYPE,SETID,DELETE,LIMIT)       ; Entry point to get ZMT segment
"RTN","IVMCZMT",13,0)
 ;
"RTN","IVMCZMT",14,0)
 ;  Input:
"RTN","IVMCZMT",15,0)
 ;      DFN - as the IEN or corresponding patient in the PATIENT file
"RTN","IVMCZMT",16,0)
 ;   VAFSTR - as string of segment fields needed separated by commas
"RTN","IVMCZMT",17,0)
 ;  VAFMTDT - (optional) as date of desired means test (defaults to latest MT)
"RTN","IVMCZMT",18,0)
 ;  VAFTYPE - (optional) as type of test:  1 - Means Test (default=1)
"RTN","IVMCZMT",19,0)
 ;      2 - Copay Test
"RTN","IVMCZMT",20,0)
 ;      4 - LTC Copay Exemption Test
"RTN","IVMCZMT",21,0)
 ;  SETID -  (optional) value to use for SEQ 1, the set id field (1 used
"RTN","IVMCZMT",22,0)
 ;     as default if not passed.)
"RTN","IVMCZMT",23,0)
 ;  DELETE - (optional, pass by reference) This array is used to
"RTN","IVMCZMT",24,0)
 ;    indicate whether the segment is being used to notify of the
"RTN","IVMCZMT",25,0)
 ;    the deletion of a means test, pharmacy copay test, or a
"RTN","IVMCZMT",26,0)
 ;    hardship determinatin.  If a means test or hardship is being
"RTN","IVMCZMT",27,0)
 ;    deleted, then VAFTYPE must equal 1.  If an Rx copay test is
"RTN","IVMCZMT",28,0)
 ;    being deleted, then VAFTYPE must equal 2.  The subscripts
"RTN","IVMCZMT",29,0)
 ;    are as follows:
"RTN","IVMCZMT",30,0)
 ;    DELETE("DATE OF TEST")=<date of test> - indicates
"RTN","IVMCZMT",31,0)
 ;    the income year of the test that the deletion flags
"RTN","IVMCZMT",32,0)
 ;    refer to
"RTN","IVMCZMT",33,0)
 ;    DELETE("HARDSHIP") -  if $G(DELETE("HARDSHIP"))=1 then the
"RTN","IVMCZMT",34,0)
 ;    segment will be created to delete the hardship.
"RTN","IVMCZMT",35,0)
 ;    DELETE("MT") - if $G(DELETE("MT"))=1 then
"RTN","IVMCZMT",36,0)
 ;    the segment will be created to delete a means test.
"RTN","IVMCZMT",37,0)
 ;    DELETE("RX")= if $G(DELETE("RX"))=1 then
"RTN","IVMCZMT",38,0)
 ;    the segment will be created to delete a pharmacy
"RTN","IVMCZMT",39,0)
 ;    copay test.
"RTN","IVMCZMT",40,0)
 ;    DELETE("LTC")= if $G(DELETE("LTC"))=1 then
"RTN","IVMCZMT",41,0)
 ;    the segment will be created to delete a Long term
"RTN","IVMCZMT",42,0)
 ;    care copay exemption test.
"RTN","IVMCZMT",43,0)
 ;  LIMIT - (optional) if $G(LIMIT)=1 then this indicates that a test in
"RTN","IVMCZMT",44,0)
 ;    an income year other than indicated in the IVM Patient File
"RTN","IVMCZMT",45,0)
 ;    should NOT be returned in the ZMT segment
"RTN","IVMCZMT",46,0)
 ;
"RTN","IVMCZMT",47,0)
 ;      ****Also assumes all HL7 variables are defined as returned ****
"RTN","IVMCZMT",48,0)
 ;   by the INIT^HLTRANS call
"RTN","IVMCZMT",49,0)
 ;
"RTN","IVMCZMT",50,0)
 ; Output - string in the form of the DHCP HL7 ZMT segment
"RTN","IVMCZMT",51,0)
 ;
"RTN","IVMCZMT",52,0)
 ;
"RTN","IVMCZMT",53,0)
 N NODE,PRIM,X,Y,VAFY,NODE2,MTIEN
"RTN","IVMCZMT",54,0)
 ;
"RTN","IVMCZMT",55,0)
 I '$G(DFN)!($G(VAFSTR)']"") G QUIT
"RTN","IVMCZMT",56,0)
 S $P(VAFY,HLFS,22)="",VAFSTR=","_VAFSTR_","
"RTN","IVMCZMT",57,0)
 S VAFTYPE=$S($G(VAFTYPE):VAFTYPE,1:1)
"RTN","IVMCZMT",58,0)
 S VAFMTDT=$S($G(VAFMTDT):VAFMTDT,1:DT)
"RTN","IVMCZMT",59,0)
 S $P(VAFY,HLFS,1)=$S($G(SETID):SETID,1:1)
"RTN","IVMCZMT",60,0)
 S (NODE,NODE2,PRIM)=""
"RTN","IVMCZMT",61,0)
 ;
"RTN","IVMCZMT",62,0)
 ;handle deletions of a test
"RTN","IVMCZMT",63,0)
 I ($G(DELETE("MT"))=1),VAFTYPE=1 D  G QUIT
"RTN","IVMCZMT",64,0)
 .S $P(VAFY,HLFS,2)=$$HLDATE^HLFNC(DELETE("DATE OF TEST")) ; MT Date
"RTN","IVMCZMT",65,0)
 .S $P(VAFY,HLFS,3)=HLQ
"RTN","IVMCZMT",66,0)
 .I ($G(DELETE("HARDSHIP"))=1) S $P(VAFY,HLFS,24)=HLQ
"RTN","IVMCZMT",67,0)
 .S $P(VAFY,HLFS,17)=VAFTYPE ; Type Of Test
"RTN","IVMCZMT",68,0)
 ;
"RTN","IVMCZMT",69,0)
 I ($G(DELETE("RX"))=1),VAFTYPE=2 D  G QUIT
"RTN","IVMCZMT",70,0)
 .S $P(VAFY,HLFS,2)=$$HLDATE^HLFNC(DELETE("DATE OF TEST")) ; MT Date
"RTN","IVMCZMT",71,0)
 .S $P(VAFY,HLFS,3)=HLQ
"RTN","IVMCZMT",72,0)
 .S $P(VAFY,HLFS,17)=VAFTYPE ; Type Of Test
"RTN","IVMCZMT",73,0)
 ;
"RTN","IVMCZMT",74,0)
 I ($G(DELETE("LTC"))=1),VAFTYPE=4 D  G QUIT
"RTN","IVMCZMT",75,0)
 .S $P(VAFY,HLFS,2)=$$HLDATE^HLFNC(DELETE("DATE OF TEST")) ; MT Date
"RTN","IVMCZMT",76,0)
 .S $P(VAFY,HLFS,3)=HLQ
"RTN","IVMCZMT",77,0)
 .S $P(VAFY,HLFS,17)=VAFTYPE ; Type Of Test
"RTN","IVMCZMT",78,0)
 ;
"RTN","IVMCZMT",79,0)
 ; Income Year requiring transmission from IVM Patient File (301.5)
"RTN","IVMCZMT",80,0)
 S IVMIY=$S($D(IVMIY):IVMIY,1:(VAFMTDT-10000))
"RTN","IVMCZMT",81,0)
 ;
"RTN","IVMCZMT",82,0)
 ; Check for a future dated Income Test
"RTN","IVMCZMT",83,0)
 S MTIEN=""
"RTN","IVMCZMT",84,0)
 N EC S EC=0
"RTN","IVMCZMT",85,0)
 I VAFTYPE'=4 D
"RTN","IVMCZMT",86,0)
 . S MTIEN=+$$FUT^DGMTU(DFN,"",$S($G(VAFTYPE):VAFTYPE,1:1))
"RTN","IVMCZMT",87,0)
 . I MTIEN D
"RTN","IVMCZMT",88,0)
 . . S NODE=$G(^DGMT(408.31,MTIEN,0)),PRIM=$G(^("PRIM")),NODE2=$G(^DGMT(408.31,MTIEN,2))
"RTN","IVMCZMT",89,0)
 . . ;the FUT API works off the a XREF that is not deleted if the test
"RTN","IVMCZMT",90,0)
 . . ;is no longer future.  As a result, you may pick up the wrong income
"RTN","IVMCZMT",91,0)
 . . ;year as a return.  The check $E(IVMIY,1,3)+1'=$E(+NODE,1,3) must be
"RTN","IVMCZMT",92,0)
 . . ;performed here and after the current Primary icnome test section below
"RTN","IVMCZMT",93,0)
 . . I ($G(LIMIT)=1),($E(IVMIY,1,3)+1)'=$E(+NODE,1,3) S EC=1
"RTN","IVMCZMT",94,0)
 . . Q
"RTN","IVMCZMT",95,0)
 . Q
"RTN","IVMCZMT",96,0)
 I VAFTYPE'=4,EC S (NODE,NODE2,MTIEN,PRIM)=""   ;Q "ZMT"_HLFS_$G(VAFY)
"RTN","IVMCZMT",97,0)
 ;
"RTN","IVMCZMT",98,0)
 ; Check for a current Primary Income Test
"RTN","IVMCZMT",99,0)
 I 'MTIEN S MTIEN=+$$LST^DGMTU(DFN,VAFMTDT,$S($G(VAFTYPE):VAFTYPE,1:1))
"RTN","IVMCZMT",100,0)
 S:(NODE="") NODE=$G(^DGMT(408.31,MTIEN,0)),PRIM=$G(^("PRIM")),NODE2=$G(^DGMT(408.31,MTIEN,2))
"RTN","IVMCZMT",101,0)
 ;
"RTN","IVMCZMT",102,0)
 ;if the wrong income yr, and told to ignore it ($G(LIMIT)=1,
"RTN","IVMCZMT",103,0)
 ;send blank means test
"RTN","IVMCZMT",104,0)
 I ($G(LIMIT)=1),($E(IVMIY,1,3)+1)'=$E(+NODE,1,3) S (NODE,NODE2,MTIEN,PRIM)="" Q "ZMT"_HLFS_$G(VAFY)
"RTN","IVMCZMT",105,0)
 ;
"RTN","IVMCZMT",106,0)
 ;
"RTN","IVMCZMT",107,0)
 I NODE'="" D
"RTN","IVMCZMT",108,0)
 .;add default values to new means test sharing fields
"RTN","IVMCZMT",109,0)
 .N STATUS,CODE,TDSTATUS,TDCODE,HARDSHIP,DATA,SOURCE,TIME
"RTN","IVMCZMT",110,0)
 .S TDSTATUS=$P(NODE2,"^",3)
"RTN","IVMCZMT",111,0)
 .S HARDSHIP=$P(NODE,"^",20)
"RTN","IVMCZMT",112,0)
 .I TDSTATUS="" D
"RTN","IVMCZMT",113,0)
 ..S STATUS=$P(NODE,"^",3)
"RTN","IVMCZMT",114,0)
 ..Q:'STATUS
"RTN","IVMCZMT",115,0)
 ..S CODE=$$GETCODE^DGMTH(STATUS)
"RTN","IVMCZMT",116,0)
 ..I CODE'="","ABCEGMP"[CODE D
"RTN","IVMCZMT",117,0)
 ...I VAFTYPE=1,HARDSHIP D
"RTN","IVMCZMT",118,0)
 ....I "AG"[CODE D  Q
"RTN","IVMCZMT",119,0)
 .....I CODE="A",($P(NODE,"^",4)'>$P(NODE,"^",27)) S TDSTATUS=$$GETSTAT^DGMTH("G",1) Q  ;Income <= GMT Threshold
"RTN","IVMCZMT",120,0)
 .....S TDSTATUS=$$GETSTAT^DGMTH("C",1)
"RTN","IVMCZMT",121,0)
 ....S TDSTATUS=STATUS
"RTN","IVMCZMT",122,0)
 ...S DATA(2.03)=TDSTATUS,$P(NODE2,"^",3)=TDSTATUS
"RTN","IVMCZMT",123,0)
 .S SOURCE=$P(NODE,"^",23)
"RTN","IVMCZMT",124,0)
 .I SOURCE=1 D
"RTN","IVMCZMT",125,0)
 ..S TIME=$P(NODE2,"^",2)
"RTN","IVMCZMT",126,0)
 ..I TIME="" S TIME=$$NOW^XLFDT,$P(NODE2,"^",2)=TIME,DATA(2.02)=TIME
"RTN","IVMCZMT",127,0)
 ..I $P(NODE2,"^",5)="",$P(NODE,"^",6) S $P(NODE2,"^",5)=$$GETSITE^DGMTU4($P(NODE,"^",6)),DATA(2.05)=$P(NODE2,"^",5)
"RTN","IVMCZMT",128,0)
 .I HARDSHIP,$P(NODE2,"^",4)="",$P(NODE,"^",22) S $P(NODE2,"^",4)=$$GETSITE^DGMTU4($P(NODE,"^",22)),DATA(2.04)=$P(NODE2,"^",4)
"RTN","IVMCZMT",129,0)
 .I $D(DATA),$$UPD^DGENDBS(408.31,MTIEN,.DATA)
"RTN","IVMCZMT",130,0)
 .;
"RTN","IVMCZMT",131,0)
 I VAFSTR[",2," S $P(VAFY,HLFS,2)=$S(+NODE:$$HLDATE^HLFNC(+NODE),1:HLQ) ; MT Date
"RTN","IVMCZMT",132,0)
 I VAFSTR[",3," S X=$P($G(^DG(408.32,+$P(NODE,"^",3),0)),"^",2),$P(VAFY,HLFS,3)=$S(X]"":X,1:"") ; MT Status
"RTN","IVMCZMT",133,0)
 I VAFSTR[",4," S $P(VAFY,HLFS,4)=$S($P(NODE,"^",4)]"":$P(NODE,"^",4),1:HLQ) ; Income
"RTN","IVMCZMT",134,0)
 I VAFSTR[",5," S $P(VAFY,HLFS,5)=$S($P(NODE,"^",5)]"":$P(NODE,"^",5),1:HLQ) ; Net Worth
"RTN","IVMCZMT",135,0)
 I VAFSTR[",6," S $P(VAFY,HLFS,6)=$S($P(NODE,"^",10):$$HLDATE^HLFNC($P(NODE,"^",10)),1:HLQ) ; Adjudication Date/Time
"RTN","IVMCZMT",136,0)
 I VAFSTR[",7," S $P(VAFY,HLFS,7)=$$YN^VAFHLFNC($P(NODE,"^",11)) ;Agreed To Pay
"RTN","IVMCZMT",137,0)
 I VAFSTR[",8," S $P(VAFY,HLFS,8)=$S($P(NODE,"^",12):$P(NODE,"^",12),1:HLQ) ; Threshold A
"RTN","IVMCZMT",138,0)
 I VAFSTR[",9," S $P(VAFY,HLFS,9)=$S($P(NODE,"^",15)]"":$P(NODE,"^",15),1:HLQ) ; Deductible Expenses
"RTN","IVMCZMT",139,0)
 I VAFSTR[",10," S $P(VAFY,HLFS,10)=$S($P(NODE,"^",7):$$HLDATE^HLFNC($P(NODE,"^",7)),1:HLQ) ; Date/Time Completed
"RTN","IVMCZMT",140,0)
 I VAFSTR[",11," S $P(VAFY,HLFS,11)=$$YN^VAFHLFNC($P(NODE,"^",16)) ;Previous Year Means Test Threshold Flag
"RTN","IVMCZMT",141,0)
 I VAFSTR[",12," S $P(VAFY,HLFS,12)=$S($P(NODE,"^",18)]"":$P(NODE,"^",18),1:HLQ) ; Total Dependents
"RTN","IVMCZMT",142,0)
 I VAFSTR[",13," S $P(VAFY,HLFS,13)=$$YN^VAFHLFNC($P(NODE,"^",20)) ;Hardship
"RTN","IVMCZMT",143,0)
 I VAFSTR[",14," S $P(VAFY,HLFS,14)=$S($P(NODE,"^",21):$$HLDATE^HLFNC($P(NODE,"^",21)),1:HLQ) ; Hardship Review Date
"RTN","IVMCZMT",144,0)
 I VAFSTR[",15," S $P(VAFY,HLFS,15)=$S($P(NODE,"^",24):$$HLDATE^HLFNC($P(NODE,"^",24)),1:HLQ) ; Date Vet Signed Test
"RTN","IVMCZMT",145,0)
 I VAFSTR[",16," S $P(VAFY,HLFS,16)=$$YN^VAFHLFNC($P(NODE,"^",14)) ;Declines To Give Income Info
"RTN","IVMCZMT",146,0)
 I VAFSTR[",17," S $P(VAFY,HLFS,17)=$S($P(NODE,"^",19):$P(NODE,"^",19),1:VAFTYPE) ; Type Of Test
"RTN","IVMCZMT",147,0)
 I VAFSTR[",18," S $P(VAFY,HLFS,18)=$S($P(NODE,"^",23)]"":$P(NODE,"^",23),1:HLQ) ; Source Of Test
"RTN","IVMCZMT",148,0)
 I VAFSTR[",19," S $P(VAFY,HLFS,19)=$$YN^VAFHLFNC(PRIM) ; Primary Test?
"RTN","IVMCZMT",149,0)
 I VAFSTR[",20," S $P(VAFY,HLFS,20)=$S($P(NODE,"^",25):$$HLDATE^HLFNC($P(NODE,"^",25)),1:HLQ) ; Date IVM Verified MT Completed
"RTN","IVMCZMT",150,0)
 I VAFSTR[",21," S $P(VAFY,HLFS,21)=$$YN^VAFHLFNC($P(NODE,"^",26)) ;Refused To Sign
"RTN","IVMCZMT",151,0)
 ;
"RTN","IVMCZMT",152,0)
 ;
"RTN","IVMCZMT",153,0)
 I VAFSTR[",22," S $P(VAFY,HLFS,22)=$P(NODE2,"^",5) ;Site Conducting Test
"RTN","IVMCZMT",154,0)
 I VAFSTR[",23," S $P(VAFY,HLFS,23)=$P(NODE2,"^",4) ;Site Granting Hardship
"RTN","IVMCZMT",155,0)
 I VAFSTR[",24," S $P(VAFY,HLFS,24)=$S($P(NODE2,"^"):$$HLDATE^HLFNC($P(NODE2,"^")),1:"") ;Hardship Effective Date
"RTN","IVMCZMT",156,0)
 I VAFSTR[",25," S $P(VAFY,HLFS,25)=$S($P(NODE2,"^",2):$$HLDATE^HLFNC($P(NODE2,"^",2)),1:"") ;Dt/Tm Test Last Edited
"RTN","IVMCZMT",157,0)
 I VAFSTR[",26," S $P(VAFY,HLFS,26)=$S($P(NODE2,"^",3):$$GETCODE^DGMTH($P(NODE2,"^",3)),1:"") ; Test Determined Status
"RTN","IVMCZMT",158,0)
 I VAFSTR[",28," S $P(VAFY,HLFS,28)=$P(NODE,"^",27)  ;GMT Threshold
"RTN","IVMCZMT",159,0)
 I VAFSTR[",29," S $P(VAFY,HLFS,29)=$P(NODE2,"^",9)  ;Hardship Reason
"RTN","IVMCZMT",160,0)
 I VAFSTR[",30," S $P(VAFY,HLFS,30)=+$P(NODE2,"^",11) ; Test Version
"RTN","IVMCZMT",161,0)
 I VAFSTR[",31," S $P(VAFY,HLFS,31)=$G(^DGMT(408.31,MTIEN,4)) ;Beneficiary Travel Financial Indicator - IVM*2.0*160
"RTN","IVMCZMT",162,0)
 ;
"RTN","IVMCZMT",163,0)
 ;can only transmit the deletion of a hardship if the segment is for a means test - and the income years must match if there is a means test
"RTN","IVMCZMT",164,0)
 ;
"RTN","IVMCZMT",165,0)
 I VAFTYPE=1,($G(DELETE("HARDSHIP"))=1),('(+NODE)!($E(DELETE("DATE OF TEST"),1,3)=$E((+NODE),1,3))) S $P(VAFY,HLFS,24)=HLQ
"RTN","IVMCZMT",166,0)
 ;
"RTN","IVMCZMT",167,0)
QUIT    Q "ZMT"_HLFS_$G(VAFY)
"RTN","IVMPTRN8")
0^2^B77554356
"RTN","IVMPTRN8",1,0)
IVMPTRN8 ;ALB/RKS/PDJ/BRM,TDM,PJH,TDM,PWC,LBD,JLS - 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**;21-OCT-94;Build 19
"RTN","IVMPTRN8",3,0)
 ;
"RTN","IVMPTRN8",4,0)
 ;
"RTN","IVMPTRN8",5,0)
BUILD(DFN,IVMMTDT,IVMCT,IVMQUERY) ; --
"RTN","IVMPTRN8",6,0)
 ;  Description: This entry point will be used to create an HL7 
"RTN","IVMPTRN8",7,0)
 ;  "Full Data Transmission" message for a patient.
"RTN","IVMPTRN8",8,0)
 ;
"RTN","IVMPTRN8",9,0)
 ;  Input:
"RTN","IVMPTRN8",10,0)
 ;        DFN - Patient IEN
"RTN","IVMPTRN8",11,0)
 ;    IVMMTDT - date of the patient's Means Test or Copay Test
"RTN","IVMPTRN8",12,0)
 ;      IVMCT - count of hl7 segments transmitted, pass by reference
"RTN","IVMPTRN8",13,0)
 ;   IVMQUERY - array passed in by reference where
"RTN","IVMPTRN8",14,0)
 ;    IVMQUERY("LTD") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",15,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",16,0)
 ;                last treatment date
"RTN","IVMPTRN8",17,0)
 ;    IVMQUERY("OVIS") -- # of the QUERY that is currently open or
"RTN","IVMPTRN8",18,0)
 ;                undefined, zero, or null if no QUERY opened for
"RTN","IVMPTRN8",19,0)
 ;                finding outpatient visits
"RTN","IVMPTRN8",20,0)
 ;
"RTN","IVMPTRN8",21,0)
 ;  HL7 variables as defined by call to INIT^IVMUFNC:
"RTN","IVMPTRN8",22,0)
 ;      HLEVN - HL7 message event counter 
"RTN","IVMPTRN8",23,0)
 ;      HLSDT - a flag that indicates that the data to be sent is
"RTN","IVMPTRN8",24,0)
 ;              stored in the ^TMP("HLS") global array.
"RTN","IVMPTRN8",25,0)
 ;
"RTN","IVMPTRN8",26,0)
 ;  The following variables returned by the INIT^HLTRANS entry point:
"RTN","IVMPTRN8",27,0)
 ;    HLNDAP - Non-DHCP Application Pointer from file 770
"RTN","IVMPTRN8",28,0)
 ;   HLNDAP0 - Zero node from file 770 corresponding to HLNDAP
"RTN","IVMPTRN8",29,0)
 ;     HLDAP - DHCP Application Pointer from file 771
"RTN","IVMPTRN8",30,0)
 ;     HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP
"RTN","IVMPTRN8",31,0)
 ;     HLPID - HL7 processing ID from file 770
"RTN","IVMPTRN8",32,0)
 ;     HLVER - HL7 version number from file 770
"RTN","IVMPTRN8",33,0)
 ;      HLFS - HL7 Field Separator from the 'FS' node of file 771
"RTN","IVMPTRN8",34,0)
 ;     HLECH - HL7 Encoding Characters from the 'EC' node of file 771
"RTN","IVMPTRN8",35,0)
 ;       HLQ - Double quotes ("") for use in building HL7 segments
"RTN","IVMPTRN8",36,0)
 ;     HLERR - if an error is encountered, an error message is returned
"RTN","IVMPTRN8",37,0)
 ;             in the HLERR variable.
"RTN","IVMPTRN8",38,0)
 ;      HLDA - the internal entry number for the entry created in
"RTN","IVMPTRN8",39,0)
 ;             file #772.
"RTN","IVMPTRN8",40,0)
 ;      HLDT - transmission date/time (associated with the entry in file
"RTN","IVMPTRN8",41,0)
 ;             #772 identified by HLDA) in internal VA FileMan format.
"RTN","IVMPTRN8",42,0)
 ;     HLDT1 - the same transmission date/time as the HLDT variable, 
"RTN","IVMPTRN8",43,0)
 ;             only in HL7 format.
"RTN","IVMPTRN8",44,0)
 ;
"RTN","IVMPTRN8",45,0)
 ; Output:
"RTN","IVMPTRN8",46,0)
 ;  ^TMP("HLS",$J,IVMCT) - global array containing all segments of the HL7 message that the VistA application wishes to send.  The HLSDT variable is defined above and the IVMCT variable is a sequential number incremented by 1.
"RTN","IVMPTRN8",47,0)
 ;
"RTN","IVMPTRN8",48,0)
 ;
"RTN","IVMPTRN8",49,0)
 N DGINC,DGIR,DGREL,I,IVMNTE,IVMPID,IVMSUB,IVMZRD,VAFPID,VAFZEL,FBZFE,IVMZCD,DELETE,NODE,IVMPIEN,TEST,IVMPNODE,TESTTYPE,SEQS,TESTCODE,HARDSHIP,ACTVIEN,IVMZMH,IVMSEQ
"RTN","IVMPTRN8",50,0)
 N EDBMTZ06,ZMHSQ,SETID,OBXCNT,OBXTMP,DGSEC,SEGOCC,ZIOSEG,N101015,RF1SEG,ZCTTYP,ZCTARY,ZCTSQ,VAFPID,CAFLG
"RTN","IVMPTRN8",51,0)
 ;
"RTN","IVMPTRN8",52,0)
 ; create (PID) Patient Identification segment
"RTN","IVMPTRN8",53,0)
 ; **** Add ICN to 2nd piece PID segment for MPI@HEC.
"RTN","IVMPTRN8",54,0)
 S IVMCMOR="1,2",IVMSEQ=1
"RTN","IVMPTRN8",55,0)
 ; check to see if site is a legacy site.  If not add ICN to PID segment.
"RTN","IVMPTRN8",56,0)
 I '$D(^PPP(1020.128,"AC",$P($$SITE^VASITE,"^",3))) D
"RTN","IVMPTRN8",57,0)
 . I +$$GETICN^MPIF001(DFN)>0,($$IFLOCAL^MPIF001(DFN)=0) S IVMSEQ=IVMSEQ_",2",IVMCMOR="1,2,3"  ;add SEQ 1 and 2 for PID
"RTN","IVMPTRN8",58,0)
 ;
"RTN","IVMPTRN8",59,0)
 ; send SSN indicating pseudo
"RTN","IVMPTRN8",60,0)
 ; I $P(IVMPID_$G(IVMPID(1)),HLFS,20)["P" D PSEUDO^IVMPTRN1  ; strip 'P' from pseudo SSNs
"RTN","IVMPTRN8",61,0)
 S IVMSEQ=IVMSEQ_",3,5,6,7,8,10,11,12,13,14,16,17,19,22,24"
"RTN","IVMPTRN8",62,0)
 K IVMPID D BLDPID^VAFCQRY1(DFN,1,IVMSEQ,.IVMPID,.HL,.ERROR)
"RTN","IVMPTRN8",63,0)
 K VAFPID D STRIP11
"RTN","IVMPTRN8",64,0)
 S SEGOCC="" F  S SEGOCC=$O(VAFPID(SEGOCC)) Q:SEGOCC=""  D
"RTN","IVMPTRN8",65,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFPID(SEGOCC)
"RTN","IVMPTRN8",66,0)
 ;
"RTN","IVMPTRN8",67,0)
 ; **** create (PD1) Patient CMOR segment for MPI@HEC.
"RTN","IVMPTRN8",68,0)
 S:'$D(HL("FS")) HL("FS")=HLFS
"RTN","IVMPTRN8",69,0)
 S:'$D(HL("ECH")) HL("ECH")=HLECH
"RTN","IVMPTRN8",70,0)
 S:'$D(HL("Q")) HL("Q")=HLQ
"RTN","IVMPTRN8",71,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLPD1(DFN,IVMCMOR)
"RTN","IVMPTRN8",72,0)
 ;
"RTN","IVMPTRN8",73,0)
 ; create (ZPD) Patient Dependent Info. segment
"RTN","IVMPTRN8",74,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN1^VAFHLZPD(DFN,"1,6,7,8,9,11,12,13,17,19,30,31,32,33,34,35,40"),IVMINS=$P(^(IVMCT),HLFS,12)
"RTN","IVMPTRN8",75,0)
 I $D(VAFZPD(1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=VAFZPD(1) K VAFZPD(1)
"RTN","IVMPTRN8",76,0)
 ;
"RTN","IVMPTRN8",77,0)
 ; create (ZTA) Temporary Address segment
"RTN","IVMPTRN8",78,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,8,9",,.HL)
"RTN","IVMPTRN8",79,0)
 ;
"RTN","IVMPTRN8",80,0)
 ; create (ZIE) Ineligible segment
"RTN","IVMPTRN8",81,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIE(DFN,"1,2,3",1)
"RTN","IVMPTRN8",82,0)
 ;
"RTN","IVMPTRN8",83,0)
 ; create (ZEL) Eligibility segment(s) 
"RTN","IVMPTRN8",84,0)
 ; **** Add 5th piece to ZEL to correct consistency check
"RTN","IVMPTRN8",85,0)
 D EN1^VAFHLZEL(DFN,"1,2,5,6,7,8,10,11,13,14,15,16,17,18,19,20,21,22,23,24,25,29,34,35,37,38,39,40",2,.VAFZEL)
"RTN","IVMPTRN8",86,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1))  ; Primary Eligibility
"RTN","IVMPTRN8",87,0)
 I $D(VAFZEL(1,1)) S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1,1))
"RTN","IVMPTRN8",88,0)
 ; - other entitled eligibilities
"RTN","IVMPTRN8",89,0)
 F IVMSUB=1:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",90,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(+IVMSUB))
"RTN","IVMPTRN8",91,0)
 ;
"RTN","IVMPTRN8",92,0)
 ; create ZE2 segment (Optional)
"RTN","IVMPTRN8",93,0)
 I $P($G(^DPT(DFN,.385)),U)'="" S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZE2(DFN,"1,2")
"RTN","IVMPTRN8",94,0)
 ;
"RTN","IVMPTRN8",95,0)
 ; create (ZEN) Enrollment segment
"RTN","IVMPTRN8",96,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEN(DFN)
"RTN","IVMPTRN8",97,0)
 ;
"RTN","IVMPTRN8",98,0)
 ; create (ZCD) Catastrophic Disability segment(s)
"RTN","IVMPTRN8",99,0)
 D BUILD^VAFHLZCD(.IVMZCD,DFN,,HLQ,HLFS)
"RTN","IVMPTRN8",100,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZCD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",101,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZCD(+IVMSUB))
"RTN","IVMPTRN8",102,0)
 ;
"RTN","IVMPTRN8",103,0)
 ; Optionally create (ZMH) Military History segments
"RTN","IVMPTRN8",104,0)
 ; Pass "*" as parameter to send unlimited MSEs in Z07 (IVM*2*141)
"RTN","IVMPTRN8",105,0)
 D ENTER^VAFHLZMH(DFN,"IVMZMH","*")
"RTN","IVMPTRN8",106,0)
 S (ZMHSQ,SETID)=0
"RTN","IVMPTRN8",107,0)
 I $D(IVMZMH) F  S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ=""  D
"RTN","IVMPTRN8",108,0)
 . Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")=""
"RTN","IVMPTRN8",109,0)
 . S SETID=SETID+1,IVMCT=IVMCT+1
"RTN","IVMPTRN8",110,0)
 . S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZMH(ZMHSQ,0),HLFS,3,6)
"RTN","IVMPTRN8",111,0)
 ;
"RTN","IVMPTRN8",112,0)
 ; create (ZRD) Rated Disabilities segment(s)
"RTN","IVMPTRN8",113,0)
 D EN^VAFHLZRD(DFN,"1,2,3,4,12,13,14,",HLQ,HLFS,"IVMZRD")
"RTN","IVMPTRN8",114,0)
 F IVMSUB=0:0 S IVMSUB=+$O(IVMZRD(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",115,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(IVMZRD(+IVMSUB,0))
"RTN","IVMPTRN8",116,0)
 ;
"RTN","IVMPTRN8",117,0)
 ; create (ZCT) Emergency Contact segment
"RTN","IVMPTRN8",118,0)
 ;S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",1,1)
"RTN","IVMPTRN8",119,0)
 K ZCTARY F ZCTTYP=1:1:5 D   ;Create Optional ZCT Segments
"RTN","IVMPTRN8",120,0)
 . S ZCTARY(ZCTTYP)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,10","",ZCTTYP,1)
"RTN","IVMPTRN8",121,0)
 S (ZCTTYP,ZCTSQ)=0
"RTN","IVMPTRN8",122,0)
 I $D(ZCTARY) F  S ZCTTYP=$O(ZCTARY(ZCTTYP)) Q:ZCTTYP=""  D
"RTN","IVMPTRN8",123,0)
 . Q:$P(ZCTARY(ZCTTYP),HLFS,11)=HLQ
"RTN","IVMPTRN8",124,0)
 . S ZCTSQ=ZCTSQ+1,$P(ZCTARY(ZCTTYP),HLFS,2)=ZCTSQ
"RTN","IVMPTRN8",125,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(ZCTTYP)
"RTN","IVMPTRN8",126,0)
 I ZCTSQ=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZCTARY(1)
"RTN","IVMPTRN8",127,0)
 ;
"RTN","IVMPTRN8",128,0)
 ; create (ZEM) Employment Info. segment for (1) Patient & (2) Spouse
"RTN","IVMPTRN8",129,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7")
"RTN","IVMPTRN8",130,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7",2,2)
"RTN","IVMPTRN8",131,0)
 ;
"RTN","IVMPTRN8",132,0)
 ; create (ZGD) Guardian segment for (1) VA & (2) Civil 
"RTN","IVMPTRN8",133,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",1)
"RTN","IVMPTRN8",134,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZGD(DFN,"1,2,3,4,5,6,7,8",2)
"RTN","IVMPTRN8",135,0)
 ;
"RTN","IVMPTRN8",136,0)
 ; Income Year requiring transmission from IVM Patient File (301.5)
"RTN","IVMPTRN8",137,0)
 S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000))
"RTN","IVMPTRN8",138,0)
 N MTINFO S MTINFO=$$FUT^DGMTU(DFN)
"RTN","IVMPTRN8",139,0)
 I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT=$P(MTINFO,U,2)
"RTN","IVMPTRN8",140,0)
 ;get the primary test for the income year
"RTN","IVMPTRN8",141,0)
 S TESTTYPE=$$GETTYPE^IVMPTRN9(DFN,IVMMTDT,.TESTCODE,.HARDSHIP,.ACTVIEN)
"RTN","IVMPTRN8",142,0)
 ;
"RTN","IVMPTRN8",143,0)
 ; The following function call returns:
"RTN","IVMPTRN8",144,0)
 ;   - Patient Relation IEN array in DGREL
"RTN","IVMPTRN8",145,0)
 ;   - Individual Annual Income IEN array in DGINC
"RTN","IVMPTRN8",146,0)
 ;   - Income Relation IEN array in DGINR
"RTN","IVMPTRN8",147,0)
 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IPR",ACTVIEN)
"RTN","IVMPTRN8",148,0)
 ;
"RTN","IVMPTRN8",149,0)
 S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1
"RTN","IVMPTRN8",150,0)
 ; create (ZIC) Income segment for veteran
"RTN","IVMPTRN8",151,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",152,0)
 ;IVM*2.0*115 -- Check for Means Test Version Indicator
"RTN","IVMPTRN8",153,0)
 N MTVERS S MTVERS=$S(+$G(ACTVIEN):+$P($G(^DGMT(408.31,ACTVIEN,2)),"^",11),1:0)
"RTN","IVMPTRN8",154,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",155,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",156,0)
 E  D
"RTN","IVMPTRN8",157,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("V")),"1,2,3,9,12,13,14,15,16,18,19")
"RTN","IVMPTRN8",158,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",159,0)
 ;use IVMIY not IVMMTDT. For LTC copay exemption, IVMMTDT is not correct
"RTN","IVMPTRN8",160,0)
 S $P(^TMP("HLS",$J,IVMCT),"^",3)=$$HLDATE^HLFNC(IVMIY)
"RTN","IVMPTRN8",161,0)
 ;
"RTN","IVMPTRN8",162,0)
 ; create (ZIR) Income Relation segment for veteran
"RTN","IVMPTRN8",163,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",164,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1"
"RTN","IVMPTRN8",165,0)
 ;
"RTN","IVMPTRN8",166,0)
 ; create (ZDP) Patient Dependent Info. segment for spouse
"RTN","IVMPTRN8",167,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",168,0)
 I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",169,0)
 . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",170,0)
 . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",171,0)
 ;
"RTN","IVMPTRN8",172,0)
 ; create (ZIC) Income segment for spouse
"RTN","IVMPTRN8",173,0)
 S IVMCT=IVMCT+1
"RTN","IVMPTRN8",174,0)
 ;IVM*2.0*115
"RTN","IVMPTRN8",175,0)
 I MTVERS=0 D  I 1
"RTN","IVMPTRN8",176,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",177,0)
 E  D
"RTN","IVMPTRN8",178,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("S")),"1,2,3,9,12,16,18,19")
"RTN","IVMPTRN8",179,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",180,0)
 ;
"RTN","IVMPTRN8",181,0)
 ; create (ZIR) Income Relation segment for spouse
"RTN","IVMPTRN8",182,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIR(+$G(DGINR("S")),"1,2,3")
"RTN","IVMPTRN8",183,0)
 I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",184,0)
 ;
"RTN","IVMPTRN8",185,0)
 ;
"RTN","IVMPTRN8",186,0)
 ; create ZDP, ZIC, and ZIR segments for all Means Test dependents
"RTN","IVMPTRN8",187,0)
 F IVMSUB=0:0 S IVMSUB=$O(DGREL("C",IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",188,0)
 . ;
"RTN","IVMPTRN8",189,0)
 . ; - create (ZDP) Dependent Info. segment for dependent child
"RTN","IVMPTRN8",190,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",191,0)
 . I $P(^TMP("HLS",$J,IVMCT),HLFS,3)'=HLQ,($P($G(^(IVMCT)),HLFS,6)=HLQ) D
"RTN","IVMPTRN8",192,0)
 . . ; - pass non-existent SSNs as 0s
"RTN","IVMPTRN8",193,0)
 . . S $P(X,HLFS,6)="000000000"
"RTN","IVMPTRN8",194,0)
 . ;
"RTN","IVMPTRN8",195,0)
 . ; - create (ZIC) Income segment for dependent child
"RTN","IVMPTRN8",196,0)
 . S IVMCT=IVMCT+1
"RTN","IVMPTRN8",197,0)
 . ;IVM*2.0*115
"RTN","IVMPTRN8",198,0)
 . I MTVERS=0 D  I 1
"RTN","IVMPTRN8",199,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,4,5,6,7,8,9,10,11,12,15")
"RTN","IVMPTRN8",200,0)
 . E  D
"RTN","IVMPTRN8",201,0)
 . . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZIC(+$G(DGINC("C",IVMSUB)),"1,2,3,9,12,15,16,18,19")
"RTN","IVMPTRN8",202,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS",$J,IVMCT),"^",2,3)
"RTN","IVMPTRN8",203,0)
 . ;
"RTN","IVMPTRN8",204,0)
 . ; - create (ZIR) Income Relation segment for dependent child
"RTN","IVMPTRN8",205,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",206,0)
 . I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS",$J,IVMCT),"^",2)
"RTN","IVMPTRN8",207,0)
 . ;
"RTN","IVMPTRN8",208,0)
 ; Send INACTIVE spouse/dependents.
"RTN","IVMPTRN8",209,0)
 D GETINACD^DGMTU11(DFN,.DGREL)
"RTN","IVMPTRN8",210,0)
 F I="S","C" D
"RTN","IVMPTRN8",211,0)
 . F IVMSUB=0:0 S IVMSUB=$O(DGIREL(I,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN8",212,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",213,0)
 ;
"RTN","IVMPTRN8",214,0)
 D GOTO^IVMPTRN9
"RTN","IVMPTRN8",215,0)
 Q
"RTN","IVMPTRN8",216,0)
 ;
"RTN","IVMPTRN8",217,0)
STRIP11 N APID,ZPID,ASQ,ATYP,SSQ
"RTN","IVMPTRN8",218,0)
 ;Extract PID segment
"RTN","IVMPTRN8",219,0)
 S IVMPID(1)=$E(IVMPID(1),5,$L(IVMPID(1)))
"RTN","IVMPTRN8",220,0)
 D BLDPID^IVMPREC6(.IVMPID,.APID)
"RTN","IVMPTRN8",221,0)
 ;
"RTN","IVMPTRN8",222,0)
 S CAFLG=0
"RTN","IVMPTRN8",223,0)
 I $D(APID(11)) D
"RTN","IVMPTRN8",224,0)
 .I $O(APID(11,"")) D  Q
"RTN","IVMPTRN8",225,0)
 ..M ZPID(11)=APID(11) K APID(11)
"RTN","IVMPTRN8",226,0)
 ..S (ASQ,SSQ)=0 F  S ASQ=$O(ZPID(11,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",227,0)
 ...S ATYP=$P($G(ZPID(11,ASQ)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",228,0)
 ...I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") Q
"RTN","IVMPTRN8",229,0)
 ...I ATYP="VACAE" S CAFLG=1
"RTN","IVMPTRN8",230,0)
 ...S SSQ=SSQ+1,APID(11,SSQ)=ZPID(11,ASQ)
"RTN","IVMPTRN8",231,0)
 .Q:$G(APID(11))=""
"RTN","IVMPTRN8",232,0)
 .S ATYP=$P($G(APID(11)),$E(HLECH),7) Q:ATYP=""
"RTN","IVMPTRN8",233,0)
 .I ATYP="VACAE" S CAFLG=1 Q
"RTN","IVMPTRN8",234,0)
 .I (ATYP="VACAA")!(ATYP="VACAC")!(ATYP="VACAM")!(ATYP="VACAO") K APID(11)
"RTN","IVMPTRN8",235,0)
 ;
"RTN","IVMPTRN8",236,0)
 I 'CAFLG,$D(APID(13)) D
"RTN","IVMPTRN8",237,0)
 .I $O(APID(13,"")) D  Q
"RTN","IVMPTRN8",238,0)
 ..S ASQ=0 F  S ASQ=$O(APID(13,ASQ)) Q:ASQ=""  D
"RTN","IVMPTRN8",239,0)
 ...Q:$G(APID(13,ASQ))=""
"RTN","IVMPTRN8",240,0)
 ...S ATYP=$P($G(APID(13,ASQ)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",241,0)
 ...I ATYP="VACPN" K APID(13,ASQ) Q
"RTN","IVMPTRN8",242,0)
 .Q:$G(APID(13))=""
"RTN","IVMPTRN8",243,0)
 .S ATYP=$P($G(APID(13)),$E(HLECH),2) Q:ATYP=""
"RTN","IVMPTRN8",244,0)
 .I ATYP="VACPN" K APID(13) Q
"RTN","IVMPTRN8",245,0)
 ;
"RTN","IVMPTRN8",246,0)
 ;Rebuild PID
"RTN","IVMPTRN8",247,0)
 D KVA^VADPT
"RTN","IVMPTRN8",248,0)
 D MAKEIT^VAFHLU("PID",.APID,.VAFPID,.VAFPID)
"RTN","IVMPTRN8",249,0)
 S VAFPID(0)=VAFPID
"RTN","IVMPTRN8",250,0)
 Q
"RTN","IVMPTRN9")
0^5^B53734874
"RTN","IVMPTRN9",1,0)
IVMPTRN9 ;ALB/KCL/CN/BRM,TDM,EG,LBD,TGH - HL7 FULL DATA TRANSMISSION (Z07) BUILDER (CONTINUED) ; 2/7/12 2:56pm
"RTN","IVMPTRN9",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46,50,53,34,49,58,79,99,116,105,115,152,160**; 21-OCT-94;Build 19
"RTN","IVMPTRN9",3,0)
 ;
"RTN","IVMPTRN9",4,0)
 ;
"RTN","IVMPTRN9",5,0)
GOTO ; place to break up the routine
"RTN","IVMPTRN9",6,0)
 ;
"RTN","IVMPTRN9",7,0)
 ; create (ZIO) Inpatient/Outpatient segment for veteran
"RTN","IVMPTRN9",8,0)
 S N101015=$G(^DPT(DFN,1010.15))
"RTN","IVMPTRN9",9,0)
 S ZIOSEG="ZIO^1^"_$$EN^IVMUFNC1(DFN,IVMMTDT,.IVMQUERY)  ;seq 1-3
"RTN","IVMPTRN9",10,0)
 S ZIOSEG=ZIOSEG_"^"_$$LTD^IVMUFNC(DFN,.IVMQUERY)        ;seq 4
"RTN","IVMPTRN9",11,0)
 S X=$P(N101015,"^",9),$P(ZIOSEG,U,6)=$S(X=0:"N",X=1:"Y",1:HLQ)   ;Appt Request
"RTN","IVMPTRN9",12,0)
 S X=$P(N101015,"^",11),$P(ZIOSEG,U,7)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) ;Appt Request Date
"RTN","IVMPTRN9",13,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZIOSEG
"RTN","IVMPTRN9",14,0)
 ;
"RTN","IVMPTRN9",15,0)
 ; create (NTE) Notes and Comments segment
"RTN","IVMPTRN9",16,0)
 D NTE^IVMUFNC4(DFN,.IVMNTE,IVMMTDT)
"RTN","IVMPTRN9",17,0)
 I '$D(IVMNTE) D
"RTN","IVMPTRN9",18,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="NTE^1"
"RTN","IVMPTRN9",19,0)
 I $D(IVMNTE) D
"RTN","IVMPTRN9",20,0)
 . ; - get notes and comments
"RTN","IVMPTRN9",21,0)
 . F IVMSUB=0:0 S IVMSUB=$O(IVMNTE(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",22,0)
 . . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMNTE(IVMSUB)
"RTN","IVMPTRN9",23,0)
 ;
"RTN","IVMPTRN9",24,0)
 ; create (IN1) Insurance segment(s) for all active insurance
"RTN","IVMPTRN9",25,0)
 K ^TMP("VAFIN1",$J)
"RTN","IVMPTRN9",26,0)
 D EN^VAFHLIN1(DFN,"1,4,5,7,8,9,12,13,15,16,17,28,36")
"RTN","IVMPTRN9",27,0)
 F IVMSUB=0:0 S IVMSUB=$O(^TMP("VAFIN1",$J,IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",28,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=^TMP("VAFIN1",$J,+IVMSUB,0)
"RTN","IVMPTRN9",29,0)
 ;
"RTN","IVMPTRN9",30,0)
 ;find if the deletion flags were set in the IVM Patient file, and if so, should the deletion indicators be sent?
"RTN","IVMPTRN9",31,0)
 F I="RX","MT","HARDSHIP","DATE OF TEST","LTC" S DELETE(I)=""
"RTN","IVMPTRN9",32,0)
 S IVMPIEN=$$FIND^IVMPLOG(DFN,($E(IVMMTDT,1,3)-1))
"RTN","IVMPTRN9",33,0)
 I IVMPIEN D
"RTN","IVMPTRN9",34,0)
 . S IVMPNODE=$G(^IVM(301.5,IVMPIEN,0))
"RTN","IVMPTRN9",35,0)
 . I $P(IVMPNODE,"^",8)!$P(IVMPNODE,"^",9)!$P(IVMPNODE,"^",10)!$P(IVMPNODE,"^",11) S DELETE("SET")=1
"RTN","IVMPTRN9",36,0)
 . ;was the MT deletion flag set, and if so verify that there is no completed MT
"RTN","IVMPTRN9",37,0)
 . I $P(IVMPNODE,"^",8),(TESTTYPE'=1)!(TESTCODE="")!("ACGP"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",8),DELETE("MT")=1
"RTN","IVMPTRN9",38,0)
 . ;
"RTN","IVMPTRN9",39,0)
 . ;was the hardship deletion flag set, and if so verify that there is no completed hardship
"RTN","IVMPTRN9",40,0)
 . I $P(IVMPNODE,"^",10),'HARDSHIP D
"RTN","IVMPTRN9",41,0)
 . . S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",10)
"RTN","IVMPTRN9",42,0)
 . . S DELETE("HARDSHIP")=1
"RTN","IVMPTRN9",43,0)
 ;
"RTN","IVMPTRN9",44,0)
 ; create (ZMT) Means Test segment 
"RTN","IVMPTRN9",45,0)
 ;
"RTN","IVMPTRN9",46,0)
 S SEQS=$S(TESTTYPE=1:"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,21,22,23,24,25,26,28,29,30,31",1:"1,17")  ;IVM*2.0*160
"RTN","IVMPTRN9",47,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,1,1,.DELETE,1)
"RTN","IVMPTRN9",48,0)
 ;
"RTN","IVMPTRN9",49,0)
 ; create (ZMT) Rx-Copay Test segment
"RTN","IVMPTRN9",50,0)
 I IVMPIEN D
"RTN","IVMPTRN9",51,0)
 . ;was the RX deletion flag set, and if so verify that there is no completed test
"RTN","IVMPTRN9",52,0)
 . I $P(IVMPNODE,"^",9),(TESTTYPE'=2)!(TESTCODE="")!("EM"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",9),DELETE("RX")=1
"RTN","IVMPTRN9",53,0)
 ;
"RTN","IVMPTRN9",54,0)
 N IVMCPDT,CPTST,LINK,CPDATE
"RTN","IVMPTRN9",55,0)
 ;should be ok to get the last co-pay test for this year vs. looking from the IVMMTDT backwards
"RTN","IVMPTRN9",56,0)
 ;as long as the means test date is in the current year
"RTN","IVMPTRN9",57,0)
 S CPTST=$$LST^DGMTU(DFN,$E(IVMIY,1,3)+1_1231,2)
"RTN","IVMPTRN9",58,0)
 I CPTST D
"RTN","IVMPTRN9",59,0)
 . S CPDATE=$P(CPTST,U,2)
"RTN","IVMPTRN9",60,0)
 . S LINK=$P($G(^DGMT(408.31,+CPTST,2)),U,6)
"RTN","IVMPTRN9",61,0)
 . I TESTTYPE=1,$E(CPDATE,1,3)=$E(IVMMTDT,1,3) D
"RTN","IVMPTRN9",62,0)
 . . ;if you have a means test and a linked co-pay test then send both (the means test
"RTN","IVMPTRN9",63,0)
 . . ;was already sent from above)
"RTN","IVMPTRN9",64,0)
 . . ;if means and copay are not linked, don't send the co-pay test (the means test
"RTN","IVMPTRN9",65,0)
 . . ;was already sent from above)
"RTN","IVMPTRN9",66,0)
 . . I LINK=+$$LST^DGMTU(DFN,IVMMTDT,1) S TESTTYPE=2,(IVMCPDT,IVMMTDT)=CPDATE
"RTN","IVMPTRN9",67,0)
 . . Q
"RTN","IVMPTRN9",68,0)
 . Q
"RTN","IVMPTRN9",69,0)
 ;always send the 2nd ZMT segment
"RTN","IVMPTRN9",70,0)
 S SEQS="1,17"
"RTN","IVMPTRN9",71,0)
 ;can also send a co-pay test if there is no means test (see module GETTYPE)
"RTN","IVMPTRN9",72,0)
 I TESTTYPE=2 D
"RTN","IVMPTRN9",73,0)
 . S SEQS="1,2,3,4,5,6,7,9,10,12,15,16,17,18,21,22,25,26,30,31"  ;IVM*2.0*160
"RTN","IVMPTRN9",74,0)
 . Q
"RTN","IVMPTRN9",75,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,2,2,.DELETE,1)
"RTN","IVMPTRN9",76,0)
 ;
"RTN","IVMPTRN9",77,0)
 ; create (ZMT) Long Term Care Copay Exemption Test segment
"RTN","IVMPTRN9",78,0)
 I IVMPIEN D
"RTN","IVMPTRN9",79,0)
 . ; set deletion indicators if LTC test deletion should be transmitted
"RTN","IVMPTRN9",80,0)
 . I $P(IVMPNODE,"^",11) S DELETE("LTC")=1 S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",11)
"RTN","IVMPTRN9",81,0)
 ;
"RTN","IVMPTRN9",82,0)
 S SEQS="1,2,3,4,5,7,9,10,12,16,17,18,22,25,30,31"  ;IVM*2.0*160
"RTN","IVMPTRN9",83,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,4,4,.DELETE,1)
"RTN","IVMPTRN9",84,0)
 ;
"RTN","IVMPTRN9",85,0)
 ;if the deletion flags were set in the IVM Patient file, unset them
"RTN","IVMPTRN9",86,0)
 I $G(DELETE("SET")) D
"RTN","IVMPTRN9",87,0)
 . N DATA
"RTN","IVMPTRN9",88,0)
 . S DATA(.08)="",DATA(.09)="",DATA(.1)="",DATA(.11)=""
"RTN","IVMPTRN9",89,0)
 . I $$UPD^DGENDBS(301.5,IVMPIEN,.DATA)
"RTN","IVMPTRN9",90,0)
 ;
"RTN","IVMPTRN9",91,0)
 ; create (ZBT) Beneficiary Travel segment based on last BT Claim
"RTN","IVMPTRN9",92,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZBT($$BTCLM^IVMUFNC4(DFN),"1,2,3,4,7")
"RTN","IVMPTRN9",93,0)
 ;
"RTN","IVMPTRN9",94,0)
 ; create (ZFE) Fee Basis segment(s)
"RTN","IVMPTRN9",95,0)
 D EN^FBHLZFE(DFN,"1,2,3,4,5")
"RTN","IVMPTRN9",96,0)
 F IVMSUB=0:0 S IVMSUB=+$O(FBZFE(IVMSUB)) Q:'IVMSUB  D
"RTN","IVMPTRN9",97,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(FBZFE(+IVMSUB))
"RTN","IVMPTRN9",98,0)
 ;
"RTN","IVMPTRN9",99,0)
 ; create (ZSP) Service Period segment
"RTN","IVMPTRN9",100,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZSP(DFN,1,1)
"RTN","IVMPTRN9",101,0)
 ;
"RTN","IVMPTRN9",102,0)
 ; optionally create (OBX) segment for Patient Sensitivity Flag
"RTN","IVMPTRN9",103,0)
 K OBXTMP
"RTN","IVMPTRN9",104,0)
 S OBXCNT=0,GETCUR=$$FINDSEC^DGENSEC(DFN)
"RTN","IVMPTRN9",105,0)
 I GETCUR,$$GET^DGENSEC(GETCUR,.DGSEC) D
"RTN","IVMPTRN9",106,0)
 . Q:(DGSEC("LEVEL")'=1)&(DGSEC("LEVEL")'=0)
"RTN","IVMPTRN9",107,0)
 . S OBXTMP(2)="CE",OBXTMP(3)="38.1"_$E(HL("ECH"))_"SECURITY LOG"
"RTN","IVMPTRN9",108,0)
 . S:DGSEC("LEVEL") OBXTMP(5)="Y"_$E(HL("ECH"))_"YES"_$E(HL("ECH"))_"HL70136"
"RTN","IVMPTRN9",109,0)
 . S:'DGSEC("LEVEL") OBXTMP(5)="N"_$E(HL("ECH"))_"NO"_$E(HL("ECH"))_"HL70136"
"RTN","IVMPTRN9",110,0)
 . S OBXTMP(11)="R",OBXTMP(14)=DGSEC("DATETIME")
"RTN","IVMPTRN9",111,0)
 . S OBXTMP(16)="" I $G(DGSEC("SOURCE"))'="" D
"RTN","IVMPTRN9",112,0)
 . . S $P(OBXTMP(16),$E(HL("ECH")),14)=$E(HL("ECH"),4)_DGSEC("SOURCE")
"RTN","IVMPTRN9",113,0)
 . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
"RTN","IVMPTRN9",114,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.OBXTMP,OBXCNT,"2,3,5,11,14,16")
"RTN","IVMPTRN9",115,0)
 . I $G(OBXTMP(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(OBXTMP(16))
"RTN","IVMPTRN9",116,0)
 ;
"RTN","IVMPTRN9",117,0)
 ; create (OBX) segment for NTR
"RTN","IVMPTRN9",118,0)
 ; CALL PIMS API TO GET NTRARRY OF NTR DATA
"RTN","IVMPTRN9",119,0)
 S GETCUR=$$ENRGET^DGNTAPI1(DFN)
"RTN","IVMPTRN9",120,0)
 I GETCUR D NTROBX^IVMPTRNA(.DGNTARR)
"RTN","IVMPTRN9",121,0)
 I $D(NTROBX) D
"RTN","IVMPTRN9",122,0)
 . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
"RTN","IVMPTRN9",123,0)
 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.NTROBX,OBXCNT,"2,3,5,11,12,14,15,16,17")
"RTN","IVMPTRN9",124,0)
 . I $G(NTROBX(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(NTROBX(16))
"RTN","IVMPTRN9",125,0)
 . K NTROBX
"RTN","IVMPTRN9",126,0)
 ;
"RTN","IVMPTRN9",127,0)
 ; create (RF1) segment
"RTN","IVMPTRN9",128,0)
 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$RF1^IVMPTRNA(DFN,"SAD")
"RTN","IVMPTRN9",129,0)
 F RF1TYP="CAD","CPH","PNO","EAD","PHH" D   ;Create Optional RF1 Segments
"RTN","IVMPTRN9",130,0)
 . S RF1SEG=$$RF1^IVMPTRNA(DFN,RF1TYP) Q:RF1SEG=""
"RTN","IVMPTRN9",131,0)
 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=RF1SEG
"RTN","IVMPTRN9",132,0)
 ;
"RTN","IVMPTRN9",133,0)
 Q
"RTN","IVMPTRN9",134,0)
 ;
"RTN","IVMPTRN9",135,0)
GETTYPE(DFN,IVMMTDT,CODE,HARDSHIP,ACTVIEN)      ;
"RTN","IVMPTRN9",136,0)
 ;Determines the type of test to include in the Z10.  HEC wants only the
"RTN","IVMPTRN9",137,0)
 ;test that they would consider primary,i.e., preference given to a comptleted means test, even if not currently in effect.
"RTN","IVMPTRN9",138,0)
 ;
"RTN","IVMPTRN9",139,0)
 ;Input:
"RTN","IVMPTRN9",140,0)
 ;  DFN
"RTN","IVMPTRN9",141,0)
 ;  IVMMTDT -date to be the search for the test
"RTN","IVMPTRN9",142,0)
 ;Output:
"RTN","IVMPTRN9",143,0)
 ;  Function value - type of test to send in Z10
"RTN","IVMPTRN9",144,0)
 ;  CODE - status code of test (pass by reference)
"RTN","IVMPTRN9",145,0)
 ;  HARDSHIP - hardship indicator (pass by reference)
"RTN","IVMPTRN9",146,0)
 ;  ACTVIEN - ien of test that should have the associated Income Relations (pass by reference)
"RTN","IVMPTRN9",147,0)
 ;
"RTN","IVMPTRN9",148,0)
 N TESTTYPE,MTNODE,RXNODE,NODE0,NODE2
"RTN","IVMPTRN9",149,0)
 S TESTTYPE=1
"RTN","IVMPTRN9",150,0)
 S (HARDSHIP,CODE,ACTVIEN)=""
"RTN","IVMPTRN9",151,0)
 Q:'$G(IVMMTDT) TESTTYPE
"RTN","IVMPTRN9",152,0)
 Q:'$G(DFN) TESTTYPE
"RTN","IVMPTRN9",153,0)
 ;
"RTN","IVMPTRN9",154,0)
 S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
"RTN","IVMPTRN9",155,0)
 S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
"RTN","IVMPTRN9",156,0)
 ;
"RTN","IVMPTRN9",157,0)
 I MTNODE="" S MTNODE=$$FUT^DGMTU(DFN,"",1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
"RTN","IVMPTRN9",158,0)
 I RXNODE="" S RXNODE=$$FUT^DGMTU(DFN,"",2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
"RTN","IVMPTRN9",159,0)
 D
"RTN","IVMPTRN9",160,0)
 . ;determine which test has the associated income relations
"RTN","IVMPTRN9",161,0)
 . ;
"RTN","IVMPTRN9",162,0)
 . I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
"RTN","IVMPTRN9",163,0)
 . I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
"RTN","IVMPTRN9",164,0)
 . I +MTNODE S ACTVIEN=+MTNODE Q
"RTN","IVMPTRN9",165,0)
 . I +RXNODE S ACTVIEN=+RXNODE Q
"RTN","IVMPTRN9",166,0)
 I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
"RTN","IVMPTRN9",167,0)
 ;
"RTN","IVMPTRN9",168,0)
 ;now find the primary test
"RTN","IVMPTRN9",169,0)
 I '(+MTNODE) G CHKCOPAY
"RTN","IVMPTRN9",170,0)
 S CODE=$P(MTNODE,"^",4)
"RTN","IVMPTRN9",171,0)
 S HARDSHIP=$P($G(^DGMT(408.31,+MTNODE,0)),"^",20)
"RTN","IVMPTRN9",172,0)
 I (CODE="")!("ACGP"'[CODE) S NODE2=$G(^DGMT(408.31,+MTNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("ACGP"'[CODE) G CHKCOPAY
"RTN","IVMPTRN9",173,0)
 ;
"RTN","IVMPTRN9",174,0)
 G QGETTYPE
"RTN","IVMPTRN9",175,0)
 ;
"RTN","IVMPTRN9",176,0)
CHKCOPAY        ;
"RTN","IVMPTRN9",177,0)
 I '(+RXNODE) G QGETTYPE
"RTN","IVMPTRN9",178,0)
 S CODE=$P(RXNODE,"^",4)
"RTN","IVMPTRN9",179,0)
 I (CODE="")!("EM"'[CODE) S NODE2=$G(^DGMT(408.31,+RXNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("EM"'[CODE) G QGETTYPE
"RTN","IVMPTRN9",180,0)
 S TESTTYPE=2
"RTN","IVMPTRN9",181,0)
 ;
"RTN","IVMPTRN9",182,0)
QGETTYPE        ;
"RTN","IVMPTRN9",183,0)
 Q TESTTYPE
"RTN","IVMPTRN9",184,0)
 ;
"RTN","IVMPTRN9",185,0)
FILTER(DFN)     ; address transmission filter
"RTN","IVMPTRN9",186,0)
 ; Check Bad Address Indicator for a known bad address and
"RTN","IVMPTRN9",187,0)
 ; Scrutinize the Street Address line 1 field for known bad address
"RTN","IVMPTRN9",188,0)
 ; strings based on functionality currently in place in HEC Legacy.
"RTN","IVMPTRN9",189,0)
 ;
"RTN","IVMPTRN9",190,0)
 ;  Input: DFN - ien of the Patient (#2) file
"RTN","IVMPTRN9",191,0)
 ; Output:   0 - filter passed (ok to transmit address)
"RTN","IVMPTRN9",192,0)
 ;           1 - filter failed (do not transmit address)
"RTN","IVMPTRN9",193,0)
 ;
"RTN","IVMPTRN9",194,0)
 N VAPA
"RTN","IVMPTRN9",195,0)
 Q:'$G(DFN) 1  ;DFN missing
"RTN","IVMPTRN9",196,0)
 Q:$$BADADR^DGUTL3(DFN) 1  ;check Bad Address Indicator
"RTN","IVMPTRN9",197,0)
 D ADD^VADPT  ;get patient address
"RTN","IVMPTRN9",198,0)
 ; Street Address Line 1 or Zip Code is <null>
"RTN","IVMPTRN9",199,0)
 Q:($G(VAPA(1))="")!($P($G(VAPA(11)),"^")="") 1
"RTN","IVMPTRN9",200,0)
 ; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or 'ADDRESS'
"RTN","IVMPTRN9",201,0)
 Q:(VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)["ADDRESS") 1
"RTN","IVMPTRN9",202,0)
 ; The first two characters of the address is equal to '**'
"RTN","IVMPTRN9",203,0)
 Q:$E(VAPA(1),1,2)="**" 1
"RTN","IVMPTRN9",204,0)
 ; passed all address filters - ok to send
"RTN","IVMPTRN9",205,0)
 Q 0
"VER")
8.0^22.0
**INSTALL NAME**
DG*5.3*901
"BLD",9601,0)
DG*5.3*901^REGISTRATION^0^3150424^y
"BLD",9601,1,0)
^^3^3^3141124^^
"BLD",9601,1,1,0)
This patch contains changes to the Date of Death application necessary to 
"BLD",9601,1,2,0)
accomodate having the Master Veteran Index become the authoritative 
"BLD",9601,1,3,0)
source for Date of Death data entry.
"BLD",9601,4,0)
^9.64PA^2^1
"BLD",9601,4,2,0)
2
"BLD",9601,4,2,2,0)
^9.641^2^1
"BLD",9601,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",9601,4,2,2,2,1,0)
^9.6411^.353^1
"BLD",9601,4,2,2,2,1,.353,0)
SOURCE OF NOTIFICATION
"BLD",9601,4,2,222)
y^n^p^^^^n^^n
"BLD",9601,4,2,224)

"BLD",9601,4,"APDD",2,2)

"BLD",9601,4,"APDD",2,2,.353)

"BLD",9601,4,"B",2,2)

"BLD",9601,6.3)
28
"BLD",9601,"KRN",0)
^9.67PA^779.2^20
"BLD",9601,"KRN",.4,0)
.4
"BLD",9601,"KRN",.401,0)
.401
"BLD",9601,"KRN",.402,0)
.402
"BLD",9601,"KRN",.403,0)
.403
"BLD",9601,"KRN",.5,0)
.5
"BLD",9601,"KRN",.84,0)
.84
"BLD",9601,"KRN",3.6,0)
3.6
"BLD",9601,"KRN",3.8,0)
3.8
"BLD",9601,"KRN",9.2,0)
9.2
"BLD",9601,"KRN",9.8,0)
9.8
"BLD",9601,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",9601,"KRN",9.8,"NM",1,0)
DGDEATH^^0^B44578937
"BLD",9601,"KRN",9.8,"NM","B","DGDEATH",1)

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

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

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

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

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

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

"BLD",9601,"KRN","B",3.6,3.6)

"BLD",9601,"KRN","B",3.8,3.8)

"BLD",9601,"KRN","B",9.2,9.2)

"BLD",9601,"KRN","B",9.8,9.8)

"BLD",9601,"KRN","B",19,19)

"BLD",9601,"KRN","B",19.1,19.1)

"BLD",9601,"KRN","B",101,101)

"BLD",9601,"KRN","B",409.61,409.61)

"BLD",9601,"KRN","B",771,771)

"BLD",9601,"KRN","B",779.2,779.2)

"BLD",9601,"KRN","B",870,870)

"BLD",9601,"KRN","B",8989.51,8989.51)

"BLD",9601,"KRN","B",8989.52,8989.52)

"BLD",9601,"KRN","B",8994,8994)

"BLD",9601,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",9601,"QUES",0)
^9.62^^
"BLD",9601,"REQB",0)
^9.611^1^1
"BLD",9601,"REQB",1,0)
DG*5.3*863^2
"BLD",9601,"REQB","B","DG*5.3*863",1)

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

"FIA",2,0,11)

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

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

"MBREQ")
0
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
901^3150424
"PKG",47,22,1,"PAH",1,1,0)
^^3^3^3150424
"PKG",47,22,1,"PAH",1,1,1,0)
This patch contains changes to the Date of Death application necessary to 
"PKG",47,22,1,"PAH",1,1,2,0)
accomodate having the Master Veteran Index become the authoritative 
"PKG",47,22,1,"PAH",1,1,3,0)
source for Date of Death data entry.
"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","DGDEATH")
0^1^B44578937
"RTN","DGDEATH",1,0)
DGDEATH ;ALB/MRL,PJR,DJS-PROCESS DECEASED PATIENTS ;10/27/04 9:45pm
"RTN","DGDEATH",2,0)
 ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725,772,863,901**;Aug 13, 1993;Build 28
"RTN","DGDEATH",3,0)
 ;
"RTN","DGDEATH",4,0)
GET N DGMTI,DATA,SON,DGDWHO
"RTN","DGDEATH",5,0)
 S DGDTHEN="" W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S (DA,DFN)=+Y
"RTN","DGDEATH",6,0)
 S DGDOLD=$G(^DPT(DFN,.35))
"RTN","DGDEATH",7,0)
 I $P(DGDOLD,"^",1)="" G CONT
"RTN","DGDEATH",8,0)
 I $P(DGDOLD,"^",1)'="" S DGDWHO=$P($G(DGDOLD),"^",5) I DGDWHO="" G CONT
"RTN","DGDEATH",9,0)
 I ((DGDWHO'="")&(DGDWHO<1))!('$D(^VA(200,DGDWHO))) W !!,"YOU MAY NOT EDIT DATE OF DEATH IF IT WAS NOT ENTERED BY A USER AT THIS SITE" S ^DPT(DFN,.35)=DGDOLD G GET
"RTN","DGDEATH",10,0)
CONT I $D(^DPT(DFN,.1)) W !?3,"Patient is currently in-house.  Discharge him with a discharge type of DEATH." G GET
"RTN","DGDEATH",11,0)
 I $S($D(^DPT(DFN,.35)):^(.35),1:"") F DGY=0:0 S DGY=$O(^DGPM("ATID1",DFN,DGY)) Q:'DGY  S DGDA=$O(^(DGY,0)) I $D(^DGPM(+DGDA,0)),$P(^(0),"^",17)]"" S DGXX=$P(^(0),"^",17),DGXX=^DGPM(DGXX,0) I "^12^38^"[("^"_$P(DGXX,"^",18)_"^") G DIS
"RTN","DGDEATH",12,0)
 D NOW^%DTC S DGNOW=%
"RTN","DGDEATH",13,0)
 S ^TMP("DEATH",$J)=1
"RTN","DGDEATH",14,0)
 K A W ! S DIE=DIC,DR=".351" D ^DIE
"RTN","DGDEATH",15,0)
 I '$D(^DPT(DFN,.35)) K ^TMP("DEATH",$J) G GET
"RTN","DGDEATH",16,0)
 S DGDNEW=^DPT(DFN,.35)
"RTN","DGDEATH",17,0)
 I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE
"RTN","DGDEATH",18,0)
 I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET
"RTN","DGDEATH",19,0)
SN S DGDSON=$P($G(DGDOLD),"^",3)
"RTN","DGDEATH",20,0)
 I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE I $P($G(^DPT(DFN,.35)),"^",3)']"" D SNDISP G SN
"RTN","DGDEATH",21,0)
 S SON=$P($G(^DPT(DFN,.35)),"^",3) I DGDSON=SON!(SON="")!(SON="^") G SN1
"RTN","DGDEATH",22,0)
 I SON'="",SON'="^",SON'=1,SON'=3,SON'=7 W !!,"INVALID SOURCE OF NOTIFICATION. PLEASE CHOOSE 1, 3, OR 7" D SNDISP G SN
"RTN","DGDEATH",23,0)
SN1 I DGDOLD'=DGDNEW D DISCHRGE
"RTN","DGDEATH",24,0)
 I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR
"RTN","DGDEATH",25,0)
 K ^TMP("DEATH",$J) G GET
"RTN","DGDEATH",26,0)
 ;
"RTN","DGDEATH",27,0)
DIS W !,"Patient has a discharge type of Death",!,"Edit the discharge",!
"RTN","DGDEATH",28,0)
Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN,DGDOLD,DGDNEW,DGDONOT Q
"RTN","DGDEATH",29,0)
XFR ; called from set x-ref of field .351 of file 2
"RTN","DGDEATH",30,0)
 N DGPCMM,DGFAPT,DGFAPTI,DGFAPT1
"RTN","DGDEATH",31,0)
 Q:'$D(DFN)
"RTN","DGDEATH",32,0)
 K DGTEXT D ^DGPATV S DGDEATH=$$GET1^DIQ(2,DFN,.351,"I"),XMSUB="PATIENT HAS EXPIRED",DGCT=0
"RTN","DGDEATH",33,0)
 D DEMOG
"RTN","DGDEATH",34,0)
 S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGPMSTAT
"RTN","DGDEATH",35,0)
 S Y=$$FMTE^XLFDT(Y),Y=$S(Y]"":Y,1:"UNKNOWN")
"RTN","DGDEATH",36,0)
 S DGDONOT=0 D APTT3
"RTN","DGDEATH",37,0)
 D LINE("")
"RTN","DGDEATH",38,0)
 D LINE("      Date/Time of Death: "_DEATHVAL_$S(DGDONOT:"",'DG1:"",$D(DGDTHEN):"",1:"  (While an inpatient)"))
"RTN","DGDEATH",39,0)
 D LINE("")
"RTN","DGDEATH",40,0)
 I '$D(ADM),DG1,$D(^DGPM(+DGA1,0)) S ADM=+^DGPM($P(^(0),"^",14),0)
"RTN","DGDEATH",41,0)
 S Y=$$FMTE^XLFDT($S($D(ADM):ADM,1:""))
"RTN","DGDEATH",42,0)
 D LINE($S($D(DGDTHEN):"",DG1:"     Admission Date/Time: "_Y_$S((DGDDT-ADM)<1:"  (Within 24 hours of hospitalization)",1:""),1:""))
"RTN","DGDEATH",43,0)
 D LINE("")
"RTN","DGDEATH",44,0)
 S DGX=$P($G(^DGPM(+$G(DGA1),0)),"^",6),DGX=$P($G(^DIC(42,+DGX,0)),U,1)
"RTN","DGDEATH",45,0)
 D LINE($S($D(DGDTHEN):"",('DG1):"",$D(DGA1):"             Admitted To: "_$S(DGX]"":DGX,1:"UNKNOWN"),1:"")) K DGX
"RTN","DGDEATH",46,0)
 D LINE("")
"RTN","DGDEATH",47,0)
 I DG1&'$D(DGDTHEN) D 
"RTN","DGDEATH",48,0)
 . D LINE($S($D(DGXFR0):"           Last Transfer: "_$S($D(^DIC(42,+$P(DGXFR0,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN"),1:""))
"RTN","DGDEATH",49,0)
 . D LINE("")
"RTN","DGDEATH",50,0)
F N DGARRAY,SDCNT S DGFAPT=DGDEATH,DGFAPTI=""
"RTN","DGDEATH",51,0)
 S DGARRAY("FLDS")=3,DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY(1)=DT,DGARRAY(3)="I;R"
"RTN","DGDEATH",52,0)
 S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
"RTN","DGDEATH",53,0)
 ;
"RTN","DGDEATH",54,0)
 I SDCNT>0 F  S DGFAPT=$O(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:'DGFAPT  S DGFAPT1=$G(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:DGFAPT1']""  D  Q:DGFAPTI
"RTN","DGDEATH",55,0)
 .I $P($P(DGFAPT1,U,3),";")'["C" D LINE("NOTE: Patient has future appointments scheduled!!") S DGFAPTI=1
"RTN","DGDEATH",56,0)
 S DGSCHAD=0 D SA I DGSCHAD D LINE("NOTE: Patient had scheduled admissions which have been cancelled!!")
"RTN","DGDEATH",57,0)
 I 'DGVETS D LINE("Patient is a NON-VETERAN."_$S($D(^DIC(21,+$P($G(^DPT(DFN,.32)),"^",3),0)):"  ["_$P(^(0),"^",1)_"]",1:""))
"RTN","DGDEATH",58,0)
 S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
"RTN","DGDEATH",59,0)
 S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
"RTN","DGDEATH",60,0)
Q1 S DGB=1 D ^DGBUL S X=DGDEATH
"RTN","DGDEATH",61,0)
 K DGDEATH,DGSCHAD,DGI,Y,DGDDT,^TMP($J,"SDAMA301") D KILL^DGPATV K ADM,DG1,DGA1,DGCT,DGT,DGXX,DGY,Z Q
"RTN","DGDEATH",62,0)
SA F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI  I $D(^DGS(41.1,DGI,0)),($P(^(0),"^",13)']""),($P(^(0),"^",17)']"") S $P(^(0),"^",13)=DGDEATH,$P(^(0),"^",14)=+DUZ,$P(^(0),"^",15)=1,$P(^(0),"^",16)=2,DGSCHAD=1
"RTN","DGDEATH",63,0)
 Q
"RTN","DGDEATH",64,0)
 ;
"RTN","DGDEATH",65,0)
DEL ; delete death bulletin
"RTN","DGDEATH",66,0)
 N DGPCMM,DELBY,DELTM,DTHINFO
"RTN","DGDEATH",67,0)
 S DFN=+$G(DA) I '$D(^DPT(DFN,0)) Q  ; no patient node
"RTN","DGDEATH",68,0)
 I +$G(^DPT(DFN,.35)) Q  ; not deletion
"RTN","DGDEATH",69,0)
 S DGDEATH=X,XMSUB="Patient Death has been Deleted",DGCT=0
"RTN","DGDEATH",70,0)
 D ^DGPATV
"RTN","DGDEATH",71,0)
 D LINE("The date of death for the following patient has been deleted.")
"RTN","DGDEATH",72,0)
 D LINE("")
"RTN","DGDEATH",73,0)
 D DEMOG
"RTN","DGDEATH",74,0)
 D LINE("")
"RTN","DGDEATH",75,0)
 S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
"RTN","DGDEATH",76,0)
 S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
"RTN","DGDEATH",77,0)
 S DGB=1 D ^DGBUL S X=DGDEATH
"RTN","DGDEATH",78,0)
 K DGCT,DGDEATH D KILL^DGPATV
"RTN","DGDEATH",79,0)
 Q
"RTN","DGDEATH",80,0)
 ;
"RTN","DGDEATH",81,0)
DEMOG ; list main demographics
"RTN","DGDEATH",82,0)
 D LINE("                    NAME: "_DGNAME)
"RTN","DGDEATH",83,0)
 D LINE("                     SSN: "_$P(SSN,"^",2))
"RTN","DGDEATH",84,0)
 D LINE("                     DOB: "_$P(DOB,"^",2))
"RTN","DGDEATH",85,0)
 I DGVETS D
"RTN","DGDEATH",86,0)
 . N DGX
"RTN","DGDEATH",87,0)
 . S DGX=$G(^DPT(DFN,.31))
"RTN","DGDEATH",88,0)
 . S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGX,U,4)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
"RTN","DGDEATH",89,0)
 . D LINE("   CLAIM FOLDER LOCATION: "_$S($D(DGLOCATN):DGLOCATN,1:"NOT LISTED"))
"RTN","DGDEATH",90,0)
 . D LINE("            CLAIM NUMBER: "_$S($P(DGX,"^",3)]"":$P(DGX,"^",3),1:"NOT LISTED"))
"RTN","DGDEATH",91,0)
 ;D LINE("   COORDINATING MASTER OF RECORD: "_DGCMOR)  ;**863 - MVI_2351 (ptd)
"RTN","DGDEATH",92,0)
 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","DTHINFO")
"RTN","DGDEATH",93,0)
 S DEATHVAL=$G(DTHINFO(2,DFN_",",.351,"E"))
"RTN","DGDEATH",94,0)
 S DEATHVAL=$$FMTE^XLFDT(DEATHVAL),DEATHVAL=$S(DEATHVAL]"":DEATHVAL,1:"UNKNOWN")
"RTN","DGDEATH",95,0)
 S SOURCE=$G(DTHINFO(2,DFN_",",.353,"E"))
"RTN","DGDEATH",96,0)
 S DELTM=$G(DTHINFO(2,DFN_",",.354,"E"))
"RTN","DGDEATH",97,0)
 S DELBY=$G(DTHINFO(2,DFN_",",.355,"E"))
"RTN","DGDEATH",98,0)
 D LINE("")
"RTN","DGDEATH",99,0)
 D LINE("             LAST EDITED BY: "_DELBY)
"RTN","DGDEATH",100,0)
 D LINE("    DATE/TIME LAST MODIFIED: "_DELTM)
"RTN","DGDEATH",101,0)
 D LINE("     SOURCE OF NOTIFICATION: "_$S(SOURCE="":"UNDEFINED",1:SOURCE))
"RTN","DGDEATH",102,0)
 ;K DEATHVAL,SOURCE,DELTM,DELBY
"RTN","DGDEATH",103,0)
 Q
"RTN","DGDEATH",104,0)
 ;
"RTN","DGDEATH",105,0)
LINE(X) ; add line contained in X to array
"RTN","DGDEATH",106,0)
 S DGCT=DGCT+1
"RTN","DGDEATH",107,0)
 S DGTEXT(DGCT,0)=X
"RTN","DGDEATH",108,0)
 Q
"RTN","DGDEATH",109,0)
DSBULL ;
"RTN","DGDEATH",110,0)
 ;
"RTN","DGDEATH",111,0)
 I $G(IVMDODUP)=1 Q
"RTN","DGDEATH",112,0)
 S DFN=DA
"RTN","DGDEATH",113,0)
 I $D(DGPMDA) D  Q
"RTN","DGDEATH",114,0)
 .S DISTYPE=$P($G(^DGPM(DGPMDA,0)),"^",18)
"RTN","DGDEATH",115,0)
 .I $G(^DG(405.2,DISTYPE,0))["DEATH" D
"RTN","DGDEATH",116,0)
 ..S FDA(2,DFN_",",.353)=1 D FILE^DIE(,"FDA","BWFERR")
"RTN","DGDEATH",117,0)
 ..D DISCHRGE,XFR
"RTN","DGDEATH",118,0)
 I $D(^TMP("DEATH",$J)) Q
"RTN","DGDEATH",119,0)
 D DISCHRGE,XFR
"RTN","DGDEATH",120,0)
 Q
"RTN","DGDEATH",121,0)
DKBULL ;
"RTN","DGDEATH",122,0)
 S DFN=DA
"RTN","DGDEATH",123,0)
 S FDA(2,DFN_",",.353)="@"
"RTN","DGDEATH",124,0)
 I $D(^TMP("DEATH",$J)) S FDA(2,DFN_",",.355)=DUZ
"RTN","DGDEATH",125,0)
 D FILE^DIE(,"FDA",)
"RTN","DGDEATH",126,0)
 D DEL
"RTN","DGDEATH",127,0)
 Q
"RTN","DGDEATH",128,0)
DISCHRGE ;
"RTN","DGDEATH",129,0)
 ; If the patient is being discharged, determine values needed for 
"RTN","DGDEATH",130,0)
 ; Source of Notification and Date/Time last entered.
"RTN","DGDEATH",131,0)
 ;
"RTN","DGDEATH",132,0)
 I '$D(DGNOW) S DGNOW=$$HTFM^XLFDT($H)
"RTN","DGDEATH",133,0)
 I $G(DGDAUTO)'=1 S FDA(2,DFN_",",.354)=DGNOW
"RTN","DGDEATH",134,0)
 S FDA(2,DFN_",",.355)=DUZ
"RTN","DGDEATH",135,0)
 D FILE^DIE(,"FDA",)
"RTN","DGDEATH",136,0)
 Q
"RTN","DGDEATH",137,0)
APTT3 ;Check to exclude "While an Inpatient" from DOD Bulletin
"RTN","DGDEATH",138,0)
 ; Input:  DFN  Output: DGDONOT
"RTN","DGDEATH",139,0)
 N DATE,XIEN,TYPE,XDOD,YES
"RTN","DGDEATH",140,0)
 S DGDONOT=0
"RTN","DGDEATH",141,0)
 S XDOD=$P($G(^DPT(DFN,.35)),"^",1) I 'XDOD Q
"RTN","DGDEATH",142,0)
 S XDOD=$P(XDOD,".",1),YES=0,TYPE=""
"RTN","DGDEATH",143,0)
 I '$D(^DGPM("APTT3",DFN)) Q
"RTN","DGDEATH",144,0)
 S DATE=$O(^DGPM("APTT3",DFN,XDOD)) I 'DATE Q
"RTN","DGDEATH",145,0)
 I $P(DATE,".",1)=XDOD S YES=1
"RTN","DGDEATH",146,0)
 I ($P(DATE,".",1)-1)=XDOD S YES=1
"RTN","DGDEATH",147,0)
 S XIEN=$O(^DGPM("APTT3",DFN,DATE,"")) I 'XIEN Q
"RTN","DGDEATH",148,0)
 S TYPE=$P($G(^DGPM(XIEN,0)),"^",4)
"RTN","DGDEATH",149,0)
 I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1
"RTN","DGDEATH",150,0)
 Q
"RTN","DGDEATH",151,0)
SNDISP ; Source of Notification display choices
"RTN","DGDEATH",152,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT,DGLIST,DGLNAME,I,X,Y
"RTN","DGDEATH",153,0)
 S DGLIST=$P($G(^DD(2,.353,0)),"^",3)
"RTN","DGDEATH",154,0)
 S Y=5
"RTN","DGDEATH",155,0)
 S DIR("?",1)=" "
"RTN","DGDEATH",156,0)
 S DIR("?",2)=" This is a required response. Please select from the following:"
"RTN","DGDEATH",157,0)
 S DIR("?",3)=" Entering '^' will take you back to the Source of Notification prompt"
"RTN","DGDEATH",158,0)
 S DIR("?",4)=" "
"RTN","DGDEATH",159,0)
 F X=1:1 S DGLNAME=$P(DGLIST,";",X) Q:DGLNAME']""  S DIR("?",Y)="      "_$P(DGLNAME,":",1)_"      "_$P(DGLNAME,":",2) S Y=Y+1
"RTN","DGDEATH",160,0)
 S DIR("?",Y)=" "
"RTN","DGDEATH",161,0)
 F I=1:1:5,7,11 Q:'$D(DIR("?",I))  W !,DIR("?",I)
"RTN","DGDEATH",162,0)
 Q
"VER")
8.0^22.0
"^DD",2,2,.353,0)
SOURCE OF NOTIFICATION^*S^1:INPATIENT AT VAMC;2:NON-VA MEDICAL FACILITY;3:DEATH CERTIFICATE ON FILE;4:VBA;5:VA INSURANCE;6:SSA;7:NCA;8:NEXT OF KIN/FAMILY/FRIEND;9:OTHER;^.35;3^Q
"^DD",2,2,.353,1,0)
^.1^^0
"^DD",2,2,.353,1,1,0)
2^AENR353^MUMPS
"^DD",2,2,.353,1,1,1)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.353,1,1,2)
D EVENT^IVMPLOG(DA)
"^DD",2,2,.353,1,1,3)
 DO NOT DELETE
"^DD",2,2,.353,1,1,"%D",0)
^.101^2^2^3050608^^^^
"^DD",2,2,.353,1,1,"%D",1,0)
This cross-reference is used to notify HEC of changes that may affect
"^DD",2,2,.353,1,1,"%D",2,0)
enrollment.
"^DD",2,2,.353,1,1,"DT")
3050608
"^DD",2,2,.353,3)
Select the first source of death that appears on the list that applies to this veteran.
"^DD",2,2,.353,12)
The following are valid Sources of Notification.
"^DD",2,2,.353,12.1)
S DIC("S")="I ""1^3^7""[Y"
"^DD",2,2,.353,21,0)
^.001^2^2^3141215^^^^
"^DD",2,2,.353,21,1,0)
This is a set of codes that represents who/what notified the VA of 
"^DD",2,2,.353,21,2,0)
the Date of Death.
"^DD",2,2,.353,"DT")
3141215
**INSTALL NAME**
DG*5.3*906
"BLD",9596,0)
DG*5.3*906^REGISTRATION^0^3150424^y
"BLD",9596,4,0)
^9.64PA^27.11^1
"BLD",9596,4,27.11,0)
27.11
"BLD",9596,4,27.11,2,0)
^9.641^27.11^1
"BLD",9596,4,27.11,2,27.11,0)
PATIENT ENROLLMENT  (File-top level)
"BLD",9596,4,27.11,2,27.11,1,0)
^9.6411^.05^1
"BLD",9596,4,27.11,2,27.11,1,.05,0)
REASON CANCELED/DECLINED
"BLD",9596,4,27.11,222)
y^y^p^^^^n^^n
"BLD",9596,4,27.11,224)

"BLD",9596,4,"APDD",27.11,27.11)

"BLD",9596,4,"APDD",27.11,27.11,.05)

"BLD",9596,4,"B",27.11,27.11)

"BLD",9596,6.3)
24
"BLD",9596,"ABPKG")
n
"BLD",9596,"KRN",0)
^9.67PA^779.2^20
"BLD",9596,"KRN",.4,0)
.4
"BLD",9596,"KRN",.401,0)
.401
"BLD",9596,"KRN",.402,0)
.402
"BLD",9596,"KRN",.403,0)
.403
"BLD",9596,"KRN",.5,0)
.5
"BLD",9596,"KRN",.84,0)
.84
"BLD",9596,"KRN",3.6,0)
3.6
"BLD",9596,"KRN",3.8,0)
3.8
"BLD",9596,"KRN",9.2,0)
9.2
"BLD",9596,"KRN",9.8,0)
9.8
"BLD",9596,"KRN",19,0)
19
"BLD",9596,"KRN",19.1,0)
19.1
"BLD",9596,"KRN",101,0)
101
"BLD",9596,"KRN",409.61,0)
409.61
"BLD",9596,"KRN",771,0)
771
"BLD",9596,"KRN",779.2,0)
779.2
"BLD",9596,"KRN",870,0)
870
"BLD",9596,"KRN",8989.51,0)
8989.51
"BLD",9596,"KRN",8989.52,0)
8989.52
"BLD",9596,"KRN",8994,0)
8994
"BLD",9596,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",9596,"KRN","B",3.6,3.6)

"BLD",9596,"KRN","B",3.8,3.8)

"BLD",9596,"KRN","B",9.2,9.2)

"BLD",9596,"KRN","B",9.8,9.8)

"BLD",9596,"KRN","B",19,19)

"BLD",9596,"KRN","B",19.1,19.1)

"BLD",9596,"KRN","B",101,101)

"BLD",9596,"KRN","B",409.61,409.61)

"BLD",9596,"KRN","B",771,771)

"BLD",9596,"KRN","B",779.2,779.2)

"BLD",9596,"KRN","B",870,870)

"BLD",9596,"KRN","B",8989.51,8989.51)

"BLD",9596,"KRN","B",8989.52,8989.52)

"BLD",9596,"KRN","B",8994,8994)

"BLD",9596,"QUES",0)
^9.62^^
"BLD",9596,"REQB",0)
^9.611^^
"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,.05)

"MBREQ")
0
"PKG",47,-1)
1^1
"PKG",47,0)
REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER 
"PKG",47,20,0)
^9.402P^^
"PKG",47,22,0)
^9.49I^1^1
"PKG",47,22,1,0)
5.3^2930813^2960613
"PKG",47,22,1,"PAH",1,0)
906^3150424
"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
"VER")
8.0^22.0
"^DD",27.11,27.11,.05,0)
REASON CANCELED/DECLINED^S^1:DISSATISFIED WITH CARE;2:GEOGRAPHIC ACCESS;3:OTHER INSURANCE;4:OTHER;5:ACA PREFERENCE;^0;5^Q
"^DD",27.11,27.11,.05,3)
Enter the reason the veteran is declining or cancelling enrollment.
"^DD",27.11,27.11,.05,21,0)
^.001^2^2^3140919^^
"^DD",27.11,27.11,.05,21,1,0)
When a patient self dis-enrolls or requests that his enrollment be ceased, s/he
"^DD",27.11,27.11,.05,21,2,0)
is asked to give a reason.
"^DD",27.11,27.11,.05,"DT")
3140919
**END**
**END**