PSGPLUP ;BIR/CML3-UPDATE A PICK LIST ;28 JUN 96 / 9:24 AM
;;5.0; INPATIENT MEDICATIONS ;**50,129,155**;16 DEC 97
;
D ENCV^PSGSETU I $D(XQUIT) Q
;
CHK ;
D NOW^%DTC S PSGDT=+$E(%,1,12)
F Q=0:0 S Q=$O(^PS(53.5,"AB",Q)) Q:'Q I $O(^(Q,PSGDT)) Q
E W !,"THERE ARE CURRENTLY NO PICK LISTS TO UPDATE." K DIR S DIR(0)="E" D ^DIR K DIR G DONE
;
ASK ;
S PSGPLGF="U",PSGPLG="" R !!,"Select WARD GROUP or PICK LIST: ",X:DTIME W:'$T $C(7) S:'$T X="^" G:"^"[X DONE I X=+X D NL I Y D UP G CHK
I X?1."?" W !!?2,"Select a Ward Group for which a pick list has been run that you wish to",!,"update.",!?2,"You may also select a Pick List by number, which prints in the upper left",!,"corner of each pick list."
D DIC,^DIC K DIC G:Y'>0 ASK S PSGPLWG=+Y,PSGPLWGP=$G(^PS(57.5,+Y,5)) D ^PSGPLG I "^"'[PSGPLG D UP D ^%ZISC
G CHK
;
DONE ;
D ^%ZISC D ENKV^PSGSETU K CML,FD,FFF,FQ,GRP,PSGPLF,PSGPLG,PSGPLGF,PSGPLREN,PSGPLS,PSGPLUPR,PSGPLTND,PSGPLUPD,PSGPLUPF,PSGPLWG,PSGPLWGN,PSGMAR,PSGPLC,SD,TS,UP,WD,XX,PDRG,PSGPLWGP,PSGPLUP Q
;
UP ;
I $D(^PS(53.5,PSGPLG,0)),'$P(^(0),"^",9) W $C(7),$C(7),!!?33,"*** WARNING ***",!,"THIS PICK LIST STARTED TO RUN ",$$ENDTC^PSGMI($P(^(0),"^",10)),", BUT HAS NOT RUN TO COMPLETION."
I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL") W $C(7),$C(7),!!?33,"*** WARNING ***",!!?15,"THIS PICK LIST IS CURRENTLY LOCKED BY ANOTHER JOB."
E D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
F R !!,"PRINT THE ENTIRE PICK LIST (P), OR ONLY THE UPDATE (U)? ",UP:DTIME W:'$T $C(7) S:'$T UP="^" D:UP'="^" UPC Q:UP]""
I UP="^" W !!,"Update terminated." Q
N PSGPLUP S:$G(UP)="U" PSGPLUP=1
D DEV Q:POP!$D(IO("Q")) W !,"...this may take a few minutes..." D QUEUE
;
ENQ ;
N PSGPLREN
I '$D(PSGPLUPQ) S PSGPLUPD=IO=IO(0)&($E(IOST)'="C") I PSGPLUPD S $P(PSGPLUPD,"^",2)=$G(ION)
S:$G(UP)="U" PSGPLUP=1
S PSGPLTND=$G(^PS(53.5,PSGPLG,0)) Q:'PSGPLTND S PSGPLS=$P(PSGPLTND,"^",3),PSGPLF=$P(PSGPLTND,"^",4),WSF=$P(PSGPLTND,"^",7),PSGPLUPF=$S(UP="U":1,1:"")
D ENQ^PSGPLUP0
D ^PSGPLR,^%ZISC I UP="P" Q
I '$D(PSGPLUPQ) S PSGPLUPR=1 F W !!,"DO YOU NEED A REPRINT OF THIS UPDATE" S %=2 D YN^DICN Q:%<0 Q:%=2 D:'% RP I % S:PSGPLUPD IOP=$P(PSGPLUPD,"^",2) D DEV Q:POP I '$D(IO("Q")) U IO D ^PSGPLR D ^%ZISC
D DONE
Q
;
UPC ;
I UP?1."?" S UP="" W !!," Enter a 'U' if you wish to print only the new and edited (updated) orders for this pick list. Enter a 'P' to print the entire pick list, including the up- dated orders. Enter a '^' to terminate this update now." Q
I UP="U" W "PDATE" Q
I UP="P" W "ICK LIST" Q
W $C(7)," ??" S UP="" Q
;
DEV ;
K PSGPLUPQ,IOP,IO("Q"),%ZIS S PSGION=ION,%ZIS="Q",%ZIS("A")="Print on Device: ",%ZIS("B")="" W ! D ^%ZIS K %ZIS I POP S IOP=PSGION D ^%ZIS K IOP S POP=1 W !,"No device chosen." Q
;
QUEUE ;
Q:'$D(IO("Q"))
K ZTSAVE S PSGTIR=$S($D(PSGPLUPR):"^PSGPLR",1:"ENQ^PSGPLUP"),ZTDESC="PICK LIST UPDATE",PSGPLUPQ=1
F X="PSGPLWG","PSGPLWGP","PSGPLG","UP","PSGPLUPF","PSGPLUPQ","PSGPLUP" S ZTSAVE(X)="" S:$D(PSJPRN) ZTSAVE("PSJPRN")=""
D ENTSK^PSGTI I $D(ZTSK) W !,"Pick list update queued!" K PSGPLUPQ Q
I '$D(ZTSK) Q
D ENQ^PSGPLUP
;
RP ;
W !!,"Enter a 'Y' to reprint this update. Enter an 'N' (or '^') if you do not want to reprint this update." Q
;
DIC K DIC S DIC="^PS(57.5,",DIC(0)="EIMQ",DIC("S")="I $D(^PS(57.5,+Y,0)),$P(^(0),""^"",2)=""P"",$O(^PS(53.5,""AB"",+Y,"_PSGDT_"))" Q
;
NL ; numeric look-up
S Y=$G(^PS(53.5,X,0)) I $S('$P(Y,"^",3):1,$P(Y,"^",3)<PSGDT:1,1:'$D(^PS(53.5,"AB",$P(Y,"^",2),+$P(Y,"^",3),X))) S Y=0 Q
S (GRP,PSGPLG)=X,X=Y,PSGID=$P(X,"^",3),PSGPLWG=$P(X,"^",2),PSGPLWGN=$P($G(^PS(57.5,PSGPLWG,0)),"^"),PSGPLWGP=$G(^(5)) S:PSGPLWGN="" PSGPLWGN=PSGPLWG_";PS(57.5," S Y=$$ENDTC^PSGMI($P(X,"^",3)),PSGOD=$$ENDTC^PSGMI($P(X,"^",4))
W " ",PSGPLWGN,!?$L(GRP)+21,Y," thru ",PSGOD S Y=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLUP 3808 printed Sep 23, 2025@19:39:03 Page 2
PSGPLUP ;BIR/CML3-UPDATE A PICK LIST ;28 JUN 96 / 9:24 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**50,129,155**;16 DEC 97
+2 ;
+3 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+4 ;
CHK ;
+1 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
+2 FOR Q=0:0
SET Q=$ORDER(^PS(53.5,"AB",Q))
if 'Q
QUIT
IF $ORDER(^(Q,PSGDT))
QUIT
+3 IF '$TEST
WRITE !,"THERE ARE CURRENTLY NO PICK LISTS TO UPDATE."
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO DONE
+4 ;
ASK ;
+1 SET PSGPLGF="U"
SET PSGPLG=""
READ !!,"Select WARD GROUP or PICK LIST: ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
GOTO DONE
IF X=+X
DO NL
IF Y
DO UP
GOTO CHK
+2 IF X?1."?"
WRITE !!?2,"Select a Ward Group for which a pick list has been run that you wish to",!,"update.",!?2,"You may also select a Pick List by number, which prints in the upper left",!,"corner of each pick list."
+3 DO DIC
DO ^DIC
KILL DIC
if Y'>0
GOTO ASK
SET PSGPLWG=+Y
SET PSGPLWGP=$GET(^PS(57.5,+Y,5))
DO ^PSGPLG
IF "^"'[PSGPLG
DO UP
DO ^%ZISC
+4 GOTO CHK
+5 ;
DONE ;
+1 DO ^%ZISC
DO ENKV^PSGSETU
KILL CML,FD,FFF,FQ,GRP,PSGPLF,PSGPLG,PSGPLGF,PSGPLREN,PSGPLS,PSGPLUPR,PSGPLTND,PSGPLUPD,PSGPLUPF,PSGPLWG,PSGPLWGN,PSGMAR,PSGPLC,SD,TS,UP,WD,XX,PDRG,PSGPLWGP,PSGPLUP
QUIT
+2 ;
UP ;
+1 IF $DATA(^PS(53.5,PSGPLG,0))
IF '$PIECE(^(0),"^",9)
WRITE $CHAR(7),$CHAR(7),!!?33,"*** WARNING ***",!,"THIS PICK LIST STARTED TO RUN ",$$ENDTC^PSGMI($PIECE(^(0),"^",10)),", BUT HAS NOT RUN TO COMPLETION."
+2 IF '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL")
WRITE $CHAR(7),$CHAR(7),!!?33,"*** WARNING ***",!!?15,"THIS PICK LIST IS CURRENTLY LOCKED BY ANOTHER JOB."
+3 IF '$TEST
DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
+4 FOR
READ !!,"PRINT THE ENTIRE PICK LIST (P), OR ONLY THE UPDATE (U)? ",UP:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET UP="^"
if UP'="^"
DO UPC
if UP]""
QUIT
+5 IF UP="^"
WRITE !!,"Update terminated."
QUIT
+6 NEW PSGPLUP
if $GET(UP)="U"
SET PSGPLUP=1
+7 DO DEV
if POP!$DATA(IO("Q"))
QUIT
WRITE !,"...this may take a few minutes..."
DO QUEUE
+8 ;
ENQ ;
+1 NEW PSGPLREN
+2 IF '$DATA(PSGPLUPQ)
SET PSGPLUPD=IO=IO(0)&($EXTRACT(IOST)'="C")
IF PSGPLUPD
SET $PIECE(PSGPLUPD,"^",2)=$GET(ION)
+3 if $GET(UP)="U"
SET PSGPLUP=1
+4 SET PSGPLTND=$GET(^PS(53.5,PSGPLG,0))
if 'PSGPLTND
QUIT
SET PSGPLS=$PIECE(PSGPLTND,"^",3)
SET PSGPLF=$PIECE(PSGPLTND,"^",4)
SET WSF=$PIECE(PSGPLTND,"^",7)
SET PSGPLUPF=$SELECT(UP="U":1,1:"")
+5 DO ENQ^PSGPLUP0
+6 DO ^PSGPLR
DO ^%ZISC
IF UP="P"
QUIT
+7 IF '$DATA(PSGPLUPQ)
SET PSGPLUPR=1
FOR
WRITE !!,"DO YOU NEED A REPRINT OF THIS UPDATE"
SET %=2
DO YN^DICN
if %<0
QUIT
if %=2
QUIT
if '%
DO RP
IF %
if PSGPLUPD
SET IOP=$PIECE(PSGPLUPD,"^",2)
DO DEV
if POP
QUIT
IF '$DATA(IO("Q"))
USE IO
DO ^PSGPLR
DO ^%ZISC
+8 DO DONE
+9 QUIT
+10 ;
UPC ;
+1 IF UP?1."?"
SET UP=""
WRITE !!," Enter a 'U' if you wish to print only the new and edited (updated) orders for this pick list. Enter a 'P' to print the entire pick list, including the up- dated orders. Enter a '^' to terminate this update now."
QUIT
+2 IF UP="U"
WRITE "PDATE"
QUIT
+3 IF UP="P"
WRITE "ICK LIST"
QUIT
+4 WRITE $CHAR(7)," ??"
SET UP=""
QUIT
+5 ;
DEV ;
+1 KILL PSGPLUPQ,IOP,IO("Q"),%ZIS
SET PSGION=ION
SET %ZIS="Q"
SET %ZIS("A")="Print on Device: "
SET %ZIS("B")=""
WRITE !
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSGION
DO ^%ZIS
KILL IOP
SET POP=1
WRITE !,"No device chosen."
QUIT
+2 ;
QUEUE ;
+1 if '$DATA(IO("Q"))
QUIT
+2 KILL ZTSAVE
SET PSGTIR=$SELECT($DATA(PSGPLUPR):"^PSGPLR",1:"ENQ^PSGPLUP")
SET ZTDESC="PICK LIST UPDATE"
SET PSGPLUPQ=1
+3 FOR X="PSGPLWG","PSGPLWGP","PSGPLG","UP","PSGPLUPF","PSGPLUPQ","PSGPLUP"
SET ZTSAVE(X)=""
if $DATA(PSJPRN)
SET ZTSAVE("PSJPRN")=""
+4 DO ENTSK^PSGTI
IF $DATA(ZTSK)
WRITE !,"Pick list update queued!"
KILL PSGPLUPQ
QUIT
+5 IF '$DATA(ZTSK)
QUIT
+6 DO ENQ^PSGPLUP
+7 ;
RP ;
+1 WRITE !!,"Enter a 'Y' to reprint this update. Enter an 'N' (or '^') if you do not want to reprint this update."
QUIT
+2 ;
DIC KILL DIC
SET DIC="^PS(57.5,"
SET DIC(0)="EIMQ"
SET DIC("S")="I $D(^PS(57.5,+Y,0)),$P(^(0),""^"",2)=""P"",$O(^PS(53.5,""AB"",+Y,"_PSGDT_"))"
QUIT
+1 ;
NL ; numeric look-up
+1 SET Y=$GET(^PS(53.5,X,0))
IF $SELECT('$PIECE(Y,"^",3):1,$PIECE(Y,"^",3)<PSGDT:1,1:'$DATA(^PS(53.5,"AB",$PIECE(Y,"^",2),+$PIECE(Y,"^",3),X)))
SET Y=0
QUIT
+2 SET (GRP,PSGPLG)=X
SET X=Y
SET PSGID=$PIECE(X,"^",3)
SET PSGPLWG=$PIECE(X,"^",2)
SET PSGPLWGN=$PIECE($GET(^PS(57.5,PSGPLWG,0)),"^")
SET PSGPLWGP=$GET(^(5))
if PSGPLWGN=""
SET PSGPLWGN=PSGPLWG_";PS(57.5,"
SET Y=$$ENDTC^PSGMI($PIECE(X,"^",3))
SET PSGOD=$$ENDTC^PSGMI($PIECE(X,"^",4))
+3 WRITE " ",PSGPLWGN,!?$LENGTH(GRP)+21,Y," thru ",PSGOD
SET Y=1
QUIT
