QANEWS0 ;HISC/GJC-GENERATE `EARLY WARNING SYSTEM' BULLETINS ;7/8/91 11:02
;;2.0;Incident Reporting;**25**;08/07/1992
EN1 ; *** MANUAL ENTRY POINT
S QANTASK=0
G EN
EN2 ; *** TASKED ENTRY POINT
S QANTASK=1
EN 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,"^",2) I QANSERV="" S QANERROR=4 D ERROR G EXIT
S QANDOM=$P(QANZERO,"^",3) 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 ERROR=6 D ERROR G EXIT
D:QANTASK MONTH,EN2^QANEWS
I 'QANTASK W !!,"Select the reporting period:" D EN1^QANEWS G:QAQQUIT EXIT
W:'QANTASK !!,"Finished."
EXIT ;
K QA,QAN,QAN1,QANIN,QANOUT,ERROR,QANCLIN,QANCREV,QAND0,QAND1,QANDATE
K QANDOM,QANEWS,QANFIND,QANLEVL,QANQUIT,QANRFPR,QANSCRN,QANSERV,QANSITE
K QANERROR,QANTASK,QANSTNO,QANTEMP,QANVAL,QANZERO,^UTILITY($J)
D K^QAQDATE,KILL^XM,KILL^QAQDATE
Q
ERROR ;
W *7,!!,"*** ",$P($T(ERR+QANERROR),";;",2)," ***",!!,*7
Q
MONTH ;
S QANSY=$E(DT,1,3),QANSM=$E(DT,4,5)
I QANSM>1 S QANSM=QANSM-1
E S QANSM=12,QANSY=QANSY-1
S QANSM=$E("0",1,2-$L(QANSM))_QANSM
S QAQNBEG=QANSY_QANSM_"01",Y=1700+QANSY,Y=(Y#4=0)&((Y#100)!(Y#400=0))
S QAQNEND=QANSY_QANSM_$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+QANSM)+$S(+QANSM=2:Y,1:0)
K QANSY,QANSM
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
;;EWS MAIL GROUP/SERVER NOT FOUND IN QA SITE PARAMETERS FILE
;;EWS DOMAIN NOT FOUND IN QA SITE PARAMETERS FILE
;;EWS DOMAIN NOT FOUND IN DOMAIN FILE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANEWS0 1902 printed Apr 09, 2024@21:01:25 Page 2
QANEWS0 ;HISC/GJC-GENERATE `EARLY WARNING SYSTEM' BULLETINS ;7/8/91 11:02
+1 ;;2.0;Incident Reporting;**25**;08/07/1992
EN1 ; *** MANUAL ENTRY POINT
+1 SET QANTASK=0
+2 GOTO EN
EN2 ; *** TASKED ENTRY POINT
+1 SET QANTASK=1
EN SET QANZERO=$SELECT($DATA(^QA(740,1,0))#2:^(0),1:0)
IF +QANZERO'>0
SET QANERROR=1
DO ERROR
GOTO EXIT
+1 SET QANSITE=$SELECT($DATA(^DIC(4,+QANZERO,0))#2:$PIECE(^(0),"^"),1:"")
IF QANSITE=""
SET QANERROR=2
DO ERROR
GOTO EXIT
+2 SET QANSTNO=$SELECT($DATA(^DIC(4,+QANZERO,99))#2:$PIECE(^(99),"^"),1:"")
IF QANSTNO=""
SET QANERROR=3
DO ERROR
GOTO EXIT
+3 SET QANSERV=$PIECE(QANZERO,"^",2)
IF QANSERV=""
SET QANERROR=4
DO ERROR
GOTO EXIT
+4 SET QANDOM=$PIECE(QANZERO,"^",3)
IF QANDOM=""
SET QANERROR=5
DO ERROR
GOTO EXIT
+5 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 ERROR=6
DO ERROR
GOTO EXIT
+6 if QANTASK
DO MONTH
DO EN2^QANEWS
+7 IF 'QANTASK
WRITE !!,"Select the reporting period:"
DO EN1^QANEWS
if QAQQUIT
GOTO EXIT
+8 if 'QANTASK
WRITE !!,"Finished."
EXIT ;
+1 KILL QA,QAN,QAN1,QANIN,QANOUT,ERROR,QANCLIN,QANCREV,QAND0,QAND1,QANDATE
+2 KILL QANDOM,QANEWS,QANFIND,QANLEVL,QANQUIT,QANRFPR,QANSCRN,QANSERV,QANSITE
+3 KILL QANERROR,QANTASK,QANSTNO,QANTEMP,QANVAL,QANZERO,^UTILITY($JOB)
+4 DO K^QAQDATE
DO KILL^XM
DO KILL^QAQDATE
+5 QUIT
ERROR ;
+1 WRITE *7,!!,"*** ",$PIECE($TEXT(ERR+QANERROR),";;",2)," ***",!!,*7
+2 QUIT
MONTH ;
+1 SET QANSY=$EXTRACT(DT,1,3)
SET QANSM=$EXTRACT(DT,4,5)
+2 IF QANSM>1
SET QANSM=QANSM-1
+3 IF '$TEST
SET QANSM=12
SET QANSY=QANSY-1
+4 SET QANSM=$EXTRACT("0",1,2-$LENGTH(QANSM))_QANSM
+5 SET QAQNBEG=QANSY_QANSM_"01"
SET Y=1700+QANSY
SET Y=(Y#4=0)&((Y#100)!(Y#400=0))
+6 SET QAQNEND=QANSY_QANSM_$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,+QANSM)+$SELECT(+QANSM=2:Y,1:0)
+7 KILL QANSY,QANSM
+8 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 ;;EWS MAIL GROUP/SERVER NOT FOUND IN QA SITE PARAMETERS FILE
+5 ;;EWS DOMAIN NOT FOUND IN QA SITE PARAMETERS FILE
+6 ;;EWS DOMAIN NOT FOUND IN DOMAIN FILE
