SCRPW11.m

SCRPW11 ;RENO/KEITH - Patient Activity by Appointment Frequency ; 15 Jul 98  02:38PM

 ;;5.3;PIMS;**139,144,1015,1016**;JUN 30, 2012;Build 20

 D TITL^SCRPW50("Patient Activity by Appointment Frequency") N SDDIV Q:'$$DIVA^SCRPW17(.SDDIV)

DTR D SUBT^SCRPW50("*** Date Range Selection ***")

FDT W ! S %DT="AEPX",%DT("A")="Beginning date: ",%DT(0)="-TODAY" D ^%DT G:X=U!($D(DTOUT)) EXIT G:X="" EXIT

 G:Y<1 FDT S SDBDAY=Y X ^DD("DD") S SDPBDA=Y

LDT W ! S %DT("A")="   Ending date: " D ^%DT G:X=U!($D(DTOUT)) EXIT G:X="" EXIT

 I Y<SDBDAY W !!,$C(7),"Ending date must be after beginning date!" G LDT

 G:Y<1 LDT S SDEDAY=Y X ^DD("DD") S SDPEDA=Y

 D SUBT^SCRPW50("*** Report Format Selection ***")

 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

 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."

 D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT S SDFMT=Y,SDOUT=0 D @(SDFMT) G:SDOUT EXIT

 D SUBT^SCRPW50("*** Output Order Selection ***")

 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

 N ZTSAVE F V="SD(","SDDIV","SDDIV(","SDFMT","SDMIN","SDBDAY","SDEDAY","SDPBDA","SDPEDA","SDBCS","SDECS","SDORD","SDMC","SDMD" S ZTSAVE(V)=""

 W !!,"This report requires 132 column output.",! D EN^XUTMDEVQ("START^SCRPW11","PT. ACTIVITY BY APPT. FREQUENCY",.ZTSAVE) G EXIT

 ;

START 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

 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

 G:SDOUT EXIT

 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

 G:SDOUT EXIT

 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

 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

 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

 I SDFMT="C" S SDII=SDII+1,SDT(SDII)="IN CLINIC GROUP: "_SD(SDCG)

 S SDII=SDII+1,SDT(SDII)="FOR PATIENTS WITH AT LEAST "_SDMIN_" APPOINTMENTS TO THESE CLINICS",SDII=SDII+1

 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDPAGE=1,SDLINE="",$P(SDLINE,"-",133)=""

 S SDIV="" F  S SDIV=$O(SDDIV(SDIV)) Q:'SDIV  S SDIV(SDDIV(SDIV))=SDIV

 I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()

 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

 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

 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

 S SDIVN="" F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT  S SDIV=SDIV(SDIVN) D DPRT(.SDIV)

 S SDI=0,SDI=$O(^TMP("SCRPW",$J,SDI)),SDMD=$O(^TMP("SCRPW",$J,SDI))

 G:SDOUT EXIT I SDMD S SDIV=0 D DPRT(.SDIV)

 I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR

 G EXIT

 ;

DPRT(SDIV) ;Print report for a division

 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

 D HDR Q:SDOUT

 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

 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

 Q

 ;

EXIT 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

 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

 ;

STOP ;Check for stop task request

 S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q

 ;

R 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"

 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

 ;

S K SD,DIC S DIC="^DIC(40.7,",DIC(0)="AEMQZ" F  D S1 Q:$G(Y)<1

 S:$D(DTOUT)!$D(DUOUT)!'$D(SD) SDOUT=1 Q

 ;

S1 D ^DIC I Y>0 S SD($P(Y(0),U,2))=""

 Q

 ;

C 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

 S SD(+Y)=$P(Y,U,2) Q

 ;

DIV() ;Check division

 Q:'SDDIV 1  Q $D(SDDIV(+$P(SDCL0,U,15)))

 ;

