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

HLCSUTL.m

Go to the documentation of this file.
  1. HLCSUTL ;ALB/MTC - CS Utility Routines ;06/03/2008 11:57
  1. ;;1.6;HEALTH LEVEL SEVEN;**2,19,58,64,65,142**;Oct 13, 1995;Build 17
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. READ(HLDHANG,HLDBSIZE,HLTRM) ; This function will perform a read on the device and
  1. ; return the characters read and the termination character.
  1. ;
  1. ; INPUT : HLDHANG - TimeOut for read
  1. ; HLDBSIZE- Block Size for read
  1. ; HLTRM - Passed by reference to return termination char
  1. ; OUTPUT: <Data> - Ok
  1. ; -1^TIMEOUT : fails
  1. ;
  1. N RESULT,X,Y
  1. ;
  1. K HLTOUT
  1. ;-- do read
  1. U IO R X#HLDBSIZE:HLDHANG I '$T S RESULT="-1^TIMEOUT" G READQ
  1. X ^%ZOSF("TRMRD") S HLTRM=Y
  1. S RESULT=X
  1. ;
  1. READQ Q RESULT
  1. ;
  1. NEXTLINE(LL0,LL1,LINE,ARR,QUE) ; This function will return the next line from the
  1. ; Logical Link file #870 specified by LL0 and the position in the queue
  1. ; specified by QUE at the position LL1. This function will return the
  1. ; line in the array specifed by ARR. And the position in the WP
  1. ; field where the last part of the segment was found.
  1. ; Lastly a <CR> will be appended to the end of the segment
  1. ;
  1. ; INPUT :
  1. ; LL0 - IFN of logical link
  1. ; LL1 - Position in QUE to begin search for next line
  1. ; LINE- Last line position, "" will return first line
  1. ; ARR - Array to store next line. The output will be in the
  1. ; following format ARR(1), ARR(2)
  1. ; QUE - Will specify "IN" or "OUT" queue to pull data from
  1. ;
  1. ; OUTPUT:
  1. ; ARR - As specified above
  1. ; RESULT - Position last segment was found or "" if no line
  1. ; was found.
  1. ;
  1. ;
  1. N RESULT,HLQUE,X,I
  1. S RESULT="",HLQUE=$S(QUE="IN":1,QUE="OUT":2,1:"")
  1. ;-- start looking for next line
  1. 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
  1. . 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))
  1. ;
  1. Q RESULT
  1. ;
  1. FLD(NODE,FLD) ;This function will return the value for the field
  1. ;INPUT: NODE=HLNODE from the HLNEXT call, passed by reference
  1. ; FLD=field position in segment
  1. ; HL("FS") must be defined
  1. ;OUTPUT: value for the field in this segment
  1. Q:$G(HL("FS"))=""!($G(NODE)="")!('$G(FLD)) ""
  1. N I,L,L1,X,Y
  1. S NODE(0)=NODE,L=0,Y=1,X=""
  1. ;Y=begining piece of each node, L1=number of pieces in each node
  1. ;L=last piece in each node, quit when last piece is greater than FLD
  1. F I=0:1 Q:'$D(NODE(I)) S L1=$L(NODE(I),HL("FS")),L=L1+Y-1 D Q:Y>FLD
  1. . ;if FLD is less than last piece, this node has field you want
  1. . S:FLD'>L X=X_$P(NODE(I),HL("FS"),(FLD-Y+1))
  1. . S Y=L
  1. K NODE(0)
  1. Q X
  1. ;
  1. CHKSUM(HLTEXT) ; This function will return the checksum for the segment
  1. ; contained in the array ARR. If no checksum can be calculated an -1
  1. ; will be returned.
  1. ;
  1. ; INPUT - HLTEXT the name of the array to be used in the calulation
  1. ; of the checksum. The format is ARR(1,N),...ARR(M,N)
  1. ; OUTPUT - Decimal checksum %ZOSF("LPC")^Lenght of segment
  1. ;
  1. N RESULT,LEN,X,X1,X2,X3,Y,I
  1. S RESULT="",LEN=0,X1=0
  1. ;
  1. F S X1=$O(@HLTEXT@(X1)) Q:'X1 S X=@HLTEXT@(X1),X2=$D(@HLTEXT@(X1)),LEN=LEN+$L(X) D
  1. . X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
  1. . I X2=11 S X3=0 F S X3=$O(@HLTEXT@(X1,X3)) Q:'X3 D
  1. .. S X=@HLTEXT@(X1,X3),LEN=LEN+$L(X) X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
  1. ;
  1. S X=RESULT X ^%ZOSF("LPC") S RESULT=Y
  1. Q RESULT_"^"_LEN
  1. ;
  1. CHKSUM2(HLTEXT) ; *** Add in <CR> *** This function will return the checksum for the segment
  1. ; contained in the array ARR. If no checksum can be calculated an -1
  1. ; will be returned.
  1. ;
  1. ; INPUT - HLTEXT the name of the array to be used in the calulation
  1. ; of the checksum. The format is ARR(1,N),...ARR(M,N)
  1. ; OUTPUT - Decimal checksum %ZOSF("LPC")^Lenght of segment
  1. ;
  1. N RESULT,LEN,X,X1,X2,X3,Y,I
  1. S RESULT="",LEN=0,X1=0
  1. ;
  1. F S X1=$O(@HLTEXT@(X1)) Q:'X1 S X=@HLTEXT@(X1),X2=$D(@HLTEXT@(X1)),LEN=LEN+$L(X) D
  1. . X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
  1. . I X2=1 S RESULT=RESULT_$C(13),LEN=LEN+1 Q
  1. . I X2=11 S X3=0 F S X3=$O(@HLTEXT@(X1,X3)) Q:'X3 D
  1. .. S X=@HLTEXT@(X1,X3),LEN=LEN+$L(X) X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y)
  1. ..I $O(@HLTEXT@(X1,X3))="" S RESULT=RESULT_$C(13),LEN=LEN+1
  1. ;
  1. S X=RESULT X ^%ZOSF("LPC") S RESULT=Y
  1. Q RESULT_"^"_LEN
  1. ;
  1. APPEND(HLTEXT,LL0,LL1) ; This function will append the data contained in
  1. ; the HLTEXT array into the IN queue multiple (LL1) of the Logical
  1. ; Link (LL0) file 870.
  1. ; INPUT : HLTEXT - Array containing text to append
  1. ; LL0 - IEN of File 870
  1. ; LL1 - IEN of IN queue multiple
  1. ;
  1. N HLI,X,X1,X2,X3
  1. S X=""
  1. S HLI=$P($G(^HLCS(870,LL0,1,LL1,1,0)),U,3)
  1. S:'HLI HLI=0
  1. 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
  1. . 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
  1. .. S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)=$G(@HLTEXT@(X,X3))
  1. . S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)="" Q
  1. ;
  1. ;-- update 0 node
  1. S ^HLCS(870,LL0,1,LL1,1,0)="^^"_HLI_"^"_HLI_"^"_DT_"^"
  1. Q
  1. ;
  1. HLNEXT ;-- This routine is used to return the next segment from file 772
  1. ; during processing of an inbound message. The following variables
  1. ; are used for the processing.
  1. ; HLMTIEN - Entry in 772 where message is
  1. ; HLQUIT - Curent ien of "IN" wp field
  1. ; HLNODE - Data is returned in HLNODE=Segment and HLNODE(n) if
  1. ; segmemt is greater than 245 chars.
  1. ;
  1. K HLNODE
  1. N HLI,HLDONE,HLX
  1. S HLNODE="",HLDONE=0
  1. I HLQUIT="" S HLQUIT=0
  1. ;HLMTIEN is undef, no response to process
  1. I '$G(HLMTIEN) S HLQUIT=0 Q
  1. ;first time, check if new format
  1. I '$D(HLDONE1) D Q:HLQUIT
  1. . S HLX=$O(^HLMA("B",HLMTIEN,0))
  1. . ;old format, set HLDONE1 so we won't come here again
  1. . I 'HLX S HLDONE1=0 Q
  1. . ;already got header, reset HLQUIT for text
  1. . I HLQUIT S (HLDONE1,HLQUIT)=0 Q
  1. . ;new format, get header in 773
  1. . S HLQUIT=$O(^HLMA(HLX,"MSH",HLQUIT))
  1. . ;there is no header
  1. . I 'HLQUIT S (HLDONE1,HLQUIT)=0 Q
  1. . S HLNODE=$G(^HLMA(HLX,"MSH",HLQUIT,0)),HLI=0
  1. . F S HLQUIT=$O(^HLMA(HLX,"MSH",HLQUIT)) Q:'HLQUIT D Q:HLDONE
  1. .. I ^HLMA(HLX,"MSH",HLQUIT,0)="" S HLDONE=1 Q
  1. .. S HLI=HLI+1,HLNODE(HLI)=$G(^HLMA(HLX,"MSH",HLQUIT,0)) Q
  1. . S HLQUIT=1 Q
  1. S HLQUIT=$O(^HL(772,HLMTIEN,"IN",HLQUIT))
  1. I HLQUIT D Q
  1. . ; patch HL*1.6*142 start
  1. . N HLQUIT2 ; use to save the last ien
  1. . S HLNODE=$G(^HL(772,HLMTIEN,"IN",HLQUIT,0)),HLI=0
  1. . ; F S HLQUIT=$O(^HL(772,HLMTIEN,"IN",HLQUIT)) Q:'HLQUIT D Q:HLDONE
  1. . F S HLQUIT2=HLQUIT,HLQUIT=$O(^HL(772,HLMTIEN,"IN",HLQUIT)) Q:'HLQUIT D Q:HLDONE
  1. .. I ^HL(772,HLMTIEN,"IN",HLQUIT,0)="" S HLDONE=1 Q
  1. .. S HLI=HLI+1,HLNODE(HLI)=$G(^HL(772,HLMTIEN,"IN",HLQUIT,0)) Q
  1. . ; for the occurrence when the last segment is not followed by <CR>
  1. . I HLQUIT="" S HLQUIT=HLQUIT2
  1. . ; patch HL*1.6*142 end
  1. ;no more nodes, kill flag and quit
  1. K HLDONE1 Q
  1. ;
  1. MSGLINE(HLMID) ;return the number of lines in a message, TCP type only
  1. ;input: HLMID=message id
  1. Q:$G(HLMID)="" 0
  1. N HLCNT,HLIENS,HLIEN
  1. ;can't find message
  1. S HLIENS=$O(^HLMA("C",HLMID,0)) Q:'HLIENS 0
  1. S HLIEN=+$G(^HLMA(HLIENS,0)) Q:'HLIEN 0
  1. S HLCNT=$P($G(^HLMA(HLIENS,"MSH",0)),U,4)+$P($G(^HL(772,HLIEN,"IN",0)),U,4)
  1. Q HLCNT
  1. ;
  1. MSGSIZE(HLIENS) ;return the number of characters in a message, TCP type only
  1. ;input: HLIENS= ien in file 773
  1. Q:'$G(HLIENS) 0
  1. N HLCNT,HLI,HLIEN,HLZ
  1. ;HLIEN=ien in file 772, message text. Blank lines are CR, add 1
  1. Q:'$G(^HLMA(HLIENS,0)) 0 S HLIEN=+(^(0)) Q:'HLIEN 0
  1. S (HLCNT,HLI,HLZ)=0
  1. ;get header
  1. F S HLI=$O(^HLMA(HLIENS,"MSH",HLI)) Q:'HLI S HLZ=$L($G(^(HLI,0))),HLCNT=HLCNT+$S(HLZ:HLZ,1:1)
  1. ;if last line of header wasn't blank, add 1 for CR
  1. S:HLZ HLCNT=HLCNT+1
  1. ;get body
  1. 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)
  1. Q HLCNT
  1. ;
  1. MSG(HLMID,HLREST) ;return the message text in the reference HLREST
  1. ;only for TCP type messages
  1. ;input: HLMID=message id, HLREST=closed local or global reference
  1. ;to place message text
  1. ;output: return 1 for success and 0 if message doesn't exist
  1. Q:$G(HLMID)=""!($G(HLREST)="") 0
  1. N HLCNT,HLI,HLIENS,HLIEN,HLZ
  1. ;can't find message
  1. S HLIENS=$O(^HLMA("C",HLMID,0)) Q:'HLIENS 0
  1. S HLIEN=+$G(^HLMA(HLIENS,0)) Q:'HLIEN 0
  1. ;RESULT must be close reference
  1. D I '$D(HLREST) Q 0
  1. . Q:HLREST'["("
  1. . I $E(HLREST,$L(HLREST))=")",$F(HLREST,")")>($F(HLREST,"(")+1) Q
  1. . K HLREST
  1. S (HLCNT,HLI)=0,HLZ=""
  1. ;get header
  1. F S HLI=$O(^HLMA(HLIENS,"MSH",HLI)) Q:'HLI S HLCNT=HLCNT+1,(HLZ,@HLREST@(HLCNT))=$G(^(HLI,0))
  1. S:HLZ'="" HLCNT=HLCNT+1,@HLREST@(HLCNT)=""
  1. ;get body
  1. S HLI=0 F S HLI=$O(^HL(772,HLIEN,"IN",HLI)) Q:'HLI S HLCNT=HLCNT+1,@HLREST@(HLCNT)=$G(^(HLI,0))
  1. Q 1