DG_53_P840.KID

KIDS Distribution saved on May 18, 2011@13:44:39
ESR 3.5 Public Law 111-163 project VistA changes.
**KIDS**:DG*5.3*840^IB*2.0*449^IVM*2.0*149^

**INSTALL NAME**
DG*5.3*840
"BLD",8016,0)
DG*5.3*840^REGISTRATION^0^3110518^y
"BLD",8016,1,0)
^^2^2^3110404^
"BLD",8016,1,1,0)
This patch contains VistA changes to support technology and business 
"BLD",8016,1,2,0)
changes that are occurring with the implementation of Public Law 111-163.
"BLD",8016,4,0)
^9.64PA^27.11^2
"BLD",8016,4,2,0)
2
"BLD",8016,4,2,2,0)
^9.641^2^1
"BLD",8016,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",8016,4,2,2,2,1,0)
^9.6411^.541^2
"BLD",8016,4,2,2,2,1,.39,0)
VETERAN CATASTROPHICALLY DISABLED?
"BLD",8016,4,2,2,2,1,.541,0)
CURRENT MOH INDICATOR
"BLD",8016,4,2,222)
y^n^p^^^^n^^n
"BLD",8016,4,2,224)

"BLD",8016,4,27.11,0)
27.11
"BLD",8016,4,27.11,2,0)
^9.641^27.11^1
"BLD",8016,4,27.11,2,27.11,0)
PATIENT ENROLLMENT  (File-top level)
"BLD",8016,4,27.11,2,27.11,1,0)
^9.6411^50.23^1
"BLD",8016,4,27.11,2,27.11,1,50.23,0)
MEDAL OF HONOR INDICATED?
"BLD",8016,4,27.11,222)
y^n^p^^^^n^^n
"BLD",8016,4,27.11,224)

"BLD",8016,4,"APDD",2,2)

"BLD",8016,4,"APDD",2,2,.39)

"BLD",8016,4,"APDD",2,2,.541)

"BLD",8016,4,"APDD",27.11,27.11)

"BLD",8016,4,"APDD",27.11,27.11,50.23)

"BLD",8016,4,"B",2,2)

"BLD",8016,4,"B",27.11,27.11)

"BLD",8016,6)
3^
"BLD",8016,6.3)
20
"BLD",8016,"ABPKG")
n
"BLD",8016,"KRN",0)
^9.67PA^779.2^20
"BLD",8016,"KRN",.4,0)
.4
"BLD",8016,"KRN",.4,"NM",0)
^9.68A^^
"BLD",8016,"KRN",.401,0)
.401
"BLD",8016,"KRN",.402,0)
.402
"BLD",8016,"KRN",.403,0)
.403
"BLD",8016,"KRN",.5,0)
.5
"BLD",8016,"KRN",.84,0)
.84
"BLD",8016,"KRN",3.6,0)
3.6
"BLD",8016,"KRN",3.8,0)
3.8
"BLD",8016,"KRN",9.2,0)
9.2
"BLD",8016,"KRN",9.8,0)
9.8
"BLD",8016,"KRN",9.8,"NM",0)
^9.68A^5^5
"BLD",8016,"KRN",9.8,"NM",1,0)
DGMTCOU1^^0^B13494520
"BLD",8016,"KRN",9.8,"NM",2,0)
DGMTR^^0^B68425673
"BLD",8016,"KRN",9.8,"NM",3,0)
DGMTR1^^0^B32321945
"BLD",8016,"KRN",9.8,"NM",4,0)
DGMTCOR^^0^B36016297
"BLD",8016,"KRN",9.8,"NM",5,0)
DGMTA^^0^B43096781
"BLD",8016,"KRN",9.8,"NM","B","DGMTA",5)

"BLD",8016,"KRN",9.8,"NM","B","DGMTCOR",4)

"BLD",8016,"KRN",9.8,"NM","B","DGMTCOU1",1)

"BLD",8016,"KRN",9.8,"NM","B","DGMTR",2)

"BLD",8016,"KRN",9.8,"NM","B","DGMTR1",3)

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

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

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

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

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

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

"BLD",8016,"KRN","B",3.6,3.6)

"BLD",8016,"KRN","B",3.8,3.8)

"BLD",8016,"KRN","B",9.2,9.2)

"BLD",8016,"KRN","B",9.8,9.8)

"BLD",8016,"KRN","B",19,19)

"BLD",8016,"KRN","B",19.1,19.1)

"BLD",8016,"KRN","B",101,101)

"BLD",8016,"KRN","B",409.61,409.61)

"BLD",8016,"KRN","B",771,771)

"BLD",8016,"KRN","B",779.2,779.2)

"BLD",8016,"KRN","B",870,870)

"BLD",8016,"KRN","B",8989.51,8989.51)

"BLD",8016,"KRN","B",8989.52,8989.52)

"BLD",8016,"KRN","B",8994,8994)

"BLD",8016,"QUES",0)
^9.62^^
"BLD",8016,"REQB",0)
^9.611^2^2
"BLD",8016,"REQB",1,0)
DG*5.3*661^2
"BLD",8016,"REQB",2,0)
DG*5.3*773^2
"BLD",8016,"REQB","B","DG*5.3*661",1)

"BLD",8016,"REQB","B","DG*5.3*773",2)

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

"FIA",2,0,11)

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

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

"FIA",2,2,.541)

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

"FIA",27.11,0,11)

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

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

"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)
840^3110518^100992
"PKG",47,22,1,"PAH",1,1,0)
^^2^2^3110518
"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 Public Law 111-163.
"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")
5
"RTN","DGMTA")
0^5^B43096781
"RTN","DGMTA",1,0)
DGMTA ;ALB/RMO/CAW/LD/SCG/AEG/PHH - Add a New Means Test;2/24/10 2:58pm
"RTN","DGMTA",2,0)
 ;;5.3;Registration;**33,45,137,166,177,182,290,344,332,433,458,535,612,564,688,661,840**;Aug 13, 1993;Build 20
"RTN","DGMTA",3,0)
 ;
"RTN","DGMTA",4,0)
EN ;Entry point to add a new means test
"RTN","DGMTA",5,0)
 N DGMDOD S DGMDOD=""
"RTN","DGMTA",6,0)
 S DGADDF=1
"RTN","DGMTA",7,0)
 I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
"RTN","DGMTA",8,0)
 S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q:Y<0 S (DFN,DGMTDFN)=+Y
"RTN","DGMTA",9,0)
 I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
"RTN","DGMTA",10,0)
 I $G(DGMDOD) W !,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") Q
"RTN","DGMTA",11,0)
 ;
"RTN","DGMTA",12,0)
 ; check if income test in progress
"RTN","DGMTA",13,0)
 D CKUPLOAD^IVMCUPL(DFN)
"RTN","DGMTA",14,0)
 ;
"RTN","DGMTA",15,0)
 ; obtain lock used to synchronize local MT/CT options with income test upload
"RTN","DGMTA",16,0)
 I $$LOCK^DGMTUTL(DFN)
"RTN","DGMTA",17,0)
 ;
"RTN","DGMTA",18,0)
 I DGMTYPT=1 N DGDOM1 D EN^DGMTR I 'DGREQF,'$G(DGDOM1) W !,*7,"A means test can only be added for patients who require one.",! K DGDOM1 G EN
"RTN","DGMTA",19,0)
 ;
"RTN","DGMTA",20,0)
 N FUTMT S FUTMT=$$FUT^DGMTU(DFN,"",DGMTYPT) I FUTMT D FTST G EN
"RTN","DGMTA",21,0)
 ;
"RTN","DGMTA",22,0)
 ;if a test was auto-completed, DGADDF gets set to 0
"RTN","DGMTA",23,0)
 I 'DGADDF W !!,*7,"A means test already exists and is in effect" G EN
"RTN","DGMTA",24,0)
 ;
"RTN","DGMTA",25,0)
 K:DGMTYPT=1 DGDOM1
"RTN","DGMTA",26,0)
 I DGMTYPT=2 D EN^DGMTCOR I 'DGMTCOR S I=$P($T(WHY+DGWRT),";",3,99) W !!,*7,"A copay exemption test can only be added for applicable veterans.",!,I G EN
"RTN","DGMTA",27,0)
 S DGLDT=$$LST^DGMTU(DFN,"",DGMTYPT),DGLD=$P(DGLDT,U,2),DGLDYR=$E(DGLD,1,3)_"1231"
"RTN","DGMTA",28,0)
 ;
"RTN","DGMTA",29,0)
DT S %DT("A")="DATE OF TEST: ",%DT="AEX",%DT(0)="-NOW",%DT("B")="NOW" W ! D ^%DT K %DT G Q:Y<0 S DGMTDT=Y
"RTN","DGMTA",30,0)
 I DGMTDT<$S(DGMTYPT=1:2860701,1:2921029) W !?3,*7,"The date of test cannot be before "_$S(DGMTYPT=1:"7/1/1986.",1:"10/29/1992.") G DT
"RTN","DGMTA",31,0)
 I DGLD,DGMTDT<DGLD W !?3,*7,"The date of test cannot be before the last date of test on " S Y=DGLD X ^DD("DD") W Y,"." G DT
"RTN","DGMTA",32,0)
 I DGLD S X1=DGMTDT,X2=DGLD D ^%DTC I X<365,DGMTDT'>DGLDYR D  G EN
"RTN","DGMTA",33,0)
 .W !?3,*7,"An annual date of test already exists on " S Y=DGLD X ^DD("DD") W Y,"."
"RTN","DGMTA",34,0)
 .S DGTTYP=$S(DGMTYPT=1:"Means ",1:"Copay Exemption ")
"RTN","DGMTA",35,0)
 .W !,$S($P($G(^DG(408.34,+$P($G(^DGMT(408.31,+DGLDT,0)),U,23),0)),U)="VAMC":"   Use the 'Edit an Existing "_DGTTYP_"Test' Option.",1:"   Use the 'View a Past Means Test' Option.")
"RTN","DGMTA",36,0)
 ;
"RTN","DGMTA",37,0)
 ;Means Test cannot be added for patient on a DOM ward on date of test
"RTN","DGMTA",38,0)
 I DGMTYPT=2 G PRINT
"RTN","DGMTA",39,0)
 N VAINDT,VADMVT,DGDOM,DGDOM1
"RTN","DGMTA",40,0)
 S VAINDT=DGMTDT
"RTN","DGMTA",41,0)
 D DOM1^DGMTR I $G(DGDOM1) D  K VAINDT,VADMVT,DGDOM,DGDOM1 G EN
"RTN","DGMTA",42,0)
 .W !,*7,"A Means Test cannot be added for patients on a DOM ward on date of test.",!
"RTN","DGMTA",43,0)
 K VAINDT,VADMVT,DGDOM,DGDOM1
"RTN","DGMTA",44,0)
 ;
"RTN","DGMTA",45,0)
 ;A warning message is displayed if last means test for patient is
"RTN","DGMTA",46,0)
 ;from a prior year and has a status of required.  The user is given
"RTN","DGMTA",47,0)
 ;the option to continue or stop adding a new means test.
"RTN","DGMTA",48,0)
 N %
"RTN","DGMTA",49,0)
 I DGLD,DGMTDT>DGLDYR,$P(DGLDT,"^",4)="R" D  Q:%=-1  I %=2 K % G EN
"RTN","DGMTA",50,0)
 .W !?3,*7,"WARNING - last means test on " S Y=DGLD X ^DD("DD") W Y," has a status of required."
"RTN","DGMTA",51,0)
DT2 .W !?3,"Do you still want to continue adding new test"
"RTN","DGMTA",52,0)
 .S %=2 D YN^DICN
"RTN","DGMTA",53,0)
 .I %=0 W !?3,"Answer 'Y'es to continue adding new test." G DT2
"RTN","DGMTA",54,0)
 .Q 
"RTN","DGMTA",55,0)
 K %
"RTN","DGMTA",56,0)
 ;
"RTN","DGMTA",57,0)
PRINT I "^P^A^C^G^"[(U_$P(DGLDT,U,4)_U) S %=1 W !,"Do you wish to print the prior means test" D YN^DICN G:%=-1 Q I %Y["?" W !!,"This will print the prior means test information.",! G PRINT
"RTN","DGMTA",58,0)
 I $G(%)=1 S DGX=DGMTDT,DGMTDT=DGLD,DGMTI=+DGLDT,DGOPT="" D DEV^DGMTP,CLOSE^DGUTQ S DGMTDT=DGX K DGX
"RTN","DGMTA",59,0)
 D ADD G EN:DGMTI<0
