- 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
