RGUTIMP ;CAIRO/DKM - Import text into FileMan file;04-Sep-1998 11:26;DKM
;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
;=================================================================
; Imports data from a specially formatted text file into a
; FileMan file.
; Inputs:
; RGINP = Full input file or global specification.
; RGTRACE= If nonzero, generates a debug trace.
; Outputs:
; Returns status code^status message. Status code of 0 means
; successful completion.
;=================================================================
ENTRY(RGINP,RGTRACE) ;
N RGLN,RGFN,RGLVL,RGBM,RGC,RGLBL,RGQT,RGST,RGIO,RGGBL
S @$$TRAP^RGZOSF("ERROR^RGUTIMP")
S RGFN=0,RGLVL=-1,RGTRACE=+$G(RGTRACE),RGST=0,RGIO=$I,U="^",RGC=0,RGGBL=$E(RGINP)=U
I RGGBL S RGINP=$$CREF^DILF(RGINP)
E D OPEN^RGZOSF(.RGINP,"R")
F Q:$$READ D Q:RGST
.U RGIO
.W:RGTRACE=1 RGC,*13
.W:RGTRACE=2 RGC_": ",$$TRUNC^RGUT(RGLN,$G(IOM,80)-$X-2),!
.D DOIT(RGLN)
D:'RGGBL CLOSE^RGZOSF(.RGINP)
Q RGST
READ() I 'RGGBL S RGC=RGC+1 Q $$READ^RGZOSF(.RGLN,RGINP)
S RGC=$O(@RGINP@(RGC))
Q:'RGC 1
I $D(@RGINP@(RGC))#2 S RGLN=@RGINP@(RGC) Q 0
I $D(@RGINP@(RGC,0))#2 S RGLN=@RGINP@(RGC,0) Q 0
Q 1
ERROR D ERR("Fatal error",$$EC^%ZOSV)
Q RGST
DOIT(RGLN) ;
N RGZ,RGL,RGFLD,RGWP
S RGLN=$$TRIM^RGUT(RGLN)
I ";"[$E(RGLN) W:RGTRACE=3 $P(RGLN,";",2,999),! Q
F RGL=0:1 Q:$E(RGLN,RGL+1)'="."
S RGLN=$E(RGLN,RGL+1,999)
I RGLN'[":" D ERR("Missing label",RGLN) Q
S RGLBL=$$TRIM^RGUT($P(RGLN,":")),RGLN=$$TRIM^RGUT($P(RGLN,":",2,999))
I 'RGL S RGFN=$$FILE(RGLN) Q
I RGL>RGLVL D ERR("Invalid nesting",RGLN) Q
S RGLVL=RGL,RGFN=+$P(RGBM(RGLVL),U,4)
S RGFLD=$$FLD(RGLBL,RGFN)
S RGZ=+$P($G(^DD(RGFN,RGFLD,0)),U,2)
I RGZ D Q:RGST
.S RGLVL=RGLVL+1,RGFN=RGZ,RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL-1),"+"_RGFN)
.I +RGBM(RGLVL)<0 D ERR("Error access subfile entry",RGLBL) Q
.S RGFLD=$$FLD(.01,RGFN)
I 'RGFLD D ERR("Unknown field",RGLBL) Q
I 'RGWP,RGLN="" Q
;S:RGLN="+" RGLN=U_$TR($P(RGBM(RGLVL),U,2),"|",",")_"$C(1))",RGLN=1+$O(@RGLN,-1)\1
I RGFLD=.01!'RGBM(RGLVL)!RGWP D Q
.I 'RGWP,RGFLD'=.01 D ERR("First field is not primary index",RGLBL) Q
.I 'RGWP D
..S RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"="_RGLN)
..S:+RGBM(RGLVL)'>0 RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"="_$$UP^XLFSTR(RGLN))
.S:+RGBM(RGLVL)'>0!RGWP RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),$S(RGLN="@"&'RGWP:RGLN,1:"~LX;.01///^S X=RGLN"))
.I +RGBM(RGLVL)'>0,RGLN'="@" D ERR("Error adding entry",RGLN)
S RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"<"_RGFLD_"///^S X=RGLN")
D:+RGBM(RGLVL)'>0 ERR("Error writing to field",RGLBL)
Q
FILE(RGFN) ;
K RGBM
S RGBM(1)=$$ENTRY^RGUTDIC(RGFN),RGLVL=1
I +RGBM(1)'<0 S RGFN=+$P(RGBM(1),U,4)
E D ERR("Error accessing database",RGFN)
Q RGFN
FLD(RGNM,RGFN) ;
N RGZ
S RGZ=$S(RGNM="":.01,RGNM=+RGNM:RGNM,1:+$O(^DD(RGFN,"B",RGNM,0)))
I '$D(^DD(RGFN,RGZ,0)) S RGZ=0
E S RGWP=$P(^(0),U,2)["W"
Q RGZ
ERR(RGMSG,RGX) ;
S RGST=RGC_U_RGMSG_$S($D(RGX):": "_RGX,1:"")
W:RGTRACE=2 RGC_": "_$P(RGST,U,2,999),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGUTIMP 3071 printed Dec 13, 2024@02:37:15 Page 2
RGUTIMP ;CAIRO/DKM - Import text into FileMan file;04-Sep-1998 11:26;DKM
+1 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
+2 ;=================================================================
+3 ; Imports data from a specially formatted text file into a
+4 ; FileMan file.
+5 ; Inputs:
+6 ; RGINP = Full input file or global specification.
+7 ; RGTRACE= If nonzero, generates a debug trace.
+8 ; Outputs:
+9 ; Returns status code^status message. Status code of 0 means
+10 ; successful completion.
+11 ;=================================================================
ENTRY(RGINP,RGTRACE) ;
+1 NEW RGLN,RGFN,RGLVL,RGBM,RGC,RGLBL,RGQT,RGST,RGIO,RGGBL
+2 SET @$$TRAP^RGZOSF("ERROR^RGUTIMP")
+3 SET RGFN=0
SET RGLVL=-1
SET RGTRACE=+$GET(RGTRACE)
SET RGST=0
SET RGIO=$IO
SET U="^"
SET RGC=0
SET RGGBL=$EXTRACT(RGINP)=U
+4 IF RGGBL
SET RGINP=$$CREF^DILF(RGINP)
+5 IF '$TEST
DO OPEN^RGZOSF(.RGINP,"R")
+6 FOR
if $$READ
QUIT
Begin DoDot:1
+7 USE RGIO
+8 if RGTRACE=1
WRITE RGC,*13
+9 if RGTRACE=2
WRITE RGC_": ",$$TRUNC^RGUT(RGLN,$GET(IOM,80)-$X-2),!
+10 DO DOIT(RGLN)
End DoDot:1
if RGST
QUIT
+11 if 'RGGBL
DO CLOSE^RGZOSF(.RGINP)
+12 QUIT RGST
READ() IF 'RGGBL
SET RGC=RGC+1
QUIT $$READ^RGZOSF(.RGLN,RGINP)
+1 SET RGC=$ORDER(@RGINP@(RGC))
+2 if 'RGC
QUIT 1
+3 IF $DATA(@RGINP@(RGC))#2
SET RGLN=@RGINP@(RGC)
QUIT 0
+4 IF $DATA(@RGINP@(RGC,0))#2
SET RGLN=@RGINP@(RGC,0)
QUIT 0
+5 QUIT 1
ERROR DO ERR("Fatal error",$$EC^%ZOSV)
+1 QUIT RGST
DOIT(RGLN) ;
+1 NEW RGZ,RGL,RGFLD,RGWP
+2 SET RGLN=$$TRIM^RGUT(RGLN)
+3 IF ";"[$EXTRACT(RGLN)
if RGTRACE=3
WRITE $PIECE(RGLN,";",2,999),!
QUIT
+4 FOR RGL=0:1
if $EXTRACT(RGLN,RGL+1)'="."
QUIT
+5 SET RGLN=$EXTRACT(RGLN,RGL+1,999)
+6 IF RGLN'[":"
DO ERR("Missing label",RGLN)
QUIT
+7 SET RGLBL=$$TRIM^RGUT($PIECE(RGLN,":"))
SET RGLN=$$TRIM^RGUT($PIECE(RGLN,":",2,999))
+8 IF 'RGL
SET RGFN=$$FILE(RGLN)
QUIT
+9 IF RGL>RGLVL
DO ERR("Invalid nesting",RGLN)
QUIT
+10 SET RGLVL=RGL
SET RGFN=+$PIECE(RGBM(RGLVL),U,4)
+11 SET RGFLD=$$FLD(RGLBL,RGFN)
+12 SET RGZ=+$PIECE($GET(^DD(RGFN,RGFLD,0)),U,2)
+13 IF RGZ
Begin DoDot:1
+14 SET RGLVL=RGLVL+1
SET RGFN=RGZ
SET RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL-1),"+"_RGFN)
+15 IF +RGBM(RGLVL)<0
DO ERR("Error access subfile entry",RGLBL)
QUIT
+16 SET RGFLD=$$FLD(.01,RGFN)
End DoDot:1
if RGST
QUIT
+17 IF 'RGFLD
DO ERR("Unknown field",RGLBL)
QUIT
+18 IF 'RGWP
IF RGLN=""
QUIT
+19 ;S:RGLN="+" RGLN=U_$TR($P(RGBM(RGLVL),U,2),"|",",")_"$C(1))",RGLN=1+$O(@RGLN,-1)\1
+20 IF RGFLD=.01!'RGBM(RGLVL)!RGWP
Begin DoDot:1
+21 IF 'RGWP
IF RGFLD'=.01
DO ERR("First field is not primary index",RGLBL)
QUIT
+22 IF 'RGWP
Begin DoDot:2
+23 SET RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"="_RGLN)
+24 if +RGBM(RGLVL)'>0
SET RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"="_$$UP^XLFSTR(RGLN))
End DoDot:2
+25 if +RGBM(RGLVL)'>0!RGWP
SET RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),$SELECT(RGLN="@"&'RGWP:RGLN,1:"~LX;.01///^S X=RGLN"))
+26 IF +RGBM(RGLVL)'>0
IF RGLN'="@"
DO ERR("Error adding entry",RGLN)
End DoDot:1
QUIT
+27 SET RGBM(RGLVL)=$$ENTRY^RGUTDIC(RGBM(RGLVL),"<"_RGFLD_"///^S X=RGLN")
+28 if +RGBM(RGLVL)'>0
DO ERR("Error writing to field",RGLBL)
+29 QUIT
FILE(RGFN) ;
+1 KILL RGBM
+2 SET RGBM(1)=$$ENTRY^RGUTDIC(RGFN)
SET RGLVL=1
+3 IF +RGBM(1)'<0
SET RGFN=+$PIECE(RGBM(1),U,4)
+4 IF '$TEST
DO ERR("Error accessing database",RGFN)
+5 QUIT RGFN
FLD(RGNM,RGFN) ;
+1 NEW RGZ
+2 SET RGZ=$SELECT(RGNM="":.01,RGNM=+RGNM:RGNM,1:+$ORDER(^DD(RGFN,"B",RGNM,0)))
+3 IF '$DATA(^DD(RGFN,RGZ,0))
SET RGZ=0
+4 IF '$TEST
SET RGWP=$PIECE(^(0),U,2)["W"
+5 QUIT RGZ
ERR(RGMSG,RGX) ;
+1 SET RGST=RGC_U_RGMSG_$SELECT($DATA(RGX):": "_RGX,1:"")
+2 if RGTRACE=2
WRITE RGC_": "_$PIECE(RGST,U,2,999),!
+3 QUIT
