- 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
