CIAUIMP ;MSC/IND/DKM - Import text into FileMan file;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Imports data from a specially formatted text file into a
; FileMan file.
; Inputs:
; CIAINP = Full input file or global specification.
; CIATRACE= If nonzero, generates a debug trace.
; Outputs:
; Returns status code^status message. Status code of 0 means
; successful completion.
;=================================================================
ENTRY(CIAINP,CIATRACE) ;
N CIALN,CIAFN,CIALVL,CIABM,CIAC,CIALBL,CIAQT,CIAST,CIAIO,CIAGBL
S @$$TRAP^CIAUOS("ERROR^CIAUIMP")
S CIAFN=0,CIALVL=-1,CIATRACE=+$G(CIATRACE),CIAST=0,CIAIO=$I,U="^",CIAC=0,CIAGBL=$E(CIAINP)=U
I CIAGBL S CIAINP=$$CREF^DILF(CIAINP)
E D OPEN^CIAUOS(.CIAINP,"R")
F Q:$$READ D Q:CIAST
.U CIAIO
.W:CIATRACE=1 CIAC,*13
.W:CIATRACE=2 CIAC_": ",$$TRUNC^CIAU(CIALN,$G(IOM,80)-$X-2),!
.D DOIT(CIALN)
D:'CIAGBL CLOSE^CIAUOS(.CIAINP)
Q CIAST
READ() I 'CIAGBL S CIAC=CIAC+1 Q $$READ^CIAUOS(.CIALN,CIAINP)
S CIAC=$O(@CIAINP@(CIAC))
Q:'CIAC 1
I $D(@CIAINP@(CIAC))#2 S CIALN=@CIAINP@(CIAC) Q 0
I $D(@CIAINP@(CIAC,0))#2 S CIALN=@CIAINP@(CIAC,0) Q 0
Q 1
ERROR D ERR("Fatal error",$$EC^%ZOSV)
Q CIAST
DOIT(CIALN) ;
N CIAZ,CIAL,CIAFLD,CIAWP
S CIALN=$$TRIM^CIAU(CIALN)
I ";"[$E(CIALN) W:CIATRACE=3 $P(CIALN,";",2,999),! Q
F CIAL=0:1 Q:$E(CIALN,CIAL+1)'="."
S CIALN=$E(CIALN,CIAL+1,999)
I CIALN'[":" D ERR("Missing label",CIALN) Q
S CIALBL=$$TRIM^CIAU($P(CIALN,":")),CIALN=$$TRIM^CIAU($P(CIALN,":",2,999))
I 'CIAL S CIAFN=$$FILE(CIALN) Q
I CIAL>CIALVL D ERR("Invalid nesting",CIALN) Q
S CIALVL=CIAL,CIAFN=+$P(CIABM(CIALVL),U,4)
S CIAFLD=$$FLD(CIALBL,CIAFN)
S CIAZ=+$P($G(^DD(CIAFN,CIAFLD,0)),U,2)
I CIAZ D Q:CIAST
.S CIALVL=CIALVL+1,CIAFN=CIAZ,CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL-1),"+"_CIAFN)
.I +CIABM(CIALVL)<0 D ERR("Error access subfile entry",CIALBL) Q
.S CIAFLD=$$FLD(.01,CIAFN)
I 'CIAFLD D ERR("Unknown field",CIALBL) Q
I 'CIAWP,CIALN="" Q
;S:CIALN="+" CIALN=U_$TR($P(CIABM(CIALVL),U,2),"|",",")_"$C(1))",CIALN=1+$O(@CIALN,-1)\1
I CIAFLD=.01!'CIABM(CIALVL)!CIAWP D Q
.I 'CIAWP,CIAFLD'=.01 D ERR("First field is not primary index",CIALBL) Q
.I 'CIAWP D
..S CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),"="_CIALN)
..S:+CIABM(CIALVL)'>0 CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),"="_$$UP^XLFSTR(CIALN))
.S:+CIABM(CIALVL)'>0!CIAWP CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),$S(CIALN="@"&'CIAWP:CIALN,1:"~LX;.01///^S X=CIALN"))
.I +CIABM(CIALVL)'>0,CIALN'="@" D ERR("Error adding entry",CIALN)
S CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),"<"_CIAFLD_"///^S X=CIALN")
D:+CIABM(CIALVL)'>0 ERR("Error writing to field",CIALBL)
Q
FILE(CIAFN) ;
K CIABM
S CIABM(1)=$$ENTRY^CIAUDIC(CIAFN),CIALVL=1
I +CIABM(1)'<0 S CIAFN=+$P(CIABM(1),U,4)
E D ERR("Error accessing database",CIAFN)
Q CIAFN
FLD(CIANM,CIAFN) ;
N CIAZ
S CIAZ=$S(CIANM="":.01,CIANM=+CIANM:CIANM,1:+$O(^DD(CIAFN,"B",CIANM,0)))
I '$D(^DD(CIAFN,CIAZ,0)) S CIAZ=0
E S CIAWP=$P(^(0),U,2)["W"
Q CIAZ
ERR(CIAMSG,CIAX) ;
S CIAST=CIAC_U_CIAMSG_$S($D(CIAX):": "_CIAX,1:"")
W:CIATRACE=2 CIAC_": "_$P(CIAST,U,2,999),!
Q
CIAUIMP ;MSC/IND/DKM - Import text into FileMan file;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Imports data from a specially formatted text file into a
+5 ; FileMan file.
+6 ; Inputs:
+7 ; CIAINP = Full input file or global specification.
+8 ; CIATRACE= If nonzero, generates a debug trace.
+9 ; Outputs:
+10 ; Returns status code^status message. Status code of 0 means
+11 ; successful completion.
+12 ;=================================================================
ENTRY(CIAINP,CIATRACE) ;
+1 NEW CIALN,CIAFN,CIALVL,CIABM,CIAC,CIALBL,CIAQT,CIAST,CIAIO,CIAGBL
+2 SET @$$TRAP^CIAUOS("ERROR^CIAUIMP")
+3 SET CIAFN=0
SET CIALVL=-1
SET CIATRACE=+$GET(CIATRACE)
SET CIAST=0
SET CIAIO=$IO
SET U="^"
SET CIAC=0
SET CIAGBL=$EXTRACT(CIAINP)=U
+4 IF CIAGBL
SET CIAINP=$$CREF^DILF(CIAINP)
+5 IF '$TEST
DO OPEN^CIAUOS(.CIAINP,"R")
+6 FOR
IF $$READ
QUIT
Begin DoDot:1
+7 USE CIAIO
+8 IF CIATRACE=1
WRITE CIAC,*13
+9 IF CIATRACE=2
WRITE CIAC_": ",$$TRUNC^CIAU(CIALN,$GET(IOM,80)-$X-2),!
+10 DO DOIT(CIALN)
End DoDot:1
IF CIAST
QUIT
+11 IF 'CIAGBL
DO CLOSE^CIAUOS(.CIAINP)
+12 QUIT CIAST
READ() IF 'CIAGBL
SET CIAC=CIAC+1
QUIT $$READ^CIAUOS(.CIALN,CIAINP)
+1 SET CIAC=$ORDER(@CIAINP@(CIAC))
+2 IF 'CIAC
QUIT 1
+3 IF $DATA(@CIAINP@(CIAC))#2
SET CIALN=@CIAINP@(CIAC)
QUIT 0
+4 IF $DATA(@CIAINP@(CIAC,0))#2
SET CIALN=@CIAINP@(CIAC,0)
QUIT 0
+5 QUIT 1
ERROR DO ERR("Fatal error",$$EC^%ZOSV)
+1 QUIT CIAST
DOIT(CIALN) ;
+1 NEW CIAZ,CIAL,CIAFLD,CIAWP
+2 SET CIALN=$$TRIM^CIAU(CIALN)
+3 IF ";"[$EXTRACT(CIALN)
IF CIATRACE=3
WRITE $PIECE(CIALN,";",2,999),!
QUIT
+4 FOR CIAL=0:1
IF $EXTRACT(CIALN,CIAL+1)'="."
QUIT
+5 SET CIALN=$EXTRACT(CIALN,CIAL+1,999)
+6 IF CIALN'[":"
DO ERR("Missing label",CIALN)
QUIT
+7 SET CIALBL=$$TRIM^CIAU($PIECE(CIALN,":"))
SET CIALN=$$TRIM^CIAU($PIECE(CIALN,":",2,999))
+8 IF 'CIAL
SET CIAFN=$$FILE(CIALN)
QUIT
+9 IF CIAL>CIALVL
DO ERR("Invalid nesting",CIALN)
QUIT
+10 SET CIALVL=CIAL
SET CIAFN=+$PIECE(CIABM(CIALVL),U,4)
+11 SET CIAFLD=$$FLD(CIALBL,CIAFN)
+12 SET CIAZ=+$PIECE($GET(^DD(CIAFN,CIAFLD,0)),U,2)
+13 IF CIAZ
Begin DoDot:1
+14 SET CIALVL=CIALVL+1
SET CIAFN=CIAZ
SET CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL-1),"+"_CIAFN)
+15 IF +CIABM(CIALVL)<0
DO ERR("Error access subfile entry",CIALBL)
QUIT
+16 SET CIAFLD=$$FLD(.01,CIAFN)
End DoDot:1
IF CIAST
QUIT
+17 IF 'CIAFLD
DO ERR("Unknown field",CIALBL)
QUIT
+18 IF 'CIAWP
IF CIALN=""
QUIT
+19 ;S:CIALN="+" CIALN=U_$TR($P(CIABM(CIALVL),U,2),"|",",")_"$C(1))",CIALN=1+$O(@CIALN,-1)\1
+20 IF CIAFLD=.01!'CIABM(CIALVL)!CIAWP
Begin DoDot:1
+21 IF 'CIAWP
IF CIAFLD'=.01
DO ERR("First field is not primary index",CIALBL)
QUIT
+22 IF 'CIAWP
Begin DoDot:2
+23 SET CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),"="_CIALN)
+24 IF +CIABM(CIALVL)'>0
SET CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),"="_$$UP^XLFSTR(CIALN))
End DoDot:2
+25 IF +CIABM(CIALVL)'>0!CIAWP
SET CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),$SELECT(CIALN="@"&'CIAWP:CIALN,1:"~LX;.01///^S X=CIALN"))
+26 IF +CIABM(CIALVL)'>0
IF CIALN'="@"
DO ERR("Error adding entry",CIALN)
End DoDot:1
QUIT
+27 SET CIABM(CIALVL)=$$ENTRY^CIAUDIC(CIABM(CIALVL),"<"_CIAFLD_"///^S X=CIALN")
+28 IF +CIABM(CIALVL)'>0
DO ERR("Error writing to field",CIALBL)
+29 QUIT
FILE(CIAFN) ;
+1 KILL CIABM
+2 SET CIABM(1)=$$ENTRY^CIAUDIC(CIAFN)
SET CIALVL=1
+3 IF +CIABM(1)'<0
SET CIAFN=+$PIECE(CIABM(1),U,4)
+4 IF '$TEST
DO ERR("Error accessing database",CIAFN)
+5 QUIT CIAFN
FLD(CIANM,CIAFN) ;
+1 NEW CIAZ
+2 SET CIAZ=$SELECT(CIANM="":.01,CIANM=+CIANM:CIANM,1:+$ORDER(^DD(CIAFN,"B",CIANM,0)))
+3 IF '$DATA(^DD(CIAFN,CIAZ,0))
SET CIAZ=0
+4 IF '$TEST
SET CIAWP=$PIECE(^(0),U,2)["W"
+5 QUIT CIAZ
ERR(CIAMSG,CIAX) ;
+1 SET CIAST=CIAC_U_CIAMSG_$SELECT($DATA(CIAX):": "_CIAX,1:"")
+2 IF CIATRACE=2
WRITE CIAC_": "_$PIECE(CIAST,U,2,999),!
+3 QUIT
