ADEKNT9.m

ADEKNT9 ; IHS/HQT/MJL - COMPILE DENTAL REPORTS ;  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;

 ;This routine contains code for procedures which the IHS Dental Program

 ;decided should not be included in the reports package.

 ;However, since the Dental Program has changed its mind several

 ;times regarding what it wants on these reports, I want to

 ;keep this code intact.  They may want to use it later.

 ;

EMER(ADELIM) ;EP

 ;PATIENTS WITH EMERGENCY EXAM THIS QUARTER

 ;BUT NO ROUTINE EXAM PAST 12 MONTHS

 ;QUIT IF NO EMERGENCY DURING CURRENT QUARTER

 ;NOT CALLED NOW, BUT KEEP CODE

 I ADELIM Q:'(ADELIM=ADEIND)

 N ADEQBD1,ADE1BD1

 S ADEQBD1=ADEQBD-.0001

 S ADE1BD1=ADE1BD-.0001

 Q:'$D(ADEHXC("0130"))

 Q:'$O(ADEHXC("0130",ADEQBD1))

 Q:$O(ADEHXC("0130",ADEQBD1))>ADEED

 I $O(ADEHXC("0110",ADE1BD1)) Q:$O(ADEHXC("0110",ADE1BD1))<ADEED

 I $O(ADEHXC("0120",ADE1BD1)) Q:$O(ADEHXC("0120",ADE1BD1))<ADEED

 I $O(ADEHXC("0150",ADE1BD1)) Q:$O(ADEHXC("0150",ADE1BD1))<ADEED

 I $O(ADEHXC("0160",ADE1BD1)) Q:$O(ADEHXC("0160",ADE1BD1))<ADEED

 S $P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)=$P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)+1

 Q

 ;

PTC(ADELIM) ;EP

 ;Patients receiving PTC this quarter but no PTC in past

 ;12 months

 ;NOT CALLED NOW, BUT KEEP CODE

 I ADELIM Q:'(ADELIM=ADEIND)

 N ADEQBD1,ADE1BD1,ADEPTC

 S ADEQBD1=ADEQBD-.0001

 S ADE1BD1=ADE1BD-.0001

 Q:'$D(ADEHXC("9990"))  ;no ptc at all

 Q:'$D(ADEHXC("9990",ADEQBD1))  ;No ptc this qtr

 Q:$O(ADEHXC("9990",ADEQBD1))>ADEED  ;ptc was after end date

 S ADEPTC=$O(ADEHXC("9990",ADEQBD1)) ;ADEPTC is date of

 ;the first ptc this quarter

 Q:$O(ADEHXC("9990",ADEPTC,-1))>ADE1BD1  ;previous ptc<1 yr ago

 ;Increment - this measure only valid for current quarter

 S $P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)=$P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)+1

 ;S $P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,2,3)=0

 Q

ADEKNT9   ; IHS/HQT/MJL - COMPILE DENTAL REPORTS ;  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;

 +3       ;This routine contains code for procedures which the IHS Dental Program

 +4       ;decided should not be included in the reports package.

 +5       ;However, since the Dental Program has changed its mind several

 +6       ;times regarding what it wants on these reports, I want to

 +7       ;keep this code intact.  They may want to use it later.

 +8       ;

EMER(ADELIM) ;EP

 +1       ;PATIENTS WITH EMERGENCY EXAM THIS QUARTER

 +2       ;BUT NO ROUTINE EXAM PAST 12 MONTHS

 +3       ;QUIT IF NO EMERGENCY DURING CURRENT QUARTER

 +4       ;NOT CALLED NOW, BUT KEEP CODE

 +5        IF ADELIM

               IF '(ADELIM=ADEIND)

                   QUIT 

 +6        NEW ADEQBD1,ADE1BD1

 +7        SET ADEQBD1=ADEQBD-.0001

 +8        SET ADE1BD1=ADE1BD-.0001

 +9        IF '$DATA(ADEHXC("0130"))

               QUIT 

 +10       IF '$ORDER(ADEHXC("0130",ADEQBD1))

               QUIT 

 +11       IF $ORDER(ADEHXC("0130",ADEQBD1))>ADEED

               QUIT 

 +12       IF $ORDER(ADEHXC("0110",ADE1BD1))

               IF $ORDER(ADEHXC("0110",ADE1BD1))<ADEED

                   QUIT 

 +13       IF $ORDER(ADEHXC("0120",ADE1BD1))

               IF $ORDER(ADEHXC("0120",ADE1BD1))<ADEED

                   QUIT 

 +14       IF $ORDER(ADEHXC("0150",ADE1BD1))

               IF $ORDER(ADEHXC("0150",ADE1BD1))<ADEED

                   QUIT 

 +15       IF $ORDER(ADEHXC("0160",ADE1BD1))

               IF $ORDER(ADEHXC("0160",ADE1BD1))<ADEED

                   QUIT 

 +16       SET $PIECE(^TMP($JOB,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)=$PIECE(^TMP($JOB,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)+1

 +17       QUIT 

 +18      ;

PTC(ADELIM) ;EP

 +1       ;Patients receiving PTC this quarter but no PTC in past

 +2       ;12 months

 +3       ;NOT CALLED NOW, BUT KEEP CODE

 +4        IF ADELIM

               IF '(ADELIM=ADEIND)

                   QUIT 

 +5        NEW ADEQBD1,ADE1BD1,ADEPTC

 +6        SET ADEQBD1=ADEQBD-.0001

 +7        SET ADE1BD1=ADE1BD-.0001

 +8       ;no ptc at all

           IF '$DATA(ADEHXC("9990"))

               QUIT 

 +9       ;No ptc this qtr

           IF '$DATA(ADEHXC("9990",ADEQBD1))

               QUIT 

 +10      ;ptc was after end date

           IF $ORDER(ADEHXC("9990",ADEQBD1))>ADEED

               QUIT 

 +11      ;ADEPTC is date of

           SET ADEPTC=$ORDER(ADEHXC("9990",ADEQBD1))

 +12      ;the first ptc this quarter

 +13      ;previous ptc<1 yr ago

           IF $ORDER(ADEHXC("9990",ADEPTC,-1))>ADE1BD1

               QUIT 

 +14      ;Increment - this measure only valid for current quarter

 +15       SET $PIECE(^TMP($JOB,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)=$PIECE(^TMP($JOB,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,1)+1

 +16      ;S $P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,2,3)=0

 +17       QUIT