source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFBKS2.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1IBDFBKS2 ;ALB/CJM/AAS - Create form spec for scanning ; 6-JUN-95
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,25**;APR 24, 1997
3 ;
4HANDPRNT(IEN,NAME,PAGE,ROW,COL,WIDTH,LINES,READTYPE,PAPKEY,PI) ;
5 ;
6 Q:($P($G(^IBE(357.6,+PI,0)),"^",6)'=1)
7 ;
8 N X1,X2,Y1,Y2,W,PICTURE,TYPEDATA,NODE0,LENGTH,LINENUM,PKDICT,CONF,L,SUBPICS,FORMAT,XYSMALL
9 S TYPEDATA="ALPHA",PICTURE=""
10 ;
11 ; -- get info associated with DHCP Data Element
12 I PAPKEY D
13 .S NODE0=$G(^IBE(359.1,PAPKEY,0)),NODE10=$G(^(10))
14 .S TYPEDATA=$P(NODE10,"^",1)
15 .S TYPEDATA=$S(TYPEDATA="a":"ALPHA",TYPEDATA="i":"INT",TYPEDATA="f":"FLOAT",TYPEDATA="t":"TIME",TYPEDATA="d":"DATE",1:"ALPHA")
16 .S PICTURE=$P(NODE10,"^",2)
17 .S FORMAT=$P(NODE0,"^",5) ;don't set year in format, needed as is for recognition
18 .S LENGTH=$P(NODE0,"^",2)
19 .S CONF=$P(NODE0,"^",7)
20 .S PKDICT=$P(NODE10,"^",3)
21 .S SUBPICS=$P(NODE10,"^",4)
22 ;
23 ;find top left-hand corner
24 S X1=((COL*COLWIDTH)+XOFFSET)*CONVERT,X1=$FN(X1,"",0)
25 S Y1=((ROW*ROWHT)+YOFFSET+YHANDOS)*CONVERT,Y1=$FN(Y1,"",0)
26 S XYSMALL=$P(^IBD(357.09,1,0),"^",12)
27 I XYSMALL'=+XYSMALL S XYSMALL=5 ;default
28 ;
29 I READTYPE=3 D
30 .;define some marksense fields - if any marked it means there is print!
31 .S FIELD=FIELD+1
32 .D BLDARY^IBDFBKS("FIELD ' "_FIELD)
33 .D BLDARY^IBDFBKS(" NAME = """_NAME_"?"";")
34 .D BLDARY^IBDFBKS(" ELEMTYPE = RECT;")
35 .D BLDARY^IBDFBKS(" METRIC = 40 40 0 0 0 0 1 0 1;")
36 .D BLDARY^IBDFBKS(" TYPEDATA = INT;")
37 .D BLDARY^IBDFBKS(" LENGTH = ",LENGTH,";")
38 .D BLDARY^IBDFBKS(" POINTS =")
39 .F L=1:1:LINES F W=1:1:WIDTH D
40 ..S X2=X1+((((W-1)*172.7645)+30)*CONVERT),X2=$FN(X2,"",0)
41 ..S Y2=Y1+(((L*180)-39)*CONVERT),Y2=$FN(Y2,"",0)
42 ..S IBDFSA(IBLC)=IBDFSA(IBLC)_" "_Y2+1_" "_X2+1
43 .S IBDFSA(IBLC)=IBDFSA(IBLC)_";"
44 .D BLDARY^IBDFBKS(" PAGE = ",PAGE,";")
45 .D BLDARY^IBDFBKS(" CONFIDENCE = "" 0"";")
46 .D BLDARY^IBDFBKS(" END = {if (FIELDSTATUS != FIELD_BLANK){")
47 .D BLDARY^IBDFBKS(" hasprint=1;")
48 .D BLDARY^IBDFBKS(" FIELDSTATUS=FIELD_BAD;")
49 .D BLDARY^IBDFBKS(" }")
50 .D BLDARY^IBDFBKS(" else {")
51 .D BLDARY^IBDFBKS(" hasprint=0;")
52 .D BLDARY^IBDFBKS(" NEXTFIELD=NEXTFIELD+1;")
53 .D BLDARY^IBDFBKS(" }};")
54 .D BLDARY^IBDFBKS(" EXFORMAT = ""NOEXPORT"";")
55 .D BLDARY^IBDFBKS(" HIDDEN = ""1"";")
56 ;
57 ;field is narrative that needs to be broken into single lines
58 I (LINES>1)&(READTYPE=2) D Q
59 .F LINENUM=1:1:LINES S:LINENUM>1 Y1=$FN(Y1+(2*ROWHT*CONVERT),"",0) D
60 ..S X2=X1+(172.7654*WIDTH*CONVERT),X2=$FN(X2,"",0)
61 ..S Y2=Y1+(180*CONVERT),Y2=$FN(Y2,"",0)
62 ..D PRINTEND^IBDFBKS3
63 ..D PKFIELD(X1+2,Y1+2,X2-2,Y2-2,2,PICTURE,0,CONF,PKDICT,WIDTH,TYPEDATA,NAME_" LINE "_LINENUM,2)
64 ..;for handprint fields,must prefix data exported with field info - for bubbles the XMAP has the field info
65 ..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
66 ;
67 ;field needs to be broken into subfields due to the print format
68 I (READTYPE=2)&(FORMAT'="") D Q
69 .N SUBFIELD,I1,I2,PREFIX,SX1,SX2,SPICTURE,LEN,FOUNDEND
70 .S PREFIX=$P(FORMAT,"_"),I1=$L(PREFIX)+1
71 .S Y2=Y1+(180*CONVERT),Y2=$FN(Y2,"",0)
72 .F Q:(I1>WIDTH) D
73 ..S I2=I1
74 ..S FOUNDEND=0 F D Q:FOUNDEND
75 ...I $E(FORMAT,I2+1)="_" S I2=I2+1
76 ...E S FOUNDEND=1 Q
77 ..;so at this point I1=beginning of the subfield, I2=the end
78 ..S SX1=$FN(X1+(172.7654*(I1-1)*CONVERT),"",0)
79 ..S SX2=$FN(X1+(172.7654*(I2)*CONVERT),"",0)
80 ..S SPICTURE=$E(SUBPICS,I1,I2)
81 ..S LEN=(I2-I1)+1
82 ..D PRINTEND^IBDFBKS3
83 ..D PKFIELD(SX1+2,Y1+2,SX2-2,Y2-2,2,SPICTURE,1,0,"",LEN,"ALPHA",NAME_" Char:"_I1_" to "_I2)
84 ..S SUBFIELD(FIELD)=""
85 ..S (I1,I2)=I2+1
86 ..S FOUNDEND=0 F D Q:FOUNDEND
87 ...I $E(FORMAT,I2+1)="_" S FOUNDEND=1 Q
88 ...I I2>WIDTH S FOUNDEND=1 Q
89 ...S I2=I2+1 Q
90 ..I $E(FORMAT,I1,I2)'="" S SUBFIELD(FIELD)=$E(FORMAT,I1,I2)
91 ..S I1=I2+1
92 .;
93 .;now create a field to concatenate the subfields together
94 .S X2=X1+(172.7654*WIDTH*CONVERT),X2=$FN(X2,"",0)
95 .S Y2=Y1+(180*CONVERT),Y2=$FN(Y2,"",0)
96 .D PKFIELD(X1,Y1,X2,Y2,1,PICTURE,0,CONF,PKDICT,WIDTH,TYPEDATA,NAME,1)
97 .D
98 ..D BLDARY^IBDFBKS("BEGIN = {ALPHA sfstr;")
99 ..D BLDARY^IBDFBKS("ALPHA str;")
100 ..D BLDARY^IBDFBKS("INT sfconf;")
101 ..D BLDARY^IBDFBKS("INT conf;")
102 ..D BLDARY^IBDFBKS("INT found;")
103 ..D BLDARY^IBDFBKS("INT ret;")
104 ..D BLDARY^IBDFBKS("INT position;") ; patch 25 code
105 ..D BLDARY^IBDFBKS("INT delfield;") ; patch 25 code
106 ..D BLDARY^IBDFBKS("found=0;")
107 ..D BLDARY^IBDFBKS("conf=10;")
108 ..I PREFIX'="" D BLDARY^IBDFBKS(" str=\"""_PREFIX_"\"";")
109 ..N SUB S SUB=0 F S SUB=$O(SUBFIELD(SUB)) Q:'SUB D
110 ...D BLDARY^IBDFBKS(" sfstr=STRIP(GETAVALUE("_SUB_"));")
111 ...D BLDARY^IBDFBKS("str=STRCAT(str,sfstr);")
112 ...D BLDARY^IBDFBKS("if (sfstr!=\""\"") found=1;")
113 ...I SUBFIELD(SUB)'="" D BLDARY^IBDFBKS("str=STRCAT(sfstr,\"""_SUBFIELD(SUB)_"\"");")
114 ...D BLDARY^IBDFBKS("sfconf=GETCONF("_SUB_");")
115 ...D BLDARY^IBDFBKS("if (sfconf<conf) conf=sfconf;")
116 ..;
117 ..; patch 25 code starts here, remove dashes and dots
118 ..D BLDARY^IBDFBKS("")
119 ..D BLDARY^IBDFBKS("delfield = 0;")
120 ..D BLDARY^IBDFBKS("position = STRFIND(str,\"".\"",1);")
121 ..D BLDARY^IBDFBKS("if (position == 1) delfield = 1;")
122 ..D BLDARY^IBDFBKS("position = STRFIND(\"" . -----.. -....-----.-.--.../////--/.@.\"",str,1);")
123 ..D BLDARY^IBDFBKS("if (position != 0 || delfield == 1) {")
124 ..D BLDARY^IBDFBKS(" if (str != \"".\"") LOG(STRCAT(\""The following handprint field "_FIELD_" value was deleted: \"",str));")
125 ..D BLDARY^IBDFBKS(" str = \""\"";")
126 ..D BLDARY^IBDFBKS(" conf = 10;")
127 ..D BLDARY^IBDFBKS(" found = 0;}")
128 ..D BLDARY^IBDFBKS("")
129 ..;
130 ..D BLDARY^IBDFBKS("if (found) ret=SETTEXT("_FIELD_",str,ITOA(conf-1),FIELD_OK);")
131 ..D BLDARY^IBDFBKS("if (found == 0) ret=SETTEXT("_FIELD_",\""\"",ITOA(conf-1),FIELD_BLANK);")
132 ..D BLDARY^IBDFBKS("};")
133 .;
134 .;for handprint fields,must prefix data exported with field info - for bubbles the XMAP has the field info
135 .S @FIELDS@(PAGE,FIELD)="H:"_IEN_":",@FIELDS@(PAGE,FIELD,"DATATYPE")=TYPEDATA
136 ;
137 ;following are handprint fields that don't need to be broken into subfields
138 ;
139 I READTYPE=1 D ;not printed in ICR format
140 .D CNVRTHT^IBDF2D1(LINES,.LINES)
141 .S X2=X1+(103.65924*WIDTH*CONVERT),X2=$FN(X2,"",0)
142 .S Y2=Y1+(ROWHT*LINES*CONVERT),Y2=$FN(Y2,"",0)
143 ;
144 I READTYPE'=1 D ;printed in ICR format
145 .S X2=X1+(172.7654*WIDTH*CONVERT),X2=$FN(X2,"",0)
146 .S Y2=Y1+(180*LINES*CONVERT),Y2=$FN(Y2,"",0)
147 ;
148 D PRINTEND^IBDFBKS3
149 D:READTYPE=2 PKFIELD(X1+2,Y1+2,X2-2,Y2-2,READTYPE,PICTURE,0,CONF,PKDICT,WIDTH,TYPEDATA,NAME,2)
150 ;
151 D:READTYPE'=2 PKFIELD(X1,Y1,X2,Y2,READTYPE,PICTURE,0,"","",LENGTH,TYPEDATA,NAME)
152 S @FIELDS@(PAGE,FIELD)="H:"_IEN_":",@FIELDS@(PAGE,FIELD,"DATATYPE")=TYPEDATA
153 ;
154 ;** END STUFF **
155 I READTYPE'=2 D ;test the results of the marksense fields that were laid on top of the operator fill field
156 .D ADDTOEND^IBDFBKS3(" if ((hasprint)&&(FIELDACCEPTED==0)){")
157 .D ADDTOEND^IBDFBKS3(" FIELDSTATUS=FIELD_BAD;}")
158 Q
159 ;
160PKFIELD(X1,Y1,X2,Y2,READTYPE,PICTURE,HIDDEN,CONF,PKDICT,LENGTH,TYPEDATA,NAME,ENDPGM) ;
161 ; -- now for the handprint field
162 S FIELD=FIELD+1
163 D BLDARY^IBDFBKS("FIELD ' "_FIELD)
164 D BLDARY^IBDFBKS(" NAME = """_NAME_""";")
165 ;
166 I READTYPE=2 D
167 .D BLDARY^IBDFBKS(" ELEMTYPE = ELEM_OT;")
168 .D BLDARY^IBDFBKS(" METRIC = 2;")
169 ;
170 E D
171 .D BLDARY^IBDFBKS(" ELEMTYPE = ELEM_OT;")
172 .D BLDARY^IBDFBKS(" METRIC = 1;")
173 ;
174 D BLDARY^IBDFBKS(" DATATYPE ="_TYPEDATA_";")
175 D BLDARY^IBDFBKS(" LENGTH = "_LENGTH_";")
176 D BLDARY^IBDFBKS(" POINTS = "_(Y1+XYSMALL)_" "_(X1+XYSMALL)_" "_(Y2-XYSMALL)_" "_(X2-XYSMALL)_";")
177 D BLDARY^IBDFBKS(" PAGE = "_PAGE_";")
178 I CONF'="" D BLDARY^IBDFBKS(" CONFIDENCE = """_CONF_""";")
179 I HIDDEN D BLDARY^IBDFBKS(" HIDDEN = ""1"";")
180 I $G(ENDPGM) D HPSKIP
181 ;
182 ;** IMAGE PROCESSING **
183 I READTYPE=2 D
184 .D BLDARY^IBDFBKS(" ImageProcessing = {")
185 .D BLDARY^IBDFBKS(" IMAGEPROC=1")
186 .D BLDARY^IBDFBKS(" DESKEW=0")
187 .D BLDARY^IBDFBKS(" DESHADE=0")
188 .D BLDARY^IBDFBKS(" SMOOTH=1")
189 .D BLDARY^IBDFBKS(" REMOVE_BORDER=1")
190 .D BLDARY^IBDFBKS(" REMOVE_NOISE=0")
191 .D BLDARY^IBDFBKS(" PROC_MIN_VERT_LINE_LEN=70")
192 .D BLDARY^IBDFBKS(" PROC_MIN_HORZ_LINE_LEN=70")
193 .D BLDARY^IBDFBKS(" FATTYPE=0")
194 .D BLDARY^IBDFBKS(" FATTEN=0};")
195 .D BLDARY^IBDFBKS(" Recognition = {FIXED_WIDTH=1")
196 .D BLDARY^IBDFBKS(" OT_RECOGTYPE=HP")
197 .D BLDARY^IBDFBKS(" };")
198 ;
199 ;** begin program **
200 I $G(ENDPGM)=2 D
201 .D BLDARY^IBDFBKS("BEGIN = {ALPHA str;")
202 .D BLDARY^IBDFBKS("INT conf;")
203 .D BLDARY^IBDFBKS("INT ret;")
204 .D BLDARY^IBDFBKS(" conf = GETCONF("_FIELD_");")
205 .D BLDARY^IBDFBKS(" if (GETSTATUS("_FIELD_") == FIELD_BLANK) {")
206 .D BLDARY^IBDFBKS(" ret=SETTEXT("_FIELD_",\""\"",ITOA(conf-1),FIELD_BLANK); }")
207 .D BLDARY^IBDFBKS("if (ret) FIELDSTATUS = FIELD_ERROR;")
208 .D BLDARY^IBDFBKS("};")
209 .;
210 I PKDICT'="" D BLDARY^IBDFBKS(" DICTIONARY = """_PKDICT_""";")
211 I PICTURE'="",TYPEDATA="ALPHA" D BLDARY^IBDFBKS(" PICTURE = """_PICTURE_""";")
212 Q
213HPSKIP ; If hand print field blank, skip it
214 D ADDTOEND^IBDFBKS3(" if ((GETSTATUS(FIELDNAME) != FIELD_BLANK) && (FIELDACCEPTED == 0)) {")
215 D ADDTOEND^IBDFBKS3(" FIELDSTATUS = FIELD_BAD;")
216 D ADDTOEND^IBDFBKS3(" saveunrf = "_FIELD_";}")
217 Q
Note: See TracBrowser for help on using the repository browser.