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)
Q
;
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
Q
;
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 !!!
Q
;
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"
Q
;
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,!!
Q
;
OUT ;
S Y="^"
Q
;
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
