- 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 Feb 19, 2025@00:20:03 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