source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLRPS2.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1SDWLRPS2 ;;IOFO BAY PINES/TEH - WAIT LIST REPORT FORMAT 1-SUMMARY;06/12/2002 ; 20 Aug 2002 2:10 PM
2 ;;5.3;scheduling;**263,412**;AUG 13 1993
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ;
11 ;
12 ;
13 ;
14EN ;
15 D INIT
16 I $$S^%ZTLOAD G END
17 D HD
18 D SORT
19 I $$S^%ZTLOAD G END
20 D PRT G:POP END ;SD*5.3*412 added for early exit
21 I $$S^%ZTLOAD G END
22 D PRT1
23 K ^TMP("SDWLRPS2",$J)
24 Q
25INIT ;Initialize variables
26 ;
27 I $D(CT1) S SDWLCT1=CT1
28 I $D(CT2) S SDWLCT2=CT2
29 I $D(DATE) S SDWLDATE=DATE
30 I $D(FORM) S SDWLFORM=FORM
31 I $D(INS) S (SDWLINS,SDWLINST)=INS
32 I $D(OPEN) S SDWLOPEN=OPEN
33 S SDWLPG=0
34 I $D(ZTSAVE) D
35 .F SDWLI="CT1","CT2","FORM","INS","OPEN" S SDWL="SDWL"_SDWLI,@SDWL=$G(ZTSAVE(SDWLI))
36 I SDWLINS="ALL" S SDWLIN("ALL")=""
37 S SDWLINST=SDWLINS
38 S SDWLTXP=$P(SDWLCT1,U,3)
39 I SDWLINS'="ALL" F SDWLI=1:1 S SDWLIN=$P($P(SDWLINS,";",SDWLI),U,1) Q:SDWLIN="" S SDWLIN(SDWLIN)="",^TMP("SDWLRPS2",$J,"D",1,SDWLIN)=0,^TMP("SDWLRPS2",$J,"D",2,SDWLIN)=0
40 I SDWLCT2'="ALL" F SDWLI=1:1 S SDWLCL=$P($P(SDWLCT2,";",SDWLI),U,1) Q:SDWLCL="" S SDWLCT2(SDWLCL)=""
41 S SDWLSCX=$S($P(SDWLCT1,U,1)="T":5,1:6)
42 D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
43 N POP S POP=0 ;SD*5.3*412
44 Q
45SORT ;Sort Records
46 S SDWLCNT=0
47 S SDWLDA=0 F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D
48 .S SDWLX=$G(^SDWL(409.3,SDWLDA,0)),SDWLERR=0,SDWLDFN=+SDWLX
49 .;-Check for Institution Sort
50 .I SDWLINS'="ALL" D
51 ..I '$D(SDWLIN(+$P(SDWLX,U,3))) S SDWLERR=1 Q
52 .S SDWLAPDT=$P(SDWLX,U,16),SDWLOPDT=$P(SDWLX,U,2) S X1=DT,X2=SDWLOPDT D ^%DTC S SDWLDWT=+X I SDWLDWT<0 S SDWLDWT=0
53 .S SDWLTYP=$P(SDWLCT1,U,1),SDWLTYPE=$S(SDWLTYP="T":$P(SDWLX,U,6),1:$P(SDWLX,U,7)) I SDWLTYPE="" S SDWLERR=7 Q
54 .S SDWLF=$P(SDWLCT1,U,2)
55 .I SDWLCT2'="ALL" D
56 ..I '$D(SDWLCT2(SDWLTYPE)) S SDWLERR=3
57 .I SDWLTYP="" S SDWLERR=4 Q
58 .I $P(SDWLX,U,17)'[SDWLOPEN S SDWLERR=6 Q
59 .Q:SDWLERR D
60 ..S SDWLSCC=2 D ELIG^VADPT I $D(VAEL(3)) S SDWLSCN=$P(VAEL(3),U,2) I SDWLSCN>49 S SDWLSCC=1
61 ..S:'$D(^TMP("SDWLRPS2",$J,"A",+$P(SDWLX,U,3),SDWLTYPE)) ^(SDWLTYPE)=0
62 ..S ^TMP("SDWLRPS2",$J,"A",+$P(SDWLX,U,3),SDWLTYPE)=^(SDWLTYPE)+1
63 ..S:'$D(^TMP("SDWLRPS2",$J,"B",+$P(SDWLX,U,3),SDWLTYPE,SDWLDFN)) ^(SDWLDFN)=0 S ^TMP("SDWLRPS2",$J,"B",+$P(SDWLX,U,3),SDWLTYPE,SDWLDFN)=^(SDWLDFN)+1
64 ..S:'$D(^TMP("SDWLRPS2",$J,"C",SDWLSCC,+$P(SDWLX,U,3),SDWLTYPE)) ^TMP("SDWLRPS2",$J,"C",SDWLSCC,+$P(SDWLX,U,3),SDWLTYPE)=0
65 ..S ^TMP("SDWLRPS2",$J,"C",SDWLSCC,+$P(SDWLX,U,3),SDWLTYPE)=^(SDWLTYPE)+1
66 ..S ^TMP("SDWLRPS2",$J,"D",SDWLSCC,+$P(SDWLX,U,3),SDWLTYPE,99999999-SDWLDWT,SDWLDA)=""
67 ..S SDWLCNT=SDWLCNT+1,^TMP("SDWLRPS2",$J,"D",SDWLSCC,+$P(SDWLX,U,3))=SDWLCNT
68 Q
69PRT ;
70 S SDWLIN=0 F S SDWLIN=$O(^TMP("SDWLRPS2",$J,"A",SDWLIN)) Q:SDWLIN="" W !,"Institution: ",$$GET1^DIQ(4,SDWLIN_",",".01"),! D Q:POP ;SD*5.3*412
71 .D PRA
72 Q
73PRA ;
74 S SDWLSC=0,(SDWLX,SDWLXT)=0 F S SDWLSC=$O(^TMP("SDWLRPS2",$J,"A",SDWLIN,SDWLSC)) Q:SDWLSC="" D Q:POP ;SD*5.3*412 added Quit to Exit
75 .I '$D(SDWLSCX) S SDWLSCX=0
76 .S SDWLX=$G(^TMP("SDWLRPS2",$J,"A",SDWLIN,SDWLSC)),SDWLXT=SDWLXT+SDWLX W !,$$EXTERNAL^DILFD(409.3,SDWLSCX,,SDWLSC),?30,SDWLX
77 .S SDWLXTT=0,SDWLDFNX=0 F S SDWLDFNX=$O(^TMP("SDWLRPS2",$J,"B",SDWLIN,SDWLSC,SDWLDFNX)) Q:SDWLDFNX="" S SDWLXTT=SDWLXTT+1
78 W !,?21,"Total #: ",SDWLXT
79 I $D(SDWLSPT) D SCR Q:POP D HD,HD1 ;SD*5.3*412 added Quit
80 Q
81PRT1 ;
82 N DFN
83 S SDWLSCC=0 F S SDWLSCC=$O(^TMP("SDWLRPS2",$J,"D",SDWLSCC)) Q:SDWLSCC="" Q:$$S^%ZTLOAD D Q:POP ;SD*5.3*412 added Quit for early exit
84 .W !,"******* ",SDWLSCC," *******",!
85 .S SDWLINS=0 F S SDWLINS=$O(^TMP("SDWLRPS2",$J,"D",SDWLSCC,SDWLINS)) Q:SDWLINS="" D Q:POP W ! ;SD*5.3*412 added Quit
86 ..W !,$P($G(^DIC(4,SDWLINS,0)),U,1),! I '$G(^TMP("SDWLRPS2",$J,"D",SDWLSCC,SDWLINS)) W !,"*** No Patient Records to Report ***" D:$D(SDWLSPT) SCR Q:POP D HD,HD1 Q ;SD*5.3*412 added first Quit
87 ..S SDWLSC=0 F S SDWLSC=$O(^TMP("SDWLRPS2",$J,"D",SDWLSCC,SDWLINS,SDWLSC)) Q:SDWLSC="" D Q:POP ;SD*5.3*412 added Quit
88 ...S SDWLWT="" F S SDWLWT=$O(^TMP("SDWLRPS2",$J,"D",SDWLSCC,SDWLINS,SDWLSC,SDWLWT)) Q:SDWLWT="" D Q:POP ;SD*5.3*412 added Quit
89 ....S SDWLDA=0 F S SDWLDA=$O(^TMP("SDWLRPS2",$J,"D",SDWLSCC,SDWLINS,SDWLSC,SDWLWT,SDWLDA)) Q:SDWLDA="" D Q:POP ;SD*5.3*412 added Quit
90 .....S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLODT=$P(X,U,2),SDWLDDT=$P(X,U,16) S DFN=+X D Q:POP ;SD*5.3*412 added Quit
91 ......D DEM^VADPT,1^VADPT
92 ......W !,VA("BID"),?6,$E(VADM(1),1,25) W ?32,$E(SDWLODT,4,5),"/",$E(SDWLODT,6,7),"/",($E(SDWLODT,1,3)+1700)
93 ......W ?47,$J(99999999-SDWLWT,5)
94 ......D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 added Quit
95 .W !
96LINE ;Draw Line
97 W !,"_______________________________________________________________________________"
98 Q
99SCR W ! S DIR(0)="E" D ^DIR S:X="^" POP=1 ; SD*5.3*412
100 Q
101HD ;Header
102 W:$D(IOF) @IOF W !,SDWLDTP,?80-$L("PCMM ASSIGNMENT Wait List Report")\2,"PCMM ASSIGNMENT Wait List Report"
103 S SDWLPG=SDWLPG+1 W ?72,"Page: ",SDWLPG
104 W !!,?30,"Institution: " D
105 .F I=1:1 S X=$P(SDWLINST,";",I) Q:X="" W:I>1 ! W ?45,$$GET1^DIQ(4,X_",",".01")
106 S X=$P(SDWLCT2,U,2)
107 W !?27,"Report Category: ",$S($P(SDWLCT1,U,1)="T":"TEAM",1:"POSITION") I X="ALL" W " ALL"
108 I X'="ALL" D
109 .F I=1:1 S X=$P($P(SDWLCT2,";",I),"^",2) Q:X="" W !,?45,X
110 S X=$G(SDWLOPEN) W !,?36,"Status: ",$S(SDWLOPEN="O":"Open",1:"All")
111 S X=$G(SDWLFORM) W !,?28,"Output Format: ",$S(SDWLFORM="S":"Summary",1:"Detailed")
112 Q
113HD1 ;
114 W !!,"Name",?30,"Date Entered",?45,"# of Days Waiting",!!
115 Q
116END K X1,X2,CT1,CT2,DATE,I,INS,OPEN,FORM
117 K ^TMP("SDWLRPS2",$J)
118 Q
Note: See TracBrowser for help on using the repository browser.