source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF10A.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1IBDF10A ;ALB/CJM - ENCOUNTER FORM - (shifting data fields,lines,text areas,blocks);3/29/93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3FLDS(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts all of the data fields in IBBLK falling within the rectangle defined by TOP,BOTTOM,LEFT,RIGHT by AMOUNT
4 ;WAY="D" for down, "U" for up, "L" for left, "R" for right
5 N SUB,NODE,IBX,IBY,FLD,PIECE,POS,VERT,SIZE,BLKSIZE
6 S VERT=$S("UD"[WAY:1,1:0)
7 S BLKSIZE=$S(VERT:IBBLK("H"),1:IBBLK("W"))
8 ;shifts to the left or up are negative
9 S:"UL"[WAY AMOUNT=AMOUNT*(-1)
10 S FLD="" F S FLD=$O(^IBE(357.5,"C",IBBLK,FLD)) Q:'FLD D
11 .S PIECE=$S(VERT:11,1:10)
12 .S NODE=$G(^IBE(357.5,FLD,0)) Q:NODE=""
13 .S IBX=$P(NODE,"^",10),IBY=$P(NODE,"^",11),POS=$P(NODE,"^",PIECE) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
14 ..S SIZE=$S(VERT:$P(NODE,"^",12),1:$S($L($P(NODE,"^",6))>$P(NODE,"^",14):$L($P(NODE,"^",6)),1:$P(NODE,"^",14)))
15 ..S $P(^IBE(357.5,FLD,0),"^",PIECE)=$S(("LU"[WAY)&(POS+AMOUNT<0):0,("RD"[WAY)&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
16 .S SUB=0 F S SUB=$O(^IBE(357.5,FLD,2,SUB)) Q:'SUB D
17 ..S NODE=$G(^IBE(357.5,FLD,2,SUB,0)) Q:NODE=""
18 ..S PIECE=$S(VERT:5,1:4) S POS=$P(NODE,"^",PIECE),IBX=$P(NODE,"^",4),IBY=$P(NODE,"^",5) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
19 ...S SIZE=$S(VERT:1,1:$L($P(NODE,"^",1)))
20 ...S $P(^IBE(357.5,FLD,2,SUB,0),"^",PIECE)=$S(("LU"[WAY)&(POS+AMOUNT<0):0,("RD"[WAY)&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
21 ..S PIECE=$S(VERT:6,1:7) S POS=$P(NODE,"^",PIECE),IBX=$P(NODE,"^",7),IBY=$P(NODE,"^",6) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
22 ...S SIZE=$S(VERT:1,1:$P(NODE,"^",8))
23 ...S $P(^IBE(357.5,FLD,2,SUB,0),"^",PIECE)=$S("LU"[WAY&(POS+AMOUNT<0):0,"RD"[WAY&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
24 Q
25MFLDS(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts the multiple choice fields in IBBLK falling within the rectangle defined by TOP,BOTTOM,LEFT,RIGHT by AMOUNT
26 ;WAY="D" for down, "U" for up, "L" for left, "R" for right
27 N SUB,NODE,IBX,IBY,FLD,PIECE,POS,VERT,SIZE,BLKSIZE
28 S VERT=$S("UD"[WAY:1,1:0)
29 S BLKSIZE=$S(VERT:IBBLK("H"),1:IBBLK("W"))
30 ;shifts to the left or up are negative
31 S:"UL"[WAY AMOUNT=AMOUNT*(-1)
32 S FLD="" F S FLD=$O(^IBE(357.93,"C",IBBLK,FLD)) Q:'FLD D
33 .S PIECE=$S(VERT:4,1:3)
34 .S NODE=$G(^IBE(357.93,FLD,0)) Q:NODE=""
35 .I $P(NODE,"^",2)]"" D
36 ..S IBX=$P(NODE,"^",3),IBY=$P(NODE,"^",4),POS=$P(NODE,"^",PIECE) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
37 ...S SIZE=$S(VERT:1,1:$L($P(NODE,"^",2)))
38 ...S $P(^IBE(357.93,FLD,0),"^",PIECE)=$S(("LU"[WAY)&(POS+AMOUNT<0):0,("RD"[WAY)&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
39 .S SUB=0 F S SUB=$O(^IBE(357.93,FLD,1,SUB)) Q:'SUB D
40 ..S NODE=$G(^IBE(357.93,FLD,1,SUB,0)) Q:NODE=""
41 ..S PIECE=$S(VERT:3,1:2) S POS=$P(NODE,"^",PIECE),IBX=$P(NODE,"^",2),IBY=$P(NODE,"^",3) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
42 ...S SIZE=$S(VERT:1,1:$L($P(NODE,"^",1)))
43 ...S $P(^IBE(357.93,FLD,1,SUB,0),"^",PIECE)=$S(("LU"[WAY)&(POS+AMOUNT<0):0,("RD"[WAY)&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
44 ..S PIECE=$S(VERT:7,1:6) S POS=$P(NODE,"^",PIECE),IBX=$P(NODE,"^",6),IBY=$P(NODE,"^",7) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
45 ...S SIZE=$S(VERT:1,1:3)
46 ...S $P(^IBE(357.93,FLD,1,SUB,0),"^",PIECE)=$S("LU"[WAY&(POS+AMOUNT<0):0,"RD"[WAY&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
47 Q
48 ;
49HFLDS(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts the hand print fields in IBBLK falling within the rectangle defined by TOP,BOTTOM,LEFT,RIGHT by AMOUNT
50 ;WAY="D" for down, "U" for up, "L" for left, "R" for right
51 N SUB,NODE,IBX,IBY,FLD,PIECE,POS,VERT,SIZE,BLKSIZE
52 S VERT=$S("UD"[WAY:1,1:0)
53 S BLKSIZE=$S(VERT:IBBLK("H"),1:IBBLK("W"))
54 ;shifts to the left or up are negative
55 S:"UL"[WAY AMOUNT=AMOUNT*(-1)
56 S FLD="" F S FLD=$O(^IBE(359.94,"C",IBBLK,FLD)) Q:'FLD D
57 .S PIECE=$S(VERT:4,1:3)
58 .S NODE=$G(^IBE(359.94,FLD,0)) Q:NODE=""
59 .I $P(NODE,"^",2)]"" D
60 ..S IBX=$P(NODE,"^",3),IBY=$P(NODE,"^",4),POS=$P(NODE,"^",PIECE) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
61 ...S SIZE=$S(VERT:1,1:$L($P(NODE,"^",2)))
62 ...S $P(^IBE(359.94,FLD,0),"^",PIECE)=$S(("LU"[WAY)&(POS+AMOUNT<0):0,("RD"[WAY)&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
63 Q
64 ;
65LINES(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts all of the lines in IBBLK falling within the range START->END by AMOUNT - if END="" range extends all the way out
66 ;WAY="D" for down, "U" for up, "L" for left, "R" for right
67 N SUB,NODE,POS,LINE,PIECE,VERT,IBX,IBY,SIZE,BLKSIZE
68 S VERT=$S("UD"[WAY:1,1:0)
69 S BLKSIZE=$S(VERT:IBBLK("H"),1:IBBLK("W"))
70 ;shifts to the left or up are negative
71 S:"UL"[WAY AMOUNT=AMOUNT*(-1)
72 S LINE="" F S LINE=$O(^IBE(357.7,"C",IBBLK,LINE)) Q:'LINE D
73 .S NODE=$G(^IBE(357.7,LINE,0)) Q:NODE=""
74 .S PIECE=$S(VERT:3,1:2)
75 .S POS=$P(NODE,"^",PIECE),IBY=$P(NODE,"^",3),IBX=$P(NODE,"^",2) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
76 .S SIZE=$S(((($P(NODE,"^",4)="V")&VERT)!(($P(NODE,"^",4)="H")&'VERT)):$P(NODE,"^",5),1:1)
77 .S $P(^IBE(357.7,LINE,0),"^",PIECE)=$S("LU"[WAY&(POS+AMOUNT<0):0,"RD"[WAY&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
78 Q
79TXT(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts all of the text areas in IBBLK falling within the range START->END by AMOUNT - if END="" range extends all the way out
80 ;WAY="D" for down, "U" for up, "L" for left, "R" for right
81 N SUB,NODE,POS,TXT,PIECE,VERT,IBX,IBY,BLKSIZE,SIZE
82 S VERT=$S("UD"[WAY:1,1:0)
83 S BLKSIZE=$S(VERT:IBBLK("H"),1:IBBLK("W"))
84 ;shifts to the left or up are negative
85 S:"UL"[WAY AMOUNT=AMOUNT*(-1)
86 S TXT="" F S TXT=$O(^IBE(357.8,"C",IBBLK,TXT)) Q:'TXT D
87 .S NODE=$G(^IBE(357.8,TXT,0)) Q:NODE=""
88 .S PIECE=$S(VERT:4,1:3)
89 .S POS=$P(NODE,"^",PIECE),IBY=$P(NODE,"^",4),IBX=$P(NODE,"^",3) I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
90 .S SIZE=$S(VERT:$P(NODE,"^",6),1:$P(NODE,"^",5))
91 .S $P(^IBE(357.8,TXT,0),"^",PIECE)=$S("LU"[WAY&(POS+AMOUNT<0):0,"RD"[WAY&((POS+AMOUNT+SIZE)>BLKSIZE):BLKSIZE-SIZE,1:POS+AMOUNT)
92 Q
93 ;
94INRANGE(X,Y,TOP,BOTTOM,LEFT,RIGHT) ;
95 ;determines if (X,Y) is in the rectangle defined by TOP,BOTTOM,LEFT,RIGHT - returns 1 if yes,0 if no
96 I (X'<LEFT),((RIGHT="")!(X'>RIGHT)),(Y'<TOP),((BOTTOM="")!(Y'>BOTTOM)) Q 1
97 Q 0
98BLOCKS(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts blocks whose top left-hand corner is within the rectangular region defined by TOP,BOTTOM,LEFT,RIGHT
99 N SUB,NODE,POS,BLOCK,PIECE,VERT,IBX,IBY,BLKSIZE,FORMSIZE,NAME
100 S VERT=$S("UD"[WAY:1,1:0)
101 ;shifts to the left or up are negative
102 S:"UL"[WAY AMOUNT=AMOUNT*(-1)
103 S BLOCK="" F S BLOCK=$O(^IBE(357.1,"C",IBFORM,BLOCK)) Q:'BLOCK D
104 .S NODE=$G(^IBE(357.1,BLOCK,0)) Q:NODE=""
105 .S NAME=$P(NODE,"^")
106 .S PIECE=$S(VERT:4,1:5)
107 .S BLKSIZE=$S(VERT:$P(NODE,"^",7),1:$P(NODE,"^",6))
108 .S FORMSIZE=$S(VERT:IBFORM("HT"),1:IBFORM("WIDTH"))
109 .S POS=$P(NODE,"^",PIECE),IBY=$P(NODE,"^",4),IBX=$P(NODE,"^",5)
110 .I $$INRANGE(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
111 ..S $P(^IBE(357.1,BLOCK,0),"^",PIECE)=$S(("LU"[WAY)&(POS+AMOUNT<0):0,("DR"[WAY)&((POS+AMOUNT+BLKSIZE)>FORMSIZE):FORMSIZE-BLKSIZE,1:POS+AMOUNT)
112 Q
Note: See TracBrowser for help on using the repository browser.