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

IBDFBKS2.m

Go to the documentation of this file. 
  1. IBDFBKS2 ;ALB/CJM/AAS - ENCOUNTER FORM - create form spec for scanning (Broker Version) ; 6-JUN-95 [ 11/13/96  5:25 PM ]
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1.  ;
  1. HANDPRNT(IEN,NAME,PAGE,ROW,COL,WIDTH,LINES,READTYPE,PAPKEY,PI) ;
  1.  ;there must be a package interface to handle the data
  1.  Q:('PI)
  1.  Q:($P($G(^IBE(357.6,PI,0)),"^",6)'=1)
  1.  ;
  1.  N X1,X2,Y1,Y2,W,PICTURE,TYPEDATA,NODE0,LENGTH,LINENUM,PKDICT,CONF,L,SUBPICS,FORMAT
  1.  S TYPEDATA="ALPHA",PICTURE=""
  1.  ; -- get info associated with DHCP Data Element
  1.  ;    (and not stored with form definition)
  1.  ; -- 9/28/95 moved file 359.1, pieces 0;3, 0;4, 0;8, 0;9 to
  1.  ;    to 10;1, 10;2, 10;3, 10;4 respectively
  1.  ;
  1.  I PAPKEY D
  1.  .S NODE0=$G(^IBE(359.1,PAPKEY,0)),NODE10=$G(^(10))
  1.  .S TYPEDATA=$P(NODE10,"^",1)
  1.  .S TYPEDATA=$S(TYPEDATA="a":"ALPHA",TYPEDATA="i":"INT",TYPEDATA="f":"FLOAT",TYPEDATA="t":"TIME",TYPEDATA="d":"DATE",1:"ALPHA")
  1.  .S PICTURE=$P(NODE10,"^",2)
  1.  .S FORMAT=$P(NODE0,"^",5)
  1.  .S LENGTH=$P(NODE0,"^",2)
  1.  .S CONF=$P(NODE0,"^",7)
  1.  .S PKDICT=$P(NODE10,"^",3)
  1.  .S SUBPICS=$P(NODE10,"^",4)
  1.  ;
  1.  ;find top left-hand corner
  1.  S X1=((COL*COLWIDTH)+XOFFSET)*CONVERT,X1=$FN(X1,"",0)
  1.  S Y1=((ROW*ROWHT)+YOFFSET+YHANDOS)*CONVERT,Y1=$FN(Y1,"",0)
  1.  ;
  1.  ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
  1.  ;ALSO MUST DO THIS IF TYPE = 1!!!!!!!!!!!!!!!!! BUT SCALE IT
  1.  I READTYPE=3 D
  1.  .;define some marksense fields - if any marked it means there is print!
  1.  .S FIELD=FIELD+1
  1.  .D BLDARY^IBDFBKS("FIELD ' "_FIELD)
  1.  .D BLDARY^IBDFBKS("  NAME = """_NAME_"?"";")
  1.  .D BLDARY^IBDFBKS("  ELEMTYPE = RECT;")
  1.  .D BLDARY^IBDFBKS("  METRIC = 40 40 0 0 0 0 1 0 1;")
  1.  .D BLDARY^IBDFBKS("  TYPEDATA = INT;")
  1.  .D BLDARY^IBDFBKS("  LENGTH = ",LENGTH,";")
  1.  .D BLDARY^IBDFBKS("  POINTS =")
  1.  .F L=1:1:LINES F W=1:1:WIDTH D
  1.  ..S X2=X1+((((W-1)*172.7645)+30)*CONVERT),X2=$FN(X2,"",0)
  1.  ..S Y2=Y1+(((L*180)-39)*CONVERT),Y2=$FN(Y2,"",0)
  1.  ..S IBDFSA(IBLC)=IBDFSA(IBLC)_" "_Y2+1_" "_X2+1
  1.  .S IBDFSA(IBLC)=IBDFSA(IBLC)_";"
  1.  .D BLDARY^IBDFBKS("  PAGE = ",PAGE,";")
  1.  .D BLDARY^IBDFBKS("  CONFIDENCE = "" 0"";")
  1.  .D BLDARY^IBDFBKS("  END = {if (FIELDSTATUS != FIELD_BLANK){")
  1.  .D BLDARY^IBDFBKS("    hasprint=1;")
  1.  .D BLDARY^IBDFBKS("    FIELDSTATUS=FIELD_BAD;")
  1.  .D BLDARY^IBDFBKS("  }")
  1.  .D BLDARY^IBDFBKS("  else {")
  1.  .D BLDARY^IBDFBKS("    hasprint=0;")
  1.  .D BLDARY^IBDFBKS("    NEXTFIELD=NEXTFIELD+1;")
  1.  .D BLDARY^IBDFBKS("  }};")
  1.  .D BLDARY^IBDFBKS("  EXFORMAT = ""NOEXPORT"";")
  1.  .D BLDARY^IBDFBKS("  HIDDEN = ""1"";")
  1.  ;
  1.  ;field is narrative that needs to be broken into single lines
  1.  I (LINES>1)&(READTYPE=2) D  Q
  1.  .F LINENUM=1:1:LINES S:LINENUM>1 Y1=$FN(Y1+(2*ROWHT*CONVERT),"",0) D
  1.  ..S X2=X1+(172.7654*WIDTH*CONVERT),X2=$FN(X2,"",0)
  1.  ..S Y2=Y1+(180*CONVERT),Y2=$FN(Y2,"",0)
  1.  ..D PRINTEND^IBDFBKS3
  1.  ..D PKFIELD(X1+2,Y1+2,X2-2,Y2-2,2,PICTURE,0,CONF,PKDICT,WIDTH,TYPEDATA,NAME,2)
  1.  ..;for handprint fields,must prefix data exported with field info - for bubbles the XMAP has the field info
  1.  ..S @FIELDS@(PAGE,FIELD)="H:"_IEN_":",@FIELDS@(PAGE,FIELD,"DATATYPE")=TYPEDATA S:LINENUM=1 @FIELDS@(PAGE,FIELD,"START")=1 S:LINENUM=LINES @FIELDS@(PAGE,FIELD,"END")=1 S @FIELDS@(PAGE,FIELD,"MULT")=1
  1.  ;
  1.  ;field needs to be broken into subfields due to the print format
  1.  I (READTYPE=2)&(FORMAT'="") D  Q
  1.  .N SUBFIELD,I1,I2,PREFIX,SX1,SX2,SPICTURE,LEN,FOUNDEND
  1.  .S PREFIX=$P(FORMAT,"_"),I1=$L(PREFIX)+1
  1.  .S Y2=Y1+(180*CONVERT),Y2=$FN(Y2,"",0)
  1.  .F  Q:(I1>WIDTH)  D
  1.  ..S I2=I1
  1.  ..S FOUNDEND=0 F  D  Q:FOUNDEND
  1.  ...I $E(FORMAT,I2+1)="_" S I2=I2+1
  1.  ...E  S FOUNDEND=1 Q
  1.  ..;so at this point I1=beginning of the subfield, I2=the end
  1.  ..S SX1=$FN(X1+(172.7654*(I1-1)*CONVERT),"",0)
  1.  ..S SX2=$FN(X1+(172.7654*(I2)*CONVERT),"",0)
  1.  ..S SPICTURE=$E(SUBPICS,I1,I2)
  1.  ..S LEN=(I2-I1)+1
  1.  ..D PRINTEND^IBDFBKS3
  1.  ..D PKFIELD(SX1+2,Y1+2,SX2-2,Y2-2,2,SPICTURE,1,0,"",LEN,"ALPHA",NAME_" Char:"_I1_" to "_I2)
  1.  ..S SUBFIELD(FIELD)=""
  1.  ..S (I1,I2)=I2+1
  1.  ..S FOUNDEND=0 F  D  Q:FOUNDEND
  1.  ...I $E(FORMAT,I2+1)="_" S FOUNDEND=1 Q
  1.  ...I I2>WIDTH S FOUNDEND=1 Q
  1.  ...S I2=I2+1 Q
  1.  ..I $E(FORMAT,I1,I2)'="" S SUBFIELD(FIELD)=$E(FORMAT,I1,I2)
  1.  ..S I1=I2+1
  1.  .
  1.  .;now create a field to concatenate the subfields together
  1.  .S X2=X1+(172.7654*WIDTH*CONVERT),X2=$FN(X2,"",0)
  1.  .S Y2=Y1+(180*CONVERT),Y2=$FN(Y2,"",0)
  1.  .D PKFIELD(X1,Y1,X2,Y2,1,PICTURE,0,CONF,PKDICT,WIDTH,TYPEDATA,NAME,1)
  1.  .D
  1.  ..D BLDARY^IBDFBKS("BEGIN = {ALPHA sfstr;")
  1.  ..D BLDARY^IBDFBKS("ALPHA str;")
  1.  ..D BLDARY^IBDFBKS("INT sfconf;")
  1.  ..D BLDARY^IBDFBKS("INT conf;")
  1.  ..D BLDARY^IBDFBKS("INT found;")
  1.  ..D BLDARY^IBDFBKS("INT ret;")
  1.  ..D BLDARY^IBDFBKS("found=0;")
  1.  ..D BLDARY^IBDFBKS("conf=10;")
  1.  ..I PREFIX'="" D BLDARY^IBDFBKS("    str=\"""_PREFIX_"\"";")
  1.  ..N SUB S SUB=0 F  S SUB=$O(SUBFIELD(SUB)) Q:'SUB  D
  1.  ...D BLDARY^IBDFBKS("  sfstr=STRIP(GETAVALUE("_SUB_"));")
  1.  ...D BLDARY^IBDFBKS("str=STRCAT(str,sfstr);")
  1.  ...D BLDARY^IBDFBKS("if (sfstr!=\""\"") found=1;")
  1.  ...I SUBFIELD(SUB)'="" D BLDARY^IBDFBKS("str=STRCAT(sfstr,\"""_SUBFIELD(SUB)_"\"");")
  1.  ...D BLDARY^IBDFBKS("sfconf=GETCONF("_SUB_");")
  1.  ...D BLDARY^IBDFBKS("if (sfconf<conf) conf=sfconf;")
  1.  ..D BLDARY^IBDFBKS("if (found) ret=SETTEXT("_FIELD_",str,ITOA(conf-1),FIELD_OK);")
  1.  ..D BLDARY^IBDFBKS("if (found == 0) ret=SETTEXT("_FIELD_",\""\"",ITOA(conf-1),FIELD_BLANK);")
  1.  ..D BLDARY^IBDFBKS("if (ret) SETTEXT("_FIELD_",str,\""1\"",FIELD_BAD);")
  1.  ..D BLDARY^IBDFBKS("};")
  1.  .;
  1.  .;for handprint fields,must prefix data exported with field info - for bubbles the XMAP has the field info
  1.  .S @FIELDS@(PAGE,FIELD)="H:"_IEN_":",@FIELDS@(PAGE,FIELD,"DATATYPE")=TYPEDATA
  1.  ;
  1.  ;following are handprint fields that don't need to be broken into subfields
  1.  ;
  1.  I READTYPE=1 D  ;not printed in ICR format
  1.  .D CNVRTHT^IBDF2D1(LINES,.LINES)
  1.  .S X2=X1+(103.65924*WIDTH*CONVERT),X2=$FN(X2,"",0)
  1.  .S Y2=Y1+(ROWHT*LINES*CONVERT),Y2=$FN(Y2,"",0)
  1.  ;
  1.  I READTYPE'=1 D  ;printed in ICR format
  1.  .S X2=X1+(172.7654*WIDTH*CONVERT),X2=$FN(X2,"",0)
  1.  .S Y2=Y1+(180*LINES*CONVERT),Y2=$FN(Y2,"",0)
  1.  ;
  1.  D PRINTEND^IBDFBKS3
  1.  D:READTYPE=2 PKFIELD(X1+2,Y1+2,X2-2,Y2-2,READTYPE,PICTURE,0,CONF,PKDICT,WIDTH,TYPEDATA,NAME,2)
  1.  ;
  1.  D:READTYPE'=2 PKFIELD(X1,Y1,X2,Y2,READTYPE,PICTURE,0,"","",LENGTH,TYPEDATA,NAME)
  1.  S @FIELDS@(PAGE,FIELD)="H:"_IEN_":",@FIELDS@(PAGE,FIELD,"DATATYPE")=TYPEDATA
  1.  D ENDSTUFF
  1.  Q
  1.  ;
  1. ENDSTUFF ;** END STUFF **
  1.  ;S L=$S(TYPEDATA="ALPHA":$L(PICTURE),1:0)
  1.  ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PUT BACK?
  1.  ;I L D
  1.  ;.D ADDTOEND^IBDFBKS3("  "_TYPEDATA_" val;")
  1.  ;.D ADDTOEND^IBDFBKS3("  INT len;")
  1.  I READTYPE'=2 D  ;test the results of the marksense fields that were laid on top of the operator fill field
  1.  .D ADDTOEND^IBDFBKS3("  if ((hasprint)&&(FIELDACCEPTED==0)){")
  1.  .D ADDTOEND^IBDFBKS3("    FIELDSTATUS=FIELD_BAD;")
  1.  .D ADDTOEND^IBDFBKS3("  }")
  1.  ;
  1.  ;!!!!!!!!!! PUT BACK?
  1.  ;I L D
  1.  ;.D ADDTOEND^IBDFBKS3("  val=GETVALUE(FIELDNAME);")
  1.  ;.D ADDTOEND^IBDFBKS3("  val=STRIP(val);")
  1.  ;.D ADDTOEND^IBDFBKS3("  len=STRLEN(val);")
  1.  ;.D ADDTOEND^IBDFBKS3("  if ((FIELDSTATUS==FIELD_OK)&&(len<"_L_")){")
  1.  ;.D ADDTOEND^IBDFBKS3("    FIELDSTATUS=FIELD_BAD;")
  1.  ;.D ADDTOEND^IBDFBKS3("    SHOW(""Value too short!"");")
  1.  ;.D ADDTOEND^IBDFBKS3("}")
  1.  Q
  1.  ;
  1. PKFIELD(X1,Y1,X2,Y2,READTYPE,PICTURE,HIDDEN,CONF,PKDICT,LENGTH,TYPEDATA,NAME,ENDPGM) ;
  1.  ; -- now for the handprint field
  1.  S FIELD=FIELD+1
  1.  D BLDARY^IBDFBKS("FIELD ' "_FIELD)
  1.  D BLDARY^IBDFBKS("  NAME = """_NAME_""";")
  1.  ;
  1.  I READTYPE=2 D
  1.  .D BLDARY^IBDFBKS("  ELEMTYPE = ELEM_OT;")
  1.  .D BLDARY^IBDFBKS("  METRIC = 2;")
  1.  ;
  1.  E  D
  1.  .D BLDARY^IBDFBKS("  ELEMTYPE = ELEM_OT;")
  1.  .D BLDARY^IBDFBKS("  METRIC = 1;")
  1.  ;
  1.  D BLDARY^IBDFBKS("  DATATYPE ="_TYPEDATA_";")
  1.  D BLDARY^IBDFBKS("  LENGTH = "_LENGTH_";")
  1.  D BLDARY^IBDFBKS("  POINTS = "_Y1_" "_X1_" "_Y2_" "_X2_";")
  1.  D BLDARY^IBDFBKS("  PAGE = "_PAGE_";")
  1.  I CONF'="" D BLDARY^IBDFBKS("  CONFIDENCE = """_CONF_""";")
  1.  I HIDDEN D BLDARY^IBDFBKS(" HIDDEN = ""1"";")
  1.  I $G(ENDPGM) D HPSKIP
  1.  ;
  1.  ;** IMAGE PROCESSING **
  1.  I READTYPE=2 D
  1.  .D BLDARY^IBDFBKS(" ImageProcessing = {")
  1.  .D BLDARY^IBDFBKS("   IMAGEPROCE = 1")
  1.  .D BLDARY^IBDFBKS("   DESKEW = 0")
  1.  .D BLDARY^IBDFBKS("   DESHADE = 0")
  1.  .D BLDARY^IBDFBKS("   REMOVE _NOISE = 0")
  1.  .D BLDARY^IBDFBKS("   SMOOTH = 1")
  1.  .D BLDARY^IBDFBKS("   PROC_MIN_VERT_LINE_LEN=70")
  1.  .D BLDARY^IBDFBKS("   PROC_MIN_HORZ_LINE_LEN=70")
  1.  .D BLDARY^IBDFBKS("   FATTYPE = 0")
  1.  .D BLDARY^IBDFBKS("   FATTEN = 0};")
  1.  .D BLDARY^IBDFBKS("   Recognition = {FIXED_WIDTH=1")
  1.  .D BLDARY^IBDFBKS("   OT_RECOGTYPE=HP")
  1.  .D BLDARY^IBDFBKS("   };")
  1.  ;
  1.  ;** begin program **
  1.  I $G(ENDPGM)=2 D
  1.  .D BLDARY^IBDFBKS("BEGIN = {ALPHA str;")
  1.  .D BLDARY^IBDFBKS("INT conf;")
  1.  .D BLDARY^IBDFBKS("INT ret;")
  1.  .D BLDARY^IBDFBKS("  conf = GETCONF("_FIELD_");")
  1.  .D BLDARY^IBDFBKS("  if (GETSTATUS("_FIELD_") == FIELD_BLANK) {")
  1.  .D BLDARY^IBDFBKS("     ret=SETTEXT("_FIELD_",\""\"",ITOA(conf-1),FIELD_BLANK); }")
  1.  .D BLDARY^IBDFBKS("if (ret) FIELDSTATUS = FIELD_ERROR;")
  1.  .D BLDARY^IBDFBKS("};")
  1.  .;
  1.  I PKDICT'="" D BLDARY^IBDFBKS("  DICTIONARY = """_PKDICT_""";")
  1.  I PICTURE'="",TYPEDATA="ALPHA" D BLDARY^IBDFBKS("  PICTURE = """_PICTURE_""";")
  1.  Q
  1. HPSKIP ; If hand print field blank, skip it
  1.  D ADDTOEND^IBDFBKS3("   if ((GETSTATUS(FIELDNAME) != FIELD_BLANK) && (FIELDACCEPTED == 0)) {")
  1.  D ADDTOEND^IBDFBKS3("     FIELDSTATUS = FIELD_BAD;}")
  1.  Q
  1.  ;