LA7VHLU7 ;DALOI/JDB - HL7 utility ;07/07/09 14:19
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
CODSYS(FLD2ARR,RSLT,CODSYS) ;
; HL7 Coding System from HL7 Component types
; Input
; FLD2ARR:<byref> The array that may contain coding system info.
; This array was generated by the FLD2ARR function.
; RSLT:<byref> Array to hold the results
; CODSYS: <opt> If specified this function will only look
; for the coding system specified.
; Output
; RSLT: If a CODSYS was specified and the coding system was
; found then the array will be defined as follows:
; RSLT(1)=1st field of CE
; RSLT(2)=2nd field of CE
; RSLT(3)=3rd field of CE
; If a CODSYS was not specified then the array will
; contain an index of all potential coding systems
; RSLT("B","99LRE",3)=""
; RSLT("B","99VA64",6)=""
; where the 3rd subscript indicates the subscript level
; in the original FLD2ARR array.
N I,X
S CODSYS=$G(CODSYS)
S I=0
S RSLT=""
F S I=$O(FLD2ARR(I)) Q:'I D ;
. Q:I#3 ;code sys is always on 3rd tuplet
. S X=FLD2ARR(I)
. I CODSYS'="" I CODSYS=X D ;
. . S RSLT=I
. . S RSLT(1)=$G(FLD2ARR(I-2))
. . S RSLT(2)=$G(FLD2ARR(I-1))
. . S RSLT(3)=X
. I CODSYS="" I X'="" S RSLT("B",X,I)=""
Q
;
FLD2ARR(VAR,FSECH) ;
; Places an HL7 field into a local array
; Requires LA7FS,LA7CS,LA7ECH
; Inputs
; VAR :<byref> The local variable to hold the array
; :VAR should be set to the complete HL7 field's data
; :before calling into this routine.
; FSECH :<opt> HL7 Field Sep & Encoding Characters
; :Defaults to LA7FS_LA7ECH
; Outputs
; VAR :Will contain the added nodes
; :VAR(1) = component #1
; :VAR(1,1) = subcomponent #1 of component #1 (HL7 escaped)
; : The component is not HL7 unescaped but the subcomponent
; : is HL7 unescaped
;
N I,II,X,X2,Z,HLEC
S Z=VAR
S FSECH=$G(FSECH)
S HLEC=""
D EC(.HLEC,FSECH)
F I=1:1:$L(Z,HLEC("CS")) D ;
. S (X,X2)=$$COMP(I,Z,HLEC("ECH"))
. I X2'[HLEC("SS") S X2=$$UNESC^LA7VHLU3(X2,HLEC)
. S VAR(I)=X2
. I X[HLEC("SS") F II=1:1:$L(X,HLEC("SS")) D ;
. . S X2=$$SUB(II,X,HLEC("ECH"))
. . S VAR(I,II)=$$UNESC^LA7VHLU3(X2,HLEC)
. ;
Q
;
VALUE(STR,FSECH) ;
; For use with the generated FLD2ARR array
; Call VALUE to return the unescaped value of the first subcomponent
; ie X(1)="A~B~C" X(1,1)=A X(1,2)=B X(1,3)=C
; $$VALUE(X(1),"^@{}~") returns "A"
N X,HLEC
S FSECH=$G(FSECH)
S HLEC=""
D EC(.HLEC,FSECH)
S X=$P(STR,HLEC("SS"))
Q $$UNESC^LA7VHLU3(X,HLEC)
;
FIELD(FLD,FS) ;
; Gets the field from an HL7 segment
; Requires the LA7SEG array
;
; Inputs
; FLD :The HL7 segment's field number
; FS :<opt> The HL7 Field Separator character
; : Defaults to LA7FS
; Output
; The data for the specified field
;
S FS=$G(FS)
I FS="" S FS=$G(LA7FS)
Q $$P^LA7VHLU(.LA7SEG,+$G(FLD)+1,FS)
;
COMP(POS,STR,ECH) ;
; Gets the component from an HL7 field
;
; Inputs
; POS :The HL7 component's position number
; STR :The string that holds the complete HL7 field data
; :for this particular component
; ECH :<opt> The HL7 Encoding string
; :Defaults to LA7ECH
; Output
; The data for the specified component
;
N X
S ECH=$G(ECH)
I ECH="" S ECH=$G(LA7ECH)
S X(0)=STR
Q $$P^LA7VHLU(.X,POS,$E(ECH,1,1))
;
SUB(POS,STR,ECH) ;
; Gets the subcomponent from an HL7 component
;
; Inputs
; POS :The HL7 subcomponent's position number
; STR :The string that holds the complete HL7 component data
; :for this particular subcomponent
; ECH :<opt> The HL7 Encoding string
; : Defaults to LA7ECH
; Output
; The data for the specified subcomponent
N X
S ECH=$G(ECH)
I ECH="" S ECH=$G(LA7ECH)
S X(0)=STR
Q $$P^LA7VHLU(.X,POS,$E(ECH,4))
;
EC(VAR,FSEC) ;
; Builds the HL7 Field Sep and Encoding Characters array
;
; Inputs
; VAR :<byref> <output>
; FSEC : <opt> The HL7 Field Separator and Encoding Characters
; : Uses LA7FS and LA7ECH if not defined
; Outputs
; VAR : VAR=FSEC VAR("FS")=Field Separator
; : VAR("CS")=Component Sep VAR("SS")=Subcomponent Sep
; : VAR("ECH")=Encoding Chars
;
S FSEC=$G(FSEC)
I FSEC="" S FSEC=$G(LA7FS)_$G(LA7ECH)
S VAR=FSEC
S VAR("FS")=$E(FSEC,1)
S VAR("ECH")=$E(FSEC,2,5)
S VAR("CS")=$E(FSEC,2,2)
S VAR("RS")=$E(FSEC,3,3)
S VAR("EC")=$E(FSEC,4,4)
S VAR("SS")=$E(FSEC,5,5)
Q
;
;
DBSTORE(FLD2ARR,API,VERS,R6247,R6248,OUT) ;
;
; Inputs
; FLD2ARR <byref>
; API : <opt>
; VERS : Version number
; R6247 : <opt> File #62.47 IEN (Concept)
; R6248 : <opt> File #62.48 IEN
; OUT : <opt> <byref> The 3rd piece of the tuplet used that
; : the DBSTORE was found for.
; Output
; The corresponding API's output (data or null) or -99 if nothing
; Also see variable OUT above.
; ie: OBX3="123\GARDIA\SCT" and a valid DBSTORE was found
; then OUT=3
;
N DBSTORE,I,CODE,STR,CODESYS,X,X2
S API=+$G(API,1)
S VERS=$G(VERS,1)
S R6247=$G(R6247)
S R6248=+$G(R6248)
I R6248<1 S R6248=$G(LA76248)
K OUT
F I=3:3:$O(FLD2ARR("A"),-1) D Q:$D(DBSTORE) ;
. S CODE=$G(FLD2ARR(I-2))
. S STR=$G(FLD2ARR(I-1))
. S CODESYS=$G(FLD2ARR(I))
. Q:CODESYS="" Q:CODE="" ;
. I API=1 D ;
. . N I
. . S X=$$HL2LAH^LA7VHLU6(CODE,STR,CODESYS,VERS,R6248,$G(LA7SS))
. . S X2=+$P(X,"^",1)
. . I X2=-1!(X2>0) S DBSTORE=X
. I API=2 D ;
. . N I
. . S X=$$HL2VA^LA7VHLU6(CODE,STR,CODESYS,VERS,R6247,R6248)
. . S X2=+$P(X,"^",1)
. . I X2=-1!(X2>0) S DBSTORE=X
. I $D(DBSTORE) S OUT=I
I '$D(DBSTORE) S DBSTORE=-99
Q DBSTORE
;
REPT2ARR(STR,FSEC,OUT) ;
; Puts an HL7 Repeating field into an array.
; The array nodes are also HL7 decoded.
; Input
; STR : Input text that may contain the HL7 repeat character
; FSEC : HL7 Field Separator and Encoding Characters string
; OUT :<byref> The array that holds the split string
; Output
; : see OUT variable above
N I,RPT,J
S RPT=$E(FSEC,3)
S J=0
I $D(OUT)>9 S J=+$O(OUT("A"),-1) ;find next available subscr
F I=1:1:$L(STR,RPT) S OUT(I+J)=$P(STR,RPT,I) S OUT(I+J)=$$UNESC^LA7VHLU3(OUT(I+J),FSEC)
Q
;
SEG2FLDS(IN,SUBSCR,FS) ;
; Inputs
; IN Closed root for input data ie ^TMP($J,"I",0)
; Each node is sequentially numbered
; SUBSCR <opt> Subscript name to use in ^TMP global for output
; Defaults to "S2F"
; Output = ^TMP($$RTNNM-"S2F",$J,SUBSCR)
; This setting allows using the utility numerous
; times in the same routine (ie recursive entry)
; FS <opt> Field Separator (default=^)
; Useful when separating HL7 coded elements,etc.
;
; Converts only one HL7 segment at a time. Puts the
; segment into an ordered array where the field number is the
; primary subscript. If the field is bigger than GBLSIZE then
; the field will continue on the next subscript
; HLSEG(1)="OBR^2^3^4^5^6^7^8^9^10^11^"
; HLSEG(2)="12^13^14^This field is longer than GBLSIZE^16^17^18^19^"
; HLSEG(3)="20^21^22^23^24^25^26^27^28^29^30"
;
; OUT(1,0)=OBR
; OUT(2,0)=2
; ...
; OUT(15,0)=first 245 characters
; OUT(15,1)=next 245 characters
; OUT(15,2)=and so on....
; ...
;
N SUB,DATA,SEGNUM,FLDNUM,FLD,D2,D3,SEQ,STR
N GBLSIZE,CONTFLD,ONODE,INODE,NODE
N OUT
S GBLSIZE=245
S FS=$G(FS)
S IN=$G(IN)
S SUBSCR=$G(SUBSCR)
I IN="" W !,"In not specified" Q
I SUBSCR="" S SUBSCR="S2F"
I $E(IN,$L(IN),$L(IN))'=")" W !,"Input not closed array" Q
S SUB=0
S SEGNUM=0
S FLDNUM=0
S SEQ=0
S ONODE="^TMP("""_$$RTNNM()_"-S2F"","_$J_","""_SUBSCR_""")"
K @ONODE ;kill output array
S ONODE=$E(ONODE,1,$L(ONODE)-1) ;;strip trailing )
S INODE=$E(IN,1,$L(IN)-1)
S INODE=INODE_",SUB)"
S SUB=0
F S SUB=$O(@INODE) Q:SUB="" D ;
. S DATA=@INODE
. I FS="" S FS=$E(DATA,4,4)
. F FLD=1:1:$L(DATA,FS) D ;
. . S CONTFLD=0
. . S D2=$P(DATA,FS,FLD)
. . ; handle field continuance
. . I (FLD=1&(FLDNUM>1)) D ;
. . . S CONTFLD=1
. . . S NODE=ONODE_","_FLDNUM_","_SEQ_")"
. . . S D3=$G(@NODE)
. . I 'CONTFLD D ;
. . . S FLDNUM=FLDNUM+1 S SEQ=0
. . . S NODE=ONODE_","_FLDNUM_","_SEQ_")"
. . . S @NODE=D2
. . ;
. . I CONTFLD D ;
. . . N I,X,CNT,STR
. . . S STR=D3_D2
. . . I $L(STR)'>GBLSIZE D Q ;
. . . . S NODE=ONODE_","_FLDNUM_","_SEQ_")"
. . . . S @NODE=STR
. . . ;
. . . ; Split apart and store if $L(STR)>GBLSIZE
. . . S X=$L(STR)\GBLSIZE S:$P(X,".",2)>0 X=X+1
. . . S CNT=$P(X,".",1)
. . . F I=1:1:CNT D ;
. . . . I I=1 S NODE=ONODE_","_FLDNUM_","_SEQ_")"
. . . . I I>1 S SEQ=SEQ+1 S NODE=ONODE_","_FLDNUM_","_SEQ_")"
. . . . S X=I*GBLSIZE
. . . . S @NODE=$E(STR,(X-GBLSIZE)+1,X)
. . . ;
. . ;
. ;
;
Q
;
RTNNM() ;
; Returns this routine's name (used for namespacing)
Q $T(+0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VHLU7 9138 printed Oct 16, 2024@17:41:05 Page 2
LA7VHLU7 ;DALOI/JDB - HL7 utility ;07/07/09 14:19
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
CODSYS(FLD2ARR,RSLT,CODSYS) ;
+1 ; HL7 Coding System from HL7 Component types
+2 ; Input
+3 ; FLD2ARR:<byref> The array that may contain coding system info.
+4 ; This array was generated by the FLD2ARR function.
+5 ; RSLT:<byref> Array to hold the results
+6 ; CODSYS: <opt> If specified this function will only look
+7 ; for the coding system specified.
+8 ; Output
+9 ; RSLT: If a CODSYS was specified and the coding system was
+10 ; found then the array will be defined as follows:
+11 ; RSLT(1)=1st field of CE
+12 ; RSLT(2)=2nd field of CE
+13 ; RSLT(3)=3rd field of CE
+14 ; If a CODSYS was not specified then the array will
+15 ; contain an index of all potential coding systems
+16 ; RSLT("B","99LRE",3)=""
+17 ; RSLT("B","99VA64",6)=""
+18 ; where the 3rd subscript indicates the subscript level
+19 ; in the original FLD2ARR array.
+20 NEW I,X
+21 SET CODSYS=$GET(CODSYS)
+22 SET I=0
+23 SET RSLT=""
+24 ;
FOR
SET I=$ORDER(FLD2ARR(I))
if 'I
QUIT
Begin DoDot:1
+25 ;code sys is always on 3rd tuplet
if I#3
QUIT
+26 SET X=FLD2ARR(I)
+27 ;
IF CODSYS'=""
IF CODSYS=X
Begin DoDot:2
+28 SET RSLT=I
+29 SET RSLT(1)=$GET(FLD2ARR(I-2))
+30 SET RSLT(2)=$GET(FLD2ARR(I-1))
+31 SET RSLT(3)=X
End DoDot:2
+32 IF CODSYS=""
IF X'=""
SET RSLT("B",X,I)=""
End DoDot:1
+33 QUIT
+34 ;
FLD2ARR(VAR,FSECH) ;
+1 ; Places an HL7 field into a local array
+2 ; Requires LA7FS,LA7CS,LA7ECH
+3 ; Inputs
+4 ; VAR :<byref> The local variable to hold the array
+5 ; :VAR should be set to the complete HL7 field's data
+6 ; :before calling into this routine.
+7 ; FSECH :<opt> HL7 Field Sep & Encoding Characters
+8 ; :Defaults to LA7FS_LA7ECH
+9 ; Outputs
+10 ; VAR :Will contain the added nodes
+11 ; :VAR(1) = component #1
+12 ; :VAR(1,1) = subcomponent #1 of component #1 (HL7 escaped)
+13 ; : The component is not HL7 unescaped but the subcomponent
+14 ; : is HL7 unescaped
+15 ;
+16 NEW I,II,X,X2,Z,HLEC
+17 SET Z=VAR
+18 SET FSECH=$GET(FSECH)
+19 SET HLEC=""
+20 DO EC(.HLEC,FSECH)
+21 ;
FOR I=1:1:$LENGTH(Z,HLEC("CS"))
Begin DoDot:1
+22 SET (X,X2)=$$COMP(I,Z,HLEC("ECH"))
+23 IF X2'[HLEC("SS")
SET X2=$$UNESC^LA7VHLU3(X2,HLEC)
+24 SET VAR(I)=X2
+25 ;
IF X[HLEC("SS")
FOR II=1:1:$LENGTH(X,HLEC("SS"))
Begin DoDot:2
+26 SET X2=$$SUB(II,X,HLEC("ECH"))
+27 SET VAR(I,II)=$$UNESC^LA7VHLU3(X2,HLEC)
End DoDot:2
+28 ;
End DoDot:1
+29 QUIT
+30 ;
VALUE(STR,FSECH) ;
+1 ; For use with the generated FLD2ARR array
+2 ; Call VALUE to return the unescaped value of the first subcomponent
+3 ; ie X(1)="A~B~C" X(1,1)=A X(1,2)=B X(1,3)=C
+4 ; $$VALUE(X(1),"^@{}~") returns "A"
+5 NEW X,HLEC
+6 SET FSECH=$GET(FSECH)
+7 SET HLEC=""
+8 DO EC(.HLEC,FSECH)
+9 SET X=$PIECE(STR,HLEC("SS"))
+10 QUIT $$UNESC^LA7VHLU3(X,HLEC)
+11 ;
FIELD(FLD,FS) ;
+1 ; Gets the field from an HL7 segment
+2 ; Requires the LA7SEG array
+3 ;
+4 ; Inputs
+5 ; FLD :The HL7 segment's field number
+6 ; FS :<opt> The HL7 Field Separator character
+7 ; : Defaults to LA7FS
+8 ; Output
+9 ; The data for the specified field
+10 ;
+11 SET FS=$GET(FS)
+12 IF FS=""
SET FS=$GET(LA7FS)
+13 QUIT $$P^LA7VHLU(.LA7SEG,+$GET(FLD)+1,FS)
+14 ;
COMP(POS,STR,ECH) ;
+1 ; Gets the component from an HL7 field
+2 ;
+3 ; Inputs
+4 ; POS :The HL7 component's position number
+5 ; STR :The string that holds the complete HL7 field data
+6 ; :for this particular component
+7 ; ECH :<opt> The HL7 Encoding string
+8 ; :Defaults to LA7ECH
+9 ; Output
+10 ; The data for the specified component
+11 ;
+12 NEW X
+13 SET ECH=$GET(ECH)
+14 IF ECH=""
SET ECH=$GET(LA7ECH)
+15 SET X(0)=STR
+16 QUIT $$P^LA7VHLU(.X,POS,$EXTRACT(ECH,1,1))
+17 ;
SUB(POS,STR,ECH) ;
+1 ; Gets the subcomponent from an HL7 component
+2 ;
+3 ; Inputs
+4 ; POS :The HL7 subcomponent's position number
+5 ; STR :The string that holds the complete HL7 component data
+6 ; :for this particular subcomponent
+7 ; ECH :<opt> The HL7 Encoding string
+8 ; : Defaults to LA7ECH
+9 ; Output
+10 ; The data for the specified subcomponent
+11 NEW X
+12 SET ECH=$GET(ECH)
+13 IF ECH=""
SET ECH=$GET(LA7ECH)
+14 SET X(0)=STR
+15 QUIT $$P^LA7VHLU(.X,POS,$EXTRACT(ECH,4))
+16 ;
EC(VAR,FSEC) ;
+1 ; Builds the HL7 Field Sep and Encoding Characters array
+2 ;
+3 ; Inputs
+4 ; VAR :<byref> <output>
+5 ; FSEC : <opt> The HL7 Field Separator and Encoding Characters
+6 ; : Uses LA7FS and LA7ECH if not defined
+7 ; Outputs
+8 ; VAR : VAR=FSEC VAR("FS")=Field Separator
+9 ; : VAR("CS")=Component Sep VAR("SS")=Subcomponent Sep
+10 ; : VAR("ECH")=Encoding Chars
+11 ;
+12 SET FSEC=$GET(FSEC)
+13 IF FSEC=""
SET FSEC=$GET(LA7FS)_$GET(LA7ECH)
+14 SET VAR=FSEC
+15 SET VAR("FS")=$EXTRACT(FSEC,1)
+16 SET VAR("ECH")=$EXTRACT(FSEC,2,5)
+17 SET VAR("CS")=$EXTRACT(FSEC,2,2)
+18 SET VAR("RS")=$EXTRACT(FSEC,3,3)
+19 SET VAR("EC")=$EXTRACT(FSEC,4,4)
+20 SET VAR("SS")=$EXTRACT(FSEC,5,5)
+21 QUIT
+22 ;
+23 ;
DBSTORE(FLD2ARR,API,VERS,R6247,R6248,OUT) ;
+1 ;
+2 ; Inputs
+3 ; FLD2ARR <byref>
+4 ; API : <opt>
+5 ; VERS : Version number
+6 ; R6247 : <opt> File #62.47 IEN (Concept)
+7 ; R6248 : <opt> File #62.48 IEN
+8 ; OUT : <opt> <byref> The 3rd piece of the tuplet used that
+9 ; : the DBSTORE was found for.
+10 ; Output
+11 ; The corresponding API's output (data or null) or -99 if nothing
+12 ; Also see variable OUT above.
+13 ; ie: OBX3="123\GARDIA\SCT" and a valid DBSTORE was found
+14 ; then OUT=3
+15 ;
+16 NEW DBSTORE,I,CODE,STR,CODESYS,X,X2
+17 SET API=+$GET(API,1)
+18 SET VERS=$GET(VERS,1)
+19 SET R6247=$GET(R6247)
+20 SET R6248=+$GET(R6248)
+21 IF R6248<1
SET R6248=$GET(LA76248)
+22 KILL OUT
+23 ;
FOR I=3:3:$ORDER(FLD2ARR("A"),-1)
Begin DoDot:1
+24 SET CODE=$GET(FLD2ARR(I-2))
+25 SET STR=$GET(FLD2ARR(I-1))
+26 SET CODESYS=$GET(FLD2ARR(I))
+27 ;
if CODESYS=""
QUIT
if CODE=""
QUIT
+28 ;
IF API=1
Begin DoDot:2
+29 NEW I
+30 SET X=$$HL2LAH^LA7VHLU6(CODE,STR,CODESYS,VERS,R6248,$GET(LA7SS))
+31 SET X2=+$PIECE(X,"^",1)
+32 IF X2=-1!(X2>0)
SET DBSTORE=X
End DoDot:2
+33 ;
IF API=2
Begin DoDot:2
+34 NEW I
+35 SET X=$$HL2VA^LA7VHLU6(CODE,STR,CODESYS,VERS,R6247,R6248)
+36 SET X2=+$PIECE(X,"^",1)
+37 IF X2=-1!(X2>0)
SET DBSTORE=X
End DoDot:2
+38 IF $DATA(DBSTORE)
SET OUT=I
End DoDot:1
if $DATA(DBSTORE)
QUIT
+39 IF '$DATA(DBSTORE)
SET DBSTORE=-99
+40 QUIT DBSTORE
+41 ;
REPT2ARR(STR,FSEC,OUT) ;
+1 ; Puts an HL7 Repeating field into an array.
+2 ; The array nodes are also HL7 decoded.
+3 ; Input
+4 ; STR : Input text that may contain the HL7 repeat character
+5 ; FSEC : HL7 Field Separator and Encoding Characters string
+6 ; OUT :<byref> The array that holds the split string
+7 ; Output
+8 ; : see OUT variable above
+9 NEW I,RPT,J
+10 SET RPT=$EXTRACT(FSEC,3)
+11 SET J=0
+12 ;find next available subscr
IF $DATA(OUT)>9
SET J=+$ORDER(OUT("A"),-1)
+13 FOR I=1:1:$LENGTH(STR,RPT)
SET OUT(I+J)=$PIECE(STR,RPT,I)
SET OUT(I+J)=$$UNESC^LA7VHLU3(OUT(I+J),FSEC)
+14 QUIT
+15 ;
SEG2FLDS(IN,SUBSCR,FS) ;
+1 ; Inputs
+2 ; IN Closed root for input data ie ^TMP($J,"I",0)
+3 ; Each node is sequentially numbered
+4 ; SUBSCR <opt> Subscript name to use in ^TMP global for output
+5 ; Defaults to "S2F"
+6 ; Output = ^TMP($$RTNNM-"S2F",$J,SUBSCR)
+7 ; This setting allows using the utility numerous
+8 ; times in the same routine (ie recursive entry)
+9 ; FS <opt> Field Separator (default=^)
+10 ; Useful when separating HL7 coded elements,etc.
+11 ;
+12 ; Converts only one HL7 segment at a time. Puts the
+13 ; segment into an ordered array where the field number is the
+14 ; primary subscript. If the field is bigger than GBLSIZE then
+15 ; the field will continue on the next subscript
+16 ; HLSEG(1)="OBR^2^3^4^5^6^7^8^9^10^11^"
+17 ; HLSEG(2)="12^13^14^This field is longer than GBLSIZE^16^17^18^19^"
+18 ; HLSEG(3)="20^21^22^23^24^25^26^27^28^29^30"
+19 ;
+20 ; OUT(1,0)=OBR
+21 ; OUT(2,0)=2
+22 ; ...
+23 ; OUT(15,0)=first 245 characters
+24 ; OUT(15,1)=next 245 characters
+25 ; OUT(15,2)=and so on....
+26 ; ...
+27 ;
+28 NEW SUB,DATA,SEGNUM,FLDNUM,FLD,D2,D3,SEQ,STR
+29 NEW GBLSIZE,CONTFLD,ONODE,INODE,NODE
+30 NEW OUT
+31 SET GBLSIZE=245
+32 SET FS=$GET(FS)
+33 SET IN=$GET(IN)
+34 SET SUBSCR=$GET(SUBSCR)
+35 IF IN=""
WRITE !,"In not specified"
QUIT
+36 IF SUBSCR=""
SET SUBSCR="S2F"
+37 IF $EXTRACT(IN,$LENGTH(IN),$LENGTH(IN))'=")"
WRITE !,"Input not closed array"
QUIT
+38 SET SUB=0
+39 SET SEGNUM=0
+40 SET FLDNUM=0
+41 SET SEQ=0
+42 SET ONODE="^TMP("""_$$RTNNM()_"-S2F"","_$JOB_","""_SUBSCR_""")"
+43 ;kill output array
KILL @ONODE
+44 ;;strip trailing )
SET ONODE=$EXTRACT(ONODE,1,$LENGTH(ONODE)-1)
+45 SET INODE=$EXTRACT(IN,1,$LENGTH(IN)-1)
+46 SET INODE=INODE_",SUB)"
+47 SET SUB=0
+48 ;
FOR
SET SUB=$ORDER(@INODE)
if SUB=""
QUIT
Begin DoDot:1
+49 SET DATA=@INODE
+50 IF FS=""
SET FS=$EXTRACT(DATA,4,4)
+51 ;
FOR FLD=1:1:$LENGTH(DATA,FS)
Begin DoDot:2
+52 SET CONTFLD=0
+53 SET D2=$PIECE(DATA,FS,FLD)
+54 ; handle field continuance
+55 ;
IF (FLD=1&(FLDNUM>1))
Begin DoDot:3
+56 SET CONTFLD=1
+57 SET NODE=ONODE_","_FLDNUM_","_SEQ_")"
+58 SET D3=$GET(@NODE)
End DoDot:3
+59 ;
IF 'CONTFLD
Begin DoDot:3
+60 SET FLDNUM=FLDNUM+1
SET SEQ=0
+61 SET NODE=ONODE_","_FLDNUM_","_SEQ_")"
+62 SET @NODE=D2
End DoDot:3
+63 ;
+64 ;
IF CONTFLD
Begin DoDot:3
+65 NEW I,X,CNT,STR
+66 SET STR=D3_D2
+67 ;
IF $LENGTH(STR)'>GBLSIZE
Begin DoDot:4
+68 SET NODE=ONODE_","_FLDNUM_","_SEQ_")"
+69 SET @NODE=STR
End DoDot:4
QUIT
+70 ;
+71 ; Split apart and store if $L(STR)>GBLSIZE
+72 SET X=$LENGTH(STR)\GBLSIZE
if $PIECE(X,".",2)>0
SET X=X+1
+73 SET CNT=$PIECE(X,".",1)
+74 ;
FOR I=1:1:CNT
Begin DoDot:4
+75 IF I=1
SET NODE=ONODE_","_FLDNUM_","_SEQ_")"
+76 IF I>1
SET SEQ=SEQ+1
SET NODE=ONODE_","_FLDNUM_","_SEQ_")"
+77 SET X=I*GBLSIZE
+78 SET @NODE=$EXTRACT(STR,(X-GBLSIZE)+1,X)
End DoDot:4
+79 ;
End DoDot:3
+80 ;
End DoDot:2
+81 ;
End DoDot:1
+82 ;
+83 QUIT
+84 ;
RTNNM() ;
+1 ; Returns this routine's name (used for namespacing)
+2 QUIT $TEXT(+0)
