- 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 Jan 18, 2025@03:52:12 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