source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFC2A.m@ 1618

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

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1IBDFC2A ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning (cont'd);MAR 3, 1995
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4BUBBLES(LIST) ;changes the marking areas to bubbles
5 ;no conversion if there is no input interface for the data
6 ;pass LIST array by reference
7 Q:'LIST("INPUT_RTN")
8 ;
9 N SC,SCORDER,LARGEST,SZCHANGE,NODE,CNT,BUBBLE
10 S (SZCHANGE,LARGEST)=0
11 ;
12 ;find the marking area used for bubbles
13 S BUBBLE=$O(^IBE(357.91,"B","BUBBLE (use for scanning)",0)) Q:'BUBBLE
14 ;
15 ;make two lists of the subcolumns, one indexed by ien and the other by the order - also, keep track of the largest subcolumn - adjustments may have to be made to it
16 S SC=0 F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC S SC(SC)=$G(^IBE(357.2,LIST,2,SC,0)),SCORDER(+SC(SC))=SC I $P(SC(SC),"^",4)=1,$P(SC(SC),"^",3)>+LARGEST S LARGEST=$P(SC(SC),"^",3)_"^"_SC
17 ;
18 ;look for the marking area subcolumns
19 S SC=0 F S SC=$O(SC(SC)) Q:'SC I $P(SC(SC),"^",4)=2,$P(SC(SC),"^",6)'=BUBBLE,$P(SC(SC),"^",6) D
20 .;
21 .;don't underline the marking area
22 .S $P(SC(SC),"^",8)=1
23 .;
24 .N MARK
25 .S MARK=$P($G(^IBE(357.91,$P(SC(SC),"^",6),0)),"^",2)
26 .Q:MARK=""
27 .I (MARK="(A) (I)")!(MARK="(A) (I) (H)")!(MARK="(P) (S)") D
28 ..;break this subcolumn in two
29 ..N QUAL1,QUAL2,HDR1,HDR2
30 ..I MARK["A" D
31 ...S QUAL1=$O(^IBD(357.98,"B","ACTIVE",0)),QUAL2=$O(^IBD(357.98,"B","INACTIVE",0)),HDR1="A",HDR2="I"
32 ..E D
33 ...S QUAL1=$O(^IBD(357.98,"B","PRIMARY",0)),QUAL2=$O(^IBD(357.98,"B","SECONDARY",0)),HDR1="P",HDR2="S"
34 ..F CNT=1:1 I '$D(^IBE(357.2,LIST,2,CNT)) Q
35 ..;create a new subcolumn
36 ..S NODE=SC(SC),$P(NODE,"^")=+SC(SC)+.5,$P(NODE,"^",2)=HDR2,$P(NODE,"^",9)=QUAL2,$P(NODE,"^",6)=BUBBLE,^IBE(357.2,LIST,2,CNT,0)=NODE,$P(^IBE(357.2,LIST,2,0),"^",4)=$P(^IBE(357.2,LIST,2,0),"^",4)+1,SC(CNT)=NODE,SCORDER(+NODE)=CNT
37 ..;change the original subcolumn
38 ..S NODE=SC(SC),$P(NODE,"^",2)=HDR1,$P(NODE,"^",9)=QUAL1,$P(NODE,"^",6)=BUBBLE,^IBE(357.2,LIST,2,SC,0)=NODE
39 ..;
40 ..;may have to make an adjustment
41 ..S SZCHANGE=SZCHANGE+($L(LIST("SEP"))-1)
42 .;
43 .;just change the marking area to bubble
44 .E D
45 ..S $P(^IBE(357.2,LIST,2,SC,0),"^",6)=BUBBLE
46 ..S SZCHANGE=SZCHANGE+(3-$L(MARK))
47 ..;
48 ;
49 ;adjust subcolumn size to make up for extra space required by bubbles - may truncate text
50 I SZCHANGE D
51 .N SLCTN,SUBCOL,ORDER,IEN,NEWSIZE,TEXT
52 .S SUBCOL=$P(LARGEST,"^",2)
53 .S NEWSIZE=$P(SC(SUBCOL),"^",3)-SZCHANGE
54 .S $P(SC(SUBCOL),"^",3)=NEWSIZE,^IBE(357.2,LIST,2,SUBCOL,0)=SC(SUBCOL)
55 .S ORDER=+SC(SUBCOL)
56 .S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",LIST,SLCTN)) Q:'SLCTN S IEN=$O(^IBE(357.3,SLCTN,1,"B",ORDER,0)) Q:'IEN D
57 ..S TEXT=$P($G(^IBE(357.3,SLCTN,1,IEN,0)),"^",2)
58 ..I $L(TEXT)>NEWSIZE D WARNING^IBDFC2("IN THE LIST '"_LIST("NAME")_"' THE TEXT '"_TEXT_"' WILL BE TRUNCATED BY "_($L(TEXT)-NEWSIZE)_" CHARACTERS - MANUAL EDITING MAY BE REQUIRED")
59 ;
60 ;reorder the subcolumns
61 N IBSWT
62 S (CNT,SCORDER)=0
63 F S SCORDER=$O(SCORDER(SCORDER)) Q:'SCORDER S CNT=CNT+1 I SCORDER'=CNT D I $P(SC(SCORDER(SCORDER)),"^",4)=1 S IBSWT(SCORDER)=CNT
64 .K ^IBE(357.2,LIST,2,"B",SCORDER,SCORDER(SCORDER))
65 .S $P(^IBE(357.2,LIST,2,SCORDER(SCORDER),0),"^")=CNT,^IBE(357.2,LIST,2,"B",CNT,SCORDER(SCORDER))=""
66 .;make the change in the selection due to the reordering of the subcolumns
67 .;I $P(SC(SCORDER(SCORDER)),"^",4)=1 D SWITCH^IBDF9A(LIST,SCORDER,CNT)
68 D SWITCH^IBDF9A(LIST,.IBSWT)
69 Q
Note: See TracBrowser for help on using the repository browser.