QANFULL ;HISC/GJC-Auto E-Mail for locally closed cases. ; 5/30/12 2:06pm
;;2.0;Incident Reporting;**1,13,18,20,33**;08/07/1992;Build 12
;
;DON'T FORGET QAQDATE FOR AD HOC REPORTS!
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^QANFULL0
EXIT ;Kill and quit
K ^UTILITY($J),C,DA,DFN,DIE,DIWF,DIWL,DIWR,DR,ERROR,QA,QAN0,QAN1,QAN742
K QAN7424,QANCASE,QANDATE,QANDESC,QANDOM,QANERROR,QANINCD,QANINCR
K QANLOOP,QANLRCP,QANLRIN,QANLVL,QANMLGP,QANNCDNT,QANOK,QANPAT
K QANPROV,QANQAN,QANQUIT,QANRSRV,QANSERV,QANSITE,QANSLEV,QANSRVCE
K QANSTNO,QANADMIT,QANDOB,QANINLOC,QANTYDTH,QANY,QANZERO,VA1026,VAIN
K VAINDT,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
Q
DESC ;Description
S DIWF="",DIWL=20,DIWR=60,QANDESC=1 K ^UTILITY($J,"W")
F QANLOOP=0:0 S QANLOOP=$O(^QA(742.4,QAN0,1,QANLOOP)) Q:QANLOOP'>0 S X=$P(^QA(742.4,QAN0,1,QANLOOP,0),U) D ^DIWP
Q
ERROR ;Errors
W *7,!!,"*** ",$P($T(ERR+QANERROR),";;",2)," ***",!!,*7
Q
INC ;Incident data, for closed incidents.
S QANINCR=0
F QAN0=0:0 S QAN0=$O(^QA(742.4,"ACS",0,QAN0)) Q:QAN0'>0 S (QANDESC,QANQUIT)=0 D INC1
Q
INC1 ;Incident data
S QAN7424=$G(^QA(742.4,QAN0,0)) Q:QAN7424']""
Q:+$P(QAN7424,U,18)'=0 ;has been xmitted
K ^UTILITY($J,"W") ;Clean up for description
S QANDATE=$P(QAN7424,U,3),QANCASE=$P(QAN7424,U)
S QANNCDNT=+$P(QAN7424,U,2),QANINLOC=$P(QAN7424,U,4)
Q:QANNCDNT'>0 ;check for null incident
S:QANINLOC]"" QANINLOC=$P($G(^QA(742.5,QANINLOC,0)),U)
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)
S VA1026=$P(QAN7424,U,9),QANLVL=$P(QAN7424,U,11),QANLRIN=$P(QAN7424,U,12)
S QANLRCP=$P(QAN7424,U,13)
D:$D(^QA(742.4,QAN0,1,0)) DESC
D EN1^QANFULL0 ;Grab patient data, build mail message
I QANQUIT K DA,DIE,DR S DIE="^QA(742.4,",DA=QAN0,DR=".17///^S X=4" 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
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[HQANFULL 3227 printed Apr 09, 2024@21:02:01 Page 2
QANFULL ;HISC/GJC-Auto E-Mail for locally closed cases. ; 5/30/12 2:06pm
+1 ;;2.0;Incident Reporting;**1,13,18,20,33**;08/07/1992;Build 12
+2 ;
+3 ;DON'T FORGET QAQDATE FOR AD HOC REPORTS!
+4 SET QANZERO=$SELECT($DATA(^QA(740,1,0))#2:^(0),1:0)
IF +QANZERO'>0
SET QANERROR=1
DO ERROR
GOTO EXIT
+5 SET QANSITE=$SELECT($DATA(^DIC(4,+QANZERO,0))#2:$PIECE(^(0),"^"),1:"")
IF QANSITE=""
SET QANERROR=2
DO ERROR
GOTO EXIT
+6 SET QANSTNO=$SELECT($DATA(^DIC(4,+QANZERO,99))#2:$PIECE(^(99),"^"),1:"")
IF QANSTNO=""
SET QANERROR=3
DO ERROR
GOTO EXIT
+7 SET QANSERV=$PIECE(QANZERO,"^",4)
IF QANSERV=""
SET QANERROR=4
DO ERROR
GOTO EXIT
+8 SET QANDOM=$PIECE(QANZERO,"^",5)
IF QANDOM=""
SET QANERROR=5
DO ERROR
GOTO EXIT
+9 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
+10 SET QANQAN=$SELECT($DATA(^QA(740,1,"QAN")):^("QAN"),1:"")
IF +QANQAN'>0
SET QANERROR=7
DO ERROR
GOTO EXIT
+11 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
+12 DO INC
if $DATA(^UTILITY($JOB,"QAN MAIL"))
DO BULL^QANFULL0
EXIT ;Kill and quit
+1 KILL ^UTILITY($JOB),C,DA,DFN,DIE,DIWF,DIWL,DIWR,DR,ERROR,QA,QAN0,QAN1,QAN742
+2 KILL QAN7424,QANCASE,QANDATE,QANDESC,QANDOM,QANERROR,QANINCD,QANINCR
+3 KILL QANLOOP,QANLRCP,QANLRIN,QANLVL,QANMLGP,QANNCDNT,QANOK,QANPAT
+4 KILL QANPROV,QANQAN,QANQUIT,QANRSRV,QANSERV,QANSITE,QANSLEV,QANSRVCE
+5 KILL QANSTNO,QANADMIT,QANDOB,QANINLOC,QANTYDTH,QANY,QANZERO,VA1026,VAIN
+6 KILL VAINDT,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
+7 QUIT
DESC ;Description
+1 SET DIWF=""
SET DIWL=20
SET DIWR=60
SET QANDESC=1
KILL ^UTILITY($JOB,"W")
+2 FOR QANLOOP=0:0
SET QANLOOP=$ORDER(^QA(742.4,QAN0,1,QANLOOP))
if QANLOOP'>0
QUIT
SET X=$PIECE(^QA(742.4,QAN0,1,QANLOOP,0),U)
DO ^DIWP
+3 QUIT
ERROR ;Errors
+1 WRITE *7,!!,"*** ",$PIECE($TEXT(ERR+QANERROR),";;",2)," ***",!!,*7
+2 QUIT
INC ;Incident data, for closed incidents.
+1 SET QANINCR=0
+2 FOR QAN0=0:0
SET QAN0=$ORDER(^QA(742.4,"ACS",0,QAN0))
if QAN0'>0
QUIT
SET (QANDESC,QANQUIT)=0
DO INC1
+3 QUIT
INC1 ;Incident data
+1 SET QAN7424=$GET(^QA(742.4,QAN0,0))
if QAN7424']""
QUIT
+2 ;has been xmitted
if +$PIECE(QAN7424,U,18)'=0
QUIT
+3 ;Clean up for description
KILL ^UTILITY($JOB,"W")
+4 SET QANDATE=$PIECE(QAN7424,U,3)
SET QANCASE=$PIECE(QAN7424,U)
+5 SET QANNCDNT=+$PIECE(QAN7424,U,2)
SET QANINLOC=$PIECE(QAN7424,U,4)
+6 ;check for null incident
if QANNCDNT'>0
QUIT
+7 if QANINLOC]""
SET QANINLOC=$PIECE($GET(^QA(742.5,QANINLOC,0)),U)
+8 SET QANINCD=$SELECT($DATA(^QA(742.1,QANNCDNT,0)):$PIECE(^(0),U),1:"")
if QANINCD']""
QUIT
+9 SET QANINCD=$TRANSLATE(QANINCD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+10 SET QANTYDTH=$SELECT(QANINCD="DEATH":$PIECE(QAN7424,U,14),1:"")
SET QANPROV=$PIECE(QAN7424,U,16)
+11 SET VA1026=$PIECE(QAN7424,U,9)
SET QANLVL=$PIECE(QAN7424,U,11)
SET QANLRIN=$PIECE(QAN7424,U,12)
+12 SET QANLRCP=$PIECE(QAN7424,U,13)
+13 if $DATA(^QA(742.4,QAN0,1,0))
DO DESC
+14 ;Grab patient data, build mail message
DO EN1^QANFULL0
+15 IF QANQUIT
KILL DA,DIE,DR
SET DIE="^QA(742.4,"
SET DA=QAN0
SET DR=".17///^S X=4"
DO ^DIE
KILL DA,DIE,DR
+16 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
+17 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
