source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF3.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.5 KB
Line 
1IBDF3 ;ALB/CJM - Edit Selection List ;NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
3 ;
4EDITLIST ;expects IBBLK to be defined
5 N IBLIST,IBVALMBG
6 D FULL^VALM1
7 S IBVALMBG=VALMBG,VALMBCK="R"
8 D SELECT
9 I IBLIST D
10 .Q:$$LSTDSCR2^IBDFU1(.IBLIST)
11 .;I IBLIST("DYNAMIC"),$G(IBLIST("CLRM")) D SEL^IBDFN15(.IBLIST)
12 .I IBLIST("DYNAMIC"),'$G(IBLIST("CLRM")) W !,"You can not edit the contents of this list - it is determined at print time!" D PAUSE^IBDFU5 Q
13 .;I '$G(IBLIST("CLRM")) D EN^VALM("IBDF DISPLAY GROUPS FOR EDIT")
14 .I $G(IBLIST("CLRM")) S IBLIST("EDITING CLRM")=1
15 .D EN^VALM("IBDF DISPLAY GROUPS FOR EDIT")
16 .K IBLIST
17 .D UNCMPBLK^IBDF19(IBBLK)
18 .I '$G(IBFASTXT) D
19 ..D IDXBLOCK^IBDFU4
20 ..S VALMBCK="R",VALMBG=IBVALMBG
21 Q
22ONENTRY ;
23 D IDXGRP
24 Q
25ONEXIT ;
26 K @VALMAR
27 Q
28SELECT ;
29 ; -- dic("s") passed in from ibdfgrp
30 S IBLIST=""
31 Q:'$G(IBBLK)
32 S DIC="^IBE(357.2,",DIC(0)="EQ",D="C",X=IBBLK
33 D IX^DIC K DIC
34 S:+Y>0 IBLIST=+Y
35 Q
36ADDBLANK() ;
37 N IGRP
38 S GRP="" F S GRP=$O(^IBE(357.4,"D",IBLIST,GRP)) Q:'GRP Q:$P(^IBE(357.4,GRP,0),"^")="BLANK"
39 I 'GRP D
40 .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",DIC(0)="",X="BLANK",DIC(0)=""
41 .D FILE^DICN K DIC
42 .S GRP=$S(+Y<0:"",1:+Y)
43 I GRP K DA,DIE S DA=GRP,DIE="^IBE(357.4,",DR=".02////0;.03////"_IBLIST D ^DIE K DIE,DA,DR
44 Q GRP
45IDXGRP ;build an index of groups in print order for list processor
46 N GRP,GRPODR
47 K @VALMAR
48 S VALMCNT=0
49 S GRPODR="" F S GRPODR=$O(^IBE(357.4,"APO",IBLIST,GRPODR)) Q:GRPODR="" D
50 .S GRP="" F S GRP=$O(^IBE(357.4,"APO",IBLIST,GRPODR,GRP)) Q:'GRP D
51 ..;
52 ..;make sure the index is correct
53 ..I $P($G(^IBE(357.4,GRP,0)),"^",3)'=IBLIST K DIK,DA S DIK="^IBE(357.4,",DA=GRP D IX^DIK K DIK,DA,^IBE(357.4,"APO",IBLIST,GRPODR,GRP) Q
54 ..;
55 ..S VALMCNT=VALMCNT+1
56 ..S @VALMAR@(VALMCNT,0)=$$DISPLAY(GRP,VALMCNT),@VALMAR@("IDX",VALMCNT,VALMCNT)=GRP
57 ..D FLDCTRL^VALM10(VALMCNT,"ID") ;set video for ID column
58 Q
59LMGRPHDR ;sets the screen hdr
60 S VALMHDR(1)="PRINT GROUPS CURRENTLY DEFINED FOR '"_$$LISTNAME_"' SELECTION LIST"
61 Q
62DISPLAY(GRP,ROW) ;
63 N NODE0,NAME,INV
64 S NODE0=$G(^IBE(357.4,GRP,0)),NAME=$P(NODE0,"^"),INV=$P(NODE0,"^",4)
65 I NAME="BLANK" S NAME="*i BLANK (Not Displayed)"
66 I NAME'="BLANK",INV="I" S NAME="*i "_NAME
67 I NAME'="BLANK",INV'="I" S NAME=" "_NAME
68 Q $$PADRIGHT^IBDFU(ROW,6)_$J($P(NODE0,"^",2),6)_$J("",3)_$$PADRIGHT^IBDFU(NAME,40)_$J($$SLCTNCNT(GRP),6)_" selection(s)"
69SLCTNCNT(GRP) ;
70 N CNT,SLCTN
71 S CNT=0,SLCTN=""
72 F S SLCTN=$O(^IBE(357.3,"D",GRP,SLCTN)) Q:'SLCTN S CNT=CNT+1
73 Q CNT
74LISTNAME() ;
75 Q $P($G(^IBE(357.2,IBLIST,0)),"^",1)
76ADDGRP ;
77 N NAME,QUIT,GRP
78 S QUIT=0
79 F D Q:QUIT
80 .K DIR S DIR(0)="357.4,.01O",DIR("B")="" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
81 .S NAME=Y
82 .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",X=NAME,DIC(0)=""
83 .D FILE^DICN K DIC,DIE,DA
84 .I +Y<0 W !,"Unable to create a new record!" D PAUSE^VALM1 S QUIT=1 Q
85 .I +Y>0 K DA S DA=+Y,DIE="^IBE(357.4,",DIE("NO^")="Any value",DR=".02;.04;.03////"_IBLIST D ^DIE K DIC,DIE,DR,DA
86 .W !,"Now Another!",!
87 D IDXGRP
88 S VALMBCK="R"
89 Q
90 ;
91ADDEMPTY ;adds a blank group - a place holder that takes up space on the form
92 ;
93 N ORDER,QUIT,GRP
94 S QUIT=0
95 F D Q:QUIT
96 .K DIR S DIR(0)="357.4,.02O",DIR("B")="" D ^DIR K DIR I (Y="")!$D(DIRUT) S QUIT=1 Q
97 .S ORDER=Y
98 .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",X=" ",DIC(0)=""
99 .D FILE^DICN K DIC,DIE,DA
100 .I +Y<0 W !,"Unable to create a new group record!" D PAUSE^VALM1 S QUIT=1 Q
101 .I +Y>0 K DA S DA=+Y,DIE="^IBE(357.4,",DIE("NO^")="Any value",DR=".02////"_ORDER_";.03////"_IBLIST D ^DIE K DIC,DIE,DR,DA
102 .W !,"Now Another!",!
103 D IDXGRP
104 S VALMBCK="R"
105 Q
106EDTSLCTN ;
107 N SEL,IBGRP S SEL=""
108 I $G(VALMCNT) D
109 .D EN^VALM2($G(XQORNOD(0)),"S")
110 .S SEL=$O(VALMY(""))
111 I SEL="" D
112 .S IBGRP=$$ADDBLANK Q:'IBGRP
113 E S IBGRP=$G(@VALMAR@("IDX",SEL,SEL))
114 D:IBGRP SLCTNS^IBDF4,IDXGRP
115 S VALMBCK="R"
116 Q
117EDITGRP ;
118 N SEL,GRP
119 S VALMBCK="R"
120 D EN^VALM2($G(XQORNOD(0)),"S")
121 S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
122 .S GRP=$G(@VALMAR@("IDX",SEL,SEL))
123 .D:GRP
124 ..K DIE,DA S DIE=357.4,DA=GRP,DR=".01;.02;.04" D ^DIE
125 ..I '$D(DA) D DELSLCTN
126 ..K DIE,DA,DR,DIC
127 D IDXGRP
128 S VALMBCK="R"
129 Q
130DELSLCTN ;deletes a group's selections
131 N SLCTN
132 S SLCTN="",DIK="^IBE(357.3,"
133 F S SLCTN=$O(^IBE(357.3,"D",GRP,SLCTN)) Q:'SLCTN I $P($G(^IBE(357.3,SLCTN,0)),"^",4)=GRP K DA S DA=SLCTN D ^DIK
134 K DIK,DA
135 Q
136DELGRP ;delete a group and all of its selections
137 N SEL,GRP
138 S VALMBCK="R"
139 D EN^VALM2($G(XQORNOD(0)))
140 S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
141 .S GRP=$G(@VALMAR@("IDX",SEL,SEL))
142 .Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.4,GRP,0)),"^"))
143 .I GRP D DELSLCTN K DA S DIK="^IBE(357.4,",DA=GRP D ^DIK K DIK
144 D IDXGRP
145 S VALMBCK="R"
146 Q
Note: See TracBrowser for help on using the repository browser.