- 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
