- 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
