SCRPW6.m

SCRPW6 ;RENO/KEITH - Trend of Facility Uniques by 12 Month Date Ranges ; 15 Jul 98  02:38PM

 ;;5.3;Scheduling;**139,144,466,510,1015**;AUG 13, 1993;Build 21

 N SDDIV,SDI,SDSTA,DIR D TITL^SCRPW50("Trend of Facility Uniques by 12 Month Date Ranges") G:'$$DIVA^SCRPW17(.SDDIV) EXIT

 D SUBT^SCRPW50("**** Status Selection ****")

 S DIR(0)="S^1:Checked Out (Outpatients);2:Checked Out (Inpatients);3:Checked Out (Out/Inpatients)",DIR("A")="Select Status",DIR("B")="1"

 D ^DIR I $D(DTOUT)!$D(DUOUT)!(+Y<0) G EXIT

 S SDSTA=$S(Y=1:2,Y=2:8,1:"2^8")

QUE W !!,"This report requires 132 column output.",!

 N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(","SDSTA" S ZTSAVE(X)=""

 D EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE),DISP0^SCRPW23 Q

UNIQ ;Calculate/print uniques

 S (SDOUT,SDSTOP)=0,SDLINE="",SDPAGE=1,$P(SDLINE,"-",133)="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDMD=$O(SDDIV(0)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1

 K ^TMP("SCRPW",$J) S SDBDT=$E(DT,1,3)-5_$E(DT,4,5)_"00",SDEDT=$E(DT,1,5)_"00",SDXEDT=$E(DT,1,3)-1_$E(DT,4,5)_"00" D OENC G:SDOUT EXIT

 S SDIV="" F  S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV=""  D STOP Q:SDOUT  D

 .S SDDT=SDBDT,SDXDT=$$YDTINC(SDDT),^TMP("SCRPW",$J,SDIV,"YR","MAX")=0 D LOOK

 .F  S SDDT=$$DTINC(SDDT) Q:SDDT>SDXEDT  S SDXDT=$$YDTINC(SDDT) D LOOK I ^TMP("SCRPW",$J,SDIV,"YR",SDDT)>^TMP("SCRPW",$J,SDIV,"YR","MAX") S ^TMP("SCRPW",$J,SDIV,"YR","MAX")=^TMP("SCRPW",$J,SDIV,"YR",SDDT)

 G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 I '$D(^TMP("SCRPW",$J)) D HDR G:SDOUT EXIT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT

 I $P(SDDIV,U,2)="SELECTED DIVISIONS" D

 .S SDI=0 F  S SDI=$O(SDDIV(SDI)) Q:'SDI  S SDIV(SDDIV(SDI))=SDI

 .Q

 I $P(SDDIV,U,2)="ALL DIVISIONS" D

 .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) SDX="***UNKNOWN***" S SDIV(SDX)=SDI

 .Q

 S:$D(SDIV)'>1 SDIV($P(SDDIV,U,2))=$P(SDDIV,U,3)

 G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 S SDIVN="" F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT  S SDIV=SDIV(SDIVN) D DPRT(.SDIV)

 G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) I SDMD S SDIV=0 D DPRT(.SDIV)

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

 ;

EXIT K SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y D END^SCRPW50 Q

 ;

