IBDF2D ;ALB/CJM - ENCOUNTER FORM - WRITE SELECTION LIST ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
;prints a selection list
PRINTLST(IBLIST) ;writes the selection list to the print array
;IBLIST - pointer to a selection list
;
N GROUPODR,SLCTNODR,GROUP,SLCTN,PRRGROUP,QUIT,COL,CWIDTH,CUTLEFT,CUTRIGHT,BOX,LINE,NEEDUPR,ALL,CNT,DRWBBL,TRACKBBL,LOCATION,HDR,SUBHDR
;CWIDTH=the width of the entries, including end "|"
;BOX=1 if the block is outlined
;LINE=1 if the separator between subcolumns has "|"
;NEEDUPR=1 if, when printing a group header, the row above should be underlined also - cures a defect caused when some subcolumns NOT underlined
;ALL=0 if list is dynamic and only data should be printed
;DRWBBL=1 while printing bubbles - can turn off printing of bubbles by setting DRWBBL=0
;TRACKBBL=1 if bubbles are going into form tracking - for dynamic lists
;HDR=text of group header
;SUBHDR=text of subheader within group (defined as a place holder)
;
S (TRACKBBL,GROUPODR,SLCTNODR,GROUP,SLCTN,PRRGROUP,COL,QUIT,NEEDUPR,CNT,SUBHDR,HDR)=""
S (DRWBBL,ALL)=1
;
Q:$$LSTDESCR^IBDFU1(.IBLIST)
Q:IBLIST("BLK")'=IBBLK
S BOX=$S(IBBLK("BOX")=2:0,1:1)
S LINE=(IBLIST("SEP")["|")
I 'IBLIST("NUMCOL") S IBLIST("NUMCOL")=8
D SCDESCR^IBDFU1(.IBLIST,.CWIDTH)
I IBLIST("DYNAMIC"),'IBPRINT("ENTIRE") S ALL=0
I IBLIST("DYNAMIC"),IBPRINT("WITH_DATA") D GETDATA(.LOCATION)
;
;should the bubbles be written to form tracking?
I IBLIST("DYNAMIC") I $G(IBPFID),$G(IBFORM("SCAN",IBBLK("PAGE"))),IBLIST("INPUT_RTN"),IBDEVICE("PCL") S TRACKBBL=1
;
;get the first column
D GETCOL^IBDF2D1(.COL) I 'COL D:IBDEVICE("LISTMAN") Q
.W !!,"The LIST="_IBLIST("NAME")_" in BLOCK="_IBBLK("NAME")_" requires at least",!,CWIDTH_" columns in order to display!",!
.D PAUSE^IBDFU5
;
D:ALL OTHER^IBDF2D2
D DRWCOL^IBDF2D1(.COL)
F D Q:QUIT
.S PRRGROUP=GROUP
.D NEXT(.GROUP,.GROUPODR,.SLCTNODR,.SLCTN) I 'SLCTN S QUIT=1 Q
.I COL("ROWSLEFT")<(1+IBLIST("BTWN")) D GETCOL^IBDF2D1(.COL) S:'COL QUIT=1 Q:QUIT D DRWCOL^IBDF2D1(.COL)
.D DISPLAY^IBDF2D3(SLCTN,.COL,HDR,.SUBHDR)
;
;for dynamic lists, if full data is needed, add to overflow report if there is more data
;
I 'IBDEVICE("LISTMAN"),IBLIST("DYNAMIC"),IBLIST("OVERFLOW"),SLCTN S @IBARRAY("OVERFLOW")@(IBBLK,IBLIST,"DYNAMIC LIST")=""
;
;no selections left - fill in with blank selections, unless dynamic and just filling in with data
I ALL S SLCTN="",QUIT=0 S:('IBLIST("DYNAMIC"))!('IBLIST("INPUT_RTN")) DRWBBL=0 F Q:'COL D
.F Q:(COL("ROWSLEFT")<(IBLIST("BTWN")+1)) D DISPLAY^IBDF2D3(SLCTN,.COL,HDR,.SUBHDR)
.D GETCOL^IBDF2D1(.COL) S:'COL QUIT=1 Q:QUIT D DRWCOL^IBDF2D1(.COL)
;
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
;
;
EXIT ;
Q
;
NEXT(GROUP,GROUPODR,SLCTNODR,SLCTN) ;finds the next selction to be printed
;** PARAMETERS - must be passed by reference **
N QUIT S QUIT=0
I IBLIST("DYNAMIC") D Q
.I IBPRINT("WITH_DATA") S:SLCTN="" SLCTN=0 S SLCTN=$O(@LOCATION@(SLCTN))
S GROUP=$G(GROUP),SLCTN=$G(SLCTN),GROUPODR=$G(GROUPODR),SLCTNODR=$G(SLCTNODR)
F Q:QUIT D
.I 'GROUP!(SLCTNODR="") D NXTGROUP(.GROUP,.GROUPODR) S (SLCTNODR,SLCTN)="" S:'GROUP QUIT=1 Q:QUIT I COL D Q:QUIT
..I COL("ROWSLEFT")<1 D GETCOL^IBDF2D1(.COL) S:'COL QUIT=1 Q:QUIT D DRWCOL^IBDF2D1(.COL)
..D GROUPHDR(GROUP,.COL,.HDR,.SUBHDR)
.I SLCTNODR="" S SLCTNODR=$O(^IBE(357.3,"APO",IBLIST,GROUP,"")) I SLCTNODR="" Q
.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))
Q
NXTGROUP(GROUP,GROUPODR) ;
;** PARAMETERS - must be passed by reference **
;
N QUIT S QUIT=0
F Q:QUIT D
.I (GROUPODR="")!('GROUP) S GROUPODR=$O(^IBE(357.4,"APO",IBLIST,GROUPODR)),GROUP="" I GROUPODR="" S QUIT=1 Q
.S GROUP=$O(^IBE(357.4,"APO",IBLIST,GROUPODR,GROUP)) S:GROUP QUIT=1
Q
;
GROUPHDR(GROUP,COL,HDR,SUBHDR) ;writes the group header to the list
;COL is the column to write at
;returns HDR=displayed text if passed by reference
;
N WIDTH,OPTIONS,OFFSET,NODE
S HDR=""
S SUBHDR=""
S NODE=^IBE(357.4,GROUP,0)
;don't print invisible headers
Q:$P(NODE,"^",4)="I"
S HDR=$P(NODE,"^")
;some other special cases
I (HDR="BLANK")!(HDR="") S HDR="" Q
;
S OPTIONS="",OFFSET=$L(IBLIST("SEP1")),WIDTH=CWIDTH-(2*OFFSET)
S HDR=$E(HDR,1,WIDTH)
S OPTIONS=$TR(IBLIST("DGHDR"),"C","")
S OPTIONS=$TR(OPTIONS,"SR","ss")
;
;only affects forms with big print - bold otherwise not available
;??? do we really want to assume bold not available for small fonts?
;I OPTIONS["s",OPTIONS'["B",IBFORM("WIDTH")<100 S OPTIONS=OPTIONS_"B"
;I IBFORM("WIDTH")>100 S OPTIONS=$TR(OPTIONS,"B")
;
I HDR=" " S OPTIONS=$TR(OPTIONS,"s","") S:'IBLIST("ULSLCTNS") OPTIONS=$TR(OPTIONS,"U","")
I IBLIST("DGHDR")["C" S OFFSET=OFFSET+((WIDTH-$L(HDR))\2)
I OPTIONS["U",$L(HDR)<WIDTH,'IBLIST("ULSLCTNS") D
.D DRWSTR^IBDFU($$Y,($$X)+OFFSET,"","U",$L(HDR))
.S OPTIONS=$TR(OPTIONS,"U","")
;want to apply options over entire column width?
;I IBLIST("ULSLCTNS")!(LINE&(OPTIONS["s")) D
I IBLIST("ULSLCTNS")!(OPTIONS["s") D
.D DRWSTR^IBDFU($$Y,($$X)+LINE,$J("",OFFSET-LINE)_HDR,OPTIONS,CWIDTH-(2*LINE))
.I OPTIONS["U",NEEDUPR D DRWSTR^IBDFU($$Y-1,($$X)+LINE,"","U",CWIDTH-(2*LINE)) S NEEDUPR=0
E D DRWSTR^IBDFU($$Y,($$X)+OFFSET,HDR,OPTIONS)
D DECREASE(.COL)
Q
;
DECREASE(COL) ;
S COL("ROWSLEFT")=COL("ROWSLEFT")-1
S COL("NEXTROW")=COL("NEXTROW")+1
Q
X() ;
Q COL("X")
Y() ;
Q COL("NEXTROW")+COL("Y")
;
GETDATA(LOCATION) ;gets the dynamic data at print time,@LOCATION=where the list was put
;
N RTN
S RTN=IBLIST("RTN")
D RTNDSCR^IBDFU1B(.RTN)
S LOCATION=RTN("DATA_LOCATION")
I RTN("ACTION")=3,RTN("DYNAMIC") D
.I $G(REPRINT),($G(RTN("INPUT_RTN"))]"") D REPRINT^IBDFN11(IBPFID,IBLIST,.LOCATION) Q
.I '$D(RTNLIST(RTN("RTN"))) Q:'$$DORTN^IBDFU1B(.RTN)
.S:'IBDEVICE("LISTMAN") RTNLIST(RTN("RTN"))=""
.K RTNLIST(RTN("RTN"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2D 6207 printed Dec 13, 2024@02:51:16 Page 2
IBDF2D ;ALB/CJM - ENCOUNTER FORM - WRITE SELECTION LIST ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
+2 ;prints a selection list
PRINTLST(IBLIST) ;writes the selection list to the print array
+1 ;IBLIST - pointer to a selection list
+2 ;
+3 NEW GROUPODR,SLCTNODR,GROUP,SLCTN,PRRGROUP,QUIT,COL,CWIDTH,CUTLEFT,CUTRIGHT,BOX,LINE,NEEDUPR,ALL,CNT,DRWBBL,TRACKBBL,LOCATION,HDR,SUBHDR
+4 ;CWIDTH=the width of the entries, including end "|"
+5 ;BOX=1 if the block is outlined
+6 ;LINE=1 if the separator between subcolumns has "|"
+7 ;NEEDUPR=1 if, when printing a group header, the row above should be underlined also - cures a defect caused when some subcolumns NOT underlined
+8 ;ALL=0 if list is dynamic and only data should be printed
+9 ;DRWBBL=1 while printing bubbles - can turn off printing of bubbles by setting DRWBBL=0
+10 ;TRACKBBL=1 if bubbles are going into form tracking - for dynamic lists
+11 ;HDR=text of group header
+12 ;SUBHDR=text of subheader within group (defined as a place holder)
+13 ;
+14 SET (TRACKBBL,GROUPODR,SLCTNODR,GROUP,SLCTN,PRRGROUP,COL,QUIT,NEEDUPR,CNT,SUBHDR,HDR)=""
+15 SET (DRWBBL,ALL)=1
+16 ;
+17 if $$LSTDESCR^IBDFU1(.IBLIST)
QUIT
+18 if IBLIST("BLK")'=IBBLK
QUIT
+19 SET BOX=$SELECT(IBBLK("BOX")=2:0,1:1)
+20 SET LINE=(IBLIST("SEP")["|")
+21 IF 'IBLIST("NUMCOL")
SET IBLIST("NUMCOL")=8
+22 DO SCDESCR^IBDFU1(.IBLIST,.CWIDTH)
+23 IF IBLIST("DYNAMIC")
IF 'IBPRINT("ENTIRE")
SET ALL=0
+24 IF IBLIST("DYNAMIC")
IF IBPRINT("WITH_DATA")
DO GETDATA(.LOCATION)
+25 ;
+26 ;should the bubbles be written to form tracking?
+27 IF IBLIST("DYNAMIC")
IF $GET(IBPFID)
IF $GET(IBFORM("SCAN",IBBLK("PAGE")))
IF IBLIST("INPUT_RTN")
IF IBDEVICE("PCL")
SET TRACKBBL=1
+28 ;
+29 ;get the first column
+30 DO GETCOL^IBDF2D1(.COL)
IF 'COL
if IBDEVICE("LISTMAN")
Begin DoDot:1
+31 WRITE !!,"The LIST="_IBLIST("NAME")_" in BLOCK="_IBBLK("NAME")_" requires at least",!,CWIDTH_" columns in order to display!",!
+32 DO PAUSE^IBDFU5
End DoDot:1
QUIT
+33 ;
+34 if ALL
DO OTHER^IBDF2D2
+35 DO DRWCOL^IBDF2D1(.COL)
+36 FOR
Begin DoDot:1
+37 SET PRRGROUP=GROUP
+38 DO NEXT(.GROUP,.GROUPODR,.SLCTNODR,.SLCTN)
IF 'SLCTN
SET QUIT=1
QUIT
+39 IF COL("ROWSLEFT")<(1+IBLIST("BTWN"))
DO GETCOL^IBDF2D1(.COL)
if 'COL
SET QUIT=1
if QUIT
QUIT
DO DRWCOL^IBDF2D1(.COL)
+40 DO DISPLAY^IBDF2D3(SLCTN,.COL,HDR,.SUBHDR)
End DoDot:1
if QUIT
QUIT
+41 ;
+42 ;for dynamic lists, if full data is needed, add to overflow report if there is more data
+43 ;
+44 IF 'IBDEVICE("LISTMAN")
IF IBLIST("DYNAMIC")
IF IBLIST("OVERFLOW")
IF SLCTN
SET @IBARRAY("OVERFLOW")@(IBBLK,IBLIST,"DYNAMIC LIST")=""
+45 ;
+46 ;no selections left - fill in with blank selections, unless dynamic and just filling in with data
+47 IF ALL
SET SLCTN=""
SET QUIT=0
if ('IBLIST("DYNAMIC"))!('IBLIST("INPUT_RTN"))
SET DRWBBL=0
FOR
if 'COL
QUIT
Begin DoDot:1
+48 FOR
if (COL("ROWSLEFT")<(IBLIST("BTWN")+1))
QUIT
DO DISPLAY^IBDF2D3(SLCTN,.COL,HDR,.SUBHDR)
+49 DO GETCOL^IBDF2D1(.COL)
if 'COL
SET QUIT=1
if QUIT
QUIT
DO DRWCOL^IBDF2D1(.COL)
End DoDot:1
+50 ;
+51 IF IBDEVICE("LISTMAN")
IF GROUP
DO NEXT(.GROUP,.GROUPODR,.SLCTNODR,.SLCTN)
IF SLCTN
WRITE !,"There are entries that do not fit on the ",IBLIST("NAME")," list!",!,"Column width="_CWIDTH,!,"Make more room to display all of the entries!",!
DO PAUSE^IBDFU5
+52 ;
+53 ;
EXIT ;
+1 QUIT
+2 ;
NEXT(GROUP,GROUPODR,SLCTNODR,SLCTN) ;finds the next selction to be printed
+1 ;** PARAMETERS - must be passed by reference **
+2 NEW QUIT
SET QUIT=0
+3 IF IBLIST("DYNAMIC")
Begin DoDot:1
+4 IF IBPRINT("WITH_DATA")
if SLCTN=""
SET SLCTN=0
SET SLCTN=$ORDER(@LOCATION@(SLCTN))
End DoDot:1
QUIT
+5 SET GROUP=$GET(GROUP)
SET SLCTN=$GET(SLCTN)
SET GROUPODR=$GET(GROUPODR)
SET SLCTNODR=$GET(SLCTNODR)
+6 FOR
if QUIT
QUIT
Begin DoDot:1
+7 IF 'GROUP!(SLCTNODR="")
DO NXTGROUP(.GROUP,.GROUPODR)
SET (SLCTNODR,SLCTN)=""
if 'GROUP
SET QUIT=1
if QUIT
QUIT
IF COL
Begin DoDot:2
+8 IF COL("ROWSLEFT")<1
DO GETCOL^IBDF2D1(.COL)
if 'COL
SET QUIT=1
if QUIT
QUIT
DO DRWCOL^IBDF2D1(.COL)
+9 DO GROUPHDR(GROUP,.COL,.HDR,.SUBHDR)
End DoDot:2
if QUIT
QUIT
+10 IF SLCTNODR=""
SET SLCTNODR=$ORDER(^IBE(357.3,"APO",IBLIST,GROUP,""))
IF SLCTNODR=""
QUIT
+11 SET SLCTN=$ORDER(^IBE(357.3,"APO",IBLIST,GROUP,SLCTNODR,SLCTN))
if SLCTN
SET QUIT=1
if 'SLCTN
SET SLCTNODR=$ORDER(^IBE(357.3,"APO",IBLIST,GROUP,SLCTNODR))
End DoDot:1
+12 QUIT
NXTGROUP(GROUP,GROUPODR) ;
+1 ;** PARAMETERS - must be passed by reference **
+2 ;
+3 NEW QUIT
SET QUIT=0
+4 FOR
if QUIT
QUIT
Begin DoDot:1
+5 IF (GROUPODR="")!('GROUP)
SET GROUPODR=$ORDER(^IBE(357.4,"APO",IBLIST,GROUPODR))
SET GROUP=""
IF GROUPODR=""
SET QUIT=1
QUIT
+6 SET GROUP=$ORDER(^IBE(357.4,"APO",IBLIST,GROUPODR,GROUP))
if GROUP
SET QUIT=1
End DoDot:1
+7 QUIT
+8 ;
GROUPHDR(GROUP,COL,HDR,SUBHDR) ;writes the group header to the list
+1 ;COL is the column to write at
+2 ;returns HDR=displayed text if passed by reference
+3 ;
+4 NEW WIDTH,OPTIONS,OFFSET,NODE
+5 SET HDR=""
+6 SET SUBHDR=""
+7 SET NODE=^IBE(357.4,GROUP,0)
+8 ;don't print invisible headers
+9 if $PIECE(NODE,"^",4)="I"
QUIT
+10 SET HDR=$PIECE(NODE,"^")
+11 ;some other special cases
+12 IF (HDR="BLANK")!(HDR="")
SET HDR=""
QUIT
+13 ;
+14 SET OPTIONS=""
SET OFFSET=$LENGTH(IBLIST("SEP1"))
SET WIDTH=CWIDTH-(2*OFFSET)
+15 SET HDR=$EXTRACT(HDR,1,WIDTH)
+16 SET OPTIONS=$TRANSLATE(IBLIST("DGHDR"),"C","")
+17 SET OPTIONS=$TRANSLATE(OPTIONS,"SR","ss")
+18 ;
+19 ;only affects forms with big print - bold otherwise not available
+20 ;??? do we really want to assume bold not available for small fonts?
+21 ;I OPTIONS["s",OPTIONS'["B",IBFORM("WIDTH")<100 S OPTIONS=OPTIONS_"B"
+22 ;I IBFORM("WIDTH")>100 S OPTIONS=$TR(OPTIONS,"B")
+23 ;
+24 IF HDR=" "
SET OPTIONS=$TRANSLATE(OPTIONS,"s","")
if 'IBLIST("ULSLCTNS")
SET OPTIONS=$TRANSLATE(OPTIONS,"U","")
+25 IF IBLIST("DGHDR")["C"
SET OFFSET=OFFSET+((WIDTH-$LENGTH(HDR))\2)
+26 IF OPTIONS["U"
IF $LENGTH(HDR)<WIDTH
IF 'IBLIST("ULSLCTNS")
Begin DoDot:1
+27 DO DRWSTR^IBDFU($$Y,($$X)+OFFSET,"","U",$LENGTH(HDR))
+28 SET OPTIONS=$TRANSLATE(OPTIONS,"U","")
End DoDot:1
+29 ;want to apply options over entire column width?
+30 ;I IBLIST("ULSLCTNS")!(LINE&(OPTIONS["s")) D
+31 IF IBLIST("ULSLCTNS")!(OPTIONS["s")
Begin DoDot:1
+32 DO DRWSTR^IBDFU($$Y,($$X)+LINE,$JUSTIFY("",OFFSET-LINE)_HDR,OPTIONS,CWIDTH-(2*LINE))
+33 IF OPTIONS["U"
IF NEEDUPR
DO DRWSTR^IBDFU($$Y-1,($$X)+LINE,"","U",CWIDTH-(2*LINE))
SET NEEDUPR=0
End DoDot:1
+34 IF '$TEST
DO DRWSTR^IBDFU($$Y,($$X)+OFFSET,HDR,OPTIONS)
+35 DO DECREASE(.COL)
+36 QUIT
+37 ;
DECREASE(COL) ;
+1 SET COL("ROWSLEFT")=COL("ROWSLEFT")-1
+2 SET COL("NEXTROW")=COL("NEXTROW")+1
+3 QUIT
X() ;
+1 QUIT COL("X")
Y() ;
+1 QUIT COL("NEXTROW")+COL("Y")
+2 ;
GETDATA(LOCATION) ;gets the dynamic data at print time,@LOCATION=where the list was put
+1 ;
+2 NEW RTN
+3 SET RTN=IBLIST("RTN")
+4 DO RTNDSCR^IBDFU1B(.RTN)
+5 SET LOCATION=RTN("DATA_LOCATION")
+6 IF RTN("ACTION")=3
IF RTN("DYNAMIC")
Begin DoDot:1
+7 IF $GET(REPRINT)
IF ($GET(RTN("INPUT_RTN"))]"")
DO REPRINT^IBDFN11(IBPFID,IBLIST,.LOCATION)
QUIT
+8 IF '$DATA(RTNLIST(RTN("RTN")))
if '$$DORTN^IBDFU1B(.RTN)
QUIT
+9 if 'IBDEVICE("LISTMAN")
SET RTNLIST(RTN("RTN"))=""
+10 KILL RTNLIST(RTN("RTN"))
End DoDot:1
+11 QUIT
