DICF0 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, get alternate index ;2/8/00 11:11
;;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.
;
ALTIDX(DINDEX,DIFILE,DIVALUE,DISCREEN,DINUMBER) ; Find alternate index when lookup value for first subscript is null.
N DIX S DIX=DINDEX,DIX("WAY")=DINDEX("WAY"),DIX("OLDSUB")=DINDEX("#")
D IDXOK(.DINDEX,DIFILE,.DIX) Q:DIX'=DINDEX
A1 ; Find next lookup value
N DIFIELD,DISUB,DITYPE,I,J,K,X,Y,Z
F DISUB=1:0 S DISUB=$O(DIVALUE(DISUB)) Q:'DISUB I DIVALUE(DISUB)]"" D
. S X=$G(DINDEX(DISUB,"TYPE"))
. S DITYPE=$S(X="V":3,X="P":2,1:1),DITYPE(DITYPE,DISUB)=""
. Q
S DIX=""
F DITYPE=1,2,3 Q:DIX]"" I $D(DITYPE(DITYPE)) F DISUB=0:0 D Q:'DISUB Q:DIX]""
. S DISUB=$O(DITYPE(DITYPE,DISUB)) Q:'DISUB
. S DIFIELD=DINDEX(DISUB,"FIELD")
A2 . ; find alternate index on that field.
. F I=0:0 S I=$O(^DD(DIFILE,DIFIELD,1,I)) Q:'I S X=$G(^(I,0)) D Q:DIX]""
. . I $P(X,U,3)="",$P(X,U,2)]"A[" S DIX=$P(X,U,2) Q:DIX'=DINDEX
. . S DIX="" Q
. I DIX]"" S DIX("#")=1,DIX(1)=DISUB Q
. F I=0:0 S I=$O(^DD("IX","F",DIFILE,DIFIELD,I)) Q:'I D Q:DIX]""
. . S DIX=$P($G(^DD("IX",I,0)),U,2) Q:DIX=""
. . I DIX=DINDEX S DIX="" Q
. . D IDXOK(.DINDEX,DIFILE,.DIX,I,.DIVALUE)
. . Q
. Q
Q:DIX=""
A3 ; Rearrange lookup values and for new index
N DIV,DIS
M DIS("S")=DISCREEN("S"),DIS("F")=DISCREEN("F")
F I=1:1:DIX("#") S J=DIX(I) D
. Q:DIVALUE(J)=""
. M DIV(I)=DIVALUE(J),DIS(I)=DISCREEN(J)
. K DIVALUE(J),DISCREEN(J) Q
A4 ; Build screening logic for fields whose lookup values are not on new index.
F J=0:0 S J=$O(DIVALUE(J)) Q:'J D
. M DIS("VAL",J)=DIVALUE(J)
. I $D(DISCREEN(J)) D
. . S X="DINDEX(",Z="DISCREEN(""VAL"","
. . F K=0:0 S K=$O(DISCREEN(J,K)) Q:'K S Y=DISCREEN(J,K) I Y[X S DISCREEN(J,K)="" F Q:Y'[X D
. . . N L,S S S=$P(Y,X),L=$L(S_X),S=S_Z,Y=$E(Y,L+1,$L(Y))
. . . S DISCREEN(J,K)=DISCREEN(J,K)_S
. . . I Y'[X S DISCREEN(J,K)=DISCREEN(J,K)_Y
. . . Q
. . M DIS("X",J)=DISCREEN(J) Q
. N DICODE,DINODE
. D GET^DICUIX1(DIFILE,DIFILE,DINDEX(J,"FIELD"),.DINODE,.DICODE)
. I "PVSD"'[DINDEX(J,"TYPE") S DIS("X",J,"GET")="S DIVAL="_DICODE Q
. S DIS("X",J,"GET")="S DIVAL=$$EXTERNAL^DIDU("_DIFILE_","_DINDEX(J,"FIELD")_","""","_DICODE_")"
. D
. . N DISAVJ S DISAVJ=J N J
. . S X=$$EXTERNAL^DIDU(DINDEX(DISAVJ,"FILE"),DINDEX(DISAVJ,"FIELD"),"",DIS("VAL",DISAVJ),"DIERR")
. . S J=$O(DIS("VAL",DISAVJ,99999),-1)+1
. . S DIS("VAL",DISAVJ,J)=X Q
. Q
K DINDEX S DINDEX=DIX,DINDEX("WAY")=DIX("WAY")
I DIFLAGS["l" S DINDEX("START")=DIX,DINDEX("OLDSUB")=DIX("OLDSUB")
K DISCREEN,DIVALUE M DISCREEN=DIS,DIVALUE=DIV K DIS,DIV
D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN)
D XFORM^DICF1(DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX)
Q
;
IDXOK(DINDEX,DIFILE,DIX,DIXIEN,DIVALUE) ; Return alternate index name DIX if it has no set/kill conditions and all subscripts are fields from original index DINDEX.
I '$G(DIXIEN) S DIXIEN=$O(^DD("IX","BB",DIFILE,DIX,0)) I 'DIXIEN S DIX="" Q
I $G(^DD("IX",DIXIEN,1.4))]""!($G(^(2.4))]"") S DIX="" Q
N I,J,X,DIFIELD,DISKIP S DISKIP=1 I $O(DIVALUE(0)) S DIX("#")=0
F I=0:0 S I=$O(^DD("IX",DIXIEN,11.1,"AC",I)) Q:'I S DISKIP=1 D Q:DISKIP
. S X=$G(^DD("IX",DIXIEN,11.1,I,0))
. Q:$P(X,U,3)'=DIFILE Q:$P(X,U,6)'=I S DIFIELD=$P(X,U,4) Q:'DIFIELD
. Q:$G(^DD("IX",DIXIEN,11.1,I,2))]""
. I '$O(DIVALUE(0)) S DISKIP=0 Q
. F J=1:1:DINDEX("#") D Q:'DISKIP
. . Q:DINDEX(J,"FIELD")'=DIFIELD
. . I I=1,DIVALUE(J)="" Q
. . S DIX(I)=J,DISKIP=0 Q
. I 'DISKIP S DIX("#")=DIX("#")+1
. Q
I DISKIP S DIX="" Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICF0 3851 printed Oct 16, 2024@18:46:33 Page 2
DICF0 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, get alternate index ;2/8/00 11:11
+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 ;
ALTIDX(DINDEX,DIFILE,DIVALUE,DISCREEN,DINUMBER) ; Find alternate index when lookup value for first subscript is null.
+1 NEW DIX
SET DIX=DINDEX
SET DIX("WAY")=DINDEX("WAY")
SET DIX("OLDSUB")=DINDEX("#")
+2 DO IDXOK(.DINDEX,DIFILE,.DIX)
if DIX'=DINDEX
QUIT
A1 ; Find next lookup value
+1 NEW DIFIELD,DISUB,DITYPE,I,J,K,X,Y,Z
+2 FOR DISUB=1:0
SET DISUB=$ORDER(DIVALUE(DISUB))
if 'DISUB
QUIT
IF DIVALUE(DISUB)]""
Begin DoDot:1
+3 SET X=$GET(DINDEX(DISUB,"TYPE"))
+4 SET DITYPE=$SELECT(X="V":3,X="P":2,1:1)
SET DITYPE(DITYPE,DISUB)=""
+5 QUIT
End DoDot:1
+6 SET DIX=""
+7 FOR DITYPE=1,2,3
if DIX]""
QUIT
IF $DATA(DITYPE(DITYPE))
FOR DISUB=0:0
Begin DoDot:1
+8 SET DISUB=$ORDER(DITYPE(DITYPE,DISUB))
if 'DISUB
QUIT
+9 SET DIFIELD=DINDEX(DISUB,"FIELD")
A2 ; find alternate index on that field.
+1 FOR I=0:0
SET I=$ORDER(^DD(DIFILE,DIFIELD,1,I))
if 'I
QUIT
SET X=$GET(^(I,0))
Begin DoDot:2
+2 IF $PIECE(X,U,3)=""
IF $PIECE(X,U,2)]"A["
SET DIX=$PIECE(X,U,2)
if DIX'=DINDEX
QUIT
+3 SET DIX=""
QUIT
End DoDot:2
if DIX]""
QUIT
+4 IF DIX]""
SET DIX("#")=1
SET DIX(1)=DISUB
QUIT
+5 FOR I=0:0
SET I=$ORDER(^DD("IX","F",DIFILE,DIFIELD,I))
if 'I
QUIT
Begin DoDot:2
+6 SET DIX=$PIECE($GET(^DD("IX",I,0)),U,2)
if DIX=""
QUIT
+7 IF DIX=DINDEX
SET DIX=""
QUIT
+8 DO IDXOK(.DINDEX,DIFILE,.DIX,I,.DIVALUE)
+9 QUIT
End DoDot:2
if DIX]""
QUIT
+10 QUIT
End DoDot:1
if 'DISUB
QUIT
if DIX]""
QUIT
+11 if DIX=""
QUIT
A3 ; Rearrange lookup values and for new index
+1 NEW DIV,DIS
+2 MERGE DIS("S")=DISCREEN("S"),DIS("F")=DISCREEN("F")
+3 FOR I=1:1:DIX("#")
SET J=DIX(I)
Begin DoDot:1
+4 if DIVALUE(J)=""
QUIT
+5 MERGE DIV(I)=DIVALUE(J),DIS(I)=DISCREEN(J)
+6 KILL DIVALUE(J),DISCREEN(J)
QUIT
End DoDot:1
A4 ; Build screening logic for fields whose lookup values are not on new index.
+1 FOR J=0:0
SET J=$ORDER(DIVALUE(J))
if 'J
QUIT
Begin DoDot:1
+2 MERGE DIS("VAL",J)=DIVALUE(J)
+3 IF $DATA(DISCREEN(J))
Begin DoDot:2
+4 SET X="DINDEX("
SET Z="DISCREEN(""VAL"","
+5 FOR K=0:0
SET K=$ORDER(DISCREEN(J,K))
if 'K
QUIT
SET Y=DISCREEN(J,K)
IF Y[X
SET DISCREEN(J,K)=""
FOR
if Y'[X
QUIT
Begin DoDot:3
+6 NEW L,S
SET S=$PIECE(Y,X)
SET L=$LENGTH(S_X)
SET S=S_Z
SET Y=$EXTRACT(Y,L+1,$LENGTH(Y))
+7 SET DISCREEN(J,K)=DISCREEN(J,K)_S
+8 IF Y'[X
SET DISCREEN(J,K)=DISCREEN(J,K)_Y
+9 QUIT
End DoDot:3
+10 MERGE DIS("X",J)=DISCREEN(J)
QUIT
End DoDot:2
+11 NEW DICODE,DINODE
+12 DO GET^DICUIX1(DIFILE,DIFILE,DINDEX(J,"FIELD"),.DINODE,.DICODE)
+13 IF "PVSD"'[DINDEX(J,"TYPE")
SET DIS("X",J,"GET")="S DIVAL="_DICODE
QUIT
+14 SET DIS("X",J,"GET")="S DIVAL=$$EXTERNAL^DIDU("_DIFILE_","_DINDEX(J,"FIELD")_","""","_DICODE_")"
+15 Begin DoDot:2
+16 NEW DISAVJ
SET DISAVJ=J
NEW J
+17 SET X=$$EXTERNAL^DIDU(DINDEX(DISAVJ,"FILE"),DINDEX(DISAVJ,"FIELD"),"",DIS("VAL",DISAVJ),"DIERR")
+18 SET J=$ORDER(DIS("VAL",DISAVJ,99999),-1)+1
+19 SET DIS("VAL",DISAVJ,J)=X
QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 KILL DINDEX
SET DINDEX=DIX
SET DINDEX("WAY")=DIX("WAY")
+22 IF DIFLAGS["l"
SET DINDEX("START")=DIX
SET DINDEX("OLDSUB")=DIX("OLDSUB")
+23 KILL DISCREEN,DIVALUE
MERGE DISCREEN=DIS,DIVALUE=DIV
KILL DIS,DIV
+24 DO INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN)
+25 DO XFORM^DICF1(DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX)
+26 QUIT
+27 ;
IDXOK(DINDEX,DIFILE,DIX,DIXIEN,DIVALUE) ; Return alternate index name DIX if it has no set/kill conditions and all subscripts are fields from original index DINDEX.
+1 IF '$GET(DIXIEN)
SET DIXIEN=$ORDER(^DD("IX","BB",DIFILE,DIX,0))
IF 'DIXIEN
SET DIX=""
QUIT
+2 IF $GET(^DD("IX",DIXIEN,1.4))]""!($GET(^(2.4))]"")
SET DIX=""
QUIT
+3 NEW I,J,X,DIFIELD,DISKIP
SET DISKIP=1
IF $ORDER(DIVALUE(0))
SET DIX("#")=0
+4 FOR I=0:0
SET I=$ORDER(^DD("IX",DIXIEN,11.1,"AC",I))
if 'I
QUIT
SET DISKIP=1
Begin DoDot:1
+5 SET X=$GET(^DD("IX",DIXIEN,11.1,I,0))
+6 if $PIECE(X,U,3)'=DIFILE
QUIT
if $PIECE(X,U,6)'=I
QUIT
SET DIFIELD=$PIECE(X,U,4)
if 'DIFIELD
QUIT
+7 if $GET(^DD("IX",DIXIEN,11.1,I,2))]""
QUIT
+8 IF '$ORDER(DIVALUE(0))
SET DISKIP=0
QUIT
+9 FOR J=1:1:DINDEX("#")
Begin DoDot:2
+10 if DINDEX(J,"FIELD")'=DIFIELD
QUIT
+11 IF I=1
IF DIVALUE(J)=""
QUIT
+12 SET DIX(I)=J
SET DISKIP=0
QUIT
End DoDot:2
if 'DISKIP
QUIT
+13 IF 'DISKIP
SET DIX("#")=DIX("#")+1
+14 QUIT
End DoDot:1
if DISKIP
QUIT
+15 IF DISKIP
SET DIX=""
QUIT
+16 QUIT
+17 ;
