Return to DIFROMS3.m CVS log

Up to [Coherent Logic Development] / freem_fileman

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