XQ41 ;SEA/JLI - Diagram menus (continued) ;08/27/97 14:47
;;8.0;KERNEL;**46**;Jul 10, 1995
L G LL:'$D(^TMP($J,"XQM",XQL,L)) K X1,X2,X3 S Y=1,XQV=^(L) S:$D(^(L,.1)) X1=^(.1) S:$D(^(.2)) X2=^(.2) S:$D(^(.3)) X3=^(.3) I $D(^(1)) S XQV(L)=^(1)
E S:$P(XQV,U,5)'="M" XQT=L
S XQP=$P(XQV,U,1),XQP(L)=$E("-----",1,5-$L(XQP))_XQP_" ",X=$P(XQV,U,3)_" ["_$P(XQV,U,2)_"]" D T I $P(XQV,U,4)]"" S X="**UNAVAILABLE**" D T
G:XQ4<0 LL I $P(XQV,U,7)]"" S X="**LOCKED: "_$P(XQV,U,7)_"**" D T
I $P(XQV,U,17)]"" S X="**R-LOCK: "_$P(XQV,U,17)_"**" D T
S XQN=$O(^DIC(19,"B",$P(XQV,U,2),0)),XQX=""
I $D(^DIC(19,XQN,3.91)) S %XQI=0 F S %XQI=$O(^DIC(19,XQN,3.91,%XQI)) Q:%XQI'>0 S XQX=XQX_$P(^(%XQI,0),U,1)_$P(^(0),U,2)_" "
I XQX="" S XQX=$P(XQV,U,10) I XQX'="" S XQX=XQX_"MO-FR"
I XQX]"" S X="**PROHIBITED TIMES: "_XQX_"**" D T
K XQX,%XQI
I XQ4>0&$D(X3) S X="**HEADER: " D T S X=X3 D T
I XQ4>0&$D(X1) S X="**ENTRY ACTION: " D T S X=X1 D T
I XQ4>0&$D(X2) S X="**EXIT ACTION: " D T S X=X2 D T
LL S Y=0,L=L+1 G L:L'>M
Y S Y=Y+1,L=1 D:$Y+2>IOSL WAIT Q:XQFLAG=U W ! G WL:$O(Z(0))>0 S Z=XQT-1
B I L=M Q:$D(XQV(Z))!'Z S Z=Z-1,L=1 W !
D D S L=L+1 G B
D Q:L'<XQT!'$D(XQV(L)) W ?W+10*(L-1)+10 I Y=1 W "|" K:XQV(L)=XQL XQV(L) F X=1:1 G Q:X=W!'$D(Z(L+1)) W "-"
W "|" W:L<M ?W+4*L Q
WL I '$D(Z(L,Y)) D D G O
S XQV=Z(L,Y),XQP=XQP(L) K Z(L,Y) S:XQT'>L L=M I Y=1 F X=1:1 Q:W+10*(L-1)-1<$X W "-"
W:Y=1 ?W+10*(L-1),XQP W ?W+10*(L-1)+6,XQV
O S L=L+1 G Y:M<L,WL
;
T S D=""
W S Z=$P(X," ",1),X=$P(X," ",2,999) I $L(D)+$L(Z)>W,$L(D) S Z(L,Y)=D,D="",Y=Y+1
I $L(Z)>W S Z(L,Y)=$E(Z,1,W),Z=$E(Z,W+1,99) S:$E(Z,1)=" " Z=$E(Z,2,99) S Y=Y+1
S D=D_Z_" " G W:X]"" S Z(L,Y)=D,Y=Y+1 Q
;
X Q:'$D(XQB(L))&('$D(XQBN(L))) Q:'$D(XQB(L,XQBN(L))) S Y=$G(XQB(L,XQBN(L))) Q:'$D(XQB(L,XQBN(L))) S XQBN(L)=XQBN(L)+1 I '$D(^DIC(19,+Y,0)) G X
E Q:'$D(Y) S Z=^DIC(19,+Y,0) S:$P(Z,U,16) XI=$S('$D(^(3)):"",1:$P(^(3),U)),Z=$P(Z,U,1,15)_U_XI_U_$P(Z,U,17,99) S ^TMP($J,"XQM",XQL,L)=$P(Y,";",2)_U_Z,XQV=$P(Z,U,6) S:L>1 ^TMP($J,"XQM",XQV(L-1),L-1,1)=XQL
F XQI=15,20,26 I $D(^DIC(19,+Y,XQI))#2,^(XQI)'="" S ^TMP($J,"XQM",XQL,L,$S(XQI=26:.3,XQI=15:.2,1:.1))=^(XQI)
I $P(Z,U,4)'="M"!$D(^TMP($J,"XQ1",+Y))!$S(XQV]""&$D(XQDUZ):'$D(^XUSEC(XQV,XQDUZ)),1:0)!($P(Z,U,3)]"") S XQL=XQL+1 G X
S ^TMP($J,"XQ1",+Y)="",XQV(L)=XQL,L=L+1,X(L)="",(Y,XQDIC,XQDIC(L))=+Y S:M<L M=L
I $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)) S XQSAV=Y D ^XQSET S Y=XQSAV K XQSAV
K XQA S XQJ=-1 F S XQJ=$O(^XUTL("XQO",Y,U,XQJ)) Q:XQJ="" S XQA($P(^(XQJ),U,2))=XQJ
K XQB(L) S XQBN(L)=1,XQJ=+^XUTL("XQO",Y,0),XQBN1=0
F XQI=1:1:XQJ S XQN=^XUTL("XQO",Y,0,XQI) F XQP=0:1 S XQB=$P(XQN,U,8*XQP+2) Q:'$L($P(XQN,U,8*XQP+2,99)) I XQB'="",($D(XQA(XQB))) S XQBN1=XQBN1+1,XQB(L,XQBN1)=XQA(XQB)_";"_$P(XQN,U,8*XQP+1) K XQA(XQB)
K XQBN1
D X
Q:L=1 S L=L-1,XQDIC=XQDIC(L) G X
;
WAIT ;
I 1 S XQFLAG="" R:IOST["C-" !?26,"Press RETURN to continue, '^' to halt...",XQFLAG:DTIME S:'$T XQFLAG=U W @IOF
Q Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ41 3031 printed Nov 22, 2024@17:14:57 Page 2
XQ41 ;SEA/JLI - Diagram menus (continued) ;08/27/97 14:47
+1 ;;8.0;KERNEL;**46**;Jul 10, 1995
L if '$DATA(^TMP($JOB,"XQM",XQL,L))
GOTO LL
KILL X1,X2,X3
SET Y=1
SET XQV=^(L)
if $DATA(^(L,.1))
SET X1=^(.1)
if $DATA(^(.2))
SET X2=^(.2)
if $DATA(^(.3))
SET X3=^(.3)
IF $DATA(^(1))
SET XQV(L)=^(1)
+1 IF '$TEST
if $PIECE(XQV,U,5)'="M"
SET XQT=L
+2 SET XQP=$PIECE(XQV,U,1)
SET XQP(L)=$EXTRACT("-----",1,5-$LENGTH(XQP))_XQP_" "
SET X=$PIECE(XQV,U,3)_" ["_$PIECE(XQV,U,2)_"]"
DO T
IF $PIECE(XQV,U,4)]""
SET X="**UNAVAILABLE**"
DO T
+3 if XQ4<0
GOTO LL
IF $PIECE(XQV,U,7)]""
SET X="**LOCKED: "_$PIECE(XQV,U,7)_"**"
DO T
+4 IF $PIECE(XQV,U,17)]""
SET X="**R-LOCK: "_$PIECE(XQV,U,17)_"**"
DO T
+5 SET XQN=$ORDER(^DIC(19,"B",$PIECE(XQV,U,2),0))
SET XQX=""
+6 IF $DATA(^DIC(19,XQN,3.91))
SET %XQI=0
FOR
SET %XQI=$ORDER(^DIC(19,XQN,3.91,%XQI))
if %XQI'>0
QUIT
SET XQX=XQX_$PIECE(^(%XQI,0),U,1)_$PIECE(^(0),U,2)_" "
+7 IF XQX=""
SET XQX=$PIECE(XQV,U,10)
IF XQX'=""
SET XQX=XQX_"MO-FR"
+8 IF XQX]""
SET X="**PROHIBITED TIMES: "_XQX_"**"
DO T
+9 KILL XQX,%XQI
+10 IF XQ4>0&$DATA(X3)
SET X="**HEADER: "
DO T
SET X=X3
DO T
+11 IF XQ4>0&$DATA(X1)
SET X="**ENTRY ACTION: "
DO T
SET X=X1
DO T
+12 IF XQ4>0&$DATA(X2)
SET X="**EXIT ACTION: "
DO T
SET X=X2
DO T
LL SET Y=0
SET L=L+1
if L'>M
GOTO L
Y SET Y=Y+1
SET L=1
if $Y+2>IOSL
DO WAIT
if XQFLAG=U
QUIT
WRITE !
if $ORDER(Z(0))>0
GOTO WL
SET Z=XQT-1
B IF L=M
if $DATA(XQV(Z))!'Z
QUIT
SET Z=Z-1
SET L=1
WRITE !
+1 DO D
SET L=L+1
GOTO B
D if L'<XQT!'$DATA(XQV(L))
QUIT
WRITE ?W+10*(L-1)+10
IF Y=1
WRITE "|"
if XQV(L)=XQL
KILL XQV(L)
FOR X=1:1
if X=W!'$DATA(Z(L+1))
GOTO Q
WRITE "-"
+1 WRITE "|"
if L<M
WRITE ?W+4*L
QUIT
WL IF '$DATA(Z(L,Y))
DO D
GOTO O
+1 SET XQV=Z(L,Y)
SET XQP=XQP(L)
KILL Z(L,Y)
if XQT'>L
SET L=M
IF Y=1
FOR X=1:1
if W+10*(L-1)-1<$X
QUIT
WRITE "-"
+2 if Y=1
WRITE ?W+10*(L-1),XQP
WRITE ?W+10*(L-1)+6,XQV
O SET L=L+1
if M<L
GOTO Y
GOTO WL
+1 ;
T SET D=""
W SET Z=$PIECE(X," ",1)
SET X=$PIECE(X," ",2,999)
IF $LENGTH(D)+$LENGTH(Z)>W
IF $LENGTH(D)
SET Z(L,Y)=D
SET D=""
SET Y=Y+1
+1 IF $LENGTH(Z)>W
SET Z(L,Y)=$EXTRACT(Z,1,W)
SET Z=$EXTRACT(Z,W+1,99)
if $EXTRACT(Z,1)=" "
SET Z=$EXTRACT(Z,2,99)
SET Y=Y+1
+2 SET D=D_Z_" "
if X]""
GOTO W
SET Z(L,Y)=D
SET Y=Y+1
QUIT
+3 ;
X if '$DATA(XQB(L))&('$DATA(XQBN(L)))
QUIT
if '$DATA(XQB(L,XQBN(L)))
QUIT
SET Y=$GET(XQB(L,XQBN(L)))
if '$DATA(XQB(L,XQBN(L)))
QUIT
SET XQBN(L)=XQBN(L)+1
IF '$DATA(^DIC(19,+Y,0))
GOTO X
E if '$DATA(Y)
QUIT
SET Z=^DIC(19,+Y,0)
if $PIECE(Z,U,16)
SET XI=$SELECT('$DATA(^(3)):"",1:$PIECE(^(3),U))
SET Z=$PIECE(Z,U,1,15)_U_XI_U_$PIECE(Z,U,17,99)
SET ^TMP($JOB,"XQM",XQL,L)=$PIECE(Y,";",2)_U_Z
SET XQV=$PIECE(Z,U,6)
if L>1
SET ^TMP($JOB,"XQM",XQV(L-1),L-1,1)=XQL
+1 FOR XQI=15,20,26
IF $DATA(^DIC(19,+Y,XQI))#2
IF ^(XQI)'=""
SET ^TMP($JOB,"XQM",XQL,L,$SELECT(XQI=26:.3,XQI=15:.2,1:.1))=^(XQI)
+2 IF $PIECE(Z,U,4)'="M"!$DATA(^TMP($JOB,"XQ1",+Y))!$SELECT(XQV]""&$DATA(XQDUZ):'$DATA(^XUSEC(XQV,XQDUZ)),1:0)!($PIECE(Z,U,3)]"")
SET XQL=XQL+1
GOTO X
+3 SET ^TMP($JOB,"XQ1",+Y)=""
SET XQV(L)=XQL
SET L=L+1
SET X(L)=""
SET (Y,XQDIC,XQDIC(L))=+Y
if M<L
SET M=L
+4 IF $SELECT('$DATA(^XUTL("XQO",XQDIC,0)):1,'$DATA(^DIC(19,XQDIC,99)):1,1:^DIC(19,XQDIC,99)'=$PIECE(^XUTL("XQO",XQDIC,0),U,2))
SET XQSAV=Y
DO ^XQSET
SET Y=XQSAV
KILL XQSAV
+5 KILL XQA
SET XQJ=-1
FOR
SET XQJ=$ORDER(^XUTL("XQO",Y,U,XQJ))
if XQJ=""
QUIT
SET XQA($PIECE(^(XQJ),U,2))=XQJ
+6 KILL XQB(L)
SET XQBN(L)=1
SET XQJ=+^XUTL("XQO",Y,0)
SET XQBN1=0
+7 FOR XQI=1:1:XQJ
SET XQN=^XUTL("XQO",Y,0,XQI)
FOR XQP=0:1
SET XQB=$PIECE(XQN,U,8*XQP+2)
if '$LENGTH($PIECE(XQN,U,8*XQP+2,99))
QUIT
IF XQB'=""
IF ($DATA(XQA(XQB)))
SET XQBN1=XQBN1+1
SET XQB(L,XQBN1)=XQA(XQB)_";"_$PIECE(XQN,U,8*XQP+1)
KILL XQA(XQB)
+8 KILL XQBN1
+9 DO X
+10 if L=1
QUIT
SET L=L-1
SET XQDIC=XQDIC(L)
GOTO X
+11 ;
WAIT ;
+1 IF 1
SET XQFLAG=""
if IOST["C-"
READ !?26,"Press RETURN to continue, '^' to halt...",XQFLAG:DTIME
if '$TEST
SET XQFLAG=U
WRITE @IOF
Q QUIT
+1 ;
