ADEGRL5B ; IHS/HQT/MJL - DENTAL CODE EDITS PT 2 ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
RESOLVE ;EP - DO APPROPRIATE RESOLUTION
I ADERTYP=1 D R1
I ADERTYP=2 D R2
I ADERTYP=3 D R3
Q
R1 ;RESOLUTION 1 - REJECT CODE (WITH MESSAGE)
I '$D(ADEOPC) K ADEV(ADECOD)
I $D(ADEOPC),+ADEV(ADECOD)<2 K ADEV(ADECOD)
I $D(ADEOPC),$D(ADEV(ADECOD)) S ADEV(ADECOD)=$$DELOP^ADEGRL5C(ADEOPC,ADEV(ADECOD))
W !,ADECOD," " W:$D(ADEOPC) "OPSITE ",^ADEOPS(ADEOPC,88) W ": "
X ^ADEDIT(ADERDFN,3)
;W !,"Return data entry SLIP TO REPORTING DENTIST FOR CORRECTION"
S ADEXFLG=1
Q
R2 ;RESOLUTION 2 - CHANGE CODE -- ONLY NON OPSITE CODES
;HAVE TO PUT CHANGED CODE BACK THRU EDITS VIA RECURSION
;BUT BE CAREFUL OF ENDLESS LOOPS!
N ADETMP
S ADETMP=$P(^ADEDIT(ADERDFN,2),U,3)
I $D(ADEOPC) D R2A S ADEREDO=1 D R2CUR Q
I '$D(ADEOPC) D R2B S ADEREDO=1 D R2CUR Q
Q
R2CUR ;Call ADEGRL5A recursively
N ADECOD
S ADECOD=ADETMP
D ^ADEGRL5A
Q ;QUITTING R2CUR
R2A ;First, delete the opsite from current adev(adecod)
N ADESFC
S ADESFC=$$GETSFC^ADEGRL5C(ADEOPC,ADEV(ADECOD))
I +ADEV(ADECOD)<2 K ADEV(ADECOD),ADES(ADECOD)
E S ADEV(ADECOD)=$$DELOP^ADEGRL5C(ADEOPC,ADEV(ADECOD))
;next, if adev(adetmp) doesnt exist, create it
I '$D(ADEV(ADETMP)) S ADEV(ADETMP)="" S ADEDES(ADETMP)=$$DES^ADEGRL5B(ADETMP)
;next, add the opsite to adev(adetmp).
S ADEV(ADETMP)=$$ADDOP^ADEGRL5(ADEOPC,ADESFC,ADEV(ADETMP))
W !,ADECOD," OPSITE ",^ADEOPS(ADEOPC,88),": recoded to ",ADETMP
S ADEXFLG=1
Q
R2B S ADEV(ADETMP)=ADEV(ADECOD),ADEXFLG=1
W !,ADECOD," recoded to ",ADETMP
K ADEV(ADECOD),ADEDES(ADECOD)
S ADEDES(ADETMP)=$$DES(ADETMP)
Q
R3 ;RESOLUTION 3 - FLAG AS NON-REPORTABLE
I '$D(ADEOPC) S $P(ADEV(ADECOD),U,5)="y"
I $D(ADEOPC),+ADEV(ADECOD)<2 S $P(ADEV(ADECOD),U,5)="y"
I $D(ADEOPC),$D(ADEV(ADECOD)) S ADEV(ADECOD)=$$NONREP(ADEOPC,ADEV(ADECOD))
I $D(ADEOPC),'$D(ADENRP(ADECOD,ADEOPC)) W !,ADECOD," " W:$D(ADEOPC) "OPSITE ",^ADEOPS(ADEOPC,88) W ": " S ADENRP(ADECOD,ADEOPC)="" X ^ADEDIT(ADERDFN,3)
I '$D(ADEOPC),$D(ADENRP(ADECOD))'=1 W !,ADECOD,":" S ADENRP(ADECOD)="" X ^ADEDIT(ADERDFN,3)
S ADEXFLG=1
Q
;
RETURN ;EP - Press return to continue
N DIR
S DIR(0)="FAO^1:1",DIR("A")="Press 'Return' to continue... "
W ! D ^DIR
K DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
Q
;
DES(ADETMP) ;EP - Returns short description of ADA CODE ADETMP
S ADETMP=$O(^AUTTADA("B",ADETMP,0))
S ADETMP=$P(^AUTTADA(ADETMP,0),U,6)
Q ADETMP
;
NONREP(ADEOPC,ADEVCOD) ;Mark opsite ADEOPC in ADEVCOD unreportable
N ADETST,ADEJ,ADENONR
S ADETST=$P(ADEVCOD,U,2),ADENONR=$P(ADEVCOD,U,5)
F ADEJ=1:1:+ADEVCOD I ADEOPC=$P(ADETST,",",ADEJ) S $P(ADENONR,",",ADEJ)="y" Q
S $P(ADEVCOD,U,5)=ADENONR
Q ADEVCOD
K ADEVCOD ;*NE
ADEGRL5B ; IHS/HQT/MJL - DENTAL CODE EDITS PT 2 ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
RESOLVE ;EP - DO APPROPRIATE RESOLUTION
+1 IF ADERTYP=1
DO R1
+2 IF ADERTYP=2
DO R2
+3 IF ADERTYP=3
DO R3
+4 QUIT
R1 ;RESOLUTION 1 - REJECT CODE (WITH MESSAGE)
+1 IF '$DATA(ADEOPC)
KILL ADEV(ADECOD)
+2 IF $DATA(ADEOPC)
IF +ADEV(ADECOD)<2
KILL ADEV(ADECOD)
+3 IF $DATA(ADEOPC)
IF $DATA(ADEV(ADECOD))
SET ADEV(ADECOD)=$$DELOP^ADEGRL5C(ADEOPC,ADEV(ADECOD))
+4 WRITE !,ADECOD," "
IF $DATA(ADEOPC)
WRITE "OPSITE ",^ADEOPS(ADEOPC,88)
WRITE ": "
+5 XECUTE ^ADEDIT(ADERDFN,3)
+6 ;W !,"Return data entry SLIP TO REPORTING DENTIST FOR CORRECTION"
+7 SET ADEXFLG=1
+8 QUIT
R2 ;RESOLUTION 2 - CHANGE CODE -- ONLY NON OPSITE CODES
+1 ;HAVE TO PUT CHANGED CODE BACK THRU EDITS VIA RECURSION
+2 ;BUT BE CAREFUL OF ENDLESS LOOPS!
+3 NEW ADETMP
+4 SET ADETMP=$PIECE(^ADEDIT(ADERDFN,2),U,3)
+5 IF $DATA(ADEOPC)
DO R2A
SET ADEREDO=1
DO R2CUR
QUIT
+6 IF '$DATA(ADEOPC)
DO R2B
SET ADEREDO=1
DO R2CUR
QUIT
+7 QUIT
R2CUR ;Call ADEGRL5A recursively
+1 NEW ADECOD
+2 SET ADECOD=ADETMP
+3 DO ^ADEGRL5A
+4 ;QUITTING R2CUR
QUIT
R2A ;First, delete the opsite from current adev(adecod)
+1 NEW ADESFC
+2 SET ADESFC=$$GETSFC^ADEGRL5C(ADEOPC,ADEV(ADECOD))
+3 IF +ADEV(ADECOD)<2
KILL ADEV(ADECOD),ADES(ADECOD)
+4 IF '$TEST
SET ADEV(ADECOD)=$$DELOP^ADEGRL5C(ADEOPC,ADEV(ADECOD))
+5 ;next, if adev(adetmp) doesnt exist, create it
+6 IF '$DATA(ADEV(ADETMP))
SET ADEV(ADETMP)=""
SET ADEDES(ADETMP)=$$DES^ADEGRL5B(ADETMP)
+7 ;next, add the opsite to adev(adetmp).
+8 SET ADEV(ADETMP)=$$ADDOP^ADEGRL5(ADEOPC,ADESFC,ADEV(ADETMP))
+9 WRITE !,ADECOD," OPSITE ",^ADEOPS(ADEOPC,88),": recoded to ",ADETMP
+10 SET ADEXFLG=1
+11 QUIT
R2B SET ADEV(ADETMP)=ADEV(ADECOD)
SET ADEXFLG=1
+1 WRITE !,ADECOD," recoded to ",ADETMP
+2 KILL ADEV(ADECOD),ADEDES(ADECOD)
+3 SET ADEDES(ADETMP)=$$DES(ADETMP)
+4 QUIT
R3 ;RESOLUTION 3 - FLAG AS NON-REPORTABLE
+1 IF '$DATA(ADEOPC)
SET $PIECE(ADEV(ADECOD),U,5)="y"
+2 IF $DATA(ADEOPC)
IF +ADEV(ADECOD)<2
SET $PIECE(ADEV(ADECOD),U,5)="y"
+3 IF $DATA(ADEOPC)
IF $DATA(ADEV(ADECOD))
SET ADEV(ADECOD)=$$NONREP(ADEOPC,ADEV(ADECOD))
+4 IF $DATA(ADEOPC)
IF '$DATA(ADENRP(ADECOD,ADEOPC))
WRITE !,ADECOD," "
IF $DATA(ADEOPC)
WRITE "OPSITE ",^ADEOPS(ADEOPC,88)
WRITE ": "
SET ADENRP(ADECOD,ADEOPC)=""
XECUTE ^ADEDIT(ADERDFN,3)
+5 IF '$DATA(ADEOPC)
IF $DATA(ADENRP(ADECOD))'=1
WRITE !,ADECOD,":"
SET ADENRP(ADECOD)=""
XECUTE ^ADEDIT(ADERDFN,3)
+6 SET ADEXFLG=1
+7 QUIT
+8 ;
RETURN ;EP - Press return to continue
+1 NEW DIR
+2 SET DIR(0)="FAO^1:1"
SET DIR("A")="Press 'Return' to continue... "
+3 WRITE !
DO ^DIR
+4 KILL DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+5 QUIT
+6 ;
DES(ADETMP) ;EP - Returns short description of ADA CODE ADETMP
+1 SET ADETMP=$ORDER(^AUTTADA("B",ADETMP,0))
+2 SET ADETMP=$PIECE(^AUTTADA(ADETMP,0),U,6)
+3 QUIT ADETMP
+4 ;
NONREP(ADEOPC,ADEVCOD) ;Mark opsite ADEOPC in ADEVCOD unreportable
+1 NEW ADETST,ADEJ,ADENONR
+2 SET ADETST=$PIECE(ADEVCOD,U,2)
SET ADENONR=$PIECE(ADEVCOD,U,5)
+3 FOR ADEJ=1:1:+ADEVCOD
IF ADEOPC=$PIECE(ADETST,",",ADEJ)
SET $PIECE(ADENONR,",",ADEJ)="y"
QUIT
+4 SET $PIECE(ADEVCOD,U,5)=ADENONR
+5 QUIT ADEVCOD
+6 ;*NE
KILL ADEVCOD
