DGRPECE ;ALB/MRY,ERC,BAJ,NCA - REGISTRATION CATASTROPHIC EDITS ; 10/4/06 3:27pm
;;5.3;Registration;**638,682,700,720,653,688,750,831,907,965,1007,1033**;Aug 13, 1993;Build 3
;
CEDITS(DFN) ;catastrophic edits - buffer values, save after check
;Input;
; DFN := patient ien
;Catastrophic edits will prompt for name, ssn, dob, and sex. Placing
;responses into a buffer space. User will be alerted on catastrophic
;edits on the following conditions:
; 1. Two or more catastrophic edits will generate a warning message.
; 2. Acceptance of two or more catastrophic edits will generate an alert
; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key.
; 3. Acceptance of <2 catastrophic edits will process normally.
;
; Arrays: BEFORE - Holds patient values before the edit process
; (before snapshot).
; BUFFER - initialized with BEFORE array, holds edited changes
; (after snapshot).
; SAVE - holds only edited changes for filing into file #2.
;
N DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN,XUNOTRIG
D BEFORE(DFN,.BEFORE,.BUFFER) ;retrieve before patient values
;buffer - get name
K DG20NAME
S BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME)
I BUFFER("NAME")="" S BUFFER("NAME")=BEFORE("NAME")
I $D(DG20NAME("FAMILY")) S BUFFER("FAMILY")=DG20NAME("FAMILY")
I $D(DG20NAME("GIVEN")) S BUFFER("GIVEN")=DG20NAME("GIVEN")
I $D(DG20NAME("MIDDLE")) S BUFFER("MIDDLE")=DG20NAME("MIDDLE")
I $D(DG20NAME("SUFFIX")) S BUFFER("SUFFIX")=DG20NAME("SUFFIX")
; the formal name is last name, first name, middle name and suffix
; the prefix and degree are only stored in file 20
I $D(DG20NAME("PREFIX")) S BUFFER("PREFIX")=DG20NAME("PREFIX")
I $D(DG20NAME("DEGREE")) S BUFFER("DEGREE")=DG20NAME("DEGREE")
K DG20NAME
;DG*5.3*688 BAJ if SSN is verified, do not allow edits
I BEFORE("SSNV")="VERIFIED" D G DOB
. S BUFFER("SSN")=BEFORE("SSN")
. W !,"SSN: "_BUFFER("SSN")
. W !,"SOCIAL SECURITY NUMBER "_BUFFER("SSN")_" has been verified by SSA --NO EDITING"
;buffer - get ssn
S DIR(0)="2,.09^^"
S DA=DFN D ^DIR
I $D(DIRUT) D CECHECK Q
S BUFFER("SSN")=Y
;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC
I $G(BUFFER("SSN"))["P" D I $D(DIRUT) D CECHECK Q
REAS . ;
. N DGREA,DGQSSN,DIR
. S DGQSSN=0
. S DGREA=$P($G(^DPT(DFN,"SSN")),U)
. S DIR(0)="2,.0906^^"
. S DA=DFN
. D ^DIR
. I ($D(DUOUT)!($D(DTOUT))!($D(DIRUT))),($G(BUFFER("SSNREAS"))']"") D
. . W !?10,"PSSN Reason Required if SSN is a Pseudo."
. . I $G(BEFORE("SSN"))["P" G REAS
. . I $G(BEFORE("SSN"))']"" G REAS
. . 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"
. . D ^DIR
. . I Y=1 S BUFFER("SSN")=BEFORE("SSN"),DGQSSN=1,Y="" Q
. . G REAS
. I DGQSSN=1 Q
. S BUFFER("SSNREAS")=Y
. I $D(DIRUT)!('$D(BUFFER("SSN"))) D CECHECK Q
DOB ;buffer - get dob
S DIR(0)="2,.03^^"
S DA=DFN D ^DIR
I $D(DIRUT) D CECHECK Q
S BUFFER("DOB")=Y
SEX ;buffer - get sex
S DIR(0)="2,.02^^"
S DIR("A")="BIRTH SEX" ; DG*5.3*907
S DA=DFN D ^DIR
K DIR("A") ; DG*5.3*907
I $D(DIRUT) D CECHECK Q
S BUFFER("SEX")=Y
; DG*5.3*907 - begin of SIGI change in this section
SIGI ;buffer - get Self-Identified Gender Identity ; DG*5.3*907
S DIR(0)="2,.024ABr" ;**1033, VAMPI-13 (jfw) - Remove Hard-Coded logic and replace with DD Read Type
;S DIR(0)="SAB^M:Male;F:Female;TM:Transmale/Transman/Female-to-Male;TF:Transfemale/Transwoman/Male-to-Female;O:Other;N:individual chooses not to answer"
;S DIR("?",1)="Select the code that specifies the patient's preferred gender."
S DIR("?",1)="This SELF IDENTIFIED GENDER value indicates the patient's view of"
S DIR("?")="their gender identity, if they choose to provide it."
S DIR("A")="SELF-IDENTIFIED GENDER IDENTITY: " S:$G(BEFORE("SIGI"))'="" DIR("B")=$$GET1^DIQ(2,+DFN_",",.024)
D ^DIR
K DIR("A"),DIR("B"),DIR("?")
;**1033, VAMPI-13 (jfw) - Insert check for deletion to display previous message
I X="@" W !,"This is a required response. Enter '^' to exit" G SIGI
I $D(DIRUT) S BUFFER("SIGI")=BEFORE("SIGI") D CECHECK Q
S BUFFER("SIGI")=Y
; DG*5.3*907 - end-section of SIGI
MBI ; buffer - get MBI (multiple birth indicator)
S DIR(0)="2,994^^"
S DA=DFN D ^DIR
S BUFFER("MBI")=Y
I $D(DIRUT) D CECHECK Q
CECHECK ;do catastrophic edit checks, alert, and save
N DGCNT,DGCEFLG
;Compare before/buffer arrays, putting edits into save array.S DIR("A")="SELF IDENTIFIED GENDER IDENTITY"
S DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE)
; DGCNT: 0 = no changes
; 1 = only one edit change, ok to save w/o CE message
; >1 = more then 1 edit, give CE message
I DGCNT>1 D ;give CE message
. S DGCEFLG=$$WARNING()
. ; DGCEFLG: 0 = exit without saving changes
. ; 1 = send alert and save
. I DGCEFLG=0 S DGCNT=0
I DGCNT>0 D SAVE(DFN) I $D(DGCEFLG),DGCEFLG D ALERT
Q
;
SAVE(DFN) ;store accepted/edited values into patient file
N FDATA,DIERR
I $D(SAVE("NAME")) S FDATA(2,+DFN_",",.01)=SAVE("NAME")
I $D(SAVE("DOB")) S FDATA(2,+DFN_",",.03)=SAVE("DOB")
I $D(SAVE("SEX")) S FDATA(2,+DFN_",",.02)=SAVE("SEX")
I $D(SAVE("SSN")) S FDATA(2,+DFN_",",.09)=SAVE("SSN")
I $D(SAVE("SSNREAS")) S FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS")
I $D(SAVE("MBI")) S FDATA(2,+DFN_",",994)=SAVE("MBI")
I $D(SAVE("SIGI")) S FDATA(2,+DFN_",",.024)=SAVE("SIGI") ; DG*5.3*907
D FILE^DIE("","FDATA","DIERR")
K FDATA,DIERR
;I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") Q:DG20IEN="" ;DG*5.3*965 commented out this line
I $G(DG20IEN),'$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") ;DG*5.3*965
I '$G(DG20IEN) D Q ;DG*5.3*965
.N DA,DIK
.S DA=+DFN,DIK="^DPT(",DIK(1)=".01^ANAM01" D EN1^DIK
.S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I")
Q:'$G(DG20IEN)
I $D(SAVE("NAME")) D
.S FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY")
.S FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN")
.S FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE")
.S FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX")
.S XUNOTRIG=1
.D FILE^DIE("","FDATA","DIERR")
.K FDATA,DIERR
I $D(BUFFER("PREFIX")) S FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX")
I $D(BUFFER("DEGREE")) S FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE")
I $D(SAVE("PREFIX")) S FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX")
I $D(SAVE("DEGREE")) S FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE")
D FILE^DIE("","FDATA","DIERR")
K FDATA,DIERR
Q
;
BEFORE(IEN,BEF,BUF) ;save original name, ssn, dob, sex, mbi, prefix, degree
N DG20
S BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01),BUF("NAME")=BEF("NAME")
S BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09),BUF("SSN")=BEF("SSN")
;Get SSN Verification flag DG*5.3*688 BAJ 11/22/2005
S BEF("SSNV")=$$GET1^DIQ(2,+IEN_",",.0907),BUF("SSNV")=BEF("SSNV")
S BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906),BUF("SSNREAS")=BEF("SSNREAS")
S BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I"),BUF("DOB")=BEF("DOB")
S BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I"),BUF("SEX")=BEF("SEX")
S BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I"),BUF("MBI")=BEF("MBI")
S BEF("SIGI")=$$GET1^DIQ(2,+IEN_",",.024,"I"),BUF("SIGI")=BEF("SIGI") ; DG*5.3*907
D GETS^DIQ(2,+IEN_",",1.01,"I","DG20")
S BEF("FAMILY")="",BEF("GIVEN")="",BUF("FAMILY")="",BUF("GIVEN")=""
S BEF("MIDDLE")="",BEF("SUFFIX")="",BUF("MIDDLE")="",BUF("SUFFIX")=""
S BEF("PREFIX")="",BEF("DEGREE")="",BUF("PREFIX")="",BUF("DEGREE")=""
S DG20IEN=DG20(2,+IEN_",",1.01,"I")
I $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN D
. S BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1),BUF("FAMILY")=BEF("FAMILY")
. S BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2),BUF("GIVEN")=BEF("GIVEN")
. S BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3),BUF("MIDDLE")=BEF("MIDDLE")
. S BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5),BUF("SUFFIX")=BEF("SUFFIX")
. S BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4),BUF("PREFIX")=BEF("PREFIX")
. S BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6),BUF("DEGREE")=BEF("DEGREE")
;add some demographic information (before snapshot)
S BEF("MAIDEN")=$E($$GET1^DIQ(2,+IEN_",",.2403),1,17)
S BEF("POBCITY")=$E($$GET1^DIQ(2,+IEN_",",.092),1,15)
S BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I")
Q
;
AFTER(BEF,BUF,SAV) ;prevent catastrophic edit checks
N DGCNT,DG20CNT S (DGCNT,DG20CNT)=0
I $D(BUF("FAMILY")),BUF("FAMILY")'="",BUF("FAMILY")'=BEF("FAMILY") D
. S DG20CNT=DG20CNT+1
. S SAV("NAME")=BUF("NAME")
I $D(BUF("GIVEN")),BUF("GIVEN")'="",BUF("GIVEN")'=BEF("GIVEN") D
. S DG20CNT=DG20CNT+1
. S SAV("NAME")=BUF("NAME")
I $D(BUF("MIDDLE")),BUF("MIDDLE")'=BEF("MIDDLE") D
. S SAV("NAME")=BUF("NAME") ; minor change doesn't count
I $D(BUF("SUFFIX")),BUF("SUFFIX")'=BEF("SUFFIX") D
. S SAV("NAME")=BUF("NAME") ; minor change doesn't count
I DG20CNT>0 S DGCNT=1
I $D(BUF("PREFIX")),BUF("PREFIX")'=BEF("PREFIX") D
. S SAV("PREFIX")=BUF("PREFIX")
I $D(BUF("DEGREE")),BUF("DEGREE")'=BEF("DEGREE") D
. S SAV("DEGREE")=BUF("DEGREE")
I $D(BUF("SIGI")),BUF("SIGI")'="",BUF("SIGI")'=BEF("SIGI") D ; DG*5.3*907
. S SAV("SIGI")=BUF("SIGI") ; DG*5.3*907
I $D(BUF("DOB")),BUF("DOB")'="",BUF("DOB")'=BEF("DOB") D
. S SAV("DOB")=BUF("DOB"),DGCNT=DGCNT+1
I $D(BUF("SEX")),BUF("SEX")'="",BUF("SEX")'=BEF("SEX") D
. S SAV("SEX")=BUF("SEX"),DGCNT=DGCNT+1
I $D(BUF("SSN")),BUF("SSN")'="",BUF("SSN")'=BEF("SSN") D
. S SAV("SSN")=BUF("SSN"),DGCNT=DGCNT+1
I $D(BUF("SSNREAS")),BUF("SSNREAS")'="",BUF("SSNREAS")'=BEF("SSNREAS") D
. S SAV("SSNREAS")=BUF("SSNREAS")
I $D(BUF("MBI")),BUF("MBI")'=BEF("MBI") D
. S SAV("MBI")=BUF("MBI")
I DGCNT=0,$D(SAV("NAME")) Q 1 ;minor name change (i.e. middle name or suffix)
I DGCNT=0,$D(SAV("PREFIX"))!($D(SAV("DEGREE"))) Q 1 ; prefix or degree change
I DGCNT=0,$D(SAV("MBI")) Q 1 ; multiple birth indicator change
I DGCNT=0,$D(SAV("SIGI")) Q 1 ; DG*5.3*907 - Add SIGI indicator change
I DGCNT=0 Q 0 ;no changes
;DG*750 check audit file for previous changes made during the current day
I DGCNT=1 D DGAUD^DGRPAUD(DFN,.DGCNT)
;Use temp file created in DGRPAUD to get information for other changes
;that were made during the day to print on the alert.
N DGAUDIEN,DGFLD,DGTYP
S DGAUDIEN=0
F S DGAUDIEN=$O(^TMP("DGRPAUD",$J,DFN,DGAUDIEN)) Q:'DGAUDIEN D
.S DGFLD=$P(^TMP("DGRPAUD",$J,DFN,DGAUDIEN),U,2),DGTYP=$P(^TMP("DGRPAUD",$J,DFN,DGAUDIEN),U,5)
.I DGFLD=.01 S BEF("NAME")=DGTYP
.I DGFLD=.09 S BEF("SSN")=DGTYP
.I DGFLD=.02 S BEF("SEX")=DGTYP
.I DGFLD=.03 S BEF("DOB")=DGTYP
.I DGFLD=.024 S BEF("SIGI")=DGTYP ; DG*5.3*907
I DGCNT<2 Q 1 ;make one change w/o CE message
I DGCNT>1 Q 2 ;more than 1 change, send CE message
K ^TMP("DGRPAUD")
;
WARNING() ;CE warning message
;Output 0 = exit without saving changes
; 1 = send alert and save
W !!,?25,"**WARNING!!**"
W !!,"The edits you are about to make, may potentially change the identity of"
W !,"this patient. Please verify that you have selected the correct patient"
W !,"and ensure that supporting documentation exists for these changes. If"
W !,"you continue with these edits, an alert will be generated and sent to"
W !,"your Supervisor and ADPAC, notifying them of the changes."
N DIR,DGANS,Y
S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits:"
S DIR("B")="NO" D ^DIR K DIR S DGANS=Y
S DGANS=$S(Y=1:1,1:0) ;0=don't save, 1=save with CE alert
Q DGANS
;
ALERT ;Queue alert
X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ALERT^DGRPECE1",ZTDTH=$H,ZTIO="",IEN=DFN
F V="IEN","BEFORE(","BUFFER(","SAVE(","XQY" S ZTSAVE(V)=""
S ZTDESC="Patient Catastrophic Edits alert" K V,ZTSK N X D ^%ZTLOAD Q
;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPECE 11794 printed Oct 16, 2024@18:56:51 Page 2
DGRPECE ;ALB/MRY,ERC,BAJ,NCA - REGISTRATION CATASTROPHIC EDITS ; 10/4/06 3:27pm
+1 ;;5.3;Registration;**638,682,700,720,653,688,750,831,907,965,1007,1033**;Aug 13, 1993;Build 3
+2 ;
CEDITS(DFN) ;catastrophic edits - buffer values, save after check
+1 ;Input;
+2 ; DFN := patient ien
+3 ;Catastrophic edits will prompt for name, ssn, dob, and sex. Placing
+4 ;responses into a buffer space. User will be alerted on catastrophic
+5 ;edits on the following conditions:
+6 ; 1. Two or more catastrophic edits will generate a warning message.
+7 ; 2. Acceptance of two or more catastrophic edits will generate an alert
+8 ; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key.
+9 ; 3. Acceptance of <2 catastrophic edits will process normally.
+10 ;
+11 ; Arrays: BEFORE - Holds patient values before the edit process
+12 ; (before snapshot).
+13 ; BUFFER - initialized with BEFORE array, holds edited changes
+14 ; (after snapshot).
+15 ; SAVE - holds only edited changes for filing into file #2.
+16 ;
+17 NEW DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN,XUNOTRIG
+18 ;retrieve before patient values
DO BEFORE(DFN,.BEFORE,.BUFFER)
+19 ;buffer - get name
+20 KILL DG20NAME
+21 SET BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME)
+22 IF BUFFER("NAME")=""
SET BUFFER("NAME")=BEFORE("NAME")
+23 IF $DATA(DG20NAME("FAMILY"))
SET BUFFER("FAMILY")=DG20NAME("FAMILY")
+24 IF $DATA(DG20NAME("GIVEN"))
SET BUFFER("GIVEN")=DG20NAME("GIVEN")
+25 IF $DATA(DG20NAME("MIDDLE"))
SET BUFFER("MIDDLE")=DG20NAME("MIDDLE")
+26 IF $DATA(DG20NAME("SUFFIX"))
SET BUFFER("SUFFIX")=DG20NAME("SUFFIX")
+27 ; the formal name is last name, first name, middle name and suffix
+28 ; the prefix and degree are only stored in file 20
+29 IF $DATA(DG20NAME("PREFIX"))
SET BUFFER("PREFIX")=DG20NAME("PREFIX")
+30 IF $DATA(DG20NAME("DEGREE"))
SET BUFFER("DEGREE")=DG20NAME("DEGREE")
+31 KILL DG20NAME
+32 ;DG*5.3*688 BAJ if SSN is verified, do not allow edits
+33 IF BEFORE("SSNV")="VERIFIED"
Begin DoDot:1
+34 SET BUFFER("SSN")=BEFORE("SSN")
+35 WRITE !,"SSN: "_BUFFER("SSN")
+36 WRITE !,"SOCIAL SECURITY NUMBER "_BUFFER("SSN")_" has been verified by SSA --NO EDITING"
End DoDot:1
GOTO DOB
+37 ;buffer - get ssn
+38 SET DIR(0)="2,.09^^"
+39 SET DA=DFN
DO ^DIR
+40 IF $DATA(DIRUT)
DO CECHECK
QUIT
+41 SET BUFFER("SSN")=Y
+42 ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC
+43 IF $GET(BUFFER("SSN"))["P"
Begin DoDot:1
REAS ;
+1 NEW DGREA,DGQSSN,DIR
+2 SET DGQSSN=0
+3 SET DGREA=$PIECE($GET(^DPT(DFN,"SSN")),U)
+4 SET DIR(0)="2,.0906^^"
+5 SET DA=DFN
+6 DO ^DIR
+7 IF ($DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIRUT)))
IF ($GET(BUFFER("SSNREAS"))']"")
Begin DoDot:2
+8 WRITE !?10,"PSSN Reason Required if SSN is a Pseudo."
+9 IF $GET(BEFORE("SSN"))["P"
GOTO REAS
+10 IF $GET(BEFORE("SSN"))']""
GOTO REAS
+11 SET DIR(0)="YA"
SET DIR("A")=" Delete Pseudo SSN?: "
SET DIR("?")="If the SSN is a Pseudo SSN there must be a Pseudo SSN Reason."
SET DIR("B")="YES"
+12 DO ^DIR
+13 IF Y=1
SET BUFFER("SSN")=BEFORE("SSN")
SET DGQSSN=1
SET Y=""
QUIT
+14 GOTO REAS
End DoDot:2
+15 IF DGQSSN=1
QUIT
+16 SET BUFFER("SSNREAS")=Y
+17 IF $DATA(DIRUT)!('$DATA(BUFFER("SSN")))
DO CECHECK
QUIT
End DoDot:1
IF $DATA(DIRUT)
DO CECHECK
QUIT
DOB ;buffer - get dob
+1 SET DIR(0)="2,.03^^"
+2 SET DA=DFN
DO ^DIR
+3 IF $DATA(DIRUT)
DO CECHECK
QUIT
+4 SET BUFFER("DOB")=Y
SEX ;buffer - get sex
+1 SET DIR(0)="2,.02^^"
+2 ; DG*5.3*907
SET DIR("A")="BIRTH SEX"
+3 SET DA=DFN
DO ^DIR
+4 ; DG*5.3*907
KILL DIR("A")
+5 IF $DATA(DIRUT)
DO CECHECK
QUIT
+6 SET BUFFER("SEX")=Y
+7 ; DG*5.3*907 - begin of SIGI change in this section
SIGI ;buffer - get Self-Identified Gender Identity ; DG*5.3*907
+1 ;**1033, VAMPI-13 (jfw) - Remove Hard-Coded logic and replace with DD Read Type
SET DIR(0)="2,.024ABr"
+2 ;S DIR(0)="SAB^M:Male;F:Female;TM:Transmale/Transman/Female-to-Male;TF:Transfemale/Transwoman/Male-to-Female;O:Other;N:individual chooses not to answer"
+3 ;S DIR("?",1)="Select the code that specifies the patient's preferred gender."
+4 SET DIR("?",1)="This SELF IDENTIFIED GENDER value indicates the patient's view of"
+5 SET DIR("?")="their gender identity, if they choose to provide it."
+6 SET DIR("A")="SELF-IDENTIFIED GENDER IDENTITY: "
if $GET(BEFORE("SIGI"))'=""
SET DIR("B")=$$GET1^DIQ(2,+DFN_",",.024)
+7 DO ^DIR
+8 KILL DIR("A"),DIR("B"),DIR("?")
+9 ;**1033, VAMPI-13 (jfw) - Insert check for deletion to display previous message
+10 IF X="@"
WRITE !,"This is a required response. Enter '^' to exit"
GOTO SIGI
+11 IF $DATA(DIRUT)
SET BUFFER("SIGI")=BEFORE("SIGI")
DO CECHECK
QUIT
+12 SET BUFFER("SIGI")=Y
+13 ; DG*5.3*907 - end-section of SIGI
MBI ; buffer - get MBI (multiple birth indicator)
+1 SET DIR(0)="2,994^^"
+2 SET DA=DFN
DO ^DIR
+3 SET BUFFER("MBI")=Y
+4 IF $DATA(DIRUT)
DO CECHECK
QUIT
CECHECK ;do catastrophic edit checks, alert, and save
+1 NEW DGCNT,DGCEFLG
+2 ;Compare before/buffer arrays, putting edits into save array.S DIR("A")="SELF IDENTIFIED GENDER IDENTITY"
+3 SET DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE)
+4 ; DGCNT: 0 = no changes
+5 ; 1 = only one edit change, ok to save w/o CE message
+6 ; >1 = more then 1 edit, give CE message
+7 ;give CE message
IF DGCNT>1
Begin DoDot:1
+8 SET DGCEFLG=$$WARNING()
+9 ; DGCEFLG: 0 = exit without saving changes
+10 ; 1 = send alert and save
+11 IF DGCEFLG=0
SET DGCNT=0
End DoDot:1
+12 IF DGCNT>0
DO SAVE(DFN)
IF $DATA(DGCEFLG)
IF DGCEFLG
DO ALERT
+13 QUIT
+14 ;
SAVE(DFN) ;store accepted/edited values into patient file
+1 NEW FDATA,DIERR
+2 IF $DATA(SAVE("NAME"))
SET FDATA(2,+DFN_",",.01)=SAVE("NAME")
+3 IF $DATA(SAVE("DOB"))
SET FDATA(2,+DFN_",",.03)=SAVE("DOB")
+4 IF $DATA(SAVE("SEX"))
SET FDATA(2,+DFN_",",.02)=SAVE("SEX")
+5 IF $DATA(SAVE("SSN"))
SET FDATA(2,+DFN_",",.09)=SAVE("SSN")
+6 IF $DATA(SAVE("SSNREAS"))
SET FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS")
+7 IF $DATA(SAVE("MBI"))
SET FDATA(2,+DFN_",",994)=SAVE("MBI")
+8 ; DG*5.3*907
IF $DATA(SAVE("SIGI"))
SET FDATA(2,+DFN_",",.024)=SAVE("SIGI")
+9 DO FILE^DIE("","FDATA","DIERR")
+10 KILL FDATA,DIERR
+11 ;I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") Q:DG20IEN="" ;DG*5.3*965 commented out this line
+12 ;DG*5.3*965
IF $GET(DG20IEN)
IF '$DATA(^VA(20,DG20IEN))
SET DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I")
+13 ;DG*5.3*965
IF '$GET(DG20IEN)
Begin DoDot:1
+14 NEW DA,DIK
+15 SET DA=+DFN
SET DIK="^DPT("
SET DIK(1)=".01^ANAM01"
DO EN1^DIK
+16 SET DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I")
End DoDot:1
QUIT
+17 if '$GET(DG20IEN)
QUIT
+18 IF $DATA(SAVE("NAME"))
Begin DoDot:1
+19 SET FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY")
+20 SET FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN")
+21 SET FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE")
+22 SET FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX")
+23 SET XUNOTRIG=1
+24 DO FILE^DIE("","FDATA","DIERR")
+25 KILL FDATA,DIERR
End DoDot:1
+26 IF $DATA(BUFFER("PREFIX"))
SET FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX")
+27 IF $DATA(BUFFER("DEGREE"))
SET FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE")
+28 IF $DATA(SAVE("PREFIX"))
SET FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX")
+29 IF $DATA(SAVE("DEGREE"))
SET FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE")
+30 DO FILE^DIE("","FDATA","DIERR")
+31 KILL FDATA,DIERR
+32 QUIT
+33 ;
BEFORE(IEN,BEF,BUF) ;save original name, ssn, dob, sex, mbi, prefix, degree
+1 NEW DG20
+2 SET BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01)
SET BUF("NAME")=BEF("NAME")
+3 SET BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09)
SET BUF("SSN")=BEF("SSN")
+4 ;Get SSN Verification flag DG*5.3*688 BAJ 11/22/2005
+5 SET BEF("SSNV")=$$GET1^DIQ(2,+IEN_",",.0907)
SET BUF("SSNV")=BEF("SSNV")
+6 SET BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906)
SET BUF("SSNREAS")=BEF("SSNREAS")
+7 SET BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I")
SET BUF("DOB")=BEF("DOB")
+8 SET BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I")
SET BUF("SEX")=BEF("SEX")
+9 SET BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I")
SET BUF("MBI")=BEF("MBI")
+10 ; DG*5.3*907
SET BEF("SIGI")=$$GET1^DIQ(2,+IEN_",",.024,"I")
SET BUF("SIGI")=BEF("SIGI")
+11 DO GETS^DIQ(2,+IEN_",",1.01,"I","DG20")
+12 SET BEF("FAMILY")=""
SET BEF("GIVEN")=""
SET BUF("FAMILY")=""
SET BUF("GIVEN")=""
+13 SET BEF("MIDDLE")=""
SET BEF("SUFFIX")=""
SET BUF("MIDDLE")=""
SET BUF("SUFFIX")=""
+14 SET BEF("PREFIX")=""
SET BEF("DEGREE")=""
SET BUF("PREFIX")=""
SET BUF("DEGREE")=""
+15 SET DG20IEN=DG20(2,+IEN_",",1.01,"I")
+16 IF $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN
Begin DoDot:1
+17 SET BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1)
SET BUF("FAMILY")=BEF("FAMILY")
+18 SET BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2)
SET BUF("GIVEN")=BEF("GIVEN")
+19 SET BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3)
SET BUF("MIDDLE")=BEF("MIDDLE")
+20 SET BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5)
SET BUF("SUFFIX")=BEF("SUFFIX")
+21 SET BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4)
SET BUF("PREFIX")=BEF("PREFIX")
+22 SET BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6)
SET BUF("DEGREE")=BEF("DEGREE")
End DoDot:1
+23 ;add some demographic information (before snapshot)
+24 SET BEF("MAIDEN")=$EXTRACT($$GET1^DIQ(2,+IEN_",",.2403),1,17)
+25 SET BEF("POBCITY")=$EXTRACT($$GET1^DIQ(2,+IEN_",",.092),1,15)
+26 SET BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I")
+27 QUIT
+28 ;
AFTER(BEF,BUF,SAV) ;prevent catastrophic edit checks
+1 NEW DGCNT,DG20CNT
SET (DGCNT,DG20CNT)=0
+2 IF $DATA(BUF("FAMILY"))
IF BUF("FAMILY")'=""
IF BUF("FAMILY")'=BEF("FAMILY")
Begin DoDot:1
+3 SET DG20CNT=DG20CNT+1
+4 SET SAV("NAME")=BUF("NAME")
End DoDot:1
+5 IF $DATA(BUF("GIVEN"))
IF BUF("GIVEN")'=""
IF BUF("GIVEN")'=BEF("GIVEN")
Begin DoDot:1
+6 SET DG20CNT=DG20CNT+1
+7 SET SAV("NAME")=BUF("NAME")
End DoDot:1
+8 IF $DATA(BUF("MIDDLE"))
IF BUF("MIDDLE")'=BEF("MIDDLE")
Begin DoDot:1
+9 ; minor change doesn't count
SET SAV("NAME")=BUF("NAME")
End DoDot:1
+10 IF $DATA(BUF("SUFFIX"))
IF BUF("SUFFIX")'=BEF("SUFFIX")
Begin DoDot:1
+11 ; minor change doesn't count
SET SAV("NAME")=BUF("NAME")
End DoDot:1
+12 IF DG20CNT>0
SET DGCNT=1
+13 IF $DATA(BUF("PREFIX"))
IF BUF("PREFIX")'=BEF("PREFIX")
Begin DoDot:1
+14 SET SAV("PREFIX")=BUF("PREFIX")
End DoDot:1
+15 IF $DATA(BUF("DEGREE"))
IF BUF("DEGREE")'=BEF("DEGREE")
Begin DoDot:1
+16 SET SAV("DEGREE")=BUF("DEGREE")
End DoDot:1
+17 ; DG*5.3*907
IF $DATA(BUF("SIGI"))
IF BUF("SIGI")'=""
IF BUF("SIGI")'=BEF("SIGI")
Begin DoDot:1
+18 ; DG*5.3*907
SET SAV("SIGI")=BUF("SIGI")
End DoDot:1
+19 IF $DATA(BUF("DOB"))
IF BUF("DOB")'=""
IF BUF("DOB")'=BEF("DOB")
Begin DoDot:1
+20 SET SAV("DOB")=BUF("DOB")
SET DGCNT=DGCNT+1
End DoDot:1
+21 IF $DATA(BUF("SEX"))
IF BUF("SEX")'=""
IF BUF("SEX")'=BEF("SEX")
Begin DoDot:1
+22 SET SAV("SEX")=BUF("SEX")
SET DGCNT=DGCNT+1
End DoDot:1
+23 IF $DATA(BUF("SSN"))
IF BUF("SSN")'=""
IF BUF("SSN")'=BEF("SSN")
Begin DoDot:1
+24 SET SAV("SSN")=BUF("SSN")
SET DGCNT=DGCNT+1
End DoDot:1
+25 IF $DATA(BUF("SSNREAS"))
IF BUF("SSNREAS")'=""
IF BUF("SSNREAS")'=BEF("SSNREAS")
Begin DoDot:1
+26 SET SAV("SSNREAS")=BUF("SSNREAS")
End DoDot:1
+27 IF $DATA(BUF("MBI"))
IF BUF("MBI")'=BEF("MBI")
Begin DoDot:1
+28 SET SAV("MBI")=BUF("MBI")
End DoDot:1
+29 ;minor name change (i.e. middle name or suffix)
IF DGCNT=0
IF $DATA(SAV("NAME"))
QUIT 1
+30 ; prefix or degree change
IF DGCNT=0
IF $DATA(SAV("PREFIX"))!($DATA(SAV("DEGREE")))
QUIT 1
+31 ; multiple birth indicator change
IF DGCNT=0
IF $DATA(SAV("MBI"))
QUIT 1
+32 ; DG*5.3*907 - Add SIGI indicator change
IF DGCNT=0
IF $DATA(SAV("SIGI"))
QUIT 1
+33 ;no changes
IF DGCNT=0
QUIT 0
+34 ;DG*750 check audit file for previous changes made during the current day
+35 IF DGCNT=1
DO DGAUD^DGRPAUD(DFN,.DGCNT)
+36 ;Use temp file created in DGRPAUD to get information for other changes
+37 ;that were made during the day to print on the alert.
+38 NEW DGAUDIEN,DGFLD,DGTYP
+39 SET DGAUDIEN=0
+40 FOR
SET DGAUDIEN=$ORDER(^TMP("DGRPAUD",$JOB,DFN,DGAUDIEN))
if 'DGAUDIEN
QUIT
Begin DoDot:1
+41 SET DGFLD=$PIECE(^TMP("DGRPAUD",$JOB,DFN,DGAUDIEN),U,2)
SET DGTYP=$PIECE(^TMP("DGRPAUD",$JOB,DFN,DGAUDIEN),U,5)
+42 IF DGFLD=.01
SET BEF("NAME")=DGTYP
+43 IF DGFLD=.09
SET BEF("SSN")=DGTYP
+44 IF DGFLD=.02
SET BEF("SEX")=DGTYP
+45 IF DGFLD=.03
SET BEF("DOB")=DGTYP
+46 ; DG*5.3*907
IF DGFLD=.024
SET BEF("SIGI")=DGTYP
End DoDot:1
+47 ;make one change w/o CE message
IF DGCNT<2
QUIT 1
+48 ;more than 1 change, send CE message
IF DGCNT>1
QUIT 2
+49 KILL ^TMP("DGRPAUD")
+50 ;
WARNING() ;CE warning message
+1 ;Output 0 = exit without saving changes
+2 ; 1 = send alert and save
+3 WRITE !!,?25,"**WARNING!!**"
+4 WRITE !!,"The edits you are about to make, may potentially change the identity of"
+5 WRITE !,"this patient. Please verify that you have selected the correct patient"
+6 WRITE !,"and ensure that supporting documentation exists for these changes. If"
+7 WRITE !,"you continue with these edits, an alert will be generated and sent to"
+8 WRITE !,"your Supervisor and ADPAC, notifying them of the changes."
+9 NEW DIR,DGANS,Y
+10 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue and save your edits:"
+11 SET DIR("B")="NO"
DO ^DIR
KILL DIR
SET DGANS=Y
+12 ;0=don't save, 1=save with CE alert
SET DGANS=$SELECT(Y=1:1,1:0)
+13 QUIT DGANS
+14 ;
ALERT ;Queue alert
+1 XECUTE ^%ZOSF("UCI")
SET ZTUCI=Y
SET ZTRTN="ALERT^DGRPECE1"
SET ZTDTH=$HOROLOG
SET ZTIO=""
SET IEN=DFN
+2 FOR V="IEN","BEFORE(","BUFFER(","SAVE(","XQY"
SET ZTSAVE(V)=""
+3 SET ZTDESC="Patient Catastrophic Edits alert"
KILL V,ZTSK
NEW X
DO ^%ZTLOAD
QUIT
+4 ;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE)
+5 QUIT
