XQ9 ; SEA/AMF,MJM - RESTRICT AVAILABILITY OF OPTIONS ;9/29/92 14:59 ;5/13/93 11:24 AM [ 04/02/2003 8:29 AM ]
;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
;;8.0;KERNEL;;Jul 10, 1995
INIT ;
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
S U="^" S:'$D(DTIME)#2 DTIME=60 S %ZIS="M" D:'$D(IOM) ^%ZIS K %ZIS
OP ;
W !!,$S($O(XQOP(0))>0:"Another ",1:"Select ") W "OPTION NAME: " R X:DTIME S:'$T X=U G:X[U OUT
I '$L(X) S XQI=$O(XQOP(0)) G:XQI="" OUT W ! G:($O(XQOP(XQI))="") ONEOPT G GETRS
I X["?" S XQH="XQRESTRICT-OPTION" W ! D:X="?" EN^XQH D:X="??" LSTOP D:X="???" LSTFIL G OP
S XQM=0 S:"-'"[$E(X,1) X=$E(X,2,999),XQM=1
S DIC=19,DIC(0)="MEZ" D ^DIC I Y<0 W " ??",*7 G OP
I XQM W $S($D(XQOP(+Y)):" Deleted",1:$C(7)_" ?? Option not on list") K XQOP(+Y) G OP
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)
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
S XQOP(+Y)=Y G OP
ONEOPT ;
S DA=$O(XQOP(0)),DIE=19,DR="2;3;3.01;3.8;3.91;3.95;3.96" D ^DIE
G OUT
;
GETRS ;Get data for each restriction field, check it, and build DR string
S XQI=0,XQDR=""
NEXT 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
I '$L(X) G NEXT
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
I X["@" S XQDR=XQDR_XQFLD(XQI)_"///@;" S XQFLD(XQI,"V")="(Delete current data from this field)" G NEXT
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
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
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
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
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
G NEXT
;
GOTRS ;Continue on in the next routine (^XQ91)
;
G ^XQ91
;
LSTOP ;List the options that have been selected thus far
I $O(XQOP(0))="" W !!,"You have not yet selected any options." Q
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)
Q
;
LSTFIL ;Show OPTION or DEVICE file
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=""
Q
;
OUT ;
K XQOP,XQFLD,XQI,XQISV,XQJ,XQJSV,XQDV,XQOD,XQTDV,XQNDV,XQTOD,XQNOD,XQDF,XQFL,XQFL2,XQD,XQDR,XQK,XQM,XQN,XQR,XQT
K DIC,DIK,DIE,DR,DA,DI,DISYS,DLAYGO,DQ,D0,D1,I,J,K,L,X,Y,XY,%,%Y,C,POP
Q
XQ9 ; SEA/AMF,MJM - RESTRICT AVAILABILITY OF OPTIONS ;9/29/92 14:59 ;5/13/93 11:24 AM [ 04/02/2003 8:29 AM ]
+1 ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
+2 ;;8.0;KERNEL;;Jul 10, 1995
INIT ;
+1 KILL XQOP,XQFLD,XQDV,XQOD
SET (XQTDV,XQTOD,XQDF)=0
SET XQOP(0)=0
SET XQJ=1
FOR XQI=2,3,3.8,3.91,3.95,3.96
SET XQFLD(XQJ)=XQI
SET XQFLD(XQJ,0)=^DD(19,XQI,0)
SET XQJ=XQJ+1
+2 SET U="^"
IF '$DATA(DTIME)#2
SET DTIME=60
SET %ZIS="M"
IF '$DATA(IOM)
DO ^%ZIS
KILL %ZIS
OP ;
+1 WRITE !!,$SELECT($ORDER(XQOP(0))>0:"Another ",1:"Select ")
WRITE "OPTION NAME: "
READ X:DTIME
IF '$TEST
SET X=U
IF X[U
GOTO OUT
+2 IF '$LENGTH(X)
SET XQI=$ORDER(XQOP(0))
IF XQI=""
GOTO OUT
WRITE !
IF ($ORDER(XQOP(XQI))="")
GOTO ONEOPT
GOTO GETRS
+3 IF X["?"
SET XQH="XQRESTRICT-OPTION"
WRITE !
IF X="?"
DO EN^XQH
IF X="??"
DO LSTOP
IF X="???"
DO LSTFIL
GOTO OP
+4 SET XQM=0
IF "-'"[$EXTRACT(X,1)
SET X=$EXTRACT(X,2,999)
SET XQM=1
+5 SET DIC=19
SET DIC(0)="MEZ"
DO ^DIC
IF Y<0
WRITE " ??",*7
GOTO OP
+6 IF XQM
WRITE $SELECT($DATA(XQOP(+Y)):" Deleted",1:$CHAR(7)_" ?? Option not on list")
KILL XQOP(+Y)
GOTO OP
+7 IF $DATA(^DIC(19,+Y,0))
SET XQK=^(0)
FOR XQI=1:1:5
SET XQJ=$PIECE(XQFLD(XQI,0),U,4)
SET XQJ=$PIECE(XQJ,";",2)
IF $LENGTH($PIECE(XQK,U,XQJ))
WRITE !?4,"CURRENT ",$PIECE(XQFLD(XQI,0),U,1),": ",$PIECE(XQK,U,XQJ)
+8 IF $DATA(^DIC(19,+Y,3.96))
SET K=$PIECE(^DIC(19,+Y,3.96,0),U,3)
SET XQJ=0
FOR XQI=1:1:K
IF $DATA(^DIC(19,+Y,3.96,XQI,0))
SET XQN=+^(0)
IF (XQJ=0)
WRITE !,?4,$PIECE(XQFLD(6,0),U,1),": "
IF (XQJ>0)
WRITE ", "
IF '(XQJ#6)
WRITE !,?22
WRITE $PIECE(^%ZIS(1,XQN,0),U,1)
SET XQJ=XQJ+1
+9 SET XQOP(+Y)=Y
GOTO OP
ONEOPT ;
+1 SET DA=$ORDER(XQOP(0))
SET DIE=19
SET DR="2;3;3.01;3.8;3.91;3.95;3.96"
DO ^DIE
+2 GOTO OUT
+3 ;
GETRS ;Get data for each restriction field, check it, and build DR string
+1 SET XQI=0
SET XQDR=""
NEXT SET XQI=XQI+1
SET XQN=+XQFLD(XQI)
IF (XQI=6)
GOTO GOTRS
WRITE !,$PIECE(XQFLD(XQI,0),U,1)_" or '@' to delete: "
READ X:DTIME
IF '$TEST
SET X=U
IF X[U
GOTO OUT
+1 IF '$LENGTH(X)
GOTO NEXT
+2 IF X["?"
SET XQH="XQRESTRICT"_$SELECT(XQN=2:"-OOO",XQN=3:"-LOCK",XQN=3.8:"-PRIORITY",XQN=3.91:"-TIMES",XQN=3.95:"-RESDEV",1:"")
WRITE !
DO EN^XQH
WRITE !
SET XQI=XQI-1
GOTO NEXT
+3 IF X["@"
SET XQDR=XQDR_XQFLD(XQI)_"///@;"
SET XQFLD(XQI,"V")="(Delete current data from this field)"
GOTO NEXT
+4 IF XQN=2
IF $LENGTH(X)>80!($LENGTH(X)<1)
KILL X
IF '$DATA(X)#2
WRITE !,$PIECE(XQFLD(XQI,0),U,1)," must be free text, 1 to 80 characters in length."
IF '$DATA(X)#2
SET XQI=XQI-1
IF '$DATA(X)#2
GOTO NEXT
SET XQDR=XQDR_XQFLD(XQI)_"///"_X_";"
SET XQFLD(XQI,"V")=X
GOTO NEXT
+5 IF XQN=3
IF $LENGTH(X)>30!($LENGTH(X)<1)!('$DATA(^DIC(19.1,"B",X)))
KILL X
IF '$DATA(X)#2
WRITE !,$PIECE(XQFLD(XQI,0),U,1)," (1 to 30 characters) must match exactly an existing key."
IF '$DATA(X)#2
SET XQI=XQI-1
IF '$DATA(X)#2
GOTO NEXT
SET XQDR=XQDR_XQN_"///"_X_";"
SET XQFLD(XQI,"V")=X
GOTO NEXT
+6 IF XQN=3.8
IF +X'=X!(X>10)!(X<1)
KILL X
IF '$DATA(X)#2
WRITE !,$PIECE(XQFLD(XQI,0),U,1)," must be a single number between 1 and 10."
IF '$DATA(X)#2
SET XQI=XQI-1
IF '$DATA(X)
GOTO NEXT
SET XQDR=XQDR_XQN_"///"_X_";"
SET XQFLD(XQI,"V")=X
GOTO NEXT
+7 IF XQN=3.91
IF $LENGTH(X)>9!($LENGTH(X)<9)!(X'?4N1"-"4N)
KILL X
IF '$DATA(X)#2
WRITE !,$PIECE(XQFLD(XQI,0),U,1)," must be 9 characters in the form '0800-1630'"
IF '$DATA(X)#2
SET XQI=XQI-1
IF '$DATA(X)#2
GOTO NEXT
SET XQDR=XQDR_XQN_"///"_X_";"
SET XQFLD(XQI,"V")=X
GOTO NEXT
+8 IF XQN=3.95
IF X'["Y"&(X'["y")&(X'["N")&(X'["n")
KILL X
IF '$DATA(X)#2
WRITE !,$PIECE(XQFLD(XQI,0),U,1)," must be 'yes' or 'no' (Y or N)"
IF '$DATA(X)#2
SET XQI=XQI-1
IF '$DATA(X)#2
GOTO NEXT
SET XQDR=XQDR_XQN_"///"_X_";"
SET XQFLD(XQI,"V")=X
+9 GOTO NEXT
+10 ;
GOTRS ;Continue on in the next routine (^XQ91)
+1 ;
+2 GOTO ^XQ91
+3 ;
LSTOP ;List the options that have been selected thus far
+1 IF $ORDER(XQOP(0))=""
WRITE !!,"You have not yet selected any options."
QUIT
+2 WRITE !!,"You've selected the following options: ",!
SET XQJ=0
SET XQI=IOM\15
FOR XQK=0:1
SET XQJ=$ORDER(XQOP(XQJ))
IF XQJ=""
QUIT
IF '(XQK#XQI)
WRITE !
WRITE ?(XQK#XQI*15),$PIECE(^DIC(19,XQJ,0),U,1)
+3 QUIT
+4 ;
LSTFIL ;Show OPTION or DEVICE file
+1 WRITE !,"Do you want to see the ",$SELECT(XQDF:"DEVICE",1:"OPTION")," file? NO// "
READ X:DTIME
IF '$TEST
SET X="N"
IF X'["Y"&(X'["y")
QUIT
SET X="?"
SET DIC=$SELECT(XQDF:3.5,1:"^DIC(19,")
SET DIC(0)="Q"
DO ^DIC
KILL DIC
SET XQDF=""
+2 QUIT
+3 ;
OUT ;
+1 KILL XQOP,XQFLD,XQI,XQISV,XQJ,XQJSV,XQDV,XQOD,XQTDV,XQNDV,XQTOD,XQNOD,XQDF,XQFL,XQFL2,XQD,XQDR,XQK,XQM,XQN,XQR,XQT
+2 KILL DIC,DIK,DIE,DR,DA,DI,DISYS,DLAYGO,DQ,D0,D1,I,J,K,L,X,Y,XY,%,%Y,C,POP
+3 QUIT
