XQT ;SEA/MJM - Menu template loader ;01/09/2001 13:32
;;8.0;KERNEL;**20,47,46,37,155**;Jul 10, 1995
;
;Entry from XQ
;
S XQTSV=XQY_U_XQDIC_U_XQY0,(XQU,XQUR)=$P(XQUR,"[",2)
I XQUR["?" D:XQUR["??" SHO^XQT4 W !!?5,"See 'Menu Templates' options for more information." G OUT
I XQUR=" ",$D(^DISV(DUZ,"XQT")) S XQUR=^("XQT"),XQU=""
D FIND G:XQK OUT D LOD I XQY<0 G OUT
S ^XUTL("XQ",$J,"S")=XQTSV,^DISV(DUZ,"XQT")=XQUR W:XQU'=-1 $E(XQUR,$L(XQU)+1,99)
K %,XQ,XQBLD,XQFL,XQI,XQJ,XQK,XQL,XQM,XQMA,XQMN,XQN,XQNO1,XQSIB,XQTSV,XQTL,XQTU,XQU
G ^XQT1 ; Template is loaded and checked
;
FIND ;Find the template requested
S XQK=0,XQN="",XQJ=1,(XQM,XQMA)=^XUTL("XQ",$J,"XQM")
I XQUR'?.ANP W *7," ??" S XQK=1 Q
S XQX=XQUR I XQUR'?.PUN S XQX=$$UP^XLFSTR(XQX) ;F XQI=1:1 Q:XQX?.NUP S XQN=$A(XQX,XQI) I XQN<123,XQN>96 S XQX=$E(XQX,1,XQI-1)_$C(XQN-32)_$E(XQX,XQI+1,255)
S XQUR=XQX
F XQI=0:0 S XQN=$O(^VA(200,DUZ,19.8,"B",XQN)) Q:XQN="" S:XQUR=$E(XQN,1,$L(XQUR)) XQ(XQJ)=XQN,XQJ=XQJ+1
I XQJ=1 W " ??",*7 S XQK=1 Q
I XQJ=2 S XQUR=XQ(1) Q
I XQJ>2 S XQK=0 D CHS
Q
;
LOD ;Load the template into the ^XUTL("XQT").
;I $D(^XUTL("XQT",$J,XQUR,0))#2 S ^("T")=1 Q
S XQN=$O(^VA(200,DUZ,19.8,"B",XQUR,0)) I XQN="" W " ??",*7 G OUT
I '$D(ZTQUEUED) W @IOF,?33,"Loading ",XQUR,"...",!
S ^XUTL("XQT",$J,XQUR,0)=DT,(XQEA,XQFL,XQTU)=0
S XQJ=$P(^VA(200,DUZ,19.8,XQN,1,0),U,3),XQY=XQM,XQL=1
D NO1^XQT5 Q:XQY'>0
F XQI=1:1:XQJ Q:XQY=-1 S XQTL=^VA(200,DUZ,19.8,XQN,1,XQI,0) F XQK=1:1 D:'XQFL RPT S XQ=$P(XQTL,U,XQK) Q:XQ="" S XQY=+XQ,XQDIC=$P(XQ,",",2),XQEA=$P(XQ,",",3) D CHK S XQMA=XQY Q:XQY=-1 D OK Q:XQY=-1
I XQY=-1 K ^XUTL("XQT",$J,XQUR)
Q
;
SET ;Build the ^XUTL("XQO",+XQDIC [ or "U"_DUZ]) nodes if need be
L +^XUTL("XQO",XQDIC):5 D:$S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^DIC(19,XQDIC,99)):1,1:^DIC(19,XQDIC,99)'=$P(^XUTL("XQO",XQDIC,0),U,2)) ^XQSET L -^XUTL("XQO",XQDIC)
Q
;
SETU ;Build the ^XUTL("XQO","U"_DUZ) nodes if need be
D:$S('$D(^XUTL("XQO","U"_DUZ)):1,'$D(^VA(200,DUZ,203.1)):1,1:^VA(200,DUZ,203.1)'=$P(^XUTL("XQO","U"_DUZ,0),U,2)) ^XQSET
Q
;
CHK ;Make sure it's OK to use this option
I $D(^XUTL("XQO","P"_XQM,U,XQY))!(XQM=XQY) Q
I $D(^XUTL("XQO","PXU",U,XQY)) Q
I '$D(XQBLD) N XQDIC S XQDIC="U"_DUZ D SETU S XQBLD=""
I $D(^XUTL("XQO","U"_DUZ,U,+XQY)) Q
S (%,XQTU)=0 F XQII=1:1 Q:XQTU S %=$O(^VA(200,DUZ,203,%,0)) Q:%'>0 S:$D(^XUTL("XQO","P"_%,U,XQY)) XQTU=1
Q:XQTU=1
D SET Q:$D(^XUTL("XQO",XQDIC,U,XQY))
I '$D(^DIC(19,XQY,0))#2 W !!,"The Option File has been changed. This template will no longer work.",!?5,"'",XQUR,"' should be deleated and/or rebuilt." S XQY=-1 Q
W !!,"Sorry, the option '",$P(^DIC(19,XQY,0),U,2),"'",!,?5,"is no longer available to you." S XQY=-1
Q
;
OK ;See if it's locked, etc.
I XQY=XQDIC D S1^XQCHK I 1
E L +^XUTL("XQO",XQDIC):5 D:$S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^DIC(19,XQDIC,99)):1,1:^DIC(19,XQDIC,99)'=$P(^XUTL("XQO",XQDIC,0),U,2)) ^XQSET L -^XUTL("XQO",XQDIC)
S %=$G(^XUTL("XQO",XQDIC,U,+XQY)) I %="",XQY'=XQDIC W !!,"Because of changes to the Option File an option is no longer available." S XQY=-1 Q
S XQY0=$S(XQY=XQDIC:XQY0,1:$P(%,U,2,99))
I $L($P(XQY0,U,3)) W !!,"Option '",$P(XQY0,U,2),"'",!,?5,"is out of order. The message is: ",$P(XQY0,U,3) S XQY=-1 Q
I $L($P(XQY0,U,6)),'$D(^XUSEC($P(XQY0,U,6),DUZ)) W !!,"Option '",$P(XQY0,U,2),!,?5,"is locked. You don't own the key." S XQY=-1 Q
I $L($P(XQY0,U,9)) D ^XQDATE S X=% D ^XQ92 I X="" W !!,"Option '",$P(XQY0,U,2),"'",!,?5,"is not permitted to run right now. Sorry." S XQY=-1 Q
I $P(XQY0,U,10)["y",'$D(^DIC(19,XQY,3.96,"B",ION)) W !!,"Option '",$P(XQY0,U,2),!,?5,"is restricted to run only only certain terminals. You're not on one. Sorry." S XQY=-1 Q
S ^XUTL("XQT",$J,XQUR,XQL)=XQY_U_XQDIC_U_XQY0
I $P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) S ^XUTL("XQT",$J,XQUR,XQL,"H")=^DIC(19,XQY,26)
I $P(XQY0,U,14),XQEA["E",$D(^DIC(19,XQY,20)),$L(^(20)) S ^XUTL("XQT",$J,XQUR,XQL,"E")=^DIC(19,XQY,20)
I $P(XQY0,U,15),XQEA["X",$D(^DIC(19,XQY,15)),$L(^(15)) S ^XUTL("XQT",$J,XQUR,XQL,"X")=^DIC(19,XQY,15)
S XQL=XQL+1
Q
;
CHS ;Choose the template from those that match
S XQK=1,XQU=-1 W !!,"Chose by number from: ",! F XQI=1:1:XQJ-1 W !,?5,XQI,". ",XQ(XQI)
W !!,"Enter a number between 1 and ",XQJ-1," or '^' to quit: " R %:DTIME S:'$T %=U S:%="" %=U Q:%=U G:(%'?.N)!(%>(XQJ-1))!(%="")!(%<1) CHS S XQUR=XQ(%),XQK=0
Q
;
RPT ;Set the 'repeat' flag in ^XUTL and strip it off list of options
S XQFL=1,^XUTL("XQT",$J,XQUR,"RPT")=$P(XQTL,U,1),XQTL=$P(XQTL,U,2,99)
Q
OUT ;
S XQY=+XQTSV,XQDIC=$P(XQTSV,U,2),XQY0=$P(XQTSV,U,3,99)
K %,XQ,XQBLD,XQEX,XQI,XQJ,XQK,XQL,XQM,XQN,XQN1,XQTSV,XQTU
G NOFIND^XQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQT 4710 printed Dec 13, 2024@02:06:48 Page 2
XQT ;SEA/MJM - Menu template loader ;01/09/2001 13:32
+1 ;;8.0;KERNEL;**20,47,46,37,155**;Jul 10, 1995
+2 ;
+3 ;Entry from XQ
+4 ;
+5 SET XQTSV=XQY_U_XQDIC_U_XQY0
SET (XQU,XQUR)=$PIECE(XQUR,"[",2)
+6 IF XQUR["?"
if XQUR["??"
DO SHO^XQT4
WRITE !!?5,"See 'Menu Templates' options for more information."
GOTO OUT
+7 IF XQUR=" "
IF $DATA(^DISV(DUZ,"XQT"))
SET XQUR=^("XQT")
SET XQU=""
+8 DO FIND
if XQK
GOTO OUT
DO LOD
IF XQY<0
GOTO OUT
+9 SET ^XUTL("XQ",$JOB,"S")=XQTSV
SET ^DISV(DUZ,"XQT")=XQUR
if XQU'=-1
WRITE $EXTRACT(XQUR,$LENGTH(XQU)+1,99)
+10 KILL %,XQ,XQBLD,XQFL,XQI,XQJ,XQK,XQL,XQM,XQMA,XQMN,XQN,XQNO1,XQSIB,XQTSV,XQTL,XQTU,XQU
+11 ; Template is loaded and checked
GOTO ^XQT1
+12 ;
FIND ;Find the template requested
+1 SET XQK=0
SET XQN=""
SET XQJ=1
SET (XQM,XQMA)=^XUTL("XQ",$JOB,"XQM")
+2 IF XQUR'?.ANP
WRITE *7," ??"
SET XQK=1
QUIT
+3 ;F XQI=1:1 Q:XQX?.NUP S XQN=$A(XQX,XQI) I XQN<123,XQN>96 S XQX=$E(XQX,1,XQI-1)_$C(XQN-32)_$E(XQX,XQI+1,255)
SET XQX=XQUR
IF XQUR'?.PUN
SET XQX=$$UP^XLFSTR(XQX)
+4 SET XQUR=XQX
+5 FOR XQI=0:0
SET XQN=$ORDER(^VA(200,DUZ,19.8,"B",XQN))
if XQN=""
QUIT
if XQUR=$EXTRACT(XQN,1,$LENGTH(XQUR))
SET XQ(XQJ)=XQN
SET XQJ=XQJ+1
+6 IF XQJ=1
WRITE " ??",*7
SET XQK=1
QUIT
+7 IF XQJ=2
SET XQUR=XQ(1)
QUIT
+8 IF XQJ>2
SET XQK=0
DO CHS
+9 QUIT
+10 ;
LOD ;Load the template into the ^XUTL("XQT").
+1 ;I $D(^XUTL("XQT",$J,XQUR,0))#2 S ^("T")=1 Q
+2 SET XQN=$ORDER(^VA(200,DUZ,19.8,"B",XQUR,0))
IF XQN=""
WRITE " ??",*7
GOTO OUT
+3 IF '$DATA(ZTQUEUED)
WRITE @IOF,?33,"Loading ",XQUR,"...",!
+4 SET ^XUTL("XQT",$JOB,XQUR,0)=DT
SET (XQEA,XQFL,XQTU)=0
+5 SET XQJ=$PIECE(^VA(200,DUZ,19.8,XQN,1,0),U,3)
SET XQY=XQM
SET XQL=1
+6 DO NO1^XQT5
if XQY'>0
QUIT
+7 FOR XQI=1:1:XQJ
if XQY=-1
QUIT
SET XQTL=^VA(200,DUZ,19.8,XQN,1,XQI,0)
FOR XQK=1:1
if 'XQFL
DO RPT
SET XQ=$PIECE(XQTL,U,XQK)
if XQ=""
QUIT
SET XQY=+XQ
SET XQDIC=$PIECE(XQ,",",2)
SET XQEA=$PIECE(XQ,",",3)
DO CHK
SET XQMA=XQY
if XQY=-1
QUIT
DO OK
if XQY=-1
QUIT
+8 IF XQY=-1
KILL ^XUTL("XQT",$JOB,XQUR)
+9 QUIT
+10 ;
SET ;Build the ^XUTL("XQO",+XQDIC [ or "U"_DUZ]) nodes if need be
+1 LOCK +^XUTL("XQO",XQDIC):5
if $SELECT('$DATA(^XUTL("XQO",XQDIC,0))
DO ^XQSET
LOCK -^XUTL("XQO",XQDIC)
+2 QUIT
+3 ;
SETU ;Build the ^XUTL("XQO","U"_DUZ) nodes if need be
+1 if $SELECT('$DATA(^XUTL("XQO","U"_DUZ))
DO ^XQSET
+2 QUIT
+3 ;
CHK ;Make sure it's OK to use this option
+1 IF $DATA(^XUTL("XQO","P"_XQM,U,XQY))!(XQM=XQY)
QUIT
+2 IF $DATA(^XUTL("XQO","PXU",U,XQY))
QUIT
+3 IF '$DATA(XQBLD)
NEW XQDIC
SET XQDIC="U"_DUZ
DO SETU
SET XQBLD=""
+4 IF $DATA(^XUTL("XQO","U"_DUZ,U,+XQY))
QUIT
+5 SET (%,XQTU)=0
FOR XQII=1:1
if XQTU
QUIT
SET %=$ORDER(^VA(200,DUZ,203,%,0))
if %'>0
QUIT
if $DATA(^XUTL("XQO","P"_%,U,XQY))
SET XQTU=1
+6 if XQTU=1
QUIT
+7 DO SET
if $DATA(^XUTL("XQO",XQDIC,U,XQY))
QUIT
+8 IF '$DATA(^DIC(19,XQY,0))#2
WRITE !!,"The Option File has been changed. This template will no longer work.",!?5,"'",XQUR,"' should be deleated and/or rebuilt."
SET XQY=-1
QUIT
+9 WRITE !!,"Sorry, the option '",$PIECE(^DIC(19,XQY,0),U,2),"'",!,?5,"is no longer available to you."
SET XQY=-1
+10 QUIT
+11 ;
OK ;See if it's locked, etc.
+1 IF XQY=XQDIC
DO S1^XQCHK
IF 1
+2 IF '$TEST
LOCK +^XUTL("XQO",XQDIC):5
if $SELECT('$DATA(^XUTL("XQO",XQDIC,0))
DO ^XQSET
LOCK -^XUTL("XQO",XQDIC)
+3 SET %=$GET(^XUTL("XQO",XQDIC,U,+XQY))
IF %=""
IF XQY'=XQDIC
WRITE !!,"Because of changes to the Option File an option is no longer available."
SET XQY=-1
QUIT
+4 SET XQY0=$SELECT(XQY=XQDIC:XQY0,1:$PIECE(%,U,2,99))
+5 IF $LENGTH($PIECE(XQY0,U,3))
WRITE !!,"Option '",$PIECE(XQY0,U,2),"'",!,?5,"is out of order. The message is: ",$PIECE(XQY0,U,3)
SET XQY=-1
QUIT
+6 IF $LENGTH($PIECE(XQY0,U,6))
IF '$DATA(^XUSEC($PIECE(XQY0,U,6),DUZ))
WRITE !!,"Option '",$PIECE(XQY0,U,2),!,?5,"is locked. You don't own the key."
SET XQY=-1
QUIT
+7 IF $LENGTH($PIECE(XQY0,U,9))
DO ^XQDATE
SET X=%
DO ^XQ92
IF X=""
WRITE !!,"Option '",$PIECE(XQY0,U,2),"'",!,?5,"is not permitted to run right now. Sorry."
SET XQY=-1
QUIT
+8 IF $PIECE(XQY0,U,10)["y"
IF '$DATA(^DIC(19,XQY,3.96,"B",ION))
WRITE !!,"Option '",$PIECE(XQY0,U,2),!,?5,"is restricted to run only only certain terminals. You're not on one. Sorry."
SET XQY=-1
QUIT
+9 SET ^XUTL("XQT",$JOB,XQUR,XQL)=XQY_U_XQDIC_U_XQY0
+10 IF $PIECE(XQY0,U,17)
IF $DATA(^DIC(19,XQY,26))
IF $LENGTH(^(26))
SET ^XUTL("XQT",$JOB,XQUR,XQL,"H")=^DIC(19,XQY,26)
+11 IF $PIECE(XQY0,U,14)
IF XQEA["E"
IF $DATA(^DIC(19,XQY,20))
IF $LENGTH(^(20))
SET ^XUTL("XQT",$JOB,XQUR,XQL,"E")=^DIC(19,XQY,20)
+12 IF $PIECE(XQY0,U,15)
IF XQEA["X"
IF $DATA(^DIC(19,XQY,15))
IF $LENGTH(^(15))
SET ^XUTL("XQT",$JOB,XQUR,XQL,"X")=^DIC(19,XQY,15)
+13 SET XQL=XQL+1
+14 QUIT
+15 ;
CHS ;Choose the template from those that match
+1 SET XQK=1
SET XQU=-1
WRITE !!,"Chose by number from: ",!
FOR XQI=1:1:XQJ-1
WRITE !,?5,XQI,". ",XQ(XQI)
+2 WRITE !!,"Enter a number between 1 and ",XQJ-1," or '^' to quit: "
READ %:DTIME
if '$TEST
SET %=U
if %=""
SET %=U
if %=U
QUIT
if (%'?.N)!(%>(XQJ-1))!(%="")!(%<1)
GOTO CHS
SET XQUR=XQ(%)
SET XQK=0
+3 QUIT
+4 ;
RPT ;Set the 'repeat' flag in ^XUTL and strip it off list of options
+1 SET XQFL=1
SET ^XUTL("XQT",$JOB,XQUR,"RPT")=$PIECE(XQTL,U,1)
SET XQTL=$PIECE(XQTL,U,2,99)
+2 QUIT
OUT ;
+1 SET XQY=+XQTSV
SET XQDIC=$PIECE(XQTSV,U,2)
SET XQY0=$PIECE(XQTSV,U,3,99)
+2 KILL %,XQ,XQBLD,XQEX,XQI,XQJ,XQK,XQL,XQM,XQN,XQN1,XQTSV,XQTU
+3 GOTO NOFIND^XQ
+4 QUIT
