| 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.
|
|---|
| 36 | ;
|
|---|
| 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:"")
|
|---|
| 38 | I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
|
|---|
| 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 | ;
|
|---|
| 58 | W ! S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
|
|---|
| 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
|
|---|
| 60 | W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
|
|---|
| 61 | ;add Pseudo SSN Reason - DG*5.3*653, ERC
|
|---|
| 62 | I $P(DGRP(0),U,9)["P" D
|
|---|
| 63 | . N DGSPACE
|
|---|
| 64 | . S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen
|
|---|
| 65 | . S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: "
|
|---|
| 66 | . I $P(DGRP(0),U,9)["P" D
|
|---|
| 67 | . . N DGREAS D SSNREAS(.DGREAS)
|
|---|
| 68 | . . Q:$G(DGREAS)']""
|
|---|
| 69 | . . W DGREAS
|
|---|
| 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 | ;
|
|---|
| 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
|
|---|
| 177 | S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
|
|---|
| 178 | D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: "
|
|---|
| 179 | W !?11
|
|---|
| 180 | S Z1=40,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
|
|---|
| 181 | S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) !?11 W:'(I#2) ?51 W DGA(I)
|
|---|
| 182 | S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?3,"County: ",DGCC K DGCC
|
|---|
| 183 | S DGCC=$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(.121),U,5),1,+$P(DGRP(.121),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W ?43,"County: ",DGCC K DGCC
|
|---|
| 184 | W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
|
|---|
| 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)
|
|---|
| 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 | ;
|
|---|
| 198 | W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
|
|---|
| 199 | ;
|
|---|
| 200 | ; *** Additional displays added for Pre-Registration
|
|---|
| 201 | I $G(DGPRFLG)=1 D
|
|---|
| 202 | . W !
|
|---|
| 203 | . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1
|
|---|
| 204 | . I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1 I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2)
|
|---|
| 205 | . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
|
|---|
| 206 | . I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1 S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2)
|
|---|
| 207 | . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
|
|---|
| 208 | . I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1 S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2)
|
|---|
| 209 | . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
|
|---|
| 210 | . I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1 S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2)
|
|---|
| 211 | . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
|
|---|
| 212 | . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
|
|---|
| 213 | . I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI D
|
|---|
| 214 | .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
|
|---|
| 215 | .. W " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D")," EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
|
|---|
| 216 | ;
|
|---|
| 217 | G ^DGRPP
|
|---|
| 218 | ;
|
|---|
| 219 | SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
|
|---|
| 220 | S DGREAS=$P(DGRP("SSN"),U)
|
|---|
| 221 | I $G(DGREAS)']"" Q
|
|---|
| 222 | S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >")
|
|---|
| 223 | Q
|
|---|
