- 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 Feb 19, 2025@00:18:19 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