CIANBUTL.m

CIANBUTL ;MSC/IND/DKM/PLS - MSC RPC Broker Utilities ;15-Oct-2015 08:51;PLS

 ;;1.1;CIA NETWORK COMPONENTS;**001007,001011,001012**;Sep 18, 2007

 ;;Copyright 2000-2015, Medsphere Systems Corporation

 ;=================================================================

 ; Cleanup stray global nodes

CLEANUP ;EP

 N UID

 F  Q:'$$NXTUID(.UID,0)  K ^XTMP("CIA",UID)

 Q

 ; Force RPC context tables to be rebuilt for all active sessions

REBLDCTX ;EP

 N UID,CTX

 F  Q:'$$NXTUID(.UID)  D

 .F CTX=0:0 S CTX=$O(^XTMP("CIA",UID,"C",CTX)) Q:'CTX  S ^(CTX)=0

 Q

 ; Get globally unique instance ID

UID() N UID,FLG

 L +^XTMP("CIA",0):5

 E  Q "-3^Cannot initialize environment"

 S FLG=0

 F UID=$P($G(^XTMP("CIA",0)),U,3)+1:1 D  Q:(UID<1)!(FLG=2)

 .I (UID<1)!(UID>999999) D  Q:UID<1

 ..S UID=$S('FLG:1,1:"-4^Lock table is full"),FLG=1

 .S:'$$ISACTIVE(UID,1) FLG=2

 S:UID>0 ^XTMP("CIA",0)=(DT+10000)_U_DT_U_UID

 L -^XTMP("CIA",0)

 Q UID

 ; Verifies that a session is truly active

 ;   UID = Unique id of session

 ;   LCK = If nonzero, leave lock active (defaults to 0)

 ;   TMO = Optional lock timeout (defaults to 0)

ISACTIVE(UID,LCK,TMO) ;EP

 Q:'$G(UID) 0

 Q:UID=$G(CIA("UID")) 1

 L +^XTMP("CIA",UID,0):+$G(TMO)

 E  Q 1

 L:'$G(LCK) -^XTMP("CIA",UID,0)

 Q 0

 ; Gets the session ID associated with this process

 ; If not in session context, attempt answerback from client

GETUID() ;EP

 I '$D(CIA("UID")) D

 .S CIA("UID")=""

 .Q:$D(ZTQUEUED)

 .N X,UID,I

 .S I=$I,UID=""

 .U $S($D(IO(0)):IO(0),1:$P)                                           ; Use home device

 .X ^%ZOSF("EOFF")                                                     ; Suppress echo

 .F  R X#1:0 Q:'$T                                                     ; Flush keyboard buffer

 .W $C(5)                                                              ; Send answerback request

 .F  R X:4 Q:'$T&'$L(X)  S UID=UID_X                                   ; Listen for response

 .S UID=$P(UID,"CIA#",2)

 .X ^%ZOSF("EON")                                                      ; Restore echo

 .U I                                                                  ; Restore previous device

 .I $$ISACTIVE(UID),$$GETVAR("DUZ",,,UID)=DUZ S CIA("UID")=UID

 .E  S CIA("UID")=""

 Q:$Q CIA("UID")

 Q

 ; Retrieve next session ID from list

 ;   UID passed as last ID processed, returned as next ID or null

 ;   FLT = <0=all; 0=inactive only; >0=active only (default)

 ;   AID = Application ID (optional)

 ;   Return value is true if ID found

NXTUID(UID,FLT,AID) ;EP

 N PFX,FND,ALL,ACT

 S FLT=+$G(FLT,1),FND=0,ALL=FLT<0,ACT=FLT>0,AID=$$OPTLKP(.AID),UID=+$G(UID)

 I $L(AID) F  S UID=$O(^XTMP("CIA",UID)) Q:'UID  D  Q:FND

 .I AID,$$GETVAR("AID0",,,UID)'=AID Q

 .I 'ALL,$$ISACTIVE(UID)'=ACT Q

 .S FND=1

 S:'FND UID=""

 Q:$Q FND

 Q

 ; Retrieve a package parameter value

PARAM(PAR,MIN,MAX) ;EP

 S VAL=+$$GET^XPAR("ALL",PAR)

 S:VAL<MIN VAL=MIN

 S:VAL>MAX VAL=MAX

 Q VAL

 ; Return free resource device

RESDEV() ;EP

 N RD,MX,SL,UID,X,C

 S MX=$$PARAM("CIANB RESOURCE DEVICE COUNT",1,40)

 S SL=$$PARAM("CIANB RESOURCE DEVICE SLOTS",1,40)

 F  Q:'$$NXTUID(.UID)  D

 .S RD=$$GETVAR("RDEV",,,UID)

 .S:RD RD(RD)=$G(RD(RD))+1

 S RD=1,C=999999

 F X=1:1:MX S:+$G(RD(X))<C RD=X,C=+$G(RD(X))

 S X=$$RES^XUDHSET("CIANB THREAD RESOURCE #"_RD,,SL,"CIA Broker Asynchronous Callbacks")

 Q RD

 ; Set maximum slots for resource devices

SETSLOTS(CNT) ;EP

 N RES,IEN,FDA,X,Y

 Q:CNT<2!(CNT>40)

 D FIND^DIC(3.5,,"@","UP","CIANB THREAD RESOURCE #",,"B")

 F RES=0:0 S RES=$O(^TMP("DILIST",$J,RES)) Q:'RES  S IEN=+$G(^(RES,0)) D:IEN

 .S FDA(3.5,IEN_",",35)=CNT

 D FILE^DIE("K","FDA")

 K ^TMP("DILIST",$J),^TMP("DIERR",$J)

 Q

 ; Return info for session

SESSION(UID,VAR) ;EP

 N X,Y,Z

 S (X,Y)=""

 S:'$L($G(VAR)) VAR="UID^WID^AID^DUZ^USER^LDT^JOB"

 F Z=1:1:$L(VAR,U) S X=X_Y_$$GETVAR($P(VAR,U,Z),,,.UID),Y=U

 Q X

 ; Show active sessions

 ;   AID = optional application id

 ;   FLT = <0=all; 0=inactive only; >0=active only (default)

SHOWSESS(AID,FLT) ;EP

 N C,X,Z

 F C=0:1 Q:'$$NXTUID(.X,.FLT,.AID)  D

 .W "#",X,?10,$$HTE^XLFDT($$GETVAR("LDT",,,X)),?40,$$GETVAR("WID",,,X),?60,$$GETVAR("USER",,,X),!

 W !,$S('C:"No sessions are",C=1:"One session is",1:C_" sessions are")," ",$S(FLT>0:"active",FLT<0:"present",1:"inactive"),".",!

 Q:$Q C

 Q

 ; Fetch an environment variable

 ;   NAME = Variable name

 ;   DFLT = Optional default value

 ;   NMSP = Optional namespace (defaults to global)

 ;   UID  = Optional session id (default to current)

GETVAR(NAME,DFLT,NMSP,UID) ;EP

 D FMTVAR(.UID,.NMSP,.NAME)

 Q $S('UID:"",1:$G(^XTMP("CIA",UID,"V",NMSP,NAME),$G(DFLT)))

 ; Save an environment variable

 ;   NAME = Variable name

 ;   VALUE = Value to be assigned (if not specified, entry is deleted)

 ;   NMSP = Optional namespace (defaults to global)

SETVAR(NAME,VALUE,NMSP,UID) ;EP

 N $ET

 S $ET="S $EC="""" G ERRVAR^CIANBUTL"

 D FMTVAR(.UID,.NMSP,.NAME)

 I 'UID Q:$Q 0 Q

 L +^XTMP("CIA",UID,"V",NMSP,NAME):1

 ;E  Q:$Q 0 Q

 I $D(VALUE) S:NMSP=-1 @NAME=VALUE S ^XTMP("CIA",UID,"V",NMSP,NAME)=VALUE

 E  K:NMSP=-1 @NAME K ^XTMP("CIA",UID,"V",NMSP,NAME)

 L -^XTMP("CIA",UID,"V",NMSP,NAME)

 Q:$Q 1

 Q

 ; Clear all variables in a namespace

CLRVAR(NMSP,UID) ;EP

 N NAME,RES

 D FMTVAR(.UID,.NMSP)

 L +^XTMP("CIA",UID,"V",NMSP):1

 ;E  Q:$Q 0 Q

 S NAME="",RES=1

 F  S NAME=$O(^XTMP("CIA",UID,"V",NMSP,NAME)) Q:'$L(NAME)  S RES=RES&$$SETVAR(NAME,,NMSP,UID)

 L -^XTMP("CIA",UID,"V",NMSP)

 Q:$Q RES

 Q

 ; Restore variables from local variable namespace

RESVAR N NAME,UID

 D FMTVAR(.UID)

 S NAME=""

 F  S NAME=$O(^XTMP("CIA",UID,"V",-1,NAME)) Q:'$L(NAME)  S @NAME=^(NAME)

 Q

 ; Error handler for var calls

ERRVAR L -^XTMP("CIA",UID,"V",NMSP,NAME)

 Q:$Q 0

 Q

 ; Format arguments for var calls

FMTVAR(UID,NMSP,NAME) ;

 S UID=$G(UID,$G(CIA("UID")))

 S NMSP=$$UP^XLFSTR($G(NMSP,0))

 S NAME=$$UP^XLFSTR($G(NAME))

 S:NMSP=-1&$L(NAME) NAME=$NA(@NAME)

 Q

 ; Retrieve dialog text

 ;  NUM = Dialog number (relative or absolute)

 ; .DLG = Array to receive text

 ;  Pn  = Optional parameters (up to 3)

GETDLG(NUM,DLG,P1,P2,P3) ;

 N PAR

 K DLG

 S:NUM<10000 NUM=NUM+199412000

 S PAR(1)=$G(P1,$G(CIA("RPC"))),PAR(2)=$G(P2),PAR(3)=$G(P3)

 D BLD^DIALOG(NUM,.PAR,,"DLG")

 Q:$Q $G(DLG(1))

 Q

 ; Lookup option, returning IEN

OPTLKP(OPT) ;EP

 Q $S('$L($G(OPT)):0,OPT=+OPT:OPT,1:$O(^DIC(19,"B",OPT,0)))

 ; Get/set out-of-order message for option

 ;   MSG = New message (if passed, a set is performed, otherwise a get)

 ;   Returns current message text

OPTMSG(OPT,MSG) ;EP

 S OPT=+$$OPTLKP(.OPT)

 I OPT,$D(^DIC(19,OPT,0)) D                                            ; Sets naked ref

 .I $D(MSG) S $P(^(0),U,3)=MSG

 .E  S MSG=$P(^(0),U,3)

 E  S MSG=""

 Q:$Q MSG

 Q

 ; Check option for valid access

 ;   OPT=Option IEN or name

 ;   TYP=Optional option type to check

 ;   Returns 0 if OK, <err code>^<err param> otherwise

OPTCHK(OPT,TYP) ;EP

 N XQY,X,Y,Z

 S XQY=$S(OPT=+OPT:OPT,1:$$OPTLKP(OPT))

 Q:XQY'>0 "2^"_OPT

 S X=$G(^DIC(19,XQY,0)),Y=$P($G(^(3)),U),Z=$P(X,U,3)

 Q:$L(Z) "19^"_Z

 I $L($G(TYP)),$P(X,U,4)'=TYP Q "20^"_OPT_U_TYP

 I $P(X,U,16),$L(Y),$$KCHK^XUSRB(Y) Q "21^"_OPT_U_Y

 S Y=$P(X,U,6)

 I $L(Y),'$$KCHK^XUSRB(Y) Q "22^"_OPT_U_Y

 S X=$$NOW^XLFDT

 D ENTRY^XQ92

 Q:'X "23^"_OPT

 Q 0

 ; Nightly task to perform various cleanup procedures.

NIGHTLY ;EP

 D CLEANUP

 D DOPURGE^CIANBEVT(1)

 D DOPURGE^CIANBLOG

 Q

CIANBUTL  ;MSC/IND/DKM/PLS - MSC RPC Broker Utilities ;15-Oct-2015 08:51;PLS

 +1       ;;1.1;CIA NETWORK COMPONENTS;**001007,001011,001012**;Sep 18, 2007

 +2       ;;Copyright 2000-2015, Medsphere Systems Corporation

 +3       ;=================================================================

 +4       ; Cleanup stray global nodes

CLEANUP   ;EP

 +1        NEW UID

 +2        FOR 

               IF '$$NXTUID(.UID,0)

                   QUIT 

               KILL ^XTMP("CIA",UID)

 +3        QUIT 

 +4       ; Force RPC context tables to be rebuilt for all active sessions

REBLDCTX  ;EP

 +1        NEW UID,CTX

 +2        FOR 

               IF '$$NXTUID(.UID)

                   QUIT 

               Begin DoDot:1

 +3                FOR CTX=0:0

                       SET CTX=$ORDER(^XTMP("CIA",UID,"C",CTX))

                       IF 'CTX

                           QUIT 

                       SET ^(CTX)=0

               End DoDot:1

 +4        QUIT 

 +5       ; Get globally unique instance ID

UID()      NEW UID,FLG

 +1        LOCK +^XTMP("CIA",0):5

 +2       IF '$TEST

               QUIT "-3^Cannot initialize environment"

 +3        SET FLG=0

 +4        FOR UID=$PIECE($GET(^XTMP("CIA",0)),U,3)+1:1

               Begin DoDot:1

 +5                IF (UID<1)!(UID>999999)

                       Begin DoDot:2

 +6                        SET UID=$SELECT('FLG:1,1:"-4^Lock table is full")

                           SET FLG=1

                       End DoDot:2

                       IF UID<1

                           QUIT 

 +7                IF '$$ISACTIVE(UID,1)

                       SET FLG=2

               End DoDot:1

               IF (UID<1)!(FLG=2)

                   QUIT 

 +8        IF UID>0

               SET ^XTMP("CIA",0)=(DT+10000)_U_DT_U_UID

 +9        LOCK -^XTMP("CIA",0)

 +10       QUIT UID

 +11      ; Verifies that a session is truly active

 +12      ;   UID = Unique id of session

 +13      ;   LCK = If nonzero, leave lock active (defaults to 0)

 +14      ;   TMO = Optional lock timeout (defaults to 0)

ISACTIVE(UID,LCK,TMO) ;EP

 +1        IF '$GET(UID)

               QUIT 0

 +2        IF UID=$GET(CIA("UID"))

               QUIT 1

 +3        LOCK +^XTMP("CIA",UID,0):+$GET(TMO)

 +4       IF '$TEST

               QUIT 1

 +5        IF '$GET(LCK)

               LOCK -^XTMP("CIA",UID,0)

 +6        QUIT 0

 +7       ; Gets the session ID associated with this process

 +8       ; If not in session context, attempt answerback from client

GETUID()  ;EP

 +1        IF '$DATA(CIA("UID"))

               Begin DoDot:1

 +2                SET CIA("UID")=""

 +3                IF $DATA(ZTQUEUED)

                       QUIT 

 +4                NEW X,UID,I

 +5                SET I=$IO

                   SET UID=""

 +6       ; Use home device

                   USE $SELECT($DATA(IO(0)):IO(0),1:$PRINCIPAL)

 +7       ; Suppress echo

                   XECUTE ^%ZOSF("EOFF")

 +8       ; Flush keyboard buffer

                   FOR 

                       READ X#1:0

                       IF '$TEST

                           QUIT 

 +9       ; Send answerback request

                   WRITE $CHAR(5)

 +10      ; Listen for response

                   FOR 

                       READ X:4

                       IF '$TEST&'$LENGTH(X)

                           QUIT 

                       SET UID=UID_X

 +11               SET UID=$PIECE(UID,"CIA#",2)

 +12      ; Restore echo

                   XECUTE ^%ZOSF("EON")

 +13      ; Restore previous device

                   USE I

 +14               IF $$ISACTIVE(UID)

                       IF $$GETVAR("DUZ",,,UID)=DUZ

                           SET CIA("UID")=UID

 +15              IF '$TEST

                       SET CIA("UID")=""

               End DoDot:1

 +16       IF $QUIT

               QUIT CIA("UID")

 +17       QUIT 

 +18      ; Retrieve next session ID from list

 +19      ;   UID passed as last ID processed, returned as next ID or null

 +20      ;   FLT = <0=all; 0=inactive only; >0=active only (default)

 +21      ;   AID = Application ID (optional)

 +22      ;   Return value is true if ID found

NXTUID(UID,FLT,AID) ;EP

 +1        NEW PFX,FND,ALL,ACT

 +2        SET FLT=+$GET(FLT,1)

           SET FND=0

           SET ALL=FLT<0

           SET ACT=FLT>0

           SET AID=$$OPTLKP(.AID)

           SET UID=+$GET(UID)

 +3        IF $LENGTH(AID)

               FOR 

                   SET UID=$ORDER(^XTMP("CIA",UID))

                   IF 'UID

                       QUIT 

                   Begin DoDot:1

 +4                    IF AID

                           IF $$GETVAR("AID0",,,UID)'=AID

                               QUIT 

 +5                    IF 'ALL

                           IF $$ISACTIVE(UID)'=ACT

                               QUIT 

 +6                    SET FND=1

                   End DoDot:1

                   IF FND

                       QUIT 

 +7        IF 'FND

               SET UID=""

 +8        IF $QUIT

               QUIT FND

 +9        QUIT 

 +10      ; Retrieve a package parameter value

PARAM(PAR,MIN,MAX) ;EP

 +1        SET VAL=+$$GET^XPAR("ALL",PAR)

 +2        IF VAL<MIN

               SET VAL=MIN

 +3        IF VAL>MAX

               SET VAL=MAX

 +4        QUIT VAL

 +5       ; Return free resource device

RESDEV()  ;EP

 +1        NEW RD,MX,SL,UID,X,C

 +2        SET MX=$$PARAM("CIANB RESOURCE DEVICE COUNT",1,40)

 +3        SET SL=$$PARAM("CIANB RESOURCE DEVICE SLOTS",1,40)

 +4        FOR 

               IF '$$NXTUID(.UID)

                   QUIT 

               Begin DoDot:1

 +5                SET RD=$$GETVAR("RDEV",,,UID)

 +6                IF RD

                       SET RD(RD)=$GET(RD(RD))+1

               End DoDot:1

 +7        SET RD=1

           SET C=999999

 +8        FOR X=1:1:MX

               IF +$GET(RD(X))<C

                   SET RD=X

                   SET C=+$GET(RD(X))

 +9        SET X=$$RES^XUDHSET("CIANB THREAD RESOURCE #"_RD,,SL,"CIA Broker Asynchronous Callbacks")

 +10       QUIT RD

 +11      ; Set maximum slots for resource devices

SETSLOTS(CNT) ;EP

 +1        NEW RES,IEN,FDA,X,Y

 +2        IF CNT<2!(CNT>40)

               QUIT 

 +3        DO FIND^DIC(3.5,,"@","UP","CIANB THREAD RESOURCE #",,"B")

 +4        FOR RES=0:0

               SET RES=$ORDER(^TMP("DILIST",$JOB,RES))

               IF 'RES

                   QUIT 

               SET IEN=+$GET(^(RES,0))

               IF IEN

                   Begin DoDot:1

 +5                    SET FDA(3.5,IEN_",",35)=CNT

                   End DoDot:1

 +6        DO FILE^DIE("K","FDA")

 +7        KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)

 +8        QUIT 

 +9       ; Return info for session

SESSION(UID,VAR) ;EP

 +1        NEW X,Y,Z

 +2        SET (X,Y)=""

 +3        IF '$LENGTH($GET(VAR))

               SET VAR="UID^WID^AID^DUZ^USER^LDT^JOB"

 +4        FOR Z=1:1:$LENGTH(VAR,U)

               SET X=X_Y_$$GETVAR($PIECE(VAR,U,Z),,,.UID)

               SET Y=U

 +5        QUIT X

 +6       ; Show active sessions

 +7       ;   AID = optional application id

 +8       ;   FLT = <0=all; 0=inactive only; >0=active only (default)

SHOWSESS(AID,FLT) ;EP

 +1        NEW C,X,Z

 +2        FOR C=0:1

               IF '$$NXTUID(.X,.FLT,.AID)

                   QUIT 

               Begin DoDot:1

 +3                WRITE "#",X,?10,$$HTE^XLFDT($$GETVAR("LDT",,,X)),?40,$$GETVAR("WID",,,X),?60,$$GETVAR("USER",,,X),!

               End DoDot:1

 +4        WRITE !,$SELECT('C:"No sessions are",C=1:"One session is",1:C_" sessions are")," ",$SELECT(FLT>0:"active",FLT<0:"present",1:"inactive"),".",!

 +5        IF $QUIT

               QUIT C

 +6        QUIT 

 +7       ; Fetch an environment variable

 +8       ;   NAME = Variable name

 +9       ;   DFLT = Optional default value

 +10      ;   NMSP = Optional namespace (defaults to global)

 +11      ;   UID  = Optional session id (default to current)

GETVAR(NAME,DFLT,NMSP,UID) ;EP

 +1        DO FMTVAR(.UID,.NMSP,.NAME)

 +2        QUIT $SELECT('UID:"",1:$GET(^XTMP("CIA",UID,"V",NMSP,NAME),$GET(DFLT)))

 +3       ; Save an environment variable

 +4       ;   NAME = Variable name

 +5       ;   VALUE = Value to be assigned (if not specified, entry is deleted)

 +6       ;   NMSP = Optional namespace (defaults to global)

SETVAR(NAME,VALUE,NMSP,UID) ;EP

 +1        NEW $ETRAP

 +2        SET $ETRAP="S $EC="""" G ERRVAR^CIANBUTL"

 +3        DO FMTVAR(.UID,.NMSP,.NAME)

 +4        IF 'UID

               IF $QUIT

                   QUIT 0

               QUIT 

 +5        LOCK +^XTMP("CIA",UID,"V",NMSP,NAME):1

 +6       ;E  Q:$Q 0 Q

 +7        IF $DATA(VALUE)

               IF NMSP=-1

                   SET @NAME=VALUE

               SET ^XTMP("CIA",UID,"V",NMSP,NAME)=VALUE

 +8       IF '$TEST

               IF NMSP=-1

                   KILL @NAME

               KILL ^XTMP("CIA",UID,"V",NMSP,NAME)

 +9        LOCK -^XTMP("CIA",UID,"V",NMSP,NAME)

 +10       IF $QUIT

               QUIT 1

 +11       QUIT 

 +12      ; Clear all variables in a namespace

CLRVAR(NMSP,UID) ;EP

 +1        NEW NAME,RES

 +2        DO FMTVAR(.UID,.NMSP)

 +3        LOCK +^XTMP("CIA",UID,"V",NMSP):1

 +4       ;E  Q:$Q 0 Q

 +5        SET NAME=""

           SET RES=1

 +6        FOR 

               SET NAME=$ORDER(^XTMP("CIA",UID,"V",NMSP,NAME))

               IF '$LENGTH(NAME)

                   QUIT 

               SET RES=RES&$$SETVAR(NAME,,NMSP,UID)

 +7        LOCK -^XTMP("CIA",UID,"V",NMSP)

 +8        IF $QUIT

               QUIT RES

 +9        QUIT 

 +10      ; Restore variables from local variable namespace

RESVAR     NEW NAME,UID

 +1        DO FMTVAR(.UID)

 +2        SET NAME=""

 +3        FOR 

               SET NAME=$ORDER(^XTMP("CIA",UID,"V",-1,NAME))

               IF '$LENGTH(NAME)

                   QUIT 

               SET @NAME=^(NAME)

 +4        QUIT 

 +5       ; Error handler for var calls

ERRVAR     LOCK -^XTMP("CIA",UID,"V",NMSP,NAME)

 +1        IF $QUIT

               QUIT 0

 +2        QUIT 

 +3       ; Format arguments for var calls

FMTVAR(UID,NMSP,NAME) ;

 +1        SET UID=$GET(UID,$GET(CIA("UID")))

 +2        SET NMSP=$$UP^XLFSTR($GET(NMSP,0))

 +3        SET NAME=$$UP^XLFSTR($GET(NAME))

 +4        IF NMSP=-1&$LENGTH(NAME)

               SET NAME=$NAME(@NAME)

 +5        QUIT 

 +6       ; Retrieve dialog text

 +7       ;  NUM = Dialog number (relative or absolute)

 +8       ; .DLG = Array to receive text

 +9       ;  Pn  = Optional parameters (up to 3)

GETDLG(NUM,DLG,P1,P2,P3) ;

 +1        NEW PAR

 +2        KILL DLG

 +3        IF NUM<10000

               SET NUM=NUM+199412000

 +4        SET PAR(1)=$GET(P1,$GET(CIA("RPC")))

           SET PAR(2)=$GET(P2)

           SET PAR(3)=$GET(P3)

 +5        DO BLD^DIALOG(NUM,.PAR,,"DLG")

 +6        IF $QUIT

               QUIT $GET(DLG(1))

 +7        QUIT 

 +8       ; Lookup option, returning IEN

OPTLKP(OPT) ;EP

 +1        QUIT $SELECT('$LENGTH($GET(OPT)):0,OPT=+OPT:OPT,1:$ORDER(^DIC(19,"B",OPT,0)))

 +2       ; Get/set out-of-order message for option

 +3       ;   MSG = New message (if passed, a set is performed, otherwise a get)

 +4       ;   Returns current message text

OPTMSG(OPT,MSG) ;EP

 +1        SET OPT=+$$OPTLKP(.OPT)

 +2       ; Sets naked ref

           IF OPT

               IF $DATA(^DIC(19,OPT,0))

                   Begin DoDot:1

 +3                    IF $DATA(MSG)

                           SET $PIECE(^(0),U,3)=MSG

 +4                   IF '$TEST

                           SET MSG=$PIECE(^(0),U,3)

                   End DoDot:1

 +5       IF '$TEST

               SET MSG=""

 +6        IF $QUIT

               QUIT MSG

 +7        QUIT 

 +8       ; Check option for valid access

 +9       ;   OPT=Option IEN or name

 +10      ;   TYP=Optional option type to check

 +11      ;   Returns 0 if OK, <err code>^<err param> otherwise

OPTCHK(OPT,TYP) ;EP

 +1        NEW XQY,X,Y,Z

 +2        SET XQY=$SELECT(OPT=+OPT:OPT,1:$$OPTLKP(OPT))

 +3        IF XQY'>0

               QUIT "2^"_OPT

 +4        SET X=$GET(^DIC(19,XQY,0))

           SET Y=$PIECE($GET(^(3)),U)

           SET Z=$PIECE(X,U,3)

 +5        IF $LENGTH(Z)

               QUIT "19^"_Z

 +6        IF $LENGTH($GET(TYP))

               IF $PIECE(X,U,4)'=TYP

                   QUIT "20^"_OPT_U_TYP

 +7        IF $PIECE(X,U,16)

               IF $LENGTH(Y)

                   IF $$KCHK^XUSRB(Y)

                       QUIT "21^"_OPT_U_Y

 +8        SET Y=$PIECE(X,U,6)

 +9        IF $LENGTH(Y)

               IF '$$KCHK^XUSRB(Y)

                   QUIT "22^"_OPT_U_Y

 +10       SET X=$$NOW^XLFDT

 +11       DO ENTRY^XQ92

 +12       IF 'X

               QUIT "23^"_OPT

 +13       QUIT 0

 +14      ; Nightly task to perform various cleanup procedures.

NIGHTLY   ;EP

 +1        DO CLEANUP

 +2        DO DOPURGE^CIANBEVT(1)

 +3        DO DOPURGE^CIANBLOG

 +4        QUIT