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

IBDFBKS.m

Go to the documentation of this file.
  1. IBDFBKS ;ALB/CJM/AAS - Create form spec file for scanning ; 6-JUN-95
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
  1. ;
  1. SCAN(IBFORMID) ;
  1. ;
  1. Q:'$G(IBFORMID)
  1. 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
  1. ;XOFFSET,YOFFSET are the page margins (in decipoints)
  1. ;XBUBOS,YBUBOS are the offsets within the col,row of the bubbles
  1. ;YHANDOS is the offset for a handprint field within the row
  1. ;
  1. I '$D(DT) D DT^DICRW
  1. I $D(^IBD(359.2,IBFORMID,0)),$D(^IBD(357.95,IBFORMID,0)) S DIK="^IBD(359.2,",DA=IBFORMID D ^DIK
  1. I '$D(DT) D DT^DICRW
  1. S IBLC=0
  1. D PARAM
  1. S CONVERT=.352778 ;for converting PCL decipoints to .1mm
  1. ; This number is actually 254/720 ... 254 PK points (.1 mm) = 1 inch
  1. ; 720 PCL5 decipoints = 1 inch
  1. ; A PCL5 decipoint = .352778 PK points
  1. S SCAN="^TMP(""IBDF"",$J,""SCAN"",IBFORMID)"
  1. K @SCAN
  1. ;
  1. S FIELDS="^TMP(""IBDF"",$J,""FIELDS"")"
  1. K @FIELDS
  1. ;
  1. ;get form description
  1. S NODE=$G(^IBD(357.95,IBFORMID,0))
  1. Q:NODE=""
  1. S PERPAGE=$P(NODE,"^",10)
  1. ;determine sizes and offsets - in terms of PCL decipoints
  1. S XOFFSET=180 ; This is 1/4 inch ... .25*720 PCL decipoints
  1. S YOFFSET=360 ; This is 1/2 inch ... .5*720 PCL decipoints
  1. ; rowht = # of PCL decipoints/line in height
  1. ; 80 lines (133 Col) = 720/8 lines per inch)
  1. ; 72 lines (96 Col) = 720/7.2 lines per inch)
  1. ; 60 lines (80 Col) = 720/6 lines per inch)
  1. S ROWHT=$P(NODE,"^",10),ROWHT=$S(ROWHT>72:90,ROWHT>60:100.0005,1:120)
  1. S COLWIDTH=$P(NODE,"^",9)
  1. 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
  1. S YBUBOS=$S(COLWIDTH>96:65,COLWIDTH>80:75,1:85)
  1. ; colwidth = # of PCL decipoints/character in width
  1. ; 133 Col = 720/16.67 char per inch
  1. ; 96 Col = 720/12 char per inch
  1. ; 80 Col = 720/10 char per inch
  1. S COLWIDTH=$S(COLWIDTH>96:(720/16.67),COLWIDTH>80:60,1:72) ;converted to decipoints
  1. S XBUBOS=XBUBOS*COLWIDTH ;converted to decipoints
  1. S YHANDOS=$S(ROWHT=90:0,ROWHT=100.0005:15,1:30)
  1. ;
  1. ;get the list of scannable pages
  1. 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)=""
  1. ;
  1. ;
  1. S PAGE=0 F S PAGE=$O(PAGE(PAGE)) Q:'PAGE D
  1. .;
  1. .;list all the bubbles
  1. .S ROW=((PAGE-1)*PERPAGE)-1
  1. .S ARY="^IBD(357.95,""AC"","_IBFORMID_")"
  1. .F S ROW=$O(@ARY@(ROW)) Q:ROW="" D
  1. ..Q:(ROW\PERPAGE)+1'=PAGE
  1. ..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
  1. ...S NODE=$G(^IBD(357.95,IBFORMID,1,IEN,0))
  1. ...Q:($P(NODE,"^",6)="")!(($P(NODE,"^",4)="")&($P(NODE,"^",8)=""))!('$P(NODE,"^",3))
  1. ...S NAME=$E($P(NODE,"^",5),1,17),QLFR=$P(NODE,"^",10)
  1. ...S TYPE=$P(NODE,"^",7)
  1. ...I (TYPE=0)!(TYPE=3) S:QLFR QLFR=$P($G(^IBD(357.98,QLFR,0)),"^",3)
  1. ...I (TYPE=1)!(TYPE=2) S:QLFR QLFR=$E($P($G(^IBD(357.98,QLFR,0)),"^"),1,12)
  1. ...I QLFR'="" S NAME=NAME_"("_QLFR_")"
  1. ...I QLFR="" S NAME=NAME_"-"
  1. ...S @SCAN@(PAGE,$P(NODE,"^",6),+$P(NODE,"^",7),COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$P(NODE,"^",3,12)
  1. ...S @SCAN@(PAGE,$P(NODE,"^",6))=NAME
  1. ...;
  1. .;
  1. .;list all the handprint fields
  1. .S ARY="^IBD(357.95,""AD"","_IBFORMID_")"
  1. .S ROW=((PAGE-1)*PERPAGE)-1
  1. .F S ROW=$O(@ARY@(ROW)) Q:ROW="" D
  1. ..Q:(ROW\PERPAGE)+1'=PAGE
  1. ..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
  1. ...S NODE=$G(^IBD(357.95,IBFORMID,2,IEN,0))
  1. ...Q:($P(NODE,"^",8)="")!('$P(NODE,"^",4))!('$P(NODE,"^",15))
  1. ...S @SCAN@(PAGE,$P(NODE,"^",8),6,COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$P(NODE,"^",3,17),NAME=$E($P(NODE,"^",5),1,15)
  1. ...I $P(NODE,"^",17) S NAME=NAME_"("_$P($G(^IBE(359.1,$P(NODE,"^",17),0)),"^")_")"
  1. ...S @SCAN@(PAGE,$P(NODE,"^",8))=NAME
  1. ;
  1. ;make form description
  1. F COUNT=1:1 S LINE=$T(FORM+COUNT^IBDFBKS1),TAG=$P(LINE,";;"),LINE=$P(LINE,";;",2) Q:TAG["QUIT" D
  1. .N PG
  1. .D BLDARY("")
  1. .I TAG["NAME" S IBDFSA(IBLC)=IBDFSA(IBLC)_" NAME = ""ENCOUNTER FORM "_IBFORMID_""";" Q
  1. .I TAG["SITE" S IBDFSA(IBLC)=IBDFSA(IBLC)_"'VA SITE = "_$P($$SITE^VASITE,"^",2),LINE=""
  1. .I TAG["PGCK" S IBDFSA(IBLC)=IBDFSA(IBLC)_" else if (" D Q
  1. ..S PG=$O(PAGE(0))
  1. ..S IBDFSA(IBLC)=IBDFSA(IBLC)_"(page!="_PG_")"
  1. ..F S PG=$O(PAGE(PG)) Q:'PG S IBDFSA(IBLC)=IBDFSA(IBLC)_"&&(page!="_PG_")"
  1. ..S IBDFSA(IBLC)=IBDFSA(IBLC)_"){"
  1. .S IBDFSA(IBLC)=IBDFSA(IBLC)_LINE
  1. .;D BLDARY(LINE)
  1. ;
  1. ;make fields
  1. S PAGE=0,FIELD=9,PRIORPG=$O(@SCAN@(0)),LN=0,BLN=0
  1. 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
  1. .S NAME=$G(@SCAN@(PAGE,FID))
  1. .;
  1. .; -- 1 = EXACTLY ONE, 2 = AT MOST ONE (0 or 1)
  1. .I (TYPE=1)!(TYPE=2) S FIELD=FIELD+1,@FIELDS@(PAGE,FIELD)="" D
  1. ..I TYPE=1 S NAME=NAME_" (1 Required)"
  1. ..I TYPE=2 S NAME=NAME_" (1 Optional)"
  1. ..S NAME=$$NAME(NAME)
  1. ..D BUBBLE^IBDFBKS3 Q
  1. .;
  1. .I TYPE=6 D Q
  1. ..N OLDNAME S OLDNAME=NAME
  1. ..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
  1. ...S NAME=$$NAME(OLDNAME)
  1. ...;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
  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))
  1. .;
  1. .;0 = ANY NUMBER
  1. .;3 = AT LEAST ONE (1 or more)
  1. .I (TYPE=0)!(TYPE=3) D
  1. ..N OLDNAME
  1. ..;I TYPE=3 N FIRST,LAST S LAST=FIELD+1,LAST=""
  1. ..I TYPE=3 N FIRST,LAST S FIRST=FIELD+1,LAST=""
  1. ..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
  1. ...S FIELD=FIELD+1,@FIELDS@(PAGE,FIELD)="",NODE=$G(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
  1. ...S (NAME,OLDNAME)=$G(@SCAN@(PAGE,FID))
  1. ...S NAME=$$NAME(NAME)
  1. ...I TYPE=3,$O(@SCAN@(PAGE,FID,TYPE,COL,ROW))="",($O(@SCAN@(PAGE,FID,TYPE,COL))="") S LAST=FIELD
  1. ...D BUBBLE^IBDFBKS3
  1. ;
  1. END ; -- end of routine
  1. K @SCAN
  1. K @FIELDS
  1. K ^TMP("IBDF-NAME",$J)
  1. S ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
  1. S ^IBD(359.2,IBFORMID,10,0)="^^"_IBLC_"^"_IBLC_"^"_DT_"^"
  1. Q
  1. ;
  1. NAME(NAME) ;
  1. ; -- make sure name is unique
  1. N X
  1. I (TYPE=0)!(TYPE=3) S NAME=NAME_" "_$P(NODE,"^",6) I TYPE=3
  1. I TYPE=1,NAME'["Required" S NAME=NAME_" Required"
  1. S X=$G(^TMP("IBDF-NAME",$J,NAME))+1
  1. S ^TMP("IBDF-NAME",$J,NAME)=+X
  1. I X>1 S NAME=NAME_" #"_X
  1. Q NAME
  1. ;
  1. BLDARY(TEXT) ;
  1. ; -- builds the export array IBDFS(linecount) = text
  1. N DIC,DA,DINUM,X,Y,I,J,DLAYGO
  1. I IBLC=1 D
  1. .S DIC="^IBD(359.2,",DIC(0)="L",DLAYGO=359.2,(DINUM,X)=IBFORMID D FILE^DICN
  1. .Q
  1. ;
  1. I IBLC>0 D
  1. .S ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
  1. .K IBDFSA(IBLC)
  1. .Q
  1. ;
  1. S IBLC=IBLC+1
  1. S IBDFSA(IBLC)=$G(TEXT)
  1. Q
  1. ;
  1. WRITE(IBFORMID) ;
  1. N LINE S LINE=0
  1. S X=0 X ^%ZOSF("RM")
  1. F S LINE=$O(^IBD(359.2,IBFORMID,10,LINE)) Q:'LINE W !,$G(^IBD(359.2,IBFORMID,10,LINE,0))
  1. S X=80 X ^%ZOSF("RM")
  1. Q
  1. ;
  1. PARAM ; -- get values from parameter file
  1. ; ibdfill := % fill required
  1. ; ibdbkgnd := % background expected
  1. S IBDFILL=$P($G(^IBD(357.09,1,0)),"^",8) I IBDFILL="" S IBDFILL=20
  1. S IBDBKGND=$P($G(^IBD(357.09,1,0)),"^",9) I IBDBKGND="" S IBDBKGND=5
  1. S XYSMALL=$P(^IBD(357.09,1,0),"^",12) I XYSMALL'=+XYSMALL S XYSMALL=4
  1. Q