CIANBRPC ;MSC/IND/DKM - MSC RPC Broker Privileged RPCs;10-Jan-2011 13:50;PLS
;;1.1;CIA NETWORK COMPONENTS;**001007,001008**;Sep 18, 2007
;;Copyright 2000-2008, Medsphere Systems Corporation
;=================================================================
; RPC: User authentication
; AID = Application ID
; WID = Workstation ID
; SID = NT Security ID
; AVC = AV Code
; WIP = Workstation IP address
; Returns:
; DATA(0)=Status code^Status text
; where Status code is one of:
; 0 = success (Params=session params)
; 1 = success, verify expired (Params=session params)
; 2 = logins inhibited (Params=null)
; 3 = locked (Params=null)
; 4 = authentication failure (Params=server^volume^UCI^port)
; 5 = other error (Params=null)
; DATA(1)=Params
; DATA(2,n)=Greeting message
AUTH(DATA,AID,WID,SID,AVC,WIP) ;
N XOPT,XUT,XUTEXT,XOPT,XUEON,XUEOFF,XUTT,XUDEV,XUSER,XUNOW,X
K DUZ,DATA,^TMP($J),^UTILITY($J)
D SET1^XUS(0)
S (DUZ,XUT)=0,DUZ(0)="",XUDEV=0,DATA(0)=4,DATA(1)=""
S AID(0)=$$OPTLKP^CIANBUTL(.AID),WID=$$ID(.WID),SID=$G(SID),WIP=$G(WIP)
I '$L(AID(0)),$$CHK(18,5,.AID) Q
S X=$$OPTMSG^CIANBUTL(AID(0))
I $L(X),$$CHK(19,2,X) Q
I '$L($G(AVC)) S DUZ=+$$AUTOLOG(SID),CIAXUT=0
E D
.I $E(AVC,1,2)="~1" S DUZ=$$CHKASH^XUSRB4(AVC)
.S:'DUZ DUZ=$$CHECKAV^XUS($$DECRYP^XUSRB1(AVC)),CIAXUT=$G(CIAXUT)+1
.I 'DUZ,CIAXUT>$P(XOPT,U,2),$$CHK(-7,3) Q
.I 'DUZ,$$CHK(-4,4)
I DUZ D
.S DATA(0)=0,XUNOW=$$NOW^XLFDT,X=$$OPTCHK^CIANBUTL(AID)
.Q:$$CHK(+X,2,$P(X,U,2),$P(X,U,3),$P(X,U,4))
.Q:$$CHK(-$$INHIBIT^XUSRB,2)
.I XUT>$P(XOPT,U,2),$$CHK(-7,3) Q
.D USER^XUS(DUZ)
.Q:$$CHK(-$$UVALID^XUS(),4)
.Q:$$CHK(-$$USER^XUS1A,4)
.F X=0:0 S X=$O(XUTEXT(X)) Q:'X S DATA(2,X)=$E(XUTEXT(X),2,9999)
.D DUZ^XUS1A,SAVE^XUS1,LOG^XUS1,ABT^XQ12
.I $$VCVALID^XUSRB,$$CHK(-12,1)
.I $G(CIA("UID")) D
..N UID
..S UID=CIA("UID"),CIA("UID")=0
..I '$D(^XTMP("CIA",UID)),$$CHK(25,5,UID) Q
..I $$SESSION^CIANBUTL(UID,"DUZ")'=DUZ,$$CHK(27,4,UID) Q
..D:$$ISACTIVE^CIANBUTL(UID) FORCEEX(CIAPORT_":"_$$GETVAR^CIANBUTL("JOB"))
..I $$ISACTIVE^CIANBUTL(UID,1,60),$$CHK(26,4,UID) Q
..S CIA("UID")=UID
..D RESVAR^CIANBUTL,SETVAR^CIANBUTL("JOB",$J)
..D BRDCAST^CIANBEVT("LOGIN",$$SESSION^CIANBUTL)
.E D
..S CIA("UID")=$$UID^CIANBUTL
..D RESET(1)
.S DATA(1)=CIA("UID")_U_$G(^XMB("NETNAME"))_U_$$GET1^DIQ(4,DUZ(2),".01")
.S:AID(0) ^XUTL("XQ",$J,1)=AID(0)_U_$G(^DIC(19,AID(0),0)),^("T")=1
.D AUTOSET(SID),STSAVE^CIANBLIS(1)
I +DATA(0)=4 D
.S DATA(1)=$P(XUENV,U,3)_U_$P(XUVOL,U)_U_XUCI_U_+CIAPORT
.D INTRO^XUS1A("DATA(2)")
Q
; Force exit disconnected broker session
FORCEEX(CIAPORT) ;
S @$$LOCKNODE^CIANBLIS=-1
Q
; Transform ID values
ID(ID) Q $E($TR($G(ID),U,"~"),1,40)
; RPC: Change verify code
CVC(DATA,OLD,NEW) ;
S DATA=$$BRCVC^XUS2($$DECRYP^XUSRB1(OLD),$$DECRYP^XUSRB1(NEW))
S:'DATA DATA="0^Your verify code has been changed."
Q
; RPC: Get division list
DIVGET(DATA) ;
N X,P
S X=0
F S X=$O(^VA(200,DUZ,2,X)) Q:'X S P=$P(^(X,0),U,2) D
.S DATA(X)=X_U_$$NS^XUAF4(X)
.S:P DATA(0)=X
S:'$D(DATA(0)) DATA(0)=+$O(DATA(0))
I 'DATA(0),$G(DUZ(2)) S DATA(0)=DUZ(2),DATA(DUZ(2))=DUZ(2)_U_$$NS^XUAF4(DUZ(2))
D:DATA(0) DIVSET(,DATA(0))
Q
; RPC: Set division
DIVSET(DATA,DIV) ;
S DUZ(2)=+DIV,DATA=1
D SETVAR^CIANBUTL("DUZ2",DUZ(2))
D SETVAR^CIANBUTL("DUZ(2)",DUZ(2),-1)
Q
; RPC: Get dialog text
DIALOG(DATA,DLG,P1,P2,P3) ;
D GETDLG^CIANBUTL(DLG,.DATA,.P1,.P2,.P3)
Q
; RPC: Reset session
RESET(LOGIN) ;
Q:'$G(CIA("UID"))
D STOPALL^CIANBASY,UNSUBALL^CIANBEVT
S LOGIN=+$G(LOGIN)
N DUZ2
S DUZ2=$$GETVAR^CIANBUTL("DUZ2")
I 'LOGIN D
.D CLOSE^CIANBLOG($$GETVAR^CIANBUTL("ALOG"_$S(DUZ2:":"_DUZ2,1:"")))
.S IO("IP")=$$GETVAR^CIANBUTL("WIP")
.D BRDCAST^CIANBEVT("LOGOUT",$$SESSION^CIANBUTL)
.K ^XTMP("CIA",CIA("UID"))
.L -^XTMP("CIA",CIA("UID"),0)
.D BYE^XUSCLEAN
E D
.N ENV,X,Y,V
.K ^XTMP("CIA",CIA("UID"))
.F ENV=0:1 S X=$P($T(ENVDATA+ENV),";;",2) Q:'$L(X) D
..S V=$P(X,";",2),@("Y="_V)
..D SETVAR^CIANBUTL($P(X,";"),Y)
..D:$P(X,";",3) SETVAR^CIANBUTL(V,Y,-1)
.D BRDCAST^CIANBEVT("LOGIN",$$SESSION^CIANBUTL)
.S IO("IP")=$$GETVAR^CIANBUTL("WIP")
.I $$ISACTIVE^CIANBLOG
.D LOG^XUS1 ;creates handle with client agent
Q
; Environment data to save
;;Name;Value;Local
ENVDATA ;;DUZ;DUZ
;;DUZ0;DUZ(0);1
;;DUZ2;DUZ(2);1
;;USER;$P($G(^VA(200,DUZ,0)),U)
;;RDEV;$$RESDEV^CIANBUTL
;;LDT;$H
;;JOB;$J
;;AID;AID
;;AID0;AID(0)
;;WID;WID
;;WIP;WIP
;;UID;CIA("UID")
;;
; Check error code
CHK(ERR,RTN,P1,P2,P3) ;
I ERR S DATA(0)=RTN_U_$S(ERR<0:$$TXT^XUS3(-ERR),1:$$GETDLG^CIANBUTL(ERR,,.P1,.P2,.P3)) S:RTN>1 DUZ=0
Q ERR
; Attempt autoauthenticate using SID
; Returns DUZ if SID has been authenticated, 0 if prohibited from
; being authenticated, or null if never been authenticated.
AUTOLOG(SID) ;
S SID=$S($L($G(SID))<3:"",1:$$DECRYP^XUSRB1(SID))
Q:$E(SID,1,9)'="S-1-5-21-" 0
S SID=$E(SID,10,999)
Q:SID<1000 0
N X
S X=$$FIND1^DIC(19941.2,"","QX",SID)
Q $S(X:+$P($G(^CIANB(19941.2,X,0)),U,2),1:"")
; Cache NT authentication information
AUTOSET(SID) ;
Q:$$AUTOLOG(.SID)'=""
N FLD
S FLD(19941.2,"+1,",.01)=SID
S FLD(19941.2,"+1,",1)=DUZ
S FLD(19941.2,"+1,",2)=$$NOW^XLFDT
D UPDATE^DIE("","FLD")
Q
; RPC: Get list of active RPCs
GETRPCS(DATA) ;
N X
D LIST^DIC(8994,,".01","Q",,,,,"I ""03""[$P(^(0),U,6)",,.DATA)
S X=""
F S X=$O(@DATA@(X)) Q:'$L(X) K:X'="ID" @DATA@(X)
Q
; RPC: Can RPC be executed in current context
CANRUN(DATA,RPC) ;
S DATA=$$CANRUN^CIANBACT($$FIND1^DIC(8994,,"QX",RPC),CIA("CTX"))
Q
; RPC: Retrieve list of active sessions
GETSESSN(DATA,VAR,AID) ;
N X,Z,C
S DATA=$$TMPGBL
F C=1:1 Q:'$$NXTUID^CIANBUTL(.X,,.AID) S @DATA@(C)=$$SESSION^CIANBUTL(X,.VAR)
Q
; RPC: Get stored variable(s)
GETVAR(DATA,LIST,NMSP) ;
N CNT
S:$L($G(LIST)) LIST(-99)=LIST
S LIST="",CNT=0
S:0[$G(NMSP) NMSP="@"
F S LIST=$O(LIST(LIST)) Q:'$L(LIST) D
.S CNT=CNT+1,DATA(CNT)=LIST(LIST)_"="_$$GETVAR^CIANBUTL(LIST(LIST),,NMSP)
Q
; RPC: Set stored variable(s)
SETVAR(DATA,LIST,NMSP,RESET) ;
S:$L($G(LIST)) LIST(-99)=LIST
S LIST="",DATA=0
S:0[$G(NMSP) NMSP="@"
D:$G(RESET) CLRVAR^CIANBUTL(NMSP)
F S LIST=$O(LIST(LIST)) Q:'$L(LIST) D
.S DATA=DATA+1
.D SETVAR^CIANBUTL($P(LIST(LIST),"="),$P(LIST(LIST),"=",2,9999),NMSP)
Q
; RPC: Get requested session info
; TYPE = 0=subscriptions, 1=local vars, 2=session vars, 3=locks, 4=pending async RPCs
; UID = Session ID (defaults to current session)
GETINFO(DATA,TYPE,UID) ;
S UID=$G(UID,$G(CIA("UID")))
I TYPE=0 D Q
.N EV,CN
.S EV="",CN=0
.F S EV=$O(^XTMP("CIA",UID,"S",EV)) Q:'$L(EV) D
..S CN=CN+1,@DATA@(CN)=EV
I TYPE=1 D Q
.D CAPTURE^CIAUHFS("ZW N X F X=""$ET"",""$EC"",""$ES"",""$J"",""$ZE"",""$ZT"" W !,X,""="",@X",DATA,99999)
I TYPE=2 D Q
.N NS,VN,VL,CN
.S NS="",CN=0
.F S NS=$O(^XTMP("CIA",UID,"V",NS)),VN="" Q:'$L(NS) D
..F S VN=$O(^XTMP("CIA",UID,"V",NS,VN)) Q:'$L(VN) S VL=$G(^(VN)) D
...S CN=CN+1,@DATA@(CN)=$S(NS=0:"<default>",NS=-1:"<mapped>",1:NS)_U_VN_U_VL
I TYPE=3 D Q
.N GBL,CN,VL
.S GBL="",CN=0
.F S GBL=$O(^XTMP("CIA",UID,"L",GBL)) Q:'$L(GBL) S VL=$G(^(GBL)) D
..S CN=CN+1,@DATA@(CN)=$TR(GBL,U,"~")_U_VL
I TYPE=4 D Q
.N TSK,CN
.S (TSK,CN)=0
.F S TSK=$O(^XTMP("CIA",UID,"T",TSK)) Q:'TSK D
..S CN=CN+1,@DATA@(CN)=TSK_U_$G(^%ZTSK(TSK,.03),"Unknown")
S @DATA@(1)="Unknown request type: "_TYPE
Q
; Lock/unlock global reference
; GBL = Global reference
; OPR = Operation to perform:
; >=0: Value is timeout for lock operation. Returns success.
; <0: Returns # of active locks for node.
; missing: Performs unlock operation. Returns success.
; DATA = Returns status according to value of OPR.
LOCK(DATA,GBL,OPR) ;
N LCK
S LCK=$D(OPR),OPR=+$G(OPR),GBL=$NA(@GBL)
I OPR<0 S DATA=$$LOCKCNT(GBL)
E I LCK D
.L +@GBL:OPR
.S DATA=$T
.I DATA,$$LOCKCNT(GBL,1)
E D
.S DATA=''$$LOCKCNT(GBL,-1)
.L:DATA -@GBL
Q
; RPC: Restore locks (after reconnect)
; Data returns list of locks that could not be restored.
LOCKRES(DATA) ;
N GBL,CNT,X
S GBL="",X=0
F S GBL=$O(^XTMP("CIA",CIA("UID"),"L",GBL)) Q:'$L(GBL) S CNT=+$G(^(GBL)) D
.F CNT=CNT:-1:1 L +@GBL:1 E D Q
..S X=X+1,@DATA@(X)=GBL
..K ^XTMP("CIA",CIA("UID"),"L",GBL)
Q
; Return lock count. Optionally increment/decrement afterwards.
; Note use of naked reference.
LOCKCNT(GBL,INC) ;
N X,Y
S X=+$G(^XTMP("CIA",CIA("UID"),"L",GBL)),Y=X+$G(INC) ; Sets naked reference
I Y>0 S ^(GBL)=Y
E K ^(GBL)
Q X
; Get temp global reference
TMPGBL(X) ;
K ^TMP("CIANBTMP"_$G(X),$J) Q $NA(^($J))
CIANBRPC ;MSC/IND/DKM - MSC RPC Broker Privileged RPCs;10-Jan-2011 13:50;PLS
+1 ;;1.1;CIA NETWORK COMPONENTS;**001007,001008**;Sep 18, 2007
+2 ;;Copyright 2000-2008, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; RPC: User authentication
+5 ; AID = Application ID
+6 ; WID = Workstation ID
+7 ; SID = NT Security ID
+8 ; AVC = AV Code
+9 ; WIP = Workstation IP address
+10 ; Returns:
+11 ; DATA(0)=Status code^Status text
+12 ; where Status code is one of:
+13 ; 0 = success (Params=session params)
+14 ; 1 = success, verify expired (Params=session params)
+15 ; 2 = logins inhibited (Params=null)
+16 ; 3 = locked (Params=null)
+17 ; 4 = authentication failure (Params=server^volume^UCI^port)
+18 ; 5 = other error (Params=null)
+19 ; DATA(1)=Params
+20 ; DATA(2,n)=Greeting message
AUTH(DATA,AID,WID,SID,AVC,WIP) ;
+1 NEW XOPT,XUT,XUTEXT,XOPT,XUEON,XUEOFF,XUTT,XUDEV,XUSER,XUNOW,X
+2 KILL DUZ,DATA,^TMP($JOB),^UTILITY($JOB)
+3 DO SET1^XUS(0)
+4 SET (DUZ,XUT)=0
SET DUZ(0)=""
SET XUDEV=0
SET DATA(0)=4
SET DATA(1)=""
+5 SET AID(0)=$$OPTLKP^CIANBUTL(.AID)
SET WID=$$ID(.WID)
SET SID=$GET(SID)
SET WIP=$GET(WIP)
+6 IF '$LENGTH(AID(0))
IF $$CHK(18,5,.AID)
QUIT
+7 SET X=$$OPTMSG^CIANBUTL(AID(0))
+8 IF $LENGTH(X)
IF $$CHK(19,2,X)
QUIT
+9 IF '$LENGTH($GET(AVC))
SET DUZ=+$$AUTOLOG(SID)
SET CIAXUT=0
+10 IF '$TEST
Begin DoDot:1
+11 IF $EXTRACT(AVC,1,2)="~1"
SET DUZ=$$CHKASH^XUSRB4(AVC)
+12 IF 'DUZ
SET DUZ=$$CHECKAV^XUS($$DECRYP^XUSRB1(AVC))
SET CIAXUT=$GET(CIAXUT)+1
+13 IF 'DUZ
IF CIAXUT>$PIECE(XOPT,U,2)
IF $$CHK(-7,3)
QUIT
+14 IF 'DUZ
IF $$CHK(-4,4)
End DoDot:1
+15 IF DUZ
Begin DoDot:1
+16 SET DATA(0)=0
SET XUNOW=$$NOW^XLFDT
SET X=$$OPTCHK^CIANBUTL(AID)
+17 IF $$CHK(+X,2,$PIECE(X,U,2),$PIECE(X,U,3),$PIECE(X,U,4))
QUIT
+18 IF $$CHK(-$$INHIBIT^XUSRB,2)
QUIT
+19 IF XUT>$PIECE(XOPT,U,2)
IF $$CHK(-7,3)
QUIT
+20 DO USER^XUS(DUZ)
+21 IF $$CHK(-$$UVALID^XUS(),4)
QUIT
+22 IF $$CHK(-$$USER^XUS1A,4)
QUIT
+23 FOR X=0:0
SET X=$ORDER(XUTEXT(X))
IF 'X
QUIT
SET DATA(2,X)=$EXTRACT(XUTEXT(X),2,9999)
+24 DO DUZ^XUS1A
DO SAVE^XUS1
DO LOG^XUS1
DO ABT^XQ12
+25 IF $$VCVALID^XUSRB
IF $$CHK(-12,1)
+26 IF $GET(CIA("UID"))
Begin DoDot:2
+27 NEW UID
+28 SET UID=CIA("UID")
SET CIA("UID")=0
+29 IF '$DATA(^XTMP("CIA",UID))
IF $$CHK(25,5,UID)
QUIT
+30 IF $$SESSION^CIANBUTL(UID,"DUZ")'=DUZ
IF $$CHK(27,4,UID)
QUIT
+31 IF $$ISACTIVE^CIANBUTL(UID)
DO FORCEEX(CIAPORT_":"_$$GETVAR^CIANBUTL("JOB"))
+32 IF $$ISACTIVE^CIANBUTL(UID,1,60)
IF $$CHK(26,4,UID)
QUIT
+33 SET CIA("UID")=UID
+34 DO RESVAR^CIANBUTL
DO SETVAR^CIANBUTL("JOB",$JOB)
+35 DO BRDCAST^CIANBEVT("LOGIN",$$SESSION^CIANBUTL)
End DoDot:2
+36 IF '$TEST
Begin DoDot:2
+37 SET CIA("UID")=$$UID^CIANBUTL
+38 DO RESET(1)
End DoDot:2
+39 SET DATA(1)=CIA("UID")_U_$GET(^XMB("NETNAME"))_U_$$GET1^DIQ(4,DUZ(2),".01")
+40 IF AID(0)
SET ^XUTL("XQ",$JOB,1)=AID(0)_U_$GET(^DIC(19,AID(0),0))
SET ^("T")=1
+41 DO AUTOSET(SID)
DO STSAVE^CIANBLIS(1)
End DoDot:1
+42 IF +DATA(0)=4
Begin DoDot:1
+43 SET DATA(1)=$PIECE(XUENV,U,3)_U_$PIECE(XUVOL,U)_U_XUCI_U_+CIAPORT
+44 DO INTRO^XUS1A("DATA(2)")
End DoDot:1
+45 QUIT
+46 ; Force exit disconnected broker session
FORCEEX(CIAPORT) ;
+1 SET @$$LOCKNODE^CIANBLIS=-1
+2 QUIT
+3 ; Transform ID values
ID(ID) QUIT $EXTRACT($TRANSLATE($GET(ID),U,"~"),1,40)
+1 ; RPC: Change verify code
CVC(DATA,OLD,NEW) ;
+1 SET DATA=$$BRCVC^XUS2($$DECRYP^XUSRB1(OLD),$$DECRYP^XUSRB1(NEW))
+2 IF 'DATA
SET DATA="0^Your verify code has been changed."
+3 QUIT
+4 ; RPC: Get division list
DIVGET(DATA) ;
+1 NEW X,P
+2 SET X=0
+3 FOR
SET X=$ORDER(^VA(200,DUZ,2,X))
IF 'X
QUIT
SET P=$PIECE(^(X,0),U,2)
Begin DoDot:1
+4 SET DATA(X)=X_U_$$NS^XUAF4(X)
+5 IF P
SET DATA(0)=X
End DoDot:1
+6 IF '$DATA(DATA(0))
SET DATA(0)=+$ORDER(DATA(0))
+7 IF 'DATA(0)
IF $GET(DUZ(2))
SET DATA(0)=DUZ(2)
SET DATA(DUZ(2))=DUZ(2)_U_$$NS^XUAF4(DUZ(2))
+8 IF DATA(0)
DO DIVSET(,DATA(0))
+9 QUIT
+10 ; RPC: Set division
DIVSET(DATA,DIV) ;
+1 SET DUZ(2)=+DIV
SET DATA=1
+2 DO SETVAR^CIANBUTL("DUZ2",DUZ(2))
+3 DO SETVAR^CIANBUTL("DUZ(2)",DUZ(2),-1)
+4 QUIT
+5 ; RPC: Get dialog text
DIALOG(DATA,DLG,P1,P2,P3) ;
+1 DO GETDLG^CIANBUTL(DLG,.DATA,.P1,.P2,.P3)
+2 QUIT
+3 ; RPC: Reset session
RESET(LOGIN) ;
+1 IF '$GET(CIA("UID"))
QUIT
+2 DO STOPALL^CIANBASY
DO UNSUBALL^CIANBEVT
+3 SET LOGIN=+$GET(LOGIN)
+4 NEW DUZ2
+5 SET DUZ2=$$GETVAR^CIANBUTL("DUZ2")
+6 IF 'LOGIN
Begin DoDot:1
+7 DO CLOSE^CIANBLOG($$GETVAR^CIANBUTL("ALOG"_$SELECT(DUZ2:":"_DUZ2,1:"")))
+8 SET IO("IP")=$$GETVAR^CIANBUTL("WIP")
+9 DO BRDCAST^CIANBEVT("LOGOUT",$$SESSION^CIANBUTL)
+10 KILL ^XTMP("CIA",CIA("UID"))
+11 LOCK -^XTMP("CIA",CIA("UID"),0)
+12 DO BYE^XUSCLEAN
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 NEW ENV,X,Y,V
+15 KILL ^XTMP("CIA",CIA("UID"))
+16 FOR ENV=0:1
SET X=$PIECE($TEXT(ENVDATA+ENV),";;",2)
IF '$LENGTH(X)
QUIT
Begin DoDot:2
+17 SET V=$PIECE(X,";",2)
SET @("Y="_V)
+18 DO SETVAR^CIANBUTL($PIECE(X,";"),Y)
+19 IF $PIECE(X,";",3)
DO SETVAR^CIANBUTL(V,Y,-1)
End DoDot:2
+20 DO BRDCAST^CIANBEVT("LOGIN",$$SESSION^CIANBUTL)
+21 SET IO("IP")=$$GETVAR^CIANBUTL("WIP")
+22 IF $$ISACTIVE^CIANBLOG
+23 ;creates handle with client agent
DO LOG^XUS1
End DoDot:1
+24 QUIT
+25 ; Environment data to save
+26 ;;Name;Value;Local
ENVDATA ;;DUZ;DUZ
+1 ;;DUZ0;DUZ(0);1
+2 ;;DUZ2;DUZ(2);1
+3 ;;USER;$P($G(^VA(200,DUZ,0)),U)
+4 ;;RDEV;$$RESDEV^CIANBUTL
+5 ;;LDT;$H
+6 ;;JOB;$J
+7 ;;AID;AID
+8 ;;AID0;AID(0)
+9 ;;WID;WID
+10 ;;WIP;WIP
+11 ;;UID;CIA("UID")
+12 ;;
+13 ; Check error code
CHK(ERR,RTN,P1,P2,P3) ;
+1 IF ERR
SET DATA(0)=RTN_U_$SELECT(ERR<0:$$TXT^XUS3(-ERR),1:$$GETDLG^CIANBUTL(ERR,,.P1,.P2,.P3))
IF RTN>1
SET DUZ=0
+2 QUIT ERR
+3 ; Attempt autoauthenticate using SID
+4 ; Returns DUZ if SID has been authenticated, 0 if prohibited from
+5 ; being authenticated, or null if never been authenticated.
AUTOLOG(SID) ;
+1 SET SID=$SELECT($LENGTH($GET(SID))<3:"",1:$$DECRYP^XUSRB1(SID))
+2 IF $EXTRACT(SID,1,9)'="S-1-5-21-"
QUIT 0
+3 SET SID=$EXTRACT(SID,10,999)
+4 IF SID<1000
QUIT 0
+5 NEW X
+6 SET X=$$FIND1^DIC(19941.2,"","QX",SID)
+7 QUIT $SELECT(X:+$PIECE($GET(^CIANB(19941.2,X,0)),U,2),1:"")
+8 ; Cache NT authentication information
AUTOSET(SID) ;
+1 IF $$AUTOLOG(.SID)'=""
QUIT
+2 NEW FLD
+3 SET FLD(19941.2,"+1,",.01)=SID
+4 SET FLD(19941.2,"+1,",1)=DUZ
+5 SET FLD(19941.2,"+1,",2)=$$NOW^XLFDT
+6 DO UPDATE^DIE("","FLD")
+7 QUIT
+8 ; RPC: Get list of active RPCs
GETRPCS(DATA) ;
+1 NEW X
+2 DO LIST^DIC(8994,,".01","Q",,,,,"I ""03""[$P(^(0),U,6)",,.DATA)
+3 SET X=""
+4 FOR
SET X=$ORDER(@DATA@(X))
IF '$LENGTH(X)
QUIT
IF X'="ID"
KILL @DATA@(X)
+5 QUIT
+6 ; RPC: Can RPC be executed in current context
CANRUN(DATA,RPC) ;
+1 SET DATA=$$CANRUN^CIANBACT($$FIND1^DIC(8994,,"QX",RPC),CIA("CTX"))
+2 QUIT
+3 ; RPC: Retrieve list of active sessions
GETSESSN(DATA,VAR,AID) ;
+1 NEW X,Z,C
+2 SET DATA=$$TMPGBL
+3 FOR C=1:1
IF '$$NXTUID^CIANBUTL(.X,,.AID)
QUIT
SET @DATA@(C)=$$SESSION^CIANBUTL(X,.VAR)
+4 QUIT
+5 ; RPC: Get stored variable(s)
GETVAR(DATA,LIST,NMSP) ;
+1 NEW CNT
+2 IF $LENGTH($GET(LIST))
SET LIST(-99)=LIST
+3 SET LIST=""
SET CNT=0
+4 IF 0[$GET(NMSP)
SET NMSP="@"
+5 FOR
SET LIST=$ORDER(LIST(LIST))
IF '$LENGTH(LIST)
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
SET DATA(CNT)=LIST(LIST)_"="_$$GETVAR^CIANBUTL(LIST(LIST),,NMSP)
End DoDot:1
+7 QUIT
+8 ; RPC: Set stored variable(s)
SETVAR(DATA,LIST,NMSP,RESET) ;
+1 IF $LENGTH($GET(LIST))
SET LIST(-99)=LIST
+2 SET LIST=""
SET DATA=0
+3 IF 0[$GET(NMSP)
SET NMSP="@"
+4 IF $GET(RESET)
DO CLRVAR^CIANBUTL(NMSP)
+5 FOR
SET LIST=$ORDER(LIST(LIST))
IF '$LENGTH(LIST)
QUIT
Begin DoDot:1
+6 SET DATA=DATA+1
+7 DO SETVAR^CIANBUTL($PIECE(LIST(LIST),"="),$PIECE(LIST(LIST),"=",2,9999),NMSP)
End DoDot:1
+8 QUIT
+9 ; RPC: Get requested session info
+10 ; TYPE = 0=subscriptions, 1=local vars, 2=session vars, 3=locks, 4=pending async RPCs
+11 ; UID = Session ID (defaults to current session)
GETINFO(DATA,TYPE,UID) ;
+1 SET UID=$GET(UID,$GET(CIA("UID")))
+2 IF TYPE=0
Begin DoDot:1
+3 NEW EV,CN
+4 SET EV=""
SET CN=0
+5 FOR
SET EV=$ORDER(^XTMP("CIA",UID,"S",EV))
IF '$LENGTH(EV)
QUIT
Begin DoDot:2
+6 SET CN=CN+1
SET @DATA@(CN)=EV
End DoDot:2
End DoDot:1
QUIT
+7 IF TYPE=1
Begin DoDot:1
+8 DO CAPTURE^CIAUHFS("ZW N X F X=""$ET"",""$EC"",""$ES"",""$J"",""$ZE"",""$ZT"" W !,X,""="",@X",DATA,99999)
End DoDot:1
QUIT
+9 IF TYPE=2
Begin DoDot:1
+10 NEW NS,VN,VL,CN
+11 SET NS=""
SET CN=0
+12 FOR
SET NS=$ORDER(^XTMP("CIA",UID,"V",NS))
SET VN=""
IF '$LENGTH(NS)
QUIT
Begin DoDot:2
+13 FOR
SET VN=$ORDER(^XTMP("CIA",UID,"V",NS,VN))
IF '$LENGTH(VN)
QUIT
SET VL=$GET(^(VN))
Begin DoDot:3
+14 SET CN=CN+1
SET @DATA@(CN)=$SELECT(NS=0:"<default>",NS=-1:"<mapped>",1:NS)_U_VN_U_VL
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+15 IF TYPE=3
Begin DoDot:1
+16 NEW GBL,CN,VL
+17 SET GBL=""
SET CN=0
+18 FOR
SET GBL=$ORDER(^XTMP("CIA",UID,"L",GBL))
IF '$LENGTH(GBL)
QUIT
SET VL=$GET(^(GBL))
Begin DoDot:2
+19 SET CN=CN+1
SET @DATA@(CN)=$TRANSLATE(GBL,U,"~")_U_VL
End DoDot:2
End DoDot:1
QUIT
+20 IF TYPE=4
Begin DoDot:1
+21 NEW TSK,CN
+22 SET (TSK,CN)=0
+23 FOR
SET TSK=$ORDER(^XTMP("CIA",UID,"T",TSK))
IF 'TSK
QUIT
Begin DoDot:2
+24 SET CN=CN+1
SET @DATA@(CN)=TSK_U_$GET(^%ZTSK(TSK,.03),"Unknown")
End DoDot:2
End DoDot:1
QUIT
+25 SET @DATA@(1)="Unknown request type: "_TYPE
+26 QUIT
+27 ; Lock/unlock global reference
+28 ; GBL = Global reference
+29 ; OPR = Operation to perform:
+30 ; >=0: Value is timeout for lock operation. Returns success.
+31 ; <0: Returns # of active locks for node.
+32 ; missing: Performs unlock operation. Returns success.
+33 ; DATA = Returns status according to value of OPR.
LOCK(DATA,GBL,OPR) ;
+1 NEW LCK
+2 SET LCK=$DATA(OPR)
SET OPR=+$GET(OPR)
SET GBL=$NAME(@GBL)
+3 IF OPR<0
SET DATA=$$LOCKCNT(GBL)
+4 IF '$TEST
IF LCK
Begin DoDot:1
+5 LOCK +@GBL:OPR
+6 SET DATA=$TEST
+7 IF DATA
IF $$LOCKCNT(GBL,1)
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET DATA=''$$LOCKCNT(GBL,-1)
+10 IF DATA
LOCK -@GBL
End DoDot:1
+11 QUIT
+12 ; RPC: Restore locks (after reconnect)
+13 ; Data returns list of locks that could not be restored.
LOCKRES(DATA) ;
+1 NEW GBL,CNT,X
+2 SET GBL=""
SET X=0
+3 FOR
SET GBL=$ORDER(^XTMP("CIA",CIA("UID"),"L",GBL))
IF '$LENGTH(GBL)
QUIT
SET CNT=+$GET(^(GBL))
Begin DoDot:1
+4 FOR CNT=CNT:-1:1
LOCK +@GBL:1
IF '$TEST
Begin DoDot:2
+5 SET X=X+1
SET @DATA@(X)=GBL
+6 KILL ^XTMP("CIA",CIA("UID"),"L",GBL)
End DoDot:2
QUIT
End DoDot:1
+7 QUIT
+8 ; Return lock count. Optionally increment/decrement afterwards.
+9 ; Note use of naked reference.
LOCKCNT(GBL,INC) ;
+1 NEW X,Y
+2 ; Sets naked reference
SET X=+$GET(^XTMP("CIA",CIA("UID"),"L",GBL))
SET Y=X+$GET(INC)
+3 IF Y>0
SET ^(GBL)=Y
+4 IF '$TEST
KILL ^(GBL)
+5 QUIT X
+6 ; Get temp global reference
TMPGBL(X) ;
+1 KILL ^TMP("CIANBTMP"_$GET(X),$JOB)
QUIT $NAME(^($JOB))
