XQALGUI ; SFCIOFO/JLI - KERNEL COMPONENTS FOR ALERTS ;07/24/11 15:02
;;8.0;KERNEL;**207,513**;Jul 10, 1995;Build 13
;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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALGUI 4084 printed Dec 13, 2024@02:05:25 Page 2
XQALGUI ; SFCIOFO/JLI - KERNEL COMPONENTS FOR ALERTS ;07/24/11 15:02
+1 ;;8.0;KERNEL;**207,513**;Jul 10, 1995;Build 13
+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 ;
