PSORLLL3 ;AITC/BWF - LASER LABELS ;11/20/02
;;7.0;OUTPATIENT PHARMACY;**454**;DEC 1997;Build 349
; BWF - modified copy of PSOLLL3
; - References to $$GETNDC^PSSNDCUT,$$NDCFMT^PSSNDCUT,SAVNDC^PSSNDCUT supported by IA 4707
;
S PRCOPAY=$S('$D(PSOCPN):0,1:1)
PF ;PATIENT FILL DOCUMENT
I $G(PSOIO("PFI"))]"" X PSOIO("PFI")
D S PSOFONT=OFONT
. S OFONT=PSOFONT,PSOFONT=PSOHFONT
. I $P(RXY,"^",9)=0 S T="NO REFILL for this prescription" D PRINT(T,1,1) S PSOY=PSOY+PSOYI Q
. I RXF+1=(1+$P(RXY,"^",9)) S T="NO REFILLS LEFT for this prescription" D PRINT(T,1,1) S PSOY=PSOY+PSOYI Q
. S T="PHONE IN OR MAIL THIS REFILL REQUEST" D PRINT(T,1,1)
. S PSOFONT=OFONT,T="Follow the refill instructions provided with your prescription." D PRINT(T,0,1)
. ;S PSOFONT=OFONT,OPSOX=PSOX,PSOX=PSOX+300,T="For Refill Call "_$P(PS,"^",3)_"-"_$P(PS,"^",4) D PRINT(T,0) S PSOX=OPSOX
. S PSOFONT=OFONT,OPSOX=PSOX,PSOX=PSOX+300,T="For Refill Call "_$P(HINFO,"^",3) D PRINT(T,0) S PSOX=OPSOX
S T=PNM_" "_$G(SSNPN) D PRINT(T,1)
S T="Rx# "_RXN_" " D PRINT(T,1)
D STRT^PSOLLU1("SEC2",T,.L) S OPSOX=PSOX,PSOX=L($E(PSOFONT,2,99))*300+PSOX
S T=DATE_" Fill "_(RXF+1)_" of "_(1+$P(RXY,"^",9)),PSOY=PSOY-PSOYI D PRINT(T) S PSOX=OPSOX
S T="" D PRINT(T,1)
S T="Qty: "_$G(QTY)_" "_$G(PSDU)_" Days supply: "_$G(DAYS) D PRINT(T,0)
S T=DRUG D PRINT(T,0)
S T=$$GET1^DIQ(50,LOCDRUG,31,"E"),T=$$NDCFMT^PSSNDCUT(T) D PRINT(T,1)
D D PRINT(T,1)
. S NOR=$P(RXY,"^",9)
. 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 PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
D PRINT($G(COPAYVAR))
;S T=$P(PS,"^")_"-"_$P(PS,"^",6) D STRT^PSOLLU1("SEC2",T,.L)
S T=$P($G(HINFO),"^")_"-"_$P($G(HINFO),"^",4) D STRT^PSOLLU1("SEC2",T,.L)
S OPSOX=PSOX,PSOX=2340-(L($E(PSOFONT,2,99))*300),PSOY=PSOY-PSOYI
D PRINT(T)
S PSOX=OPSOX,PSOYI=PSOBYI
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(PSOFONT))]"" X PSOIO(PSOFONT)
Q
PRINT(T,BOLD,HDR) ;
S BOLD=+$G(BOLD),HDR=+$G(HDR)
I 'BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
I BOLD,$G(PSOIO(PSOFONT_"B"))]"" X PSOIO(PSOFONT_"B")
I HDR D
. S OPSOX=PSOX D STRT^PSOLLU1("SEC2",T,.L)
. S PSOX=4.2-L($E(PSOFONT,2,99))*300/2+OPSOX
I $G(PSOIO("ST"))]"" X PSOIO("ST")
W T,!
I HDR S PSOX=OPSOX
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[HPSORLLL3 2503 printed Nov 22, 2024@17:43:54 Page 2
PSORLLL3 ;AITC/BWF - LASER LABELS ;11/20/02
+1 ;;7.0;OUTPATIENT PHARMACY;**454**;DEC 1997;Build 349
+2 ; BWF - modified copy of PSOLLL3
+3 ; - References to $$GETNDC^PSSNDCUT,$$NDCFMT^PSSNDCUT,SAVNDC^PSSNDCUT supported by IA 4707
+4 ;
+5 SET PRCOPAY=$SELECT('$DATA(PSOCPN):0,1:1)
PF ;PATIENT FILL DOCUMENT
+1 IF $GET(PSOIO("PFI"))]""
XECUTE PSOIO("PFI")
+2 Begin DoDot:1
+3 SET OFONT=PSOFONT
SET PSOFONT=PSOHFONT
+4 IF $PIECE(RXY,"^",9)=0
SET T="NO REFILL for this prescription"
DO PRINT(T,1,1)
SET PSOY=PSOY+PSOYI
QUIT
+5 IF RXF+1=(1+$PIECE(RXY,"^",9))
SET T="NO REFILLS LEFT for this prescription"
DO PRINT(T,1,1)
SET PSOY=PSOY+PSOYI
QUIT
+6 SET T="PHONE IN OR MAIL THIS REFILL REQUEST"
DO PRINT(T,1,1)
+7 SET PSOFONT=OFONT
SET T="Follow the refill instructions provided with your prescription."
DO PRINT(T,0,1)
+8 ;S PSOFONT=OFONT,OPSOX=PSOX,PSOX=PSOX+300,T="For Refill Call "_$P(PS,"^",3)_"-"_$P(PS,"^",4) D PRINT(T,0) S PSOX=OPSOX
+9 SET PSOFONT=OFONT
SET OPSOX=PSOX
SET PSOX=PSOX+300
SET T="For Refill Call "_$PIECE(HINFO,"^",3)
DO PRINT(T,0)
SET PSOX=OPSOX
End DoDot:1
SET PSOFONT=OFONT
+10 SET T=PNM_" "_$GET(SSNPN)
DO PRINT(T,1)
+11 SET T="Rx# "_RXN_" "
DO PRINT(T,1)
+12 DO STRT^PSOLLU1("SEC2",T,.L)
SET OPSOX=PSOX
SET PSOX=L($EXTRACT(PSOFONT,2,99))*300+PSOX
+13 SET T=DATE_" Fill "_(RXF+1)_" of "_(1+$PIECE(RXY,"^",9))
SET PSOY=PSOY-PSOYI
DO PRINT(T)
SET PSOX=OPSOX
+14 SET T=""
DO PRINT(T,1)
+15 SET T="Qty: "_$GET(QTY)_" "_$GET(PSDU)_" Days supply: "_$GET(DAYS)
DO PRINT(T,0)
+16 SET T=DRUG
DO PRINT(T,0)
+17 SET T=$$GET1^DIQ(50,LOCDRUG,31,"E")
SET T=$$NDCFMT^PSSNDCUT(T)
DO PRINT(T,1)
+18 Begin DoDot:1
+19 SET NOR=$PIECE(RXY,"^",9)
+20 IF $PIECE(RXY,"^",9)=0
SET T="NO REFILL"
QUIT
+21 IF NOR=0
SET T="NO REFILLS LEFT"
QUIT
+22 SET T="May refill "_NOR_"X by "_EXPDT
End DoDot:1
DO PRINT(T,1)
+23 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
+24 DO PRINT($GET(COPAYVAR))
+25 ;S T=$P(PS,"^")_"-"_$P(PS,"^",6) D STRT^PSOLLU1("SEC2",T,.L)
+26 SET T=$PIECE($GET(HINFO),"^")_"-"_$PIECE($GET(HINFO),"^",4)
DO STRT^PSOLLU1("SEC2",T,.L)
+27 SET OPSOX=PSOX
SET PSOX=2340-(L($EXTRACT(PSOFONT,2,99))*300)
SET PSOY=PSOY-PSOYI
+28 DO PRINT(T)
+29 SET PSOX=OPSOX
SET PSOYI=PSOBYI
+30 IF $GET(PSOIO("SBT"))]""
XECUTE PSOIO("SBT")
+31 SET X2=$PIECE($GET(HINFO),"^",4)_"-"_RX
+32 WRITE X2
+33 IF $GET(PSOIO("EBT"))]""
XECUTE PSOIO("EBT")
+34 IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+35 QUIT
PRINT(T,BOLD,HDR) ;
+1 SET BOLD=+$GET(BOLD)
SET HDR=+$GET(HDR)
+2 IF 'BOLD
IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+3 IF BOLD
IF $GET(PSOIO(PSOFONT_"B"))]""
XECUTE PSOIO(PSOFONT_"B")
+4 IF HDR
Begin DoDot:1
+5 SET OPSOX=PSOX
DO STRT^PSOLLU1("SEC2",T,.L)
+6 SET PSOX=4.2-L($EXTRACT(PSOFONT,2,99))*300/2+OPSOX
End DoDot:1
+7 IF $GET(PSOIO("ST"))]""
XECUTE PSOIO("ST")
+8 WRITE T,!
+9 IF HDR
SET PSOX=OPSOX
+10 IF $GET(PSOIO("ET"))]""
XECUTE PSOIO("ET")
+11 ;TURN OFF BOLDING
IF BOLD
IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+12 QUIT
