Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m	(revision 636)
@@ -1,8 +1,59 @@
-DGRP1 ;ALB/MRL,ERC - DEMOGRAPHIC DATA ; 06/22/06
- ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653**;Aug 13, 1993;Build 2
+DGRP1 ;ALB/MRL - DEMOGRAPHIC DATA ;1/8/07  09:14
+ ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ; 2005 03 18 (VA/JT): DG*5.3*629, stop Missing Patient message based
+ ; on questionable data in Missing Person Date fld (.153).
+ ;
+ ; 2005 04 25? (VA/MRY): DG*5.3*638, add Sex to IDs shown.
+ ;
+ ; 2005 04 27 (VA/JT): DG*5.3*649, change last $EXTRACT for Alias SSN in
+ ; GETNCAL to 10 chars instead of 9, to preserve trailing P for pseudo-
+ ; SSNs.
+ ;
+ ; 2006 04 21 (WV/TOAD, after DAOU/WCJ (2005 02 07) and
+ ; VA/CJS (2005/12/23)): restore 6-part VOE change; space dots and
+ ; semi-colons.
+ ;
+ ; 2006 05 09 (WV/TOAD): rewrite VOE change to fix bugs introduced by
+ ; VA and VOE, and completely refactor bug-prone GETNCAL, and merge back
+ ; into main subroutine body.
  ;
 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:"")
  I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
  ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'.  NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
+ ;
+ ; ** VOE change 1 of 3 **
+ ;
+ ; if EHR agency code, display Registration Date (Date Entered into
+ ; File, .097)
+ ;
+ ; new lines:
+ I $G(DUZ("AG"))="E" D
+ . W !?58,"Reg Dt: ",$$FMTE^XLFDT($P(DGRP(0),U,16),"2D")
+ ;
+ ;
+ ; show field groups 1 and 2 in two columns
+ ;
+ ; field groups 1 & 2 part 1: show Name, SSN, and DOB
+ ;
+ ;
+ ; ** end of VOE change 1 **
+ ;
  W ! S Z=1 D WW^DGRPV W "    Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
  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,5 +68,110 @@
  . . Q:$G(DGREAS)']""
  . . W DGREAS
