Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPMVDL1

DGPMVDL1.m

Go to the documentation of this file.
  1. DGPMVDL1 ;ALB/MIR - DELETE PATIENT MOVEMENTS, CONTINUED ; 11 JAN 88 @9
  1. ;;5.3;Registration;;Aug 13, 1993
  1. D3 ;can this discharge be deleted?
  1. I $P(DGPMP,"^",18)=42 S DGPMER=1 W !,"You can not delete a WHILE ASIH type discharge" Q
  1. I $P(DGPMAN,"^",21),("^41^46^"[("^"_+$P(DGPMP,"^",18)_"^")) S DGPMER=1 W !,"Delete through corresponding NHCU/DOM movements" Q
  1. I $O(^DGPM("APTT1",DFN,+DGPMP)) S DGPMER=1 W !,"Can only delete discharge for last admission" Q
  1. S X=$O(^DGPM("APTT1",DFN,+DGPMP)),Y=$O(^DGPM("APTT4",DFN,+DGPMP))
  1. 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
  1. 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
  1. Q
  1. 3 I $P(DGPMP,"^",18)=47 G 47
  1. S DGPMADM=DGPMCA D DD,DS^DGPTMSG1
  1. 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
  1. 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"
  1. 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
  1. S DA=DGPMPTF,DIE="^DGPT(",DR="70////"_DGPMPD D ^DIE ;update PTF d/c d/t
  1. Q
  1. 47 ;if DISCHARGE FROM NHCU/DOM WHILE ASIH
  1. S DGPMNI=+$P(DGPMP,"^",14),DGPMTN=DGPM0 D FINDLAST^DGPMV32
  1. 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
  1. Q
  1. D4 Q
  1. 4 ;check-in...delete all related lodger movements
  1. 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
  1. Q
  1. D5 ;can't be followed by another movement
  1. S X=$O(^DGPM("APTT1",DFN,+DGPMP)),Y=$O(^DGPM("APTT4",DFN,+DGPMP))
  1. 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."
  1. Q
  1. 5 ;check-out...delete pointer in check-out movement
  1. S ^UTILITY("DGPM",$J,4,DGPMCA,"P")=$S($D(^UTILITY("DGPM",$J,4,DGPMCA,"P")):^("P"),1:DGPMAN)
  1. S DA=DGPMDA,DIK="^DGPM(" D ^DIK
  1. S ^UTILITY("DGPM",$J,4,DGPMCA,"A")=$G(^DGPM(DGPMCA,0))
  1. Q
  1. D6 ;can't delete ts mvt associated w/CA
  1. 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."
  1. Q
  1. 6 ; -- treating specialty xfrs
  1. Q
  1. DD ;Delete discharge, update admission mvt, and PTF record
  1. ;pass in DGPMADM - admission mvt for which d/c is being deleted
  1. Q:'$D(^DGPM(+DGPMADM,0)) S DA=$P(^(0),"^",17) I '$D(^DGPM(+DA,0)) Q
  1. S ^UTILITY("DGPM",$J,1,DGPMADM,"P")=$S($D(^UTILITY("DGPM",$J,1,DGPMADM,"P")):^("P"),1:^DGPM(+DGPMADM,0)) ;adm mvt before deletion
  1. S ^UTILITY("DGPM",$J,3,DA,"P")=^DGPM(DA,0),^("A")="",DIK="^DGPM(" D ^DIK
  1. S ^UTILITY("DGPM",$J,1,DGPMADM,"A")=^DGPM(+DGPMADM,0) ;set after of admission
  1. S DA=$P(^DGPM(DGPMADM,0),"^",16),DIE="^DGPT(",DR="70///@;71///@;72///@" D ^DIE
  1. K DGPMADM Q