ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;May 26, 2023@16:17
;;3.0;BAR CODE MED ADMIN;**8,37,102,122,125,144**;Mar 2004;Build 7
;;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"
. ;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
;
;If SSN lookup fails, try name lookup and add User only if Termination Date (if it exists)
;is greater than today.
;PSB*3.0*144: Evaluate termination date.
; ALPBTRMX=1 if termination date exists and is today or earlier.
N ALPBTRMX
S ALPBTRMX=$S('$G(ALPBTRM):0,$$FMDIFF^XLFDT(ALPBTRM,DT)>0:0,1:1)
I +Y<1,'ALPBTRMX,'$G(ALPBDIS) S DLAYGO=200,DIC="^VA(200,",DIC(0)="LMX",X=ALPBNAM D ^DIC K DIC,DA,DR
I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
. ;Update name too
. S DIE="^VA(200,",DR=".01////"_ALPBNAM
. S DR=DR_";7////"_$S('$G(ALPBDIS):"@",1:ALPBDIS)
. I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////"_ALPBSSN
. I +ALPBMENU S DR=DR_";201////"_ALPBMENU
. S DR=DR_";9.2////"_$S('$G(ALPBTRM):"@",1:ALPBTRM)
. I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA
. ; Direct set used for the ACCESS CODE value because it may contain semi-colon (;), which affects the DIE call
. I $D(^VA(200,ALPBDA,0)) D
. . S $P(^VA(200,ALPBDA,0),"^",3)=ALPBAC
. D IX1^DIK
. ; VERIFY CODE needs to be set after re-indexing the record otherwise it will delete it because the ACCESS CODE was set
. I $D(^VA(200,ALPBDA,0)) D
. . ;PSB*3.0*144: Do not null out Verify Code.
. . ; Previous logic nulled out the Verify Code if Termination
. . ; Date exists. There is no need to check variable ALPBTRMX
. . ; because the logic will not get to this point if ALPBTRMX=1.
. . S $P(^VA(200,ALPBDA,.1),"^",2)=ALPBVC
. . S $P(^VA(200,ALPBDA,.1),"^",1)=$H
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBGEN1 5558 printed Apr 09, 2024@20:44:52 Page 2
ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;May 26, 2023@16:17
+1 ;;3.0;BAR CODE MED ADMIN;**8,37,102,122,125,144**;Mar 2004;Build 7
+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 ;Unescape Access Code
+6 SET ALPBAC=$$UNESC(ALPBAC)
+7 ;Unescape Verify Code
+8 SET ALPBVC=$$UNESC(ALPBVC)
End DoDot:1
+9 SET ALPBNAM=$PIECE(STF,FS,3)
SET ALPBNAM=$PIECE(ALPBNAM,CS,1)_","_$PIECE(ALPBNAM,CS,2)_" "_$PIECE(ALPBNAM,CS,3)_" "_$PIECE(ALPBNAM,CS,4)
+10 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 ;
+7 ;If SSN lookup fails, try name lookup and add User only if Termination Date (if it exists)
+8 ;is greater than today.
+9 ;PSB*3.0*144: Evaluate termination date.
+10 ; ALPBTRMX=1 if termination date exists and is today or earlier.
+11 NEW ALPBTRMX
+12 SET ALPBTRMX=$SELECT('$GET(ALPBTRM):0,$$FMDIFF^XLFDT(ALPBTRM,DT)>0:0,1:1)
+13 IF +Y<1
IF 'ALPBTRMX
IF '$GET(ALPBDIS)
SET DLAYGO=200
SET DIC="^VA(200,"
SET DIC(0)="LMX"
SET X=ALPBNAM
DO ^DIC
KILL DIC,DA,DR
+14 IF +Y>0
SET (ALPBDA,DA)=+Y
SET ALPBMENU=$ORDER(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0))
Begin DoDot:1
+15 ;Update name too
+16 SET DIE="^VA(200,"
SET DR=".01////"_ALPBNAM
+17 SET DR=DR_";7////"_$SELECT('$GET(ALPBDIS):"@",1:ALPBDIS)
+18 IF ALPBSSN]""
IF $LENGTH(ALPBSSN)=9
SET DR=DR_";9////"_ALPBSSN
+19 IF +ALPBMENU
SET DR=DR_";201////"_ALPBMENU
+20 SET DR=DR_";9.2////"_$SELECT('$GET(ALPBTRM):"@",1:ALPBTRM)
+21 IF $GET(DR)]""
DO ^DIE
KILL DIC,DA,DR
SET DIK=DIE
SET DA=ALPBDA
+22 ; Direct set used for the ACCESS CODE value because it may contain semi-colon (;), which affects the DIE call
+23 IF $DATA(^VA(200,ALPBDA,0))
Begin DoDot:2
+24 SET $PIECE(^VA(200,ALPBDA,0),"^",3)=ALPBAC
End DoDot:2
+25 DO IX1^DIK
+26 ; VERIFY CODE needs to be set after re-indexing the record otherwise it will delete it because the ACCESS CODE was set
+27 IF $DATA(^VA(200,ALPBDA,0))
Begin DoDot:2
+28 ;PSB*3.0*144: Do not null out Verify Code.
+29 ; Previous logic nulled out the Verify Code if Termination
+30 ; Date exists. There is no need to check variable ALPBTRMX
+31 ; because the logic will not get to this point if ALPBTRMX=1.
+32 SET $PIECE(^VA(200,ALPBDA,.1),"^",2)=ALPBVC
+33 SET $PIECE(^VA(200,ALPBDA,.1),"^",1)=$HOROLOG
End DoDot:2
End DoDot:1
+34 KILL ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
+35 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
