source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIFROMS1.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
RevLine 
[613]1DIFROMS1 ;SFISC/DCL/TKW-MOVE DD TO TARGET ARRAY ;5/5/98 12:59
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6EN ;
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
11FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(2) Q
12FILE 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 ..; If multiple field sent, send ^DD(SUBFILE#,0) and ^("NM",multiple name) for partial DDs
42 ..I 'DIFRPFD D
43 ...N SUBNUM S SUBNUM=$$SUBNUM(DIFRD,DIFRX)
44 ...I 'SUBNUM Q
45 ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0)=^DD(SUBNUM,0)
46 ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0,"NM",$O(^DD(SUBNUM,0,"NM","")))=""
47 ...Q
48 ..Q
49 .; * * Clean up x-refs in DDs * *
50 .S DIFRQ=$NA(@DIFRTA@("^DD",DIFRFILE,DIFRD))
51 .S DIFRTART=$$OREF^DILF(DIFRQ)
52 .F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""
53 ..S DIFRK=1
54 ..S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
55 ..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
56 ..Q:DIFRK
57 ..K @DIFRK
58 ..Q
59 .; * * Build DD 0 node after x-ref clean up * *
60 .; for full DD or full sub-DD
61 .I DIFRFDD!(DIFRPFD) D
62 ..M @DIFRTA@("^DD",DIFRFILE,DIFRD,0)=^DD(DIFRD,0)
63 ..K @DIFRTA@("^DD",DIFRFILE,DIFRD,0,"VR")
64 ..Q
65 .Q
66IXKEY ; Send entries from KEY and INDEX file
67 S DIFRD=0
68 F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
69 . I $O(^DD("IX","B",DIFRD,0)) D DDIXOUT^DIFROMSX(DIFRFILE,DIFRD,DIFRFDD,DIFRTA)
70 . I $O(^DD("KEY","B",DIFRD,0)) D DDKEYOUT^DIFROMSY(DIFRFILE,DIFRD,DIFRTA)
71 . Q
72 Q
73 ;
74 Q
75SUBNUM(F,FD) ;
76 ;Returns 0 if FielD in File is not multiple, otherwise subfile#.
77 N SUBNUM S SUBNUM=+$P($G(^DD(F,FD,0)),U,2)
78 I 'SUBNUM Q 0
79 I $P($G(^DD(SUBNUM,.01,0)),U,2)["W" Q 0
80 Q SUBNUM
81 ;
82ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
83 ;;FIA Array Does Not Exist;1;9501
84 ;;FIA File Number Invalid;2;9502
Note: See TracBrowser for help on using the repository browser.