source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF9B3.m@ 619

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1IBDF9B3 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add data fields) ;FEB 1,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4LABELS ;Create, Edit, or Delete LABELS from the form
5 I Y="I" D LABELS^IBDF9B3 Q
6 ;
7 N IBVALMBG,QUIT
8 S QUIT=0
9 S IBVALMBG=VALMBG
10 S VALMBCK="R"
11 ;
12 F D Q:QUIT
13 .D FULL^VALM1
14 .K DIR S DIR("?",1)="You can Create, Edit, or Delete labels, Shift all of the labels AND data",DIR("?")="fields within a range up or down."
15 .W !!,DIR("?",1),!,DIR("?"),!
16 .S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;Q:Quit",DIR("A")="[C]reate, [D]elete, [E]dit, [S]hift, [Q]uit"
17 .D ^DIR K DIR I $D(DIRUT)!(Y<0) S QUIT=1 Q
18 .I Y="Q" S QUIT=1 Q
19 .D @$S(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
20 .D RE^VALM4
21 S VALMBCK="R",VALMBG=IBVALMBG
22 Q
23SHIFT ;expects IBBLK to be defined - shifts all fields within range supplied by user
24 D SHIFT^IBDF10("D")
25 D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
26 Q
27EDITFLD ;expects IBBLK to be defined
28 N IBFIELD,NOD
29 N IBI,IBOLD,IBX,IBY,IBW,IBDELETE ;these are used in the input template
30 D SELECT
31 I IBFIELD D
32 .D RE^VALM4
33 .S IBOLD=1,(IBX,IBY)=""
34 .K DR,DIE,DA S DIE=357.5,DA=IBFIELD,DR="[IBDF EDIT LABEL FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
35 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
36 Q
37SELECT ;
38 S IBFIELD=0
39 Q:'$G(IBBLK)
40 I '$O(^IBE(357.5,"C",IBBLK,0)) W !,"There is no label only field!" D PAUSE^IBDFU5 Q
41AGAIN K DIC S DIC="^IBE(357.5,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
42 S DIC("S")="I $P(^(0),U,2)=IBBLK,+$P(^(0),U,3)=0"
43 D IX^DIC K DIC
44 S:+Y>0 IBFIELD=+Y
45 I 'IBFIELD,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No label selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
46 Q
47DLTFLD ;expects IBBLK to be defined
48 N IBFIELD
49 D SELECT
50 I IBFIELD D
51 .Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.5,IBFIELD,0)),"^"))
52 .D DLTFLD^IBDFU3(357.5,IBBLK,IBFIELD)
53 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
54 Q
55NEWFLD ;adds a new field, expects IBBLK to be defined
56 N NAME,FIELD,NODE,IBRTN,DLAYGO
57 N IBX,IBY,IBW,IBDELETE,IBOLD ;these are used in the input template
58 S NAME=$$NEWNAME^IBDF9B Q:NAME=-1
59 S IBOLD=0,(IBX,IBY)=""
60 K DIC,DIE,DD,DO,DINUM S DIC="^IBE(357.5,",DIC(0)="FL",X=NAME,DLAYGO=357.5
61 D FILE^DICN K DIC,DIE,DA
62 S FIELD=$S(+Y<0:"",1:+Y)
63 I 'FIELD D
64 .W !,"Unable to create a new label!" D PAUSE^IBDFU5
65 I FIELD D
66 .S IBDELETE=1
67 .D RE^VALM4
68 .K DIE,DA,DR S DIE=357.5,DA=FIELD,DR="[IBDF EDIT LABEL FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC
69 .I IBDELETE K DA S DIK="^IBE(357.5,",DA=FIELD D ^DIK K DIK,DA Q
70 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
71 Q
Note: See TracBrowser for help on using the repository browser.