- 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 Feb 19, 2025@00:20:45 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 ;