source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUDPR.m@ 1590

Last change on this file since 1590 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1PSOSUDPR ;BIR/RTR-Delete printed Rx's from Suspense File ; 10/4/96
2 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
3 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use this option!",! Q
4 W !!,"This option allows you to delete printed Rx's from suspense.",!
5EN K DIR,PSOCODE S DIR(0)="SB^R:Rx;P:Patient;D:Date Range;B:Batch",DIR("B")="Rx",DIR("A")="Delete by"
6 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)=""
7 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)=""
8 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("?")=" "
9 W ! D ^DIR K DIR S PSOCODE=Y I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
10 S PSODIVS=0 F ZZZ=0:0 S ZZZ=$O(^PS(59,ZZZ)) Q:'ZZZ S PSODIVS=PSODIVS+1
11 I PSOCODE="P" D ALL G EN
12 I PSOCODE="D" D DATE G EN
13 I PSOCODE="B" D ^PSOSUDP1 G EN
14SING ;Delete single RX
15 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
16 S OUT=0,ANS=Y D:Y["-" PSOINST^PSOSUPAT D:OUT MES G:OUT SING
17 S:Y["-" Y=$P(Y,"-",2),X=$P($G(^PSRX(+Y,0)),"^")
18 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,"^")
19 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
20 I $P($G(^PS(52.5,SUSINT,0)),"^",6)'=PSOSITE S PSPOP=0 D CKDIV^PSOSUPAT I PSPOP W ! D MES G SING
21 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
22 S DA=SUSINT,DIK="^PS(52.5," D ^DIK W !!?5,"Rx# ",RXEXT," deleted from suspense!",!
23 G EN
24DATE ;
25 S PSONLY=0
26 W !!,"Deleting by date range will delete based on the day the Rx was",!,"actually printed from suspense!"
27BDATE 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
28EDATE 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
29 S EDATE=$E(Y,1,7) W !
30 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
31 I PSODIVS>1,'Y S PSONLY=1
32 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
33 W !!,"Deleting printed suspense entries."
34 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
35 .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 "."
36 ..I PSOSITE'=$P($G(^PS(52.5,QQ,0)),"^",6) S PDIVFLAG=1
37 W !,"Finished!"
38 Q
39ALL ;
40 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
41 S PSALL=Y
42BAR 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
43 .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
44 .S PSODFN=$P($G(^PSRX(RXN,0)),"^",2) W !!,"Patient: ",$P($G(^DPT(PSODFN,0)),"^")
45 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
46 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
47 W !!,"Deleting Suspense entries for ",$P($G(^DPT(PSODFN,0)),"^")
48 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 "."
49 W !!,"Finished!",! G ALL
50END 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
51 ;
52MES W !!?3,"Nothing deleted!",! Q
Note: See TracBrowser for help on using the repository browser.