DGYPSDE2 ;ALB/GAH - EST. FILE SIZE NEEDED FOR OUT PATIENT ENCOUNTER FILE ; 10/10/2006
;;5.3;REGISTRATION;**568,725**;Aug 13, 1993;Build 12
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYPSDE2 3893 printed Apr 09, 2024@21:52:46 Page 2
DGYPSDE2 ;ALB/GAH - EST. FILE SIZE NEEDED FOR OUT PATIENT ENCOUNTER FILE ; 10/10/2006
+1 ;;5.3;REGISTRATION;**568,725**;Aug 13, 1993;Build 12
+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
