PSOSUDP1 ;BIR/RTR-Delete a batch of printed Rx's ; 1/10/96
;;7.0;OUTPATIENT PHARMACY;;DEC 1997
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
W !!,"Enter a date range to see all batches printed from suspense within those dates."
BEG K ^TMP($J,"PSODES"),^TMP($J,"PSODESPR"),^UTILITY($J,"PSODEPT"),PSOOUT,DTOUT,PSOLISTD
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
S BEGDATE=BEGDATE-.0001,ENDDATE=ENDDATE+.9999,RECNT=1 W !!,"Gathering batches, please wait...",! H 1
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
.I '$G(PDIVFLAG),MMM=$G(PSOSITE) S ^TMP($J,"PSODES",RECNT,ZZZ,XXX,MMM)="",RECNT=RECNT+1
.I $G(PDIVFLAG) S ^TMP($J,"PSODES",RECNT,ZZZ,XXX,MMM)="",RECNT=RECNT+1
I '$D(^TMP($J,"PSODES")) W $C(7),!!,"There are no printed batches found for that date range!",! G BEG
H 1 W @IOF W !,"BATCH",?8,"QUEUED TO PRINT ON:",?30,"PRINTED BY:",?59,"DIVISION" W ! F AA=1:1:78 W "-"
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
.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
..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 "-"
I $G(PSOOUT),Y="" G END
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
S COUNT=1 F ZZ=1:1:$L(Y) S ZZZ=$E(Y,ZZ) I ZZZ="," S COUNT=COUNT+1
S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y,",",JJ),^TMP($J,"PSODESPR",RR)=""
YLOOP I $G(Y(1)) F PSYLOOP=0:0 S PSYLOOP=$O(Y(PSYLOOP)) Q:'PSYLOOP D
.S COUNT=1 F ZZ=1:1:$L(Y(PSYLOOP)) S ZZZ=$E(Y(PSYLOOP),ZZ) I ZZZ="," S COUNT=COUNT+1
.S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y(PSYLOOP),",",JJ),^TMP($J,"PSODESPR",RR)=""
W !!,"Batches selected for Deletion are:",! F ZZZ=0:0 S ZZZ=$O(^TMP($J,"PSODESPR",ZZZ)) Q:'ZZZ D
.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")
.W !,"Batch ",ZZZ," Queued for ",PSODATE," by ",PSOUSER
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
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
I $G(PSOLISTD),Y="P" D DEQUE^PSOSUBCH G ENDM
I $G(PSOLISTD) D LIST I $G(PSOOUT) G END
;I Y D LIST I $G(PSOOUT) G END
DEL 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
F GG="PSOPAR","PSOSYS","PSOSITE" S:$D(@GG) ZTSAVE(GG)=""
F NNN=0:0 S NNN=$O(^TMP($J,"PSODESPR",NNN)) Q:'NNN D
.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))
.S ^UTILITY($J,"PSODEPT",PSRDATE,PSRDUZ,PSRDIV)=""
S ZTSAVE("^UTILITY($J,""PSODEPT"",")=""
W ! S ZTRTN="BEG^PSOSUDP2",ZTDESC="DELETE PRINTED BATCHES FROM SUSPENSE",ZTIO="",ZTDTH=$H D ^%ZTLOAD
I $D(ZTSK) W !!,"PRINTED BATCHES QUEUED FOR DELETION!",!!
G END
ENDM W !!?3,"Nothing deleted!"
END 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
K PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RESITE,RR,SS,XXX,ZZ,ZZZ,ZZZ Q
LIST F LLL=0:0 S LLL=$O(^TMP($J,"PSODESPR",LLL)) Q:'LLL!($G(PSOOUT)) D
.W ! S DIR(0)="E" D ^DIR K DIR S:'Y PSOOUT=1 Q:$G(PSOOUT)
.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
..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
...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:"")
I $G(PSOOUT),(Y="") Q
S PSOOUT=0 I Y'=0 W !,"END OF LIST"
Q
HEAD W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
Q
HEADONE S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUDP1 5240 printed Dec 13, 2024@02:35:25 Page 2
PSOSUDP1 ;BIR/RTR-Delete a batch of printed Rx's ; 1/10/96
+1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
+2 KILL PDIVFLAG
IF PSODIVS>1
KILL DIR
WRITE !
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Delete batches from your division ("_$PIECE($GET(^PS(59,+$GET(PSOSITE),0)),"^")_") only"
DO ^DIR
KILL DIR
if Y=0
SET PDIVFLAG=1
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
WRITE !!?3,"Nothing deleted!"
GOTO END
+3 WRITE !!,"Enter a date range to see all batches printed from suspense within those dates."
BEG KILL ^TMP($JOB,"PSODES"),^TMP($JOB,"PSODESPR"),^UTILITY($JOB,"PSODEPT"),PSOOUT,DTOUT,PSOLISTD
+1 WRITE !
KILL %DT
SET %DT="AEX"
SET %DT("A")="START DATE: "
DO ^%DT
KILL %DT
if Y<0!($DATA(DTOUT))
GOTO ENDM
SET (%DT(0),BEGDATE)=Y
WRITE !
SET %DT="AEX"
SET %DT("A")="END DATE: "
DO ^%DT
KILL %DT
if Y<0!($DATA(DTOUT))
GOTO ENDM
SET ENDDATE=Y
+2 SET BEGDATE=BEGDATE-.0001
SET ENDDATE=ENDDATE+.9999
SET RECNT=1
WRITE !!,"Gathering batches, please wait...",!
HANG 1
+3 FOR ZZZ=BEGDATE:0
SET ZZZ=$ORDER(^PS(52.5,"AS",ZZZ))
if 'ZZZ!(ZZZ>ENDDATE)
QUIT
FOR XXX=0:0
SET XXX=$ORDER(^PS(52.5,"AS",ZZZ,XXX))
if 'XXX
QUIT
FOR MMM=0:0
SET MMM=$ORDER(^PS(52.5,"AS",ZZZ,XXX,MMM))
if 'MMM
QUIT
Begin DoDot:1
+4 IF '$GET(PDIVFLAG)
IF MMM=$GET(PSOSITE)
SET ^TMP($JOB,"PSODES",RECNT,ZZZ,XXX,MMM)=""
SET RECNT=RECNT+1
+5 IF $GET(PDIVFLAG)
SET ^TMP($JOB,"PSODES",RECNT,ZZZ,XXX,MMM)=""
SET RECNT=RECNT+1
End DoDot:1
+6 IF '$DATA(^TMP($JOB,"PSODES"))
WRITE $CHAR(7),!!,"There are no printed batches found for that date range!",!
GOTO BEG
+7 HANG 1
WRITE @IOF
WRITE !,"BATCH",?8,"QUEUED TO PRINT ON:",?30,"PRINTED BY:",?59,"DIVISION"
WRITE !
FOR AA=1:1:78
WRITE "-"
+8 WRITE !
FOR AAA=0:0
SET AAA=$ORDER(^TMP($JOB,"PSODES",AAA))
if 'AAA!($GET(PSOOUT))
QUIT
SET PSIDATE=$ORDER(^TMP($JOB,"PSODES",AAA,0))
SET PSODUZ=$ORDER(^TMP($JOB,"PSODES",AAA,PSIDATE,0))
SET PSPDIV=$ORDER(^TMP($JOB,"PSODES",AAA,PSIDATE,PSODUZ,0))
Begin DoDot:1
+9 SET Y=PSIDATE
XECUTE ^DD("DD")
SET PSODATE=Y
SET PSOUSER=$SELECT($DATA(^VA(200,PSODUZ,0)):$EXTRACT($PIECE($GET(^(0)),"^"),1,28),1:"UNKNOWN")
SET PSPRDIV=$EXTRACT($PIECE($GET(^PS(59,PSPDIV,0)),"^"),1,20)
if ($Y+5)>IOSL
Begin DoDot:2
+10 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET PSOOUT=1
IF Y
WRITE @IOF
WRITE !,"BATCH",?8,"QUEUED TO PRINT ON:",?30,"PRINTED BY:",?59,"DIVISION"
WRITE !
FOR AA=1:1:78
WRITE "-"
End DoDot:2
if $GET(PSOOUT)
QUIT
WRITE !?1,AAA,?8,PSODATE,?30,PSOUSER,?59,PSPRDIV
End DoDot:1
+11 IF $GET(PSOOUT)
IF Y=""
GOTO END
+12 SET RECNT=RECNT-1
SET PSOOUT=0
WRITE !
KILL DIR
SET DIR("A")="Select Batch(s) to delete"
SET DIR(0)="L^1:"_RECNT
DO ^DIR
KILL DIR
if Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
GOTO ENDM
+13 SET COUNT=1
FOR ZZ=1:1:$LENGTH(Y)
SET ZZZ=$EXTRACT(Y,ZZ)
IF ZZZ=","
SET COUNT=COUNT+1
+14 SET COUNT=COUNT-1
FOR JJ=1:1:COUNT
SET RR=$PIECE(Y,",",JJ)
SET ^TMP($JOB,"PSODESPR",RR)=""
YLOOP IF $GET(Y(1))
FOR PSYLOOP=0:0
SET PSYLOOP=$ORDER(Y(PSYLOOP))
if 'PSYLOOP
QUIT
Begin DoDot:1
+1 SET COUNT=1
FOR ZZ=1:1:$LENGTH(Y(PSYLOOP))
SET ZZZ=$EXTRACT(Y(PSYLOOP),ZZ)
IF ZZZ=","
SET COUNT=COUNT+1
+2 SET COUNT=COUNT-1
FOR JJ=1:1:COUNT
SET RR=$PIECE(Y(PSYLOOP),",",JJ)
SET ^TMP($JOB,"PSODESPR",RR)=""
End DoDot:1
+3 WRITE !!,"Batches selected for Deletion are:",!
FOR ZZZ=0:0
SET ZZZ=$ORDER(^TMP($JOB,"PSODESPR",ZZZ))
if 'ZZZ
QUIT
Begin DoDot:1
+4 SET PSIDATE=$ORDER(^TMP($JOB,"PSODES",ZZZ,0))
SET PSODUZ=$ORDER(^TMP($JOB,"PSODES",ZZZ,PSIDATE,0))
SET Y=PSIDATE
XECUTE ^DD("DD")
SET PSODATE=Y
SET PSOUSER=$SELECT($DATA(^VA(200,PSODUZ,0)):$PIECE($GET(^(0)),"^"),1:"UNKNOWN")
+5 WRITE !,"Batch ",ZZZ," Queued for ",PSODATE," by ",PSOUSER
End DoDot:1
+6 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Before Deleting, would you like a list of these prescriptions"
DO ^DIR
KILL DIR
if Y["^"!($DATA(DTOUT))
GOTO ENDM
+7 IF Y
WRITE !
SET PSOLISTD=1
SET DIR(0)="SB^S:SCREEN;P:PRINTER"
SET DIR("A")="Print list to the screen or to a printer"
SET DIR("B")="Screen"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO END
+8 IF $GET(PSOLISTD)
IF Y="P"
DO DEQUE^PSOSUBCH
GOTO ENDM
+9 IF $GET(PSOLISTD)
DO LIST
IF $GET(PSOOUT)
GOTO END
+10 ;I Y D LIST I $G(PSOOUT) G END
DEL WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Are you sure you want to delete the batches"
DO ^DIR
KILL DIR
IF Y'=1
GOTO ENDM
+1 FOR GG="PSOPAR","PSOSYS","PSOSITE"
if $DATA(@GG)
SET ZTSAVE(GG)=""
+2 FOR NNN=0:0
SET NNN=$ORDER(^TMP($JOB,"PSODESPR",NNN))
if 'NNN
QUIT
Begin DoDot:1
+3 SET PSRDATE=$ORDER(^TMP($JOB,"PSODES",NNN,0))
SET PSRDUZ=$ORDER(^TMP($JOB,"PSODES",NNN,PSRDATE,0))
SET PSRDIV=$ORDER(^TMP($JOB,"PSODES",NNN,PSRDATE,PSRDUZ,0))
+4 SET ^UTILITY($JOB,"PSODEPT",PSRDATE,PSRDUZ,PSRDIV)=""
End DoDot:1
+5 SET ZTSAVE("^UTILITY($J,""PSODEPT"",")=""
+6 WRITE !
SET ZTRTN="BEG^PSOSUDP2"
SET ZTDESC="DELETE PRINTED BATCHES FROM SUSPENSE"
SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+7 IF $DATA(ZTSK)
WRITE !!,"PRINTED BATCHES QUEUED FOR DELETION!",!!
+8 GOTO END
ENDM WRITE !!?3,"Nothing deleted!"
END KILL ^TMP($JOB,"PSODES"),^TMP($JOB,"PSODESPR"),^UTILITY($JOB,"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
+1 KILL PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RESITE,RR,SS,XXX,ZZ,ZZZ,ZZZ
QUIT
LIST FOR LLL=0:0
SET LLL=$ORDER(^TMP($JOB,"PSODESPR",LLL))
if 'LLL!($GET(PSOOUT))
QUIT
Begin DoDot:1
+1 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET PSOOUT=1
if $GET(PSOOUT)
QUIT
+2 DO HEAD
SET REDT=$ORDER(^TMP($JOB,"PSODES",LLL,0))
SET REDUZ=$ORDER(^TMP($JOB,"PSODES",LLL,REDT,0))
SET RESITE=$ORDER(^TMP($JOB,"PSODES",LLL,REDT,REDUZ,0))
FOR SS=0:0
SET SS=$ORDER(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS))
if 'SS!($GET(PSOOUT))
QUIT
Begin DoDot:2
+3 FOR GG=0:0
SET GG=$ORDER(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS,GG))
if 'GG!($GET(PSOOUT))
QUIT
if ($Y+5)>IOSL
DO HEADONE
if $GET(PSOOUT)
QUIT
IF $DATA(^PS(52.5,GG,0))
SET INRX=$PIECE(^(0),"^")
IF $DATA(^PSRX(INRX,0))
Begin DoDot:3
+4 WRITE !,$PIECE(^PSRX(INRX,0),"^"),?20,$PIECE($GET(^DPT(+$PIECE(^PSRX(INRX,0),"^",2),0)),"^"),?60,$SELECT($PIECE($GET(^PS(52.5,GG,0)),"^",5):"(PARTIAL)",$PIECE($GET(^(0)),"^",12):"(REPRINT)",1:"")
End DoDot:3
End DoDot:2
End DoDot:1
+5 IF $GET(PSOOUT)
IF (Y="")
QUIT
+6 SET PSOOUT=0
IF Y'=0
WRITE !,"END OF LIST"
+7 QUIT
HEAD WRITE @IOF
WRITE !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,!
FOR ZZZZ=1:1:78
WRITE "-"
+1 QUIT
HEADONE SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSOOUT=1
QUIT
+1 WRITE @IOF
WRITE !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,!
FOR ZZZZ=1:1:78
WRITE "-"
+2 QUIT