DPRT(SDIV) ;Print division

 K SDTIT D DHDR^SCRPW46(SDIV,1,.SDTIT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity within report parameters found for this division!" D HDR Q:SDOUT  W !!?(IOM-$L(SDX)\2),SDX Q

 S SDDT=SDBDT D FIG,HDR,HD1 Q:SDOUT  D LINE(SDDT) F  S SDDT=$O(^TMP("SCRPW",$J,SDIV,"YR",SDDT)) Q:'SDDT!SDOUT  D LINE(SDDT)

 D:$Y>($S(IOSL<80:IOSL,1:80)-5) HDR Q:SDOUT  F  W ! Q:$Y>($S(IOSL<80:IOSL,1:80)-6)

 W !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a"

 W !?25,"status of '"_$S(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'.  This excludes any 'action required' activity."

 Q

 ;

DIV(SDD) ;Check division

 ;Required input: MEDICAL CENTER DIVISION pointer

 Q:'SDDIV 1

 Q $D(SDDIV(SDD))

 ;

SET(SDIV) ;Set TMP global

 S SDSTOP=SDSTOP+1 D:SDSTOP#2000=0 STOP Q:SDOUT

 Q:'SDIV  D SET1(SDIV) D:SDMD SET1(0) Q

 ;

SET1(SDIV) S ^TMP("SCRPW",$J,SDIV,"PT",SDDFN,$E(SDDT,1,5)_"00")="" Q

 ;

OENC S SDXDT=SDBDT,SDDFN=0

 F  S SDDFN=$O(^SCE("ADFN",SDDFN)) Q:'SDDFN  S SDDT=SDXDT F  S SDDT=$O(^SCE("ADFN",SDDFN,SDDT)) Q:'SDDT!(SDDT>SDEDT)  D OENC1

 Q

 ;

OENC1 S SDOE=0 F  S SDOE=$O(^SCE("ADFN",SDDFN,SDDT,SDOE)) Q:'SDOE  S SDOE0=$$GETOE^SDOE(SDOE) I $$OE(SDOE0,SDSTA) S SDIV=$P(SDOE0,U,11) I SDIV,$$DIV(SDIV) D SET(SDIV)

 Q

 ;

OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter

 ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node

 ;                SDSTA=2 -outpatient,8 -inpatient, 2^8 -both

 ;Output: '1' if checked out "parent" encounter, '0' otherwise

 I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0

 S SDSTA=$G(SDSTA,2),SDSTA="^"_SDSTA_"^"

 Q:'$P(SDOE0,U,6)&(SDSTA[$P(SDOE0,U,12))&($P(SDOE0,U,7)'="") 1

 Q 0

 ;

STOP ;Check for stop task request

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

 ;

HDR D STOP Q:SDOUT  I $E(IOST)="C" 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,!?36,"<*>  TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES  <*>"

 N SDI S SDI=$S(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients") W !,?53,SDI ;?(132-SDI\2),SDI

 S SDI=0 F  S SDI=$O(SDTIT(SDI)) Q:'SDI  W !?(132-$L(SDTIT(SDI))\2),SDTIT(SDI)

 W !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q

 ;

HD1 Q:SDOUT  W !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$S(SDFIG=1:"",1:"s"),")",!,$E(SDLINE,1,SDFIG1) Q

 ;

DTINC(SDDT) ;Increment date by one month

 ;Required input: SDDT=date

 ;Output: next month to examine

 Q:$E(SDDT,4,5)=12 $E(SDDT,1,3)+1_"0100"

 Q $E(SDDT,1,5)+1_"00"

 ;

LOOK S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=0,SDDFN=0 F  S SDDFN=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN)) Q:'SDDFN  D L1

 Q

 ;

L1 I $D(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) D LSET Q

 S SDX=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) I SDX,SDX<SDXDT D LSET

 Q

 ;

LSET S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=^TMP("SCRPW",$J,SDIV,"YR",SDDT)+1 Q

 ;

YDTINC(SDDT) ;Increment date by one year

 ;Required input: SDDT=date

 ;Output: date + 1 year

 Q $E(SDDT,1,3)+1_$E(SDDT,4,7)

 ;

FIG S SDMAX=^TMP("SCRPW",$J,SDIV,"YR","MAX") F SDFIG=1,10,25,50,100,250,500,1000,2500,5000,10000 Q:SDMAX/SDFIG<99

 S SDFIG1=34+(SDMAX\SDFIG) S:SDFIG1<73 SDFIG1=73 Q

 ;

LINE(SDDT) ;Print statistics line

 ;Required input: SDDT=date

 D:$Y>(IOSL-3) HDR,HD1 Q:SDOUT  S SDCT=^TMP("SCRPW",$J,SDIV,"YR",SDDT),SDMO=$E(SDDT,4,5),SDYR=(17+$E(SDDT))_$E(SDDT,2,3),SDXMO=SDMO-1 S:SDXMO=0 SDXMO=12 S:$L(SDXMO)=1 SDXMO=0_SDXMO

 S SDXYR=$S(SDXMO=12:SDYR,1:SDYR+1)

 W !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$J(SDCT,6,0),?32,"| " F SDI=1:1:(SDCT\SDFIG) W "*"

 Q

