source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUDP1.m@ 949

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1PSOSUDP1 ;BIR/RTR-Delete a batch of printed Rx's ; 1/10/96
2 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
3 K PDIVFLAG I PSODIVS>1 K DIR W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Delete batches from your division ("_$P($G(^PS(59,+$G(PSOSITE),0)),"^")_") only" D ^DIR K DIR S:Y=0 PDIVFLAG=1 I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!?3,"Nothing deleted!" G END
4 W !!,"Enter a date range to see all batches printed from suspense within those dates."
5BEG K ^TMP($J,"PSODES"),^TMP($J,"PSODESPR"),^UTILITY($J,"PSODEPT"),PSOOUT,DTOUT,PSOLISTD
6 W ! K %DT S %DT="AEX",%DT("A")="START DATE: " D ^%DT K %DT G:Y<0!($D(DTOUT)) ENDM S (%DT(0),BEGDATE)=Y W ! S %DT="AEX",%DT("A")="END DATE: " D ^%DT K %DT G:Y<0!($D(DTOUT)) ENDM S ENDDATE=Y
7 S BEGDATE=BEGDATE-.0001,ENDDATE=ENDDATE+.9999,RECNT=1 W !!,"Gathering batches, please wait...",! H 1
8 F ZZZ=BEGDATE:0 S ZZZ=$O(^PS(52.5,"AS",ZZZ)) Q:'ZZZ!(ZZZ>ENDDATE) F XXX=0:0 S XXX=$O(^PS(52.5,"AS",ZZZ,XXX)) Q:'XXX F MMM=0:0 S MMM=$O(^PS(52.5,"AS",ZZZ,XXX,MMM)) Q:'MMM D
9 .I '$G(PDIVFLAG),MMM=$G(PSOSITE) S ^TMP($J,"PSODES",RECNT,ZZZ,XXX,MMM)="",RECNT=RECNT+1
10 .I $G(PDIVFLAG) S ^TMP($J,"PSODES",RECNT,ZZZ,XXX,MMM)="",RECNT=RECNT+1
11 I '$D(^TMP($J,"PSODES")) W $C(7),!!,"There are no printed batches found for that date range!",! G BEG
12 H 1 W @IOF W !,"BATCH",?8,"QUEUED TO PRINT ON:",?30,"PRINTED BY:",?59,"DIVISION" W ! F AA=1:1:78 W "-"
13 W ! F AAA=0:0 S AAA=$O(^TMP($J,"PSODES",AAA)) Q:'AAA!($G(PSOOUT)) S PSIDATE=$O(^TMP($J,"PSODES",AAA,0)),PSODUZ=$O(^TMP($J,"PSODES",AAA,PSIDATE,0)),PSPDIV=$O(^TMP($J,"PSODES",AAA,PSIDATE,PSODUZ,0)) D
14 .S Y=PSIDATE X ^DD("DD") S PSODATE=Y,PSOUSER=$S($D(^VA(200,PSODUZ,0)):$E($P($G(^(0)),"^"),1,28),1:"UNKNOWN"),PSPRDIV=$E($P($G(^PS(59,PSPDIV,0)),"^"),1,20) D:($Y+5)>IOSL Q:$G(PSOOUT) W !?1,AAA,?8,PSODATE,?30,PSOUSER,?59,PSPRDIV
15 ..W ! K DIR S DIR(0)="E" D ^DIR K DIR S:'Y PSOOUT=1 I Y W @IOF W !,"BATCH",?8,"QUEUED TO PRINT ON:",?30,"PRINTED BY:",?59,"DIVISION" W ! F AA=1:1:78 W "-"
16 I $G(PSOOUT),Y="" G END
17 S RECNT=RECNT-1,PSOOUT=0 W ! K DIR S DIR("A")="Select Batch(s) to delete",DIR(0)="L^1:"_RECNT D ^DIR K DIR G:Y["^"!($D(DTOUT))!($D(DUOUT)) ENDM
18 S COUNT=1 F ZZ=1:1:$L(Y) S ZZZ=$E(Y,ZZ) I ZZZ="," S COUNT=COUNT+1
19 S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y,",",JJ),^TMP($J,"PSODESPR",RR)=""
20YLOOP I $G(Y(1)) F PSYLOOP=0:0 S PSYLOOP=$O(Y(PSYLOOP)) Q:'PSYLOOP D
21 .S COUNT=1 F ZZ=1:1:$L(Y(PSYLOOP)) S ZZZ=$E(Y(PSYLOOP),ZZ) I ZZZ="," S COUNT=COUNT+1
22 .S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y(PSYLOOP),",",JJ),^TMP($J,"PSODESPR",RR)=""
23 W !!,"Batches selected for Deletion are:",! F ZZZ=0:0 S ZZZ=$O(^TMP($J,"PSODESPR",ZZZ)) Q:'ZZZ D
24 .S PSIDATE=$O(^TMP($J,"PSODES",ZZZ,0)),PSODUZ=$O(^TMP($J,"PSODES",ZZZ,PSIDATE,0)) S Y=PSIDATE X ^DD("DD") S PSODATE=Y,PSOUSER=$S($D(^VA(200,PSODUZ,0)):$P($G(^(0)),"^"),1:"UNKNOWN")
25 .W !,"Batch ",ZZZ," Queued for ",PSODATE," by ",PSOUSER
26 W ! K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Before Deleting, would you like a list of these prescriptions" D ^DIR K DIR G:Y["^"!($D(DTOUT)) ENDM
27 I Y W ! S PSOLISTD=1 S DIR(0)="SB^S:SCREEN;P:PRINTER",DIR("A")="Print list to the screen or to a printer",DIR("B")="Screen" D ^DIR K DIR I $D(DIRUT) G END
28 I $G(PSOLISTD),Y="P" D DEQUE^PSOSUBCH G ENDM
29 I $G(PSOLISTD) D LIST I $G(PSOOUT) G END
30 ;I Y D LIST I $G(PSOOUT) G END
31DEL W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Are you sure you want to delete the batches" D ^DIR K DIR I Y'=1 G ENDM
32 F GG="PSOPAR","PSOSYS","PSOSITE" S:$D(@GG) ZTSAVE(GG)=""
33 F NNN=0:0 S NNN=$O(^TMP($J,"PSODESPR",NNN)) Q:'NNN D
34 .S PSRDATE=$O(^TMP($J,"PSODES",NNN,0)),PSRDUZ=$O(^TMP($J,"PSODES",NNN,PSRDATE,0)),PSRDIV=$O(^TMP($J,"PSODES",NNN,PSRDATE,PSRDUZ,0))
35 .S ^UTILITY($J,"PSODEPT",PSRDATE,PSRDUZ,PSRDIV)=""
36 S ZTSAVE("^UTILITY($J,""PSODEPT"",")=""
37 W ! S ZTRTN="BEG^PSOSUDP2",ZTDESC="DELETE PRINTED BATCHES FROM SUSPENSE",ZTIO="",ZTDTH=$H D ^%ZTLOAD
38 I $D(ZTSK) W !!,"PRINTED BATCHES QUEUED FOR DELETION!",!!
39 G END
40ENDM W !!?3,"Nothing deleted!"
41END K ^TMP($J,"PSODES"),^TMP($J,"PSODESPR"),^UTILITY($J,"PSODEPT"),%DT,%ZIS,AA,AAA,BEGDATE,COUNT,DUOUT,DTOUT,ENDDATE,GG,INRX,JJ,LLL,MMM,NNN,POP,PSIDATE,PSODATE,PSODUZ,PSOREDEV,PSORTIME,PSOUSER,PSPDIV,PDPRDIV,PDIVFLAG,PSYLOOP,PSOLISTD
42 K PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RESITE,RR,SS,XXX,ZZ,ZZZ,ZZZ Q
43LIST F LLL=0:0 S LLL=$O(^TMP($J,"PSODESPR",LLL)) Q:'LLL!($G(PSOOUT)) D
44 .W ! S DIR(0)="E" D ^DIR K DIR S:'Y PSOOUT=1 Q:$G(PSOOUT)
45 .D HEAD S REDT=$O(^TMP($J,"PSODES",LLL,0)),REDUZ=$O(^TMP($J,"PSODES",LLL,REDT,0)) S RESITE=$O(^TMP($J,"PSODES",LLL,REDT,REDUZ,0)) F SS=0:0 S SS=$O(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS)) Q:'SS!($G(PSOOUT)) D
46 ..F GG=0:0 S GG=$O(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS,GG)) Q:'GG!($G(PSOOUT)) D:($Y+5)>IOSL HEADONE Q:$G(PSOOUT) I $D(^PS(52.5,GG,0)) S INRX=$P(^(0),"^") I $D(^PSRX(INRX,0)) D
47 ...W !,$P(^PSRX(INRX,0),"^"),?20,$P($G(^DPT(+$P(^PSRX(INRX,0),"^",2),0)),"^"),?60,$S($P($G(^PS(52.5,GG,0)),"^",5):"(PARTIAL)",$P($G(^(0)),"^",12):"(REPRINT)",1:"")
48 I $G(PSOOUT),(Y="") Q
49 S PSOOUT=0 I Y'=0 W !,"END OF LIST"
50 Q
51HEAD W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
52 Q
53HEADONE S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
54 W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
55 Q
Note: See TracBrowser for help on using the repository browser.