Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.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/DGRPECE.m
r613 r623 1 DGRPECE 2 ;;5.3;Registration;**638,682,700,720,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 CEDITS(DFN) 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 REAS 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 DOB 79 80 81 82 83 84 SEX 85 86 87 88 89 90 MBI 91 92 93 94 95 CECHECK 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 SAVE(DFN) 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 BEFORE(IEN,BEF,BUF) 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 AFTER(BEF,BUF,SAV) 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 WARNING() 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 ALERT 212 213 214 215 216 1 DGRPECE ;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 ; 20 CEDITS(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 60 REAS . ; 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 78 DOB ;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 84 SEX ;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 90 MBI ; 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 95 CECHECK ;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 ; 110 SAVE(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 ; 136 BEFORE(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 ; 162 AFTER(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 ; 196 WARNING() ;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 ; 211 ALERT ;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 TracChangeset
for help on using the changeset viewer.
