source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENRPT4.m@ 1569

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1DGENRPT4 ;ALB/DW,LBD/EG - EGT Actual Detailed Impact Report ; 1/20/05 1:04pm
2 ;;5.3;Registration;**232,306,417,456,491,513,568,585**;Aug 13,1993
3 ;
4 ;
5ENPT ;Actual Detailed Report selected.
6 K ^TMP($J,"BY4"),^TMP($J,"CNT4")
7 N INFAP,BDT,EDT S (INFAP,BDT,EDT)=""
8 D RPDT I BDT="^"!(EDT="^")!($D(DTOUT)) Q
9 D INFAP I INFAP="^"!($D(DTOUT)) Q
10 N EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,L,BY,DIC,FLDS,DHD,DIOEND,X,DFN,PSSN,FCTY,DIOBEG,VASD,VAERR,RLEGT,ENRDT
11 S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,FCTY,RLEGT)=""
12 W !!,"*** This report requires a 132 column printer. ***",!!
13 S DIC="^DGEN(27.11,"
14 S DIOBEG="D PRESORT^DGENRPT4"
15 S BY(0)="^TMP($J,""BY4"",",L(0)=3,L=0
16 S FLDS="D PT^DGENRPT4 W X;C0;L20,W PSSN;C22;L10,D EP^DGENRPT4 W X;C33;L2,D ENRED^DGENRPT4 W X;C37;L10,D ENRST^DGENRPT4 W X;C49;L12"
17 I INFAP=1 D
18 . S FLDS(2)="D WRD^DGENRPT4 W X;C63;L15;""WARD"",D FAP1^DGENRPT4 W X;C80;L31,D PCPVD^DGENRPT4 W X;C110;L10,D PFCLTY^DGENRPT4 W X;C121;L11"
19 . S DHD="W ?0 D DETHD1^DGENRPT4"
20 I INFAP=0 D
21 . S FLDS(2)="D WRD^DGENRPT4 W X;C63;L15;""WARD"",D FAP0^DGENRPT4 W X;C80;L31,D PCPVD^DGENRPT4 W X;C88;L10,D PFCLTY^DGENRPT4 W X;C100;L12"
22 . S DHD="W ?0 D DETHD0^DGENRPT4"
23 S DIOEND="D END^DGENRPT4"
24 D EN1^DIP
25 D EXIT
26 Q
27 ;
28INFAP ;Ask the user if Future Appointments is wanted on the report.
29 N DIR,X,Y
30 S DIR(0)="Y^1:3"
31 S DIR("A")="Do you want to include Future Appointments"
32 D ^DIR S INFAP=Y
33 I ($D(DTOUT)) W *7
34 Q
35 ;
36RPDT ;Ask the user the Report Begin Date and Report End Date.
37 N DIR,X,Y
38 S DIR(0)="DA^::E"
39 S DIR("A")="Report Begin Date: "
40 S DIR("?")="Please enter the Enrollment End Date as the beginning date that will be reported on."
41 D ^DIR S BDT=Y
42 I BDT="^" Q
43 I ($D(DTOUT)) W *7 Q
44 ;
45RPDT2 S DIR(0)="DA^::E"
46 S DIR("A")="Report End Date: "
47 S DIR("?")="Please enter the Enrollment End Date as the end date that will be reported on. Report End Date cannot be earlier than Report Begin Date."
48 D ^DIR S EDT=Y
49 I EDT="^" Q
50 I ($D(DTOUT)) W *7 Q
51 I EDT<BDT G RPDT2
52 Q
53 ;
54PRESORT ;First get the current EGT Setting from file #27.16.
55 N GETEGTS,REC,TP S (GETEGTS,REC,TP)=""
56 S REC=$$FINDCUR^DGENEGT()
57 ;If no EGT setting on file, print patient of all enrollment priorities.
58 I REC=0 W !,"No EGT setting on file.",! S EGT=0 G PRESRT1
59 S TP=$$GET^DGENEGT(REC,.GETEGTS)
60 ;Get EGT Priority.
61 S EGT=GETEGTS("PRIORITY"),RLEGT=EGT
62 I EGT="" W !,"No EGT setting on file.",! S EGT=0
63 S EGTSUB=GETEGTS("SUBGRP")
64 ;Get EGT Effective Date.
65 S EGTEDT=GETEGTS("EFFDATE") I EGTEDT S EGTEDT=$$FMTE^XLFDT(EGTEDT)
66 ;Get last EGT setting Date/Time.
67 S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT)
68 ;Get EGT Type.
69 S EGTTP=GETEGTS("TYPE")
70 S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED"
71 ;
72PRESRT1 ;Sort for patient's current record and get the potentially affected.
73 N IND,PRT,DFN,NM,PSSN,PEDT,PCTRY,PRTSUB,ABV
74 S (IND,PRT,DFN,NM,PSSN,PEDT,PCTRY,PRTSUB,ABV)=""
75 K ^TMP($J,"BY4"),^TMP($J,"CNT4")
76 F S DFN=$O(^DGEN(27.11,"C",DFN)) Q:DFN="" D
77 . S IND=$$FINDCUR^DGENA(DFN)
78 . I IND D
79 .. D EGTP
80 .. S PEDT=$P($G(^DGEN(27.11,IND,0)),U,11)
81 .. S PCTRY=$$CATEGORY^DGENA4(DFN)
82 .. I ABV=0&(PCTRY="N")&(PEDT'<BDT)&(PEDT'>EDT) D
83 ... K VADM(1),VADM(2) D DEM^VADPT S NM=VADM(1) D BYSRT
84 ... S PSSN=$P($G(VADM(2)),U),^TMP($J,"CNT4",PRT,PSSN)=""
85 I EGTSUB>4 S EGTSUB="ER" Q
86 S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
87 D GETAPPT^DGENRPT5("BY4")
88 Q
89 ;
90EGTP ;Get patients EGT Priority.
91 S (PRT,PRTSUB,ABV,ENRDT)=""
92 S PRT=$P($G(^DGEN(27.11,IND,0)),U,7)
93 S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12)
94 S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10)
95 S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U)
96 S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB)
97 I PRT=7!(PRT=8) D
98 . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
99 . S:PRTSUB="" PRTSUB="ER"
100 S PRT=PRT_PRTSUB
101 Q
102 ;
103BYSRT ;Sort patients by last name for "BY(0)".
104 S ^TMP($J,"BY4",NM,DFN,IND)=""
105 Q
106 ;
107PT ;Get the patient NAME and SSN
108 S (X,DFN,PSSN)="" K VADM(1),VADM(2)
109 S DFN=$P($G(^DGEN(27.11,D0,0)),U,2)
110 I DFN D DEM^VADPT S X=$E(VADM(1),1,20),PSSN=$P(VADM(2),U)
111 Q
112 ;
113EP ;Get the patient EGT Priority.
114 S X=""
115 N PRT,PRTSUB S (PRT,PRTSUB)=""
116 S PRT=$P($G(^DGEN(27.11,D0,0)),U,7)
117 I PRT=7!(PRT=8) D
118 .S PRTSUB=$P($G(^DGEN(27.11,D0,0)),U,12)
119 .S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
120 .S:PRTSUB="" PRTSUB="ER"
121 .S PRT=PRT_PRTSUB
122 S X=PRT
123 Q
124 ;
125ENRED ;Get the patient ENROLLMENT END DATE.
126 S X=""
127 S X=$P($G(^DGEN(27.11,D0,0)),U,11)
128 I X="" S X="N/A" Q
129 S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
130 Q
131 ;
132ENRST ;Get the patient ENROLLMENT STATUS.
133 S X=""
134 S X=$P($G(^DGEN(27.11,D0,0)),U,4)
135 S X=$P($G(^DGEN(27.15,X,0)),U,1),X=$E(X,1,12)
136 Q
137 ;
138WRD ;Get the patient WARD.
139 S X="" K VAIP(5)
140 D IN5^VADPT S X=$P($G(VAIP(5)),U,2),X=$E(X,1,15)
141 I X="" S X="N/A"
142 Q
143 ;
144FAP1 ;Get the patient FUTURE APPOINTMENTS.
145 N J,POP,ADT S (X,J,ADT)="",POP=0
146 K ^UTILITY("VASD",$J)
147 ;if there is lower level data, then it is an error eg 01/20/2005
148 I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q
149 D BLDUTL^DGENRPT5(DFN)
150 F S J=$O(^UTILITY("VASD",$J,J)) Q:J=""!POP D
151 . S X=$P($G(^UTILITY("VASD",$J,J,"E")),U,2),X=$E(X,1,20)
152 . S ADT=$P($G(^UTILITY("VASD",$J,J,"I")),U),ADT=$P(ADT,".",1)
153 . S ADT=$E(ADT,4,5)_"/"_$E(ADT,6,7)_"/"_(1700+$E(ADT,1,3))
154 . S X=ADT_" "_X
155 . I J=1 W X S X=""
156 . I J>1&(J<6) W !,?79,X S X=""
157 . I J=6 S X="" W !,?79,"More Appts" S POP=1 Q
158 I $D(^UTILITY("VASD",$J))=0 S X="NONE"
159 Q
160 ;
161FAP0 ;See if the patient has future appointment.
162 S X="NO"
163 K ^UTILITY("VASD",$J)
164 ;in order to be a valid appointment, there must be
165 ;lower level subscripts. if not, then it is
166 ;an error eg 01/20/2005
167 I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q
168 D BLDUTL^DGENRPT5(DFN)
169 I $G(^UTILITY("VASD",$J,1,"I"))'="" S X="YES"
170 Q
171 ;
172PCPVD ;Get the patient PC PROVIDER.
173 ;;Site must use PCMM module.
174 S X=""
175 S X=$$PCPRACT^DGSDUTL(DFN)
176 I X="" S X="N/A" Q
177 S X=$P(X,U,2),X=$E(X,1,10)
178 Q
179 ;
180PFCLTY ;Get the patient PREFFERED FACILITY.
181 S (X,FCTY)=""
182 S X=$$PREF^DGENPTA(DFN,.FCTY),X=$E(FCTY,1,11)
183 I X="" S X="N/A"
184 Q
185 ;
186DETHD ;General header for the Preliminary Detailed Report.
187 ;Get the date/time the report is run.
188 N RDT,Y,DT1,DT2 S (RDT,Y,DT1,DT2)=""
189 D NOW^%DTC S Y=% X ^DD("DD")
190 S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)
191 S DT1=$$FMTE^XLFDT(BDT),DT2=$$FMTE^XLFDT(EDT)
192 ;Write the header.
193 W !,?((IOM-33)\2),"EGT Actual Detailed Impact Report"
194 W !,?((IOM-38-$L(DT1_DT2))\2),"Date Range of Enrollment End Date: ",DT1," - ",DT2
195 W !,?((IOM-22-$L(RDT))\2),"Date/Time Report Run: ",RDT
196 W !,?((IOM-45-$L(RLEGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",RLEGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
197 W !,?((IOM-28-$L(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
198 W !!,"IMPORTANT NOTE: Actual report is based on a comparison of the EGT Setting and the Enrollment Category as provided by HEC."
199 Q
200 ;
201DETHD1 ;Header for the Preliminary Detailed Report, with Future Appointments.
202 D DETHD
203 W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?109,"PC",?120,"PREF"
204 W !,?36,"END DATE",?48,"STATUS",?79,"APPOINTMENTS",?109,"PROVIDER",?120,"FACILITY",!!
205 Q
206 ;
207DETHD0 ;Header for the Preliminary Detailed Report, no Future Appointments.
208 D DETHD
209 W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?87,"PC",?99,"PREF"
210 W !,?36,"END DATE",?48,"STATUS",?79,"APPTS",?87,"PROVIDER",?99,"FACILITY",!!
211 Q
212 ;
213END ;At the end of the display.
214 N PSSN,J,COUNT S (PSSN,J)="",COUNT=0
215 F S J=$O(^TMP($J,"CNT4",J)) Q:J="" D
216 . F S PSSN=$O(^TMP($J,"CNT4",J,PSSN)) Q:PSSN="" S COUNT=COUNT+1
217 W !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",COUNT
218 Q
219 ;
220EXIT ;Clean up upon exit of the routine.
221 D KVA^VADPT
222 K ^TMP($J,"BY4"),^TMP($J,"CNT4")
223 Q
Note: See TracBrowser for help on using the repository browser.