PSOLBL1 ;BHAM ISC/SAB - PRINTS LABEL ; 6/21/13 2:55pm
;;7.0;OUTPATIENT PHARMACY;**107,110,225,326,367,318**;DEC 1997;Build 13
START S COPIES=COPIES-1
W $C(13) S $X=0 W "VA (119)",?10,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3) W:('SIDE)&(PRTFL) ?40,"PLEASE REFER ONLY TO '",$S(REF:"1. REFILL REQUEST",1:"2. RENEWAL ORDER"),"'" W:+$G(RXP) ?100,"(PARTIAL)" W:$G(REPRINT) ?110,"(REPRINT)"
W !,$P(PS,"^",2) W:('SIDE)&(PRTFL) ?40,"INSTRUCTION ON REVERSE SIDE OF THIS FORM" W:'SIDE ?102,"(Filled at ",$P(PS2,"^",2),")"
W !,$P(PS,"^",7),", ",STATE," ",$P(PS,"^",5) W:'SIDE ?83,"*** ",$P(PS2,"^")," ***"
W !,?22,$S(MW["C":"CERTIFIED MAIL",1:"") W:'SIDE ?38,SSNP,?69,"RX: ",RXN
W !,?2,PNM W:'SIDE ?38,PNM,?64,"EXPIRES: ",EXDT W:('SIDE)&(PRTFL) ?83,"INDICATE ANY ADDRESS CHANGES"
W !,?2,$S($D(PSMP(1)):PSMP(1),1:VAPA(1)) W:'SIDE ?38,$E(VAPA(1),1,25),?64,"REFILLS: ",REF ;W:('SIDE)&(PRTFL) ?83,LINE
W:('SIDE)&(PRTFL) ?83,"_____PERM. _____TEMP." W:'PRTFL ?83,"* A 'NEW' RX IS REQUIRED. *"
S ADDR(3)=VAPA(4)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6),ADDR(2)="" S:VAPA(2)]"" ADDR(2)=VAPA(2)_" "_VAPA(3)
I ADDR(2)="" S ADDR(2)=ADDR(3),ADDR(3)=""
S ADDR(5)=$E(VAPA(4),1,13)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6)
W !,?2,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$E(ADDR(2),1,35)) W:'SIDE ?38,$S($G(ADDR(3))="":ADDR(5),1:$E(ADDR(2),1,24)),?62,$S(RFLMSG]"":"*",1:" "),"LST FILL: "
W:'SIDE $G(PSOLASTF)
I 'SIDE W:PRTFL ?83,"ADDRESS: ",$E(LINE,1,23) W:'PRTFL ?83,"********** PLEASE NOTE ***********"
W !,?2,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:ADDR(3)) I 'SIDE W ?38,$S(ADDR(3)'="":ADDR(5),1:""),?64,"ROUTING: ",$S(MW="REGULAR":"MAIL",1:MW) W:PRTFL ?83,"CITY/STATE/ZIP: ",$E(LINE,1,16) W:'PRTFL ?83,"* THIS RX CAN NOT BE 'RENEWED'. *"
;NEW LABEL WHITE SPACE
I +$G(PSOBARS),'SIDE,$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX W !,?40 S X1=$X W @PSOBAR1,X2,@PSOBAR0,$C(13),!,$S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**")
E F NLWS=1:1:5 W ! W:NLWS=5 $S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**")
; Printing FDA Medication Guide (if there's one)
I $$MGONFILE^PSOFDAUT(RX) D
. W ?83,"Read FDA Med Guide"
. I $G(REPRINT),'$D(RXRP(RX,"MG")) Q
. N FDAMG S FDAMG=$$PRINTMG^PSOFDAMG(RX,$P($G(PSOFDAPT),"^",2))
W !
;
W !,?8,"VA Medical Center" I 'SIDE W ?38,INT(1)
W !,$P(PS,"^")," ",$P(PS,"^",3),"-",$P(PS,"^",4) W:'SIDE ?38,INT(2) I 'SIDE W:PRTFL ?83 W:'PRTFL ?83,"* PLEASE CONTACT YOUR PHYSICIAN. *"
W !,?4,RXN,?15,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," (",RXF+1," OF ",1+$P(RXY,"^",9),")" I 'SIDE W ?38,INT(3) W:(PRTFL)&('REF) ?83,"***** FOR PHYSICIAN USE ONLY *****" W:'PRTFL ?83,"**********************************"
W !,PNM,?29,"#",$P(RXY,"^",7)
W:'SIDE ?38,"CAP: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")," WARN:",WARN,?68,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," " S I1=$P($H,",",2)\60 W:'SIDE I1\60,":",(I1#60\10)_(I1#10) W:('SIDE)&(PRTFL) ?83,"SIGNATURE : ",$E(LINE,1,20)
SIG F DR=1:1:$S(SGC<5:4,1:6) D SIG1
I SGC>4 F I=1:1:22 W ! I I>22-SGC S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X
;I SGC>4 F I=1:1:$S($P($G(PSOPAR),"^",10):22,1:16) W ! I I>($S($P($G(PSOPAR),"^",10):28,1:22)-SGC) S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X
W !?3,$E(PHYS,1,14),?25,"(",$P(RXY,"^",16),"/",$S($D(VRPH):VRPH,1:" "),")" W:'SIDE ?38,DRUG,?38+$L(DRUG)," (QTY:",$P(RXY,"^",7)," DAYS:",$P(RXY,"^",8)," FILL: ",RXF+1," OF ",1+$P(RXY,"^",9)," ISD:",ISD,")"
W !,DRUG W:'SIDE ?38,PHYS,?62,RFLMSG,?100,PATST," ",PSCLN
I $D(PSOBARS),PSOBARS W $C(13),# S $X=0
E W !
I COPIES>0 S SIDE=1 G START
;STORE LABEL PRINT NODE
D NOW^%DTC S NOW=% K %,%H,%I S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I
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)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($G(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)
S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I
I '$D(PSSPND),$P(PSOPAR,"^",18) D CHCK2^PSOTRLBL
END K PSCLN,%DT,ADDR,DATE,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,%H,COPIES,DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,INT,ISD,I1,MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL,SGC,PSMP,PSI,PSJ,VRPH,REPRINT,PS55,PS55X Q
Q
;
SIG1 S X=$S($D(SGY(DR)):SGY(DR),1:"") W !,X
I 'SIDE W ?38,X I PRTFL W ?83 W:DR=1 ?83,$S('REF:"PRINT NAME: "_$E(LINE,1,25),1:"") W:DR=2 "DATE: ",$E(LINE,1,10) W:(DR=2)&('REF) " DEA# ",$E(LINE,1,6) W:(DR=3)&('REF) "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"
Q
;
OSET I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D Q
.S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=""
.S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________"
I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
S TECH=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
S QTY=$P(^PSRX(RX,1,RXFL(RX),0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=""
S DAYS=$P(^PSRX(RX,1,RXFL(RX),0),"^",10),LOT="________",MFG="________"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLBL1 5595 printed Oct 16, 2024@18:30:59 Page 2
PSOLBL1 ;BHAM ISC/SAB - PRINTS LABEL ; 6/21/13 2:55pm
+1 ;;7.0;OUTPATIENT PHARMACY;**107,110,225,326,367,318**;DEC 1997;Build 13
START SET COPIES=COPIES-1
+1 WRITE $CHAR(13)
SET $X=0
WRITE "VA (119)",?10,$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3)
if ('SIDE)&(PRTFL)
WRITE ?40,"PLEASE REFER ONLY TO '",$SELECT(REF:"1. REFILL REQUEST",1:"2. RENEWAL ORDER"),"'"
if +$GET(RXP)
WRITE ?100,"(PARTIAL)"
if $GET(REPRINT)
WRITE ?110,"(REPRINT)"
+2 WRITE !,$PIECE(PS,"^",2)
if ('SIDE)&(PRTFL)
WRITE ?40,"INSTRUCTION ON REVERSE SIDE OF THIS FORM"
if 'SIDE
WRITE ?102,"(Filled at ",$PIECE(PS2,"^",2),")"
+3 WRITE !,$PIECE(PS,"^",7),", ",STATE," ",$PIECE(PS,"^",5)
if 'SIDE
WRITE ?83,"*** ",$PIECE(PS2,"^")," ***"
+4 WRITE !,?22,$SELECT(MW["C":"CERTIFIED MAIL",1:"")
if 'SIDE
WRITE ?38,SSNP,?69,"RX: ",RXN
+5 WRITE !,?2,PNM
if 'SIDE
WRITE ?38,PNM,?64,"EXPIRES: ",EXDT
if ('SIDE)&(PRTFL)
WRITE ?83,"INDICATE ANY ADDRESS CHANGES"
+6 ;W:('SIDE)&(PRTFL) ?83,LINE
WRITE !,?2,$SELECT($DATA(PSMP(1)):PSMP(1),1:VAPA(1))
if 'SIDE
WRITE ?38,$EXTRACT(VAPA(1),1,25),?64,"REFILLS: ",REF
+7 if ('SIDE)&(PRTFL)
WRITE ?83,"_____PERM. _____TEMP."
if 'PRTFL
WRITE ?83,"* A 'NEW' RX IS REQUIRED. *"
+8 SET ADDR(3)=VAPA(4)_", "_$PIECE($GET(^DIC(5,+$PIECE(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6)
SET ADDR(2)=""
if VAPA(2)]""
SET ADDR(2)=VAPA(2)_" "_VAPA(3)
+9 IF ADDR(2)=""
SET ADDR(2)=ADDR(3)
SET ADDR(3)=""
+10 SET ADDR(5)=$EXTRACT(VAPA(4),1,13)_", "_$PIECE($GET(^DIC(5,+$PIECE(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6)
+11 WRITE !,?2,$SELECT($DATA(PSMP(2)):PSMP(2),$DATA(PSMP(1)):"",1:$EXTRACT(ADDR(2),1,35))
if 'SIDE
WRITE ?38,$SELECT($GET(ADDR(3))="":ADDR(5),1:$EXTRACT(ADDR(2),1,24)),?62,$SELECT(RFLMSG]"":"*",1:" "),"LST FILL: "
+12 if 'SIDE
WRITE $GET(PSOLASTF)
+13 IF 'SIDE
if PRTFL
WRITE ?83,"ADDRESS: ",$EXTRACT(LINE,1,23)
if 'PRTFL
WRITE ?83,"********** PLEASE NOTE ***********"
+14 WRITE !,?2,$SELECT($DATA(PSMP(3)):PSMP(3),$DATA(PSMP(1)):"",1:ADDR(3))
IF 'SIDE
WRITE ?38,$SELECT(ADDR(3)'="":ADDR(5),1:""),?64,"ROUTING: ",$SELECT(MW="REGULAR":"MAIL",1:MW)
if PRTFL
WRITE ?83,"CITY/STATE/ZIP: ",$EXTRACT(LINE,1,16)
if 'PRTFL
WRITE ?83,"* THIS RX CAN NOT BE 'RENEWED'. *"
+15 ;NEW LABEL WHITE SPACE
+16 IF +$GET(PSOBARS)
IF 'SIDE
IF $PIECE(PSOPAR,"^",19)'=1
SET X="S"
SET X2=PSOINST_"-"_RX
WRITE !,?40
SET X1=$X
WRITE @PSOBAR1,X2,@PSOBAR0,$CHAR(13),!,$SELECT($GET(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**")
+17 IF '$TEST
FOR NLWS=1:1:5
WRITE !
if NLWS=5
WRITE $SELECT($GET(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**")
+18 ; Printing FDA Medication Guide (if there's one)
+19 IF $$MGONFILE^PSOFDAUT(RX)
Begin DoDot:1
+20 WRITE ?83,"Read FDA Med Guide"
+21 IF $GET(REPRINT)
IF '$DATA(RXRP(RX,"MG"))
QUIT
+22 NEW FDAMG
SET FDAMG=$$PRINTMG^PSOFDAMG(RX,$PIECE($GET(PSOFDAPT),"^",2))
End DoDot:1
+23 WRITE !
+24 ;
+25 WRITE !,?8,"VA Medical Center"
IF 'SIDE
WRITE ?38,INT(1)
+26 WRITE !,$PIECE(PS,"^")," ",$PIECE(PS,"^",3),"-",$PIECE(PS,"^",4)
if 'SIDE
WRITE ?38,INT(2)
IF 'SIDE
if PRTFL
WRITE ?83
if 'PRTFL
WRITE ?83,"* PLEASE CONTACT YOUR PHYSICIAN. *"
+27 WRITE !,?4,RXN,?15,$EXTRACT(DATE,4,5),"/",$EXTRACT(DATE,6,7),"/",$EXTRACT(DATE,2,3)," (",RXF+1," OF ",1+$PIECE(RXY,"^",9),")"
IF 'SIDE
WRITE ?38,INT(3)
if (PRTFL)&('REF)
WRITE ?83,"***** FOR PHYSICIAN USE ONLY *****"
if 'PRTFL
WRITE ?83,"**********************************"
+28 WRITE !,PNM,?29,"#",$PIECE(RXY,"^",7)
+29 if 'SIDE
WRITE ?38,"CAP: ",$SELECT(PSCAP:"**NON-SFTY**",1:"SAFETY")," WARN:",WARN,?68,$EXTRACT(DATE,4,5),"/",$EXTRACT(DATE,6,7),"/",$EXTRACT(DATE,2,3)," "
SET I1=$PIECE($HOROLOG,",",2)\60
if 'SIDE
WRITE I1\60,":",(I1#60\10)_(I1#10)
if ('SIDE)&(PRTFL)
WRITE ?83,"SIGNATURE : ",$EXTRACT(LINE,1,20)
SIG FOR DR=1:1:$SELECT(SGC<5:4,1:6)
DO SIG1
+1 IF SGC>4
FOR I=1:1:22
WRITE !
IF I>22-SGC
SET DR=DR+1
SET X=$SELECT($DATA(SGY(DR)):SGY(DR),1:"")
WRITE X
if 'SIDE
WRITE ?38,X
+2 ;I SGC>4 F I=1:1:$S($P($G(PSOPAR),"^",10):22,1:16) W ! I I>($S($P($G(PSOPAR),"^",10):28,1:22)-SGC) S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X
+3 WRITE !?3,$EXTRACT(PHYS,1,14),?25,"(",$PIECE(RXY,"^",16),"/",$SELECT($DATA(VRPH):VRPH,1:" "),")"
if 'SIDE
WRITE ?38,DRUG,?38+$LENGTH(DRUG)," (QTY:",$PIECE(RXY,"^",7)," DAYS:",$PIECE(RXY,"^",8)," FILL: ",RXF+1," OF ",1+$PIECE(RXY,"^",9)," ISD:",ISD,")"
+4 WRITE !,DRUG
if 'SIDE
WRITE ?38,PHYS,?62,RFLMSG,?100,PATST," ",PSCLN
+5 IF $DATA(PSOBARS)
IF PSOBARS
WRITE $CHAR(13),#
SET $X=0
+6 IF '$TEST
WRITE !
+7 IF COPIES>0
SET SIDE=1
GOTO START
+8 ;STORE LABEL PRINT NODE
+9 DO NOW^%DTC
SET NOW=%
KILL %,%H,%I
SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(RX,1,I))
if 'I
QUIT
SET RXF=I
+10 SET IR=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(RX,"L",FDA))
if 'FDA
QUIT
SET IR=FDA
+11 SET IR=IR+1
SET ^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
+12 SET ^PSRX(RX,"L",IR,0)=NOW_"^"_$SELECT($GET(RXP):99-RXPI,1:RXF)_"^"_$SELECT($GET(PCOMX)]"":$GET(PCOMX),1:"From RX number "_$PIECE(^PSRX(RX,0),"^"))_$SELECT($GET(RXP):" (Partial)",1:"")_$SELECT($GET(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
+13 ;Storing FDA Medication Guide filename in the Prescription file
+14 IF $$MGONFILE^PSOFDAUT(RX)
Begin DoDot:1
+15 IF $GET(RXRP(RX))
IF '$GET(RXRP(RX,"MG"))
QUIT
+16 SET ^PSRX(RX,"L",IR,"FDA")=$PIECE($$MGONFILE^PSOFDAUT(RX),"^",2)
End DoDot:1
+17 SET ^PSRX(RX,"TYPE")=0
KILL RXF,IR,FDA,NOW,I
+18 IF '$DATA(PSSPND)
IF $PIECE(PSOPAR,"^",18)
DO CHCK2^PSOTRLBL
END KILL PSCLN,%DT,ADDR,DATE,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,%H,COPIES,DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,INT,ISD,I1,MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL,SGC,PSMP,PSI,PSJ,VRPH,REPRINT,PS55,PS55X
QUIT
+1 QUIT
+2 ;
SIG1 SET X=$SELECT($DATA(SGY(DR)):SGY(DR),1:"")
WRITE !,X
+1 IF 'SIDE
WRITE ?38,X
IF PRTFL
WRITE ?83
if DR=1
WRITE ?83,$SELECT('REF:"PRINT NAME: "_$EXTRACT(LINE,1,25),1:"")
if DR=2
WRITE "DATE: ",$EXTRACT(LINE,1,10)
if (DR=2)&('REF)
WRITE " DEA# ",$EXTRACT(LINE,1,6)
if (DR=3)&('REF)
WRITE "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"
+2 QUIT
+3 ;
OSET IF $GET(RXFL(RX))']""!($GET(RXFL(RX))=0)
Begin DoDot:1
+1 SET TECH=$PIECE($GET(^VA(200,+$PIECE(^PSRX(RX,0),"^",16),0)),"^")
SET QTY=$PIECE(^PSRX(RX,0),"^",7)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(^PSRX(RX,0),"^",4),0)):$PIECE(^(0),"^"),1:"UKN")
DO 6^VADPT
DO PID^VADPT
SET SSNPN=""
+2 SET DAYS=$PIECE(^PSRX(RX,0),"^",8)
SET MFG="________"
SET LOT="________"
End DoDot:1
QUIT
+3 IF '$DATA(^PSRX(RX,1,RXFL(RX),0))
KILL RXFL(RX)
QUIT
+4 SET TECH=$SELECT($DATA(^VA(200,+$PIECE(^PSRX(RX,1,RXFL(RX),0),"^",7),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
+5 SET QTY=$PIECE(^PSRX(RX,1,RXFL(RX),0),"^",4)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(^PSRX(RX,1,RXFL(RX),0),"^",17),0)):$PIECE(^(0),"^"),$DATA(^VA(200,+$PIECE(^PSRX(RX,0),"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
DO 6^VADPT
DO PID^VADPT
SET SSNPN=""
+6 SET DAYS=$PIECE(^PSRX(RX,1,RXFL(RX),0),"^",10)
SET LOT="________"
SET MFG="________"
+7 QUIT