LOOP 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()

 I SDFMT="R" Q:SDCLCS<SDBCS!(SDCLCS>SDECS)

 I SDFMT="S" Q:'$D(SD(+SDCLCS))

L1 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

 Q

 ;

EVAL S SDSTOP=SDSTOP+1 I SDSTOP#1000=0 D STOP Q:SDOUT

 ;SD*562 if DFN missing in appt sub-file of file #44 delete record

 I '$D(DFN)!(DFN="")!(DFN=0) D  Q

 .S DA(2)=SDCL,DA(1)=SDDAY,DA=SDCLPT

 .S DIK="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIK

 .K DA,DIK

 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)

 Q

 ;

EV1(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

 S ^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS)=$G(^TMP("SCRPW",$J,SDIV,0,DFN,SDCLCS))+1 Q

 ;

FAPP 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

 Q

 ;

FAP1 I SDFMT="R",$P(SDPTAP0,U,2)'["C",SDCLCS'<SDBCS,SDCLCS'>SDECS S ^TMP("SCRPW",$J,SDIV,1,DFN,SDDAY,$P(SDCL0,U))=SDCLCS

 I SDFMT="S",$P(SDPTAP0,U,2)'["C",$D(SD(+SDCLCS)) S ^TMP("SCRPW",$J,SDIV,1,DFN,SDDAY,$P(SDCL0,U))=SDCLCS

 Q

 ;

ORDR S SDFREQ=^TMP("SCRPW",$J,SDIV,0,DFN),^TMP("SCRPW",$J,SDIV,2,SDFREQ,DFN)="",SDPTCS=0

 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)=""

 Q

 ;

HDR ;Print report header

 D STOP Q:SDOUT

 I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT

 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)

 W !,SDLINE,!,"For date range: ",SDPBDA," to ",SDPEDA,!,"Date printed: ",SDPNOW,?(126-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q

 ;

PRT 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)

 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

 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

 Q

 ;

PRT1 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,")"

 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")

 Q

 ;

PRT2 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,")"

 Q

 ;

ALPH D ^VADPT S SDNAM=VADM(1),^TMP("SCRPW",$J,SDIV,3,SDNAM,DFN)=SDFREQ Q

SCRPW11   ;RENO/KEITH - Patient Activity by Appointment Frequency ; 15 Jul 98  02:38PM

 +1       ;;5.3;PIMS;**139,144,1015,1016**;JUN 30, 2012;Build 20

 +2        DO TITL^SCRPW50("Patient Activity by Appointment Frequency")

           NEW SDDIV

           IF '$$DIVA^SCRPW17(.SDDIV)

               QUIT 

DTR        DO SUBT^SCRPW50("*** Date Range Selection ***")

FDT        WRITE !

           SET %DT="AEPX"

           SET %DT("A")="Beginning date: "

           SET %DT(0)="-TODAY"

           DO ^%DT

           IF X=U!($DATA(DTOUT))

               GOTO EXIT

           IF X=""

               GOTO EXIT

 +1        IF Y<1

               GOTO FDT

           SET SDBDAY=Y

           XECUTE ^DD("DD")

           SET SDPBDA=Y

