source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW11.m@ 1641

Last change on this file since 1641 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1SCRPW11 ;RENO/KEITH - Patient Activity by Appointment Frequency ; 15 Jul 98 02:38PM
2 ;;5.3;Scheduling;**139,144**;AUG 13, 1993
3 D TITL^SCRPW50("Patient Activity by Appointment Frequency") N SDDIV Q:'$$DIVA^SCRPW17(.SDDIV)
4DTR D SUBT^SCRPW50("*** Date Range Selection ***")
5FDT W ! S %DT="AEPX",%DT("A")="Beginning date: ",%DT(0)="-TODAY" D ^%DT G:X=U!($D(DTOUT)) EXIT G:X="" EXIT
6 G:Y<1 FDT S SDBDAY=Y X ^DD("DD") S SDPBDA=Y
7LDT W ! S %DT("A")=" Ending date: " D ^%DT G:X=U!($D(DTOUT)) EXIT G:X="" EXIT
8 I Y<SDBDAY W !!,$C(7),"Ending date must be after beginning date!" G LDT
9 G:Y<1 LDT S SDEDAY=Y X ^DD("DD") S SDPEDA=Y
10 D SUBT^SCRPW50("*** Report Format Selection ***")
11 W ! S DIR(0)="N^1:999:0",DIR("?")="Enter the minimum number of appointments for a patient to be included in this report",DIR("A")="Minimum appointment frequency" D ^DIR G:Y'>0 EXIT S SDMIN=Y
12 K DIR S DIR(0)="S^R:RANGE OF STOP CODES;S:SELECTED STOP CODES;C:CLINIC GROUP",DIR("A")="Limit clinics by",DIR("?")="Output will be limited to primary stop codes or clinic group as specified."
13 D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT S SDFMT=Y,SDOUT=0 D @(SDFMT) G:SDOUT EXIT
14 D SUBT^SCRPW50("*** Output Order Selection ***")
15 K DIR S DIR(0)="S^A:ALPHABETIC;V:VISIT FREQUENCY",DIR("A")="Specify output order" D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT S SDORD=Y
16 N ZTSAVE F V="SD(","SDDIV","SDDIV(","SDFMT","SDMIN","SDBDAY","SDEDAY","SDPBDA","SDPEDA","SDBCS","SDECS","SDORD","SDMC","SDMD" S ZTSAVE(V)=""
17 W !!,"This report requires 132 column output.",! D EN^XUTMDEVQ("START^SCRPW11","PT. ACTIVITY BY APPT. FREQUENCY",.ZTSAVE) G EXIT
18 ;
19START K ^TMP("SCRPW",$J) S (SDOUT,SDSTOP)=0,SDMD=$O(SDDIV(0)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
20 I SDFMT="C" S SDCG=$O(SD(0)),SDCL=0 F S SDCL=$O(^SC("ASCRPW",SDCG,SDCL)) Q:'SDCL S SDCL0=$G(^SC(SDCL,0)) I $$DIV() D LOOP Q:SDOUT
21 G:SDOUT EXIT
22 I SDFMT'="C" S SDCL=0 F S SDCL=$O(^SC(SDCL)) Q:SDCL'>0 S SDCL0=$G(^SC(SDCL,0)) I $$DIV() D LOOP Q:SDOUT
23 G:SDOUT EXIT
24 S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,0,DFN)) Q:DFN'>0 S SDSTOP=SDSTOP+1 D:SDSTOP#1000=0 STOP Q:SDOUT D FAPP,ORDR
25 S SDII=1,SDT(SDII)="<*> PATIENT ACTIVITY BY APPOINTMENT FREQUENCY <*>" S:SDFMT="R" SDII=SDII+1,SDT(SDII)="IN CLINICS WITH PRIMARY STOP CODES "_SDBCS_" TO "_SDECS
26 I SDFMT="S" S SDI=0 F S SDI=$O(SD(SDI)) Q:'SDI S SDII=SDII+1,SDT(SDII)="IN CLINICS WITH PRIMARY STOP CODE: "_SDI
27 I SDFMT="C" S SDII=SDII+1,SDT(SDII)="IN CLINIC GROUP: "_SD(SDCG)
28 S SDII=SDII+1,SDT(SDII)="FOR PATIENTS WITH AT LEAST "_SDMIN_" APPOINTMENTS TO THESE CLINICS",SDII=SDII+1
29 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDPAGE=1,SDLINE="",$P(SDLINE,"-",133)=""
30 S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV
31 I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
32 I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
33 D:$E(IOST)="C" DISP0^SCRPW23 S (SDI,SDIV)="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDI!(SDIV="") S:$O(^TMP("SCRPW",$J,SDIV,2,(SDMIN-1))) SDI=1
34 I 'SDI S SDIV=0 D DHDR^SCRPW40(SDII,.SDT),HDR G:SDOUT EXIT S SDX="No activity found that meets report criteria!" W !!?(IOM-$L(SDX)\2),SDX G EXIT
35 S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
36 S SDI=0,SDI=$O(^TMP("SCRPW",$J,SDI)),SDMD=$O(^TMP("SCRPW",$J,SDI))
37 G:SDOUT EXIT I SDMD S SDIV=0 D DPRT(.SDIV)
38 I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
39 G EXIT
40 ;
41DPRT(SDIV) ;Print report for a division
42 D DHDR^SCRPW40(SDII,.SDT) I '$O(^TMP("SCRPW",$J,SDIV,2,(SDMIN-1))) S SDX="No activity found for this division within report parameters!" D HDR Q:SDOUT W !!?(IOM-$L(SDX)\2),SDX Q
43 D HDR Q:SDOUT
44 S SDFREQ=999999999 F S SDFREQ=$O(^TMP("SCRPW",$J,SDIV,2,SDFREQ),-1) Q:SDFREQ'>0!(SDFREQ<SDMIN)!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,2,SDFREQ,DFN)) Q:DFN'>0!SDOUT D:SDORD="V" PRT D:SDORD="A" ALPH
45 I SDORD="A" S SDNAM="" F S SDNAM=$O(^TMP("SCRPW",$J,SDIV,3,SDNAM)) Q:SDNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,3,SDNAM,DFN)) Q:'DFN!SDOUT S SDFREQ=^TMP("SCRPW",$J,SDIV,3,SDNAM,DFN) D PRT
46 Q
47 ;
48EXIT D END^SCRPW50 K SD,SDFMT,SDBCS,SDBDAY,SDCL,SDCL0,SDCLCS,SDCLPT,SDCS,SDDAY,DFN,SDECS,SDEDAY,SDFREQ,SDMIN,SDPTAP0,SDPTCLT,SDPTCSF,SDI,SDOUT,DIC,DTOUT,DUOUT,%,%H,%I,%DT,SDDIV,SDII,SDMC,SDMD,X,SDIVN,SDSTOP,SDX
49 D KVA^VADPT K SDCG,SDORD,SDNAM,SDCLNA,SDPTCS,SDT,SDBDAY,SDEDAY,SDRBDA,SDREDA,SDPBDA,SDPEDA,SDPNOW,SDLINE,SDPAGE,DGPGM,DGVAR,DIR,POP,Y,V,ZTSAVE,^TMP("SCRPW",$J) Q
50 ;
51STOP ;Check for stop task request
52 S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
53 ;
54R K DIR S DIR(0)="N^101:999:0",DIR("?")="Specify a range of Clinic Stop codes defined for clinics to be returned in this report",DIR("A")="Start with CLINIC STOP"
55 W ! D ^DIR S:$D(DTOUT)!$D(DUOUT)!($G(Y)<1) SDOUT=1 Q:SDOUT S SDBCS=Y,DIR(0)="N^"_Y_":999:0",DIR("A")="End with CLINIC STOP" D ^DIR S:$D(DTOUT)!$D(DUOUT)!($G(Y)<1) SDOUT=1 Q:SDOUT S SDECS=Y Q
56 ;
57S K SD,DIC S DIC="^DIC(40.7,",DIC(0)="AEMQZ" F D S1 Q:$G(Y)<1
58 S:$D(DTOUT)!$D(DUOUT)!'$D(SD) SDOUT=1 Q
59 ;
60S1 D ^DIC I Y>0 S SD($P(Y(0),U,2))=""
61 Q
62 ;
63C K SD,DIC S DIC="^SD(409.67,",DIC(0)="AEMQ" W ! D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) S SDOUT=1 Q
64 S SD(+Y)=$P(Y,U,2) Q
65 ;
66DIV() ;Check division
67 Q:'SDDIV 1 Q $D(SDDIV(+$P(SDCL0,U,15)))
68 ;
69LOOP S SDCLCS=$P(SDCL0,U,7),SDCLCS=$P($G(^DIC(40.7,+SDCLCS,0)),U,2),SDIV=$P(SDCL0,U,15) S:'SDIV SDIV=$$PRIM^VASITE()
70 I SDFMT="R" Q:SDCLCS<SDBCS!(SDCLCS>SDECS)
71 I SDFMT="S" Q:'$D(SD(+SDCLCS))
72L1 S SDDAY=SDBDAY F S SDDAY=$O(^SC(SDCL,"S",SDDAY)) Q:(SDDAY'>0!(SDDAY>SDEDAY))!SDOUT S SDCLPT=0 F S SDCLPT=$O(^SC(SDCL,"S",SDDAY,1,SDCLPT)) Q:SDCLPT'>0!SDOUT S DFN=+^SC(SDCL,"S",SDDAY,1,SDCLPT,0) D EVAL
73 Q
74 ;
75EVAL S SDSTOP=SDSTOP+1 I SDSTOP#1000=0 D STOP Q:SDOUT
76 S SDPTAP0=^DPT(DFN,"S",SDDAY,0) Q:$P(SDPTAP0,U,2)["C"!($P(SDPTAP0,U,2)["N") D EV1(SDIV) D:SDMD EV1(0)
77 Q
78 ;
79EV1(SDIV) S ^TMP("SCRPW",$J,SDIV,0,DFN)=$G(^TMP("SCRPW",$J,SDIV,0,DFN))+1,^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS,$P(SDCL0,U))=$G(^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS,$P(SDCL0,U)))+1
80 S ^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS)=$G(^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS))+1 Q
81 ;
82FAPP S SDDAY=DT F S SDDAY=$O(^DPT(DFN,"S",SDDAY)) Q:SDDAY'>0 S SDPTAP0=^DPT(DFN,"S",SDDAY,0),SDCL=+SDPTAP0,SDCL0=^SC(SDCL,0),SDCLCS=$P(SDCL0,U,7),SDCLCS=$P(^DIC(40.7,SDCLCS,0),U,2) D FAP1
83 Q
84 ;
85FAP1 I SDFMT="R",$P(SDPTAP0,U,2)'["C",SDCLCS'<SDBCS,SDCLCS'>SDECS S ^TMP("SCRPW",$J,SDIV,1,DFN,SDDAY,$P(SDCL0,U))=SDCLCS
86 I SDFMT="S",$P(SDPTAP0,U,2)'["C",$D(SD(+SDCLCS)) S ^TMP("SCRPW",$J,SDIV,1,DFN,SDDAY,$P(SDCL0,U))=SDCLCS
87 Q
88 ;
89ORDR S SDFREQ=^TMP("SCRPW",$J,SDIV,0,DFN),^TMP("SCRPW",$J,SDIV,2,SDFREQ,DFN)="",SDPTCS=0
90 F S SDPTCS=$O(^TMP("SCRPW",$J,SDIV,0,DFN,SDPTCS)) Q:SDPTCS'>0 S SDPTCSF=^TMP("SCRPW",$J,SDIV,0,DFN,SDPTCS),^TMP("SCRPW",$J,SDIV,2,SDFREQ,DFN,SDPTCSF,SDPTCS)=""
91 Q
92 ;
93HDR ;Print report header
94 D STOP Q:SDOUT
95 I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
96 W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE S SDI=0 F S SDI=$O(SDT(SDI)) Q:'SDI W !?(132-$L(SDT(SDI))\2),SDT(SDI)
97 W !,SDLINE,!,"For date range: ",SDPBDA," to ",SDPEDA,!,"Date printed: ",SDPNOW,?(126-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
98 ;
99PRT D:$Y>(IOSL-7) HDR Q:SDOUT D ^VADPT W !!,"Number of appts.: ",SDFREQ,?24,"Patient: ",$E(VADM(1),1,30),?65,"SSN: ",$P(VADM(2),U,2)
100 S SDPTCSF=99999999 F S SDPTCSF=$O(^TMP("SCRPW",$J,SDIV,2,SDFREQ,DFN,SDPTCSF),-1) Q:SDPTCSF'>0!SDOUT S SDCLCS=0 F S SDCLCS=$O(^TMP("SCRPW",$J,SDIV,2,SDFREQ,DFN,SDPTCSF,SDCLCS)) Q:SDCLCS'>0!SDOUT D PRT1
101 I $D(^TMP("SCRPW",$J,SDIV,1,DFN)) D:$Y>(IOSL-5) HDR Q:SDOUT W !?44,"FUTURE APPOINTMENTS:" S SDDAY=0 F S SDDAY=$O(^TMP("SCRPW",$J,SDIV,1,DFN,SDDAY)) Q:SDDAY'>0!SDOUT D PRT2
102 Q
103 ;
104PRT1 D:$Y>(IOSL-6) HDR Q:SDOUT S SDCS=0,SDCS=$O(^DIC(40.7,"C",SDCLCS,SDCS)),SDCS=$P(^DIC(40.7,SDCS,0),U) W !?29,SDPTCSF," appointments to ",SDCS," (",SDCLCS,")"
105 S SDCLNA="" F S SDCLNA=$O(^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS,SDCLNA)) Q:SDCLNA']"" D:$Y>(IOSL-5) HDR Q:SDOUT S SDPTCLT=^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS,SDCLNA) W !?34,SDPTCLT," ",SDCLNA," appointment",$S(SDPTCLT=1:"",1:"s")
106 Q
107 ;
108PRT2 S SDCLNA="" F S SDCLNA=$O(^TMP("SCRPW",$J,SDIV,1,DFN,SDDAY,SDCLNA)) Q:SDCLNA']"" D:$Y>(IOSL-4) HDR Q:SDOUT S SDCLCS=^TMP("SCRPW",$J,SDIV,1,DFN,SDDAY,SDCLNA),Y=SDDAY X ^DD("DD") W !?44,Y," ",SDCLNA," (",SDCLCS,")"
109 Q
110 ;
111ALPH D ^VADPT S SDNAM=VADM(1),^TMP("SCRPW",$J,SDIV,3,SDNAM,DFN)=SDFREQ Q
Note: See TracBrowser for help on using the repository browser.