- 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 Jan 18, 2025@03:38:24 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