XWBDRPC ;ISF/RWF - Deferred RPCs, used by XWB2HL7 ;01/14/2003 09:27
;;1.1;RPC BROKER;**12,20,32**;Mar 28, 1997
Q
;This is the entry point used by the Broker
EN1(RET,RPC,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ;Call a deferred RPC with 1-7 parameters.
N X,I,INX,N,XWBPAR,XWBPCNT,XWBDVER,XWBHDL
N XWBMSG,ZTSAVE,ZTDTH,ZTIO,ZTRTN,ZTSK,ZTDESC
S RET="",(XWBPAR,RPCIEN)="",XWBPCNT=0,XWBDVER=1
;Find RPC.
S RPCIEN=$$RPCIEN^XWBLIB($P(RPC,"^")) I RPCIEN'>0 S RET(0)="",RET(1)="-1^RPC not found" Q
;Check if RPC is active
I '$$RPCAVAIL^XWBLIB(RPCIEN,"L") S RET(0)="-1^RPC Access Blocked" Q
;Build a handle to link request with return.
S XWBHDL=$$HANDLE()
F I=1:1:10 Q:'$D(@("P"_I)) S XWBPCNT=I
;Build ZTSAVE
F N="RPC","XWBHDL","XWBPCNT","P1","P2","P3","P4","P5","P6","P7","P8","P9","P10" Q:'$D(@N) S ZTSAVE(N)="" S:$D(@N)>9 ZTSAVE(N_"(")=""
S ZTDESC="Deferred RPC - "_RPC
S ZTRTN="DQ^XWBDRPC",ZTIO="NULL",ZTDTH=(+$H_",10") ;run first
;Call Taskman
D ^%ZTLOAD
S RET(0)=XWBHDL
I ZTSK>0 D SETNODE(XWBHDL,"TASKID",ZTSK)
Q
;
;This is called by TaskMan to process a RPC.
DQ ;
N $ES,$ET S $ET="D ERR^XWBDRPC"
N %,%1,%2,IX,X,Y,ERR,PAR
S IX=0,XWBAPVER=+$P(RPC,"^",2),RPC=$P(RPC,"^")
S XWBRPC=0,XWBRPC=$$RPCGET(RPC,.XWBRPC) I XWBRPC'>0 S XWBY(0)="-1^RPC name not found" G REX
S PAR=$$PARAM D SETNODE(XWBHDL,"WRAP",XWBRPC("WRAP"))
S X=$$HDLSTA(XWBHDL,"0^Running") ;Tell user we started
;Result returned in XWBY
D CAPI(XWBRPC("RTAG"),XWBRPC("RNAM"),PAR)
REX ;Exit from RPC
;Check to see if our handle is still good.
I $$HDLSTA(XWBHDL,"0^LoadRestlts")<0 S XWBY(0)="-1^Abort" Q
;Move data into XTMP for application to pick up.
I $D(XWBY)>9 D
. S %1="XWBY"
. F S %1=$Q(@%1) Q:%1="" D PLACE(XWBHDL,@%1)
I $D(XWBY)=1,$E(XWBY)'="^" D PLACE(XWBHDL,XWBY)
;If XWBY is a $NA value just return it.
I $D(XWBY)=1,$E(XWBY)="^" D
. S %1=XWBY,%2=$E(XWBY,1,$L(XWBY)-1)
. F S %1=$Q(@%1) Q:%1'[%2 D PLACE(XWBHDL,@%1)
S X=$$HDLSTA(XWBHDL,"1^Done")
Q
;
CAPI(TAG,NAM,PAR) ;make API call
N R
S R=TAG_"^"_NAM_"(.XWBY"_$S(PAR="":")",1:","_PAR_")")
;Ready to call RPC?
D @R
;Return data in XWBY
Q
;
ERR ;Handle an error
D ^%ZTER ;Record error
I $D(XWBHDL) S X=$$HDLSTA(XWBHDL,"-1^Error: "_$E($$EC^%ZOSV,1,200))
D UNWIND^%ZTER
;
RTNDATA(RET,HDL) ;Return the data under a handle
N I,N,RD,WRAP S RET="" K ^TMP($J,"XWB")
I $G(HDL)="" S RET(0)="-1^Bad Handle" Q
S N=$$CHKHDL^XWBDRPC(HDL) I N<1 S RET(0)=N Q
I N'["Done" S RET(0)="-1^Not DONE" Q
;Default is to return an array, switch to global if to big
S N=(^XTMP(HDL,"CNT")>100)
S I=0,RD=$S(N:$NA(^TMP($J,"XWB")),1:"RET")
;Move into a TMP global, Global is killed in XWBTCPC
I N S RET=$NA(^TMP($J,"XWB")),I=$$RTRNFMT^XWBLIB(4) ;Make return a global
I N M ^TMP($J,"XWB")=^XTMP(HDL,"D")
I 'N F S RET(I)=$G(^XTMP(HDL,"D",I)),I=$O(^XTMP(HDL,"D",I)) Q:I'>0
Q
;
CLEAR(RET,HDL) ;Clear the data under a handle
K ^XTMP(HDL),^TMP("XWBHDL",$J,HDL)
S RET(0)=1
Q
;
CLEARALL(RET) ;Clear ALL the data for this job.
N X
S X="" F S X=$O(^TMP("XWBHDL",$J,X)) Q:X="" D CLEAR(.RET,X)
Q
;
RPCGET(N,R) ;Convert RPC name to IEN and parameters.
N T,T0
S T=$G(N) Q:T="" "-1^No RPC name"
S T=$$RPCIEN^XWBLIB(T) Q:T'>0 "-1^Bad RPC name"
Q:'$D(R) T
S T0=$G(^XWB(8994,T,0)),R("IEN")=T,R("NAME")=$P(T0,"^")
S R("RTAG")=$P(T0,"^",2),R("RNAM")=$P(T0,"^",3)
S R("RTNTYPE")=$P(T0,"^",4),R("WRAP")=$P(T0,"^",8)
Q T
;
PARAM() ;Build remote parameter list
N I,%,X,A S X=""
F I=1:1:XWBPCNT S %="P"_I,A="XWBA"_I Q:'$D(@%) K @A D
. I $D(@%)=1 S X=X_%_"," Q
. S X=X_"."_A_"," M @A=@% Q
Q $E(X,1,$L(X)-1)
;
ADDHDL(HL) ;Add a handle to local set
S ^TMP("XWBHDL",$J,HL)=""
Q
;
HANDLE() ;Return a unique handle into ^XTMP
N %H,A,J,HL
S %H=$H,J="XWBDRPC"_($J#2048)_"-"_(%H#7*86400+$P(%H,",",2))_"_",A=-1
HAN2 S A=A+1,HL=J_A L +^XTMP(HL):0 I '$T G HAN2
I $D(^XTMP(HL)) L -^XTMP(HL) G HAN2
S ^XTMP(HL,0)=$$HTFM^XLFDT(%H+2)_"^"_$G(DT) L -^XTMP(HL)
S ^XTMP(HL,"STATUS")="0^New",^("CNT")=0
Q HL
;
HDLSTA(HL,STATUS) ;update the status node in XTMP
Q:'$D(^XTMP(HL)) -1
L +^XTMP(HL):5
S ^XTMP(HL,"STATUS")=STATUS
L -^XTMP(HL)
Q 1
;
PLACE(HL,DATA) ;Called to place each line of data.
N IX
Q:'$D(^XTMP(HL,"CNT"))
S IX=+$G(^XTMP(HL,"CNT")),^XTMP(HL,"D",IX)=DATA,^XTMP(HL,"CNT")=IX+1
Q
;
RPCCHK(RET,HDL) ;RPC handle status check.
S RET(0)=$$CHKHDL(HDL)
Q
;
CHKHDL(HL) ;Return the status of a handle
Q:'$D(^XTMP(HL)) "-1^Bad Handle"
L +^XTMP(HL):1 I '$T Q "0^Busy"
N % S %=$G(^XTMP(HL,"STATUS"),"0^Null")
L -^XTMP(HL)
Q %
;
GETNODE(HL,ND) ;Get a status node
Q $G(^XTMP(HL,ND))
;
SETNODE(HL,ND,DATA) ;Set a status node
S ^XTMP(HL,ND)=DATA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBDRPC 4759 printed Dec 13, 2024@02:37:11 Page 2
XWBDRPC ;ISF/RWF - Deferred RPCs, used by XWB2HL7 ;01/14/2003 09:27
+1 ;;1.1;RPC BROKER;**12,20,32**;Mar 28, 1997
+2 QUIT
+3 ;This is the entry point used by the Broker
EN1(RET,RPC,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ;Call a deferred RPC with 1-7 parameters.
+1 NEW X,I,INX,N,XWBPAR,XWBPCNT,XWBDVER,XWBHDL
+2 NEW XWBMSG,ZTSAVE,ZTDTH,ZTIO,ZTRTN,ZTSK,ZTDESC
+3 SET RET=""
SET (XWBPAR,RPCIEN)=""
SET XWBPCNT=0
SET XWBDVER=1
+4 ;Find RPC.
+5 SET RPCIEN=$$RPCIEN^XWBLIB($PIECE(RPC,"^"))
IF RPCIEN'>0
SET RET(0)=""
SET RET(1)="-1^RPC not found"
QUIT
+6 ;Check if RPC is active
+7 IF '$$RPCAVAIL^XWBLIB(RPCIEN,"L")
SET RET(0)="-1^RPC Access Blocked"
QUIT
+8 ;Build a handle to link request with return.
+9 SET XWBHDL=$$HANDLE()
+10 FOR I=1:1:10
if '$DATA(@("P"_I))
QUIT
SET XWBPCNT=I
+11 ;Build ZTSAVE
+12 FOR N="RPC","XWBHDL","XWBPCNT","P1","P2","P3","P4","P5","P6","P7","P8","P9","P10"
if '$DATA(@N)
QUIT
SET ZTSAVE(N)=""
if $DATA(@N)>9
SET ZTSAVE(N_"(")=""
+13 SET ZTDESC="Deferred RPC - "_RPC
+14 ;run first
SET ZTRTN="DQ^XWBDRPC"
SET ZTIO="NULL"
SET ZTDTH=(+$HOROLOG_",10")
+15 ;Call Taskman
+16 DO ^%ZTLOAD
+17 SET RET(0)=XWBHDL
+18 IF ZTSK>0
DO SETNODE(XWBHDL,"TASKID",ZTSK)
+19 QUIT
+20 ;
+21 ;This is called by TaskMan to process a RPC.
DQ ;
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^XWBDRPC"
+2 NEW %,%1,%2,IX,X,Y,ERR,PAR
+3 SET IX=0
SET XWBAPVER=+$PIECE(RPC,"^",2)
SET RPC=$PIECE(RPC,"^")
+4 SET XWBRPC=0
SET XWBRPC=$$RPCGET(RPC,.XWBRPC)
IF XWBRPC'>0
SET XWBY(0)="-1^RPC name not found"
GOTO REX
+5 SET PAR=$$PARAM
DO SETNODE(XWBHDL,"WRAP",XWBRPC("WRAP"))
+6 ;Tell user we started
SET X=$$HDLSTA(XWBHDL,"0^Running")
+7 ;Result returned in XWBY
+8 DO CAPI(XWBRPC("RTAG"),XWBRPC("RNAM"),PAR)
REX ;Exit from RPC
+1 ;Check to see if our handle is still good.
+2 IF $$HDLSTA(XWBHDL,"0^LoadRestlts")<0
SET XWBY(0)="-1^Abort"
QUIT
+3 ;Move data into XTMP for application to pick up.
+4 IF $DATA(XWBY)>9
Begin DoDot:1
+5 SET %1="XWBY"
+6 FOR
SET %1=$QUERY(@%1)
if %1=""
QUIT
DO PLACE(XWBHDL,@%1)
End DoDot:1
+7 IF $DATA(XWBY)=1
IF $EXTRACT(XWBY)'="^"
DO PLACE(XWBHDL,XWBY)
+8 ;If XWBY is a $NA value just return it.
+9 IF $DATA(XWBY)=1
IF $EXTRACT(XWBY)="^"
Begin DoDot:1
+10 SET %1=XWBY
SET %2=$EXTRACT(XWBY,1,$LENGTH(XWBY)-1)
+11 FOR
SET %1=$QUERY(@%1)
if %1'[%2
QUIT
DO PLACE(XWBHDL,@%1)
End DoDot:1
+12 SET X=$$HDLSTA(XWBHDL,"1^Done")
+13 QUIT
+14 ;
CAPI(TAG,NAM,PAR) ;make API call
+1 NEW R
+2 SET R=TAG_"^"_NAM_"(.XWBY"_$SELECT(PAR="":")",1:","_PAR_")")
+3 ;Ready to call RPC?
+4 DO @R
+5 ;Return data in XWBY
+6 QUIT
+7 ;
ERR ;Handle an error
+1 ;Record error
DO ^%ZTER
+2 IF $DATA(XWBHDL)
SET X=$$HDLSTA(XWBHDL,"-1^Error: "_$EXTRACT($$EC^%ZOSV,1,200))
+3 DO UNWIND^%ZTER
+4 ;
RTNDATA(RET,HDL) ;Return the data under a handle
+1 NEW I,N,RD,WRAP
SET RET=""
KILL ^TMP($JOB,"XWB")
+2 IF $GET(HDL)=""
SET RET(0)="-1^Bad Handle"
QUIT
+3 SET N=$$CHKHDL^XWBDRPC(HDL)
IF N<1
SET RET(0)=N
QUIT
+4 IF N'["Done"
SET RET(0)="-1^Not DONE"
QUIT
+5 ;Default is to return an array, switch to global if to big
+6 SET N=(^XTMP(HDL,"CNT")>100)
+7 SET I=0
SET RD=$SELECT(N:$NAME(^TMP($JOB,"XWB")),1:"RET")
+8 ;Move into a TMP global, Global is killed in XWBTCPC
+9 ;Make return a global
IF N
SET RET=$NAME(^TMP($JOB,"XWB"))
SET I=$$RTRNFMT^XWBLIB(4)
+10 IF N
MERGE ^TMP($JOB,"XWB")=^XTMP(HDL,"D")
+11 IF 'N
FOR
SET RET(I)=$GET(^XTMP(HDL,"D",I))
SET I=$ORDER(^XTMP(HDL,"D",I))
if I'>0
QUIT
+12 QUIT
+13 ;
CLEAR(RET,HDL) ;Clear the data under a handle
+1 KILL ^XTMP(HDL),^TMP("XWBHDL",$JOB,HDL)
+2 SET RET(0)=1
+3 QUIT
+4 ;
CLEARALL(RET) ;Clear ALL the data for this job.
+1 NEW X
+2 SET X=""
FOR
SET X=$ORDER(^TMP("XWBHDL",$JOB,X))
if X=""
QUIT
DO CLEAR(.RET,X)
+3 QUIT
+4 ;
RPCGET(N,R) ;Convert RPC name to IEN and parameters.
+1 NEW T,T0
+2 SET T=$GET(N)
if T=""
QUIT "-1^No RPC name"
+3 SET T=$$RPCIEN^XWBLIB(T)
if T'>0
QUIT "-1^Bad RPC name"
+4 if '$DATA(R)
QUIT T
+5 SET T0=$GET(^XWB(8994,T,0))
SET R("IEN")=T
SET R("NAME")=$PIECE(T0,"^")
+6 SET R("RTAG")=$PIECE(T0,"^",2)
SET R("RNAM")=$PIECE(T0,"^",3)
+7 SET R("RTNTYPE")=$PIECE(T0,"^",4)
SET R("WRAP")=$PIECE(T0,"^",8)
+8 QUIT T
+9 ;
PARAM() ;Build remote parameter list
+1 NEW I,%,X,A
SET X=""
+2 FOR I=1:1:XWBPCNT
SET %="P"_I
SET A="XWBA"_I
if '$DATA(@%)
QUIT
KILL @A
Begin DoDot:1
+3 IF $DATA(@%)=1
SET X=X_%_","
QUIT
+4 SET X=X_"."_A_","
MERGE @A=@%
QUIT
End DoDot:1
+5 QUIT $EXTRACT(X,1,$LENGTH(X)-1)
+6 ;
ADDHDL(HL) ;Add a handle to local set
+1 SET ^TMP("XWBHDL",$JOB,HL)=""
+2 QUIT
+3 ;
HANDLE() ;Return a unique handle into ^XTMP
+1 NEW %H,A,J,HL
+2 SET %H=$HOROLOG
SET J="XWBDRPC"_($JOB#2048)_"-"_(%H#7*86400+$PIECE(%H,",",2))_"_"
SET A=-1
HAN2 SET A=A+1
SET HL=J_A
LOCK +^XTMP(HL):0
IF '$TEST
GOTO HAN2
+1 IF $DATA(^XTMP(HL))
LOCK -^XTMP(HL)
GOTO HAN2
+2 SET ^XTMP(HL,0)=$$HTFM^XLFDT(%H+2)_"^"_$GET(DT)
LOCK -^XTMP(HL)
+3 SET ^XTMP(HL,"STATUS")="0^New"
SET ^("CNT")=0
+4 QUIT HL
+5 ;
HDLSTA(HL,STATUS) ;update the status node in XTMP
+1 if '$DATA(^XTMP(HL))
QUIT -1
+2 LOCK +^XTMP(HL):5
+3 SET ^XTMP(HL,"STATUS")=STATUS
+4 LOCK -^XTMP(HL)
+5 QUIT 1
+6 ;
PLACE(HL,DATA) ;Called to place each line of data.
+1 NEW IX
+2 if '$DATA(^XTMP(HL,"CNT"))
QUIT
+3 SET IX=+$GET(^XTMP(HL,"CNT"))
SET ^XTMP(HL,"D",IX)=DATA
SET ^XTMP(HL,"CNT")=IX+1
+4 QUIT
+5 ;
RPCCHK(RET,HDL) ;RPC handle status check.
+1 SET RET(0)=$$CHKHDL(HDL)
+2 QUIT
+3 ;
CHKHDL(HL) ;Return the status of a handle
+1 if '$DATA(^XTMP(HL))
QUIT "-1^Bad Handle"
+2 LOCK +^XTMP(HL):1
IF '$TEST
QUIT "0^Busy"
+3 NEW %
SET %=$GET(^XTMP(HL,"STATUS"),"0^Null")
+4 LOCK -^XTMP(HL)
+5 QUIT %
+6 ;
GETNODE(HL,ND) ;Get a status node
+1 QUIT $GET(^XTMP(HL,ND))
+2 ;
SETNODE(HL,ND,DATA) ;Set a status node
+1 SET ^XTMP(HL,ND)=DATA
+2 QUIT
+3 ;
