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

CIANBACT.m

Go to the documentation of this file. 
  1. CIANBACT ;MSC/IND/DKM/PLS - MSC RPC Broker Actions;16-Apr-2013 18:42;PLS
  1.  ;;1.1;CIA NETWORK COMPONENTS;**001007,001010**;Sep 18, 2007
  1.  ;;Copyright 2000-2008, Medsphere Systems Corporation
  1.  ;=================================================================
  1.  ; Connect action
  1.  ; CIADATA is returned to client as:
  1.  ;   callback flag^authentication method^server version^case sensitive^context cached
  1. ACTC N X,Y,VOL,UCI,PORT,IP,AUTH
  1.  S Y=$$GETUCI,UCI(0)=Y,UCI=$$UP^XLFSTR($G(CIA("UCI"),Y)),VOL=$P(UCI,",",2)
  1.  S:'$L(UCI) UCI=Y
  1.  S:'$L(VOL) VOL=$P(Y,",",2),$P(UCI,",",2)=VOL
  1.  I UCI'=UCI(0),$$ERRCHK(0[$$UCICHECK^%ZOSV(UCI),14,UCI) Q
  1.  Q:$$ERRCHK('$L(VOL),11)
  1.  S AUTH=$$AUTHMETH(UCI),CIADATA="0^"_AUTH_"^1.1^"_$$GET^XPAR("SYS","XU VC CASE SENSITIVE")_"^1"
  1.  Q:$$ERRCHK('$L(AUTH),24,UCI)
  1.  I $D(^%ZOSF("ACTJ")) D  Q:$$ERRCHK(X'>Y&X,10,Y,X)
  1.  .; Y=# active jobs, X=max active jobs
  1.  .X ^%ZOSF("ACTJ")
  1.  .S X=+$O(^XTV(8989.3,1,4,"B",VOL,0)),X=$S(X:+$P($G(^XTV(8989.3,1,4,X,0)),U,3),1:0)
  1.  S PORT=CIA("LP"),X=$$CLIENTIP^CIAUOS,IP=$S(CIAMODE=2:CIAIP,$L(X):X,1:CIA("IP"))
  1.  S @("X=$$JOB"_CIAOS)
  1.  D ERRCHK('X,12)
  1.  Q
  1.  ; Disconnect action
  1. ACTD D RESET^CIANBRPC()
  1.  S CIADATA=1,CIAQUIT=1
  1.  Q
  1.  ; Query action
  1. ACTQ Q:$$ASYCHK^CIANBASY
  1.  Q:$$EVTCHK^CIANBEVT
  1.  ; Ping action
  1. ACTP S DT=$$NOW^XLFDT,CIADATA=$$PARAM^CIANBUTL("CIANB POLLING INTERVAL",1,60)_U_DT,DT=DT\1
  1.  Q
  1.  ; Subscribe action
  1. ACTS S CIADATA=1
  1.  Q:$$ERRCHK('$$SUBSCR^CIANBEVT(CIA("EVT"),1),13,CIA("EVT"))
  1.  Q
  1.  ; Unsubscribe action
  1. ACTU S CIADATA=$$SUBSCR^CIANBEVT(CIA("EVT"),0)
  1.  Q
  1.  ; RPC action
  1. ACTR N RPC,RTN,CIAD,XWBWRAP,XWBPTYPE,I
  1.  I '$D(CIA("CTX")) S CIA("CTX")=$$GETVAR^CIANBUTL("CTX")
  1.  E  D SETVAR^CIANBUTL("CTX",CIA("CTX"))
  1.  S:CIA("CTX")="" CIA("CTX")=$$GETVAR^CIANBUTL("AID")
  1.  S RPC=$$FIND1^DIC(8994,,"QX",$G(CIA("RPC")))
  1.  Q:$$ERRCHK('RPC,3)
  1.  S I=$G(^XWB(8994,RPC,0)),RTN=$P(I,U,2,3),XWBWRAP=+$P(I,U,8),XWBPTYPE=$P(I,U,4)
  1.  Q:$$ERRCHK($S($E($P(RTN,U,2),1,5)="CIANB":0,1:'$$CANRUN(RPC,CIA("CTX"))),4)
  1.  Q:$$ERRCHK("03"'[$P(I,U,6),5)
  1.  Q:$$ERRCHK(RTN'?.8AN1"^"1.8AN,6)
  1.  Q:$$ERRCHK("^1^2^3^4^5^H^"'[(U_XWBPTYPE_U),6)
  1.  Q:$$ERRCHK(ARG>40,7,,ARG,40)
  1.  I $G(CIA("ASY")) D
  1.  .N RD
  1.  .S RD="CIANB THREAD RESOURCE #"_$$GETVAR^CIANBUTL("RDEV")
  1.  .S CIAD=$$QUEUE^CIAUTSK("TASK^CIANBASY","ASYNC RPC: "_CIA("RPC"),,"RTN^XWBWRAP^XWBPTYPE^ARG^ARG(^CIA(^XWBOS^P*",RD)
  1.  .Q:$$ERRCHK(CIAD<1,8)
  1.  .S ^XTMP("CIA",CIA("UID"),"T",CIAD)=""
  1.  .D REPLY^CIANBLIS(CIAD)
  1.  E  D
  1.  .S:XWBPTYPE=4 CIAD=$$TMPGBL^CIANBRPC("X")
  1.  .D STREST^CIANBLIS(1),DORPC,DATAOUT
  1.  Q
  1.  ; Builds the RPC entry code and executes it
  1. DORPC N I,P,XWBAPVER,XQY,CIAQUIT,ALOG,$ET
  1.  S RTN=RTN_"(.CIAD",XWBAPVER=$G(CIA("VER")),XQY=$$GETVAR^CIANBUTL("AID0")
  1.  S ALOG=$$ISACTIVE^CIANBLOG,ALOG(0)=$S(ALOG:$$LOG^CIANBLOG(ALOG,1,CIA("RPC")),1:0)
  1.  F I=1:1:ARG D
  1.  .S RTN=RTN_","
  1.  .Q:'$D(ARG(I))
  1.  .S P="P"_I,RTN=RTN_"."_P
  1.  .S:$D(@P)=10 @P=""
  1.  .D:ALOG(0) ADD^CIANBLOG(ALOG,ALOG(0),P,1)
  1.  S RTN=RTN_")"
  1.  D
  1.  .N ALOG
  1.  .D @RTN
  1.  I $$TEST^CIAUOS("BUSARPC") D
  1.  .D CIA^BUSARPC(XWBPTYPE,RTN,$G(CIA("RPC")))
  1.  I ALOG(0) D
  1.  .N VAL,ARY
  1.  .S VAL=$C(13)_"Return Data:"_$C(13)
  1.  .D ADD^CIANBLOG(ALOG,ALOG(0),"VAL")
  1.  .I XWBPTYPE=1 S VAL=$G(CIAD),ARY="VAL"
  1.  .E  I XWBPTYPE=2 S ARY="CIAD"
  1.  .E  I XWBPTYPE=3 S ARY="CIAD"
  1.  .E  I XWBPTYPE=4 S ARY=CIAD
  1.  .E  I XWBPTYPE=5 S VAL=$G(@CIAD),ARY="VAL"
  1.  .E  I XWBPTYPE="H" S VAL=CIAD,ARY="VAL"
  1.  .E  Q
  1.  .D ADD^CIANBLOG(ALOG,ALOG(0),ARY)
  1.  Q
  1.  ; Test for error condition
  1.  ; TEST = If true, setup the error
  1.  ; ERR  = Error code
  1.  ; Pn   = Optional parameters (up to 3)
  1. ERRCHK(TEST,ERR,P1,P2,P3) ;
  1.  I TEST,'$G(CIAERR(0)) D
  1.  .D GETDLG^CIANBUTL(ERR,.CIAERR,.P1,.P2,.P3)
  1.  .S CIAERR(0)=ERR
  1.  Q:$Q +$G(CIAERR(0))
  1.  Q
  1.  ; Writes return data to TCP stream
  1. DATAOUT D TCPUSE^CIANBLIS
  1.  W $C(0)
  1.  I XWBPTYPE=1 W $G(CIAD),! Q
  1.  I XWBPTYPE=2 D OUT("CIAD",1) Q
  1.  I XWBPTYPE=3 D OUT("CIAD",XWBWRAP) Q
  1.  I XWBPTYPE=4 D OUT(CIAD,XWBWRAP) Q
  1.  I XWBPTYPE=5 W $G(@CIAD),! Q
  1.  I XWBPTYPE="H" D HFSOUT(CIAD,XWBWRAP) Q
  1.  Q
  1.  ; Write array (local or global) to TCP stream
  1. OUT(ARY,EOL) ;
  1.  N X,L,K
  1.  S K=$E(ARY)'="~"
  1.  S:'K ARY=$E(ARY,2,999)
  1.  Q:'$L(ARY)
  1.  S ARY=$NA(@ARY)
  1.  S X=ARY,L=$QL(ARY),EOL=$S($G(EOL):$C(13),1:"")
  1.  F  S X=$Q(@X) Q:'$L(X)  Q:$NA(@X,L)'=ARY  W @X,EOL,!
  1.  K:K @ARY
  1.  Q
  1.  ; Write contents of HFS to TCP stream
  1. HFSOUT(HFS,EOL) ;
  1.  N X
  1.  S EOL=$S($G(EOL):$C(13),1:"")
  1.  D OPEN^CIAUOS(.HFS,"R")
  1.  F  Q:$$READ^CIAUOS(.X,HFS)  D
  1.  .D TCPUSE^CIANBLIS
  1.  .W X,EOL,!
  1.  D CLOSE^CIAUOS(.HFS),DELETE^CIAUOS(HFS)
  1.  Q
  1.  ; Returns true if RPC can run in current context
  1. CANRUN(RPC,CTX) ;
  1.  Q:'$G(DUZ)!'RPC 0
  1.  S CTX(0)=$$OPTLKP^CIANBUTL(CTX)
  1.  Q:$$ERRCHK('$L(CTX(0)),2,CTX) 0
  1.  D:'$G(^XTMP("CIA",CIA("UID"),"C",CTX(0))) BLDCTX(CTX(0))
  1.  Q:$$KCHK^XUSRB("XUPROGMODE") 1
  1.  Q $D(^XTMP("CIA",CIA("UID"),"C",CTX(0),RPC))
  1.  ; Build RPC context table
  1. BLDCTX(OPT,CTX) ;
  1.  N X
  1.  I '$D(CTX) K ^XTMP("CIA",CIA("UID"),"C",OPT) S ^(OPT)=1,CTX=OPT
  1.  Q:$D(^XTMP("CIA",CIA("UID"),"C",CTX,0,OPT))  S ^(OPT)=""
  1.  Q:$$OPTCHK^CIANBUTL(OPT,"B")
  1.  M ^XTMP("CIA",CIA("UID"),"C",CTX)=^DIC(19,OPT,"RPC","B")
  1.  F X=0:0 S X=$O(^DIC(19,OPT,10,"B",X)) Q:'X  D BLDCTX(X,CTX)
  1.  K:CTX=OPT ^XTMP("CIA",CIA("UID"),"C",CTX,0)
  1.  Q
  1.  ; OS-specific job commands
  1. JOB1() I CIAMODE=2 D MODE2 Q 1
  1.  J EN^CIANBLIS(PORT,IP,1)[UCI]::15
  1.  Q $T
  1. JOB2() I CIAMODE=2 D MODE2 Q 1
  1.  J EN^CIANBLIS(PORT,IP,1)[UCI]:100000:15
  1.  Q $T
  1. JOB3() I $G(CIA("DBG"))!($G(CIA("VER"))<1.5) J EN^CIANBLIS(PORT,IP,1)[$P(UCI,",")]::15 Q $T
  1.  S $P(CIADATA,U)=1
  1.  D REPLY^CIANBLIS(CIADATA)
  1.  K CIADATA
  1.  J EN^CIANBLIS(CIAPORT,CIAIP,2)[$P(UCI,",")]:(:4:CIATDEV:CIATDEV):15
  1.  Q $T
  1.  ; Mode 2 support for MSM and DSM
  1. MODE2 D:UCI'=UCI(0) SETUCI(UCI)
  1.  S UCI(0)=UCI
  1.  I '$G(CIA("DBG")),$G(CIA("VER"))'<1.5 S $P(CIADATA,U)=1,CIAMODE=1
  1.  E  S CIAQUIT=1 D REPLY^CIANBLIS(),TCPCLOSE^CIANBLIS,EN^CIANBLIS(PORT,IP,1)
  1.  Q
  1.  ; Return current UCI
  1. GETUCI() N Y
  1.  D UCI^%ZOSV
  1.  Q Y
  1.  ; Change UCI
  1. SETUCI(X) D SWAP^%XUCI
  1.  Q
  1.  ; Get authentication method for target UCI
  1. AUTHMETH(UCI) ;
  1.  N X,PC
  1.  F PC=2,1 D  Q:$L(X)
  1.  .S X=$$GET^XPAR("ALL","CIANB AUTHENTICATION",$P(UCI,",",1,PC))
  1.  Q X