source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMVDL.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 2/13/04 1:01pm
2 ;;5.3;Registration;**161,517**;Aug 13, 1993
3 ;
4 ;D_DGPMT - these lines are used as DEL nodes. If DGPMER=1, movement can
5 ; not be deleted.
6 ;DGPMT - once the movement is to be deleted, these are the other
7 ; updates that must also occur.
8 ;
9D1 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
10 I DGPMER W !,"Cannot delete before ASIH transfers are removed" Q
11 I $P(DGPMAN,"^",21),$P(DGPMAN,"^",17) S DGPMER=1 W !,"Must delete discharge first"
12 I $O(^DGPT("ACENSUS",+$P(DGPMAN,U,16),0)) S DGPMER=1 W !,"Cannot delete while PTF Census record #",$O(^(0))," is closed."
13 Q
141 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
15 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
16 I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT ENTRIES." K FLAG H 2 Q
17 S DGMSG="Patient admission has been deleted for admit date: "_$$FMTE^XLFDT(+DGPMAN,"5DZ"),DGMSG1="Deleted Admission"
18 D MSG^DGPTMSG1 S DA=$P(DGPMAN,U,16),DIK="^DGPT(" D ^DIK:DA>0 K FLAG,I,DA,DIK ; delete PTF record
19 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
20 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
21 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",!
22 G Q1:($P(DGX1,"^",18)'=13) S DGPMADM=$P(DGX1,"^",14) D DD^DGPMVDL1
23Q1 K ORQUIT Q
24Q Q
25D2 ;Can this transfer be deleted?
26 I $P(DGPMP,"^",18)=43,($P(DGPM2,"^",18)=42) S DGPMER=0 Q
27 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
28 I "^13^44^"[("^"_$P(DGPMP,"^",18)_"^") S DGPMER=1 W !,"Must delete through corresponding hospital admission" Q
29 I $P(DGPMP,"^",18)=14,$P(DGPMAN,"^",17) S DGPMER=1 W !,"Cannot delete while discharge exists" Q
30 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
31 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
32 Q
332 I DGPMABL,DGPM0 S DGPMND=DGPM0 D AB^DGPMV32
34 S DGPMTYP=$P(DGPMP,"^",18) I DGPMTYP=43 S DGPMADM=DGPMCA D DD^DGPMVDL1 Q
35 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
36 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
37 Q:'DGX I "^13^44^"[("^"_$P(^DGPM(DGJ,0),"^",18)_"^") S DGPMADM=$P(^(0),"^",15) I $P(DGPMP,"^",22) D DD^DGPMVDL1
38 Q:$P(^DGPM(DGJ,0),"^",18)=44 S DGPMAB=+^DGPM(DGJ,0) D ASIHOF^DGPMV321 ;recreate 30 days
39 Q
Note: See TracBrowser for help on using the repository browser.