Released XU*8*443 SEQ #394 Extracted from mail message **KIDS**:XU*8.0*443^ **INSTALL NAME** XU*8.0*443 "BLD",1000,0) XU*8.0*443^KERNEL^0^3080317^y "BLD",1000,1,0) ^^1^1^3080317^^ "BLD",1000,1,1,0) See the description on the patch module on FORUM. "BLD",1000,4,0) ^9.64PA^^ "BLD",1000,6.3) 4 "BLD",1000,"KRN",0) ^9.67PA^779.2^20 "BLD",1000,"KRN",.4,0) .4 "BLD",1000,"KRN",.401,0) .401 "BLD",1000,"KRN",.402,0) .402 "BLD",1000,"KRN",.403,0) .403 "BLD",1000,"KRN",.5,0) .5 "BLD",1000,"KRN",.84,0) .84 "BLD",1000,"KRN",3.6,0) 3.6 "BLD",1000,"KRN",3.8,0) 3.8 "BLD",1000,"KRN",9.2,0) 9.2 "BLD",1000,"KRN",9.8,0) 9.8 "BLD",1000,"KRN",9.8,"NM",0) ^9.68A^9^9 "BLD",1000,"KRN",9.8,"NM",1,0) XQALDATA^^0^B8047519 "BLD",1000,"KRN",9.8,"NM",2,0) XQALDEL^^0^B55829845 "BLD",1000,"KRN",9.8,"NM",3,0) XQALERT1^^0^B78786817 "BLD",1000,"KRN",9.8,"NM",4,0) XQALMAKE^^0^B13487319 "BLD",1000,"KRN",9.8,"NM",5,0) XQALSET^^0^B72175488 "BLD",1000,"KRN",9.8,"NM",6,0) XQALSET1^^0^B4576629 "BLD",1000,"KRN",9.8,"NM",7,0) XQALSUR1^^0^B64901704 "BLD",1000,"KRN",9.8,"NM",8,0) XQALSURO^^0^B77946006 "BLD",1000,"KRN",9.8,"NM",9,0) XQARPRT2^^0^B75569961 "BLD",1000,"KRN",9.8,"NM","B","XQALDATA",1) "BLD",1000,"KRN",9.8,"NM","B","XQALDEL",2) "BLD",1000,"KRN",9.8,"NM","B","XQALERT1",3) "BLD",1000,"KRN",9.8,"NM","B","XQALMAKE",4) "BLD",1000,"KRN",9.8,"NM","B","XQALSET",5) "BLD",1000,"KRN",9.8,"NM","B","XQALSET1",6) "BLD",1000,"KRN",9.8,"NM","B","XQALSUR1",7) "BLD",1000,"KRN",9.8,"NM","B","XQALSURO",8) "BLD",1000,"KRN",9.8,"NM","B","XQARPRT2",9) "BLD",1000,"KRN",19,0) 19 "BLD",1000,"KRN",19.1,0) 19.1 "BLD",1000,"KRN",101,0) 101 "BLD",1000,"KRN",409.61,0) 409.61 "BLD",1000,"KRN",771,0) 771 "BLD",1000,"KRN",779.2,0) 779.2 "BLD",1000,"KRN",870,0) 870 "BLD",1000,"KRN",8989.51,0) 8989.51 "BLD",1000,"KRN",8989.52,0) 8989.52 "BLD",1000,"KRN",8994,0) 8994 "BLD",1000,"KRN","B",.4,.4) "BLD",1000,"KRN","B",.401,.401) "BLD",1000,"KRN","B",.402,.402) "BLD",1000,"KRN","B",.403,.403) "BLD",1000,"KRN","B",.5,.5) "BLD",1000,"KRN","B",.84,.84) "BLD",1000,"KRN","B",3.6,3.6) "BLD",1000,"KRN","B",3.8,3.8) "BLD",1000,"KRN","B",9.2,9.2) "BLD",1000,"KRN","B",9.8,9.8) "BLD",1000,"KRN","B",19,19) "BLD",1000,"KRN","B",19.1,19.1) "BLD",1000,"KRN","B",101,101) "BLD",1000,"KRN","B",409.61,409.61) "BLD",1000,"KRN","B",771,771) "BLD",1000,"KRN","B",779.2,779.2) "BLD",1000,"KRN","B",870,870) "BLD",1000,"KRN","B",8989.51,8989.51) "BLD",1000,"KRN","B",8989.52,8989.52) "BLD",1000,"KRN","B",8994,8994) "BLD",1000,"QDEF") ^^^^NO^^^^NO^^NO "BLD",1000,"QUES",0) ^9.62^^ "BLD",1000,"REQB",0) ^9.611^^ "MBREQ") 0 "PKG",3,-1) 1^1 "PKG",3,0) KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^ "PKG",3,20,0) ^9.402P^^0 "PKG",3,22,0) ^9.49I^1^1 "PKG",3,22,1,0) 8.0^3051215^2970507^.5 "PKG",3,22,1,"PAH",1,0) 443^3080317 "PKG",3,22,1,"PAH",1,1,0) ^^1^1^3080317 "PKG",3,22,1,"PAH",1,1,1,0) See the description on the patch module on FORUM. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 9 "RTN","XQALDATA") 0^1^B8047519^B6975610 "RTN","XQALDATA",1,0) XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;4/9/07 13:39 "RTN","XQALDATA",2,0) ;;8.0;KERNEL;**207,285,443**;Jul 10, 1995;Build 4 "RTN","XQALDATA",3,0) Q "RTN","XQALDATA",4,0) GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; "RTN","XQALDATA",5,0) N XREF,XVAL,X,X2,X3,I,NCNT ; P443 "RTN","XQALDATA",6,0) S:$G(XQAUSER)'>0 XQAUSER=DUZ "RTN","XQALDATA",7,0) S:$G(FRSTDATE)'>0 FRSTDATE=0 "RTN","XQALDATA",8,0) S:$G(LASTDATE)'>0 LASTDATE=0 "RTN","XQALDATA",9,0) S NCNT=0 K @ROOT "RTN","XQALDATA",10,0) I FRSTDATE=0 D Q "RTN","XQALDATA",11,0) . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0 S X=^(I,0),X3=$G(^(3)),X2=$G(^(2)) D "RTN","XQALDATA",12,0) . . S NCNT=NCNT+1 "RTN","XQALDATA",13,0) . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X,U,7,8)="^ ":"I ",1:" ")_$P(X,U,3)_U_$P(X,U,2)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443 "RTN","XQALDATA",14,0) . S @ROOT=NCNT "RTN","XQALDATA",15,0) S XREF="R" "RTN","XQALDATA",16,0) S XVAL=XQAUSER "RTN","XQALDATA",17,0) D CHKTRAIL "RTN","XQALDATA",18,0) Q "RTN","XQALDATA",19,0) GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ; "RTN","XQALDATA",20,0) N XREF,XVAL,NCNT "RTN","XQALDATA",21,0) S NCNT=0 K @ROOT "RTN","XQALDATA",22,0) I $G(PATIENT)'>0 S @ROOT=0 Q "RTN","XQALDATA",23,0) S XREF="C" "RTN","XQALDATA",24,0) S XVAL=PATIENT "RTN","XQALDATA",25,0) D CHKTRAIL "RTN","XQALDATA",26,0) Q "RTN","XQALDATA",27,0) CHKTRAIL ; "RTN","XQALDATA",28,0) N XQ1,X,X1,X2,X3 "RTN","XQALDATA",29,0) ; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL -- from GETPAT or GETUSER "RTN","XQALDATA",30,0) F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0 D "RTN","XQALDATA",31,0) . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X="" "RTN","XQALDATA",32,0) . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q "RTN","XQALDATA",33,0) . I FRSTDATE>0,$P(X,U,2)0,LASTDATE>0,$P(X,U,2)>LASTDATE Q "RTN","XQALDATA",35,0) . S NCNT=NCNT+1 "RTN","XQALDATA",36,0) . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443 "RTN","XQALDATA",37,0) S @ROOT=NCNT "RTN","XQALDATA",38,0) Q "RTN","XQALDATA",39,0) GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; "RTN","XQALDATA",40,0) N NCNT,KEY "RTN","XQALDATA",41,0) S:$G(XQAUSER)'>0 XQAUSER=DUZ "RTN","XQALDATA",42,0) S:$G(FRSTDATE)'>0 FRSTDATE=0 "RTN","XQALDATA",43,0) S:$G(LASTDATE)'>0 LASTDATE=0 "RTN","XQALDATA",44,0) S NCNT=0 K @ROOT "RTN","XQALDATA",45,0) I FRSTDATE=0 D Q "RTN","XQALDATA",46,0) . N X,X2,X3,X4,I S I="" F S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0 S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) D "RTN","XQALDATA",47,0) . . I $P(X,U,4)'="" S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; MARK SEEN "RTN","XQALDATA",48,0) . . S NCNT=NCNT+1 "RTN","XQALDATA",49,0) . . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X,U,7,8)="^ ":"I ",1:"R "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2) "RTN","XQALDATA",50,0) . . I X2'="" D "RTN","XQALDATA",51,0) . . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_" Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2) "RTN","XQALDATA",52,0) . . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2) "RTN","XQALDATA",53,0) . . . Q "RTN","XQALDATA",54,0) . S @ROOT=NCNT "RTN","XQALDATA",55,0) . Q "RTN","XQALDATA",56,0) Q "RTN","XQALDEL") 0^2^B55829845^B55765502 "RTN","XQALDEL",1,0) XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;4/9/07 15:13 "RTN","XQALDEL",2,0) ;;8.0;KERNEL;**6,24,65,114,174,285,443**;Jul 10, 1995;Build 4 "RTN","XQALDEL",3,0) ;; "RTN","XQALDEL",4,0) Q "RTN","XQALDEL",5,0) ; "RTN","XQALDEL",6,0) DELETE ; "RTN","XQALDEL",7,0) N XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1 "RTN","XQALDEL",8,0) Q:'$D(XQAID) Q:XQAID="" S:'$D(XQAKILL) XQAKILL=0 S:$P(XQAID,";")="NO-ID" XQAKILL=1 "RTN","XQALDEL",9,0) S XQADAT=$$NOW^XLFDT() "RTN","XQALDEL",10,0) I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ "RTN","XQALDEL",11,0) S XQAFOUND=0 D "RTN","XQALDEL",12,0) . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID S XQAFOUND=1 Q "RTN","XQALDEL",13,0) S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT "RTN","XQALDEL",14,0) K XQXX,XQXY "RTN","XQALDEL",15,0) I '$D(^XTV(8992,"AXQA",XQAID,XQAUSER)) D KILLOC "RTN","XQALDEL",16,0) F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL "RTN","XQALDEL",17,0) . I XQAKILL S XQX=XQAUSER ; Make sure XQAKILL gets only XQAUSER "RTN","XQALDEL",18,0) . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,XQK)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) S XQAID1=XQAID D:$D(^XTV(8992,XQX,"XQA",XQK,0)) DELA S XQAID=XQAID1 "RTN","XQALDEL",19,0) K XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL "RTN","XQALDEL",20,0) Q "RTN","XQALDEL",21,0) ; "RTN","XQALDEL",22,0) DELETEA ; "RTN","XQALDEL",23,0) N XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ "RTN","XQALDEL",24,0) Q:'$D(XQAID) Q:XQAID="" S XQA1=$P(XQAID,";") "RTN","XQALDEL",25,0) S XQADAT=$$NOW^XLFDT() "RTN","XQALDEL",26,0) I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ "RTN","XQALDEL",27,0) S:'$D(XQAKILL) XQAKILL=0 G:$P(XQAID,";")="NO-ID" DELETE "RTN","XQALDEL",28,0) S XQAFOUND=0 D "RTN","XQALDEL",29,0) . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P($G(^(XQK,0)),U,2)=XQAID S XQAFOUND=1 Q "RTN","XQALDEL",30,0) S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT "RTN","XQALDEL",31,0) I '$D(^XTV(8992,"AXQAN",XQA1,XQAUSER)) D KILLOC "RTN","XQALDEL",32,0) I $P(XQAID,",",2)'=""!($P(XQAID,";",2)="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQAN",XQA1,XQX)) Q:XQX'>0 D Q:XQAKILL "RTN","XQALDEL",33,0) . I XQAKILL S XQX=XQAUSER "RTN","XQALDEL",34,0) . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQAN",XQA1,XQX,XQK)) Q:XQK'>0 K ^(XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA "RTN","XQALDEL",35,0) I $P(XQAID,",",2)=""&($P(XQAID,";",2)'="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL "RTN","XQALDEL",36,0) . I XQAKILL S XQX=XQAUSER "RTN","XQALDEL",37,0) . S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,0)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA "RTN","XQALDEL",38,0) K XQAID,XQA1,XQX,XQK,XQAKILL "RTN","XQALDEL",39,0) Q "RTN","XQALDEL",40,0) DELA ; "RTN","XQALDEL",41,0) N XQDEL11 S XQAID=$P($G(^XTV(8992,XQX,"XQA",XQK,0)),U,2),XQDEL11=$P($G(^(0)),U) K ^XTV(8992,XQX,"XQA",XQK) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQX,XQK) "RTN","XQALDEL",42,0) D COUNT(-1,XQX) "RTN","XQALDEL",43,0) K:XQAID'="" ^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) K:XQDEL11'="" ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK) "RTN","XQALDEL",44,0) S XQXX=$S(XQAID'="":$O(^XTV(8992.1,"B",XQAID,0)),1:0) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQX,0)) I XQXY>0,$P(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0 S $P(^(0),U,5)=XQADAT I $G(XQAUSERD) S $P(^(0),U,9)=DUZ "RTN","XQALDEL",45,0) K XQXX,XQXY "RTN","XQALDEL",46,0) Q "RTN","XQALDEL",47,0) ; "RTN","XQALDEL",48,0) COUNT(%1,%2) ;Change the count on the zero node, (amount, user) "RTN","XQALDEL",49,0) Q:$G(%2)'>0 "RTN","XQALDEL",50,0) L +^XTV(8992,%2):10 "RTN","XQALDEL",51,0) I %1 S %=$P($G(^XTV(8992,%2,"XQA",0)),U,4)+%1 S:%'<0 $P(^(0),U,4)=% "RTN","XQALDEL",52,0) I '%1 D "RTN","XQALDEL",53,0) . N % S %1=0,%=0 F S %=$O(^XTV(8992,%2,"XQA",%)) Q:%'>0 S %1=%1+1 "RTN","XQALDEL",54,0) . S $P(^XTV(8992,%2,"XQA",0),U,4)=%1 "RTN","XQALDEL",55,0) L -^XTV(8992,%2) "RTN","XQALDEL",56,0) Q "RTN","XQALDEL",57,0) KILLOC ; "RTN","XQALDEL",58,0) N XQX,XQK "RTN","XQALDEL",59,0) S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID D "RTN","XQALDEL",60,0) . N XQAID D DELA "RTN","XQALDEL",61,0) Q "RTN","XQALDEL",62,0) ; "RTN","XQALDEL",63,0) OLDDEL ; "RTN","XQALDEL",64,0) N XQADAT,X2,XQDAT,XQDEL1 "RTN","XQALDEL",65,0) S XQADAT=$$NOW^XLFDT() "RTN","XQALDEL",66,0) S X2=-15 I $G(ZTQPARAM)>0 S X2=-ZTQPARAM "RTN","XQALDEL",67,0) S XQDAT=$$FMADD^XLFDT(DT,X2) "RTN","XQALDEL",68,0) ;Loop thru users (XQDEL1) levels "RTN","XQALDEL",69,0) F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992,XQDEL1)) Q:XQDEL1'>0 D OLDDEL1 "RTN","XQALDEL",70,0) D KILLARCH "RTN","XQALDEL",71,0) K X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT "RTN","XQALDEL",72,0) Q "RTN","XQALDEL",73,0) OLDDEL1 ;Loop thru the Alert (XQDEL2) level "RTN","XQALDEL",74,0) L +^XTV(8992,XQDEL1):10 "RTN","XQALDEL",75,0) N XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA "RTN","XQALDEL",76,0) S XQAGLOB=$NA(^XTV(8992,XQDEL1,"XQA")),XQAUSER=XQDEL1 "RTN","XQALDEL",77,0) F XQDEL2=0:0 S XQDEL2=$O(@XQAGLOB@(XQDEL2)) Q:XQDEL2'>0 S XQAZERO=^(XQDEL2,0) D "RTN","XQALDEL",78,0) . ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174 "RTN","XQALDEL",79,0) . I $P(XQAZERO,U,15)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,15))\1=DT D Q:$D(KILLOLD) ; changed '>DT to =DT so only send once without killing "RTN","XQALDEL",80,0) . . N XQA D GETBKUP(.XQA,XQDEL1) "RTN","XQALDEL",81,0) . . I $D(XQA) S XQALTYPE="BACKUP REVIEWER" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 "RTN","XQALDEL",82,0) . . Q ; End of Backup Reviewer Code -- P174 "RTN","XQALDEL",83,0) . I $P(XQAZERO,U,13)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,13))\1=DT D Q:$D(KILLOLD) ; P174 "RTN","XQALDEL",84,0) . . N XQA,I F I=0:0 S I=$O(^XMB(3.7,XQAUSER,9,I)) Q:I'>0 S XQAV=+^(I,0),XQA(XQAV)=XQAV "RTN","XQALDEL",85,0) . . I $D(XQA) S XQALTYPE="EMAIL SURROGATE" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 "RTN","XQALDEL",86,0) . . Q "RTN","XQALDEL",87,0) . I $P(XQAZERO,U,14)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,14))\1=DT D Q:$D(KILLOLD) ; P174 "RTN","XQALDEL",88,0) . . N XQA,I S I=$P($G(^VA(200,XQAUSER,5)),U) I I>0 S I=$P($G(^DIC(49,+I,0)),U,3) I I>0,$D(^VA(200,+I,0)) S XQA(+I)=+I "RTN","XQALDEL",89,0) . . I $D(XQA) S XQALTYPE="CHIEF/SUPERVISOR" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 "RTN","XQALDEL",90,0) . . Q "RTN","XQALDEL",91,0) . I XQDEL2'>XQDAT D OLDDEL2 "RTN","XQALDEL",92,0) . Q "RTN","XQALDEL",93,0) K:$O(^XTV(8992,XQDEL1,"XQA",0))="" ^XTV(8992,XQDEL1,"XQA") "RTN","XQALDEL",94,0) L -^XTV(8992,XQDEL1) "RTN","XQALDEL",95,0) Q "RTN","XQALDEL",96,0) ; "RTN","XQALDEL",97,0) OLDDEL2 ; "RTN","XQALDEL",98,0) N XQA,XQXX,XQXY "RTN","XQALDEL",99,0) S XQA=$P(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2) K ^XTV(8992,XQDEL1,"XQA",XQDEL2) K:XQA'="" ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$P(XQA,";"),XQDEL1) "RTN","XQALDEL",100,0) D COUNT(-1,XQDEL1) "RTN","XQALDEL",101,0) I XQA'="" S XQXX=$O(^XTV(8992.1,"B",XQA,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQDEL1,0)) I XQXY>0 S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT "RTN","XQALDEL",102,0) Q "RTN","XQALDEL",103,0) ; "RTN","XQALDEL",104,0) KILLARCH ; "RTN","XQALDEL",105,0) ; Q ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285 JLI 040624 "RTN","XQALDEL",106,0) N DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK "RTN","XQALDEL",107,0) S XQDAT=$$FMADD^XLFDT(DT,-30) "RTN","XQALDEL",108,0) F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0 D "RTN","XQALDEL",109,0) . S X1=$P($G(^XTV(8992.1,XQDEL1,0)),U,2),X2=$P($G(^(0)),U,8) "RTN","XQALDEL",110,0) . S DA=XQDEL1 I X2="",X1>XQDAT Q "RTN","XQALDEL",111,0) . I X2>0,DT0 S XQAUSER=+Y "RTN","XQALDEL",120,0) S XQALDELE=1 "RTN","XQALDEL",121,0) K XQX1 "RTN","XQALDEL",122,0) D DOIT^XQALERT1 "RTN","XQALDEL",123,0) K XQALDELE S XQAUSERD=1 "RTN","XQALDEL",124,0) I $D(XQX1),XQX1>0 D "RTN","XQALDEL",125,0) . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) "RTN","XQALDEL",126,0) . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQAKILL=1 "RTN","XQALDEL",127,0) . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) "RTN","XQALDEL",128,0) . . I XQAID'="" D DELETE "RTN","XQALDEL",129,0) . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) "RTN","XQALDEL",130,0) K XQAUSER,XQX1 "RTN","XQALDEL",131,0) Q "RTN","XQALDEL",132,0) ; "RTN","XQALDEL",133,0) GETBKUP(XQA,XQAUSER) ; JLI 030129 - REMOVED TO SEPARATE METHOD "RTN","XQALDEL",134,0) N I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST "RTN","XQALDEL",135,0) S XQPARAM="XQAL BACKUP REVIEWER" "RTN","XQALDEL",136,0) D GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=200 ; USER "RTN","XQALDEL",137,0) I '($D(XQLIST)>1) S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 D GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=49 ; SERVICE "RTN","XQALDEL",138,0) I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4 ; DIVISION "RTN","XQALDEL",139,0) I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4.2 ; SYSTEM "RTN","XQALDEL",140,0) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=$P(XQLIST(I),U,2),XQA(XQAV)=XQAV "RTN","XQALDEL",141,0) ; Removed Teams per Curtis Anderson with CPRS "RTN","XQALDEL",142,0) ;I '$D(XQA) D ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS "RTN","XQALDEL",143,0) ;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION "RTN","XQALDEL",144,0) ;. S I=0 F S I=$O(XQORY(I)) Q:I'>0 K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D "RTN","XQALDEL",145,0) ;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0 S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV "RTN","XQALDEL",146,0) ;. . Q` "RTN","XQALDEL",147,0) ;. Q "RTN","XQALDEL",148,0) ;I '$D(XQLIST) D ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM) "RTN","XQALDEL",149,0) ;. S XQENTITY="SYS" "RTN","XQALDEL",150,0) ;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION "RTN","XQALDEL",151,0) ;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION "RTN","XQALDEL",152,0) ;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV "RTN","XQALDEL",153,0) ;. Q "RTN","XQALDEL",154,0) ;I '$D(XQA) D ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP "RTN","XQALDEL",155,0) ;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 "RTN","XQALDEL",156,0) ;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT "RTN","XQALDEL",157,0) ;. F I=0:0 S I=$O(XQA(I)) Q:I'>0 S XQA(I)=I "RTN","XQALDEL",158,0) ;. Q "RTN","XQALDEL",159,0) Q "RTN","XQALDEL",160,0) ; "RTN","XQALDEL",161,0) DIVENTIT(XQAUSER) ; "RTN","XQALDEL",162,0) N ENTITY,NCNT,DIVNAM,I "RTN","XQALDEL",163,0) S ENTITY="" I DUZ=XQAUSER S ENTITY="DIV.`"_DUZ(2) "RTN","XQALDEL",164,0) I ENTITY="" D "RTN","XQALDEL",165,0) . K NCNT,DIVNAM S NCNT=0 F I=0:0 S I=$O(^VA(200,XQAUSER,2,I)) Q:I'>0 S NCNT=NCNT+1,DIVNAM(NCNT)=+^(I,0) I $P(^(0),U,2) S DIVNAM=+^(0) "RTN","XQALDEL",166,0) . I NCNT'>0 Q "RTN","XQALDEL",167,0) . I NCNT=1 S ENTITY="DIV.`"_DIVNAM(1) Q "RTN","XQALDEL",168,0) . I $D(DIVNAM)#2 S ENTITY="DIV.`"_DIVNAM Q "RTN","XQALDEL",169,0) . F I=1:1:NCNT S ENTITY="DIV.`"_DIVNAM(I)_$S(ENTITY'="":U,1:"")_ENTITY "RTN","XQALDEL",170,0) I ENTITY="" S ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I") "RTN","XQALDEL",171,0) Q ENTITY "RTN","XQALDEL",172,0) ; "RTN","XQALDEL",173,0) BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE "RTN","XQALDEL",174,0) G BKUPREVW^XQALBUTL "RTN","XQALDEL",175,0) ; "RTN","XQALERT1") 0^3^B78786817^B77322571 "RTN","XQALERT1",1,0) XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;4/9/07 14:54 "RTN","XQALERT1",2,0) ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366,443**;Jul 10, 1995;Build 4 "RTN","XQALERT1",3,0) ;; "RTN","XQALERT1",4,0) Q "RTN","XQALERT1",5,0) ; "RTN","XQALERT1",6,0) DOIT I $D(XQX1),XQX1'>0 K XQX1 "RTN","XQALERT1",7,0) I $D(XQAID) D I '$D(XQAID) G EXIT "RTN","XQALERT1",8,0) . N XQACHOIC,REASK S REASK=0 "RTN","XQALERT1",9,0) . I '$D(XQX1),$O(^XTV(8992,XQAUSER,"XQA",+$O(^XTV(8992,XQAUSER,"XQA",0))))'>0,$G(XQAROUX)="^ " S XQAROU="" "RTN","XQALERT1",10,0) AGAIN . S XQACHOIC="Y:YES;N:NO;C:CONTINUE;",XQAQ("?")="Enter Y (or C) to continue, N to exit alert processing" "RTN","XQALERT1",11,0) . S XQACHOIC=$G(XQACHOIC)_"F:FORWARD ALERT;R:RENEW(MAKE NEW AGAIN);" S XQAQ("?",1)="Enter F to forward this alert to someone else",XQAQ("?",2)="Enter R to Renew (Make New) this alert" "RTN","XQALERT1",12,0) . D I REASK=1 G AGAIN "RTN","XQALERT1",13,0) . . S REASK=0 W !! K DIR S DIR(0)="SA^"_XQACHOIC,DIR("A")=$S(XQACHOIC["F:":"Continue (Y/N) or F(orward) or R(enew) ",1:"Continue Processing (Y/N) "),DIR("B")="YES" M DIR("?")=XQAQ("?") D ^DIR K DIR "RTN","XQALERT1",14,0) . . I $D(DUOUT)!$D(DIRUT) S Y="N" K DUOUT,DIRUT "RTN","XQALERT1",15,0) . . I Y="N" D:$D(XQAKILL) DELETEA^XQALERT K XQAID "RTN","XQALERT1",16,0) . . I Y="R" S REASK=REASK+1 K XQAKILL I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE "RTN","XQALERT1",17,0) . . I Y="F" D:'$D(^XTV(8992,"AXQA",XQAID,DUZ)) RESTORE D FRWRDONE S REASK=REASK+1 "RTN","XQALERT1",18,0) . . Q "RTN","XQALERT1",19,0) . Q "RTN","XQALERT1",20,0) I $D(XQAKILL) D DELETEA^XQALERT "RTN","XQALERT1",21,0) S XQAREV=1,XQXOUT=0,XQK=0,XQACNT=0 K XQADATA,XQAID,XQAROU,XQAKILL,XQAROUX "RTN","XQALERT1",22,0) I '$D(XQX1) S XQX1=0 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2") I $O(^XTV(8992,XQAUSER,"XQA",0))'>0 K XQX1 D:'$G(^TMP("XQALERT1",$J,"NOTFIRST")) CHKSURO G:$O(^XTV(8992,XQAUSER,"XQA",0))'>0 EXIT S XQX1=0 ; P366 "RTN","XQALERT1",23,0) I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER) ; P366 "RTN","XQALERT1",24,0) S ^TMP("XQALERT1",$J,"NOTFIRST")=1 ; Added 2/2/99 jli to clear flag for initial entry "RTN","XQALERT1",25,0) ;Sort and remove display only "RTN","XQALERT1",26,0) I 'XQX1 W !!! D "RTN","XQALERT1",27,0) . D SORT "RTN","XQALERT1",28,0) ; Now display them. "RTN","XQALERT1",29,0) SUBLOOP W @IOF "RTN","XQALERT1",30,0) N XQZ1,XQZ "RTN","XQALERT1",31,0) S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3),XQZ4=^(4) D I XQX'="" D DOIT1 "RTN","XQALERT1",32,0) . I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI)) "RTN","XQALERT1",33,0) . Q "RTN","XQALERT1",34,0) S:'$D(XQXOUT) XQXOUT=0 G:XQXOUT EXIT G:XQK'>0&'XQX1 EXIT I 'XQX1 D ASK G:XQXOUT EXIT "RTN","XQALERT1",35,0) G:+XQX1=0 EXIT I XQX1<0 S XQX1=0 G DOIT "RTN","XQALERT1",36,0) I $D(XQALDELE)!$D(XQALFWD) Q "RTN","XQALERT1",37,0) ;D WAIT(+XQX1) G:XQXOUT EXIT "RTN","XQALERT1",38,0) G:XQXOUT EXIT "RTN","XQALERT1",39,0) G EN^XQALDOIT "RTN","XQALERT1",40,0) ; "RTN","XQALERT1",41,0) RESTORE ; Restore a deleted message for use "RTN","XQALERT1",42,0) N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU,X4,LONG "RTN","XQALERT1",43,0) S XTVGLOB=$NA(^XTV(8992,DUZ,"XQA")) "RTN","XQALERT1",44,0) S ADUZ=$O(^XTV(8992,"AXQA",XQAID,0)) I ADUZ>0 S TIME=$O(^(ADUZ,0)) D I 1 "RTN","XQALERT1",45,0) . M @XTVGLOB@(TIME)=^XTV(8992,ADUZ,"XQA",TIME) K @XTVGLOB@(TIME,2) ; copy alert, kill comment if any "RTN","XQALERT1",46,0) E S ALERTREF=$O(^XTV(8992.1,"B",XQAID,0)) Q:ALERTREF'>0 D ; otherwise rebuild from alert tracking file if possible "RTN","XQALERT1",47,0) . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2)),X4=$O(^(4,0)) "RTN","XQALERT1",48,0) . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4),LONG=(X4>0) "RTN","XQALERT1",49,0) . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",LONG:"L",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ") "RTN","XQALERT1",50,0) . S @XTVGLOB@(TIME,0)=X I $G(X2)'="" S ^(1)=X2 "RTN","XQALERT1",51,0) S ^XTV(8992,"AXQA",XQAID,DUZ,TIME)="",^XTV(8992,"AXQAN",$E($P(XQAID,";"),1,30),DUZ,TIME)="" "RTN","XQALERT1",52,0) Q "RTN","XQALERT1",53,0) ; "RTN","XQALERT1",54,0) EXIT ; "RTN","XQALERT1",55,0) I $G(XQALAST)="I",$G(DUZ("AUTO")) D WAIT2 "RTN","XQALERT1",56,0) I $D(XQALDELE)!$D(XQALFWD) Q "RTN","XQALERT1",57,0) K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2"),XQI,XQX,XQJ,XQK,XQX1,XQX2,XQXOUT,XQ1,XQII,XQACNT,XQA1,XQAREV,%ZIS,XQAROU,XQALAST,XQAROUX,XQON,XQOFF,XQ1ON,XQ1OFF,XQOUT,XQAQ "RTN","XQALERT1",58,0) K ^TMP("XQALERT1",$J) "RTN","XQALERT1",59,0) Q "RTN","XQALERT1",60,0) ; "RTN","XQALERT1",61,0) ; CHKSURO added 2/2/99 to give user opportunity to add/remove surrogate if no alerts present "RTN","XQALERT1",62,0) CHKSURO ; If user selects process alerts with no alerts present, give him/her the opportunity to add or delete a surrogate "RTN","XQALERT1",63,0) ; P366 - list currently established surrogates if any "RTN","XQALERT1",64,0) I '$G(^TMP("XQALERT1",$J,"NOTFIRST")) W !!,"You have no alerts for processing.",! "RTN","XQALERT1",65,0) D SURROGAT^XQALSURO ; XU*8*17 "RTN","XQALERT1",66,0) Q "RTN","XQALERT1",67,0) ; "RTN","XQALERT1",68,0) DOIT1 ; "RTN","XQALERT1",69,0) I XQK=0 S XQALINFO=0 I '$D(XQALFWD) W @IOF "RTN","XQALERT1",70,0) S XQON="$C(0)",XQOFF="$C(0)" S XQOUT=$P(XQX,U,3) I ($$UP^XLFSTR(XQOUT)["CRITICAL")!($$UP^XLFSTR(XQOUT)["ABNORMAL IMA") D:'$D(XQ1ON) SETREV^XQALERT S XQON=XQ1ON,XQOFF=XQ1OFF ; P285 "RTN","XQALERT1",71,0) S XQK=XQK+1 W !,$J(XQK,2),".",$S(XQZ4:"L",$P(XQX,U,8)=" ":"I",1:" ")," ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'="" ; P285 "RTN","XQALERT1",72,0) . W !?8,"Forwarded by: ",$P(^VA(200,+XQZ1,0),U)," Generated: ",$$DAT8^XQALERT(+$P($P(XQX,U,2),";",3),1) "RTN","XQALERT1",73,0) . I $P(XQZ1,U,3)'="" W !?8,$P(XQZ1,U,3) "RTN","XQALERT1",74,0) S ^TMP("XQ",$J,"XQA1",XQK)=XQX,^(XQK,1)=XQII,^(2)=XQZ,^(3)=XQZ1 "RTN","XQALERT1",75,0) I ($Y+6)>IOSL N XQKVALUE S XQKVALUE=XQK D ASK0(XQI) S:'$D(XQK) XQK=XQKVALUE Q:XQX1!(XQXOUT) W @IOF "RTN","XQALERT1",76,0) Q "RTN","XQALERT1",77,0) ; "RTN","XQALERT1",78,0) ASK0(XQI) ;Stack XQI "RTN","XQALERT1",79,0) ASK ; "RTN","XQALERT1",80,0) N XQALNEWF K XQALAST "RTN","XQALERT1",81,0) ;I '$D(XQALDELE)&'$D(XQALFWD) S XQALNEWF=$P(^XTV(8992,XQAUSER,0),U,5) I XQALNEWF<20 D "RTN","XQALERT1",82,0) ;. N XQALFDA "RTN","XQALERT1",83,0) ;. S XQALNEWF=XQALNEWF+1,XQALFDA=(8992,(XQAUSER_","),.05)=XQALNEWF D FILE^DIE("","XQALFDA") "RTN","XQALERT1",84,0) ;. W !,"NEW OPTIONS: S-to add/remove SURROGATE and D-to selectively Delete SOME alerts" "RTN","XQALERT1",85,0) S XQ1=0,XQXOUT=0 W !?10,"Select from 1 to ",XQK W:$D(XQALDELE) " to DELETE" W:$D(XQALFWD) " to FORWARD" "RTN","XQALERT1",86,0) W !?10,"or enter ?, A, " W:'$D(XQALDELE)&'$D(XQALFWD)&(XQALINFO>0) "I, D, " W:'$D(XQALDELE)&'$D(XQALFWD) "F, S, P, M, R, " W "or ^ to exit" I XQI>0,$O(^XTV(8992,XQAUSER,"XQA",XQI))>0 W !?10,"or RETURN to continue" S XQ1=1 "RTN","XQALERT1",87,0) R ": ",XQII:DTIME S:'$T!(XQII[U)!(XQII=""&'XQ1) XQXOUT=1 Q:XQXOUT "RTN","XQALERT1",88,0) I '$D(XQALDELE)&'$D(XQALFWD),"PpMm"[$E(XQII_".") D MORP^XQALDOIT D:"Pp"[$E(XQII_".") PRINT^XQALDOIT D:"Mm"[$E(XQII_".") MAIL^XQALDOIT K ^TMP("XQ",$J,"XQA2") G ASK "RTN","XQALERT1",89,0) I XQII'="",XQII["?" D HELP G ASK "RTN","XQALERT1",90,0) I XQII=""&XQ1 Q "RTN","XQALERT1",91,0) I "IiAaFfRrSsDd"'[$E(XQII_"."),$L(XQII)>31,$E(XQII,1,32)?1N.N W !,$C(7)," ?? Invalid number entered",! G ASK "RTN","XQALERT1",92,0) I "IiAaFfRrSsDd"'[$E(XQII_"."),(XQII<1)!(XQII>XQK) W $C(7)," ??",! G ASK "RTN","XQALERT1",93,0) I '$D(XQALDELE)&'$D(XQALFWD),"Ff"[$E(XQII) D FWRD^XQALFWD S XQX1=-2 Q ; MODIFIED 7-6 "RTN","XQALERT1",94,0) I '$D(XQALDELE)&'$D(XQALFWD),"Ss"[$E(XQII) D CHKSURO S XQX1=-1 Q "RTN","XQALERT1",95,0) I '$D(XQALDELE)&'$D(XQALFWD),"Dd"[$E(XQII) D ASKDEL S XQX1=-2 Q ; MODIFIED 7-6 "RTN","XQALERT1",96,0) I '$D(XQALDELE),"Rr"[$E(XQII) S XQX1=-2 Q "RTN","XQALERT1",97,0) I "Aa"[$E(XQII) S X="1-"_XQACNT,DIR(0)="LV^1:"_XQACNT D ^DIR K DIR,XQX1 M XQX1=Y S XQII="" K Y ;Merge list from Y "RTN","XQALERT1",98,0) I XQII'="","Ii"[$E(XQII) S XQX1(0)="",XQX2=0,XQII="" F XQK=0:0 S XQK=$O(^TMP("XQ",$J,"XQA1",XQK)) S:XQK'>0 XQX1=XQX1(0) Q:XQK'>0 I $P(^(XQK),U,7,8)="^ " S XQX1(XQX2)=XQX1(XQX2)_XQK_"," S:$L(XQX1(XQX2))>240 XQX2=XQX2+1,XQX1(XQX2)="" "RTN","XQALERT1",99,0) I XQII="" Q "RTN","XQALERT1",100,0) S X=XQII,DIR(0)="LV^1:"_XQK D ^DIR I '$D(Y) W $C(7)," ??" D HELP G ASK ;Use of 'LV' is special "RTN","XQALERT1",101,0) K XQX1 M XQX1=Y K Y S Y=XQX1 ;Merge list from Y "RTN","XQALERT1",102,0) Q "RTN","XQALERT1",103,0) WAIT(IFN) ;Wait for user input if last alert is INFO and next isn't. "RTN","XQALERT1",104,0) N X,YY Q:$G(XQXOUT) "RTN","XQALERT1",105,0) S X=$G(^TMP("XQ",$J,"XQA1",IFN)),YY=$P(X,U,7,8),YY=$S(YY="^ ":"I",YY="^":"O",1:"R") "RTN","XQALERT1",106,0) I $G(XQALAST)="I","OR"[YY D WAIT2 "RTN","XQALERT1",107,0) I YY="I",$Y+4>IOSL D WAIT2 W @IOF "RTN","XQALERT1",108,0) S XQALAST=YY "RTN","XQALERT1",109,0) Q "RTN","XQALERT1",110,0) WAIT2 ;Wait for user input before continuing "RTN","XQALERT1",111,0) N DIR,Y,DIROUT,DIRUT S DIR(0)="E",DIR("?")="The next ALERT may cause the loss of info on the screen." "RTN","XQALERT1",112,0) D ^DIR S:$D(DIRUT) XQXOUT=1 "RTN","XQALERT1",113,0) Q "RTN","XQALERT1",114,0) ; "RTN","XQALERT1",115,0) HELP W !!,"YOU MAY ENTER:",!?3,$S(XQK>1:"One or more numbers",1:"A number")," in the range 1 to ",XQK," to select specific alert(s)" "RTN","XQALERT1",116,0) W !?6,"for "_$S($D(XQALDELE):"DELETION.",$D(XQALFWD):"FORWARDING",1:"processing.") W:XQK>1 " This may be a series of numbers, e.g., 2,3,6-9" "RTN","XQALERT1",117,0) W !?3,"A to "_$S($D(XQALDELE):"DELETE",$D(XQALFWD):"FORWARD",1:"process")," all of the pending alerts in the order shown." "RTN","XQALERT1",118,0) W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"I to process all of the INFORMATION ONLY alerts, if any, without further ado." "RTN","XQALERT1",119,0) W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"S to add or remove a surrogate to receive alerts for you" "RTN","XQALERT1",120,0) W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"F to forward one or more specific alerts. Forwarding may be as an ALERT",!,"to specific user(s) and/or mail group(s), or as a MAIL MESSAGE, or to a",!,"specific PRINTER." "RTN","XQALERT1",121,0) W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"D to delete specific alerts (some alerts may not be deleted)" "RTN","XQALERT1",122,0) W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"P to print a copy of the pending alerts on a printer" "RTN","XQALERT1",123,0) W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"M to receive a MailMan message containing a copy of these pending alerts" "RTN","XQALERT1",124,0) W:'$D(XQALDELE) !?3,"R to Redisplay the available alerts" "RTN","XQALERT1",125,0) W !?3,"^ to exit" "RTN","XQALERT1",126,0) I XQI W !?5,"or RETURN to see additional pending ALERTS" "RTN","XQALERT1",127,0) W !! "RTN","XQALERT1",128,0) Q "RTN","XQALERT1",129,0) ; "RTN","XQALERT1",130,0) SORT ;Sort and remove display only "RTN","XQALERT1",131,0) N XQZ,XQZ1,XQZ4,XQI,XQK,XQX,XQJ "RTN","XQALERT1",132,0) F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)),XQZ4=$O(^(4,0)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D "RTN","XQALERT1",133,0) . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1,^(4)=XQZ4 "RTN","XQALERT1",134,0) S XQK=0 F XQI=0:0 S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQK=XQK+1 M ^TMP("XQ",$J,"XQA1",XQK)=^TMP("XQ",$J,"XQA",XQI) "RTN","XQALERT1",135,0) Q "RTN","XQALERT1",136,0) ; "RTN","XQALERT1",137,0) ASKDEL ; "RTN","XQALERT1",138,0) N XQALDELE,XQX1COPY,XQAID,DA,XQAKILL,XQXOUT,XQAUSERD,XQALVALU "RTN","XQALERT1",139,0) S XQALDELE=1 "RTN","XQALERT1",140,0) K XQX1 "RTN","XQALERT1",141,0) D DOIT^XQALERT1 "RTN","XQALERT1",142,0) K XQALDELE S XQAUSERD=1 "RTN","XQALERT1",143,0) I $D(XQX1),XQX1>0 D "RTN","XQALERT1",144,0) . M XQX1COPY=XQX1 "RTN","XQALERT1",145,0) . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) "RTN","XQALERT1",146,0) . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQALVALU=^(DA),XQAKILL=1 "RTN","XQALERT1",147,0) . . I $P(XQALVALU,U,8)=" "!$P(XQALVALU,U,10) D "RTN","XQALERT1",148,0) . . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) "RTN","XQALERT1",149,0) . . . I XQAID'="" D DELETE^XQALDEL "RTN","XQALERT1",150,0) . . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) "RTN","XQALERT1",151,0) . K XQX1 M XQX1=XQX1COPY S XQAID=0 "RTN","XQALERT1",152,0) . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) "RTN","XQALERT1",153,0) . . I $D(^TMP("XQ",$J,"XQA1",DA)) W:'XQAID !!,"Unable to delete alerts which require action: ",DA W:XQAID ",",DA S XQAID=1 "RTN","XQALERT1",154,0) . I XQAID=1 K DIR S DIR(0)="E" D ^DIR K DIR "RTN","XQALERT1",155,0) K XQX1,XQAKILL "RTN","XQALERT1",156,0) Q "RTN","XQALERT1",157,0) ; "RTN","XQALERT1",158,0) FRWRDONE ; "RTN","XQALERT1",159,0) N XQX1,XQALFWDL S XQALFWDL(1)=XQAID "RTN","XQALERT1",160,0) N XQAID "RTN","XQALERT1",161,0) D FWDONE^XQALFWD "RTN","XQALERT1",162,0) Q "RTN","XQALMAKE") 0^4^B13487319^B12107074 "RTN","XQALMAKE",1,0) XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;4/9/07 14:03 "RTN","XQALMAKE",2,0) ;;8.0;KERNEL;**443**;Jul 10, 1995;Build 4 "RTN","XQALMAKE",3,0) ;; "RTN","XQALMAKE",4,0) ENTRY ; "RTN","XQALMAKE",5,0) W !!,"ALERT GENERATOR" "RTN","XQALMAKE",6,0) TEXT K XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR "RTN","XQALMAKE",7,0) R !!,"ON THE NEXT LINE ENTER THE TEXT TO BE DISPLAYED FOR THE ALERT ___",!,X:DTIME G:'$T!(X[U)!(X="") EXIT W !!,X S XQALX=X,DIR(0)="Y",DIR("A")="Is this text OK? ",DIR("B")="YES" D ^DIR K DIR G:'Y TEXT S XQAMSG=XQALX "RTN","XQALMAKE",8,0) D LOOP1 G:'$D(XQA) EXIT "RTN","XQALMAKE",9,0) ASKOPT S DIR(0)="Y",DIR("A")="Do you want to transfer control to an option when the alert is selected" D ^DIR K DIR I Y D GETOPT G:Y'="" SETIT G ASKOPT "RTN","XQALMAKE",10,0) ASKROU S DIR(0)="Y",DIR("A")="Do you want to transfer control to a routine when the alert is selected" D ^DIR K DIR G:'Y SETIT "RTN","XQALMAKE",11,0) R !,"Enter ROUTINE name or ENTRY^ROUTINE name: ",X:DTIME S:'$T X=U G:X=U EXIT G:X="" ASKROU S XQAROU=X S X=$S(X'[U:X,1:$P(X,U,2)) G:X="" ASKROU X ^%ZOSF("TEST") I 'Y W !,"Routine '",X,"' not present" G ASKROU "RTN","XQALMAKE",12,0) SETIT ; "RTN","XQALMAKE",13,0) I '$D(XQAROU),'$D(XQAOPT) S DIR(0)="Y",DIR("A")="Do you want to make a long text info only alert" D ^DIR K DIR I Y D LONGTEXT "RTN","XQALMAKE",14,0) W !!,"As currently entered, this alert will display the following text:",!!,XQAMSG "RTN","XQALMAKE",15,0) W !!,"The alert is currently to be delivered to:" S XQAX="" F I=1:1 S XQAX=$O(XQA(XQAX)) Q:XQAX="" S X=$S(XQAX>0:$P(^VA(200,XQAX,0),U),1:XQAX) W:(I#2) ! W:'(I#2) ?40 W X "RTN","XQALMAKE",16,0) W:$D(XQAROU) !!,"On selection of the alert, the user will run the routine ",XQAROU W:$D(XQAOPT) !!,"On selection of the alert, the user will be taken to the",!,"the option ",XQAOPT W !! "RTN","XQALMAKE",17,0) S DIR(0)="Y",DIR("A")="Is this alert what was intended",DIR("B")="YES" D ^DIR K DIR I 'Y G ENTRY "RTN","XQALMAKE",18,0) D SETUP^XQALERT "RTN","XQALMAKE",19,0) W !!?20,"ALERT IS NOW SET",!! "RTN","XQALMAKE",20,0) G ENTRY "RTN","XQALMAKE",21,0) ; "RTN","XQALMAKE",22,0) GETOPT ; "RTN","XQALMAKE",23,0) S DIC=19,DIC(0)="AEQM",DIC("A")="Indicate the desired OPTION: " D ^DIC K DIC S:Y'>0 Y="" S XQAOPT=$P(Y,U,2) "RTN","XQALMAKE",24,0) Q "RTN","XQALMAKE",25,0) ; "RTN","XQALMAKE",26,0) EXIT ; "RTN","XQALMAKE",27,0) K XQALDIC,XQALX,XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR,X,Y "RTN","XQALMAKE",28,0) Q "RTN","XQALMAKE",29,0) LOOP1 K XQA R !,"Enter a User name or G.mailgroup",!,"as recipient of the Alert: ",X:DTIME S:'$T!(X="") X=U I X'[U D SETONE G:Y'>0 LOOP1 "RTN","XQALMAKE",30,0) I X'[U F R !,"Enter another user or G.mailgroup: ",X:DTIME S:'$T X=U Q:X[U!(X="") D SETONE "RTN","XQALMAKE",31,0) K:X[U XQA Q "RTN","XQALMAKE",32,0) SETONE ; "RTN","XQALMAKE",33,0) S XQALDIC=$S("g.G."[$E(X,1,2):3.8,1:200),X=$S(XQALDIC=3.8:$E(X,3,$L(X)),1:X),DIC=XQALDIC,DIC(0)="EMQ" D ^DIC Q:Y'>0 S X=$S(XQALDIC=3.8:"G."_$P(Y,U,2),1:+Y),XQA(X)="" "RTN","XQALMAKE",34,0) Q "RTN","XQALMAKE",35,0) ; "RTN","XQALMAKE",36,0) LONGTEXT ; "RTN","XQALMAKE",37,0) W !,"Enter .EXIT to terminate input",! "RTN","XQALMAKE",38,0) S COUNT="" F R X:DTIME Q:X=".EXIT" S COUNT=COUNT+1,XQATEXT(COUNT)=X W ! "RTN","XQALMAKE",39,0) Q "RTN","XQALSET") 0^5^B72175488^B69325670 "RTN","XQALSET",1,0) XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;4/10/07 14:06 "RTN","XQALSET",2,0) ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285,443**;Jul 10, 1995;Build 4 "RTN","XQALSET",3,0) ;; "RTN","XQALSET",4,0) Q "RTN","XQALSET",5,0) ; Original entry point - throw away return value since no value expected "RTN","XQALSET",6,0) SETUP ; "RTN","XQALSET",7,0) N I S I=$$SETUP1() K XQALERR "RTN","XQALSET",8,0) Q "RTN","XQALSET",9,0) ; "RTN","XQALSET",10,0) SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID. "RTN","XQALSET",11,0) ; If not successful XQALERR is defined and contains reason for failure. "RTN","XQALSET",12,0) K XQALERR "RTN","XQALSET",13,0) I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0 "RTN","XQALSET",14,0) I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0 "RTN","XQALSET",15,0) N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE "RTN","XQALSET",16,0) S XQALTYPE="INITIAL RECIPIENT" "RTN","XQALSET",17,0) S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" " "RTN","XQALSET",18,0) NOW S XQX=$$NOW^XLFDT() "RTN","XQALSET",19,0) S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX "RTN","XQALSET",20,0) S XQAID=$$SETIEN(XQA1,XQX),XQADA="" "RTN","XQALSET",21,0) Q $$REENT() "RTN","XQALSET",22,0) ; "RTN","XQALSET",23,0) REENT() ; Entry for forwarding, etc. "RTN","XQALSET",24,0) N RETVAL S RETVAL=1 "RTN","XQALSET",25,0) K ^TMP("XQAGROUP",$J) ; P443 - clear location for storage of groups processed "RTN","XQALSET",26,0) N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT() "RTN","XQALSET",27,0) S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,80)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1 "RTN","XQALSET",28,0) S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE "RTN","XQALSET",29,0) S XQALIN=XQX_U_XQALIN1,XQJ=0 "RTN","XQALSET",30,0) K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA "RTN","XQALSET",31,0) LOOP1 S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1 "RTN","XQALSET",32,0) LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE "RTN","XQALSET",33,0) N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0 S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON "RTN","XQALSET",34,0) ; The following section of code was added to provide a generalized way to handle surrogates "RTN","XQALSET",35,0) F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ="" D "RTN","XQALSET",36,0) . N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D ; Modified to get final surrogate if a sequence of them "RTN","XQALSET",37,0) . . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry "RTN","XQALSET",38,0) . . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original "RTN","XQALSET",39,0) . . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to "RTN","XQALSET",40,0) . . S XQALIST(XQJ,"z TO_SURO",X)="" "RTN","XQALSET",41,0) . . Q "RTN","XQALSET",42,0) . Q "RTN","XQALSET",43,0) ; "RTN","XQALSET",44,0) S XQJ=0 "RTN","XQALSET",45,0) LOOP ; "RTN","XQALSET",46,0) S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP "RTN","XQALSET",47,0) ; "RTN","XQALSET",48,0) I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on "RTN","XQALSET",49,0) ; "RTN","XQALSET",50,0) I '$D(^XTV(8992,XQJ,0)) D I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ "RTN","XQALSET",51,0) . N FDA,IENS "RTN","XQALSET",52,0) . F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111)) "RTN","XQALSET",53,0) . . K DIERR,^TMP("DIERR",$J) "RTN","XQALSET",54,0) . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ "RTN","XQALSET",55,0) . . S IENS(1)=XQJ "RTN","XQALSET",56,0) . . D UPDATE^DIE("S",FDA,"IENS") "RTN","XQALSET",57,0) . . Q "RTN","XQALSET",58,0) . Q "RTN","XQALSET",59,0) L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^" "RTN","XQALSET",60,0) REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP "RTN","XQALSET",61,0) S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1) "RTN","XQALSET",62,0) I $D(XQATEXT) S:($D(XQATEXT)#2) XQATEXT(.1)=XQATEXT D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") ; P443 PUT DATA IN XQATEXT INTO ARRAY "RTN","XQALSET",63,0) L -^XTV(8992,XQJ) "RTN","XQALSET",64,0) K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)="" "RTN","XQALSET",65,0) S XQNRECIP=XQNRECIP+1 "RTN","XQALSET",66,0) G LOOP "RTN","XQALSET",67,0) ; "RTN","XQALSET",68,0) WRAP ; "RTN","XQALSET",69,0) M XQALIST1=XQALIST "RTN","XQALSET",70,0) I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS" "RTN","XQALSET",71,0) E I XQNRECIP=0 D I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN "RTN","XQALSET",72,0) . N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0 D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0 S XQA(XQAA(XQJ))="" "RTN","XQALSET",73,0) . I $D(XQA) D CHEKACTV^XQALSET1(.XQA) "RTN","XQALSET",74,0) . I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO "RTN","XQALSET",75,0) . I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES "RTN","XQALSET",76,0) . I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH "RTN","XQALSET",77,0) . I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users "RTN","XQALSET",78,0) . Q "RTN","XQALSET",79,0) ; END OF JLI 030129 INSERTION P285 "RTN","XQALSET",80,0) ; moved recording of users in Alert Tracking file to here to include all of them 030220 "RTN","XQALSET",81,0) ; modified code to use FM calls instead of direct global references "RTN","XQALSET",82,0) I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users "RTN","XQALSET",83,0) ; "RTN","XQALSET",84,0) I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D L -^XTV(8992.1,XQADA) ; 030131 "RTN","XQALSET",85,0) . F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0 D "RTN","XQALSET",86,0) . . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL "RTN","XQALSET",87,0) . . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ) "RTN","XQALSET",88,0) . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1" "RTN","XQALSET",89,0) . . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT="" I $E(SUBSCRPT,1)'="z" D "RTN","XQALSET",90,0) . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D "RTN","XQALSET",91,0) . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) "RTN","XQALSET",92,0) . . . . Q "RTN","XQALSET",93,0) . . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM "RTN","XQALSET",94,0) . . . Q "RTN","XQALSET",95,0) . . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0)) "RTN","XQALSET",96,0) . . I $D(XQALIST1(XQJ,"z AS_SURO")) D "RTN","XQALSET",97,0) . . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y" "RTN","XQALSET",98,0) . . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0 S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM "RTN","XQALSET",99,0) . . . Q "RTN","XQALSET",100,0) . . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D ; FORWARDING "RTN","XQALSET",101,0) . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D "RTN","XQALSET",102,0) . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) "RTN","XQALSET",103,0) . . . . Q "RTN","XQALSET",104,0) . . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT "RTN","XQALSET",105,0) . . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER "RTN","XQALSET",106,0) . . . Q "RTN","XQALSET",107,0) . . N IENSTR D UPDATE^DIE("",FDA,"IENSTR") "RTN","XQALSET",108,0) . . Q "RTN","XQALSET",109,0) . Q "RTN","XQALSET",110,0) ; "RTN","XQALSET",111,0) I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID "RTN","XQALSET",112,0) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0) "RTN","XQALSET",113,0) K ^TMP("XQAGROUP",$J) ; P443 - clear global used to track processing of groups "RTN","XQALSET",114,0) K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT "RTN","XQALSET",115,0) Q RETVAL "RTN","XQALSET",116,0) ; "RTN","XQALSET",117,0) SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers "RTN","XQALSET",118,0) N XVAL "RTN","XQALSET",119,0) I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0 "RTN","XQALSET",120,0) Q 1 "RTN","XQALSET",121,0) ; "RTN","XQALSET",122,0) SETIEN(XQA1,XQI) ; determine unique XQAID value for alert "RTN","XQALSET",123,0) N XQAID "RTN","XQALSET",124,0) S:$G(XQA1)="" XQA1="NO-ID" F S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D L -^XTV(8992,"AXQA",XQAID) Q:XQI="" S XQI=XQI+.00000001 "RTN","XQALSET",125,0) . I $D(^XTV(8992,"AXQA",XQAID)) Q "RTN","XQALSET",126,0) . S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI="" "RTN","XQALSET",127,0) . Q "RTN","XQALSET",128,0) Q XQAID "RTN","XQALSET",129,0) ; "RTN","XQALSET",130,0) SETTRACK ; Setup entry in Alert Tracking file "RTN","XQALSET",131,0) ; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues "RTN","XQALSET",132,0) N FDA,IENS,XQA2,DIERR "RTN","XQALSET",133,0) S XQADA=0 "RTN","XQALSET",134,0) S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3) "RTN","XQALSET",135,0) F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",111)) "RTN","XQALSET",136,0) . K DIERR,^TMP("DIERR",$J) "RTN","XQALSET",137,0) . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA "RTN","XQALSET",138,0) . S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS") "RTN","XQALSET",139,0) . K @FDA "RTN","XQALSET",140,0) . Q "RTN","XQALSET",141,0) I $D(DIERR) Q ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q "RTN","XQALSET",142,0) Q:IENS(1)'>0 S (DA,XQADA)=IENS(1) "RTN","XQALSET",143,0) S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG "RTN","XQALSET",144,0) I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X "RTN","XQALSET",145,0) I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2) "RTN","XQALSET",146,0) I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1 "RTN","XQALSET",147,0) I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT "RTN","XQALSET",148,0) I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2) "RTN","XQALSET",149,0) I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG "RTN","XQALSET",150,0) I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA "RTN","XQALSET",151,0) I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID "RTN","XQALSET",152,0) I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN "RTN","XQALSET",153,0) D FILE^DIE("KS",FDA) "RTN","XQALSET",154,0) I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT") "RTN","XQALSET",155,0) Q "RTN","XQALSET",156,0) ; "RTN","XQALSET",157,0) CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate "RTN","XQALSET",158,0) Q $$CHEKUSER^XQALSET1(XQAUSER) "RTN","XQALSET",159,0) ; "RTN","XQALSET1") 0^6^B4576629^B2528410 "RTN","XQALSET1",1,0) XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;4/9/07 10:26 "RTN","XQALSET1",2,0) ;;8.0;KERNEL;**285,443**;Jul 10, 1995;Build 4 "RTN","XQALSET1",3,0) ;; "RTN","XQALSET1",4,0) Q "RTN","XQALSET1",5,0) GROUP ; "RTN","XQALSET1",6,0) N XQI,XQL,XQL1,XQL2,XQLIST "RTN","XQALSET1",7,0) S XQL=$E(XQJ,3,$L(XQJ)) ; P443 - changed from code that forced upper case "RTN","XQALSET1",8,0) I $D(^TMP("XQAGROUP",$J,XQL)) Q ; P443 group has already been processed - prevent cycling "RTN","XQALSET1",9,0) S ^TMP("XQAGROUP",$J,XQL)="" ; P443 mark that the group has been seen "RTN","XQALSET1",10,0) S XQI=$$FIND1^DIC(3.8,,"X",XQL) Q:XQI'>0 "RTN","XQALSET1",11,0) N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D "RTN","XQALSET1",12,0) . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 S XQA(^(XQI,.01))="" "RTN","XQALSET1",13,0) . Q "RTN","XQALSET1",14,0) K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D "RTN","XQALSET1",15,0) . N XQAGROUP M XQAGROUP=@XQLIST@("ID") ; P443 - store group list data locally so it is not over written by recursive call to LIST^DIC "RTN","XQALSET1",16,0) . N XQI F XQI=0:0 S XQI=$O(XQAGROUP(XQI)) Q:XQI'>0 N XQJ S XQJ="G."_XQAGROUP(XQI,.01) D GROUP ; P443 - change to reference XQAGROUP "RTN","XQALSET1",17,0) . Q "RTN","XQALSET1",18,0) K @XQLIST,XQLIST "RTN","XQALSET1",19,0) K XQA(XQJ) "RTN","XQALSET1",20,0) D CHEKACTV(.XQA) "RTN","XQALSET1",21,0) Q "RTN","XQALSET1",22,0) ; "RTN","XQALSET1",23,0) ; Check and remove any entries in array that don't have active surrogates and aren't active "RTN","XQALSET1",24,0) CHEKACTV(XQARRAY) ; "RTN","XQALSET1",25,0) N XQJ "RTN","XQALSET1",26,0) F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0 I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ) "RTN","XQALSET1",27,0) Q "RTN","XQALSET1",28,0) ; "RTN","XQALSET1",29,0) CHEKUSER(XQAUSER) ; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate "RTN","XQALSET1",30,0) N VALUE "RTN","XQALSET1",31,0) S VALUE=$$ACTVSURO^XQALSURO(XQAUSER) "RTN","XQALSET1",32,0) I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0 "RTN","XQALSET1",33,0) Q VALUE "RTN","XQALSET1",34,0) ; "RTN","XQALSUR1") 0^7^B64901704^B65103748 "RTN","XQALSUR1",1,0) XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;11/21/07 08:35 "RTN","XQALSUR1",2,0) ;;8.0;KERNEL;**366,443**;Jul 10, 1995;Build 4 "RTN","XQALSUR1",3,0) Q "RTN","XQALSUR1",4,0) ; "RTN","XQALSUR1",5,0) RETURN(XQAUSER) ; P366 - return alerts to the user "RTN","XQALSUR1",6,0) N XQAI,X0,XQASTRT,XQASURO,XQAEND "RTN","XQALSUR1",7,0) ; identify periods in the surrogate multiple that haven't been returned "RTN","XQALSUR1",8,0) F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D "RTN","XQALSUR1",9,0) . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) "RTN","XQALSUR1",10,0) . ; and clear the flag indicating we need to restore these alerts "RTN","XQALSUR1",11,0) . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") "RTN","XQALSUR1",12,0) . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) "RTN","XQALSUR1",13,0) . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) "RTN","XQALSUR1",14,0) . Q "RTN","XQALSUR1",15,0) Q "RTN","XQALSUR1",16,0) ; "RTN","XQALSUR1",17,0) PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them "RTN","XQALSUR1",18,0) N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP "RTN","XQALSUR1",19,0) S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") "RTN","XQALSUR1",20,0) F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D "RTN","XQALSUR1",21,0) . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 "RTN","XQALSUR1",22,0) . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) "RTN","XQALSUR1",23,0) . F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D "RTN","XQALSUR1",24,0) . . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate "RTN","XQALSUR1",25,0) . . Q "RTN","XQALSUR1",26,0) . I 'XNOSURO D "RTN","XQALSUR1",27,0) . . N XQA,XQACMNT,XQALTYPE "RTN","XQALSUR1",28,0) . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" "RTN","XQALSUR1",29,0) . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) "RTN","XQALSUR1",30,0) . . Q "RTN","XQALSUR1",31,0) . ; walk through each of those it was sent to as a surrogate for XQAUSER "RTN","XQALSUR1",32,0) . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D "RTN","XQALSUR1",33,0) . . ; and identify each time they were considered a recipient of the alert "RTN","XQALSUR1",34,0) . . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO "RTN","XQALSUR1",35,0) . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well "RTN","XQALSUR1",36,0) . . . ; walk through the SURROGATE FOR entries for this user "RTN","XQALSUR1",37,0) . . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO "RTN","XQALSUR1",38,0) . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned "RTN","XQALSUR1",39,0) . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert "RTN","XQALSUR1",40,0) . . . . Q "RTN","XQALSUR1",41,0) . . . Q "RTN","XQALSUR1",42,0) . . I 'XNOSURO D "RTN","XQALSUR1",43,0) . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL "RTN","XQALSUR1",44,0) . . . Q "RTN","XQALSUR1",45,0) . . Q "RTN","XQALSUR1",46,0) . Q "RTN","XQALSUR1",47,0) Q "RTN","XQALSUR1",48,0) ; "RTN","XQALSUR1",49,0) SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST "RTN","XQALSUR1",50,0) ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) "RTN","XQALSUR1",51,0) ; "RTN","XQALSUR1",52,0) ; returns XQALIST=count "RTN","XQALSUR1",53,0) ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME "RTN","XQALSUR1",54,0) ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 "RTN","XQALSUR1",55,0) ; "RTN","XQALSUR1",56,0) N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU "RTN","XQALSUR1",57,0) D CHEKSUBS^XQALSUR2(XQAUSER) "RTN","XQALSUR1",58,0) S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) "RTN","XQALSUR1",59,0) S XQANOW=$$NOW^XLFDT(),XQALCNT=0 "RTN","XQALSUR1",60,0) S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D "RTN","XQALSUR1",61,0) . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q "RTN","XQALSUR1",62,0) . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND "RTN","XQALSUR1",63,0) . Q "RTN","XQALSUR1",64,0) ; now rearrange by earliest to last "RTN","XQALSUR1",65,0) K XQALIST S XQALIST=0 "RTN","XQALSUR1",66,0) S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D "RTN","XQALSUR1",67,0) . ; if end date not specified, and start date follows, set end date to next start date "RTN","XQALSUR1",68,0) . I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3) "RTN","XQALSUR1",69,0) . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) "RTN","XQALSUR1",70,0) . Q "RTN","XQALSUR1",71,0) Q "RTN","XQALSUR1",72,0) ; "RTN","XQALSUR1",73,0) DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy "RTN","XQALSUR1",74,0) N XQALNEXT,XQALIST,I,XQALAST "RTN","XQALSUR1",75,0) I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" "RTN","XQALSUR1",76,0) S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D "RTN","XQALSUR1",77,0) . F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q "RTN","XQALSUR1",78,0) . Q "RTN","XQALSUR1",79,0) Q XQALSURO "RTN","XQALSUR1",80,0) ; "RTN","XQALSUR1",81,0) DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated "RTN","XQALSUR1",82,0) N XQALY,XQA0,XQALIEN,XQALS "RTN","XQALSUR1",83,0) S XQALY="" I XQALEND'>0 S XQALEND=4000101 "RTN","XQALSUR1",84,0) F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) "RTN","XQALSUR1",86,0) . Q "RTN","XQALSUR1",87,0) Q XQALY "RTN","XQALSUR1",88,0) ; "RTN","XQALSUR1",89,0) SURRO1(XQAUSER) ; "RTN","XQALSUR1",90,0) N XQALSURO,XQALSTRT,XQALEND "RTN","XQALSUR1",91,0) D CHKREMV^XQALSURO "RTN","XQALSUR1",92,0) SURRO11 ; "RTN","XQALSUR1",93,0) S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q "RTN","XQALSUR1",94,0) I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11 "RTN","XQALSUR1",95,0) S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q "RTN","XQALSUR1",96,0) S XQALEND=+$$ENDDLG() I XQALEND<0 Q "RTN","XQALSUR1",97,0) D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) "RTN","XQALSUR1",98,0) G SURRO11 ; "RTN","XQALSUR1",99,0) Q "RTN","XQALSUR1",100,0) ; "RTN","XQALSUR1",101,0) ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date "RTN","XQALSUR1",102,0) REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship "RTN","XQALSUR1",103,0) I $G(XQAUSER)'>0 Q "RTN","XQALSUR1",104,0) S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) "RTN","XQALSUR1",105,0) N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 "RTN","XQALSUR1",106,0) D CHEKSUBS^XQALSUR2(XQAUSER) "RTN","XQALSUR1",107,0) S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 "RTN","XQALSUR1",108,0) S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 "RTN","XQALSUR1",109,0) S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) "RTN","XQALSUR1",110,0) S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D "RTN","XQALSUR1",111,0) . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) "RTN","XQALSUR1",112,0) . Q "RTN","XQALSUR1",113,0) S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. "RTN","XQALSUR1",114,0) Q "RTN","XQALSUR1",115,0) ; "RTN","XQALSUR1",116,0) DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; "RTN","XQALSUR1",117,0) N XQALNOW,XQALFM "RTN","XQALSUR1",118,0) S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER "RTN","XQALSUR1",119,0) I XQALXREF>0 D "RTN","XQALSUR1",120,0) . S XQALNOW=$$NOW^XLFDT() "RTN","XQALSUR1",121,0) . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now "RTN","XQALSUR1",122,0) . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now "RTN","XQALSUR1",123,0) . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 "RTN","XQALSUR1",124,0) . Q "RTN","XQALSUR1",125,0) I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D "RTN","XQALSUR1",126,0) . S XQALFM(8992,XQAUSER,.02)="@" "RTN","XQALSUR1",127,0) . S XQALFM(8992,XQAUSER,.03)="@" "RTN","XQALSUR1",128,0) . S XQALFM(8992,XQAUSER,.04)="@" "RTN","XQALSUR1",129,0) . Q "RTN","XQALSUR1",130,0) I $D(XQALFM) D FILE^DIE("","XQALFM") "RTN","XQALSUR1",131,0) ; ZEXCEPT: XTMUNIT (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN) "RTN","XQALSUR1",132,0) I XQALSURO>0,'$D(XTMUNIT) D "RTN","XQALSUR1",133,0) . N XQAMESG,XMSUB,XMTEXT "RTN","XQALSUR1",134,0) . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" "RTN","XQALSUR1",135,0) . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." "RTN","XQALSUR1",136,0) . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" "RTN","XQALSUR1",137,0) . D SENDMESG^XQALSURO "RTN","XQALSUR1",138,0) . Q "RTN","XQALSUR1",139,0) Q "RTN","XQALSUR1",140,0) ; "RTN","XQALSUR1",141,0) NEWDLG() ; new surrogate dialog "RTN","XQALSUR1",142,0) N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO" "RTN","XQALSUR1",143,0) S Y=$$ASKDIR(.DIR) I 'Y Q 0 "RTN","XQALSUR1",144,0) ; "RTN","XQALSUR1",145,0) S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 "RTN","XQALSUR1",146,0) I Y>0 W " ",$P(Y,U,2) "RTN","XQALSUR1",147,0) Q +Y "RTN","XQALSUR1",148,0) ; "RTN","XQALSUR1",149,0) STRTDLG() ; new surrogate start date/time dialog "RTN","XQALSUR1",150,0) N DIR "RTN","XQALSUR1",151,0) S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 "RTN","XQALSUR1",152,0) S DIR("A",1)="",DIR("A",2)="" "RTN","XQALSUR1",153,0) S DIR("A",3)="if no date/time is entered, alerts will start going to" "RTN","XQALSUR1",154,0) S DIR("A",4)="the SURROGATE immediately." "RTN","XQALSUR1",155,0) Q +$$ASKDIR(.DIR) "RTN","XQALSUR1",156,0) ; "RTN","XQALSUR1",157,0) ENDDLG() ; new surrogate end date/time dialog "RTN","XQALSUR1",158,0) N DIR "RTN","XQALSUR1",159,0) S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 "RTN","XQALSUR1",160,0) S DIR("A",1)="",DIR("A",2)="" "RTN","XQALSUR1",161,0) S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" "RTN","XQALSUR1",162,0) S DIR("A",4)="to terminate alerts going to the SURROGATE" "RTN","XQALSUR1",163,0) Q +$$ASKDIR(.DIR) "RTN","XQALSUR1",164,0) ; "RTN","XQALSUR1",165,0) ASKDIR(DIR) ; "RTN","XQALSUR1",166,0) N Y,DTOUT,DUOUT "RTN","XQALSUR1",167,0) D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 "RTN","XQALSUR1",168,0) Q Y "RTN","XQALSURO") 0^8^B77946006^B62950995 "RTN","XQALSURO",1,0) XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;3/17/08 15:20 "RTN","XQALSURO",2,0) ;;8.0;KERNEL;**114,125,173,285,366,443**;Jul 10, 1995;Build 4 "RTN","XQALSURO",3,0) ;; "RTN","XQALSURO",4,0) Q "RTN","XQALSURO",5,0) OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER "RTN","XQALSURO",6,0) N XQAUSER,DIR,Y "RTN","XQALSURO",7,0) S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which" "RTN","XQALSURO",8,0) S DIR("A")="NEW PERSON entry" "RTN","XQALSURO",9,0) D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) "RTN","XQALSURO",10,0) S XQAUSER=+Y "RTN","XQALSURO",11,0) G SURROGAT "RTN","XQALSURO",12,0) Q "RTN","XQALSURO",13,0) ; "RTN","XQALSURO",14,0) SURROGAT ; USER SPECIFICATION OF SURROGATE "RTN","XQALSURO",15,0) I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ "RTN","XQALSURO",16,0) D SURRO1^XQALSUR1(XQAUSER) "RTN","XQALSURO",17,0) Q "RTN","XQALSURO",18,0) CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates "RTN","XQALSURO",19,0) I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_XQALSURO_") as a surrogate!" ;P443 "RTN","XQALSURO",20,0) I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443 "RTN","XQALSURO",21,0) I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND)) "RTN","XQALSURO",22,0) N XQALSTRT "RTN","XQALSURO",23,0) S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D "RTN","XQALSURO",24,0) . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q "RTN","XQALSURO",25,0) . F S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0 I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q "RTN","XQALSURO",26,0) . Q "RTN","XQALSURO",27,0) Q XQALSURO "RTN","XQALSURO",28,0) ; "RTN","XQALSURO",29,0) SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; Use SETSURO1 instead "RTN","XQALSURO",30,0) N XQALVAL ; P443 "RTN","XQALSURO",31,0) S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443 "RTN","XQALSURO",32,0) Q "RTN","XQALSURO",33,0) ; "RTN","XQALSURO",34,0) SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT "RTN","XQALSURO",35,0) N XQALFM,XQALIEN,XQAIENS "RTN","XQALSURO",36,0) I $G(XQAUSER)'>0 Q "RTN","XQALSURO",37,0) I $G(XQALSURO)'>0 Q "RTN","XQALSURO",38,0) I '$D(^XTV(8992,XQAUSER,0)) D "RTN","XQALSURO",39,0) . N XQALFM,XQALFM1 "RTN","XQALSURO",40,0) . S XQALFM1(1)=XQAUSER "RTN","XQALSURO",41,0) . S XQALFM(8992,"+1,",.01)=XQAUSER "RTN","XQALSURO",42,0) . D UPDATE^DIE("","XQALFM","XQALFM1") "RTN","XQALSURO",43,0) . Q "RTN","XQALSURO",44,0) S XQAIENS=XQAUSER_"," "RTN","XQALSURO",45,0) ; P366 - force no start date/time to NOW "RTN","XQALSURO",46,0) ; P366 - change to force anything less than NOW to NOW - 8/22/05 "RTN","XQALSURO",47,0) I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT() "RTN","XQALSURO",48,0) ; P366 - add values to new multiple "RTN","XQALSURO",49,0) S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT "RTN","XQALSURO",50,0) S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO "RTN","XQALSURO",51,0) I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND "RTN","XQALSURO",52,0) K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN") "RTN","XQALSURO",53,0) ; P366 - if start date time is already in effect - place in old locations to make active "RTN","XQALSURO",54,0) I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) "RTN","XQALSURO",55,0) N XQAMESG,XMSUB,XMTEXT "RTN","XQALSURO",56,0) S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for" "RTN","XQALSURO",57,0) S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT) "RTN","XQALSURO",58,0) I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"." "RTN","XQALSURO",59,0) E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND) "RTN","XQALSURO",60,0) S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E") "RTN","XQALSURO",61,0) S XMTEXT="XQAMESG(" "RTN","XQALSURO",62,0) ; ZEXCEPT: XTMUNIT - Defined if unit tests are being run "RTN","XQALSURO",63,0) D:'$D(XTMUNIT) SENDMESG "RTN","XQALSURO",64,0) Q "RTN","XQALSURO",65,0) ; "RTN","XQALSURO",66,0) ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate "RTN","XQALSURO",67,0) N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND "RTN","XQALSURO",68,0) S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0="" S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3) "RTN","XQALSURO",69,0) S X0=^XTV(8992,XQAUSER,0) "RTN","XQALSURO",70,0) I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove. "RTN","XQALSURO",71,0) K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT "RTN","XQALSURO",72,0) S XQALFM(8992,XQAUSER_",",.02)=XQALSURO "RTN","XQALSURO",73,0) S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@") "RTN","XQALSURO",74,0) D FILE^DIE("","XQALFM") "RTN","XQALSURO",75,0) Q "RTN","XQALSURO",76,0) ; "RTN","XQALSURO",77,0) ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0 "RTN","XQALSURO",78,0) SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO "RTN","XQALSURO",79,0) I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT() "RTN","XQALSURO",80,0) N XQAVAL "RTN","XQALSURO",81,0) S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate "RTN","XQALSURO",82,0) D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443 "RTN","XQALSURO",83,0) Q XQALSURO "RTN","XQALSURO",84,0) ; "RTN","XQALSURO",85,0) CHKREMV ; "RTN","XQALSURO",86,0) N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y "RTN","XQALSURO",87,0) ; ZEXCEPT: XQAUSER (EXTERNAL VALUE) "RTN","XQALSURO",88,0) D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST) "RTN","XQALSURO",89,0) W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE" "RTN","XQALSURO",90,0) F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 W !,XQAI," ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4)) "RTN","XQALSURO",91,0) W ! I XQASLIST'>0 W !," No current surrogates",! Q "RTN","XQALSURO",92,0) S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0 "RTN","XQALSURO",93,0) S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR "RTN","XQALSURO",94,0) I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0 D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3)) "RTN","XQALSURO",95,0) Q "RTN","XQALSURO",96,0) ; "RTN","XQALSURO",97,0) ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date "RTN","XQALSURO",98,0) REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship "RTN","XQALSURO",99,0) I $G(XQAUSER)'>0 Q "RTN","XQALSURO",100,0) D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT)) "RTN","XQALSURO",101,0) Q "RTN","XQALSURO",102,0) ; "RTN","XQALSURO",103,0) ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range "RTN","XQALSURO",104,0) CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ) "RTN","XQALSURO",105,0) N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI "RTN","XQALSURO",106,0) D CHEKSUBS^XQALSUR2(XQAUSER) "RTN","XQALSURO",107,0) I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times "RTN","XQALSURO",108,0) ; "RTN","XQALSURO",109,0) ; P366 - find the latest start time which is now or past or the first one in the future "RTN","XQALSURO",110,0) S XQANOW=$$NOW^XLFDT() D "RTN","XQALSURO",111,0) . S XQAIVAL=0,XQASTR1=0 "RTN","XQALSURO",112,0) . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'0 D "RTN","XQALSURO",113,0) . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI "RTN","XQALSURO",114,0) . . Q "RTN","XQALSURO",115,0) . ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one "RTN","XQALSURO",116,0) . I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT="" F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D Q:XQAIVAL>0 "RTN","XQALSURO",117,0) . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI "RTN","XQALSURO",118,0) . . Q "RTN","XQALSURO",119,0) . I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL) "RTN","XQALSURO",120,0) . Q "RTN","XQALSURO",121,0) ; P366 - end "RTN","XQALSURO",122,0) S X=$G(^XTV(8992,XQAUSER,0)) "RTN","XQALSURO",123,0) ; now check for a CURRENT surrogate, already started and not expired or cyclic "RTN","XQALSURO",124,0) I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2) "RTN","XQALSURO",125,0) . N DATE ; Get Current date/time to check date/times if present "RTN","XQALSURO",126,0) . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR "RTN","XQALSURO",127,0) . ; Current Date/time past End date for surrogate "RTN","XQALSURO",128,0) . S DATE=$P(X,U,4) I (DATE>0&(DATE0 Q:'$$ISACTIVE(XQASURO) S XQASURO1=XQASURO D "RTN","XQALSURO",135,0) . . I $D(XQALLIST(XQASURO)) D REMVSURO(XQASURO) S XQASURO1=XQAUSER K XQALLIST S XQALLIST(XQAUSER)="" Q "RTN","XQALSURO",136,0) . . S XQALLIST(XQASURO1)="" "RTN","XQALSURO",137,0) . . Q "RTN","XQALSURO",138,0) . ; END OF P443 MODIFICATION "RTN","XQALSURO",139,0) . Q "RTN","XQALSURO",140,0) Q -1 "RTN","XQALSURO",141,0) ; "RTN","XQALSURO",142,0) ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1) "RTN","XQALSURO",143,0) N DATA "RTN","XQALSURO",144,0) S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0 ; NO SURROGATE SPECIFIED "RTN","XQALSURO",145,0) I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0 ; START DATE/TIME NOT YET "RTN","XQALSURO",146,0) I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0 ; PAST END DATE/TIME "RTN","XQALSURO",147,0) Q 1 "RTN","XQALSURO",148,0) ; "RTN","XQALSURO",149,0) ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time "RTN","XQALSURO",150,0) N CURRSURO,NEXTSURO,SURODATA,NOW "RTN","XQALSURO",151,0) S NOW=$$NOW^XLFDT() "RTN","XQALSURO",152,0) S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1 "RTN","XQALSURO",153,0) F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO "RTN","XQALSURO",154,0) Q CURRSURO "RTN","XQALSURO",155,0) ; "RTN","XQALSURO",156,0) GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times "RTN","XQALSURO",157,0) I $$CURRSURO(XQAUSER)'>0 Q "" "RTN","XQALSURO",158,0) N GLOBREF,IENS,X "RTN","XQALSURO",159,0) S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF "RTN","XQALSURO",160,0) D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF) "RTN","XQALSURO",161,0) S GLOBREF=$NA(@GLOBREF@(8992,IENS)) "RTN","XQALSURO",162,0) S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I")) "RTN","XQALSURO",163,0) K @GLOBREF "RTN","XQALSURO",164,0) Q X "RTN","XQALSURO",165,0) ; "RTN","XQALSURO",166,0) GETFOR ;OPT. "RTN","XQALSURO",167,0) N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y "RTN","XQALSURO",168,0) S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate." "RTN","XQALSURO",169,0) S DIR("A")="Select User (NEW PERSON entry)" "RTN","XQALSURO",170,0) D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) "RTN","XQALSURO",171,0) S XQAUSER=+Y "RTN","XQALSURO",172,0) D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q "RTN","XQALSURO",173,0) S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0 D:(XQACNT>(IOSL-4)) Q:$D(DIRUT) W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1 "RTN","XQALSURO",174,0) . S DIR(0)="E" D ^DIR K DIR "RTN","XQALSURO",175,0) . Q "RTN","XQALSURO",176,0) K DIRUT "RTN","XQALSURO",177,0) Q "RTN","XQALSURO",178,0) ; "RTN","XQALSURO",179,0) SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER "RTN","XQALSURO",180,0) D SUROLIST^XQALSUR1(XQAUSER,.XQALIST) "RTN","XQALSURO",181,0) Q "RTN","XQALSURO",182,0) ; "RTN","XQALSURO",183,0) SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for "RTN","XQALSURO",184,0) I $G(XQAUSER)="" Q "RTN","XQALSURO",185,0) N I,COUNT S I=0,COUNT=0 F S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0 I $$CURRSURO(I)>0 D "RTN","XQALSURO",186,0) . S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E") "RTN","XQALSURO",187,0) S LIST=COUNT "RTN","XQALSURO",188,0) Q "RTN","XQALSURO",189,0) ; "RTN","XQALSURO",190,0) SENDMESG ; "RTN","XQALSURO",191,0) N XMY,XMDUZ,XMCHAN "RTN","XQALSURO",192,0) ; ZEXCEPT: XQALSURO (EXTERNAL VALUE) "RTN","XQALSURO",193,0) S XMY(XQALSURO)="",XMDUZ=.5 "RTN","XQALSURO",194,0) D ^XMD "RTN","XQALSURO",195,0) Q "RTN","XQARPRT2") 0^9^B75569961^B74224397 "RTN","XQARPRT2",1,0) XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS ;4/9/07 10:16 "RTN","XQARPRT2",2,0) ;;8.0;KERNEL;**316,443**;Jul 10, 1995;Build 4 "RTN","XQARPRT2",3,0) ; Based on the original routine AEKALERT "RTN","XQARPRT2",4,0) Q "RTN","XQARPRT2",5,0) EN ; OPT - interactive lists alerts from start date for a single user based on contents of alert tracking file "RTN","XQARPRT2",6,0) N DIR,XQADOC S DIR(0)="PO^200:EMZ" D ^DIR K DIR Q:$D(DIRUT) Q:Y'>0 S XQADOC=+Y "RTN","XQARPRT2",7,0) EN1 ; "RTN","XQARPRT2",8,0) N XQASDATE,XQAWORDS,XQADISP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,POP,XQAU1N4 "RTN","XQARPRT2",9,0) D DATES Q:Y'>0 "RTN","XQARPRT2",10,0) D WORDS() Q:$D(DIRUT) K Y "RTN","XQARPRT2",11,0) S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^XQARPRT2",ZTDESC="List of User Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q "RTN","XQARPRT2",12,0) DQ1 ; "RTN","XQARPRT2",13,0) N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT "RTN","XQARPRT2",14,0) S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")" "RTN","XQARPRT2",15,0) U IO "RTN","XQARPRT2",16,0) D HEADER(HEADERID,1) "RTN","XQARPRT2",17,0) S XQAIEN=$O(^XTV(8992.1,"D",XQASDATE-.0000001)) I XQAIEN>0 S XQAIEN=$O(^(XQAIEN,0)) ; find starting point instead of having to work up through x-ref "RTN","XQARPRT2",18,0) I XQAIEN>0 F S XQAIEN=$O(^XTV(8992.1,"R",XQADOC,XQAIEN)) Q:XQAIEN'>0 D Q:$D(DIRUT)!(XQADATE>XQAEDATE) "RTN","XQARPRT2",19,0) . S XQANODE0=$G(^XTV(8992.1,XQAIEN,0)),XQADATE=$P(XQANODE0,"^",2) Q:(XQADATEXQAEDATE) "RTN","XQARPRT2",20,0) . D PRNTATRK(XQAIEN) "RTN","XQARPRT2",21,0) D HEADER(HEADERID,0) "RTN","XQARPRT2",22,0) D ^%ZISC "RTN","XQARPRT2",23,0) K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y "RTN","XQARPRT2",24,0) Q "RTN","XQARPRT2",25,0) ; "RTN","XQARPRT2",26,0) WORDS(TYPE) ; Allow user to select alerts containing only certain words "RTN","XQARPRT2",27,0) S DIR(0)="Y",DIR("A")="Do you want to "_$S($G(TYPE)'="":"count",1:"list")_" only alerts containing specific words or phrase(s)" "RTN","XQARPRT2",28,0) S DIR("?",1)="You can enter one or more words or phrases which you want to be used to" "RTN","XQARPRT2",29,0) S DIR("?",2)="select the alerts to be listed. If you enter NO, all for the selected" "RTN","XQARPRT2",30,0) S DIR("?",3)="individual in the selected time period will be selected. If you enter" "RTN","XQARPRT2",31,0) S DIR("?",4)="YES, you will be prompted to enter a word or phrase. You will be prompted" "RTN","XQARPRT2",32,0) S DIR("?",5)="again, and you may enter as many word or phrase entries as you want." "RTN","XQARPRT2",33,0) S DIR("?",6)="Comparisons will NOT be case specific." "RTN","XQARPRT2",34,0) S DIR("?",7)="" "RTN","XQARPRT2",35,0) S DIR("?",8)="HOWEVER ALL WORDS OR PHRASES ENTERED MUST BE IN THE MESSAGE FOR AN ALERT" "RTN","XQARPRT2",36,0) S DIR("?")="TO BE SELECTED." "RTN","XQARPRT2",37,0) D ^DIR K DIR Q:Y'>0 "RTN","XQARPRT2",38,0) ; "RTN","XQARPRT2",39,0) F J=1:1 W:J>1 !?7,"--- OR ---",!,"Enter another set of words or phrases that should",!,"be matched independently of the previous entr"_$S(J>2:"ies",1:"y") D Q:'$D(XQAWORDS(J)) "RTN","XQARPRT2",40,0) . W !?10,"ALL words or phrases connected by -AND- must appear in the",!?10,"message for an alert to be selected" "RTN","XQARPRT2",41,0) . S DIR("?",1)="Enter a word, at least three characters long, or phrase, without regard to" "RTN","XQARPRT2",42,0) . S DIR("?",2)="case, that you want to be required for selection of alerts to be listed." "RTN","XQARPRT2",43,0) . S DIR("?",3)="If more than one word or phrase are specified, ALL of them must be in alerts" "RTN","XQARPRT2",44,0) . S DIR("?")="which will be listed." "RTN","XQARPRT2",45,0) . F I=1:1 S DIR(0)="FO^3:",DIR("A")="Enter "_$S(I=1:"a",1:"another")_" word or phrase" W:I>1 !?10,"-AND-" D ^DIR Q:(Y="")!(Y["^") S XQAWORDS(J,I)=$$UP^XLFSTR(Y) "RTN","XQARPRT2",46,0) . K DIR,DIRUT "RTN","XQARPRT2",47,0) . Q "RTN","XQARPRT2",48,0) ; "RTN","XQARPRT2",49,0) I $D(XQAWORDS)>1,$G(TYPE)="" D "RTN","XQARPRT2",50,0) . S DIR(0)="SO^1:Both Action and Info Only;2:Action Alerts;3:Info Only Alerts",DIR("?",1)="Select whether alerts listed should be alerts involving actions (2), info",DIR("?")="only or text only alerts (3), or both (1)." "RTN","XQARPRT2",51,0) . S DIR("A")="Select Alert Type(s) desired",DIR("B")=1 D ^DIR K DIR S:Y'>0 Y=1 K DIRUT S XQADISP=+Y "RTN","XQARPRT2",52,0) . Q "RTN","XQARPRT2",53,0) Q "RTN","XQARPRT2",54,0) ; "RTN","XQARPRT2",55,0) USER ;USER ENTRY POINT "RTN","XQARPRT2",56,0) N DIR,XQADOC S XQADOC=DUZ "RTN","XQARPRT2",57,0) G EN1 "RTN","XQARPRT2",58,0) ; "RTN","XQARPRT2",59,0) DATES ; "RTN","XQARPRT2",60,0) S DIR(0)="DO^::EX",DIR("B")="TODAY",DIR("A")="START DATE" D ^DIR K DIR Q:Y'>0 S XQASDATE=+Y "RTN","XQARPRT2",61,0) I XQASDATE<$$OLDEST() W !?10,"The earliest date in the alert tracking file is ",$$FMTE^XLFDT($$OLDEST(),"D") S XQASDATE=$$OLDEST() "RTN","XQARPRT2",62,0) I $D(XQA1U4N) W !,"*** WARNING ***: Do not specify too many days - each entry in the Alert Tracking",!,"file must be checked for the date range specified.",! S DIR("B")=$$FMTE^XLFDT(XQASDATE) "RTN","XQARPRT2",63,0) S DIR(0)="DO^"_XQASDATE_":DT",DIR("A")="END DATE" D ^DIR K DIR Q:$D(DIRUT) I Y>0 S XQAEDATE=Y+.24 "RTN","XQARPRT2",64,0) Q "RTN","XQARPRT2",65,0) ; "RTN","XQARPRT2",66,0) PRNTATRK(IEN) ; Print data for an entry from the alert tracking file "RTN","XQARPRT2",67,0) N XQANODE0,XQADATE,Y,XQANEN,XQAMSG,XQAOPT,XQAROU,XQAMSGUC "RTN","XQARPRT2",68,0) S XQANODE0=$G(^XTV(8992.1,IEN,0)),XQADATE=$P(XQANODE0,"^",2) "RTN","XQARPRT2",69,0) S XQAMSG=$G(^XTV(8992.1,IEN,1)),XQAOPT=$P(XQAMSG,U,2),XQAROU=$P(XQAMSG,U,3,4),XQAMSG=$P(XQAMSG,U) "RTN","XQARPRT2",70,0) S XQAOPT=$S(XQAOPT>0:" [OPT]",1:"") S XQAROU=$S((XQAROU'="")&(XQAROU'="^"):" [ROU]",1:"") S XQAOPT=$S(XQAOPT'="":XQAOPT,XQAROU'="":XQAROU,1:" ") "RTN","XQARPRT2",71,0) I $D(XQAWORDS)>1 S XQAMSGUC=$$UP^XLFSTR(XQAMSG) D Q:XQAMSGUC="" "RTN","XQARPRT2",72,0) . N XQAMSG1,J,I S XQAMSG1=XQAMSGUC F J=0:0 S J=$O(XQAWORDS(J)) Q:J'>0 S XQAMSGUC=XQAMSG1 D Q:XQAMSGUC'="" "RTN","XQARPRT2",73,0) . . F I=0:0 S I=$O(XQAWORDS(J,I)) Q:I'>0 I XQAMSGUC'[XQAWORDS(J,I) S XQAMSGUC="" Q "RTN","XQARPRT2",74,0) . . I XQAMSGUC'="",XQADISP'=1 D "RTN","XQARPRT2",75,0) . . . I XQADISP=2,XQAOPT="",XQAROU="" S XQAMSGUC="" "RTN","XQARPRT2",76,0) . . . I XQADISP=3,(XQAOPT'="")!(XQAROU'="") S XQAMSGUC="" "RTN","XQARPRT2",77,0) . . . Q "RTN","XQARPRT2",78,0) . . Q "RTN","XQARPRT2",79,0) . Q "RTN","XQARPRT2",80,0) S XQANEN=$$FMTE^XLFDT(XQADATE,"5Z")_XQAOPT_" ien="_IEN "RTN","XQARPRT2",81,0) W !,$E(XQAMSG,1,IOM-1) W !?35,XQANEN S XQATOT=XQATOT+1 "RTN","XQARPRT2",82,0) S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D Q:$D(DIRUT) S XQACTR=0 "RTN","XQARPRT2",83,0) . I $D(ZTQUEUED) W @IOF "RTN","XQARPRT2",84,0) . E U IO(0) S DIR(0)="E" D ^DIR K DIR W ! "RTN","XQARPRT2",85,0) . U IO "RTN","XQARPRT2",86,0) . Q "RTN","XQARPRT2",87,0) Q "RTN","XQARPRT2",88,0) ; "RTN","XQARPRT2",89,0) HEADER(XQANAME,DOFF) ; Output header at start of report XQANAME indicates who report is for "RTN","XQARPRT2",90,0) W:DOFF @IOF W:'DOFF ! W $S('DOFF:"Found "_XQATOT_" ",1:""),$S($D(XQAWORDS)>1:"Selected ",1:""),"Alerts for ",XQANAME,!," for dates ",$$FMTE^XLFDT(XQASDATE)," through " "RTN","XQARPRT2",91,0) N OUTDATE S OUTDATE=$$FMTE^XLFDT(XQAEDATE,"D") I 'DOFF,$D(XQADATE),XQADATE0 W:I>1 !?10,"--- OR ---" D "RTN","XQARPRT2",101,0) . F J=0:0 S J=$O(XQAWORDS(I,J)) Q:J'>0 W !?5,$S(J=1:"Selected alerts containing:",1:" and containing:"),?35,XQAWORDS(I,J) S XQACTR=XQACTR+1 "RTN","XQARPRT2",102,0) . Q "RTN","XQARPRT2",103,0) Q "RTN","XQARPRT2",104,0) DTPT ; OPT - GIVEN DATE AND PATIENT, TAKE A LOOK AT ALL USING 'D' X-REF "RTN","XQARPRT2",105,0) ; for one day and for 1 patient list data in alert tracking file related to patient "RTN","XQARPRT2",106,0) N DIR,XQANAME,XQADFN,XQA1U4N,XQASDATE,XQAEDATE,XQA1U4NP,XQAWORDS "RTN","XQARPRT2",107,0) S DIR(0)="PO^2:EMZ" D ^DIR Q:Y'>0 S XQANAME=$P(Y,"^",2),XQADFN=+Y,XQA1U4N=$$GET1^DIQ(2,XQADFN_",",.0905),XQA1U4NP="("_XQA1U4N_")" "RTN","XQARPRT2",108,0) D CHEKSCAN(XQADFN) Q:$D(DIRUT) "RTN","XQARPRT2",109,0) D DATES Q:Y'>0 "RTN","XQARPRT2",110,0) D WORDS() K Y Q:$D(DIRUT) "RTN","XQARPRT2",111,0) S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DTPTDQ^XQARPRT2",ZTDESC="List of Patient Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q "RTN","XQARPRT2",112,0) DTPTDQ ; "RTN","XQARPRT2",113,0) N XQANWID,FOUND,ONE,ZERO,XQACTR,XQAIEN,XQATYPE,XQADATE,HEADERID,XQATOT "RTN","XQARPRT2",114,0) S HEADERID="Patient "_$$GET1^DIQ(2,XQADFN_",",.01)_" ("_$$GET1^DIQ(2,XQADFN_",",.0905)_")" "RTN","XQARPRT2",115,0) D HEADER(HEADERID,1) "RTN","XQARPRT2",116,0) S XQADATE=XQASDATE-0.0000001 F S XQADATE=$O(^XTV(8992.1,"D",XQADATE)) Q:(XQADATE'>0)!(XQADATE>XQAEDATE) D Q:$D(DIRUT) "RTN","XQARPRT2",117,0) . S XQAIEN=0 F S XQAIEN=$O(^XTV(8992.1,"D",XQADATE,XQAIEN)) Q:XQAIEN="" S ONE=$G(^XTV(8992.1,XQAIEN,1)),ZERO=$G(^(0)),XQATYPE=$E(ZERO,1,3) D Q:$D(DIRUT) "RTN","XQARPRT2",118,0) . . S FOUND=0 "RTN","XQARPRT2",119,0) . . I (XQATYPE="DVB")!(XQATYPE="OR,") I $P(ZERO,U,4)=XQADFN S FOUND=1 "RTN","XQARPRT2",120,0) . . I (XQATYPE="GMA"),$P(ONE,U)[XQANAME S FOUND=1 "RTN","XQARPRT2",121,0) . . I (XQATYPE="TIU"),$P(ONE,U)[$E(XQANAME,1,9),$P(ONE,U)[XQA1U4NP S FOUND=1 "RTN","XQARPRT2",122,0) . . I FOUND D PRNTATRK(XQAIEN) "RTN","XQARPRT2",123,0) . . Q "RTN","XQARPRT2",124,0) . Q "RTN","XQARPRT2",125,0) D HEADER(HEADERID,0) "RTN","XQARPRT2",126,0) Q "RTN","XQARPRT2",127,0) ; "RTN","XQARPRT2",128,0) CHEKSCAN(XQADFN) ; Output a list of dates when OR, and DVB alerts are found "RTN","XQARPRT2",129,0) N DIR,OLDEST,X,Y,XQASDATE,XX,CNT,COL,BASECNT,I "RTN","XQARPRT2",130,0) W !!! S DIR(0)="Y",DIR("A")="Do you want to scan for a list of dates that have at least some alerts for this patient",DIR("A",1)="The quick scan method used here will not pick up some alerts," "RTN","XQARPRT2",131,0) S DIR("A",2)="but should give an indication of when alerts might be found.",DIR("A",3)="" "RTN","XQARPRT2",132,0) D ^DIR K DIR Q:$D(DIRUT) I Y D "RTN","XQARPRT2",133,0) . K ^TMP("XQARPRT2",$J) "RTN","XQARPRT2",134,0) . N OLDEST S OLDEST=$$FMTE^XLFDT($$OLDEST(),"5DZ") "RTN","XQARPRT2",135,0) . S DIR(0)="SO^;1:1 Week ago;2:1 month ago;3:3 months ago;4:6 months ago;5:1 year ago;6:As far back as possible",DIR("A")="Select a period for starting",DIR("A",1)="The oldest entry in your Alert Tracking file is from "_OLDEST,DIR("A",2)="" "RTN","XQARPRT2",136,0) . D ^DIR K DIR Q:Y'>0 "RTN","XQARPRT2",137,0) . S X=$S(Y=1:"1W",Y=2:"1M",Y=3:"3M",Y=4:"6M",Y=5:"12M",1:"1000M"),X="T-"_X D ^%DT S XQASDATE=Y "RTN","XQARPRT2",138,0) . F I=0:0 S I=$O(^XTV(8992.1,"C",XQADFN,I)) Q:I'>0 S ZERO=$P(^XTV(8992.1,I,0),U,2) I ZERO'0 S CNT=CNT+1,XX(CNT)=$G(XX(CNT))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " I (CNT-BASECNT)>(IOSL-4) S COL=COL+1 S:'(COL#3) BASECNT=CNT S CNT=BASECNT "RTN","XQARPRT2",142,0) . S CNT=2 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0 S CNT=CNT+1,XX(CNT\3)=$G(XX(CNT\3))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " "RTN","XQARPRT2",143,0) . F I=0:0 S I=$O(XX(I)) Q:I'>0 W !,XX(I) "RTN","XQARPRT2",144,0) . Q "RTN","XQARPRT2",145,0) Q "RTN","XQARPRT2",146,0) ; "RTN","XQARPRT2",147,0) VIEWTRAK ; OPT. View an entry in the Alert Tracking file in Captioned mode "RTN","XQARPRT2",148,0) D VIEWTRAK^XQARPRT1 "RTN","XQARPRT2",149,0) Q "RTN","XQARPRT2",150,0) ; "RTN","XQARPRT2",151,0) OLDEST() ; Returns date of oldest entry in alert tracking file "RTN","XQARPRT2",152,0) Q $$OLDEST^XQARPRT1() "VER") 8.0^22.0 "BLD",1000,6) ^394 **END** **END**