CIANBEVT ;MSC/IND/DKM - Event Support ;03-Dec-2009 16:53;PLS
;;1.1;CIA NETWORK COMPONENTS;**001007**;Sep 18, 2007
;;Copyright 2000-2008, Medsphere Systems Corporation
;=================================================================
; Check for the occurrence of host events
EVTCHK() ;EP
N RTN,$ET,X
S $ET="",X="ERR1^CIANBEVT",@^%ZOSF("TRAP")
L +^XTMP("CIA",CIA("UID"),"E"):0
E Q 0
S RTN=+$O(^XTMP("CIA",CIA("UID"),"E",0)),X=$NA(^(RTN))
I RTN D
.D TCPUSE^CIANBLIS
.W $C(3)
.D OUT^CIANBACT(X)
ERR1 L -^XTMP("CIA",CIA("UID"),"E")
Q $G(RTN)
; Start monitor in background if not already running
MONSTART ;EP
I '$$MONCHECK,$$QUEUE^CIAUTSK("MONITOR^CIANBEVT","VueCentric Event Monitor")
Q
; Returns true if event monitor is running
; LOCK = If specified and true, do not release lock.
MONCHECK(LOCK) ;EP
L +^XTMP("CIANBEVT MONITOR"):0
E Q 1
L:'$G(LOCK) -^XTMP("CIANBEVT MONITOR")
Q 0
; Taskman entry point for background event monitor
MONITOR ;EP
N IEN,TYPE,EXE,IDLE,PMETH,X
S ZTREQ="@",IDLE=360
Q:$$MONCHECK(1)
F D Q:IDLE<1!$$S^%ZTLOAD
.H 5
.F IEN=0:0 S IEN=$O(^CIANB(19941.21,IEN)) Q:'IEN D
..S X=$G(^(IEN,0)),TYPE=$P(X,U),PMETH=$P(X,U,6),EXE=$G(^(1)) ; Note: NR set above
..I $L(EXE),'$P(X,U,2),$$CHKINT(+$P(X,U,3)) D
...I PMETH D EXEMON Q
...N UID
...F Q:'$$NXTUID^CIANBUTL(.UID) D EXEUID(UID,TYPE)
.S IDLE=$S($$NXTUID^CIANBUTL:360,1:IDLE-1)
L -^XTMP("CIANBEVT MONITOR")
Q
; Execute an event monitor in session context
EXEUID(UID,TYPE) ;EP
Q:'$$ISSUBSCR(UID,TYPE)
N CIA,DUZ
S CIA("UID")=UID,DUZ=$$EXEVAR("DUZ"),DUZ(0)=$$EXEVAR("DUZ0"),DUZ(2)=$$EXEVAR("DUZ2")
D EXEMON
Q
; Execute the event monitor
EXEMON N X,$ET
S X="EXEERR^CIANBEVT",@^%ZOSF("TRAP"),$ET=""
D EXERUN
Q
EXERUN N IEN,IDLE
X EXE
Q
; Log any errors
EXEERR N ERT,ERD,X
S ERT=$TR($$EC^%ZOSV,U,"~"),ERD=$$NOW^XLFDT
S X=$G(^CIANB(19941.21,IEN,100)),^(100)=ERD_U_ERT
D:(ERD\1'=(X\1))!($P(X,U,2)'=ERT) ^%ZTER
Q
EXEVAR(VAR) ;
Q $$GETVAR^CIANBUTL(VAR,,,UID)
; Check nominal polling interval. Return true if event needs to be polled.
CHKINT(INT) ;EP
Q:'INT 1
N NXT,NOW,CHK
S NOW=$H,NOW=NOW*86400+$P(NOW,",",2)
S NXT=$G(IEN(IEN),NOW),CHK=NOW'<NXT
S:CHK IEN(IEN)=NOW+INT
Q CHK
; RPC: Broadcast an event to some or all active users
BCAST(DATA,EVENT,STUB,LST,AID) ;
S DATA=$$BRDCAST(.EVENT,.STUB,.LST,.AID)
Q
; Called by event monitor to signal an event to client
SIGNAL(STUB) ;
D QUEUE(TYPE,.STUB)
Q
; Add an event to a process event queue
QUEUE(TYPE,STUB,UID) ;EP
N Q
S:'$D(UID) UID=$G(CIA("UID"))
I '$$ISSUBSCR(UID,TYPE) Q:$Q 0 Q
L +^XTMP("CIA",UID,"E"):5
E Q:$Q 0 Q
S Q=1+$O(^XTMP("CIA",UID,"E",$C(1)),-1),^(Q,0)=TYPE_$C(13) M ^(1)=STUB
L -^XTMP("CIA",UID,"E")
Q:$Q 1
Q
; Lookup event type, returning IEN
EVENTIEN(TYPE) ;EP
N X,Y
Q:TYPE=+TYPE!'$L(TYPE) +TYPE
S X=$E(TYPE,1,30),Y=0
F S Y=+$O(^CIANB(19941.21,"B",X,Y)) Q:'Y!($P($G(^CIANB(19941.21,Y,0)),U)=TYPE)
Q $S(Y:Y,1:$$EVENTIEN($P(TYPE,".",1,$L(TYPE,".")-1)))
; Return event name, given IEN
EVENTNAM(IEN) ;EP
Q $P($G(^CIANB(19941.21,+IEN,0)),U)
; Check to see if an event type is disabled
DISABLED(TYPE) ;EP
N X,Y
S X=$$EVENTIEN(TYPE),Y=$G(^CIANB(19941.21,+X,0)),TYPE=$P(Y,U),Y=+$P(Y,U,2)
S:'Y Y=$$KEYCHECK(X,20)
Q $S(Y:Y,'X:0,1:$$DISABLED($P(TYPE,".",1,$L(TYPE,".")-1)))
; Check to see if event type is protected by security key(s)
; Returns true if user does not have required keys
; SB=20: Publication keys; SB=21: Subscription keys
KEYCHECK(TYPE,SB) ;EP
N X,Y,Z
S X=$$EVENTIEN(TYPE),(Y,Z)=0
F S Z=$O(^CIANB(19941.21,X,SB,"B",Z)) Q:'Z D Q:'Y
.S Y='$$HASKEY(Z)
Q Y
; Return true if user has key
HASKEY(KEY) ;EP
S:KEY=+KEY KEY=$$LKUP^XPDKEY(KEY)
Q $S($L(KEY):''$$KCHK^XUSRB(KEY),1:0)
; Signal an event to all or selected sessions
; If called as extrinsic, returns # of events broadcast
BRDCAST(TYPE,STUB,USR,AID) ;EP
N X,C
S C=0
I '$$DISABLED(TYPE) D
.I $D(USR("DUZ"))>1 D
..F Q:'$$NXTUID^CIANBUTL(.X,-1,.AID) D
...S:$D(USR("DUZ",+$$GETVAR^CIANBUTL("DUZ",,,X))) USR("UID",X)=""
.S X=""
.F D Q:'X
..I $D(USR)>1 S X=$O(USR("UID",X))
..E D NXTUID^CIANBUTL(.X,-1,.AID)
..S:X C=C+$$QUEUE(.TYPE,.STUB,X)
.D LOG(TYPE,.STUB)
.D FPRTCOL(TYPE,.STUB)
Q:$Q C
Q
; Fire Associated Event Protocol
FPRTCOL(TYPE,STUB) ;
N EVT,X
S EVT=$$EVENTIEN(TYPE)
Q:'EVT
S X=$P($G(^CIANB(19941.21,+EVT,0)),U,7)_";ORD(101,"
Q:'X
D EN^XQOR
Q
; Subscribe to / unsubscribe from a named event
; Returns new subscription state
SUBSCR(TYPE,SUBSCR) ;EP
I '$L(TYPE) Q:$Q 0 Q
N CURRNT
S CURRNT=''$D(^XTMP("CIA",CIA("UID"),"S",TYPE)),SUBSCR=''$G(SUBSCR)
I CURRNT'=SUBSCR D
.I SUBSCR D Q:'SUBSCR
..I $$KEYCHECK(TYPE,21) S SUBSCR=0
..E S ^XTMP("CIA",CIA("UID"),"S",TYPE)=""
.E D
..K ^XTMP("CIA",CIA("UID"),"S",TYPE)
..D CLRVAR^CIANBUTL("EVENT."_TYPE)
.D BRDCAST($S(SUBSCR:"",1:"UN")_"SUBSCRIBE."_TYPE,$$SESSION^CIANBUTL)
Q:$Q SUBSCR
Q
; Unsubscribe from all events (done at logout)
UNSUBALL ;EP
N TYPE
S TYPE=""
F S TYPE=$O(^XTMP("CIA",CIA("UID"),"S",TYPE)) Q:'$L(TYPE) D
.D SUBSCR(TYPE,0)
Q
; Returns true if session is a subscriber
ISSUBSCR(UID,TYPE) ;EP
Q $S('$$ISACTIVE^CIANBUTL(UID):0,1:$$ISSUBX(TYPE))
ISSUBX(TYPE) ;
Q $S('$L(TYPE):0,$D(^XTMP("CIA",UID,"S",TYPE)):1,1:$$ISSUBX($P(TYPE,".",1,$L(TYPE,".")-1)))
; Returns list of subscribers to a given event type
GETSUBSC(DATA,TYPE) ;EP
N Z
D GETSESSN^CIANBRPC(.DATA)
F Z=0:0 S Z=$O(@DATA@(Z)) Q:'Z K:'$$ISSUBSCR(+@DATA@(Z),TYPE) @DATA@(Z)
Q
; Returns number of days to retain log entries for an event type.
ISLOGGED(TYPE) ;EP
N X,Y
S TYPE=$$EVENTIEN(TYPE)
S:TYPE X=^CIANB(19941.21,TYPE,0),Y=$P(X,U,4),X=$P(X,U)
Q $S('TYPE:0,'$L(Y):$$ISLOGGED($P(X,".",$L(X,".")-1)),1:Y)
; Log an event
LOG(TYPE,STUB) ;EP
N IEN,FDA,ERR,STB,X
S IEN=$$ISACTIVE^CIANBLOG
I IEN D
.S X=$$LOG^CIANBLOG(IEN,2,TYPE)
.D:X ADD^CIANBLOG(IEN,X,"STUB")
Q:'$$ISLOGGED(TYPE)
S FDA=$NA(FDA(19941.23,"+1,")),STB="STUB",X=0
F D Q:'$L(STB)
.S:$D(@STB)#2 X=X+1,STB(X)=@STB
.S STB=$Q(@STB)
S @FDA@(.01)=$$NOW^XLFDT
S @FDA@(1)=TYPE
S @FDA@(2)=DUZ
S @FDA@(3)=$$GETUID^CIANBUTL
S:X @FDA@(10)="STB"
D UPDATE^DIE("U","FDA",,"ERR")
Q
; Purge event log. Specify at least one of:
; DATE = Date before which entries will be purged.
; TYPE = Event type to be purged.
; FLAG = If set, purges child events as well.
PURGELOG(DATE,TYPE,FLAG) ;EP
N IEN,CNT
S CNT=0,TYPE=$G(TYPE),FLAG=$S($G(FLAG):12,1:1)
S:TYPE=+TYPE TYPE=$$EVENTNAM(TYPE)
I $G(DATE) D
.F S DATE=$O(^CIANB(19941.23,"B",DATE),-1),IEN=0 Q:'DATE D
..F S IEN=$O(^CIANB(19941.23,"B",DATE,IEN)) Q:'IEN D
...I $L(TYPE),FLAG'[$$RELATES(TYPE,$P(^CIANB(19941.23,IEN,0),U,2)) Q
...S CNT=CNT+$$DELLOG(IEN)
E D
.N TYP
.S IEN=0,TYP=TYPE
.F Q:'$L(TYPE) D
..F S IEN=$O(^CIANB(19941.23,"C",TYPE,IEN)) Q:'IEN S CNT=CNT+$$DELLOG(IEN)
..S TYPE=$O(^CIANB(19941.23,"C",TYPE))
..S:FLAG'[$$RELATES(TYP,TYPE) TYPE=""
Q:$Q CNT
Q
; Delete log entry corresponding to IEN
DELLOG(IEN) ;EP
N FDA,ERR
S FDA(19941.23,IEN_",",.01)="@"
D FILE^DIE(,"FDA","ERR")
Q:$Q '$D(ERR)
Q
; Task purge in background
TASKPRG ;EP
N ZTSK
S ZTSK=$$QUEUE^CIAUTSK("DOPURGE^CIANBEVT(1)","Purge CIA EVENT LOG")
I ZTSK>0 W !,"CIA EVENT LOG purge submitted as task #",ZTSK,!!
E W !,"Error submitting CIA EVENT LOG purge.",!!
Q
; Purges event log according to retention settings
DOPURGE(SILENT) ;EP
N IEN,TPNM,TPEN,DATE,CNT,TOT
S TPNM="",SILENT=+$G(SILENT),TOT=0
F S TPNM=$O(^CIANB(19941.23,"C",TPNM)) Q:'$L(TPNM) D
.S TPEN=$$EVENTIEN(TPNM),DATE=+$P($G(^CIANB(19941.21,TPEN,0)),U,5)
.S DATE=$$FMADD^XLFDT(DT,$S(DATE:1-DATE,1:-13))
.S CNT=$$PURGELOG(DATE,TPNM),TOT=TOT+CNT
.I CNT,'SILENT W $$SNGPLR^CIAU(CNT,"event")," purged for ",TPNM,!
W:'SILENT !,"Total events purged: ",TOT,!!
S:$D(ZTQUEUED) ZTREQ="@"
Q
; Returns the relationship between event types
; 0 = none
; 1 = same
; 2 = A is parent of B
; 3 = B is parent of A
RELATES(EVA,EVB) ;EP
N SWP,X
S:EVA=+EVA EVA=$$EVENTNAM(EVA)
S:EVB=+EVB EVB=$$EVENTNAM(EVB)
S:$L(EVA)>$L(EVB) SWP=EVA,EVA=EVB,EVB=SWP
Q:EVA=EVB 1
F D Q:'$L(EVB)!(EVA=EVB)
.S EVB=$P(EVB,".",1,$L(EVB,".")-1)
Q $S(EVA'=EVB:0,$D(SWP):3,1:2)
CIANBEVT ;MSC/IND/DKM - Event Support ;03-Dec-2009 16:53;PLS
+1 ;;1.1;CIA NETWORK COMPONENTS;**001007**;Sep 18, 2007
+2 ;;Copyright 2000-2008, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Check for the occurrence of host events
EVTCHK() ;EP
+1 NEW RTN,$ETRAP,X
+2 SET $ETRAP=""
SET X="ERR1^CIANBEVT"
SET @^%ZOSF("TRAP")
+3 LOCK +^XTMP("CIA",CIA("UID"),"E"):0
+4 IF '$TEST
QUIT 0
+5 SET RTN=+$ORDER(^XTMP("CIA",CIA("UID"),"E",0))
SET X=$NAME(^(RTN))
+6 IF RTN
Begin DoDot:1
+7 DO TCPUSE^CIANBLIS
+8 WRITE $CHAR(3)
+9 DO OUT^CIANBACT(X)
End DoDot:1
ERR1 LOCK -^XTMP("CIA",CIA("UID"),"E")
+1 QUIT $GET(RTN)
+2 ; Start monitor in background if not already running
MONSTART ;EP
+1 IF '$$MONCHECK
IF $$QUEUE^CIAUTSK("MONITOR^CIANBEVT","VueCentric Event Monitor")
+2 QUIT
+3 ; Returns true if event monitor is running
+4 ; LOCK = If specified and true, do not release lock.
MONCHECK(LOCK) ;EP
+1 LOCK +^XTMP("CIANBEVT MONITOR"):0
+2 IF '$TEST
QUIT 1
+3 IF '$GET(LOCK)
LOCK -^XTMP("CIANBEVT MONITOR")
+4 QUIT 0
+5 ; Taskman entry point for background event monitor
MONITOR ;EP
+1 NEW IEN,TYPE,EXE,IDLE,PMETH,X
+2 SET ZTREQ="@"
SET IDLE=360
+3 IF $$MONCHECK(1)
QUIT
+4 FOR
Begin DoDot:1
+5 HANG 5
+6 FOR IEN=0:0
SET IEN=$ORDER(^CIANB(19941.21,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 ; Note: NR set above
SET X=$GET(^(IEN,0))
SET TYPE=$PIECE(X,U)
SET PMETH=$PIECE(X,U,6)
SET EXE=$GET(^(1))
+8 IF $LENGTH(EXE)
IF '$PIECE(X,U,2)
IF $$CHKINT(+$PIECE(X,U,3))
Begin DoDot:3
+9 IF PMETH
DO EXEMON
QUIT
+10 NEW UID
+11 FOR
IF '$$NXTUID^CIANBUTL(.UID)
QUIT
DO EXEUID(UID,TYPE)
End DoDot:3
End DoDot:2
+12 SET IDLE=$SELECT($$NXTUID^CIANBUTL:360,1:IDLE-1)
End DoDot:1
IF IDLE<1!$$S^%ZTLOAD
QUIT
+13 LOCK -^XTMP("CIANBEVT MONITOR")
+14 QUIT
+15 ; Execute an event monitor in session context
EXEUID(UID,TYPE) ;EP
+1 IF '$$ISSUBSCR(UID,TYPE)
QUIT
+2 NEW CIA,DUZ
+3 SET CIA("UID")=UID
SET DUZ=$$EXEVAR("DUZ")
SET DUZ(0)=$$EXEVAR("DUZ0")
SET DUZ(2)=$$EXEVAR("DUZ2")
+4 DO EXEMON
+5 QUIT
+6 ; Execute the event monitor
EXEMON NEW X,$ETRAP
+1 SET X="EXEERR^CIANBEVT"
SET @^%ZOSF("TRAP")
SET $ETRAP=""
+2 DO EXERUN
+3 QUIT
EXERUN NEW IEN,IDLE
+1 XECUTE EXE
+2 QUIT
+3 ; Log any errors
EXEERR NEW ERT,ERD,X
+1 SET ERT=$TRANSLATE($$EC^%ZOSV,U,"~")
SET ERD=$$NOW^XLFDT
+2 SET X=$GET(^CIANB(19941.21,IEN,100))
SET ^(100)=ERD_U_ERT
+3 IF (ERD\1'=(X\1))!($PIECE(X,U,2)'=ERT)
DO ^%ZTER
+4 QUIT
EXEVAR(VAR) ;
+1 QUIT $$GETVAR^CIANBUTL(VAR,,,UID)
+2 ; Check nominal polling interval. Return true if event needs to be polled.
CHKINT(INT) ;EP
+1 IF 'INT
QUIT 1
+2 NEW NXT,NOW,CHK
+3 SET NOW=$HOROLOG
SET NOW=NOW*86400+$PIECE(NOW,",",2)
+4 SET NXT=$GET(IEN(IEN),NOW)
SET CHK=NOW'<NXT
+5 IF CHK
SET IEN(IEN)=NOW+INT
+6 QUIT CHK
+7 ; RPC: Broadcast an event to some or all active users
BCAST(DATA,EVENT,STUB,LST,AID) ;
+1 SET DATA=$$BRDCAST(.EVENT,.STUB,.LST,.AID)
+2 QUIT
+3 ; Called by event monitor to signal an event to client
SIGNAL(STUB) ;
+1 DO QUEUE(TYPE,.STUB)
+2 QUIT
+3 ; Add an event to a process event queue
QUEUE(TYPE,STUB,UID) ;EP
+1 NEW Q
+2 IF '$DATA(UID)
SET UID=$GET(CIA("UID"))
+3 IF '$$ISSUBSCR(UID,TYPE)
IF $QUIT
QUIT 0
QUIT
+4 LOCK +^XTMP("CIA",UID,"E"):5
+5 IF '$TEST
IF $QUIT
QUIT 0
QUIT
+6 SET Q=1+$ORDER(^XTMP("CIA",UID,"E",$CHAR(1)),-1)
SET ^(Q,0)=TYPE_$CHAR(13)
MERGE ^(1)=STUB
+7 LOCK -^XTMP("CIA",UID,"E")
+8 IF $QUIT
QUIT 1
+9 QUIT
+10 ; Lookup event type, returning IEN
EVENTIEN(TYPE) ;EP
+1 NEW X,Y
+2 IF TYPE=+TYPE!'$LENGTH(TYPE)
QUIT +TYPE
+3 SET X=$EXTRACT(TYPE,1,30)
SET Y=0
+4 FOR
SET Y=+$ORDER(^CIANB(19941.21,"B",X,Y))
IF 'Y!($PIECE($GET(^CIANB(19941.21,Y,0)),U)=TYPE)
QUIT
+5 QUIT $SELECT(Y:Y,1:$$EVENTIEN($PIECE(TYPE,".",1,$LENGTH(TYPE,".")-1)))
+6 ; Return event name, given IEN
EVENTNAM(IEN) ;EP
+1 QUIT $PIECE($GET(^CIANB(19941.21,+IEN,0)),U)
+2 ; Check to see if an event type is disabled
DISABLED(TYPE) ;EP
+1 NEW X,Y
+2 SET X=$$EVENTIEN(TYPE)
SET Y=$GET(^CIANB(19941.21,+X,0))
SET TYPE=$PIECE(Y,U)
SET Y=+$PIECE(Y,U,2)
+3 IF 'Y
SET Y=$$KEYCHECK(X,20)
+4 QUIT $SELECT(Y:Y,'X:0,1:$$DISABLED($PIECE(TYPE,".",1,$LENGTH(TYPE,".")-1)))
+5 ; Check to see if event type is protected by security key(s)
+6 ; Returns true if user does not have required keys
+7 ; SB=20: Publication keys; SB=21: Subscription keys
KEYCHECK(TYPE,SB) ;EP
+1 NEW X,Y,Z
+2 SET X=$$EVENTIEN(TYPE)
SET (Y,Z)=0
+3 FOR
SET Z=$ORDER(^CIANB(19941.21,X,SB,"B",Z))
IF 'Z
QUIT
Begin DoDot:1
+4 SET Y='$$HASKEY(Z)
End DoDot:1
IF 'Y
QUIT
+5 QUIT Y
+6 ; Return true if user has key
HASKEY(KEY) ;EP
+1 IF KEY=+KEY
SET KEY=$$LKUP^XPDKEY(KEY)
+2 QUIT $SELECT($LENGTH(KEY):''$$KCHK^XUSRB(KEY),1:0)
+3 ; Signal an event to all or selected sessions
+4 ; If called as extrinsic, returns # of events broadcast
BRDCAST(TYPE,STUB,USR,AID) ;EP
+1 NEW X,C
+2 SET C=0
+3 IF '$$DISABLED(TYPE)
Begin DoDot:1
+4 IF $DATA(USR("DUZ"))>1
Begin DoDot:2
+5 FOR
IF '$$NXTUID^CIANBUTL(.X,-1,.AID)
QUIT
Begin DoDot:3
+6 IF $DATA(USR("DUZ",+$$GETVAR^CIANBUTL("DUZ",,,X)))
SET USR("UID",X)=""
End DoDot:3
End DoDot:2
+7 SET X=""
+8 FOR
Begin DoDot:2
+9 IF $DATA(USR)>1
SET X=$ORDER(USR("UID",X))
+10 IF '$TEST
DO NXTUID^CIANBUTL(.X,-1,.AID)
+11 IF X
SET C=C+$$QUEUE(.TYPE,.STUB,X)
End DoDot:2
IF 'X
QUIT
+12 DO LOG(TYPE,.STUB)
+13 DO FPRTCOL(TYPE,.STUB)
End DoDot:1
+14 IF $QUIT
QUIT C
+15 QUIT
+16 ; Fire Associated Event Protocol
FPRTCOL(TYPE,STUB) ;
+1 NEW EVT,X
+2 SET EVT=$$EVENTIEN(TYPE)
+3 IF 'EVT
QUIT
+4 SET X=$PIECE($GET(^CIANB(19941.21,+EVT,0)),U,7)_";ORD(101,"
+5 IF 'X
QUIT
+6 DO EN^XQOR
+7 QUIT
+8 ; Subscribe to / unsubscribe from a named event
+9 ; Returns new subscription state
SUBSCR(TYPE,SUBSCR) ;EP
+1 IF '$LENGTH(TYPE)
IF $QUIT
QUIT 0
QUIT
+2 NEW CURRNT
+3 SET CURRNT=''$DATA(^XTMP("CIA",CIA("UID"),"S",TYPE))
SET SUBSCR=''$GET(SUBSCR)
+4 IF CURRNT'=SUBSCR
Begin DoDot:1
+5 IF SUBSCR
Begin DoDot:2
+6 IF $$KEYCHECK(TYPE,21)
SET SUBSCR=0
+7 IF '$TEST
SET ^XTMP("CIA",CIA("UID"),"S",TYPE)=""
End DoDot:2
IF 'SUBSCR
QUIT
+8 IF '$TEST
Begin DoDot:2
+9 KILL ^XTMP("CIA",CIA("UID"),"S",TYPE)
+10 DO CLRVAR^CIANBUTL("EVENT."_TYPE)
End DoDot:2
+11 DO BRDCAST($SELECT(SUBSCR:"",1:"UN")_"SUBSCRIBE."_TYPE,$$SESSION^CIANBUTL)
End DoDot:1
+12 IF $QUIT
QUIT SUBSCR
+13 QUIT
+14 ; Unsubscribe from all events (done at logout)
UNSUBALL ;EP
+1 NEW TYPE
+2 SET TYPE=""
+3 FOR
SET TYPE=$ORDER(^XTMP("CIA",CIA("UID"),"S",TYPE))
IF '$LENGTH(TYPE)
QUIT
Begin DoDot:1
+4 DO SUBSCR(TYPE,0)
End DoDot:1
+5 QUIT
+6 ; Returns true if session is a subscriber
ISSUBSCR(UID,TYPE) ;EP
+1 QUIT $SELECT('$$ISACTIVE^CIANBUTL(UID):0,1:$$ISSUBX(TYPE))
ISSUBX(TYPE) ;
+1 QUIT $SELECT('$LENGTH(TYPE):0,$DATA(^XTMP("CIA",UID,"S",TYPE)):1,1:$$ISSUBX($PIECE(TYPE,".",1,$LENGTH(TYPE,".")-1)))
+2 ; Returns list of subscribers to a given event type
GETSUBSC(DATA,TYPE) ;EP
+1 NEW Z
+2 DO GETSESSN^CIANBRPC(.DATA)
+3 FOR Z=0:0
SET Z=$ORDER(@DATA@(Z))
IF 'Z
QUIT
IF '$$ISSUBSCR(+@DATA@(Z),TYPE)
KILL @DATA@(Z)
+4 QUIT
+5 ; Returns number of days to retain log entries for an event type.
ISLOGGED(TYPE) ;EP
+1 NEW X,Y
+2 SET TYPE=$$EVENTIEN(TYPE)
+3 IF TYPE
SET X=^CIANB(19941.21,TYPE,0)
SET Y=$PIECE(X,U,4)
SET X=$PIECE(X,U)
+4 QUIT $SELECT('TYPE:0,'$LENGTH(Y):$$ISLOGGED($PIECE(X,".",$LENGTH(X,".")-1)),1:Y)
+5 ; Log an event
LOG(TYPE,STUB) ;EP
+1 NEW IEN,FDA,ERR,STB,X
+2 SET IEN=$$ISACTIVE^CIANBLOG
+3 IF IEN
Begin DoDot:1
+4 SET X=$$LOG^CIANBLOG(IEN,2,TYPE)
+5 IF X
DO ADD^CIANBLOG(IEN,X,"STUB")
End DoDot:1
+6 IF '$$ISLOGGED(TYPE)
QUIT
+7 SET FDA=$NAME(FDA(19941.23,"+1,"))
SET STB="STUB"
SET X=0
+8 FOR
Begin DoDot:1
+9 IF $DATA(@STB)#2
SET X=X+1
SET STB(X)=@STB
+10 SET STB=$QUERY(@STB)
End DoDot:1
IF '$LENGTH(STB)
QUIT
+11 SET @FDA@(.01)=$$NOW^XLFDT
+12 SET @FDA@(1)=TYPE
+13 SET @FDA@(2)=DUZ
+14 SET @FDA@(3)=$$GETUID^CIANBUTL
+15 IF X
SET @FDA@(10)="STB"
+16 DO UPDATE^DIE("U","FDA",,"ERR")
+17 QUIT
+18 ; Purge event log. Specify at least one of:
+19 ; DATE = Date before which entries will be purged.
+20 ; TYPE = Event type to be purged.
+21 ; FLAG = If set, purges child events as well.
PURGELOG(DATE,TYPE,FLAG) ;EP
+1 NEW IEN,CNT
+2 SET CNT=0
SET TYPE=$GET(TYPE)
SET FLAG=$SELECT($GET(FLAG):12,1:1)
+3 IF TYPE=+TYPE
SET TYPE=$$EVENTNAM(TYPE)
+4 IF $GET(DATE)
Begin DoDot:1
+5 FOR
SET DATE=$ORDER(^CIANB(19941.23,"B",DATE),-1)
SET IEN=0
IF 'DATE
QUIT
Begin DoDot:2
+6 FOR
SET IEN=$ORDER(^CIANB(19941.23,"B",DATE,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+7 IF $LENGTH(TYPE)
IF FLAG'[$$RELATES(TYPE,$PIECE(^CIANB(19941.23,IEN,0),U,2))
QUIT
+8 SET CNT=CNT+$$DELLOG(IEN)
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 NEW TYP
+11 SET IEN=0
SET TYP=TYPE
+12 FOR
IF '$LENGTH(TYPE)
QUIT
Begin DoDot:2
+13 FOR
SET IEN=$ORDER(^CIANB(19941.23,"C",TYPE,IEN))
IF 'IEN
QUIT
SET CNT=CNT+$$DELLOG(IEN)
+14 SET TYPE=$ORDER(^CIANB(19941.23,"C",TYPE))
+15 IF FLAG'[$$RELATES(TYP,TYPE)
SET TYPE=""
End DoDot:2
End DoDot:1
+16 IF $QUIT
QUIT CNT
+17 QUIT
+18 ; Delete log entry corresponding to IEN
DELLOG(IEN) ;EP
+1 NEW FDA,ERR
+2 SET FDA(19941.23,IEN_",",.01)="@"
+3 DO FILE^DIE(,"FDA","ERR")
+4 IF $QUIT
QUIT '$DATA(ERR)
+5 QUIT
+6 ; Task purge in background
TASKPRG ;EP
+1 NEW ZTSK
+2 SET ZTSK=$$QUEUE^CIAUTSK("DOPURGE^CIANBEVT(1)","Purge CIA EVENT LOG")
+3 IF ZTSK>0
WRITE !,"CIA EVENT LOG purge submitted as task #",ZTSK,!!
+4 IF '$TEST
WRITE !,"Error submitting CIA EVENT LOG purge.",!!
+5 QUIT
+6 ; Purges event log according to retention settings
DOPURGE(SILENT) ;EP
+1 NEW IEN,TPNM,TPEN,DATE,CNT,TOT
+2 SET TPNM=""
SET SILENT=+$GET(SILENT)
SET TOT=0
+3 FOR
SET TPNM=$ORDER(^CIANB(19941.23,"C",TPNM))
IF '$LENGTH(TPNM)
QUIT
Begin DoDot:1
+4 SET TPEN=$$EVENTIEN(TPNM)
SET DATE=+$PIECE($GET(^CIANB(19941.21,TPEN,0)),U,5)
+5 SET DATE=$$FMADD^XLFDT(DT,$SELECT(DATE:1-DATE,1:-13))
+6 SET CNT=$$PURGELOG(DATE,TPNM)
SET TOT=TOT+CNT
+7 IF CNT
IF 'SILENT
WRITE $$SNGPLR^CIAU(CNT,"event")," purged for ",TPNM,!
End DoDot:1
+8 IF 'SILENT
WRITE !,"Total events purged: ",TOT,!!
+9 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+10 QUIT
+11 ; Returns the relationship between event types
+12 ; 0 = none
+13 ; 1 = same
+14 ; 2 = A is parent of B
+15 ; 3 = B is parent of A
RELATES(EVA,EVB) ;EP
+1 NEW SWP,X
+2 IF EVA=+EVA
SET EVA=$$EVENTNAM(EVA)
+3 IF EVB=+EVB
SET EVB=$$EVENTNAM(EVB)
+4 IF $LENGTH(EVA)>$LENGTH(EVB)
SET SWP=EVA
SET EVA=EVB
SET EVB=SWP
+5 IF EVA=EVB
QUIT 1
+6 FOR
Begin DoDot:1
+7 SET EVB=$PIECE(EVB,".",1,$LENGTH(EVB,".")-1)
End DoDot:1
IF '$LENGTH(EVB)!(EVA=EVB)
QUIT
+8 QUIT $SELECT(EVA'=EVB:0,$DATA(SWP):3,1:2)
