DGREGDEL.m

DGREGDEL ;ALB/XAK - DELETE A REGISTRATION ;01 JAN 86

 ;;5.3;Registration;**107,1015**;Aug 13, 1993;Build 21

FIND W !! S DIC="^DPT(",DIC(0)="AEQMZ",DIC("S")="S I=$O(^DPT(Y,""DIS"",0)),I=$S(I>0:^(I,0),1:"""") I I]"""",'$P(I,U,6)" D ^DIC K DIC("S"),DIC("A") G Q:Y'>0 S (DA,DFN)=+Y

 S I=$O(^DPT(DFN,"DIS",0)) I I']"" W !!,"No registrations on file." G FIND

 S X=^DPT(DFN,"DIS",I,0) I $P(X,"^",6),$P(X,"^",7) W !!,"All registrations are dispositioned." G FIND

 S:'$D(^DPT(DA,"DIS",0)) ^(0)="^2.101D^"_I_"^"

 W ! N IOM S DIC="^DPT("_DFN_",""DIS"",",DA=I,DR=0,IOM=40 D EN^DIQ

W W !,"Are you sure you want to delete this registration" S %=2 D YN^DICN I %,%'=1 G FIND

 I '% W !!?4,*7,"YES - If you want to permanently remove this registration.",!?4,"NO  - If you wish to retain this registration data on file.",! G W

 S DIK=DIC,DA(1)=DFN D ^DIK W !,"Deleted.",! G FIND

Q K DIC,DIK,DA,DFN,DGIOM Q

DGREGDEL  ;ALB/XAK - DELETE A REGISTRATION ;01 JAN 86

 +1       ;;5.3;Registration;**107,1015**;Aug 13, 1993;Build 21

FIND       WRITE !!

           SET DIC="^DPT("

           SET DIC(0)="AEQMZ"

           SET DIC("S")="S I=$O(^DPT(Y,""DIS"",0)),I=$S(I>0:^(I,0),1:"""") I I]"""",'$P(I,U,6)"

           DO ^DIC

           KILL DIC("S"),DIC("A")

           IF Y'>0

               GOTO Q

           SET (DA,DFN)=+Y

 +1        SET I=$ORDER(^DPT(DFN,"DIS",0))

           IF I']""

               WRITE !!,"No registrations on file."

               GOTO FIND

 +2        SET X=^DPT(DFN,"DIS",I,0)

           IF $PIECE(X,"^",6)

               IF $PIECE(X,"^",7)

                   WRITE !!,"All registrations are dispositioned."

                   GOTO FIND

 +3        IF '$DATA(^DPT(DA,"DIS",0))

               SET ^(0)="^2.101D^"_I_"^"

 +4        WRITE !

           NEW IOM

           SET DIC="^DPT("_DFN_",""DIS"","

           SET DA=I

           SET DR=0

           SET IOM=40

           DO EN^DIQ

W          WRITE !,"Are you sure you want to delete this registration"

           SET %=2

           DO YN^DICN

           IF %

               IF %'=1

                   GOTO FIND

 +1        IF '%

               WRITE !!?4,*7,"YES - If you want to permanently remove this registration.",!?4,"NO  - If you wish to retain this registration data on file.",!

               GOTO W

 +2        SET DIK=DIC

           SET DA(1)=DFN

           DO ^DIK

           WRITE !,"Deleted.",!

           GOTO FIND

Q          KILL DIC,DIK,DA,DFN,DGIOM

           QUIT