QAOSEWS0 ;HISC/DAD-GENERATE 'EARLY WARNING SYSTEM' BULLETINS ;5/14/93 07:54
;;3.0;Occurrence Screen;;09/14/1993
EN1 S QAOSTASK=0 ; *** MANUAL ENTRY POINT
G EN
EN2 S QAOSTASK=1 ; *** TASKED ENTRY POINT
EN S QAOSZERO=$G(^QA(740,1,0)) I +QAOSZERO'>0 S QAOERROR=1 D ERROR G EXIT
S QAOSSITE=$P($G(^DIC(4,+QAOSZERO,0)),"^")
I QAOSSITE="" S QAOERROR=2 D ERROR G EXIT
S QAOSSTNO=$P($G(^DIC(4,+QAOSZERO,99)),"^")
I QAOSSTNO="" S QAOERROR=3 D ERROR G EXIT
S QAOSSERV=$P(QAOSZERO,"^",2) I QAOSSERV="" S QAOERROR=4 D ERROR G EXIT
S QAOSDOM=$P(QAOSZERO,"^",3) I QAOSDOM="" S QAOERROR=5 D ERROR G EXIT
S QA=+$O(^DIC(4.2,"B",$E(QAOSDOM,1,30),0))
I $S($D(^DIC(4.2,QA,0))[0:1,$P(^(0),"^")'=QAOSDOM:1,1:0) S ERROR=6 D ERROR G EXIT
S QAOSLGRP=+$P(QAOSZERO,"^",6),QAOSLGRP=$P($G(^XMB(3.8,QAOSLGRP,0)),"^")
S QAOSLDOM=$G(^XMB("NETNAME"))
I QAOSTASK D ; Automatic monthly date range
. S QAOSY=$E(DT,1,3),QAOSM=$E(DT,4,5)
. I QAOSM>1 S QAOSM=QAOSM-1
. E S QAOSM=12,QAOSY=QAOSY-1
. S QAOSM=$E("0",1,2-$L(QAOSM))_QAOSM
. S QAQNBEG=QAOSY_QAOSM_"01",Y=1700+QAOSY,Y=(Y#4=0)&((Y#100)!(Y#400=0))
. S QAQNEND=QAOSY_QAOSM_$P("31^28^31^30^31^30^31^31^30^31^30^31","^",+QAOSM)+$S(+QAOSM=2:Y,1:0)
. K QAOSY,QAOSM
. Q
I 'QAOSTASK W !!,"Select the reporting period:" S QAQDATE="Monthly" D ^QAQDATE G:QAQQUIT EXIT
I 'QAOSTASK D WAIT^DICD
S QAOSLIST(0)="1," D ^QAOSPSM0
D EN^QAOSEWS1
EXIT ;
K %,%ZIS,DIR,DIRUT,ERROR,POP,QA,QAO,QAOBLANK,QAOERROR,QAOPART2,QAOS
K QAOSACTN,QAOSCLIN,QAOSCREV,QAOSCRN,QAOSD0,QAOSD1,QAOSDATA,QAOSDATE
K QAOSDOM,QAOSEWS,QAOSFIND,QAOSLDOM,QAOSLEVL,QAOSLGRP,QAOSLIST,QAOSLST
K QAOSM,QAOSMGMT,QAOSNUM,QAOSPEER,QAOSQUIT,QAOSRFPR,QAOSS1,QAOSS2
K QAOSSCRN,QAOSSEQ,QAOSSERV,QAOSSITE,QAOSSTAT,QAOSSTNO,QAOSTASK,QAOSTEMP
K QAOSTEXT,QAOSY,QAOSZERO,TAB,UNDL,X,Y,ZTRTN,ZTSAVE
K ^UTILITY($J,"QAOSPSM"),^UTILITY($J,"QAOSXREF"),^UTILITY($J,"QAOSPEND")
D K^QAQDATE,KILL^XM S:$D(ZTQUEUED) ZTREQ="@"
Q
ERROR ;
W:'QAOSTASK *7,!!,"*** ",$P($T(ERR+QAOERROR),";;",2)," ***",!!,*7
Q
ERR ;;ERROR MESSAGES: REASONS EWS BULLETIN COULD NOT BE SENT
;;STATION NAME NOT FOUND IN QA SITE PARAMETERS FILE
;;STATION NAME NOT FOUND IN INSTITUTION FILE
;;STATION 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[HQAOSEWS0 2395 printed Nov 22, 2024@17:31:30 Page 2
QAOSEWS0 ;HISC/DAD-GENERATE 'EARLY WARNING SYSTEM' BULLETINS ;5/14/93 07:54
+1 ;;3.0;Occurrence Screen;;09/14/1993
EN1 ; *** MANUAL ENTRY POINT
SET QAOSTASK=0
+1 GOTO EN
EN2 ; *** TASKED ENTRY POINT
SET QAOSTASK=1
EN SET QAOSZERO=$GET(^QA(740,1,0))
IF +QAOSZERO'>0
SET QAOERROR=1
DO ERROR
GOTO EXIT
+1 SET QAOSSITE=$PIECE($GET(^DIC(4,+QAOSZERO,0)),"^")
+2 IF QAOSSITE=""
SET QAOERROR=2
DO ERROR
GOTO EXIT
+3 SET QAOSSTNO=$PIECE($GET(^DIC(4,+QAOSZERO,99)),"^")
+4 IF QAOSSTNO=""
SET QAOERROR=3
DO ERROR
GOTO EXIT
+5 SET QAOSSERV=$PIECE(QAOSZERO,"^",2)
IF QAOSSERV=""
SET QAOERROR=4
DO ERROR
GOTO EXIT
+6 SET QAOSDOM=$PIECE(QAOSZERO,"^",3)
IF QAOSDOM=""
SET QAOERROR=5
DO ERROR
GOTO EXIT
+7 SET QA=+$ORDER(^DIC(4.2,"B",$EXTRACT(QAOSDOM,1,30),0))
+8 IF $SELECT($DATA(^DIC(4.2,QA,0))[0:1,$PIECE(^(0),"^")'=QAOSDOM:1,1:0)
SET ERROR=6
DO ERROR
GOTO EXIT
+9 SET QAOSLGRP=+$PIECE(QAOSZERO,"^",6)
SET QAOSLGRP=$PIECE($GET(^XMB(3.8,QAOSLGRP,0)),"^")
+10 SET QAOSLDOM=$GET(^XMB("NETNAME"))
+11 ; Automatic monthly date range
IF QAOSTASK
Begin DoDot:1
+12 SET QAOSY=$EXTRACT(DT,1,3)
SET QAOSM=$EXTRACT(DT,4,5)
+13 IF QAOSM>1
SET QAOSM=QAOSM-1
+14 IF '$TEST
SET QAOSM=12
SET QAOSY=QAOSY-1
+15 SET QAOSM=$EXTRACT("0",1,2-$LENGTH(QAOSM))_QAOSM
+16 SET QAQNBEG=QAOSY_QAOSM_"01"
SET Y=1700+QAOSY
SET Y=(Y#4=0)&((Y#100)!(Y#400=0))
+17 SET QAQNEND=QAOSY_QAOSM_$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",+QAOSM)+$SELECT(+QAOSM=2:Y,1:0)
+18 KILL QAOSY,QAOSM
+19 QUIT
End DoDot:1
+20 IF 'QAOSTASK
WRITE !!,"Select the reporting period:"
SET QAQDATE="Monthly"
DO ^QAQDATE
if QAQQUIT
GOTO EXIT
+21 IF 'QAOSTASK
DO WAIT^DICD
+22 SET QAOSLIST(0)="1,"
DO ^QAOSPSM0
+23 DO EN^QAOSEWS1
EXIT ;
+1 KILL %,%ZIS,DIR,DIRUT,ERROR,POP,QA,QAO,QAOBLANK,QAOERROR,QAOPART2,QAOS
+2 KILL QAOSACTN,QAOSCLIN,QAOSCREV,QAOSCRN,QAOSD0,QAOSD1,QAOSDATA,QAOSDATE
+3 KILL QAOSDOM,QAOSEWS,QAOSFIND,QAOSLDOM,QAOSLEVL,QAOSLGRP,QAOSLIST,QAOSLST
+4 KILL QAOSM,QAOSMGMT,QAOSNUM,QAOSPEER,QAOSQUIT,QAOSRFPR,QAOSS1,QAOSS2
+5 KILL QAOSSCRN,QAOSSEQ,QAOSSERV,QAOSSITE,QAOSSTAT,QAOSSTNO,QAOSTASK,QAOSTEMP
+6 KILL QAOSTEXT,QAOSY,QAOSZERO,TAB,UNDL,X,Y,ZTRTN,ZTSAVE
+7 KILL ^UTILITY($JOB,"QAOSPSM"),^UTILITY($JOB,"QAOSXREF"),^UTILITY($JOB,"QAOSPEND")
+8 DO K^QAQDATE
DO KILL^XM
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 QUIT
ERROR ;
+1 if 'QAOSTASK
WRITE *7,!!,"*** ",$PIECE($TEXT(ERR+QAOERROR),";;",2)," ***",!!,*7
+2 QUIT
ERR ;;ERROR MESSAGES: REASONS EWS BULLETIN COULD NOT BE SENT
+1 ;;STATION NAME NOT FOUND IN QA SITE PARAMETERS FILE
+2 ;;STATION NAME NOT FOUND IN INSTITUTION FILE
+3 ;;STATION 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
