DGRPECE1 ;ALB/MRY - REGISTRATION CATASTROPHIC EDITS ALERT ; 11/17/04 9:30am
;;5.3;Registration;**638,831**;Aug 13, 1993;Build 10
;
ALERT ;setup alert, display
K XQA,XQAMSG,XQAROU,XQAARCH,XQAID,XQADATA
N DGSITE,DGDUZ,CNT,DGI
;XQA builds alert array. XMY builds mailgroup array (if needed).
S DGDUZ=0 F S DGDUZ=$O(^XUSEC("DG CATASTROPHIC EDIT",DGDUZ)) Q:'DGDUZ S XQA(DGDUZ)=""
I $O(XQA(""))="" D
. S DGDUZ=0 F S DGDUZ=$O(^XUSEC("DG SUPERVISOR",DGDUZ)) Q:'DGDUZ S XQA(DGDUZ)="",XMY(DGDUZ)=""
. S XMY("G.MPIF EXCEPTIONS")=""
. D MSG
I $O(XQA(""))="" Q ;hard to believe no supervisors.
S XQAMSG="POTENTIAL CATASTROPHIC EDIT OF PATIENT IDENTIFYING DATA"
;see below for XQADATA values
S CNT=0 F DGI="NAME","SSN","DOB","SEX","MAIDEN","POBCITY","POBSTATE" S CNT=CNT+1 I $D(BEFORE(DGI)) S $P(XQADATA,U,CNT)=BEFORE(DGI)
S CNT=7 F DGI="NAME","SSN","DOB","SEX" S CNT=CNT+1 I $D(BUFFER(DGI)) S $P(XQADATA,U,CNT)=BUFFER(DGI) I $D(SAVE(DGI)) S $P(XQADATA,U,CNT)=$P(XQADATA,U,CNT)_";*"
S $P(XQADATA,U,12)=IEN,DGSITE=$$SITE^VASITE(),DGSITE=$P(DGSITE,U,3)
S $P(XQADATA,U,13)=DGSITE,$P(XQADATA,U,14)=XQY ;XQY = users current option (pointer)
S XQAROU="DISP^DGRPECE1",XQAARCH=365
S XQAID="DG,"_IEN
D SETUP^XQALERT Q
;
DISP ;display catastrophic alert information
N DGNAME,DGIEN,DGDATA,Y,HDR,HDR1,HDR2,DGRFLG
K XQAKILL ; Keep alert, unless removed (XQAKILL=1 below)
S DGIEN=$O(^XTV(8992.1,"B",XQAID,""))
W @IOF ;W !!,$TR($J("",IOM)," ","=")
S HDR=" <POTENTIAL CATASTROPHIC EDIT OF PATIENT IDENTIFYING DATA> "
S HDR1=$TR($J("",(IOM/2-($L(HDR)/2)))," ","=")_HDR,HDR2=HDR1_$TR($J("",(IOM-$L(HDR1)))," ","=")
W !,HDR2 ;W !,?(IOM-$L(HDR)/2),HDR
S DGNAME=$P($P(XQADATA,U,8),";")
W !,"Patient: ",DGNAME_" (ICN:"_$$GETICN^MPIF001($P(XQADATA,U,12))_")",?60,"Station: ",$P(XQADATA,U,13)
W !,$TR($J("",IOM)," ","-")
W !,"Patient Identification fields (before edit)"
W !,$TR($J("",IOM)," ","-")
W !?1,"Name: ",$P(XQADATA,U),?45,"Soc. Security Number: ",$P(XQADATA,U,2)
W !?1,"Date of Birth: ",$$DATE4($P(XQADATA,U,3)),?45,"Gender: ",$S($P(XQADATA,U,4)="M":"MALE",$P(XQADATA,U,4)="F":"FEMALE",1:$P(XQADATA,U,4))
W !?1,"Mother's Maiden Name: ",$P(XQADATA,U,5)
W !?1,"Place of Birth [city]: ",$P(XQADATA,U,6)
W !?1,"Place of Birth [state]: " I $P(XQADATA,U,7) W $P(^DIC(5,$P(XQADATA,U,7),0),U)
W !,$TR($J("",IOM)," ","-")
W !,"Patient Identification fields (after edit)"
W !,$TR($J("",IOM)," ","-")
W ! W:$P($P(XQADATA,U,8),";",2)="*" "*" W ?1,"Name: ",$P($P(XQADATA,U,8),";") W ?44 W:$P($P(XQADATA,U,9),";",2)="*" "*" W ?45,"Soc. Security Number: ",$P($P(XQADATA,U,9),";")
W ! W:$P($P(XQADATA,U,10),";",2)="*" "*" W ?1,"Date of Birth: ",$$DATE4($P($P(XQADATA,U,10),";"))
W ?44 W:$P($P(XQADATA,U,11),";",2)="*" "*" W ?45,"Gender: ",$S($P($P(XQADATA,U,11),";")="M":"MALE",$P($P(XQADATA,U,11),";")="F":"FEMALE",1:"")
W !,$TR($J("",IOM)," ","-")
S DGDATA=$$GET1^DIQ(8992.1,+DGIEN_",",.02)
W !,"Edited by: ",$$GET1^DIQ(8992.1,+DGIEN_",",.05),?45,"Generated: ",$$FMTE^XLFDT(DGDATA,"2P")
S DGDATA=$P(XQADATA,U,14),DGDATA=$$GET1^DIQ(19,+DGDATA_",",.01) ;option name
W !,"With Option: ",DGDATA
;W !,$TR($J("",IOM)," ","-")
S DGDATA=$$GET1^DIQ(8992.1,+DGIEN_",",2)
W !,"Reviewed by: " W:$P(DGDATA,U,15) $P(^VA(200,$P(DGDATA,U,15),0),U)
W:$P(DGDATA,U,15) ?45,"Catastrophic Edit: ",$S($P(DGDATA,U,16)=1:"YES",1:"NO")
W !,$TR($J("",IOM)," ","-")
;CE reviewed?
S DGRFLG=0 ;Review flag determine delete prompting
I $P(DGDATA,U,15)="" D REVIEW S DGRFLG=1
;If CE reviewed, can the alert be removed?
I $P(DGDATA,U,15) D REMOVE
K XQAKILL
Q
;
REVIEW ;
N DGANS,DIR,DGCE
S DIR(0)="Y",DIR("A")="IS REVIEW COMPLETE"
S DIR("B")="NO" D ^DIR K DIR S DGANS=Y
I DGANS=1 D
. S DIR(0)="Y",DIR("A")="IS THIS ALERT DETERMINED TO BE A CATASTROPHIC EDIT"
. S DIR("B")="NO" D ^DIR K DIR S DGCE=Y
. N FDA
. S $P(DGDATA,U,15)=DUZ
. S $P(DGDATA,U,16)=DGCE
. S FDA(8992.1,+DGIEN_",",2)=DGDATA
. D FILE^DIE("","FDA","DIERR")
Q
REMOVE ;
N Y,DIR
S DIR(0)="Y"
S:DGRFLG=1 DIR("A")="DO YOU WANT TO DELETE ALERT"
S:DGRFLG=0 DIR("A")="THIS ALERT HAS BEEN REVIEWED, DO YOU WANT TO DELETE THE ALERT"
S DIR("B")="NO" D ^DIR K DIR
I Y=1 S XQAKILL=1 D DELETE^XQALERT ;keep renewed, unless reviewed
Q
MSG ;
K ^TMP($J,"DGRPECE")
S XMDUZ=.5,XMSUB="POTENTIAL CATASTROPHIC EDIT ALERT SETUP"
S ^TMP($J,"DGRPECE",1,0)="ATTENTION ADT SUPERVISORS:"
S ^TMP($J,"DGRPECE",2,0)=" "
S ^TMP($J,"DGRPECE",3,0)="You are receiving this message along with a potential catastrophic edit alert"
S ^TMP($J,"DGRPECE",4,0)="because there are no users holding the DG CATASTROPHIC EDIT key."
S ^TMP($J,"DGRPECE",5,0)=" "
S ^TMP($J,"DGRPECE",6,0)="Please see that an appropriate Supervisor and ADPAC are given this key."
S ^TMP($J,"DGRPECE",7,0)="Documentation on these catastrophic edits can be found in patch DG*5.3*638."
S ^TMP($J,"DGRPECE",8,0)=" "
S ^TMP($J,"DGRPECE",9,0)="This message has been forwarded to the National Data Quality mailgroup."
S ^TMP($J,"DGRPECE",10,0)="Station name: "_$P($$SITE^VASITE(),U,2)_" ("_$P($$SITE^VASITE(),U)_")"
S XMTEXT="^TMP("_$J_",""DGRPECE""," D ^XMD S DA=XMZ,DIE=3.9,DR="1.7///P;1.97///Y" D ^DIE
K ^TMP($J,"DGRPECE"),DIE,DA,DR,XMY,XMDUZ,XMSUB,XMTEXT,XMZ Q
DATE4(X) ;return date in DD/MM/YYYY format
I X'["/" D
.S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
Q X
;
XQADATA ;XQADATA =
;1=before snapshot name^ (31 chars = 30 chars+'^')
;2=before snapshot ssn^ (11)
;3=before snapshot dob^ ( 8)
;4=before snapshot sex^ ( 2)
;5=before snapshot mother's maiden name^ (18)
;6=before snapshot pob city^ (16)
;7=before snapshot pob state^ ( 3) a guess, its a pointer
;8=after snapshot name^ (31)
;9=after snapshot ssn^ (11)
;10=after snapshot dob^ ( 8)
;11=after snapshot sex^ ( 2)
;12=patient ien^ (11) a guess, its a pointer
;13=station#^ ( 6) a guess, its a pointer
;14=user menu pointer^ ( 5) a guess, its a pointer
;15=reviewer duz^ (11) a guess, its a pointer
;16=CE edit (y/n) ( 2)
; total = 176 chars.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPECE1 6403 printed Dec 13, 2024@02:56:19 Page 2
DGRPECE1 ;ALB/MRY - REGISTRATION CATASTROPHIC EDITS ALERT ; 11/17/04 9:30am
+1 ;;5.3;Registration;**638,831**;Aug 13, 1993;Build 10
+2 ;
ALERT ;setup alert, display
+1 KILL XQA,XQAMSG,XQAROU,XQAARCH,XQAID,XQADATA
+2 NEW DGSITE,DGDUZ,CNT,DGI
+3 ;XQA builds alert array. XMY builds mailgroup array (if needed).
+4 SET DGDUZ=0
FOR
SET DGDUZ=$ORDER(^XUSEC("DG CATASTROPHIC EDIT",DGDUZ))
if 'DGDUZ
QUIT
SET XQA(DGDUZ)=""
+5 IF $ORDER(XQA(""))=""
Begin DoDot:1
+6 SET DGDUZ=0
FOR
SET DGDUZ=$ORDER(^XUSEC("DG SUPERVISOR",DGDUZ))
if 'DGDUZ
QUIT
SET XQA(DGDUZ)=""
SET XMY(DGDUZ)=""
+7 SET XMY("G.MPIF EXCEPTIONS")=""
+8 DO MSG
End DoDot:1
+9 ;hard to believe no supervisors.
IF $ORDER(XQA(""))=""
QUIT
+10 SET XQAMSG="POTENTIAL CATASTROPHIC EDIT OF PATIENT IDENTIFYING DATA"
+11 ;see below for XQADATA values
+12 SET CNT=0
FOR DGI="NAME","SSN","DOB","SEX","MAIDEN","POBCITY","POBSTATE"
SET CNT=CNT+1
IF $DATA(BEFORE(DGI))
SET $PIECE(XQADATA,U,CNT)=BEFORE(DGI)
+13 SET CNT=7
FOR DGI="NAME","SSN","DOB","SEX"
SET CNT=CNT+1
IF $DATA(BUFFER(DGI))
SET $PIECE(XQADATA,U,CNT)=BUFFER(DGI)
IF $DATA(SAVE(DGI))
SET $PIECE(XQADATA,U,CNT)=$PIECE(XQADATA,U,CNT)_";*"
+14 SET $PIECE(XQADATA,U,12)=IEN
SET DGSITE=$$SITE^VASITE()
SET DGSITE=$PIECE(DGSITE,U,3)
+15 ;XQY = users current option (pointer)
SET $PIECE(XQADATA,U,13)=DGSITE
SET $PIECE(XQADATA,U,14)=XQY
+16 SET XQAROU="DISP^DGRPECE1"
SET XQAARCH=365
+17 SET XQAID="DG,"_IEN
+18 DO SETUP^XQALERT
QUIT
+19 ;
DISP ;display catastrophic alert information
+1 NEW DGNAME,DGIEN,DGDATA,Y,HDR,HDR1,HDR2,DGRFLG
+2 ; Keep alert, unless removed (XQAKILL=1 below)
KILL XQAKILL
+3 SET DGIEN=$ORDER(^XTV(8992.1,"B",XQAID,""))
+4 ;W !!,$TR($J("",IOM)," ","=")
WRITE @IOF
+5 SET HDR=" <POTENTIAL CATASTROPHIC EDIT OF PATIENT IDENTIFYING DATA> "
+6 SET HDR1=$TRANSLATE($JUSTIFY("",(IOM/2-($LENGTH(HDR)/2)))," ","=")_HDR
SET HDR2=HDR1_$TRANSLATE($JUSTIFY("",(IOM-$LENGTH(HDR1)))," ","=")
+7 ;W !,?(IOM-$L(HDR)/2),HDR
WRITE !,HDR2
+8 SET DGNAME=$PIECE($PIECE(XQADATA,U,8),";")
+9 WRITE !,"Patient: ",DGNAME_" (ICN:"_$$GETICN^MPIF001($PIECE(XQADATA,U,12))_")",?60,"Station: ",$PIECE(XQADATA,U,13)
+10 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+11 WRITE !,"Patient Identification fields (before edit)"
+12 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+13 WRITE !?1,"Name: ",$PIECE(XQADATA,U),?45,"Soc. Security Number: ",$PIECE(XQADATA,U,2)
+14 WRITE !?1,"Date of Birth: ",$$DATE4($PIECE(XQADATA,U,3)),?45,"Gender: ",$SELECT($PIECE(XQADATA,U,4)="M":"MALE",$PIECE(XQADATA,U,4)="F":"FEMALE",1:$PIECE(XQADATA,U,4))
+15 WRITE !?1,"Mother's Maiden Name: ",$PIECE(XQADATA,U,5)
+16 WRITE !?1,"Place of Birth [city]: ",$PIECE(XQADATA,U,6)
+17 WRITE !?1,"Place of Birth [state]: "
IF $PIECE(XQADATA,U,7)
WRITE $PIECE(^DIC(5,$PIECE(XQADATA,U,7),0),U)
+18 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+19 WRITE !,"Patient Identification fields (after edit)"
+20 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+21 WRITE !
if $PIECE($PIECE(XQADATA,U,8),";",2)="*"
WRITE "*"
WRITE ?1,"Name: ",$PIECE($PIECE(XQADATA,U,8),";")
WRITE ?44
if $PIECE($PIECE(XQADATA,U,9),";",2)="*"
WRITE "*"
WRITE ?45,"Soc. Security Number: ",$PIECE($PIECE(XQADATA,U,9),";")
+22 WRITE !
if $PIECE($PIECE(XQADATA,U,10),";",2)="*"
WRITE "*"
WRITE ?1,"Date of Birth: ",$$DATE4($PIECE($PIECE(XQADATA,U,10),";"))
+23 WRITE ?44
if $PIECE($PIECE(XQADATA,U,11),";",2)="*"
WRITE "*"
WRITE ?45,"Gender: ",$SELECT($PIECE($PIECE(XQADATA,U,11),";")="M":"MALE",$PIECE($PIECE(XQADATA,U,11),";")="F":"FEMALE",1:"")
+24 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+25 SET DGDATA=$$GET1^DIQ(8992.1,+DGIEN_",",.02)
+26 WRITE !,"Edited by: ",$$GET1^DIQ(8992.1,+DGIEN_",",.05),?45,"Generated: ",$$FMTE^XLFDT(DGDATA,"2P")
+27 ;option name
SET DGDATA=$PIECE(XQADATA,U,14)
SET DGDATA=$$GET1^DIQ(19,+DGDATA_",",.01)
+28 WRITE !,"With Option: ",DGDATA
+29 ;W !,$TR($J("",IOM)," ","-")
+30 SET DGDATA=$$GET1^DIQ(8992.1,+DGIEN_",",2)
+31 WRITE !,"Reviewed by: "
if $PIECE(DGDATA,U,15)
WRITE $PIECE(^VA(200,$PIECE(DGDATA,U,15),0),U)
+32 if $PIECE(DGDATA,U,15)
WRITE ?45,"Catastrophic Edit: ",$SELECT($PIECE(DGDATA,U,16)=1:"YES",1:"NO")
+33 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+34 ;CE reviewed?
+35 ;Review flag determine delete prompting
SET DGRFLG=0
+36 IF $PIECE(DGDATA,U,15)=""
DO REVIEW
SET DGRFLG=1
+37 ;If CE reviewed, can the alert be removed?
+38 IF $PIECE(DGDATA,U,15)
DO REMOVE
+39 KILL XQAKILL
+40 QUIT
+41 ;
REVIEW ;
+1 NEW DGANS,DIR,DGCE
+2 SET DIR(0)="Y"
SET DIR("A")="IS REVIEW COMPLETE"
+3 SET DIR("B")="NO"
DO ^DIR
KILL DIR
SET DGANS=Y
+4 IF DGANS=1
Begin DoDot:1
+5 SET DIR(0)="Y"
SET DIR("A")="IS THIS ALERT DETERMINED TO BE A CATASTROPHIC EDIT"
+6 SET DIR("B")="NO"
DO ^DIR
KILL DIR
SET DGCE=Y
+7 NEW FDA
+8 SET $PIECE(DGDATA,U,15)=DUZ
+9 SET $PIECE(DGDATA,U,16)=DGCE
+10 SET FDA(8992.1,+DGIEN_",",2)=DGDATA
+11 DO FILE^DIE("","FDA","DIERR")
End DoDot:1
+12 QUIT
REMOVE ;
+1 NEW Y,DIR
+2 SET DIR(0)="Y"
+3 if DGRFLG=1
SET DIR("A")="DO YOU WANT TO DELETE ALERT"
+4 if DGRFLG=0
SET DIR("A")="THIS ALERT HAS BEEN REVIEWED, DO YOU WANT TO DELETE THE ALERT"
+5 SET DIR("B")="NO"
DO ^DIR
KILL DIR
+6 ;keep renewed, unless reviewed
IF Y=1
SET XQAKILL=1
DO DELETE^XQALERT
+7 QUIT
MSG ;
+1 KILL ^TMP($JOB,"DGRPECE")
+2 SET XMDUZ=.5
SET XMSUB="POTENTIAL CATASTROPHIC EDIT ALERT SETUP"
+3 SET ^TMP($JOB,"DGRPECE",1,0)="ATTENTION ADT SUPERVISORS:"
+4 SET ^TMP($JOB,"DGRPECE",2,0)=" "
+5 SET ^TMP($JOB,"DGRPECE",3,0)="You are receiving this message along with a potential catastrophic edit alert"
+6 SET ^TMP($JOB,"DGRPECE",4,0)="because there are no users holding the DG CATASTROPHIC EDIT key."
+7 SET ^TMP($JOB,"DGRPECE",5,0)=" "
+8 SET ^TMP($JOB,"DGRPECE",6,0)="Please see that an appropriate Supervisor and ADPAC are given this key."
+9 SET ^TMP($JOB,"DGRPECE",7,0)="Documentation on these catastrophic edits can be found in patch DG*5.3*638."
+10 SET ^TMP($JOB,"DGRPECE",8,0)=" "
+11 SET ^TMP($JOB,"DGRPECE",9,0)="This message has been forwarded to the National Data Quality mailgroup."
+12 SET ^TMP($JOB,"DGRPECE",10,0)="Station name: "_$PIECE($$SITE^VASITE(),U,2)_" ("_$PIECE($$SITE^VASITE(),U)_")"
+13 SET XMTEXT="^TMP("_$JOB_",""DGRPECE"","
DO ^XMD
SET DA=XMZ
SET DIE=3.9
SET DR="1.7///P;1.97///Y"
DO ^DIE
+14 KILL ^TMP($JOB,"DGRPECE"),DIE,DA,DR,XMY,XMDUZ,XMSUB,XMTEXT,XMZ
QUIT
DATE4(X) ;return date in DD/MM/YYYY format
+1 IF X'["/"
Begin DoDot:1
+2 if X
SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
End DoDot:1
+3 QUIT X
+4 ;
XQADATA ;XQADATA =
+1 ;1=before snapshot name^ (31 chars = 30 chars+'^')
+2 ;2=before snapshot ssn^ (11)
+3 ;3=before snapshot dob^ ( 8)
+4 ;4=before snapshot sex^ ( 2)
+5 ;5=before snapshot mother's maiden name^ (18)
+6 ;6=before snapshot pob city^ (16)
+7 ;7=before snapshot pob state^ ( 3) a guess, its a pointer
+8 ;8=after snapshot name^ (31)
+9 ;9=after snapshot ssn^ (11)
+10 ;10=after snapshot dob^ ( 8)
+11 ;11=after snapshot sex^ ( 2)
+12 ;12=patient ien^ (11) a guess, its a pointer
+13 ;13=station#^ ( 6) a guess, its a pointer
+14 ;14=user menu pointer^ ( 5) a guess, its a pointer
+15 ;15=reviewer duz^ (11) a guess, its a pointer
+16 ;16=CE edit (y/n) ( 2)
+17 ; total = 176 chars.
