ADE6P21.m

ADE6P21 ;IHS/OIT/ENM - ADE6.0 PATCH 21 NO OPSITE MOD [ 06/4/2010 16:25 PM ]

 ;;6.0;ADE;**21**;MAR 25, 1999

 ;

MODADA ;EP

 D P1,P11,P2,P3,D4,D5,D6,D7,D8

 Q

P1 ;IHS/OIT/ENM 12/4/09

 ;No Opsite changes (set 'NO OPSITE' = n)

 N DIE,DR,DA,CODE

 F CODE="0170","0416","0431","0472","0473","0474","0475","0479","0480","0481","0484","0485",5225,5226,7260,7261,7286,7287,7288,7410,7411,7412,7413,7414,7415,7440,7441,7460,7461,7465 D

 .S DA=0

 .S DA=$O(^AUTTADA("B",CODE,DA))

 .S DIE="^AUTTADA(",DR=".09////"_"n" D ^DIE K DA,DIE,DR

 .Q

P11 ;IHS/OIT/ENM 06/04/10

 ;No Opsite changes (set 'NO OPSITE' = n)

 N DIE,DR,DA,CODE

 F CODE=7472,7473 D

 .S DA=0

 .S DA=$O(^AUTTADA("B",CODE,DA))

 .S DIE="^AUTTADA(",DR=".09////"_"n" D ^DIE K DA,DIE,DR

 .Q

P2 ;No Opsite changes (set 'NO OPSITE' = n)

 N DIE,DR,DA,CODE

 F CODE=7510,7511,7520,7521,7530,7540,7560,7871,7910,7911,7912,7981,7982,7983,7991,7999,9211,9221,9242,9920,"IH23","IH24","IH25","IH26","IH27","IH28","IH29","IH30","IH31","IH32" D

 .S DA=0

 .S DA=$O(^AUTTADA("B",CODE,DA))

 .S DIE="^AUTTADA(",DR=".09////"_"n" D ^DIE K DA,DIE,DR

 Q

P3 ;No Opsite changes(Delete 'NO OPSITE' fld)

 N DIE,DR,DA,CODE

 F CODE=5862,6055,6080,6090,6100,6920,7670 D

 .S DA=0

 .S DA=$O(^AUTTADA("B",CODE,DA))

 .S DIE="^AUTTADA(",DR=".09////"_"@" D ^DIE K DA,DIE,DR

 Q

D4 ;Set 'inactive field to date

 N DIE,DR,DA,CODE

 F CODE=5600,5900,9250,"IH54","IH59" D

 .S DA=0

 .S DA=$O(^AUTTADA("B",CODE,DA))

 .S DIE="^AUTTADA(",DR=".08////"_"3100606" D ^DIE K DA,DIE,DR

 Q

D5 ;Edit Dent Oper Site Name

 N DIE,DR,DA,CODE,IRN

 S IRN=0,MNIC="",ONAM=""

 F  S IRN=$O(^ADEOPS(IRN)) Q:'IRN  S ONAM=$P(^ADEOPS(IRN,0),"^",1),MNIC=^ADEOPS(IRN,88) D DCK

 Q

DCK ;

 S OPNAME="DECIDUOUS CENTRAL INCISOR, MAND RIGHT, SUPERNUMERARY"

 Q:MNIC'="ES"

 I ONAM=OPNAME D

 .S DA=IRN

 .S DIE="^ADEOPS(",DR=".01////"_"DECIDUOUS CENTRAL INCISOR, MAX RIGHT, SUPERNUMERARY" D ^DIE K DA,DIE,DR

 Q

D6 ;Edit Dent Oper Site Name

 N DIE,DR,DA,CODE,IRN

 S IRN=0,MNIC="",ONAM=""

 F  S IRN=$O(^ADEOPS(IRN)) Q:'IRN  S ONAM=$P(^ADEOPS(IRN,0),"^",1),MNIC=^ADEOPS(IRN,88) D DCK1

 Q

DCK1 ;

 S OPNAME="PERMANENT FIRST BICUSPID, MAX RIGHT, SUPERNUMERARY"

 Q:MNIC'=54

 I ONAM=OPNAME D

 .S DA=IRN

 .S DIE="^ADEOPS(",DR="8801////"_55 D ^DIE K DA,DIE,DR

 Q

