VAFHLRO1 ;BP/JRP - UTILITIES FOR BUILDING HL7 ROLE SEGMENT;11/18/1997
;;5.3;Registration;**160**;Aug 13, 1993
;
;
FIXLEN(INARR,OUTARR,MAXLEN,WORKSUB) ;Fixed length copy/collapse
;
;Input : INARR - Input array (full global reference)
; OUTARR - Output array (full global reference)
; MAXLEN - Maximum length (defaults to 245)
; WORKSUB - Subscript [in OUTARR] to begin from (defaults to 0)
;Output : None
; INARR() will be collapsed into OUTARR()
;Notes : Validity and existance of input is assumed
; : OUTARR() is not initialized (i.e. KILLed) on input
; : Sample input & output with maximum length of 4
; INARR(1)=12345 OUTARR(0)=1234
; INARR(1,2)=ABCD OUTARR(1)=5ABC
; INARR(2)=567 OUTARR(2)=D567
;
;
S MAXLEN=$G(MAXLEN)
S:(MAXLEN<1) MAXLEN=245
S WORKSUB=$G(WORKSUB)
S:(WORKSUB<1) WORKSUB=0
;Declare variables
N ROOT,VALUE,RESULT
;Declare variables for recursive portion of call
N LENVAL,LENRES,LEN,LENOVR
;Remember root of INARR
S ROOT=$$OREF^DILF(INARR)
;Work down INARR
S RESULT=""
F S INARR=$Q(@INARR) Q:((INARR="")!(INARR'[ROOT)) D
.;Grab value to append
.S VALUE=$G(@INARR)
.;Recusively do fix length copy/collapse
.D FIXLEN1
;If anything still left in RESULT, put into OUTARR()
S:(RESULT'="") @OUTARR@(WORKSUB)=RESULT
;Done
Q
;
FIXLEN1 ;Recursive portion of FIXLEN
;
;Input : VALUE - Value to append to RESULT
; RESULT - Working & resulting value
; OUTARR - Array to place max length results into (full global)
; WORKSUB - Working subscript in OUTARR (where to put results)
; MAXLEN - Maximum length for RESULT
;Output : None
; If max length was exceeded, then OUTARR(WORKSUB) will contain
; the leading portion of appending, WORKSUB will be incremented
; by 1, and RESULT will contain what was left. If max length
; was not exceeded, then VALUE will be appended to RESULT and
; OUTARR(WORKSUB) will be left unchanged.
;Notes : Validity and existance of input is assumed
; : Declarations done in FIXLEN
; : VALUE may be modified by this call
;
;VALUE is null - done
Q:(VALUE="")
;Get lengths of VAL & RES
S LENVAL=$L(VALUE)
S LENRES=$L(RESULT)
;Determine what resulting length will be
S LEN=LENRES+LENVAL
;Max length will not be exceeded - append and quit
I (LEN<MAXLEN) S RESULT=RESULT_VALUE Q
I (LEN=MAXLEN) S RESULT=RESULT_VALUE Q
;Determine exceeding length
S LENOVR=LEN-MAXLEN
;Put non-exceeding portion into output array
S @OUTARR@(WORKSUB)=RESULT_$E(VALUE,1,(LENVAL-LENOVR))
;Increment working subscript
S WORKSUB=WORKSUB+1
;Put exceeding portion into RESULT
; Use recursion to account for further exceeding
S RESULT=""
S VALUE=$E(VALUE,((LENVAL-LENOVR)+1),LENVAL)
D FIXLEN1
;Done
Q
;
GETATT(SEQ) ;Get element attributes
;
;Input : SEQ - Sequence number
;Output : Role segment attributes (as defined by HL7 standard)
; SEQ^LEN^DT^OPT^RP/#^TBL#^ITEM#^ELEMENT NAME
;Notes : Null is returned on bad input
;
;Get/return attributes
S SEQ="S"_$G(SEQ)
Q $P($T(@SEQ),";;",2,999)
;
SEQREQ(SEQ) ;Required element ?
;
;Input : SEQ - Sequence number
;Output : 1 = Yes 0 = No
;Notes : 0 (no) is returned on bad input
;
;Declare variables
N TMP
;Get attributes
S TMP=$$GETATT($G(SEQ))
;Required/optional attribute lists required
Q:($P(TMP,"^",4)="R") 1
;Optional
Q 0
;
ERROR(SEQ,OUTARR,ERROR) ;Add error node to output array
;
;Input : SEQ - Sequence number
; OUTARR - Output array
; ERROR - Error text to include
;Output : None
; Required Element
; OUTARR("ERROR",SEQ,x) = Error text
; Optional Element
; OUTARR("WARNING",SEQ,x) = Error text
;Notes : Input error text (ERROR) will be appended to text stating
; whether element is required/optional and the element name
;
N ATTRIB,REQUIRED,ELEMENT,TEXT
;Get attributes
S ATTRIB=$$GETATT($G(SEQ))
;Required/Optional
S REQUIRED=0
S:($P(ATTRIB,"^",4)="R") REQUIRED=1
;Element name
S ELEMENT=$P(ATTRIB,"^",8)
S:(ELEMENT="") ELEMENT="Unknown (seq #"_SEQ_")"
;Build blanket error text
S TEXT=$S(REQUIRED:"Required",1:"Optional")
S TEXT=TEXT_" data element '"_ELEMENT_"'"
;Append input error text (if present)
S:($G(ERROR)'="") TEXT=TEXT_" "_ERROR
;Use WARNING node for optional element & ERROR node for required
S:('REQUIRED) OUTARR=$NA(@OUTARR@("WARNING"))
S:(REQUIRED) OUTARR=$NA(@OUTARR@("ERROR"))
;Get next subscript in ouput array
S ATTRIB=1+$O(@OUTARR@(SEQ,""),-1)
;Place error text into output array
S @OUTARR@(SEQ,ATTRIB)=TEXT
;Done
Q
;
;
;Role segment attributes (as defined by HL7 standard)
ATTRIB ;;SEQ^LEN^DT^OPT^RP/#^TBL#^ITEM#^ELEMENT NAME
S1 ;;1^60^EI^R^^^01206^Role Instance ID
S2 ;;2^2^ID^R^^0287^00816^Action Code
S3 ;;3^80^CE^R^^^01197^Role
S4 ;;4^80^XCN^R^^^01198^Role Person
S5 ;;5^26^TS^O^^^01199^Role Begin Date/Time
S6 ;;6^26^TS^O^^^01200^Role End Date/Time
S7 ;;7^80^CE^O^^^01201^Role Duration
S8 ;;8^80^CE^O^^^01205^Role Action Reason
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHLRO1 5267 printed Sep 23, 2025@20:39:05 Page 2
VAFHLRO1 ;BP/JRP - UTILITIES FOR BUILDING HL7 ROLE SEGMENT;11/18/1997
+1 ;;5.3;Registration;**160**;Aug 13, 1993
+2 ;
+3 ;
FIXLEN(INARR,OUTARR,MAXLEN,WORKSUB) ;Fixed length copy/collapse
+1 ;
+2 ;Input : INARR - Input array (full global reference)
+3 ; OUTARR - Output array (full global reference)
+4 ; MAXLEN - Maximum length (defaults to 245)
+5 ; WORKSUB - Subscript [in OUTARR] to begin from (defaults to 0)
+6 ;Output : None
+7 ; INARR() will be collapsed into OUTARR()
+8 ;Notes : Validity and existance of input is assumed
+9 ; : OUTARR() is not initialized (i.e. KILLed) on input
+10 ; : Sample input & output with maximum length of 4
+11 ; INARR(1)=12345 OUTARR(0)=1234
+12 ; INARR(1,2)=ABCD OUTARR(1)=5ABC
+13 ; INARR(2)=567 OUTARR(2)=D567
+14 ;
+15 ;
+16 SET MAXLEN=$GET(MAXLEN)
+17 if (MAXLEN<1)
SET MAXLEN=245
+18 SET WORKSUB=$GET(WORKSUB)
+19 if (WORKSUB<1)
SET WORKSUB=0
+20 ;Declare variables
+21 NEW ROOT,VALUE,RESULT
+22 ;Declare variables for recursive portion of call
+23 NEW LENVAL,LENRES,LEN,LENOVR
+24 ;Remember root of INARR
+25 SET ROOT=$$OREF^DILF(INARR)
+26 ;Work down INARR
+27 SET RESULT=""
+28 FOR
SET INARR=$QUERY(@INARR)
if ((INARR="")!(INARR'[ROOT))
QUIT
Begin DoDot:1
+29 ;Grab value to append
+30 SET VALUE=$GET(@INARR)
+31 ;Recusively do fix length copy/collapse
+32 DO FIXLEN1
End DoDot:1
+33 ;If anything still left in RESULT, put into OUTARR()
+34 if (RESULT'="")
SET @OUTARR@(WORKSUB)=RESULT
+35 ;Done
+36 QUIT
+37 ;
FIXLEN1 ;Recursive portion of FIXLEN
+1 ;
+2 ;Input : VALUE - Value to append to RESULT
+3 ; RESULT - Working & resulting value
+4 ; OUTARR - Array to place max length results into (full global)
+5 ; WORKSUB - Working subscript in OUTARR (where to put results)
+6 ; MAXLEN - Maximum length for RESULT
+7 ;Output : None
+8 ; If max length was exceeded, then OUTARR(WORKSUB) will contain
+9 ; the leading portion of appending, WORKSUB will be incremented
+10 ; by 1, and RESULT will contain what was left. If max length
+11 ; was not exceeded, then VALUE will be appended to RESULT and
+12 ; OUTARR(WORKSUB) will be left unchanged.
+13 ;Notes : Validity and existance of input is assumed
+14 ; : Declarations done in FIXLEN
+15 ; : VALUE may be modified by this call
+16 ;
+17 ;VALUE is null - done
+18 if (VALUE="")
QUIT
+19 ;Get lengths of VAL & RES
+20 SET LENVAL=$LENGTH(VALUE)
+21 SET LENRES=$LENGTH(RESULT)
+22 ;Determine what resulting length will be
+23 SET LEN=LENRES+LENVAL
+24 ;Max length will not be exceeded - append and quit
+25 IF (LEN<MAXLEN)
SET RESULT=RESULT_VALUE
QUIT
+26 IF (LEN=MAXLEN)
SET RESULT=RESULT_VALUE
QUIT
+27 ;Determine exceeding length
+28 SET LENOVR=LEN-MAXLEN
+29 ;Put non-exceeding portion into output array
+30 SET @OUTARR@(WORKSUB)=RESULT_$EXTRACT(VALUE,1,(LENVAL-LENOVR))
+31 ;Increment working subscript
+32 SET WORKSUB=WORKSUB+1
+33 ;Put exceeding portion into RESULT
+34 ; Use recursion to account for further exceeding
+35 SET RESULT=""
+36 SET VALUE=$EXTRACT(VALUE,((LENVAL-LENOVR)+1),LENVAL)
+37 DO FIXLEN1
+38 ;Done
+39 QUIT
+40 ;
GETATT(SEQ) ;Get element attributes
+1 ;
+2 ;Input : SEQ - Sequence number
+3 ;Output : Role segment attributes (as defined by HL7 standard)
+4 ; SEQ^LEN^DT^OPT^RP/#^TBL#^ITEM#^ELEMENT NAME
+5 ;Notes : Null is returned on bad input
+6 ;
+7 ;Get/return attributes
+8 SET SEQ="S"_$GET(SEQ)
+9 QUIT $PIECE($TEXT(@SEQ),";;",2,999)
+10 ;
SEQREQ(SEQ) ;Required element ?
+1 ;
+2 ;Input : SEQ - Sequence number
+3 ;Output : 1 = Yes 0 = No
+4 ;Notes : 0 (no) is returned on bad input
+5 ;
+6 ;Declare variables
+7 NEW TMP
+8 ;Get attributes
+9 SET TMP=$$GETATT($GET(SEQ))
+10 ;Required/optional attribute lists required
+11 if ($PIECE(TMP,"^",4)="R")
QUIT 1
+12 ;Optional
+13 QUIT 0
+14 ;
ERROR(SEQ,OUTARR,ERROR) ;Add error node to output array
+1 ;
+2 ;Input : SEQ - Sequence number
+3 ; OUTARR - Output array
+4 ; ERROR - Error text to include
+5 ;Output : None
+6 ; Required Element
+7 ; OUTARR("ERROR",SEQ,x) = Error text
+8 ; Optional Element
+9 ; OUTARR("WARNING",SEQ,x) = Error text
+10 ;Notes : Input error text (ERROR) will be appended to text stating
+11 ; whether element is required/optional and the element name
+12 ;
+13 NEW ATTRIB,REQUIRED,ELEMENT,TEXT
+14 ;Get attributes
+15 SET ATTRIB=$$GETATT($GET(SEQ))
+16 ;Required/Optional
+17 SET REQUIRED=0
+18 if ($PIECE(ATTRIB,"^",4)="R")
SET REQUIRED=1
+19 ;Element name
+20 SET ELEMENT=$PIECE(ATTRIB,"^",8)
+21 if (ELEMENT="")
SET ELEMENT="Unknown (seq #"_SEQ_")"
+22 ;Build blanket error text
+23 SET TEXT=$SELECT(REQUIRED:"Required",1:"Optional")
+24 SET TEXT=TEXT_" data element '"_ELEMENT_"'"
+25 ;Append input error text (if present)
+26 if ($GET(ERROR)'="")
SET TEXT=TEXT_" "_ERROR
+27 ;Use WARNING node for optional element & ERROR node for required
+28 if ('REQUIRED)
SET OUTARR=$NAME(@OUTARR@("WARNING"))
+29 if (REQUIRED)
SET OUTARR=$NAME(@OUTARR@("ERROR"))
+30 ;Get next subscript in ouput array
+31 SET ATTRIB=1+$ORDER(@OUTARR@(SEQ,""),-1)
+32 ;Place error text into output array
+33 SET @OUTARR@(SEQ,ATTRIB)=TEXT
+34 ;Done
+35 QUIT
+36 ;
+37 ;
+38 ;Role segment attributes (as defined by HL7 standard)
ATTRIB ;;SEQ^LEN^DT^OPT^RP/#^TBL#^ITEM#^ELEMENT NAME
S1 ;;1^60^EI^R^^^01206^Role Instance ID
S2 ;;2^2^ID^R^^0287^00816^Action Code
S3 ;;3^80^CE^R^^^01197^Role
S4 ;;4^80^XCN^R^^^01198^Role Person
S5 ;;5^26^TS^O^^^01199^Role Begin Date/Time
S6 ;;6^26^TS^O^^^01200^Role End Date/Time
S7 ;;7^80^CE^O^^^01201^Role Duration
S8 ;;8^80^CE^O^^^01205^Role Action Reason
