IBDF19 ;ALB/CJM - ENCOUNTER FORM (compile forms,delete workcopy);NOV 22,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
GARBAGE ;delete unused blocks (belonging to WORKCOPY form)
N IBJUNK,BLK,CR,FORM
;
;first delete unused workcopy blocks
;find the form=WORKCOPY, used as a work area
S IBJUNK=+$O(^IBE(357,"B","WORKCOPY",""))
;clean up blocks not being used
S BLK=0 F S BLK=$O(^IBE(357.1,"C",IBJUNK,BLK)) Q:'BLK L +^IBE(357.1,BLK):1 I $T D DLTBLK^IBDFU3(BLK,IBJUNK,357.1) L -^IBE(357.1,BLK)
W !,"Blocks not belonging to any form have been deleted"
;
;delete cross-references for compilied forms if the forms have been deleted
F CR="AT","AC","AG","AU","AB" S FORM=0 F S FORM=$O(^IBE(357,CR,FORM)) Q:'FORM I '$D(^IBE(357,FORM)) K ^IBE(357,CR,FORM)
W !,"Extraneous cross-references on non-existant forms have been deleted"
Q
;
;
COMPILE ;compiles IBFORM at the form level - leaves blocks already compiled alone
;
;lock the form while compiling
Q:'$$LOCKFORM^IBDFU7(IBFORM)
;compile it only if not already compiled - it could have been compiled by another process while the form was being locked
I $$FORMDSCR^IBDFU1C(.IBFORM) I 'IBFORM("COMPILED") D
.N IBARRAY,IBDEVICE,IBPRINT,DFN,IBCLINIC,IBAPPT,SUB
.S (IBDEVICE("RASTER"),IBDEVICE("GRAPHICS"))=1
.S (IBDEVICE("CRT"),IBDEVICE("LISTMAN"),IBAPPT,IBCLINIC,DFN,IBDEVICE("PCL"))=0
.D UNCMPL(.IBFORM,0)
.D PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,1)
.D ARRAYS^IBDFU1C(.IBFORM,.IBARRAY)
.K ^TMP("IB",$J,"INTERFACES")
.S SUB="" F S SUB=$O(IBARRAY(SUB)) Q:SUB="" K @IBARRAY(SUB)
.D DRWBLKS^IBDF2A
.S:IBFORM("COMPILED")'="F" IBFORM("COMPILED")=1
.S $P(^IBE(357,IBFORM,0),"^",5)=IBFORM("COMPILED")
.; -- if form not scannable and it compiled w/o formtype id...get one
.I 'IBFORM("SCAN"),IBFORM("COMPILED"),'$P(^IBE(357,IBFORM,0),"^",13) S IBFORM("TYPE")=$$FORMTYPE^IBDF18D(1) I IBFORM("TYPE") S $P(^IBE(357,IBFORM,0),"^",13)=IBFORM("TYPE")
.S:$P(^IBE(357,IBFORM,0),"^",13) ^IBE(357,"ADEF",$P(^IBE(357,IBFORM,0),"^",13),IBFORM)=""
.K ^TMP("IB",$J,"INTERFACES"),X,Y,I
D FREEFORM^IBDFU7(IBFORM)
; -- build form spec if form compiled successfully
I IBFORM("SCAN"),IBFORM("COMPILED"),IBFORM("TYPE") D SCAN^IBDFBKS(IBFORM("TYPE"))
Q
;
ASKCMPL(IBFORM) ;ask if the form should be compiled or uncompiled
Q:'$G(IBFORM)
N BLK,QUIT S QUIT=0
I $P($G(^IBE(357,IBFORM,0)),"^",5) D
.W !,"The form is currently compiled. Should it be recompiled?"
.K DIR S DIR(0)="Y",DIR("B")="YES"
.D ^DIR K DIR
.S:$D(DUOUT)!(Y'=1) QUIT=1
Q:QUIT
;uncompile the form
D UNCMPALL(IBFORM)
Q
;
CMPLACTN ;action for compiling a form listed on the screen
N IBFORM
I $G(IBAPI("SELECT"))'="" X IBAPI("SELECT")
I IBFORM D ASKCMPL(IBFORM)
S VALMBCK="R"
Q
;
KILLTBL(IBFORM) ;
; -- marks the FORM DEFINITION TABLE for deletion
; IBFORM("TYPE") is reset to "", pass IBFORM by reference
;
Q:'IBFORM("TYPE")
;
; -- Mark forms for deletion
S $P(^IBD(357.95,IBFORM("TYPE"),0),"^",2)=DT,^IBD(357.95,"ADEL",DT,IBFORM("TYPE"))=""
K ^IBE(357,"ADEF",IBFORM("TYPE"),IBFORM) ; kill cross reference
S IBFORM("TYPE")="",$P(^IBE(357,IBFORM,0),"^",13)=""
Q
;
UNCMPL(IBFORM,FAILED) ;marks the form as not compiled and deletes or marks for deletion the FORM DEFINITION TABLE
;leaves the blocks compiled
;if FAILED means compilation of form was attempted, but failed - mark form accordingly
;IBFORM is the form - if passed by reference IBFORM("TYPE") and IBFORM("COMPILED") are set
;
Q:'IBFORM
N NODE
S NODE=$G(^IBE(357,IBFORM,0))
S IBFORM("SCAN")=$P(NODE,"^",12),IBFORM("TYPE")=$P(NODE,"^",13)
D:IBFORM("TYPE") KILLTBL(.IBFORM)
S IBFORM("COMPILED")=$S($G(FAILED):"F",1:0),$P(^IBE(357,IBFORM,0),"^",5)=IBFORM("COMPILED")
Q
;
UNCMPALL(IBFORM) ;uncompile the form and it's blocks
N BLK
D UNCMPL(IBFORM,0)
;also uncompile all of its blocks
S BLK=0 F S BLK=$O(^IBE(357.1,"C",IBFORM,BLK)) Q:'BLK D UNCMPBLK^IBDF19(BLK)
Q
BLKCHNG(FORM,BLOCK) ;call this if the block is edited - uncompiles the block and form
D UNCMPBLK(BLOCK)
D UNCMPL(FORM)
Q
;
UNCMPBLK(BLOCK) ;delete the compiled version of the block
K ^IBE(357.1,BLOCK,"V"),^IBE(357.1,BLOCK,"S"),^IBE(357.1,BLOCK,"B"),^IBE(357.1,BLOCK,"H")
Q
;
KILL(TYPE) ;deletes the form definition=TYPE
K ^IBD(357.95,"AC",TYPE),^IBD(357.95,TYPE,1)
K ^IBD(357.95,"AD",TYPE),^IBD(357.95,TYPE,2)
K DA S DIK="^IBD(357.95,",DA=TYPE D ^DIK K DIK,DA
Q
;
RECMPALL ;causes all forms to be recompiled
N IBFORM,IBQUIT,DIR,DIRUT,DUOUT,DTOUT
S IBQUIT=0
I '$D(ZTQUEUED) D
.S DIR("?")="Enter 'Yes' to cause all forms to uncompile or 'No' to do nothing. Forms will actually recompile as they are printed."
.S DIR(0)="Y",DIR("A")="Do you really want to Recompile all Forms"
.D ^DIR S IBQUIT='Y
I $G(IBQUIT) W !!,"Okay, nothing recompiled" Q
;
W:'$D(ZTQUEUED) !!,"Uncompiling all forms..."
S IBFORM=0
F S IBFORM=$O(^IBE(357,IBFORM)) Q:'IBFORM D
.Q:'$$LOCKFORM^IBDFU7(IBFORM)
.D UNCMPALL(IBFORM)
.D FREEFORM^IBDFU7(IBFORM)
.W:'$D(ZTQUEUED) "."
W:'$D(ZTQUEUED) !!,"Okay, forms will be recompiled as they are printed."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF19 5161 printed Oct 16, 2024@18:51:47 Page 2
IBDF19 ;ALB/CJM - ENCOUNTER FORM (compile forms,delete workcopy);NOV 22,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
GARBAGE ;delete unused blocks (belonging to WORKCOPY form)
+1 NEW IBJUNK,BLK,CR,FORM
+2 ;
+3 ;first delete unused workcopy blocks
+4 ;find the form=WORKCOPY, used as a work area
+5 SET IBJUNK=+$ORDER(^IBE(357,"B","WORKCOPY",""))
+6 ;clean up blocks not being used
+7 SET BLK=0
FOR
SET BLK=$ORDER(^IBE(357.1,"C",IBJUNK,BLK))
if 'BLK
QUIT
LOCK +^IBE(357.1,BLK):1
IF $TEST
DO DLTBLK^IBDFU3(BLK,IBJUNK,357.1)
LOCK -^IBE(357.1,BLK)
+8 WRITE !,"Blocks not belonging to any form have been deleted"
+9 ;
+10 ;delete cross-references for compilied forms if the forms have been deleted
+11 FOR CR="AT","AC","AG","AU","AB"
SET FORM=0
FOR
SET FORM=$ORDER(^IBE(357,CR,FORM))
if 'FORM
QUIT
IF '$DATA(^IBE(357,FORM))
KILL ^IBE(357,CR,FORM)
+12 WRITE !,"Extraneous cross-references on non-existant forms have been deleted"
+13 QUIT
+14 ;
+15 ;
COMPILE ;compiles IBFORM at the form level - leaves blocks already compiled alone
+1 ;
+2 ;lock the form while compiling
+3 if '$$LOCKFORM^IBDFU7(IBFORM)
QUIT
+4 ;compile it only if not already compiled - it could have been compiled by another process while the form was being locked
+5 IF $$FORMDSCR^IBDFU1C(.IBFORM)
IF 'IBFORM("COMPILED")
Begin DoDot:1
+6 NEW IBARRAY,IBDEVICE,IBPRINT,DFN,IBCLINIC,IBAPPT,SUB
+7 SET (IBDEVICE("RASTER"),IBDEVICE("GRAPHICS"))=1
+8 SET (IBDEVICE("CRT"),IBDEVICE("LISTMAN"),IBAPPT,IBCLINIC,DFN,IBDEVICE("PCL"))=0
+9 DO UNCMPL(.IBFORM,0)
+10 DO PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,1)
+11 DO ARRAYS^IBDFU1C(.IBFORM,.IBARRAY)
+12 KILL ^TMP("IB",$JOB,"INTERFACES")
+13 SET SUB=""
FOR
SET SUB=$ORDER(IBARRAY(SUB))
if SUB=""
QUIT
KILL @IBARRAY(SUB)
+14 DO DRWBLKS^IBDF2A
+15 if IBFORM("COMPILED")'="F"
SET IBFORM("COMPILED")=1
+16 SET $PIECE(^IBE(357,IBFORM,0),"^",5)=IBFORM("COMPILED")
+17 ; -- if form not scannable and it compiled w/o formtype id...get one
+18 IF 'IBFORM("SCAN")
IF IBFORM("COMPILED")
IF '$PIECE(^IBE(357,IBFORM,0),"^",13)
SET IBFORM("TYPE")=$$FORMTYPE^IBDF18D(1)
IF IBFORM("TYPE")
SET $PIECE(^IBE(357,IBFORM,0),"^",13)=IBFORM("TYPE")
+19 if $PIECE(^IBE(357,IBFORM,0),"^",13)
SET ^IBE(357,"ADEF",$PIECE(^IBE(357,IBFORM,0),"^",13),IBFORM)=""
+20 KILL ^TMP("IB",$JOB,"INTERFACES"),X,Y,I
End DoDot:1
+21 DO FREEFORM^IBDFU7(IBFORM)
+22 ; -- build form spec if form compiled successfully
+23 IF IBFORM("SCAN")
IF IBFORM("COMPILED")
IF IBFORM("TYPE")
DO SCAN^IBDFBKS(IBFORM("TYPE"))
+24 QUIT
+25 ;
ASKCMPL(IBFORM) ;ask if the form should be compiled or uncompiled
+1 if '$GET(IBFORM)
QUIT
+2 NEW BLK,QUIT
SET QUIT=0
+3 IF $PIECE($GET(^IBE(357,IBFORM,0)),"^",5)
Begin DoDot:1
+4 WRITE !,"The form is currently compiled. Should it be recompiled?"
+5 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
+6 DO ^DIR
KILL DIR
+7 if $DATA(DUOUT)!(Y'=1)
SET QUIT=1
End DoDot:1
+8 if QUIT
QUIT
+9 ;uncompile the form
+10 DO UNCMPALL(IBFORM)
+11 QUIT
+12 ;
CMPLACTN ;action for compiling a form listed on the screen
+1 NEW IBFORM
+2 IF $GET(IBAPI("SELECT"))'=""
XECUTE IBAPI("SELECT")
+3 IF IBFORM
DO ASKCMPL(IBFORM)
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
KILLTBL(IBFORM) ;
+1 ; -- marks the FORM DEFINITION TABLE for deletion
+2 ; IBFORM("TYPE") is reset to "", pass IBFORM by reference
+3 ;
+4 if 'IBFORM("TYPE")
QUIT
+5 ;
+6 ; -- Mark forms for deletion
+7 SET $PIECE(^IBD(357.95,IBFORM("TYPE"),0),"^",2)=DT
SET ^IBD(357.95,"ADEL",DT,IBFORM("TYPE"))=""
+8 ; kill cross reference
KILL ^IBE(357,"ADEF",IBFORM("TYPE"),IBFORM)
+9 SET IBFORM("TYPE")=""
SET $PIECE(^IBE(357,IBFORM,0),"^",13)=""
+10 QUIT
+11 ;
UNCMPL(IBFORM,FAILED) ;marks the form as not compiled and deletes or marks for deletion the FORM DEFINITION TABLE
+1 ;leaves the blocks compiled
+2 ;if FAILED means compilation of form was attempted, but failed - mark form accordingly
+3 ;IBFORM is the form - if passed by reference IBFORM("TYPE") and IBFORM("COMPILED") are set
+4 ;
+5 if 'IBFORM
QUIT
+6 NEW NODE
+7 SET NODE=$GET(^IBE(357,IBFORM,0))
+8 SET IBFORM("SCAN")=$PIECE(NODE,"^",12)
SET IBFORM("TYPE")=$PIECE(NODE,"^",13)
+9 if IBFORM("TYPE")
DO KILLTBL(.IBFORM)
+10 SET IBFORM("COMPILED")=$SELECT($GET(FAILED):"F",1:0)
SET $PIECE(^IBE(357,IBFORM,0),"^",5)=IBFORM("COMPILED")
+11 QUIT
+12 ;
UNCMPALL(IBFORM) ;uncompile the form and it's blocks
+1 NEW BLK
+2 DO UNCMPL(IBFORM,0)
+3 ;also uncompile all of its blocks
+4 SET BLK=0
FOR
SET BLK=$ORDER(^IBE(357.1,"C",IBFORM,BLK))
if 'BLK
QUIT
DO UNCMPBLK^IBDF19(BLK)
+5 QUIT
BLKCHNG(FORM,BLOCK) ;call this if the block is edited - uncompiles the block and form
+1 DO UNCMPBLK(BLOCK)
+2 DO UNCMPL(FORM)
+3 QUIT
+4 ;
UNCMPBLK(BLOCK) ;delete the compiled version of the block
+1 KILL ^IBE(357.1,BLOCK,"V"),^IBE(357.1,BLOCK,"S"),^IBE(357.1,BLOCK,"B"),^IBE(357.1,BLOCK,"H")
+2 QUIT
+3 ;
KILL(TYPE) ;deletes the form definition=TYPE
+1 KILL ^IBD(357.95,"AC",TYPE),^IBD(357.95,TYPE,1)
+2 KILL ^IBD(357.95,"AD",TYPE),^IBD(357.95,TYPE,2)
+3 KILL DA
SET DIK="^IBD(357.95,"
SET DA=TYPE
DO ^DIK
KILL DIK,DA
+4 QUIT
+5 ;
RECMPALL ;causes all forms to be recompiled
+1 NEW IBFORM,IBQUIT,DIR,DIRUT,DUOUT,DTOUT
+2 SET IBQUIT=0
+3 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+4 SET DIR("?")="Enter 'Yes' to cause all forms to uncompile or 'No' to do nothing. Forms will actually recompile as they are printed."
+5 SET DIR(0)="Y"
SET DIR("A")="Do you really want to Recompile all Forms"
+6 DO ^DIR
SET IBQUIT='Y
End DoDot:1
+7 IF $GET(IBQUIT)
WRITE !!,"Okay, nothing recompiled"
QUIT
+8 ;
+9 if '$DATA(ZTQUEUED)
WRITE !!,"Uncompiling all forms..."
+10 SET IBFORM=0
+11 FOR
SET IBFORM=$ORDER(^IBE(357,IBFORM))
if 'IBFORM
QUIT
Begin DoDot:1
+12 if '$$LOCKFORM^IBDFU7(IBFORM)
QUIT
+13 DO UNCMPALL(IBFORM)
+14 DO FREEFORM^IBDFU7(IBFORM)
+15 if '$DATA(ZTQUEUED)
WRITE "."
End DoDot:1
+16 if '$DATA(ZTQUEUED)
WRITE !!,"Okay, forms will be recompiled as they are printed."
+17 QUIT
