XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;07/24/11 15:13
;;8.0;KERNEL;**285,443,513**;Jul 10, 1995;Build 13
;Per VHA Directive 2004-038, this routine should not be modified
Q
GROUP ;
N XQI,XQL,XQL1,XQL2,XQLIST
; ZEXCEPT: XQA,XQJ - defined in calling routine
S XQL=$E(XQJ,3,$L(XQJ)) ; P443 - changed from code that forced upper case
I $D(^TMP("XQAGROUP",$J,XQL)) Q ; P443 group has already been processed - prevent cycling
S ^TMP("XQAGROUP",$J,XQL)="" ; P443 mark that the group has been seen
S XQI=$$FIND1^DIC(3.8,,"X",XQL) I XQI'>0 K XQA(XQJ) Q ; P513 remove entry if not available
N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D
. N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 S XQA(^(XQI,.01))=""
. Q
K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D
. N XQAGROUP M XQAGROUP=@XQLIST@("ID") ; P443 - store group list data locally so it is not over written by recursive call to LIST^DIC
. 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
. Q
K @XQLIST,XQLIST
K XQA(XQJ)
D CHEKACTV(.XQA)
Q
;
; Check and remove any entries in array that don't have active surrogates and aren't active
CHEKACTV(XQARRAY) ;
N XQJ
F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0 I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ)
Q
;
CHEKUSER(XQAUSER) ; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
N VALUE
S VALUE=$$ACTVSURO^XQALSURO(XQAUSER)
I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0
Q VALUE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALSET1 1656 printed Oct 16, 2024@18:06:16 Page 2
XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;07/24/11 15:13
+1 ;;8.0;KERNEL;**285,443,513**;Jul 10, 1995;Build 13
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
GROUP ;
+1 NEW XQI,XQL,XQL1,XQL2,XQLIST
+2 ; ZEXCEPT: XQA,XQJ - defined in calling routine
+3 ; P443 - changed from code that forced upper case
SET XQL=$EXTRACT(XQJ,3,$LENGTH(XQJ))
+4 ; P443 group has already been processed - prevent cycling
IF $DATA(^TMP("XQAGROUP",$JOB,XQL))
QUIT
+5 ; P443 mark that the group has been seen
SET ^TMP("XQAGROUP",$JOB,XQL)=""
+6 ; P513 remove entry if not available
SET XQI=$$FIND1^DIC(3.8,,"X",XQL)
IF XQI'>0
KILL XQA(XQJ)
QUIT
+7 NEW XQLIST
DO LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST)
IF XQLIST("ORDER")>0
Begin DoDot:1
+8 NEW XQI
FOR XQI=0:0
SET XQI=$ORDER(@XQLIST@("ID",XQI))
if XQI'>0
QUIT
SET XQA(^(XQI,.01))=""
+9 QUIT
End DoDot:1
+10 KILL @XQLIST,XQLIST
DO LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST)
IF XQLIST("ORDER")>0
Begin DoDot:1
+11 ; P443 - store group list data locally so it is not over written by recursive call to LIST^DIC
NEW XQAGROUP
MERGE XQAGROUP=@XQLIST@("ID")
+12 ; P443 - change to reference XQAGROUP
NEW XQI
FOR XQI=0:0
SET XQI=$ORDER(XQAGROUP(XQI))
if XQI'>0
QUIT
NEW XQJ
SET XQJ="G."_XQAGROUP(XQI,.01)
DO GROUP
+13 QUIT
End DoDot:1
+14 KILL @XQLIST,XQLIST
+15 KILL XQA(XQJ)
+16 DO CHEKACTV(.XQA)
+17 QUIT
+18 ;
+19 ; Check and remove any entries in array that don't have active surrogates and aren't active
CHEKACTV(XQARRAY) ;
+1 NEW XQJ
+2 FOR XQJ=0:0
SET XQJ=$ORDER(XQARRAY(XQJ))
if XQJ'>0
QUIT
IF $$CHEKUSER(XQJ)'>0
KILL XQARRAY(XQJ)
+3 QUIT
+4 ;
CHEKUSER(XQAUSER) ; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
+1 NEW VALUE
+2 SET VALUE=$$ACTVSURO^XQALSURO(XQAUSER)
+3 IF VALUE'>0
SET VALUE=XQAUSER
IF '$$ACTIVE^XUSER(XQAUSER)
QUIT 0
+4 QUIT VALUE
+5 ;
