source: IHS-VA_UTILITIES-XB/trunk/XBHEDD9.m@ 679

Last change on this file since 679 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.
File size: 3.6 KB
Line 
1XBHEDD9 ;402,DJB,10/23/91,EDD - NODE Lookup and Look-up by Global
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;;David Bolduc - Togus, ME
4 N FILE,FLD,NODE,NODE0,NODE1,PIECE
5 K ^UTILITY($J,"EDD/NP") S FILE=ZNUM
6ND ;Lookup by NODE and PIECE
7 D NDGET G:FLAGQ EX D NDBLD
8 I '$D(^UTILITY($J,"EDD/NP")) W *7," No such node." G ND
9ND1 D NDPRT G:FLAGQ EX
10 I $O(^UTILITY($J,"EDD/NP",NODE,""))=0 S FILE=+$P(^UTILITY($J,"EDD/NP",NODE,0),U,3),NODE1=NODE G ND
11 D NDSUM G:FLAGD ND G:FLAGE EX
12 S FLAGQ=0 G ND1
13EX ;
14 S:'FLAGE FLAGQ=0 K NP,FLAGD,FNAM,FNUM,LEV,^UTILITY($J,"EDD/NP")
15 Q
16NDGET ;Node get
17 W !
18NDGET1 I FILE'=ZNUM W !,"Select '",NODE1,"' SUBNODE: "
19 E W !,"Select NODE: "
20 R NODE:DTIME S:'$T NODE="^" I "^"[NODE S FLAGQ=1 Q
21 I NODE="?" D HELP G NDGET1
22 Q
23NDBLD ;
24 S FLD=0 K ^UTILITY($J,"EDD/NP")
25 F S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 I $P($P(^DD(FILE,FLD,0),U,4),";")=NODE S NODE0=^(0),NP=$P(NODE0,U,4),PIECE=$P(NP,";",2),^UTILITY($J,"EDD/NP",NODE,PIECE)=FLD_U_$P(NODE0,U,1,4)
26 Q
27NDPRT ;Print
28 S PIECE="" W @IOF D HD
29 F S PIECE=$O(^UTILITY($J,"EDD/NP",NODE,PIECE)) Q:PIECE="" W !?3,$J(NODE_";"_PIECE,12),?20,$J($P(^UTILITY($J,"EDD/NP",NODE,PIECE),U),7),?32,$P(^(PIECE),U,2) I $Y>SIZE D PAGE Q:FLAGQ=1
30 Q
31NDSUM ;
32 W !!?2,"You may now do an 'INDIVIDUAL FIELD SUMMARY'",!?2,"on the field(s) listed above.."
33 S FLAGD=0 W ! S DIC="^DD("_FILE_",",DIC(0)="QEAM" D ^DIC I Y<0 S FLAGD=1 Q
34 S FNUM=+Y,FNAM=$P(Y,U,2),LEV=1,FILE(LEV)=FILE D ^XBHEDD4 Q:FLAGQ
35 I $Y'>SIZE F I=$Y:1:SIZE W !
36 R ?2,"<RETURN> to continue..",XX:DTIME
37 Q
38PAGE ;
39 R !!?2,"<RETURN> to continue, '^' to quit, '^' to exit: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q
40 W @IOF D HD
41 Q
42HELP ;
43 N FLD,NDTEMP
44 S FLD=0 K ^UTILITY($J,"EDD/NP")
45 F S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 S NDTEMP=$P($P(^DD(FILE,FLD,0),U,4),";") W:'$D(^UTILITY($J,"EDD/NP",NDTEMP))#2 " ",NDTEMP W:$X>70 !?5 S ^UTILITY($J,"EDD/NP",NDTEMP)=""
46 K ^UTILITY($J,"EDD/NP") Q
47HD ;Node look-up
48 W !?3,"NODE ; PIECE",?20,"FLD NUM",?42,"FIELD NAME"
49 W !?3,"------------",?20,"-------",?32,"------------------------------"
50 Q
51GLOBAL ;Find File when user enters global
52 K ^UTILITY($J) S (FLAGGL,FLAGGL1)=0
53 I '$D(^UTILITY("EDD/GL")) W *7,!?25,"You have no data in ^UTILITY(""EDD/GL""). You must run",!?25,"option 10, List Globals in ASCII Order, before you",!?25,"can do a lookup on a global." S FLAGGL=1 Q
54 I $D(^UTILITY("EDD/GL",X)) S ZNUM=$P(^(X),U),ZNAM=$P(^(X),U,2),ZGL=X Q
55 S XX=X F I=1:1 S XX=$O(^UTILITY("EDD/GL",XX)) Q:XX=""!($E(XX,1,$L(X))'=X) D GLLIST I I#5=0 D GLPAGE Q:FLAGGL!FLAGGL1
56 I '$D(^UTILITY($J)) W *7," ??" S FLAGGL=1
57 Q:FLAGGL
58 I 'FLAGGL1 S I=(I-1) D GLPAGE1 Q:FLAGGL
59 I Z1>I F II=(I+1):1:Z1 S XX=$O(^UTILITY("EDD/GL",XX)) Q:XX=""!($E(XX,1,$L(X))'=X) S ^UTILITY($J,II)=$P(^UTILITY("EDD/GL",XX),U)_"\~"_$P(^(XX),U,2)_"\~"_XX
60 I '$D(^UTILITY($J,Z1)) W *7," ??" S FLAGGL=1 Q
61 S ZNUM=$P(^UTILITY($J,Z1),"\~"),ZNAM=$P(^(Z1),"\~",2),ZGL=$P(^(Z1),"\~",3)
62 I '$D(^DD(ZNUM)) W *7," ?? This file has been deleted." S FLAGGL=1 ;Check to see if file still exists
63 Q
64GLLIST ;List Globals
65 I I=1 W !?28,"FILE NUM",?38,"FILE NAME (Truncated to 32)",!?28,"--------",?38,"--------------------------------"
66 W !?3,$J(I,3)," ",XX,?28,$J($P(^UTILITY("EDD/GL",XX),U),8),?38,$E($P(^(XX),U,2),1,32)
67 S ^UTILITY($J,I)=$P(^UTILITY("EDD/GL",XX),U)_"\~"_$P(^(XX),U,2)_"\~"_XX
68 Q
69GLPAGE ;
70 W !,"TYPE '^' TO STOP, OR",!,"CHOOSE NUMBER: "
71 R Z1:DTIME S:'$T Z1="^" I Z1="?" W " Enter a number from left hand column.." G GLPAGE
72 S:Z1["^" FLAGGL=1 I +Z1>0 S FLAGGL1=1
73 Q
74GLPAGE1 ;
75 W !,"TYPE '^' TO STOP, OR",!,"CHOOSE NUMBER: "
76 R Z1:DTIME S:'$T Z1="^" I "^"[Z1!(+Z1'>0) S FLAGGL=1
77 I Z1="?" W " Enter a number from left hand column.." G GLPAGE1
78 Q
Note: See TracBrowser for help on using the repository browser.