Return to DIFROMS1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIFROMS1	;SFISC/DCL-MOVE DD TO TARGET ARRAY;11:00 AM  30 Nov 1994;
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	;
    5: 	Q
    6: EN	;
    7: 	I '$D(@DIFRFIA) D ERR(1) Q
    8: 	G:$G(DIFRFILE) FCHK
    9: 	S DIFRFILE=0 F  S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0  D FILE
   10: 	Q
   11: FCHK	I '$D(@DIFRFIA@(DIFRFILE)) D ERR(2) Q
   12: FILE	N DSEC,DIFRD,DIFRX,DIFR01,DIFRFDD
   13: 	N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFRPFD
   14: 	S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1))
   15: 	S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p"
   16: 	S DSEC=$TR($P(DIFR01,"^",2),"y","Y")="Y"
   17: 	S DIFRPFD=@DIFRFIA@(DIFRFILE,DIFRFILE)=0
   18: 	I DIFRFDD!DIFRPFD D
   19: 	.M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%")=^DIC(DIFRFILE,"%")
   20: 	.M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%D")=^DIC(DIFRFILE,"%D")
   21: 	.S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0)=$P(^DIC(DIFRFILE,0),"^",1,2)
   22: 	.S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0,"GL")=^DIC(DIFRFILE,0,"GL")
   23: 	.S @DIFRTA@("^DIC",DIFRFILE,"B",@DIFRFIA@(DIFRFILE),DIFRFILE)=""
   24: 	.Q
   25: 	I DSEC,(DIFRFDD!(DIFRPFD)) D
   26: 	.D XY^%RCR("^DIC("_DIFRFILE_",0,",$$OREF^DILF($NA(@DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0))))
   27: 	.K @DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0,"GL")
   28: 	.Q
   29: 	S DIFRD=0
   30: 	;              * * Go through each DD and sub-DD * *
   31: 	F  S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0  S DIFRPFD=^(DIFRD)=0 D
   32: 	.S DIFRX=0
   33: 	.;         * * Merge each field DD to transport structure * *
   34: 	.;F  S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0  I $D(@DIFRFIA@(DIFRFILE,DIFRD))<9!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
   35: 	.F  S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0  I DIFRPFD!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
   36: 	..M @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX)=^DD(DIFRD,DIFRX)
   37: 	..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
   38: 	...I DSEC S @DIFRTA@("SEC","^DD",DIFRFILE,DIFRD,DIFRX,SEC)=^DD(DIFRD,DIFRX,SEC)
   39: 	...K @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX,SEC)
   40: 	...Q
   41: 	..Q
   42: 	.;                * * Clean up x-refs in DDs * *
   43: 	.S DIFRQ=$NA(@DIFRTA@("^DD",DIFRFILE,DIFRD))
   44: 	.S DIFRTART=$$OREF^DILF(DIFRQ)
   45: 	.F  S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="")  D:$P(DIFRQ,DIFRTART,2,99)[""""
   46: 	..S DIFRK=1
   47: 	..S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
   48: 	..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
   49: 	..Q:DIFRK
   50: 	..K @DIFRK
   51: 	..Q
   52: 	.;           * * Build DD 0 node after x-ref clean up * *
   53: 	.;               for full DD or full sub-DD
   54: 	.I DIFRFDD!(DIFRPFD) D
   55: 	..M @DIFRTA@("^DD",DIFRFILE,DIFRD,0)=^DD(DIFRD,0)
   56: 	..K @DIFRTA@("^DD",DIFRFILE,DIFRD,0,"VR")
   57: 	..Q
   58: 	.Q
   59: 	Q
   60: ERR(X)	D BLD^DIALOG($P($T(ERR+X),";",5)) Q
   61: 	;;FIA Array Does Not Exist;1;9501
   62: 	;;FIA File Number Invalid;2;9502