Released XU*8*730 SEQ #571 Extracted from mail message **KIDS**:XU*8.0*730^ **INSTALL NAME** XU*8.0*730 "BLD",1689,0) XU*8.0*730^KERNEL^0^3200608^y "BLD",1689,1,0) ^^2^2^3200518^ "BLD",1689,1,1,0) Kernel patch XU*8*730 CLARIFY USAGE OF MULTIPLE SURROGATE PERIODS. Please "BLD",1689,1,2,0) refer to National Patch Module for more information. "BLD",1689,4,0) ^9.64PA^^ "BLD",1689,6) 3 "BLD",1689,6.3) 1 "BLD",1689,"ABPKG") n "BLD",1689,"KRN",0) ^9.67PA^779.2^20 "BLD",1689,"KRN",.4,0) .4 "BLD",1689,"KRN",.401,0) .401 "BLD",1689,"KRN",.402,0) .402 "BLD",1689,"KRN",.403,0) .403 "BLD",1689,"KRN",.5,0) .5 "BLD",1689,"KRN",.84,0) .84 "BLD",1689,"KRN",3.6,0) 3.6 "BLD",1689,"KRN",3.8,0) 3.8 "BLD",1689,"KRN",9.2,0) 9.2 "BLD",1689,"KRN",9.8,0) 9.8 "BLD",1689,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",1689,"KRN",9.8,"NM",1,0) XQALSURO^^0^B94465692 "BLD",1689,"KRN",9.8,"NM",2,0) XQALSUR1^^0^B73029435 "BLD",1689,"KRN",9.8,"NM",3,0) XQALSUR2^^0^B9231034 "BLD",1689,"KRN",9.8,"NM","B","XQALSUR1",2) "BLD",1689,"KRN",9.8,"NM","B","XQALSUR2",3) "BLD",1689,"KRN",9.8,"NM","B","XQALSURO",1) "BLD",1689,"KRN",19,0) 19 "BLD",1689,"KRN",19.1,0) 19.1 "BLD",1689,"KRN",101,0) 101 "BLD",1689,"KRN",409.61,0) 409.61 "BLD",1689,"KRN",771,0) 771 "BLD",1689,"KRN",779.2,0) 779.2 "BLD",1689,"KRN",870,0) 870 "BLD",1689,"KRN",8989.51,0) 8989.51 "BLD",1689,"KRN",8989.52,0) 8989.52 "BLD",1689,"KRN",8994,0) 8994 "BLD",1689,"KRN","B",.4,.4) "BLD",1689,"KRN","B",.401,.401) "BLD",1689,"KRN","B",.402,.402) "BLD",1689,"KRN","B",.403,.403) "BLD",1689,"KRN","B",.5,.5) "BLD",1689,"KRN","B",.84,.84) "BLD",1689,"KRN","B",3.6,3.6) "BLD",1689,"KRN","B",3.8,3.8) "BLD",1689,"KRN","B",9.2,9.2) "BLD",1689,"KRN","B",9.8,9.8) "BLD",1689,"KRN","B",19,19) "BLD",1689,"KRN","B",19.1,19.1) "BLD",1689,"KRN","B",101,101) "BLD",1689,"KRN","B",409.61,409.61) "BLD",1689,"KRN","B",771,771) "BLD",1689,"KRN","B",779.2,779.2) "BLD",1689,"KRN","B",870,870) "BLD",1689,"KRN","B",8989.51,8989.51) "BLD",1689,"KRN","B",8989.52,8989.52) "BLD",1689,"KRN","B",8994,8994) "BLD",1689,"QDEF") ^^^^NO^^^^NO^^NO "BLD",1689,"QUES",0) ^9.62^^ "BLD",1689,"REQB",0) ^9.611^2^2 "BLD",1689,"REQB",1,0) XU*8.0*602^2 "BLD",1689,"REQB",2,0) XU*8.0*690^2 "BLD",1689,"REQB","B","XU*8.0*602",1) "BLD",1689,"REQB","B","XU*8.0*690",2) "MBREQ") 0 "PKG",3,-1) 1^1 "PKG",3,0) KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^ "PKG",3,22,0) ^9.49I^1^1 "PKG",3,22,1,0) 8.0^3090706^3090706^6 "PKG",3,22,1,"PAH",1,0) 730^3200608^76 "PKG",3,22,1,"PAH",1,1,0) ^^2^2^3200608 "PKG",3,22,1,"PAH",1,1,1,0) Kernel patch XU*8*730 CLARIFY USAGE OF MULTIPLE SURROGATE PERIODS. Please "PKG",3,22,1,"PAH",1,1,2,0) refer to National Patch Module for more information. "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") 3 "RTN","XQALSUR1") 0^2^B73029435^B72344647 "RTN","XQALSUR1",1,0) XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ; May 12, 2020@15:45 "RTN","XQALSUR1",2,0) ;;8.0;KERNEL;**366,443,602,730**;Jul 10, 1995;Build 1 "RTN","XQALSUR1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified "RTN","XQALSUR1",4,0) Q "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,XQASLIST "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) ; p602 check again for cyclical surrogates "RTN","XQALSUR1",98,0) I $$DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND)'>0 W $C(7),!,$$DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND),! G SURRO11 "RTN","XQALSUR1",99,0) D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) "RTN","XQALSUR1",100,0) D DISPSUR^XQALSUR2(XQAUSER,.XQASLIST) ; p730 "RTN","XQALSUR1",101,0) G SURRO11 ; "RTN","XQALSUR1",102,0) Q "RTN","XQALSUR1",103,0) ; "RTN","XQALSUR1",104,0) ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date "RTN","XQALSUR1",105,0) REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship "RTN","XQALSUR1",106,0) I $G(XQAUSER)'>0 Q "RTN","XQALSUR1",107,0) S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) "RTN","XQALSUR1",108,0) N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 "RTN","XQALSUR1",109,0) D CHEKSUBS^XQALSUR2(XQAUSER) "RTN","XQALSUR1",110,0) S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 "RTN","XQALSUR1",111,0) S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 "RTN","XQALSUR1",112,0) S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) "RTN","XQALSUR1",113,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",114,0) . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) "RTN","XQALSUR1",115,0) . Q "RTN","XQALSUR1",116,0) S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. "RTN","XQALSUR1",117,0) D CLEANUP^XQALSUR2(XQAUSER) ;p602 clean up surrogate history (moved from SR. RETURN) "RTN","XQALSUR1",118,0) Q "RTN","XQALSUR1",119,0) ; "RTN","XQALSUR1",120,0) DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; "RTN","XQALSUR1",121,0) N XQALNOW,XQALFM "RTN","XQALSUR1",122,0) S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER "RTN","XQALSUR1",123,0) I XQALXREF>0 D "RTN","XQALSUR1",124,0) . S XQALNOW=$$NOW^XLFDT() "RTN","XQALSUR1",125,0) . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now "RTN","XQALSUR1",126,0) . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now "RTN","XQALSUR1",127,0) . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 "RTN","XQALSUR1",128,0) . Q "RTN","XQALSUR1",129,0) I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D "RTN","XQALSUR1",130,0) . S XQALFM(8992,XQAUSER,.02)="@" "RTN","XQALSUR1",131,0) . S XQALFM(8992,XQAUSER,.03)="@" "RTN","XQALSUR1",132,0) . S XQALFM(8992,XQAUSER,.04)="@" "RTN","XQALSUR1",133,0) . Q "RTN","XQALSUR1",134,0) I $D(XQALFM) D FILE^DIE("","XQALFM") "RTN","XQALSUR1",135,0) ; ZEXCEPT: XTMUNIT (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN) "RTN","XQALSUR1",136,0) I XQALSURO>0,'$D(XTMUNIT) D "RTN","XQALSUR1",137,0) . N XQAMESG,XMSUB,XMTEXT "RTN","XQALSUR1",138,0) . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" "RTN","XQALSUR1",139,0) . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." "RTN","XQALSUR1",140,0) . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" "RTN","XQALSUR1",141,0) . D SENDMESG^XQALSURO "RTN","XQALSUR1",142,0) . Q "RTN","XQALSUR1",143,0) Q "RTN","XQALSUR1",144,0) ; "RTN","XQALSUR1",145,0) NEWDLG() ; new surrogate dialog "RTN","XQALSUR1",146,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",147,0) S Y=$$ASKDIR(.DIR) I 'Y Q 0 "RTN","XQALSUR1",148,0) ; "RTN","XQALSUR1",149,0) S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 "RTN","XQALSUR1",150,0) I Y>0 W " ",$P(Y,U,2) "RTN","XQALSUR1",151,0) Q +Y "RTN","XQALSUR1",152,0) ; "RTN","XQALSUR1",153,0) STRTDLG() ; new surrogate start date/time dialog "RTN","XQALSUR1",154,0) N DIR "RTN","XQALSUR1",155,0) S DIR(0)="DO^NOW::AEFRX",DIR("A")="Enter Date/Time SURROGATE is to start" ; BRX-1000-10427 "RTN","XQALSUR1",156,0) S DIR("A",1)="",DIR("A",2)="" "RTN","XQALSUR1",157,0) S DIR("A",3)=" - If no date/time is entered, new alerts will start going to" "RTN","XQALSUR1",158,0) S DIR("A",4)=" the SURROGATE immediately." "RTN","XQALSUR1",159,0) S DIR("A",5)=" - A past date/time (earlier than NOW) is not permitted." "RTN","XQALSUR1",160,0) S DIR("A",6)=" - If a date is entered, then a time is also required." "RTN","XQALSUR1",161,0) S DIR("A",7)="" "RTN","XQALSUR1",162,0) Q +$$ASKDIR(.DIR) "RTN","XQALSUR1",163,0) ; "RTN","XQALSUR1",164,0) ENDDLG() ; new surrogate end date/time dialog "RTN","XQALSUR1",165,0) N DIR "RTN","XQALSUR1",166,0) S DIR(0)="DO^NOW::AEFRX",DIR("A")="Enter Date/Time SURROGATE is to end" ; BRX-1000-10427 "RTN","XQALSUR1",167,0) S DIR("A",1)="",DIR("A",2)="" "RTN","XQALSUR1",168,0) S DIR("A",3)=" - If no date/time is entered, YOU must remove the SURROGATE" "RTN","XQALSUR1",169,0) S DIR("A",4)=" to terminate the surrogacy." "RTN","XQALSUR1",170,0) S DIR("A",5)=" - A past date/time (earlier than NOW) is not permitted." "RTN","XQALSUR1",171,0) S DIR("A",6)=" - If a date is entered, then a time is also required." "RTN","XQALSUR1",172,0) S DIR("A",7)="" "RTN","XQALSUR1",173,0) Q +$$ASKDIR(.DIR) "RTN","XQALSUR1",174,0) ; "RTN","XQALSUR1",175,0) ASKDIR(DIR) ; "RTN","XQALSUR1",176,0) N Y,DTOUT,DUOUT "RTN","XQALSUR1",177,0) D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 "RTN","XQALSUR1",178,0) Q Y "RTN","XQALSUR2") 0^3^B9231034^B6427475 "RTN","XQALSUR2",1,0) XQALSUR2 ;FO-OAK.SEA/JLI-Continuation of alert surrogate processing ;May 18, 2020@16:32 "RTN","XQALSUR2",2,0) ;;8.0;KERNEL;**366,513,602,690,730**;Jul 10, 1995;Build 1 "RTN","XQALSUR2",3,0) ;Per VHA VA Directive 6402, this routine should not be modified "RTN","XQALSUR2",4,0) Q "RTN","XQALSUR2",5,0) ; added to handle adjustment for manual or Fileman editing of surrogate on top zero node "RTN","XQALSUR2",6,0) CHEKSUBS(XQAUSER) ; "RTN","XQALSUR2",7,0) N XQA0,XQASTR1,XQANOW,XQB0,XQB1 "RTN","XQALSUR2",8,0) S XQANOW=$$NOW^XLFDT() "RTN","XQALSUR2",9,0) S XQA0=$G(^XTV(8992,XQAUSER,0)) I $P(XQA0,U,2)>0 D "RTN","XQALSUR2",10,0) . N XQAFDA,XQAIEN,XQADA "RTN","XQALSUR2",11,0) . S XQASTR1=$P(XQA0,U,3) S:XQASTR1'>0 XQASTR1=XQANOW,XQAFDA(8992,XQAUSER_",",.03)=XQASTR1 D "RTN","XQALSUR2",12,0) . . S XQADA=0 F S XQADA=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1,XQADA)) Q:XQADA'>0 Q:$P(^XTV(8992,XQAUSER,2,XQADA,0),U,2)=$P(XQA0,U,2) "RTN","XQALSUR2",13,0) . . S XQAIEN=$S(XQADA>0:XQADA,1:"+1")_","_XQAUSER_"," S XQAFDA(8992.02,XQAIEN,.01)=XQASTR1 "RTN","XQALSUR2",14,0) . . S XQAFDA(8992.02,XQAIEN,.02)=$P(XQA0,U,2) S:$P(XQA0,U,4)>0 XQAFDA(8992.02,XQAIEN,.03)=$P(XQA0,U,4) "RTN","XQALSUR2",15,0) . . D:XQADA'>0 UPDATE^DIE("","XQAFDA") "RTN","XQALSUR2",16,0) . . D:XQADA>0 FILE^DIE("","XQAFDA") "RTN","XQALSUR2",17,0) . . Q "RTN","XQALSUR2",18,0) . Q "RTN","XQALSUR2",19,0) Q "RTN","XQALSUR2",20,0) ; "RTN","XQALSUR2",21,0) CHKCRIT(ZERONODE) ;EXTRINSIC - check for critical indication for alert "RTN","XQALSUR2",22,0) ; ZERONODE - input - Value for zero node for alert data "RTN","XQALSUR2",23,0) ; RETURN VALUE - 1 if the alert is indicated as critical "RTN","XQALSUR2",24,0) ; 0 otherwise "RTN","XQALSUR2",25,0) N RESULT,IEN "RTN","XQALSUR2",26,0) S RESULT=0 "RTN","XQALSUR2",27,0) F IEN=0:0 S IEN=$O(^XTV(8992.3,IEN)) Q:IEN'>0 D Q:RESULT "RTN","XQALSUR2",28,0) . N IENS,RES,MSG,CRITTEXT,PKGID,ALERTTXT "RTN","XQALSUR2",29,0) . S IENS=IEN_"," "RTN","XQALSUR2",30,0) . D GETS^DIQ(8992.3,IENS,".01:.02",,"RES","MSG") "RTN","XQALSUR2",31,0) . S CRITTEXT=$$UP^XLFSTR(RES(8992.3,IENS,.01)),PKGID=$$UP^XLFSTR(RES(8992.3,IENS,.02)) "RTN","XQALSUR2",32,0) . I PKGID'="",$$UP^XLFSTR($P(ZERONODE,U,2))'[PKGID Q "RTN","XQALSUR2",33,0) . S ALERTTXT=$$UP^XLFSTR($P(ZERONODE,U,3)) "RTN","XQALSUR2",34,0) . I ALERTTXT[CRITTEXT,ALERTTXT'["NOT "_CRITTEXT,ALERTTXT'["NON "_CRITTEXT S RESULT=1 ;;XU*8*690 - Added check for "NON" critical text "RTN","XQALSUR2",35,0) Q RESULT "RTN","XQALSUR2",36,0) CLEANUP(XQAUSER) ;SR. - clean up expired surrogate info "RTN","XQALSUR2",37,0) N XQAI,XQANOW,XQASUR "RTN","XQALSUR2",38,0) S XQANOW=$$NOW^XLFDT() "RTN","XQALSUR2",39,0) I $P($G(^XTV(8992,XQAUSER,2,0)),U,2)>0 D "RTN","XQALSUR2",40,0) . S XQAI=0 F S XQAI=$O(^XTV(8992,XQAUSER,2,XQAI)) Q:XQAI'>0 D "RTN","XQALSUR2",41,0) . . S XQASUR=$G(^XTV(8992,XQAUSER,2,XQAI,0)) "RTN","XQALSUR2",42,0) . . I ($P(XQASUR,U)0) D "RTN","XQALSUR2",43,0) . . . N XQAIEN S XQAIEN=XQAI_","_XQAUSER_"," "RTN","XQALSUR2",44,0) . . . N XQAFDA S XQAFDA(8992.02,XQAIEN,.01)="@" D FILE^DIE("","XQAFDA") "RTN","XQALSUR2",45,0) Q "RTN","XQALSUR2",46,0) ; p730 "RTN","XQALSUR2",47,0) DISPSUR(XQAUSER,XQASLIST) ; Prints and returns current list of surrogate periods for a user "RTN","XQALSUR2",48,0) ; usage: N LIST D DISPSUR^XQAUSER(DUZ,.LIST) "RTN","XQALSUR2",49,0) N XQAI "RTN","XQALSUR2",50,0) D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST) "RTN","XQALSUR2",51,0) I $G(XQASLIST)<1 W !!," No current surrogates",! Q "RTN","XQALSUR2",52,0) W !!,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE" "RTN","XQALSUR2",53,0) F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 D "RTN","XQALSUR2",54,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","XQALSUR2",55,0) W ! "RTN","XQALSUR2",56,0) Q "RTN","XQALSUR2",57,0) ; "RTN","XQALSURO") 0^1^B94465692^B93224133 "RTN","XQALSURO",1,0) XQALSURO ;ISC-SF.SEA/JLI,ISD/HGW - SURROGATES FOR ALERTS ; May 15, 2020@11:57 "RTN","XQALSURO",2,0) ;;8.0;KERNEL;**114,125,173,285,366,443,513,602,730**;Jul 10, 1995;Build 1 "RTN","XQALSURO",3,0) ;Per VHA Directive 2004-038, this routine should not be modified "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) ; "RTN","XQALSURO",19,0) CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates "RTN","XQALSURO",20,0) I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_$$NAME^XUSER(XQALSURO,"F")_") as a surrogate!" ;P443 "RTN","XQALSURO",21,0) I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443 "RTN","XQALSURO",22,0) I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND)) "RTN","XQALSURO",23,0) ;p602 in SURRO11^XQALSUR1 split the check for cyclical surrogates into two parts. The following code becomes unnecessary. "RTN","XQALSURO",24,0) ;N XQALSTRT "RTN","XQALSURO",25,0) ;S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D "RTN","XQALSURO",26,0) ;. I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q "RTN","XQALSURO",27,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",28,0) ;. Q "RTN","XQALSURO",29,0) Q XQALSURO "RTN","XQALSURO",30,0) ; "RTN","XQALSURO",31,0) SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. ICR #2790 (Supported) "RTN","XQALSURO",32,0) ; Use SETSURO1 instead "RTN","XQALSURO",33,0) N XQALVAL ; P443 "RTN","XQALSURO",34,0) S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443 "RTN","XQALSURO",35,0) Q "RTN","XQALSURO",36,0) ; "RTN","XQALSURO",37,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",38,0) N XQALFM,XQALIEN,XQAIENS "RTN","XQALSURO",39,0) I '$D(^XTV(8992,XQAUSER,0)) D "RTN","XQALSURO",40,0) . N XQALFM,XQALFM1 "RTN","XQALSURO",41,0) . S XQALFM1(1)=XQAUSER "RTN","XQALSURO",42,0) . S XQALFM(8992,"+1,",.01)=XQAUSER "RTN","XQALSURO",43,0) . D UPDATE^DIE("","XQALFM","XQALFM1") "RTN","XQALSURO",44,0) . Q "RTN","XQALSURO",45,0) S XQAIENS=XQAUSER_"," "RTN","XQALSURO",46,0) ; P366 - force no start date/time to NOW, and anything less than NOW to NOW "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)&(XQALEND'>XQALSTRT) S XQALEND=$$FMADD^XLFDT(XQALSTRT,0,0,0,1) ;p602 force end date/time to be after start date/time "RTN","XQALSURO",52,0) I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND "RTN","XQALSURO",53,0) K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN") "RTN","XQALSURO",54,0) ; P366 - if start date time is already in effect - place in old locations to make active "RTN","XQALSURO",55,0) ;D ACTIVATE(XQAUSER,XQALIEN(1)) ; P513 activate if current or next "RTN","XQALSURO",56,0) I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) ; p602 activate only if current "RTN","XQALSURO",57,0) N XQAMESG,XMSUB,XMTEXT "RTN","XQALSURO",58,0) S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for" "RTN","XQALSURO",59,0) S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT) "RTN","XQALSURO",60,0) I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"." "RTN","XQALSURO",61,0) E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND) "RTN","XQALSURO",62,0) S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E") "RTN","XQALSURO",63,0) S XMTEXT="XQAMESG(" "RTN","XQALSURO",64,0) ; ZEXCEPT: XTMUNIT - Defined if unit tests are being run "RTN","XQALSURO",65,0) D:'$D(XTMUNIT) SENDMESG "RTN","XQALSURO",66,0) Q "RTN","XQALSURO",67,0) ; "RTN","XQALSURO",68,0) ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate "RTN","XQALSURO",69,0) N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND "RTN","XQALSURO",70,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",71,0) S X0=^XTV(8992,XQAUSER,0) "RTN","XQALSURO",72,0) I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activating a new surrogate, if one exists simply remove. "RTN","XQALSURO",73,0) K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT "RTN","XQALSURO",74,0) S XQALFM(8992,XQAUSER_",",.02)=XQALSURO "RTN","XQALSURO",75,0) S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@") "RTN","XQALSURO",76,0) D FILE^DIE("","XQALFM") "RTN","XQALSURO",77,0) Q "RTN","XQALSURO",78,0) ; "RTN","XQALSURO",79,0) ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0 "RTN","XQALSURO",80,0) SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ;EXTRINSIC. ICR #3213 (supported) "RTN","XQALSURO",81,0) ; This should be used instead of SETSURO "RTN","XQALSURO",82,0) I $G(XQAUSER)'>0 Q "Invalid Internal Entry Number for user ("_XQAUSER_")" ; P513 moved from SETSUROX+2 "RTN","XQALSURO",83,0) I $G(XQALSURO)'>0 Q "Invalid Internal Entry Number for surrogate ("_XQALSURO_")" ; P513 moved from SETSUROX+3 "RTN","XQALSURO",84,0) I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT() "RTN","XQALSURO",85,0) N XQAVAL "RTN","XQALSURO",86,0) S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate "RTN","XQALSURO",87,0) D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443 "RTN","XQALSURO",88,0) Q XQALSURO "RTN","XQALSURO",89,0) ; "RTN","XQALSURO",90,0) CHKREMV ; "RTN","XQALSURO",91,0) N DIR,XQAI,XQAQUIT,XQASLIST,XQAVAL,YVAL,Y "RTN","XQALSURO",92,0) ; ZEXCEPT: XQAUSER (EXTERNAL VALUE) "RTN","XQALSURO",93,0) ; p730 "RTN","XQALSURO",94,0) ;D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST) "RTN","XQALSURO",95,0) ; Display list and allow user to remove surrogate periods until satisfied "RTN","XQALSURO",96,0) S XQAQUIT=0 F D Q:$G(XQASLIST)<1!XQAQUIT "RTN","XQALSURO",97,0) . D DISPSUR^XQALSUR2(XQAUSER,.XQASLIST) "RTN","XQALSURO",98,0) . Q:$G(XQASLIST)<=0 "RTN","XQALSURO",99,0) . S DIR(0)="Y",DIR("B")="NO" "RTN","XQALSURO",100,0) . S DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient" "RTN","XQALSURO",101,0) . S DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." "RTN","XQALSURO",102,0) . D ^DIR K DIR S XQAQUIT='+Y "RTN","XQALSURO",103,0) . Q:XQAQUIT "RTN","XQALSURO",104,0) . S DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" "RTN","XQALSURO",105,0) . S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST D ^DIR K DIR "RTN","XQALSURO",106,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",107,0) . W ! "RTN","XQALSURO",108,0) Q "RTN","XQALSURO",109,0) ; "RTN","XQALSURO",110,0) ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date "RTN","XQALSURO",111,0) REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ;SR. ICR #2790 (supported) "RTN","XQALSURO",112,0) ; Ends the currently active surrogate relationship "RTN","XQALSURO",113,0) I $G(XQAUSER)'>0 Q "RTN","XQALSURO",114,0) D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT)) "RTN","XQALSURO",115,0) Q "RTN","XQALSURO",116,0) ; "RTN","XQALSURO",117,0) ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range "RTN","XQALSURO",118,0) CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. ICR #2790 (supported) "RTN","XQALSURO",119,0) ; Returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ) "RTN","XQALSURO",120,0) N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI "RTN","XQALSURO",121,0) D CHEKSUBS^XQALSUR2(XQAUSER) "RTN","XQALSURO",122,0) I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times "RTN","XQALSURO",123,0) ; "RTN","XQALSURO",124,0) ; P366 - find the latest start time which is now or past or the first one in the future "RTN","XQALSURO",125,0) S XQANOW=$$NOW^XLFDT() D "RTN","XQALSURO",126,0) . S XQAIVAL=0,XQASTR1=0 "RTN","XQALSURO",127,0) . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'0 D "RTN","XQALSURO",128,0) . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI "RTN","XQALSURO",129,0) . . Q "RTN","XQALSURO",130,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",131,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",132,0) . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI "RTN","XQALSURO",133,0) . . Q "RTN","XQALSURO",134,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",135,0) . Q "RTN","XQALSURO",136,0) ; P366 - end "RTN","XQALSURO",137,0) S X=$G(^XTV(8992,XQAUSER,0)) "RTN","XQALSURO",138,0) ; now check for a CURRENT surrogate, already started and not expired or cyclic "RTN","XQALSURO",139,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",140,0) . N DATE ; Get Current date/time to check date/times if present "RTN","XQALSURO",141,0) . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR "RTN","XQALSURO",142,0) . ; Current Date/time past End date for surrogate "RTN","XQALSURO",143,0) . S DATE=$P(X,U,4) I (DATE>0&(DATEXQANOW Q ; P513 "RTN","XQALSURO",146,0) . N XQASURO,XQASURO1 S XQASURO1=+$P(^XTV(8992,XQAUSER,0),U,2) "RTN","XQALSURO",147,0) . ; REMOVE IF SURROGATE IS USER "RTN","XQALSURO",148,0) . I XQASURO1=XQAUSER D REMVSURO(XQAUSER) Q "RTN","XQALSURO",149,0) . N XQALLIST,XQAUDATE S XQAUDATE=DATE,XQALLIST(XQAUSER,DATE)="" ; P513 JLI 100504 add XQAUDATE to be able to check earlier start time "RTN","XQALSURO",150,0) . ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts "RTN","XQALSURO",151,0) . ; P513 but ignore if surrogate isn't already active - JLI 100504 "RTN","XQALSURO",152,0) . ; begin changes in P513 "RTN","XQALSURO",153,0) . S XQASURO1=XQAUSER "RTN","XQALSURO",154,0) . F S XQASURO=$P($G(^XTV(8992,XQASURO1,0)),U,2) Q:XQASURO'>0 Q:'$$ISACTIVE(XQASURO) S DATE=$P(^XTV(8992,XQASURO,0),U,3) Q:DATE>XQANOW D S XQASURO1=XQASURO ; JLI 100504 "RTN","XQALSURO",155,0) . . ;I $D(XQALLIST(XQASURO1)) D "RTN","XQALSURO",156,0) . . I $D(XQALLIST(XQASURO)) D ; p730 check on NEXT surrogate and not on XQAUSER for first pass "RTN","XQALSURO",157,0) . . . N DATE1 S DATE1=$O(XQALLIST(XQASURO1,"")) "RTN","XQALSURO",158,0) . . . ; remove the surrogate relationship that started earliest "RTN","XQALSURO",159,0) . . . I DATE0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0 ; START DATE/TIME NOT YET "RTN","XQALSURO",174,0) I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0 ; PAST END DATE/TIME "RTN","XQALSURO",175,0) Q 1 "RTN","XQALSURO",176,0) ; "RTN","XQALSURO",177,0) ACTVSURO(XQAUSER) ;SR. ICR #2790 (supported) "RTN","XQALSURO",178,0) ; Returns the actual surrogate at this time "RTN","XQALSURO",179,0) N CURRSURO,NEXTSURO,SURODATA,NOW "RTN","XQALSURO",180,0) S NOW=$$NOW^XLFDT() "RTN","XQALSURO",181,0) S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1 "RTN","XQALSURO",182,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",183,0) Q CURRSURO "RTN","XQALSURO",184,0) ; "RTN","XQALSURO",185,0) GETSURO(XQAUSER) ;EXTRINSIC. ICR #3213 (supported) "RTN","XQALSURO",186,0) ; Returns data for surrogate for user including times "RTN","XQALSURO",187,0) I $$CURRSURO(XQAUSER)'>0 Q "" "RTN","XQALSURO",188,0) N GLOBREF,IENS,X "RTN","XQALSURO",189,0) S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF "RTN","XQALSURO",190,0) D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF) "RTN","XQALSURO",191,0) S GLOBREF=$NA(@GLOBREF@(8992,IENS)) "RTN","XQALSURO",192,0) S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I")) "RTN","XQALSURO",193,0) K @GLOBREF "RTN","XQALSURO",194,0) Q X "RTN","XQALSURO",195,0) ; "RTN","XQALSURO",196,0) GETFOR ;OPT. "RTN","XQALSURO",197,0) N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y "RTN","XQALSURO",198,0) S DIR(0)="PD^200:AEMQ" "RTN","XQALSURO",199,0) S DIR("A")="Select Surrogate (NEW PERSON entry)" "RTN","XQALSURO",200,0) S DIR("A",1)="",DIR("A",2)="" "RTN","XQALSURO",201,0) S DIR("A",3)=" - List Users who have chosen this User to be their current Surrogate." ;p602 "RTN","XQALSURO",202,0) S DIR("A",4)="" "RTN","XQALSURO",203,0) D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) "RTN","XQALSURO",204,0) S XQAUSER=+Y "RTN","XQALSURO",205,0) D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q "RTN","XQALSURO",206,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",207,0) . S DIR(0)="E" D ^DIR K DIR "RTN","XQALSURO",208,0) . Q "RTN","XQALSURO",209,0) K DIRUT "RTN","XQALSURO",210,0) Q "RTN","XQALSURO",211,0) ; "RTN","XQALSURO",212,0) SUROLIST(XQAUSER,XQALIST) ;SR. ICR #3213 (supported) "RTN","XQALSURO",213,0) ; Returns list of current and scheduled surrogates for XQAUSER "RTN","XQALSURO",214,0) D SUROLIST^XQALSUR1(XQAUSER,.XQALIST) "RTN","XQALSURO",215,0) Q "RTN","XQALSURO",216,0) ; "RTN","XQALSURO",217,0) SUROFOR(LIST,XQAUSER) ;SR. ICR #3213 (supported) "RTN","XQALSURO",218,0) ; Returns list of users XQAUSER is acting as a surrogate for "RTN","XQALSURO",219,0) I $G(XQAUSER)="" Q "RTN","XQALSURO",220,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",221,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",222,0) S LIST=COUNT "RTN","XQALSURO",223,0) Q "RTN","XQALSURO",224,0) ; "RTN","XQALSURO",225,0) SENDMESG ; "RTN","XQALSURO",226,0) N XMY,XMDUZ,XMCHAN "RTN","XQALSURO",227,0) ; ZEXCEPT: XQALSURO (EXTERNAL VALUE) "RTN","XQALSURO",228,0) S XMY(XQALSURO)="",XMDUZ=.5 "RTN","XQALSURO",229,0) D ^XMD "RTN","XQALSURO",230,0) Q "VER") 8.0^22.2 "BLD",1689,6) ^571 **END** **END**