Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORDD101

ORDD101.m

Go to the documentation of this file.
  1. ORDD101 ; slc/KCM - Build menus in XUTL (file 101) ;10/31/91 14:53 ;
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
  1. SET ;From: Cross reference in file 101, field 99 Entry: DA Exit: DA
  1. ;NOTE: Lock ^ORD(101,DA) when calling
  1. Q:$D(^ORD(101,DA,0))[0
  1. 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
  1. N ORCOL,ORCCOL,ORROW,ORCROW,ORPOS,ORTOT,S1,S2,X,X1
  1. K ^TMP("XQORM",$J) D KILL
  1. S ORCOL=1 I $P($G(^ORD(101,DA,4)),"^")>0 S ORCOL=80\$P(^(4),"^",1)
  1. S ^XUTL("XQORM",DA_";ORD(101,","COL")=ORCOL,(ORTOT,S2)=0
  1. F S S2=$O(^ORD(101,DA,10,S2)) Q:S2'>0 D
  1. . S X=^ORD(101,DA,10,S2,0)
  1. . 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))
  1. . S ^TMP("XQORM",$J,X,S2)="",ORTOT=ORTOT+1
  1. S ORROW=ORTOT\ORCOL+$S(ORTOT#ORCOL:1,1:0),ORCCOL=1,ORCROW=0,S1=""
  1. F S S1=$O(^TMP("XQORM",$J,S1)) Q:S1="" S S2=0 D ;S1 is sequence (#,M_,Z_)
  1. . F S S2=$O(^TMP("XQORM",$J,S1,S2)) Q:S2'>0 D ;S2 is IEN of item multiple
  1. . . S X=^ORD(101,DA,10,S2,0) ;X is the item node
  1. . . 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
  1. . . S ORCROW=ORCROW+1 I ORCROW>ORROW S ORCROW=1,ORCCOL=ORCCOL+1
  1. . . S ORPOS=ORCROW+(ORCCOL/10) D
  1. . . . S X1=$S($L($P(X,"^",6)):$P(X,"^",6),1:$P(^ORD(101,+X,0),"^",2)),X1=$TR(X1,",=;-"," ") Q:'$L(X1)
  1. . . . S ^XUTL("XQORM",DA_";ORD(101,",ORPOS,0)=S2_"^"_+X_"^"_X1_"^"_$P(X,"^",2)_"^"_$P(X,"^",5)
  1. . . . I $P(X,"^",5)'="O" D
  1. . . . . S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP(X1),ORPOS)=""
  1. . . . . I $L($P(X,"^",2)) S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($P(X,"^",2)),ORPOS)=1
  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
  1. S X=$H,^XUTL("XQORM",DA_";ORD(101,",0)=X,^ORD(101,DA,99)=X
  1. K ^TMP("XQORM",$J)
  1. Q
  1. UP(X) ;Convert X to upper case
  1. Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. KILL ;From: File 101, Field 99 Entry: DA Exit: DA
  1. K ^XUTL("XQORM",DA_";ORD(101,") Q
  1. REDO ;From: File 101, Field 7 Entry: DA Exit: DA
  1. N I,X S X=$H I $D(^ORD(101,DA,0)) S ^(99)=X
  1. F I=0:0 S I=$O(^ORD(101,"AD",DA,I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
  1. Q
  1. REDOM ;From: File 101, Field 1.1 Entry: DA(1) Exit: DA(1)
  1. N I,X S I=0,X=$H
  1. F S I=$O(^ORD(101,"AD",DA(1),I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
  1. Q
  1. REDOX ;From: Subfile 101.01, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
  1. I $D(^ORD(101,DA(1),0)) S ^(99)=$H Q
  1. 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
  1. S ORDDA=DA(1) K:X=ORDDA X D TREE1 K ORDDA,ORDDF,ORDD Q
  1. 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
  1. Q
  1. TREE2 N ORDDA S ORDDA=ORDD N ORDD D TREE1 Q
  1. NAME ;CHECK NAMESPACING IN PACKAGE FILE.
  1. I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
  1. F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
  1. I 0
  1. Q
  1. 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
  1. I 0 Q
  1. CHKNAME ;CHECK A NAME, AND DISPLAY APPROPRIATE MESSAGE
  1. I $D(^ORD(101,"B",X)) D EN^DDIOL("Duplicate names not allowed.") K X Q
  1. D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q
  1. I '$D(DIFROM) D EN^DDIOL("Located in the "_$E(X,1,%)_" ("_%1_") namespace.")
  1. Q
  1. 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.",!!
  1. T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1