D7 ;Edit Dent Oper Site Name

 N DIE,DR,DA,CODE

 F CODE="SUPRANUMERY #1","SUPRANUMERY #2","SUPRANUMERY #3","SUPRANUMERY #4" D

 .S DA=0

 .I $O(^ADEOPS("B",CODE_"(DO NOT USE)",0)) Q

 .S DA=$O(^ADEOPS("B",CODE,DA))

 .S DIE="^ADEOPS(",DR=".01////"_CODE_"(DO NOT USE)" D ^DIE K DA,DIE,DR,ONAM,OPNAME,MNIC

 Q

D8 ;Edit Dent Oper Site Name

 N DIE,DR,DA,CODE,IRN

 S IRN=0,MNIC="",ONAM=""

 F  S IRN=$O(^ADEOPS(IRN)) Q:'IRN  S ONAM=$P(^ADEOPS(IRN,0),"^",1),MNIC=^ADEOPS(IRN,88) D DXK

 Q

DXK ;

 S OPNAME="PERMANENT CENTRAL INCISOR, MAND RIGHT, SUPERNUMERARY"

 Q:MNIC'="58"

 I ONAM=OPNAME D

 .S DA=IRN

 .S DIE="^ADEOPS(",DR=".01////"_"PERMANENT CENTRAL INCISOR, MAX RIGHT, SUPERNUMERARY" D ^DIE K DA,DIE,DR

 Q

ADE6P21   ;IHS/OIT/ENM - ADE6.0 PATCH 21 NO OPSITE MOD [ 06/4/2010 16:25 PM ]

 +1       ;;6.0;ADE;**21**;MAR 25, 1999

 +2       ;

MODADA    ;EP

 +1        DO P1

           DO P11

           DO P2

           DO P3

           DO D4

           DO D5

           DO D6

           DO D7

           DO D8

 +2        QUIT 

P1        ;IHS/OIT/ENM 12/4/09

 +1       ;No Opsite changes (set 'NO OPSITE' = n)

 +2        NEW DIE,DR,DA,CODE

 +3        FOR CODE="0170","0416","0431","0472","0473","0474","0475","0479","0480","0481","0484","0485",5225,5226,7260,7261,7286,7287,7288,7410,7411,7412,7413,7414,7415,7440,7441,7460,7461,7465

               Begin DoDot:1

 +4                SET DA=0

 +5                SET DA=$ORDER(^AUTTADA("B",CODE,DA))

 +6                SET DIE="^AUTTADA("

                   SET DR=".09////"_"n"

                   DO ^DIE

                   KILL DA,DIE,DR

 +7                QUIT 

               End DoDot:1

P11       ;IHS/OIT/ENM 06/04/10

 +1       ;No Opsite changes (set 'NO OPSITE' = n)

 +2        NEW DIE,DR,DA,CODE

 +3        FOR CODE=7472,7473

               Begin DoDot:1

 +4                SET DA=0

 +5                SET DA=$ORDER(^AUTTADA("B",CODE,DA))

 +6                SET DIE="^AUTTADA("

                   SET DR=".09////"_"n"

                   DO ^DIE

                   KILL DA,DIE,DR

 +7                QUIT 

               End DoDot:1

P2        ;No Opsite changes (set 'NO OPSITE' = n)

 +1        NEW DIE,DR,DA,CODE

 +2        FOR CODE=7510,7511,7520,7521,7530,7540,7560,7871,7910,7911,7912,7981,7982,7983,7991,7999,9211,9221,9242,9920,"IH23","IH24","IH25","IH26","IH27","IH28","IH29","IH30","IH31","IH32"

               Begin DoDot:1

 +3                SET DA=0

 +4                SET DA=$ORDER(^AUTTADA("B",CODE,DA))

 +5                SET DIE="^AUTTADA("

                   SET DR=".09////"_"n"

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +6        QUIT 

P3        ;No Opsite changes(Delete 'NO OPSITE' fld)

 +1        NEW DIE,DR,DA,CODE

 +2        FOR CODE=5862,6055,6080,6090,6100,6920,7670

               Begin DoDot:1

 +3                SET DA=0

 +4                SET DA=$ORDER(^AUTTADA("B",CODE,DA))

 +5                SET DIE="^AUTTADA("

                   SET DR=".09////"_"@"

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +6        QUIT 

