source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTS.m@ 1036

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

revised back to 6/30/08 version
File size: 9.5 KB
Line 
1PSOAFPTS ;VFA/HMS autofinish print for star printer ;3/13/07 19:26
2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
3 ; Copyright (C) GNU GPL 2007 WorldVistA
4 ;
5PRNT ;PAGEMODE for Star Micronics
6 ;
7 U IO ;vfah fax
8 ;
9 F DR=1:1 Q:$G(SGY(DR))="" S SN=19+DR D
10 .S AFSIG(SN)=$G(SGY(DR))
11 S SIGL=DR-1
12 ;
13 S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3)
14 S AFORD=$P(^PSRX(RX,"OR1"),"^",2)
15 I $G(AFESFLAG)="Y" D
16 .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4)
17 .I $G(AFES)=1 S AFESYN="Y"
18 .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5)
19 ;
20 S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6)
21 S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3)
22 ;
23 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59
24 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN=""
25 ;
26 S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y") D
27 .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D
28 ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y"
29 K DONE
30 ;
31DIAG ;
32 S AFICD9(1)="None",AFICD(1)="Not Available",L=2
33 I $D(^OR(100,AFORD,5.1,0)) D
34 .S AFORL=0
35 .F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="") D
36 ..S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1)
37 ..I AFORIN>"" D
38 ...S AFICD9(L)=$P($G(^ICD9(AFORIN,0)),"^",1)
39 ...S AFICD(L)=$P($G(^ICD9(AFORIN,0)),"^",3)
40 S AFICDN=L-1
41 ;
42PRC ;
43 K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=70,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
44 F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S PSOAFZZ=ZZ
45 ;
46 W $C(27),"C",$C(10),$C(0) ;Clear format
47 ;
48 W $C(27),"L00;0110,0030,0920,0030,0,6",$C(10),$C(0) ;T
49 W $C(27),"L01;0025,0100,0025,0230,1,6",$C(10),$C(0) ;L
50 W $C(27),"L02;1000,0100,1000,0238,1,6",$C(10),$C(0) ;R
51 W $C(27),"L03;0025,0230,1000,0230,0,6",$C(10),$C(0) ;B
52 W $C(27),"L10;0920,0030,0920,0100,1,6",$C(10),$C(0) ;R
53 W $C(27),"L11;0920,0100,1000,0100,0,6",$C(10),$C(0) ;B
54 W $C(27),"L12;0110,0030,0110,0102,1,6",$C(10),$C(0) ;R
55 W $C(27),"L13;0025,0100,0112,0100,0,6",$C(10),$C(0) ;B
56 ;
57 W $C(27),"L05;0025,0470,1000,0470,0,2",$C(10),$C(0) ;Div Line
58 ;
59 W $C(27),"PC00;0210,0055,1,1,4,00,00",$C(10),$C(0) ;Dr
60 W $C(27),"PC01;0025,0100,1,1,2,00,00",$C(10),$C(0) ;Dr
61 W $C(27),"PC02;0025,0145,1,1,2,00,00",$C(10),$C(0) ;Dr Phone
62 W $C(27),"PC70;0025,0190,1,1,2,00,00",$C(10),$C(0) ;Free line
63 ;
64 W $C(27),"PC03;0025,0285,1,1,1,00,03",$C(10),$C(0) ;Rx For
65 W $C(27),"PC04;0130,0280,1,1,2,00,00",$C(10),$C(0) ;Pat Name
66 W $C(27),"PC05;0130,0320,1,1,2,00,00",$C(10),$C(0) ;Pat Str1
67 W $C(27),"PC06;0130,0360,1,1,2,00,00",$C(10),$C(0) ;Pat Str2
68 W $C(27),"PC07;0130,0400,1,1,2,00,00",$C(10),$C(0) ;Pat Str3
69 W $C(27),"PC08;0130,0440,1,1,2,00,00",$C(10),$C(0) ;Pat City
70 ;
71 S DHL=4
72 S:$L(DRUG)>33 DHL=2 ;Reduce size for L>33
73 W $C(27),"PC09;0025,0500,1,1,"_DHL_",00,00",$C(10),$C(0) ;Drug
74 ;
75 W $C(27),"PC72;0025,0558,1,1,1,00,03",$C(10),$C(0) ;AKA Notice
76 W $C(27),"PC71;0225,0550,1,1,2,00,00",$C(10),$C(0) ;Drug Syn
77 ;
78 W $C(27),"PC10;0025,0590,1,1,1,00,03",$C(10),$C(0) ;SDD Disclaimer
79 ;
80 S SL=19,VP=590
81 F L=1:1:SIGL D
82 .S SL=SL+1,VP=VP+40
83 .D SVP
84 .W $C(27),"PC"_SL_";0025,"_VP_",1,1,2,00,00",$C(10),$C(0)
85 ;
86 S VP=VP+60 D SVP
87 W $C(27),"PC50;0085,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp:
88 W $C(27),"PC51;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp Num
89 ;
90 ;S VP=VP+40 D SVP
91 W $C(27),"PC52;0450,"_VP_",1,1,1,00,03",$C(10),$C(0) ;Disp Disclaimer
92 ;
93 S VP=VP+40 D SVP
94 W $C(27),"PC53;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Days
95 W $C(27),"PC54;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Supply
96 ;
97 S VP=VP+40 D SVP
98 W $C(27),"PC55;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Refill
99 W $C(27),"PC56;0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
100 ;
101 S VP=VP+40 D SVP
102 W $C(27),"PC57;0045,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Issue
103 W $C(27),"PC58;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Date #
104 ;
105 ;Diag Line Logo
106 S VP=VP+40 D SVP
107 W $C(27),"PC79;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Diag
108 ;
109 S SL=79,VP=VP-40 ;Diag lines
110 F L=1:1:AFICDN D
111 .S SL=SL+1,VP=VP+40
112 .D SVP
113 .W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
114 .S SL=SL+1
115 .W $C(27),"PC"_SL_";0475,"_VP_",1,1,2,00,00",$C(10),$C(0)
116 ;
117 ;DOB Line
118 S SL=SL+1,VP=VP+40 D SVP
119 W $C(27),"PC"_SL_";0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB:
120 S SL=SL+1
121 W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB
122 ;
123 ;Comment Line Logo
124 I $G(PSOAFZZ)>0 D
125 .S SL=SL+1,VP=VP+40 D SVP
126 .W $C(27),"PC"_SL_";0008,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Comment Logo
127 ;
128 I $G(PSOAFZZ)>0 D
129 .S VP=VP-40 ;Comment lines
130 .F L=1:1:PSOAFZZ D
131 ..S SL=SL+1,VP=VP+$S(L=1:48,1:25)
132 ..D SVP
133 ..W $C(27),"PC"_SL_";0300,"_VP_",1,1,1,00,00",$C(10),$C(0)
134 ;
135 ;Signature lines start here
136 I $G(AFESYN)="Y" S VP=VP+130 D SVP G SIGNL
137 S VP=VP+130 D SVP
138 W $C(27),"PC59;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Sig:
139 ;
140 S VP=VP+30 D SVP
141 W $C(27),"L04;0230,"_VP_",1000,"_VP_",0,2",$C(10),$C(0) ;Line
142 ;
143SIGNL S VP=VP+10 D SVP
144 I $G(AFESYN)="Y" G SIGNL1
145 W $C(27),"PC60;0240,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Prov Name
146SIGNL1 W $C(27),"PC60;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;ES Prov Name
147 ;
148 S VP=VP+110 D SVP
149 W $C(27),"PC61;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Trail
150 ;
151 S VP=VP+90 D SVP
152 W $C(27),"PC62;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On:
153 W $C(27),"PC63;0320,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On D/T
154 ;
155 ;Testing form length on Star
156 S PA=$S(VP>1501:1900,1:1500)
157 W $C(27),"D"_PA_"",$C(10),$C(0) ;Set print area
158 ;
159 W $C(27),"B",$C(10),$C(0) ;Enable cutter
160 ;
161 S OFF=$P(PS,"^",1)
162 S VFAX=OFF,VFAM=20
163 D CENTER
164 S OFF=VFAX
165 W $C(27),"RC00;"_OFF_"",$C(10),$C(0)
166 ;
167 S OFFAD=$P(PS,"^",7)_","_STATE_" "_$G(PSOHZIP)
168 S VFAX=OFFAD,VFAM=49
169 D CENTER
170 S OFFAD=VFAX
171 W $C(27),"RC01;"_OFFAD_"",$C(10),$C(0)
172 ;
173 S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4)
174 S VFAX=OFFTEL,VFAM=49
175 D CENTER
176 S OFFTEL=VFAX
177 W $C(27),"RC02;"_OFFTEL_"",$C(10),$C(0)
178 ;
179 S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4)
180 S VFAX=OFFFREE,VFAM=49
181 D CENTER
182 S OFFFREE=VFAX
183 W $C(27),"RC70;"_OFFFREE_"",$C(10),$C(0)
184 ;
185 W $C(27),"RC03;Rx for:",$C(10),$C(0)
186 ;
187 D 6^VADPT,PID^VADPT
188 S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID")))
189 S AFPNAM=PNM_" "_$G(PSOAFPTI)
190 W $C(27),"RC04;"_AFPNAM_"",$C(10),$C(0)
191 ;
192 S AFPADD1=$G(VAPA(1))
193 W $C(27),"RC05;"_AFPADD1_"",$C(10),$C(0)
194 ;
195 S AFPADD2=$G(ADDR(2))
196 W $C(27),"RC06;"_AFPADD2_"",$C(10),$C(0)
197 ;
198 S AFPADD3=$G(ADDR(3))
199 W $C(27),"RC07;"_AFPADD3_"",$C(10),$C(0)
200 ;
201 S AFPADD4=$G(ADDR(4))
202 W $C(27),"RC08;"_AFPADD4_"",$C(10),$C(0)
203 ;
204 S AFDRUG=DRUG
205 W $C(27),"RC09;"_AFDRUG_"",$C(10),$C(0)
206 ;
207 S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5)
208 I SYNFLAG="Y"&(AFSYN'="") D
209 .W $C(27),"RC72;Also known as:",$C(10),$C(0) ;L-72
210 .W $C(27),"RC71;"_AFSYN_"",$C(10),$C(0) ;L-71
211 ;
212 I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y"
213 I $G(VFASDD)="Y" D
214 .W $C(27),"RC10;Pharmacy may choose strength(s) of drug to meet requirements of directions",$C(10),$C(0)
215 ;
216 ;
217SIG S SN=19
218 F L=1:1:SIGL S SN=SN+1 W $C(27),"RC"_SN_";"_AFSIG(SN)_"",$C(10),$C(0)
219 ;
220 W $C(27),"RC50;Dispense:",$C(10),$C(0)
221 S AFDISP=$G(QTY)_" "_$G(PSDU)
222 W $C(27),"RC51;"_AFDISP_"",$C(10),$C(0)
223 ;
224 I $G(VFASDD)="Y" W $C(27),"RC52;Pharmacy to adjust qty for # of days",$C(10),$C(0)
225 ;
226 W $C(27),"RC53;Days Supply:",$C(10),$C(0)
227 S VFADAYS=$G(DAYS)
228 W $C(27),"RC54;"_VFADAYS_"",$C(10),$C(0)
229 ;
230 W $C(27),"RC55;Refill(s):",$C(10),$C(0)
231 S AFRF=$P(RXY,"^",9)
232 W $C(27),"RC56;"_AFRF_"",$C(10),$C(0)
233 ;
234 W $C(27),"RC57;Issue Date:",$C(10),$C(0)
235 W $C(27),"RC58;"_DATE_"",$C(10),$C(0)
236 ;
237DIA S PSOAFDOB=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)
238 I PSOAFDOB="Y" D
239 .W $C(27),"RC79;Diagnosis:",$C(10),$C(0)
240 .S SN=79
241 .F L=1:1:AFICDN S SN=SN+1 D
242 ..W $C(27),"RC"_SN_";"_AFICD9(L)_"",$C(10),$C(0)
243 ..S SN=SN+1
244 ..W $C(27),"RC"_SN_";"_AFICD(L)_"",$C(10),$C(0)
245 I PSOAFDOB="" S SN=80+AFICDN
246 ;
247DOB ;DOB
248 S PSOAFDIG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)
249 I PSOAFDIG="Y" D
250 .S PSOAFDOB=$P($G(VADM(3)),"^",2),PSOAFDOL=" DOB:"
251 .S SN=SN+1
252 .W $C(27),"RC"_SN_"; DOB:",$C(10),$C(0)
253 .S SN=SN+1
254 .W $C(27),"RC"_SN_";"_PSOAFDOB_"",$C(10),$C(0)
255 I PSOAFDIG="" S SN=SN+2
256 ;
257COM ;
258 I $D(^UTILITY($J,"W")) D
259 .S SN=SN+1
260 .W $C(27),"RC"_SN_"; MD Comments:",$C(10),$C(0)
261 .F ZZ=0:0:PSOAFZZ S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S PSOAFCOM=^(0),SN=SN+1 W $C(27),"RC"_SN_";"_PSOAFCOM_"",$C(10),$C(0)
262 K PSOZAFZZ,^UTILITY($J,"W")
263 ;
264 ;Signature Block
265SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists
266 I $G(AFESFLAG)="Y" D
267 .I $G(AFESYN)="Y" D
268 ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I")
269 ..I AFDEA="" D
270 ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I")
271 ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I")
272 ..S AFSIGN=$G(AFESIGNN)_" "_AFDEA
273 ;
274SIGN1 I $G(AFESFLAG)'="Y" D
275 .W $C(27),"RC59;Signature:",$C(10),$C(0) ;SCD
276 .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists
277 .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I")
278 .I AFDEA="" D
279 ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I")
280 .S AFSIGN=" "_$G(PHYS)_" "_AFDEA
281 ;
282SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN
283 W $C(27),"RC60;"_AFSIGN_"",$C(10),$C(0) ;SCD
284 ;
285 K AFESYN,AFESIGN,AFESIGNN
286 ;
287 W $C(27),"RC61;Must write BRAND NECESSARY to dispense brand drug",$C(10),$C(0) ;SCD
288 ;
289 S AFPTIM=$S($D(REPRINT):"Re-Printed on:",1:"Printed on:")
290 W $C(27),"RC62;"_AFPTIM_"",$C(10),$C(0) ;SCD
291 D NOW^%DTC S Y=% X ^DD("DD")
292 S AFPRNDT=Y_" ("_RX_")"
293 W $C(27),"RC63;"_AFPRNDT_"",$C(10),$C(0) ;SCD
294 ;
295WRITE W $C(27),"I",$C(10),$C(0) ;Print label
296 ;
297 K VFASDD
298 Q
299 ;
300SVP S VP=$S($L(VP)=1:"000"_VP,$L(VP)=2:"00"_VP,$L(VP)=3:"0"_VP,1:VP)
301 Q
302 ;
303CENTER ;Center header
304 S VFAS=(VFAM-$L(VFAX))\2
305 F L=1:1:VFAS S VFAX=" "_VFAX
Note: See TracBrowser for help on using the repository browser.