IBDFU3 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(deleting blocks) ;01/08/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
DLTBLK(BLOCK,FORM,FILE) ;deletes BLOCK (in FILE) if not part of the toolkit (unless IBTKBLK=1) and, if FORM is passed in, the block actually is on FORM
N IBDX,IBDPI,IBDCS
Q:('$G(BLOCK))
Q:(FILE'=357.1)&(FILE'=358.1)
N NODE,DIK,DA
S NODE=$G(^IBE(FILE,BLOCK,0))
K DA S DA=BLOCK,DIK="^IBE("_FILE_","
;don't delete it if part of the toolkit or doesn't belong to the form (messed up cross-references), unless IBTKBLK=1 (means deletion is during special option for editing the tk)
G:$G(IBTKBLK) JUSTDOIT
I ($P(NODE,"^",14)) D Q
.S $P(^IBE(FILE,BLOCK,0),"^",2)=$O(^IBE(FILE\1,"B","TOOL KIT",""))
.I $G(FORM)'="" K ^IBE(FILE,"C",FORM,BLOCK) D IX1^DIK
I $G(FORM)'="",($P(NODE,"^",2)'=FORM) D Q
.;don't delete it - instead re-index it and quit
.K ^IBE(FILE,"C",FORM,BLOCK) D IX1^DIK
JUSTDOIT ;
;delete its components
D DLTCNTNT(BLOCK,FILE)
;delete the block (DIC,DA are newed)
D ^DIK
Q
;
DLTCNTNT(BLOCK,FILE) ;delete everything in BLOCK, but not the block itself
Q:('$G(BLOCK))!('$G(FILE))
Q:(FILE'=357.1)&(FILE'=358.1)
N LIST,FLD,LINE,TEXT,TARGET,DIK,DA
;delete selection lists from BLOCK
S TARGET=$S(FILE[358:358.2,1:357.2)
S LIST="" F S LIST=$O(^IBE(TARGET,"C",BLOCK,LIST)) Q:'LIST D DLTLIST(TARGET,BLOCK,LIST)
;delete data fields
S TARGET=$S(FILE[358:358.5,1:357.5)
S FLD="" F S FLD=$O(^IBE(TARGET,"C",BLOCK,FLD)) Q:'FLD D DLTFLD(TARGET,BLOCK,FLD)
;delete multiple choice fields
S TARGET=$S(FILE[358:358.93,1:357.93)
S FLD="" F S FLD=$O(^IBE(TARGET,"C",BLOCK,FLD)) Q:'FLD D DLTIFLD(TARGET,BLOCK,FLD)
;delete hand print fields
S TARGET=$S(FILE[358:358.94,1:359.94)
S FLD="" F S FLD=$O(^IBE(TARGET,"C",BLOCK,FLD)) Q:'FLD D DLTHFLD(TARGET,BLOCK,FLD)
;delete lines
S TARGET=$S(FILE[358:358.7,1:357.7)
S LINE="" F S LINE=$O(^IBE(TARGET,"C",BLOCK,LINE)) Q:'LINE D DLTLINE(TARGET,BLOCK,LINE)
;delete text areas
S TARGET=$S(FILE[358:358.8,1:357.8)
S TEXT="" F S TEXT=$O(^IBE(TARGET,"C",BLOCK,TEXT)) Q:'TEXT D DLTTEXT(TARGET,BLOCK,TEXT)
Q
;
DLTLIST(FILE,BLOCK,LIST) ;delete the LIST, its selections and groups
Q:'$G(LIST)!'$G(BLOCK)!(($G(FILE)'=357.2)&($G(FILE)'=358.2))
N GRP,SLCTN,DIK,DA,IBDX,IBDPI,IBDCS,IBDFLD
S IBDPI=0,IBDCS="" I FILE=357.2 S IBDPI=$P(^IBE(357.2,LIST,0),U,11) I IBDPI?1.N S IBDX=^IBE(357.6,IBDPI,0),IBDCS=+$P(IBDX,U,22) ;Coding System
S DIK="^IBE("_FILE_",",DA=LIST
;don't delete it if it does not belong to BLOCK - instead, reindex it and quit
I $P($G(^IBE(FILE,LIST,0)),"^",2)'=BLOCK K ^IBE(FILE,"C",BLOCK,LIST) D IX1^DIK Q
;delete its contents(DIK,DA are newed)
D DLISTCNT(LIST,FILE)
;delete the list
D ^DIK
Q
DLISTCNT(LIST,FILE) ;delete the list's selections and groups
N GRP,SLCTN,DIK,DA,GFILE,SFILE,IBDX,IBDCS,IBDPI
Q:('$G(LIST))!('$G(FILE))
Q:(FILE'=357.2)&(FILE'=358.2)
S GFILE=$S(FILE[358:358.4,1:357.4)
S SFILE=$S(FILE[358:358.3,1:357.3)
;now delete list's contents
S GRP="" F S GRP=$O(^IBE(GFILE,"D",LIST,GRP)) Q:'GRP S DA=GRP D
.I $P($G(^IBE(GFILE,GRP,0)),"^",3)=LIST D
..S DIK="^IBE("_GFILE_"," D ^DIK
..S SLCTN="",DIK="^IBE("_SFILE_"," F S SLCTN=$O(^IBE(SFILE,"D",GRP,SLCTN)) Q:'SLCTN S DA=SLCTN D
...I $P($G(^IBE(SFILE,SLCTN,0)),"^",4)=GRP D
....D ^DIK
...E K ^IBE(SFILE,"C",LIST,SLCTN) D IX1^DIK
.;
.E K ^IBE(GFILE,"D",LIST,GRP) D IX1^DIK
S SLCTN="",DIK="^IBE("_SFILE_"," F S SLCTN=$O(^IBE(SFILE,"C",LIST,SLCTN)) Q:'SLCTN S DA=SLCTN D
.I $P($G(^IBE(SFILE,SLCTN,0)),"^",3)=LIST D
..D ^DIK
.E K ^IBE(SFILE,"C",LIST,SLCTN) D IX1^DIK
Q
;
DLTFLD(FILE,BLOCK,FLD) ;delete a display field
Q:('$G(BLOCK))!('$G(FLD))!('$G(FILE))
Q:(FILE'=357.5)&(FILE'=358.5)
N DA,DIK
S DIK="^IBE("_FILE_",",DA=FLD
I $P($G(^IBE(FILE,FLD,0)),"^",2)=BLOCK D
.D ^DIK
E K ^IBE(FILE,"C",BLOCK,FLD) D IX1^DIK
Q
;
DLTIFLD(FILE,BLOCK,FLD) ;delete a multiple choice field
Q:('$G(BLOCK))!('$G(FLD))!('$G(FILE))
Q:(FILE'=357.93)&(FILE'=358.93)
N DA,DIK
S DIK="^IBE("_FILE_",",DA=FLD
I $P($G(^IBE(FILE,FLD,0)),"^",8)=BLOCK D
.D ^DIK
E K ^IBE(FILE,"C",BLOCK,FLD) D IX1^DIK
Q
DLTHFLD(FILE,BLOCK,FLD) ;delete a hand print field
Q:('$G(BLOCK))!('$G(FLD))!('$G(FILE))
Q:(FILE'=359.94)&(FILE'=358.94)
N DA,DIK
S DIK="^IBE("_FILE_",",DA=FLD
I $P($G(^IBE(FILE,FLD,0)),"^",8)=BLOCK D
.D ^DIK
E K ^IBE(FILE,"C",BLOCK,FLD) D IX1^DIK
Q
;
DLTTEXT(FILE,BLOCK,TEXT) ;delete the TEXT AREA
Q:('$G(BLOCK))!('$G(TEXT))!('$G(FILE))
Q:(FILE'=357.8)&(FILE'=358.8)
N DA,DIK
S DIK="^IBE("_FILE_",",DA=TEXT
I $P($G(^IBE(FILE,TEXT,0)),"^",2)=BLOCK D
.D ^DIK
E K ^IBE(FILE,"C",BLOCK,TEXT) D IX1^DIK
Q
DLTLINE(FILE,BLOCK,LINE) ;delete the line
Q:('$G(BLOCK))!('$G(LINE))!('$G(FILE))
Q:(FILE'=357.7)&(FILE'=358.7)
N DA,DIK
S DIK="^IBE("_FILE_",",DA=LINE
I $P($G(^IBE(FILE,LINE,0)),"^",6)=BLOCK D
.D ^DIK
E K ^IBE(FILE,"C",BLOCK,LINE) D IX1^DIK
Q
FASTEXIT ;just sets a flag signaling system should be exited
S VALMBCK="Q"
K DIR S DIR(0)="Y",DIR("A")="Exit Encounter Form Option",DIR("B")="NO" D ^DIR
I $D(DIRUT)!(Y) S IBFASTXT=1
K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU3 5224 printed Dec 13, 2024@02:53:38 Page 2
IBDFU3 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(deleting blocks) ;01/08/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
DLTBLK(BLOCK,FORM,FILE) ;deletes BLOCK (in FILE) if not part of the toolkit (unless IBTKBLK=1) and, if FORM is passed in, the block actually is on FORM
+1 NEW IBDX,IBDPI,IBDCS
+2 if ('$GET(BLOCK))
QUIT
+3 if (FILE'=357.1)&(FILE'=358.1)
QUIT
+4 NEW NODE,DIK,DA
+5 SET NODE=$GET(^IBE(FILE,BLOCK,0))
+6 KILL DA
SET DA=BLOCK
SET DIK="^IBE("_FILE_","
+7 ;don't delete it if part of the toolkit or doesn't belong to the form (messed up cross-references), unless IBTKBLK=1 (means deletion is during special option for editing the tk)
+8 if $GET(IBTKBLK)
GOTO JUSTDOIT
+9 IF ($PIECE(NODE,"^",14))
Begin DoDot:1
+10 SET $PIECE(^IBE(FILE,BLOCK,0),"^",2)=$ORDER(^IBE(FILE\1,"B","TOOL KIT",""))
+11 IF $GET(FORM)'=""
KILL ^IBE(FILE,"C",FORM,BLOCK)
DO IX1^DIK
End DoDot:1
QUIT
+12 IF $GET(FORM)'=""
IF ($PIECE(NODE,"^",2)'=FORM)
Begin DoDot:1
+13 ;don't delete it - instead re-index it and quit
+14 KILL ^IBE(FILE,"C",FORM,BLOCK)
DO IX1^DIK
End DoDot:1
QUIT
JUSTDOIT ;
+1 ;delete its components
+2 DO DLTCNTNT(BLOCK,FILE)
+3 ;delete the block (DIC,DA are newed)
+4 DO ^DIK
+5 QUIT
+6 ;
DLTCNTNT(BLOCK,FILE) ;delete everything in BLOCK, but not the block itself
+1 if ('$GET(BLOCK))!('$GET(FILE))
QUIT
+2 if (FILE'=357.1)&(FILE'=358.1)
QUIT
+3 NEW LIST,FLD,LINE,TEXT,TARGET,DIK,DA
+4 ;delete selection lists from BLOCK
+5 SET TARGET=$SELECT(FILE[358:358.2,1:357.2)
+6 SET LIST=""
FOR
SET LIST=$ORDER(^IBE(TARGET,"C",BLOCK,LIST))
if 'LIST
QUIT
DO DLTLIST(TARGET,BLOCK,LIST)
+7 ;delete data fields
+8 SET TARGET=$SELECT(FILE[358:358.5,1:357.5)
+9 SET FLD=""
FOR
SET FLD=$ORDER(^IBE(TARGET,"C",BLOCK,FLD))
if 'FLD
QUIT
DO DLTFLD(TARGET,BLOCK,FLD)
+10 ;delete multiple choice fields
+11 SET TARGET=$SELECT(FILE[358:358.93,1:357.93)
+12 SET FLD=""
FOR
SET FLD=$ORDER(^IBE(TARGET,"C",BLOCK,FLD))
if 'FLD
QUIT
DO DLTIFLD(TARGET,BLOCK,FLD)
+13 ;delete hand print fields
+14 SET TARGET=$SELECT(FILE[358:358.94,1:359.94)
+15 SET FLD=""
FOR
SET FLD=$ORDER(^IBE(TARGET,"C",BLOCK,FLD))
if 'FLD
QUIT
DO DLTHFLD(TARGET,BLOCK,FLD)
+16 ;delete lines
+17 SET TARGET=$SELECT(FILE[358:358.7,1:357.7)
+18 SET LINE=""
FOR
SET LINE=$ORDER(^IBE(TARGET,"C",BLOCK,LINE))
if 'LINE
QUIT
DO DLTLINE(TARGET,BLOCK,LINE)
+19 ;delete text areas
+20 SET TARGET=$SELECT(FILE[358:358.8,1:357.8)
+21 SET TEXT=""
FOR
SET TEXT=$ORDER(^IBE(TARGET,"C",BLOCK,TEXT))
if 'TEXT
QUIT
DO DLTTEXT(TARGET,BLOCK,TEXT)
+22 QUIT
+23 ;
DLTLIST(FILE,BLOCK,LIST) ;delete the LIST, its selections and groups
+1 if '$GET(LIST)!'$GET(BLOCK)!(($GET(FILE)'=357.2)&($GET(FILE)'=358.2))
QUIT
+2 NEW GRP,SLCTN,DIK,DA,IBDX,IBDPI,IBDCS,IBDFLD
+3 ;Coding System
SET IBDPI=0
SET IBDCS=""
IF FILE=357.2
SET IBDPI=$PIECE(^IBE(357.2,LIST,0),U,11)
IF IBDPI?1.N
SET IBDX=^IBE(357.6,IBDPI,0)
SET IBDCS=+$PIECE(IBDX,U,22)
+4 SET DIK="^IBE("_FILE_","
SET DA=LIST
+5 ;don't delete it if it does not belong to BLOCK - instead, reindex it and quit
+6 IF $PIECE($GET(^IBE(FILE,LIST,0)),"^",2)'=BLOCK
KILL ^IBE(FILE,"C",BLOCK,LIST)
DO IX1^DIK
QUIT
+7 ;delete its contents(DIK,DA are newed)
+8 DO DLISTCNT(LIST,FILE)
+9 ;delete the list
+10 DO ^DIK
+11 QUIT
DLISTCNT(LIST,FILE) ;delete the list's selections and groups
+1 NEW GRP,SLCTN,DIK,DA,GFILE,SFILE,IBDX,IBDCS,IBDPI
+2 if ('$GET(LIST))!('$GET(FILE))
QUIT
+3 if (FILE'=357.2)&(FILE'=358.2)
QUIT
+4 SET GFILE=$SELECT(FILE[358:358.4,1:357.4)
+5 SET SFILE=$SELECT(FILE[358:358.3,1:357.3)
+6 ;now delete list's contents
+7 SET GRP=""
FOR
SET GRP=$ORDER(^IBE(GFILE,"D",LIST,GRP))
if 'GRP
QUIT
SET DA=GRP
Begin DoDot:1
+8 IF $PIECE($GET(^IBE(GFILE,GRP,0)),"^",3)=LIST
Begin DoDot:2
+9 SET DIK="^IBE("_GFILE_","
DO ^DIK
+10 SET SLCTN=""
SET DIK="^IBE("_SFILE_","
FOR
SET SLCTN=$ORDER(^IBE(SFILE,"D",GRP,SLCTN))
if 'SLCTN
QUIT
SET DA=SLCTN
Begin DoDot:3
+11 IF $PIECE($GET(^IBE(SFILE,SLCTN,0)),"^",4)=GRP
Begin DoDot:4
+12 DO ^DIK
End DoDot:4
+13 IF '$TEST
KILL ^IBE(SFILE,"C",LIST,SLCTN)
DO IX1^DIK
End DoDot:3
End DoDot:2
+14 ;
+15 IF '$TEST
KILL ^IBE(GFILE,"D",LIST,GRP)
DO IX1^DIK
End DoDot:1
+16 SET SLCTN=""
SET DIK="^IBE("_SFILE_","
FOR
SET SLCTN=$ORDER(^IBE(SFILE,"C",LIST,SLCTN))
if 'SLCTN
QUIT
SET DA=SLCTN
Begin DoDot:1
+17 IF $PIECE($GET(^IBE(SFILE,SLCTN,0)),"^",3)=LIST
Begin DoDot:2
+18 DO ^DIK
End DoDot:2
+19 IF '$TEST
KILL ^IBE(SFILE,"C",LIST,SLCTN)
DO IX1^DIK
End DoDot:1
+20 QUIT
+21 ;
DLTFLD(FILE,BLOCK,FLD) ;delete a display field
+1 if ('$GET(BLOCK))!('$GET(FLD))!('$GET(FILE))
QUIT
+2 if (FILE'=357.5)&(FILE'=358.5)
QUIT
+3 NEW DA,DIK
+4 SET DIK="^IBE("_FILE_","
SET DA=FLD
+5 IF $PIECE($GET(^IBE(FILE,FLD,0)),"^",2)=BLOCK
Begin DoDot:1
+6 DO ^DIK
End DoDot:1
+7 IF '$TEST
KILL ^IBE(FILE,"C",BLOCK,FLD)
DO IX1^DIK
+8 QUIT
+9 ;
DLTIFLD(FILE,BLOCK,FLD) ;delete a multiple choice field
+1 if ('$GET(BLOCK))!('$GET(FLD))!('$GET(FILE))
QUIT
+2 if (FILE'=357.93)&(FILE'=358.93)
QUIT
+3 NEW DA,DIK
+4 SET DIK="^IBE("_FILE_","
SET DA=FLD
+5 IF $PIECE($GET(^IBE(FILE,FLD,0)),"^",8)=BLOCK
Begin DoDot:1
+6 DO ^DIK
End DoDot:1
+7 IF '$TEST
KILL ^IBE(FILE,"C",BLOCK,FLD)
DO IX1^DIK
+8 QUIT
DLTHFLD(FILE,BLOCK,FLD) ;delete a hand print field
+1 if ('$GET(BLOCK))!('$GET(FLD))!('$GET(FILE))
QUIT
+2 if (FILE'=359.94)&(FILE'=358.94)
QUIT
+3 NEW DA,DIK
+4 SET DIK="^IBE("_FILE_","
SET DA=FLD
+5 IF $PIECE($GET(^IBE(FILE,FLD,0)),"^",8)=BLOCK
Begin DoDot:1
+6 DO ^DIK
End DoDot:1
+7 IF '$TEST
KILL ^IBE(FILE,"C",BLOCK,FLD)
DO IX1^DIK
+8 QUIT
+9 ;
DLTTEXT(FILE,BLOCK,TEXT) ;delete the TEXT AREA
+1 if ('$GET(BLOCK))!('$GET(TEXT))!('$GET(FILE))
QUIT
+2 if (FILE'=357.8)&(FILE'=358.8)
QUIT
+3 NEW DA,DIK
+4 SET DIK="^IBE("_FILE_","
SET DA=TEXT
+5 IF $PIECE($GET(^IBE(FILE,TEXT,0)),"^",2)=BLOCK
Begin DoDot:1
+6 DO ^DIK
End DoDot:1
+7 IF '$TEST
KILL ^IBE(FILE,"C",BLOCK,TEXT)
DO IX1^DIK
+8 QUIT
DLTLINE(FILE,BLOCK,LINE) ;delete the line
+1 if ('$GET(BLOCK))!('$GET(LINE))!('$GET(FILE))
QUIT
+2 if (FILE'=357.7)&(FILE'=358.7)
QUIT
+3 NEW DA,DIK
+4 SET DIK="^IBE("_FILE_","
SET DA=LINE
+5 IF $PIECE($GET(^IBE(FILE,LINE,0)),"^",6)=BLOCK
Begin DoDot:1
+6 DO ^DIK
End DoDot:1
+7 IF '$TEST
KILL ^IBE(FILE,"C",BLOCK,LINE)
DO IX1^DIK
+8 QUIT
FASTEXIT ;just sets a flag signaling system should be exited
+1 SET VALMBCK="Q"
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Exit Encounter Form Option"
SET DIR("B")="NO"
DO ^DIR
+3 IF $DATA(DIRUT)!(Y)
SET IBFASTXT=1
+4 KILL DIR
+5 QUIT
