XQALSURO ;ISC-SF.SEA/JLI,ISD/HGW - SURROGATES FOR ALERTS ; May 12, 2021@14:27
;;8.0;KERNEL;**114,125,173,285,366,443,513,602,730,754**;Jul 10, 1995;Build 1
;Per VHA Directive 2004-038, this routine should not be modified
Q
OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER
N XQAUSER,DIR,Y
S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which"
S DIR("A")="NEW PERSON entry"
D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2)
S XQAUSER=+Y
G SURROGAT
Q
;
SURROGAT ; USER SPECIFICATION OF SURROGATE
I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
D SURRO1^XQALSUR1(XQAUSER)
Q
;
CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates
I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_$$NAME^XUSER(XQALSURO,"F")_") as a surrogate!" ;P443
I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443
I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND))
;p602 in SURRO11^XQALSUR1 split the check for cyclical surrogates into two parts. The following code becomes unnecessary.
;N XQALSTRT
;S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D
;. I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q
;. 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
;. Q
Q XQALSURO
;
SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. ICR #2790 (Supported)
; Use SETSURO1 instead
N XQALVAL ; P443
S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443
Q
;
SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT
N XQALFM,XQALIEN,XQAIENS
I '$D(^XTV(8992,XQAUSER,0)) D
. N XQALFM,XQALFM1
. S XQALFM1(1)=XQAUSER
. S XQALFM(8992,"+1,",.01)=XQAUSER
. D UPDATE^DIE("","XQALFM","XQALFM1")
. Q
S XQAIENS=XQAUSER_","
; P366 - force no start date/time to NOW, and anything less than NOW to NOW
I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT()
; P366 - add values to new multiple
S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT
S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO
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
I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND
K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN")
; P366 - if start date time is already in effect - place in old locations to make active
;D ACTIVATE(XQAUSER,XQALIEN(1)) ; P513 activate if current or next
I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) ; p602 activate only if current
N XQAMESG,XMSUB,XMTEXT
S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for"
S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT)
I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"."
E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND)
S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
S XMTEXT="XQAMESG("
; ZEXCEPT: XTMUNIT - Defined if unit tests are being run
D:'$D(XTMUNIT) SENDMESG
Q
;
ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate
N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND
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)
S X0=^XTV(8992,XQAUSER,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.
K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT
S XQALFM(8992,XQAUSER_",",.02)=XQALSURO
S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@")
D FILE^DIE("","XQALFM")
Q
;
; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0
SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ;EXTRINSIC. ICR #3213 (supported)
; This should be used instead of SETSURO
I $G(XQAUSER)'>0 Q "Invalid Internal Entry Number for user ("_XQAUSER_")" ; P513 moved from SETSUROX+2
I $G(XQALSURO)'>0 Q "Invalid Internal Entry Number for surrogate ("_XQALSURO_")" ; P513 moved from SETSUROX+3
I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT()
N XQAVAL
S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate
D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443
Q XQALSURO
;
CHKREMV ;
N DIR,XQAI,XQAQUIT,XQASLIST,XQAVAL,YVAL,Y
; ZEXCEPT: XQAUSER (EXTERNAL VALUE)
; p730
;D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
; Display list and allow user to remove surrogate periods until satisfied
S XQAQUIT=0 F D Q:$G(XQASLIST)<1!XQAQUIT
. D DISPSUR^XQALSUR2(XQAUSER,.XQASLIST)
. Q:$G(XQASLIST)<=0
. S DIR(0)="Y",DIR("B")="NO"
. S DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient"
. S DIR("?")="A surrogate will receive your alerts until they are removed as surrogate."
. D ^DIR K DIR S XQAQUIT='+Y
. Q:XQAQUIT
. S DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove"
. S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST D ^DIR K DIR
. 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))
. W !
Q
;
; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ;SR. ICR #2790 (supported)
; Ends the currently active surrogate relationship
I $G(XQAUSER)'>0 Q
D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT))
Q
;
; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range
CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. ICR #2790 (supported)
; Returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ)
N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI
D CHEKSUBS^XQALSUR2(XQAUSER)
I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times
;
; P366 - find the latest start time which is now or past or the first one in the future
S XQANOW=$$NOW^XLFDT() D
. S XQAIVAL=0,XQASTR1=0
. F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'<XQANOW S XQASTR1=XQASTRT F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D
. . ; p754 somebody removed surr by gbl kill, cleanup
. . I '$D(^XTV(8992,XQAUSER,2,XQAI,0)) K ^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI) Q
. . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
. . Q
. ; 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
. 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
. . ; p754 somebody removed surr by gbl kill, cleanup
. . I '$D(^XTV(8992,XQAUSER,2,XQAI,0)) K ^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI) Q
. . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
. . Q
. 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)
. Q
; P366 - end
S X=$G(^XTV(8992,XQAUSER,0))
; now check for a CURRENT surrogate, already started and not expired or cyclic
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)
. N DATE ; Get Current date/time to check date/times if present
. ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR
. ; Current Date/time past End date for surrogate
. S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW)) D REMVSURO(XQAUSER) Q
. ; P513 quit if not already active
. S DATE=$P(X,U,3) S:DATE="" DATE=XQANOW I DATE>XQANOW Q ; P513
. N XQASURO,XQASURO1 S XQASURO1=+$P(^XTV(8992,XQAUSER,0),U,2)
. ; REMOVE IF SURROGATE IS USER
. I XQASURO1=XQAUSER D REMVSURO(XQAUSER) Q
. Q ; p754 cyclic checks are done at surrogate creation time and the following is not needed
Q -1
;. N XQALLIST,XQAUDATE S XQAUDATE=DATE,XQALLIST(XQAUSER,DATE)="" ; P513 JLI 100504 add XQAUDATE to be able to check earlier start time
;. ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts
;. ; P513 but ignore if surrogate isn't already active - JLI 100504
;. ; begin changes in P513
;. S XQASURO1=XQAUSER
;. 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
;. . ;I $D(XQALLIST(XQASURO1)) D
;. . I $D(XQALLIST(XQASURO)) D ; p730 check on NEXT surrogate and not on XQAUSER for first pass
;. . . N DATE1 S DATE1=$O(XQALLIST(XQASURO1,""))
;. . . ; remove the surrogate relationship that started earliest
;. . . I DATE<DATE1 D REMVSURO(XQASURO)
;. . . I DATE1<=DATE D REMVSURO(XQASURO1)
;. . . S XQASURO=XQAUSER K XQALLIST S DATE=XQAUDATE ; start over
;. . . Q
;. . S XQALLIST(XQASURO,DATE)=""
;. . ; end of P513 modification
;. . Q
;. ; END OF P443 MODIFICATION
;. Q
;Q -1
;
ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1)
N DATA
S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0 ; NO SURROGATE SPECIFIED
I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0 ; START DATE/TIME NOT YET
I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0 ; PAST END DATE/TIME
Q 1
;
ACTVSURO(XQAUSER) ;SR. ICR #2790 (supported)
; Returns the actual surrogate at this time
N CURRSURO,NEXTSURO,SURODATA,NOW
S NOW=$$NOW^XLFDT()
S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1
F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO
Q CURRSURO
;
GETSURO(XQAUSER) ;EXTRINSIC. ICR #3213 (supported)
; Returns data for surrogate for user including times
I $$CURRSURO(XQAUSER)'>0 Q ""
N GLOBREF,IENS,X
S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF
D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF)
S GLOBREF=$NA(@GLOBREF@(8992,IENS))
S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I"))
K @GLOBREF
Q X
;
GETFOR ;OPT.
N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y
S DIR(0)="PD^200:AEMQ"
S DIR("A")="Select Surrogate (NEW PERSON entry)"
S DIR("A",1)="",DIR("A",2)=""
S DIR("A",3)=" - List Users who have chosen this User to be their current Surrogate." ;p602
S DIR("A",4)=""
D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2)
S XQAUSER=+Y
D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q
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
. S DIR(0)="E" D ^DIR K DIR
. Q
K DIRUT
Q
;
SUROLIST(XQAUSER,XQALIST) ;SR. ICR #3213 (supported)
; Returns list of current and scheduled surrogates for XQAUSER
D SUROLIST^XQALSUR1(XQAUSER,.XQALIST)
Q
;
SUROFOR(LIST,XQAUSER) ;SR. ICR #3213 (supported)
; Returns list of users XQAUSER is acting as a surrogate for
I $G(XQAUSER)="" Q
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
. 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")
S LIST=COUNT
Q
;
SENDMESG ;
N XMY,XMDUZ,XMCHAN
; ZEXCEPT: XQALSURO (EXTERNAL VALUE)
S XMY(XQALSURO)="",XMDUZ=.5
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALSURO 11988 printed Apr 09, 2024@21:16:43 Page 2
XQALSURO ;ISC-SF.SEA/JLI,ISD/HGW - SURROGATES FOR ALERTS ; May 12, 2021@14:27
+1 ;;8.0;KERNEL;**114,125,173,285,366,443,513,602,730,754**;Jul 10, 1995;Build 1
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER
+1 NEW XQAUSER,DIR,Y
+2 SET DIR(0)="PD^200:AEMQ"
SET DIR("A",1)="SURROGATE related to which"
+3 SET DIR("A")="NEW PERSON entry"
+4 DO ^DIR
KILL DIR
if Y'>0
QUIT
WRITE " ",$PIECE(Y,U,2)
+5 SET XQAUSER=+Y
+6 GOTO SURROGAT
+7 QUIT
+8 ;
SURROGAT ; USER SPECIFICATION OF SURROGATE
+1 IF '$DATA(XQAUSER)
NEW XQAUSER
SET XQAUSER=DUZ
+2 DO SURRO1^XQALSUR1(XQAUSER)
+3 QUIT
+4 ;
CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates
+1 ;P443
IF '$$ACTIVE^XUSER(XQALSURO)
QUIT "You cannot have an INACTIVE USER ("_$$NAME^XUSER(XQALSURO,"F")_") as a surrogate!"
+2 ; moved in P443
IF XQALSURO=XQAUSER
QUIT "You cannot specify yourself as your own surrogate!"
+3 IF $GET(XQASTRT)>0
QUIT $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$GET(XQAEND))
+4 ;p602 in SURRO11^XQALSUR1 split the check for cyclical surrogates into two parts. The following code becomes unnecessary.
+5 ;N XQALSTRT
+6 ;S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D
+7 ;. I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q
+8 ;. 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
+9 ;. Q
+10 QUIT XQALSURO
+11 ;
SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. ICR #2790 (Supported)
+1 ; Use SETSURO1 instead
+2 ; P443
NEW XQALVAL
+3 ; P443
SET XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$GET(XQALSTRT),$GET(XQALEND))
+4 QUIT
+5 ;
SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT
+1 NEW XQALFM,XQALIEN,XQAIENS
+2 IF '$DATA(^XTV(8992,XQAUSER,0))
Begin DoDot:1
+3 NEW XQALFM,XQALFM1
+4 SET XQALFM1(1)=XQAUSER
+5 SET XQALFM(8992,"+1,",.01)=XQAUSER
+6 DO UPDATE^DIE("","XQALFM","XQALFM1")
+7 QUIT
End DoDot:1
+8 SET XQAIENS=XQAUSER_","
+9 ; P366 - force no start date/time to NOW, and anything less than NOW to NOW
+10 IF $GET(XQALSTRT)<$$NOW^XLFDT()
SET XQALSTRT=$$NOW^XLFDT()
+11 ; P366 - add values to new multiple
+12 SET XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT
+13 SET XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO
+14 ;p602 force end date/time to be after start date/time
IF (XQALEND>0)&(XQALEND'>XQALSTRT)
SET XQALEND=$$FMADD^XLFDT(XQALSTRT,0,0,0,1)
+15 IF XQALEND>0
SET XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND
+16 KILL XQALIEN
DO UPDATE^DIE("","XQALFM","XQALIEN")
+17 ; P366 - if start date time is already in effect - place in old locations to make active
+18 ;D ACTIVATE(XQAUSER,XQALIEN(1)) ; P513 activate if current or next
+19 ; p602 activate only if current
IF XQALSTRT'>$$NOW^XLFDT()
DO ACTIVATE(XQAUSER,XQALIEN(1))
+20 NEW XQAMESG,XMSUB,XMTEXT
+21 SET XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for"
+22 SET XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT)
+23 IF $GET(XQALEND)'>0
SET XQAMESG(2,0)=XQAMESG(2,0)_"."
+24 IF '$TEST
SET XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND)
+25 SET XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
+26 SET XMTEXT="XQAMESG("
+27 ; ZEXCEPT: XTMUNIT - Defined if unit tests are being run
+28 if '$DATA(XTMUNIT)
DO SENDMESG
+29 QUIT
+30 ;
ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate
+1 NEW X0,XQALFM,XQALSURO,XQALSTRT,XQALEND
+2 SET X0=$GET(^XTV(8992,XQAUSER,2,XQALIEN,0))
if X0=""
QUIT
SET XQALSTRT=$PIECE(X0,U)
SET XQALSURO=$PIECE(X0,U,2)
SET XQALEND=$PIECE(X0,U,3)
+3 SET X0=^XTV(8992,XQAUSER,0)
+4 ; If we are activating a new surrogate, if one exists simply remove.
IF $PIECE(X0,U,2)>0
IF $PIECE(X0,U,3)'>$$NOW^XLFDT()
DO REMVSURO(XQAUSER)
+5 KILL XQALFM
SET XQALFM(8992,XQAUSER_",",.03)=XQALSTRT
+6 SET XQALFM(8992,XQAUSER_",",.02)=XQALSURO
+7 SET XQALFM(8992,XQAUSER_",",.04)=$SELECT($GET(XQALEND)>0:XQALEND,1:"@")
+8 DO FILE^DIE("","XQALFM")
+9 QUIT
+10 ;
+11 ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0
SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ;EXTRINSIC. ICR #3213 (supported)
+1 ; This should be used instead of SETSURO
+2 ; P513 moved from SETSUROX+2
IF $GET(XQAUSER)'>0
QUIT "Invalid Internal Entry Number for user ("_XQAUSER_")"
+3 ; P513 moved from SETSUROX+3
IF $GET(XQALSURO)'>0
QUIT "Invalid Internal Entry Number for surrogate ("_XQALSURO_")"
+4 IF $GET(XQALSTRT)'>0
SET XQALSTRT=$$NOW^XLFDT()
+5 NEW XQAVAL
+6 ; Can't use as surrogate
SET XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$GET(XQALEND))
IF XQAVAL'>0
QUIT XQAVAL
+7 ; P443
DO SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$GET(XQALEND))
+8 QUIT XQALSURO
+9 ;
CHKREMV ;
+1 NEW DIR,XQAI,XQAQUIT,XQASLIST,XQAVAL,YVAL,Y
+2 ; ZEXCEPT: XQAUSER (EXTERNAL VALUE)
+3 ; p730
+4 ;D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
+5 ; Display list and allow user to remove surrogate periods until satisfied
+6 SET XQAQUIT=0
FOR
Begin DoDot:1
+7 DO DISPSUR^XQALSUR2(XQAUSER,.XQASLIST)
+8 if $GET(XQASLIST)<=0
QUIT
+9 SET DIR(0)="Y"
SET DIR("B")="NO"
+10 SET DIR("A")="Do you want to REMOVE "_$SELECT(XQASLIST>1:"a",1:"THIS")_" surrogate recipient"
+11 SET DIR("?")="A surrogate will receive your alerts until they are removed as surrogate."
+12 DO ^DIR
KILL DIR
SET XQAQUIT='+Y
+13 if XQAQUIT
QUIT
+14 SET DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove"
+15 SET Y=1
IF XQASLIST>1
SET DIR(0)="L^1:"_XQASLIST
DO ^DIR
KILL DIR
+16 IF Y>0
SET YVAL=Y
FOR XQAI=1:1
SET XQAVAL=+$PIECE(YVAL,",",XQAI)
if XQAVAL'>0
QUIT
DO REMVSURO(XQAUSER,$PIECE(XQASLIST(XQAVAL),U),$PIECE(XQASLIST(XQAVAL),U,3))
+17 WRITE !
End DoDot:1
if $GET(XQASLIST)<1!XQAQUIT
QUIT
+18 QUIT
+19 ;
+20 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ;SR. ICR #2790 (supported)
+1 ; Ends the currently active surrogate relationship
+2 IF $GET(XQAUSER)'>0
QUIT
+3 DO REMVSURO^XQALSUR1(XQAUSER,$GET(XQALSURO),$GET(XQALSTRT))
+4 QUIT
+5 ;
+6 ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range
CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. ICR #2790 (supported)
+1 ; Returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ)
+2 NEW X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI
+3 DO CHEKSUBS^XQALSUR2(XQAUSER)
+4 ; P366 - check for current in specified date/times
IF $GET(XQASTRT)>0
QUIT $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$GET(XQAEND))
+5 ;
+6 ; P366 - find the latest start time which is now or past or the first one in the future
+7 SET XQANOW=$$NOW^XLFDT()
Begin DoDot:1
+8 SET XQAIVAL=0
SET XQASTR1=0
+9 FOR XQASTRT=0:0
SET XQASTRT=$ORDER(^XTV(8992,XQAUSER,2,"B",XQASTRT))
if XQASTRT'>0
QUIT
if XQASTRT'<XQANOW
QUIT
SET XQASTR1=XQASTRT
FOR XQAI=0:0
SET XQAI=$ORDER(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI))
if XQAI'>0
QUIT
Begin DoDot:2
+10 ; p754 somebody removed surr by gbl kill, cleanup
+11 IF '$DATA(^XTV(8992,XQAUSER,2,XQAI,0))
KILL ^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)
QUIT
+12 SET XQAEND=$PIECE(^XTV(8992,XQAUSER,2,XQAI,0),U,3)
IF (XQAEND="")!(XQAEND>XQANOW)
SET XQAIVAL=XQAI
+13 QUIT
End DoDot:2
+14 ; 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
+15 IF XQAIVAL=0
SET XQASTRT=$ORDER(^XTV(8992,XQAUSER,2,"B",XQASTR1))
if XQASTRT=""
QUIT
FOR XQAI=0:0
SET XQAI=$ORDER(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI))
if XQAI'>0
QUIT
Begin DoDot:2
+16 ; p754 somebody removed surr by gbl kill, cleanup
+17 IF '$DATA(^XTV(8992,XQAUSER,2,XQAI,0))
KILL ^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)
QUIT
+18 SET XQAEND=$PIECE(^XTV(8992,XQAUSER,2,XQAI,0),U,3)
IF (XQAEND="")!(XQAEND>XQANOW)
SET XQAIVAL=XQAI
+19 QUIT
End DoDot:2
if XQAIVAL>0
QUIT
+20 IF XQAIVAL>0
SET XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0)
SET XQASTRT=^XTV(8992,XQAUSER,0)
IF ($PIECE(XQA0,U,2)'=$PIECE(XQASTRT,U,2))!($PIECE(XQA0,U)'=$PIECE(XQASTRT,U,3))!(+$PIECE(XQA0,U,3)'=+$PIECE(XQASTRT,U,4))
DO ACTIVATE(XQAUSER,XQAIVAL)
+21 QUIT
End DoDot:1
+22 ; P366 - end
+23 SET X=$GET(^XTV(8992,XQAUSER,0))
+24 ; now check for a CURRENT surrogate, already started and not expired or cyclic
+25 IF $PIECE(X,U,2)>0
IF +$PIECE(X,U,3)'>XQANOW
Begin DoDot:1
+26 ; Get Current date/time to check date/times if present
NEW DATE
+27 ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR
+28 ; Current Date/time past End date for surrogate
+29 SET DATE=$PIECE(X,U,4)
IF (DATE>0&(DATE<XQANOW))
DO REMVSURO(XQAUSER)
QUIT
+30 ; P513 quit if not already active
+31 ; P513
SET DATE=$PIECE(X,U,3)
if DATE=""
SET DATE=XQANOW
IF DATE>XQANOW
QUIT
+32 NEW XQASURO,XQASURO1
SET XQASURO1=+$PIECE(^XTV(8992,XQAUSER,0),U,2)
+33 ; REMOVE IF SURROGATE IS USER
+34 IF XQASURO1=XQAUSER
DO REMVSURO(XQAUSER)
QUIT
+35 ; p754 cyclic checks are done at surrogate creation time and the following is not needed
QUIT
End DoDot:1
IF $PIECE($GET(^XTV(8992,XQAUSER,0)),U,2)>0
QUIT +$PIECE(^XTV(8992,XQAUSER,0),U,2)
+36 QUIT -1
+37 ;. N XQALLIST,XQAUDATE S XQAUDATE=DATE,XQALLIST(XQAUSER,DATE)="" ; P513 JLI 100504 add XQAUDATE to be able to check earlier start time
+38 ;. ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts
+39 ;. ; P513 but ignore if surrogate isn't already active - JLI 100504
+40 ;. ; begin changes in P513
+41 ;. S XQASURO1=XQAUSER
+42 ;. 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
+43 ;. . ;I $D(XQALLIST(XQASURO1)) D
+44 ;. . I $D(XQALLIST(XQASURO)) D ; p730 check on NEXT surrogate and not on XQAUSER for first pass
+45 ;. . . N DATE1 S DATE1=$O(XQALLIST(XQASURO1,""))
+46 ;. . . ; remove the surrogate relationship that started earliest
+47 ;. . . I DATE<DATE1 D REMVSURO(XQASURO)
+48 ;. . . I DATE1<=DATE D REMVSURO(XQASURO1)
+49 ;. . . S XQASURO=XQAUSER K XQALLIST S DATE=XQAUDATE ; start over
+50 ;. . . Q
+51 ;. . S XQALLIST(XQASURO,DATE)=""
+52 ;. . ; end of P513 modification
+53 ;. . Q
+54 ;. ; END OF P443 MODIFICATION
+55 ;. Q
+56 ;Q -1
+57 ;
ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1)
+1 NEW DATA
+2 ; NO SURROGATE SPECIFIED
SET DATA=$GET(^XTV(8992,XQAUSER,0))
if $PIECE(DATA,U,2)=""
QUIT 0
+3 ; START DATE/TIME NOT YET
IF $PIECE(DATA,U,3)>0
IF $PIECE(DATA,U,3)>$$NOW^XLFDT()
QUIT 0
+4 ; PAST END DATE/TIME
IF $PIECE(DATA,U,4)>0
IF $PIECE(DATA,U,4)<$$NOW^XLFDT()
QUIT 0
+5 QUIT 1
+6 ;
ACTVSURO(XQAUSER) ;SR. ICR #2790 (supported)
+1 ; Returns the actual surrogate at this time
+2 NEW CURRSURO,NEXTSURO,SURODATA,NOW
+3 SET NOW=$$NOW^XLFDT()
+4 SET CURRSURO=$$CURRSURO(XQAUSER)
SET SURODATA=$$GETSURO(XQAUSER)
IF (CURRSURO'>0)!(+$PIECE(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO)))
QUIT -1
+5 FOR
SET NEXTSURO=$$CURRSURO(CURRSURO)
SET SURODATA=$$GETSURO(CURRSURO)
if NEXTSURO'>0
QUIT
if +$PIECE(SURODATA,U,3)>NOW
QUIT
if '(+$$ACTIVE^XUSER(NEXTSURO))
QUIT
SET CURRSURO=NEXTSURO
+6 QUIT CURRSURO
+7 ;
GETSURO(XQAUSER) ;EXTRINSIC. ICR #3213 (supported)
+1 ; Returns data for surrogate for user including times
+2 IF $$CURRSURO(XQAUSER)'>0
QUIT ""
+3 NEW GLOBREF,IENS,X
+4 SET IENS=XQAUSER_","
SET GLOBREF=$NAME(^TMP($JOB,"XQALSURO"))
KILL @GLOBREF
+5 DO GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF)
+6 SET GLOBREF=$NAME(@GLOBREF@(8992,IENS))
+7 SET X=$GET(@GLOBREF@(.02,"I"))_U_$GET(@GLOBREF@(.02,"E"))_U_$GET(@GLOBREF@(.03,"I"))_U_$GET(@GLOBREF@(.04,"I"))
+8 KILL @GLOBREF
+9 QUIT X
+10 ;
GETFOR ;OPT.
+1 NEW XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y
+2 SET DIR(0)="PD^200:AEMQ"
+3 SET DIR("A")="Select Surrogate (NEW PERSON entry)"
+4 SET DIR("A",1)=""
SET DIR("A",2)=""
+5 ;p602
SET DIR("A",3)=" - List Users who have chosen this User to be their current Surrogate."
+6 SET DIR("A",4)=""
+7 DO ^DIR
KILL DIR
if Y'>0
QUIT
WRITE " ",$PIECE(Y,U,2)
+8 SET XQAUSER=+Y
+9 DO SUROFOR(.VALUES,XQAUSER)
IF VALUES'>0
WRITE !,"No entries found.",!!
QUIT
+10 SET XQACNT=0
KILL DIRUT
FOR I=0:0
SET I=$ORDER(VALUES(I))
if I'>0
QUIT
if (XQACNT>(IOSL-4))
Begin DoDot:1
+11 SET DIR(0)="E"
DO ^DIR
KILL DIR
+12 QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
WRITE !,?5,$PIECE(VALUES(I),U,2)
SET XQACNT=XQACNT+1
+13 KILL DIRUT
+14 QUIT
+15 ;
SUROLIST(XQAUSER,XQALIST) ;SR. ICR #3213 (supported)
+1 ; Returns list of current and scheduled surrogates for XQAUSER
+2 DO SUROLIST^XQALSUR1(XQAUSER,.XQALIST)
+3 QUIT
+4 ;
SUROFOR(LIST,XQAUSER) ;SR. ICR #3213 (supported)
+1 ; Returns list of users XQAUSER is acting as a surrogate for
+2 IF $GET(XQAUSER)=""
QUIT
+3 NEW I,COUNT
SET I=0
SET COUNT=0
FOR
SET I=$ORDER(^XTV(8992,"AC",XQAUSER,I))
if I'>0
QUIT
IF $$CURRSURO(I)>0
Begin DoDot:1
+4 SET COUNT=COUNT+1
SET LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E")
End DoDot:1
+5 SET LIST=COUNT
+6 QUIT
+7 ;
SENDMESG ;
+1 NEW XMY,XMDUZ,XMCHAN
+2 ; ZEXCEPT: XQALSURO (EXTERNAL VALUE)
+3 SET XMY(XQALSURO)=""
SET XMDUZ=.5
+4 DO ^XMD
+5 QUIT
