DGPMV3 ;ALB/MIR - ENTER TRANSACTION INFORMATION; 8 MAY 89 ; 5/23/06 8:32am
;;5.3;Registration;**34,54,62,95,692,715,1003,1005,1013,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 2/21/2000 changed to IHS input templates
; 3/08/2001 set ^utility for IHS fields
; 7/25/2001 added code for silent APIs
;IHS/ITSC/LJF 04/14/2005 PATCH 1003 cannot allow user to ^ out of EBC
;IHS/OIT/LJF 05/26/2006 PATCH 1005 don't allow ^ out for discharges
;ihs/cmi/maw 04/08/2011 PATCH 1013 add delete reason for bulletin
;
K ^UTILITY("DGPM",$J)
D NOW^%DTC S DGNOW=%,DGPMHY=DGPMY,DGPMOUT=0 G:'DGPMN DT S X=DGPMY
S DGPM0ND=DGPMY_"^"_DGPMT_"^"_DFN_"^^^^^^^^^^^"_$S("^1^4^"[("^"_DGPMT_"^"):"",1:DGPMCA)
;
I DGPMT=1 S $P(DGPM0ND,"^",25)=$S(DGPMSA:1,1:0)
;-- provider change
I DGPMT=6,$D(DGPMPC) S DGPM0ND=$$PRODAT(DGPM0ND)
D NEW G Q:Y'>0 S (DA,DGPMDA)=+Y
S:DGPMT=1!(DGPMT=4) DGPMCA=DA,DGPMAN=^DGPM(DA,0) D VAR G DR
I $G(BDGAPI) D VAR G DR ;IHS/ANMC/LJF 7/25/2001
DT D VAR G:DGPM1X DR S (DGPMY,Y)=DGPMHY X ^DD("DD") W !,DGPMUC," DATE: ",Y,"// " R X:DTIME G Q:'$T!(X["^") I X="" G DR
S %DT="SRXE",%DT(0)="-NOW" I X["?"!(Y<0) D HELP^%DTC G DT
I X="@" G OKD
D ^%DT I Y<0 D HELP^%DTC G DT
K %DT S DGPMY=Y D CHK^DGPMV30:(X]"")&(DGPMY'=+DGPMP) I $D(DGPME) S DGPMY=DGPMHY W !,DGPME K DGPME G DT
DR ;select input template for transaction type
;IHS/ITSC/LJF 04/14/2005 PATCH 1003 always set no-hat out, not just for new entries
;S DIE="^DGPM(" I "^1^4^6^"[("^"_DGPMT_"^"),DGPMN S DIE("NO^")=""
;IHS/OIT/LJF 05/26/2006 PATCH 1005 don't aloow hat-out for discharge either
;S DIE="^DGPM(" I "^1^4^6^"[("^"_DGPMT_"^") S DIE("NO^")=""
S DIE="^DGPM(" I "^1^3^4^6^"[("^"_DGPMT_"^") S DIE("NO^")=""
;
S DGODSPT=$S('$D(^DGPM(DGPMCA,"ODS")):0,^("ODS"):1,1:0)
;
;IHS/ANMC/LJF 2/21/2001 changed to IHS input templates
;S DR=$S(DGPMT=1:"[DGPM ADMIT]",DGPMT=2:"[DGPM TRANSFER]",DGPMT=3:"[DGPM DISCHARGE]",DGPMT=4:"[DGPM CHECK-IN LODGER]",DGPMT=5:"[DGPM LODGER CHECK-OUT]",DGPMT=6:"[DGPM SPECIALTY TRANSFER]",1:"") G Q:DR="" K DQ,DG D ^DIE K DIE
S DR=$S(DGPMT=1:"[BDGPM ADMIT]",DGPMT=2:"[BDGPM TRANSFER]",DGPMT=3:"[BDGPM DISCHARGE]",DGPMT=4:"[DGPM CHECK-IN LODGER]",DGPMT=5:"[DGPM LODGER CHECK-OUT]",DGPMT=6:"[BDGPM SPECIALTY TRANSFER]",1:"")
G Q:DR="" I $G(BDGAPI) S X("]")=" API]" S DR=$$REPLACE^XLFSTR(DR,.X)
K DQ,DG,X D ^DIE K DIE
;IHS/ANMC/LJF 2/21/2001;7/25/2001 end of changes
;
I $D(Y)#2 S DGPMOUT=1
;Modified in patch dg*5.3*692 to include privacy indicator node "DIR"
K DGZ S (^UTILITY("DGPM",$J,DGPMT,DGPMDA,"A"),DGPMA)=$S($D(^DGPM(DGPMDA,0)):^(0)_$S($G(^("DIR"))'="":U_^("DIR"),1:""),1:"")
D:DGPMT'=4 @("^DGPMV3"_DGPMT)
I DGPMT=4,$S('$D(^DGPM(DGPMDA,"LD")):1,'$P(^("LD"),"^",1):1,1:0) S DIK="^DGPM(",DA=DGPMDA W !,"Incomplete check-in...deleted" D ^DIK K DIK S DGPMA=""
S (^UTILITY("DGPM",$J,DGPMT,DGPMDA,"A"),DGPMA)=$G(^DGPM(DGPMDA,0))_$S($G(^("DIR"))'="":U_^("DIR"),1:"") I DGPMT=6 S Y=DGPMDA D AFTER^DGPMV36
EVENTS ;
I DGPMT=4!(DGPMT=5) D RESET^DGPMDDLD
I DGPMT'=4&(DGPMT'=5) D RESET^DGPMDDCN I (DGPMT'=6) D SI^DGPMV33
D:DGPMA]"" START^DGPWB(DFN)
D EN^DGPMVBM ;notify building management if room-bed change
;IHS/ANMC/LJF 3/08/2001 add check for IHS node of ^utility
;S DGOK=0 F I=0:0 S I=$O(^UTILITY("DGPM",$J,I)) Q:'I F J=0:0 S J=$O(^UTILITY("DGPM",$J,I,J)) Q:'J I ^(J,"A")'=^("P") S DGOK=1 Q
S DGOK=0 F I=0:0 S I=$O(^UTILITY("DGPM",$J,I)) Q:'I F J=0:0 S J=$O(^UTILITY("DGPM",$J,I,J)) Q:'J I (^(J,"A")'=^("P"))!($G(^("IHSA"))'=$G(^("IHSP"))) S DGOK=1 Q
;IHS/ANMC/LJF 3/08/2001 end of changes
;
I DGOK D ^DGPMEVT ;Invoke Movement Event Driver
Q S:$D(DGPMBYP) DGPMBYP=DGPMDA
K DGIDX,DGOWD,DGOTY ;variables set in DGPMGLC - G&L corrections
K DGODS,DGODSPT ;ods variables
K %DT,DA,DGER,DGNOW,DGOK,DGPM0,DGPM0ND,DGPM2,DGPMA,DGPMAB,DGPMABL,DGPMDA,DGPMER,DGPMHY,DGPMNI,DGPMOC,DGPMOS,DGPMOUT,DGPMP,DGPMPHY,DGPMPHY0,DGPMPTF,DGPMSP,DGPMTYP,DGPMTN,DGPMWD,DGT,DGSV,DGX,DGX1
K DIC,DIE,DIK,DR,I,I1,J,K,X,X1,X2,Y,^UTILITY("DGPM",$J) Q
;
OKD ;IHS/ANMC/LJF 3/08/2001 added set of IHS node in ^utility
S ^UTILITY("DGPM",$J,DGPMT,DGPMDA,"IHSP")=$G(^DGPM(DGPMDA,"IHS"))
;
K %DT W ! S DGPMER=0,(^UTILITY("DGPM",$J,DGPMT,DGPMDA,"P"),DGPMP)=^DGPM(DGPMDA,0),Y=DGPMDA D:DGPMT=6 PRIOR^DGPMV36 D @("D"_DGPMT_"^DGPMVDL"_$S(DGPMT>2:1,1:"")) G Q:DGPMER
W !,"Are you sure you want to delete this movement" S %=2 D YN^DICN G Q:%<0,DT:%=2 I '% W !?5,"Answer yes to delete this ",DGPMUC," or no to continue" G OKD
D @(DGPMT_"^DGPMVDL"_$S(DGPMT>2:1,1:""))
S BDGDLREA=$$DELREAS() ;ihs/cmi/maw 04/08/2011 Patch 1013 RQMT157 add delete reason
I DGPMT'=3,(DGPMT'=5) S DIK="^DGPM(",DA=DGPMDA D ^DIK:DGPMDA
;IHS/ANMC/LJF 3/08/2001 added setting of IHS nodes in ^utility
;S (^UTILITY("DGPM",$J,DGPMT,DGPMDA,"A"),DGPMA)=$S($P(DGPMP,"^",18)'=47:"",1:^DGPM(+DGPMDA,0)) I DGPMT=6 S Y=DGPMDA D AFTER^DGPMV36
S (^UTILITY("DGPM",$J,DGPMT,DGPMDA,"A"),DGPMA)=$S($P(DGPMP,"^",18)'=47:"",1:^DGPM(+DGPMDA,0)),^UTILITY("DGPM",$J,DGPMT,DGPMDA,"IHSA")=$G(^DGPM(+DGPMDA,"IHS")) I DGPMT=6 S Y=DGPMDA D AFTER^DGPMV36
;I DGPMDA,$O(^DGPM("APHY",DGPMDA,0)) S DIK="^DGPM(",DA=+$O(^(0)) I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,6,DA,"P")=^(0),^("A")="",Y=DA D PRIOR^DGPMV36,^DIK S Y=DA D AFTER^DGPMV36
I DGPMDA,$O(^DGPM("APHY",DGPMDA,0)) S DIK="^DGPM(",DA=+$O(^(0)) I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,6,DA,"P")=^(0),^("A")="",^("IHSA")="",^("IHSP")=$G(^DGPM(+DA,"IHS")),Y=DA D PRIOR^DGPMV36,^DIK S Y=DA D AFTER^DGPMV36
;IHS/ANMC/LJF 3/08/2001 end of changes
G EVENTS
VAR ;Set up variables
;Modified in patch dg*5.3*692 to include privacy indicator node "DIR"
S DA=DGPMDA,(^UTILITY("DGPM",$J,DGPMT,DGPMDA,"P"),DGPMP)=$S(DGPMN=1:"",1:$G(^DGPM(DA,0))_$S($G(^("DIR"))'="":U_^("DIR"),1:""),1:"") ;DGPMP=Before edit
;IHS/ANMC/LJF 3/08/2001 added setting of IHS node in ^utility
S ^UTILITY("DGPM",$J,DGPMT,DGPMDA,"IHSP")=$G(^DGPM(+DGPMDA,"IHS"))
;
I DGPMT=6 S Y=DGPMDA D PRIOR^DGPMV36
S DGX=DGPMY+($P(DGPMP,"^",22)/10000000)
S X=$O(^DGPM("APMV",DFN,DGPMCA,(9999999.9999999-DGX))),X1=$O(^DGPM("APMV",DFN,DGPMCA,+X,0)) S DGPM0=$S($D(^DGPM(+X1,0)):^(0),1:"") ;DGPM0=prior movement
S X=$O(^DGPM("APCA",DFN,DGPMCA,+DGX)),X=$O(^(+X,0)),DGPM2=$S($D(^DGPM(+X,0)):^(0),1:"") ;DGPM2=next movement
S DGPMABL=0 I DGPM2,$D(^DG(405.2,+$P(DGPM2,"^",18),"E")) S DGPMABL=+^("E") ;is the next movement an absence?
I DGPMT=6 S Y=DGPMDA D PRIOR^DGPMV36
Q
NEW ;Entry point to add a new entry to ^DGPM
D NEW^DGPMV301 ; continuation of routine DGPMV3 in DGPMV301
Q
;
PRODAT(NODE) ;-- This function will add the ward and other data from the
; previous TS movement to the provider TS movement.
;
N X,Y
S Y=NODE,X=$O(^DGPM("ATS",DFN,DGPMCA,9999999.9999999-$P(NODE,U))) I X S X=$O(^(X,0)) I X S X=$O(^(X,0)) I X S X=^DGPM(X,0)
S $P(Y,U,4)=$P(X,U,4),$P(Y,U,9)=$P(X,U,9)
Q Y
;
DELREAS() ;-- get the delete reason PATCH 1013
S DIR(0)="S^A:Admit Error;P:Patient Refused;L:Left Without Being Seen;O:Other"
S DIR("A")="Delete Reason"
D ^DIR
I $D(DIRUT) Q ""
Q $G(Y(0))
;
DGPMV3 ;ALB/MIR - ENTER TRANSACTION INFORMATION; 8 MAY 89 ; 5/23/06 8:32am
+1 ;;5.3;Registration;**34,54,62,95,692,715,1003,1005,1013,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 2/21/2000 changed to IHS input templates
+3 ; 3/08/2001 set ^utility for IHS fields
+4 ; 7/25/2001 added code for silent APIs
+5 ;IHS/ITSC/LJF 04/14/2005 PATCH 1003 cannot allow user to ^ out of EBC
+6 ;IHS/OIT/LJF 05/26/2006 PATCH 1005 don't allow ^ out for discharges
+7 ;ihs/cmi/maw 04/08/2011 PATCH 1013 add delete reason for bulletin
+8 ;
+9 KILL ^UTILITY("DGPM",$JOB)
+10 DO NOW^%DTC
SET DGNOW=%
SET DGPMHY=DGPMY
SET DGPMOUT=0
IF 'DGPMN
GOTO DT
SET X=DGPMY
+11 SET DGPM0ND=DGPMY_"^"_DGPMT_"^"_DFN_"^^^^^^^^^^^"_$SELECT("^1^4^"[("^"_DGPMT_"^"):"",1:DGPMCA)
+12 ;
+13 IF DGPMT=1
SET $PIECE(DGPM0ND,"^",25)=$SELECT(DGPMSA:1,1:0)
+14 ;-- provider change
+15 IF DGPMT=6
IF $DATA(DGPMPC)
SET DGPM0ND=$$PRODAT(DGPM0ND)
+16 DO NEW
IF Y'>0
GOTO Q
SET (DA,DGPMDA)=+Y
+17 IF DGPMT=1!(DGPMT=4)
SET DGPMCA=DA
SET DGPMAN=^DGPM(DA,0)
DO VAR
GOTO DR
+18 ;IHS/ANMC/LJF 7/25/2001
IF $GET(BDGAPI)
DO VAR
GOTO DR
DT DO VAR
IF DGPM1X
GOTO DR
SET (DGPMY,Y)=DGPMHY
XECUTE ^DD("DD")
WRITE !,DGPMUC," DATE: ",Y,"// "
READ X:DTIME
IF '$TEST!(X["^")
GOTO Q
IF X=""
GOTO DR
+1 SET %DT="SRXE"
SET %DT(0)="-NOW"
IF X["?"!(Y<0)
DO HELP^%DTC
GOTO DT
+2 IF X="@"
GOTO OKD
+3 DO ^%DT
IF Y<0
DO HELP^%DTC
GOTO DT
+4 KILL %DT
SET DGPMY=Y
IF (X]"")&(DGPMY'=+DGPMP)
DO CHK^DGPMV30
IF $DATA(DGPME)
SET DGPMY=DGPMHY
WRITE !,DGPME
KILL DGPME
GOTO DT
DR ;select input template for transaction type
+1 ;IHS/ITSC/LJF 04/14/2005 PATCH 1003 always set no-hat out, not just for new entries
+2 ;S DIE="^DGPM(" I "^1^4^6^"[("^"_DGPMT_"^"),DGPMN S DIE("NO^")=""
+3 ;IHS/OIT/LJF 05/26/2006 PATCH 1005 don't aloow hat-out for discharge either
+4 ;S DIE="^DGPM(" I "^1^4^6^"[("^"_DGPMT_"^") S DIE("NO^")=""
+5 SET DIE="^DGPM("
IF "^1^3^4^6^"[("^"_DGPMT_"^")
SET DIE("NO^")=""
+6 ;
+7 SET DGODSPT=$SELECT('$DATA(^DGPM(DGPMCA,"ODS")):0,^("ODS"):1,1:0)
+8 ;
+9 ;IHS/ANMC/LJF 2/21/2001 changed to IHS input templates
+10 ;S DR=$S(DGPMT=1:"[DGPM ADMIT]",DGPMT=2:"[DGPM TRANSFER]",DGPMT=3:"[DGPM DISCHARGE]",DGPMT=4:"[DGPM CHECK-IN LODGER]",DGPMT=5:"[DGPM LODGER CHECK-OUT]",DGPMT=6:"[DGPM SPECIALTY TRANSFER]",1:"") G Q:DR="" K DQ,DG D ^DIE K DIE
+11 SET DR=$SELECT(DGPMT=1:"[BDGPM ADMIT]",DGPMT=2:"[BDGPM TRANSFER]",DGPMT=3:"[BDGPM DISCHARGE]",DGPMT=4:"[DGPM CHECK-IN LODGER]",DGPMT=5:"[DGPM LODGER CHECK-OUT]",DGPMT=6:"[BDGPM SPECIALTY TRANSFER]",1:"")
+12 IF DR=""
GOTO Q
IF $GET(BDGAPI)
SET X("]")=" API]"
SET DR=$$REPLACE^XLFSTR(DR,.X)
+13 KILL DQ,DG,X
DO ^DIE
KILL DIE
+14 ;IHS/ANMC/LJF 2/21/2001;7/25/2001 end of changes
+15 ;
+16 IF $DATA(Y)#2
SET DGPMOUT=1
+17 ;Modified in patch dg*5.3*692 to include privacy indicator node "DIR"
+18 KILL DGZ
SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"A"),DGPMA)=$SELECT($DATA(^DGPM(DGPMDA,0)):^(0)_$SELECT($GET(^("DIR"))'="":U_^("DIR"),1:""),1:"")
+19 IF DGPMT'=4
DO @("^DGPMV3"_DGPMT)
+20 IF DGPMT=4
IF $SELECT('$DATA(^DGPM(DGPMDA,"LD")):1,'$PIECE(^("LD"),"^",1):1,1:0)
SET DIK="^DGPM("
SET DA=DGPMDA
WRITE !,"Incomplete check-in...deleted"
DO ^DIK
KILL DIK
SET DGPMA=""
+21 SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"A"),DGPMA)=$GET(^DGPM(DGPMDA,0))_$SELECT($GET(^("DIR"))'="":U_^("DIR"),1:"")
IF DGPMT=6
SET Y=DGPMDA
DO AFTER^DGPMV36
EVENTS ;
+1 IF DGPMT=4!(DGPMT=5)
DO RESET^DGPMDDLD
+2 IF DGPMT'=4&(DGPMT'=5)
DO RESET^DGPMDDCN
IF (DGPMT'=6)
DO SI^DGPMV33
+3 IF DGPMA]""
DO START^DGPWB(DFN)
+4 ;notify building management if room-bed change
DO EN^DGPMVBM
+5 ;IHS/ANMC/LJF 3/08/2001 add check for IHS node of ^utility
+6 ;S DGOK=0 F I=0:0 S I=$O(^UTILITY("DGPM",$J,I)) Q:'I F J=0:0 S J=$O(^UTILITY("DGPM",$J,I,J)) Q:'J I ^(J,"A")'=^("P") S DGOK=1 Q
+7 SET DGOK=0
FOR I=0:0
SET I=$ORDER(^UTILITY("DGPM",$JOB,I))
IF 'I
QUIT
FOR J=0:0
SET J=$ORDER(^UTILITY("DGPM",$JOB,I,J))
IF 'J
QUIT
IF (^(J,"A")'=^("P"))!($GET(^("IHSA"))'=$GET(^("IHSP")))
SET DGOK=1
QUIT
+8 ;IHS/ANMC/LJF 3/08/2001 end of changes
+9 ;
+10 ;Invoke Movement Event Driver
IF DGOK
DO ^DGPMEVT
Q IF $DATA(DGPMBYP)
SET DGPMBYP=DGPMDA
+1 ;variables set in DGPMGLC - G&L corrections
KILL DGIDX,DGOWD,DGOTY
+2 ;ods variables
KILL DGODS,DGODSPT
+3 KILL %DT,DA,DGER,DGNOW,DGOK,DGPM0,DGPM0ND,DGPM2,DGPMA,DGPMAB,DGPMABL,DGPMDA,DGPMER,DGPMHY,DGPMNI,DGPMOC,DGPMOS,DGPMOUT,DGPMP,DGPMPHY,DGPMPHY0,DGPMPTF,DGPMSP,DGPMTYP,DGPMTN,DGPMWD,DGT,DGSV,DGX,DGX1
+4 KILL DIC,DIE,DIK,DR,I,I1,J,K,X,X1,X2,Y,^UTILITY("DGPM",$JOB)
QUIT
+5 ;
OKD ;IHS/ANMC/LJF 3/08/2001 added set of IHS node in ^utility
+1 SET ^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"IHSP")=$GET(^DGPM(DGPMDA,"IHS"))
+2 ;
+3 KILL %DT
WRITE !
SET DGPMER=0
SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"P"),DGPMP)=^DGPM(DGPMDA,0)
SET Y=DGPMDA
IF DGPMT=6
DO PRIOR^DGPMV36
DO @("D"_DGPMT_"^DGPMVDL"_$SELECT(DGPMT>2:1,1:""))
IF DGPMER
GOTO Q
+4 WRITE !,"Are you sure you want to delete this movement"
SET %=2
DO YN^DICN
IF %<0
GOTO Q
IF %=2
GOTO DT
IF '%
WRITE !?5,"Answer yes to delete this ",DGPMUC," or no to continue"
GOTO OKD
+5 DO @(DGPMT_"^DGPMVDL"_$SELECT(DGPMT>2:1,1:""))
+6 ;ihs/cmi/maw 04/08/2011 Patch 1013 RQMT157 add delete reason
SET BDGDLREA=$$DELREAS()
+7 IF DGPMT'=3
IF (DGPMT'=5)
SET DIK="^DGPM("
SET DA=DGPMDA
IF DGPMDA
DO ^DIK
+8 ;IHS/ANMC/LJF 3/08/2001 added setting of IHS nodes in ^utility
+9 ;S (^UTILITY("DGPM",$J,DGPMT,DGPMDA,"A"),DGPMA)=$S($P(DGPMP,"^",18)'=47:"",1:^DGPM(+DGPMDA,0)) I DGPMT=6 S Y=DGPMDA D AFTER^DGPMV36
+10 SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"A"),DGPMA)=$SELECT($PIECE(DGPMP,"^",18)'=47:"",1:^DGPM(+DGPMDA,0))
SET ^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"IHSA")=$GET(^DGPM(+DGPMDA,"IHS"))
IF DGPMT=6
SET Y=DGPMDA
DO AFTER^DGPMV36
+11 ;I DGPMDA,$O(^DGPM("APHY",DGPMDA,0)) S DIK="^DGPM(",DA=+$O(^(0)) I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,6,DA,"P")=^(0),^("A")="",Y=DA D PRIOR^DGPMV36,^DIK S Y=DA D AFTER^DGPMV36
+12 IF DGPMDA
IF $ORDER(^DGPM("APHY",DGPMDA,0))
SET DIK="^DGPM("
SET DA=+$ORDER(^(0))
IF $DATA(^DGPM(+DA,0))
SET ^UTILITY("DGPM",$JOB,6,DA,"P")=^(0)
SET ^("A")=""
SET ^("IHSA")=""
SET ^("IHSP")=$GET(^DGPM(+DA,"IHS"))
SET Y=DA
DO PRIOR^DGPMV36
DO ^DIK
SET Y=DA
DO AFTER^DGPMV36
+13 ;IHS/ANMC/LJF 3/08/2001 end of changes
+14 GOTO EVENTS
VAR ;Set up variables
+1 ;Modified in patch dg*5.3*692 to include privacy indicator node "DIR"
+2 ;DGPMP=Before edit
SET DA=DGPMDA
SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"P"),DGPMP)=$SELECT(DGPMN=1:"",1:$GET(^DGPM(DA,0))_$SELECT($GET(^("DIR"))'="":U_^("DIR"),1:""),1:"")
+3 ;IHS/ANMC/LJF 3/08/2001 added setting of IHS node in ^utility
+4 SET ^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"IHSP")=$GET(^DGPM(+DGPMDA,"IHS"))
+5 ;
+6 IF DGPMT=6
SET Y=DGPMDA
DO PRIOR^DGPMV36
+7 SET DGX=DGPMY+($PIECE(DGPMP,"^",22)/10000000)
+8 ;DGPM0=prior movement
SET X=$ORDER(^DGPM("APMV",DFN,DGPMCA,(9999999.9999999-DGX)))
SET X1=$ORDER(^DGPM("APMV",DFN,DGPMCA,+X,0))
SET DGPM0=$SELECT($DATA(^DGPM(+X1,0)):^(0),1:"")
+9 ;DGPM2=next movement
SET X=$ORDER(^DGPM("APCA",DFN,DGPMCA,+DGX))
SET X=$ORDER(^(+X,0))
SET DGPM2=$SELECT($DATA(^DGPM(+X,0)):^(0),1:"")
+10 ;is the next movement an absence?
SET DGPMABL=0
IF DGPM2
IF $DATA(^DG(405.2,+$PIECE(DGPM2,"^",18),"E"))
SET DGPMABL=+^("E")
+11 IF DGPMT=6
SET Y=DGPMDA
DO PRIOR^DGPMV36
+12 QUIT
NEW ;Entry point to add a new entry to ^DGPM
+1 ; continuation of routine DGPMV3 in DGPMV301
DO NEW^DGPMV301
+2 QUIT
+3 ;
PRODAT(NODE) ;-- This function will add the ward and other data from the
+1 ; previous TS movement to the provider TS movement.
+2 ;
+3 NEW X,Y
+4 SET Y=NODE
SET X=$ORDER(^DGPM("ATS",DFN,DGPMCA,9999999.9999999-$PIECE(NODE,U)))
IF X
SET X=$ORDER(^(X,0))
IF X
SET X=$ORDER(^(X,0))
IF X
SET X=^DGPM(X,0)
+5 SET $PIECE(Y,U,4)=$PIECE(X,U,4)
SET $PIECE(Y,U,9)=$PIECE(X,U,9)
+6 QUIT Y
+7 ;
DELREAS() ;-- get the delete reason PATCH 1013
+1 SET DIR(0)="S^A:Admit Error;P:Patient Refused;L:Left Without Being Seen;O:Other"
+2 SET DIR("A")="Delete Reason"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT ""
+5 QUIT $GET(Y(0))
+6 ;