"RTN","DGMTA",60,0)
 S DGMTACT="ADD",DGMTROU="EN^DGMTA" G EN^DGMTSC
"RTN","DGMTA",61,0)
 ;
"RTN","DGMTA",62,0)
Q K DA,DFN,DGADDF,DGBL,DGFL,DGFLD,DGIRO,DGLD,DGLDT,DGLDYR,DGMTACT,DGMTCOR,DGMTDT,DGMTI,DGMTROU,DGREQF,DGTTYP,DGMTYPT,DGVI,DGVO,X,X1,X2,Y
"RTN","DGMTA",63,0)
 ;
"RTN","DGMTA",64,0)
 ; release lock used to synchronize local MT/CT options with income test upload
"RTN","DGMTA",65,0)
 I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
"RTN","DGMTA",66,0)
 Q
"RTN","DGMTA",67,0)
 ;
"RTN","DGMTA",68,0)
ADD ;Add means test
"RTN","DGMTA",69,0)
 ; Input  -- DFN     Patient IEN
"RTN","DGMTA",70,0)
 ;           DGMTDT  Date
"RTN","DGMTA",71,0)
 ;           DGMTYPT Type of Test 1=MT 2=COPAY 4=LTC
"RTN","DGMTA",72,0)
 ; Output -- DGMTI   Annual Means/Copay/LTC Test IEN
"RTN","DGMTA",73,0)
 N DA,DD,DIC,DIK,DINUM,DLAYGO,DO,DS,X,D0,DGSITE,CONVRT,CURIEN,LINK,DGLNKMT
"RTN","DGMTA",74,0)
 ;
"RTN","DGMTA",75,0)
 ; obtain lock used to synchronize local MT/CT options with income test upload
"RTN","DGMTA",76,0)
 I $$LOCK^DGMTUTL(DFN) E  Q
"RTN","DGMTA",77,0)
 ;
"RTN","DGMTA",78,0)
 ; Check for Linked test and don't lose the link.
"RTN","DGMTA",79,0)
 S LINK="",DGLNKMT=$$LST^DGMTU(DFN,DGMTDT,DGMTYPT),CURIEN=+DGLNKMT
"RTN","DGMTA",80,0)
 I CURIEN D
"RTN","DGMTA",81,0)
 . ;Don't link test if it's in a different year (DG*5.3*661)
"RTN","DGMTA",82,0)
 . I $E($P(DGLNKMT,U,2),1,3)'=$E(DGMTDT,1,3) Q
"RTN","DGMTA",83,0)
 . S LINK=$P($G(^DGMT(408.31,CURIEN,2)),U,6)
"RTN","DGMTA",84,0)
 ;
"RTN","DGMTA",85,0)
 S DGSITE=$$GETSITE^DGMTU4(.DUZ)
"RTN","DGMTA",86,0)
 S X=DGMTDT,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
"RTN","DGMTA",87,0)
 ;
"RTN","DGMTA",88,0)
 ;Look for existing IAI records and convert (if necessary)
"RTN","DGMTA",89,0)
 D ALL^DGMTU21(DFN,"VSD",DT,"IPR") ;ALL only returns IAI from last IY
"RTN","DGMTA",90,0)
 I $D(DGINC) DO
"RTN","DGMTA",91,0)
 . D ISCNVRT^DGMTUTL(.DGINC)
"RTN","DGMTA",92,0)
 ;
"RTN","DGMTA",93,0)
 ; The DIC("DR") string is built in this specific order so that
"RTN","DGMTA",94,0)
 ; all triggers and "M" x-refs fire correctly.  Should not be
"RTN","DGMTA",95,0)
 ; modified without an in-depth review of DD of file #408.31.
"RTN","DGMTA",96,0)
 ;
"RTN","DGMTA",97,0)
 I DGMTYPT=2 D
"RTN","DGMTA",98,0)
 .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK
"RTN","DGMTA",99,0)
 .S DIC("DR")=DIC("DR")_";.02////"_DFN_";.019////"_DGMTYPT_";.23////1"
"RTN","DGMTA",100,0)
 E  D
"RTN","DGMTA",101,0)
 .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK
"RTN","DGMTA",102,0)
 .S DIC("DR")=DIC("DR")_";.019////"_DGMTYPT_";.02////"_DFN_";.23////1"
"RTN","DGMTA",103,0)
 K DD,DO
"RTN","DGMTA",104,0)
 D FILE^DICN S DGMTI=+Y
"RTN","DGMTA",105,0)
 ;
"RTN","DGMTA",106,0)
 ; Check for another test in the current year and convert IAI records if needed
"RTN","DGMTA",107,0)
 ; Send new test date (as test that have) into VRCHKUP
"RTN","DGMTA",108,0)
 I $D(TYPE),((+TYPE=1)!(TYPE=4)) S CONVRT=$$VRCHKUP^DGMTU2(DGMTYPT,TYPE,DGMTDT)
"RTN","DGMTA",109,0)
 I $D(TYPE),((+TYPE'=1)&(TYPE'=4)) S CONVRT=$$VRCHKUP^DGMTU2(DGMTYPT,,DGMTDT)
"RTN","DGMTA",110,0)
 I '$D(TYPE) S CONVRT=$$VRCHKUP^DGMTU2(DGMTYPT,,DGMTDT)
"RTN","DGMTA",111,0)
 N DGERR,DGMTRT
"RTN","DGMTA",112,0)
 S DGMTRT(408.31,DGMTI_",",2.11)=1
"RTN","DGMTA",113,0)
 S DGERR=""
"RTN","DGMTA",114,0)
 D FILE^DIE("","DGMTRT",DGERR)
"RTN","DGMTA",115,0)
 ; release lock used to synchronize local MT/CT options with income test upload
"RTN","DGMTA",116,0)
 D UNLOCK^DGMTUTL(DFN)
"RTN","DGMTA",117,0)
 ;
"RTN","DGMTA",118,0)
ADDQ Q
"RTN","DGMTA",119,0)
 ;
"RTN","DGMTA",120,0)
FTST ; Build message for future tests that are added to the system, but
"RTN","DGMTA",121,0)
 ; were not performed by the VAMC trying to add a new MT.
"RTN","DGMTA",122,0)
 N SITE,DGMTYPT,DGTTYP,SRC,SCT
"RTN","DGMTA",123,0)
 S SCT=$P(^DGMT(408.31,+FUTMT,2),U,5),SITE=$$INST^DGENU()
"RTN","DGMTA",124,0)
 S DGMTYPT=$P(^DGMT(408.31,+FUTMT,0),U,19)
"RTN","DGMTA",125,0)
 S DGTTYP=$S(DGMTYPT=1:"Means ",1:"Copay Exemption ")
"RTN","DGMTA",126,0)
 W !?3,*7,"A future test already exists on "
"RTN","DGMTA",127,0)
 S Y=$P(FUTMT,U,2) X ^DD("DD") W Y,"."
"RTN","DGMTA",128,0)
 ; This site performed the MT
"RTN","DGMTA",129,0)
 I SITE=SCT D
"RTN","DGMTA",130,0)
 .W !?3,"Use the 'Edit an Existing "_DGTTYP_"Test' Option."
"RTN","DGMTA",131,0)
 ;
"RTN","DGMTA",132,0)
 ; The MT was added by another VAMC
"RTN","DGMTA",133,0)
 I SITE'=SCT D
"RTN","DGMTA",134,0)
 .S SRC=$P(FUTMT,U,5)
"RTN","DGMTA",135,0)
 .I SCT W !?3,"The "_DGTTYP_"Test was conducted at Site: ",SCT
"RTN","DGMTA",136,0)
 .W !?3,"Please contact "
"RTN","DGMTA",137,0)
 .W $S($D(^DIC(4,+SCT,0)):$P(^DIC(4,+SCT,0),U),SRC=2:"IVM",SRC=3:"the HEC",1:"the site")
"RTN","DGMTA",138,0)
 .W ",",!?3,"if it is necessary to edit the test."
"RTN","DGMTA",139,0)
 Q
"RTN","DGMTA",140,0)
WHY ;Why Copay Test cannot be added
"RTN","DGMTA",141,0)
 ;;Patient is not a veteran.
"RTN","DGMTA",142,0)
 ;;Patient does not have a Primary Eligibility Code.
"RTN","DGMTA",143,0)
 ;;Patient is Service Connected 50-100%.
"RTN","DGMTA",144,0)
 ;;Means Test options must be used instead of Copay options.
"RTN","DGMTA",145,0)
 ;;Patient is receiving Aid and Attendance, automatically exempted.
"RTN","DGMTA",146,0)
 ;;Patient is receiving Housebound Benefits, automatically exempted.
"RTN","DGMTA",147,0)
 ;;Patient is receiving a VA Pension, automatically exempted.
"RTN","DGMTA",148,0)
 ;;Patient is in a DOM ward, automatically exempted.
"RTN","DGMTA",149,0)
 ;;Patient is an inpatient, automatically exempted.
"RTN","DGMTA",150,0)
 ;;Patient was a POW, automatically exempted.
"RTN","DGMTA",151,0)
 ;;Patient is Unemployable, automatically exempted.
"RTN","DGMTA",152,0)
 ;;Patient is Catastrophically Disabled, automatically exempted.
"RTN","DGMTCOR")
0^4^B36016297
"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**;Aug 13, 1993;Build 20
"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)
 I DGMTI,'$$OLD^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",82,0)
CHKQ Q
"RTN","DGMTCOR",83,0)
 ;
"RTN","DGMTCOR",84,0)
NLA ; Change Status to NO LONGER APPLICABLE - if appropriate
"RTN","DGMTCOR",85,0)
 ;
"RTN","DGMTCOR",86,0)
 N DGCS,DGMTI,DGMT0,DGINI,DGINR,DGVAL,DGFL,DGFLD,DGIEN,DGMTACT,TDATE
"RTN","DGMTCOR",87,0)
 S DGMTI=+$$LST^DGMTU(DFN,"",2) Q:'DGMTI!($P($G(^DGMT(408.31,DGMTI,0)),U,3)=10)
"RTN","DGMTCOR",88,0)
 ; Do not allow update of IVM test by site
"RTN","DGMTCOR",89,0)
 I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D  Q  ;Check if converted IVM MT
"RTN","DGMTCOR",90,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",91,0)
 . S DGNOIVMUPD=2 ; Prevent double printing of the message
"RTN","DGMTCOR",92,0)
 S DGMT0=$G(^DGMT(408.31,DGMTI,0)) Q:'DGMT0
"RTN","DGMTCOR",93,0)
 S DGCS=$P(DGMT0,U,3)
"RTN","DGMTCOR",94,0)
 S TDATE=+DGMT0
"RTN","DGMTCOR",95,0)
 S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTCOR",96,0)
 ;
"RTN","DGMTCOR",97,0)
 D SAVESTAT^DGMTU4(DGMTI)
"RTN","DGMTCOR",98,0)
 ;
"RTN","DGMTCOR",99,0)
 S DGFL=408.31,DGIEN=DGMTI
"RTN","DGMTCOR",100,0)
 S DGFLD=.03 I DGCS]"" S DGVAL=DGCS D KILL^DGMTR
"RTN","DGMTCOR",101,0)
 S DGVAL=10,$P(^DGMT(408.31,DGMTI,0),"^",3)=DGVAL D SET^DGMTR
"RTN","DGMTCOR",102,0)
 S DGFLD=.17,DGVAL=DT,$P(^DGMT(408.31,DGMTI,0),"^",17)=DT D SET^DGMTR
"RTN","DGMTCOR",103,0)
 W:'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY TEST NO LONGER APPLICABLE"
"RTN","DGMTCOR",104,0)
 D GETINCOM^DGMTU4(DFN,TDATE)
"RTN","DGMTCOR",105,0)
 S DGMTYPT=2 D QUE^DGMTR
"RTN","DGMTCOR",106,0)
 S DGRGAUTO=0
"RTN","DGMTCOR",107,0)
NLAQ Q
"RTN","DGMTCOR",108,0)
 ;
