source: IHS-VA_UTILITIES-XB/trunk/XBDHD2.m@ 1115

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

Modified directory structure; moved routines.
File size: 4.4 KB
Line 
1XBDHD2 ; IHS/ADC/GTH - SPECIAL CHOICES ; [ 02/07/97 3:02 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4NEW ;
5 NEW XBDHFROM,XBDHI,XBDHTEMP,XBDHTO
6 ;
7START ;
8 I $D(XBDHECHN) S XBDHCHN=XBDHECHN,XBDHX=^TMP("XBDH",$J,"HEADER",XBDHCHN),XBDHHDR=$P(XBDHX,V,3),XBDHHDW=$P(XBDHX,V,4)
9 W "EDITING HEADER LINE SEGMENT """,$C(64+XBDHCHN),""" FIELD = """,$P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,2),"""",!
10 F XBDHI=1:1:7 W $E($T(TEXT+XBDHI),4,99),!
11 W !
12CNEXT ;
13 S DIR(0)="NO^1:8:",DIR("A")="Your choice",DIR("?")="Enter the number of the editing function or <CR> to go on"
14 D ^DIR
15 KILL DIR
16 S XBDHX=Y
17 I "^"[XBDHX KILL XBDHECHN Q
18 G @("C"_XBDHX)
19 ;
20C1 ;
21 S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5)=(XBDHHDW-$L(XBDHHDR))\2
22 D ^XBDHD1
23 G START
24 ;
25C2 ;
26 S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5)=0
27 D ^XBDHD1
28 G START
29 ;
30C3 ;
31 W !!
32C31 ;
33 S DIR(0)="NO^"_$L(XBDHHDR)_":"_(XBDHNSL+XBDHHDW)_":",DIR("A")="New field width"
34 D ^DIR
35 KILL DIR
36 S XBDHX=Y
37 I "^"[XBDHX G START
38 I XBDHX'=+XBDHX W *13,$J("",IOM),*13,*7,*7 G C31
39 I (XBDHX<$L(XBDHHDR))!(XBDHX>(XBDHNSL+XBDHHDW)) W *7,*7,*13,$J("",IOM),*13 G C31
40 S XBDHHDW=XBDHX,$P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,4)=XBDHX G:$E($P(^(XBDHCHN),V,5)) C1
41 D ^XBDHD1
42 G START
43 ;
44C4 ;
45 W !!
46 S DIR(0)="FO^1:"_XBDHHDW_"",DIR("A")="New header name"
47 D ^DIR
48 KILL DIR
49 S XBDHX=Y
50 I XBDHX="" G C8
51 I XBDHX=U G START
52 I $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5) S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,3)=XBDHX,XBDHHDR=XBDHX G C1
53 S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,3)=XBDHX
54 D ^XBDHD1
55 G START
56 ;
57C5 ;
58 S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,6)="+"
59 W !!,"ENTRIES RIGHT JUSTIFIED TO A WIDTH OF ",XBDHHDW," COLUMNS"
60 H 2
61 D ^XBDHD1
62 G START
63 ;
64C6 ;
65 S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,7)="+"
66 W !!,"ENTRIES WILL BE WORD WRAPPED TO A WIDTH OF ",XBDHHDW," COLUMNS"
67 H 2
68 D ^XBDHD1
69 G START
70 ;
71C7 ;
72 I '$D(XBDHECHN) KILL ^TMP("XBDH",$J,"HEADER",XBDHCHN) D ^XBDHD1 Q
73 S X=""
74 F L=0:0 S X=$O(^TMP("XBDH",$J,"HEADER",X)) Q:X="" S ^TMP("XBDH",$J,"HT",X)=^TMP("XBDH",$J,"HEADER",X) W "."
75 S XBDHTEMP=^TMP("XBDH",$J,"HEADER")
76 KILL ^TMP("XBDH",$J,"HT",XBDHECHN),^TMP("XBDH",$J,"HEADER")
77 S X=""
78 F I=1:1 S X=$O(^TMP("XBDH",$J,"HT",X)) Q:X="" S ^TMP("XBDH",$J,"HEADER",I)=^TMP("XBDH",$J,"HT",X) W "."
79 S ^TMP("XBDH",$J,"HEADER")=XBDHTEMP
80 KILL ^TMP("XBDH",$J,"HT"),XBDHTEMP
81 KILL XBDHECHN
82 D ^XBDHD1
83 Q
84 ;
85C8 ;
86 S XBDHFROM=$S($D(XBDHECHN):XBDHECHN,1:XBDHCHN),XBDHFROM=$C(64+XBDHFROM)
87 S X=""
88 F XBDHTCHN=0:1 S X=$O(^TMP("XBDH",$J,"HEADER",X)) Q:X="" S ^TMP("XBDH",$J,"HT",X)=^(X) W "." S Y="" F L=0:0 S Y=$O(^TMP("XBDH",$J,"HEADER",X,Y)) Q:Y="" S ^TMP("XBDH",$J,"HT",X,Y)=^(Y)
89 I XBDHCHN<2 W *7,*13,$J("",IOM),*13 G CNEXT
90 W *13,$J("",IOM),*13
91 ;
92MOVE ;
93 S DIR(0)="FO^",DIR("A")="Where do you want to move this header (A - "_$C(64+XBDHTCHN)_")",DIR("?")="Enter a letter which corresponds to a header line field"
94 D ^DIR
95 KILL DIR
96 S XBDHTO=Y
97 I "^"[XBDHTO W ! G START
98 I XBDHTO'?1U W *7,*7,*13,$J("",IOM),*13 G MOVE
99 I XBDHTO]$C(64+XBDHCHN) W *7,*7,*13,$J("",IOM),*13 G MOVE
100 I XBDHFROM=XBDHTO W *7,*13,$J("",IOM),*13 G MOVE
101 S XBDHFROM=$A(XBDHFROM)-64,XBDHTO=$A(XBDHTO)-64
102 S XBDHX=XBDHTO+.1
103 S:(XBDHFROM>XBDHTO) XBDHX=XBDHTO-.1
104 S ^TMP("XBDH",$J,"HT",XBDHX)=^TMP("XBDH",$J,"HEADER",XBDHFROM)
105 S Y=""
106 F L=0:0 S Y=$O(^TMP("XBDH",$J,"HEADER",XBDHFROM,Y)) Q:Y="" S ^TMP("XBDH",$J,"HT",XBDHX,Y)=^TMP("XBDH",$J,"HEADER",XBDHFROM,Y)
107 S XBDHTEMP=^TMP("XBDH",$J,"HEADER")
108 KILL ^TMP("XBDH",$J,"HT",XBDHFROM),^TMP("XBDH",$J,"HEADER")
109 S X=""
110 F I=1:1 S X=$O(^TMP("XBDH",$J,"HT",X)) Q:X="" S ^TMP("XBDH",$J,"HEADER",I)=^TMP("XBDH",$J,"HT",X) S Y="" F L=0:0 S Y=$O(^TMP("XBDH",$J,"HT",X,Y)) Q:Y="" S ^TMP("XBDH",$J,"HEADER",I,Y)=^TMP("XBDH",$J,"HT",X,Y)
111 S ^TMP("XBDH",$J,"HEADER")=XBDHTEMP
112 KILL ^TMP("XBDH",$J,"HT"),XBDHTEMP,XBDHECHN
113 D ^XBDHD1
114 G START
115 ;
116TEXT ;
117 ;;DO YOU WANT TO MAKE ANY OTHER CHANGES TO THIS HEADER OR ITS FIELD?
118 ;;
119 ;; <CR> ACCEPT HEADER AS IS
120 ;; 1) CENTER HEADER WITHIN FIELD 5) RIGHT JUSTIFY ENTRIES
121 ;; 2) UNCENTER HEADER 6) WORD WRAP ENTRIES
122 ;; 3) CHANGE FIELD WIDTH 7) REMOVE THIS HEADER
123 ;; 4) CHANGE HEADER NAME 8) MOVE THIS HEADER
124 ;
125NOTES ;
126 ; MAKES SECONDARY EDITING CHANGES AFTER EACH FIELD IS ENTERED
127 ; INPUT = XBDHCHN OR XBDHECHN (XBDHECHN IS THE .A OR .B CHN),^TMP("XBDH",$J,"HEADER",CHN),XBDHTHLW
128 ; OUTPUT = RESET ^TMP("XBDH",$J,"HEADER",CHN)
129 ; TO INSERT A NEW FIELD SIMPLY APPEND IT TO THE END OF THE LINE AND THE MOVE IT
Note: See TracBrowser for help on using the repository browser.