- 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 Feb 19, 2025@00:02:47 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