- PSOLLL1 ;BIR/BHW - LASER LABELS ;10/24/2002
- ;;7.0;OUTPATIENT PHARMACY;**120,141,135,162,161,233,200,264,326,338,367,383,370**;DEC 1997;Build 14
- ;
- ;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
- ;
- 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(^VA(200,+$P($G(^PSRX(RX,3)),"^",3),0)),"^")
- 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
- 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:" ")_")"
- 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=""
- S T="VAMC "_$P(PS,"^",7)_", "_STATE_" "_$G(PSOHZIP) S:SIGF!($G(FILLCONT)) T=" " D PRINT(T)
- S T=$P(PS2,"^",2)_" "_TECH_" Ph: "_$P(PS,"^",3)_"-"_$P(PS,"^",4) S:SIGF!($G(FILLCONT)) T=" " D PRINT(T)
- 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-5
- 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
- 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 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")
- 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
- K PSOWLBL
- 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," ",40)=" "
- S T="Attn: (119)"_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=""):"",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'="" D ;*370
- . N PSOFOREN S PSOFOREN=1
- . I PSOFORGN["UNITED STATES",$P(PS,"^")'["MANILA" S PSOFOREN=0
- . I PSOFORGN["PHILIPPINES",$P(PS,"^")["MANILA" S PSOFOREN=0
- . S PSOFORGN=PSOFOREN
- 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 ;
- 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
- I 'L4!PMIM S PIMI=0 D ^PSOLLL4 S L4=1
- I L5 W @IOF G CONT2
- 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
- S X2=PSOINST_"-"_RX W X2
- 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
- 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
- ;
- ;Storing FDA Medication Guide filename in the Prescription file
- I $$MGONFILE^PSOFDAUT(RX) D
- . I $G(RXRP(RX)),'$G(RXRP(RX,"MG")) Q
- . S ^PSRX(RX,"L",IR,"FDA")=$P($$MGONFILE^PSOFDAUT(RX),"^",2)
- ;
- 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 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLLL1 10117 printed Feb 18, 2025@23:56:57 Page 2
- PSOLLL1 ;BIR/BHW - LASER LABELS ;10/24/2002
- +1 ;;7.0;OUTPATIENT PHARMACY;**120,141,135,162,161,233,200,264,326,338,367,383,370**;DEC 1997;Build 14
- +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 ;
- 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(^VA(200,+$PIECE($GET(^PSRX(RX,3)),"^",3),0)),"^")
- 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 SET TECH="("_$SELECT($PIECE($GET(^PSRX(+$GET(RX),"OR1")),"^",5):$PIECE($GET(^PSRX(+$GET(RX),"OR1")),"^",5),1:$PIECE(RXY,"^",16))_"/"_$SELECT($GET(VRPH)&($PIECE(PSOPAR,"^",32)):VRPH,1:" ")_")"
- +6 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 DO 6^VADPT
- DO PID^VADPT6
- SET SSNPN=""
- End DoDot:1
- SET PSOSTLK=1
- +3 SET T="VAMC "_$PIECE(PS,"^",7)_", "_STATE_" "_$GET(PSOHZIP)
- if SIGF!($GET(FILLCONT))
- SET T=" "
- DO PRINT(T)
- +4 SET T=$PIECE(PS2,"^",2)_" "_TECH_" Ph: "_$PIECE(PS,"^",3)_"-"_$PIECE(PS,"^",4)
- if SIGF!($GET(FILLCONT))
- SET T=" "
- DO PRINT(T)
- +5 SET PSDU=$PIECE($GET(^PSDRUG($PIECE($GET(^PSRX(RX,0)),"^",6),660)),"^",8)
- +6 IF $GET(PSOIO("BLB"))]""
- XECUTE PSOIO("BLB")
- +7 SET XFONT=$EXTRACT(PSOFONT,2,99)
- +8 SET T="Rx# "_RXN_" "
- if SIGF!($GET(FILLCONT))
- SET T=" "
- DO PRINT(T,1)
- +9 DO STRT^PSOLLU1("RX#",T,.L)
- SET PSOY=PSOY-PSOYI
- SET OPSOX=PSOX
- SET PSOX=L(XFONT)*300+PSOX
- +10 SET DR=$GET(SIGF("DR"))
- +11 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)
- +12 SET PSOX=OPSOX
- SET T=PNM
- if SIGF!($GET(FILLCONT))
- SET T=" "
- IF T'=" "
- DO PRINT(T,1)
- +13 IF DR>1
- SET PSOX=OPSOX
- SET T="Rx# "_RXN_" (label continued)"
- DO PRINT(T)
- +14 DO STRT^PSOLLU1("SIG",T,.L)
- +15 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)
- +16 SET PSOX=OPSOX
- SET LENGTH=0
- SET PTEXT=""
- SET SIGF=0
- SET XFONT=$EXTRACT(PSOFONT,2,99)
- +17 NEW DP,TEXTP,TEXTL,MORE
- +18 IF 'SIGM
- IF '$GET(FILLCONT)
- DO COUNTSG^PSOLLLW
- +19 SET DR=SIGF("DR")
- +20 IF DR>1
- IF '$DATA(NSGY(DR,4))
- Begin DoDot:1
- +21 ; 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
- +22 FOR I=1:1
- if '$DATA(NSGY(DR,I))
- QUIT
- SET TEXT=NSGY(DR,I)
- DO PRINT(TEXT)
- +23 IF I>4
- IF $DATA(NSGY(DR,5))
- SET SIGF=1
- SET SIGF("DR")=DR+1
- +24 IF $GET(PSOIO("BLF"))]""
- XECUTE PSOIO("BLF")
- +25 SET PSOY=PSODY-PSOYI
- SET PSOFONT=PSODFONT
- +26 IF SIGF
- if 'SIGM&('$GET(FILLCONT))
- GOTO WARN
- GOTO CONT
- +27 IF '$DATA(NSGY)
- GOTO CONT
- +28 KILL NSGY,^TMP($JOB,"PSOSIG",RX)
- +29 DO NOW^%DTC
- SET X1=X
- SET X2=365
- DO C^%DTC
- SET Y=X
- XECUTE ^DD("DD")
- +30 SET DEA=$PIECE($GET(^PSDRUG($PIECE(RXY,"^",6),0)),"^",3)
- SET T=""
- +31 IF DEA'["S"
- SET T="Discard after "_$SELECT(DEA[0!(DEA["M"):"_________",1:Y)_"__________ "
- +32 SET T=T_"Mfr_________"
- DO PRINT(T)
- +33 SET PSOY=PSOY-5
- +34 Begin DoDot:1
- +35 SET NOR=$PIECE(RXY,"^",9)-RXF
- +36 IF $PIECE(RXY,"^",9)=0
- SET T="NO REFILL"
- QUIT
- +37 IF NOR=0
- SET T="NO REFILLS LEFT"
- QUIT
- +38 SET T="May refill "_NOR_"X by "_EXPDT
- End DoDot:1
- SET PSOFONT="F8"
- DO PRINT(T)
- +39 SET PPHYS=$GET(PHYS)
- +40 SET XFONT=$EXTRACT(PSOQFONT,2,99)
- +41 SET TEXT="Qty: "
- DO STRT^PSOLLU1("SIG",TEXT,.L)
- SET Q(1)=L(XFONT)
- +42 SET TEXT=" "_PSDU
- DO STRT^PSOLLU1("SIG",TEXT,.L)
- SET Q(2)=L(XFONT)
- +43 SET TEXT=" "_$GET(PHYS)
- DO STRT^PSOLLU1("SIG",TEXT,.L)
- SET Q(3)=L(XFONT)
- +44 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)
- +45 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
- +46 SET PSOFONT=PSOTFONT
- SET OPSOX=PSOX
- SET PSOX=PSOX+(Q(1)*300)
- SET PSOY=PSOQY-PSOYI
- SET T=$GET(QTY)
- DO PRINT(T)
- +47 SET PSOX=OPSOX
- SET PSOFONT=PSOQFONT
- SET PSOY=PSOY-PSOYI
- SET T="Qty: "
- DO PRINT(T)
- +48 SET PSOX=PSOX+(Q(1)+Q(4)*300)
- SET PSOY=PSOY-PSOYI
- SET T=" "_$GET(PSDU)_" "_$GET(PPHYS)
- DO PRINT(T)
- +49 SET PSOFONT=PSOTFONT
- SET PSOX=OPSOX
- SET PSOY=PSOTY-PSOYI
- SET T=DRUG
- DO STRT^PSOLLU1("SIG",T,.L)
- +50 IF L($EXTRACT(PSOFONT,2,99))>3
- SET PSOFONT=$SELECT(PSOFONT="F12":"F10",PSOFONT="F10":"F9",PSOFONT="F9":F8,PSOFONT="F8":"F6")
- +51 SET ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX"
- +52 IF $GET(PSOSTLK)
- SET T=$SELECT($GET(PSOSTALK):ZTKDRUG,1:DRUG)
- +53 DO PRINT(T,1)
- +54 IF SIGM
- GOTO CONT
- +55 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 KILL PSOWLBL
- +4 SET PSOLAN=$PIECE($GET(^PS(55,DFN,"LAN")),"^",2)
- +5 SET WARN5=WARN
- FOR
- if $LENGTH(WARN5,",")>4
- QUIT
- SET WARN5=" ,"_WARN5
- +6 FOR WWW=1:1:5
- SET PSOWARN=$PIECE(WARN5,",",WWW)
- IF PSOWARN'=""
- Begin DoDot:1
- +7 IF PSOWARN["N"
- DO NEWWARN^PSOLLLW
- QUIT
- +8 DO WARN54^PSOLLLW
- End DoDot:1
- +9 ;RETURN MAIL
- +10 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)
- +11 SET VAADDR1=$PIECE(PS,"^")
- SET VASTREET=$PIECE(PS,"^",2)
- SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
- +12 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:""))
- +13 IF $GET(PSOIO("RMI"))]""
- XECUTE PSOIO("RMI")
- +14 SET PSOYI=$GET(PSOHYI,40)
- SET OFONT=PSOFONT
- SET PSOFONT=$GET(PSOHFONT)
- +15 SET BLNKLIN=""
- SET $PIECE(BLNKLIN," ",40)=" "
- +16 SET T="Attn: (119)"_BLNKLIN_$$FMTE^XLFDT(DT)
- DO PRINT(T,0)
- +17 SET T=$GET(VASTREET)
- DO PRINT(T,0)
- +18 SET T=$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
- DO PRINT(T,0)
- +19 SET PSOY=PSOY+PSOYI
- SET T=$SELECT(PS55=2:"***DO NOT MAIL***",1:"")
- IF T'=""
- DO PRINT(T,0)
- +20 IF T'="***DO NOT MAIL***"
- SET T=$SELECT(PS55[0!(PS55[3)!(PS55=""):"",1:"CERTIFIED MAIL-")
- SET T=T_$GET(MAILCOM)
- if $LENGTH(T)>25
- SET PSOFONT="F8"
- DO PRINT(T,0)
- +21 SET PSOFONT=OFONT
- +22 SET T=PNM
- +23 SET PSOY=PSOY+PSOYI
- SET PSOYI=PSORYI
- DO PRINT(T,0)
- +24 IF $GET(VAPA(1))=""!(PS55=2)
- GOTO W
- +25 ; ADD CHECK FOR BAD ADDRESS INDICATOR OR FOREIGN ADDRESS
- +26 NEW PSOBADR,PSOTEMP,PSOFORGN,I
- +27 SET PSOBADR=0
- SET PSOTEMP=0
- +28 SET PSOFORGN=$PIECE($GET(VAPA(25)),"^",2)
- +29 ;*370
- IF PSOFORGN'=""
- Begin DoDot:1
- +30 NEW PSOFOREN
- SET PSOFOREN=1
- +31 IF PSOFORGN["UNITED STATES"
- IF $PIECE(PS,"^")'["MANILA"
- SET PSOFOREN=0
- +32 IF PSOFORGN["PHILIPPINES"
- IF $PIECE(PS,"^")["MANILA"
- SET PSOFOREN=0
- +33 SET PSOFORGN=PSOFOREN
- End DoDot:1
- +34 IF 'PSOFORGN
- SET PSOBADR=$$BADADR^DGUTL3(DFN)
- +35 IF 'PSOFORGN
- IF PSOBADR
- SET PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
- +36 FOR I=1:1:3
- IF $GET(VAPA(I))]""
- Begin DoDot:1
- +37 SET T=""
- IF I=1
- IF 'PSOFORGN
- IF PSOBADR
- IF '$GET(PSOTEMP)
- SET T="** BAD ADDRESS INDICATED **"
- +38 IF I=1
- IF T=""
- IF PSOFORGN
- SET T="*** FOREIGN ADDRESS ***"
- +39 IF T=""
- IF 'PSOFORGN
- IF 'PSOBADR!$GET(PSOTEMP)
- SET T=$GET(VAPA(I))
- +40 DO STRT^PSOLLU1("ML",T,.L)
- IF L($EXTRACT(PSOFONT,2,99))<2.37
- DO PRINT(T,0)
- QUIT
- +41 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
- +42 SET A=+$GET(VAPA(5))
- IF A
- SET A=$SELECT($DATA(^DIC(5,A,0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
- +43 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)))
- +44 DO PRINT(T,0)
- W ;
- +1 SET T=$SELECT(MW="WINDOW":"WINDOW -",1:"MAIL -")
- +2 NEW XFONT
- +3 SET OFONT=PSOFONT
- SET PSOYI=$GET(PSOTYI,40)
- SET PSOFONT=PSOTFONT
- SET XFONT=$EXTRACT(PSOFONT,2,99)
- SET PSOY=PSOTY
- +4 IF T["WINDOW"
- Begin DoDot:1
- +5 ; START 1 LINE HIGHER IF METHOD OF PICK-UP
- IF $GET(^PSRX(RX,"MP"))'=""
- SET PSOY=PSOY-PSOYI
- +6 SET OPSOX=PSOX
- DO PRINT(T,1)
- SET PSOX=PSOX+200
- SET PSOY=PSOY-PSOYI
- +7 SET T=$GET(^PSRX(RX,"MP"))
- IF T=""
- SET PSOFONT=OFONT
- SET PSOX=OPSOX
- QUIT
- +8 NEW FIRST
- +9 SET FIRST=1
- +10 DO STRT^PSOLLU1("ML",T,.L)
- +11 IF L(XFONT)<1.75
- DO PRINT(T,0)
- SET PSOFONT=OFONT
- SET PSOX=OPSOX
- QUIT
- +12 FOR F=10,9,8,6
- IF L(F)<4.5
- QUIT
- +13 SET XFONT=F
- SET PSOFONT="F"_F
- SET PSOYI=$SELECT(PSOFONT="F12":40,PSOFONT="F10":35,PSOFONT="F9":30,PSOFONT="F8":25,1:20)
- +14 FOR J=$LENGTH(T," "):-1:1
- SET PTEXT=$PIECE(T," ",1,J)
- DO STRT^PSOLLU1("ML",PTEXT,.L)
- Begin DoDot:2
- +15 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
- +16 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
- +17 if PTEXT]""
- DO PRINT(PTEXT,0)
- End DoDot:1
- +18 IF T="MAIL -"
- DO PRINT(T,1)
- +19 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 IF 'L4!PMIM
- SET PIMI=0
- DO ^PSOLLL4
- SET L4=1
- +5 IF L5
- WRITE @IOF
- GOTO CONT2
- BARC ; ONLY PRINT BARCODE ON 1ST BOTTLE LABEL
- IF $GET(BOTTLBL)
- GOTO BARCE
- +1 SET BOTTLBL=1
- +2 IF $GET(PSOIO("BLBC"))]""
- XECUTE PSOIO("BLBC")
- IF $GET(NOBARC)
- GOTO BARCE
- +3 SET X2=PSOINST_"-"_RX
- WRITE X2
- +4 IF $GET(PSOIO("EBLBC"))]""
- XECUTE 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 SET ^PSRX(RX,"L",IR,0)=PSOFNOW_"^"_$SELECT($GET(RXP):99-RXPI,1:RXF)_"^"_$SELECT($GET(PCOMX)]"":$GET(PCOMX),$GET(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$PIECE(^PSRX(RX,0),"^"))_...
- ... $SELECT($GET(RXP):" (Partial)",1:"")_$SELECT($DATA(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
- +10 ;
- +11 ;Storing FDA Medication Guide filename in the Prescription file
- +12 IF $$MGONFILE^PSOFDAUT(RX)
- Begin DoDot:1
- +13 IF $GET(RXRP(RX))
- IF '$GET(RXRP(RX,"MG"))
- QUIT
- +14 SET ^PSRX(RX,"L",IR,"FDA")=$PIECE($$MGONFILE^PSOFDAUT(RX),"^",2)
- End DoDot:1
- +15 ;
- +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 IF $GET(SIDE)
- GOTO END
- +1 DO ^PSOLLL5
- +2 DO ^PSOLLLH
- +3 DO ^PSOLLL6
- +4 IF '$PIECE($GET(^PS(59,PSOSITE,1)),"^",18)
- QUIT
- +5 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 ;