source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPW42.m@ 1328

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1SCRPW42 ;RENO/KEITH - Veterans Without Activity Since a Specified Date Range (cont.) ; 5/25/2004
2 ;;5.3;Scheduling;**144,176,375**;AUG 13, 1993
3 D:$E(IOST)="C" DISP0^SCRPW23 D HDR G:SDOUT EXIT D PRT0 G:SDOUT EXIT W !!,"REPORT TOTAL: ",SDT(0)
4 I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
5EXIT 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
6 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
7 ;
8HDR ;Print report header
9 I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
10 D STOP Q:SDOUT W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0)
11 W:$X $$XY^SCRPW50("",0,0)
12 W SDLINE,!?34,"<*> VETERANS WITHOUT ACTIVITY SINCE A SPECIFIED DATE RANGE <*>",!,SDLINE
13 W:SDFEE'="" !,?40,"****",SDFEE,"****"
14 W !,"Last activity date range: ",SD("PBDT")," to ",SD("PEDT"),!,"Date printed: ",SDPNOW,?(126-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
15 ;
16HD2 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
17 ;
18STOP ;Check for stop task request
19 S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
20 ;
21DSV(S1,S2,S3,S4) ;Produce detail sort value
22 ;Required input: S1, S2, S3, S4=subscript values
23 N SDX S SDX=$G(^TMP("SCRPW",$J,3,S1,S2,S3,S4)) Q:SDX SDX
24 S (SDX,^TMP("SCRPW",$J,3,0))=$G(^TMP("SCRPW",$J,3,0))+1
25 S ^TMP("SCRPW",$J,3,S1,S2,S3,S4)=SDX Q SDX
26 ;
27PRT0 ;Print 0 sorts
28 I '$D(^TMP("SCRPW",$J,1)) W !!,"No patients found that meet the report criteria!" S SDOUT=1 Q
29 S SDT(0)=0 I SD("SORT") D PRT1 Q
30 D SHD(0),HD2 S SDPNAM=""
31 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)
32 Q
33 ;
34PRT1 ;Print 1 sort
35 S S1="" F S S1=$O(^TMP("SCRPW",$J,1,S1)) Q:S1=""!SDOUT D
36 .S SDT(1)=0 D:SD("PAGE")=1&SDPG HDR Q:SDOUT
37 .I SD("SORT")=1 D PRT11 Q
38 .D PRT2,SST(1) Q
39 Q
40 ;
41PRT2 ;Print 2 sorts
42 S S2="" F S S2=$O(^TMP("SCRPW",$J,1,S1,S2)) Q:S2=""!SDOUT D
43 .S SDT(2)=0 D:SD("PAGE")=2&SDPG HDR Q:SDOUT
44 .I SD("SORT")=2 D PRT21 Q
45 .D PRT3,SST(2) Q
46 Q
47 ;
48PRT3 ;Print 3 sorts
49 S S3="" F S S3=$O(^TMP("SCRPW",$J,1,S1,S2,S3)) Q:S3=""!SDOUT D
50 .S SDT(3)=0 D:SD("PAGE")=3&SDPG HDR Q:SDOUT
51 .I SD("SORT")=3 D PRT31 Q
52 .D PRT4,SST(3) Q
53 Q
54 ;
55PRT4 ;Print 4 sorts
56 S S4="" F S S4=$O(^TMP("SCRPW",$J,1,S1,S2,S3,S4)) Q:S4=""!SDOUT D
57 .S SDUI=$$DSV(S1,S2,S3,S4)
58 .S SDT(4)=0 D:SD("PAGE")=4&SDPG HDR Q:SDOUT
59 .I SD("SORT")=4 D PRT41 Q
60 .D PRT5,SST(4) Q
61 Q
62 ;
63PRT5 ;Print 5 sorts
64 S S5="" F S S5=$O(^TMP("SCRPW",$J,2,SDUI,S5)) Q:S5=""!SDOUT D
65 .S SDT(5)=0 D:SD("PAGE")=5&SDPG HDR Q:SDOUT
66 .I SD("SORT")=5 D PRT51 Q
67 .D PRT6,SST(5) Q
68 Q
69 ;
70PRT6 ;Print 6 sorts
71 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
72 Q
73 ;
74PRT11 D SHD(1),HD2 S SDPNAM=""
75 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)
76 W ! D SST(1) Q
77 ;
78PRT21 D SHD(2),HD2 S SDPNAM=""
79 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)
80 W ! D SST(2) Q
81 ;
82PRT31 D SHD(3),HD2 S SDPNAM=""
83 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)
84 W ! D SST(3) Q
85 ;
86PRT41 D SHD(4),HD2 S SDPNAM=""
87 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)
88 W ! D SST(4) Q
89 ;
90PRT51 D SHD(5),HD2 S SDPNAM=""
91 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)
92 W ! D SST(5) Q
93 ;
94PRT61 D SHD(6),HD2 S SDPNAM=""
95 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)
96 W ! D SST(6) Q
97 ;
98SHD(SDLEV) ;Print sort subheaders
99 ;Required input: SDLEV=number of sort levels
100 Q:SDOUT
101 I $Y>(IOSL-SDLEV-6) D HDR S SDPG=0 Q:SDOUT
102 W:(SD("PAGE")'=SD("SORT")&SDPG) !!,SDLINE S SDPG=1
103 I SD("SORT") W ! N SDI S SDI=0 D W !
104 .F S SDI=$O(SD("SORT",SDI)) Q:'SDI W !?(5*SDI),$P(SD("SORT",SDI),U,2),": ",@("S"_SDI)
105 .Q
106 Q
107 ;
108PLINE(SDLEV) ;Print detail line
109 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)
110 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)
111 N SDI F SDI=0:1:SDLEV S SDT(SDI)=SDT(SDI)+1
112 Q
113 ;
114SST(SDLEV) ;Print sort subtotal
115 D:$Y>(IOSL-3) HDR Q:SDOUT
116 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
117 ;
118S44 ;Print 'Means Test/Eligibility/Enrollment Report'
119 F SDX="MTP","EEP","EPP" S SDIV="" D
120 .F S SDIV=$O(^TMP("SCRPW",$J,0,SDIV)) Q:SDIV="" S SDZ="" D
121 ..F S SDZ=$O(^TMP("SCRPW",$J,0,SDIV,SDX,SDZ)) Q:SDZ="" S (SDTU,SDTV,DFN)=0 D
122 ...F S DFN=$O(^TMP("SCRPW",$J,0,SDIV,SDX,SDZ,DFN)) Q:'DFN S SDTU=SDTU+1,SDT=0 D
123 ....F S SDT=$O(^TMP("SCRPW",$J,0,SDIV,SDX,SDZ,DFN,SDT)) Q:'SDT S SDTV=SDTV+1
124 ....Q
125 ...S $P(^TMP("SCRPW",$J,0,SDIV,$E(SDX,1,2),SDZ,"ENC"),U,2)=SDTV_U_SDTU Q
126 ..Q
127 .Q
128 S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,0,SDIV)) Q:SDIV="" S (SDTU,SDTV)=0 D
129 .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
130 .S $P(^TMP("SCRPW",$J,0,SDIV,"RPT","ENC"),U,2)=SDTV_U_SDTU Q
131 .Q
132 D STOP G:SDOUT EXIT1
133 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
134 .I $P(SDDIV,U,2)="SELECTED DIVISIONS" D Q
135 ..S SDI=0 F S SDI=$O(SDDIV(SDI)) Q:'SDI S SDIV(SDDIV(SDI))=SDI
136 ..Q
137 .I $P(SDDIV,U,2)="ALL DIVISIONS" D Q
138 ..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
139 ..Q
140 .S SDIV($P(SDDIV,U,2))=$P(SDDIV,U) Q
141 I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
142 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)
143 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)
144 I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR
145EXIT1 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
146 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
147 K SDT,SDTIT,SDTU,SDTV,SDU,SDV,SDX,SDY,SDZ,T,X,Y Q
Note: See TracBrowser for help on using the repository browser.