ADEXCOD.m

ADEXCOD ; IHS/HQT/MJL  - UPDATE ADA CODE FILE ;08:42 PM  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;------->INIT

 S U="^"

 I $D(^ADEXCOD)<10 D  K DIFQ G END1

 . W !!,*7,"The ADEXCOD global must be restored before installing the IHS DENTAL package.",!,"Please review the installation instructions."

 I $P(^ADEXCOD(0),U)'["9-1-94" D  K DIFQ G END1

 . W !!,*7,"The CURRENT VERSION of the ADEXCOD global must be restored",!,"before installing the IHS DENTAL package.  Please review the installation",!,"instructions."

 ;

CONF S %=0

 W !,"Did you back up the ^AUTTADA global before beginning this installation"

 D YN^DICN

 I %=0 W !?5,"Answer NO if you did not save a backup of the ^AUTTADA global before",!,"beginning this installation.",! G CONF

 I %'=1 W !!,"Back up ^AUTTADA before installing the IHS DENTAL package.",!,"Keep the backup on file." K DIFQ G END1

 W !!,"CHECKING FOR DUPLICATE CODES AND REINDEXING"

 D ^ADEXCOD2

 W !!,"UPDATING ADA CODE FILE NOW."

 ;W !,"TEST--SKIPPING UPDATE" G END ;***COMMENT AND KEEP

 ;Set Input Transforms

 S ADEY=0

 F ADEX=.01:.01:.09,8801 S ADEY=ADEY+1,ADEXFRM(ADEY)=$P(^DD(9999999.31,ADEX,0),U,5,99)

 S ADECOD=0,ADEXFRM(8)=""

CTRL ;------->$O THRU TEMPFILE ^ADEXCOD AND GET CODE

 S ADECOD=$O(^ADEXCOD("B",ADECOD)) G:ADECOD="" END

 S ADEZDFN=0 W "." S ADEZDFN=$O(^ADEXCOD("B",ADECOD,ADEZDFN))

 ;------->IF CODE IN ^AUTTADA, UPDATE

 I $D(^AUTTADA("B",ADECOD)) D UPDATE G CTRL

 ;------->OTHERWISE ADD IT

 D ADD G CTRL

END W !,"ADA CODE File update done!"

END1 K ADERROR,ADEODFN,ADEZDFN,ADECOD,ADEOMN,ADEX,ADEY,ADEXFRM,ADENOD

 ;

RESTYP ;Re-index DENTAL RESOURCE TYPE file

 Q:'$D(^ADERSCT)

 W !!,"Re-indexing the DENTAL RESOURCE TYPE file - please wait.",!

 K ^ADERSCT("B") ;Kill "b" x-ref prior to re-index

 S DIK="^ADERSCT("

 D IXALL^DIK

 Q

 ;

UPDATE S ADEODFN=0

 ;

U1 S ADEODFN=$O(^AUTTADA("B",ADECOD,ADEODFN))

 G:$O(^AUTTADA("B",ADECOD,ADEODFN))]"" U1

 ;KILL OLD "C" AND "D" XREFS

 I $P(^AUTTADA(ADEODFN,0),U,2)]"" K ^AUTTADA("C",$E($P(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)

 I $P(^AUTTADA(ADEODFN,0),U,6)]"" K ^AUTTADA("D",$E($P(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)

 ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0)

 S ADENOD=^ADEXCOD(ADEZDFN,0)

 F ADEX=1:1:9 D

 . S X=$P(ADENOD,U,ADEX)

 . Q:X=""

 . D  Q:'$D(X)  ;Apply input transform

 . . X ADEXFRM(ADEX)

 . S $P(^AUTTADA(ADEODFN,0),U,ADEX)=X

 D XREF

 K ^AUTTADA(ADEODFN,11) S:$D(^ADEXCOD(ADEZDFN,11,0)) ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)

 I $D(^ADEXCOD(ADEZDFN,11,0)) D TEXT

 I $D(^AUTTADA(ADEODFN,88)),^(88)]"" S ADEOMN=^AUTTADA(ADEODFN,88) K ^AUTTADA("B",ADEOMN),^AUTTADA(ADEODFN,88)

 I $D(^ADEXCOD(ADEZDFN,88)),^(88)]"" D

 . S X=^ADEXCOD(ADEZDFN,88)

 . X ADEXFRM(10) ;Apply input transform

 . Q:'$D(X)

 . S ^AUTTADA(ADEODFN,88)=X,^AUTTADA("B",$E(X,1,30),ADEODFN)=1

 Q

ADD S ADEODFN=$P(^AUTTADA(0),U,3)+1

