85 lines
3.5 KiB
Mathematica
85 lines
3.5 KiB
Mathematica
DIFROMS1 ;SFISC/DCL/TKW-MOVE DD TO TARGET ARRAY ;5/5/98 12:59
|
|
;;22.0;VA FileMan;;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
Q
|
|
EN ;
|
|
I '$D(@DIFRFIA) D ERR(1) Q
|
|
G:$G(DIFRFILE) FCHK
|
|
S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE
|
|
Q
|
|
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(2) Q
|
|
FILE N DSEC,DIFRD,DIFRX,DIFR01,DIFRFDD
|
|
N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFRPFD
|
|
S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1))
|
|
S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p"
|
|
S DSEC=$TR($P(DIFR01,"^",2),"y","Y")="Y"
|
|
S DIFRPFD=@DIFRFIA@(DIFRFILE,DIFRFILE)=0
|
|
I DIFRFDD!DIFRPFD D
|
|
.M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%")=^DIC(DIFRFILE,"%")
|
|
.M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%D")=^DIC(DIFRFILE,"%D")
|
|
.S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0)=$P(^DIC(DIFRFILE,0),"^",1,2)
|
|
.S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0,"GL")=^DIC(DIFRFILE,0,"GL")
|
|
.S @DIFRTA@("^DIC",DIFRFILE,"B",@DIFRFIA@(DIFRFILE),DIFRFILE)=""
|
|
.Q
|
|
I DSEC,(DIFRFDD!(DIFRPFD)) D
|
|
.D XY^%RCR("^DIC("_DIFRFILE_",0,",$$OREF^DILF($NA(@DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0))))
|
|
.K @DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0,"GL")
|
|
.Q
|
|
S DIFRD=0
|
|
; * * Go through each DD and sub-DD * *
|
|
F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 S DIFRPFD=^(DIFRD)=0 D
|
|
.S DIFRX=0
|
|
.; * * Merge each field DD to transport structure * *
|
|
.;F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I $D(@DIFRFIA@(DIFRFILE,DIFRD))<9!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
|
|
.F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I DIFRPFD!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
|
|
..M @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX)=^DD(DIFRD,DIFRX)
|
|
..N SEC F SEC=8,8.5,9 I $D(^DD(DIFRD,DIFRX,SEC)) D:SEC=8 I SEC>8,^(SEC)'="^",$P(^(0),"^",2)'["K",^(SEC)'="@" D
|
|
...I DSEC S @DIFRTA@("SEC","^DD",DIFRFILE,DIFRD,DIFRX,SEC)=^DD(DIFRD,DIFRX,SEC)
|
|
...K @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX,SEC)
|
|
...Q
|
|
..; If multiple field sent, send ^DD(SUBFILE#,0) and ^("NM",multiple name) for partial DDs
|
|
..I 'DIFRPFD D
|
|
...N SUBNUM S SUBNUM=$$SUBNUM(DIFRD,DIFRX)
|
|
...I 'SUBNUM Q
|
|
...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0)=^DD(SUBNUM,0)
|
|
...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0,"NM",$O(^DD(SUBNUM,0,"NM","")))=""
|
|
...Q
|
|
..Q
|
|
.; * * Clean up x-refs in DDs * *
|
|
.S DIFRQ=$NA(@DIFRTA@("^DD",DIFRFILE,DIFRD))
|
|
.S DIFRTART=$$OREF^DILF(DIFRQ)
|
|
.F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""
|
|
..S DIFRK=1
|
|
..S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
|
|
..F I=1:1 Q:I'<C S G=$P(R2,",",F,I) Q:G="" I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1=R1+1,C=C+($L(G,",")-1) I 'G,G'?1"0".E,R1#2 S DIFRK=DIFRTART_$P(R2,",",1,I)_")" Q
|
|
..Q:DIFRK
|
|
..K @DIFRK
|
|
..Q
|
|
.; * * Build DD 0 node after x-ref clean up * *
|
|
.; for full DD or full sub-DD
|
|
.I DIFRFDD!(DIFRPFD) D
|
|
..M @DIFRTA@("^DD",DIFRFILE,DIFRD,0)=^DD(DIFRD,0)
|
|
..K @DIFRTA@("^DD",DIFRFILE,DIFRD,0,"VR")
|
|
..Q
|
|
.Q
|
|
IXKEY ; Send entries from KEY and INDEX file
|
|
S DIFRD=0
|
|
F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
|
|
. I $O(^DD("IX","B",DIFRD,0)) D DDIXOUT^DIFROMSX(DIFRFILE,DIFRD,DIFRFDD,DIFRTA)
|
|
. I $O(^DD("KEY","B",DIFRD,0)) D DDKEYOUT^DIFROMSY(DIFRFILE,DIFRD,DIFRTA)
|
|
. Q
|
|
Q
|
|
;
|
|
Q
|
|
SUBNUM(F,FD) ;
|
|
;Returns 0 if FielD in File is not multiple, otherwise subfile#.
|
|
N SUBNUM S SUBNUM=+$P($G(^DD(F,FD,0)),U,2)
|
|
I 'SUBNUM Q 0
|
|
I $P($G(^DD(SUBNUM,.01,0)),U,2)["W" Q 0
|
|
Q SUBNUM
|
|
;
|
|
ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
|
|
;;FIA Array Does Not Exist;1;9501
|
|
;;FIA File Number Invalid;2;9502
|