DDBR3.m

DDBR3 ;SFISC/DCL-SELECT FILE & WP FIELD TO BROWSE ;NOV 04, 1996@13:48

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

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

DDBR3     ;SFISC/DCL-SELECT FILE & WP FIELD TO BROWSE ;NOV 04, 1996@13:48

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

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