Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: CIANBEVT

CIANBEVT.m

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