Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDF2D2

IBDF2D2.m

Go to the documentation of this file.
  1. IBDF2D2 ;ALB/CJM - ENCOUNTER FORM - PRINT SELECTION LIST (cont'd) ;NOV 16,1992
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. OTHER ;prints area at bottom of list for 'other'
  1. N MAX,NODE,NAR,CODE,REQLEN,WIDTH,AREA,SC,IBY,IBX,COLWIDTH,ICR,NOTICR,COLUMNS,HT,I,J,HDR
  1. ;
  1. ;for ICR, each char will take up 172.7654
  1. ;for non-ICR, allocate 103.6593 for each hand printed char
  1. S ICR=172.7654
  1. S NOTICR=103.65924
  1. ;
  1. ;how much space for each machine printed char?
  1. D
  1. .I IBFORM("WIDTH")>96 S COLWIDTH=720/16.67 Q
  1. .I IBFORM("WIDTH")>80 S COLWIDTH=60 Q
  1. .S COLWIDTH=72
  1. ;
  1. Q:'IBLIST("INPUT_RTN")
  1. Q:'IBLIST("OTHER")
  1. I IBLIST("NAR_PRINT")!IBLIST("NAR_READ") D
  1. .S NAR=IBLIST("NAR_DATATYPE")
  1. .I 'NAR S (IBLIST("NAR_READ"),IBLIST("NAR_PRINT"))=0 Q
  1. .D DATATYPE^IBDFU1B(.NAR)
  1. .S:NAR("MAX_INPUT")<NAR("SPACE") NAR("MAX_INPUT")=NAR("SPACE")
  1. I IBLIST("CODE_PRINT")!IBLIST("CODE_READ") D
  1. .S CODE=IBLIST("CODE_DATATYPE")
  1. .I 'CODE S (IBLIST("CODE_READ"),IBLIST("CODE_PRINT"))=0 Q
  1. .D DATATYPE^IBDFU1B(.CODE)
  1. Q:'IBLIST("CODE_PRINT")&'IBLIST("NAR_PRINT")
  1. ;
  1. ;print field for code in ICR format? read with ICR?
  1. I IBLIST("CODE_PRINT") S IBLIST("CODE_PRINT")=2
  1. I '$G(IBFORM("SCAN",IBBLK("PAGE"))) D
  1. .S (IBLIST("CODE_READ"),IBLIST("NAR_READ"))=0
  1. .I IBLIST("CODE_PRINT"),IBLIST("CODE_READ") S IBLIST("CODE_READ")=3 ;read without ICR, but in ICR format
  1. .I 'IBLIST("CODE_PRINT"),IBLIST("NAR_PRINT") S IBLIST("CODE_READ")=1 ;read the code without ICR from the narrative - not printed in ICR format
  1. E I IBFORM("SCAN","ICR") D
  1. .I IBLIST("NAR_READ"),IBLIST("NAR_PRINT") S (IBLIST("NAR_PRINT"),IBLIST("NAR_READ"))=2
  1. .I IBLIST("CODE_PRINT") S IBLIST("CODE_READ")=2
  1. .I 'IBLIST("CODE_PRINT"),IBLIST("CODE_READ"),IBLIST("NAR_PRINT")=2 S IBLIST("CODE_PRINT")=3 ;read the code without ICR, but it is printed in ICR format
  1. ;
  1. ;calculate required width=REQLEN
  1. S MAX=IBBLK("W")-BOX
  1. S REQLEN=1+BOX
  1. F SC=1:1:8 I IBLIST("SCTYPE",SC)=2 D
  1. .I IBLIST("ROUTINE",SC)]"" S AREA(REQLEN)=SC,REQLEN=REQLEN+4 Q
  1. .I $L(IBLIST("SCSYMBOL",SC)) S AREA(REQLEN)=SC,REQLEN=REQLEN+$L(IBLIST("SCSYMBOL",SC))+1
  1. I REQLEN<(BOX+2) S REQLEN=BOX
  1. S (CODE("COL"),NAR("COL"))=REQLEN
  1. S:IBLIST("CODE_PRINT") REQLEN=REQLEN+$FN(((CODE("SPACE")*ICR)/COLWIDTH)+.49,"",0)
  1. Q:REQLEN>MAX
  1. ;
  1. ;use ICR format? Set WIDTH=width of a handprinted character accordingly
  1. S WIDTH=$S(IBFORM("SCAN","ICR")&IBLIST("NAR_READ")&$G(IBFORM("SCAN",IBBLK("PAGE"))):ICR,1:NOTICR)
  1. I IBLIST("NAR_PRINT") D
  1. .S NAR("LINES")=0
  1. .F D Q:I<MAX
  1. ..S NAR("LINES")=NAR("LINES")+1
  1. ..S NAR("WIDTH")=$FN((NAR("SPACE")/NAR("LINES"))+.49,"",0)
  1. ..S I=REQLEN+$FN(.49+((NAR("WIDTH")*WIDTH)/COLWIDTH),"",0)
  1. .S REQLEN=I+1
  1. .I (MAX-REQLEN)<(CWIDTH-2),(IBLIST("OTHER")<2)!(REQLEN<((MAX\2))-2) S NAR("WIDTH")=NAR("WIDTH")+(((MAX-REQLEN)*COLWIDTH)\WIDTH) I WIDTH=ICR,NAR("WIDTH")>NAR("MAX_INPUT") S NAR("WIDTH")=NAR("MAX_INPUT")
  1. .;
  1. .S CODE("COL")=NAR("COL")+1+$FN(.49+((NAR("WIDTH")*WIDTH)/COLWIDTH),"",0)
  1. ;
  1. S HT=2 S:IBLIST("NAR_PRINT") HT=NAR("LINES") D:IBLIST("NAR_PRINT")=1 CNVRTHT^IBDF2D1(HT,.HT) S:IBLIST("NAR_PRINT")=2 HT=HT*2 S:IBLIST("OTHER")>1 HT=HT+1
  1. S COLUMNS=1 I IBLIST("OTHER")>1 S COLUMNS=(MAX-BOX)\(REQLEN-BOX+1) S:'COLUMNS COLUMNS=1
  1. ;
  1. S J=($FN((IBLIST("OTHER")/COLUMNS)+.49,"",0)*HT)+1 ;J=the hight needed
  1. I (J+COL("Y"))>(IBBLK("H")-BOX) S IBLIST("OTHER")=(IBBLK("H")-BOX)\(HT*COLUMNS),J=$FN((IBLIST("OTHER")/COLUMNS)+.49,"",0)*HT
  1. S J=J+1 ;want one line space between the 'other' and the list above it
  1. S I=IBBLK("H")-(COL("Y")+J+BOX) I I<COL("H") S:I<0 I=0 S (COL("ROWSLEFT"),COL("H"))=I S:IBLIST("H",2)>I IBLIST("H",2)=I S:IBLIST("H",3)>I IBLIST("H",3)=I
  1. S J=$FN(.49+(CWIDTH\(COLUMNS*REQLEN)),"",0)+1 ;now J=width needed
  1. S:($G(IBLIST("X",J))<(COLUMNS*REQLEN)) J=J+1
  1. I ('$D(IBLIST("X",J)))!($G(IBLIST("X",J))'<(COLUMNS*REQLEN)) I '$G(IBLIST("H",J)) S IBLIST("H",J)=99
  1. S IBY=COL("Y")+COL("H")+1,IBX=0
  1. ;
  1. ;draw the headers
  1. I IBLIST("NAR_PRINT") S HDR=IBLIST("NAR_HDR") D CNVRTLEN^IBDF2D1(NAR("WIDTH"),.WIDTH) I $L(HDR)>WIDTH S HDR=$E("NARRATIVE",1,WIDTH)
  1. F J=0:1:(COLUMNS-1) D
  1. .D:IBLIST("NAR_PRINT") DRWSTR^IBDFU(IBY,NAR("COL")+(J*REQLEN),HDR,"s") D:IBLIST("CODE_PRINT") DRWSTR^IBDFU(IBY,CODE("COL")+(J*REQLEN),IBLIST("CODE_HDR"),"s")
  1. ;
  1. S IBY=IBY+1
  1. F J=0:1:(IBLIST("OTHER")-1) S I=J#COLUMNS,CNT=CNT+1 S:(I=0)&J IBY=IBY+HT D AREAS(IBY,I,CNT)
  1. Q
  1. ;
  1. AREAS(IBY,COLUMN,CNT) ;draw the bubbles, etc.
  1. S IBX="" F S IBX=$O(AREA(IBX)) Q:'IBX D
  1. .S SC=AREA(IBX)
  1. .I IBLIST("ROUTINE",SC)]"" D
  1. ..D DRWBBL^IBDFM1((IBLIST("OTHER")>1)+IBY,IBX+(COLUMN*REQLEN),IBLIST("INPUT_RTN"),"",IBLIST("NAME"),"S"_IBLIST_"("_SC,IBLIST("RULE",SC),"OTHER#"_CNT_")","OTHER",IBLIST("QLFR",SC),0,CNT)
  1. .E D
  1. ..S I=IBLIST("SCSYMBOL",SC) I " "[I S I=$TR(I," ","_")
  1. ..D DRWSTR^IBDFU(1+IBY,IBX+(COLUMN*REQLEN),I)
  1. .;
  1. .D:IBLIST("SCHDR",SC)'="" DRWSTR^IBDFU(IBY+1+(IBLIST("OTHER")>1),IBX+(COLUMN*REQLEN)+((IBLIST("SCW",SC)-$L(IBLIST("SCHDR",SC)))\2),IBLIST("SCHDR",SC))
  1. ;
  1. ;add fields for the narrative
  1. I IBLIST("NAR_PRINT")!IBLIST("NAR_READ") D
  1. .D DRWHAND^IBDFM1(IBY+(IBLIST("OTHER")>1),NAR("COL")+(COLUMN*REQLEN),NAR("WIDTH"),IBLIST("INPUT_RTN"),NAR("LINES"),"S"_IBLIST_"(N",IBLIST("NAME")_"(OTHER)","OTHER","",CNT,IBLIST("NAR_PRINT"),IBLIST("NAR_READ"),NAR)
  1. .D:IBLIST("OTHER")>1 DRWSTR^IBDFU(IBY,NAR("COL")+(COLUMN*REQLEN),"(OTHER#"_CNT_")")
  1. ;
  1. ;add fields for the code
  1. I IBLIST("CODE_PRINT")!IBLIST("CODE_READ") D
  1. .I IBLIST("CODE_PRINT") D
  1. ..D DRWHAND^IBDFM1(IBY+(IBLIST("OTHER")>1),CODE("COL")+(COLUMN*REQLEN),CODE("SPACE"),IBLIST("INPUT_RTN"),1,"S"_IBLIST_"(C",IBLIST("NAME")_"(OTHER)","OTHER","",CNT,IBLIST("CODE_PRINT"),IBLIST("CODE_READ"),CODE)
  1. .D:('IBLIST("NAR_PRINT"))&(IBLIST("OTHER")>1) DRWSTR^IBDFU(IBY,CODE("COL")+(COLUMN*REQLEN),"(OTHER#"_CNT_")")
  1. .;
  1. .;if there wasn't a field printed on the form for the code, but there was for the narrative, read the code from the narrative - ICR should not be used, rather, require the operator to key in the code
  1. .I ('IBLIST("CODE_PRINT"))&IBLIST("NAR_PRINT") D
  1. ..D DRWHAND^IBDFM1(IBY+(IBLIST("OTHER")>1),NAR("COL")+(COLUMN*REQLEN),NAR("WIDTH"),IBLIST("INPUT_RTN"),NAR("LINES"),"S"_IBLIST_"(C",IBLIST("NAME")_"(OTHER)","OTHER","",CNT,0,IBLIST("CODE_READ"),CODE)
  1. Q