DGDEPU ;ALB/CAW/AMA - Dependent Utilities - Generic ;11/3/94
;;5.3;Registration;**45,733**;Aug 13, 1993;Build 15
;
SEL ; -- select processing
;DG*5.3*733 -- added DIR to the list a vars to be NEW'ed
N BG,LST,Y,DIR
S BG=+$O(@VALMAR@("IDX",$S($G(BEG):BEG,1:1),0))
S LST=+$O(@VALMAR@("IDX",$S($G(END):END,1:DGCNT),0))
I 'BG W !!,*7,"There are no '",VALM("ENTITY"),"s' to select.",! S DIR(0)="E" D ^DIR K DIR D OUT G SELQ
S Y=+$P($P(XQORNOD(0),U,4),"=",2)
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
;
; -- check was valid entries
S DGERR=0,DGW=Y
I DGW<BG!(DGW>LST) D
. W !,*7,"Selection '",DGW,"' is not a valid choice."
. D OUT,PAUSE^VALM1
;
SELQ K DIRUT,DTOUT,DUOUT,DIROUT Q
;
OUT ;
S DGERR=1
Q
;
LOOKUP ; Look up the tests that can be added to
;
S DIC("S")="I $P(^(0),U,2)=DFN"
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)
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
S DGMTI=+Y,DGMT0=Y(0) K DIC,Y
LOOKUPQ ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGDEPU 1208 printed Dec 13, 2024@02:42:02 Page 2
DGDEPU ;ALB/CAW/AMA - Dependent Utilities - Generic ;11/3/94
+1 ;;5.3;Registration;**45,733**;Aug 13, 1993;Build 15
+2 ;
SEL ; -- select processing
+1 ;DG*5.3*733 -- added DIR to the list a vars to be NEW'ed
+2 NEW BG,LST,Y,DIR
+3 SET BG=+$ORDER(@VALMAR@("IDX",$SELECT($GET(BEG):BEG,1:1),0))
+4 SET LST=+$ORDER(@VALMAR@("IDX",$SELECT($GET(END):END,1:DGCNT),0))
+5 IF 'BG
WRITE !!,*7,"There are no '",VALM("ENTITY"),"s' to select.",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
DO OUT
GOTO SELQ
+6 SET Y=+$PIECE($PIECE(XQORNOD(0),U,4),"=",2)
+7 IF 'Y
SET DIR(0)="N^"_BG_":"_LST
SET DIR("A")="Select "_VALM("ENTITY")_"(s)"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO OUT
GOTO SELQ
+8 ;
+9 ; -- check was valid entries
+10 SET DGERR=0
SET DGW=Y
+11 IF DGW<BG!(DGW>LST)
Begin DoDot:1
+12 WRITE !,*7,"Selection '",DGW,"' is not a valid choice."
+13 DO OUT
DO PAUSE^VALM1
End DoDot:1
+14 ;
SELQ KILL DIRUT,DTOUT,DUOUT,DIROUT
QUIT
+1 ;
OUT ;
+1 SET DGERR=1
+2 QUIT
+3 ;
LOOKUP ; Look up the tests that can be added to
+1 ;
+2 SET DIC("S")="I $P(^(0),U,2)=DFN"
+3 WRITE !
SET DIC="^DGMT(408.31,"
SET DIC(0)="EQZ"
SET X=DFN
SET D="C"
DO IX^DIC
KILL DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<0)
GOTO LOOKUPQ
+4 IF ('$PIECE($GET(^DG(408.34,+$PIECE(Y(0),"^",23),0)),U,2))!('$PIECE($GET(^DGMT(408.31,+Y,"PRIM")),"^"))
WRITE !?5,*7,"This means test is uneditable and cannot be added to."
GOTO LOOKUP
+5 SET DGMTI=+Y
SET DGMT0=Y(0)
KILL DIC,Y
LOOKUPQ ;
+1 QUIT