LDT        WRITE !

           SET %DT("A")="   Ending date: "

           DO ^%DT

           IF X=U!($DATA(DTOUT))

               GOTO EXIT

           IF X=""

               GOTO EXIT

 +1        IF Y<SDBDAY

               WRITE !!,$CHAR(7),"Ending date must be after beginning date!"

               GOTO LDT

 +2        IF Y<1

               GOTO LDT

           SET SDEDAY=Y

           XECUTE ^DD("DD")

           SET SDPEDA=Y

 +3        DO SUBT^SCRPW50("*** Report Format Selection ***")

 +4        WRITE !

           SET DIR(0)="N^1:999:0"

           SET DIR("?")="Enter the minimum number of appointments for a patient to be included in this report"

           SET DIR("A")="Minimum appointment frequency"

           DO ^DIR

           IF Y'>0

               GOTO EXIT

           SET SDMIN=Y

 +5        KILL DIR

           SET DIR(0)="S^R:RANGE OF STOP CODES;S:SELECTED STOP CODES;C:CLINIC GROUP"

           SET DIR("A")="Limit clinics by"

           SET DIR("?")="Output will be limited to primary stop codes or clinic group as specified."

 +6        DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               GOTO EXIT

           SET SDFMT=Y

           SET SDOUT=0

           DO @(SDFMT)

           IF SDOUT

               GOTO EXIT

 +7        DO SUBT^SCRPW50("*** Output Order Selection ***")

 +8        KILL DIR

           SET DIR(0)="S^A:ALPHABETIC;V:VISIT FREQUENCY"

           SET DIR("A")="Specify output order"

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               GOTO EXIT

           SET SDORD=Y

 +9        NEW ZTSAVE

           FOR V="SD(","SDDIV","SDDIV(","SDFMT","SDMIN","SDBDAY","SDEDAY","SDPBDA","SDPEDA","SDBCS","SDECS","SDORD","SDMC","SDMD"

               SET ZTSAVE(V)=""

 +10       WRITE !!,"This report requires 132 column output.",!

           DO EN^XUTMDEVQ("START^SCRPW11","PT. ACTIVITY BY APPT. FREQUENCY",.ZTSAVE)

           GOTO EXIT

 +11      ;

