source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLROF.m@ 1361

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1SDWLROF ;;IOFO BAY PINES/TEH - WAIT LIST OVERDUE REPORT 1;06/12/2002 ; 29 Aug 2002 2:54 PM
2 ;;5.3;scheduling;**263,414**;AUG 13 1993
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ;
11 ;
12 ;
13 ;
14EN D INIT
15 I $$S^%ZTLOAD G END
16 D SORT
17 I $$S^%ZTLOAD G END
18 D PRINT
19 I $$S^%ZTLOAD G END
20 K ^TMP("SDWLQOF",$J)
21 Q
22INIT ;Initialize variables
23 ;
24 I $D(CT1) S SDWLCT1=CT1
25 I $D(CT2) S SDWLCT2=CT2
26 I $D(DATE) S SDWLDATE=DATE
27 I $D(FORM) S SDWLFORM=FORM
28 I $D(INS) S SDWLINS=INS
29 S SDWLPG=0
30 I $D(ZTSAVE) D
31 .F SDWLI="CT1","CT2","FORM","INS" S SDWL="SDWL"_SDWLI,@SDWL=$G(ZTSAVE(SDWLI))
32 I SDWLINS="ALL" S SDWLIN("ALL")=""
33 S SDWLTXP=$P(SDWLCT1,U,3),SDWLF=$P(SDWLCT1,U,2)
34 I SDWLINS'="ALL" F SDWLI=1:1 S SDWLIN=$P($P(SDWLINS,";",SDWLI),U,1) Q:SDWLIN="" S SDWLIN(SDWLIN)="",^TMP("SDWLQOF",$J,SDWLIN)=0
35 I SDWLCT2'="ALL" F SDWLI=1:1 S SDWLCL=$P($P(SDWLCT2,";",SDWLI),U,1) Q:SDWLCL="" S SDWLCT2(SDWLCL)=""
36 D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
37 Q
38SORT ;Sort Records
39 K ^TMP("SDWLROF",$J)
40 S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D
41 .S SDWLX=$G(^SDWL(409.3,SDWLDA,0)),SDWLERR=0,SDWLDFN=+SDWLX I 'SDWLDFN Q
42 .;-Check for Institution Sort
43 .I SDWLINS'="ALL" D
44 ..I '$D(SDWLIN(+$P(SDWLX,U,3))) S SDWLERR=1
45 .;-Check for Date Range Compliance
46 .I $P(SDWLX,U,16)'<DT,$P(SDWLX,U,16)'=DT S SDWLERR=2
47 .S SDWLTYP=$P(SDWLCT1,U,1),SDWLTYPE=$S(SDWLTYP="C":+$P(SDWLX,U,9),1:+$P(SDWLX,U,8)) I SDWLTYPE=""!('SDWLTYPE) S SDWLERR=7 Q
48 .I SDWLCT2'="ALL" D
49 ..I '$D(SDWLCT2(SDWLTYPE)) S SDWLERR=3
50 .I SDWLTYP="" S SDWLERR=4
51 .I $P(SDWLX,U,17)["C" S SDWLERR=6
52 .Q:SDWLERR D
53 ..S SDWLSCC=2,DFN=SDWLDFN D ELIG^VADPT I $D(VAEL(3)) S SDWLSCN=$P(VAEL(3),U,2) I SDWLSCN>49 S SDWLSCC=1
54 ..S ^TMP("SDWLROF",$J,+$P(SDWLX,U,3),SDWLTYPE,SDWLSCC,SDWLDA)=""
55 ..S SDWLCNT=SDWLCNT+1,^TMP("SDWLROF",$J,+$P(SDWLX,U,3))=SDWLCNT
56 Q
57PRINT ;Print Report
58 D HD S SDWLCNT=0 I '$D(^TMP("SDWLROF",$J)) W !!,?80-$L("*** No Patient Records to Report ***")\2,"*** No Patient Records to Report ***" Q
59 S SDWLA="" F S SDWLA=$O(^TMP("SDWLROF",$J,SDWLA)) G END:$$S^%ZTLOAD Q:SDWLA="" D Q:$D(DUOUT)
60 .D LINE W !!,"Institution: " S X=$$EXTERNAL^DILFD(409.3,2,,SDWLA) W X I '$G(^TMP("SDWLROF",$J,SDWLA)) W !!,"*** No Patient Records to Report ***"
61 .S SDWLB="" F S SDWLB=$O(^TMP("SDWLROF",$J,SDWLA,SDWLB)) Q:SDWLB="" D Q:$D(DUOUT)
62 ..W !!,"Clinic/Service: " S X=$$EXTERNAL^DILFD(409.3,SDWLTXP,,SDWLB) W X,! Q:$D(DUOUT)
63 ..S SDWLC="" F S SDWLC=$O(^TMP("SDWLROF",$J,SDWLA,SDWLB,SDWLC)) Q:SDWLC="" D Q:$D(DUOUT)
64 ...S SDWLD="" F S SDWLD=$O(^TMP("SDWLROF",$J,SDWLA,SDWLB,SDWLC,SDWLD)) Q:SDWLD="" D Q:$D(DUOUT)
65 ....S (DFN,SDWLDFN)=$P($G(^SDWL(409.3,SDWLD,0)),U,1) D 1^VADPT,DEM^VADPT,ELIG^VADPT,ADD^VADPT
66 ....S SDWLELIG=$P(VAEL(1),U,2)
67 ....S SDWLNAM=VADM(1),SDWLSSN=VA("BID")
68 ....S SDWLDEAD=1
69 ....S SDWLAPTD=$P(^SDWL(409.3,SDWLD,0),U,16),SDWLCOM=$P(^SDWL(409.3,SDWLD,0),U,18)
70 ....S SDWLRBY=$P(^SDWL(409.3,SDWLD,0),U,12),SDWLRPV=$P(^SDWL(409.3,SDWLD,0),U,13)
71 ....S SDWLPH=$G(VAPA(8))
72 ....I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
73 ....W !!,SDWLNAM
74 ....W ?35,SDWLSSN I SDWLAPTD'="" W ?50,"Desired Date: ",SDWLAPTD
75 ....W !,"Primary Eligibility: ",SDWLELIG
76 ....W !,"Comments: ",SDWLCOM,!
77 ....I SDWLRBY W !,"Requested by: ",$$EXTERNAL^DILFD(409.3,11,,SDWLRBY)
78 ....I SDWLRPV W ?35,"Requesting Provider: " S X=$$EXTERNAL^DILFD(409.3,12,,SDWLRPV) W X
79 ....W !,"Telephone (Home): ",$P(SDWLPH,U,1) I $P(SDWLPH,U,2) W !,?10,"(Work): ",$P(SDWLPH,U,2)
80 ....W !,"*****"
81 ....I $D(SDWLSPT) S DIR(0)="E" D ^DIR I X["^" S DUOUT=1 Q
82 ....I '$D(SDWLSPT),'$D(DUOUT),$Y>(IOSL-5) D HD
83 ....K VAEL,VADM,VA,VAPA
84 W !!,"** End of Report **"
85 Q
86LINE ;Draw Line
87 W !,"_______________________________________________________________________________"
88 Q
89HD ;Header
90 W:$D(IOF) @IOF W !,SDWLDTP,?80-$L("Appt Wait List Overdue Report")\2,"Appt Wait List Overdue Report"
91 S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD S SDWLPG=SDWLPG+1 W ?72,"Page: ",SDWLPG
92 W !!,?30,"Institution: " I SDWLINS="ALL" D
93 .W ?45,SDWLINS
94 F I=1:1 S X=$P($P(SDWLINS,";",I),"^",2) Q:X="" W:I>1 ! W ?45,X
95 S X=$P(SDWLCT2,U,2)
96 W !?26,"Report Category: ",$S($P(SDWLCT1,U,1)="C":"CLINIC",1:"SPECIALTY") I X="ALL" W " ALL"
97 I X'="ALL" D
98 .F I=1:1 S X=$P($P(SDWLCT2,";",I),"^",2) Q:X="" W !,?45,$$EXTERNAL^DILFD(SDWLF,.01,,X)
99 S X=$G(SDWLFORM) W !,?28,"Output Format: ",$S(SDWLFORM="S":"Summary",1:"Detailed")
100 Q
101END K SDWL,SDWLA,SDWLAPTD,SDWLB,SDWLBD,SDWLBDT,SDWLC,SDWLCAT,SDWLCNT,SDWLCOM,SDWLCT1,SDWLCT2,SDWLCTX,SDWLD
102 K SDLWDA,SDLWDEAD,SDWLDFN,SDWLE,SDWLEDT,SDWLELIG,SDWLERR,SDWLF,SDWLFD,SDWLI,SDWLIN,SDWLINS,SDWLINST
103 K SDWLNAM,SDWLPD,SDWLPG,SDWLPH,SDWLPROM,SDWLRBY,SDWLPRV,SDWLSCC,SDWLSPT,SDWLSSN,SDWLTAG,SDLTK,SDWLTXP
104 K SDWLTYP,SDWLTYPE,SDWLX,CT1,CT2,DATE,I,INS,OPEN,FORM
105 Q
Note: See TracBrowser for help on using the repository browser.