Return to DIFROMS1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIFROMS1.m, revision 1.1.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