source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ9.m@ 789

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1XQ9 ; SEA/AMF,MJM - RESTRICT AVAILABILITY OF OPTIONS ;9/29/92 14:59 ;5/13/93 11:24 AM
2 ;;8.0;KERNEL;;Jul 10, 1995
3INIT ;
4 K XQOP,XQFLD,XQDV,XQOD S (XQTDV,XQTOD,XQDF)=0 S XQOP(0)=0,XQJ=1 F XQI=2,3,3.8,3.91,3.95,3.96 S XQFLD(XQJ)=XQI,XQFLD(XQJ,0)=^DD(19,XQI,0) S XQJ=XQJ+1
5 S U="^" S:'$D(DTIME)#2 DTIME=60 S %ZIS="M" D:'$D(IOM) ^%ZIS K %ZIS
6OP ;
7 W !!,$S($O(XQOP(0))>0:"Another ",1:"Select ") W "OPTION NAME: " R X:DTIME S:'$T X=U G:X[U OUT
8 I '$L(X) S XQI=$O(XQOP(0)) G:XQI="" OUT W ! G:($O(XQOP(XQI))="") ONEOPT G GETRS
9 I X["?" S XQH="XQRESTRICT-OPTION" W ! D:X="?" EN^XQH D:X="??" LSTOP D:X="???" LSTFIL G OP
10 S XQM=0 S:"-'"[$E(X,1) X=$E(X,2,999),XQM=1
11 S DIC=19,DIC(0)="MEZ" D ^DIC I Y<0 W " ??",*7 G OP
12 I XQM W $S($D(XQOP(+Y)):" Deleted",1:$C(7)_" ?? Option not on list") K XQOP(+Y) G OP
13 I $D(^DIC(19,+Y,0)) S XQK=^(0) F XQI=1:1:5 S XQJ=$P(XQFLD(XQI,0),U,4),XQJ=$P(XQJ,";",2) I $L($P(XQK,U,XQJ)) W !?4,"CURRENT ",$P(XQFLD(XQI,0),U,1),": ",$P(XQK,U,XQJ)
14 I $D(^DIC(19,+Y,3.96)) S K=$P(^DIC(19,+Y,3.96,0),U,3) S XQJ=0 F XQI=1:1:K I $D(^DIC(19,+Y,3.96,XQI,0)) S XQN=+^(0) W:(XQJ=0) !,?4,$P(XQFLD(6,0),U,1),": " W:(XQJ>0) ", " W:'(XQJ#6) !,?22 W $P(^%ZIS(1,XQN,0),U,1) S XQJ=XQJ+1
15 S XQOP(+Y)=Y G OP
16ONEOPT ;
17 S DA=$O(XQOP(0)),DIE=19,DR="2;3;3.01;3.8;3.91;3.95;3.96" D ^DIE
18 G OUT
19 ;
20GETRS ;Get data for each restriction field, check it, and build DR string
21 S XQI=0,XQDR=""
22NEXT S XQI=XQI+1,XQN=+XQFLD(XQI) G:(XQI=6) GOTRS W !,$P(XQFLD(XQI,0),U,1)_" or '@' to delete: " R X:DTIME S:'$T X=U G:X[U OUT
23 I '$L(X) G NEXT
24 I X["?" S XQH="XQRESTRICT"_$S(XQN=2:"-OOO",XQN=3:"-LOCK",XQN=3.8:"-PRIORITY",XQN=3.91:"-TIMES",XQN=3.95:"-RESDEV",1:"") W ! D EN^XQH W ! S XQI=XQI-1 G NEXT
25 I X["@" S XQDR=XQDR_XQFLD(XQI)_"///@;" S XQFLD(XQI,"V")="(Delete current data from this field)" G NEXT
26 I XQN=2 K:$L(X)>80!($L(X)<1) X W:'$D(X)#2 !,$P(XQFLD(XQI,0),U,1)," must be free text, 1 to 80 characters in length." S:'$D(X)#2 XQI=XQI-1 G:'$D(X)#2 NEXT S XQDR=XQDR_XQFLD(XQI)_"///"_X_";" S XQFLD(XQI,"V")=X G NEXT
27 I XQN=3 K:$L(X)>30!($L(X)<1)!('$D(^DIC(19.1,"B",X))) X W:'$D(X)#2 !,$P(XQFLD(XQI,0),U,1)," (1 to 30 characters) must match exactly an existing key." S:'$D(X)#2 XQI=XQI-1 G:'$D(X)#2 NEXT S XQDR=XQDR_XQN_"///"_X_";" S XQFLD(XQI,"V")=X G NEXT
28 I XQN=3.8 K:+X'=X!(X>10)!(X<1) X W:'$D(X)#2 !,$P(XQFLD(XQI,0),U,1)," must be a single number between 1 and 10." S:'$D(X)#2 XQI=XQI-1 G:'$D(X) NEXT S XQDR=XQDR_XQN_"///"_X_";" S XQFLD(XQI,"V")=X G NEXT
29 I XQN=3.91 K:$L(X)>9!($L(X)<9)!(X'?4N1"-"4N) X W:'$D(X)#2 !,$P(XQFLD(XQI,0),U,1)," must be 9 characters in the form '0800-1630'" S:'$D(X)#2 XQI=XQI-1 G:'$D(X)#2 NEXT S XQDR=XQDR_XQN_"///"_X_";" S XQFLD(XQI,"V")=X G NEXT
30 I XQN=3.95 K:X'["Y"&(X'["y")&(X'["N")&(X'["n") X W:'$D(X)#2 !,$P(XQFLD(XQI,0),U,1)," must be 'yes' or 'no' (Y or N)" S:'$D(X)#2 XQI=XQI-1 G:'$D(X)#2 NEXT S XQDR=XQDR_XQN_"///"_X_";" S XQFLD(XQI,"V")=X
31 G NEXT
32 ;
33GOTRS ;Continue on in the next routine (^XQ91)
34 ;
35 G ^XQ91
36 ;
37LSTOP ;List the options that have been selected thus far
38 I $O(XQOP(0))="" W !!,"You have not yet selected any options." Q
39 W !!,"You've selected the following options: ",! S XQJ=0,XQI=IOM\15 F XQK=0:1 S XQJ=$O(XQOP(XQJ)) Q:XQJ="" W:'(XQK#XQI) ! W ?(XQK#XQI*15),$P(^DIC(19,XQJ,0),U,1)
40 Q
41 ;
42LSTFIL ;Show OPTION or DEVICE file
43 W !,"Do you want to see the ",$S(XQDF:"DEVICE",1:"OPTION")," file? NO// " R X:DTIME S:'$T X="N" Q:X'["Y"&(X'["y") S X="?",DIC=$S(XQDF:3.5,1:"^DIC(19,"),DIC(0)="Q" D ^DIC K DIC S XQDF=""
44 Q
45 ;
46OUT ;
47 K XQOP,XQFLD,XQI,XQISV,XQJ,XQJSV,XQDV,XQOD,XQTDV,XQNDV,XQTOD,XQNOD,XQDF,XQFL,XQFL2,XQD,XQDR,XQK,XQM,XQN,XQR,XQT
48 K DIC,DIK,DIE,DR,DA,DI,DISYS,DLAYGO,DQ,D0,D1,I,J,K,L,X,Y,XY,%,%Y,C,POP
49 Q
Note: See TracBrowser for help on using the repository browser.