Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDE3

IBDE3.m

Go to the documentation of this file.
  1. IBDE3 ;ALB/CJM - ENCOUNTER FORM - IMP/EXP UTILITY -DISPLAYS TOOLKIT BLOCKS ;AUG 12,1993
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
  1. ;
  1. HDR ;
  1. S VALMHDR(1)="LIST OF TOOLKIT BLOCKS READY FOR IMPORT OR EXPORT"
  1. S VALMHDR(3)="(** there are "_$S($O(^IBE(358,0)):"also",1:"no")_" forms in the work space **)"
  1. Q
  1. ONENTRY ;
  1. N LINE
  1. S VALMCNT=$G(BLKCNT)
  1. I $D(BLKLIST) S LINE=0 F S LINE=$O(@BLKLIST@(LINE)) Q:'LINE D FLDCTRL^VALM10(LINE)
  1. Q
  1. ONEXIT ;
  1. Q
  1. ;
  1. IDXBLKS ;build an array of forms used by IBCLINIC for the list processor
  1. N BLOCK,NODE,ORDER
  1. K @BLKLIST
  1. S (VALMCNT,ORDER)=0 F S ORDER=$O(^IBE(358.1,"D",ORDER)) Q:'ORDER S BLOCK=0 F S BLOCK=$O(^IBE(358.1,"D",ORDER,BLOCK)) Q:'BLOCK D
  1. .I $D(^IBE(358.1,BLOCK,0)) D
  1. ..S VALMCNT=VALMCNT+1,@BLKLIST@(VALMCNT,0)=$$DISPLAY(BLOCK,VALMCNT),@BLKLIST@("IDX",VALMCNT,VALMCNT)=BLOCK D FLDCTRL^VALM10(VALMCNT) ;set video for ID column
  1. S BLKCNT=VALMCNT
  1. Q
  1. ;
  1. DISPLAY(BLOCK,ID) ;
  1. N NODE,RET
  1. S RET=$J(ID,3)_" "
  1. S NODE=$G(^IBE(358.1,BLOCK,0))
  1. S RET=RET_$$PADRIGHT^IBDFU($P(NODE,"^",1),30)_" "_$P(NODE,"^",13)
  1. Q RET
  1. ;
  1. ADD ;adds a block to the work space
  1. N OLDBLOCK,NEWBLOCK
  1. D FULL^VALM1
  1. S VALMBCK="R"
  1. S OLDBLOCK=$$SELECT Q:'OLDBLOCK
  1. S NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,"",357.1,358.1,"","",1)
  1. I NEWBLOCK K DIE,DR,DA S DIE="^IBE(358.1,",DA=NEWBLOCK,DR="1;" D ^DIE K DIE,DR,DA
  1. D IDXBLKS
  1. Q
  1. ;
  1. DELETE ;deletes a block from the work space
  1. N PICK,FORM,IBTKBLK
  1. S IBTKBLK=1 ;can't delete tk blocks unless IBTKBLK
  1. D EN^VALM2($G(XQORNOD(0)))
  1. S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) I BLOCK,$$RUSURE^IBDFU5($P($G(^IBE(358.1,BLOCK,0)),"^")) D DLTBLK^IBDFU3(BLOCK,"",358.1)
  1. S VALMBCK="R"
  1. D IDXBLKS
  1. Q
  1. EDIT ;allows the export notes of a block to be edited
  1. N PICK,BLOCK
  1. D EN^VALM2($G(XQORNOD(0)))
  1. D FULL^VALM1
  1. S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D:BLOCK
  1. .K DIE,DR,DA S DIE="^IBE(358.1,",DR="1;",DA=BLOCK D ^DIE K DIE,DA,DR
  1. S VALMBCK="R"
  1. D IDXBLKS
  1. Q
  1. IMPORT ;allows the user to pick a block from the imp/exp files, then import it
  1. N PICK,BLOCK,NEWBLOCK,IBTKBLK,NAME
  1. S IBTKBLK=1
  1. D EN^VALM2($G(XQORNOD(0)))
  1. D FULL^VALM1
  1. S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D:BLOCK
  1. .S NAME=$$NEWNAME($P($G(^IBE(358.1,BLOCK,0)),"^"))
  1. .Q:NAME=""
  1. .S NEWBLOCK=$$COPYBLK^IBDFU2(BLOCK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13,NAME)
  1. .D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLOCK,"",358.1)
  1. S VALMBCK="R"
  1. D IDXBLKS
  1. D UPDATE^IBDECLN(1) ;clean up qualifiers (with messages)
  1. Q
  1. VIEW ;allows the export notes of a form to be edited
  1. N PICK,BLOCK,IBARY,IBHDRRTN
  1. D EN^VALM2($G(XQORNOD(0)),"S")
  1. S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D
  1. .S IBHDRRTN="D VIEWHDR^IBDE3"
  1. .S IBARY="^IBE(358.1,"_BLOCK_",1)"
  1. .D EN^VALM("IBDE TEXT DISPLAY")
  1. S VALMBCK="R"
  1. Q
  1. VIEWHDR ;
  1. S VALMHDR(1)="Export Notes For "_$P($G(^IBE(358.1,BLOCK,0)),"^")_" Block"
  1. Q
  1. SELECT() ;allows the user to select a form, then a block from it
  1. N IBFORM,IBBLK
  1. S (IBFORM,IBBLK)=""
  1. K DIR S DIR(0)="S^1:TOOLKIT BLOCK;2:BLOCK FROM A TOOLKIT FORM;3:BLOCK FROM A FORM NOT IN THE TOOLKIT"
  1. S DIR("A")="What type of block do you want to export?"
  1. D ^DIR K DIR
  1. Q:(Y=-1)!($D(DIRUT)) ""
  1. I Y=1 D
  1. .S IBFORM=$$TKFORM^IBDFU2C
  1. E S IBFORM=$$SLCTFORM^IBDFU4($S(Y=2:1,1:0))
  1. I IBFORM D
  1. .W !!,"NOW CHOOSE THE BLOCK TO COPY!",!
  1. .S IBBLK=$$SLCTBLK^IBDFU8(IBFORM)
  1. Q IBBLK
  1. ;
  1. NEWNAME(OLDNAME) ;asks the user to select uniqued toolkit block name
  1. ;returns "" if unsuccessfull, else the blk name
  1. ;shows OLDNAME as the default if defined
  1. ;
  1. N NAME,FOUND,TKBLK,ORDER S NAME=""
  1. K DIR S DIR(0)="357.1,.01A",DIR("A")="New Toolkit Block Name: ",DIR("?")="Enter a unique name for the toolkit block up to 30 characters"
  1. S DIR("B")="" I $G(OLDNAME)'="" S DIR("B")=OLDNAME
  1. F D Q:'FOUND
  1. .S FOUND=0
  1. .D ^DIR I $D(DIRUT) S Y="" Q
  1. .S ORDER=0 F S ORDER=$O(^IBE(357.1,"D",ORDER)) Q:ORDER="" S TKBLK=$O(^IBE(357.1,"D",ORDER,0)) Q:'TKBLK I $P($G(^IBE(357.1,TKBLK,0)),"^")=Y W !,"There is already a toolkit block with that name! The name should be unique." S FOUND=1 Q
  1. S:'FOUND NAME=Y
  1. K DIR
  1. Q NAME