Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.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/DGRP1.m
r613 r623 1 DGRP1 2 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,634**;Aug 13, 1993;Build 30 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 EN 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 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 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 SSNREAS(DGREAS) 220 221 222 223 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
Note:
See TracChangeset
for help on using the changeset viewer.
