- 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 Feb 19, 2025@00:16:30 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