DGPMVDL1 ;ALB/MIR - DELETE PATIENT MOVEMENTS, CONTINUED ; 11 JAN 88 @9
;;5.3;Registration;;Aug 13, 1993
D3 ;can this discharge be deleted?
I $P(DGPMP,"^",18)=42 S DGPMER=1 W !,"You can not delete a WHILE ASIH type discharge" Q
I $P(DGPMAN,"^",21),("^41^46^"[("^"_+$P(DGPMP,"^",18)_"^")) S DGPMER=1 W !,"Delete through corresponding NHCU/DOM movements" Q
I $O(^DGPM("APTT1",DFN,+DGPMP)) S DGPMER=1 W !,"Can only delete discharge for last admission" Q
S X=$O(^DGPM("APTT1",DFN,+DGPMP)),Y=$O(^DGPM("APTT4",DFN,+DGPMP))
I X!Y S DGPMER=1 W !,"There is a",$S(X:"n admission",1:" check-in")," movement following this discharge.",!,"You can only remove a discharge when it is the last movement for the patient." Q
I $P(DGPMP,"^",18)=47,("^13^44^"[("^"_$P(DGPM0,"^",18)_"^")),$D(^DGPM(+$P(DGPM0,"^",15),0)),$P(^(0),"^",17) S DGPMER=1 W !,"You must delete the hospital discharge first" Q
Q
3 I $P(DGPMP,"^",18)=47 G 47
S DGPMADM=DGPMCA D DD,DS^DGPTMSG1
K DA Q:$P(DGPMAN,"^",18)'=40 I $D(^DGPM(+$P(DGPMAN,"^",21),0)) S DGPMTN=^(0),DGPMNI=$P(DGPMTN,"^",14) I $D(^DGPM(+DGPMNI,0)) S DA=$P(^(0),"^",17),DGPMPTF=$P(^(0),"^",16) I $D(^DGPM(+DA,0)),($P(^(0),"^",18)=47) Q
Q:'$D(DA) D FINDLAST^DGPMV32 Q:'DGPMAB S X1=+DGPMAB,X2=30 D C^%DTC S DGPMPD=X,DIE="^DGPM(",DR=".01///"_X_";.22////0"
K DQ,DG Q:'$D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,3,DA,"P")=^(0) D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0) ;delete ASIH sequence and restore 30 days if deleting hospital discharge
S DA=DGPMPTF,DIE="^DGPT(",DR="70////"_DGPMPD D ^DIE ;update PTF d/c d/t
Q
47 ;if DISCHARGE FROM NHCU/DOM WHILE ASIH
S DGPMNI=+$P(DGPMP,"^",14),DGPMTN=DGPM0 D FINDLAST^DGPMV32
Q:'+DGPMAB S X1=DGPMAB,X2=30 D C^%DTC S DGMAS=42 D FAMT^DGPMV30 S DIE="^DGPM(",DA=DGPMDA,DR=".01///"_X_";.04////"_DGFAC D ^DIE K DGFAC
Q
D4 Q
4 ;check-in...delete all related lodger movements
F DGI=DGPMDA:0 S DGI=$O(^DGPM("CA",DGPMDA,DGI)) Q:'DGI I $D(^DGPM(DGI,0)) S DA=DGI,DIK="^DGPM(" D ^DIK
Q
D5 ;can't be followed by another movement
S X=$O(^DGPM("APTT1",DFN,+DGPMP)),Y=$O(^DGPM("APTT4",DFN,+DGPMP))
I X!Y S DGPMER=1 W !,"There is a",$S(X:"n admission",1:" check-in")," movement following this check-out.",!,"You can only remove a check-out when it is the last movement for the patient."
Q
5 ;check-out...delete pointer in check-out movement
S ^UTILITY("DGPM",$J,4,DGPMCA,"P")=$S($D(^UTILITY("DGPM",$J,4,DGPMCA,"P")):^("P"),1:DGPMAN)
S DA=DGPMDA,DIK="^DGPM(" D ^DIK
S ^UTILITY("DGPM",$J,4,DGPMCA,"A")=$G(^DGPM(DGPMCA,0))
Q
D6 ;can't delete ts mvt associated w/CA
I $P(DGPMP,"^",14),$P(DGPMP,"^",14)=$P(DGPMP,"^",24) S DGPMER=1 W !,"You are not allowed to delete a specialty transfer that is",!,"assoicated with the initial admission movement."
Q
6 ; -- treating specialty xfrs
Q
DD ;Delete discharge, update admission mvt, and PTF record
;pass in DGPMADM - admission mvt for which d/c is being deleted
Q:'$D(^DGPM(+DGPMADM,0)) S DA=$P(^(0),"^",17) I '$D(^DGPM(+DA,0)) Q
S ^UTILITY("DGPM",$J,1,DGPMADM,"P")=$S($D(^UTILITY("DGPM",$J,1,DGPMADM,"P")):^("P"),1:^DGPM(+DGPMADM,0)) ;adm mvt before deletion
S ^UTILITY("DGPM",$J,3,DA,"P")=^DGPM(DA,0),^("A")="",DIK="^DGPM(" D ^DIK
S ^UTILITY("DGPM",$J,1,DGPMADM,"A")=^DGPM(+DGPMADM,0) ;set after of admission
S DA=$P(^DGPM(DGPMADM,0),"^",16),DIE="^DGPT(",DR="70///@;71///@;72///@" D ^DIE
K DGPMADM Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMVDL1 3371 printed Sep 23, 2025@20:26:21 Page 2
DGPMVDL1 ;ALB/MIR - DELETE PATIENT MOVEMENTS, CONTINUED ; 11 JAN 88 @9
+1 ;;5.3;Registration;;Aug 13, 1993
D3 ;can this discharge be deleted?
+1 IF $PIECE(DGPMP,"^",18)=42
SET DGPMER=1
WRITE !,"You can not delete a WHILE ASIH type discharge"
QUIT
+2 IF $PIECE(DGPMAN,"^",21)
IF ("^41^46^"[("^"_+$PIECE(DGPMP,"^",18)_"^"))
SET DGPMER=1
WRITE !,"Delete through corresponding NHCU/DOM movements"
QUIT
+3 IF $ORDER(^DGPM("APTT1",DFN,+DGPMP))
SET DGPMER=1
WRITE !,"Can only delete discharge for last admission"
QUIT
+4 SET X=$ORDER(^DGPM("APTT1",DFN,+DGPMP))
SET Y=$ORDER(^DGPM("APTT4",DFN,+DGPMP))
+5 IF X!Y
SET DGPMER=1
WRITE !,"There is a",$SELECT(X:"n admission",1:" check-in")," movement following this discharge.",!,"You can only remove a discharge when it is the last movement for the patient."
QUIT
+6 IF $PIECE(DGPMP,"^",18)=47
IF ("^13^44^"[("^"_$PIECE(DGPM0,"^",18)_"^"))
IF $DATA(^DGPM(+$PIECE(DGPM0,"^",15),0))
IF $PIECE(^(0),"^",17)
SET DGPMER=1
WRITE !,"You must delete the hospital discharge first"
QUIT
+7 QUIT
3 IF $PIECE(DGPMP,"^",18)=47
GOTO 47
+1 SET DGPMADM=DGPMCA
DO DD
DO DS^DGPTMSG1
+2 KILL DA
if $PIECE(DGPMAN,"^",18)'=40
QUIT
IF $DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0))
SET DGPMTN=^(0)
SET DGPMNI=$PIECE(DGPMTN,"^",14)
IF $DATA(^DGPM(+DGPMNI,0))
SET DA=$PIECE(^(0),"^",17)
SET DGPMPTF=$PIECE(^(0),"^",16)
IF $DATA(^DGPM(+DA,0))
IF ($PIECE(^(0),"^",18)=47)
QUIT
+3 if '$DATA(DA)
QUIT
DO FINDLAST^DGPMV32
if 'DGPMAB
QUIT
SET X1=+DGPMAB
SET X2=30
DO C^%DTC
SET DGPMPD=X
SET DIE="^DGPM("
SET DR=".01///"_X_";.22////0"
+4 ;delete ASIH sequence and restore 30 days if deleting hospital discharge
KILL DQ,DG
if '$DATA(^DGPM(+DA,0))
QUIT
SET ^UTILITY("DGPM",$JOB,3,DA,"P")=^(0)
DO ^DIE
SET ^UTILITY("DGPM",$JOB,3,DA,"A")=^DGPM(DA,0)
+5 ;update PTF d/c d/t
SET DA=DGPMPTF
SET DIE="^DGPT("
SET DR="70////"_DGPMPD
DO ^DIE
+6 QUIT
47 ;if DISCHARGE FROM NHCU/DOM WHILE ASIH
+1 SET DGPMNI=+$PIECE(DGPMP,"^",14)
SET DGPMTN=DGPM0
DO FINDLAST^DGPMV32
+2 if '+DGPMAB
QUIT
SET X1=DGPMAB
SET X2=30
DO C^%DTC
SET DGMAS=42
DO FAMT^DGPMV30
SET DIE="^DGPM("
SET DA=DGPMDA
SET DR=".01///"_X_";.04////"_DGFAC
DO ^DIE
KILL DGFAC
+3 QUIT
D4 QUIT
4 ;check-in...delete all related lodger movements
+1 FOR DGI=DGPMDA:0
SET DGI=$ORDER(^DGPM("CA",DGPMDA,DGI))
if 'DGI
QUIT
IF $DATA(^DGPM(DGI,0))
SET DA=DGI
SET DIK="^DGPM("
DO ^DIK
+2 QUIT
D5 ;can't be followed by another movement
+1 SET X=$ORDER(^DGPM("APTT1",DFN,+DGPMP))
SET Y=$ORDER(^DGPM("APTT4",DFN,+DGPMP))
+2 IF X!Y
SET DGPMER=1
WRITE !,"There is a",$SELECT(X:"n admission",1:" check-in")," movement following this check-out.",!,"You can only remove a check-out when it is the last movement for the patient."
+3 QUIT
5 ;check-out...delete pointer in check-out movement
+1 SET ^UTILITY("DGPM",$JOB,4,DGPMCA,"P")=$SELECT($DATA(^UTILITY("DGPM",$JOB,4,DGPMCA,"P")):^("P"),1:DGPMAN)
+2 SET DA=DGPMDA
SET DIK="^DGPM("
DO ^DIK
+3 SET ^UTILITY("DGPM",$JOB,4,DGPMCA,"A")=$GET(^DGPM(DGPMCA,0))
+4 QUIT
D6 ;can't delete ts mvt associated w/CA
+1 IF $PIECE(DGPMP,"^",14)
IF $PIECE(DGPMP,"^",14)=$PIECE(DGPMP,"^",24)
SET DGPMER=1
WRITE !,"You are not allowed to delete a specialty transfer that is",!,"assoicated with the initial admission movement."
+2 QUIT
6 ; -- treating specialty xfrs
+1 QUIT
DD ;Delete discharge, update admission mvt, and PTF record
+1 ;pass in DGPMADM - admission mvt for which d/c is being deleted
+2 if '$DATA(^DGPM(+DGPMADM,0))
QUIT
SET DA=$PIECE(^(0),"^",17)
IF '$DATA(^DGPM(+DA,0))
QUIT
+3 ;adm mvt before deletion
SET ^UTILITY("DGPM",$JOB,1,DGPMADM,"P")=$SELECT($DATA(^UTILITY("DGPM",$JOB,1,DGPMADM,"P")):^("P"),1:^DGPM(+DGPMADM,0))
+4 SET ^UTILITY("DGPM",$JOB,3,DA,"P")=^DGPM(DA,0)
SET ^("A")=""
SET DIK="^DGPM("
DO ^DIK
+5 ;set after of admission
SET ^UTILITY("DGPM",$JOB,1,DGPMADM,"A")=^DGPM(+DGPMADM,0)
+6 SET DA=$PIECE(^DGPM(DGPMADM,0),"^",16)
SET DIE="^DGPT("
SET DR="70///@;71///@;72///@"
DO ^DIE
+7 KILL DGPMADM
QUIT
