Return to DIFROMS3.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Annotation of freem_fileman/USER/DIFROMS3.m, revision 1.1

1.1     ! snw         1: DIFROMS3       ;SFISC/DCL- DATA TO DISTRIBUTION ARRAY;02:37 PM  18 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(2) Q
        !             8:        G:$G(DIFRFILE) FILE
        !             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(5) Q  ;  * * * * PHASING OUT * * * *
        !            12: FILE   N DIFRS,DIFRSCR,DIFRDA,DIFROOT,DIFRRLR,DIFR01,DIFRPR,DIFRDNSC,DIFRFRV,DIFRFRVX
        !            13:        N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFR2DD,DIFRNODE,DIFRFELD,DIFRPCE,DIFRIENS,DIFRDD0
        !            14:        S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFRPR=$TR($P(DIFR01,"^",5),"Y","y")="y"
        !            15:        I $TR($P(DIFR01,"^",7),"Y","y")'="y" Q
        !            16:        I DIFRPR D PGL^DIFROMSP(DIFRFILE,"",DIFRTA)
        !            17:        S DIFRS=$G(@DIFRFIA@(DIFRFILE,0,11))]"",DIFRSCR=$G(^(11))
        !            18:        S DIFROOT=$NA(@($$ROOT^DILFD(DIFRFILE,"",1))),DIFRDA=0  ;$NA/trans gbl $Q
        !            19:        S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRO"))
        !            20:        S:DIFRRLR="" DIFRRLR=DIFROOT
        !            21:        I $D(@DIFRRLR)'>9 D ERR(4) Q
        !            22:        N Y
        !            23:        F  S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0  D
        !            24:        .I '$D(@DIFROOT@(DIFRDA,0)) D  Q
        !            25:        ..N DIFRERR S DIFRERR(1)=DIFRDA,DIFRERR(2)=DIFRFILE
        !            26:        ..D BLD^DIALOG(9513,.DIFRERR)
        !            27:        ..Q
        !            28:        .I DIFRS,$D(@DIFRRLR@(DIFRDA,0)) S Y=DIFRDA X DIFRSCR Q:'$T  ;set *NAKED* and *Y*
        !            29:        .M @DIFRTA@("DATA",DIFRFILE,DIFRDA)=@DIFROOT@(DIFRDA)
        !            30:        .Q
        !            31:        S DIFRQ=$NA(@DIFRTA@("DATA",DIFRFILE))  ;$NA/trans gbl/$Q
        !            32:        S DIFRTART=$$OREF^DILF(DIFRQ)
        !            33:        F  S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="")  D:$P(DIFRQ,DIFRTART,2,99)[""""!(DIFRPR)
        !            34:        .K R1
        !            35:        .S DIFRK=1
        !            36:        .S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
        !            37:        .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)=G,R1=R1+1,C=C+($L(G,",")-1) I 'G,G'?1"0".E,R1#2 S DIFRK=DIFRTART_$P(R2,",",1,I)_")" Q
        !            38:        .I DIFRPR,DIFRK,'(R1#2) D  Q  ;RESOLVE POINTERS
        !            39:        ..D  Q:DIFR2DD'>0
        !            40:        ...I R1'>3 S DIFR2DD=DIFRFILE Q
        !            41:        ...S R3=""
        !            42:        ...F I=0:1:R1-3 S R3=R3_R1(I)_","
        !            43:        ...S DIFR2DD=+$P($G(@(DIFRTART_R3_"0)")),"^",2)
        !            44:        ...Q
        !            45:        ..S DIFRNODE=R1($O(R1(""),-1)),DIFRDNSC=R2
        !            46:        ..Q:'$D(@DIFRTA@("PGL",DIFR2DD,DIFRNODE))
        !            47:        ..S DIFRPCE=0
        !            48:        ..F  S DIFRPCE=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE)) Q:DIFRPCE=""  D:DIFRPCE>0
        !            49:        ...Q:$P(@DIFRQ,"^",DIFRPCE)=""
        !            50:        ...S DIFRFELD=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE,"")),(I,DIFRIENS)=""
        !            51:        ...;CREATE IENS * * * * * * * * * * * * * * * * *
        !            52:        ...F  S I=$O(R1(I),-1) Q:I=""  S:'(I#2) DIFRIENS=DIFRIENS_R1(I)_","
        !            53:        ...S DIFRDD0=^DD(DIFR2DD,DIFRFELD,0)
        !            54:        ...S DIFRFRV=$$GET1^DIQ(DIFR2DD,DIFRIENS,DIFRFELD)
        !            55:        ...I DIFRFRV']"" D  Q
        !            56:        ....N DIFRERR
        !            57:        ....S DIFRERR(1)=DIFR2DD,DIFRERR(2)=DIFRIENS,DIFRERR(3)=DIFRFELD
        !            58:        ....D BLD^DIALOG(9514,.DIFRERR)
        !            59:        ....Q
        !            60:        ...S DIFRFRVX="FRV1"
        !            61:        ...; If .01 field on file level is a pointer use "FRV0" subscript
        !            62:        ...;I R1'>3,DIFRPCE=1,DIFRNODE=0 S DIFRFRVX="FRV0"
        !            63:        ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE)=DIFRFRV
        !            64:        ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE,"F")=$S($P(DIFRDD0,"^",2)["P":";"_$P(DIFRDD0,"^",3),$P(DIFRDD0,"^",2)["V":"1;"_$P($P(@DIFRQ,"^",DIFRPCE),";",2),1:"")
        !            65:        ...Q
        !            66:        ..Q
        !            67:        ..;Q:IF HEADER NODE OR IF NOT DATA NODE THEN FIND DD AND CHECK
        !            68:        ..;  IF DD#,"PGL",DATA NODE EXIST IF SO GET PIECE AND FIELD
        !            69:        ..;  AND SET IT UP INTO A STRUCTURE ; ALL RESOLVED; .01,IDs AND PTR.
        !            70:        ..;IT WAS DECIDED NOT TO RESOLVE .01 AND ID POINTERS
        !            71:        ..Q
        !            72:        .Q:DIFRK
        !            73:        .K @DIFRK
        !            74:        .Q
        !            75:        Q
        !            76:        ;
        !            77: ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y  D BLD^DIALOG(Y) Q
        !            78:        ;;FIA Node Is Set To "No Data";1;9509
        !            79:        ;;FIA Array Does Not Exist;2;9501
        !            80:        ;;;3;
        !            81:        ;;Records Do Not Exist;4;9510
        !            82:        ;;FIA File Number Invalid;5;9502