- DGENRPT1 ;ALB/DW,LBD - EGT Preliminary Summary Impact Report ; 04/24/03 2:32pm ; 07/22/02 9:40am
- ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13,1993
- ;
- ;
- ENPT ;Preliminary Summary Report selected.
- K ^TMP($J,"SS1"),^TMP($J,"RT1")
- I $$FINDCUR^DGENEGT()=0 W !,"No EGT setting on file." Q
- D PRINT
- 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 Prioity.
- S EGT=GETEGTS("PRIORITY")
- 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,TMP,ABV,PRTSUB
- S (IND,PRT,DFN,PSSN,TMP,ABV,PRTSUB)="",INPT="OUT"
- K ^TMP($J,"SS1"),^TMP($J,"RT1")
- F S DFN=$O(^DGEN(27.11,"C",DFN)) Q:DFN="" D
- . S IND=$$FINDCUR^DGENA(DFN)
- . I IND D EGTP I ABV=0 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,"RT1",PRT,PSSN)=PRT_"^"_INPT
- ;
- PRESRT2 ;Sort the sorted.
- N CNT,ICNT,OCNT,J,K
- S (J,K)=""
- F S J=$O(^TMP($J,"RT1",J)) Q:J="" D
- . S (CNT,ICNT,OCNT)=0
- . F S K=$O(^TMP($J,"RT1",J,K)) Q:K="" D
- .. S INPT=$P($G(^TMP($J,"RT1",J,K)),U,2)
- .. S CNT=CNT+1 S:INPT="IN" ICNT=ICNT+1 S:INPT="OUT" OCNT=OCNT+1
- .. S ^TMP($J,"SS1",J)=CNT_"^"_ICNT_"^"_OCNT
- K ^TMP($J,"RT1")
- Q
- ;
- EGTP ;Decide if the patient is above EGT.
- 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^DGENRPT1",ZTDESC="DG EGT Preliminary Summary Report."
- . 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,ENRDT
- S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP)=""
- D GETEGTS
- D PRESRT1
- D PSHEAD
- D DATA
- D ^%ZISC
- EXIT S:$D(ZTQUEUED) ZTREQ="@"
- D KVA^VADPT
- K ^TMP($J,"SS1")
- Q
- ;
- PSHEAD ;Header for the Preliminary Detailed Report.
- ;Get the date/time the report is run.
- N RDT,Y S (RDT,Y)=""
- D NOW^%DTC S Y=% X ^DD("DD")
- S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)
- S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
- I ((EGT=7)!(EGT=8)),EGTSUB="" S EGTSUB="ER"
- ;Write the header.
- W !,?((IOM-38)\2),"EGT Preliminary Summary Impact Report"
- W !,?((IOM-22-$L(RDT))\2),"Date/Time Report Run: ",RDT
- W !,?((IOM-45-$L(EGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",EGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT
- W !,?((IOM-28-$L(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT
- W !!,"IMPORTANT NOTE:",!,"Preliminary report is based on a comparison of the EGT setting to the veterans current enrollment priority as shown in VISTA."
- 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,COUNT S (T,EP,TLT,INPT,OPT)="",COUNT=0
- F S T=$O(^TMP($J,"SS1",T)) Q:T="" D
- . S EP=T,TLT=$P($G(^TMP($J,"SS1",T)),U),INPT=$P($G(^TMP($J,"SS1",T)),U,2),OPT=$P($G(^TMP($J,"SS1",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[HDGENRPT1 4123 printed Jan 18, 2025@03:43:49 Page 2
- DGENRPT1 ;ALB/DW,LBD - EGT Preliminary Summary Impact Report ; 04/24/03 2:32pm ; 07/22/02 9:40am
- +1 ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13,1993
- +2 ;
- +3 ;
- ENPT ;Preliminary Summary Report selected.
- +1 KILL ^TMP($JOB,"SS1"),^TMP($JOB,"RT1")
- +2 IF $$FINDCUR^DGENEGT()=0
- WRITE !,"No EGT setting on file."
- QUIT
- +3 DO PRINT
- +4 QUIT
- +5 ;
- 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 Prioity.
- +5 SET EGT=GETEGTS("PRIORITY")
- +6 SET EGTSUB=GETEGTS("SUBGRP")
- +7 ;Get EGT Effective Date.
- +8 SET EGTEDT=GETEGTS("EFFDATE")
- IF EGTEDT
- SET EGTEDT=$$FMTE^XLFDT(EGTEDT)
- +9 ;Get last EGT setting Date/Time.
- +10 SET EGTLDT=GETEGTS("ENTDATE")
- IF EGTLDT
- SET EGTLDT=$$FMTE^XLFDT(EGTLDT)
- +11 ;Get EGT Type.
- +12 SET EGTTP=GETEGTS("TYPE")
- +13 SET EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP)
- if EGTTP=""
- SET EGTTP="UNSPECIFIED"
- +14 QUIT
- +15 ;
- PRESRT1 ;Sort for patient's current record and get the potentially affected.
- +1 NEW IND,PRT,DFN,INPT,PSSN,TMP,ABV,PRTSUB
- +2 SET (IND,PRT,DFN,PSSN,TMP,ABV,PRTSUB)=""
- SET INPT="OUT"
- +3 KILL ^TMP($JOB,"SS1"),^TMP($JOB,"RT1")
- +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
- DO EGTP
- IF ABV=0
- Begin DoDot:2
- +7 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"
- +8 KILL VADM(2)
- DO DEM^VADPT
- SET PSSN=$PIECE($GET(VADM(2)),U)
- +9 SET ^TMP($JOB,"RT1",PRT,PSSN)=PRT_"^"_INPT
- End DoDot:2
- End DoDot:1
- +10 ;
- PRESRT2 ;Sort the sorted.
- +1 NEW CNT,ICNT,OCNT,J,K
- +2 SET (J,K)=""
- +3 FOR
- SET J=$ORDER(^TMP($JOB,"RT1",J))
- if J=""
- QUIT
- Begin DoDot:1
- +4 SET (CNT,ICNT,OCNT)=0
- +5 FOR
- SET K=$ORDER(^TMP($JOB,"RT1",J,K))
- if K=""
- QUIT
- Begin DoDot:2
- +6 SET INPT=$PIECE($GET(^TMP($JOB,"RT1",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,"SS1",J)=CNT_"^"_ICNT_"^"_OCNT
- End DoDot:2
- End DoDot:1
- +9 KILL ^TMP($JOB,"RT1")
- +10 QUIT
- +11 ;
- EGTP ;Decide if the patient is above EGT.
- +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^DGENRPT1"
- SET ZTDESC="DG EGT Preliminary Summary Report."
- +5 DO ^%ZTLOAD
- +6 SET TSK=$SELECT($DATA(ZTSK)=0:"C",1:"Y")
- +7 IF TSK="Y"
- WRITE !!,"Report queued! Task number: ",ZTSK
- +8 DO HOME^%ZIS
- End DoDot:1
- GOTO EXIT
- +9 ;
- WRITER ;Write out the report.
- +1 USE IO
- +2 IF $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +3 NEW EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,ENRDT
- +4 SET (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP)=""
- +5 DO GETEGTS
- +6 DO PRESRT1
- +7 DO PSHEAD
- +8 DO DATA
- +9 DO ^%ZISC
- EXIT if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 DO KVA^VADPT
- +2 KILL ^TMP($JOB,"SS1")
- +3 QUIT
- +4 ;
- PSHEAD ;Header for the Preliminary Detailed Report.
- +1 ;Get the date/time the report is run.
- +2 NEW RDT,Y
- SET (RDT,Y)=""
- +3 DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- +4 SET RDT=$PIECE(Y,"@",1)_" @ "_$PIECE($PIECE(Y,"@",2),":",1,2)
- +5 SET EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB)
- +6 IF ((EGT=7)!(EGT=8))
- IF EGTSUB=""
- SET EGTSUB="ER"
- +7 ;Write the header.
- +8 WRITE !,?((IOM-38)\2),"EGT Preliminary Summary Impact Report"
- +9 WRITE !,?((IOM-22-$LENGTH(RDT))\2),"Date/Time Report Run: ",RDT
- +10 WRITE !,?((IOM-45-$LENGTH(EGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",EGT_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:",!,"Preliminary report is based on a comparison of the EGT setting to the veterans current enrollment priority as shown in VISTA."
- +13 WRITE !!,"ENROLLMENT PRIORITY",?23,"TOTAL (UNIQUE SSN)",?43,"# INPATIENT",?57,"# OUTPATIENT",!
- +14 QUIT
- +15 ;
- DATA ;Get all the data for the report.
- +1 NEW T,EP,TLT,INPT,OPT,COUNT
- SET (T,EP,TLT,INPT,OPT)=""
- SET COUNT=0
- +2 FOR
- SET T=$ORDER(^TMP($JOB,"SS1",T))
- if T=""
- QUIT
- Begin DoDot:1
- +3 SET EP=T
- SET TLT=$PIECE($GET(^TMP($JOB,"SS1",T)),U)
- SET INPT=$PIECE($GET(^TMP($JOB,"SS1",T)),U,2)
- SET OPT=$PIECE($GET(^TMP($JOB,"SS1",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