PSOVERC ;BHAM ISC/DMA,SAB - discontinue duplicate class from verify ; 07/22/95 17:11
;;7.0;OUTPATIENT PHARMACY;**146,223,148,249**;DEC 1997;Build 9
W !,$C(7)," *** SAME CLASS *** OF DRUG IN RX # ",$P(^PSRX(+$P(RX0,"^"),0),"^")," ",$P(DRG,"^") Q:'$P(PSOPAR,"^",18)
S PTST="" I $D(^PS(55,PSDFN,"PS")) S Z=+^("PS") I $D(^PS(53,Z,0)) S PTST=^(0)
DATA S DUPRX0=^PSRX($P(RX0,"^"),0),$P(DUPRX0,"^",15)=+$G(^("STA")),PSRFLS=$P(DUPRX0,"^",9),ISSD=$P(^(0),"^",13),RX0=DUPRX0,RX2=^(2),CAN=$P(DUPRX0,"^",15)'<11 K PSONULN S $P(PSONULN,"-",79)="-"
W !!,$J("Status: ",24) S J=$P(RX0,"^") D STAT^PSOFUNC W ST K RX0,RX2 W ?40,$J("Issued: ",24),$E(ISSD,4,5),"-",$E(ISSD,6,7),"-",$E(ISSD,2,3)
W !,$J("SIG: ",24),$P(DUPRX0,"^",10),!,$J("QTY: ",24),$P(DUPRX0,"^",7),?40,$J("# of refills: ",24),PSRFLS
S PHYS=$S($D(^VA(200,+$P(DUPRX0,"^",4),0)):^(0),1:"UNKNOWN")
W !,$J("Provider: ",24),$P(PHYS,"^"),?40,$J("Refills remaining: ",24),PSRFLS-$S($D(^PSRX($P(RX0,"^"),1,0)):$P(^(0),"^",4),1:0)
S LSTFL=+^PSRX($P(RX0,"^"),3) W !?40,$J("Last filled on: ",24),$E(LSTFL,4,5),"-",$E(LSTFL,6,7),"-",$E(LSTFL,2,3)
W !,PSONULN,! I (CAN)!($P(DUPRX0,"^",15)=12) S CAN=1 Q
I PTST["AUTH ABS",'$P(PSOPAR,"^",5) S X=1 Q
ASKC S DIR("A")="Discontinue Prescription #"_$P(DUPRX0,"^")_" ",DIR("B")="N",DIR(0)="SA^1:YES;0:NO",DIR("?")="Enter Y to discontinue this Prescription." D ^DIR K DIR
I 'Y W " Prescription was not discontinued..." Q
CANOLD S $P(^PSRX($P(RX0,"^"),"STA"),"^")=12,$P(^PSRX($P(RX0,"^"),3),"^",5)=DT
S PSMSG="Discontinued by new prescription",PSREA="C",PSRXREF=0 N PSOVRCTP S PSOVRCTP=$P(RX0,"^") D REVERSE^PSOBPSU1(PSOVRCTP,,"DC",7),CAN^PSOTPCAN(PSOVRCTP) D ACTLOG
S PSI="",$P(PSD(DRG),"^",3)=12 W " Prescription has been discontinued." S DA=$O(^PS(52.5,"B",$P(RX0,"^"),0)) I DA S PSI=$G(^PS(52.5,DA,"P")),DIK="^PS(52.5," D ^DIK K DIK,DA
D:'PSI SUSPCAN^PSOUTL
Q
ACTLOG ;adds activity log for discontinuations
S RXF=0 F JJ=0:0 S JJ=$O(^PSRX($P(RX0,"^"),1,JJ)) Q:'JJ S RXF=JJ S:JJ>5 RXF=JJ+1
S IR=0 F JJ=0:0 S JJ=$O(^PSRX($P(RX0,"^"),"A",JJ)) Q:'JJ S IR=JJ
S IR=IR+1,^PSRX($P(RX0,"^"),"A",IR,0)=DT_"^C^"_DUZ_"^"_RXF_"^"_PSMSG K RXF,JJ,IR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOVERC 2162 printed Apr 09, 2024@21:30:39 Page 2
PSOVERC ;BHAM ISC/DMA,SAB - discontinue duplicate class from verify ; 07/22/95 17:11
+1 ;;7.0;OUTPATIENT PHARMACY;**146,223,148,249**;DEC 1997;Build 9
+2 WRITE !,$CHAR(7)," *** SAME CLASS *** OF DRUG IN RX # ",$PIECE(^PSRX(+$PIECE(RX0,"^"),0),"^")," ",$PIECE(DRG,"^")
if '$PIECE(PSOPAR,"^",18)
QUIT
+3 SET PTST=""
IF $DATA(^PS(55,PSDFN,"PS"))
SET Z=+^("PS")
IF $DATA(^PS(53,Z,0))
SET PTST=^(0)
DATA SET DUPRX0=^PSRX($PIECE(RX0,"^"),0)
SET $PIECE(DUPRX0,"^",15)=+$GET(^("STA"))
SET PSRFLS=$PIECE(DUPRX0,"^",9)
SET ISSD=$PIECE(^(0),"^",13)
SET RX0=DUPRX0
SET RX2=^(2)
SET CAN=$PIECE(DUPRX0,"^",15)'<11
KILL PSONULN
SET $PIECE(PSONULN,"-",79)="-"
+1 WRITE !!,$JUSTIFY("Status: ",24)
SET J=$PIECE(RX0,"^")
DO STAT^PSOFUNC
WRITE ST
KILL RX0,RX2
WRITE ?40,$JUSTIFY("Issued: ",24),$EXTRACT(ISSD,4,5),"-",$EXTRACT(ISSD,6,7),"-",$EXTRACT(ISSD,2,3)
+2 WRITE !,$JUSTIFY("SIG: ",24),$PIECE(DUPRX0,"^",10),!,$JUSTIFY("QTY: ",24),$PIECE(DUPRX0,"^",7),?40,$JUSTIFY("# of refills: ",24),PSRFLS
+3 SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(DUPRX0,"^",4),0)):^(0),1:"UNKNOWN")
+4 WRITE !,$JUSTIFY("Provider: ",24),$PIECE(PHYS,"^"),?40,$JUSTIFY("Refills remaining: ",24),PSRFLS-$SELECT($DATA(^PSRX($PIECE(RX0,"^"),1,0)):$PIECE(^(0),"^",4),1:0)
+5 SET LSTFL=+^PSRX($PIECE(RX0,"^"),3)
WRITE !?40,$JUSTIFY("Last filled on: ",24),$EXTRACT(LSTFL,4,5),"-",$EXTRACT(LSTFL,6,7),"-",$EXTRACT(LSTFL,2,3)
+6 WRITE !,PSONULN,!
IF (CAN)!($PIECE(DUPRX0,"^",15)=12)
SET CAN=1
QUIT
+7 IF PTST["AUTH ABS"
IF '$PIECE(PSOPAR,"^",5)
SET X=1
QUIT
ASKC SET DIR("A")="Discontinue Prescription #"_$PIECE(DUPRX0,"^")_" "
SET DIR("B")="N"
SET DIR(0)="SA^1:YES;0:NO"
SET DIR("?")="Enter Y to discontinue this Prescription."
DO ^DIR
KILL DIR
+1 IF 'Y
WRITE " Prescription was not discontinued..."
QUIT
CANOLD SET $PIECE(^PSRX($PIECE(RX0,"^"),"STA"),"^")=12
SET $PIECE(^PSRX($PIECE(RX0,"^"),3),"^",5)=DT
+1 SET PSMSG="Discontinued by new prescription"
SET PSREA="C"
SET PSRXREF=0
NEW PSOVRCTP
SET PSOVRCTP=$PIECE(RX0,"^")
DO REVERSE^PSOBPSU1(PSOVRCTP,,"DC",7)
DO CAN^PSOTPCAN(PSOVRCTP)
DO ACTLOG
+2 SET PSI=""
SET $PIECE(PSD(DRG),"^",3)=12
WRITE " Prescription has been discontinued."
SET DA=$ORDER(^PS(52.5,"B",$PIECE(RX0,"^"),0))
IF DA
SET PSI=$GET(^PS(52.5,DA,"P"))
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK,DA
+3 if 'PSI
DO SUSPCAN^PSOUTL
+4 QUIT
ACTLOG ;adds activity log for discontinuations
+1 SET RXF=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX($PIECE(RX0,"^"),1,JJ))
if 'JJ
QUIT
SET RXF=JJ
if JJ>5
SET RXF=JJ+1
+2 SET IR=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX($PIECE(RX0,"^"),"A",JJ))
if 'JJ
QUIT
SET IR=JJ
+3 SET IR=IR+1
SET ^PSRX($PIECE(RX0,"^"),"A",IR,0)=DT_"^C^"_DUZ_"^"_RXF_"^"_PSMSG
KILL RXF,JJ,IR
+4 QUIT
