PSGPLUP.m

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

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