Changeset 636 for FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 1 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m
r628 r636 1 DGRP1 ;ALB/MRL,ERC - DEMOGRAPHIC DATA ; 06/22/06 2 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653**;Aug 13, 1993;Build 2 1 DGRP1 ;ALB/MRL - DEMOGRAPHIC DATA ;1/8/07 09:14 2 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,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 ; 20 ; 2005 03 18 (VA/JT): DG*5.3*629, stop Missing Patient message based 21 ; on questionable data in Missing Person Date fld (.153). 22 ; 23 ; 2005 04 25? (VA/MRY): DG*5.3*638, add Sex to IDs shown. 24 ; 25 ; 2005 04 27 (VA/JT): DG*5.3*649, change last $EXTRACT for Alias SSN in 26 ; GETNCAL to 10 chars instead of 9, to preserve trailing P for pseudo- 27 ; SSNs. 28 ; 29 ; 2006 04 21 (WV/TOAD, after DAOU/WCJ (2005 02 07) and 30 ; VA/CJS (2005/12/23)): restore 6-part VOE change; space dots and 31 ; semi-colons. 32 ; 33 ; 2006 05 09 (WV/TOAD): rewrite VOE change to fix bugs introduced by 34 ; VA and VOE, and completely refactor bug-prone GETNCAL, and merge back 35 ; into main subroutine body. 3 36 ; 4 37 EN S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") 5 38 I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0 6 39 ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'. NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0 40 ; 41 ; ** VOE change 1 of 3 ** 42 ; 43 ; if EHR agency code, display Registration Date (Date Entered into 44 ; File, .097) 45 ; 46 ; new lines: 47 I $G(DUZ("AG"))="E" D 48 . W !?58,"Reg Dt: ",$$FMTE^XLFDT($P(DGRP(0),U,16),"2D") 49 ; 50 ; 51 ; show field groups 1 and 2 in two columns 52 ; 53 ; field groups 1 & 2 part 1: show Name, SSN, and DOB 54 ; 55 ; 56 ; ** end of VOE change 1 ** 57 ; 7 58 W ! S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV 8 59 W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV … … 17 68 . . Q:$G(DGREAS)']"" 18 69 . . W DGREAS 19 D GETNCAL ;Display name component, sex, and alias information 70 ; 71 ; ** VOE change 2 of 3 ** 72 ; 73 ; eliminate unnecessary subroutine GETNCAL and merge code back into 74 ; the main subroutine, and make the following changes: 75 ; 76 ; For EHR or IHS agency code, show Health Record No. (.02) for the 77 ; current Facility from the Health Record No. multiple field 78 ; (4101/9000001.41) of the IHS Patient file (9000001) for the current 79 ; patient. 80 ; 81 ; Move Sex field over so it shows up in the same location for 82 ; VA, IHS, and EHR, leaving a blank for where HRN can appear. 83 ; 84 ; Fix the VA bug in which patients having five valid aliases 85 ; were showing "< More alias entries on file >" instead of the fifth 86 ; alias. 87 ; 88 ; Refactor entire subroutine: clean original design was broken 89 ; by patching and had become fragile and confusing; tighten variable 90 ; scopes, use clearer names, comment. 91 ; 92 ; before: 93 ; 94 ; D GETNCAL ;Display name component, sex, and alias information 95 ; 96 ; after: 97 ; 98 ; field groups 1 & 2 part 2: load name components 99 ; 100 ; 101 N DGLABEL S DGLABEL="^ Given^Middle^Prefix^Suffix^Degree" ; labels 102 N DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," ; Name Components fd (1.01) 103 I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") ; Name Components file 104 ; loads Family (Last) Name (1), Given (First) Name (2), 105 ; Middle Name (3), Prefix (4), Suffix (5), and Degree (6) 106 ; 107 ; 108 ; field groups 1 & 2 part 3: load aliases 109 ; 110 ; 111 N DGCOUNT S DGCOUNT=0 ; how many aliases do we find 112 N DGALIAS S DGALIAS=0 ; IEN of Alias subfile (1/2.01) of Patient fl (2) 113 ; and array of aliases found 114 S DGALIAS=0 F D Q:'DGALIAS 115 . ; 116 . S DGALIAS=$O(^DPT(DFN,.01,DGALIAS)) 117 . Q:'DGALIAS ; out of alias subrecords 118 . N DGNODE S DGNODE=$G(^DPT(DFN,.01,DGALIAS,0)) ; 0-node of subrecord 119 . Q:'$L(DGNODE) ; bad node 120 . ; 121 . S DGCOUNT=DGCOUNT+1 ; another valid alias 122 . I DGCOUNT=6 S DGALIAS=0 Q ; can't show > 5, need to know if 6 or > 123 . ; 124 . S DGALIAS(DGCOUNT)=$P(DGNODE,U) ; Alias fld (.01) 125 . ; 126 . N DGSSN S DGSSN=$P(DGNODE,U,2) ; Alias SSN fld (1) 127 . I $L(DGSSN) D 128 . . S DGSSN=" "_$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10) 129 . . ; incl leading space to separate from alias name 130 . . ; incl 10 chars to allow for P of pseudo-SSNs 131 . . S $E(DGALIAS(DGCOUNT),20)=DGSSN ; truncate alias name & append SSN 132 . ; 133 . S DGALIAS(DGCOUNT)=$E(DGALIAS(DGCOUNT),1,32) ; truncate alias 134 ; 135 I DGCOUNT=0 S DGALIAS(1)="< No alias entries on file >" 136 I DGCOUNT=6 S DGALIAS(5)="< More alias entries on file >" 137 K DGCOUNT 138 ; 139 ; 140 ; field groups 1 & 2 part 4: show 1st name component, and IDs HRN & Sex 141 ; 142 ; 143 W !?5,"Family: " 144 W $E($G(DGCOMP(20,DGCOMP,1)),1,27) 145 ; 146 I "EI"[$G(DUZ("AG")),$G(DUZ(2)) D 147 . N DGNODE S DGNODE=$G(^AUPNPAT(DFN,41,DUZ(2),0)) ; get 0-node for the 148 . ; current Facility from the Health Record No. multiple field 149 . ; (4101/9000001.41) for DFN in the IHS Patient file (9000001) 150 . N DGHRN S DGHRN=$P(DGNODE,U,2) ; Health Record No. (.02) 151 . W ?42," HRN: ",DGHRN 152 ; 153 D 154 . N DGSEX S DGSEX=$P(DGRP(0),U,2) ; Sex fld (.02) of Patient file (2) 155 . W ?61,"Sex: ",$S(DGSEX="M":"MALE",DGSEX="F":"FEMALE",1:"UNANSWERED") 156 ; 157 ; 158 ; field groups 1 & 2 part 5: show remaining name components and aliases 159 ; 160 ; 161 N DGCOUNT F DGCOUNT=2:1:6 D 162 . W !?5,$P(DGLABEL,U,DGCOUNT),": " 163 . N DGNAME S DGNAME=$G(DGCOMP(20,DGCOMP,DGCOUNT)) ; next name component 164 . W $E(DGNAME,1,$S(DGCOUNT=2:23,1:27)) ; 1st line leaves room for "[2]" 165 . I DGCOUNT=2 D ; header for aliases 166 . . W ?37 N DGRPW,Z S DGRPW=0,Z=2 D WW^DGRPV ; write [2], suppress LF 167 . . W " Alias: " 168 . W ?47,$G(DGALIAS(DGCOUNT-1)) ; show next alias 169 ; 170 ; 171 ; show field group 3: remarks 172 ; 173 ; 174 ; ** end of VOE change 2 ** 175 ; 20 176 S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU 21 177 S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17 … … 29 185 S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU) 30 186 W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X 187 ; 188 ; ** VOE change 3 of 3 ** 189 ; 190 ; if EHR agency code, display Alternate Phone Number (.134) 191 ; 192 ; new lines: 193 I $G(DUZ("AG"))="E" D 194 . W !?1,"Alt Ph: ",$P($G(^DPT(DFN,.13)),U,4) 195 ; 196 ; ** end of VOE change 3 ** 197 ; 31 198 W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16)) 32 199 ; … … 50 217 G ^DGRPP 51 218 ; 52 GETNCAL ;Get name component values53 N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW54 S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"55 S DGCOMP=+$G(^DPT(DFN,"NAME"))_","56 I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")57 ;Get alias values58 S DGA=0 F DGI=1:1:5 D Q:'$D(DGALIAS(DGI))59 A2 .S DGA=$O(^DPT(DFN,.01,DGA))60 .I 'DGA D:DGI=1 Q61 ..S DGALIAS(DGI)="< No alias entries on file >" Q62 .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q63 .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A264 .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)65 .I $L(DGX) D66 ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)67 ..; BAJ DG*5.3*700 retrofit 06/22/0668 ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)69 ..S $E(DGALIAS(DGI),20)=DGX Q70 .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)71 .Q72 ;Display name component, sex, multiple birth indicator and alias data73 F DGI=1:1:6 D74 .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:23,1:27))75 .I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV76 .; BAJ DG*5.3*700 retrofit 06/220677 .I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV78 .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "79 .I DGI>1 W ?47,$G(DGALIAS(DGI-1))80 .Q81 Q82 219 SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC 83 220 S DGREAS=$P(DGRP("SSN"),U)
Note:
See TracChangeset
for help on using the changeset viewer.