source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALFWD.m@ 1742

XQALFWD ;ISC-SF.SEA/JLI - FORWARD ALERTS ;7/24/03  16:27
 ;;8.0;KERNEL;**6,65,91,111,114,128,129,285**;Jul 10, 1995
 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
 ;
 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) ;
 Q:'$D(XQALST)  Q:'$D(XQARECIP)
 N I,XQAVALS,XQALTYPE
 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 IOP=XQAARR D ^%ZIS Q:POP
 . D PRNT D ^%ZISC
 Q
 ;
SETXQA ;
 I $D(XQARECIP)=1 S XQAVALS(XQARECIP)="" Q
 S J="" F  S J=$O(XQARECIP(J)) Q:J=""  S XQAVALS(XQARECIP(J))=""
 Q
 ;
SETXMY ;
 I $D(XQARECIP)=1 S XMY(XQARECIP)="" Q
 S J="" F  S J=$O(XQARECIP(J)) Q:J=""  S XMY(XQARECIP(J))=""
 Q
 ;
MAIL1 ;
 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 ;
 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 ;
 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 ;
 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) ;
 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