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
