source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPHL1.m@ 1765

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

initial load of FOIAVistA 6/30/08 version

File size: 7.7 KB
Line 
1PSOTPHL1 ;BPFO/EL-CREATE HL7 BATCH MESSAGE FILE ;09/10/03
2 ;;7.0;OUTPATIENT PHARMACY;**146,153,227**;DEC 1997
3 ;
4 ; Summary:
5 ; Use of ^VAFCQRY API is approved under private IA #3630
6 ; For initial run, makes sure the "Transmission End Date" (#46.2) in
7 ; File 59.7 - Pharmacy System File is null.
8 ; If field (#46.2) is null, the system will pick up all DFN in File 52.91
9 ; from the first date of file creation to the "RunDate"-1.
10 ; If field (#46.2) has a date, the system will pick up DFN starting
11 ; from the last "Transmission End Date"+1 to the "RunDate"-1.
12 ; This program only runs on Sunday. RunTime will be 6pm.
13 ; Tab: EN^PSOTPHL1(RDT,EDT,.SDT) is the ad-hoc entry point if user
14 ; wants to run it at certain "Transmission Begin Date",
15 ; "Transmission End Date", & return actual "Transmission Begin Date".
16 ; If run is success, an audit node will be placed at File 59.7 as:
17 ; ^PS(59.7,D0,46)=TransmissionStartDt_"^"_TransmissionEndDt_"^"_MshID_"^"_MshCnt_"^"_LineCnt
18 ;
19 ; At the end of each run, this program will send out mail to the mail
20 ; group "PSO TPB HL7 EXTRACT" except the non-Sunday TaskMan check
21 ;
22 Q ; placed out of order by PSO*7*227
23 N A,B,C,CK,EDT,ERR,FRTIME,I,L,R,RDT,SDT,SET,X
24 N BCNT,DATA,DFN,EVENT,LN,MCNT,PGM,PS,PSO
25 N BBDT,BEDT,DADT,EXC,INS,PADT,PN,REASON,STA,WAITYP
26 ;
27START S CK=0 D DATE I CK=1 G ENDS
28 ;
29 D EN^PSOTPHL1(RDT,EDT,.SDT)
30 Q
31 ;
32DATE ; Check if first time run or Sunday
33 S (EDT,FRTIME,PS,SET)=0,PS=59.7
34 S EDT=$$GET1^DIQ(PS,"1,46",46.2,"I"),EDT=+EDT
35 D NOW^%DTC
36 D DW^%DTC
37 I EDT'>0 S FRTIME=1 G GDATE
38 I X'["SUN" S CK=1 Q
39 ;
40 S SDT=EDT+1
41GDATE S RDT="",SET=1
42 S RDT=$S(EDT:EDT,1:0)
43 S EDT=DT-1
44 Q
45 ;
46INIT ; Variable Initialization
47 S (BCNT,LN,MCNT,CK)=0
48 S PGM="PSOTPHL1"
49 S PSO=52.91
50 D INHL7
51 ;
52 K ^TMP("HLS",$J),^TMP(PGM,$J,EDT)
53 ;
54 Q
55 ;
56INHL7 S EVENT="PSO TPB EV"
57 I '$D(U) S U="^"
58 D INIT^HLFNC2(EVENT,.HL)
59 I $G(HL) S ERR=$P(HL,"^",2),CK=1 Q
60 D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1)
61 D INHD
62 Q
63 ;
64INHD I '$D(DTIME) S DTIME=0
65 I '$D(HL("DTM")) S HL("DTM")=HLDT1
66 I '$D(HL("FS")) S HL("FS")="^"
67 I '$D(HL("ECH")) S HL("ECH")="~|\&"
68 I '$D(HL("ETN")) S HL("ETN")="S12"
69 I '$D(HL("MTN")) S HL("MTN")="SIU"
70 I '$D(HL("MTN_ETN")) S HL("MTN_ETN")="SIU_S12"
71 I '$D(HL("PID")) S HL("PID")="P"
72 I '$D(HL("Q")) S HL("Q")=""""
73 I '$D(HL("VER")) S HL("VER")="2.4"
74 I '$D(HL("CC")) S HL("CC")="US"
75 I '$D(HL("ACAT")) S HL("ACAT")="AL"
76 I '$D(HL("APAT")) S HL("APAT")="NE"
77 I '$D(HL("SAN")) S HL("SAN")="PSO TPB-PHARM"
78 I '$D(HL("RAN")) S HL("RAN")="PSO TPB-ACC"
79 ;
80 Q
81 ;
82BHS ; CREATE "BHS" SEGMENT
83 S BCNT=BCNT+1
84 S LN=LN+1
85 ;
86 Q
87 ;
88EN(RDT,EDT,SDT) ; ENTRY POINT FOR PROCESS
89 D INIT I CK=1 G OUT
90 D BHS
91 D PROCESS
92 D BTS
93 G OUT
94 ;
95PROCESS ; Sort and Process the message body
96 I '$D(SET) S SDT=RDT,RDT=RDT-1
97 I $G(FRTIME)=1 D FRTIME
98P10 S RDT=$O(^PS(PSO,"AX",RDT)) G P30:(RDT>EDT)!(RDT="")
99 I SDT>RDT S SDT=RDT
100 S DFN=""
101P20 S DFN=$O(^PS(PSO,"AX",RDT,DFN)) G P10:DFN=""
102 I '$D(^PS(PSO,DFN,0)) K ^PS(PSO,"AX",RDT,DFN) G P20
103 S ^TMP(PGM,$J,EDT,"ZZ",DFN)=RDT
104 G P20
105 ;
106FRTIME ; To generate a complete data set for the frist time
107 S (DFN,RDT,X)=""
108 S SDT=999999999
109F10 S DFN=$O(^PS(PSO,DFN)) Q:(DFN'?1N.N)!(DFN="")
110 I '$D(^PS(PSO,DFN,0)) G F10
111 S X=$P(^PS(PSO,DFN,0),"^",2)
112 I SDT>X S SDT=X
113 S ^TMP(PGM,$J,EDT,"ZZ",DFN)=X
114 G F10
115 ;
116P30 I '$D(^TMP(PGM,$J,EDT,"ZZ")) D G GEN
117 . S MCNT=0
118 . D MSH^HLFNC2(.HL,HLMID_"-"_MCNT,.X,"")
119 . D WRITE
120 ;
121 S DFN=""
122DFN S DFN=$O(^TMP(PGM,$J,EDT,"ZZ",DFN)) G GEN:DFN=""
123 S RDT=^TMP(PGM,$J,EDT,"ZZ",DFN)
124 D EXTRACT
125 D MSH
126 D SCH
127 D PID
128 G DFN
129 ;
130GEN S HLP="" D GENERATE^HLMA(EVENT,"GB",1,.R,HLDA,.HLP)
131 Q
132 ;
133EXTRACT ; Extract data from File 52.91
134 S (A,B,BBDT,BEDT,C,DADT,DATA,EXC,INS,PADT,PN,REASON,STA,WAITYP,X)=""
135 S X=^PS(PSO,DFN,0)
136 S DATA="PN,BBDT,BEDT,REASON,DADT,WAITYP,STA,INS,EXC,PADT"
137 F I=1:1:10 S @$P(DATA,",",I)=$P(X,"^",I)
138 I $D(PADT) S PADT=$P(PADT,".")
139 I +BBDT=+RDT S HL("ETN")="S12"
140 E S HL("ETN")="S14"
141 S HL("MTN_ETN")=HL("MTN")_"_"_HL("ETN")
142 S A="BBDT,BEDT,DADT,PADT"
143 F I=1:1:4 S B=$P(A,",",I) I $G(@B)>0 S C=$$HLDATE^HLFNC(@B,"DT"),@$P(A,",",I)=C
144 Q
145 ;
146MSH ; CREATE "MSH" SEGMENT
147 S MCNT=MCNT+1
148 D MSH^HLFNC2(.HL,HLMID_"-"_MCNT,.X,"")
149 ;
150 D WRITE
151 Q
152 ;
153SCH ; CREATE "SCH" SEGMENT
154 K SCH S (X,A,B,C)="",I=0 S:REASON>9 REASON=9
155 S X="Seen by VA Provider,No/Show/Cancellation,Patient Ended"
156 S X=X_",Non-Formulary Rx not accepted,Patient Expired,All Rx's Inactive"
157 S X=X_",Exclusion,Patient Refused Appointment,Patient Unreachable"
158 S A=$P(X,",",REASON)
159 ;
160 S X="" S:EXC>3 EXC=3
161 S X="Excluded due to active Rx#"
162 S X=X_",Excluded due to actual appt<30 days from desired appt date"
163 S X=X_",Exclued due to active Rx# and actual appt<30 days from desired appt date"
164 S B=$P(X,",",EXC)
165 ;
166 I WAITYP="E" S C="EWL"
167 E I WAITYP="M" S C="Manual"
168 E I WAITYP="S" S C="Schedule"
169 E S C="S\T\E"
170 ;
171 S X=""
172 S X=HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_REASON_"~"_A
173 S X=X_HL("FS")_EXC_"~"_B_HL("FS")_WAITYP_"~"_C
174 S X=X_HL("FS")_HL("FS")_HL("FS")
175 S I=I+1,SCH(I)="SCH"_X
176 ;
177 S X="",X=X_"~~~"_DADT_"~~~~Desired Appointment Date|~~~"
178 S X=X_PADT_"~~~~Primary Care Scheduled Appointment Date|~~~"
179 S X=X_BBDT_"~~~~Date Pharmacy Benefit Began|~~~"
180 S X=X_BEDT_"~~~~Inactivation of Benefit Date|~~~"
181 S X=X_$$HLDATE^HLFNC(RDT,"DT")_"~~~~Record Change Date"
182 I $L(SCH(I)_X)<246 S SCH(I)=SCH(I)_X
183 E S I=I+1,SCH(I)=X
184 ;
185 S X="",$P(X,"^",12)=STA_"~~~"_INS_"&"_$$GET1^DIQ(4,INS_",0",.01)
186 I $L(SCH(I)_X)<246 S SCH(I)=SCH(I)_X
187 E S I=I+1,SCH(I)=X
188 ;
189 F I=1:1 S X=$G(SCH(I)) Q:X="" D
190 . I I=1 D WRITE
191 . E D WRITEN
192 Q
193 ;
194PID ; CREATE "PID" SEGMENT
195 K PID
196 D DEM^VADPT,ADD^VADPT
197 D BLDPID^PSOTPHL2(DFN,1,.PID,.HL,.ERR)
198 Q:$G(PID(1))=""
199 S X=""
200 F I=1:1 S X=$G(PID(I)) Q:X="" D
201 . I I=1 D WRITE
202 . E D WRITEN
203 Q
204 ;
205BTS ; CREATE "BTS" SEGMENT
206 S LN=LN+1
207 Q
208 ;
209WRITE ; Write single line
210 S LN=LN+1
211 S ^TMP("HLS",$J,LN)=X
212 Q
213 ;
214WRITEN ; Write multiple lines
215 S ^TMP("HLS",$J,LN,I-1)=X
216 Q
217 ;
218CLEANUP ; Clean up variables
219 K A,B,C,CK,EDT,ERR,I,L,R,RDT,SDT,X
220 K BCNT,DATA,DFN,EVENT,LN,MCNT,PGM,PS,PSO
221 K BBDT,BEDT,DADT,EXC,INS,PADT,PN,REASON,STA,WAITYP
222 Q
223 ;
224OUT ; End of compilation
225 I CK=1 G END
226 K ^TMP("HLS",$J),^TMP(PGM,$J,EDT),PID,SCH
227 I SDT>EDT S SDT=EDT
228 I $G(SET)=1 S ^PS(PS,1,46)=SDT_"^"_EDT_"^"_HLDA_"^"_MCNT_"^"_LN
229 ;
230END D MAIL
231 I $G(SET)'=1 D CLEANUP
232ENDS I $G(FRTIME)=1 D RESET
233 S:$D(ZTQUEUED) ZTREQ="@"
234 Q
235 ;
236RESET ; Reset to run tomorrow
237 D RESCH^XUTMOPT("PSO TPB HL7 EXTRACT","T+1@18:00","","24H","L")
238 Q
239 ;
240RESET1 ; Reset to run tomorrow
241 D RESET,EDIT^XUTMOPT("PSO TPB HL7 EXTRACT")
242 Q
243 ;
244MAIL ;Send mail message
245 I '$G(DUZ) Q
246 K PSOTTEXT,XMY S (XMDUZ,XMSUB,XMTEST,A,B,C,I,L,R,X)=""
247 S C="G.PSO TPB HL7 EXTRACT"
248 S XMY(C)=""
249 S PSOTTEXT(1)="SENT TO: "_C
250 S XMDUZ="PSO TPB HL7 EXTRACT"
251 S (A,B)=""
252 I '$D(SET) S A="Ad-Hoc"
253 E S A=$S(($G(FRTIME)=1):"first-time",1:"weekly")
254 S B=$S(($G(CK)=1):"unsuccessful",1:"successful")
255 S XMSUB="PSO TPB HL7 "_A_" update ** "_B_" **"
256 S A=XMSUB
257 I $G(CK)=1 D FAIL
258 E D SUCC
259 S PSOTTEXT(2)=" "
260 S PSOTTEXT(3)="The weekly generation of the HL7 Message of"
261 S PSOTTEXT(3.2)="TPB Patient Information was "_B
262 S PSOTTEXT(4)=""
263 S PSOTTEXT(5)=I
264 S PSOTTEXT(6)=L
265 S PSOTTEXT(6.2)=R
266 S PSOTTEXT(6.4)=X
267 S PSOTTEXT(7)=" "
268 D NOW^%DTC S Y=% X ^DD("DD") S PSOTTEXT(8)="The job ended at "_$G(Y)
269 S PSOTTEXT(9)=" "
270 S XMTEXT="PSOTTEXT(" N DIFROM D ^XMD
271 I $D(XMMG),(XMMG["Error =") D
272 . K XMY(C)
273 . S XMSUB=A,XMY(DUZ)="",PSOTTEXT(1)=PSOTTEXT(1)_" ("_XMMG_")",XMMG=""
274 . S XMTEXT="PSOTTEXT(" D ^XMD
275 K PSOTTEXT,XMDUZ,XMSUB,XMTEXT,XMY
276 Q
277FAIL ; Msg for unsuccessful run
278 S I="Reason: "_$S(($D(ERR)):ERR,1:"Check Event Server Protocol OR the run date")
279 S L=" "
280 S R="Please contact National Help Desk @888-596-4357"
281 S X=" "
282 Q
283 ;
284SUCC ; Msg for successful run
285 S I="Please check the PSOTPBAAC HL7 Logical Link to ensure"
286 S L="successful transmission to the Austin Automation Center."
287 S R=" "
288 S X="MSH-ID: "_HLDA
289 Q
290 ;
Note: See TracBrowser for help on using the repository browser.