PSOSUDPR ;BIR/RTR-Delete printed Rx's from Suspense File ; 10/4/96
;;7.0;OUTPATIENT PHARMACY;;DEC 1997
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use this option!",! Q
W !!,"This option allows you to delete printed Rx's from suspense.",!
EN K DIR,PSOCODE S DIR(0)="SB^R:Rx;P:Patient;D:Date Range;B:Batch",DIR("B")="Rx",DIR("A")="Delete by"
S DIR("A",1)="Enter 'R' to delete one Rx, 'P' to delete by patient, 'D' by date range,",DIR("A",2)="or 'B' to delete by printed batches. Enter '^' to Exit.",DIR("A",3)=""
S DIR("?",1)="This option allows you to remove Rx's from suspense that have already been",DIR("?",2)="printed. This will ensure that they cannot be reprinted if suspense is reset",DIR("?",3)="for reprinting.",DIR("?",4)=""
S DIR("?",5)="You may delete a single Rx, all Rx's for a particular patient, all Rx's that",DIR("?",6)="fall within a specified date range, or all Rx's from a printed batch.",DIR("?")=" "
W ! D ^DIR K DIR S PSOCODE=Y I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
S PSODIVS=0 F ZZZ=0:0 S ZZZ=$O(^PS(59,ZZZ)) Q:'ZZZ S PSODIVS=PSODIVS+1
I PSOCODE="P" D ALL G EN
I PSOCODE="D" D DATE G EN
I PSOCODE="B" D ^PSOSUDP1 G EN
SING ;Delete single RX
K DIR S DIR("A")="Select Rx #: ",DIR(0)="FOA",DIR("?")="Enter the prescription number or wand the barcode" W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!(X="") D MES G EN
S OUT=0,ANS=Y D:Y["-" PSOINST^PSOSUPAT D:OUT MES G:OUT SING
S:Y["-" Y=$P(Y,"-",2),X=$P($G(^PSRX(+Y,0)),"^")
S:ANS'["-" X=Y W ! S DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0))",DIC="^PS(52.5,",DIC(0)="ZQE" D ^DIC K DIC W ! G:$D(DTOUT)!($D(DUOUT)) EN D MES:Y<0 G SING:Y<0 S (RXINT,RXREC)=+Y(0),SUSINT=$P(Y,"^")
S RXEXT=$P($G(^PSRX(RXINT,0)),"^") I $P($G(^PS(52.5,SUSINT,"P")),"^")=0!($P($G(^("P")),"^")="") W $C(7),!?5,"Cannot delete, Rx# ",RXEXT," has not been printed yet!" G SING
I $P($G(^PS(52.5,SUSINT,0)),"^",6)'=PSOSITE S PSPOP=0 D CKDIV^PSOSUPAT I PSPOP W ! D MES G SING
W ! K DIR S DIR("A")="OK to delete Rx# "_$G(RXEXT)_" from suspense",DIR("B")="Y",DIR(0)="Y" D ^DIR K DIR I 'Y D MES G SING
S DA=SUSINT,DIK="^PS(52.5," D ^DIK W !!?5,"Rx# ",RXEXT," deleted from suspense!",!
G EN
DATE ;
S PSONLY=0
W !!,"Deleting by date range will delete based on the day the Rx was",!,"actually printed from suspense!"
BDATE W ! K %DT S %DT="AEX",%DT("A")="Start Date : " D ^%DT K %DT G:Y=-1&(X'["^") BDATE I X["^"!($D(DTOUT)) D MES Q
EDATE S BDATE=$E(Y,1,7) S %DT(0)=Y,%DT="AEX",%DT("A")="End Date :" D ^%DT K %DT G:Y=-1&(X'["^") EDATE I X["^"!($D(DTOUT)) D MES Q
S EDATE=$E(Y,1,7) W !
I PSODIVS>1 K DIR S DIR(0)="Y",DIR("A")="Delete printed Rx's for all Divisions",DIR("B")="Y" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) D MES Q
I PSODIVS>1,'Y S PSONLY=1
W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="OK to delete printed Rx's for the date range entered" D ^DIR K DIR I 'Y D MES Q
W !!,"Deleting printed suspense entries."
S EDATE=EDATE+.9999 S BDATE=BDATE-.0001 F SS=BDATE:0 S SS=$O(^PS(52.5,"ADL",SS)) Q:'SS!(SS>EDATE) D
.F QQ=0:0 S QQ=$O(^PS(52.5,"ADL",SS,QQ)) Q:'QQ S PDIVFLAG=0,PSINT=$P($G(^PS(52.5,QQ,0)),"^") D:PSONLY I 'PDIVFLAG,$P($G(^PS(52.5,QQ,"P")),"^")=1 S DA=QQ,DIK="^PS(52.5," D ^DIK W "."
..I PSOSITE'=$P($G(^PS(52.5,QQ,0)),"^",6) S PDIVFLAG=1
W !,"Finished!"
Q
ALL ;
W ! K DIR S DIR("A")="Are you entering patient name or RX barcode",DIR(0)="SB^P:Patient Name;B:Barcode" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) D MES Q
S PSALL=Y
BAR S OUT=0 I PSALL="B" W ! K DIR S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20" D ^DIR K DIR G:Y["^"!($D(DTOUT))!($D(DUOUT)) ALL S BCNUM=Y D G:OUT BAR
.D PSOINST^PSOSUPAT Q:OUT S RXN=$P(BCNUM,"-",2) I '$D(^PSRX(RXN,0))!('$P($G(^PSRX(RXN,0)),"^",2)) W !!,"Invalid Prescription!",! S OUT=1 Q
.S PSODFN=$P($G(^PSRX(RXN,0)),"^",2) W !!,"Patient: ",$P($G(^DPT(PSODFN,0)),"^")
I PSALL'="B" K DIC W ! S DIC(0)="QEAMZ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AF"",+Y))" D ^DIC K DIC G:Y<0!($D(DTOUT))!($D(DUOUT)) ALL S PSODFN=+Y
W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="OK to delete printed entries for "_$P($G(^DPT(PSODFN,0)),"^") D ^DIR K DIR I 'Y D MES Q
W !!,"Deleting Suspense entries for ",$P($G(^DPT(PSODFN,0)),"^")
F EE=0:0 S EE=$O(^PS(52.5,"AF",PSODFN,EE)) Q:'EE I $P($G(^PS(52.5,EE,"P")),"^")=1&($P(^PS(52.5,EE,0),"^",7)'["QL") S PSORXIN=$P($G(^PS(52.5,EE,0)),"^"),DA=EE,DIK="^PS(52.5," D ^DIK W "."
W !!,"Finished!",! G ALL
END K ANS,BCNUM,BDATE,DA,DFN,DIC,DIR,PDIVFLAG,EDATE,EE,OUT,PSALL,PSINT,PSOCODE,PSODFN,PSODIVS,PSONLY,PSORXIN,PSPOP,QQ,RXINT,RXN,RXREC,SS,SUSINT,X,Y,ZZZ Q
;
MES W !!?3,"Nothing deleted!",! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUDPR 4655 printed Dec 13, 2024@02:35:26 Page 2
PSOSUDPR ;BIR/RTR-Delete printed Rx's from Suspense File ; 10/4/96
+1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,?5,"Site Parameters must be defined to use this option!",!
QUIT
+3 WRITE !!,"This option allows you to delete printed Rx's from suspense.",!
EN KILL DIR,PSOCODE
SET DIR(0)="SB^R:Rx;P:Patient;D:Date Range;B:Batch"
SET DIR("B")="Rx"
SET DIR("A")="Delete by"
+1 SET DIR("A",1)="Enter 'R' to delete one Rx, 'P' to delete by patient, 'D' by date range,"
SET DIR("A",2)="or 'B' to delete by printed batches. Enter '^' to Exit."
SET DIR("A",3)=""
+2 SET DIR("?",1)="This option allows you to remove Rx's from suspense that have already been"
SET DIR("?",2)="printed. This will ensure that they cannot be reprinted if suspense is reset"
SET DIR("?",3)="for reprinting."
SET DIR("?",4)=""
+3 SET DIR("?",5)="You may delete a single Rx, all Rx's for a particular patient, all Rx's that"
SET DIR("?",6)="fall within a specified date range, or all Rx's from a printed batch."
SET DIR("?")=" "
+4 WRITE !
DO ^DIR
KILL DIR
SET PSOCODE=Y
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
GOTO END
+5 SET PSODIVS=0
FOR ZZZ=0:0
SET ZZZ=$ORDER(^PS(59,ZZZ))
if 'ZZZ
QUIT
SET PSODIVS=PSODIVS+1
+6 IF PSOCODE="P"
DO ALL
GOTO EN
+7 IF PSOCODE="D"
DO DATE
GOTO EN
+8 IF PSOCODE="B"
DO ^PSOSUDP1
GOTO EN
SING ;Delete single RX
+1 KILL DIR
SET DIR("A")="Select Rx #: "
SET DIR(0)="FOA"
SET DIR("?")="Enter the prescription number or wand the barcode"
WRITE !
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(X="")
DO MES
GOTO EN
+2 SET OUT=0
SET ANS=Y
if Y["-"
DO PSOINST^PSOSUPAT
if OUT
DO MES
if OUT
GOTO SING
+3 if Y["-"
SET Y=$PIECE(Y,"-",2)
SET X=$PIECE($GET(^PSRX(+Y,0)),"^")
+4 if ANS'["-"
SET X=Y
WRITE !
SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0))"
SET DIC="^PS(52.5,"
SET DIC(0)="ZQE"
DO ^DIC
KILL DIC
WRITE !
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO EN
if Y<0
DO MES
if Y<0
GOTO SING
SET (RXINT,RXREC)=+Y(0)
SET SUSINT=$PIECE(Y,"^")
+5 SET RXEXT=$PIECE($GET(^PSRX(RXINT,0)),"^")
IF $PIECE($GET(^PS(52.5,SUSINT,"P")),"^")=0!($PIECE($GET(^("P")),"^")="")
WRITE $CHAR(7),!?5,"Cannot delete, Rx# ",RXEXT," has not been printed yet!"
GOTO SING
+6 IF $PIECE($GET(^PS(52.5,SUSINT,0)),"^",6)'=PSOSITE
SET PSPOP=0
DO CKDIV^PSOSUPAT
IF PSPOP
WRITE !
DO MES
GOTO SING
+7 WRITE !
KILL DIR
SET DIR("A")="OK to delete Rx# "_$GET(RXEXT)_" from suspense"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF 'Y
DO MES
GOTO SING
+8 SET DA=SUSINT
SET DIK="^PS(52.5,"
DO ^DIK
WRITE !!?5,"Rx# ",RXEXT," deleted from suspense!",!
+9 GOTO EN
DATE ;
+1 SET PSONLY=0
+2 WRITE !!,"Deleting by date range will delete based on the day the Rx was",!,"actually printed from suspense!"
BDATE WRITE !
KILL %DT
SET %DT="AEX"
SET %DT("A")="Start Date : "
DO ^%DT
KILL %DT
if Y=-1&(X'["^")
GOTO BDATE
IF X["^"!($DATA(DTOUT))
DO MES
QUIT
EDATE SET BDATE=$EXTRACT(Y,1,7)
SET %DT(0)=Y
SET %DT="AEX"
SET %DT("A")="End Date :"
DO ^%DT
KILL %DT
if Y=-1&(X'["^")
GOTO EDATE
IF X["^"!($DATA(DTOUT))
DO MES
QUIT
+1 SET EDATE=$EXTRACT(Y,1,7)
WRITE !
+2 IF PSODIVS>1
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Delete printed Rx's for all Divisions"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
DO MES
QUIT
+3 IF PSODIVS>1
IF 'Y
SET PSONLY=1
+4 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="OK to delete printed Rx's for the date range entered"
DO ^DIR
KILL DIR
IF 'Y
DO MES
QUIT
+5 WRITE !!,"Deleting printed suspense entries."
+6 SET EDATE=EDATE+.9999
SET BDATE=BDATE-.0001
FOR SS=BDATE:0
SET SS=$ORDER(^PS(52.5,"ADL",SS))
if 'SS!(SS>EDATE)
QUIT
Begin DoDot:1
+7 FOR QQ=0:0
SET QQ=$ORDER(^PS(52.5,"ADL",SS,QQ))
if 'QQ
QUIT
SET PDIVFLAG=0
SET PSINT=$PIECE($GET(^PS(52.5,QQ,0)),"^")
if PSONLY
Begin DoDot:2
+8 IF PSOSITE'=$PIECE($GET(^PS(52.5,QQ,0)),"^",6)
SET PDIVFLAG=1
End DoDot:2
IF 'PDIVFLAG
IF $PIECE($GET(^PS(52.5,QQ,"P")),"^")=1
SET DA=QQ
SET DIK="^PS(52.5,"
DO ^DIK
WRITE "."
End DoDot:1
+9 WRITE !,"Finished!"
+10 QUIT
ALL ;
+1 WRITE !
KILL DIR
SET DIR("A")="Are you entering patient name or RX barcode"
SET DIR(0)="SB^P:Patient Name;B:Barcode"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
DO MES
QUIT
+2 SET PSALL=Y
BAR SET OUT=0
IF PSALL="B"
WRITE !
KILL DIR
SET DIR("A")="Enter/wand barcode"
SET DIR(0)="FO^5:20"
DO ^DIR
KILL DIR
if Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
GOTO ALL
SET BCNUM=Y
Begin DoDot:1
+1 DO PSOINST^PSOSUPAT
if OUT
QUIT
SET RXN=$PIECE(BCNUM,"-",2)
IF '$DATA(^PSRX(RXN,0))!('$PIECE($GET(^PSRX(RXN,0)),"^",2))
WRITE !!,"Invalid Prescription!",!
SET OUT=1
QUIT
+2 SET PSODFN=$PIECE($GET(^PSRX(RXN,0)),"^",2)
WRITE !!,"Patient: ",$PIECE($GET(^DPT(PSODFN,0)),"^")
End DoDot:1
if OUT
GOTO BAR
+3 IF PSALL'="B"
KILL DIC
WRITE !
SET DIC(0)="QEAMZ"
SET DIC="^DPT("
SET DIC("S")="I $D(^PS(52.5,""AF"",+Y))"
DO ^DIC
KILL DIC
if Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO ALL
SET PSODFN=+Y
+4 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="OK to delete printed entries for "_$PIECE($GET(^DPT(PSODFN,0)),"^")
DO ^DIR
KILL DIR
IF 'Y
DO MES
QUIT
+5 WRITE !!,"Deleting Suspense entries for ",$PIECE($GET(^DPT(PSODFN,0)),"^")
+6 FOR EE=0:0
SET EE=$ORDER(^PS(52.5,"AF",PSODFN,EE))
if 'EE
QUIT
IF $PIECE($GET(^PS(52.5,EE,"P")),"^")=1&($PIECE(^PS(52.5,EE,0),"^",7)'["QL")
SET PSORXIN=$PIECE($GET(^PS(52.5,EE,0)),"^")
SET DA=EE
SET DIK="^PS(52.5,"
DO ^DIK
WRITE "."
+7 WRITE !!,"Finished!",!
GOTO ALL
END KILL ANS,BCNUM,BDATE,DA,DFN,DIC,DIR,PDIVFLAG,EDATE,EE,OUT,PSALL,PSINT,PSOCODE,PSODFN,PSODIVS,PSONLY,PSORXIN,PSPOP,QQ,RXINT,RXN,RXREC,SS,SUSINT,X,Y,ZZZ
QUIT
+1 ;
MES WRITE !!?3,"Nothing deleted!",!
QUIT
