source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDE3.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1IBDE3 ;ALB/CJM - ENCOUNTER FORM - IMP/EXP UTILITY -DISPLAYS TOOLKIT BLOCKS ;AUG 12,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
3 ;
4HDR ;
5 S VALMHDR(1)="LIST OF TOOLKIT BLOCKS READY FOR IMPORT OR EXPORT"
6 S VALMHDR(3)="(** there are "_$S($O(^IBE(358,0)):"also",1:"no")_" forms in the work space **)"
7 Q
8ONENTRY ;
9 N LINE
10 S VALMCNT=$G(BLKCNT)
11 I $D(BLKLIST) S LINE=0 F S LINE=$O(@BLKLIST@(LINE)) Q:'LINE D FLDCTRL^VALM10(LINE)
12 Q
13ONEXIT ;
14 Q
15 ;
16IDXBLKS ;build an array of forms used by IBCLINIC for the list processor
17 N BLOCK,NODE,ORDER
18 K @BLKLIST
19 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
20 .I $D(^IBE(358.1,BLOCK,0)) D
21 ..S VALMCNT=VALMCNT+1,@BLKLIST@(VALMCNT,0)=$$DISPLAY(BLOCK,VALMCNT),@BLKLIST@("IDX",VALMCNT,VALMCNT)=BLOCK D FLDCTRL^VALM10(VALMCNT) ;set video for ID column
22 S BLKCNT=VALMCNT
23 Q
24 ;
25DISPLAY(BLOCK,ID) ;
26 N NODE,RET
27 S RET=$J(ID,3)_" "
28 S NODE=$G(^IBE(358.1,BLOCK,0))
29 S RET=RET_$$PADRIGHT^IBDFU($P(NODE,"^",1),30)_" "_$P(NODE,"^",13)
30 Q RET
31 ;
32ADD ;adds a block to the work space
33 N OLDBLOCK,NEWBLOCK
34 D FULL^VALM1
35 S VALMBCK="R"
36 S OLDBLOCK=$$SELECT Q:'OLDBLOCK
37 S NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,"",357.1,358.1,"","",1)
38 I NEWBLOCK K DIE,DR,DA S DIE="^IBE(358.1,",DA=NEWBLOCK,DR="1;" D ^DIE K DIE,DR,DA
39 D IDXBLKS
40 Q
41 ;
42DELETE ;deletes a block from the work space
43 N PICK,FORM,IBTKBLK
44 S IBTKBLK=1 ;can't delete tk blocks unless IBTKBLK
45 D EN^VALM2($G(XQORNOD(0)))
46 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)
47 S VALMBCK="R"
48 D IDXBLKS
49 Q
50EDIT ;allows the export notes of a block to be edited
51 N PICK,BLOCK
52 D EN^VALM2($G(XQORNOD(0)))
53 D FULL^VALM1
54 S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D:BLOCK
55 .K DIE,DR,DA S DIE="^IBE(358.1,",DR="1;",DA=BLOCK D ^DIE K DIE,DA,DR
56 S VALMBCK="R"
57 D IDXBLKS
58 Q
59IMPORT ;allows the user to pick a block from the imp/exp files, then import it
60 N PICK,BLOCK,NEWBLOCK,IBTKBLK,NAME
61 S IBTKBLK=1
62 D EN^VALM2($G(XQORNOD(0)))
63 D FULL^VALM1
64 S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D:BLOCK
65 .S NAME=$$NEWNAME($P($G(^IBE(358.1,BLOCK,0)),"^"))
66 .Q:NAME=""
67 .S NEWBLOCK=$$COPYBLK^IBDFU2(BLOCK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13,NAME)
68 .D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLOCK,"",358.1)
69 S VALMBCK="R"
70 D IDXBLKS
71 D UPDATE^IBDECLN(1) ;clean up qualifiers (with messages)
72 Q
73VIEW ;allows the export notes of a form to be edited
74 N PICK,BLOCK,IBARY,IBHDRRTN
75 D EN^VALM2($G(XQORNOD(0)),"S")
76 S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D
77 .S IBHDRRTN="D VIEWHDR^IBDE3"
78 .S IBARY="^IBE(358.1,"_BLOCK_",1)"
79 .D EN^VALM("IBDE TEXT DISPLAY")
80 S VALMBCK="R"
81 Q
82VIEWHDR ;
83 S VALMHDR(1)="Export Notes For "_$P($G(^IBE(358.1,BLOCK,0)),"^")_" Block"
84 Q
85SELECT() ;allows the user to select a form, then a block from it
86 N IBFORM,IBBLK
87 S (IBFORM,IBBLK)=""
88 K DIR S DIR(0)="S^1:TOOLKIT BLOCK;2:BLOCK FROM A TOOLKIT FORM;3:BLOCK FROM A FORM NOT IN THE TOOLKIT"
89 S DIR("A")="What type of block do you want to export?"
90 D ^DIR K DIR
91 Q:(Y=-1)!($D(DIRUT)) ""
92 I Y=1 D
93 .S IBFORM=$$TKFORM^IBDFU2C
94 E S IBFORM=$$SLCTFORM^IBDFU4($S(Y=2:1,1:0))
95 I IBFORM D
96 .W !!,"NOW CHOOSE THE BLOCK TO COPY!",!
97 .S IBBLK=$$SLCTBLK^IBDFU8(IBFORM)
98 Q IBBLK
99 ;
100NEWNAME(OLDNAME) ;asks the user to select uniqued toolkit block name
101 ;returns "" if unsuccessfull, else the blk name
102 ;shows OLDNAME as the default if defined
103 ;
104 N NAME,FOUND,TKBLK,ORDER S NAME=""
105 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"
106 S DIR("B")="" I $G(OLDNAME)'="" S DIR("B")=OLDNAME
107 F D Q:'FOUND
108 .S FOUND=0
109 .D ^DIR I $D(DIRUT) S Y="" Q
110 .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
111 S:'FOUND NAME=Y
112 K DIR
113 Q NAME
Note: See TracBrowser for help on using the repository browser.