XQALFWD ;ISC/JLI,ISD/HGW - FORWARD ALERTS ;06/20/12 13:09
;;8.0;KERNEL;**6,65,91,111,114,128,129,285,602**;Jul 10, 1995;Build 9
;Per VHA Directive 2004-038, this routine should not be modified.
Q
FWRD ; ENTRY POINT FOR SELECTION FROM 'VIEW ALERTS' SCREEN
; USER NEEDS TO SELECT ALERT(S) FOR FORWARDING
; TYPE (ALERT, MAIL MESSAGE, OR PRINT)
; AND RECIPIENT(S) OR DEVICE
; AND COMMENT IF ANY TO BE DISPLAYED WITH ALERT
;
; ZEXCEPT: DIC,DIRUT,IOF,X,XQA,XQAARR,XQACOMNT,XQALFWD,XQALFWDL,XQATYP,XQX1,XQXOUT,Y
W !,"Enter RETURN to continue:" R X:DTIME Q:'$T W @IOF,!,"You may now Select the alert or alerts that you want forwarded:",!
N XQI,XQK,XQACNT,XQAREV,DIR
S XQALFWD=1 S XQX1=-1 D DOIT^XQALERT1
K XQALFWDL
S:'$D(XQX1) XQX1=-1 S:'$D(XQXOUT) XQXOUT=0
F Q:XQX1'>0 S XQALFWDL(+XQX1)=$P(^TMP("XQ",$J,"XQA1",+XQX1),U,2),XQX1=$P(XQX1,",",2,200)
G:'$D(XQALFWDL) EXIT
FWDONE K DIR S DIR(0)="S^A:ALERT;M:MAIL MESSAGE;P:PRINT COPY;",DIR("A")="Select the method of forwarding desired",DIR("B")="ALERT" D ^DIR K DIR G:$D(DIRUT) EXIT S XQATYP=Y
I XQATYP="A"!(XQATYP="M") D LOOP1^XQALMAKE G:'$D(XQA) EXIT N XQAI S XQAI="" F S XQAI=$O(XQA(XQAI)) Q:XQAI="" S XQAARR(XQAI)=XQAI K XQA(XQAI)
I XQATYP="P" S DIC=3.5,DIC(0)="AEQM",DIC("A")="Select the DEVICE to print on: " D ^DIC K DIC G:Y'>0 EXIT S XQAARR="`"_(+Y)
S DIR("A",1)="You may enter a comment to be associated with the forwarded alert if you wish",DIR("A")="Comment (optional)",DIR("?")="Free text 1 to 245 characters.",DIR(0)="FO^1:245"
D ^DIR G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) EXIT S XQACOMNT=X
K XQALFWD,DIR
D FORWARD(.XQALFWDL,.XQAARR,XQATYP,XQACOMNT)
EXIT S XQX1=-1 W !!,"You will now return to PROCESSING ALERTS, enter RETURN to continue:" R X:DTIME
K XQALFWDL,XQAARR,XQATYP,XQACOMNT,DIRUT,XQALFWD
Q
;
FORWARD1(XQAID,XQARECIP,XQATYPE,XQACOMNT,XQALTYPE) ;
D FORWARD(.XQAID,XQARECIP,XQATYPE,XQACOMNT)
Q
;
FORWARD(XQALST,XQARECIP,XQATYPE,XQACOMNT) ; SR. ICR #3009 (Supported)
;D FORWARD^XQALFWD([.]alerts,[.]users,type[,comment])
; [.]alerts - Alerts to be forwarded by full identifier ($$SETUP1^XQALERT)
; [.]users - Users to forward alerts to by IEN (file #200), G.MAIL GROUP, or printer (name or `IEN)
; type - A:alert, M:mailgroup, P:printer
; comment - Character string comment to accompany the alert
; ZEXCEPT: IOP
Q:'$D(XQALST) Q:'$D(XQARECIP)
N I,XQAPRNT,XQAVALS,XQALTYPE,%ZIS,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
S XQALTYPE="FWD BY USER"
S XQATYPE=$G(XQATYPE)
I XQATYPE="A" D
. N XQAI S XQAI="" F S XQAI=$O(XQALST(XQAI)) Q:XQAI="" D SETXQA D RESETUP(XQALST(XQAI),.XQAVALS,XQACOMNT)
. I $O(XQALST(""))="",$D(XQALST)=1,XQALST'="" D SETXQA D RESETUP(XQALST,.XQAVALS,XQACOMNT)
I XQATYPE="M" D
. D MAIL1
I XQATYPE="P" D
. S XQAPRNT=$$FIND1^DIC(3.5,,"X",$G(XQARECIP)) Q:XQAPRNT'>0 ;p602
. S IOP="Q;"_$P($G(^%ZIS(1,XQAPRNT,0)),U) ;p602
. S %ZIS="Q" D ^%ZIS Q:POP ;p602
. S ZTRTN="PRNT^XQALFWD",ZTDESC="Forward alerts to printer",ZTDTH=$H,ZTSAVE("XQA*")="" ;p602
. D ^%ZTLOAD D HOME^%ZIS K IO("Q") ;p602
Q
;
SETXQA ;
; ZEXCEPT: J,XQARECIP,XQAVALS
I $D(XQARECIP)=1 S XQAVALS(XQARECIP)="" Q
S J="" F S J=$O(XQARECIP(J)) Q:J="" S XQAVALS(XQARECIP(J))=""
Q
;
SETXMY ;
; ZEXCEPT: J,XMY,XQARECIP
I $D(XQARECIP)=1 S XMY(XQARECIP)="" Q
S J="" F S J=$O(XQARECIP(J)) Q:J="" S XMY(XQARECIP(J))=""
Q
;
MAIL1 ;
; ZEXCEPT: X,XQALST,XQAUSER
N I,XMY,XMSUB,XMTEXT
N XQAI S XQAI="" F S XQAI=$O(XQALST(XQAI)) Q:XQAI="" S X=$O(^XTV(8992,"AXQA",XQALST(XQAI),XQAUSER,0)) I X'="" S X=$G(^XTV(8992,XQAUSER,"XQA",X,0)) I X'="" D SETXMY D MAIL
I $D(XQALST)=1,XQALST]"" S X=$O(^XTV(8992,"AXQA",XQALST,XQAUSER,0)) I X'="" S X=$G(^XTV(8992,XQAUSER,"XQA",X,0)) I X'="" D SETXMY D MAIL
Q
MAIL ;
; ZEXCEPT: X,XMSUB,XMTEXT,XQACOMNT,XQAUSER
K ^TMP($J,"XQAL") S XMSUB="ALERT: "_$P(X,U,3),XMTEXT="^TMP($J,""XQAL"","
S ^TMP($J,"XQAL",1,0)=$P(X,U,3),^TMP($J,"XQAL",2,0)=" Forwarded by: "_$P(^VA(200,XQAUSER,0),U)_" Generated: "_$$DAT8^XQALERT($P($P(X,U,2),";",3),1) S:$G(XQACOMNT)'="" ^TMP($J,"XQAL",3,0)=XQACOMNT
D ^XMD
Q
;
PRNT ;
; ZEXCEPT: X,XQALST,XQAUSER
I $D(XQALST)=1,XQALST>0 S X=$O(^XTV(8992,"AXQA",XQALST,XQAUSER,0)) I X'="" S X=$G(^XTV(8992,XQAUSER,"XQA",X,0)) I X'="" D PRNT1
N XQAI S XQAI="" F S XQAI=$O(XQALST(XQAI)) Q:XQAI="" S X=$O(^XTV(8992,"AXQA",XQALST(XQAI),XQAUSER,0)) I X'="" S X=$G(^XTV(8992,XQAUSER,"XQA",X,0)) I X'="" D PRNT1
Q
PRNT1 ;
; ZEXCEPT: IOF,X,XQACOMNT,XQAUSER
U IO W @IOF
W !!,"ALERT: "_$P(X,U,3),!!," Forwarded by: ",$P(^VA(200,XQAUSER,0),U)," Generated on: ",$$DAT8^XQALERT($P($P(X,U,2),";",3)),!!,$G(XQACOMNT)
Q
;
RESETUP(XQAIDVAL,XQA,XQACOMNT) ;
; ZEXCEPT: XQALTYPE,XQAUSER
N XQAIEN,DA,XQI,XQJ,XQK,XQX,X,X1,X3,XQARESET,XQAID,XQA1,XQADA,XQAOPT1,XQAMSG,XQACTMSG,XQADATA,XQAGUID,RETVAL,XQADA,XQADFN
S:'$D(XQAUSER) XQAUSER=DUZ
S XQARESET=1,XQALTYPE=$G(XQALTYPE,"FWD BY USER")
S XQAIEN=$O(^XTV(8992,"AXQA",XQAIDVAL,XQAUSER,0)) Q:XQAIEN'>0
S X=$G(^XTV(8992,XQAUSER,"XQA",XQAIEN,0)),X1=$G(^(1)),X3=$G(^(3))
Q:X=""
S XQAID=$P(X,U,2),XQA1=$P(XQAID,";"),XQADA=$O(^XTV(8992.1,"B",XQAID,0))
S XQAOPT1=$P(X,U,7,8),XQAMSG=$P(X,U,3),XQACTMSG=$P(X,U,6)
S XQADATA=$S(X1'="":X1,1:$P(X,U,9,100)) S:$P(X3,U)'="" XQAGUID=$P(X3,U) S:$P(X3,U,2)'="" XQADFN=$P(X3,U,2)
S XQX=$$NOW^XLFDT()
S RETVAL=$$REENT^XQALSET()
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALFWD 5372 printed Jan 18, 2025@03:06:35 Page 2
XQALFWD ;ISC/JLI,ISD/HGW - FORWARD ALERTS ;06/20/12 13:09
+1 ;;8.0;KERNEL;**6,65,91,111,114,128,129,285,602**;Jul 10, 1995;Build 9
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
FWRD ; ENTRY POINT FOR SELECTION FROM 'VIEW ALERTS' SCREEN
+1 ; USER NEEDS TO SELECT ALERT(S) FOR FORWARDING
+2 ; TYPE (ALERT, MAIL MESSAGE, OR PRINT)
+3 ; AND RECIPIENT(S) OR DEVICE
+4 ; AND COMMENT IF ANY TO BE DISPLAYED WITH ALERT
+5 ;
+6 ; ZEXCEPT: DIC,DIRUT,IOF,X,XQA,XQAARR,XQACOMNT,XQALFWD,XQALFWDL,XQATYP,XQX1,XQXOUT,Y
+7 WRITE !,"Enter RETURN to continue:"
READ X:DTIME
if '$TEST
QUIT
WRITE @IOF,!,"You may now Select the alert or alerts that you want forwarded:",!
+8 NEW XQI,XQK,XQACNT,XQAREV,DIR
+9 SET XQALFWD=1
SET XQX1=-1
DO DOIT^XQALERT1
+10 KILL XQALFWDL
+11 if '$DATA(XQX1)
SET XQX1=-1
if '$DATA(XQXOUT)
SET XQXOUT=0
+12 FOR
if XQX1'>0
QUIT
SET XQALFWDL(+XQX1)=$PIECE(^TMP("XQ",$JOB,"XQA1",+XQX1),U,2)
SET XQX1=$PIECE(XQX1,",",2,200)
+13 if '$DATA(XQALFWDL)
GOTO EXIT
FWDONE KILL DIR
SET DIR(0)="S^A:ALERT;M:MAIL MESSAGE;P:PRINT COPY;"
SET DIR("A")="Select the method of forwarding desired"
SET DIR("B")="ALERT"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET XQATYP=Y
+1 IF XQATYP="A"!(XQATYP="M")
DO LOOP1^XQALMAKE
if '$DATA(XQA)
GOTO EXIT
NEW XQAI
SET XQAI=""
FOR
SET XQAI=$ORDER(XQA(XQAI))
if XQAI=""
QUIT
SET XQAARR(XQAI)=XQAI
KILL XQA(XQAI)
+2 IF XQATYP="P"
SET DIC=3.5
SET DIC(0)="AEQM"
SET DIC("A")="Select the DEVICE to print on: "
DO ^DIC
KILL DIC
if Y'>0
GOTO EXIT
SET XQAARR="`"_(+Y)
+3 SET DIR("A",1)="You may enter a comment to be associated with the forwarded alert if you wish"
SET DIR("A")="Comment (optional)"
SET DIR("?")="Free text 1 to 245 characters."
SET DIR(0)="FO^1:245"
+4 DO ^DIR
if $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO EXIT
SET XQACOMNT=X
+5 KILL XQALFWD,DIR
+6 DO FORWARD(.XQALFWDL,.XQAARR,XQATYP,XQACOMNT)
EXIT SET XQX1=-1
WRITE !!,"You will now return to PROCESSING ALERTS, enter RETURN to continue:"
READ X:DTIME
+1 KILL XQALFWDL,XQAARR,XQATYP,XQACOMNT,DIRUT,XQALFWD
+2 QUIT
+3 ;
FORWARD1(XQAID,XQARECIP,XQATYPE,XQACOMNT,XQALTYPE) ;
+1 DO FORWARD(.XQAID,XQARECIP,XQATYPE,XQACOMNT)
+2 QUIT
+3 ;
FORWARD(XQALST,XQARECIP,XQATYPE,XQACOMNT) ; SR. ICR #3009 (Supported)
+1 ;D FORWARD^XQALFWD([.]alerts,[.]users,type[,comment])
+2 ; [.]alerts - Alerts to be forwarded by full identifier ($$SETUP1^XQALERT)
+3 ; [.]users - Users to forward alerts to by IEN (file #200), G.MAIL GROUP, or printer (name or `IEN)
+4 ; type - A:alert, M:mailgroup, P:printer
+5 ; comment - Character string comment to accompany the alert
+6 ; ZEXCEPT: IOP
+7 if '$DATA(XQALST)
QUIT
if '$DATA(XQARECIP)
QUIT
+8 NEW I,XQAPRNT,XQAVALS,XQALTYPE,%ZIS,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
+9 SET XQALTYPE="FWD BY USER"
+10 SET XQATYPE=$GET(XQATYPE)
+11 IF XQATYPE="A"
Begin DoDot:1
+12 NEW XQAI
SET XQAI=""
FOR
SET XQAI=$ORDER(XQALST(XQAI))
if XQAI=""
QUIT
DO SETXQA
DO RESETUP(XQALST(XQAI),.XQAVALS,XQACOMNT)
+13 IF $ORDER(XQALST(""))=""
IF $DATA(XQALST)=1
IF XQALST'=""
DO SETXQA
DO RESETUP(XQALST,.XQAVALS,XQACOMNT)
End DoDot:1
+14 IF XQATYPE="M"
Begin DoDot:1
+15 DO MAIL1
End DoDot:1
+16 IF XQATYPE="P"
Begin DoDot:1
+17 ;p602
SET XQAPRNT=$$FIND1^DIC(3.5,,"X",$GET(XQARECIP))
if XQAPRNT'>0
QUIT
+18 ;p602
SET IOP="Q;"_$PIECE($GET(^%ZIS(1,XQAPRNT,0)),U)
+19 ;p602
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+20 ;p602
SET ZTRTN="PRNT^XQALFWD"
SET ZTDESC="Forward alerts to printer"
SET ZTDTH=$HOROLOG
SET ZTSAVE("XQA*")=""
+21 ;p602
DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
End DoDot:1
+22 QUIT
+23 ;
SETXQA ;
+1 ; ZEXCEPT: J,XQARECIP,XQAVALS
+2 IF $DATA(XQARECIP)=1
SET XQAVALS(XQARECIP)=""
QUIT
+3 SET J=""
FOR
SET J=$ORDER(XQARECIP(J))
if J=""
QUIT
SET XQAVALS(XQARECIP(J))=""
+4 QUIT
+5 ;
SETXMY ;
+1 ; ZEXCEPT: J,XMY,XQARECIP
+2 IF $DATA(XQARECIP)=1
SET XMY(XQARECIP)=""
QUIT
+3 SET J=""
FOR
SET J=$ORDER(XQARECIP(J))
if J=""
QUIT
SET XMY(XQARECIP(J))=""
+4 QUIT
+5 ;
MAIL1 ;
+1 ; ZEXCEPT: X,XQALST,XQAUSER
+2 NEW I,XMY,XMSUB,XMTEXT
+3 NEW XQAI
SET XQAI=""
FOR
SET XQAI=$ORDER(XQALST(XQAI))
if XQAI=""
QUIT
SET X=$ORDER(^XTV(8992,"AXQA",XQALST(XQAI),XQAUSER,0))
IF X'=""
SET X=$GET(^XTV(8992,XQAUSER,"XQA",X,0))
IF X'=""
DO SETXMY
DO MAIL
+4 IF $DATA(XQALST)=1
IF XQALST]""
SET X=$ORDER(^XTV(8992,"AXQA",XQALST,XQAUSER,0))
IF X'=""
SET X=$GET(^XTV(8992,XQAUSER,"XQA",X,0))
IF X'=""
DO SETXMY
DO MAIL
+5 QUIT
MAIL ;
+1 ; ZEXCEPT: X,XMSUB,XMTEXT,XQACOMNT,XQAUSER
+2 KILL ^TMP($JOB,"XQAL")
SET XMSUB="ALERT: "_$PIECE(X,U,3)
SET XMTEXT="^TMP($J,""XQAL"","
+3 SET ^TMP($JOB,"XQAL",1,0)=$PIECE(X,U,3)
SET ^TMP($JOB,"XQAL",2,0)=" Forwarded by: "_$PIECE(^VA(200,XQAUSER,0),U)_" Generated: "_$$DAT8^XQALERT($PIECE($PIECE(X,U,2),";",3),1)
if $GET(XQACOMNT)'=""
SET ^TMP($JOB,"XQAL",3,0)=XQACOMNT
+4 DO ^XMD
+5 QUIT
+6 ;
PRNT ;
+1 ; ZEXCEPT: X,XQALST,XQAUSER
+2 IF $DATA(XQALST)=1
IF XQALST>0
SET X=$ORDER(^XTV(8992,"AXQA",XQALST,XQAUSER,0))
IF X'=""
SET X=$GET(^XTV(8992,XQAUSER,"XQA",X,0))
IF X'=""
DO PRNT1
+3 NEW XQAI
SET XQAI=""
FOR
SET XQAI=$ORDER(XQALST(XQAI))
if XQAI=""
QUIT
SET X=$ORDER(^XTV(8992,"AXQA",XQALST(XQAI),XQAUSER,0))
IF X'=""
SET X=$GET(^XTV(8992,XQAUSER,"XQA",X,0))
IF X'=""
DO PRNT1
+4 QUIT
PRNT1 ;
+1 ; ZEXCEPT: IOF,X,XQACOMNT,XQAUSER
+2 USE IO
WRITE @IOF
+3 WRITE !!,"ALERT: "_$PIECE(X,U,3),!!," Forwarded by: ",$PIECE(^VA(200,XQAUSER,0),U)," Generated on: ",$$DAT8^XQALERT($PIECE($PIECE(X,U,2),";",3)),!!,$GET(XQACOMNT)
+4 QUIT
+5 ;
RESETUP(XQAIDVAL,XQA,XQACOMNT) ;
+1 ; ZEXCEPT: XQALTYPE,XQAUSER
+2 NEW XQAIEN,DA,XQI,XQJ,XQK,XQX,X,X1,X3,XQARESET,XQAID,XQA1,XQADA,XQAOPT1,XQAMSG,XQACTMSG,XQADATA,XQAGUID,RETVAL,XQADA,XQADFN
+3 if '$DATA(XQAUSER)
SET XQAUSER=DUZ
+4 SET XQARESET=1
SET XQALTYPE=$GET(XQALTYPE,"FWD BY USER")
+5 SET XQAIEN=$ORDER(^XTV(8992,"AXQA",XQAIDVAL,XQAUSER,0))
if XQAIEN'>0
QUIT
+6 SET X=$GET(^XTV(8992,XQAUSER,"XQA",XQAIEN,0))
SET X1=$GET(^(1))
SET X3=$GET(^(3))
+7 if X=""
QUIT
+8 SET XQAID=$PIECE(X,U,2)
SET XQA1=$PIECE(XQAID,";")
SET XQADA=$ORDER(^XTV(8992.1,"B",XQAID,0))
+9 SET XQAOPT1=$PIECE(X,U,7,8)
SET XQAMSG=$PIECE(X,U,3)
SET XQACTMSG=$PIECE(X,U,6)
+10 SET XQADATA=$SELECT(X1'="":X1,1:$PIECE(X,U,9,100))
if $PIECE(X3,U)'=""
SET XQAGUID=$PIECE(X3,U)
if $PIECE(X3,U,2)'=""
SET XQADFN=$PIECE(X3,U,2)
+11 SET XQX=$$NOW^XLFDT()
+12 SET RETVAL=$$REENT^XQALSET()
+13 QUIT
