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

CIANBRPC.m

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