DGENRPT4.m

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 ---DGENRPT4   7942     printed  Mar 13, 2025@21:47:44                                                                                                                                                                                                    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