source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSUTL.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.1 KB
Line 
1HLCSUTL ;ALB/MTC - CS Utility Routines ;05/31/2000 13:34
2 ;;1.6;HEALTH LEVEL SEVEN;**2,19,58,64,65**;Oct 13, 1995
3 ;
4 Q
5 ;
6READ(HLDHANG,HLDBSIZE,HLTRM) ; This function will perform a read on the device and
7 ; return the characters read and the termination character.
8 ;
9 ; INPUT : HLDHANG - TimeOut for read
10 ; HLDBSIZE- Block Size for read
11 ; HLTRM - Passed by reference to return termination char
12 ; OUTPUT: <Data> - Ok
13 ; -1^TIMEOUT : fails
14 ;
15 N RESULT,X,Y
16 ;
17 K HLTOUT
18 ;-- do read
19 U IO R X#HLDBSIZE:HLDHANG I '$T S RESULT="-1^TIMEOUT" G READQ
20 X ^%ZOSF("TRMRD") S HLTRM=Y
21 S RESULT=X
22 ;
23READQ Q RESULT
24 ;
25NEXTLINE(LL0,LL1,LINE,ARR,QUE) ; This function will return the next line from the
26 ; Logical Link file #870 specified by LL0 and the position in the queue
27 ; specified by QUE at the position LL1. This function will return the
28 ; line in the array specifed by ARR. And the position in the WP
29 ; field where the last part of the segment was found.
30 ; Lastly a <CR> will be appended to the end of the segment
31 ;
32 ; INPUT :
33 ; LL0 - IFN of logical link
34 ; LL1 - Position in QUE to begin search for next line
35 ; LINE- Last line position, "" will return first line
36 ; ARR - Array to store next line. The output will be in the
37 ; following format ARR(1), ARR(2)
38 ; QUE - Will specify "IN" or "OUT" queue to pull data from
39 ;
40 ; OUTPUT:
41 ; ARR - As specified above
42 ; RESULT - Position last segment was found or "" if no line
43 ; was found.
44 ;
45 ;
46 N RESULT,HLQUE,X,I
47 S RESULT="",HLQUE=$S(QUE="IN":1,QUE="OUT":2,1:"")
48 ;-- start looking for next line
49 S X=+LINE,I=0 F S X=$O(^HLCS(870,LL0,HLQUE,LL1,1,X)) Q:'X D I $G(^HLCS(870,LL0,HLQUE,LL1,1,X,0))="" S RESULT=X,@ARR@(I)=@ARR@(I)_$C(13) Q
50 . I $D(^HLCS(870,LL0,HLQUE,LL1,1,X,0)),^(0)'="" S I=I+1,@ARR@(I)=$G(^HLCS(870,LL0,HLQUE,LL1,1,X,0))
51 ;
52 Q RESULT
53 ;
54FLD(NODE,FLD) ;This function will return the value for the field
55 ;INPUT: NODE=HLNODE from the HLNEXT call, passed by reference
56 ; FLD=field position in segment
57 ; HL("FS") must be defined
58 ;OUTPUT: value for the field in this segment
59 Q:$G(HL("FS"))=""!($G(NODE)="")!('$G(FLD)) ""
60 N I,L,L1,X,Y
61 S NODE(0)=NODE,L=0,Y=1,X=""
62 ;Y=begining piece of each node, L1=number of pieces in each node
63 ;L=last piece in each node, quit when last piece is greater than FLD
64 F I=0:1 Q:'$D(NODE(I)) S L1=$L(NODE(I),HL("FS")),L=L1+Y-1 D Q:Y>FLD
65 . ;if FLD is less than last piece, this node has field you want
66 . S:FLD'>L X=X_$P(NODE(I),HL("FS"),(FLD-Y+1))
67 . S Y=L
68 K NODE(0)
69 Q X
70 ;
71CHKSUM(HLTEXT) ; This function will return the checksum for the segment
72 ; contained in the array ARR. If no checksum can be calculated an -1
73 ; will be returned.
74 ;
75 ; INPUT - HLTEXT the name of the array to be used in the calulation
76 ; of the checksum. The format is ARR(1,N),...ARR(M,N)
77 ; OUTPUT - Decimal checksum %ZOSF("LPC")^Lenght of segment
78 ;
79 N RESULT,LEN,X,X1,X2,X3,Y,I
80 S RESULT="",LEN=0,X1=0
81 ;
82 F S X1=$O(@HLTEXT@(X1)) Q:'X1 S X=@HLTEXT@(X1),X2=$D(@HLTEXT@(X1)),LEN=LEN+$L(X) D
83 . X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
84 . I X2=11 S X3=0 F S X3=$O(@HLTEXT@(X1,X3)) Q:'X3 D
85 .. S X=@HLTEXT@(X1,X3),LEN=LEN+$L(X) X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
86 ;
87 S X=RESULT X ^%ZOSF("LPC") S RESULT=Y
88 Q RESULT_"^"_LEN
89 ;
90CHKSUM2(HLTEXT) ; *** Add in <CR> *** This function will return the checksum for the segment
91 ; contained in the array ARR. If no checksum can be calculated an -1
92 ; will be returned.
93 ;
94 ; INPUT - HLTEXT the name of the array to be used in the calulation
95 ; of the checksum. The format is ARR(1,N),...ARR(M,N)
96 ; OUTPUT - Decimal checksum %ZOSF("LPC")^Lenght of segment
97 ;
98 N RESULT,LEN,X,X1,X2,X3,Y,I
99 S RESULT="",LEN=0,X1=0
100 ;
101 F S X1=$O(@HLTEXT@(X1)) Q:'X1 S X=@HLTEXT@(X1),X2=$D(@HLTEXT@(X1)),LEN=LEN+$L(X) D
102 . X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
103 . I X2=1 S RESULT=RESULT_$C(13),LEN=LEN+1 Q
104 . I X2=11 S X3=0 F S X3=$O(@HLTEXT@(X1,X3)) Q:'X3 D
105 .. S X=@HLTEXT@(X1,X3),LEN=LEN+$L(X) X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
106 ..I $O(@HLTEXT@(X1,X3))="" S RESULT=RESULT_$C(13),LEN=LEN+1
107 ;
108 S X=RESULT X ^%ZOSF("LPC") S RESULT=Y
109 Q RESULT_"^"_LEN
110 ;
111APPEND(HLTEXT,LL0,LL1) ; This function will append the data contained in
112 ; the HLTEXT array into the IN queue multiple (LL1) of the Logical
113 ; Link (LL0) file 870.
114 ; INPUT : HLTEXT - Array containing text to append
115 ; LL0 - IEN of File 870
116 ; LL1 - IEN of IN queue multiple
117 ;
118 N HLI,X,X1,X2,X3
119 S X=""
120 S HLI=$P($G(^HLCS(870,LL0,1,LL1,1,0)),U,3)
121 S:'HLI HLI=0
122 F S X=$O(@HLTEXT@(X)) Q:'X S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)=@HLTEXT@(X),X2=$D(@HLTEXT@(X)) D
123 . I X2=11 S ^HLCS(870,LL0,1,LL1,2,HLI,0)="" S X3=0 F S X3=$O(@HLTEXT@(X,X3)) Q:'X3 D
124 .. S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)=$G(@HLTEXT@(X,X3))
125 . S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)="" Q
126 ;
127 ;-- update 0 node
128 S ^HLCS(870,LL0,1,LL1,1,0)="^^"_HLI_"^"_HLI_"^"_DT_"^"
129 Q
130 ;
131HLNEXT ;-- This routine is used to return the next segment from file 772
132 ; during processing of an inbound message. The following variables
133 ; are used for the processing.
134 ; HLMTIEN - Entry in 772 where message is
135 ; HLQUIT - Curent ien of "IN" wp field
136 ; HLNODE - Data is returned in HLNODE=Segment and HLNODE(n) if
137 ; segmemt is greater than 245 chars.
138 ;
139 K HLNODE
140 N HLI,HLDONE,HLX
141 S HLNODE="",HLDONE=0
142 I HLQUIT="" S HLQUIT=0
143 ;HLMTIEN is undef, no response to process
144 I '$G(HLMTIEN) S HLQUIT=0 Q
145 ;first time, check if new format
146 I '$D(HLDONE1) D Q:HLQUIT
147 . S HLX=$O(^HLMA("B",HLMTIEN,0))
148 . ;old format, set HLDONE1 so we won't come here again
149 . I 'HLX S HLDONE1=0 Q
150 . ;already got header, reset HLQUIT for text
151 . I HLQUIT S (HLDONE1,HLQUIT)=0 Q
152 . ;new format, get header in 773
153 . S HLQUIT=$O(^HLMA(HLX,"MSH",HLQUIT))
154 . ;there is no header
155 . I 'HLQUIT S (HLDONE1,HLQUIT)=0 Q
156 . S HLNODE=$G(^HLMA(HLX,"MSH",HLQUIT,0)),HLI=0
157 . F S HLQUIT=$O(^HLMA(HLX,"MSH",HLQUIT)) Q:'HLQUIT D Q:HLDONE
158 .. I ^HLMA(HLX,"MSH",HLQUIT,0)="" S HLDONE=1 Q
159 .. S HLI=HLI+1,HLNODE(HLI)=$G(^HLMA(HLX,"MSH",HLQUIT,0)) Q
160 . S HLQUIT=1 Q
161 S HLQUIT=$O(^HL(772,HLMTIEN,"IN",HLQUIT))
162 I HLQUIT D Q
163 . S HLNODE=$G(^HL(772,HLMTIEN,"IN",HLQUIT,0)),HLI=0
164 . F S HLQUIT=$O(^HL(772,HLMTIEN,"IN",HLQUIT)) Q:'HLQUIT D Q:HLDONE
165 .. I ^HL(772,HLMTIEN,"IN",HLQUIT,0)="" S HLDONE=1 Q
166 .. S HLI=HLI+1,HLNODE(HLI)=$G(^HL(772,HLMTIEN,"IN",HLQUIT,0)) Q
167 ;no more nodes, kill flag and quit
168 K HLDONE1 Q
169 ;
170MSGLINE(HLMID) ;return the number of lines in a message, TCP type only
171 ;input: HLMID=message id
172 Q:$G(HLMID)="" 0
173 N HLCNT,HLIENS,HLIEN
174 ;can't find message
175 S HLIENS=$O(^HLMA("C",HLMID,0)) Q:'HLIENS 0
176 S HLIEN=+$G(^HLMA(HLIENS,0)) Q:'HLIEN 0
177 S HLCNT=$P($G(^HLMA(HLIENS,"MSH",0)),U,4)+$P($G(^HL(772,HLIEN,"IN",0)),U,4)
178 Q HLCNT
179 ;
180MSGSIZE(HLIENS) ;return the number of characters in a message, TCP type only
181 ;input: HLIENS= ien in file 773
182 Q:'$G(HLIENS) 0
183 N HLCNT,HLI,HLIEN,HLZ
184 ;HLIEN=ien in file 772, message text. Blank lines are CR, add 1
185 Q:'$G(^HLMA(HLIENS,0)) 0 S HLIEN=+(^(0)) Q:'HLIEN 0
186 S (HLCNT,HLI,HLZ)=0
187 ;get header
188 F S HLI=$O(^HLMA(HLIENS,"MSH",HLI)) Q:'HLI S HLZ=$L($G(^(HLI,0))),HLCNT=HLCNT+$S(HLZ:HLZ,1:1)
189 ;if last line of header wasn't blank, add 1 for CR
190 S:HLZ HLCNT=HLCNT+1
191 ;get body
192 S HLI=0 F S HLI=$O(^HL(772,HLIEN,"IN",HLI)) Q:'HLI S HLZ=$L($G(^(HLI,0))),HLCNT=HLCNT+$S(HLZ:HLZ,1:1)
193 Q HLCNT
194 ;
195MSG(HLMID,HLREST) ;return the message text in the reference HLREST
196 ;only for TCP type messages
197 ;input: HLMID=message id, HLREST=closed local or global reference
198 ;to place message text
199 ;output: return 1 for success and 0 if message doesn't exist
200 Q:$G(HLMID)=""!($G(HLREST)="") 0
201 N HLCNT,HLI,HLIENS,HLIEN,HLZ
202 ;can't find message
203 S HLIENS=$O(^HLMA("C",HLMID,0)) Q:'HLIENS 0
204 S HLIEN=+$G(^HLMA(HLIENS,0)) Q:'HLIEN 0
205 ;RESULT must be close reference
206 D I '$D(HLREST) Q 0
207 . Q:HLREST'["("
208 . I $E(HLREST,$L(HLREST))=")",$F(HLREST,")")>($F(HLREST,"(")+1) Q
209 . K HLREST
210 S (HLCNT,HLI)=0,HLZ=""
211 ;get header
212 F S HLI=$O(^HLMA(HLIENS,"MSH",HLI)) Q:'HLI S HLCNT=HLCNT+1,(HLZ,@HLREST@(HLCNT))=$G(^(HLI,0))
213 S:HLZ'="" HLCNT=HLCNT+1,@HLREST@(HLCNT)=""
214 ;get body
215 S HLI=0 F S HLI=$O(^HL(772,HLIEN,"IN",HLI)) Q:'HLI S HLCNT=HLCNT+1,@HLREST@(HLCNT)=$G(^(HLI,0))
216 Q 1
217
Note: See TracBrowser for help on using the repository browser.