source: IHS-VA_UTILITIES-XB/trunk/XBFORM.m@ 1800

Last change on this file since 1800 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.
File size: 5.4 KB
Line 
1XBFORM ; IHS/ADC/GTH - BUILD ARRAY FROM WP FORMAT ; [ 07/08/1999 3:53 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; Please refer to routine XBFORM0 for documentation.
5 ;
6 Q
7 ;
8EDIT(XBFORM,XBWPDIC,XBWPFLD) ;EP Edit a Form
9EDIT2 ;
10 KILL ^TMP($J,"XBFORM",XBFORM)
11 S XBLLINE=0,XBFMT=1
12 I $D(XBLMMRK) S XBLMMARK=XBLMMRK
13 I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
14 S XBLMMRK=XBLMMARK
15 D EDITWP,WPGET,BUILD,ZBUILD
16 ;** add RV markers
17 I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
18 I $D(DIRUT) D EXIT KILL XBLLINE Q
19MARK ;
20 I $G(XBLMMARK) F XBRVL=5:5 Q:'$D(XBZ(XBRVL)) S:'(XBRVL#10) $E(XBZ(XBRVL,0),80)=$E(XBRVL)
21 KILL XBRVL
22 D ARRAY^XBLM("XBZ(",XBFORM),CLEAR^VALM1
23 I $$DIR^XBDIR("S^R:Re-Edit;Q:Quit")="R" KILL XBZ G EDIT2
24 D EXIT
25 KILL XBLLINE
26 Q
27 ;
28GEN(XBFORM,XBWPDIC,XBWPFLD,XBREF,XBFMT,XBLAST) ;EP ** generate array
29 NEW XBLLINE
30 S XBLLINE=$G(XBLAST)
31 I $D(^TMP($J,"XBFORM",XBFORM)) D ZBUILD,REFBUILD,EXIT Q XBLLINE
32 D WPGET,BUILD,ZBUILD,REFBUILD,EXIT
33 Q XBLLINE
34 ;
35EDITWP ;** edit WP array
36 KILL DIE,DIC,DA,DR
37 S DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="AEQMLZ"
38 I $L($G(XBFORM))>0 S X=XBFORM,DIC(0)="XL"
39 D ^DIC
40 I Y'>0 S XBQUIT=1 Q
41 S DIE=$$DIC^XBDIQ1(XBWPDIC),DA=+Y,DR=XBWPFLD
42 D ^DIE
43 Q
44 ;
45WPGET ;** get WP array
46 KILL XBWP,XBL,XBOUT,XBVAR,XBWWP,DIC,DR,DIE,DA
47 S X=XBFORM,DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="X"
48 D ^DIC
49 I Y'>0 S XBWP(1)=XBFORM_" NOT FOUND",XBQUIT=1
50 S DA=+Y
51 D ENP^XBDIQ1(XBWPDIC,DA,XBWPFLD,"XBWWP(")
52 S %X="XBWWP("_XBWPFLD_",",%Y="XBWP("
53 D %XY^%RCR
54 KILL XBWWP
55 Q
56 ;
57BUILD ;** scan WP array to build XBL
58 S XBWPL="",XBLINE=0
59 Q:$D(^TMP($J,"XBFORM",XBFORM))
60 F S XBWPL=$O(XBWP(XBWPL)) Q:XBWPL'>0 D LINE
61 Q
62 ;
63LINE ;** process one line of the WP array
64 S Z=XBWP(XBWPL),XBLINE=XBLINE+1
65 F I=1:1:$L(Z) S A=$E(Z,I) D Q:$G(XBQUIT)
66 . I I=1,A="#" D MAP S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
67 . I I=1,A="*" D OUT S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
68 . I I=1,A=";" S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
69 . I A'=" ",A'="|" D TEXT Q
70 . I A="|" D VAR Q
71 .Q
72 KILL XBQUIT
73 Q
74 ;
75ZBUILD ;** build Z array from XBL
76 KILL Z
77 I '$G(XBFMT) F XBL=1:1 D Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL)))
78 . I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE)=" " Q
79 . D FILL
80 .Q
81 I $G(XBFMT)=1 F XBL=1:1 D Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL)))
82 . I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE,0)=" " Q
83 . D FILL
84 .Q
85 Q
86 ;
87REFBUILD ; %RCR BACK TO CALL
88 S %Y=XBREF,%X="XBZ("
89 D %XY^%RCR
90 S XBLLINE=XBLLINE+XBL
91 Q
92 ;
93FILL ;** fill one line
94 S XBCOL=0,T=""
95 F S XBCOL=$O(^TMP($J,"XBFORM",XBFORM,XBL,XBCOL)) Q:XBCOL'>0 D
96 . S X=^TMP($J,"XBFORM",XBFORM,XBL,XBCOL)
97 . S XBCOLX=XBCOL
98 . I XBCOL#1 S XBCOLX=XBCOL\1,X="S X="_X X X
99 . S XBXL=$L(X)
100 . Q:X=""
101 . S T=$$SETSTR^VALM1(X,T,XBCOLX,XBXL)
102 .Q
103 I T="" S XBLLINE=$G(XBLLINE)-1 Q
104 S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
105 S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
106 Q
107 ;
108TEXT ;**
109 NEW W
110 S XBCOL=I
111 F W=I:1:$L(Z) S A=$E(Z,W) Q:A="|"
112 I W'=$L(Z) S W=W-1
113 S XBT=$E(Z,I,W),^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL)=XBT,I=W
114 Q
115 ;
116VAR ;** add .5 to column count to indicate a variable vs text
117 S XBCOL=I
118 F W=I+1:1:$L(Z) S A=$E(Z,W) I A="|" Q
119 S XBT=$E(Z,I+1,W-1)
120 I XBT="" S XBT="""|"""
121 S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT,I=W
122 I XBT'["@" D Q
123 . Q:'$D(XBOUT(XBT))
124 . I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
125 . S O=XBOUT(XBT),XBT=$$SUB^XBFORM1(XBT,O)
126 . S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
127 .Q
128 S XBV=$P(XBT,"@"),XBV=XBVAR(XBV),XBS=$P(XBT,"@",2)
129 I $L(XBS) S XBS="("_XBS_")"
130 S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBV_XBS
131 I $D(XBOUT(XBT)) D
132 . I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
133 . S O=XBOUT(XBT),XBT=XBV_XBS,XBT=$$SUB^XBFORM1(XBT,O)
134 . S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
135 .Q
136 Q
137 ;
138MAP ;** map shorthand for variables
139 ;#xx1=yyy1|xx2=yyy2|
140 S Z=$E(Z,2,999)
141 I Z'["|" S XBVSUB=$P(Z,"="),XBVAL=$P(Z,"=",2),XBVAR(XBVSUB)=XBVAL Q
142 F I=1:1 S P=$P(Z,"|",I) Q:P="" S XBVSUB=$P(P,"="),XBVAL=$P(P,"=",2),XBVAR(XBVSUB)=XBVAL
143 Q
144 ;
145OUT ;** output transform of data field
146 ;*field:mumps output transform f(x)|
147 S Z=$E(Z,2,999)
148 I Z'["|" S XBVSUB=$P(Z,":"),XBVAL=$P(Z,":",2,99),XBOUT(XBVSUB)=XBVAL Q
149 F I=1:1 S P=$P(Z,"|",I) Q:P="" S XBVSUB=$P(P,":"),XBVAL=$P(P,":",2,99),XBOUT(XBVSUB)=XBVAL
150 Q
151 ;
152TABS ;
153 S XBF="|....^...."
154 W #
155 F I=0:1:7 W ?I*10,I*10
156 F L=1:1:66 W !?1,L,?3,"..^...." F X=1:1:7 W XBF
157 Q
158 ;
159EXIT ;
160 KILL XBZ,XBFMT,XBCOL,XBCOLX,XBF,XBL,XBLINE,XBLN,XBLOAD,XBOUT,XBQUIT,XBROU,XBS,XBT,XBTAG,XBTAGE,XBV,XBVAL,XBVAR,XBVSUB,XBWP,XBWPDA,XBWPDIC,XBWPFLD,XBWPL,XBWPNODE,XBWPSUB,XBWWP,XBX,XBXL,XBRVL,XBLWP,XBLMMRK
161 KILL XBLIN,XBLIN0,XBLIN1,XBLINX
162 Q
163 ;
164MDY(X) ;external date to mm/dd/yy x :: var or ~"NOW"~ or ~"TODAY"~
165 S %DT="TS"
166 D ^%DT
167 ;begin Y2K fix block
168 ;S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
169 S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;Y2000
170 ;end Y2K fix block
171 Q X
172 ;
173WP(X) ;build wp entry X #:: WP(FLD,n)=TEXTn
174 NEW I,W
175 S XBLWP=$G(XBLLINE),W=$P(X,")")
176 F I=0:1 S X=$Q(@X) Q:X="" Q:(W'=$P(X,",")) D
177 . S T=@X,XBLLINE=XBLWP+I
178 . S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
179 . S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
180 .Q
181 Q ""
182 ;
183FL(X) ; FL fill lines until line X
184 NEW I,W
185 S XBLWP=$G(XBLLINE)
186 Q:((XBLLINE+XBL)'<X) ""
187 F XBLLINE=XBLLINE:1:X-XBL D
188 . S T=" "
189 . S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
190 . S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
191 .Q
192 Q ""
193 ;
194FMSUB(X) ;process popular ;D8 ;L20 ;R20
195 NEW BARC,BARP
196 S BARC=$E(X,2),BARP=$E(X,3,999)
197 I BARC="D" S X="$J(X,"_BARP_",2)" Q X
198 I BARC="L" S X="$E(X,1,"_BARP_")" Q X
199 I BARC="R" S X="$J(X,"_BARP_")" Q X
200 S X="X"
201 Q X
202 ;
Note: See TracBrowser for help on using the repository browser.