D4        ;Set 'inactive field to date

 +1        NEW DIE,DR,DA,CODE

 +2        FOR CODE=5600,5900,9250,"IH54","IH59"

               Begin DoDot:1

 +3                SET DA=0

 +4                SET DA=$ORDER(^AUTTADA("B",CODE,DA))

 +5                SET DIE="^AUTTADA("

                   SET DR=".08////"_"3100606"

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +6        QUIT 

D5        ;Edit Dent Oper Site Name

 +1        NEW DIE,DR,DA,CODE,IRN

 +2        SET IRN=0

           SET MNIC=""

           SET ONAM=""

 +3        FOR 

               SET IRN=$ORDER(^ADEOPS(IRN))

               IF 'IRN

                   QUIT 

               SET ONAM=$PIECE(^ADEOPS(IRN,0),"^",1)

               SET MNIC=^ADEOPS(IRN,88)

               DO DCK

 +4        QUIT 

DCK       ;

 +1        SET OPNAME="DECIDUOUS CENTRAL INCISOR, MAND RIGHT, SUPERNUMERARY"

 +2        IF MNIC'="ES"

               QUIT 

 +3        IF ONAM=OPNAME

               Begin DoDot:1

 +4                SET DA=IRN

 +5                SET DIE="^ADEOPS("

                   SET DR=".01////"_"DECIDUOUS CENTRAL INCISOR, MAX RIGHT, SUPERNUMERARY"

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +6        QUIT 

D6        ;Edit Dent Oper Site Name

 +1        NEW DIE,DR,DA,CODE,IRN

 +2        SET IRN=0

           SET MNIC=""

           SET ONAM=""

 +3        FOR 

               SET IRN=$ORDER(^ADEOPS(IRN))

               IF 'IRN

                   QUIT 

               SET ONAM=$PIECE(^ADEOPS(IRN,0),"^",1)

               SET MNIC=^ADEOPS(IRN,88)

               DO DCK1

 +4        QUIT 

DCK1      ;

 +1        SET OPNAME="PERMANENT FIRST BICUSPID, MAX RIGHT, SUPERNUMERARY"

 +2        IF MNIC'=54

               QUIT 

 +3        IF ONAM=OPNAME

               Begin DoDot:1

 +4                SET DA=IRN

 +5                SET DIE="^ADEOPS("

                   SET DR="8801////"_55

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +6        QUIT 

D7        ;Edit Dent Oper Site Name

 +1        NEW DIE,DR,DA,CODE

 +2        FOR CODE="SUPRANUMERY #1","SUPRANUMERY #2","SUPRANUMERY #3","SUPRANUMERY #4"

               Begin DoDot:1

 +3                SET DA=0

 +4                IF $ORDER(^ADEOPS("B",CODE_"(DO NOT USE)",0))

                       QUIT 

 +5                SET DA=$ORDER(^ADEOPS("B",CODE,DA))

 +6                SET DIE="^ADEOPS("

                   SET DR=".01////"_CODE_"(DO NOT USE)"

                   DO ^DIE

                   KILL DA,DIE,DR,ONAM,OPNAME,MNIC

               End DoDot:1

 +7        QUIT 

D8        ;Edit Dent Oper Site Name

 +1        NEW DIE,DR,DA,CODE,IRN

 +2        SET IRN=0

           SET MNIC=""

           SET ONAM=""

 +3        FOR 

               SET IRN=$ORDER(^ADEOPS(IRN))

               IF 'IRN

                   QUIT 

               SET ONAM=$PIECE(^ADEOPS(IRN,0),"^",1)

               SET MNIC=^ADEOPS(IRN,88)

               DO DXK

 +4        QUIT 

DXK       ;

 +1        SET OPNAME="PERMANENT CENTRAL INCISOR, MAND RIGHT, SUPERNUMERARY"

 +2        IF MNIC'="58"

               QUIT 

 +3        IF ONAM=OPNAME

               Begin DoDot:1

 +4                SET DA=IRN

 +5                SET DIE="^ADEOPS("

                   SET DR=".01////"_"PERMANENT CENTRAL INCISOR, MAX RIGHT, SUPERNUMERARY"

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +6        QUIT