Routine: XBDHDF

XBDHDF ; IHS/ADC/GTH - GETS FIELD INFO FOR HEADER LINE EDITOR ; [ 02/07/97   3:02 PM ]

 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997

NEW ;

 NEW XBDHXX,XBDHQUIT

VAR ;

 S X=^TMP("XBDH",$J,"STACK",XBDHLIFO),XBDHDFN=$P(X,U),XBDHDFNA=$P(X,U,2),XBDHDSUB=$P(X,U,3),XBDHDPTH=$P(X,U,4)

 KILL X

 I $D(XBDHMFLG) KILL XBDHMFLG S Y="" G OK1

MORE ;

 D PATH

GETFIELD ;

 S Z=$J("",(XBDHLIFO*2)-2)_$S(XBDHCHN=1:"First",1:"Then")_" print "_$S(XBDHLIFO>1:(XBDHDFNA_" "),1:"")_XBDHDSUB_"field"

 S A=""

 I $D(XBDHMULT) S A=XBDHMULT,XBDHMFLG="" KILL XBDHMULT

 S Z=Z_": "

 I A]"" S Z=Z_A_"//"

 W !,Z

 R Y:DTIME

 E  S Y=U

 I Y="" S Y=A

 I Y="?" W !!,"Enter field name,number,computed expr.,MUMPS code,jump syntax or '??' for list",!! G GETFIELD

 I Y="^" W !! Q

 I Y="",XBDHCHN=1 W ! G GETFIELD

 I Y="",XBDHLIFO=1 W !! Q

OK1 ;

 I Y="" KILL ^TMP("XBDH",$J,"STACK",XBDHLIFO) S XBDHLIFO=XBDHLIFO-1,XBDHDPTH=$P(XBDHDPTH,";",1,XBDHLIFO)_";" W !!! G VAR

 I Y?1"."1U,$E(Y,2)']$C(63+XBDHCHN) S XBDHECHN=($A($E(Y,2))-64) Q

 S XBDHXX=Y

 I $E(Y,$L(Y))=":" D ^XBDHDF1 G VAR:Y'=-1,OUT:A="^",GETFIELD

 S DIC(0)="EZ",DIC="^DD(XBDHDFN,",X=Y

 D ^DIC

 I X="??" W !! G GETFIELD

 I Y'=-1 D OK S X=$P(^DD(XBDHDFN,+Y,0),U,2) I X?1.9N1"."2N.E D MULTIPLE I Z="VAR" G VAR

 I Y'=-1 Q

CKMUMPS ;

 D ^DIM

 I $D(X) W !,"MUMPS EXPRESSION ENTERED",!! D MUMPS G @X

CKM1 ;

 S Y=XBDHXX

 I $E(Y,$L(Y))'=":" D ^XBDHDF1 G VAR:Y'=-1,OUT:A="^"

 D COMPUTED

 G:$D(XBDHQUIT) OUT

W !

 Q:$D(XBDHHDN)

 G GETFIELD

OK ;

 S XBDHHDNO=+Y,XBDHHDN=$P(Y,U,2)

COMPUTED ;

 I XBDHXX="NUMBER" S (XBDHHDN,XBDHHDNO)=XBDHXX KILL XBDHXX Q

 S X=XBDHXX

 D ^DIM

 I $D(X) G C1

W !

 S DIR(0)="YO",DIR("A")="This is a computed expression, right",DIR("B")="YES"

 D ^DIR

 KILL DIR

 I Y=U W !! Q

 I 'Y KILL Y,XBDHHDN W !,"SORRY, I DON'T UNDERSTAND THIS ENTRY...TRY AGAIN",!!,*7 Q

C1 ;

 S XBDHHDN="",XBDHHDNO=XBDHXX

 KILL XBDHXX

MUMPS ;

 S %=1

 W !,"DOES THIS MUMPS EXPRESSION REQUIRE A COLUMN HEADER"

 D YN^DICN

 I %Y=U S X="OUT" Q

 I $E(%Y)'="N" W ! S X="CKM1" Q

 F I=1:1 I '$D(^TMP("XBDH",$J,"HEADER",XBDHCHN,I)) S ^(I)=XBDHXX Q

 S X="GETFIELD"

 W !!!

