source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENRPT2.m@ 724

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

initial load of WorldVistAEHR

File size: 6.4 KB
Line 
1DGENRPT2 ;ALB/GAH - EGT Preliminary Detailed Impact Report ; 10/10/2005
2 ;;5.3;Registration;**232,306,417,456,491,513,568,725**;Aug 13,1993;Build 12
3 ;
4 ;
5ENPT ;Preliminary Detailed Report selected.
6 K ^TMP($J,"BY2"),^TMP($J,"CNT2")
7 I $$FINDCUR^DGENEGT()=0 W !,"No EGT setting on file." Q
8 N INFAP S INFAP=""
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,TOTAL,DIOBEG,VASD,VAERR,ENRDT
11 S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,FCTY)="",TOTAL=0
12 W !!,"*** This report requires a 132 column printer. ***",!!
13 S DIC="^DGEN(27.11,"
14 S BY(0)="^TMP($J,""BY2""",L(0)=3,L=0
15 S DIOBEG="D PRESORT^DGENRPT2"
16 S FLDS="D PT^DGENRPT2 W X;C0;L20,W PSSN;C22;L10,D EP^DGENRPT2 W X;C33;L2,D ENRED^DGENRPT2 W X;C37;L10,D ENRST^DGENRPT2 W X;C49;L12"
17 I INFAP=1 D
18 . S FLDS(2)="D WRD^DGENRPT2 W X;C63;L15;""WARD"",D FAP1^DGENRPT2 W X;C80;L31,D PCPVD^DGENRPT2 W X;C110;L10,D PFCLTY^DGENRPT2 W X;C121;L11"
19 . S DHD="W ?0 D DETHD1^DGENRPT2"
20 I INFAP=0 D
21 . S FLDS(2)="D WRD^DGENRPT2 W X;C63;L15;""WARD"",D FAP0^DGENRPT2 W X;C80;L31,D PCPVD^DGENRPT2 W X;C88;L10,D PFCLTY^DGENRPT2 W X;C100;L12"
22 . S DHD="W ?0 D DETHD0^DGENRPT2"
23 S DIOEND="D END^DGENRPT2"
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 ;
36PRESORT ;First get the current EGT Setting from file #27.16.
37 N GETEGTS,REC,TP S (GETEGTS,REC,TP)=""
38 S REC=$$FINDCUR^DGENEGT()
39 I REC=0 Q
40 S TP=$$GET^DGENEGT(REC,.GETEGTS)
41 ;Get EGT Priority.
42 S EGT=GETEGTS("PRIORITY")
43 S EGTSUB=GETEGTS("SUBGRP")
44 ;Get EGT Effective Date.
45 S EGTEDT=GETEGTS("EFFDATE") I EGTEDT S EGTEDT=$$FMTE^XLFDT(EGTEDT)
46 ;Get last EGT setting Date/Time.
47 S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT)
48 ;Get EGT Type.
49 S EGTTP=GETEGTS("TYPE")
50 S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED"
51 ;Sort for patient's current record and get the potentially affected.
52 N IND,PRT,DFN,NM,PSSN,PRTSUB,ABV
53 S (IND,PRT,DFN,NM,PSSN,PRTSUB,ABV)=""
54 K ^TMP($J,"BY2"),^TMP($J,"CNT2")
55 F S DFN=$O(^DGEN(27.11,"C",DFN)) Q:DFN="" D
56 . S IND=$$FINDCUR^DGENA(DFN)
57 . I IND D EGTP I ABV=0 D
58 .. K VADM(1),VADM(2) D DEM^VADPT S NM=VADM(1) D BYSRT
59 .. S PSSN=$P($G(VADM(2)),U),^TMP($J,"CNT2",PRT,PSSN)=""
60 I EGTSUB>4 S EGTSUB="ER" Q
61 S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
62 D GETAPPT^DGENRPT5("BY2")
63 Q
64 ;
65EGTP ;Get patients EGT Priority.
66 S (PRT,PRTSUB,ABV,ENRDT)=""
67 S PRT=$P($G(^DGEN(27.11,IND,0)),U,7)
68 S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12)
69 S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10)
70 S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U)
71 S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB)
72 I PRT=7!(PRT=8) D
73 . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
74 . S:PRTSUB="" PRTSUB="ER"
75 S PRT=PRT_PRTSUB
76 Q
77 ;
78BYSRT ;Sort patients by last name for "BY(0)".
79 S ^TMP($J,"BY2",NM,DFN,IND)=""
80 Q
81 ;
82PT ;Get the patient NAME and SSN
83 S (X,DFN,PSSN)="" K VADM(1),VADM(2)
84 S DFN=$P($G(^DGEN(27.11,D0,0)),U,2)
85 I DFN D DEM^VADPT S X=$E(VADM(1),1,20),PSSN=$P(VADM(2),U)
86 Q
87 ;
88EP ;Get the patient EGT Priority.
89 S X=""
90 N PRT,PRTSUB S (PRT,PRTSUB)=""
91 S PRT=$P($G(^DGEN(27.11,D0,0)),U,7)
92 I PRT=7!(PRT=8) D
93 .S PRTSUB=$P($G(^DGEN(27.11,D0,0)),U,12)
94 .S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
95 .S:PRTSUB="" PRTSUB="ER"
96 .S PRT=PRT_PRTSUB
97 S X=PRT
98 Q
99 ;
100ENRED ;Get the patient ENROLLMENT END DATE.
101 S X=""
102 S X=$P($G(^DGEN(27.11,D0,0)),U,11)
103 I X="" S X="N/A" Q
104 S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
105 Q
106 ;
107ENRST ;Get the patient ENROLLMENT STATUS.
108 S X=""
109 S X=$P($G(^DGEN(27.11,D0,0)),U,4)
110 S X=$P($G(^DGEN(27.15,X,0)),U,1),X=$E(X,1,12)
111 Q
112 ;
113WRD ;Get the patient WARD.
114 S X="" K VAIP(5)
115 D IN5^VADPT S X=$P($G(VAIP(5)),U,2),X=$E(X,1,15)
116 I X="" S X="N/A"
117 Q
118 ;
119FAP1 ;Get the patient FUTURE APPOINTMENTS.
120 N J,POP,ADT S (X,ADT)="",POP=0,J=0
121 K ^UTILITY("VASD",$J)
122 S X=$$FAPCHK(DFN) Q:X'=""
123 D BLDUTL^DGENRPT5(DFN)
124 F S J=$O(^UTILITY("VASD",$J,J)) Q:J=""!POP D
125 . S X=$P($G(^UTILITY("VASD",$J,J,"E")),U,2),X=$E(X,1,20)
126 . S ADT=$P($G(^UTILITY("VASD",$J,J,"I")),U),ADT=$P(ADT,".",1)
127 . S ADT=$E(ADT,4,5)_"/"_$E(ADT,6,7)_"/"_(1700+$E(ADT,1,3))
128 . S X=ADT_" "_X
129 . I J=1 W X S X=""
130 . I J>1&(J<6) W !,?79,X S X=""
131 . I J=6 S X="" W !,?79,"More Appts" S POP=1 Q
132 I $D(^UTILITY("VASD",$J))=0 S X="NONE"
133 Q
134 ;
135FAP0 ;See if the patient has future appointment.
136 S X="NO"
137 K ^UTILITY("VASD",$J)
138 S X=$$FAPCHK(DFN) Q:X'=""
139 D BLDUTL^DGENRPT5(DFN)
140 I $G(^UTILITY("VASD",$J,1,"I"))'="" S X="YES"
141 Q
142 ;
143FAPCHK(DFN) ;
144 Q $G(^TMP($J,"SDAMA",DFN,"ERROR"))
145PCPVD ;Get the patient PC PROVIDER.
146 ;;Site must use PCMM module.
147 S X=""
148 S X=$$PCPRACT^DGSDUTL(DFN)
149 I X="" S X="N/A" Q
150 S X=$P(X,U,2),X=$E(X,1,10)
151 Q
152 ;
153PFCLTY ;Get the patient PREFFERED FACILITY.
154 S (X,FCTY)=""
155 S X=$$PREF^DGENPTA(DFN,.FCTY),X=$E(FCTY,1,10)
156 I X="" S X="N/A"
157 Q
158 ;
159DETHD ;General header for the Preliminary Detailed Report.
160 ;Get the date/time the report is run.
161 N RDT,Y S (RDT,Y)=""
162 D NOW^%DTC S Y=% X ^DD("DD")
163 S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)
164 ;Write the header.
165 W !,?((IOM-38)\2),"EGT Preliminary Detailed Impact Report"
166 W !,?((IOM-22-$L(RDT))\2),"Date/Time Report Run: ",RDT
167 W !,?((IOM-45-$L(EGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",EGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
168 W !,?((IOM-28-$L(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
169 W !!,"IMPORTANT NOTE:",!,"Preliminary report is based on a comparison of the EGT setting to the veterans current enrollment priority as shown in VISTA."
170 Q
171 ;
172DETHD1 ;Header for the Preliminary Detailed Report, with Future Appointments.
173 D DETHD
174 W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?109,"PC",?120,"PREF"
175 W !,?36,"END DATE",?48,"STATUS",?79,"APPOINTMENTS",?109,"PROVIDER",?120,"FACILITY",!!
176 Q
177 ;
178DETHD0 ;Header for the Preliminary Detailed Report, no Future Appointments.
179 D DETHD
180 W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?87,"PC",?99,"PREF"
181 W !,?36,"END DATE",?48,"STATUS",?79,"APPTS",?87,"PROVIDER",?99,"FACILITY",!!
182 Q
183 ;
184END ;At the end of the display.
185 N PSSN,J S (PSSN,J)=""
186 F S J=$O(^TMP($J,"CNT2",J)) Q:J="" D
187 . F S PSSN=$O(^TMP($J,"CNT2",J,PSSN)) Q:PSSN="" D
188 ..S TOTAL=TOTAL+1
189 W !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",TOTAL
190 Q
191 ;
192EXIT ;Clean up upon exit of the routine.
193 D KVA^VADPT
194 K ^TMP($J,"BY2"),^TMP($J,"CNT2"),^TMP($J,"SDAMA")
195 Q
Note: See TracBrowser for help on using the repository browser.