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

Last change on this file since 1724 was 628, checked in by George Lilly, 15 years ago

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