124 lines
3.5 KiB
Mathematica
124 lines
3.5 KiB
Mathematica
XBDHDF ; IHS/ADC/GTH - GETS FIELD INFO FOR HEADER LINE EDITOR ; [ 02/07/97 3:02 PM ]
|
|
;;4.0;XB;;Jul 20, 2009;Build 2
|
|
;
|
|
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
|