MULTIPLE ;

 S Z=^DD(+X,.01,0)

 I $P(Z,U,2)["W" W "    (word-processing)" Q

 W "      (multiple)"

 S Z=$O(^DD(+X,0,"NM","")),XBDHLIFO=XBDHLIFO+1,XBDHDPTH=XBDHDPTH_Z_";"

 S ^TMP("XBDH",$J,"STACK",XBDHLIFO)=+X_U_Z_U_"SUB-"_U_XBDHDPTH

 S Z=$O(^DD(+X,.01))

 S:Z'=+Z XBDHMULT=$P(^DD(+X,.01,0),U)

 W !!

 S Z="VAR"

PATH ;

 NEW A,X,Y,Z

 S X="CURRENTLY PRINTING FIELDS FROM THE ",A=0,Y=$L(XBDHDPTH,";")

 I XBDHDPTH="" S X=X_"'"_XBDHPDNA_"'"_" FILE" G LINE

DECI ;

 S Y=Y-1

 G:Y=0 LAST

 S A=A+1,Z=$P(XBDHDPTH,";",Y)

 I A>1 S X=X_"OF THE "

 I $E(Z,$L(Z))=":" S X=X_"'"_$P(^TMP("XBDH",$J,"STACK",XBDHLIFO),U,2)_"'"_" FILE" G LINE

 S X=X_"'"_Z_"'"_" SUB-FILE "

 G DECI

LAST ;

 I A S X=X_"OF THE "

 S X=X_"'"_XBDHPDNA_"'"_" FILE"

LINE ;

 W !!,X,!!

OUT ;

 S Y="^"

NOTES ;

 ; INTERPRETS THE ANSWER TO THE "THEN ENTER FIELD: " QUERY

 ; INPUT = ^TMP("XBDH",$J,"STACK",XBDHLIFO) [XBDHDFN^XBDHDFNA^XBDHDSUB^XBDHDPTH],XBDHCHN,XBDHLIFO

 ; OUTPUT = XBDHHDNO,XBDHHDN

 ; IF FIELD IS A MULTIPLE, IT RESETS PATH AND LIFO AND ASKS FOR SUBFILE.  IF ONLY .01 FIELD OF SUBFILE EXISTS, IT PROMPTS FOR IT.

 ; ANY ANSWER IT CANT FIGURE OUT IS TREATED (AT LEAST TEMPORARILY) AS A COMPUTED FIELD

 ; IF ANSWER IS A RELATIONAL JUMP (ie ENDS IN ':') IT CHECKS ITS LEGALITY,RESETS PATH AND LIFO.

 ; MUMPS EXPRSSIONS ARE ATTACHED TO THE SUCCEEDING FIELD AS THE SUBSCRIPT ^TMP("XBDH",$J,"HEADER",X,Y) AND WILL FOLLOW THIS FIELD IF IT IS MOVED OR REMOVED

 ; IF USER IS IN A SUBFILE OR JUMPED-TO FILE , PRESSING <CR> WILL MOVE HIM TO THE NEXT HIGHER LEVEL

XBDHDF    ; IHS/ADC/GTH - GETS FIELD INFO FOR HEADER LINE EDITOR ; [ 02/07/97   3:02 PM ]

 +1       ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997

 +2       ;

NEW       ;

 +1        NEW XBDHXX,XBDHQUIT

VAR       ;

 +1        SET X=^TMP("XBDH",$JOB,"STACK",XBDHLIFO)

           SET XBDHDFN=$PIECE(X,U)

           SET XBDHDFNA=$PIECE(X,U,2)

           SET XBDHDSUB=$PIECE(X,U,3)

           SET XBDHDPTH=$PIECE(X,U,4)

 +2        KILL X

 +3        IF $DATA(XBDHMFLG)

               KILL XBDHMFLG

               SET Y=""

               GOTO OK1

MORE      ;

 +1        DO PATH

GETFIELD  ;

 +1        SET Z=$JUSTIFY("",(XBDHLIFO*2)-2)_$SELECT(XBDHCHN=1:"First",1:"Then")_" print "_$SELECT(XBDHLIFO>1:(XBDHDFNA_" "),1:"")_XBDHDSUB_"field"

 +2        SET A=""

 +3        IF $DATA(XBDHMULT)

               SET A=XBDHMULT

               SET XBDHMFLG=""

               KILL XBDHMULT

 +4        SET Z=Z_": "

 +5        IF A]""

               SET Z=Z_A_"//"

 +6        WRITE !,Z

 +7        READ Y:DTIME

 +8       IF '$TEST

               SET Y=U

 +9        IF Y=""

               SET Y=A

 +10       IF Y="?"

               WRITE !!,"Enter field name,number,computed expr.,MUMPS code,jump syntax or '??' for list",!!

               GOTO GETFIELD

 +11       IF Y="^"

               WRITE !!

               QUIT

 +12       IF Y=""

               IF XBDHCHN=1

                   WRITE !

                   GOTO GETFIELD

 +13       IF Y=""

               IF XBDHLIFO=1

                   WRITE !!

                   QUIT

