- 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 Jan 18, 2025@03:00:15 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