DGENRPT4 ;ALB/DW,LBD/EG - EGT Actual Detailed Impact Report ; 1/20/05 1:04pm
;;5.3;Registration;**232,306,417,456,491,513,568,585**;Aug 13,1993
;
;
ENPT ;Actual Detailed Report selected.
K ^TMP($J,"BY4"),^TMP($J,"CNT4")
N INFAP,BDT,EDT S (INFAP,BDT,EDT)=""
D RPDT I BDT="^"!(EDT="^")!($D(DTOUT)) Q
D INFAP I INFAP="^"!($D(DTOUT)) Q
N EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,L,BY,DIC,FLDS,DHD,DIOEND,X,DFN,PSSN,FCTY,DIOBEG,VASD,VAERR,RLEGT,ENRDT
S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,FCTY,RLEGT)=""
W !!,"*** This report requires a 132 column printer. ***",!!
S DIC="^DGEN(27.11,"
S DIOBEG="D PRESORT^DGENRPT4"
S BY(0)="^TMP($J,""BY4"",",L(0)=3,L=0
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"
I INFAP=1 D
. 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"
. S DHD="W ?0 D DETHD1^DGENRPT4"
I INFAP=0 D
. 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"
. S DHD="W ?0 D DETHD0^DGENRPT4"
S DIOEND="D END^DGENRPT4"
D EN1^DIP
D EXIT
Q
;
INFAP ;Ask the user if Future Appointments is wanted on the report.
N DIR,X,Y
S DIR(0)="Y^1:3"
S DIR("A")="Do you want to include Future Appointments"
D ^DIR S INFAP=Y
I ($D(DTOUT)) W *7
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
;
PRESORT ;First get the current EGT Setting from file #27.16.
N GETEGTS,REC,TP S (GETEGTS,REC,TP)=""
S REC=$$FINDCUR^DGENEGT()
;If no EGT setting on file, print patient of all enrollment priorities.
I REC=0 W !,"No EGT setting on file.",! S EGT=0 G PRESRT1
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"
;
PRESRT1 ;Sort for patient's current record and get the potentially affected.
N IND,PRT,DFN,NM,PSSN,PEDT,PCTRY,PRTSUB,ABV
S (IND,PRT,DFN,NM,PSSN,PEDT,PCTRY,PRTSUB,ABV)=""
K ^TMP($J,"BY4"),^TMP($J,"CNT4")
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 VADM(1),VADM(2) D DEM^VADPT S NM=VADM(1) D BYSRT
... S PSSN=$P($G(VADM(2)),U),^TMP($J,"CNT4",PRT,PSSN)=""
I EGTSUB>4 S EGTSUB="ER" Q
S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
D GETAPPT^DGENRPT5("BY4")
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
;
BYSRT ;Sort patients by last name for "BY(0)".
S ^TMP($J,"BY4",NM,DFN,IND)=""
Q
;
PT ;Get the patient NAME and SSN
S (X,DFN,PSSN)="" K VADM(1),VADM(2)
S DFN=$P($G(^DGEN(27.11,D0,0)),U,2)
I DFN D DEM^VADPT S X=$E(VADM(1),1,20),PSSN=$P(VADM(2),U)
Q
;
EP ;Get the patient EGT Priority.
S X=""
N PRT,PRTSUB S (PRT,PRTSUB)=""
S PRT=$P($G(^DGEN(27.11,D0,0)),U,7)
I PRT=7!(PRT=8) D
.S PRTSUB=$P($G(^DGEN(27.11,D0,0)),U,12)
.S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
.S:PRTSUB="" PRTSUB="ER"
.S PRT=PRT_PRTSUB
S X=PRT
Q
;
ENRED ;Get the patient ENROLLMENT END DATE.
S X=""
S X=$P($G(^DGEN(27.11,D0,0)),U,11)
I X="" S X="N/A" Q
S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
Q
;
ENRST ;Get the patient ENROLLMENT STATUS.
S X=""
S X=$P($G(^DGEN(27.11,D0,0)),U,4)
S X=$P($G(^DGEN(27.15,X,0)),U,1),X=$E(X,1,12)
Q
;
WRD ;Get the patient WARD.
S X="" K VAIP(5)
D IN5^VADPT S X=$P($G(VAIP(5)),U,2),X=$E(X,1,15)
I X="" S X="N/A"
Q
;
FAP1 ;Get the patient FUTURE APPOINTMENTS.
N J,POP,ADT S (X,J,ADT)="",POP=0
K ^UTILITY("VASD",$J)
;if there is lower level data, then it is an error eg 01/20/2005
I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q
D BLDUTL^DGENRPT5(DFN)
F S J=$O(^UTILITY("VASD",$J,J)) Q:J=""!POP D
. S X=$P($G(^UTILITY("VASD",$J,J,"E")),U,2),X=$E(X,1,20)
. S ADT=$P($G(^UTILITY("VASD",$J,J,"I")),U),ADT=$P(ADT,".",1)
. S ADT=$E(ADT,4,5)_"/"_$E(ADT,6,7)_"/"_(1700+$E(ADT,1,3))
. S X=ADT_" "_X
. I J=1 W X S X=""
. I J>1&(J<6) W !,?79,X S X=""
. I J=6 S X="" W !,?79,"More Appts" S POP=1 Q
I $D(^UTILITY("VASD",$J))=0 S X="NONE"
Q
;
FAP0 ;See if the patient has future appointment.
S X="NO"
K ^UTILITY("VASD",$J)
;in order to be a valid appointment, there must be
;lower level subscripts. if not, then it is
;an error eg 01/20/2005
I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q
D BLDUTL^DGENRPT5(DFN)
I $G(^UTILITY("VASD",$J,1,"I"))'="" S X="YES"
Q
;
PCPVD ;Get the patient PC PROVIDER.
;;Site must use PCMM module.
S X=""
S X=$$PCPRACT^DGSDUTL(DFN)
I X="" S X="N/A" Q
S X=$P(X,U,2),X=$E(X,1,10)
Q
;
PFCLTY ;Get the patient PREFFERED FACILITY.
S (X,FCTY)=""
S X=$$PREF^DGENPTA(DFN,.FCTY),X=$E(FCTY,1,11)
I X="" S X="N/A"
Q
;
DETHD ;General 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)
;Write the header.
W !,?((IOM-33)\2),"EGT Actual Detailed Impact Report"
W !,?((IOM-38-$L(DT1_DT2))\2),"Date Range of Enrollment End Date: ",DT1," - ",DT2
W !,?((IOM-22-$L(RDT))\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."
Q
;
DETHD1 ;Header for the Preliminary Detailed Report, with Future Appointments.
D DETHD
W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?109,"PC",?120,"PREF"
W !,?36,"END DATE",?48,"STATUS",?79,"APPOINTMENTS",?109,"PROVIDER",?120,"FACILITY",!!
Q
;
DETHD0 ;Header for the Preliminary Detailed Report, no Future Appointments.
D DETHD
W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?87,"PC",?99,"PREF"
W !,?36,"END DATE",?48,"STATUS",?79,"APPTS",?87,"PROVIDER",?99,"FACILITY",!!
Q
;
END ;At the end of the display.
N PSSN,J,COUNT S (PSSN,J)="",COUNT=0
F S J=$O(^TMP($J,"CNT4",J)) Q:J="" D
. F S PSSN=$O(^TMP($J,"CNT4",J,PSSN)) Q:PSSN="" S COUNT=COUNT+1
W !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",COUNT
Q
;
EXIT ;Clean up upon exit of the routine.
D KVA^VADPT
K ^TMP($J,"BY4"),^TMP($J,"CNT4")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENRPT4 7942 printed Nov 22, 2024@17:53:09 Page 2
DGENRPT4 ;ALB/DW,LBD/EG - EGT Actual Detailed Impact Report ; 1/20/05 1:04pm
+1 ;;5.3;Registration;**232,306,417,456,491,513,568,585**;Aug 13,1993
+2 ;
+3 ;
ENPT ;Actual Detailed Report selected.
+1 KILL ^TMP($JOB,"BY4"),^TMP($JOB,"CNT4")
+2 NEW INFAP,BDT,EDT
SET (INFAP,BDT,EDT)=""
+3 DO RPDT
IF BDT="^"!(EDT="^")!($DATA(DTOUT))
QUIT
+4 DO INFAP
IF INFAP="^"!($DATA(DTOUT))
QUIT
+5 NEW EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,L,BY,DIC,FLDS,DHD,DIOEND,X,DFN,PSSN,FCTY,DIOBEG,VASD,VAERR,RLEGT,ENRDT
+6 SET (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,FCTY,RLEGT)=""
+7 WRITE !!,"*** This report requires a 132 column printer. ***",!!
+8 SET DIC="^DGEN(27.11,"
+9 SET DIOBEG="D PRESORT^DGENRPT4"
+10 SET BY(0)="^TMP($J,""BY4"","
SET L(0)=3
SET L=0
+11 SET 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"
+12 IF INFAP=1
Begin DoDot:1
+13 SET 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"
+14 SET DHD="W ?0 D DETHD1^DGENRPT4"
End DoDot:1
+15 IF INFAP=0
Begin DoDot:1
+16 SET 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"
+17 SET DHD="W ?0 D DETHD0^DGENRPT4"
End DoDot:1
+18 SET DIOEND="D END^DGENRPT4"
+19 DO EN1^DIP
+20 DO EXIT
+21 QUIT
+22 ;
INFAP ;Ask the user if Future Appointments is wanted on the report.
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y^1:3"
+3 SET DIR("A")="Do you want to include Future Appointments"
+4 DO ^DIR
SET INFAP=Y
+5 IF ($DATA(DTOUT))
WRITE *7
+6 QUIT
+7 ;
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 ;
PRESORT ;First get the current EGT Setting from file #27.16.
+1 NEW GETEGTS,REC,TP
SET (GETEGTS,REC,TP)=""
+2 SET REC=$$FINDCUR^DGENEGT()
+3 ;If no EGT setting on file, print patient of all enrollment priorities.
+4 IF REC=0
WRITE !,"No EGT setting on file.",!
SET EGT=0
GOTO PRESRT1
+5 SET TP=$$GET^DGENEGT(REC,.GETEGTS)
+6 ;Get EGT Priority.
+7 SET EGT=GETEGTS("PRIORITY")
SET RLEGT=EGT
+8 IF EGT=""
WRITE !,"No EGT setting on file.",!
SET EGT=0
+9 SET EGTSUB=GETEGTS("SUBGRP")
+10 ;Get EGT Effective Date.
+11 SET EGTEDT=GETEGTS("EFFDATE")
IF EGTEDT
SET EGTEDT=$$FMTE^XLFDT(EGTEDT)
+12 ;Get last EGT setting Date/Time.
+13 SET EGTLDT=GETEGTS("ENTDATE")
IF EGTLDT
SET EGTLDT=$$FMTE^XLFDT(EGTLDT)
+14 ;Get EGT Type.
+15 SET EGTTP=GETEGTS("TYPE")
+16 SET EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP)
if EGTTP=""
SET EGTTP="UNSPECIFIED"
+17 ;
PRESRT1 ;Sort for patient's current record and get the potentially affected.
+1 NEW IND,PRT,DFN,NM,PSSN,PEDT,PCTRY,PRTSUB,ABV
+2 SET (IND,PRT,DFN,NM,PSSN,PEDT,PCTRY,PRTSUB,ABV)=""
+3 KILL ^TMP($JOB,"BY4"),^TMP($JOB,"CNT4")
+4 FOR
SET DFN=$ORDER(^DGEN(27.11,"C",DFN))
if DFN=""
QUIT
Begin DoDot:1
+5 SET IND=$$FINDCUR^DGENA(DFN)
+6 IF IND
Begin DoDot:2
+7 DO EGTP
+8 SET PEDT=$PIECE($GET(^DGEN(27.11,IND,0)),U,11)
+9 SET PCTRY=$$CATEGORY^DGENA4(DFN)
+10 IF ABV=0&(PCTRY="N")&(PEDT'<BDT)&(PEDT'>EDT)
Begin DoDot:3
+11 KILL VADM(1),VADM(2)
DO DEM^VADPT
SET NM=VADM(1)
DO BYSRT
+12 SET PSSN=$PIECE($GET(VADM(2)),U)
SET ^TMP($JOB,"CNT4",PRT,PSSN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF EGTSUB>4
SET EGTSUB="ER"
QUIT
+14 SET EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
+15 DO GETAPPT^DGENRPT5("BY4")
+16 QUIT
+17 ;
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 ;
BYSRT ;Sort patients by last name for "BY(0)".
+1 SET ^TMP($JOB,"BY4",NM,DFN,IND)=""
+2 QUIT
+3 ;
PT ;Get the patient NAME and SSN
+1 SET (X,DFN,PSSN)=""
KILL VADM(1),VADM(2)
+2 SET DFN=$PIECE($GET(^DGEN(27.11,D0,0)),U,2)
+3 IF DFN
DO DEM^VADPT
SET X=$EXTRACT(VADM(1),1,20)
SET PSSN=$PIECE(VADM(2),U)
+4 QUIT
+5 ;
EP ;Get the patient EGT Priority.
+1 SET X=""
+2 NEW PRT,PRTSUB
SET (PRT,PRTSUB)=""
+3 SET PRT=$PIECE($GET(^DGEN(27.11,D0,0)),U,7)
+4 IF PRT=7!(PRT=8)
Begin DoDot:1
+5 SET PRTSUB=$PIECE($GET(^DGEN(27.11,D0,0)),U,12)
+6 SET PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
+7 if PRTSUB=""
SET PRTSUB="ER"
+8 SET PRT=PRT_PRTSUB
End DoDot:1
+9 SET X=PRT
+10 QUIT
+11 ;
ENRED ;Get the patient ENROLLMENT END DATE.
+1 SET X=""
+2 SET X=$PIECE($GET(^DGEN(27.11,D0,0)),U,11)
+3 IF X=""
SET X="N/A"
QUIT
+4 SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
+5 QUIT
+6 ;
ENRST ;Get the patient ENROLLMENT STATUS.
+1 SET X=""
+2 SET X=$PIECE($GET(^DGEN(27.11,D0,0)),U,4)
+3 SET X=$PIECE($GET(^DGEN(27.15,X,0)),U,1)
SET X=$EXTRACT(X,1,12)
+4 QUIT
+5 ;
WRD ;Get the patient WARD.
+1 SET X=""
KILL VAIP(5)
+2 DO IN5^VADPT
SET X=$PIECE($GET(VAIP(5)),U,2)
SET X=$EXTRACT(X,1,15)
+3 IF X=""
SET X="N/A"
+4 QUIT
+5 ;
FAP1 ;Get the patient FUTURE APPOINTMENTS.
+1 NEW J,POP,ADT
SET (X,J,ADT)=""
SET POP=0
+2 KILL ^UTILITY("VASD",$JOB)
+3 ;if there is lower level data, then it is an error eg 01/20/2005
+4 IF $DATA(^TMP($JOB,"SDAMA",101))=1
SET X="Appt. DB Unavail."
QUIT
+5 DO BLDUTL^DGENRPT5(DFN)
+6 FOR
SET J=$ORDER(^UTILITY("VASD",$JOB,J))
if J=""!POP
QUIT
Begin DoDot:1
+7 SET X=$PIECE($GET(^UTILITY("VASD",$JOB,J,"E")),U,2)
SET X=$EXTRACT(X,1,20)
+8 SET ADT=$PIECE($GET(^UTILITY("VASD",$JOB,J,"I")),U)
SET ADT=$PIECE(ADT,".",1)
+9 SET ADT=$EXTRACT(ADT,4,5)_"/"_$EXTRACT(ADT,6,7)_"/"_(1700+$EXTRACT(ADT,1,3))
+10 SET X=ADT_" "_X
+11 IF J=1
WRITE X
SET X=""
+12 IF J>1&(J<6)
WRITE !,?79,X
SET X=""
+13 IF J=6
SET X=""
WRITE !,?79,"More Appts"
SET POP=1
QUIT
End DoDot:1
+14 IF $DATA(^UTILITY("VASD",$JOB))=0
SET X="NONE"
+15 QUIT
+16 ;
FAP0 ;See if the patient has future appointment.
+1 SET X="NO"
+2 KILL ^UTILITY("VASD",$JOB)
+3 ;in order to be a valid appointment, there must be
+4 ;lower level subscripts. if not, then it is
+5 ;an error eg 01/20/2005
+6 IF $DATA(^TMP($JOB,"SDAMA",101))=1
SET X="Appt. DB Unavail."
QUIT
+7 DO BLDUTL^DGENRPT5(DFN)
+8 IF $GET(^UTILITY("VASD",$JOB,1,"I"))'=""
SET X="YES"
+9 QUIT
+10 ;
PCPVD ;Get the patient PC PROVIDER.
+1 ;;Site must use PCMM module.
+2 SET X=""
+3 SET X=$$PCPRACT^DGSDUTL(DFN)
+4 IF X=""
SET X="N/A"
QUIT
+5 SET X=$PIECE(X,U,2)
SET X=$EXTRACT(X,1,10)
+6 QUIT
+7 ;
PFCLTY ;Get the patient PREFFERED FACILITY.
+1 SET (X,FCTY)=""
+2 SET X=$$PREF^DGENPTA(DFN,.FCTY)
SET X=$EXTRACT(FCTY,1,11)
+3 IF X=""
SET X="N/A"
+4 QUIT
+5 ;
DETHD ;General 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 ;Write the header.
+7 WRITE !,?((IOM-33)\2),"EGT Actual Detailed Impact Report"
+8 WRITE !,?((IOM-38-$LENGTH(DT1_DT2))\2),"Date Range of Enrollment End Date: ",DT1," - ",DT2
+9 WRITE !,?((IOM-22-$LENGTH(RDT))\2),"Date/Time Report Run: ",RDT
+10 WRITE !,?((IOM-45-$LENGTH(RLEGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",RLEGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
+11 WRITE !,?((IOM-28-$LENGTH(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
+12 WRITE !!,"IMPORTANT NOTE: Actual report is based on a comparison of the EGT Setting and the Enrollment Category as provided by HEC."
+13 QUIT
+14 ;
DETHD1 ;Header for the Preliminary Detailed Report, with Future Appointments.
+1 DO DETHD
+2 WRITE !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?109,"PC",?120,"PREF"
+3 WRITE !,?36,"END DATE",?48,"STATUS",?79,"APPOINTMENTS",?109,"PROVIDER",?120,"FACILITY",!!
+4 QUIT
+5 ;
DETHD0 ;Header for the Preliminary Detailed Report, no Future Appointments.
+1 DO DETHD
+2 WRITE !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?87,"PC",?99,"PREF"
+3 WRITE !,?36,"END DATE",?48,"STATUS",?79,"APPTS",?87,"PROVIDER",?99,"FACILITY",!!
+4 QUIT
+5 ;
END ;At the end of the display.
+1 NEW PSSN,J,COUNT
SET (PSSN,J)=""
SET COUNT=0
+2 FOR
SET J=$ORDER(^TMP($JOB,"CNT4",J))
if J=""
QUIT
Begin DoDot:1
+3 FOR
SET PSSN=$ORDER(^TMP($JOB,"CNT4",J,PSSN))
if PSSN=""
QUIT
SET COUNT=COUNT+1
End DoDot:1
+4 WRITE !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",COUNT
+5 QUIT
+6 ;
EXIT ;Clean up upon exit of the routine.
+1 DO KVA^VADPT
+2 KILL ^TMP($JOB,"BY4"),^TMP($JOB,"CNT4")
+3 QUIT
