- DDSVAL ;SFISC/MKO-GET,PUT FOR DD IELDS ;2OCT2003
- ;;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.
- ;
- GET(DDSFILE,DA,DDSFLD,DDSER,DDSPARM) ;Get value for file/field
- N DDP,DIE,DDSANS,DDSTMP,X
- N DDSVDA,DDSVDDL0,DDSVDL,DDSVDV,DDSVND,DDSVPC,DIERR
- ;
- S DDSANS=""
- I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I"
- ;
- D GDIE() G:$G(DIERR) GETQ G:'$G(DDSVDA) GETQ
- ;
- I DDSFLD[":",$$FIND^DDSLIB(DDSFLD,":") D G GETQ
- . S DDSANS=$$REL^DDSVALM(DDP,.DA,DDSFLD,DDSPARM)
- ;
- S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) GETQ
- ;
- S:$D(DDSREFT)#2 DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD))
- I $D(DDS),$D(DDSREFT)#2,$D(@DDSTMP@("D")) D
- . I $D(@DDSTMP@("M")),'^("M") D Q
- .. S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSVDA,DDSFLD))
- .. M @DDSANS=@DDSTMP@("D")
- . S DDSANS=$G(@DDSTMP@("D")) I DDSPARM["E",$D(^("X"))#2 S DDSANS=^("X")
- E D
- . D GNDPC Q:$G(DIERR)
- . I DDSVPC=0,DDSVDV["W" D GETWP^DDSVALM Q
- . S DDSANS=$$GVAL(DIE,DA,DDSVND,DDSVPC)
- . I DDSPARM["E" S DDSANS=$$EXTERNAL^DILFD(DDP,DDSFLD,"",DDSANS)
- ;
- GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVAL")
- Q DDSANS
- ;
- PUT(DDSFILE,DA,DDSFLD,DDSVAL,DDSER,DDSPARM) ;Put value for file/field
- N DDP,DDSVDA,DDSV0,DDSV02,DDSVDL,DIE
- N DIERR
- ;
- S:$D(DDSVAL)[0 DDSVAL=""
- I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E"
- ;
- D GDIE($D(DDS)#2) G:$G(DIERR) PUTQ G:'$G(DDSVDA) PUTQ
- S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) PUTQ
- I DDSFLD=.01,"@"[DDSVAL D BLD^DIALOG(3086) G PUTQ
- ;
- S DDSV0=^DD(DDP,DDSFLD,0),DDSV02=$P(DDSV0,U,2)
- I +DDSV02 D
- . D MULT^DDSVALM
- E D VALPUT
- ;
- PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVAL")
- Q
- ;
- VALPUT ;Validate and put
- N DDSVY
- I DDSPARM["E" D
- . D VAL^DIE(DDP,DDSVDA,DDSFLD,"ER",DDSVAL,.DDSVY)
- E D
- . D AUXVAL^DIEV(DDP,DDSVDA,DDSFLD,"EIR",DDSVAL,.DDSVY,DDSV0,DDSV02)
- Q:$G(DIERR)
- I DDSVY=DDSVY(0),'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"X")) K DDSVY(0)
- ;
- I $D(DDS) D
- . S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD)) ^("GL")=DIE
- . D UPDATE(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.DDSVY)
- . S DDSCHG=1
- E D
- . N DDSFDA
- . S DDSFDA(DDP,DDSVDA,DDSFLD)=DDSVY
- . D FILE^DIE("","DDSFDA")
- Q
- ;
- UPDATE(DDP,DDSVDA,DA,FLD,PG,Y) ;Store value, repaint
- N DX,DY,BK,DDO,LEN,EXT,PAGE,RJ,REP,VAL
- S (EXT,@DDSREFT@("F"_DDP,DDSVDA,FLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (EXT,^("X"))=Y(0)
- ;
- D:FLD=.01
- . S PAGE=0 F S PAGE=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE)) Q:'PAGE D
- .. S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE,BK)) Q:'BK D
- ... D:$P($G(@DDSREFS@(PAGE,BK)),U,8)
- .... N DDSPTB S DDSPTB=$G(@DDSREFS@(PAGE,BK,"PTB"))
- .... D:DDSPTB]"" RPF^DDS7(DDP,DDSPTB,DDSVDA,.DA)
- ;
- S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK)) Q:'BK D
- . S DDO=0 F S DDO=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK,DDO)) Q:'DDO D
- .. S LEN=$G(@DDSREFS@(PG,BK,DDO,"D")) Q:LEN=""
- .. S DY=+LEN,DX=$P(LEN,U,2),RJ=$P(LEN,U,10),LEN=$P(LEN,U,3)
- .. S REP=$P($G(@DDSREFS@(PG,BK)),U,7)
- .. I $G(REP) D Q:DY=""
- ... N SN,PDA,OFS
- ... S PDA=$G(@DDSREFT@(PG,BK)) I 'PDA S DY="" Q
- ... S REP=$P($G(@DDSREFT@(PG,BK,PDA)),U,2,999) I REP="" S DY="" Q
- ... S SN=$G(@DDSREFT@(PG,BK,PDA,"B",DDSVDA)) I 'SN S DY="" Q
- HITE ... N HITE S HITE=$$HITE^DDSR(BK),OFS=SN-$P(REP,U,2)*HITE ;DJW/GFT
- ... I OFS'<0,$P(REP,U,5)*HITE>OFS S DY=DY+OFS ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW
- ... E S DY=""
- .. S VAL=$P(DDGLVID,DDGLDEL)_$E(EXT,1,LEN)_$P(DDGLVID,DDGLDEL,10)
- .. X IOXY
- .. W $S(RJ:$J("",LEN-$L(EXT))_VAL,1:VAL_$J("",LEN-$L(EXT)))
- ;
- D:$D(@DDSREFS@("PT",DDP,FLD)) RPB^DDS7(DDP,FLD,PG)
- D:$D(@DDSREFS@("COMP",DDP,FLD,PG)) RPCF^DDSCOMP(PG)
- Q
- ;
- GDIE(DDSVL) ;In:
- ; DDSFILE = File # or root
- ; DA = Record array
- ; DDSVL = Flag to lock record
- ;Returns:
- ; DIE = Global root of file
- ; DDP = File #
- ; DDSVDL = Level #
- ; DDSVDA = DA,DA(1),...,
- S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2))
- I DDP=0 D BLD^DIALOG(202,"file") Q
- D GL^DDS10(DDP,.DA,.DIE,.DDSVDL,.DDSVDA,$G(DDSVL))
- Q
- ;
- GNDPC ;In:
- ; DDP = File #
- ; DDSFLD = Field #
- ;Returns:
- ; DDSVDDL0 = 0 node of DD
- ; DDSVND = Node where data resides
- ; DDSVPC = Piece where data resides
- ; DDSVDV = Field specifications
- ; X = Pointed to file root or set of codes
- I $G(DDSFLD)="" D BLD^DIALOG(202,"field") Q
- S DDSVDDL0=$G(^DD(DDP,DDSFLD,0))
- I DDSVDDL0?."^" D Q
- . N I,E
- . S (I("FILE"),E("FILE"))=DDP,I(1)="#"_DDSFLD,E("FIELD")=DDSFLD
- . D BLD^DIALOG(501,.I,.E)
- ;
- S DDSVPC=$P(DDSVDDL0,U,4)
- S DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2)
- S DDSVDV=$P(DDSVDDL0,U,2),X=$P(DDSVDDL0,U,3)
- ;
- N P S P("FILE")=DDP,P("FIELD")=DDSFLD
- I DDSVPC=" " D
- . D BLD^DIALOG(520,"computed",.P)
- I DDSVPC=0 D
- . S DDSVDV=+DDSVDV_$P($G(^DD(+DDSVDV,.01,0)),U,2)
- . D:DDSVDV'["W" BLD^DIALOG(520,"multiple",.P)
- Q
- ;
- GVAL(DIE,DA,ND,PC) ;Get value
- N LN,Y
- S LN=$G(@(DIE_"DA,ND)"))
- I $E(PC)'="E" S Y=$P(LN,U,PC)
- E S Y=$E(LN,+$E(PC,2,999),$P(PC,",",2)) S:Y?." " Y=""
- Q Y
- ;
- FIELD(DDP,FLD) ;Get field number
- N F,P
- S:$E(FLD)="""" FLD=$$UQT^DDSLIB($E(FLD,1,$$AFTQ^DDSLIB(FLD)-1))
- ;
- S F=FLD,P("FILE")=DDP
- I FLD'=+$P(FLD,"E") D Q:$G(DIERR) ""
- . S F=$O(^DD(DDP,"B",FLD,""))
- . I F="" S P(1)=FLD D BLD^DIALOG(501,.P)
- ;
- I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q ""
- Q F
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSVAL 5531 printed Jan 18, 2025@03:44:36 Page 2
- DDSVAL ;SFISC/MKO-GET,PUT FOR DD IELDS ;2OCT2003
- +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 ;
- GET(DDSFILE,DA,DDSFLD,DDSER,DDSPARM) ;Get value for file/field
- +1 NEW DDP,DIE,DDSANS,DDSTMP,X
- +2 NEW DDSVDA,DDSVDDL0,DDSVDL,DDSVDV,DDSVND,DDSVPC,DIERR
- +3 ;
- +4 SET DDSANS=""
- +5 IF $GET(DDSPARM)'["I"
- IF $GET(DDSPARM)'["E"
- SET DDSPARM=$GET(DDSPARM)_"I"
- +6 ;
- +7 DO GDIE()
- if $GET(DIERR)
- GOTO GETQ
- if '$GET(DDSVDA)
- GOTO GETQ
- +8 ;
- +9 IF DDSFLD[":"
- IF $$FIND^DDSLIB(DDSFLD,":")
- Begin DoDot:1
- +10 SET DDSANS=$$REL^DDSVALM(DDP,.DA,DDSFLD,DDSPARM)
- End DoDot:1
- GOTO GETQ
- +11 ;
- +12 SET DDSFLD=$$FIELD(DDP,DDSFLD)
- if $GET(DIERR)
- GOTO GETQ
- +13 ;
- +14 if $DATA(DDSREFT)#2
- SET DDSTMP=$NAME(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD))
- +15 IF $DATA(DDS)
- IF $DATA(DDSREFT)#2
- IF $DATA(@DDSTMP@("D"))
- Begin DoDot:1
- +16 IF $DATA(@DDSTMP@("M"))
- IF '^("M")
- Begin DoDot:2
- +17 SET DDSANS=$NAME(^TMP("DDSWP",$JOB,DDP,DDSVDA,DDSFLD))
- +18 MERGE @DDSANS=@DDSTMP@("D")
- End DoDot:2
- QUIT
- +19 SET DDSANS=$GET(@DDSTMP@("D"))
- IF DDSPARM["E"
- IF $DATA(^("X"))#2
- SET DDSANS=^("X")
- End DoDot:1
- +20 IF '$TEST
- Begin DoDot:1
- +21 DO GNDPC
- if $GET(DIERR)
- QUIT
- +22 IF DDSVPC=0
- IF DDSVDV["W"
- DO GETWP^DDSVALM
- QUIT
- +23 SET DDSANS=$$GVAL(DIE,DA,DDSVND,DDSVPC)
- +24 IF DDSPARM["E"
- SET DDSANS=$$EXTERNAL^DILFD(DDP,DDSFLD,"",DDSANS)
- End DoDot:1
- +25 ;
- GETQ if $GET(DIERR)
- DO ERR^DDSVALM("$$GET^DDSVAL")
- +1 QUIT DDSANS
- +2 ;
- PUT(DDSFILE,DA,DDSFLD,DDSVAL,DDSER,DDSPARM) ;Put value for file/field
- +1 NEW DDP,DDSVDA,DDSV0,DDSV02,DDSVDL,DIE
- +2 NEW DIERR
- +3 ;
- +4 if $DATA(DDSVAL)[0
- SET DDSVAL=""
- +5 IF $GET(DDSPARM)'["I"
- IF $GET(DDSPARM)'["E"
- SET DDSPARM=$GET(DDSPARM)_"E"
- +6 ;
- +7 DO GDIE($DATA(DDS)#2)
- if $GET(DIERR)
- GOTO PUTQ
- if '$GET(DDSVDA)
- GOTO PUTQ
- +8 SET DDSFLD=$$FIELD(DDP,DDSFLD)
- if $GET(DIERR)
- GOTO PUTQ
- +9 IF DDSFLD=.01
- IF "@"[DDSVAL
- DO BLD^DIALOG(3086)
- GOTO PUTQ
- +10 ;
- +11 SET DDSV0=^DD(DDP,DDSFLD,0)
- SET DDSV02=$PIECE(DDSV0,U,2)
- +12 IF +DDSV02
- Begin DoDot:1
- +13 DO MULT^DDSVALM
- End DoDot:1
- +14 IF '$TEST
- DO VALPUT
- +15 ;
- PUTQ if $GET(DIERR)
- DO ERR^DDSVALM("PUT^DDSVAL")
- +1 QUIT
- +2 ;
- VALPUT ;Validate and put
- +1 NEW DDSVY
- +2 IF DDSPARM["E"
- Begin DoDot:1
- +3 DO VAL^DIE(DDP,DDSVDA,DDSFLD,"ER",DDSVAL,.DDSVY)
- End DoDot:1
- +4 IF '$TEST
- Begin DoDot:1
- +5 DO AUXVAL^DIEV(DDP,DDSVDA,DDSFLD,"EIR",DDSVAL,.DDSVY,DDSV0,DDSV02)
- End DoDot:1
- +6 if $GET(DIERR)
- QUIT
- +7 IF DDSVY=DDSVY(0)
- IF '$DATA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"X"))
- KILL DDSVY(0)
- +8 ;
- +9 IF $DATA(DDS)
- Begin DoDot:1
- +10 if '$DATA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD))
- SET ^("GL")=DIE
- +11 DO UPDATE(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.DDSVY)
- +12 SET DDSCHG=1
- End DoDot:1
- +13 IF '$TEST
- Begin DoDot:1
- +14 NEW DDSFDA
- +15 SET DDSFDA(DDP,DDSVDA,DDSFLD)=DDSVY
- +16 DO FILE^DIE("","DDSFDA")
- End DoDot:1
- +17 QUIT
- +18 ;
- UPDATE(DDP,DDSVDA,DA,FLD,PG,Y) ;Store value, repaint
- +1 NEW DX,DY,BK,DDO,LEN,EXT,PAGE,RJ,REP,VAL
- +2 SET (EXT,@DDSREFT@("F"_DDP,DDSVDA,FLD,"D"))=Y
- SET ^("F")=3
- if $DATA(Y(0))#2
- SET (EXT,^("X"))=Y(0)
- +3 ;
- +4 if FLD=.01
- Begin DoDot:1
- +5 SET PAGE=0
- FOR
- SET PAGE=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PAGE))
- if 'PAGE
- QUIT
- Begin DoDot:2
- +6 SET BK=0
- FOR
- SET BK=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PAGE,BK))
- if 'BK
- QUIT
- Begin DoDot:3
- +7 if $PIECE($GET(@DDSREFS@(PAGE,BK)),U,8)
- Begin DoDot:4
- +8 NEW DDSPTB
- SET DDSPTB=$GET(@DDSREFS@(PAGE,BK,"PTB"))
- +9 if DDSPTB]""
- DO RPF^DDS7(DDP,DDSPTB,DDSVDA,.DA)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 ;
- +11 SET BK=0
- FOR
- SET BK=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PG,BK))
- if 'BK
- QUIT
- Begin DoDot:1
- +12 SET DDO=0
- FOR
- SET DDO=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PG,BK,DDO))
- if 'DDO
- QUIT
- Begin DoDot:2
- +13 SET LEN=$GET(@DDSREFS@(PG,BK,DDO,"D"))
- if LEN=""
- QUIT
- +14 SET DY=+LEN
- SET DX=$PIECE(LEN,U,2)
- SET RJ=$PIECE(LEN,U,10)
- SET LEN=$PIECE(LEN,U,3)
- +15 SET REP=$PIECE($GET(@DDSREFS@(PG,BK)),U,7)
- +16 IF $GET(REP)
- Begin DoDot:3
- +17 NEW SN,PDA,OFS
- +18 SET PDA=$GET(@DDSREFT@(PG,BK))
- IF 'PDA
- SET DY=""
- QUIT
- +19 SET REP=$PIECE($GET(@DDSREFT@(PG,BK,PDA)),U,2,999)
- IF REP=""
- SET DY=""
- QUIT
- +20 SET SN=$GET(@DDSREFT@(PG,BK,PDA,"B",DDSVDA))
- IF 'SN
- SET DY=""
- QUIT
- HITE ;DJW/GFT
- NEW HITE
- SET HITE=$$HITE^DDSR(BK)
- SET OFS=SN-$PIECE(REP,U,2)*HITE
- +1 ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW
- IF OFS'<0
- IF $PIECE(REP,U,5)*HITE>OFS
- SET DY=DY+OFS
- +2 IF '$TEST
- SET DY=""
- End DoDot:3
- if DY=""
- QUIT
- +3 SET VAL=$PIECE(DDGLVID,DDGLDEL)_$EXTRACT(EXT,1,LEN)_$PIECE(DDGLVID,DDGLDEL,10)
- +4 XECUTE IOXY
- +5 WRITE $SELECT(RJ:$JUSTIFY("",LEN-$LENGTH(EXT))_VAL,1:VAL_$JUSTIFY("",LEN-$LENGTH(EXT)))
- End DoDot:2
- End DoDot:1
- +6 ;
- +7 if $DATA(@DDSREFS@("PT",DDP,FLD))
- DO RPB^DDS7(DDP,FLD,PG)
- +8 if $DATA(@DDSREFS@("COMP",DDP,FLD,PG))
- DO RPCF^DDSCOMP(PG)
- +9 QUIT
- +10 ;
- GDIE(DDSVL) ;In:
- +1 ; DDSFILE = File # or root
- +2 ; DA = Record array
- +3 ; DDSVL = Flag to lock record
- +4 ;Returns:
- +5 ; DIE = Global root of file
- +6 ; DDP = File #
- +7 ; DDSVDL = Level #
- +8 ; DDSVDA = DA,DA(1),...,
- +9 SET DDP=$SELECT(DDSFILE=+DDSFILE:DDSFILE,1:+$PIECE($GET(@(DDSFILE_"0)")),U,2))
- +10 IF DDP=0
- DO BLD^DIALOG(202,"file")
- QUIT
- +11 DO GL^DDS10(DDP,.DA,.DIE,.DDSVDL,.DDSVDA,$GET(DDSVL))
- +12 QUIT
- +13 ;
- GNDPC ;In:
- +1 ; DDP = File #
- +2 ; DDSFLD = Field #
- +3 ;Returns:
- +4 ; DDSVDDL0 = 0 node of DD
- +5 ; DDSVND = Node where data resides
- +6 ; DDSVPC = Piece where data resides
- +7 ; DDSVDV = Field specifications
- +8 ; X = Pointed to file root or set of codes
- +9 IF $GET(DDSFLD)=""
- DO BLD^DIALOG(202,"field")
- QUIT
- +10 SET DDSVDDL0=$GET(^DD(DDP,DDSFLD,0))
- +11 IF DDSVDDL0?."^"
- Begin DoDot:1
- +12 NEW I,E
- +13 SET (I("FILE"),E("FILE"))=DDP
- SET I(1)="#"_DDSFLD
- SET E("FIELD")=DDSFLD
- +14 DO BLD^DIALOG(501,.I,.E)
- End DoDot:1
- QUIT
- +15 ;
- +16 SET DDSVPC=$PIECE(DDSVDDL0,U,4)
- +17 SET DDSVND=$PIECE(DDSVPC,";")
- SET DDSVPC=$PIECE(DDSVPC,";",2)
- +18 SET DDSVDV=$PIECE(DDSVDDL0,U,2)
- SET X=$PIECE(DDSVDDL0,U,3)
- +19 ;
- +20 NEW P
- SET P("FILE")=DDP
- SET P("FIELD")=DDSFLD
- +21 IF DDSVPC=" "
- Begin DoDot:1
- +22 DO BLD^DIALOG(520,"computed",.P)
- End DoDot:1
- +23 IF DDSVPC=0
- Begin DoDot:1
- +24 SET DDSVDV=+DDSVDV_$PIECE($GET(^DD(+DDSVDV,.01,0)),U,2)
- +25 if DDSVDV'["W"
- DO BLD^DIALOG(520,"multiple",.P)
- End DoDot:1
- +26 QUIT
- +27 ;
- GVAL(DIE,DA,ND,PC) ;Get value
- +1 NEW LN,Y
- +2 SET LN=$GET(@(DIE_"DA,ND)"))
- +3 IF $EXTRACT(PC)'="E"
- SET Y=$PIECE(LN,U,PC)
- +4 IF '$TEST
- SET Y=$EXTRACT(LN,+$EXTRACT(PC,2,999),$PIECE(PC,",",2))
- if Y?." "
- SET Y=""
- +5 QUIT Y
- +6 ;
- FIELD(DDP,FLD) ;Get field number
- +1 NEW F,P
- +2 if $EXTRACT(FLD)=""""
- SET FLD=$$UQT^DDSLIB($EXTRACT(FLD,1,$$AFTQ^DDSLIB(FLD)-1))
- +3 ;
- +4 SET F=FLD
- SET P("FILE")=DDP
- +5 IF FLD'=+$PIECE(FLD,"E")
- Begin DoDot:1
- +6 SET F=$ORDER(^DD(DDP,"B",FLD,""))
- +7 IF F=""
- SET P(1)=FLD
- DO BLD^DIALOG(501,.P)
- End DoDot:1
- if $GET(DIERR)
- QUIT ""
- +8 ;
- +9 IF $DATA(^DD(DDP,F,0))[0
- SET P(1)="#"_F
- DO BLD^DIALOG(501,.P)
- QUIT ""
- +10 QUIT F