PSO7M529 ;WILM/BDB - DEA DELETE ;05/15/2018
;;7.0;OUTPATIENT PHARMACY;**529**;DEC 1997;Build 94
;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
Q
;
START ;
N DEA,NPIEN,DA,DEAIEN,RSLT
S RSLT=$$ALERT()
I '+$G(RSLT) W !!,"Nothing deleted.",! Q
S DEA="A"
F S DEA=$O(^VA(200,"PS4",DEA)) Q:DEA="" D
.S NPIEN=0 S NPIEN=$O(^VA(200,"PS4",DEA,NPIEN)) Q:NPIEN="" D
..S DA=$O(^VA(200,"PS4",DEA,NPIEN,0)) Q:DA=""
..S DA(1)=NPIEN,DIK="^VA(200,"_DA(1)_",""PS4""," D ^DIK K DIK
S DEAIEN=0 F S DEAIEN=$O(^XTV(8991.9,DEAIEN)) Q:DEAIEN="" D
.S DA=DEAIEN,DIK="^XTV(8991.9," D ^DIK K DIK,DA
W !!,"The DEA profile data has been deleted from the DEA multiple fields"
W !,"in the New Person file (#200) and in the DEA Numbers file (#8991.9)."
Q
;
ALERT() ;
N Y,DIR
S DIR("A",1)=""
S DIR("A",2)=" ************************************************************"
S DIR("A",3)=" ** You are about to delete all DEA profile data for the **"
S DIR("A",4)=" ** new DEA multiple fields in the New Person file (#200) **"
S DIR("A",5)=" ** and in the DEA Numbers file (#8991.9). At the prompt **"
S DIR("A",6)=" ** enter ""YES"" to delete the data, or enter ""NO"" or ""^"" **"
S DIR("A",7)=" ** to exit without deleting. **"
S DIR("A",8)=" ************************************************************"
S DIR("A",9)=""
S DIR(0)="Y",DIR("A")="Delete the new multiple DEA profile data? "
S DIR("?")="Enter ""YES"" to delete the new multiple DEA profile data"
S DIR("??")=DIR("?")
S DIR("B")="NO" D ^DIR
Q $G(Y)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO7M529 1712 printed Dec 13, 2024@02:23:42 Page 2
PSO7M529 ;WILM/BDB - DEA DELETE ;05/15/2018
+1 ;;7.0;OUTPATIENT PHARMACY;**529**;DEC 1997;Build 94
+2 ;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
+3 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+4 QUIT
+5 ;
START ;
+1 NEW DEA,NPIEN,DA,DEAIEN,RSLT
+2 SET RSLT=$$ALERT()
+3 IF '+$GET(RSLT)
WRITE !!,"Nothing deleted.",!
QUIT
+4 SET DEA="A"
+5 FOR
SET DEA=$ORDER(^VA(200,"PS4",DEA))
if DEA=""
QUIT
Begin DoDot:1
+6 SET NPIEN=0
SET NPIEN=$ORDER(^VA(200,"PS4",DEA,NPIEN))
if NPIEN=""
QUIT
Begin DoDot:2
+7 SET DA=$ORDER(^VA(200,"PS4",DEA,NPIEN,0))
if DA=""
QUIT
+8 SET DA(1)=NPIEN
SET DIK="^VA(200,"_DA(1)_",""PS4"","
DO ^DIK
KILL DIK
End DoDot:2
End DoDot:1
+9 SET DEAIEN=0
FOR
SET DEAIEN=$ORDER(^XTV(8991.9,DEAIEN))
if DEAIEN=""
QUIT
Begin DoDot:1
+10 SET DA=DEAIEN
SET DIK="^XTV(8991.9,"
DO ^DIK
KILL DIK,DA
End DoDot:1
+11 WRITE !!,"The DEA profile data has been deleted from the DEA multiple fields"
+12 WRITE !,"in the New Person file (#200) and in the DEA Numbers file (#8991.9)."
+13 QUIT
+14 ;
ALERT() ;
+1 NEW Y,DIR
+2 SET DIR("A",1)=""
+3 SET DIR("A",2)=" ************************************************************"
+4 SET DIR("A",3)=" ** You are about to delete all DEA profile data for the **"
+5 SET DIR("A",4)=" ** new DEA multiple fields in the New Person file (#200) **"
+6 SET DIR("A",5)=" ** and in the DEA Numbers file (#8991.9). At the prompt **"
+7 SET DIR("A",6)=" ** enter ""YES"" to delete the data, or enter ""NO"" or ""^"" **"
+8 SET DIR("A",7)=" ** to exit without deleting. **"
+9 SET DIR("A",8)=" ************************************************************"
+10 SET DIR("A",9)=""
+11 SET DIR(0)="Y"
SET DIR("A")="Delete the new multiple DEA profile data? "
+12 SET DIR("?")="Enter ""YES"" to delete the new multiple DEA profile data"
+13 SET DIR("??")=DIR("?")
+14 SET DIR("B")="NO"
DO ^DIR
+15 QUIT $GET(Y)
+16 ;
