DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 2/13/04 1:01pm
;;5.3;Registration;**161,517,895**;Aug 13, 1993;Build 11
;
;D_DGPMT - these lines are used as DEL nodes. If DGPMER=1, movement can
; not be deleted.
;DGPMT - once the movement is to be deleted, these are the other
; updates that must also occur.
;
D1 S DGPMER=0 F I=0:0 S I=$O(^DGPM("APMV",DFN,DGPMCA,I)) Q:I'>0 S J=$O(^(I,0)) I $D(^DGPM(J,0)),($P(^(0),"^",15)]"") S DGPMER=1 Q
I DGPMER W !,"Cannot delete before ASIH transfers are removed" Q
I $P(DGPMAN,"^",21),$P(DGPMAN,"^",17) S DGPMER=1 W !,"Must delete discharge first"
I $O(^DGPT("ACENSUS",+$P(DGPMAN,U,16),0)) S DGPMER=1 W !,"Cannot delete while PTF Census record #",$O(^(0))," is closed."
Q
1 ;S DA=$P(DGPMAN,U,16),DIK="^DGPT(",FLAG=1,I=0 F S I=$O(^DGCPT(46,"C",DA,I)) Q:'I I '$G(^DGCPT(I,9)) S FLAG=0 Q
;I FLAG S I=0 F S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I I '$G(^DGICD9(I,9)) S FLAG=0 Q
;DG*5.3*895 corrects issue with deleting admissions
S DA=$P(DGPMAN,U,16),DIK="^DGPT(",FLAG=1,I=0 F S I=$O(^DGCPT(46,"C",DA,I)) Q:'I I '$G(^DGCPT(46,I,9)) S FLAG=0 Q
I FLAG S I=0 F S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I I '$G(^DGICD9(46.1,I,9)) S FLAG=0 Q
I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT ENTRIES." K FLAG H 2 Q
S DGMSG="Patient admission has been deleted for admit date: "_$$FMTE^XLFDT(+DGPMAN,"5DZ"),DGMSG1="Deleted Admission"
D MSG^DGPTMSG1 S DA=$P(DGPMAN,U,16),DIK="^DGPT(" D ^DIK:DA>0 K FLAG,I,DA,DIK ; delete PTF record
S DA=$O(^DGS(41.1,"AMVT",DGPMDA,0)) I DA S DIE="^DGS(41.1,",DR="17///@" D ^DIE ;remove scheduled admission reference in 41.1
F DGI=DGPMDA:0 S DGI=$O(^DGPM("CA",DGPMDA,DGI)) Q:'DGI I $D(^DGPM(DGI,0)) S DGPMTYP=$P(^(0),"^",2),DA=DGI,DIK="^DGPM(",^UTILITY("DGPM",$J,DGPMTYP,DA,"P")=^(0),^("A")="" D ^DIK
S DGX=$P(DGPMAN,"^",21) G Q1:'DGX S DIK="^DGPM(",DA=DGX I $D(^DGPM(+DA,0)) S DGX1=^(0),^UTILITY("DGPM",$J,2,DA,"P")=^(0),^("A")="" D ^DIK W !,"ASIH transfer deleted",!
G Q1:($P(DGX1,"^",18)'=13) S DGPMADM=$P(DGX1,"^",14) D DD^DGPMVDL1
Q1 K ORQUIT Q
Q Q
D2 ;Can this transfer be deleted?
I $P(DGPMP,"^",18)=43,($P(DGPM2,"^",18)=42) S DGPMER=0 Q
I DGPM2,'$D(^DG(405.1,+$P(DGPM2,"^",4),"F",+$P(DGPM0,"^",4),0)) S DGPMER=1 W !,"Cannot delete transfer - would create an invalid transfer pair" Q
I "^13^44^"[("^"_$P(DGPMP,"^",18)_"^") S DGPMER=1 W !,"Must delete through corresponding hospital admission" Q
I $P(DGPMP,"^",18)=14,$P(DGPMAN,"^",17) S DGPMER=1 W !,"Cannot delete while discharge exists" Q
I $D(^DGPM(+$P(DGPMP,"^",15),0)),$D(^DGP(45.84,+$P(^(0),"^",16))) S DGPMER=1 W !,"Cannot delete when corresponding admission PTF closed out" Q
I "^14^43^45^"[("^"_$P(DGPMP,"^",18)_"^"),("^13^14^43^44^45^"[("^"_$P(DGPM2,"^",18)_"^")) S DGX=$S($D(^DG(405.1,+$P(DGPM2,"^",4),0)):$P(^(0),"^",1),1:"") W !,DGX," movement must be removed first" S DGPMER=1 Q
Q
2 I DGPMABL,DGPM0 S DGPMND=DGPM0 D AB^DGPMV32
S DGPMTYP=$P(DGPMP,"^",18) I DGPMTYP=43 S DGPMADM=DGPMCA D DD^DGPMVDL1 Q
I DGPMTYP=45 Q:'$P(DGPMP,"^",22) S DGX=$O(^DGPM("APTT3",DFN,DGPMP+.0000001,0)) I $D(^DGPM(+DGX,0)) S DGPMADM=$P(^(0),"^",14) D DD^DGPMVDL1 Q
Q:DGPMTYP'=14 S DGX=0 F I=(9999999.9999999-DGPMP):0 S I=$O(^DGPM("ATID2",DFN,I)) Q:'I S DGJ=$O(^(I,0)) I $D(^DGPM(+DGJ,0)),("^13^43^44^"[("^"_$P(^(0),"^",18)_"^")) S DGX=1 Q
Q:'DGX I "^13^44^"[("^"_$P(^DGPM(DGJ,0),"^",18)_"^") S DGPMADM=$P(^(0),"^",15) I $P(DGPMP,"^",22) D DD^DGPMVDL1
Q:$P(^DGPM(DGJ,0),"^",18)=44 S DGPMAB=+^DGPM(DGJ,0) D ASIHOF^DGPMV321 ;recreate 30 days
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMVDL 3575 printed Apr 09, 2024@21:47:25 Page 2
DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 2/13/04 1:01pm
+1 ;;5.3;Registration;**161,517,895**;Aug 13, 1993;Build 11
+2 ;
+3 ;D_DGPMT - these lines are used as DEL nodes. If DGPMER=1, movement can
+4 ; not be deleted.
+5 ;DGPMT - once the movement is to be deleted, these are the other
+6 ; updates that must also occur.
+7 ;
D1 SET DGPMER=0
FOR I=0:0
SET I=$ORDER(^DGPM("APMV",DFN,DGPMCA,I))
if I'>0
QUIT
SET J=$ORDER(^(I,0))
IF $DATA(^DGPM(J,0))
IF ($PIECE(^(0),"^",15)]"")
SET DGPMER=1
QUIT
+1 IF DGPMER
WRITE !,"Cannot delete before ASIH transfers are removed"
QUIT
+2 IF $PIECE(DGPMAN,"^",21)
IF $PIECE(DGPMAN,"^",17)
SET DGPMER=1
WRITE !,"Must delete discharge first"
+3 IF $ORDER(^DGPT("ACENSUS",+$PIECE(DGPMAN,U,16),0))
SET DGPMER=1
WRITE !,"Cannot delete while PTF Census record #",$ORDER(^(0))," is closed."
+4 QUIT
1 ;S DA=$P(DGPMAN,U,16),DIK="^DGPT(",FLAG=1,I=0 F S I=$O(^DGCPT(46,"C",DA,I)) Q:'I I '$G(^DGCPT(I,9)) S FLAG=0 Q
+1 ;I FLAG S I=0 F S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I I '$G(^DGICD9(I,9)) S FLAG=0 Q
+2 ;DG*5.3*895 corrects issue with deleting admissions
+3 SET DA=$PIECE(DGPMAN,U,16)
SET DIK="^DGPT("
SET FLAG=1
SET I=0
FOR
SET I=$ORDER(^DGCPT(46,"C",DA,I))
if 'I
QUIT
IF '$GET(^DGCPT(46,I,9))
SET FLAG=0
QUIT
+4 IF FLAG
SET I=0
FOR
SET I=$ORDER(^DGICD9(46.1,"C",DA,I))
if 'I
QUIT
IF '$GET(^DGICD9(46.1,I,9))
SET FLAG=0
QUIT
+5 IF 'FLAG
WRITE !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT ENTRIES."
KILL FLAG
HANG 2
QUIT
+6 SET DGMSG="Patient admission has been deleted for admit date: "_$$FMTE^XLFDT(+DGPMAN,"5DZ")
SET DGMSG1="Deleted Admission"
+7 ; delete PTF record
DO MSG^DGPTMSG1
SET DA=$PIECE(DGPMAN,U,16)
SET DIK="^DGPT("
if DA>0
DO ^DIK
KILL FLAG,I,DA,DIK
+8 ;remove scheduled admission reference in 41.1
SET DA=$ORDER(^DGS(41.1,"AMVT",DGPMDA,0))
IF DA
SET DIE="^DGS(41.1,"
SET DR="17///@"
DO ^DIE
+9 FOR DGI=DGPMDA:0
SET DGI=$ORDER(^DGPM("CA",DGPMDA,DGI))
if 'DGI
QUIT
IF $DATA(^DGPM(DGI,0))
SET DGPMTYP=$PIECE(^(0),"^",2)
SET DA=DGI
SET DIK="^DGPM("
SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"P")=^(0)
SET ^("A")=""
DO ^DIK
+10 SET DGX=$PIECE(DGPMAN,"^",21)
if 'DGX
GOTO Q1
SET DIK="^DGPM("
SET DA=DGX
IF $DATA(^DGPM(+DA,0))
SET DGX1=^(0)
SET ^UTILITY("DGPM",$JOB,2,DA,"P")=^(0)
SET ^("A")=""
DO ^DIK
WRITE !,"ASIH transfer deleted",!
+11 if ($PIECE(DGX1,"^",18)'=13)
GOTO Q1
SET DGPMADM=$PIECE(DGX1,"^",14)
DO DD^DGPMVDL1
Q1 KILL ORQUIT
QUIT
Q QUIT
D2 ;Can this transfer be deleted?
+1 IF $PIECE(DGPMP,"^",18)=43
IF ($PIECE(DGPM2,"^",18)=42)
SET DGPMER=0
QUIT
+2 IF DGPM2
IF '$DATA(^DG(405.1,+$PIECE(DGPM2,"^",4),"F",+$PIECE(DGPM0,"^",4),0))
SET DGPMER=1
WRITE !,"Cannot delete transfer - would create an invalid transfer pair"
QUIT
+3 IF "^13^44^"[("^"_$PIECE(DGPMP,"^",18)_"^")
SET DGPMER=1
WRITE !,"Must delete through corresponding hospital admission"
QUIT
+4 IF $PIECE(DGPMP,"^",18)=14
IF $PIECE(DGPMAN,"^",17)
SET DGPMER=1
WRITE !,"Cannot delete while discharge exists"
QUIT
+5 IF $DATA(^DGPM(+$PIECE(DGPMP,"^",15),0))
IF $DATA(^DGP(45.84,+$PIECE(^(0),"^",16)))
SET DGPMER=1
WRITE !,"Cannot delete when corresponding admission PTF closed out"
QUIT
+6 IF "^14^43^45^"[("^"_$PIECE(DGPMP,"^",18)_"^")
IF ("^13^14^43^44^45^"[("^"_$PIECE(DGPM2,"^",18)_"^"))
SET DGX=$SELECT($DATA(^DG(405.1,+$PIECE(DGPM2,"^",4),0)):$PIECE(^(0),"^",1),1:"")
WRITE !,DGX," movement must be removed first"
SET DGPMER=1
QUIT
+7 QUIT
2 IF DGPMABL
IF DGPM0
SET DGPMND=DGPM0
DO AB^DGPMV32
+1 SET DGPMTYP=$PIECE(DGPMP,"^",18)
IF DGPMTYP=43
SET DGPMADM=DGPMCA
DO DD^DGPMVDL1
QUIT
+2 IF DGPMTYP=45
if '$PIECE(DGPMP,"^",22)
QUIT
SET DGX=$ORDER(^DGPM("APTT3",DFN,DGPMP+.0000001,0))
IF $DATA(^DGPM(+DGX,0))
SET DGPMADM=$PIECE(^(0),"^",14)
DO DD^DGPMVDL1
QUIT
+3 if DGPMTYP'=14
QUIT
SET DGX=0
FOR I=(9999999.9999999-DGPMP):0
SET I=$ORDER(^DGPM("ATID2",DFN,I))
if 'I
QUIT
SET DGJ=$ORDER(^(I,0))
IF $DATA(^DGPM(+DGJ,0))
IF ("^13^43^44^"[("^"_$PIECE(^(0),"^",18)_"^"))
SET DGX=1
QUIT
+4 if 'DGX
QUIT
IF "^13^44^"[("^"_$PIECE(^DGPM(DGJ,0),"^",18)_"^")
SET DGPMADM=$PIECE(^(0),"^",15)
IF $PIECE(DGPMP,"^",22)
DO DD^DGPMVDL1
+5 ;recreate 30 days
if $PIECE(^DGPM(DGJ,0),"^",18)=44
QUIT
SET DGPMAB=+^DGPM(DGJ,0)
DO ASIHOF^DGPMV321
+6 QUIT