OK1       ;

 +1        IF Y=""

               KILL ^TMP("XBDH",$JOB,"STACK",XBDHLIFO)

               SET XBDHLIFO=XBDHLIFO-1

               SET XBDHDPTH=$PIECE(XBDHDPTH,";",1,XBDHLIFO)_";"

               WRITE !!!

               GOTO VAR

 +2        IF Y?1"."1U

               IF $EXTRACT(Y,2)']$CHAR(63+XBDHCHN)

                   SET XBDHECHN=($ASCII($EXTRACT(Y,2))-64)

                   QUIT

 +3        SET XBDHXX=Y

 +4        IF $EXTRACT(Y,$LENGTH(Y))=":"

               DO ^XBDHDF1

               IF Y'=-1

                   GOTO VAR

               IF A="^"

                   GOTO OUT

               GOTO GETFIELD

 +5        SET DIC(0)="EZ"

           SET DIC="^DD(XBDHDFN,"

           SET X=Y

 +6        DO ^DIC

 +7        IF X="??"

               WRITE !!

               GOTO GETFIELD

 +8        IF Y'=-1

               DO OK

               SET X=$PIECE(^DD(XBDHDFN,+Y,0),U,2)

               IF X?1.9N1"."2N.E

                   DO MULTIPLE

                   IF Z="VAR"

                       GOTO VAR

 +9        IF Y'=-1

               QUIT

CKMUMPS   ;

 +1        DO ^DIM

 +2        IF $DATA(X)

               WRITE !,"MUMPS EXPRESSION ENTERED",!!

               DO MUMPS

               GOTO @X

CKM1      ;

 +1        SET Y=XBDHXX

 +2        IF $EXTRACT(Y,$LENGTH(Y))'=":"

               DO ^XBDHDF1

               IF Y'=-1

                   GOTO VAR

               IF A="^"

                   GOTO OUT

 +3        DO COMPUTED

 +4        IF $DATA(XBDHQUIT)

               GOTO OUT

 +5        WRITE !

 +6        IF $DATA(XBDHHDN)

               QUIT

 +7        GOTO GETFIELD

 +8       ;

OK        ;

 +1        SET XBDHHDNO=+Y

           SET XBDHHDN=$PIECE(Y,U,2)

 +2        QUIT

 +3       ;

COMPUTED  ;

 +1        IF XBDHXX="NUMBER"

               SET (XBDHHDN,XBDHHDNO)=XBDHXX

               KILL XBDHXX

               QUIT

 +2        SET X=XBDHXX

 +3        DO ^DIM

 +4        IF $DATA(X)

               GOTO C1

 +5        WRITE !

 +6        SET DIR(0)="YO"

           SET DIR("A")="This is a computed expression, right"

           SET DIR("B")="YES"

 +7        DO ^DIR

 +8        KILL DIR

 +9        IF Y=U

               WRITE !!

               QUIT

 +10       IF 'Y

               KILL Y,XBDHHDN

               WRITE !,"SORRY, I DON'T UNDERSTAND THIS ENTRY...TRY AGAIN",!!,*7

               QUIT

C1        ;

 +1        SET XBDHHDN=""

           SET XBDHHDNO=XBDHXX

 +2        KILL XBDHXX

 +3        QUIT

 +4       ;

