Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DITR1

DITR1.m

Go to the documentation of this file.
  1. DITR1 ;SFISC/GFT-FIND ENTRY MATCHES ;18-MAR-2013
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. 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))
  1. N DIMATCH S DIMATCH=0
  1. G WORD:$P(^DD(DDT(DTL),.01,0),U,2)["W",Q:X="",ON:'W
  1. S V="" N DIKEY S DIKEY=$O(^DD("KEY","AP",DDT(DTL),"P",0))
  1. I DIKEY S A=0 D MATCHKEY(DIKEY,.V,.A,.DIMATCH) Q:A
  1. K DINUM I ^DD(DDT(DTL),.01,0)["DINUM" D Q
  1. . I $P(^DD(DDT(DTL),.01,0),U,2)["P" D DINUM Q
  1. . S V=X,DA=Y,Y=0,D0=$S($D(D0):D0,$D(DFR):DFR,1:"") D DA
  1. . X $P(^DD(DDT(DTL),.01,0),U,5,99)
  1. . S X=V,Y=DA I '$D(DINUM) S A=1 Q
  1. . S Y=DINUM K DINUM D DINUM Q
  1. I $D(^DD(DDT(DTL),.001,0)) D HAS001 Q
  1. I DIKEY D Q
  1. . I V>0 S Y=V D OLD Q
  1. . D NEW Q
  1. S V=0 D:'$D(DISYS) OS^DII
  1. N DISUBLN,DISUBMX
  1. S DISUBLN=$$SUBLN(DDT(DTL))
  1. S DISUBMX=+$P(^DD("OS",DISYS,0),U,7) S:'DISUBMX DISUBMX=63
  1. B 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
  1. 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
  1. I $D(@(DTO(DTL)_V_",0)")),$P(^(0),X)="" D MATCH G OLD:'$D(A)
  1. G B
  1. ;
  1. DA Q:'% S DA(%)=@("D"_Y),Y=Y+1,%=%-1 G DA
  1. ;
  1. DINUM I DIKEY,V>0,V'=Y S A=1 Q
  1. I @("'$D("_DTO(DTL)_"Y))") D ADD Q
  1. I DIKEY S:Y'=V A=1 D:'A OLD Q
  1. S V=Y D MATCH I $D(A) S A=1 Q
  1. D OLD Q
  1. ;
  1. HAS001 ; If file has .001 field, .01 and Identifiers/Keys must match
  1. I DIKEY,V>0,V'=Y S A=1 Q
  1. I @("$G("_DTO(DTL)_"Y,0))']""""") D ADD Q
  1. I DIKEY S:Y'=V A=1 D:'A OLD Q
  1. S V=Y N DIZERO S DIZERO=@(DTO(DTL)_"Y,0)") I $P(DIZERO,U)'=X S A=1 Q
  1. D MATCH I $D(A) S A=1 Q
  1. D OLD Q
  1. ;
  1. NEW S W=0
  1. ON I @("$D("_DTO(DTL)_"Y))") G OLD:W S DITRCNT=$G(DITRCNT)+1,Y=DITRCNT G ON
  1. ADD 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
  1. OLD I DIMATCH,$G(DIFRDKPR),$G(DIFRDKPD),'DTL D REPLACE
  1. S DTO(DTL+1)=DTO(DTL)_Y_",",DTN(DTL+1)=0,A=0
  1. Q Q
  1. ;
  1. WORD I $G(DIFRDKP) Q:$D(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01))
  1. 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
  1. ;
  1. MATCH S A=1 I Y'=V,$D(^DD(DDT(DTL),.001,0)) Q
  1. S Y=V,I=.01 N DIOUT,DIFL,DIREC
  1. I S DIOUT=0
  1. F S I=$O(^DD(DDT(DTL),0,"ID",I)) Q:'I D I2 Q:DIOUT
  1. Q:DIOUT
  1. S DIMATCH=1 K A Q
  1. ;
  1. I2 S DIFL=DDT(DTL),DIREC=I I '$D(^DD(DIFL,DIREC,0))#2 Q:'DIKEY S DIOUT=1 Q
  1. K B D P Q:W=""
  1. S B=W
  1. I3 ; Entry point for initial matching on KEY values
  1. I DTO S A=$P(A,";",2)_U_$P(A,";",1) D Q:%'>0
  1. . F %=0:0 S %=$O(^UTILITY("DITR",$J,DDF(DFL+1),%)) Q:%'>0 Q:^(%)=A
  1. E S %=I
  1. S DIFL=DDF(DFL+1),DIREC=% I '$D(^DD(DIFL,DIREC,0)) Q:'DIKEY S DIOUT=1 Q
  1. D P I W="" Q:'DIKEY S DIOUT=1 Q
  1. I W=B!(DIKEY) Q
  1. S Y=@("D"_(DFL\2)),DIOUT=1 Q
  1. ;
  1. P S A=$P(^DD(DIFL,DIREC,0),U,4)
  1. S %=$P(A,";",2),W=$P(A,";")
  1. I @("'$D("_$S('$D(B):DTO(DTL)_"Y,",DFL:DFR(DFL)_"DFN(DFL),",1:DFR(1))_"W))") S W="" Q
  1. I % S W=$P(^(W),U,%)
  1. E S W=$E(^(W),+$E(%,2,9),$P(%,",",2))
  1. Q:DIKEY
  1. UP I %["F" S W=$$UP^DILIBF(W)
  1. Q
  1. ;
  1. MATCHKEY(DIKEY,V,A,DIMATCH) ; Match Primary Key fields
  1. ; DIKEY=IEN of Primary Key, V=IEN of matching record on target file, A set to 1 if errors are encountered.
  1. N %,B,S,W,Y,DIOUT,DIENS,DIFL,DIERR,DIREC,DIVAL
  1. S S="",DIOUT=0
  1. 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
  1. . I DIFL'=DDT(DTL)!('$D(^DD(DDT(DTL),DIREC,0))#2) S DIOUT=1 Q
  1. . S %=$P(^DD(DIFL,DIREC,0),U,4),I=DIREC,(B,W)=""
  1. . D Q:DIOUT I W="" S DIOUT=1 Q
  1. .. N A,DIFL,DIREC S A=% D I3 Q
  1. . S DIVAL(S)=W Q
  1. S A=0 I DIOUT S A=1 Q
  1. N KEYN,DA,DIENS,DIERR
  1. S KEYN=$P($G(^DD("IX",+$P(^DD("KEY",DIKEY,0),U,4),0)),U,2) I KEYN="" S A=1 Q
  1. 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)
  1. S V=$$FIND1^DIC(DDT(DTL),DIENS,"QXK",.DIVAL,,,"DIERR")
  1. I $G(DIERR) S A=1 Q
  1. I V>0 S DIMATCH=1
  1. S A=0 Q
  1. ;
  1. REPLACE ;
  1. N DA,DIK,DISAV0 S DISAV0=$P(@(DIFROOT_"0)"),U,3,4)
  1. K @DIFRSA@("TMP")
  1. I DIFRDKPS M @DIFRSA@("TMP",DIFRFILE,Y)=@(DTO(DTL)_Y_")")
  1. S DA=Y,DIK=DIFROOT
  1. N %,A,B,D0,DDF,DDT,DFL,DFR,DINUM,DTL,DTN,DTO,I,W,X,Y,Z
  1. D ^DIK
  1. S DIFRDKPD=0,$P(@(DIFROOT_"0)"),U,3,4)=DISAV0
  1. Q
  1. ;
  1. SUBLN(DIFILE) ; Return maximum subscript length for "B" index.
  1. N I,DIWHEREB,DISUBLN S DIWHEREB=""
  1. S DIWHEREB=$O(^DD("IX","BB",DIFILE,"B",0))
  1. I 'DIWHEREB,$D(^DD(DIFILE,0,"IX","B",DIFILE,.01)) S DIWHEREB=0
  1. I DIWHEREB="" Q 0
  1. I DIWHEREB D
  1. . S I=$O(^DD("IX","F",DIFILE,.01,DIWHEREB,0)) Q:'I
  1. . S DISUBLN=+$P($G(^DD("IX",DIWHEREB,11.1,I,0)),U,5)
  1. . S:'DISUBLN DISUBLN=999
  1. 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
  1. . S I=$G(^DD(DIFILE,.01,1,I,1)),DISUBLN=+$P(I,"$E(X,1,",2) Q
  1. Q:$G(DISUBLN) DISUBLN
  1. Q 30
  1. ;