- XQ8 ;SEA/AMF,LUKE - Build menu trees ;06/06/2002 10:41 [ 07/29/2004 9:01 AM ]
- ;;8.0;KERNEL;**81,89,116,157**;Jul 10, 1995
- ;
- Q ;You can't start here.
- TIME ;See if there are prohibited times for this option
- S %XQI=$P(^DIC(19,Y,0),U,9) I $L(%XQI)>2 S XQP(L)=%XQI_"MO-FR"
- I $D(^DIC(19,Y,3.91)) S %XQI=0 F S %XQI=$O(^DIC(19,Y,3.91,%XQI)) Q:%XQI'>0 S XQP(L)=$S($D(XQP(L)):XQP(L)_";",1:"")_$P(^(%XQI,0),U,1)_$P(^(0),U,2)
- K %XQI I '$D(XQP(L)),$L($P(Y(0),U,9)) S XQP(L)=$P(Y(0),U,9)
- Q
- UP S X=$$UP^XLFSTR(X) ;F Z=1:1 Q:X?.NUP S W=$A(X,Z) I W<123,W>96 S X=$E(X,1,Z-1)_$C(W-32)_$E(X,Z+1,255)
- Q
- CHK ;Called from XQ81+107
- S XQRE=$D(^XUTL("XQO",XQDIC,"^BUILD")) I XQRE,($P($H,",",2)-^("^BUILD")>1800)!(^("^BUILD")>$P($H,",",2)) K ^("^BUILD") S XQRE=0
- Q
- PMO ;Called from XQ71+21
- D CHK W !,$S(XQRE:"I'M REBUILDING",1:"I NEED TO REBUILD")," MENUS .... QUICK ACCESS IS TEMPORARILY DISABLED" W:$D(XQMMJ) !!,"Please proceed to '",$E(XQMMJ,2,99),"'" K XQMMJ,XQMM I XQRE K XQRE Q
- Q
- ;
- PM1 ;Enter here to build a single menu called by XQ83
- S XQPM1=""
- S:XQDIC'="PXU" XQXUF=""
- ;
- PM2 ;Enter here to rebuild a single menu Called by RD3+10^XQ81
- ;$D(XQFG1) causes it rebuild in real time otherwise it is queued
- D:$D(XQCON) CHK S:'$D(XQRE) XQRE=0 Q:XQRE
- K ^TMP("XQO",$J,XQDIC) S ^XUTL("XQO",XQDIC,"^BUILD")=$P($H,",",2) G:$D(XQFG1) REBLD
- ;
- S ZTIO="",ZTRTN="REBLD^XQ8",ZTDTH=$H
- S ZTSAVE("XQDIC")="",ZTSAVE("XQPM2")=""
- S ZTDESC="Rebuild The Single Menu "_XQDIC D ^%ZTLOAD Q
- ;
- REBLD K XQFG1 S U="^",UU="^^" ;Taskman entry
- S:'$D(XQDATE) XQDATE=$H
- I XQDIC'="PXU" S Y=+$P(XQDIC,"P",2) Q:Y'>0 Q:'$D(^DIC(19,Y,0))
- I '$D(XQXUF) K ^TMP("XQO",$J,"PXU") S XQSAV=XQDIC S XQDIC="PXU",Y=$O(^DIC(19,"B","XUCOMMAND",0)) S:Y>0 %="",(L,X(0))=0,(XQPX,XQD)=Y D:Y>0 TREE1,PMOK S XQDIC=XQSAV,XQXUF=1,^TMP("XQO",$J,"PXU",0)=XQDATE
- S Y=$P(XQDIC,"P",2) G:Y'>0!'$D(^DIC(19,+Y,0)) PMOKA I Y>0,$D(^DIC(19,Y,0)),$P(^(0),U,4)="M" D PMOK S %="",(L,X(0))=0,XQD=Y D TREE1
- S:$D(^DIC(19,$E(XQDIC,2,99),0)) ^(99.1)=XQDATE S ^TMP("XQO",$J,XQDIC,0)=XQDATE
- S Y=+$P(XQDIC,"P",2)
- I Y>0 S (XQD,%)=^DIC(19,Y,0),L=1,XQP(L)="" D TIME S ^TMP("XQO",$J,XQDIC,U,Y)=U_$P(%,U,1,2)_U_$S(($P(%,U,3)]""):1,1:"")_U_$P(%,U,4)_UU_$P(%,U,6,8)_U_XQP(L)_U_$P(%,U,10,99)
- I Y>0,'$D(^DIC(19,Y,"U")) S XQFL=0 S:$D(X)#2 XQSAVE=X,XQFL=1 S X=$E($P(^DIC(19,+Y,0),U,2),1,30) D UP S ^("U")=X S:XQFL X=XQSAVE
- I Y>0 S ^TMP("XQO",$J,XQDIC,^DIC(19,Y,"U")_U)=Y_"^0"
- PMOKA K ^XUTL("XQO",XQDIC,"^BUILD") I '$D(XQFG),$D(ZTSK) K ^%ZTSK(ZTSK)
- PMOK K %,XQA,XQD,XQE,XQF,XQFL,XQP,XQR,XQRE,XQSAVE
- ;
- I $D(XQPM1) D
- .;A single menu is being built
- .D MERGET^XQ81
- .D MERGEX^XQ81
- .K ^TMP($J),^TMP("XQO",$J)
- .Q
- K XQPM1
- I $D(ZTQUEUED) S ZTREQ="@"
- Q
- ;
- TREE ;
- S X(L)=$O(^DIC(19,XQD,10,X(L))) Q:X(L)'>0 S Y=^(X(L),0),%=$P(Y,U,2),Y=+Y G:$D(XQR(Y))!'$D(^DIC(19,Y,0)) TREE S XQR(Y)="" I $D(XQFG),'$D(XQNTREE) W:'(Y#5) "."
- TREE1 S Y(0)=^DIC(19,Y,0),X=$S($D(^("U")):^("U"),1:"") I X="" S X=$E($P(Y(0),U,2),1,30) D UP S ^("U")=X
- S Y(1)=X S:'$L($P(Y(0),U,5)) $P(Y(0),U,5)=0
- G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=Y S:$L($P(Y(0),U,10)) XQE(L)=$P(Y(0),U,10)
- S:$P(Y(0),U,16) XQF(L)=$P(^DIC(19,Y,3),U) I $D(XQF(L)) K:XQF(L)="" XQF(L)
- D TIME,PMOSET S L=L+1,X(L)=0,(XQD,XQD(L))=Y D TREE
- Q:L<2 K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQP(L),XQE(L),XQF(L) S XQD=XQD(L) G TREE
- ;
- PMOSET ;
- S K=0,X=$E(Y(1),1,27) I $L(X) S X=X_U D:$D(^TMP("XQO",$J,XQDIC,X))!$D(^(X_"1")) PMO3 S:L&'K ^TMP("XQO",$J,XQDIC,X)=Y_"^1"
- I $D(%),$L(%) S X=%,K=0 D UP Q:'$L(X) S X=X_U D:$D(^TMP("XQO",$J,XQDIC,X))!$D(^(X_"1")) PMO3 S:L&'K ^TMP("XQO",$J,XQDIC,X)=Y_"^0"
- S (XQA,XQK,XQP,XQE,XQF)="" F D="XQA","XQK","XQP","XQE","XQF" F I=1:1:L I $D(@(D_"(I)")) S @D=@D_@(D_"(I)")_","
- I '$D(^TMP("XQO",$J,XQDIC,"^",Y)) S ^(Y)=U_$P(Y(0),U,1,2)_U_$S(($P(Y(0),U,3)]""):1,1:"")_U_$P(Y(0),U,4)_U_XQA_U_XQK_U_$P(Y(0),U,7,8)_U_XQP_U_XQE_U_$P(Y(0),U,11,15)_U_XQF_U_$P(Y(0),U,17,99) Q
- S %=$S('$D(^TMP("XQO",$J,XQDIC,"^",Y,0)):1,1:^(0)+1),^(0)=%,^(0,%)=XQA_U_XQK_U_XQP_U_XQE_U_XQF
- Q
- PMO3 ;
- S D=X,K=$S($D(^TMP("XQO",$J,XQDIC,X)):(Y=+^(X)),1:0) F S V=$O(^TMP("XQO",$J,XQDIC,D)) Q:K!($P(V,U,1)'=$P(X,U,1)) S D=V S:Y=+^(V) K=1
- I 'K S I=$P(D,U,2) S:'$L(I) I=0 I I=0 S ^(X_"1")=^TMP("XQO",$J,XQDIC,X) K ^(X) S I=1
- I 'K S X=X_(I+1)
- Q
- ;BUILD moved to XQ81
- Q
- XQ8 ;SEA/AMF,LUKE - Build menu trees ;06/06/2002 10:41 [ 07/29/2004 9:01 AM ]
- +1 ;;8.0;KERNEL;**81,89,116,157**;Jul 10, 1995
- +2 ;
- +3 ;You can't start here.
- QUIT
- TIME ;See if there are prohibited times for this option
- +1 SET %XQI=$PIECE(^DIC(19,Y,0),U,9)
- IF $LENGTH(%XQI)>2
- SET XQP(L)=%XQI_"MO-FR"
- +2 IF $DATA(^DIC(19,Y,3.91))
- SET %XQI=0
- FOR
- SET %XQI=$ORDER(^DIC(19,Y,3.91,%XQI))
- IF %XQI'>0
- QUIT
- SET XQP(L)=$SELECT($DATA(XQP(L)):XQP(L)_";",1:"")_$PIECE(^(%XQI,0),U,1)_$PIECE(^(0),U,2)
- +3 KILL %XQI
- IF '$DATA(XQP(L))
- IF $LENGTH($PIECE(Y(0),U,9))
- SET XQP(L)=$PIECE(Y(0),U,9)
- +4 QUIT
- UP ;F Z=1:1 Q:X?.NUP S W=$A(X,Z) I W<123,W>96 S X=$E(X,1,Z-1)_$C(W-32)_$E(X,Z+1,255)
- SET X=$$UP^XLFSTR(X)
- +1 QUIT
- CHK ;Called from XQ81+107
- +1 SET XQRE=$DATA(^XUTL("XQO",XQDIC,"^BUILD"))
- IF XQRE
- IF ($PIECE($HOROLOG,",",2)-^("^BUILD")>1800)!(^("^BUILD")>$PIECE($HOROLOG,",",2))
- KILL ^("^BUILD")
- SET XQRE=0
- +2 QUIT
- PMO ;Called from XQ71+21
- +1 DO CHK
- WRITE !,$SELECT(XQRE:"I'M REBUILDING",1:"I NEED TO REBUILD")," MENUS .... QUICK ACCESS IS TEMPORARILY DISABLED"
- IF $DATA(XQMMJ)
- WRITE !!,"Please proceed to '",$EXTRACT(XQMMJ,2,99),"'"
- KILL XQMMJ,XQMM
- IF XQRE
- KILL XQRE
- QUIT
- +2 QUIT
- +3 ;
- PM1 ;Enter here to build a single menu called by XQ83
- +1 SET XQPM1=""
- +2 IF XQDIC'="PXU"
- SET XQXUF=""
- +3 ;
- PM2 ;Enter here to rebuild a single menu Called by RD3+10^XQ81
- +1 ;$D(XQFG1) causes it rebuild in real time otherwise it is queued
- +2 IF $DATA(XQCON)
- DO CHK
- IF '$DATA(XQRE)
- SET XQRE=0
- IF XQRE
- QUIT
- +3 KILL ^TMP("XQO",$JOB,XQDIC)
- SET ^XUTL("XQO",XQDIC,"^BUILD")=$PIECE($HOROLOG,",",2)
- IF $DATA(XQFG1)
- GOTO REBLD
- +4 ;
- +5 SET ZTIO=""
- SET ZTRTN="REBLD^XQ8"
- SET ZTDTH=$HOROLOG
- +6 SET ZTSAVE("XQDIC")=""
- SET ZTSAVE("XQPM2")=""
- +7 SET ZTDESC="Rebuild The Single Menu "_XQDIC
- DO ^%ZTLOAD
- QUIT
- +8 ;
- REBLD ;Taskman entry
- KILL XQFG1
- SET U="^"
- SET UU="^^"
- +1 IF '$DATA(XQDATE)
- SET XQDATE=$HOROLOG
- +2 IF XQDIC'="PXU"
- SET Y=+$PIECE(XQDIC,"P",2)
- IF Y'>0
- QUIT
- IF '$DATA(^DIC(19,Y,0))
- QUIT
- +3 IF '$DATA(XQXUF)
- KILL ^TMP("XQO",$JOB,"PXU")
- SET XQSAV=XQDIC
- SET XQDIC="PXU"
- SET Y=$ORDER(^DIC(19,"B","XUCOMMAND",0))
- IF Y>0
- SET %=""
- SET (L,X(0))=0
- SET (XQPX,XQD)=Y
- IF Y>0
- DO TREE1
- DO PMOK
- SET XQDIC=XQSAV
- SET XQXUF=1
- SET ^TMP("XQO",$JOB,"PXU",0)=XQDATE
- +4 SET Y=$PIECE(XQDIC,"P",2)
- IF Y'>0!'$DATA(^DIC(19,+Y,0))
- GOTO PMOKA
- IF Y>0
- IF $DATA(^DIC(19,Y,0))
- IF $PIECE(^(0),U,4)="M"
- DO PMOK
- SET %=""
- SET (L,X(0))=0
- SET XQD=Y
- DO TREE1
- +5 IF $DATA(^DIC(19,$EXTRACT(XQDIC,2,99),0))
- SET ^(99.1)=XQDATE
- SET ^TMP("XQO",$JOB,XQDIC,0)=XQDATE
- +6 SET Y=+$PIECE(XQDIC,"P",2)
- +7 IF Y>0
- SET (XQD,%)=^DIC(19,Y,0)
- SET L=1
- SET XQP(L)=""
- DO TIME
- SET ^TMP("XQO",$JOB,XQDIC,U,Y)=U_$PIECE(%,U,1,2)_U_$SELECT(($PIECE(%,U,3)]""):1,1:"")_U_$PIECE(%,U,4)_UU_$PIECE(%,U,6,8)_U_XQP(L)_U_$PIECE(%,U,10,99)
- +8 IF Y>0
- IF '$DATA(^DIC(19,Y,"U"))
- SET XQFL=0
- IF $DATA(X)#2
- SET XQSAVE=X
- SET XQFL=1
- SET X=$EXTRACT($PIECE(^DIC(19,+Y,0),U,2),1,30)
- DO UP
- SET ^("U")=X
- IF XQFL
- SET X=XQSAVE
- +9 IF Y>0
- SET ^TMP("XQO",$JOB,XQDIC,^DIC(19,Y,"U")_U)=Y_"^0"
- PMOKA KILL ^XUTL("XQO",XQDIC,"^BUILD")
- IF '$DATA(XQFG)
- IF $DATA(ZTSK)
- KILL ^%ZTSK(ZTSK)
- PMOK KILL %,XQA,XQD,XQE,XQF,XQFL,XQP,XQR,XQRE,XQSAVE
- +1 ;
- +2 IF $DATA(XQPM1)
- Begin DoDot:1
- +3 ;A single menu is being built
- +4 DO MERGET^XQ81
- +5 DO MERGEX^XQ81
- +6 KILL ^TMP($JOB),^TMP("XQO",$JOB)
- +7 QUIT
- End DoDot:1
- +8 KILL XQPM1
- +9 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +10 QUIT
- +11 ;
- TREE ;
- +1 SET X(L)=$ORDER(^DIC(19,XQD,10,X(L)))
- IF X(L)'>0
- QUIT
- SET Y=^(X(L),0)
- SET %=$PIECE(Y,U,2)
- SET Y=+Y
- IF $DATA(XQR(Y))!'$DATA(^DIC(19,Y,0))
- GOTO TREE
- SET XQR(Y)=""
- IF $DATA(XQFG)
- IF '$DATA(XQNTREE)
- IF '(Y#5)
- WRITE "."
- TREE1 SET Y(0)=^DIC(19,Y,0)
- SET X=$SELECT($DATA(^("U")):^("U"),1:"")
- IF X=""
- SET X=$EXTRACT($PIECE(Y(0),U,2),1,30)
- DO UP
- SET ^("U")=X
- +1 SET Y(1)=X
- IF '$LENGTH($PIECE(Y(0),U,5))
- SET $PIECE(Y(0),U,5)=0
- +2 IF $LENGTH($PIECE(Y(0),U,3))
- GOTO TREE
- IF $LENGTH($PIECE(Y(0),U,6))
- SET XQK(L)=$PIECE(Y(0),U,6)
- SET XQA(L)=Y
- IF $LENGTH($PIECE(Y(0),U,10))
- SET XQE(L)=$PIECE(Y(0),U,10)
- +3 IF $PIECE(Y(0),U,16)
- SET XQF(L)=$PIECE(^DIC(19,Y,3),U)
- IF $DATA(XQF(L))
- IF XQF(L)=""
- KILL XQF(L)
- +4 DO TIME
- DO PMOSET
- SET L=L+1
- SET X(L)=0
- SET (XQD,XQD(L))=Y
- DO TREE
- +5 IF L<2
- QUIT
- KILL XQR(XQD(L))
- SET L=L-1
- KILL XQA(L),XQK(L),XQP(L),XQE(L),XQF(L)
- SET XQD=XQD(L)
- GOTO TREE
- +6 ;
- PMOSET ;
- +1 SET K=0
- SET X=$EXTRACT(Y(1),1,27)
- IF $LENGTH(X)
- SET X=X_U
- IF $DATA(^TMP("XQO",$JOB,XQDIC,X))!$DATA(^(X_"1"))
- DO PMO3
- IF L&'K
- SET ^TMP("XQO",$JOB,XQDIC,X)=Y_"^1"
- +2 IF $DATA(%)
- IF $LENGTH(%)
- SET X=%
- SET K=0
- DO UP
- IF '$LENGTH(X)
- QUIT
- SET X=X_U
- IF $DATA(^TMP("XQO",$JOB,XQDIC,X))!$DATA(^(X_"1"))
- DO PMO3
- IF L&'K
- SET ^TMP("XQO",$JOB,XQDIC,X)=Y_"^0"
- +3 SET (XQA,XQK,XQP,XQE,XQF)=""
- FOR D="XQA","XQK","XQP","XQE","XQF"
- FOR I=1:1:L
- IF $DATA(@(D_"(I)"))
- SET @D=@D_@(D_"(I)")_","
- +4 IF '$DATA(^TMP("XQO",$JOB,XQDIC,"^",Y))
- SET ^(Y)=U_$PIECE(Y(0),U,1,2)_U_$SELECT(($PIECE(Y(0),U,3)]""):1,1:"")_U_$PIECE(Y(0),U,4)_U_XQA_U_XQK_U_$PIECE(Y(0),U,7,8)_U_XQP_U_XQE_U_$PIECE(Y(0),U,11,15)_U_XQF_U_$PIECE(Y(0),U,17,99)
- QUIT
- +5 SET %=$SELECT('$DATA(^TMP("XQO",$JOB,XQDIC,"^",Y,0)):1,1:^(0)+1)
- SET ^(0)=%
- SET ^(0,%)=XQA_U_XQK_U_XQP_U_XQE_U_XQF
- +6 QUIT
- PMO3 ;
- +1 SET D=X
- SET K=$SELECT($DATA(^TMP("XQO",$JOB,XQDIC,X)):(Y=+^(X)),1:0)
- FOR
- SET V=$ORDER(^TMP("XQO",$JOB,XQDIC,D))
- IF K!($PIECE(V,U,1)'=$PIECE(X,U,1))
- QUIT
- SET D=V
- IF Y=+^(V)
- SET K=1
- +2 IF 'K
- SET I=$PIECE(D,U,2)
- IF '$LENGTH(I)
- SET I=0
- IF I=0
- SET ^(X_"1")=^TMP("XQO",$JOB,XQDIC,X)
- KILL ^(X)
- SET I=1
- +3 IF 'K
- SET X=X_(I+1)
- +4 QUIT
- +5 ;BUILD moved to XQ81
- +6 QUIT