START      KILL ^TMP("SCRPW",$JOB)

           SET (SDOUT,SDSTOP)=0

           SET SDMD=$ORDER(SDDIV(0))

           SET SDMD=$ORDER(SDDIV(SDMD))

           IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"

               SET SDMD=1

 +1        IF SDFMT="C"

               SET SDCG=$ORDER(SD(0))

               SET SDCL=0

               FOR 

                   SET SDCL=$ORDER(^SC("ASCRPW",SDCG,SDCL))

                   IF 'SDCL

                       QUIT 

                   SET SDCL0=$GET(^SC(SDCL,0))

                   IF $$DIV()

                       DO LOOP

                       IF SDOUT

                           QUIT 

 +2        IF SDOUT

               GOTO EXIT

 +3        IF SDFMT'="C"

               SET SDCL=0

               FOR 

                   SET SDCL=$ORDER(^SC(SDCL))

                   IF SDCL'>0

                       QUIT 

                   SET SDCL0=$GET(^SC(SDCL,0))

                   IF $$DIV()

                       DO LOOP

                       IF SDOUT

                           QUIT 

 +4        IF SDOUT

               GOTO EXIT

 +5        SET SDIV=""

           FOR 

               SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))

               IF SDIV=""!SDOUT

                   QUIT 

               SET DFN=0

               FOR 

                   SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,0,DFN))

                   IF DFN'>0

                       QUIT 

                   SET SDSTOP=SDSTOP+1

                   IF SDSTOP#1000=0

                       DO STOP

                   IF SDOUT

                       QUIT 

                   DO FAPP

                   DO ORDR

 +6        SET SDII=1

           SET SDT(SDII)="<*>  PATIENT ACTIVITY BY APPOINTMENT FREQUENCY  <*>"

           IF SDFMT="R"

               SET SDII=SDII+1

               SET SDT(SDII)="IN CLINICS WITH PRIMARY STOP CODES "_SDBCS_" TO "_SDECS

 +7        IF SDFMT="S"

               SET SDI=0

               FOR 

                   SET SDI=$ORDER(SD(SDI))

                   IF 'SDI

                       QUIT 

                   SET SDII=SDII+1

                   SET SDT(SDII)="IN CLINICS WITH PRIMARY STOP CODE: "_SDI

 +8        IF SDFMT="C"

               SET SDII=SDII+1

               SET SDT(SDII)="IN CLINIC GROUP: "_SD(SDCG)

 +9        SET SDII=SDII+1

           SET SDT(SDII)="FOR PATIENTS WITH AT LEAST "_SDMIN_" APPOINTMENTS TO THESE CLINICS"

           SET SDII=SDII+1

 +10       DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

           SET SDPNOW=$PIECE(Y,":",1,2)

           SET SDPAGE=1

           SET SDLINE=""

           SET $PIECE(SDLINE,"-",133)=""

 +11       SET SDIV=""

           FOR 

               SET SDIV=$ORDER(SDDIV(SDIV))

               IF 'SDIV

                   QUIT 

               SET SDIV(SDDIV(SDIV))=SDIV

 +12       IF 'SDDIV

               IF $PIECE(SDDIV,U,2)'="ALL DIVISIONS"

                   SET SDIV($PIECE(SDDIV,U,2))=$$PRIM^VASITE()

 +13       IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"

               SET SDI=0

               FOR 

                   SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))

                   IF 'SDI

                       QUIT 

                   SET SDX=$PIECE($GET(^DG(40.8,SDI,0)),U)

                   IF $LENGTH(SDX)

                       SET SDIV(SDX)=SDI

 +14       IF $EXTRACT(IOST)="C"

               DO DISP0^SCRPW23

           SET (SDI,SDIV)=""

           FOR 

               SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))

               IF SDI!(SDIV="")

                   QUIT 

               IF $ORDER(^TMP("SCRPW",$JOB,SDIV,2,(SDMIN-1)))

                   SET SDI=1

 +15       IF 'SDI

               SET SDIV=0

               DO DHDR^SCRPW40(SDII,.SDT)

               DO HDR

               IF SDOUT

                   GOTO EXIT

               SET SDX="No activity found that meets report criteria!"

               WRITE !!?(IOM-$LENGTH(SDX)\2),SDX

               GOTO EXIT

 +16       SET SDIVN=""

           FOR 

               SET SDIVN=$ORDER(SDIV(SDIVN))

               IF SDIVN=""!SDOUT

                   QUIT 

               SET SDIV=SDIV(SDIVN)

               DO DPRT(.SDIV)

 +17       SET SDI=0

           SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))

           SET SDMD=$ORDER(^TMP("SCRPW",$JOB,SDI))

 +18       IF SDOUT

               GOTO EXIT

           IF SDMD

               SET SDIV=0

               DO DPRT(.SDIV)

 +19       IF $EXTRACT(IOST)="C"

               IF 'SDOUT

                   NEW DIR

                   SET DIR(0)="E"

                   DO ^DIR

 +20       GOTO EXIT

 +21      ;

DPRT(SDIV) ;Print report for a division

 +1        DO DHDR^SCRPW40(SDII,.SDT)

           IF '$ORDER(^TMP("SCRPW",$JOB,SDIV,2,(SDMIN-1)))

               SET SDX="No activity found for this division within report parameters!"

               DO HDR

               IF SDOUT

                   QUIT 

               WRITE !!?(IOM-$LENGTH(SDX)\2),SDX

               QUIT 

 +2        DO HDR

           IF SDOUT

               QUIT 

 +3        SET SDFREQ=999999999

           FOR 

               SET SDFREQ=$ORDER(^TMP("SCRPW",$JOB,SDIV,2,SDFREQ),-1)

               IF SDFREQ'>0!(SDFREQ<SDMIN)!SDOUT

                   QUIT 

               SET DFN=0

               FOR 

                   SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,2,SDFREQ,DFN))

                   IF DFN'>0!SDOUT

                       QUIT 

                   IF SDORD="V"

                       DO PRT

                   IF SDORD="A"

                       DO ALPH

 +4        IF SDORD="A"

               SET SDNAM=""

               FOR 

                   SET SDNAM=$ORDER(^TMP("SCRPW",$JOB,SDIV,3,SDNAM))

                   IF SDNAM=""!SDOUT

                       QUIT 

                   SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,3,SDNAM,DFN))

                       IF 'DFN!SDOUT

                           QUIT 

                       SET SDFREQ=^TMP("SCRPW",$JOB,SDIV,3,SDNAM,DFN)

                       DO PRT

 +5        QUIT 

 +6       ;

