source: IHS-VA_UTILITIES-XB/trunk/XBDHDF.m@ 1379

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