Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ADEXCOD2

ADEXCOD2.m

Go to the documentation of this file.
  1. 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
  1. ;CHECK FOR DUPES IN AUTTADA
  1. D DUPE
  1. ;KILL AND REBUILD ALL XREFS
  1. D REBLD
  1. ;
  1. END K ^ADEUTIL("ADEXCOD") ;^ADEUTIL("ADEXCOD") transient global
  1. Q
  1. ;
  1. DUPE N ADEX,ADECOD,ADE,ADEXFRM
  1. K ^ADEUTIL("ADEXCOD")
  1. S ADEX=0 F S ADEX=$O(^AUTTADA(ADEX)) Q:'+ADEX D D1
  1. Q
  1. D1 W "." ;***TEST FOR INTERACTIVE MODE
  1. Q:$P(^AUTTADA(ADEX,0),U,8)]"" ;FHL 9/9/98;IHS/HMW P2
  1. S ADECOD=$P(^AUTTADA(ADEX,0),U)
  1. I $D(^ADEUTIL("ADEXCOD",ADECOD)) D FIX
  1. S ^ADEUTIL("ADEXCOD",ADECOD)=ADEX ;transient working global
  1. Q
  1. FIX ;IF DUPES ARE LOCATED, SET EARLIEST ONE(S) (BY DFN) TO INACTIVE
  1. ; (IF IT'S NOT INACTIVE ALREADY)
  1. S ADE("FIRST")=^ADEUTIL("ADEXCOD",ADECOD)
  1. W !,"Duplicate Code ",ADECOD," at DFN ",ADE("FIRST")," and ",ADEX,".",!,"Code at DFN ",ADE("FIRST")," inactive. Inactivation date: "
  1. I $P(^AUTTADA(ADE("FIRST"),0),U,8)="" D Q
  1. . S X=DT
  1. . S ADEXFRM=$P(^DD(9999999.31,.08,0),U,5,99) ;Input Transform
  1. . W "TODAY"
  1. . X ADEXFRM
  1. . S:$D(X) $P(^AUTTADA(ADE("FIRST"),0),U,8)=X
  1. S Y=$P(^AUTTADA(ADE("FIRST"),0),U,8) X ^DD("DD") W Y,!
  1. Q
  1. ;
  1. REBLD ;
  1. N ADEX
  1. ;Kill cross-references prior to reindex:
  1. F ADEX="B","BA","C","D","AC" K ^AUTTADA(ADEX)
  1. S DIK="^AUTTADA("
  1. D IXALL^DIK
  1. Q