- 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