SCRPW6    ;RENO/KEITH - Trend of Facility Uniques by 12 Month Date Ranges ; 15 Jul 98  02:38PM

 +1       ;;5.3;Scheduling;**139,144,466,510,1015**;AUG 13, 1993;Build 21

 +2        NEW SDDIV,SDI,SDSTA,DIR

           DO TITL^SCRPW50("Trend of Facility Uniques by 12 Month Date Ranges")

           IF '$$DIVA^SCRPW17(.SDDIV)

               GOTO EXIT

 +3        DO SUBT^SCRPW50("**** Status Selection ****")

 +4        SET DIR(0)="S^1:Checked Out (Outpatients);2:Checked Out (Inpatients);3:Checked Out (Out/Inpatients)"

           SET DIR("A")="Select Status"

           SET DIR("B")="1"

 +5        DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!(+Y<0)

               GOTO EXIT

 +6        SET SDSTA=$SELECT(Y=1:2,Y=2:8,1:"2^8")

QUE        WRITE !!,"This report requires 132 column output.",!

 +1        NEW ZTSAVE

           FOR X="SDDIV","SDDIV(","SDDNU(","SDSTA"

               SET ZTSAVE(X)=""

 +2        DO EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE)

           DO DISP0^SCRPW23

           QUIT 

UNIQ      ;Calculate/print uniques

 +1        SET (SDOUT,SDSTOP)=0

           SET SDLINE=""

           SET SDPAGE=1

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

           DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

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

           SET SDMD=$ORDER(SDDIV(0))

           SET SDMD=$ORDER(SDDIV(SDMD))

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

               SET SDMD=1

 +2        KILL ^TMP("SCRPW",$JOB)

           SET SDBDT=$EXTRACT(DT,1,3)-5_$EXTRACT(DT,4,5)_"00"

           SET SDEDT=$EXTRACT(DT,1,5)_"00"

           SET SDXEDT=$EXTRACT(DT,1,3)-1_$EXTRACT(DT,4,5)_"00"

           DO OENC

           IF SDOUT

               GOTO EXIT

 +3        SET SDIV=""

           FOR 

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

               IF SDIV=""

                   QUIT 

               DO STOP

               IF SDOUT

                   QUIT 

               Begin DoDot:1

 +4                SET SDDT=SDBDT

                   SET SDXDT=$$YDTINC(SDDT)

                   SET ^TMP("SCRPW",$JOB,SDIV,"YR","MAX")=0

                   DO LOOK

 +5                FOR 

                       SET SDDT=$$DTINC(SDDT)

                       IF SDDT>SDXEDT

                           QUIT 

                       SET SDXDT=$$YDTINC(SDDT)

                       DO LOOK

                       IF ^TMP("SCRPW",$JOB,SDIV,"YR",SDDT)>^TMP("SCRPW",$JOB,SDIV,"YR","MAX")

                           SET ^TMP("SCRPW",$JOB,SDIV,"YR","MAX")=^TMP("SCRPW",$JOB,SDIV,"YR",SDDT)

               End DoDot:1

 +6        IF SDOUT

               GOTO EXIT

           IF $EXTRACT(IOST)="C"

               DO DISP0^SCRPW23

           IF '$DATA(^TMP("SCRPW",$JOB))

               DO HDR

               IF SDOUT

                   GOTO EXIT

               SET SDX="No activity found within selected report parameters!"

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

               GOTO EXIT

 +7        IF $PIECE(SDDIV,U,2)="SELECTED DIVISIONS"

               Begin DoDot:1

 +8                SET SDI=0

                   FOR 

                       SET SDI=$ORDER(SDDIV(SDI))

                       IF 'SDI

                           QUIT 

                       SET SDIV(SDDIV(SDI))=SDI

 +9                QUIT 

               End DoDot:1

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

               Begin DoDot:1

 +11               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 SDX="***UNKNOWN***"

                       SET SDIV(SDX)=SDI

 +12               QUIT 

               End DoDot:1

 +13       IF $DATA(SDIV)'>1

               SET SDIV($PIECE(SDDIV,U,2))=$PIECE(SDDIV,U,3)

 +14       IF SDOUT

               GOTO EXIT

           IF $EXTRACT(IOST)="C"

               DO DISP0^SCRPW23

           SET SDIVN=""

           FOR 

               SET SDIVN=$ORDER(SDIV(SDIVN))

               IF SDIVN=""!SDOUT

                   QUIT 

               SET SDIV=SDIV(SDIVN)

               DO DPRT(.SDIV)

 +15       IF SDOUT

               GOTO EXIT

           SET SDMD=0

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

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

           IF SDMD

               SET SDIV=0

               DO DPRT(.SDIV)

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

               IF 'SDOUT

                   WRITE !

                   NEW DIR

                   SET DIR(0)="E"

                   DO ^DIR

 +17      ;

