Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m
r613 r623 1 DGRPU 2 ;;5.3;Registration;**33,114,489,624,672,689,634**;Aug 13, 1993;Build 30 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 H 20 21 22 23 24 25 26 27 AL(DGLEN) 28 A 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 W 46 47 48 49 H1 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 INCOME(DFN,DGDT) 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 MTCOMP(DFN,DGDT) 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 HLP1010 106 107 108 109 110 111 112 113 114 115 116 HLPCS 117 118 119 120 121 122 123 124 125 126 127 HLP1823 128 129 130 131 132 133 134 135 136 HLPMLDS 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 HLP3602 166 167 168 169 170 171 172 173 HLP3603 174 175 176 177 178 179 180 181 182 SSNNM(DFN) 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 ID 201 202 203 204 205 206 207 208 209 210 211 1 DGRPU ;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 28 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 19 H ;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 ; 27 AL(DGLEN) ;DGLEN= Available length of line 28 A ;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 ; 45 W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q 46 W ?X,@DGVI,Z,@DGVO 47 Q 48 ; 49 H1 ; 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 ; 67 INCOME(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 ; 85 MTCOMP(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 ; 105 HLP1010 ;* 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 ; 116 HLPCS ; * 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 ; 127 HLP1823 ;*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 ; 136 HLPMLDS ;* 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 165 HLP3602 ;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 173 HLP3603 ;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 182 SSNNM(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 ; 200 ID 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 TracChangeset
for help on using the changeset viewer.
