source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF9D.m@ 1005

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1IBDF9D ;ALB/CJM - ENCOUNTER FORM (create/edit/delete lines);MARCH 20, 1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3LINE ;Create, Edit, or Delete a line on the block
4 S VALMBCK="R"
5 K DIR S DIR("?",1)="You can add vertical or horizontal lines to the block, or edit or delete",DIR("?")="a line already there IF it was created through this action."
6 S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete",DIR("A")="[C]reate , [D]elete, or [E]dit a line"
7 D ^DIR K DIR I $D(DIRUT)!(Y<0) Q
8 D @$S(Y="C":"NEWLINE",Y="E":"EDITLINE",Y="D":"DLTLINE",1:"")
9 S VALMBCK="R"
10 Q
11EDITLINE ;expects IBBLK to be defined - edits an already existing line
12 N IBLINE,IBDFDONE
13 ;IBDFDONE is used in the imput template
14 D FULL^VALM1
15 D SELECT
16 I IBLINE D
17 .D RE^VALM4
18 .K DIE,DA S DIE=357.7,DA=IBLINE,DR="[IBDF FORM LINE]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
19 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
20 Q
21SELECT ;select a line on the block
22 S IBLINE=0
23 Q:'$G(IBBLK)
24 I '$O(^IBE(357.7,"C",IBBLK,0)) W !,"There is no line!" D PAUSE^IBDFU5 Q
25AGAIN K DIC S DIC="^IBE(357.7,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
26 S DIC("S")="I $P($G(^(0)),U,6)=IBBLK"
27 D IX^DIC K DIC
28 S:+Y>0 IBLINE=+Y
29 I 'IBLINE,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No data line selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
30 Q
31DLTLINE ;expects IBBLK to be defined - deletes one of the blocks lines
32 N IBLINE
33 D FULL^VALM1
34 D SELECT
35 I IBLINE D
36 .Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.7,IBLINE,0)),"^"))
37 .D DLTLINE^IBDFU3(357.7,IBBLK,IBLINE)
38 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
39 Q
40NEWLINE ;adds a new line, expects IBBLK to be defined
41 N IBLINE,NODE,IBDFDONE,DLAYGO
42 ;IBDONE - a flag used in the input template to indicate if the input template was completed - delete the line if not completed
43 ;S NAME=$$NEWNAME Q:NAME=-1
44 K DIC,DIE,DD,DO,DINUM S DIC="^IBE(357.7,",DIC(0)="FL",X="NAME",DLAYGO=357.7
45 D FILE^DICN K DIC,DIE,DA,DO
46 S IBLINE=+Y
47 I 'IBLINE D
48 .W !,"Unable to create a new line!" D PAUSE^IBDFU5
49 I IBLINE D
50 .K DIE,DA S DIE=357.7,DA=IBLINE,DR="[IBDF FORM LINE]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
51 .I 'IBDFDONE K DA S DIK="^IBE(357.7,",DA=IBLINE D ^DIK K DIK Q
52 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
53 Q
54NEWNAME(IBLINE) ;
55 N NODE,NAME S NODE=$G(^IBE(357.7,IBLINE,0))
56 Q:NODE="" "LINE"
57 S NAME=$P(NODE,"^",4)_"("_(+$P(NODE,"^",3)+1)_","_(+$P(NODE,"^",2)+1)_")"
58 Q NAME
59MAXLEN() ;returns the maximum length of the line=IBLINE that will fit in the block=IBBLK
60 N LEN,TYPE,NODE,POS
61 S NODE=$G(^IBE(357.7,IBLINE,0))
62 S TYPE=$P(NODE,"^",4)
63 S POS=$S(TYPE="H":$P(NODE,"^",2),1:$P(NODE,"^",3))
64 Q ((1+$S(TYPE="H":$$MAXX^IBDFU1B,1:$$MAXY^IBDFU1B))-POS)
65 ;
66TOOMANY() ;are there too many lines in the box? returns 0 or 1
67 ;IBBLK is assumed to be defined=the block
68 N SPACING,NODE,START,NUMBER
69 Q:'$G(IBLINE) 0
70 Q:'$G(IBBLK) 0
71 S NODE=$G(^IBE(357.7,IBLINE,0))
72 S START=$P(NODE,"^",3),SPACING=$P(NODE,"^",8),NUMBER=$P(NODE,"^",7)
73 S SPACING=$S(SPACING="d":2,SPACING="t":3,1:1)
74 I (START+(SPACING*NUMBER)-(SPACING-1))>$$MAXY^IBDFU1B
75 Q $T
Note: See TracBrowser for help on using the repository browser.