ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
PARSIT ;PARSE MESSAGE ON RECEIVING SIDE
N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS="" ;Field separator
S EC=$G(HL("ECH")) Q:EC="" ;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
N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
F X HLNEXT Q:$G(HLQUIT)'>0 D
. I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2)
. I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF
Q
PSTF ;Process STF segment
S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA"
S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D
. S ALPBSSN=$TR(ALPBSSN,"-","")
. I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE"
. I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE"
. ;Unescape Access Code
. S ALPBAC=$$UNESC(ALPBAC)
. ;Unescape Verify Code
. S ALPBVC=$$UNESC(ALPBVC)
S ALPBNAM=$P(STF,FS,3),ALPBNAM=$P(ALPBNAM,CS,1)_","_$P(ALPBNAM,CS,2)_" "_$P(ALPBNAM,CS,3)_" "_$P(ALPBNAM,CS,4) I ALPBNAM[" " S ALPBNAM=$TR(ALPBNAM," ","") I ALPBNAM']"" S ALERR("NAME")="MISSING NAME"
I $D(ALERR) G PERR
S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0)
I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L")
FILE ;Store File 200 data on backup system
N Y,DIC,DIE,DA,DR
Q:'$D(ALPBNAM)
Q:$L(ALPBSSN)'=9
;Try exact SSn lookup first
K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC
;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
;If SSN lookup fails, try name lookup and add
I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
. S DIE="^VA(200,",DR="2////^S X=ALPBAC"
. ;Update name too
. S DR=DR_";.01////^S X=ALPBNAM"
. I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS"
. I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN"
. I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC"
. I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU"
. I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM"
. I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK
K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
Q
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
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
PERR ;PROCESSING ERRORS
H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
K ALERR
Q
ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
+1 ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
PARSIT ;PARSE MESSAGE ON RECEIVING SIDE
+1 NEW FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
+2 ;Field separator
SET FS=$GET(HL("FS"))
IF FS=""
WRITE !,"NO SEPARATOR"
IF FS=""
QUIT
+3 ;Encoding Charaters
SET EC=$GET(HL("ECH"))
IF EC=""
QUIT
+4 ;Component separator
SET CS=$EXTRACT(EC)
+5 ;Repitition separator
SET RS=$EXTRACT(EC,2)
+6 ;Escape character
SET ESC=$EXTRACT(EC,3)
+7 ;Subcomponent separator
SET SS=$EXTRACT(EC,4)
+8 ;escaped escape character
SET EEC=ESC_"E"_ESC
+9 ;escaped field sep
SET EFS=ESC_"F"_ESC
+10 ;escaped component sep
SET ECS=ESC_"S"_ESC
+11 ; escaped repitition sep
SET ERS=ESC_"R"_ESC
+12 ;escaped subcomponent separator
SET ESS=ESC_"T"_ESC
+13 NEW ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
+14 FOR
XECUTE HLNEXT
IF $GET(HLQUIT)'>0
QUIT
Begin DoDot:1
+15 IF $EXTRACT(HLNODE,1,3)="EVN"
SET ALPBMT=$PIECE(HLNODE,2)
+16 IF $EXTRACT(HLNODE,1,3)="STF"
SET STF=$EXTRACT(HLNODE,5,9999)
DO PSTF
End DoDot:1
+17 QUIT
PSTF ;Process STF segment
+1 SET ALPBKY=$PIECE(STF,FS,1)
IF ALPBKY'[200_CS_"VISTA"
QUIT
+2 SET ALPBID=$PIECE(STF,FS,2)
SET ALPBSSN=$EXTRACT(ALPBID,1,9)
SET ALPBAC=$PIECE(ALPBID,RS,2)
SET ALPBVC=$PIECE(ALPBID,RS,3)
Begin DoDot:1
+3 SET ALPBSSN=$TRANSLATE(ALPBSSN,"-","")
+4 IF ALPBAC']""
SET ALERR("ACCESS")="MISSING ACCESS CODE"
+5 IF ALPBVC']""
SET ALERR("VERIFY")="MISSING VERIFY CODE"
+6 ;Unescape Access Code
+7 SET ALPBAC=$$UNESC(ALPBAC)
+8 ;Unescape Verify Code
+9 SET ALPBVC=$$UNESC(ALPBVC)
End DoDot:1
+10 SET ALPBNAM=$PIECE(STF,FS,3)
SET ALPBNAM=$PIECE(ALPBNAM,CS,1)_","_$PIECE(ALPBNAM,CS,2)_" "_$PIECE(ALPBNAM,CS,3)_" "_$PIECE(ALPBNAM,CS,4)
IF ALPBNAM[" "
SET ALPBNAM=$TRANSLATE(ALPBNAM," ","")
IF ALPBNAM']""
SET ALERR("NAME")="MISSING NAME"
+11 IF $DATA(ALERR)
GOTO PERR
+12 SET ALPBDIS=$SELECT($PIECE(STF,FS,7)="I":1,1:0)
+13 IF $PIECE(STF,FS,13)]""
SET ALPBTRM=$$HL7TFM^XLFDT($PIECE(STF,FS,13),"L")
FILE ;Store File 200 data on backup system
+1 NEW Y,DIC,DIE,DA,DR
+2 IF '$DATA(ALPBNAM)
QUIT
+3 IF $LENGTH(ALPBSSN)'=9
QUIT
+4 ;Try exact SSn lookup first
+5 KILL Y
SET DIC="^VA(200,"
SET DIC(0)="X"
SET X=ALPBSSN
SET D="SSN"
DO IX^DIC
+6 ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
+7 ;If SSN lookup fails, try name lookup and add
+8 IF +Y<1
SET DLAYGO=200
SET DIC="^VA(200,"
SET DIC(0)="LM"
SET X=ALPBNAM
DO ^DIC
KILL DIC,DA,DR
+9 IF +Y>0
SET (ALPBDA,DA,DUZ)=+Y
SET ALPBMENU=$ORDER(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0))
Begin DoDot:1
+10 SET DIE="^VA(200,"
SET DR="2////^S X=ALPBAC"
+11 ;Update name too
+12 SET DR=DR_";.01////^S X=ALPBNAM"
+13 IF ALPBDIS]""
SET DR=DR_";7////^S X=ALPBDIS"
+14 IF ALPBSSN]""
IF $LENGTH(ALPBSSN)=9
SET DR=DR_";9////^S X=ALPBSSN"
+15 IF ALPBVC]""
SET DR=DR_";11////^S X=ALPBVC"
+16 IF +ALPBMENU
SET DR=DR_";201////^S X=ALPBMENU"
+17 IF $GET(ALPBTRM)]""
SET DR=DR_";9.2////^S X=ALPBTRM"
+18 IF $GET(DR)]""
DO ^DIE
KILL DIC,DA,DR
SET DIK=DIE
SET DA=ALPBDA
DO IX1^DIK
End DoDot:1
+19 KILL ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
+20 QUIT
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 IF $GET(ST)=""
QUIT ""
+5 SET PR=$GET(PR)
IF PR]""
DO INIT^HLFNC2(PR,.HL)
+6 IF '$DATA(HL)
Begin DoDot:1
+7 SET HL("FS")="^"
+8 SET HL("ECH")="~|\&"
End DoDot:1
+9 ;Field separator
SET FS=$GET(HL("FS"))
IF FS=""
QUIT ""
+10 ;Encoding Charaters
SET EC=$GET(HL("ECH"))
IF EC=""
QUIT ""
+11 ;Component separator
SET CS=$EXTRACT(EC)
+12 ;Repitition separator
SET RS=$EXTRACT(EC,2)
+13 ;Escape character
SET ESC=$EXTRACT(EC,3)
+14 ;Subcomponent separator
SET SS=$EXTRACT(EC,4)
+15 ;escaped escape character
SET EEC=ESC_"E"_ESC
+16 ;escaped field sep
SET EFS=ESC_"F"_ESC
+17 ;escaped component sep
SET ECS=ESC_"S"_ESC
+18 ; escaped repitition sep
SET ERS=ESC_"R"_ESC
+19 ;escaped subcomponent separator
SET ESS=ESC_"T"_ESC
+20 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
+21 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)
+22 IF $GET(L)]""
SET ST=L
+23 ;
+24 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
+25 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)
+26 IF $GET(L)]""
SET ST=L
+27 ;
+28 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
+29 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)
+30 IF $GET(L)]""
SET ST=L
+31 ;
+32 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
+33 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)
+34 IF $GET(L)]""
SET ST=L
+35 ;
+36 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
+37 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)
+38 IF $GET(L)]""
SET ST=L
+39 KILL I,J,K,L,X
+40 QUIT ST
PERR ;PROCESSING ERRORS
+1 HANG 1
SET DATE=$$NOW^XLFDT
MERGE ^TMP("BCBU",$JOB,$SELECT($GET(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
+2 KILL ALERR
+3 QUIT
