source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLUP.m@ 701

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PSGPLUP ;BIR/CML3-UPDATE A PICK LIST ;28 JUN 96 / 9:24 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**50,129,155**;16 DEC 97
3 ;
4 D ENCV^PSGSETU I $D(XQUIT) Q
5 ;
6CHK ;
7 D NOW^%DTC S PSGDT=+$E(%,1,12)
8 F Q=0:0 S Q=$O(^PS(53.5,"AB",Q)) Q:'Q I $O(^(Q,PSGDT)) Q
9 E W !,"THERE ARE CURRENTLY NO PICK LISTS TO UPDATE." K DIR S DIR(0)="E" D ^DIR K DIR G DONE
10 ;
11ASK ;
12 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
13 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."
14 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
15 G CHK
16 ;
17DONE ;
18 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
19 ;
20UP ;
21 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."
22 I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL") W $C(7),$C(7),!!?33,"*** WARNING ***",!!?15,"THIS PICK LIST IS CURRENTLY LOCKED BY ANOTHER JOB."
23 E D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
24 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]""
25 I UP="^" W !!,"Update terminated." Q
26 N PSGPLUP S:$G(UP)="U" PSGPLUP=1
27 D DEV Q:POP!$D(IO("Q")) W !,"...this may take a few minutes..." D QUEUE
28 ;
29ENQ ;
30 N PSGPLREN
31 I '$D(PSGPLUPQ) S PSGPLUPD=IO=IO(0)&($E(IOST)'="C") I PSGPLUPD S $P(PSGPLUPD,"^",2)=$G(ION)
32 S:$G(UP)="U" PSGPLUP=1
33 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:"")
34 D ENQ^PSGPLUP0
35 D ^PSGPLR,^%ZISC I UP="P" Q
36 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
37 D DONE
38 Q
39 ;
40UPC ;
41 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
42 I UP="U" W "PDATE" Q
43 I UP="P" W "ICK LIST" Q
44 W $C(7)," ??" S UP="" Q
45 ;
46DEV ;
47 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
48 ;
49QUEUE ;
50 Q:'$D(IO("Q"))
51 K ZTSAVE S PSGTIR=$S($D(PSGPLUPR):"^PSGPLR",1:"ENQ^PSGPLUP"),ZTDESC="PICK LIST UPDATE",PSGPLUPQ=1
52 F X="PSGPLWG","PSGPLWGP","PSGPLG","UP","PSGPLUPF","PSGPLUPQ","PSGPLUP" S ZTSAVE(X)="" S:$D(PSJPRN) ZTSAVE("PSJPRN")=""
53 D ENTSK^PSGTI I $D(ZTSK) W !,"Pick list update queued!" K PSGPLUPQ Q
54 I '$D(ZTSK) Q
55 D ENQ^PSGPLUP
56 ;
57RP ;
58 W !!,"Enter a 'Y' to reprint this update. Enter an 'N' (or '^') if you do not want to reprint this update." Q
59 ;
60DIC 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
61 ;
62NL ; numeric look-up
63 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
64 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))
65 W " ",PSGPLWGN,!?$L(GRP)+21,Y," thru ",PSGOD S Y=1 Q
Note: See TracBrowser for help on using the repository browser.