PSOLLLW ;BIR/EJW - LASER LABELS NEW WARNING LABEL SOURCE ;05/04/2004
;;7.0;OUTPATIENT PHARMACY;**161,338**;DEC 1997;Build 3
;
;External reference to WTEXT^PSSWRNA supported by DBIA 4444
;
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
;
WARN54 ; WARNING LABELS FROM RX CONSULT FILE
I PSOWARN=" " S PSOY=WWW*115+29+(WWW-1*2) Q ; PRINT BLANK LABEL(S) TO BOTTOM-JUSTIFY IF LESS THAN 5 WARNING LABELS
S (LENGTH,OUT)=0,LINE=1,LCNT=3
S TEXT=$$WTEXT^PSSWRNA(PSOWARN,PSOLAN)
I TEXT'="" D FORMAT
Q
;
NEWWARN ; NEW WARNING LABEL SOURCE
S (LENGTH,OUT)=0,LINE=1,LCNT=3
S TEXT=$$WTEXT^PSSWRNA(PSOWARN,PSOLAN)
I TEXT'="" D FORMAT
Q
;
FORMAT ;
D STRT^PSOLLU1("WRN",TEXT,.L,.XFONT)
D INCREM
S PTEXT=""
F I=1:1 Q:$E(TEXT)'=" " S TEXT=$E(TEXT,2,255)
F I=1:1:$L(TEXT," ") D STRT^PSOLLU1("WRN",$P(TEXT," ",I)_" ",.L) D Q:OUT
. I LENGTH+L($E(XFONT,2,99))<1.99 S PTEXT=PTEXT_$P(TEXT," ",I)_" ",LENGTH=LENGTH+L($E(XFONT,2,99)) Q
. S LENGTH=0,I=I-1,PSOFONT=XFONT
. I LINE=4,$P(TEXT," ",I+1)'="" D
. . S PTEXT="... See printed Additional Warnings."
. . S PSOWLBL=$G(PSOWLBL)_$G(PSOWARN)_","
. D PRINT(PTEXT) S PTEXT="",LINE=LINE+1 I LINE>LCNT S OUT=1 Q
I 'OUT S PSOFONT=XFONT D PRINT(PTEXT)
S PSOY=WWW*115+29+(WWW-1*2)
Q
;
INCREM ;
I XFONT="F6" S LCNT=4
S PSOY=PSOY+$S(XFONT="F12":10,XFONT="F10":8,XFONT="F9":8,1:5),PSOYI=$S(XFONT="F12":40,XFONT="F10":35,XFONT="F9":29,1:29)
I WWW=1 S PSOY=$S(PSOY>103:PSOY-20,1:PSOY),PSOYI=$S(XFONT="F10":30,XFONT="F6":20,1:PSOYI)
Q
;
COUNTSG ; COUNT LINES NEEDED FOR BOTTLE LABEL SIG FOR CALCULATED FONT
N CNT,SUBS
S CNT=0
K ^TMP($J,"PSOSIG",RX)
S PSOX=OPSOX,LENGTH=0,PTEXT="",SIGF=0,XFONT=$E(PSOFONT,2,99)
N DP,TEXTP,TEXTL,MORE
F DR=SIGF("DR"):1 Q:$G(SGY(DR))="" S TEXT=SGY(DR) D Q:SIGF
. F I=1:1 Q:$E(TEXT,I)'=" " S TEXT=$E(TEXT,2,255)
. S DP=$S(TEXT[" ":" ",TEXT[",":",",1:" ")
. F I=SIGF("T"):1:$L(TEXT,DP) D Q:SIGF
.. S TEXTP=$P(TEXT,DP,I) Q:TEXTP="" I $D(SIGF("J")) S TEXTP=$E(TEXTP,SIGF("J"),255) K SIGF("J")
.. D STRT^PSOLLU1("SIG",TEXTP_" ",.L) I L(XFONT)>3.3 D
... S MORE=0
... F J=$L(TEXTP):-1:1 S TEXTL=PTEXT_$E(TEXTP,1,J) D STRT^PSOLLU1("SIG",TEXTL_" ",.L) D Q:SIGF!MORE
.... Q:L(XFONT)>3.3
.... S CNT=CNT+1,^TMP($J,"PSOSIG",RX,CNT)=TEXTL,TEXT=$E(TEXT,J+1,999),PTEXT=""
.... D STRT^PSOLLU1("SIG",TEXT_DP,.L) S TEXTP=TEXT,J=$L(TEXTP) I L(XFONT)<3.3 S MORE=1,LENGTH=0
.. I LENGTH+L(XFONT)<3.3 S PTEXT=PTEXT_TEXTP_" ",LENGTH=LENGTH+L(XFONT) Q
.. S LENGTH=0,I=I-1
.. S CNT=CNT+1,^TMP($J,"PSOSIG",RX,CNT)=PTEXT S PTEXT=""
. I 'SIGF S SIGF("T")=1
I PTEXT]"" S CNT=CNT+1,^TMP($J,"PSOSIG",RX,CNT)=PTEXT
K NSGY
; FOR LONG SIGS THE SMALLEST FONT WILL BE USED. USING THAT FONT, 9 LINES OF THE SIG WILL FIT ON EACH BOTTLE LABEL. ON THE LAST 'CONTINUED' LABEL A MAXIMUM OF 4 LINES OF THE SIG CAN PRINT (WITHIN LINES 5-8 OF THE LABEL).
; IF THERE ARE LESS THAN 4 LINES ON THE LAST 'CONTINUED' LABEL, THE REMAINDER OF THE SIG WILL PRINT BOTTOM-JUSTIFIED WITHIN LINES 5-8 OF THE CONTINUATION LABEL.
N I,J,MODCNT
F I=1:1:CNT S J=$S(I#9:(I\9)+1,1:I\9) D
.S SUBS=$S(J=1:I,1:I-((J-1)*9))
.S NSGY(J,SUBS)=^TMP($J,"PSOSIG",RX,I)
S MODCNT=CNT#9 I MODCNT=0!(MODCNT>4) S NSGY($G(J)+1,0)=" " ; FORCE LAST CONTINUED LABEL
Q
;
COUNTSGF ; COUNT LINES NEEDED FOR PHARMACY FILL CARD SIG FOR CALCULATED FONT
N CNT
S CNT=0
K ^TMP($J,"PSOSIGF",RX)
S LENGTH=0,PTEXT="",PFF=0,XFONT=$E(PSOFONT,2,99)
N DP,TEXTP,TEXTL,MORE
F DR=PFF("DR"):1 Q:$G(PGY(DR))="" S TEXT=PGY(DR) D Q:PFF
. F I=1:1 Q:$E(TEXT,I)'=" " S TEXT=$E(TEXT,2,255)
. S DP=$S(TEXT[" ":" ",TEXT[",":",",1:" ")
. F I=PFF("T"):1:$L(TEXT,DP) D Q:PFF
.. S TEXTP=$P(TEXT,DP,I) Q:TEXTP="" I $D(PFF("J")) S TEXTP=$E(TEXTP,PFF("J"),255) K PFF("J")
.. D STRT^PSOLLU1("SIG",TEXTP_" ",.L) I L(XFONT)>3.3 D
... S MORE=0
... F J=$L(TEXTP):-1:1 S TEXTL=PTEXT_$E(TEXTP,1,J) D STRT^PSOLLU1("SIG",TEXTL_" ",.L) D Q:PFF!MORE
.... Q:L(XFONT)>3.3
.... S CNT=CNT+1,^TMP($J,"PSOSIGF",RX,CNT)=TEXTL,TEXT=$E(TEXT,J+1,999),PTEXT=""
.... D STRT^PSOLLU1("SIG",TEXT_DP,.L) S TEXTP=TEXT,J=$L(TEXTP) I L(XFONT)<3.3 S MORE=1,LENGTH=0
.. I LENGTH+L(XFONT)<3.3 S PTEXT=PTEXT_TEXTP_" ",LENGTH=LENGTH+L(XFONT) Q
.. S LENGTH=0,I=I-1
.. S CNT=CNT+1,^TMP($J,"PSOSIGF",RX,CNT)=PTEXT S PTEXT=""
. I 'PFF S PFF("T")=1
I PTEXT]"" S CNT=CNT+1,^TMP($J,"PSOSIGF",RX,CNT)=PTEXT
K NPGY
; 11 LINES OF THE SIG WILL FIT ON EACH PHARMACY FILL CARD LABEL. ON THE LAST 'CONTINUED' LABEL A MAXIMUM OF 4 LINES OF THE SIG CAN PRINT
N I,J,MODCNT
F I=1:1:CNT S J=$S(I#11:(I\11)+1,1:I\11) D
.S SUBS=$S(J=1:I,1:I-((J-1)*11))
.S NPGY(J,SUBS)=^TMP($J,"PSOSIGF",RX,I)
S MODCNT=CNT#11 I MODCNT=0!(MODCNT>4) S NPGY($G(J)+1,0)=" " ; FORCE LAST CONTINUED LABEL
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLLLW 5001 printed Sep 23, 2025@20:07:07 Page 2
PSOLLLW ;BIR/EJW - LASER LABELS NEW WARNING LABEL SOURCE ;05/04/2004
+1 ;;7.0;OUTPATIENT PHARMACY;**161,338**;DEC 1997;Build 3
+2 ;
+3 ;External reference to WTEXT^PSSWRNA supported by DBIA 4444
+4 ;
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
+9 ;
WARN54 ; WARNING LABELS FROM RX CONSULT FILE
+1 ; PRINT BLANK LABEL(S) TO BOTTOM-JUSTIFY IF LESS THAN 5 WARNING LABELS
IF PSOWARN=" "
SET PSOY=WWW*115+29+(WWW-1*2)
QUIT
+2 SET (LENGTH,OUT)=0
SET LINE=1
SET LCNT=3
+3 SET TEXT=$$WTEXT^PSSWRNA(PSOWARN,PSOLAN)
+4 IF TEXT'=""
DO FORMAT
+5 QUIT
+6 ;
NEWWARN ; NEW WARNING LABEL SOURCE
+1 SET (LENGTH,OUT)=0
SET LINE=1
SET LCNT=3
+2 SET TEXT=$$WTEXT^PSSWRNA(PSOWARN,PSOLAN)
+3 IF TEXT'=""
DO FORMAT
+4 QUIT
+5 ;
FORMAT ;
+1 DO STRT^PSOLLU1("WRN",TEXT,.L,.XFONT)
+2 DO INCREM
+3 SET PTEXT=""
+4 FOR I=1:1
if $EXTRACT(TEXT)'=" "
QUIT
SET TEXT=$EXTRACT(TEXT,2,255)
+5 FOR I=1:1:$LENGTH(TEXT," ")
DO STRT^PSOLLU1("WRN",$PIECE(TEXT," ",I)_" ",.L)
Begin DoDot:1
+6 IF LENGTH+L($EXTRACT(XFONT,2,99))<1.99
SET PTEXT=PTEXT_$PIECE(TEXT," ",I)_" "
SET LENGTH=LENGTH+L($EXTRACT(XFONT,2,99))
QUIT
+7 SET LENGTH=0
SET I=I-1
SET PSOFONT=XFONT
+8 IF LINE=4
IF $PIECE(TEXT," ",I+1)'=""
Begin DoDot:2
+9 SET PTEXT="... See printed Additional Warnings."
+10 SET PSOWLBL=$GET(PSOWLBL)_$GET(PSOWARN)_","
End DoDot:2
+11 DO PRINT(PTEXT)
SET PTEXT=""
SET LINE=LINE+1
IF LINE>LCNT
SET OUT=1
QUIT
End DoDot:1
if OUT
QUIT
+12 IF 'OUT
SET PSOFONT=XFONT
DO PRINT(PTEXT)
+13 SET PSOY=WWW*115+29+(WWW-1*2)
+14 QUIT
+15 ;
INCREM ;
+1 IF XFONT="F6"
SET LCNT=4
+2 SET PSOY=PSOY+$SELECT(XFONT="F12":10,XFONT="F10":8,XFONT="F9":8,1:5)
SET PSOYI=$SELECT(XFONT="F12":40,XFONT="F10":35,XFONT="F9":29,1:29)
+3 IF WWW=1
SET PSOY=$SELECT(PSOY>103:PSOY-20,1:PSOY)
SET PSOYI=$SELECT(XFONT="F10":30,XFONT="F6":20,1:PSOYI)
+4 QUIT
+5 ;
COUNTSG ; COUNT LINES NEEDED FOR BOTTLE LABEL SIG FOR CALCULATED FONT
+1 NEW CNT,SUBS
+2 SET CNT=0
+3 KILL ^TMP($JOB,"PSOSIG",RX)
+4 SET PSOX=OPSOX
SET LENGTH=0
SET PTEXT=""
SET SIGF=0
SET XFONT=$EXTRACT(PSOFONT,2,99)
+5 NEW DP,TEXTP,TEXTL,MORE
+6 FOR DR=SIGF("DR"):1
if $GET(SGY(DR))=""
QUIT
SET TEXT=SGY(DR)
Begin DoDot:1
+7 FOR I=1:1
if $EXTRACT(TEXT,I)'=" "
QUIT
SET TEXT=$EXTRACT(TEXT,2,255)
+8 SET DP=$SELECT(TEXT[" ":" ",TEXT[",":",",1:" ")
+9 FOR I=SIGF("T"):1:$LENGTH(TEXT,DP)
Begin DoDot:2
+10 SET TEXTP=$PIECE(TEXT,DP,I)
if TEXTP=""
QUIT
IF $DATA(SIGF("J"))
SET TEXTP=$EXTRACT(TEXTP,SIGF("J"),255)
KILL SIGF("J")
+11 DO STRT^PSOLLU1("SIG",TEXTP_" ",.L)
IF L(XFONT)>3.3
Begin DoDot:3
+12 SET MORE=0
+13 FOR J=$LENGTH(TEXTP):-1:1
SET TEXTL=PTEXT_$EXTRACT(TEXTP,1,J)
DO STRT^PSOLLU1("SIG",TEXTL_" ",.L)
Begin DoDot:4
+14 if L(XFONT)>3.3
QUIT
+15 SET CNT=CNT+1
SET ^TMP($JOB,"PSOSIG",RX,CNT)=TEXTL
SET TEXT=$EXTRACT(TEXT,J+1,999)
SET PTEXT=""
+16 DO STRT^PSOLLU1("SIG",TEXT_DP,.L)
SET TEXTP=TEXT
SET J=$LENGTH(TEXTP)
IF L(XFONT)<3.3
SET MORE=1
SET LENGTH=0
End DoDot:4
if SIGF!MORE
QUIT
End DoDot:3
+17 IF LENGTH+L(XFONT)<3.3
SET PTEXT=PTEXT_TEXTP_" "
SET LENGTH=LENGTH+L(XFONT)
QUIT
+18 SET LENGTH=0
SET I=I-1
+19 SET CNT=CNT+1
SET ^TMP($JOB,"PSOSIG",RX,CNT)=PTEXT
SET PTEXT=""
End DoDot:2
if SIGF
QUIT
+20 IF 'SIGF
SET SIGF("T")=1
End DoDot:1
if SIGF
QUIT
+21 IF PTEXT]""
SET CNT=CNT+1
SET ^TMP($JOB,"PSOSIG",RX,CNT)=PTEXT
+22 KILL NSGY
+23 ; FOR LONG SIGS THE SMALLEST FONT WILL BE USED. USING THAT FONT, 9 LINES OF THE SIG WILL FIT ON EACH BOTTLE LABEL. ON THE LAST 'CONTINUED' LABEL A MAXIMUM OF 4 LINES OF THE SIG CAN PRINT (WITHIN LINES 5-8 OF THE LABEL).
+24 ; IF THERE ARE LESS THAN 4 LINES ON THE LAST 'CONTINUED' LABEL, THE REMAINDER OF THE SIG WILL PRINT BOTTOM-JUSTIFIED WITHIN LINES 5-8 OF THE CONTINUATION LABEL.
+25 NEW I,J,MODCNT
+26 FOR I=1:1:CNT
SET J=$SELECT(I#9:(I\9)+1,1:I\9)
Begin DoDot:1
+27 SET SUBS=$SELECT(J=1:I,1:I-((J-1)*9))
+28 SET NSGY(J,SUBS)=^TMP($JOB,"PSOSIG",RX,I)
End DoDot:1
+29 ; FORCE LAST CONTINUED LABEL
SET MODCNT=CNT#9
IF MODCNT=0!(MODCNT>4)
SET NSGY($GET(J)+1,0)=" "
+30 QUIT
+31 ;
COUNTSGF ; COUNT LINES NEEDED FOR PHARMACY FILL CARD SIG FOR CALCULATED FONT
+1 NEW CNT
+2 SET CNT=0
+3 KILL ^TMP($JOB,"PSOSIGF",RX)
+4 SET LENGTH=0
SET PTEXT=""
SET PFF=0
SET XFONT=$EXTRACT(PSOFONT,2,99)
+5 NEW DP,TEXTP,TEXTL,MORE
+6 FOR DR=PFF("DR"):1
if $GET(PGY(DR))=""
QUIT
SET TEXT=PGY(DR)
Begin DoDot:1
+7 FOR I=1:1
if $EXTRACT(TEXT,I)'=" "
QUIT
SET TEXT=$EXTRACT(TEXT,2,255)
+8 SET DP=$SELECT(TEXT[" ":" ",TEXT[",":",",1:" ")
+9 FOR I=PFF("T"):1:$LENGTH(TEXT,DP)
Begin DoDot:2
+10 SET TEXTP=$PIECE(TEXT,DP,I)
if TEXTP=""
QUIT
IF $DATA(PFF("J"))
SET TEXTP=$EXTRACT(TEXTP,PFF("J"),255)
KILL PFF("J")
+11 DO STRT^PSOLLU1("SIG",TEXTP_" ",.L)
IF L(XFONT)>3.3
Begin DoDot:3
+12 SET MORE=0
+13 FOR J=$LENGTH(TEXTP):-1:1
SET TEXTL=PTEXT_$EXTRACT(TEXTP,1,J)
DO STRT^PSOLLU1("SIG",TEXTL_" ",.L)
Begin DoDot:4
+14 if L(XFONT)>3.3
QUIT
+15 SET CNT=CNT+1
SET ^TMP($JOB,"PSOSIGF",RX,CNT)=TEXTL
SET TEXT=$EXTRACT(TEXT,J+1,999)
SET PTEXT=""
+16 DO STRT^PSOLLU1("SIG",TEXT_DP,.L)
SET TEXTP=TEXT
SET J=$LENGTH(TEXTP)
IF L(XFONT)<3.3
SET MORE=1
SET LENGTH=0
End DoDot:4
if PFF!MORE
QUIT
End DoDot:3
+17 IF LENGTH+L(XFONT)<3.3
SET PTEXT=PTEXT_TEXTP_" "
SET LENGTH=LENGTH+L(XFONT)
QUIT
+18 SET LENGTH=0
SET I=I-1
+19 SET CNT=CNT+1
SET ^TMP($JOB,"PSOSIGF",RX,CNT)=PTEXT
SET PTEXT=""
End DoDot:2
if PFF
QUIT
+20 IF 'PFF
SET PFF("T")=1
End DoDot:1
if PFF
QUIT
+21 IF PTEXT]""
SET CNT=CNT+1
SET ^TMP($JOB,"PSOSIGF",RX,CNT)=PTEXT
+22 KILL NPGY
+23 ; 11 LINES OF THE SIG WILL FIT ON EACH PHARMACY FILL CARD LABEL. ON THE LAST 'CONTINUED' LABEL A MAXIMUM OF 4 LINES OF THE SIG CAN PRINT
+24 NEW I,J,MODCNT
+25 FOR I=1:1:CNT
SET J=$SELECT(I#11:(I\11)+1,1:I\11)
Begin DoDot:1
+26 SET SUBS=$SELECT(J=1:I,1:I-((J-1)*11))
+27 SET NPGY(J,SUBS)=^TMP($JOB,"PSOSIGF",RX,I)
End DoDot:1
+28 ; FORCE LAST CONTINUED LABEL
SET MODCNT=CNT#11
IF MODCNT=0!(MODCNT>4)
SET NPGY($GET(J)+1,0)=" "
+29 QUIT
+30 ;