EXIT       DO END^SCRPW50

           KILL 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

 +1        DO KVA^VADPT

           KILL SDCG,SDORD,SDNAM,SDCLNA,SDPTCS,SDT,SDBDAY,SDEDAY,SDRBDA,SDREDA,SDPBDA,SDPEDA,SDPNOW,SDLINE,SDPAGE,DGPGM,DGVAR,DIR,POP,Y,V,ZTSAVE,^TMP("SCRPW",$JOB)

           QUIT 

 +2       ;

STOP      ;Check for stop task request

 +1        IF $GET(ZTQUEUED)

               SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)

           QUIT 

 +2       ;

R          KILL DIR

           SET DIR(0)="N^101:999:0"

           SET DIR("?")="Specify a range of Clinic Stop codes defined for clinics to be returned in this report"

           SET DIR("A")="Start with CLINIC STOP"

 +1        WRITE !

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)<1)

               SET SDOUT=1

           IF SDOUT

               QUIT 

           SET SDBCS=Y

           SET DIR(0)="N^"_Y_":999:0"

           SET DIR("A")="End with CLINIC STOP"

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)<1)

               SET SDOUT=1

           IF SDOUT

               QUIT 

           SET SDECS=Y

           QUIT 

 +2       ;

S          KILL SD,DIC

           SET DIC="^DIC(40.7,"

           SET DIC(0)="AEMQZ"

           FOR 

               DO S1

               IF $GET(Y)<1

                   QUIT 

 +1        IF $DATA(DTOUT)!$DATA(DUOUT)!'$DATA(SD)

               SET SDOUT=1

           QUIT 

 +2       ;

S1         DO ^DIC

           IF Y>0

               SET SD($PIECE(Y(0),U,2))=""

 +1        QUIT 

 +2       ;

C          KILL SD,DIC

           SET DIC="^SD(409.67,"

           SET DIC(0)="AEMQ"

           WRITE !

           DO ^DIC

           IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)<1)

               SET SDOUT=1

               QUIT 

 +1        SET SD(+Y)=$PIECE(Y,U,2)

           QUIT 

 +2       ;

DIV()     ;Check division

 +1        IF 'SDDIV

               QUIT 1

           QUIT $DATA(SDDIV(+$PIECE(SDCL0,U,15)))

 +2       ;

LOOP       SET SDCLCS=$PIECE(SDCL0,U,7)

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

           SET SDIV=$PIECE(SDCL0,U,15)

           IF 'SDIV

               SET SDIV=$$PRIM^VASITE()

 +1        IF SDFMT="R"

               IF SDCLCS<SDBCS!(SDCLCS>SDECS)

                   QUIT 

 +2        IF SDFMT="S"

               IF '$DATA(SD(+SDCLCS))

                   QUIT 

