Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENRPT2

DGENRPT2.m

Go to the documentation of this file.
  1. DGENRPT2 ;ALB/GAH - EGT Preliminary Detailed Impact Report ; 10/10/2005
  1. ;;5.3;Registration;**232,306,417,456,491,513,568,725**;Aug 13,1993;Build 12
  1. ;
  1. ;
  1. ENPT ;Preliminary Detailed Report selected.
  1. K ^TMP($J,"BY2"),^TMP($J,"CNT2")
  1. I $$FINDCUR^DGENEGT()=0 W !,"No EGT setting on file." Q
  1. N INFAP S INFAP=""
  1. D INFAP I INFAP="^"!($D(DTOUT)) Q
  1. N EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,L,BY,DIC,FLDS,DHD,DIOEND,X,DFN,PSSN,FCTY,TOTAL,DIOBEG,VASD,VAERR,ENRDT
  1. S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,FCTY)="",TOTAL=0
  1. W !!,"*** This report requires a 132 column printer. ***",!!
  1. S DIC="^DGEN(27.11,"
  1. S BY(0)="^TMP($J,""BY2""",L(0)=3,L=0
  1. S DIOBEG="D PRESORT^DGENRPT2"
  1. 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"
  1. I INFAP=1 D
  1. . 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"
  1. . S DHD="W ?0 D DETHD1^DGENRPT2"
  1. I INFAP=0 D
  1. . 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"
  1. . S DHD="W ?0 D DETHD0^DGENRPT2"
  1. S DIOEND="D END^DGENRPT2"
  1. D EN1^DIP
  1. D EXIT
  1. Q
  1. ;
  1. INFAP ;Ask the user if Future Appointments is wanted on the report.
  1. N DIR,X,Y
  1. S DIR(0)="Y^1:3"
  1. S DIR("A")="Do you want to include Future Appointments"
  1. D ^DIR S INFAP=Y
  1. I ($D(DTOUT)) W *7
  1. Q
  1. ;
  1. PRESORT ;First get the current EGT Setting from file #27.16.
  1. N GETEGTS,REC,TP S (GETEGTS,REC,TP)=""
  1. S REC=$$FINDCUR^DGENEGT()
  1. I REC=0 Q
  1. S TP=$$GET^DGENEGT(REC,.GETEGTS)
  1. ;Get EGT Priority.
  1. S EGT=GETEGTS("PRIORITY")
  1. S EGTSUB=GETEGTS("SUBGRP")
  1. ;Get EGT Effective Date.
  1. S EGTEDT=GETEGTS("EFFDATE") I EGTEDT S EGTEDT=$$FMTE^XLFDT(EGTEDT)
  1. ;Get last EGT setting Date/Time.
  1. S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT)
  1. ;Get EGT Type.
  1. S EGTTP=GETEGTS("TYPE")
  1. S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED"
  1. ;Sort for patient's current record and get the potentially affected.
  1. N IND,PRT,DFN,NM,PSSN,PRTSUB,ABV
  1. S (IND,PRT,DFN,NM,PSSN,PRTSUB,ABV)=""
  1. K ^TMP($J,"BY2"),^TMP($J,"CNT2")
  1. F S DFN=$O(^DGEN(27.11,"C",DFN)) Q:DFN="" D
  1. . S IND=$$FINDCUR^DGENA(DFN)
  1. . I IND D EGTP I ABV=0 D
  1. .. K VADM(1),VADM(2) D DEM^VADPT S NM=VADM(1) D BYSRT
  1. .. S PSSN=$P($G(VADM(2)),U),^TMP($J,"CNT2",PRT,PSSN)=""
  1. I EGTSUB>4 S EGTSUB="ER" Q
  1. S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
  1. D GETAPPT^DGENRPT5("BY2")
  1. Q
  1. ;
  1. EGTP ;Get patients EGT Priority.
  1. S (PRT,PRTSUB,ABV,ENRDT)=""
  1. S PRT=$P($G(^DGEN(27.11,IND,0)),U,7)
  1. S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12)
  1. S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10)
  1. S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U)
  1. S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB)
  1. I PRT=7!(PRT=8) D
  1. . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
  1. . S:PRTSUB="" PRTSUB="ER"
  1. S PRT=PRT_PRTSUB
  1. Q
  1. ;
  1. BYSRT ;Sort patients by last name for "BY(0)".
  1. S ^TMP($J,"BY2",NM,DFN,IND)=""
  1. Q
  1. ;
  1. PT ;Get the patient NAME and SSN
  1. S (X,DFN,PSSN)="" K VADM(1),VADM(2)
  1. S DFN=$P($G(^DGEN(27.11,D0,0)),U,2)
  1. I DFN D DEM^VADPT S X=$E(VADM(1),1,20),PSSN=$P(VADM(2),U)
  1. Q
  1. ;
  1. EP ;Get the patient EGT Priority.
  1. S X=""
  1. N PRT,PRTSUB S (PRT,PRTSUB)=""
  1. S PRT=$P($G(^DGEN(27.11,D0,0)),U,7)
  1. I PRT=7!(PRT=8) D
  1. .S PRTSUB=$P($G(^DGEN(27.11,D0,0)),U,12)
  1. .S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB)
  1. .S:PRTSUB="" PRTSUB="ER"
  1. .S PRT=PRT_PRTSUB
  1. S X=PRT
  1. Q
  1. ;
  1. ENRED ;Get the patient ENROLLMENT END DATE.
  1. S X=""
  1. S X=$P($G(^DGEN(27.11,D0,0)),U,11)
  1. I X="" S X="N/A" Q
  1. S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
  1. Q
  1. ;
  1. ENRST ;Get the patient ENROLLMENT STATUS.
  1. S X=""
  1. S X=$P($G(^DGEN(27.11,D0,0)),U,4)
  1. S X=$P($G(^DGEN(27.15,X,0)),U,1),X=$E(X,1,12)
  1. Q
  1. ;
  1. WRD ;Get the patient WARD.
  1. S X="" K VAIP(5)
  1. D IN5^VADPT S X=$P($G(VAIP(5)),U,2),X=$E(X,1,15)
  1. I X="" S X="N/A"
  1. Q
  1. ;
  1. FAP1 ;Get the patient FUTURE APPOINTMENTS.
  1. N J,POP,ADT S (X,ADT)="",POP=0,J=0
  1. K ^UTILITY("VASD",$J)
  1. S X=$$FAPCHK(DFN) Q:X'=""
  1. D BLDUTL^DGENRPT5(DFN)
  1. F S J=$O(^UTILITY("VASD",$J,J)) Q:J=""!POP D
  1. . S X=$P($G(^UTILITY("VASD",$J,J,"E")),U,2),X=$E(X,1,20)
  1. . S ADT=$P($G(^UTILITY("VASD",$J,J,"I")),U),ADT=$P(ADT,".",1)
  1. . S ADT=$E(ADT,4,5)_"/"_$E(ADT,6,7)_"/"_(1700+$E(ADT,1,3))
  1. . S X=ADT_" "_X
  1. . I J=1 W X S X=""
  1. . I J>1&(J<6) W !,?79,X S X=""
  1. . I J=6 S X="" W !,?79,"More Appts" S POP=1 Q
  1. I $D(^UTILITY("VASD",$J))=0 S X="NONE"
  1. Q
  1. ;
  1. FAP0 ;See if the patient has future appointment.
  1. S X="NO"
  1. K ^UTILITY("VASD",$J)
  1. S X=$$FAPCHK(DFN) Q:X'=""
  1. D BLDUTL^DGENRPT5(DFN)
  1. I $G(^UTILITY("VASD",$J,1,"I"))'="" S X="YES"
  1. Q
  1. ;
  1. FAPCHK(DFN) ;
  1. Q $G(^TMP($J,"SDAMA",DFN,"ERROR"))
  1. PCPVD ;Get the patient PC PROVIDER.
  1. ;;Site must use PCMM module.
  1. S X=""
  1. S X=$$PCPRACT^DGSDUTL(DFN)
  1. I X="" S X="N/A" Q
  1. S X=$P(X,U,2),X=$E(X,1,10)
  1. Q
  1. ;
  1. PFCLTY ;Get the patient PREFFERED FACILITY.
  1. S (X,FCTY)=""
  1. S X=$$PREF^DGENPTA(DFN,.FCTY),X=$E(FCTY,1,10)
  1. I X="" S X="N/A"
  1. Q
  1. ;
  1. DETHD ;General header for the Preliminary Detailed Report.
  1. ;Get the date/time the report is run.
  1. N RDT,Y S (RDT,Y)=""
  1. D NOW^%DTC S Y=% X ^DD("DD")
  1. S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)
  1. ;Write the header.
  1. W !,?((IOM-38)\2),"EGT Preliminary Detailed Impact Report"
  1. W !,?((IOM-22-$L(RDT))\2),"Date/Time Report Run: ",RDT
  1. W !,?((IOM-45-$L(EGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",EGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
  1. W !,?((IOM-28-$L(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
  1. W !!,"IMPORTANT NOTE:",!,"Preliminary report is based on a comparison of the EGT setting to the veterans current enrollment priority as shown in VISTA."
  1. Q
  1. ;
  1. DETHD1 ;Header for the Preliminary Detailed Report, with Future Appointments.
  1. D DETHD
  1. W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?109,"PC",?120,"PREF"
  1. W !,?36,"END DATE",?48,"STATUS",?79,"APPOINTMENTS",?109,"PROVIDER",?120,"FACILITY",!!
  1. Q
  1. ;
  1. DETHD0 ;Header for the Preliminary Detailed Report, no Future Appointments.
  1. D DETHD
  1. W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?87,"PC",?99,"PREF"
  1. W !,?36,"END DATE",?48,"STATUS",?79,"APPTS",?87,"PROVIDER",?99,"FACILITY",!!
  1. Q
  1. ;
  1. END ;At the end of the display.
  1. N PSSN,J S (PSSN,J)=""
  1. F S J=$O(^TMP($J,"CNT2",J)) Q:J="" D
  1. . F S PSSN=$O(^TMP($J,"CNT2",J,PSSN)) Q:PSSN="" D
  1. ..S TOTAL=TOTAL+1
  1. W !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",TOTAL
  1. Q
  1. ;
  1. EXIT ;Clean up upon exit of the routine.
  1. D KVA^VADPT
  1. K ^TMP($J,"BY2"),^TMP($J,"CNT2"),^TMP($J,"SDAMA")
  1. Q