source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFBKS.m@ 649

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1IBDFBKS ;ALB/CJM/AAS - Create form spec file for scanning ; 6-JUN-95
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
3 ;
4SCAN(IBFORMID) ;
5 ;
6 Q:'$G(IBFORMID)
7 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
8 ;XOFFSET,YOFFSET are the page margins (in decipoints)
9 ;XBUBOS,YBUBOS are the offsets within the col,row of the bubbles
10 ;YHANDOS is the offset for a handprint field within the row
11 ;
12 I '$D(DT) D DT^DICRW
13 I $D(^IBD(359.2,IBFORMID,0)),$D(^IBD(357.95,IBFORMID,0)) S DIK="^IBD(359.2,",DA=IBFORMID D ^DIK
14 I '$D(DT) D DT^DICRW
15 S IBLC=0
16 D PARAM
17 S CONVERT=.352778 ;for converting PCL decipoints to .1mm
18 ; This number is actually 254/720 ... 254 PK points (.1 mm) = 1 inch
19 ; 720 PCL5 decipoints = 1 inch
20 ; A PCL5 decipoint = .352778 PK points
21 S SCAN="^TMP(""IBDF"",$J,""SCAN"",IBFORMID)"
22 K @SCAN
23 ;
24 S FIELDS="^TMP(""IBDF"",$J,""FIELDS"")"
25 K @FIELDS
26 ;
27 ;get form description
28 S NODE=$G(^IBD(357.95,IBFORMID,0))
29 Q:NODE=""
30 S PERPAGE=$P(NODE,"^",10)
31 ;determine sizes and offsets - in terms of PCL decipoints
32 S XOFFSET=180 ; This is 1/4 inch ... .25*720 PCL decipoints
33 S YOFFSET=360 ; This is 1/2 inch ... .5*720 PCL decipoints
34 ; rowht = # of PCL decipoints/line in height
35 ; 80 lines (133 Col) = 720/8 lines per inch)
36 ; 72 lines (96 Col) = 720/7.2 lines per inch)
37 ; 60 lines (80 Col) = 720/6 lines per inch)
38 S ROWHT=$P(NODE,"^",10),ROWHT=$S(ROWHT>72:90,ROWHT>60:100.0005,1:120)
39 S COLWIDTH=$P(NODE,"^",9)
40 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
41 S YBUBOS=$S(COLWIDTH>96:65,COLWIDTH>80:75,1:85)
42 ; colwidth = # of PCL decipoints/character in width
43 ; 133 Col = 720/16.67 char per inch
44 ; 96 Col = 720/12 char per inch
45 ; 80 Col = 720/10 char per inch
46 S COLWIDTH=$S(COLWIDTH>96:(720/16.67),COLWIDTH>80:60,1:72) ;converted to decipoints
47 S XBUBOS=XBUBOS*COLWIDTH ;converted to decipoints
48 S YHANDOS=$S(ROWHT=90:0,ROWHT=100.0005:15,1:30)
49 ;
50 ;get the list of scannable pages
51 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)=""
52 ;
53 ;
54 S PAGE=0 F S PAGE=$O(PAGE(PAGE)) Q:'PAGE D
55 .;
56 .;list all the bubbles
57 .S ROW=((PAGE-1)*PERPAGE)-1
58 .S ARY="^IBD(357.95,""AC"","_IBFORMID_")"
59 .F S ROW=$O(@ARY@(ROW)) Q:ROW="" D
60 ..Q:(ROW\PERPAGE)+1'=PAGE
61 ..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
62 ...S NODE=$G(^IBD(357.95,IBFORMID,1,IEN,0))
63 ...Q:($P(NODE,"^",6)="")!(($P(NODE,"^",4)="")&($P(NODE,"^",8)=""))!('$P(NODE,"^",3))
64 ...S NAME=$E($P(NODE,"^",5),1,17),QLFR=$P(NODE,"^",10)
65 ...S TYPE=$P(NODE,"^",7)
66 ...I (TYPE=0)!(TYPE=3) S:QLFR QLFR=$P($G(^IBD(357.98,QLFR,0)),"^",3)
67 ...I (TYPE=1)!(TYPE=2) S:QLFR QLFR=$E($P($G(^IBD(357.98,QLFR,0)),"^"),1,12)
68 ...I QLFR'="" S NAME=NAME_"("_QLFR_")"
69 ...I QLFR="" S NAME=NAME_"-"
70 ...S @SCAN@(PAGE,$P(NODE,"^",6),+$P(NODE,"^",7),COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$P(NODE,"^",3,12)
71 ...S @SCAN@(PAGE,$P(NODE,"^",6))=NAME
72 ...;
73 .;
74 .;list all the handprint fields
75 .S ARY="^IBD(357.95,""AD"","_IBFORMID_")"
76 .S ROW=((PAGE-1)*PERPAGE)-1
77 .F S ROW=$O(@ARY@(ROW)) Q:ROW="" D
78 ..Q:(ROW\PERPAGE)+1'=PAGE
79 ..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
80 ...S NODE=$G(^IBD(357.95,IBFORMID,2,IEN,0))
81 ...Q:($P(NODE,"^",8)="")!('$P(NODE,"^",4))!('$P(NODE,"^",15))
82 ...S @SCAN@(PAGE,$P(NODE,"^",8),6,COL,(ROW-((PAGE-1)*PERPAGE)),IEN)=$P(NODE,"^",3,17),NAME=$E($P(NODE,"^",5),1,15)
83 ...I $P(NODE,"^",17) S NAME=NAME_"("_$P($G(^IBE(359.1,$P(NODE,"^",17),0)),"^")_")"
84 ...S @SCAN@(PAGE,$P(NODE,"^",8))=NAME
85 ;
86 ;make form description
87 F COUNT=1:1 S LINE=$T(FORM+COUNT^IBDFBKS1),TAG=$P(LINE,";;"),LINE=$P(LINE,";;",2) Q:TAG["QUIT" D
88 .N PG
89 .D BLDARY("")
90 .I TAG["NAME" S IBDFSA(IBLC)=IBDFSA(IBLC)_" NAME = ""ENCOUNTER FORM "_IBFORMID_""";" Q
91 .I TAG["SITE" S IBDFSA(IBLC)=IBDFSA(IBLC)_"'VA SITE = "_$P($$SITE^VASITE,"^",2),LINE=""
92 .I TAG["PGCK" S IBDFSA(IBLC)=IBDFSA(IBLC)_" else if (" D Q
93 ..S PG=$O(PAGE(0))
94 ..S IBDFSA(IBLC)=IBDFSA(IBLC)_"(page!="_PG_")"
95 ..F S PG=$O(PAGE(PG)) Q:'PG S IBDFSA(IBLC)=IBDFSA(IBLC)_"&&(page!="_PG_")"
96 ..S IBDFSA(IBLC)=IBDFSA(IBLC)_"){"
97 .S IBDFSA(IBLC)=IBDFSA(IBLC)_LINE
98 .;D BLDARY(LINE)
99 ;
100 ;make fields
101 S PAGE=0,FIELD=9,PRIORPG=$O(@SCAN@(0)),LN=0,BLN=0
102 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
103 .S NAME=$G(@SCAN@(PAGE,FID))
104 .;
105 .; -- 1 = EXACTLY ONE, 2 = AT MOST ONE (0 or 1)
106 .I (TYPE=1)!(TYPE=2) S FIELD=FIELD+1,@FIELDS@(PAGE,FIELD)="" D
107 ..I TYPE=1 S NAME=NAME_" (1 Required)"
108 ..I TYPE=2 S NAME=NAME_" (1 Optional)"
109 ..S NAME=$$NAME(NAME)
110 ..D BUBBLE^IBDFBKS3 Q
111 .;
112 .I TYPE=6 D Q
113 ..N OLDNAME S OLDNAME=NAME
114 ..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
115 ...S NAME=$$NAME(OLDNAME)
116 ...;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
117 ...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))
118 .;
119 .;0 = ANY NUMBER
120 .;3 = AT LEAST ONE (1 or more)
121 .I (TYPE=0)!(TYPE=3) D
122 ..N OLDNAME
123 ..;I TYPE=3 N FIRST,LAST S LAST=FIELD+1,LAST=""
124 ..I TYPE=3 N FIRST,LAST S FIRST=FIELD+1,LAST=""
125 ..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
126 ...S FIELD=FIELD+1,@FIELDS@(PAGE,FIELD)="",NODE=$G(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
127 ...S (NAME,OLDNAME)=$G(@SCAN@(PAGE,FID))
128 ...S NAME=$$NAME(NAME)
129 ...I TYPE=3,$O(@SCAN@(PAGE,FID,TYPE,COL,ROW))="",($O(@SCAN@(PAGE,FID,TYPE,COL))="") S LAST=FIELD
130 ...D BUBBLE^IBDFBKS3
131 ;
132END ; -- end of routine
133 K @SCAN
134 K @FIELDS
135 K ^TMP("IBDF-NAME",$J)
136 S ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
137 S ^IBD(359.2,IBFORMID,10,0)="^^"_IBLC_"^"_IBLC_"^"_DT_"^"
138 Q
139 ;
140NAME(NAME) ;
141 ; -- make sure name is unique
142 N X
143 I (TYPE=0)!(TYPE=3) S NAME=NAME_" "_$P(NODE,"^",6) I TYPE=3
144 I TYPE=1,NAME'["Required" S NAME=NAME_" Required"
145 S X=$G(^TMP("IBDF-NAME",$J,NAME))+1
146 S ^TMP("IBDF-NAME",$J,NAME)=+X
147 I X>1 S NAME=NAME_" #"_X
148 Q NAME
149 ;
150BLDARY(TEXT) ;
151 ; -- builds the export array IBDFS(linecount) = text
152 N DIC,DA,DINUM,X,Y,I,J,DLAYGO
153 I IBLC=1 D
154 .S DIC="^IBD(359.2,",DIC(0)="L",DLAYGO=359.2,(DINUM,X)=IBFORMID D FILE^DICN
155 .Q
156 ;
157 I IBLC>0 D
158 .S ^IBD(359.2,IBFORMID,10,IBLC,0)=IBDFSA(IBLC)
159 .K IBDFSA(IBLC)
160 .Q
161 ;
162 S IBLC=IBLC+1
163 S IBDFSA(IBLC)=$G(TEXT)
164 Q
165 ;
166WRITE(IBFORMID) ;
167 N LINE S LINE=0
168 S X=0 X ^%ZOSF("RM")
169 F S LINE=$O(^IBD(359.2,IBFORMID,10,LINE)) Q:'LINE W !,$G(^IBD(359.2,IBFORMID,10,LINE,0))
170 S X=80 X ^%ZOSF("RM")
171 Q
172 ;
173PARAM ; -- get values from parameter file
174 ; ibdfill := % fill required
175 ; ibdbkgnd := % background expected
176 S IBDFILL=$P($G(^IBD(357.09,1,0)),"^",8) I IBDFILL="" S IBDFILL=20
177 S IBDBKGND=$P($G(^IBD(357.09,1,0)),"^",9) I IBDBKGND="" S IBDBKGND=5
178 S XYSMALL=$P(^IBD(357.09,1,0),"^",12) I XYSMALL'=+XYSMALL S XYSMALL=4
179 Q
Note: See TracBrowser for help on using the repository browser.