"RTN","DGMTCOR",109,0)
INC ;Update copay status to 'INCOMPLETE' if applicable OR restore completed test
"RTN","DGMTCOR",110,0)
 N DGMTACT,DGMTI,DGFL,DGFLD,DGIEN,DGMTP,DGVAL,DGMT0,AUTOCOMP,ERROR
"RTN","DGMTCOR",111,0)
 S AUTOCOMP=0
"RTN","DGMTCOR",112,0)
 S DGMTI=+$$LST^DGMTU(DFN,"",2)
"RTN","DGMTCOR",113,0)
 D
"RTN","DGMTCOR",114,0)
 .Q:'DGMTI
"RTN","DGMTCOR",115,0)
 .I ($P($G(^DGMT(408.31,DGMTI,0)),U,3)'=10) S AUTOCOMP=1 Q
"RTN","DGMTCOR",116,0)
 .S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGCS=$P(DGMT0,U,3)
"RTN","DGMTCOR",117,0)
 .Q:'DGMT0
"RTN","DGMTCOR",118,0)
 .S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTCOR",119,0)
 .S AUTOCOMP=$$AUTOCOMP^DGMTR(DGMTI)
"RTN","DGMTCOR",120,0)
 .W:'AUTOCOMP&'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY EXEMPTION TEST UPDATED TO INCOMPLETE"
"RTN","DGMTCOR",121,0)
 .W:AUTOCOMP&'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY EXEMPTION TEST UPDATED TO ",$$GETNAME^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),"^",3))
"RTN","DGMTCOR",122,0)
 .S DGMTYPT=2 D QUE^DGMTR
"RTN","DGMTCOR",123,0)
 .S DGRGAUTO=0
"RTN","DGMTCOR",124,0)
 ;
"RTN","DGMTCOR",125,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",126,0)
 ;
"RTN","DGMTCOR",127,0)
INCQ Q
"RTN","DGMTCOR",128,0)
 ;
"RTN","DGMTCOR",129,0)
QREGAUTO ;Queues off test done by IB recalculating CP status
"RTN","DGMTCOR",130,0)
 ;  Input: DFN
"RTN","DGMTCOR",131,0)
 ;  Action: Possible update of Copay Status
"RTN","DGMTCOR",132,0)
 ;
"RTN","DGMTCOR",133,0)
 Q:'$D(^IBA(354.1,"APIDT",DFN,1))  ;No action if no status on file
"RTN","DGMTCOR",134,0)
 S ZTDESC="CHECK PATIENT FILE CHANGES VS CP STATUS",ZTDTH=$H,ZTRTN="REGAUTO^IBARXEU5",ZTSAVE("DFN")="",ZTIO=""
"RTN","DGMTCOR",135,0)
 D ^%ZTLOAD
"RTN","DGMTCOR",136,0)
 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","DGMTCOR",137,0)
 Q
"RTN","DGMTCOR",138,0)
 ;
"RTN","DGMTCOR",139,0)
IVMCVT(IVMTIEN) ; Check for a converted IVM Means Test
"RTN","DGMTCOR",140,0)
 ;  Input  IVMTIEN - MT IEN to check
"RTN","DGMTCOR",141,0)
 ;  Return 1 - if converted MT
"RTN","DGMTCOR",142,0)
 ;         0 - if not a converted MT
"RTN","DGMTCOR",143,0)
 ;
"RTN","DGMTCOR",144,0)
 N FLAG,IVMAR
"RTN","DGMTCOR",145,0)
 S FLAG=0
"RTN","DGMTCOR",146,0)
 I '$G(IVMTIEN) G IVMQ
"RTN","DGMTCOR",147,0)
 D GETS^DIQ(408.31,IVMTIEN,".23;.25","E","IVMAR")
"RTN","DGMTCOR",148,0)
 ; To identify an IVM converted test in the ANNUAL MEANS TEST, #408.31, if the Source of Test (#.23)
"RTN","DGMTCOR",149,0)
 ; is equal to 'IVM' OR the Date IVM Verified MT Completed (#.25) is populated, then the test should
"RTN","DGMTCOR",150,0)
 ; be considered a converted test. 
"RTN","DGMTCOR",151,0)
 I IVMAR(408.31,IVMTIEN_",",.23,"E")="IVM" S FLAG=1 G IVMQ
"RTN","DGMTCOR",152,0)
 I IVMAR(408.31,IVMTIEN_",",.25,"E")]"" S FLAG=1 G IVMQ
"RTN","DGMTCOR",153,0)
IVMQ ;
"RTN","DGMTCOR",154,0)
 Q FLAG
"RTN","DGMTCOU1")
0^1^B13494520
"RTN","DGMTCOU1",1,0)
DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES;8/13/04 8:31am
"RTN","DGMTCOU1",2,0)
 ;;5.3;Registration;**33,45,54,335,358,401,436,445,564,840**;Aug 13, 1993;Build 20
"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 365 DAYS)
"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)
 S:$$365($P(DGLST,U,2),DGDT) DGLST="" ;RETURN NULL IF LAST >365
"RTN","DGMTCOU1",94,0)
 Q DGLST
"RTN","DGMTCOU1",95,0)
365(X1,DGDT) ; RETURNS 1 IF X1 IS MORE THAN 1 YEAR BEFORE DGDT
"RTN","DGMTCOU1",96,0)
 Q X1+10000'>DGDT
"RTN","DGMTR")
0^2^B68425673
"RTN","DGMTR",1,0)
DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - 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**;Aug 13, 1993;Build 20
"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)
 ;  - who is NOT a Medal of Honor recipient 
"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)
 I DGCS S OLD=$$OLD^DGMTU4(+DGMT0)
"RTN","DGMTR",60,0)
 ;Purple Heart Recipient ;brm 10/02/00 added 1 line below
"RTN","DGMTR",61,0)
 I $P($G(^DPT(DFN,.53)),U)="Y" S DGREQF=0
"RTN","DGMTR",62,0)
 ;Catastrophically disabled
"RTN","DGMTR",63,0)
 I $P($G(^DPT(DFN,.39)),U,6)="Y" S DGREQF=0 ;DG*5.3*840
"RTN","DGMTR",64,0)
 ;Medal of Honor DG*5.3*840
"RTN","DGMTR",65,0)
 I $P($G(^DPT(DFN,.54)),U)="Y" S DGREQF=0
"RTN","DGMTR",66,0)
 D
"RTN","DGMTR",67,0)
 .I DGREQF,DGCS=3,'OLD D REQ Q
"RTN","DGMTR",68,0)
 .I DGREQF,'$G(DGADDF),((DGCS=6)!(DGCS=2)),$P(DGMT0,U,11)=1,DGMTLTD>2991005 S DGREQF=0,DGNOCOPF=1 Q
"RTN","DGMTR",69,0)
 .; next line added 2/19/02 - DG*5.3*426
"RTN","DGMTR",70,0)
 .I DGREQF,'$G(DGADDF),$G(DGCS)=6,+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGREQF=0,DGNOCOPF=1 Q
"RTN","DGMTR",71,0)
 .I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)),'$G(DGMDOD) D ADD Q
"RTN","DGMTR",72,0)
 .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(IVMZ10F) D NOL Q
"RTN","DGMTR",73,0)
 ;be sure to check whether or not patient is subject to RX copay!
"RTN","DGMTR",74,0)
 D EN^DGMTCOR
"RTN","DGMTR",75,0)
 Q
"RTN","DGMTR",76,0)
 ;Check if patient is in a DOM
"RTN","DGMTR",77,0)
 ;  call to DOM checks if patient currently on a DOM ward
"RTN","DGMTR",78,0)
 ;                                     (called from EN)
"RTN","DGMTR",79,0)
 ;  call to DOM1 checks if patient on a DOM ward for a specific date
"RTN","DGMTR",80,0)
 ;    before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
"RTN","DGMTR",81,0)
 ;                          S VAINDT=specific date
"RTN","DGMTR",82,0)
 ;                          S DFN=Patient IEN
"RTN","DGMTR",83,0)
 ;                 output - DGDOM & DGDOM1 (defined and set to 1 if
"RTN","DGMTR",84,0)
 ;                          patient on a DOM ward for specific date)
"RTN","DGMTR",85,0)
DOM N VAINDT,VADMVT
"RTN","DGMTR",86,0)
DOM1 D ADM^VADPT2
"RTN","DGMTR",87,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",88,0)
 Q
"RTN","DGMTR",89,0)
SC(DFN) ;Check if patient is SC 0% non-compensable
"RTN","DGMTR",90,0)
 ; Input  -- DFN     Patient IEN
"RTN","DGMTR",91,0)
 ; Output -- 1=Yes and 0=No
"RTN","DGMTR",92,0)
 ;     No if:
"RTN","DGMTR",93,0)
 ;        No total annual VA check amount
"RTN","DGMTR",94,0)
 ;        POW STATUS INDICATOR is yes
"RTN","DGMTR",95,0)
 ;        Secondary Eligibility is one of the following:
"RTN","DGMTR",96,0)
 ;           A&A, NSC, VA PENSION
"RTN","DGMTR",97,0)
 ;           HOUSEBOUND, MEXICAN BORDER WAR, WWI, POW
"RTN","DGMTR",98,0)
 N DG,DGE,DGF,Y
"RTN","DGMTR",99,0)
 S Y=0
"RTN","DGMTR",100,0)
 ;Primary eligibility is SC LESS THAN 50%
"RTN","DGMTR",101,0)
 I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
"RTN","DGMTR",102,0)
 G:'Y SCQ
"RTN","DGMTR",103,0)
 ;Service connected percentage is 0
"RTN","DGMTR",104,0)
 I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
"RTN","DGMTR",105,0)
 ;No Total annual VA check amount
"RTN","DGMTR",106,0)
 I $P($G(^DPT(DFN,.362)),"^",20) S Y=0 G SCQ
"RTN","DGMTR",107,0)
 ;POW STATUS INDICATOR
"RTN","DGMTR",108,0)
 I $P($G(^DPT(DFN,.52)),"^",5)="Y" S Y=0 G SCQ
"RTN","DGMTR",109,0)
 ;Purple Heart Indicator
"RTN","DGMTR",110,0)
 I $P($G(^DPT(DFN,.53)),"^")="Y" S Y=0 G SCQ
"RTN","DGMTR",111,0)
 ;Secondary Eligibility
"RTN","DGMTR",112,0)
 F DG=2,4,15:1:18 S DGE(DG)=""
"RTN","DGMTR",113,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",114,0)
SCQ Q +$G(Y)
"RTN","DGMTR",115,0)
ADD ;Add a required means test
"RTN","DGMTR",116,0)
 N DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTP,ERROR
"RTN","DGMTR",117,0)
 W:'$G(DGMSGF) !,"MEANS TEST REQUIRED"
"RTN","DGMTR",118,0)
 S DGMTACT="ADD" D PRIOR^DGMTEVT
"RTN","DGMTR",119,0)
 S DGMTDT=DT D ADD^DGMTA
"RTN","DGMTR",120,0)
 I DGMTI>0 S DGMTYPT=1 D
"RTN","DGMTR",121,0)
 .N DATA S DATA(.03)=$$GETSTAT^DGMTH("R",1) I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
"RTN","DGMTR",122,0)
 .D GETINCOM^DGMTU4(DFN,DT)
"RTN","DGMTR",123,0)
 .D QUE
"RTN","DGMTR",124,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",125,0)
 Q
"RTN","DGMTR",126,0)
REQ ;Update means test status to REQUIRED
"RTN","DGMTR",127,0)
 N DGMTA,AUTOCOMP,DGMTE,ERROR
"RTN","DGMTR",128,0)
 ;may have set prior MT for means test upload
"RTN","DGMTR",129,0)
 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTR",130,0)
 S AUTOCOMP=$$AUTOCOMP(DGMTI)
"RTN","DGMTR",131,0)
 ;if a test were auto-completed, don't want another being added inadvertently
"RTN","DGMTR",132,0)
 I AUTOCOMP,$G(DGADDF) S DGADDF=0
"RTN","DGMTR",133,0)
 I AUTOCOMP S DGCS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
"RTN","DGMTR",134,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",135,0)
 I ('AUTOCOMP),('$G(DGMSGF)) W !,"MEANS TEST REQUIRED"
