- 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 Feb 18, 2025@23:06:36 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)