EHMDISCH ;ALB/WTC - EHRM - AUTOMATED PATIENT DISCHARGE TOOL; Jun 06, 2025@13:23:13
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**15**;Apr 19, 2021;Build 14
;
;
Q ;
;
LIST ;
;
; List patients eligible for discharge. To be used at time of conversion to Millennium.
;
N WARD,DFN,VADM,FIRST,PTNAME,SORTBY,INSTFLTR,DIR,Y,X,INSTUTN,IEN,INSTNAME,QUEUED,LINES,QUIT,STATION,POP,TXDTTM,NEWWARD,INCLHIST,WARDFLTR ;
;
S INSTFLTR=$$INSTFLTR() Q:INSTFLTR="" ;
S WARDFLTR="" I $P(INSTFLTR,U,1)="S" S WARDFLTR=$$WARDFLTR($P(INSTFLTR,U,2)) ;
;
S DIR(0)="S^WARD:Ward;PATIENT:Patient",DIR("A")="Sort by" D ^DIR Q:$D(DIRUT) S SORTBY=Y ;
;
K DIR ;
S DIR(0)="Y",DIR("A")="Include transfer history",DIR("B")="NO" D ^DIR Q:$D(DIRUT) S INCLHIST=Y ;
;
W !!,"Report is 160 columns wide",! ;
S %ZIS="Q" D ^%ZIS I POP Q ;
;
; If report is queued, add to Taskman
;
S QUEUED=0 I $D(IO("Q")) S QUEUED=1 D Q ;
. N ZTDESC,ZTRTN,ZTSAVE,ZTSK ;
. S ZTRTN="LIST1^EHMDISCH",ZTDESC="Patient Discharge List" ;
. S ZTSAVE("*")="" ;
. D ^%ZTLOAD W $S($D(ZTSK):"...Task queued",1:"...Task cancelled"),! ;
;
LIST1 ; TaskMan start point
;
I 'QUEUED,SORTBY="WARD" W !,"Sorting patients within ward..." ;
I 'QUEUED,SORTBY="PATIENT" W !,"Sorting patients..." ;
K ^TMP("EHMDISCH",$J) ;
;
D BLDLIST(SORTBY,INSTFLTR,WARDFLTR,QUEUED) ;
U IO ;
;
I SORTBY="WARD" D ;
. S INSTUTN="",QUIT=0 F S INSTUTN=$O(^TMP("EHMDISCH",$J,INSTUTN)) Q:INSTUTN="" D Q:QUIT ;
.. S INSTNAME=$P(INSTUTN,U,1),IEN=$P(INSTUTN,U,2),STATION=$$GET1^DIQ(4,IEN,99) D HEADER(INSTNAME,STATION,SORTBY) ;
.. S WARD="",LINES=0 F S WARD=$O(^TMP("EHMDISCH",$J,INSTUTN,WARD)) Q:WARD="" D Q:QUIT ;
... S PTNAME="",FIRST=1 ;
... F S PTNAME=$O(^TMP("EHMDISCH",$J,INSTUTN,WARD,PTNAME)) Q:PTNAME="" Q:QUIT S DFN=0 F S DFN=$O(^TMP("EHMDISCH",$J,INSTUTN,WARD,PTNAME,DFN)) Q:'DFN S X=^(DFN) D S FIRST=0 Q:QUIT ;
.... ;
.... I 'QUEUED D PAGINATE(.QUIT,INSTNAME,STATION,SORTBY,.LINES) Q:QUIT ;
.... ;
.... W $S(FIRST:WARD,1:""),?32,PTNAME,?64,$$DATETIME($P(X,U,3)),?81,$P(X,U,2),?91,$P(X,U,4),?123,$P(X,U,5),! S LINES=LINES+1 ;
.... Q:'INCLHIST ;
.... ;
.... ; Transfers
.... ;
.... Q:$D(^TMP("EHMDISCH",$J,INSTUTN,WARD,PTNAME,DFN))<10 ; No transfers
.... ;
.... S TXDTTM=0 F S TXDTTM=$O(^TMP("EHMDISCH",$J,INSTUTN,WARD,PTNAME,DFN,TXDTTM)) Q:'TXDTTM S X=^(TXDTTM) W ?10,$P(X,U,1),?25,$$DATETIME(TXDTTM),?42,$P(X,U,2),?74,$P(X,U,3),! S LINES=LINES+1 ;
.... W ! S LINES=LINES+1 ;
... W ! ;
.. ;
.. I 'QUEUED,'QUIT S QUIT=$$CONTINUE()=0 ;
;
I SORTBY="PATIENT" D ;
. S INSTUTN="",QUIT=0 F S INSTUTN=$O(^TMP("EHMDISCH",$J,INSTUTN)) Q:INSTUTN="" D Q:QUIT ;
.. S INSTNAME=$P(INSTUTN,U,1),IEN=$P(INSTUTN,U,2),STATION=$$GET1^DIQ(4,IEN,99) D HEADER(INSTNAME,STATION,SORTBY) ;
.. S PTNAME="",FIRST="",LINES=0 F S PTNAME=$O(^TMP("EHMDISCH",$J,INSTUTN,PTNAME)) Q:PTNAME="" D Q:QUIT ;
... I FIRST'=$E(PTNAME,1) W ! S LINES=LINES+1 ;
... S FIRST=$E(PTNAME,1) ;
... S DFN=0 F S DFN=$O(^TMP("EHMDISCH",$J,INSTUTN,PTNAME,DFN)) Q:'DFN S X=^(DFN) D Q:QUIT ;
.... ;
.... I 'QUEUED D PAGINATE(.QUIT,INSTNAME,STATION,SORTBY,.LINES) Q:QUIT ;
.... ;
.... W PTNAME,?32,$P(X,U,2),?64,$$DATETIME($P(X,U,4)),?81,$P(X,U,3),?91,$P(X,U,5),?123,$P(X,U,6),! S LINES=LINES+1 ;
.... Q:'INCLHIST ;
.... ;
.... ; Transfers
.... ;
.... Q:$D(^TMP("EHMDISCH",$J,INSTUTN,PTNAME,DFN))<10 ; No transfers
.... ;
.... S TXDTTM=0 F S TXDTTM=$O(^TMP("EHMDISCH",$J,INSTUTN,PTNAME,DFN,TXDTTM)) Q:'TXDTTM S X=^(TXDTTM) W ?10,$P(X,U,1),?25,$$DATETIME(TXDTTM),?42,$P(X,U,2),?74,$P(X,U,3),! S LINES=LINES+1 ;
.... W ! S LINES=LINES+1 ;
.. ;
.. I 'QUEUED,'QUIT S QUIT=$$CONTINUE()=0 ;
;
I QUIT W ! ;
U 0 I 'QUEUED,IO=$I R !,"Press [RETURN] to continue",X:$G(DTIME,300) ;
K ^TMP("EHMDISCH",$J) D ^%ZISC ;
Q ;
;
;
W @IOF,$$CENTER("Patient Discharge List - "_INSTNAME_" ("_STATION_")",IOM),?IOM-8,$$FMTE^XLFDT(DT,2),!! ;
I SORTBY="WARD" D ;
. W "WARD",?32,"PATIENT",?64,"ADMIT DATE/TIME",?81,"ROOM/BED",?91,"DIAGNOSIS",?123,"ATTENDING PROVIDER",! ;
. W $$DASHES(30),?32,$$DASHES(30),?64,$$DASHES(15),?81,$$DASHES(8),?91,$$DASHES(30),?123,$$DASHES(30),! ;
;
I SORTBY="PATIENT" D ;
. W "PATIENT",?32,"WARD",?64,"ADMIT DATE/TIME",?81,"ROOM/BED",?91,"DIAGNOSIS",?123,"ATTENDING PROVIDER",! ;
. W $$DASHES(30),?32,$$DASHES(30),?64,$$DASHES(15),?81,$$DASHES(8),?91,$$DASHES(30),?123,$$DASHES(30),! ;
Q ;
;
SUMMARY ;
;
; Summary of patients eligible for discharge. To be used at time of conversion to Millennium.
;
N WARD,DFN,VADM,FIRST,PTNAME,INSTUTN,IEN,INSTNAME,ADMDTTM,QUEUED,LINES,QUIT,STATION,POP,TOTAL1,TOTAL2 ;
;
W !,"Report is 80 columns wide",! ;
S %ZIS="Q" D ^%ZIS I POP Q ;
;
; If report is queued, add to Taskman
;
S QUEUED=0 I $D(IO("Q")) S QUEUED=1 D Q ;
. N ZTDESC,ZTRTN,ZTSAVE,ZTSK ;
. S ZTRTN="SUMMARY1^EHMDISCH",ZTDESC="Summary of Patients to be Discharged" ;
. S ZTSAVE("*")="" ;
. D ^%ZTLOAD W $S($D(ZTSK):"...Task queued",1:"...Task cancelled"),! ;
;
SUMMARY1 ; TaskMan start point
;
I 'QUEUED W !,"Sorting patients within ward..." ;
K ^TMP("EHMDISCH",$J),^TMP("EHMDISCH",$J+.1) ;
;
D BLDLIST("WARD","A",,QUEUED) ;
U IO ;
S INSTUTN="" ;
F S INSTUTN=$O(^TMP("EHMDISCH",$J,INSTUTN)) Q:INSTUTN="" D ;
. S INSTNAME=$P(INSTUTN,U,1),IEN=$P(INSTUTN,U,2),STATION=$$GET1^DIQ(4,IEN,99) ;
. S WARD="" F S WARD=$O(^TMP("EHMDISCH",$J,INSTUTN,WARD)) Q:WARD="" D ;
.. S PTNAME="" ;
.. F S PTNAME=$O(^TMP("EHMDISCH",$J,INSTUTN,WARD,PTNAME)) Q:PTNAME="" S DFN=0 F S DFN=$O(^TMP("EHMDISCH",$J,INSTUTN,WARD,PTNAME,DFN)) Q:'DFN S ^(WARD)=$G(^TMP("EHMDISCH",$J+.1,INSTUTN,WARD))+1 ;
;
W @IOF,$$CENTER("Summary of Patients to be Discharged",IOM),?IOM-8,$$FMTE^XLFDT(DT,2),!! ;
W "INSTITUTION",?42,"WARD",?74,"COUNT",!,$$DASHES(40),?42,$$DASHES(30),?74,$$DASHES(6),! ;
S INSTUTN="",TOTAL2=0 ;
F S INSTUTN=$O(^TMP("EHMDISCH",$J+.1,INSTUTN)) Q:INSTUTN="" D ;
. S INSTNAME=$P(INSTUTN,U,1),IEN=$P(INSTUTN,U,2),STATION=$$GET1^DIQ(4,IEN,99) ;
. W INSTNAME," (",STATION,")" ;
. S WARD="",TOTAL1=0 F S WARD=$O(^TMP("EHMDISCH",$J+.1,INSTUTN,WARD)) Q:WARD="" W ?42,WARD,?74,$J(^(WARD),6),! S TOTAL1=TOTAL1+^(WARD) ;
. W ?42,$$DASHES(30),?74,$$DASHES(6),! ;
. W ?42,"TOTAL",?74,$J(TOTAL1,6),!! S TOTAL2=TOTAL2+TOTAL1 ;
W ?42,"GRAND TOTAL",?74,$J(TOTAL2,6),! ;
;
U 0 I 'QUEUED,IO=$I R !,"Press [RETURN] to continue",X:$G(DTIME,300) ;
K ^TMP("EHMDISCH",$J),^TMP("EHMDISCH",$J+.1) D ^%ZISC ;
;
Q ;
;
DISCHARGE ;
;
; Discharge eligible patients. To be used at time of conversion to Millennium.
;
N DSCWARD,DFN,VADM,FIRST,PTNAME,SORTBY,INSTFLTR,INSTUTN,IEN,INSTNAME,ADMDTTM,QUEUED,LINES,QUIT,STATION,POP,ROOMBED,WARDFLTR ;
;
W !!,"*** This option automatically discharges eligible patients and processes all downstream discharge protocols. ***",! ;
I $$CONTINUE("NO")'=1 Q ;
;
S INSTFLTR=$$INSTFLTR() Q:INSTFLTR="" ;
S WARDFLTR="" I $P(INSTFLTR,U,1)="S" S WARDFLTR=$$WARDFLTR($P(INSTFLTR,U,2)) ;
;
D BLDLIST("WARD",INSTFLTR,WARDFLTR,0) W ! ;
;
S INSTUTN="" F S INSTUTN=$O(^TMP("EHMDISCH",$J,INSTUTN)) Q:INSTUTN="" D ;
. S INSTNAME=$P(INSTUTN,U,1),IEN=$P(INSTUTN,U,2),STATION=$$GET1^DIQ(4,IEN,99) W !,"INSTITUTION (STA): ",INSTNAME," (",STATION,")",! ;
. S DSCWARD="" F S DSCWARD=$O(^TMP("EHMDISCH",$J,INSTUTN,DSCWARD)) Q:DSCWARD="" D ;
.. S PTNAME="" W $$DASHES(80),!,DSCWARD ;
.. F S PTNAME=$O(^TMP("EHMDISCH",$J,INSTUTN,DSCWARD,PTNAME)) Q:PTNAME="" S DFN=0 F S DFN=$O(^TMP("EHMDISCH",$J,INSTUTN,DSCWARD,PTNAME,DFN)) Q:'DFN S ROOMBED=$P(^(DFN),U,2),ADMDTTM=$P(^(DFN),U,3) D ;
... ;
... W PTNAME,?32,$$DATETIME(ADMDTTM),?52,ROOMBED,! D ENTRY^EHMDGPMV(DFN) W !,$$DASHES(80),! ;
... ;
... ; Mark incomplete record.
... ;
... D IRT(DFN,ADMDTTM) ;
;
K ^TMP("EHMDISCH",$J) ;
;
Q ;
;
BLDLIST(SORTBY,INSTFLTR,WARDFLTR,QUEUED) ;
;
; Build sorted list of patients to be discharged in ^TMP("EHMDISCH",$J).
;
; INSTFLTR = "A" if all institutions are included or "S^ien" if a single institution included. "ien" points to file #4.
; SORTBY = "WARD" or "PATIENT"
; QUEUED = 1 if report is queued, 0 otherwise.
;
N WARD,IEN,INSTUTN,INSTNAME,DFN,ADMPTR,VADM,VAIN,VAIP,IDX,TRANSFER,WARDTO ;
;
K ^TMP("EHMDISCH",$J) S WARD="" F S WARD=$O(^DPT("CN",WARD)) Q:WARD="" D ;
. I $G(WARDFLTR)'="" Q:$P(^SC(WARDFLTR,0),U,1)'=WARD ;
. S IEN=$O(^SC("B",WARD,0)) Q:'IEN S INSTUTN=$P($G(^SC(IEN,0)),U,4) Q:'INSTUTN I $P(INSTFLTR,U,1)="S" Q:$P(INSTFLTR,U,2)'=INSTUTN ;
. S INSTNAME=$P(^DIC(4,INSTUTN,0),U,1) ;
. W:'QUEUED "." S DFN=0 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN S ADMPTR=^(DFN) D ;
.. ;
.. K VADM D DEM^VADPT ;
.. K VAIN D INP^VADPT ;
.. K VAIP D IN5^VADPT ;
.. ;
.. ; Patient movement pointer (#405) ^ Room/Bed ^ Admission Date/Time ^ Admitting Diagnosis ^ Attending Provider's Name
.. ;
.. I SORTBY="WARD" S ^TMP("EHMDISCH",$J,INSTNAME_U_INSTUTN,WARD,VADM(1),DFN)=ADMPTR_U_VAIN(5)_U_$P(VAIN(7),U,1)_U_VAIN(9)_U_$P(VAIN(11),U,2) D Q ;
... ;
... ; Transfers
... ;
... F IDX=13:1:17 Q:VAIP(IDX,1)="" S ^TMP("EHMDISCH",$J,INSTNAME_U_INSTUTN,WARD,VADM(1),DFN,$P(VAIP(IDX,1),U,1))=$P(VAIP(IDX,2),U,2)_U_$P(VAIP(IDX,4),U,2)_U_VAIP(9) ;
.. ;
.. ; Patient movement pointer (#405) ^ Ward ^ Room/Bed ^ Admission Date/Time ^ Admitting Diagnosis ^ Attending Provider's Name
.. ;
.. I SORTBY="PATIENT" S ^TMP("EHMDISCH",$J,INSTNAME_U_INSTUTN,VADM(1),DFN)=ADMPTR_U_WARD_U_VAIN(5)_U_$P(VAIN(7),U,1)_U_VAIN(9)_U_$P(VAIN(11),U,2) D Q ;
... ;
... ; Transfers
... ;
... F IDX=13:1:17 Q:VAIP(IDX,1)="" S ^TMP("EHMDISCH",$J,INSTNAME_U_INSTUTN,VADM(1),DFN,$P(VAIP(IDX,1),U,1))=$P(VAIP(IDX,2),U,2)_U_$P(VAIP(IDX,4),U,2)_U_VAIP(9) ;
Q ;
;
POSTLIST ;
;
; List patients discharged at conversion. To be used at time of or after conversion to Millennium.
;
N DFN,VADM,PTNAME,DSCDTTM,QUEUED,POP,X,LINES,QUIT ;
;
;
W !,"Report is 80 columns wide",! ;
S %ZIS="Q" D ^%ZIS I POP Q ;
;
; If report is queued, add to Taskman
;
S QUEUED=0 I $D(IO("Q")) S QUEUED=1 D Q ;
. N ZTDESC,ZTRTN,ZTSAVE,ZTSK ;
. S ZTRTN="POSTLIST1^EHMDISCH",ZTDESC="Patients Discharged at Conversion List" ;
. S ZTSAVE("*")="" ;
. D ^%ZTLOAD W $S($D(ZTSK):"...Task queued",1:"...Task cancelled"),! ;
;
POSTLIST1 ; TaskMan start point
;
K ^TMP("EHMDISCH",$J) S DSCDTTM="" F S DSCDTTM=$O(^DPT("ACERNER",DSCDTTM)) Q:'DSCDTTM S DFN=0 F S DFN=$O(^DPT("ACERNER",DSCDTTM,DFN)) Q:'DFN D ;
. W:'QUEUED "." ;
. ;
. K VADM D DEM^VADPT ;
. S ^TMP("EHMDISCH",$J,VADM(1),DFN)=DSCDTTM ;
;
U IO ;
;
D POSTHDR ;
S PTNAME="",QUIT=0,LINES=0 F S PTNAME=$O(^TMP("EHMDISCH",$J,PTNAME)) Q:PTNAME="" D Q:QUIT ;
. S DFN=0 F S DFN=$O(^TMP("EHMDISCH",$J,PTNAME,DFN)) Q:'DFN S DSCDTTM=^(DFN) D Q:QUIT ;
.. ;
.. ; If report displayed on screen, stop when screen full and prompt user to continue or stop.
.. ;
.. U 0 ;
.. I IO=$I,LINES'<(IOSL-7) S QUIT=$$CONTINUE()=0 Q:QUIT U IO D POSTHDR S LINES=1 ;
.. ;
.. ; New page header for printed report
.. ;
.. I LINES'<IOSL U IO D POSTHDR S LINES=1 ;
.. ;
.. U IO W PTNAME,?32,$$DATETIME(DSCDTTM),! S LINES=LINES+1 ;
;
I QUIT W ! ;
U 0 I 'QUEUED,IO=$I R !,"Press [RETURN] to continue",X:$G(DTIME,300) ;
K ^TMP("EHMDISCH",$J) D ^%ZISC ;
Q ;
;
POSTHDR ;
;
W @IOF,$$CENTER("Patients Discharged at Conversion",IOM),?IOM-8,$$FMTE^XLFDT(DT,2),! ;
W !,"Patient Name",?32,"Date/Time Discharged",!,$$DASHES(30),?32,$$DASHES(20),! ;
Q ;
;
PAGINATE(QUIT,INSTNAME,STATION,SORTBY,LINES) ;
;
; If report displayed on screen, stop when screen full and prompt user to continue or stop.
;
U 0 ;
I IO=$I Q:LINES<(IOSL-7) S QUIT=$$CONTINUE()=0 Q:QUIT U IO D HEADER(INSTNAME,STATION,SORTBY) S LINES=1 Q ;
;
; New page header for printed report
;
I LINES'<IOSL U IO D HEADER(INSTNAME,STATION,SORTBY) S LINES=1 ;
Q ;
;
CENTER(TEXT,WIDTH) ;
;
; Return centered text.
;
N CENTERED ;
S CENTERED=$J("",WIDTH-$L(TEXT)/2)_TEXT ;
Q CENTERED ;
;
DASHES(COUNT) ;
;
N I,DASHES S DASHES="" F I=1:1:COUNT S DASHES=DASHES_"-" ;
Q DASHES ;
;
CONTINUE(DEFAULT) ;
;
; Prompt user to continue or quit.
;
; DEFAULT - Default answer (YES or NO) - optional. YES assumed.
;
N DIR,Y,DIRUT,X,Y ;
S DIR(0)="Y",DIR("A")="Continue",DIR("B")=$S($G(DEFAULT)'="":DEFAULT,1:"YES") D ^DIR ;
I $D(DIRUT) Q 0 ;
Q Y ;
;
DATETIME(X) ;
;
; Returns date and time in HH/MM/YY HH:MM format (zero-filled if required)
;
N DATE,TIME,I,PC,HH,MM ;
S DATE=$P(X,".",1),TIME=$P(X,".",2)_"0000" ;
S DATE=$$FMTE^XLFDT(DATE,2) F I=1:1:3 S PC=$P(DATE,"/",I) S:PC<10 PC="0"_(+PC) S $P(DATE,"/",I)=PC ;
S HH=$E(TIME,1,2),MM=$E(TIME,3,4),TIME=HH_":"_MM ;
Q DATE_" "_TIME ;
;
INSTFLTR() ;
;
; Enter institution filter.
;
N DIR,DIC,X,Y,INSTFLTR ;
;
S DIR(0)="SO^A:All;S:Selected",DIR("A")="Institutions",DIR("B")="All" D ^DIR Q:$D(DIRUT) "" S INSTFLTR=Y ;
;
I INSTFLTR="S" D ;
. ;
. ; Select institution to include.
. ;
. K DIC S DIC=4,DIC(0)="AEQM",DIC("A")="Institution: ",DIC("S")="I $$INSTSCRN^EHMDISCH(Y)" D ^DIC ;
. ;K DIC S DIC=4,DIC(0)="AEQM",DIC("A")="Institution: ",DIC("S")="I 1" D ^DIC ;
. I $D(DIRUT) S INSTFLTR="" Q ;
. I Y=-1 S INSTFLTR="" Q ;
. S INSTFLTR="S^"_Y ;
;
Q INSTFLTR ;
;
INSTSCRN(IEN4) ;
;
; Screen institutions for the VistA instance only.
;
I $$GET1^DIQ(4,IEN4,99)=$P($$SITE^VASITE(),U,3) Q 1 ;
;
N IEN1,OK,IEN S OK=0,IEN1=0 ;
F S IEN1=$O(^DIC(4,IEN4,7,IEN1)) Q:'IEN1 I $P($G(^(IEN1,0)),U,1)=2 S IEN=$P(^(0),U,2) I IEN,$$GET1^DIQ(4,IEN,99)=$P($$SITE^VASITE(),U,3) S OK=1 Q ;
;
Q OK ;
;
WARDFLTR(INSTUTN) ;
;
; Enter ward filter
;
N DIC,X,Y,WARDFLTR ;
;
S DIC=44,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)=INSTUTN,$P(^(0),U,3)=""W""" D ^DIC S WARDFLTR=+Y ;
I WARDFLTR<0 S WARDFLTR="" ;
Q WARDFLTR ;
;
IRT(DFN,ADMDTTM) ;
;
; Mark INCOMPLETE RECORDS (file #393) entries COMPLETED for a patient being discharged.
;
; Note: Should be only one discharge summary entry in #393 per admission.
;
N IEN,PTMVMT,TYPE,DIE,DR,DA ;
;
S IEN=0 F I=1:1 S IEN=$O(^VAS(393,"B",DFN,IEN)) Q:'IEN S PTMVMT=$P($G(^VAS(393,IEN,0)),U,4),TYPE=$P($G(^VAS(393,IEN,0)),U,2) D ;
. Q:'PTMVMT Q:$$GET1^DIQ(405,PTMVMT,.01,"I")'=ADMDTTM ;
. Q:'TYPE Q:$$GET1^DIQ(393,IEN,.02)'="DISCHARGE SUMMARY" ;
. ;
. ; Mark COMPLETED
. ;
. K DIE,DR S DA=IEN,DR=".11////COMPLETED",DIE=^DIC(393,0,"GL") D ^DIE ;
;
Q ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEHMDISCH 14709 printed Jul 11, 2026@01:48:11 Page 2
EHMDISCH ;ALB/WTC - EHRM - AUTOMATED PATIENT DISCHARGE TOOL; Jun 06, 2025@13:23:13
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**15**;Apr 19, 2021;Build 14
+2 ;
+3 ;
+4 ;
QUIT
+5 ;
LIST ;
+1 ;
+2 ; List patients eligible for discharge. To be used at time of conversion to Millennium.
+3 ;
+4 ;
NEW WARD,DFN,VADM,FIRST,PTNAME,SORTBY,INSTFLTR,DIR,Y,X,INSTUTN,IEN,INSTNAME,QUEUED,LINES,QUIT,STATION,POP,TXDTTM,NEWWARD,INCLHIST,WARDFLTR
+5 ;
+6 ;
SET INSTFLTR=$$INSTFLTR()
if INSTFLTR=""
QUIT
+7 ;
SET WARDFLTR=""
IF $PIECE(INSTFLTR,U,1)="S"
SET WARDFLTR=$$WARDFLTR($PIECE(INSTFLTR,U,2))
+8 ;
+9 ;
SET DIR(0)="S^WARD:Ward;PATIENT:Patient"
SET DIR("A")="Sort by"
DO ^DIR
if $DATA(DIRUT)
QUIT
SET SORTBY=Y
+10 ;
+11 ;
KILL DIR
+12 ;
SET DIR(0)="Y"
SET DIR("A")="Include transfer history"
SET DIR("B")="NO"
DO ^DIR
if $DATA(DIRUT)
QUIT
SET INCLHIST=Y
+13 ;
+14 ;
WRITE !!,"Report is 160 columns wide",!
+15 ;
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
+16 ;
+17 ; If report is queued, add to Taskman
+18 ;
+19 ;
SET QUEUED=0
IF $DATA(IO("Q"))
SET QUEUED=1
Begin DoDot:1
+20 ;
NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
+21 ;
SET ZTRTN="LIST1^EHMDISCH"
SET ZTDESC="Patient Discharge List"
+22 ;
SET ZTSAVE("*")=""
+23 ;
DO ^%ZTLOAD
WRITE $SELECT($DATA(ZTSK):"...Task queued",1:"...Task cancelled"),!
End DoDot:1
QUIT
+24 ;
LIST1 ; TaskMan start point
+1 ;
+2 ;
IF 'QUEUED
IF SORTBY="WARD"
WRITE !,"Sorting patients within ward..."
+3 ;
IF 'QUEUED
IF SORTBY="PATIENT"
WRITE !,"Sorting patients..."
+4 ;
KILL ^TMP("EHMDISCH",$JOB)
+5 ;
+6 ;
DO BLDLIST(SORTBY,INSTFLTR,WARDFLTR,QUEUED)
+7 ;
USE IO
+8 ;
+9 ;
IF SORTBY="WARD"
Begin DoDot:1
+10 ;
SET INSTUTN=""
SET QUIT=0
FOR
SET INSTUTN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN))
if INSTUTN=""
QUIT
Begin DoDot:2
+11 ;
SET INSTNAME=$PIECE(INSTUTN,U,1)
SET IEN=$PIECE(INSTUTN,U,2)
SET STATION=$$GET1^DIQ(4,IEN,99)
DO HEADER(INSTNAME,STATION,SORTBY)
+12 ;
SET WARD=""
SET LINES=0
FOR
SET WARD=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,WARD))
if WARD=""
QUIT
Begin DoDot:3
+13 ;
SET PTNAME=""
SET FIRST=1
+14 ;
FOR
SET PTNAME=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,WARD,PTNAME))
if PTNAME=""
QUIT
if QUIT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,WARD,PTNAME,DFN))
if 'DFN
QUIT
SET X=^(DFN)
Begin DoDot:4
+15 ;
+16 ;
IF 'QUEUED
DO PAGINATE(.QUIT,INSTNAME,STATION,SORTBY,.LINES)
if QUIT
QUIT
+17 ;
+18 ;
WRITE $SELECT(FIRST:WARD,1:""),?32,PTNAME,?64,$$DATETIME($PIECE(X,U,3)),?81,$PIECE(X,U,2),?91,$PIECE(X,U,4),?123,$PIECE(X,U,5),!
SET LINES=LINES+1
+19 ;
if 'INCLHIST
QUIT
+20 ;
+21 ; Transfers
+22 ;
+23 ; No transfers
if $DATA(^TMP("EHMDISCH",$JOB,INSTUTN,WARD,PTNAME,DFN))<10
QUIT
+24 ;
+25 ;
SET TXDTTM=0
FOR
SET TXDTTM=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,WARD,PTNAME,DFN,TXDTTM))
if 'TXDTTM
QUIT
SET X=^(TXDTTM)
WRITE ?10,$PIECE(X,U,1),?25,$$DATETIME(TXDTTM),?42,$PIECE(X,U,2),?74,$PIECE(X,U,3),!
SET LINES=LINES+1
+26 ;
WRITE !
SET LINES=LINES+1
End DoDot:4
SET FIRST=0
if QUIT
QUIT
+27 ;
WRITE !
End DoDot:3
if QUIT
QUIT
+28 ;
+29 ;
IF 'QUEUED
IF 'QUIT
SET QUIT=$$CONTINUE()=0
End DoDot:2
if QUIT
QUIT
End DoDot:1
+30 ;
+31 ;
IF SORTBY="PATIENT"
Begin DoDot:1
+32 ;
SET INSTUTN=""
SET QUIT=0
FOR
SET INSTUTN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN))
if INSTUTN=""
QUIT
Begin DoDot:2
+33 ;
SET INSTNAME=$PIECE(INSTUTN,U,1)
SET IEN=$PIECE(INSTUTN,U,2)
SET STATION=$$GET1^DIQ(4,IEN,99)
DO HEADER(INSTNAME,STATION,SORTBY)
+34 ;
SET PTNAME=""
SET FIRST=""
SET LINES=0
FOR
SET PTNAME=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,PTNAME))
if PTNAME=""
QUIT
Begin DoDot:3
+35 ;
IF FIRST'=$EXTRACT(PTNAME,1)
WRITE !
SET LINES=LINES+1
+36 ;
SET FIRST=$EXTRACT(PTNAME,1)
+37 ;
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,PTNAME,DFN))
if 'DFN
QUIT
SET X=^(DFN)
Begin DoDot:4
+38 ;
+39 ;
IF 'QUEUED
DO PAGINATE(.QUIT,INSTNAME,STATION,SORTBY,.LINES)
if QUIT
QUIT
+40 ;
+41 ;
WRITE PTNAME,?32,$PIECE(X,U,2),?64,$$DATETIME($PIECE(X,U,4)),?81,$PIECE(X,U,3),?91,$PIECE(X,U,5),?123,$PIECE(X,U,6),!
SET LINES=LINES+1
+42 ;
if 'INCLHIST
QUIT
+43 ;
+44 ; Transfers
+45 ;
+46 ; No transfers
if $DATA(^TMP("EHMDISCH",$JOB,INSTUTN,PTNAME,DFN))<10
QUIT
+47 ;
+48 ;
SET TXDTTM=0
FOR
SET TXDTTM=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,PTNAME,DFN,TXDTTM))
if 'TXDTTM
QUIT
SET X=^(TXDTTM)
WRITE ?10,$PIECE(X,U,1),?25,$$DATETIME(TXDTTM),?42,$PIECE(X,U,2),?74,$PIECE(X,U,3),!
SET LINES=LINES+1
+49 ;
WRITE !
SET LINES=LINES+1
End DoDot:4
if QUIT
QUIT
End DoDot:3
if QUIT
QUIT
+50 ;
+51 ;
IF 'QUEUED
IF 'QUIT
SET QUIT=$$CONTINUE()=0
End DoDot:2
if QUIT
QUIT
End DoDot:1
+52 ;
+53 ;
IF QUIT
WRITE !
+54 ;
USE 0
IF 'QUEUED
IF IO=$IO
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
+55 ;
KILL ^TMP("EHMDISCH",$JOB)
DO ^%ZISC
+56 ;
QUIT
+57 ;
+1 ;
+2 ;
WRITE @IOF,$$CENTER("Patient Discharge List - "_INSTNAME_" ("_STATION_")",IOM),?IOM-8,$$FMTE^XLFDT(DT,2),!!
+3 ;
IF SORTBY="WARD"
Begin DoDot:1
+4 ;
WRITE "WARD",?32,"PATIENT",?64,"ADMIT DATE/TIME",?81,"ROOM/BED",?91,"DIAGNOSIS",?123,"ATTENDING PROVIDER",!
+5 ;
WRITE $$DASHES(30),?32,$$DASHES(30),?64,$$DASHES(15),?81,$$DASHES(8),?91,$$DASHES(30),?123,$$DASHES(30),!
End DoDot:1
+6 ;
+7 ;
IF SORTBY="PATIENT"
Begin DoDot:1
+8 ;
WRITE "PATIENT",?32,"WARD",?64,"ADMIT DATE/TIME",?81,"ROOM/BED",?91,"DIAGNOSIS",?123,"ATTENDING PROVIDER",!
+9 ;
WRITE $$DASHES(30),?32,$$DASHES(30),?64,$$DASHES(15),?81,$$DASHES(8),?91,$$DASHES(30),?123,$$DASHES(30),!
End DoDot:1
+10 ;
QUIT
+11 ;
SUMMARY ;
+1 ;
+2 ; Summary of patients eligible for discharge. To be used at time of conversion to Millennium.
+3 ;
+4 ;
NEW WARD,DFN,VADM,FIRST,PTNAME,INSTUTN,IEN,INSTNAME,ADMDTTM,QUEUED,LINES,QUIT,STATION,POP,TOTAL1,TOTAL2
+5 ;
+6 ;
WRITE !,"Report is 80 columns wide",!
+7 ;
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
+8 ;
+9 ; If report is queued, add to Taskman
+10 ;
+11 ;
SET QUEUED=0
IF $DATA(IO("Q"))
SET QUEUED=1
Begin DoDot:1
+12 ;
NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
+13 ;
SET ZTRTN="SUMMARY1^EHMDISCH"
SET ZTDESC="Summary of Patients to be Discharged"
+14 ;
SET ZTSAVE("*")=""
+15 ;
DO ^%ZTLOAD
WRITE $SELECT($DATA(ZTSK):"...Task queued",1:"...Task cancelled"),!
End DoDot:1
QUIT
+16 ;
SUMMARY1 ; TaskMan start point
+1 ;
+2 ;
IF 'QUEUED
WRITE !,"Sorting patients within ward..."
+3 ;
KILL ^TMP("EHMDISCH",$JOB),^TMP("EHMDISCH",$JOB+.1)
+4 ;
+5 ;
DO BLDLIST("WARD","A",,QUEUED)
+6 ;
USE IO
+7 ;
SET INSTUTN=""
+8 ;
FOR
SET INSTUTN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN))
if INSTUTN=""
QUIT
Begin DoDot:1
+9 ;
SET INSTNAME=$PIECE(INSTUTN,U,1)
SET IEN=$PIECE(INSTUTN,U,2)
SET STATION=$$GET1^DIQ(4,IEN,99)
+10 ;
SET WARD=""
FOR
SET WARD=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,WARD))
if WARD=""
QUIT
Begin DoDot:2
+11 ;
SET PTNAME=""
+12 ;
FOR
SET PTNAME=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,WARD,PTNAME))
if PTNAME=""
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,WARD,PTNAME,DFN))
if 'DFN
QUIT
SET ^(WARD)=$GET(^TMP("EHMDISCH",$JOB+.1,INSTUTN,WARD))+1
End DoDot:2
End DoDot:1
+13 ;
+14 ;
WRITE @IOF,$$CENTER("Summary of Patients to be Discharged",IOM),?IOM-8,$$FMTE^XLFDT(DT,2),!!
+15 ;
WRITE "INSTITUTION",?42,"WARD",?74,"COUNT",!,$$DASHES(40),?42,$$DASHES(30),?74,$$DASHES(6),!
+16 ;
SET INSTUTN=""
SET TOTAL2=0
+17 ;
FOR
SET INSTUTN=$ORDER(^TMP("EHMDISCH",$JOB+.1,INSTUTN))
if INSTUTN=""
QUIT
Begin DoDot:1
+18 ;
SET INSTNAME=$PIECE(INSTUTN,U,1)
SET IEN=$PIECE(INSTUTN,U,2)
SET STATION=$$GET1^DIQ(4,IEN,99)
+19 ;
WRITE INSTNAME," (",STATION,")"
+20 ;
SET WARD=""
SET TOTAL1=0
FOR
SET WARD=$ORDER(^TMP("EHMDISCH",$JOB+.1,INSTUTN,WARD))
if WARD=""
QUIT
WRITE ?42,WARD,?74,$JUSTIFY(^(WARD),6),!
SET TOTAL1=TOTAL1+^(WARD)
+21 ;
WRITE ?42,$$DASHES(30),?74,$$DASHES(6),!
+22 ;
WRITE ?42,"TOTAL",?74,$JUSTIFY(TOTAL1,6),!!
SET TOTAL2=TOTAL2+TOTAL1
End DoDot:1
+23 ;
WRITE ?42,"GRAND TOTAL",?74,$JUSTIFY(TOTAL2,6),!
+24 ;
+25 ;
USE 0
IF 'QUEUED
IF IO=$IO
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
+26 ;
KILL ^TMP("EHMDISCH",$JOB),^TMP("EHMDISCH",$JOB+.1)
DO ^%ZISC
+27 ;
+28 ;
QUIT
+29 ;
DISCHARGE ;
+1 ;
+2 ; Discharge eligible patients. To be used at time of conversion to Millennium.
+3 ;
+4 ;
NEW DSCWARD,DFN,VADM,FIRST,PTNAME,SORTBY,INSTFLTR,INSTUTN,IEN,INSTNAME,ADMDTTM,QUEUED,LINES,QUIT,STATION,POP,ROOMBED,WARDFLTR
+5 ;
+6 ;
WRITE !!,"*** This option automatically discharges eligible patients and processes all downstream discharge protocols. ***",!
+7 ;
IF $$CONTINUE("NO")'=1
QUIT
+8 ;
+9 ;
SET INSTFLTR=$$INSTFLTR()
if INSTFLTR=""
QUIT
+10 ;
SET WARDFLTR=""
IF $PIECE(INSTFLTR,U,1)="S"
SET WARDFLTR=$$WARDFLTR($PIECE(INSTFLTR,U,2))
+11 ;
+12 ;
DO BLDLIST("WARD",INSTFLTR,WARDFLTR,0)
WRITE !
+13 ;
+14 ;
SET INSTUTN=""
FOR
SET INSTUTN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN))
if INSTUTN=""
QUIT
Begin DoDot:1
+15 ;
SET INSTNAME=$PIECE(INSTUTN,U,1)
SET IEN=$PIECE(INSTUTN,U,2)
SET STATION=$$GET1^DIQ(4,IEN,99)
WRITE !,"INSTITUTION (STA): ",INSTNAME," (",STATION,")",!
+16 ;
SET DSCWARD=""
FOR
SET DSCWARD=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,DSCWARD))
if DSCWARD=""
QUIT
Begin DoDot:2
+17 ;
SET PTNAME=""
WRITE $$DASHES(80),!,DSCWARD
+18 ;
FOR
SET PTNAME=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,DSCWARD,PTNAME))
if PTNAME=""
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("EHMDISCH",$JOB,INSTUTN,DSCWARD,PTNAME,DFN))
if 'DFN
QUIT
SET ROOMBED=$PIECE(^(DFN),U,2)
SET ADMDTTM=$PIECE(^(DFN),U,3)
Begin DoDot:3
+19 ;
+20 ;
WRITE PTNAME,?32,$$DATETIME(ADMDTTM),?52,ROOMBED,!
DO ENTRY^EHMDGPMV(DFN)
WRITE !,$$DASHES(80),!
+21 ;
+22 ; Mark incomplete record.
+23 ;
+24 ;
DO IRT(DFN,ADMDTTM)
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;
+26 ;
KILL ^TMP("EHMDISCH",$JOB)
+27 ;
+28 ;
QUIT
+29 ;
BLDLIST(SORTBY,INSTFLTR,WARDFLTR,QUEUED) ;
+1 ;
+2 ; Build sorted list of patients to be discharged in ^TMP("EHMDISCH",$J).
+3 ;
+4 ; INSTFLTR = "A" if all institutions are included or "S^ien" if a single institution included. "ien" points to file #4.
+5 ; SORTBY = "WARD" or "PATIENT"
+6 ; QUEUED = 1 if report is queued, 0 otherwise.
+7 ;
+8 ;
NEW WARD,IEN,INSTUTN,INSTNAME,DFN,ADMPTR,VADM,VAIN,VAIP,IDX,TRANSFER,WARDTO
+9 ;
+10 ;
KILL ^TMP("EHMDISCH",$JOB)
SET WARD=""
FOR
SET WARD=$ORDER(^DPT("CN",WARD))
if WARD=""
QUIT
Begin DoDot:1
+11 ;
IF $GET(WARDFLTR)'=""
if $PIECE(^SC(WARDFLTR,0),U,1)'=WARD
QUIT
+12 ;
SET IEN=$ORDER(^SC("B",WARD,0))
if 'IEN
QUIT
SET INSTUTN=$PIECE($GET(^SC(IEN,0)),U,4)
if 'INSTUTN
QUIT
IF $PIECE(INSTFLTR,U,1)="S"
if $PIECE(INSTFLTR,U,2)'=INSTUTN
QUIT
+13 ;
SET INSTNAME=$PIECE(^DIC(4,INSTUTN,0),U,1)
+14 ;
if 'QUEUED
WRITE "."
SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
if 'DFN
QUIT
SET ADMPTR=^(DFN)
Begin DoDot:2
+15 ;
+16 ;
KILL VADM
DO DEM^VADPT
+17 ;
KILL VAIN
DO INP^VADPT
+18 ;
KILL VAIP
DO IN5^VADPT
+19 ;
+20 ; Patient movement pointer (#405) ^ Room/Bed ^ Admission Date/Time ^ Admitting Diagnosis ^ Attending Provider's Name
+21 ;
+22 ;
IF SORTBY="WARD"
SET ^TMP("EHMDISCH",$JOB,INSTNAME_U_INSTUTN,WARD,VADM(1),DFN)=ADMPTR_U_VAIN(5)_U_$PIECE(VAIN(7),U,1)_U_VAIN(9)_U_$PIECE(VAIN(11),U,2)
Begin DoDot:3
+23 ;
+24 ; Transfers
+25 ;
+26 ;
FOR IDX=13:1:17
if VAIP(IDX,1)=""
QUIT
SET ^TMP("EHMDISCH",$JOB,INSTNAME_U_INSTUTN,WARD,VADM(1),DFN,$PIECE(VAIP(IDX,1),U,1))=$PIECE(VAIP(IDX,2),U,2)_U_$PIECE(VAIP(IDX,4),U,2)_U_VAIP(9)
End DoDot:3
QUIT
+27 ;
+28 ; Patient movement pointer (#405) ^ Ward ^ Room/Bed ^ Admission Date/Time ^ Admitting Diagnosis ^ Attending Provider's Name
+29 ;
+30 ;
IF SORTBY="PATIENT"
SET ^TMP("EHMDISCH",$JOB,INSTNAME_U_INSTUTN,VADM(1),DFN)=ADMPTR_U_WARD_U_VAIN(5)_U_$PIECE(VAIN(7),U,1)_U_VAIN(9)_U_$PIECE(VAIN(11),U,2)
Begin DoDot:3
+31 ;
+32 ; Transfers
+33 ;
+34 ;
FOR IDX=13:1:17
if VAIP(IDX,1)=""
QUIT
SET ^TMP("EHMDISCH",$JOB,INSTNAME_U_INSTUTN,VADM(1),DFN,$PIECE(VAIP(IDX,1),U,1))=$PIECE(VAIP(IDX,2),U,2)_U_$PIECE(VAIP(IDX,4),U,2)_U_VAIP(9)
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+35 ;
QUIT
+36 ;
POSTLIST ;
+1 ;
+2 ; List patients discharged at conversion. To be used at time of or after conversion to Millennium.
+3 ;
+4 ;
NEW DFN,VADM,PTNAME,DSCDTTM,QUEUED,POP,X,LINES,QUIT
+5 ;
+6 ;
+7 ;
WRITE !,"Report is 80 columns wide",!
+8 ;
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
+9 ;
+10 ; If report is queued, add to Taskman
+11 ;
+12 ;
SET QUEUED=0
IF $DATA(IO("Q"))
SET QUEUED=1
Begin DoDot:1
+13 ;
NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
+14 ;
SET ZTRTN="POSTLIST1^EHMDISCH"
SET ZTDESC="Patients Discharged at Conversion List"
+15 ;
SET ZTSAVE("*")=""
+16 ;
DO ^%ZTLOAD
WRITE $SELECT($DATA(ZTSK):"...Task queued",1:"...Task cancelled"),!
End DoDot:1
QUIT
+17 ;
POSTLIST1 ; TaskMan start point
+1 ;
+2 ;
KILL ^TMP("EHMDISCH",$JOB)
SET DSCDTTM=""
FOR
SET DSCDTTM=$ORDER(^DPT("ACERNER",DSCDTTM))
if 'DSCDTTM
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^DPT("ACERNER",DSCDTTM,DFN))
if 'DFN
QUIT
Begin DoDot:1
+3 ;
if 'QUEUED
WRITE "."
+4 ;
+5 ;
KILL VADM
DO DEM^VADPT
+6 ;
SET ^TMP("EHMDISCH",$JOB,VADM(1),DFN)=DSCDTTM
End DoDot:1
+7 ;
+8 ;
USE IO
+9 ;
+10 ;
DO POSTHDR
+11 ;
SET PTNAME=""
SET QUIT=0
SET LINES=0
FOR
SET PTNAME=$ORDER(^TMP("EHMDISCH",$JOB,PTNAME))
if PTNAME=""
QUIT
Begin DoDot:1
+12 ;
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("EHMDISCH",$JOB,PTNAME,DFN))
if 'DFN
QUIT
SET DSCDTTM=^(DFN)
Begin DoDot:2
+13 ;
+14 ; If report displayed on screen, stop when screen full and prompt user to continue or stop.
+15 ;
+16 ;
USE 0
+17 ;
IF IO=$IO
IF LINES'<(IOSL-7)
SET QUIT=$$CONTINUE()=0
if QUIT
QUIT
USE IO
DO POSTHDR
SET LINES=1
+18 ;
+19 ; New page header for printed report
+20 ;
+21 ;
IF LINES'<IOSL
USE IO
DO POSTHDR
SET LINES=1
+22 ;
+23 ;
USE IO
WRITE PTNAME,?32,$$DATETIME(DSCDTTM),!
SET LINES=LINES+1
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+24 ;
+25 ;
IF QUIT
WRITE !
+26 ;
USE 0
IF 'QUEUED
IF IO=$IO
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
+27 ;
KILL ^TMP("EHMDISCH",$JOB)
DO ^%ZISC
+28 ;
QUIT
+29 ;
POSTHDR ;
+1 ;
+2 ;
WRITE @IOF,$$CENTER("Patients Discharged at Conversion",IOM),?IOM-8,$$FMTE^XLFDT(DT,2),!
+3 ;
WRITE !,"Patient Name",?32,"Date/Time Discharged",!,$$DASHES(30),?32,$$DASHES(20),!
+4 ;
QUIT
+5 ;
PAGINATE(QUIT,INSTNAME,STATION,SORTBY,LINES) ;
+1 ;
+2 ; If report displayed on screen, stop when screen full and prompt user to continue or stop.
+3 ;
+4 ;
USE 0
+5 ;
IF IO=$IO
if LINES<(IOSL-7)
QUIT
SET QUIT=$$CONTINUE()=0
if QUIT
QUIT
USE IO
DO HEADER(INSTNAME,STATION,SORTBY)
SET LINES=1
QUIT
+6 ;
+7 ; New page header for printed report
+8 ;
+9 ;
IF LINES'<IOSL
USE IO
DO HEADER(INSTNAME,STATION,SORTBY)
SET LINES=1
+10 ;
QUIT
+11 ;
CENTER(TEXT,WIDTH) ;
+1 ;
+2 ; Return centered text.
+3 ;
+4 ;
NEW CENTERED
+5 ;
SET CENTERED=$JUSTIFY("",WIDTH-$LENGTH(TEXT)/2)_TEXT
+6 ;
QUIT CENTERED
+7 ;
DASHES(COUNT) ;
+1 ;
+2 ;
NEW I,DASHES
SET DASHES=""
FOR I=1:1:COUNT
SET DASHES=DASHES_"-"
+3 ;
QUIT DASHES
+4 ;
CONTINUE(DEFAULT) ;
+1 ;
+2 ; Prompt user to continue or quit.
+3 ;
+4 ; DEFAULT - Default answer (YES or NO) - optional. YES assumed.
+5 ;
+6 ;
NEW DIR,Y,DIRUT,X,Y
+7 ;
SET DIR(0)="Y"
SET DIR("A")="Continue"
SET DIR("B")=$SELECT($GET(DEFAULT)'="":DEFAULT,1:"YES")
DO ^DIR
+8 ;
IF $DATA(DIRUT)
QUIT 0
+9 ;
QUIT Y
+10 ;
DATETIME(X) ;
+1 ;
+2 ; Returns date and time in HH/MM/YY HH:MM format (zero-filled if required)
+3 ;
+4 ;
NEW DATE,TIME,I,PC,HH,MM
+5 ;
SET DATE=$PIECE(X,".",1)
SET TIME=$PIECE(X,".",2)_"0000"
+6 ;
SET DATE=$$FMTE^XLFDT(DATE,2)
FOR I=1:1:3
SET PC=$PIECE(DATE,"/",I)
if PC<10
SET PC="0"_(+PC)
SET $PIECE(DATE,"/",I)=PC
+7 ;
SET HH=$EXTRACT(TIME,1,2)
SET MM=$EXTRACT(TIME,3,4)
SET TIME=HH_":"_MM
+8 ;
QUIT DATE_" "_TIME
+9 ;
INSTFLTR() ;
+1 ;
+2 ; Enter institution filter.
+3 ;
+4 ;
NEW DIR,DIC,X,Y,INSTFLTR
+5 ;
+6 ;
SET DIR(0)="SO^A:All;S:Selected"
SET DIR("A")="Institutions"
SET DIR("B")="All"
DO ^DIR
if $DATA(DIRUT)
QUIT ""
SET INSTFLTR=Y
+7 ;
+8 ;
IF INSTFLTR="S"
Begin DoDot:1
+9 ;
+10 ; Select institution to include.
+11 ;
+12 ;
KILL DIC
SET DIC=4
SET DIC(0)="AEQM"
SET DIC("A")="Institution: "
SET DIC("S")="I $$INSTSCRN^EHMDISCH(Y)"
DO ^DIC
+13 ;K DIC S DIC=4,DIC(0)="AEQM",DIC("A")="Institution: ",DIC("S")="I 1" D ^DIC ;
+14 ;
IF $DATA(DIRUT)
SET INSTFLTR=""
QUIT
+15 ;
IF Y=-1
SET INSTFLTR=""
QUIT
+16 ;
SET INSTFLTR="S^"_Y
End DoDot:1
+17 ;
+18 ;
QUIT INSTFLTR
+19 ;
INSTSCRN(IEN4) ;
+1 ;
+2 ; Screen institutions for the VistA instance only.
+3 ;
+4 ;
IF $$GET1^DIQ(4,IEN4,99)=$PIECE($$SITE^VASITE(),U,3)
QUIT 1
+5 ;
+6 ;
NEW IEN1,OK,IEN
SET OK=0
SET IEN1=0
+7 ;
FOR
SET IEN1=$ORDER(^DIC(4,IEN4,7,IEN1))
if 'IEN1
QUIT
IF $PIECE($GET(^(IEN1,0)),U,1)=2
SET IEN=$PIECE(^(0),U,2)
IF IEN
IF $$GET1^DIQ(4,IEN,99)=$PIECE($$SITE^VASITE(),U,3)
SET OK=1
QUIT
+8 ;
+9 ;
QUIT OK
+10 ;
WARDFLTR(INSTUTN) ;
+1 ;
+2 ; Enter ward filter
+3 ;
+4 ;
NEW DIC,X,Y,WARDFLTR
+5 ;
+6 ;
SET DIC=44
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,4)=INSTUTN,$P(^(0),U,3)=""W"""
DO ^DIC
SET WARDFLTR=+Y
+7 ;
IF WARDFLTR<0
SET WARDFLTR=""
+8 ;
QUIT WARDFLTR
+9 ;
IRT(DFN,ADMDTTM) ;
+1 ;
+2 ; Mark INCOMPLETE RECORDS (file #393) entries COMPLETED for a patient being discharged.
+3 ;
+4 ; Note: Should be only one discharge summary entry in #393 per admission.
+5 ;
+6 ;
NEW IEN,PTMVMT,TYPE,DIE,DR,DA
+7 ;
+8 ;
SET IEN=0
FOR I=1:1
SET IEN=$ORDER(^VAS(393,"B",DFN,IEN))
if 'IEN
QUIT
SET PTMVMT=$PIECE($GET(^VAS(393,IEN,0)),U,4)
SET TYPE=$PIECE($GET(^VAS(393,IEN,0)),U,2)
Begin DoDot:1
+9 ;
if 'PTMVMT
QUIT
if $$GET1^DIQ(405,PTMVMT,.01,"I")'=ADMDTTM
QUIT
+10 ;
if 'TYPE
QUIT
if $$GET1^DIQ(393,IEN,.02)'="DISCHARGE SUMMARY"
QUIT
+11 ;
+12 ; Mark COMPLETED
+13 ;
+14 ;
KILL DIE,DR
SET DA=IEN
SET DR=".11////COMPLETED"
SET DIE=^DIC(393,0,"GL")
DO ^DIE
End DoDot:1
+15 ;
+16 ;
QUIT
+17 ;
