DDSZ ;SFISC/MKO-FORM COMPILER ;9:41 AM 19 Nov 2001 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**94**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
;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
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
;
;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
DDSZ ;SFISC/MKO-FORM COMPILER ;9:41 AM 19 Nov 2001 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**94**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
+5 ;Prompt, compile
+6 NEW DDSFRM,DDSDDP,DDSREFS
+7 NEW C,DIC,X,Y
+8 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+9 ;
+10 SET DIC="^DIST(.403,"
SET DIC(0)="AEQZ"
+11 DO ^DIC
KILL DIC
IF Y=-1!'$DATA(^DIST(.403,+Y,0))
QUIT
+12 SET DDSFRM=Y
SET DDSDDP=$PIECE(Y(0),U,8)
+13 ;
+14 WRITE !!,"Compiling "_$PIECE(Y,U,2)_" (#"_+Y_") ...",!
+15 DO EN(DDSFRM,DDSDDP)
+16 IF $GET(DIERR)
WRITE $CHAR(7)
DO MSG^DIALOG("BW")
+17 QUIT
+18 ;
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 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
End DoDot:1
+21 ;
+22 ;Set @DDSREFS@(DDSPG,DDSB)
+23 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:"")
+24 ;
+25 IF DDSPTB]""
DO PT^DDSPTR(DDSDDP,DDSPTB,DDSFRM,DDSPG,DDSB)
+26 DO EN^DDSZ1(DDSPG,DDSB,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,.DDSNDD,.DDSPGRP,.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV)
+27 ;
+28 KILL DDSBX,DDSBY,DDSDN,DDSPTB,DDSTP
+29 QUIT
+30 ;
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
