source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGYPSDE2.m@ 1742

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