ADEXCOD2.m

ADEXCOD2 ; IHS/HQT/MJL - UPDATE ADA CODE FILE PART 3 ;08:45 PM  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;CHECK FOR DUPES IN AUTTADA

 D DUPE

 ;KILL AND REBUILD ALL XREFS

 D REBLD

 ;

END K ^ADEUTIL("ADEXCOD") ;^ADEUTIL("ADEXCOD") transient global

 Q

 ;

DUPE N ADEX,ADECOD,ADE,ADEXFRM

 K ^ADEUTIL("ADEXCOD")

 S ADEX=0 F  S ADEX=$O(^AUTTADA(ADEX)) Q:'+ADEX  D D1

 Q

D1 W "." ;***TEST FOR INTERACTIVE MODE

 Q:$P(^AUTTADA(ADEX,0),U,8)]""  ;FHL 9/9/98;IHS/HMW P2

 S ADECOD=$P(^AUTTADA(ADEX,0),U)

 I $D(^ADEUTIL("ADEXCOD",ADECOD)) D FIX

 S ^ADEUTIL("ADEXCOD",ADECOD)=ADEX ;transient working global

 Q

FIX ;IF DUPES ARE LOCATED, SET EARLIEST ONE(S) (BY DFN) TO INACTIVE

 ;      (IF IT'S NOT INACTIVE ALREADY)

 S ADE("FIRST")=^ADEUTIL("ADEXCOD",ADECOD)

 W !,"Duplicate Code ",ADECOD," at DFN ",ADE("FIRST")," and ",ADEX,".",!,"Code at DFN ",ADE("FIRST")," inactive. Inactivation date: "

 I $P(^AUTTADA(ADE("FIRST"),0),U,8)="" D  Q

 . S X=DT

 . S ADEXFRM=$P(^DD(9999999.31,.08,0),U,5,99) ;Input Transform

 . W "TODAY"

 . X ADEXFRM

 . S:$D(X) $P(^AUTTADA(ADE("FIRST"),0),U,8)=X

 S Y=$P(^AUTTADA(ADE("FIRST"),0),U,8) X ^DD("DD") W Y,!

 Q

 ;

REBLD ;

 N ADEX

 ;Kill cross-references prior to reindex:

 F ADEX="B","BA","C","D","AC" K ^AUTTADA(ADEX)

 S DIK="^AUTTADA("

 D IXALL^DIK

 Q

ADEXCOD2  ; IHS/HQT/MJL - UPDATE ADA CODE FILE PART 3 ;08:45 PM  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;CHECK FOR DUPES IN AUTTADA

 +3        DO DUPE

 +4       ;KILL AND REBUILD ALL XREFS

 +5        DO REBLD

 +6       ;

END       ;^ADEUTIL("ADEXCOD") transient global

           KILL ^ADEUTIL("ADEXCOD")

 +1        QUIT 

 +2       ;

DUPE       NEW ADEX,ADECOD,ADE,ADEXFRM

 +1        KILL ^ADEUTIL("ADEXCOD")

 +2        SET ADEX=0

           FOR 

               SET ADEX=$ORDER(^AUTTADA(ADEX))

               IF '+ADEX

                   QUIT 

               DO D1

 +3        QUIT 

D1        ;***TEST FOR INTERACTIVE MODE

           WRITE "."

 +1       ;FHL 9/9/98;IHS/HMW P2

           IF $PIECE(^AUTTADA(ADEX,0),U,8)]""

               QUIT 

 +2        SET ADECOD=$PIECE(^AUTTADA(ADEX,0),U)

 +3        IF $DATA(^ADEUTIL("ADEXCOD",ADECOD))

               DO FIX

 +4       ;transient working global

           SET ^ADEUTIL("ADEXCOD",ADECOD)=ADEX

 +5        QUIT 

FIX       ;IF DUPES ARE LOCATED, SET EARLIEST ONE(S) (BY DFN) TO INACTIVE

 +1       ;      (IF IT'S NOT INACTIVE ALREADY)

 +2        SET ADE("FIRST")=^ADEUTIL("ADEXCOD",ADECOD)

 +3        WRITE !,"Duplicate Code ",ADECOD," at DFN ",ADE("FIRST")," and ",ADEX,".",!,"Code at DFN ",ADE("FIRST")," inactive. Inactivation date: "

 +4        IF $PIECE(^AUTTADA(ADE("FIRST"),0),U,8)=""

               Begin DoDot:1

 +5                SET X=DT

 +6       ;Input Transform

                   SET ADEXFRM=$PIECE(^DD(9999999.31,.08,0),U,5,99)

 +7                WRITE "TODAY"

 +8                XECUTE ADEXFRM

 +9                IF $DATA(X)

                       SET $PIECE(^AUTTADA(ADE("FIRST"),0),U,8)=X

               End DoDot:1

               QUIT 

 +10       SET Y=$PIECE(^AUTTADA(ADE("FIRST"),0),U,8)

           XECUTE ^DD("DD")

           WRITE Y,!

 +11       QUIT 

 +12      ;

REBLD     ;

 +1        NEW ADEX

 +2       ;Kill cross-references prior to reindex:

 +3        FOR ADEX="B","BA","C","D","AC"

               KILL ^AUTTADA(ADEX)

 +4        SET DIK="^AUTTADA("

 +5        DO IXALL^DIK

 +6        QUIT