130 lines
4.4 KiB
Mathematica
130 lines
4.4 KiB
Mathematica
|
XBDHD2 ; IHS/ADC/GTH - SPECIAL CHOICES ; [ 02/07/97 3:02 PM ]
|
||
|
|
;;4.0;XB;;Jul 20, 2009;Build 2
|
||
|
|
;
|
||
|
|
NEW ;
|
||
|
|
NEW XBDHFROM,XBDHI,XBDHTEMP,XBDHTO
|
||
|
|
;
|
||
|
|
START ;
|
||
|
|
I $D(XBDHECHN) S XBDHCHN=XBDHECHN,XBDHX=^TMP("XBDH",$J,"HEADER",XBDHCHN),XBDHHDR=$P(XBDHX,V,3),XBDHHDW=$P(XBDHX,V,4)
|
||
|
|
W "EDITING HEADER LINE SEGMENT """,$C(64+XBDHCHN),""" FIELD = """,$P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,2),"""",!
|
||
|
|
F XBDHI=1:1:7 W $E($T(TEXT+XBDHI),4,99),!
|
||
|
|
W !
|
||
|
|
CNEXT ;
|
||
|
|
S DIR(0)="NO^1:8:",DIR("A")="Your choice",DIR("?")="Enter the number of the editing function or <CR> to go on"
|
||
|
|
D ^DIR
|
||
|
|
KILL DIR
|
||
|
|
S XBDHX=Y
|
||
|
|
I "^"[XBDHX KILL XBDHECHN Q
|
||
|
|
G @("C"_XBDHX)
|
||
|
|
;
|
||
|
|
C1 ;
|
||
|
|
S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5)=(XBDHHDW-$L(XBDHHDR))\2
|
||
|
|
D ^XBDHD1
|
||
|
|
G START
|
||
|
|
;
|
||
|
|
C2 ;
|
||
|
|
S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5)=0
|
||
|
|
D ^XBDHD1
|
||
|
|
G START
|
||
|
|
;
|
||
|
|
C3 ;
|
||
|
|
W !!
|
||
|
|
C31 ;
|
||
|
|
S DIR(0)="NO^"_$L(XBDHHDR)_":"_(XBDHNSL+XBDHHDW)_":",DIR("A")="New field width"
|
||
|
|
D ^DIR
|
||
|
|
KILL DIR
|
||
|
|
S XBDHX=Y
|
||
|
|
I "^"[XBDHX G START
|
||
|
|
I XBDHX'=+XBDHX W *13,$J("",IOM),*13,*7,*7 G C31
|
||
|
|
I (XBDHX<$L(XBDHHDR))!(XBDHX>(XBDHNSL+XBDHHDW)) W *7,*7,*13,$J("",IOM),*13 G C31
|
||
|
|
S XBDHHDW=XBDHX,$P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,4)=XBDHX G:$E($P(^(XBDHCHN),V,5)) C1
|
||
|
|
D ^XBDHD1
|
||
|
|
G START
|
||
|
|
;
|
||
|
|
C4 ;
|
||
|
|
W !!
|
||
|
|
S DIR(0)="FO^1:"_XBDHHDW_"",DIR("A")="New header name"
|
||
|
|
D ^DIR
|
||
|
|
KILL DIR
|
||
|
|
S XBDHX=Y
|
||
|
|
I XBDHX="" G C8
|
||
|
|
I XBDHX=U G START
|
||
|
|
I $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5) S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,3)=XBDHX,XBDHHDR=XBDHX G C1
|
||
|
|
S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,3)=XBDHX
|
||
|
|
D ^XBDHD1
|
||
|
|
G START
|
||
|
|
;
|
||
|
|
C5 ;
|
||
|
|
S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,6)="+"
|
||
|
|
W !!,"ENTRIES RIGHT JUSTIFIED TO A WIDTH OF ",XBDHHDW," COLUMNS"
|
||
|
|
H 2
|
||
|
|
D ^XBDHD1
|
||
|
|
G START
|
||
|
|
;
|
||
|
|
C6 ;
|
||
|
|
S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,7)="+"
|
||
|
|
W !!,"ENTRIES WILL BE WORD WRAPPED TO A WIDTH OF ",XBDHHDW," COLUMNS"
|
||
|
|
H 2
|
||
|
|
D ^XBDHD1
|
||
|
|
G START
|
||
|
|
;
|
||
|
|
C7 ;
|
||
|
|
I '$D(XBDHECHN) KILL ^TMP("XBDH",$J,"HEADER",XBDHCHN) D ^XBDHD1 Q
|
||
|
|
S X=""
|
||
|
|
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 "."
|
||
|
|
S XBDHTEMP=^TMP("XBDH",$J,"HEADER")
|
||
|
|
KILL ^TMP("XBDH",$J,"HT",XBDHECHN),^TMP("XBDH",$J,"HEADER")
|
||
|
|
S X=""
|
||
|
|
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 "."
|
||
|
|
S ^TMP("XBDH",$J,"HEADER")=XBDHTEMP
|
||
|
|
KILL ^TMP("XBDH",$J,"HT"),XBDHTEMP
|
||
|
|
KILL XBDHECHN
|
||
|
|
D ^XBDHD1
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
C8 ;
|
||
|
|
S XBDHFROM=$S($D(XBDHECHN):XBDHECHN,1:XBDHCHN),XBDHFROM=$C(64+XBDHFROM)
|
||
|
|
S X=""
|
||
|
|
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)
|
||
|
|
I XBDHCHN<2 W *7,*13,$J("",IOM),*13 G CNEXT
|
||
|
|
W *13,$J("",IOM),*13
|
||
|
|
;
|
||
|
|
MOVE ;
|
||
|
|
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"
|
||
|
|
D ^DIR
|
||
|
|
KILL DIR
|
||
|
|
S XBDHTO=Y
|
||
|
|
I "^"[XBDHTO W ! G START
|
||
|
|
I XBDHTO'?1U W *7,*7,*13,$J("",IOM),*13 G MOVE
|
||
|
|
I XBDHTO]$C(64+XBDHCHN) W *7,*7,*13,$J("",IOM),*13 G MOVE
|
||
|
|
I XBDHFROM=XBDHTO W *7,*13,$J("",IOM),*13 G MOVE
|
||
|
|
S XBDHFROM=$A(XBDHFROM)-64,XBDHTO=$A(XBDHTO)-64
|
||
|
|
S XBDHX=XBDHTO+.1
|
||
|
|
S:(XBDHFROM>XBDHTO) XBDHX=XBDHTO-.1
|
||
|
|
S ^TMP("XBDH",$J,"HT",XBDHX)=^TMP("XBDH",$J,"HEADER",XBDHFROM)
|
||
|
|
S Y=""
|
||
|
|
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)
|
||
|
|
S XBDHTEMP=^TMP("XBDH",$J,"HEADER")
|
||
|
|
KILL ^TMP("XBDH",$J,"HT",XBDHFROM),^TMP("XBDH",$J,"HEADER")
|
||
|
|
S X=""
|
||
|
|
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)
|
||
|
|
S ^TMP("XBDH",$J,"HEADER")=XBDHTEMP
|
||
|
|
KILL ^TMP("XBDH",$J,"HT"),XBDHTEMP,XBDHECHN
|
||
|
|
D ^XBDHD1
|
||
|
|
G START
|
||
|
|
;
|
||
|
|
TEXT ;
|
||
|
|
;;DO YOU WANT TO MAKE ANY OTHER CHANGES TO THIS HEADER OR ITS FIELD?
|
||
|
|
;;
|
||
|
|
;; <CR> ACCEPT HEADER AS IS
|
||
|
|
;; 1) CENTER HEADER WITHIN FIELD 5) RIGHT JUSTIFY ENTRIES
|
||
|
|
;; 2) UNCENTER HEADER 6) WORD WRAP ENTRIES
|
||
|
|
;; 3) CHANGE FIELD WIDTH 7) REMOVE THIS HEADER
|
||
|
|
;; 4) CHANGE HEADER NAME 8) MOVE THIS HEADER
|
||
|
|
;
|
||
|
|
NOTES ;
|
||
|
|
; MAKES SECONDARY EDITING CHANGES AFTER EACH FIELD IS ENTERED
|
||
|
|
; INPUT = XBDHCHN OR XBDHECHN (XBDHECHN IS THE .A OR .B CHN),^TMP("XBDH",$J,"HEADER",CHN),XBDHTHLW
|
||
|
|
; OUTPUT = RESET ^TMP("XBDH",$J,"HEADER",CHN)
|
||
|
|
; TO INSERT A NEW FIELD SIMPLY APPEND IT TO THE END OF THE LINE AND THE MOVE IT
|