XQORD101 ; slc/KCM - Build menus in XUTL (file 101) ;9/24/98 16:40
;;8.0;KERNEL;**98**;Sept. 24,1998
SET ;From: Cross reference in file 101, field 99 Entry: DA Exit: DA
;NOTE: Lock ^ORD(101,DA) when calling
Q:$D(^ORD(101,DA,0))[0
I $D(^ORD(101,DA,99)),$D(^XUTL("XQORM",DA_";ORD(101,",0)),$P(^ORD(101,DA,99),"^")=$P(^XUTL("XQORM",DA_";ORD(101,",0),"^") Q
N ORCOL,ORCCOL,ORROW,ORCROW,ORPOS,ORTOT,S1,S2,X,X1
K ^TMP("XQORM",$J) D KILL
S ORCOL=1 I $P($G(^ORD(101,DA,4)),"^")>0 S ORCOL=80\$P(^(4),"^",1)
S ^XUTL("XQORM",DA_";ORD(101,","COL")=ORCOL,(ORTOT,S2)=0
F S S2=$O(^ORD(101,DA,10,S2)) Q:S2'>0 D
. S X=^ORD(101,DA,10,S2,0)
. S X=$S(+$P(X,"^",3):+$P(X,"^",3),+$P(X,"^",2):+$P(X,"^",2),$L($P(X,"^",2)):"M"_$P(X,"^",2),1:"Z"_$P(^ORD(101,+X,0),"^",2))
. S ^TMP("XQORM",$J,X,S2)="",ORTOT=ORTOT+1
S ORROW=ORTOT\ORCOL+$S(ORTOT#ORCOL:1,1:0),ORCCOL=1,ORCROW=0,S1=""
F S S1=$O(^TMP("XQORM",$J,S1)) Q:S1="" S S2=0 D ;S1 is sequence (#,M_,Z_)
. F S S2=$O(^TMP("XQORM",$J,S1,S2)) Q:S2'>0 D ;S2 is IEN of item multiple
. . S X=^ORD(101,DA,10,S2,0) ;X is the item node
. . I '$D(^ORD(101,+X,0)) K ^ORD(101,DA,10,S2),^("B",+X,S2) S $P(^ORD(101,DA,10,0),"^",3,4)=S2_"^"_($P(^ORD(101,DA,10,0),"^",4)-1) Q
. . S ORCROW=ORCROW+1 I ORCROW>ORROW S ORCROW=1,ORCCOL=ORCCOL+1
. . S ORPOS=ORCROW+(ORCCOL/10) D
. . . S X1=$S($L($P(X,"^",6)):$P(X,"^",6),1:$P(^ORD(101,+X,0),"^",2)),X1=$TR(X1,",=;-"," ") Q:'$L(X1)
. . . S ^XUTL("XQORM",DA_";ORD(101,",ORPOS,0)=S2_"^"_+X_"^"_X1_"^"_$P(X,"^",2)_"^"_$P(X,"^",5)
. . . I $P(X,"^",5)'="O" D
. . . . S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP(X1),ORPOS)=""
. . . . I $L($P(X,"^",2)) S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($P(X,"^",2)),ORPOS)=1
. . . . I $D(^ORD(101,+X,2)) S X1=0 F S X1=$O(^ORD(101,+X,2,X1)) Q:X1'>0 I $L($G(^ORD(101,+X,2,X1,0))) S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($P(^(0),"^")),ORPOS)=1
S X=$H,^XUTL("XQORM",DA_";ORD(101,",0)=X,^ORD(101,DA,99)=X
K ^TMP("XQORM",$J)
Q
UP(X) ;Convert X to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
KILL ;From: File 101, Field 99 Entry: DA Exit: DA
K ^XUTL("XQORM",DA_";ORD(101,") Q
REDO ;From: File 101, Field 7 Entry: DA Exit: DA
N I,X S X=$H I $D(^ORD(101,DA,0)) S ^(99)=X
F I=0:0 S I=$O(^ORD(101,"AD",DA,I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
Q
REDOM ;From: File 101, Field 1.1 Entry: DA(1) Exit: DA(1)
N I,X S I=0,X=$H
F S I=$O(^ORD(101,"AD",DA(1),I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
Q
REDOX ;From: Subfile 101.01, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
I $D(^ORD(101,DA(1),0)) S ^(99)=$H Q
TREE ;Look back up tree to make sure item is not ancestor (input xform)
;From: 101.01,.01 101.01,4 100.981,.01 Entry: DA(1),X,ORDDF
S ORDDA=DA(1) K:X=ORDDA X D TREE1 K ORDDA,ORDDF,ORDD Q
TREE1 F ORDD=0:0 Q:'$D(X) S ORDD=$O(^ORD(ORDDF,"AD",ORDDA,ORDD)) Q:ORDD'>0 K:ORDD=X X Q:'$D(X) D TREE2
Q
TREE2 N ORDDA S ORDDA=ORDD N ORDD D TREE1 Q
NAME ;CHECK NAMESPACING IN PACKAGE FILE.
I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
I 0
Q
NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) I %1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U) I 1 Q
I 0 Q
CHKNAME ;CHECK A NAME, AND DISPLAY APPROPRIATE MESSAGE
I $D(^ORD(101,"B",X)) W " Duplicate names not allowed." K X Q
D NAME E W !,"Not a known package or a local namespace." Q
W:'$D(ORNMCHK) !," Located in the ",$E(X,1,%)," (",%1,") namespace." Q
TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!!
T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQORD101 3715 printed Apr 09, 2024@21:05:29 Page 2
XQORD101 ; slc/KCM - Build menus in XUTL (file 101) ;9/24/98 16:40
+1 ;;8.0;KERNEL;**98**;Sept. 24,1998
SET ;From: Cross reference in file 101, field 99 Entry: DA Exit: DA
+1 ;NOTE: Lock ^ORD(101,DA) when calling
+2 if $DATA(^ORD(101,DA,0))[0
QUIT
+3 IF $DATA(^ORD(101,DA,99))
IF $DATA(^XUTL("XQORM",DA_";ORD(101,",0))
IF $PIECE(^ORD(101,DA,99),"^")=$PIECE(^XUTL("XQORM",DA_";ORD(101,",0),"^")
QUIT
+4 NEW ORCOL,ORCCOL,ORROW,ORCROW,ORPOS,ORTOT,S1,S2,X,X1
+5 KILL ^TMP("XQORM",$JOB)
DO KILL
+6 SET ORCOL=1
IF $PIECE($GET(^ORD(101,DA,4)),"^")>0
SET ORCOL=80\$PIECE(^(4),"^",1)
+7 SET ^XUTL("XQORM",DA_";ORD(101,","COL")=ORCOL
SET (ORTOT,S2)=0
+8 FOR
SET S2=$ORDER(^ORD(101,DA,10,S2))
if S2'>0
QUIT
Begin DoDot:1
+9 SET X=^ORD(101,DA,10,S2,0)
+10 SET X=$SELECT(+$PIECE(X,"^",3):+$PIECE(X,"^",3),+$PIECE(X,"^",2):+$PIECE(X,"^",2),$LENGTH($PIECE(X,"^",2)):"M"_$PIECE(X,"^",2),1:"Z"_$PIECE(^ORD(101,+X,0),"^",2))
+11 SET ^TMP("XQORM",$JOB,X,S2)=""
SET ORTOT=ORTOT+1
End DoDot:1
+12 SET ORROW=ORTOT\ORCOL+$SELECT(ORTOT#ORCOL:1,1:0)
SET ORCCOL=1
SET ORCROW=0
SET S1=""
+13 ;S1 is sequence (#,M_,Z_)
FOR
SET S1=$ORDER(^TMP("XQORM",$JOB,S1))
if S1=""
QUIT
SET S2=0
Begin DoDot:1
+14 ;S2 is IEN of item multiple
FOR
SET S2=$ORDER(^TMP("XQORM",$JOB,S1,S2))
if S2'>0
QUIT
Begin DoDot:2
+15 ;X is the item node
SET X=^ORD(101,DA,10,S2,0)
+16 IF '$DATA(^ORD(101,+X,0))
KILL ^ORD(101,DA,10,S2),^("B",+X,S2)
SET $PIECE(^ORD(101,DA,10,0),"^",3,4)=S2_"^"_($PIECE(^ORD(101,DA,10,0),"^",4)-1)
QUIT
+17 SET ORCROW=ORCROW+1
IF ORCROW>ORROW
SET ORCROW=1
SET ORCCOL=ORCCOL+1
+18 SET ORPOS=ORCROW+(ORCCOL/10)
Begin DoDot:3
+19 SET X1=$SELECT($LENGTH($PIECE(X,"^",6)):$PIECE(X,"^",6),1:$PIECE(^ORD(101,+X,0),"^",2))
SET X1=$TRANSLATE(X1,",=;-"," ")
if '$LENGTH(X1)
QUIT
+20 SET ^XUTL("XQORM",DA_";ORD(101,",ORPOS,0)=S2_"^"_+X_"^"_X1_"^"_$PIECE(X,"^",2)_"^"_$PIECE(X,"^",5)
+21 IF $PIECE(X,"^",5)'="O"
Begin DoDot:4
+22 SET ^XUTL("XQORM",DA_";ORD(101,","B",$$UP(X1),ORPOS)=""
+23 IF $LENGTH($PIECE(X,"^",2))
SET ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($PIECE(X,"^",2)),ORPOS)=1
+24 IF $DATA(^ORD(101,+X,2))
SET X1=0
FOR
SET X1=$ORDER(^ORD(101,+X,2,X1))
if X1'>0
QUIT
IF $LENGTH($GET(^ORD(101,+X,2,X1,0)))
SET ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($PIECE(^(0),"^")),ORPOS)=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 SET X=$HOROLOG
SET ^XUTL("XQORM",DA_";ORD(101,",0)=X
SET ^ORD(101,DA,99)=X
+26 KILL ^TMP("XQORM",$JOB)
+27 QUIT
UP(X) ;Convert X to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
KILL ;From: File 101, Field 99 Entry: DA Exit: DA
+1 KILL ^XUTL("XQORM",DA_";ORD(101,")
QUIT
REDO ;From: File 101, Field 7 Entry: DA Exit: DA
+1 NEW I,X
SET X=$HOROLOG
IF $DATA(^ORD(101,DA,0))
SET ^(99)=X
+2 FOR I=0:0
SET I=$ORDER(^ORD(101,"AD",DA,I))
if I'>0
QUIT
IF $DATA(^ORD(101,I,0))
SET ^(99)=X
+3 QUIT
REDOM ;From: File 101, Field 1.1 Entry: DA(1) Exit: DA(1)
+1 NEW I,X
SET I=0
SET X=$HOROLOG
+2 FOR
SET I=$ORDER(^ORD(101,"AD",DA(1),I))
if I'>0
QUIT
IF $DATA(^ORD(101,I,0))
SET ^(99)=X
+3 QUIT
REDOX ;From: Subfile 101.01, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
+1 IF $DATA(^ORD(101,DA(1),0))
SET ^(99)=$HOROLOG
QUIT
TREE ;Look back up tree to make sure item is not ancestor (input xform)
+1 ;From: 101.01,.01 101.01,4 100.981,.01 Entry: DA(1),X,ORDDF
+2 SET ORDDA=DA(1)
if X=ORDDA
KILL X
DO TREE1
KILL ORDDA,ORDDF,ORDD
QUIT
TREE1 FOR ORDD=0:0
if '$DATA(X)
QUIT
SET ORDD=$ORDER(^ORD(ORDDF,"AD",ORDDA,ORDD))
if ORDD'>0
QUIT
if ORDD=X
KILL X
if '$DATA(X)
QUIT
DO TREE2
+1 QUIT
TREE2 NEW ORDDA
SET ORDDA=ORDD
NEW ORDD
DO TREE1
QUIT
NAME ;CHECK NAMESPACING IN PACKAGE FILE.
+1 IF $EXTRACT(X,1)="A"!($EXTRACT(X,1)="Z")
SET %=1
SET %1="Local"
QUIT
+2 FOR %=4:-1:2
if $DATA(^DIC(9.4,"C",$EXTRACT(X,1,%)))
GOTO NAMEOK
+3 IF 0
+4 QUIT
NAMEOK SET %1=$ORDER(^DIC(9.4,"C",$EXTRACT(X,1,%),0))
IF %1
if $DATA(^DIC(9.4,%1,0))
SET %1=$PIECE(^(0),U)
IF 1
QUIT
+1 IF 0
QUIT
CHKNAME ;CHECK A NAME, AND DISPLAY APPROPRIATE MESSAGE
+1 IF $DATA(^ORD(101,"B",X))
WRITE " Duplicate names not allowed."
KILL X
QUIT
+2 DO NAME
IF '$TEST
WRITE !,"Not a known package or a local namespace."
QUIT
+3 if '$DATA(ORNMCHK)
WRITE !," Located in the ",$EXTRACT(X,1,%)," (",%1,") namespace."
QUIT
TEST WRITE !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!!
T1 READ !,"NAME: ",X:DTIME," "
if X=""
QUIT
DO CHKNAME
GOTO T1
