source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLRP.m@ 1147

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1PSGPLRP ;BIR/CML3-PICK LIST REPRINT DRIVER ;18 APR 95 / 4:20 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**50**;16 DEC 97
3 ;
4 D ENCV^PSGSETU I $D(XQUIT) Q
5 ;
6START ;
7 R !!,"Select WARD GROUP or PICK LIST: ",X:DTIME W:'$T $C(7) S:'$T X="^" G:"^"[X DONE
8 I X=+X,$D(^PS(53.5,X,0)) S PSGPLG=X I '$D(^PS(53.5,"AF",PSGPLG)) S Y=^PS(53.5,X,0),PSGPLWG=+$P(Y,U,2),PSGPLWGP=$G(^PS(57.5,PSGPLWG,5)),PSGID=$P(Y,"^",3)
9 I S PSGOD=$P(Y,"^",4),Y=$S('$D(^PS(57.5,PSGPLWG,0)):PSGPLWG_";PS(57.5",$P(^(0),"^")]"":$P(^(0),"^"),1:PSGPLWG_";PS(57.5") W " ",Y,!?$L(PSGPLG)+21,$$ENDTC^PSGMI(PSGID)," thru ",$$ENDTC^PSGMI(PSGOD) D RP1 G START
10 D:X?1."?" HLP K DIC S DIC="^PS(57.5,",DIC(0)="EIMQ",DIC("S")="I $D(^PS(57.5,+Y,0)),$P(^(0),""^"",2)=""P"",$D(^PS(53.5,""AB"",+Y))!$D(^PS(53.5,""AO"",+Y))" D ^DIC K DIC G:+Y'>0 START
11 S PSGPLWG=+Y,PSGPLWGP=$G(^PS(57.5,PSGPLWG,5)) D NOW^%DTC S PSGDT=%,PSGPLGF="P",PSGPLG="" F D ^PSGPLG Q:"^"[PSGPLG D RP1
12 G START
13 ;
14DONE ;
15 D ENKV^PSGSETU K PSGPLGF,PSGPLG,PSGPLWG,PSGPLWGP,PSGPLUPF,PN,RB,WDN,TM,Y,PSGPLSTR Q
16 ;
17RP1 ;
18 K PSGPLUPF S %=2 I $D(^PS(53.5,"AU",PSGPLG)) D PW Q:%<1
19 D PAT Q:$D(DUOUT)
20 I %=2,$D(^PS(53.5,PSGPLG,0)) I '$P(^(0),"^",9) W $C(7),$C(7),!!?33,"*** WARNING ***",!,"THIS PICK LIST STARTED TO RUN ",$$ENDTC^PSGMI($P(^(0),"^",11)),", BUT HAS NOT RUN TO COMPLETION."
21 K ZTSAVE S ZTDESC="UNIT DOSE PICK LIST REPRINT",PSGTIR="^PSGPLR",(ZTSAVE("PSGPLG"),ZTSAVE("PSGPLWG"),ZTSAVE("PSGPLWGP"),ZTSAVE("PSGPLSTR"))="" S:$D(PSGPLUPF) ZTSAVE("PSGPLUPF")="" S:$D(PSJPRN) ZTSAVE("PSJPRN")=""
22 D ENDEV^PSGTI I POP W !,"No device selected. Option terminated." Q
23 I $D(IO("Q")) W:$D(ZTSK) !,"Pick list print queued!" Q
24 W !!," ...one moment, please..." D ^PSGPLR D ^%ZISC Q
25 ;
26HLP ;
27 W !?2,"Select a Ward Group for which a pick list has run for which you wish to",!,"reprint.",!?2,"You may also select a Pick List by number, which prints in the upper left",!,"corner of each pick list." Q
28 ;
29PW ; print which? pick list or update
30 F W !!,"This pick list has an update.",!,"Do you want to print the update" S %=2 D YN^DICN Q:% W !!?2,"An update has been run for this pick list. Enter 'YES' to print the update",!,"only. Enter 'NO' to print the complete pick list."
31 S:%=1 PSGPLUPF=1 Q
32 ;
33PAT ; select patient to start from
34 I $G(PSGPLUPF)=1 S DIC("S")="I $P(^(0),U,5)=1"
35 S PSGPLSTR="",DIC="^PS(53.5,"_PSGPLG_",1,",DIC("A")="Select PATIENT to start from (optional): ",DIC(0)="AEQZ" D ^DIC K DIC Q:Y<0
36 S WDN=$S($P(^PS(53.5,PSGPLG,0),"^",7)=1:"zns",1:$P(Y(0),"^",3)),TM=$P(Y(0),"^",2)
37 S RB=$P($G(^PS(53.5,PSGPLG,1,+Y(0),0)),U,4) I RB]"",$P(^PS(53.5,PSGPLG,0),U,6),RB'="zz" S RB=$S($P(RB,"-",2)?1N:0,1:"")_$P(RB,"-",2)_"-"_$P(RB,"-")
38 S RB=$S($P(^PS(53.5,PSGPLG,0),"^",8)=1:"zz",RB="":"zz",1:RB)
39 S PN=$E($P($G(^DPT(+Y(0),0)),U),1,12)_U_+Y(0)
40 Q:'$D(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN))
41 S PSGPLSTR=TM_"^"_WDN_"^"_RB_"^"_PN
42 Q
Note: See TracBrowser for help on using the repository browser.