ADEPQA3A ; IHS/HQT/MJL - CODE SEARCH PARAMS ;08:37 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**12**;APRIL 1999
;
ADA() ;ENTRY POINT
; - Returns "1/0^Code DFN^Followed-by Code^NOT flag^Relative Date
; ^Same Opsite(Y/N)^Particular Opsite" (Codes and Opsite DFN)
;Check that opsite required for codes before prompting for opsite&same
N ADECOD,ADEJ,ADEY,ADEK,ADEFLG,ADERSP,ADEBEG,ADEND,DIR
;
ADACTRL ;Control Sequence
ADAC1 ;FHL 9/9/98
D ADAS1 Q:$$HAT^ADEPQA() 0
Q:ADECOD="" 0
S $P(ADERSP,U)="1^"_ADECOD
ADAC2 D ADAS2 G:$$HAT^ADEPQA() ADAC1 S $P(ADERSP,U,7)=ADECOD
ADAC3 N ADENOT D ADAS3 G:$$HAT^ADEPQA() ADAC2 S $P(ADERSP,U,3)=ADECOD S:ADENOT $P(ADERSP,U,4)=1
;
ADAC4 I $P(ADERSP,U,3)]"" D ADAS4 G:$$HAT^ADEPQA() ADAC3 S $P(ADERSP,U,5)=ADECOD
ADAC5 I $P(ADERSP,U,3)]"" D ADAS5 G:$$HAT^ADEPQA() ADAC3 S $P(ADERSP,U,6)=ADECOD
ADAC6 I $P(ADERSP,U,3)]"" D ADAS6 G:$$HAT^ADEPQA() ADAC3 S $P(ADERSP,U,8)=ADECOD
Q ADERSP
K ADERSP ;*NE
ADAS6 S ADECOD=""
W ! S DIR("A")="Do you want to include codes on the SAME VISIT as 'FOLLOWED BY' codes?"
S DIR(0)="Y"
S DIR("B")="N"
D ^DIR
Q:$$HAT^ADEPQA()
S:Y=1 ADECOD="Y"
Q
ADAS5 S ADECOD=""
W ! S DIR("A")="Do you want the 'FOLLOWED BY' codes to apply to the SAME OPSITE"
S DIR(0)="Y"
S DIR("B")="N"
D ^DIR
Q:$$HAT^ADEPQA()
S:Y=1 ADECOD="Y"
Q
ADAS4 S ADECOD="" K DIR
W ! S DIR("A")="What time limit (in days) should apply to the 'FOLLOWED BY' codes? "
S DIR(0)="NOA^0:10000:0"
D ^DIR
Q:$$HAT^ADEPQA()
S ADECOD=Y
Q
ADAS1 S ADECOD="" K DIR
W ! S DIR("A")="Limit the search to a particular ADA Code or set of Codes"
S DIR("B")="YES"
S DIR(0)="Y" D ^DIR
I $$HAT^ADEPQA() Q
I Y=0 Q
D ADAS1B G:$$HAT^ADEPQA() ADAS1
Q
ADAS3 S ADECOD="" K DIR S ADENOT=0
W ! S DIR("A")="Limit the search to ADA Codes which are FOLLOWED BY a particular code"
S DIR("B")="YES"
S DIR(0)="Y" D ^DIR
I $$HAT^ADEPQA() Q
I Y=0 Q
D ADAS1B G:$$HAT^ADEPQA() ADAS3
Q
ADAS1B N DIC
N ADEX,ADEXSEL S ADEX="7110^7120^7130^7140",ADEXSEL=0 ;IHS/SET/HMW 2-6-2003 **12**
F D Q:X="" Q:$$HAT^ADEPQA() S ADEY=$P(Y,U) D ADA2
. S DIC="^AUTTADA(",DIC(0)="E",D="BA"
. R !,"Select ADA CODE: ",X:DTIME S:'$T!(X[U) DTOUT=1 Q:X="" S X=X_" "
. D IX^DIC
. I ADEX[$P(Y,U,2),ADEXSEL=0 D CDT4REM^ADECD49 S ADEXSEL=1 ;IHS/SET/HMW 2-6-2003 **12**
Q
ADAS2 S ADECOD=""
W ! S DIR("A")="Do you want these ADA Codes to apply to a particular Opsite or Opsites"
S DIR("B")="YES",DIR(0)="Y" D ^DIR
I $$HAT^ADEPQA() Q
I Y=0 Q
K DIR
S DIR(0)="PO^ADEOPS(:EM"
F D ^DIR Q:X="" Q:$$HAT^ADEPQA() S ADEY=$P(Y,U) D ADA4
I $$HAT^ADEPQA() K DIR G ADAS2
Q
ADA2 I ADEY'=-1 D ADA3 Q
I ADEY=-1,X="NOT " D Q
. I '$D(ADENOT) W " --",X," ??" Q
. W !,"OK. I will look for procedures NOT followed by these codes."
. S ADENOT=1
I ADEY=-1,X'["-" W " --",X," ??" Q
I ADEY=-1 S ADEBEG=$P(X,"-",1)_" ",ADEND=$P(X,"-",2) D
. I ADEBEG'?4N1" " W " --",ADEBEG," ??" Q
. I ADEND'?4N1" " W " --",ADEND," ??" Q
. ;IHS/SET/HMW Replaced next 4 lines with line following **12**
. ;D
. ;. N ADEJ
. ;. S ADEJ=0
. ;. F S ADEJ=$O(^AUTTADA("BA",ADEJ)) Q:'+ADEJ I $O(^AUTTADA("BA",ADEJ))>ADEBEG S ADEBEG=ADEJ Q
. S ADEBEG=$O(^AUTTADA("BA",ADEBEG),-1)
. F S ADEBEG=$O(^AUTTADA("BA",ADEBEG)) Q:ADEBEG="" Q:ADEBEG>ADEND S ADEY=$O(^AUTTADA("BA",ADEBEG,0)) W !,?5,ADEBEG,?15,$P(^AUTTADA(ADEY,0),U,2) D ADA3
Q
ADA4 I ADEY'=-1 D ADA3 Q
I ADEY=-1,X'["-" W !,?5," -- Enter a single operative site or a range of PERMANENT TOOTH NUMBERS",!,?5,"separated by a dash, e.g. 6-9" Q
I ADEY=-1 S ADEBEG=$P(X,"-",1),ADEND=$P(X,"-",2) D
. I ADEBEG'?1.2N W ?20,"--",ADEBEG,"?? Ranges can apply only to permanent tooth numbers." Q
. I ADEND'?1.2N W ?20,"--",ADEND,"?? Ranges can apply only to permanent tooth numbers." Q
. S ADEBEG=ADEBEG-1 F S ADEBEG=$O(^ADEOPS("B",ADEBEG)) Q:ADEBEG="" Q:ADEBEG>ADEND Q:ADEBEG'?1.2N S ADEY=$O(^ADEOPS("B",ADEBEG,0)) W !,?5,ADEBEG,?15,$P(^ADEOPS(ADEY,0),U) D ADA3
Q
ADA3 S ADEFLG=0 F ADEK=1:1:$L(ADECOD,",") I $P(ADECOD,",",ADEK)=ADEY S ADEFLG=1 Q
I 'ADEFLG,ADECOD="" S ADECOD=ADEY Q
S:'ADEFLG $P(ADECOD,",",$L(ADECOD,",")+1)=ADEY
Q
ADEPQA3A ; IHS/HQT/MJL - CODE SEARCH PARAMS ;08:37 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**12**;APRIL 1999
+2 ;
ADA() ;ENTRY POINT
+1 ; - Returns "1/0^Code DFN^Followed-by Code^NOT flag^Relative Date
+2 ; ^Same Opsite(Y/N)^Particular Opsite" (Codes and Opsite DFN)
+3 ;Check that opsite required for codes before prompting for opsite&same
+4 NEW ADECOD,ADEJ,ADEY,ADEK,ADEFLG,ADERSP,ADEBEG,ADEND,DIR
+5 ;
ADACTRL ;Control Sequence
ADAC1 ;FHL 9/9/98
+1 DO ADAS1
IF $$HAT^ADEPQA()
QUIT 0
+2 IF ADECOD=""
QUIT 0
+3 SET $PIECE(ADERSP,U)="1^"_ADECOD
ADAC2 DO ADAS2
IF $$HAT^ADEPQA()
GOTO ADAC1
SET $PIECE(ADERSP,U,7)=ADECOD
ADAC3 NEW ADENOT
DO ADAS3
IF $$HAT^ADEPQA()
GOTO ADAC2
SET $PIECE(ADERSP,U,3)=ADECOD
IF ADENOT
SET $PIECE(ADERSP,U,4)=1
+1 ;
ADAC4 IF $PIECE(ADERSP,U,3)]""
DO ADAS4
IF $$HAT^ADEPQA()
GOTO ADAC3
SET $PIECE(ADERSP,U,5)=ADECOD
ADAC5 IF $PIECE(ADERSP,U,3)]""
DO ADAS5
IF $$HAT^ADEPQA()
GOTO ADAC3
SET $PIECE(ADERSP,U,6)=ADECOD
ADAC6 IF $PIECE(ADERSP,U,3)]""
DO ADAS6
IF $$HAT^ADEPQA()
GOTO ADAC3
SET $PIECE(ADERSP,U,8)=ADECOD
+1 QUIT ADERSP
+2 ;*NE
KILL ADERSP
ADAS6 SET ADECOD=""
+1 WRITE !
SET DIR("A")="Do you want to include codes on the SAME VISIT as 'FOLLOWED BY' codes?"
+2 SET DIR(0)="Y"
+3 SET DIR("B")="N"
+4 DO ^DIR
+5 IF $$HAT^ADEPQA()
QUIT
+6 IF Y=1
SET ADECOD="Y"
+7 QUIT
ADAS5 SET ADECOD=""
+1 WRITE !
SET DIR("A")="Do you want the 'FOLLOWED BY' codes to apply to the SAME OPSITE"
+2 SET DIR(0)="Y"
+3 SET DIR("B")="N"
+4 DO ^DIR
+5 IF $$HAT^ADEPQA()
QUIT
+6 IF Y=1
SET ADECOD="Y"
+7 QUIT
ADAS4 SET ADECOD=""
KILL DIR
+1 WRITE !
SET DIR("A")="What time limit (in days) should apply to the 'FOLLOWED BY' codes? "
+2 SET DIR(0)="NOA^0:10000:0"
+3 DO ^DIR
+4 IF $$HAT^ADEPQA()
QUIT
+5 SET ADECOD=Y
+6 QUIT
ADAS1 SET ADECOD=""
KILL DIR
+1 WRITE !
SET DIR("A")="Limit the search to a particular ADA Code or set of Codes"
+2 SET DIR("B")="YES"
+3 SET DIR(0)="Y"
DO ^DIR
+4 IF $$HAT^ADEPQA()
QUIT
+5 IF Y=0
QUIT
+6 DO ADAS1B
IF $$HAT^ADEPQA()
GOTO ADAS1
+7 QUIT
ADAS3 SET ADECOD=""
KILL DIR
SET ADENOT=0
+1 WRITE !
SET DIR("A")="Limit the search to ADA Codes which are FOLLOWED BY a particular code"
+2 SET DIR("B")="YES"
+3 SET DIR(0)="Y"
DO ^DIR
+4 IF $$HAT^ADEPQA()
QUIT
+5 IF Y=0
QUIT
+6 DO ADAS1B
IF $$HAT^ADEPQA()
GOTO ADAS3
+7 QUIT
ADAS1B NEW DIC
+1 ;IHS/SET/HMW 2-6-2003 **12**
NEW ADEX,ADEXSEL
SET ADEX="7110^7120^7130^7140"
SET ADEXSEL=0
+2 FOR
Begin DoDot:1
+3 SET DIC="^AUTTADA("
SET DIC(0)="E"
SET D="BA"
+4 READ !,"Select ADA CODE: ",X:DTIME
IF '$TEST!(X[U)
SET DTOUT=1
IF X=""
QUIT
SET X=X_" "
+5 DO IX^DIC
+6 ;IHS/SET/HMW 2-6-2003 **12**
IF ADEX[$PIECE(Y,U,2)
IF ADEXSEL=0
DO CDT4REM^ADECD49
SET ADEXSEL=1
End DoDot:1
IF X=""
QUIT
IF $$HAT^ADEPQA()
QUIT
SET ADEY=$PIECE(Y,U)
DO ADA2
+7 QUIT
ADAS2 SET ADECOD=""
+1 WRITE !
SET DIR("A")="Do you want these ADA Codes to apply to a particular Opsite or Opsites"
+2 SET DIR("B")="YES"
SET DIR(0)="Y"
DO ^DIR
+3 IF $$HAT^ADEPQA()
QUIT
+4 IF Y=0
QUIT
+5 KILL DIR
+6 SET DIR(0)="PO^ADEOPS(:EM"
+7 FOR
DO ^DIR
IF X=""
QUIT
IF $$HAT^ADEPQA()
QUIT
SET ADEY=$PIECE(Y,U)
DO ADA4
+8 IF $$HAT^ADEPQA()
KILL DIR
GOTO ADAS2
+9 QUIT
ADA2 IF ADEY'=-1
DO ADA3
QUIT
+1 IF ADEY=-1
IF X="NOT "
Begin DoDot:1
+2 IF '$DATA(ADENOT)
WRITE " --",X," ??"
QUIT
+3 WRITE !,"OK. I will look for procedures NOT followed by these codes."
+4 SET ADENOT=1
End DoDot:1
QUIT
+5 IF ADEY=-1
IF X'["-"
WRITE " --",X," ??"
QUIT
+6 IF ADEY=-1
SET ADEBEG=$PIECE(X,"-",1)_" "
SET ADEND=$PIECE(X,"-",2)
Begin DoDot:1
+7 IF ADEBEG'?4N1" "
WRITE " --",ADEBEG," ??"
QUIT
+8 IF ADEND'?4N1" "
WRITE " --",ADEND," ??"
QUIT
+9 ;IHS/SET/HMW Replaced next 4 lines with line following **12**
+10 ;D
+11 ;. N ADEJ
+12 ;. S ADEJ=0
+13 ;. F S ADEJ=$O(^AUTTADA("BA",ADEJ)) Q:'+ADEJ I $O(^AUTTADA("BA",ADEJ))>ADEBEG S ADEBEG=ADEJ Q
+14 SET ADEBEG=$ORDER(^AUTTADA("BA",ADEBEG),-1)
+15 FOR
SET ADEBEG=$ORDER(^AUTTADA("BA",ADEBEG))
IF ADEBEG=""
QUIT
IF ADEBEG>ADEND
QUIT
SET ADEY=$ORDER(^AUTTADA("BA",ADEBEG,0))
WRITE !,?5,ADEBEG,?15,$PIECE(^AUTTADA(ADEY,0),U,2)
DO ADA3
End DoDot:1
+16 QUIT
ADA4 IF ADEY'=-1
DO ADA3
QUIT
+1 IF ADEY=-1
IF X'["-"
WRITE !,?5," -- Enter a single operative site or a range of PERMANENT TOOTH NUMBERS",!,?5,"separated by a dash, e.g. 6-9"
QUIT
+2 IF ADEY=-1
SET ADEBEG=$PIECE(X,"-",1)
SET ADEND=$PIECE(X,"-",2)
Begin DoDot:1
+3 IF ADEBEG'?1.2N
WRITE ?20,"--",ADEBEG,"?? Ranges can apply only to permanent tooth numbers."
QUIT
+4 IF ADEND'?1.2N
WRITE ?20,"--",ADEND,"?? Ranges can apply only to permanent tooth numbers."
QUIT
+5 SET ADEBEG=ADEBEG-1
FOR
SET ADEBEG=$ORDER(^ADEOPS("B",ADEBEG))
IF ADEBEG=""
QUIT
IF ADEBEG>ADEND
QUIT
IF ADEBEG'?1.2N
QUIT
SET ADEY=$ORDER(^ADEOPS("B",ADEBEG,0))
WRITE !,?5,ADEBEG,?15,$PIECE(^ADEOPS(ADEY,0),U)
DO ADA3
End DoDot:1
+6 QUIT
ADA3 SET ADEFLG=0
FOR ADEK=1:1:$LENGTH(ADECOD,",")
IF $PIECE(ADECOD,",",ADEK)=ADEY
SET ADEFLG=1
QUIT
+1 IF 'ADEFLG
IF ADECOD=""
SET ADECOD=ADEY
QUIT
+2 IF 'ADEFLG
SET $PIECE(ADECOD,",",$LENGTH(ADECOD,",")+1)=ADEY
+3 QUIT
