- PSORLLL2 ;AITC/BWF-LASER LABEL ;11/19/02
- ;;7.0;OUTPATIENT PHARMACY;**454**;DEC 1997;Build 349
- ;
- ; BWF - modified copy of PSOLLL2
- ;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)
- S SSNPN=""
- 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(PSOSITE) S NDCTEXT="NDC "_$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,LOCDRUG,31,"E"))
- 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=$P($G(HINFO),"^",4)_"-"_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[HPSORLLL2 3736 printed Feb 19, 2025@00:00:20 Page 2
- PSORLLL2 ;AITC/BWF-LASER LABEL ;11/19/02
- +1 ;;7.0;OUTPATIENT PHARMACY;**454**;DEC 1997;Build 349
- +2 ;
- +3 ; BWF - modified copy of PSOLLL2
- +4 ;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 SET SSNPN=""
- +9 SET T=PNM_" "_$GET(SSNPN)
- DO PRINT(T,1)
- SET SSNPN=""
- +10 SET LENGTH=0
- SET PTEXT=""
- SET PFF=0
- SET XFONT=$EXTRACT(PSOFONT,2,99)
- +11 NEW DP,TEXTP,TEXTL,MORE
- +12 SET DR=PFF("DR")
- +13 FOR I=1:1
- if '$DATA(NPGY(DR,I))
- QUIT
- SET TEXT=NPGY(DR,I)
- DO PRINT(TEXT)
- +14 IF I>4
- IF $DATA(NPGY(DR,5))
- SET PFF=1
- SET PFF("DR")=DR+1
- +15 SET OPSOY=PSOY
- +16 IF $GET(PSOIO("PFDQ"))]""
- XECUTE PSOIO("PFDQ")
- +17 IF PFF
- SET PSOX=PSOCX
- SET PSOY=OPSOY
- SET T="(continued on next fill document)"
- SET PFM=1
- DO PRINT(T)
- QUIT
- +18 KILL NPGY,^TMP($JOB,"PSOSIGF")
- +19 SET XFONT=$EXTRACT(PSOQFONT,2,99)
- +20 SET TEXT="Qty: "
- DO STRT^PSOLLU1("SIG2",TEXT,.L)
- SET Q(1)=L(XFONT)
- +21 SET TEXT=" "_PSDU
- DO STRT^PSOLLU1("SIG2",TEXT,.L)
- SET Q(2)=L(XFONT)
- +22 SET TEXT=" "_$GET(PHYS)
- DO STRT^PSOLLU1("SIG2",TEXT,.L)
- SET Q(3)=L(XFONT)
- +23 SET PPHYS=$GET(PHYS)
- +24 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)
- +25 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
- +26 SET OPSOX=PSOX
- SET PSOX=Q(1)*300+OPSOX
- SET T=$GET(QTY)
- DO PRINT(T)
- SET PSOX=OPSOX
- +27 SET PSOFONT=PSOQFONT
- SET PSOY=PSOY-PSOYI
- SET T="Qty: "
- DO PRINT(T)
- +28 SET PSOY=PSOY-PSOYI
- SET PSOX=Q(1)+Q(4)*300+OPSOX
- SET T=" "_$GET(PSDU)_" "_$GET(PPHYS)
- DO PRINT(T)
- +29 IF $GET(PSOIO("PFDT"))]""
- XECUTE PSOIO("PFDT")
- +30 SET T=DRUG
- DO PRINT(T)
- L11 ;
- +1 NEW NDCTEXT
- +2 SET NDCTEXT="NDC/MFR_______________"
- +3 IF $$ECMEON^BPSUTIL(PSOSITE)
- SET NDCTEXT="NDC "_$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,LOCDRUG,31,"E"))
- +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=$PIECE($GET(HINFO),"^",4)_"-"_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