DDBR3 ;SFISC/DCL-SELECT FILE & WP FIELD TO BROWSE ;NOV 04, 1996@13:48
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
LIST(DDBLIST) ;DDBLIST=Target array for file number,ien,field,...
S DDBLIST=-1 ;no selection
EN ;
N %,%H,%ZISOS,A,D,D0,D1,DA,DDBB,DDBDDF,DDBDIC,DDBFRCD,DDBIEN,DDBRCR,DDBX,DIC,DICS,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DX,I,POP,S,X,Y
;S DIC=1,DIC(0)="AEMQ" D ^DIC Q:+Y'>0 ;Select file
D ^DICRW Q:Y'>0
S DIC="^DD("_+Y_",",DIC(0)="AEMQ"
M S DIC("W")="I $P(^(0),U,2) W $S($P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")"
S DIC("S")="I $P(^(0),U,2)"
D ^DIC I +Y'>0,$D(@(DIC_"0,""UP"")")) S DIC="^DD("_+^("UP")_"," G M ;Select field/back out of multiples
Q:+Y'>0
I $P(@(DIC_+Y_",0)"),U,2) S DIC="^DD("_+$P(^(0),U,2)_",",Y=.01 G D:$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",M
D ;
K DIC("S")
S DDBDIC=$$UP^DIQGU(+$P(DIC,"^DD(",2),.DDBDIC),(DDBX,DDBIEN)=""
S DDBFRCD=$$GET^DIQGDD(DDBDIC,"","NAME")_":[",DDBB=0
F S DDBX=$O(DDBDIC(DDBX)) Q:DDBX'<0 D Q:$G(Y)'>0
.K DA D IEN(","_DDBIEN,.DA)
.S DIC=$$ROOT^DIQGU(+DDBDIC(DDBX),","_DDBIEN),DIC(0)="AEMQ" Q:DIC']""
.S DDBRCR=$$CREF^DILF(DIC)
.I $P($G(@DDBRCR@(0)),U,4)'>0 D K DDBIEN Q
..W $C(7),!!,"No Records at "_$S(DDBDIC=+DDBDIC(DDBX):"FILE",1:$P(^DD(+DDBDIC(DDBX),.01,0),U))_" Level.",!
..Q
.D ^DIC I Y'>0 K DDBIEN Q
.S DDBIEN=+Y_","_DDBIEN
.S DDBFRCD=DDBFRCD_$S(DDBB:"\",1:"")_$$GET^DIQG(+DDBDIC(DDBX),DDBIEN,.01),DDBB=1
.K DA D IEN(DDBIEN,.DA)
.Q
DISP ;
S DDBDDF=$O(^DD(+DDBDIC(-1),"SB",+DDBDIC(0),"")) Q:'DDBDDF
S DDBFRCD=DDBFRCD_"] (wp): "_$P(^DD(DDBDIC(0),.01,0),"^")
I $D(DDBIEN) D Q
.N DDBX S DDBX=$P($$GET^DIQG(+DDBDIC(-1),DDBIEN,DDBDDF,"B"),"$CREF$",2)
.S DDBLIST=$D(@DDBX)
.S DDBLIST(1)=+DDBDIC(-1)
.S DDBLIST(2)=DDBIEN
.S DDBLIST(3)=DDBDDF
.S DDBLIST(4)="N"
.S DDBLIST(5)=DDBFRCD
.S DDBLIST(6)=DDBX
.Q
Q
IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)="" S DA(I-1)=$P(IEN,",",I)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBR3 2234 printed Apr 09, 2024@21:56:19 Page 2
DDBR3 ;SFISC/DCL-SELECT FILE & WP FIELD TO BROWSE ;NOV 04, 1996@13:48
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
LIST(DDBLIST) ;DDBLIST=Target array for file number,ien,field,...
+1 ;no selection
SET DDBLIST=-1
EN ;
+1 NEW %,%H,%ZISOS,A,D,D0,D1,DA,DDBB,DDBDDF,DDBDIC,DDBFRCD,DDBIEN,DDBRCR,DDBX,DIC,DICS,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DX,I,POP,S,X,Y
+2 ;S DIC=1,DIC(0)="AEMQ" D ^DIC Q:+Y'>0 ;Select file
+3 DO ^DICRW
if Y'>0
QUIT
+4 SET DIC="^DD("_+Y_","
SET DIC(0)="AEMQ"
M SET DIC("W")="I $P(^(0),U,2) W $S($P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")"
+1 SET DIC("S")="I $P(^(0),U,2)"
+2 ;Select field/back out of multiples
DO ^DIC
IF +Y'>0
IF $DATA(@(DIC_"0,""UP"")"))
SET DIC="^DD("_+^("UP")_","
GOTO M
+3 if +Y'>0
QUIT
+4 IF $PIECE(@(DIC_+Y_",0)"),U,2)
SET DIC="^DD("_+$PIECE(^(0),U,2)_","
SET Y=.01
if $PIECE(^DD(+$PIECE(^(0),U,2),.01,0),U,2)["W"
GOTO D
GOTO M
D ;
+1 KILL DIC("S")
+2 SET DDBDIC=$$UP^DIQGU(+$PIECE(DIC,"^DD(",2),.DDBDIC)
SET (DDBX,DDBIEN)=""
+3 SET DDBFRCD=$$GET^DIQGDD(DDBDIC,"","NAME")_":["
SET DDBB=0
+4 FOR
SET DDBX=$ORDER(DDBDIC(DDBX))
if DDBX'<0
QUIT
Begin DoDot:1
+5 KILL DA
DO IEN(","_DDBIEN,.DA)
+6 SET DIC=$$ROOT^DIQGU(+DDBDIC(DDBX),","_DDBIEN)
SET DIC(0)="AEMQ"
if DIC']""
QUIT
+7 SET DDBRCR=$$CREF^DILF(DIC)
+8 IF $PIECE($GET(@DDBRCR@(0)),U,4)'>0
Begin DoDot:2
+9 WRITE $CHAR(7),!!,"No Records at "_$SELECT(DDBDIC=+DDBDIC(DDBX):"FILE",1:$PIECE(^DD(+DDBDIC(DDBX),.01,0),U))_" Level.",!
+10 QUIT
End DoDot:2
KILL DDBIEN
QUIT
+11 DO ^DIC
IF Y'>0
KILL DDBIEN
QUIT
+12 SET DDBIEN=+Y_","_DDBIEN
+13 SET DDBFRCD=DDBFRCD_$SELECT(DDBB:"\",1:"")_$$GET^DIQG(+DDBDIC(DDBX),DDBIEN,.01)
SET DDBB=1
+14 KILL DA
DO IEN(DDBIEN,.DA)
+15 QUIT
End DoDot:1
if $GET(Y)'>0
QUIT
DISP ;
+1 SET DDBDDF=$ORDER(^DD(+DDBDIC(-1),"SB",+DDBDIC(0),""))
if 'DDBDDF
QUIT
+2 SET DDBFRCD=DDBFRCD_"] (wp): "_$PIECE(^DD(DDBDIC(0),.01,0),"^")
+3 IF $DATA(DDBIEN)
Begin DoDot:1
+4 NEW DDBX
SET DDBX=$PIECE($$GET^DIQG(+DDBDIC(-1),DDBIEN,DDBDDF,"B"),"$CREF$",2)
+5 SET DDBLIST=$DATA(@DDBX)
+6 SET DDBLIST(1)=+DDBDIC(-1)
+7 SET DDBLIST(2)=DDBIEN
+8 SET DDBLIST(3)=DDBDDF
+9 SET DDBLIST(4)="N"
+10 SET DDBLIST(5)=DDBFRCD
+11 SET DDBLIST(6)=DDBX
+12 QUIT
End DoDot:1
QUIT
+13 QUIT
IEN(IEN,DA) SET DA=$PIECE(IEN,",")
NEW I
FOR I=2:1
if $PIECE(IEN,",",I)=""
QUIT
SET DA(I-1)=$PIECE(IEN,",",I)
+1 QUIT
