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

ADEXCOD.m

Go to the documentation of this file.
  1. ADEXCOD ; IHS/HQT/MJL - UPDATE ADA CODE FILE ;08:42 PM [ 03/24/1999 9:04 AM ]
  1. ;;6.0;ADE;;APRIL 1999
  1. ;------->INIT
  1. S U="^"
  1. I $D(^ADEXCOD)<10 D K DIFQ G END1
  1. . W !!,*7,"The ADEXCOD global must be restored before installing the IHS DENTAL package.",!,"Please review the installation instructions."
  1. I $P(^ADEXCOD(0),U)'["9-1-94" D K DIFQ G END1
  1. . W !!,*7,"The CURRENT VERSION of the ADEXCOD global must be restored",!,"before installing the IHS DENTAL package. Please review the installation",!,"instructions."
  1. ;
  1. CONF S %=0
  1. W !,"Did you back up the ^AUTTADA global before beginning this installation"
  1. D YN^DICN
  1. I %=0 W !?5,"Answer NO if you did not save a backup of the ^AUTTADA global before",!,"beginning this installation.",! G CONF
  1. I %'=1 W !!,"Back up ^AUTTADA before installing the IHS DENTAL package.",!,"Keep the backup on file." K DIFQ G END1
  1. W !!,"CHECKING FOR DUPLICATE CODES AND REINDEXING"
  1. D ^ADEXCOD2
  1. W !!,"UPDATING ADA CODE FILE NOW."
  1. ;W !,"TEST--SKIPPING UPDATE" G END ;***COMMENT AND KEEP
  1. ;Set Input Transforms
  1. S ADEY=0
  1. F ADEX=.01:.01:.09,8801 S ADEY=ADEY+1,ADEXFRM(ADEY)=$P(^DD(9999999.31,ADEX,0),U,5,99)
  1. S ADECOD=0,ADEXFRM(8)=""
  1. CTRL ;------->$O THRU TEMPFILE ^ADEXCOD AND GET CODE
  1. S ADECOD=$O(^ADEXCOD("B",ADECOD)) G:ADECOD="" END
  1. S ADEZDFN=0 W "." S ADEZDFN=$O(^ADEXCOD("B",ADECOD,ADEZDFN))
  1. ;------->IF CODE IN ^AUTTADA, UPDATE
  1. I $D(^AUTTADA("B",ADECOD)) D UPDATE G CTRL
  1. ;------->OTHERWISE ADD IT
  1. D ADD G CTRL
  1. END W !,"ADA CODE File update done!"
  1. END1 K ADERROR,ADEODFN,ADEZDFN,ADECOD,ADEOMN,ADEX,ADEY,ADEXFRM,ADENOD
  1. ;
  1. RESTYP ;Re-index DENTAL RESOURCE TYPE file
  1. Q:'$D(^ADERSCT)
  1. W !!,"Re-indexing the DENTAL RESOURCE TYPE file - please wait.",!
  1. K ^ADERSCT("B") ;Kill "b" x-ref prior to re-index
  1. S DIK="^ADERSCT("
  1. D IXALL^DIK
  1. Q
  1. ;
  1. UPDATE S ADEODFN=0
  1. ;
  1. U1 S ADEODFN=$O(^AUTTADA("B",ADECOD,ADEODFN))
  1. G:$O(^AUTTADA("B",ADECOD,ADEODFN))]"" U1
  1. ;KILL OLD "C" AND "D" XREFS
  1. I $P(^AUTTADA(ADEODFN,0),U,2)]"" K ^AUTTADA("C",$E($P(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)
  1. I $P(^AUTTADA(ADEODFN,0),U,6)]"" K ^AUTTADA("D",$E($P(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)
  1. ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0)
  1. S ADENOD=^ADEXCOD(ADEZDFN,0)
  1. F ADEX=1:1:9 D
  1. . S X=$P(ADENOD,U,ADEX)
  1. . Q:X=""
  1. . D Q:'$D(X) ;Apply input transform
  1. . . X ADEXFRM(ADEX)
  1. . S $P(^AUTTADA(ADEODFN,0),U,ADEX)=X
  1. D XREF
  1. K ^AUTTADA(ADEODFN,11) S:$D(^ADEXCOD(ADEZDFN,11,0)) ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)
  1. I $D(^ADEXCOD(ADEZDFN,11,0)) D TEXT
  1. I $D(^AUTTADA(ADEODFN,88)),^(88)]"" S ADEOMN=^AUTTADA(ADEODFN,88) K ^AUTTADA("B",ADEOMN),^AUTTADA(ADEODFN,88)
  1. I $D(^ADEXCOD(ADEZDFN,88)),^(88)]"" D
  1. . S X=^ADEXCOD(ADEZDFN,88)
  1. . X ADEXFRM(10) ;Apply input transform
  1. . Q:'$D(X)
  1. . S ^AUTTADA(ADEODFN,88)=X,^AUTTADA("B",$E(X,1,30),ADEODFN)=1
  1. Q
  1. ADD S ADEODFN=$P(^AUTTADA(0),U,3)+1
  1. A1 I $D(^AUTTADA(ADEODFN)) S ADEODFN=ADEODFN+1 G A1
  1. ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0) D XREF
  1. S ADENOD=^ADEXCOD(ADEZDFN,0)
  1. S ADEXFRM(8)=""
  1. F ADEX=1:1:9 D
  1. . S X=$P(ADENOD,U,ADEX)
  1. . Q:X=""
  1. . D Q:'$D(X) ;Apply input transform
  1. . . X ADEXFRM(ADEX)
  1. . S $P(^AUTTADA(ADEODFN,0),U,ADEX)=X
  1. D XREF
  1. S ^AUTTADA("B",$E(ADECOD,1,30),ADEODFN)=""
  1. I $D(^ADEXCOD(ADEZDFN,11,0)) D
  1. . S ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)
  1. . D TEXT
  1. I $D(^ADEXCOD(ADEZDFN,88)),^(88)]"" D
  1. . S X=^ADEXCOD(ADEZDFN,88)
  1. . X ADEXFRM(10) ;Apply input transform
  1. . Q:'$D(X)
  1. . S ^AUTTADA(ADEODFN,88)=X,^AUTTADA("B",$E(X,1,30),ADEODFN)=1
  1. S $P(^AUTTADA(0),U,3)=ADEODFN,$P(^(0),U,4)=$P(^(0),U,4)+1
  1. Q
  1. TEXT S ADETXT=0
  1. ;NOTE: There is NO input transform for the field set in next line
  1. ;because it is a Fileman word-processing field and Fileman doesn't
  1. ;put input-transforms on wp fields.
  1. F S ADETXT=$O(^ADEXCOD(ADEZDFN,11,ADETXT)) Q:'+ADETXT S:$D(^ADEXCOD(ADEZDFN,11,ADETXT,0)) ^AUTTADA(ADEODFN,11,ADETXT,0)=^ADEXCOD(ADEZDFN,11,ADETXT,0)
  1. Q
  1. XREF S:$P(^AUTTADA(ADEODFN,0),U,2)]"" ^AUTTADA("C",$E($P(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)=""
  1. S:$P(^AUTTADA(ADEODFN,0),U,6)]"" ^AUTTADA("D",$E($P(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)=""
  1. S ^AUTTADA("BA",ADECOD_" ",ADEODFN)=""
  1. Q