DDSZ ;SFISC/MKO-FORM COMPILER ;17JUN2004
;;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.
;
;Prompt, compile
N DDSFRM,DDSDDP,DDSREFS
N C,DIC,X,Y
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
;
S DIC="^DIST(.403,",DIC(0)="AEQZ"
D ^DIC K DIC Q:Y=-1!'$D(^DIST(.403,+Y,0))
S DDSFRM=Y,DDSDDP=$P(Y(0),U,8)
;
W !!,"Compiling "_$P(Y,U,2)_" (#"_+Y_") ...",!
D EN(DDSFRM,DDSDDP)
I $G(DIERR) W $C(7) D MSG^DIALOG("BW")
Q
;
ALL ;Compile all forms
N DDSFRM,DDSDDP,DDSFNUM,DDSREFS
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
W:'$D(DDSQUIET) !,"Compiling all forms ...",!
;
S DDSFNUM=0
F S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM D
. Q:$D(^DIST(.403,DDSFNUM,0))[0
. S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U),DDSDDP=+$P(^(0),U,8)
. S DDSREFS=$$REF^DDS0(DDSFRM)
. W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")"
. D EN(DDSFRM,DDSDDP)
. I $G(DIERR),'$D(DDSQUIET) W !,$C(7) D MSG^DIALOG("BW") W !
Q
;
EN(DDSFRM,DDSDDP,DDSREFS) ;Compile a form
N DDSDO,DDSPG,DDSNDD,DDSPGRP
;
S:'$G(DDSDDP) DDSDDP=$P(^DIST(.403,+DDSFRM,0),U,8)
S:$G(DDSREFS)="" DDSREFS=$$REF^DDS0(DDSFRM)
K @DDSREFS
;
;Find page groups
D PGRP^DDSZ3(+DDSFRM,.DDSPGRP)
;
S DDSPG=0,(DDSDO,DDSNDD)=1
F S DDSPG=$O(^DIST(.403,+DDSFRM,40,DDSPG)) Q:'DDSPG D PG(DDSFRM,DDSPG,DDSDDP,.DDSDO,.DDSNDD) Q:$G(DIERR)
I $G(DIERR) D ERR(DDSFRM,DDSREFS) Q
S $P(^DIST(.403,+DDSFRM,0),U,9,11)=+$G(DDSDO)_U_+$G(DDSNDD)_U_1 ;DDSNDD=1 means don't need a starting DA
Q
;
PG(DDSFRM,DDSPG,DDSDDP,DDSDO,DDSNDD) ;Compile a page
;
Q:$D(^DIST(.403,+DDSFRM,40,DDSPG,0))[0
D:$P($G(^DIST(.403,+DDSFRM,40,DDSPG,1)),U,2)]"" ASUB^DDSZ3(DDSPG,DDSFRM)
;
;Get page coordinates
S DDSPX=$P(^DIST(.403,+DDSFRM,40,DDSPG,0),U,3)
S DDSPY=$P(DDSPX,",")-1,DDSPX=$P(DDSPX,",",2)-1
S:DDSPY<0 DDSPY=0 S:DDSPX<0 DDSPX=0
;
;Compile header block
S DDSB=$P($G(^DIST(.403,+DDSFRM,40,DDSPG,0)),U,2)
I DDSB]"" D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,"",1,"",.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END
;
;Compile all other blocks on page
S DDSBO="" F S DDSBO=$O(^DIST(.403,+DDSFRM,40,DDSPG,40,"AC",DDSBO)) Q:DDSBO="" S DDSB=$O(^(DDSBO,0)) Q:'DDSB D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,"",.DDSDO,.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END
;
D:$D(DDSSCR)!$D(DDSORD) EN^DDSZ2(.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV)
;
END K DDSB,DDSBO,DDSMUL,DDSNAV,DDSORD
K DDSP,DDSPX,DDSPY,DDSREP,DDSRNAV,DDSSCR
Q
;
BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,DDSH,DDSDO,DDSNDD,DDSSCR,DDSNAV,DDSORD) ;
;Compile block
; DDSH = 1 if header block
; DDSDO = killed if any edit blocks
; DDSNDD = killed if any DD fields
;
N DDP
I $D(^DIST(.404,DDSB,0))[0 D BLD^DIALOG(3051,"#"_DDSB) Q
S DDSDN=$P(^DIST(.404,DDSB,0),U,3),DDP=+$P(^(0),U,2)
;
S DDSPTB=""
S:'$G(DDSH) DDSPTB=$G(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,1))
;
;Get DDSBY,DDSBX,DDSTP
I $G(DDSH) S DDSBY=DDSPY,DDSBX=DDSPX,DDSTP="h",DDSREP=1
E D
. S DDSBX=$P(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,0),U,3),DDSTP=$P(^(0),U,4) S DDSREP=$S($G(^(2)):^(2),1:1)
. K:DDSTP="e" DDSDO
. S DDSBY=$P(DDSBX,",")-1,DDSBX=$P(DDSBX,",",2)-1
. S:DDSBY<0 DDSBY=0 S:DDSBX<0 DDSBX=0
. S DDSBY=DDSBY+DDSPY,DDSBX=DDSBX+DDSPX
IND . I DDSREP>1,+$G(^DIST(.403,+DDSFRM,21))=+$P($G(^DIST(.403,+DDSFRM,40,DDSPG,0)),U) D ;RECORD SELECTION PAGE USING REPEATING BLOCK
..N IND
..S IND=$P(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,2),U,2) I IND]"",$D(^DD(+DDSDDP,0,"IX",IND,+DDSDDP)) D
...S IND=^DIC(+DDSDDP,0,"GL")_""""_IND_"""" ;BUILD COMPUTED MULTIPLE OFF THE REPEATING-BLOCK INDEX
...I $D(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL"))
...S ^("COMP MUL")="N D,DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTRT)=$NA("_IND_")),DIMSCNT=$QL(DIMQ) F S DIMQ=$Q(@DIMQ) Q:DIMQ="""" Q:$NA(@DIMQ,DIMSCNT)'=DIMSTRT S D=$QS(DIMQ,$QL(DIMQ)) Q:'D I @DIMQ="""" N D0 S D0=D X DICMX"
..I $G(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL"))]"" S ^("COMP MUL PTR")=+DDSDDP
;
;Set @DDSREFS@(DDSPG,DDSB)
S @DDSREFS@(DDSPG,DDSB)=DDSBY_U_DDSBX_U_$P($G(^DIST(.404,DDSB,0)),U,2)_U_DDSDN_U_DDSTP_$S(DDSREP>1:U_U_+DDSREP,1:"")
;
D:DDSPTB]"" PT^DDSPTR(DDSDDP,DDSPTB,DDSFRM,DDSPG,DDSB)
D EN^DDSZ1(DDSPG,DDSB,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,.DDSNDD,.DDSPGRP,.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV)
;
K DDSBX,DDSBY,DDSDN,DDSPTB,DDSTP
Q
;
ENGRP(DDSFRM) ;Compile a form and all forms that use any of the blocks
;on that form
N DDSLST
D FRMLST(DDSFRM,.DDSLST)
;
;Compile all forms in DDSLST
S DDSFRM=0 F S DDSFRM=$O(DDSLST(DDSFRM)) Q:'DDSFRM D EN(DDSFRM)
Q
;
DELGRP(DDSFRM) ;Uncompile a form and all forms that use any of the blocks
;on that form
N DDSLST
D FRMLST(DDSFRM,.DDSLST)
;
;Uncompile all forms in DDSLST
S DDSFRM=0 F S DDSFRM=$O(DDSLST(DDSFRM)) Q:'DDSFRM D DEL(DDSFRM)
Q
;
ENLIST(DDSROOT) ;Compile all forms in @DDSROOT
N DDSFRM
S DDSFRM=0 F S DDSFRM=$O(@DDSROOT@(DDSFRM)) Q:'DDSFRM D EN(DDSFRM)
Q
;
FRMLST(DDSFRM,DDSLST) ;Build list of forms that contain blocks on this form
N DDSPG,DDSBK
S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG D
. D BLDLST($P($G(^DIST(.403,DDSFRM,40,DDSPG,0)),U,2),.DDSLST)
. S DDSBK=0 F S DDSBK=$O(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK D
.. D BLDLST($P($G(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK,0)),U),.DDSLST)
Q
;
BLDLST(DDSBK,DDSLST) ;Build list of forms that contain a given block
N DDSFRM
Q:'$G(DDSBK)
S DDSFRM=0 F S DDSFRM=$O(^DIST(.403,"AB",DDSBK,DDSFRM)) Q:'DDSFRM S DDSLST(DDSFRM)=""
S DDSFRM=0 F S DDSFRM=$O(^DIST(.403,"AC",DDSBK,DDSFRM)) Q:'DDSFRM S DDSLST(DDSFRM)=""
Q
;
DELALL ;Delete compile global for all forms
N DDSFRM,DDSFNUM,DDSREFS
W:'$D(DDSQUIET) !,"Deleting compiled form data ...",!
;
S DDSFNUM=0
F S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM D
. Q:$D(^DIST(.403,DDSFNUM,0))[0
. S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U)
. W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")"
. D DEL(DDSFRM)
Q
;
DEL(DDSFRM) ;Delete compiled global
N DDSREFS
S DDSREFS=$$REF^DDS0(DDSFRM) K @DDSREFS
S $P(^DIST(.403,+DDSFRM,0),U,11)=""
Q
;
ERR(DDSFRM,DDSREFS) ;Print error, kill compiled global
Q:'$G(DIERR)
N DDSNAM
S DDSNAM=$P(DDSFRM,U,2)
S:DDSNAM="" DDSNAM=$P($G(^DIST(.403,+DDSFRM,0)),U)
D BLD^DIALOG(3002,DDSNAM)
S $P(^DIST(.403,+DDSFRM,0),U,11)=""
K @DDSREFS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSZ 6622 printed Oct 16, 2024@18:44:14 Page 2
DDSZ ;SFISC/MKO-FORM COMPILER ;17JUN2004
+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 ;
+7 ;Prompt, compile
+8 NEW DDSFRM,DDSDDP,DDSREFS
+9 NEW C,DIC,X,Y
+10 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+11 ;
+12 SET DIC="^DIST(.403,"
SET DIC(0)="AEQZ"
+13 DO ^DIC
KILL DIC
if Y=-1!'$DATA(^DIST(.403,+Y,0))
QUIT
+14 SET DDSFRM=Y
SET DDSDDP=$PIECE(Y(0),U,8)
+15 ;
+16 WRITE !!,"Compiling "_$PIECE(Y,U,2)_" (#"_+Y_") ...",!
+17 DO EN(DDSFRM,DDSDDP)
+18 IF $GET(DIERR)
WRITE $CHAR(7)
DO MSG^DIALOG("BW")
+19 QUIT
+20 ;
ALL ;Compile all forms
+1 NEW DDSFRM,DDSDDP,DDSFNUM,DDSREFS
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 if '$DATA(DDSQUIET)
WRITE !,"Compiling all forms ...",!
+4 ;
+5 SET DDSFNUM=0
+6 FOR
SET DDSFNUM=$ORDER(^DIST(.403,DDSFNUM))
if 'DDSFNUM
QUIT
Begin DoDot:1
+7 if $DATA(^DIST(.403,DDSFNUM,0))[0
QUIT
+8 SET DDSFRM=DDSFNUM_U_$PIECE(^DIST(.403,DDSFNUM,0),U)
SET DDSDDP=+$PIECE(^(0),U,8)
+9 SET DDSREFS=$$REF^DDS0(DDSFRM)
+10 if '$DATA(DDSQUIET)
WRITE !?3,$PIECE(DDSFRM,U,2),?35,"(#"_+DDSFRM_")"
+11 DO EN(DDSFRM,DDSDDP)
+12 IF $GET(DIERR)
IF '$DATA(DDSQUIET)
WRITE !,$CHAR(7)
DO MSG^DIALOG("BW")
WRITE !
End DoDot:1
+13 QUIT
+14 ;
EN(DDSFRM,DDSDDP,DDSREFS) ;Compile a form
+1 NEW DDSDO,DDSPG,DDSNDD,DDSPGRP
+2 ;
+3 if '$GET(DDSDDP)
SET DDSDDP=$PIECE(^DIST(.403,+DDSFRM,0),U,8)
+4 if $GET(DDSREFS)=""
SET DDSREFS=$$REF^DDS0(DDSFRM)
+5 KILL @DDSREFS
+6 ;
+7 ;Find page groups
+8 DO PGRP^DDSZ3(+DDSFRM,.DDSPGRP)
+9 ;
+10 SET DDSPG=0
SET (DDSDO,DDSNDD)=1
+11 FOR
SET DDSPG=$ORDER(^DIST(.403,+DDSFRM,40,DDSPG))
if 'DDSPG
QUIT
DO PG(DDSFRM,DDSPG,DDSDDP,.DDSDO,.DDSNDD)
if $GET(DIERR)
QUIT
+12 IF $GET(DIERR)
DO ERR(DDSFRM,DDSREFS)
QUIT
+13 ;DDSNDD=1 means don't need a starting DA
SET $PIECE(^DIST(.403,+DDSFRM,0),U,9,11)=+$GET(DDSDO)_U_+$GET(DDSNDD)_U_1
+14 QUIT
+15 ;
PG(DDSFRM,DDSPG,DDSDDP,DDSDO,DDSNDD) ;Compile a page
+1 ;
+2 if $DATA(^DIST(.403,+DDSFRM,40,DDSPG,0))[0
QUIT
+3 if $PIECE($GET(^DIST(.403,+DDSFRM,40,DDSPG,1)),U,2)]""
DO ASUB^DDSZ3(DDSPG,DDSFRM)
+4 ;
+5 ;Get page coordinates
+6 SET DDSPX=$PIECE(^DIST(.403,+DDSFRM,40,DDSPG,0),U,3)
+7 SET DDSPY=$PIECE(DDSPX,",")-1
SET DDSPX=$PIECE(DDSPX,",",2)-1
+8 if DDSPY<0
SET DDSPY=0
if DDSPX<0
SET DDSPX=0
+9 ;
+10 ;Compile header block
+11 SET DDSB=$PIECE($GET(^DIST(.403,+DDSFRM,40,DDSPG,0)),U,2)
+12 IF DDSB]""
DO BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,"",1,"",.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD)
if $GET(DIERR)
GOTO END
+13 ;
+14 ;Compile all other blocks on page
+15 SET DDSBO=""
FOR
SET DDSBO=$ORDER(^DIST(.403,+DDSFRM,40,DDSPG,40,"AC",DDSBO))
if DDSBO=""
QUIT
SET DDSB=$ORDER(^(DDSBO,0))
if 'DDSB
QUIT
DO BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,"",.DDSDO,.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD)
if $GET(DIERR)
GOTO END
+16 ;
+17 if $DATA(DDSSCR)!$DATA(DDSORD)
DO EN^DDSZ2(.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV)
+18 ;
END KILL DDSB,DDSBO,DDSMUL,DDSNAV,DDSORD
+1 KILL DDSP,DDSPX,DDSPY,DDSREP,DDSRNAV,DDSSCR
+2 QUIT
+3 ;
BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,DDSH,DDSDO,DDSNDD,DDSSCR,DDSNAV,DDSORD) ;
+1 ;Compile block
+2 ; DDSH = 1 if header block
+3 ; DDSDO = killed if any edit blocks
+4 ; DDSNDD = killed if any DD fields
+5 ;
+6 NEW DDP
+7 IF $DATA(^DIST(.404,DDSB,0))[0
DO BLD^DIALOG(3051,"#"_DDSB)
QUIT
+8 SET DDSDN=$PIECE(^DIST(.404,DDSB,0),U,3)
SET DDP=+$PIECE(^(0),U,2)
+9 ;
+10 SET DDSPTB=""
+11 if '$GET(DDSH)
SET DDSPTB=$GET(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,1))
+12 ;
+13 ;Get DDSBY,DDSBX,DDSTP
+14 IF $GET(DDSH)
SET DDSBY=DDSPY
SET DDSBX=DDSPX
SET DDSTP="h"
SET DDSREP=1
+15 IF '$TEST
Begin DoDot:1
+16 SET DDSBX=$PIECE(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,0),U,3)
SET DDSTP=$PIECE(^(0),U,4)
SET DDSREP=$SELECT($GET(^(2)):^(2),1:1)
+17 if DDSTP="e"
KILL DDSDO
+18 SET DDSBY=$PIECE(DDSBX,",")-1
SET DDSBX=$PIECE(DDSBX,",",2)-1
+19 if DDSBY<0
SET DDSBY=0
if DDSBX<0
SET DDSBX=0
+20 SET DDSBY=DDSBY+DDSPY
SET DDSBX=DDSBX+DDSPX
IND ;RECORD SELECTION PAGE USING REPEATING BLOCK
IF DDSREP>1
IF +$GET(^DIST(.403,+DDSFRM,21))=+$PIECE($GET(^DIST(.403,+DDSFRM,40,DDSPG,0)),U)
Begin DoDot:2
+1 NEW IND
+2 SET IND=$PIECE(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,2),U,2)
IF IND]""
IF $DATA(^DD(+DDSDDP,0,"IX",IND,+DDSDDP))
Begin DoDot:3
+3 ;BUILD COMPUTED MULTIPLE OFF THE REPEATING-BLOCK INDEX
SET IND=^DIC(+DDSDDP,0,"GL")_""""_IND_""""
+4 IF $DATA(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL"))
+5 SET ^("COMP MUL")="N D,DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTRT)=$NA("_IND_")),DIMSCNT=$QL(DIMQ) F S DIMQ=$Q(@DIMQ) Q:DIMQ="""" Q:$NA(@DIMQ,DIMSCNT)'=DIMSTRT S D=$QS(DIMQ,$QL(DIMQ)) Q:'D I @DIMQ="""" N D0 S D0=D
X DICMX"
End DoDot:3
+6 IF $GET(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL"))]""
SET ^("COMP MUL PTR")=+DDSDDP
End DoDot:2
End DoDot:1
+7 ;
+8 ;Set @DDSREFS@(DDSPG,DDSB)
+9 SET @DDSREFS@(DDSPG,DDSB)=DDSBY_U_DDSBX_U_$PIECE($GET(^DIST(.404,DDSB,0)),U,2)_U_DDSDN_U_DDSTP_$SELECT(DDSREP>1:U_U_+DDSREP,1:"")
+10 ;
+11 if DDSPTB]""
DO PT^DDSPTR(DDSDDP,DDSPTB,DDSFRM,DDSPG,DDSB)
+12 DO EN^DDSZ1(DDSPG,DDSB,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,.DDSNDD,.DDSPGRP,.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV)
+13 ;
+14 KILL DDSBX,DDSBY,DDSDN,DDSPTB,DDSTP
+15 QUIT
+16 ;
ENGRP(DDSFRM) ;Compile a form and all forms that use any of the blocks
+1 ;on that form
+2 NEW DDSLST
+3 DO FRMLST(DDSFRM,.DDSLST)
+4 ;
+5 ;Compile all forms in DDSLST
+6 SET DDSFRM=0
FOR
SET DDSFRM=$ORDER(DDSLST(DDSFRM))
if 'DDSFRM
QUIT
DO EN(DDSFRM)
+7 QUIT
+8 ;
DELGRP(DDSFRM) ;Uncompile a form and all forms that use any of the blocks
+1 ;on that form
+2 NEW DDSLST
+3 DO FRMLST(DDSFRM,.DDSLST)
+4 ;
+5 ;Uncompile all forms in DDSLST
+6 SET DDSFRM=0
FOR
SET DDSFRM=$ORDER(DDSLST(DDSFRM))
if 'DDSFRM
QUIT
DO DEL(DDSFRM)
+7 QUIT
+8 ;
ENLIST(DDSROOT) ;Compile all forms in @DDSROOT
+1 NEW DDSFRM
+2 SET DDSFRM=0
FOR
SET DDSFRM=$ORDER(@DDSROOT@(DDSFRM))
if 'DDSFRM
QUIT
DO EN(DDSFRM)
+3 QUIT
+4 ;
FRMLST(DDSFRM,DDSLST) ;Build list of forms that contain blocks on this form
+1 NEW DDSPG,DDSBK
+2 SET DDSPG=0
FOR
SET DDSPG=$ORDER(^DIST(.403,DDSFRM,40,DDSPG))
if 'DDSPG
QUIT
Begin DoDot:1
+3 DO BLDLST($PIECE($GET(^DIST(.403,DDSFRM,40,DDSPG,0)),U,2),.DDSLST)
+4 SET DDSBK=0
FOR
SET DDSBK=$ORDER(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK))
if 'DDSBK
QUIT
Begin DoDot:2
+5 DO BLDLST($PIECE($GET(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK,0)),U),.DDSLST)
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
BLDLST(DDSBK,DDSLST) ;Build list of forms that contain a given block
+1 NEW DDSFRM
+2 if '$GET(DDSBK)
QUIT
+3 SET DDSFRM=0
FOR
SET DDSFRM=$ORDER(^DIST(.403,"AB",DDSBK,DDSFRM))
if 'DDSFRM
QUIT
SET DDSLST(DDSFRM)=""
+4 SET DDSFRM=0
FOR
SET DDSFRM=$ORDER(^DIST(.403,"AC",DDSBK,DDSFRM))
if 'DDSFRM
QUIT
SET DDSLST(DDSFRM)=""
+5 QUIT
+6 ;
DELALL ;Delete compile global for all forms
+1 NEW DDSFRM,DDSFNUM,DDSREFS
+2 if '$DATA(DDSQUIET)
WRITE !,"Deleting compiled form data ...",!
+3 ;
+4 SET DDSFNUM=0
+5 FOR
SET DDSFNUM=$ORDER(^DIST(.403,DDSFNUM))
if 'DDSFNUM
QUIT
Begin DoDot:1
+6 if $DATA(^DIST(.403,DDSFNUM,0))[0
QUIT
+7 SET DDSFRM=DDSFNUM_U_$PIECE(^DIST(.403,DDSFNUM,0),U)
+8 if '$DATA(DDSQUIET)
WRITE !?3,$PIECE(DDSFRM,U,2),?35,"(#"_+DDSFRM_")"
+9 DO DEL(DDSFRM)
End DoDot:1
+10 QUIT
+11 ;
DEL(DDSFRM) ;Delete compiled global
+1 NEW DDSREFS
+2 SET DDSREFS=$$REF^DDS0(DDSFRM)
KILL @DDSREFS
+3 SET $PIECE(^DIST(.403,+DDSFRM,0),U,11)=""
+4 QUIT
+5 ;
ERR(DDSFRM,DDSREFS) ;Print error, kill compiled global
+1 if '$GET(DIERR)
QUIT
+2 NEW DDSNAM
+3 SET DDSNAM=$PIECE(DDSFRM,U,2)
+4 if DDSNAM=""
SET DDSNAM=$PIECE($GET(^DIST(.403,+DDSFRM,0)),U)
+5 DO BLD^DIALOG(3002,DDSNAM)
+6 SET $PIECE(^DIST(.403,+DDSFRM,0),U,11)=""
+7 KILL @DDSREFS
+8 QUIT