"RTN","DGMTR",136,0)
 I (AUTOCOMP),('$G(DGMSGF)) W !,"CURRENT MEANS TEST STATUS IS ",$$GETNAME^DGMTH(DGCS)
"RTN","DGMTR",137,0)
 S DGMTYPT=1
"RTN","DGMTR",138,0)
 D QUE
"RTN","DGMTR",139,0)
 Q
"RTN","DGMTR",140,0)
AUTOCOMP(DGMTI) ;
"RTN","DGMTR",141,0)
 ;Will either automatically complete the test (RX copay or means test) 
"RTN","DGMTR",142,0)
 ;based on the Test Determined Status, or will change the status to
"RTN","DGMTR",143,0)
 ;Required for means tests or Incomplete for Rx copay tests
"RTN","DGMTR",144,0)
 ;Input:
"RTN","DGMTR",145,0)
 ;  DGMTI - the ien of the test
"RTN","DGMTR",146,0)
 ;Output:
"RTN","DGMTR",147,0)
 ;  Function value - 1 if the test was completed, 0 otherwise
"RTN","DGMTR",148,0)
 N NODE0,NODE2,DATA,RET,LINKIEN,DGINR,DGINI,ERROR,CODE,TYPE,DFN,TDATE
"RTN","DGMTR",149,0)
 S RET=0
"RTN","DGMTR",150,0)
 Q:'$G(DGMTI) RET
"RTN","DGMTR",151,0)
 S NODE0=$G(^DGMT(408.31,DGMTI,0))
"RTN","DGMTR",152,0)
 Q:(NODE0="") RET
"RTN","DGMTR",153,0)
 S TYPE=$P(NODE0,"^",19)
"RTN","DGMTR",154,0)
 S DFN=$P(NODE0,"^",2)
"RTN","DGMTR",155,0)
 S TDATE=+NODE0
"RTN","DGMTR",156,0)
 S NODE2=$G(^DGMT(408.31,DGMTI,2))
"RTN","DGMTR",157,0)
 ;get test-determined status code
"RTN","DGMTR",158,0)
 S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
"RTN","DGMTR",159,0)
 ;if means test
"RTN","DGMTR",160,0)
 I TYPE=1 D
"RTN","DGMTR",161,0)
 .S DATA(.03)=$$GETSTAT^DGMTH("R",1),DATA(.17)=""
"RTN","DGMTR",162,0)
 .I (CODE'=""),"ACGP"[CODE D
"RTN","DGMTR",163,0)
 ..S RET=1
"RTN","DGMTR",164,0)
 ..S DATA(.03)=$P(NODE2,"^",3)
"RTN","DGMTR",165,0)
 ..;determine status if there is a hardship
"RTN","DGMTR",166,0)
 ..I $P(NODE0,"^",20) D
"RTN","DGMTR",167,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",168,0)
 .I (CODE="")!(CODE'=""&"ACGP"'[CODE) D
"RTN","DGMTR",169,0)
 ..; Check for another test in the current year and convert IAI records, if needed
"RTN","DGMTR",170,0)
 ..S CONVRT=$$VRCHKUP^DGMTU2(1,,TDATE)
"RTN","DGMTR",171,0)
 ..S DATA(2.11)=1
"RTN","DGMTR",172,0)
 ;RX copay test
"RTN","DGMTR",173,0)
 I TYPE=2 D
"RTN","DGMTR",174,0)
 .S DATA(.03)=$$GETSTAT^DGMTH("I",2),DATA(.17)=""
"RTN","DGMTR",175,0)
 .I (CODE'=""),"EM"[CODE D
"RTN","DGMTR",176,0)
 ..S RET=1
"RTN","DGMTR",177,0)
 ..S DATA(.03)=$P(NODE2,"^",3)
"RTN","DGMTR",178,0)
 .I (CODE="")!(CODE'=""&"EM"'[CODE) D
"RTN","DGMTR",179,0)
 ..; Check for another test in the current year and convert IAI records, if needed
"RTN","DGMTR",180,0)
 ..S CONVRT=$$VRCHKUP^DGMTU2(2,,TDATE)
"RTN","DGMTR",181,0)
 ..S DATA(2.11)=1
"RTN","DGMTR",182,0)
 I '$$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR) W:'$G(DGMSGF) ERROR
"RTN","DGMTR",183,0)
 ;restore the pointers from the Income Relation file (408.22) to this
"RTN","DGMTR",184,0)
 ;test, using the linked test
"RTN","DGMTR",185,0)
 S LINKIEN=$P(NODE2,"^",6)
"RTN","DGMTR",186,0)
 I LINKIEN D
"RTN","DGMTR",187,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",188,0)
 ..K DATA
"RTN","DGMTR",189,0)
 ..S DATA(31)=DGMTI
"RTN","DGMTR",190,0)
 ..I $$UPD^DGENDBS(408.22,+DGINR,.DATA)
"RTN","DGMTR",191,0)
 D GETINCOM^DGMTU4(DFN,TDATE)
"RTN","DGMTR",192,0)
 Q RET
"RTN","DGMTR",193,0)
NOL ;Update means test status to NO LONGER REQUIRED
"RTN","DGMTR",194,0)
 N DGMTA,DGINI,DGINR,DGMTDT,DATA
"RTN","DGMTR",195,0)
 I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D  G NOLQ ; Check for converted IVM MT
"RTN","DGMTR",196,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",197,0)
 . S DGNOIVMUPD=2 ; Prevent double printing of the message
"RTN","DGMTR",198,0)
 W:'$G(DGMSGF) !,"MEANS TEST NO LONGER REQUIRED"
"RTN","DGMTR",199,0)
 ;may have set prior MT for means test upload
"RTN","DGMTR",200,0)
 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
"RTN","DGMTR",201,0)
 ;save the Test Determined Status
"RTN","DGMTR",202,0)
 D SAVESTAT^DGMTU4(DGMTI)
"RTN","DGMTR",203,0)
 S DATA(.03)=3,DATA(.17)=DT I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
"RTN","DGMTR",204,0)
 D QUE
"RTN","DGMTR",205,0)
 ;create a Rx copay test based on MT if needed
"RTN","DGMTR",206,0)
 D COPYRX^DGMTR1(DFN,DGMTI)
"RTN","DGMTR",207,0)
NOLQ Q
"RTN","DGMTR",208,0)
SET ;Set Cross-reference
"RTN","DGMTR",209,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGMTR",210,0)
 S DA=DGIEN,X=DGVAL,DGIX=0
"RTN","DGMTR",211,0)
 F  S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX  X ^(DGIX,1) S X=DGVAL
"RTN","DGMTR",212,0)
 Q
"RTN","DGMTR",213,0)
KILL ;Kill Cross-reference
"RTN","DGMTR",214,0)
 N D0,DA,DIV,DGIX,X
"RTN","DGMTR",215,0)
 S DA=DGIEN,X=DGVAL,DGIX=0
"RTN","DGMTR",216,0)
 F  S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX  X ^(DGIX,2) S X=DGVAL
"RTN","DGMTR",217,0)
 Q
"RTN","DGMTR",218,0)
QUE ;Queue means test event driver
"RTN","DGMTR",219,0)
 D AFTER^DGMTEVT
"RTN","DGMTR",220,0)
 S ZTDESC="MEANS TEST EVENT DRIVER",ZTDTH=$H,ZTRTN="EN^DGMTEVT"
"RTN","DGMTR",221,0)
 F I="DFN","DGMTACT","DGMTI","DGMTP","DGMTA","DGMTYPT" S ZTSAVE(I)=""
"RTN","DGMTR",222,0)
 S ZTSAVE("DGMTINF")=1
"RTN","DGMTR",223,0)
 I $D(IVMZ10) S ZTSAVE("IVMZ10")=""
"RTN","DGMTR",224,0)
 I $D(DGENUPLD) S ZTSAVE("DGENUPLD")=""
"RTN","DGMTR",225,0)
 S ZTIO="" D ^%ZTLOAD
"RTN","DGMTR",226,0)
 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","DGMTR",227,0)
 Q
"RTN","DGMTR",228,0)
SELIG ;Check if secondary eligibility code missing from ELIGIBILITY CODE
"RTN","DGMTR",229,0)
 ;file (#8) or entry in file #8 not pointing to MAS ELIGIBILITY
"RTN","DGMTR",230,0)
 ;CODE file (#8.1)
"RTN","DGMTR",231,0)
 N DGTXT
"RTN","DGMTR",232,0)
 S DGF=$G(^DIC(8,+DG,0)) I DGF="" D  Q
"RTN","DGMTR",233,0)
 .S DGTXT(4)="Entry with an IEN OF "_DG_" missing from"
"RTN","DGMTR",234,0)
 .S DGTXT(5)="the ELIGIBILITY CODE file (#8)"
"RTN","DGMTR",235,0)
 .D MAIL^DGMTR1
"RTN","DGMTR",236,0)
 .Q
"RTN","DGMTR",237,0)
 S DGF=$P(DGF,"^",9) I DGF=""!('$D(^DIC(8.1,+DGF,0))) D
"RTN","DGMTR",238,0)
 .S DGTXT(4)="ELIGIBILITY CODE file (#8) entry with an IEN OF "_DG_" doesn't"
"RTN","DGMTR",239,0)
 .S DGTXT(5)="have a valid pointer to the MAS ELIGIBILITY CODE file (#8.1)"
"RTN","DGMTR",240,0)
 .D MAIL^DGMTR1
"RTN","DGMTR",241,0)
 .S DGF=""
"RTN","DGMTR",242,0)
 .Q
"RTN","DGMTR",243,0)
 Q
"RTN","DGMTR1")
0^3^B32321945
"RTN","DGMTR1",1,0)
DGMTR1 ;ALB/CJM,SCG,LBD - 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**;Aug 13, 1993;Build 20
"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)
 .;must still be effective
"RTN","DGMTR1",33,0)
 .Q:($$FMDIFF^XLFDT(DT,$P(NODE0,"^"))>365)
"RTN","DGMTR1",34,0)
 .Q:$$OLD^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
"VER")
8.0^22.0
"^DD",2,2,.39,0)
VETERAN CATASTROPHICALLY DISABLED?^S^Y:YES;N:NO;^.39;6^Q
"^DD",2,2,.39,1,0)
^.1
"^DD",2,2,.39,1,1,0)
2^VCD^MUMPS
"^DD",2,2,.39,1,1,1)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.39,1,1,2)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.39,1,1,"%D",0)
^.101^2^2^3110301^^
"^DD",2,2,.39,1,1,"%D",1,0)
This cross-reference is used to auto-update the patients
"^DD",2,2,.39,1,1,"%D",2,0)
PATIENT ENROLLMENT (#27.11) record.
"^DD",2,2,.39,1,1,"DT")
2990618
"^DD",2,2,.39,1,2,0)
2^AVCDMT^MUMPS
"^DD",2,2,.39,1,2,1)
N DFN,DGMT,DGNOCOPF,DGREQF,DGWRT,IVMZ10F S DFN=DA D EN^DGMTR
"^DD",2,2,.39,1,2,2)
N DFN,DGMT,DGNOCOPF,DGREQF,DGWRT,IVMZ10F S DFN=DA D EN^DGMTR
"^DD",2,2,.39,1,2,"%D",0)
^^20^20^3110302^
"^DD",2,2,.39,1,2,"%D",1,0)
This cross-reference calls the Means Test software.
"^DD",2,2,.39,1,2,"%D",2,0)
If answered 'YES', then a Means Test is not
"^DD",2,2,.39,1,2,"%D",3,0)
required and the Rx Copay is exempt.
"^DD",2,2,.39,1,2,"%D",4,0)
Executing this cross-reference will result in the
"^DD",2,2,.39,1,2,"%D",5,0)
following file and field changes:
"^DD",2,2,.39,1,2,"%D",6,0)
 
"^DD",2,2,.39,1,2,"%D",7,0)
ANNUAL MEANS TEST FILE (#408.31)
"^DD",2,2,.39,1,2,"%D",8,0)
  Field: STATUS (#.03)
"^DD",2,2,.39,1,2,"%D",9,0)
  When a veteran is determined to be Catastrophically Disabled, the STATUS
