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