source: IHS-VA_UTILITIES-XB/XBFORM.m@ 641

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

Initial commit of XB, move away from sf.net.
Includes kids file and documentation.
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.