source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORELD1.m@ 1806

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

initial load of WorldVistAEHR
File size: 10.9 KB
RevLine 
[613]1PSORELD1 ;BIR/PWC-HL7 V.2.4 EXTERNAL INTERFACE RELEASE DATE/TIME CONT. ;5:23 AM 31 Jan 2008
2 ;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997;Build 4
3 ;Modified from FOIA VISTA,
4 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
5 ;General Public License See attached copy of the License.
6 ;
7 ;This program is free software; you can redistribute it and/or modify
8 ;it under the terms of the GNU General Public License as published by
9 ;the Free Software Foundation; either version 2 of the License, or
10 ;(at your option) any later version.
11 ;
12 ;This program is distributed in the hope that it will be useful,
13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;GNU General Public License for more details.
16 ;
17 ;You should have received a copy of the GNU General Public License along
18 ;with this program; if not, write to the Free Software Foundation, Inc.,
19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 ;
21 ;HLFNC supp. by DBIA 10106
22 ;PSNAPIS supp. by DBIA 2531
23 ;VASITE supp. by DBIA 10112
24 ;VADPT supp. by DBIA 10061
25 ;EN^DIQ1 supp. by DBIA 100
26 ;EN^VAFHLPID supp. by DBIA 263
27 ;EN^VAFHLZTA supp. by DBIA 758
28 ;BLDPID^VAFCQRY supp. by DBIA 3630
29 ;MAKEIT^VAFHLU supp. by DBIA 4346
30 ;PSDRUG supp. by DBIA 221
31 ;PS(50.7 supp. by DBIA 2223
32 ;PS(50.606 supp. by DBIA 2174
33 ;PS(50.607 supp. by DBIA 2221
34 ;PS(55 supp. by DBIA 2228
35 ;PSNDF(50.6 supp. by DBIA 2195
36 ;DIC(5 supp. by DBIA 10056
37 ;DPT supp. by DBIA 3097
38 ;SC supp. by DBIA 10040
39 ;SEGPRSE^SCMSVUT5 supp. by DBIA 4347
40 ;SEQPRSE^SCMSVUT5 supp. by DBIA 4347
41 ;
42INIT D GETDATA
43 D PID(.PSI),PV1(.PSI),PV2(.PSI),ORC(.PSI),RXE(.PSI),RXD(.PSI)
44 ; clean up data set by GETDATA
45 K BINGO,RELDT,SITE,SITADD,SITPHN,PSOXN,PSOXN2,PSND1,PSND2,PSND3,PRODUCT,PSOPROD,VANAME
46 K UNIT,PSDOSE,PODOSENM,POIPTR,NRFL,DISPDT,COPAY,ERR,PSONDC,NFDL,NFLD,PSZIP,PSOHZIP,TRADENM,X,Y,UU
47 QUIT
48 ; ========
49GETDATA ; this is the place to set all data needed for several segments
50 I $G(FP)="F"&('$G(FPN)) D ;original
51 . S FDT=$P(^PSRX(IRXN,2),"^",2),VPHARMID=$P(^(2),"^",10),DISPDT=$P(^(2),"^",5),EXDT=$P(^(2),"^",6),PSONDC=$P(^(2),"^",7)
52 . S PVDR=$P(^PSRX(IRXN,0),"^",4),QTY=$P(^(0),"^",7),DASPLY=$P(^(0),"^",8),MW=$P(^(0),"^",11),EBY=$P(^(0),"^",16)
53 I $G(FP)="F"&($G(FPN)) D ;refill
54 . S FDT=$P(^PSRX(IRXN,1,FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",19)
55 . S EXDT=$S($P(^(0),"^",15):$P(^(0),"^",15),1:$P(^PSRX(IRXN,2),"^",6))
56 . S VPHARMID=$S($P(^PSRX(IRXN,1,FPN,0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10))
57 . S EBY=$S($P(^PSRX(IRXN,1,FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17)
58 . S PSONDC=$S($P($G(^PSRX(IRXN,1,FPN,1)),"^",3):$P(^(1),"^",3),1:$P(^PSRX(IRXN,2),"^",7))
59 I $G(FP)="P" D ;partial
60 . S FDT=$P(^PSRX(IRXN,"P",FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",13)
61 . S PVDR=$P(^(0),"^",17),EXDT=$P(^PSRX(IRXN,2),"^",6)
62 . S EBY=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7))
63 . S VPHARMID=$S($P(^(0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10)),PVDR=$P(^PSRX(IRXN,"P",FPN,0),"^",17)
64 . S PSONDC=$S($P(^PSRX(IRXN,"P",FPN,0),"^",12):$P(^(0),"^",12),1:$P(^PSRX(IRXN,2),"^",7))
65 S EFDT=$P(^PSRX(IRXN,2),"^",2) S:$G(EFDT) EFDT=$$HLDATE^HLFNC(EFDT,"DT")
66 S ISDT=$P(^PSRX(IRXN,0),"^",13) S:$G(ISDT) ISDT=$$HLDATE^HLFNC(ISDT,"DT")
67 S DEAID=$$GET1^DIQ(200,PVDR_",",53.2)
68 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=VPHARMID D ^DIC
69 S VPHARM=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
70 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=EBY D ^DIC
71 S EBY1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
72 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=PVDR D ^DIC
73 S PVDR1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
74 S PRIORDT=$P(^PSRX(IRXN,3),"^",4),PRIORDT=$$HLDATE^HLFNC(PRIORDT,"DT")
75 S FDT=$$HLDATE^HLFNC(FDT,"DT")
76 S:$G(DISPDT) DISPDT=$$HLDATE^HLFNC(DISPDT,"DT")
77 S:$G(EXDT) EXDT=$$HLDATE^HLFNC(EXDT,"DT")
78 S EBY1=$$HLNAME^HLFNC(EBY1,HLECH),PVDR1=$$HLNAME^HLFNC(PVDR1,HLECH)
79 S FIN=$P(^PSRX(IRXN,"OR1"),"^",5)
80 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=FIN D ^DIC
81 S FIN1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
82 S SITE=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
83 S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
84 S CLN=+$P(^PSRX(IRXN,0),"^",5),CLN1=$S($D(^SC(CLN,0)):$P(^(0),"^",1),1:"UNKNOWN")
85 S CSINER=$P(^PSRX(IRXN,3),"^",3)
86 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=CSINER D ^DIC
87 S CSINER1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
88 D 6^VADPT
89 I MW="W" S MP=$S($P($G(^PSRX(IRXN,"MP")),"^"):$P(^("MP"),"^"),1:"""""")
90 S X=$S($D(^PS(55,DFN,0)):^(0),1:""),CAP=$P(X,"^",2)
91 S:MW="M" MP="""""",MW=$S($P(X,"^",3):"R",1:MW) S MW=$S(MW="M":"REGULAR MAIL",MW="R":"CERTIFIED MAIL",MW="W":"WINDOW",1:"""""")
92 I (($P(^PSRX(IRXN,"STA"),"^")>0)&($P(^("STA"),"^")'=2)&('$G(PSODBQ)))!'$G(^PSRX(IRXN,"IB")) S COPAY="NO COPAY"
93 E S COPAY="COPAY"
94 S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
95 S DATE=$$HLDATE^HLFNC(FDT) D NOW^%DTC S NOW=$$HLDATE^HLFNC(%,"TS")
96 S OLAN=$$GET1^DIQ(55,IDGN_",",106.1,"I"),OTLAN="N" I OLAN=1 S OTLAN="Y"
97 S CSUB1=$$GET1^DIQ(50,IDGN_",",3),CSUB="N" I $E(CSUB1,1)>1&($E(CSUB1,1)<6) S CSUB="Y"
98 S SCTALK=+$G(^PS(55,"ASTALK",$P(^PSRX(IRXN,0),"^",2)))
99 K DIC,DR,DIQ S DA=$P($$SITE^VASITE(),"^") I DA D
100 .K PSOINST S DIC=4,DIQ(0)="I",DR=99,DIQ="PSOINST" D EN^DIQ1
101 .S PSOINST=PSOINST(4,DA,99,"I") K DIC,DA,DR,DIQ,PSOINST(4)
102 S DRUG=$$ZZ^PSOSUTL(IRXN),DEA=$P(^PSDRUG(IDGN,0),"^",3),WARN=$P($G(^(0)),"^",8)
103 S PSND1=$P($G(^PSDRUG(IDGN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3)
104 K PSOXN,PSOXN2,PSOPROD
105 I PSND1,PSND3 D
106 .S PSOPROD=$$PROD2^PSNAPIS(PSND1,PSND3),VANAME=$P($G(PSOPROD),"^",1)
107 .I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3),UNIT=$P($G(PSOXN),"^",6) S PSOXN=$P($G(PSOXN),"^",5) S PSOXN2=$$PROD2^PSNAPIS(PSND1,PSND3) Q
108 .S PSOXN2=$G(^PSNDF(PSND1,5,PSND3,2))
109 .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0))
110 .I $G(PRODUCT)'="" S PSOXN=+$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^"),UNIT=$P($G(^PS(50.607,PSOXN,0)),"^")
111 S NFLD=0,UU="" F S UU=$O(^PSRX(IRXN,1,UU)) Q:UU="" S:$D(^PSRX(IRXN,1,UU,0)) NFLD=NFLD+1
112 S NRFL=$P(^PSRX(IRXN,0),"^",9),RFRM=(NRFL-NFLD)
113 QUIT
114 ; =========
115PID(PSI) ;patient ID segment
116 QUIT:'$D(DFN)!$D(PAS)
117 ;
118 S HLFS=HL1("FS"),HLECH=HL1("ECH"),HLQ=HL1("Q"),HLVER=HL1("VER")
119 K PSPID,PSPID1
120 D BLDPID^VAFCQRY(DFN,"","3,5,7,8,11,13",.PSPID,.HL1,.ERR)
121 ; put PID in format needed for segment parser
122 S PSPID=PSPID(1) K PSPID(1)
123 S (X,Y)=1 F S X=+$O(PSPID(X)) Q:'X S PSPID(Y)=PSPID(X),Y=Y+1 K PSPID(X)
124 ;parse PID into individual fields
125 K PRSEPID D SEGPRSE^SCMSVUT5("PSPID","PRSEPID",HL1("FS"))
126 ; parse address into individual components
127 K ADDSEQ D SEQPRSE^SCMSVUT5($NA(PRSEPID(11)),"ADDSEQ",HL1("ECH"))
128 ; build ZTA (Temporary Address)
129 K X2 S X2=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,",1)
130 ; parse X2 (ZTA) into individual fields if temp add. exists
131 I $P(X2,HLFS,3) D
132 . K PRSEZTA D SEGPRSE^SCMSVUT5("X2","PRSEZTA",HL1("FS"))
133 . ; parse temporary address into individual components
134 . K TMPADD D SEQPRSE^SCMSVUT5($NA(PRSEZTA(5)),"TMPADD",HL1("ECH"))
135 . ; add temporary address as next repitition in PID segment
136 . S SPOT=1+$O(ADDSEQ(""),-1)
137 . M ADDSEQ(SPOT)=TMPADD(1)
138 . S ADDSEQ(SPOT,7)="C"
139 . S ADDSEQ(SPOT,9)=PRSEZTA(6)
140 . S ADDSEQ(SPOT,12,1)=PRSEZTA(3)
141 . S ADDSEQ(SPOT,12,2)=PRSEZTA(4)
142 . ;move address sequence back into parse PID segment
143 . K PRSEPID(11) M PRSEPID(11)=ADDSEQ
144 ; rebuild PID segment
145 K PSPID1 D MAKEIT^VAFHLU("PID",.PRSEPID,.PSPID1,.PSPID1)
146 ;put rebuilt PID into format used by $$EN^VAFCQRY
147 K PSPID S PSPID(1)=PSPID1
148 S X=0,Y=2 F S X=+$O(PSPID1(X)) Q:'X S PSPID(Y)=PSPID1(X) S Y=Y+1
149 S CNT=0 F I=1:1 Q:'$D(PSPID(I)) D
150 . I I=1 S ^TMP("PSO",$J,PSI)=PSPID(I) Q
151 . S CNT=CNT+1 S ^TMP("PSO",$J,PSI,CNT)=PSPID(I)
152 S PSI=PSI+1
153 S PAS=1
154 K PSPID,PSPID1,PRSEPID,PRSEZTA,SPOT,TMPADD,ADDSEQ
155 QUIT
156 ; =========
157PV1(PSI) ;patient visit segment
158 N PV1 ;hardcoded to letter O for Outpatient (Patient class)
159 S PV1="PV1"_FS_FS_"O"_FS
160 S ^TMP("PSO",$J,PSI)=PV1
161 S PSI=PSI+1
162 QUIT
163 ; =========
164PV2(PSI) ;patient visit segment (additional information)
165 ;PATIENT STATUS AND COPAY
166 N PV2 S PV1=""
167 S $P(PV2,"|",24)=$P($G(^PS(53,+$P($G(^PSRX(IRXN,0)),"^",3),0)),"^",2)_"~"_COPAY_FS
168 S ^TMP("PSO",$J,PSI)="PV2|"_PV2
169 S PSI=PSI+1
170 QUIT
171 ; =========
172ORC(PSI) ;common order segment
173 QUIT:'$D(DFN)
174 ;
175 N ORC S ORC=""
176 S $P(ORC,"|",1)="OE"
177 S $P(ORC,"|",2)=IRXN_CS_"OP7.0"
178 S $P(ORC,"|",9)=ISDT
179 S $P(ORC,"|",10)=EBY_CS_EBY1
180 S $P(ORC,"|",12)=PVDR_CS_PVDR1
181 S $P(ORC,"|",13)=$G(PSOLAP)
182 S $P(ORC,"|",15)=EFDT
183 S $P(ORC,"|",16)=$S($G(RXPR(IRXN)):"PARTIAL",$G(RXFL(IRXN)):"REFILL",$G(RXRP(IRXN)):"REPRINT",1:"NEW")
184 S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC"
185 S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"")
186 ; 3080129 - RCR
187 ; Segment 21 is incomplete. Truncated.
188 ; S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)_
189 S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)
190 S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
191 S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP
192 S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4)
193 S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1
194 QUIT
195 ; ===========
196RXE(PSI) ;Pharmacy/treatment Encoded Order segment
197 QUIT:'$D(DFN)
198 ;
199 N RXE,PSDRG10
200 S RXE=""
201 S $P(RXE,"|",1)=""""""
202 S PSDRG10=$P($G(^PSDRUG(IDGN,"ND")),"^",10)
203 ;
204 ; 29JAN2008 - RCR ; The problem is tha/home/rcr/PSORELD1.mt the last $PIECE is incomplete. This needs to be validated
205 ; S $P(RXE,"|",2)=$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^"_CS_"99PSD"
206 S $P(RXE,"|",2)=$S(PSDRG10'="":PSDRG10,($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
207 S $P(RXE,"|",3)=""
208 I $G(PSOXN)="" S PSOXN=""""""
209 S $P(RXE,"|",5)=PSOXN_CS_$S($G(UNIT)'="":$G(UNIT),1:"""""")_CS_"99PSU"
210 S POIPTR=$P($G(^PSRX(IRXN,"OR1")),"^")
211 I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
212 I '$G(POIPTR) S PODOSE=$P($G(^PS(50.7,$P($G(^PSDRUG(IDGN,2)),"^"),0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
213 S TRADENM=$G(^PSRX(IRXN,"TN"))
214 S $P(RXE,"|",6)=PODOSE_CS_PODOSENM_CS_"99PSF"
215 S $P(RXE,"|",8)=MP
216 ;
217 ; 3080129 - RCR
218 ; Segment 9 is incomplete, truncated.
219 ; S $P(RXE,"|",9)=TRADENM_
220 S $P(RXE,"|",9)=TRADENM
221 S $P(RXE,"|",15)=$P(^PSRX(IRXN,0),"^")
222 S ^TMP("PSO",$J,PSI)="RXE|"_RXE,PSI=PSI+1
223 QUIT
224 ; =========
225RXD(PSI) ;pharmacy dispense segment
226 QUIT:'$D(DFN)
227 ;
228 N RXD S RXD=""
229 S $P(RXD,"|",1)=$S($G(NFLD):NFLD,1:0)
230 S $P(RXD,"|",2)=CS_$G(VANAME)
231 S $P(RXD,"|",3)=DISPDT
232 S $P(RXD,"|",7)=$P(^PSRX(IRXN,0),"^")
233 S $P(RXD,"|",9)=RELDT_RS_BINGO_RS_PSONDC
234 QUIT
235 ; ========
Note: See TracBrowser for help on using the repository browser.