HLOPRS1 ;IRMFO-ALB/CJM -RTNs for parsing messages (continued);03/24/2004 14:43 ;01/19/2007
;;1.6;HEALTH LEVEL SEVEN;**118,131,133,134**;Oct 13, 1995;Build 30
;Per VHA Directive 2004-038, this routine should not be modified.
;
PARSE(FIELD,REP,COMP,SUBCOMP,ESCAPE,SEG,TO) ;
;Parses the segment stored in SEG(1),SEG(2),... into TO()
;Input:
; FIELD - field separator
; REP - field repetition separator
; COMP - component separator
; SUBCOMP - subcomponent separator
; ESCAPE - escape character
; SEG - (pass by reference) the array holding the unparsed segment.
;Output:
; Function returns 1 on success, 0 on failure
; TO - (pass by reference) - the parsed values
; SEG- This input variable is deleted during the processing. If it is needs to be retained, pass in a copy!
;
N VALUE,CHAR,COUNTS
K TO
Q:$L($G(FIELD))'=1 0
Q:$L($G(REP))'=1 0
Q:$L($G(COMP))'=1 0
Q:'$D(SUBCOMP) 0
Q:'$D(SEG) 0
S COUNTS("FIELD")=0
S COUNTS("REP")=1
S COUNTS("COMP")=1
S COUNTS("SUBCOMP")=1
S VALUE=""
S SEG("LINE")=$O(SEG(0)),SEG("CHAR")=0
F S CHAR=$$NEXTCHAR(.SEG) D Q:'$L(CHAR)
.I '$L(CHAR) D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=VALUE
.E I CHAR=FIELD D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("FIELD")=COUNTS("FIELD")+1,COUNTS("REP")=1,COUNTS("COMP")=1,COUNTS("SUBCOMP")=1
.E I CHAR=REP D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("REP")=COUNTS("REP")+1,COUNTS("COMP")=1,COUNTS("SUBCOMP")=1
.E I CHAR=COMP D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("COMP")=COUNTS("COMP")+1,COUNTS("SUBCOMP")=1
.E I CHAR=SUBCOMP D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("SUBCOMP")=COUNTS("SUBCOMP")+1
.E S VALUE=VALUE_CHAR
S TO("SEGMENT TYPE")=$G(TO(0,1,1,1)),TO(0)=TO("SEGMENT TYPE")
I (TO("SEGMENT TYPE")="BHS")!(TO("SEGMENT TYPE")="MSH") S TO("FIELD SEPARATOR")=FIELD
Q 1
;
NEXTCHAR(SEG) ;
;returns the next character in the segment array
;
Q:'SEG("LINE") ""
N RET
S SEG("CHAR")=SEG("CHAR")+1
S RET=$E(SEG(SEG("LINE")),SEG("CHAR"))
Q:RET]"" RET
S SEG("LINE")=$O(SEG(SEG("LINE")))
I SEG("LINE") S SEG("CHAR")=1 Q $E(SEG(SEG("LINE")))
Q ""
;
DESCAPE(VALUE,FIELD,COMP,SUBCOMP,REP,ESCAPE) ;
;Replaces the escape sequences with the corresponding encoding character and returns the result as the function value
;
Q:ESCAPE="" VALUE
N NEWSTRNG,SUBSTRNG,SET,LEN,I,SUBLEN,CHAR
S (NEWSTRNG,SUBSTRNG,SUBLEN)=""
S SET="FSTRE"
S LEN=$L(VALUE)
F I=1:1:LEN S SUBSTRNG=SUBSTRNG_$E(VALUE,I),SUBLEN=SUBLEN+1 D:SUBLEN=3
.S CHAR=$E(SUBSTRNG,2)
.I $E(SUBSTRNG,1)=ESCAPE,$E(SUBSTRNG,3)=ESCAPE,SET[CHAR D
..I CHAR="F" S NEWSTRNG=NEWSTRNG_FIELD,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="S" S NEWSTRNG=NEWSTRNG_COMP,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="T" S NEWSTRNG=NEWSTRNG_SUBCOMP,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="R" S NEWSTRNG=NEWSTRNG_REP,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="E" S NEWSTRNG=NEWSTRNG_ESCAPE,SUBSTRNG="",SUBLEN=0 Q
.E S NEWSTRNG=NEWSTRNG_$E(SUBSTRNG),SUBSTRNG=$E(SUBSTRNG,2,3),SUBLEN=2
Q NEWSTRNG_SUBSTRNG
;
GETCODE(SEG,VALUE,FIELD,COMP,REP) ;
;Implements GETCNE and GETCWE
;
N SUB,VAR
Q:'$G(FIELD)
I '$G(COMP) D
.S VAR="COMP",SUB=1
E D
.S VAR="SUB"
S:'$G(REP) REP=1
S @VAR=1,VALUE("ID")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
S @VAR=2,VALUE("TEXT")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
S @VAR=3,VALUE("SYSTEM")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
S @VAR=4,VALUE("ALTERNATE ID")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
S @VAR=5,VALUE("ALTERNATE TEXT")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
S @VAR=6,VALUE("ALTERNATE SYSTEM")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,RE)
S @VAR=7,VALUE("SYSTEM VERSION")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
S @VAR=8,VALUE("ALTERNATE SYSTEM VERSION")=$$GET^HLOPRS(.SEG,FIELD,COM)
S @VAR=9,VALUE("ORIGINAL TEXT")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOPRS1 4355 printed Sep 23, 2025@19:35:05 Page 2
HLOPRS1 ;IRMFO-ALB/CJM -RTNs for parsing messages (continued);03/24/2004 14:43 ;01/19/2007
+1 ;;1.6;HEALTH LEVEL SEVEN;**118,131,133,134**;Oct 13, 1995;Build 30
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
PARSE(FIELD,REP,COMP,SUBCOMP,ESCAPE,SEG,TO) ;
+1 ;Parses the segment stored in SEG(1),SEG(2),... into TO()
+2 ;Input:
+3 ; FIELD - field separator
+4 ; REP - field repetition separator
+5 ; COMP - component separator
+6 ; SUBCOMP - subcomponent separator
+7 ; ESCAPE - escape character
+8 ; SEG - (pass by reference) the array holding the unparsed segment.
+9 ;Output:
+10 ; Function returns 1 on success, 0 on failure
+11 ; TO - (pass by reference) - the parsed values
+12 ; SEG- This input variable is deleted during the processing. If it is needs to be retained, pass in a copy!
+13 ;
+14 NEW VALUE,CHAR,COUNTS
+15 KILL TO
+16 if $LENGTH($GET(FIELD))'=1
QUIT 0
+17 if $LENGTH($GET(REP))'=1
QUIT 0
+18 if $LENGTH($GET(COMP))'=1
QUIT 0
+19 if '$DATA(SUBCOMP)
QUIT 0
+20 if '$DATA(SEG)
QUIT 0
+21 SET COUNTS("FIELD")=0
+22 SET COUNTS("REP")=1
+23 SET COUNTS("COMP")=1
+24 SET COUNTS("SUBCOMP")=1
+25 SET VALUE=""
+26 SET SEG("LINE")=$ORDER(SEG(0))
SET SEG("CHAR")=0
+27 FOR
SET CHAR=$$NEXTCHAR(.SEG)
Begin DoDot:1
+28 IF '$LENGTH(CHAR)
Begin DoDot:2
+29 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=VALUE
End DoDot:2
QUIT
+30 IF '$TEST
IF CHAR=FIELD
Begin DoDot:2
+31 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+32 SET COUNTS("FIELD")=COUNTS("FIELD")+1
SET COUNTS("REP")=1
SET COUNTS("COMP")=1
SET COUNTS("SUBCOMP")=1
End DoDot:2
QUIT
+33 IF '$TEST
IF CHAR=REP
Begin DoDot:2
+34 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+35 SET COUNTS("REP")=COUNTS("REP")+1
SET COUNTS("COMP")=1
SET COUNTS("SUBCOMP")=1
End DoDot:2
QUIT
+36 IF '$TEST
IF CHAR=COMP
Begin DoDot:2
+37 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+38 SET COUNTS("COMP")=COUNTS("COMP")+1
SET COUNTS("SUBCOMP")=1
End DoDot:2
QUIT
+39 IF '$TEST
IF CHAR=SUBCOMP
Begin DoDot:2
+40 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+41 SET COUNTS("SUBCOMP")=COUNTS("SUBCOMP")+1
End DoDot:2
QUIT
+42 IF '$TEST
SET VALUE=VALUE_CHAR
End DoDot:1
if '$LENGTH(CHAR)
QUIT
+43 SET TO("SEGMENT TYPE")=$GET(TO(0,1,1,1))
SET TO(0)=TO("SEGMENT TYPE")
+44 IF (TO("SEGMENT TYPE")="BHS")!(TO("SEGMENT TYPE")="MSH")
SET TO("FIELD SEPARATOR")=FIELD
+45 QUIT 1
+46 ;
NEXTCHAR(SEG) ;
+1 ;returns the next character in the segment array
+2 ;
+3 if 'SEG("LINE")
QUIT ""
+4 NEW RET
+5 SET SEG("CHAR")=SEG("CHAR")+1
+6 SET RET=$EXTRACT(SEG(SEG("LINE")),SEG("CHAR"))
+7 if RET]""
QUIT RET
+8 SET SEG("LINE")=$ORDER(SEG(SEG("LINE")))
+9 IF SEG("LINE")
SET SEG("CHAR")=1
QUIT $EXTRACT(SEG(SEG("LINE")))
+10 QUIT ""
+11 ;
DESCAPE(VALUE,FIELD,COMP,SUBCOMP,REP,ESCAPE) ;
+1 ;Replaces the escape sequences with the corresponding encoding character and returns the result as the function value
+2 ;
+3 if ESCAPE=""
QUIT VALUE
+4 NEW NEWSTRNG,SUBSTRNG,SET,LEN,I,SUBLEN,CHAR
+5 SET (NEWSTRNG,SUBSTRNG,SUBLEN)=""
+6 SET SET="FSTRE"
+7 SET LEN=$LENGTH(VALUE)
+8 FOR I=1:1:LEN
SET SUBSTRNG=SUBSTRNG_$EXTRACT(VALUE,I)
SET SUBLEN=SUBLEN+1
if SUBLEN=3
Begin DoDot:1
+9 SET CHAR=$EXTRACT(SUBSTRNG,2)
+10 IF $EXTRACT(SUBSTRNG,1)=ESCAPE
IF $EXTRACT(SUBSTRNG,3)=ESCAPE
IF SET[CHAR
Begin DoDot:2
+11 IF CHAR="F"
SET NEWSTRNG=NEWSTRNG_FIELD
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+12 IF CHAR="S"
SET NEWSTRNG=NEWSTRNG_COMP
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+13 IF CHAR="T"
SET NEWSTRNG=NEWSTRNG_SUBCOMP
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+14 IF CHAR="R"
SET NEWSTRNG=NEWSTRNG_REP
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+15 IF CHAR="E"
SET NEWSTRNG=NEWSTRNG_ESCAPE
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
End DoDot:2
+16 IF '$TEST
SET NEWSTRNG=NEWSTRNG_$EXTRACT(SUBSTRNG)
SET SUBSTRNG=$EXTRACT(SUBSTRNG,2,3)
SET SUBLEN=2
End DoDot:1
+17 QUIT NEWSTRNG_SUBSTRNG
+18 ;
GETCODE(SEG,VALUE,FIELD,COMP,REP) ;
+1 ;Implements GETCNE and GETCWE
+2 ;
+3 NEW SUB,VAR
+4 if '$GET(FIELD)
QUIT
+5 IF '$GET(COMP)
Begin DoDot:1
+6 SET VAR="COMP"
SET SUB=1
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET VAR="SUB"
End DoDot:1
+9 if '$GET(REP)
SET REP=1
+10 SET @VAR=1
SET VALUE("ID")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
+11 SET @VAR=2
SET VALUE("TEXT")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
+12 SET @VAR=3
SET VALUE("SYSTEM")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
+13 SET @VAR=4
SET VALUE("ALTERNATE ID")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
+14 SET @VAR=5
SET VALUE("ALTERNATE TEXT")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
+15 SET @VAR=6
SET VALUE("ALTERNATE SYSTEM")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,RE)
+16 SET @VAR=7
SET VALUE("SYSTEM VERSION")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
+17 SET @VAR=8
SET VALUE("ALTERNATE SYSTEM VERSION")=$$GET^HLOPRS(.SEG,FIELD,COM)
+18 SET @VAR=9
SET VALUE("ORIGINAL TEXT")=$$GET^HLOPRS(.SEG,FIELD,COMP,SUB,REP)
+19 QUIT
