- 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 Jan 18, 2025@03:42:43 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