DITR1 ;SFISC/GFT-FIND ENTRY MATCHES ;18-MAR-2013
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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))
N DIMATCH S DIMATCH=0
G WORD:$P(^DD(DDT(DTL),.01,0),U,2)["W",Q:X="",ON:'W
S V="" N DIKEY S DIKEY=$O(^DD("KEY","AP",DDT(DTL),"P",0))
I DIKEY S A=0 D MATCHKEY(DIKEY,.V,.A,.DIMATCH) Q:A
K DINUM I ^DD(DDT(DTL),.01,0)["DINUM" D Q
. I $P(^DD(DDT(DTL),.01,0),U,2)["P" D DINUM Q
. S V=X,DA=Y,Y=0,D0=$S($D(D0):D0,$D(DFR):DFR,1:"") D DA
. X $P(^DD(DDT(DTL),.01,0),U,5,99)
. S X=V,Y=DA I '$D(DINUM) S A=1 Q
. S Y=DINUM K DINUM D DINUM Q
I $D(^DD(DDT(DTL),.001,0)) D HAS001 Q
I DIKEY D Q
. I V>0 S Y=V D OLD Q
. D NEW Q
S V=0 D:'$D(DISYS) OS^DII
N DISUBLN,DISUBMX
S DISUBLN=$$SUBLN(DDT(DTL))
S DISUBMX=+$P(^DD("OS",DISYS,0),U,7) S:'DISUBMX DISUBMX=63
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
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
I $D(@(DTO(DTL)_V_",0)")),$P(^(0),X)="" D MATCH G OLD:'$D(A)
G B
;
DA Q:'% S DA(%)=@("D"_Y),Y=Y+1,%=%-1 G DA
;
DINUM I DIKEY,V>0,V'=Y S A=1 Q
I @("'$D("_DTO(DTL)_"Y))") D ADD Q
I DIKEY S:Y'=V A=1 D:'A OLD Q
S V=Y D MATCH I $D(A) S A=1 Q
D OLD Q
;
HAS001 ; If file has .001 field, .01 and Identifiers/Keys must match
I DIKEY,V>0,V'=Y S A=1 Q
I @("$G("_DTO(DTL)_"Y,0))']""""") D ADD Q
I DIKEY S:Y'=V A=1 D:'A OLD Q
S V=Y N DIZERO S DIZERO=@(DTO(DTL)_"Y,0)") I $P(DIZERO,U)'=X S A=1 Q
D MATCH I $D(A) S A=1 Q
D OLD Q
;
NEW S W=0
ON I @("$D("_DTO(DTL)_"Y))") G OLD:W S DITRCNT=$G(DITRCNT)+1,Y=DITRCNT G ON
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
OLD I DIMATCH,$G(DIFRDKPR),$G(DIFRDKPD),'DTL D REPLACE
S DTO(DTL+1)=DTO(DTL)_Y_",",DTN(DTL+1)=0,A=0
Q Q
;
WORD I $G(DIFRDKP) Q:$D(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01))
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
;
MATCH S A=1 I Y'=V,$D(^DD(DDT(DTL),.001,0)) Q
S Y=V,I=.01 N DIOUT,DIFL,DIREC
I S DIOUT=0
F S I=$O(^DD(DDT(DTL),0,"ID",I)) Q:'I D I2 Q:DIOUT
Q:DIOUT
S DIMATCH=1 K A Q
;
I2 S DIFL=DDT(DTL),DIREC=I I '$D(^DD(DIFL,DIREC,0))#2 Q:'DIKEY S DIOUT=1 Q
K B D P Q:W=""
S B=W
I3 ; Entry point for initial matching on KEY values
I DTO S A=$P(A,";",2)_U_$P(A,";",1) D Q:%'>0
. F %=0:0 S %=$O(^UTILITY("DITR",$J,DDF(DFL+1),%)) Q:%'>0 Q:^(%)=A
E S %=I
S DIFL=DDF(DFL+1),DIREC=% I '$D(^DD(DIFL,DIREC,0)) Q:'DIKEY S DIOUT=1 Q
D P I W="" Q:'DIKEY S DIOUT=1 Q
I W=B!(DIKEY) Q
S Y=@("D"_(DFL\2)),DIOUT=1 Q
;
P S A=$P(^DD(DIFL,DIREC,0),U,4)
S %=$P(A,";",2),W=$P(A,";")
I @("'$D("_$S('$D(B):DTO(DTL)_"Y,",DFL:DFR(DFL)_"DFN(DFL),",1:DFR(1))_"W))") S W="" Q
I % S W=$P(^(W),U,%)
E S W=$E(^(W),+$E(%,2,9),$P(%,",",2))
Q:DIKEY
UP I %["F" S W=$$UP^DILIBF(W)
Q
;
MATCHKEY(DIKEY,V,A,DIMATCH) ; Match Primary Key fields
; DIKEY=IEN of Primary Key, V=IEN of matching record on target file, A set to 1 if errors are encountered.
N %,B,S,W,Y,DIOUT,DIENS,DIFL,DIERR,DIREC,DIVAL
S S="",DIOUT=0
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
. I DIFL'=DDT(DTL)!('$D(^DD(DDT(DTL),DIREC,0))#2) S DIOUT=1 Q
. S %=$P(^DD(DIFL,DIREC,0),U,4),I=DIREC,(B,W)=""
. D Q:DIOUT I W="" S DIOUT=1 Q
.. N A,DIFL,DIREC S A=% D I3 Q
. S DIVAL(S)=W Q
S A=0 I DIOUT S A=1 Q
N KEYN,DA,DIENS,DIERR
S KEYN=$P($G(^DD("IX",+$P(^DD("KEY",DIKEY,0),U,4),0)),U,2) I KEYN="" S A=1 Q
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)
S V=$$FIND1^DIC(DDT(DTL),DIENS,"QXK",.DIVAL,,,"DIERR")
I $G(DIERR) S A=1 Q
I V>0 S DIMATCH=1
S A=0 Q
;
REPLACE ;
N DA,DIK,DISAV0 S DISAV0=$P(@(DIFROOT_"0)"),U,3,4)
K @DIFRSA@("TMP")
I DIFRDKPS M @DIFRSA@("TMP",DIFRFILE,Y)=@(DTO(DTL)_Y_")")
S DA=Y,DIK=DIFROOT
N %,A,B,D0,DDF,DDT,DFL,DFR,DINUM,DTL,DTN,DTO,I,W,X,Y,Z
D ^DIK
S DIFRDKPD=0,$P(@(DIFROOT_"0)"),U,3,4)=DISAV0
Q
;
SUBLN(DIFILE) ; Return maximum subscript length for "B" index.
N I,DIWHEREB,DISUBLN S DIWHEREB=""
S DIWHEREB=$O(^DD("IX","BB",DIFILE,"B",0))
I 'DIWHEREB,$D(^DD(DIFILE,0,"IX","B",DIFILE,.01)) S DIWHEREB=0
I DIWHEREB="" Q 0
I DIWHEREB D
. S I=$O(^DD("IX","F",DIFILE,.01,DIWHEREB,0)) Q:'I
. S DISUBLN=+$P($G(^DD("IX",DIWHEREB,11.1,I,0)),U,5)
. S:'DISUBLN DISUBLN=999
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
. S I=$G(^DD(DIFILE,.01,1,I,1)),DISUBLN=+$P(I,"$E(X,1,",2) Q
Q:$G(DISUBLN) DISUBLN
Q 30
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITR1 5249 printed Dec 13, 2024@02:54:31 Page 2
DITR1 ;SFISC/GFT-FIND ENTRY MATCHES ;18-MAR-2013
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 SET W=DMRG
SET X=$PIECE(Z,U)
SET %=DFL\2
SET Y=@("D"_%)
SET A=1
if $GET(DIFRDKP)
SET DIFRNOAD=$DATA(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01,0))
+8 NEW DIMATCH
SET DIMATCH=0
+9 if $PIECE(^DD(DDT(DTL),.01,0),U,2)["W"
GOTO WORD
if X=""
GOTO Q
if 'W
GOTO ON
+10 SET V=""
NEW DIKEY
SET DIKEY=$ORDER(^DD("KEY","AP",DDT(DTL),"P",0))
+11 IF DIKEY
SET A=0
DO MATCHKEY(DIKEY,.V,.A,.DIMATCH)
if A
QUIT
+12 KILL DINUM
IF ^DD(DDT(DTL),.01,0)["DINUM"
Begin DoDot:1
+13 IF $PIECE(^DD(DDT(DTL),.01,0),U,2)["P"
DO DINUM
QUIT
+14 SET V=X
SET DA=Y
SET Y=0
SET D0=$SELECT($DATA(D0):D0,$DATA(DFR):DFR,1:"")
DO DA
+15 XECUTE $PIECE(^DD(DDT(DTL),.01,0),U,5,99)
+16 SET X=V
SET Y=DA
IF '$DATA(DINUM)
SET A=1
QUIT
+17 SET Y=DINUM
KILL DINUM
DO DINUM
QUIT
End DoDot:1
QUIT
+18 IF $DATA(^DD(DDT(DTL),.001,0))
DO HAS001
QUIT
+19 IF DIKEY
Begin DoDot:1
+20 IF V>0
SET Y=V
DO OLD
QUIT
+21 DO NEW
QUIT
End DoDot:1
QUIT
+22 SET V=0
if '$DATA(DISYS)
DO OS^DII
+23 NEW DISUBLN,DISUBMX
+24 SET DISUBLN=$$SUBLN(DDT(DTL))
+25 SET DISUBMX=+$PIECE(^DD("OS",DISYS,0),U,7)
if 'DISUBMX
SET DISUBMX=63
B IF DISUBLN=0
FOR A=1:1
SET V=$ORDER(@(DTO(DTL)_V_")"))
if V'>0
GOTO NEW
IF $DATA(^(V,0))
IF $PIECE(^(0),U)=X
DO MATCH
if '$DATA(A)
GOTO OLD
SET A=1
+1 SET V=$SELECT($ORDER(@(DTO(DTL)_"""B"",$E(X,1,DISUBMX),V)"))>0:$ORDER(^(V)),1:$ORDER(@(DTO(DTL)_"""B"",$E(X,1,DISUBLN),V)")))
if V'>0
GOTO NEW
+2 IF $DATA(@(DTO(DTL)_V_",0)"))
IF $PIECE(^(0),X)=""
DO MATCH
if '$DATA(A)
GOTO OLD
+3 GOTO B
+4 ;
DA if '%
QUIT
SET DA(%)=@("D"_Y)
SET Y=Y+1
SET %=%-1
GOTO DA
+1 ;
DINUM IF DIKEY
IF V>0
IF V'=Y
SET A=1
QUIT
+1 IF @("'$D("_DTO(DTL)_"Y))")
DO ADD
QUIT
+2 IF DIKEY
if Y'=V
SET A=1
if 'A
DO OLD
QUIT
+3 SET V=Y
DO MATCH
IF $DATA(A)
SET A=1
QUIT
+4 DO OLD
QUIT
+5 ;
HAS001 ; If file has .001 field, .01 and Identifiers/Keys must match
+1 IF DIKEY
IF V>0
IF V'=Y
SET A=1
QUIT
+2 IF @("$G("_DTO(DTL)_"Y,0))']""""")
DO ADD
QUIT
+3 IF DIKEY
if Y'=V
SET A=1
if 'A
DO OLD
QUIT
+4 SET V=Y
NEW DIZERO
SET DIZERO=@(DTO(DTL)_"Y,0)")
IF $PIECE(DIZERO,U)'=X
SET A=1
QUIT
+5 DO MATCH
IF $DATA(A)
SET A=1
QUIT
+6 DO OLD
QUIT
+7 ;
NEW SET W=0
ON IF @("$D("_DTO(DTL)_"Y))")
if W
GOTO OLD
SET DITRCNT=$GET(DITRCNT)+1
SET Y=DITRCNT
GOTO ON
ADD if $GET(DIFRDKP)
if DIFRNOAD
GOTO Q
SET @("V="_DTO(DTL)_"0)")
SET ^(0)=$PIECE(V,U,1,2)_U_Y_U_($PIECE(V,U,4)+1)
SET ^(Y,0)=X
OLD IF DIMATCH
IF $GET(DIFRDKPR)
IF $GET(DIFRDKPD)
IF 'DTL
DO REPLACE
+1 SET DTO(DTL+1)=DTO(DTL)_Y_","
SET DTN(DTL+1)=0
SET A=0
Q QUIT
+1 ;
WORD IF $GET(DIFRDKP)
if $DATA(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01))
QUIT
+1 SET @("V=$O("_DTO(DTL)_"0))")
if V'>0!'DKP
XECUTE "K "_$EXTRACT(DTO(DTL),1,$LENGTH(DTO(DTL))-1)_") S:$D("_DFR(DFL)_"0)) "_DTO(DTL)_"0)=^(0)"
XECUTE "F V=0:0 S V=$O("_DFR(DFL)_"V)) Q:V'>0 S:$D(^(V,0)) "_DTO(DTL)_"V,0)=^(0)"
SET (DFL,DTL)=DFL-1
QUIT
+2 ;
MATCH SET A=1
IF Y'=V
IF $DATA(^DD(DDT(DTL),.001,0))
QUIT
+1 SET Y=V
SET I=.01
NEW DIOUT,DIFL,DIREC
I SET DIOUT=0
+1 FOR
SET I=$ORDER(^DD(DDT(DTL),0,"ID",I))
if 'I
QUIT
DO I2
if DIOUT
QUIT
+2 if DIOUT
QUIT
+3 SET DIMATCH=1
KILL A
QUIT
+4 ;
I2 SET DIFL=DDT(DTL)
SET DIREC=I
IF '$DATA(^DD(DIFL,DIREC,0))#2
if 'DIKEY
QUIT
SET DIOUT=1
QUIT
+1 KILL B
DO P
if W=""
QUIT
+2 SET B=W
I3 ; Entry point for initial matching on KEY values
+1 IF DTO
SET A=$PIECE(A,";",2)_U_$PIECE(A,";",1)
Begin DoDot:1
+2 FOR %=0:0
SET %=$ORDER(^UTILITY("DITR",$JOB,DDF(DFL+1),%))
if %'>0
QUIT
if ^(%)=A
QUIT
End DoDot:1
if %'>0
QUIT
+3 IF '$TEST
SET %=I
+4 SET DIFL=DDF(DFL+1)
SET DIREC=%
IF '$DATA(^DD(DIFL,DIREC,0))
if 'DIKEY
QUIT
SET DIOUT=1
QUIT
+5 DO P
IF W=""
if 'DIKEY
QUIT
SET DIOUT=1
QUIT
+6 IF W=B!(DIKEY)
QUIT
+7 SET Y=@("D"_(DFL\2))
SET DIOUT=1
QUIT
+8 ;
P SET A=$PIECE(^DD(DIFL,DIREC,0),U,4)
+1 SET %=$PIECE(A,";",2)
SET W=$PIECE(A,";")
+2 IF @("'$D("_$SELECT('$DATA(B):DTO(DTL)_"Y,",DFL:DFR(DFL)_"DFN(DFL),",1:DFR(1))_"W))")
SET W=""
QUIT
+3 IF %
SET W=$PIECE(^(W),U,%)
+4 IF '$TEST
SET W=$EXTRACT(^(W),+$EXTRACT(%,2,9),$PIECE(%,",",2))
+5 if DIKEY
QUIT
UP IF %["F"
SET W=$$UP^DILIBF(W)
+1 QUIT
+2 ;
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.
+2 NEW %,B,S,W,Y,DIOUT,DIENS,DIFL,DIERR,DIREC,DIVAL
+3 SET S=""
SET DIOUT=0
+4 FOR
SET S=$ORDER(^DD("KEY",DIKEY,2,"S",S))
if 'S!(DIOUT)
QUIT
SET DIREC=""
FOR
SET DIREC=$ORDER(^DD("KEY",DIKEY,2,"S",S,DIREC))
if 'DIREC!(DIOUT)
QUIT
SET DIFL=""
FOR
SET DIFL=$ORDER(^DD("KEY",DIKEY,2,"S",S,DIREC,DIFL))
if 'DIFL!(DIOUT)
QUIT
Begin DoDot:1
+5 IF DIFL'=DDT(DTL)!('$DATA(^DD(DDT(DTL),DIREC,0))#2)
SET DIOUT=1
QUIT
+6 SET %=$PIECE(^DD(DIFL,DIREC,0),U,4)
SET I=DIREC
SET (B,W)=""
+7 Begin DoDot:2
+8 NEW A,DIFL,DIREC
SET A=%
DO I3
QUIT
End DoDot:2
if DIOUT
QUIT
IF W=""
SET DIOUT=1
QUIT
+9 SET DIVAL(S)=W
QUIT
End DoDot:1
+10 SET A=0
IF DIOUT
SET A=1
QUIT
+11 NEW KEYN,DA,DIENS,DIERR
+12 SET KEYN=$PIECE($GET(^DD("IX",+$PIECE(^DD("KEY",DIKEY,0),U,4),0)),U,2)
IF KEYN=""
SET A=1
QUIT
+13 SET DIENS=","
IF $GET(D1)
SET %=DFL\2
SET Y=0
SET D0=$SELECT($GET(D0):D0,$GET(DFR):DFR,1:"")
IF D0
DO DA
SET DIENS=$$IENS^DILF(.DA)
+14 SET V=$$FIND1^DIC(DDT(DTL),DIENS,"QXK",.DIVAL,,,"DIERR")
+15 IF $GET(DIERR)
SET A=1
QUIT
+16 IF V>0
SET DIMATCH=1
+17 SET A=0
QUIT
+18 ;
REPLACE ;
+1 NEW DA,DIK,DISAV0
SET DISAV0=$PIECE(@(DIFROOT_"0)"),U,3,4)
+2 KILL @DIFRSA@("TMP")
+3 IF DIFRDKPS
MERGE @DIFRSA@("TMP",DIFRFILE,Y)=@(DTO(DTL)_Y_")")
+4 SET DA=Y
SET DIK=DIFROOT
+5 NEW %,A,B,D0,DDF,DDT,DFL,DFR,DINUM,DTL,DTN,DTO,I,W,X,Y,Z
+6 DO ^DIK
+7 SET DIFRDKPD=0
SET $PIECE(@(DIFROOT_"0)"),U,3,4)=DISAV0
+8 QUIT
+9 ;
SUBLN(DIFILE) ; Return maximum subscript length for "B" index.
+1 NEW I,DIWHEREB,DISUBLN
SET DIWHEREB=""
+2 SET DIWHEREB=$ORDER(^DD("IX","BB",DIFILE,"B",0))
+3 IF 'DIWHEREB
IF $DATA(^DD(DIFILE,0,"IX","B",DIFILE,.01))
SET DIWHEREB=0
+4 IF DIWHEREB=""
QUIT 0
+5 IF DIWHEREB
Begin DoDot:1
+6 SET I=$ORDER(^DD("IX","F",DIFILE,.01,DIWHEREB,0))
if 'I
QUIT
+7 SET DISUBLN=+$PIECE($GET(^DD("IX",DIWHEREB,11.1,I,0)),U,5)
+8 if 'DISUBLN
SET DISUBLN=999
End DoDot:1
+9 IF 'DIWHEREB
FOR I=0:0
SET I=$ORDER(^DD(DIFILE,.01,1,I))
if 'I
QUIT
IF $PIECE($GET(^(I,0)),U,2)="B"
Begin DoDot:1
+10 SET I=$GET(^DD(DIFILE,.01,1,I,1))
SET DISUBLN=+$PIECE(I,"$E(X,1,",2)
QUIT
End DoDot:1
QUIT
+11 if $GET(DISUBLN)
QUIT DISUBLN
+12 QUIT 30
+13 ;
