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

XWB2HL7A.m

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