- 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 Feb 19, 2025@00:03:36 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 ;