- IBDF2D2 ;ALB/CJM - ENCOUNTER FORM - PRINT SELECTION LIST (cont'd) ;NOV 16,1992
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- OTHER ;prints area at bottom of list for 'other'
- N MAX,NODE,NAR,CODE,REQLEN,WIDTH,AREA,SC,IBY,IBX,COLWIDTH,ICR,NOTICR,COLUMNS,HT,I,J,HDR
- ;
- ;for ICR, each char will take up 172.7654
- ;for non-ICR, allocate 103.6593 for each hand printed char
- S ICR=172.7654
- S NOTICR=103.65924
- ;
- ;how much space for each machine printed char?
- D
- .I IBFORM("WIDTH")>96 S COLWIDTH=720/16.67 Q
- .I IBFORM("WIDTH")>80 S COLWIDTH=60 Q
- .S COLWIDTH=72
- ;
- Q:'IBLIST("INPUT_RTN")
- Q:'IBLIST("OTHER")
- I IBLIST("NAR_PRINT")!IBLIST("NAR_READ") D
- .S NAR=IBLIST("NAR_DATATYPE")
- .I 'NAR S (IBLIST("NAR_READ"),IBLIST("NAR_PRINT"))=0 Q
- .D DATATYPE^IBDFU1B(.NAR)
- .S:NAR("MAX_INPUT")<NAR("SPACE") NAR("MAX_INPUT")=NAR("SPACE")
- I IBLIST("CODE_PRINT")!IBLIST("CODE_READ") D
- .S CODE=IBLIST("CODE_DATATYPE")
- .I 'CODE S (IBLIST("CODE_READ"),IBLIST("CODE_PRINT"))=0 Q
- .D DATATYPE^IBDFU1B(.CODE)
- Q:'IBLIST("CODE_PRINT")&'IBLIST("NAR_PRINT")
- ;
- ;print field for code in ICR format? read with ICR?
- I IBLIST("CODE_PRINT") S IBLIST("CODE_PRINT")=2
- I '$G(IBFORM("SCAN",IBBLK("PAGE"))) D
- .S (IBLIST("CODE_READ"),IBLIST("NAR_READ"))=0
- .I IBLIST("CODE_PRINT"),IBLIST("CODE_READ") S IBLIST("CODE_READ")=3 ;read without ICR, but in ICR format
- .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
- E I IBFORM("SCAN","ICR") D
- .I IBLIST("NAR_READ"),IBLIST("NAR_PRINT") S (IBLIST("NAR_PRINT"),IBLIST("NAR_READ"))=2
- .I IBLIST("CODE_PRINT") S IBLIST("CODE_READ")=2
- .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
- ;
- ;calculate required width=REQLEN
- S MAX=IBBLK("W")-BOX
- S REQLEN=1+BOX
- F SC=1:1:8 I IBLIST("SCTYPE",SC)=2 D
- .I IBLIST("ROUTINE",SC)]"" S AREA(REQLEN)=SC,REQLEN=REQLEN+4 Q
- .I $L(IBLIST("SCSYMBOL",SC)) S AREA(REQLEN)=SC,REQLEN=REQLEN+$L(IBLIST("SCSYMBOL",SC))+1
- I REQLEN<(BOX+2) S REQLEN=BOX
- S (CODE("COL"),NAR("COL"))=REQLEN
- S:IBLIST("CODE_PRINT") REQLEN=REQLEN+$FN(((CODE("SPACE")*ICR)/COLWIDTH)+.49,"",0)
- Q:REQLEN>MAX
- ;
- ;use ICR format? Set WIDTH=width of a handprinted character accordingly
- S WIDTH=$S(IBFORM("SCAN","ICR")&IBLIST("NAR_READ")&$G(IBFORM("SCAN",IBBLK("PAGE"))):ICR,1:NOTICR)
- I IBLIST("NAR_PRINT") D
- .S NAR("LINES")=0
- .F D Q:I<MAX
- ..S NAR("LINES")=NAR("LINES")+1
- ..S NAR("WIDTH")=$FN((NAR("SPACE")/NAR("LINES"))+.49,"",0)
- ..S I=REQLEN+$FN(.49+((NAR("WIDTH")*WIDTH)/COLWIDTH),"",0)
- .S REQLEN=I+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")
- .;
- .S CODE("COL")=NAR("COL")+1+$FN(.49+((NAR("WIDTH")*WIDTH)/COLWIDTH),"",0)
- ;
- 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
- S COLUMNS=1 I IBLIST("OTHER")>1 S COLUMNS=(MAX-BOX)\(REQLEN-BOX+1) S:'COLUMNS COLUMNS=1
- ;
- S J=($FN((IBLIST("OTHER")/COLUMNS)+.49,"",0)*HT)+1 ;J=the hight needed
- I (J+COL("Y"))>(IBBLK("H")-BOX) S IBLIST("OTHER")=(IBBLK("H")-BOX)\(HT*COLUMNS),J=$FN((IBLIST("OTHER")/COLUMNS)+.49,"",0)*HT
- S J=J+1 ;want one line space between the 'other' and the list above it
- 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
- S J=$FN(.49+(CWIDTH\(COLUMNS*REQLEN)),"",0)+1 ;now J=width needed
- S:($G(IBLIST("X",J))<(COLUMNS*REQLEN)) J=J+1
- I ('$D(IBLIST("X",J)))!($G(IBLIST("X",J))'<(COLUMNS*REQLEN)) I '$G(IBLIST("H",J)) S IBLIST("H",J)=99
- S IBY=COL("Y")+COL("H")+1,IBX=0
- ;
- ;draw the headers
- 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)
- F J=0:1:(COLUMNS-1) D
- .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")
- ;
- S IBY=IBY+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)
- Q
- ;
- AREAS(IBY,COLUMN,CNT) ;draw the bubbles, etc.
- S IBX="" F S IBX=$O(AREA(IBX)) Q:'IBX D
- .S SC=AREA(IBX)
- .I IBLIST("ROUTINE",SC)]"" D
- ..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)
- .E D
- ..S I=IBLIST("SCSYMBOL",SC) I " "[I S I=$TR(I," ","_")
- ..D DRWSTR^IBDFU(1+IBY,IBX+(COLUMN*REQLEN),I)
- .;
- .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))
- ;
- ;add fields for the narrative
- I IBLIST("NAR_PRINT")!IBLIST("NAR_READ") D
- .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)
- .D:IBLIST("OTHER")>1 DRWSTR^IBDFU(IBY,NAR("COL")+(COLUMN*REQLEN),"(OTHER#"_CNT_")")
- ;
- ;add fields for the code
- I IBLIST("CODE_PRINT")!IBLIST("CODE_READ") D
- .I IBLIST("CODE_PRINT") D
- ..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)
- .D:('IBLIST("NAR_PRINT"))&(IBLIST("OTHER")>1) DRWSTR^IBDFU(IBY,CODE("COL")+(COLUMN*REQLEN),"(OTHER#"_CNT_")")
- .;
- .;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
- .I ('IBLIST("CODE_PRINT"))&IBLIST("NAR_PRINT") D
- ..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)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2D2 6268 printed Jan 18, 2025@03:52:29 Page 2
- IBDF2D2 ;ALB/CJM - ENCOUNTER FORM - PRINT SELECTION LIST (cont'd) ;NOV 16,1992
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- OTHER ;prints area at bottom of list for 'other'
- +1 NEW MAX,NODE,NAR,CODE,REQLEN,WIDTH,AREA,SC,IBY,IBX,COLWIDTH,ICR,NOTICR,COLUMNS,HT,I,J,HDR
- +2 ;
- +3 ;for ICR, each char will take up 172.7654
- +4 ;for non-ICR, allocate 103.6593 for each hand printed char
- +5 SET ICR=172.7654
- +6 SET NOTICR=103.65924
- +7 ;
- +8 ;how much space for each machine printed char?
- +9 Begin DoDot:1
- +10 IF IBFORM("WIDTH")>96
- SET COLWIDTH=720/16.67
- QUIT
- +11 IF IBFORM("WIDTH")>80
- SET COLWIDTH=60
- QUIT
- +12 SET COLWIDTH=72
- End DoDot:1
- +13 ;
- +14 if 'IBLIST("INPUT_RTN")
- QUIT
- +15 if 'IBLIST("OTHER")
- QUIT
- +16 IF IBLIST("NAR_PRINT")!IBLIST("NAR_READ")
- Begin DoDot:1
- +17 SET NAR=IBLIST("NAR_DATATYPE")
- +18 IF 'NAR
- SET (IBLIST("NAR_READ"),IBLIST("NAR_PRINT"))=0
- QUIT
- +19 DO DATATYPE^IBDFU1B(.NAR)
- +20 if NAR("MAX_INPUT")<NAR("SPACE")
- SET NAR("MAX_INPUT")=NAR("SPACE")
- End DoDot:1
- +21 IF IBLIST("CODE_PRINT")!IBLIST("CODE_READ")
- Begin DoDot:1
- +22 SET CODE=IBLIST("CODE_DATATYPE")
- +23 IF 'CODE
- SET (IBLIST("CODE_READ"),IBLIST("CODE_PRINT"))=0
- QUIT
- +24 DO DATATYPE^IBDFU1B(.CODE)
- End DoDot:1
- +25 if 'IBLIST("CODE_PRINT")&'IBLIST("NAR_PRINT")
- QUIT
- +26 ;
- +27 ;print field for code in ICR format? read with ICR?
- +28 IF IBLIST("CODE_PRINT")
- SET IBLIST("CODE_PRINT")=2
- +29 IF '$GET(IBFORM("SCAN",IBBLK("PAGE")))
- Begin DoDot:1
- +30 SET (IBLIST("CODE_READ"),IBLIST("NAR_READ"))=0
- +31 ;read without ICR, but in ICR format
- IF IBLIST("CODE_PRINT")
- IF IBLIST("CODE_READ")
- SET IBLIST("CODE_READ")=3
- +32 ;read the code without ICR from the narrative - not printed in ICR format
- IF 'IBLIST("CODE_PRINT")
- IF IBLIST("NAR_PRINT")
- SET IBLIST("CODE_READ")=1
- End DoDot:1
- +33 IF '$TEST
- IF IBFORM("SCAN","ICR")
- Begin DoDot:1
- +34 IF IBLIST("NAR_READ")
- IF IBLIST("NAR_PRINT")
- SET (IBLIST("NAR_PRINT"),IBLIST("NAR_READ"))=2
- +35 IF IBLIST("CODE_PRINT")
- SET IBLIST("CODE_READ")=2
- +36 ;read the code without ICR, but it is printed in ICR format
- IF 'IBLIST("CODE_PRINT")
- IF IBLIST("CODE_READ")
- IF IBLIST("NAR_PRINT")=2
- SET IBLIST("CODE_PRINT")=3
- End DoDot:1
- +37 ;
- +38 ;calculate required width=REQLEN
- +39 SET MAX=IBBLK("W")-BOX
- +40 SET REQLEN=1+BOX
- +41 FOR SC=1:1:8
- IF IBLIST("SCTYPE",SC)=2
- Begin DoDot:1
- +42 IF IBLIST("ROUTINE",SC)]""
- SET AREA(REQLEN)=SC
- SET REQLEN=REQLEN+4
- QUIT
- +43 IF $LENGTH(IBLIST("SCSYMBOL",SC))
- SET AREA(REQLEN)=SC
- SET REQLEN=REQLEN+$LENGTH(IBLIST("SCSYMBOL",SC))+1
- End DoDot:1
- +44 IF REQLEN<(BOX+2)
- SET REQLEN=BOX
- +45 SET (CODE("COL"),NAR("COL"))=REQLEN
- +46 if IBLIST("CODE_PRINT")
- SET REQLEN=REQLEN+$FNUMBER(((CODE("SPACE")*ICR)/COLWIDTH)+.49,"",0)
- +47 if REQLEN>MAX
- QUIT
- +48 ;
- +49 ;use ICR format? Set WIDTH=width of a handprinted character accordingly
- +50 SET WIDTH=$SELECT(IBFORM("SCAN","ICR")&IBLIST("NAR_READ")&$GET(IBFORM("SCAN",IBBLK("PAGE"))):ICR,1:NOTICR)
- +51 IF IBLIST("NAR_PRINT")
- Begin DoDot:1
- +52 SET NAR("LINES")=0
- +53 FOR
- Begin DoDot:2
- +54 SET NAR("LINES")=NAR("LINES")+1
- +55 SET NAR("WIDTH")=$FNUMBER((NAR("SPACE")/NAR("LINES"))+.49,"",0)
- +56 SET I=REQLEN+$FNUMBER(.49+((NAR("WIDTH")*WIDTH)/COLWIDTH),"",0)
- End DoDot:2
- if I<MAX
- QUIT
- +57 SET REQLEN=I+1
- +58 IF (MAX-REQLEN)<(CWIDTH-2)
- IF (IBLIST("OTHER")<2)!(REQLEN<((MAX\2))-2)
- SET NAR("WIDTH")=NAR("WIDTH")+(((MAX-REQLEN)*COLWIDTH)\WIDTH)
- IF WIDTH=ICR
- IF NAR("WIDTH")>NAR("MAX_INPUT")
- SET NAR("WIDTH")=NAR("MAX_INPUT")
- +59 ;
- +60 SET CODE("COL")=NAR("COL")+1+$FNUMBER(.49+((NAR("WIDTH")*WIDTH)/COLWIDTH),"",0)
- End DoDot:1
- +61 ;
- +62 SET HT=2
- if IBLIST("NAR_PRINT")
- SET HT=NAR("LINES")
- if IBLIST("NAR_PRINT")=1
- DO CNVRTHT^IBDF2D1(HT,.HT)
- if IBLIST("NAR_PRINT")=2
- SET HT=HT*2
- if IBLIST("OTHER")>1
- SET HT=HT+1
- +63 SET COLUMNS=1
- IF IBLIST("OTHER")>1
- SET COLUMNS=(MAX-BOX)\(REQLEN-BOX+1)
- if 'COLUMNS
- SET COLUMNS=1
- +64 ;
- +65 ;J=the hight needed
- SET J=($FNUMBER((IBLIST("OTHER")/COLUMNS)+.49,"",0)*HT)+1
- +66 IF (J+COL("Y"))>(IBBLK("H")-BOX)
- SET IBLIST("OTHER")=(IBBLK("H")-BOX)\(HT*COLUMNS)
- SET J=$FNUMBER((IBLIST("OTHER")/COLUMNS)+.49,"",0)*HT
- +67 ;want one line space between the 'other' and the list above it
- SET J=J+1
- +68 SET I=IBBLK("H")-(COL("Y")+J+BOX)
- IF I<COL("H")
- if I<0
- SET I=0
- SET (COL("ROWSLEFT"),COL("H"))=I
- if IBLIST("H",2)>I
- SET IBLIST("H",2)=I
- if IBLIST("H",3)>I
- SET IBLIST("H",3)=I
- +69 ;now J=width needed
- SET J=$FNUMBER(.49+(CWIDTH\(COLUMNS*REQLEN)),"",0)+1
- +70 if ($GET(IBLIST("X",J))<(COLUMNS*REQLEN))
- SET J=J+1
- +71 IF ('$DATA(IBLIST("X",J)))!($GET(IBLIST("X",J))'<(COLUMNS*REQLEN))
- IF '$GET(IBLIST("H",J))
- SET IBLIST("H",J)=99
- +72 SET IBY=COL("Y")+COL("H")+1
- SET IBX=0
- +73 ;
- +74 ;draw the headers
- +75 IF IBLIST("NAR_PRINT")
- SET HDR=IBLIST("NAR_HDR")
- DO CNVRTLEN^IBDF2D1(NAR("WIDTH"),.WIDTH)
- IF $LENGTH(HDR)>WIDTH
- SET HDR=$EXTRACT("NARRATIVE",1,WIDTH)
- +76 FOR J=0:1:(COLUMNS-1)
- Begin DoDot:1
- +77 if IBLIST("NAR_PRINT")
- DO DRWSTR^IBDFU(IBY,NAR("COL")+(J*REQLEN),HDR,"s")
- if IBLIST("CODE_PRINT")
- DO DRWSTR^IBDFU(IBY,CODE("COL")+(J*REQLEN),IBLIST("CODE_HDR"),"s")
- End DoDot:1
- +78 ;
- +79 SET IBY=IBY+1
- +80 FOR J=0:1:(IBLIST("OTHER")-1)
- SET I=J#COLUMNS
- SET CNT=CNT+1
- if (I=0)&J
- SET IBY=IBY+HT
- DO AREAS(IBY,I,CNT)
- +81 QUIT
- +82 ;
- AREAS(IBY,COLUMN,CNT) ;draw the bubbles, etc.
- +1 SET IBX=""
- FOR
- SET IBX=$ORDER(AREA(IBX))
- if 'IBX
- QUIT
- Begin DoDot:1
- +2 SET SC=AREA(IBX)
- +3 IF IBLIST("ROUTINE",SC)]""
- Begin DoDot:2
- +4 DO 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)
- End DoDot:2
- +5 IF '$TEST
- Begin DoDot:2
- +6 SET I=IBLIST("SCSYMBOL",SC)
- IF " "[I
- SET I=$TRANSLATE(I," ","_")
- +7 DO DRWSTR^IBDFU(1+IBY,IBX+(COLUMN*REQLEN),I)
- End DoDot:2
- +8 ;
- +9 if IBLIST("SCHDR",SC)'=""
- DO DRWSTR^IBDFU(IBY+1+(IBLIST("OTHER")>1),IBX+(COLUMN*REQLEN)+((IBLIST("SCW",SC)-$LENGTH(IBLIST("SCHDR",SC)))\2),IBLIST("SCHDR",SC))
- End DoDot:1
- +10 ;
- +11 ;add fields for the narrative
- +12 IF IBLIST("NAR_PRINT")!IBLIST("NAR_READ")
- Begin DoDot:1
- +13 DO 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)
- +14 if IBLIST("OTHER")>1
- DO DRWSTR^IBDFU(IBY,NAR("COL")+(COLUMN*REQLEN),"(OTHER#"_CNT_")")
- End DoDot:1
- +15 ;
- +16 ;add fields for the code
- +17 IF IBLIST("CODE_PRINT")!IBLIST("CODE_READ")
- Begin DoDot:1
- +18 IF IBLIST("CODE_PRINT")
- Begin DoDot:2
- +19 DO 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)
- End DoDot:2
- +20 if ('IBLIST("NAR_PRINT"))&(IBLIST("OTHER")>1)
- DO DRWSTR^IBDFU(IBY,CODE("COL")+(COLUMN*REQLEN),"(OTHER#"_CNT_")")
- +21 ;
- +22 ;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
- +23 IF ('IBLIST("CODE_PRINT"))&IBLIST("NAR_PRINT")
- Begin DoDot:2
- +24 DO 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)
- End DoDot:2
- End DoDot:1
- +25 QUIT