Return to DIFROMS1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIFROMS1.m, revision 1.1

1.1     ! snw         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