"^DD",2,2,.39,1,2,"%D",10,0)
field is set to NO LONGER APPLICABLE.
"^DD",2,2,.39,1,2,"%D",11,0)
  When a Catastrophically Disabled veteran is no longer determined to be
"^DD",2,2,.39,1,2,"%D",12,0)
Catastrophically Disabled, then the STATUS field is set to one of the
"^DD",2,2,.39,1,2,"%D",13,0)
sixteen possible Means Test statuses.
"^DD",2,2,.39,1,2,"%D",14,0)
 
"^DD",2,2,.39,1,2,"%D",15,0)
BILLING EXEMPTIONS FILE (#354.1)
"^DD",2,2,.39,1,2,"%D",16,0)
  Field: STATUS (#.04)
"^DD",2,2,.39,1,2,"%D",17,0)
  When a veteran is determined to be Catastrophically Disabled, the STATUS
"^DD",2,2,.39,1,2,"%D",18,0)
field is set to EXEMPT.
"^DD",2,2,.39,1,2,"%D",19,0)
  When a Catastrophically Disabled veteran is no longer determined to be
"^DD",2,2,.39,1,2,"%D",20,0)
Catastrophically Disabled, then the STATUS field is set to NON-EXEMPT.
"^DD",2,2,.39,1,2,"DT")
3110302
"^DD",2,2,.39,21,0)
^.001^2^2^3110301^^^^
"^DD",2,2,.39,21,1,0)
This field states whether or not the patient is a veteran who has been
"^DD",2,2,.39,21,2,0)
determined to meet the criteria for CATASTROPHICALLY DISABLED.
"^DD",2,2,.39,"DT")
3110302
"^DD",2,2,.541,0)
CURRENT MOH INDICATOR^S^Y:YES;N:NO;^.54;1^Q
"^DD",2,2,.541,1,0)
^.1
"^DD",2,2,.541,1,1,0)
2^AMHEN^MUMPS
"^DD",2,2,.541,1,1,1)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.541,1,1,2)
D AUTOUPD^DGENA2(DA)
"^DD",2,2,.541,1,1,3)
DO NOT DELETE
"^DD",2,2,.541,1,1,"%D",0)
^^2^2^3110302^
"^DD",2,2,.541,1,1,"%D",1,0)
This cross-reference is used to update the patient's current PATIENT 
"^DD",2,2,.541,1,1,"%D",2,0)
ENROLLMENT (#27.11) record.
"^DD",2,2,.541,1,1,"DT")
3110302
"^DD",2,2,.541,1,2,0)
2^AMHMT^MUMPS
"^DD",2,2,.541,1,2,1)
N DFN,DGMT,DGNOCOPF,DGREQF,DGWRT,IVMZ10F S DFN=DA D EN^DGMTR
"^DD",2,2,.541,1,2,2)
N DFN,DGMT,DGNOCOPF,DGREQF,DGWRT,IVMZ10F S DFN=DA D EN^DGMTR
"^DD",2,2,.541,1,2,"%D",0)
^.101^5^5^3110302^^
"^DD",2,2,.541,1,2,"%D",1,0)
This cross-ref calls the Means Test software. If the PATIENT file (#2), 
"^DD",2,2,.541,1,2,"%D",2,0)
CURRENT MOH INDICATOR field (#.541) is set to 'YES', then the PATIENT 
"^DD",2,2,.541,1,2,"%D",3,0)
file (#2), CURRENT MEANS TEST STATUS field (#.14) is set to '3'.  '3' is 
"^DD",2,2,.541,1,2,"%D",4,0)
a pointer to the MEANS TEST STATUS file (#408.32) and indicates that the 
"^DD",2,2,.541,1,2,"%D",5,0)
Means Test is 'NO LONGER REQUIRED.'
"^DD",2,2,.541,1,2,"DT")
3110302
"^DD",2,2,.541,3)
If the patient is a veteran, enter 'Y' if Medal of Honor has been awarded, or 'N' if Medal of Honor has not been awarded.
"^DD",2,2,.541,21,0)
^.001^3^3^3110301^^
"^DD",2,2,.541,21,1,0)
This field cannot be edited in VistA.  It is set by the Z11 Upload from 
"^DD",2,2,.541,21,2,0)
HEC.  A response of 'YES' or 'NO' is indicated only if the patient is a 
"^DD",2,2,.541,21,3,0)
veteran.
"^DD",2,2,.541,"DT")
3110302
"^DD",27.11,27.11,50.23,0)
MEDAL OF HONOR INDICATED?^S^Y:YES;N:NO;^E;23^Q
"^DD",27.11,27.11,50.23,3)
If patient has received a Medal of Honor, enter 'Y'. If not, enter 'N'
"^DD",27.11,27.11,50.23,21,0)
^^3^3^3110217^
"^DD",27.11,27.11,50.23,21,1,0)
This field corresponds to the CURRENT MOH INDICATOR (#.541) field in the 
"^DD",27.11,27.11,50.23,21,2,0)
PATIENT (#2) file. It is set by the Medal of Honor Indicated in the 
"^DD",27.11,27.11,50.23,21,3,0)
Registration screens, or by the Z11 Upload from HEC.
"^DD",27.11,27.11,50.23,23,0)
^^2^2^3110217^
"^DD",27.11,27.11,50.23,23,1,0)
This field is updated by the F cross-reference on the CURRENT MOH 
"^DD",27.11,27.11,50.23,23,2,0)
INDICATOR (#.541) field in the PATIENT (#2) file.
"^DD",27.11,27.11,50.23,"DT")
3110214
**INSTALL NAME**
IB*2.0*449
"BLD",8187,0)
IB*2.0*449^INTEGRATED BILLING^0^3110518^y
"BLD",8187,1,0)
^^1^1^3110222^
"BLD",8187,1,1,0)
CD PATIENT COPAY EXEMPTION
"BLD",8187,4,0)
^9.64PA^^
"BLD",8187,6.3)
15
"BLD",8187,"ABPKG")
n
"BLD",8187,"INIT")
POST^IB20P449
"BLD",8187,"KRN",0)
^9.67PA^779.2^20
"BLD",8187,"KRN",.4,0)
.4
"BLD",8187,"KRN",.401,0)
.401
"BLD",8187,"KRN",.402,0)
.402
"BLD",8187,"KRN",.403,0)
.403
"BLD",8187,"KRN",.5,0)
.5
"BLD",8187,"KRN",.84,0)
.84
"BLD",8187,"KRN",3.6,0)
3.6
"BLD",8187,"KRN",3.8,0)
3.8
"BLD",8187,"KRN",9.2,0)
9.2
"BLD",8187,"KRN",9.8,0)
9.8
"BLD",8187,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",8187,"KRN",9.8,"NM",1,0)
IBARXEU1^^0^B17685834
"BLD",8187,"KRN",9.8,"NM",2,0)
IBOCDRPT^^0^B17809803
"BLD",8187,"KRN",9.8,"NM","B","IBARXEU1",1)

"BLD",8187,"KRN",9.8,"NM","B","IBOCDRPT",2)

"BLD",8187,"KRN",19,0)
19
"BLD",8187,"KRN",19,"NM",0)
^9.68A^2^2
"BLD",8187,"KRN",19,"NM",1,0)
IB CD CHARGE REPORT^^0
"BLD",8187,"KRN",19,"NM",2,0)
IB OUTPUT PATIENT REPORT MENU^^2
"BLD",8187,"KRN",19,"NM","B","IB CD CHARGE REPORT",1)

"BLD",8187,"KRN",19,"NM","B","IB OUTPUT PATIENT REPORT MENU",2)

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

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

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

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

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

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

"BLD",8187,"KRN","B",3.6,3.6)

"BLD",8187,"KRN","B",3.8,3.8)

"BLD",8187,"KRN","B",9.2,9.2)

"BLD",8187,"KRN","B",9.8,9.8)

"BLD",8187,"KRN","B",19,19)

"BLD",8187,"KRN","B",19.1,19.1)

"BLD",8187,"KRN","B",101,101)

"BLD",8187,"KRN","B",409.61,409.61)

"BLD",8187,"KRN","B",771,771)

"BLD",8187,"KRN","B",779.2,779.2)

"BLD",8187,"KRN","B",870,870)

"BLD",8187,"KRN","B",8989.51,8989.51)

"BLD",8187,"KRN","B",8989.52,8989.52)

"BLD",8187,"KRN","B",8994,8994)

"BLD",8187,"PRE")
IB20P449
"BLD",8187,"QUES",0)
^9.62^^0
"BLD",8187,"REQB",0)
^9.611^1^1
"BLD",8187,"REQB",1,0)
IB*2.0*367^2
"BLD",8187,"REQB","B","IB*2.0*367",1)

"INIT")
POST^IB20P449
"KRN",19,2323,-1)
2^2
"KRN",19,2323,0)
IB OUTPUT PATIENT REPORT MENU^Patient Billing Reports Menu^^M^1258^^^^^^^49
"KRN",19,2323,10,0)
^19.01IP^32^32
"KRN",19,2323,10,32,0)
11132^CD
"KRN",19,2323,10,32,"^")
IB CD CHARGE REPORT
"KRN",19,2323,"U")
PATIENT BILLING REPORTS MENU
"KRN",19,11132,-1)
0^1
"KRN",19,11132,0)
IB CD CHARGE REPORT^Catastrophically Disabled Copay Report^^R^^^^^^^^INTEGRATED BILLING
"KRN",19,11132,1,0)
^^6^6^3110321^
"KRN",19,11132,1,1,0)
This will produce a report of Catastrophically Disabled patients with
"KRN",19,11132,1,2,0)
charges.  The Catastrophically Disabled legislation effective date is May
"KRN",19,11132,1,3,0)
5, 2010.  You should not enter a date prior to that date, any date entered
"KRN",19,11132,1,4,0)
before that will be automatically changed to May 5, 2010.  It should be
"KRN",19,11132,1,5,0)
queued to a printer off hours as it can take some time to run with at
"KRN",19,11132,1,6,0)
least a margin of 132 columns.
"KRN",19,11132,25)
EN^IBOCDRPT
"KRN",19,11132,"U")
CATASTROPHICALLY DISABLED COPA
"MBREQ")
0
"ORD",18,19)
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
"ORD",18,19,0)
OPTION
"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)
449^3110518^100992
"PKG",49,22,1,"PAH",1,1,0)
^^1^1^3110518
"PKG",49,22,1,"PAH",1,1,1,0)
CD PATIENT COPAY EXEMPTION
"PRE")
IB20P449
"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","IB20P449")
0^^B10083206
"RTN","IB20P449",1,0)
IB20P449 ;ELZ/OAK - POST INIT FOR PATCH;02/22/2011
"RTN","IB20P449",2,0)
 ;;2.0;INTEGRATED BILLING;**449**;21-MAR-94;Build 15
"RTN","IB20P449",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IB20P449",4,0)
 ;
"RTN","IB20P449",5,0)
 ;
"RTN","IB20P449",6,0)
ENV ;
"RTN","IB20P449",7,0)
 ; setup so no queue of install
"RTN","IB20P449",8,0)
 S XPDNOQUE=1
"RTN","IB20P449",9,0)
 Q
"RTN","IB20P449",10,0)
 ;
"RTN","IB20P449",11,0)
POST ; post init entry point
"RTN","IB20P449",12,0)
 ;
"RTN","IB20P449",13,0)
 D MES^XPDUTL("  Starting post-init for IB*2.0*449")
"RTN","IB20P449",14,0)
 ;
"RTN","IB20P449",15,0)
 D 3542
"RTN","IB20P449",16,0)
 D 3503
"RTN","IB20P449",17,0)
 D REPORT
"RTN","IB20P449",18,0)
 ;
"RTN","IB20P449",19,0)
 D MES^XPDUTL("  Finished post-init for IB*2.0*449")
"RTN","IB20P449",20,0)
 ;
"RTN","IB20P449",21,0)
 Q
"RTN","IB20P449",22,0)
 ;
"RTN","IB20P449",23,0)
3542 ; add entry to exemption file 354.2 if not there
"RTN","IB20P449",24,0)
 I $O(^IBE(354.2,"B","CATASTROPHICALLY DISABLED",0)) D  Q