L1         SET SDDAY=SDBDAY

           FOR 

               SET SDDAY=$ORDER(^SC(SDCL,"S",SDDAY))

               IF (SDDAY'>0!(SDDAY>SDEDAY))!SDOUT

                   QUIT 

               SET SDCLPT=0

               FOR 

                   SET SDCLPT=$ORDER(^SC(SDCL,"S",SDDAY,1,SDCLPT))

                   IF SDCLPT'>0!SDOUT

                       QUIT 

                   SET DFN=+^SC(SDCL,"S",SDDAY,1,SDCLPT,0)

                   DO EVAL

 +1        QUIT 

 +2       ;

EVAL       SET SDSTOP=SDSTOP+1

           IF SDSTOP#1000=0

               DO STOP

               IF SDOUT

                   QUIT 

 +1       ;SD*562 if DFN missing in appt sub-file of file #44 delete record

 +2        IF '$DATA(DFN)!(DFN="")!(DFN=0)

               Begin DoDot:1

 +3                SET DA(2)=SDCL

                   SET DA(1)=SDDAY

                   SET DA=SDCLPT

 +4                SET DIK="^SC("_DA(2)_",""S"","_DA(1)_",1,"

                   DO ^DIK

 +5                KILL DA,DIK

               End DoDot:1

               QUIT 

 +6        SET SDPTAP0=^DPT(DFN,"S",SDDAY,0)

           IF $PIECE(SDPTAP0,U,2)["C"!($PIECE(SDPTAP0,U,2)["N")

               QUIT 

           DO EV1(SDIV)

           IF SDMD

               DO EV1(0)

 +7        QUIT 

 +8       ;

EV1(SDIV)  SET ^TMP("SCRPW",$JOB,SDIV,0,DFN)=$GET(^TMP("SCRPW",$JOB,SDIV,0,DFN))+1

           SET ^TMP("SCRPW",$JOB,SDIV,0,DFN,SDCLCS,$PIECE(SDCL0,U))=$GET(^TMP("SCRPW",$JOB,SDIV,0,DFN,SDCLCS,$PIECE(SDCL0,U)))+1

 +1        SET ^TMP("SCRPW",$JOB,SDIV,0,DFN,SDCLCS)=$GET(^TMP("SCRPW",$JOB,SDIV,0,DFN,SDCLCS))+1

           QUIT 

 +2       ;

FAPP       SET SDDAY=DT

           FOR 

               SET SDDAY=$ORDER(^DPT(DFN,"S",SDDAY))

               IF SDDAY'>0

                   QUIT 

               SET SDPTAP0=^DPT(DFN,"S",SDDAY,0)

               SET SDCL=+SDPTAP0

               SET SDCL0=^SC(SDCL,0)

               SET SDCLCS=$PIECE(SDCL0,U,7)

               SET SDCLCS=$PIECE(^DIC(40.7,SDCLCS,0),U,2)

               DO FAP1

 +1        QUIT 

 +2       ;

FAP1       IF SDFMT="R"

               IF $PIECE(SDPTAP0,U,2)'["C"

                   IF SDCLCS'<SDBCS

                       IF SDCLCS'>SDECS

                           SET ^TMP("SCRPW",$JOB,SDIV,1,DFN,SDDAY,$PIECE(SDCL0,U))=SDCLCS

 +1        IF SDFMT="S"

               IF $PIECE(SDPTAP0,U,2)'["C"

                   IF $DATA(SD(+SDCLCS))

                       SET ^TMP("SCRPW",$JOB,SDIV,1,DFN,SDDAY,$PIECE(SDCL0,U))=SDCLCS

 +2        QUIT 

 +3       ;

ORDR       SET SDFREQ=^TMP("SCRPW",$JOB,SDIV,0,DFN)

           SET ^TMP("SCRPW",$JOB,SDIV,2,SDFREQ,DFN)=""

           SET SDPTCS=0

 +1        FOR 

               SET SDPTCS=$ORDER(^TMP("SCRPW",$JOB,SDIV,0,DFN,SDPTCS))

               IF SDPTCS'>0

                   QUIT 

               SET SDPTCSF=^TMP("SCRPW",$JOB,SDIV,0,DFN,SDPTCS)

               SET ^TMP("SCRPW",$JOB,SDIV,2,SDFREQ,DFN,SDPTCSF,SDPTCS)=""

 +2        QUIT 

 +3       ;

HDR       ;Print report header

 +1        DO STOP

           IF SDOUT

               QUIT 

 +2        IF $EXTRACT(IOST)="C"

               IF SDPAGE>1

                   NEW DIR

                   SET DIR(0)="E"

                   DO ^DIR

                   SET SDOUT=Y'=1

                   IF SDOUT

                       QUIT 

 +3        IF SDPAGE>1!($EXTRACT(IOST)="C")