EXIT       KILL SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y

           DO END^SCRPW50

           QUIT 

 +1       ;

DPRT(SDIV) ;Print division

 +1        KILL SDTIT

           DO DHDR^SCRPW46(SDIV,1,.SDTIT)

           IF '$DATA(^TMP("SCRPW",$JOB,SDIV))

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

               DO HDR

               IF SDOUT

                   QUIT 

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

               QUIT 

 +2        SET SDDT=SDBDT

           DO FIG

           DO HDR

           DO HD1

           IF SDOUT

               QUIT 

           DO LINE(SDDT)

           FOR 

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

               IF 'SDDT!SDOUT

                   QUIT 

               DO LINE(SDDT)

 +3        IF $Y>($SELECT(IOSL<80

               DO HDR

           IF SDOUT

               QUIT 

           FOR 

               WRITE !

               IF $Y>($SELECT(IOSL<80

                   QUIT 

 +4        WRITE !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a"

 +5        WRITE !?25,"status of '"_$SELECT(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'.  This excludes any 'action required' activity."

 +6        QUIT 

 +7       ;

DIV(SDD)  ;Check division

 +1       ;Required input: MEDICAL CENTER DIVISION pointer

 +2        IF 'SDDIV

               QUIT 1

 +3        QUIT $DATA(SDDIV(SDD))

 +4       ;

SET(SDIV) ;Set TMP global

 +1        SET SDSTOP=SDSTOP+1

           IF SDSTOP#2000=0

               DO STOP

           IF SDOUT

               QUIT 

 +2        IF 'SDIV

               QUIT 

           DO SET1(SDIV)

           IF SDMD

               DO SET1(0)

           QUIT 

 +3       ;

SET1(SDIV)  SET ^TMP("SCRPW",$JOB,SDIV,"PT",SDDFN,$EXTRACT(SDDT,1,5)_"00")=""

           QUIT 

 +1       ;

OENC       SET SDXDT=SDBDT

           SET SDDFN=0

 +1        FOR 

               SET SDDFN=$ORDER(^SCE("ADFN",SDDFN))

               IF 'SDDFN

                   QUIT 

               SET SDDT=SDXDT

               FOR 

                   SET SDDT=$ORDER(^SCE("ADFN",SDDFN,SDDT))

                   IF 'SDDT!(SDDT>SDEDT)

                       QUIT 

                   DO OENC1

 +2        QUIT 

 +3       ;

OENC1      SET SDOE=0

           FOR 

               SET SDOE=$ORDER(^SCE("ADFN",SDDFN,SDDT,SDOE))

               IF 'SDOE

                   QUIT 

               SET SDOE0=$$GETOE^SDOE(SDOE)

               IF $$OE(SDOE0,SDSTA)

                   SET SDIV=$PIECE(SDOE0,U,11)

                   IF SDIV

                       IF $$DIV(SDIV)

                           DO SET(SDIV)

 +1        QUIT 

 +2       ;

OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter

 +1       ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node

 +2       ;                SDSTA=2 -outpatient,8 -inpatient, 2^8 -both

 +3       ;Output: '1' if checked out "parent" encounter, '0' otherwise

 +4        IF $PIECE(SDOE0,U,4)

               IF $PIECE($GET(^SC($PIECE(SDOE0,U,4),0)),U,17)="Y"

                   QUIT 0

 +5        SET SDSTA=$GET(SDSTA,2)

           SET SDSTA="^"_SDSTA_"^"

 +6        IF '$PIECE(SDOE0,U,6)&(SDSTA[$PIECE(SDOE0,U,12))&($PIECE(SDOE0,U,7)'="")

               QUIT 1

 +7        QUIT 0

 +8       ;

STOP      ;Check for stop task request

 +1        IF $GET(ZTQUEUED)

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

           QUIT 

 +2       ;

HDR        DO STOP

           IF SDOUT

               QUIT 

           IF $EXTRACT(IOST)="C"

               NEW DIR

               SET DIR(0)="E"

               DO ^DIR

               SET SDOUT=Y'=1

               IF SDOUT

                   QUIT 

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

               WRITE $$XY^SCRPW50(IOF,1,0)

           IF $X

               WRITE $$XY^SCRPW50("",0,0)

           WRITE SDLINE,!?36,"<*>  TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES  <*>"

 +2       ;?(132-SDI\2),SDI

           NEW SDI

           SET SDI=$SELECT(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients")

           WRITE !,?53,SDI

 +3        SET SDI=0

           FOR 

               SET SDI=$ORDER(SDTIT(SDI))

               IF 'SDI

                   QUIT 

               WRITE !?(132-$LENGTH(SDTIT(SDI))\2),SDTIT(SDI)

 +4        WRITE !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE

           SET SDPAGE=SDPAGE+1

           QUIT 

 +5       ;

HD1        IF SDOUT

               QUIT 

           WRITE !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$SELECT(SDFIG=1:"",1:"s"),")",!,$EXTRACT(SDLINE,1,SDFIG1)

           QUIT 

 +1       ;

DTINC(SDDT) ;Increment date by one month

 +1       ;Required input: SDDT=date

 +2       ;Output: next month to examine

 +3        IF $EXTRACT(SDDT,4,5)=12

               QUIT $EXTRACT(SDDT,1,3)+1_"0100"

 +4        QUIT $EXTRACT(SDDT,1,5)+1_"00"

 +5       ;

LOOK       SET ^TMP("SCRPW",$JOB,SDIV,"YR",SDDT)=0

           SET SDDFN=0

           FOR 

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

               IF 'SDDFN

                   QUIT 

               DO L1

 +1        QUIT 

 +2       ;

L1         IF $DATA(^TMP("SCRPW",$JOB,SDIV,"PT",SDDFN,SDDT))

               DO LSET

               QUIT 

 +1        SET SDX=$ORDER(^TMP("SCRPW",$JOB,SDIV,"PT",SDDFN,SDDT))

           IF SDX

               IF SDX<SDXDT

                   DO LSET

 +2        QUIT 

 +3       ;

LSET       SET ^TMP("SCRPW",$JOB,SDIV,"YR",SDDT)=^TMP("SCRPW",$JOB,SDIV,"YR",SDDT)+1

           QUIT 

 +1       ;

YDTINC(SDDT) ;Increment date by one year

 +1       ;Required input: SDDT=date

 +2       ;Output: date + 1 year

 +3        QUIT $EXTRACT(SDDT,1,3)+1_$EXTRACT(SDDT,4,7)

 +4       ;

FIG        SET SDMAX=^TMP("SCRPW",$JOB,SDIV,"YR","MAX")

           FOR SDFIG=1,10,25,50,100,250,500,1000,2500,5000,10000

               IF SDMAX/SDFIG<99

                   QUIT 

 +1        SET SDFIG1=34+(SDMAX\SDFIG)

           IF SDFIG1<73

               SET SDFIG1=73

           QUIT 

 +2       ;

LINE(SDDT) ;Print statistics line

 +1       ;Required input: SDDT=date

 +2        IF $Y>(IOSL-3)

               DO HDR

               DO HD1

           IF SDOUT

               QUIT 

           SET SDCT=^TMP("SCRPW",$JOB,SDIV,"YR",SDDT)

           SET SDMO=$EXTRACT(SDDT,4,5)

           SET SDYR=(17+$EXTRACT(SDDT))_$EXTRACT(SDDT,2,3)

           SET SDXMO=SDMO-1

           IF SDXMO=0

               SET SDXMO=12

           IF $LENGTH(SDXMO)=1

               SET SDXMO=0_SDXMO

 +3        SET SDXYR=$SELECT(SDXMO=12:SDYR,1:SDYR+1)

 +4        WRITE !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$JUSTIFY(SDCT,6,0),?32,"| "

           FOR SDI=1:1:(SDCT\SDFIG)

               WRITE "*"

 +5        QUIT