XWBM2MC ;OIFO-Oakland/REM - M2M Broker Client APIs ;09/15/15 06:18
;;1.1;RPC BROKER;**28,34,64**;Mar 28, 1997;Build 12
;Per VA Directive 6402, this routine should not be modified.
;
QUIT
;
;p34 -make sure RES is defined - CALLRPC.
; -error exception if RPCNAM not defined - CALLRPC.
; -kill XWBY before going to PARSE^XWBRPC - CALLRPC.
; -return 0 when error occurs and XWBY=error msg - CALLRPC.
; -new module to GET the division for a user - GETDIV.
; -new module to SET the division for a user - SETDIV.
; -kills entry for current context in ^TMP("XWBM2M",$J) - CLEAN.
; -comment out line. Will do PRE in REQUEST^XWBRPCC - PARAM.
; -send PORT;IP to ERROR so it's included in error msg - ERROR.
; -add 2 more error msg for GETDIV and SETDIV - ERRMGS.
;
CONNECT(PORT,IP,AV) ;Establishes the connection to the server.
;CONNECT returns 1=successful, 0=failed
;PORT - PORT number where listener is running.
;IP - IP address where the listener is running.
;AV - Access and verify codes to sign on into VistA.
;DIV - User division.
;
;K XWBPARMS
N XWBSTAT,XWBPARMS
S XWBPARMS("ADDRESS")=IP,XWBPARMS("PORT")=PORT
S XWBPARMS("RETRIES")=3 ;Retries 3 times to open
;
;p34-send PORT;IP to ERROR so it's included in error msg.
I '$$OPEN^XWBRL(.XWBPARMS) D ERROR(1,PORT_";"_IP) Q 0
D SAVDEV^%ZISUTL("XWBM2M PORT")
;
;XUS SIGNON SETUP RPC
I '$$SIGNON() D ERROR(2) S X=$$CLOSE() Q 0
; Results from XUS Signon
; 1=server name, 2=volume, 3=uci, 4=device, 5=# attempts
; 6=skip signon-screen
;M ^TMP("XWBM2M",$J,"XUS SIGNON")=^TMP("XWBM2MRPC",$J,"RESULTS") ;Remove after testing **REM
;
;Validate AV codes
;S AV=$$CHARCHK^XWBUTL(AV) ;Convert and special char
I '$$VALIDAV(AV) D ERROR(3) S X=$$CLOSE() Q 0
;
I $G(^TMP("XWBM2MRPC",$J,"RESULTS",1))'>0 D ERROR(4) S X=$$CLOSE() Q 0
;M ^TMP("XWBM2M",$J,"XUS AV CODE")=^TMP("XWBM2MRPC",$J,"RESULTS") ;Remove after testing **REM
;
D USE^%ZISUTL("XWBM2M CLIENT") U IO
S ^TMP("XWBM2M",$J,"CONNECTED")=1
Q 1
;
ISCONT() ;Function to check connection status. 1=connect, 0=not connect
Q $G(^TMP("XWBM2M",$J,"CONNECTED"),0)
;
SETCONTX(CONTXNA) ;Set context and returns 1=successful or 0=failed
N REQ,XWBPARMS,X
S ^TMP("XWBM2M",$J,"CONTEXT")=""
K ^TMP("XWBM2M",$J,"ERROR","SETCONTX")
;;D PRE,SETPARAM(1,"STRING",$$CHARCHK^XWBUTL($$ENCRYP^XUSRB1(CONTXNA)))
D PRE,SETPARAM(1,"STRING",$$ENCRYP^XUSRB1(CONTXNA))
S X=$$CALLRPC("XWB CREATE CONTEXT","REQ",1)
S REQ=$G(REQ(1))
I REQ'=1 S ^TMP("XWBM2ME",$J,"ERROR","SETCONTX")=REQ Q 0
S ^TMP("XWBM2M",$J,"CONTEXT")=CONTXNA
Q 1
;
GETCONTX(CONTEXT) ;Returns current context
S CONTEXT=$G(^TMP("XWBM2M",$J,"CONTEXT"))
I CONTEXT="" Q 0
Q 1
;
SETPARAM(INDEX,TYPE,VALUE) ;Set a Params entry
S XWBPARMS("PARAMS",INDEX,"TYPE")=TYPE
S XWBPARMS("PARAMS",INDEX,"VALUE")=VALUE
Q
;
PARAM(PARAMNUM,ROOT) ;Build the PARAM data structure
;p34-comment out line. Will do PRE in REQUEST^XWBRPCC
;
I PARAMNUM=""!(ROOT="") Q 0
;D PRE ;*p34
M XWBPARMS("PARAMS",PARAMNUM)=@ROOT
Q 1
;
CALLRPC(RPCNAM,RES,CLRPARMS) ;Call to RPC and wraps RPC in XML
;RPCNAM -RPC name to run
;RES -location where to place results. If no RES, then results will be
; placed in ^TMP("XWBM2M",$J,"RESULTS")
;CLRPARMS - 1=clear PARAMS, 0=do not clear PARAMS. Default is 1.
;
N ER,ERX,GL
I '$D(RES) S RES="" ;*p34-make sure RES is defined.
I '$D(RPCNAM) D Q 0 ;*p34-error if RPCNAM not defined.
.I $G(RES)'="" S @RES="Pass in NULL for RPCNAM."
.I $G(RES)="" S ^TMP("XWBM2MRPC",$J,"RESULTS",1)="Pass in NULL for RPCNAM."
K ^TMP("XWBM2MRPC",$J,"RESULTS") ;Clear before run new RPC
K ^TMP("XWBM2ME",$J,"ERROR","CALLRPC")
I '$$ISCONT() D ERROR(5) Q 0 ;Not connected so do not run RPC
D SAVDEV^%ZISUTL("XWBM2M CLIENT")
D USE^%ZISUTL("XWBM2M PORT") U IO
S XWBPARMS("URI")=RPCNAM
S XWBCRLFL=0
D REQUEST^XWBRPCC(.XWBPARMS)
I XWBCRLFL D Q 0
. I $G(CLRPARMS)'=0 K XWBPARMS("PARAMS")
. K RES
. D USE^%ZISUTL("XWBM2M CLIENT") U IO
;
;Check if needed!! **REM
;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC"))
;
I '$$EXECUTE^XWBVLC(.XWBPARMS) D Q 0 ;Run RPC and place raw XML results
.D ERROR(6)
.D USE^%ZISUTL("XWBM2M CLIENT") U IO
;
S XWBY="" I RES'="" S XWBY=RES K @($G(XWBY)) ;*p34-kill XWBY before PARSE
D PARSE^XWBRPC(.XWBPARMS,XWBY)
;
;*p34-return 0 when error occurs and XWBY=error msg.
I ($G(RES))'="",($G(@XWBY))="",($G(@(XWBY_"("_1_")")))="" D Q ERX
.S ER=$G(^TMP("XWBM2MVLC",$J,"XML",2))
.S ERX=$S(ER["ERROR":0,ER["ERRORS":0,ER["error":0,ER["errors":0,1:1)
.I 'ERX S @XWBY=ER
.D USE^%ZISUTL("XWBM2M CLIENT") U IO
;When RES in not defined.
I ($G(RES))="",($G(^TMP("XWBM2MRPC",$J,"RESULTS")))="",($G(^TMP("XWBM2MRPC",$J,"RESULTS",1)))="" D Q ERX
.S ER=$G(^TMP("XWBM2MVLC",$J,"XML",2))
.S ERX=$S(ER["ERROR":0,ER["ERRORS":0,ER["error":0,ER["errors":0,1:1)
.I 'ERX S ^TMP("XWBM2MRPC",$J,"RESULTS",1)=ER
.D USE^%ZISUTL("XWBM2M CLIENT") U IO
;
I $G(CLRPARMS)'=0 K XWBPARMS("PARAMS") ;Default is to clear
D USE^%ZISUTL("XWBM2M CLIENT") U IO
Q 1
;
CLOSE() ;Close connection
I '$$ISCONT() D ERROR(5) Q 0 ;Not connected
D SAVDEV^%ZISUTL("XWBM2M CLIENT")
D USE^%ZISUTL("XWBM2M PORT") U IO
D CLOSE^XWBRL
D RMDEV^%ZISUTL("XWBM2M PORT")
D CLEAN
S ^TMP("XWBM2M",$J,"CONNECTED")=0
Q 1
;
CLEAN ;Clean up
;*p34-kills entry for current context in ^TMP("XWBM2M",$J)
;
I '$G(XWBDBUG) K XWBPARMS
K ^TMP("XWBM2M",$J),^TMP("XWBM2MRPC",$J),^TMP("XWBM2MVLC",$J)
K ^TMP("XWBM2MRL"),^TMP("XWBM2ML",$J),^TMP("XWBVLL")
K XWBTDEV,XWBTID,XWBVER,XWBCBK,XWBFIRST,XWBTO,XWBQUIT,XWBREAD
K XWBRL,XWBROOT,XWBSTOP,XWBX,XWBY,XWBYX,XWBREQ,XWBCOK
K XWBCLRFL
Q
;
SIGNON() ;
;Encrpt AV before sending with RPC
N XWBPARMS,XWBY
K XWBPARMS
S XWBPARMS("URI")="XUS SIGNON SETUP"
S XWBCRLFL=0
D REQUEST^XWBRPCC(.XWBPARMS)
I XWBCRLFL Q 0
;
;Check if needed!! **REM
;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC",$J,"XML"))
;
I '$$EXECUTE^XWBVLC(.XWBPARMS) Q 0 ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
S XWBY="" D PARSE^XWBRPC(.XWBPARMS,XWBY) ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
Q 1
;
VALIDAV(AV) ;Check AV code
K XWBPARMS
S AV=$$ENCRYP^XUSRB1(AV) ;Encrypt access/verify codes
D PRE
;
; -String parameter type
S XWBPARMS("PARAMS",1,"TYPE")="STRING"
;;S XWBPARMS("PARAMS",1,"VALUE")=$$CHARCHK^XWBUTL(AV)
S XWBPARMS("PARAMS",1,"VALUE")=AV
S XWBPARMS("URI")="XUS AV CODE"
S XWBCRLFL=0
D REQUEST^XWBRPCC(.XWBPARMS)
I XWBCRLFL Q 0
;
;Check if needed!! **REM
;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC",$J,"XML"))
;
I '$$EXECUTE^XWBVLC(.XWBPARMS) Q 0 ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
S XWBY="" D PARSE^XWBRPC(.XWBPARMS,XWBY) ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
K XWBPARMS
Q 1
;
GETDIV(XWBDIVG) ;*p34-gets the division for a user.
;Returns 1-succuss, 0=fail
;XWBDIVG - where the division string will be places.
;Return value for XWBDIVG:
; XWBDIVG(1)=number of divisions
; XWBDIVG(#)='ien;station name;station#' delimitated with ";"
; If a user has only 1 divison, then XWBDIVG(1)=0 because Kernel
; will automatically assign that division as a default. Use IEN to
; set division in $$SETDIV.
N RPC,ROOT
K XWBPARMS
D PRE,SETPARAM(1,"STRING","DUMBY")
I '$$CALLRPC^XWBM2MC("XUS DIVISION GET",XWBDIVG,0) D ERROR(10) Q 0
K XWBPARMS
Q 1
;
SETDIV(XWBDIVS) ;*p34-sets the division for a user.
;Returns 1-success, 0=fail
;XWBDIVS - Division to set. Use IEN from $$GETDIV.
N REQ
K XWBPARMS
S REQ="RESULT"
D PRE,SETPARAM(1,"STRING",XWBDIVS)
I '$$CALLRPC^XWBM2MC("XUS DIVISION SET",REQ,0) D ERROR(11) Q 0
K XWBPARMS
Q 1
;
PRE ;Prepare the needed PARMS **REM might not need PRE
;S XWBCON="DSM" ;Check if needed!! **REM
;
S XWBPARMS("MODE")="RPCBroker"
Q
;
ERROR(CODE,STR) ;Will write error msg and related API in TMP
;*p34-new STR to append to error msg.
N API,X
S API=$P($T(ERRMSG+CODE),";;",3)
S X=$NA(^TMP("XWBM2ME",$J,"ERROR",API)),@X=$P($T(ERRMSG+CODE),";;",2)_$G(STR) ;*p34
Q
;
ERRMSG ; Error messages *p34-add 2 more error msg for GETDIV and SETDIV.
;;Could not open connection;;CONNECT
;;XUS SIGNON SETUP RPC failed;;SIGNON
;;XUS AV CODE RPC failed;;SIGNON
;;Invalid user, no DUZ returned;;SIGNON
;;There is no connection;;CALLRPC
;;RPC could not be processed;;CALLRPC
;;Remote Procedure Unknown;;SERVER
;;Control Character Found;;CALLRPC
;;Error in division return;;CONNECT
;;Could not obtain list of valid divisions for current user;;GETDIV
;;Could not Set active Division for current user;;SETDIV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBM2MC 8828 printed Mar 13, 2025@21:42:08 Page 2
XWBM2MC ;OIFO-Oakland/REM - M2M Broker Client APIs ;09/15/15 06:18
+1 ;;1.1;RPC BROKER;**28,34,64**;Mar 28, 1997;Build 12
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ;p34 -make sure RES is defined - CALLRPC.
+7 ; -error exception if RPCNAM not defined - CALLRPC.
+8 ; -kill XWBY before going to PARSE^XWBRPC - CALLRPC.
+9 ; -return 0 when error occurs and XWBY=error msg - CALLRPC.
+10 ; -new module to GET the division for a user - GETDIV.
+11 ; -new module to SET the division for a user - SETDIV.
+12 ; -kills entry for current context in ^TMP("XWBM2M",$J) - CLEAN.
+13 ; -comment out line. Will do PRE in REQUEST^XWBRPCC - PARAM.
+14 ; -send PORT;IP to ERROR so it's included in error msg - ERROR.
+15 ; -add 2 more error msg for GETDIV and SETDIV - ERRMGS.
+16 ;
CONNECT(PORT,IP,AV) ;Establishes the connection to the server.
+1 ;CONNECT returns 1=successful, 0=failed
+2 ;PORT - PORT number where listener is running.
+3 ;IP - IP address where the listener is running.
+4 ;AV - Access and verify codes to sign on into VistA.
+5 ;DIV - User division.
+6 ;
+7 ;K XWBPARMS
+8 NEW XWBSTAT,XWBPARMS
+9 SET XWBPARMS("ADDRESS")=IP
SET XWBPARMS("PORT")=PORT
+10 ;Retries 3 times to open
SET XWBPARMS("RETRIES")=3
+11 ;
+12 ;p34-send PORT;IP to ERROR so it's included in error msg.
+13 IF '$$OPEN^XWBRL(.XWBPARMS)
DO ERROR(1,PORT_";"_IP)
QUIT 0
+14 DO SAVDEV^%ZISUTL("XWBM2M PORT")
+15 ;
+16 ;XUS SIGNON SETUP RPC
+17 IF '$$SIGNON()
DO ERROR(2)
SET X=$$CLOSE()
QUIT 0
+18 ; Results from XUS Signon
+19 ; 1=server name, 2=volume, 3=uci, 4=device, 5=# attempts
+20 ; 6=skip signon-screen
+21 ;M ^TMP("XWBM2M",$J,"XUS SIGNON")=^TMP("XWBM2MRPC",$J,"RESULTS") ;Remove after testing **REM
+22 ;
+23 ;Validate AV codes
+24 ;S AV=$$CHARCHK^XWBUTL(AV) ;Convert and special char
+25 IF '$$VALIDAV(AV)
DO ERROR(3)
SET X=$$CLOSE()
QUIT 0
+26 ;
+27 IF $GET(^TMP("XWBM2MRPC",$JOB,"RESULTS",1))'>0
DO ERROR(4)
SET X=$$CLOSE()
QUIT 0
+28 ;M ^TMP("XWBM2M",$J,"XUS AV CODE")=^TMP("XWBM2MRPC",$J,"RESULTS") ;Remove after testing **REM
+29 ;
+30 DO USE^%ZISUTL("XWBM2M CLIENT")
USE IO
+31 SET ^TMP("XWBM2M",$JOB,"CONNECTED")=1
+32 QUIT 1
+33 ;
ISCONT() ;Function to check connection status. 1=connect, 0=not connect
+1 QUIT $GET(^TMP("XWBM2M",$JOB,"CONNECTED"),0)
+2 ;
SETCONTX(CONTXNA) ;Set context and returns 1=successful or 0=failed
+1 NEW REQ,XWBPARMS,X
+2 SET ^TMP("XWBM2M",$JOB,"CONTEXT")=""
+3 KILL ^TMP("XWBM2M",$JOB,"ERROR","SETCONTX")
+4 ;;D PRE,SETPARAM(1,"STRING",$$CHARCHK^XWBUTL($$ENCRYP^XUSRB1(CONTXNA)))
+5 DO PRE
DO SETPARAM(1,"STRING",$$ENCRYP^XUSRB1(CONTXNA))
+6 SET X=$$CALLRPC("XWB CREATE CONTEXT","REQ",1)
+7 SET REQ=$GET(REQ(1))
+8 IF REQ'=1
SET ^TMP("XWBM2ME",$JOB,"ERROR","SETCONTX")=REQ
QUIT 0
+9 SET ^TMP("XWBM2M",$JOB,"CONTEXT")=CONTXNA
+10 QUIT 1
+11 ;
GETCONTX(CONTEXT) ;Returns current context
+1 SET CONTEXT=$GET(^TMP("XWBM2M",$JOB,"CONTEXT"))
+2 IF CONTEXT=""
QUIT 0
+3 QUIT 1
+4 ;
SETPARAM(INDEX,TYPE,VALUE) ;Set a Params entry
+1 SET XWBPARMS("PARAMS",INDEX,"TYPE")=TYPE
+2 SET XWBPARMS("PARAMS",INDEX,"VALUE")=VALUE
+3 QUIT
+4 ;
PARAM(PARAMNUM,ROOT) ;Build the PARAM data structure
+1 ;p34-comment out line. Will do PRE in REQUEST^XWBRPCC
+2 ;
+3 IF PARAMNUM=""!(ROOT="")
QUIT 0
+4 ;D PRE ;*p34
+5 MERGE XWBPARMS("PARAMS",PARAMNUM)=@ROOT
+6 QUIT 1
+7 ;
CALLRPC(RPCNAM,RES,CLRPARMS) ;Call to RPC and wraps RPC in XML
+1 ;RPCNAM -RPC name to run
+2 ;RES -location where to place results. If no RES, then results will be
+3 ; placed in ^TMP("XWBM2M",$J,"RESULTS")
+4 ;CLRPARMS - 1=clear PARAMS, 0=do not clear PARAMS. Default is 1.
+5 ;
+6 NEW ER,ERX,GL
+7 ;*p34-make sure RES is defined.
IF '$DATA(RES)
SET RES=""
+8 ;*p34-error if RPCNAM not defined.
IF '$DATA(RPCNAM)
Begin DoDot:1
+9 IF $GET(RES)'=""
SET @RES="Pass in NULL for RPCNAM."
+10 IF $GET(RES)=""
SET ^TMP("XWBM2MRPC",$JOB,"RESULTS",1)="Pass in NULL for RPCNAM."
End DoDot:1
QUIT 0
+11 ;Clear before run new RPC
KILL ^TMP("XWBM2MRPC",$JOB,"RESULTS")
+12 KILL ^TMP("XWBM2ME",$JOB,"ERROR","CALLRPC")
+13 ;Not connected so do not run RPC
IF '$$ISCONT()
DO ERROR(5)
QUIT 0
+14 DO SAVDEV^%ZISUTL("XWBM2M CLIENT")
+15 DO USE^%ZISUTL("XWBM2M PORT")
USE IO
+16 SET XWBPARMS("URI")=RPCNAM
+17 SET XWBCRLFL=0
+18 DO REQUEST^XWBRPCC(.XWBPARMS)
+19 IF XWBCRLFL
Begin DoDot:1
+20 IF $GET(CLRPARMS)'=0
KILL XWBPARMS("PARAMS")
+21 KILL RES
+22 DO USE^%ZISUTL("XWBM2M CLIENT")
USE IO
End DoDot:1
QUIT 0
+23 ;
+24 ;Check if needed!! **REM
+25 ;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC"))
+26 ;
+27 ;Run RPC and place raw XML results
IF '$$EXECUTE^XWBVLC(.XWBPARMS)
Begin DoDot:1
+28 DO ERROR(6)
+29 DO USE^%ZISUTL("XWBM2M CLIENT")
USE IO
End DoDot:1
QUIT 0
+30 ;
+31 ;*p34-kill XWBY before PARSE
SET XWBY=""
IF RES'=""
SET XWBY=RES
KILL @($GET(XWBY))
+32 DO PARSE^XWBRPC(.XWBPARMS,XWBY)
+33 ;
+34 ;*p34-return 0 when error occurs and XWBY=error msg.
+35 IF ($GET(RES))'=""
IF ($GET(@XWBY))=""
IF ($GET(@(XWBY_"("_1_")")))=""
Begin DoDot:1
+36 SET ER=$GET(^TMP("XWBM2MVLC",$JOB,"XML",2))
+37 SET ERX=$SELECT(ER["ERROR":0,ER["ERRORS":0,ER["error":0,ER["errors":0,1:1)
+38 IF 'ERX
SET @XWBY=ER
+39 DO USE^%ZISUTL("XWBM2M CLIENT")
USE IO
End DoDot:1
QUIT ERX
+40 ;When RES in not defined.
+41 IF ($GET(RES))=""
IF ($GET(^TMP("XWBM2MRPC",$JOB,"RESULTS")))=""
IF ($GET(^TMP("XWBM2MRPC",$JOB,"RESULTS",1)))=""
Begin DoDot:1
+42 SET ER=$GET(^TMP("XWBM2MVLC",$JOB,"XML",2))
+43 SET ERX=$SELECT(ER["ERROR":0,ER["ERRORS":0,ER["error":0,ER["errors":0,1:1)
+44 IF 'ERX
SET ^TMP("XWBM2MRPC",$JOB,"RESULTS",1)=ER
+45 DO USE^%ZISUTL("XWBM2M CLIENT")
USE IO
End DoDot:1
QUIT ERX
+46 ;
+47 ;Default is to clear
IF $GET(CLRPARMS)'=0
KILL XWBPARMS("PARAMS")
+48 DO USE^%ZISUTL("XWBM2M CLIENT")
USE IO
+49 QUIT 1
+50 ;
CLOSE() ;Close connection
+1 ;Not connected
IF '$$ISCONT()
DO ERROR(5)
QUIT 0
+2 DO SAVDEV^%ZISUTL("XWBM2M CLIENT")
+3 DO USE^%ZISUTL("XWBM2M PORT")
USE IO
+4 DO CLOSE^XWBRL
+5 DO RMDEV^%ZISUTL("XWBM2M PORT")
+6 DO CLEAN
+7 SET ^TMP("XWBM2M",$JOB,"CONNECTED")=0
+8 QUIT 1
+9 ;
CLEAN ;Clean up
+1 ;*p34-kills entry for current context in ^TMP("XWBM2M",$J)
+2 ;
+3 IF '$GET(XWBDBUG)
KILL XWBPARMS
+4 KILL ^TMP("XWBM2M",$JOB),^TMP("XWBM2MRPC",$JOB),^TMP("XWBM2MVLC",$JOB)
+5 KILL ^TMP("XWBM2MRL"),^TMP("XWBM2ML",$JOB),^TMP("XWBVLL")
+6 KILL XWBTDEV,XWBTID,XWBVER,XWBCBK,XWBFIRST,XWBTO,XWBQUIT,XWBREAD
+7 KILL XWBRL,XWBROOT,XWBSTOP,XWBX,XWBY,XWBYX,XWBREQ,XWBCOK
+8 KILL XWBCLRFL
+9 QUIT
+10 ;
SIGNON() ;
+1 ;Encrpt AV before sending with RPC
+2 NEW XWBPARMS,XWBY
+3 KILL XWBPARMS
+4 SET XWBPARMS("URI")="XUS SIGNON SETUP"
+5 SET XWBCRLFL=0
+6 DO REQUEST^XWBRPCC(.XWBPARMS)
+7 IF XWBCRLFL
QUIT 0
+8 ;
+9 ;Check if needed!! **REM
+10 ;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC",$J,"XML"))
+11 ;
+12 ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
IF '$$EXECUTE^XWBVLC(.XWBPARMS)
QUIT 0
+13 ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
SET XWBY=""
DO PARSE^XWBRPC(.XWBPARMS,XWBY)
+14 QUIT 1
+15 ;
VALIDAV(AV) ;Check AV code
+1 KILL XWBPARMS
+2 ;Encrypt access/verify codes
SET AV=$$ENCRYP^XUSRB1(AV)
+3 DO PRE
+4 ;
+5 ; -String parameter type
+6 SET XWBPARMS("PARAMS",1,"TYPE")="STRING"
+7 ;;S XWBPARMS("PARAMS",1,"VALUE")=$$CHARCHK^XWBUTL(AV)
+8 SET XWBPARMS("PARAMS",1,"VALUE")=AV
+9 SET XWBPARMS("URI")="XUS AV CODE"
+10 SET XWBCRLFL=0
+11 DO REQUEST^XWBRPCC(.XWBPARMS)
+12 IF XWBCRLFL
QUIT 0
+13 ;
+14 ;Check if needed!! **REM
+15 ;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC",$J,"XML"))
+16 ;
+17 ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
IF '$$EXECUTE^XWBVLC(.XWBPARMS)
QUIT 0
+18 ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
SET XWBY=""
DO PARSE^XWBRPC(.XWBPARMS,XWBY)
+19 KILL XWBPARMS
+20 QUIT 1
+21 ;
GETDIV(XWBDIVG) ;*p34-gets the division for a user.
+1 ;Returns 1-succuss, 0=fail
+2 ;XWBDIVG - where the division string will be places.
+3 ;Return value for XWBDIVG:
+4 ; XWBDIVG(1)=number of divisions
+5 ; XWBDIVG(#)='ien;station name;station#' delimitated with ";"
+6 ; If a user has only 1 divison, then XWBDIVG(1)=0 because Kernel
+7 ; will automatically assign that division as a default. Use IEN to
+8 ; set division in $$SETDIV.
+9 NEW RPC,ROOT
+10 KILL XWBPARMS
+11 DO PRE
DO SETPARAM(1,"STRING","DUMBY")
+12 IF '$$CALLRPC^XWBM2MC("XUS DIVISION GET",XWBDIVG,0)
DO ERROR(10)
QUIT 0
+13 KILL XWBPARMS
+14 QUIT 1
+15 ;
SETDIV(XWBDIVS) ;*p34-sets the division for a user.
+1 ;Returns 1-success, 0=fail
+2 ;XWBDIVS - Division to set. Use IEN from $$GETDIV.
+3 NEW REQ
+4 KILL XWBPARMS
+5 SET REQ="RESULT"
+6 DO PRE
DO SETPARAM(1,"STRING",XWBDIVS)
+7 IF '$$CALLRPC^XWBM2MC("XUS DIVISION SET",REQ,0)
DO ERROR(11)
QUIT 0
+8 KILL XWBPARMS
+9 QUIT 1
+10 ;
PRE ;Prepare the needed PARMS **REM might not need PRE
+1 ;S XWBCON="DSM" ;Check if needed!! **REM
+2 ;
+3 SET XWBPARMS("MODE")="RPCBroker"
+4 QUIT
+5 ;
ERROR(CODE,STR) ;Will write error msg and related API in TMP
+1 ;*p34-new STR to append to error msg.
+2 NEW API,X
+3 SET API=$PIECE($TEXT(ERRMSG+CODE),";;",3)
+4 ;*p34
SET X=$NAME(^TMP("XWBM2ME",$JOB,"ERROR",API))
SET @X=$PIECE($TEXT(ERRMSG+CODE),";;",2)_$GET(STR)
+5 QUIT
+6 ;
ERRMSG ; Error messages *p34-add 2 more error msg for GETDIV and SETDIV.
+1 ;;Could not open connection;;CONNECT
+2 ;;XUS SIGNON SETUP RPC failed;;SIGNON
+3 ;;XUS AV CODE RPC failed;;SIGNON
+4 ;;Invalid user, no DUZ returned;;SIGNON
+5 ;;There is no connection;;CALLRPC
+6 ;;RPC could not be processed;;CALLRPC
+7 ;;Remote Procedure Unknown;;SERVER
+8 ;;Control Character Found;;CALLRPC
+9 ;;Error in division return;;CONNECT
+10 ;;Could not obtain list of valid divisions for current user;;GETDIV
+11 ;;Could not Set active Division for current user;;SETDIV
+12 QUIT
