source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN.m@ 1166

Last change on this file since 1166 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 6.4 KB
Line 
1ALPBGEN ;SFVAMC/JC - Build HL7 PMU messages ;03/11/2004 15:54
2 ;;3.0;BAR CODE MED ADMIN;**7,8**;March 2004
3HL7(XUIEN,XUFLG,XUSR) ;GENERATE MESSAGE - For Subscriber to XUSER DATA REQUEST (BCBU PMU MESSAGE BUILDER)
4 ;Build HL7 PMU~B01 or B02 message from array XUSR() and XUNAME()
5 ;B01=Personnel Add/Create event type
6 ;B02=Personnel Update event type
7 ;
8 ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
9 Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
10 Q:'$D(XUSR) ;Array of user data from Kernel
11 Q:'$D(XUIEN) ;Internal entry of user required
12 ;
13 ;SFVAMC/JC - 10/8/03 ADD CHECK FOR BCMA USER STATUS
14 Q:+$$ISBCMA^ALPBGEN2(XUIEN)<1
15 ;
16 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
17 S ALPBEVN=$S(XUFLG=1:"PSB BCBU PMU_B01 EVENT",1:"PSB BCBU PMU_B02 EVENT")
18 S ALPBRCV=$S(XUFLG=1:"PSB BCBU PMU_B01 RECV",1:"PSB BCBU PMU_B02 RECV")
19 K HL D INIT^HLFNC2(ALPBEVN,.HL)
20 I +$G(HL) W !,HL Q ;SETUP ERROR or no subscribers.
21 S N=0
22 S MT=$S(XUFLG=1:"B01",1:"B02")
23 S FS=$G(HL("FS")) Q:FS="" ;Field separator
24 S EC=$G(HL("ECH")) Q:EC="" ;Encoding Characters
25 S CS=$E(EC) ;Component separator
26 S RS=$E(EC,2) ;Repetition separator
27 S ESC=$E(EC,3) ;Escape character
28 S SS=$E(EC,4) ;Subcomponent separator
29 S EEC=ESC_"E"_ESC ;escaped escape character
30 S EFS=ESC_"F"_ESC ;escaped field separator
31 S ECS=ESC_"S"_ESC ;escaped component separator
32 S ERS=ESC_"R"_ESC ; escaped Repetition separator
33 S ESS=ESC_"T"_ESC ;escaped subcomponent separator
34EVN ;EVN segment
35 S N=N+1
36 S HLA("HLS",N)="EVN"_FS_MT_FS_$$FMTHL7^XLFDT($$NOW^XLFDT)
37GSTF ;Generate Staff Detail Segment
38 N ALPBSSN,STF S STF="STF"
39 S $P(STF,FS,2)=XUIEN_CS_200_CS_"VISTA" ;Primary Key
40 ;Staff ID Code
41 ;SSN Incorrect variable reference before transmit to workstation
42 ;also don't plus SSN
43 ;S ALPBSSN=$TR($G(XUSR("ALPBSSN")),"-","") S:+ALPBSSN ALPBSSN=$$M10^HLFNC(ALPBSSN,EC) S:'+ALPBSSN ALPBSSN=ALPBSSN_CS_""_CS_"LOCAL"
44 S ALPBSSN=$TR($G(XUSR("SSN")),"-","") Q:$L(ALPBSSN)'=9 S ALPBSSN=$$M10^HLFNC(ALPBSSN,EC)
45 S $P(STF,FS,3)=ALPBSSN_CS_"USSSA"_CS_"SS"_RS_$$ESC($G(XUSR("ACCESS CODE")))_RS_$$ESC($G(XUSR("VERIFY CODE")))
46GSTNM ;Staff Name
47 N SN S SN=""
48 I $D(XUSR("HL7NAME")) D
49 . S XUSR("HL7NAME")=$TR(XUSR("HL7NAME"),"~",CS)
50 . S SN=XUSR("HL7NAME")
51 I '$D(XUSR("HL7NAME")),$D(XUSR("NAME")) D
52 . S SN=$TR(XUSR("NAME"),",",CS)
53 S $P(STF,FS,4)=SN
54 ;Active/Inactive (Disuser=1 or 0 or null)
55 S $P(STF,FS,8)=$S(XUSR("DISUSER")=1:"I",1:"A")
56 ;Termination Date
57 I XUSR("TERMINATION DATE")]"" S $P(STF,FS,14)=$$FMTHL7^XLFDT(XUSR("TERMINATION DATE"))
58 ;Add to HL7 array
59 S N=N+1,HLA("HLS",N)=STF
60 ;Send the message
61 Q:'$D(HLA)
62 ;Check user's divisions
63SEND K HLL S ALPBDIV="" F S ALPBDIV=$O(XUSR("DIV",ALPBDIV)) Q:ALPBDIV="" D
64 . K DIC,D,X,Y
65 . S DIC="^DG(40.8,",D="AD",X=ALPBDIV,DIC(0)="XN"
66 . D IX^DIC
67 . Q:+Y'>0
68 . S ALPBDIV1=+Y
69 . K DIC,D,X,Y,ALPHLL
70 . D GET^ALPBPARM(.ALPHLL,ALPBDIV1)
71 . I $D(ALPHLL) S I=0 F S I=$O(ALPHLL("LINKS",I)) Q:I<1 D
72 . . S $P(ALPHLL("LINKS",I),"^",1)=ALPBRCV
73 . . S HLL("LINKS",($O(HLL("LINKS",999999),-1)+1))=ALPHLL("LINKS",I)
74 K ALPHLL
75 ;. K DIC,D,X,Y
76 ;. D GET^ALPBPARM(.HLL,ALPBDIV1)
77 ;. I $D(HLL) S I=0 F S I=$O(HLL("LINKS",I)) Q:I<1 S $P(HLL("LINKS",I),"^",1)=ALPBRCV
78 ;If no division assoc. use defaults
79 I $O(XUSR("DIV",0))=""!('$D(HLL)) D GET^ALPBPARM(.HLL,"","",ALPBRCV)
80 K MYRESULT
81 I '$D(HLL) S MYRESULT="1-No subscribers" Q
82 D GENERATE^HLMA(ALPBEVN,"LM",1,.MYRESULT)
83 I $P(MYRESULT,U,2)]"" S ALERR=MYRESULT D SERR
84 Q
85 ;
86ESC(ST,PR) ;Translate reserved characters to escape sequences in Access/Verify
87 ;ST=String to translate
88 ;PR=Event Protocol to set up HL array variables (optional)
89 ;First, do the escape character
90 I $G(ST)']"" Q ""
91 S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
92 I '$D(HL) D
93 . S HL("FS")="^"
94 . S HL("ECH")="~|\&"
95 S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
96 S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters
97 S CS=$E(EC) ;Component separator
98 S RS=$E(EC,2) ;Repitition separator
99 S ESC=$E(EC,3) ;Escape character
100 S SS=$E(EC,4) ;Subcomponent separator
101 S EEC=ESC_"E"_ESC ;escaped escape character
102 S EFS=ESC_"F"_ESC ;escaped field sep
103 S ECS=ESC_"S"_ESC ;escaped component sep
104 S ERS=ESC_"R"_ESC ; escaped repitition sep
105 S ESS=ESC_"T"_ESC ;escaped subcomponent separator
106 F I=1:1:$L(ST) S J=$E(ST,I),^TMP($J,I)=J D
107 . S:J=ESC ^TMP($J,I)=EEC
108 . S:J=FS ^TMP($J,I)=EFS
109 . S:J=CS ^TMP($J,I)=ECS
110 . S:J=RS ^TMP($J,I)=ERS
111 . S:J=SS ^TMP($J,I)=ESS
112 S I=0,ST="" F S I=$O(^TMP($J,I)) Q:I<1 S ST=ST_^TMP($J,I)
113 K ^TMP($J)
114 Q ST
115UNESC(ST,PR) ;Unescape string from message
116 ;ST=String to translate
117 ;PR=Event Protocol to set up HL array variables (optional)
118 ;First, do the escape character
119 I $G(ST)="" Q ""
120 S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
121 I '$D(HL) D
122 . S HL("FS")="^"
123 . S HL("ECH")="~|\&"
124 S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
125 S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters
126 S CS=$E(EC) ;Component separator
127 S RS=$E(EC,2) ;Repitition separator
128 S ESC=$E(EC,3) ;Escape character
129 S SS=$E(EC,4) ;Subcomponent separator
130 S EEC=ESC_"E"_ESC ;escaped escape character
131 S EFS=ESC_"F"_ESC ;escaped field sep
132 S ECS=ESC_"S"_ESC ;escaped component sep
133 S ERS=ESC_"R"_ESC ; escaped repitition sep
134 S ESS=ESC_"T"_ESC ;escaped subcomponent separator
135 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
136 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)
137 I $G(L)]"" S ST=L
138 ;
139 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
140 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)
141 I $G(L)]"" S ST=L
142 ;
143 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
144 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)
145 I $G(L)]"" S ST=L
146 ;
147 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
148 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)
149 I $G(L)]"" S ST=L
150 ;
151 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
152 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)
153 I $G(L)]"" S ST=L
154 K I,J,K,L,X
155 Q ST
156 ;
157SERR ;SEND ERRORS
158 K XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
159 S XQA("G.PSB BCBU ERRORS")=""
160 S XQAMSG="Error sending HL7 message "_$G(HL("MID"))_". Header in HLMA("_$G(HLMTIENS)_"Error: "_ALERR
161 D SETUP^XQALERT
162 Q
Note: See TracBrowser for help on using the repository browser.