EHMDGPMV ;ALB/WTC - EHRM - AUTOMATED PATIENT DISCHARGE TOOL; Apr 24, 2025@05:53:22
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**15**;Apr 19, 2021;Build 14
;
; Cloned from DGPMV
;
; Reference to Patient file (#2), field #9000 in ICR #7546
;
Q ;
;
ENTRY(DFN) ; EHM*1*15
;
; DFN = Patient (pointer to #2)
;
N DGPMT,ZTQUEUED,EHMRTNCD ; WTC 7/16/24
S DGPMT=3,DGPMN="" ; DGPMT=3 for discharge wtc 7/12/24
S ZTQUEUED=1 ; set to prevent interaction in protocols. WTC 7/16/24
;
PAT K ORACTION,ORMENU
D LO^DGUTL I '$D(IOF) S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
PAT1 W ! ;I DGPMT=5 S DGPMN=0 D SPCLU^DGPMV0 G OREN:'DGER,Q
; DISABLED EHM*1*15 ; S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")=$S('$D(DGPMPC):$P("Admit^Transfer^Discharge^Check-in^Check-out^Specialty Change for","^",DGPMT),1:"Provider Change for")_" PATIENT: "
; DISABLED EHM*1*15 ; S:"^1^4^"'[("^"_DGPMT_"^") DIC("S")="I $D(^DGPM($S(DGPMT'=5:""APTT1"",1:""APTT4""),+Y))" D ^DIC K DIC G Q:Y'>0 S DFN=+Y,DGPMN=$P(Y,"^",3)
OREN ; DISABLED EHM*1*15 ;S DGUSEOR=$$USINGOR()
; DISABLED EHM*1*15 ;I DGUSEOR Q:'$D(ORVP) S DFN=+ORVP,DGPMN="",Y(0)=$G(^DPT(DFN,0))
; DISABLED EHM*1*15 ;I $$LODGER(DFN)&(DGPMT=1) D Q
; DISABLED EHM*1*15 ;.W !,*7,"Patient is a lodger...you can not add an admission!"
; DISABLED EHM*1*15 ;.W !," Press RETURN to continue"
; DISABLED EHM*1*15 ;.R XTEMP:30
; DISABLED EHM*1*15 ;.D DISPOQ K DGPMDER
MOVE ;
S XQORQUIT=1,DGPME=0 D UC
; DISABLED EHM*1*15 ;G CHK:"^1^4^"[("^"_DGPMT_"^") I '$D(^DGPM("APTT"_$S(DGPMT'=5:1,1:4),DFN)) W !!,"'",$P(Y(0),"^",1),"' HAS NEVER BEEN ",$S(DGPMT'=5:"ADMITTED",1:"CHECK-IN")," TO THE DHCP ADMISSIONS MODULE" G PAT1:'DGUSEOR,Q
CHK ; DISABLED EHM*1*15 ;D:DGPMN REG I 'DGPME,$D(^DPT(DFN,.35)),+^(.35) S Y=+^(.35) D DIED
; DISABLED EHM*1*15 ;D NEW^DGPMVODS I $S('DGODSON:0,'$D(^DPT(DFN,.32)):1,'$D(^DIC(21,+$P(^(.32),"^",3),0)):1,1:0) S DGPME=1
S DGPME=0 S EHMRTNCD=$$ENTRY^EHMDGPMV1() G Q ; WTC 4/10/24 P15
; DISABLED EHM*1*15 ;D:'DGPME ^DGPMV1 G PAT1:'DGUSEOR,Q
;
REG ;new patient
; DISABLED EHM*1*15 ; D NEW^DGRP
; DISABLED EHM*1*15 ;W !!,"NEW PATIENT! WANT TO LOAD 10-10 DATA NOW" S %=1 D YN^DICN I %=1 D ENED^DGRP S:'$D(^DPT(DFN,0)) DGPME=1 Q
; DISABLED EHM*1*15 ;Q:%>0 I % S DGPME=1 Q
; DISABLED EHM*1*15 ;W !?4,"Answer YES if you want to load 10/10 data at this time otherwise answer NO.",*7 G REG
;
DIED X ^DD("DD") W !!,"PATIENT EXPIRED '",Y,"'...WANT TO CONTINUE" S %=2 D YN^DICN Q:%=1 I % S DGPME=1 Q
; DISABLED EHM*1*15 ;W !?4,*7,"Answer YES if you want to continue this process even though the patient",!?4,"has expired otherwise answer NO!" G DIED
;
Q ;WTC ;K %,DFN,DGER,DGPM5X,DGODS,DGODSON,DGPMUC,DGPME,DGPMN,DGPMT,DGPMPC,DIC,X,Y,^UTILITY("VAIP",$J) D KVAR^VADPT
;
; Record date/time discharge posted. wtc 7/17/24
;
I $G(EHMRTNCD) D DSC2CRNR(DFN) ;
;
K %,DFN,DGER,DGPM5X,DGODS,DGODSON,DGPMUC,DGPME,DGPMN,DGPMT,DGPMPC,DIC,X,Y,^UTILITY("VAIP",$J) D KVAR^VADPT
I '$G(DGUSEOR) K XQORQUIT
K DGUSEOR
Q
;
UC ; -- set type of mvt literal
S DGPMUC=$P("ADMISSION^TRANSFER^DISCHARGE^LODGER CHECK-IN^CHECK-OUT LODGER^SPECIALTY TRANSFER^ROOM-BED CHANGE","^",DGPMT)
I DGPMT=6,$D(DGPMPC) S DGPMUC="PROVIDER CHANGE"
Q
;
CA ; -- bypass interactive process and allows editing of past admission
; mvts
;
; input: DFN
; DGPMT - mvt transaction type
; DGPMCA - coresp. adm
;
; output: Y - the mvt entry added/edited
;
D UC
K VAIP S VAIP("E")=DGPMCA N DGPMCA D INP^DGPMV10
S DGPMBYP="" D C^DGPMV1
S Y=DGPMBYP K DGPMUC,DGPMBYP
Q
DISPO ;called from admission disposition types
;input DGPMSVC=SVC OF WARD REQUIRED (FROM DISPOSITION TYPE FILE)
; DFN=patient file IFN (this variable is NOT killed on exit)
;output DGPMDER=disposition error?? - FOR FUTURE USE
;
S DGPMT=1,(DGPML,DGPMMD)="" K DGPMDER,VAIP S VAIP("D")="L" D UC^DGPMV,INP^DGPMV10,NOW^%DTC
I DGPMVI(1)&('DGPMDCD!(DGPMDCD>%)) W !,"Patient is already an inpatient...editing the admission is not allowed." D DISPOQ K DGPMDER Q
I $$LODGER(DFN) W !,*7,"Patient is a lodger...you can not add an admission!" D DISPOQ K DGPMDER Q
;next line should be involked in future release to error if wrong service
;I DGPMVI(1)&('DGPMDCD!(DGPMDCD>%)) S DGPMDER=$S(DGPMSVC="H"&("^NH^D^"'[("^"_DGPMSV_"^")):0,DGPMSVC=DGPMSV:0,1:1) W:DGPMDER=1 "Current inpatient, but not to proper service" Q
D NEW^DGPMVODS I $S('DGODSON:0,'$D(^DPT(DFN,.32)):1,'$D(^DIC(21,+$P(^(.32),"^",3),0)):1,1:0) S DGPME=1
S DEF="NOW",DGPM1X=0 D SEL^DGPMV2 I '$D(DGPMDER) S DGPMDER=1
DISPOQ D Q^DGPMV1 K DGODS,DGODSON,DGPMT,DGPMSV,DGPMSVC,DGPMUC,DGPMN,^UTILITY("VAIP",$J) Q
;
USINGOR() ; return a 1 if OE/RR option is being used or 0 otherwise
N RETURN,X
S RETURN=0,X=+$$VERSION^XPDUTL("OR")
I X<3,$D(ORACTION) S RETURN=1
I X'<3,$D(ORMENU) S RETURN=1
Q RETURN
LODGER(DFN) ; Determine lodger status
; Input: DFN=patient IEN
; Output: '1' if currently a lodger, '0' otherwise
N DGPMDCD,DGPMVI,I,X
D LODGER^DGPMV10
Q DGPMVI(2)=4
;
DSC2CRNR(DFN) ;
;
; Post date/time to field #9000 DISCHARGED TO CERNER. EHM*1*15
;
N DIE,DA,DR ;
S DIE="^DPT(",DA=DFN,DR="9000///NOW" D ^DIE ; ICR #7546
Q ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEHMDGPMV 5249 printed Jul 11, 2026@01:48:07 Page 2
EHMDGPMV ;ALB/WTC - EHRM - AUTOMATED PATIENT DISCHARGE TOOL; Apr 24, 2025@05:53:22
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**15**;Apr 19, 2021;Build 14
+2 ;
+3 ; Cloned from DGPMV
+4 ;
+5 ; Reference to Patient file (#2), field #9000 in ICR #7546
+6 ;
+7 ;
QUIT
+8 ;
ENTRY(DFN) ; EHM*1*15
+1 ;
+2 ; DFN = Patient (pointer to #2)
+3 ;
+4 ; WTC 7/16/24
NEW DGPMT,ZTQUEUED,EHMRTNCD
+5 ; DGPMT=3 for discharge wtc 7/12/24
SET DGPMT=3
SET DGPMN=""
+6 ; set to prevent interaction in protocols. WTC 7/16/24
SET ZTQUEUED=1
+7 ;
PAT KILL ORACTION,ORMENU
+1 DO LO^DGUTL
IF '$DATA(IOF)
SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
PAT1 ;I DGPMT=5 S DGPMN=0 D SPCLU^DGPMV0 G OREN:'DGER,Q
WRITE !
+1 ; DISABLED EHM*1*15 ; S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")=$S('$D(DGPMPC):$P("Admit^Transfer^Discharge^Check-in^Check-out^Specialty Change for","^",DGPMT),1:"Provider Change for")_" PATIENT: "
+2 ; DISABLED EHM*1*15 ; S:"^1^4^"'[("^"_DGPMT_"^") DIC("S")="I $D(^DGPM($S(DGPMT'=5:""APTT1"",1:""APTT4""),+Y))" D ^DIC K DIC G Q:Y'>0 S DFN=+Y,DGPMN=$P(Y,"^",3)
OREN ; DISABLED EHM*1*15 ;S DGUSEOR=$$USINGOR()
+1 ; DISABLED EHM*1*15 ;I DGUSEOR Q:'$D(ORVP) S DFN=+ORVP,DGPMN="",Y(0)=$G(^DPT(DFN,0))
+2 ; DISABLED EHM*1*15 ;I $$LODGER(DFN)&(DGPMT=1) D Q
+3 ; DISABLED EHM*1*15 ;.W !,*7,"Patient is a lodger...you can not add an admission!"
+4 ; DISABLED EHM*1*15 ;.W !," Press RETURN to continue"
+5 ; DISABLED EHM*1*15 ;.R XTEMP:30
+6 ; DISABLED EHM*1*15 ;.D DISPOQ K DGPMDER
MOVE ;
+1 SET XQORQUIT=1
SET DGPME=0
DO UC
+2 ; DISABLED EHM*1*15 ;G CHK:"^1^4^"[("^"_DGPMT_"^") I '$D(^DGPM("APTT"_$S(DGPMT'=5:1,1:4),DFN)) W !!,"'",$P(Y(0),"^",1),"' HAS NEVER BEEN ",$S(DGPMT'=5:"ADMITTED",1:"CHECK-IN")," TO THE DHCP ADMISSIONS MODULE" G PAT1:'DGUSEOR,Q
CHK ; DISABLED EHM*1*15 ;D:DGPMN REG I 'DGPME,$D(^DPT(DFN,.35)),+^(.35) S Y=+^(.35) D DIED
+1 ; DISABLED EHM*1*15 ;D NEW^DGPMVODS I $S('DGODSON:0,'$D(^DPT(DFN,.32)):1,'$D(^DIC(21,+$P(^(.32),"^",3),0)):1,1:0) S DGPME=1
+2 ; WTC 4/10/24 P15
SET DGPME=0
SET EHMRTNCD=$$ENTRY^EHMDGPMV1()
GOTO Q
+3 ; DISABLED EHM*1*15 ;D:'DGPME ^DGPMV1 G PAT1:'DGUSEOR,Q
+4 ;
REG ;new patient
+1 ; DISABLED EHM*1*15 ; D NEW^DGRP
+2 ; DISABLED EHM*1*15 ;W !!,"NEW PATIENT! WANT TO LOAD 10-10 DATA NOW" S %=1 D YN^DICN I %=1 D ENED^DGRP S:'$D(^DPT(DFN,0)) DGPME=1 Q
+3 ; DISABLED EHM*1*15 ;Q:%>0 I % S DGPME=1 Q
+4 ; DISABLED EHM*1*15 ;W !?4,"Answer YES if you want to load 10/10 data at this time otherwise answer NO.",*7 G REG
+5 ;
DIED XECUTE ^DD("DD")
WRITE !!,"PATIENT EXPIRED '",Y,"'...WANT TO CONTINUE"
SET %=2
DO YN^DICN
if %=1
QUIT
IF %
SET DGPME=1
QUIT
+1 ; DISABLED EHM*1*15 ;W !?4,*7,"Answer YES if you want to continue this process even though the patient",!?4,"has expired otherwise answer NO!" G DIED
+2 ;
Q ;WTC ;K %,DFN,DGER,DGPM5X,DGODS,DGODSON,DGPMUC,DGPME,DGPMN,DGPMT,DGPMPC,DIC,X,Y,^UTILITY("VAIP",$J) D KVAR^VADPT
+1 ;
+2 ; Record date/time discharge posted. wtc 7/17/24
+3 ;
+4 ;
IF $GET(EHMRTNCD)
DO DSC2CRNR(DFN)
+5 ;
+6 KILL %,DFN,DGER,DGPM5X,DGODS,DGODSON,DGPMUC,DGPME,DGPMN,DGPMT,DGPMPC,DIC,X,Y,^UTILITY("VAIP",$JOB)
DO KVAR^VADPT
+7 IF '$GET(DGUSEOR)
KILL XQORQUIT
+8 KILL DGUSEOR
+9 QUIT
+10 ;
UC ; -- set type of mvt literal
+1 SET DGPMUC=$PIECE("ADMISSION^TRANSFER^DISCHARGE^LODGER CHECK-IN^CHECK-OUT LODGER^SPECIALTY TRANSFER^ROOM-BED CHANGE","^",DGPMT)
+2 IF DGPMT=6
IF $DATA(DGPMPC)
SET DGPMUC="PROVIDER CHANGE"
+3 QUIT
+4 ;
CA ; -- bypass interactive process and allows editing of past admission
+1 ; mvts
+2 ;
+3 ; input: DFN
+4 ; DGPMT - mvt transaction type
+5 ; DGPMCA - coresp. adm
+6 ;
+7 ; output: Y - the mvt entry added/edited
+8 ;
+9 DO UC
+10 KILL VAIP
SET VAIP("E")=DGPMCA
NEW DGPMCA
DO INP^DGPMV10
+11 SET DGPMBYP=""
DO C^DGPMV1
+12 SET Y=DGPMBYP
KILL DGPMUC,DGPMBYP
+13 QUIT
DISPO ;called from admission disposition types
+1 ;input DGPMSVC=SVC OF WARD REQUIRED (FROM DISPOSITION TYPE FILE)
+2 ; DFN=patient file IFN (this variable is NOT killed on exit)
+3 ;output DGPMDER=disposition error?? - FOR FUTURE USE
+4 ;
+5 SET DGPMT=1
SET (DGPML,DGPMMD)=""
KILL DGPMDER,VAIP
SET VAIP("D")="L"
DO UC^DGPMV
DO INP^DGPMV10
DO NOW^%DTC
+6 IF DGPMVI(1)&('DGPMDCD!(DGPMDCD>%))
WRITE !,"Patient is already an inpatient...editing the admission is not allowed."
DO DISPOQ
KILL DGPMDER
QUIT
+7 IF $$LODGER(DFN)
WRITE !,*7,"Patient is a lodger...you can not add an admission!"
DO DISPOQ
KILL DGPMDER
QUIT
+8 ;next line should be involked in future release to error if wrong service
+9 ;I DGPMVI(1)&('DGPMDCD!(DGPMDCD>%)) S DGPMDER=$S(DGPMSVC="H"&("^NH^D^"'[("^"_DGPMSV_"^")):0,DGPMSVC=DGPMSV:0,1:1) W:DGPMDER=1 "Current inpatient, but not to proper service" Q
+10 DO NEW^DGPMVODS
IF $SELECT('DGODSON:0,'$DATA(^DPT(DFN,.32)):1,'$DATA(^DIC(21,+$PIECE(^(.32),"^",3),0)):1,1:0)
SET DGPME=1
+11 SET DEF="NOW"
SET DGPM1X=0
DO SEL^DGPMV2
IF '$DATA(DGPMDER)
SET DGPMDER=1
DISPOQ DO Q^DGPMV1
KILL DGODS,DGODSON,DGPMT,DGPMSV,DGPMSVC,DGPMUC,DGPMN,^UTILITY("VAIP",$JOB)
QUIT
+1 ;
USINGOR() ; return a 1 if OE/RR option is being used or 0 otherwise
+1 NEW RETURN,X
+2 SET RETURN=0
SET X=+$$VERSION^XPDUTL("OR")
+3 IF X<3
IF $DATA(ORACTION)
SET RETURN=1
+4 IF X'<3
IF $DATA(ORMENU)
SET RETURN=1
+5 QUIT RETURN
LODGER(DFN) ; Determine lodger status
+1 ; Input: DFN=patient IEN
+2 ; Output: '1' if currently a lodger, '0' otherwise
+3 NEW DGPMDCD,DGPMVI,I,X
+4 DO LODGER^DGPMV10
+5 QUIT DGPMVI(2)=4
+6 ;
DSC2CRNR(DFN) ;
+1 ;
+2 ; Post date/time to field #9000 DISCHARGED TO CERNER. EHM*1*15
+3 ;
+4 ;
NEW DIE,DA,DR
+5 ; ICR #7546
SET DIE="^DPT("
SET DA=DFN
SET DR="9000///NOW"
DO ^DIE
+6 ;
QUIT
+7 ;
