- DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 7/31/07 11:19am
- ;;5.3;Registration;**517,760**;Aug 13, 1993;Build 11
- ;
- A D LO^DGUTL I $D(^DISV(DUZ,"^DPT(")),$D(^("^DGPT(")) S A=+^("^DGPT("),B=+^("^DPT(") I $D(^DGPT(A,0)),$D(^DPT(B,0)) S:(+^DGPT(A,0)'=B&$D(^DGPT("B",B))) ^DISV(DUZ,"^DGPT(")=""
- Q
- ;
- ASK D A W !!
- S Y=1 D RTY^DGPTUTL
- S DIC("S")="I $P(^(0),U,11)=1,'$D(^DGP(45.84,+Y))",DIC="^DGPT(",DIC(0)="NEAQ",DIC("A")="Enter PTF record to delete: "
- D ^DIC G Q:Y'>0 S DA=+Y,DIC(0)="NE",X=DA D CEN G ASK:'$D(DA)
- A1 W !! D ^DIC S %=2 W !,"Ok to delete" D YN^DICN
- I %=1 S DGPTIFN=DA D KDGPT W !,"****** DELETED ******" D HANG^DGPTUTL G Q
- AD I '% W !,"Anwer Yes or No",!,"On deletion pointers will be updated" G A1
- ;
- ;
- Q K DA,DFN,A,B,L,I,ANS,DIE,DR,DIK,DIC,DGRTY,DGRTY0,DGPTIFN Q
- ;
- HEL ;
- I '$D(DGRTY) S Y=1 D RTY^DGPTUTL
- D A W !!
- S DIC(0)="NEAQ",DIC="^DGP(45.84,",DIC("S")="I '$D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$P(^(0),U,11)="_DGRTY,DIC("A")="Enter "_$P(DGRTY0,U)_" record to re-open: "
- D ^DIC G Q:Y'>0 S (X,DGPTIFN)=+Y,%=2
- A2 I '% W !!,DGPTIFN," ",$P(^DPT(+^DGPT(DGPTIFN,0),0),U) S DGSENFLG="",X=DGPTIFN,DIC(0)="NE",DIC="^DGP(45.84," D ^DIC K DIC,DGSENFLG
- I DGRTY=2 D CHK G Q:'DGPTIFN
- S %=2 W !,"Ok to reactivate" D YN^DICN
- I '% W !,"Answer Yes or No" G A2
- G Q:%'=1
- D OPEN G Q
- ;
- OLD I '$D(^DISV(DUZ,"PTFAD",DFN)) W " ???",*7,*7 G AD
- S X=^(DFN)
- Q
- DREL ; -- open released rec
- I '$D(DGRTY) S Y=1 D RTY^DGPTUTL
- W ! S DIC("A")="Enter Released "_$P(DGRTY0,U)_" Record to Re-open: ",DIC("S")="I $D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$D(^(70)),+^(70)>2901000,$P(^(0),U,11)="_DGRTY,DIC="^DGP(45.84,",DIC(0)="MEQA"
- D ^DIC K DIC G Q:+Y'>0 S DGPTIFN=+Y
- I DGRTY=2 D CHK G Q:'DGPTIFN
- OK W !,"Ok to Re-open" S %=2 D YN^DICN
- I '% W !!?14,"Enter <RET> to exit routine",!?10,"Enter 'Y' for YES to RE-OPEN Record",! G OK
- G Q:%'=1
- S DA(1)=$O(^DGP(45.83,"C",DGPTIFN,0)) I DA(1) S DIK="^DGP(45.83,"_DA(1)_",""P"",",DA=DGPTIFN D ^DIK K DIK,DA
- D OPEN G Q
- ;
- OPEN ;
- D KDGP,KDGPT:DGRTY=2
- W !,"****** RECORD RE-OPENED ******" D HANG^DGPTUTL
- Q
- ;
- KDGP ; -- kill close-out rec ; input DGPTIFN := ifn
- S DA=DGPTIFN,DIK="^DGP(45.84," D ^DIK K DIK,DA
- Q
- ;
- KDGPT ; -- kill DGPT rec ; input DGPTIFN := ifn
- S DA=DGPTIFN,DIK="^DGPT(",FLAG=1,I=0 F S I=$O(^DGCPT(46,"C",DA,I)) Q:'I I '$G(^DGCPT(46,I,9)) S FLAG=0 Q
- I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT RECORDS." H 2 K FLAG Q
- D ^DIK K DA,DIK,I,FLAG
- I DGRTY=1 S DA=+$O(^DGPM("APTF",DGPTIFN,0)) I $D(^DGPM(DA,0)),$P(^(0),U,16)=DGPTIFN S DR=".16///@",DIE="^DGPM(" D ^DIE K DR,DIE
- K DA Q
- ;
- CHK ; -- check to see if PTF is open ; return DGPTIFN="" is not open
- I $D(^DGPT(+$P(^DGPT(DGPTIFN,0),U,12),0)),$P(^(0),U,6) W !!,*7,?5,"Associated PTF record #",+$P(^DGPT(DGPTIFN,0),U,12)," must be RE-OPENED",!?5,"in order to re-open Census record #",DGPTIFN,"." S DGPTIFN=""
- Q
- ;
- CEN ; -- check if closed for census
- K DGI
- F DGI=0:0 S DGI=$O(^DGPT("ACENSUS",DA,DGI)) Q:'DGI I $D(^DGPT(DGI,0)),$P(^(0),U,12)=DA,$D(^DG(45.86,+$P(^(0),U,13),0)) S Y=+^(0) X ^DD("DD") S DGI(DGI)=Y
- G CENQ:$D(DGI)<10
- W !!?2,*7,"This PTF record is associated with the following Census records:"
- F DGI=0:0 S DGI=$O(DGI(DGI)) Q:'DGI W !?10,"Census Record #",DGI,?35,"==>",?40,"Census Date: ",DGI(DGI)
- W !!?2,"PTF record can not be deleted."
- K DA
- CENQ K DGI Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFDEL 3399 printed Jan 18, 2025@03:52:50 Page 2
- DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 7/31/07 11:19am
- +1 ;;5.3;Registration;**517,760**;Aug 13, 1993;Build 11
- +2 ;
- A DO LO^DGUTL
- IF $DATA(^DISV(DUZ,"^DPT("))
- IF $DATA(^("^DGPT("))
- SET A=+^("^DGPT(")
- SET B=+^("^DPT(")
- IF $DATA(^DGPT(A,0))
- IF $DATA(^DPT(B,0))
- if (+^DGPT(A,0)'=B&$DATA(^DGPT("B",B)))
- SET ^DISV(DUZ,"^DGPT(")=""
- +1 QUIT
- +2 ;
- ASK DO A
- WRITE !!
- +1 SET Y=1
- DO RTY^DGPTUTL
- +2 SET DIC("S")="I $P(^(0),U,11)=1,'$D(^DGP(45.84,+Y))"
- SET DIC="^DGPT("
- SET DIC(0)="NEAQ"
- SET DIC("A")="Enter PTF record to delete: "
- +3 DO ^DIC
- if Y'>0
- GOTO Q
- SET DA=+Y
- SET DIC(0)="NE"
- SET X=DA
- DO CEN
- if '$DATA(DA)
- GOTO ASK
- A1 WRITE !!
- DO ^DIC
- SET %=2
- WRITE !,"Ok to delete"
- DO YN^DICN
- +1 IF %=1
- SET DGPTIFN=DA
- DO KDGPT
- WRITE !,"****** DELETED ******"
- DO HANG^DGPTUTL
- GOTO Q
- AD IF '%
- WRITE !,"Anwer Yes or No",!,"On deletion pointers will be updated"
- GOTO A1
- +1 ;
- +2 ;
- Q KILL DA,DFN,A,B,L,I,ANS,DIE,DR,DIK,DIC,DGRTY,DGRTY0,DGPTIFN
- QUIT
- +1 ;
- HEL ;
- +1 IF '$DATA(DGRTY)
- SET Y=1
- DO RTY^DGPTUTL
- +2 DO A
- WRITE !!
- +3 SET DIC(0)="NEAQ"
- SET DIC="^DGP(45.84,"
- SET DIC("S")="I '$D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$P(^(0),U,11)="_DGRTY
- SET DIC("A")="Enter "_$PIECE(DGRTY0,U)_" record to re-open: "
- +4 DO ^DIC
- if Y'>0
- GOTO Q
- SET (X,DGPTIFN)=+Y
- SET %=2
- A2 IF '%
- WRITE !!,DGPTIFN," ",$PIECE(^DPT(+^DGPT(DGPTIFN,0),0),U)
- SET DGSENFLG=""
- SET X=DGPTIFN
- SET DIC(0)="NE"
- SET DIC="^DGP(45.84,"
- DO ^DIC
- KILL DIC,DGSENFLG
- +1 IF DGRTY=2
- DO CHK
- if 'DGPTIFN
- GOTO Q
- +2 SET %=2
- WRITE !,"Ok to reactivate"
- DO YN^DICN
- +3 IF '%
- WRITE !,"Answer Yes or No"
- GOTO A2
- +4 if %'=1
- GOTO Q
- +5 DO OPEN
- GOTO Q
- +6 ;
- OLD IF '$DATA(^DISV(DUZ,"PTFAD",DFN))
- WRITE " ???",*7,*7
- GOTO AD
- +1 SET X=^(DFN)
- +2 QUIT
- DREL ; -- open released rec
- +1 IF '$DATA(DGRTY)
- SET Y=1
- DO RTY^DGPTUTL
- +2 WRITE !
- SET DIC("A")="Enter Released "_$PIECE(DGRTY0,U)_" Record to Re-open: "
- SET DIC("S")="I $D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$D(^(70)),+^(70)>2901000,$P(^(0),U,11)="_DGRTY
- SET DIC="^DGP(45.84,"
- SET DIC(0)="MEQA"
- +3 DO ^DIC
- KILL DIC
- if +Y'>0
- GOTO Q
- SET DGPTIFN=+Y
- +4 IF DGRTY=2
- DO CHK
- if 'DGPTIFN
- GOTO Q
- OK WRITE !,"Ok to Re-open"
- SET %=2
- DO YN^DICN
- +1 IF '%
- WRITE !!?14,"Enter <RET> to exit routine",!?10,"Enter 'Y' for YES to RE-OPEN Record",!
- GOTO OK
- +2 if %'=1
- GOTO Q
- +3 SET DA(1)=$ORDER(^DGP(45.83,"C",DGPTIFN,0))
- IF DA(1)
- SET DIK="^DGP(45.83,"_DA(1)_",""P"","
- SET DA=DGPTIFN
- DO ^DIK
- KILL DIK,DA
- +4 DO OPEN
- GOTO Q
- +5 ;
- OPEN ;
- +1 DO KDGP
- if DGRTY=2
- DO KDGPT
- +2 WRITE !,"****** RECORD RE-OPENED ******"
- DO HANG^DGPTUTL
- +3 QUIT
- +4 ;
- KDGP ; -- kill close-out rec ; input DGPTIFN := ifn
- +1 SET DA=DGPTIFN
- SET DIK="^DGP(45.84,"
- DO ^DIK
- KILL DIK,DA
- +2 QUIT
- +3 ;
- KDGPT ; -- kill DGPT rec ; input DGPTIFN := ifn
- +1 SET DA=DGPTIFN
- SET DIK="^DGPT("
- SET FLAG=1
- SET I=0
- FOR
- SET I=$ORDER(^DGCPT(46,"C",DA,I))
- if 'I
- QUIT
- IF '$GET(^DGCPT(46,I,9))
- SET FLAG=0
- QUIT
- +2 IF 'FLAG
- WRITE !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT RECORDS."
- HANG 2
- KILL FLAG
- QUIT
- +3 DO ^DIK
- KILL DA,DIK,I,FLAG
- +4 IF DGRTY=1
- SET DA=+$ORDER(^DGPM("APTF",DGPTIFN,0))
- IF $DATA(^DGPM(DA,0))
- IF $PIECE(^(0),U,16)=DGPTIFN
- SET DR=".16///@"
- SET DIE="^DGPM("
- DO ^DIE
- KILL DR,DIE
- +5 KILL DA
- QUIT
- +6 ;
- CHK ; -- check to see if PTF is open ; return DGPTIFN="" is not open
- +1 IF $DATA(^DGPT(+$PIECE(^DGPT(DGPTIFN,0),U,12),0))
- IF $PIECE(^(0),U,6)
- WRITE !!,*7,?5,"Associated PTF record #",+$PIECE(^DGPT(DGPTIFN,0),U,12)," must be RE-OPENED",!?5,"in order to re-open Census record #",DGPTIFN,"."
- SET DGPTIFN=""
- +2 QUIT
- +3 ;
- CEN ; -- check if closed for census
- +1 KILL DGI
- +2 FOR DGI=0:0
- SET DGI=$ORDER(^DGPT("ACENSUS",DA,DGI))
- if 'DGI
- QUIT
- IF $DATA(^DGPT(DGI,0))
- IF $PIECE(^(0),U,12)=DA
- IF $DATA(^DG(45.86,+$PIECE(^(0),U,13),0))
- SET Y=+^(0)
- XECUTE ^DD("DD")
- SET DGI(DGI)=Y
- +3 if $DATA(DGI)<10
- GOTO CENQ
- +4 WRITE !!?2,*7,"This PTF record is associated with the following Census records:"
- +5 FOR DGI=0:0
- SET DGI=$ORDER(DGI(DGI))
- if 'DGI
- QUIT
- WRITE !?10,"Census Record #",DGI,?35,"==>",?40,"Census Date: ",DGI(DGI)
- +6 WRITE !!?2,"PTF record can not be deleted."
- +7 KILL DA
- CENQ KILL DGI
- QUIT