Return to DIFROMS1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Initial revision

DIFROMS1	;SFISC/DCL-MOVE DD TO TARGET ARRAY;11:00 AM  30 Nov 1994;
	;;21.0;VA FileMan;;Dec 28, 1994
	;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
	..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
	Q
ERR(X)	D BLD^DIALOG($P($T(ERR+X),";",5)) Q
	;;FIA Array Does Not Exist;1;9501
	;;FIA File Number Invalid;2;9502