IBDF2D1 ;ALB/CJM - ENCOUNTER FORM - PRINT SELECTION LIST (cont'd) ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
GETCOL(COL) ;finds next column
;COL - array where output data stored,SHOULD BE PASSED BY REFERENCE
;COL=last column number processed
;COL("Y")=columns starting row relative to block
;COL("X")=column's starting column relative to block
;COL("H")=column's height, i.e., maximum # of selections
;
S COL=$G(COL)+1
S NEEDUPR=0
I COL=1 S COL("H")=+IBLIST("H",1),COL("X")=+IBLIST("X",1),COL("Y")=+IBLIST("Y",1)
I COL>IBLIST("NUMCOL") S COL=0 Q
I $G(IBLIST("Y",COL))'=+$G(IBLIST("Y",COL)) D
.I COL=1 S COL("Y")=$S(IBBLK("HDR")="":BOX,1:2+BOX)
.I COL'=1 Q ;leave value from prior col
E S COL("Y")=$G(IBLIST("Y",COL))
I $G(IBLIST("X",COL))'=+$G(IBLIST("X",COL)) D
.Q:COL=1
.S COL("X")=COL("X")+CWIDTH+$S(IBLIST("SEP")=" ":2,IBLIST("SEP")=" ":4,1:0)
E S COL("X")=$G(IBLIST("X",COL))
I $G(IBLIST("H",COL))'=+$G(IBLIST("H",COL)) D
.I COL=1 S COL("H")=IBBLK("H")
.I COL'=1 Q ;leave value from prior col
E S COL("H")=$G(IBLIST("H",COL))
I BOX,'LINE,COL("X")=0 S COL("X")=1
I (COL("X")+CWIDTH+(('LINE)&BOX))>IBBLK("W") S COL=0 Q
I (COL("Y")+COL("H"))>(IBBLK("H")-(2*BOX)) S COL("H")=(IBBLK("H")-(COL("Y")+BOX))
S COL("ROWSLEFT")=COL("H"),COL("NEXTROW")=0
Q
;
DRWCOL(COL) ;draws one column of the selection list except for its contents and rows
N I,OFFSET,WIDTH
I LINE,(COL("X")'=0)!('BOX),ALL D DRWVLINE^IBDFU($$Y^IBDF2D,$$X^IBDF2D,COL("H"),"|")
I LINE,('BOX)!(COL("X")+CWIDTH'=IBBLK("W")),ALL D DRWVLINE^IBDFU($$Y^IBDF2D,$$X^IBDF2D+(CWIDTH-1),COL("H"),"|")
;
;draw the column header
I IBLIST("HDR")'="",(COL("ROWSLEFT")>0) D:ALL D DECREASE^IBDF2D(.COL)
.S IBLIST("DHDR")=$TR(IBLIST("DHDR"),"RS","rs")
.;only affects forms with big print - bold otherwise not available
.I (IBLIST("DHDR")["s")!(IBLIST("DHDR")["r"),IBLIST("DHDR")'["B",IBFORM("WIDTH")<100 S IBLIST("DHDR")=IBLIST("DHDR")_"B"
.I IBFORM("WIDTH")>100 S IBLIST("DHDR")=$TR(IBLIST("DHDR"),"B")
.;
.S WIDTH=CWIDTH-(2*LINE)
.S OFFSET=LINE
.I IBLIST("DHDR")["C",$L(IBLIST("HDR"))<WIDTH S OFFSET=OFFSET+((WIDTH-$L(IBLIST("HDR")))\2)
.D DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+LINE,$J("",OFFSET)_IBLIST("HDR"),$TR(IBLIST("DHDR"),"C",""),WIDTH)
;
;draw the header line for the subcolumns
I COL("ROWSLEFT")>0,IBLIST("CHDR")]"" D:ALL D DECREASE^IBDF2D(.COL)
.S IBLIST("DSCHDR")=$TR(IBLIST("DSCHDR"),"R","r")
.;only affects forms with big print - bold otherwise not available
.I IBLIST("DSCHDR")["r",IBLIST("DSCHDR")'["B",IBFORM("WIDTH")<100 S IBLIST("DSCHDR")=IBLIST("DSCHDR")_"B"
.I IBFORM("WIDTH")>100 S IBLIST("DSCHDR")=$TR(IBLIST("DSCHDR"),"B")
.;
.;apply options across entire line?
.;if nothing else applies uderline SCs (maybe)
.I IBLIST("ULSLCTNS")!LINE!(BOX&(CWIDTH>(IBBLK("W")-3-(2*(IBLIST("SEP1")))))) D Q
..I IBLIST("DSCHDR")="",IBLIST("ULSLCTNS") S IBLIST("DSCHDR")=IBLIST("DSCHDR")_"U"
..D DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+LINE,IBLIST("CHDR"),IBLIST("DSCHDR"),CWIDTH-(2*LINE))
.;
.;apply display options just to the text, not accross the column
.I IBLIST("DSCHDR")="" S IBLIST("DSCHDR")="U"
.F I=1-IBLIST("SC0"):1:8 I IBLIST("SCTYPE",I)'="",IBLIST("SCHDR",I)'="" D DRWSTR^IBDFU($$Y^IBDF2D,(($$X^IBDF2D)+IBLIST("SCOS",I)),IBLIST("SCHDR",I),IBLIST("DSCHDR"),$L(IBLIST("SCHDR",I)))
Q
;
CNVRTHT(HPLINES,LINES) ;changes HPLINES=number of handprint lines into LINES=print lines on the page
;pass LINES by reference
S LINES=$FN(1.5*HPLINES,"",0)
Q
;
CNVRTLEN(HPWIDTH,WIDTH) ;changes HPWIDTH=width in terms of handprint characters into width in terms of columns(machine print characters)
;pass WIDTH by reference
;
N COLWIDTH
D
.I IBFORM("WIDTH")>96 S COLWIDTH=720/16.67 Q
.I IBFORM("WIDTH")>80 S COLWIDTH=60 Q
.S COLWIDTH=72
S WIDTH=$FN(.49+((HPWIDTH*103.65924)/COLWIDTH),"",0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2D1 3919 printed Dec 13, 2024@02:51:17 Page 2
IBDF2D1 ;ALB/CJM - ENCOUNTER FORM - PRINT SELECTION LIST (cont'd) ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
GETCOL(COL) ;finds next column
+1 ;COL - array where output data stored,SHOULD BE PASSED BY REFERENCE
+2 ;COL=last column number processed
+3 ;COL("Y")=columns starting row relative to block
+4 ;COL("X")=column's starting column relative to block
+5 ;COL("H")=column's height, i.e., maximum # of selections
+6 ;
+7 SET COL=$GET(COL)+1
+8 SET NEEDUPR=0
+9 IF COL=1
SET COL("H")=+IBLIST("H",1)
SET COL("X")=+IBLIST("X",1)
SET COL("Y")=+IBLIST("Y",1)
+10 IF COL>IBLIST("NUMCOL")
SET COL=0
QUIT
+11 IF $GET(IBLIST("Y",COL))'=+$GET(IBLIST("Y",COL))
Begin DoDot:1
+12 IF COL=1
SET COL("Y")=$SELECT(IBBLK("HDR")="":BOX,1:2+BOX)
+13 ;leave value from prior col
IF COL'=1
QUIT
End DoDot:1
+14 IF '$TEST
SET COL("Y")=$GET(IBLIST("Y",COL))
+15 IF $GET(IBLIST("X",COL))'=+$GET(IBLIST("X",COL))
Begin DoDot:1
+16 if COL=1
QUIT
+17 SET COL("X")=COL("X")+CWIDTH+$SELECT(IBLIST("SEP")=" ":2,IBLIST("SEP")=" ":4,1:0)
End DoDot:1
+18 IF '$TEST
SET COL("X")=$GET(IBLIST("X",COL))
+19 IF $GET(IBLIST("H",COL))'=+$GET(IBLIST("H",COL))
Begin DoDot:1
+20 IF COL=1
SET COL("H")=IBBLK("H")
+21 ;leave value from prior col
IF COL'=1
QUIT
End DoDot:1
+22 IF '$TEST
SET COL("H")=$GET(IBLIST("H",COL))
+23 IF BOX
IF 'LINE
IF COL("X")=0
SET COL("X")=1
+24 IF (COL("X")+CWIDTH+(('LINE)&BOX))>IBBLK("W")
SET COL=0
QUIT
+25 IF (COL("Y")+COL("H"))>(IBBLK("H")-(2*BOX))
SET COL("H")=(IBBLK("H")-(COL("Y")+BOX))
+26 SET COL("ROWSLEFT")=COL("H")
SET COL("NEXTROW")=0
+27 QUIT
+28 ;
DRWCOL(COL) ;draws one column of the selection list except for its contents and rows
+1 NEW I,OFFSET,WIDTH
+2 IF LINE
IF (COL("X")'=0)!('BOX)
IF ALL
DO DRWVLINE^IBDFU($$Y^IBDF2D,$$X^IBDF2D,COL("H"),"|")
+3 IF LINE
IF ('BOX)!(COL("X")+CWIDTH'=IBBLK("W"))
IF ALL
DO DRWVLINE^IBDFU($$Y^IBDF2D,$$X^IBDF2D+(CWIDTH-1),COL("H"),"|")
+4 ;
+5 ;draw the column header
+6 IF IBLIST("HDR")'=""
IF (COL("ROWSLEFT")>0)
if ALL
Begin DoDot:1
+7 SET IBLIST("DHDR")=$TRANSLATE(IBLIST("DHDR"),"RS","rs")
+8 ;only affects forms with big print - bold otherwise not available
+9 IF (IBLIST("DHDR")["s")!(IBLIST("DHDR")["r")
IF IBLIST("DHDR")'["B"
IF IBFORM("WIDTH")<100
SET IBLIST("DHDR")=IBLIST("DHDR")_"B"
+10 IF IBFORM("WIDTH")>100
SET IBLIST("DHDR")=$TRANSLATE(IBLIST("DHDR"),"B")
+11 ;
+12 SET WIDTH=CWIDTH-(2*LINE)
+13 SET OFFSET=LINE
+14 IF IBLIST("DHDR")["C"
IF $LENGTH(IBLIST("HDR"))<WIDTH
SET OFFSET=OFFSET+((WIDTH-$LENGTH(IBLIST("HDR")))\2)
+15 DO DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+LINE,$JUSTIFY("",OFFSET)_IBLIST("HDR"),$TRANSLATE(IBLIST("DHDR"),"C",""),WIDTH)
End DoDot:1
DO DECREASE^IBDF2D(.COL)
+16 ;
+17 ;draw the header line for the subcolumns
+18 IF COL("ROWSLEFT")>0
IF IBLIST("CHDR")]""
if ALL
Begin DoDot:1
+19 SET IBLIST("DSCHDR")=$TRANSLATE(IBLIST("DSCHDR"),"R","r")
+20 ;only affects forms with big print - bold otherwise not available
+21 IF IBLIST("DSCHDR")["r"
IF IBLIST("DSCHDR")'["B"
IF IBFORM("WIDTH")<100
SET IBLIST("DSCHDR")=IBLIST("DSCHDR")_"B"
+22 IF IBFORM("WIDTH")>100
SET IBLIST("DSCHDR")=$TRANSLATE(IBLIST("DSCHDR"),"B")
+23 ;
+24 ;apply options across entire line?
+25 ;if nothing else applies uderline SCs (maybe)
+26 IF IBLIST("ULSLCTNS")!LINE!(BOX&(CWIDTH>(IBBLK("W")-3-(2*(IBLIST("SEP1"))))))
Begin DoDot:2
+27 IF IBLIST("DSCHDR")=""
IF IBLIST("ULSLCTNS")
SET IBLIST("DSCHDR")=IBLIST("DSCHDR")_"U"
+28 DO DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+LINE,IBLIST("CHDR"),IBLIST("DSCHDR"),CWIDTH-(2*LINE))
End DoDot:2
QUIT
+29 ;
+30 ;apply display options just to the text, not accross the column
+31 IF IBLIST("DSCHDR")=""
SET IBLIST("DSCHDR")="U"
+32 FOR I=1-IBLIST("SC0"):1:8
IF IBLIST("SCTYPE",I)'=""
IF IBLIST("SCHDR",I)'=""
DO DRWSTR^IBDFU($$Y^IBDF2D,(($$X^IBDF2D)+IBLIST("SCOS",I)),IBLIST("SCHDR",I),IBLIST("DSCHDR"),$LENGTH(IBLIST("SCHDR",I)))
End DoDot:1
DO DECREASE^IBDF2D(.COL)
+33 QUIT
+34 ;
CNVRTHT(HPLINES,LINES) ;changes HPLINES=number of handprint lines into LINES=print lines on the page
+1 ;pass LINES by reference
+2 SET LINES=$FNUMBER(1.5*HPLINES,"",0)
+3 QUIT
+4 ;
CNVRTLEN(HPWIDTH,WIDTH) ;changes HPWIDTH=width in terms of handprint characters into width in terms of columns(machine print characters)
+1 ;pass WIDTH by reference
+2 ;
+3 NEW COLWIDTH
+4 Begin DoDot:1
+5 IF IBFORM("WIDTH")>96
SET COLWIDTH=720/16.67
QUIT
+6 IF IBFORM("WIDTH")>80
SET COLWIDTH=60
QUIT
+7 SET COLWIDTH=72
End DoDot:1
+8 SET WIDTH=$FNUMBER(.49+((HPWIDTH*103.65924)/COLWIDTH),"",0)
+9 QUIT