MUMPS     ;

 +1        SET %=1

 +2        WRITE !,"DOES THIS MUMPS EXPRESSION REQUIRE A COLUMN HEADER"

 +3        DO YN^DICN

 +4        IF %Y=U

               SET X="OUT"

               QUIT

 +5        IF $EXTRACT(%Y)'="N"

               WRITE !

               SET X="CKM1"

               QUIT

 +6        FOR I=1:1

               IF '$DATA(^TMP("XBDH",$JOB,"HEADER",XBDHCHN,I))

                   SET ^(I)=XBDHXX

                   QUIT

 +7        SET X="GETFIELD"

 +8        WRITE !!!

 +9        QUIT

 +10      ;

MULTIPLE  ;

 +1        SET Z=^DD(+X,.01,0)

 +2        IF $PIECE(Z,U,2)["W"

               WRITE "    (word-processing)"

               QUIT

 +3        WRITE "      (multiple)"

 +4        SET Z=$ORDER(^DD(+X,0,"NM",""))

           SET XBDHLIFO=XBDHLIFO+1

           SET XBDHDPTH=XBDHDPTH_Z_";"

 +5        SET ^TMP("XBDH",$JOB,"STACK",XBDHLIFO)=+X_U_Z_U_"SUB-"_U_XBDHDPTH

 +6        SET Z=$ORDER(^DD(+X,.01))

 +7        IF Z'=+Z

               SET XBDHMULT=$PIECE(^DD(+X,.01,0),U)

 +8        WRITE !!

 +9        SET Z="VAR"

 +10       QUIT

 +11      ;

PATH      ;

 +1        NEW A,X,Y,Z

 +2        SET X="CURRENTLY PRINTING FIELDS FROM THE "

           SET A=0

           SET Y=$LENGTH(XBDHDPTH,";")

 +3        IF XBDHDPTH=""

               SET X=X_"'"_XBDHPDNA_"'"_" FILE"

               GOTO LINE

DECI      ;

 +1        SET Y=Y-1

 +2        IF Y=0

               GOTO LAST

 +3        SET A=A+1

           SET Z=$PIECE(XBDHDPTH,";",Y)

 +4        IF A>1

               SET X=X_"OF THE "

 +5        IF $EXTRACT(Z,$LENGTH(Z))=":"

               SET X=X_"'"_$PIECE(^TMP("XBDH",$JOB,"STACK",XBDHLIFO),U,2)_"'"_" FILE"

               GOTO LINE

 +6        SET X=X_"'"_Z_"'"_" SUB-FILE "

 +7        GOTO DECI

 +8       ;

LAST      ;

 +1        IF A

               SET X=X_"OF THE "

 +2        SET X=X_"'"_XBDHPDNA_"'"_" FILE"

LINE      ;

 +1        WRITE !!,X,!!

 +2        QUIT

 +3       ;

OUT       ;

 +1        SET Y="^"

 +2        QUIT

 +3       ;

NOTES     ;

 +1       ; INTERPRETS THE ANSWER TO THE "THEN ENTER FIELD: " QUERY

 +2       ; INPUT = ^TMP("XBDH",$J,"STACK",XBDHLIFO) [XBDHDFN^XBDHDFNA^XBDHDSUB^XBDHDPTH],XBDHCHN,XBDHLIFO

 +3       ; OUTPUT = XBDHHDNO,XBDHHDN

 +4       ; IF FIELD IS A MULTIPLE, IT RESETS PATH AND LIFO AND ASKS FOR SUBFILE.  IF ONLY .01 FIELD OF SUBFILE EXISTS, IT PROMPTS FOR IT.

 +5       ; ANY ANSWER IT CANT FIGURE OUT IS TREATED (AT LEAST TEMPORARILY) AS A COMPUTED FIELD

 +6       ; IF ANSWER IS A RELATIONAL JUMP (ie ENDS IN ':') IT CHECKS ITS LEGALITY,RESETS PATH AND LIFO.

 +7       ; MUMPS EXPRSSIONS ARE ATTACHED TO THE SUCCEEDING FIELD AS THE SUBSCRIPT ^TMP("XBDH",$J,"HEADER",X,Y) AND WILL FOLLOW THIS FIELD IF IT IS MOVED OR REMOVED

 +8       ; IF USER IS IN A SUBFILE OR JUMPED-TO FILE , PRESSING <CR> WILL MOVE HIM TO THE NEXT HIGHER LEVEL

XBDHDF.m