A1 I $D(^AUTTADA(ADEODFN)) S ADEODFN=ADEODFN+1 G A1

 ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0) D XREF

 S ADENOD=^ADEXCOD(ADEZDFN,0)

 S ADEXFRM(8)=""

 F ADEX=1:1:9 D

 . S X=$P(ADENOD,U,ADEX)

 . Q:X=""

 . D  Q:'$D(X)  ;Apply input transform

 . . X ADEXFRM(ADEX)

 . S $P(^AUTTADA(ADEODFN,0),U,ADEX)=X

 D XREF

 S ^AUTTADA("B",$E(ADECOD,1,30),ADEODFN)=""

 I $D(^ADEXCOD(ADEZDFN,11,0)) D

 . S ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)

 . D TEXT

 I $D(^ADEXCOD(ADEZDFN,88)),^(88)]"" D

 . S X=^ADEXCOD(ADEZDFN,88)

 . X ADEXFRM(10) ;Apply input transform

 . Q:'$D(X)

 . S ^AUTTADA(ADEODFN,88)=X,^AUTTADA("B",$E(X,1,30),ADEODFN)=1

 S $P(^AUTTADA(0),U,3)=ADEODFN,$P(^(0),U,4)=$P(^(0),U,4)+1

 Q

TEXT S ADETXT=0

 ;NOTE:  There is NO input transform for the field set in next line

 ;because it is a Fileman word-processing field and Fileman doesn't

 ;put input-transforms on wp fields.

 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)

 Q

XREF S:$P(^AUTTADA(ADEODFN,0),U,2)]"" ^AUTTADA("C",$E($P(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)=""

 S:$P(^AUTTADA(ADEODFN,0),U,6)]"" ^AUTTADA("D",$E($P(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)=""

 S ^AUTTADA("BA",ADECOD_" ",ADEODFN)=""

 Q

ADEXCOD   ; IHS/HQT/MJL  - UPDATE ADA CODE FILE ;08:42 PM  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;------->INIT

 +3        SET U="^"

 +4        IF $DATA(^ADEXCOD)<10

               Begin DoDot:1

 +5                WRITE !!,*7,"The ADEXCOD global must be restored before installing the IHS DENTAL package.",!,"Please review the installation instructions."

               End DoDot:1

               KILL DIFQ

               GOTO END1

 +6        IF $PIECE(^ADEXCOD(0),U)'["9-1-94"

               Begin DoDot:1

 +7                WRITE !!,*7,"The CURRENT VERSION of the ADEXCOD global must be restored",!,"before installing the IHS DENTAL package.  Please review the installation",!,"instructions."

               End DoDot:1

               KILL DIFQ

               GOTO END1

 +8       ;

CONF       SET %=0

 +1        WRITE !,"Did you back up the ^AUTTADA global before beginning this installation"

 +2        DO YN^DICN

 +3        IF %=0

               WRITE !?5,"Answer NO if you did not save a backup of the ^AUTTADA global before",!,"beginning this installation.",!

               GOTO CONF

 +4        IF %'=1

               WRITE !!,"Back up ^AUTTADA before installing the IHS DENTAL package.",!,"Keep the backup on file."

               KILL DIFQ

               GOTO END1

 +5        WRITE !!,"CHECKING FOR DUPLICATE CODES AND REINDEXING"

 +6        DO ^ADEXCOD2

 +7        WRITE !!,"UPDATING ADA CODE FILE NOW."

 +8       ;W !,"TEST--SKIPPING UPDATE" G END ;***COMMENT AND KEEP

 +9       ;Set Input Transforms

 +10       SET ADEY=0

 +11       FOR ADEX=.01:.01:.09,8801

               SET ADEY=ADEY+1

               SET ADEXFRM(ADEY)=$PIECE(^DD(9999999.31,ADEX,0),U,5,99)

 +12       SET ADECOD=0

           SET ADEXFRM(8)=""

CTRL      ;------->$O THRU TEMPFILE ^ADEXCOD AND GET CODE

 +1        SET ADECOD=$ORDER(^ADEXCOD("B",ADECOD))

           IF ADECOD=""

               GOTO END

 +2        SET ADEZDFN=0

           WRITE "."

           SET ADEZDFN=$ORDER(^ADEXCOD("B",ADECOD,ADEZDFN))

 +3       ;------->IF CODE IN ^AUTTADA, UPDATE

 +4        IF $DATA(^AUTTADA("B",ADECOD))

               DO UPDATE

               GOTO CTRL

 +5       ;------->OTHERWISE ADD IT

 +6        DO ADD

           GOTO CTRL

END        WRITE !,"ADA CODE File update done!"

END1       KILL ADERROR,ADEODFN,ADEZDFN,ADECOD,ADEOMN,ADEX,ADEY,ADEXFRM,ADENOD

 +1       ;

RESTYP    ;Re-index DENTAL RESOURCE TYPE file

 +1        IF '$DATA(^ADERSCT)

               QUIT 

 +2        WRITE !!,"Re-indexing the DENTAL RESOURCE TYPE file - please wait.",!

 +3       ;Kill "b" x-ref prior to re-index

           KILL ^ADERSCT("B")

 +4        SET DIK="^ADERSCT("

 +5        DO IXALL^DIK

 +6        QUIT 

 +7       ;

UPDATE     SET ADEODFN=0

 +1       ;

U1         SET ADEODFN=$ORDER(^AUTTADA("B",ADECOD,ADEODFN))

 +1        IF $ORDER(^AUTTADA("B",ADECOD,ADEODFN))]""

               GOTO U1

 +2       ;KILL OLD "C" AND "D" XREFS

 +3        IF $PIECE(^AUTTADA(ADEODFN,0),U,2)]""

               KILL ^AUTTADA("C",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)

 +4        IF $PIECE(^AUTTADA(ADEODFN,0),U,6)]""

               KILL ^AUTTADA("D",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)

 +5       ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0)

 +6        SET ADENOD=^ADEXCOD(ADEZDFN,0)

 +7        FOR ADEX=1:1:9

               Begin DoDot:1

 +8                SET X=$PIECE(ADENOD,U,ADEX)

 +9                IF X=""

                       QUIT 

 +10      ;Apply input transform

                   Begin DoDot:2

 +11                   XECUTE ADEXFRM(ADEX)

                   End DoDot:2

                   IF '$DATA(X)

                       QUIT 

 +12               SET $PIECE(^AUTTADA(ADEODFN,0),U,ADEX)=X

               End DoDot:1

 +13       DO XREF

 +14       KILL ^AUTTADA(ADEODFN,11)

           IF $DATA(^ADEXCOD(ADEZDFN,11,0))

               SET ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)

 +15       IF $DATA(^ADEXCOD(ADEZDFN,11,0))

               DO TEXT

 +16       IF $DATA(^AUTTADA(ADEODFN,88))

               IF ^(88)]""

                   SET ADEOMN=^AUTTADA(ADEODFN,88)

                   KILL ^AUTTADA("B",ADEOMN),^AUTTADA(ADEODFN,88)

 +17       IF $DATA(^ADEXCOD(ADEZDFN,88))

               IF ^(88)]""

                   Begin DoDot:1

 +18                   SET X=^ADEXCOD(ADEZDFN,88)

 +19      ;Apply input transform

                       XECUTE ADEXFRM(10)

 +20                   IF '$DATA(X)

                           QUIT 

 +21                   SET ^AUTTADA(ADEODFN,88)=X

                       SET ^AUTTADA("B",$EXTRACT(X,1,30),ADEODFN)=1

                   End DoDot:1

 +22       QUIT 

