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

PSOAFPTS ;VFA/HMS autofinish print for star printer ;3/13/07  19:26
 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
 ; Copyright (C) GNU GPL 2007 WorldVistA
 ;
PRNT ;PAGEMODE for Star Micronics
 ;
 U IO ;vfah fax
 ;
 F DR=1:1 Q:$G(SGY(DR))=""  S SN=19+DR D
 .S AFSIG(SN)=$G(SGY(DR))
 S SIGL=DR-1
 ;
 S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3)
 S AFORD=$P(^PSRX(RX,"OR1"),"^",2)
 I $G(AFESFLAG)="Y" D
 .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4)
 .I $G(AFES)=1 S AFESYN="Y"
 .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5)
 ;
 S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6)
 S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3)
 ;
 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59
 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN=""
 ;
 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
 .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D
 ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y"
 K DONE
 ;
DIAG ;
 S AFICD9(1)="None",AFICD(1)="Not Available",L=2
 I $D(^OR(100,AFORD,5.1,0)) D
 .S AFORL=0
 .F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="")  D
 ..S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1)
 ..I AFORIN>"" D
 ...S AFICD9(L)=$P($G(^ICD9(AFORIN,0)),"^",1)
 ...S AFICD(L)=$P($G(^ICD9(AFORIN,0)),"^",3)
 S AFICDN=L-1
 ;
PRC ;
 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
 F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S PSOAFZZ=ZZ
 ;
 W $C(27),"C",$C(10),$C(0) ;Clear format
 ;
 W $C(27),"L00;0110,0030,0920,0030,0,6",$C(10),$C(0) ;T
 W $C(27),"L01;0025,0100,0025,0230,1,6",$C(10),$C(0) ;L
 W $C(27),"L02;1000,0100,1000,0238,1,6",$C(10),$C(0) ;R
 W $C(27),"L03;0025,0230,1000,0230,0,6",$C(10),$C(0) ;B
 W $C(27),"L10;0920,0030,0920,0100,1,6",$C(10),$C(0) ;R
 W $C(27),"L11;0920,0100,1000,0100,0,6",$C(10),$C(0) ;B
 W $C(27),"L12;0110,0030,0110,0102,1,6",$C(10),$C(0) ;R
 W $C(27),"L13;0025,0100,0112,0100,0,6",$C(10),$C(0) ;B
 ;
 W $C(27),"L05;0025,0470,1000,0470,0,2",$C(10),$C(0) ;Div Line
 ;
 W $C(27),"PC00;0210,0055,1,1,4,00,00",$C(10),$C(0) ;Dr
 W $C(27),"PC01;0025,0100,1,1,2,00,00",$C(10),$C(0) ;Dr
 W $C(27),"PC02;0025,0145,1,1,2,00,00",$C(10),$C(0) ;Dr Phone
 W $C(27),"PC70;0025,0190,1,1,2,00,00",$C(10),$C(0) ;Free line
 ;
 W $C(27),"PC03;0025,0285,1,1,1,00,03",$C(10),$C(0) ;Rx For
 W $C(27),"PC04;0130,0280,1,1,2,00,00",$C(10),$C(0) ;Pat Name
 W $C(27),"PC05;0130,0320,1,1,2,00,00",$C(10),$C(0) ;Pat Str1
 W $C(27),"PC06;0130,0360,1,1,2,00,00",$C(10),$C(0) ;Pat Str2
 W $C(27),"PC07;0130,0400,1,1,2,00,00",$C(10),$C(0) ;Pat Str3
 W $C(27),"PC08;0130,0440,1,1,2,00,00",$C(10),$C(0) ;Pat City
 ;
 S DHL=4
 S:$L(DRUG)>33 DHL=2 ;Reduce size for L>33
 W $C(27),"PC09;0025,0500,1,1,"_DHL_",00,00",$C(10),$C(0) ;Drug
 ;
 W $C(27),"PC72;0025,0558,1,1,1,00,03",$C(10),$C(0) ;AKA Notice
 W $C(27),"PC71;0225,0550,1,1,2,00,00",$C(10),$C(0) ;Drug Syn
 ;
 W $C(27),"PC10;0025,0590,1,1,1,00,03",$C(10),$C(0) ;SDD Disclaimer
 ;
 S SL=19,VP=590
 F L=1:1:SIGL D
 .S SL=SL+1,VP=VP+40
 .D SVP
 .W $C(27),"PC"_SL_";0025,"_VP_",1,1,2,00,00",$C(10),$C(0)
 ;
 S VP=VP+60 D SVP
 W $C(27),"PC50;0085,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp:
 W $C(27),"PC51;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp Num
 ;
 ;S VP=VP+40 D SVP
 W $C(27),"PC52;0450,"_VP_",1,1,1,00,03",$C(10),$C(0) ;Disp Disclaimer
 ;
 S VP=VP+40 D SVP
 W $C(27),"PC53;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Days
 W $C(27),"PC54;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Supply
 ;
 S VP=VP+40 D SVP
 W $C(27),"PC55;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Refill
 W $C(27),"PC56;0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
 ;
 S VP=VP+40 D SVP
 W $C(27),"PC57;0045,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Issue
 W $C(27),"PC58;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Date #
 ;
 ;Diag Line Logo
 S VP=VP+40 D SVP
 W $C(27),"PC79;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Diag
 ;
 S SL=79,VP=VP-40 ;Diag lines
 F L=1:1:AFICDN D
 .S SL=SL+1,VP=VP+40
 .D SVP
 .W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
 .S SL=SL+1
 .W $C(27),"PC"_SL_";0475,"_VP_",1,1,2,00,00",$C(10),$C(0)
 ;
 ;DOB Line
 S SL=SL+1,VP=VP+40 D SVP
 W $C(27),"PC"_SL_";0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB:
 S SL=SL+1
 W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB
 ;
 ;Comment Line Logo
 I $G(PSOAFZZ)>0 D
 .S SL=SL+1,VP=VP+40 D SVP
 .W $C(27),"PC"_SL_";0008,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Comment Logo
 ;
 I $G(PSOAFZZ)>0 D
 .S VP=VP-40 ;Comment lines
 .F L=1:1:PSOAFZZ D
 ..S SL=SL+1,VP=VP+$S(L=1:48,1:25)
 ..D SVP
 ..W $C(27),"PC"_SL_";0300,"_VP_",1,1,1,00,00",$C(10),$C(0)
 ;
 ;Signature lines start here
 I $G(AFESYN)="Y" S VP=VP+130 D SVP G SIGNL
 S VP=VP+130 D SVP
 W $C(27),"PC59;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Sig:
 ;
 S VP=VP+30 D SVP
 W $C(27),"L04;0230,"_VP_",1000,"_VP_",0,2",$C(10),$C(0) ;Line
 ;
