DGYPSDE2.m

DGYPSDE2 ;ALB/GAH - EST. FILE SIZE NEEDED FOR OUT PATIENT ENCOUNTER FILE ; 10/10/2006

 ;;5.3;REGISTRATION;**568,725,1015**;Aug 13, 1993;Build 21

 ;

START N DGI,DGDTE,DGNUM,DGCSC,DGCNT,DGCLAR,X1,X2,DFN

 N DGAPT,DGDISP,DGNODE,DGAE,DGAEDT,DGPCL,DGARRAY,SDCNT

 S X1=DT,X2=-365 D C^%DTC S DG1YR=X ; one yr ago

 S TDT=DT+.2359 ; today

 ; Build Appointment information from Scheduling API

 S DGARRAY(1)=DG1YR_";"_TDT,DGARRAY("FLDS")="2;3;10",DGARRAY("SORT")="P"

 S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)

 S (DGYR("AP"),DGYR("DI"),DGYR("AE"),DGYR("CR"),DFN,DGCNT)=0

 ;SET UP A TEMP ARRAY -DGCLAR- WITH CLASSIFICATION ABBREVIATIONS

 S DGCLAR(1)="AO",DGCLAR(2)="IR",DGCLAR(3)="SC",DGCLAR(4)="EC"

 F DGCNT=1:1:4 S DGCL(DGCNT)=0

 D DISAPP,AEDIT

 K DGARRAY,SDCNT,^TMP($J,"SDAMA301")

 Q

 ;

