source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVDF3.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1PSOVDF3 ;BIR/RTR-OUTPATIENT PHARMACY VDEF MESSAGE CONTINUED ;06/16/05
2 ;;7.0;OUTPATIENT PHARMACY;**205,235,261**;DEC 1997;Build 9
3 ;External reference to PS(50.7 supported by DBIA 2223
4 ;External refernce to PS(50.607 supported by DBIA 2221
5 ;
6DOSE(GLOBAL) ;Add Dosage information to RXE 1
7 N RES S RES=""
8 N PSODD1,PSODD2,PSODD3,PSODD5,PSODDL,PSODDN,PSORES1,PSODDUNT,PSOD1FLG
9 F PSODDL=0:0 S PSODDL=$O(GLOBAL(PSODDL)) Q:'PSODDL D
10 .S PSODDN=$G(GLOBAL(PSODDL,0)) Q:PSODDN=""
11 .S PSODD1=$P(PSODDN,"^"),PSODD2=$P(PSODDN,"^",2),PSODD3=$P(PSODDN,"^",3),PSODD5=$P(PSODDN,"^",5),PSODDUNT=""
12 .I PSODD1="",PSODD2="",PSODD5="" Q
13 .I PSODD5'="",($E(PSODD5,$L(PSODD5))'?1A) S PSODD5=PSODD5_"D"
14 .I PSODD5'="" S PSODD5=$$REPL^PSOVDF1(PSODD5)
15 .S PSOD1FLG=0
16 .I PSODD2'="",PSODD3'="",$P($G(^PS(50.607,PSODD3,0)),"^")'="" S PSOD1FLG=1,PSODDUNT=$P($G(^(0)),"^"),PSODDUNT=$$REPL^PSOVDF1(PSODDUNT) S:$G(PSODD1)'="" PSODD1=$$REPL^PSOVDF1(PSODD1),PSODD1=PSODD1_PSODDUNT
17 .I 'PSOD1FLG,$G(PSODD1)'="" S PSODD1=$$REPL^PSOVDF1(PSODD1)
18 .S PSORES1=""
19 .I PSODD1'=""!(PSODD2'="") D
20 ..I PSODD2'="" S PSODD2=$$REPL^PSOVDF1(PSODD2) S PSORES1=PSODD2 S:PSODD1'="" PSORES1=PSORES1_SEPS_PSODD1 Q
21 ..S PSORES1=SEPS_PSODD1
22 .I PSODD5'="" D
23 ..I PSORES1="" S PSORES1=SEPC_SEPC_PSODD5 Q
24 ..S PSORES1=PSORES1_SEPC_SEPC_PSODD5
25 .Q:PSORES1=""
26 .I $G(RES)'="" S RES=RES_SEPR_PSORES1 Q
27 .S RES=PSORES1
28 K TEMP
29 Q RES
30 ;
31FINISH ;Finish rest of RXE 1 segment
32 N PSOVAL1 S PSOVAL1=$P(VAL,SEPR)
33 S WR=""
34 S WR=$$GET^PSOVDF2(.GL,2,2)
35 I $G(WR)'="" S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL^PSOVDF1(WR),$P(PSOVAL1,SEPC,4)=WR,$P(PSOVAL1,SEPC,7)="FILL"
36 ; (1~5-26.1)
37 S WR=$$GET^PSOVDF2(.GL,3,5)
38 I $G(WR)'="" D
39 .S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL^PSOVDF1(WR),$P(PSOVAL1,SEPC,5)=WR,$P(PSOVAL1,SEPC,7)=$P(PSOVAL1,SEPC,7)_"/CANCEL"
40 E S WR=$$GET^PSOVDF2(.GL,2,6) I $G(WR)'="" D
41 . S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL^PSOVDF1(WR),$P(PSOVAL1,SEPC,5)=WR,$P(PSOVAL1,SEPC,7)=$P(PSOVAL1,SEPC,7)_"/EXPIRATION"
42 S $P(VAL,SEPR)=PSOVAL1
43 S WR=""
44 Q
45 ;
46REM ;Remarks for Original Fill
47 S MSG="",CTR=0
48 S VAL=$$GET^PSOVDF2(.GL,3,7)
49 I $G(VAL)="" Q
50 S VAL=$$REPL^PSOVDF1(VAL)
51 D PUT(3)
52 S CTR=CTR+1,VAL=CTR D PUT(1)
53 S VAL="RE"_SEPC_"REMARKS"_SEPC_SRC_"_12" D PUT(4)
54 S MSG="NTE"_SEPF_MSG D OUT^PSOVDF2
55 Q
56 ;
57DEL ;Deletion comments
58 S MSG=""
59 S VAL=$$GET^PSOVDF2(.GL,"D",1)
60 I $G(VAL)="" Q
61 S VAL=$$REPL^PSOVDF1(VAL)
62 D PUT(3)
63 S CTR=CTR+1,VAL=CTR D PUT(1)
64 S VAL="DE"_SEPC_"DELETION COMMENTS"_SEPC_SRC_"_108" D PUT(4)
65 S MSG="NTE"_SEPF_MSG D OUT^PSOVDF2
66 Q
67 ;
68CLOZ ; Clozapine Dosage
69 S VAL=$$REPL^PSOVDF1(VAL)
70 D PUT(5)
71 S CTR=CTR+1,VAL=CTR D PUT(1)
72 S VAL="NM" D PUT(2)
73 S VAL="CLOZAPINE DOSAGE" D PUT(3)
74 S VAL="MG/DAY" D PUT(6)
75 S VAL="F" D PUT(11)
76 S MSG="OBX"_SEPF_MSG D OUT^PSOVDF2
77 Q
78 ;
79WBC ; WBC results
80 S VAL=$$REPL^PSOVDF1(VAL)
81 D PUT(5)
82 S CTR=CTR+1,VAL=CTR D PUT(1)
83 S VAL="NM" D PUT(2)
84 S VAL="WBC RESULTS" D PUT(3)
85 S VAL="F" D PUT(11)
86 ; (14-303)
87 S VAL=$$GET^PSOVDF2(.GL,"SAND",3)
88 I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL^PSOVDF1(VAL) D PUT(14)
89 S MSG="OBX"_SEPF_MSG D OUT^PSOVDF2
90 Q
91PRC ;Provider Comments, do not piece out data, can contain up-arrow
92 S MSG=""
93 I '$D(GL("PRC")) Q
94 S VAL="" K TEMP M TEMP=GL("PRC") S VAL=$$SSETZ(.TEMP,1)
95 I $G(VAL)="" Q
96 D PUT(3)
97 S CTR=CTR+1,VAL=CTR D PUT(1)
98 S VAL="PR"_SEPC_"PROVIDER COMMENTS"_SEPC_HLINST_"_52.039_.01" D PUT(4)
99 S MSG="NTE"_SEPF_MSG D OUT^PSOVDF2
100 Q
101SSETZ(GLOBAL,P) ;Format Provider Comments
102 N RES,PSOVPCOM,PSOVDFD1,X
103 S (RES,X)="",PSOVDFD1=0
104SSET10Z S PSOVDFD1=$O(GLOBAL(PSOVDFD1)) G SSETQZ:'PSOVDFD1
105 S PSOVPCOM=GLOBAL(PSOVDFD1,0) I PSOVPCOM="" G SSET10Z
106 I $G(RES)'="" S RES=RES_" "_PSOVPCOM
107 E S RES=PSOVPCOM
108 G SSET10Z
109SSETQZ ;
110 I $G(RES)'="" S RES=$$REPL^PSOVDF1(RES)
111 Q RES
112 ;
113 Q
114 ;
115PUT(P) ; Put in MSG
116 I $G(VAL)="" Q
117 S $P(MSG,SEPF,P)=VAL
118 Q
119 ;
120SSET(GL,L) ;Instruction field
121 N RES,X,Y
122 S RES="",Y=0
123 Q:$G(L)="" RES
124 F S Y=$O(GL(Y)) Q:'Y D
125 . S X=GL(Y,0),X=$$REPL^PSOVDF1(X) I X'="" D
126 . . S X=SEPC_X
127 . . I $G(RES)'="" S RES=RES_SEPR_X_SEPC_L
128 . . E S RES=X_SEPC_L
129 . . S CTR=CTR+1
130 Q RES
131 ;
132SSETX(GLOBAL,L) ;Format Sig, don't piece out, can possibly contain up-arrow from Provider Comments
133 Q:L=""
134 N RES,PSOVSIG,PSOVDFD1,X
135 S (RES,X)="",PSOVDFD1=0
136SSET10X S PSOVDFD1=$O(GLOBAL(PSOVDFD1)) G SSETQX:'PSOVDFD1
137 S PSOVSIG=GLOBAL(PSOVDFD1,0) I PSOVSIG'="" D
138 .S PSOVSIG=$$REPL^PSOVDF1(PSOVSIG)
139 .I $G(RES)'="" S RES=RES_PSOVSIG
140 .E S RES=$S(L[115:SEPC,1:"")_PSOVSIG
141 G SSET10X
142SSETQX I $G(RES)="" Q RES
143 I L[115 S RES=RES_SEPC_L
144 E S RES=RES_SEPC_SEPC_L
145 Q RES
146 ;
147 Q
148ORC13 ;
149 S WR="",$P(WR,SEPC,2)=VAL
150 S VAL=$P($G(^SC(VAL,0)),U) I $G(VAL)'="" S VAL=$$REPL^PSOVDF1(VAL),$P(WR,SEPC)=VAL
151 S VAL=WR
152 Q
153 ;
154RXE1OF31 ;
155 D RXE31A
156 S:WR'="" VAL=WR_SEPR_VAL
157 Q
158 ;
159RXE31 ;
160 S VAL=$P($G(^PSDRUG(PSOVDRUG,0)),"^"),VAL=$$REPL^PSOVDF1(VAL)
161 S VAL=PSOVDRUG_SEPC_VAL_SEPC_HLINST_"_50_.01"
162 Q
163 ;
164RXE31A ;
165 D RXE31
166 N CMOP S CMOP=$G(^PSDRUG(PSOVDRUG,"ND"))
167 I $P(CMOP,"^",10)'="" S CMOP=$$REPL^PSOVDF1($P(CMOP,"^",10)),VAL=VAL_SEPR_CMOP_SEPC_SEPC_HLINST_"_50_27"
168 Q
169 ;
170RXE6 ;
171 N DOSF,DOS,VDOS
172 S DOSF="",VDOS=$$GET^PSOVDF2(.GL,"OR1",1)
173 Q:VDOS=""
174 I $G(VDOS) S DOS=$P($G(^PS(50.7,VDOS,0)),"^",2) D:$G(DOS)
175 . S DOSF=$$REPL^PSOVDF1($P($G(^PS(50.606,DOS,0)),"^")) D:DOSF'=""
176 . . S VAL=DOS_SEPC_DOSF_SEPC_HLINST_"_50.7_.02"
177 . . S VDOS=$$GETVUID^XTID(50.7,.02,DOS) D:$P(VDOS,"^")'=0
178 . . . S VDOS=$P(VDOS,"^"),VDOS=$$REPL^PSOVDF1(VDOS) S VAL=VAL_SEPC_VDOS_SEPC_DOSF_SEPC_"99VA_50.7_.02"
179 Q
180 ;
181FT1A7 ;
182 S TP=$$GET^PSOVDF2(.GL,"OR1",1)
183 S:$G(TP) VAL=$$REPL^PSOVDF1($P($G(^PS(50.7,TP,0)),"^"))
184 I VAL'="" S VAL=TP_SEPC_VAL_SEPC_SRC_"_39.2",VFT7=VAL
185 Q
186 ;
187FT1S2 ; ORIGINAL SEQ# 2
188 S VAL=$$GET1^DIQ(52,PSOVDFD0_",",105,"I") Q:VAL=""
189 S WR=$$GET1^DIQ(52,PSOVDFD0_",",105) Q:WR=""
190 S MSG="",WR=$$REPL^PSOVDF1(WR)
191 S VAL=VAL_SEPC_WR_SEPC_SRC_"_105" D PUT(7)
192 S VAL=$G(CTR)+1 D PUT(1)
193 S VAL=$$GET^PSOVDF2(.GL,2,2)
194 I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL^PSOVDF1(VAL) D PUT(4)
195 S VAL="CO" D PUT(6)
196 S MSG="FT1"_SEPF_MSG D OUT^PSOVDF2
197 Q
198 ;
199FT1R ; REFILL & PARTIAL
200 S VAL=$P(TP,U,11) Q:VAL=""
201 S MSG="",VAL=$$REPL^PSOVDF1(VAL) D PUT(12)
202 S VAL=PSOVDFD1 D PUT(1)
203 S VAL=$P(TP,U,1) I VAL'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL^PSOVDF1(VAL) D PUT(4)
204 S VAL="CG" D PUT(6)
205 I $G(VFT7) S VAL=VFT7 D PUT(7)
206 S MSG="FT1"_SEPF_MSG D OUT^PSOVDF2
207 Q
208 ;
209NSET(GLOBAL) ;Verb-8, Noun-3, Schedule-7, Conjuntion-5
210 N I,J,K,L,M,N,O,P,X,Y,Z
211 S (Z,X)="",Y=0,M=52.0113
212NSET1 ;
213 F S Y=$O(GLOBAL(Y)) Q:'Y D
214 . S X=$G(GLOBAL(Y,0)) Q:X=""
215 . F I=9,4,8,6 S N=I-1,O=M_"_"_N,L=HLINST_"_"_O D
216 . . S J=$P($G(X),U,I),J=$$REPL^PSOVDF1(J) I J'="" D
217 . . . S P=0 I I=6 S J=$$GET1^DIQ(M,Y_","_PSOVDFD0,N) D
218 . . . . S K=$$GETVUID^XTID(M,N) I $P(K,"^")'=0 S K=$P(K,"^"),K=$$REPL^PSOVDF1(K),J=K_SEPC_J_SEPC_"99VA_",P=1
219 . . . S J=$S(P:"",1:SEPC)_J
220 . . . I Z'="" S Z=Z_SEPR_J_$S(P:O,1:SEPC_L)
221 . . . E S Z=J_SEPC_$S(P:O,1:L)
222 . . . S CTR=CTR+1
223 Q Z
224 ;
225ORCCS ; ORC 25,4-6 - Checking the CMOP EVENT sub-file (#52.01)
226 N X,Y,RF,VU,I,ST S I=0
227 F S I=$O(GL(4,I)) Q:'I S X=GL(4,I,0) I X'="" S RF=$P(X,"^",3),Y=$P(X,"^",4) D
228 . I Y'="" S ST=$$GET1^DIQ(52.01,I_","_PSOVDFD0,3) I ST'="" S VU=$$GETVUID^XTID(52.01,3) D
229 . . I $P(VU,"^")'=0 S VU=$P(VU,"^"),VU=$$REPL^PSOVDF1(VU)
230 . . E S VU=""
231 . . S ST=$$REPL^PSOVDF1(ST)
232 . . S VCMP(RF)=$S(VU'="":VU,1:Y)_SEPC_ST_SEPC_$S(VU'="":"99VA",1:HLINST)_"_52_400"
233 Q
234 ;
235ORC25 ;
236 N PSOVALE S PSOVALE=$G(PSOVAR(52,PSOVEN,100,"E")),PSOVALE=$$REPL^PSOVDF1(PSOVALE)
237 S PSOVLV=$$GETVUID^XTID(52,100,VAL)
238 I $P($G(PSOVLV),"^")'=0 S PSOVLV=$P(PSOVLV,"^"),PSOVLV=$$REPL^PSOVDF1(PSOVLV) D Q
239 . S VAL=$G(PSOVLV)_SEPC_$G(PSOVALE)_SEPC_"99VA_52_100"
240 I $G(VAL)'="" S VAL=$$REPL^PSOVDF1(VAL),VAL=VAL_SEPC_$G(PSOVALE)_SEPC_SRC_"_100"
241 Q
242 ;
243PREM ;
244 S VAL="RE"_SEPC_"REMARKS"_SEPC_HLINST_"_52.2_.03"
245 Q
246 ;
247RREM ;
248 S VAL="RE"_SEPC_"REMARKS"_SEPC_HLINST_"_52.1_3"
249 Q
250 ;
Note: See TracBrowser for help on using the repository browser.