"RTN","IB20P449",25,0)
 . D MES^XPDUTL("    - CATASTROPHICALLY DISABLED already exists, nothing to add to 354.2.")
"RTN","IB20P449",26,0)
 ;
"RTN","IB20P449",27,0)
 N DO,X,Y,DIC
"RTN","IB20P449",28,0)
 ;
"RTN","IB20P449",29,0)
 S X="CATASTROPHICALLY DISABLED",DIC="^IBE(354.2,",DIC(0)=""
"RTN","IB20P449",30,0)
 S DIC("DR")=".02///Patient is Catastrophically Disabled;.03///1;.04///1;.05///100"
"RTN","IB20P449",31,0)
 D FILE^DICN
"RTN","IB20P449",32,0)
 ;
"RTN","IB20P449",33,0)
 D MES^XPDUTL($S(Y>1:"    - CATASTROPHICALLY DISABLED Exemption Reason (#354.2) added.",1:"*** ERROR: COULD NOT CREATE NEW CD ENTRY IN 354.2 ***"))
"RTN","IB20P449",34,0)
 ;
"RTN","IB20P449",35,0)
 Q
"RTN","IB20P449",36,0)
 ;
"RTN","IB20P449",37,0)
3503 ; add entry to Charge Removal Reason file if not there
"RTN","IB20P449",38,0)
 ;
"RTN","IB20P449",39,0)
 N IBX,DO,DIC,X,Y
"RTN","IB20P449",40,0)
 ;
"RTN","IB20P449",41,0)
 D MES^XPDUTL("    - Adding entry to Charge Removal Reason (#350.3) file.")
"RTN","IB20P449",42,0)
 S IBX="CATASTROPHICALLY DISABLED^CD" D
"RTN","IB20P449",43,0)
 . K DO S DIC="^IBE(350.3,",DIC(0)="",X=$P(IBX,"^")
"RTN","IB20P449",44,0)
 . S DIC("DR")=".02///^S X=$P(IBX,U,2);.03///3"
"RTN","IB20P449",45,0)
 . I $O(^IBE(350.3,"B",X,0)) D MES^XPDUTL("      - "_X_" already exists.") Q
"RTN","IB20P449",46,0)
 . D FILE^DICN
"RTN","IB20P449",47,0)
 . D MES^XPDUTL($S(Y>1:"      - "_$P(IBX,"^")_" entry added.",1:"*** ERROR: COULD NOT CREATE NEW "_$P(IBX,"^",2)_" ENTRY IN 350.3 ***"))
"RTN","IB20P449",48,0)
 ;
"RTN","IB20P449",49,0)
 D MES^XPDUTL("    - Done adding entry in Charge Removal Reason (#350.3) file.")
"RTN","IB20P449",50,0)
 Q
"RTN","IB20P449",51,0)
 ;
"RTN","IB20P449",52,0)
REPORT ; - this will produce a report of patient's with charges that are CD.
"RTN","IB20P449",53,0)
 ;
"RTN","IB20P449",54,0)
 N POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBA,IBEDT,IBBDT,ZTSAVE
"RTN","IB20P449",55,0)
 S IBBDT=3100504,IBEDT=DT
"RTN","IB20P449",56,0)
 S IBA(1)="Select the device for the Catastrophically Disabled Charge report.  It"
"RTN","IB20P449",57,0)
 S IBA(2)="should be queued to a printer off hours as it can take some time to run"
"RTN","IB20P449",58,0)
 S IBA(3)="with at least a margin of 132 columns."
"RTN","IB20P449",59,0)
 D MES^XPDUTL(.IBA)
"RTN","IB20P449",60,0)
 S %ZIS="QM" D ^%ZIS Q:POP
"RTN","IB20P449",61,0)
 I $D(IO("Q")) D  Q
"RTN","IB20P449",62,0)
 .S ZTRTN="DQ^IBOCDRPT",ZTDESC="Catastrophically Disabled Copay Report"
"RTN","IB20P449",63,0)
 .S (ZTSAVE("IBEDT"),ZTSAVE("IBBDT"))=""
"RTN","IB20P449",64,0)
 .D ^%ZTLOAD D HOME^%ZIS K IO("Q")
"RTN","IB20P449",65,0)
 .D MES^XPDUTL("Catastrophically Disabled Copay Report queued #"_ZTSK)
"RTN","IB20P449",66,0)
 D DQ^IBOCDRPT
"RTN","IB20P449",67,0)
 Q
"RTN","IBARXEU1")
0^1^B17685834
"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**;21-MAR-94;Build 15
"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)
AUTOSTQ I IBEXREA="" Q IBEXREA
"RTN","IBARXEU1",38,0)
 Q $O(^IBE(354.2,"ACODE",+IBEXREA,0))_"^"_IBDT
"RTN","IBARXEU1",39,0)
 ;
"RTN","IBARXEU1",40,0)
 ;
"RTN","IBARXEU1",41,0)
INCST(DFN,IBDT) ; -- return medication copayment exemption reason/date
"RTN","IBARXEU1",42,0)
 ; -- ask mas for income data
"RTN","IBARXEU1",43,0)
 ;
"RTN","IBARXEU1",44,0)
 ;    returns :  = exemption reason (pointer to 354.2) ^ date
"RTN","IBARXEU1",45,0)
 ;
"RTN","IBARXEU1",46,0)
 N IBDATA,X,DGMT,CLN,CONV
"RTN","IBARXEU1",47,0)
 S IBDATA=$G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,IBDT,3),0)) ;get any test
"RTN","IBARXEU1",48,0)
 I $$PLUS^IBARXEU0(+IBDATA)<IBDT S X=$O(^IBE(354.2,"ACODE",210,0))_"^"_IBDT G INCSTQ ; means test too old -no data
"RTN","IBARXEU1",49,0)
 I $P(IBDATA,U,23)=2 D  G:CONV INCSTQ ;skip Edb conv. tests
"RTN","IBARXEU1",50,0)
 .;Loop through the MT comments, Check for EDB converted test
"RTN","IBARXEU1",51,0)
 .;No comments to check
"RTN","IBARXEU1",52,0)
 .S (CLN,CONV)=0,DGMT=$$LST^DGMTCOU1(DFN,IBDT,3)
"RTN","IBARXEU1",53,0)
 .F  S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV)  D
"RTN","IBARXEU1",54,0)
 ..;If most recent test is a converted test use current info from IBA(354
"RTN","IBARXEU1",55,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",56,0)
 ;
"RTN","IBARXEU1",57,0)
 I $$NETW^IBARXEU1 S X=$$MTCOMP^IBARXEU5($$INCDT(IBDATA),IBDATA)
"RTN","IBARXEU1",58,0)
 I '$$NETW^IBARXEU1 S X=$$INCDT(IBDATA),X=$P(X,"^",3)_"^"_$P(X,"^",2)
"RTN","IBARXEU1",59,0)
INCSTQ Q X
"RTN","IBARXEU1",60,0)
 ;
"RTN","IBARXEU1",61,0)
INCDT(IBDATA) ; -- calcualtes copay exemption status based on income
"RTN","IBARXEU1",62,0)
 ; and net worth
"RTN","IBARXEU1",63,0)
 ;    input  := zeroth node from 408.31
"RTN","IBARXEU1",64,0)
 ;    output := 1 = exempt    ^date of test^ exemption reason 
"RTN","IBARXEU1",65,0)
 ;              2 = non-exempt^...
"RTN","IBARXEU1",66,0)
 ;              3 = pending adjudication (if active)^...
"RTN","IBARXEU1",67,0)
 ;
"RTN","IBARXEU1",68,0)
 N X,IBDT,IBINCOM,IBEXREA,IBDEPEN,IBNETW,IBTABLE,IBLEVEL,IBTHRES
"RTN","IBARXEU1",69,0)
 I '$D(DFN) N DFN S DFN=$P(IBDATA,"^",2)
"RTN","IBARXEU1",70,0)
 S IBEXREA=""
"RTN","IBARXEU1",71,0)
 ;
"RTN","IBARXEU1",72,0)
 ; -- if test incomplete, no longer required, no longer applicable, or
"RTN","IBARXEU1",73,0)
 ;    required set to no income data 
"RTN","IBARXEU1",74,0)
 ;    autoexempt test should be done first before getting to here
"RTN","IBARXEU1",75,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",76,0)
 ;
"RTN","IBARXEU1",77,0)
 S IBDT=+IBDATA
"RTN","IBARXEU1",78,0)
 S IBINCOM=$P(IBDATA,"^",4)-$P(IBDATA,"^",15) I IBINCOM<0 S IBINCOM=0
"RTN","IBARXEU1",79,0)
 S IBDEPEN=$P(IBDATA,"^",18),IBNETW=$P(IBDATA,"^",5)
"RTN","IBARXEU1",80,0)
 ;
"RTN","IBARXEU1",81,0)
 ; -- get A&A income level
"RTN","IBARXEU1",82,0)
 ;S IBLEVEL=$$THRES(IBDT,2,IBDEPEN)
"RTN","IBARXEU1",83,0)
 S IBLEVEL=$$THRES(IBDT,$S($E(IBDT,1,5)'<29612:1,1:2),IBDEPEN)
"RTN","IBARXEU1",84,0)
 I $P(IBLEVEL,"^",3) S IBPRIOR=$P(IBLEVEL,"^",3)
"RTN","IBARXEU1",85,0)
 ;
"RTN","IBARXEU1",86,0)
 S IBEXREA=120 ; low income
"RTN","IBARXEU1",87,0)
 I IBINCOM>+IBLEVEL S IBEXREA=110 G NO ;high income not exempt
"RTN","IBARXEU1",88,0)
 ;
"RTN","IBARXEU1",89,0)
 I '$$NETW G NO
"RTN","IBARXEU1",90,0)
 ;
"RTN","IBARXEU1",91,0)
 ; -- get networth threshold amount
"RTN","IBARXEU1",92,0)
 S IBTHRES=+$$THRES(IBDT,4,0)
"RTN","IBARXEU1",93,0)
 ; -- low income check for net worth
"RTN","IBARXEU1",94,0)
 S IBEXREA=$S((IBINCOM+IBNETW)>IBTHRES:130,1:120)
"RTN","IBARXEU1",95,0)
 ;
"RTN","IBARXEU1",96,0)
NO ; -- not enough information
"RTN","IBARXEU1",97,0)
 I IBEXREA="" S IBEXREA=210
"RTN","IBARXEU1",98,0)
 ;
"RTN","IBARXEU1",99,0)
 I $$NETW S Y=$S(IBEXREA=110:2,IBEXREA=120:1,IBEXREA=130:3,1:2)
"RTN","IBARXEU1",100,0)
 I '$$NETW S Y=$S(IBEXREA=120:1,1:2)
"RTN","IBARXEU1",101,0)
 ;
"RTN","IBARXEU1",102,0)
INCDTQ Q Y_"^"_+IBDATA_"^"_$O(^IBE(354.2,"ACODE",+IBEXREA,0))
"RTN","IBARXEU1",103,0)
 ;
"RTN","IBARXEU1",104,0)
THRES(DATE,TYPE,DEPEND) ; -- return threshold amount 
"RTN","IBARXEU1",105,0)
 ;
"RTN","IBARXEU1",106,0)
 ; -- if date is less than 12/1/92 will use 12/1 92 rates
"RTN","IBARXEU1",107,0)
 ;     date =: fileman format of effective date
"RTN","IBARXEU1",108,0)
 ;     type =: 2= pension plus A&A   1992 thru 1995
"RTN","IBARXEU1",109,0)
 ;     type =: 1= basic pension 1996 to present
"RTN","IBARXEU1",110,0)
 ;     depend =: number of dependents
"RTN","IBARXEU1",111,0)
 ;
"RTN","IBARXEU1",112,0)
 ; -- returns rate^effective date^prior year
"RTN","IBARXEU1",113,0)
 ;
"RTN","IBARXEU1",114,0)
 I DATE<2921201 S DATE=2921201 ; use threshold rates from 12/1/92
"RTN","IBARXEU1",115,0)
 N IBTABLE,IBLEVEL,IBPRIOR
"RTN","IBARXEU1",116,0)
 S IBLEVEL=""
"RTN","IBARXEU1",117,0)
 ; -- get entry to determine income amounts