- D GETNCAL  ;Display name component, sex, and alias information
+ ;
+ ; ** VOE change 2 of 3 **
+ ;
+ ; eliminate unnecessary subroutine GETNCAL and merge code back into
+ ; the main subroutine, and make the following changes:
+ ;
+ ; For EHR or IHS agency code, show Health Record No. (.02) for the
+ ; current Facility from the Health Record No. multiple field
+ ; (4101/9000001.41) of the IHS Patient file (9000001) for the current
+ ; patient.
+ ;
+ ; Move Sex field over so it shows up in the same location for
+ ; VA, IHS, and EHR, leaving a blank for where HRN can appear.
+ ;
+ ; Fix the VA bug in which patients having five valid aliases
+ ; were showing "< More alias entries on file >" instead of the fifth
+ ; alias.
+ ;
+ ; Refactor entire subroutine: clean original design was broken
+ ; by patching and had become fragile and confusing; tighten variable
+ ; scopes, use clearer names, comment.
+ ;
+ ; before:
+ ;
+ ; D GETNCAL  ;Display name component, sex, and alias information
+ ;
+ ; after:
+ ;
+ ; field groups 1 & 2 part 2: load name components
+ ;
+ ;
+ N DGLABEL S DGLABEL="^ Given^Middle^Prefix^Suffix^Degree" ; labels
+ N DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," ; Name Components fd (1.01)
+ I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") ; Name Components file
+ ; loads Family (Last) Name (1), Given (First) Name (2),
+ ; Middle Name (3), Prefix (4), Suffix (5), and Degree (6)
+ ;
+ ;
+ ; field groups 1 & 2 part 3: load aliases
+ ;
+ ;
+ N DGCOUNT S DGCOUNT=0 ; how many aliases do we find
+ N DGALIAS S DGALIAS=0 ; IEN of Alias subfile (1/2.01) of Patient fl (2)
+ ;                       and array of aliases found
+ S DGALIAS=0 F  D  Q:'DGALIAS
+ . ;
+ . S DGALIAS=$O(^DPT(DFN,.01,DGALIAS))
+ . Q:'DGALIAS  ; out of alias subrecords
+ . N DGNODE S DGNODE=$G(^DPT(DFN,.01,DGALIAS,0)) ; 0-node of subrecord
+ . Q:'$L(DGNODE)  ; bad node
+ . ;
+ . S DGCOUNT=DGCOUNT+1 ; another valid alias
+ . I DGCOUNT=6 S DGALIAS=0 Q  ; can't show > 5, need to know if 6 or >
+ . ;
+ . S DGALIAS(DGCOUNT)=$P(DGNODE,U) ; Alias fld (.01)
+ . ;
+ . N DGSSN S DGSSN=$P(DGNODE,U,2) ; Alias SSN fld (1)
+ . I $L(DGSSN) D
+ . . S DGSSN=" "_$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10)
+ . . ; incl leading space to separate from alias name
+ . . ; incl 10 chars to allow for P of pseudo-SSNs
+ . . S $E(DGALIAS(DGCOUNT),20)=DGSSN ; truncate alias name & append SSN
+ . ;
+ . S DGALIAS(DGCOUNT)=$E(DGALIAS(DGCOUNT),1,32) ; truncate alias
+ ;
+ I DGCOUNT=0 S DGALIAS(1)="< No alias entries on file >"
+ I DGCOUNT=6 S DGALIAS(5)="< More alias entries on file >"
+ K DGCOUNT
+ ;
+ ;
+ ; field groups 1 & 2 part 4: show 1st name component, and IDs HRN & Sex
+ ;
+ ;
+ W !?5,"Family: "
+ W $E($G(DGCOMP(20,DGCOMP,1)),1,27)
+ ;
+ I "EI"[$G(DUZ("AG")),$G(DUZ(2)) D
+ . N DGNODE S DGNODE=$G(^AUPNPAT(DFN,41,DUZ(2),0)) ; get 0-node for the
+ . ; current Facility from the Health Record No. multiple field
+ . ; (4101/9000001.41) for DFN in the IHS Patient file (9000001)
+ . N DGHRN S DGHRN=$P(DGNODE,U,2) ; Health Record No. (.02)
+ . W ?42," HRN: ",DGHRN
+ ;
+ D
+ . N DGSEX S DGSEX=$P(DGRP(0),U,2) ; Sex fld (.02) of Patient file (2)
+ . W ?61,"Sex: ",$S(DGSEX="M":"MALE",DGSEX="F":"FEMALE",1:"UNANSWERED")
+ ;
+ ;
+ ; field groups 1 & 2 part 5: show remaining name components and aliases
+ ;
+ ;
+ N DGCOUNT F DGCOUNT=2:1:6 D
+ . W !?5,$P(DGLABEL,U,DGCOUNT),": "
+ . N DGNAME S DGNAME=$G(DGCOMP(20,DGCOMP,DGCOUNT)) ; next name component
+ . W $E(DGNAME,1,$S(DGCOUNT=2:23,1:27)) ; 1st line leaves room for "[2]"
+ . I DGCOUNT=2 D  ; header for aliases
+ . . W ?37 N DGRPW,Z S DGRPW=0,Z=2 D WW^DGRPV ; write [2], suppress LF
+ . . W " Alias: "
+ . W ?47,$G(DGALIAS(DGCOUNT-1)) ; show next alias
+ ;
+ ;
+ ; show field group 3: remarks
+ ;
+ ;
+ ; ** end of VOE change 2 **
+ ;
  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
  S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
@@ -29,4 +185,15 @@
  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)
  W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
+ ;
+ ; ** VOE change 3 of 3 **
+ ;
+ ; if EHR agency code, display Alternate Phone Number (.134)
+ ;
+ ; new lines:
+ I $G(DUZ("AG"))="E" D
+ . W !?1,"Alt Ph: ",$P($G(^DPT(DFN,.13)),U,4)
+ ;
+ ; ** end of VOE change 3 **
+ ;
  W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
  ;
@@ -50,34 +217,4 @@
  G ^DGRPP
  ;
-GETNCAL ;Get name component values
- N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
- S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
- S DGCOMP=+$G(^DPT(DFN,"NAME"))_","
- I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
- ;Get alias values
- S DGA=0 F DGI=1:1:5 D  Q:'$D(DGALIAS(DGI))
-A2 .S DGA=$O(^DPT(DFN,.01,DGA))
- .I 'DGA D:DGI=1  Q
- ..S DGALIAS(DGI)="< No alias entries on file >" Q
- .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q
- .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2
- .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)
- .I $L(DGX) D
- ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)
- ..; BAJ DG*5.3*700 retrofit 06/22/06
- ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)
- ..S $E(DGALIAS(DGI),20)=DGX Q
- .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)
- .Q
- ;Display name component, sex, multiple birth indicator and alias data
- F DGI=1:1:6 D
- .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:23,1:27))
- .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^DGRPV
- .; BAJ DG*5.3*700 retrofit 06/2206
- .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^DGRPV
- .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "
- .I DGI>1 W ?47,$G(DGALIAS(DGI-1))
- .Q
- Q
 SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
  S DGREAS=$P(DGRP("SSN"),U)
