- DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 2/13/04 1:01pm
- ;;5.3;Registration;**161,517,1015**;Aug 13, 1993;Build 21
- ;IHS/ANMC/LJF 3/09/2001 added IHS ^utility nodes
- ;
- ;D_DGPMT - these lines are used as DEL nodes. If DGPMER=1, movement can
- ; not be deleted.
- ;DGPMT - once the movement is to be deleted, these are the other
- ; updates that must also occur.
- ;
- 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
- I DGPMER W !,"Cannot delete before ASIH transfers are removed" Q
- I $P(DGPMAN,"^",21),$P(DGPMAN,"^",17) S DGPMER=1 W !,"Must delete discharge first"
- I $O(^DGPT("ACENSUS",+$P(DGPMAN,U,16),0)) S DGPMER=1 W !,"Cannot delete while PTF Census record #",$O(^(0))," is closed."
- Q
- 1 ;ihs/cmi/maw 06/18/2012 PATCH 1015 removed the delete of ptf to match patch 1013 code
- ;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
- ;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
- ;I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT ENTRIES." K FLAG H 2 Q
- S DGMSG="Patient admission has been deleted for admit date: "_$$FMTE^XLFDT(+DGPMAN,"5DZ"),DGMSG1="Deleted Admission"
- D MSG^DGPTMSG1 S DA=$P(DGPMAN,U,16),DIK="^DGPT(" D ^DIK:DA>0 K FLAG,I,DA,DIK ; delete PTF record
- 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
- ;IHS/ANMC/LJF 3/09/2001 added IHS nodes to ^utility
- ;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
- F DGI=DGPMDA:0 S DGI=$O(^DGPM("CA",DGPMDA,DGI)) Q:'DGI I $D(^DGPM(DGI,0)) D
- . S DGPMTYP=$P(^(0),"^",2),DA=DGI,DIK="^DGPM(",^UTILITY("DGPM",$J,DGPMTYP,DA,"P")=^(0),^("A")=""
- . S ^UTILITY("DGPM",$J,DGPMTYP,DA,"IHSP")=$G(^DGPM(DGI,"IHS")),^UTILITY("DGPM",$J,DGPMTYP,DA,"IHSA")=""
- . D ^DIK
- ;IHS/ANMC/LJF 3/09/2001 end of changes
- 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",!
- G Q1:($P(DGX1,"^",18)'=13) S DGPMADM=$P(DGX1,"^",14) D DD^DGPMVDL1
- Q1 K ORQUIT Q
- Q Q
- D2 ;Can this transfer be deleted?
- I $P(DGPMP,"^",18)=43,($P(DGPM2,"^",18)=42) S DGPMER=0 Q
- 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
- I "^13^44^"[("^"_$P(DGPMP,"^",18)_"^") S DGPMER=1 W !,"Must delete through corresponding hospital admission" Q
- I $P(DGPMP,"^",18)=14,$P(DGPMAN,"^",17) S DGPMER=1 W !,"Cannot delete while discharge exists" Q
- 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
- 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
- Q
- 2 I DGPMABL,DGPM0 S DGPMND=DGPM0 D AB^DGPMV32
- S DGPMTYP=$P(DGPMP,"^",18) I DGPMTYP=43 S DGPMADM=DGPMCA D DD^DGPMVDL1 Q
- 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
- 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
- Q:'DGX I "^13^44^"[("^"_$P(^DGPM(DGJ,0),"^",18)_"^") S DGPMADM=$P(^(0),"^",15) I $P(DGPMP,"^",22) D DD^DGPMVDL1
- Q:$P(^DGPM(DGJ,0),"^",18)=44 S DGPMAB=+^DGPM(DGJ,0) D ASIHOF^DGPMV321 ;recreate 30 days
- Q
- DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 2/13/04 1:01pm
- +1 ;;5.3;Registration;**161,517,1015**;Aug 13, 1993;Build 21
- +2 ;IHS/ANMC/LJF 3/09/2001 added IHS ^utility nodes
- +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 ;
- D1 SET DGPMER=0
- FOR I=0:0
- SET I=$ORDER(^DGPM("APMV",DFN,DGPMCA,I))
- IF I'>0
- QUIT
- SET J=$ORDER(^(I,0))
- IF $DATA(^DGPM(J,0))
- IF ($PIECE(^(0),"^",15)]"")
- SET DGPMER=1
- QUIT
- +1 IF DGPMER
- WRITE !,"Cannot delete before ASIH transfers are removed"
- QUIT
- +2 IF $PIECE(DGPMAN,"^",21)
- IF $PIECE(DGPMAN,"^",17)
- SET DGPMER=1
- WRITE !,"Must delete discharge first"
- +3 IF $ORDER(^DGPT("ACENSUS",+$PIECE(DGPMAN,U,16),0))
- SET DGPMER=1
- WRITE !,"Cannot delete while PTF Census record #",$ORDER(^(0))," is closed."
- +4 QUIT
- 1 ;ihs/cmi/maw 06/18/2012 PATCH 1015 removed the delete of ptf to match patch 1013 code
- +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
- +2 ;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
- +3 ;I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT ENTRIES." K FLAG H 2 Q
- +4 SET DGMSG="Patient admission has been deleted for admit date: "_$$FMTE^XLFDT(+DGPMAN,"5DZ")
- SET DGMSG1="Deleted Admission"
- +5 ; delete PTF record
- DO MSG^DGPTMSG1
- SET DA=$PIECE(DGPMAN,U,16)
- SET DIK="^DGPT("
- IF DA>0
- DO ^DIK
- KILL FLAG,I,DA,DIK
- +6 ;remove scheduled admission reference in 41.1
- SET DA=$ORDER(^DGS(41.1,"AMVT",DGPMDA,0))
- IF DA
- SET DIE="^DGS(41.1,"
- SET DR="17///@"
- DO ^DIE
- +7 ;IHS/ANMC/LJF 3/09/2001 added IHS nodes to ^utility
- +8 ;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
- +9 FOR DGI=DGPMDA:0
- SET DGI=$ORDER(^DGPM("CA",DGPMDA,DGI))
- IF 'DGI
- QUIT
- IF $DATA(^DGPM(DGI,0))
- Begin DoDot:1
- +10 SET DGPMTYP=$PIECE(^(0),"^",2)
- SET DA=DGI
- SET DIK="^DGPM("
- SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"P")=^(0)
- SET ^("A")=""
- +11 SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"IHSP")=$GET(^DGPM(DGI,"IHS"))
- SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"IHSA")=""
- +12 DO ^DIK
- End DoDot:1
- +13 ;IHS/ANMC/LJF 3/09/2001 end of changes
- +14 SET DGX=$PIECE(DGPMAN,"^",21)
- IF 'DGX
- GOTO Q1
- SET DIK="^DGPM("
- SET DA=DGX
- IF $DATA(^DGPM(+DA,0))
- SET DGX1=^(0)
- SET ^UTILITY("DGPM",$JOB,2,DA,"P")=^(0)
- SET ^("A")=""
- DO ^DIK
- WRITE !,"ASIH transfer deleted",!
- +15 IF ($PIECE(DGX1,"^",18)'=13)
- GOTO Q1
- SET DGPMADM=$PIECE(DGX1,"^",14)
- DO DD^DGPMVDL1
- Q1 KILL ORQUIT
- QUIT
- Q QUIT
- D2 ;Can this transfer be deleted?
- +1 IF $PIECE(DGPMP,"^",18)=43
- IF ($PIECE(DGPM2,"^",18)=42)
- SET DGPMER=0
- QUIT
- +2 IF DGPM2
- IF '$DATA(^DG(405.1,+$PIECE(DGPM2,"^",4),"F",+$PIECE(DGPM0,"^",4),0))
- SET DGPMER=1
- WRITE !,"Cannot delete transfer - would create an invalid transfer pair"
- QUIT
- +3 IF "^13^44^"[("^"_$PIECE(DGPMP,"^",18)_"^")
- SET DGPMER=1
- WRITE !,"Must delete through corresponding hospital admission"
- QUIT
- +4 IF $PIECE(DGPMP,"^",18)=14
- IF $PIECE(DGPMAN,"^",17)
- SET DGPMER=1
- WRITE !,"Cannot delete while discharge exists"
- QUIT
- +5 IF $DATA(^DGPM(+$PIECE(DGPMP,"^",15),0))
- IF $DATA(^DGP(45.84,+$PIECE(^(0),"^",16)))
- SET DGPMER=1
- WRITE !,"Cannot delete when corresponding admission PTF closed out"
- QUIT
- +6 IF "^14^43^45^"[("^"_$PIECE(DGPMP,"^",18)_"^")
- IF ("^13^14^43^44^45^"[("^"_$PIECE(DGPM2,"^",18)_"^"))
- SET DGX=$SELECT($DATA(^DG(405.1,+$PIECE(DGPM2,"^",4),0)):$PIECE(^(0),"^",1),1:"")
- WRITE !,DGX," movement must be removed first"
- SET DGPMER=1
- QUIT
- +7 QUIT
- 2 IF DGPMABL
- IF DGPM0
- SET DGPMND=DGPM0
- DO AB^DGPMV32
- +1 SET DGPMTYP=$PIECE(DGPMP,"^",18)
- IF DGPMTYP=43
- SET DGPMADM=DGPMCA
- DO DD^DGPMVDL1
- QUIT
- +2 IF DGPMTYP=45
- IF '$PIECE(DGPMP,"^",22)
- QUIT
- SET DGX=$ORDER(^DGPM("APTT3",DFN,DGPMP+.0000001,0))
- IF $DATA(^DGPM(+DGX,0))
- SET DGPMADM=$PIECE(^(0),"^",14)
- DO DD^DGPMVDL1
- QUIT
- +3 IF DGPMTYP'=14
- QUIT
- SET DGX=0
- FOR I=(9999999.9999999-DGPMP):0
- SET I=$ORDER(^DGPM("ATID2",DFN,I))
- IF 'I
- QUIT
- SET DGJ=$ORDER(^(I,0))
- IF $DATA(^DGPM(+DGJ,0))
- IF ("^13^43^44^"[("^"_$PIECE(^(0),"^",18)_"^"))
- SET DGX=1
- QUIT
- +4 IF 'DGX
- QUIT
- IF "^13^44^"[("^"_$PIECE(^DGPM(DGJ,0),"^",18)_"^")
- SET DGPMADM=$PIECE(^(0),"^",15)
- IF $PIECE(DGPMP,"^",22)
- DO DD^DGPMVDL1
- +5 ;recreate 30 days
- IF $PIECE(^DGPM(DGJ,0),"^",18)=44
- QUIT
- SET DGPMAB=+^DGPM(DGJ,0)
- DO ASIHOF^DGPMV321
- +6 QUIT
