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: ;
; 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