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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1DGENRPT3 ;ALB/DW,LBD - EGT Actual Summary Impact Report ; 04/24/03 2:40pm ; 07/22/02 9:40am
2 ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13,1993
3 ;
4 ;
5ENPT ;Actual Summary Report selected.
6 K ^TMP($J,"SS3"),^TMP($J,"RT3")
7 N BDT,EDT S (BDT,EDT)=""
8 D RPDT I BDT="^"!(EDT="^")!($D(DTOUT)) Q
9 D PRINT
10 Q
11 ;
12RPDT ;Ask the user the Report Begin Date and Report End Date.
13 N DIR,X,Y
14 S DIR(0)="DA^::E"
15 S DIR("A")="Report Begin Date: "
16 S DIR("?")="Please enter the Enrollment End Date as the beginning date that will be reported on."
17 D ^DIR S BDT=Y
18 I BDT="^" Q
19 I ($D(DTOUT)) W *7 Q
20 ;
21RPDT2 S DIR(0)="DA^::E"
22 S DIR("A")="Report End Date: "
23 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."
24 D ^DIR S EDT=Y
25 I EDT="^" Q
26 I ($D(DTOUT)) W *7 Q
27 I EDT<BDT G RPDT2
28 Q
29 ;
30GETEGTS ;First get the current EGT parameters from file #27.16.
31 N GETEGTS,REC,TP S (GETEGTS,REC,TP)=""
32 S REC=$$FINDCUR^DGENEGT() I REC=0 Q
33 S TP=$$GET^DGENEGT(REC,.GETEGTS)
34 ;Get EGT Priority.
35 S EGT=GETEGTS("PRIORITY"),RLEGT=EGT
36 I EGT="" W !,"No EGT setting on file.",! S EGT=0
37 S EGTSUB=GETEGTS("SUBGRP")
38 ;Get EGT Effective Date.
39 S EGTEDT=GETEGTS("EFFDATE") I EGTEDT S EGTEDT=$$FMTE^XLFDT(EGTEDT)
40 ;Get last EGT setting Date/Time.
41 S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT)
42 ;Get EGT Type.
43 S EGTTP=GETEGTS("TYPE")
44 S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED"
45 Q
46 ;
47PRESRT1 ;Sort for patient's current record and get the potentially affected.
48 N IND,PRT,DFN,INPT,PSSN,PEDT,PCTRY,TMP,PRTSUB,ABV
49 S (IND,PRT,DFN,PSSN,PEDT,PCTRY,TMP,PRTSUB,ABV)="",INPT="OUT"
50 K ^TMP($J,"SS3"),^TMP($J,"RT3")
51 F S DFN=$O(^DGEN(27.11,"C",DFN)) Q:DFN="" D
52 . S IND=$$FINDCUR^DGENA(DFN) I IND D
53 .. D EGTP
54 .. S PEDT=$P($G(^DGEN(27.11,IND,0)),U,11)
55 .. S PCTRY=$$CATEGORY^DGENA4(DFN)
56 .. I ABV=0&(PCTRY="N")&(PEDT'<BDT)&(PEDT'>EDT) D
57 ... K VAIP(2) S INPT="OUT" D IN5^VADPT S TMP=$P($G(VAIP(2)),U) I TMP=1!(TMP=2)!(TMP=6) S INPT="IN"
58 ... K VADM(2) D DEM^VADPT S PSSN=$P($G(VADM(2)),U)
59 ... S ^TMP($J,"RT3",PRT,PSSN)=PRT_"^"_INPT
60 ;
61PRESRT2 ;Sort the sorted.
62 N CNT,ICNT,OCNT,J,K
63 S (J,K)=""
64 F S J=$O(^TMP($J,"RT3",J)) Q:J="" D
65 . S (CNT,ICNT,OCNT)=0
66 . F S K=$O(^TMP($J,"RT3",J,K)) Q:K="" D
67 .. S INPT=$P($G(^TMP($J,"RT3",J,K)),U,2)
68 .. S CNT=CNT+1 S:INPT="IN" ICNT=ICNT+1 S:INPT="OUT" OCNT=OCNT+1
69 .. S ^TMP($J,"SS3",J)=CNT_"^"_ICNT_"^"_OCNT
70 K ^TMP($J,"RT3")
71 Q
72 ;
73EGTP ;Get patients EGT Priority.
74 S (PRT,PRTSUB,ABV,ENRDT)=""
75 S PRT=$P($G(^DGEN(27.11,IND,0)),U,7)
76 S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12)
77 S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10)
78 S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U)
79 S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB)
80 I PRT=7!(PRT=8) D
81 . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
82 . S:PRTSUB="" PRTSUB="ER"
83 S PRT=PRT_PRTSUB
84 Q
85 ;
86PRINT ;Print the report.
87 N POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY,ZTSAVE,TSK,%ZIS,ZTRTN,ZTDESC
88 S %ZIS="QM" D ^%ZIS G EXIT:POP
89 I $D(IO("Q")) D G EXIT
90 . S ZTRTN="WRITER^DGENRPT3",ZTDESC="DG EGT Actual Summary Report."
91 . S ZTSAVE("BDT")="",ZTSAVE("EDT")=""
92 . D ^%ZTLOAD
93 . S TSK=$S($D(ZTSK)=0:"C",1:"Y")
94 . I TSK="Y" W !!,"Report queued! Task number: ",ZTSK
95 . D HOME^%ZIS
96 ;
97WRITER ;Write out the report.
98 U IO
99 I $E(IOST,1,2)="C-" W @IOF
100 N EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,COUNT,RLEGT,ENRDT
101 S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,RLEGT)="",COUNT=0
102 I $$FINDCUR^DGENEGT()=0 W !,"No EGT setting on file.",! S EGT=0
103 I $$FINDCUR^DGENEGT()'=0 D GETEGTS
104 D PRESRT1
105 D PSHEAD
106 D DATA
107 D ^%ZISC
108EXIT S:$D(ZTQUEUED) ZTREQ="@"
109 D KVA^VADPT
110 K ^TMP($J,"SS3")
111 Q
112 ;
113PSHEAD ;Header for the Preliminary Detailed Report.
114 ;Get the date/time the report is run.
115 N RDT,Y,DT1,DT2 S (RDT,Y,DT1,DT2)=""
116 D NOW^%DTC S Y=% X ^DD("DD")
117 S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)
118 S DT1=$$FMTE^XLFDT(BDT),DT2=$$FMTE^XLFDT(EDT)
119 S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
120 I ((EGT=7)!(EGT=8)),EGTSUB="" S EGTSUB="ER"
121 ;Write the header.
122 W !,?((IOM-32)\2),"EGT Actual Summary Impact Report"
123 W !,?((IOM-62)\2),"Date Range of Enrollment End Date: ",DT1," - ",DT2
124 W !,?((IOM-41)\2),"Date/Time Report Run: ",RDT
125 W !,?((IOM-45-$L(RLEGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",RLEGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
126 W !,?((IOM-28-$L(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
127 W !!,"IMPORTANT NOTE: Actual report is based on a comparison of the EGT Setting and the Enrollment Category as provided by HEC."
128 W !!,"ENROLLMENT PRIORITY",?23,"TOTAL (UNIQUE SSN)",?43,"# INPATIENT",?57,"# OUTPATIENT",!
129 Q
130 ;
131DATA ;Get all the data for the report.
132 N T,EP,TLT,INPT,OPT S (T,EP,TLT,INPT,OPT)=""
133 F S T=$O(^TMP($J,"SS3",T)) Q:T="" D
134 . S EP=T,TLT=$P($G(^TMP($J,"SS3",T)),U),INPT=$P($G(^TMP($J,"SS3",T)),U,2),OPT=$P($G(^TMP($J,"SS3",T)),U,3)
135 . S COUNT=COUNT+TLT
136 . W !,EP,?25,TLT,?45,INPT,?59,OPT
137 W !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",COUNT
138 Q
Note: See TracBrowser for help on using the repository browser.