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

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

initial load of WorldVistAEHR
File size: 8.8 KB
RevLine 
[613]1DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;12/25/06 18:28
2 ;;5.3;Registration;**33,114,489,624,672,689,634**;Aug 13, 1993;Build 30
3 ; Modified from FOIA VISTA,
4 ; Copyright (C) 2007 WorldVistA
5 ;
6 ; This program is free software; you can redistribute it and/or modify
7 ; it under the terms of the GNU General Public License as published by
8 ; the Free Software Foundation; either version 2 of the License, or
9 ; (at your option) any later version.
10 ;
11 ; This program is distributed in the hope that it will be useful,
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ; GNU General Public License for more details.
15 ;
16 ; You should have received a copy of the GNU General Public License
17 ; along with this program; if not, write to the Free Software
18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
19H ;Screen Header
20 I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
21 I DGRPS=1.1 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
22 S X=$$SSNNM(DFN)
23 I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
24 S X="",$P(X,"=",80)="" W !,X Q
25 Q
26 ;
27AL(DGLEN) ;DGLEN= Available length of line
28A ;Format address(es)
29 I '$D(DGLEN) N DGLEN S DGLEN=29
30 N DGX
31 F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S DGA(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2
32 I DGA2=1 S DGA(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2
33 S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),DGA(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
34 I ".33^.34^.211^.331^.311^.25^.21"[DGAD D
35 .F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I)
36 E D
37 .I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q
38 .S DGX=$P(DGRP(DGAD),U,DGA1+11)
39 S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9)
40 S DGA(DGA2)=$E($P(DGA(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(DGA(DGA2),",",2)):",",1:"")_$P(DGA(DGA2),",",2)_" "_DGX
41 F I=0:0 S I=$O(DGA(I)) Q:'I S DGA(I)=$E(DGA(I),1,DGLEN)
42 K DGA1,I,J
43 Q
44 ;
45W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q
46 W ?X,@DGVI,Z,@DGVO
47 Q
48 ;
49H1 ;
50 ;;PATIENT DEMOGRAPHIC DATA
51 ;;PATIENT DATA
52 ;;EMERGENCY CONTACT DATA
53 ;;APPLICANT/SPOUSE EMPLOYMENT DATA
54 ;;INSURANCE DATA
55 ;;MILITARY SERVICE DATA
56 ;;ELIGIBILITY STATUS DATA
57 ;;FAMILY DEMOGRAPHIC DATA
58 ;;INCOME SCREENING DATA
59 ;;INELIGIBLE/MISSING DATA
60 ;;ELIGIBILITY VERIFICATION DATA
61 ;;ADMISSION INFORMATION
62 ;;APPLICATION INFORMATION
63 ;;APPOINTMENT INFORMATION
64 ;;SPONSOR DEMOGRAPHIC INFORMATION
65 ;
66 ;
67INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data
68 ; (called by PTF)
69 ;
70 ;
71 ; Input: DFN as IEN of PATIENT file
72 ; DGDT as date to return income as of
73 ;
74 ; Output: total income (computed function)
75 ; (from 408.21 if available...otherwise from file 2)
76 ;
77 ;
78 N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0
79 D ALL^DGMTU21(DFN,"V",DGDT,"I")
80 S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I)
81 I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20)
82 Q DGTOT
83 ;
84 ;
85MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete?
86 ;
87 ; Input: DFN as IEN of PATIENT file
88 ; DGDT as 'as of' date
89 ;
90 ; Output: 1 if means test/COPAY for year prior to DT passed is complete
91 ; 0 otherwise
92 ; DGMTYPT 1=MT;2=CP;0=NONE
93 ;
94 N COMP,MT,X,YR
95 S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT)
96 S DGMTYPT=+$P(MT,U,5)
97 S COMP=1
98 I DGMTYPT=1 D ;MT
99 .I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
100 I DGMTYPT=2 D ;CP
101 .I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
102 S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*10000<YR S COMP=0
103 Q COMP
104 ;
105HLP1010 ;* This is called by the Executable Help for Patient field #1010.159
106 ; (APPOINTMENT REQUEST ON 1010EZ)
107 W !!," Enter a 'Y' if the veteran applicant has requested an"
108 W !," appointment with a VA doctor or provider and wants to be"
109 W !," seen as soon as one becomes available Enter a 'N'"
110 W !," if the veteran applicant has not requested an appointment."
111 W !!," This question may ONLY be entered ONCE for the veteran."
112 W !," The answer to this question CANNOT be changed after the"
113 W !," initial entry.",!
114 Q
115 ;
116HLPCS ; * This is called by the Executable Help for Income Relation field #.1
117 Q:X="?"
118 N DIR,DGRDVAR
119 W !?8,"Enter in this field a Yes or No to indicate whether the veteran"
120 W !?8,"contributed any dollar amount to the child's support last calendar"
121 W !?8,"year. The contributions do not have to be in regular set amounts."
122 W !?8,"For example, a veteran who paid a child's school tuition or"
123 W !?8,"medical bills would be contributing to the child's support.",!
124 W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
125 Q
126 ;
127HLP1823 ;*This is called by the Executable Help for Patient Relation field #.18
128 N DIR,DGRDVAR
129 W !?7,"Enter 'Y' if the child is currently 18 to 23 years old and the child"
130 W !?7,"attended school last calendar year. Enter 'N' if the child is currently"
131 W !?7,"18 to 23 years old but the child did not attend school last calendar"
132 W !?7,"year. Enter 'N' if the child is not currently 18 to 23 years old.",!
133 I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
134 Q
135 ;
136HLPMLDS ;* This is called by the Executable Help for Patient field #.362
137 ; (DISABILITY RET. FROM MILITARY?)
138 N X,Y,DIR
139 W !!," Enter '0' or 'NO' if the veteran:"
140 W !," -- Is NOT retired from the military OR"
141 W !," -- Is retired from the military due to length of service AND"
142 W !," does NOT have a disability confirmed by the Military Branch"
143 W !," to have been incurred in or aggravated while on active duty."
144 W !!," Enter '1' or 'YES, RECEIVING MILITARY RETIREMENT' if the veteran:"
145 W !," -- Is confirmed by the Military Branch to have been discharged"
146 W !," or released due to a disability incurred in or aggravated"
147 W !," while on active duty AND"
148 W !," -- Has NOT filed a claim for VA compensation benefits OR"
149 W !," -- Has been rated by the VA to be NSC OR"
150 W !," -- Has been rated by the VA to have noncompensable 0%"
151 W !," SC conditions."
152 S DIR(0)="E" D ^DIR Q:+Y<1
153 W !!," Enter '2' or 'YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA"
154 W !," COMPENSATION' if the veteran:"
155 W !," -- Is confirmed by the Military Branch to have been discharged"
156 W !," or released due to a disability incurred in or aggravated"
157 W !," while on active duty AND"
158 W !," -- Is receiving military disability retirement pay AND"
159 W !," -- Has been rated by VA to have compensable SC conditions"
160 W !," but is NOT receiving compensation from the VA"
161 W !!," Once eligibility has been verified, this field will no longer"
162 W !," be editable to any user who does not hold the designated security"
163 W !," key."
164 Q
165HLP3602 ;help text for field .3602, Rec'ing Disability in Lieu of VA Comp
166 W !," Enter 'Y' if this veteran applicant is receiving disability"
167 W !," retirement pay from the Military instead of VA compensation."
168 W !," Enter 'N' if this veteran applicant is not receiving disability"
169 W !," retirement pay from the Military instead of VA compensation."
170 W !," Once eligibility has been verified by HEC this field will no longer "
171 W !," be editable by VistA users. Send updates and/or requests to HEC."
172 Q
173HLP3603 ;help text for field .3603, Discharge Due to LOD Disability
174 W !," Enter 'Y' if this veteran applicant was discharged from the"
175 W !," military for a disability incurred or aggravated in the line "
176 W !," of duty. Enter 'N' if this veteran applicant was not discharged"
177 W !," from the military for a disability incurred or aggravated in the"
178 W !," line of duty. Once eligibility has been verified by HEC this field"
179 W !," will no longer be editable by VistA users. Send updates and/or requests"
180 W !," to HEC."
181 Q
182SSNNM(DFN) ; SSN and name on first line of screen
183 ;
184 ; ** start of VOE change: DAOU/JLG 2/1/2005,VA/CJS,WV/TOAD 5/9/2006 **
185 ;
186 ; Change code so it will display HRN if SSN is null
187 ;
188 ; before:
189 ;
190 ; N X,SSN
191 ; S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
192 ;
193 ; after:
194 ;
195 ; Social Security Number field (.09) in Patient file (2)
196 N X,SSN,HRN
197 S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9)
198 I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
199 ;
200ID S SSN=$$ID^DGLBPID(DFN) ;**GFT/VW
201 ; for IHS or EHR, replace SSN with HRN
202 I $G(DUZ("AG"))'="V" D
203 . Q:SSN]""
204 . S HRN=$$HRN^AUPNPAT3(+DFN,DUZ(2))
205 . I HRN S SSN="HRN-"_HRN
206 ;
207 ; ** end of VOE change **
208 ;
209 S X=$P(X,U)_"; "_SSN
210 Q X
211 ;
Note: See TracBrowser for help on using the repository browser.