"RTN","IBARXEU1",118,0)
 S IBTABLE=$G(^IBE(354.3,+$O(^(+$O(^IBE(354.3,"AIVDT",TYPE,-(DATE+.000001))),0)),0))
"RTN","IBARXEU1",119,0)
 G:IBTABLE="" THRESQ
"RTN","IBARXEU1",120,0)
 I TYPE=4 S DEPEND=0
"RTN","IBARXEU1",121,0)
 ;
"RTN","IBARXEU1",122,0)
 ; --see if rate is for prior year
"RTN","IBARXEU1",123,0)
 S IBPRIOR="" I $$PLUS^IBARXEU0(+IBTABLE)<DATE S IBPRIOR=+IBTABLE
"RTN","IBARXEU1",124,0)
 ;
"RTN","IBARXEU1",125,0)
 ; -- rates begin in piece 3 for veteran alone, piece 4 for 1 dependent..
"RTN","IBARXEU1",126,0)
 S IBLEVEL=$S(DEPEND<9:$P(IBTABLE,"^",DEPEND+3),1:"")
"RTN","IBARXEU1",127,0)
 I IBLEVEL="" S IBLEVEL=$P(IBTABLE,"^",4)+((DEPEND-1)*$P(IBTABLE,"^",12))
"RTN","IBARXEU1",128,0)
THRESQ Q IBLEVEL_"^"_+IBTABLE_"^"_IBPRIOR
"RTN","IBARXEU1",129,0)
 ;
"RTN","IBARXEU1",130,0)
NETW() ; -- use networth in determining copay exemptions - specs keep changing
"RTN","IBARXEU1",131,0)
 ;    returns 1 if should use networth in exemption determination
"RTN","IBARXEU1",132,0)
 ;    returns 0 if should not use networth in exemption
"RTN","IBARXEU1",133,0)
 Q 0
"RTN","IBOCDRPT")
0^2^B17809803
"RTN","IBOCDRPT",1,0)
IBOCDRPT ;ELZ/OAK - CATASTROPHICALLY DISABLED PATIENT BILLING ;03/21/2011
"RTN","IBOCDRPT",2,0)
 ;;2.0;INTEGRATED BILLING;**449**;21-MAR-94;Build 15
"RTN","IBOCDRPT",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBOCDRPT",4,0)
 ;
"RTN","IBOCDRPT",5,0)
 ;
"RTN","IBOCDRPT",6,0)
EN ; - this will produce a report of patient's with charges that are CD.
"RTN","IBOCDRPT",7,0)
 ;
"RTN","IBOCDRPT",8,0)
 N POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBEDT,IBBDT,%DT,ZTSAVE
"RTN","IBOCDRPT",9,0)
 W !,"The Catastrophically Disabled legislation effective date is May 5, 2010."
"RTN","IBOCDRPT",10,0)
 W !,"You should not enter a date prior to that date, any date entered before"
"RTN","IBOCDRPT",11,0)
 W !,"that will be automatically changed to May 5, 2010."
"RTN","IBOCDRPT",12,0)
 S %DT(0)=3100505,%DT("B")="May 5, 2010"
"RTN","IBOCDRPT",13,0)
 D DATE^IBOUTL Q:'IBEDT
"RTN","IBOCDRPT",14,0)
 ;
"RTN","IBOCDRPT",15,0)
 W !!,"Select the device for the Catastrophically Disabled Charge report.  It"
"RTN","IBOCDRPT",16,0)
 W !,"should be queued to a printer off hours as it can take some time to run"
"RTN","IBOCDRPT",17,0)
 W !,"with at least a margin of 132 columns."
"RTN","IBOCDRPT",18,0)
 S %ZIS="QM" D ^%ZIS Q:POP
"RTN","IBOCDRPT",19,0)
 I $D(IO("Q")) D  Q
"RTN","IBOCDRPT",20,0)
 .S ZTRTN="DQ^IBOCDRPT",ZTDESC="Catastrophically Disabled Copay Report"
"RTN","IBOCDRPT",21,0)
 .S (ZTSAVE("IBEDT"),ZTSAVE("IBBDT"))=""
"RTN","IBOCDRPT",22,0)
 .D ^%ZTLOAD D HOME^%ZIS K IO("Q")
"RTN","IBOCDRPT",23,0)
 .D MES^XPDUTL("Catastrophically Disabled Copay Report queued #"_ZTSK)
"RTN","IBOCDRPT",24,0)
DQ U IO
"RTN","IBOCDRPT",25,0)
 ;
"RTN","IBOCDRPT",26,0)
 N IBX,IBZ,IBDT,IBDG,DFN,IBP,IBARX,IBARBILL,IBARDATA,IBDPT,IBDDT,IBQUIT
"RTN","IBOCDRPT",27,0)
 ;
"RTN","IBOCDRPT",28,0)
 S (IBP,IBQUIT)=0
"RTN","IBOCDRPT",29,0)
 D HEAD
"RTN","IBOCDRPT",30,0)
 I IBBDT<3100505 S IBBDT=3100505 ; not before CD effective date
"RTN","IBOCDRPT",31,0)
 S IBDDT=IBBDT-1 F  S IBDDT=$O(^IB("D",IBDDT)) Q:'IBDDT!(IBQUIT)  S IBX=0 F  S IBX=$O(^IB("D",IBDDT,IBX)) Q:'IBX!(IBQUIT)  D
"RTN","IBOCDRPT",32,0)
 . S IBZ=$G(^IB(IBX,0)),DFN=+$P(IBZ,"^",2)
"RTN","IBOCDRPT",33,0)
 . S IBDT=$S($E($P(IBZ,"^",4),1,2)=52:IBDDT,$P(IBZ,"^",8)="RX COPAYMENT":IBDDT,$P(IBZ,"^",15):$P(IBZ,"^",15),1:$P(IBZ,"^",14))
"RTN","IBOCDRPT",34,0)
 . K IBDG
"RTN","IBOCDRPT",35,0)
 . S IBDG=$$GET^DGENCDA(DFN,.IBDG)  ; IA# 4969
"RTN","IBOCDRPT",36,0)
 . S IBARX=+$O(^PRCA(430,"B",$S($P(IBZ,"^",11):$P(IBZ,"^",11),1:0),0))  ; IA# 389
"RTN","IBOCDRPT",37,0)
 . S IBARBILL=$S(IBARX:$$BILL^RCJIBFN2(IBARX),1:"")  ; IA# 1452
"RTN","IBOCDRPT",38,0)
 . K IBARDATA
"RTN","IBOCDRPT",39,0)
 . I IBARX D DIQ^RCJIBFN2(IBARX,"77:79;141;203;255.1","IBARDATA") ; IA# 1452
"RTN","IBOCDRPT",40,0)
 . ;
"RTN","IBOCDRPT",41,0)
 . ; quit if no date, status cancelled (ib) or pt not CD, or no charge
"RTN","IBOCDRPT",42,0)
 . Q:'IBDT!($P(IBZ,"^",5)=10)!($G(IBDG("VCD"))'="Y")!('$P(IBZ,"^",7))
"RTN","IBOCDRPT",43,0)
 . ; quit if cancelled in AR (if passed)
"RTN","IBOCDRPT",44,0)
 . I IBARX,$P(IBARBILL,"^",2)=26 Q
"RTN","IBOCDRPT",45,0)
 . ; quit if CD effective date not before event date
"RTN","IBOCDRPT",46,0)
 . Q:IBDT<3100505!(IBDT<$G(IBDG("DATE")))
"RTN","IBOCDRPT",47,0)
 . ; quit if not within specified date range
"RTN","IBOCDRPT",48,0)
 . Q:IBDT<IBBDT!($P(IBDT,".")>(IBEDT+1))
"RTN","IBOCDRPT",49,0)
 . ; quit if LTC inpatient
"RTN","IBOCDRPT",50,0)
 . I $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^")["DG LTC INPT"!($P($G(^(0)),"^")["DG LTC FEE INPT") Q
"RTN","IBOCDRPT",51,0)
 . ;
"RTN","IBOCDRPT",52,0)
 . S IBDPT=$G(^DPT(DFN,0))
"RTN","IBOCDRPT",53,0)
 . W !,$E($P(IBDPT,"^"),1,20) ; patient name
"RTN","IBOCDRPT",54,0)
 . W ?22,$E($P(IBDPT,"^",9),6,9) ; last 4 snn
"RTN","IBOCDRPT",55,0)
 . W ?27,$$FMTE^XLFDT($G(IBDG("DATE")),"2DZ") ; Catastrophically Disabled Date, IA# 10103
"RTN","IBOCDRPT",56,0)
 . W ?36,$$FMTE^XLFDT(IBDT,"2DZ") ; date of service, IA# 10103
"RTN","IBOCDRPT",57,0)
 . W:$E($P(IBZ,"^",4),1,2)=52 ?45,$E($P($P(IBZ,"^",8),"-"),1,11) ; rx
"RTN","IBOCDRPT",58,0)
 . W ?57,$E($P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^"),1,9) ; action type
"RTN","IBOCDRPT",59,0)
 . W ?67,$E($P($P(IBZ,"^",11),"-",2),1,8) ; ar bill no
"RTN","IBOCDRPT",60,0)
 . W ?76,$E($P($G(^IBE(350.21,+$P(IBZ,"^",5),0)),"^"),1,8) ; 350 status
"RTN","IBOCDRPT",61,0)
 . W ?85,$J($FN($P(IBARBILL,"^",3),"",2),7) ; current balance
"RTN","IBOCDRPT",62,0)
 . W ?93,$J($FN($G(IBARDATA(430,IBARX,77,"E")),"",2),7) ; pd principal
"RTN","IBOCDRPT",63,0)
 . W ?101,$J($FN($G(IBARDATA(430,IBARX,78,"E")),"",2),5) ; pd int
"RTN","IBOCDRPT",64,0)
 . W ?107,$J($FN($G(IBARDATA(430,IBARX,79,"E")),"",2),5) ; pd admin
"RTN","IBOCDRPT",65,0)
 . W ?113,$$FMTE^XLFDT($G(IBARDATA(430,IBARX,141,"I")),"2DZ") ; IA# 10103
"RTN","IBOCDRPT",66,0)
 . W ?122,$E($G(IBARDATA(430,IBARX,203,"E")),1,6)
"RTN","IBOCDRPT",67,0)
 . W ?129,$E($G(IBARDATA(430,IBARX,255.1,"E")),1,4)
"RTN","IBOCDRPT",68,0)
 . I $Y+3>IOSL D HEAD
"RTN","IBOCDRPT",69,0)
 ; 
"RTN","IBOCDRPT",70,0)
 D ^%ZISC
"RTN","IBOCDRPT",71,0)
EXIT S:$D(ZTQUEUED) ZTREQ="@"
"RTN","IBOCDRPT",72,0)
 Q
"RTN","IBOCDRPT",73,0)
HEAD ;
"RTN","IBOCDRPT",74,0)
 N IBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","IBOCDRPT",75,0)
 I IBP,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I $D(DIRUT) S IBQUIT=1 Q
"RTN","IBOCDRPT",76,0)
 S IBP=IBP+1
"RTN","IBOCDRPT",77,0)
 W @IOF,!,"Catastrophically Disabled Copayment Charge Report                     PAGE: ",IBP,!
"RTN","IBOCDRPT",78,0)
 W "PATIENT                SSN CD DATE   DOS     RX          TYPE      BILL NO  STATUS   BALANCE PD PRIN  INT   ADM   TOP     FUND   RSC",!
"RTN","IBOCDRPT",79,0)
 F IBL=1:1:$S(IOM:IOM,1:132) W "-"
"RTN","IBOCDRPT",80,0)
 Q
