- 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 Jan 18, 2025@03:44:39 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