-
Notifications
You must be signed in to change notification settings - Fork 5
/
ZDIOUT1.m
171 lines (171 loc) · 6.47 KB
/
ZDIOUT1.m
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
ZDIOUT1 ; Experimental FileMan file output to host file
;---------------------------------------------------------------------------
; Copyright 2011 The Open Source Electronic Health Record Agent
;
; Licensed under the Apache License, Version 2.0 (the "License");
; you may not use this file except in compliance with the License.
; You may obtain a copy of the License at
;
; http://www.apache.org/licenses/LICENSE-2.0
;
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
; See the License for the specific language governing permissions and
; limitations under the License.
;---------------------------------------------------------------------------
N W "Experimental FileMan file output to host file",!
D ASKFILE Q:FILE["^"
D ASKDIR Q:DIR["^"
D SAVEFILE(FILE,DIR)
Q
SAVEFILE(FILE,DIR) ; Save FILE to given host directory
I '$$SLASH(DIR) Q
N FGR S FGR=$$FGR(FILE) Q:'$$CHECK(FGR,"Not a valid file number: "_FILE)
S IO=DIR_$P($E(FGR,2,$L(FGR)),"(")_"+"_$$FILENAME(FILE,FGR)_".txt"
W IO,!
C IO O IO:("WNS"):1 E U $P W "Cannot open """_IO_""" for write!",! Q
D FILE("",FILE,FGR)
C IO
Q
PRNFILE(FILE,IO) ; Print FILE, optionally to IO device
S:'$D(IO) IO=$P
N FGR S FGR=$$FGR(FILE) Q:'$$CHECK(FGR,"Not a valid file number: "_FILE)
D FILE("",FILE,FGR)
Q
PRNENTRY(FILE,I,IO) ; Print FILE record #I, optionally to IO device
S:'$D(IO) IO=$P
N FGR S FGR=$$FGR(FILE) Q:'$$CHECK(FGR,"Not a valid file number: "_FILE)
N DD D DDCR(FILE,.DD)
D ENTITY("",FILE,.DD,$$EGR(FGR,I))
Q
PRNDD(FILE,IO) ; Print DD for FILE, optionally to IO device
S:'$D(IO) IO=$P
; DD(FILE) is a file#0 whose entries define fields of FILE
N FGR S FGR=$NA(^DD(FILE))
I '$D(@FGR) W "Not a valid file number: "_FILE,! Q
D FILE("",0,FGR)
Q
;---------------------------------------------------------------------------
; Private implementation entry points below.
; References cite the VA FileMan 22.0 Programmer Manual.
;
ASKFILE ; Ask for file number
R !,"File#: ",FILE G:FILE="" ASKFILE Q:FILE["^" S FILE=+FILE
S FGR=$$FGR(FILE)
I '$$CHECK(FGR," (Not a valid file number)") G ASKFILE
W " ",$$FILENAME(FILE,FGR)
Q
ASKDIR ; Ask for host dir
R !,!,"Host output directory: ",DIR,! Q:DIR["^" G:'$$SLASH(DIR) ASKDIR
Q
SLASH(DIR) ; Validate trailing slash
I $E(DIR,$L(DIR))?1(1"/",1"\") Q 1
E U $P W "Output directory must end in a slash!" Q 0
FGR(FILE) ; Get FILE Global Root
Q $$ROOT^DILFD(FILE,"",1)
EGR(FGR,I) ; Get ENTRY Global Root
Q $NA(@FGR@(I))
CHECK(V,MSG) ; Validate non-empty value
I V="" W MSG,! Q 0
Q 1
DDCR(FILE,DD) ; X-ref global subscript location to DD field
; The DD field definition 0-node has ^-pieces "^^^S;P^" where
; "S;P" is the node Subscript and Piece within the node value (14.9.2).
N F S F="" F S F=$O(^DD(FILE,F)) Q:F="" D:+F
. N F4,S,P S F4=$P(^DD(FILE,F,0),"^",4),S=$P(F4,";",1),P=$P(F4,";",2) Q:S=" "
. S DD(S,F)=P ; Subscript S contains field F at piece P
Q
FILE(D,FILE,FGR) ; Write all entries in a file
; TODO: Sort entries by .01 or KEY to ensure consistent order
N DD D DDCR(FILE,.DD)
N I S I="" F S I=$O(@FGR@(I)) Q:I="" D
. I +I D
. . D ENTITY(D,FILE,.DD,$$EGR(FGR,I))
. E D ; TODO: Handle known non-entry subscripts such as "B"
. . D SUBS(D,$$EGR(FGR,I),I)
Q
WP(D,FGR) ; Write a word-processing value
; A word processing field is actually a file in which each entry has a
; .01 field containing the line of text, and the type of the field has "W".
U IO W D,";",$$VALUE(@FGR@(0)),! ; TODO: Preserve date from ^(0)
N I S I="" F S I=$O(@FGR@(I)) Q:I="" D:+I ; TODO: Other subscripts?
. U IO W D,$$VALUE(@FGR@(I,0)),!
U IO W D,";",!
Q
ENTITY(D,FILE,DD,EGR) ; Write a file entry
U IO W D,"ENTITY"_$C(9)_";;"_$$FILENAME(FILE,FGR)_"^"_$S(FILE=0:"",1:FILE)_" ;"_EGR,!
U IO W D_$C(9)_";",!
; Add key tag with field .01 value (14.9.2).
; TODO: Use indexing cross-references or KEY file entries for key tags?
; TODO: Escape key values, handle pointers?
U IO W D,"KA"_$C(9)_";;",$P(@EGR@(0),"^"),!
U IO W D_$C(9)_";",!
N S S S="" F S S=$O(@EGR@(S)) Q:S="" D ; Find DD fields at S.
. I $D(DD(S))<10 D ; TODO: Field defs like "DEL" not in ^DD(0)
. . D SUBS(D,$NA(@EGR@(S)),S)
. N F S F="" F S F=$O(DD(S,F)) Q:F="" D
. . D FIELD(D,FILE,F,$NA(@EGR@(S)),DD(S,F))
Q
;
SUBS(D,G,S) ; Write an extraneous subscript
U IO W D,"SUBS"_$C(9)_";;"_S,!
I $D(@G)#10 U IO W D_$C(9),$$VALUE(@G),!
I $D(@G)\10 U IO W D_$C(9),"; OMITTED CHILDREN",!
U IO W D_$C(9),";",!
Q
FIELD(D,FILE,F,EGRF,P) ; Write a field
; The DD field definition 0-node has ^-pieces "NAME^TYPE^" (14.9.2).
N FD S FD=^DD(FILE,F,0)
N NAME S NAME=$P(FD,"^",1)
N TYPE S TYPE=$P(FD,"^",2)
; TYPE starts with a subfile number if the field is a multiple (14.9.2)
N SUBFILE S SUBFILE=+TYPE
I SUBFILE D
. D FIELDSUB
E D
. D FIELDONE
Q
FIELDTAG ; Write tag for a field
U IO W D,"F"_$TR(F,".","P")_$C(9)_";;"_NAME_"^"_F_" ;"_TYPE,!
Q
FIELDSUB ; Write a multiple-valued field
D FIELDTAG
I $D(@EGRF)#10 U IO W D_$C(9),"; OMITTED SELF",!
; Word-processing values are files whose .01 field type has "W".
I $P($G(^DD(SUBFILE,.01,0)),"^",2)["W" D
. D WP(D_$C(9),EGRF)
E D
. D FILE(D_$C(9),SUBFILE,EGRF) U IO W D_$C(9),";",!
Q
FIELDONE ; Write a single-valued field
N V S V=$$FIELDVAL(EGRF,P) Q:V=""
N EV ; Some TYPEs have an external-format value
N T S T=TYPE
I T["F" S TYPE=TYPE_";"_"Free Text"
I T["N" S TYPE=TYPE_";"_"Numeric"
I T["K" S TYPE=TYPE_";"_"MUMPS Code"
I T["P" S TYPE=TYPE_";"_"Pointer",EV=1
I T["V" S TYPE=TYPE_";"_"Variable Pointer",EV=1
I T["S" S TYPE=TYPE_";"_"Set of Codes",EV=1
I T["D" S TYPE=TYPE_";"_"Date",EV=1
I $D(EV) S V=V_"^"_$$EXTERNAL^DILFD(FILE,F,"",V)
D FIELDTAG
U IO W D_$C(9),$$VALUE(V),!
I $D(@EGRF)\10 U IO W D_$C(9),"; OMITTED CHILDREN",!
U IO W D_$C(9),";",!
Q
FIELDVAL(EGRF,P) ; Extract piece P of node value holding field
I +P Q $P(@EGRF,"^",P)
I $E(P,1)="E" Q $E(@EGRF,$P($E(P,2,$L(P)),",",1),$P(P,",",2))
Q ";UNKNOWN ""GLOBAL SUBSCRIPT LOCATION"" PIECE """_P_""""
;
FILENAME(FILE,FGR) ; Lookup the name of given FILE# (or subfile#)
I FILE=0 Q $P(@FGR@(0),"^") ; DD
Q $O(^DD(FILE,0,"NM","")) ; TODO: Reliable? Any documented API?
VALUE(V) ; Write value line to output
; TODO: If value starts in one of " $ ; or contains non-printing
; characters then it must be escaped for evaluation on RHS of SET.
; TODO: Caller must define indentation level with a comment if
; the first character of the first value is a tab or space.
Q V