source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 9.5 KB
Line 
1DGRPECE ;ALB/MRY - REGISTRATION CATASTROPHIC EDITS ;1/6/07 13:28
2 ;;5.3;Registration;**638,682,700,720,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 ;
20CEDITS(DFN) ;catastrophic edits - buffer values, save after check
21 ;Input;
22 ; DFN := patient ien
23 ;Catastrophic edits will prompt for name, ssn, dob, and sex. Placing
24 ;responses into a buffer space. User will be alerted on catastrophic
25 ;edits on the following conditions:
26 ; 1. Two or more catastrophic edits will generate a warning message.
27 ; 2. Acceptance of two or more catastrophic edits will generate an alert
28 ; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key.
29 ; 3. Acceptance of <2 catastrophic edits will process normally.
30 ;
31 ; Arrays: BEFORE - Holds patient values before the edit process
32 ; (before snapshot).
33 ; BUFFER - initialized with BEFORE array, holds edited changes
34 ; (after snapshot).
35 ; SAVE - holds only edited changes for filing into file #2.
36 ;
37 N DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN
38 D BEFORE(DFN,.BEFORE,.BUFFER) ;retrieve before patient values
39 ;buffer - get name
40 K DG20NAME
41 S BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME)
42 I BUFFER("NAME")="" S BUFFER("NAME")=BEFORE("NAME")
43 I $D(DG20NAME("FAMILY")) S BUFFER("FAMILY")=DG20NAME("FAMILY")
44 I $D(DG20NAME("GIVEN")) S BUFFER("GIVEN")=DG20NAME("GIVEN")
45 I $D(DG20NAME("MIDDLE")) S BUFFER("MIDDLE")=DG20NAME("MIDDLE")
46 I $D(DG20NAME("SUFFIX")) S BUFFER("SUFFIX")=DG20NAME("SUFFIX")
47 ; the formal name is last name, first name, middle name and suffix
48 ; the prefix and degree are only stored in file 20
49 I $D(DG20NAME("PREFIX")) S BUFFER("PREFIX")=DG20NAME("PREFIX")
50 I $D(DG20NAME("DEGREE")) S BUFFER("DEGREE")=DG20NAME("DEGREE")
51 K DG20NAME
52 ;buffer - get ssn
53 S DIR(0)="2,.09^^"
54 S DA=DFN D ^DIR
55 I $D(DIRUT),DUZ("AG")="V" D CECHECK Q ; VOE modification, SSN may be null
56 I $D(DTOUT)!$D(DUOUT) D CECHECK Q ; VOE modification
57 S BUFFER("SSN")=Y
58 ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC
59 I $G(BUFFER("SSN"))["P" D I $D(DIRUT) D CECHECK Q
60REAS . ;
61 . N DGREA,DGQSSN,DIR
62 . S DGQSSN=0
63 . S DGREA=$P($G(^DPT(DFN,"SSN")),U)
64 . S DIR(0)="2,.0906^^"
65 . S DA=DFN
66 . D ^DIR
67 . I ($D(DUOUT)!($D(DTOUT))!($D(DIRUT))),($G(BUFFER("SSNREAS"))']"") D
68 . . W !?10,"PSSN Reason Required if SSN is a Pseudo."
69 . . I $G(BEFORE("SSN"))["P" G REAS
70 . . I $G(BEFORE("SSN"))']"" G REAS
71 . . S DIR(0)="YA",DIR("A")=" Delete Pseudo SSN?: ",DIR("?")="If the SSN is a Pseudo SSN there must be a Pseudo SSN Reason.",DIR("B")="YES"
72 . . D ^DIR
73 . . I Y=1 S BUFFER("SSN")=BEFORE("SSN"),DGQSSN=1,Y="" Q
74 . . G REAS
75 . I DGQSSN=1 Q
76 . S BUFFER("SSNREAS")=Y
77 . I $D(DIRUT)!('$D(BUFFER("SSN"))) D CECHECK Q
78DOB ;buffer - get dob
79 S DIR(0)="2,.03^^"
80 S DA=DFN D ^DIR
81 I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
82 I $D(DTOUT)!$D(DUOUT) D CECHECK Q ; VOE modification
83 S BUFFER("DOB")=Y
84SEX ;buffer - get sex
85 S DIR(0)="2,.02^^"
86 S DA=DFN D ^DIR
87 I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
88 I $D(DTOUT)!$D(DUOUT) D CECHECK Q ; VOE modification
89 S BUFFER("SEX")=Y
90MBI ; buffer - get MBI (multiple birth indicator)
91 S DIR(0)="2,994^^"
92 S DA=DFN D ^DIR
93 S BUFFER("MBI")=Y
94 I $D(DIRUT) D CECHECK Q
95CECHECK ;do catastrophic edit checks, alert, and save
96 N DGCNT,DGCEFLG
97 ;Compare before/buffer arrays, putting edits into save array.
98 S DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE)
99 ; DGCNT: 0 = no changes
100 ; 1 = only one edit change, ok to save w/o CE message
101 ; >1 = more then 1 edit, give CE message
102 I DGCNT>1 D ;give CE message
103 . S DGCEFLG=$$WARNING()
104 . ; DGCEFLG: 0 = exit without saving changes
105 . ; 1 = send alert and save
106 . I DGCEFLG=0 S DGCNT=0
107 I DGCNT>0 D SAVE(DFN) I $D(DGCEFLG),DGCEFLG D ALERT
108 Q
109 ;
110SAVE(DFN) ;store accepted/edited values into patient file
111 N FDATA,DIERR
112 I $D(SAVE("NAME")) S FDATA(2,+DFN_",",.01)=SAVE("NAME")
113 I $D(SAVE("DOB")) S FDATA(2,+DFN_",",.03)=SAVE("DOB")
114 I $D(SAVE("SEX")) S FDATA(2,+DFN_",",.02)=SAVE("SEX")
115 I $D(SAVE("SSN")) S FDATA(2,+DFN_",",.09)=SAVE("SSN")
116 I $D(SAVE("SSNREAS")) S FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS")
117 I $D(SAVE("MBI")) S FDATA(2,+DFN_",",994)=SAVE("MBI")
118 D FILE^DIE("","FDATA","DIERR")
119 K FDATA,DIERR
120 I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I")
121 I $D(SAVE("NAME")) D
122 .S FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY")
123 .S FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN")
124 .S FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE")
125 .S FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX")
126 .D FILE^DIE("","FDATA","DIERR")
127 .K FDATA,DIERR
128 I $D(BUFFER("PREFIX")) S FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX")
129 I $D(BUFFER("DEGREE")) S FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE")
130 I $D(SAVE("PREFIX")) S FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX")
131 I $D(SAVE("DEGREE")) S FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE")
132 D FILE^DIE("","FDATA","DIERR")
133 K FDATA,DIERR
134 Q
135 ;
136BEFORE(IEN,BEF,BUF) ;save original name, ssn, dob, sex, mbi, prefix, degree
137 N DG20
138 S BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01),BUF("NAME")=BEF("NAME")
139 S BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09),BUF("SSN")=BEF("SSN")
140 S BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906),BUF("SSNREAS")=BEF("SSNREAS")
141 S BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I"),BUF("DOB")=BEF("DOB")
142 S BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I"),BUF("SEX")=BEF("SEX")
143 S BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I"),BUF("MBI")=BEF("MBI")
144 D GETS^DIQ(2,+IEN_",",1.01,"I","DG20")
145 S BEF("FAMILY")="",BEF("GIVEN")="",BUF("FAMILY")="",BUF("GIVEN")=""
146 S BEF("MIDDLE")="",BEF("SUFFIX")="",BUF("MIDDLE")="",BUF("SUFFIX")=""
147 S BEF("PREFIX")="",BEF("DEGREE")="",BUF("PREFIX")="",BUF("DEGREE")=""
148 S DG20IEN=DG20(2,+IEN_",",1.01,"I")
149 I $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN D
150 . S BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1),BUF("FAMILY")=BEF("FAMILY")
151 . S BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2),BUF("GIVEN")=BEF("GIVEN")
152 . S BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3),BUF("MIDDLE")=BEF("MIDDLE")
153 . S BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5),BUF("SUFFIX")=BEF("SUFFIX")
154 . S BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4),BUF("PREFIX")=BEF("PREFIX")
155 . S BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6),BUF("DEGREE")=BEF("DEGREE")
156 ;add some demographic information (before snapshot)
157 S BEF("MAIDEN")=$E($$GET1^DIQ(2,+IEN_",",.2403),1,17)
158 S BEF("POBCITY")=$E($$GET1^DIQ(2,+IEN_",",.092),1,15)
159 S BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I")
160 Q
161 ;
162AFTER(BEF,BUF,SAV) ;prevent catastrophic edit checks
163 N DGCNT,DG20CNT S (DGCNT,DG20CNT)=0
164 I $D(BUF("FAMILY")),BUF("FAMILY")'="",BUF("FAMILY")'=BEF("FAMILY") D
165 . S DG20CNT=DG20CNT+1
166 . S SAV("NAME")=BUF("NAME")
167 I $D(BUF("GIVEN")),BUF("GIVEN")'="",BUF("GIVEN")'=BEF("GIVEN") D
168 . S DG20CNT=DG20CNT+1
169 . S SAV("NAME")=BUF("NAME")
170 I $D(BUF("MIDDLE")),BUF("MIDDLE")'=BEF("MIDDLE") D
171 . S SAV("NAME")=BUF("NAME") ; minor change doesn't count
172 I $D(BUF("SUFFIX")),BUF("SUFFIX")'=BEF("SUFFIX") D
173 . S SAV("NAME")=BUF("NAME") ; minor change doesn't count
174 I DG20CNT>0 S DGCNT=1
175 I $D(BUF("PREFIX")),BUF("PREFIX")'=BEF("PREFIX") D
176 . S SAV("PREFIX")=BUF("PREFIX")
177 I $D(BUF("DEGREE")),BUF("DEGREE")'=BEF("DEGREE") D
178 . S SAV("DEGREE")=BUF("DEGREE")
179 I $D(BUF("DOB")),BUF("DOB")'="",BUF("DOB")'=BEF("DOB") D
180 . S SAV("DOB")=BUF("DOB"),DGCNT=DGCNT+1
181 I $D(BUF("SEX")),BUF("SEX")'="",BUF("SEX")'=BEF("SEX") D
182 . S SAV("SEX")=BUF("SEX"),DGCNT=DGCNT+1
183 I $D(BUF("SSN")),BUF("SSN")'="",BUF("SSN")'=BEF("SSN") D
184 . S SAV("SSN")=BUF("SSN"),DGCNT=DGCNT+1
185 I $D(BUF("SSNREAS")),BUF("SSNREAS")'="",BUF("SSNREAS")'=BEF("SSNREAS") D
186 . S SAV("SSNREAS")=BUF("SSNREAS"),DGCNT=DGCNT+1
187 I $D(BUF("MBI")),BUF("MBI")'=BEF("MBI") D
188 . S SAV("MBI")=BUF("MBI")
189 I DGCNT=0,$D(SAV("NAME")) Q 1 ;minor name change (i.e. middle name or suffix)
190 I DGCNT=0,$D(SAV("PREFIX"))!($D(SAV("DEGREE"))) Q 1 ; prefix or degree change
191 I DGCNT=0,$D(SAV("MBI")) Q 1 ; multiple birth indicator change
192 I DGCNT=0 Q 0 ;no changes
193 I DGCNT<2 Q 1 ;make one change w/o CE message
194 I DGCNT>1 Q 2 ;more than 1 change, send CE message
195 ;
196WARNING() ;CE warning message
197 ;Output 0 = exit without saving changes
198 ; 1 = send alert and save
199 W !!,?25,"**WARNING!!**"
200 W !!,"The edits you are about to make, may potentially change the identity of"
201 W !,"this patient. Please verify that you have selected the correct patient"
202 W !,"and ensure that supporting documentation exists for these changes. If"
203 W !,"you continue with these edits, an alert will be generated and sent to"
204 W !,"your Supervisor and ADPAC, notifying them of the changes."
205 N DIR,DGANS,Y
206 S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits:"
207 S DIR("B")="NO" D ^DIR K DIR S DGANS=Y
208 S DGANS=$S(Y=1:1,1:0) ;0=don't save, 1=save with CE alert
209 Q DGANS
210 ;
211ALERT ;Queue alert
212 X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ALERT^DGRPECE1",ZTDTH=$H,ZTIO="",IEN=DFN
213 F V="IEN","BEFORE(","BUFFER(","SAVE(","XQY" S ZTSAVE(V)=""
214 S ZTDESC="Patient Catastrophic Edits alert" K V,ZTSK N X D ^%ZTLOAD Q
215 ;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE)
216 Q
Note: See TracBrowser for help on using the repository browser.