source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGUTIMP.m@ 811

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

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1RGUTIMP ;CAIRO/DKM - Import text into FileMan file;04-Sep-1998 11:26;DKM
2 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
3 ;=================================================================
4 ; Imports data from a specially formatted text file into a
5 ; FileMan file.
6 ; Inputs:
7 ; RGINP = Full input file or global specification.
8 ; RGTRACE= If nonzero, generates a debug trace.
9 ; Outputs:
10 ; Returns status code^status message. Status code of 0 means
11 ; successful completion.
12 ;=================================================================
13ENTRY(RGINP,RGTRACE) ;
14 N RGLN,RGFN,RGLVL,RGBM,RGC,RGLBL,RGQT,RGST,RGIO,RGGBL
15 S @$$TRAP^RGZOSF("ERROR^RGUTIMP")
16 S RGFN=0,RGLVL=-1,RGTRACE=+$G(RGTRACE),RGST=0,RGIO=$I,U="^",RGC=0,RGGBL=$E(RGINP)=U
17 I RGGBL S RGINP=$$CREF^DILF(RGINP)
18 E D OPEN^RGZOSF(.RGINP,"R")
19 F Q:$$READ D Q:RGST
20 .U RGIO
21 .W:RGTRACE=1 RGC,*13
22 .W:RGTRACE=2 RGC_": ",$$TRUNC^RGUT(RGLN,$G(IOM,80)-$X-2),!
23 .D DOIT(RGLN)
24 D:'RGGBL CLOSE^RGZOSF(.RGINP)
25 Q RGST
26READ() I 'RGGBL S RGC=RGC+1 Q $$READ^RGZOSF(.RGLN,RGINP)
27 S RGC=$O(@RGINP@(RGC))
28 Q:'RGC 1
29 I $D(@RGINP@(RGC))#2 S RGLN=@RGINP@(RGC) Q 0
30 I $D(@RGINP@(RGC,0))#2 S RGLN=@RGINP@(RGC,0) Q 0
31 Q 1
32ERROR D ERR("Fatal error",$$EC^%ZOSV)
33 Q RGST
34DOIT(RGLN) ;
35 N RGZ,RGL,RGFLD,RGWP
36 S RGLN=$$TRIM^RGUT(RGLN)
37 I ";"[$E(RGLN) W:RGTRACE=3 $P(RGLN,";",2,999),! Q
38 F RGL=0:1 Q:$E(RGLN,RGL+1)'="."
39 S RGLN=$E(RGLN,RGL+1,999)
40 I RGLN'[":" D ERR("Missing label",RGLN) Q
41 S RGLBL=$$TRIM^RGUT($P(RGLN,":")),RGLN=$$TRIM^RGUT($P(RGLN,":",2,999))
42 I 'RGL S RGFN=$$FILE(RGLN) Q
43 I RGL>RGLVL D ERR("Invalid nesting",RGLN) Q
44 S RGLVL=RGL,RGFN=+$P(RGBM(RGLVL),U,4)
45 S RGFLD=$$FLD(RGLBL,RGFN)
46 S RGZ=+$P($G(^DD(RGFN,RGFLD,0)),U,2)
47 I RGZ D Q:RGST
48 .S RGLVL=RGLVL+1,RGFN=RGZ,RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL-1),"+"_RGFN)
49 .I +RGBM(RGLVL)<0 D ERR("Error access subfile entry",RGLBL) Q
50 .S RGFLD=$$FLD(.01,RGFN)
51 I 'RGFLD D ERR("Unknown field",RGLBL) Q
52 I 'RGWP,RGLN="" Q
53 ;S:RGLN="+" RGLN=U_$TR($P(RGBM(RGLVL),U,2),"|",",")_"$C(1))",RGLN=1+$O(@RGLN,-1)\1
54 I RGFLD=.01!'RGBM(RGLVL)!RGWP D Q
55 .I 'RGWP,RGFLD'=.01 D ERR("First field is not primary index",RGLBL) Q
56 .I 'RGWP D
57 ..S RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"="_RGLN)
58 ..S:+RGBM(RGLVL)'>0 RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"="_$$UP^XLFSTR(RGLN))
59 .S:+RGBM(RGLVL)'>0!RGWP RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),$S(RGLN="@"&'RGWP:RGLN,1:"~LX;.01///^S X=RGLN"))
60 .I +RGBM(RGLVL)'>0,RGLN'="@" D ERR("Error adding entry",RGLN)
61 S RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"<;"_RGFLD_"///^S X=RGLN")
62 D:+RGBM(RGLVL)'>0 ERR("Error writing to field",RGLBL)
63 Q
64FILE(RGFN) ;
65 K RGBM
66 S RGBM(1)=$$ENTRY^RGUTDIC(RGFN),RGLVL=1
67 I +RGBM(1)'<0 S RGFN=+$P(RGBM(1),U,4)
68 E D ERR("Error accessing database",RGFN)
69 Q RGFN
70FLD(RGNM,RGFN) ;
71 N RGZ
72 S RGZ=$S(RGNM="":.01,RGNM=+RGNM:RGNM,1:+$O(^DD(RGFN,"B",RGNM,0)))
73 I '$D(^DD(RGFN,RGZ,0)) S RGZ=0
74 E S RGWP=$P(^(0),U,2)["W"
75 Q RGZ
76ERR(RGMSG,RGX) ;
77 S RGST=RGC_U_RGMSG_$S($D(RGX):": "_RGX,1:"")
78 W:RGTRACE=2 RGC_": "_$P(RGST,U,2,999),!
79 Q
Note: See TracBrowser for help on using the repository browser.