DG_53_P858.KID

KIDS Distribution saved on Dec 19, 2013@11:51:09
Discontinue Annual Means Test Renewal VistA changes.
**KIDS**:DG*5.3*858^EAS*1.0*106^IVM*2.0*154^DGBT*1.0*24^IB*2.0*385^

**INSTALL NAME**
DG*5.3*858
"BLD",8436,0)
DG*5.3*858^REGISTRATION^0^3131219^y
"BLD",8436,1,0)
^^3^3^3120830^
"BLD",8436,1,1,0)
This patch contains VistA changes to support technology and business
"BLD",8436,1,2,0)
changes that are occurring with the implementation of Discontinue
"BLD",8436,1,3,0)
Annual Means Test Renewal.
"BLD",8436,4,0)
^9.64PA^43^1
"BLD",8436,4,43,0)
43
"BLD",8436,4,43,2,0)
^9.641^43^1
"BLD",8436,4,43,2,43,0)
MAS PARAMETERS  (File-top level)
"BLD",8436,4,43,2,43,1,0)
^9.6411^1205^1
"BLD",8436,4,43,2,43,1,1205,0)
VFA START DATE
"BLD",8436,4,43,222)
y^n^p^^^^n^^n
"BLD",8436,4,43,224)

"BLD",8436,4,"APDD",43,43)

"BLD",8436,4,"APDD",43,43,1205)

"BLD",8436,4,"B",43,43)

"BLD",8436,6.3)
30
"BLD",8436,"ABPKG")
n
"BLD",8436,"INID")
^y
"BLD",8436,"INIT")
DG53858P
"BLD",8436,"KRN",0)
^9.67PA^779.2^20
"BLD",8436,"KRN",.4,0)
.4
"BLD",8436,"KRN",.401,0)
.401
"BLD",8436,"KRN",.402,0)
.402
"BLD",8436,"KRN",.403,0)
.403
"BLD",8436,"KRN",.5,0)
.5
"BLD",8436,"KRN",.84,0)
.84
"BLD",8436,"KRN",3.6,0)
3.6
"BLD",8436,"KRN",3.8,0)
3.8
"BLD",8436,"KRN",9.2,0)
9.2
"BLD",8436,"KRN",9.8,0)
9.8
"BLD",8436,"KRN",9.8,"NM",0)
^9.68A^10^10
"BLD",8436,"KRN",9.8,"NM",1,0)
DGMTR^^0^B70325698
"BLD",8436,"KRN",9.8,"NM",2,0)
DGMTR1^^0^B32852422
"BLD",8436,"KRN",9.8,"NM",3,0)
DGMTU^^0^B55660004
"BLD",8436,"KRN",9.8,"NM",4,0)
DGMTU4^^0^B73029877
"BLD",8436,"KRN",9.8,"NM",5,0)
DGRPC2^^0^B71389194
"BLD",8436,"KRN",9.8,"NM",6,0)
DGMTE^^0^B27294301
"BLD",8436,"KRN",9.8,"NM",7,0)
DGMTCOR^^0^B36225262
"BLD",8436,"KRN",9.8,"NM",8,0)
DGMTEO^^0^B13226436
"BLD",8436,"KRN",9.8,"NM",9,0)
DGMTHL1^^0^B64633533
"BLD",8436,"KRN",9.8,"NM",10,0)
DGMTCOU1^^0^B13152902
"BLD",8436,"KRN",9.8,"NM","B","DGMTCOR",7)

"BLD",8436,"KRN",9.8,"NM","B","DGMTCOU1",10)

"BLD",8436,"KRN",9.8,"NM","B","DGMTE",6)

"BLD",8436,"KRN",9.8,"NM","B","DGMTEO",8)

"BLD",8436,"KRN",9.8,"NM","B","DGMTHL1",9)

"BLD",8436,"KRN",9.8,"NM","B","DGMTR",1)

"BLD",8436,"KRN",9.8,"NM","B","DGMTR1",2)

"BLD",8436,"KRN",9.8,"NM","B","DGMTU",3)

"BLD",8436,"KRN",9.8,"NM","B","DGMTU4",4)

"BLD",8436,"KRN",9.8,"NM","B","DGRPC2",5)

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

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

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

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

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

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

"BLD",8436,"KRN","B",3.6,3.6)

"BLD",8436,"KRN","B",3.8,3.8)

"BLD",8436,"KRN","B",9.2,9.2)

"BLD",8436,"KRN","B",9.8,9.8)

"BLD",8436,"KRN","B",19,19)

"BLD",8436,"KRN","B",19.1,19.1)

"BLD",8436,"KRN","B",101,101)

"BLD",8436,"KRN","B",409.61,409.61)

"BLD",8436,"KRN","B",771,771)

"BLD",8436,"KRN","B",779.2,779.2)

"BLD",8436,"KRN","B",870,870)

"BLD",8436,"KRN","B",8989.51,8989.51)

"BLD",8436,"KRN","B",8989.52,8989.52)

"BLD",8436,"KRN","B",8994,8994)

"BLD",8436,"QDEF")
^^^^^^^^^^YES
"BLD",8436,"QUES",0)
^9.62^^
"BLD",8436,"REQB",0)
^9.611^6^6
"BLD",8436,"REQB",1,0)
DG*5.3*536^2
"BLD",8436,"REQB",2,0)
DG*5.3*624^2
"BLD",8436,"REQB",3,0)
DG*5.3*797^2
"BLD",8436,"REQB",4,0)
DG*5.3*834^2
"BLD",8436,"REQB",5,0)
DG*5.3*841^2
"BLD",8436,"REQB",6,0)
DG*5.3*658^2
"BLD",8436,"REQB","B","DG*5.3*536",1)

"BLD",8436,"REQB","B","DG*5.3*624",2)

"BLD",8436,"REQB","B","DG*5.3*658",6)

"BLD",8436,"REQB","B","DG*5.3*797",3)

"BLD",8436,"REQB","B","DG*5.3*834",4)

"BLD",8436,"REQB","B","DG*5.3*841",5)

"FIA",43)
MAS PARAMETERS
"FIA",43,0)
^DG(43,
"FIA",43,0,0)
43
"FIA",43,0,1)
y^n^p^^^^n^^n
"FIA",43,0,10)

"FIA",43,0,11)

"FIA",43,0,"RLRO")

"FIA",43,0,"VR")
5.3^DG
"FIA",43,43)
1
"FIA",43,43,1205)

"INIT")
DG53858P
"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)
858^3131219^100992
"PKG",47,22,1,"PAH",1,1,0)
^^3^3^3131219
"PKG",47,22,1,"PAH",1,1,1,0)
This patch contains VistA changes to support technology and business
"PKG",47,22,1,"PAH",1,1,2,0)
changes that are occurring with the implementation of Discontinue
"PKG",47,22,1,"PAH",1,1,3,0)
Annual Means Test Renewal.
"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")
11
"RTN","DG53858P")
0^^B233052
"RTN","DG53858P",1,0)
DG53858P ;ALB/BDB - VFA PROJECT POST-INSTALL;8/30/12
"RTN","DG53858P",2,0)
 ;;5.3;Registration;**858**;Aug 13, 1993;Build 30
"RTN","DG53858P",3,0)
 ;
"RTN","DG53858P",4,0)
 ; This routine will set the VFA Start Date into the
"RTN","DG53858P",5,0)
 ;  MAS PARAMETERS file (#43)
"RTN","DG53858P",6,0)
 ;
"RTN","DG53858P",7,0)
EN ; Entry point for post-install
"RTN","DG53858P",8,0)
 D VFA
"RTN","DG53858P",9,0)
 Q
"RTN","DG53858P",10,0)
 ;
"RTN","DG53858P",11,0)
VFA ; Set the VFA Start Date equal to January 1, 2013
"RTN","DG53858P",12,0)
 D BMES^XPDUTL(">>>VFA Start Date set to January 1, 2013.")
"RTN","DG53858P",13,0)
 S ^DG(43,1,"VFA")="3130101"
"RTN","DG53858P",14,0)
 Q
"RTN","DG53858P",15,0)
 ;
"RTN","DGMTCOR")
0^7^B36225262
"RTN","DGMTCOR",1,0)
DGMTCOR ;ALB/CAW,SCG,LBD,TMK - Check Copay Test Requirements;07/28/08
"RTN","DGMTCOR",2,0)
 ;;5.3;Registration;**21,45,182,290,305,330,344,495,564,773,840,858**;Aug 13, 1993;Build 30
"RTN","DGMTCOR",3,0)
 ;
"RTN","DGMTCOR",4,0)
 ;A patient may apply for a copay test under the following conditions:
"RTN","DGMTCOR",5,0)
 ;  - Applicant is a veteran
"RTN","DGMTCOR",6,0)
 ;  - Applicant's primary or other eligibility does NOT contain
"RTN","DGMTCOR",7,0)
 ;    - Service Connected 50% to 100% or
"RTN","DGMTCOR",8,0)
 ;    - Aid and Attendance or
"RTN","DGMTCOR",9,0)
 ;    - Housebound or
"RTN","DGMTCOR",10,0)
 ;    - VA Pension
"RTN","DGMTCOR",11,0)
 ;    - Catastrophically Disabled
"RTN","DGMTCOR",12,0)
 ;  - Primary Eligibility is NSC
"RTN","DGMTCOR",13,0)
 ;    - who has NOT been means tested
"RTN","DGMTCOR",14,0)
 ;    - who claims exposure to agent orange or ionizing radiation
"RTN","DGMTCOR",15,0)
 ;    - who is eligible for medicaid
"RTN","DGMTCOR",16,0)
 ;  - Applicants who have answered 'no' to Receiving A&A, HB, or Pension
"RTN","DGMTCOR",17,0)
 ;  - Applicants who have previously qualified and applied for a copay 
"RTN","DGMTCOR",18,0)
 ;      exemption, still qualify and have NOT been copay tested in the
"RTN","DGMTCOR",19,0)
 ;      past year
"RTN","DGMTCOR",20,0)
 ;  - Applicants who are not currently a DOM patient or inpatient
"RTN","DGMTCOR",21,0)
 ;      (they are temporarily exempt from copay testing) DG*5.3*290
"RTN","DGMTCOR",22,0)
 ;  - Applicants who do not have POW eligibility (DG*5.3*564 - HVE III)
"RTN","DGMTCOR",23,0)
 ;  - Applicants who do not meet criteria for Unemployable: 
"RTN","DGMTCOR",24,0)
 ;      Unemployable="Y", SC%>0, not receiving A&A, HB or Pension, and
"RTN","DGMTCOR",25,0)
 ;      Total VA Check Amount>0  (DG*5.3*564 - HVE III) 
"RTN","DGMTCOR",26,0)
 ;
"RTN","DGMTCOR",27,0)
 ; Input  -- DFN     Patient IEN
"RTN","DGMTCOR",28,0)
 ;           DGADDF  Means Test Add Flag (optional)
"RTN","DGMTCOR",29,0)
 ;           DGNOIVMUPD Do Not Update IVM Copay Test Flag (optional)
"RTN","DGMTCOR",30,0)
 ; Output -- DGMTCOR  Copay Test Flag
"RTN","DGMTCOR",31,0)
 ;                   (1 if eligible and 0 if not eligible)
"RTN","DGMTCOR",32,0)
 ;
"RTN","DGMTCOR",33,0)
 ;
"RTN","DGMTCOR",34,0)
EN ;
"RTN","DGMTCOR",35,0)
 Q:$G(VAFCA08)=1
"RTN","DGMTCOR",36,0)
 N DGMTI,DGMTYPT,DGMDOD
"RTN","DGMTCOR",37,0)
 D ON^DGMTCOU G:'Y ENQ
"RTN","DGMTCOR",38,0)
 S DGRGAUTO=1 ;possible change in cp status w/o call to cp event driver
"RTN","DGMTCOR",39,0)
 D CHK
"RTN","DGMTCOR",40,0)
 ;
"RTN","DGMTCOR",41,0)
 Q:($G(DGWRT)=8)!($G(DGWRT)=9)   ;brm;quit if inpatient or dom;DG*5.3*290
"RTN","DGMTCOR",42,0)
 S IVMZ10F=+$G(IVMZ10F)
"RTN","DGMTCOR",43,0)
 I 'DGMTCOR,'$G(DGADDF),'$G(DGMDOD),'IVMZ10F D NLA
"RTN","DGMTCOR",44,0)
 I DGMTCOR,'$G(DGADDF),'$G(DGMDOD) D INC
"RTN","DGMTCOR",45,0)
 I DGRGAUTO&'$G(DGADDF) D QREGAUTO ;if cp event driver not fired off & NOT a new means test
"RTN","DGMTCOR",46,0)
 ;
"RTN","DGMTCOR",47,0)
ENQ Q
"RTN","DGMTCOR",48,0)
 ;
"RTN","DGMTCOR",49,0)
CHK N STATUS,DGELIG,DGE,DGI,DGNODE,DGMDOD,DGMTDT,DGMTI,DGMTL
"RTN","DGMTCOR",50,0)
 S DGMTCOR=1,DGMT="",DGMTYPT=2
"RTN","DGMTCOR",51,0)
 I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0,DGWRT=1 G CHKQ ;NON-VET
"RTN","DGMTCOR",52,0)
 ;Added with DG*5.3*344
"RTN","DGMTCOR",53,0)
 S DGMTL=$$LST^DGMTU(DFN),DGMTI=+DGMTL,DGMTDT=$P(DGMTL,U,2)
"RTN","DGMTCOR",54,0)
 S DGMDOD=$P($G(^DPT(DFN,.35)),U)
"RTN","DGMTCOR",55,0)
 I 'DGMTI,$G(DGMDOD) S DGMTCOR=0 Q
"RTN","DGMTCOR",56,0)
 I DGMDOD,(DGMTCOR),(DGMTDT>(DGMDOD-1)) S DGMTCOR=0 G CHKQ
"RTN","DGMTCOR",57,0)
 ;
"RTN","DGMTCOR",58,0)
 I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0,DGWRT=2 G CHKQ  ;NO PRIM ELIG
"RTN","DGMTCOR",59,0)
 I +$G(DGMDOD) S DGNOCOPF=1
"RTN","DGMTCOR",60,0)
 ;
"RTN","DGMTCOR",61,0)
 ;This doesn't work! The "AEL" x-ref not there when changing the primary
"RTN","DGMTCOR",62,0)
 ;eligibility! Problem with order that the cross-references are called
"RTN","DGMTCOR",63,0)
 ;in, DGMTR is called before the "AEL" x-ref is set!
"RTN","DGMTCOR",64,0)
 ;F  S DGMTI=$O(^DPT("AEL",DFN,DGMTI)) Q:'DGMTI  S DGMTE=$P($G(^DIC(8,DGMTI,0)),U,9) I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0,DGWRT=3 G CHKQ
"RTN","DGMTCOR",65,0)
 ;
"RTN","DGMTCOR",66,0)
 ;
"RTN","DGMTCOR",67,0)
 S DGI=$P($G(^DPT(DFN,.36)),"^"),DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U
"RTN","DGMTCOR",68,0)
 S DGI=0 F  S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI  S DGE=$P($G(^DPT(DFN,"E",DGI,0)),U),DGELIG=DGELIG_$P($G(^DIC(8,+DGE,0)),U,9)_U
"RTN","DGMTCOR",69,0)
 I (DGELIG["^1^") S DGMTCOR=0,DGWRT=3 G CHKQ  ;SC 50-100%
"RTN","DGMTCOR",70,0)
 F DGI=.3,.362,.39,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) ;DG*5.3*840
"RTN","DGMTCOR",71,0)
 I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0,DGWRT=5 G CHKQ ;A&A
"RTN","DGMTCOR",72,0)
 I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0,DGWRT=6 G CHKQ ;HB
"RTN","DGMTCOR",73,0)
 I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0,DGWRT=7 G CHKQ ;PENSION
"RTN","DGMTCOR",74,0)
 I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0,DGWRT=10 G CHKQ ;POW (DG*5.3*564)
"RTN","DGMTCOR",75,0)
 I $P(DGNODE(.39),U,6)["Y"!(DGELIG["^21^") S DGMTCOR=0,DGWRT=12 G CHKQ ;CD (DG*5.3*840
"RTN","DGMTCOR",76,0)
 I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0,DGWRT=11 G CHKQ ;UNEMPLOYABLE (DG*5.3*564)
"RTN","DGMTCOR",77,0)
 ;brm added next 3 lines for DG*5.3*290
"RTN","DGMTCOR",78,0)
 N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR,NOW
"RTN","DGMTCOR",79,0)
 D DOM^DGMTR I $G(DGDOM) S DGMTCOR=0,DGRGAUTO=0,DGWRT=8 Q        ;DOM
"RTN","DGMTCOR",80,0)
 D IN5^VADPT I $G(VAIP(1))'="" S DGMTCOR=0,DGRGAUTO=0,DGWRT=9 Q  ;INP
"RTN","DGMTCOR",81,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTCOR",82,0)
 I DGMTI,'$$OLDMTPF^DGMTU4(DGMTDT) S STATUS=$P($G(^DGMT(408.31,+DGMTI,0)),U,3) I STATUS'="3" S DGMTCOR=0,DGWRT=4 G CHKQ
"RTN","DGMTCOR",83,0)
CHKQ Q
"RTN","DGMTCOR",84,0)
 ;
"RTN","DGMTCOR",85,0)
NLA ; Change Status to NO LONGER APPLICABLE - if appropriate
"RTN","DGMTCOR",86,0)
 ;
"RTN","DGMTCOR",87,0)
 N DGCS,DGMTI,DGMT0,DGINI,DGINR,DGVAL,DGFL,DGFLD,DGIEN,DGMTACT,TDATE
"RTN","DGMTCOR",88,0)
 S DGMTI=+$$LST^DGMTU(DFN,"",2) Q:'DGMTI!($P($G(^DGMT(408.31,DGMTI,0)),U,3)=10)
"RTN","DGMTCOR",89,0)
 ; Do not allow update of IVM test by site
"RTN","DGMTCOR",90,0)
 I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D  Q  ;Check if converted IVM MT
"RTN","DGMTCOR",91,0)
 . ;I '$G(DGMSGF),$G(DGNOIVMUPD)<2 W !,"IVM RX COPAY TEST EXISTS, BUT VISTA CALCULATES 'NO LONGER APPLICABLE'",!,"CONTACT IVM TO CLEAR UP THE DISCREPANCY - YOU CANNOT UPDATE AN IVM TEST"
"RTN","DGMTCOR",92,0)
 . S DGNOIVMUPD=2 ; Prevent double printing of the message
"RTN","DGMTCOR",93,0)
 S DGMT0=$G(^DGMT(408.31,DGMTI,0)) Q:'DGMT0
"RTN","DGMTCOR",94,0)
 S DGCS=$P(DGMT0,U,3)
"RTN","DGMTCOR",95,0)
 S TDATE=+DGMT0
"RTN","DGMTCOR",96,0)
 S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTCOR",97,0)
 ;
"RTN","DGMTCOR",98,0)
 D SAVESTAT^DGMTU4(DGMTI)
"RTN","DGMTCOR",99,0)
 ;
"RTN","DGMTCOR",100,0)
 S DGFL=408.31,DGIEN=DGMTI
"RTN","DGMTCOR",101,0)
 S DGFLD=.03 I DGCS]"" S DGVAL=DGCS D KILL^DGMTR
"RTN","DGMTCOR",102,0)
 S DGVAL=10,$P(^DGMT(408.31,DGMTI,0),"^",3)=DGVAL D SET^DGMTR
"RTN","DGMTCOR",103,0)
 S DGFLD=.17,DGVAL=DT,$P(^DGMT(408.31,DGMTI,0),"^",17)=DT D SET^DGMTR
"RTN","DGMTCOR",104,0)
 W:'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY TEST NO LONGER APPLICABLE"
"RTN","DGMTCOR",105,0)
 D GETINCOM^DGMTU4(DFN,TDATE)
"RTN","DGMTCOR",106,0)
 S DGMTYPT=2 D QUE^DGMTR
"RTN","DGMTCOR",107,0)
 S DGRGAUTO=0
"RTN","DGMTCOR",108,0)
NLAQ Q
"RTN","DGMTCOR",109,0)
 ;
"RTN","DGMTCOR",110,0)
INC ;Update copay status to 'INCOMPLETE' if applicable OR restore completed test
"RTN","DGMTCOR",111,0)
 N DGMTACT,DGMTI,DGFL,DGFLD,DGIEN,DGMTP,DGVAL,DGMT0,AUTOCOMP,ERROR
"RTN","DGMTCOR",112,0)
 S AUTOCOMP=0
"RTN","DGMTCOR",113,0)
 S DGMTI=+$$LST^DGMTU(DFN,"",2)
"RTN","DGMTCOR",114,0)
 D
"RTN","DGMTCOR",115,0)
 .Q:'DGMTI
"RTN","DGMTCOR",116,0)
 .I ($P($G(^DGMT(408.31,DGMTI,0)),U,3)'=10) S AUTOCOMP=1 Q
"RTN","DGMTCOR",117,0)
 .S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGCS=$P(DGMT0,U,3)
"RTN","DGMTCOR",118,0)
 .Q:'DGMT0
"RTN","DGMTCOR",119,0)
 .S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTCOR",120,0)
 .S AUTOCOMP=$$AUTOCOMP^DGMTR(DGMTI)
"RTN","DGMTCOR",121,0)
 .W:'AUTOCOMP&'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY EXEMPTION TEST UPDATED TO INCOMPLETE"
"RTN","DGMTCOR",122,0)
 .W:AUTOCOMP&'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY EXEMPTION TEST UPDATED TO ",$$GETNAME^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),"^",3))
"RTN","DGMTCOR",123,0)
 .S DGMTYPT=2 D QUE^DGMTR
"RTN","DGMTCOR",124,0)
 .S DGRGAUTO=0
"RTN","DGMTCOR",125,0)
 ;
"RTN","DGMTCOR",126,0)
 I $G(IVMZ10)'="UPLOAD IN PROGRESS",$G(DGQSENT)'=1,'AUTOCOMP,'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
"RTN","DGMTCOR",127,0)
 ;
"RTN","DGMTCOR",128,0)
INCQ Q
"RTN","DGMTCOR",129,0)
 ;
"RTN","DGMTCOR",130,0)
QREGAUTO ;Queues off test done by IB recalculating CP status
"RTN","DGMTCOR",131,0)
 ;  Input: DFN
"RTN","DGMTCOR",132,0)
 ;  Action: Possible update of Copay Status
"RTN","DGMTCOR",133,0)
 ;
"RTN","DGMTCOR",134,0)
 Q:'$D(^IBA(354.1,"APIDT",DFN,1))  ;No action if no status on file
"RTN","DGMTCOR",135,0)
 S ZTDESC="CHECK PATIENT FILE CHANGES VS CP STATUS",ZTDTH=$H,ZTRTN="REGAUTO^IBARXEU5",ZTSAVE("DFN")="",ZTIO=""
"RTN","DGMTCOR",136,0)
 D ^%ZTLOAD
"RTN","DGMTCOR",137,0)
 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","DGMTCOR",138,0)
 Q
"RTN","DGMTCOR",139,0)
 ;
"RTN","DGMTCOR",140,0)
IVMCVT(IVMTIEN) ; Check for a converted IVM Means Test
"RTN","DGMTCOR",141,0)
 ;  Input  IVMTIEN - MT IEN to check
"RTN","DGMTCOR",142,0)
 ;  Return 1 - if converted MT
"RTN","DGMTCOR",143,0)
 ;         0 - if not a converted MT
"RTN","DGMTCOR",144,0)
 ;
"RTN","DGMTCOR",145,0)
 N FLAG,IVMAR
"RTN","DGMTCOR",146,0)
 S FLAG=0
"RTN","DGMTCOR",147,0)
 I '$G(IVMTIEN) G IVMQ
"RTN","DGMTCOR",148,0)
 D GETS^DIQ(408.31,IVMTIEN,".23;.25","E","IVMAR")
"RTN","DGMTCOR",149,0)
 ; To identify an IVM converted test in the ANNUAL MEANS TEST, #408.31, if the Source of Test (#.23)
"RTN","DGMTCOR",150,0)
 ; is equal to 'IVM' OR the Date IVM Verified MT Completed (#.25) is populated, then the test should
"RTN","DGMTCOR",151,0)
 ; be considered a converted test. 
"RTN","DGMTCOR",152,0)
 I IVMAR(408.31,IVMTIEN_",",.23,"E")="IVM" S FLAG=1 G IVMQ
"RTN","DGMTCOR",153,0)
 I IVMAR(408.31,IVMTIEN_",",.25,"E")]"" S FLAG=1 G IVMQ
"RTN","DGMTCOR",154,0)
IVMQ ;
"RTN","DGMTCOR",155,0)
 Q FLAG
"RTN","DGMTCOU1")
0^10^B13152902
"RTN","DGMTCOU1",1,0)
DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD,BDB - COPAY UTILITIES;8/13/04 8:31am
"RTN","DGMTCOU1",2,0)
 ;;5.3;Registration;**33,45,54,335,358,401,436,445,564,840,858**;Aug 13, 1993;Build 30
"RTN","DGMTCOU1",3,0)
AUTO(DFN,AUTOEX) ;
"RTN","DGMTCOU1",4,0)
 ; Returns 1 if Exempt from CP w/o needing MT/CP information
"RTN","DGMTCOU1",5,0)
 ;  INPUT: DFN     [Required]
"RTN","DGMTCOU1",6,0)
 ;         AUTOEX  [Optional]
"RTN","DGMTCOU1",7,0)
 ;  RETURNS 1=Exempt 0=Not Exempt
"RTN","DGMTCOU1",8,0)
 ;
"RTN","DGMTCOU1",9,0)
 ; Hold the Auto exclusion information for later use
"RTN","DGMTCOU1",10,0)
 S AUTOEX=$$AUTOINFO(DFN)
"RTN","DGMTCOU1",11,0)
 ;
"RTN","DGMTCOU1",12,0)
 Q AUTOEX["1"
"RTN","DGMTCOU1",13,0)
AUTOINFO(DFN) ;
"RTN","DGMTCOU1",14,0)
 ; This returns info needed to IB to see if MT information needs to be
"RTN","DGMTCOU1",15,0)
 ; looked at to determine Copay Exemption Status
"RTN","DGMTCOU1",16,0)
 ;
"RTN","DGMTCOU1",17,0)
 ;  INPUT: DFN - IEN of Patient File (Required)
"RTN","DGMTCOU1",18,0)
 ;  OUTPUT:(SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PT^NON.VET^INPT^POW^UNEMP^CD)
"RTN","DGMTCOU1",19,0)
 ;  Piece: (   1  ^   2   ^   3  ^   4   ^   5  ^   6   ^  7 ^ 8 ^  9  ^10)
"RTN","DGMTCOU1",20,0)
 ;  PIECES =1 IF TRUE
"RTN","DGMTCOU1",21,0)
 ;
"RTN","DGMTCOU1",22,0)
 N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT,DGI
"RTN","DGMTCOU1",23,0)
 S DGX=""
"RTN","DGMTCOU1",24,0)
 I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S $P(DGX,U,6)=1 G QTAUTO ;NON-VET
"RTN","DGMTCOU1",25,0)
 S DGEL=0,DGALLEL=U
"RTN","DGMTCOU1",26,0)
 F  S DGEL=$O(^DPT("AEL",DFN,DGEL)) Q:'DGEL  S DGALLEL=DGALLEL_$P($G(^DIC(8,DGEL,0)),U,9)_U
"RTN","DGMTCOU1",27,0)
 F DGI=.3,.362,.39,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) ;DG*5.3*840
"RTN","DGMTCOU1",28,0)
 I (DGALLEL["^1^") S $P(DGX,U,1)=1 G QTAUTO ;SC>50
"RTN","DGMTCOU1",29,0)
 I $P(DGNODE(.362),U,12)["Y"!(DGALLEL["^2^") S $P(DGX,U,2)=1 G QTAUTO ;A&A
"RTN","DGMTCOU1",30,0)
 I $P(DGNODE(.362),U,13)["Y"!(DGALLEL["^15^") S $P(DGX,U,3)=1 G QTAUTO ;HB
"RTN","DGMTCOU1",31,0)
 I $P(DGNODE(.362),U,14)["Y"!(DGALLEL["^4^") S $P(DGX,U,4)=1 G QTAUTO ;PENSION
"RTN","DGMTCOU1",32,0)
 I $P(DGNODE(.52),U,5)["Y"!(DGALLEL["^18^") S $P(DGX,U,8)=1 G QTAUTO ;POW
"RTN","DGMTCOU1",33,0)
 I $P(DGNODE(.39),U,6)["Y"!(DGALLEL["^21^") S $P(DGX,U,10)=1 G QTAUTO ;CD DG*5.3*840
"RTN","DGMTCOU1",34,0)
 I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S $P(DGX,U,9)=1 G QTAUTO ;UNEMPLOYABLE
"RTN","DGMTCOU1",35,0)
 N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
"RTN","DGMTCOU1",36,0)
 D DOM^DGMTR I $G(DGDOM) S $P(DGX,U,5)=1 G QTAUTO ;DOM
"RTN","DGMTCOU1",37,0)
 D IN5^VADPT I $G(VAIP(1))'="" S $P(DGX,U,7)=1 G QTAUTO ;INPAT
"RTN","DGMTCOU1",38,0)
QTAUTO Q DGX
"RTN","DGMTCOU1",39,0)
 ;
"RTN","DGMTCOU1",40,0)
LST(DFN,DGDT,DGMTYPT1) ;Last Copay Exemption or Means Test for a patient
"RTN","DGMTCOU1",41,0)
 ;   Input  -- DFN   Patient IEN
"RTN","DGMTCOU1",42,0)
 ;             DGDT  Date/Time  (Optional- default today@2359)
"RTN","DGMTCOU1",43,0)
 ;             DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
"RTN","DGMTCOU1",44,0)
 ;   Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
"RTN","DGMTCOU1",45,0)
 ;      Piece:   1   ^     2              3         4            5
"RTN","DGMTCOU1",46,0)
 ;
"RTN","DGMTCOU1",47,0)
 N DGCPDT,DGIDT,DGIDT,DGMTDT,DGMTI,Y
"RTN","DGMTCOU1",48,0)
 S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
"RTN","DGMTCOU1",49,0)
 I '$D(DGMTYPT1) S DGMTYPT1=3
"RTN","DGMTCOU1",50,0)
 I DGMTYPT1=3 D  ;EITHER
"RTN","DGMTCOU1",51,0)
 .S DGMTDT=+$O(^DGMT(408.31,"AID",1,DFN,DGIDT))
"RTN","DGMTCOU1",52,0)
 .S DGCPDT=+$O(^DGMT(408.31,"AID",2,DFN,DGIDT))
"RTN","DGMTCOU1",53,0)
 .S DGMTYPT1=$S(DGCPDT<DGMTDT:2,(DGCPDT>DGMTDT):1,$D(^DGMT(408.31,"AS",1,3,+DGMTDT,DFN)):2,1:1)
"RTN","DGMTCOU1",54,0)
 S DGMTI=+$$LST^DGMTU(DFN,$P(DGIDT,"-",2),DGMTYPT1)
"RTN","DGMTCOU1",55,0)
 I $D(^DGMT(408.31,DGMTI,0)) S Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS^DGMTU(DFN,+$P(^(0),"^",3))_"^"_DGMTYPT1
"RTN","DGMTCOU1",56,0)
 Q $G(Y)
"RTN","DGMTCOU1",57,0)
THRESH(DGDT) ;PRINTS THE YEAR'S COPAY THRESHOLDS
"RTN","DGMTCOU1",58,0)
 ;UPDATE 11/15/00 TO REFLECT YEAR'S COPAY THRESHOLDS PER VHA DIRECTIVE
"RTN","DGMTCOU1",59,0)
 ;99-064
"RTN","DGMTCOU1",60,0)
 N DGCPLEV,DGDEP,DGNODE,DGTYPE,Y
"RTN","DGMTCOU1",61,0)
 I '$D(DGDT) S DGDT=DT
"RTN","DGMTCOU1",62,0)
 S DGDT=DGDT\1
"RTN","DGMTCOU1",63,0)
 S Y=DGDT X ^DD("DD") W !,?2,"Net Annual Income Thresholds on ",Y,":"
"RTN","DGMTCOU1",64,0)
 S DGTYPE=$S(DGDT<2961201:2,1:1)
"RTN","DGMTCOU1",65,0)
 S DGCPLEV=$$THRES^IBARXEU1(DGDT,DGTYPE,0)
"RTN","DGMTCOU1",66,0)
 I DGCPLEV']"" W !,"None for this date..." G THRESHQT
"RTN","DGMTCOU1",67,0)
 W !,?5,"Num. Dependents: ",?25,"0 (Self)",?42,1,?52,2,?62,3,?72,4
"RTN","DGMTCOU1",68,0)
 W !,?5,"Net Income:"
"RTN","DGMTCOU1",69,0)
 F DGDEP=0:1:4 W ?(23+(DGDEP*10)),$J(+$$THRES^IBARXEU1(DGDT,DGTYPE,DGDEP),10)
"RTN","DGMTCOU1",70,0)
THRESHQT Q
"RTN","DGMTCOU1",71,0)
DISPMAS(DFN) ; Displays Co
"RTN","DGMTCOU1",72,0)
 N DGCPS,DGEX,Y,AUTOEX
"RTN","DGMTCOU1",73,0)
 S DGEX=$$AUTO(DFN,.AUTOEX)
"RTN","DGMTCOU1",74,0)
 I $P($G(AUTOEX),U,5)!($P($G(AUTOEX),U,7)) Q
"RTN","DGMTCOU1",75,0)
 I DGEX W !,"Patient is exempt from Copay."
"RTN","DGMTCOU1",76,0)
 I 'DGEX D
"RTN","DGMTCOU1",77,0)
 .S DGCPS=$$LST365(DFN,DT,2),Y=$P(DGCPS,U,2)
"RTN","DGMTCOU1",78,0)
 .I DGCPS]"" D
"RTN","DGMTCOU1",79,0)
 ..X ^DD("DD")
"RTN","DGMTCOU1",80,0)
 ..W !,"Patient's Copay Status is ",$P(DGCPS,U,3)
"RTN","DGMTCOU1",81,0)
 ..W ".  Last Test Date: ",Y,"."
"RTN","DGMTCOU1",82,0)
 Q
"RTN","DGMTCOU1",83,0)
LST365(DFN,DGDT,DGMTYPT1) ;RETURNS CURRENT MT/CP  (WITHIN 1 YEAR OF VFA START DATE)
"RTN","DGMTCOU1",84,0)
 ;  Input:   DGDT - IB DATE
"RTN","DGMTCOU1",85,0)
 ;           DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
"RTN","DGMTCOU1",86,0)
 ;  Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
"RTN","DGMTCOU1",87,0)
 ;     Piece:   1   ^     2              3         4            5
"RTN","DGMTCOU1",88,0)
 N DGLST
"RTN","DGMTCOU1",89,0)
 S DGDT=$G(DGDT)
"RTN","DGMTCOU1",90,0)
 I '$D(DGMTYPT1) S DGMTYPT1=3
"RTN","DGMTCOU1",91,0)
 S DGLST=$$LST(DFN,DGDT,DGMTYPT1)
"RTN","DGMTCOU1",92,0)
 S:$P(DGLST,U,4)="N" DGLST=$$LST(DFN,DGDT,2)
"RTN","DGMTCOU1",93,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTCOU1",94,0)
 S:$$OLDMTPF^DGMTU4($P(DGLST,U,2)) DGLST=""
"RTN","DGMTCOU1",95,0)
 Q DGLST
"RTN","DGMTE")
0^6^B27294301
"RTN","DGMTE",1,0)
DGMTE ;ALB/RMO,CAW,LD,SCG,BDB - Edit an Existing Means Test ;03 APR 2002 2:00 pm
"RTN","DGMTE",2,0)
 ;;5.3;Registration;**33,45,182,344,332,433,624,858**;Aug 13, 1993;Build 30
"RTN","DGMTE",3,0)
 ;
"RTN","DGMTE",4,0)
EN ;Entry point to edit an existing means test
"RTN","DGMTE",5,0)
 N DGMDOD S DGMDOD=""
"RTN","DGMTE",6,0)
 I DGMTYPT=1 S DIC("S")="I $P(^(0),U,14)"
"RTN","DGMTE",7,0)
 I DGMTYPT=2!(DGMTYPT=4) S DIC("S")="I $D(^DGMT(408.31,""AID"",DGMTYPT,+Y))"
"RTN","DGMTE",8,0)
 I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
"RTN","DGMTE",9,0)
 S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q:Y<0 S (DFN,DGMTDFN)=+Y
"RTN","DGMTE",10,0)
 I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
"RTN","DGMTE",11,0)
 I $G(DGMDOD) W !,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") Q
"RTN","DGMTE",12,0)
 ;
"RTN","DGMTE",13,0)
 ; check if income test upload in progress
"RTN","DGMTE",14,0)
 D CKUPLOAD^IVMCUPL(DFN)
"RTN","DGMTE",15,0)
 ;
"RTN","DGMTE",16,0)
 ; obtain lock used to synchronize local MT/CT options with income test upload
"RTN","DGMTE",17,0)
 I $$LOCK^DGMTUTL(DFN)
"RTN","DGMTE",18,0)
 ;
"RTN","DGMTE",19,0)
DT S DIC("A")="Select DATE OF TEST: "
"RTN","DGMTE",20,0)
 N FUTFLG,VSITE,DGLSTDT S FUTFLG=0,VSITE=+$P($$SITE^VASITE(),U,3)
"RTN","DGMTE",21,0)
 I $D(^DGMT(408.31,+$$FUT^DGMTU(DFN,"",DGMTYPT),0)),+$P($G(^(2)),U,5)=VSITE S DIC("B")=$P(^(0),"^"),FUTFLG=1
"RTN","DGMTE",22,0)
 ;cannot edit a means test that is more than 1 year old DG*5.3*858
"RTN","DGMTE",23,0)
 I 'FUTFLG I $D(^DGMT(408.31,+$$LST^DGMTU(DFN,"",DGMTYPT),0)) S (DIC("B"),DGLSTDT)=$P(^(0),"^") I $$OLD^DGMTU4(DGLSTDT),(DGMTYPT=1) D  K DIC G Q
"RTN","DGMTE",24,0)
 . W !!,"Please use the Add a New Means Test Option.",!,"User may not edit a Means Test that is more than 1 year old."
"RTN","DGMTE",25,0)
 S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
"RTN","DGMTE",26,0)
 S:DGMTYPT'=4 DIC("S")=DIC("S")_" I $G(^(""PRIM""))!($P(^(0),U,1)>DT)"
"RTN","DGMTE",27,0)
 S DIC="^DGMT(408.31,",DIC(0)="EQZ" W ! D EN^DGMTLK K DIC G Q:Y<0
"RTN","DGMTE",28,0)
 S DGMTI=+Y,DGMTDT=$P(Y,"^",2),DGMT0=Y(0)
"RTN","DGMTE",29,0)
 ;
"RTN","DGMTE",30,0)
 ;If test is uneditable, print error message and allow user to view test
"RTN","DGMTE",31,0)
 ;or print 10-10EZ/EZR
"RTN","DGMTE",32,0)
 ;
"RTN","DGMTE",33,0)
 I '$P($G(^DG(408.34,+$P(Y(0),U,23),0)),U,2) D  D:$G(DGMTERR) VIEWPRT G EN
"RTN","DGMTE",34,0)
 .W !!?3,*7,"Warning: Uneditable "_$S(DGMTYPT=1:"means",1:"copay")_" test.  The source of this test is "_$S($$SR^DGMTAUD1(Y(0))]"":$$SR^DGMTAUD1(Y(0)),1:"UNKNOWN")
"RTN","DGMTE",35,0)
 .W !?12,"which has been flagged as an uneditable source.",!
"RTN","DGMTE",36,0)
 .S DIR("A")="Would you like to view the "_$S(DGMTYPT=1:"means",1:"copay")_" test or print the 10-10EZR/EZ",DIR("B")="NO",DIR(0)="Y"
"RTN","DGMTE",37,0)
 .D ^DIR K DIR S DGMTERR=Y I $D(DTOUT)!($D(DUOUT)) K DGMTERR,DTOUT,DUOUT
"RTN","DGMTE",38,0)
 I "^3^10^"[("^"_$P(Y(0),"^",3)_"^") W !?3,*7,$S(DGMTYPT=1:"Means",1:"Copay")_" test is NO LONGER "_$S(DGMTYPT=1:"REQUIRED",1:"APPLICABLE")_", it cannot be edited." G EN
"RTN","DGMTE",39,0)
 I DGMTYPT=4,$P($G(^DGMT(408.31,DGMTI,2)),U,8) D  I $G(DGOUT) K DGOUT G EN
"RTN","DGMTE",40,0)
 .N DGMT,DGT S DGMT=$P(^DGMT(408.31,DGMTI,2),U,8),DGT=$P($G(^DGMT(408.31,DGMT,0)),U,19)
"RTN","DGMTE",41,0)
 .I DGT,DGT>2 Q
"RTN","DGMTE",42,0)
 .W !!,?3,"This LTC copay exemption test is linked to the ",$$FTIME^DGMTUTL(+^DGMT(408.31,DGMT,0)),$S(DGT=1:" means",1:" RX copay")," test."
"RTN","DGMTE",43,0)
 .W !,?3,"Changes should be made using the 'Edit an Existing ",$S(DGT=1:"Means",1:"Copay Exemption")," Test'"
"RTN","DGMTE",44,0)
 .W !,?3,"menu option."
"RTN","DGMTE",45,0)
 .S DGOUT=1
"RTN","DGMTE",46,0)
 D DISPLAY^DGMTU23(DGMTI,DGMTYPT),PAUSE I $D(DTOUT)!($D(DUOUT)) K DTOUT,DUOUT G EN
"RTN","DGMTE",47,0)
 ;
"RTN","DGMTE",48,0)
 ;hardship determination, once granted, will remain unless deleted by
"RTN","DGMTE",49,0)
 ;hardship option
"RTN","DGMTE",50,0)
 ;I $P(DGMT0,"^",20),'$$EDIT() G EN ; if hardship
"RTN","DGMTE",51,0)
 ;
"RTN","DGMTE",52,0)
 S DGMTACT="EDT",DGMTROU="EN^DGMTE" G EN^DGMTSC
"RTN","DGMTE",53,0)
 ;
"RTN","DGMTE",54,0)
Q K DFN,DGMTACT,DGMTDT,DGMTERR,DGMT0,DGMTI,DGMTROU,DGMTYPT,DGMTX,DGOUT,DTOUT,DUOUT,X,Y
"RTN","DGMTE",55,0)
 ;
"RTN","DGMTE",56,0)
 ; release lock used to synchronize local MT/CT options with income test upload
"RTN","DGMTE",57,0)
 I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
"RTN","DGMTE",58,0)
 Q
"RTN","DGMTE",59,0)
 ;
"RTN","DGMTE",60,0)
PAUSE S DIR(0)="E" D ^DIR
"RTN","DGMTE",61,0)
 Q
"RTN","DGMTE",62,0)
 ;
"RTN","DGMTE",63,0)
VIEWPRT ; Select 1 to view an uneditable means test or 2 to print a 10-10EZ/EZR
"RTN","DGMTE",64,0)
 ;
"RTN","DGMTE",65,0)
 S DIR(0)="S^1:View Means Test;2:Print Means Test 10-10EZR/EZ",DIR("A")="Select Choice"
"RTN","DGMTE",66,0)
 D ^DIR S DGMTANS=Y G:$D(DTOUT)!($D(DUOUT)) VIEWPRTQ
"RTN","DGMTE",67,0)
 I DGMTANS=1 D EN1^DGMTV
"RTN","DGMTE",68,0)
 I DGMTANS=2 D 
"RTN","DGMTE",69,0)
 .N RPTSEL,DGTASK
"RTN","DGMTE",70,0)
 .D FULL^VALM1
"RTN","DGMTE",71,0)
 .S (RPTSEL,DGTASK)=""
"RTN","DGMTE",72,0)
 .I $D(DGFINOP) DO
"RTN","DGMTE",73,0)
 ..W !!,"Options for printing financial assessment information will follow."
"RTN","DGMTE",74,0)
 ..W !,"Generally, you should answer 'YES' to 'PRINT 10-10EZR?' after updating"
"RTN","DGMTE",75,0)
 ..W !,"patient demographic or financial information.  Answer 'YES' to 'PRINT"
"RTN","DGMTE",76,0)
 ..W !,"10-10EZ?' after entering new patient demographic and financial information."
"RTN","DGMTE",77,0)
 .S RPTSEL=$$SEL1010^DG1010P("EZR/EZ") ;*Select 1010EZ/R form to print
"RTN","DGMTE",78,0)
 .S:RPTSEL'="-1" DGTASK=$$PRT1010^DG1010P(RPTSEL,DFN,DGMTI) ;*Print 1010EZ/R
"RTN","DGMTE",79,0)
 ;
"RTN","DGMTE",80,0)
VIEWPRTQ ;
"RTN","DGMTE",81,0)
 K DGMTANS,DIR,DTOUT,DUOUT,Y
"RTN","DGMTE",82,0)
 Q
"RTN","DGMTE",83,0)
 ;
"RTN","DGMTE",84,0)
EDIT() ; want to edit even though MT is hardship?
"RTN","DGMTE",85,0)
 ;
"RTN","DGMTE",86,0)
 ; Output:  1 if user wants to edit, 0 otherwise
"RTN","DGMTE",87,0)
 ;
"RTN","DGMTE",88,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,X,Y
"RTN","DGMTE",89,0)
 S DIR("?",1)="WARNING:  You are about to access a means test for which a hardship has"
"RTN","DGMTE",90,0)
 S DIR("?",2)="          been authorized.  If you proceed, the hardship will be removed"
"RTN","DGMTE",91,0)
 S DIR("?",3)="          and the means test category will be recalculated!  To avoid"
"RTN","DGMTE",92,0)
 S DIR("?",4)="          this problem, enter NO at the next prompt and use the 'View"
"RTN","DGMTE",93,0)
 S DIR("?",5)="          a Past Means Test' option should you need to see details of"
"RTN","DGMTE",94,0)
 S DIR("?",6)="          this means test."
"RTN","DGMTE",95,0)
 S DIR("?",7)=" "
"RTN","DGMTE",96,0)
 S DIR("?")="Enter NO to stop editing this means test.  Enter YES to continue"
"RTN","DGMTE",97,0)
 F I=1:1 Q:'$D(DIR("?",I))  W !,DIR("?",I)
"RTN","DGMTE",98,0)
 S DIR("A")="Do you want to continue editing this means test?  ",DIR("B")="NO",DIR(0)="YA"
"RTN","DGMTE",99,0)
 D ^DIR
"RTN","DGMTE",100,0)
 Q Y
"RTN","DGMTEO")
0^8^B13226436
"RTN","DGMTEO",1,0)
DGMTEO ;ALB/RMO,CAW,LD,TDM,BDB - Other Means Test Edit Options ; 8/2/02 11:14am
"RTN","DGMTEO",2,0)
 ;;5.3;Registration;**33,45,182,456,858**;Aug 13, 1993;Build 30
"RTN","DGMTEO",3,0)
 ;
"RTN","DGMTEO",4,0)
ADJ ;Entry point to adjudicate a means test
"RTN","DGMTEO",5,0)
 N PADISP,DGLSTDT
"RTN","DGMTEO",6,0)
 S DIC="^DPT(",DIC(0)="AEMQ"
"RTN","DGMTEO",7,0)
 I DGMTYPT=1 S DIC("S")="I $P(^(0),U,14)=2"
"RTN","DGMTEO",8,0)
 I DGMTYPT=2 S DIC("S")="I $D(^DGMT(408.31,""AID"",DGMTYPT,+Y))"
"RTN","DGMTEO",9,0)
 W ! D ^DIC K DIC G ADJQ:Y<0 S DFN=+Y
"RTN","DGMTEO",10,0)
 S DGMTI=+$$LST^DGMTU(DFN,"",DGMTYPT),DGMTS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
"RTN","DGMTEO",11,0)
 I "^2^11^"'[("^"_DGMTS_"^") W !?3,*7,"Last means test is not PENDING ADJUDICATION." G ADJ
"RTN","DGMTEO",12,0)
 ;DG*5.3*858 user may not adjudicate a means test that is more than 1 year old
"RTN","DGMTEO",13,0)
 S DGLSTDT=$P($G(^DGMT(408.31,DGMTI,0)),"^",1) I $$OLD^DGMTU4(DGLSTDT) W !!,"Please use the Add a New Means Test Option.",!,"User may not adjudicate a Means Test that is more than 1 year old." G ADJ
"RTN","DGMTEO",14,0)
 ;
"RTN","DGMTEO",15,0)
 S PADISP=$$PA^DGMTUTL(DGMTI) S:PADISP="" PADISP="UNKNOWN"
"RTN","DGMTEO",16,0)
 W !!,"=============================================="
"RTN","DGMTEO",17,0)
 W !,?3,"Patient pending adjudication for ",PADISP,"."
"RTN","DGMTEO",18,0)
 W !,"=============================================="
"RTN","DGMTEO",19,0)
 ;
"RTN","DGMTEO",20,0)
 S DGMTACT="ADJ" D PRIOR^DGMTEVT
"RTN","DGMTEO",21,0)
 S DA=DGMTI,DIE="^DGMT(408.31,",DR="[DGMT ENTER/EDIT ADJUDICATION]" W ! D ^DIE K DA,DIE,DR
"RTN","DGMTEO",22,0)
 D AFTER^DGMTEVT S DGMTINF=0 D EN^DGMTEVT
"RTN","DGMTEO",23,0)
 ;
"RTN","DGMTEO",24,0)
 ;Update the TEST-DETERMINED STATUS field (#2.03) in the Annual Means
"RTN","DGMTEO",25,0)
 ;TEST file (#408.31) when adjudicating a means test.
"RTN","DGMTEO",26,0)
 D SAVESTAT^DGMTU4(DGMTI)
"RTN","DGMTEO",27,0)
 G ADJ
"RTN","DGMTEO",28,0)
ADJQ K DFN,DGMTA,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTS,DGMTYPT,Y
"RTN","DGMTEO",29,0)
 Q
"RTN","DGMTEO",30,0)
 ;
"RTN","DGMTEO",31,0)
COM ;Entry point to complete a required means test
"RTN","DGMTEO",32,0)
 S DIC="^DPT(",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,14)=1" W ! D ^DIC K DIC G COMQ:Y<0 S DFN=+Y
"RTN","DGMTEO",33,0)
 S DGMTI=+$$LST^DGMTU(DFN),DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTDT=$P(DGMT0,"^")
"RTN","DGMTEO",34,0)
 I $P(DGMT0,"^",3)'=1 W !?3,*7,"Last means test is not REQUIRED." G COM
"RTN","DGMTEO",35,0)
 ;DG*5.3*858 user may not complete a means test that is more than 1 year old
"RTN","DGMTEO",36,0)
 I $$OLD^DGMTU4(DGMTDT) W !!,"Please use the Add a New Means Test Option.",!,"User may not complete a Means Test that is more than 1 year old." G COM
"RTN","DGMTEO",37,0)
 S DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" G EN^DGMTSC
"RTN","DGMTEO",38,0)
COMQ K DFN,DGMT0,DGMTACT,DGMTDT,DGMTI,DGMTROU,DGMTYPT,Y
"RTN","DGMTEO",39,0)
 Q
"RTN","DGMTEO",40,0)
 ;
"RTN","DGMTEO",41,0)
CAT ;Entry point to change a patient's means test category
"RTN","DGMTEO",42,0)
 ;
"RTN","DGMTEO",43,0)
 ;no longer allowed to do this - instead, must enter a hardship or
"RTN","DGMTEO",44,0)
 ;net-worth adjudication
"RTN","DGMTEO",45,0)
 Q
"RTN","DGMTEO",46,0)
 ;
"RTN","DGMTEO",47,0)
 S DIC="^DPT(",DIC(0)="AEMQ",DIC("S")="I ""^1^3^""'[(U_$P(^(0),U,14)_U)" W ! D ^DIC K DIC G CATQ:Y<0 S DFN=+Y
"RTN","DGMTEO",48,0)
 S DGMTI=+$$LST^DGMTU(DFN),DGMTS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
"RTN","DGMTEO",49,0)
 I 'DGMTS W !?3,*7,"No means test to change." G CAT
"RTN","DGMTEO",50,0)
 S DGMTACT="CAT" D PRIOR^DGMTEVT
"RTN","DGMTEO",51,0)
 I $G(DGMTP) D
"RTN","DGMTEO",52,0)
 .W !!,"MEANS TEST DATE: ",$$DATE^DGMTOREQ($P(DGMTP,U)),?44,"SOURCE OF TEST: ",$$SR^DGMTAUD1(DGMTP),!
"RTN","DGMTEO",53,0)
 .I $P($G(^DG(408.34,+$P(DGMTP,U,23),0)),U)="VAMC",($P($G(^DG(408.32,+$P(DGMTP,U,3),0)),U)="CATEGORY A") D
"RTN","DGMTEO",54,0)
 ..F I=1:1 S J=$P($T(CATTXT+I),";;",2) Q:J="END"  W !,J
"RTN","DGMTEO",55,0)
 S DA=DGMTI,DIE="^DGMT(408.31,",DR="[DGMT ENTER/EDIT CATEGORY]" W ! D ^DIE K DA,DIE,DR
"RTN","DGMTEO",56,0)
 S DGMTYPT=1 D AFTER^DGMTEVT S DGMTINF=0 D EN^DGMTEVT,CATQ G CAT
"RTN","DGMTEO",57,0)
CATQ K DFN,DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTINF,DGMTP,DGMTS,DGMTYPT,I,J,Y
"RTN","DGMTEO",58,0)
 Q
"RTN","DGMTEO",59,0)
CATTXT ;
"RTN","DGMTEO",60,0)
 ;;NOTE:  VAMC Category A means tests can be changed to another 
"RTN","DGMTEO",61,0)
 ;;       category by editing the patient's means test data through
"RTN","DGMTEO",62,0)
 ;;       the 'Edit an Existing Means Test' option ONLY.
"RTN","DGMTEO",63,0)
 ;;END
"RTN","DGMTHL1")
0^9^B64633533
"RTN","DGMTHL1",1,0)
DGMTHL1 ;ALB/CJM/TDM,LBD - Hardship Determinations - Build List Area;13 JUN 1997 08:00 am ; 9/6/12 6:07pm
"RTN","DGMTHL1",2,0)
 ;;5.3;Registration;**182,456,536,858**;08/13/93;Build 30
"RTN","DGMTHL1",3,0)
 ;
"RTN","DGMTHL1",4,0)
EN(DGARY,HARDSHIP,DGCNT) ;Entry point to build list area
"RTN","DGMTHL1",5,0)
 ; Input;
"RTN","DGMTHL1",6,0)
 ;   DGARY    Global array subscript
"RTN","DGMTHL1",7,0)
 ;   HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",8,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGMTHL1",9,0)
 ;
"RTN","DGMTHL1",10,0)
 N DGLINE
"RTN","DGMTHL1",11,0)
 S DGLINE=1,DGCNT=0
"RTN","DGMTHL1",12,0)
 D SET(DGARY,.HARDSHIP,.DGLINE,.DGCNT)
"RTN","DGMTHL1",13,0)
 Q
"RTN","DGMTHL1",14,0)
 ;
"RTN","DGMTHL1",15,0)
SET(DGARY,HARDSHIP,DGLINE,DGCNT) ;
"RTN","DGMTHL1",16,0)
 ;Description: Writes hardship
"RTN","DGMTHL1",17,0)
 ; Input  -- DGARY    Global array subscript
"RTN","DGMTHL1",18,0)
 ;           HARDSHIP    Hardship array
"RTN","DGMTHL1",19,0)
 ;           DGLINE   Line number
"RTN","DGMTHL1",20,0)
 ; Output -- DGCNT    Number of lines in the list
"RTN","DGMTHL1",21,0)
 N DGSTART,LINE
"RTN","DGMTHL1",22,0)
 ;
"RTN","DGMTHL1",23,0)
 S DGSTART=DGLINE ; starting line number
"RTN","DGMTHL1",24,0)
 D SET^DGENL1(DGARY,DGLINE,"Hardship",21,IORVON,IORVOFF,,,,.DGCNT)
"RTN","DGMTHL1",25,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",26,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Current Means Test Status:   ",31)_$$EXT^DGMTH("CURRENT STATUS",HARDSHIP("CURRENT STATUS")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",27,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",28,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Income Year:   ",31)_$S(HARDSHIP("YEAR"):$$EXT^DGMTH("YEAR",HARDSHIP("YEAR")),1:""),1,,,,,,.DGCNT)
"RTN","DGMTHL1",29,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",30,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Means Test Date:   ",31)_$$EXT^DGMTH("TEST DATE",HARDSHIP("TEST DATE")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",31,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",32,0)
 I (HARDSHIP("AGREE")'="") D SET^DGENL1(DGARY,DGLINE,$J("Agreed To Pay Deductible:   ",31)_$$EXT^DGMTH("AGREE",HARDSHIP("AGREE")),1,,,,,,.DGCNT) S DGLINE=DGLINE+1
"RTN","DGMTHL1",33,0)
 ;
"RTN","DGMTHL1",34,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",35,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Hardship?:   ",31)_$$EXT^DGMTH("HARDSHIP?",HARDSHIP("HARDSHIP?")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",36,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",37,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Hardship Effective Date:   ",31)_$$EXT^DGMTH("EFFECTIVE",HARDSHIP("EFFECTIVE")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",38,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",39,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Review Date:   ",31)_$$EXT^DGMTH("REVIEW",HARDSHIP("REVIEW")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",40,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",41,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Site Granting Hardship:   ",31)_$$EXT^DGMTH("SITE",HARDSHIP("SITE")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",42,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",43,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Approved By:   ",31)_$$EXT^DGMTH("BY",HARDSHIP("BY")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",44,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",45,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Hardship Reason:   ",31)_$$EXT^DGMTH("REASON",HARDSHIP("REASON")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",46,0)
 S DGLINE=DGLINE+2
"RTN","DGMTHL1",47,0)
 ;
"RTN","DGMTHL1",48,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Date Category Last Changed:   ",31)_$$EXT^DGMTH("DT/TM CTGRY CHNGD",HARDSHIP("DT/TM CTGRY CHNGD")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",49,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",50,0)
 D SET^DGENL1(DGARY,DGLINE,$J("Category Last Changed By:   ",31)_$$EXT^DGMTH("CTGRY CHNGD BY",HARDSHIP("CTGRY CHNGD BY")),1,,,,,,.DGCNT)
"RTN","DGMTHL1",51,0)
 S DGLINE=DGLINE+1
"RTN","DGMTHL1",52,0)
 I $D(^DGMT(408.31,HARDSHIP("MTIEN"),"C")) D
"RTN","DGMTHL1",53,0)
 .N LINE
"RTN","DGMTHL1",54,0)
 .D SET^DGENL1(DGARY,DGLINE,"COMMENTS:",1,$G(IOINHI),$G(IOINORM),,,,.DGCNT)
"RTN","DGMTHL1",55,0)
 .S DGLINE=DGLINE+1
"RTN","DGMTHL1",56,0)
 .S LINE=0
"RTN","DGMTHL1",57,0)
 .F  S LINE=$O(^DGMT(408.31,HARDSHIP("MTIEN"),"C",LINE)) Q:'LINE  D
"RTN","DGMTHL1",58,0)
 ..D SET^DGENL1(DGARY,DGLINE,$G(^DGMT(408.31,HARDSHIP("MTIEN"),"C",LINE,0)),1,,,,,,.DGCNT)
"RTN","DGMTHL1",59,0)
 ..S DGLINE=DGLINE+1
"RTN","DGMTHL1",60,0)
 Q
"RTN","DGMTHL1",61,0)
 ;
"RTN","DGMTHL1",62,0)
CHKADD(HARDSHIP) ;
"RTN","DGMTHL1",63,0)
 ;Determines whether granting a hardship is appropriate
"RTN","DGMTHL1",64,0)
 ;Input:
"RTN","DGMTHL1",65,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",66,0)
 ;Output:
"RTN","DGMTHL1",67,0)
 ;  Function Value - 1 if the hardship can be granted, 0 otherwise   
"RTN","DGMTHL1",68,0)
 ;
"RTN","DGMTHL1",69,0)
 ; Add check for MT more than a year old (DG*5.3*858)
"RTN","DGMTHL1",70,0)
 I $G(HARDSHIP("TEST DATE")),$$OLD^DGMTU4(HARDSHIP("TEST DATE")) Q 0
"RTN","DGMTHL1",71,0)
 ;
"RTN","DGMTHL1",72,0)
 N CODE
"RTN","DGMTHL1",73,0)
 S CODE=""
"RTN","DGMTHL1",74,0)
 S CODE=$$GETCODE^DGMTH(HARDSHIP("CURRENT STATUS"))
"RTN","DGMTHL1",75,0)
 I CODE'="C",CODE'="P",CODE'="G" Q 0
"RTN","DGMTHL1",76,0)
 Q 1
"RTN","DGMTHL1",77,0)
 ;
"RTN","DGMTHL1",78,0)
ADD(HARDSHIP) ;
"RTN","DGMTHL1",79,0)
 ;Add hardship protocol.
"RTN","DGMTHL1",80,0)
 ;
"RTN","DGMTHL1",81,0)
 ;Input:
"RTN","DGMTHL1",82,0)
 ;  HARDSHIP - hardship array, pass by reference
"RTN","DGMTHL1",83,0)
 ;Output:
"RTN","DGMTHL1",84,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",85,0)
 ;
"RTN","DGMTHL1",86,0)
 N CODE,ERROR
"RTN","DGMTHL1",87,0)
 I $G(DUZ)'>1 W !,"YOUR DUZ IS NOT DEFINED!" D PAUSE^VALM1 S VALMBCK="R" Q
"RTN","DGMTHL1",88,0)
 S CODE=""
"RTN","DGMTHL1",89,0)
 S CODE=$$GETCODE^DGMTH(HARDSHIP("CURRENT STATUS"))
"RTN","DGMTHL1",90,0)
 I CODE'="C",CODE'="P",CODE'="G" W !,"PATIENT NOT CURRENTLY RESPONSIBLE FOR COPAYMENT CHARGES!" D PAUSE^VALM1 Q
"RTN","DGMTHL1",91,0)
 S HARDSHIP("EFFECTIVE")=DT
"RTN","DGMTHL1",92,0)
 S HARDSHIP("SITE")=$$GETSITE^DGMTU4(.DUZ)
"RTN","DGMTHL1",93,0)
 I HARDSHIP("TEST STATUS")="" S HARDSHIP("TEST STATUS")=HARDSHIP("CURRENT STATUS")
"RTN","DGMTHL1",94,0)
 ;S HARDSHIP("CURRENT STATUS")=$$GETSTAT^DGMTH("A",1)
"RTN","DGMTHL1",95,0)
 S HARDSHIP("BY")=DUZ
"RTN","DGMTHL1",96,0)
 S HARDSHIP("CTGRY CHNGD BY")=DUZ
"RTN","DGMTHL1",97,0)
 S HARDSHIP("DT/TM CTGRY CHNGD")=$$NOW^XLFDT
"RTN","DGMTHL1",98,0)
 S HARDSHIP("HARDSHIP?")=1
"RTN","DGMTHL1",99,0)
 D
"RTN","DGMTHL1",100,0)
 .I '$$GETSTAT(.HARDSHIP) Q
"RTN","DGMTHL1",101,0)
 .I '$$GETEFF(.HARDSHIP) Q
"RTN","DGMTHL1",102,0)
 .I '$$GETREV(.HARDSHIP) Q
"RTN","DGMTHL1",103,0)
 .I '$$GETREAS(.HARDSHIP) Q
"RTN","DGMTHL1",104,0)
 .D PRIOR(.HARDSHIP)
"RTN","DGMTHL1",105,0)
 .I $$STORE^DGMTH(.HARDSHIP,.ERROR) D
"RTN","DGMTHL1",106,0)
 ..N EVENTS
"RTN","DGMTHL1",107,0)
 ..S EVENTS("IVM")=1
"RTN","DGMTHL1",108,0)
 ..I $$LOG^IVMPLOG(HARDSHIP("DFN"),HARDSHIP("YEAR"),.EVENTS)
"RTN","DGMTHL1",109,0)
 .E  W !,$G(ERROR) D PAUSE^VALM1
"RTN","DGMTHL1",110,0)
 .D AFTER(.HARDSHIP)
"RTN","DGMTHL1",111,0)
 D INIT^DGMTHL
"RTN","DGMTHL1",112,0)
 S VALMBCK="R"
"RTN","DGMTHL1",113,0)
 Q
"RTN","DGMTHL1",114,0)
 ;
"RTN","DGMTHL1",115,0)
EDIT(HARDSHIP) ;
"RTN","DGMTHL1",116,0)
 ;Add hardship protocol.
"RTN","DGMTHL1",117,0)
 ;
"RTN","DGMTHL1",118,0)
 ;Input:
"RTN","DGMTHL1",119,0)
 ;  HARDSHIP - hardship array, pass by reference
"RTN","DGMTHL1",120,0)
 ;Output:
"RTN","DGMTHL1",121,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",122,0)
 ;
"RTN","DGMTHL1",123,0)
 N ERROR
"RTN","DGMTHL1",124,0)
 D
"RTN","DGMTHL1",125,0)
 .I '$$GETSTAT(.HARDSHIP,1) Q
"RTN","DGMTHL1",126,0)
 .I '$$GETEFF(.HARDSHIP) Q
"RTN","DGMTHL1",127,0)
 .I '$$GETREV(.HARDSHIP) Q
"RTN","DGMTHL1",128,0)
 .I '$$GETREAS(.HARDSHIP) Q
"RTN","DGMTHL1",129,0)
 .D PRIOR(.HARDSHIP)
"RTN","DGMTHL1",130,0)
 .I $$STORE^DGMTH(.HARDSHIP,.ERROR) D
"RTN","DGMTHL1",131,0)
 ..N EVENTS
"RTN","DGMTHL1",132,0)
 ..S EVENTS("IVM")=1
"RTN","DGMTHL1",133,0)
 ..I $$LOG^IVMPLOG(HARDSHIP("DFN"),HARDSHIP("YEAR"),.EVENTS)
"RTN","DGMTHL1",134,0)
 .E  W !,$G(ERROR) D PAUSE^VALM1
"RTN","DGMTHL1",135,0)
 .D AFTER(.HARDSHIP)
"RTN","DGMTHL1",136,0)
 D INIT^DGMTHL
"RTN","DGMTHL1",137,0)
 S VALMBCK="R"
"RTN","DGMTHL1",138,0)
 Q
"RTN","DGMTHL1",139,0)
 ;
"RTN","DGMTHL1",140,0)
CHKDEL(HARDSHIP) ;
"RTN","DGMTHL1",141,0)
 ;Checks whether the hardship can be deleted.
"RTN","DGMTHL1",142,0)
 ;Input:
"RTN","DGMTHL1",143,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",144,0)
 I (HARDSHIP("HARDSHIP?")="1"),(HARDSHIP("BY")!((+HARDSHIP("SITE")=+$$GETSITE^DGMTU4($G(DUZ))))) Q 1
"RTN","DGMTHL1",145,0)
 Q 0
"RTN","DGMTHL1",146,0)
DELETE(HARDSHIP) ;
"RTN","DGMTHL1",147,0)
 ;Deletes the hardship.
"RTN","DGMTHL1",148,0)
 ;
"RTN","DGMTHL1",149,0)
 ;Input:
"RTN","DGMTHL1",150,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",151,0)
 ;
"RTN","DGMTHL1",152,0)
 N ERROR
"RTN","DGMTHL1",153,0)
 I $$RUSURE,'$$DELETE^DGMTH(.HARDSHIP,1,.ERROR) W !,"AN ERROR OCCURRED - "_$G(ERROR) D PAUSE^VALM1
"RTN","DGMTHL1",154,0)
 D INIT^DGMTHL
"RTN","DGMTHL1",155,0)
 S VALMBCK="R"
"RTN","DGMTHL1",156,0)
 Q
"RTN","DGMTHL1",157,0)
 ;
"RTN","DGMTHL1",158,0)
GETSTAT(HARDSHIP,EDITFLG) ;
"RTN","DGMTHL1",159,0)
 ;Asks the user to enter the means test status.
"RTN","DGMTHL1",160,0)
 ;
"RTN","DGMTHL1",161,0)
 ;Input:
"RTN","DGMTHL1",162,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",163,0)
 ;  EDITFLG  - Edit Flag: 1=Edit
"RTN","DGMTHL1",164,0)
 ;Output:
"RTN","DGMTHL1",165,0)
 ;  HARDSHIP("CURRENT STATUS")
"RTN","DGMTHL1",166,0)
 ;
"RTN","DGMTHL1",167,0)
 N DIR,FLTRSTAT
"RTN","DGMTHL1",168,0)
 S FLTRSTAT=$$GETCODE^DGMTH($S($G(EDITFLG):HARDSHIP("TEST STATUS"),1:HARDSHIP("CURRENT STATUS")))
"RTN","DGMTHL1",169,0)
 S DIR(0)="Pr^408.32:EMZ"
"RTN","DGMTHL1",170,0)
 S DIR("S")="I $P(^(0),U,19)=1"
"RTN","DGMTHL1",171,0)
 I "CP"[FLTRSTAT S DIR("S")=DIR("S")_",""AG""[$P(^(0),U,2)"
"RTN","DGMTHL1",172,0)
 I FLTRSTAT="G" S DIR("S")=DIR("S")_",""A""[$P(^(0),U,2)"
"RTN","DGMTHL1",173,0)
 S DIR("A")="Means Test Status"
"RTN","DGMTHL1",174,0)
 S DIR("B")=$$EXT^DGMTH("CURRENT STATUS",HARDSHIP("CURRENT STATUS"))
"RTN","DGMTHL1",175,0)
 D FULL^VALM1
"RTN","DGMTHL1",176,0)
 D ^DIR
"RTN","DGMTHL1",177,0)
 I $D(DIRUT) Q 0
"RTN","DGMTHL1",178,0)
 I Y<1 Q 0
"RTN","DGMTHL1",179,0)
 S HARDSHIP("CURRENT STATUS")=+Y
"RTN","DGMTHL1",180,0)
 ; Don't reset agreed to pay if mt copay req/GMT copay req/pend adj
"RTN","DGMTHL1",181,0)
 S:"^C^G^P^"'[(U_$P($G(^DG(408.32,+Y,0)),U,2)_U) HARDSHIP("AGREE")=""
"RTN","DGMTHL1",182,0)
 S VALMBCK="R"
"RTN","DGMTHL1",183,0)
 Q 1
"RTN","DGMTHL1",184,0)
 ;
"RTN","DGMTHL1",185,0)
GETEFF(HARDSHIP) ;
"RTN","DGMTHL1",186,0)
 ;Asks the user to enter the effective date.  Returns 1 on success, 0 on failure
"RTN","DGMTHL1",187,0)
 ;
"RTN","DGMTHL1",188,0)
 ;Input:
"RTN","DGMTHL1",189,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",190,0)
 ;Output:
"RTN","DGMTHL1",191,0)
 ;  HARDSHIP("EFFECTIVE")
"RTN","DGMTHL1",192,0)
 ;
"RTN","DGMTHL1",193,0)
 N DIR
"RTN","DGMTHL1",194,0)
 S DIR(0)="D^"_HARDSHIP("TEST DATE")_":"_DT_":EX"
"RTN","DGMTHL1",195,0)
 S DIR("A")="Hardship Effective Date"
"RTN","DGMTHL1",196,0)
 S DIR("B")=$$FMTE^XLFDT($S(HARDSHIP("EFFECTIVE"):HARDSHIP("EFFECTIVE"),1:HARDSHIP("TEST DATE")),"1D")
"RTN","DGMTHL1",197,0)
 D ^DIR
"RTN","DGMTHL1",198,0)
 I $D(DIRUT) Q 0
"RTN","DGMTHL1",199,0)
 I Y<1 Q 0
"RTN","DGMTHL1",200,0)
 S HARDSHIP("EFFECTIVE")=Y
"RTN","DGMTHL1",201,0)
 Q 1
"RTN","DGMTHL1",202,0)
GETREV(HARDSHIP) ;
"RTN","DGMTHL1",203,0)
 ;Asks the user to enter the review date.  Returns 1 on success, 0 on failure
"RTN","DGMTHL1",204,0)
 ;
"RTN","DGMTHL1",205,0)
 ;Input:
"RTN","DGMTHL1",206,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",207,0)
 ;Output:
"RTN","DGMTHL1",208,0)
 ;  HARDSHIP("REVIEW")
"RTN","DGMTHL1",209,0)
 ;
"RTN","DGMTHL1",210,0)
 N RET,STOP,X,Y
"RTN","DGMTHL1",211,0)
 S (STOP,RET)=0
"RTN","DGMTHL1",212,0)
 S DIR(0)="DO^::EX"
"RTN","DGMTHL1",213,0)
 S DIR("A")="Hardship Review Date"
"RTN","DGMTHL1",214,0)
 I HARDSHIP("REVIEW") S DIR("B")=$$FMTE^XLFDT(HARDSHIP("REVIEW"),"1D")
"RTN","DGMTHL1",215,0)
 S DIR("?")="Enter a future date if you wish to conduct a review."
"RTN","DGMTHL1",216,0)
 F  D  Q:STOP
"RTN","DGMTHL1",217,0)
 .N DIR
"RTN","DGMTHL1",218,0)
 .S DIR(0)="DO^::EX"
"RTN","DGMTHL1",219,0)
 .S DIR("A")="Hardship Review Date"
"RTN","DGMTHL1",220,0)
 .I HARDSHIP("REVIEW") S DIR("B")=$$FMTE^XLFDT(HARDSHIP("REVIEW"),"1D")
"RTN","DGMTHL1",221,0)
 .S DIR("?")="Enter a future date if you wish to conduct a review."
"RTN","DGMTHL1",222,0)
 .D ^DIR
"RTN","DGMTHL1",223,0)
 .I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S STOP=1,RET=0 Q
"RTN","DGMTHL1",224,0)
 .I X="@" S Y="",STOP=1,RET=1 Q
"RTN","DGMTHL1",225,0)
 .I Y=-1 S STOP=1,RET=0 Q
"RTN","DGMTHL1",226,0)
 .I Y<DT W !,DIR("?") Q
"RTN","DGMTHL1",227,0)
 .S (STOP,RET)=1
"RTN","DGMTHL1",228,0)
 S:RET HARDSHIP("REVIEW")=Y
"RTN","DGMTHL1",229,0)
 Q RET
"RTN","DGMTHL1",230,0)
 ;
"RTN","DGMTHL1",231,0)
GETREAS(HARDSHIP) ;
"RTN","DGMTHL1",232,0)
 ;Asks the user to enter the hardship reason.
"RTN","DGMTHL1",233,0)
 ;
"RTN","DGMTHL1",234,0)
 ;Input:
"RTN","DGMTHL1",235,0)
 ;  HARDSHIP - hardship array (pass by reference)
"RTN","DGMTHL1",236,0)
 ;Output
"RTN","DGMTHL1",237,0)
 ;  HARDSHIP("REASON")
"RTN","DGMTHL1",238,0)
 ;
"RTN","DGMTHL1",239,0)
 N DIR
"RTN","DGMTHL1",240,0)
 S DIR(0)="FO^3:80"
"RTN","DGMTHL1",241,0)
 S DIR("A")="Hardship Reason"
"RTN","DGMTHL1",242,0)
 S DIR("B")=$G(HARDSHIP("REASON")) K:DIR("B")="" DIR("B")
"RTN","DGMTHL1",243,0)
 D ^DIR
"RTN","DGMTHL1",244,0)
 I $D(DTOUT)!$D(DUOUT) Q 0
"RTN","DGMTHL1",245,0)
 S HARDSHIP("REASON")=Y
"RTN","DGMTHL1",246,0)
 Q 1
"RTN","DGMTHL1",247,0)
 ;
"RTN","DGMTHL1",248,0)
PRIOR(HARDSHIP) ;set up for means test event driver
"RTN","DGMTHL1",249,0)
 S DFN=HARDSHIP("DFN")
"RTN","DGMTHL1",250,0)
 S DGMTI=HARDSHIP("MTIEN")
"RTN","DGMTHL1",251,0)
 S DGMTS=HARDSHIP("CURRENT STATUS")
"RTN","DGMTHL1",252,0)
 S DGMTACT="CAT"
"RTN","DGMTHL1",253,0)
 S DGMTYPT=1
"RTN","DGMTHL1",254,0)
 D PRIOR^DGMTEVT
"RTN","DGMTHL1",255,0)
 Q
"RTN","DGMTHL1",256,0)
AFTER(HARDSHIP) ;calls means test event driver
"RTN","DGMTHL1",257,0)
 D AFTER^DGMTEVT
"RTN","DGMTHL1",258,0)
 S DGMTINF=0
"RTN","DGMTHL1",259,0)
 D EN^DGMTEVT
"RTN","DGMTHL1",260,0)
 K DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTINF,DGMTP,DGMTS,DGMTYPT,I,J,Y
"RTN","DGMTHL1",261,0)
 Q
"RTN","DGMTHL1",262,0)
COMMENTS(HARDSHIP) ;
"RTN","DGMTHL1",263,0)
 ;Edit Comments protocol.
"RTN","DGMTHL1",264,0)
 ;
"RTN","DGMTHL1",265,0)
 ;Input:
"RTN","DGMTHL1",266,0)
 ;  HARDSHIP - hardship array, pass by reference
"RTN","DGMTHL1",267,0)
 ;Output:
"RTN","DGMTHL1",268,0)
 ;  none
"RTN","DGMTHL1",269,0)
 ;
"RTN","DGMTHL1",270,0)
 N DA,DIE,DR
"RTN","DGMTHL1",271,0)
 I $G(DUZ)'>1 W !,"YOUR DUZ IS NOT DEFINED!" D PAUSE^VALM1 S VALMBCK="R" Q
"RTN","DGMTHL1",272,0)
 D FULL^VALM1
"RTN","DGMTHL1",273,0)
 I $G(HARDSHIP("MTIEN")) S DR="50",DA=HARDSHIP("MTIEN"),DIE=408.31 D ^DIE
"RTN","DGMTHL1",274,0)
 D INIT^DGMTHL
"RTN","DGMTHL1",275,0)
 I VALMCNT<15 S VALMBG=1
"RTN","DGMTHL1",276,0)
 S VALMBCK="R"
"RTN","DGMTHL1",277,0)
 Q
"RTN","DGMTHL1",278,0)
 ;
"RTN","DGMTHL1",279,0)
RUSURE() ;
"RTN","DGMTHL1",280,0)
 ;Description: Asks user 'Are you sure?'
"RTN","DGMTHL1",281,0)
 ;Input: none
"RTN","DGMTHL1",282,0)
 ;Output: Function Value returns 0 or 1
"RTN","DGMTHL1",283,0)
 ;
"RTN","DGMTHL1",284,0)
 N DIR
"RTN","DGMTHL1",285,0)
 S DIR(0)="Y"
"RTN","DGMTHL1",286,0)
 S DIR("A")="Are you sure that the hardship should be deleted"
"RTN","DGMTHL1",287,0)
 S DIR("B")="NO"
"RTN","DGMTHL1",288,0)
 D ^DIR
"RTN","DGMTHL1",289,0)
 Q:$D(DIRUT) 0
"RTN","DGMTHL1",290,0)
 Q Y
"RTN","DGMTR")
0^1^B70325698
"RTN","DGMTR",1,0)
DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD,BDB - Check Means Test Requirements;7/8/05 2:30pm
"RTN","DGMTR",2,0)
 ;;5.3;Registration;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672,688,773,840,841,858**;Aug 13, 1993;Build 30
"RTN","DGMTR",3,0)
 ;A patient requires a means test under the following conditions:
"RTN","DGMTR",4,0)
 ;  - Primary Eligibility is NSC OR patient is SC 0% non-compensable
"RTN","DGMTR",5,0)
 ;  - who is NOT receiving disability retirement from the military
"RTN","DGMTR",6,0)
 ;  - who is NOT eligible for medicaid
"RTN","DGMTR",7,0)
 ;  - who is NOT on a DOM ward
"RTN","DGMTR",8,0)
 ;  - who has NOT been means tested in the past year
"RTN","DGMTR",9,0)
 ;  - who is NOT a Purple Heart recipient
"RTN","DGMTR",10,0)
 ;  - who is NOT Catastrophically Disabled
"RTN","DGMTR",11,0)
 ; 
"RTN","DGMTR",12,0)
 ; Input  -- DFN     Patient IEN
"RTN","DGMTR",13,0)
 ;           DGADDF  Means Test Add Flag  (Optional- default none)
"RTN","DGMTR",14,0)
 ;                   (1 if using the 'Add a New Means Test' option)
"RTN","DGMTR",15,0)
 ;           DGMSGF  Means Test Msg Flag  (Optional- default none)
"RTN","DGMTR",16,0)
 ;                   (1 to suppress messages)
"RTN","DGMTR",17,0)
 ;           DGNOIVMUPD No IVM Update Flag (Optional - default allow)
"RTN","DGMTR",18,0)
 ;                   (1 if updating of an IVM test is not allowed)
"RTN","DGMTR",19,0)
 ; Output -- DGREQF  Means Test Require Flag
"RTN","DGMTR",20,0)
 ;                   (1 if required and 0 if not required)
"RTN","DGMTR",21,0)
 ;           DGDOM1  DOM Patient Flag (defined and set to 1 if
"RTN","DGMTR",22,0)
 ;                               patient currently on a DOM ward)
"RTN","DGMTR",23,0)
 ;           DGNOCOPF = 1 to suppress copay test prompt 0 otherwise
"RTN","DGMTR",24,0)
 ;                      used in CP^DG10.  Killed there as well.
"RTN","DGMTR",25,0)
 ;           If NOT using the 'Add a New Means Test' option,
"RTN","DGMTR",26,0)
 ;           a REQUIRED date of test will be added for the
"RTN","DGMTR",27,0)
 ;           patient if it is required.
"RTN","DGMTR",28,0)
 ;           If a means test is required and the current
"RTN","DGMTR",29,0)
 ;           status is NO LONGER REQUIRED, the last date of
"RTN","DGMTR",30,0)
 ;           test and current means test status will be
"RTN","DGMTR",31,0)
 ;           updated to REQUIRED unless the DGNOIVMUPD flag is set to 1
"RTN","DGMTR",32,0)
 ;           and the current primary means test is an IVM test. 
"RTN","DGMTR",33,0)
 ;           If a means test is no longer required the
"RTN","DGMTR",34,0)
 ;           last date of test and the current means test
"RTN","DGMTR",35,0)
 ;           status will also be updated to NO LONGER REQUIRED unless
"RTN","DGMTR",36,0)
 ;           the DGNOIVMUPD flag is set to 1 and the current primary
"RTN","DGMTR",37,0)
 ;           means test is an IVM test.
"RTN","DGMTR",38,0)
EN N DGCS,DGDOM,DGMT0,DGMTI,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMTLTD,DGMDOD,DGMTDT
"RTN","DGMTR",39,0)
 ;DG*5.3*146 change to exit if during patient merge process
"RTN","DGMTR",40,0)
 Q:$G(VAFCA08)=1
"RTN","DGMTR",41,0)
 ;DGMTCOR is needed if uploading copay test
"RTN","DGMTR",42,0)
 I $G(RXPRIME)'="DGMTU4" N DGMTCOR
"RTN","DGMTR",43,0)
 S (DGQSENT,DGREQF)=0,(OLD,DGMTYPT)=1
"RTN","DGMTR",44,0)
 I $D(^DPT(DFN,.36)) S X=^(.36) D
"RTN","DGMTR",45,0)
 . I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DFN)) S DGREQF=1
"RTN","DGMTR",46,0)
 . I $P(X,"^",12)=1 S DGREQF=0 ;new field, DG 672
"RTN","DGMTR",47,0)
 . I $P(X,"^",13)=1 S DGREQF=0 ;new field, DG 672 
"RTN","DGMTR",48,0)
 S (DGMTI,DGMT0)="",DGMTI=+$$LST^DGMTU(DFN)
"RTN","DGMTR",49,0)
 S:DGMTI DGMT0=$G(^DGMT(408.31,DGMTI,0))
"RTN","DGMTR",50,0)
 ;Added with DG*5.3*344
"RTN","DGMTR",51,0)
 S:DGMTI DGMTDT=$P(DGMT0,U)
"RTN","DGMTR",52,0)
 S DGMDOD=$P($G(^DPT(DFN,.35)),U)
"RTN","DGMTR",53,0)
 I 'DGMTI,$G(DGMDOD) D EN^DGMTCOR S DGREQF=0 Q
"RTN","DGMTR",54,0)
 I DGREQF S:$G(^DPT(DFN,.38)) DGREQF=0
"RTN","DGMTR",55,0)
 I DGREQF D DOM S:$G(DGDOM) DGREQF=0
"RTN","DGMTR",56,0)
 S DGCS=$P(DGMT0,"^",3)
"RTN","DGMTR",57,0)
 S DGMTLTD=+DGMT0,DGNOCOPF=0
"RTN","DGMTR",58,0)
 I +$G(DGMDOD) S DGNOCOPF=1
"RTN","DGMTR",59,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTR",60,0)
 I DGCS S OLD=$$OLDMTPF^DGMTU4(+DGMT0)
"RTN","DGMTR",61,0)
 ;Purple Heart Recipient ;brm 10/02/00 added 1 line below
"RTN","DGMTR",62,0)
 I $P($G(^DPT(DFN,.53)),U)="Y" S DGREQF=0
"RTN","DGMTR",63,0)
 ;Catastrophically disabled
"RTN","DGMTR",64,0)
 I $P($G(^DPT(DFN,.39)),U,6)="Y" S DGREQF=0 ;DG*5.3*840
"RTN","DGMTR",65,0)
 ;Medal of Honor DG*5.3*840.  Functionality removed with DG*5.3*841
"RTN","DGMTR",66,0)
 ;I $P($G(^DPT(DFN,.54)),U)="Y" S DGREQF=0
"RTN","DGMTR",67,0)
 D
"RTN","DGMTR",68,0)
 .;DG*5.3*858 for 1 yr old nol means tests, if not nol, set a mt required stub  
"RTN","DGMTR",69,0)
 .I DGREQF,DGCS=3,$$OLD^DGMTU4(+DGMT0) D ADD Q
"RTN","DGMTR",70,0)
 .I DGREQF,DGCS=3,'$$OLD^DGMTU4(+DGMT0) D REQ Q
"RTN","DGMTR",71,0)
 .I DGREQF,'$G(DGADDF),((DGCS=6)!(DGCS=2)),$P(DGMT0,U,11)=1,DGMTLTD>2991005 S DGREQF=0,DGNOCOPF=1 Q
"RTN","DGMTR",72,0)
 .; next line added 2/19/02 - DG*5.3*426
"RTN","DGMTR",73,0)
 .I DGREQF,'$G(DGADDF),$G(DGCS)=6,+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGREQF=0,DGNOCOPF=1 Q
"RTN","DGMTR",74,0)
 .I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)),'$G(DGMDOD) D ADD Q
"RTN","DGMTR",75,0)
 .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(IVMZ10F) D NOL Q
"RTN","DGMTR",76,0)
 ;be sure to check whether or not patient is subject to RX copay!
"RTN","DGMTR",77,0)
 D EN^DGMTCOR
"RTN","DGMTR",78,0)
 Q
"RTN","DGMTR",79,0)
 ;Check if patient is in a DOM
"RTN","DGMTR",80,0)
 ;  call to DOM checks if patient currently on a DOM ward
"RTN","DGMTR",81,0)
 ;                                     (called from EN)
"RTN","DGMTR",82,0)
 ;  call to DOM1 checks if patient on a DOM ward for a specific date
"RTN","DGMTR",83,0)
 ;    before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
"RTN","DGMTR",84,0)
 ;                          S VAINDT=specific date
"RTN","DGMTR",85,0)
 ;                          S DFN=Patient IEN
"RTN","DGMTR",86,0)
 ;                 output - DGDOM & DGDOM1 (defined and set to 1 if
"RTN","DGMTR",87,0)
 ;                          patient on a DOM ward for specific date)
"RTN","DGMTR",88,0)
DOM N VAINDT,VADMVT
"RTN","DGMTR",89,0)
DOM1 D ADM^VADPT2
"RTN","DGMTR",90,0)
 I VADMVT,$P($G(^DG(43,1,0)),"^",21),$D(^DIC(42,+$P($G(^DGPM(VADMVT,0)),"^",6),0)),$P(^(0),"^",3)="D" S (DGDOM,DGDOM1)=1
"RTN","DGMTR",91,0)
 Q
"RTN","DGMTR",92,0)
SC(DFN) ;Check if patient is SC 0% non-compensable
"RTN","DGMTR",93,0)
 ; Input  -- DFN     Patient IEN
"RTN","DGMTR",94,0)
 ; Output -- 1=Yes and 0=No
"RTN","DGMTR",95,0)
 ;     No if:
"RTN","DGMTR",96,0)
 ;        No total annual VA check amount
"RTN","DGMTR",97,0)
 ;        POW STATUS INDICATOR is yes
"RTN","DGMTR",98,0)
 ;        Secondary Eligibility is one of the following:
"RTN","DGMTR",99,0)
 ;           A&A, NSC, VA PENSION
"RTN","DGMTR",100,0)
 ;           HOUSEBOUND, MEXICAN BORDER WAR, WWI, POW
"RTN","DGMTR",101,0)
 N DG,DGE,DGF,Y
"RTN","DGMTR",102,0)
 S Y=0
"RTN","DGMTR",103,0)
 ;Primary eligibility is SC LESS THAN 50%
"RTN","DGMTR",104,0)
 I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
"RTN","DGMTR",105,0)
 G:'Y SCQ
"RTN","DGMTR",106,0)
 ;Service connected percentage is 0
"RTN","DGMTR",107,0)
 I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
"RTN","DGMTR",108,0)
 ;No Total annual VA check amount
"RTN","DGMTR",109,0)
 I $P($G(^DPT(DFN,.362)),"^",20) S Y=0 G SCQ
"RTN","DGMTR",110,0)
 ;POW STATUS INDICATOR
"RTN","DGMTR",111,0)
 I $P($G(^DPT(DFN,.52)),"^",5)="Y" S Y=0 G SCQ
"RTN","DGMTR",112,0)
 ;Purple Heart Indicator
"RTN","DGMTR",113,0)
 I $P($G(^DPT(DFN,.53)),"^")="Y" S Y=0 G SCQ
"RTN","DGMTR",114,0)
 ;Secondary Eligibility
"RTN","DGMTR",115,0)
 F DG=2,4,15:1:18 S DGE(DG)=""
"RTN","DGMTR",116,0)
 S DG=0 F  S DG=$O(^DPT(DFN,"E","B",DG)) Q:'DG  D SELIG I DGF,$D(DGE(+DGF)) S Y=0 Q
"RTN","DGMTR",117,0)
SCQ Q +$G(Y)
"RTN","DGMTR",118,0)
ADD ;Add a required means test
"RTN","DGMTR",119,0)
 N DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTP,ERROR
"RTN","DGMTR",120,0)
 W:'$G(DGMSGF) !,"MEANS TEST REQUIRED"
"RTN","DGMTR",121,0)
 S DGMTACT="ADD" D PRIOR^DGMTEVT
"RTN","DGMTR",122,0)
 S DGMTDT=DT D ADD^DGMTA
"RTN","DGMTR",123,0)
 I DGMTI>0 S DGMTYPT=1 D
"RTN","DGMTR",124,0)
 .N DATA S DATA(.03)=$$GETSTAT^DGMTH("R",1) I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
"RTN","DGMTR",125,0)
 .D GETINCOM^DGMTU4(DFN,DT)
"RTN","DGMTR",126,0)
 .D QUE
"RTN","DGMTR",127,0)
 I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
"RTN","DGMTR",128,0)
 Q
"RTN","DGMTR",129,0)
REQ ;Update means test status to REQUIRED
"RTN","DGMTR",130,0)
 N DGMTA,AUTOCOMP,DGMTE,ERROR
"RTN","DGMTR",131,0)
 ;may have set prior MT for means test upload
"RTN","DGMTR",132,0)
 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTR",133,0)
 S AUTOCOMP=$$AUTOCOMP(DGMTI)
"RTN","DGMTR",134,0)
 ;if a test were auto-completed, don't want another being added inadvertently
"RTN","DGMTR",135,0)
 I AUTOCOMP,$G(DGADDF) S DGADDF=0
"RTN","DGMTR",136,0)
 I AUTOCOMP S DGCS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
"RTN","DGMTR",137,0)
 I $G(IVMZ10)'="UPLOAD IN PROGRESS",'AUTOCOMP,'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
"RTN","DGMTR",138,0)
 I ('AUTOCOMP),('$G(DGMSGF)) W !,"MEANS TEST REQUIRED"
"RTN","DGMTR",139,0)
 I (AUTOCOMP),('$G(DGMSGF)) W !,"CURRENT MEANS TEST STATUS IS ",$$GETNAME^DGMTH(DGCS)
"RTN","DGMTR",140,0)
 S DGMTYPT=1
"RTN","DGMTR",141,0)
 D QUE
"RTN","DGMTR",142,0)
 Q
"RTN","DGMTR",143,0)
AUTOCOMP(DGMTI) ;
"RTN","DGMTR",144,0)
 ;Will either automatically complete the test (RX copay or means test) 
"RTN","DGMTR",145,0)
 ;based on the Test Determined Status, or will change the status to
"RTN","DGMTR",146,0)
 ;Required for means tests or Incomplete for Rx copay tests
"RTN","DGMTR",147,0)
 ;Input:
"RTN","DGMTR",148,0)
 ;  DGMTI - the ien of the test
"RTN","DGMTR",149,0)
 ;Output:
"RTN","DGMTR",150,0)
 ;  Function value - 1 if the test was completed, 0 otherwise
"RTN","DGMTR",151,0)
 N NODE0,NODE2,DATA,RET,LINKIEN,DGINR,DGINI,ERROR,CODE,TYPE,DFN,TDATE
"RTN","DGMTR",152,0)
 S RET=0
"RTN","DGMTR",153,0)
 Q:'$G(DGMTI) RET
"RTN","DGMTR",154,0)
 S NODE0=$G(^DGMT(408.31,DGMTI,0))
"RTN","DGMTR",155,0)
 Q:(NODE0="") RET
"RTN","DGMTR",156,0)
 S TYPE=$P(NODE0,"^",19)
"RTN","DGMTR",157,0)
 S DFN=$P(NODE0,"^",2)
"RTN","DGMTR",158,0)
 S TDATE=+NODE0
"RTN","DGMTR",159,0)
 S NODE2=$G(^DGMT(408.31,DGMTI,2))
"RTN","DGMTR",160,0)
 ;get test-determined status code
"RTN","DGMTR",161,0)
 S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
"RTN","DGMTR",162,0)
 ;if means test
"RTN","DGMTR",163,0)
 I TYPE=1 D
"RTN","DGMTR",164,0)
 .S DATA(.03)=$$GETSTAT^DGMTH("R",1),DATA(.17)=""
"RTN","DGMTR",165,0)
 .I (CODE'=""),"ACGP"[CODE D
"RTN","DGMTR",166,0)
 ..S RET=1
"RTN","DGMTR",167,0)
 ..S DATA(.03)=$P(NODE2,"^",3)
"RTN","DGMTR",168,0)
 ..;determine status if there is a hardship
"RTN","DGMTR",169,0)
 ..I $P(NODE0,"^",20) D
"RTN","DGMTR",170,0)
 ...S DATA(.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="C"&($P(NODE0,U,27)>$P(NODE0,U,12)):"G",1:"A"),1)
"RTN","DGMTR",171,0)
 .I (CODE="")!(CODE'=""&"ACGP"'[CODE) D
"RTN","DGMTR",172,0)
 ..; Check for another test in the current year and convert IAI records, if needed
"RTN","DGMTR",173,0)
 ..S CONVRT=$$VRCHKUP^DGMTU2(1,,TDATE)
"RTN","DGMTR",174,0)
 ..S DATA(2.11)=1
"RTN","DGMTR",175,0)
 ;RX copay test
"RTN","DGMTR",176,0)
 I TYPE=2 D
"RTN","DGMTR",177,0)
 .S DATA(.03)=$$GETSTAT^DGMTH("I",2),DATA(.17)=""
"RTN","DGMTR",178,0)
 .I (CODE'=""),"EM"[CODE D
"RTN","DGMTR",179,0)
 ..S RET=1
"RTN","DGMTR",180,0)
 ..S DATA(.03)=$P(NODE2,"^",3)
"RTN","DGMTR",181,0)
 .I (CODE="")!(CODE'=""&"EM"'[CODE) D
"RTN","DGMTR",182,0)
 ..; Check for another test in the current year and convert IAI records, if needed
"RTN","DGMTR",183,0)
 ..S CONVRT=$$VRCHKUP^DGMTU2(2,,TDATE)
"RTN","DGMTR",184,0)
 ..S DATA(2.11)=1
"RTN","DGMTR",185,0)
 I '$$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR) W:'$G(DGMSGF) ERROR
"RTN","DGMTR",186,0)
 ;restore the pointers from the Income Relation file (408.22) to this
"RTN","DGMTR",187,0)
 ;test, using the linked test
"RTN","DGMTR",188,0)
 S LINKIEN=$P(NODE2,"^",6)
"RTN","DGMTR",189,0)
 I LINKIEN D
"RTN","DGMTR",190,0)
 .S DGINI=0 F  S DGINI=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI)) Q:'DGINI  S DGINR=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
"RTN","DGMTR",191,0)
 ..K DATA
"RTN","DGMTR",192,0)
 ..S DATA(31)=DGMTI
"RTN","DGMTR",193,0)
 ..I $$UPD^DGENDBS(408.22,+DGINR,.DATA)
"RTN","DGMTR",194,0)
 D GETINCOM^DGMTU4(DFN,TDATE)
"RTN","DGMTR",195,0)
 Q RET
"RTN","DGMTR",196,0)
NOL ;Update means test status to NO LONGER REQUIRED
"RTN","DGMTR",197,0)
 N DGMTA,DGINI,DGINR,DGMTDT,DATA
"RTN","DGMTR",198,0)
 I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D  G NOLQ ; Check for converted IVM MT
"RTN","DGMTR",199,0)
 . ;I '$G(DGMSGF),$G(DGNOIVMUPD)<2 W !,"IVM MEANS TEST EXISTS, BUT VISTA CALCULATES 'NO LONGER REQUIRED'",!,"CONTACT IVM TO CLEAR UP THE DISCREPANCY - YOU CANNOT UPDATE AN IVM TEST"
"RTN","DGMTR",200,0)
 . S DGNOIVMUPD=2 ; Prevent double printing of the message
"RTN","DGMTR",201,0)
 W:'$G(DGMSGF) !,"MEANS TEST NO LONGER REQUIRED"
"RTN","DGMTR",202,0)
 ;may have set prior MT for means test upload
"RTN","DGMTR",203,0)
 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTR",204,0)
 ;save the Test Determined Status
"RTN","DGMTR",205,0)
 D SAVESTAT^DGMTU4(DGMTI)
"RTN","DGMTR",206,0)
 S DATA(.03)=3,DATA(.17)=DT I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
"RTN","DGMTR",207,0)
 D QUE
"RTN","DGMTR",208,0)
 ;create a Rx copay test based on MT if needed
"RTN","DGMTR",209,0)
 D COPYRX^DGMTR1(DFN,DGMTI)
"RTN","DGMTR",210,0)
NOLQ Q
"RTN","DGMTR",211,0)
SET ;Set Cross-reference
"RTN","DGMTR",212,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGMTR",213,0)
 S DA=DGIEN,X=DGVAL,DGIX=0
"RTN","DGMTR",214,0)
 F  S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX  X ^(DGIX,1) S X=DGVAL
"RTN","DGMTR",215,0)
 Q
"RTN","DGMTR",216,0)
KILL ;Kill Cross-reference
"RTN","DGMTR",217,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGMTR",218,0)
 S DA=DGIEN,X=DGVAL,DGIX=0
"RTN","DGMTR",219,0)
 F  S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX  X ^(DGIX,2) S X=DGVAL
"RTN","DGMTR",220,0)
 Q
"RTN","DGMTR",221,0)
QUE ;Queue means test event driver
"RTN","DGMTR",222,0)
 D AFTER^DGMTEVT
"RTN","DGMTR",223,0)
 S ZTDESC="MEANS TEST EVENT DRIVER",ZTDTH=$H,ZTRTN="EN^DGMTEVT"
"RTN","DGMTR",224,0)
 F I="DFN","DGMTACT","DGMTI","DGMTP","DGMTA","DGMTYPT" S ZTSAVE(I)=""
"RTN","DGMTR",225,0)
 S ZTSAVE("DGMTINF")=1
"RTN","DGMTR",226,0)
 I $D(IVMZ10) S ZTSAVE("IVMZ10")=""
"RTN","DGMTR",227,0)
 I $D(DGENUPLD) S ZTSAVE("DGENUPLD")=""
"RTN","DGMTR",228,0)
 S ZTIO="" D ^%ZTLOAD
"RTN","DGMTR",229,0)
 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","DGMTR",230,0)
 Q
"RTN","DGMTR",231,0)
SELIG ;Check if secondary eligibility code missing from ELIGIBILITY CODE
"RTN","DGMTR",232,0)
 ;file (#8) or entry in file #8 not pointing to MAS ELIGIBILITY
"RTN","DGMTR",233,0)
 ;CODE file (#8.1)
"RTN","DGMTR",234,0)
 N DGTXT
"RTN","DGMTR",235,0)
 S DGF=$G(^DIC(8,+DG,0)) I DGF="" D  Q
"RTN","DGMTR",236,0)
 .S DGTXT(4)="Entry with an IEN OF "_DG_" missing from"
"RTN","DGMTR",237,0)
 .S DGTXT(5)="the ELIGIBILITY CODE file (#8)"
"RTN","DGMTR",238,0)
 .D MAIL^DGMTR1
"RTN","DGMTR",239,0)
 .Q
"RTN","DGMTR",240,0)
 S DGF=$P(DGF,"^",9) I DGF=""!('$D(^DIC(8.1,+DGF,0))) D
"RTN","DGMTR",241,0)
 .S DGTXT(4)="ELIGIBILITY CODE file (#8) entry with an IEN OF "_DG_" doesn't"
"RTN","DGMTR",242,0)
 .S DGTXT(5)="have a valid pointer to the MAS ELIGIBILITY CODE file (#8.1)"
"RTN","DGMTR",243,0)
 .D MAIL^DGMTR1
"RTN","DGMTR",244,0)
 .S DGF=""
"RTN","DGMTR",245,0)
 .Q
"RTN","DGMTR",246,0)
 Q
"RTN","DGMTR1")
0^2^B32852422
"RTN","DGMTR1",1,0)
DGMTR1 ;ALB/CJM,SCG,LBD,BDB - Check Means Test Requirements Cont'd;3/25/92  09:51
"RTN","DGMTR1",2,0)
 ;;5.3;Registration;**182,344,433,456,564,688,840,858**;Aug 13, 1993;Build 30
"RTN","DGMTR1",3,0)
 ;
"RTN","DGMTR1",4,0)
COPYRX(DFN,MTIEN) ;
"RTN","DGMTR1",5,0)
 ;Creates a Pharmacy Copay test based on the means test if the vet is
"RTN","DGMTR1",6,0)
 ;subject to the Rx copayment and the income screening was already
"RTN","DGMTR1",7,0)
 ;completed
"RTN","DGMTR1",8,0)
 ;1/16/2002 - Changes added for LTC Copay Phase II (DG*5.3*433)
"RTN","DGMTR1",9,0)
 ;Creates a Pharmacy Copay test based on a LTC copay exemption test
"RTN","DGMTR1",10,0)
 ;(type 4) if the veteran is exempt from means test
"RTN","DGMTR1",11,0)
 ;
"RTN","DGMTR1",12,0)
 N NODE0,RXSTATUS,Y,DGMT,DGMTYPT,DGNODE,DATA,SUB,COMMENTS,RXIEN,DGMTACT,DGMTI,DGMTP,DGMTA,NODE2,CODE,QUIT,TRIES,ERROR,TYPE
"RTN","DGMTR1",13,0)
 ;
"RTN","DGMTR1",14,0)
 S DGMTP="",DGMTACT="ADD"
"RTN","DGMTR1",15,0)
 D ON^DGMTCOU G:'Y COPYRXQ
"RTN","DGMTR1",16,0)
 I $$CHK(DFN) D
"RTN","DGMTR1",17,0)
 .S NODE0=$G(^DGMT(408.31,MTIEN,0))
"RTN","DGMTR1",18,0)
 .Q:NODE0=""
"RTN","DGMTR1",19,0)
 .S NODE2=$G(^DGMT(408.31,MTIEN,2))
"RTN","DGMTR1",20,0)
 .;
"RTN","DGMTR1",21,0)
 .;get type of test (1=means test; 4=LTC copay exemption test)
"RTN","DGMTR1",22,0)
 .S TYPE=$P(NODE0,"^",19)
"RTN","DGMTR1",23,0)
 .;
"RTN","DGMTR1",24,0)
 .;must have been completed
"RTN","DGMTR1",25,0)
 .S CODE=$$GETCODE^DGMTH($P(NODE0,"^",3))
"RTN","DGMTR1",26,0)
 .S QUIT=1
"RTN","DGMTR1",27,0)
 .I (CODE'=""),("ACGP01"[CODE) S QUIT=0
"RTN","DGMTR1",28,0)
 .S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
"RTN","DGMTR1",29,0)
 .I (CODE'=""),("ACGP01"[CODE) S QUIT=0
"RTN","DGMTR1",30,0)
 .Q:QUIT
"RTN","DGMTR1",31,0)
 .;
"RTN","DGMTR1",32,0)
 .;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTR1",33,0)
 .;Q:($$FMDIFF^XLFDT(DT,$P(NODE0,"^"))>365)
"RTN","DGMTR1",34,0)
 .Q:$$OLDMTPF^DGMTU4($P(NODE0,"^"))
"RTN","DGMTR1",35,0)
 .Q:($P(NODE0,"^",14))  ;declined to provide income information
"RTN","DGMTR1",36,0)
 .Q:($P(NODE0,"^",26))  ;refused to sign the test
"RTN","DGMTR1",37,0)
 .F TRIES=1:1 D  Q:(TRIES>3)
"RTN","DGMTR1",38,0)
 ..S DGNODE=$$LST^DGMTU(DFN,$S((DT>$P(NODE0,"^",2)):DT,1:$P(NODE0,"^",2)),2),RXIEN=+DGNODE
"RTN","DGMTR1",39,0)
 ..;
"RTN","DGMTR1",40,0)
 ..;mark existing test as non-primary
"RTN","DGMTR1",41,0)
 ..I RXIEN,($E($P(DGNODE,"^",2),1,3)=$E($P(NODE0,"^"),1,3)) D
"RTN","DGMTR1",42,0)
 ...S DATA(2)=0 I $$UPD^DGENDBS(408.31,RXIEN,.DATA)
"RTN","DGMTR1",43,0)
 ..E  S TRIES=4
"RTN","DGMTR1",44,0)
 .;
"RTN","DGMTR1",45,0)
 .S RXIEN=$P(NODE2,"^",6)
"RTN","DGMTR1",46,0)
 .;if already copied, reuse the same record
"RTN","DGMTR1",47,0)
 .I RXIEN,$P($G(^DGMT(408.31,RXIEN,2)),"^",6)=MTIEN D
"RTN","DGMTR1",48,0)
 ..S DGMTI=RXIEN
"RTN","DGMTR1",49,0)
 ..; Check for another test in the current year and convert IAI records, if needed
"RTN","DGMTR1",50,0)
 ..S CONVRT=$$VRCHKUP^DGMTU2(2,TYPE,$P(^DGMT(408.31,MTIEN,0),"^"),$P(^DGMT(408.31,RXIEN,0),"^"))
"RTN","DGMTR1",51,0)
 .E  D  Q:'DGMTI
"RTN","DGMTR1",52,0)
 ..;This call works. Adding via the ADD^DGENDBS encountered an error
"RTN","DGMTR1",53,0)
 ..S DGMTDT=$P(NODE0,"^") S DGMTYPT=2 D ADD^DGMTA
"RTN","DGMTR1",54,0)
 .;
"RTN","DGMTR1",55,0)
 .S DATA(.019)=2
"RTN","DGMTR1",56,0)
 .S DATA(.03)=""
"RTN","DGMTR1",57,0)
 .F SUB=.01,.02,.04,.05,.06,.07,.14,.15,.18,.23,.24,.25 S DATA(SUB)=$P(NODE0,"^",(SUB/.01))
"RTN","DGMTR1",58,0)
 .S DATA(2)=1
"RTN","DGMTR1",59,0)
 .S DATA(2.02)=$P(NODE2,"^",2)
"RTN","DGMTR1",60,0)
 .S DATA(2.05)=$P(NODE2,"^",5)
"RTN","DGMTR1",61,0)
 .I TYPE=1 D
"RTN","DGMTR1",62,0)
 ..S DATA(2.06)=MTIEN
"RTN","DGMTR1",63,0)
 ..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed means test"
"RTN","DGMTR1",64,0)
 ..S COMMENTS("LINES",2,0)="which was changed to NO LONGER REQUIRED. All data including income"
"RTN","DGMTR1",65,0)
 ..S COMMENTS("LINES",3,0)="screening was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
"RTN","DGMTR1",66,0)
 .I TYPE=4 D
"RTN","DGMTR1",67,0)
 ..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed"
"RTN","DGMTR1",68,0)
 ..S COMMENTS("LINES",2,0)="LTC copay exemption test. All data including income screening"
"RTN","DGMTR1",69,0)
 ..S COMMENTS("LINES",3,0)="was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
"RTN","DGMTR1",70,0)
 .S DATA(50)="COMMENTS(""LINES"")"
"RTN","DGMTR1",71,0)
 .S (DATA(.03),DATA(2.03))=$$RXSTATUS(MTIEN)
"RTN","DGMTR1",72,0)
 .S DATA(2.11)=1
"RTN","DGMTR1",73,0)
 .I $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
"RTN","DGMTR1",74,0)
 .K DATA
"RTN","DGMTR1",75,0)
 .S:TYPE=1 DATA(2.06)=DGMTI
"RTN","DGMTR1",76,0)
 .S:TYPE=4 DATA(2.08)=DGMTI
"RTN","DGMTR1",77,0)
 .I $$UPD^DGENDBS(408.31,MTIEN,.DATA,.ERROR)
"RTN","DGMTR1",78,0)
 .D TRANSFER^DGMTU4(DFN,MTIEN,DGMTI)
"RTN","DGMTR1",79,0)
 .D QUE^DGMTR
"RTN","DGMTR1",80,0)
COPYRXQ ;
"RTN","DGMTR1",81,0)
 K ERROR
"RTN","DGMTR1",82,0)
 Q
"RTN","DGMTR1",83,0)
 ;
"RTN","DGMTR1",84,0)
RXSTATUS(MTIEN) ;
"RTN","DGMTR1",85,0)
 ;Determins RX Copay Status based on the means test
"RTN","DGMTR1",86,0)
 ;
"RTN","DGMTR1",87,0)
 Q:('$G(MTIEN)) ""
"RTN","DGMTR1",88,0)
 N NODE0,NODE,PIECE,IBSTATUS,MTSTATUS
"RTN","DGMTR1",89,0)
 S NODE0=$G(^DGMT(408.31,MTIEN,0))
"RTN","DGMTR1",90,0)
 Q:(NODE0="") ""
"RTN","DGMTR1",91,0)
 F PIECE=1,2,4,5,14,15,18 S $P(NODE,"^",PIECE)=$P(NODE0,"^",PIECE)
"RTN","DGMTR1",92,0)
 S $P(NODE,"^",19)=2
"RTN","DGMTR1",93,0)
 S IBSTATUS=+$$INCDT^IBARXEU1(NODE)
"RTN","DGMTR1",94,0)
 S MTSTATUS=$S(IBSTATUS=1:"E",IBSTATUS=2:"M",1:"")
"RTN","DGMTR1",95,0)
 Q:(MTSTATUS="") ""
"RTN","DGMTR1",96,0)
 Q $O(^DG(408.32,"AC",2,MTSTATUS,0))
"RTN","DGMTR1",97,0)
 ;
"RTN","DGMTR1",98,0)
CHK(DFN) ;
"RTN","DGMTR1",99,0)
 ;can the veteran take a RX copay test?
"RTN","DGMTR1",100,0)
 N DGMTI,DGMTCOR,DGNODE,DGELIG,DGI,DGE
"RTN","DGMTR1",101,0)
 S DGMTCOR=1
"RTN","DGMTR1",102,0)
 ;
"RTN","DGMTR1",103,0)
 I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0 G CHKQ ;NON-VET
"RTN","DGMTR1",104,0)
 S DGI=$P($G(^DPT(DFN,.36)),U) I 'DGI S DGMTCOR=0 G CHKQ ;NO PRIM ELIG
"RTN","DGMTR1",105,0)
 S DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U
"RTN","DGMTR1",106,0)
 S DGI=0 F  S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI  S DGE=$P($G(^DPT(DFN,"E",DGI,0)),U),DGELIG=DGELIG_$P($G(^DIC(8,+DGE,0)),U,9)_U
"RTN","DGMTR1",107,0)
 I (DGELIG["^1^") S DGMTCOR=0 G CHKQ  ;SC 50-100%
"RTN","DGMTR1",108,0)
 F DGI=.3,.362,.39,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI))
"RTN","DGMTR1",109,0)
 I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0 G CHKQ ;A&A
"RTN","DGMTR1",110,0)
 I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0 G CHKQ ;HB
"RTN","DGMTR1",111,0)
 I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0 G CHKQ ;PENSION
"RTN","DGMTR1",112,0)
 I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0 G CHKQ ;POW
"RTN","DGMTR1",113,0)
 I $P(DGNODE(.39),U,6)["Y"!(DGELIG["^21^") S DGMTCOR=0 G CHKQ ;CD DG*5.3*840
"RTN","DGMTR1",114,0)
 I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0 G CHKQ ;UNEMPLOYABLE
"RTN","DGMTR1",115,0)
CHKQ ;
"RTN","DGMTR1",116,0)
 Q DGMTCOR
"RTN","DGMTR1",117,0)
MAIL ; Send a mailman msg to user/ INCONSISTENCY EDIT GROUP with results
"RTN","DGMTR1",118,0)
 N %,DGB,I,VA,VADM,VAERR,Y,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
"RTN","DGMTR1",119,0)
 D DEM^VADPT
"RTN","DGMTR1",120,0)
 S XMSUB="Patient "_VADM(1)_" has an invalid secondary eligibility"
"RTN","DGMTR1",121,0)
 S XMDUZ="PIMS PACKAGE",XMY(DUZ)="",XMY(.5)=""
"RTN","DGMTR1",122,0)
 S DGB=+$P($G(^DG(43,1,"NOT")),"^",6)
"RTN","DGMTR1",123,0)
 I $D(^XMB(3.8,DGB,0)) S XMY("G."_$P($G(^XMB(3.8,DGB,0)),"^"))=""
"RTN","DGMTR1",124,0)
 S XMTEXT="DGTXT("
"RTN","DGMTR1",125,0)
 D NOW^%DTC S Y=% D DD^%DT
"RTN","DGMTR1",126,0)
 S DGTXT(1)="On "_Y_"  "_VADM(1)_" ("_VA("BID")_")"
"RTN","DGMTR1",127,0)
 S DGTXT(2)="has an invalid secondary eligibility"
"RTN","DGMTR1",128,0)
 S DGTXT(3)="  "
"RTN","DGMTR1",129,0)
 ;que mailman message
"RTN","DGMTR1",130,0)
 N DIFROM,I,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","DGMTR1",131,0)
 F I="DGTXT(","XMDUZ","XMSUB","XMTEXT","XMY(" S ZTSAVE(I)=""
"RTN","DGMTR1",132,0)
 S ZTDESC="MAILMAN MSG FOR INVALID ELIGIBILITY CODE FILE ENTRIES"
"RTN","DGMTR1",133,0)
 S ZTDTH=$$NOW^XLFDT(),ZTIO="",ZTRTN="^XMD"
"RTN","DGMTR1",134,0)
 D ^%ZTLOAD
"RTN","DGMTR1",135,0)
 Q
"RTN","DGMTU")
0^3^B55660004
"RTN","DGMTU",1,0)
DGMTU ;ALB/RMO,LBD,BRM,EG,BDB - Means Test Utilities ; 02/08/2005 07:10 AM
"RTN","DGMTU",2,0)
 ;;5.3;Registration;**4,33,182,277,290,374,358,420,426,411,332,433,456,476,519,451,630,783,799,834,858**;Aug 13, 1993;Build 30
"RTN","DGMTU",3,0)
 ;MT=Means Test
"RTN","DGMTU",4,0)
LST(DFN,DGDT,DGMTYPT) ;Last MT for a patient
"RTN","DGMTU",5,0)
 ;         Input  -- DFN   Patient IEN
"RTN","DGMTU",6,0)
 ;                   DGDT  Date/Time  (Optional- default today@2359)
"RTN","DGMTU",7,0)
 ;                DGMTYPT  Type of Test (Optional - if not defined 
"RTN","DGMTU",8,0)
 ;                                       Means Test will be assumed)
"RTN","DGMTU",9,0)
 ;         Output -- Annual Means Test IEN^Date of Test
"RTN","DGMTU",10,0)
 ;                   ^Status Name^Status Code^Source of Test
"RTN","DGMTU",11,0)
 N DGIDT,DGMTFL1,DGMTI,DGNOD,Y I '$D(DGMTYPT) S DGMTYPT=1
"RTN","DGMTU",12,0)
 S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
"RTN","DGMTU",13,0)
 F  S DGIDT=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT)) Q:'DGIDT!$G(DGMTFL1)  D
"RTN","DGMTU",14,0)
 .F DGMTI=0:0 S DGMTI=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT,DGMTI)) Q:'DGMTI!$G(DGMTFL1)  D
"RTN","DGMTU",15,0)
 ..S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD,$G(^("PRIM"))!(DGMTYPT=4) S DGMTFL1=1,Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS(DFN,+$P(^(0),"^",3))_"^"_$P(DGNOD,"^",23) ; chk for primary MT
"RTN","DGMTU",16,0)
 Q $G(Y)
"RTN","DGMTU",17,0)
 ;
"RTN","DGMTU",18,0)
LVMT(DFN,DGDT) ;Last valid MT (status other than required)
"RTN","DGMTU",19,0)
 ;          Input  -- DFN    Patient IEN
"RTN","DGMTU",20,0)
 ;                    DGDT   Date (Optional - default today)
"RTN","DGMTU",21,0)
 ;          Output -- Annual Means Test IEN^Date of Test^Status Name
"RTN","DGMTU",22,0)
 ;                     ^Status Code
"RTN","DGMTU",23,0)
 N DGMT,DGMTL
"RTN","DGMTU",24,0)
 S:'$D(DGDT) DGDT=DT S DGMTL=$$LST^DGMTU(DFN,DGDT)
"RTN","DGMTU",25,0)
 I $P(DGMTL,"^",4)="R" F  S DGMT=$$LST^DGMTU(DFN,DGDT) Q:DGMT']""!($P(DGMT,U,4)'="R")  S DGDT=$P(DGMT,U,2)-1
"RTN","DGMTU",26,0)
 Q $S($G(DGMT)]"":DGMT,1:$G(DGMTL))
"RTN","DGMTU",27,0)
 ;
"RTN","DGMTU",28,0)
NVMT(DFN,DGDT) ;Next valid MT (status other than required)
"RTN","DGMTU",29,0)
 ;          Input  -- DFN    Patient IEN
"RTN","DGMTU",30,0)
 ;                    DGDT   Date (Required)
"RTN","DGMTU",31,0)
 ;          Output -- Annual Means Test IEN^Date of Test^Status Name
"RTN","DGMTU",32,0)
 ;                     ^Status Code
"RTN","DGMTU",33,0)
 N DGDTE,DGMT,DGMT0,DGMTI,DGMTPR,DGMTS
"RTN","DGMTU",34,0)
 S DGDTE=DGDT
"RTN","DGMTU",35,0)
 F  S DGDTE=$O(^DGMT(408.31,"AD",1,DFN,DGDTE)) Q:'DGDTE!$G(DGMT)  D
"RTN","DGMTU",36,0)
 .F DGMTI=0:0 S DGMTI=$O(^DGMT(408.31,"AD",1,DFN,DGDTE,DGMTI)) Q:'DGMTI  S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTS=+$P(DGMT0,"^",3),DGMTPR=$G(^("PRIM")) I +DGMT0,DGMTS'=1,DGMTPR S DGMT=DGMTI_"^"_+DGMT0_"^"_$$MTS^DGMTU(DFN,DGMTS) Q
"RTN","DGMTU",37,0)
 Q $G(DGMT)
"RTN","DGMTU",38,0)
 ;
"RTN","DGMTU",39,0)
MTS(DFN,DGMTS) ;MT status -- default current
"RTN","DGMTU",40,0)
 ;         Input  -- DFN    Patient IEN
"RTN","DGMTU",41,0)
 ;                   DGMTS  Means Test Status IEN  (Optional)
"RTN","DGMTU",42,0)
 ;         Output -- Status Name^Status Code
"RTN","DGMTU",43,0)
 N Y
"RTN","DGMTU",44,0)
 S DGMTS=$S($G(DGMTS)>0:DGMTS,1:$P($G(^DPT(DFN,0)),"^",14))
"RTN","DGMTU",45,0)
 I DGMTS S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2)
"RTN","DGMTU",46,0)
 Q $G(Y)
"RTN","DGMTU",47,0)
 ;
"RTN","DGMTU",48,0)
DIS(DFN) ;Display patients current MT status,
"RTN","DGMTU",49,0)
 ;        eligibility for care, deductible information,
"RTN","DGMTU",50,0)
 ;        date of test and date of completion
"RTN","DGMTU",51,0)
 ;         Input  -- DFN    Patient IEN
"RTN","DGMTU",52,0)
 ;         Output -- None
"RTN","DGMTU",53,0)
 N DGCS,DGDED,DGMTI,DGMT0
"RTN","DGMTU",54,0)
 S DGCS=$P($G(^DPT(DFN,0)),"^",14) G DISQ:DGCS=""
"RTN","DGMTU",55,0)
 S DGMTI=+$$LST^DGMTU(DFN),DGMT0=$G(^DGMT(408.31,DGMTI,0))
"RTN","DGMTU",56,0)
 S MTSIG=$P(DGMT0,"^",29)
"RTN","DGMTU",57,0)
 W !,"Means Test Signed?: ",$S(MTSIG=1:"YES",MTSIG=0:"NO",MTSIG=9:"DELETED",1:"")
"RTN","DGMTU",58,0)
 I DGCS=1 W !!,"Patient Requires a Means Test"
"RTN","DGMTU",59,0)
 I DGCS=2 W !!,"Patient's Means Test is Pending Adjudication for "_$$PA^DGMTUTL(DGMTI)
"RTN","DGMTU",60,0)
 I DGCS=3 W !!,"Means Test Not Required"
"RTN","DGMTU",61,0)
 I ("^4^5^6^16^")[("^"_DGCS_"^") W !!,"Patient's status is ",$$GETNAME^DGMTH(DGCS)," based on primary means test"
"RTN","DGMTU",62,0)
 I $D(^DG(408.32,DGCS,"MSG")) W !,^("MSG")
"RTN","DGMTU",63,0)
 I DGCS=6 S DGDED=$P(DGMT0,"^",11) W ! W:DGDED]"" "Has",$S(DGDED:"",1:" not")," agreed to pay the deductible"
"RTN","DGMTU",64,0)
 S Y=$P(DGMT0,"^") X ^DD("DD") W !,"Primary Means Test ",$S(DGCS=1:"Required from",1:"Last Applied")," '",Y,"'"
"RTN","DGMTU",65,0)
 I ("^2^4^5^6^16^")[("^"_DGCS_"^") S Y=$P(DGMT0,"^",7) X ^DD("DD") W " (COMPLETED: ",Y,")"
"RTN","DGMTU",66,0)
 I DGCS=3 S Y=$P(DGMT0,"^",17) X ^DD("DD") W " (NO LONGER REQUIRED: ",Y,")"
"RTN","DGMTU",67,0)
DISQ Q
"RTN","DGMTU",68,0)
 ;
"RTN","DGMTU",69,0)
EDT(DFN,DGDT) ;Display patients current MT information and provide
"RTN","DGMTU",70,0)
 ;        the user with the option of proceeding with a required
"RTN","DGMTU",71,0)
 ;        MT or editing an existing means test
"RTN","DGMTU",72,0)
 ;         Input  -- DFN    Patient IEN
"RTN","DGMTU",73,0)
 ;                   DGDT   Date/Time
"RTN","DGMTU",74,0)
 ;         Output -- None
"RTN","DGMTU",75,0)
 ;
"RTN","DGMTU",76,0)
 ; obtain lock used to synchronize local MT/CT options with income test upload
"RTN","DGMTU",77,0)
 ; '+' added to VSITE check to allow divisions to edit parent owned tests
"RTN","DGMTU",78,0)
 N VSITE
"RTN","DGMTU",79,0)
 I $$LOCK^DGMTUTL(DFN)
"RTN","DGMTU",80,0)
 ;
"RTN","DGMTU",81,0)
 D DIS(DFN)
"RTN","DGMTU",82,0)
 S DGMTI=+$$LST(DFN,DGDT),VSITE=+$P($$SITE^VASITE(),U,3)
"RTN","DGMTU",83,0)
 G EDTQ:'DGMTI!(DGMTI'=+$$LST^DGMTU(DFN))
"RTN","DGMTU",84,0)
 I +$P($G(^DGMT(408.31,DGMTI,2)),U,5)'=VSITE G EDTQ ; Test doesn't belong to site
"RTN","DGMTU",85,0)
 S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTDT=+DGMT0,DGMTS=$P(DGMT0,"^",3)
"RTN","DGMTU",86,0)
 S DIR("A")="Do you wish to "_$S(DGMTS=1:"proceed with",1:"edit")_" the means test at this time"
"RTN","DGMTU",87,0)
 S DIR("B")=$S(DGMTS&($D(DGPRFLG)):"NO",DGMTS=1:"YES",1:"NO"),DIR(0)="Y"
"RTN","DGMTU",88,0)
 W ! D ^DIR G EDTQ:$D(DTOUT)!($D(DUOUT))
"RTN","DGMTU",89,0)
 I Y S DGMTYPT=1,DGMTACT="EDT",DGMTROU="EDTQ^DGMTU" G EN^DGMTSC
"RTN","DGMTU",90,0)
EDTQ K DGMT0,DGMTACT,DGMTDT,DGMTI,DGMTROU,DGMTS,DIR,DTOUT,DUOUT,Y
"RTN","DGMTU",91,0)
 ;
"RTN","DGMTU",92,0)
 ; release lock
"RTN","DGMTU",93,0)
 D UNLOCK^DGMTUTL(DFN)
"RTN","DGMTU",94,0)
 ;
"RTN","DGMTU",95,0)
 Q
"RTN","DGMTU",96,0)
 ;
"RTN","DGMTU",97,0)
CMTS(DFN) ;Get Current MT Status - query HEC if necessary
"RTN","DGMTU",98,0)
 ;
"RTN","DGMTU",99,0)
 ;        Input: DFN=patient ien
"RTN","DGMTU",100,0)
 ;       Output: MT IEN^Date of Test^Status Name
"RTN","DGMTU",101,0)
 ;                 ^Status Code^Source of Test
"RTN","DGMTU",102,0)
 ;
"RTN","DGMTU",103,0)
 N X,Y,DGMTDATA,DGQSENT,DGDOD,NODE0,DGRET,DGMFLG,DGTAG,DGMTYPT
"RTN","DGMTU",104,0)
 D CHKPT^DGMTU4(DFN)
"RTN","DGMTU",105,0)
 S DGMTYPT=1,DGMTDATA=$$LST(DFN,"",DGMTYPT)
"RTN","DGMTU",106,0)
 ;Next line checks to see if patient has expired, if so, Query not initiated
"RTN","DGMTU",107,0)
 S DGDOD=$P($G(^DPT(DFN,.35)),U)
"RTN","DGMTU",108,0)
 I +DGDOD Q DGMTDATA
"RTN","DGMTU",109,0)
 ;Next line checks to see if current test exists, if not, Query not initiated 
"RTN","DGMTU",110,0)
 I '$G(DGMTDATA) Q DGMTDATA
"RTN","DGMTU",111,0)
 D:+$$QFLG(DGMTDATA)
"RTN","DGMTU",112,0)
 .I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN),$G(DGMFLG)'=0 D
"RTN","DGMTU",113,0)
 ..I $$LOCK^DGMTUTL(DFN)
"RTN","DGMTU",114,0)
 ..D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1
"RTN","DGMTU",115,0)
 ..I '$D(ZTQUEUED),'$G(DGMSGF),$G(DGQSENT) W !!,"Financial query queued to be sent to HEC...",! H .5
"RTN","DGMTU",116,0)
 ..D UNLOCK^DGMTUTL(DFN)
"RTN","DGMTU",117,0)
 .S DGMTDATA=$$LST(DFN,"",DGMTYPT)
"RTN","DGMTU",118,0)
 D:+$$MFLG(DGMTDATA)
"RTN","DGMTU",119,0)
 .S DGMFLG=$$MFLG(DGMTDATA)
"RTN","DGMTU",120,0)
 .S DGTAG=$S(DGMFLG=1:"MSG"_DGMFLG,DGMFLG=2:"MSG"_DGMFLG,1:0)
"RTN","DGMTU",121,0)
 .I DGTAG["MSG",'$G(DGMSGF) D @DGTAG
"RTN","DGMTU",122,0)
 Q DGMTDATA   ;return most current MT data
"RTN","DGMTU",123,0)
MFLG(DGMTDATA) ;Set up appropriate informational message flag for user's
"RTN","DGMTU",124,0)
 ;benefit.
"RTN","DGMTU",125,0)
 ;Input        -     DGMTDATA as defined by $$LST function.
"RTN","DGMTU",126,0)
 ;Output       -     DGRETV
"RTN","DGMTU",127,0)
 ;     1 = Current Test is REQUIRED
"RTN","DGMTU",128,0)
 ;     2 = Test is > 1 year older than January 1, 2013 and is in a
"RTN","DGMTU",129,0)
 ;         status of other than REQUIRED or NO LONGER REQUIRED
"RTN","DGMTU",130,0)
 ;     2 = Pend Adj for GMT, test date is 10/6/99 or
"RTN","DGMTU",131,0)
 ;         greater and agreed to the deductible
"RTN","DGMTU",132,0)
 ;     0 = CAT C/Pend Adj for MT, test date is 10/6/99
"RTN","DGMTU",133,0)
 ;         or greater and agreed to the deductible.
"RTN","DGMTU",134,0)
 ; OR  0 = Cat C, declined income info and agreed
"RTN","DGMTU",135,0)
 ;         to pay deductible.
"RTN","DGMTU",136,0)
 ; OR  0 = Has a future dated Means Test
"RTN","DGMTU",137,0)
 N DGRETV,FTST,DGMT0
"RTN","DGMTU",138,0)
 S DGRETV=0 I '$G(DGMTDATA) Q DGRETV
"RTN","DGMTU",139,0)
 S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
"RTN","DGMTU",140,0)
 I $P(DGMTDATA,U,4)="R" S DGRETV=1
"RTN","DGMTU",141,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTU",142,0)
 I $$OLDMTPF^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S DGRETV=2
"RTN","DGMTU",143,0)
 I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S DGRETV=0
"RTN","DGMTU",144,0)
 I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
"RTN","DGMTU",145,0)
 D DOM^DGMTR I $G(DGDOM) S DGRETV=0
"RTN","DGMTU",146,0)
 S FTST=$$FUT(DFN)
"RTN","DGMTU",147,0)
 I DGRETV,FTST,$P(^DGMT(408.31,+FTST,0),U,19)=1 S DGRETV=0
"RTN","DGMTU",148,0)
 Q DGRETV
"RTN","DGMTU",149,0)
MSG1 ;Informational message 1
"RTN","DGMTU",150,0)
 N NODE0,Y
"RTN","DGMTU",151,0)
 S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
"RTN","DGMTU",152,0)
 W !!,$C(7),?15,"*** Patient Requires a Means Test ***",!
"RTN","DGMTU",153,0)
 S Y=$P(NODE0,U) X ^DD("DD") W !,?14,"Primary Means Test Required from "_Y,!
"RTN","DGMTU",154,0)
 I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
"RTN","DGMTU",155,0)
 Q
"RTN","DGMTU",156,0)
MSG2 ;Informational message 2
"RTN","DGMTU",157,0)
 N NODE0,Y
"RTN","DGMTU",158,0)
 S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
"RTN","DGMTU",159,0)
 W !!,$C(7),?17,"*** Patient Requires a Means Test ***",!
"RTN","DGMTU",160,0)
 S Y=$P(NODE0,U) X ^DD("DD") W !,?25,"*** Please update ***",! ;DG*5.3*858
"RTN","DGMTU",161,0)
 ;S Y=$P(NODE0,U) X ^DD("DD") W !,?10,"Patient's Test dated "_Y_" is "_$P(DGMTDATA,U,3)_"."_" The test"
"RTN","DGMTU",162,0)
 ;W !,?10,"date is greater than 1 year old.  Please update."
"RTN","DGMTU",163,0)
 I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
"RTN","DGMTU",164,0)
 Q
"RTN","DGMTU",165,0)
QFLG(DGMTDATA) ;
"RTN","DGMTU",166,0)
 ;INPUT - DGMTDATA
"RTN","DGMTU",167,0)
 ;OUTPUT- IVMQFLG 1 if query is necessary 0 if not
"RTN","DGMTU",168,0)
 N IVMQFLG,DGMT0
"RTN","DGMTU",169,0)
 S IVMQFLG=0 I '$G(DGMTDATA) Q IVMQFLG
"RTN","DGMTU",170,0)
 S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
"RTN","DGMTU",171,0)
 ;Set flag to 1 if Means test is Required.
"RTN","DGMTU",172,0)
 I $P(DGMTDATA,U,4)="R" S IVMQFLG=1
"RTN","DGMTU",173,0)
 ;Set flag to 1 if Means test older than 1 year from January 1, 2013 and status is not
"RTN","DGMTU",174,0)
 ;NO LONGER REQUIRED and not REQUIRED.
"RTN","DGMTU",175,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTU",176,0)
 I $$OLDMTPF^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S IVMQFLG=1
"RTN","DGMTU",177,0)
 ;If Cat C/Pend Adj for MT, older than 1 year from January 1, 2013, agreed to pay, test
"RTN","DGMTU",178,0)
 ;date > 10/5/99 reset flag to 0 - no query is necessary.
"RTN","DGMTU",179,0)
 I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S IVMQFLG=0
"RTN","DGMTU",180,0)
 ;If patient is Cat C, declined to provide income but has agreed to
"RTN","DGMTU",181,0)
 ;pay deductible, no query necessary - reset flag to 0
"RTN","DGMTU",182,0)
 I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
"RTN","DGMTU",183,0)
 ;If patient is on a DOM ward, don't initiate query
"RTN","DGMTU",184,0)
 D DOM^DGMTR I $G(DGDOM) S IVMQFLG=0
"RTN","DGMTU",185,0)
 Q IVMQFLG
"RTN","DGMTU",186,0)
 ;
"RTN","DGMTU",187,0)
FUT(DFN,DGDT,DGMTYPT) ; Future MT for a patient
"RTN","DGMTU",188,0)
 ;DFN      Patient IEN
"RTN","DGMTU",189,0)
 ;DGDT     Date (Optional- default to today)
"RTN","DGMTU",190,0)
 ;DGMTYPT  Type of Test (Optional - default to MT)
"RTN","DGMTU",191,0)
 ;Return
"RTN","DGMTU",192,0)
 ;If a DCD test was performed it will be returned, else the
"RTN","DGMTU",193,0)
 ;current future dated test for the Income Year.
"RTN","DGMTU",194,0)
 ;MT IEN^Date of Test^Status Name^Status Code^Source
"RTN","DGMTU",195,0)
 ;
"RTN","DGMTU",196,0)
 N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,LAST,TYPTST
"RTN","DGMTU",197,0)
 S:'$D(DGMTYPT) DGMTYPT=1
"RTN","DGMTU",198,0)
 ;no future LTC eg 02/15/2005
"RTN","DGMTU",199,0)
 I ($G(DGMTYPT)=4) Q ""
"RTN","DGMTU",200,0)
 S TYPTST=$S(DGMTYPT=2:"AF",1:"AE")
"RTN","DGMTU",201,0)
 S DGIDT=$S($G(DGDT)>0:DGDT,1:DT),DONE=0
"RTN","DGMTU",202,0)
 S (ARR,LAST,Y)=""
"RTN","DGMTU",203,0)
 S:$P(DGIDT,".",2) DGIDT=$P(DGIDT,".")
"RTN","DGMTU",204,0)
 F  S DGIDT=$O(^IVM(301.5,TYPTST,DFN,DGIDT)) Q:'DGIDT!(DONE)  D
"RTN","DGMTU",205,0)
 .S MTIEN=0
"RTN","DGMTU",206,0)
 .F  S MTIEN=$O(^IVM(301.5,TYPTST,DFN,DGIDT,MTIEN)) Q:'MTIEN!(DONE)  D
"RTN","DGMTU",207,0)
 ..Q:'$D(^DGMT(408.31,MTIEN,0))
"RTN","DGMTU",208,0)
 ..S MTNOD=^DGMT(408.31,MTIEN,0),SRCE=$P(MTNOD,U,23)
"RTN","DGMTU",209,0)
 ..I SRCE'=1 S DONE=1,Y=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23) Q
"RTN","DGMTU",210,0)
 ..I 'DONE,'$D(ARR($P(MTNOD,U),MTIEN)) S ARR($P(MTNOD,U),MTIEN)=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23)
"RTN","DGMTU",211,0)
 I 'DONE S LAST=$O(ARR(""),-1) I LAST S Y=ARR(LAST,$O(ARR(LAST,""),-1))
"RTN","DGMTU",212,0)
 Q $G(Y)
"RTN","DGMTU4")
0^4^B73029877
"RTN","DGMTU4",1,0)
DGMTU4 ;ALB/CJM,SCG,LBD,EG,PHH,BDB MEANS TEST UTILITES ; 06/07/2005
"RTN","DGMTU4",2,0)
 ;;5.3;Registration;**182,267,285,347,454,456,476,610,658,858**;Aug 13, 1993;Build 30
"RTN","DGMTU4",3,0)
 ;
"RTN","DGMTU4",4,0)
GETSITE(DUZ) ;
"RTN","DGMTU4",5,0)
 ;Descripition:  Gets the users station number.  If not found, it will
"RTN","DGMTU4",6,0)
 ;return the station number of the primary facility.
"RTN","DGMTU4",7,0)
 ;
"RTN","DGMTU4",8,0)
 ;Input:
"RTN","DGMTU4",9,0)
 ;      DUZ array, pass by reference
"RTN","DGMTU4",10,0)
 ;Output:
"RTN","DGMTU4",11,0)
 ;      Function Value - station number with suffix
"RTN","DGMTU4",12,0)
 N FACILITY,STATION,CURSTN,CHILD,CIEN
"RTN","DGMTU4",13,0)
 S FACILITY=""
"RTN","DGMTU4",14,0)
 S:($G(DUZ)'=.5) FACILITY=$G(DUZ(2))
"RTN","DGMTU4",15,0)
 I 'FACILITY S FACILITY=+$$SITE^VASITE()
"RTN","DGMTU4",16,0)
 S:FACILITY STATION=$$STA^XUAF4(FACILITY)
"RTN","DGMTU4",17,0)
 S CURSTN=$P($$SITE^VASITE,"^",3)
"RTN","DGMTU4",18,0)
 I $D(STATION) D
"RTN","DGMTU4",19,0)
 .I STATION']"" D
"RTN","DGMTU4",20,0)
 ..D CHILDREN^XUAF4("CHILD","`"_FACILITY,"PARENT FACILITY")
"RTN","DGMTU4",21,0)
 ..S CIEN=0 F  S CIEN=$O(CHILD("C",CIEN)) Q:'CIEN  I CIEN=CURSTN S STATION=$$STA^XUAF4(CIEN) Q
"RTN","DGMTU4",22,0)
 ..I STATION']"" D
"RTN","DGMTU4",23,0)
 ...D CHILDREN^XUAF4("CHILD","`"_FACILITY,"VISN")
"RTN","DGMTU4",24,0)
 ...S CIEN=0 F  S CIEN=$O(CHILD("C",CIEN)) Q:'CIEN  I CIEN=CURSTN S STATION=$$STA^XUAF4(CIEN) Q
"RTN","DGMTU4",25,0)
 Q $G(STATION)
"RTN","DGMTU4",26,0)
 ;
"RTN","DGMTU4",27,0)
DATETIME(MTIEN) ;
"RTN","DGMTU4",28,0)
 ;Writes date/time stamp to means test record
"RTN","DGMTU4",29,0)
 N DATA
"RTN","DGMTU4",30,0)
 Q:$G(IVMZ10)="UPLOAD IN PROGRESS"
"RTN","DGMTU4",31,0)
 S DATA(2.02)=$$NOW^XLFDT
"RTN","DGMTU4",32,0)
 I $G(MTIEN),$D(^DGMT(408.31,MTIEN,0)) I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
"RTN","DGMTU4",33,0)
 Q
"RTN","DGMTU4",34,0)
SAVESTAT(MTIEN,DGERR) ;
"RTN","DGMTU4",35,0)
 ;Save the Test Determined Status (#2.03) in the ANNUAL MEANS TEST file
"RTN","DGMTU4",36,0)
 ;(#408.31)
"RTN","DGMTU4",37,0)
 ;
"RTN","DGMTU4",38,0)
 ;Input:
"RTN","DGMTU4",39,0)
 ;      MTIEN - IEN of 408.31
"RTN","DGMTU4",40,0)
 ;      DGERR  - (optional) 1 - Means or Copay Test is incomplete
"RTN","DGMTU4",41,0)
 ;                          0 - Means or Copay Test is complete       
"RTN","DGMTU4",42,0)
 ;
"RTN","DGMTU4",43,0)
 ;only current statuses of P, A, or C for Means Tests and
"RTN","DGMTU4",44,0)
 ;current status of M, or E for Copay Tests will be stored.
"RTN","DGMTU4",45,0)
 ;
"RTN","DGMTU4",46,0)
 ;if test is incomplete the Test Determined Status will be deleted.
"RTN","DGMTU4",47,0)
 ;
"RTN","DGMTU4",48,0)
 Q:('$G(MTIEN))
"RTN","DGMTU4",49,0)
 ;
"RTN","DGMTU4",50,0)
 N CODE,DATA,NODE0,TYPE
"RTN","DGMTU4",51,0)
 I $G(DGERR) S DATA(2.03)="" G SET
"RTN","DGMTU4",52,0)
 S NODE0=$G(^DGMT(408.31,MTIEN,0))
"RTN","DGMTU4",53,0)
 S TYPE=$P(NODE0,"^",19)
"RTN","DGMTU4",54,0)
 S CODE=$$GETCODE^DGMTH($P(NODE0,"^",3))
"RTN","DGMTU4",55,0)
 S:CODE="A" (DATA(.11),DATA(.14))=""
"RTN","DGMTU4",56,0)
 S DATA(2.03)=""
"RTN","DGMTU4",57,0)
 I TYPE=1,(CODE="N") Q
"RTN","DGMTU4",58,0)
 I TYPE=2,(CODE="L") Q
"RTN","DGMTU4",59,0)
 I TYPE=1,(CODE'=""),"CPAG"[CODE D
"RTN","DGMTU4",60,0)
 .S DATA(2.03)=$P(NODE0,"^",3)
"RTN","DGMTU4",61,0)
 .I $P(NODE0,"^",20) D
"RTN","DGMTU4",62,0)
 ..S DATA(2.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="A"&(($P(NODE0,U,4)-$P(NODE0,U,15))'>$P(NODE0,U,27)):"G",1:"C"),1)
"RTN","DGMTU4",63,0)
 I TYPE=2,(CODE'=""),"ME"[CODE S DATA(2.03)=$P(NODE0,"^",3)
"RTN","DGMTU4",64,0)
SET I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
"RTN","DGMTU4",65,0)
 Q
"RTN","DGMTU4",66,0)
MTPRIME(MTIEN) ;
"RTN","DGMTU4",67,0)
 ;Makes the means test MTIEN primary
"RTN","DGMTU4",68,0)
 ;
"RTN","DGMTU4",69,0)
 N DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTDATE,YREND,DGMTDC,IBPRIOR,MTPRIME,LSTNODE
"RTN","DGMTU4",70,0)
 Q:('$G(MTIEN))
"RTN","DGMTU4",71,0)
 S MTPRIME="DGMTU4"
"RTN","DGMTU4",72,0)
 S NODE=$G(^DGMT(408.31,MTIEN,0))
"RTN","DGMTU4",73,0)
 Q:(NODE="")
"RTN","DGMTU4",74,0)
 S DFN=$P($G(^DGMT(408.31,MTIEN,0)),"^",2)
"RTN","DGMTU4",75,0)
 Q:'DFN
"RTN","DGMTU4",76,0)
 Q:+$G(^DGMT(408.31,MTIEN,"PRIM"))  ;already marked as primary!
"RTN","DGMTU4",77,0)
 S MTDATE=+NODE
"RTN","DGMTU4",78,0)
 Q:'MTDATE
"RTN","DGMTU4",79,0)
 Q:($P(NODE,"^",19)'=1)
"RTN","DGMTU4",80,0)
 ;
"RTN","DGMTU4",81,0)
 S DGMTACT="ADD"
"RTN","DGMTU4",82,0)
 D PRIOR^DGMTEVT
"RTN","DGMTU4",83,0)
 ;
"RTN","DGMTU4",84,0)
 ;marks any existing tests as non-primary - shouldn't be more than
"RTN","DGMTU4",85,0)
 ;one such test, but give it two tries
"RTN","DGMTU4",86,0)
 I '$$OLD(MTDATE) D
"RTN","DGMTU4",87,0)
 .S YREND=DT_.2359
"RTN","DGMTU4",88,0)
 E  D
"RTN","DGMTU4",89,0)
 .S YREND=$E(MTDATE,1,3)_1231.9999
"RTN","DGMTU4",90,0)
 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,1) Q:'(+NODE)  Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3))  D
"RTN","DGMTU4",91,0)
 .N DATA
"RTN","DGMTU4",92,0)
 .;set up for the event driver - should be treated as an edit
"RTN","DGMTU4",93,0)
 .S:(TRIES=1) DGMTACT="EDT",DGMTI=+NODE D PRIOR^DGMTEVT
"RTN","DGMTU4",94,0)
 .;set the old test to non-primary
"RTN","DGMTU4",95,0)
 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
"RTN","DGMTU4",96,0)
 ;
"RTN","DGMTU4",97,0)
 ;don't want any old RX copay tests as primary either - if needed, they can be auto-created based on the means test
"RTN","DGMTU4",98,0)
 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,2) Q:'(+NODE)  Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3))  D
"RTN","DGMTU4",99,0)
 .N DATA
"RTN","DGMTU4",100,0)
 .;set the old test to non-primary
"RTN","DGMTU4",101,0)
 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
"RTN","DGMTU4",102,0)
 ;
"RTN","DGMTU4",103,0)
 ;mark this test as primary
"RTN","DGMTU4",104,0)
 K DATA S DATA(2)=1 I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
"RTN","DGMTU4",105,0)
 ;
"RTN","DGMTU4",106,0)
 ; Get Last Primary Means Test irrespective of income year
"RTN","DGMTU4",107,0)
 S LSTNODE=$$LST^DGMTU(DFN)
"RTN","DGMTU4",108,0)
 ;if STATUS is REQUIRED & test is PRIMARY, then set it to NOT PRIMARY
"RTN","DGMTU4",109,0)
 ;if the uploaded test is MT COPAY REQUIRED
"RTN","DGMTU4",110,0)
 ; MT COPAY (CAT C) doesn't expire, which is why you have to 
"RTN","DGMTU4",111,0)
 ; flip the test to Not Primary eg 02/01/2005
"RTN","DGMTU4",112,0)
 I $P(LSTNODE,U,4)="R",+$G(^DGMT(408.31,+LSTNODE,"PRIM")),$P(^DGMT(408.31,MTIEN,0),U,3)=6 D
"RTN","DGMTU4",113,0)
 . N DATA S DATA(2)=0 I $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
"RTN","DGMTU4",114,0)
 ;if means test is required and test is primary and not a CAT C, 
"RTN","DGMTU4",115,0)
 ;and it hasn't expired, flip the test to Not Primary eg 02/23/2005
"RTN","DGMTU4",116,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTU4",117,0)
 I $P(LSTNODE,U,4)="R",+$G(^DGMT(408.31,+LSTNODE,"PRIM")),$P(^DGMT(408.31,MTIEN,0),U,3)'=6,'$$OLDMTPF(MTDATE) D
"RTN","DGMTU4",118,0)
 . N DATA S DATA(2)=0 I $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
"RTN","DGMTU4",119,0)
 ;
"RTN","DGMTU4",120,0)
 ;If this is a Z10 upload, call the means test event driver and quit.
"RTN","DGMTU4",121,0)
 ;
"RTN","DGMTU4",122,0)
 I $G(IVMZ10)="UPLOAD IN PROGRESS" D  Q
"RTN","DGMTU4",123,0)
 .S DGMTI=MTIEN
"RTN","DGMTU4",124,0)
 .S DGMTINF=1
"RTN","DGMTU4",125,0)
 .D QUE^DGMTR
"RTN","DGMTU4",126,0)
 ;
"RTN","DGMTU4",127,0)
 ;If the test is still in effect, need to do additional checks
"RTN","DGMTU4",128,0)
 ;and call event driver
"RTN","DGMTU4",129,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTU4",130,0)
 I '$$OLDMTPF(MTDATE) D
"RTN","DGMTU4",131,0)
 .;Mark this test as NO LONGER REQUIRED -  calling EN^DGMTR will
"RTN","DGMTU4",132,0)
 .;change it back to its old status if required and will que the event
"RTN","DGMTU4",133,0)
 .;driver
"RTN","DGMTU4",134,0)
 .K DATA
"RTN","DGMTU4",135,0)
 .S DATA(.03)=$$GETSTAT^DGMTH("N",1)
"RTN","DGMTU4",136,0)
 .I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
"RTN","DGMTU4",137,0)
 .S (DGADDF,DGMSGF)=1 ;don't want new test added or messages
"RTN","DGMTU4",138,0)
 .S DGMTI=MTIEN
"RTN","DGMTU4",139,0)
 .S DGMTINF=1
"RTN","DGMTU4",140,0)
 .;
"RTN","DGMTU4",141,0)
 .D EN^DGMTR
"RTN","DGMTU4",142,0)
 .;if the test wasn't required, maybe a Rx copay test is needed
"RTN","DGMTU4",143,0)
 .I '$G(DGREQF),'$G(DGDOM1) D COPYRX^DGMTR1(DFN,MTIEN)
"RTN","DGMTU4",144,0)
 Q
"RTN","DGMTU4",145,0)
 ;
"RTN","DGMTU4",146,0)
RXPRIME(RXIEN) ;
"RTN","DGMTU4",147,0)
 ;Makes phramacy copay test =RXIEN the primary test
"RTN","DGMTU4",148,0)
 ;
"RTN","DGMTU4",149,0)
 N DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTIEN,DGRAUTO,DGADDF,DGMTE,DGMTCOR,DGMT,YREND,RXPRIME,QUIT
"RTN","DGMTU4",150,0)
 ;
"RTN","DGMTU4",151,0)
 Q:('$G(RXIEN))
"RTN","DGMTU4",152,0)
 S RXPRIME="DGMTU4"
"RTN","DGMTU4",153,0)
 S QUIT=0
"RTN","DGMTU4",154,0)
 S NODE=$G(^DGMT(408.31,RXIEN,0))
"RTN","DGMTU4",155,0)
 Q:(NODE="")
"RTN","DGMTU4",156,0)
 S DFN=$P($G(^DGMT(408.31,RXIEN,0)),"^",2)
"RTN","DGMTU4",157,0)
 Q:'DFN
"RTN","DGMTU4",158,0)
 Q:+$G(^DGMT(408.31,RXIEN,"PRIM"))  ;already marked as primary!
"RTN","DGMTU4",159,0)
 S MTDATE=+NODE
"RTN","DGMTU4",160,0)
 Q:'MTDATE
"RTN","DGMTU4",161,0)
 Q:($P(NODE,"^",19)'=2)
"RTN","DGMTU4",162,0)
 ;
"RTN","DGMTU4",163,0)
 S DGMTINF=1
"RTN","DGMTU4",164,0)
 ;
"RTN","DGMTU4",165,0)
 ;marks any existing tests as non-primary - shouldn't be more than
"RTN","DGMTU4",166,0)
 ;one such test, but give it two tries
"RTN","DGMTU4",167,0)
 ;
"RTN","DGMTU4",168,0)
 I '$$OLD(MTDATE) D
"RTN","DGMTU4",169,0)
 .S YREND=DT_.2359
"RTN","DGMTU4",170,0)
 E  D
"RTN","DGMTU4",171,0)
 .S YREND=$E(MTDATE,1,3)_1231.9999
"RTN","DGMTU4",172,0)
 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,2) Q:'(+NODE)  Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3))  D
"RTN","DGMTU4",173,0)
 .N DATA
"RTN","DGMTU4",174,0)
 .;set up for the event driver - should be treated as an edit
"RTN","DGMTU4",175,0)
 .S:(TRIES=1) DGMTACT="EDT",DGMTI=+NODE D PRIOR^DGMTEVT
"RTN","DGMTU4",176,0)
 .;set the old test to non-primary
"RTN","DGMTU4",177,0)
 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
"RTN","DGMTU4",178,0)
 ;
"RTN","DGMTU4",179,0)
 ;don't want any old means tests marked as primary - unless they are actually needed!  In which case, do not make this Rx test primary.
"RTN","DGMTU4",180,0)
 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,1) Q:'(+NODE)  Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3))  D
"RTN","DGMTU4",181,0)
 .N DATA
"RTN","DGMTU4",182,0)
 .;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTU4",183,0)
 .I '$$OLDMTPF($P(NODE,"^",2)),$P(NODE,"^",4)'="","ACGP"[$P(NODE,"^",4) S QUIT=1 Q
"RTN","DGMTU4",184,0)
 .;set the old test to non-primary
"RTN","DGMTU4",185,0)
 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
"RTN","DGMTU4",186,0)
 ;
"RTN","DGMTU4",187,0)
 I QUIT G QRXPRIME
"RTN","DGMTU4",188,0)
 ;mark this test as primary -  calling
"RTN","DGMTU4",189,0)
 ;EN^DGMTCOR will change it to NO LONGER APPLICABLE if appropriate
"RTN","DGMTU4",190,0)
 ;
"RTN","DGMTU4",191,0)
 K DATA
"RTN","DGMTU4",192,0)
 S DATA(2)=1 I $$UPD^DGENDBS(408.31,RXIEN,.DATA)
"RTN","DGMTU4",193,0)
 ;
"RTN","DGMTU4",194,0)
 ;If the test is still in effect, need to do additional checks
"RTN","DGMTU4",195,0)
 ;and call event driver
"RTN","DGMTU4",196,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGMTU4",197,0)
 I '$$OLDMTPF(MTDATE) D
"RTN","DGMTU4",198,0)
 .S DGMSGF=1,DGADDF=0 ;don't want new test added or messages
"RTN","DGMTU4",199,0)
 .;
"RTN","DGMTU4",200,0)
 .;EN^DGMTR will first create a stub for a required MT if needed, then
"RTN","DGMTU4",201,0)
 .;call ^DGMTCOR to set the status of the copay test
"RTN","DGMTU4",202,0)
 .D EN^DGMTR
"RTN","DGMTU4",203,0)
 .;
"RTN","DGMTU4",204,0)
 .;if the pharmacy copay test was determined to be required, than
"RTN","DGMTU4",205,0)
 .;que the event driver
"RTN","DGMTU4",206,0)
 .I DGMTCOR D
"RTN","DGMTU4",207,0)
 ..S DGMTACT="ADD"
"RTN","DGMTU4",208,0)
 ..D PRIOR^DGMTEVT
"RTN","DGMTU4",209,0)
 ..S DGMTI=RXIEN
"RTN","DGMTU4",210,0)
 ..D QUE^DGMTR
"RTN","DGMTU4",211,0)
QRXPRIME ;
"RTN","DGMTU4",212,0)
 Q
"RTN","DGMTU4",213,0)
 ;
"RTN","DGMTU4",214,0)
OLD(TESTDATE) ;
"RTN","DGMTU4",215,0)
 ;Checks if the date is older than 365 days.  Returns 0 for no, 1 for yes
"RTN","DGMTU4",216,0)
 ;if the test is exactly 365 days, 
"RTN","DGMTU4",217,0)
 ;it is considered expired eg 03/09/2005
"RTN","DGMTU4",218,0)
 ;I ($$FMDIFF^XLFDT(DT,TESTDATE)'<365) Q 1
"RTN","DGMTU4",219,0)
 I TESTDATE<(DT-10000) Q 1
"RTN","DGMTU4",220,0)
 Q 0
"RTN","DGMTU4",221,0)
 ;
"RTN","DGMTU4",222,0)
OLDMTPF(TESTDATE) ;
"RTN","DGMTU4",223,0)
 ;For the Discontinue Annual Means Test Renewal project DG*5.3*858
"RTN","DGMTU4",224,0)
 ;Checks if the date is more than 1 year older than the Discontinue
"RTN","DGMTU4",225,0)
 ; Annual Means Test Renewal Point Forward Date.
"RTN","DGMTU4",226,0)
 ;Discontinue Annual Means Test Renewal Point Forward Date
"RTN","DGMTU4",227,0)
 ;Input  TESTDATE - Means Test Date
"RTN","DGMTU4",228,0)
 ;       
"RTN","DGMTU4",229,0)
 ;Output 0 for No
"RTN","DGMTU4",230,0)
 ;       1 for Yes
"RTN","DGMTU4",231,0)
 ;
"RTN","DGMTU4",232,0)
 N DGMTPFD
"RTN","DGMTU4",233,0)
 S DGMTPFD=$P(^DG(43,1,"VFA"),"^",1)
"RTN","DGMTU4",234,0)
 I TESTDATE<(DGMTPFD-10000) Q 1
"RTN","DGMTU4",235,0)
 Q 0
"RTN","DGMTU4",236,0)
 ;
"RTN","DGMTU4",237,0)
TRANSFER(DFN,FROM,TO) ;
"RTN","DGMTU4",238,0)
 ;transfers the Income Relations from the test=FROM to test=TO
"RTN","DGMTU4",239,0)
 ;
"RTN","DGMTU4",240,0)
 N DGINI,DGINR,DATA,ERROR
"RTN","DGMTU4",241,0)
 Q:'$G(DFN)
"RTN","DGMTU4",242,0)
 Q:'$G(FROM)
"RTN","DGMTU4",243,0)
 Q:'$G(TO)
"RTN","DGMTU4",244,0)
 Q:(FROM=TO)
"RTN","DGMTU4",245,0)
 S DGINI=0 F  S DGINI=$O(^DGMT(408.22,"AMT",FROM,DFN,DGINI)) Q:'DGINI  S DGINR=$O(^DGMT(408.22,"AMT",FROM,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
"RTN","DGMTU4",246,0)
 .K DATA
"RTN","DGMTU4",247,0)
 .S DATA(31)=TO
"RTN","DGMTU4",248,0)
 .I $$UPD^DGENDBS(408.22,+DGINR,.DATA,.ERROR)
"RTN","DGMTU4",249,0)
 Q
"RTN","DGMTU4",250,0)
 ;
"RTN","DGMTU4",251,0)
GETINCOM(DFN,TDATE) ;
"RTN","DGMTU4",252,0)
 ;Makes sure Income Relations point to the right test
"RTN","DGMTU4",253,0)
 ;
"RTN","DGMTU4",254,0)
 ;Input:
"RTN","DGMTU4",255,0)
 ;  DFN
"RTN","DGMTU4",256,0)
 ;  TDATE -income year of test (uses $E(IVMMTDT,1,3))
"RTN","DGMTU4",257,0)
 ;Output: none.  Repoints Income Relations if necessary
"RTN","DGMTU4",258,0)
 ;
"RTN","DGMTU4",259,0)
 N MTNODE,RXNODE,IVMMTDT,CODE,ACTVIEN
"RTN","DGMTU4",260,0)
 Q:'$G(TDATE)
"RTN","DGMTU4",261,0)
 Q:'$G(DFN)
"RTN","DGMTU4",262,0)
 ;
"RTN","DGMTU4",263,0)
 S IVMMTDT=$E(TDATE,1,3)_"1231.9"
"RTN","DGMTU4",264,0)
 S (CODE,ACTVIEN)=""
"RTN","DGMTU4",265,0)
 S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
"RTN","DGMTU4",266,0)
 S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
"RTN","DGMTU4",267,0)
 ;
"RTN","DGMTU4",268,0)
 D
"RTN","DGMTU4",269,0)
 .;determine which test has the associated income relations
"RTN","DGMTU4",270,0)
 .;
"RTN","DGMTU4",271,0)
 .I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
"RTN","DGMTU4",272,0)
 .I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
"RTN","DGMTU4",273,0)
 .I +MTNODE S ACTVIEN=+MTNODE Q
"RTN","DGMTU4",274,0)
 .I +RXNODE S ACTVIEN=+RXNODE Q
"RTN","DGMTU4",275,0)
 I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
"RTN","DGMTU4",276,0)
 Q
"RTN","DGMTU4",277,0)
 ;
"RTN","DGMTU4",278,0)
CHKPT(DFN) ;
"RTN","DGMTU4",279,0)
 ; Cross check the CURRENT MEANS TEST STATUS in the PATIENT File (#2) with the
"RTN","DGMTU4",280,0)
 ; primary means test in the ANNUAL MEANS TEST File (#408.31).  Update the 
"RTN","DGMTU4",281,0)
 ; CURRENT MEANS TEST STATUS if the fields are out of synch.
"RTN","DGMTU4",282,0)
 ;
"RTN","DGMTU4",283,0)
 N PATMT,DGMTI,DATA
"RTN","DGMTU4",284,0)
 ;
"RTN","DGMTU4",285,0)
 Q:$G(DFN)'>0
"RTN","DGMTU4",286,0)
 Q:'$D(^DPT(DFN))
"RTN","DGMTU4",287,0)
 S PATMT=$$GET1^DIQ(2,DFN,.14,"I")
"RTN","DGMTU4",288,0)
 S DGMTI=+$$LST^DGMTU(DFN)
"RTN","DGMTU4",289,0)
 S DATA(.14)=$P($G(^DGMT(408.31,DGMTI,0)),U,3)
"RTN","DGMTU4",290,0)
 Q:DATA(.14)=PATMT
"RTN","DGMTU4",291,0)
 ;
"RTN","DGMTU4",292,0)
 I $$UPD^DGENDBS(2,DFN,.DATA)
"RTN","DGMTU4",293,0)
 Q
"RTN","DGRPC2")
0^5^B71389194
"RTN","DGRPC2",1,0)
DGRPC2 ;ALB/MRL/SCK/PJR/BAJ/LBD/BDB - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 10/14/10 9:56am
"RTN","DGRPC2",2,0)
 ;;5.3;Registration;**45,69,108,121,205,218,342,387,470,467,489,505,507,528,451,564,570,657,688,780,797,858**;Aug 13, 1993;Build 30
"RTN","DGRPC2",3,0)
 ;
"RTN","DGRPC2",4,0)
43 ;off
"RTN","DGRPC2",5,0)
44 ;off
"RTN","DGRPC2",6,0)
45 ;off
"RTN","DGRPC2",7,0)
46 ;off
"RTN","DGRPC2",8,0)
47 ;off
"RTN","DGRPC2",9,0)
 S DGLST=$S(DGCHK[",47,":47,DGCHK[",46,":46,DGCHK[",45,":45,DGCHK[",44,":44,1:DGLST)
"RTN","DGRPC2",10,0)
 D NEXT G @DGLST
"RTN","DGRPC2",11,0)
48 I DGVT S DGD=DGP(.362) I DGCHK[(",48,"),($P(DGD,"^",17)="Y"),($P(DGD,"^",6)="") S X=48 D COMB
"RTN","DGRPC2",12,0)
 D NEXT G @DGLST
"RTN","DGRPC2",13,0)
49 ;
"RTN","DGRPC2",14,0)
50 ; insurance checks
"RTN","DGRPC2",15,0)
 I DGCHK[",49,"!(DGCHK[",50,") D  S DGLST=$S(DGCHK["50":50,1:49)
"RTN","DGRPC2",16,0)
 . N COV,INS,X
"RTN","DGRPC2",17,0)
 . S X=0,COV=$S($P(DGP(.31),"^",11)="Y":1,1:0)
"RTN","DGRPC2",18,0)
 . S INS=$$INSUR^IBBAPI(DFN,DT,"R")
"RTN","DGRPC2",19,0)
 . I COV,'INS S X=49 ; yes, but none
"RTN","DGRPC2",20,0)
 . I 'COV,INS S X=50 ; not yes, but some
"RTN","DGRPC2",21,0)
 . I DGCHK[(","_X_",") D COMB
"RTN","DGRPC2",22,0)
 D NEXT G @DGLST
"RTN","DGRPC2",23,0)
51 D NEXT G @DGLST ; 51 disabled
"RTN","DGRPC2",24,0)
 S X=$S($D(^DIC(21,+$P(DGP(.32),"^",3),0)):$P(^(0),"^",3),1:"")
"RTN","DGRPC2",25,0)
 I X="Z"&($P(DGP(.32),"^",5)'=7)&($P(DGP(.32),"^",10)'=7)&($P(DGP(.32),"^",15)'=7)!($P(DGP(.32),"^",5)=7&(X'="Z")) S X=51 D COMB
"RTN","DGRPC2",26,0)
 ;
"RTN","DGRPC2",27,0)
52 I $P(DGP(.31),"^",11)']"" S X=52 D COMB ;automatically on
"RTN","DGRPC2",28,0)
 D NEXT G @DGLST
"RTN","DGRPC2",29,0)
53 I $P(DGP(.311),"^",15)']"" S X=53 D COMB ;automatically on
"RTN","DGRPC2",30,0)
 D NEXT G @DGLST
"RTN","DGRPC2",31,0)
54 ;
"RTN","DGRPC2",32,0)
55 ;BELOW IS USED BY BOTH 54 & 55
"RTN","DGRPC2",33,0)
 N DGMT
"RTN","DGRPC2",34,0)
 S DGLST=$S(DGCHK["55":55,1:54)
"RTN","DGRPC2",35,0)
 I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) D NEXT G @DGLST ; patient died before current year
"RTN","DGRPC2",36,0)
 N DGE S DGE=+$O(^DIC(8.1,"B","SERVICE CONNECTED 50% to 100%",0))
"RTN","DGRPC2",37,0)
 I $P($G(^DPT(DFN,.3)),U,2)'<50!($P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),U,9)=DGE) D NEXT G @DGLST ;50-100% SC
"RTN","DGRPC2",38,0)
 S DGPTYP=$G(^DG(391,+DGP("TYPE"),"S")),DGISYR=$E(DT,1,3)-1_"0000" I '$P(DGPTYP,"^",8)&('$P(DGPTYP,"^",9)) K DGPTYP,DGISYR D NEXT G @DGLST ; screens 8 and 9 off
"RTN","DGRPC2",39,0)
 ; If current/not outdated means test exits, pass to income retrieval
"RTN","DGRPC2",40,0)
 ; Patch 780
"RTN","DGRPC2",41,0)
 S DGMT=$$LST^DGMTU(DFN)
"RTN","DGRPC2",42,0)
 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","DGRPC2",43,0)
 I DGMT,$$OLDMTPF^DGMTU4($P(DGMT,U,2)) S DGMT=""
"RTN","DGRPC2",44,0)
 D ALL^DGMTU21(DFN,"VSD",$S(DGMT:$P(DGMT,U,2),1:DT),"IP",$S(DGMT:DGMT,1:""))
"RTN","DGRPC2",45,0)
 I '$P(DGPTYP,"^",8)!(DGCHK'["54") G JUST55 ; screen 8 off OR JUST 55 IN CHK
"RTN","DGRPC2",46,0)
 S DGFL=0 I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") S DGFL=1
"RTN","DGRPC2",47,0)
 I 'DGFL F I=0:0 S I=$O(DGREL("D",I)) Q:'I  I $$SSN^DGMTU1(+DGREL("D",I))']"" S DGFL=1 Q
"RTN","DGRPC2",48,0)
 I DGFL S X=54 D COMB
"RTN","DGRPC2",49,0)
JUST55 I DGCHK'["55" D NEXT G @DGLST
"RTN","DGRPC2",50,0)
 S DGLST=55
"RTN","DGRPC2",51,0)
 I '$P(DGPTYP,"^",9) D NEXT G @DGLST ; screen 9 off
"RTN","DGRPC2",52,0)
 D TOT^DGRP9(.DGINC) S DGFL=0
"RTN","DGRPC2",53,0)
 F DGD="V","S","D" I $D(DGTOT(DGD)) F I=8:1:17 I $P(DGTOT(DGD),"^",I)]"" S DGFL=1 Q
"RTN","DGRPC2",54,0)
 I 'DGFL N DGAPD,DG55 D  I 'DGAPD&('DG55)  S X=55 D COMB
"RTN","DGRPC2",55,0)
 . S DGAPD=+$$LST^DGMTU(DFN),DGAPD=+$P($G(^DGMT(408.31,+DGAPD,0)),U,11)
"RTN","DGRPC2",56,0)
 . S DG55=$$CHECK55(DFN) ; **507, Additional Income Checks
"RTN","DGRPC2",57,0)
 D NEXT G @DGLST
"RTN","DGRPC2",58,0)
56 I DGVT S DGD=DGP(.3) I DGCHK[(",56,"),($P(DGD,"^",11)="Y"),($P(DGP(.362),"^",20)="") S X=56 D COMB
"RTN","DGRPC2",59,0)
 D NEXT G END^DGRPC3:$S('+DGLST:1,+DGLST=99:1,1:0) G @DGLST
"RTN","DGRPC2",60,0)
57 I $P(DGP(.38),U,1) D
"RTN","DGRPC2",61,0)
 .N X1,X2
"RTN","DGRPC2",62,0)
 .S X1=$P(DGP(.38),U,2)
"RTN","DGRPC2",63,0)
 .S X=$P($G(^DG(43,1,0)),U,46) S X2=$S(X:X,1:365) D C^%DTC
"RTN","DGRPC2",64,0)
 .I X<DT S X=57 D COMB
"RTN","DGRPC2",65,0)
 D NEXT G @DGLST
"RTN","DGRPC2",66,0)
58 ;58 - EC Claim - No Gulf/Som Svc
"RTN","DGRPC2",67,0)
 ;off
"RTN","DGRPC2",68,0)
 ;DG*5.3*688 changed the wording of Environmental Contaminants
"RTN","DGRPC2",69,0)
 ;so if this cc is ever activated the text in ^DGIN(38.6,58 
"RTN","DGRPC2",70,0)
 ;needs to be changed to Southwest Asia Conditions.
"RTN","DGRPC2",71,0)
 D NEXT G @DGLST
"RTN","DGRPC2",72,0)
59 ;59 - incomplete Catastrophic Disability info
"RTN","DGRPC2",73,0)
 I $$HASCAT^DGENCDA(DFN) D
"RTN","DGRPC2",74,0)
 .I '$P(DGP(.39),"^",2) S X=59 D COMB
"RTN","DGRPC2",75,0)
 D NEXT G @DGLST
"RTN","DGRPC2",76,0)
60 ;60 - Location of agent orange exposure unanswered
"RTN","DGRPC2",77,0)
 I DGVT,$P(DGP(.321),"^",2)="Y",$P(DGP(.321),"^",13)="" S X=60 D COMB
"RTN","DGRPC2",78,0)
 D NEXT G @DGLST
"RTN","DGRPC2",79,0)
61 ;61 - Incomplete Phone Number
"RTN","DGRPC2",80,0)
 ; DG*5.3*657 BAJ Phone number check modified
"RTN","DGRPC2",81,0)
 ; Home phone check is disabled
"RTN","DGRPC2",82,0)
 ; Work phone is required only if pt is employed
"RTN","DGRPC2",83,0)
 N EMPST
"RTN","DGRPC2",84,0)
 S EMPST=","_$P($G(^DPT(DFN,.311)),U,15)_","
"RTN","DGRPC2",85,0)
 I ",1,2,4,"[EMPST,($P(DGP(.13),"^",2)="") S X=61 D COMB
"RTN","DGRPC2",86,0)
 D NEXT G @DGLST
"RTN","DGRPC2",87,0)
62 ;62 - Missing Emergency Contact Name
"RTN","DGRPC2",88,0)
 I $P(DGP(.33),"^")="" S X=62 D COMB
"RTN","DGRPC2",89,0)
 D NEXT G @DGLST
"RTN","DGRPC2",90,0)
63 ;Confidential Address check
"RTN","DGRPC2",91,0)
 N STR63,J,DGI,DGERR
"RTN","DGRPC2",92,0)
 S DGERR=0
"RTN","DGRPC2",93,0)
 I $P(DGP(.141),U,9)="Y",$P($$CAACT^DGRPCADD(DFN),U) D
"RTN","DGRPC2",94,0)
 . ; country is either NULL or non-numeric
"RTN","DGRPC2",95,0)
 . I '$P(DGP(.141),U,16) S DGERR=1 Q
"RTN","DGRPC2",96,0)
 . ; country is not in Country file
"RTN","DGRPC2",97,0)
 . I '$D(^HL(779.004,$P(DGP(.141),"^",16))) S DGERR=1 Q
"RTN","DGRPC2",98,0)
 . S STR63="1,4,5,6" I $$FORIEN^DGADDUTL($P(DGP(.141),"^",16)) S STR63="1,4"
"RTN","DGRPC2",99,0)
 . F J=1:1:$L(STR63,",") S DGI=$P(STR63,",",J) Q:DGERR  I $P(DGP(.141),U,DGI)="" S DGERR=1
"RTN","DGRPC2",100,0)
 I DGERR S X=63 D COMB
"RTN","DGRPC2",101,0)
 D NEXT G @DGLST
"RTN","DGRPC2",102,0)
64 ;64 - Place of Birth City/State Missing ;**505
"RTN","DGRPC2",103,0)
 I $P(DGP(0),"^",11)=""!($P(DGP(0),"^",12)="") S X=64 D COMB
"RTN","DGRPC2",104,0)
 D NEXT G @DGLST
"RTN","DGRPC2",105,0)
65 ;65 - Mother's Maiden Name Missing ;**505
"RTN","DGRPC2",106,0)
 I $P(DGP(.24),"^",3)="" S X=65 D COMB
"RTN","DGRPC2",107,0)
 D NEXT G @DGLST
"RTN","DGRPC2",108,0)
66 ;66 - Pseudo SSN in use ;**505
"RTN","DGRPC2",109,0)
 ; DG*5.3*657 BAJ 11/20/2005 Removed from CC.  Pseudo notice appears in Patient List
"RTN","DGRPC2",110,0)
 ;I $P(DGP(0),"^",9)["P" S X=66 D COMB
"RTN","DGRPC2",111,0)
 ; off
"RTN","DGRPC2",112,0)
 D NEXT G @DGLST
"RTN","DGRPC2",113,0)
67 ;67 - Serv Sep Date [Last] missing or imprecise, patch 528
"RTN","DGRPC2",114,0)
 N DGG
"RTN","DGRPC2",115,0)
 S DGG=$$CVELIG^DGCV(DFN)
"RTN","DGRPC2",116,0)
 I $G(DGG)["A"!($G(DGG)["F") S X=67 D COMB
"RTN","DGRPC2",117,0)
 D NEXT G @DGLST
"RTN","DGRPC2",118,0)
68 ;used for 68-71, for Combat Vet, DG*5.3*528
"RTN","DGRPC2",119,0)
69 ;
"RTN","DGRPC2",120,0)
70 ;
"RTN","DGRPC2",121,0)
71 ;
"RTN","DGRPC2",122,0)
 ;68 - Combat To Date missing or imprecise, patch 528
"RTN","DGRPC2",123,0)
 ;69 - Yugoslavia To Date missing or imprecise, patch 528
"RTN","DGRPC2",124,0)
 ;70 - Somalia To Date missing or imprecise, patch 528
"RTN","DGRPC2",125,0)
 ;71 - Persian Gulf To Date missing or imprecise, patch 528
"RTN","DGRPC2",126,0)
 N DGG
"RTN","DGRPC2",127,0)
 S DGG=$$CVELIG^DGCV(DFN)
"RTN","DGRPC2",128,0)
 I DGG["B"!(DGG["G") S X=68 D COMB
"RTN","DGRPC2",129,0)
 I DGG["C"!(DGG["H") S X=69 D COMB
"RTN","DGRPC2",130,0)
 I DGG["D"!(DGG["I") S X=70 D COMB
"RTN","DGRPC2",131,0)
 I DGG["E"!(DGG["J") S X=71 D COMB
"RTN","DGRPC2",132,0)
 S DGLST=71
"RTN","DGRPC2",133,0)
 D NEXT G @DGLST
"RTN","DGRPC2",134,0)
72 ;; MSE - Required Fields
"RTN","DGRPC2",135,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSERR S X=72 D COMB
"RTN","DGRPC2",136,0)
 D NEXT G @DGLST
"RTN","DGRPC2",137,0)
73 ;; An MSE FROM date precedes an MSE TO date
"RTN","DGRPC2",138,0)
 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR D NEXT G @DGLST
"RTN","DGRPC2",139,0)
 N I1
"RTN","DGRPC2",140,0)
 ;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
"RTN","DGRPC2",141,0)
 I $D(DGPMSE) D  D NEXT G @DGLST
"RTN","DGRPC2",142,0)
 .N OUT S I1=0 F  S I1=$O(DGPMSE(I1)) Q:'I1!($G(OUT))  D
"RTN","DGRPC2",143,0)
 ..I $P(DGPMSE(I1),U,7) Q  ;Don't check MSE verified by HEC
"RTN","DGRPC2",144,0)
 ..I '$$B4^DGRPDT($P(DGPMSE(I1),U),$P(DGPMSE(I1),U,2),1) S X=73 D COMB S (MSERR,MSDATERR,OUT)=1 Q
"RTN","DGRPC2",145,0)
 ;Otherwise, use MSE data in DGP(.32)
"RTN","DGRPC2",146,0)
 F I1=6,11,16 I '$$B4^DGRPDT($P(DGP(.32),"^",I1),$P(DGP(.32),"^",I1+1),1) S X=73 D COMB S (MSERR,MSDATERR)=1 Q
"RTN","DGRPC2",147,0)
 D NEXT G @DGLST
"RTN","DGRPC2",148,0)
74 ;; Conflict Date Missing or Incomplete
"RTN","DGRPC2",149,0)
 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK I CONERR S X=74 D COMB
"RTN","DGRPC2",150,0)
 D NEXT G @DGLST
"RTN","DGRPC2",151,0)
75 ;; Conflict TO date precedes FROM date
"RTN","DGRPC2",152,0)
76 ;; Conflict Date out of range for conflict
"RTN","DGRPC2",153,0)
 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
"RTN","DGRPC2",154,0)
 S LOC="",(I5,I6)=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC=""  I CONARR(LOC)=1 D
"RTN","DGRPC2",155,0)
 .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
"RTN","DGRPC2",156,0)
 .S DATA=CONSPEC(LOC)
"RTN","DGRPC2",157,0)
 .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
"RTN","DGRPC2",158,0)
 .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
"RTN","DGRPC2",159,0)
 .I '$$B4^DGRPDT(FROMDAT,TODAT,1) S X=75 D COMB:'I5&(DGCHK[(",75,")) S CONARR(LOC)=2,I5=1 Q
"RTN","DGRPC2",160,0)
 .I DGCHK'[(",76,") Q
"RTN","DGRPC2",161,0)
 .S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
"RTN","DGRPC2",162,0)
 .I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),FROMDAT,TODAT) S X=76 D COMB:'I6 S CONARR(LOC)=2,I6=1
"RTN","DGRPC2",163,0)
 .Q
"RTN","DGRPC2",164,0)
 S DGLST=76 D NEXT G @DGLST
"RTN","DGRPC2",165,0)
77 ;; Date out of range for POW Location
"RTN","DGRPC2",166,0)
 ;; Check turned off by EVC project (DG*5.3*688)
"RTN","DGRPC2",167,0)
 D NEXT G @DGLST
"RTN","DGRPC2",168,0)
78 ;; Date out of range for Combat Location
"RTN","DGRPC2",169,0)
 S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
"RTN","DGRPC2",170,0)
 ;; Don't check if Combat Data Incomplete or if Combat TO precedes FROM
"RTN","DGRPC2",171,0)
 I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
"RTN","DGRPC2",172,0)
 I $P(DGP(.52),"^",11)'="Y" D NEXT G @DGLST ;; Don't check if no COMBAT
"RTN","DGRPC2",173,0)
 S LOC=$$COMPOW^DGRPMS($P(DGP(.52),"^",12)) I LOC="" D NEXT G @DGLST
"RTN","DGRPC2",174,0)
 I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=78 D COMB
"RTN","DGRPC2",175,0)
 D NEXT G @DGLST
"RTN","DGRPC2",176,0)
COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
"RTN","DGRPC2",177,0)
 ;
"RTN","DGRPC2",178,0)
NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,+DGLST<79 Q
"RTN","DGRPC2",179,0)
 S:'DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC3"
"RTN","DGRPC2",180,0)
 Q
"RTN","DGRPC2",181,0)
FIND F I=DGLST:1:99 I DGCHK[(","_I_",") Q
"RTN","DGRPC2",182,0)
 I DGNCK,(I>17),(I<36) S DGLST=36 G FIND
"RTN","DGRPC2",183,0)
 I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>78:"^DGRPC3",DGLST>42:"",DGLST>17:"^DGRPC1",1:"^DGRPC"))
"RTN","DGRPC2",184,0)
 G END^DGRPC3
"RTN","DGRPC2",185,0)
 ;
"RTN","DGRPC2",186,0)
CHECK55(DFN) ;Business rules for additional 55-INCOME DATA MISSING checks
"RTN","DGRPC2",187,0)
 ;  Modeled from DGMTR checks.
"RTN","DGRPC2",188,0)
 ;  Input  DFN - IEN from PATIENT File #2
"RTN","DGRPC2",189,0)
 ;
"RTN","DGRPC2",190,0)
 ;  Output 1 - If Income check passes additional business rules
"RTN","DGRPC2",191,0)
 ;         0 - If Income check fails additional business rules
"RTN","DGRPC2",192,0)
 ;
"RTN","DGRPC2",193,0)
 N VAMB,VASV,VA,VADMVT,VAEL,VAINDT,DGRTN,DGMED,DG,DG1,DGWARD,DGSRVC
"RTN","DGRPC2",194,0)
 ;
"RTN","DGRPC2",195,0)
 S DGRTN=0
"RTN","DGRPC2",196,0)
 D MB^VADPT I +VAMB(7) S DGRTN=1 G Q55  ; Check if receiving VA Disability
"RTN","DGRPC2",197,0)
 D SVC^VADPT I +VASV(4) S DGRTN=1 G Q55  ; check if POW status indicated
"RTN","DGRPC2",198,0)
 I +VASV(9),(+VASV(9,1)=3) S DGRTN=1 G Q55  ; Check if Purple Heart Status is Confirmed
"RTN","DGRPC2",199,0)
 D GETS^DIQ(2,DFN_",",".381:.383","I","DGMED")
"RTN","DGRPC2",200,0)
 I $G(DGMED(2,DFN_",",.381,"I")) S DGRTN=1 G Q55  ; Check if eligible for Medicaid
"RTN","DGRPC2",201,0)
 D ADM^VADPT2 ; Check for current admission to DOM ward 
"RTN","DGRPC2",202,0)
 I +$G(VADMVT) D  G:DGRTN Q55
"RTN","DGRPC2",203,0)
 . Q:'$$GET1^DIQ(43,1,16,"I")  ; Has Dom wards?
"RTN","DGRPC2",204,0)
 . S DGWARD=$$GET1^DIQ(405,VADMVT,.06,"I") ; Get ward location
"RTN","DGRPC2",205,0)
 . S DGSRVC=$$GET1^DIQ(42,DGWARD,.03,"I") ; Get ward service
"RTN","DGRPC2",206,0)
 . S:DGSRVC="D" DGRTN=1 ; If ward service is 'D', then return 1
"RTN","DGRPC2",207,0)
 ;
"RTN","DGRPC2",208,0)
 ; Additional checks for 0% SC
"RTN","DGRPC2",209,0)
 D ELIG^VADPT
"RTN","DGRPC2",210,0)
 I +VAEL(3),'$P(VAEL(3),U,2) D  ; Check if service connected with % of zero
"RTN","DGRPC2",211,0)
 . I +VAMB(4) S DGRTN=1 Q  ; Check if receiving a VA pension
"RTN","DGRPC2",212,0)
 . S DG=0 ; Check for secondary eligibilities
"RTN","DGRPC2",213,0)
 . F  S DG=$O(VAEL(1,DG)) Q:'DG  D  Q:DGRTN
"RTN","DGRPC2",214,0)
 . . F DG1=2,4,15,16,17,18 I DG=DG1 S DGRTN=1 Q
"RTN","DGRPC2",215,0)
 ; DG*5.3*657 BAJ
"RTN","DGRPC2",216,0)
 ; Additional business rules
"RTN","DGRPC2",217,0)
 ; Do NOT file inconsistency for the following:
"RTN","DGRPC2",218,0)
 ; 1. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, A&A = "YES"
"RTN","DGRPC2",219,0)
 ; 2. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, VA Pension = "YES"
"RTN","DGRPC2",220,0)
 ; 3. Patient Type is "NSC Veteran" and A&A = "YES"
"RTN","DGRPC2",221,0)
 ; 4. Patient Type is "NSC Veteran" and VA Pension = "YES"
"RTN","DGRPC2",222,0)
 ; Arrays elements used:
"RTN","DGRPC2",223,0)
 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
"RTN","DGRPC2",224,0)
 ; .. VAEL(6) $P 2 = PATIENT TYPE, "B" INDEX VALUE
"RTN","DGRPC2",225,0)
 ; .. VAMB(1) $P 1 = RECEIVING A&A
"RTN","DGRPC2",226,0)
 ; .. VAMB(4) $P 1 = RECEIVING VA PENSION
"RTN","DGRPC2",227,0)
 I $P(VAEL(1),"^",2)="SC LESS THAN 50%",+VAEL(3) S PCNT=$P(VAEL(3),"^",2) I PCNT'<10,PCNT'>50 S DGRTN=$S(+VAMB(1):1,VAMB(4):1,1:DGRTN)
"RTN","DGRPC2",228,0)
 I $P($G(VAEL(6)),"^",2)="NSC VETERAN" S DGRTN=$S(+VAMB(1):1,VAMB(4):1,1:DGRTN)
"RTN","DGRPC2",229,0)
 ;
"RTN","DGRPC2",230,0)
Q55 D KVAR^VADPT
"RTN","DGRPC2",231,0)
 Q $G(DGRTN)
"VER")
8.0^22.0
"^DD",43,43,1205,0)
VFA START DATE^D^^VFA;1^S %DT="EX" D ^%DT S X=Y K:3130101<X!(3120601>X) X
"^DD",43,43,1205,3)
Type a date between 6/1/2012 and 1/1/2013.
"^DD",43,43,1205,21,0)
^^5^5^3120904^
"^DD",43,43,1205,21,1,0)
The date, January 1,2013, that the Veteran Financial Assessment(VFA)
"^DD",43,43,1205,21,2,0)
project becomes operational.  A Primary Means Test(MT) on file less than
"^DD",43,43,1205,21,3,0)
or equal to 1 year old as of the VFA Start Date shall not expire.
"^DD",43,43,1205,21,4,0)
Otherwise, MTs older than 1 year shall be considered expired and a new MT
"^DD",43,43,1205,21,5,0)
shall be required.
"^DD",43,43,1205,"DT")
3120904
**INSTALL NAME**
EAS*1.0*106
"BLD",8437,0)
EAS*1.0*106^ENROLLMENT APPLICATION SYSTEM^0^3131219^y
"BLD",8437,1,0)
^^3^3^3120905^^
"BLD",8437,1,1,0)
This patch contains VistA changes to support technology and
"BLD",8437,1,2,0)
business changes that are occurring with the implementation of 
"BLD",8437,1,3,0)
Discontinue Annual Means Test Renewal.
"BLD",8437,4,0)
^9.64PA^^
"BLD",8437,6.3)
28
"BLD",8437,"ABPKG")
n
"BLD",8437,"INID")
^y
"BLD",8437,"INIT")
EAS1106P
"BLD",8437,"KRN",0)
^9.67PA^779.2^20
"BLD",8437,"KRN",.4,0)
.4
"BLD",8437,"KRN",.401,0)
.401
"BLD",8437,"KRN",.402,0)
.402
"BLD",8437,"KRN",.403,0)
.403
"BLD",8437,"KRN",.5,0)
.5
"BLD",8437,"KRN",.84,0)
.84
"BLD",8437,"KRN",3.6,0)
3.6
"BLD",8437,"KRN",3.8,0)
3.8
"BLD",8437,"KRN",9.2,0)
9.2
"BLD",8437,"KRN",9.8,0)
9.8
"BLD",8437,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",8437,"KRN",9.8,"NM",1,0)
EASECMT^^0^B37476470
"BLD",8437,"KRN",9.8,"NM",2,0)
EASMTCHK^^0^B37185022
"BLD",8437,"KRN",9.8,"NM","B","EASECMT",1)

"BLD",8437,"KRN",9.8,"NM","B","EASMTCHK",2)

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

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

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

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

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

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

"BLD",8437,"KRN","B",3.6,3.6)

"BLD",8437,"KRN","B",3.8,3.8)

"BLD",8437,"KRN","B",9.2,9.2)

"BLD",8437,"KRN","B",9.8,9.8)

"BLD",8437,"KRN","B",19,19)

"BLD",8437,"KRN","B",19.1,19.1)

"BLD",8437,"KRN","B",101,101)

"BLD",8437,"KRN","B",409.61,409.61)

"BLD",8437,"KRN","B",771,771)

"BLD",8437,"KRN","B",779.2,779.2)

"BLD",8437,"KRN","B",870,870)

"BLD",8437,"KRN","B",8989.51,8989.51)

"BLD",8437,"KRN","B",8989.52,8989.52)

"BLD",8437,"KRN","B",8994,8994)

"BLD",8437,"QUES",0)
^9.62^^
"BLD",8437,"REQB",0)
^9.611^2^2
"BLD",8437,"REQB",1,0)
EAS*1.0*46^2
"BLD",8437,"REQB",2,0)
EAS*1.0*88^2
"BLD",8437,"REQB","B","EAS*1.0*46",1)

"BLD",8437,"REQB","B","EAS*1.0*88",2)

"INIT")
EAS1106P
"MBREQ")
0
"PKG",187,-1)
1^1
"PKG",187,0)
ENROLLMENT APPLICATION SYSTEM^EAS^ENROLLMENT
"PKG",187,20,0)
^9.402P^^0
"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)
106^3131219^100992
"PKG",187,22,1,"PAH",1,1,0)
^^3^3^3131219
"PKG",187,22,1,"PAH",1,1,1,0)
This patch contains VistA changes to support technology and
"PKG",187,22,1,"PAH",1,1,2,0)
business changes that are occurring with the implementation of 
"PKG",187,22,1,"PAH",1,1,3,0)
Discontinue Annual Means Test Renewal.
"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")
3
"RTN","EAS1106P")
0^^B6761093
"RTN","EAS1106P",1,0)
EAS1106P ;ALB/PWC - VFA PROJECT POST-INSTALL ; 9/5/12 5:55pm
"RTN","EAS1106P",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**106**;MAR 15,2001;Build 28
"RTN","EAS1106P",3,0)
EN ; SET MENU OPTIONS OUT OF ORDER
"RTN","EAS1106P",4,0)
 D OUT,DEL
"RTN","EAS1106P",5,0)
 Q
"RTN","EAS1106P",6,0)
OUT N OPTION,TEXT
"RTN","EAS1106P",7,0)
 D BMES^XPDUTL("The following menu options for Means Test letters and reports have been placed out of order by this installation.")
"RTN","EAS1106P",8,0)
 S OPTION="",TEXT="Disabled by the VFA project. Do not use."
"RTN","EAS1106P",9,0)
 F OPTION="EAS MT AUTO LETTERS MENU","EAS MT LETTERS SEARCH","EAS MT RETURNED","EAS MT PRINT MENU","EAS MT 60 DAY LETTER PRINT","EAS MT 30 DAY LETTER PRINT" D PRINT
"RTN","EAS1106P",10,0)
 F OPTION="EAS MT 0 DAY LETTER PRINT","EAS MT REPRINT LETTERS","EAS MT REPRINT SINGLE LETTER","EAS MT REPORT OF CONTACT","EAS MT UES OVERRIDE" D PRINT
"RTN","EAS1106P",11,0)
 F OPTION="EAS MT REPORT MENU","EAS MT PENDING LETTERS","EAS MT SUMMARY REPORT","EAS MT STATISTICS SUMMARY","EAS MT UNRETURNED LETTERS","EAS MT APPT EXPIRATION RPT","EAS MT EXPIRATIONS" D PRINT
"RTN","EAS1106P",12,0)
 F OPTION="EAS MT UE STATUS","EAS MT SETUP MENU","EAS MT PARAMETERS","EAS MT PROHIBIT EDIT","EAS MT LETTERS EDIT","EAS MT TEST LETTER","EAS MT CLEAR IN USE FLAG" D PRINT
"RTN","EAS1106P",13,0)
 ; SET BACKGROUND JOBS OUT OF ORDER
"RTN","EAS1106P",14,0)
 F OPTION="EAS MT LETTERS BG PRINT","EAS MT LETTERS BG SEARCH","EAS MT EXPIRATION BG PRINT" D PRINT
"RTN","EAS1106P",15,0)
 Q
"RTN","EAS1106P",16,0)
PRINT ; PRINT OUT OF ORDER MENU OPTIONS
"RTN","EAS1106P",17,0)
 D OUT^XPDMENU(OPTION,TEXT)
"RTN","EAS1106P",18,0)
 D BMES^XPDUTL("["_OPTION_"]")
"RTN","EAS1106P",19,0)
 Q
"RTN","EAS1106P",20,0)
DEL ; CHECK TO SEE IF EAS MT AUTO LETTERS MENU IS ON ANY SUBMENUS AND DELETE
"RTN","EAS1106P",21,0)
 N OPIEN,ITEM,OPNM,ITEMNM
"RTN","EAS1106P",22,0)
 S OPIEN=$O(^DIC(19,"B","EAS MT AUTO LETTERS MENU","")) Q:OPIEN=""
"RTN","EAS1106P",23,0)
 S ITEM="" F  S ITEM=$O(^DIC(19,"AD",OPIEN,ITEM)) Q:ITEM=""  D
"RTN","EAS1106P",24,0)
 . S OPNM=$$GET1^DIQ(19,OPIEN,.01),ITEMNM=$$GET1^DIQ(19,ITEM,.01)
"RTN","EAS1106P",25,0)
 . D DELETE^XPDMENU(ITEMNM,OPNM)
"RTN","EAS1106P",26,0)
 Q
"RTN","EASECMT")
0^1^B37476470
"RTN","EASECMT",1,0)
EASECMT ;ALB/LBD,BDB - Means Test for LTC Co-Pay exemption ; 27 DEC 2001
"RTN","EASECMT",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,16,18,70,88,106**;Mar 15, 2001;Build 28
"RTN","EASECMT",3,0)
 ;
"RTN","EASECMT",4,0)
EN ; This is the entry point for the routine that will find the 
"RTN","EASECMT",5,0)
 ; financial test for a veteran that can be used to check if
"RTN","EASECMT",6,0)
 ; veteran's income is below the threshold and exempt from LTC
"RTN","EASECMT",7,0)
 ; co-payments.  If a financial test is not on file for the veteran
"RTN","EASECMT",8,0)
 ; it can be added through this process.
"RTN","EASECMT",9,0)
 ;  Input --      DFN = Patient IEN
"RTN","EASECMT",10,0)
 ;  Output --     DGEXMPT = 1 (exempt from LTC co-payments)
"RTN","EASECMT",11,0)
 ;                        = 0 or "" (not exempt from LTC co-payments)
"RTN","EASECMT",12,0)
 ;                DGOUT = 1 (user wants to exit from the process) 
"RTN","EASECMT",13,0)
 N DGCMPLT,DGMTI,DGMTDT,DGMTYPT,DGMTACT,DGL,DGCS,DGMSGF,DGREQF,DGDOM,DGDOM1,Y
"RTN","EASECMT",14,0)
 ; Does veteran have current LTC co-pay exemption test (type 4)?
"RTN","EASECMT",15,0)
 S Y=$$GETLTC4(DFN) I Y S DGEXMPT=$S($P(Y,U,3)="EXEMPT":1,1:0) Q
"RTN","EASECMT",16,0)
 ; Does veteran have current means test?
"RTN","EASECMT",17,0)
 S DGL=$$LST^DGMTU(DFN),DGMTI=+DGL,DGMTDT=$P(DGL,U,2),DGCS=$P(DGL,U,4)
"RTN","EASECMT",18,0)
 ; If last means test has status of Cat C or Pend. Adj. and vet agreed
"RTN","EASECMT",19,0)
 ; to pay MT copay, new means test is not required
"RTN","EASECMT",20,0)
 I ((DGCS="C")!(DGCS="P")),$P($G(^DGMT(408.31,DGMTI,0)),U,11)=1,DGMTDT>2991005 S DGEXMPT=0 D LTC4(DGMTI,DGEXMPT) Q
"RTN","EASECMT",21,0)
 ; If means test is required or more than a year old, do new means test
"RTN","EASECMT",22,0)
 ; EAS*1.0*106 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","EASECMT",23,0)
 I (DGCS="R")!($$OLDMTPF^DGMTU4(DGMTDT)) D  Q:$G(DGOUT)!(DGMTYPT=4)
"RTN","EASECMT",24,0)
 .S (DGADDF,DGMSGF)=1 D ^DGMTR S DGMTYPT=$S(DGREQF:1,1:4)
"RTN","EASECMT",25,0)
 .I '$$ASK(DGMTYPT) S DGOUT=1 Q
"RTN","EASECMT",26,0)
 .S DGMTACT="ADD" I DGMTYPT=1,$E(DGMTDT,1,3)=$E(DT,1,3) S DGMTACT="EDT"
"RTN","EASECMT",27,0)
 .D MT(DFN,DGMTYPT,DGMTACT,.DGMTI,.DGCMPLT)
"RTN","EASECMT",28,0)
 .I '$G(DGCMPLT) S DGOUT=1 Q
"RTN","EASECMT",29,0)
 .I DGMTYPT=4 D
"RTN","EASECMT",30,0)
 ..D DOM^DGMTR I '$G(DGDOM1) D COPYRX^DGMTR1(DFN,DGMTI)
"RTN","EASECMT",31,0)
 ..S Y=$$GETCODE^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),U,3)),DGEXMPT=$S(Y=0:1,1:0)
"RTN","EASECMT",32,0)
 ; If no means test or means test is no longer required, check if
"RTN","EASECMT",33,0)
 ; there is an RX co-pay test, otherwise do new LTC co-pay exemption test
"RTN","EASECMT",34,0)
 I DGCS=""!(DGCS="N") D  Q:$G(DGOUT)!($G(DGMTYPT)=4)
"RTN","EASECMT",35,0)
 .S DGL=$$LST^DGMTU(DFN,DT,2),DGMTI=+DGL,DGMTDT=$P(DGL,U,2),DGCS=$P(DGL,U,4)
"RTN","EASECMT",36,0)
 .I DGMTI,'$$OLD^DGMTU4(DGMTDT),("^I^L^")'[("^"_DGCS_"^") Q
"RTN","EASECMT",37,0)
 .S DGMTYPT=4
"RTN","EASECMT",38,0)
 .I '$$ASK(DGMTYPT) S DGOUT=1 Q
"RTN","EASECMT",39,0)
 .D MT(DFN,DGMTYPT,"ADD",.DGMTI,.DGCMPLT)
"RTN","EASECMT",40,0)
 .I '$G(DGCMPLT) S DGOUT=1 Q
"RTN","EASECMT",41,0)
 .D DOM^DGMTR I '$G(DGDOM1) D COPYRX^DGMTR1(DFN,DGMTI)
"RTN","EASECMT",42,0)
 .S Y=$$GETCODE^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),U,3))
"RTN","EASECMT",43,0)
 .S DGEXMPT=$S(Y=0:1,1:0)
"RTN","EASECMT",44,0)
 ; Check if veteran's income is below the pension threshold
"RTN","EASECMT",45,0)
 S DGEXMPT=$$THRES(DFN,DGMTDT)
"RTN","EASECMT",46,0)
 I DGEXMPT<0 W !!,"The income threshold check could not be completed due to an error." S DGOUT=1 Q
"RTN","EASECMT",47,0)
 ; Create LTC co-pay exemption test (type 4) by copying MT
"RTN","EASECMT",48,0)
 D LTC4(DGMTI,DGEXMPT)
"RTN","EASECMT",49,0)
 Q
"RTN","EASECMT",50,0)
 ;
"RTN","EASECMT",51,0)
THRES(DFN,DGMTDT) ; Is veteran's income below the pension threshold
"RTN","EASECMT",52,0)
 ; Input   -  DFN = Patient IEN
"RTN","EASECMT",53,0)
 ;            DGMTDT = Test date
"RTN","EASECMT",54,0)
 ; Output  -   = 1 (Below the threshold)
"RTN","EASECMT",55,0)
 ;             = 0 (Above the threshold)
"RTN","EASECMT",56,0)
 ;             = -1(Error)
"RTN","EASECMT",57,0)
 N DGDC,DGDEP,DGDET,DGERR,DGIN0,DGIN1,DGIN2,DGINI,DGINT,DGINTF,DGIRI
"RTN","EASECMT",58,0)
 N DGNC,DGND,DGNWT,DGNWTF,DGPRI,DGSP,DGVINI,DGVIR0,DGVIRI,DGTHRES
"RTN","EASECMT",59,0)
 N DGLY,DGMTPAR
"RTN","EASECMT",60,0)
 ; Get current single veteran pension threshold amount
"RTN","EASECMT",61,0)
 S DGTHRES=$$THRES^IBARXEU1(DGMTDT,1,0) I '+DGTHRES Q -1
"RTN","EASECMT",62,0)
 ; Calculate veteran's income level and check against the threshold
"RTN","EASECMT",63,0)
 S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) I 'DGPRI Q -1
"RTN","EASECMT",64,0)
 D GETIENS^DGMTU2(DFN,DGPRI,DGMTDT) I '$G(DGIRI),'$G(DGINI) Q -1
"RTN","EASECMT",65,0)
 S DGVIRI=DGIRI,DGVINI=DGINI
"RTN","EASECMT",66,0)
 S DGLY=$$LYR^DGMTSCU1(DGMTDT) D PAR^DGMTSCU
"RTN","EASECMT",67,0)
 D DEP^DGMTSCU2,INC^DGMTSCU3 I '$D(DGINT) Q -1
"RTN","EASECMT",68,0)
 ; If vet declined to provide financial info, return 0 (above threshold)
"RTN","EASECMT",69,0)
 I $P($G(^DGMT(408.31,+$G(DGMTI),0)),U,14) Q 0
"RTN","EASECMT",70,0)
 I (DGINT-DGDET)'>+DGTHRES Q 1
"RTN","EASECMT",71,0)
 Q 0
"RTN","EASECMT",72,0)
 ;
"RTN","EASECMT",73,0)
MT(DFN,TYPE,ACT,DGMTI,DGCMPLT) ; Complete a means test or LTC co-pay exemption test
"RTN","EASECMT",74,0)
 ; Input    -  DFN = Patient IEN
"RTN","EASECMT",75,0)
 ;             TYPE = Type of test (1=MT; 4=LTC4)
"RTN","EASECMT",76,0)
 ;             ACT = Type of action (ADD or EDT)
"RTN","EASECMT",77,0)
 ;             DGMTI = If EDT action, IEN of test to be edited
"RTN","EASECMT",78,0)
 ; Output   -  DGCMPLT = 1 (MT completed)
"RTN","EASECMT",79,0)
 ;                     = 0 (MT not completed)
"RTN","EASECMT",80,0)
 ;             DGMTI = IEN of new test
"RTN","EASECMT",81,0)
 N DGMTYPT,DGMTACT,DGMTROU,DGMT0,DGSTA,TYPESAVE,DGCMPLT
"RTN","EASECMT",82,0)
 S DGCMPLT=0
"RTN","EASECMT",83,0)
 I $$LOCK^DGMTUTL(DFN) E  Q DGCMPLT
"RTN","EASECMT",84,0)
 S DGMTYPT=TYPE,DGMTACT=ACT
"RTN","EASECMT",85,0)
 S TYPESAVE=TYPE ;*GTS - EAS*1*70
"RTN","EASECMT",86,0)
 S DGMTDT=$S(DGMTACT="EDT":+$G(^DGMT(408.31,DGMTI,0)),1:DT) I 'DGMTDT D MT1 Q
"RTN","EASECMT",87,0)
 ;*GTS - EAS*1*70
"RTN","EASECMT",88,0)
 ; If adding a LTC CP Exemption test, TYPE indicates test copied from for ADD^DGMTA
"RTN","EASECMT",89,0)
 I DGMTACT="ADD" S:TYPE=4 TYPE=1 D ADD^DGMTA S TYPE=TYPESAVE I '$G(DGMTI) D MT1 Q
"RTN","EASECMT",90,0)
 S DGMTROU="MT1^EASECMT"
"RTN","EASECMT",91,0)
 G EN^DGMTSC
"RTN","EASECMT",92,0)
MT1 I $G(DGMTI) D
"RTN","EASECMT",93,0)
 .S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGSTA=$$GETCODE^DGMTH($P(DGMT0,U,3))
"RTN","EASECMT",94,0)
 .I DGSTA'="","ACP01"[DGSTA,$P(DGMT0,U,7)]"" S DGCMPLT=1
"RTN","EASECMT",95,0)
 .I 'DGCMPLT,TYPE=4 D DEL  ;Delete incomplete LTC copay exemption test
"RTN","EASECMT",96,0)
 D UNLOCK^DGMTUTL(DFN)
"RTN","EASECMT",97,0)
 Q
"RTN","EASECMT",98,0)
 ;
"RTN","EASECMT",99,0)
LTC4(DGMT,DGEXMPT) ; Create or update LTC copay exemption test (type 4) by copying
"RTN","EASECMT",100,0)
 ; means test
"RTN","EASECMT",101,0)
 ; Input   -   DGMT = Annual Means Test IEN of test to be copied
"RTN","EASECMT",102,0)
 ;         -   DGEXMPT = LTC copayments exemption status (optional)
"RTN","EASECMT",103,0)
 Q:'DGMT
"RTN","EASECMT",104,0)
 N DGMT0,DGMT2,DA,DIC,DIK,DLAYGO,X,DFN,DGMTI,DGCONVRT
"RTN","EASECMT",105,0)
 N DGMTA,DGMTP,DGMTACT,DGMTINF,DGMTYPT
"RTN","EASECMT",106,0)
 ; Quit if this is a LTC copay exemption test (type 4)
"RTN","EASECMT",107,0)
 S DGMT0=$G(^DGMT(408.31,DGMT,0)) I $P(DGMT0,U,19)=4 Q
"RTN","EASECMT",108,0)
 S DGMT2=$G(^DGMT(408.31,DGMT,2))
"RTN","EASECMT",109,0)
 ; Add a new LTC 4 test or edit an existing LTC 4 test?
"RTN","EASECMT",110,0)
 S DGMTI=$O(^DGMT(408.31,"AT",DGMT,0))
"RTN","EASECMT",111,0)
 S DGMTACT=$S(DGMTI:"EDT",1:"ADD")
"RTN","EASECMT",112,0)
 S DGMTP="" I DGMTACT="EDT" S DGMTP=$G(^DGMT(408.31,DGMTI,0))
"RTN","EASECMT",113,0)
 S DFN=$P(DGMT0,U,2)
"RTN","EASECMT",114,0)
 ; Add new entry to Annual Means Test file (#408.31) for LTC 4 test
"RTN","EASECMT",115,0)
 I DGMTACT="ADD" D  Q:DGMTI'>0
"RTN","EASECMT",116,0)
 .S X=+DGMT0,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
"RTN","EASECMT",117,0)
 .D FILE^DICN S DGMTI=+Y
"RTN","EASECMT",118,0)
 .;*GTS - EAS*1*70
"RTN","EASECMT",119,0)
 .S DGCONVRT=$$VRCHKUP^DGMTU2(4,$P(DGMT0,"^",19),+DGMT0,+DGMT0)
"RTN","EASECMT",120,0)
 .S DATA(2.11)=1
"RTN","EASECMT",121,0)
 F I=.01,.02,.04,.05,.06,.11,.14,.15,.18,.23 S DATA(I)=$P(DGMT0,U,(I/.01))
"RTN","EASECMT",122,0)
 I '$D(DGEXMPT) S DGEXMPT=$$THRES(DFN,$P(DGMT0,U,1))
"RTN","EASECMT",123,0)
 S DATA(.03)=$S(DGEXMPT:15,1:14),DATA(.07)=DT
"RTN","EASECMT",124,0)
 S DATA(.019)=4,DATA(2.02)=$P(DGMT2,U,2),DATA(2.08)=DGMT
"RTN","EASECMT",125,0)
 S DATA(2.05)=$P(DGMT2,U,5)
"RTN","EASECMT",126,0)
 I $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
"RTN","EASECMT",127,0)
 K DATA,ERROR
"RTN","EASECMT",128,0)
 ; Update the LTC copay test (type 3), if status changed
"RTN","EASECMT",129,0)
 I DGMTACT="EDT" D UPLTC3(DGMTI)
"RTN","EASECMT",130,0)
 ; Update Audit file and IVM Patient file
"RTN","EASECMT",131,0)
 S DGMTYPT=4,DGMTINF=1 D AFTER^DGMTEVT
"RTN","EASECMT",132,0)
 D EN^DGMTAUD
"RTN","EASECMT",133,0)
 D EN^IVMPMTE
"RTN","EASECMT",134,0)
 Q
"RTN","EASECMT",135,0)
 ;
"RTN","EASECMT",136,0)
ASK(TYPE) ; Does user want to perform MT/LTC4 test now?
"RTN","EASECMT",137,0)
 ; Input   -   TYPE = Type of test, 1: MT; 4: LTC Copay Exemption
"RTN","EASECMT",138,0)
 ; Output  -   Y = 1 (YES)
"RTN","EASECMT",139,0)
 ;               = 0 (NO)
"RTN","EASECMT",140,0)
 N DIR,TST
"RTN","EASECMT",141,0)
 S TST=$S(TYPE=1:"Means Test",1:"LTC Copay Exemption Test")
"RTN","EASECMT",142,0)
 W !!,"The previous year's financial information is not on file for this veteran.",!,"A ",TST," is required."
"RTN","EASECMT",143,0)
 S DIR("A")="Do you wish to complete the "_TST_" at this time"
"RTN","EASECMT",144,0)
 S DIR("B")="NO",DIR(0)="Y"
"RTN","EASECMT",145,0)
 W ! D ^DIR
"RTN","EASECMT",146,0)
 Q +(Y)
"RTN","EASECMT",147,0)
 ;
"RTN","EASECMT",148,0)
GETLTC4(DFN,DGMTDT) ; Return last LTC co-pay exemption test (type 4),
"RTN","EASECMT",149,0)
 ; if less than a year old
"RTN","EASECMT",150,0)
 ; Input   -   DFN = Patient IEN
"RTN","EASECMT",151,0)
 ;             DGMTDT (optional) = Date of test
"RTN","EASECMT",152,0)
 ; Output  -   Y = Annual Means Test IEN^Date of Test^Status Name^
"RTN","EASECMT",153,0)
 ;                    Status Code^Source of Test
"RTN","EASECMT",154,0)
 ;               = "" (no current LTC co-pay exemption test)
"RTN","EASECMT",155,0)
 N Y
"RTN","EASECMT",156,0)
 S Y="" Q:'$G(DFN) Y I '$G(DGMTDT) S DGMTDT=DT
"RTN","EASECMT",157,0)
 S Y=$$LST^DGMTU(DFN,DGMTDT,4) I '(+Y) Q Y
"RTN","EASECMT",158,0)
 I $$OLD^DGMTU4($P(Y,U,2)) S Y=""
"RTN","EASECMT",159,0)
 Q Y
"RTN","EASECMT",160,0)
 ;
"RTN","EASECMT",161,0)
DEL ;Delete incomplete LTC Copay Exemption test (type 4)
"RTN","EASECMT",162,0)
 ; Input   -- DGMTI  LTC Copay Exemption test IEN
"RTN","EASECMT",163,0)
 N DA,DIK,DIE,DR,V
"RTN","EASECMT",164,0)
 Q:'$G(DGMTI)  Q:$P($G(^DGMT(408.31,DGMTI,0)),U,19)'=4
"RTN","EASECMT",165,0)
 ; Delete pointer in Income Relation file (#408.22)
"RTN","EASECMT",166,0)
 I $D(^DGMT(408.22,"AMT",DGMTI)) D
"RTN","EASECMT",167,0)
 .S DIE="^DGMT(408.22,",DR="31///@"
"RTN","EASECMT",168,0)
 .S V=$O(^DGMT(408.22,"AMT",DGMTI,0)) Q:'V
"RTN","EASECMT",169,0)
 .S IR=0 F  S IR=$O(^DGMT(408.22,"AMT",DGMTI,V,IR)) Q:'IR  S DA=$O(^(IR,0)) I DA D ^DIE
"RTN","EASECMT",170,0)
 ; Delete LTC Copay Exemption test from Annual Means Test file (#408.31)
"RTN","EASECMT",171,0)
 S DA=DGMTI,DIK="^DGMT(408.31,"
"RTN","EASECMT",172,0)
 D ^DIK
"RTN","EASECMT",173,0)
 Q
"RTN","EASECMT",174,0)
 ;
"RTN","EASECMT",175,0)
UPLTC3(DGMT4) ;If the status of a LTC Copay Exemption test (type 4) changes,
"RTN","EASECMT",176,0)
 ;update the status of the LTC Copay test (type 3), if necessary
"RTN","EASECMT",177,0)
 ;  Input   -- DGMT4  LTC Copay Exemption test IEN
"RTN","EASECMT",178,0)
 N DGMT3,DGMTS4,DGMTS3,DGS,DATA,ERROR
"RTN","EASECMT",179,0)
 Q:'DGMT4
"RTN","EASECMT",180,0)
 S DGMT3=$O(^DGMT(408.31,"AT",DGMT4,0)) Q:$G(^DGMT(408.31,+DGMT3,0))=""
"RTN","EASECMT",181,0)
 ; Get test status
"RTN","EASECMT",182,0)
 S DGMTS4=$$GETNAME^DGMTH($P(^DGMT(408.31,DGMT4,0),U,3))
"RTN","EASECMT",183,0)
 S DGMTS3=$$GETNAME^DGMTH($P(^DGMT(408.31,DGMT3,0),U,3))
"RTN","EASECMT",184,0)
 ; If test status is the same quit
"RTN","EASECMT",185,0)
 I DGMTS4=DGMTS3 Q
"RTN","EASECMT",186,0)
 ; If LTC copay test (type 3) is Exempt and the Reason for Exemption is
"RTN","EASECMT",187,0)
 ; anything other than 2 (Income Last Year Below Threshold), quit
"RTN","EASECMT",188,0)
 I DGMTS3="EXEMPT",$P($G(^DGMT(408.31,DGMT3,2)),U,7)'=2 Q
"RTN","EASECMT",189,0)
 ; Get IEN of Means Test Status and update LTC copay test
"RTN","EASECMT",190,0)
 S DGS="" F  S DGS=$O(^DG(408.32,"B",DGMTS4,DGS)) Q:'DGS  I $P(^DG(408.32,DGS,0),U,19)=3 Q
"RTN","EASECMT",191,0)
 S DATA(.03)=DGS,DATA(2.07)=$S(DGMTS4="EXEMPT":2,1:"@")
"RTN","EASECMT",192,0)
 I $$UPD^DGENDBS(408.31,DGMT3,.DATA,.ERROR)
"RTN","EASECMT",193,0)
 Q
"RTN","EASMTCHK")
0^2^B37185022
"RTN","EASMTCHK",1,0)
EASMTCHK ;ALB/SCK,PJR,BDB -  MEANS TEST BLOCKING CHECK ; 11/13/03 11:13am
"RTN","EASMTCHK",2,0)
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,12,15,38,46,106**;MAR 15,2001;Build 28
"RTN","EASMTCHK",3,0)
 ; This routine provides an API, which when called from Appointment Management will allow 
"RTN","EASMTCHK",4,0)
 ; for the blocking of future appointments and appointment check-in/out if the patient 
"RTN","EASMTCHK",5,0)
 ; requires a Means Test or has a Means Test Status of Required. $$LST^DGMTU is used 
"RTN","EASMTCHK",6,0)
 ; to determine if a MT is REQUIRED.  If a MT does not have a status of REQUIRED, 
"RTN","EASMTCHK",7,0)
 ; but is more than 365 days out (same criteria used in OLD^DGMTU4), the MT will 
"RTN","EASMTCHK",8,0)
 ; be considered "REQUIRED" for blocking purposes. If a Means Test is required, the 
"RTN","EASMTCHK",9,0)
 ; following combinations of appointment actions will be blocked:
"RTN","EASMTCHK",10,0)
 ;    o Making a future appt for a Regular appt type
"RTN","EASMTCHK",11,0)
 ;    o Check In/Out an appt which is either a Regular or Research type
"RTN","EASMTCHK",12,0)
 ;
"RTN","EASMTCHK",13,0)
 ; A Walk-in will see the alert notice, and will be warned NOT to CHECK-IN the walk-in 
"RTN","EASMTCHK",14,0)
 ; appointment. Unscheduled/Walk-ins can ONLY be checked out.
"RTN","EASMTCHK",15,0)
 ;
"RTN","EASMTCHK",16,0)
 ; This API may be passed a flag to "silence" the screen display of the alert message, and 
"RTN","EASMTCHK",17,0)
 ; will accept an array variable to return the alert text in. Inpatient appointments 
"RTN","EASMTCHK",18,0)
 ; are not affected in any way.  Domicilary are not considered inpatients for the purpose 
"RTN","EASMTCHK",19,0)
 ; of Means Test Blocking for appointments
"RTN","EASMTCHK",20,0)
 ;
"RTN","EASMTCHK",21,0)
MT(DFN,EASAPT,EASACT,EASDT,EASQT,EASMSG) ; Entry point for MT Check
"RTN","EASMTCHK",22,0)
 ; Input Variables
"RTN","EASMTCHK",23,0)
 ;    DFN    - Patient's IEN in File #2
"RTN","EASMTCHK",24,0)
 ;    EASAPT - Appointment Type (File #409.1) [Optional]
"RTN","EASMTCHK",25,0)
 ;    EASACT - Appointment Action Flag [Optional] Default = "Other"
"RTN","EASMTCHK",26,0)
 ;             "M"  - Make an Appointment
"RTN","EASMTCHK",27,0)
 ;             "C"  - Check In/Out an existing appointment
"RTN","EASMTCHK",28,0)
 ;             "W"  - Unscheduled/Walk-in appointment
"RTN","EASMTCHK",29,0)
 ;             "O"  - Other
"RTN","EASMTCHK",30,0)
 ;             "L"  - Letters
"RTN","EASMTCHK",31,0)
 ;
"RTN","EASMTCHK",32,0)
 ;    EASDT  - Appointment Date/Time [Optional]
"RTN","EASMTCHK",33,0)
 ;    EASQT  - Silent flag [Optional], if set will prevent display of alert message
"RTN","EASMTCHK",34,0)
 ;    EASMSG - Return array for alert message [Optional], if passed in, the alert 
"RTN","EASMTCHK",35,0)
 ;             message text will be copied to this array
"RTN","EASMTCHK",36,0)
 ;
"RTN","EASMTCHK",37,0)
 ; Output
"RTN","EASMTCHK",38,0)
 ;    1  - Block action (MT Required)
"RTN","EASMTCHK",39,0)
 ;    0  - Don't block action (MT Not required)
"RTN","EASMTCHK",40,0)
 ;
"RTN","EASMTCHK",41,0)
 N RSLT,EASMT,EASTXT,EASX,EAMTS,DSPLY,IENS
"RTN","EASMTCHK",42,0)
 ;
"RTN","EASMTCHK",43,0)
 S RSLT=0
"RTN","EASMTCHK",44,0)
 S EASQT=+$G(EASQT)
"RTN","EASMTCHK",45,0)
 S EASAPT=+$G(EASAPT)
"RTN","EASMTCHK",46,0)
 S EASDT=$G(EASDT)
"RTN","EASMTCHK",47,0)
 S EASACT=$G(EASACT)
"RTN","EASMTCHK",48,0)
 S:EASACT']"" EASACT="O"
"RTN","EASMTCHK",49,0)
 ; If Appt type is not defined, action is CI/CO, get appt date
"RTN","EASMTCHK",50,0)
 I 'EASAPT,EASACT="C",EASDT]"" D
"RTN","EASMTCHK",51,0)
 .N DGARRAY,SDCNT
"RTN","EASMTCHK",52,0)
 .S DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY("FLDS")=10
"RTN","EASMTCHK",53,0)
 .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
"RTN","EASMTCHK",54,0)
 .S EASAPT=+$P($G(^TMP($J,"SDAMA301",DFN,EASDT)),U,10)
"RTN","EASMTCHK",55,0)
 .K DGARRAY,SDCNT,^TMP($J,"SDAMA301")
"RTN","EASMTCHK",56,0)
 ;
"RTN","EASMTCHK",57,0)
 Q:$$INP(DFN) RSLT       ; Quit if inpatient
"RTN","EASMTCHK",58,0)
 S EAMTS=$$MTCHK(DFN,EASACT)    ; Get MT Check flag
"RTN","EASMTCHK",59,0)
 Q:'EAMTS RSLT
"RTN","EASMTCHK",60,0)
 ;
"RTN","EASMTCHK",61,0)
 ;Build Alert message 
"RTN","EASMTCHK",62,0)
 D BLDMSG(EASACT,.EASTXT)
"RTN","EASMTCHK",63,0)
 I $D(EASMSG) M @EASMSG=EASTXT ; If output array defined,copy message test
"RTN","EASMTCHK",64,0)
 ;
"RTN","EASMTCHK",65,0)
 ; Check appointment action and appointment type.  Set blocking action
"RTN","EASMTCHK",66,0)
 I EASACT="M",EASAPT=9 S (DSPLY,RSLT)=1 ; Make an Appt.
"RTN","EASMTCHK",67,0)
 ;
"RTN","EASMTCHK",68,0)
 I EASACT="C" D  ; Check-in an appt.
"RTN","EASMTCHK",69,0)
 . I $G(EASAPT)=9 S (DSPLY,RSLT)=1
"RTN","EASMTCHK",70,0)
 ;
"RTN","EASMTCHK",71,0)
 I "W,O"[EASACT D  ; Walk-in/Other appt.
"RTN","EASMTCHK",72,0)
 . S:$G(EASAPT)=9 DSPLY=1
"RTN","EASMTCHK",73,0)
 ;
"RTN","EASMTCHK",74,0)
 I $G(DSPLY) D
"RTN","EASMTCHK",75,0)
 . Q:EASQT  ; If silent flag is set, do not display alert
"RTN","EASMTCHK",76,0)
 . S EASX=0
"RTN","EASMTCHK",77,0)
 . W !?5,$CHAR(7),"******************************************************"
"RTN","EASMTCHK",78,0)
 . F  S EASX=$O(EASTXT(EASX)) Q:'EASX  D
"RTN","EASMTCHK",79,0)
 . . W !?5,EASTXT(EASX)
"RTN","EASMTCHK",80,0)
 ;
"RTN","EASMTCHK",81,0)
 ; Check for override key on making appointments
"RTN","EASMTCHK",82,0)
 I EASACT="M" D
"RTN","EASMTCHK",83,0)
 . I $D(^XUSEC("EAS MTOVERRIDE",DUZ)) S RSLT=0
"RTN","EASMTCHK",84,0)
 Q $G(RSLT)
"RTN","EASMTCHK",85,0)
 ;
"RTN","EASMTCHK",86,0)
MTCHK(DFN,EASACT) ; Check Means Test Status
"RTN","EASMTCHK",87,0)
 ; Input
"RTN","EASMTCHK",88,0)
 ;     DFN
"RTN","EASMTCHK",89,0)
 ;
"RTN","EASMTCHK",90,0)
 ; Output  
"RTN","EASMTCHK",91,0)
 ;     0   OK
"RTN","EASMTCHK",92,0)
 ;     1   MEANS TEST Required
"RTN","EASMTCHK",93,0)
 ;
"RTN","EASMTCHK",94,0)
 N RSLT,EASTAT,EASDT
"RTN","EASMTCHK",95,0)
 ;
"RTN","EASMTCHK",96,0)
 S RSLT=0
"RTN","EASMTCHK",97,0)
 S EASTAT=$$LST^DGMTU(DFN,"",1)
"RTN","EASMTCHK",98,0)
 I EASTAT]"" D
"RTN","EASMTCHK",99,0)
 . I $P(EASTAT,U,4)="R" S RSLT=1 Q
"RTN","EASMTCHK",100,0)
 . ;; Condition Check: MT Stat="P" AND GMT Threshold>Threshold A
"RTN","EASMTCHK",101,0)
 . ;;  AND MT Date is after 10/5/1999 AND Agrees to pay Deductible
"RTN","EASMTCHK",102,0)
 . ;;  AND MT Date is older than 365 days, THEN MT is required
"RTN","EASMTCHK",103,0)
 . ;; EAS*1.0*106  MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","EASMTCHK",104,0)
 . I $P(EASTAT,U,4)="P",$$GET1^DIQ(408.31,+EASTAT,.27,"I")>$$GET1^DIQ(408.31,+EASTAT,.12,"I"),$P(EASTAT,U,2)>2991005,$$GET1^DIQ(408.31,+EASTAT,.11,"I"),$$OLDMTPF^DGMTU4($P(EASTAT,U,2)) S RSLT=1 Q
"RTN","EASMTCHK",105,0)
 . ;; Condition Check: Cat C or Pending Adj.
"RTN","EASMTCHK",106,0)
 . ;;  AND Agrees to pay Deductible AND MT date after 10/5/1999
"RTN","EASMTCHK",107,0)
 . I "C,P"[$P(EASTAT,U,4),$$GET1^DIQ(408.31,+EASTAT,.11,"I"),$P(EASTAT,U,2)>2991005 Q
"RTN","EASMTCHK",108,0)
 . ;; EAS*1.0*106  MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","EASMTCHK",109,0)
 . I $P(EASTAT,U,4)="P",$$GET1^DIQ(408.31,+EASTAT,.27,"I")>$$GET1^DIQ(408.31,+EASTAT,.12,"I"),$P(EASTAT,U,2)>2991005,$$GET1^DIQ(408.31,+EASTAT,.11,"I"),$$OLDMTPF^DGMTU4($P(EASTAT,U,2)) S RSLT=1 Q
"RTN","EASMTCHK",110,0)
 . ;; Condition Check: Cat C AND Declines to give income information AND Agreed to pay deductible
"RTN","EASMTCHK",111,0)
 . I $P(EASTAT,U,4)="C",$$GET1^DIQ(408.31,+EASTAT,.14,"I"),$$GET1^DIQ(408.31,+EASTAT,.11,"I") Q
"RTN","EASMTCHK",112,0)
 . S EASDT=$P(EASTAT,U,2)
"RTN","EASMTCHK",113,0)
 . ;; EAS*1.0*106  MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","EASMTCHK",114,0)
 . I $$OLDMTPF^DGMTU4(EASDT) S RSLT=1
"RTN","EASMTCHK",115,0)
 . I $G(EASACT)="L" D
"RTN","EASMTCHK",116,0)
 . . ;; For letters, need to check for letters past 60-day threshold
"RTN","EASMTCHK",117,0)
 . . I ($$FMDIFF^XLFDT(DT,EASDT)>304) S RSLT=1
"RTN","EASMTCHK",118,0)
 ;
"RTN","EASMTCHK",119,0)
 I $P(EASTAT,U,4)="N" S RSLT=0
"RTN","EASMTCHK",120,0)
 Q $G(RSLT)
"RTN","EASMTCHK",121,0)
 ;
"RTN","EASMTCHK",122,0)
BLDMSG(EASACT,EASTXT) ; Build alert message to user
"RTN","EASMTCHK",123,0)
 N LINE
"RTN","EASMTCHK",124,0)
 ;
"RTN","EASMTCHK",125,0)
 S LINE=1
"RTN","EASMTCHK",126,0)
 S EASTXT(LINE)="Means Test Alert",LINE=LINE+1
"RTN","EASMTCHK",127,0)
 S EASTXT(LINE)="A Means Test is required or needs to be completed.",LINE=LINE+1
"RTN","EASMTCHK",128,0)
 ;
"RTN","EASMTCHK",129,0)
 I "M,C,W"[EASACT D
"RTN","EASMTCHK",130,0)
 . S EASTXT(LINE)="Please perform MEANS TEST or instruct patient",LINE=LINE+1
"RTN","EASMTCHK",131,0)
 . S EASTXT(LINE)="to report for Means Test interview.",LINE=LINE+1
"RTN","EASMTCHK",132,0)
 ;
"RTN","EASMTCHK",133,0)
 I EASACT="M" D
"RTN","EASMTCHK",134,0)
 . S EASTXT(LINE)=">> A future appointment cannot be made at this time."
"RTN","EASMTCHK",135,0)
 . S:$D(^XUSEC("EAS MTOVERRIDE",DUZ)) EASTXT(LINE)=">> Override Key in Effect."
"RTN","EASMTCHK",136,0)
 . S LINE=LINE+1
"RTN","EASMTCHK",137,0)
 ;
"RTN","EASMTCHK",138,0)
 I EASACT="C" S EASTXT(LINE)=">> This action may not be completed at this time.",LINE=LINE+1
"RTN","EASMTCHK",139,0)
 I EASACT="W" D
"RTN","EASMTCHK",140,0)
 . S EASTXT(LINE)=">> Check-Out ONLY.  Do NOT Check-In (CI) a walk-in appointment",LINE=LINE+1
"RTN","EASMTCHK",141,0)
 . S EASTXT(LINE)="   You will not be able to check-out the appt. if you do so.",LINE=LINE+1
"RTN","EASMTCHK",142,0)
 Q
"RTN","EASMTCHK",143,0)
 ;
"RTN","EASMTCHK",144,0)
INP(DFN) ; Check on Inpatient status
"RTN","EASMTCHK",145,0)
 ;  Input
"RTN","EASMTCHK",146,0)
 ;     DFN   - IEN from patient file
"RTN","EASMTCHK",147,0)
 ;  Output
"RTN","EASMTCHK",148,0)
 ;     1 - Patient has Inpatient status 
"RTN","EASMTCHK",149,0)
 ;     0 - Patient does not have Inpatient status
"RTN","EASMTCHK",150,0)
 ;  Default
"RTN","EASMTCHK",151,0)
 ;     Inpatient API defaults to TODAY for inpatient status check
"RTN","EASMTCHK",152,0)
 ;
"RTN","EASMTCHK",153,0)
 N VAERR,EAIN,VAROOT,VAINDT
"RTN","EASMTCHK",154,0)
 ;
"RTN","EASMTCHK",155,0)
 S VAINDT=$$NOW^XLFDT,VAROOT="EAIN"
"RTN","EASMTCHK",156,0)
 ;; Modified to treat DOM patients as inpatients for the purpose of appointment blocking.
"RTN","EASMTCHK",157,0)
 ;; EAS*1*12
"RTN","EASMTCHK",158,0)
 D INP^VADPT
"RTN","EASMTCHK",159,0)
 Q $S(+$G(EAIN(1)):1,1:0)
"VER")
8.0^22.0
**INSTALL NAME**
IVM*2.0*154
"BLD",8438,0)
IVM*2.0*154^INCOME VERIFICATION MATCH^0^3131219^y
"BLD",8438,1,0)
^^3^3^3120819^
"BLD",8438,1,1,0)
This patch contains VistA changes to support technology and
"BLD",8438,1,2,0)
business changes that are occurring with the implementation of
"BLD",8438,1,3,0)
Discontinue Annual Means Test Renewal.
"BLD",8438,4,0)
^9.64PA^^
"BLD",8438,6.3)
28
"BLD",8438,"ABPKG")
n
"BLD",8438,"KRN",0)
^9.67PA^779.2^20
"BLD",8438,"KRN",.4,0)
.4
"BLD",8438,"KRN",.401,0)
.401
"BLD",8438,"KRN",.402,0)
.402
"BLD",8438,"KRN",.403,0)
.403
"BLD",8438,"KRN",.5,0)
.5
"BLD",8438,"KRN",.84,0)
.84
"BLD",8438,"KRN",3.6,0)
3.6
"BLD",8438,"KRN",3.8,0)
3.8
"BLD",8438,"KRN",9.2,0)
9.2
"BLD",8438,"KRN",9.8,0)
9.8
"BLD",8438,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",8438,"KRN",9.8,"NM",1,0)
IVMCQ^^0^B25370590
"BLD",8438,"KRN",9.8,"NM","B","IVMCQ",1)

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

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

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

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

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

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

"BLD",8438,"KRN","B",3.6,3.6)

"BLD",8438,"KRN","B",3.8,3.8)

"BLD",8438,"KRN","B",9.2,9.2)

"BLD",8438,"KRN","B",9.8,9.8)

"BLD",8438,"KRN","B",19,19)

"BLD",8438,"KRN","B",19.1,19.1)

"BLD",8438,"KRN","B",101,101)

"BLD",8438,"KRN","B",409.61,409.61)

"BLD",8438,"KRN","B",771,771)

"BLD",8438,"KRN","B",779.2,779.2)

"BLD",8438,"KRN","B",870,870)

"BLD",8438,"KRN","B",8989.51,8989.51)

"BLD",8438,"KRN","B",8989.52,8989.52)

"BLD",8438,"KRN","B",8994,8994)

"BLD",8438,"QUES",0)
^9.62^^
"BLD",8438,"REQB",0)
^9.611^1^1
"BLD",8438,"REQB",1,0)
IVM*2.0*120^2
"BLD",8438,"REQB","B","IVM*2.0*120",1)

"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)
154^3131219^100992
"PKG",120,22,1,"PAH",1,1,0)
^^3^3^3131219
"PKG",120,22,1,"PAH",1,1,1,0)
This patch contains VistA changes to support technology and
"PKG",120,22,1,"PAH",1,1,2,0)
business changes that are occurring with the implementation of
"PKG",120,22,1,"PAH",1,1,3,0)
Discontinue Annual Means Test Renewal.
"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","IVMCQ")
0^1^B25370590
"RTN","IVMCQ",1,0)
IVMCQ ;ALB/KCL/AEG/GAH,BDB - API FOR FINANCIAL QUERIES ; 28-N0V-06
"RTN","IVMCQ",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**17,30,55,120,154**;21-OCT-94;Build 28
"RTN","IVMCQ",3,0)
 ;
"RTN","IVMCQ",4,0)
 ;
"RTN","IVMCQ",5,0)
OPT ; Entry point for stand-alone financial query option.
"RTN","IVMCQ",6,0)
 ;
"RTN","IVMCQ",7,0)
 N IVMQUIT
"RTN","IVMCQ",8,0)
 W !!,"This option allows queries to be sent to the Health Eligibility"
"RTN","IVMCQ",9,0)
 W !,"Center (HEC) for patients that require updated income information."
"RTN","IVMCQ",10,0)
 S IVMQUIT=0 F  D EACH1 Q:IVMQUIT
"RTN","IVMCQ",11,0)
 Q
"RTN","IVMCQ",12,0)
 ;
"RTN","IVMCQ",13,0)
EACH1 ; Description: Used to send a financial query for each patient selected. from stand-alone option.
"RTN","IVMCQ",14,0)
 ;
"RTN","IVMCQ",15,0)
 N DFN,IVMERROR,IVMOK,IVMOUT,IVMQUE,IVMREPLY,Y
"RTN","IVMCQ",16,0)
 S DIC="^DPT(",DIC(0)="AEMQ"
"RTN","IVMCQ",17,0)
 W ! D ^DIC K DIC S DFN=+Y I Y<1 S IVMQUIT=1 G EACH1Q
"RTN","IVMCQ",18,0)
 ;
"RTN","IVMCQ",19,0)
 ; does patient need a financial query?
"RTN","IVMCQ",20,0)
 I '$$NEED(DFN,1,.IVMERROR) W !!,"A financial query can not be sent for this patient!" W !,IVMERROR G EACH1Q
"RTN","IVMCQ",21,0)
 ;
"RTN","IVMCQ",22,0)
 ; ask if okay to send query?
"RTN","IVMCQ",23,0)
 I '$$ASK(.IVMOK)!($G(IVMOK)) G EACH1Q
"RTN","IVMCQ",24,0)
 ;
"RTN","IVMCQ",25,0)
 ; notify when a reply to query is received?
"RTN","IVMCQ",26,0)
 S IVMREPLY=$$NOTIFY(.IVMOUT)
"RTN","IVMCQ",27,0)
 I $G(IVMOUT) G EACH1Q
"RTN","IVMCQ",28,0)
 ;
"RTN","IVMCQ",29,0)
 ; send query for patient, else write error
"RTN","IVMCQ",30,0)
 I $$QUERY^IVMCQ1(DFN,$G(DUZ),$G(IVMREPLY),$G(XQY),.IVMERROR,1) W !!,"Financial query sent ..."
"RTN","IVMCQ",31,0)
 E  D
"RTN","IVMCQ",32,0)
 .W !!,"Failure to send query: ",IVMERROR
"RTN","IVMCQ",33,0)
 ;
"RTN","IVMCQ",34,0)
EACH1Q Q
"RTN","IVMCQ",35,0)
 ;
"RTN","IVMCQ",36,0)
 ;
"RTN","IVMCQ",37,0)
REG(DFN) ; Entry point to automatically send a query to HEC for updated financial information.
"RTN","IVMCQ",38,0)
 ;
"RTN","IVMCQ",39,0)
 ;   This entry point is called from hooks in registration: 
"RTN","IVMCQ",40,0)
 ;      - Register a Patient option (DGREG)
"RTN","IVMCQ",41,0)
 ;      - Load/Edit Patient Data option (DG10)
"RTN","IVMCQ",42,0)
 ;
"RTN","IVMCQ",43,0)
 ;  Input:
"RTN","IVMCQ",44,0)
 ;   DFN - IEN of patient record in PATIENT file
"RTN","IVMCQ",45,0)
 ;
"RTN","IVMCQ",46,0)
 ; Output: none
"RTN","IVMCQ",47,0)
 ;
"RTN","IVMCQ",48,0)
 I '$G(DFN) G REGQ
"RTN","IVMCQ",49,0)
 I '$$NEED(DFN) G REGQ
"RTN","IVMCQ",50,0)
 I $$QUERY^IVMCQ1(DFN,$G(DUZ),0,$G(XQY),,1) W !!,"Financial query sent ..."
"RTN","IVMCQ",51,0)
REGQ Q
"RTN","IVMCQ",52,0)
 ;
"RTN","IVMCQ",53,0)
 ;
"RTN","IVMCQ",54,0)
APPT ; Entry point for IVM SEND FINANCIAL QUERY protocol.
"RTN","IVMCQ",55,0)
 ;
"RTN","IVMCQ",56,0)
 ;  Input:
"RTN","IVMCQ",57,0)
 ;   SDAMEVT - IEN of record in APPOINTMENT TRANSACTION TYPE file.
"RTN","IVMCQ",58,0)
 ;             (Transaction type that can occur against an appointment)
"RTN","IVMCQ",59,0)
 ;     SDATA - Array passed from the [SDAM APPOINTMENT EVENTS]
"RTN","IVMCQ",60,0)
 ;             extended protocol.  2nd piece of SDATA is IEN of patient
"RTN","IVMCQ",61,0)
 ;             record in PATIENT file.
"RTN","IVMCQ",62,0)
 ;
"RTN","IVMCQ",63,0)
 ; Output: none
"RTN","IVMCQ",64,0)
 ;
"RTN","IVMCQ",65,0)
 N DFN
"RTN","IVMCQ",66,0)
 ;
"RTN","IVMCQ",67,0)
 ; quit if supported Sched vars not defined
"RTN","IVMCQ",68,0)
 I '$D(SDAMEVT) G APPTQ
"RTN","IVMCQ",69,0)
 S DFN=$P($G(SDATA),"^",2)
"RTN","IVMCQ",70,0)
 I 'DFN G APPTQ
"RTN","IVMCQ",71,0)
 ;
"RTN","IVMCQ",72,0)
 ; quit if transaction type not (make appt, check-in, check-out)
"RTN","IVMCQ",73,0)
 I SDAMEVT'=1,(SDAMEVT'=4),(SDAMEVT'=5) G APPTQ
"RTN","IVMCQ",74,0)
 ;
"RTN","IVMCQ",75,0)
 ; does patient need query sent?
"RTN","IVMCQ",76,0)
 I '$$NEED(DFN,1) G APPTQ
"RTN","IVMCQ",77,0)
 ;
"RTN","IVMCQ",78,0)
 ; send query for patient
"RTN","IVMCQ",79,0)
 I $$QUERY^IVMCQ1(DFN,$G(DUZ),0,$G(XQY),,1)
"RTN","IVMCQ",80,0)
 ;
"RTN","IVMCQ",81,0)
APPTQ Q
"RTN","IVMCQ",82,0)
 ;
"RTN","IVMCQ",83,0)
 ;
"RTN","IVMCQ",84,0)
ASK(IVMTOUT) ; Ask user if ok to send financial query for patient.
"RTN","IVMCQ",85,0)
 ;
"RTN","IVMCQ",86,0)
 ;  Input: none
"RTN","IVMCQ",87,0)
 ;
"RTN","IVMCQ",88,0)
 ; Output: 
"RTN","IVMCQ",89,0)
 ;  Function Value: 1=Yes and 0=No
"RTN","IVMCQ",90,0)
 ;                  IVMTOUT (pass by reference)  1=Timeout or up-arrow
"RTN","IVMCQ",91,0)
 ;
"RTN","IVMCQ",92,0)
 N DIR,DIRUT,DTOUT,DUOUT,X,Y
"RTN","IVMCQ",93,0)
 W !
"RTN","IVMCQ",94,0)
 S DIR("A")="Would you like to send a financial query for this patient"
"RTN","IVMCQ",95,0)
 S DIR("B")="YES"
"RTN","IVMCQ",96,0)
 S DIR(0)="Y"
"RTN","IVMCQ",97,0)
 W ! D ^DIR
"RTN","IVMCQ",98,0)
 I $D(DTOUT)!($D(DUOUT)) S IVMTOUT=1
"RTN","IVMCQ",99,0)
 Q +$G(Y)
"RTN","IVMCQ",100,0)
 ;
"RTN","IVMCQ",101,0)
 ;
"RTN","IVMCQ",102,0)
NOTIFY(IVMOUT) ; Ask if user should be notified when a reply to query is received.
"RTN","IVMCQ",103,0)
 ;
"RTN","IVMCQ",104,0)
 ;  Input: none
"RTN","IVMCQ",105,0)
 ;
"RTN","IVMCQ",106,0)
 ; Output: 
"RTN","IVMCQ",107,0)
 ;  Function Value: 1=Yes and 0=No
"RTN","IVMCQ",108,0)
 ;                  IVMOUT (pass by reference)  1=Timeout or up-arrow
"RTN","IVMCQ",109,0)
 ;
"RTN","IVMCQ",110,0)
 N DIR,DTOUT,DUOUT,X,Y
"RTN","IVMCQ",111,0)
 S DIR("A")="Do you want to be notified when a query reply is received"
"RTN","IVMCQ",112,0)
 S DIR("B")="YES"
"RTN","IVMCQ",113,0)
 S DIR(0)="Y"
"RTN","IVMCQ",114,0)
 W ! D ^DIR
"RTN","IVMCQ",115,0)
 I $D(DTOUT)!($D(DUOUT)) S IVMOUT=1
"RTN","IVMCQ",116,0)
 Q +$G(Y)
"RTN","IVMCQ",117,0)
 ;
"RTN","IVMCQ",118,0)
 ;
"RTN","IVMCQ",119,0)
NEED(DFN,IVMSENT,ERROR) ; Description: Used to determine if a financial query should be sent for a patient.
"RTN","IVMCQ",120,0)
 ;
"RTN","IVMCQ",121,0)
 ;  Input:
"RTN","IVMCQ",122,0)
 ;       DFN - ien of patient record in PATIENT file
"RTN","IVMCQ",123,0)
 ;   IVMSENT - (optional) Check if query sent on same day 0=>No|1=>Yes
"RTN","IVMCQ",124,0)
 ; Output:
"RTN","IVMCQ",125,0)
 ;  Function Value: Does pt. need a query? 1 on success, 0 on failure
"RTN","IVMCQ",126,0)
 ;     ERROR - If failure, return the reason for not sending
"RTN","IVMCQ",127,0)
 ;             the query (pass by reference)
"RTN","IVMCQ",128,0)
 ;
"RTN","IVMCQ",129,0)
 N DGMSGF,DGADDF,DGREQF,IVMBT,IVML,SUCCESS
"RTN","IVMCQ",130,0)
 N IVMDOD
"RTN","IVMCQ",131,0)
 ;
"RTN","IVMCQ",132,0)
 S SUCCESS=0,(DGMSGF,DGADDF)=1
"RTN","IVMCQ",133,0)
 I '$D(IVMSENT) S IVMSENT=1
"RTN","IVMCQ",134,0)
 ; Can this patient be identified?
"RTN","IVMCQ",135,0)
 I '$G(DFN) S ERROR="PATIENT CAN NOT BE IDENTIFIED" G NEEDQ
"RTN","IVMCQ",136,0)
 ; is this patient deceased?
"RTN","IVMCQ",137,0)
 S IVMDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
"RTN","IVMCQ",138,0)
 I IVMDOD]"" S ERROR="Patient Expired on "_$$GET1^DIQ(2,DFN_",",.351,"E")_".  Financial query unnecessary."  G NEEDQ
"RTN","IVMCQ",139,0)
 ; Check to see if this patient is currently on a DOM ward.
"RTN","IVMCQ",140,0)
 D DOM^DGMTR I $G(DGDOM) D  G NEEDQ
"RTN","IVMCQ",141,0)
 .S ERROR="PATIENT CURRENTLY A DOMICILIARY PATIENT - "
"RTN","IVMCQ",142,0)
 .S ERROR=ERROR_"QUERY NOT REQUIRED"
"RTN","IVMCQ",143,0)
 .K DGDOM
"RTN","IVMCQ",144,0)
 .Q
"RTN","IVMCQ",145,0)
 ; Check for PRIMARY test either MEANS or Copay exemption.
"RTN","IVMCQ",146,0)
 S IVML=$$LST^DGMTCOU1(DFN,DT_.2359,3)
"RTN","IVMCQ",147,0)
 ; If no primary test on file check to see if patient requires a means
"RTN","IVMCQ",148,0)
 ; test or copay exemption test.  Call to DGMTR invokes EN^DGMTCOR as
"RTN","IVMCQ",149,0)
 ; well.
"RTN","IVMCQ",150,0)
 I IVML']"" D EN^DGMTR I +$G(DGREQF) S SUCCESS=1 G NEEDQ
"RTN","IVMCQ",151,0)
 ;
"RTN","IVMCQ",152,0)
 ; If current test is not incomplete and not required and is less than
"RTN","IVMCQ",153,0)
 ; 365 days old, presume a current test exists, no query necessary.
"RTN","IVMCQ",154,0)
 ; IVM*2.0*154  MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","IVMCQ",155,0)
 I ($P(IVML,U,4)'="I")&($P(IVML,U,4)'="R"),'$$OLDMTPF^DGMTU4($P(IVML,U,2)) D  G NEEDQ
"RTN","IVMCQ",156,0)
 .S ERROR="PATIENT HAS A CURRENT "_$S($P(IVML,U,5)=1:"MEANS",$P(IVML,U,5)=2:"COPAY EXEMPTION",1:"MEANS")_" TEST ON FILE"
"RTN","IVMCQ",157,0)
 .Q
"RTN","IVMCQ",158,0)
 ;
"RTN","IVMCQ",159,0)
 ; If the current test is NO LONGER REQUIRED or NO LONGER APPLICABLE no
"RTN","IVMCQ",160,0)
 ; query is necessary.
"RTN","IVMCQ",161,0)
 I ($P(IVML,U,4)="N")!($P(IVML,U,4)="L") D  G NEEDQ
"RTN","IVMCQ",162,0)
 .S ERROR="PATIENT'S "_$S($P(IVML,U,5)=1:"MEANS",$P(IVML,U,5)=2:"COPAY EXEMPTION",1:"MEANS")_" TEST STATUS "_$P(IVML,U,3)_"."
"RTN","IVMCQ",163,0)
 .Q
"RTN","IVMCQ",164,0)
 ;
"RTN","IVMCQ",165,0)
 ; If current test is not REQUIRED and not NO LONGER REQUIRED and it is 
"RTN","IVMCQ",166,0)
 ; older than 365 days, initiate query.
"RTN","IVMCQ",167,0)
 ; IVM*2.0*154  MT less than 1 year old as of "VFA Start Date" and point forward do not expire
"RTN","IVMCQ",168,0)
 I ($P(IVML,U,4)'="R")&($P(IVML,U,4)'="N"),$$OLDMTPF^DGMTU4($P(IVML,U,2)) S SUCCESS=1 G NEEDQ
"RTN","IVMCQ",169,0)
 ;
"RTN","IVMCQ",170,0)
 ; If a query is pending, don't send another.
"RTN","IVMCQ",171,0)
 I $$OPEN^IVMCQ2(DFN) S ERROR="A QUERY IS ALREADY PENDING FOR THIS PATIENT" G NEEDQ
"RTN","IVMCQ",172,0)
 ;
"RTN","IVMCQ",173,0)
 ; if a query has already been sent today, don't send another.
"RTN","IVMCQ",174,0)
 I IVMSENT,$$SENT^IVMCQ2(DFN) S ERROR="A QUERY HAS BEEN SENT FOR PATIENT TODAY" G NEEDQ
"RTN","IVMCQ",175,0)
 ;
"RTN","IVMCQ",176,0)
 ; Has a bene travel cert been filed with a year?
"RTN","IVMCQ",177,0)
 S IVMBT=$O(^DGBT(392.2,"C",DFN,0))
"RTN","IVMCQ",178,0)
 I IVMBT,$$FMDIFF^XLFDT(DT,+$G(^DGBT(392.2,IVMBT,0))\1)>330 S SUCCESS=1 G NEEDQ
"RTN","IVMCQ",179,0)
 ;
"RTN","IVMCQ",180,0)
 S ERROR="A FINANCIAL QUERY IS NOT REQUIRED FOR THIS PATIENT"
"RTN","IVMCQ",181,0)
 ;
"RTN","IVMCQ",182,0)
NEEDQ Q SUCCESS
"VER")
8.0^22.0
**INSTALL NAME**
DGBT*1.0*24
"BLD",8545,0)
DGBT*1.0*24^BENEFICIARY TRAVEL^0^3131219^y
"BLD",8545,1,0)
^^2^2^3130315^
"BLD",8545,1,1,0)
Modifications to the Beneficiary Travel Claims screen<1> for Veterans
"BLD",8545,1,2,0)
Financial Assesment discontinuation of Means Test Expirations.
"BLD",8545,4,0)
^9.64PA^^
"BLD",8545,6.3)
13
"BLD",8545,"ABPKG")
n
"BLD",8545,"KRN",0)
^9.67PA^779.2^20
"BLD",8545,"KRN",.4,0)
.4
"BLD",8545,"KRN",.401,0)
.401
"BLD",8545,"KRN",.402,0)
.402
"BLD",8545,"KRN",.403,0)
.403
"BLD",8545,"KRN",.5,0)
.5
"BLD",8545,"KRN",.84,0)
.84
"BLD",8545,"KRN",3.6,0)
3.6
"BLD",8545,"KRN",3.8,0)
3.8
"BLD",8545,"KRN",9.2,0)
9.2
"BLD",8545,"KRN",9.8,0)
9.8
"BLD",8545,"KRN",9.8,"NM",0)
^9.68A^4^4
"BLD",8545,"KRN",9.8,"NM",1,0)
DGBT1^^0^B127576754
"BLD",8545,"KRN",9.8,"NM",2,0)
DGBTUTL1^^0^B55063675
"BLD",8545,"KRN",9.8,"NM",3,0)
DGBTALTI^^0^B51270693
"BLD",8545,"KRN",9.8,"NM",4,0)
DGBTUTL^^0^B104795609
"BLD",8545,"KRN",9.8,"NM","B","DGBT1",1)

"BLD",8545,"KRN",9.8,"NM","B","DGBTALTI",3)

"BLD",8545,"KRN",9.8,"NM","B","DGBTUTL",4)

"BLD",8545,"KRN",9.8,"NM","B","DGBTUTL1",2)

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

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

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

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

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

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

"BLD",8545,"KRN","B",3.6,3.6)

"BLD",8545,"KRN","B",3.8,3.8)

"BLD",8545,"KRN","B",9.2,9.2)

"BLD",8545,"KRN","B",9.8,9.8)

"BLD",8545,"KRN","B",19,19)

"BLD",8545,"KRN","B",19.1,19.1)

"BLD",8545,"KRN","B",101,101)

"BLD",8545,"KRN","B",409.61,409.61)

"BLD",8545,"KRN","B",771,771)

"BLD",8545,"KRN","B",779.2,779.2)

"BLD",8545,"KRN","B",870,870)

"BLD",8545,"KRN","B",8989.51,8989.51)

"BLD",8545,"KRN","B",8989.52,8989.52)

"BLD",8545,"KRN","B",8994,8994)

"BLD",8545,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",8545,"QUES",0)
^9.62^^
"BLD",8545,"REQB",0)
^9.611^1^1
"BLD",8545,"REQB",1,0)
DGBT*1.0*20^1
"BLD",8545,"REQB","B","DGBT*1.0*20",1)

"MBREQ")
0
"PKG",190,-1)
1^1
"PKG",190,0)
BENEFICIARY TRAVEL^DGBT^Beneficiary Travel
"PKG",190,22,0)
^9.49I^1^1
"PKG",190,22,1,0)
1.0^3020319^3030325^66481
"PKG",190,22,1,"PAH",1,0)
24^3131219^100992
"PKG",190,22,1,"PAH",1,1,0)
^^2^2^3131219
"PKG",190,22,1,"PAH",1,1,1,0)
Modifications to the Beneficiary Travel Claims screen<1> for Veterans
"PKG",190,22,1,"PAH",1,1,2,0)
Financial Assesment discontinuation of Means Test Expirations.
"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")
4
"RTN","DGBT1")
0^1^B127576754
"RTN","DGBT1",1,0)
DGBT1 ;ALB/SCK/BLD - BENEFICIARY TRAVEL DISPLAY SCREEN 1;10/31/05
"RTN","DGBT1",2,0)
 ;;1.0;Beneficiary Travel;**11,20,24**;September 25, 2001;Build 13
"RTN","DGBT1",3,0)
 Q
"RTN","DGBT1",4,0)
SCREEN ;  clear screen and write headers
"RTN","DGBT1",5,0)
 N TOTRIPS,ONEWAY,RT,MONTHDED,WAIVER,WTYPE,TTRIPS,TDED,TFIEN,DGBTOTHER
"RTN","DGBT1",6,0)
 D MONTOT(.TOTRIPS,.ONEWAY,.RT,.MONTHDED,.WAIVER,.WTYPE,.TTRIPS,.TDED) Q:$G(DGBTQUIT)
"RTN","DGBT1",7,0)
 S DGBTOTHER=0
"RTN","DGBT1",8,0)
 W @IOF
"RTN","DGBT1",9,0)
 W !?18,"Beneficiary Travel Claim Information <Screen 1>"
"RTN","DGBT1",10,0)
 W !!?2,"Claim Date: ",DGBTDTE
"RTN","DGBT1",11,0)
 D PID^VADPT6 W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2)
"RTN","DGBT1",12,0)
 I '$G(CHZFLG)!('$D(^DGBT(392,DGBTDT,"D"))) W !!?5,"Address: ",VAPA(1) W:VAPA(2)]"" !?14,VAPA(2) W:VAPA(3)]"" !?14,VAPA(3) W !?14,VAPA(4),$S(VAPA(4)]"":", "_$P(VAPA(5),"^",2)_"  "_$P(VAPA(11),U,2),1:"UNSPECIFIED")
"RTN","DGBT1",13,0)
 I $G(CHZFLG),$D(^DGBT(392,DGBTDT,"D")) D
"RTN","DGBT1",14,0)
 .N CLMADD,CLMST
"RTN","DGBT1",15,0)
 .S CLMADD=^DGBT(392,DGBTDT,"D")
"RTN","DGBT1",16,0)
 .S CLMST=$P(CLMADD,"^",5) S:$G(CLMST)'="" CLMST=$P(^DIC(5,CLMST,0),"^",2)
"RTN","DGBT1",17,0)
 .W !!?5,"Address: ",$P(CLMADD,"^",1) W:$P(CLMADD,"^",2)]"" !?14,$P(CLMADD,"^",2) W:$P(CLMADD,"^",3)]"" !?14,$P(CLMADD,"^",3) W !?14,$P(CLMADD,"^",4),$S($P(CLMADD,"^",4)]"":", "_CLMST_"  "_$P(CLMADD,"^",6),1:"UNSPECIFIED")
"RTN","DGBT1",18,0)
 W !!?5,$$ADDCHG(DFN)
"RTN","DGBT1",19,0)
 ;
"RTN","DGBT1",20,0)
SETVAR  ;  if new claim, move in current info for elig, sc%
"RTN","DGBT1",21,0)
 I 'CHZFLG S DGBTELG=VAEL(1),DGBTCSC=VAEL(3)
"RTN","DGBT1",22,0)
 I +DGBTELG=3,'$E(DGBTCSC)=1 S DGBTCSC=1
"RTN","DGBT1",23,0)
 I ($P(DGBTELG,U,2)["NSC")&(DGBTDYFL)&'($G(DGBTREF)) D
"RTN","DGBT1",24,0)
 .I +$TR($P(DGBTINC,U),"$,","")<DGBTRXTH S $P(DGBTELG,U,2)=$P(DGBTELG,U,2)_" LOW INCOME"
"RTN","DGBT1",25,0)
 W !!," Eligibility: ",$P(DGBTELG,"^",2) W:DGBTCSC ?45,"SC%: ",$P(DGBTCSC,"^",2) ;W !
"RTN","DGBT1",26,0)
 I $O(VAEL(1,0))'="" W !," Other Elig.: " F I=0:0 S I=$O(VAEL(1,I)) Q:'I  D
"RTN","DGBT1",27,0)
 .W ?14,$P(VAEL(1,I),"^",2),!
"RTN","DGBT1",28,0)
 .I VAEL(1,I)["HOUSEBOUND" S DGBTOTHER=1
"RTN","DGBT1",29,0)
 .I VAEL(1,I)["AID & ATTENDANCE" S DGBTOTHER=1
"RTN","DGBT1",30,0)
 .I VAEL(1,I)["PENSION" S DGBTOTHER=1
"RTN","DGBT1",31,0)
 ;
"RTN","DGBT1",32,0)
SC ;  service connected status/information
"RTN","DGBT1",33,0)
 I DGBTCSC&($P(DGBTCSC,"^",2)'>29) W !!,"Disabilities:" S I3=""
"RTN","DGBT1",34,0)
 N DGQUIT
"RTN","DGBT1",35,0)
 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I!($G(DGQUIT)=1)  D
"RTN","DGBT1",36,0)
 . S I1=^(I,0),I2=$S($D(^DIC(31,+I1,0)):$P(^(0),"^",1)_" ("_+$P(I1,"^",2)_"%-"_$S($P(I1,"^",3):"SC",1:"NSC")_")",1:""),I3=I1
"RTN","DGBT1",37,0)
 . I $Y>(IOSL-3) D PAUSE I DGQUIT=0 W @IOF
"RTN","DGBT1",38,0)
 . I $G(DGQUIT)=1 Q
"RTN","DGBT1",39,0)
 .D
"RTN","DGBT1",40,0)
 ..I DGBTCSC&($P(DGBTCSC,"^",2)'>29) Q
"RTN","DGBT1",41,0)
 ..I I=$O(^DPT(DFN,.372,0)) W !
"RTN","DGBT1",42,0)
 . W ?16 W I2,!
"RTN","DGBT1",43,0)
 ;
"RTN","DGBT1",44,0)
INCOME ;  income and eligibility information
"RTN","DGBT1",45,0)
 ;DAYFLG = NUMBER OF DAYS SINCE LAST MEANS TEST
"RTN","DGBT1",46,0)
 N DGBTIFL,DGBTDATA,TESTDATE,DGBTDAYS,DGNOTEST,RXCP,RXCPST,DGRXDATA,RXDAYS,RXCPDATA,RXCPTS,DGBTST,BUSEXP,LOWINC,NOTEST
"RTN","DGBT1",47,0)
 ;
"RTN","DGBT1",48,0)
 ;
"RTN","DGBT1",49,0)
 S DGBTIFL=$P(DGBTINC,U,2)
"RTN","DGBT1",50,0)
 S (DAYFLG,RXDAYS,RXCPTS)=""
"RTN","DGBT1",51,0)
 ;CHECK HOW DAYS SINCE LAST MEANS TEST
"RTN","DGBT1",52,0)
 I $$DAYSTEST(DFN,.DAYFLG,.RXDAYS,.RXCPST,.LOWINC,.DGNOTEST)
"RTN","DGBT1",53,0)
 ;
"RTN","DGBT1",54,0)
 ; added for patch *24 to check for VFA MT currency and reset DAYFLG as needed
"RTN","DGBT1",55,0)
 I $$MTCHK^DGBTUTL1(DFN,$P(DGBTDT,".",1))>0 D
"RTN","DGBT1",56,0)
 . S (DAYFLG,DGBTDYFL)=1
"RTN","DGBT1",57,0)
 ;
"RTN","DGBT1",58,0)
 S BUSEXP=$$ABP^DGBTUTL(DFN)
"RTN","DGBT1",59,0)
 ;
"RTN","DGBT1",60,0)
 ;CHANGED FOR DGBT*1*20
"RTN","DGBT1",61,0)
 S ELIGTYP=$$GET1^DIQ(8.1,3_",",.01)
"RTN","DGBT1",62,0)
 I '$G(DGBTOTHER),'$G(LOWINC),($G(VAEL(3))),$P($G(VAEL(3)),"^",2)<30,($P(VAEL(1),"^",2))=ELIGTYP W !?2,"BT Alert: ELIGIBLE FOR SC APPOINTMENTS ONLY"
"RTN","DGBT1",63,0)
 I $G(BUSEXP) D
"RTN","DGBT1",64,0)
 .S Y=BUSEXP X ^DD("DD")
"RTN","DGBT1",65,0)
 .W !!?2,"BT Alert: BUS PASS ISSUED - EXPIRES ",Y
"RTN","DGBT1",66,0)
 ; 
"RTN","DGBT1",67,0)
 I (DAYFLG!DGBTINCA),'$G(RXCPST) D  D QUIT Q    ;valid mt in last 365 days + PAVEL
"RTN","DGBT1",68,0)
 .W !!?2,"Income: ",$P(DGBTINC,U),DGBTDTY,?35,"Source of Income:  ",$S(DGBTIFL="M":"MEANS TEST",DGBTIFL="C":"COPAY TEST",DGBTIFL="P":"Alt.Income POW",DGBTIFL="H":"Alt. Income Hardship",1:"")
"RTN","DGBT1",69,0)
 .W !?2,"No. of Dependents: ",DGBTDEP
"RTN","DGBT1",70,0)
 .;
"RTN","DGBT1",71,0)
 .I DGBTMTS]"" W:$P(DGBTMTS,"^")'="N" ?40,"MT Status: ",$S($P(DGBTMTS,"^")="R":"REQUIRED",$P(DGBTMTS,"^")="P":$P($P(DGBTMTS,"^",2)," "),DGBTMTS=U!($G(RXCPST)):" NOT APPLICABLE",1:$P(DGBTMTS,"^",2))
"RTN","DGBT1",72,0)
 .W:$P(DGBTMTS,"^")="P" !?68,$P($P(DGBTMTS,"^",2)," ",2)
"RTN","DGBT1",73,0)
 .I $P(DGBTMTS,"^")="N" W !!?20,"MEANS TEST ",$P(DGBTMTS,"^",2)
"RTN","DGBT1",74,0)
 .;
"RTN","DGBT1",75,0)
 .W !!?2,"BT Income: ",$S($D(DGBTCA):DGBTCA,1:"NOT RECORDED") W:$D(DGBTCE) ?25,"Certified Eligible: ",$S(DGBTCE:"YES",1:"NO"),?53,"Date Certified: ",$S($D(DGBTCD):DGBTCD,1:"NOT RECORDED")
"RTN","DGBT1",76,0)
 .I $D(DGBTCE) I DGBTCE'=1 W *7,*7,!!?8,"* * * NOTE * * PATIENT HAS BEEN CERTIFIED INELIGIBLE BASED ON INCOME"
"RTN","DGBT1",77,0)
 .S DGBTINFL="" I $D(DGBTINC),$D(DGBTCA),$P(DGBTINC,U)'=DGBTCA,$P(DGBTMTS,"^")'="N" S DGBTINFL=" * * * * Discrepancy exists in incomes reported, please verify * * * *" W !!?5,DGBTINFL
"RTN","DGBT1",78,0)
 .I '$D(DGBTRET(0)) W !,?50,$$WVEXP     ;*DGBT*1.0*20 BLD * E2
"RTN","DGBT1",79,0)
 .I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)'="MAN" W !,?50,$$WVEXP ; /*DGBT*1.0*20 RFE */
"RTN","DGBT1",80,0)
 .I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)="MAN" W !,?52,"WAIVER EXPIRES: ",$P(DGBTRET(0),"^",7)
"RTN","DGBT1",81,0)
 .F I=$Y:1:20 W !
"RTN","DGBT1",82,0)
 ;
"RTN","DGBT1",83,0)
 ;no valid mt test in last 365 days or no test has been done
"RTN","DGBT1",84,0)
 I 'DAYFLG D  D QUIT Q
"RTN","DGBT1",85,0)
  .W !!?2,"Income: ","",?40,"Source of Income:  ",""
"RTN","DGBT1",86,0)
 .W !?2,"No. of Dependents: ",DGBTDEP
"RTN","DGBT1",87,0)
 .I DGBTMTS]"" W ?40,"MT Status: ","EXPIRED"
"RTN","DGBT1",88,0)
 .W !!?2,"BT Income: ",$S($D(DGBTCA):DGBTCA,1:"NOT RECORDED") W:$D(DGBTCE) ?25,"Certified Eligible: ",$S(DGBTCE:"YES",1:"NO"),?53,"Date Certified: ",$S($D(DGBTCD):DGBTCD,1:"NOT RECORDED")
"RTN","DGBT1",89,0)
 .I '$D(DGBTRET(0)) W !,?50,$$WVEXP     ;*DGBT*1.0*20 BLD * E2
"RTN","DGBT1",90,0)
 .I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)'="MAN" W !,?50,$$WVEXP ; /*DGBT*1.0*20 RFE */
"RTN","DGBT1",91,0)
 .I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)="MAN" W !,?52,"WAIVER EXPIRES: ",$P(DGBTRET(0),"^",7)
"RTN","DGBT1",92,0)
 .F I=$Y:1:20 W !
"RTN","DGBT1",93,0)
 ;
"RTN","DGBT1",94,0)
 I DAYFLG,$G(RXCPST) D
"RTN","DGBT1",95,0)
 .I $G(RXCP)'=1,$P($G(DGBTINCA),"^",2)'="" W !!?2,"Income: ",$S($P($G(DGBTINCA),"^",2)'="":$P(DGBTINCA,"^",2),1:""),DGBTDTY,?40,"Source of Income:  ","Alternate Income/"_$S($P(DGBTINCA,"^",4)="H":"Hardship",1:"POW")
"RTN","DGBT1",96,0)
 .I $G(RXCP)'=1,$P($G(DGBTINCA),"^",2)="" W !!?2,"Income: ",DGBTDTY,?40,"Source of Income:  ","COPAY TEST"               ;RXCP'=1 Copy NON-EXEMPT
"RTN","DGBT1",97,0)
 .I $G(RXCP)=1,$P($G(DGBTINCA),"^",2)'="" W !!?2,"Income: ",$S($P($G(DGBTINCA),"^",2)'="":$P(DGBTINCA,"^",2),1:""),DGBTDTY,?40,"Source of Income:  ","Alternate Income/"_$S($P(DGBTINCA,"^",4)="H":"Hardship",1:"POW")
"RTN","DGBT1",98,0)
 .I $G(RXCP)=1,$P($G(DGBTINCA),"^",2)="" W !!?2,"Income: ",$P(DGBTINC,U),DGBTDTY,?40,"Source of Income:  ","COPAY TEST"  ;RXCP=1  Copay EXEMPT
"RTN","DGBT1",99,0)
 .W !?2,"No. of Dependents: ",DGBTDEP
"RTN","DGBT1",100,0)
 .I DGBTMTS]"" W ?40,"MT Status: ","NOT APPLICABLE"
"RTN","DGBT1",101,0)
 .W !!?2,"BT Income: ","INELIGIBLE"
"RTN","DGBT1",102,0)
 .I '$D(DGBTRET(0)) W ?50,$$WVEXP     ;*DGBT*1.0*20 BLD * E2
"RTN","DGBT1",103,0)
 .I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)'="MAN" W ?50,$$WVEXP ; /*DGBT*1.0*20 RFE */
"RTN","DGBT1",104,0)
 .I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)="MAN" W ?52,"WAIVER EXPIRES: ",$P(DGBTRET(0),"^",7)
"RTN","DGBT1",105,0)
 .F I=$Y:1:20 W !
"RTN","DGBT1",106,0)
 ;
"RTN","DGBT1",107,0)
QUIT ;
"RTN","DGBT1",108,0)
 K I1,I2,I3
"RTN","DGBT1",109,0)
 D MONTDISP(TOTRIPS,ONEWAY,RT,MONTHDED,WAIVER,WTYPE)
"RTN","DGBT1",110,0)
 Q
"RTN","DGBT1",111,0)
 ;
"RTN","DGBT1",112,0)
MONTOT(TOTRIPS,ONEWAY,RT,MONTHDED,WAIVER,WTYPE,TTRIPS,TDED) ;
"RTN","DGBT1",113,0)
 ;
"RTN","DGBT1",114,0)
 N RETURN
"RTN","DGBT1",115,0)
 S RETURN=""
"RTN","DGBT1",116,0)
 ;Return values: total number of trips ^ number of one way trips ^ number of round trips ^ deductible (all this for the month) ^ waiver y/n (y will be 1, n will be no) ^
"RTN","DGBT1",117,0)
 ;total number of trips as of this claim date ^ deductible as of this claim date
"RTN","DGBT1",118,0)
 ;from the local data base
"RTN","DGBT1",119,0)
 S RETURN=$$WAIV^DGBTRDVW(DFN,DGBTDTI)
"RTN","DGBT1",120,0)
 S ONEWAY=$S($P($G(RETURN),"^",2):$P($G(RETURN),"^",2),1:0)
"RTN","DGBT1",121,0)
 S RT=$S($P($G(RETURN),"^",3):$P($G(RETURN),"^",3),1:0)
"RTN","DGBT1",122,0)
 S WAIVER=$S($P($G(RETURN),"^",5)=1:"YES",1:"NO")
"RTN","DGBT1",123,0)
 S MONTHDED=$S($P($G(RETURN),"^",4):$P($G(RETURN),"^",4),1:0)
"RTN","DGBT1",124,0)
 S WTYPE=$P(RETURN,"^",5)
"RTN","DGBT1",125,0)
 S TOTRIPS=(RT*2)+ONEWAY
"RTN","DGBT1",126,0)
 S TTRIPS=$S($P($G(RETURN),U,8):$P($G(RETURN),U,8),1:0)
"RTN","DGBT1",127,0)
 S TDED=$S($P($G(RETURN),U,9):$P($G(RETURN),U,9),1:0)
"RTN","DGBT1",128,0)
 S DGBTREF=0
"RTN","DGBT1",129,0)
 S DGBTREF=$$LSTMTRIN(DFN,DGBTDTI)
"RTN","DGBT1",130,0)
 I (WAIVER="NO")&($G(DGBTDYFL)) D
"RTN","DGBT1",131,0)
 .I DGBTNSC D  Q
"RTN","DGBT1",132,0)
 ..N INCOME
"RTN","DGBT1",133,0)
 ..S INCOME=+$TR($P($G(DGBTINC),U),"$,","")
"RTN","DGBT1",134,0)
 ..I INCOME'="",INCOME<DGBTRXTH,'$G(DGBTREF) S WAIVER="YES",$P(RETURN,U,5)=1,$P(RETURN,U,6)="NSC"
"RTN","DGBT1",135,0)
 ..;I ($P($G(DGBTINC),"^",1)'="")&+$TR($P(DGBTINC,U),"$,","")<DGBTRXTH,'$G(DGBTREF) S WAIVER="YES",$P(RETURN,U,5)=1,$P(RETURN,U,6)="NSC"
"RTN","DGBT1",136,0)
 .I '$G(DGBTREF)&(+$G(VAEL(3)))&($P($G(DGBTINC),"^",1)'="")&(+$TR($P(DGBTINC,U),"$,","")<DGBTMTTH) S WAIVER="YES",$P(RETURN,U,5)=1,$P(RETURN,U,6)="LI" Q
"RTN","DGBT1",137,0)
 .I ($P($G(DGBTINC),"^",1)'="")&+$$LI^DGBTUTL(DFN,DGBTDTI,DGBTDEP,,DGBTINCA)'=0 S WAIVER="YES",$P(RETURN,U,5)=1,$P(RETURN,U,6)="LI"
"RTN","DGBT1",138,0)
 .I $P($G(DGBTINC),"^",1)="" S $P(RETURN,"^",6)=""
"RTN","DGBT1",139,0)
 I TOTRIPS<6,MONTHDED<18,$P(RETURN,"^",5)=0 D  Q:$G(DGBTQUIT)      ;if less than 6 trips and no waiver check for remote facility visits
"RTN","DGBT1",140,0)
 .S RETURN=""
"RTN","DGBT1",141,0)
 .D OPT^DGBTRDV(DFN,DGBTDTI) I $G(RDVMSG) W $$PAUSE^DGBTUTL(0) S:$G(Y)="^" DGBTQUIT=1 Q:$G(DGBTQUIT)!($G(DGBTRET(0))="")
"RTN","DGBT1",142,0)
 .I $G(RDVMSG) W $$PAUSE^DGBTUTL(0)
"RTN","DGBT1",143,0)
 .S ONEWAY=$G(ONEWAY)+$P(RETURN,"^",2)
"RTN","DGBT1",144,0)
 .S RT=$G(RT)+$P(RETURN,"^",3)
"RTN","DGBT1",145,0)
 .S MONTHDED=$G(MONTHDED)+$P(RETURN,"^",4)
"RTN","DGBT1",146,0)
 .S TOTRIPS=TOTRIPS+$P(RETURN,"^",1)
"RTN","DGBT1",147,0)
 .S TTRIPS=TTRIPS+$P(RETURN,U,8)
"RTN","DGBT1",148,0)
 .S TDED=TDED+$P(RETURN,U,9)
"RTN","DGBT1",149,0)
 .S $P(RETURN,"^",1)=TOTRIPS
"RTN","DGBT1",150,0)
 .S $P(RETURN,"^",8)=TTRIPS
"RTN","DGBT1",151,0)
 .S $P(RETURN,"^",9)=TDED
"RTN","DGBT1",152,0)
 .I $P(RETURN,"^",5)'=1 S $P(RETURN,"^",5)=$S(TTRIPS>6:1,TDED>18:0,1:$P(RETURN,"^",5))
"RTN","DGBT1",153,0)
 .S WAIVER=$S($P(RETURN,"^",5)=1:"YES",1:"NO")
"RTN","DGBT1",154,0)
 I WAIVER'="YES" S WAIVER=$S($P(RETURN,"^",1)>6:"YES",1:"NO")
"RTN","DGBT1",155,0)
 S MONTOT=$G(TOTRIPS)_"^"_$G(ONEWAY)_"^"_$G(RT)_"^"_$G(MONTHDED)_"^"_$G(WAIVER)_U_$G(TTRIPS)_U_$G(TDED)
"RTN","DGBT1",156,0)
 Q
"RTN","DGBT1",157,0)
 ;
"RTN","DGBT1",158,0)
MONTDISP(TOTRIPS,ONEWAY,RT,MONTHDED,WAIVER,WTYPE) ;
"RTN","DGBT1",159,0)
 ;
"RTN","DGBT1",160,0)
 W !?2,"TOTAL TRIPS THIS MONTH: ",$G(ONEWAY)_" ONE WAY, ",$G(RT)_" RD TRIP"
"RTN","DGBT1",161,0)
 W ?52,"WAIVER GRANTED: ",$G(WAIVER)
"RTN","DGBT1",162,0)
 W !?2,"TOTAL DEDUCTIBLE THIS MONTH: ",MONTHDED
"RTN","DGBT1",163,0)
 ;
"RTN","DGBT1",164,0)
 Q
"RTN","DGBT1",165,0)
 ;
"RTN","DGBT1",166,0)
PAUSE   ;added with DGBT*1*11
"RTN","DGBT1",167,0)
 I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
"RTN","DGBT1",168,0)
 Q
"RTN","DGBT1",169,0)
 ;
"RTN","DGBT1",170,0)
DAYSTEST(DFN,DAYFLG,RXDAYS,RXCPST,LOWINC,NOTEST) ;determines whether or not a valid MT in last 365 days.
"RTN","DGBT1",171,0)
 N DGBTDATA,TESTDATA,DGBTDAYS,DGMTSTAT,DGBTST,DGRXDATA,DGTSTTYP,DGMTST,X,DGMTYPT1,THRESHLD,INCOM
"RTN","DGBT1",172,0)
 S DGMTYPT1=3,DAYFLG=0,(DGMTST,RXCPST,THRESHLD,INCOM)=""
"RTN","DGBT1",173,0)
 S DGBTDATA=$$LST^DGMTCOU1(DFN,$P(DGBTDT,".",1),.DGMTYPT1)
"RTN","DGBT1",174,0)
 I DGBTDATA'="" D
"RTN","DGBT1",175,0)
 .S TESTDATE=$$LSTMTDT(DFN)
"RTN","DGBT1",176,0)
 .S DGBTDAYS=$$FMDIFF^XLFDT($P(DGBTDTI,".",1),TESTDATE)            ;get number of days from claim date to last MT
"RTN","DGBT1",177,0)
 .S DAYFLG=$S(DGBTDAYS>365:0,1:1)                   ;if greater than 365 days then no valid MT test
"RTN","DGBT1",178,0)
 .I DGMTYPT1=1 S DGMTST=$P(DGBTDATA,"^",3)="NO LONGER REQUIRED"
"RTN","DGBT1",179,0)
 .I DGMTYPT1=2 S RXCPST=$P(DGBTDATA,"^",3)="NON-EXEMPT"
"RTN","DGBT1",180,0)
 .S:RXCPST'=1 RXCP=1                             ;************************
"RTN","DGBT1",181,0)
 .S DGBTRET=$S(+$$LI^DGBTUTL(DFN,DGBTDTI,DGBTDEP,,DGBTINCA):"1^",1:"0^") ;Get Low Income + count Alternate Income   PAVEL
"RTN","DGBT1",182,0)
 .S LOWINC=$P(DGBTRET,"^",1)
"RTN","DGBT1",183,0)
 I $G(DAYFLG)=0 S DGNOTEST=1
"RTN","DGBT1",184,0)
 Q ""
"RTN","DGBT1",185,0)
 ;
"RTN","DGBT1",186,0)
ADDCHG(DFN) ;this will print the permanet Address last changed date or the Temporary Address last change date
"RTN","DGBT1",187,0)
 ;
"RTN","DGBT1",188,0)
 N DATE,TMPADD
"RTN","DGBT1",189,0)
 S TMPADD=$S($$GET1^DIQ(2,DFN,.12105)="YES":0,1:1)
"RTN","DGBT1",190,0)
 I TMPADD D
"RTN","DGBT1",191,0)
 .S DATE="Date Address Last Changed: "_$P($$GET1^DIQ(2,DFN,.118),"@",1)
"RTN","DGBT1",192,0)
 E  S DATE="Date Address Last Changed: "_$P($$GET1^DIQ(2,DFN,.12113),"@",1)
"RTN","DGBT1",193,0)
 ;
"RTN","DGBT1",194,0)
 Q DATE
"RTN","DGBT1",195,0)
 ; 
"RTN","DGBT1",196,0)
WVEXP() ; Waiver expiration date  ; /* Tagline added DGBT*1.0*20 RFE */
"RTN","DGBT1",197,0)
 N RETURN,VFADT,VFAMTDT,VFAMTDTP
"RTN","DGBT1",198,0)
 I $$WVELG Q "WAIVER EXPIRES: PENSION"
"RTN","DGBT1",199,0)
 N WVREQEXP
"RTN","DGBT1",200,0)
 I $D(^DGBT(392.7,"C",DFN)) S WVREQEXP=$$WVREQ("IN")
"RTN","DGBT1",201,0)
 I $G(WVREQEXP)="PENSION" Q "WAIVER EXPIRES: PENSION"
"RTN","DGBT1",202,0)
 N DGMTYPT1,TESTDATEI
"RTN","DGBT1",203,0)
 S TESTDATE=$$TESTDATE
"RTN","DGBT1",204,0)
 S TESTDATEI=$$DTFORMI(TESTDATE)
"RTN","DGBT1",205,0)
 I TESTDATEI<$P(DGBTDTI,".") Q ""
"RTN","DGBT1",206,0)
 I +$G(DGBTINCA) Q "WAIVER EXPIRES: "_TESTDATE
"RTN","DGBT1",207,0)
 I '+$G(LOWINC) Q $$WVREQ("EX")
"RTN","DGBT1",208,0)
 N LABL
"RTN","DGBT1",209,0)
 S LABL=$S($G(DGMTYPT1)=1:"MEANS TEST ",$G(DGMTYPT1)=2:"COPAY TEST ",1:"WAIVER ")_"EXPIRES: "
"RTN","DGBT1",210,0)
 ; ADDED FOR PATCH 24 VFA MT DO NOT EXPIRE
"RTN","DGBT1",211,0)
 S VFADT=+$$GET1^DIQ(43,"1,",1205,"I",,"ERR")
"RTN","DGBT1",212,0)
 S VFAMTDT=$P($$LST^DGMTCOU1(DFN,$P(DGBTDTI,"."),3),U,2),VFAMTDTP=$$FMADD^XLFDT(VFAMTDT,365,0,0,0)
"RTN","DGBT1",213,0)
 I VFAMTDTP'<VFADT&(LABL["MEANS TEST") Q "MEANS TEST DO NOT EXPIRE"
"RTN","DGBT1",214,0)
 ;
"RTN","DGBT1",215,0)
 Q LABL_TESTDATE
"RTN","DGBT1",216,0)
 ;
"RTN","DGBT1",217,0)
TESTDATE() ;
"RTN","DGBT1",218,0)
 I (+$G(DGBTINCA)),($G(WVREQEXP)>$P(DGBTINCA,U,5)) Q $$DTFORM(WVREQEXP)
"RTN","DGBT1",219,0)
 I +$G(DGBTINCA) Q $$DTFORM($P(DGBTINCA,U,5))
"RTN","DGBT1",220,0)
 S DGMTYPT1=3
"RTN","DGBT1",221,0)
 S TESTDATE=$P($$LST^DGMTCOU1(DFN,DGBTDTI,.DGMTYPT1),U,2)
"RTN","DGBT1",222,0)
 I 'DAYFLG S (TESTDATE,DGMTYPT1)=0
"RTN","DGBT1",223,0)
 I (+TESTDATE=0),($E($G(WVREQEXP),1,3)>$E(DGBTDTI,1,3)) Q $$DTFORM(WVREQEXP)
"RTN","DGBT1",224,0)
 I +TESTDATE=0 Q "12/31/"_$E(DGBTDTI,2,3)
"RTN","DGBT1",225,0)
 Q $$DTFORM(($E(TESTDATE,1,3)+1)_$E(TESTDATE,4,7))
"RTN","DGBT1",226,0)
 ;
"RTN","DGBT1",227,0)
DTFORM(INTDT) ;
"RTN","DGBT1",228,0)
 Q $E(INTDT,4,5)_"/"_$E(INTDT,6,7)_"/"_$E(INTDT,2,3)
"RTN","DGBT1",229,0)
 ;
"RTN","DGBT1",230,0)
DTFORMI(TESTDATE) ; 
"RTN","DGBT1",231,0)
 Q 3_$P(TESTDATE,"/",3)_$P(TESTDATE,"/",2)_$P(TESTDATE,"/")
"RTN","DGBT1",232,0)
 ;
"RTN","DGBT1",233,0)
WVELG() ; Eligibility for waiver being PENSION DGBT*1.0*20 RFE
"RTN","DGBT1",234,0)
 I VAEL(1)["PENSION" Q 1
"RTN","DGBT1",235,0)
 I $P(VAEL(1),"^",2)="AID & ATTENDANCE" Q 1
"RTN","DGBT1",236,0)
 I $P(VAEL(1),"^",2)="HOUSEBOUND" Q 1
"RTN","DGBT1",237,0)
 N HIT
"RTN","DGBT1",238,0)
 S (HIT,I)=""
"RTN","DGBT1",239,0)
 F  S I=$O(VAEL(1,I)) Q:I=""  D  Q:HIT
"RTN","DGBT1",240,0)
 .I VAEL(1,I)["PENSION" S HIT=1 Q
"RTN","DGBT1",241,0)
 .I $P(VAEL(1,I),"^",2)="AID & ATTENDANCE" S HIT=1 Q
"RTN","DGBT1",242,0)
 .I $P(VAEL(1,I),"^",2)="HOUSEBOUND" S HIT=1 Q
"RTN","DGBT1",243,0)
 Q HIT
"RTN","DGBT1",244,0)
 ;
"RTN","DGBT1",245,0)
YEAR(DT1) ; DT2 will be a year after DT1  ; /*Tagline added DGBT*1.0*20 RFE */
"RTN","DGBT1",246,0)
 N DT2,MO,YR
"RTN","DGBT1",247,0)
 S DT2=$$FMTH^XLFDT(DT1,1)+365
"RTN","DGBT1",248,0)
 S YR=+$E(DT1,2,3),MO=+$E(DT1,4,5)
"RTN","DGBT1",249,0)
 I (YR#4=3),(MO>2) S DT2=DT2+1 ; Leap year
"RTN","DGBT1",250,0)
 I (YR#4=0),(MO<3) S DT2=DT2+1 ; Leap year
"RTN","DGBT1",251,0)
 Q DT2
"RTN","DGBT1",252,0)
 ;
"RTN","DGBT1",253,0)
WVREQ(INEX) ; Manual deductible waiver request DGBT*1.0*20 RFE
"RTN","DGBT1",254,0)
 I '$D(^DGBT(392.7,"C",DFN)) Q ""
"RTN","DGBT1",255,0)
 N DGBTDW,EXPDT
"RTN","DGBT1",256,0)
 S (DGBTDW,I)=""
"RTN","DGBT1",257,0)
 F  S I=$O(^DGBT(392.7,"C",DFN,I),-1) Q:I=""  D  Q:DGBTDW'=""
"RTN","DGBT1",258,0)
 .I $$GET1^DIQ(392.7,I,97,"I") Q
"RTN","DGBT1",259,0)
 . S EXPDT=$$GET1^DIQ(392.7,I,8,"I")
"RTN","DGBT1",260,0)
 . I EXPDT="PENSION" S DGBTDW=1 Q
"RTN","DGBT1",261,0)
 . I $E(I,1,3)=$E(DGBTA,1,3) S DGBTDW=^DGBT(392.7,I,0) Q
"RTN","DGBT1",262,0)
 . I $E(I,1,3)'=($E(DGBTA,1,3)-1) Q
"RTN","DGBT1",263,0)
 . I $$GET1^DIQ(392.7,I,8,"I")<$P(DGBTA,".") Q
"RTN","DGBT1",264,0)
 . S DGBTDW=^DGBT(392.7,I,0)
"RTN","DGBT1",265,0)
 I DGBTDW="" Q ""
"RTN","DGBT1",266,0)
 I $P(DGBTDW,"^",3)=0 Q ""
"RTN","DGBT1",267,0)
 I $P(DGBTA,".")<$P($P(DGBTDW,U),".") Q ""
"RTN","DGBT1",268,0)
 I INEX="IN" Q EXPDT
"RTN","DGBT1",269,0)
 I $G(EXPDT)="PENSION" Q "WAIVER EXPIRES: PENSION"
"RTN","DGBT1",270,0)
 I EXPDT<$P(DGBTDTI,".") Q ""
"RTN","DGBT1",271,0)
 Q "WAIVER EXPIRES: "_$$DTFORM(EXPDT)
"RTN","DGBT1",272,0)
 ;
"RTN","DGBT1",273,0)
LSTMTDT(DFN) ;this will return the last means test date
"RTN","DGBT1",274,0)
 N MTIEN
"RTN","DGBT1",275,0)
 S MTIEN=""
"RTN","DGBT1",276,0)
 S MTIEN=$O(^DGMT(408.31,"C",DFN,MTIEN),-1)
"RTN","DGBT1",277,0)
 S LSTMTDT=$P(^DGMT(408.31,MTIEN,0),"^",1)
"RTN","DGBT1",278,0)
 Q LSTMTDT
"RTN","DGBT1",279,0)
 ;
"RTN","DGBT1",280,0)
LSTMTRIN(DFN,DGBTDTI) ;this willl return whether the patient refused to give income
"RTN","DGBT1",281,0)
 N MTIEN,REFUSED
"RTN","DGBT1",282,0)
 S REFUSED=1
"RTN","DGBT1",283,0)
 S MTIEN=+$$LST^DGMTCOU1(DFN,DGBTDTI,3)
"RTN","DGBT1",284,0)
 I MTIEN'="" S REFUSED=$$GET1^DIQ(408.31,MTIEN,.14,"I")
"RTN","DGBT1",285,0)
 Q REFUSED
"RTN","DGBTALTI")
0^3^B51270693
"RTN","DGBTALTI",1,0)
DGBTALTI ;PAV - BENEFICIARY/TRAVEL Alternate Income Enter/Edit;4/23/2012@1130
"RTN","DGBTALTI",2,0)
 ;;1.0;Beneficiary Travel;**20,24**;September 25, 2001;Build 13
"RTN","DGBTALTI",3,0)
ALT ;BT Alternate Income Enter/Edit
"RTN","DGBTALTI",4,0)
 D KILL S DGBTIME=300 S:'$D(DTIME) DTIME=DGBTIME S:'$D(U) U="^"
"RTN","DGBTALTI",5,0)
 I '$D(DT)#2 S %DT="",S="T" D ^%DT S DT=Y
"RTN","DGBTALTI",6,0)
PATIENT ; patient lookup, quit if patient doesn't exist
"RTN","DGBTALTI",7,0)
 D QUIT1^DGBTEND ; kill local variables except med division vars
"RTN","DGBTALTI",8,0)
 S DGBTDTI=DT
"RTN","DGBTALTI",9,0)
 S DGBTTOUT="",DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Select PATIENT: "
"RTN","DGBTALTI",10,0)
 W !!,"BT Alternate Income Enter/Edit" D ^DIC K DIC G:+Y'>0 EXITE
"RTN","DGBTALTI",11,0)
 ; get patient information#
"RTN","DGBTALTI",12,0)
 S DFN=+Y
"RTN","DGBTALTI",13,0)
 L +^DGBT(392.9,DFN):3
"RTN","DGBTALTI",14,0)
 E  W !,*7,"Somebody else is Editing this entry",*7 G EXIT
"RTN","DGBTALTI",15,0)
 D 6^VADPT,KVAR^DGBTEND,PID^VADPT ;
"RTN","DGBTALTI",16,0)
 I '+VAEL(1) W !!,"Eligibility is missing from registration and is required to continue.",*7 G EXIT
"RTN","DGBTALTI",17,0)
 D GA^DGBTUTL(DFN,"XX(3)",DT,"XX(5)") ;W !! ZW XX W !
"RTN","DGBTALTI",18,0)
 I $D(XX(5,1))!(XX(3)) D  W ! G:$G(EXIT) EXIT
"RTN","DGBTALTI",19,0)
 .W ! S DIR("A")="<D>isplay Income History, or <C>ontinue with current Alt. Income: ",DIR(0)="SA^;D:Display;C:Continue",DIR("B")="C" D ^DIR
"RTN","DGBTALTI",20,0)
 .I Y=U!($G(DUOUT)) S EXIT=1 Q
"RTN","DGBTALTI",21,0)
 .Q:Y="C"
"RTN","DGBTALTI",22,0)
 .W !!,"History of Alt. Incomes:" S I=0
"RTN","DGBTALTI",23,0)
 .F  S I=$O(XX(5,I)) Q:'I  W !,I,":  ",$$FMTE^XLFDT($P(XX(5,I),U,3)),?30,"$",$P(XX(5,I),U,2),?40,$S($P(XX(5,I),U,4)="H":"Hardship",1:"POW"),?50,"Ex: ",$$FMTE^XLFDT($P(XX(5,I),U,5))
"RTN","DGBTALTI",24,0)
 .W:XX(3) !,"*",":  ",$$FMTE^XLFDT($P(XX(3),U,3)),?30,"$",$P(XX(3),U,2),?40,$S($P(XX(3),U,4)="H":"Hardship",1:"POW"),?50,"Ex: ",$$FMTE^XLFDT($P(XX(3),U,5))
"RTN","DGBTALTI",25,0)
DATE ;Get the date
"RTN","DGBTALTI",26,0)
 K DIR S DIR("A")="Begin Date",DIR("B")=$$FMTE^XLFDT(DT),DIR(0)="D^"_$$FMADD^XLFDT(DT,-30)_":DT:EA"
"RTN","DGBTALTI",27,0)
 D ^DIR G:(Y=U)!$G(DTOUT)!$G(DUOUT) EXIT
"RTN","DGBTALTI",28,0)
 S DGBTDTI=Y,DGBTDTY=" (Year: "_$$FMTE^XLFDT($E(DGBTDTI,1,3)_"0000")_")"
"RTN","DGBTALTI",29,0)
 S XXX(3)=XX(3) K XX D PI(DFN,DGBTDTI,.XX) S XX(3)=XXX(3)
"RTN","DGBTALTI",30,0)
 D PD S TXT=""
"RTN","DGBTALTI",31,0)
RD ;Display - Redisplay Alt. Income on File
"RTN","DGBTALTI",32,0)
 I XX(3) W !!,*7 S:'$L(TXT) TXT=$$FMTE^XLFDT($P(XX(3),U,3))_": $"_$P(XX(3),U,2)_" Alternate income is on the File" W TXT D  G:EXIT EXIT G RD
"RTN","DGBTALTI",33,0)
 .I $$FMDIFF^XLFDT(DT,$P(XX(3),U,3))>30 W !!,"No Edit permited for Alt. Income older as 30 days." S EXIT=1 Q
"RTN","DGBTALTI",34,0)
 .S EXIT=0,TXT=""
"RTN","DGBTALTI",35,0)
 .K DIR S DIR("A")="<D>elete Alt. Income, <E>dit Alt. Income, or <Q>uit ",DIR("B")="Quit",DIR(0)="SA^D:Delete;E:Edit;Q:Quit" D ^DIR
"RTN","DGBTALTI",36,0)
 .I Y="Q"!(Y=U) S EXIT=1 Q
"RTN","DGBTALTI",37,0)
 .I Y="E" S X=$$SETINC(DFN,$P(XX(3),U,3),DGBTDTI) D GA^DGBTUTL(DFN,"XX(3)",DGBTDTI),PD S TXT=$$FMTE^XLFDT($P(XX(3),U,3))_": Alt. Income "_$S($P(XX(3),U,4)="H":"Hardship",1:"POW")_": $"_$P(XX(3),U,2)_" has been Saved " Q
"RTN","DGBTALTI",38,0)
 .I Y="D" S DA(1)=DFN,DA=$P(XX(3),U,3),DIK="^DGBT(392.9,DFN,1," D ^DIK W !,"Alternate Income Deleted" S EXIT=1
"RTN","DGBTALTI",39,0)
 I XX(1) W !!,"Patient Already Qualified for Low Income Condition",*7 G EXIT
"RTN","DGBTALTI",40,0)
 W:XX(4) !!,"This is the POW Patient",*7
"RTN","DGBTALTI",41,0)
 W !
"RTN","DGBTALTI",42,0)
RD1 W !,"Continue Processing Alternate Income" S %=1 D YN^DICN
"RTN","DGBTALTI",43,0)
 I %=2!(%=-1) G EXIT
"RTN","DGBTALTI",44,0)
 I '% W !,"    Answer with 'Yes' or 'No'",*7 G RD1
"RTN","DGBTALTI",45,0)
 I $$SETINC(DFN,,DGBTDTI) S DA(1)=DFN,DA=DGBTDTI,DIK="^DGBT(392.9,DFN,1," D ^DIK W !,"Alternate Income Deleted" G EXIT
"RTN","DGBTALTI",46,0)
 D GA^DGBTUTL(DFN,"XX(3)",DGBTDTI),PD
"RTN","DGBTALTI",47,0)
 I XX(3) W !!,$S($P(XX(3),U,4)="H":"Hardship",1:"POW")_": $",$P(XX(3),U,2)," Begin: ",$$FMTE^XLFDT($P(XX(3),U,3))," Expire: ",$$FMTE^XLFDT($P(XX(3),U,5))," has been Saved "
"RTN","DGBTALTI",48,0)
 G EXIT
"RTN","DGBTALTI",49,0)
 Q 
"RTN","DGBTALTI",50,0)
SETINC(DFN,OLDDATE,DGBTDTI) ;Set Alt Income
"RTN","DGBTALTI",51,0)
 N DIE,DR,Y,FDA,DA
"RTN","DGBTALTI",52,0)
 I $G(OLDDATE) S DA(1)=DFN,DA=OLDDATE,DIK="^DGBT(392.9,DFN,1," D ^DIK
"RTN","DGBTALTI",53,0)
 I '$D(^DGBT(392.9,DFN,0)) S IENC(1)=DFN  S FDA(392.9,"+1,",.01)=IENC(1) D UPDATE^DIE(,"FDA","IENC")
"RTN","DGBTALTI",54,0)
 K IENC S IENC(2)=DGBTDTI,FDA(392.91,"+2,"_DFN_",",.01)=IENC(2) D UPDATE^DIE(,"FDA","IENC","DGBTERR")
"RTN","DGBTALTI",55,0)
 W !,"Begin of Alt. Income: ",$$FMTE^XLFDT(DGBTDTI)
"RTN","DGBTALTI",56,0)
 K DIR S DIR("A")="Enter the Alternate Income",DIR(0)="392.91,1"
"RTN","DGBTALTI",57,0)
 I $L($P($G(XX(3)),U,2)) S DIR("B")=$P($G(XX(3)),U,2),DIR(0)="392.91,1"
"RTN","DGBTALTI",58,0)
 E  S DIR(0)="392.91,1A",DIR("A")=DIR("A")_": "
"RTN","DGBTALTI",59,0)
 D ^DIR
"RTN","DGBTALTI",60,0)
 Q:Y=U!$G(DTOUT) 1  ;$S($P($G(XX(3)),U,2):0,1:1)
"RTN","DGBTALTI",61,0)
 S FDA(392.91,DGBTDTI_","_DFN_",",1)=Y
"RTN","DGBTALTI",62,0)
 K DIR S DIR("A")="Enter the Reason for Alternate Income: "
"RTN","DGBTALTI",63,0)
 I XX(4) S DIR("B")="P",DIR(0)="SA^P:POW;H:Hardship"
"RTN","DGBTALTI",64,0)
 E  S DIR("B")="H",DIR(0)="SA^H:Hardship"
"RTN","DGBTALTI",65,0)
 D ^DIR
"RTN","DGBTALTI",66,0)
 I Y=U!$G(DTOUT) Q 1
"RTN","DGBTALTI",67,0)
 S FDA(392.91,DGBTDTI_","_DFN_",",2)=Y
"RTN","DGBTALTI",68,0)
 S FDA(392.91,DGBTDTI_","_DFN_",",3)=$S(Y="H":$E(DGBTDTI,1,3)_1231,1:$E(DGBTDTI,1,3)+1_$E(DGBTDTI,4,7))
"RTN","DGBTALTI",69,0)
 D FILE^DIE(,"FDA")
"RTN","DGBTALTI",70,0)
 Q 0
"RTN","DGBTALTI",71,0)
PI(DFN,DGBTDTI,XX) ;Return Patient info in XX
"RTN","DGBTALTI",72,0)
 ;XX(1)=Already Low Income on Record
"RTN","DGBTALTI",73,0)
 ;XX(2)=Hardship on Record  <== Discontinued
"RTN","DGBTALTI",74,0)
 ;XX(3)=Alt Income is on file   1^$Alt Inc^Date^Reason^Exp Date
"RTN","DGBTALTI",75,0)
 ;XX(4)=POW on file
"RTN","DGBTALTI",76,0)
 ;XX(5)=Expired Alt Income on file (list)  XX(5,I)=Date^income^reason^expiration date
"RTN","DGBTALTI",77,0)
 N X0,X1,FDA K XX
"RTN","DGBTALTI",78,0)
 S DGBTDEP=$$DEP^VAFMON(DFN,DGBTDTI)
"RTN","DGBTALTI",79,0)
 S DGBTMTTH=$$MTTH^DGBTMTTH(DGBTDEP,DGBTDTI) ; Means test threshold
"RTN","DGBTALTI",80,0)
 S DGBTRXTH=+$$THRES^IBARXEU1(DGBTDTI,1,DGBTDEP) ; RX co-pay threshhold
"RTN","DGBTALTI",81,0)
 S X0=+$$LI^DGBTUTL(DFN,DGBTDTI,DGBTDEP,1)
"RTN","DGBTALTI",82,0)
 S XX(1)=$S("1^2"[X0:1,1:0)
"RTN","DGBTALTI",83,0)
 ;S XX(2)=$S(X0=3:1,1:0)
"RTN","DGBTALTI",84,0)
 D GA^DGBTUTL(DFN,"XX(3)",DGBTDTI,"XX(5)")
"RTN","DGBTALTI",85,0)
 D SVC^VADPT
"RTN","DGBTALTI",86,0)
 S XX(4)=+$G(VASV(4))
"RTN","DGBTALTI",87,0)
 Q:XX(4)
"RTN","DGBTALTI",88,0)
 ;VAEL(1)="15^HOUSEBOUND"
"RTN","DGBTALTI",89,0)
 ;VAEL(1,18)="18^PRISONER OF WAR"
"RTN","DGBTALTI",90,0)
 I VAEL(1)["PRISONER OF WAR" S XX(4)=1
"RTN","DGBTALTI",91,0)
 F  S X0=$O(VAEL(1,X0)) Q:'X0  I VAEL(1,X0)["PRISONER OF WAR" S XX(4)=1 Q
"RTN","DGBTALTI",92,0)
 Q
"RTN","DGBTALTI",93,0)
PD ;Display patient information
"RTN","DGBTALTI",94,0)
 W @IOF
"RTN","DGBTALTI",95,0)
 D PID^VADPT6 W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2)
"RTN","DGBTALTI",96,0)
 W !!?5,"Address: ",VAPA(1) W:VAPA(2)]"" !?14,VAPA(2) W:VAPA(3)]"" !?14,VAPA(3) W !?14,VAPA(4),$S(VAPA(4)]"":", "_$P(VAPA(5),"^",2)_"  "_$P(VAPA(11),U,2),1:"UNSPECIFIED")
"RTN","DGBTALTI",97,0)
 ;  if move in current info for elig, sc%
"RTN","DGBTALTI",98,0)
 S DGBTELG=VAEL(1),DGBTCSC=VAEL(3)
"RTN","DGBTALTI",99,0)
 I +DGBTELG=3,'$E(DGBTCSC)=1 S DGBTCSC=1
"RTN","DGBTALTI",100,0)
 W !!," Eligibility: ",$P(DGBTELG,"^",2) W:DGBTCSC ?45,"SC%: ",$P(DGBTCSC,"^",2) W ?65,"POW:",$S(XX(4):"YES",1:"NO") W !
"RTN","DGBTALTI",101,0)
 I $O(VAEL(1,0))'="" W !," Other Elig.: " F I=0:0 S I=$O(VAEL(1,I)) Q:'I  W ?14,$P(VAEL(1,I),"^",2)," "
"RTN","DGBTALTI",102,0)
 ;  service connected status/information
"RTN","DGBTALTI",103,0)
 I DGBTCSC&($P(DGBTCSC,"^",2)'>29) W !!,"Disabilities:" S I3=""
"RTN","DGBTALTI",104,0)
 N DGQUIT,I
"RTN","DGBTALTI",105,0)
 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I!($G(DGQUIT)=1)  D
"RTN","DGBTALTI",106,0)
 . S I1=^(I,0),I2=$S($D(^DIC(31,+I1,0)):$P(^(0),"^",1)_" ("_+$P(I1,"^",2)_"%-"_$S($P(I1,"^",3):"SC",1:"NSC")_")",1:""),I3=I1
"RTN","DGBTALTI",107,0)
 . I $Y>(IOSL-3) D PAUSE I $G(DGQUIT)=0 W @IOF
"RTN","DGBTALTI",108,0)
 . I $G(DGQUIT)=1 Q
"RTN","DGBTALTI",109,0)
 . W ?16 W I2,!
"RTN","DGBTALTI",110,0)
 ;;;
"RTN","DGBTALTI",111,0)
 D:XX(3)
"RTN","DGBTALTI",112,0)
 .N X,X2,X3
"RTN","DGBTALTI",113,0)
 .S X=$P(XX(3),U,2),DGBTIFL=$E($P(XX(3),U,4)) ; returns income & source.
"RTN","DGBTALTI",114,0)
 .I X?1N.E!(X<0) D
"RTN","DGBTALTI",115,0)
 .I X<0 S X=0
"RTN","DGBTALTI",116,0)
 .S X2="0$",X3=8 D COMMA^%DTC
"RTN","DGBTALTI",117,0)
 .S DGBTINC=X_U_$G(DGBTIFL)
"RTN","DGBTALTI",118,0)
 S DGBTDT=DGBTDTI,DGBTINCA=XX(3)
"RTN","DGBTALTI",119,0)
 I $$DAYSTEST^DGBT1(DFN,.DAYFLG,.RXDAYS,.RXCPST,.LOWINC,.DGNOTEST)
"RTN","DGBTALTI",120,0)
 ; Inserted PATCH 24
"RTN","DGBTALTI",121,0)
 I $$MTCHK^DGBTUTL1(DFN,DGBTDT)>0 D
"RTN","DGBTALTI",122,0)
 . S (DAYFLG,DGBTDYFL)=1
"RTN","DGBTALTI",123,0)
 S X=$$LST^DGMTCOU1(DFN,DT,3),DGBTMTS=$P(X,U,4)_U_$P(X,U,3)
"RTN","DGBTALTI",124,0)
 S:XX(3) RXCPST=0,DGBTMTS=U,DAYFLG=1 ; PAVEL
"RTN","DGBTALTI",125,0)
 ;I DAYFLG,$G(RXCPST),$G(RXCP)'=1 S DGBTINC="^",DGBTIFL=""
"RTN","DGBTALTI",126,0)
 I DAYFLG,$G(RXCPST) S DGBTIFL="C" S:DGBTMTS]"" DGBTMTS=U S:$G(RXCP)'=1 DGBTINC="^"
"RTN","DGBTALTI",127,0)
 I 'DAYFLG S DGBTINC="^",DGBTIFL="^",DGBTMTS="EX^"
"RTN","DGBTALTI",128,0)
 W !!?2,"Income: ",$P($G(DGBTINC),U),$G(DGBTDTY),?35,"Source of Income:  "
"RTN","DGBTALTI",129,0)
 W $S($G(DGBTIFL)="M":"MEANS TEST",$G(DGBTIFL)="C":"COPAY TEST",$G(DGBTIFL)="P":"Alt. Income POW",$G(DGBTIFL)="H":"Alt. Income Hardship",1:"")
"RTN","DGBTALTI",130,0)
 I XX(3) W !,?40," (Expire: ",$$FMTE^XLFDT($P(XX(3),U,5)),")"
"RTN","DGBTALTI",131,0)
 W !?2,"No. of Dependents: ",+DGBTDEP
"RTN","DGBTALTI",132,0)
 I DGBTMTS]"" W:$P(DGBTMTS,"^")'="N" ?35,"MT Status: ",$S($P(DGBTMTS,"^")="EX":"EXPIRED",$P(DGBTMTS,"^")="R":"REQUIRED",$P(DGBTMTS,"^")="P":$P($P(DGBTMTS,"^",2)," "),DGBTMTS=U!($G(RXCPST)):" NOT APPLICABLE",1:$P(DGBTMTS,"^",2))
"RTN","DGBTALTI",133,0)
 ;
"RTN","DGBTALTI",134,0)
 Q
"RTN","DGBTALTI",135,0)
PAUSE   ;added with DGBT*1*11
"RTN","DGBTALTI",136,0)
 I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
"RTN","DGBTALTI",137,0)
 Q 
"RTN","DGBTALTI",138,0)
EXIT ;Exit patient
"RTN","DGBTALTI",139,0)
 I $G(DFN) L -^DGBT(392.9,DFN)
"RTN","DGBTALTI",140,0)
 W !!,"EXITING Patient" D KILL G ALT
"RTN","DGBTALTI",141,0)
 Q
"RTN","DGBTALTI",142,0)
EXITE ; Exit Menu
"RTN","DGBTALTI",143,0)
 I $G(DFN) L -^DGBT(392.9,DFN)
"RTN","DGBTALTI",144,0)
 W !!,"EXITING Alternate Income Menu" D KILL
"RTN","DGBTALTI",145,0)
 Q
"RTN","DGBTALTI",146,0)
KILL ;Kill Local variable.. Dont use NEW, because of return to Patient Prompt
"RTN","DGBTALTI",147,0)
 K DGBTTOUT,DGBTAI,DGBTAIE,DGBTR,DGBTHAR,DGBTELG,VAEL,DGBTCSC,VAPA,VASV,DGBTDEP,DGBTIFL,DGBTINC,IENC,DGBTDTI,DGBTERR,DGBTMTS,DGBTDTY,TXT
"RTN","DGBTALTI",148,0)
 K DGBTINCA,DAYFLG,RXDAYS,RXCPST,LOWINC,DGNOTEST,RXCP,DDD
"RTN","DGBTALTI",149,0)
 K X,Y,I,I1,I2,I3,X2,DFN,DIC,Y,EXP,DA,DR,DIE,FDA,XX,XXX,DIR,EXIT,%DT
"RTN","DGBTUTL")
0^4^B104795609
"RTN","DGBTUTL",1,0)
DGBTUTL ;ALB/SCK - BENEFICIARY/TRAVEL UTILITY ROUTINES;11/14/11
"RTN","DGBTUTL",2,0)
 ;;1.0;Beneficiary Travel;**20,24**;September 25, 2001;Build 13
"RTN","DGBTUTL",3,0)
START ;
"RTN","DGBTUTL",4,0)
 Q
"RTN","DGBTUTL",5,0)
MILES(DGBTRN,DGBTDX) ;
"RTN","DGBTUTL",6,0)
 ; DGBTRN holds the record no., and DGBTDX holds the division pointer passed in during the function call
"RTN","DGBTUTL",7,0)
 N DGBTML,XX,DGBTCHK
"RTN","DGBTUTL",8,0)
 S XX="",(DGBTML,DGBTDEF)=0
"RTN","DGBTUTL",9,0)
 F XX=0:0 S XX=$O(^DGBT(392.1,DGBTRN,1,XX)) Q:+XX'>0!(DGBTML>0)  D
"RTN","DGBTUTL",10,0)
 . S DGBTCHK=$P($G(^DGBT(392.1,DGBTRN,1,XX,0)),U,1) I DGBTDX=DGBTCHK S DGBTML=$P($G(^(0)),U,2)
"RTN","DGBTUTL",11,0)
 I DGBTML'>0 S DGBTML=$P($G(^DGBT(392.1,DGBTRN,0)),U,3),DGBTDEF=1
"RTN","DGBTUTL",12,0)
 K DGBTRN,DGBTDX
"RTN","DGBTUTL",13,0)
 Q DGBTML
"RTN","DGBTUTL",14,0)
DICLKUP(DGBTRN,DGBTDX,DGBTP) ;
"RTN","DGBTUTL",15,0)
 N RETURN,XX
"RTN","DGBTUTL",16,0)
 S DIC="^DGBT(392.1,DGBTRN,1,",DIC(0)="MZX",X=DGBTDX,RETURN=""
"RTN","DGBTUTL",17,0)
 D ^DIC
"RTN","DGBTUTL",18,0)
 I +Y>0 D
"RTN","DGBTUTL",19,0)
 . I DGBTP=4 S RETURN=$S(+$P($G(Y(0)),U,4)>0:$P($G(Y(0)),U,5),1:"")
"RTN","DGBTUTL",20,0)
 . I DGBTP=3 S RETURN=$S(+$P($G(Y(0)),U,3)>0:$P(^(0),U,3),1:0)
"RTN","DGBTUTL",21,0)
 Q RETURN
"RTN","DGBTUTL",22,0)
DEPCTY(ZIPCDE) ;
"RTN","DGBTUTL",23,0)
 N RETURN
"RTN","DGBTUTL",24,0)
 S DIC="^DGBT(392.1,",DIC(0)="MZ",X=$S($L(ZIPCDE)>5:$E(ZIPCDE,1,5),1:ZIPCDE) D ^DIC S RETURN=Y K DIC
"RTN","DGBTUTL",25,0)
 K ZIPCDE
"RTN","DGBTUTL",26,0)
 Q RETURN
"RTN","DGBTUTL",27,0)
 ;
"RTN","DGBTUTL",28,0)
DWAIVER(DFN,DGBTDCV,CLIEN) ;Get Deductible Waiver ***PAVEL
"RTN","DGBTUTL",29,0)
 ;DFN - Patient IEN
"RTN","DGBTUTL",30,0)
 ;DGBTDCV - Deductible amount
"RTN","DGBTUTL",31,0)
 ;CLIEN - Ien of current BT Claim
"RTN","DGBTUTL",32,0)
 N VAEL,DGBTMW,EXIT,DGBTRDV
"RTN","DGBTUTL",33,0)
 S EXIT=0
"RTN","DGBTUTL",34,0)
 ;added by bld to correct problem with manual waiver's
"RTN","DGBTUTL",35,0)
 I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)="MAN" Q "0^Manual Waiver"
"RTN","DGBTUTL",36,0)
 I $D(^DGBT(392.7,"C",DFN)) D  Q:EXIT "0^Manual Waiver"
"RTN","DGBTUTL",37,0)
 .S EXIT=0,DGBTMW=CLIEN+0.00001
"RTN","DGBTUTL",38,0)
 .F  S DGBTMW=$O(^DGBT(392.7,"C",DFN,DGBTMW),-1) Q:'DGBTMW!EXIT  D
"RTN","DGBTUTL",39,0)
 ..Q:$P(^DGBT(392.7,DGBTMW,0),"^",3)'=1      ;Waiver not Authorized
"RTN","DGBTUTL",40,0)
 ..Q:$D(^DGBT(392.7,DGBTMW,"DEL"))     ;Waiver deleted
"RTN","DGBTUTL",41,0)
 ..I $P(^DGBT(392.7,DGBTMW,0),"^",7)="PENSION" S EXIT=1 Q      ;Waiver never expire
"RTN","DGBTUTL",42,0)
 ..Q:$P(CLIEN,".",1)>$P(^DGBT(392.7,DGBTMW,0),"^",7)      ;Waiver expired
"RTN","DGBTUTL",43,0)
 ..S EXIT=1       ;Waiver found.
"RTN","DGBTUTL",44,0)
 .Q
"RTN","DGBTUTL",45,0)
 D ELIG^VADPT
"RTN","DGBTUTL",46,0)
 I $$WVELG^DGBT1 Q "0^VA Pension"
"RTN","DGBTUTL",47,0)
 I $P(DGBTINC,U,2)="H" Q "0^Alt Income Hardship"
"RTN","DGBTUTL",48,0)
 I $P(DGBTINC,U,2)="P" Q "0^Alt Income POW"
"RTN","DGBTUTL",49,0)
 I $G(DAYFLG)&('$G(DGBTREF))&(DGBTNSC)&($P($G(DGBTINC),"^",1)'="")&(+$TR($P(DGBTINC,U),"$,","")<DGBTRXTH) Q "0^NSC Low Income"
"RTN","DGBTUTL",50,0)
 I $G(DGBTREF)&(DGBTNSC) Q "0^Patient refuse to provide financial information"
"RTN","DGBTUTL",51,0)
 I '$G(DAYFLG) Q "0^Patient has expired Means Test or Co-Pay Test"
"RTN","DGBTUTL",52,0)
 ;Output:
"RTN","DGBTUTL",53,0)
 ;VAEL(4) If the VETERAN (Y/N)? field is YES, a "1" will be returned; otherwise, a "0" will be returned. (e.g., 1)
"RTN","DGBTUTL",54,0)
 I 'VAEL(4) Q "0^NO Veteran"
"RTN","DGBTUTL",55,0)
 N INCOME,X0,X1,X2,XX,MTEST
"RTN","DGBTUTL",56,0)
 N VAMB D MB^VADPT
"RTN","DGBTUTL",57,0)
 N LI
"RTN","DGBTUTL",58,0)
 ;Output:
"RTN","DGBTUTL",59,0)
 ;VAMB(1) A&A BENEFITS? field is YES, a "1" will be returned in the first piece; otherwise, a "0".
"RTN","DGBTUTL",60,0)
 ; If receiving A&A benefits, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece. (e.g., 1^1000)
"RTN","DGBTUTL",61,0)
 ;VAMB(2) HOUSEBOUND BENEFITS? field is YES, a "1" will be returned in the first piece; otherwise, a "0".
"RTN","DGBTUTL",62,0)
 ; If receiving housebound benefits, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece.
"RTN","DGBTUTL",63,0)
 ;(e.g., 1^0) ;VAMB(4) VA PENSION? field is YES, a "1" will be returned in the first piece; otherwise, a "0" .
"RTN","DGBTUTL",64,0)
 ; If receiving a VA pension, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece. (e.g., 1^563.23)
"RTN","DGBTUTL",65,0)
 I VAMB(4),VAMB(1) Q "0^VA Pension and A&A"
"RTN","DGBTUTL",66,0)
 I VAMB(4),VAMB(2) Q "0^VA Pension and HB"
"RTN","DGBTUTL",67,0)
 I VAMB(4) Q "0^VA Pension"
"RTN","DGBTUTL",68,0)
 ;Is the mode of transportation :Common Carrier ?
"RTN","DGBTUTL",69,0)
 S LI=0
"RTN","DGBTUTL",70,0)
 I '$G(DGBTREF) S XX=$$LI(DFN,DGBTDTI,DGBTDEP,,DGBTINCA) ;Get Low Income + Hardship
"RTN","DGBTUTL",71,0)
 I $G(DGBTMLT)=0 S XX=0
"RTN","DGBTUTL",72,0)
 I '$G(XX),$G(DGBTCCMODE)'="",$G(DGBTCCREQ),$G(DGBTMLT) Q "0^Mode of transportation is Common Carrier/With Mileage"
"RTN","DGBTUTL",73,0)
 I '$G(XX),$G(DGBTCCMODE)'="",$G(DGBTCCREQ) Q "0^Mode of transportation is Common Carrier"
"RTN","DGBTUTL",74,0)
 Q $S(+$G(XX):"0^"_$P($G(XX),U,2),1:DGBTDCV)
"RTN","DGBTUTL",75,0)
 ;
"RTN","DGBTUTL",76,0)
GA(DFN,AA,DGBTDTI,AB) ;Get Alternate Income on file
"RTN","DGBTUTL",77,0)
 ;@AA= 0^    = no Valid Alternate Income
"RTN","DGBTUTL",78,0)
 ;@AA= 1^Alt Income^Date Alt. Income Entered^Reason: Hardship or POW^Expiration date
"RTN","DGBTUTL",79,0)
 ;@AB(I)=1^Alt Income^Date Alt. Income Entered^Reason: Hardship or POW^Expiration date   - Expire income
"RTN","DGBTUTL",80,0)
 ;Example:  @AA=1^7777.7^3120501.203728^H^3121231
"RTN","DGBTUTL",81,0)
 ;FDA(392.9,"7171872,",.01,"I")="7171872"
"RTN","DGBTUTL",82,0)
 ;FDA(392.91,"3120423.211054,7171872,",.01,"I")=3120423.211054
"RTN","DGBTUTL",83,0)
 ;FDA(392.91,"3120423.211054,7171872,",1,"I")=12345.67
"RTN","DGBTUTL",84,0)
 ;FDA(392.91,"3120423.211054,7171872,",2,"I")="H"
"RTN","DGBTUTL",85,0)
 ;FDA(392.91,"3120423.211054,7171872,",3,"I")=3121231
"RTN","DGBTUTL",86,0)
 N FDA,X0,X,Y,I,FDD,AC
"RTN","DGBTUTL",87,0)
 S @AA="0^" ;S XX(3)="0^"
"RTN","DGBTUTL",88,0)
 D GETS^DIQ(392.9,DFN_",","**","I","FDA","DGBTERR")
"RTN","DGBTUTL",89,0)
 S X0=$G(FDA(392.9,DFN_",",.01,"I"))
"RTN","DGBTUTL",90,0)
 Q:'$L(X0)!'$G(DGBTDTI)
"RTN","DGBTUTL",91,0)
 S X0="" F  S X0=$O(FDA(392.91,X0)) Q:'$L(X0)  S X=$P(X0,",",1) M FDD(392.91,X)=FDA(392.91,X0)
"RTN","DGBTUTL",92,0)
 S X0=DGBTDTI+0.000001
"RTN","DGBTUTL",93,0)
 F  S X0=$O(FDD(392.91,X0),-1) Q:'X0  D  Q:+@AA  ;Quit If Alternate income found
"RTN","DGBTUTL",94,0)
 .Q:DGBTDTI>$G(FDD(392.91,X0,3,"I"))  ;Alternate Income Expired continue search
"RTN","DGBTUTL",95,0)
 .S @AA="1^"_$G(FDD(392.91,X0,1,"I"))_U_X0_U_$G(FDD(392.91,X0,2,"I"))_U_$G(FDD(392.91,X0,3,"I"))
"RTN","DGBTUTL",96,0)
 .K FDD(392.91,X0)
"RTN","DGBTUTL",97,0)
 I $D(FDD),$L($G(AB)) D
"RTN","DGBTUTL",98,0)
 .S AB=$S($E(AB,$L(AB))=")":$E(AB,1,$L(AB)-1)_",",1:AB_"(")
"RTN","DGBTUTL",99,0)
 .S X0=0 F I=1:1 S X0=$O(FDD(392.91,X0)) Q:'X0  S AC=AB_I_")",@AC="1^"_$G(FDD(392.91,X0,1,"I"))_U_X0_U_$G(FDD(392.91,X0,2,"I"))_U_$G(FDD(392.91,X0,3,"I"))
"RTN","DGBTUTL",100,0)
 Q
"RTN","DGBTUTL",101,0)
LI(DFN,DGBTDTI,DGBTDEP,FLAG,DGBTINCA) ;Low Income
"RTN","DGBTUTL",102,0)
 ;DGBTDEP = # of Dependence
"RTN","DGBTUTL",103,0)
 ;FLAG = 1 Indication if printable Income value returned in DGBTINC and Income Type Type in DGBTIFL
"RTN","DGBTUTL",104,0)
 ;DGBTINCA = Possible Alternate income set for the VA Patient
"RTN","DGBTUTL",105,0)
 ;             1^alt income^date^alt. income reason POW or HARDSHIP^expiration date
"RTN","DGBTUTL",106,0)
 ;DGBTRET = RETURN VALUE:
"RTN","DGBTUTL",107,0)
 ;           0^
"RTN","DGBTUTL",108,0)
 ;           1^Low Income Copay
"RTN","DGBTUTL",109,0)
 ;           2^Low Income M Test
"RTN","DGBTUTL",110,0)
 ;           3^Alt. Income POW
"RTN","DGBTUTL",111,0)
 ;           4^Alt. Income Hardship
"RTN","DGBTUTL",112,0)
 N INCOME,X,X0,X2,X3,Y,MTEST,DGBTRET
"RTN","DGBTUTL",113,0)
 S DGBTRET="0^"
"RTN","DGBTUTL",114,0)
 I $G(DGBTREF) Q DGBTRET
"RTN","DGBTUTL",115,0)
 I '$G(DAYFLG) Q DGBTRET
"RTN","DGBTUTL",116,0)
 I '$G(FLAG) N DGBTINC,DGBTIFL
"RTN","DGBTUTL",117,0)
 S DGBTINCA=$G(DGBTINCA,"0^")
"RTN","DGBTUTL",118,0)
 S (Y,INCOME)=$$INCOME^VAFMON(DFN,DGBTDTI,1)
"RTN","DGBTUTL",119,0)
 I '$G(DGBTDYFL) S (Y,INCOME)="0^"
"RTN","DGBTUTL",120,0)
 S:DGBTINCA (Y,INCOME)=$P(DGBTINCA,U,2)_U_$E($P(DGBTINCA,U,4))
"RTN","DGBTUTL",121,0)
 S X=$P(Y,U),DGBTIFL=$P(Y,U,2) ; returns income & source.
"RTN","DGBTUTL",122,0)
 I DGBTIFL["I^V" S (DGBTINC,DGBTIFL,X,Y)="" Q DGBTRET ;Ignore if Income type is I or V
"RTN","DGBTUTL",123,0)
 I X?1N.E!(X<0) D
"RTN","DGBTUTL",124,0)
 .I X<0 S X=0
"RTN","DGBTUTL",125,0)
 .S X2="0$",X3=8 D COMMA^%DTC
"RTN","DGBTUTL",126,0)
 S DGBTINC=X_U_$G(DGBTIFL)
"RTN","DGBTUTL",127,0)
 I $G(DGBTINCA) Q $S($P(DGBTINCA,U,4)="P":"3^Alt. Income POW",1:"4^Alt. Income Hardship")
"RTN","DGBTUTL",128,0)
 I $P(INCOME,U,2)="C" D  Q:$G(DGBTRET) $G(DGBTRET)  ;Copay income
"RTN","DGBTUTL",129,0)
 .S INCOME=+$G(INCOME)
"RTN","DGBTUTL",130,0)
 .I $G(DGBTRXTH),'($G(INCOME)>$G(DGBTRXTH)) S DGBTRET="1^Low Income Copay"
"RTN","DGBTUTL",131,0)
 ;Get the patient Means Test for corresponding data and see if patient is M-test Low Income.
"RTN","DGBTUTL",132,0)
 S MTEST=+$$LST^DGMTU(DFN,DGBTDTI,1) Q:'MTEST DGBTRET ;Get last Means test
"RTN","DGBTUTL",133,0)
 I $G(DGBTRXTH),'($G(INCOME)>$G(DGBTRXTH)) Q "2^Low Income M Test"                                ;change by bld 10/9/2012@2346
"RTN","DGBTUTL",134,0)
 Q $G(DGBTRET)
"RTN","DGBTUTL",135,0)
 ;
"RTN","DGBTUTL",136,0)
EXIT ;
"RTN","DGBTUTL",137,0)
 Q
"RTN","DGBTUTL",138,0)
TEST ;
"RTN","DGBTUTL",139,0)
 W !,"DATE/TIME REQUIRED.."
"RTN","DGBTUTL",140,0)
 S X="OLD",DTOUT=1
"RTN","DGBTUTL",141,0)
 Q
"RTN","DGBTUTL",142,0)
 ;
"RTN","DGBTUTL",143,0)
ABP(DGBTU) ;Function returns date if patient has an active bus pass. Function added in patch 20
"RTN","DGBTUTL",144,0)
 N DATE,IEN,EXPDT
"RTN","DGBTUTL",145,0)
 S DATE=0,IEN=0,EXPDT=0
"RTN","DGBTUTL",146,0)
 F  S DATE=$O(^DGBT(392,"AI",DGBTU,DATE)) Q:'+DATE  S IEN=^DGBT(392,"AI",DGBTU,DATE) I $D(^DGBT(392,IEN,"B"))&($P($G(^DGBT(392,IEN,"B")),U,2)'<DT) S EXPDT=$P(^("B"),U,2) Q
"RTN","DGBTUTL",147,0)
 Q EXPDT
"RTN","DGBTUTL",148,0)
 ;
"RTN","DGBTUTL",149,0)
MHELP ;help text for Mileage/One Way field. Field 32 file 392.
"RTN","DGBTUTL",150,0)
 ;
"RTN","DGBTUTL",151,0)
 ;
"RTN","DGBTUTL",152,0)
 W !,?5,"If patient used a common carrier, then the mileage entered here would be"
"RTN","DGBTUTL",153,0)
 W !,?5,"only the mileage needed to get to the common carrier pick up point.",!
"RTN","DGBTUTL",154,0)
 Q
"RTN","DGBTUTL",155,0)
 ;
"RTN","DGBTUTL",156,0)
PAUSE(EXCEL) ;
"RTN","DGBTUTL",157,0)
 ;
"RTN","DGBTUTL",158,0)
 N DIR,PROMPT,PROMPT1,PROMPT2,PROMPT3
"RTN","DGBTUTL",159,0)
 K Y
"RTN","DGBTUTL",160,0)
 S EXCEL=$G(EXCEL)
"RTN","DGBTUTL",161,0)
 S PROMPT1="REPORT HAS FINISHED, "
"RTN","DGBTUTL",162,0)
 I IOST'["C-" S DGBTQ=1 W !!!,PROMPT1 Q ""                                ;quit if sent to a printer
"RTN","DGBTUTL",163,0)
 S PROMPT2="TURN OFF CAPTURE, THEN "
"RTN","DGBTUTL",164,0)
 S PROMPT3="PRESS RETURN TO CONTINUE OR '^' TO STOP...."
"RTN","DGBTUTL",165,0)
 I EXCEL S PROMPT=PROMPT1_PROMPT2_PROMPT3
"RTN","DGBTUTL",166,0)
 I 'EXCEL S PROMPT=PROMPT3
"RTN","DGBTUTL",167,0)
 W !
"RTN","DGBTUTL",168,0)
 S DIR("A")=PROMPT,DIR(0)="FAO" D ^DIR
"RTN","DGBTUTL",169,0)
 Q Y
"RTN","DGBTUTL",170,0)
 ;
"RTN","DGBTUTL",171,0)
YESNO(PROMPT) ;
"RTN","DGBTUTL",172,0)
 ;
"RTN","DGBTUTL",173,0)
 K DTOUT,DUOUT,DIRUT,DIROUT
"RTN","DGBTUTL",174,0)
 S DIR(0)="Y",DIR("B")="YES",DIR("?")="ENTER Y(ES) OR N(O)"
"RTN","DGBTUTL",175,0)
 I $G(PROMPT)'="" S DIR("A")=PROMPT
"RTN","DGBTUTL",176,0)
 D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) Q 0
"RTN","DGBTUTL",177,0)
 Q Y
"RTN","DGBTUTL",178,0)
 ;
"RTN","DGBTUTL",179,0)
DEVICE(RPTNAM,ROUTINE,DGBTEXCEL,COLWID) ;common device call for DGBT reports
"RTN","DGBTUTL",180,0)
 ;
"RTN","DGBTUTL",181,0)
 N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,ZTQUEUED
"RTN","DGBTUTL",182,0)
 ; RPTNAM = NAME OF DGBT REPORT BEING RUN
"RTN","DGBTUTL",183,0)
 ; ROUTINE = "TAG^ROUTINE"
"RTN","DGBTUTL",184,0)
 ;
"RTN","DGBTUTL",185,0)
 S DGBTQ1=0
"RTN","DGBTUTL",186,0)
 S %ZIS="PQM"
"RTN","DGBTUTL",187,0)
 D ^%ZIS
"RTN","DGBTUTL",188,0)
 I POP S DGBTQ=1 Q
"RTN","DGBTUTL",189,0)
 I IOST["C-" D  Q  ;
"RTN","DGBTUTL",190,0)
 .N X I IOM=255,$D(^%ZOSF("RM")) S (X,IOM)=512 X ^%ZOSF("RM")
"RTN","DGBTUTL",191,0)
 ;Check for exit
"RTN","DGBTUTL",192,0)
 I $G(IO("Q"))  D  S DGBTQ=1
"RTN","DGBTUTL",193,0)
  .S ZTRTN=ROUTINE
"RTN","DGBTUTL",194,0)
 .S ZTDESC="BT REPORT: "_RPTNAM
"RTN","DGBTUTL",195,0)
 .S ZTSAVE("*")=""
"RTN","DGBTUTL",196,0)
 .D ^%ZTLOAD
"RTN","DGBTUTL",197,0)
 .W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
"RTN","DGBTUTL",198,0)
 .D HOME^%ZIS K IO("Q")
"RTN","DGBTUTL",199,0)
 Q
"RTN","DGBTUTL",200,0)
 ;
"RTN","DGBTUTL",201,0)
SELEXCEL() ; - Returns whether to capture data for Excel report.
"RTN","DGBTUTL",202,0)
 ; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
"RTN","DGBTUTL",203,0)
 ;
"RTN","DGBTUTL",204,0)
 N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
"RTN","DGBTUTL",205,0)
 ;
"RTN","DGBTUTL",206,0)
 S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
"RTN","DGBTUTL",207,0)
 S DIR("A")="Do you want to capture report data for an Excel document"
"RTN","DGBTUTL",208,0)
 S DIR("?")="^D HEXC^DGBTUTL"
"RTN","DGBTUTL",209,0)
 D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^"
"RTN","DGBTUTL",210,0)
 K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","DGBTUTL",211,0)
 S EXCEL=0 I Y S EXCEL=1
"RTN","DGBTUTL",212,0)
 ;
"RTN","DGBTUTL",213,0)
 ;Display Excel display message
"RTN","DGBTUTL",214,0)
 I EXCEL=1 D EXMSG
"RTN","DGBTUTL",215,0)
 ;
"RTN","DGBTUTL",216,0)
 Q EXCEL
"RTN","DGBTUTL",217,0)
 ;
"RTN","DGBTUTL",218,0)
HEXC ; - 'Do you want to capture data...' prompt
"RTN","DGBTUTL",219,0)
 W !!,"      Enter:  'Y'    -  To capture detail report data to transfer"
"RTN","DGBTUTL",220,0)
 W !,"                        to an Excel document"
"RTN","DGBTUTL",221,0)
 W !,"              '<CR>' -  To skip this option"
"RTN","DGBTUTL",222,0)
 W !,"              '^'    -  To quit this option"
"RTN","DGBTUTL",223,0)
 Q
"RTN","DGBTUTL",224,0)
 ;
"RTN","DGBTUTL",225,0)
PRINTMSG ;common help message if user selects a printer
"RTN","DGBTUTL",226,0)
 ;
"RTN","DGBTUTL",227,0)
 W !!,"WARNING - THIS REPORT REQUIRES THAT A DEVICE WITH ",COLWID," COLUMN WIDTH BE USED."
"RTN","DGBTUTL",228,0)
 W !,"IT WILL NOT DISPLAY CORRECTLY USING 80 COLUMN WIDTH DEVICES",!
"RTN","DGBTUTL",229,0)
 Q
"RTN","DGBTUTL",230,0)
 ;
"RTN","DGBTUTL",231,0)
EXMSG ;common help message if user selects Excel option
"RTN","DGBTUTL",232,0)
 W !!?5,"Before continuing, please set up your terminal to capture the"
"RTN","DGBTUTL",233,0)
 W !?5,"detail report data. On some terminals, this can  be  done  by"
"RTN","DGBTUTL",234,0)
 W !?5,"clicking  on the 'Tools' menu above, then click  on  'Capture"
"RTN","DGBTUTL",235,0)
 W !?5,"Incoming  Data' to save to  Desktop. This  report  may take a"
"RTN","DGBTUTL",236,0)
 W !?5,"while to run."
"RTN","DGBTUTL",237,0)
 W !!?5,"Note: To avoid  undesired  wrapping of the data  saved to the"
"RTN","DGBTUTL",238,0)
 W !?5,"      file, please enter '0;512;999' at the 'DEVICE:' prompt.",!
"RTN","DGBTUTL",239,0)
 Q
"RTN","DGBTUTL",240,0)
 ;
"RTN","DGBTUTL",241,0)
RDV(DGBTRDV,DGBTDTI) ;this will process the remote sites for visits during current month.
"RTN","DGBTUTL",242,0)
 ;
"RTN","DGBTUTL",243,0)
 q
"RTN","DGBTUTL",244,0)
 N DGBTIEN,CURDATE,LASTVISIT
"RTN","DGBTUTL",245,0)
 S DGBTIEN=0
"RTN","DGBTUTL",246,0)
 S CLMMONTH=$E(DGBTDTI,1,5)
"RTN","DGBTUTL",247,0)
 F  S DGBTIEN=$O(DGBTRDV(DGBTIEN)) Q:DGBTIEN=""  D
"RTN","DGBTUTL",248,0)
 .S VISITDATA=DGBTRDV(DGBTIEN)
"RTN","DGBTUTL",249,0)
 .S LASTVISIT=$E($P(VISITDATA,"^",3),1,5)
"RTN","DGBTUTL",250,0)
 .Q:LASTVISIT'=CLMMONTH
"RTN","DGBTUTL",251,0)
 ;
"RTN","DGBTUTL",252,0)
 Q
"RTN","DGBTUTL",253,0)
NMRNG(PATNAME,SNAME,ENAME,RESULT) ;
"RTN","DGBTUTL",254,0)
 I (SNAME="AAA"),(ENAME="ZZZ") Q 1
"RTN","DGBTUTL",255,0)
 N DONE,I,LEN1,LEN2,PNAM
"RTN","DGBTUTL",256,0)
 S PNAM=$$UP^XLFSTR(PATNAME)
"RTN","DGBTUTL",257,0)
 I '$$SNAM(PNAM,$$UP^XLFSTR(SNAME)) Q 0
"RTN","DGBTUTL",258,0)
 Q $$ENAM(PNAM,$$UP^XLFSTR(ENAME))
"RTN","DGBTUTL",259,0)
SNAM(PNAM,SNAM) ;
"RTN","DGBTUTL",260,0)
 I SNAM="AAA" Q 1
"RTN","DGBTUTL",261,0)
 S LEN1=$L(PNAM),LEN2=$L(SNAM),DONE=0
"RTN","DGBTUTL",262,0)
 F I=1:1:$S(LEN1<LEN2:LEN1,1:LEN2) D  Q:DONE
"RTN","DGBTUTL",263,0)
 .I $E(PNAM,I)]$E(SNAM,I) S DONE=1 Q
"RTN","DGBTUTL",264,0)
 .I $E(PNAM,I)=$E(SNAM,I) Q
"RTN","DGBTUTL",265,0)
 .S RESULT=0,DONE=1
"RTN","DGBTUTL",266,0)
 Q RESULT
"RTN","DGBTUTL",267,0)
ENAM(PNAM,ENAM) ;
"RTN","DGBTUTL",268,0)
 I ENAM="ZZZ" Q 1
"RTN","DGBTUTL",269,0)
 S LEN1=$L(PNAM),LEN2=$L(ENAM),DONE=0
"RTN","DGBTUTL",270,0)
 F I=1:1:$S(LEN1<LEN2:LEN1,1:LEN2) D  Q:DONE
"RTN","DGBTUTL",271,0)
 .I $E(ENAM,I)]$E(PNAM,I) S DONE=1 Q
"RTN","DGBTUTL",272,0)
 .I $E(ENAM,I)=$E(PNAM,I) Q
"RTN","DGBTUTL",273,0)
 .S RESULT=0,DONE=1
"RTN","DGBTUTL",274,0)
 Q RESULT
"RTN","DGBTUTL",275,0)
 ;
"RTN","DGBTUTL",276,0)
DRDV(DFN,DGBTDCV,DGBTDTI,DLM) ;Used in remote data view to get local Deductible
"RTN","DGBTUTL",277,0)
 N I,DGBTDCM
"RTN","DGBTUTL",278,0)
 S DLM=$G(DLM,";") ;Output Delimiter
"RTN","DGBTUTL",279,0)
 S DGBTDCM=0 ;Cumulative of Deductible
"RTN","DGBTUTL",280,0)
 ;Get Ded. paid.
"RTN","DGBTUTL",281,0)
 S I=$E(DGBTDTI,1,5)_"00.2399"
"RTN","DGBTUTL",282,0)
 F  S I=$O(^DGBT(392,"C",DFN,I)) Q:'I!($E(I,1,5)>$E(DGBTDT,1,5))  S:$P($G(^DGBT(392,I,1)),U,2)'=15 DGBTDCM=DGBTDCM+($P(^DGBT(392,I,0),"^",9))
"RTN","DGBTUTL",283,0)
 S I=$$DWAIVER(DFN,DGBTDCV,DGBTDTI)
"RTN","DGBTUTL",284,0)
 ;Q Site;Ded paid;0 if ded reset to 0; Why deductible reset to 0 
"RTN","DGBTUTL",285,0)
 Q $G(DUZ(2))_DLM_DGBTDCM_DLM_$P(I,U,1)_DLM_$P(I,U,2)
"RTN","DGBTUTL",286,0)
 Q
"RTN","DGBTUTL",287,0)
 ;
"RTN","DGBTUTL",288,0)
NSC() ;
"RTN","DGBTUTL",289,0)
 I VAEL(1)["NSC" Q 1
"RTN","DGBTUTL",290,0)
 N HIT
"RTN","DGBTUTL",291,0)
 S (HIT,I)=""
"RTN","DGBTUTL",292,0)
 F  S I=$O(VAEL(1,I)) Q:I=""  D  Q:HIT
"RTN","DGBTUTL",293,0)
 .I VAEL(1,I)["NSC" S HIT=1
"RTN","DGBTUTL",294,0)
 Q HIT
"RTN","DGBTUTL",295,0)
 ;
"RTN","DGBTUTL",296,0)
DAYFLAG() ; See if we have a valid income test
"RTN","DGBTUTL",297,0)
 ;Modified for patch 24
"RTN","DGBTUTL",298,0)
 N MTIEN,STATUS,RESULT,VFADT
"RTN","DGBTUTL",299,0)
 S VFADT=+$$GET1^DIQ(43,"1,",1205,"I",,"ERR")
"RTN","DGBTUTL",300,0)
 ;S MTIEN=$O(^DGMT(408.31,"C",DFN,""),-1) ; Removed so MT associated with claim date can be retrieved
"RTN","DGBTUTL",301,0)
 S MTIEN=+$$LST^DGMTCOU1(DFN,$P(DGBTDTI,"."),3)
"RTN","DGBTUTL",302,0)
 I MTIEN="" Q 0
"RTN","DGBTUTL",303,0)
 S STATUS=$P($$MTS^DGMTU(DFN,$$GET1^DIQ(408.31,MTIEN,.03,"I")),U,2)
"RTN","DGBTUTL",304,0)
 I (STATUS?1A)&("LN"[STATUS) Q 0
"RTN","DGBTUTL",305,0)
 ;
"RTN","DGBTUTL",306,0)
 I DGBTDTI'>VFADT D
"RTN","DGBTUTL",307,0)
 . S RESULT=$$FMDIFF^XLFDT($P(DGBTDTI,"."),$$GET1^DIQ(408.31,MTIEN,.01,"I"))'>365
"RTN","DGBTUTL",308,0)
 E  D
"RTN","DGBTUTL",309,0)
 . I $$GET1^DIQ(408.31,MTIEN,.019)["MEANS TEST" D
"RTN","DGBTUTL",310,0)
 . . S RESULT=$$MTCHK^DGBTUTL1(DFN,$P(DGBTDTI,"."))
"RTN","DGBTUTL",311,0)
 . E  D
"RTN","DGBTUTL",312,0)
 . . S RESULT=$$FMDIFF^XLFDT($P(DGBTDTI,"."),$$GET1^DIQ(408.31,MTIEN,.01,"I"))'>365
"RTN","DGBTUTL",313,0)
 Q +$G(RESULT)
"RTN","DGBTUTL1")
0^2^B55063675
"RTN","DGBTUTL1",1,0)
DGBTUTL1 ;PAV - BENEFICIARY/TRAVEL UTILITY ROUTINES;11/14/11
"RTN","DGBTUTL1",2,0)
 ;;1.0;Beneficiary Travel;**20,24**;September 25, 2001;Build 13
"RTN","DGBTUTL1",3,0)
ELIG(DFN) ;***PAVEL
"RTN","DGBTUTL1",4,0)
 ;IBARXEU1 = DBIA1046
"RTN","DGBTUTL1",5,0)
 ;DFN - Patient IEN
"RTN","DGBTUTL1",6,0)
 ;The BT System must correctly determine if a veteran is eligible for BT reimbursement.  
"RTN","DGBTUTL1",7,0)
 ;There are several checks that the BT System must be modified to automatically make 
"RTN","DGBTUTL1",8,0)
 ;when determin;ing a veteran's eligibility, as well as several checks that require input from the user.
"RTN","DGBTUTL1",9,0)
 ;When the BT user starts a claim, the BT System must be modified to perform the following checks automatically:
"RTN","DGBTUTL1",10,0)
 D SETC     ;Setting entries in file 492.41
"RTN","DGBTUTL1",11,0)
 N VAEL,DGBTX D ELIG^VADPT
"RTN","DGBTUTL1",12,0)
 S DGBTX=0
"RTN","DGBTUTL1",13,0)
 ;a)    If the veteran is Service Connected 30% or greater they are eligible for BT reimbursement.
"RTN","DGBTUTL1",14,0)
 I $G(VAEL(3)),$P(VAEL(3),U,2)>29 D QUALQUES Q $S($G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:$P($T(BTC+1),";;",2)) ;"1^SC 30% or greater"
"RTN","DGBTUTL1",15,0)
 I $P(DGBTINC,U,2)="H" D QUALQUES Q $S($G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:$P($T(BTC+18),";;",2))
"RTN","DGBTUTL1",16,0)
 I $P(DGBTINC,U,2)="P" D QUALQUES Q $S($G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:$P($T(BTC+19),";;",2))
"RTN","DGBTUTL1",17,0)
 ;b)    If the veteran receives a VA pension they are eligible for BT reimbursement.
"RTN","DGBTUTL1",18,0)
 I $$WVELG^DGBT1 D QUALQUES Q $S($G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:$P($T(BTC+2),";;",2)) ;"2^Recipient of VA Pension"
"RTN","DGBTUTL1",19,0)
 I '$G(DGBTREF)&(DGBTNSC)&($P(DGBTINC,"^",1)'="")&(+$TR($P(DGBTINC,U),"$,","")<DGBTRXTH)&(DGBTDYFL) D QUALQUES Q $S($G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:$P($T(BTC+16),";;",2))
"RTN","DGBTUTL1",20,0)
 I '$G(DGBTREF)&(+$P($G(VAEL(3)),U)&(+$P($G(VAEL(3)),U,2)<30)) D  I $G(DGBTX) Q $S($G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:$P($T(BTC+17),";;",2))
"RTN","DGBTUTL1",21,0)
 .I ($P(DGBTINC,"^",1)'="")&(+$TR($P(DGBTINC,U),"$,","")<DGBTRXTH)&('DGBTNSC)&(DGBTDYFL) S DGBTX=$T D QUALQUES
"RTN","DGBTUTL1",22,0)
 N VAMB D MB^VADPT
"RTN","DGBTUTL1",23,0)
 I VAMB(4) D QUALQUES Q $S($G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:$P($T(BTC+2),";;",2)) ;"2^Recipient of VA Pension"
"RTN","DGBTUTL1",24,0)
 ;c)    If the veteran is below the Low Income Eligibility thresholds based upon his current Means Test or Rx Co-pay test 
"RTN","DGBTUTL1",25,0)
 ;      they are eligible for BT reimbursement.
"RTN","DGBTUTL1",26,0)
 N XX,LI
"RTN","DGBTUTL1",27,0)
 S LI="0^"
"RTN","DGBTUTL1",28,0)
 I 'DGBTREF&($P(DGBTINC,"^",1)'="") S LI=$$LI^DGBTUTL(DFN,DGBTDTI,DGBTDEP,,DGBTINCA)
"RTN","DGBTUTL1",29,0)
 I LI D QUALQUES S XX=$S(+LI:$P($T(BTC+(LI+2)),";;",2),$G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:0) Q:XX XX
"RTN","DGBTUTL1",30,0)
 ;$G(DGBTELL)=14:$P($T(BTC+14),";;",2),$G(DGBTELL)=15:$P($T(BTC+15),";;",2),1:
"RTN","DGBTUTL1",31,0)
 ;
"RTN","DGBTUTL1",32,0)
 ;d)    The.  Service Connected (SC) appointment. If it can be determined that the veteran is travelling for a SC appointment 
"RTN","DGBTUTL1",33,0)
 ;      then they are eligible for BT reimbursement.  NOTE: the data in PCE may not always be complete.  If BT is unable 
"RTN","DGBTUTL1",34,0)
 ;      to automatically determine if the travel is SC related then BT may need to ask the user to perform this step manually (see step f).
"RTN","DGBTUTL1",35,0)
 ;e)    The BT System must check the PCE System in VistA to see if the patient is travelling for a Comp and Pension (C&P) appointment. 
"RTN","DGBTUTL1",36,0)
 ;      If it can be determined that the veteran is travelling for a C&P appointment then they are eligible for BT reimbursement.  
"RTN","DGBTUTL1",37,0)
 ;      NOTE: the data in PCE may not always be complete.  If BT is unable to automatically determine if the travel is C&P 
"RTN","DGBTUTL1",38,0)
 ;      related then BT may need to ask the user to perform this step manually (see step g).
"RTN","DGBTUTL1",39,0)
 ;
"RTN","DGBTUTL1",40,0)
PCE ; Patient Encounter
"RTN","DGBTUTL1",41,0)
 N DGVAL,DGCBK,DGDT1,DGQUERY,SDOE0,SDSTOP
"RTN","DGBTUTL1",42,0)
 ;
"RTN","DGBTUTL1",43,0)
 ;S DGVAL("DFN")=DFN,DGVAL("BDT")=DGBTDTI\1,DGVAL("EDT")=DGVAL("BDT")_".9999"
"RTN","DGBTUTL1",44,0)
 ;S DGCBK="I $P(SDOE0,U,8)=2 D VIS^DGBTUTL1(SDOE0) S DGDT1=+SDOE0",DGDT1=""
"RTN","DGBTUTL1",45,0)
 ;S XX=0 ;D SCAN^DGSDU("PATIENT/DATE",.DGVAL,"",DGCBK,1,.DGQUERY)
"RTN","DGBTUTL1",46,0)
 ;Q:XX XX    ;XX="7^Service connected appointment on the file"
"RTN","DGBTUTL1",47,0)
 ;XX="8^Compensation & Pension appointment on the file"
"RTN","DGBTUTL1",48,0)
 ;
"RTN","DGBTUTL1",49,0)
 ;If any of the above automatic checks (a, b, c, d or e) indicate that the veteran is eligible for BT reimbursement 
"RTN","DGBTUTL1",50,0)
 ;then the processing for this enhancement is complete.  If, however, the veteran does not pass any of the tests 
"RTN","DGBTUTL1",51,0)
 ;outlined above, the BT System must ask the user for additional information in order to determine if the veteran 
"RTN","DGBTUTL1",52,0)
 ;is eligible for BT reimbursement:
"RTN","DGBTUTL1",53,0)
 ;
"RTN","DGBTUTL1",54,0)
 ;f)    The BT System must ask the user if the veteran is travelling for a SC appointment.
"RTN","DGBTUTL1",55,0)
 ;      If the user responds with YES then the veteran is eligible for BT reimbursement.  Otherwise, go to step g.
"RTN","DGBTUTL1",56,0)
 ;g)    The BT System must ask the user if the veteran is travelling for a C&P appointment.
"RTN","DGBTUTL1",57,0)
 ;      If the user responds with YES then the veteran is eligible for BT reimbursement.
"RTN","DGBTUTL1",58,0)
 ;
"RTN","DGBTUTL1",59,0)
 ;DGBTSCAP - Contains answer to SC appointment question
"RTN","DGBTUTL1",60,0)
 ;DGBTCPAP = Contains answer to C&P appointment question
"RTN","DGBTUTL1",61,0)
 S DGBTSCAP=$$GET1^DIQ(392,DGBTDTI,43.4,"I")
"RTN","DGBTUTL1",62,0)
 S DGBTCPAP=$$GET1^DIQ(392,DGBTDTI,43,"I")
"RTN","DGBTUTL1",63,0)
 I '$G(DGBTNSC) W !,"IS THIS A CLAIM FOR A SERVICE CONNECTED APPOINTMENT" S %=$S('DGBTSCAP:2,1:1) D YN^DICN S DGBTSCAP=$S(%=2:"NO",1:"YES") I %'=2 D CLRLTR^DGBTDLT(0)
"RTN","DGBTUTL1",64,0)
 I '$G(DGBTNSC) Q:%=1 $P($T(BTC+9),";;",2) ;"9^Patient stated SERVICE CONNECTED APPOINTMENT^43.1"
"RTN","DGBTUTL1",65,0)
 I '$G(DGBTNSC) Q:%=-1 $P($T(BTC+14),";;",2) ;"14^Patient Exits Claim"
"RTN","DGBTUTL1",66,0)
 W !,"IS THIS A CLAIM FOR A COMP AND PENSION APPOINTMENT" S %=$S('DGBTCPAP:2,1:1) D YN^DICN S DGBTCPAP=$S(%=2:"NO",1:"YES") I %'=2 D CLRLTR^DGBTDLT(0)
"RTN","DGBTUTL1",67,0)
 Q:%=1 $P($T(BTC+10),";;",2) ;"10^Patient stated COMP AND PENSION APPOINTMENT"
"RTN","DGBTUTL1",68,0)
 Q:%=-1 $P($T(BTC+14),";;",2) ;"14^Patient Exits Claim"
"RTN","DGBTUTL1",69,0)
 W !!,"PATIENT IS NOT ELIGIBLE FOR BT REIMBURSEMENT"
"RTN","DGBTUTL1",70,0)
 W !!,"CONTINUE WITH CLAIM" S %=2 D YN^DICN
"RTN","DGBTUTL1",71,0)
 I %=2!('%)  S DGBTAPPTYP=1 Q $P($T(BTC+15),";;",2) ;"15^PATIENT AGREES WITH DENIAL OF CLAIM" ;<==  Here we should plug E11 Patient stated that he doesn' want to continue with claim
"RTN","DGBTUTL1",72,0)
 D CLRLTR^DGBTDLT(0)
"RTN","DGBTUTL1",73,0)
 Q:%=-1 $P($T(BTC+14),";;",2) ;"14^Patient Exits Claim"
"RTN","DGBTUTL1",74,0)
 K DIR S DIR("A")="SELECT REASON FOR ELIGIBILITY: ",DIR(0)="SA^1:Caregiver;2:Transplant;3:Other" D ^DIR
"RTN","DGBTUTL1",75,0)
 Q:Y=U $P($T(BTC+14),";;",2) ;"14^Patient Exits Claim"
"RTN","DGBTUTL1",76,0)
 Q:Y=1 $P($T(BTC+11),";;",2) ;"11^PATIENT STATED ELIGIBILITY REASON Caregiver "
"RTN","DGBTUTL1",77,0)
 Q:Y=2 $P($T(BTC+12),";;",2) ;"12^PATIENT STATED ELIGIBILITY REASON Transplant"
"RTN","DGBTUTL1",78,0)
 ; Here assuming that Y=3
"RTN","DGBTUTL1",79,0)
 K DIR S DIR("A")="SPECIFY OTHER REASON FOR ELIGIBILITY",DIR(0)="F" D ^DIR
"RTN","DGBTUTL1",80,0)
 Q:Y=U $P($T(BTC+14),";;",2) ;"14^Patient Exits Claim"
"RTN","DGBTUTL1",81,0)
 Q $P($T(BTC+13),";;",2)_": "_Y ;"13^PATIENT STATED OTHER REASON FOR ELIGIBILITY: "_Y
"RTN","DGBTUTL1",82,0)
 ;
"RTN","DGBTUTL1",83,0)
 ;If any of the above manual checks (f or g) indicate that the veteran is eligible for BT reimbursement then 
"RTN","DGBTUTL1",84,0)
 ;the processing for this enhancement is complete.  If, however, the veteran does not pass any of the manual tests outlined above, 
"RTN","DGBTUTL1",85,0)
 ;the BT System must inform the user that the veteran does not qualify for BT reimbursement.  
"RTN","DGBTUTL1",86,0)
 ;The BT System must then ask the user if they want to continue with the claim anyway.  
"RTN","DGBTUTL1",87,0)
 ;If the user responds with NO then the claim is denied and the enhancement is complete. 
"RTN","DGBTUTL1",88,0)
 ;NOTE: at this point in the processing the BT application must Auto-generate BT Denial-of-Benefits Statement and 
"RTN","DGBTUTL1",89,0)
 ;Appellate Rights (see section 2.6.11)
"RTN","DGBTUTL1",90,0)
EXIT ;
"RTN","DGBTUTL1",91,0)
 Q
"RTN","DGBTUTL1",92,0)
VIS(DGBTCSN) ;
"RTN","DGBTUTL1",93,0)
 Q
"RTN","DGBTUTL1",94,0)
 S:$S('DGDT1:0,1:+SDOE0'=DGDT1) SDSTOP=1
"RTN","DGBTUTL1",95,0)
 I 'SDSTOP D
"RTN","DGBTUTL1",96,0)
 .N DGBTCS,YY
"RTN","DGBTUTL1",97,0)
 .S:$P(DGBTCSN,U,3) DGBTCS=$P(DGBTCSN,U,3)
"RTN","DGBTUTL1",98,0)
 .S YY=$$GET1^DIQ(409.1,$P(DGBTCSN,"^",10)_",",4)
"RTN","DGBTUTL1",99,0)
 .S:YY="SC" XX=$P($T(BTC+7),";;",2) ;"7^Service connected appointment on the file"
"RTN","DGBTUTL1",100,0)
 .S:YY="CP" XX=$P($T(BTC+8),";;",2) ;"8^Compensation & Pension appointment on the file"
"RTN","DGBTUTL1",101,0)
 Q
"RTN","DGBTUTL1",102,0)
BTC ; List of entries in 392.41 file
"RTN","DGBTUTL1",103,0)
 ;;1^SC 30% or greater
"RTN","DGBTUTL1",104,0)
 ;;2^Recipient of VA Pension
"RTN","DGBTUTL1",105,0)
 ;;3^Low Income Copay
"RTN","DGBTUTL1",106,0)
 ;;4^Low Income M Test
"RTN","DGBTUTL1",107,0)
 ;;5^Alt. Income POW
"RTN","DGBTUTL1",108,0)
 ;;6^Alt.Income Hardship
"RTN","DGBTUTL1",109,0)
 ;;7^Service connected appointment on the file
"RTN","DGBTUTL1",110,0)
 ;;8^Compensation & Pension appointment on the file
"RTN","DGBTUTL1",111,0)
 ;;9^Patient stated SERVICE CONNECTED APPOINTMENT
"RTN","DGBTUTL1",112,0)
 ;;10^Patient stated COMP AND PENSION APPOINTMENT
"RTN","DGBTUTL1",113,0)
 ;;11^PATIENT STATED ELIGIBILITY REASON Caregiver
"RTN","DGBTUTL1",114,0)
 ;;12^PATIENT STATED ELIGIBILITY REASON Transplant
"RTN","DGBTUTL1",115,0)
 ;;13^PATIENT STATED OTHER REASON FOR ELIGIBILITY 
"RTN","DGBTUTL1",116,0)
 ;;14^""
"RTN","DGBTUTL1",117,0)
 ;;15^CLAIM DENIED
"RTN","DGBTUTL1",118,0)
 ;;16^NSC Low Income
"RTN","DGBTUTL1",119,0)
 ;;17^SC Under 30% and Low Income
"RTN","DGBTUTL1",120,0)
 ;;18^Alternate Income Hardship
"RTN","DGBTUTL1",121,0)
 ;;19^Alternate Income POW
"RTN","DGBTUTL1",122,0)
 ;;20^Patient stated QUALIFIED SC APPOINTMENT
"RTN","DGBTUTL1",123,0)
 ;;21^Patient refuse to provide financial information
"RTN","DGBTUTL1",124,0)
 ;;END
"RTN","DGBTUTL1",125,0)
 Q
"RTN","DGBTUTL1",126,0)
SETC ;Set entries into 392.41 if these are not there
"RTN","DGBTUTL1",127,0)
 N II,FDA,IENC
"RTN","DGBTUTL1",128,0)
 F II=1:1 S IENC(1)=+$P($T(BTC+II),";;",2) Q:'IENC(1)  S FDA(392.41,"+1,",.01)=IENC(1),FDA(392.41,"+1,",1)=$P($T(BTC+II),"^",2) D UPDATE^DIE(,"FDA","IENC")
"RTN","DGBTUTL1",129,0)
 Q
"RTN","DGBTUTL1",130,0)
KILLC ;Remove all entries from 392.41
"RTN","DGBTUTL1",131,0)
 N DA,DIK S DA=0,DIK="^DGBT(392.41," F  S DA=$O(^DGBT(392.41,DA)) Q:'DA  D ^DIK
"RTN","DGBTUTL1",132,0)
 Q
"RTN","DGBTUTL1",133,0)
 ;
"RTN","DGBTUTL1",134,0)
QUALQUES ;this will ask if the appointment was a qualified appointment if the patient is SC 30% or greater
"RTN","DGBTUTL1",135,0)
 ;
"RTN","DGBTUTL1",136,0)
 ;DGBTQAP - Contains answer for Qualified Appointment question
"RTN","DGBTUTL1",137,0)
 S DGBTQAP=$$GET1^DIQ(392,DGBTDTI,43.5,"I")
"RTN","DGBTUTL1",138,0)
 W !!,"Answer NO if you want to deny claim for any reason. Want to continue" S %=$S('$G(DGBTQAP):1,1:$G(DGBTQAP)) D YN^DICN S DGBTQAP=$S(%=2:"NO",1:"YES") I %'=2 D CLRLTR^DGBTDLT(0)
"RTN","DGBTUTL1",139,0)
 I %=2 S DGBTELL=15,LI="" ;$P($T(BTC+9),";;",2) ;"20^Patient stated QUALIFIED SC APPOINTMENT^43.1"
"RTN","DGBTUTL1",140,0)
 I %'=2 D CLRLTR^DGBTDLT(0)
"RTN","DGBTUTL1",141,0)
 I %=-1 S DGBTELL=14
"RTN","DGBTUTL1",142,0)
 ;
"RTN","DGBTUTL1",143,0)
 Q
"RTN","DGBTUTL1",144,0)
 ;
"RTN","DGBTUTL1",145,0)
MTCHK(DFN,DGBTDTI) ;
"RTN","DGBTUTL1",146,0)
 N VFADT,RESULT,MTIEN,MTDATA,ERR,DGBTMT,VFADAYS,MTDAYS,DGDONE,DGMTST,DGIEN
"RTN","DGBTUTL1",147,0)
 ;
"RTN","DGBTUTL1",148,0)
 S (DGDONE,RESULT)=0
"RTN","DGBTUTL1",149,0)
 ;
"RTN","DGBTUTL1",150,0)
 S MTIEN=+$$LST^DGMTCOU1(DFN,$P(DGBTDTI,".",1),1)
"RTN","DGBTUTL1",151,0)
 I '$G(MTIEN) Q 0
"RTN","DGBTUTL1",152,0)
 D GETS^DIQ(408.31,MTIEN_",",".01;.03;.27;.11;.14;.12;.07","IE","MTDATA","ERR")
"RTN","DGBTUTL1",153,0)
 M DGBTMT=MTDATA(408.31,MTIEN_",")
"RTN","DGBTUTL1",154,0)
 ;
"RTN","DGBTUTL1",155,0)
 S VFADT=$$GET1^DIQ(43,"1,",1205,"I",,"ERR")
"RTN","DGBTUTL1",156,0)
 I '$G(VFADT) Q -1
"RTN","DGBTUTL1",157,0)
 ;
"RTN","DGBTUTL1",158,0)
 ; Decision Rule 6
"RTN","DGBTUTL1",159,0)
 I +DGBTMT(.01,"I")>DT G MTQ
"RTN","DGBTUTL1",160,0)
 ;
"RTN","DGBTUTL1",161,0)
 ; Decision Rule 1
"RTN","DGBTUTL1",162,0)
 S MTDAYS=$$FMADD^XLFDT(+DGBTMT(.01,"I"),365,0,0,0)
"RTN","DGBTUTL1",163,0)
 I MTDAYS'<VFADT D  I +$G(DGDONE) G MTQ ; Quit on meeting conditions
"RTN","DGBTUTL1",164,0)
 . I +DGBTMT(.07,"I")>0 S (DGDONE,RESULT)=1
"RTN","DGBTUTL1",165,0)
 ;
"RTN","DGBTUTL1",166,0)
 ; Decision Rule 2
"RTN","DGBTUTL1",167,0)
 I +DGBTMT(.01,"I")>VFADT D  I +$G(DGDONE) G MTQ ; Quit on meeting conditions
"RTN","DGBTUTL1",168,0)
 . I +DGBTMT(.07,"I")>0 S (DGDONE,RESULT)=1
"RTN","DGBTUTL1",169,0)
 ;
"RTN","DGBTUTL1",170,0)
 S DGMTST=$O(^DG(408.32,"B","MT COPAY REQUIRED",0))
"RTN","DGBTUTL1",171,0)
 ; Decision Rule 3
"RTN","DGBTUTL1",172,0)
 I +DGBTMT(.03,"I")=DGMTST D  I +$G(DGDONE) G MTQ ; Quit on meeting conditions
"RTN","DGBTUTL1",173,0)
 . I DGBTMT(.07,"I")'<2991006 D
"RTN","DGBTUTL1",174,0)
 ..  I +DGBTMT(.11,"I") S (DGDONE,RESULT)=1
"RTN","DGBTUTL1",175,0)
 ;
"RTN","DGBTUTL1",176,0)
 ; Decision Rule 4
"RTN","DGBTUTL1",177,0)
 I +DGBTMT(.03,"I")=DGMTST D  I +$G(DGDONE) G MTQ ; Quit on meeting conditions
"RTN","DGBTUTL1",178,0)
 . I +DGBTMT(.11,"I") D
"RTN","DGBTUTL1",179,0)
 .. I +DGBTMT(.14,"I") S (DGDONE,RESULT)=1
"RTN","DGBTUTL1",180,0)
 ;
"RTN","DGBTUTL1",181,0)
 ; Decision Rule 5
"RTN","DGBTUTL1",182,0)
 I DGBTMT(.03,"E")["PENDING" D
"RTN","DGBTUTL1",183,0)
 . I +DGBTMT(.27,"I")'>+DGBTMT(.12,"I") D
"RTN","DGBTUTL1",184,0)
 .. I DGBTMT(.07,"I")'<2991006 D
"RTN","DGBTUTL1",185,0)
 ... I +DGBTMT(.11,"I") D
"RTN","DGBTUTL1",186,0)
 .... I DGBTMT(.14,"I")=0 S RESULT=1
"RTN","DGBTUTL1",187,0)
 ;
"RTN","DGBTUTL1",188,0)
MTQ ;
"RTN","DGBTUTL1",189,0)
 Q RESULT
"VER")
8.0^22.0
**INSTALL NAME**
IB*2.0*385
"BLD",8539,0)
IB*2.0*385^INTEGRATED BILLING^0^3131219^y
"BLD",8539,4,0)
^9.64PA^^
"BLD",8539,6.3)
35
"BLD",8539,"INID")
^
"BLD",8539,"INIT")
POST^IB20P385
"BLD",8539,"KRN",0)
^9.67PA^779.2^20
"BLD",8539,"KRN",.4,0)
.4
"BLD",8539,"KRN",.401,0)
.401
"BLD",8539,"KRN",.402,0)
.402
"BLD",8539,"KRN",.403,0)
.403
"BLD",8539,"KRN",.5,0)
.5
"BLD",8539,"KRN",.84,0)
.84
"BLD",8539,"KRN",3.6,0)
3.6
"BLD",8539,"KRN",3.8,0)
3.8
"BLD",8539,"KRN",9.2,0)
9.2
"BLD",8539,"KRN",9.8,0)
9.8
"BLD",8539,"KRN",9.8,"NM",0)
^9.68A^9^9
"BLD",8539,"KRN",9.8,"NM",1,0)
IBARXEU^^0^B23454054
"BLD",8539,"KRN",9.8,"NM",2,0)
IBARXEL^^0^B17084396
"BLD",8539,"KRN",9.8,"NM",3,0)
IBARXEL1^^0^B15139470
"BLD",8539,"KRN",9.8,"NM",4,0)
IBARXEPL^^0^B29058648
"BLD",8539,"KRN",9.8,"NM",5,0)
IBARXEU0^^0^B13703927
"BLD",8539,"KRN",9.8,"NM",6,0)
IBARXEU1^^0^B18924658
"BLD",8539,"KRN",9.8,"NM",7,0)
IBAMTED1^^0^B22776911
"BLD",8539,"KRN",9.8,"NM",8,0)
IBAMTED2^^0^B4174484
"BLD",8539,"KRN",9.8,"NM",9,0)
IBAUTL6^^0^B18639666
"BLD",8539,"KRN",9.8,"NM","B","IBAMTED1",7)

"BLD",8539,"KRN",9.8,"NM","B","IBAMTED2",8)

"BLD",8539,"KRN",9.8,"NM","B","IBARXEL",2)

"BLD",8539,"KRN",9.8,"NM","B","IBARXEL1",3)

"BLD",8539,"KRN",9.8,"NM","B","IBARXEPL",4)

"BLD",8539,"KRN",9.8,"NM","B","IBARXEU",1)

"BLD",8539,"KRN",9.8,"NM","B","IBARXEU0",5)

"BLD",8539,"KRN",9.8,"NM","B","IBARXEU1",6)

"BLD",8539,"KRN",9.8,"NM","B","IBAUTL6",9)

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

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

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

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

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

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

"BLD",8539,"KRN","B",3.6,3.6)

"BLD",8539,"KRN","B",3.8,3.8)

"BLD",8539,"KRN","B",9.2,9.2)

"BLD",8539,"KRN","B",9.8,9.8)

"BLD",8539,"KRN","B",19,19)

"BLD",8539,"KRN","B",19.1,19.1)

"BLD",8539,"KRN","B",101,101)

"BLD",8539,"KRN","B",409.61,409.61)

"BLD",8539,"KRN","B",771,771)

"BLD",8539,"KRN","B",779.2,779.2)

"BLD",8539,"KRN","B",870,870)

"BLD",8539,"KRN","B",8989.51,8989.51)

"BLD",8539,"KRN","B",8989.52,8989.52)

"BLD",8539,"KRN","B",8994,8994)

"BLD",8539,"PRE")
IB20P385
"BLD",8539,"QUES",0)
^9.62^^
"BLD",8539,"REQB",0)
^9.611^7^7
"BLD",8539,"REQB",1,0)
DG*5.3*858^2
"BLD",8539,"REQB",2,0)
IB*2.0*153^2
"BLD",8539,"REQB",3,0)
IB*2.0*217^2
"BLD",8539,"REQB",4,0)
IB*2.0*269^2
"BLD",8539,"REQB",5,0)
IB*2.0*293^2
"BLD",8539,"REQB",6,0)
IB*2.0*449^2
"BLD",8539,"REQB",7,0)
IB*2.0*195^2
"BLD",8539,"REQB","B","DG*5.3*858",1)

"BLD",8539,"REQB","B","IB*2.0*153",2)

"BLD",8539,"REQB","B","IB*2.0*195",7)

"BLD",8539,"REQB","B","IB*2.0*217",3)

"BLD",8539,"REQB","B","IB*2.0*269",4)

"BLD",8539,"REQB","B","IB*2.0*293",5)

"BLD",8539,"REQB","B","IB*2.0*449",6)

"INIT")
POST^IB20P385
"MBREQ")
0
"PKG",49,-1)
1^1
"PKG",49,0)
INTEGRATED BILLING^IB^INTEGRATED BILLING
"PKG",49,20,0)
^9.402P^1^1
"PKG",49,20,1,0)
2^^IBAXDR
"PKG",49,20,1,1)

"PKG",49,20,"B",2,1)

"PKG",49,22,0)
^9.49I^1^1
"PKG",49,22,1,0)
2.0^2940321^2960627
"PKG",49,22,1,"PAH",1,0)
385^3131219
"PRE")
IB20P385
"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")
10
"RTN","IB20P385")
0^^B21179841
"RTN","IB20P385",1,0)
IB20P385 ;OAK/ELZ - POST INIT ROUTINE FOR IB*2*385 ;5/15/2013
"RTN","IB20P385",2,0)
 ;;2.0;INTEGRATED BILLING;**385**;21-MAR-94;Build 35
"RTN","IB20P385",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IB20P385",4,0)
 ;
"RTN","IB20P385",5,0)
ENV ;
"RTN","IB20P385",6,0)
 ; need to make sure we can find the CD entry for 354.1 before we can
"RTN","IB20P385",7,0)
 ; install.
"RTN","IB20P385",8,0)
 N DIC,X,Y
"RTN","IB20P385",9,0)
 S DIC="^IBE(354.2,",DIC(0)="",X="CATASTROPHICALLY DISABLED" D ^DIC
"RTN","IB20P385",10,0)
 I Y<1 W !,"CATASTROPHICALLY DISABLED entry in file 354.1 not found!!" S XPDQUIT=2
"RTN","IB20P385",11,0)
 Q
"RTN","IB20P385",12,0)
 ;
"RTN","IB20P385",13,0)
POST ;
"RTN","IB20P385",14,0)
 N IBA
"RTN","IB20P385",15,0)
 I $$INSTALDT^XPDUTL("IB*2.0*385") D MES("--> Patch previously installed, not running post-init again",1) Q
"RTN","IB20P385",16,0)
 D MES("--> Starting post-install",1)
"RTN","IB20P385",17,0)
 D CDFIX ; correct file 354.1 code field for CD patients
"RTN","IB20P385",18,0)
 ;D KIDSVFA ; clean up records since VFA start date and cancel charges
"RTN","IB20P385",19,0)
 D MES("--> Post-install complete",1)
"RTN","IB20P385",20,0)
 ;
"RTN","IB20P385",21,0)
 Q
"RTN","IB20P385",22,0)
 ;
"RTN","IB20P385",23,0)
CDFIX ; - need to find the CD entry in file 354.1 and update the code so it is
"RTN","IB20P385",24,0)
 ; a 2 digit code, going to use 70 since IB ignores that code if passed
"RTN","IB20P385",25,0)
 ; in by the DG package
"RTN","IB20P385",26,0)
 N DIC,X,Y,IBFDA
"RTN","IB20P385",27,0)
 D MES("--> Updating 354.2 CATASTROPHICALLY DISABLED entry",1)
"RTN","IB20P385",28,0)
 S DIC="^IBE(354.2,",DIC(0)="",X="CATASTROPHICALLY DISABLED" D ^DIC
"RTN","IB20P385",29,0)
 I Y<1 D MES("*** Cannot find CATASTROPHICALLY DISABLED ***") Q
"RTN","IB20P385",30,0)
 S IBFDA(354.2,+Y_",",.05)=70 D FILE^DIE(,"IBFDA")
"RTN","IB20P385",31,0)
 D MES("     - CATASTROPHICALLY DISABLED entry updated")
"RTN","IB20P385",32,0)
 Q
"RTN","IB20P385",33,0)
 ;
"RTN","IB20P385",34,0)
KIDSVFA ; - entry for KIDS doing the VFA clean-up to know to output status bar
"RTN","IB20P385",35,0)
 N IBKIDS
"RTN","IB20P385",36,0)
 S IBKIDS=1
"RTN","IB20P385",37,0)
 ;
"RTN","IB20P385",38,0)
VFA ; - clean up since VFA is effective in the past
"RTN","IB20P385",39,0)
 N IBCT,IBDT,IBE,IBOK,IBUP,IBZ354,DFN,DA,DR,DIE,IBDATE,IBFDA
"RTN","IB20P385",40,0)
 ;
"RTN","IB20P385",41,0)
 D MES("--> Cleaning up Patient Exemptions started",1)
"RTN","IB20P385",42,0)
 ;
"RTN","IB20P385",43,0)
 S IBCT=0
"RTN","IB20P385",44,0)
 ;
"RTN","IB20P385",45,0)
 S IBE=$O(^IBE(354.2,"B","NO INCOME DATA",0))
"RTN","IB20P385",46,0)
 I 'IBE S IBA(1)="***Cannot find Exemption Reason NO INCOME DATA***",IBA(2)="---------- Post install aborded!!! ----------" D MES(.IBA) Q
"RTN","IB20P385",47,0)
 ;
"RTN","IB20P385",48,0)
 ; -- already running, if not setup xtmp
"RTN","IB20P385",49,0)
 I $D(^XTMP("IB20P385",0)) S IBA(1)="Post-install may have already run or may be running now",IBA(2)="Quiting this post-install..." D MES(.IBA) Q
"RTN","IB20P385",50,0)
 S ^XTMP("IB20P385",0)=$$FMADD^XLFDT(DT,30)_"^"_DT
"RTN","IB20P385",51,0)
 ;
"RTN","IB20P385",52,0)
 ; -- setup status bar every 5%
"RTN","IB20P385",53,0)
 S XPDIDTOT=$P(^IBA(354,0),"^",4),IBUP=$P(XPDIDTOT/20,".")
"RTN","IB20P385",54,0)
 ;
"RTN","IB20P385",55,0)
 ; -- go through 354 to find NO INCOME records since 1/1/13
"RTN","IB20P385",56,0)
 S DFN=+$G(^XTMP("IB20P385","DFN")) F  S DFN=$O(^IBA(354,DFN)) Q:'DFN  D
"RTN","IB20P385",57,0)
 . ;
"RTN","IB20P385",58,0)
 . ; -- update status bar
"RTN","IB20P385",59,0)
 . S IBCT=IBCT+1 I '(IBCT#IBUP) X $S(IBKIDS:"D UPDATE^XPDID(IBCT)",1:"W "".""")
"RTN","IB20P385",60,0)
 . ;
"RTN","IB20P385",61,0)
 . S IBZ354=^IBA(354,DFN,0)
"RTN","IB20P385",62,0)
 . ;
"RTN","IB20P385",63,0)
 . ; quit if not a NO INCOME record active after 1/1/13
"RTN","IB20P385",64,0)
 . I $P(IBZ354,"^",3)<3130101!($P(IBZ354,"^",5)'=IBE) D DFN(DFN) Q
"RTN","IB20P385",65,0)
 . ;
"RTN","IB20P385",66,0)
 . ; look at previously active records to see if they were VFA-OK
"RTN","IB20P385",67,0)
 . S IBDT=$$LST^IBARXEU0(DFN,$P(IBZ354,"^",3)),IBOK=0
"RTN","IB20P385",68,0)
 . F  S IBDT=$$LST^IBARXEU0(DFN,$$FMADD^XLFDT(+IBDT,-1)) S IBOK=$$VFAOK^IBARXEU(IBDT) Q:IBDT<3120101!(IBOK&($P(IBDT,"^",5)'=IBE))
"RTN","IB20P385",69,0)
 . I 'IBOK!($P(IBDT,"^",5)=IBE) D DFN(DFN) Q
"RTN","IB20P385",70,0)
 . ;
"RTN","IB20P385",71,0)
 . ; set 354 to OK values
"RTN","IB20P385",72,0)
 . D UP354(DFN,+IBDT,$P(IBDT,"^",4),$P(IBDT,"^",5))
"RTN","IB20P385",73,0)
 . ;
"RTN","IB20P385",74,0)
 . ; clean up 354.1 entries
"RTN","IB20P385",75,0)
 . S IBDATE=-IBDT F  S IBDATE=$O(^IBA(354.1,"AIVDT",1,DFN,IBDATE),-1) Q:'IBDATE  D
"RTN","IB20P385",76,0)
 .. S DA=$O(^IBA(354.1,"AIVDT",1,DFN,IBDATE,0))
"RTN","IB20P385",77,0)
 .. S DIE="^IBA(354.1,",DR=".1////0" D ^DIE
"RTN","IB20P385",78,0)
 . ;
"RTN","IB20P385",79,0)
 . ; cancel copay bills if exempt
"RTN","IB20P385",80,0)
 . I '$P(IBDT,"^",4) D DFN(DFN) Q
"RTN","IB20P385",81,0)
 . D CANCEL(DFN,IBDT)
"RTN","IB20P385",82,0)
 . ;
"RTN","IB20P385",83,0)
 . D DFN(DFN)
"RTN","IB20P385",84,0)
 ;
"RTN","IB20P385",85,0)
 D MES("--> Cleaning up Patient Exemptions completed",1)
"RTN","IB20P385",86,0)
 ;
"RTN","IB20P385",87,0)
 Q
"RTN","IB20P385",88,0)
CANCEL(DFN,IBXX) ; cancel charges from date of last active exemption
"RTN","IB20P385",89,0)
 N IBBDT,IBEDT,X,Y,IBDATE,IBFOUND,IBNN,IBPARNT,IBPARDT,IBPARNT1,IBLAST
"RTN","IB20P385",90,0)
 N IBCRES,IBND,IBDUZ,IBATYP,IBSEQNO,IBIL,IBUNIT,IBCHRG,IBN,IBFAC,DA,DIE
"RTN","IB20P385",91,0)
 N DR,IBYCHK,DLAYGO,IBSITE,IBNOW,IBAFY,ERR,IBWHER,IBARCAN
"RTN","IB20P385",92,0)
 ;
"RTN","IB20P385",93,0)
 S IBBDT=$S(IBXX<3130101:3130101,1:+IBXX)
"RTN","IB20P385",94,0)
 S IBEDT=DT
"RTN","IB20P385",95,0)
 ;
"RTN","IB20P385",96,0)
 ; - quit if there are no charges to cancel
"RTN","IB20P385",97,0)
 S X=$O(^IB("APTDT",DFN,(IBBDT-.01))) I 'X!(X>(IBEDT+.9)) G CANCELQ
"RTN","IB20P385",98,0)
 ;
"RTN","IB20P385",99,0)
 ; - cancel the charges in billing
"RTN","IB20P385",100,0)
 S Y=1 D ARPARM^IBAUTL I Y<0 G CANCELQ
"RTN","IB20P385",101,0)
 ;
"RTN","IB20P385",102,0)
 S IBDATE=IBBDT-.0001,IBFOUND=0
"RTN","IB20P385",103,0)
 F  S IBDATE=$O(^IB("APTDT",DFN,IBDATE)) Q:'IBDATE!((IBEDT+.9)<IBDATE)  D
"RTN","IB20P385",104,0)
 . S IBNN=0 F  S IBNN=$O(^IB("APTDT",DFN,IBDATE,IBNN)) Q:'IBNN  D BILL^IBARXEU3
"RTN","IB20P385",105,0)
 ;
"RTN","IB20P385",106,0)
 ; - cancel bills in AR, if at least one charge was cancelled
"RTN","IB20P385",107,0)
 I IBFOUND S IBARCAN=1 D ARCAN^IBARXEU4(DFN,$P(IBXX,"^",4),IBBDT,IBEDT)
"RTN","IB20P385",108,0)
 ;
"RTN","IB20P385",109,0)
CANCELQ Q
"RTN","IB20P385",110,0)
 ;
"RTN","IB20P385",111,0)
MES(X,T) ; - display message
"RTN","IB20P385",112,0)
 X $S($G(T):"D BMES^XPDUTL(.X)",1:"D MES^XPDUTL(.X)")
"RTN","IB20P385",113,0)
 K X
"RTN","IB20P385",114,0)
 Q
"RTN","IB20P385",115,0)
 ;
"RTN","IB20P385",116,0)
RESTART ; - unadvertised entry to restart process from last XTMP patient
"RTN","IB20P385",117,0)
 N IBKIDS
"RTN","IB20P385",118,0)
 S IBKIDS=0
"RTN","IB20P385",119,0)
 K ^XTMP("IB20P385",0)
"RTN","IB20P385",120,0)
 D VFA
"RTN","IB20P385",121,0)
 Q
"RTN","IB20P385",122,0)
 ;
"RTN","IB20P385",123,0)
DFN(DFN) ; saves DFN into XTMP
"RTN","IB20P385",124,0)
 S ^XTMP("IB20P385","DFN")=DFN
"RTN","IB20P385",125,0)
 Q
"RTN","IB20P385",126,0)
 ;
"RTN","IB20P385",127,0)
UP354(DA,IBDT,IBSTAT,IBEXREA) ; -- calling out separate to update 354
"RTN","IB20P385",128,0)
 N DIE,DR
"RTN","IB20P385",129,0)
 S DIE="^IBA(354,"
"RTN","IB20P385",130,0)
 S DR="[IB CURRENT STATUS]"
"RTN","IB20P385",131,0)
 D ^DIE
"RTN","IB20P385",132,0)
 Q
"RTN","IBAMTED1")
0^7^B22776911
"RTN","IBAMTED1",1,0)
IBAMTED1 ;ALB/AAS - MEANS TEST EVENT DRIVER - EXEMPTION PROCESSING ; 18-DEC-92
"RTN","IBAMTED1",2,0)
 ;;2.0;INTEGRATED BILLING;**15,112,153,385**;21-MAR-94;Build 35
"RTN","IBAMTED1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBAMTED1",4,0)
 ;
"RTN","IBAMTED1",5,0)
EN N IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER,IBEXERR,IBJOB,IBON
"RTN","IBAMTED1",6,0)
 N IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP,IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
"RTN","IBAMTED1",7,0)
 N DA,DR,DIC,DIE,I,J,X,Y,X1
"RTN","IBAMTED1",8,0)
 ;
"RTN","IBAMTED1",9,0)
 S IBON=$$ON^IBARXEU0 I IBON<1 G ENQ
"RTN","IBAMTED1",10,0)
 S IBJOB=12,IBWHER=13
"RTN","IBAMTED1",11,0)
 ;
"RTN","IBAMTED1",12,0)
 ; -- quit if nothing different (except completion date)
"RTN","IBAMTED1",13,0)
 Q:'$D(DGMTA)!('$D(DGMTP))
"RTN","IBAMTED1",14,0)
 I $P(DGMTA,"^",1,5)=$P(DGMTP,"^",1,5),$P(DGMTA,"^",10,20)=$P(DGMTP,"^",10,20) Q
"RTN","IBAMTED1",15,0)
 I DGMTA]"",DGMTP]"",DGMTACT="DEL" Q  ; IVM 'delete' transmission
"RTN","IBAMTED1",16,0)
 ;
"RTN","IBAMTED1",17,0)
 ; -- quit if invoked from ib=>mt=>ib
"RTN","IBAMTED1",18,0)
 Q:$D(IBEVT)
"RTN","IBAMTED1",19,0)
 ;
"RTN","IBAMTED1",20,0)
 ; -- quit if before start date
"RTN","IBAMTED1",21,0)
 I +DGMTA G ENQ:+$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
"RTN","IBAMTED1",22,0)
 I +DGMTP G ENQ:+$$PLUS^IBARXEU0(+DGMTP)<$$STDATE^IBARXEU
"RTN","IBAMTED1",23,0)
 ;
"RTN","IBAMTED1",24,0)
 ;
"RTN","IBAMTED1",25,0)
 I '$D(ZTQUEUED),$D(IBTALK) W !,"Determining Medication Co-Payment Exemption"
"RTN","IBAMTED1",26,0)
 ;
"RTN","IBAMTED1",27,0)
 ; -- if no patient add patient
"RTN","IBAMTED1",28,0)
 I '+$G(^IBA(354,DFN,0)) D ADDP^IBAUTL6 I $G(IBEXERR) G ENQ
"RTN","IBAMTED1",29,0)
 ;
"RTN","IBAMTED1",30,0)
 D AUTO I IBAUTO'="" G ENQ
"RTN","IBAMTED1",31,0)
 ;
"RTN","IBAMTED1",32,0)
 ; -- not auto exempt any more see if is more current auto status
"RTN","IBAMTED1",33,0)
 S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)=2,$P(X,"^",2)>+DGMTA S IBOLDAUT=$P(X,"^",2)
"RTN","IBAMTED1",34,0)
 ; -- if mean test is required or no longer required
"RTN","IBAMTED1",35,0)
 ;    or copay test is incomplete or no longer applicable
"RTN","IBAMTED1",36,0)
 ;    add exemption of no income data
"RTN","IBAMTED1",37,0)
 S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) D AEX G ENQ
"RTN","IBAMTED1",38,0)
 ;
"RTN","IBAMTED1",39,0)
 I "^ADD^DEL^EDT^ADJ^STA^CAT^COM^UPL^DUP^"[DGMTACT D @DGMTACT
"RTN","IBAMTED1",40,0)
 ;
"RTN","IBAMTED1",41,0)
ENQ ; -- exit copay exemption creation
"RTN","IBAMTED1",42,0)
 I $G(IBEXERR) D ^IBAERR
"RTN","IBAMTED1",43,0)
 I $D(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^"),"   ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
"RTN","IBAMTED1",44,0)
 Q
"RTN","IBAMTED1",45,0)
 ;
"RTN","IBAMTED1",46,0)
ADD ; -- adding a new test
"RTN","IBAMTED1",47,0)
 I DGMTACT="ADD" D AEX
"RTN","IBAMTED1",48,0)
 ;
"RTN","IBAMTED1",49,0)
ADDQ Q
"RTN","IBAMTED1",50,0)
 ;
"RTN","IBAMTED1",51,0)
AEX ; -- add exemption logic
"RTN","IBAMTED1",52,0)
 ;    DO NOT USER FOR AUTOMATICS
"RTN","IBAMTED1",53,0)
 ;
"RTN","IBAMTED1",54,0)
 S IBEXREA=""
"RTN","IBAMTED1",55,0)
 ;
"RTN","IBAMTED1",56,0)
 ; -- if means test required, no longer required,
"RTN","IBAMTED1",57,0)
 ;    or copay test incomplete or no longer applicable
"RTN","IBAMTED1",58,0)
 ;    set up no income data exemption if not automatic.
"RTN","IBAMTED1",59,0)
 ;
"RTN","IBAMTED1",60,0)
 S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) S IBEXREA=$O(^IBE(354.2,"ACODE",$S($P(DGMTA,"^",14):110,1:210),0))
"RTN","IBAMTED1",61,0)
 ;
"RTN","IBAMTED1",62,0)
 ;
"RTN","IBAMTED1",63,0)
 I $$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$$MTCOMP^IBARXEU5($$INCDT^IBARXEU1(DGMTA),DGMTA)
"RTN","IBAMTED1",64,0)
 I '$$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$P($$INCDT^IBARXEU1(DGMTA),"^",3)
"RTN","IBAMTED1",65,0)
 ;
"RTN","IBAMTED1",66,0)
 ; -- make sure more recent exemption than current test date is inactivetd
"RTN","IBAMTED1",67,0)
 D MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
"RTN","IBAMTED1",68,0)
 D ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$G(IBOLDAUT))
"RTN","IBAMTED1",69,0)
 Q
"RTN","IBAMTED1",70,0)
 ;
"RTN","IBAMTED1",71,0)
UPL ; -- uploading an IVM-verified means test
"RTN","IBAMTED1",72,0)
DUP ; -- deleting an IVM-verified means test
"RTN","IBAMTED1",73,0)
EDT ; -- editing an old means test
"RTN","IBAMTED1",74,0)
 ;    if data different attempt to add new test
"RTN","IBAMTED1",75,0)
 I DGMTA=DGMTP G EDITQ
"RTN","IBAMTED1",76,0)
 D AEX
"RTN","IBAMTED1",77,0)
EDITQ Q
"RTN","IBAMTED1",78,0)
 ;
"RTN","IBAMTED1",79,0)
DEL ; -- means test deleted
"RTN","IBAMTED1",80,0)
 ;    find exemption for date and inactivate
"RTN","IBAMTED1",81,0)
 ;    update current exemption status
"RTN","IBAMTED1",82,0)
 ;
"RTN","IBAMTED1",83,0)
 N IBFORCE,IBVFAOK
"RTN","IBAMTED1",84,0)
 Q:'$D(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
"RTN","IBAMTED1",85,0)
 S IBFORCE=+DGMTP ; force inactivate entries for deleted date
"RTN","IBAMTED1",86,0)
 ;
"RTN","IBAMTED1",87,0)
 S IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP),IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
"RTN","IBAMTED1",88,0)
 ;
"RTN","IBAMTED1",89,0)
 ; -- look up VFA status
"RTN","IBAMTED1",90,0)
 S IBVFAOK=$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBEXREA,"^",2)))
"RTN","IBAMTED1",91,0)
 ;
"RTN","IBAMTED1",92,0)
 ; -- cancel prior exemption with a no data exemption if last date older than 1 year, only if it is not VFA OK.
"RTN","IBAMTED1",93,0)
 I $$PLUS^IBARXEU0($P(IBEXREA,"^",2))<DT,'IBVFAOK D ADDEX^IBAUTL6(+$O(^IBE(354.2,"ACODE",210,0)),+DGMTP) G DELQ
"RTN","IBAMTED1",94,0)
 ;
"RTN","IBAMTED1",95,0)
 ; -- add correct exemption and update current status
"RTN","IBAMTED1",96,0)
 D ADDEX^IBAUTL6(+IBEXREA,+$P(IBEXREA,"^",2))
"RTN","IBAMTED1",97,0)
DELQ Q
"RTN","IBAMTED1",98,0)
 ;
"RTN","IBAMTED1",99,0)
COM ; -- complete a required means test
"RTN","IBAMTED1",100,0)
CAT ; -- category change
"RTN","IBAMTED1",101,0)
STA ; -- status change
"RTN","IBAMTED1",102,0)
ADJ ; -- means test adjudication
"RTN","IBAMTED1",103,0)
 ;
"RTN","IBAMTED1",104,0)
 S IBAX1=$$CODE(DGMTP),IBAX=$$CODE(DGMTA)
"RTN","IBAMTED1",105,0)
 ;
"RTN","IBAMTED1",106,0)
 I $$NETW^IBARXEU1,IBAX1="P",IBAX'="P" D  G ADJQ ;treat as an adjudication
"RTN","IBAMTED1",107,0)
 .I $P(DGMTA,"^",19)=1 S IBEXREA=$S(IBAX="C":140,IBAX="A":150,1:"") ; means test codes
"RTN","IBAMTED1",108,0)
 .I $P(DGMTA,"^",19)=2 S IBEXREA=$S(IBAX="N":140,IBAX="E":150,1:"") ; copay exemption test
"RTN","IBAMTED1",109,0)
 .S IBEXREA=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
"RTN","IBAMTED1",110,0)
 .Q:'$G(IBEXREA)
"RTN","IBAMTED1",111,0)
 .D ADDEX^IBAUTL6(IBEXREA,+DGMTA,1,1)
"RTN","IBAMTED1",112,0)
 .Q
"RTN","IBAMTED1",113,0)
 ;
"RTN","IBAMTED1",114,0)
 ;I $P(DGMTA,"^",19)=1,IBAX1="C",IBAX="A" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is a means test hardship
"RTN","IBAMTED1",115,0)
 ;
"RTN","IBAMTED1",116,0)
 I $P(DGMTA,"^",19)=2,IBAX1="N",IBAX="E" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is income test hardship
"RTN","IBAMTED1",117,0)
 ;
"RTN","IBAMTED1",118,0)
 D AEX
"RTN","IBAMTED1",119,0)
 ;
"RTN","IBAMTED1",120,0)
ADJQ Q
"RTN","IBAMTED1",121,0)
 ;
"RTN","IBAMTED1",122,0)
CODE(TEST) ; -- return means test status
"RTN","IBAMTED1",123,0)
 I '$G(TEST) S TEST=""
"RTN","IBAMTED1",124,0)
 Q $P($G(^DG(408.32,+$P(TEST,"^",3),0)),"^",2)
"RTN","IBAMTED1",125,0)
 ;
"RTN","IBAMTED1",126,0)
AUTO ; -- if auto status patient
"RTN","IBAMTED1",127,0)
 ;       add auto exemption if needed
"RTN","IBAMTED1",128,0)
 S IBDT=$S(+DGMTA:+DGMTA,+DGMTP:+DGMTP,1:"")
"RTN","IBAMTED1",129,0)
 S IBAUTO=$$AUTOST^IBARXEU1(DFN,IBDT) I IBAUTO'="" D  G AUTOQ
"RTN","IBAMTED1",130,0)
 .S X=$$RXST^IBARXEU(DFN,IBDT)
"RTN","IBAMTED1",131,0)
 .I X=""!($$PLUS^IBARXEU0($P(X,"^",5))<DT) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,DT) Q  ; add exemption if none or old
"RTN","IBAMTED1",132,0)
 .I $P(X,"^",3)'=$P($G(^IBE(354.2,+IBAUTO,0)),"^",5) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,IBDT) Q  ; if computes different add new exemption
"RTN","IBAMTED1",133,0)
 ;
"RTN","IBAMTED1",134,0)
AUTOQ Q
"RTN","IBAMTED2")
0^8^B4174484
"RTN","IBAMTED2",1,0)
IBAMTED2 ;ALB/GN - RX COPAY TEST EVENT DRIVER - Z06 EXEMPTION PROCESSING ; 6/5/04 2:32pm
"RTN","IBAMTED2",2,0)
 ;;2.0;INTEGRATED BILLING;**269,385**;21-MAR-94;Build 35
"RTN","IBAMTED2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBAMTED2",4,0)
 ;
"RTN","IBAMTED2",5,0)
 ;IB*2*269 add this new API to handle updating IVM converted RX Copay
"RTN","IBAMTED2",6,0)
 ;         Tests via Z06 transmissions.
"RTN","IBAMTED2",7,0)
 ;
"RTN","IBAMTED2",8,0)
 ;
"RTN","IBAMTED2",9,0)
EN N IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER
"RTN","IBAMTED2",10,0)
 N IBEXERR,IBJOB,IBON,IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP
"RTN","IBAMTED2",11,0)
 N IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW
"RTN","IBAMTED2",12,0)
 N IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
"RTN","IBAMTED2",13,0)
 N DA,DR,DIC,DIE,I,J,X,Y,X1
"RTN","IBAMTED2",14,0)
 ;
"RTN","IBAMTED2",15,0)
 ;
"RTN","IBAMTED2",16,0)
 ;check if add and/or delete of a Z06 was performed by ^EASPREC7
"RTN","IBAMTED2",17,0)
 I DGMTACT="UPL",+DGMTA,'$G(EASZ06D) D ADD
"RTN","IBAMTED2",18,0)
 I DGMTACT="DEL",+DGMTP,$G(EASZ06D) D DEL
"RTN","IBAMTED2",19,0)
 Q
"RTN","IBAMTED2",20,0)
 ;
"RTN","IBAMTED2",21,0)
ADD ;quit if before start date
"RTN","IBAMTED2",22,0)
 Q:+$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
"RTN","IBAMTED2",23,0)
 ;
"RTN","IBAMTED2",24,0)
 ;if no patient add patient
"RTN","IBAMTED2",25,0)
 I '+$G(^IBA(354,DFN,0)) D ADDP^IBAUTL6 I $G(IBEXERR) D ^IBAERR  Q
"RTN","IBAMTED2",26,0)
 ;
"RTN","IBAMTED2",27,0)
 ;see if last reason is auto type and save date, used by ADDEX tag
"RTN","IBAMTED2",28,0)
 N IB0 S IB0=$$LSTAC^IBARXEU0(DFN)
"RTN","IBAMTED2",29,0)
 I $L(+IB0)=2,$P(IB0,"^",2)>+DGMTA S IBOLDAUT=$P(IB0,"^",2)
"RTN","IBAMTED2",30,0)
 ;
"RTN","IBAMTED2",31,0)
 ;set IVM converted case to reason: Income>Threshold (Not Exempt)
"RTN","IBAMTED2",32,0)
 S IBEXREA=$O(^IBE(354.2,"ACODE",110,0))
"RTN","IBAMTED2",33,0)
 ;
"RTN","IBAMTED2",34,0)
 ;inactivate most recent exemption test
"RTN","IBAMTED2",35,0)
 D MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
"RTN","IBAMTED2",36,0)
 ;
"RTN","IBAMTED2",37,0)
 ;add new IVM converted test
"RTN","IBAMTED2",38,0)
 D ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$G(IBOLDAUT))
"RTN","IBAMTED2",39,0)
 ;
"RTN","IBAMTED2",40,0)
 Q
"RTN","IBAMTED2",41,0)
 ;
"RTN","IBAMTED2",42,0)
DEL ; Converted Copay test deleted.  Now inactivate that exemption for
"RTN","IBAMTED2",43,0)
 ; that date & update current exemption status for this date
"RTN","IBAMTED2",44,0)
 ;
"RTN","IBAMTED2",45,0)
 ;force inactivate entries for deleted date
"RTN","IBAMTED2",46,0)
 N IBFORCE
"RTN","IBAMTED2",47,0)
 Q:'$D(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
"RTN","IBAMTED2",48,0)
 S IBFORCE=+DGMTP
"RTN","IBAMTED2",49,0)
 ;
"RTN","IBAMTED2",50,0)
 ;test in DGMT(408.31) has been deleted at this point, now get
"RTN","IBAMTED2",51,0)
 ;the last test that remains on file in order to activate it
"RTN","IBAMTED2",52,0)
 S IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP)
"RTN","IBAMTED2",53,0)
 S IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
"RTN","IBAMTED2",54,0)
 ;
"RTN","IBAMTED2",55,0)
 ;if last date is older than 1 year, then cancel prior exemption
"RTN","IBAMTED2",56,0)
 ; --- only if test is also not VFA ok
"RTN","IBAMTED2",57,0)
 ;cancel prior exemption with a no exemption
"RTN","IBAMTED2",58,0)
 I $$PLUS^IBARXEU0($P(IBEXREA,"^",2))<DT,'$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBEXREA,"^",2))) D  Q
"RTN","IBAMTED2",59,0)
 . D ADDEX^IBAUTL6(+$O(^IBE(354.2,"ACODE",210,0)),+DGMTP)
"RTN","IBAMTED2",60,0)
 ;
"RTN","IBAMTED2",61,0)
 ;else, add correct exemption and update current status
"RTN","IBAMTED2",62,0)
 D ADDEX^IBAUTL6(+IBEXREA,+$P(IBEXREA,"^",2))
"RTN","IBAMTED2",63,0)
 Q
"RTN","IBARXEL")
0^2^B17084396
"RTN","IBARXEL",1,0)
IBARXEL ;ALB/CPM - RX COPAY EXEMPTION INCOME TEST REMINDERS ;22-MAR-95
"RTN","IBARXEL",2,0)
 ;;2.0;INTEGRATED BILLING;**34,139,206,217,385**;21-MAR-94;Build 35
"RTN","IBARXEL",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBARXEL",4,0)
 ;
"RTN","IBARXEL",5,0)
EN ; Entry point for the generation of income test reminder letters.
"RTN","IBARXEL",6,0)
 ; Invoked by the nightly IB Background job (routine IBAMTC).
"RTN","IBARXEL",7,0)
 ;
"RTN","IBARXEL",8,0)
 ; - check the job parameters
"RTN","IBARXEL",9,0)
 S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0)) I 'IBLET G ENQ
"RTN","IBARXEL",10,0)
 S IBLET0=$G(^IBE(354.6,IBLET,0))
"RTN","IBARXEL",11,0)
 S IBDEV=$P(IBLET0,"^",5) I IBDEV="" G ENQ
"RTN","IBARXEL",12,0)
 S IBREPR=$P(IBLET0,"^",7)
"RTN","IBARXEL",13,0)
 ;
"RTN","IBARXEL",14,0)
 ; - should the job run tonight?
"RTN","IBARXEL",15,0)
 D NOW^%DTC S IBDAT=%
"RTN","IBARXEL",16,0)
 S IBDAY=$$DOW^XLFDT(IBDAT\1,1)
"RTN","IBARXEL",17,0)
 I $E(IBDAT,8,17)>.17 S IBDAY=$S(IBDAY=6:0,1:IBDAY+1)
"RTN","IBARXEL",18,0)
 I $P(IBLET0,"^",6)'[IBDAY G ENQ
"RTN","IBARXEL",19,0)
 ;
"RTN","IBARXEL",20,0)
 ; - who needs a letter?
"RTN","IBARXEL",21,0)
 S IBSTART=$$FMADD^XLFDT(IBDAT\1,-366)
"RTN","IBARXEL",22,0)
 S IBEND=$$FMADD^XLFDT(IBDAT\1,-305)
"RTN","IBARXEL",23,0)
 ;
"RTN","IBARXEL",24,0)
 K ^TMP("IBEX",$J)
"RTN","IBARXEL",25,0)
 S IBD=IBSTART F  S IBD=$O(^IBA(354.1,"B",IBD)) Q:'IBD!(IBD>IBEND)  D
"RTN","IBARXEL",26,0)
 .S IBEX=0 F  S IBEX=$O(^IBA(354.1,"B",IBD,IBEX)) Q:'IBEX  D
"RTN","IBARXEL",27,0)
 ..S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
"RTN","IBARXEL",28,0)
 ..;
"RTN","IBARXEL",29,0)
 ..; - don't reprint letter unless requested
"RTN","IBARXEL",30,0)
 ..S IBLASTPR=$P(IBEXD,"^",16)
"RTN","IBARXEL",31,0)
 ..I IBREPR,IBLASTPR,IBLASTPR'=IBREPR Q
"RTN","IBARXEL",32,0)
 ..I 'IBREPR,IBLASTPR Q
"RTN","IBARXEL",33,0)
 ..;
"RTN","IBARXEL",34,0)
 ..Q:$P(IBEXD,"^",3)'=1  ;           not a copay exemption
"RTN","IBARXEL",35,0)
 ..Q:'$P(IBEXD,"^",10)  ;            exemption is not active
"RTN","IBARXEL",36,0)
 ..;
"RTN","IBARXEL",37,0)
 ..S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
"RTN","IBARXEL",38,0)
 ..I IBEXREA'=110,IBEXREA'=120 Q  ;  exemption is not based on income
"RTN","IBARXEL",39,0)
 ..;
"RTN","IBARXEL",40,0)
 ..; -- veteran income test excempt from expiration under VFA rules
"RTN","IBARXEL",41,0)
 ..Q:$$VFAOK^IBARXEU(IBEXD)
"RTN","IBARXEL",42,0)
 ..;
"RTN","IBARXEL",43,0)
 ..S DFN=+$P(IBEXD,"^",2)
"RTN","IBARXEL",44,0)
 ..Q:$$BIL^DGMTUB(DFN,IBD)  ; vet is cat c or pend. adj. & agreed to pay deductible
"RTN","IBARXEL",45,0)
 ..I $P(IBLET0,"^",8),$$DOM(DFN) Q  ;  vet is in a dom
"RTN","IBARXEL",46,0)
 ..Q:$G(^DPT(DFN,.35))  ;              vet is deceased
"RTN","IBARXEL",47,0)
 ..I +IBEXD'=$P($G(^IBA(354,DFN,0)),"^",3) Q  ;  exemption not current
"RTN","IBARXEL",48,0)
 ..Q:$D(^TMP("IBEX",$J,"V",DFN))  ;    vet already getting letter
"RTN","IBARXEL",49,0)
 ..;
"RTN","IBARXEL",50,0)
 ..; - sort letters by zip code
"RTN","IBARXEL",51,0)
 ..K VA,VAERR,VAPA D ADD^VADPT
"RTN","IBARXEL",52,0)
 ..S IBZIP=$P(VAPA($S($$CONFADD():18,1:11)),"^",2) S:IBZIP="" IBZIP="99999-9999"
"RTN","IBARXEL",53,0)
 ..S:'$P(IBZIP,"-",2) IBZIP=$E(IBZIP,1,5)_"-0000"
"RTN","IBARXEL",54,0)
 ..S ^TMP("IBEX",$J,"V",DFN)=""
"RTN","IBARXEL",55,0)
 ..S ^TMP("IBEX",$J,"L",IBZIP,IBEX)=+IBEXD_"^"_+$P(IBEXD,"^",4)_"^"_DFN
"RTN","IBARXEL",56,0)
 ;
"RTN","IBARXEL",57,0)
 ; - open a print device if necessary
"RTN","IBARXEL",58,0)
 I '$D(^TMP("IBEX",$J,"L")) G ENQ
"RTN","IBARXEL",59,0)
 S IOP=IBDEV D ^%ZIS I POP G ENQ
"RTN","IBARXEL",60,0)
 U IO
"RTN","IBARXEL",61,0)
 ;
"RTN","IBARXEL",62,0)
 ; - print the letters
"RTN","IBARXEL",63,0)
 S IBSCR="" F  S IBSCR=$O(^TMP("IBEX",$J,"L",IBSCR)) Q:IBSCR=""  D
"RTN","IBARXEL",64,0)
 .S IBEX=0 F  S IBEX=$O(^TMP("IBEX",$J,"L",IBSCR,IBEX)) Q:'IBEX  D PRINT
"RTN","IBARXEL",65,0)
 ;
"RTN","IBARXEL",66,0)
ENQ I $G(IBREPR),IBLET S DA=IBLET,DIE="^IBE(354.6,",DR=".07////@" D ^DIE K DA,DR,DIE
"RTN","IBARXEL",67,0)
 ;
"RTN","IBARXEL",68,0)
 D ^%ZISC
"RTN","IBARXEL",69,0)
 K ^TMP("IBEX",$J),DFN,VAPA,VA,VAERR,X
"RTN","IBARXEL",70,0)
 K IBD,IBEX,IBEXD,IBEXREA,IBDAT,IBDAY,IBDEV,IBZIP,IBLET0,IBREPR,IBQUIT
"RTN","IBARXEL",71,0)
 K IBEND,IBLET,IBSTART,IBSCR,IBEXPD,IBDATA,IBNAM,IBALIN,IBLASTPR
"RTN","IBARXEL",72,0)
 Q
"RTN","IBARXEL",73,0)
 ;
"RTN","IBARXEL",74,0)
 ;
"RTN","IBARXEL",75,0)
PRINT ; Print a reminder letter.
"RTN","IBARXEL",76,0)
 ;  Required variable input:
"RTN","IBARXEL",77,0)
 ;      IBEX  --  Pointer to exemption in file #354.1
"RTN","IBARXEL",78,0)
 ;     IBLET  --  Pointer to the reminder letter in file #354.6
"RTN","IBARXEL",79,0)
 ;
"RTN","IBARXEL",80,0)
 ; - set letter variables
"RTN","IBARXEL",81,0)
 S IBEXD=$G(^IBA(354.1,+IBEX,0))
"RTN","IBARXEL",82,0)
 S IBEXPD=$$DATE($$PLUS^IBARXEU0(+IBEXD))
"RTN","IBARXEL",83,0)
 ;S IBEXPD=$$DATE($$FMADD^XLFDT(+IBEXD,365))
"RTN","IBARXEL",84,0)
 S DFN=+$P(IBEXD,"^",2),IBQUIT=0
"RTN","IBARXEL",85,0)
 S IBDATA=$$PT^IBEFUNC(DFN),IBNAM=$P(IBDATA,"^")
"RTN","IBARXEL",86,0)
 S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
"RTN","IBARXEL",87,0)
 I IBALIN<10!(IBALIN>25) S IBALIN=15
"RTN","IBARXEL",88,0)
 ;
"RTN","IBARXEL",89,0)
 ; - print letter
"RTN","IBARXEL",90,0)
 D ONE^IBARXEPL
"RTN","IBARXEL",91,0)
 ;
"RTN","IBARXEL",92,0)
 ; - update the exemption
"RTN","IBARXEL",93,0)
 S DA=IBEX,DIE="^IBA(354.1,",DR=".16////"_DT D ^DIE K DA,DR,DIE
"RTN","IBARXEL",94,0)
 K IBEXD,TAB,IBCNTL,IB,IBCNT,IBX,VAPA,VA,VAERR
"RTN","IBARXEL",95,0)
 Q
"RTN","IBARXEL",96,0)
 ;
"RTN","IBARXEL",97,0)
 ;
"RTN","IBARXEL",98,0)
DATE(X) ; Format the exemption expiration date.
"RTN","IBARXEL",99,0)
 N A S A="January^February^March^April^May^June^July^August^September^October^November^December"
"RTN","IBARXEL",100,0)
 Q $P(A,"^",+$E(X,4,5))_" "_+$E(X,6,7)_", "_(1700+$E(X,1,3))
"RTN","IBARXEL",101,0)
 ;
"RTN","IBARXEL",102,0)
DOM(DFN) ; Is the veteran in a domiciliary?
"RTN","IBARXEL",103,0)
 ;  Input:  DFN  -  Pointer to the patient in file #2
"RTN","IBARXEL",104,0)
 ; Output:    0  -  Vet is not in a domiciliary
"RTN","IBARXEL",105,0)
 ;            1  -  Vet is in a domiciliary
"RTN","IBARXEL",106,0)
 ;
"RTN","IBARXEL",107,0)
 N VAIN,VA,VAERR
"RTN","IBARXEL",108,0)
 D INP^VADPT
"RTN","IBARXEL",109,0)
 Q $P($G(^DIC(42,+$G(VAIN(4)),0)),"^",3)="D"
"RTN","IBARXEL",110,0)
 ;
"RTN","IBARXEL",111,0)
CONFADD() ; Determine, does the patient have a Confidential Address.
"RTN","IBARXEL",112,0)
 ; Input: VAPA() local array (by ADD^VADPT)
"RTN","IBARXEL",113,0)
 I '$G(VAPA(12)) Q 0  ; The Conf Address is not active
"RTN","IBARXEL",114,0)
 I $P($G(VAPA(22,3)),U,3)'="Y" Q 0  ; The Conf Address is not valid for billing-related correspondence
"RTN","IBARXEL",115,0)
 Q 1
"RTN","IBARXEL1")
0^3^B15139470
"RTN","IBARXEL1",1,0)
IBARXEL1 ;ALB/CPM - RX COPAY EXEMPTION REMINDER REPRINT ;14-APR-95
"RTN","IBARXEL1",2,0)
 ;;2.0;INTEGRATED BILLING;**34,199,217,385**;21-MAR-94;Build 35
"RTN","IBARXEL1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBARXEL1",4,0)
 ;
"RTN","IBARXEL1",5,0)
REPR ; Reprint a single income test reminder letter.
"RTN","IBARXEL1",6,0)
 S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0))
"RTN","IBARXEL1",7,0)
 I 'IBLET W !!,"You do not have the Income Test Reminder letter defined!" G REPRQ
"RTN","IBARXEL1",8,0)
 ;
"RTN","IBARXEL1",9,0)
 S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQMZ",DIC("A")="Select BILLING PATIENT: "
"RTN","IBARXEL1",10,0)
 N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
"RTN","IBARXEL1",11,0)
 D ^DIC K DIC S DFN=+Y G:Y<0 REPRQ
"RTN","IBARXEL1",12,0)
 ;
"RTN","IBARXEL1",13,0)
 ; - find the most recent active exemption
"RTN","IBARXEL1",14,0)
 S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0))
"RTN","IBARXEL1",15,0)
 S IBEXD=$G(^IBA(354.1,IBEX,0))
"RTN","IBARXEL1",16,0)
 I 'IBEXD W !!,"This veteran has never had an active copayment exemption status!" G REPR
"RTN","IBARXEL1",17,0)
 ;
"RTN","IBARXEL1",18,0)
 I $G(^DPT(DFN,.35)) W !!,*7,"Please note that this veteran died on ",$$DAT1^IBOUTL(+^(.35)),"."
"RTN","IBARXEL1",19,0)
 ;
"RTN","IBARXEL1",20,0)
 ; - VFA exemption - print not allowed
"RTN","IBARXEL1",21,0)
 I $$VFAOK^IBARXEU(IBEXD) W !!,"This veteran's current exemption is based on a Means Test and a new test is not required." G REPR
"RTN","IBARXEL1",22,0)
 ;
"RTN","IBARXEL1",23,0)
 ; - display the veteran's current exemption status
"RTN","IBARXEL1",24,0)
 S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
"RTN","IBARXEL1",25,0)
 W !!,$TR($J("",80)," ","=")
"RTN","IBARXEL1",26,0)
 W !?10,"Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4)),"  (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
"RTN","IBARXEL1",27,0)
 W !?12,"Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
"RTN","IBARXEL1",28,0)
 ;
"RTN","IBARXEL1",29,0)
 ; - display the previous status if the veteran has not reported income
"RTN","IBARXEL1",30,0)
 I IBEXREA=210 D
"RTN","IBARXEL1",31,0)
 .S IBCHK=1
"RTN","IBARXEL1",32,0)
 .S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-IBEXD)),0))
"RTN","IBARXEL1",33,0)
 .S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
"RTN","IBARXEL1",34,0)
 .S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
"RTN","IBARXEL1",35,0)
 .W !!?4,"Prior Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4)),"  (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
"RTN","IBARXEL1",36,0)
 .W !?6,"Prior Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
"RTN","IBARXEL1",37,0)
 ;
"RTN","IBARXEL1",38,0)
 ; - if a letter has already been printed, display the print date
"RTN","IBARXEL1",39,0)
 I $P(IBEXD,"^",16) D
"RTN","IBARXEL1",40,0)
 .W !!?12,"Letter Printed: ",$$DAT1^IBOUTL($P(IBEXD,"^",16))
"RTN","IBARXEL1",41,0)
 .S X=$P($$LST^DGMTCOU1(DFN,$$FMADD^XLFDT(DT,60),3),"^",2)
"RTN","IBARXEL1",42,0)
 .W ?41,"Current Income Test Date: ",$S(X:$$DAT1^IBOUTL(X),1:"<none>")
"RTN","IBARXEL1",43,0)
 W !,$TR($J("",80)," ","=")
"RTN","IBARXEL1",44,0)
 ;
"RTN","IBARXEL1",45,0)
 ; - exemption must be based on income
"RTN","IBARXEL1",46,0)
 I IBEXREA'=110,IBEXREA'=120 W !!,"You may only generate a letter for an exemption based on income!",! K IBCHK G REPR
"RTN","IBARXEL1",47,0)
 ;
"RTN","IBARXEL1",48,0)
 I '$G(IBCHK),+IBEXD>$$FMADD^XLFDT(DT,-305) W !!,"Please note that this exemption is not due to expire for ",$$FMDIFF^XLFDT(+IBEXD+10000,DT)," days!"
"RTN","IBARXEL1",49,0)
 ;
"RTN","IBARXEL1",50,0)
 ; check for Cat C or Pending Adj. and has agreed to pay deductible
"RTN","IBARXEL1",51,0)
 I $$BIL^DGMTUB(DFN,DT) W !!,"**Please note that this veteran no longer requires a Means Test**"
"RTN","IBARXEL1",52,0)
 ;
"RTN","IBARXEL1",53,0)
 ; - okay to print letter?
"RTN","IBARXEL1",54,0)
 S DIR(0)="Y",DIR("A")="Okay to print the reminder letter",DIR("?")="To print the income test reminder letter, answer 'YES.'  Otherwise, answer 'NO.'"
"RTN","IBARXEL1",55,0)
 W ! D ^DIR K DIR,DIRUT,DTOUT,DUOUT,DIROUT I 'Y G REPRQ
"RTN","IBARXEL1",56,0)
 ;
"RTN","IBARXEL1",57,0)
 W !!,"*** Please note that the reminder letter prints in 80 columns. ***",!
"RTN","IBARXEL1",58,0)
 S %ZIS="QM" D ^%ZIS G:POP REPRQ
"RTN","IBARXEL1",59,0)
 I $D(IO("Q")) D  G REPRQ
"RTN","IBARXEL1",60,0)
 .S ZTRTN="DQ^IBARXEL1",ZTDESC="IB - PRINT INCOME TEST REMINDER LETTER"
"RTN","IBARXEL1",61,0)
 .F I="IBEX","IBLET" S ZTSAVE(I)=""
"RTN","IBARXEL1",62,0)
 .D ^%ZTLOAD K IO("Q") D HOME^%ZIS
"RTN","IBARXEL1",63,0)
 .W !!,$S($D(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
"RTN","IBARXEL1",64,0)
 .K ZTSK,IO("Q")
"RTN","IBARXEL1",65,0)
 ;
"RTN","IBARXEL1",66,0)
 U IO
"RTN","IBARXEL1",67,0)
 ;
"RTN","IBARXEL1",68,0)
DQ ; Queued entry point.
"RTN","IBARXEL1",69,0)
 D PRINT^IBARXEL
"RTN","IBARXEL1",70,0)
 I $D(ZTQUEUED) S ZTREQ="@" Q
"RTN","IBARXEL1",71,0)
 ;
"RTN","IBARXEL1",72,0)
REPRQ D ^%ZISC
"RTN","IBARXEL1",73,0)
 K DFN,IBLET,IBEX,IBEXD,IBEXREA,IBCHK,IBEXPD,IBQUIT,IBDATA,IBNAM,IBALIN
"RTN","IBARXEL1",74,0)
 Q
"RTN","IBARXEPL")
0^4^B29058648
"RTN","IBARXEPL",1,0)
IBARXEPL ;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93
"RTN","IBARXEPL",2,0)
 ;;2.0;INTEGRATED BILLING;**34,54,190,206,385**;21-MAR-94;Build 35
"RTN","IBARXEPL",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBARXEPL",4,0)
 ;
"RTN","IBARXEPL",5,0)
% I '$D(DT) D DT^DICRW
"RTN","IBARXEPL",6,0)
 I '$D(IOF) D HOME^%ZIS
"RTN","IBARXEPL",7,0)
 W @IOF,"Print Exemption letters to patients"
"RTN","IBARXEPL",8,0)
 K ^TMP("IBEX LIST",$J)
"RTN","IBARXEPL",9,0)
 S (IBTEMP,IBADDT,IBOK,IBQUIT)=""
"RTN","IBARXEPL",10,0)
 ;
"RTN","IBARXEPL",11,0)
 ; -- find template
"RTN","IBARXEPL",12,0)
 S IBTEMP=$O(^DIBT("B","IB EXEMPTION LETTER",0))
"RTN","IBARXEPL",13,0)
 ;
"RTN","IBARXEPL",14,0)
 ; -- use old template or build new one
"RTN","IBARXEPL",15,0)
 W !!!
"RTN","IBARXEPL",16,0)
 ;
"RTN","IBARXEPL",17,0)
 I IBTEMP D  G:IBQUIT END
"RTN","IBARXEPL",18,0)
 .S DIR(0)="Y",DIR("A")="Delete Results of Previous Search",DIR("B")="NO"
"RTN","IBARXEPL",19,0)
 .S DIR("?")="Enter 'Yes' if you would like to delete the results of a previous search, Enter 'No' if you want to keep the results (i.e. you may be reprinting letters from the same list)."
"RTN","IBARXEPL",20,0)
 .D ^DIR K DIR I $D(DIRUT) S IBQUIT=1
"RTN","IBARXEPL",21,0)
 .I Y=1 D DELT S IBTEMP=0
"RTN","IBARXEPL",22,0)
 .Q
"RTN","IBARXEPL",23,0)
 ;
"RTN","IBARXEPL",24,0)
 I 'IBTEMP D  G:IBQUIT END D:IBADD ADDT
"RTN","IBARXEPL",25,0)
 .S DIR(0)="Y",DIR("A")="Store results of Search in Template",DIR("B")="YES"
"RTN","IBARXEPL",26,0)
 .S DIR("?")="Enter 'Yes' if you would like the results of the search stored in a Sort Template named IB EXEMPTION LETTER.  Enter 'No' if you do not want the template created."
"RTN","IBARXEPL",27,0)
 .S DIR("?",1)="Creating the search template will allow you to",DIR("?",2)="print other lists from the patients you sent the letters to."
"RTN","IBARXEPL",28,0)
 .S DIR("?",3)=" "
"RTN","IBARXEPL",29,0)
 .D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 Q
"RTN","IBARXEPL",30,0)
 .S IBADD=Y
"RTN","IBARXEPL",31,0)
 .Q
"RTN","IBARXEPL",32,0)
 ;
"RTN","IBARXEPL",33,0)
 D PRINT
"RTN","IBARXEPL",34,0)
 ;
"RTN","IBARXEPL",35,0)
END I $D(ZTQUEUED) Q
"RTN","IBARXEPL",36,0)
 D ^%ZISC,KVAR^VADPT
"RTN","IBARXEPL",37,0)
 K C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP
"RTN","IBARXEPL",38,0)
 K IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN
"RTN","IBARXEPL",39,0)
 K BY,DHD,DIOEND,FLDS,FR,I,L,TO,VAPA,^TMP("IBEX LIST",$J)
"RTN","IBARXEPL",40,0)
 Q
"RTN","IBARXEPL",41,0)
 ;
"RTN","IBARXEPL",42,0)
ADDT ; -- create new template in ^dibt
"RTN","IBARXEPL",43,0)
 K DD,DO
"RTN","IBARXEPL",44,0)
 S DIC="^DIBT(",DIC(0)="L",X="IB EXEMPTION LETTER",DIC("DR")="2///NOW;4///354;7///NOW"
"RTN","IBARXEPL",45,0)
 D FILE^DICN S IBTEMP=+Y I +Y S IBADDT=1 W !!,"<<< Search Template IB EXEMPTION LETTER created!",!
"RTN","IBARXEPL",46,0)
 Q
"RTN","IBARXEPL",47,0)
 ;
"RTN","IBARXEPL",48,0)
DELT ; -- delete search template
"RTN","IBARXEPL",49,0)
 Q:$P($G(^DIBT(+IBTEMP,0)),"^",1)'="IB EXEMPTION LETTER"
"RTN","IBARXEPL",50,0)
 S DIK="^DIBT(",DA=IBTEMP D ^DIK K DIK,DA
"RTN","IBARXEPL",51,0)
 W !!,"<<< Search Template IB EXEMPTION LETTER deleted!",!
"RTN","IBARXEPL",52,0)
 S IBTEMP=""
"RTN","IBARXEPL",53,0)
 Q
"RTN","IBARXEPL",54,0)
 ;
"RTN","IBARXEPL",55,0)
SCR ; -- don't send letters to deceased patients, non-vets, vfa exempt
"RTN","IBARXEPL",56,0)
 ;    called by print template IB DO NOT USE
"RTN","IBARXEPL",57,0)
 S IBOK=0 N IBX
"RTN","IBARXEPL",58,0)
 I +$G(^DPT(D0,.35)) G SCRQ ; deceased
"RTN","IBARXEPL",59,0)
 I $P($G(^DPT(D0,"VET")),"^")="N" G SCRQ ; patient non-vet
"RTN","IBARXEPL",60,0)
 S IBX=$P($G(^IBE(354.2,+$P($G(^IBA(354,D0,0)),"^",5),0)),"^",5)
"RTN","IBARXEPL",61,0)
 I IBX=60 G SCRQ ;exemption is non-vet
"RTN","IBARXEPL",62,0)
 I IBX=10 G SCRQ ;sc>50
"RTN","IBARXEPL",63,0)
 S IBOK=1
"RTN","IBARXEPL",64,0)
SCRQ Q
"RTN","IBARXEPL",65,0)
 ;
"RTN","IBARXEPL",66,0)
PRINT ; -- run through list of letters to PRINT
"RTN","IBARXEPL",67,0)
 S X="IB NOW EXEMPT",DIC(0)="XZ",DIC="^IBE(354.6," D ^DIC S IBLET=+Y
"RTN","IBARXEPL",68,0)
 Q:IBLET<1
"RTN","IBARXEPL",69,0)
 ;
"RTN","IBARXEPL",70,0)
 S DIC="^IBA(354,",L=0,FLDS="[IB DO NOT USE]",BY="[IB EXEMPT PATIENTS]",(FR,TO)="?,?,?",DHD="@@"
"RTN","IBARXEPL",71,0)
 S DIOEND="D LET^IBARXEPL"
"RTN","IBARXEPL",72,0)
 D EN1^DIP
"RTN","IBARXEPL",73,0)
 Q
"RTN","IBARXEPL",74,0)
 ;
"RTN","IBARXEPL",75,0)
LET ; -- called by dioend, prints list from tmp array
"RTN","IBARXEPL",76,0)
 S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
"RTN","IBARXEPL",77,0)
 I IBALIN<10!(IBALIN>25) S IBALIN=15
"RTN","IBARXEPL",78,0)
 S IBNAM="" F  S IBNAM=$O(^TMP("IBEX LIST",$J,IBNAM)) Q:IBNAM=""!(IBQUIT)  S DFN=0 F  S DFN=$O(^TMP("IBEX LIST",$J,IBNAM,DFN)) Q:'DFN!(IBQUIT)  S IBDATA=^(DFN) D ONE
"RTN","IBARXEPL",79,0)
 D FINAL,END
"RTN","IBARXEPL",80,0)
 Q
"RTN","IBARXEPL",81,0)
 ;
"RTN","IBARXEPL",82,0)
ONE ; -- print one letter
"RTN","IBARXEPL",83,0)
 N IBCONF ; Confidential Address Flag
"RTN","IBARXEPL",84,0)
 S TAB=5
"RTN","IBARXEPL",85,0)
 I '$D(IOF) D HOME^%ZIS
"RTN","IBARXEPL",86,0)
 S IBCNTL=$G(IBCNTL)+1 I $E(IOST,1,2)="C-" W @IOF
"RTN","IBARXEPL",87,0)
 S IB=0
"RTN","IBARXEPL",88,0)
 ;
"RTN","IBARXEPL",89,0)
 ; -- print header
"RTN","IBARXEPL",90,0)
 S IBCNT=0
"RTN","IBARXEPL",91,0)
 F I=1:1:6 S IB=$O(^IBE(354.6,IBLET,2,IB)) Q:'IB  S X=$G(^(IB,0)) W !?(IOM-$L(X)+1/2),X S IBCNT=IBCNT+1
"RTN","IBARXEPL",92,0)
 W !?TAB S Y=DT D DT^DIQ S IBCNT=IBCNT+1
"RTN","IBARXEPL",93,0)
 F IBCNT=IBCNT:1:6 W ! S IBCNT=IBCNT+1
"RTN","IBARXEPL",94,0)
 W !?(IOM-28),"In Reply Refer To:" S IBCNT=IBCNT+1
"RTN","IBARXEPL",95,0)
 W !?(IOM-28),$E($P(IBDATA,"^")),$P($P(IBDATA,"^",2),"-",3),!
"RTN","IBARXEPL",96,0)
 S IBCNT=IBCNT+2
"RTN","IBARXEPL",97,0)
 ; don't print renewal date if they are VFA OK
"RTN","IBARXEPL",98,0)
 S IBX=$$RXST^IBARXEU(DFN,DT) I $P($G(^IBE(354.6,IBLET,0)),"^",3)'=2,$P(IBX,"^",3)=120 S Y=$$PLUS^IBARXEU0($P(IBX,"^",5)) I '$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBX,"^",5))) W ?(IOM-28),"Renewal Date: " D DT^DIQ
"RTN","IBARXEPL",99,0)
 ;
"RTN","IBARXEPL",100,0)
 ; -- print pt. name and address
"RTN","IBARXEPL",101,0)
 F IBCNT=IBCNT:1:(IBALIN-1) W !
"RTN","IBARXEPL",102,0)
 W !?TAB,$P(IBNAM,",",2)," ",$P(IBNAM,",") D ADD^VADPT S IBCNT=IBCNT+1
"RTN","IBARXEPL",103,0)
 S IBCONF=$$CONFADD^IBARXEL() ; Should we use Confidential Address?
"RTN","IBARXEPL",104,0)
 W !?TAB,VAPA($S(IBCONF:13,1:1)) S IBCNT=IBCNT+1
"RTN","IBARXEPL",105,0)
 I VAPA($S(IBCONF:14,1:2))'="" W !?TAB,VAPA($S(IBCONF:14,1:2)) I VAPA($S(IBCONF:15,1:3))'="" W ", ",VAPA($S(IBCONF:15,1:3)) S IBCNT=IBCNT+1
"RTN","IBARXEPL",106,0)
 W !?TAB,VAPA($S(IBCONF:16,1:4)),", ",$P($G(^DIC(5,+VAPA($S(IBCONF:17,1:5)),0)),"^",2),"  ",$S(IBCONF:$P(VAPA(18),"^",2),1:VAPA(6)) S IBCNT=IBCNT+1
"RTN","IBARXEPL",107,0)
 I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT
"RTN","IBARXEPL",108,0)
 ;
"RTN","IBARXEPL",109,0)
 ; -- print main body
"RTN","IBARXEPL",110,0)
 W !! S IBCNT=IBCNT+2
"RTN","IBARXEPL",111,0)
 K ^UTILITY($J,"W"),DIWR,DIWL,DIWF,DN S DIWL=1,DIWF="C80WN"
"RTN","IBARXEPL",112,0)
 S IB=0 F  S IB=$O(^IBE(354.6,IBLET,1,IB)) Q:IB=""  S X=$G(^(IB,0)) D ^DIWP S IBCNT=IBCNT+1 ; W !,X
"RTN","IBARXEPL",113,0)
 D ^DIWW K ^UTILITY($J,"W")
"RTN","IBARXEPL",114,0)
 I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT
"RTN","IBARXEPL",115,0)
 W:$E(IOST,1,2)'="C-" @IOF
"RTN","IBARXEPL",116,0)
 Q
"RTN","IBARXEPL",117,0)
 ;
"RTN","IBARXEPL",118,0)
FINAL ; -- Print last page
"RTN","IBARXEPL",119,0)
 W @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"
"RTN","IBARXEPL",120,0)
 W !!,?20,$G(IBCNTL)," LETTERS PRINTED"
"RTN","IBARXEPL",121,0)
 Q
"RTN","IBARXEU")
0^1^B23454054
"RTN","IBARXEU",1,0)
IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ;2-NOV-92
"RTN","IBARXEU",2,0)
 ;;2.0;INTEGRATED BILLING;**20,222,293,385**;21-MAR-94;Build 35
"RTN","IBARXEU",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBARXEU",4,0)
 ;
"RTN","IBARXEU",5,0)
 ;
"RTN","IBARXEU",6,0)
RXST(DFN,IBDT) ; -- Check rx income exemption status of patient
"RTN","IBARXEU",7,0)
 ;
"RTN","IBARXEU",8,0)
 ;  input = :  dfn  = patient file pointer
"RTN","IBARXEU",9,0)
 ;             ibdt = date to check for (optional) default is today
"RTN","IBARXEU",10,0)
 ;
"RTN","IBARXEU",11,0)
 ;  returns :  -1 if no data   ^text^reason code^reason text^date of test
"RTN","IBARXEU",12,0)
 ;              0 if non exempt
"RTN","IBARXEU",13,0)
 ;              1 if exempt
"RTN","IBARXEU",14,0)
 ;
"RTN","IBARXEU",15,0)
 N X,Y,Z,IBX,IBON
"RTN","IBARXEU",16,0)
 ;
"RTN","IBARXEU",17,0)
 S IBON=$$ON^IBARXEU0 I IBON<1 Q IBON
"RTN","IBARXEU",18,0)
 ;
"RTN","IBARXEU",19,0)
 S IBX=""
"RTN","IBARXEU",20,0)
 I '$G(IBDT) S IBDT=DT
"RTN","IBARXEU",21,0)
 I IBDT>DT S IBDT=DT ; no future dates
"RTN","IBARXEU",22,0)
 ;
"RTN","IBARXEU",23,0)
 ; -- date before legislations
"RTN","IBARXEU",24,0)
 I IBDT<$$STDATE S IBX="0^NON-EXEMPT^^Date is Prior to Legislation^" G RXSTQ ; nobody exempt prior to legislation
"RTN","IBARXEU",25,0)
 ;
"RTN","IBARXEU",26,0)
 ; -- if no data on patient quit
"RTN","IBARXEU",27,0)
 S X=$G(^IBA(354,DFN,0))
"RTN","IBARXEU",28,0)
 I X=""!('$D(^IBA(354.1,"AP",DFN))) S IBX="-1^UNKNOWN^^Medication Copayment Exemption status never determined" G RXSTQ ; no data return -1
"RTN","IBARXEU",29,0)
 ;
"RTN","IBARXEU",30,0)
 ; -- use current status if ibdt not less than current test and
"RTN","IBARXEU",31,0)
 ;    not greater than current test date +365
"RTN","IBARXEU",32,0)
 I IBDT'<$P(X,U,3),IBDT'>$$PLUS^IBARXEU0($P(X,U,3)) S IBX=$$IBX^IBARXEU0(DFN,IBDT) G RXSTQ
"RTN","IBARXEU",33,0)
 ;
"RTN","IBARXEU",34,0)
 ; -- if ibdt not less than current date but greater than
"RTN","IBARXEU",35,0)
 ;    current test +365 is into future
"RTN","IBARXEU",36,0)
 I IBDT'<$P(X,U,3),IBDT>$$PLUS^IBARXEU0($P(X,U,3)) D
"RTN","IBARXEU",37,0)
 .S Y=$$LST^IBARXEU0(DFN,IBDT)
"RTN","IBARXEU",38,0)
 .;
"RTN","IBARXEU",39,0)
 .; -- see if patient was SC>50, can't be updated so don't say previous
"RTN","IBARXEU",40,0)
 .;    also check to see if last is still ok under VFA rules
"RTN","IBARXEU",41,0)
 .I $L($$ACODE^IBARXEU0(Y))<3!($$VFAOK(Y)) S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3) Q
"RTN","IBARXEU",42,0)
 .;
"RTN","IBARXEU",43,0)
 .S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
"RTN","IBARXEU",44,0)
 ;
"RTN","IBARXEU",45,0)
 ; -- if ibdt less than current date need old exemption data
"RTN","IBARXEU",46,0)
 I IBDT<$P(X,U,3) D  G RXSTQ
"RTN","IBARXEU",47,0)
 .;
"RTN","IBARXEU",48,0)
 .; -- find status of prior test
"RTN","IBARXEU",49,0)
 .S Y=$$LST^IBARXEU0(DFN,IBDT)
"RTN","IBARXEU",50,0)
 .;
"RTN","IBARXEU",51,0)
 .; -- no previous data
"RTN","IBARXEU",52,0)
 .I Y="" D  Q
"RTN","IBARXEU",53,0)
 ..S IBX="-1^UNKNOWN^^No data for date requested."
"RTN","IBARXEU",54,0)
 ..Q
"RTN","IBARXEU",55,0)
 .;
"RTN","IBARXEU",56,0)
 .S Z=$G(^IBA(354,DFN,0)),Z=$P(Z,U,5)_U_$P(Z,U,3) ; get status & date
"RTN","IBARXEU",57,0)
 .;
"RTN","IBARXEU",58,0)
 .; -- if old exemption is current for copay date
"RTN","IBARXEU",59,0)
 .I IBDT'>$$PLUS^IBARXEU0(+Y) D  Q
"RTN","IBARXEU",60,0)
 ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ; exemption reason node
"RTN","IBARXEU",61,0)
 ..S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
"RTN","IBARXEU",62,0)
 ..Q
"RTN","IBARXEU",63,0)
 .;
"RTN","IBARXEU",64,0)
 .; -- if ibdt is greater than old exemption + 365
"RTN","IBARXEU",65,0)
 .;    report previous
"RTN","IBARXEU",66,0)
 .I IBDT>$$PLUS^IBARXEU0(+Y) D  Q
"RTN","IBARXEU",67,0)
 ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ;exemption reason node
"RTN","IBARXEU",68,0)
 ..;
"RTN","IBARXEU",69,0)
 ..; -- see if patient was SC>50, can't be updated so don't say previous
"RTN","IBARXEU",70,0)
 ..;    also check to see if last is still ok under VFA rules
"RTN","IBARXEU",71,0)
 ..I $L($$ACODE^IBARXEU0(Y))<3!($$VFAOK(Y)) S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3) Q
"RTN","IBARXEU",72,0)
 ..;
"RTN","IBARXEU",73,0)
 ..S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
"RTN","IBARXEU",74,0)
 ..Q
"RTN","IBARXEU",75,0)
 .Q
"RTN","IBARXEU",76,0)
 ;
"RTN","IBARXEU",77,0)
RXSTQ Q IBX
"RTN","IBARXEU",78,0)
 ;
"RTN","IBARXEU",79,0)
DISP(DFN,IBDT,NO,NULL) ; -- formats text to display 
"RTN","IBARXEU",80,0)
 ; -- input =  dfn
"RTN","IBARXEU",81,0)
 ;             ibdt = date to check for
"RTN","IBARXEU",82,0)
 ;             no   = number of lines to print (1, 2, or 3)
"RTN","IBARXEU",83,0)
 ;             null = if zero print unknown, if non-zero quit
"RTN","IBARXEU",84,0)
 ;
"RTN","IBARXEU",85,0)
 I '$G(IBDT) S IBDT=DT
"RTN","IBARXEU",86,0)
 I '$D(NULL) S NULL=1
"RTN","IBARXEU",87,0)
 I IBDT>DT S IBDT=DT ; no future dates
"RTN","IBARXEU",88,0)
 I '$G(NO) S NO=3
"RTN","IBARXEU",89,0)
 S X=$$RXST(DFN,IBDT)
"RTN","IBARXEU",90,0)
 S IBON=$$ON^IBARXEU0 I IBON<1 S X=IBON
"RTN","IBARXEU",91,0)
 I X<0&(NULL) G DISPQ
"RTN","IBARXEU",92,0)
 W !,"Medication Copayment Exemption Status: ",$P(X,U,2) G:NO<2 DISPQ
"RTN","IBARXEU",93,0)
 W !,$P(X,U,4) G:NO<3 DISPQ
"RTN","IBARXEU",94,0)
 I $P(X,U,5) W !,"Last Rx Copay Exemption date: " S Y=$P(X,U,5) D DT^DIQ
"RTN","IBARXEU",95,0)
DISPQ Q
"RTN","IBARXEU",96,0)
 ;
"RTN","IBARXEU",97,0)
STDATE() ; -- legislative start date for income exemption
"RTN","IBARXEU",98,0)
 Q 2921030
"RTN","IBARXEU",99,0)
 ;
"RTN","IBARXEU",100,0)
 ;
"RTN","IBARXEU",101,0)
ACTIVE(IBZ) ; -- SCREEN for active field of billing exemptions file
"RTN","IBARXEU",102,0)
 ;    only one entry per effective date can be active
"RTN","IBARXEU",103,0)
 ;
"RTN","IBARXEU",104,0)
 N IBX,IBY,T
"RTN","IBARXEU",105,0)
 S T=0
"RTN","IBARXEU",106,0)
 S IBZ=$S(IBZ=1:IBZ,$E(IBZ)="A":1,1:0)
"RTN","IBARXEU",107,0)
 I 'IBZ S T=1 G ACTIVEQ
"RTN","IBARXEU",108,0)
 S IBX=$G(^IBA(354.1,DA,0))
"RTN","IBARXEU",109,0)
 S IBY=$O(^IBA(354.1,"AIVDT",+$P(IBX,U,3),+$P(IBX,U,2),-$P(IBX,U),0))
"RTN","IBARXEU",110,0)
 I 'IBY!(IBY=DA) S T=1
"RTN","IBARXEU",111,0)
 W:$D(IBTALK) !!,"Another entry is already Active, You must inactivate it first",!!
"RTN","IBARXEU",112,0)
ACTIVEQ Q T
"RTN","IBARXEU",113,0)
 ;
"RTN","IBARXEU",114,0)
VFA() ; -- returns VFA (no longer asking for mt income info) start date
"RTN","IBARXEU",115,0)
 ;  less One year
"RTN","IBARXEU",116,0)
 ; ICR #431
"RTN","IBARXEU",117,0)
 N IBDT
"RTN","IBARXEU",118,0)
 S IBDT=$$GET1^DIQ(43,"1,",1205,"I")
"RTN","IBARXEU",119,0)
 S:IBDT IBDT=$$MINUS^IBARXEU0(IBDT)
"RTN","IBARXEU",120,0)
 Q IBDT
"RTN","IBARXEU",121,0)
 ;
"RTN","IBARXEU",122,0)
VFAOK(X) ; - under VFA (veterans financial assestment) rules, MT no
"RTN","IBARXEU",123,0)
 ; longer required if within one year of VFA start date, use last test.
"RTN","IBARXEU",124,0)
 ; Pass in the zeroth node of the 354.1 exemption.
"RTN","IBARXEU",125,0)
 ;   Output = OK under VFA rules or not (1 or 0)
"RTN","IBARXEU",126,0)
 ;
"RTN","IBARXEU",127,0)
 N IBACODE,IBLST
"RTN","IBARXEU",128,0)
 ;
"RTN","IBARXEU",129,0)
 ; -- is this test income related, if not then not OK
"RTN","IBARXEU",130,0)
 S IBACODE=$$ACODE^IBARXEU0(X)
"RTN","IBARXEU",131,0)
 I IBACODE<100,IBACODE>200 Q 0
"RTN","IBARXEU",132,0)
 ;
"RTN","IBARXEU",133,0)
 ; -- is the test MT related, if not then not OK, ICR# 423
"RTN","IBARXEU",134,0)
 S IBLST=$$LST^DGMTCOU1(+$P(X,"^",2),+X,1)
"RTN","IBARXEU",135,0)
 I 'IBLST!($P(IBLST,"^",2)'=+X) Q 0
"RTN","IBARXEU",136,0)
 ;
"RTN","IBARXEU",137,0)
 ; -- is the test within dates needed?
"RTN","IBARXEU",138,0)
 Q $S(X<$$VFA:0,1:1)
"RTN","IBARXEU",139,0)
 ;
"RTN","IBARXEU0")
0^5^B13703927
"RTN","IBARXEU0",1,0)
IBARXEU0 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92
"RTN","IBARXEU0",2,0)
 ;;2.0;INTEGRATED BILLING;**139,385**; 21-MAR-94;Build 35
"RTN","IBARXEU0",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBARXEU0",4,0)
 ;
"RTN","IBARXEU0",5,0)
 ;
"RTN","IBARXEU0",6,0)
RXEXMT(DFN,IBDT) ; -- Check income exemption status of patient
"RTN","IBARXEU0",7,0)
 ; -- Warning, this function may cause new entries to be created
"RTN","IBARXEU0",8,0)
 ;    when no data exists of new entry for current caledar year exists.
"RTN","IBARXEU0",9,0)
 ;
"RTN","IBARXEU0",10,0)
 ;  input = :  dfn  = patient file pointer
"RTN","IBARXEU0",11,0)
 ;             ibdt = date to check for
"RTN","IBARXEU0",12,0)
 ;  returns :
"RTN","IBARXEU0",13,0)
 ;              0 if not exempt
"RTN","IBARXEU0",14,0)
 ;              1 if exempt^text^reason code^reason^date of test
"RTN","IBARXEU0",15,0)
 ;
"RTN","IBARXEU0",16,0)
 ;*** START RT CLOCK
"RTN","IBARXEU0",17,0)
 ;S XRTN="ADD EXEMPTION",XRTL=$ZU(0) D T0^%ZOSV
"RTN","IBARXEU0",18,0)
 ;
"RTN","IBARXEU0",19,0)
 N X,Y,IBON,IBX,IBJOB,IBEXERR,IBWHER,DA,DR,DIC,DIE,IBOUT
"RTN","IBARXEU0",20,0)
 ;
"RTN","IBARXEU0",21,0)
 S IBON=$$ON I IBON<1 Q IBON
"RTN","IBARXEU0",22,0)
 ;
"RTN","IBARXEU0",23,0)
 S IBX="",IBJOB=14,IBEXERR="",IBOUT=0
"RTN","IBARXEU0",24,0)
 I '$G(IBDT) S IBDT=DT
"RTN","IBARXEU0",25,0)
 I IBDT>DT S IBDT=DT ; no future dates
"RTN","IBARXEU0",26,0)
 ;
"RTN","IBARXEU0",27,0)
 ; -- date before legislation
"RTN","IBARXEU0",28,0)
 I IBDT<$$STDATE^IBARXEU S IBX="0^NON-EXEMPT^^Date is prior to legislation^" G RXEXMTQ
"RTN","IBARXEU0",29,0)
 ;
"RTN","IBARXEU0",30,0)
 S X=$G(^IBA(354,DFN,0))
"RTN","IBARXEU0",31,0)
 ;
"RTN","IBARXEU0",32,0)
 ; -- if current patient, current request, get data and quit
"RTN","IBARXEU0",33,0)
 I IBDT'<$P(X,"^",3),IBDT'>$$PLUS($P(X,"^",3)),$P(X,"^",4)'="" S IBX=$$IBX(DFN,IBDT) G RXEXMTQ
"RTN","IBARXEU0",34,0)
 ;
"RTN","IBARXEU0",35,0)
 ; -- if no patient add one
"RTN","IBARXEU0",36,0)
 I '+X D ADDP^IBAUTL6 S X=$G(^IBA(354,DFN,0)) G:$G(IBEXERR) RXEXMTQ D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT) G RXEXMTQ
"RTN","IBARXEU0",37,0)
 ;
"RTN","IBARXEU0",38,0)
 ; -- if current exemption older than 365 days add new one
"RTN","IBARXEU0",39,0)
 I IBDT'<$P(X,"^",3),IBDT>$$PLUS($P(X,"^",3)) D  G RXEXMTQ
"RTN","IBARXEU0",40,0)
 . ;
"RTN","IBARXEU0",41,0)
 . ; -- is the exemption still ok under VFA rules
"RTN","IBARXEU0",42,0)
 . I $$VFAOK^IBARXEU($$LST(DFN,IBDT)) S IBX=$$IBX(DFN,IBDT) Q
"RTN","IBARXEU0",43,0)
 . ;
"RTN","IBARXEU0",44,0)
 . ; add a new one
"RTN","IBARXEU0",45,0)
 . D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT)
"RTN","IBARXEU0",46,0)
 ;
"RTN","IBARXEU0",47,0)
 ; -- if ibdt less than current date need old exemption data
"RTN","IBARXEU0",48,0)
 I IBDT<$P(X,"^",3) D
"RTN","IBARXEU0",49,0)
 .;
"RTN","IBARXEU0",50,0)
 .;find status of prior year
"RTN","IBARXEU0",51,0)
 .S Y=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.0001))),0)),0))
"RTN","IBARXEU0",52,0)
 .; -- no data
"RTN","IBARXEU0",53,0)
 .I Y="" D AEX(DFN,IBDT)
"RTN","IBARXEU0",54,0)
 .;
"RTN","IBARXEU0",55,0)
 .; -- old data too old need to insert exemption
"RTN","IBARXEU0",56,0)
 .I IBDT>$$PLUS(+Y) D  Q:IBOUT
"RTN","IBARXEU0",57,0)
 .. ;
"RTN","IBARXEU0",58,0)
 .. ; -- is old exemption still good under VFA
"RTN","IBARXEU0",59,0)
 .. I $$VFAOK^IBARXEU(Y) S IBX=$$IBX(DFN,IBDT),IBOUT=1 Q
"RTN","IBARXEU0",60,0)
 .. ;
"RTN","IBARXEU0",61,0)
 .. ; -- need to insert exemption
"RTN","IBARXEU0",62,0)
 .. D AEX(DFN,IBDT)
"RTN","IBARXEU0",63,0)
 .;
"RTN","IBARXEU0",64,0)
 .; -- if old exemption is current for this copay date
"RTN","IBARXEU0",65,0)
 .S IBX=$$IBXOLD(DFN,IBDT)
"RTN","IBARXEU0",66,0)
 .Q
"RTN","IBARXEU0",67,0)
 ;
"RTN","IBARXEU0",68,0)
 ;*** STOP RT CLOCK
"RTN","IBARXEU0",69,0)
RXEXMTQ ;I $D(XRT0),$D(XRTN) D T1^%ZOSV
"RTN","IBARXEU0",70,0)
 ;
"RTN","IBARXEU0",71,0)
 Q IBX
"RTN","IBARXEU0",72,0)
 ;
"RTN","IBARXEU0",73,0)
 ;
"RTN","IBARXEU0",74,0)
AEX(DFN,IBDT) ; -- add exemption
"RTN","IBARXEU0",75,0)
 ; set exemption effective date to means test dates
"RTN","IBARXEU0",76,0)
 ;
"RTN","IBARXEU0",77,0)
 N X
"RTN","IBARXEU0",78,0)
 S X=$$STATUS^IBARXEU1(DFN,IBDT)
"RTN","IBARXEU0",79,0)
 D ADDEX^IBAUTL6(+X,$P(X,"^",2))
"RTN","IBARXEU0",80,0)
 Q
"RTN","IBARXEU0",81,0)
 ;
"RTN","IBARXEU0",82,0)
IBX(DFN,IBDT) ; -- format output from current status
"RTN","IBARXEU0",83,0)
 N X,Y
"RTN","IBARXEU0",84,0)
 S X=$G(^IBA(354,DFN,0)),Y=$$LST(DFN,IBDT)
"RTN","IBARXEU0",85,0)
 Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
"RTN","IBARXEU0",86,0)
 ;
"RTN","IBARXEU0",87,0)
IBXOLD(DFN,IBDT) ; -- format output from old exemption
"RTN","IBARXEU0",88,0)
 N X,Y
"RTN","IBARXEU0",89,0)
 S Y=$$LST(DFN,IBDT)
"RTN","IBARXEU0",90,0)
 S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ; exemption reason node
"RTN","IBARXEU0",91,0)
 Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
"RTN","IBARXEU0",92,0)
 ;
"RTN","IBARXEU0",93,0)
 ;
"RTN","IBARXEU0",94,0)
ON() ; -- is copay exemption testing on
"RTN","IBARXEU0",95,0)
 ;    output 1 = exemption testing is active
"RTN","IBARXEU0",96,0)
 ;           0 = exemption testing is inactive (everybody non-exempt)
"RTN","IBARXEU0",97,0)
 ;          -1 = copay is off (everybody exempt)
"RTN","IBARXEU0",98,0)
 Q 1
"RTN","IBARXEU0",99,0)
 ;Q "0^NON-EXEMPT^0^Medication Copay Exemption Testing turned off^"_DT
"RTN","IBARXEU0",100,0)
 ;Q "-1^EXEMPT^0^Medication Copayment has been turned off^"_DT
"RTN","IBARXEU0",101,0)
 ;
"RTN","IBARXEU0",102,0)
PLUS(X1) ; -- computes plus 1 year (into future)
"RTN","IBARXEU0",103,0)
 ; if x1=2920930 + 1 year = +10000 = 2930930
"RTN","IBARXEU0",104,0)
 I $E(X1,4,7)="0229" Q X1+10072  ;makes the anniversary date March 1
"RTN","IBARXEU0",105,0)
 Q X1+10000
"RTN","IBARXEU0",106,0)
 ;
"RTN","IBARXEU0",107,0)
MINUS(X1) ; -- computes minus 1 year (into past)
"RTN","IBARXEU0",108,0)
 Q X1-10000
"RTN","IBARXEU0",109,0)
 ;
"RTN","IBARXEU0",110,0)
ACODE(Y) ; -- return lookup code of reason, input zeroth node of exemption
"RTN","IBARXEU0",111,0)
 Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",5)
"RTN","IBARXEU0",112,0)
 ;
"RTN","IBARXEU0",113,0)
REASON(Y) ; -- return reason description, input zeroth node of exemption
"RTN","IBARXEU0",114,0)
 Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",2)
"RTN","IBARXEU0",115,0)
 ;
"RTN","IBARXEU0",116,0)
TEXT(X) ; -- convert 0 or 1 to text
"RTN","IBARXEU0",117,0)
 Q $S(X=1:"EXEMPT",X=0:"NON-EXEMPT",1:"UNKNOWN")
"RTN","IBARXEU0",118,0)
 ;
"RTN","IBARXEU0",119,0)
LST(DFN,IBDT) ; -- returns last exemption entry before date x
"RTN","IBARXEU0",120,0)
 ;
"RTN","IBARXEU0",121,0)
 ; -- returns zeroth node of last test before date
"RTN","IBARXEU0",122,0)
 ;
"RTN","IBARXEU0",123,0)
 I '$G(IBDT) S IBDT=DT
"RTN","IBARXEU0",124,0)
 Q $G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.00001))),0)),0))
"RTN","IBARXEU0",125,0)
 ;
"RTN","IBARXEU0",126,0)
LSTAC(DFN) ; -- computes last reason code and date for a patient
"RTN","IBARXEU0",127,0)
 ; -- returns exemption reason ^ exemption date
"RTN","IBARXEU0",128,0)
 N X1
"RTN","IBARXEU0",129,0)
 S X1=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0)),0))
"RTN","IBARXEU0",130,0)
 Q $P($G(^IBE(354.2,+$P(X1,"^",5),0)),"^",5)_"^"_+X1
"RTN","IBARXEU1")
0^6^B18924658
"RTN","IBARXEU1",1,0)
IBARXEU1 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 3/27/07 3:10pm
"RTN","IBARXEU1",2,0)
 ;;2.0;INTEGRATED BILLING;**26,112,74,275,367,449,385**;21-MAR-94;Build 35
"RTN","IBARXEU1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBARXEU1",4,0)
 ;
"RTN","IBARXEU1",5,0)
STATUS(DFN,IBDT) ; -- Determine medication copayment exemption status
"RTN","IBARXEU1",6,0)
 ; -- requests data from MAS
"RTN","IBARXEU1",7,0)
 ;
"RTN","IBARXEU1",8,0)
 ;    returns :        = exemption reason (pointer to 354.2) ^ date
"RTN","IBARXEU1",9,0)
 ;
"RTN","IBARXEU1",10,0)
 N X,Y
"RTN","IBARXEU1",11,0)
 I $G(IBDT)="" S IBDT=DT
"RTN","IBARXEU1",12,0)
 S X=$$AUTOST(DFN,IBDT)
"RTN","IBARXEU1",13,0)
 I X'="" G STATUSQ
"RTN","IBARXEU1",14,0)
 S X=$$INCST(DFN,IBDT)
"RTN","IBARXEU1",15,0)
STATUSQ Q X
"RTN","IBARXEU1",16,0)
 ;
"RTN","IBARXEU1",17,0)
AUTOST(DFN,IBDT) ; -- Determine automatically exempt patients.
"RTN","IBARXEU1",18,0)
 ;    input :     dfn  =  patient file pointer
"RTN","IBARXEU1",19,0)
 ;               ibdt  =  internal form of effective date
"RTN","IBARXEU1",20,0)
 ;
"RTN","IBARXEU1",21,0)
 ;    returns :        =  exemption reason (pointer to 354.2) ^ date
"RTN","IBARXEU1",22,0)
 ;                        null if no autostatus
"RTN","IBARXEU1",23,0)
 ;
"RTN","IBARXEU1",24,0)
 N IBEXREA,IBEXMT,I
"RTN","IBARXEU1",25,0)
 S (IBEXREA,IBEXMT)=""
"RTN","IBARXEU1",26,0)
 I $G(IBDT)="" S IBDT=DT
"RTN","IBARXEU1",27,0)
 ;
"RTN","IBARXEU1",28,0)
 ; -- ask mas if in receipt of pension/a&a/hb, etc.
"RTN","IBARXEU1",29,0)
 ;    the automatic determinations
"RTN","IBARXEU1",30,0)
 ;    returns:
"RTN","IBARXEU1",31,0)
 ; sc>50%^rec a&a^rec hb^rec pen^n/a^non-vet^^POW^Unempl.^cd
"RTN","IBARXEU1",32,0)
 ;   1       1      1       1           1      1    1     1
"RTN","IBARXEU1",33,0)
 ;    pieces =1 if true
"RTN","IBARXEU1",34,0)
 S IBEXMT=$$AUTOINFO^DGMTCOU1(DFN) I IBEXMT="" G AUTOSTQ
"RTN","IBARXEU1",35,0)
 I IBEXMT[1 F I=1,2,3,4,6,8,9,10 I $P(IBEXMT,"^",I)=1 S IBEXREA=I*10 Q  ;lookup code is piece position time 10
"RTN","IBARXEU1",36,0)
 ;
"RTN","IBARXEU1",37,0)
 ; -- need to move CD patinet's to 70 which is ignored by IB, used to
"RTN","IBARXEU1",38,0)
 ;    keep other stuff working, auto-exempt stuff relies on a 2 digit
"RTN","IBARXEU1",39,0)
 ;    code to work properly
"RTN","IBARXEU1",40,0)
 I IBEXREA=100 S IBEXREA=70 ;not used above
"RTN","IBARXEU1",41,0)
 ;
"RTN","IBARXEU1",42,0)
AUTOSTQ I IBEXREA="" Q IBEXREA
"RTN","IBARXEU1",43,0)
 Q $O(^IBE(354.2,"ACODE",+IBEXREA,0))_"^"_IBDT
"RTN","IBARXEU1",44,0)
 ;
"RTN","IBARXEU1",45,0)
 ;
"RTN","IBARXEU1",46,0)
INCST(DFN,IBDT) ; -- return medication copayment exemption reason/date
"RTN","IBARXEU1",47,0)
 ; -- ask mas for income data
"RTN","IBARXEU1",48,0)
 ;
"RTN","IBARXEU1",49,0)
 ;    returns :  = exemption reason (pointer to 354.2) ^ date
"RTN","IBARXEU1",50,0)
 ;
"RTN","IBARXEU1",51,0)
 N IBDATA,X,DGMT,CLN,CONV
"RTN","IBARXEU1",52,0)
 S IBDATA=$G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,IBDT,3),0)) ;get any test
"RTN","IBARXEU1",53,0)
 ;
"RTN","IBARXEU1",54,0)
 ; -- is the mt too old even under VFA rules - no data
"RTN","IBARXEU1",55,0)
 I $$PLUS^IBARXEU0(+IBDATA)<IBDT,'$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,+IBDATA)) S X=$O(^IBE(354.2,"ACODE",210,0))_"^"_IBDT G INCSTQ
"RTN","IBARXEU1",56,0)
 ;
"RTN","IBARXEU1",57,0)
 I $P(IBDATA,U,23)=2 D  G:CONV INCSTQ ;skip Edb conv. tests
"RTN","IBARXEU1",58,0)
 .;Loop through the MT comments, Check for EDB converted test
"RTN","IBARXEU1",59,0)
 .;No comments to check
"RTN","IBARXEU1",60,0)
 .S (CLN,CONV)=0,DGMT=$$LST^DGMTCOU1(DFN,IBDT,3)
"RTN","IBARXEU1",61,0)
 .F  S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV)  D
"RTN","IBARXEU1",62,0)
 ..;If most recent test is a converted test use current info from IBA(354
"RTN","IBARXEU1",63,0)
 ..I $G(^DGMT(408.31,+DGMT,"C",CLN,0))["Z06 MT via Edb" S CONV=1,X=$P($G(^IBA(354,DFN,0)),"^",5)_"^"_$P($G(^IBA(354,DFN,0)),"^",3)
"RTN","IBARXEU1",64,0)
 ;
"RTN","IBARXEU1",65,0)
 I $$NETW S X=$$MTCOMP^IBARXEU5($$INCDT(IBDATA),IBDATA)
"RTN","IBARXEU1",66,0)
 I '$$NETW S X=$$INCDT(IBDATA),X=$P(X,"^",3)_"^"_$P(X,"^",2)
"RTN","IBARXEU1",67,0)
INCSTQ Q X
"RTN","IBARXEU1",68,0)
 ;
"RTN","IBARXEU1",69,0)
INCDT(IBDATA) ; -- calcualtes copay exemption status based on income
"RTN","IBARXEU1",70,0)
 ; and net worth
"RTN","IBARXEU1",71,0)
 ;    input  := zeroth node from 408.31
"RTN","IBARXEU1",72,0)
 ;    output := 1 = exempt    ^date of test^ exemption reason 
"RTN","IBARXEU1",73,0)
 ;              2 = non-exempt^...
"RTN","IBARXEU1",74,0)
 ;              3 = pending adjudication (if active)^...
"RTN","IBARXEU1",75,0)
 ;
"RTN","IBARXEU1",76,0)
 N X,IBDT,IBINCOM,IBEXREA,IBDEPEN,IBNETW,IBTABLE,IBLEVEL,IBTHRES
"RTN","IBARXEU1",77,0)
 I '$D(DFN) N DFN S DFN=$P(IBDATA,"^",2)
"RTN","IBARXEU1",78,0)
 S IBEXREA=""
"RTN","IBARXEU1",79,0)
 ;
"RTN","IBARXEU1",80,0)
 ; -- if test incomplete, no longer required, no longer applicable, or
"RTN","IBARXEU1",81,0)
 ;    required set to no income data 
"RTN","IBARXEU1",82,0)
 ;    autoexempt test should be done first before getting to here
"RTN","IBARXEU1",83,0)
 S X=$P(IBDATA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(IBDATA,"^",14)) S IBEXREA=$S($P(IBDATA,"^",14):110,1:210) G NO
"RTN","IBARXEU1",84,0)
 ;
"RTN","IBARXEU1",85,0)
 S IBDT=+IBDATA
"RTN","IBARXEU1",86,0)
 S IBINCOM=$P(IBDATA,"^",4)-$P(IBDATA,"^",15) I IBINCOM<0 S IBINCOM=0
"RTN","IBARXEU1",87,0)
 S IBDEPEN=$P(IBDATA,"^",18),IBNETW=$P(IBDATA,"^",5)
"RTN","IBARXEU1",88,0)
 ;
"RTN","IBARXEU1",89,0)
 ; -- get A&A income level
"RTN","IBARXEU1",90,0)
 ;S IBLEVEL=$$THRES(IBDT,2,IBDEPEN)
"RTN","IBARXEU1",91,0)
 S IBLEVEL=$$THRES(IBDT,$S($E(IBDT,1,5)'<29612:1,1:2),IBDEPEN)
"RTN","IBARXEU1",92,0)
 I $P(IBLEVEL,"^",3) S IBPRIOR=$P(IBLEVEL,"^",3)
"RTN","IBARXEU1",93,0)
 ;
"RTN","IBARXEU1",94,0)
 S IBEXREA=120 ; low income
"RTN","IBARXEU1",95,0)
 I IBINCOM>+IBLEVEL S IBEXREA=110 G NO ;high income not exempt
"RTN","IBARXEU1",96,0)
 ;
"RTN","IBARXEU1",97,0)
 I '$$NETW G NO
"RTN","IBARXEU1",98,0)
 ;
"RTN","IBARXEU1",99,0)
 ; -- get networth threshold amount
"RTN","IBARXEU1",100,0)
 S IBTHRES=+$$THRES(IBDT,4,0)
"RTN","IBARXEU1",101,0)
 ; -- low income check for net worth
"RTN","IBARXEU1",102,0)
 S IBEXREA=$S((IBINCOM+IBNETW)>IBTHRES:130,1:120)
"RTN","IBARXEU1",103,0)
 ;
"RTN","IBARXEU1",104,0)
NO ; -- not enough information
"RTN","IBARXEU1",105,0)
 I IBEXREA="" S IBEXREA=210
"RTN","IBARXEU1",106,0)
 ;
"RTN","IBARXEU1",107,0)
 I $$NETW S Y=$S(IBEXREA=110:2,IBEXREA=120:1,IBEXREA=130:3,1:2)
"RTN","IBARXEU1",108,0)
 I '$$NETW S Y=$S(IBEXREA=120:1,1:2)
"RTN","IBARXEU1",109,0)
 ;
"RTN","IBARXEU1",110,0)
INCDTQ Q Y_"^"_+IBDATA_"^"_$O(^IBE(354.2,"ACODE",+IBEXREA,0))
"RTN","IBARXEU1",111,0)
 ;
"RTN","IBARXEU1",112,0)
THRES(DATE,TYPE,DEPEND) ; -- return threshold amount 
"RTN","IBARXEU1",113,0)
 ;
"RTN","IBARXEU1",114,0)
 ; -- if date is less than 12/1/92 will use 12/1 92 rates
"RTN","IBARXEU1",115,0)
 ;     date =: fileman format of effective date
"RTN","IBARXEU1",116,0)
 ;     type =: 2= pension plus A&A   1992 thru 1995
"RTN","IBARXEU1",117,0)
 ;     type =: 1= basic pension 1996 to present
"RTN","IBARXEU1",118,0)
 ;     depend =: number of dependents
"RTN","IBARXEU1",119,0)
 ;
"RTN","IBARXEU1",120,0)
 ; -- returns rate^effective date^prior year
"RTN","IBARXEU1",121,0)
 ;
"RTN","IBARXEU1",122,0)
 I DATE<2921201 S DATE=2921201 ; use threshold rates from 12/1/92
"RTN","IBARXEU1",123,0)
 N IBTABLE,IBLEVEL,IBPRIOR
"RTN","IBARXEU1",124,0)
 S IBLEVEL=""
"RTN","IBARXEU1",125,0)
 ; -- get entry to determine income amounts
"RTN","IBARXEU1",126,0)
 S IBTABLE=$G(^IBE(354.3,+$O(^(+$O(^IBE(354.3,"AIVDT",TYPE,-(DATE+.000001))),0)),0))
"RTN","IBARXEU1",127,0)
 G:IBTABLE="" THRESQ
"RTN","IBARXEU1",128,0)
 I TYPE=4 S DEPEND=0
"RTN","IBARXEU1",129,0)
 ;
"RTN","IBARXEU1",130,0)
 ; --see if rate is for prior year
"RTN","IBARXEU1",131,0)
 S IBPRIOR="" I $$PLUS^IBARXEU0(+IBTABLE)<DATE S IBPRIOR=+IBTABLE
"RTN","IBARXEU1",132,0)
 ;
"RTN","IBARXEU1",133,0)
 ; -- rates begin in piece 3 for veteran alone, piece 4 for 1 dependent..
"RTN","IBARXEU1",134,0)
 S IBLEVEL=$S(DEPEND<9:$P(IBTABLE,"^",DEPEND+3),1:"")
"RTN","IBARXEU1",135,0)
 I IBLEVEL="" S IBLEVEL=$P(IBTABLE,"^",4)+((DEPEND-1)*$P(IBTABLE,"^",12))
"RTN","IBARXEU1",136,0)
THRESQ Q IBLEVEL_"^"_+IBTABLE_"^"_IBPRIOR
"RTN","IBARXEU1",137,0)
 ;
"RTN","IBARXEU1",138,0)
NETW() ; -- use networth in determining copay exemptions - specs keep changing
"RTN","IBARXEU1",139,0)
 ;    returns 1 if should use networth in exemption determination
"RTN","IBARXEU1",140,0)
 ;    returns 0 if should not use networth in exemption
"RTN","IBARXEU1",141,0)
 Q 0
"RTN","IBAUTL6")
0^9^B18639666
"RTN","IBAUTL6",1,0)
IBAUTL6 ;AAS/ALB-RX EXEMPTION UTILITY ROUTINE (CONT.);2-NOV-92
"RTN","IBAUTL6",2,0)
 ;;2.0;INTEGRATED BILLING;**34,195,385**;21-MAR-94;Build 35
"RTN","IBAUTL6",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBAUTL6",4,0)
 ;
"RTN","IBAUTL6",5,0)
ADDP ; -- Add patient to file 354
"RTN","IBAUTL6",6,0)
 ; -- Input    : dfn    =  entry in patient file
"RTN","IBAUTL6",7,0)
 ;    returns  : ibadd  =  0 if not added, 1 if added
"RTN","IBAUTL6",8,0)
 ;
"RTN","IBAUTL6",9,0)
 N DINUM,DLAYGO,X
"RTN","IBAUTL6",10,0)
 I '$D(DT) D DT^DICRW
"RTN","IBAUTL6",11,0)
 S IBWHER=11,IBEXERR=""
"RTN","IBAUTL6",12,0)
 S IBADD=0
"RTN","IBAUTL6",13,0)
 I $S('$D(DFN):1,'$D(^IBA(354)):1,$D(^IBA(354,DFN)):1,1:0) G ADDPQ
"RTN","IBAUTL6",14,0)
 K DO,DD,DIC,DR,DA,DIE S DIC="^IBA(354,",DIC(0)="L",DLAYGO=354
"RTN","IBAUTL6",15,0)
 L +^IBA(354,DFN):15 I $T,'$D(^IBA(354,DFN)) S (DINUM,X)=DFN D FILE^DICN I +Y>0 S IBADD=1
"RTN","IBAUTL6",16,0)
 I IBADD'=1 S IBEXERR=9
"RTN","IBAUTL6",17,0)
 L -^IBA(354,DFN)
"RTN","IBAUTL6",18,0)
 ;
"RTN","IBAUTL6",19,0)
ADDPQ K DO,DD,DIC,DR,DIE,DA
"RTN","IBAUTL6",20,0)
 Q
"RTN","IBAUTL6",21,0)
 ;
"RTN","IBAUTL6",22,0)
ADDEX(IBEXREA,IBDT,IBHOW,IBTYPE,IBOLDAUT) ; -- add entry to 354.1 and update
"RTN","IBAUTL6",23,0)
 ;  -- this will become the active entry for this effective date
"RTN","IBAUTL6",24,0)
 ;     other entries for this effective date should be cancelled
"RTN","IBAUTL6",25,0)
 ;     prior to making this call
"RTN","IBAUTL6",26,0)
 ;
"RTN","IBAUTL6",27,0)
 ;  -- input      dfn  =  pt ien (required)
"RTN","IBAUTL6",28,0)
 ;            ibexrea  =  pointer to exemption reason file (required)
"RTN","IBAUTL6",29,0)
 ;               ibdt  =  internal form of effective date (required)
"RTN","IBAUTL6",30,0)
 ;              ibhow  =  1=system added, 2=user override (optional) default =1
"RTN","IBAUTL6",31,0)
 ;             ibtype  =  type of exemption (optional)  default =1 (copay)
"RTN","IBAUTL6",32,0)
 ;           iboldaut  = date (optional)  if defined is the date of a previous exemption status (automatic) that needs to be inactivated
"RTN","IBAUTL6",33,0)
 ;
"RTN","IBAUTL6",34,0)
 ;  -- returns  ibadde = ibexrea^ibdt or null if not added
"RTN","IBAUTL6",35,0)
 ;              iberr  = error if occurs else null
"RTN","IBAUTL6",36,0)
 ;
"RTN","IBAUTL6",37,0)
 L +^IBA(354,DFN):30 I '$T S IBEXERR=1 W:$D(IBTALK)&('$D(ZTQUEUED)) !,"ENTRY LOCKED" G ADDEXQ
"RTN","IBAUTL6",38,0)
A1 I '$D(^IBA(354,DFN,0)) D ADDP G ADDEXQ:$G(IBEXERR)
"RTN","IBAUTL6",39,0)
 ;
"RTN","IBAUTL6",40,0)
 N IBDGMTA,IBDGMTP,IBDGMTF,IBVFAOK
"RTN","IBAUTL6",41,0)
 I $D(DGMTA) S IBDGMTA=$G(DGMTA),IBDGMTP=$G(DGMTP),IBDGMTF=$G(DGMTINF)
"RTN","IBAUTL6",42,0)
 N X,X1,X2,Y,IBCNT,DGMTA,DGMTP,DGMTINF
"RTN","IBAUTL6",43,0)
 I $D(IBDGMTA) S DGMTA=$G(IBDGMTA),DGMTP=$G(IBDGMTP),DGMTINF=$G(IBDGMTF)
"RTN","IBAUTL6",44,0)
 S IBWHER=12,IBEXERR="",IBADDE=""
"RTN","IBAUTL6",45,0)
 ;
"RTN","IBAUTL6",46,0)
 ;  - one last quick check
"RTN","IBAUTL6",47,0)
 I IBDT'?7N S IBEXERR=3 G ADDEXQ
"RTN","IBAUTL6",48,0)
 I DUZ,$G(^VA(200,+DUZ,0))="" S IBEXERR=8 G ADDEXQ
"RTN","IBAUTL6",49,0)
 ; if DUZ=0, it will be considered as .5 (POSTMASTER) by the input template [IB NEW EXEMPTION]
"RTN","IBAUTL6",50,0)
 ;
"RTN","IBAUTL6",51,0)
 D BEFORE^IBARXEVT ;get prior exemption
"RTN","IBAUTL6",52,0)
 ;
"RTN","IBAUTL6",53,0)
 N IBSTAT,IBEXDA
"RTN","IBAUTL6",54,0)
 S IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
"RTN","IBAUTL6",55,0)
 S IBHOW=$S('$D(IBHOW):1,IBHOW="":1,IBHOW>2:1,IBHOW<1:1,1:IBHOW)
"RTN","IBAUTL6",56,0)
 S IBTYPE=$S('$D(IBTYPE):1,IBTYPE="":1,1:IBTYPE)
"RTN","IBAUTL6",57,0)
 ;I '$D(IBACTION) S IBACTION="ADD"
"RTN","IBAUTL6",58,0)
 ;
"RTN","IBAUTL6",59,0)
 ; -- inactivate a current autoexempt of no longer autoexempt
"RTN","IBAUTL6",60,0)
 I $G(IBOLDAUT)?7N D INACT^IBAUTL7(IBOLDAUT) ;I '$D(ZTQUEUED),$D(IBTALK) W !,"Inactivating current non-income based exemption for patient"
"RTN","IBAUTL6",61,0)
 ;
"RTN","IBAUTL6",62,0)
 ; -- if forcing a new entry to correct problems
"RTN","IBAUTL6",63,0)
 I $G(IBFORCE)?7N D INACT^IBAUTL7(IBFORCE)
"RTN","IBAUTL6",64,0)
 ;
"RTN","IBAUTL6",65,0)
 ; -- check for duplicate entry
"RTN","IBAUTL6",66,0)
 I $G(IBOLDAUT)'?7N,$G(IBFORCE)'?7N,$$DUPL() W:'$D(ZTQUEUED)&($D(IBTALK)) !,"Exemption Attempting to Add is a duplicate, nothing added!",! G ADDEXQ
"RTN","IBAUTL6",67,0)
 ;
"RTN","IBAUTL6",68,0)
 ; -- inactivate previous active entries
"RTN","IBAUTL6",69,0)
 D INACT^IBAUTL7(IBDT) I $G(IBEXERR) G ADDEXQ
"RTN","IBAUTL6",70,0)
 ;
"RTN","IBAUTL6",71,0)
 ; -- if no income data from conversion set date = start date
"RTN","IBAUTL6",72,0)
 I $D(IBCONVER),$P($G(^IBE(354.2,+IBEXREA,0)),"^",5)=210 S IBDT=$$STDATE^IBARXEU
"RTN","IBAUTL6",73,0)
 ;
"RTN","IBAUTL6",74,0)
 ; -- add entry
"RTN","IBAUTL6",75,0)
 S DIC="^IBA(354.1,",DIC(0)="L",X=IBDT K DO,DD D FILE^DICN
"RTN","IBAUTL6",76,0)
 S (IBEXDA,DA)=+Y I Y<1 W:'$D(ZTQUEUED)&($D(IBTALK)) !,"Can't add entry to exemption file" S IBEXERR=4 G ADDEXQ
"RTN","IBAUTL6",77,0)
 ;
"RTN","IBAUTL6",78,0)
 ; -- edit new entry
"RTN","IBAUTL6",79,0)
 S DIE="^IBA(354.1,",DR="[IB NEW EXEMPTION]" ; use compiled template
"RTN","IBAUTL6",80,0)
 ;
"RTN","IBAUTL6",81,0)
 ;DR=".02////"_DFN_";.03////"_IBTYPE_";.04////"_IBSTAT_";.05////"_IBEXREA_";.06////"_IBHOW_";.07////"_DUZ_";.08///NOW;.1////1;.11////"_$G(IBASIG)
"RTN","IBAUTL6",82,0)
 ;
"RTN","IBAUTL6",83,0)
 D ^DIE
"RTN","IBAUTL6",84,0)
 I $D(Y) S IBEXERR=5 G ADDEXQ
"RTN","IBAUTL6",85,0)
 S IBADDE=IBEXREA_"^"_IBDT
"RTN","IBAUTL6",86,0)
 ;
"RTN","IBAUTL6",87,0)
 ; -- VFA check
"RTN","IBAUTL6",88,0)
 S IBVFAOK=$$VFAOK^IBARXEU($G(^IBA(354.1,DA,0)))
"RTN","IBAUTL6",89,0)
 ;
"RTN","IBAUTL6",90,0)
 ; -- clean up a bit
"RTN","IBAUTL6",91,0)
 K DIC,DIE,DA,DR
"RTN","IBAUTL6",92,0)
 ;
"RTN","IBAUTL6",93,0)
 ; --if effective date is in last 365 days make current
"RTN","IBAUTL6",94,0)
 I IBDT>$$MINUS^IBARXEU0(DT)!(IBVFAOK) D CURREX^IBAUTL7(IBSTAT,IBDT) I $G(IBEXERR) G ADDEXQ
"RTN","IBAUTL6",95,0)
 ;
"RTN","IBAUTL6",96,0)
 I '$D(ZTQUEUED),$G(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^"),"   ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
"RTN","IBAUTL6",97,0)
 ; -- setup and call event driver
"RTN","IBAUTL6",98,0)
 I '$D(IBCONVER) D  ;if not from conversion do following
"RTN","IBAUTL6",99,0)
 .D AFTER^IBARXEVT
"RTN","IBAUTL6",100,0)
 .S IBEVT=$$RXST^IBARXEU(DFN,$S(IBDT<$$STDATE^IBARXEU:$$STDATE^IBARXEU,1:IBDT))
"RTN","IBAUTL6",101,0)
 .D ^IBARXEVT
"RTN","IBAUTL6",102,0)
 .I IBSTAT D CANCEL^IBARXEU3 ;exempt patient cancel old charges
"RTN","IBAUTL6",103,0)
 .D ^IBARXEB ; process bulletins and alerts
"RTN","IBAUTL6",104,0)
 ;
"RTN","IBAUTL6",105,0)
ADDEXQ ;
"RTN","IBAUTL6",106,0)
 L -^IBA(354,DFN)
"RTN","IBAUTL6",107,0)
 I $G(IBEXERR) D ^IBAERR
"RTN","IBAUTL6",108,0)
 K DO,DD,DIC,DIE,DA,DR,IBEVT,IBEVTP,IBEVTA,IBASIG,IBARCAN
"RTN","IBAUTL6",109,0)
 Q
"RTN","IBAUTL6",110,0)
 ;
"RTN","IBAUTL6",111,0)
DUPL() ; -- see if entry is a duplicate
"RTN","IBAUTL6",112,0)
 N X,Y
"RTN","IBAUTL6",113,0)
 S X=0
"RTN","IBAUTL6",114,0)
 S Y=$$LST^IBARXEU0(DFN,IBDT)
"RTN","IBAUTL6",115,0)
 I IBDT=+Y,+IBEXREA=+$P(Y,"^",5),IBTYPE=$P(Y,"^",3) S X=1
"RTN","IBAUTL6",116,0)
 Q X
"VER")
8.0^22.0
**END**
**END**