PSOLLL1 ;BIR/BHW - LASER LABELS ;07-Nov-2013 14:58;DU
;;7.0;OUTPATIENT PHARMACY;**120,141,135,162,1001,1005,1006,1008,1009,1013,161,233,200,264,326,1015,1016,1018**;DEC 1997;Build 21
;
;Reference to ^PSDRUG supported by DBIA 221
;Reference ^VA(200,D0,"PS" supported by DBIA 224
;External reference to ^PS(55 supported by DBIA 2228
; Modified - IHS/CIA/PLS - 03/01/04
; 10/15/04 - Line ADDRESS+6
; 10/27/04 - Line CONT+4
; IHS/MSC/PLS 09/11/07 - Line L1+40
; 10/25/07 - Line ST+7
; 05/01/09 - Line L1+53
; 04/30/10 - Line W
; 06/02/10 - Line WARN+14
; 09/26/11 - Line W+1,W+2
; IHS/MSC/MGH - 02/26/13 - Line COPY+9
; IHS/MSC/PLS - 08/30/13 - Line COPY+14
ST I $P($G(^PSRX(RX,3)),"^",3) S PSOPROV=+$P(^(0),"^",4),PSOPROV=$S($G(RXP):+$P($G(RXP),"^",17),$G(RXF):+$P($G(^PSRX(RX,1,RXF,0)),"^",17),1:PSOPROV) S:'$G(PSOPROV) PSOPROV=+$P(^PSRX(RX,0),"^",4) D
. I +$P($G(^VA(200,PSOPROV,"PS")),"^",7) S:'$P($G(PHYS),"/",2) PHYS=$G(PHYS)_"/"_+$P($G(^PSRX(RX,3)),"^",3)
S $P(ULN,"_",34)="",PSOTRAIL=1
S (Y,X1)=EXPDT X ^DD("DD") S EXPDT=Y,Y=$P(^PSRX(RX,0),"^",13) X ^DD("DD") S ISD=Y,X2=DT D ^%DTC S DIFF=X
S Y=DATE X ^DD("DD") S DATE=Y
; IHS/CIA/PLS - 03/06/04 - Set TECH to initials and not New Person IEN
;S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")"
; IHS/MSC/PLS - 10/25/07 - Changed logic to call $$LBLINI^APSPLBL
;S TECH="("_$$USRINI($S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16)))_"/"_$$USRINI($S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" "))_")"
S TECH="("_$$LBLINI^APSPLBL(RX,$S($G(RXP):"P",$G(RXF):"R",1:""),$S($G(RXP):RXP,$G(RXF):RXF,1:""))_"/"_$$USRINI($S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" "))_")"
S PSZIP=$P(PS,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
L1 I $G(PSOIO("BLH"))]"" X PSOIO("BLH")
I 'SIGF,'SIGM,'PMIM K PSOSTLK,ZTKDRUG I $L($T(PSOSTALK^PSOTALK1)) D PSOSTALK^PSOTALK1 D S PSOSTLK=1 ; PRINT ONE SCRIPTALK LABEL IF APPLICABLE
.;D 6^VADPT,PID^VADPT6 S SSNPN="" ;IHS/MSC/PLS 06/14/13
; IHS/CIA/PLS - 03/31/04 - Change VAMC to IHS
;S T="VAMC "_$P(PS,"^",7)_", "_STATE_" "_$G(PSOHZIP) S:SIGF!($G(FILLCONT)) T=" " D PRINT(T)
D:'$G(FILLCONT) ADDRESS
;S T=$P(PS2,"^",2)_" "_TECH_" Ph: "_$P(PS,"^",3)_"-"_$P(PS,"^",4) S:SIGF!($G(FILLCONT)) T=" " D PRINT(T) ; IHS/PLS/CIA - 03/31/04 - Suppress - no room
S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8)
I $G(PSOIO("BLB"))]"" X PSOIO("BLB")
S XFONT=$E(PSOFONT,2,99)
S T="Rx# "_RXN_" " S:SIGF!($G(FILLCONT)) T=" " D PRINT(T,1)
D STRT^PSOLLU1("RX#",T,.L) S PSOY=PSOY-PSOYI,OPSOX=PSOX,PSOX=L(XFONT)*300+PSOX
S DR=$G(SIGF("DR"))
S T=" "_DATE_" "_$S('SIGF:"Fill "_(RXF+1)_" of "_(1+$P(RXY,"^",9)),1:"(label continued)") S:SIGF!($G(FILLCONT)) T=" " D PRINT(T)
S PSOX=OPSOX,T=PNM S:SIGF!($G(FILLCONT)) T=" " I T'=" " D PRINT(T,1)
I DR>1 S PSOX=OPSOX,T="Rx# "_RXN_" (label continued)" D PRINT(T)
D STRT^PSOLLU1("SIG",T,.L)
S OPSOX=PSOX,PSOX=L(XFONT)*300+PSOX,PSOY=PSOY-PSOYI,T=" "_$G(SSNPN) S:SIGF!($G(FILLCONT)) T=" " D PRINT(T)
S PSOX=OPSOX,LENGTH=0,PTEXT="",SIGF=0,XFONT=$E(PSOFONT,2,99)
N DP,TEXTP,TEXTL,MORE
I 'SIGM,'$G(FILLCONT) D COUNTSG^PSOLLLW
S DR=SIGF("DR")
I DR>1,'$D(NSGY(DR,4)) D
.F I=4:-1:1 Q:$D(NSGY(DR,I)) S T=" " D PRINT(T) ; BOTTOM-JUSTIFY CONTINUED BOTTLE SIG JUST ABOVE 'DISCARD' LINE
F I=1:1 Q:'$D(NSGY(DR,I)) S TEXT=NSGY(DR,I) D PRINT(TEXT)
I I>4,$D(NSGY(DR,5)) S SIGF=1,SIGF("DR")=DR+1
I $G(PSOIO("BLF"))]"" X PSOIO("BLF")
S PSOY=PSODY-PSOYI,PSOFONT=PSODFONT
I SIGF G WARN:'SIGM&('$G(FILLCONT)),CONT
I '$D(NSGY) G CONT
K NSGY,^TMP($J,"PSOSIG",RX)
D NOW^%DTC S X1=X,X2=365 D C^%DTC S Y=X X ^DD("DD")
S DEA=$P($G(^PSDRUG($P(RXY,"^",6),0)),"^",3),T=""
I DEA'["S" S T="Discard after "_$S(DEA[0!(DEA["M"):"_________",1:Y)_"__________ "
S T=T_"Mfr_________" D PRINT(T)
S PSOY=PSOY-7
D S PSOFONT="F8" D PRINT(T)
. S NOR=$P(RXY,"^",9)-RXF
. I $P(RXY,"^",9)=0 S T="NO REFILL" Q
. I NOR=0 S T="NO REFILLS LEFT" Q
. S T="May refill "_NOR_"X by "_EXPDT
I $$GET1^DIQ(9009033,PSOSITE,311,"I") D
.S PSOY=PSOY-10
.S T="NDC "_$$NDCVAL^APSPFUNC(RX,+$G(RXFL(RX))) D PRINT(T) ;IHS/MSC/PLS - 09/11/07
S PPHYS=$G(PHYS)
S XFONT=$E(PSOQFONT,2,99)
S TEXT="Qty: " D STRT^PSOLLU1("SIG",TEXT,.L) S Q(1)=L(XFONT)
S TEXT=" "_PSDU D STRT^PSOLLU1("SIG",TEXT,.L) S Q(2)=L(XFONT)
S TEXT=" "_$G(PHYS) D STRT^PSOLLU1("SIG",TEXT,.L) S Q(3)=L(XFONT)
S TEXT=$G(QTY) D STRT^PSOLLU1("SIG",TEXT,.L) S LENGTH=Q(1)+Q(2)+Q(3)+L(XFONT+2),Q(4)=L(XFONT+2)
I LENGTH>3 F I=$L(PHYS)-1:-1:1 S PPHYS=$E(PHYS,1,I),TEXT=" "_PPHYS D STRT^PSOLLU1("SIG",TEXT,.L) I Q(1)+Q(2)+Q(4)+L(XFONT)<3.3 Q
;S PSOFONT=PSOTFONT,OPSOX=PSOX,PSOX=PSOX+(Q(1)*300),PSOY=PSOQY-PSOYI,T=$G(QTY) D PRINT(T)
S PSOFONT=PSOTFONT,OPSOX=PSOX,PSOX=PSOX+(Q(1)*300)
S PSOY=PSOQY-PSOYI+9
S T=$G(QTY) D PRINT(T)
S PSOX=OPSOX,PSOFONT=PSOQFONT,PSOY=PSOY-PSOYI,T="Qty: " D PRINT(T)
S PSOX=PSOX+(Q(1)+Q(4)*300),PSOY=PSOY-PSOYI,T=" "_$G(PSDU)_" "_$G(PPHYS) D PRINT(T)
S PSOFONT=PSOTFONT,PSOX=OPSOX,PSOY=PSOTY-PSOYI,T=DRUG D STRT^PSOLLU1("SIG",T,.L)
;I L($E(PSOFONT,2,99))>3 S PSOFONT=$S(PSOFONT="F12":"F10",PSOFONT="F10":"F9",PSOFONT="F9":F8,PSOFONT="F8":"F6")
I L($E(PSOFONT,2,99))>3 S PSOFONT=$S(PSOFONT="F12":"F10",PSOFONT="F10":"F9",PSOFONT="F9":"F8",PSOFONT="F8":"F6") ;IHS/MSC/PLS 05/01/09 - Corrected typo.
S ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX"
I $G(PSOSTLK) S T=$S($G(PSOSTALK):ZTKDRUG,1:DRUG)
D PRINT(T,1)
I SIGM G CONT
S ^PSRX(RX,"TYPE")=0
WARN ;PRINT WARNING LABELS
I $G(PSOIO("WLI"))]"" X PSOIO("WLI")
; IF <5 WARNINGS, PRINT LABELS BOTTOM-JUSTIFIED
S PSOLAN=$P($G(^PS(55,DFN,"LAN")),"^",2)
S WARN5=WARN F Q:$L(WARN5,",")>4 S WARN5=" ,"_WARN5
F WWW=1:1:5 S PSOWARN=$P(WARN5,",",WWW) I PSOWARN'="" D
. I PSOWARN["N" D NEWWARN^PSOLLLW Q
. D WARN54^PSOLLLW
;RETURN MAIL
S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
S PSZIP=$P(PS,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
I $G(PSOIO("RMI"))]"" X PSOIO("RMI")
S PSOYI=$G(PSOHYI,40),OFONT=PSOFONT,PSOFONT=$G(PSOHFONT)
S BLNKLIN="",$P(BLNKLIN," ",30)=" " ;IHS/MSC/PLS - 06/02/2010
; IHS/CIA/PLS - 03/05/04 - Changed 119 to Pharmacy
;S T="Attn: (119)"_BLNKLIN_$$FMTE^XLFDT(DT) D PRINT(T,0)
S T="Attn: Pharmacy"_BLNKLIN_$$FMTE^XLFDT(DT) D PRINT(T,0)
S T=$G(VASTREET) D PRINT(T,0)
S T=$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) D PRINT(T,0)
S PSOY=PSOY+PSOYI,T=$S(PS55=2:"***DO NOT MAIL***",1:"") I T'="" D PRINT(T,0)
I T'="***DO NOT MAIL***" S T=$S(PS55[0!(PS55[3)!(PS55=""):"REGULAR MAIL",1:"CERTIFIED MAIL") S T=T_"-"_$G(MAILCOM) S:$L(T)>25 PSOFONT="F8" D PRINT(T,0)
S PSOFONT=OFONT
S T=PNM
S PSOY=PSOY+PSOYI,PSOYI=PSORYI D PRINT(T,0)
I $G(VAPA(1))=""!(PS55=2) G W
; ADD CHECK FOR BAD ADDRESS INDICATOR OR FOREIGN ADDRESS
N PSOBADR,PSOTEMP,PSOFORGN,I
S PSOBADR=0,PSOTEMP=0
S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
I 'PSOFORGN S PSOBADR=$$BADADR^DGUTL3(DFN)
I 'PSOFORGN,PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
F I=1:1:3 I $G(VAPA(I))]"" D
. S T="" I I=1,'PSOFORGN,PSOBADR,'$G(PSOTEMP) S T="** BAD ADDRESS INDICATED **"
. I I=1,T="",PSOFORGN S T="*** FOREIGN ADDRESS ***"
. I T="" I 'PSOFORGN I 'PSOBADR!$G(PSOTEMP) S T=$G(VAPA(I))
. D STRT^PSOLLU1("ML",T,.L) I L($E(PSOFONT,2,99))<2.37 D PRINT(T,0) Q
. F F=12,10,9,8,6 I L(F)<2.37 S OFONT=PSOFONT,PSOFONT="F"_F D PRINT(T,0) S PSOFONT=OFONT Q
S A=+$G(VAPA(5)) I A S A=$S($D(^DIC(5,A,0)):$P(^(0),"^",2),1:"UNKNOWN")
S T="" I 'PSOFORGN I 'PSOBADR!$G(PSOTEMP) S T=$G(VAPA(4))_", "_A_" "_$S($G(VAPA(11)):$P(VAPA(11),"^",2),1:$G(VAPA(6)))
D PRINT(T,0)
W D:$$GET1^DIQ(9009033,PSOSITE,320,"I") PRINT("DOB:"_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN),"5Z"),0) ;IHS/MSC/PLS - 04/30/10
D:$$GET1^DIQ(9009033,PSOSITE,403,"I") PRINT("NPI:"_$$GET1^DIQ(200,$P(^PSRX(RX,0),U,4),41.99)) ;IHS/MSC/PLS - 09/26/2011
D:$$GET1^DIQ(9009033,PSOSITE,404,"I") PRINT("DEA:"_$$DEAVAUS^APSPFUNC($P(^PSRX(RX,0),U,4))) ;IHS/MSC/PLS - 09/26/2011
S T=$S(MW="WINDOW":"WINDOW -",1:"MAIL -")
N XFONT
S OFONT=PSOFONT,PSOYI=$G(PSOTYI,40),PSOFONT=PSOTFONT,XFONT=$E(PSOFONT,2,99),PSOY=PSOTY
I T["WINDOW" D
. I $G(^PSRX(RX,"MP"))'="" S PSOY=PSOY-PSOYI ; START 1 LINE HIGHER IF METHOD OF PICK-UP
. S OPSOX=PSOX D PRINT(T,1) S PSOX=PSOX+200,PSOY=PSOY-PSOYI
. S T=$G(^PSRX(RX,"MP")) I T="" S PSOFONT=OFONT,PSOX=OPSOX Q
. N FIRST
. S FIRST=1
. D STRT^PSOLLU1("ML",T,.L)
. I L(XFONT)<1.75 D PRINT(T,0) S PSOFONT=OFONT,PSOX=OPSOX Q
. F F=10,9,8,6 I L(F)<4.5 Q
. S XFONT=F,PSOFONT="F"_F,PSOYI=$S(PSOFONT="F12":40,PSOFONT="F10":35,PSOFONT="F9":30,PSOFONT="F8":25,1:20)
. F J=$L(T," "):-1:1 S PTEXT=$P(T," ",1,J) D STRT^PSOLLU1("ML",PTEXT,.L) D Q:T=""
.. I FIRST I L(XFONT)<1.75 D PRINT(PTEXT,0) S T=$P(T," ",J+1,512),J=$L(T," ")+1,PTEXT="",FIRST=0,PSOX=OPSOX,PSOY=PSOY+20 Q
.. I 'FIRST I L(XFONT)<2.3 D PRINT(PTEXT,0) S T=$P(T," ",J+1,512),J=$L(T," ")+1,PTEXT=""
. D:PTEXT]"" PRINT(PTEXT,0)
I T="MAIL -" D PRINT(T,1)
S PSOFONT=OFONT
CONT I $G(SIDE) G BARC:'L5,CONT2
I $G(COPIES)>1 G BARC
I 'L2!PFM D ^PSOLLL2 S L2=1
I 'L3 D ^PSOLLL3 S L3=1
; IHS/CIA/PLS - 10/27/04 - Incorrect variable was set
;I 'L4!PMIM S PIMI=0 D ^PSOLLL4 S L4=1
I 'L4!PMIM S PMIM=0 D ^PSOLLL4 S L4=1
I L5 W @IOF G CONT2
; IHS/CIA/PLS - 03/08/04 - Changed to use barcode output routine
BARC I $G(BOTTLBL) G BARCE ; ONLY PRINT BARCODE ON 1ST BOTTLE LABEL
S BOTTLBL=1
;I $G(PSOIO("BLBC"))]"" X PSOIO("BLBC") I $G(NOBARC) G BARCE
I $G(NOBARC) G BARCE
; IHS/CIA/PLS - 03/08/04 - Changed to use barcode output routine
;S X2=PSOINST_"-"_RX W X2
;IHS/MSC/PLS - 12/06/07 - Moved the top of barcode up by 60 points
;S X2=PSOINST_$S($L(PSOINST):"-",1:"")_RX W $$BC^CIAUBC28(X2,1,50,950,120)
S X2=PSOINST_$S($L(PSOINST):"-",1:"")_RX W $$BC^CIAUBC28(X2,1,50,950,60)
;W $$BC^CIAUBC28($TR($$NDCVAL^APSPFUNC(RX,+$G(RXFL(RX))),"-","")_","_+$G(QTY),1,50,970,120)
;I $G(PSOIO("EBLBC"))]"" X PSOIO("EBLBC")
BARCE W @IOF
COPY I SIGF S SIGM=1 G L1 ; NEED TO FINISH PRINTING CONTINUED BOTTLE LABEL
S FILLCONT=0 I PFM!PMIM S FILLCONT=1 G L1
I $G(COPIES)>1 D G L1
. S COPIES=COPIES-1
. S (SIGM,PFM,PMIM,L2,L3,L4,L5,BOTTLBL)=0
. K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1
. F I="A","B","I" S PMIF(I)=1
S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA
S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
;IHS/MSC/MGH - 07/26/2013
;S ^PSRX(RX,"L",IR,0)=PSOFNOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
D ;need because line was to long IHS/MSC/PLS -03/14/2013
.N DATA
.S DATA=PSOFNOW_U_$S($G(RXP):99-RXPI,1:RXF)_U_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),U))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):$S($G(APSPREIS)=1:" (Reissue)",1:" (Reprint)"),1:"")
.S DATA=DATA_U_PDUZ
.S ^PSRX(RX,"L",IR,0)=DATA
N PSOBADR,PSOTEMP
S PSOBADR=$$CHKRX^PSOBAI(RX)
I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^")
I $G(PSOBADR),'$G(PSOTEMP) D
.S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
.S ^PSRX(RX,"L",IR,0)=PSOFNOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ
S L5=1
CONT2 I SIGF S SIGM=1 G L1 ; MORE BOTTLE LABEL SIG TO PRINT
I PMIM G CONT ; MORE PMI INFO TO PRINT
I $G(PSOBLALL)=1,$P(PPL,",",PI+1)="" D TRAIL
Q
PRINT(T,B) ;
S BOLD=$G(B)
I 'BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
I BOLD,$G(PSOIO(PSOFONT_"B"))]"" X PSOIO(PSOFONT_"B")
I $G(PSOIO("ST"))]"" X PSOIO("ST")
W T,!
I $G(PSOIO("ET"))]"" X PSOIO("ET")
I BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT) ;TURN OFF BOLDING
Q
TRAIL G END ; IHS/CIA/PLS - 03/31/04 - Suppress printing of last page
;I $G(SIDE) G END
D ^PSOLLL5
D ^PSOLLLH
D ^PSOLLL6
I '$P($G(^PS(59,PSOSITE,1)),"^",18) Q
I '$G(REPRINT) D ^PSOLLL7
END I '$P(PSOPAR,"^",31) Q
W @IOF
I $G(PSOIO("PMII"))]"" X PSOIO("PMII")
I $G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
S T="NEXT PATIENT"
S PSOX=1100-(L($E(PSOFONT,2,99))*300/2)
I $G(PSOIO("ST"))]"" X PSOIO("ST")
W T,!
I $G(PSOIO("ET"))]"" X PSOIO("ET")
Q
; Return initials associated with user
USRINI(IEN) ;
Q:'IEN " "
Q $$GET1^DIQ(200,IEN,1)
; Output Outpatient Facility Mailing Address
ADDRESS ;
N PS,VAADDR1,VASTREET,STATE,OFONT,PSOFONT,PSZIP,PSOHZIP
S PSOFONT="F6",PSOYI=25
S PSOX=0
S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
; IHS/CIA/PLS - 10/15/04 - Added tech initials to bottle label
S VAADDR1=$$LJ^XLFSTR(VAADDR1,30)_$$RJ^XLFSTR(TECH,19)
S PSZIP=$P(PS,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
D PRINT(VAADDR1,0)
S T=$G(VASTREET) D PRINT(T,0)
S T=$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP)_" Ph: "_$P(PS,"^",3)_"-"_$P(PS,"^",4) D PRINT(T,0)
Q
PSOLLL1 ;BIR/BHW - LASER LABELS ;07-Nov-2013 14:58;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**120,141,135,162,1001,1005,1006,1008,1009,1013,161,233,200,264,326,1015,1016,1018**;DEC 1997;Build 21
+2 ;
+3 ;Reference to ^PSDRUG supported by DBIA 221
+4 ;Reference ^VA(200,D0,"PS" supported by DBIA 224
+5 ;External reference to ^PS(55 supported by DBIA 2228
+6 ; Modified - IHS/CIA/PLS - 03/01/04
+7 ; 10/15/04 - Line ADDRESS+6
+8 ; 10/27/04 - Line CONT+4
+9 ; IHS/MSC/PLS 09/11/07 - Line L1+40
+10 ; 10/25/07 - Line ST+7
+11 ; 05/01/09 - Line L1+53
+12 ; 04/30/10 - Line W
+13 ; 06/02/10 - Line WARN+14
+14 ; 09/26/11 - Line W+1,W+2
+15 ; IHS/MSC/MGH - 02/26/13 - Line COPY+9
+16 ; IHS/MSC/PLS - 08/30/13 - Line COPY+14
ST IF $PIECE($GET(^PSRX(RX,3)),"^",3)
SET PSOPROV=+$PIECE(^(0),"^",4)
SET PSOPROV=$SELECT($GET(RXP):+$PIECE($GET(RXP),"^",17),$GET(RXF):+$PIECE($GET(^PSRX(RX,1,RXF,0)),"^",17),1:PSOPROV)
IF '$GET(PSOPROV)
SET PSOPROV=+$PIECE(^PSRX(RX,0),"^",4)
Begin DoDot:1
+1 IF +$PIECE($GET(^VA(200,PSOPROV,"PS")),"^",7)
IF '$PIECE($GET(PHYS),"/",2)
SET PHYS=$GET(PHYS)_"/"_+$PIECE($GET(^PSRX(RX,3)),"^",3)
End DoDot:1
+2 SET $PIECE(ULN,"_",34)=""
SET PSOTRAIL=1
+3 SET (Y,X1)=EXPDT
XECUTE ^DD("DD")
SET EXPDT=Y
SET Y=$PIECE(^PSRX(RX,0),"^",13)
XECUTE ^DD("DD")
SET ISD=Y
SET X2=DT
DO ^%DTC
SET DIFF=X
+4 SET Y=DATE
XECUTE ^DD("DD")
SET DATE=Y
+5 ; IHS/CIA/PLS - 03/06/04 - Set TECH to initials and not New Person IEN
+6 ;S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")"
+7 ; IHS/MSC/PLS - 10/25/07 - Changed logic to call $$LBLINI^APSPLBL
+8 ;S TECH="("_$$USRINI($S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16)))_"/"_$$USRINI($S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" "))_")"
+9 SET TECH="("_$$LBLINI^APSPLBL(RX,$SELECT($GET(RXP):"P",$GET(RXF):"R",1:""),$SELECT($GET(RXP):RXP,$GET(RXF):RXF,1:""))_"/"_$$USRINI($SELECT($GET(VRPH)&($PIECE(PSOPAR,"^",32)):VRPH,1:" "))_")"
+10 SET PSZIP=$PIECE(PS,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
L1 IF $GET(PSOIO("BLH"))]""
XECUTE PSOIO("BLH")
+1 ; PRINT ONE SCRIPTALK LABEL IF APPLICABLE
IF 'SIGF
IF 'SIGM
IF 'PMIM
KILL PSOSTLK,ZTKDRUG
IF $LENGTH($TEXT(PSOSTALK^PSOTALK1))
DO PSOSTALK^PSOTALK1
Begin DoDot:1
+2 ;D 6^VADPT,PID^VADPT6 S SSNPN="" ;IHS/MSC/PLS 06/14/13
End DoDot:1
SET PSOSTLK=1
+3 ; IHS/CIA/PLS - 03/31/04 - Change VAMC to IHS
+4 ;S T="VAMC "_$P(PS,"^",7)_", "_STATE_" "_$G(PSOHZIP) S:SIGF!($G(FILLCONT)) T=" " D PRINT(T)
+5 IF '$GET(FILLCONT)
DO ADDRESS
+6 ;S T=$P(PS2,"^",2)_" "_TECH_" Ph: "_$P(PS,"^",3)_"-"_$P(PS,"^",4) S:SIGF!($G(FILLCONT)) T=" " D PRINT(T) ; IHS/PLS/CIA - 03/31/04 - Suppress - no room
+7 SET PSDU=$PIECE($GET(^PSDRUG($PIECE($GET(^PSRX(RX,0)),"^",6),660)),"^",8)
+8 IF $GET(PSOIO("BLB"))]""
XECUTE PSOIO("BLB")
+9 SET XFONT=$EXTRACT(PSOFONT,2,99)
+10 SET T="Rx# "_RXN_" "
IF SIGF!($GET(FILLCONT))
SET T=" "
DO PRINT(T,1)
+11 DO STRT^PSOLLU1("RX#",T,.L)
SET PSOY=PSOY-PSOYI
SET OPSOX=PSOX
SET PSOX=L(XFONT)*300+PSOX
+12 SET DR=$GET(SIGF("DR"))
+13 SET T=" "_DATE_" "_$SELECT('SIGF:"Fill "_(RXF+1)_" of "_(1+$PIECE(RXY,"^",9)),1:"(label continued)")
IF SIGF!($GET(FILLCONT))
SET T=" "
DO PRINT(T)
+14 SET PSOX=OPSOX
SET T=PNM
IF SIGF!($GET(FILLCONT))
SET T=" "
IF T'=" "
DO PRINT(T,1)
+15 IF DR>1
SET PSOX=OPSOX
SET T="Rx# "_RXN_" (label continued)"
DO PRINT(T)
+16 DO STRT^PSOLLU1("SIG",T,.L)
+17 SET OPSOX=PSOX
SET PSOX=L(XFONT)*300+PSOX
SET PSOY=PSOY-PSOYI
SET T=" "_$GET(SSNPN)
IF SIGF!($GET(FILLCONT))
SET T=" "
DO PRINT(T)
+18 SET PSOX=OPSOX
SET LENGTH=0
SET PTEXT=""
SET SIGF=0
SET XFONT=$EXTRACT(PSOFONT,2,99)
+19 NEW DP,TEXTP,TEXTL,MORE
+20 IF 'SIGM
IF '$GET(FILLCONT)
DO COUNTSG^PSOLLLW
+21 SET DR=SIGF("DR")
+22 IF DR>1
IF '$DATA(NSGY(DR,4))
Begin DoDot:1
+23 ; BOTTOM-JUSTIFY CONTINUED BOTTLE SIG JUST ABOVE 'DISCARD' LINE
FOR I=4:-1:1
IF $DATA(NSGY(DR,I))
QUIT
SET T=" "
DO PRINT(T)
End DoDot:1
+24 FOR I=1:1
IF '$DATA(NSGY(DR,I))
QUIT
SET TEXT=NSGY(DR,I)
DO PRINT(TEXT)
+25 IF I>4
IF $DATA(NSGY(DR,5))
SET SIGF=1
SET SIGF("DR")=DR+1
+26 IF $GET(PSOIO("BLF"))]""
XECUTE PSOIO("BLF")
+27 SET PSOY=PSODY-PSOYI
SET PSOFONT=PSODFONT
+28 IF SIGF
IF 'SIGM&('$GET(FILLCONT))
GOTO WARN
GOTO CONT
+29 IF '$DATA(NSGY)
GOTO CONT
+30 KILL NSGY,^TMP($JOB,"PSOSIG",RX)
+31 DO NOW^%DTC
SET X1=X
SET X2=365
DO C^%DTC
SET Y=X
XECUTE ^DD("DD")
+32 SET DEA=$PIECE($GET(^PSDRUG($PIECE(RXY,"^",6),0)),"^",3)
SET T=""
+33 IF DEA'["S"
SET T="Discard after "_$SELECT(DEA[0!(DEA["M"):"_________",1:Y)_"__________ "
+34 SET T=T_"Mfr_________"
DO PRINT(T)
+35 SET PSOY=PSOY-7
+36 Begin DoDot:1
+37 SET NOR=$PIECE(RXY,"^",9)-RXF
+38 IF $PIECE(RXY,"^",9)=0
SET T="NO REFILL"
QUIT
+39 IF NOR=0
SET T="NO REFILLS LEFT"
QUIT
+40 SET T="May refill "_NOR_"X by "_EXPDT
End DoDot:1
SET PSOFONT="F8"
DO PRINT(T)
+41 IF $$GET1^DIQ(9009033,PSOSITE,311,"I")
Begin DoDot:1
+42 SET PSOY=PSOY-10
+43 ;IHS/MSC/PLS - 09/11/07
SET T="NDC "_$$NDCVAL^APSPFUNC(RX,+$GET(RXFL(RX)))
DO PRINT(T)
End DoDot:1
+44 SET PPHYS=$GET(PHYS)
+45 SET XFONT=$EXTRACT(PSOQFONT,2,99)
+46 SET TEXT="Qty: "
DO STRT^PSOLLU1("SIG",TEXT,.L)
SET Q(1)=L(XFONT)
+47 SET TEXT=" "_PSDU
DO STRT^PSOLLU1("SIG",TEXT,.L)
SET Q(2)=L(XFONT)
+48 SET TEXT=" "_$GET(PHYS)
DO STRT^PSOLLU1("SIG",TEXT,.L)
SET Q(3)=L(XFONT)
+49 SET TEXT=$GET(QTY)
DO STRT^PSOLLU1("SIG",TEXT,.L)
SET LENGTH=Q(1)+Q(2)+Q(3)+L(XFONT+2)
SET Q(4)=L(XFONT+2)
+50 IF LENGTH>3
FOR I=$LENGTH(PHYS)-1:-1:1
SET PPHYS=$EXTRACT(PHYS,1,I)
SET TEXT=" "_PPHYS
DO STRT^PSOLLU1("SIG",TEXT,.L)
IF Q(1)+Q(2)+Q(4)+L(XFONT)<3.3
QUIT
+51 ;S PSOFONT=PSOTFONT,OPSOX=PSOX,PSOX=PSOX+(Q(1)*300),PSOY=PSOQY-PSOYI,T=$G(QTY) D PRINT(T)
+52 SET PSOFONT=PSOTFONT
SET OPSOX=PSOX
SET PSOX=PSOX+(Q(1)*300)
+53 SET PSOY=PSOQY-PSOYI+9
+54 SET T=$GET(QTY)
DO PRINT(T)
+55 SET PSOX=OPSOX
SET PSOFONT=PSOQFONT
SET PSOY=PSOY-PSOYI
SET T="Qty: "
DO PRINT(T)
+56 SET PSOX=PSOX+(Q(1)+Q(4)*300)
SET PSOY=PSOY-PSOYI
SET T=" "_$GET(PSDU)_" "_$GET(PPHYS)
DO PRINT(T)
+57 SET PSOFONT=PSOTFONT
SET PSOX=OPSOX
SET PSOY=PSOTY-PSOYI
SET T=DRUG
DO STRT^PSOLLU1("SIG",T,.L)
+58 ;I L($E(PSOFONT,2,99))>3 S PSOFONT=$S(PSOFONT="F12":"F10",PSOFONT="F10":"F9",PSOFONT="F9":F8,PSOFONT="F8":"F6")
+59 ;IHS/MSC/PLS 05/01/09 - Corrected typo.
IF L($EXTRACT(PSOFONT,2,99))>3
SET PSOFONT=$SELECT(PSOFONT="F12":"F10",PSOFONT="F10":"F9",PSOFONT="F9":"F8",PSOFONT="F8":"F6")
+60 SET ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX"
+61 IF $GET(PSOSTLK)
SET T=$SELECT($GET(PSOSTALK):ZTKDRUG,1:DRUG)
+62 DO PRINT(T,1)
+63 IF SIGM
GOTO CONT
+64 SET ^PSRX(RX,"TYPE")=0
WARN ;PRINT WARNING LABELS
+1 IF $GET(PSOIO("WLI"))]""
XECUTE PSOIO("WLI")
+2 ; IF <5 WARNINGS, PRINT LABELS BOTTOM-JUSTIFIED
+3 SET PSOLAN=$PIECE($GET(^PS(55,DFN,"LAN")),"^",2)
+4 SET WARN5=WARN
FOR
IF $LENGTH(WARN5,",")>4
QUIT
SET WARN5=" ,"_WARN5
+5 FOR WWW=1:1:5
SET PSOWARN=$PIECE(WARN5,",",WWW)
IF PSOWARN'=""
Begin DoDot:1
+6 IF PSOWARN["N"
DO NEWWARN^PSOLLLW
QUIT
+7 DO WARN54^PSOLLLW
End DoDot:1
+8 ;RETURN MAIL
+9 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
IF $PIECE(PSOSYS,"^",4)
IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
+10 SET VAADDR1=$PIECE(PS,"^")
SET VASTREET=$PIECE(PS,"^",2)
SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+11 SET PSZIP=$PIECE(PS,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+12 IF $GET(PSOIO("RMI"))]""
XECUTE PSOIO("RMI")
+13 SET PSOYI=$GET(PSOHYI,40)
SET OFONT=PSOFONT
SET PSOFONT=$GET(PSOHFONT)
+14 ;IHS/MSC/PLS - 06/02/2010
SET BLNKLIN=""
SET $PIECE(BLNKLIN," ",30)=" "
+15 ; IHS/CIA/PLS - 03/05/04 - Changed 119 to Pharmacy
+16 ;S T="Attn: (119)"_BLNKLIN_$$FMTE^XLFDT(DT) D PRINT(T,0)
+17 SET T="Attn: Pharmacy"_BLNKLIN_$$FMTE^XLFDT(DT)
DO PRINT(T,0)
+18 SET T=$GET(VASTREET)
DO PRINT(T,0)
+19 SET T=$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
DO PRINT(T,0)
+20 SET PSOY=PSOY+PSOYI
SET T=$SELECT(PS55=2:"***DO NOT MAIL***",1:"")
IF T'=""
DO PRINT(T,0)
+21 IF T'="***DO NOT MAIL***"
SET T=$SELECT(PS55[0!(PS55[3)!(PS55=""):"REGULAR MAIL",1:"CERTIFIED MAIL")
SET T=T_"-"_$GET(MAILCOM)
IF $LENGTH(T)>25
SET PSOFONT="F8"
DO PRINT(T,0)
+22 SET PSOFONT=OFONT
+23 SET T=PNM
+24 SET PSOY=PSOY+PSOYI
SET PSOYI=PSORYI
DO PRINT(T,0)
+25 IF $GET(VAPA(1))=""!(PS55=2)
GOTO W
+26 ; ADD CHECK FOR BAD ADDRESS INDICATOR OR FOREIGN ADDRESS
+27 NEW PSOBADR,PSOTEMP,PSOFORGN,I
+28 SET PSOBADR=0
SET PSOTEMP=0
+29 SET PSOFORGN=$PIECE($GET(VAPA(25)),"^",2)
IF PSOFORGN'=""
IF PSOFORGN'["UNITED STATES"
SET PSOFORGN=1
+30 IF 'PSOFORGN
SET PSOBADR=$$BADADR^DGUTL3(DFN)
+31 IF 'PSOFORGN
IF PSOBADR
SET PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
+32 FOR I=1:1:3
IF $GET(VAPA(I))]""
Begin DoDot:1
+33 SET T=""
IF I=1
IF 'PSOFORGN
IF PSOBADR
IF '$GET(PSOTEMP)
SET T="** BAD ADDRESS INDICATED **"
+34 IF I=1
IF T=""
IF PSOFORGN
SET T="*** FOREIGN ADDRESS ***"
+35 IF T=""
IF 'PSOFORGN
IF 'PSOBADR!$GET(PSOTEMP)
SET T=$GET(VAPA(I))
+36 DO STRT^PSOLLU1("ML",T,.L)
IF L($EXTRACT(PSOFONT,2,99))<2.37
DO PRINT(T,0)
QUIT
+37 FOR F=12,10,9,8,6
IF L(F)<2.37
SET OFONT=PSOFONT
SET PSOFONT="F"_F
DO PRINT(T,0)
SET PSOFONT=OFONT
QUIT
End DoDot:1
+38 SET A=+$GET(VAPA(5))
IF A
SET A=$SELECT($DATA(^DIC(5,A,0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+39 SET T=""
IF 'PSOFORGN
IF 'PSOBADR!$GET(PSOTEMP)
SET T=$GET(VAPA(4))_", "_A_" "_$SELECT($GET(VAPA(11)):$PIECE(VAPA(11),"^",2),1:$GET(VAPA(6)))
+40 DO PRINT(T,0)
W ;IHS/MSC/PLS - 04/30/10
IF $$GET1^DIQ(9009033,PSOSITE,320,"I")
DO PRINT("DOB:"_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN),"5Z"),0)
+1 ;IHS/MSC/PLS - 09/26/2011
IF $$GET1^DIQ(9009033,PSOSITE,403,"I")
DO PRINT("NPI:"_$$GET1^DIQ(200,$PIECE(^PSRX(RX,0),U,4),41.99))
+2 ;IHS/MSC/PLS - 09/26/2011
IF $$GET1^DIQ(9009033,PSOSITE,404,"I")
DO PRINT("DEA:"_$$DEAVAUS^APSPFUNC($PIECE(^PSRX(RX,0),U,4)))
+3 SET T=$SELECT(MW">W="W">WINDOW">W":"W">WINDOW">W -",1:"MAIL -")
+4 NEW XFONT
+5 SET OFONT=PSOFONT
SET PSOYI=$GET(PSOTYI,40)
SET PSOFONT=PSOTFONT
SET XFONT=$EXTRACT(PSOFONT,2,99)
SET PSOY=PSOTY
+6 IF T["WINDOW"
Begin DoDot:1
+7 ; START 1 LINE HIGHER IF METHOD OF PICK-UP
IF $GET(^PSRX(RX,"MP"))'=""
SET PSOY=PSOY-PSOYI
+8 SET OPSOX=PSOX
DO PRINT(T,1)
SET PSOX=PSOX+200
SET PSOY=PSOY-PSOYI
+9 SET T=$GET(^PSRX(RX,"MP"))
IF T=""
SET PSOFONT=OFONT
SET PSOX=OPSOX
QUIT
+10 NEW FIRST
+11 SET FIRST=1
+12 DO STRT^PSOLLU1("ML",T,.L)
+13 IF L(XFONT)<1.75
DO PRINT(T,0)
SET PSOFONT=OFONT
SET PSOX=OPSOX
QUIT
+14 FOR F=10,9,8,6
IF L(F)<4.5
QUIT
+15 SET XFONT=F
SET PSOFONT="F"_F
SET PSOYI=$SELECT(PSOFONT="F12":40,PSOFONT="F10":35,PSOFONT="F9":30,PSOFONT="F8":25,1:20)
+16 FOR J=$LENGTH(T," "):-1:1
SET PTEXT=$PIECE(T," ",1,J)
DO STRT^PSOLLU1("ML",PTEXT,.L)
Begin DoDot:2
+17 IF FIRST
IF L(XFONT)<1.75
DO PRINT(PTEXT,0)
SET T=$PIECE(T," ",J+1,512)
SET J=$LENGTH(T," ")+1
SET PTEXT=""
SET FIRST=0
SET PSOX=OPSOX
SET PSOY=PSOY+20
QUIT
+18 IF 'FIRST
IF L(XFONT)<2.3
DO PRINT(PTEXT,0)
SET T=$PIECE(T," ",J+1,512)
SET J=$LENGTH(T," ")+1
SET PTEXT=""
End DoDot:2
IF T=""
QUIT
+19 IF PTEXT]""
DO PRINT(PTEXT,0)
End DoDot:1
+20 IF T="MAIL -"
DO PRINT(T,1)
+21 SET PSOFONT=OFONT
CONT IF $GET(SIDE)
IF 'L5
GOTO BARC
GOTO CONT2
+1 IF $GET(COPIES)>1
GOTO BARC
+2 IF 'L2!PFM
DO ^PSOLLL2
SET L2=1
+3 IF 'L3
DO ^PSOLLL3
SET L3=1
+4 ; IHS/CIA/PLS - 10/27/04 - Incorrect variable was set
+5 ;I 'L4!PMIM S PIMI=0 D ^PSOLLL4 S L4=1
+6 IF 'L4!PMIM
SET PMIM=0
DO ^PSOLLL4
SET L4=1
+7 IF L5
WRITE @IOF
GOTO CONT2
+8 ; IHS/CIA/PLS - 03/08/04 - Changed to use barcode output routine
BARC ; ONLY PRINT BARCODE ON 1ST BOTTLE LABEL
IF $GET(BOTTLBL)
GOTO BARCE
+1 SET BOTTLBL=1
+2 ;I $G(PSOIO("BLBC"))]"" X PSOIO("BLBC") I $G(NOBARC) G BARCE
+3 IF $GET(NOBARC)
GOTO BARCE
+4 ; IHS/CIA/PLS - 03/08/04 - Changed to use barcode output routine
+5 ;S X2=PSOINST_"-"_RX W X2
+6 ;IHS/MSC/PLS - 12/06/07 - Moved the top of barcode up by 60 points
+7 ;S X2=PSOINST_$S($L(PSOINST):"-",1:"")_RX W $$BC^CIAUBC28(X2,1,50,950,120)
+8 SET X2=PSOINST_$SELECT($LENGTH(PSOINST):"-",1:"")_RX
WRITE $$BC^CIAUBC28(X2,1,50,950,60)
+9 ;W $$BC^CIAUBC28($TR($$NDCVAL^APSPFUNC(RX,+$G(RXFL(RX))),"-","")_","_+$G(QTY),1,50,970,120)
+10 ;I $G(PSOIO("EBLBC"))]"" X PSOIO("EBLBC")
BARCE WRITE @IOF
COPY ; NEED TO FINISH PRINTING CONTINUED BOTTLE LABEL
IF SIGF
SET SIGM=1
GOTO L1
+1 SET FILLCONT=0
IF PFM!PMIM
SET FILLCONT=1
GOTO L1
+2 IF $GET(COPIES)>1
Begin DoDot:1
+3 SET COPIES=COPIES-1
+4 SET (SIGM,PFM,PMIM,L2,L3,L4,L5,BOTTLBL)=0
+5 KILL SIGF,PFF,PMIF
SET (SIGF,PFF,PMIF)=0
FOR I="DR","T"
SET (SIGF(I),PFF(I))=1
+6 FOR I="A","B","I"
SET PMIF(I)=1
End DoDot:1
GOTO L1
+7 SET IR=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(RX,"L",FDA))
IF 'FDA
QUIT
SET IR=FDA
+8 SET IR=IR+1
SET ^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
+9 ;IHS/MSC/MGH - 07/26/2013
+10 ;S ^PSRX(RX,"L",IR,0)=PSOFNOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
+11 ;need because line was to long IHS/MSC/PLS -03/14/2013
Begin DoDot:1
+12 NEW DATA
+13 SET DATA=PSOFNOW_U_$SELECT($GET(RXP):99-RXPI,1:RXF)_U_$SELECT($GET(PCOMX)]"":...
... $GET(PCOMX),$GET(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$PIECE(^PSRX(RX,0),U))_$SELECT($GET(RXP):" (Partial)",1:"")_$SELECT($DATA(REPRINT):$SELECT($GET(APSPREIS)=1:" (Reissue)",1:" (Reprint)"),1:"")
+14 SET DATA=DATA_U_PDUZ
+15 SET ^PSRX(RX,"L",IR,0)=DATA
End DoDot:1
+16 NEW PSOBADR,PSOTEMP
+17 SET PSOBADR=$$CHKRX^PSOBAI(RX)
+18 IF $GET(PSOBADR)
SET PSOTEMP=$PIECE(PSOBADR,"^",2)
SET PSOBADR=$PIECE(PSOBADR,"^")
+19 IF $GET(PSOBADR)
IF '$GET(PSOTEMP)
Begin DoDot:1
+20 SET IR=IR+1
SET ^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
+21 SET ^PSRX(RX,"L",IR,0)=PSOFNOW_"^"_$SELECT($GET(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$GET(MW)_" (BAD ADDRESS)"_"^"_PDUZ
End DoDot:1
+22 SET L5=1
CONT2 ; MORE BOTTLE LABEL SIG TO PRINT
IF SIGF
SET SIGM=1
GOTO L1
+1 ; MORE PMI INFO TO PRINT
IF PMIM
GOTO CONT
+2 IF $GET(PSOBLALL)=1
IF $PIECE(PPL,",",PI+1)=""
DO TRAIL
+3 QUIT
PRINT(T,B) ;
+1 SET BOLD=$GET(B)
+2 IF 'BOLD
IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+3 IF BOLD
IF $GET(PSOIO(PSOFONT_"B"))]""
XECUTE PSOIO(PSOFONT_"B")
+4 IF $GET(PSOIO("ST"))]""
XECUTE PSOIO("ST")
+5 WRITE T,!
+6 IF $GET(PSOIO("ET"))]""
XECUTE PSOIO("ET")
+7 ;TURN OFF BOLDING
IF BOLD
IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+8 QUIT
TRAIL ; IHS/CIA/PLS - 03/31/04 - Suppress printing of last page
GOTO END
+1 ;I $G(SIDE) G END
+2 DO ^PSOLLL5
+3 DO ^PSOLLLH
+4 DO ^PSOLLL6
+5 IF '$PIECE($GET(^PS(59,PSOSITE,1)),"^",18)
QUIT
+6 IF '$GET(REPRINT)
DO ^PSOLLL7
END IF '$PIECE(PSOPAR,"^",31)
QUIT
+1 WRITE @IOF
+2 IF $GET(PSOIO("PMII"))]""
XECUTE PSOIO("PMII")
+3 IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+4 SET T="NEXT PATIENT"
+5 SET PSOX=1100-(L($EXTRACT(PSOFONT,2,99))*300/2)
+6 IF $GET(PSOIO("ST"))]""
XECUTE PSOIO("ST")
+7 WRITE T,!
+8 IF $GET(PSOIO("ET"))]""
XECUTE PSOIO("ET")
+9 QUIT
+10 ; Return initials associated with user
USRINI(IEN) ;
+1 IF 'IEN
QUIT " "
+2 QUIT $$GET1^DIQ(200,IEN,1)
+3 ; Output Outpatient Facility Mailing Address
ADDRESS ;
+1 NEW PS,VAADDR1,VASTREET,STATE,OFONT,PSOFONT,PSZIP,PSOHZIP
+2 SET PSOFONT="F6"
SET PSOYI=25
+3 SET PSOX=0
+4 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
IF $PIECE(PSOSYS,"^",4)
IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
+5 SET VAADDR1=$PIECE(PS,"^")
SET VASTREET=$PIECE(PS,"^",2)
SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+6 ; IHS/CIA/PLS - 10/15/04 - Added tech initials to bottle label
+7 SET VAADDR1=$$LJ^XLFSTR(VAADDR1,30)_$$RJ^XLFSTR(TECH,19)
+8 SET PSZIP=$PIECE(PS,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+9 DO PRINT(VAADDR1,0)
+10 SET T=$GET(VASTREET)
DO PRINT(T,0)
+11 SET T=$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)_" Ph: "_$PIECE(PS,"^",3)_"-"_$PIECE(PS,"^",4)
DO PRINT(T,0)
+12 QUIT
