DGPMV ;ALB/MRL/MIR - PATIENT MOVEMENT DRIVER; 10 MAR 89 [ 03/16/2004 7:49 AM ]
;;5.3;Registration;**60,200,268,1015,1017**;Aug 13, 1993;Build 5
;IHS/ANMC/LJF 2/21/2001 Removed patient laygo; changed DHCP to IHS
; 3/08/2001 Added check for temporary chart #
;
;OPTION VALUE OF DGPMT
;------ --------------
;admit 1
;transfer 2
;discharge 3
;check-in 4
;check-out 5
;t.s. transfer 6
;
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
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: "
;
;IHS/ANMC/LJF 2/21/2001 remove ability to add new patient
;S:DGPMT=1 DIC(0)=DIC(0)_"L",DLAYGO=2 S:"^1^4^"'[("^"_DGPMT_"^") DIC("S")="I $D(^DGPM($S(DGPMT'=5:""APTT1"",1:""APTT4""),+Y))" D ^DIC K DIC,DLAYGO G Q:Y'>0 S DFN=+Y,DGPMN=$P(Y,"^",3)
S:"^1^4^"'[("^"_DGPMT_"^") DIC("S")="I $D(^DGPM($S(DGPMT'=5:""APTT1"",1:""APTT4""),+Y))" D ^DIC K DIC,DLAYGO G Q:Y'>0 S DFN=+Y,DGPMN=$P(Y,"^",3)
;IHS/ANMC/LJF 2/21/2001 end of changes
;
;IHS/ANMC/LJF 3/08/2001 checking for temporary chart #
I $$HRCN^BDGF2(DFN,DUZ(2))["T" D G PAT1
. D MSG^BDGF("Cannot Admit Patient with Temporary chart number",1,0)
. D MSG^BDGF("Please contact medical records for new chart number",1,0)
;IHS/ANMC/LJF 3/08/2001 end of new code
;
OREN S DGUSEOR=$$USINGOR()
I DGUSEOR Q:'$D(ORVP) S DFN=+ORVP,DGPMN="",Y(0)=$G(^DPT(DFN,0))
I $$LODGER(DFN)&(DGPMT=1) D Q
.W !,*7,"Patient is a lodger...you can not add an admission!"
.W !," Press RETURN to continue"
.R XTEMP:30
.D DISPOQ K DGPMDER
MOVE ;
S XQORQUIT=1,DGPME=0 D UC
;
;IHS/ANMC/LJF 2/21/2001 changed DHCP to IHS
;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
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 IHS ADMISSIONS MODULE" G PAT1:'DGUSEOR,Q
;IHS/ANMC/LJF 2/21/2001 end of change
;
CHK D:DGPMN REG I 'DGPME,$D(^DPT(DFN,.35)),+^(.35) S Y=+^(.35) D DIED
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
D:'DGPME ^DGPMV1 G PAT1:'DGUSEOR,Q
;
REG ;new patient
D NEW^DGRP
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
Q:%>0 I % S DGPME=1 Q
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
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 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"
;ihs/cmi/maw 09/16/2013 patch 1017 add call to auditing sofware here
S X="BUSAAPI" X ^%ZOSF("TEST") Q:'$T
N BDGAUDIT,BDGREC
S BDGREC(1)=DFN
S BDGAUDIT=$$LOG^BUSAAPI("A","P","A",$P(XQY0,U)_"-"_$P(XQY0,U,2),"PATIENT "_$G(DGPMUC),"BDGREC")
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
DGPMV ;ALB/MRL/MIR - PATIENT MOVEMENT DRIVER; 10 MAR 89 [ 03/16/2004 7:49 AM ]
+1 ;;5.3;Registration;**60,200,268,1015,1017**;Aug 13, 1993;Build 5
+2 ;IHS/ANMC/LJF 2/21/2001 Removed patient laygo; changed DHCP to IHS
+3 ; 3/08/2001 Added check for temporary chart #
+4 ;
+5 ;OPTION VALUE OF DGPMT
+6 ;------ --------------
+7 ;admit 1
+8 ;transfer 2
+9 ;discharge 3
+10 ;check-in 4
+11 ;check-out 5
+12 ;t.s. transfer 6
+13 ;
PAT KILL ORACTION,ORMENU
+1 DO LO^DGUTL
IF '$DATA(IOF)
SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
PAT1 WRITE !
IF DGPMT=5
SET DGPMN=0
DO SPCLU^DGPMV0
IF 'DGER
GOTO OREN
GOTO Q
+1 SET DIC="^DPT("
SET DIC(0)="AEQMZ"
SET DIC("A")=$SELECT('$DATA(DGPMPC):$PIECE("Admit^Transfer^Discharge^Check-in^Check-out^Specialty Change for","^",DGPMT),1:"Provider Change for")_" PATIENT: "
+2 ;
+3 ;IHS/ANMC/LJF 2/21/2001 remove ability to add new patient
+4 ;S:DGPMT=1 DIC(0)=DIC(0)_"L",DLAYGO=2 S:"^1^4^"'[("^"_DGPMT_"^") DIC("S")="I $D(^DGPM($S(DGPMT'=5:""APTT1"",1:""APTT4""),+Y))" D ^DIC K DIC,DLAYGO G Q:Y'>0 S DFN=+Y,DGPMN=$P(Y,"^",3)
+5 IF "^1^4^"'[("^"_DGPMT_"^")
SET DIC("S")="I $D(^DGPM($S(DGPMT'=5:""APTT1"",1:""APTT4""),+Y))"
DO ^DIC
KILL DIC,DLAYGO
IF Y'>0
GOTO Q
SET DFN=+Y
SET DGPMN=$PIECE(Y,"^",3)
+6 ;IHS/ANMC/LJF 2/21/2001 end of changes
+7 ;
+8 ;IHS/ANMC/LJF 3/08/2001 checking for temporary chart #
+9 IF $$HRCN^BDGF2(DFN,DUZ(2))["T"
Begin DoDot:1
+10 DO MSG^BDGF("Cannot Admit Patient with Temporary chart number",1,0)
+11 DO MSG^BDGF("Please contact medical records for new chart number",1,0)
End DoDot:1
GOTO PAT1
+12 ;IHS/ANMC/LJF 3/08/2001 end of new code
+13 ;
OREN SET DGUSEOR=$$USINGOR()
+1 IF DGUSEOR
IF '$DATA(ORVP)
QUIT
SET DFN=+ORVP
SET DGPMN=""
SET Y(0)=$GET(^DPT(DFN,0))
+2 IF $$LODGER(DFN)&(DGPMT=1)
Begin DoDot:1
+3 WRITE !,*7,"Patient is a lodger...you can not add an admission!"
+4 WRITE !," Press RETURN to continue"
+5 READ XTEMP:30
+6 DO DISPOQ
KILL DGPMDER
End DoDot:1
QUIT
MOVE ;
+1 SET XQORQUIT=1
SET DGPME=0
DO UC
+2 ;
+3 ;IHS/ANMC/LJF 2/21/2001 changed DHCP to IHS
+4 ;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
+5 IF "^1^4^"[("^"_DGPMT_"^")
GOTO CHK
IF '$DATA(^DGPM("APTT"_$SELECT(DGPMT'=5:1,1:4),DFN))
WRITE !!,"'",$PIECE(Y(0),"^",1),"' HAS NEVER BEEN ",$SELECT(DGPMT'=5:"ADMITTED",1:"CHECK-IN")," TO THE IHS ADMISSIONS MODULE"
IF 'DGUSEOR
GOTO PAT1
GOTO Q
+6 ;IHS/ANMC/LJF 2/21/2001 end of change
+7 ;
CHK IF DGPMN
DO REG
IF 'DGPME
IF $DATA(^DPT(DFN,.35))
IF +^(.35)
SET Y=+^(.35)
DO DIED
+1 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
+2 IF 'DGPME
DO ^DGPMV1
IF 'DGUSEOR
GOTO PAT1
GOTO Q
+3 ;
REG ;new patient
+1 DO NEW^DGRP
+2 WRITE !!,"NEW PATIENT! WANT TO LOAD 10-10 DATA NOW"
SET %=1
DO YN^DICN
IF %=1
DO ENED^DGRP
IF '$DATA(^DPT(DFN,0))
SET DGPME=1
QUIT
+3 IF %>0
QUIT
IF %
SET DGPME=1
QUIT
+4 WRITE !?4,"Answer YES if you want to load 10/10 data at this time otherwise answer NO.",*7
GOTO 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 WRITE !?4,*7,"Answer YES if you want to continue this process even though the patient",!?4,"has expired otherwise answer NO!"
GOTO DIED
+2 ;
Q KILL %,DFN,DGER,DGPM5X,DGODS,DGODSON,DGPMUC,DGPME,DGPMN,DGPMT,DGPMPC,DIC,X,Y,^UTILITY("VAIP",$JOB)
DO KVAR^VADPT
+1 IF '$GET(DGUSEOR)
KILL XQORQUIT
+2 KILL DGUSEOR
+3 QUIT
+4 ;
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 ;ihs/cmi/maw 09/16/2013 patch 1017 add call to auditing sofware here
+4 SET X="BUSAAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+5 NEW BDGAUDIT,BDGREC
+6 SET BDGREC(1)=DFN
+7 SET BDGAUDIT=$$LOG^BUSAAPI("A","P","A",$PIECE(XQY0,U)_"-"_$PIECE(XQY0,U,2),"PATIENT "_$GET(DGPMUC),"BDGREC")
+8 QUIT
+9 ;
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
