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

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

initial load of WorldVistAEHR
File size: 8.3 KB
Line 
1DGRPEIS3 ;ALB/CAW,EG,ERC - INCOME SCREENING DATA (CON'T) ; 1/3/06 9:03am
2 ;;5.3;Registration;**45,624,659,653**;Aug 13, 1993;Build 2
3 ;
4HELP ; Display information when veteran's DOB is past the income year
5 ;
6 W !!,"Please return to screen 8 and check the veteran's effective date."
7 W !,"The effective date was created based on the veteran's date of birth."
8 W !,"You might also want to check the date of birth for this veteran."
9 W ! S DIR(0)="E" D ^DIR K DIR W !
10 Q
11 ;
12WRT ; Write age statement
13 Q:'$G(DGMTI)
14 W !!,"This dependent is 18 years or older. To list this person as a dependent"
15 W !,"they have to be:"
16 W !," 1. An UNMARRIED child who is under the age of 18."
17 W !," 2. Between the ages of 18 and 23 and attending school."
18 W !," 3. An unmarried child over the age of 17 who became permanently"
19 W !," incapable of self support before the age of 18."
20 Q
21 ;
22EDIT ;CALLED FROM ROUTINE DGRPEIS
23 N DGEXIT
24 S DGEDDEP=1
25 S DGFL=$G(DGFL)
26 S DATE=$S($G(DATE):DATE,1:$$LYR^DGMTSCU1(DT))
27 S X=$P(DGPREF,"^",2)
28 S DGTYPE=$G(DGTYPE),DGTYPE=$S(DGTYPE']"":"S",DGTYPE="C":"C",DGTYPE="D":"D",1:"S")
29 S DIE="^"_$P(X,";",2),DA=+X
30 ;
31 ;changes to make Pseudo SSN Reason required - DG*5.3*653, ERC
32 S DGEXIT=0
33 S DR=".01;.02;.03;.09;S UPARROW=1"
34 K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1 Q
35 I $P($G(@(DIE_DA_",0)")),U,9)["P" D
36SSNREA . ;if SSN is pseudo Pseudo SSN Reason is required - DG*5.3*653, ERC
37 . S DR=$S(DIE["DGPR":.1,1:.0906)_";S UPARROW=1"
38 . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1 Q
39 . I $P($G(@(DIE_DA_",0)")),U,10)']"" G SSNREA
40 I DGEXIT=1 Q
41 I DGTYPE="S" D
42 . S DR="1.1;S UPARROW=1"
43 . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1
44 I DGEXIT=1 Q
45 ;
46 ;
47 S DOB=$P($G(@(DIE_DA_",0)")),U,3)
48 ;
49 N DGVADD,DGSADD,DGIPIEN,DGUQTLP,SPOUSE,DGFL,DGRPI
50 S (DGVADD,DGSADD,DGIPIEN,DGUQTLP)=0
51 S SPOUSE=$S(DGTYPE="S":1,1:0),DGFL=$G(DGFL)
52 ; Is spouse/dependent address same as patient address?
53 K DIR
54 S DIR(0)="YAO^^"
55 S DIR("A")="STREET ADDRESS SAME AS PATIENT'S: "
56 S DIR("B")="YES"
57 S DIR("?")="Enter 'Y' if the "_$S(SPOUSE:"spouse",1:"child")_" has the same address as the patient, otherwise enter 'N'."
58 D ^DIR
59 S DGVADD=+Y
60 K Y,DIR
61 S DGIPIEN=$$SPSCHK^DGRPEIS(DFN)
62 I 'DGVADD,(DGTYPE'="S"),DGIPIEN D
63 . K DIR,Y
64 . S DIR(0)="YAO^^"
65 . S DIR("A")="STREET ADDRESS SAME AS SPOUSE'S: "
66 . S DIR("B")="YES"
67 . S DIR("?")="Enter 'Y' if the child has the same address as the spouse, otherwise enter 'N'."
68 . D ^DIR
69 . S DGSADD=+Y
70 . K Y,DIR
71 ;
72 ; If spouse/dependent address is same as patient's, set spouse/dep address
73 I DGVADD!DGSADD D
74 . I DGVADD D PATASET^DGRPEIS(DFN) ;*Set to Patient address
75 . I DGSADD D SPSASET^DGRPEIS(DGIPIEN) ;*Set to Spouse address
76 . N FLD,FDA S FLD=0 F S FLD=$O(ANS(FLD)) Q:'FLD D
77 . . S FDA(408.13,DA_",",FLD)=ANS(FLD) K ANS(FLD)
78 . D FILE^DIE("","FDA","")
79 ;
80 ;Spouse/dep address not same as patient/spouse address; prompt for it
81 I 'DGVADD,'DGSADD D
82 . S DR="1.2;S:X']"""" Y=1.5;1.3;S:X']"""" Y=1.5;1.4;1.5;1.6;1.7;1.8;S UPARROW=1"
83 . K DG,DQ D ^DIE
84 I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) D EDITQ Q
85 ;
86 I DGTYPE'="S" K UPARROW S DIE="^DGPR(408.12,",DA=+DGPREF,DR=".02;S UPARROW=1" K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1)
87 S RELATION=$P($G(^DGPR(408.12,+DGPREF,0)),"^",2)
88 S DGX=$O(^DGPR(408.12,+DGPREF,"E","AID","")),DGMIEN=$O(^(+DGX,0))
89EDACTDT I $G(^DGPR(408.12,+DGPREF,"E",+DGMIEN,0)) D G:$G(DGFL)<0 EDITQ
90 . S (DGACT,Y)=+^(0) X ^DD("DD")
91 . S DIR("B")=Y
92 . D READ^DGRPEIS2
93 . I -DGACT'=DGX W !,"Use 'Expand Dependent' option to change effective date." H 2 S DGFL=-1 Q
94 . Q:$G(DGFL)<0
95 . S DIE="^DGPR(408.12,"_+DGPREF_",""E"",",DA(1)=+DGPREF,DA=DGMIEN,DR=".01///"_DGACT
96 . D ^DIE
97 I DGTYPE="S" S X=+DGPREF D SETUP^DGRPEIS1
98 K DGACT,DGMIEN,RELATION,DA,DIE,DR,UPARROW,DTOUT,DUOUT,DIRUT
99EDITQ K DA,DIE,DIRUT,DR,DTOUT,DUOUT
100 Q
101 ;
102HELP1(DGISDT) ; Displays the help for the active/inactive prompt
103 ;
104 D CLEAR^VALM1
105 W !,"Enter the date this person first became a dependent of the veteran."
106 W !,"In the case of a spouse, this would be the date of marriage. For"
107 W !,"a child, this would be the date of birth or date of adoption. For a"
108 W !,"stepchild, this would be the date of marriage to the child's parent."
109 W !!,"Date must be before DEC 31, "_DGISDT_" as dependents are collected for the"
110 W !,"prior calendar year only."
111 S VALMBCK="R"
112 Q
113 ;
114HELPDOB ; * Displays help for Date of Birth
115 N DGRDVAR
116 I X="?" D Q
117 . W !?5,"Enter the date this dependent was born. The date must not be during the"
118 . W !?5,"current calendar year. Only persons that were dependents before the"
119 . W !?5,"current year may be entered.",!
120 . I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
121 ;
122 W !?8,"Enter the date on which this relative was born. This information is"
123 W !?8,"necessary for use in the income screening and means test portions of"
124 W !?8,"MAS."
125 W !!?8,"The date entered must not be during the current calendar year. That"
126 W !?8,"is, it must be on or before December 31 or the prior calendar year."
127 I $G(DA) W ! S DIR(0)="E" D ^DIR Q:+Y<1
128 W !!?8,"The reason for this is that this data is used for collecting income"
129 W !?8,"information for the purposes of comparing this data with the Internal"
130 W !?8,"Revenue Service (IRS). Children born during the calendar year cannot"
131 W !?8,"be entered until next year."
132 I $G(DA) W !!,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
133 Q
134 ;
135HELPMN ; * Displays help for Spouse Maiden Name
136 W !?8,"Enter the spouse's maiden name in 'LAST,FIRST MIDDLE SUFFIX' format."
137 W !?8,"Entry of the LAST name only is permitted and the comma may be omitted."
138 W !?8,"If the response contains no comma, one will be appended to the value."
139 W !?8,"Including the comma, the value must be at least 3 characters in length.",!
140 Q
141 ;
142HELPSA1 ; * Displays help for Street Address 1
143 N DGRELTP
144 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
145 W !,"If a "_DGRELTP_"'s name has been specified, enter the first line of"
146 W !,"that person's street address [3-30 characters]; otherwise this field"
147 W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
148 W !,"name is on file."
149 I $G(DA),(X="?") W !
150 Q
151 ;
152HELPSA2 ; * Displays help for Street Address 2
153 N DGRELTP
154 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
155 W !,"If a "_DGRELTP_"'s name has been specified, enter the second line of"
156 W !,"that person's street address [3-30 characters]; otherwise this field"
157 W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
158 W !,"name is on file."
159 I $G(DA),(X="?") W !
160 Q
161 ;
162HELPSA3 ; * Displays help for Street Address 3
163 N DGRELTP
164 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
165 W !,"If a "_DGRELTP_"'s name has been specified, enter the third line of"
166 W !,"that person's street address [3-30 characters]; otherwise this field"
167 W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
168 W !,"name is on file."
169 I $G(DA),(X="?") W !
170 Q
171 ;
172HELPCITY ; * Displays help for City
173 N DGRELTP
174 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
175 W !,"If a "_DGRELTP_"'s name has been specified, enter the city in which"
176 W !,"that person resides [3-30 characters]; otherwise this field may be"
177 W !,"left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
178 W !,"name is on file."
179 I $G(DA),(X="?") W !
180 Q
181 ;
182HELPSTAT ; * Displays help for the state
183 N DGRELTP,DIRA,DGRDVAR
184 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
185 W !,"If a "_DGRELTP_"'s name has been specified, select the state in which"
186 W !,"that person resides; otherwise this field may be left blank. This"
187 W !,"field cannot be deleted as long as a "_DGRELTP_"'s name is on file.",!
188 ;
189 Q:X="?"
190 W !,"Enter RETURN to continue:" R DGRDVAR:DTIME
191 Q
192 ;
193HELPZIP ; * Displays help for the Zip code
194 N DGRELTP
195 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
196 W !,"Answer with the 5 digit format (e.g. 12345) or the nine digit"
197 W !,"format (e.g. 12345-6789 or 123456789). This is related to the"
198 W !,DGRELTP_"'s address."
199 I $G(DA),(X="?") W !
200 Q
201HELPPHON ; * Displays help for the Phone number
202 N DGRELTP
203 S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
204 W !,"If a "_DGRELTP_"'s name has been specified, enter the "_DGRELTP_"'s"
205 W !,"phone number [4-20 characters], otherwise this field may be left"
206 W !,"blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
207 W !,"name is on file."
208 I $G(DA),(X="?") W !
209 Q
Note: See TracBrowser for help on using the repository browser.