source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF2D.m

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1IBDF2D ;ALB/CJM - ENCOUNTER FORM - WRITE SELECTION LIST ;NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
3 ;prints a selection list
4PRINTLST(IBLIST) ;writes the selection list to the print array
5 ;IBLIST - pointer to a selection list
6 ;
7 N GROUPODR,SLCTNODR,GROUP,SLCTN,PRRGROUP,QUIT,COL,CWIDTH,CUTLEFT,CUTRIGHT,BOX,LINE,NEEDUPR,ALL,CNT,DRWBBL,TRACKBBL,LOCATION,HDR,SUBHDR
8 ;CWIDTH=the width of the entries, including end "|"
9 ;BOX=1 if the block is outlined
10 ;LINE=1 if the separator between subcolumns has "|"
11 ;NEEDUPR=1 if, when printing a group header, the row above should be underlined also - cures a defect caused when some subcolumns NOT underlined
12 ;ALL=0 if list is dynamic and only data should be printed
13 ;DRWBBL=1 while printing bubbles - can turn off printing of bubbles by setting DRWBBL=0
14 ;TRACKBBL=1 if bubbles are going into form tracking - for dynamic lists
15 ;HDR=text of group header
16 ;SUBHDR=text of subheader within group (defined as a place holder)
17 ;
18 S (TRACKBBL,GROUPODR,SLCTNODR,GROUP,SLCTN,PRRGROUP,COL,QUIT,NEEDUPR,CNT,SUBHDR,HDR)=""
19 S (DRWBBL,ALL)=1
20 ;
21 Q:$$LSTDESCR^IBDFU1(.IBLIST)
22 Q:IBLIST("BLK")'=IBBLK
23 S BOX=$S(IBBLK("BOX")=2:0,1:1)
24 S LINE=(IBLIST("SEP")["|")
25 I 'IBLIST("NUMCOL") S IBLIST("NUMCOL")=8
26 D SCDESCR^IBDFU1(.IBLIST,.CWIDTH)
27 I IBLIST("DYNAMIC"),'IBPRINT("ENTIRE") S ALL=0
28 I IBLIST("DYNAMIC"),IBPRINT("WITH_DATA") D GETDATA(.LOCATION)
29 ;
30 ;should the bubbles be written to form tracking?
31 I IBLIST("DYNAMIC") I $G(IBPFID),$G(IBFORM("SCAN",IBBLK("PAGE"))),IBLIST("INPUT_RTN"),IBDEVICE("PCL") S TRACKBBL=1
32 ;
33 ;get the first column
34 D GETCOL^IBDF2D1(.COL) I 'COL D:IBDEVICE("LISTMAN") Q
35 .W !!,"The LIST="_IBLIST("NAME")_" in BLOCK="_IBBLK("NAME")_" requires at least",!,CWIDTH_" columns in order to display!",!
36 .D PAUSE^IBDFU5
37 ;
38 D:ALL OTHER^IBDF2D2
39 D DRWCOL^IBDF2D1(.COL)
40 F D Q:QUIT
41 .S PRRGROUP=GROUP
42 .D NEXT(.GROUP,.GROUPODR,.SLCTNODR,.SLCTN) I 'SLCTN S QUIT=1 Q
43 .I COL("ROWSLEFT")<(1+IBLIST("BTWN")) D GETCOL^IBDF2D1(.COL) S:'COL QUIT=1 Q:QUIT D DRWCOL^IBDF2D1(.COL)
44 .D DISPLAY^IBDF2D3(SLCTN,.COL,HDR,.SUBHDR)
45 ;
46 ;for dynamic lists, if full data is needed, add to overflow report if there is more data
47 ;
48 I 'IBDEVICE("LISTMAN"),IBLIST("DYNAMIC"),IBLIST("OVERFLOW"),SLCTN S @IBARRAY("OVERFLOW")@(IBBLK,IBLIST,"DYNAMIC LIST")=""
49 ;
50 ;no selections left - fill in with blank selections, unless dynamic and just filling in with data
51 I ALL S SLCTN="",QUIT=0 S:('IBLIST("DYNAMIC"))!('IBLIST("INPUT_RTN")) DRWBBL=0 F Q:'COL D
52 .F Q:(COL("ROWSLEFT")<(IBLIST("BTWN")+1)) D DISPLAY^IBDF2D3(SLCTN,.COL,HDR,.SUBHDR)
53 .D GETCOL^IBDF2D1(.COL) S:'COL QUIT=1 Q:QUIT D DRWCOL^IBDF2D1(.COL)
54 ;
55 I IBDEVICE("LISTMAN"),GROUP D NEXT(.GROUP,.GROUPODR,.SLCTNODR,.SLCTN) I SLCTN W !,"There are entries that do not fit on the ",IBLIST("NAME")," list!",!,"Column width="_CWIDTH,!,"Make more room to display all of the entries!",! D PAUSE^IBDFU5
56 ;
57 ;
58EXIT ;
59 Q
60 ;
61NEXT(GROUP,GROUPODR,SLCTNODR,SLCTN) ;finds the next selction to be printed
62 ;** PARAMETERS - must be passed by reference **
63 N QUIT S QUIT=0
64 I IBLIST("DYNAMIC") D Q
65 .I IBPRINT("WITH_DATA") S:SLCTN="" SLCTN=0 S SLCTN=$O(@LOCATION@(SLCTN))
66 S GROUP=$G(GROUP),SLCTN=$G(SLCTN),GROUPODR=$G(GROUPODR),SLCTNODR=$G(SLCTNODR)
67 F Q:QUIT D
68 .I 'GROUP!(SLCTNODR="") D NXTGROUP(.GROUP,.GROUPODR) S (SLCTNODR,SLCTN)="" S:'GROUP QUIT=1 Q:QUIT I COL D Q:QUIT
69 ..I COL("ROWSLEFT")<1 D GETCOL^IBDF2D1(.COL) S:'COL QUIT=1 Q:QUIT D DRWCOL^IBDF2D1(.COL)
70 ..D GROUPHDR(GROUP,.COL,.HDR,.SUBHDR)
71 .I SLCTNODR="" S SLCTNODR=$O(^IBE(357.3,"APO",IBLIST,GROUP,"")) I SLCTNODR="" Q
72 .S SLCTN=$O(^IBE(357.3,"APO",IBLIST,GROUP,SLCTNODR,SLCTN)) S:SLCTN QUIT=1 S:'SLCTN SLCTNODR=$O(^IBE(357.3,"APO",IBLIST,GROUP,SLCTNODR))
73 Q
74NXTGROUP(GROUP,GROUPODR) ;
75 ;** PARAMETERS - must be passed by reference **
76 ;
77 N QUIT S QUIT=0
78 F Q:QUIT D
79 .I (GROUPODR="")!('GROUP) S GROUPODR=$O(^IBE(357.4,"APO",IBLIST,GROUPODR)),GROUP="" I GROUPODR="" S QUIT=1 Q
80 .S GROUP=$O(^IBE(357.4,"APO",IBLIST,GROUPODR,GROUP)) S:GROUP QUIT=1
81 Q
82 ;
83GROUPHDR(GROUP,COL,HDR,SUBHDR) ;writes the group header to the list
84 ;COL is the column to write at
85 ;returns HDR=displayed text if passed by reference
86 ;
87 N WIDTH,OPTIONS,OFFSET,NODE
88 S HDR=""
89 S SUBHDR=""
90 S NODE=^IBE(357.4,GROUP,0)
91 ;don't print invisible headers
92 Q:$P(NODE,"^",4)="I"
93 S HDR=$P(NODE,"^")
94 ;some other special cases
95 I (HDR="BLANK")!(HDR="") S HDR="" Q
96 ;
97 S OPTIONS="",OFFSET=$L(IBLIST("SEP1")),WIDTH=CWIDTH-(2*OFFSET)
98 S HDR=$E(HDR,1,WIDTH)
99 S OPTIONS=$TR(IBLIST("DGHDR"),"C","")
100 S OPTIONS=$TR(OPTIONS,"SR","ss")
101 ;
102 ;only affects forms with big print - bold otherwise not available
103 ;??? do we really want to assume bold not available for small fonts?
104 ;I OPTIONS["s",OPTIONS'["B",IBFORM("WIDTH")<100 S OPTIONS=OPTIONS_"B"
105 ;I IBFORM("WIDTH")>100 S OPTIONS=$TR(OPTIONS,"B")
106 ;
107 I HDR=" " S OPTIONS=$TR(OPTIONS,"s","") S:'IBLIST("ULSLCTNS") OPTIONS=$TR(OPTIONS,"U","")
108 I IBLIST("DGHDR")["C" S OFFSET=OFFSET+((WIDTH-$L(HDR))\2)
109 I OPTIONS["U",$L(HDR)<WIDTH,'IBLIST("ULSLCTNS") D
110 .D DRWSTR^IBDFU($$Y,($$X)+OFFSET,"","U",$L(HDR))
111 .S OPTIONS=$TR(OPTIONS,"U","")
112 ;want to apply options over entire column width?
113 ;I IBLIST("ULSLCTNS")!(LINE&(OPTIONS["s")) D
114 I IBLIST("ULSLCTNS")!(OPTIONS["s") D
115 .D DRWSTR^IBDFU($$Y,($$X)+LINE,$J("",OFFSET-LINE)_HDR,OPTIONS,CWIDTH-(2*LINE))
116 .I OPTIONS["U",NEEDUPR D DRWSTR^IBDFU($$Y-1,($$X)+LINE,"","U",CWIDTH-(2*LINE)) S NEEDUPR=0
117 E D DRWSTR^IBDFU($$Y,($$X)+OFFSET,HDR,OPTIONS)
118 D DECREASE(.COL)
119 Q
120 ;
121DECREASE(COL) ;
122 S COL("ROWSLEFT")=COL("ROWSLEFT")-1
123 S COL("NEXTROW")=COL("NEXTROW")+1
124 Q
125X() ;
126 Q COL("X")
127Y() ;
128 Q COL("NEXTROW")+COL("Y")
129 ;
130GETDATA(LOCATION) ;gets the dynamic data at print time,@LOCATION=where the list was put
131 ;
132 N RTN
133 S RTN=IBLIST("RTN")
134 D RTNDSCR^IBDFU1B(.RTN)
135 S LOCATION=RTN("DATA_LOCATION")
136 I RTN("ACTION")=3,RTN("DYNAMIC") D
137 .I $G(REPRINT),($G(RTN("INPUT_RTN"))]"") D REPRINT^IBDFN11(IBPFID,IBLIST,.LOCATION) Q
138 .I '$D(RTNLIST(RTN("RTN"))) Q:'$$DORTN^IBDFU1B(.RTN)
139 .S:'IBDEVICE("LISTMAN") RTNLIST(RTN("RTN"))=""
140 .K RTNLIST(RTN("RTN"))
141 Q
Note: See TracBrowser for help on using the repository browser.