- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m
r613 r623 1 ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07 2 ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 Q 5 ; 6 PARSIT ;PARSE MESSAGE ON RECEIVING SIDE 7 N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF 8 S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS="" ;Field separator 9 S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters 10 S CS=$E(EC) ;Component separator 11 S RS=$E(EC,2) ;Repitition separator 12 S ESC=$E(EC,3) ;Escape character 13 S SS=$E(EC,4) ;Subcomponent separator 14 S EEC=ESC_"E"_ESC ;escaped escape character 15 S EFS=ESC_"F"_ESC ;escaped field sep 16 S ECS=ESC_"S"_ESC ;escaped component sep 17 S ERS=ESC_"R"_ESC ; escaped repitition sep 18 S ESS=ESC_"T"_ESC ;escaped subcomponent separator 19 N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM 20 F X HLNEXT Q:$G(HLQUIT)'>0 D 21 . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2) 22 . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF 23 Q 24 PSTF ;Process STF segment 25 S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA" 26 S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D 27 . S ALPBSSN=$TR(ALPBSSN,"-","") 28 . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE" 29 . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE" 30 . ;Unescape Access Code 31 . S ALPBAC=$$UNESC(ALPBAC) 32 . ;Unescape Verify Code 33 . S ALPBVC=$$UNESC(ALPBVC) 34 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" 35 I $D(ALERR) G PERR 36 S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0) 37 I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L") 38 FILE ;Store File 200 data on backup system 39 N Y,DIC,DIE,DA,DR 40 Q:'$D(ALPBNAM) 41 Q:$L(ALPBSSN)'=9 42 ;Try exact SSn lookup first 43 K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC 44 ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR 45 ;If SSN lookup fails, try name lookup and add 46 I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR 47 I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D 48 . S DIE="^VA(200,",DR="2////^S X=ALPBAC" 49 . ;Update name too 50 . S DR=DR_";.01////^S X=ALPBNAM" 51 . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS" 52 . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN" 53 . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC" 54 . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU" 55 . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM" 56 . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK 57 K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM 58 Q 59 UNESC(ST,PR) ;Unescape string from message 60 ;ST=String to translate 61 ;PR=Event Protocol to set up HL array variables (optional) 62 ;First, do the escape character 63 I $G(ST)="" Q "" 64 S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL) 65 I '$D(HL) D 66 . S HL("FS")="^" 67 . S HL("ECH")="~|\&" 68 S FS=$G(HL("FS")) I FS="" Q "" ;Field separator 69 S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters 70 S CS=$E(EC) ;Component separator 71 S RS=$E(EC,2) ;Repitition separator 72 S ESC=$E(EC,3) ;Escape character 73 S SS=$E(EC,4) ;Subcomponent separator 74 S EEC=ESC_"E"_ESC ;escaped escape character 75 S EFS=ESC_"F"_ESC ;escaped field sep 76 S ECS=ESC_"S"_ESC ;escaped component sep 77 S ERS=ESC_"R"_ESC ; escaped repitition sep 78 S ESS=ESC_"T"_ESC ;escaped subcomponent separator 79 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 80 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) 81 I $G(L)]"" S ST=L 82 ; 83 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 84 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) 85 I $G(L)]"" S ST=L 86 ; 87 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 88 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) 89 I $G(L)]"" S ST=L 90 ; 91 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 92 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) 93 I $G(L)]"" S ST=L 94 ; 95 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 96 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) 97 I $G(L)]"" S ST=L 98 K I,J,K,L,X 99 Q ST 100 PERR ;PROCESSING ERRORS 101 H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR 102 K ALERR 103 Q 1 ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003 07:59 2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004 3 Q 4 ; 5 PARSIT ;PARSE MESSAGE ON RECEIVING SIDE 6 N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF 7 S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS="" ;Field separator 8 S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters 9 S CS=$E(EC) ;Component separator 10 S RS=$E(EC,2) ;Repitition separator 11 S ESC=$E(EC,3) ;Escape character 12 S SS=$E(EC,4) ;Subcomponent separator 13 S EEC=ESC_"E"_ESC ;escaped escape character 14 S EFS=ESC_"F"_ESC ;escaped field sep 15 S ECS=ESC_"S"_ESC ;escaped component sep 16 S ERS=ESC_"R"_ESC ; escaped repitition sep 17 S ESS=ESC_"T"_ESC ;escaped subcomponent separator 18 N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM 19 F X HLNEXT Q:$G(HLQUIT)'>0 D 20 . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2) 21 . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF 22 Q 23 PSTF ;Process STF segment 24 S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA" 25 S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D 26 . S ALPBSSN=$TR(ALPBSSN,"-","") 27 . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE" 28 . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE" 29 . ;Unescape Access Code 30 . S ALPBAC=$$UNESC(ALPBAC) 31 . ;Unescape Verify Code 32 . S ALPBVC=$$UNESC(ALPBVC) 33 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" 34 I $D(ALERR) G PERR 35 S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0) 36 I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L") 37 FILE ;Store File 200 data on backup system 38 N Y,DIC,DIE,DA,DR 39 Q:'$D(ALPBNAM) 40 Q:$L(ALPBSSN)'=9 41 ;Try exact SSn lookup first 42 K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC 43 ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR 44 ;If SSN lookup fails, try name lookup and add 45 I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR 46 I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D 47 . S DIE="^VA(200,",DR="2////^S X=ALPBAC" 48 . ;Update name too 49 . S DR=DR_";.01////^S X=ALPBNAM" 50 . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS" 51 . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN" 52 . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC" 53 . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU" 54 . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM" 55 . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK 56 K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM 57 Q 58 UNESC(ST,PR) ;Unescape string from message 59 ;ST=String to translate 60 ;PR=Event Protocol to set up HL array variables (optional) 61 ;First, do the escape character 62 I $G(ST)="" Q "" 63 S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL) 64 I '$D(HL) D 65 . S HL("FS")="^" 66 . S HL("ECH")="~|\&" 67 S FS=$G(HL("FS")) I FS="" Q "" ;Field separator 68 S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters 69 S CS=$E(EC) ;Component separator 70 S RS=$E(EC,2) ;Repitition separator 71 S ESC=$E(EC,3) ;Escape character 72 S SS=$E(EC,4) ;Subcomponent separator 73 S EEC=ESC_"E"_ESC ;escaped escape character 74 S EFS=ESC_"F"_ESC ;escaped field sep 75 S ECS=ESC_"S"_ESC ;escaped component sep 76 S ERS=ESC_"R"_ESC ; escaped repitition sep 77 S ESS=ESC_"T"_ESC ;escaped subcomponent separator 78 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 79 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) 80 I $G(L)]"" S ST=L 81 ; 82 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 83 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) 84 I $G(L)]"" S ST=L 85 ; 86 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 87 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) 88 I $G(L)]"" S ST=L 89 ; 90 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 91 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) 92 I $G(L)]"" S ST=L 93 ; 94 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 95 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) 96 I $G(L)]"" S ST=L 97 K I,J,K,L,X 98 Q ST 99 PERR ;PROCESSING ERRORS 100 H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR 101 K ALERR 102 Q
Note:
See TracChangeset
for help on using the changeset viewer.
