DGPMV3 ;ALB/MIR - ENTER TRANSACTION INFORMATION; 8 MAY 89 ; 7/08/24 10:11am
;;5.3;Registration;**34,54,62,95,692,715,895,1104**;Aug 13, 1993;Build 59
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
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(DGPMUC)="ADMISSION" D CPTCK ; DG*5.3*895 Check for 801 screen data
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
S DIE="^DGPM(" I "^1^4^6^"[("^"_DGPMT_"^"),DGPMN S DIE("NO^")=""
S DGODSPT=$S('$D(^DGPM(DGPMCA,"ODS")):0,^("ODS"):1,1:0)
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
I $D(^UTILITY($J,"PXCOMPACT")),'$D(^UTILITY("DGPM",$J,1,DGPMDA,"A")),$G(PTF)'="" D EDITADMIT^DGCOMPACT(PTF)
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
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
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 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
;delete an admission
I DGPMT=1 D
. ; get EOC number
. N DA,DIK,PXEOCNUM,PXEOCSEQ
. S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
. ; get EOC sequence number
. S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
. ; delete entire episode if only 1 sequence or just delete latest sequence if >1
. I PXEOCSEQ=1 D
. . S DIK="^PXCOMP(818,",DA=PXEOCNUM
. . D ^DIK
. . K DA,DIK
. I PXEOCSEQ>1 D
. . S DA(1)=PXEOCNUM,DA=PXEOCSEQ,DIK="^PXCOMP(818,"_DA(1)_",10,"
. . D ^DIK
. . K DA,DIK
;delete a discharge
I DGPMT=3 D
. N PXEOCNUM,PXEOCSEQ
. S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
. S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
. I (PXEOCNUM'=""),(PXEOCSEQ'="") D REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ)
;delete a transfer
I DGPMT=2 D
. N DGFOUND,DGMOVSEQ,PXEOCNUM,PXEOCSEQ,PXSTARTDT
. ;get episode of care start date
. S PXSTARTDT=$$GETSTDT^PXCOMPACT(DFN),DGFOUND=""
. I (PXSTARTDT="")!(PXSTARTDT'=$P(DGPMY,".",1)) Q
. ;loop through "M" levels to see if any match the start date
. S DGMOVSEQ=0
. F S DGMOVSEQ=$O(^DGPT(PTF,"M",DGMOVSEQ)) Q:(DGMOVSEQ="")!(DGFOUND) D
. . I $P(^DGPT(PTF,"M",DGMOVSEQ,0),"^",10)'=DGPMY Q
. . I $P(^DGPT(PTF,"M",DGMOVSEQ,0),"^",33)'="Y" Q
. . S DGFOUND=1
. I DGFOUND,$P(^DGPT(PTF,70),"^",33)=1 D
. . S PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
. . ; get EOC sequence number
. . S PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
. . I PXEOCSEQ=1 D
. . . S DIK="^PXCOMP(818,",DA=PXEOCNUM
. . . D ^DIK
. . . K DA,DIK
. . I PXEOCSEQ>1 D
. . . S DA(1)=PXEOCNUM,DA=PXEOCSEQ,DIK="^PXCOMP(818,"_DA(1)_",10,"
. . . D ^DIK
. . . K DA,DIK
D @(DGPMT_"^DGPMVDL"_$S(DGPMT>2:1,1:""))
I DGPMT'=3,(DGPMT'=5) S DIK="^DGPM(",DA=DGPMDA D ^DIK:DGPMDA
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
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
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
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
;
CPTCK ; DG*5.3*895 Admission Deletion - Check to see if there is 801 screen data on file (DGPMFLG = okay to delete)
N DGPMDA,DGPMI,DGPMFLG
S DGPMDA=$P($G(DGPMAN),U,16),DGPMI=0,DGPMFLG=1
Q:DGPMDA=""
F S I=$O(^DGCPT(46,"C",DGPMDA,DGPMI)) Q:'DGPMI I '$G(^DGCPT(46,DGPMI,9)) S DGPMFLG=0
I DGPMFLG S DGPMI=0 F S DGPMI=$O(^DGICD9(46.1,"C",DGPMDA,DGPMI)) Q:'DGPMI I '$G(^DGICD9(46.1,DGPMI,9)) S DGPMFLG=0
I 'DGPMFLG W !!,"CANNOT DELETE THE ADMISSION. THE PTF HAS ACTIVE ORDERS OR CPT ENTRIES." S X="^" H 2 W !
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV3 6870 printed Dec 13, 2024@02:50:12 Page 2
DGPMV3 ;ALB/MIR - ENTER TRANSACTION INFORMATION; 8 MAY 89 ; 7/08/24 10:11am
+1 ;;5.3;Registration;**34,54,62,95,692,715,895,1104**;Aug 13, 1993;Build 59
+2 KILL ^UTILITY("DGPM",$JOB)
+3 DO NOW^%DTC
SET DGNOW=%
SET DGPMHY=DGPMY
SET DGPMOUT=0
if 'DGPMN
GOTO DT
SET X=DGPMY
+4 SET DGPM0ND=DGPMY_"^"_DGPMT_"^"_DFN_"^^^^^^^^^^^"_$SELECT("^1^4^"[("^"_DGPMT_"^"):"",1:DGPMCA)
+5 ;
+6 IF DGPMT=1
SET $PIECE(DGPM0ND,"^",25)=$SELECT(DGPMSA:1,1:0)
+7 ;-- provider change
+8 IF DGPMT=6
IF $DATA(DGPMPC)
SET DGPM0ND=$$PRODAT(DGPM0ND)
+9 DO NEW
if Y'>0
GOTO Q
SET (DA,DGPMDA)=+Y
+10 if DGPMT=1!(DGPMT=4)
SET DGPMCA=DA
SET DGPMAN=^DGPM(DA,0)
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 ; DG*5.3*895 Check for 801 screen data
IF X="@"
IF $GET(DGPMUC)="ADMISSION"
DO CPTCK
+3 IF X="@"
GOTO OKD
+4 DO ^%DT
IF Y<0
DO HELP^%DTC
GOTO DT
+5 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 SET DIE="^DGPM("
IF "^1^4^6^"[("^"_DGPMT_"^")
IF DGPMN
SET DIE("NO^")=""
+2 SET DGODSPT=$SELECT('$DATA(^DGPM(DGPMCA,"ODS")):0,^("ODS"):1,1:0)
+3 SET DR=$SELECT(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:"")
if DR=""
GOTO Q
KILL DQ,DG
DO ^DIE
KILL DIE
+4 IF $DATA(^UTILITY($JOB,"PXCOMPACT"))
IF '$DATA(^UTILITY("DGPM",$JOB,1,DGPMDA,"A"))
IF $GET(PTF)'=""
DO EDITADMIT^DGCOMPACT(PTF)
+5 IF $DATA(Y)#2
SET DGPMOUT=1
+6 ;Modified in patch dg*5.3*692 to include privacy indicator node "DIR"
+7 KILL DGZ
SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"A"),DGPMA)=$SELECT($DATA(^DGPM(DGPMDA,0)):^(0)_$SELECT($GET(^("DIR"))'="":U_^("DIR"),1:""),1:"")
+8 if DGPMT'=4
DO @("^DGPMV3"_DGPMT)
+9 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=""
+10 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 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")
SET DGOK=1
QUIT
+6 ;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 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
+1 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
+2 ;delete an admission
+3 IF DGPMT=1
Begin DoDot:1
+4 ; get EOC number
+5 NEW DA,DIK,PXEOCNUM,PXEOCSEQ
+6 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+7 ; get EOC sequence number
+8 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+9 ; delete entire episode if only 1 sequence or just delete latest sequence if >1
+10 IF PXEOCSEQ=1
Begin DoDot:2
+11 SET DIK="^PXCOMP(818,"
SET DA=PXEOCNUM
+12 DO ^DIK
+13 KILL DA,DIK
End DoDot:2
+14 IF PXEOCSEQ>1
Begin DoDot:2
+15 SET DA(1)=PXEOCNUM
SET DA=PXEOCSEQ
SET DIK="^PXCOMP(818,"_DA(1)_",10,"
+16 DO ^DIK
+17 KILL DA,DIK
End DoDot:2
End DoDot:1
+18 ;delete a discharge
+19 IF DGPMT=3
Begin DoDot:1
+20 NEW PXEOCNUM,PXEOCSEQ
+21 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+22 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+23 IF (PXEOCNUM'="")
IF (PXEOCSEQ'="")
DO REOPNEOC^PXCOMPACT(PXEOCNUM,PXEOCSEQ)
End DoDot:1
+24 ;delete a transfer
+25 IF DGPMT=2
Begin DoDot:1
+26 NEW DGFOUND,DGMOVSEQ,PXEOCNUM,PXEOCSEQ,PXSTARTDT
+27 ;get episode of care start date
+28 SET PXSTARTDT=$$GETSTDT^PXCOMPACT(DFN)
SET DGFOUND=""
+29 IF (PXSTARTDT="")!(PXSTARTDT'=$PIECE(DGPMY,".",1))
QUIT
+30 ;loop through "M" levels to see if any match the start date
+31 SET DGMOVSEQ=0
+32 FOR
SET DGMOVSEQ=$ORDER(^DGPT(PTF,"M",DGMOVSEQ))
if (DGMOVSEQ="")!(DGFOUND)
QUIT
Begin DoDot:2
+33 IF $PIECE(^DGPT(PTF,"M",DGMOVSEQ,0),"^",10)'=DGPMY
QUIT
+34 IF $PIECE(^DGPT(PTF,"M",DGMOVSEQ,0),"^",33)'="Y"
QUIT
+35 SET DGFOUND=1
End DoDot:2
+36 IF DGFOUND
IF $PIECE(^DGPT(PTF,70),"^",33)=1
Begin DoDot:2
+37 SET PXEOCNUM=$$GETEOC^PXCOMPACT(DFN)
+38 ; get EOC sequence number
+39 SET PXEOCSEQ=$$GETEOCSEQ^PXCOMPACT(DFN)
+40 IF PXEOCSEQ=1
Begin DoDot:3
+41 SET DIK="^PXCOMP(818,"
SET DA=PXEOCNUM
+42 DO ^DIK
+43 KILL DA,DIK
End DoDot:3
+44 IF PXEOCSEQ>1
Begin DoDot:3
+45 SET DA(1)=PXEOCNUM
SET DA=PXEOCSEQ
SET DIK="^PXCOMP(818,"_DA(1)_",10,"
+46 DO ^DIK
+47 KILL DA,DIK
End DoDot:3
End DoDot:2
End DoDot:1
+48 DO @(DGPMT_"^DGPMVDL"_$SELECT(DGPMT>2:1,1:""))
+49 IF DGPMT'=3
IF (DGPMT'=5)
SET DIK="^DGPM("
SET DA=DGPMDA
if DGPMDA
DO ^DIK
+50 SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"A"),DGPMA)=$SELECT($PIECE(DGPMP,"^",18)'=47:"",1:^DGPM(+DGPMDA,0))
IF DGPMT=6
SET Y=DGPMDA
DO AFTER^DGPMV36
+51 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 Y=DA
DO PRIOR^DGPMV36
DO ^DIK
SET Y=DA
DO AFTER^DGPMV36
+52 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 IF DGPMT=6
SET Y=DGPMDA
DO PRIOR^DGPMV36
+4 SET DGX=DGPMY+($PIECE(DGPMP,"^",22)/10000000)
+5 ;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:"")
+6 ;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:"")
+7 ;is the next movement an absence?
SET DGPMABL=0
IF DGPM2
IF $DATA(^DG(405.2,+$PIECE(DGPM2,"^",18),"E"))
SET DGPMABL=+^("E")
+8 IF DGPMT=6
SET Y=DGPMDA
DO PRIOR^DGPMV36
+9 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 ;
CPTCK ; DG*5.3*895 Admission Deletion - Check to see if there is 801 screen data on file (DGPMFLG = okay to delete)
+1 NEW DGPMDA,DGPMI,DGPMFLG
+2 SET DGPMDA=$PIECE($GET(DGPMAN),U,16)
SET DGPMI=0
SET DGPMFLG=1
+3 if DGPMDA=""
QUIT
+4 FOR
SET I=$ORDER(^DGCPT(46,"C",DGPMDA,DGPMI))
if 'DGPMI
QUIT
IF '$GET(^DGCPT(46,DGPMI,9))
SET DGPMFLG=0
+5 IF DGPMFLG
SET DGPMI=0
FOR
SET DGPMI=$ORDER(^DGICD9(46.1,"C",DGPMDA,DGPMI))
if 'DGPMI
QUIT
IF '$GET(^DGICD9(46.1,DGPMI,9))
SET DGPMFLG=0
+6 IF 'DGPMFLG
WRITE !!,"CANNOT DELETE THE ADMISSION. THE PTF HAS ACTIVE ORDERS OR CPT ENTRIES."
SET X="^"
HANG 2
WRITE !
+7 QUIT
+8 ;
