Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAFHLRO1

VAFHLRO1.m

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