- FHZDOC2 ; HISC/REL - Diagram Menus ;3/12/89 20:56
- ;;5.5;DIETETICS;;Jan 28, 2005
- W !! D INIT
- R "Select USER or OPTION name: ",X:DTIME S DIC=3,DIC(0)="EMZ",DIC("S")="I $D(^(201)),^(201)",FL="US" G:X=""!(X["^") END
- RQUE D ^DIC I Y>0 S D0=+Y,MQ=$P(Y(0),U,1),Y=+^(201) I $D(^DIC(19,Y,0)) D E G:'FL QPU D GO Q
- S DIC=19,DIC(0)="QEMZ" K DIC("S") D ^DIC S FL="OP",D0=+Y I Y=-1 G FHZDOC2
- I $P(Y(0),U,4)'="M" W !,*7,"This is not a menu option and therefore cannot be diagrammed.",! G FHZDOC2
- D:Y>0 E G:'FL QPU Q
- ;
- OP ;
- D INIT S Y=D0 D E:$D(^DIC(19,Y,0)) G GO
- US ;
- D INIT Q:'$D(^VA(200,D0,201)) S XQDUZ=D0,Y=+^(201) Q:'$D(^DIC(19,Y,0)) D E
- GO K X,XQV,DIC U IO S W=IOM\M-10,%="" S:W>33 W=33
- I W<10 D ^%ZISC W !,*7,"This menu contains too many levels to be diagrammed using this margin width." G FHZDOC2
- S X=^TMP($J,"XQM",1,0),Z=$P(X,"^",2)
- W @IOF,!!?(IOM-17-$L(Z)\2),"DIAGRAM OF MENU: ",Z
- K ^TMP($J,"XQM",1,0) W !,$P(X,U,3)," (",$P(X,U,2),")",!,"|",!,"|"
- F XQL=1:1 Q:'$D(^TMP($J,"XQM",XQL)) S XQT=M,L=1 K Z D L
- D END
- Q Q
- ;
- L G LL:'$D(^TMP($J,"XQM",XQL,L)) S Y=1,XQV=^(L) I $D(^(L,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 LL
- S XQV=$P(XQV,U,7) I XQV]"" S X="**LOCKED: "_XQV_"**" D T
- LL S Y=0,L=L+1 G L:L'>M
- Y S Y=Y+1,L=1 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) K Z(L,Y) S:Y=1 XQP=XQP(L) 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 S Y=$P(XQB(L),U,XQBN(L)) Q:'$L($P(XQB(L),U,XQBN(L),99)) S XQBN(L)=XQBN(L)+1 I '$D(^DIC(19,+Y,0)) G X
- E S Z=^(0),^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 I $P(Z,U,4)'="M"!$S(XQV]""&$D(XQDUZ):'$D(^XUSEC(XQV,XQDUZ)),1:0)!($P(Z,U,3)]"") S XQL=XQL+1 G X
- S XQV(L)=XQL,L=L+1,X(L)="",(Y,DIC,DIC(L))=+Y S:M<L M=L
- I $S('$D(^XUTL("XQO",DIC,0)):1,'$D(^DIC(19,DIC,99)):1,1:^DIC(19,DIC,99)'=$P(^XUTL("XQO",DIC,0),U,2)) Q ;S XQSY=Y,XQDIC=DIC D SET^XQ7 S Y=XQSY
- K XQA S XQJ=-1 F XQI=0:0 S XQJ=$O(^XUTL("XQO",Y,U,XQJ)) Q:XQJ=-1 S XQA($P(^(XQJ),U,2))=XQJ
- S XQB(L)="",XQBN(L)=1,XQJ=+^XUTL("XQO",Y,0) F XQI=1:1:XQJ S XQN=^XUTL("XQO",Y,0,XQI) F XQP=0:1 S XQB=$P(XQN,U,7*XQP+2) Q:'$L($P(XQN,U,7*XQP+2,99)) I $D(XQA(XQB)) S XQB(L)=XQB(L)_XQA(XQB)_";"_$P(XQN,U,7*XQP+1)_U K XQA(XQB)
- D X
- Q:L=1 S L=L-1,DIC=DIC(L) G X
- ;
- INIT K ^TMP($J,"XQM"),X,IOP,XQDUZ,DIC S L=0,XQL=1,X(0)=0,M=1
- Q
- QPU ;
- S %ZIS="QM" D ^%ZIS Q:POP
- I $D(IO("Q")) K IO("Q") S ZTRTN=FL_"^FHZDOC2",ZTSAVE("D0")="",ZTDESC="DIAGRAM MENUS" D ^%ZTLOAD K ZTSK G FHZDOC2
- D:IO["" GO
- G FHZDOC2
- END K ^TMP($J,"XQM"),X,FL,IOP,XQDUZ,DIC D ^%ZISC
- I $D(ZTSK) K ^%ZTSK(ZTSK)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHZDOC2 3218 printed Feb 18, 2025@23:22:13 Page 2
- FHZDOC2 ; HISC/REL - Diagram Menus ;3/12/89 20:56
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 WRITE !!
- DO INIT
- +3 READ "Select USER or OPTION name: ",X:DTIME
- SET DIC=3
- SET DIC(0)="EMZ"
- SET DIC("S")="I $D(^(201)),^(201)"
- SET FL="US"
- if X=""!(X["^")
- GOTO END
- RQUE DO ^DIC
- IF Y>0
- SET D0=+Y
- SET MQ=$PIECE(Y(0),U,1)
- SET Y=+^(201)
- IF $DATA(^DIC(19,Y,0))
- DO E
- if 'FL
- GOTO QPU
- DO GO
- QUIT
- +1 SET DIC=19
- SET DIC(0)="QEMZ"
- KILL DIC("S")
- DO ^DIC
- SET FL="OP"
- SET D0=+Y
- IF Y=-1
- GOTO FHZDOC2
- +2 IF $PIECE(Y(0),U,4)'="M"
- WRITE !,*7,"This is not a menu option and therefore cannot be diagrammed.",!
- GOTO FHZDOC2
- +3 if Y>0
- DO E
- if 'FL
- GOTO QPU
- QUIT
- +4 ;
- OP ;
- +1 DO INIT
- SET Y=D0
- if $DATA(^DIC(19,Y,0))
- DO E
- GOTO GO
- US ;
- +1 DO INIT
- if '$DATA(^VA(200,D0,201))
- QUIT
- SET XQDUZ=D0
- SET Y=+^(201)
- if '$DATA(^DIC(19,Y,0))
- QUIT
- DO E
- GO KILL X,XQV,DIC
- USE IO
- SET W=IOM\M-10
- SET %=""
- if W>33
- SET W=33
- +1 IF W<10
- DO ^%ZISC
- WRITE !,*7,"This menu contains too many levels to be diagrammed using this margin width."
- GOTO FHZDOC2
- +2 SET X=^TMP($JOB,"XQM",1,0)
- SET Z=$PIECE(X,"^",2)
- +3 WRITE @IOF,!!?(IOM-17-$LENGTH(Z)\2),"DIAGRAM OF MENU: ",Z
- +4 KILL ^TMP($JOB,"XQM",1,0)
- WRITE !,$PIECE(X,U,3)," (",$PIECE(X,U,2),")",!,"|",!,"|"
- +5 FOR XQL=1:1
- if '$DATA(^TMP($JOB,"XQM",XQL))
- QUIT
- SET XQT=M
- SET L=1
- KILL Z
- DO L
- +6 DO END
- Q QUIT
- +1 ;
- L if '$DATA(^TMP($JOB,"XQM",XQL,L))
- GOTO LL
- SET Y=1
- SET XQV=^(L)
- IF $DATA(^(L,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
- GOTO LL
- +3 SET XQV=$PIECE(XQV,U,7)
- IF XQV]""
- SET X="**LOCKED: "_XQV_"**"
- DO T
- LL SET Y=0
- SET L=L+1
- if L'>M
- GOTO L
- Y SET Y=Y+1
- SET L=1
- 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)
- KILL Z(L,Y)
- if Y=1
- SET XQP=XQP(L)
- 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 SET Y=$PIECE(XQB(L),U,XQBN(L))
- if '$LENGTH($PIECE(XQB(L),U,XQBN(L),99))
- QUIT
- SET XQBN(L)=XQBN(L)+1
- IF '$DATA(^DIC(19,+Y,0))
- GOTO X
- E SET Z=^(0)
- 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
- IF $PIECE(Z,U,4)'="M"!$SELECT(XQV]""&$DATA(XQDUZ):'$DATA(^XUSEC(XQV,XQDUZ)),1:0)!($PIECE(Z,U,3)]"")
- SET XQL=XQL+1
- GOTO X
- +1 SET XQV(L)=XQL
- SET L=L+1
- SET X(L)=""
- SET (Y,DIC,DIC(L))=+Y
- if M<L
- SET M=L
- +2 ;S XQSY=Y,XQDIC=DIC D SET^XQ7 S Y=XQSY
- IF $SELECT('$DATA(^XUTL("XQO",DIC,0)):1,'$DATA(^DIC(19,DIC,99)):1,1:^DIC(19,DIC,99)'=$PIECE(^XUTL("XQO",DIC,0),U,2))
- QUIT
- +3 KILL XQA
- SET XQJ=-1
- FOR XQI=0:0
- SET XQJ=$ORDER(^XUTL("XQO",Y,U,XQJ))
- if XQJ=-1
- QUIT
- SET XQA($PIECE(^(XQJ),U,2))=XQJ
- +4 SET XQB(L)=""
- SET XQBN(L)=1
- SET XQJ=+^XUTL("XQO",Y,0)
- FOR XQI=1:1:XQJ
- SET XQN=^XUTL("XQO",Y,0,XQI)
- FOR XQP=0:1
- SET XQB=$PIECE(XQN,U,7*XQP+2)
- if '$LENGTH($PIECE(XQN,U,7*XQP+2,99))
- QUIT
- IF $DATA(XQA(XQB))
- SET XQB(L)=XQB(L)_XQA(XQB)_";"_$PIECE(XQN,U,7*XQP+1)_U
- KILL XQA(XQB)
- +5 DO X
- +6 if L=1
- QUIT
- SET L=L-1
- SET DIC=DIC(L)
- GOTO X
- +7 ;
- INIT KILL ^TMP($JOB,"XQM"),X,IOP,XQDUZ,DIC
- SET L=0
- SET XQL=1
- SET X(0)=0
- SET M=1
- +1 QUIT
- QPU ;
- +1 SET %ZIS="QM"
- DO ^%ZIS
- if POP
- QUIT
- +2 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN=FL_"^FHZDOC2"
- SET ZTSAVE("D0")=""
- SET ZTDESC="DIAGRAM MENUS"
- DO ^%ZTLOAD
- KILL ZTSK
- GOTO FHZDOC2
- +3 if IO[""
- DO GO
- +4 GOTO FHZDOC2
- END KILL ^TMP($JOB,"XQM"),X,FL,IOP,XQDUZ,DIC
- DO ^%ZISC
- +1 IF $DATA(ZTSK)
- KILL ^%ZTSK(ZTSK)
- +2 QUIT
