XWB2HL7A ;;ISF/AC - Remote RPCs via HL7. ;03/26/09 16:22
;;1.1;RPC BROKER;**12,54**;Mar 28, 1997;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
RPCINFO ;RPC Information
;Msg Type: SPQ - stored procedure request (event Q01)
;--------------
;MSH Message Header
;SPR Store Procedure Request
; Query Tag^Query/Response Format Code^Stored Proc Name^Param List
;[ RDF ] Table Row Definition
; # of Columns per Row^Column Description
;[ DSC ] Continuation Pointer
;--------------
;Response Msg Type: TBR - tabular data response
;--------------
;MSH Message Header
;MSA Message Acknowledgment
;[ERR] Error
;QAK Query Acknowledgment
;RDF Table Row Definition
; # of Columns per Row^Column Description
;{ RDT } Table Row Data
; Column Value
;[ DSC ] Continuation Pointer
;-------------
DIRECT(XWB2SPN,XWB2HNDL,XWB2RET,XWB2DEST,XWB2PRAM,XWB2PARY) ;DIR RPC CALL
N XWB2DRCT
S XWB2DRCT=1
G D2
;
;-------------
;This is where the RPC calls to send the RPC to the remote system
;(procedurename, query tag, error return, destination, Parameter array)
CALL(XWB2SPN,XWB2HNDL,XWB2RET,XWB2DEST,XWB2PRAM,XWB2PARY) ;RPC CALL
;
D2 N I,J,HL,HLA,HLL,XWB2LSTI,HLERR,XWB2EMAP,XWB2FLD,XWB2LPRM,XWB2MAP2,XWB2PARM,XWB2QTAG,XWB2SPRL,XWB2SPR,XWB2X,XWB2EID,XWB2MIEN,XWB2OVFL,XWB2RSLT,Y
S XWB2QTAG=$G(XWB2HNDL)
S XWB2SPN=$G(XWB2SPN)
S XWB2FLD="@SPR.4.2"
S (XWB2RET,XWB2PARM)=""
D BLDDIST($G(XWB2DEST))
I '$O(HLL("LINKS",0)) S $P(XWB2RET,"^",2,3)="-1^Station # not found" Q
S XWB2EID=+$$FIND1^DIC(101,,"MX","XWB RPC EVENT")
I 'XWB2EID S $P(XWB2RET,"^",2,3)="-1^RPC Broker Protocol not setup" Q
D INIT^HLFNC2(.XWB2EID,.HL)
I $O(HL(""))']"" S $P(XWB2RET,"^",2,3)="-1^RPC Broker Params not setup" Q
;XWB2EMAP=encoding characters to map by order.
;XWB2MAP2=escaped characters used for mapping encoding characters.
S Y=""
F I=3,0,1,2,4 S Y=Y_$S(I:$E(HL("ECH"),I),1:HL("FS"))
S XWB2EMAP=Y,XWB2MAP2="EFSRT"
F I=0:0 S I=$O(XWB2PRAM(I)) Q:I'>0!$P(XWB2RET,"^",2) D
.I $L(XWB2PRAM(I))>255 S $P(XWB2RET,"^",2,3)="-1^RPC Parameter(s) exceed length of 255." Q
.S XWB2PRAM(I)=$$XLATE(XWB2PRAM(I),.XWB2OVFL)
.S J=0
.I $O(XWB2OVFL(0)) D K XWB2OVFL
..F K=1,2 I $D(XWB2OVFL(K)) D
...S XWB2PRAM(I,(K/10))=XWB2OVFL(1)
...S J=(K/10) K XWB2OVFL(K)
.F S J=$O(XWB2PRAM(I,J)) Q:J'>0!$P(XWB2RET,"^",2) D
..I $L(XWB2PRAM(I))>255 S $P(XWB2RET,"^",2,3)="-1^RPC Parameter(s) exceed length of 255." Q
..S XWB2PRAM(I,J)=$$XLATE(XWB2PRAM(I,J),.XWB2OVFL)
..I $O(XWB2OVFL(0)) D K XWB2OVFL
...F K=1,2 I $D(XWB2OVFL(K)) D
....S XWB2PRAM(I,J+(K/10))=XWB2OVFL(1)
....S J=J+(K/10) K XWB2OVFL(K)
I $P(XWB2RET,"^",2) Q
D RPCSEND
M XWB2RET=XWB2RSLT ;Move the return info into return var.
CALLXIT ;Cleanup before exit.
Q
;
RPCSEND ;
N I,J
S HLA("HLS",1)="SPR"_HL("FS")_XWB2QTAG_HL("FS")_"T"_HL("FS")_XWB2SPN_HL("FS")_XWB2FLD_$E(HL("ECH"))
S XWB2SPRL=$L(HLA("HLS",1)),XWB2SPR=$NA(HLA("HLS",1))
S I=$O(XWB2PRAM(0)) Q:I'>0 D
.S XWB2LSTI=I,XWB2X=XWB2PRAM(I)
.I (XWB2SPRL+$L(XWB2X))>255!$O(XWB2PRAM(I,0)) D NXTNODE
.S @XWB2SPR=@XWB2SPR_XWB2X,XWB2SPRL=$L(@XWB2SPR)
.F J=0:0 S J=$O(XWB2PRAM(I,J)) Q:J'>0 D
..S XWB2X=XWB2PRAM(I,J)
..D NXTNODE
..S @XWB2SPR=@XWB2SPR_XWB2X,XWB2SPRL=$L(@XWB2SPR)
..Q
F S I=$O(XWB2PRAM(I)) Q:I'>0 D
.S XWB2X=XWB2PRAM(I)
.I (XWB2SPRL+$L(XWB2X)+1)>255!$O(XWB2PRAM(I,0)) D NXTNODE
.S @XWB2SPR=@XWB2SPR_$E(HL("ECH"),4)_XWB2X,XWB2SPRL=$L(@XWB2SPR)
.F J=0:0 S J=$O(XWB2PRAM(I,J)) Q:J'>0 D
..S XWB2X=XWB2PRAM(I,J)
..D NXTNODE
..S @XWB2SPR=@XWB2SPR_XWB2X,XWB2SPRL=$L(@XWB2SPR)
..Q
S HLA("HLS",2)="RDF"_HL("FS")_"1"_HL("FS")_"@DSP.3"_$E(HL("ECH"))_"TX"_$E(HL("ECH"))_"300"
I $D(XWB2DRCT) D DIRECT^HLMA(XWB2EID,"LM",1,.XWB2RSLT) Q
D GENERATE^HLMA(XWB2EID,"LM",1,.XWB2RSLT,.XWB2MIEN)
Q
;
NXTNODE ;Get next node
N XWB2QL,XWB2QS
S XWB2QL=$QL($NA(@XWB2SPR))
I XWB2QL=2 S XWB2SPR=$NA(@XWB2SPR@(1)),@XWB2SPR="" Q
I XWB2QL=3 D Q
.S XWB2QS=+$QS($NA(@XWB2SPR),3)+1
.S XWB2SPR=$NA(@$NA(@XWB2SPR,2)@(XWB2QS)),@XWB2SPR=""
Q
;
;
BLDDIST(X) ;Build distribution list -- HLL("LINKS") ARRAY.
N %,XWB2LIST
D LINK^HLUTIL3(X,.XWB2LIST,"I")
S %=+$O(XWB2LIST(0)) Q:'%
S HLL("LINKS",1)="XWB RPC SUBSCRIBER"_U_XWB2LIST(%)
Q
XLATE(S,OF) ;TRANSLATE FS and Encoding characters to Formating codes.
;Change ^ > \F\
N X,I,I1,I2,I3,FC,TC,N,Y,Y1,L,L1,L2
S OF(0)=S
F I1=1:1:5 S FC=$E(XWB2EMAP,I1),TC=$E(XWB2MAP2,I1) D
. S Y=""
. F I2=0,1,2 Q:'$D(OF(I2)) S S=OF(I2) D S OF(I2)=S
. . S L1=1,L2=$F(S,FC) Q:'L2
. . F S Y1=$E(S,L1,L2-2) D S L1=L2,L2=$F(S,FC,L1) Q:'L2
. . . ;If next part wont fit, add it to the overflow node and exit
. . . I $L(Y)+$L(Y1)+3>250 S OF(I2+1)=$E(S,L1,$L(S))_$G(OF(I2+1)),OF(I2)=Y,S="" Q
. . . S Y=Y_Y1_$$ECODE(TC)
. . . Q
. . ;Add the rest of S to the output.
. . S N=$E(S,L1,$L(S)) I $L(Y)+$L(N)>250 S OF(I2+1)=N_$G(OF(I2+1)),N=""
. . S S=Y_N,Y=""
. . Q
. Q
S Y=OF(0) K OF(0)
Q Y
;
ECODE(%) ;
Q $E(HL("ECH"),3)_%_$E(HL("ECH"),3)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWB2HL7A 5088 printed Apr 09, 2024@21:39:27 Page 2
XWB2HL7A ;;ISF/AC - Remote RPCs via HL7. ;03/26/09 16:22
+1 ;;1.1;RPC BROKER;**12,54**;Mar 28, 1997;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
RPCINFO ;RPC Information
+1 ;Msg Type: SPQ - stored procedure request (event Q01)
+2 ;--------------
+3 ;MSH Message Header
+4 ;SPR Store Procedure Request
+5 ; Query Tag^Query/Response Format Code^Stored Proc Name^Param List
+6 ;[ RDF ] Table Row Definition
+7 ; # of Columns per Row^Column Description
+8 ;[ DSC ] Continuation Pointer
+9 ;--------------
+10 ;Response Msg Type: TBR - tabular data response
+11 ;--------------
+12 ;MSH Message Header
+13 ;MSA Message Acknowledgment
+14 ;[ERR] Error
+15 ;QAK Query Acknowledgment
+16 ;RDF Table Row Definition
+17 ; # of Columns per Row^Column Description
+18 ;{ RDT } Table Row Data
+19 ; Column Value
+20 ;[ DSC ] Continuation Pointer
+21 ;-------------
DIRECT(XWB2SPN,XWB2HNDL,XWB2RET,XWB2DEST,XWB2PRAM,XWB2PARY) ;DIR RPC CALL
+1 NEW XWB2DRCT
+2 SET XWB2DRCT=1
+3 GOTO D2
+4 ;
+5 ;-------------
+6 ;This is where the RPC calls to send the RPC to the remote system
+7 ;(procedurename, query tag, error return, destination, Parameter array)
CALL(XWB2SPN,XWB2HNDL,XWB2RET,XWB2DEST,XWB2PRAM,XWB2PARY) ;RPC CALL
+1 ;
D2 NEW I,J,HL,HLA,HLL,XWB2LSTI,HLERR,XWB2EMAP,XWB2FLD,XWB2LPRM,XWB2MAP2,XWB2PARM,XWB2QTAG,XWB2SPRL,XWB2SPR,XWB2X,XWB2EID,XWB2MIEN,XWB2OVFL,XWB2RSLT,Y
+1 SET XWB2QTAG=$GET(XWB2HNDL)
+2 SET XWB2SPN=$GET(XWB2SPN)
+3 SET XWB2FLD="@SPR.4.2"
+4 SET (XWB2RET,XWB2PARM)=""
+5 DO BLDDIST($GET(XWB2DEST))
+6 IF '$ORDER(HLL("LINKS",0))
SET $PIECE(XWB2RET,"^",2,3)="-1^Station # not found"
QUIT
+7 SET XWB2EID=+$$FIND1^DIC(101,,"MX","XWB RPC EVENT")
+8 IF 'XWB2EID
SET $PIECE(XWB2RET,"^",2,3)="-1^RPC Broker Protocol not setup"
QUIT
+9 DO INIT^HLFNC2(.XWB2EID,.HL)
+10 IF $ORDER(HL(""))']""
SET $PIECE(XWB2RET,"^",2,3)="-1^RPC Broker Params not setup"
QUIT
+11 ;XWB2EMAP=encoding characters to map by order.
+12 ;XWB2MAP2=escaped characters used for mapping encoding characters.
+13 SET Y=""
+14 FOR I=3,0,1,2,4
SET Y=Y_$SELECT(I:$EXTRACT(HL("ECH"),I),1:HL("FS"))
+15 SET XWB2EMAP=Y
SET XWB2MAP2="EFSRT"
+16 FOR I=0:0
SET I=$ORDER(XWB2PRAM(I))
if I'>0!$PIECE(XWB2RET,"^",2)
QUIT
Begin DoDot:1
+17 IF $LENGTH(XWB2PRAM(I))>255
SET $PIECE(XWB2RET,"^",2,3)="-1^RPC Parameter(s) exceed length of 255."
QUIT
+18 SET XWB2PRAM(I)=$$XLATE(XWB2PRAM(I),.XWB2OVFL)
+19 SET J=0
+20 IF $ORDER(XWB2OVFL(0))
Begin DoDot:2
+21 FOR K=1,2
IF $DATA(XWB2OVFL(K))
Begin DoDot:3
+22 SET XWB2PRAM(I,(K/10))=XWB2OVFL(1)
+23 SET J=(K/10)
KILL XWB2OVFL(K)
End DoDot:3
End DoDot:2
KILL XWB2OVFL
+24 FOR
SET J=$ORDER(XWB2PRAM(I,J))
if J'>0!$PIECE(XWB2RET,"^",2)
QUIT
Begin DoDot:2
+25 IF $LENGTH(XWB2PRAM(I))>255
SET $PIECE(XWB2RET,"^",2,3)="-1^RPC Parameter(s) exceed length of 255."
QUIT
+26 SET XWB2PRAM(I,J)=$$XLATE(XWB2PRAM(I,J),.XWB2OVFL)
+27 IF $ORDER(XWB2OVFL(0))
Begin DoDot:3
+28 FOR K=1,2
IF $DATA(XWB2OVFL(K))
Begin DoDot:4
+29 SET XWB2PRAM(I,J+(K/10))=XWB2OVFL(1)
+30 SET J=J+(K/10)
KILL XWB2OVFL(K)
End DoDot:4
End DoDot:3
KILL XWB2OVFL
End DoDot:2
End DoDot:1
+31 IF $PIECE(XWB2RET,"^",2)
QUIT
+32 DO RPCSEND
+33 ;Move the return info into return var.
MERGE XWB2RET=XWB2RSLT
CALLXIT ;Cleanup before exit.
+1 QUIT
+2 ;
RPCSEND ;
+1 NEW I,J
+2 SET HLA("HLS",1)="SPR"_HL("FS")_XWB2QTAG_HL("FS")_"T"_HL("FS")_XWB2SPN_HL("FS")_XWB2FLD_$EXTRACT(HL("ECH"))
+3 SET XWB2SPRL=$LENGTH(HLA("HLS",1))
SET XWB2SPR=$NAME(HLA("HLS",1))
+4 SET I=$ORDER(XWB2PRAM(0))
if I'>0
QUIT
Begin DoDot:1
+5 SET XWB2LSTI=I
SET XWB2X=XWB2PRAM(I)
+6 IF (XWB2SPRL+$LENGTH(XWB2X))>255!$ORDER(XWB2PRAM(I,0))
DO NXTNODE
+7 SET @XWB2SPR=@XWB2SPR_XWB2X
SET XWB2SPRL=$LENGTH(@XWB2SPR)
+8 FOR J=0:0
SET J=$ORDER(XWB2PRAM(I,J))
if J'>0
QUIT
Begin DoDot:2
+9 SET XWB2X=XWB2PRAM(I,J)
+10 DO NXTNODE
+11 SET @XWB2SPR=@XWB2SPR_XWB2X
SET XWB2SPRL=$LENGTH(@XWB2SPR)
+12 QUIT
End DoDot:2
End DoDot:1
+13 FOR
SET I=$ORDER(XWB2PRAM(I))
if I'>0
QUIT
Begin DoDot:1
+14 SET XWB2X=XWB2PRAM(I)
+15 IF (XWB2SPRL+$LENGTH(XWB2X)+1)>255!$ORDER(XWB2PRAM(I,0))
DO NXTNODE
+16 SET @XWB2SPR=@XWB2SPR_$EXTRACT(HL("ECH"),4)_XWB2X
SET XWB2SPRL=$LENGTH(@XWB2SPR)
+17 FOR J=0:0
SET J=$ORDER(XWB2PRAM(I,J))
if J'>0
QUIT
Begin DoDot:2
+18 SET XWB2X=XWB2PRAM(I,J)
+19 DO NXTNODE
+20 SET @XWB2SPR=@XWB2SPR_XWB2X
SET XWB2SPRL=$LENGTH(@XWB2SPR)
+21 QUIT
End DoDot:2
End DoDot:1
+22 SET HLA("HLS",2)="RDF"_HL("FS")_"1"_HL("FS")_"@DSP.3"_$EXTRACT(HL("ECH"))_"TX"_$EXTRACT(HL("ECH"))_"300"
+23 IF $DATA(XWB2DRCT)
DO DIRECT^HLMA(XWB2EID,"LM",1,.XWB2RSLT)
QUIT
+24 DO GENERATE^HLMA(XWB2EID,"LM",1,.XWB2RSLT,.XWB2MIEN)
+25 QUIT
+26 ;
NXTNODE ;Get next node
+1 NEW XWB2QL,XWB2QS
+2 SET XWB2QL=$QLENGTH($NAME(@XWB2SPR))
+3 IF XWB2QL=2
SET XWB2SPR=$NAME(@XWB2SPR@(1))
SET @XWB2SPR=""
QUIT
+4 IF XWB2QL=3
Begin DoDot:1
+5 SET XWB2QS=+$QSUBSCRIPT($NAME(@XWB2SPR),3)+1
+6 SET XWB2SPR=$NAME(@$NAME(@XWB2SPR,2)@(XWB2QS))
SET @XWB2SPR=""
End DoDot:1
QUIT
+7 QUIT
+8 ;
+9 ;
BLDDIST(X) ;Build distribution list -- HLL("LINKS") ARRAY.
+1 NEW %,XWB2LIST
+2 DO LINK^HLUTIL3(X,.XWB2LIST,"I")
+3 SET %=+$ORDER(XWB2LIST(0))
if '%
QUIT
+4 SET HLL("LINKS",1)="XWB RPC SUBSCRIBER"_U_XWB2LIST(%)
+5 QUIT
XLATE(S,OF) ;TRANSLATE FS and Encoding characters to Formating codes.
+1 ;Change ^ > \F\
+2 NEW X,I,I1,I2,I3,FC,TC,N,Y,Y1,L,L1,L2
+3 SET OF(0)=S
+4 FOR I1=1:1:5
SET FC=$EXTRACT(XWB2EMAP,I1)
SET TC=$EXTRACT(XWB2MAP2,I1)
Begin DoDot:1
+5 SET Y=""
+6 FOR I2=0,1,2
if '$DATA(OF(I2))
QUIT
SET S=OF(I2)
Begin DoDot:2
+7 SET L1=1
SET L2=$FIND(S,FC)
if 'L2
QUIT
+8 FOR
SET Y1=$EXTRACT(S,L1,L2-2)
Begin DoDot:3
+9 ;If next part wont fit, add it to the overflow node and exit
+10 IF $LENGTH(Y)+$LENGTH(Y1)+3>250
SET OF(I2+1)=$EXTRACT(S,L1,$LENGTH(S))_$GET(OF(I2+1))
SET OF(I2)=Y
SET S=""
QUIT
+11 SET Y=Y_Y1_$$ECODE(TC)
+12 QUIT
End DoDot:3
SET L1=L2
SET L2=$FIND(S,FC,L1)
if 'L2
QUIT
+13 ;Add the rest of S to the output.
+14 SET N=$EXTRACT(S,L1,$LENGTH(S))
IF $LENGTH(Y)+$LENGTH(N)>250
SET OF(I2+1)=N_$GET(OF(I2+1))
SET N=""
+15 SET S=Y_N
SET Y=""
+16 QUIT
End DoDot:2
SET OF(I2)=S
+17 QUIT
End DoDot:1
+18 SET Y=OF(0)
KILL OF(0)
+19 QUIT Y
+20 ;
ECODE(%) ;
+1 QUIT $EXTRACT(HL("ECH"),3)_%_$EXTRACT(HL("ECH"),3)
+2 ;
