AMQQEM3 ; IHS/CMI/THL - FINE TUNES THE HEADER LINE ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;-----
I 'Y Q
S AMQQEMN=Y,AMQQEM3=0
N Y
I '$D(AMQQEM("FIX")) N AMQQFLEN D FLEN^AMQQEM31 I $D(AMQQQUIT) Q
I $D(AMQQSTOP) G EXIT
RUN F AMQQEM3=1:1:5 D @$P("LIST^DATE^TYPE^TUNE^LIST",U,AMQQEM3) I $D(AMQQQUIT)!($G(AMQQEMFN)>98)!($D(AMQQSTOP)) Q
EXIT I $D(AMQQSTOP) W *7 S AMQQEMFS=$P(AMQQEMFS,U,1,$L(AMQQEMFS,U)-2)_U K AMQQSTOP,@G@(AMQQEMN) D LIST
K AMQQEM3,AMQQEMAX,AMQQEMP,DIRUT,DIROUT,DUOUT,DTOUT
Q
;
LIST ; - EP -
N T K H
I AMQQEMFS="" Q
S J=1
S (I,N)=0
S H(1)=""
S T=0
F AMQQEMFN=1:1 S A=$P(AMQQEMFS,U,AMQQEMFN) Q:A="" D
.S X=$P(@G@(A,0),U,6)
.S Y=$P(@G@(A,0),U,7)
.I 'Y,A=$G(AMQQEMN),$D(AMQQFLEN) S Y=AMQQFLEN
.I 'Y,$G(AMQQEM("FIX")) S Y=AMQQEM("FIX"),$P(@G@(A,0),U,7)=AMQQEM("FIX")
.I '$D(AMQQEM("FIX")) S Y=Y+1 ; ADD 1 SPACE FOR THE DELIMITER
.S X=$E(X,1,Y)
.S Z=""
.S $P(Z," ",((Y+1)-$L(X)))=""
.S T=T+Y
.I (Y+N)>78 S:AMQQEMFN>1 J=J+1 S N=0,H(J)=""
.S I=I+1
.S N=N+Y
.S H(J)=H(J)_X_Z_";"_Y_";"_$C(64+I)_U
I AMQQEMFN<99 D DISP
Q
;
DISP N A,D,I,X,Y,Z,%,J,N,K,T S (T,K)=0
S D=$G(AMQQEM("DEL"))
S:D="TAB" D="t"
S:D="UP ARROW" D=U
W @IOF
F J=1:1 Q:'$D(H(J)) S N=0 W:J>1 ! D
.F I=1:1 S X=$P(H(J),U,I) Q:X="" W $P(X,";") S N=N+$P(X,";",2)
.W !
.F I=1:1 S X=$P(H(J),U,I) Q:X="" S K=K+1,Y=$P(X,";",2),T=T+Y,Z=$P(X,";",3) S:$P(AMQQEMFS,U,K)=AMQQEMN&(AMQQEM3'=5) Z=U S %="",$P(%,Z,Y+$D(AMQQEM("FIX")))="" W %,D
.I $D(H(J+1)) Q
.S A=78-N
.S:N>78 A=78-(N#78)
.S:(AMQQEM("LEN")-T)<A A=AMQQEM("LEN")-T
.S %=""
.S $P(%,".",A+1)=""
.W %
.W:(AMQQEM("LEN")-T)>A ">"
S %=""
S $P(%,"-",78)=""
W !,%
Q
;
TUNE I $D(AMQQEMKL) D T21 W !!,"This field cancelled..." H 2 K AMQQEMKL Q
W @IOF
D LIST
W !
S %=$P(@G@(AMQQEMN,0),U,6)
I %="" S %=$P(^(0),U,3)
W "Edit field/variable = """,%,""""
S DIR(0)="SO^0:NO ADDITIONAL CHANGES;1:DATA TYPE;2:DELETE;3:MOVE;4:RENAME;5:TRANSFORM (MUMPS code, programmers only)"
S DIR(0)=DIR(0)_";6:"_$S($D(AMQQEM("FIX")):"WIDTH OF FIELD",1:"SUBSTITUTE DELIMITER CHARACTER")
S DIR(0)=DIR(0)_";7:PUT VALUE IN QUOTES"
I '$D(AMQQEM("FIX")) S DIR(0)=DIR(0)_";8:CHANGE FIELD WIDTH"
S DIR("A")=" Your choice"
S DIR("B")="NO ADDITIONAL CHANGES"
D ^DIR
K DIR
S:$D(DUOUT) DIRUT=1
I Y?1."^" S AMQQQUIT="" Q
I 'Y Q
I Y=2 D T2 Q
I Y=8 S Y=9
I Y=7 S Y=8
I Y=6,'$D(AMQQEM("FIX")) S Y=7
D MARK^AMQQEMAN,@("T"_Y)
I $D(AMQQQUIT) Q
D LIST
G TUNE
Q
;
DATE I $P(@G@(AMQQEMN,0),U,4)="D",'$D(AMQQEM("DATE TRANS")) K DIR D Q
.D ^AMQQEM21
.I $D(AMQQQUIT) Q
.I $D(AMQQEMNO) K AMQQEMNO S AMQQEMKL="" Q
.F %=0:0 S %=$O(@G@(%)) Q:'% I $P(^(%,0),U,4)="D" S ^(2)=AMQQEM("DATE TRANS")
D MARK^AMQQEMAN
Q
;
TYPE I $G(AMQQEM("DATA"))'=2!($D(AMQQEMKL)) Q
W "DATA TYPE",!
TYPE1 S %=$P(@G@(AMQQEMN,0),U,4)
S DIR("B")=$S(%="D":"D",%="N":"N",1:"F")
S DIR(0)="S^N:NUMBER;D:DATE;F:FREE TEXT;M:MONEY($dollars.cents)"
S DIR("A")="Data type"
D ^DIR
K DIR
S:$D(DUOUT) DIRUT=1
I X?1."^" S AMQQQUIT="" Q
S $P(@G@(AMQQEMN,0),U,4)=Y
Q
;
T1 W "VIEW/EDIT DATA TYPE",!
D TYPE1
Q
;
T2 W "DELETE",!
S DIR(0)="YO",DIR("A")="Are you sure that you want to delete this segment"
D ^DIR
K DIR
S:$D(DUOUT) DIRUT=1
I X?1."^" S AMQQQUIT="" Q
I 'Y Q
T21 F %=1:1 S X=$P(AMQQEMFS,U,%) Q:X="" I X=AMQQEMN S AMQQEMFS=$P(AMQQEMFS,U,1,%-1)_U_$P(AMQQEMFS,U,%+1,99) S:$P(AMQQEMFS,U)="" AMQQEMFS=$P(AMQQEMFS,U,2,99) Q
I AMQQEMFS="" W @IOF
Q
;
T3 W "MOVE",!
I $L(AMQQEMFS,U)=2 W *7,"Whoops, you have only defined one segment. Request denied..." H 3 Q
S X=0
F %=1:1 S Y=$P(AMQQEMFS,U,%) Q:Y="" I Y S X=X+1 I Y=AMQQEMN S AMQQEMP=%
S %(1)=$S(AMQQEMP=1:"B",1:"A")
S %(2)=$S(AMQQEMP=X:$C(64+X-1),1:$C(64+X))
S AMQQEMAX=X
I 'X W " ??",*7 Q
I X=2 S AMQQEMFS=$P(AMQQEMFS,U,2)_U_$P(AMQQEMFS,U)_U Q
S DIR("B")="("_%(1)_"-"_%(2)_")"
S DIR(0)="FO^:"
S DIR("A")="Move to which segment"
D ^DIR
K DIR
S:$D(DUOUT) DIRUT=1
I "^"[X Q
I X?2."^" S AMQQQUIT="" Q
I X'?1U W " ??",*7 D MARK^AMQQEMAN G T3
I ($A(X)-64)>AMQQEMAX W " ??",*7 G T3
I $P(AMQQEMFS,U,$A(X)-64)=AMQQEMN W " ??",*7 G T3
S Z=$P(AMQQEMFS,U,AMQQEMP)
S $P(AMQQEMFS,U,AMQQEMP)=""
I $E(AMQQEMFS)=U S AMQQEMFS=$E(AMQQEMFS,2,999)
I AMQQEMFS["^^" S AMQQEMFS=$P(AMQQEMFS,"^^")_U_$P(AMQQEMFS,"^^",2)
S $P(AMQQEMFS,U,$A(X)-64)=Z_U_$P(AMQQEMFS,U,$A(X)-64)
Q
;
T4 W "RENAME FIELD",!
I $P(@G@(AMQQEMN,0),U,6)="" S $P(^(0),U,6)=$P(^(0),U,3) W "Current field name: ",$P(^(0),U,6)
S DIR(0)="FO^1:"_AMQQEM("HLEN")
S DIR("A")="Enter new name"
D ^DIR
K DIR
S:$D(DUOUT) DIRUT=1
I "^"[X Q
I "^^"=X S AMQQQUIT="" Q
S $P(@G@(AMQQEMN,0),U,6)=Y
Q
;
T5 D T5^AMQQEM31
Q
;
T6 D T6^AMQQEM31
Q
;
T7 D T7^AMQQEM31
Q
;
T8 D T8^AMQQEM31
Q
;
T9 D T6^AMQQEM31
Q
;
AMQQEM3 ; IHS/CMI/THL - FINE TUNES THE HEADER LINE ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;-----
+3 IF 'Y
QUIT
+4 SET AMQQEMN=Y
SET AMQQEM3=0
+5 NEW Y
+6 IF '$DATA(AMQQEM("FIX"))
NEW AMQQFLEN
DO FLEN^AMQQEM31
IF $DATA(AMQQQUIT)
QUIT
+7 IF $DATA(AMQQSTOP)
GOTO EXIT
RUN FOR AMQQEM3=1:1:5
DO @$PIECE("LIST^DATE^TYPE^TUNE^LIST",U,AMQQEM3)
IF $DATA(AMQQQUIT)!($GET(AMQQEMFN)>98)!($DATA(AMQQSTOP))
QUIT
EXIT IF $DATA(AMQQSTOP)
WRITE *7
SET AMQQEMFS=$PIECE(AMQQEMFS,U,1,$LENGTH(AMQQEMFS,U)-2)_U
KILL AMQQSTOP,@G@(AMQQEMN)
DO LIST
+1 KILL AMQQEM3,AMQQEMAX,AMQQEMP,DIRUT,DIROUT,DUOUT,DTOUT
+2 QUIT
+3 ;
LIST ; - EP -
+1 NEW T
KILL H
+2 IF AMQQEMFS=""
QUIT
+3 SET J=1
+4 SET (I,N)=0
+5 SET H(1)=""
+6 SET T=0
+7 FOR AMQQEMFN=1:1
SET A=$PIECE(AMQQEMFS,U,AMQQEMFN)
IF A=""
QUIT
Begin DoDot:1
+8 SET X=$PIECE(@G@(A,0),U,6)
+9 SET Y=$PIECE(@G@(A,0),U,7)
+10 IF 'Y
IF A=$GET(AMQQEMN)
IF $DATA(AMQQFLEN)
SET Y=AMQQFLEN
+11 IF 'Y
IF $GET(AMQQEM("FIX"))
SET Y=AMQQEM("FIX")
SET $PIECE(@G@(A,0),U,7)=AMQQEM("FIX")
+12 ; ADD 1 SPACE FOR THE DELIMITER
IF '$DATA(AMQQEM("FIX"))
SET Y=Y+1
+13 SET X=$EXTRACT(X,1,Y)
+14 SET Z=""
+15 SET $PIECE(Z," ",((Y+1)-$LENGTH(X)))=""
+16 SET T=T+Y
+17 IF (Y+N)>78
IF AMQQEMFN>1
SET J=J+1
SET N=0
SET H(J)=""
+18 SET I=I+1
+19 SET N=N+Y
+20 SET H(J)=H(J)_X_Z_";"_Y_";"_$CHAR(64+I)_U
End DoDot:1
+21 IF AMQQEMFN<99
DO DISP
+22 QUIT
+23 ;
DISP NEW A,D,I,X,Y,Z,%,J,N,K,T
SET (T,K)=0
+1 SET D=$GET(AMQQEM("DEL"))
+2 IF D="TAB"
SET D="t"
+3 IF D="UP ARROW"
SET D=U
+4 WRITE @IOF
+5 FOR J=1:1
IF '$DATA(H(J))
QUIT
SET N=0
IF J>1
WRITE !
Begin DoDot:1
+6 FOR I=1:1
SET X=$PIECE(H(J),U,I)
IF X=""
QUIT
WRITE $PIECE(X,";")
SET N=N+$PIECE(X,";",2)
+7 WRITE !
+8 FOR I=1:1
SET X=$PIECE(H(J),U,I)
IF X=""
QUIT
SET K=K+1
SET Y=$PIECE(X,";",2)
SET T=T+Y
SET Z=$PIECE(X,";",3)
IF $PIECE(AMQQEMFS,U,K)=AMQQEMN&(AMQQEM3'=5)
SET Z=U
SET %=""
SET $PIECE(%,Z,Y+$DATA(AMQQEM("FIX")))=""
WRITE %,D
+9 IF $DATA(H(J+1))
QUIT
+10 SET A=78-N
+11 IF N>78
SET A=78-(N#78)
+12 IF (AMQQEM("LEN")-T)<A
SET A=AMQQEM("LEN")-T
+13 SET %=""
+14 SET $PIECE(%,".",A+1)=""
+15 WRITE %
+16 IF (AMQQEM("LEN")-T)>A
WRITE ">"
End DoDot:1
+17 SET %=""
+18 SET $PIECE(%,"-",78)=""
+19 WRITE !,%
+20 QUIT
+21 ;
TUNE IF $DATA(AMQQEMKL)
DO T21
WRITE !!,"This field cancelled..."
HANG 2
KILL AMQQEMKL
QUIT
+1 WRITE @IOF
+2 DO LIST
+3 WRITE !
+4 SET %=$PIECE(@G@(AMQQEMN,0),U,6)
+5 IF %=""
SET %=$PIECE(^(0),U,3)
+6 WRITE "Edit field/variable = """,%,""""
+7 SET DIR(0)="SO^0:NO ADDITIONAL CHANGES;1:DATA TYPE;2:DELETE;3:MOVE;4:RENAME;5:TRANSFORM (MUMPS code, programmers only)"
+8 SET DIR(0)=DIR(0)_";6:"_$SELECT($DATA(AMQQEM("FIX")):"WIDTH OF FIELD",1:"SUBSTITUTE DELIMITER CHARACTER")
+9 SET DIR(0)=DIR(0)_";7:PUT VALUE IN QUOTES"
+10 IF '$DATA(AMQQEM("FIX"))
SET DIR(0)=DIR(0)_";8:CHANGE FIELD WIDTH"
+11 SET DIR("A")=" Your choice"
+12 SET DIR("B")="NO ADDITIONAL CHANGES"
+13 DO ^DIR
+14 KILL DIR
+15 IF $DATA(DUOUT)
SET DIRUT=1
+16 IF Y?1."^"
SET AMQQQUIT=""
QUIT
+17 IF 'Y
QUIT
+18 IF Y=2
DO T2
QUIT
+19 IF Y=8
SET Y=9
+20 IF Y=7
SET Y=8
+21 IF Y=6
IF '$DATA(AMQQEM("FIX"))
SET Y=7
+22 DO MARK^AMQQEMAN
DO @("T"_Y)
+23 IF $DATA(AMQQQUIT)
QUIT
+24 DO LIST
+25 GOTO TUNE
+26 QUIT
+27 ;
DATE IF $PIECE(@G@(AMQQEMN,0),U,4)="D"
IF '$DATA(AMQQEM("DATE TRANS"))
KILL DIR
Begin DoDot:1
+1 DO ^AMQQEM21
+2 IF $DATA(AMQQQUIT)
QUIT
+3 IF $DATA(AMQQEMNO)
KILL AMQQEMNO
SET AMQQEMKL=""
QUIT
+4 FOR %=0:0
SET %=$ORDER(@G@(%))
IF '%
QUIT
IF $PIECE(^(%,0),U,4)="D"
SET ^(2)=AMQQEM("DATE TRANS")
End DoDot:1
QUIT
+5 DO MARK^AMQQEMAN
+6 QUIT
+7 ;
TYPE IF $GET(AMQQEM("DATA"))'=2!($DATA(AMQQEMKL))
QUIT
+1 WRITE "DATA TYPE",!
TYPE1 SET %=$PIECE(@G@(AMQQEMN,0),U,4)
+1 SET DIR("B")=$SELECT(%="D":"D",%="N":"N",1:"F")
+2 SET DIR(0)="S^N:NUMBER;D:DATE;F:FREE TEXT;M:MONEY($dollars.cents)"
+3 SET DIR("A")="Data type"
+4 DO ^DIR
+5 KILL DIR
+6 IF $DATA(DUOUT)
SET DIRUT=1
+7 IF X?1."^"
SET AMQQQUIT=""
QUIT
+8 SET $PIECE(@G@(AMQQEMN,0),U,4)=Y
+9 QUIT
+10 ;
T1 WRITE "VIEW/EDIT DATA TYPE",!
+1 DO TYPE1
+2 QUIT
+3 ;
T2 WRITE "DELETE",!
+1 SET DIR(0)="YO"
SET DIR("A")="Are you sure that you want to delete this segment"
+2 DO ^DIR
+3 KILL DIR
+4 IF $DATA(DUOUT)
SET DIRUT=1
+5 IF X?1."^"
SET AMQQQUIT=""
QUIT
+6 IF 'Y
QUIT
T21 FOR %=1:1
SET X=$PIECE(AMQQEMFS,U,%)
IF X=""
QUIT
IF X=AMQQEMN
SET AMQQEMFS=$PIECE(AMQQEMFS,U,1,%-1)_U_$PIECE(AMQQEMFS,U,%+1,99)
IF $PIECE(AMQQEMFS,U)=""
SET AMQQEMFS=$PIECE(AMQQEMFS,U,2,99)
QUIT
+1 IF AMQQEMFS=""
WRITE @IOF
+2 QUIT
+3 ;
T3 WRITE "MOVE",!
+1 IF $LENGTH(AMQQEMFS,U)=2
WRITE *7,"Whoops, you have only defined one segment. Request denied..."
HANG 3
QUIT
+2 SET X=0
+3 FOR %=1:1
SET Y=$PIECE(AMQQEMFS,U,%)
IF Y=""
QUIT
IF Y
SET X=X+1
IF Y=AMQQEMN
SET AMQQEMP=%
+4 SET %(1)=$SELECT(AMQQEMP=1:"B",1:"A")
+5 SET %(2)=$SELECT(AMQQEMP=X:$CHAR(64+X-1),1:$CHAR(64+X))
+6 SET AMQQEMAX=X
+7 IF 'X
WRITE " ??",*7
QUIT
+8 IF X=2
SET AMQQEMFS=$PIECE(AMQQEMFS,U,2)_U_$PIECE(AMQQEMFS,U)_U
QUIT
+9 SET DIR("B")="("_%(1)_"-"_%(2)_")"
+10 SET DIR(0)="FO^:"
+11 SET DIR("A")="Move to which segment"
+12 DO ^DIR
+13 KILL DIR
+14 IF $DATA(DUOUT)
SET DIRUT=1
+15 IF "^"[X
QUIT
+16 IF X?2."^"
SET AMQQQUIT=""
QUIT
+17 IF X'?1U
WRITE " ??",*7
DO MARK^AMQQEMAN
GOTO T3
+18 IF ($ASCII(X)-64)>AMQQEMAX
WRITE " ??",*7
GOTO T3
+19 IF $PIECE(AMQQEMFS,U,$ASCII(X)-64)=AMQQEMN
WRITE " ??",*7
GOTO T3
+20 SET Z=$PIECE(AMQQEMFS,U,AMQQEMP)
+21 SET $PIECE(AMQQEMFS,U,AMQQEMP)=""
+22 IF $EXTRACT(AMQQEMFS)=U
SET AMQQEMFS=$EXTRACT(AMQQEMFS,2,999)
+23 IF AMQQEMFS["^^"
SET AMQQEMFS=$PIECE(AMQQEMFS,"^^")_U_$PIECE(AMQQEMFS,"^^",2)
+24 SET $PIECE(AMQQEMFS,U,$ASCII(X)-64)=Z_U_$PIECE(AMQQEMFS,U,$ASCII(X)-64)
+25 QUIT
+26 ;
T4 WRITE "RENAME FIELD",!
+1 IF $PIECE(@G@(AMQQEMN,0),U,6)=""
SET $PIECE(^(0),U,6)=$PIECE(^(0),U,3)
WRITE "Current field name: ",$PIECE(^(0),U,6)
+2 SET DIR(0)="FO^1:"_AMQQEM("HLEN")
+3 SET DIR("A")="Enter new name"
+4 DO ^DIR
+5 KILL DIR
+6 IF $DATA(DUOUT)
SET DIRUT=1
+7 IF "^"[X
QUIT
+8 IF "^^"=X
SET AMQQQUIT=""
QUIT
+9 SET $PIECE(@G@(AMQQEMN,0),U,6)=Y
+10 QUIT
+11 ;
T5 DO T5^AMQQEM31
+1 QUIT
+2 ;
T6 DO T6^AMQQEM31
+1 QUIT
+2 ;
T7 DO T7^AMQQEM31
+1 QUIT
+2 ;
T8 DO T8^AMQQEM31
+1 QUIT
+2 ;
T9 DO T6^AMQQEM31
+1 QUIT
+2 ;
