source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALGUI.m@ 1696

XQALGUI ; SFCIOFO/JLI - KERNEL COMPONENTS FOR ALERTS ;3/15/02  11:24
 ;;8.0;KERNEL;**207**;Jul 10, 1995
 ;
 ;  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)=$G(^XTV(8992,DUZ,"XQA",IEN,3))
 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
 ;