PSOTRLBL ;BHAM ISC/AMC/SAB - MULTI RX REFILL REQUEST FORM ;08/24/17 10:11
;;7.0;OUTPATIENT PHARMACY;**19,92,107,110,326,441**;DEC 1997;Build 208
;External reference ^PS(59.7 supported by DBIA 694
;External reference to ^PS(55 supported by DBIA 2228
CHK S PSDO=$O(^PS(52.5,"C",ZI,D0)),DFN=$P(^PS(52.5,D0,0),"^",3) I PSDO>0 S PSDFN=$P(^PS(52.5,PSDO,0),"^",3) Q:PSDFN=DFN
G BUILD
CHCK2 Q:'$G(PPL) S:'$D(PI) PI=0 Q:COPIES G:$G(PSOLAPPL)!($G(PSDFNFLG)) CHEDI I $P(PPL,",",PI+1)'="" Q
CHEDI S $P(PSLN,"_",39)="" I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) F PI=0:1 G:$P(PPL,",",PI)="" INST S RX=$P(PPL,",",PI) D C^PSOLBL
BUILD Q:'DFN S PS1=$G(^PS(59,PSOSITE,1)),PSOSITE7=$G(^("IB")),PSOSYS=$G(^PS(59.7,1,40.1)) I '$D(PSSPND) F PSRX=0:0 S PSRX=$O(RX(PSRX)) Q:'PSRX K RX(PSRX)
F PSRX=0:0 S PSRX=$O(^PS(55,DFN,"P",PSRX)) Q:'PSRX D RZX
G:'$O(RX(0))&($P($G(PSOPAR),"^",28)) EXIT
S PSINF("STREET")=VAPA(1),PSINF("STREET 2")=VAPA(2),PSINF("CITY")=VAPA(4),PSINF("ZIP")=$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),PSINF("STATE")=$P(VAPA(5),"^",2)
S:VAPA(1)="" PSINF("STREET")="NO ADDRESS",(PSINF("CITY"),PSINF("STATE"),PSINF("ZIP"))="" S PSINF("NAME")=$P(^DPT(DFN,0),"^") D PID^VADPT S PSINF("SSAN")=VA("PID")
S PSA=0,VASTREET=$P(^PS(59,PSOSITE,0),"^",2),VAADDR1=$P(^(0),"^")
I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0),VASTREET=$P(^PS(59,$P(PSOSYS,"^",4),0),"^",2),VAADDR1=$P(^PS(59,$P(PSOSYS,"^",4),0),"^")
S COUNT=$S($G(PSOBARS)&($P(PSOPAR,"^",19)):3,1:10)
I '$P(^PS(59,PSOSITE,1),"^",28) D DOCOLD Q
;NEW LABEL
DOCNEW W ?54,PSINF("NAME")
I PSINF("STREET 2")="" S PSINF("STREET 2")=PSINF("STREET"),PSINF("STREET")=""
W !,?54,$G(VAPA(1)),!,?54,$G(ADDR(2))
I $G(ADDR(3))="",$G(ADDR(4))="" G ADD
I $G(ADDR(3))'="",$G(ADDR(4))="" W !,?54,$G(ADDR(3)) G ADD
W !,?54,$G(ADDR(3)),!,?54,$G(ADDR(4))
ADD I 'PSOORIG W !,?54,"Please check prescriptions to be refilled" ;441 PAPI
I PSOORIG W !,?54,"Please check prescriptions to be filled/refilled"
F J=1:1:COUNT S PSA=$O(RX(PSA)) S:'PSA J=J-1 Q:'PSA D SCRPTNEW
W !,?54,"(",PSLN,")",!,?60,"PATIENT'S SIGNATURE ",$E(DT,4,5),"/",$E(DT,6,7),"/",($E(DT,1,3)+1700)
DOCEND W @IOF I PSA,$O(RX(PSA)) G DOCNEW
INST ;
EXIT K PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSLN,PSRXX,PSSS,PSST,PSOCR,DIWL,DIWR,DIWF,PSO9 Q
SCRPTNEW W !,?54,"(___) ",$$ZZ^PSOSUTL(PSA) K ZDRUG
W !,?60,$P(RX(PSA),"^",2)," " D DTCONNW W ?64,"Expires ",PSDT2," Rx# ",$P(^PSRX(PSA,0),"^") K TN
I $G(PSOBARS),$P($G(PSOPAR),"^",19) S X="S",X2=PSOINST_"-"_PSA W !,?60 S X1=$X W @PSOBAR1,X2,@PSOBAR0
Q
DTCONNW S PSDT2=$P(RX(PSA),"^"),PSDT2=$E(PSDT2,4,5)_"/"_$E(PSDT2,6,7)_"/"_($E(PSDT2,1,3)+1700) Q
;OLD LABEL
DOCOLD W $C(13) S $X=0 W ?38,PSINF("SSAN")," FEE: " I $P($G(PSOPAR),"^",17) W $P($G(^DPT(DFN,.17)),"^",2)
W ?63,"REFILL REQUEST: PLEASE CHECK PRESCRIPTIONS TO BE REFILLED",!?38,PSINF("NAME"),?79,"YOUR SIGNATURE IS REQUIRED"
W !?38,PSINF("STREET"),?60,"REFILLS" W:PSINF("STREET 2")]"" !?38,PSINF("STREET 2") W !?38,PSINF("CITY"),?59,"REMAINING EXPIRES",!?38,PSINF("STATE")," ",PSINF("ZIP")
F J=1:1:COUNT S PSA=$O(RX(PSA)) S:'PSA J=J-1 Q:'PSA D SCRPTOLD
W !!! W ?40,"(",PSLN,")"," PATIENT'S SIGNATURE ",$E(DT,4,5),"/",$E(DT,6,7),"/",($E(DT,1,3)+1700)
W @IOF I PSA,$O(RX(PSA)) G DOCOLD
K PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSRXX,PSSS,PSST,PSLN Q
SCRPTOLD W !?56,"(____) ",$P(RX(PSA),"^",2)," " D DTCONOD W ?67,PSDT2," ",$P(^PSRX(PSA,0),"^")
W ?85,$$ZZ^PSOSUTL(PSA) K ZDRUG
I $G(PSOBARS),+$P($G(PSOPAR),"^",19) S X="S",X2=PSOINST_"-"_PSA W !,?80 S X1=$X W @PSOBAR1,X2,@PSOBAR0
Q
DTCONOD S PSDT2=$P(RX(PSA),"^"),PSDT2=$E(PSDT2,4,5)_"/"_$E(PSDT2,6,7)_"/"_($E(PSDT2,1,3)+1700) Q
REFILL F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC S PSRFL=PSRFL-1
I PSRFL>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0
Q
RZX ;
S PSOORIG=0 ;441 PAPI
S PSRXX=+^PS(55,DFN,"P",PSRX,0) I $D(^PSRX(PSRXX,0)) D
.N EXPDT
.S EXPDT=$P(^PSRX(PSRXX,2),"^",6) I EXPDT'>DT Q
.S PSRFL=$P(^PSRX(PSRXX,0),"^",9) D:$D(^PSRX(PSRXX,1))&PSRFL REFILL
.I +PSRFL=0,$G(^PSRX(PSRXX,"PARK")),$P($G(^PSRX(PSRXX,"STA")),"^")=0 D CHKLBL^PSOPRKA(PSRXX,0) I 'LBLP S RX(PSRXX)=EXPDT_"^"_PSRFL,PSOORIG=1
.I PSRFL>0,$P($G(^PSRX(PSRXX,"STA")),"^")<10,134'[$E(+$P($G(^("STA")),"^")) S RX(PSRXX)=EXPDT_"^"_PSRFL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTRLBL 4411 printed Sep 23, 2025@20:12:29 Page 2
PSOTRLBL ;BHAM ISC/AMC/SAB - MULTI RX REFILL REQUEST FORM ;08/24/17 10:11
+1 ;;7.0;OUTPATIENT PHARMACY;**19,92,107,110,326,441**;DEC 1997;Build 208
+2 ;External reference ^PS(59.7 supported by DBIA 694
+3 ;External reference to ^PS(55 supported by DBIA 2228
CHK SET PSDO=$ORDER(^PS(52.5,"C",ZI,D0))
SET DFN=$PIECE(^PS(52.5,D0,0),"^",3)
IF PSDO>0
SET PSDFN=$PIECE(^PS(52.5,PSDO,0),"^",3)
if PSDFN=DFN
QUIT
+1 GOTO BUILD
CHCK2 if '$GET(PPL)
QUIT
if '$DATA(PI)
SET PI=0
if COPIES
QUIT
if $GET(PSOLAPPL)!($GET(PSDFNFLG))
GOTO CHEDI
IF $PIECE(PPL,",",PI+1)'=""
QUIT
CHEDI SET $PIECE(PSLN,"_",39)=""
IF $ORDER(PSORX("PSOL",$GET(PPL1)))
SET PPL1=$ORDER(PSORX("PSOL",PPL1))
SET PPL=PSORX("PSOL",PPL1)
FOR PI=0:1
if $PIECE(PPL,",",PI)=""
GOTO INST
SET RX=$PIECE(PPL,",",PI)
DO C^PSOLBL
BUILD if 'DFN
QUIT
SET PS1=$GET(^PS(59,PSOSITE,1))
SET PSOSITE7=$GET(^("IB"))
SET PSOSYS=$GET(^PS(59.7,1,40.1))
IF '$DATA(PSSPND)
FOR PSRX=0:0
SET PSRX=$ORDER(RX(PSRX))
if 'PSRX
QUIT
KILL RX(PSRX)
+1 FOR PSRX=0:0
SET PSRX=$ORDER(^PS(55,DFN,"P",PSRX))
if 'PSRX
QUIT
DO RZX
+2 if '$ORDER(RX(0))&($PIECE($GET(PSOPAR),"^",28))
GOTO EXIT
+3 SET PSINF("STREET")=VAPA(1)
SET PSINF("STREET 2")=VAPA(2)
SET PSINF("CITY")=VAPA(4)
SET PSINF("ZIP")=$SELECT($GET(VAPA(11))]"":$PIECE($GET(VAPA(11)),"^",2),1:$GET(VAPA(6)))
SET PSINF("STATE")=$PIECE(VAPA(5),"^",2)
+4 if VAPA(1)=""
SET PSINF("STREET")="NO ADDRESS"
SET (PSINF("CITY"),PSINF("STATE"),PSINF("ZIP"))=""
SET PSINF("NAME")=$PIECE(^DPT(DFN,0),"^")
DO PID^VADPT
SET PSINF("SSAN")=VA("PID")
+5 SET PSA=0
SET VASTREET=$PIECE(^PS(59,PSOSITE,0),"^",2)
SET VAADDR1=$PIECE(^(0),"^")
+6 IF $PIECE(PSOSYS,"^",4)
IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
SET VASTREET=$PIECE(^PS(59,$PIECE(PSOSYS,"^",4),0),"^",2)
SET VAADDR1=$PIECE(^PS(59,$PIECE(PSOSYS,"^",4),0),"^")
+7 SET COUNT=$SELECT($GET(PSOBARS)&($PIECE(PSOPAR,"^",19)):3,1:10)
+8 IF '$PIECE(^PS(59,PSOSITE,1),"^",28)
DO DOCOLD
QUIT
+9 ;NEW LABEL
DOCNEW WRITE ?54,PSINF("NAME")
+1 IF PSINF("STREET 2")=""
SET PSINF("STREET 2")=PSINF("STREET")
SET PSINF("STREET")=""
+2 WRITE !,?54,$GET(VAPA(1)),!,?54,$GET(ADDR(2))
+3 IF $GET(ADDR(3))=""
IF $GET(ADDR(4))=""
GOTO ADD
+4 IF $GET(ADDR(3))'=""
IF $GET(ADDR(4))=""
WRITE !,?54,$GET(ADDR(3))
GOTO ADD
+5 WRITE !,?54,$GET(ADDR(3)),!,?54,$GET(ADDR(4))
ADD ;441 PAPI
IF 'PSOORIG
WRITE !,?54,"Please check prescriptions to be refilled"
+1 IF PSOORIG
WRITE !,?54,"Please check prescriptions to be filled/refilled"
+2 FOR J=1:1:COUNT
SET PSA=$ORDER(RX(PSA))
if 'PSA
SET J=J-1
if 'PSA
QUIT
DO SCRPTNEW
+3 WRITE !,?54,"(",PSLN,")",!,?60,"PATIENT'S SIGNATURE ",$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",($EXTRACT(DT,1,3)+1700)
DOCEND WRITE @IOF
IF PSA
IF $ORDER(RX(PSA))
GOTO DOCNEW
INST ;
EXIT KILL PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSLN,PSRXX,PSSS,PSST,PSOCR,DIWL,DIWR,DIWF,PSO9
QUIT
SCRPTNEW WRITE !,?54,"(___) ",$$ZZ^PSOSUTL(PSA)
KILL ZDRUG
+1 WRITE !,?60,$PIECE(RX(PSA),"^",2)," "
DO DTCONNW
WRITE ?64,"Expires ",PSDT2," Rx# ",$PIECE(^PSRX(PSA,0),"^")
KILL TN
+2 IF $GET(PSOBARS)
IF $PIECE($GET(PSOPAR),"^",19)
SET X="S"
SET X2=PSOINST_"-"_PSA
WRITE !,?60
SET X1=$X
WRITE @PSOBAR1,X2,@PSOBAR0
+3 QUIT
DTCONNW SET PSDT2=$PIECE(RX(PSA),"^")
SET PSDT2=$EXTRACT(PSDT2,4,5)_"/"_$EXTRACT(PSDT2,6,7)_"/"_($EXTRACT(PSDT2,1,3)+1700)
QUIT
+1 ;OLD LABEL
DOCOLD WRITE $CHAR(13)
SET $X=0
WRITE ?38,PSINF("SSAN")," FEE: "
IF $PIECE($GET(PSOPAR),"^",17)
WRITE $PIECE($GET(^DPT(DFN,.17)),"^",2)
+1 WRITE ?63,"REFILL REQUEST: PLEASE CHECK PRESCRIPTIONS TO BE REFILLED",!?38,PSINF("NAME"),?79,"YOUR SIGNATURE IS REQUIRED"
+2 WRITE !?38,PSINF("STREET"),?60,"REFILLS"
if PSINF("STREET 2")]""
WRITE !?38,PSINF("STREET 2")
WRITE !?38,PSINF("CITY"),?59,"REMAINING EXPIRES",!?38,PSINF("STATE")," ",PSINF("ZIP")
+3 FOR J=1:1:COUNT
SET PSA=$ORDER(RX(PSA))
if 'PSA
SET J=J-1
if 'PSA
QUIT
DO SCRPTOLD
+4 WRITE !!!
WRITE ?40,"(",PSLN,")"," PATIENT'S SIGNATURE ",$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",($EXTRACT(DT,1,3)+1700)
+5 WRITE @IOF
IF PSA
IF $ORDER(RX(PSA))
GOTO DOCOLD
+6 KILL PSINF,AMC,PSA,PSDFN,PSDO,PSDT2,PSRFL,PSRX,PSRXX,PSSS,PSST,PSLN
QUIT
SCRPTOLD WRITE !?56,"(____) ",$PIECE(RX(PSA),"^",2)," "
DO DTCONOD
WRITE ?67,PSDT2," ",$PIECE(^PSRX(PSA,0),"^")
+1 WRITE ?85,$$ZZ^PSOSUTL(PSA)
KILL ZDRUG
+2 IF $GET(PSOBARS)
IF +$PIECE($GET(PSOPAR),"^",19)
SET X="S"
SET X2=PSOINST_"-"_PSA
WRITE !,?80
SET X1=$X
WRITE @PSOBAR1,X2,@PSOBAR0
+3 QUIT
DTCONOD SET PSDT2=$PIECE(RX(PSA),"^")
SET PSDT2=$EXTRACT(PSDT2,4,5)_"/"_$EXTRACT(PSDT2,6,7)_"/"_($EXTRACT(PSDT2,1,3)+1700)
QUIT
REFILL FOR AMC=0:0
SET AMC=$ORDER(^PSRX(PSRXX,1,AMC))
if 'AMC
QUIT
SET PSRFL=PSRFL-1
+1 IF PSRFL>0
SET X1=DT
SET X2=$PIECE(^PSRX(PSRXX,0),"^",8)-10
DO C^%DTC
IF X'<$PIECE(^(2),"^",6)
SET PSRFL=0
+2 QUIT
RZX ;
+1 ;441 PAPI
SET PSOORIG=0
+2 SET PSRXX=+^PS(55,DFN,"P",PSRX,0)
IF $DATA(^PSRX(PSRXX,0))
Begin DoDot:1
+3 NEW EXPDT
+4 SET EXPDT=$PIECE(^PSRX(PSRXX,2),"^",6)
IF EXPDT'>DT
QUIT
+5 SET PSRFL=$PIECE(^PSRX(PSRXX,0),"^",9)
if $DATA(^PSRX(PSRXX,1))&PSRFL
DO REFILL
+6 IF +PSRFL=0
IF $GET(^PSRX(PSRXX,"PARK"))
IF $PIECE($GET(^PSRX(PSRXX,"STA")),"^")=0
DO CHKLBL^PSOPRKA(PSRXX,0)
IF 'LBLP
SET RX(PSRXX)=EXPDT_"^"_PSRFL
SET PSOORIG=1
+7 IF PSRFL>0
IF $PIECE($GET(^PSRX(PSRXX,"STA")),"^")<10
IF 134'[$EXTRACT(+$PIECE($GET(^("STA")),"^"))
SET RX(PSRXX)=EXPDT_"^"_PSRFL
End DoDot:1
+8 QUIT
