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

XWB2HL7B.m

Go to the documentation of this file. 
  1. XWB2HL7B ;ISF/AC  - Remote RPCs via HL7. ;03/27/2003  17:46
  1.  ;;1.1;RPC BROKER;**12,22,39**;Mar 28, 1997
  1. RPCRECV ;Called from the XWB RPC CLIENT protocol
  1.  ;Called on the remote system
  1.  N I,I1,J,XWB2EMAP,XWB2IPRM,XWB2LPRM,XWB2MAP2,XWB2PEND,XWB2QTAG,XWB2RNAM,XWB2RFLD,CMPNTREM,XWB2RPCP,XWB2SPN,XWB2RSLT,XWB2Y,Y
  1.  F I=1:1 X HLNEXT Q:HLQUIT'>0  S XWB2Y(I)=HLNODE,J=0 F  S J=$O(HLNODE(J)) Q:'J  S XWB2Y(I,J)=HLNODE(J)
  1.  ;Define Encoding characters to map by order
  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.  D PARSSPR G GENACK:$G(HLERR)]""
  1.  ;Merge into the parameter list the last of the remainder
  1.  ;nodes that have not been processed.
  1.  S I1=$O(XWB2RPCP("R",0)) I I1 D
  1.  .M XWB2RPCP(I1)=XWB2RPCP("R",I1)
  1.  .K XWB2RPCP("R")
  1.  D COMPRES(.XWB2RPCP)
  1.  ;Call to build and do rpc
  1.  D REMOTE^XWB2HL7(.XWB2RNAM,XWB2QTAG,XWB2SPN,.XWB2RPCP)
  1. GENACK ;Generate ack/nak
  1.  K ^TMP("HLA",$J)
  1.  S ^TMP("HLA",$J,1)="MSA"_HL("FS")_$S($G(HLERR)]"":"AE",1:"AA")_HL("FS")_HL("MID")_$S($G(HLERR)]"":HL("FS")_HLERR,1:"")
  1.  S ^TMP("HLA",$J,2)="QAK"_HL("FS")_XWB2QTAG_HL("FS")_$S($G(HLERR)]"":"AE",1:"OK")
  1.  S ^TMP("HLA",$J,3)="RDF"_HL("FS")_"1"_HL("FS")_"@DSP.3"_$E(HL("ECH"))_"TX"_$E(HL("ECH"))_"300"
  1.  D:$G(HLERR)']"" BLDRDT
  1.  D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.XWB2RSLT)
  1. RECVXIT ;Cleanup of receiver processing sub-routine
  1.  K ^TMP("HLA",$J)
  1.  Q
  1.  ;
  1. PARSSPR ;Parse SPR segment for paramaeters.
  1.  N %,%1
  1.  S I=2
  1.  ;Extract handle
  1.  S XWB2QTAG=$P(XWB2Y(I),HL("FS"),2)
  1.  ;Extract Stored Procedure Name
  1.  S XWB2SPN=$P(XWB2Y(I),HL("FS"),4)
  1.  ;Extract Input Parameters
  1.  S XWB2IPRM=$P(XWB2Y(I),HL("FS"),5)
  1.  ;Determine whether Input Parameters fit on one line of SPR segment.
  1.  ;XWB2LPRM=1 if parameters continue on overflow nodes.
  1.  ;XWB2LPRM=0 if parameters fit on a single node.
  1.  S XWB2LPRM=$S($L(XWB2Y(I),HL("FS"))=5:$S($O(XWB2Y(I,0)):1,1:0),1:0)
  1.  ;Format of
  1.  ;INPUT PARAMETERS:@SPR.4.2~PARAM1&PARAM2
  1.  ;
  1.  ;Short SPR segment
  1.  I 'XWB2LPRM S %=$P(XWB2Y(I),HL("FS"),5) D INPUTPRM(%,0) Q
  1.  ;Long SPR segment
  1.  S %=$P(XWB2Y(I),HL("FS"),5,9999)
  1.  F %1=0:0 S %1=$O(XWB2Y(I,%1)) D INPUTPRM(%,(%1>0)) Q:%1'>0!$G(XWB2PEND)  S %=XWB2Y(I,%1)
  1.  ;
  1.  Q
  1.  ;
  1. INPUTPRM(X1,L1) ;Process Input Parameters
  1.  ;X1 contains an extract of Input Parameters
  1.  ;L1=0 if Parameters fit on a single SPR Segment node.
  1.  ;L1=1 if Parameters do not fit on a single SPR Segment node.
  1.  N I,IL,Y1
  1.  S IL=$L(X1,HL("FS"))
  1.  S Y1=$P(X1,HL("FS"),1)
  1.  I $G(L1),IL'>1 D REPEATLP(Y1,1) S:$G(HLERR)]"" XWB2PEND=1 Q
  1.  D REPEATLP(Y1)
  1.  I IL>1!($G(HLERR)]"") S XWB2PEND=1
  1.  Q
  1. REPEATLP(X2,L2) ;Loop through repeatable components.
  1.  ;X2 contains an extract of Input Parameters
  1.  ;$G(L2)>0 if component may extend onto overflow node.
  1.  N I,RL,Y2
  1.  S RL=$L(X2,$E(HL("ECH"),2))
  1.  F I=1:1:RL D  Q:$G(HLERR)]""
  1.  .S Y2=$P(X2,$E(HL("ECH"),2),I)
  1.  .I $G(L2),I=RL D COMPONT(Y2,1) Q
  1.  .D COMPONT(Y2)
  1.  Q
  1. COMPONT(X3,L3) ;Loop through the two components.
  1.  ;X3 contains an extract of a component.
  1.  ;$G(L3)>0 if component may extend onto next overflow node.
  1.  N CL,I,Y3
  1.  S CL=$L(X3,$E(HL("ECH")))
  1.  I CL>2 S HLERR="Too many components!" Q
  1.  I CL=2 D  Q
  1.  .S Y3=$P(X3,$E(HL("ECH")),1)
  1.  .;CHECK FLD REMAINDER,
  1.  .S I=$O(XWB2RFLD("R",0)) I I D  Q:$G(HLERR)]""
  1.  ..I ($L(XWB2RFLD("R",+I))+$L(Y3))>255 S HLERR="Field name too long!" Q
  1.  ..S XWB2RFLD(+I)=XWB2RFLD("R",+I)_Y3
  1.  ..K XWB2RFLD("R",+I)
  1.  .S I=+$O(XWB2RFLD("@"),-1)+1
  1.  .S XWB2RFLD(I)=Y3
  1.  .;CLEAR FLD REMAINDER
  1.  .S Y3=$P(X3,$E(HL("ECH")),2)
  1.  .D SUBCMPNT(Y3,$G(L3))
  1.  .;SET COMPONENT REMAINDER FLAG.
  1.  .S CMPNTREM=$G(L3)
  1.  I CL=1 D  Q
  1.  .S Y3=$P(X3,$E(HL("ECH")),1)
  1.  .I $G(CMPNTREM) D SUBCMPNT(Y3,$G(L3)) Q
  1.  .S I=$O(XWB2RFLD("R",0)) I I D  Q
  1.  ..I ($L(XWB2RFLD("R",+I))+$L(Y3))>255 S HLERR="Field name too long!" Q
  1.  ..S XWB2RFLD(+I)=XWB2RFLD("R",+I)_Y3
  1.  ..K XWB2RFLD("R",+I)
  1.  ;
  1.  Q
  1. SUBCMPNT(X4,L4) ;Loop through sub-components.
  1.  ;X4 contains an extract of the subcomponent.
  1.  ;L4=0 if subcomponent does not extend onto next overflow node.
  1.  ;L4=1 if subcomponent does extend onto next overflow node.
  1.  N I,I1,I2,RMNDRLEN,SL,Y4
  1.  S SL=$L(X4,$E(HL("ECH"),4))
  1.  F I=1:1:SL D
  1.  .S Y4=$P(X4,$E(HL("ECH"),4),I)
  1.  .I $G(L4),I=SL D  Q
  1.  ..;Long node, find last remainder
  1.  ..S I1=$O(XWB2RPCP("R",0))
  1.  ..I 'I1 D
  1.  ...;No remainder, create remainder for next parameter(subcomponent).
  1.  ...S I1=+$O(XWB2RPCP("@"),-1)+1
  1.  ...S XWB2RPCP("R",I1)=Y4 Q
  1.  ..E  D
  1.  ...;Remainder exists, find last remainder overflow
  1.  ...S I2=+$O(XWB2RPCP("R",I1,"@"),-1)+1
  1.  ...;Length of last remainder
  1.  ...S RMNDRLEN=$S(I2=1:$L(XWB2RPCP("R",I1)),1:$L(XWB2RPCP("R",I1,I2-1)))
  1.  ...;If last remainder has space, squeeze more chars onto last remainder.
  1.  ...I RMNDRLEN<255 D
  1.  ....I I2=1 D  Q
  1.  .....S XWB2RPCP("R",I1)=XWB2RPCP("R",I1)_$E(Y4,1,255-RMNDRLEN)
  1.  .....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
  1.  ....E  D
  1.  .....S XWB2RPCP("R",I1,I2-1)=XWB2RPCP("R",I1,I2-1)_$E(Y4,1,255-RMNDRLEN)
  1.  .....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
  1.  ...;Save remaining chars in Y4 in current remainder node.
  1.  ...S XWB2RPCP("R",I1,I2)=Y4
  1.  .;Merge Remainder nodes into primary nodes.
  1.  .;then remove Remainder nodes.
  1.  .S I1=$O(XWB2RPCP("R",0)) I I1 D  Q
  1.  ..S I2=+$O(XWB2RPCP("R",I1,"@"),-1)+1
  1.  ..S RMNDRLEN=$S(I2=1:$L(XWB2RPCP("R",I1)),1:$L(XWB2RPCP("R",I1,I2-1)))
  1.  ..I RMNDRLEN<255 D
  1.  ...I I2=1 D  Q
  1.  ....S XWB2RPCP("R",I1)=XWB2RPCP("R",I1)_$E(Y4,1,255-RMNDRLEN)
  1.  ....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
  1.  ...E  D
  1.  ....S XWB2RPCP("R",I1,I2-1)=XWB2RPCP("R",I1,I2-1)_$E(Y4,1,255-RMNDRLEN)
  1.  ....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
  1.  ..S:Y4]"" XWB2RPCP("R",I1,I2)=Y4
  1.  ..M XWB2RPCP(I1)=XWB2RPCP("R",I1)
  1.  ..K XWB2RPCP("R")
  1.  .S I1=+$O(XWB2RPCP("@"),-1)+1
  1.  .S XWB2RPCP(I1)=Y4
  1.  Q
  1.  ;
  1. BLDRDT ;Build RDT segments.
  1.  N RDTNODE,NODELEN,I,NODERDT
  1.  S RDTNODE=XWB2RNAM,NODERDT=$E(XWB2RNAM,1,$L(XWB2RNAM)-($E(XWB2RNAM,$L(XWB2RNAM))=")"))
  1.  I '($D(@RDTNODE)#2) D  Q:RDTNODE'[NODERDT
  1.  .S RDTNODE=$Q(@RDTNODE)
  1.  F I=4:1 D  S RDTNODE=$Q(@RDTNODE) Q:RDTNODE'[NODERDT
  1.  .S NODELEN=$L(@RDTNODE)
  1.  .I NODELEN'>241 S ^TMP("HLA",$J,I)="RDT"_HL("FS")_@RDTNODE Q
  1.  .S ^TMP("HLA",$J,I)="RDT"_HL("FS")_$E(@RDTNODE,1,241)
  1.  .S ^TMP("HLA",$J,I,1)=$E(@RDTNODE,242,9999)
  1.  Q
  1.  ;
  1. DXLATE(X,OVFL) ;TRANSLATE encoded characters back to there Formating codes.
  1.  ;Undoes the work of XLATE^XWB2HL7A,  \F\ > ^
  1.  N D,I,I1,L,L1,X1,X2,Y
  1.  S D=$E(HL("ECH"),3),L=$F(X,D),OVFL=""
  1.  I 'L Q X
  1.  F  D  S L=$F(X,D,L) Q:'L
  1.  . S L1=$F(XWB2MAP2,$E(X,L))
  1.  . I L1'>1 D  Q
  1.  . .I L1=1 S OVFL=$E(X,L-1),X=$E(X,1,$L(X)-1)
  1.  . I L=$L(X) S OVFL=$E(X,L-1,L),X=$E(X,1,L-2) Q
  1.  . S X2=$E(XWB2EMAP,L1-1)
  1.  . S $E(X,L-1,L+1)=X2,L=0
  1.  Q X ;Return the converted string
  1.  ;
  1. COMPRES(XWB2P) ;DXLATE AND COMPRESS ARRAY.
  1.  N CNODE,E,I,J,L,L1,NNODE,XWB2X1,XWB2X2
  1.  S E=$E(HL("ECH"),3)
  1.  F I=0:0 S I=$O(XWB2P(I)) Q:I'>0  D
  1.  .S CNODE=$NA(XWB2P(I))
  1.  .S @CNODE=$$DXLATE(@CNODE,.XWB2X1)
  1.  .S L=$L(@CNODE),NNODE=CNODE
  1.  .F  S NNODE=$$NEXTNODE(NNODE) Q:NNODE']""  D
  1.  ..I $G(XWB2X1)]"" D
  1.  ...S L1=$L(XWB2X1)
  1.  ...S XWB2X2=$E(@NNODE,1,3-L1)
  1.  ...S Y=$$DXLATE(XWB2X1_XWB2X2)
  1.  ...I $L(Y)=1 D
  1.  ....S @CNODE=@CNODE_Y
  1.  ....S @NNODE=$E(@NNODE,3-L1+1,$L(@NNODE))
  1.  ...E  S @CNODE=@CNODE_XWB2X1
  1.  ..S CNODE=NNODE
  1.  ..K XWB2X1 S @CNODE=$$DXLATE(@CNODE,.XWB2X1)
  1.  .I $G(XWB2X1)]"" S @CNODE=@CNODE_XWB2X1
  1.  ;Compress nodes
  1.  F I=0:0 S I=$O(XWB2P(I)) Q:I'>0  D
  1.  .S CNODE=$NA(XWB2P(I))
  1.  .S L=$L(@CNODE)
  1.  .S NNODE=CNODE
  1.  .F  Q:NNODE']""  S NNODE=$$NEXTNODE(NNODE) Q:NNODE']""  D
  1.  ..I L'<255 S CNODE=NNODE,L=$L(@CNODE) Q
  1.  ..F  S NNODE=$$NEXTNODE(NNODE) Q:NNODE']""  D  I L=255 S NNODE=CNODE Q
  1.  ...S L1=$L(@NNODE)
  1.  ...I 'L1 Q
  1.  ...S $E(@CNODE,L+1,255)=$E(@NNODE,1,255-L)
  1.  ...S @NNODE=$E(@NNODE,255-L+1,255)
  1.  ...S L=$L(@CNODE)
  1.  .;Clean up excess nodes
  1.  .S NNODE=CNODE
  1.  .F  S NNODE=$$NEXTNODE(NNODE) Q:NNODE']""  D
  1.  ..I '$L(@NNODE) K @NNODE
  1.  Q
  1.  ;
  1. NEXTNODE(%) ;Get next node from $NA reference.
  1.  N QL,QS,X1,Y
  1.  S QL=$QL($NA(@%))
  1.  I QL=1 S X1=$O(@%@(0)),Y=$S(X1:$NA(@%@(X1)),1:"") Q Y
  1.  I QL=2 D  Q Y
  1.  .S X1=$O(@%),Y=$S(X1:$NA(@$NA(@%,1)@(X1)),1:"") Q
  1.  Q "" ;Error, should not have more than two nodes.