DICF0.m

DICF0 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, get alternate index ;2/8/00  11:11 [ 04/02/2003   8:25 AM ]

 ;;22.0;VA FileMan;**1001**;APR 1, 2003

 ;;22.0;VA FileMan;**28**;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

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

 ;

DICF0     ;SEA/TOAD,SF/TKW-VA FileMan: Finder, get alternate index ;2/8/00  11:11 [ 04/02/2003   8:25 AM ]

 +1       ;;22.0;VA FileMan;**1001**;APR 1, 2003

 +2       ;;22.0;VA FileMan;**28**;Mar 30, 1999

 +3       ;Per VHA Directive 10-93-142, this routine should not be modified.

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      ;