| [613] | 1 | DGPMVDL ;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 | ;
|
|---|
| 9 | 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
|
|---|
| 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
|
|---|
| 14 | 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
|
|---|
| 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
|
|---|
| 23 | Q1 K ORQUIT Q
|
|---|
| 24 | Q Q
|
|---|
| 25 | D2 ;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
|
|---|
| 33 | 2 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
|
|---|
