source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFBKS3.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1IBDFBKS3 ;ALB/CJM/AAS - ENCOUNTER FORM - create form spec for scanning (Broker Version) ; 6-JUN-95 [ 11/13/96 3:32 PM ]
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4BUBBLE ;
5 N COUNT
6 ;
7 D PRINTEND ;the end program for the prior field
8 ;
9 D BLDARY^IBDFBKS("FIELD ' "_FIELD)
10 ;
11 ;** NAME **
12 D BLDARY^IBDFBKS(" NAME = """_NAME_""";")
13 ;
14 ;** ELEMTYPE **
15 D BLDARY^IBDFBKS(" ELEMTYPE = RECT;")
16 ;
17 ;** METRIC **
18 D BLDARY^IBDFBKS(" METRIC = 30 16 0 0 -16 -12 "_$G(IBDFILL,20)_" "_$G(IBDBKGND,5)_" 1;")
19 ;D BLDARY^IBDFBKS(" METRIC = 30 16 0 0 -16 -12 20 5 1;")
20 ;
21 ;** DATATYPE **
22 D BLDARY^IBDFBKS(" DATATYPE =INT;")
23 ;
24 ;** LENGTH **
25 I (TYPE=1)!(TYPE=2) D
26 .D BLDARY^IBDFBKS(" LENGTH = ")
27 .S COUNT=0
28 .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 COUNT=COUNT+1
29 .S IBDFSA(IBLC)=IBDFSA(IBLC)_COUNT_";"
30 I (TYPE=0)!(TYPE=3) D BLDARY^IBDFBKS(" LENGTH = 1;")
31 ;
32 ;** POINTS **
33 I (TYPE=0)!(TYPE=3) S Y=ROW,X=COL D FINDBUB(.Y,.X) D BLDARY^IBDFBKS(" POINTS = "_Y_" "_X_";")
34 I (TYPE=1)!(TYPE=2) D
35 .D BLDARY^IBDFBKS(" POINTS =")
36 .S COL="" F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" D
37 ..S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" D
38 ...S X=COL,Y=ROW
39 ...D FINDBUB(.Y,.X)
40 ...I $L(IBDFSA(IBLC))+$L(" "_Y_" "_X)<252 S IBDFSA(IBLC)=IBDFSA(IBLC)_" "_Y_" "_X Q
41 ...D BLDARY^IBDFBKS("~~~"_" "_Y_" "_X)
42 .S IBDFSA(IBLC)=IBDFSA(IBLC)_";"
43 ;
44 ;** PAGE **
45 D BLDARY^IBDFBKS(" PAGE = "_PAGE_";")
46 ;
47 ;** END ** program to enforce selection rule and to go to end of page
48 I TYPE=1 D ;exactly one required
49 .D ADDTOEND(" if (GETSTATUS("_FIELD_") == FIELD_BLANK){")
50 .;D ADDTOEND(" \' SHOW(\"""_$$CKNAM(NAME)_" is required!\"");")
51 .D ADDTOEND(" if (BATCH==0) {FIELDSTATUS = FIELD_BAD;}")
52 .D ADDTOEND(" if (BATCH==1) {saveunrf = "_FIELD_";}")
53 .D ADDTOEND(" }")
54 .D ADDTOEND(" if ((GETSTATUS("_FIELD_") == FIELD_TOOMANY)&&(BATCH == 1)) {")
55 .D ADDTOEND(" saveunrf = "_FIELD_";}")
56 ;
57 I TYPE=2 D ;at most one required
58 .D ADDTOEND(" if ((GETSTATUS("_FIELD_") == FIELD_TOOMANY)&&(BATCH == 1)) {")
59 .D ADDTOEND(" saveunrf = "_FIELD_";}")
60 ;
61 I TYPE=3,LAST'="" D ;at least one required
62 .D ADDTOEND(" INT field;")
63 .D ADDTOEND(" field="_FIRST_";") ;AAS Changed 11/14
64 .N X S X=LAST+1 D ADDTOEND(" while (field<"_X_"){") ;AAS changed 11/14
65 .D ADDTOEND(" if (GETSTATUS(field) != FIELD_BLANK) break;")
66 .D ADDTOEND(" field=field+1;")
67 .D ADDTOEND(" }")
68 .S X=LAST+1 D ADDTOEND(" if (field == "_X_"){")
69 .D ADDTOEND(" SHOW(\"""_$$CKNAM(OLDNAME)_" at least 1 required!\"");")
70 .D ADDTOEND(" FIELDSTATUS = FIELD_BAD;")
71 .D ADDTOEND(" }")
72 ;D ADDTOEND(" };")
73 ;
74 ;** XMAP **
75 ; -- only TYPE=0 (selection rule=anynumber) might be dynmaic
76 I (TYPE=0)!(TYPE=3) D BLDARY^IBDFBKS(" XMAP = "","_$S($P(NODE,"^",9):"D:"_FID_":"_$P(NODE,"^",10),1:"B:"_IEN_":"_$$GETCODE($P(NODE,"^",2),$P(NODE,"^")))_""";")
77 ;
78 I (TYPE=1)!(TYPE=2) D
79 .D BLDARY^IBDFBKS(" XMAP = """)
80 .S COL=""
81 .F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" D
82 ..S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" D
83 ...S IEN=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW,0)) I IEN D
84 ....S NODE=$G(^(IEN))
85 ....N IBX
86 ....S IBX=","_$S($P(NODE,"^",9):"D:"_FID_":"_$P(NODE,"^",10),1:"B:"_IEN_":"_$$GETCODE($P(NODE,"^",2),$P(NODE,"^")))
87 ....I $L(IBDFSA(IBLC))+$L(IBX)<252 S IBDFSA(IBLC)=IBDFSA(IBLC)_IBX Q
88 ....D BLDARY^IBDFBKS("~~~"_IBX)
89 .S IBDFSA(IBLC)=IBDFSA(IBLC)_""";"
90 ;
91 ;** MAP **
92 I (TYPE=0)!(TYPE=3) D BLDARY^IBDFBKS(" MAP = "" ,"_$TR($P(NODE,"^",6),",;"," ")_""";")
93 ;
94 I (TYPE=1)!(TYPE=2) D
95 .D BLDARY^IBDFBKS(" MAP = "" ")
96 .;
97 .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
98 ..I IEN S NODE=$G(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
99 ..I $L(IBDFSA(IBLC))+$L($TR($P(NODE,"^",6),",;"," "))<252 S IBDFSA(IBLC)=IBDFSA(IBLC)_","_$TR($P(NODE,"^",6),",;"," ") Q
100 ..D BLDARY^IBDFBKS("~~~"_","_$TR($P(NODE,"^",6),",;"," "))
101 .S IBDFSA(IBLC)=IBDFSA(IBLC)_""";"
102 I $D(OTHER($P(FID,"("),IEN)) S OTHER($P(FID,"("),IEN)=FIELD
103 Q
104 ;
105FINDBUB(Y,X) ;
106 ;converts row,col of bubble to paperkeyboard points, with proper offsets added - call by reference
107 S X=((COL*COLWIDTH)+(XBUBOS+XOFFSET))*CONVERT
108 ;S X=1+$FN(X,"",0)
109 S X=$FN(X,"",0)
110 S Y=((ROW*ROWHT)+(YOFFSET+YBUBOS))*CONVERT
111 ;S Y=1+$FN(Y,"",0)
112 S Y=$FN(Y,"",0)
113 Q
114 ;
115ADDTOBEG(TEXT) ;
116 I '$D(BEGIN) S BEGIN(1)=" BEGIN = {",BLN=1
117 S BLN=BLN+1
118 S BEGIN(BLN)=TEXT
119 Q
120 ;
121PRINTBEG ;
122 I $D(BEGIN) D
123 .S BLN=0 F S BLN=$O(BEGIN(BLN)) Q:'BLN D BLDARY^IBDFBKS(BEGIN(BLN))
124 .D BLDARY^IBDFBKS(" };")
125 .K BEGIN
126 Q
127 ;
128ADDTOEND(TEXT) ;
129 I '$D(END) S END(1)=" END = {",LN=1
130 S LN=LN+1
131 S END(LN)=TEXT
132 Q
133 ;
134PRINTEND ;
135 I $D(END) D
136 .S LN=0 F S LN=$O(END(LN)) Q:'LN D BLDARY^IBDFBKS(END(LN))
137 .D BLDARY^IBDFBKS(" };")
138 .K END
139 I PRIORPG'=PAGE D PAGEEND(PRIORPG)
140 I PAGE>1,PRIORPG'=PAGE D PAGETOP(PAGE)
141 S PRIORPG=PAGE
142 Q
143 ;
144GETCODE(VALUE,PI) ;returns the value after passing it through the output transform contained in the package interface file
145 ;
146 N X,Y S (Y,X)=VALUE
147 ;
148 I PI X $G(^IBE(357.6,PI,14))
149 Q Y
150 ;
151PAGEEND(PAGE) ;end of page processing
152 N FLD
153 S FIELD=FIELD+1
154 F COUNT=1:1 S LINE=$T(BOTTOM+COUNT^IBDFBKS1),TAG=$P(LINE,";;"),LINE=$P(LINE,";;",2) Q:TAG["QUIT" D
155 .I TAG["NUMBER" D BLDARY^IBDFBKS("FIELD ' "_FIELD) Q
156 .I TAG["NAME" D BLDARY^IBDFBKS(" NAME = ""BOTTOM OF PAGE"_PAGE_""";") Q
157 .I TAG["PAGE" D BLDARY^IBDFBKS(" PAGE = "_PAGE_";") Q
158 .I TAG["SAVE" D Q
159 ..D BLDARY^IBDFBKS(" Save = STRCAT(\""SAVEFORM(\"",ITOA(GETIVALUE(7)));")
160 ..D BLDARY^IBDFBKS(" Save = STRCAT(Save,"","_PAGE_",,V)"");")
161 ..;
162 .I TAG["EXPORT" D Q
163 ..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,\""$$NEW$$("");")
164 ..D BLDARY^IBDFBKS(" Data=\""$$ADD$$(FORMTYPE="_IBFORMID_",\"";")
165 ..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
166 ..D BLDARY^IBDFBKS(" Data=STRCAT(\""$$ADD$$(FORMID=\"",ITOA(GETIVALUE(7)));")
167 ..D BLDARY^IBDFBKS(" Data=STRCAT(Data,\"",\"");")
168 ..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
169 ..D BLDARY^IBDFBKS(" Data=\""$$ADD$$(PAGE="_PAGE_",\"";")
170 ..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
171 ..D BLDARY^IBDFBKS(" Data=\""$$ADD$$(DATA=,\"";")
172 ..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
173 ..;
174 ..D FIELDS^IBDFBKS4
175 .D BLDARY^IBDFBKS(LINE)
176 Q
177 ;
178 ;;;.I TAG["EXPORT" D Q
179 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(\""FORMTYPE="_IBFORMID_"\"",RS);")
180 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""FORMID=\"");")
181 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,ITOA(GETIVALUE(7)));")
182 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
183 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""PAGE="_PAGE_"\"");")
184 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
185 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""DATA=\"");")
186 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
187 ;;;..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
188 ;
189PAGETOP(PAGE) ;add field for top of page
190 S FIELD=FIELD+1
191 F COUNT=1:1 S LINE=$T(TOPOFPG+COUNT^IBDFBKS1),TAG=$P(LINE,";;"),LINE=$P(LINE,";;",2) Q:TAG["QUIT" D
192 .I TAG["NUMBER" D BLDARY^IBDFBKS("FIELD ' "_FIELD) Q
193 .I TAG["FLDNAME" D BLDARY^IBDFBKS(" NAME = ""TOP OF PAGE "_PAGE_""";") Q
194 .I TAG["PAGE" D BLDARY^IBDFBKS(" PAGE = "_PAGE_";") Q
195 .D BLDARY^IBDFBKS(LINE)
196 Q
197CKNAM(NAME) ; - format name with \ for paperkey when displaying name
198 F CHAR="\","'" I NAME[CHAR D
199 .F A=1:1:$L(NAME,CHAR)-1 S NAME=$P(NAME,CHAR,1,A)_"\"_CHAR_$P(NAME,CHAR,A+1,$L(NAME,CHAR))
200 Q NAME
Note: See TracBrowser for help on using the repository browser.