XBDHD2 ; IHS/ADC/GTH - SPECIAL CHOICES ; [ 02/07/97 3:02 PM ]
;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
;
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
XBDHD2 ; IHS/ADC/GTH - SPECIAL CHOICES ; [ 02/07/97 3:02 PM ]
+1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
+2 ;
NEW ;
+1 NEW XBDHFROM,XBDHI,XBDHTEMP,XBDHTO
+2 ;
START ;
+1 IF $DATA(XBDHECHN)
SET XBDHCHN=XBDHECHN
SET XBDHX=^TMP("XBDH",$JOB,"HEADER",XBDHCHN)
SET XBDHHDR=$PIECE(XBDHX,V,3)
SET XBDHHDW=$PIECE(XBDHX,V,4)
+2 WRITE "EDITING HEADER LINE SEGMENT """,$CHAR(64+XBDHCHN),""" FIELD = """,$PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,2),"""",!
+3 FOR XBDHI=1:1:7
WRITE $EXTRACT($TEXT(TEXT+XBDHI),4,99),!
+4 WRITE !
CNEXT ;
+1 SET DIR(0)="NO^1:8:"
SET DIR("A")="Your choice"
SET DIR("?")="Enter the number of the editing function or <CR> to go on"
+2 DO ^DIR
+3 KILL DIR
+4 SET XBDHX=Y
+5 IF "^"[XBDHX
KILL XBDHECHN
QUIT
+6 GOTO @("C"_XBDHX)
+7 ;
C1 ;
+1 SET $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,5)=(XBDHHDW-$LENGTH(XBDHHDR))\2
+2 DO ^XBDHD1
+3 GOTO START
+4 ;
C2 ;
+1 SET $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,5)=0
+2 DO ^XBDHD1
+3 GOTO START
+4 ;
C3 ;
+1 WRITE !!
C31 ;
+1 SET DIR(0)="NO^"_$LENGTH(XBDHHDR)_":"_(XBDHNSL+XBDHHDW)_":"
SET DIR("A")="New field width"
+2 DO ^DIR
+3 KILL DIR
+4 SET XBDHX=Y
+5 IF "^"[XBDHX
GOTO START
+6 IF XBDHX'=+XBDHX
WRITE *13,$JUSTIFY("",IOM),*13,*7,*7
GOTO C31
+7 IF (XBDHX<$LENGTH(XBDHHDR))!(XBDHX>(XBDHNSL+XBDHHDW))
WRITE *7,*7,*13,$JUSTIFY("",IOM),*13
GOTO C31
+8 SET XBDHHDW=XBDHX
SET $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,4)=XBDHX
IF $EXTRACT($PIECE(^(XBDHCHN),V,5))
GOTO C1
+9 DO ^XBDHD1
+10 GOTO START
+11 ;
C4 ;
+1 WRITE !!
+2 SET DIR(0)="FO^1:"_XBDHHDW_""
SET DIR("A")="New header name"
+3 DO ^DIR
+4 KILL DIR
+5 SET XBDHX=Y
+6 IF XBDHX=""
GOTO C8
+7 IF XBDHX=U
GOTO START
+8 IF $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,5)
SET $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,3)=XBDHX
SET XBDHHDR=XBDHX
GOTO C1
+9 SET $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,3)=XBDHX
+10 DO ^XBDHD1
+11 GOTO START
+12 ;
C5 ;
+1 SET $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,6)="+"
+2 WRITE !!,"ENTRIES RIGHT JUSTIFIED TO A WIDTH OF ",XBDHHDW," COLUMNS"
+3 HANG 2
+4 DO ^XBDHD1
+5 GOTO START
+6 ;
C6 ;
+1 SET $PIECE(^TMP("XBDH",$JOB,"HEADER",XBDHCHN),V,7)="+"
+2 WRITE !!,"ENTRIES WILL BE WORD WRAPPED TO A WIDTH OF ",XBDHHDW," COLUMNS"
+3 HANG 2
+4 DO ^XBDHD1
+5 GOTO START
+6 ;
C7 ;
+1 IF '$DATA(XBDHECHN)
KILL ^TMP("XBDH",$JOB,"HEADER",XBDHCHN)
DO ^XBDHD1
QUIT
+2 SET X=""
+3 FOR L=0:0
SET X=$ORDER(^TMP("XBDH",$JOB,"HEADER",X))
IF X=""
QUIT
SET ^TMP("XBDH",$JOB,"HT",X)=^TMP("XBDH",$JOB,"HEADER",X)
WRITE "."
+4 SET XBDHTEMP=^TMP("XBDH",$JOB,"HEADER")
+5 KILL ^TMP("XBDH",$JOB,"HT",XBDHECHN),^TMP("XBDH",$JOB,"HEADER")
+6 SET X=""
+7 FOR I=1:1
SET X=$ORDER(^TMP("XBDH",$JOB,"HT",X))
IF X=""
QUIT
SET ^TMP("XBDH",$JOB,"HEADER",I)=^TMP("XBDH",$JOB,"HT",X)
WRITE "."
+8 SET ^TMP("XBDH",$JOB,"HEADER")=XBDHTEMP
+9 KILL ^TMP("XBDH",$JOB,"HT"),XBDHTEMP
+10 KILL XBDHECHN
+11 DO ^XBDHD1
+12 QUIT
+13 ;
C8 ;
+1 SET XBDHFROM=$SELECT($DATA(XBDHECHN):XBDHECHN,1:XBDHCHN)
SET XBDHFROM=$CHAR(64+XBDHFROM)
+2 SET X=""
+3 FOR XBDHTCHN=0:1
SET X=$ORDER(^TMP("XBDH",$JOB,"HEADER",X))
IF X=""
QUIT
SET ^TMP("XBDH",$JOB,"HT",X)=^(X)
WRITE "."
SET Y=""
FOR L=0:0
SET Y=$ORDER(^TMP("XBDH",$JOB,"HEADER",X,Y))
IF Y=""
QUIT
SET ^TMP("XBDH",$JOB,"HT",X,Y)=^(Y)
+4 IF XBDHCHN<2
WRITE *7,*13,$JUSTIFY("",IOM),*13
GOTO CNEXT
+5 WRITE *13,$JUSTIFY("",IOM),*13
+6 ;
MOVE ;
+1 SET DIR(0)="FO^"
SET DIR("A")="Where do you want to move this header (A - "_$CHAR(64+XBDHTCHN)_")"
SET DIR("?")="Enter a letter which corresponds to a header line field"
+2 DO ^DIR
+3 KILL DIR
+4 SET XBDHTO=Y
+5 IF "^"[XBDHTO
WRITE !
GOTO START
+6 IF XBDHTO'?1U
WRITE *7,*7,*13,$JUSTIFY("",IOM),*13
GOTO MOVE
+7 IF XBDHTO]$CHAR(64+XBDHCHN)
WRITE *7,*7,*13,$JUSTIFY("",IOM),*13
GOTO MOVE
+8 IF XBDHFROM=XBDHTO
WRITE *7,*13,$JUSTIFY("",IOM),*13
GOTO MOVE
+9 SET XBDHFROM=$ASCII(XBDHFROM)-64
SET XBDHTO=$ASCII(XBDHTO)-64
+10 SET XBDHX=XBDHTO+.1
+11 IF (XBDHFROM>XBDHTO)
SET XBDHX=XBDHTO-.1
+12 SET ^TMP("XBDH",$JOB,"HT",XBDHX)=^TMP("XBDH",$JOB,"HEADER",XBDHFROM)
+13 SET Y=""
+14 FOR L=0:0
SET Y=$ORDER(^TMP("XBDH",$JOB,"HEADER",XBDHFROM,Y))
IF Y=""
QUIT
SET ^TMP("XBDH",$JOB,"HT",XBDHX,Y)=^TMP("XBDH",$JOB,"HEADER",XBDHFROM,Y)
+15 SET XBDHTEMP=^TMP("XBDH",$JOB,"HEADER")
+16 KILL ^TMP("XBDH",$JOB,"HT",XBDHFROM),^TMP("XBDH",$JOB,"HEADER")
+17 SET X=""
+18 FOR I=1:1
SET X=$ORDER(^TMP("XBDH",$JOB,"HT",X))
IF X=""
QUIT
SET ^TMP("XBDH",$JOB,"HEADER",I)=^TMP("XBDH",$JOB,"HT",X)
SET Y=""
FOR L=0:0
SET Y=$ORDER(^TMP("XBDH",$JOB,"HT",X,Y))
IF Y=""
QUIT
SET ^TMP("XBDH",$JOB,"HEADER",I,Y)=^TMP("XBDH",$JOB,"HT",X,Y)
+19 SET ^TMP("XBDH",$JOB,"HEADER")=XBDHTEMP
+20 KILL ^TMP("XBDH",$JOB,"HT"),XBDHTEMP,XBDHECHN
+21 DO ^XBDHD1
+22 GOTO START
+23 ;
TEXT ;
+1 ;;DO YOU WANT TO MAKE ANY OTHER CHANGES TO THIS HEADER OR ITS FIELD?
+2 ;;
+3 ;; <CR> ACCEPT HEADER AS IS
+4 ;; 1) CENTER HEADER WITHIN FIELD 5) RIGHT JUSTIFY ENTRIES
+5 ;; 2) UNCENTER HEADER 6) WORD WRAP ENTRIES
+6 ;; 3) CHANGE FIELD WIDTH 7) REMOVE THIS HEADER
+7 ;; 4) CHANGE HEADER NAME 8) MOVE THIS HEADER
+8 ;
NOTES ;
+1 ; MAKES SECONDARY EDITING CHANGES AFTER EACH FIELD IS ENTERED
+2 ; INPUT = XBDHCHN OR XBDHECHN (XBDHECHN IS THE .A OR .B CHN),^TMP("XBDH",$J,"HEADER",CHN),XBDHTHLW
+3 ; OUTPUT = RESET ^TMP("XBDH",$J,"HEADER",CHN)
+4 ; TO INSERT A NEW FIELD SIMPLY APPEND IT TO THE END OF THE LINE AND THE MOVE IT
