QANDELE ;HISC/GJC-Auto E-Mail for locally deleted cases ; 5/30/12 2:05pm
;;2.0;Incident Reporting;**1,18,20,33**;08/07/1992;Build 12
;
S QANZERO=$S($D(^QA(740,1,0))#2:^(0),1:0) I +QANZERO'>0 S QANERROR=1 D ERROR G EXIT
S QANSITE=$S($D(^DIC(4,+QANZERO,0))#2:$P(^(0),"^"),1:"") I QANSITE="" S QANERROR=2 D ERROR G EXIT
S QANSTNO=$S($D(^DIC(4,+QANZERO,99))#2:$P(^(99),"^"),1:"") I QANSTNO="" S QANERROR=3 D ERROR G EXIT
S QANSERV=$P(QANZERO,"^",4) I QANSERV="" S QANERROR=4 D ERROR G EXIT
S QANDOM=$P(QANZERO,"^",5) I QANDOM="" S QANERROR=5 D ERROR G EXIT
S QA=+$O(^DIC(4.2,"B",QANDOM,0)) I $S('$D(^DIC(4.2,QA,0))#2:1,$P(^(0),"^")'=QANDOM:1,1:0) S QANERROR=6 D ERROR G EXIT
S QANQAN=$S($D(^QA(740,1,"QAN")):^("QAN"),1:"") I +QANQAN'>0 S QANERROR=7 D ERROR G EXIT
S QANMLGP=+$P(QANQAN,U),QANMLGP(0)=$S($D(^XMB(3.8,QANMLGP,0))#2:$P(^(0),U),1:"") I QANMLGP(0)']"" S QANERROR=7 D ERROR G EXIT
D INC D:$D(^UTILITY($J,"QAN MAIL")) BULL
EXIT ;Kill and quit
K ^UTILITY($J),DA,DIE,DR,ERROR,QA,QAN0,QAN1,QAN742,QAN7424,QANCASE
K QANDATE,QANDESC,QANDOM,QANERROR,QANINCD,QANINCR,QANMLGP,QANNCDNT
K QANOK,QANPAT,QANPROV,QANQAN,QANQUIT,QANSERV,QANSITE,QANSLEV,QANSRVCE
K QANDOB,QANSTNO,QANTYDTH,QANZERO,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
Q
BULL ;Mail message
D KILL^XM
S XMY(QANSERV_"@"_QANDOM)="",XMDUZ=.5
S XMSUB="QAN Incident Event: "_^DD("SITE")_" ("_^DD("SITE",1)_")"
S XMTEXT="^UTILITY($J,""QAN MAIL""," D ^XMD,KILL^XM
Q
ERROR ;Error messages
W *7,!!,"*** ",$P($T(ERR+QANERROR),";;",2)," ***",!!,*7
Q
INC ;Choose the incident, check 'ACS' x-ref for deleted.
S QANINCR=0
F QAN0=0:0 S QAN0=$O(^QA(742.4,"ACS",2,QAN0)) Q:QAN0'>0 S (QANDESC,QANQUIT)=0 D INC1
Q
INC1 ;If 'DELETED' and not xmitted, continue
S QAN7424=$G(^QA(742.4,QAN0,0)) Q:QAN7424']""
Q:+$P(QAN7424,U,18)'=0 ;Been xmitted
S QANDATE=$P(QAN7424,U,3),QANCASE=$P(QAN7424,U),QANNCDNT=+$P(QAN7424,U,2)
Q:QANNCDNT'>0 ;check for null incident
S QANINCD=$S($D(^QA(742.1,QANNCDNT,0)):$P(^(0),U),1:"") Q:QANINCD']""
S QANINCD=$TR(QANINCD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S QANTYDTH=$S(QANINCD="DEATH":$P(QAN7424,U,14),1:""),QANPROV=$P(QAN7424,U,16)
;/*** Grab patient data ***/
F QAN1=0:0 S QAN1=$O(^QA(742,"BCS",QAN0,QAN1)) Q:QAN1'>0 S QAN742=$G(^QA(742,QAN1,0)) S:QAN742]"" QANOK=0 D:QAN742]"" PAT
I QANQUIT K DA,DIE,DR S DIE="^QA(742.4,",DA=QAN0,DR=".17///^S X=2" D ^DIE K DA,DIE,DR
I QANQUIT K DA,DIE,DR S DIE="^QA(742.4,",DA=QAN0,DR=".21///^S X=1" D ^DIE K DA,DIE,DR
Q
INCK ;Check status of incident
I QANINCD="HOMICIDE" S QANOK=1
I QANINCD="DEATH" D
. S QANTYDTH=+$G(QANTYDTH)
. I '$D(^QA(742.14,"BUPPER","OTHER",QANTYDTH)),('$D(^QA(742.14,"BUPPER","WITHIN 24 HOURS OF ADMISSION (EX. DOA'S AND TERMINALS)",QANTYDTH))) S QANOK=1
I QANINCD="SUICIDE" S QANOK=1
I QANINCD="SEXUAL ASSAULT" S QANOK=1
I QANINCD="SUICIDE ATTEMPT" S QANOK=1
I QANINCD="INFORMED CONSENT-FAIL. TO OBTAIN" S QANOK=1
I QANINCD="PATIENT ABUSE" S QANOK=1
I QANINCD="INJURY NOT OTHERWISE LISTED",(QANSLEV'<2) S QANOK=1
I QANINCD="ASSAULT-PATIENT TO PATIENT",(QANSLEV'<2) S QANOK=1
I QANINCD="FIRE-PATIENT INVOLVED IN",(QANSLEV'<2) S QANOK=1
I QANINCD="ASSAULT-PATIENT/STAFF",(QANSLEV'<2) S QANOK=1
I QANINCD="FALL",(QANSLEV'<2) S QANOK=1
I QANINCD="MEDICATION ERROR",(QANSLEV'<2) S QANOK=1
I QANINCD="TRANSFUSION ERROR",(QANSLEV'<2) S QANOK=1
I QANINCD="MISSING PATIENT",(QANSLEV'<2) S QANOK=1
Q
PAT ;Patient data
Q:$P(QAN742,U,12)'<0 ;Checks for deleted patients.
S (QANSRVCE,Y)=$P(QAN742,U,8),C=$P(^DD(742,.08,0),U,2) D:Y]"" Y^DIQ S QANSRVCE=Y
S QANSLEV=+$P(QAN742,U,10) D INCK Q:'QANOK
S QANQUIT=1,QANINCR=QANINCR+1
S QANPAT=$P(QAN742,U),^UTILITY($J,"QAN PAT",QAN1)=$P(^DPT(QANPAT,0),U)
S ^UTILITY($J,"QAN SSN",QAN1)=$P(^DPT(QANPAT,0),U,9)
S QANDOB=$P(^DPT(QANPAT,0),U,3)
S ^UTILITY($J,"QAN MAIL",QANINCR)="DELETE^"_QANCASE_"^INCD^"_QANINCD_"^"_QANDATE_"^^^^"_QANMLGP(0)_"^^^"_$G(QANPROV)_"^"
S QANINCR=QANINCR+1
S ^UTILITY($J,"QAN MAIL",QANINCR)="DELETE^"_QANCASE_"^PAT^"_$G(^UTILITY($J,"QAN PAT",QAN1))_"^"_$G(^UTILITY($J,"QAN SSN",QAN1))_"^"_QANSLEV_"^"_QANTYDTH_"^"_QANSRVCE_"^^"_QANDOB_"^"
Q
ERR ;;ERROR MESSAGES: REASONS EWS BULLETIN COULD NOT BE SENT
;;SITE NOT FOUND IN QA SITE PARAMETERS FILE
;;SITE NOT FOUND IN INSTITUTION FILE
;;SITE NUMBER NOT FOUND IN INSTITUTION FILE
;;NQADB MAIL GROUP/SERVER NOT FOUND IN QA SITE PARAMETERS FILE
;;NQADB DOMAIN NOT FOUND IN QA SITE PARAMETERS FILE
;;NQADB DOMAIN NOT FOUND IN DOMAIN FILE
;;QA INCIDENT MAILGROUP NOT FOUND IN QA SITE PARAMETERS FILE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANDELE 4597 printed Oct 16, 2024@18:00:31 Page 2
QANDELE ;HISC/GJC-Auto E-Mail for locally deleted cases ; 5/30/12 2:05pm
+1 ;;2.0;Incident Reporting;**1,18,20,33**;08/07/1992;Build 12
+2 ;
+3 SET QANZERO=$SELECT($DATA(^QA(740,1,0))#2:^(0),1:0)
IF +QANZERO'>0
SET QANERROR=1
DO ERROR
GOTO EXIT
+4 SET QANSITE=$SELECT($DATA(^DIC(4,+QANZERO,0))#2:$PIECE(^(0),"^"),1:"")
IF QANSITE=""
SET QANERROR=2
DO ERROR
GOTO EXIT
+5 SET QANSTNO=$SELECT($DATA(^DIC(4,+QANZERO,99))#2:$PIECE(^(99),"^"),1:"")
IF QANSTNO=""
SET QANERROR=3
DO ERROR
GOTO EXIT
+6 SET QANSERV=$PIECE(QANZERO,"^",4)
IF QANSERV=""
SET QANERROR=4
DO ERROR
GOTO EXIT
+7 SET QANDOM=$PIECE(QANZERO,"^",5)
IF QANDOM=""
SET QANERROR=5
DO ERROR
GOTO EXIT
+8 SET QA=+$ORDER(^DIC(4.2,"B",QANDOM,0))
IF $SELECT('$DATA(^DIC(4.2,QA,0))#2:1,$PIECE(^(0),"^")'=QANDOM:1,1:0)
SET QANERROR=6
DO ERROR
GOTO EXIT
+9 SET QANQAN=$SELECT($DATA(^QA(740,1,"QAN")):^("QAN"),1:"")
IF +QANQAN'>0
SET QANERROR=7
DO ERROR
GOTO EXIT
+10 SET QANMLGP=+$PIECE(QANQAN,U)
SET QANMLGP(0)=$SELECT($DATA(^XMB(3.8,QANMLGP,0))#2:$PIECE(^(0),U),1:"")
IF QANMLGP(0)']""
SET QANERROR=7
DO ERROR
GOTO EXIT
+11 DO INC
if $DATA(^UTILITY($JOB,"QAN MAIL"))
DO BULL
EXIT ;Kill and quit
+1 KILL ^UTILITY($JOB),DA,DIE,DR,ERROR,QA,QAN0,QAN1,QAN742,QAN7424,QANCASE
+2 KILL QANDATE,QANDESC,QANDOM,QANERROR,QANINCD,QANINCR,QANMLGP,QANNCDNT
+3 KILL QANOK,QANPAT,QANPROV,QANQAN,QANQUIT,QANSERV,QANSITE,QANSLEV,QANSRVCE
+4 KILL QANDOB,QANSTNO,QANTYDTH,QANZERO,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
+5 QUIT
BULL ;Mail message
+1 DO KILL^XM
+2 SET XMY(QANSERV_"@"_QANDOM)=""
SET XMDUZ=.5
+3 SET XMSUB="QAN Incident Event: "_^DD("SITE")_" ("_^DD("SITE",1)_")"
+4 SET XMTEXT="^UTILITY($J,""QAN MAIL"","
DO ^XMD
DO KILL^XM
+5 QUIT
ERROR ;Error messages
+1 WRITE *7,!!,"*** ",$PIECE($TEXT(ERR+QANERROR),";;",2)," ***",!!,*7
+2 QUIT
INC ;Choose the incident, check 'ACS' x-ref for deleted.
+1 SET QANINCR=0
+2 FOR QAN0=0:0
SET QAN0=$ORDER(^QA(742.4,"ACS",2,QAN0))
if QAN0'>0
QUIT
SET (QANDESC,QANQUIT)=0
DO INC1
+3 QUIT
INC1 ;If 'DELETED' and not xmitted, continue
+1 SET QAN7424=$GET(^QA(742.4,QAN0,0))
if QAN7424']""
QUIT
+2 ;Been xmitted
if +$PIECE(QAN7424,U,18)'=0
QUIT
+3 SET QANDATE=$PIECE(QAN7424,U,3)
SET QANCASE=$PIECE(QAN7424,U)
SET QANNCDNT=+$PIECE(QAN7424,U,2)
+4 ;check for null incident
if QANNCDNT'>0
QUIT
+5 SET QANINCD=$SELECT($DATA(^QA(742.1,QANNCDNT,0)):$PIECE(^(0),U),1:"")
if QANINCD']""
QUIT
+6 SET QANINCD=$TRANSLATE(QANINCD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+7 SET QANTYDTH=$SELECT(QANINCD="DEATH":$PIECE(QAN7424,U,14),1:"")
SET QANPROV=$PIECE(QAN7424,U,16)
+8 ;/*** Grab patient data ***/
+9 FOR QAN1=0:0
SET QAN1=$ORDER(^QA(742,"BCS",QAN0,QAN1))
if QAN1'>0
QUIT
SET QAN742=$GET(^QA(742,QAN1,0))
if QAN742]""
SET QANOK=0
if QAN742]""
DO PAT
+10 IF QANQUIT
KILL DA,DIE,DR
SET DIE="^QA(742.4,"
SET DA=QAN0
SET DR=".17///^S X=2"
DO ^DIE
KILL DA,DIE,DR
+11 IF QANQUIT
KILL DA,DIE,DR
SET DIE="^QA(742.4,"
SET DA=QAN0
SET DR=".21///^S X=1"
DO ^DIE
KILL DA,DIE,DR
+12 QUIT
INCK ;Check status of incident
+1 IF QANINCD="HOMICIDE"
SET QANOK=1
+2 IF QANINCD="DEATH"
Begin DoDot:1
+3 SET QANTYDTH=+$GET(QANTYDTH)
+4 IF '$DATA(^QA(742.14,"BUPPER","OTHER",QANTYDTH))
IF ('$DATA(^QA(742.14,"BUPPER","WITHIN 24 HOURS OF ADMISSION (EX. DOA'S AND TERMINALS)",QANTYDTH)))
SET QANOK=1
End DoDot:1
+5 IF QANINCD="SUICIDE"
SET QANOK=1
+6 IF QANINCD="SEXUAL ASSAULT"
SET QANOK=1
+7 IF QANINCD="SUICIDE ATTEMPT"
SET QANOK=1
+8 IF QANINCD="INFORMED CONSENT-FAIL. TO OBTAIN"
SET QANOK=1
+9 IF QANINCD="PATIENT ABUSE"
SET QANOK=1
+10 IF QANINCD="INJURY NOT OTHERWISE LISTED"
IF (QANSLEV'<2)
SET QANOK=1
+11 IF QANINCD="ASSAULT-PATIENT TO PATIENT"
IF (QANSLEV'<2)
SET QANOK=1
+12 IF QANINCD="FIRE-PATIENT INVOLVED IN"
IF (QANSLEV'<2)
SET QANOK=1
+13 IF QANINCD="ASSAULT-PATIENT/STAFF"
IF (QANSLEV'<2)
SET QANOK=1
+14 IF QANINCD="FALL"
IF (QANSLEV'<2)
SET QANOK=1
+15 IF QANINCD="MEDICATION ERROR"
IF (QANSLEV'<2)
SET QANOK=1
+16 IF QANINCD="TRANSFUSION ERROR"
IF (QANSLEV'<2)
SET QANOK=1
+17 IF QANINCD="MISSING PATIENT"
IF (QANSLEV'<2)
SET QANOK=1
+18 QUIT
PAT ;Patient data
+1 ;Checks for deleted patients.
if $PIECE(QAN742,U,12)'<0
QUIT
+2 SET (QANSRVCE,Y)=$PIECE(QAN742,U,8)
SET C=$PIECE(^DD(742,.08,0),U,2)
if Y]""
DO Y^DIQ
SET QANSRVCE=Y
+3 SET QANSLEV=+$PIECE(QAN742,U,10)
DO INCK
if 'QANOK
QUIT
+4 SET QANQUIT=1
SET QANINCR=QANINCR+1
+5 SET QANPAT=$PIECE(QAN742,U)
SET ^UTILITY($JOB,"QAN PAT",QAN1)=$PIECE(^DPT(QANPAT,0),U)
+6 SET ^UTILITY($JOB,"QAN SSN",QAN1)=$PIECE(^DPT(QANPAT,0),U,9)
+7 SET QANDOB=$PIECE(^DPT(QANPAT,0),U,3)
+8 SET ^UTILITY($JOB,"QAN MAIL",QANINCR)="DELETE^"_QANCASE_"^INCD^"_QANINCD_"^"_QANDATE_"^^^^"_QANMLGP(0)_"^^^"_$GET(QANPROV)_"^"
+9 SET QANINCR=QANINCR+1
+10 SET ^UTILITY($JOB,"QAN MAIL",QANINCR)="DELETE^"_QANCASE_"^PAT^"_$GET(^UTILITY($JOB,"QAN PAT",QAN1))_"^"_$GET(^UTILITY($JOB,"QAN SSN",QAN1))_"^"_QANSLEV_"^"_QANTYDTH_"^"_QANSRVCE_"^^"_QANDOB_"^"
+11 QUIT
ERR ;;ERROR MESSAGES: REASONS EWS BULLETIN COULD NOT BE SENT
+1 ;;SITE NOT FOUND IN QA SITE PARAMETERS FILE
+2 ;;SITE NOT FOUND IN INSTITUTION FILE
+3 ;;SITE NUMBER NOT FOUND IN INSTITUTION FILE
+4 ;;NQADB MAIL GROUP/SERVER NOT FOUND IN QA SITE PARAMETERS FILE
+5 ;;NQADB DOMAIN NOT FOUND IN QA SITE PARAMETERS FILE
+6 ;;NQADB DOMAIN NOT FOUND IN DOMAIN FILE
+7 ;;QA INCIDENT MAILGROUP NOT FOUND IN QA SITE PARAMETERS FILE