DISAPP ; FOR THE LAST YR PICK UP ALL APPT. AND DISP. FROM PATIENT FILE

 ; SDAMA301 = APPOINTMENTS, "DIS" = DISPOSTIONS

 F  S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:'DFN  D

 .S DGAPT=0 F  S DGAPT=$O(^TMP($J,"SDAMA301",DFN,DGAPT)) Q:'DGAPT  D

 ..N DGAPT0,DGCLN,DGSTAT,DGTYP S DGAPT0=^TMP($J,"SDAMA301",DFN,DGAPT)

 ..S DGSTAT=$P($P(DGAPT0,U,3),";"),DGCLN=$P($P(DGAPT0,U,2),";"),DGTYP=$P($P(DGAPT0,U,10),";")

 ..I DGSTAT["C"!(DGSTAT["N") Q

 ..; INCR WILL CHECK FOR AND ACCUMULATE CLASSIFICATIONS

 ..I $$STATUS(DFN,DGAPT,DGCLN,1)="C",$$EXEMPT($P($G(^SC(DGCLN,0)),U,7),DGTYP) D INCR(DFN)

 ..S DGYR("AP")=DGYR("AP")+1

 ..S:$P($G(^SC(DGCLN,0)),U,18)]"" DGYR("CR")=DGYR("CR")+1

 .; -- Dispositions

 .S DGDISP=0 F  S DGDISP=$O(^DPT(DFN,"DIS",DGDISP)) Q:'DGDISP  D

 ..S DGNODE=$G(^DPT(DFN,"DIS",DGDISP,0))

 ..I ((+DGNODE)>DG1YR)&((+DGNODE)<TDT),$P(DGNODE,U,2)=0!($P(DGNODE,U,2)=1)  D

 ...I $$STATUS(DFN,DGDISP,0,3)="C",$$EXEMPT(+$O(^DIC(40.7,"C",102,0)),9) D INCR(DFN)

 ...S DGYR("DI")=DGYR("DI")+1

 Q

AEDIT ;FOR THE PAST YEAR PICK UP ALL ADD/EDITS FROM THE STOP CODE FILE

 ;

 S DGAEDT=""

 F  S DGAEDT=$O(^SDV(DGAEDT)) Q:DGAEDT=""  D

 .S DGNODE=$G(^SDV(DGAEDT,0))

 .I (DGAEDT>DG1YR)&(DGAEDT<TDT)  D

 ..S DGAE=0

 ..F  S DGAE=$O(^SDV(DGAEDT,"CS",DGAE)) Q:'DGAE  D

 ...N DGAE0 S DGAE0=^SDV(DGAEDT,"CS",DGAE,0)

 ...; DUPL WILL CHECK FOR ASSOCIATED APPT

 ...I $$STATUS(+$P(DGNODE,U,2),+DGNODE,0,2),$$EXEMPT(+DGAE0,+$P(DGAE0,U,5)) D INCR($P(DGNODE,U,2))

 ...D DUPL

 ...S DGYR("AE")=DGYR("AE")+1

 Q

DUPL ; FOR EACH A/E RUN THROUGH THE APPTS LOOOK FOR ASSOC. APPTS

 ; IF FOUND AND THEY HAVE A CLASSIFICATION CALL DECR

 N DGBEG,DGEND

 S DGCSC=^SDV(DGAEDT,"CS",DGAE,0)

 S DFN=$P(DGNODE,U,2)

 S DGCL=$P(DGCSC,U,3)

 S DGBEG=$P(DGAEDT,".")

 S DGEND=DGBEG+.2359

 S DGI=DGBEG

 F  S DGI=$O(^TMP($J,"SDAMA301",DFN,DGI)) Q:('DGI)!(DGI>DGEND)  D

 .N DGI0,DGIST,DGICL,DGITP S DGI0=^TMP($J,"SDAMA301",DFN,DGI)

 .S DGIST=$P($P(DGI0,U,3),";"),DGICL=$P($P(DGI0,U,2),";"),DGITP=$P($P(DGI0,U,10),";")

 .I DGIST["C"!(DGIST["N") Q

 .I +DGI0=DGCL,$$STATUS(DFN,DGI,DGCL,1)="C",$$EXEMPT(+$P($G(^SC(DGICL,0)),U,7),DGITP) D DECR(DFN)

 Q

DECR(DFN) ;  DECREMENT ARRAY WITH THE CLASS CNTS 

 N DGYPCL D BLD^DGYPSDE3(DFN,.DGYPCL)

 I $O(DGYPCL(0))  D

 .S DGYPPCL=0

 .F  S DGYPPCL=$O(DGYPCL(DGYPPCL)) Q:'DGYPPCL  D

 ..S DGCL(DGYPPCL)=DGCL(DGYPPCL)-1

 Q

INCR(DFN) ;  INCREMENT ARRAY WITH CLASS CNTS

 N DGYPCL D BLD^DGYPSDE3(DFN,.DGYPCL)

 I $O(DGYPCL(0))  D

 .S DGYPPCL=0

 .F  S DGYPPCL=$O(DGYPCL(DGYPPCL)) Q:'DGYPPCL  D

 ..S DGCL(DGYPPCL)=DGCL(DGYPPCL)+1

 Q

 ;

 ;  STATUS WILL DETERMINE IF APPT WAS AN INPATIENT

 ; OR A NON STOP CODE CLINIC

STATUS(DFN,DGT,DGCL,DGORG) ;

 N Y S Y=""

 I $$INP^SDAM2(DFN,DGT)="I" S Y="I"

 I Y="",DGORG=1,$P($G(^SC(+DGCL,0)),U,17)="Y" S Y="NC"

 I Y="" S Y="C"

 Q Y

 ;

 ;  EXEMPT WILL RETURN A LOW IF THE STOP CODE IS BETWEEN 103+170

 ; OR APPT TYPE IS NOT 9=REGULAR OR 2=SPECIAL DENTAL 

EXEMPT(DGSTOP,DGAPTY) ;

 N Y

 S DGSTOP=$P($G(^DIC(40.7,+DGSTOP,0)),U,2)

 I DGSTOP>103,DGSTOP<171 S Y=0 G EXEMPTQ

 I DGAPTY=9!(DGAPTY=2) S Y=1 G EXEMPTQ

 S Y=0

EXEMPTQ Q Y

DGYPSDE2  ;ALB/GAH - EST. FILE SIZE NEEDED FOR OUT PATIENT ENCOUNTER FILE ; 10/10/2006

 +1       ;;5.3;REGISTRATION;**568,725,1015**;Aug 13, 1993;Build 21

 +2       ;

START      NEW DGI,DGDTE,DGNUM,DGCSC,DGCNT,DGCLAR,X1,X2,DFN

 +1        NEW DGAPT,DGDISP,DGNODE,DGAE,DGAEDT,DGPCL,DGARRAY,SDCNT

 +2       ; one yr ago

           SET X1=DT

           SET X2=-365

           DO C^%DTC

           SET DG1YR=X

 +3       ; today

           SET TDT=DT+.2359

 +4       ; Build Appointment information from Scheduling API

 +5        SET DGARRAY(1)=DG1YR_";"_TDT

           SET DGARRAY("FLDS")="2;3;10"

           SET DGARRAY("SORT")="P"

 +6        SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)

 +7        SET (DGYR("AP"),DGYR("DI"),DGYR("AE"),DGYR("CR"),DFN,DGCNT)=0

 +8       ;SET UP A TEMP ARRAY -DGCLAR- WITH CLASSIFICATION ABBREVIATIONS

 +9        SET DGCLAR(1)="AO"

           SET DGCLAR(2)="IR"

           SET DGCLAR(3)="SC"

           SET DGCLAR(4)="EC"

 +10       FOR DGCNT=1:1:4

               SET DGCL(DGCNT)=0

 +11       DO DISAPP

           DO AEDIT

 +12       KILL DGARRAY,SDCNT,^TMP($JOB,"SDAMA301")

 +13       QUIT 

 +14      ;

DISAPP    ; FOR THE LAST YR PICK UP ALL APPT. AND DISP. FROM PATIENT FILE

 +1       ; SDAMA301 = APPOINTMENTS, "DIS" = DISPOSTIONS

 +2        FOR 

               SET DFN=$ORDER(^TMP($JOB,"SDAMA301",DFN))

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +3                SET DGAPT=0

                   FOR 

                       SET DGAPT=$ORDER(^TMP($JOB,"SDAMA301",DFN,DGAPT))

                       IF 'DGAPT

                           QUIT 

                       Begin DoDot:2

 +4                        NEW DGAPT0,DGCLN,DGSTAT,DGTYP

                           SET DGAPT0=^TMP($JOB,"SDAMA301",DFN,DGAPT)

 +5                        SET DGSTAT=$PIECE($PIECE(DGAPT0,U,3),";")

                           SET DGCLN=$PIECE($PIECE(DGAPT0,U,2),";")

                           SET DGTYP=$PIECE($PIECE(DGAPT0,U,10),";")

 +6                        IF DGSTAT["C"!(DGSTAT["N")

                               QUIT 

 +7       ; INCR WILL CHECK FOR AND ACCUMULATE CLASSIFICATIONS

 +8                        IF $$STATUS(DFN,DGAPT,DGCLN,1)="C"

                               IF $$EXEMPT($PIECE($GET(^SC(DGCLN,0)),U,7),DGTYP)

                                   DO INCR(DFN)

 +9                        SET DGYR("AP")=DGYR("AP")+1

 +10                       IF $PIECE($GET(^SC(DGCLN,0)),U,18)]""

                               SET DGYR("CR")=DGYR("CR")+1

                       End DoDot:2

 +11      ; -- Dispositions

 +12               SET DGDISP=0

                   FOR 

                       SET DGDISP=$ORDER(^DPT(DFN,"DIS",DGDISP))

                       IF 'DGDISP

                           QUIT 

                       Begin DoDot:2

 +13                       SET DGNODE=$GET(^DPT(DFN,"DIS",DGDISP,0))

 +14                       IF ((+DGNODE)>DG1YR)&((+DGNODE)<TDT)

                               IF $PIECE(DGNODE,U,2)=0!($PIECE(DGNODE,U,2)=1)

                                   Begin DoDot:3

 +15                                   IF $$STATUS(DFN,DGDISP,0,3)="C"

                                           IF $$EXEMPT(+$ORDER(^DIC(40.7,"C",102,0)),9)

                                               DO INCR(DFN)

 +16                                   SET DGYR("DI")=DGYR("DI")+1

                                   End DoDot:3

                       End DoDot:2

               End DoDot:1

 +17       QUIT 

AEDIT     ;FOR THE PAST YEAR PICK UP ALL ADD/EDITS FROM THE STOP CODE FILE

 +1       ;

 +2        SET DGAEDT=""

 +3        FOR 

               SET DGAEDT=$ORDER(^SDV(DGAEDT))

               IF DGAEDT=""

                   QUIT 

               Begin DoDot:1

 +4                SET DGNODE=$GET(^SDV(DGAEDT,0))

 +5                IF (DGAEDT>DG1YR)&(DGAEDT<TDT)

                       Begin DoDot:2

 +6                        SET DGAE=0

 +7                        FOR 

                               SET DGAE=$ORDER(^SDV(DGAEDT,"CS",DGAE))

                               IF 'DGAE

                                   QUIT 

                               Begin DoDot:3

 +8                                NEW DGAE0

                                   SET DGAE0=^SDV(DGAEDT,"CS",DGAE,0)

 +9       ; DUPL WILL CHECK FOR ASSOCIATED APPT

 +10                               IF $$STATUS(+$PIECE(DGNODE,U,2),+DGNODE,0,2)

                                       IF $$EXEMPT(+DGAE0,+$PIECE(DGAE0,U,5))

                                           DO INCR($PIECE(DGNODE,U,2))

 +11                               DO DUPL

 +12                               SET DGYR("AE")=DGYR("AE")+1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +13       QUIT 

DUPL      ; FOR EACH A/E RUN THROUGH THE APPTS LOOOK FOR ASSOC. APPTS

 +1       ; IF FOUND AND THEY HAVE A CLASSIFICATION CALL DECR

 +2        NEW DGBEG,DGEND

 +3        SET DGCSC=^SDV(DGAEDT,"CS",DGAE,0)

 +4        SET DFN=$PIECE(DGNODE,U,2)

 +5        SET DGCL=$PIECE(DGCSC,U,3)

 +6        SET DGBEG=$PIECE(DGAEDT,".")

 +7        SET DGEND=DGBEG+.2359

 +8        SET DGI=DGBEG

 +9        FOR 

               SET DGI=$ORDER(^TMP($JOB,"SDAMA301",DFN,DGI))

               IF ('DGI)!(DGI>DGEND)

                   QUIT 

               Begin DoDot:1

 +10               NEW DGI0,DGIST,DGICL,DGITP

                   SET DGI0=^TMP($JOB,"SDAMA301",DFN,DGI)

 +11               SET DGIST=$PIECE($PIECE(DGI0,U,3),";")

                   SET DGICL=$PIECE($PIECE(DGI0,U,2),";")

                   SET DGITP=$PIECE($PIECE(DGI0,U,10),";")

 +12               IF DGIST["C"!(DGIST["N")

                       QUIT 

 +13               IF +DGI0=DGCL

                       IF $$STATUS(DFN,DGI,DGCL,1)="C"

                           IF $$EXEMPT(+$PIECE($GET(^SC(DGICL,0)),U,7),DGITP)

                               DO DECR(DFN)

               End DoDot:1

 +14       QUIT 

DECR(DFN) ;  DECREMENT ARRAY WITH THE CLASS CNTS 

 +1        NEW DGYPCL

           DO BLD^DGYPSDE3(DFN,.DGYPCL)

 +2        IF $ORDER(DGYPCL(0))

               Begin DoDot:1

 +3                SET DGYPPCL=0

 +4                FOR 

                       SET DGYPPCL=$ORDER(DGYPCL(DGYPPCL))

                       IF 'DGYPPCL

                           QUIT 

                       Begin DoDot:2

 +5                        SET DGCL(DGYPPCL)=DGCL(DGYPPCL)-1

                       End DoDot:2

               End DoDot:1

 +6        QUIT 

INCR(DFN) ;  INCREMENT ARRAY WITH CLASS CNTS

 +1        NEW DGYPCL

           DO BLD^DGYPSDE3(DFN,.DGYPCL)

 +2        IF $ORDER(DGYPCL(0))

               Begin DoDot:1

 +3                SET DGYPPCL=0

 +4                FOR 

                       SET DGYPPCL=$ORDER(DGYPCL(DGYPPCL))

                       IF 'DGYPPCL

                           QUIT 

                       Begin DoDot:2

 +5                        SET DGCL(DGYPPCL)=DGCL(DGYPPCL)+1

                       End DoDot:2

               End DoDot:1

 +6        QUIT 

 +7       ;

 +8       ;  STATUS WILL DETERMINE IF APPT WAS AN INPATIENT

 +9       ; OR A NON STOP CODE CLINIC

STATUS(DFN,DGT,DGCL,DGORG) ;

 +1        NEW Y

           SET Y=""

 +2        IF $$INP^SDAM2(DFN,DGT)="I"

               SET Y="I"

 +3        IF Y=""

               IF DGORG=1

                   IF $PIECE($GET(^SC(+DGCL,0)),U,17)="Y"

                       SET Y="NC"

 +4        IF Y=""

               SET Y="C"

 +5        QUIT Y

 +6       ;

 +7       ;  EXEMPT WILL RETURN A LOW IF THE STOP CODE IS BETWEEN 103+170

 +8       ; OR APPT TYPE IS NOT 9=REGULAR OR 2=SPECIAL DENTAL 

EXEMPT(DGSTOP,DGAPTY) ;

 +1        NEW Y

 +2        SET DGSTOP=$PIECE($GET(^DIC(40.7,+DGSTOP,0)),U,2)

 +3        IF DGSTOP>103

               IF DGSTOP<171

                   SET Y=0

                   GOTO EXEMPTQ

 +4        IF DGAPTY=9!(DGAPTY=2)

               SET Y=1

               GOTO EXEMPTQ

 +5        SET Y=0

EXEMPTQ    QUIT Y