SIGNL S VP=VP+10 D SVP
 I $G(AFESYN)="Y" G SIGNL1
 W $C(27),"PC60;0240,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Prov Name
SIGNL1 W $C(27),"PC60;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;ES Prov Name
 ;
 S VP=VP+110 D SVP
 W $C(27),"PC61;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Trail
 ;
 S VP=VP+90 D SVP
 W $C(27),"PC62;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On:
 W $C(27),"PC63;0320,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On D/T
 ;
 ;Testing form length on Star
 S PA=$S(VP>1501:1900,1:1500)
 W $C(27),"D"_PA_"",$C(10),$C(0) ;Set print area
 ;
 W $C(27),"B",$C(10),$C(0) ;Enable cutter
 ;
 S OFF=$P(PS,"^",1)
 S VFAX=OFF,VFAM=20
 D CENTER
 S OFF=VFAX
 W $C(27),"RC00;"_OFF_"",$C(10),$C(0)
 ;
 S OFFAD=$P(PS,"^",7)_","_STATE_"  "_$G(PSOHZIP)
 S VFAX=OFFAD,VFAM=49
 D CENTER
 S OFFAD=VFAX
 W $C(27),"RC01;"_OFFAD_"",$C(10),$C(0)
 ;
 S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4)
 S VFAX=OFFTEL,VFAM=49
 D CENTER
 S OFFTEL=VFAX
 W $C(27),"RC02;"_OFFTEL_"",$C(10),$C(0)
 ;
 S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4)
 S VFAX=OFFFREE,VFAM=49
 D CENTER
 S OFFFREE=VFAX
 W $C(27),"RC70;"_OFFFREE_"",$C(10),$C(0)
 ;
 W $C(27),"RC03;Rx for:",$C(10),$C(0)
 ;
 D 6^VADPT,PID^VADPT
 S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID")))
 S AFPNAM=PNM_" "_$G(PSOAFPTI)
 W $C(27),"RC04;"_AFPNAM_"",$C(10),$C(0)
 ;
 S AFPADD1=$G(VAPA(1))
 W $C(27),"RC05;"_AFPADD1_"",$C(10),$C(0)
 ;
 S AFPADD2=$G(ADDR(2))
 W $C(27),"RC06;"_AFPADD2_"",$C(10),$C(0)
 ;
 S AFPADD3=$G(ADDR(3))
 W $C(27),"RC07;"_AFPADD3_"",$C(10),$C(0)
 ;
 S AFPADD4=$G(ADDR(4))
 W $C(27),"RC08;"_AFPADD4_"",$C(10),$C(0)
 ;
 S AFDRUG=DRUG
 W $C(27),"RC09;"_AFDRUG_"",$C(10),$C(0)
 ;
 S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5)
 I SYNFLAG="Y"&(AFSYN'="") D
 .W $C(27),"RC72;Also known as:",$C(10),$C(0) ;L-72
 .W $C(27),"RC71;"_AFSYN_"",$C(10),$C(0) ;L-71
 ;
 I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y"
 I $G(VFASDD)="Y" D
 .W $C(27),"RC10;Pharmacy may choose strength(s) of drug to meet requirements of directions",$C(10),$C(0)
 ;
 ;
SIG S SN=19
 F L=1:1:SIGL S SN=SN+1 W $C(27),"RC"_SN_";"_AFSIG(SN)_"",$C(10),$C(0)
 ;
 W $C(27),"RC50;Dispense:",$C(10),$C(0)
 S AFDISP=$G(QTY)_" "_$G(PSDU)
 W $C(27),"RC51;"_AFDISP_"",$C(10),$C(0)
 ;
 I $G(VFASDD)="Y" W $C(27),"RC52;Pharmacy to adjust qty for # of days",$C(10),$C(0)
 ;
 W $C(27),"RC53;Days Supply:",$C(10),$C(0)
 S VFADAYS=$G(DAYS)
 W $C(27),"RC54;"_VFADAYS_"",$C(10),$C(0)
 ;
 W $C(27),"RC55;Refill(s):",$C(10),$C(0)
 S AFRF=$P(RXY,"^",9)
 W $C(27),"RC56;"_AFRF_"",$C(10),$C(0)
 ;
 W $C(27),"RC57;Issue Date:",$C(10),$C(0)
 W $C(27),"RC58;"_DATE_"",$C(10),$C(0)
 ;
DIA S PSOAFDOB=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)
 I PSOAFDOB="Y" D
 .W $C(27),"RC79;Diagnosis:",$C(10),$C(0)
 .S SN=79
 .F L=1:1:AFICDN S SN=SN+1 D
 ..W $C(27),"RC"_SN_";"_AFICD9(L)_"",$C(10),$C(0)
 ..S SN=SN+1
 ..W $C(27),"RC"_SN_";"_AFICD(L)_"",$C(10),$C(0)
 I PSOAFDOB="" S SN=80+AFICDN
 ;
