XQALGUI.m

XQALGUI ; SFCIOFO/JLI - KERNEL COMPONENTS FOR ALERTS ;07/24/11  15:02

 ;;8.0;KERNEL;**207,513**;Jul 10, 1995;Build 16

 ;Per VHA Directive 2004-038, this routine should not be modified

 ;

 ;  added CURRSURO and SETSURO entry points  3/21/00  jli

 ;

 ; All entry is at the ENTRY tag.  The type of processing is indicated by the

 ; variable LOC which contains the name of the tag to be used for processing.

 ; The following tags currently exist and expect the variable names indicated

 ;

 ;  SEND

 ;  GETLIST

 ;  ISPEND

 ;  ISNEW

 ;  DELETE

 ;  FORWARD

 ;  CURRSURO

 ;  SETSURO

 ;

ENTRY(XQALRSLT,DATA) ;

 K ^TMP($J) N I,LOC,XQA,XQACTMSG,XQAEND,XQAID,XQALFWD,XQALRSL1,XQAMSG,XQASTART,XQASURO,XQATEXT

 N NAME,XQALSTO S NAME="" S XQALSTO=$NA(^TMP("XQALXQAL",$J)) K @XQALSTO

 F  S NAME=$O(DATA(NAME)) Q:NAME=""  D  I $E(NAME)'=U S @("^TMP(""XQALXQAL"",$J,"_NAME1_")")=DATA(NAME)

 . I $E(NAME)=U S @NAME=DATA(NAME) Q

 . S NAME1=""""

 . F I=1:1 S X=$P(NAME,",",I) Q:X=""  S NAME1=NAME1_$S(I>1:",""",1:"")_X_""""

 S NAME="" F  S NAME=$O(@XQALSTO@(NAME)) Q:NAME=""  D:$D(@XQALSTO@(NAME))>1  I $D(@XQALSTO@(NAME))=1 N @NAME S @NAME=@XQALSTO@(NAME)

 . N NAME1 S NAME1=""

 . F  S NAME1=$O(@XQALSTO@(NAME,NAME1)) Q:NAME1=""  S @(NAME_"("""_NAME1_""")")=^(NAME1)

 Q:'$D(LOC)

 ; need to add code here to check key if XQAUSER is defined and not DUZ

 G @LOC

 ;

2 ;

SEND ;

SETUP ; ENTRY FOR SETUP NEW ALERT

 I '$D(XQAUSER) S XQAUSER=DUZ

 Q:($O(XQA(""))="")  Q:'$D(XQAMSG)

 I $D(^TMP($J,"XQAL1")) S XQATEXT=$NA(^TMP($J,"XQAL1"))

 D SETUP^XQALERT ; Supported Reference

 Q

 ;

GETLIST ; GET LIST OF ALERTS FOR USER

 I '$D(XQAUSER) S XQAUSER=DUZ

 S XQALRSLT=$NA(^TMP($J)),XQALRSL1=$NA(^TMP("XQALXQAL",$J)) K @XQALRSL1,@XQALRSLT

 D GETUSER1^XQALDATA(XQALRSL1,XQAUSER) ;

 F I=0:0 S I=$O(@XQALRSL1@(I)) Q:I'>0  S X=^(I) K ^(I) S @XQALRSLT@(I)=X

 Q

 ;

ISPEND ;

 S XQALRSLT=$NA(^TMP($J,"XQALXQAL")) K @XQALRSLT

 I $O(^XTV(8992,DUZ,"XQA",0))>0 S @XQALRSLT@(1)=1

 E  S @XQALRSLT@(1)=0

 Q

 ;

ISNEW ;

 S XQALRSLT=$NA(^TMP($J,"XQALXQAL")) K @XQALRSLT

 S @XQALRSLT@(1)=0

 F I=0:0 S I=$O(^XTV(8992,DUZ,"XQA",I)) Q:I'>0  I $P($G(^(I,0)),U,4)>0 S @XQALRSLT@(1)=1 Q

 Q

 ;

DELETE ;

 I '$D(XQAUSER) S XQAUSER=DUZ

 D DELETE^XQALERT

 Q

 ;

FORWARD ;

 I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ

 S XQALFWD(1)=IEN

 D FORWARD^XQALFWD(.XQALFWD,.XQA,"A",$G(XQACTMSG))

 Q

 ;

GETSURO ; GET CURRENT SURROGATE INFORMATION (IF ANY)

 I '$D(XQAUSER) S XQAUSER=DUZ

 N X S X=$$GETSURO^XQALSURO(XQAUSER) I X'>0 S X="" ; SUPPORTED REFERENCE

 S XQALRSLT=$NA(^TMP($J,"XQALXQAL")) K @XQALRSLT

 S @XQALRSLT@(1)=X

 Q

 ;

SETSURO ; SET NEW SURROGATE

 Q:XQASURO'>0

 I '$D(XQAUSER) S XQAUSER=DUZ

 S XQALRSLT=$NA(^TMP("XQALRSLT",$J)) K @XQALRSLT

 S @XQALRSLT@(1)=$$SETSURO1^XQALSURO(XQAUSER,XQASURO,XQASTART,XQAEND) ; SUPPORTED REFERENCE

 Q

 ;

SUROFOR ;

 N SUROLIST S XQALRSLT=$NA(^TMP("XQALRSLT",$J)) K @XQALRSLT

 I '$D(XQAUSER) S XQAUSER=DUZ

 D SUROFOR^XQALSURO(.SUROLIST,XQAUSER)

 M @XQALRSLT=SUROLIST

 Q

 Q

 ;

REMVSURO ; REMOVE SURROGATE

 I '$D(XQAUSER) S XQAUSER=DUZ

 D REMVSURO^XQALSURO(XQAUSER) ; SUPPORTED REFERENCE

 Q

 ;

GETDATA ;

 S XQALRSLT=$NA(^TMP("XQALRSLT",$J)) K @XQALRSLT

 N IEN S IEN=$O(^XTV(8992,"AXQA",XQAID,DUZ,0)) Q:IEN'>0

 S @XQALRSLT@(1)=$P(^XTV(8992,DUZ,"XQA",IEN,0),U,7,8)

 S @XQALRSLT@(2)=$G(^XTV(8992,DUZ,"XQA",IEN,1))

 S @XQALRSLT@(3)=$P($G(^XTV(8992,DUZ,"XQA",IEN,3)),U)

 Q

 ;

GETLONG ; TAKE LONG TEXT BACK TO THE CLIENT

 S XQALRSLT=$NA(^TMP("XQALRSLT",$J)) K @XQALRSLT

 I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ

 N IEN,IENS,XQALTMP S IEN=$O(^XTV(8992,"AXQA",XQAID,XQAUSER,0)) Q:IEN'>0

 S IENS=IEN_","_XQAUSER_",",XQALTMP=$NA(^TMP($J)) K @XQALTMP

 D GETS^DIQ(8992.01,(IEN_","_XQAUSER_","),"4","",XQALTMP)

 F I=0:0 S I=$O(@XQALTMP@(8992.01,IENS,4,I)) Q:I'>0  S @XQALRSLT@(I)=^(I)

 K @XQALTMP

 Q

 ;

CHKADPAC ; Check for ADPAC or IRM status

 S XQALRSLT=$NA(^TMP("XQALRSLT",$J)) K @XQALRSLT

 N XQALVAL,RESULT S XQALVAL=0

 D OWNSKEY^XUSRB(.RESULT,"XQAL-DELETE") S XQALVAL=RESULT(0)

 S @XQALRSLT@(1)=XQALVAL

 Q

 ;

XQALGUI   ; SFCIOFO/JLI - KERNEL COMPONENTS FOR ALERTS ;07/24/11  15:02

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

 +2       ;Per VHA Directive 2004-038, this routine should not be modified

 +3       ;

 +4       ;  added CURRSURO and SETSURO entry points  3/21/00  jli

 +5       ;

 +6       ; All entry is at the ENTRY tag.  The type of processing is indicated by the

 +7       ; variable LOC which contains the name of the tag to be used for processing.

 +8       ; The following tags currently exist and expect the variable names indicated

 +9       ;

 +10      ;  SEND

 +11      ;  GETLIST

 +12      ;  ISPEND

 +13      ;  ISNEW

 +14      ;  DELETE

 +15      ;  FORWARD

 +16      ;  CURRSURO

 +17      ;  SETSURO

 +18      ;

ENTRY(XQALRSLT,DATA) ;

 +1        KILL ^TMP($JOB)

           NEW I,LOC,XQA,XQACTMSG,XQAEND,XQAID,XQALFWD,XQALRSL1,XQAMSG,XQASTART,XQASURO,XQATEXT

 +2        NEW NAME,XQALSTO

           SET NAME=""

           SET XQALSTO=$NAME(^TMP("XQALXQAL",$JOB))

           KILL @XQALSTO

 +3        FOR 

               SET NAME=$ORDER(DATA(NAME))

               IF NAME=""

                   QUIT 

               Begin DoDot:1

 +4                IF $EXTRACT(NAME)=U

                       SET @NAME=DATA(NAME)

                       QUIT 

 +5                SET NAME1=""""

 +6                FOR I=1:1

                       SET X=$PIECE(NAME,",",I)

                       IF X=""

                           QUIT 

                       SET NAME1=NAME1_$SELECT(I>1:",""",1:"")_X_""""

               End DoDot:1

               IF $EXTRACT(NAME)'=U

                   SET @("^TMP(""XQALXQAL"",$J,"_NAME1_")")=DATA(NAME)

 +7        SET NAME=""

           FOR 

               SET NAME=$ORDER(@XQALSTO@(NAME))

               IF NAME=""

                   QUIT 

               IF $DATA(@XQALSTO@(NAME))>1

                   Begin DoDot:1

 +8                    NEW NAME1

                       SET NAME1=""

 +9                    FOR 

                           SET NAME1=$ORDER(@XQALSTO@(NAME,NAME1))

                           IF NAME1=""

                               QUIT 

                           SET @(NAME_"("""_NAME1_""")")=^(NAME1)

                   End DoDot:1

               IF $DATA(@XQALSTO@(NAME))=1

                   NEW @NAME

                   SET @NAME=@XQALSTO@(NAME)

 +10       IF '$DATA(LOC)

               QUIT 

 +11      ; need to add code here to check key if XQAUSER is defined and not DUZ

 +12       GOTO @LOC

 +13      ;

2         ;

SEND      ;

SETUP     ; ENTRY FOR SETUP NEW ALERT

 +1        IF '$DATA(XQAUSER)

               SET XQAUSER=DUZ

 +2        IF ($ORDER(XQA(""))="")

               QUIT 

           IF '$DATA(XQAMSG)

               QUIT 

 +3        IF $DATA(^TMP($JOB,"XQAL1"))

               SET XQATEXT=$NAME(^TMP($JOB,"XQAL1"))

 +4       ; Supported Reference

           DO SETUP^XQALERT

 +5        QUIT 

 +6       ;

GETLIST   ; GET LIST OF ALERTS FOR USER

 +1        IF '$DATA(XQAUSER)

               SET XQAUSER=DUZ

 +2        SET XQALRSLT=$NAME(^TMP($JOB))

           SET XQALRSL1=$NAME(^TMP("XQALXQAL",$JOB))

           KILL @XQALRSL1,@XQALRSLT

 +3       ;

           DO GETUSER1^XQALDATA(XQALRSL1,XQAUSER)

 +4        FOR I=0:0

               SET I=$ORDER(@XQALRSL1@(I))

               IF I'>0

                   QUIT 

               SET X=^(I)

               KILL ^(I)

               SET @XQALRSLT@(I)=X

 +5        QUIT 

 +6       ;

ISPEND    ;

 +1        SET XQALRSLT=$NAME(^TMP($JOB,"XQALXQAL"))

           KILL @XQALRSLT

 +2        IF $ORDER(^XTV(8992,DUZ,"XQA",0))>0

               SET @XQALRSLT@(1)=1

 +3       IF '$TEST

               SET @XQALRSLT@(1)=0

 +4        QUIT 

 +5       ;

ISNEW     ;

 +1        SET XQALRSLT=$NAME(^TMP($JOB,"XQALXQAL"))

           KILL @XQALRSLT

 +2        SET @XQALRSLT@(1)=0

 +3        FOR I=0:0

               SET I=$ORDER(^XTV(8992,DUZ,"XQA",I))

               IF I'>0

                   QUIT 

               IF $PIECE($GET(^(I,0)),U,4)>0

                   SET @XQALRSLT@(1)=1

                   QUIT 

 +4        QUIT 

 +5       ;

DELETE    ;

 +1        IF '$DATA(XQAUSER)

               SET XQAUSER=DUZ

 +2        DO DELETE^XQALERT

 +3        QUIT 

 +4       ;

FORWARD   ;

 +1        IF '$DATA(XQAUSER)

               NEW XQAUSER

               SET XQAUSER=DUZ

 +2        SET XQALFWD(1)=IEN

 +3        DO FORWARD^XQALFWD(.XQALFWD,.XQA,"A",$GET(XQACTMSG))

 +4        QUIT 

 +5       ;

GETSURO   ; GET CURRENT SURROGATE INFORMATION (IF ANY)

 +1        IF '$DATA(XQAUSER)

               SET XQAUSER=DUZ

 +2       ; SUPPORTED REFERENCE

           NEW X

           SET X=$$GETSURO^XQALSURO(XQAUSER)

           IF X'>0

               SET X=""

 +3        SET XQALRSLT=$NAME(^TMP($JOB,"XQALXQAL"))

           KILL @XQALRSLT

 +4        SET @XQALRSLT@(1)=X

 +5        QUIT 

 +6       ;

SETSURO   ; SET NEW SURROGATE

 +1        IF XQASURO'>0

               QUIT 

 +2        IF '$DATA(XQAUSER)

               SET XQAUSER=DUZ

 +3        SET XQALRSLT=$NAME(^TMP("XQALRSLT",$JOB))

           KILL @XQALRSLT

 +4       ; SUPPORTED REFERENCE

           SET @XQALRSLT@(1)=$$SETSURO1^XQALSURO(XQAUSER,XQASURO,XQASTART,XQAEND)

 +5        QUIT 

 +6       ;

SUROFOR   ;

 +1        NEW SUROLIST

           SET XQALRSLT=$NAME(^TMP("XQALRSLT",$JOB))

           KILL @XQALRSLT

 +2        IF '$DATA(XQAUSER)

               SET XQAUSER=DUZ

 +3        DO SUROFOR^XQALSURO(.SUROLIST,XQAUSER)

 +4        MERGE @XQALRSLT=SUROLIST

 +5        QUIT 

 +6        QUIT 

 +7       ;

REMVSURO  ; REMOVE SURROGATE

 +1        IF '$DATA(XQAUSER)

               SET XQAUSER=DUZ

 +2       ; SUPPORTED REFERENCE

           DO REMVSURO^XQALSURO(XQAUSER)

 +3        QUIT 

 +4       ;

GETDATA   ;

 +1        SET XQALRSLT=$NAME(^TMP("XQALRSLT",$JOB))

           KILL @XQALRSLT

 +2        NEW IEN

           SET IEN=$ORDER(^XTV(8992,"AXQA",XQAID,DUZ,0))

           IF IEN'>0

               QUIT 

 +3        SET @XQALRSLT@(1)=$PIECE(^XTV(8992,DUZ,"XQA",IEN,0),U,7,8)

 +4        SET @XQALRSLT@(2)=$GET(^XTV(8992,DUZ,"XQA",IEN,1))

 +5        SET @XQALRSLT@(3)=$PIECE($GET(^XTV(8992,DUZ,"XQA",IEN,3)),U)

 +6        QUIT 

 +7       ;

GETLONG   ; TAKE LONG TEXT BACK TO THE CLIENT

 +1        SET XQALRSLT=$NAME(^TMP("XQALRSLT",$JOB))

           KILL @XQALRSLT

 +2        IF '$DATA(XQAUSER)

               NEW XQAUSER

               SET XQAUSER=DUZ

 +3        NEW IEN,IENS,XQALTMP

           SET IEN=$ORDER(^XTV(8992,"AXQA",XQAID,XQAUSER,0))

           IF IEN'>0

               QUIT 

 +4        SET IENS=IEN_","_XQAUSER_","

           SET XQALTMP=$NAME(^TMP($JOB))

           KILL @XQALTMP

 +5        DO GETS^DIQ(8992.01,(IEN_","_XQAUSER_","),"4","",XQALTMP)

 +6        FOR I=0:0

               SET I=$ORDER(@XQALTMP@(8992.01,IENS,4,I))

               IF I'>0

                   QUIT 

               SET @XQALRSLT@(I)=^(I)

 +7        KILL @XQALTMP

 +8        QUIT 

 +9       ;

CHKADPAC  ; Check for ADPAC or IRM status

 +1        SET XQALRSLT=$NAME(^TMP("XQALRSLT",$JOB))

           KILL @XQALRSLT

 +2        NEW XQALVAL,RESULT

           SET XQALVAL=0

 +3        DO OWNSKEY^XUSRB(.RESULT,"XQAL-DELETE")

           SET XQALVAL=RESULT(0)

 +4        SET @XQALRSLT@(1)=XQALVAL

 +5        QUIT 

 +6       ;