- 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
- 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
