DGDEPU.m

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 ---DGDEPU   1208     printed  Sep 02, 2024@19:27:22                                                                                                                                                                                                      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