DGENRPT3 ;ALB/DW,LBD - EGT Actual Summary Impact Report ; 04/24/03 2:40pm ; 07/22/02 9:40am
;;5.3;Registration;**232,306,417,456,491,513**;Aug 13,1993
;
;
ENPT ;Actual Summary Report selected.
K ^TMP($J,"SS3"),^TMP($J,"RT3")
N BDT,EDT S (BDT,EDT)=""
D RPDT I BDT="^"!(EDT="^")!($D(DTOUT)) Q
D PRINT
Q
;
RPDT ;Ask the user the Report Begin Date and Report End Date.
N DIR,X,Y
S DIR(0)="DA^::E"
S DIR("A")="Report Begin Date: "
S DIR("?")="Please enter the Enrollment End Date as the beginning date that will be reported on."
D ^DIR S BDT=Y
I BDT="^" Q
I ($D(DTOUT)) W *7 Q
;
RPDT2 S DIR(0)="DA^::E"
S DIR("A")="Report End Date: "
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."
D ^DIR S EDT=Y
I EDT="^" Q
I ($D(DTOUT)) W *7 Q
I EDT<BDT G RPDT2
Q
;
GETEGTS ;First get the current EGT parameters from file #27.16.
N GETEGTS,REC,TP S (GETEGTS,REC,TP)=""
S REC=$$FINDCUR^DGENEGT() I REC=0 Q
S TP=$$GET^DGENEGT(REC,.GETEGTS)
;Get EGT Priority.
S EGT=GETEGTS("PRIORITY"),RLEGT=EGT
I EGT="" W !,"No EGT setting on file.",! S EGT=0
S EGTSUB=GETEGTS("SUBGRP")
;Get EGT Effective Date.
S EGTEDT=GETEGTS("EFFDATE") I EGTEDT S EGTEDT=$$FMTE^XLFDT(EGTEDT)
;Get last EGT setting Date/Time.
S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT)
;Get EGT Type.
S EGTTP=GETEGTS("TYPE")
S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED"
Q
;
PRESRT1 ;Sort for patient's current record and get the potentially affected.
N IND,PRT,DFN,INPT,PSSN,PEDT,PCTRY,TMP,PRTSUB,ABV
S (IND,PRT,DFN,PSSN,PEDT,PCTRY,TMP,PRTSUB,ABV)="",INPT="OUT"
K ^TMP($J,"SS3"),^TMP($J,"RT3")
F S DFN=$O(^DGEN(27.11,"C",DFN)) Q:DFN="" D
. S IND=$$FINDCUR^DGENA(DFN) I IND D
.. D EGTP
.. S PEDT=$P($G(^DGEN(27.11,IND,0)),U,11)
.. S PCTRY=$$CATEGORY^DGENA4(DFN)
.. I ABV=0&(PCTRY="N")&(PEDT'<BDT)&(PEDT'>EDT) D
... 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"
... K VADM(2) D DEM^VADPT S PSSN=$P($G(VADM(2)),U)
... S ^TMP($J,"RT3",PRT,PSSN)=PRT_"^"_INPT
;
PRESRT2 ;Sort the sorted.
N CNT,ICNT,OCNT,J,K
S (J,K)=""
F S J=$O(^TMP($J,"RT3",J)) Q:J="" D
. S (CNT,ICNT,OCNT)=0
. F S K=$O(^TMP($J,"RT3",J,K)) Q:K="" D
.. S INPT=$P($G(^TMP($J,"RT3",J,K)),U,2)
.. S CNT=CNT+1 S:INPT="IN" ICNT=ICNT+1 S:INPT="OUT" OCNT=OCNT+1
.. S ^TMP($J,"SS3",J)=CNT_"^"_ICNT_"^"_OCNT
K ^TMP($J,"RT3")
Q
;
EGTP ;Get patients EGT Priority.
S (PRT,PRTSUB,ABV,ENRDT)=""
S PRT=$P($G(^DGEN(27.11,IND,0)),U,7)
S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12)
S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10)
S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U)
S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB)
I PRT=7!(PRT=8) D
. S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
. S:PRTSUB="" PRTSUB="ER"
S PRT=PRT_PRTSUB
Q
;
PRINT ;Print the report.
N POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY,ZTSAVE,TSK,%ZIS,ZTRTN,ZTDESC
S %ZIS="QM" D ^%ZIS G EXIT:POP
I $D(IO("Q")) D G EXIT
. S ZTRTN="WRITER^DGENRPT3",ZTDESC="DG EGT Actual Summary Report."
. S ZTSAVE("BDT")="",ZTSAVE("EDT")=""
. D ^%ZTLOAD
. S TSK=$S($D(ZTSK)=0:"C",1:"Y")
. I TSK="Y" W !!,"Report queued! Task number: ",ZTSK
. D HOME^%ZIS
;
WRITER ;Write out the report.
U IO
I $E(IOST,1,2)="C-" W @IOF
N EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,COUNT,RLEGT,ENRDT
S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,RLEGT)="",COUNT=0
I $$FINDCUR^DGENEGT()=0 W !,"No EGT setting on file.",! S EGT=0
I $$FINDCUR^DGENEGT()'=0 D GETEGTS
D PRESRT1
D PSHEAD
D DATA
D ^%ZISC
EXIT S:$D(ZTQUEUED) ZTREQ="@"
D KVA^VADPT
K ^TMP($J,"SS3")
Q
;
PSHEAD ;Header for the Preliminary Detailed Report.
;Get the date/time the report is run.
N RDT,Y,DT1,DT2 S (RDT,Y,DT1,DT2)=""
D NOW^%DTC S Y=% X ^DD("DD")
S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)
S DT1=$$FMTE^XLFDT(BDT),DT2=$$FMTE^XLFDT(EDT)
S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
I ((EGT=7)!(EGT=8)),EGTSUB="" S EGTSUB="ER"
;Write the header.
W !,?((IOM-32)\2),"EGT Actual Summary Impact Report"
W !,?((IOM-62)\2),"Date Range of Enrollment End Date: ",DT1," - ",DT2
W !,?((IOM-41)\2),"Date/Time Report Run: ",RDT
W !,?((IOM-45-$L(RLEGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",RLEGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
W !,?((IOM-28-$L(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
W !!,"IMPORTANT NOTE: Actual report is based on a comparison of the EGT Setting and the Enrollment Category as provided by HEC."
W !!,"ENROLLMENT PRIORITY",?23,"TOTAL (UNIQUE SSN)",?43,"# INPATIENT",?57,"# OUTPATIENT",!
Q
;
DATA ;Get all the data for the report.
N T,EP,TLT,INPT,OPT S (T,EP,TLT,INPT,OPT)=""
F S T=$O(^TMP($J,"SS3",T)) Q:T="" D
. 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)
. S COUNT=COUNT+TLT
. W !,EP,?25,TLT,?45,INPT,?59,OPT
W !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",COUNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENRPT3 5149 printed Nov 22, 2024@17:53:08 Page 2
DGENRPT3 ;ALB/DW,LBD - EGT Actual Summary Impact Report ; 04/24/03 2:40pm ; 07/22/02 9:40am
+1 ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13,1993
+2 ;
+3 ;
ENPT ;Actual Summary Report selected.
+1 KILL ^TMP($JOB,"SS3"),^TMP($JOB,"RT3")
+2 NEW BDT,EDT
SET (BDT,EDT)=""
+3 DO RPDT
IF BDT="^"!(EDT="^")!($DATA(DTOUT))
QUIT
+4 DO PRINT
+5 QUIT
+6 ;
RPDT ;Ask the user the Report Begin Date and Report End Date.
+1 NEW DIR,X,Y
+2 SET DIR(0)="DA^::E"
+3 SET DIR("A")="Report Begin Date: "
+4 SET DIR("?")="Please enter the Enrollment End Date as the beginning date that will be reported on."
+5 DO ^DIR
SET BDT=Y
+6 IF BDT="^"
QUIT
+7 IF ($DATA(DTOUT))
WRITE *7
QUIT
+8 ;
RPDT2 SET DIR(0)="DA^::E"
+1 SET DIR("A")="Report End Date: "
+2 SET 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."
+3 DO ^DIR
SET EDT=Y
+4 IF EDT="^"
QUIT
+5 IF ($DATA(DTOUT))
WRITE *7
QUIT
+6 IF EDT<BDT
GOTO RPDT2
+7 QUIT
+8 ;
GETEGTS ;First get the current EGT parameters from file #27.16.
+1 NEW GETEGTS,REC,TP
SET (GETEGTS,REC,TP)=""
+2 SET REC=$$FINDCUR^DGENEGT()
IF REC=0
QUIT
+3 SET TP=$$GET^DGENEGT(REC,.GETEGTS)
+4 ;Get EGT Priority.
+5 SET EGT=GETEGTS("PRIORITY")
SET RLEGT=EGT
+6 IF EGT=""
WRITE !,"No EGT setting on file.",!
SET EGT=0
+7 SET EGTSUB=GETEGTS("SUBGRP")
+8 ;Get EGT Effective Date.
+9 SET EGTEDT=GETEGTS("EFFDATE")
IF EGTEDT
SET EGTEDT=$$FMTE^XLFDT(EGTEDT)
+10 ;Get last EGT setting Date/Time.
+11 SET EGTLDT=GETEGTS("ENTDATE")
IF EGTLDT
SET EGTLDT=$$FMTE^XLFDT(EGTLDT)
+12 ;Get EGT Type.
+13 SET EGTTP=GETEGTS("TYPE")
+14 SET EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP)
if EGTTP=""
SET EGTTP="UNSPECIFIED"
+15 QUIT
+16 ;
PRESRT1 ;Sort for patient's current record and get the potentially affected.
+1 NEW IND,PRT,DFN,INPT,PSSN,PEDT,PCTRY,TMP,PRTSUB,ABV
+2 SET (IND,PRT,DFN,PSSN,PEDT,PCTRY,TMP,PRTSUB,ABV)=""
SET INPT="OUT"
+3 KILL ^TMP($JOB,"SS3"),^TMP($JOB,"RT3")
+4 FOR
SET DFN=$ORDER(^DGEN(27.11,"C",DFN))
if DFN=""
QUIT
Begin DoDot:1
+5 SET IND=$$FINDCUR^DGENA(DFN)
IF IND
Begin DoDot:2
+6 DO EGTP
+7 SET PEDT=$PIECE($GET(^DGEN(27.11,IND,0)),U,11)
+8 SET PCTRY=$$CATEGORY^DGENA4(DFN)
+9 IF ABV=0&(PCTRY="N")&(PEDT'<BDT)&(PEDT'>EDT)
Begin DoDot:3
+10 KILL VAIP(2)
SET INPT="OUT"
DO IN5^VADPT
SET TMP=$PIECE($GET(VAIP(2)),U)
IF TMP=1!(TMP=2)!(TMP=6)
SET INPT="IN"
+11 KILL VADM(2)
DO DEM^VADPT
SET PSSN=$PIECE($GET(VADM(2)),U)
+12 SET ^TMP($JOB,"RT3",PRT,PSSN)=PRT_"^"_INPT
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
PRESRT2 ;Sort the sorted.
+1 NEW CNT,ICNT,OCNT,J,K
+2 SET (J,K)=""
+3 FOR
SET J=$ORDER(^TMP($JOB,"RT3",J))
if J=""
QUIT
Begin DoDot:1
+4 SET (CNT,ICNT,OCNT)=0
+5 FOR
SET K=$ORDER(^TMP($JOB,"RT3",J,K))
if K=""
QUIT
Begin DoDot:2
+6 SET INPT=$PIECE($GET(^TMP($JOB,"RT3",J,K)),U,2)
+7 SET CNT=CNT+1
if INPT="IN"
SET ICNT=ICNT+1
if INPT="OUT"
SET OCNT=OCNT+1
+8 SET ^TMP($JOB,"SS3",J)=CNT_"^"_ICNT_"^"_OCNT
End DoDot:2
End DoDot:1
+9 KILL ^TMP($JOB,"RT3")
+10 QUIT
+11 ;
EGTP ;Get patients EGT Priority.
+1 SET (PRT,PRTSUB,ABV,ENRDT)=""
+2 SET PRT=$PIECE($GET(^DGEN(27.11,IND,0)),U,7)
+3 if ((PRT=7)!(PRT=8))
SET PRTSUB=$PIECE($GET(^DGEN(27.11,IND,0)),U,12)
+4 SET ENRDT=$PIECE($GET(^DGEN(27.11,IND,0)),U,10)
+5 if 'ENRDT
SET ENRDT=$PIECE($GET(^DGEN(27.11,IND,0)),U)
+6 SET ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB)
+7 IF PRT=7!(PRT=8)
Begin DoDot:1
+8 SET PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
+9 if PRTSUB=""
SET PRTSUB="ER"
End DoDot:1
+10 SET PRT=PRT_PRTSUB
+11 QUIT
+12 ;
PRINT ;Print the report.
+1 NEW POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY,ZTSAVE,TSK,%ZIS,ZTRTN,ZTDESC
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTRTN="WRITER^DGENRPT3"
SET ZTDESC="DG EGT Actual Summary Report."
+5 SET ZTSAVE("BDT")=""
SET ZTSAVE("EDT")=""
+6 DO ^%ZTLOAD
+7 SET TSK=$SELECT($DATA(ZTSK)=0:"C",1:"Y")
+8 IF TSK="Y"
WRITE !!,"Report queued! Task number: ",ZTSK
+9 DO HOME^%ZIS
End DoDot:1
GOTO EXIT
+10 ;
WRITER ;Write out the report.
+1 USE IO
+2 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+3 NEW EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,COUNT,RLEGT,ENRDT
+4 SET (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,RLEGT)=""
SET COUNT=0
+5 IF $$FINDCUR^DGENEGT()=0
WRITE !,"No EGT setting on file.",!
SET EGT=0
+6 IF $$FINDCUR^DGENEGT()'=0
DO GETEGTS
+7 DO PRESRT1
+8 DO PSHEAD
+9 DO DATA
+10 DO ^%ZISC
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 DO KVA^VADPT
+2 KILL ^TMP($JOB,"SS3")
+3 QUIT
+4 ;
PSHEAD ;Header for the Preliminary Detailed Report.
+1 ;Get the date/time the report is run.
+2 NEW RDT,Y,DT1,DT2
SET (RDT,Y,DT1,DT2)=""
+3 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+4 SET RDT=$PIECE(Y,"@",1)_" @ "_$PIECE($PIECE(Y,"@",2),":",1,2)
+5 SET DT1=$$FMTE^XLFDT(BDT)
SET DT2=$$FMTE^XLFDT(EDT)
+6 SET EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
+7 IF ((EGT=7)!(EGT=8))
IF EGTSUB=""
SET EGTSUB="ER"
+8 ;Write the header.
+9 WRITE !,?((IOM-32)\2),"EGT Actual Summary Impact Report"
+10 WRITE !,?((IOM-62)\2),"Date Range of Enrollment End Date: ",DT1," - ",DT2
+11 WRITE !,?((IOM-41)\2),"Date/Time Report Run: ",RDT
+12 WRITE !,?((IOM-45-$LENGTH(RLEGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",RLEGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
+13 WRITE !,?((IOM-28-$LENGTH(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
+14 WRITE !!,"IMPORTANT NOTE: Actual report is based on a comparison of the EGT Setting and the Enrollment Category as provided by HEC."
+15 WRITE !!,"ENROLLMENT PRIORITY",?23,"TOTAL (UNIQUE SSN)",?43,"# INPATIENT",?57,"# OUTPATIENT",!
+16 QUIT
+17 ;
DATA ;Get all the data for the report.
+1 NEW T,EP,TLT,INPT,OPT
SET (T,EP,TLT,INPT,OPT)=""
+2 FOR
SET T=$ORDER(^TMP($JOB,"SS3",T))
if T=""
QUIT
Begin DoDot:1
+3 SET EP=T
SET TLT=$PIECE($GET(^TMP($JOB,"SS3",T)),U)
SET INPT=$PIECE($GET(^TMP($JOB,"SS3",T)),U,2)
SET OPT=$PIECE($GET(^TMP($JOB,"SS3",T)),U,3)
+4 SET COUNT=COUNT+TLT
+5 WRITE !,EP,?25,TLT,?45,INPT,?59,OPT
End DoDot:1
+6 WRITE !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",COUNT
+7 QUIT
