source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m@ 812

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002
2 ;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;This routine will intercept the HL7 message that it sent from Pharmacy
5 ;to CPRS to update order information. The message is then parsed and
6 ;repackage so it can be sent to the BCBU workstation.
7 ;
8 ; Reference/IA
9 ; EN^PSJBCBU/3876
10 ; $$EN^VAFHLPID/263
11 ; $$EN^VAFHAPV1/4512
12 ; EN1^GMRADPT/10099
13 ; EN^PSJBCMA1/2829
14 ;
15IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
16 N VAIN,ALPMSG
17 S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
18 I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
19 S MSH=0
20 F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH"
21 I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
22 S MSFS=$E(@ALPMSG@(MSH),4,4)
23 S MSCS=$E(@ALPMSG@(MSH),5,5)
24 S MSCH=$E(@ALPMSG@(MSH),6,6)
25 S MSCTR=$E(@ALPMSG@(MSH),4,8)
26 ;The message is confirmed to be a Pharmacy message
27 I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
28 ;A PID and PV1 segment is required for this message
29 S PID=0
30 F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID"
31 I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
32 ;Also the patient must have an inpatient status
33 S PV1=0
34 F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1"
35 I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
36 I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
37 S ORC=0
38 F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC"
39 I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
40 ;RE-BUILDING THE MESSAGE FOR BCBU
41 S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
42 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
43 S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
44 I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
45 K ALPB
46 D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
47SEED ;Entry point for ^ALPBIND
48 N VAIN
49 D INIT
50 S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D
51 . ;convert and move the message to the HLA array for transport
52 . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
53 . ;Now check for continuations
54 . S SUB1=0
55 . F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D
56 . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
57 . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
58 . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
59 . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
60 K HLA("HLS",MSH)
61 I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
62 S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
63 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
64 S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
65 ;Fix RXE segement for Administration Type
66 D RXE
67 ;Get the Division that the patient is associated with
68 D PDIV
69 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
70 I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
71 ;SET NEW PV1
72 D NOW^%DTC
73 S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
74 S HLA("HLS",PV1)=STRING
75 I +ORC>0 D
76 . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
77 . Q:ALPST=""
78 . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
79 D AL1
80 ;Capture message to review for testing before sending
81 D SEND
82EXIT ;EXIT and kill
83 K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
84 K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
85 K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
86 K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
87 Q ALPRSLT
88INI() ;INTIAL SET UP ENTRY
89 G SEED
90INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
91 ;SET UP ENVIRONMENT FOR MESSAGE
92 K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
93 S EVENT="PSB BCBU ORM SEND"
94 D INIT^HLFNC2(EVENT,.HL,1)
95 S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
96 Q
97SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
98 K ALPRSLT,ALPOPTS
99 D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
100 Q
101AL1 ;ALLERGY SEGMENT BUILD
102 ;The will build the ALP segment with the curent allergies
103 ;for the patient to be added to the message
104 N DFN
105 Q:+ALPDFN'>0
106 K GMRAL
107 S DFN=ALPDFN
108 S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN
109 D EN1^GMRADPT
110 Q:'$D(GMRAL)
111 S ALPI=0,ALPC=1,ALPSYM=""
112 F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D
113 . S ALPADR=""
114 . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
115 . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
116 . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
117 . ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D
118 . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
119 . ;S $P(ALPDATA,HLFS,6)=ALPSYM
120 . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
121 . S ALPC=ALPC+1
122 K GMRAL
123 Q
124RXE ;
125 Q:+$G(RXE)'>0
126 K ^TMP("PSJ1",$J)
127 Q:'$D(HLA("HLS",RXE))
128 S DATA=HLA("HLS",RXE)
129 D EN^PSJBCMA1(ALPDFN,ALPORD,1)
130 S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
131 Q:TYP="CONTINUOUS"
132 Q:TYP="FILL ON REQUEST"
133 S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
134 I ALP1[TYP Q
135 I ALP2[TYP Q
136 S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
137 S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
138 S HLA("HLS",RXE)=DATA
139 K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
140 Q
141PDIV ;PATIENT DIVISION
142 ;Check ALPBMDT Variable
143 S:+$G(ALPBMDT)'>0 ALPBMDT=0
144 S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
145 ;Screen Dom
146 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q
147 ;Now do I send the Message or not Based of Division
148 I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
149 I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
150 Q
151MEDL(ALPML) ;Use this entry to send MedLog messages
152 N VAIN
153 ;ALPML is the IEN of the MedLog for file #53.79
154 I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
155 I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
156 ;First get the required HL7 Variables
157 D INIT
158 ;Need to build the PID, PV1 and ORC segments
159 S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
160 I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
161 ;Get the Division that the patient is associated with
162 D PDIV
163 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
164 I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
165 S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
166 S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
167 S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
168 S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
169 S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
170 S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
171 I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
172 S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
173 I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
174 S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
175 I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
176 S HLA("HLS",1)=PID
177 S HLA("HLS",2)=PV1
178 ;BUILD ORC SEGMENT
179 S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
180 S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
181 S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
182 S HLA("HLS",3)=ORC
183 ;The Message is ready to send
184 D SEND
185 Q ALPRSLT
186 ;
187ADMQ ;Need to que a single patient init for admissions
188 S ALDFN=ALPDFN
189 S ZTDTH=$$NOW^XLFDT
190 S ZTRTN="PAT^ALPBIND"
191 S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
192 S ZTIO="",ZTSAVE("ALDFN")=""
193 D ^%ZTLOAD
194 K ZTIO,ZTDESC,ZTRTN,ZTSK
195 Q
196PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
197 N VAIN
198 I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
199 D INIT
200 ;Check Movement type. If not a discharge then don't pass date and time
201 S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
202 ;Get the Division that the patient is associated with
203 D PDIV
204 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
205 I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
206 S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
207 S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
208 S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
209 D SEND
210 I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
211 I $G(ALPTT)="ADMISSION" D ADMQ
212 ;SEND A DISCHARGE TO DIV SENDING ASIH
213 I $G(ALPTYP)[13!($G(ALPTYP)[40) D
214 .D INIT
215 .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
216 .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD
217 .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
218 .D GET^ALPBPARM(.HLL,ALPBDIV)
219 .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
220 .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
221 .S $P(HLA("HLS",2),HLFS,37)="ASIH"
222 .D SEND
223 Q ALPRSLT
Note: See TracBrowser for help on using the repository browser.