XQALSET1.m

XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;07/24/11  15:13

 ;;8.0;KERNEL;**285,443,513**;Jul 10, 1995;Build 16

 ;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

 ;

XQALSET1  ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;07/24/11  15:13

 +1       ;;8.0;KERNEL;**285,443,513**;Jul 10, 1995;Build 16

 +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       ;