ORHLESC ;SLC/JMH - HL7 UTILITY ;11:26 AM 2 Apr 2001
;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
;
; VAL = COMPONENT_REPETITION_ESCAPE_SUBCOMPONENT_FIELD
;
ESC(ORSTR,VAL) ; REPLACE HL7 DELIMITER CHAR
N SEPC,SEPR,SEPS,SEPF,SEPE,REPSEPC,REPSEPR,REPSEPS,REPSEPF,REPSEPE,I,HL7DEL
I '$L($G(VAL)) S VAL="~|\&^"
I $G(ORSTR)="" Q ""
I $TR(ORSTR,$G(VAL))=ORSTR Q ORSTR
N X,Y,Z,RES
S SEPE=$E(VAL,3),REPSEPE=SEPE_"E"_SEPE
S SEPC=$E(VAL,1),REPSEPC=SEPE_"S"_SEPE
S SEPR=$E(VAL,2),REPSEPR=SEPE_"R"_SEPE
S SEPS=$E(VAL,4),REPSEPS=SEPE_"T"_SEPE
S SEPF=$E(VAL,5),REPSEPF=SEPE_"F"_SEPE
S RES=ORSTR
I $F(ORSTR,SEPE) S X=RES D
. S Z=$P(X,SEPE,2,9999),Y=$P(X,SEPE)_REPSEPE_Z,RES=Y,X=Z I '$F(Z,SEPE) Q
. F I=2:1 S Z=$P(X,SEPE,2,9999),Y=$P(RES,REPSEPE,1,I-1)_REPSEPE_$P(X,SEPE)_REPSEPE_Z,RES=Y,X=Z I '$F(Z,SEPE) Q
;
I $F(RES,SEPC) F I=1:1 S Y=$P(RES,SEPC)_REPSEPC_$P(RES,SEPC,2,9999),RES=Y I '$F(RES,SEPC) Q
I $F(RES,SEPR) F I=1:1 S Y=$P(RES,SEPR)_REPSEPR_$P(RES,SEPR,2,9999),RES=Y I '$F(RES,SEPR) Q
I $F(RES,SEPS) F I=1:1 S Y=$P(RES,SEPS)_REPSEPS_$P(RES,SEPS,2,9999),RES=Y I '$F(RES,SEPS) Q
I $F(RES,SEPF) F I=1:1 S Y=$P(RES,SEPF)_REPSEPF_$P(RES,SEPF,2,9999),RES=Y I '$F(RES,SEPF) Q
Q RES
UNESC(ORSTR,VAL) ;
; Remove Escape Characters from HL7 Message Text
; Escape Sequence codes:
; F = field separator (ORFS)
; S = component separator (ORCS)
; R = repetition separator (ORRS)
; E = escape character (ORES)
; T = subcomponent separator (ORSS)
N ORFS,ORCS,ORRS,ORES,ORSS
I '$L($G(VAL)) S VAL="~|\&^"
S ORFS=$E(VAL,5)
S ORCS=$E(VAL,1)
S ORRS=$E(VAL,2)
S ORES=$E(VAL,3)
S ORSS=$E(VAL,4)
N ORCHR,ORREP,I1,I2,J1,J2,K,VALUE
F ORCHR="F","S","R","E","T" S ORREP(ORES_ORCHR_ORES)=$S(ORCHR="F":ORFS,ORCHR="S":ORCS,ORCHR="R":ORRS,ORCHR="E":ORES,ORCHR="T":ORSS)
S ORSTR=$$REPLACE^XLFSTR(ORSTR,.ORREP)
F S I1=$P(ORSTR,ORES_"X") Q:$L(I1)=$L(ORSTR) D
.S I2=$P(ORSTR,ORES_"X",2,99)
.S J1=$P(I2,ORES) Q:'$L(J1)
.S J2=$P(I2,ORES,2,99)
.S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10)
.S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE))
.S ORSTR=I1_K_J2
Q ORSTR
REPLACE(X,Y,Z) ;
; X is initial string
; Y is string to be replaced
; Z is string to replace
N RET
I X'[Y Q X
S I=1,RET=$P(X,Y) F S I=I+1,RET=RET_Z_$P(X,Y,I) Q:I=$L(X,Y)
Q RET
ORHLESC ;SLC/JMH - HL7 UTILITY ;11:26 AM 2 Apr 2001
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
+2 ;
+3 ; VAL = COMPONENT_REPETITION_ESCAPE_SUBCOMPONENT_FIELD
+4 ;
ESC(ORSTR,VAL) ; REPLACE HL7 DELIMITER CHAR
+1 NEW SEPC,SEPR,SEPS,SEPF,SEPE,REPSEPC,REPSEPR,REPSEPS,REPSEPF,REPSEPE,I,HL7DEL
+2 IF '$LENGTH($GET(VAL))
SET VAL="~|\&^"
+3 IF $GET(ORSTR)=""
QUIT ""
+4 IF $TRANSLATE(ORSTR,$GET(VAL))=ORSTR
QUIT ORSTR
+5 NEW X,Y,Z,RES
+6 SET SEPE=$EXTRACT(VAL,3)
SET REPSEPE=SEPE_"E"_SEPE
+7 SET SEPC=$EXTRACT(VAL,1)
SET REPSEPC=SEPE_"S"_SEPE
+8 SET SEPR=$EXTRACT(VAL,2)
SET REPSEPR=SEPE_"R"_SEPE
+9 SET SEPS=$EXTRACT(VAL,4)
SET REPSEPS=SEPE_"T"_SEPE
+10 SET SEPF=$EXTRACT(VAL,5)
SET REPSEPF=SEPE_"F"_SEPE
+11 SET RES=ORSTR
+12 IF $FIND(ORSTR,SEPE)
SET X=RES
Begin DoDot:1
+13 SET Z=$PIECE(X,SEPE,2,9999)
SET Y=$PIECE(X,SEPE)_REPSEPE_Z
SET RES=Y
SET X=Z
IF '$FIND(Z,SEPE)
QUIT
+14 FOR I=2:1
SET Z=$PIECE(X,SEPE,2,9999)
SET Y=$PIECE(RES,REPSEPE,1,I-1)_REPSEPE_$PIECE(X,SEPE)_REPSEPE_Z
SET RES=Y
SET X=Z
IF '$FIND(Z,SEPE)
QUIT
End DoDot:1
+15 ;
+16 IF $FIND(RES,SEPC)
FOR I=1:1
SET Y=$PIECE(RES,SEPC)_REPSEPC_$PIECE(RES,SEPC,2,9999)
SET RES=Y
IF '$FIND(RES,SEPC)
QUIT
+17 IF $FIND(RES,SEPR)
FOR I=1:1
SET Y=$PIECE(RES,SEPR)_REPSEPR_$PIECE(RES,SEPR,2,9999)
SET RES=Y
IF '$FIND(RES,SEPR)
QUIT
+18 IF $FIND(RES,SEPS)
FOR I=1:1
SET Y=$PIECE(RES,SEPS)_REPSEPS_$PIECE(RES,SEPS,2,9999)
SET RES=Y
IF '$FIND(RES,SEPS)
QUIT
+19 IF $FIND(RES,SEPF)
FOR I=1:1
SET Y=$PIECE(RES,SEPF)_REPSEPF_$PIECE(RES,SEPF,2,9999)
SET RES=Y
IF '$FIND(RES,SEPF)
QUIT
+20 QUIT RES
UNESC(ORSTR,VAL) ;
+1 ; Remove Escape Characters from HL7 Message Text
+2 ; Escape Sequence codes:
+3 ; F = field separator (ORFS)
+4 ; S = component separator (ORCS)
+5 ; R = repetition separator (ORRS)
+6 ; E = escape character (ORES)
+7 ; T = subcomponent separator (ORSS)
+8 NEW ORFS,ORCS,ORRS,ORES,ORSS
+9 IF '$LENGTH($GET(VAL))
SET VAL="~|\&^"
+10 SET ORFS=$EXTRACT(VAL,5)
+11 SET ORCS=$EXTRACT(VAL,1)
+12 SET ORRS=$EXTRACT(VAL,2)
+13 SET ORES=$EXTRACT(VAL,3)
+14 SET ORSS=$EXTRACT(VAL,4)
+15 NEW ORCHR,ORREP,I1,I2,J1,J2,K,VALUE
+16 FOR ORCHR="F","S","R","E","T"
SET ORREP(ORES_ORCHR_ORES)=$SELECT(ORCHR="F":ORFS,ORCHR="S":ORCS,ORCHR="R":ORRS,ORCHR="E":ORES,ORCHR="T":ORSS)
+17 SET ORSTR=$$REPLACE^XLFSTR(ORSTR,.ORREP)
+18 FOR
SET I1=$PIECE(ORSTR,ORES_"X")
IF $LENGTH(I1)=$LENGTH(ORSTR)
QUIT
Begin DoDot:1
+19 SET I2=$PIECE(ORSTR,ORES_"X",2,99)
+20 SET J1=$PIECE(I2,ORES)
IF '$LENGTH(J1)
QUIT
+21 SET J2=$PIECE(I2,ORES,2,99)
+22 SET VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10)
+23 SET K=$SELECT(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$CHAR(VALUE))
+24 SET ORSTR=I1_K_J2
End DoDot:1
+25 QUIT ORSTR
REPLACE(X,Y,Z) ;
+1 ; X is initial string
+2 ; Y is string to be replaced
+3 ; Z is string to replace
+4 NEW RET
+5 IF X'[Y
QUIT X
+6 SET I=1
SET RET=$PIECE(X,Y)
FOR
SET I=I+1
SET RET=RET_Z_$PIECE(X,Y,I)
IF I=$LENGTH(X,Y)
QUIT
+7 QUIT RET
