LA7UTILC ;DALOI/JDB - Browse UI message <cont> ;05/01/09 15:59
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
;
BRO(LA7HDR,LA7DOC,LA7IEN,LA7J) ; Setup text for browser.
; Called from DQ^LA7UTILA
;
N LA7,LA7DT,LA7X,I,J,K,X,Y,EOS,SEGIN
;
K ^TMP($$RTNNM,$J,"SEG")
K ^TMP($$RTNNM,$J,"COMP")
;
D GETS^DIQ(62.49,LA7IEN,".01:149;151:161;162*","ENR","LA7") ; Retrieve data from file 62.49
S J=$G(LA7J,1)
D ADDTEXT(" ["_$$CJ^XLFSTR(" Message Statistics ",IOM-4,"*")_"]")
D ADDTEXT(" ")
;
S I="LA7(62.49)",K=0,J(0)=J
F S I=$Q(@I) Q:I="" Q:$E($QS(I,1),1,5)'=62.49 D
. S X=$QS(I,3)_": "_@I
. I K=0,$L(X)>((IOM\2)-1) S K=1,Y=""
. I K=0 S K=1,Y=$$LJ^XLFSTR(X,(IOM\2)+2)
. E S K=0 D ADDTEXT(Y_$QS(I,3)_": "_@I)
I K=1 D ADDTEXT(Y)
I J(0)=J D ADDTEXT($$CJ^XLFSTR(" [None Found]",IOM-1))
S LA7X=$G(^LAHM(62.49,LA7IEN,0))
S LA7DT=$P(LA7X,"^",5) ; Date/time message received
S LA7DT(0)=LA7DT\1 ; Date message received.
S LA7DT(1)=LA7DT#1 ; Time message received.
S K="LA7ERR^"_(LA7DT(0)-.1)
D ADDTEXT(" ")
D ADDTEXT(" ["_$$CJ^XLFSTR(" Error Message ",IOM-4,"*")_"]")
D ADDTEXT(" ")
;
; Save value of "J", determine if any error message found.
S J(0)=J
F S K=$O(^XTMP(K)) Q:K=""!($P(K,"^")'="LA7ERR") D
. I LA7DT(0)=$P(K,"^",2) S I=LA7DT(1)-.01 S:I<0 I=0 ; Start looking after date/time of message.
. E S I=0
. F S I=$O(^XTMP(K,I)) Q:'I D
. . S X=^XTMP(K,I)
. . I $P(X,"^",2)=LA7IEN D
. . . D ADDTEXT("Date: "_$$FMTE^XLFDT($P(K,"^",2)+I,1))
. . . S X=$P(X,"^",4)
. . . S X=$$DECODEUP^XMCU1(X)
. . . D ADDTEXT("Text: "_X) ; Get error message.
. . . D ADDTEXT(" ")
;
I J(0)=J D ADDTEXT($$CJ^XLFSTR("[None Found]",IOM-1))
D ADDTEXT(" ")
D ADDTEXT(" ["_$$CJ^XLFSTR(" Text of Message ",IOM-4,"*")_"]")
D ADDTEXT(" ")
D HLIN("^LAHM(62.49,LA7IEN,150,")
;
; If linked to another entry go parse that entry also
I $P(LA7X,"^",7) D BRO("LA7 UI Message Display",LA7DOC,$P(LA7X,"^",7),J)
;
; Setup document list.
S LA7HDR=LA7HDR_" Msg #"_LA7DOC_" - "_$P(^LAHM(62.49,LA7DOC,0),"^",6)
S ^TMP($J,"LIST",LA7HDR)="^TMP(""DDB"",$J,"_LA7DOC_")"
Q
;
;
HLIN(GBL) ;
; Retrieve/Parse HL7 message from global.
; Uses LA7DOC,J,LA7X,LA7PASR in symtbl
; Can be called separately to populate ^TMP("DDB",$J
; Inputs
; GBL: Open global root where HL7 message is stored
; : Format must be ^GBL(subscripts,seq,0)=data
; : ie ^LAHM(62.49,LA7IEN,150,
;
N EOS,HLFS,HLECH,CNT,I,SEGIN
I $D(LA7DOC)[0 N LA7DOC S LA7DOC=""
I $D(LA7X)[0 N LA7X S LA7X=""
I $D(J)[0 N J S J=0
S J(0)=J
S I=0
S EOS=0 ;End of Segment flag
; HL7 message text. Segments are separated by empty
; lines in the WP field. Segments can be greater than
; global line storage limit (continuation).
; Each HL7 segment is stored (one at a time) in
; ^TMP($$NMSPC,$J,"SEG",#) for passing to SEG2FLD API
;
K ^TMP($$RTNNM(),$J,"SEG")
;
; Segments are stored one at a time here for SEG2FLD API
S SEGIN="^TMP("""_$$RTNNM()_""",$J,""SEG"")"
S CNT=0
S GBL=$G(GBL)
Q:GBL=""
S GBL=GBL_"I)"
S I=0
F S I=$O(@GBL) Q:'I D
. S CNT=CNT+1
. S GBL(0)=$E(GBL,1,$L(GBL)-1)
. S GBL(0)=GBL(0)_",0)"
. S X=$G(@GBL(0))
. I $G(HLFS)="" I $E(X,1,3)="MSH" S HLFS=$E(X,4,4),HLECH=$E(X,5,8)
. D ADDTEXT(X)
. I X="" S EOS=1 ;end of segment indicated by blank line
. E S EOS=0
. ; Parse each message segment.
. I '$G(LA7PARS) Q
. I 'EOS S ^TMP($$RTNNM,$J,"SEG",CNT)=X
. I EOS D ;
. . N HLARR,HLOARR
. . M HLARR=^TMP($$RTNNM,$J,"SEG")
. . D HL2HLO(,.HLARR,HLFS_HLECH,.HLOARR)
. . K HLARR
. . D PF
. . S EOS=0
. . K ^TMP($$RTNNM,$J,"SEG")
. . K ^TMP("LA7VHLU7-S2F",$J,"SEG")
. ;
;
I J(0)=J D ADDTEXT($$CJ^XLFSTR("[None Found]",IOM-1))
Q
;
;
PF ;
; Parse Fields
; HLO compatible array in HLOARR
; Symbol Table
; HLFS defined (HL7 Field Separator)
;
N NODE,NODEN,SUB,FLD,FLDCNT,FLDLAST,STR,SEG,CNT,ISCOMP,ISMSH,DATA
N SHOWNULL,SHOWFLD,SEG2FLD,PROCFLD
N COMP,I,NXTFLD,NXTCOMP,OUT,REP,SEGID,SUB,OUT
;
S FLDCNT=0 ;field count
S FLDLAST=1 ; last field #
S CNT=0
K ^TMP($$RTNNM,$J,"COMP")
S SEG="UNKNOWN" ;segment name
S ISCOMP=0 ; is a component field
S ISMSH=0 ; is the MSH segment
S SHOWNULL='+$P($G(LA7PARS),"^",2) ;User wants to show empty fields
S SHOWFLD=1 ; show field (1=yes 0=no)
S SEG2FLD="LA7VHLU7-S2F" ; ^TMP subscript where SEG2FLD outputs
;
S NODE="HLOARR(1)"
S SEGID=$G(HLOARR(0,1,1,1))
I SEGID="MSH" S ISMSH=1
;
F S NODE=$Q(@NODE) Q:NODE="" D ;
. S STR=""
. S CNT=CNT+1
. S FLD=$QS(NODE,1) ;field #
. S REP=$QS(NODE,2)
. S COMP=$QS(NODE,3)
. S SUB=$QS(NODE,4) ; sub # (a field starts at 0)
. S DATA=@NODE
. S NXTFLD=FLD
. S NXTCOMP=COMP
. ;look ahead
. S X=$Q(@NODE)
. ;W !,"X=",X
. I X'="" S NXTFLD=$QS(X,1) S NXTCOMP=$QS(X,3)
. I '$D(FLD(FLD,"ISREP")) D ;
. . S X=$O(HLOARR(FLD,1))
. . I X S FLD(FLD,"ISREP")=1
. . E S FLD(FLD,"ISREP")=0
. ;
. ; display field if component field
. I FLD=NXTFLD I NXTCOMP'=COMP I $G(FLD(FLD))'=1 D ;
. . K OUT
. . S X=$$HLO2STR(.HLOARR,FLD,HLFS_HLECH,.OUT)
. . I '$D(OUT) S OUT(0)=X K X
. . S I=""
. . F S I=$O(OUT(I)) Q:I="" D ;
. . . I I=0 D ADDTEXT(SEGID_"-"_FLD_" = "_OUT(I))
. . . I I D ADDTEXT(OUT(I),1)
. . S FLD(FLD)=1 ;full field has been displayed
. . K OUT
. ;
. S STR=SEGID_"-"_FLD
. I REP=1 I FLD(FLD,"ISREP") S STR=STR_".1"
. I REP>1 S STR=STR_"."_REP
. I COMP>1 S STR=STR_"-"_COMP
. I COMP=1 D
. . S X=$Q(@NODE)
. . I X'="",$QS(X,1)=FLD,$QS(X,2)=REP,$QS(X,3)'=COMP,$QS(X,4)=SUB S STR=STR_"-"_COMP
. I SUB>1 S STR=STR_"-"_SUB
. I SUB=1 D
. . S X=$Q(@NODE)
. . I X'="",$QS(X,1)=FLD,$QS(X,2)=REP,$QS(X,3)=COMP,$QS(X,4)'=SUB S STR=STR_"-"_SUB
. S STR=STR_" = "_DATA
. D ADDTEXT(STR)
;
; Separate segments with blank line.
D ADDTEXT("")
Q
;
;
PC(SEGNAM,FLDNUM,SHOWNULL) ;
; Parse Components
; In Symbol table:
; HLECH defined (HL7 encoding characters)
; ^TMP($$RTNNM,$J,"COMP") already has the field's data from PF above
;
N IN,STR,COMPNUM,NODE,DATA,COMP,SUB,SEG2FLD
S SEGNAM=$G(SEGNAM)
S SHOWNULL=+$G(SHOWNULL)
S SEG2FLD=$$RTNNM()
S IN="^TMP("""_$$RTNNM_""","_$J_",""COMP"")"
; will return components in ^TMP("LA7VHLU7-S2F",$J,"COMP",1,0)
K ^TMP("LA7VHLU7-S2F",$J,"COMP")
D SEG2FLDS^LA7VHLU7(IN,"COMP",$E(HLECH,1,1))
S NODE="^TMP(""LA7VHLU7-S2F"",$J,""COMP"")"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,1)'="LA7VHLU7-S2F" Q:$QS(NODE,2)'=$J Q:$QS(NODE,3)'="COMP" D ;
. S DATA=@NODE
. I 'SHOWNULL,DATA="" Q ;
. S COMP=$QS(NODE,4)
. S SUB=$QS(NODE,5)
. S STR=SEGNAM_"-"_FLDNUM_"-"_COMP_" = "_DATA
. I SEGNAM="MSH" I FLDNUM=2 S STR="" ;dont decode MSH-2
. I STR'="" D ADDTEXT(STR)
K ^TMP("LA7VHLU7-S2F",$J,"COMP")
Q
;
;
ADDTEXT(STR,APPEND) ;
S STR=$G(STR)
S APPEND=+$G(APPEND)
N X
Q:$G(LA7DOC)=""
; FM Browser does not like holes in the global subscript
; ie ^TMP("DDB",1) -> ^TMP("DDB",3) (missing #2 sub)
; will cause Browser to stop display
S X=+$O(^TMP("DDB",$J,LA7DOC,"A"),-1)
I 'APPEND D ;
. S X=X+1
. S ^TMP("DDB",$J,LA7DOC,X)=$G(STR)
. S J=J+1
I APPEND D ;
. S ^TMP("DDB",$J,LA7DOC,X)=$G(^TMP("DDB",$J,LA7DOC,X))_STR
Q
;
RTNNM() ;
Q $T(+0)
;
;
STRBUF(BUFF,ADD,MAXSTR,OUT) ;
; Breaks a long string into an array based on MAXSTR.
; Leftover string is in BUF after call.
; This method is recursive.
; Used in HLO2STR API.
; Inputs
; BUFF:<byref> Buffer (should be empty at start)
; ADD:<byref> New text to add (is consumed by process)
; MAXSTR: Max string length <dflt=245>
; OUT:<byref> See Outputs
; Outputs
; BUFF: Any leftover portion of the string.
; OUT: The array that holds the portions of the string,
; starting at node 0.
;
N AVAIL,IDX,I,II
S ADD=$G(ADD)
S MAXSTR=$G(MAXSTR,245)
S AVAIL=MAXSTR-$L(BUFF)
I AVAIL<0 S AVAIL=0
I 'AVAIL D ;
. I '$D(OUT) S IDX=0
. E S IDX=+$O(OUT("A"),-1)+1
. S OUT(IDX)=BUFF
. S BUFF=""
; max out buffer
S AVAIL=MAXSTR-$L(BUFF)
S BUFF=BUFF_$E(ADD,1,AVAIL)
S $E(ADD,1,AVAIL)=""
; finish off
S II=$L(ADD)/MAXSTR
I II["." S II=II+1 S II=$P(II,".",1)
F I=1:1:II D ;
. N I,II
. D STRBUF(.BUFF,.ADD,MAXSTR,.OUT)
Q
;
;
HLO2STR(SEGARR,FIELD,FSECH,OUT,MAXSTR) ;
; Convert an HLO segment array to a segment string.
; Useful when calling APIs that work with a segment string.
; Inputs
; SEGARR:<byref> The HLO segment array
; FIELD:<opt> The field number to extract <dflt=all>
; FSECH: The HL7 field sep and encoding characters
; OUT:<byref> See Outputs
; MAXSTR:<opt><dflt=245>
; Outputs
; Returns either the segment string or the segment length.
; If the string cant fit in one "node" the string is
; broken up into smaller sections and returned in OUT(i)
N BUF,C,CC,EC,ECH,F,FLD,FLDS,FS,I,IDX,MAX,MAXSTR,NODE,R,RC,S,SC,SIZE
N STOP,STR,STR2,STRF,STRC,STRR,STRS,TYPE,TXT,VAL
S MAXSTR=$G(MAXSTR)
I MAXSTR<1 S MAXSTR=245
S FIELD=$G(FIELD)
I FIELD<1 S FIELD=0
S FLD=FIELD
K OUT
S FS=$E(FSECH,1,1) ;field sep
S ECH=$E(FSECH,2,5) ;enc chars
S CC=$E(ECH,1,1) ;comp char
S RC=$E(ECH,2,2) ;repeat char
S EC=$E(ECH,3,3) ; escape char
S SC=$E(ECH,4,4) ; sub char
S F(0)=0
; SEGARR(FLD,REP,C,S)=val
S STR=""
S STOP=0
S NODE="SEGARR(FLD)"
F S NODE=$Q(@NODE) Q:NODE="" D Q:STOP ;
. Q:$QL(NODE)'=4
. I +$QS(NODE,1)'=$QS(NODE,1) S STOP=1 Q ;end if not field #
. S F=$QS(NODE,1)
. I FIELD I F Q:F<FIELD I F>FIELD S F=FIELD S STOP=1 Q ; Q ;S STOP=1 Q
. I F(0) I F'=F(0) D ;
. . S FLDS(F(0))=$P(STR,FS,F(0))
. . I FLDS(F(0))="" K FLDS(F(0))
. . S STR=""
. S R=$QS(NODE,2) ;rep #
. S C=$QS(NODE,3) ;comp #
. S S=$QS(NODE,4) ;sub #
. S VAL=@NODE
. I F=0 I R=1 I C=1 I S=1 S TYPE=VAL Q ;seg type
. S VAL=$$CHKDATA^LA7VHLU3(VAL,FSECH)
. S STRF=$P(STR,FS,F) ;field string
. S STRR=$P(STRF,RC,R) ;rep string
. S STRC=$P(STRR,CC,C) ;comp string
. S STRS=$P(STRC,SC,S) ;sub string
. S $P(STRS,SC,S)=VAL
. ; remove extra HL7 chars
. S STRS=$$TRIM^XLFSTR(STRS,"LR",SC)
. S STRC=$$TRIM^XLFSTR(STRC,"LR",CC)
. S STRR=$$TRIM^XLFSTR(STRR,"LR",RC)
. S STRF=$$TRIM^XLFSTR(STRF,"LR",FS)
. S $P(STRC,SC,S)=STRS K STRS
. S $P(STRR,CC,C)=STRC K STRC
. S $P(STRF,RC,R)=STRR K STRR
. S $P(STR,FS,F)=STRF K STRF
. S F(0)=F ;last field #
;
; store last one
I STR'="" D ;
. S FLDS(F)=$P(STR,FS,F)
. I FLDS(F)="" K FLDS(F)
;
S TYPE=$G(TYPE)
I TYPE="" S TYPE=$G(SEGARR(0,1,1,1))
I TYPE="" S TYPE="xxx"
;
; calculate size
S SIZE=$L(TYPE) ;seg name
S I=0
F FLD=1:1:$O(FLDS("A"),-1) D ;
. S SIZE=SIZE+1+$L($G(FLDS(FLD)))
;
; quit STR if not too big
S STR=""
I SIZE'>MAXSTR D Q STR
. S I=0
. F S I=$O(FLDS(I)) Q:'I D ;
. . S $P(STR,FS,I)=FLDS(I)
. ;
. S STR=TYPE_FS_STR ;prepend seg name
. ; only return field data if requested
. I FIELD S STR=$P(STR,FS,$L(STR,FS))
;
; Create array to pass long string back
S STR=""
;S BUF=TYPE ;prepend seg name
I FIELD D ;
. S BUF=""
. S TXT=$G(FLDS(FIELD))
. D STRBUF(.BUF,.TXT,MAXSTR,.OUT)
;
I 'FIELD S BUF=TYPE F FLD=1:1:$O(FLDS("A"),-1) D ;
. S TXT=FS_$G(FLDS(FLD))
. D STRBUF(.BUF,.TXT,MAXSTR,.OUT)
;
I BUF'="" D ;
. S IDX=$O(OUT("A"),-1)+1
. S OUT(IDX)=BUF
;
Q SIZE
;
;
HL2HLO(STR,IN,FSECH,OUT) ;
; Convert an HL7 segment string into HLO segment array
; Inputs
; STR:<opt> Complete HL7 string segment.
; IN:<opt><byref> Local array that holds HL7 segment.
; (Must be subscripted).
; FSECH: Original field sep and encoding chars.
; OUT:<byref> See Outputs
; Outputs
; OUT array (Segment array built by SET^HLOAPI)
N Z,I
S STR=$G(STR)
K OUT
I STR="" I $D(IN) D ;
. N NODE
. S NODE="IN("""")"
. F S NODE=$Q(@NODE) Q:NODE="" D ;
. . S STR=STR_@NODE
. ;I '$O(IN(0)) S STR=$G(IN(0)) Q
. ;S I=""
. ;F S I=$O(IN(I)) Q:I="" S STR=STR_IN(I)
;
D HL2ARR(STR,FSECH,.Z)
D ARR2HLO(.Z,.OUT,FSECH)
Q
;
;
HL2ARR(STR,FSECH,OUT) ;
; Deconstructs an entire HL7 segment string into an array compatible
; with the ARR2HLO function.
; Inputs
; STR: The HL7 string segment to be parsed.
; FSECH: The original HL7 field sep and encoding characters.
; OUT:<byref> See Outputs. Kills on entry.
; Outputs
; OUT: The array that can be used with the ARR2HLO function.
; OUT(field#,component#,subcomp#)=value
; Repeating fields are stored in decimals ie OUT(1.01)
; FS=| EC=^#!@ STR="PID|a^b^A@B@C"
; OUT(0,1)="PID" OUT(1,1)="a" OUT(1,2)="b" OUT(1,3)="A@B@C"
; OUT(1,3,1)="A" OUT(1,3,2)="B" OUT(1,3,3)="C"
;
N FLD,FS,D1,D2,X,REP,REPC,ISREP,SEGID
K OUT
S FS=$E(FSECH,1,1)
S REPC=$E(FSECH,3,3)
S SEGID=$P(STR,FS,1)
S ISREP=0
I SEGID="MSH" S STR="MSH"_$E(FSECH)_$E(FSECH)_$E(FSECH)_$P(STR,$E(FSECH),3,$L(STR))
F FLD=0:1:$L(STR,FS)-1 S D1=$P(STR,FS,FLD+1) D ;
. I SEGID="MSH" I '$D(OUT(0)) D Q ;
. . S OUT(0,1)="MSH"
. . S OUT(1,1)=$E(FSECH,1,1)
. . S OUT(2,1)=$E(FSECH,2,$L(FSECH))
. . S FLD=2
. ;
. S ISREP=0
. I D1[REPC S ISREP=1
. I ISREP F REP=1:1:$L(D1,REPC) S D2=$P(D1,REPC,REP) D ;
. . D FLD2ARR^LA7VHLU7(.D2,FSECH)
. . S X=FLD+(REP/100)
. . M OUT(X)=D2
. . S OUT(X)=""
. . K D2
. ;
. I 'ISREP D ;
. . D FLD2ARR^LA7VHLU7(.D1,FSECH)
. . M OUT(FLD)=D1
. . S OUT(FLD)=""
. . K D1
. ;
Q
;
;
ARR2HLO(ARR,SEG,FSECH) ;
; Builds the HLO segment array from the HL2ARR array
; using the SET^HLOAPI function.
; Deletes ARR nodes as it goes & sets top levels to null to
; save space.
; Inputs
; ARR: The array built from HL2ARR.
; SEG:<byref> See Outputs.
; FSECH: The original HL7 field sep and encoding chars.
; Outputs
; SEG: The HLO SEG array.
;
N NODE,FLD,COMP,SUB,VAL,REP,ISREP,FLDX
S NODE="ARR(0)"
F S NODE=$Q(@NODE) Q:NODE="" D ;
. I $QL(NODE)=1 S @NODE="" Q
. S (FLD,FLDX)=$QS(NODE,1)
. S COMP=$QS(NODE,2)
. S ISREP=0
. I FLD#1>0 S ISREP=1
. ;dont file top level if child nodes exist
. I $QL(NODE)=2 I $O(ARR(FLDX,COMP,0)) S @NODE="" Q
. S VAL=@NODE
. Q:VAL=""
. I VAL[$E(FSECH,3,3) D ;
. . S VAL=$$UNESC^LA7VHLU3(VAL,FSECH)
. S SUB=1
. I $QL(NODE)>2 S SUB=$QS(NODE,3)
. I 'ISREP D SET^HLOAPI(.SEG,VAL,FLD,COMP,SUB)
. I ISREP D ;
. . S REP=(FLD#1)*100
. . D SET^HLOAPI(.SEG,VAL,(FLD\1),COMP,SUB,REP)
. K @NODE
. ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7UTILC 14550 printed Apr 09, 2024@20:47:12 Page 2
LA7UTILC ;DALOI/JDB - Browse UI message <cont> ;05/01/09 15:59
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
+5 ;
BRO(LA7HDR,LA7DOC,LA7IEN,LA7J) ; Setup text for browser.
+1 ; Called from DQ^LA7UTILA
+2 ;
+3 NEW LA7,LA7DT,LA7X,I,J,K,X,Y,EOS,SEGIN
+4 ;
+5 KILL ^TMP($$RTNNM,$JOB,"SEG")
+6 KILL ^TMP($$RTNNM,$JOB,"COMP")
+7 ;
+8 ; Retrieve data from file 62.49
DO GETS^DIQ(62.49,LA7IEN,".01:149;151:161;162*","ENR","LA7")
+9 SET J=$GET(LA7J,1)
+10 DO ADDTEXT(" ["_$$CJ^XLFSTR(" Message Statistics ",IOM-4,"*")_"]")
+11 DO ADDTEXT(" ")
+12 ;
+13 SET I="LA7(62.49)"
SET K=0
SET J(0)=J
+14 FOR
SET I=$QUERY(@I)
if I=""
QUIT
if $EXTRACT($QSUBSCRIPT(I,1),1,5)'=62.49
QUIT
Begin DoDot:1
+15 SET X=$QSUBSCRIPT(I,3)_": "_@I
+16 IF K=0
IF $LENGTH(X)>((IOM\2)-1)
SET K=1
SET Y=""
+17 IF K=0
SET K=1
SET Y=$$LJ^XLFSTR(X,(IOM\2)+2)
+18 IF '$TEST
SET K=0
DO ADDTEXT(Y_$QSUBSCRIPT(I,3)_": "_@I)
End DoDot:1
+19 IF K=1
DO ADDTEXT(Y)
+20 IF J(0)=J
DO ADDTEXT($$CJ^XLFSTR(" [None Found]",IOM-1))
+21 SET LA7X=$GET(^LAHM(62.49,LA7IEN,0))
+22 ; Date/time message received
SET LA7DT=$PIECE(LA7X,"^",5)
+23 ; Date message received.
SET LA7DT(0)=LA7DT\1
+24 ; Time message received.
SET LA7DT(1)=LA7DT#1
+25 SET K="LA7ERR^"_(LA7DT(0)-.1)
+26 DO ADDTEXT(" ")
+27 DO ADDTEXT(" ["_$$CJ^XLFSTR(" Error Message ",IOM-4,"*")_"]")
+28 DO ADDTEXT(" ")
+29 ;
+30 ; Save value of "J", determine if any error message found.
+31 SET J(0)=J
+32 FOR
SET K=$ORDER(^XTMP(K))
if K=""!($PIECE(K,"^")'="LA7ERR")
QUIT
Begin DoDot:1
+33 ; Start looking after date/time of message.
IF LA7DT(0)=$PIECE(K,"^",2)
SET I=LA7DT(1)-.01
if I<0
SET I=0
+34 IF '$TEST
SET I=0
+35 FOR
SET I=$ORDER(^XTMP(K,I))
if 'I
QUIT
Begin DoDot:2
+36 SET X=^XTMP(K,I)
+37 IF $PIECE(X,"^",2)=LA7IEN
Begin DoDot:3
+38 DO ADDTEXT("Date: "_$$FMTE^XLFDT($PIECE(K,"^",2)+I,1))
+39 SET X=$PIECE(X,"^",4)
+40 SET X=$$DECODEUP^XMCU1(X)
+41 ; Get error message.
DO ADDTEXT("Text: "_X)
+42 DO ADDTEXT(" ")
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 IF J(0)=J
DO ADDTEXT($$CJ^XLFSTR("[None Found]",IOM-1))
+45 DO ADDTEXT(" ")
+46 DO ADDTEXT(" ["_$$CJ^XLFSTR(" Text of Message ",IOM-4,"*")_"]")
+47 DO ADDTEXT(" ")
+48 DO HLIN("^LAHM(62.49,LA7IEN,150,")
+49 ;
+50 ; If linked to another entry go parse that entry also
+51 IF $PIECE(LA7X,"^",7)
DO BRO("LA7 UI Message Display",LA7DOC,$PIECE(LA7X,"^",7),J)
+52 ;
+53 ; Setup document list.
+54 SET LA7HDR=LA7HDR_" Msg #"_LA7DOC_" - "_$PIECE(^LAHM(62.49,LA7DOC,0),"^",6)
+55 SET ^TMP($JOB,"LIST",LA7HDR)="^TMP(""DDB"",$J,"_LA7DOC_")"
+56 QUIT
+57 ;
+58 ;
HLIN(GBL) ;
+1 ; Retrieve/Parse HL7 message from global.
+2 ; Uses LA7DOC,J,LA7X,LA7PASR in symtbl
+3 ; Can be called separately to populate ^TMP("DDB",$J
+4 ; Inputs
+5 ; GBL: Open global root where HL7 message is stored
+6 ; : Format must be ^GBL(subscripts,seq,0)=data
+7 ; : ie ^LAHM(62.49,LA7IEN,150,
+8 ;
+9 NEW EOS,HLFS,HLECH,CNT,I,SEGIN
+10 IF $DATA(LA7DOC)[0
NEW LA7DOC
SET LA7DOC=""
+11 IF $DATA(LA7X)[0
NEW LA7X
SET LA7X=""
+12 IF $DATA(J)[0
NEW J
SET J=0
+13 SET J(0)=J
+14 SET I=0
+15 ;End of Segment flag
SET EOS=0
+16 ; HL7 message text. Segments are separated by empty
+17 ; lines in the WP field. Segments can be greater than
+18 ; global line storage limit (continuation).
+19 ; Each HL7 segment is stored (one at a time) in
+20 ; ^TMP($$NMSPC,$J,"SEG",#) for passing to SEG2FLD API
+21 ;
+22 KILL ^TMP($$RTNNM(),$JOB,"SEG")
+23 ;
+24 ; Segments are stored one at a time here for SEG2FLD API
+25 SET SEGIN="^TMP("""_$$RTNNM()_""",$J,""SEG"")"
+26 SET CNT=0
+27 SET GBL=$GET(GBL)
+28 if GBL=""
QUIT
+29 SET GBL=GBL_"I)"
+30 SET I=0
+31 FOR
SET I=$ORDER(@GBL)
if 'I
QUIT
Begin DoDot:1
+32 SET CNT=CNT+1
+33 SET GBL(0)=$EXTRACT(GBL,1,$LENGTH(GBL)-1)
+34 SET GBL(0)=GBL(0)_",0)"
+35 SET X=$GET(@GBL(0))
+36 IF $GET(HLFS)=""
IF $EXTRACT(X,1,3)="MSH"
SET HLFS=$EXTRACT(X,4,4)
SET HLECH=$EXTRACT(X,5,8)
+37 DO ADDTEXT(X)
+38 ;end of segment indicated by blank line
IF X=""
SET EOS=1
+39 IF '$TEST
SET EOS=0
+40 ; Parse each message segment.
+41 IF '$GET(LA7PARS)
QUIT
+42 IF 'EOS
SET ^TMP($$RTNNM,$JOB,"SEG",CNT)=X
+43 ;
IF EOS
Begin DoDot:2
+44 NEW HLARR,HLOARR
+45 MERGE HLARR=^TMP($$RTNNM,$JOB,"SEG")
+46 DO HL2HLO(,.HLARR,HLFS_HLECH,.HLOARR)
+47 KILL HLARR
+48 DO PF
+49 SET EOS=0
+50 KILL ^TMP($$RTNNM,$JOB,"SEG")
+51 KILL ^TMP("LA7VHLU7-S2F",$JOB,"SEG")
End DoDot:2
+52 ;
End DoDot:1
+53 ;
+54 IF J(0)=J
DO ADDTEXT($$CJ^XLFSTR("[None Found]",IOM-1))
+55 QUIT
+56 ;
+57 ;
PF ;
+1 ; Parse Fields
+2 ; HLO compatible array in HLOARR
+3 ; Symbol Table
+4 ; HLFS defined (HL7 Field Separator)
+5 ;
+6 NEW NODE,NODEN,SUB,FLD,FLDCNT,FLDLAST,STR,SEG,CNT,ISCOMP,ISMSH,DATA
+7 NEW SHOWNULL,SHOWFLD,SEG2FLD,PROCFLD
+8 NEW COMP,I,NXTFLD,NXTCOMP,OUT,REP,SEGID,SUB,OUT
+9 ;
+10 ;field count
SET FLDCNT=0
+11 ; last field #
SET FLDLAST=1
+12 SET CNT=0
+13 KILL ^TMP($$RTNNM,$JOB,"COMP")
+14 ;segment name
SET SEG="UNKNOWN"
+15 ; is a component field
SET ISCOMP=0
+16 ; is the MSH segment
SET ISMSH=0
+17 ;User wants to show empty fields
SET SHOWNULL='+$PIECE($GET(LA7PARS),"^",2)
+18 ; show field (1=yes 0=no)
SET SHOWFLD=1
+19 ; ^TMP subscript where SEG2FLD outputs
SET SEG2FLD="LA7VHLU7-S2F"
+20 ;
+21 SET NODE="HLOARR(1)"
+22 SET SEGID=$GET(HLOARR(0,1,1,1))
+23 IF SEGID="MSH"
SET ISMSH=1
+24 ;
+25 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
Begin DoDot:1
+26 SET STR=""
+27 SET CNT=CNT+1
+28 ;field #
SET FLD=$QSUBSCRIPT(NODE,1)
+29 SET REP=$QSUBSCRIPT(NODE,2)
+30 SET COMP=$QSUBSCRIPT(NODE,3)
+31 ; sub # (a field starts at 0)
SET SUB=$QSUBSCRIPT(NODE,4)
+32 SET DATA=@NODE
+33 SET NXTFLD=FLD
+34 SET NXTCOMP=COMP
+35 ;look ahead
+36 SET X=$QUERY(@NODE)
+37 ;W !,"X=",X
+38 IF X'=""
SET NXTFLD=$QSUBSCRIPT(X,1)
SET NXTCOMP=$QSUBSCRIPT(X,3)
+39 ;
IF '$DATA(FLD(FLD,"ISREP"))
Begin DoDot:2
+40 SET X=$ORDER(HLOARR(FLD,1))
+41 IF X
SET FLD(FLD,"ISREP")=1
+42 IF '$TEST
SET FLD(FLD,"ISREP")=0
End DoDot:2
+43 ;
+44 ; display field if component field
+45 ;
IF FLD=NXTFLD
IF NXTCOMP'=COMP
IF $GET(FLD(FLD))'=1
Begin DoDot:2
+46 KILL OUT
+47 SET X=$$HLO2STR(.HLOARR,FLD,HLFS_HLECH,.OUT)
+48 IF '$DATA(OUT)
SET OUT(0)=X
KILL X
+49 SET I=""
+50 ;
FOR
SET I=$ORDER(OUT(I))
if I=""
QUIT
Begin DoDot:3
+51 IF I=0
DO ADDTEXT(SEGID_"-"_FLD_" = "_OUT(I))
+52 IF I
DO ADDTEXT(OUT(I),1)
End DoDot:3
+53 ;full field has been displayed
SET FLD(FLD)=1
+54 KILL OUT
End DoDot:2
+55 ;
+56 SET STR=SEGID_"-"_FLD
+57 IF REP=1
IF FLD(FLD,"ISREP")
SET STR=STR_".1"
+58 IF REP>1
SET STR=STR_"."_REP
+59 IF COMP>1
SET STR=STR_"-"_COMP
+60 IF COMP=1
Begin DoDot:2
+61 SET X=$QUERY(@NODE)
+62 IF X'=""
IF $QSUBSCRIPT(X,1)=FLD
IF $QSUBSCRIPT(X,2)=REP
IF $QSUBSCRIPT(X,3)'=COMP
IF $QSUBSCRIPT(X,4)=SUB
SET STR=STR_"-"_COMP
End DoDot:2
+63 IF SUB>1
SET STR=STR_"-"_SUB
+64 IF SUB=1
Begin DoDot:2
+65 SET X=$QUERY(@NODE)
+66 IF X'=""
IF $QSUBSCRIPT(X,1)=FLD
IF $QSUBSCRIPT(X,2)=REP
IF $QSUBSCRIPT(X,3)=COMP
IF $QSUBSCRIPT(X,4)'=SUB
SET STR=STR_"-"_SUB
End DoDot:2
+67 SET STR=STR_" = "_DATA
+68 DO ADDTEXT(STR)
End DoDot:1
+69 ;
+70 ; Separate segments with blank line.
+71 DO ADDTEXT("")
+72 QUIT
+73 ;
+74 ;
PC(SEGNAM,FLDNUM,SHOWNULL) ;
+1 ; Parse Components
+2 ; In Symbol table:
+3 ; HLECH defined (HL7 encoding characters)
+4 ; ^TMP($$RTNNM,$J,"COMP") already has the field's data from PF above
+5 ;
+6 NEW IN,STR,COMPNUM,NODE,DATA,COMP,SUB,SEG2FLD
+7 SET SEGNAM=$GET(SEGNAM)
+8 SET SHOWNULL=+$GET(SHOWNULL)
+9 SET SEG2FLD=$$RTNNM()
+10 SET IN="^TMP("""_$$RTNNM_""","_$J_",""COMP"")"
+11 ; will return components in ^TMP("LA7VHLU7-S2F",$J,"COMP",1,0)
+12 KILL ^TMP("LA7VHLU7-S2F",$JOB,"COMP")
+13 DO SEG2FLDS^LA7VHLU7(IN,"COMP",$EXTRACT(HLECH,1,1))
+14 SET NODE="^TMP(""LA7VHLU7-S2F"",$J,""COMP"")"
+15 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,1)'="LA7VHLU7-S2F"
QUIT
if $QSUBSCRIPT(NODE,2)'=$JOB
QUIT
if $QSUBSCRIPT(NODE,3)'="COMP"
QUIT
Begin DoDot:1
+16 SET DATA=@NODE
+17 ;
IF 'SHOWNULL
IF DATA=""
QUIT
+18 SET COMP=$QSUBSCRIPT(NODE,4)
+19 SET SUB=$QSUBSCRIPT(NODE,5)
+20 SET STR=SEGNAM_"-"_FLDNUM_"-"_COMP_" = "_DATA
+21 ;dont decode MSH-2
IF SEGNAM="MSH"
IF FLDNUM=2
SET STR=""
+22 IF STR'=""
DO ADDTEXT(STR)
End DoDot:1
+23 KILL ^TMP("LA7VHLU7-S2F",$JOB,"COMP")
+24 QUIT
+25 ;
+26 ;
ADDTEXT(STR,APPEND) ;
+1 SET STR=$GET(STR)
+2 SET APPEND=+$GET(APPEND)
+3 NEW X
+4 if $GET(LA7DOC)=""
QUIT
+5 ; FM Browser does not like holes in the global subscript
+6 ; ie ^TMP("DDB",1) -> ^TMP("DDB",3) (missing #2 sub)
+7 ; will cause Browser to stop display
+8 SET X=+$ORDER(^TMP("DDB",$JOB,LA7DOC,"A"),-1)
+9 ;
IF 'APPEND
Begin DoDot:1
+10 SET X=X+1
+11 SET ^TMP("DDB",$JOB,LA7DOC,X)=$GET(STR)
+12 SET J=J+1
End DoDot:1
+13 ;
IF APPEND
Begin DoDot:1
+14 SET ^TMP("DDB",$JOB,LA7DOC,X)=$GET(^TMP("DDB",$JOB,LA7DOC,X))_STR
End DoDot:1
+15 QUIT
+16 ;
RTNNM() ;
+1 QUIT $TEXT(+0)
+2 ;
+3 ;
STRBUF(BUFF,ADD,MAXSTR,OUT) ;
+1 ; Breaks a long string into an array based on MAXSTR.
+2 ; Leftover string is in BUF after call.
+3 ; This method is recursive.
+4 ; Used in HLO2STR API.
+5 ; Inputs
+6 ; BUFF:<byref> Buffer (should be empty at start)
+7 ; ADD:<byref> New text to add (is consumed by process)
+8 ; MAXSTR: Max string length <dflt=245>
+9 ; OUT:<byref> See Outputs
+10 ; Outputs
+11 ; BUFF: Any leftover portion of the string.
+12 ; OUT: The array that holds the portions of the string,
+13 ; starting at node 0.
+14 ;
+15 NEW AVAIL,IDX,I,II
+16 SET ADD=$GET(ADD)
+17 SET MAXSTR=$GET(MAXSTR,245)
+18 SET AVAIL=MAXSTR-$LENGTH(BUFF)
+19 IF AVAIL<0
SET AVAIL=0
+20 ;
IF 'AVAIL
Begin DoDot:1
+21 IF '$DATA(OUT)
SET IDX=0
+22 IF '$TEST
SET IDX=+$ORDER(OUT("A"),-1)+1
+23 SET OUT(IDX)=BUFF
+24 SET BUFF=""
End DoDot:1
+25 ; max out buffer
+26 SET AVAIL=MAXSTR-$LENGTH(BUFF)
+27 SET BUFF=BUFF_$EXTRACT(ADD,1,AVAIL)
+28 SET $EXTRACT(ADD,1,AVAIL)=""
+29 ; finish off
+30 SET II=$LENGTH(ADD)/MAXSTR
+31 IF II["."
SET II=II+1
SET II=$PIECE(II,".",1)
+32 ;
FOR I=1:1:II
Begin DoDot:1
+33 NEW I,II
+34 DO STRBUF(.BUFF,.ADD,MAXSTR,.OUT)
End DoDot:1
+35 QUIT
+36 ;
+37 ;
HLO2STR(SEGARR,FIELD,FSECH,OUT,MAXSTR) ;
+1 ; Convert an HLO segment array to a segment string.
+2 ; Useful when calling APIs that work with a segment string.
+3 ; Inputs
+4 ; SEGARR:<byref> The HLO segment array
+5 ; FIELD:<opt> The field number to extract <dflt=all>
+6 ; FSECH: The HL7 field sep and encoding characters
+7 ; OUT:<byref> See Outputs
+8 ; MAXSTR:<opt><dflt=245>
+9 ; Outputs
+10 ; Returns either the segment string or the segment length.
+11 ; If the string cant fit in one "node" the string is
+12 ; broken up into smaller sections and returned in OUT(i)
+13 NEW BUF,C,CC,EC,ECH,F,FLD,FLDS,FS,I,IDX,MAX,MAXSTR,NODE,R,RC,S,SC,SIZE
+14 NEW STOP,STR,STR2,STRF,STRC,STRR,STRS,TYPE,TXT,VAL
+15 SET MAXSTR=$GET(MAXSTR)
+16 IF MAXSTR<1
SET MAXSTR=245
+17 SET FIELD=$GET(FIELD)
+18 IF FIELD<1
SET FIELD=0
+19 SET FLD=FIELD
+20 KILL OUT
+21 ;field sep
SET FS=$EXTRACT(FSECH,1,1)
+22 ;enc chars
SET ECH=$EXTRACT(FSECH,2,5)
+23 ;comp char
SET CC=$EXTRACT(ECH,1,1)
+24 ;repeat char
SET RC=$EXTRACT(ECH,2,2)
+25 ; escape char
SET EC=$EXTRACT(ECH,3,3)
+26 ; sub char
SET SC=$EXTRACT(ECH,4,4)
+27 SET F(0)=0
+28 ; SEGARR(FLD,REP,C,S)=val
+29 SET STR=""
+30 SET STOP=0
+31 SET NODE="SEGARR(FLD)"
+32 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
Begin DoDot:1
+33 if $QLENGTH(NODE)'=4
QUIT
+34 ;end if not field #
IF +$QSUBSCRIPT(NODE,1)'=$QSUBSCRIPT(NODE,1)
SET STOP=1
QUIT
+35 SET F=$QSUBSCRIPT(NODE,1)
+36 ; Q ;S STOP=1 Q
IF FIELD
IF F
if F<FIELD
QUIT
IF F>FIELD
SET F=FIELD
SET STOP=1
QUIT
+37 ;
IF F(0)
IF F'=F(0)
Begin DoDot:2
+38 SET FLDS(F(0))=$PIECE(STR,FS,F(0))
+39 IF FLDS(F(0))=""
KILL FLDS(F(0))
+40 SET STR=""
End DoDot:2
+41 ;rep #
SET R=$QSUBSCRIPT(NODE,2)
+42 ;comp #
SET C=$QSUBSCRIPT(NODE,3)
+43 ;sub #
SET S=$QSUBSCRIPT(NODE,4)
+44 SET VAL=@NODE
+45 ;seg type
IF F=0
IF R=1
IF C=1
IF S=1
SET TYPE=VAL
QUIT
+46 SET VAL=$$CHKDATA^LA7VHLU3(VAL,FSECH)
+47 ;field string
SET STRF=$PIECE(STR,FS,F)
+48 ;rep string
SET STRR=$PIECE(STRF,RC,R)
+49 ;comp string
SET STRC=$PIECE(STRR,CC,C)
+50 ;sub string
SET STRS=$PIECE(STRC,SC,S)
+51 SET $PIECE(STRS,SC,S)=VAL
+52 ; remove extra HL7 chars
+53 SET STRS=$$TRIM^XLFSTR(STRS,"LR",SC)
+54 SET STRC=$$TRIM^XLFSTR(STRC,"LR",CC)
+55 SET STRR=$$TRIM^XLFSTR(STRR,"LR",RC)
+56 SET STRF=$$TRIM^XLFSTR(STRF,"LR",FS)
+57 SET $PIECE(STRC,SC,S)=STRS
KILL STRS
+58 SET $PIECE(STRR,CC,C)=STRC
KILL STRC
+59 SET $PIECE(STRF,RC,R)=STRR
KILL STRR
+60 SET $PIECE(STR,FS,F)=STRF
KILL STRF
+61 ;last field #
SET F(0)=F
End DoDot:1
if STOP
QUIT
+62 ;
+63 ; store last one
+64 ;
IF STR'=""
Begin DoDot:1
+65 SET FLDS(F)=$PIECE(STR,FS,F)
+66 IF FLDS(F)=""
KILL FLDS(F)
End DoDot:1
+67 ;
+68 SET TYPE=$GET(TYPE)
+69 IF TYPE=""
SET TYPE=$GET(SEGARR(0,1,1,1))
+70 IF TYPE=""
SET TYPE="xxx"
+71 ;
+72 ; calculate size
+73 ;seg name
SET SIZE=$LENGTH(TYPE)
+74 SET I=0
+75 ;
FOR FLD=1:1:$ORDER(FLDS("A"),-1)
Begin DoDot:1
+76 SET SIZE=SIZE+1+$LENGTH($GET(FLDS(FLD)))
End DoDot:1
+77 ;
+78 ; quit STR if not too big
+79 SET STR=""
+80 IF SIZE'>MAXSTR
Begin DoDot:1
+81 SET I=0
+82 ;
FOR
SET I=$ORDER(FLDS(I))
if 'I
QUIT
Begin DoDot:2
+83 SET $PIECE(STR,FS,I)=FLDS(I)
End DoDot:2
+84 ;
+85 ;prepend seg name
SET STR=TYPE_FS_STR
+86 ; only return field data if requested
+87 IF FIELD
SET STR=$PIECE(STR,FS,$LENGTH(STR,FS))
End DoDot:1
QUIT STR
+88 ;
+89 ; Create array to pass long string back
+90 SET STR=""
+91 ;S BUF=TYPE ;prepend seg name
+92 ;
IF FIELD
Begin DoDot:1
+93 SET BUF=""
+94 SET TXT=$GET(FLDS(FIELD))
+95 DO STRBUF(.BUF,.TXT,MAXSTR,.OUT)
End DoDot:1
+96 ;
+97 ;
IF 'FIELD
SET BUF=TYPE
FOR FLD=1:1:$ORDER(FLDS("A"),-1)
Begin DoDot:1
+98 SET TXT=FS_$GET(FLDS(FLD))
+99 DO STRBUF(.BUF,.TXT,MAXSTR,.OUT)
End DoDot:1
+100 ;
+101 ;
IF BUF'=""
Begin DoDot:1
+102 SET IDX=$ORDER(OUT("A"),-1)+1
+103 SET OUT(IDX)=BUF
End DoDot:1
+104 ;
+105 QUIT SIZE
+106 ;
+107 ;
HL2HLO(STR,IN,FSECH,OUT) ;
+1 ; Convert an HL7 segment string into HLO segment array
+2 ; Inputs
+3 ; STR:<opt> Complete HL7 string segment.
+4 ; IN:<opt><byref> Local array that holds HL7 segment.
+5 ; (Must be subscripted).
+6 ; FSECH: Original field sep and encoding chars.
+7 ; OUT:<byref> See Outputs
+8 ; Outputs
+9 ; OUT array (Segment array built by SET^HLOAPI)
+10 NEW Z,I
+11 SET STR=$GET(STR)
+12 KILL OUT
+13 ;
IF STR=""
IF $DATA(IN)
Begin DoDot:1
+14 NEW NODE
+15 SET NODE="IN("""")"
+16 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
Begin DoDot:2
+17 SET STR=STR_@NODE
End DoDot:2
+18 ;I '$O(IN(0)) S STR=$G(IN(0)) Q
+19 ;S I=""
+20 ;F S I=$O(IN(I)) Q:I="" S STR=STR_IN(I)
End DoDot:1
+21 ;
+22 DO HL2ARR(STR,FSECH,.Z)
+23 DO ARR2HLO(.Z,.OUT,FSECH)
+24 QUIT
+25 ;
+26 ;
HL2ARR(STR,FSECH,OUT) ;
+1 ; Deconstructs an entire HL7 segment string into an array compatible
+2 ; with the ARR2HLO function.
+3 ; Inputs
+4 ; STR: The HL7 string segment to be parsed.
+5 ; FSECH: The original HL7 field sep and encoding characters.
+6 ; OUT:<byref> See Outputs. Kills on entry.
+7 ; Outputs
+8 ; OUT: The array that can be used with the ARR2HLO function.
+9 ; OUT(field#,component#,subcomp#)=value
+10 ; Repeating fields are stored in decimals ie OUT(1.01)
+11 ; FS=| EC=^#!@ STR="PID|a^b^A@B@C"
+12 ; OUT(0,1)="PID" OUT(1,1)="a" OUT(1,2)="b" OUT(1,3)="A@B@C"
+13 ; OUT(1,3,1)="A" OUT(1,3,2)="B" OUT(1,3,3)="C"
+14 ;
+15 NEW FLD,FS,D1,D2,X,REP,REPC,ISREP,SEGID
+16 KILL OUT
+17 SET FS=$EXTRACT(FSECH,1,1)
+18 SET REPC=$EXTRACT(FSECH,3,3)
+19 SET SEGID=$PIECE(STR,FS,1)
+20 SET ISREP=0
+21 IF SEGID="MSH"
SET STR="MSH"_$EXTRACT(FSECH)_$EXTRACT(FSECH)_$EXTRACT(FSECH)_$PIECE(STR,$EXTRACT(FSECH),3,$LENGTH(STR))
+22 ;
FOR FLD=0:1:$LENGTH(STR,FS)-1
SET D1=$PIECE(STR,FS,FLD+1)
Begin DoDot:1
+23 ;
IF SEGID="MSH"
IF '$DATA(OUT(0))
Begin DoDot:2
+24 SET OUT(0,1)="MSH"
+25 SET OUT(1,1)=$EXTRACT(FSECH,1,1)
+26 SET OUT(2,1)=$EXTRACT(FSECH,2,$LENGTH(FSECH))
+27 SET FLD=2
End DoDot:2
QUIT
+28 ;
+29 SET ISREP=0
+30 IF D1[REPC
SET ISREP=1
+31 ;
IF ISREP
FOR REP=1:1:$LENGTH(D1,REPC)
SET D2=$PIECE(D1,REPC,REP)
Begin DoDot:2
+32 DO FLD2ARR^LA7VHLU7(.D2,FSECH)
+33 SET X=FLD+(REP/100)
+34 MERGE OUT(X)=D2
+35 SET OUT(X)=""
+36 KILL D2
End DoDot:2
+37 ;
+38 ;
IF 'ISREP
Begin DoDot:2
+39 DO FLD2ARR^LA7VHLU7(.D1,FSECH)
+40 MERGE OUT(FLD)=D1
+41 SET OUT(FLD)=""
+42 KILL D1
End DoDot:2
+43 ;
End DoDot:1
+44 QUIT
+45 ;
+46 ;
ARR2HLO(ARR,SEG,FSECH) ;
+1 ; Builds the HLO segment array from the HL2ARR array
+2 ; using the SET^HLOAPI function.
+3 ; Deletes ARR nodes as it goes & sets top levels to null to
+4 ; save space.
+5 ; Inputs
+6 ; ARR: The array built from HL2ARR.
+7 ; SEG:<byref> See Outputs.
+8 ; FSECH: The original HL7 field sep and encoding chars.
+9 ; Outputs
+10 ; SEG: The HLO SEG array.
+11 ;
+12 NEW NODE,FLD,COMP,SUB,VAL,REP,ISREP,FLDX
+13 SET NODE="ARR(0)"
+14 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
Begin DoDot:1
+15 IF $QLENGTH(NODE)=1
SET @NODE=""
QUIT
+16 SET (FLD,FLDX)=$QSUBSCRIPT(NODE,1)
+17 SET COMP=$QSUBSCRIPT(NODE,2)
+18 SET ISREP=0
+19 IF FLD#1>0
SET ISREP=1
+20 ;dont file top level if child nodes exist
+21 IF $QLENGTH(NODE)=2
IF $ORDER(ARR(FLDX,COMP,0))
SET @NODE=""
QUIT
+22 SET VAL=@NODE
+23 if VAL=""
QUIT
+24 ;
IF VAL[$EXTRACT(FSECH,3,3)
Begin DoDot:2
+25 SET VAL=$$UNESC^LA7VHLU3(VAL,FSECH)
End DoDot:2
+26 SET SUB=1
+27 IF $QLENGTH(NODE)>2
SET SUB=$QSUBSCRIPT(NODE,3)
+28 IF 'ISREP
DO SET^HLOAPI(.SEG,VAL,FLD,COMP,SUB)
+29 ;
IF ISREP
Begin DoDot:2
+30 SET REP=(FLD#1)*100
+31 DO SET^HLOAPI(.SEG,VAL,(FLD\1),COMP,SUB,REP)
End DoDot:2
+32 KILL @NODE
+33 ;
End DoDot:1
+34 QUIT
