QANMAIL ;HISC/GJC-Manually xmit data to the region (part 1) ;8/23/93 13:39
;;2.0;Incident Reporting;**1,18,20**;08/07/1992
EN1 ;Manually xmit data
S (QANQUIT,QANXIT)=0 K ^UTILITY($J,"QAN MAIL")
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 INCD ;Set incident data
I QANXIT D EXIT Q
D:$D(^UTILITY($J,"QAN MAIL")) BULL^QANMAL0
W !!?5,$S($D(^UTILITY($J,"QAN MAIL")):"Data transmitted to the region.",1:"No data found!")
EXIT ;Kill and quit
D KILL^XUSCLEAN K ^UTILITY($J,"QAN MAIL")
Q
ERROR ;Find error type
W *7,!!,"*** ",$P($T(ERR+QANERROR),";;",2)," ***",!!,*7
Q
INCD ;
;Choose the incident, put into report option
;*** QANIEN IS FILE 742.4'S IEN ***
K DD,DLAYGO,DO,DINUM,D,DIC S QANTYPE=1,DIC="^QA(742.4,",DIC(0)="QEANZ",DIC("A")="Select Incident Case Number: ",DIC("W")="D EN1^QANUTL"
S DIC("S")="I +$P(^(0),U,18)=0"
D ^DIC K DD,DLAYGO,DINUM,DO,D,DIC
I +Y=-1 W !!,*7,"Incident not selected, exiting!!" Q
E S QANIEN=+Y
S QAN7424=$G(^QA(742.4,QANIEN,0)) S:QAN7424']"" QANXIT=1
Q:QANXIT S (QANDESC,QANINCR)=0
S QANDATE=$P(QAN7424,U,3),QANCASE=$P(QAN7424,U)
S QANNCDNT=$P(QAN7424,U,2),QANINLOC=$P(QAN7424,U,4)
S:QANINLOC]"" QANINLOC=$P($G(^QA(742.5,QANINLOC,0)),U)
S QANINCD=$P($G(^QA(742.1,QANNCDNT,0)),U)
S:QANINCD']"" QANXIT=1 Q:QANXIT
S QANINCD=$TR(QANINCD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S QANTYDTH=$S(QANINCD="DEATH":$P(QAN7424,U,14),1:"")
S QANLCST=$P(QAN7424,U,8)
S QABANNER=$S(QANLCST=0:"CMAN",QANLCST=2:"DMAN",1:"OMAN")
S VA1026=+$P(QAN7424,U,9),QANLVL=$P(QAN7424,U,11)
S QANLRIN=$P(QAN7424,U,12),QANLRCP=$P(QAN7424,U,13)
I $D(^QA(742.4,QANIEN,1,0)) D DESC
D EN1^QANMAL0 ;Grab all associated patient data
I QANQUIT D
. K DA,DIE,DR S DA=QANIEN,DIE="^QA(742.4,"
. S DR=".17////"_QANLCST_";.21////1" D ^DIE
. K DIE,DA,DR
Q
DESC ;Grab description data
S DIWF="",DIWL=20,DIWR=60,QANDESC=1 K ^UTILITY($J,"W")
F QANLOOP=0:0 S QANLOOP=$O(^QA(742.4,QANIEN,1,QANLOOP)) Q:QANLOOP'>0 S X=$P(^QA(742.4,QANIEN,1,QANLOOP,0),U) D ^DIWP
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[HQANMAIL 3186 printed Nov 22, 2024@17:10:01 Page 2
QANMAIL ;HISC/GJC-Manually xmit data to the region (part 1) ;8/23/93 13:39
+1 ;;2.0;Incident Reporting;**1,18,20**;08/07/1992
EN1 ;Manually xmit data
+1 SET (QANQUIT,QANXIT)=0
KILL ^UTILITY($JOB,"QAN MAIL")
+2 SET QANZERO=$SELECT($DATA(^QA(740,1,0))#2:^(0),1:0)
IF +QANZERO'>0
SET QANERROR=1
DO ERROR
GOTO EXIT
+3 SET QANSITE=$SELECT($DATA(^DIC(4,+QANZERO,0))#2:$PIECE(^(0),"^"),1:"")
IF QANSITE=""
SET QANERROR=2
DO ERROR
GOTO EXIT
+4 SET QANSTNO=$SELECT($DATA(^DIC(4,+QANZERO,99))#2:$PIECE(^(99),"^"),1:"")
IF QANSTNO=""
SET QANERROR=3
DO ERROR
GOTO EXIT
+5 SET QANSERV=$PIECE(QANZERO,"^",4)
IF QANSERV=""
SET QANERROR=4
DO ERROR
GOTO EXIT
+6 SET QANDOM=$PIECE(QANZERO,"^",5)
IF QANDOM=""
SET QANERROR=5
DO ERROR
GOTO EXIT
+7 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
+8 SET QANQAN=$SELECT($DATA(^QA(740,1,"QAN")):^("QAN"),1:"")
IF +QANQAN'>0
SET QANERROR=7
DO ERROR
GOTO EXIT
+9 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
+10 ;Set incident data
DO INCD
+11 IF QANXIT
DO EXIT
QUIT
+12 if $DATA(^UTILITY($JOB,"QAN MAIL"))
DO BULL^QANMAL0
+13 WRITE !!?5,$SELECT($DATA(^UTILITY($JOB,"QAN MAIL")):"Data transmitted to the region.",1:"No data found!")
EXIT ;Kill and quit
+1 DO KILL^XUSCLEAN
KILL ^UTILITY($JOB,"QAN MAIL")
+2 QUIT
ERROR ;Find error type
+1 WRITE *7,!!,"*** ",$PIECE($TEXT(ERR+QANERROR),";;",2)," ***",!!,*7
+2 QUIT
INCD ;
+1 ;Choose the incident, put into report option
+2 ;*** QANIEN IS FILE 742.4'S IEN ***
+3 KILL DD,DLAYGO,DO,DINUM,D,DIC
SET QANTYPE=1
SET DIC="^QA(742.4,"
SET DIC(0)="QEANZ"
SET DIC("A")="Select Incident Case Number: "
SET DIC("W")="D EN1^QANUTL"
+4 SET DIC("S")="I +$P(^(0),U,18)=0"
+5 DO ^DIC
KILL DD,DLAYGO,DINUM,DO,D,DIC
+6 IF +Y=-1
WRITE !!,*7,"Incident not selected, exiting!!"
QUIT
+7 IF '$TEST
SET QANIEN=+Y
+8 SET QAN7424=$GET(^QA(742.4,QANIEN,0))
if QAN7424']""
SET QANXIT=1
+9 if QANXIT
QUIT
SET (QANDESC,QANINCR)=0
+10 SET QANDATE=$PIECE(QAN7424,U,3)
SET QANCASE=$PIECE(QAN7424,U)
+11 SET QANNCDNT=$PIECE(QAN7424,U,2)
SET QANINLOC=$PIECE(QAN7424,U,4)
+12 if QANINLOC]""
SET QANINLOC=$PIECE($GET(^QA(742.5,QANINLOC,0)),U)
+13 SET QANINCD=$PIECE($GET(^QA(742.1,QANNCDNT,0)),U)
+14 if QANINCD']""
SET QANXIT=1
if QANXIT
QUIT
+15 SET QANINCD=$TRANSLATE(QANINCD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+16 SET QANTYDTH=$SELECT(QANINCD="DEATH":$PIECE(QAN7424,U,14),1:"")
+17 SET QANLCST=$PIECE(QAN7424,U,8)
+18 SET QABANNER=$SELECT(QANLCST=0:"CMAN",QANLCST=2:"DMAN",1:"OMAN")
+19 SET VA1026=+$PIECE(QAN7424,U,9)
SET QANLVL=$PIECE(QAN7424,U,11)
+20 SET QANLRIN=$PIECE(QAN7424,U,12)
SET QANLRCP=$PIECE(QAN7424,U,13)
+21 IF $DATA(^QA(742.4,QANIEN,1,0))
DO DESC
+22 ;Grab all associated patient data
DO EN1^QANMAL0
+23 IF QANQUIT
Begin DoDot:1
+24 KILL DA,DIE,DR
SET DA=QANIEN
SET DIE="^QA(742.4,"
+25 SET DR=".17////"_QANLCST_";.21////1"
DO ^DIE
+26 KILL DIE,DA,DR
End DoDot:1
+27 QUIT
DESC ;Grab description data
+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,QANIEN,1,QANLOOP))
if QANLOOP'>0
QUIT
SET X=$PIECE(^QA(742.4,QANIEN,1,QANLOOP,0),U)
DO ^DIWP
+3 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
