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

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

initial load of WorldVistAEHR

File size: 4.9 KB
Line 
1DITR1 ;SFISC/GFT-FIND ENTRY MATCHES ;9:20 AM 15 Jun 2001
2 ;;22.0;VA FileMan;**41**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 S W=DMRG,X=$P(Z,U),%=DFL\2,Y=@("D"_%),A=1 S:$G(DIFRDKP) DIFRNOAD=$D(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01,0))
5 N DIMATCH S DIMATCH=0
6 G WORD:$P(^DD(DDT(DTL),.01,0),U,2)["W",Q:X="",ON:'W
7 S V="" N DIKEY S DIKEY=$O(^DD("KEY","AP",DDT(DTL),"P",0))
8 I DIKEY S A=0 D MATCHKEY(DIKEY,.V,.A,.DIMATCH) Q:A
9 K DINUM I ^DD(DDT(DTL),.01,0)["DINUM" D Q
10 . I $P(^DD(DDT(DTL),.01,0),U,2)["P" D DINUM Q
11 . S V=X,DA=Y,Y=0,D0=$S($D(D0):D0,$D(DFR):DFR,1:"") D DA
12 . X $P(^DD(DDT(DTL),.01,0),U,5,99)
13 . S X=V,Y=DA I '$D(DINUM) S A=1 Q
14 . S Y=DINUM K DINUM D DINUM Q
15 I $D(^DD(DDT(DTL),.001,0)) D HAS001 Q
16 I DIKEY D Q
17 . I V>0 S Y=V D OLD Q
18 . D NEW Q
19 S V=0 D:'$D(DISYS) OS^DII
20 N DISUBLN,DISUBMX
21 S DISUBLN=$$SUBLN(DDT(DTL))
22 S DISUBMX=+$P(^DD("OS",DISYS,0),U,7) S:'DISUBMX DISUBMX=63
23B I DISUBLN=0 F A=1:1 S V=$O(@(DTO(DTL)_V_")")) G NEW:V'>0 I $D(^(V,0)),$P(^(0),U)=X D MATCH G OLD:'$D(A) S A=1
24 S V=$S($O(@(DTO(DTL)_"""B"",$E(X,1,DISUBMX),V)"))>0:$O(^(V)),1:$O(@(DTO(DTL)_"""B"",$E(X,1,DISUBLN),V)"))) G NEW:V'>0
25 I $D(@(DTO(DTL)_V_",0)")),$P(^(0),X)="" D MATCH G OLD:'$D(A)
26 G B
27 ;
28DA Q:'% S DA(%)=@("D"_Y),Y=Y+1,%=%-1 G DA
29 ;
30DINUM I DIKEY,V>0,V'=Y S A=1 Q
31 I @("'$D("_DTO(DTL)_"Y))") D ADD Q
32 I DIKEY S:Y'=V A=1 D:'A OLD Q
33 S V=Y D MATCH I $D(A) S A=1 Q
34 D OLD Q
35 ;
36HAS001 ; If file has .001 field, .01 and Identifiers/Keys must match
37 I DIKEY,V>0,V'=Y S A=1 Q
38 I @("$G("_DTO(DTL)_"Y,0))']""""") D ADD Q
39 I DIKEY S:Y'=V A=1 D:'A OLD Q
40 S V=Y N DIZERO S DIZERO=@(DTO(DTL)_"Y,0)") I $P(DIZERO,U)'=X S A=1 Q
41 D MATCH I $D(A) S A=1 Q
42 D OLD Q
43 ;
44NEW S W=0
45ON I @("$D("_DTO(DTL)_"Y))") G OLD:W S DITRCNT=$G(DITRCNT)+1,Y=DITRCNT G ON
46ADD G:$G(DIFRDKP) Q:DIFRNOAD S @("V="_DTO(DTL)_"0)"),^(0)=$P(V,U,1,2)_U_Y_U_($P(V,U,4)+1),^(Y,0)=X
47OLD I DIMATCH,$G(DIFRDKPR),$G(DIFRDKPD),'DTL D REPLACE
48 S DTO(DTL+1)=DTO(DTL)_Y_",",DTN(DTL+1)=0,A=0
49Q Q
50 ;
51WORD I $G(DIFRDKP) Q:$D(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01))
52 S @("V=$O("_DTO(DTL)_"0))") X:V'>0!'DKP "K "_$E(DTO(DTL),1,$L(DTO(DTL))-1)_") S:$D("_DFR(DFL)_"0)) "_DTO(DTL)_"0)=^(0)","F V=0:0 S V=$O("_DFR(DFL)_"V)) Q:V'>0 S:$D(^(V,0)) "_DTO(DTL)_"V,0)=^(0)" S (DFL,DTL)=DFL-1 Q
53 ;
54MATCH S A=1 I Y'=V,$D(^DD(DDT(DTL),.001,0)) Q
55 S Y=V,I=.01 N DIOUT,DIFL,DIREC
56I S DIOUT=0
57 F S I=$O(^DD(DDT(DTL),0,"ID",I)) Q:'I D I2 Q:DIOUT
58 Q:DIOUT
59 S DIMATCH=1 K A Q
60 ;
61I2 S DIFL=DDT(DTL),DIREC=I I '$D(^DD(DIFL,DIREC,0))#2 Q:'DIKEY S DIOUT=1 Q
62 K B D P Q:W=""
63 S B=W
64I3 ; Entry point for initial matching on KEY values
65 I DTO S A=$P(A,";",2)_U_$P(A,";",1) D Q:%'>0
66 . F %=0:0 S %=$O(^UTILITY("DITR",$J,DDF(DFL+1),%)) Q:%'>0 Q:^(%)=A
67 E S %=I
68 S DIFL=DDF(DFL+1),DIREC=% I '$D(^DD(DIFL,DIREC,0)) Q:'DIKEY S DIOUT=1 Q
69 D P I W="" Q:'DIKEY S DIOUT=1 Q
70 I W=B!(DIKEY) Q
71 S Y=@("D"_(DFL\2)),DIOUT=1 Q
72 ;
73P S A=$P(^DD(DIFL,DIREC,0),U,4)
74 S %=$P(A,";",2),W=$P(A,";")
75 I @("'$D("_$S('$D(B):DTO(DTL)_"Y,",DFL:DFR(DFL)_"DFN(DFL),",1:DFR(1))_"W))") S W="" Q
76 I % S W=$P(^(W),U,%)
77 E S W=$E(^(W),+$E(W,2,9),$P(W,",",2))
78 Q:DIKEY
79 I %["F",W?.E1L.E F %=1:1:$L(W) I $E(W,%)?1L S W=$E(W,0,%-1)_$C($A(W,%)-32)_$E(W,%+1,999)
80 Q
81 ;
82MATCHKEY(DIKEY,V,A,DIMATCH) ; Match Primary Key fields
83 ; DIKEY=IEN of Primary Key, V=IEN of matching record on target file, A set to 1 if errors are encountered.
84 N %,B,S,W,Y,DIOUT,DIENS,DIFL,DIERR,DIREC,DIVAL
85 S S="",DIOUT=0
86 F S S=$O(^DD("KEY",DIKEY,2,"S",S)) Q:'S!(DIOUT) S DIREC="" F S DIREC=$O(^DD("KEY",DIKEY,2,"S",S,DIREC)) Q:'DIREC!(DIOUT) S DIFL="" F S DIFL=$O(^DD("KEY",DIKEY,2,"S",S,DIREC,DIFL)) Q:'DIFL!(DIOUT) D
87 . I DIFL'=DDT(DTL)!('$D(^DD(DDT(DTL),DIREC,0))#2) S DIOUT=1 Q
88 . S %=$P(^DD(DIFL,DIREC,0),U,4),I=DIREC,(B,W)=""
89 . D Q:DIOUT I W="" S DIOUT=1 Q
90 .. N A,DIFL,DIREC S A=% D I3 Q
91 . S DIVAL(S)=W Q
92 S A=0 I DIOUT S A=1 Q
93 N KEYN,DA,DIENS,DIERR
94 S KEYN=$P($G(^DD("IX",+$P(^DD("KEY",DIKEY,0),U,4),0)),U,2) I KEYN="" S A=1 Q
95 S DIENS="," I $G(D1) S %=DFL\2,Y=0,D0=$S($G(D0):D0,$G(DFR):DFR,1:"") I D0 D DA S DIENS=$$IENS^DILF(.DA)
96 S V=$$FIND1^DIC(DDT(DTL),DIENS,"QXK",.DIVAL,,,"DIERR")
97 I $G(DIERR) S A=1 Q
98 I V>0 S DIMATCH=1
99 S A=0 Q
100 ;
101REPLACE ;
102 N DA,DIK,DISAV0 S DISAV0=$P(@(DIFROOT_"0)"),U,3,4)
103 K @DIFRSA@("TMP")
104 I DIFRDKPS M @DIFRSA@("TMP",DIFRFILE,Y)=@(DTO(DTL)_Y_")")
105 S DA=Y,DIK=DIFROOT
106 N %,A,B,D0,DDF,DDT,DFL,DFR,DINUM,DTL,DTN,DTO,I,W,X,Y,Z
107 D ^DIK
108 S DIFRDKPD=0,$P(@(DIFROOT_"0)"),U,3,4)=DISAV0
109 Q
110 ;
111SUBLN(DIFILE) ; Return maximum subscript length for "B" index.
112 N I,DIWHEREB,DISUBLN S DIWHEREB=""
113 S DIWHEREB=$O(^DD("IX","BB",DIFILE,"B",0))
114 I 'DIWHEREB,$D(^DD(DIFILE,0,"IX","B",DIFILE,.01)) S DIWHEREB=0
115 I DIWHEREB="" Q 0
116 I DIWHEREB D
117 . S I=$O(^DD("IX","F",DIFILE,.01,DIWHEREB,0)) Q:'I
118 . S DISUBLN=+$P($G(^DD("IX",DIWHEREB,11.1,I,0)),U,5)
119 . S:'DISUBLN DISUBLN=999
120 I 'DIWHEREB F I=0:0 S I=$O(^DD(DIFILE,.01,1,I)) Q:'I I $P($G(^(I,0)),U,2)="B" D Q
121 . S I=$G(^DD(DIFILE,.01,1,I,1)),DISUBLN=+$P(I,"$E(X,1,",2) Q
122 Q:$G(DISUBLN) DISUBLN
123 Q 30
124 ;
Note: See TracBrowser for help on using the repository browser.