source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTA.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1DGMTA ;ALB/RMO/CAW/LD/SCG/AEG/PHH - Add a New Means Test ; 07/06/2004
2 ;;5.3;Registration;**33,45,137,166,177,182,290,344,332,433,458,535,612,564**;Aug 13, 1993
3 ;
4EN ;Entry point to add a new means test
5 N DGMDOD S DGMDOD=""
6 S DGADDF=1
7 I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
8 S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q:Y<0 S (DFN,DGMTDFN)=+Y
9 I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
10 I $G(DGMDOD) W !,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") Q
11 ;
12 ; check if income test in progress
13 D CKUPLOAD^IVMCUPL(DFN)
14 ;
15 ; obtain lock used to synchronize local MT/CT options with income test upload
16 I $$LOCK^DGMTUTL(DFN)
17 ;
18 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
19 ;
20 N FUTMT S FUTMT=$$FUT^DGMTU(DFN,"",DGMTYPT) I FUTMT D FTST G EN
21 ;
22 ;if a test was auto-completed, DGADDF gets set to 0
23 I 'DGADDF W !!,*7,"A means test already exists and is in effect" G EN
24 ;
25 K:DGMTYPT=1 DGDOM1
26 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
27 S DGLDT=$$LST^DGMTU(DFN,"",DGMTYPT),DGLD=$P(DGLDT,U,2),DGLDYR=$E(DGLD,1,3)_"1231"
28 ;
29DT 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
30 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
31 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
32 I DGLD S X1=DGMTDT,X2=DGLD D ^%DTC I X<365,DGMTDT'>DGLDYR D G EN
33 .W !?3,*7,"An annual date of test already exists on " S Y=DGLD X ^DD("DD") W Y,"."
34 .S DGTTYP=$S(DGMTYPT=1:"Means ",1:"Copay Exemption ")
35 .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.")
36 ;
37 ;Means Test cannot be added for patient on a DOM ward on date of test
38 I DGMTYPT=2 G PRINT
39 N VAINDT,VADMVT,DGDOM,DGDOM1
40 S VAINDT=DGMTDT
41 D DOM1^DGMTR I $G(DGDOM1) D K VAINDT,VADMVT,DGDOM,DGDOM1 G EN
42 .W !,*7,"A Means Test cannot be added for patients on a DOM ward on date of test.",!
43 K VAINDT,VADMVT,DGDOM,DGDOM1
44 ;
45 ;A warning message is displayed if last means test for patient is
46 ;from a prior year and has a status of required. The user is given
47 ;the option to continue or stop adding a new means test.
48 N %
49 I DGLD,DGMTDT>DGLDYR,$P(DGLDT,"^",4)="R" D Q:%=-1 I %=2 K % G EN
50 .W !?3,*7,"WARNING - last means test on " S Y=DGLD X ^DD("DD") W Y," has a status of required."
51DT2 .W !?3,"Do you still want to continue adding new test"
52 .S %=2 D YN^DICN
53 .I %=0 W !?3,"Answer 'Y'es to continue adding new test." G DT2
54 .Q
55 K %
56 ;
57PRINT 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
58 I $G(%)=1 S DGX=DGMTDT,DGMTDT=DGLD,DGMTI=+DGLDT,DGOPT="" D DEV^DGMTP,CLOSE^DGUTQ S DGMTDT=DGX K DGX
59 D ADD G EN:DGMTI<0
60 S DGMTACT="ADD",DGMTROU="EN^DGMTA" G EN^DGMTSC
61 ;
62Q 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
63 ;
64 ; release lock used to synchronize local MT/CT options with income test upload
65 I $D(DGMTDFN)#2 D UNLOCK^DGMTUTL(DGMTDFN) K DGMTDFN
66 Q
67 ;
68ADD ;Add means test
69 ; Input -- DFN Patient IEN
70 ; DGMTDT Date
71 ; DGMTYPT Type of Test 1=MT 2=COPAY 4=LTC
72 ; Output -- DGMTI Annual Means/Copay/LTC Test IEN
73 N DA,DD,DIC,DIK,DINUM,DLAYGO,DO,DS,X,D0,DGSITE
74 ;
75 ; obtain lock used to synchronize local MT/CT options with income test upload
76 I $$LOCK^DGMTUTL(DFN) E Q
77 ;
78 ; Check for Linked test and don't loose the link.
79 S LINK="",CURIEN=+$$LST^DGMTU(DFN,DGMTDT,DGMTYPT)
80 I CURIEN S LINK=$P($G(^DGMT(408.31,CURIEN,2)),U,6)
81 ;
82 S DGSITE=$$GETSITE^DGMTU4(.DUZ)
83 S X=DGMTDT,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
84 ;
85 ; The DIC("DR") string is built in this specific order so that
86 ; all triggers and "M" x-refs fire correctly. Should not be
87 ; modified without an in-depth review of DD of file #408.31.
88 ;
89 I DGMTYPT=2 D
90 .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK
91 .S DIC("DR")=DIC("DR")_";.02////"_DFN_";.019////"_DGMTYPT_";.23////1"
92 E D
93 .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK
94 .S DIC("DR")=DIC("DR")_";.019////"_DGMTYPT_";.02////"_DFN_";.23////1"
95 K DD,DO
96 D FILE^DICN S DGMTI=+Y
97 ;
98 ; release lock used to synchronize local MT/CT options with income test upload
99 D UNLOCK^DGMTUTL(DFN)
100 ;
101ADDQ Q
102 ;
103FTST ; Build message for future tests that are added to the system, but
104 ; were not performed by the VAMC trying to add a new MT.
105 N SITE,DGMTYPT,DGTTYP,SRC,SCT
106 S SCT=$P(^DGMT(408.31,+FUTMT,2),U,5),SITE=$$INST^DGENU()
107 S DGMTYPT=$P(^DGMT(408.31,+FUTMT,0),U,19)
108 S DGTTYP=$S(DGMTYPT=1:"Means ",1:"Copay Exemption ")
109 W !?3,*7,"A future test already exists on "
110 S Y=$P(FUTMT,U,2) X ^DD("DD") W Y,"."
111 ; This site performed the MT
112 I SITE=SCT D
113 .W !?3,"Use the 'Edit an Existing "_DGTTYP_"Test' Option."
114 ;
115 ; The MT was added by another VAMC
116 I SITE'=SCT D
117 .S SRC=$P(FUTMT,U,5)
118 .I SCT W !?3,"The "_DGTTYP_"Test was conducted at Site: ",SCT
119 .W !?3,"Please contact "
120 .W $S($D(^DIC(4,+SCT,0)):$P(^DIC(4,+SCT,0),U),SRC=2:"IVM",SRC=3:"the HEC",1:"the site")
121 .W ",",!?3,"if it is necessary to edit the test."
122 Q
123WHY ;Why Copay Test cannot be added
124 ;;Patient is not a veteran.
125 ;;Patient does not have a Primary Eligibility Code.
126 ;;Patient is Service Connected 50-100%.
127 ;;Means Test options must be used instead of Copay options.
128 ;;Patient is receiving Aid and Attendance, automatically exempted.
129 ;;Patient is receiving Housebound Benefits, automatically exempted.
130 ;;Patient is receiving a VA Pension, automatically exempted.
131 ;;Patient is in a DOM ward, automatically exempted.
132 ;;Patient is an inpatient, automatically exempted.
133 ;;Patient was a POW, automatically exempted.
134 ;;Patient is Unemployable, automatically exempted.
Note: See TracBrowser for help on using the repository browser.