PSOLLL2 ;BIR/JLC-LASER LABEL ;11/19/02
;;7.0;OUTPATIENT PHARMACY;**120,138,141,161,200,391,617**;DEC 1997;Build 110
;
;Reference to $$ECMEON^BPSUTIL supported by DBIA 4410
L1 I $G(PSOIO("PFDI"))]"" X PSOIO("PFDI")
I '$G(PFF) D
.N PGY
.M PGY=SGY I $D(OSGY) K PGY M PGY=OSGY
.D COUNTSGF^PSOLLLW
S PFM=0,T=$S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"")
S T=T_$S($G(RXP):"(PARTIAL)",1:"")_$S($D(REPRINT):" ",$G(RXP):" ",1:"")_$P(PS2,"^",2)_" "_TECH_" "_$P(PSONOWT,":",1,2) D PRINT(T)
S T="Rx# "_RXN_" "_DATE_" "_$S('PFF:"Fill "_(RXF+1)_" of "_(1+$P(RXY,"^",9)),1:"(fill document continued)") D PRINT(T)
I $G(^PSRX(RX,"PKI"))'="" D
. S SSNPN=^PSRX(RX,"PKI"),SSNPN=$S($P(SSNPN,"^",1)!$P(SSNPN,"^",3):"(DSIG)",$P(SSNPN,"^",2):"(NOT DSIG)",1:"")
S T=PNM_" "_$G(SSNPN) D PRINT(T,1) S SSNPN=""
S LENGTH=0,PTEXT="",PFF=0,XFONT=$E(PSOFONT,2,99)
N DP,TEXTP,TEXTL,MORE
S DR=PFF("DR")
F I=1:1 Q:'$D(NPGY(DR,I)) S TEXT=NPGY(DR,I) D PRINT(TEXT)
I I>4,$D(NPGY(DR,5)) S PFF=1,PFF("DR")=DR+1
S OPSOY=PSOY
I $G(PSOIO("PFDQ"))]"" X PSOIO("PFDQ")
I PFF S PSOX=PSOCX,PSOY=OPSOY,T="(continued on next fill document)" S PFM=1 D PRINT(T) Q
K NPGY,^TMP($J,"PSOSIGF")
S XFONT=$E(PSOQFONT,2,99)
S TEXT="Qty: " D STRT^PSOLLU1("SIG2",TEXT,.L) S Q(1)=L(XFONT)
S TEXT=" "_PSDU D STRT^PSOLLU1("SIG2",TEXT,.L) S Q(2)=L(XFONT)
S TEXT=" "_$G(PHYS) D STRT^PSOLLU1("SIG2",TEXT,.L) S Q(3)=L(XFONT)
S PPHYS=$G(PHYS)
S TEXT=$G(QTY) D STRT^PSOLLU1("SIG2",TEXT,.L) S LENGTH=Q(1)+Q(2)+Q(3)+L(XFONT+2),Q(4)=L(XFONT+2)
I LENGTH>3.7 F I=$L(PHYS)-1:-1:1 S PPHYS=$E(PHYS,1,I),TEXT=" "_PPHYS D STRT^PSOLLU1("SIG2",TEXT,.L) I Q(1)+Q(2)+Q(4)+L(XFONT)<3.7 Q
S OPSOX=PSOX,PSOX=Q(1)*300+OPSOX,T=$G(QTY) D PRINT(T) S PSOX=OPSOX
S PSOFONT=PSOQFONT,PSOY=PSOY-PSOYI,T="Qty: " D PRINT(T)
S PSOY=PSOY-PSOYI,PSOX=Q(1)+Q(4)*300+OPSOX,T=" "_$G(PSDU)_" "_$G(PPHYS) D PRINT(T)
I $G(PSOIO("PFDT"))]"" X PSOIO("PFDT")
S T=DRUG D PRINT(T)
L11 ;
N NDCTEXT
S NDCTEXT="NDC/MFR_______________"
I $$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RXF)) S NDCTEXT="NDC "_$$GETNDC^PSONDCUT(RX,RXF)
S OPSOX=PSOX,T=NDCTEXT D PRINT(T)
S T="Lot# ___________________" D STRT^PSOLLU1("SIG2",T,.L)
S PSOY=PSOY-PSOYI,PSOX=L(XFONT+2)*300+OPSOX,T="Lot# _____________________" D PRINT(T)
L12 S PSOX=OPSOX,T="Tech___________________ RPh _____________________" D PRINT(T)
S PSOFONT=PSOTFONT
S T="Routing: "_$S("W"[$E(MW):MW,PS55=2:"DO NOT MAIL",1:MW_" MAIL")_" Days supply: "_$G(DAYS)_" Cap: "_$S('PSCAP:"SAFETY",1:"") D PRINT(T)
I PSCAP D
.D STRT^PSOLLU1("SIG2",T,.L) S LENGTH=L(XFONT+1)
.S OPSOX=PSOX,T="NON-SAFETY",PSOX=LENGTH*300+OPSOX,PSOY=PSOY-PSOYI D PRINT(T,1) S PSOX=OPSOX
S T="Isd: "_ISD_" Exp: "_EXPDT_" Last Fill: "_$G(PSOFLAST) D PRINT(T)
S PSOYI=PSOBYI,PSOY=PSOBY
I $G(PSOIO("SBT"))]"" X PSOIO("SBT")
S X2=PSOINST_"-"_RX
W X2
I $G(PSOIO("EBT"))]"" X PSOIO("EBT")
I $G(PSOIO("PFDW"))]"" X PSOIO("PFDW")
S XFONT=$E(PSOFONT,2,99)
I $G(WARN)'="" S PTEXT="DRUG WARNING " D STRT^PSOLLU1("SIG2",PTEXT,.L) S LENGTH=L(XFONT) D
. F I=1:1:$L(WARN,",") S TEXT=$P(WARN,",",I)_"," D
.. D STRT^PSOLLU1("SIG2",TEXT,.L)
.. I LENGTH+L(XFONT)<1.8 S PTEXT=PTEXT_TEXT,LENGTH=LENGTH+L(XFONT) Q
.. S LENGTH=0,I=I-1
.. S T=$P(PTEXT,",",1,$L(PTEXT,",")-1) D PRINT(T) S PTEXT=""
.. I PSOY>PSOYM W "*"
. I PTEXT]"" S T=$P(PTEXT,",",1,$L(PTEXT,",")-1) D PRINT(T)
S PTEXT="Pat. Stat "_PATST_" Clinic: "_PSCLN D STRT^PSOLLU1("SIG2",PTEXT,.L) S T=PTEXT D PRINT(T)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLLL2 3836 printed Oct 16, 2024@18:31:11 Page 2
PSOLLL2 ;BIR/JLC-LASER LABEL ;11/19/02
+1 ;;7.0;OUTPATIENT PHARMACY;**120,138,141,161,200,391,617**;DEC 1997;Build 110
+2 ;
+3 ;Reference to $$ECMEON^BPSUTIL supported by DBIA 4410
L1 IF $GET(PSOIO("PFDI"))]""
XECUTE PSOIO("PFDI")
+1 IF '$GET(PFF)
Begin DoDot:1
+2 NEW PGY
+3 MERGE PGY=SGY
IF $DATA(OSGY)
KILL PGY
MERGE PGY=OSGY
+4 DO COUNTSGF^PSOLLLW
End DoDot:1
+5 SET PFM=0
SET T=$SELECT($DATA(REPRINT)&($GET(PSOBLALL)):"(GROUP REPRINT)",$DATA(REPRINT):"(REPRINT)",1:"")
+6 SET T=T_$SELECT($GET(RXP):"(PARTIAL)",1:"")_$SELECT($DATA(REPRINT):" ",$GET(RXP):" ",1:"")_$PIECE(PS2,"^",2)_" "_TECH_" "_$PIECE(PSONOWT,":",1,2)
DO PRINT(T)
+7 SET T="Rx# "_RXN_" "_DATE_" "_$SELECT('PFF:"Fill "_(RXF+1)_" of "_(1+$PIECE(RXY,"^",9)),1:"(fill document continued)")
DO PRINT(T)
+8 IF $GET(^PSRX(RX,"PKI"))'=""
Begin DoDot:1
+9 SET SSNPN=^PSRX(RX,"PKI")
SET SSNPN=$SELECT($PIECE(SSNPN,"^",1)!$PIECE(SSNPN,"^",3):"(DSIG)",$PIECE(SSNPN,"^",2):"(NOT DSIG)",1:"")
End DoDot:1
+10 SET T=PNM_" "_$GET(SSNPN)
DO PRINT(T,1)
SET SSNPN=""
+11 SET LENGTH=0
SET PTEXT=""
SET PFF=0
SET XFONT=$EXTRACT(PSOFONT,2,99)
+12 NEW DP,TEXTP,TEXTL,MORE
+13 SET DR=PFF("DR")
+14 FOR I=1:1
if '$DATA(NPGY(DR,I))
QUIT
SET TEXT=NPGY(DR,I)
DO PRINT(TEXT)
+15 IF I>4
IF $DATA(NPGY(DR,5))
SET PFF=1
SET PFF("DR")=DR+1
+16 SET OPSOY=PSOY
+17 IF $GET(PSOIO("PFDQ"))]""
XECUTE PSOIO("PFDQ")
+18 IF PFF
SET PSOX=PSOCX
SET PSOY=OPSOY
SET T="(continued on next fill document)"
SET PFM=1
DO PRINT(T)
QUIT
+19 KILL NPGY,^TMP($JOB,"PSOSIGF")
+20 SET XFONT=$EXTRACT(PSOQFONT,2,99)
+21 SET TEXT="Qty: "
DO STRT^PSOLLU1("SIG2",TEXT,.L)
SET Q(1)=L(XFONT)
+22 SET TEXT=" "_PSDU
DO STRT^PSOLLU1("SIG2",TEXT,.L)
SET Q(2)=L(XFONT)
+23 SET TEXT=" "_$GET(PHYS)
DO STRT^PSOLLU1("SIG2",TEXT,.L)
SET Q(3)=L(XFONT)
+24 SET PPHYS=$GET(PHYS)
+25 SET TEXT=$GET(QTY)
DO STRT^PSOLLU1("SIG2",TEXT,.L)
SET LENGTH=Q(1)+Q(2)+Q(3)+L(XFONT+2)
SET Q(4)=L(XFONT+2)
+26 IF LENGTH>3.7
FOR I=$LENGTH(PHYS)-1:-1:1
SET PPHYS=$EXTRACT(PHYS,1,I)
SET TEXT=" "_PPHYS
DO STRT^PSOLLU1("SIG2",TEXT,.L)
IF Q(1)+Q(2)+Q(4)+L(XFONT)<3.7
QUIT
+27 SET OPSOX=PSOX
SET PSOX=Q(1)*300+OPSOX
SET T=$GET(QTY)
DO PRINT(T)
SET PSOX=OPSOX
+28 SET PSOFONT=PSOQFONT
SET PSOY=PSOY-PSOYI
SET T="Qty: "
DO PRINT(T)
+29 SET PSOY=PSOY-PSOYI
SET PSOX=Q(1)+Q(4)*300+OPSOX
SET T=" "_$GET(PSDU)_" "_$GET(PPHYS)
DO PRINT(T)
+30 IF $GET(PSOIO("PFDT"))]""
XECUTE PSOIO("PFDT")
+31 SET T=DRUG
DO PRINT(T)
L11 ;
+1 NEW NDCTEXT
+2 SET NDCTEXT="NDC/MFR_______________"
+3 IF $$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RXF))
SET NDCTEXT="NDC "_$$GETNDC^PSONDCUT(RX,RXF)
+4 SET OPSOX=PSOX
SET T=NDCTEXT
DO PRINT(T)
+5 SET T="Lot# ___________________"
DO STRT^PSOLLU1("SIG2",T,.L)
+6 SET PSOY=PSOY-PSOYI
SET PSOX=L(XFONT+2)*300+OPSOX
SET T="Lot# _____________________"
DO PRINT(T)
L12 SET PSOX=OPSOX
SET T="Tech___________________ RPh _____________________"
DO PRINT(T)
+1 SET PSOFONT=PSOTFONT
+2 SET T="Routing: "_$SELECT("W"[$EXTRACT(MW):MW,PS55=2:"DO NOT MAIL",1:MW_" MAIL")_" Days supply: "_$GET(DAYS)_" Cap: "_$SELECT('PSCAP:"SAFETY",1:"")
DO PRINT(T)
+3 IF PSCAP
Begin DoDot:1
+4 DO STRT^PSOLLU1("SIG2",T,.L)
SET LENGTH=L(XFONT+1)
+5 SET OPSOX=PSOX
SET T="NON-SAFETY"
SET PSOX=LENGTH*300+OPSOX
SET PSOY=PSOY-PSOYI
DO PRINT(T,1)
SET PSOX=OPSOX
End DoDot:1
+6 SET T="Isd: "_ISD_" Exp: "_EXPDT_" Last Fill: "_$GET(PSOFLAST)
DO PRINT(T)
+7 SET PSOYI=PSOBYI
SET PSOY=PSOBY
+8 IF $GET(PSOIO("SBT"))]""
XECUTE PSOIO("SBT")
+9 SET X2=PSOINST_"-"_RX
+10 WRITE X2
+11 IF $GET(PSOIO("EBT"))]""
XECUTE PSOIO("EBT")
+12 IF $GET(PSOIO("PFDW"))]""
XECUTE PSOIO("PFDW")
+13 SET XFONT=$EXTRACT(PSOFONT,2,99)
+14 IF $GET(WARN)'=""
SET PTEXT="DRUG WARNING "
DO STRT^PSOLLU1("SIG2",PTEXT,.L)
SET LENGTH=L(XFONT)
Begin DoDot:1
+15 FOR I=1:1:$LENGTH(WARN,",")
SET TEXT=$PIECE(WARN,",",I)_","
Begin DoDot:2
+16 DO STRT^PSOLLU1("SIG2",TEXT,.L)
+17 IF LENGTH+L(XFONT)<1.8
SET PTEXT=PTEXT_TEXT
SET LENGTH=LENGTH+L(XFONT)
QUIT
+18 SET LENGTH=0
SET I=I-1
+19 SET T=$PIECE(PTEXT,",",1,$LENGTH(PTEXT,",")-1)
DO PRINT(T)
SET PTEXT=""
+20 IF PSOY>PSOYM
WRITE "*"
End DoDot:2
+21 IF PTEXT]""
SET T=$PIECE(PTEXT,",",1,$LENGTH(PTEXT,",")-1)
DO PRINT(T)
End DoDot:1
+22 SET PTEXT="Pat. Stat "_PATST_" Clinic: "_PSCLN
DO STRT^PSOLLU1("SIG2",PTEXT,.L)
SET T=PTEXT
DO PRINT(T)
+23 QUIT
+24 ;
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
