source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLRPT1.m@ 1096

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

initial load of WorldVistAEHR
File size: 6.2 KB
Line 
1SDWLRPT1 ;;IOFO BAY PINES/TEH - WAIT LIST REPORT FORMAT 1;06/12/2002 ; 29 Aug 2002 2:54 PM
2 ;;5.3;scheduling;**263,399,394**;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("SDWLRPT1",$J),^TMP("SDWLRQ1",$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 I $D(OPEN) S SDWLOPEN=OPEN
30 S SDWLPG=0
31 I $D(ZTSAVE) D
32 .F SDWLI="CT1","CT2","DATE","FORM","INS","OPEN" S SDWL="SDWL"_SDWLI,@SDWL=$G(ZTSAVE(SDWLI))
33 I SDWLINS="ALL" S SDWLIN("ALL")=""
34 S SDWLTXP=$P(SDWLCT1,U,3)
35 S SDWLOPEN=$S(SDWLOPEN=1:"O",1:"C")
36 I SDWLINS'="ALL" F SDWLI=1:1 S SDWLIN=$P($P(SDWLINS,";",SDWLI),U,1) Q:SDWLIN="" S SDWLIN(SDWLIN)="",^TMP("SDWLRPT1",$J,$P(^DIC(4,SDWLIN,0),U,1))=0
37 I SDWLCT2'="ALL" F SDWLI=1:1 S SDWLCT=$P($P(SDWLCT2,";",SDWLI),U,1) Q:SDWLCT="" S SDWLCT2(SDWLCT)=""
38 I SDWLDATE="ALL" S SDWLBD=0,SDWLED=9999999 G INIT1
39 S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2)
40INIT1 D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=$P(Y,":",1,2)
41 Q
42SORT ;Sort Records
43 S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D
44 .S SDWLX=$G(^SDWL(409.3,SDWLDA,0)),SDWLERR=0,SDWLDFN=+SDWLX
45 .;-Check for Institution Sort
46 .I SDWLINS'="ALL" D
47 ..I '$D(SDWLIN(+$P(SDWLX,U,3))) S SDWLERR=1 Q
48 .;-Check for Date Range Compliance
49 .I $P(SDWLX,U,16)<SDWLBD!($P(SDWLX,U,16)>SDWLED) S SDWLERR=2 Q
50 .S SDWLTYP=$P(SDWLCT1,U,1),SDWLTYPE=$S(SDWLTYP="C":$P(SDWLX,U,9),1:$P(SDWLX,U,8)) I SDWLTYPE="" S SDWLERR=7 Q
51 .I SDWLCT2'="ALL" D
52 ..I '$D(SDWLCT2(SDWLTYPE)) S SDWLERR=3
53 .I SDWLTYP="" S SDWLERR=4 Q
54 .I $P(SDWLX,U,3)=""!($P(SDWLX,U,16)="") S SDWLERR=5 Q
55 .I SDWLOPEN'["C",$P(SDWLX,U,17)'[SDWLOPEN S SDWLERR=6 Q
56 .Q:SDWLERR D
57 ..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
58 ..S SDWLF=$P(SDWLCT1,U,2)
59 ..S SDWLIENS=$P(SDWLX,U,3)_",",X=$$GET1^DIQ(4,SDWLIENS,".01")
60 ..S SDWLSIEN=SDWLTYPE_",",Y=$$GET1^DIQ(SDWLF,SDWLSIEN,".01")
61 ..S ^TMP("SDWLRPT1",$J,X,Y,SDWLSCC,+$P(SDWLX,U,16),SDWLDA)=""
62 ..S SDWLCNT=SDWLCNT+1,^TMP("SDWLRPT1",$J,$P(^DIC(4,+$P(SDWLX,U,3),0),U,1))=SDWLCNT
63 Q
64PRINT ;Print Report
65 N DFN
66 D HD S SDWLCNT=0 I '$D(^TMP("SDWLRPT1",$J)) W !!,?80-$L("*** No Patient Records to Report ***")\2,"*** No Patient Records to Report ***" Q
67 S SDWLA="" F S SDWLA=$O(^TMP("SDWLRPT1",$J,SDWLA)) G END:$$S^%ZTLOAD Q:SDWLA="" D Q:$D(DUOUT)
68 .D LINE W !!,"Institution: " S X=SDWLA W X I '$G(^TMP("SDWLRPT1",$J,SDWLA)) W !!,"*** No Patient Records to Report ***"
69 .S SDWLB="" F S SDWLB=$O(^TMP("SDWLRPT1",$J,SDWLA,SDWLB)) Q:SDWLB="" D Q:$D(DUOUT)
70 ..W !!,"Clinic/Service: " S X=SDWLB W X,! Q:$D(DUOUT)
71 ..S SDWLC="" F S SDWLC=$O(^TMP("SDWLRPT1",$J,SDWLA,SDWLB,SDWLC)) Q:SDWLC="" D Q:$D(DUOUT)
72 ...S SDWLD="" F S SDWLD=$O(^TMP("SDWLRPT1",$J,SDWLA,SDWLB,SDWLC,SDWLD)) Q:SDWLD="" D Q:$D(DUOUT)
73 ....S SDWLE="" F S SDWLE=$O(^TMP("SDWLRPT1",$J,SDWLA,SDWLB,SDWLC,SDWLD,SDWLE)) Q:SDWLE="" D Q:$D(DUOUT)
74 .....S SDWLDFN=$P($G(^SDWL(409.3,SDWLE,0)),U,1),DFN=SDWLDFN D DEM^VADPT,ELIG^VADPT,ADD^VADPT
75 .....S SDWLNAM=VADM(1),SDWLELIG=VAEL(1) I SDWLELIG="" S SDWLELIG=0
76 .....I SDWLELIG=0 S SDWLELIG="No Eligibility Status found"
77 .....S SDWLDEAD=1
78 .....S SDWLSSN=VA("BID"),SDWLAPTD=$P(^SDWL(409.3,SDWLE,0),U,16),SDWLCOM=$P(^SDWL(409.3,SDWLE,0),U,18)
79 .....S SDWLRBY=$P(^SDWL(409.3,SDWLE,0),U,12),SDWLRPV=$P(^SDWL(409.3,SDWLE,0),U,13)
80 .....S SDWLPH=$G(VAPA(8)) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
81 .....W !!,SDWLNAM
82 .....W ?35,SDWLSSN I SDWLAPTD'="" W ?50,"Desired Date: ",SDWLAPTD
83 .....W !,"Primary Eligibility: ",$P(SDWLELIG,U,2)
84 .....;PATCH SD*5.3*394 See Note.
85 .....N SDWLSCP
86 .....W !,"Service Connected Priority: " S SDWLSCP=$$GET1^DIQ(409.3,SDWLE_",",15,"I") W $S(SDWLSCP=1:"YES",1:"NO")
87 .....W !,"Comments: ",SDWLCOM,!
88 .....I SDWLRBY W !,"Requested by: ",$$EXTERNAL^DILFD(409.3,11,,SDWLRBY)
89 .....I SDWLRPV W ?35,"Requesting Provider: " S X=$$EXTERNAL^DILFD(409.3,12,,SDWLRPV) W X
90 .....W !,"Telephone (Home): ",$P(SDWLPH,U,1) I $P(SDWLPH,U,2) W !,?10,"(Work): ",$P(SDWLPH,U,2)
91 .....I $D(^SDWL(409.3,SDWLE,"DIS")) D
92 ......S SDWLDISX=$G(^SDWL(409.3,SDWLE,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2)
93 ......S SDWLDDT=$P(^SDWL(409.3,SDWLE,"DIS"),U,1),SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3)
94 .....I $D(SDWLDISX) W !,"Disposition: ",$P(SDWLDISX,U,3)," (",SDWLDIDT,")" K SDWLDISX,SDWLDIS,SDWLDDUZ,SDWLDIDT
95 .....W !,"*****"
96 .....I $D(SDWLSPT),$Y>IOSL S DIR(0)="E" D ^DIR I X["^" S DUOUT=1 Q
97 .....I '$D(SDWLSPT),'$D(DUOUT),$Y>(IOSL-5) D HD
98 W !!,"** End of Report **"
99 Q
100LINE ;Draw Line
101 W !,"_______________________________________________________________________________"
102 Q
103HD ;Header
104 W:$D(IOF) @IOF W !,SDWLDTP,?80-$L("Appointment Wait List Report")\2,"Appointment Wait List Report"
105 S SDWLPG=SDWLPG+1 W ?72,"Page: ",SDWLPG
106 W !!,?30,"Institution: " I SDWLINS="ALL" D
107 .W ?45,SDWLINS
108 F I=1:1 S X=$P($P(SDWLINS,";",I),"^",2) Q:X="" W:I>1 ! W ?45,X
109 S Y=$P(SDWLDATE,U,1) D DD^%DT S SDWLBDT=Y S Y=$P(SDWLDATE,U,2) D DD^%DT S SDWLEDT=Y
110 W !,?23,"Date Desired Range: ",SDWLBDT
111 I SDWLEDT'="" W " to ",SDWLEDT
112 S X=$P(SDWLCT2,U,2)
113 W !?26,"Report Category: ",$S($P(SDWLCT1,U,1)="C":"CLINIC",1:"SPECIALTY") I X="ALL" W " ALL"
114 S SDWLF=$P(SDWLCT1,U,1)
115 I X'="ALL" D
116 .F I=1:1 S X=$P($P(SDWLCT2,";",I),"^",2) Q:X="" W !,?45,$S(SDWLF="C":$P(^SC(X,0),U,1),1:$P(^DIC(40.7,X,0),U,1))
117 S X=$G(SDWLOPEN) W !,?35,"Status: ",$S(SDWLOPEN="O":"Open",1:"All")
118 S X=$G(SDWLFORM) W !,?28,"Output Format: ",$S(SDWLFORM="S":"Summary",1:"Detailed")
119 Q
120END K SDWL,SDWLA,SDWLAPTD,SDWLB,SDWLBD,SDWLBDT,SDWLC,SDWLCAT,SDWLCNT,SDWLCOM,SDWLCT1,SDWLCT2,SDWLCTX,SDWLD
121 K SDLWDA,SDLWDEAD,SDWLDFN,SDWLE,SDWLEDT,SDWLELIG,SDWLERR,SDWLF,SDWLFD,SDWLI,SDWLIN,SDWLINS,SDWLINST
122 K SDWLNAM,SDWLPD,SDWLPG,SDWLPH,SDWLPROM,SDWLRBY,SDWLPRV,SDWLSCC,SDWLSPT,SDWLSSN,SDWLTAG,SDLTK,SDWLTXP
123 K SDWLTYP,SDWLTYPE,SDWLX,VDAM,VAPA,SDWLIENS,CT1,CT2,DATE,I,INS,OPEN,FORM,SDWLSIEN
124 D EN^SDWLKIL
125 Q
Note: See TracBrowser for help on using the repository browser.