ALPBGEN1.m

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