Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XQALSURO

XQALSURO.m

Go to the documentation of this file. 
  1. 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
  1.  ;Per VHA Directive 2004-038, this routine should not be modified
  1.  Q
  1. OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER
  1.  N XQAUSER,DIR,Y
  1.  S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which"
  1.  S DIR("A")="NEW PERSON entry"
  1.  D ^DIR K DIR Q:Y'>0  W "  ",$P(Y,U,2)
  1.  S XQAUSER=+Y
  1.  G SURROGAT
  1.  Q
  1.  ;
  1. SURROGAT ; USER SPECIFICATION OF SURROGATE
  1.  I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
  1.  D SURRO1^XQALSUR1(XQAUSER)
  1.  Q
  1.  ;
  1. CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates
  1.  I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_$$NAME^XUSER(XQALSURO,"F")_") as a surrogate!" ;P443
  1.  I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443
  1.  I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND))
  1.  ;p602 in SURRO11^XQALSUR1 split the check for cyclical surrogates into two parts. The following code becomes unnecessary.
  1.  ;N XQALSTRT
  1.  ;S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D
  1.  ;. I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q
  1.  ;. 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
  1.  ;. Q
  1.  Q XQALSURO
  1.  ;
  1. SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. ICR #2790 (Supported)
  1.  ; Use SETSURO1 instead
  1.  N XQALVAL ; P443
  1.  S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443
  1.  Q
  1.  ;
  1. SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT
  1.  N XQALFM,XQALIEN,XQAIENS
  1.  I '$D(^XTV(8992,XQAUSER,0)) D
  1.  . N XQALFM,XQALFM1
  1.  . S XQALFM1(1)=XQAUSER
  1.  . S XQALFM(8992,"+1,",.01)=XQAUSER
  1.  . D UPDATE^DIE("","XQALFM","XQALFM1")
  1.  . Q
  1.  S XQAIENS=XQAUSER_","
  1.  ; P366 - force no start date/time to NOW, and anything less than NOW to NOW
  1.  I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT()
  1.  ; P366 - add values to new multiple
  1.  S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT
  1.  S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO
  1.  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
  1.  I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND
  1.  K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN")
  1.  ; P366 - if start date time is already in effect - place in old locations to make active
  1.  ;D ACTIVATE(XQAUSER,XQALIEN(1)) ; P513 activate if current or next
  1.  I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) ; p602 activate only if current
  1.  N XQAMESG,XMSUB,XMTEXT
  1.  S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for"
  1.  S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT)
  1.  I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"."
  1.  E  S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND)
  1.  S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
  1.  S XMTEXT="XQAMESG("
  1.  ; ZEXCEPT: XTMUNIT   - Defined if unit tests are being run
  1.  D:'$D(XTMUNIT) SENDMESG
  1.  Q
  1.  ;
  1. ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate
  1.  N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND
  1.  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)
  1.  S X0=^XTV(8992,XQAUSER,0)
  1.  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.
  1.  K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT
  1.  S XQALFM(8992,XQAUSER_",",.02)=XQALSURO
  1.  S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@")
  1.  D FILE^DIE("","XQALFM")
  1.  Q
  1.  ;
  1.  ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND)  returns 0 if invalid, otherwise > 0
  1. SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ;EXTRINSIC. ICR #3213 (supported)
  1.  ; This should be used instead of SETSURO
  1.  I $G(XQAUSER)'>0 Q "Invalid Internal Entry Number for user ("_XQAUSER_")" ; P513 moved from SETSUROX+2
  1.  I $G(XQALSURO)'>0 Q "Invalid Internal Entry Number for surrogate ("_XQALSURO_")" ; P513 moved from SETSUROX+3
  1.  I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT()
  1.  N XQAVAL
  1.  S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate
  1.  D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443
  1.  Q XQALSURO
  1.  ;
  1. CHKREMV ;
  1.  N DIR,XQAI,XQAQUIT,XQASLIST,XQAVAL,YVAL,Y
  1.  ; ZEXCEPT: XQAUSER    (EXTERNAL VALUE)
  1.  ; p730
  1.  ;D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
  1.  ; Display list and allow user to remove surrogate periods until satisfied
  1.  S XQAQUIT=0 F  D  Q:$G(XQASLIST)<1!XQAQUIT
  1.  . D DISPSUR^XQALSUR2(XQAUSER,.XQASLIST)
  1.  . Q:$G(XQASLIST)<=0
  1.  . S DIR(0)="Y",DIR("B")="NO"
  1.  . S DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient"
  1.  . S DIR("?")="A surrogate will receive your alerts until they are removed as surrogate."
  1.  . D ^DIR K DIR S XQAQUIT='+Y
  1.  . Q:XQAQUIT
  1.  . S DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove"
  1.  . S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST D ^DIR K DIR
  1.  . 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))
  1.  . W !
  1.  Q
  1.  ;
  1.  ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
  1. REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ;SR. ICR #2790 (supported)
  1.  ; Ends the currently active surrogate relationship
  1.  I $G(XQAUSER)'>0 Q
  1.  D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT))
  1.  Q
  1.  ;
  1.  ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range
  1. CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. ICR #2790 (supported)
  1.  ; Returns current surrogate for user or -1  usage $$CURRSURO^XQALSURO(DUZ)
  1.  N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI
  1.  D CHEKSUBS^XQALSUR2(XQAUSER)
  1.  I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times
  1.  ;
  1.  ; P366 - find the latest start time which is now or past or the first one in the future
  1.  S XQANOW=$$NOW^XLFDT() D
  1.  . S XQAIVAL=0,XQASTR1=0
  1.  . 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
  1.  . . ; p754 somebody removed surr by gbl kill, cleanup
  1.  . . I '$D(^XTV(8992,XQAUSER,2,XQAI,0)) K ^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI) Q
  1.  . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
  1.  . . Q
  1.  . ; 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
  1.  . 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
  1.  . . ; p754 somebody removed surr by gbl kill, cleanup
  1.  . . I '$D(^XTV(8992,XQAUSER,2,XQAI,0)) K ^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI) Q
  1.  . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
  1.  . . Q
  1.  . 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)
  1.  . Q
  1.  ; P366 - end
  1.  S X=$G(^XTV(8992,XQAUSER,0))
  1.  ; now check for a CURRENT surrogate, already started and not expired or cyclic
  1.  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)
  1.  . N DATE ;   Get Current date/time to check date/times if present
  1.  . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR
  1.  . ;  Current Date/time past End date for surrogate
  1.  . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW)) D REMVSURO(XQAUSER) Q
  1.  . ; P513 quit if not already active
  1.  . S DATE=$P(X,U,3) S:DATE="" DATE=XQANOW I DATE>XQANOW Q  ; P513
  1.  . N XQASURO,XQASURO1 S XQASURO1=+$P(^XTV(8992,XQAUSER,0),U,2)
  1.  . ; REMOVE IF SURROGATE IS USER
  1.  . I XQASURO1=XQAUSER D REMVSURO(XQAUSER) Q
  1.  . Q  ; p754 cyclic checks are done at surrogate creation time and the following is not needed
  1.  Q -1
  1.  ;. N XQALLIST,XQAUDATE S XQAUDATE=DATE,XQALLIST(XQAUSER,DATE)="" ; P513 JLI 100504 add XQAUDATE to be able to check earlier start time
  1.  ;. ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts
  1.  ;. ; P513 but ignore if surrogate isn't already active - JLI 100504
  1.  ;. ; begin changes in P513
  1.  ;. S XQASURO1=XQAUSER
  1.  ;. 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
  1.  ;. . ;I $D(XQALLIST(XQASURO1)) D
  1.  ;. . I $D(XQALLIST(XQASURO)) D  ; p730 check on NEXT surrogate and not on XQAUSER for first pass
  1.  ;. . . N DATE1 S DATE1=$O(XQALLIST(XQASURO1,""))
  1.  ;. . . ; remove the surrogate relationship that started earliest
  1.  ;. . . I DATE<DATE1 D REMVSURO(XQASURO)
  1.  ;. . . I DATE1<=DATE D REMVSURO(XQASURO1)
  1.  ;. . . S XQASURO=XQAUSER K XQALLIST S DATE=XQAUDATE ; start over
  1.  ;. . . Q
  1.  ;. . S XQALLIST(XQASURO,DATE)=""
  1.  ;. . ; end of P513 modification
  1.  ;. . Q
  1.  ;. ; END OF P443 MODIFICATION
  1.  ;. Q
  1.  ;Q -1
  1.  ;
  1. ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1)
  1.  N DATA
  1.  S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0  ; NO SURROGATE SPECIFIED
  1.  I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0  ; START DATE/TIME NOT YET
  1.  I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0  ; PAST END DATE/TIME
  1.  Q 1
  1.  ;
  1. ACTVSURO(XQAUSER) ;SR. ICR #2790 (supported)
  1.  ; Returns the actual surrogate at this time
  1.  N CURRSURO,NEXTSURO,SURODATA,NOW
  1.  S NOW=$$NOW^XLFDT()
  1.  S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1
  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
  1.  Q CURRSURO
  1.  ;
  1. GETSURO(XQAUSER) ;EXTRINSIC. ICR #3213 (supported)
  1.  ; Returns data for surrogate for user including times
  1.  I $$CURRSURO(XQAUSER)'>0 Q ""
  1.  N GLOBREF,IENS,X
  1.  S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF
  1.  D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF)
  1.  S GLOBREF=$NA(@GLOBREF@(8992,IENS))
  1.  S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I"))
  1.  K @GLOBREF
  1.  Q X
  1.  ;
  1. GETFOR ;OPT.
  1.  N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y
  1.  S DIR(0)="PD^200:AEMQ"
  1.  S DIR("A")="Select Surrogate (NEW PERSON entry)"
  1.  S DIR("A",1)="",DIR("A",2)=""
  1.  S DIR("A",3)=" - List Users who have chosen this User to be their current Surrogate." ;p602
  1.  S DIR("A",4)=""
  1.  D ^DIR K DIR Q:Y'>0  W "  ",$P(Y,U,2)
  1.  S XQAUSER=+Y
  1.  D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q
  1.  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
  1.  . S DIR(0)="E" D ^DIR K DIR
  1.  . Q
  1.  K DIRUT
  1.  Q
  1.  ;
  1. SUROLIST(XQAUSER,XQALIST) ;SR. ICR #3213 (supported)
  1.  ; Returns list of current and scheduled surrogates for XQAUSER
  1.  D SUROLIST^XQALSUR1(XQAUSER,.XQALIST)
  1.  Q
  1.  ;
  1. SUROFOR(LIST,XQAUSER) ;SR. ICR #3213 (supported)
  1.  ; Returns list of users XQAUSER is acting as a surrogate for
  1.  I $G(XQAUSER)="" Q
  1.  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
  1.  . 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")
  1.  S LIST=COUNT
  1.  Q
  1.  ;
  1. SENDMESG ;
  1.  N XMY,XMDUZ,XMCHAN
  1.  ; ZEXCEPT: XQALSURO   (EXTERNAL VALUE)
  1.  S XMY(XQALSURO)="",XMDUZ=.5
  1.  D ^XMD
  1.  Q