ADD        SET ADEODFN=$PIECE(^AUTTADA(0),U,3)+1

A1         IF $DATA(^AUTTADA(ADEODFN))

               SET ADEODFN=ADEODFN+1

               GOTO A1

 +1       ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0) D XREF

 +2        SET ADENOD=^ADEXCOD(ADEZDFN,0)

 +3        SET ADEXFRM(8)=""

 +4        FOR ADEX=1:1:9

               Begin DoDot:1

 +5                SET X=$PIECE(ADENOD,U,ADEX)

 +6                IF X=""

                       QUIT 

 +7       ;Apply input transform

                   Begin DoDot:2

 +8                    XECUTE ADEXFRM(ADEX)

                   End DoDot:2

                   IF '$DATA(X)

                       QUIT 

 +9                SET $PIECE(^AUTTADA(ADEODFN,0),U,ADEX)=X

               End DoDot:1

 +10       DO XREF

 +11       SET ^AUTTADA("B",$EXTRACT(ADECOD,1,30),ADEODFN)=""

 +12       IF $DATA(^ADEXCOD(ADEZDFN,11,0))

               Begin DoDot:1

 +13               SET ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)

 +14               DO TEXT

               End DoDot:1

 +15       IF $DATA(^ADEXCOD(ADEZDFN,88))

               IF ^(88)]""

                   Begin DoDot:1

 +16                   SET X=^ADEXCOD(ADEZDFN,88)

 +17      ;Apply input transform

                       XECUTE ADEXFRM(10)

 +18                   IF '$DATA(X)

                           QUIT 

 +19                   SET ^AUTTADA(ADEODFN,88)=X

                       SET ^AUTTADA("B",$EXTRACT(X,1,30),ADEODFN)=1

                   End DoDot:1

 +20       SET $PIECE(^AUTTADA(0),U,3)=ADEODFN

           SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1

 +21       QUIT 

TEXT       SET ADETXT=0

 +1       ;NOTE:  There is NO input transform for the field set in next line

 +2       ;because it is a Fileman word-processing field and Fileman doesn't

 +3       ;put input-transforms on wp fields.

 +4        FOR 

               SET ADETXT=$ORDER(^ADEXCOD(ADEZDFN,11,ADETXT))

               IF '+ADETXT

                   QUIT 

               IF $DATA(^ADEXCOD(ADEZDFN,11,ADETXT,0))

                   SET ^AUTTADA(ADEODFN,11,ADETXT,0)=^ADEXCOD(ADEZDFN,11,ADETXT,0)

 +5        QUIT 

XREF       IF $PIECE(^AUTTADA(ADEODFN,0),U,2)]""

               SET ^AUTTADA("C",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)=""

 +1        IF $PIECE(^AUTTADA(ADEODFN,0),U,6)]""

               SET ^AUTTADA("D",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)=""

 +2        SET ^AUTTADA("BA",ADECOD_" ",ADEODFN)=""

 +3        QUIT