IBDFBKS ;ALB/CJM/AAS - Create form spec file for scanning ; 6-JUN-95
;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
;
SCAN(IBFORMID) ;
;
Q:'$G(IBFORMID)
N IBLC,PERPAGE,PAGE,ROW,COL,PAGESIZE,SCAN,ARY,X,Y,ROWHT,ROWWIDTH,CONVERT,COUNT,LINE,TAG,NAME,XOFFSET,YOFFSET,NODE,FID,TYPE,XBUBOS,YBUBOS,COUNT,YHANDOS,FIELD,IEN,QLFR,PRIORPAG,END,LN,FIELDS,IBDFILL,IBDBKGND,XYSMALL
;XOFFSET,YOFFSET are the page margins (in decipoints)
;XBUBOS,YBUBOS are the offsets within the col,row of the bubbles
;YHANDOS is the offset for a handprint field within the row
;
I '$D(DT) D DT^DICRW
I $D(^IBD(359.2,IBFORMID,0)),$D(^IBD(357.95,IBFORMID,0)) S DIK="^IBD(359.2,",DA=IBFORMID D ^DIK
I '$D(DT) D DT^DICRW
S IBLC=0
D PARAM
S CONVERT=.352778 ;for converting PCL decipoints to .1mm
; This number is actually 254/720 ... 254 PK points (.1 mm) = 1 inch
; 720 PCL5 decipoints = 1 inch
; A PCL5 decipoint = .352778 PK points
S SCAN="^TMP(""IBDF"",$J,""SCAN"",IBFORMID)"
K @SCAN
;
S FIELDS="^TMP(""IBDF"",$J,""FIELDS"")"
K @FIELDS
;
;get form description
S NODE=$G(^IBD(357.95,IBFORMID,0))
Q:NODE=""
S PERPAGE=$P(NODE,"^",10)
;determine sizes and offsets - in terms of PCL decipoints
S XOFFSET=180 ; This is 1/4 inch ... .25*720 PCL decipoints
S YOFFSET=360 ; This is 1/2 inch ... .5*720 PCL decipoints
; rowht = # of PCL decipoints/line in height
; 80 lines (133 Col) = 720/8 lines per inch)
; 72 lines (96 Col) = 720/7.2 lines per inch)
; 60 lines (80 Col) = 720/6 lines per inch)
S ROWHT=$P(NODE,"^",10),ROWHT=$S(ROWHT>72:90,ROWHT>60:100.0005,1:120)
S COLWIDTH=$P(NODE,"^",9)
S XBUBOS=$S(COLWIDTH>96:.5,COLWIDTH>80:.75,1:1) ;leaves offset in terms of fraction of column width - must still convert to decipoints
S YBUBOS=$S(COLWIDTH>96:65,COLWIDTH>80:75,1:85)
; colwidth = # of PCL decipoints/character in width
; 133 Col = 720/16.67 char per inch
; 96 Col = 720/12 char per inch
; 80 Col = 720/10 char per inch
S COLWIDTH=$S(COLWIDTH>96:(720/16.67),COLWIDTH>80:60,1:72) ;converted to decipoints
S XBUBOS=XBUBOS*COLWIDTH ;converted to decipoints
S YHANDOS=$S(ROWHT=90:0,ROWHT=100.0005:15,1:30)
;
;get the list of scannable pages
S IEN=0 F S IEN=$O(^IBD(357.95,IBFORMID,3,IEN)) Q:'IEN S NODE=$G(^IBD(357.95,IBFORMID,3,IEN,0)) S:$P(NODE,"^",2) PAGE(+NODE)=""
;
;
S PAGE=0 F S PAGE=$O(PAGE(PAGE)) Q:'PAGE D
.;
.;list all the bubbles
.S ROW=((PAGE-1)*PERPAGE)-1
.S ARY="^IBD(357.95,""AC"","_IBFORMID_")"
.F S ROW=$O(@ARY@(ROW)) Q:ROW="" D
..Q:(ROW\PERPAGE)+1'=PAGE
..S COL="" F S COL=$O(@ARY@(ROW,COL)) Q:COL="" S IEN=0 F S IEN=$O(@ARY@(ROW,COL,IEN)) Q:'IEN D
...S NODE=$G(^IBD(357.95,IBFORMID,1,IEN,0))
...Q:($P(NODE,"^",6)="")!(($P(NODE,"^",4)="")&($P(NODE,"^",8)=""))!('$P(NODE,"^",3))
...S NAME=$E($P(NODE,"^",5),1,17),QLFR=$P(NODE,"^",10)
...S TYPE=$P(NODE,"^",7)
...I (TYPE=0)!(TYPE=3) S:QLFR QLFR=$P($G(^IBD(357.98,QLFR,0)),"^",3)
...I (TYPE=1)!(TYPE=2) S:QLFR QLFR=$E($P($G(^IBD(357.98,QLFR,0)),"^"),1,12)
...I QLFR'="" S NAME=NAME_"("_QLFR_")"
...I QLFR="" S NAME=NAME_"-"
...S @SCAN@(PAGE,$P(NODE,"^",6),+$P(NODE,"^",7),COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$P(NODE,"^",3,12)
...S @SCAN@(PAGE,$P(NODE,"^",6))=NAME
...;
.;
.;list all the handprint fields
.S ARY="^IBD(357.95,""AD"","_IBFORMID_")"
.S ROW=((PAGE-1)*PERPAGE)-1
.F S ROW=$O(@ARY@(ROW)) Q:ROW="" D
..Q:(ROW\PERPAGE)+1'=PAGE
..S COL="" F S COL=$O(@ARY@(ROW,COL)) Q:COL="" S IEN=0 F S IEN=$O(@ARY@(ROW,COL,IEN)) Q:'IEN D
...S NODE=$G(^IBD(357.95,IBFORMID,2,IEN,0))
...Q:($P(NODE,"^",8)="")!('$P(NODE,"^",4))!('$P(NODE,"^",15))
...S @SCAN@(PAGE,$P(NODE,"^",8),6,COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$P(NODE,"^",3,17),NAME=$E($P(NODE,"^",5),1,15)
...I $P(NODE,"^",17) S NAME=NAME_"("_$P($G(^IBE(359.1,$P(NODE,"^",17),0)),"^")_")"
...S @SCAN@(PAGE,$P(NODE,"^",8))=NAME
;
;make form description
F COUNT=1:1 S LINE=$T(FORM+COUNT^IBDFBKS1),TAG=$P(LINE,";;"),LINE=$P(LINE,";;",2) Q:TAG["QUIT" D
.N PG
.D BLDARY("")
.I TAG["NAME" S IBDFSA(IBLC)=IBDFSA(IBLC)_" NAME = ""ENCOUNTER FORM "_IBFORMID_""";" Q
.I TAG["SITE" S IBDFSA(IBLC)=IBDFSA(IBLC)_"'VA SITE = "_$P($$SITE^VASITE,"^",2),LINE=""
.I TAG["PGCK" S IBDFSA(IBLC)=IBDFSA(IBLC)_" else if (" D Q
..S PG=$O(PAGE(0))
..S IBDFSA(IBLC)=IBDFSA(IBLC)_"(page!="_PG_")"
..F S PG=$O(PAGE(PG)) Q:'PG S IBDFSA(IBLC)=IBDFSA(IBLC)_"&&(page!="_PG_")"
..S IBDFSA(IBLC)=IBDFSA(IBLC)_"){"
.S IBDFSA(IBLC)=IBDFSA(IBLC)_LINE
.;D BLDARY(LINE)
;
;make fields
S PAGE=0,FIELD=9,PRIORPG=$O(@SCAN@(0)),LN=0,BLN=0
F S PAGE=$O(@SCAN@(PAGE)) D:PRIORPG'=PAGE PRINTEND^IBDFBKS3 Q:'PAGE S FID="" F S FID=$O(@SCAN@(PAGE,FID)) Q:FID="" S TYPE=$O(@SCAN@(PAGE,FID,"")) Q:TYPE="" D
.S NAME=$G(@SCAN@(PAGE,FID))
.;
.; -- 1 = EXACTLY ONE, 2 = AT MOST ONE (0 or 1)
.I (TYPE=1)!(TYPE=2) S FIELD=FIELD+1,@FIELDS@(PAGE,FIELD)="" D
..I TYPE=1 S NAME=NAME_" (1 Required)"
..I TYPE=2 S NAME=NAME_" (1 Optional)"
..S NAME=$$NAME(NAME)
..D BUBBLE^IBDFBKS3 Q
.;
.I TYPE=6 D Q
..N OLDNAME S OLDNAME=NAME
..S COL="" F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" S IEN=0 F S IEN=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN)) Q:'IEN D
...S NAME=$$NAME(OLDNAME)
...;S IBDLAST=0 I $O(@SCAN@(PAGE,FID,TYPE,COL,ROW))="",$O(@SCAN@(PAGE,FID,TYPE,COL))="",$O(@SCAN@(PAGE,FID,TYPE))="" S IBDLAST=1
...S NODE=$G(@SCAN@(PAGE,FID,6,COL,ROW,IEN)) D HANDPRNT^IBDFBKS2(IEN,NAME,PAGE,ROW,COL,$P(NODE,"^",1),$P(NODE,"^",4),$P(NODE,"^",13),$P(NODE,"^",15),$P(NODE,"^",2))
.;
.;0 = ANY NUMBER
.;3 = AT LEAST ONE (1 or more)
.I (TYPE=0)!(TYPE=3) D
..N OLDNAME
..;I TYPE=3 N FIRST,LAST S LAST=FIELD+1,LAST=""
..I TYPE=3 N FIRST,LAST S FIRST=FIELD+1,LAST=""
..S COL="" F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" S IEN=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW,0)) D:IEN
...S FIELD=FIELD+1,@FIELDS@(PAGE,FIELD)="",NODE=$G(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
...S (NAME,OLDNAME)=$G(@SCAN@(PAGE,FID))
...S NAME=$$NAME(NAME)
...I TYPE=3,$O(@SCAN@(PAGE,FID,TYPE,COL,ROW))="",($O(@SCAN@(PAGE,FID,TYPE,COL))="") S LAST=FIELD
...D BUBBLE^IBDFBKS3
;
END ; -- end of routine
K @SCAN
K @FIELDS
K ^TMP("IBDF-NAME",$J)
S ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
S ^IBD(359.2,IBFORMID,10,0)="^^"_IBLC_"^"_IBLC_"^"_DT_"^"
Q
;
NAME(NAME) ;
; -- make sure name is unique
N X
I (TYPE=0)!(TYPE=3) S NAME=NAME_" "_$P(NODE,"^",6) I TYPE=3
I TYPE=1,NAME'["Required" S NAME=NAME_" Required"
S X=$G(^TMP("IBDF-NAME",$J,NAME))+1
S ^TMP("IBDF-NAME",$J,NAME)=+X
I X>1 S NAME=NAME_" #"_X
Q NAME
;
BLDARY(TEXT) ;
; -- builds the export array IBDFS(linecount) = text
N DIC,DA,DINUM,X,Y,I,J,DLAYGO
I IBLC=1 D
.S DIC="^IBD(359.2,",DIC(0)="L",DLAYGO=359.2,(DINUM,X)=IBFORMID D FILE^DICN
.Q
;
I IBLC>0 D
.S ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
.K IBDFSA(IBLC)
.Q
;
S IBLC=IBLC+1
S IBDFSA(IBLC)=$G(TEXT)
Q
;
WRITE(IBFORMID) ;
N LINE S LINE=0
S X=0 X ^%ZOSF("RM")
F S LINE=$O(^IBD(359.2,IBFORMID,10,LINE)) Q:'LINE W !,$G(^IBD(359.2,IBFORMID,10,LINE,0))
S X=80 X ^%ZOSF("RM")
Q
;
PARAM ; -- get values from parameter file
; ibdfill := % fill required
; ibdbkgnd := % background expected
S IBDFILL=$P($G(^IBD(357.09,1,0)),"^",8) I IBDFILL="" S IBDFILL=20
S IBDBKGND=$P($G(^IBD(357.09,1,0)),"^",9) I IBDBKGND="" S IBDBKGND=5
S XYSMALL=$P(^IBD(357.09,1,0),"^",12) I XYSMALL'=+XYSMALL S XYSMALL=4
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFBKS 7642 printed Dec 13, 2024@02:51:54 Page 2
IBDFBKS ;ALB/CJM/AAS - Create form spec file for scanning ; 6-JUN-95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
+2 ;
SCAN(IBFORMID) ;
+1 ;
+2 if '$GET(IBFORMID)
QUIT
+3 NEW IBLC,PERPAGE,PAGE,ROW,COL,PAGESIZE,SCAN,ARY,X,Y,ROWHT,ROWWIDTH,CONVERT,COUNT,LINE,TAG,NAME,XOFFSET,YOFFSET,NODE,FID,TYPE,XBUBOS,YBUBOS,COUNT,YHANDOS,FIELD,IEN,QLFR,PRIORPAG,END,LN,FIELDS,IBDFILL,IBDBKGND,XYSMALL
+4 ;XOFFSET,YOFFSET are the page margins (in decipoints)
+5 ;XBUBOS,YBUBOS are the offsets within the col,row of the bubbles
+6 ;YHANDOS is the offset for a handprint field within the row
+7 ;
+8 IF '$DATA(DT)
DO DT^DICRW
+9 IF $DATA(^IBD(359.2,IBFORMID,0))
IF $DATA(^IBD(357.95,IBFORMID,0))
SET DIK="^IBD(359.2,"
SET DA=IBFORMID
DO ^DIK
+10 IF '$DATA(DT)
DO DT^DICRW
+11 SET IBLC=0
+12 DO PARAM
+13 ;for converting PCL decipoints to .1mm
SET CONVERT=.352778
+14 ; This number is actually 254/720 ... 254 PK points (.1 mm) = 1 inch
+15 ; 720 PCL5 decipoints = 1 inch
+16 ; A PCL5 decipoint = .352778 PK points
+17 SET SCAN="^TMP(""IBDF"",$J,""SCAN"",IBFORMID)"
+18 KILL @SCAN
+19 ;
+20 SET FIELDS="^TMP(""IBDF"",$J,""FIELDS"")"
+21 KILL @FIELDS
+22 ;
+23 ;get form description
+24 SET NODE=$GET(^IBD(357.95,IBFORMID,0))
+25 if NODE=""
QUIT
+26 SET PERPAGE=$PIECE(NODE,"^",10)
+27 ;determine sizes and offsets - in terms of PCL decipoints
+28 ; This is 1/4 inch ... .25*720 PCL decipoints
SET XOFFSET=180
+29 ; This is 1/2 inch ... .5*720 PCL decipoints
SET YOFFSET=360
+30 ; rowht = # of PCL decipoints/line in height
+31 ; 80 lines (133 Col) = 720/8 lines per inch)
+32 ; 72 lines (96 Col) = 720/7.2 lines per inch)
+33 ; 60 lines (80 Col) = 720/6 lines per inch)
+34 SET ROWHT=$PIECE(NODE,"^",10)
SET ROWHT=$SELECT(ROWHT>72:90,ROWHT>60:100.0005,1:120)
+35 SET COLWIDTH=$PIECE(NODE,"^",9)
+36 ;leaves offset in terms of fraction of column width - must still convert to decipoints
SET XBUBOS=$SELECT(COLWIDTH>96:.5,COLWIDTH>80:.75,1:1)
+37 SET YBUBOS=$SELECT(COLWIDTH>96:65,COLWIDTH>80:75,1:85)
+38 ; colwidth = # of PCL decipoints/character in width
+39 ; 133 Col = 720/16.67 char per inch
+40 ; 96 Col = 720/12 char per inch
+41 ; 80 Col = 720/10 char per inch
+42 ;converted to decipoints
SET COLWIDTH=$SELECT(COLWIDTH>96:(720/16.67),COLWIDTH>80:60,1:72)
+43 ;converted to decipoints
SET XBUBOS=XBUBOS*COLWIDTH
+44 SET YHANDOS=$SELECT(ROWHT=90:0,ROWHT=100.0005:15,1:30)
+45 ;
+46 ;get the list of scannable pages
+47 SET IEN=0
FOR
SET IEN=$ORDER(^IBD(357.95,IBFORMID,3,IEN))
if 'IEN
QUIT
SET NODE=$GET(^IBD(357.95,IBFORMID,3,IEN,0))
if $PIECE(NODE,"^",2)
SET PAGE(+NODE)=""
+48 ;
+49 ;
+50 SET PAGE=0
FOR
SET PAGE=$ORDER(PAGE(PAGE))
if 'PAGE
QUIT
Begin DoDot:1
+51 ;
+52 ;list all the bubbles
+53 SET ROW=((PAGE-1)*PERPAGE)-1
+54 SET ARY="^IBD(357.95,""AC"","_IBFORMID_")"
+55 FOR
SET ROW=$ORDER(@ARY@(ROW))
if ROW=""
QUIT
Begin DoDot:2
+56 if (ROW\PERPAGE)+1'=PAGE
QUIT
+57 SET COL=""
FOR
SET COL=$ORDER(@ARY@(ROW,COL))
if COL=""
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(@ARY@(ROW,COL,IEN))
if 'IEN
QUIT
Begin DoDot:3
+58 SET NODE=$GET(^IBD(357.95,IBFORMID,1,IEN,0))
+59 if ($PIECE(NODE,"^",6)="")!(($PIECE(NODE,"^",4)="")&($PIECE(NODE,"^",8)=""))!('$PIECE(NODE,"^",3))
QUIT
+60 SET NAME=$EXTRACT($PIECE(NODE,"^",5),1,17)
SET QLFR=$PIECE(NODE,"^",10)
+61 SET TYPE=$PIECE(NODE,"^",7)
+62 IF (TYPE=0)!(TYPE=3)
if QLFR
SET QLFR=$PIECE($GET(^IBD(357.98,QLFR,0)),"^",3)
+63 IF (TYPE=1)!(TYPE=2)
if QLFR
SET QLFR=$EXTRACT($PIECE($GET(^IBD(357.98,QLFR,0)),"^"),1,12)
+64 IF QLFR'=""
SET NAME=NAME_"("_QLFR_")"
+65 IF QLFR=""
SET NAME=NAME_"-"
+66 SET @SCAN@(PAGE,$PIECE(NODE,"^",6),+$PIECE(NODE,"^",7),COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$PIECE(NODE,"^",3,12)
+67 SET @SCAN@(PAGE,$PIECE(NODE,"^",6))=NAME
+68 ;
End DoDot:3
End DoDot:2
+69 ;
+70 ;list all the handprint fields
+71 SET ARY="^IBD(357.95,""AD"","_IBFORMID_")"
+72 SET ROW=((PAGE-1)*PERPAGE)-1
+73 FOR
SET ROW=$ORDER(@ARY@(ROW))
if ROW=""
QUIT
Begin DoDot:2
+74 if (ROW\PERPAGE)+1'=PAGE
QUIT
+75 SET COL=""
FOR
SET COL=$ORDER(@ARY@(ROW,COL))
if COL=""
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(@ARY@(ROW,COL,IEN))
if 'IEN
QUIT
Begin DoDot:3
+76 SET NODE=$GET(^IBD(357.95,IBFORMID,2,IEN,0))
+77 if ($PIECE(NODE,"^",8)="")!('$PIECE(NODE,"^",4))!('$PIECE(NODE,"^",15))
QUIT
+78 SET @SCAN@(PAGE,$PIECE(NODE,"^",8),6,COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$PIECE(NODE,"^",3,17)
SET NAME=$EXTRACT($PIECE(NODE,"^",5),1,15)
+79 IF $PIECE(NODE,"^",17)
SET NAME=NAME_"("_$PIECE($GET(^IBE(359.1,$PIECE(NODE,"^",17),0)),"^")_")"
+80 SET @SCAN@(PAGE,$PIECE(NODE,"^",8))=NAME
End DoDot:3
End DoDot:2
End DoDot:1
+81 ;
+82 ;make form description
+83 FOR COUNT=1:1
SET LINE=$TEXT(FORM+COUNT^IBDFBKS1)
SET TAG=$PIECE(LINE,";;")
SET LINE=$PIECE(LINE,";;",2)
if TAG["QUIT"
QUIT
Begin DoDot:1
+84 NEW PG
+85 DO BLDARY("")
+86 IF TAG["NAME"
SET IBDFSA(IBLC)=IBDFSA(IBLC)_" NAME = ""ENCOUNTER FORM "_IBFORMID_""";"
QUIT
+87 IF TAG["SITE"
SET IBDFSA(IBLC)=IBDFSA(IBLC)_"'VA SITE = "_$PIECE($$SITE^VASITE,"^",2)
SET LINE=""
+88 IF TAG["PGCK"
SET IBDFSA(IBLC)=IBDFSA(IBLC)_" else if ("
Begin DoDot:2
+89 SET PG=$ORDER(PAGE(0))
+90 SET IBDFSA(IBLC)=IBDFSA(IBLC)_"(page!="_PG_")"
+91 FOR
SET PG=$ORDER(PAGE(PG))
if 'PG
QUIT
SET IBDFSA(IBLC)=IBDFSA(IBLC)_"&&(page!="_PG_")"
+92 SET IBDFSA(IBLC)=IBDFSA(IBLC)_"){"
End DoDot:2
QUIT
+93 SET IBDFSA(IBLC)=IBDFSA(IBLC)_LINE
+94 ;D BLDARY(LINE)
End DoDot:1
+95 ;
+96 ;make fields
+97 SET PAGE=0
SET FIELD=9
SET PRIORPG=$ORDER(@SCAN@(0))
SET LN=0
SET BLN=0
+98 FOR
SET PAGE=$ORDER(@SCAN@(PAGE))
if PRIORPG'=PAGE
DO PRINTEND^IBDFBKS3
if 'PAGE
QUIT
SET FID=""
FOR
SET FID=$ORDER(@SCAN@(PAGE,FID))
if FID=""
QUIT
SET TYPE=$ORDER(@SCAN@(PAGE,FID,""))
if TYPE=""
QUIT
Begin DoDot:1
+99 SET NAME=$GET(@SCAN@(PAGE,FID))
+100 ;
+101 ; -- 1 = EXACTLY ONE, 2 = AT MOST ONE (0 or 1)
+102 IF (TYPE=1)!(TYPE=2)
SET FIELD=FIELD+1
SET @FIELDS@(PAGE,FIELD)=""
Begin DoDot:2
+103 IF TYPE=1
SET NAME=NAME_" (1 Required)"
+104 IF TYPE=2
SET NAME=NAME_" (1 Optional)"
+105 SET NAME=$$NAME(NAME)
+106 DO BUBBLE^IBDFBKS3
QUIT
End DoDot:2
+107 ;
+108 IF TYPE=6
Begin DoDot:2
+109 NEW OLDNAME
SET OLDNAME=NAME
+110 SET COL=""
FOR
SET COL=$ORDER(@SCAN@(PAGE,FID,TYPE,COL))
if COL=""
QUIT
SET ROW=""
FOR
SET ROW=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW))
if ROW=""
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
if 'IEN
QUIT
Begin DoDot:3
+111 SET NAME=$$NAME(OLDNAME)
+112 ;S IBDLAST=0 I $O(@SCAN@(PAGE,FID,TYPE,COL,ROW))="",$O(@SCAN@(PAGE,FID,TYPE,COL))="",$O(@SCAN@(PAGE,FID,TYPE))="" S IBDLAST=1
+113 SET NODE=$GET(@SCAN@(PAGE,FID,6,COL,ROW,IEN))
DO HANDPRNT^IBDFBKS2(IEN,NAME,PAGE,ROW,COL,$PIECE(NODE,"^",1),$PIECE(NODE,"^",4),$PIECE(NODE,"^",13),$PIECE(NODE,"^",15),$PIECE(NODE,"^",2))
End DoDot:3
End DoDot:2
QUIT
+114 ;
+115 ;0 = ANY NUMBER
+116 ;3 = AT LEAST ONE (1 or more)
+117 IF (TYPE=0)!(TYPE=3)
Begin DoDot:2
+118 NEW OLDNAME
+119 ;I TYPE=3 N FIRST,LAST S LAST=FIELD+1,LAST=""
+120 IF TYPE=3
NEW FIRST,LAST
SET FIRST=FIELD+1
SET LAST=""
+121 SET COL=""
FOR
SET COL=$ORDER(@SCAN@(PAGE,FID,TYPE,COL))
if COL=""
QUIT
SET ROW=""
FOR
SET ROW=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW))
if ROW=""
QUIT
SET IEN=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW,0))
if IEN
Begin DoDot:3
+122 SET FIELD=FIELD+1
SET @FIELDS@(PAGE,FIELD)=""
SET NODE=$GET(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
+123 SET (NAME,OLDNAME)=$GET(@SCAN@(PAGE,FID))
+124 SET NAME=$$NAME(NAME)
+125 IF TYPE=3
IF $ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW))=""
IF ($ORDER(@SCAN@(PAGE,FID,TYPE,COL))="")
SET LAST=FIELD
+126 DO BUBBLE^IBDFBKS3
End DoDot:3
End DoDot:2
End DoDot:1
+127 ;
END ; -- end of routine
+1 KILL @SCAN
+2 KILL @FIELDS
+3 KILL ^TMP("IBDF-NAME",$JOB)
+4 SET ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
+5 SET ^IBD(359.2,IBFORMID,10,0)="^^"_IBLC_"^"_IBLC_"^"_DT_"^"
+6 QUIT
+7 ;
NAME(NAME) ;
+1 ; -- make sure name is unique
+2 NEW X
+3 IF (TYPE=0)!(TYPE=3)
SET NAME=NAME_" "_$PIECE(NODE,"^",6)
IF TYPE=3
+4 IF TYPE=1
IF NAME'["Required"
SET NAME=NAME_" Required"
+5 SET X=$GET(^TMP("IBDF-NAME",$JOB,NAME))+1
+6 SET ^TMP("IBDF-NAME",$JOB,NAME)=+X
+7 IF X>1
SET NAME=NAME_" #"_X
+8 QUIT NAME
+9 ;
BLDARY(TEXT) ;
+1 ; -- builds the export array IBDFS(linecount) = text
+2 NEW DIC,DA,DINUM,X,Y,I,J,DLAYGO
+3 IF IBLC=1
Begin DoDot:1
+4 SET DIC="^IBD(359.2,"
SET DIC(0)="L"
SET DLAYGO=359.2
SET (DINUM,X)=IBFORMID
DO FILE^DICN
+5 QUIT
End DoDot:1
+6 ;
+7 IF IBLC>0
Begin DoDot:1
+8 SET ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
+9 KILL IBDFSA(IBLC)
+10 QUIT
End DoDot:1
+11 ;
+12 SET IBLC=IBLC+1
+13 SET IBDFSA(IBLC)=$GET(TEXT)
+14 QUIT
+15 ;
WRITE(IBFORMID) ;
+1 NEW LINE
SET LINE=0
+2 SET X=0
XECUTE ^%ZOSF("RM")
+3 FOR
SET LINE=$ORDER(^IBD(359.2,IBFORMID,10,LINE))
if 'LINE
QUIT
WRITE !,$GET(^IBD(359.2,IBFORMID,10,LINE,0))
+4 SET X=80
XECUTE ^%ZOSF("RM")
+5 QUIT
+6 ;
PARAM ; -- get values from parameter file
+1 ; ibdfill := % fill required
+2 ; ibdbkgnd := % background expected
+3 SET IBDFILL=$PIECE($GET(^IBD(357.09,1,0)),"^",8)
IF IBDFILL=""
SET IBDFILL=20
+4 SET IBDBKGND=$PIECE($GET(^IBD(357.09,1,0)),"^",9)
IF IBDBKGND=""
SET IBDBKGND=5
+5 SET XYSMALL=$PIECE(^IBD(357.09,1,0),"^",12)
IF XYSMALL'=+XYSMALL
SET XYSMALL=4
+6 QUIT
