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

XWBM2MC.m

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