source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDD101.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.6 KB
Line 
1ORDD101 ; slc/KCM - Build menus in XUTL (file 101) ;10/31/91 14:53 ;
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
3SET ;From: Cross reference in file 101, field 99 Entry: DA Exit: DA
4 ;NOTE: Lock ^ORD(101,DA) when calling
5 Q:$D(^ORD(101,DA,0))[0
6 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
7 N ORCOL,ORCCOL,ORROW,ORCROW,ORPOS,ORTOT,S1,S2,X,X1
8 K ^TMP("XQORM",$J) D KILL
9 S ORCOL=1 I $P($G(^ORD(101,DA,4)),"^")>0 S ORCOL=80\$P(^(4),"^",1)
10 S ^XUTL("XQORM",DA_";ORD(101,","COL")=ORCOL,(ORTOT,S2)=0
11 F S S2=$O(^ORD(101,DA,10,S2)) Q:S2'>0 D
12 . S X=^ORD(101,DA,10,S2,0)
13 . 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))
14 . S ^TMP("XQORM",$J,X,S2)="",ORTOT=ORTOT+1
15 S ORROW=ORTOT\ORCOL+$S(ORTOT#ORCOL:1,1:0),ORCCOL=1,ORCROW=0,S1=""
16 F S S1=$O(^TMP("XQORM",$J,S1)) Q:S1="" S S2=0 D ;S1 is sequence (#,M_,Z_)
17 . F S S2=$O(^TMP("XQORM",$J,S1,S2)) Q:S2'>0 D ;S2 is IEN of item multiple
18 . . S X=^ORD(101,DA,10,S2,0) ;X is the item node
19 . . 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
20 . . S ORCROW=ORCROW+1 I ORCROW>ORROW S ORCROW=1,ORCCOL=ORCCOL+1
21 . . S ORPOS=ORCROW+(ORCCOL/10) D
22 . . . S X1=$S($L($P(X,"^",6)):$P(X,"^",6),1:$P(^ORD(101,+X,0),"^",2)),X1=$TR(X1,",=;-"," ") Q:'$L(X1)
23 . . . S ^XUTL("XQORM",DA_";ORD(101,",ORPOS,0)=S2_"^"_+X_"^"_X1_"^"_$P(X,"^",2)_"^"_$P(X,"^",5)
24 . . . I $P(X,"^",5)'="O" D
25 . . . . S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP(X1),ORPOS)=""
26 . . . . I $L($P(X,"^",2)) S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($P(X,"^",2)),ORPOS)=1
27 . . . . 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
28 S X=$H,^XUTL("XQORM",DA_";ORD(101,",0)=X,^ORD(101,DA,99)=X
29 K ^TMP("XQORM",$J)
30 Q
31UP(X) ;Convert X to upper case
32 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
33KILL ;From: File 101, Field 99 Entry: DA Exit: DA
34 K ^XUTL("XQORM",DA_";ORD(101,") Q
35REDO ;From: File 101, Field 7 Entry: DA Exit: DA
36 N I,X S X=$H I $D(^ORD(101,DA,0)) S ^(99)=X
37 F I=0:0 S I=$O(^ORD(101,"AD",DA,I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
38 Q
39REDOM ;From: File 101, Field 1.1 Entry: DA(1) Exit: DA(1)
40 N I,X S I=0,X=$H
41 F S I=$O(^ORD(101,"AD",DA(1),I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
42 Q
43REDOX ;From: Subfile 101.01, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
44 I $D(^ORD(101,DA(1),0)) S ^(99)=$H Q
45TREE ;Look back up tree to make sure item is not ancestor (input xform)
46 ;From: 101.01,.01 101.01,4 100.981,.01 Entry: DA(1),X,ORDDF
47 S ORDDA=DA(1) K:X=ORDDA X D TREE1 K ORDDA,ORDDF,ORDD Q
48TREE1 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
49 Q
50TREE2 N ORDDA S ORDDA=ORDD N ORDD D TREE1 Q
51NAME ;CHECK NAMESPACING IN PACKAGE FILE.
52 I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
53 F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
54 I 0
55 Q
56NAMEOK 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
57 I 0 Q
58CHKNAME ;CHECK A NAME, AND DISPLAY APPROPRIATE MESSAGE
59 I $D(^ORD(101,"B",X)) D EN^DDIOL("Duplicate names not allowed.") K X Q
60 D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q
61 I '$D(DIFROM) D EN^DDIOL("Located in the "_$E(X,1,%)_" ("_%1_") namespace.")
62 Q
63TEST 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.",!!
64T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1
Note: See TracBrowser for help on using the repository browser.