- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTS.m
r613 r623 1 PSOAFPTS 2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41 3 4 5 PRNT 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 DIAG 32 33 34 35 36 37 38 39 40 41 42 PRC 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 SIGNL 144 145 146 SIGNL1 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 SIG 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 DIA 238 239 240 241 242 243 244 245 246 247 DOB 248 249 250 251 252 253 254 255 256 257 COM 258 259 260 261 262 263 264 265 SIGN 266 267 268 269 270 271 272 273 274 SIGN1 275 276 277 278 279 280 281 282 SIGNP 283 284 285 286 287 288 289 290 291 292 293 294 295 WRITE 296 297 298 299 300 SVP 301 302 303 CENTER 304 305 1 PSOAFPTS ;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 ; 5 PRNT ;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 ; 31 DIAG ; 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 ; 42 PRC ; 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 ; 143 SIGNL 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 146 SIGNL1 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 ; 217 SIG 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 ; 237 DIA 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 ; 247 DOB ;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 ; 257 COM ; 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 265 SIGN ;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 ; 274 SIGN1 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 ; 282 SIGNP 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 ; 295 WRITE W $C(27),"I",$C(10),$C(0) ;Print label 296 ; 297 K VFASDD 298 Q 299 ; 300 SVP S VP=$S($L(VP)=1:"000"_VP,$L(VP)=2:"00"_VP,$L(VP)=3:"0"_VP,1:VP) 301 Q 302 ; 303 CENTER ;Center header 304 S VFAS=(VFAM-$L(VFAX))\2 305 F L=1:1:VFAS S VFAX=" "_VFAX
Note:
See TracChangeset
for help on using the changeset viewer.
