SCRPW42 ;RENO/KEITH - Veterans Without Activity Since a Specified Date Range (cont.) ; 5/25/2004
;;5.3;Scheduling;**144,176,375**;AUG 13, 1993
D:$E(IOST)="C" DISP0^SCRPW23 D HDR G:SDOUT EXIT D PRT0 G:SDOUT EXIT W !!,"REPORT TOTAL: ",SDT(0)
I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
EXIT D END^SCRPW50,KVA^VADPT K %,%H,%I,%DT,D0,DFN,DG1,DGA1,DGT,DGXFR0,DIR,DTOUT,DUOUT,S1,S2,S3,S4,S5,S6,SD,SD0,SDACR,SDUI
K SDACT,SDBD,SDDT,SDED,SDI,SDL,SDLINE,SDMTS,SDNOW,SDNUL,SDOE0,SDOUT,SDPAGE,SDPG,SDPNAM,SDPNOW,SDS,SDSSN,SDSTOP,SDT,SDTOT,SDX,SDY,SDZ,T,X,Y,SDFEE Q
;
HDR ;Print report header
I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
D STOP Q:SDOUT W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0)
W:$X $$XY^SCRPW50("",0,0)
W SDLINE,!?34,"<*> VETERANS WITHOUT ACTIVITY SINCE A SPECIFIED DATE RANGE <*>",!,SDLINE
W:SDFEE'="" !,?40,"****",SDFEE,"****"
W !,"Last activity date range: ",SD("PBDT")," to ",SD("PEDT"),!,"Date printed: ",SDPNOW,?(126-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
;
HD2 Q:SDOUT D:$Y>(IOSL-4) HDR Q:SDOUT W !,"Patient:",?26,"SSN:",?38,"Last activity:",?57,"Location:",?86,"Means Test:",?102,"Primary eligibility:" Q
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
DSV(S1,S2,S3,S4) ;Produce detail sort value
;Required input: S1, S2, S3, S4=subscript values
N SDX S SDX=$G(^TMP("SCRPW",$J,3,S1,S2,S3,S4)) Q:SDX SDX
S (SDX,^TMP("SCRPW",$J,3,0))=$G(^TMP("SCRPW",$J,3,0))+1
S ^TMP("SCRPW",$J,3,S1,S2,S3,S4)=SDX Q SDX
;
PRT0 ;Print 0 sorts
I '$D(^TMP("SCRPW",$J,1)) W !!,"No patients found that meet the report criteria!" S SDOUT=1 Q
S SDT(0)=0 I SD("SORT") D PRT1 Q
D SHD(0),HD2 S SDPNAM=""
F S SDPNAM=$O(^TMP("SCRPW",$J,1,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,1,SDPNAM,DFN)) Q:'DFN!SDOUT S SDX=^TMP("SCRPW",$J,1,SDPNAM,DFN) D PLINE(0)
Q
;
PRT1 ;Print 1 sort
S S1="" F S S1=$O(^TMP("SCRPW",$J,1,S1)) Q:S1=""!SDOUT D
.S SDT(1)=0 D:SD("PAGE")=1&SDPG HDR Q:SDOUT
.I SD("SORT")=1 D PRT11 Q
.D PRT2,SST(1) Q
Q
;
PRT2 ;Print 2 sorts
S S2="" F S S2=$O(^TMP("SCRPW",$J,1,S1,S2)) Q:S2=""!SDOUT D
.S SDT(2)=0 D:SD("PAGE")=2&SDPG HDR Q:SDOUT
.I SD("SORT")=2 D PRT21 Q
.D PRT3,SST(2) Q
Q
;
PRT3 ;Print 3 sorts
S S3="" F S S3=$O(^TMP("SCRPW",$J,1,S1,S2,S3)) Q:S3=""!SDOUT D
.S SDT(3)=0 D:SD("PAGE")=3&SDPG HDR Q:SDOUT
.I SD("SORT")=3 D PRT31 Q
.D PRT4,SST(3) Q
Q
;
PRT4 ;Print 4 sorts
S S4="" F S S4=$O(^TMP("SCRPW",$J,1,S1,S2,S3,S4)) Q:S4=""!SDOUT D
.S SDUI=$$DSV(S1,S2,S3,S4)
.S SDT(4)=0 D:SD("PAGE")=4&SDPG HDR Q:SDOUT
.I SD("SORT")=4 D PRT41 Q
.D PRT5,SST(4) Q
Q
;
PRT5 ;Print 5 sorts
S S5="" F S S5=$O(^TMP("SCRPW",$J,2,SDUI,S5)) Q:S5=""!SDOUT D
.S SDT(5)=0 D:SD("PAGE")=5&SDPG HDR Q:SDOUT
.I SD("SORT")=5 D PRT51 Q
.D PRT6,SST(5) Q
Q
;
PRT6 ;Print 6 sorts
S S6="" F S S6=$O(^TMP("SCRPW",$J,2,SDUI,S5,S6)) Q:S6=""!SDOUT S SDT(6)=0 D:SD("PAGE")=6&SDPG HDR Q:SDOUT D PRT61
Q
;
PRT11 D SHD(1),HD2 S SDPNAM=""
F S SDPNAM=$O(^TMP("SCRPW",$J,1,S1,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,1,S1,SDPNAM,DFN)) Q:'DFN!SDOUT S SDX=^TMP("SCRPW",$J,1,S1,SDPNAM,DFN) D PLINE(1)
W ! D SST(1) Q
;
PRT21 D SHD(2),HD2 S SDPNAM=""
F S SDPNAM=$O(^TMP("SCRPW",$J,1,S1,S2,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,1,S1,S2,SDPNAM,DFN)) Q:'DFN!SDOUT S SDX=^TMP("SCRPW",$J,1,S1,S2,SDPNAM,DFN) D PLINE(2)
W ! D SST(2) Q
;
PRT31 D SHD(3),HD2 S SDPNAM=""
F S SDPNAM=$O(^TMP("SCRPW",$J,1,S1,S2,S3,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,1,S1,S2,S3,SDPNAM,DFN)) Q:'DFN!SDOUT S SDX=^TMP("SCRPW",$J,1,S1,S2,S3,SDPNAM,DFN) D PLINE(3)
W ! D SST(3) Q
;
PRT41 D SHD(4),HD2 S SDPNAM=""
F S SDPNAM=$O(^TMP("SCRPW",$J,2,SDUI,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,2,SDUI,SDPNAM,DFN)) Q:'DFN!SDOUT S SDX=^TMP("SCRPW",$J,2,SDUI,SDPNAM,DFN) D PLINE(4)
W ! D SST(4) Q
;
PRT51 D SHD(5),HD2 S SDPNAM=""
F S SDPNAM=$O(^TMP("SCRPW",$J,2,SDUI,S5,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,2,SDUI,S5,SDPNAM,DFN)) Q:'DFN!SDOUT S SDX=^TMP("SCRPW",$J,2,SDUI,S5,SDPNAM,DFN) D PLINE(5)
W ! D SST(5) Q
;
PRT61 D SHD(6),HD2 S SDPNAM=""
F S SDPNAM=$O(^TMP("SCRPW",$J,2,SDUI,S5,S6,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,2,SDUI,S5,S6,SDPNAM,DFN)) Q:'DFN!SDOUT S SDX=^TMP("SCRPW",$J,2,SDUI,S5,S6,SDPNAM,DFN) D PLINE(6)
W ! D SST(6) Q
;
SHD(SDLEV) ;Print sort subheaders
;Required input: SDLEV=number of sort levels
Q:SDOUT
I $Y>(IOSL-SDLEV-6) D HDR S SDPG=0 Q:SDOUT
W:(SD("PAGE")'=SD("SORT")&SDPG) !!,SDLINE S SDPG=1
I SD("SORT") W ! N SDI S SDI=0 D W !
.F S SDI=$O(SD("SORT",SDI)) Q:'SDI W !?(5*SDI),$P(SD("SORT",SDI),U,2),": ",@("S"_SDI)
.Q
Q
;
PLINE(SDLEV) ;Print detail line
D:$Y>(IOSL-3) HDR,HD2 Q:SDOUT D ELIG^VADPT S SDMTS=$P(VAEL(9),U,2),SDMTS=$S($L(SDMTS)>13:$E(SDMTS,1,13)_".",1:SDMTS)
W !,$E(SDPNAM,1,24),?26,$P(SDX,U) S Y=$P(SDX,U,2) X ^DD("DD") W ?38,$P(Y,":",1,2),?57,$E($P(SDX,U,3),1,27),?86,SDMTS,?102,$P(VAEL(1),U,2)
N SDI F SDI=0:1:SDLEV S SDT(SDI)=SDT(SDI)+1
Q
;
SST(SDLEV) ;Print sort subtotal
D:$Y>(IOSL-3) HDR Q:SDOUT
W !?(5*SDLEV),"SUBTOTAL: ",SDT(SDLEV)," " S SDX=$P(SD("SORT",SDLEV),U,2)_" = "_@("S"_SDLEV),SDX=$E(SDX,1,(130-$X)) W "(",SDX,")" Q
;
S44 ;Print 'Means Test/Eligibility/Enrollment Report'
F SDX="MTP","EEP","EPP" S SDIV="" D
.F S SDIV=$O(^TMP("SCRPW",$J,0,SDIV)) Q:SDIV="" S SDZ="" D
..F S SDZ=$O(^TMP("SCRPW",$J,0,SDIV,SDX,SDZ)) Q:SDZ="" S (SDTU,SDTV,DFN)=0 D
...F S DFN=$O(^TMP("SCRPW",$J,0,SDIV,SDX,SDZ,DFN)) Q:'DFN S SDTU=SDTU+1,SDT=0 D
....F S SDT=$O(^TMP("SCRPW",$J,0,SDIV,SDX,SDZ,DFN,SDT)) Q:'SDT S SDTV=SDTV+1
....Q
...S $P(^TMP("SCRPW",$J,0,SDIV,$E(SDX,1,2),SDZ,"ENC"),U,2)=SDTV_U_SDTU Q
..Q
.Q
S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,0,SDIV)) Q:SDIV="" S (SDTU,SDTV)=0 D
.S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,0,SDIV,"RPT",DFN)) Q:'DFN S SDTU=SDTU+1,SDT=0 F S SDT=$O(^TMP("SCRPW",$J,0,SDIV,"RPT",DFN,SDT)) Q:'SDT S SDTV=SDTV+1
.S $P(^TMP("SCRPW",$J,0,SDIV,"RPT","ENC"),U,2)=SDTV_U_SDTU Q
.Q
D STOP G:SDOUT EXIT1
S SDLINE="",$P(SDLINE,"-",(IOM+1))="",SDPG=0 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDTIT(1)="<*> MEANS TEST/ELIGIBILITY/ENROLLMENT REPORT <*>" D
.I $P(SDDIV,U,2)="SELECTED DIVISIONS" D Q
..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 Q
..S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:'$L(SDX) SDX="***UNKNOWN***" S SDIV(SDX)=SDI
..Q
.S SDIV($P(SDDIV,U,2))=$P(SDDIV,U) Q
I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
D:$E(IOST)="C" DISP0^SCRPW23 S C=(IOM-80\2),SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT^SCRPW44(.SDIV)
G:SDOUT EXIT1 S SDMD=$O(^TMP("SCRPW",$J,0,0)),SDMD=$O(^TMP("SCRPW",$J,0,SDMD)) I SDMD S SDIV=0 D DPRT^SCRPW44(.SDIV)
I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR
EXIT1 D END^SCRPW50,KVA^VADPT K %,%DT,C,DFN,DIC,DIR,DTOUT,DUOUT,I,S0,S1,S2,S3,S4,S5,S6,SD,SD0,SDACR,SDACT,SDDIV,SDE,SDEL,SDEP,SDUI
K SDI,SDII,SDIV,SDIVN,SDL,SDL1,SDLEV,SDLF,SDLINE,SDMD,SDMT,SDMTS,SDNUL,SDOE,SDOE0,SDOUT,SDP,SDPAGE,SDPG,SDPGL,SDPNAM,SDPNOW,SDS,SDSSN,SDSTOP
K SDT,SDTIT,SDTU,SDTV,SDU,SDV,SDX,SDY,SDZ,T,X,Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW42 7462 printed Nov 22, 2024@17:53:40 Page 2
SCRPW42 ;RENO/KEITH - Veterans Without Activity Since a Specified Date Range (cont.) ; 5/25/2004
+1 ;;5.3;Scheduling;**144,176,375**;AUG 13, 1993
+2 if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
DO HDR
if SDOUT
GOTO EXIT
DO PRT0
if SDOUT
GOTO EXIT
WRITE !!,"REPORT TOTAL: ",SDT(0)
+3 IF $EXTRACT(IOST)="C"
IF 'SDOUT
NEW DIR
SET DIR(0)="E"
DO ^DIR
EXIT DO END^SCRPW50
DO KVA^VADPT
KILL %,%H,%I,%DT,D0,DFN,DG1,DGA1,DGT,DGXFR0,DIR,DTOUT,DUOUT,S1,S2,S3,S4,S5,S6,SD,SD0,SDACR,SDUI
+1 KILL SDACT,SDBD,SDDT,SDED,SDI,SDL,SDLINE,SDMTS,SDNOW,SDNUL,SDOE0,SDOUT,SDPAGE,SDPG,SDPNAM,SDPNOW,SDS,SDSSN,SDSTOP,SDT,SDTOT,SDX,SDY,SDZ,T,X,Y,SDFEE
QUIT
+2 ;
HDR ;Print report header
+1 IF $EXTRACT(IOST)="C"
IF SDPAGE>1
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET SDOUT=Y'=1
if SDOUT
QUIT
+2 DO STOP
if SDOUT
QUIT
if SDPAGE>1!($EXTRACT(IOST)="C")
WRITE $$XY^SCRPW50(IOF,1,0)
+3 if $X
WRITE $$XY^SCRPW50("",0,0)
+4 WRITE SDLINE,!?34,"<*> VETERANS WITHOUT ACTIVITY SINCE A SPECIFIED DATE RANGE <*>",!,SDLINE
+5 if SDFEE'=""
WRITE !,?40,"****",SDFEE,"****"
+6 WRITE !,"Last activity date range: ",SD("PBDT")," to ",SD("PEDT"),!,"Date printed: ",SDPNOW,?(126-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE
SET SDPAGE=SDPAGE+1
QUIT
+7 ;
HD2 if SDOUT
QUIT
if $Y>(IOSL-4)
DO HDR
if SDOUT
QUIT
WRITE !,"Patient:",?26,"SSN:",?38,"Last activity:",?57,"Location:",?86,"Means Test:",?102,"Primary eligibility:"
QUIT
+1 ;
STOP ;Check for stop task request
+1 if $DATA(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
DSV(S1,S2,S3,S4) ;Produce detail sort value
+1 ;Required input: S1, S2, S3, S4=subscript values
+2 NEW SDX
SET SDX=$GET(^TMP("SCRPW",$JOB,3,S1,S2,S3,S4))
if SDX
QUIT SDX
+3 SET (SDX,^TMP("SCRPW",$JOB,3,0))=$GET(^TMP("SCRPW",$JOB,3,0))+1
+4 SET ^TMP("SCRPW",$JOB,3,S1,S2,S3,S4)=SDX
QUIT SDX
+5 ;
PRT0 ;Print 0 sorts
+1 IF '$DATA(^TMP("SCRPW",$JOB,1))
WRITE !!,"No patients found that meet the report criteria!"
SET SDOUT=1
QUIT
+2 SET SDT(0)=0
IF SD("SORT")
DO PRT1
QUIT
+3 DO SHD(0)
DO HD2
SET SDPNAM=""
+4 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,1,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,1,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
SET SDX=^TMP("SCRPW",$JOB,1,SDPNAM,DFN)
DO PLINE(0)
+5 QUIT
+6 ;
PRT1 ;Print 1 sort
+1 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRPW",$JOB,1,S1))
if S1=""!SDOUT
QUIT
Begin DoDot:1
+2 SET SDT(1)=0
if SD("PAGE")=1&SDPG
DO HDR
if SDOUT
QUIT
+3 IF SD("SORT")=1
DO PRT11
QUIT
+4 DO PRT2
DO SST(1)
QUIT
End DoDot:1
+5 QUIT
+6 ;
PRT2 ;Print 2 sorts
+1 SET S2=""
FOR
SET S2=$ORDER(^TMP("SCRPW",$JOB,1,S1,S2))
if S2=""!SDOUT
QUIT
Begin DoDot:1
+2 SET SDT(2)=0
if SD("PAGE")=2&SDPG
DO HDR
if SDOUT
QUIT
+3 IF SD("SORT")=2
DO PRT21
QUIT
+4 DO PRT3
DO SST(2)
QUIT
End DoDot:1
+5 QUIT
+6 ;
PRT3 ;Print 3 sorts
+1 SET S3=""
FOR
SET S3=$ORDER(^TMP("SCRPW",$JOB,1,S1,S2,S3))
if S3=""!SDOUT
QUIT
Begin DoDot:1
+2 SET SDT(3)=0
if SD("PAGE")=3&SDPG
DO HDR
if SDOUT
QUIT
+3 IF SD("SORT")=3
DO PRT31
QUIT
+4 DO PRT4
DO SST(3)
QUIT
End DoDot:1
+5 QUIT
+6 ;
PRT4 ;Print 4 sorts
+1 SET S4=""
FOR
SET S4=$ORDER(^TMP("SCRPW",$JOB,1,S1,S2,S3,S4))
if S4=""!SDOUT
QUIT
Begin DoDot:1
+2 SET SDUI=$$DSV(S1,S2,S3,S4)
+3 SET SDT(4)=0
if SD("PAGE")=4&SDPG
DO HDR
if SDOUT
QUIT
+4 IF SD("SORT")=4
DO PRT41
QUIT
+5 DO PRT5
DO SST(4)
QUIT
End DoDot:1
+6 QUIT
+7 ;
PRT5 ;Print 5 sorts
+1 SET S5=""
FOR
SET S5=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,S5))
if S5=""!SDOUT
QUIT
Begin DoDot:1
+2 SET SDT(5)=0
if SD("PAGE")=5&SDPG
DO HDR
if SDOUT
QUIT
+3 IF SD("SORT")=5
DO PRT51
QUIT
+4 DO PRT6
DO SST(5)
QUIT
End DoDot:1
+5 QUIT
+6 ;
PRT6 ;Print 6 sorts
+1 SET S6=""
FOR
SET S6=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,S5,S6))
if S6=""!SDOUT
QUIT
SET SDT(6)=0
if SD("PAGE")=6&SDPG
DO HDR
if SDOUT
QUIT
DO PRT61
+2 QUIT
+3 ;
PRT11 DO SHD(1)
DO HD2
SET SDPNAM=""
+1 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,1,S1,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,1,S1,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
SET SDX=^TMP("SCRPW",$JOB,1,S1,SDPNAM,DFN)
DO PLINE(1)
+2 WRITE !
DO SST(1)
QUIT
+3 ;
PRT21 DO SHD(2)
DO HD2
SET SDPNAM=""
+1 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,1,S1,S2,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,1,S1,S2,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
SET SDX=^TMP("SCRPW",$JOB,1,S1,S2,SDPNAM,DFN)
DO PLINE(2)
+2 WRITE !
DO SST(2)
QUIT
+3 ;
PRT31 DO SHD(3)
DO HD2
SET SDPNAM=""
+1 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,1,S1,S2,S3,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,1,S1,S2,S3,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
SET SDX=^TMP("SCRPW",$JOB,1,S1,S2,S3,SDPNAM,DFN)
DO PLINE(3)
+2 WRITE !
DO SST(3)
QUIT
+3 ;
PRT41 DO SHD(4)
DO HD2
SET SDPNAM=""
+1 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
SET SDX=^TMP("SCRPW",$JOB,2,SDUI,SDPNAM,DFN)
DO PLINE(4)
+2 WRITE !
DO SST(4)
QUIT
+3 ;
PRT51 DO SHD(5)
DO HD2
SET SDPNAM=""
+1 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,S5,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,S5,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
SET SDX=^TMP("SCRPW",$JOB,2,SDUI,S5,SDPNAM,DFN)
DO PLINE(5)
+2 WRITE !
DO SST(5)
QUIT
+3 ;
PRT61 DO SHD(6)
DO HD2
SET SDPNAM=""
+1 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,S5,S6,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,2,SDUI,S5,S6,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
SET SDX=^TMP("SCRPW",$JOB,2,SDUI,S5,S6,SDPNAM,DFN)
DO PLINE(6)
+2 WRITE !
DO SST(6)
QUIT
+3 ;
SHD(SDLEV) ;Print sort subheaders
+1 ;Required input: SDLEV=number of sort levels
+2 if SDOUT
QUIT
+3 IF $Y>(IOSL-SDLEV-6)
DO HDR
SET SDPG=0
if SDOUT
QUIT
+4 if (SD("PAGE")'=SD("SORT")&SDPG)
WRITE !!,SDLINE
SET SDPG=1
+5 IF SD("SORT")
WRITE !
NEW SDI
SET SDI=0
Begin DoDot:1
+6 FOR
SET SDI=$ORDER(SD("SORT",SDI))
if 'SDI
QUIT
WRITE !?(5*SDI),$PIECE(SD("SORT",SDI),U,2),": ",@("S"_SDI)
+7 QUIT
End DoDot:1
WRITE !
+8 QUIT
+9 ;
PLINE(SDLEV) ;Print detail line
+1 if $Y>(IOSL-3)
DO HDR
DO HD2
if SDOUT
QUIT
DO ELIG^VADPT
SET SDMTS=$PIECE(VAEL(9),U,2)
SET SDMTS=$SELECT($LENGTH(SDMTS)>13:$EXTRACT(SDMTS,1,13)_".",1:SDMTS)
+2 WRITE !,$EXTRACT(SDPNAM,1,24),?26,$PIECE(SDX,U)
SET Y=$PIECE(SDX,U,2)
XECUTE ^DD("DD")
WRITE ?38,$PIECE(Y,":",1,2),?57,$EXTRACT($PIECE(SDX,U,3),1,27),?86,SDMTS,?102,$PIECE(VAEL(1),U,2)
+3 NEW SDI
FOR SDI=0:1:SDLEV
SET SDT(SDI)=SDT(SDI)+1
+4 QUIT
+5 ;
SST(SDLEV) ;Print sort subtotal
+1 if $Y>(IOSL-3)
DO HDR
if SDOUT
QUIT
+2 WRITE !?(5*SDLEV),"SUBTOTAL: ",SDT(SDLEV)," "
SET SDX=$PIECE(SD("SORT",SDLEV),U,2)_" = "_@("S"_SDLEV)
SET SDX=$EXTRACT(SDX,1,(130-$X))
WRITE "(",SDX,")"
QUIT
+3 ;
S44 ;Print 'Means Test/Eligibility/Enrollment Report'
+1 FOR SDX="MTP","EEP","EPP"
SET SDIV=""
Begin DoDot:1
+2 FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,0,SDIV))
if SDIV=""
QUIT
SET SDZ=""
Begin DoDot:2
+3 FOR
SET SDZ=$ORDER(^TMP("SCRPW",$JOB,0,SDIV,SDX,SDZ))
if SDZ=""
QUIT
SET (SDTU,SDTV,DFN)=0
Begin DoDot:3
+4 FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,0,SDIV,SDX,SDZ,DFN))
if 'DFN
QUIT
SET SDTU=SDTU+1
SET SDT=0
Begin DoDot:4
+5 FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,0,SDIV,SDX,SDZ,DFN,SDT))
if 'SDT
QUIT
SET SDTV=SDTV+1
+6 QUIT
End DoDot:4
+7 SET $PIECE(^TMP("SCRPW",$JOB,0,SDIV,$EXTRACT(SDX,1,2),SDZ,"ENC"),U,2)=SDTV_U_SDTU
QUIT
End DoDot:3
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 SET SDIV=""
FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,0,SDIV))
if SDIV=""
QUIT
SET (SDTU,SDTV)=0
Begin DoDot:1
+11 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,0,SDIV,"RPT",DFN))
if 'DFN
QUIT
SET SDTU=SDTU+1
SET SDT=0
FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,0,SDIV,"RPT",DFN,SDT))
if 'SDT
QUIT
SET SDTV=SDTV+1
+12 SET $PIECE(^TMP("SCRPW",$JOB,0,SDIV,"RPT","ENC"),U,2)=SDTV_U_SDTU
QUIT
+13 QUIT
End DoDot:1
+14 DO STOP
if SDOUT
GOTO EXIT1
+15 SET SDLINE=""
SET $PIECE(SDLINE,"-",(IOM+1))=""
SET SDPG=0
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET SDPNOW=$PIECE(Y,":",1,2)
SET SDTIT(1)="<*> MEANS TEST/ELIGIBILITY/ENROLLMENT REPORT <*>"
Begin DoDot:1
+16 IF $PIECE(SDDIV,U,2)="SELECTED DIVISIONS"
Begin DoDot:2
+17 SET SDI=0
FOR
SET SDI=$ORDER(SDDIV(SDI))
if 'SDI
QUIT
SET SDIV(SDDIV(SDI))=SDI
+18 QUIT
End DoDot:2
QUIT
+19 IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
Begin DoDot:2
+20 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^DG(40.8,SDI,0)),U)
if '$LENGTH(SDX)
SET SDX="***UNKNOWN***"
SET SDIV(SDX)=SDI
+21 QUIT
End DoDot:2
QUIT
+22 SET SDIV($PIECE(SDDIV,U,2))=$PIECE(SDDIV,U)
QUIT
End DoDot:1
+23 IF 'SDDIV
IF $PIECE(SDDIV,U,2)'="ALL DIVISIONS"
SET SDIV($PIECE(SDDIV,U,2))=$$PRIM^VASITE()
+24 if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
SET C=(IOM-80\2)
SET SDIVN=""
FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
if SDIVN=""!SDOUT
QUIT
SET SDIV=SDIV(SDIVN)
DO DPRT^SCRPW44(.SDIV)
+25 if SDOUT
GOTO EXIT1
SET SDMD=$ORDER(^TMP("SCRPW",$JOB,0,0))
SET SDMD=$ORDER(^TMP("SCRPW",$JOB,0,SDMD))
IF SDMD
SET SDIV=0
DO DPRT^SCRPW44(.SDIV)
+26 IF $EXTRACT(IOST)="C"
IF 'SDOUT
WRITE !
NEW DIR
SET DIR(0)="E"
DO ^DIR
EXIT1 DO END^SCRPW50
DO KVA^VADPT
KILL %,%DT,C,DFN,DIC,DIR,DTOUT,DUOUT,I,S0,S1,S2,S3,S4,S5,S6,SD,SD0,SDACR,SDACT,SDDIV,SDE,SDEL,SDEP,SDUI
+1 KILL SDI,SDII,SDIV,SDIVN,SDL,SDL1,SDLEV,SDLF,SDLINE,SDMD,SDMT,SDMTS,SDNUL,SDOE,SDOE0,SDOUT,SDP,SDPAGE,SDPG,SDPGL,SDPNAM,SDPNOW,SDS,SDSSN,SDSTOP
+2 KILL SDT,SDTIT,SDTU,SDTV,SDU,SDV,SDX,SDY,SDZ,T,X,Y
QUIT
