VistA-IHS-VA_UTILITIES-XB/XBDHD2.m

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