ALPBGEN ;SFVAMC/JC - Build HL7 PMU messages ;03/11/2004 15:54
;;3.0;BAR CODE MED ADMIN;**7,8,102,127**;March 2004;Build 6
HL7(XUIEN,XUFLG,XUSR) ;GENERATE MESSAGE - For Subscriber to XUSER DATA REQUEST (BCBU PMU MESSAGE BUILDER)
;Build HL7 PMU~B01 or B02 message from array XUSR() and XUNAME()
;B01=Personnel Add/Create event type
;B02=Personnel Update event type
;
;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
Q:'$D(XUSR) ;Array of user data from Kernel
Q:'$D(XUIEN) ;Internal entry of user required
;
;SFVAMC/JC - 10/8/03 ADD CHECK FOR BCMA USER STATUS
I '$G(XUSR("TERMINATION DATE")),'$G(XUSR("DISUSER")),$$ISBCMA^ALPBGEN2(XUIEN)<1 Q
;
N ALPBEVN,MT,FS,EC,CS,RS,ESC,SS,N,ALERR,ALPBDIV,ALPBRCV,ECS,EEC,EFS,ERS,ESS,HLA,HLMTIENS,HLNEXT,HLNODE,HLQUIT,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
S ALPBEVN=$S(XUFLG=1:"PSB BCBU PMU_B01 EVENT",1:"PSB BCBU PMU_B02 EVENT")
S ALPBRCV=$S(XUFLG=1:"PSB BCBU PMU_B01 RECV",1:"PSB BCBU PMU_B02 RECV")
K HL D INIT^HLFNC2(ALPBEVN,.HL)
I +$G(HL) W !,HL Q ;SETUP ERROR or no subscribers.
S N=0
S MT=$S(XUFLG=1:"B01",1:"B02")
S FS=$G(HL("FS")) Q:FS="" ;Field separator
S EC=$G(HL("ECH")) Q:EC="" ;Encoding Characters
S CS=$E(EC) ;Component separator
S RS=$E(EC,2) ;Repetition separator
S ESC=$E(EC,3) ;Escape character
S SS=$E(EC,4) ;Subcomponent separator
S EEC=ESC_"E"_ESC ;escaped escape character
S EFS=ESC_"F"_ESC ;escaped field separator
S ECS=ESC_"S"_ESC ;escaped component separator
S ERS=ESC_"R"_ESC ; escaped Repetition separator
S ESS=ESC_"T"_ESC ;escaped subcomponent separator
EVN ;EVN segment
S N=N+1
S HLA("HLS",N)="EVN"_FS_MT_FS_$$FMTHL7^XLFDT($$NOW^XLFDT)
GSTF ;Generate Staff Detail Segment
N ALPBSSN,STF S STF="STF"
S $P(STF,FS,2)=XUIEN_CS_200_CS_"VISTA" ;Primary Key
;Staff ID Code
;SSN Incorrect variable reference before transmit to workstation
;also don't plus SSN
;S ALPBSSN=$TR($G(XUSR("ALPBSSN")),"-","") S:+ALPBSSN ALPBSSN=$$M10^HLFNC(ALPBSSN,EC) S:'+ALPBSSN ALPBSSN=ALPBSSN_CS_""_CS_"LOCAL"
S ALPBSSN=$TR($G(XUSR("SSN")),"-","") Q:$L(ALPBSSN)'=9 S ALPBSSN=$$M10^HLFNC(ALPBSSN,EC)
S $P(STF,FS,3)=ALPBSSN_CS_"USSSA"_CS_"SS"_RS_$$ESC($G(XUSR("ACCESS CODE")))_RS_$$ESC($G(XUSR("VERIFY CODE")))
GSTNM ;Staff Name
N SN S SN=""
I $D(XUSR("HL7NAME")) D
. S XUSR("HL7NAME")=$TR(XUSR("HL7NAME"),"~",CS)
. S SN=XUSR("HL7NAME")
I '$D(XUSR("HL7NAME")),$D(XUSR("NAME")) D
. S SN=$TR(XUSR("NAME"),",",CS)
S $P(STF,FS,4)=SN
;Active/Inactive (Disuser=1 or 0 or null)
S $P(STF,FS,8)=$S(XUSR("DISUSER")=1:"I",1:"A")
;Termination Date
I XUSR("TERMINATION DATE")]"" S $P(STF,FS,14)=$$FMTHL7^XLFDT(XUSR("TERMINATION DATE"))
;Add to HL7 array
S N=N+1,HLA("HLS",N)=STF
;Send the message
Q:'$D(HLA)
;Check user's divisions
SEND K HLL S ALPBDIV="" F S ALPBDIV=$O(XUSR("DIV",ALPBDIV)) Q:ALPBDIV="" D
. K DIC,D,X,Y
. S DIC="^DG(40.8,",D="AD",X=ALPBDIV,DIC(0)="XN"
. D IX^DIC
. Q:+Y'>0
. S ALPBDIV1=+Y
. K DIC,D,X,Y,ALPHLL
. D GET^ALPBPARM(.ALPHLL,ALPBDIV1)
. I $D(ALPHLL) S I=0 F S I=$O(ALPHLL("LINKS",I)) Q:I<1 D
. . S $P(ALPHLL("LINKS",I),"^",1)=ALPBRCV
. . S HLL("LINKS",($O(HLL("LINKS",999999),-1)+1))=ALPHLL("LINKS",I)
K ALPHLL
;If no division assoc. use defaults
I $O(XUSR("DIV",0))=""!('$D(HLL)) D GET^ALPBPARM(.HLL,"","",ALPBRCV)
K MYRESULT
I '$D(HLL) S MYRESULT="1-No subscribers" Q
D GENERATE^HLMA(ALPBEVN,"LM",1,.MYRESULT)
I $P(MYRESULT,U,2)]"" S ALERR=MYRESULT D SERR
Q
;
ESC(ST,PR) ;Translate reserved characters to escape sequences in Access/Verify
;ST=String to translate
;PR=Event Protocol to set up HL array variables (optional)
;First, do the escape character
N I,J
I $G(ST)']"" Q ""
S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
I '$D(HL) D
. S HL("FS")="^"
. S HL("ECH")="~|\&"
S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters
S CS=$E(EC) ;Component separator
S RS=$E(EC,2) ;Repitition separator
S ESC=$E(EC,3) ;Escape character
S SS=$E(EC,4) ;Subcomponent separator
S EEC=ESC_"E"_ESC ;escaped escape character
S EFS=ESC_"F"_ESC ;escaped field sep
S ECS=ESC_"S"_ESC ;escaped component sep
S ERS=ESC_"R"_ESC ; escaped repitition sep
S ESS=ESC_"T"_ESC ;escaped subcomponent separator
F I=1:1:$L(ST) S J=$E(ST,I),^TMP($J,I)=J D
. S:J=ESC ^TMP($J,I)=EEC
. S:J=FS ^TMP($J,I)=EFS
. S:J=CS ^TMP($J,I)=ECS
. S:J=RS ^TMP($J,I)=ERS
. S:J=SS ^TMP($J,I)=ESS
S I=0,ST="" F S I=$O(^TMP($J,I)) Q:I<1 S ST=ST_^TMP($J,I)
K ^TMP($J)
Q ST
UNESC(ST,PR) ;Unescape string from message
;ST=String to translate
;PR=Event Protocol to set up HL array variables (optional)
;First, do the escape character
N I,J,K,L,X
I $G(ST)="" Q ""
S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
I '$D(HL) D
. S HL("FS")="^"
. S HL("ECH")="~|\&"
S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters
S CS=$E(EC) ;Component separator
S RS=$E(EC,2) ;Repitition separator
S ESC=$E(EC,3) ;Escape character
S SS=$E(EC,4) ;Subcomponent separator
S EEC=ESC_"E"_ESC ;escaped escape character
S EFS=ESC_"F"_ESC ;escaped field sep
S ECS=ESC_"S"_ESC ;escaped component sep
S ERS=ESC_"R"_ESC ; escaped repitition sep
S ESS=ESC_"T"_ESC ;escaped subcomponent separator
K I,J,K,L,X F S X=$F(ST,EEC) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EEC K(I)=$P(K(I),EEC)_ESC S L=$G(L)_K(I)
I $G(L)]"" S ST=L
;
K I,J,K,L,X F S X=$F(ST,EFS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EFS K(I)=$P(K(I),EFS)_FS S L=$G(L)_K(I)
I $G(L)]"" S ST=L
;
K I,J,K,L,X S I=0 F S X=$F(ST,ECS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ECS K(I)=$P(K(I),ECS)_CS S L=$G(L)_K(I)
I $G(L)]"" S ST=L
;
K I,J,K,L,X S I=0 F S X=$F(ST,ERS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ERS K(I)=$P(K(I),ERS)_RS S L=$G(L)_K(I)
I $G(L)]"" S ST=L
;
K I,J,K,L,X S I=0 F S X=$F(ST,ESS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ESS K(I)=$P(K(I),ESS)_SS S L=$G(L)_K(I)
I $G(L)]"" S ST=L
K I,J,K,L,X
Q ST
;
SERR ;SEND ERRORS
K XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
S XQA("G.PSB BCBU ERRORS")=""
S XQAMSG="Error sending HL7 message "_$G(HL("MID"))_". Header in HLMA("_$G(HLMTIENS)_"Error: "_ALERR
D SETUP^XQALERT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBGEN 6661 printed Apr 09, 2024@20:46:17 Page 2
ALPBGEN ;SFVAMC/JC - Build HL7 PMU messages ;03/11/2004 15:54
+1 ;;3.0;BAR CODE MED ADMIN;**7,8,102,127**;March 2004;Build 6
HL7(XUIEN,XUFLG,XUSR) ;GENERATE MESSAGE - For Subscriber to XUSER DATA REQUEST (BCBU PMU MESSAGE BUILDER)
+1 ;Build HL7 PMU~B01 or B02 message from array XUSR() and XUNAME()
+2 ;B01=Personnel Add/Create event type
+3 ;B02=Personnel Update event type
+4 ;
+5 ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
+6 if +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
QUIT
+7 ;Array of user data from Kernel
if '$DATA(XUSR)
QUIT
+8 ;Internal entry of user required
if '$DATA(XUIEN)
QUIT
+9 ;
+10 ;SFVAMC/JC - 10/8/03 ADD CHECK FOR BCMA USER STATUS
+11 IF '$GET(XUSR("TERMINATION DATE"))
IF '$GET(XUSR("DISUSER"))
IF $$ISBCMA^ALPBGEN2(XUIEN)<1
QUIT
+12 ;
+13 NEW ALPBEVN,MT,FS,EC,CS,RS,ESC,SS,N,ALERR,ALPBDIV,ALPBRCV,ECS,EEC,EFS,ERS,ESS,HLA,HLMTIENS,HLNEXT,HLNODE,HLQUIT,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
+14 SET ALPBEVN=$SELECT(XUFLG=1:"PSB BCBU PMU_B01 EVENT",1:"PSB BCBU PMU_B02 EVENT")
+15 SET ALPBRCV=$SELECT(XUFLG=1:"PSB BCBU PMU_B01 RECV",1:"PSB BCBU PMU_B02 RECV")
+16 KILL HL
DO INIT^HLFNC2(ALPBEVN,.HL)
+17 ;SETUP ERROR or no subscribers.
IF +$GET(HL)
WRITE !,HL
QUIT
+18 SET N=0
+19 SET MT=$SELECT(XUFLG=1:"B01",1:"B02")
+20 ;Field separator
SET FS=$GET(HL("FS"))
if FS=""
QUIT
+21 ;Encoding Characters
SET EC=$GET(HL("ECH"))
if EC=""
QUIT
+22 ;Component separator
SET CS=$EXTRACT(EC)
+23 ;Repetition separator
SET RS=$EXTRACT(EC,2)
+24 ;Escape character
SET ESC=$EXTRACT(EC,3)
+25 ;Subcomponent separator
SET SS=$EXTRACT(EC,4)
+26 ;escaped escape character
SET EEC=ESC_"E"_ESC
+27 ;escaped field separator
SET EFS=ESC_"F"_ESC
+28 ;escaped component separator
SET ECS=ESC_"S"_ESC
+29 ; escaped Repetition separator
SET ERS=ESC_"R"_ESC
+30 ;escaped subcomponent separator
SET ESS=ESC_"T"_ESC
EVN ;EVN segment
+1 SET N=N+1
+2 SET HLA("HLS",N)="EVN"_FS_MT_FS_$$FMTHL7^XLFDT($$NOW^XLFDT)
GSTF ;Generate Staff Detail Segment
+1 NEW ALPBSSN,STF
SET STF="STF"
+2 ;Primary Key
SET $PIECE(STF,FS,2)=XUIEN_CS_200_CS_"VISTA"
+3 ;Staff ID Code
+4 ;SSN Incorrect variable reference before transmit to workstation
+5 ;also don't plus SSN
+6 ;S ALPBSSN=$TR($G(XUSR("ALPBSSN")),"-","") S:+ALPBSSN ALPBSSN=$$M10^HLFNC(ALPBSSN,EC) S:'+ALPBSSN ALPBSSN=ALPBSSN_CS_""_CS_"LOCAL"
+7 SET ALPBSSN=$TRANSLATE($GET(XUSR("SSN")),"-","")
if $LENGTH(ALPBSSN)'=9
QUIT
SET ALPBSSN=$$M10^HLFNC(ALPBSSN,EC)
+8 SET $PIECE(STF,FS,3)=ALPBSSN_CS_"USSSA"_CS_"SS"_RS_$$ESC($GET(XUSR("ACCESS CODE")))_RS_$$ESC($GET(XUSR("VERIFY CODE")))
GSTNM ;Staff Name
+1 NEW SN
SET SN=""
+2 IF $DATA(XUSR("HL7NAME"))
Begin DoDot:1
+3 SET XUSR("HL7NAME")=$TRANSLATE(XUSR("HL7NAME"),"~",CS)
+4 SET SN=XUSR("HL7NAME")
End DoDot:1
+5 IF '$DATA(XUSR("HL7NAME"))
IF $DATA(XUSR("NAME"))
Begin DoDot:1
+6 SET SN=$TRANSLATE(XUSR("NAME"),",",CS)
End DoDot:1
+7 SET $PIECE(STF,FS,4)=SN
+8 ;Active/Inactive (Disuser=1 or 0 or null)
+9 SET $PIECE(STF,FS,8)=$SELECT(XUSR("DISUSER")=1:"I",1:"A")
+10 ;Termination Date
+11 IF XUSR("TERMINATION DATE")]""
SET $PIECE(STF,FS,14)=$$FMTHL7^XLFDT(XUSR("TERMINATION DATE"))
+12 ;Add to HL7 array
+13 SET N=N+1
SET HLA("HLS",N)=STF
+14 ;Send the message
+15 if '$DATA(HLA)
QUIT
+16 ;Check user's divisions
SEND KILL HLL
SET ALPBDIV=""
FOR
SET ALPBDIV=$ORDER(XUSR("DIV",ALPBDIV))
if ALPBDIV=""
QUIT
Begin DoDot:1
+1 KILL DIC,D,X,Y
+2 SET DIC="^DG(40.8,"
SET D="AD"
SET X=ALPBDIV
SET DIC(0)="XN"
+3 DO IX^DIC
+4 if +Y'>0
QUIT
+5 SET ALPBDIV1=+Y
+6 KILL DIC,D,X,Y,ALPHLL
+7 DO GET^ALPBPARM(.ALPHLL,ALPBDIV1)
+8 IF $DATA(ALPHLL)
SET I=0
FOR
SET I=$ORDER(ALPHLL("LINKS",I))
if I<1
QUIT
Begin DoDot:2
+9 SET $PIECE(ALPHLL("LINKS",I),"^",1)=ALPBRCV
+10 SET HLL("LINKS",($ORDER(HLL("LINKS",999999),-1)+1))=ALPHLL("LINKS",I)
End DoDot:2
End DoDot:1
+11 KILL ALPHLL
+12 ;If no division assoc. use defaults
+13 IF $ORDER(XUSR("DIV",0))=""!('$DATA(HLL))
DO GET^ALPBPARM(.HLL,"","",ALPBRCV)
+14 KILL MYRESULT
+15 IF '$DATA(HLL)
SET MYRESULT="1-No subscribers"
QUIT
+16 DO GENERATE^HLMA(ALPBEVN,"LM",1,.MYRESULT)
+17 IF $PIECE(MYRESULT,U,2)]""
SET ALERR=MYRESULT
DO SERR
+18 QUIT
+19 ;
ESC(ST,PR) ;Translate reserved characters to escape sequences in Access/Verify
+1 ;ST=String to translate
+2 ;PR=Event Protocol to set up HL array variables (optional)
+3 ;First, do the escape character
+4 NEW I,J
+5 IF $GET(ST)']""
QUIT ""
+6 SET PR=$GET(PR)
IF PR]""
DO INIT^HLFNC2(PR,.HL)
+7 IF '$DATA(HL)
Begin DoDot:1
+8 SET HL("FS")="^"
+9 SET HL("ECH")="~|\&"
End DoDot:1
+10 ;Field separator
SET FS=$GET(HL("FS"))
IF FS=""
QUIT ""
+11 ;Encoding Charaters
SET EC=$GET(HL("ECH"))
IF EC=""
QUIT ""
+12 ;Component separator
SET CS=$EXTRACT(EC)
+13 ;Repitition separator
SET RS=$EXTRACT(EC,2)
+14 ;Escape character
SET ESC=$EXTRACT(EC,3)
+15 ;Subcomponent separator
SET SS=$EXTRACT(EC,4)
+16 ;escaped escape character
SET EEC=ESC_"E"_ESC
+17 ;escaped field sep
SET EFS=ESC_"F"_ESC
+18 ;escaped component sep
SET ECS=ESC_"S"_ESC
+19 ; escaped repitition sep
SET ERS=ESC_"R"_ESC
+20 ;escaped subcomponent separator
SET ESS=ESC_"T"_ESC
+21 FOR I=1:1:$LENGTH(ST)
SET J=$EXTRACT(ST,I)
SET ^TMP($JOB,I)=J
Begin DoDot:1
+22 if J=ESC
SET ^TMP($JOB,I)=EEC
+23 if J=FS
SET ^TMP($JOB,I)=EFS
+24 if J=CS
SET ^TMP($JOB,I)=ECS
+25 if J=RS
SET ^TMP($JOB,I)=ERS
+26 if J=SS
SET ^TMP($JOB,I)=ESS
End DoDot:1
+27 SET I=0
SET ST=""
FOR
SET I=$ORDER(^TMP($JOB,I))
if I<1
QUIT
SET ST=ST_^TMP($JOB,I)
+28 KILL ^TMP($JOB)
+29 QUIT ST
UNESC(ST,PR) ;Unescape string from message
+1 ;ST=String to translate
+2 ;PR=Event Protocol to set up HL array variables (optional)
+3 ;First, do the escape character
+4 NEW I,J,K,L,X
+5 IF $GET(ST)=""
QUIT ""
+6 SET PR=$GET(PR)
IF PR]""
DO INIT^HLFNC2(PR,.HL)
+7 IF '$DATA(HL)
Begin DoDot:1
+8 SET HL("FS")="^"
+9 SET HL("ECH")="~|\&"
End DoDot:1
+10 ;Field separator
SET FS=$GET(HL("FS"))
IF FS=""
QUIT ""
+11 ;Encoding Charaters
SET EC=$GET(HL("ECH"))
IF EC=""
QUIT ""
+12 ;Component separator
SET CS=$EXTRACT(EC)
+13 ;Repitition separator
SET RS=$EXTRACT(EC,2)
+14 ;Escape character
SET ESC=$EXTRACT(EC,3)
+15 ;Subcomponent separator
SET SS=$EXTRACT(EC,4)
+16 ;escaped escape character
SET EEC=ESC_"E"_ESC
+17 ;escaped field sep
SET EFS=ESC_"F"_ESC
+18 ;escaped component sep
SET ECS=ESC_"S"_ESC
+19 ; escaped repitition sep
SET ERS=ESC_"R"_ESC
+20 ;escaped subcomponent separator
SET ESS=ESC_"T"_ESC
+21 KILL I,J,K,L,X
FOR
SET X=$FIND(ST,EEC)
if X
SET I=$GET(I)+1
SET K(I)=$EXTRACT(ST,1,X-1)
SET ST=$EXTRACT(ST,X,999)
if 'X
SET K($GET(I)+1)=ST
if 'X
QUIT
+22 SET I=0
FOR
SET I=$ORDER(K(I))
if I<1
QUIT
if K(I)[EEC
SET K(I)=$PIECE(K(I),EEC)_ESC
SET L=$GET(L)_K(I)
+23 IF $GET(L)]""
SET ST=L
+24 ;
+25 KILL I,J,K,L,X
FOR
SET X=$FIND(ST,EFS)
if X
SET I=$GET(I)+1
SET K(I)=$EXTRACT(ST,1,X-1)
SET ST=$EXTRACT(ST,X,999)
if 'X
SET K($GET(I)+1)=ST
if 'X
QUIT
+26 SET I=0
FOR
SET I=$ORDER(K(I))
if I<1
QUIT
if K(I)[EFS
SET K(I)=$PIECE(K(I),EFS)_FS
SET L=$GET(L)_K(I)
+27 IF $GET(L)]""
SET ST=L
+28 ;
+29 KILL I,J,K,L,X
SET I=0
FOR
SET X=$FIND(ST,ECS)
if X
SET I=$GET(I)+1
SET K(I)=$EXTRACT(ST,1,X-1)
SET ST=$EXTRACT(ST,X,999)
if 'X
SET K(I+1)=ST
if 'X
QUIT
+30 SET I=0
FOR
SET I=$ORDER(K(I))
if I<1
QUIT
if K(I)[ECS
SET K(I)=$PIECE(K(I),ECS)_CS
SET L=$GET(L)_K(I)
+31 IF $GET(L)]""
SET ST=L
+32 ;
+33 KILL I,J,K,L,X
SET I=0
FOR
SET X=$FIND(ST,ERS)
if X
SET I=$GET(I)+1
SET K(I)=$EXTRACT(ST,1,X-1)
SET ST=$EXTRACT(ST,X,999)
if 'X
SET K(I+1)=ST
if 'X
QUIT
+34 SET I=0
FOR
SET I=$ORDER(K(I))
if I<1
QUIT
if K(I)[ERS
SET K(I)=$PIECE(K(I),ERS)_RS
SET L=$GET(L)_K(I)
+35 IF $GET(L)]""
SET ST=L
+36 ;
+37 KILL I,J,K,L,X
SET I=0
FOR
SET X=$FIND(ST,ESS)
if X
SET I=$GET(I)+1
SET K(I)=$EXTRACT(ST,1,X-1)
SET ST=$EXTRACT(ST,X,999)
if 'X
SET K(I+1)=ST
if 'X
QUIT
+38 SET I=0
FOR
SET I=$ORDER(K(I))
if I<1
QUIT
if K(I)[ESS
SET K(I)=$PIECE(K(I),ESS)_SS
SET L=$GET(L)_K(I)
+39 IF $GET(L)]""
SET ST=L
+40 KILL I,J,K,L,X
+41 QUIT ST
+42 ;
SERR ;SEND ERRORS
+1 KILL XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
+2 SET XQA("G.PSB BCBU ERRORS")=""
+3 SET XQAMSG="Error sending HL7 message "_$GET(HL("MID"))_". Header in HLMA("_$GET(HLMTIENS)_"Error: "_ALERR
+4 DO SETUP^XQALERT
+5 QUIT
