[628] | 1 | XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;3/17/08 15:20
|
---|
| 2 | ;;8.0;KERNEL;**114,125,173,285,366,443**;Jul 10, 1995;Build 4
|
---|
| 3 | ;;
|
---|
| 4 | Q
|
---|
| 5 | OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER
|
---|
| 6 | N XQAUSER,DIR,Y
|
---|
| 7 | S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which"
|
---|
| 8 | S DIR("A")="NEW PERSON entry"
|
---|
| 9 | D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2)
|
---|
| 10 | S XQAUSER=+Y
|
---|
| 11 | G SURROGAT
|
---|
| 12 | Q
|
---|
| 13 | ;
|
---|
| 14 | SURROGAT ; USER SPECIFICATION OF SURROGATE
|
---|
| 15 | I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
|
---|
| 16 | D SURRO1^XQALSUR1(XQAUSER)
|
---|
| 17 | Q
|
---|
| 18 | CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates
|
---|
| 19 | I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_XQALSURO_") as a surrogate!" ;P443
|
---|
| 20 | I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443
|
---|
| 21 | I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND))
|
---|
| 22 | N XQALSTRT
|
---|
| 23 | S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D
|
---|
| 24 | . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q
|
---|
| 25 | . 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
|
---|
| 26 | . Q
|
---|
| 27 | Q XQALSURO
|
---|
| 28 | ;
|
---|
| 29 | SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; Use SETSURO1 instead
|
---|
| 30 | N XQALVAL ; P443
|
---|
| 31 | S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443
|
---|
| 32 | Q
|
---|
| 33 | ;
|
---|
| 34 | SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT
|
---|
| 35 | N XQALFM,XQALIEN,XQAIENS
|
---|
| 36 | I $G(XQAUSER)'>0 Q
|
---|
| 37 | I $G(XQALSURO)'>0 Q
|
---|
| 38 | I '$D(^XTV(8992,XQAUSER,0)) D
|
---|
| 39 | . N XQALFM,XQALFM1
|
---|
| 40 | . S XQALFM1(1)=XQAUSER
|
---|
| 41 | . S XQALFM(8992,"+1,",.01)=XQAUSER
|
---|
| 42 | . D UPDATE^DIE("","XQALFM","XQALFM1")
|
---|
| 43 | . Q
|
---|
| 44 | S XQAIENS=XQAUSER_","
|
---|
| 45 | ; P366 - force no start date/time to NOW
|
---|
| 46 | ; P366 - change to force anything less than NOW to NOW - 8/22/05
|
---|
| 47 | I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT()
|
---|
| 48 | ; P366 - add values to new multiple
|
---|
| 49 | S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT
|
---|
| 50 | S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO
|
---|
| 51 | I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND
|
---|
| 52 | K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN")
|
---|
| 53 | ; P366 - if start date time is already in effect - place in old locations to make active
|
---|
| 54 | I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1))
|
---|
| 55 | N XQAMESG,XMSUB,XMTEXT
|
---|
| 56 | S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for"
|
---|
| 57 | S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT)
|
---|
| 58 | I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"."
|
---|
| 59 | E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND)
|
---|
| 60 | S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
|
---|
| 61 | S XMTEXT="XQAMESG("
|
---|
| 62 | ; ZEXCEPT: XTMUNIT - Defined if unit tests are being run
|
---|
| 63 | D:'$D(XTMUNIT) SENDMESG
|
---|
| 64 | Q
|
---|
| 65 | ;
|
---|
| 66 | ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate
|
---|
| 67 | N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND
|
---|
| 68 | 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)
|
---|
| 69 | S X0=^XTV(8992,XQAUSER,0)
|
---|
| 70 | 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.
|
---|
| 71 | K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT
|
---|
| 72 | S XQALFM(8992,XQAUSER_",",.02)=XQALSURO
|
---|
| 73 | S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@")
|
---|
| 74 | D FILE^DIE("","XQALFM")
|
---|
| 75 | Q
|
---|
| 76 | ;
|
---|
| 77 | ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0
|
---|
| 78 | SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO
|
---|
| 79 | I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT()
|
---|
| 80 | N XQAVAL
|
---|
| 81 | S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate
|
---|
| 82 | D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443
|
---|
| 83 | Q XQALSURO
|
---|
| 84 | ;
|
---|
| 85 | CHKREMV ;
|
---|
| 86 | N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y
|
---|
| 87 | ; ZEXCEPT: XQAUSER (EXTERNAL VALUE)
|
---|
| 88 | D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
|
---|
| 89 | W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE"
|
---|
| 90 | 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))
|
---|
| 91 | W ! I XQASLIST'>0 W !," No current surrogates",! Q
|
---|
| 92 | 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
|
---|
| 93 | 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
|
---|
| 94 | 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))
|
---|
| 95 | Q
|
---|
| 96 | ;
|
---|
| 97 | ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
|
---|
| 98 | REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship
|
---|
| 99 | I $G(XQAUSER)'>0 Q
|
---|
| 100 | D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT))
|
---|
| 101 | Q
|
---|
| 102 | ;
|
---|
| 103 | ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range
|
---|
| 104 | CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ)
|
---|
| 105 | N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI
|
---|
| 106 | D CHEKSUBS^XQALSUR2(XQAUSER)
|
---|
| 107 | I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times
|
---|
| 108 | ;
|
---|
| 109 | ; P366 - find the latest start time which is now or past or the first one in the future
|
---|
| 110 | S XQANOW=$$NOW^XLFDT() D
|
---|
| 111 | . S XQAIVAL=0,XQASTR1=0
|
---|
| 112 | . 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
|
---|
| 113 | . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
|
---|
| 114 | . . Q
|
---|
| 115 | . ; 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
|
---|
| 116 | . 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
|
---|
| 117 | . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
|
---|
| 118 | . . Q
|
---|
| 119 | . 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)
|
---|
| 120 | . Q
|
---|
| 121 | ; P366 - end
|
---|
| 122 | S X=$G(^XTV(8992,XQAUSER,0))
|
---|
| 123 | ; now check for a CURRENT surrogate, already started and not expired or cyclic
|
---|
| 124 | 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)
|
---|
| 125 | . N DATE ; Get Current date/time to check date/times if present
|
---|
| 126 | . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR
|
---|
| 127 | . ; Current Date/time past End date for surrogate
|
---|
| 128 | . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW)) D REMVSURO(XQAUSER) Q
|
---|
| 129 | . N XQASURO,XQASURO1 S XQASURO1=+$P(^XTV(8992,XQAUSER,0),U,2)
|
---|
| 130 | . ; REMOVE IF SURROGATE IS USER
|
---|
| 131 | . I XQASURO1=XQAUSER D REMVSURO(XQAUSER) Q
|
---|
| 132 | . N XQALLIST S XQALLIST(XQAUSER)=""
|
---|
| 133 | . ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts
|
---|
| 134 | . F S XQASURO=$P($G(^XTV(8992,XQASURO1,0)),U,2) Q:XQASURO'>0 Q:'$$ISACTIVE(XQASURO) S XQASURO1=XQASURO D
|
---|
| 135 | . . I $D(XQALLIST(XQASURO)) D REMVSURO(XQASURO) S XQASURO1=XQAUSER K XQALLIST S XQALLIST(XQAUSER)="" Q
|
---|
| 136 | . . S XQALLIST(XQASURO1)=""
|
---|
| 137 | . . Q
|
---|
| 138 | . ; END OF P443 MODIFICATION
|
---|
| 139 | . Q
|
---|
| 140 | Q -1
|
---|
| 141 | ;
|
---|
| 142 | ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1)
|
---|
| 143 | N DATA
|
---|
| 144 | S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0 ; NO SURROGATE SPECIFIED
|
---|
| 145 | I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0 ; START DATE/TIME NOT YET
|
---|
| 146 | I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0 ; PAST END DATE/TIME
|
---|
| 147 | Q 1
|
---|
| 148 | ;
|
---|
| 149 | ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time
|
---|
| 150 | N CURRSURO,NEXTSURO,SURODATA,NOW
|
---|
| 151 | S NOW=$$NOW^XLFDT()
|
---|
| 152 | S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1
|
---|
| 153 | F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO
|
---|
| 154 | Q CURRSURO
|
---|
| 155 | ;
|
---|
| 156 | GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times
|
---|
| 157 | I $$CURRSURO(XQAUSER)'>0 Q ""
|
---|
| 158 | N GLOBREF,IENS,X
|
---|
| 159 | S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF
|
---|
| 160 | D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF)
|
---|
| 161 | S GLOBREF=$NA(@GLOBREF@(8992,IENS))
|
---|
| 162 | S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I"))
|
---|
| 163 | K @GLOBREF
|
---|
| 164 | Q X
|
---|
| 165 | ;
|
---|
| 166 | GETFOR ;OPT.
|
---|
| 167 | N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y
|
---|
| 168 | S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate."
|
---|
| 169 | S DIR("A")="Select User (NEW PERSON entry)"
|
---|
| 170 | D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2)
|
---|
| 171 | S XQAUSER=+Y
|
---|
| 172 | D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q
|
---|
| 173 | 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
|
---|
| 174 | . S DIR(0)="E" D ^DIR K DIR
|
---|
| 175 | . Q
|
---|
| 176 | K DIRUT
|
---|
| 177 | Q
|
---|
| 178 | ;
|
---|
| 179 | SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER
|
---|
| 180 | D SUROLIST^XQALSUR1(XQAUSER,.XQALIST)
|
---|
| 181 | Q
|
---|
| 182 | ;
|
---|
| 183 | SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for
|
---|
| 184 | I $G(XQAUSER)="" Q
|
---|
| 185 | 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
|
---|
| 186 | . 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")
|
---|
| 187 | S LIST=COUNT
|
---|
| 188 | Q
|
---|
| 189 | ;
|
---|
| 190 | SENDMESG ;
|
---|
| 191 | N XMY,XMDUZ,XMCHAN
|
---|
| 192 | ; ZEXCEPT: XQALSURO (EXTERNAL VALUE)
|
---|
| 193 | S XMY(XQALSURO)="",XMDUZ=.5
|
---|
| 194 | D ^XMD
|
---|
| 195 | Q
|
---|