source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEPU.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.1 KB
Line 
1DGDEPU ;ALB/CAW/AMA - Dependent Utilities - Generic ;11/3/94
2 ;;5.3;Registration;**45,733**;Aug 13, 1993;Build 15
3 ;
4SEL ; -- select processing
5 ;DG*5.3*733 -- added DIR to the list a vars to be NEW'ed
6 N BG,LST,Y,DIR
7 S BG=+$O(@VALMAR@("IDX",$S($G(BEG):BEG,1:1),0))
8 S LST=+$O(@VALMAR@("IDX",$S($G(END):END,1:DGCNT),0))
9 I 'BG W !!,*7,"There are no '",VALM("ENTITY"),"s' to select.",! S DIR(0)="E" D ^DIR K DIR D OUT G SELQ
10 S Y=+$P($P(XQORNOD(0),U,4),"=",2)
11 I 'Y S DIR(0)="N^"_BG_":"_LST,DIR("A")="Select "_VALM("ENTITY")_"(s)" D ^DIR K DIR I $D(DIRUT) D OUT G SELQ
12 ;
13 ; -- check was valid entries
14 S DGERR=0,DGW=Y
15 I DGW<BG!(DGW>LST) D
16 . W !,*7,"Selection '",DGW,"' is not a valid choice."
17 . D OUT,PAUSE^VALM1
18 ;
19SELQ K DIRUT,DTOUT,DUOUT,DIROUT Q
20 ;
21OUT ;
22 S DGERR=1
23 Q
24 ;
25LOOKUP ; Look up the tests that can be added to
26 ;
27 S DIC("S")="I $P(^(0),U,2)=DFN"
28 W ! S DIC="^DGMT(408.31,",DIC(0)="EQZ",X=DFN,D="C" D IX^DIC K DIC G LOOKUPQ:$D(DTOUT)!($D(DUOUT))!(+Y<0)
29 I ('$P($G(^DG(408.34,+$P(Y(0),"^",23),0)),U,2))!('$P($G(^DGMT(408.31,+Y,"PRIM")),"^")) W !?5,*7,"This means test is uneditable and cannot be added to." G LOOKUP
30 S DGMTI=+Y,DGMT0=Y(0) K DIC,Y
31LOOKUPQ ;
32 Q
Note: See TracBrowser for help on using the repository browser.