Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m

    r613 r623  
    1 XQ5     ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;01/30/2008
    2         ;;8.0;KERNEL;**44,130,484**;Jul 10, 1995;Build 2
    3         ; Per VHA Directive 2004-038, this routine should not be modified.
    4         ; Option & Input Template: XUEDITOPT
    5 DIP     ;
    6         K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1)
    7         S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
    8 DIP1    ;
    9         D:$G(DUZ0) PRNT
    10         D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0
    11 BY      ;
    12         D:$G(DUZ0) SORT
    13         K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1)
    14         S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
    15 BY1     ;
    16         D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR
    17 TEM     ;
    18         I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY
    19         S XQ(64)=X
    20 FR      K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(65)=X
    21 TO      K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(66)=X
    22         D PUT G Q1
    23 DIE     ;
    24         S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
    25         K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1)
    26         G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR""))  F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q"
    27 DIE1    ;
    28         D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1
    29 PUT     S X=0 F  S X=$O(XQ(X)) Q:X'>0  S ^DIC(19,DA,X)=XQ(X)
    30         Q
    31         ;
    32 Q       W *7,!,"NO CHANGE MADE TO OPTION LOGIC"
    33 Q1      K XQDIC,XQ,Y S DIC=DIE Q
    34         ;
    35 DIC     S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2)
    36         S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
    37         I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q
    38         W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED"
    39         S %=$S(XQ(31)["L":0,1:2) D YN^DICN
    40         I %=1 I XQ(31)'["L" S XQ(31)=XQ(31)_"L"
    41         I %=2 I XQ(31)["L" S XQ(31)=$TR(XQ(31),"L")
    42 A       Q
    43         ;
    44 DIQ     ;
    45         S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
    46         K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: "
    47         I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2)
    48         G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
    49 DIQ1    ;
    50         D ^DIC K DIC G:Y<0 Q  S (XQ(80),XQ(30))=$P(^(0,"GL"),U,2)
    51         S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
    52         D PUT G Q1
    53         ;
    54 NAME    ;
    55         I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
    56         F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
    57         I 0
    58         Q
    59 NAMEOK  S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q
    60         ;
    61 CHKNAME ;Called from the input transform of the .01 field of the Option File
    62         Q:$D(DIFROM)!($D(ZTQUEUED))  K XQPK
    63         I $D(DIC(0))#2,DIC(0)'["E" Q
    64         D NAME E  D EN^DDIOL("Not a known package or a local namespace.") Q
    65         D EN^DDIOL("  Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q
    66         ;
    67 PRNT    W !,?16,"*** IMPORTANT PLEASE READ ***",!
    68         W !,"By selecting a new Print/Sort Template below, your defaults will"
    69         W !,"be changed. Your defaults are currently set as follows (see below)."
    70         W !,"Should you desire to keep the defaults as they are, or to revise"
    71         W !,"one or more, enter an '^' up-arrow, without selecting a new"
    72         W !,"template name."
    73         W !!,?23,"Default Values",!,?23,"==============",!
    74         W !,?5,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
    75         W ?40,"L.: "_$$GET1^DIQ(19,DA,62)
    76         W !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63)
    77         W ?40,"BY: "_$$GET1^DIQ(19,DA,64)
    78         W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
    79         W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
    80         Q
    81         ;
    82 SORT    W !,?16,"*** IMPORTANT PLEASE READ ***",!
    83         W !,"By selecting a new Sort Template below, your defaults will be"
    84         W !,"changed. Your defaults are currently set as follows (see below)."
    85         W !,"Should you desire to keep the defaults as they are, or to revise"
    86         W !,"one or more, enter an '^' up-arrow, without selecting a new Sort"
    87         W !,"Template."
    88         W !!,?23,"Default Values",!,?23,"==============",!
    89         W ?5,"BY: "_$$GET1^DIQ(19,DA,64)
    90         W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
    91         W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
    92         Q
    93 TEST    W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs.  It does this by looking at the package file.",!!
    94 T1      R !,"NAME: ",X:DTIME,"  " Q:X=""  D CHKNAME G T1
    95 CLEAR   ;Clear fields not used by this option.
    96         I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
    97         I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
    98         I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%)
    99         Q
    100 CLEAR1  S XQI=0 F  S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0  S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI)
    101         K XQI,XQJ
    102         Q
     1XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;09/20/96  15:33
     2 ;;8.0;KERNEL;**44,130**;Jul 10, 1995
     3DIP ;
     4 K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1)
     5 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
     6DIP1 ;
     7 D:$G(DUZ0) PRNT
     8 D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0
     9BY ;
     10 D:$G(DUZ0) SORT
     11 K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1)
     12 S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
     13BY1 ;
     14 D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR
     15TEM ;
     16 I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY
     17 S XQ(64)=X
     18FR K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(65)=X
     19TO K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(66)=X
     20 D PUT G Q1
     21DIE ;
     22 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
     23 K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1)
     24 G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR""))  F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q"
     25DIE1 ;
     26 D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1
     27PUT S X=0 F  S X=$O(XQ(X)) Q:X'>0  S ^DIC(19,DA,X)=XQ(X)
     28 Q
     29 ;
     30Q W *7,!,"NO CHANGE MADE TO OPTION LOGIC"
     31Q1 K XQDIC,XQ,Y S DIC=DIE Q
     32 ;
     33DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2),XQ(31)="AEMQ"
     34 I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q
     35 W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED"
     36 S %=$S($D(^DIC(19,DA,31)):^(31)'["L"+1,1:0) D YN^DICN I %=1 S XQ(31)="AEMQL"
     37A Q
     38 ;
     39DIQ ;
     40 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
     41 K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: "
     42 I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2)
     43 G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
     44DIQ1 ;
     45 D ^DIC K DIC G:Y<0 Q S XQ(31)="AEMQ",(XQ(80),XQ(30))=$P(^(0,"GL"),U,2) D PUT G Q1
     46 ;
     47NAME ;
     48 I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
     49 F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
     50 I 0
     51 Q
     52NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q
     53 ;
     54CHKNAME ;Called from the input transform of the .01 field of the Option File
     55 Q:$D(DIFROM)!($D(ZTQUEUED))  K XQPK
     56 I $D(DIC(0))#2,DIC(0)'["E" Q
     57 D NAME E  D EN^DDIOL("Not a known package or a local namespace.") Q
     58 D EN^DDIOL("  Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q
     59 ;
     60PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",!
     61 W !,"By selecting a new Print/Sort Template below, your defaults will"
     62 W !,"be changed. Your defaults are currently set as follows(see below)."
     63 W !,"Should you desire to keep the defaults as they are, or to revise"
     64 W !,"one or more, enter an '^' up-arrow, without selecting a new"
     65 W !,"template name."
     66 W !!,?23,"Default Values",!,?23,"==============",!
     67 W !,?17,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
     68 W ?40,"L.: "_$$GET1^DIQ(19,DA,62)
     69 W !,?17,"FLDS: "_$$GET1^DIQ(19,DA,63)
     70 W ?40,"BY: "_$$GET1^DIQ(19,DA,64)
     71 W !,?17,"FR: "_$$GET1^DIQ(19,DA,65)
     72 W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
     73 Q
     74 ;
     75SORT W !,?16,"*** IMPORTANT PLEASE READ ***",!
     76 W !,"By selecting a new Sort Template below, your defaults will be"
     77 W !,"changed. Your defaults are currently set as follow(see below)."
     78 W !,"Should you desire to keep the defaults as they are, or to revise"
     79 W !,"one or more, enter an '^' up-arrow, without selecting a new Sort"
     80 W !,"Template."
     81 W !!,?23,"Default Values",!,?23,"==============",!
     82 W ?17,"BY: "_$$GET1^DIQ(19,DA,64)
     83 W !,?17,"FR: "_$$GET1^DIQ(19,DA,65)
     84 W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
     85 Q
     86TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs.  It does this by looking at the package file.",!!
     87T1 R !,"NAME: ",X:DTIME,"  " Q:X=""  D CHKNAME G T1
     88CLEAR ;Clear fields not used by this option.
     89 I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
     90 I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
     91 I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%)
     92 Q
     93CLEAR1 S XQI=0 F  S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0  S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI)
     94 K XQI,XQJ
     95 Q
Note: See TracChangeset for help on using the changeset viewer.