Changeset 623 for WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m
r613 r623 1 HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/15/08 11:11 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122,140**;OCT 13,1995;Build 5 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ;Receiver 5 ;connection is initiated by sender and listener accepts connection 6 ;and calls this routine 7 ; 8 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1" 9 N HLMIEN,HLASTMSG 10 ; 11 ; patch HL*1.6*140, save IO 12 S HLTCPORT("IO")=IO ;RWF 13 ; patch HL*1.6*122 start 14 ; variable to replace ^TMP 15 N HLTMBUF 16 ; 17 ; for HL7 application proxy user 18 ;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed 19 N HLDUZ 20 S HLDUZ=+$G(DUZ) 21 ; 22 D MON^HLCSTCP("Open") 23 ; K ^TMP("HLCSTCP",$J,0) 24 S HLMIEN=0,HLASTMSG="" 25 ; 26 ; patch HL*1.6*122 TEST v2: DUZ code removed 27 ; set DUZ for application proxy user 28 ;; D PROXY^HLCSTCP4 29 ; 30 F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3 31 . ; clean variables 32 . D CLEANVAR^HLCSTCP4 33 . ; patch HL*1.6*140, restore the saved IO 34 . S IO=HLTCPORT("IO") ;RWF 35 . S HLMIEN=$$READ 36 . Q:'HLMIEN 37 . ; 38 . ; patch HL*1.6*122 TEST v2: DUZ code removed 39 . ; DUZ comparison/reset for application proxy user 40 . ;; D HLDUZ^HLCSTCP4 41 . D HLDUZ2^HLCSTCP4 42 . ; protect HLDUZ 43 . N HLDUZ 44 . D PROCESS 45 ; patch HL*1.6*122 end 46 Q 47 ; 48 PROCESS ;check message and reply 49 ;HLDP=LL in 870 50 N HLTCP,HLTCPI,HLTCPO 51 S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN 52 ;update monitor, msg. received 53 D LLCNT^HLCSTCP(HLDP,1) 54 D NEW^HLTP3(HLMIEN) 55 ;I IO'=HLTCPORT("IO") D ^%ZTER ;RWF 56 ;update monitor, msg. processed 57 D LLCNT^HLCSTCP(HLDP,2) 58 Q 59 ; 60 READ() ;read 1 message, returns ien in 773^ien in 772 for message 61 D MON^HLCSTCP("Reading") 62 N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X 63 ;HLDSTRT=start char., HLDEND=end char., HLRS=record separator 64 S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13) 65 ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772 66 ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack 67 ; HL*1.6*122 start 68 ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK 69 S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK 70 N HLBUFF,HLXX,MAXWAIT 71 ; based on patch 132 for readtime 72 S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD) 73 S HLRS("START-FLAG")=0 74 S HLTMBUF(0)="" 75 ; variable used to store data in HLBUFF 76 S HLX(1)=$G(HLTMBUF(1)) 77 S HLTMBUF(1)="" 78 S HLBUFF("START")=0 79 S HLBUFF("END")=0 80 I (HLX]"")!(HLX(1)]"") D 81 . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D 82 .. S HLBUFF("START")=1 83 . I (HLX[HLDEND)!(HLX(1)[HLDEND) D 84 .. S HLBUFF("END")=1 85 F D RDBLK Q:HLRDOUT 86 ;**132** 87 ;switch to null device if opened to prevent 'leakage' 88 I $G(IO(0))]"",IO(0)'=IO U IO(0) 89 ; 90 ;save any excess for next time 91 S:HLX]"" HLTMBUF(0)=HLX 92 S:HLX(1)]"" HLTMBUF(1)=HLX(1) 93 I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0 94 Q HLIND1 95 ; 96 RDBLK ; 97 ; initialize 98 S HLBUFF="" 99 ; 100 ;S HLDB=HLDBSIZE-$L(HLX) 101 ; store the total length of HLX and HLX(1) in HLDB(1) 102 S HLDB(1)=$L(HLX)+$L(HLX(1)) 103 ; 104 ;**132 ** 105 ;U IO R X#HLDB:HLDREAD 106 ; U IO R X#HLDB:MAXWAIT 107 ; 108 ; remove the readcount to speedup GT.M 109 U IO 110 R:(HLDB(1)<HLDBSIZE) HLBUFF:MAXWAIT 111 ; 112 I HLBUFF]"" D 113 . I HLBUFF[HLDSTRT,(HLBUFF("START")=0) D 114 .. ; remove the extraneous text prefixing the "START" char 115 .. I $P(HLBUFF,HLDSTRT)]"" S HLBUFF=HLDSTRT_$P(HLBUFF,HLDSTRT,2,99) 116 .. S HLBUFF("START")=1 117 . ; 118 . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1 119 ; detect disconnect for GT.M 120 I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=",UREAD," 121 ; timedout, <clean up>, quit 122 ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q 123 ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q 124 ; patch HL*1.6*140 125 ; I '$T,HLBUFF="",HLX="",HLX(1)="" D Q 126 I HLBUFF="",HLX="",HLX(1)="" D Q 127 . D:('HLHDR)&('HLIND1) CLEAN 128 ;add incoming line to what wasn't processed in last read 129 ;S HLX=$G(HLX)_X 130 ; get block of characters from read buffer HLBUFF 131 ; every 'for-loop' deal with one read at most, and one message at most 132 ; if HLX is not empty, loop continues even no data is read 133 ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done 134 ; quit, when HLRDOUT is set to 1, means one message is encountered 135 ; an "end" 136 ; F D Q:HLXX=""!(HLRDOUT) 137 F D Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)="")) 138 . ; 139 . ; if HLX(1) is not empty 140 . I HLX(1)]"" D 141 .. ; hldb(2) is the number of characters extracted from hlx(1) 142 .. ; to be concatenated with hlx 143 .. S HLDB(2)=HLDBSIZE-$L(HLX) 144 .. ; hlx(2) stores the first hldb(2) characters extracted 145 .. ; from hlx(1) 146 .. S HLX(2)=$E(HLX(1),1,HLDB(2)) 147 .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1))) 148 .. S HLX=$G(HLX)_HLX(2) 149 . ; 150 . ; if HLX(1) is empty, and HLBUFF contains data 151 . ; all the data in hlx(1) need to be extracted first 152 . I HLX(1)="",HLBUFF]"" D 153 .. S HLDB=HLDBSIZE-$L(HLX) 154 .. S HLXX=$E(HLBUFF,1,HLDB) 155 .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF)) 156 .. S HLX=$G(HLX)_HLXX 157 . ; quit when HLX is empty 158 . Q:(HLX="") 159 . ; ** 132 ** 160 . ; if no segment end, HLX not full, go back for more 161 . I $L(HLX)<HLDBSIZE,HLX'[HLRS,HLX'[HLDEND Q 162 . ;add incoming line to what wasn't processed 163 . D RDBLK2 164 ; 165 ; it is possible one message is encountered an "end" and other 166 ; messages left in buffer,HLBUFF, save it in HLX for next run 167 I HLBUFF]"" D 168 . ; variable HLBUFF may remain data with size more than HLDBSIZE 169 . ; variable HLBUFF is not empty, only if the total length of 170 . ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be 171 . ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed 172 . ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error 173 . S HLX(1)=$G(HLX(1))_HLBUFF 174 . S HLBUFF="" 175 Q 176 ; 177 RDBLK2 ;data stream: <sb>dddd<cr><eb><cr> 178 ; HL*1.6*122 end 179 ; look for segment= <CR> 180 F Q:HLX'[HLRS D Q:HLRDOUT 181 . ; Get the first piece, save the rest of the line 182 . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999) 183 . ; check for start block, Quit if no ien 184 . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q 185 .. S HLRS("START-FLAG")=1 ; HL*1.6*122 186 .. D:HLMSG(HLINE,0)[HLDSTRT 187 ... S X=$L(HLMSG(HLINE,0),HLDSTRT) 188 ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X) 189 ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2) 190 ... D RESET:(HLINE>1) 191 .. ; 192 .. ; patch HL*1.6*122 193 .. ; if the first line less than 10 characters 194 .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D 195 ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10) 196 ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999) 197 .. ; 198 .. ;ping message 199 .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q 200 .. ; get next ien to store 201 .. D MIEN^HLCSTCP4 202 .. K HLMSG 203 .. S (HLINE,HLHDR)=0 204 . ; check for end block; <eb><cr> 205 . I HLMSG(HLINE,0)[HLDEND D 206 .. ; patch HL*1.6*122 start 207 .. ;no msg. ien 208 .. ; Q:'HLIND1 209 .. I 'HLIND1 D CLEAN Q 210 .. ; Kill just the last line if no data before HLDEND 211 .. I $P(HLMSG(HLINE,0),HLDEND)']"" D 212 ... K HLMSG(HLINE,0) S HLINE=HLINE-1 213 .. E S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND) 214 .. ; patch HL*1.6*122 end 215 .. ; 216 .. ; move into 772 217 .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")") 218 .. ;mark that end block has been received 219 .. ;HLIND1=ien in 773^ien in 772^1 if end block was received 220 .. S $P(HLIND1,U,3)=1 221 .. S HLBUFF("HLIND1")=HLIND1 222 .. ;reset variables for next message 223 .. D CLEAN 224 . ;add blank line for carriage return 225 . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)="" 226 Q:HLRDOUT 227 ;If the line is long and no <CR> move it into the array. 228 I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q 229 . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX="" 230 ;have start block but no record separator 231 I HLX[HLDSTRT D Q 232 . ;check for more than 1 start block 233 . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X) 234 . ; 235 . ; patch HL*1.6*122 236 . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 237 . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 238 . ; 239 . D RESET:(HLHDR&(HLINE>1)) 240 ;if no ien, reset 241 ; patch HL*1.6*122 242 ; I 'HLIND1 D CLEAN Q 243 I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q 244 ; big message-merge from local to global every 100 lines 245 I (HLINE-$O(HLMSG(0)))>100 D 246 . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG 247 . ; reset working array 248 . K HLMSG 249 Q 250 ; 251 SAVE(SRC,DEST) ;save into global & set top node 252 ;SRC=source array (passed by ref.), DEST=destination global 253 ; 254 ; patch HL*1.6*122: MPI-client/server 255 I DEST["HLMA" D 256 . F L +^HLMA(+HLIND1):10 Q:$T H 1 257 E D 258 . F L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T H 1 259 ; 260 M @DEST=SRC 261 S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^" 262 ; 263 I DEST["HLMA" L -^HLMA(+HLIND1) 264 E L -^HL(772,+$P(HLIND1,U,2)) 265 ; 266 Q 267 ; 268 DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files. 269 N DIK,DA 270 S DA=+HLMAMT,DIK="^HLMA(" 271 D ^DIK 272 S DA=$P(HLMAMT,U,2),DIK="^HL(772," 273 D ^DIK 274 Q 275 PING ;process PING message 276 S X=HLMSG(1,0) 277 ; patch HL*1.6*140, flush character- HLTCPLNK("IOF") 278 ; I X[HLDEND U IO W X,! D 279 I X[HLDEND U IO W X,HLTCPLNK("IOF") D 280 . ; switch to null device if opened to prevent 'leakage' 281 . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0) 282 CLEAN ;reset var. for next message 283 K HLMSG 284 S HLINE=0,HLRDOUT=1 285 Q 286 ; 287 ERROR ; Error trap for disconnect error and return back to the read loop. 288 ; patch HL*1.6*122 289 ; move to routine HLCSTCP4 (splitted-size over 10000) 290 D ERROR1^HLCSTCP4 291 Q 292 ; 293 CC(X) ;cleanup and close 294 D MON^HLCSTCP(X) 295 H 2 296 Q 297 RESET ;reset info as a result of no end block 298 N % 299 S HLMSG(1,0)=HLMSG(HLINE,0) 300 F %=2:1:HLINE K HLMSG(%,0) 301 S HLINE=1 302 Q 1 HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;7/28/07 08:58 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ;Receiver 5 ;connection is initiated by sender and listener accepts connection 6 ;and calls this routine 7 ; 8 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1" 9 N HLMIEN,HLASTMSG 10 ; 11 ; patch HL*1.6*122 start 12 ; variable to replace ^TMP 13 N HLTMBUF 14 ; for HL7 application proxy user 15 N HLDUZ,DUZ 16 D MON^HLCSTCP("Open") 17 ; K ^TMP("HLCSTCP",$J,0) 18 S HLMIEN=0,HLASTMSG="" 19 ; set DUZ for application proxy user 20 D PROXY^HLCSTCP4 21 F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3 22 . ; clean variables 23 . D CLEANVAR^HLCSTCP4 24 . S HLMIEN=$$READ 25 . Q:'HLMIEN 26 . ; DUZ comparison/reset for application proxy user 27 . D HLDUZ^HLCSTCP4 28 . ; protect HLDUZ 29 . N HLDUZ 30 . D PROCESS 31 ; patch HL*1.6*122 end 32 Q 33 ; 34 PROCESS ;check message and reply 35 ;HLDP=LL in 870 36 N HLTCP,HLTCPI,HLTCPO 37 S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN 38 ;update monitor, msg. received 39 D LLCNT^HLCSTCP(HLDP,1) 40 D NEW^HLTP3(HLMIEN) 41 ;update monitor, msg. processed 42 D LLCNT^HLCSTCP(HLDP,2) 43 Q 44 ; 45 READ() ;read 1 message, returns ien in 773^ien in 772 for message 46 D MON^HLCSTCP("Reading") 47 N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X 48 ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator 49 S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13) 50 ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772 51 ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack 52 ; HL*1.6*122 start 53 ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK 54 S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK 55 N HLBUFF,HLXX,MAXWAIT 56 ; based on patch 132 for readtime 57 S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD) 58 S HLRS("START-FLAG")=0 59 S HLTMBUF(0)="" 60 ; variable used to store data in HLBUFF 61 S HLX(1)=$G(HLTMBUF(1)) 62 S HLTMBUF(1)="" 63 S HLBUFF("START")=0 64 S HLBUFF("END")=0 65 I (HLX]"")!(HLX(1)]"") D 66 . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D 67 .. S HLBUFF("START")=1 68 . I (HLX[HLDEND)!(HLX(1)[HLDEND) D 69 .. S HLBUFF("END")=1 70 F D RDBLK Q:HLRDOUT 71 ;**132** 72 ;switch to null device if opened to prevent 'leakage' 73 I $G(IO(0))]"",IO(0)'=IO U IO(0) 74 ; 75 ;save any excess for next time 76 S:HLX]"" HLTMBUF(0)=HLX 77 S:HLX(1)]"" HLTMBUF(1)=HLX(1) 78 I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0 79 Q HLIND1 80 ; 81 RDBLK ; 82 ; initialize 83 S HLBUFF="" 84 ; 85 ;S HLDB=HLDBSIZE-$L(HLX) 86 ; store the total length of HLX and HLX(1) in HLDB(1) 87 S HLDB(1)=$L(HLX)+$L(HLX(1)) 88 ; 89 ;**132 ** 90 ;U IO R X#HLDB:HLDREAD 91 ; U IO R X#HLDB:MAXWAIT 92 ; 93 ; remove the readcount to speedup GT.M 94 U IO 95 R:(HLDB(1)<HLDBSIZE) HLBUFF:MAXWAIT 96 I HLBUFF]"" D 97 . I HLBUFF[HLDSTRT,(HLBUFF("START")=0) D 98 .. ; remove the extraneous text prefixing the "START" char 99 .. I $P(HLBUFF,HLDSTRT)]"" S HLBUFF=HLDSTRT_$P(HLBUFF,HLDSTRT,2,99) 100 .. S HLBUFF("START")=1 101 . ; 102 . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1 103 ; detect disconnect for GT.M 104 I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE="" 105 ; timedout, <clean up>, quit 106 ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q 107 ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q 108 I '$T,HLBUFF="",HLX="",HLX(1)="" D Q 109 . D:('HLHDR)&('HLIND1) CLEAN 110 ;add incoming line to what wasn't processed in last read 111 ;S HLX=$G(HLX)_X 112 ; 113 ; get block of characters from read buffer HLBUFF 114 ; every 'for-loop' deal with one read at most, and one message at most 115 ; if HLX is not empty, loop continues even no data is read 116 ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done 117 ; quit, when HLRDOUT is set to 1, means one message is encountered 118 ; an "end" 119 ; F D Q:HLXX=""!(HLRDOUT) 120 F D Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)="")) 121 . ; 122 . ; if HLX(1) is not empty 123 . I HLX(1)]"" D 124 .. ; hldb(2) is the number of characters extracted from hlx(1) 125 .. ; to be concatenated with hlx 126 .. S HLDB(2)=HLDBSIZE-$L(HLX) 127 .. ; hlx(2) stores the first hldb(2) characters extracted 128 .. ; from hlx(1) 129 .. S HLX(2)=$E(HLX(1),1,HLDB(2)) 130 .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1))) 131 .. S HLX=$G(HLX)_HLX(2) 132 . ; 133 . ; if HLX(1) is empty, and HLBUFF contains data 134 . ; all the data in hlx(1) need to be extracted first 135 . I HLX(1)="",HLBUFF]"" D 136 .. S HLDB=HLDBSIZE-$L(HLX) 137 .. S HLXX=$E(HLBUFF,1,HLDB) 138 .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF)) 139 .. S HLX=$G(HLX)_HLXX 140 . ; quit when HLX is empty 141 . Q:(HLX="") 142 . ; ** 132 ** 143 . ; if no segment end, HLX not full, go back for more 144 . I $L(HLX)<HLDBSIZE,HLX'[HLRS,HLX'[HLDEND Q 145 . ;add incoming line to what wasn't processed 146 . D RDBLK2 147 ; 148 ; it is possible one message is encountered an "end" and other 149 ; messages left in buffer,HLBUFF, save it in HLX for next run 150 I HLBUFF]"" D 151 . ; variable HLBUFF may remain data with size more than HLDBSIZE 152 . ; variable HLBUFF is not empty, only if the total length of 153 . ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be 154 . ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed 155 . ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error 156 . S HLX(1)=$G(HLX(1))_HLBUFF 157 . S HLBUFF="" 158 Q 159 ; 160 RDBLK2 ;data stream: <sb>dddd<cr><eb><cr> 161 ; HL*1.6*122 end 162 ; look for segment= <CR> 163 F Q:HLX'[HLRS D Q:HLRDOUT 164 . ; Get the first piece, save the rest of the line 165 . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999) 166 . ; check for start block, Quit if no ien 167 . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q 168 .. S HLRS("START-FLAG")=1 ; HL*1.6*122 169 .. D:HLMSG(HLINE,0)[HLDSTRT 170 ... S X=$L(HLMSG(HLINE,0),HLDSTRT) 171 ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X) 172 ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2) 173 ... D RESET:(HLINE>1) 174 .. ; 175 .. ; patch HL*1.6*122 176 .. ; if the first line less than 10 characters 177 .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D 178 ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10) 179 ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999) 180 .. ; 181 .. ;ping message 182 .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q 183 .. ; get next ien to store 184 .. D MIEN^HLCSTCP4 185 .. K HLMSG 186 .. S (HLINE,HLHDR)=0 187 . ; check for end block; <eb><cr> 188 . I HLMSG(HLINE,0)[HLDEND D 189 .. ; patch HL*1.6*122 start 190 .. ;no msg. ien 191 .. ; Q:'HLIND1 192 .. I 'HLIND1 D CLEAN Q 193 .. ; Kill just the last line if no data before HLDEND 194 .. I $P(HLMSG(HLINE,0),HLDEND)']"" D 195 ... K HLMSG(HLINE,0) S HLINE=HLINE-1 196 .. E S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND) 197 .. ; patch HL*1.6*122 end 198 .. ; 199 .. ; move into 772 200 .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")") 201 .. ;mark that end block has been received 202 .. ;HLIND1=ien in 773^ien in 772^1 if end block was received 203 .. S $P(HLIND1,U,3)=1 204 .. S HLBUFF("HLIND1")=HLIND1 205 .. ;reset variables for next message 206 .. D CLEAN 207 . ;add blank line for carriage return 208 . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)="" 209 Q:HLRDOUT 210 ;If the line is long and no <CR> move it into the array. 211 I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q 212 . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX="" 213 ;have start block but no record seperator 214 I HLX[HLDSTRT D Q 215 . ;check for more than 1 start block 216 . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X) 217 . ; 218 . ; patch HL*1.6*122 219 . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 220 . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 221 . ; 222 . D RESET:(HLHDR&(HLINE>1)) 223 ;if no ien, reset 224 ; patch HL*1.6*122 225 ; I 'HLIND1 D CLEAN Q 226 I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q 227 ; big message-merge from local to global every 100 lines 228 I (HLINE-$O(HLMSG(0)))>100 D 229 . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG 230 . ; reset working array 231 . K HLMSG 232 Q 233 ; 234 SAVE(SRC,DEST) ;save into global & set top node 235 ;SRC=source array (passed by ref.), DEST=destination global 236 M @DEST=SRC 237 S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^" 238 Q 239 ; 240 DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files. 241 N DIK,DA 242 S DA=+HLMAMT,DIK="^HLMA(" 243 D ^DIK 244 S DA=$P(HLMAMT,U,2),DIK="^HL(772," 245 D ^DIK 246 Q 247 PING ;process PING message 248 S X=HLMSG(1,0) 249 I X[HLDEND U IO W X,! D 250 . ; switch to null device if opened to prevent 'leakage' 251 . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0) 252 CLEAN ;reset var. for next message 253 K HLMSG 254 S HLINE=0,HLRDOUT=1 255 Q 256 ; 257 ERROR ; Error trap for disconnect error and return back to the read loop. 258 S $ETRAP="D UNWIND^%ZTER" 259 I $$EC^%ZOSV["IOEOF" D UNWIND^%ZTER Q ;VOE change for GT.M 260 I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q 261 I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q 262 I $ECODE["UREAD" D UNWIND^%ZTER Q ; HL*1.6*122 GT.M 263 S HLCSOUT=1 D ^%ZTER,CC("Error") 264 D UNWIND^%ZTER 265 Q 266 ; 267 CC(X) ;cleanup and close 268 D MON^HLCSTCP(X) 269 H 2 270 Q 271 RESET ;reset info as a result of no end block 272 N % 273 S HLMSG(1,0)=HLMSG(HLINE,0) 274 F %=2:1:HLINE K HLMSG(%,0) 275 S HLINE=1 276 Q
Note:
See TracChangeset
for help on using the changeset viewer.