"VER")
8.0^22.0
**INSTALL NAME**
IVM*2.0*149
"BLD",8191,0)
IVM*2.0*149^INCOME VERIFICATION MATCH^0^3110518^y
"BLD",8191,1,0)
^^2^2^3110404^
"BLD",8191,1,1,0)
This patch contains VistA changes to support technology and business
"BLD",8191,1,2,0)
changes that are occurring with the implementation of Public Law 111-163.
"BLD",8191,4,0)
^9.64PA^^
"BLD",8191,6.3)
5
"BLD",8191,"ABPKG")
n
"BLD",8191,"KRN",0)
^9.67PA^779.2^20
"BLD",8191,"KRN",.4,0)
.4
"BLD",8191,"KRN",.401,0)
.401
"BLD",8191,"KRN",.402,0)
.402
"BLD",8191,"KRN",.403,0)
.403
"BLD",8191,"KRN",.5,0)
.5
"BLD",8191,"KRN",.84,0)
.84
"BLD",8191,"KRN",3.6,0)
3.6
"BLD",8191,"KRN",3.8,0)
3.8
"BLD",8191,"KRN",9.2,0)
9.2
"BLD",8191,"KRN",9.8,0)
9.8
"BLD",8191,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",8191,"KRN",9.8,"NM",1,0)
IVMUFNC5^^0^B8601879
"BLD",8191,"KRN",9.8,"NM","B","IVMUFNC5",1)

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

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

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

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

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

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

"BLD",8191,"KRN","B",3.6,3.6)

"BLD",8191,"KRN","B",3.8,3.8)

"BLD",8191,"KRN","B",9.2,9.2)

"BLD",8191,"KRN","B",9.8,9.8)

"BLD",8191,"KRN","B",19,19)

"BLD",8191,"KRN","B",19.1,19.1)

"BLD",8191,"KRN","B",101,101)

"BLD",8191,"KRN","B",409.61,409.61)

"BLD",8191,"KRN","B",771,771)

"BLD",8191,"KRN","B",779.2,779.2)

"BLD",8191,"KRN","B",870,870)

"BLD",8191,"KRN","B",8989.51,8989.51)

"BLD",8191,"KRN","B",8989.52,8989.52)

"BLD",8191,"KRN","B",8994,8994)

"BLD",8191,"QUES",0)
^9.62^^
"BLD",8191,"REQB",0)
^9.611^1^1
"BLD",8191,"REQB",1,0)
IVM*2.0*109^2
"BLD",8191,"REQB","B","IVM*2.0*109",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)
149^3110518^100992
"PKG",120,22,1,"PAH",1,1,0)
^^2^2^3110518
"PKG",120,22,1,"PAH",1,1,1,0)
This patch contains VistA changes to support technology and business
"PKG",120,22,1,"PAH",1,1,2,0)
changes that are occurring with the implementation of Public Law 111-163.
"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","IVMUFNC5")
0^1^B8601879
"RTN","IVMUFNC5",1,0)
IVMUFNC5 ;ALB/AEG - IVM UTILITIES CONTINUED ; 8/10/05 1:39pm
"RTN","IVMUFNC5",2,0)
 ;;2.0;INCOME VERIFICATION MATCH;**55,109,149**;5-10-2002;Build 5
"RTN","IVMUFNC5",3,0)
 ;
"RTN","IVMUFNC5",4,0)
AGE(DT) ;
"RTN","IVMUFNC5",5,0)
 N Y
"RTN","IVMUFNC5",6,0)
 S Y=$E(DT,1,3)-1_"0000",Y=Y-10000
"RTN","IVMUFNC5",7,0)
 Q Y
"RTN","IVMUFNC5",8,0)
 ;
"RTN","IVMUFNC5",9,0)
INCY(IVMMTDT) ;
"RTN","IVMUFNC5",10,0)
 N Y
"RTN","IVMUFNC5",11,0)
 S Y=$E(IVMMTDT,1,3)_"0000",Y=Y-10000
"RTN","IVMUFNC5",12,0)
 Q Y
"RTN","IVMUFNC5",13,0)
 ;
"RTN","IVMUFNC5",14,0)
CATC(DATA) ;
"RTN","IVMUFNC5",15,0)
 ; Extrinsic function to determine is incoming ZMT1 segment meets 
"RTN","IVMUFNC5",16,0)
 ; one of the following groups:
"RTN","IVMUFNC5",17,0)
 ;     1.  Cat C or Pending Adj. / Provided income info / test date
"RTN","IVMUFNC5",18,0)
 ;         is 10/6/99 or later and Agreed to Pay is YES.
"RTN","IVMUFNC5",19,0)
 ;     OR
"RTN","IVMUFNC5",20,0)
 ;
"RTN","IVMUFNC5",21,0)
 ;     2.  Category C based upon declination to provide income info
"RTN","IVMUFNC5",22,0)
 ;         but agreed to pay deductible.
"RTN","IVMUFNC5",23,0)
 ;
"RTN","IVMUFNC5",24,0)
 ; Input(s):  $G(^TMP($J,"IVMCM","ZMT1")) global node - Incoming ZMT
"RTN","IVMUFNC5",25,0)
 ;            segment.
"RTN","IVMUFNC5",26,0)
 ;
"RTN","IVMUFNC5",27,0)
 ; Output(s):  Function Value. 1 = Yes patient meets one of the criteria
"RTN","IVMUFNC5",28,0)
 ;                             0 = NO test does not meet criteria.
"RTN","IVMUFNC5",29,0)
 N MTDAT,RETV
"RTN","IVMUFNC5",30,0)
 S RETV=0
"RTN","IVMUFNC5",31,0)
 Q:'$D(DATA) 0
"RTN","IVMUFNC5",32,0)
 S MTDAT("DT")=$P($G(DATA),U,2),MTDAT("MTS")=$P($G(DATA),U,3)
"RTN","IVMUFNC5",33,0)
 S MTDAT("APD")=$P($G(DATA),U,7),MTDAT("DCLI")=$P($G(DATA),U,16)
"RTN","IVMUFNC5",34,0)
 ; Patient Provided income information.
"RTN","IVMUFNC5",35,0)
 I '+$G(MTDAT("DCLI")) D
"RTN","IVMUFNC5",36,0)
 .; If Cat C or Pending Adjudication test date on or after 10/6/99
"RTN","IVMUFNC5",37,0)
 .; Provided Income info and Agreed to Pay.
"RTN","IVMUFNC5",38,0)
 .;
"RTN","IVMUFNC5",39,0)
 .I $G(MTDAT("MTS"))="C",$G(MTDAT("DT"))'<2991006,$G(MTDAT("APD"))=1 S RETV=1 Q
"RTN","IVMUFNC5",40,0)
 .I $G(MTDAT("MTS"))="P",$G(MTDAT("DT"))'<2991006,$G(MTDAT("APD"))=1 S RETV=1 Q
"RTN","IVMUFNC5",41,0)
 ;
"RTN","IVMUFNC5",42,0)
 ; Patient Declined to provide income information.
"RTN","IVMUFNC5",43,0)
 I +$G(MTDAT("DCLI")) D
"RTN","IVMUFNC5",44,0)
 .; Cat C and Agreed to Pay - No date restriction
"RTN","IVMUFNC5",45,0)
 .I $G(MTDAT("MTS"))="C",+$G(MTDAT("APD")) S RETV=1 Q
"RTN","IVMUFNC5",46,0)
 ;
"RTN","IVMUFNC5",47,0)
 Q RETV
"RTN","IVMUFNC5",48,0)
 ;
"RTN","IVMUFNC5",49,0)
ELIG(DFN) ; Eligibility Check for Cat C uploads older than previous
"RTN","IVMUFNC5",50,0)
 ;         income year data.
"RTN","IVMUFNC5",51,0)
 ;
"RTN","IVMUFNC5",52,0)
 ; Input: DFN - Patient IEN
"RTN","IVMUFNC5",53,0)
 ; Output: Function Value 0 if Z10 upload not appropriate
"RTN","IVMUFNC5",54,0)
 ;
"RTN","IVMUFNC5",55,0)
 N IVMELI
"RTN","IVMUFNC5",56,0)
 S IVMELI=0
"RTN","IVMUFNC5",57,0)
 ; Check primary eligibility
"RTN","IVMUFNC5",58,0)
 I $D(^DPT(DFN,.36)) S X=^(.36) D
"RTN","IVMUFNC5",59,0)
 .; If NSC or SC < 50 0% appropriate to upload old test.
"RTN","IVMUFNC5",60,0)
 .I $P($G(^DIC(8,+X,0)),U,9)=5!($$SC(DFN)) S IVMELI=1
"RTN","IVMUFNC5",61,0)
 .I $P(X,U,12)=1 S IVMELI=0
"RTN","IVMUFNC5",62,0)
 .I $P(X,U,13)=1 S IVMELI=0
"RTN","IVMUFNC5",63,0)
 .K X
"RTN","IVMUFNC5",64,0)
 ; If deceased patient --- don't upload.
"RTN","IVMUFNC5",65,0)
 I +$$GET1^DIQ(2,DFN_",",.351,"I") S IVMELI=0
"RTN","IVMUFNC5",66,0)
 ; If eligible for medicaid, don't upload.
"RTN","IVMUFNC5",67,0)
 I +$$GET1^DIQ(2,DFN_",",.381,"I") S IVMELI=0
"RTN","IVMUFNC5",68,0)
 ; Check PH status.
"RTN","IVMUFNC5",69,0)
 I $P($G(^DPT(DFN,.53)),U)="Y" S IVMELI=0
"RTN","IVMUFNC5",70,0)
 ; Catastrophically disabled
"RTN","IVMUFNC5",71,0)
 I $P($G(^DPT(DFN,.39)),U,6)="Y" S IVMELI=0 ;IVM*2.0*149
"RTN","IVMUFNC5",72,0)
 Q IVMELI
"RTN","IVMUFNC5",73,0)
 ;
"RTN","IVMUFNC5",74,0)
SC(DFN) ; Check to see if patient is SC 0% non-compensable.
"RTN","IVMUFNC5",75,0)
 ; Input -- DFN Patient IEN
"RTN","IVMUFNC5",76,0)
 ; Output -- Function value 1=Yes or 0=No
"RTN","IVMUFNC5",77,0)
 ;
"RTN","IVMUFNC5",78,0)
 N IVMG,IVME,IVMF,IVMY
"RTN","IVMUFNC5",79,0)
 S IVMY=0
"RTN","IVMUFNC5",80,0)
 ; Primary Eligibility is SC < 50 %
"RTN","IVMUFNC5",81,0)
 I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+X,0)),U,9)=3 S IVMY=1
"RTN","IVMUFNC5",82,0)
 G:'IVMY SCQ
"RTN","IVMUFNC5",83,0)
 ; Service Connected percentage = 0
"RTN","IVMUFNC5",84,0)
 I $P($G(^DPT(DFN,.3)),U,2)'=0 S IVMY=0 G SCQ
"RTN","IVMUFNC5",85,0)
 ; No Total annual VA Check amount
"RTN","IVMUFNC5",86,0)
 I $P($G(^DPT(DFN,.362)),U,20) S IVMY=0 G SCQ
"RTN","IVMUFNC5",87,0)
 ; POW Status indicated.
"RTN","IVMUFNC5",88,0)
 I $P($G(^DPT(DFN,.52)),U,5)="Y" S IVMY=0 G SCQ
"RTN","IVMUFNC5",89,0)
 ; Purple Heart Indicated.
"RTN","IVMUFNC5",90,0)
 I $P($G(^DPT(DFN,.53)),U)="Y" S IVMY=0 G SCQ
"RTN","IVMUFNC5",91,0)
 ; Check Secondary Eligibilities.
"RTN","IVMUFNC5",92,0)
 F IVMG=2,4,15:1:18 S IVME(IVMG)=""
"RTN","IVMUFNC5",93,0)
 S IVMG=0 F  S IVMG=$O(^DPT(DFN,"E","B",IVMG)) Q:'IVMG  D SEL I IVMF,$D(IVME(+IVMF)) S IVMY=0 Q
"RTN","IVMUFNC5",94,0)
SCQ Q +$G(IVMY)
"RTN","IVMUFNC5",95,0)
 ;
"RTN","IVMUFNC5",96,0)
SEL ;
"RTN","IVMUFNC5",97,0)
 S IVMF=$G(^DIC(8,+IVMG,0)) I IVMF="" Q
"RTN","IVMUFNC5",98,0)
 S IVMF=$P(IVMF,U,9)
"RTN","IVMUFNC5",99,0)
 I IVMF=""!('$D(^DIC(8.1,+IVMF,0))) D
"RTN","IVMUFNC5",100,0)
 .S IVMF=""
"RTN","IVMUFNC5",101,0)
 .Q
"RTN","IVMUFNC5",102,0)
 Q
"VER")
8.0^22.0
**END**
**END**