DOB ;DOB
 S PSOAFDIG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)
 I PSOAFDIG="Y" D
 .S PSOAFDOB=$P($G(VADM(3)),"^",2),PSOAFDOL="      DOB:"
 .S SN=SN+1
 .W $C(27),"RC"_SN_";      DOB:",$C(10),$C(0)
 .S SN=SN+1
 .W $C(27),"RC"_SN_";"_PSOAFDOB_"",$C(10),$C(0)
 I PSOAFDIG="" S SN=SN+2
 ;
COM ;
 I $D(^UTILITY($J,"W")) D
 .S SN=SN+1
 .W $C(27),"RC"_SN_"; MD Comments:",$C(10),$C(0)
 .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)
 K PSOZAFZZ,^UTILITY($J,"W")
 ;
 ;Signature Block
SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists
 I $G(AFESFLAG)="Y" D
 .I $G(AFESYN)="Y" D
 ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I")
 ..I AFDEA="" D
 ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I")
 ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I")
 ..S AFSIGN=$G(AFESIGNN)_"  "_AFDEA
 ;
SIGN1 I $G(AFESFLAG)'="Y" D
 .W $C(27),"RC59;Signature:",$C(10),$C(0)  ;SCD
 .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists
 .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I")
 .I AFDEA="" D
 ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I")
 .S AFSIGN="           "_$G(PHYS)_"  "_AFDEA
 ;
SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN
 W $C(27),"RC60;"_AFSIGN_"",$C(10),$C(0) ;SCD
 ;
 K AFESYN,AFESIGN,AFESIGNN
 ;
 W $C(27),"RC61;Must write BRAND NECESSARY to dispense brand drug",$C(10),$C(0) ;SCD
 ;
 S AFPTIM=$S($D(REPRINT):"Re-Printed on:",1:"Printed on:")
 W $C(27),"RC62;"_AFPTIM_"",$C(10),$C(0) ;SCD
 D NOW^%DTC S Y=% X ^DD("DD")
 S AFPRNDT=Y_"  ("_RX_")"
 W $C(27),"RC63;"_AFPRNDT_"",$C(10),$C(0) ;SCD
 ;
WRITE W $C(27),"I",$C(10),$C(0) ;Print label
 ;
 K VFASDD
 Q
 ;
SVP S VP=$S($L(VP)=1:"000"_VP,$L(VP)=2:"00"_VP,$L(VP)=3:"0"_VP,1:VP)
 Q
 ;
CENTER ;Center header
 S VFAS=(VFAM-$L(VFAX))\2
 F L=1:1:VFAS S VFAX=" "_VFAX