- 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