source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLRO1.m@ 1438

Last change on this file since 1438 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1VAFHLRO1 ;BP/JRP - UTILITIES FOR BUILDING HL7 ROLE SEGMENT;11/18/1997
2 ;;5.3;Registration;**160**;Aug 13, 1993
3 ;
4 ;
5FIXLEN(INARR,OUTARR,MAXLEN,WORKSUB) ;Fixed length copy/collapse
6 ;
7 ;Input : INARR - Input array (full global reference)
8 ; OUTARR - Output array (full global reference)
9 ; MAXLEN - Maximum length (defaults to 245)
10 ; WORKSUB - Subscript [in OUTARR] to begin from (defaults to 0)
11 ;Output : None
12 ; INARR() will be collapsed into OUTARR()
13 ;Notes : Validity and existance of input is assumed
14 ; : OUTARR() is not initialized (i.e. KILLed) on input
15 ; : Sample input & output with maximum length of 4
16 ; INARR(1)=12345 OUTARR(0)=1234
17 ; INARR(1,2)=ABCD OUTARR(1)=5ABC
18 ; INARR(2)=567 OUTARR(2)=D567
19 ;
20 ;
21 S MAXLEN=$G(MAXLEN)
22 S:(MAXLEN<1) MAXLEN=245
23 S WORKSUB=$G(WORKSUB)
24 S:(WORKSUB<1) WORKSUB=0
25 ;Declare variables
26 N ROOT,VALUE,RESULT
27 ;Declare variables for recursive portion of call
28 N LENVAL,LENRES,LEN,LENOVR
29 ;Remember root of INARR
30 S ROOT=$$OREF^DILF(INARR)
31 ;Work down INARR
32 S RESULT=""
33 F S INARR=$Q(@INARR) Q:((INARR="")!(INARR'[ROOT)) D
34 .;Grab value to append
35 .S VALUE=$G(@INARR)
36 .;Recusively do fix length copy/collapse
37 .D FIXLEN1
38 ;If anything still left in RESULT, put into OUTARR()
39 S:(RESULT'="") @OUTARR@(WORKSUB)=RESULT
40 ;Done
41 Q
42 ;
43FIXLEN1 ;Recursive portion of FIXLEN
44 ;
45 ;Input : VALUE - Value to append to RESULT
46 ; RESULT - Working & resulting value
47 ; OUTARR - Array to place max length results into (full global)
48 ; WORKSUB - Working subscript in OUTARR (where to put results)
49 ; MAXLEN - Maximum length for RESULT
50 ;Output : None
51 ; If max length was exceeded, then OUTARR(WORKSUB) will contain
52 ; the leading portion of appending, WORKSUB will be incremented
53 ; by 1, and RESULT will contain what was left. If max length
54 ; was not exceeded, then VALUE will be appended to RESULT and
55 ; OUTARR(WORKSUB) will be left unchanged.
56 ;Notes : Validity and existance of input is assumed
57 ; : Declarations done in FIXLEN
58 ; : VALUE may be modified by this call
59 ;
60 ;VALUE is null - done
61 Q:(VALUE="")
62 ;Get lengths of VAL & RES
63 S LENVAL=$L(VALUE)
64 S LENRES=$L(RESULT)
65 ;Determine what resulting length will be
66 S LEN=LENRES+LENVAL
67 ;Max length will not be exceeded - append and quit
68 I (LEN<MAXLEN) S RESULT=RESULT_VALUE Q
69 I (LEN=MAXLEN) S RESULT=RESULT_VALUE Q
70 ;Determine exceeding length
71 S LENOVR=LEN-MAXLEN
72 ;Put non-exceeding portion into output array
73 S @OUTARR@(WORKSUB)=RESULT_$E(VALUE,1,(LENVAL-LENOVR))
74 ;Increment working subscript
75 S WORKSUB=WORKSUB+1
76 ;Put exceeding portion into RESULT
77 ; Use recursion to account for further exceeding
78 S RESULT=""
79 S VALUE=$E(VALUE,((LENVAL-LENOVR)+1),LENVAL)
80 D FIXLEN1
81 ;Done
82 Q
83 ;
84GETATT(SEQ) ;Get element attributes
85 ;
86 ;Input : SEQ - Sequence number
87 ;Output : Role segment attributes (as defined by HL7 standard)
88 ; SEQ^LEN^DT^OPT^RP/#^TBL#^ITEM#^ELEMENT NAME
89 ;Notes : Null is returned on bad input
90 ;
91 ;Get/return attributes
92 S SEQ="S"_$G(SEQ)
93 Q $P($T(@SEQ),";;",2,999)
94 ;
95SEQREQ(SEQ) ;Required element ?
96 ;
97 ;Input : SEQ - Sequence number
98 ;Output : 1 = Yes 0 = No
99 ;Notes : 0 (no) is returned on bad input
100 ;
101 ;Declare variables
102 N TMP
103 ;Get attributes
104 S TMP=$$GETATT($G(SEQ))
105 ;Required/optional attribute lists required
106 Q:($P(TMP,"^",4)="R") 1
107 ;Optional
108 Q 0
109 ;
110ERROR(SEQ,OUTARR,ERROR) ;Add error node to output array
111 ;
112 ;Input : SEQ - Sequence number
113 ; OUTARR - Output array
114 ; ERROR - Error text to include
115 ;Output : None
116 ; Required Element
117 ; OUTARR("ERROR",SEQ,x) = Error text
118 ; Optional Element
119 ; OUTARR("WARNING",SEQ,x) = Error text
120 ;Notes : Input error text (ERROR) will be appended to text stating
121 ; whether element is required/optional and the element name
122 ;
123 N ATTRIB,REQUIRED,ELEMENT,TEXT
124 ;Get attributes
125 S ATTRIB=$$GETATT($G(SEQ))
126 ;Required/Optional
127 S REQUIRED=0
128 S:($P(ATTRIB,"^",4)="R") REQUIRED=1
129 ;Element name
130 S ELEMENT=$P(ATTRIB,"^",8)
131 S:(ELEMENT="") ELEMENT="Unknown (seq #"_SEQ_")"
132 ;Build blanket error text
133 S TEXT=$S(REQUIRED:"Required",1:"Optional")
134 S TEXT=TEXT_" data element '"_ELEMENT_"'"
135 ;Append input error text (if present)
136 S:($G(ERROR)'="") TEXT=TEXT_" "_ERROR
137 ;Use WARNING node for optional element & ERROR node for required
138 S:('REQUIRED) OUTARR=$NA(@OUTARR@("WARNING"))
139 S:(REQUIRED) OUTARR=$NA(@OUTARR@("ERROR"))
140 ;Get next subscript in ouput array
141 S ATTRIB=1+$O(@OUTARR@(SEQ,""),-1)
142 ;Place error text into output array
143 S @OUTARR@(SEQ,ATTRIB)=TEXT
144 ;Done
145 Q
146 ;
147 ;
148 ;Role segment attributes (as defined by HL7 standard)
149ATTRIB ;;SEQ^LEN^DT^OPT^RP/#^TBL#^ITEM#^ELEMENT NAME
150S1 ;;1^60^EI^R^^^01206^Role Instance ID
151S2 ;;2^2^ID^R^^0287^00816^Action Code
152S3 ;;3^80^CE^R^^^01197^Role
153S4 ;;4^80^XCN^R^^^01198^Role Person
154S5 ;;5^26^TS^O^^^01199^Role Begin Date/Time
155S6 ;;6^26^TS^O^^^01200^Role End Date/Time
156S7 ;;7^80^CE^O^^^01201^Role Duration
157S8 ;;8^80^CE^O^^^01205^Role Action Reason
Note: See TracBrowser for help on using the repository browser.