ACMDALLR ; IHS/TUCSON/TMJ - DELETE ALL REGISTERS & LIST DATA ;
;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996
;;WRITTEN FOR DEMO AND TRAINING OHPRD TUCSON
;;THIS ROUTINE WILL DELETE ++ALL++ REGISTERS FOR TRG PURPOSES
EN D DELREG
EXIT K ACMRGTP,ACMRG,ACMRGNA,ACMI,ACMGREF,ACMCTRL,ACMCTRLE,ACMCTRLP,ACMCTRLS,ACMCTRLX,ACMDELRG,ACMCTR,ACMCTR2,ACZ
Q
DELREG W:$D(IOF) @IOF
W !,"WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING",*7,*7,*7,!!,"The next procedure will allow you to COMPLETELY delete ALL Registers from"
W !,"the Case Management System. The register, including all patients and all",!,"information on all patients will be deleted WITH NO POSSIBILITY of recovering"
W !,"any of the data. Be absolutely certain this is what you want before proceding."
S DIR(0)="YO",DIR("A")="Shall I make you an authorized user for all registers",DIR("B")="NO"
W !
D ^DIR K DIR
Q:Y=""!(Y["^") I Y=1 S Y=DUZ D SUSR0
D SAVE Q:$D(ACMQ)
S DIR(0)="YO",DIR("A")="Delete all other registers and data",DIR("B")="NO"
W !
D ^DIR K DIR
Q:Y'=1
W !!,"First I will remove unreferenced pointers..." D FRESH
W !,"...Finished...Starting Deletions..."
S ACMCTR=0 F S ACMCTR=$O(^ACM(41.1,"B",ACMCTR)) Q:ACMCTR="" D DELETE
W !!,"...Deleting all REGISTERS completed",!
Q
DELETE ;
S ACMRG=0,ACMRG=$O(^ACM(41.1,"B",ACMCTR,ACMRG)),ACMRGNA=$P(^ACM(41.1,ACMRG,0),U,1)
I $D(^TMP("ACM",$J,ACMRGNA)) W !!,"...Saving Register: ",ACMRGNA,!! Q
W !!,"...Deleting all PATIENT related data...for register: ",ACMRGNA
F ACMI=42,43,44,45,46,47,48,51,53,54 S ACMGREF="^ACM("_ACMI_")" S DA=0 F S DA=$O(@ACMGREF@("F",ACMRGNA,DA)) Q:'DA W "." S DIK="^ACM("_ACMI_"," D ^DIK
K DIK,DIC,DA
W !,"...Deleting all REGISTER related list entries...for register: ",ACMRGNA
F ACMI=42.1,43.1,44.1,45.1,47.1,48,50,51.1,53.1,54.1 S ACMGREF="^ACM("_ACMI_")" S DA(1)=0 F S DA(1)=$O(@ACMGREF@("RG",ACMRG,DA(1))) Q:'DA(1) D
.S DA=0
.F S DA=$O(@ACMGREF@("RG",ACMRG,DA(1),DA)) Q:'DA W "." S DIK="^ACM("_ACMI_","_DA(1)_",""RG""," D ^DIK D DELLST
K DIK,DIC,DA
W !,"...Deleting all PATIENTS from the register...",ACMRGNA
S DIK="^ACM(41,",DA=0
F S DA=$O(^ACM(41,"B",ACMRG,DA)) Q:'DA W "." D ^DIK
K DIK,DIC,DA
W !,"...Deleting the register...",ACMRGNA
S DIK="^ACM(41.1,",DA=ACMRG D ^DIK
K DIK,DIC,DA
W !,"The ",ACMRGNA," and all related data have been deleted.",!! H 3
Q
DELLST S DA=DA(1) S ACMCTR2=0,ACMCTR2=$O(@ACMGREF@(DA,"RG",ACMCTR2)) Q:ACMCTR2'="" W "." S DIK="^ACM("_ACMI_"," D ^DIK
Q
FRESH F ACMI=42.1,43.1,44.1,45.1,47.1,48,50,51.1,53.1,54.1 D FRESH1
Q
FRESH1 ;
S ACZ=0 F S ACZ=$O(^ACM(ACMI,ACZ)) Q:+ACZ=0 D FRESH2
Q
FRESH2 ;
S X=0,X=$O(^ACM(ACMI,ACZ,"RG",X)) Q:X'=""
S DIK="^ACM("_ACMI_",",DA=ACZ D ^DIK W "."
Q
SAVE ;ALLOWS USER TO SAVE EXISTING REGISTERS FROM DELETION
K ACMQ,^TMP("ACM",$J)
S DIR(0)="YO",DIR("A")="Save an existing register(s)",DIR("B")="NO"
W !
D ^DIR K DIR
S:Y["^" ACMQ=1 Q:Y'=1
SAVE1 S (ACMRGTP,ACMDELRG)="" D RGTPX^ACMGTPZ
I '$D(ACMRG) W !,"FINISHED..." D DSPSAV H 2 Q
S ACMRGNA=$P(^ACM(41.1,ACMRG,0),U,1) S ^TMP("ACM",$J,ACMRGNA)="" W !,"Saving ",ACMRGNA G SAVE1
;
DSPSAV ;DISPLAYS SAVED REGISTERS
W !!!,"Saved Registers include: " S X=0 F S X=$O(^TMP("ACM",$J,X)) Q:X="" W !,"Register: ",X
W !! Q
SUSR S DIC="^VA(200,",DIC(0)="AQEM" D ^DIC Q:+Y<1
SUSR0 S ACMX=0,ACMY=+Y F S ACMX=$O(^ACM(41.1,ACMX)) Q:+ACMX=0 D SUSR1
W !,"User is now authorized for ALL registers...",!!
Q
SUSR1 ;
I '$D(^ACM(41.1,ACMX,"AU",0)) S ^ACM(41.1,ACMX,"UA",0)="^9002241.12P^0^0"
S DIE="^ACM(41.1,ACMX,""AU"",",DA(1)=ACMX,DA=ACMY,DR=".01///^S X=DA",DIC(0)="LX" D ^DIE Q
ACMDALLR ; IHS/TUCSON/TMJ - DELETE ALL REGISTERS & LIST DATA ;
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996
+2 ;;WRITTEN FOR DEMO AND TRAINING OHPRD TUCSON
+3 ;;THIS ROUTINE WILL DELETE ++ALL++ REGISTERS FOR TRG PURPOSES
EN DO DELREG
EXIT KILL ACMRGTP,ACMRG,ACMRGNA,ACMI,ACMGREF,ACMCTRL,ACMCTRLE,ACMCTRLP,ACMCTRLS,ACMCTRLX,ACMDELRG,ACMCTR,ACMCTR2,ACZ
+1 QUIT
DELREG IF $DATA(IOF)
WRITE @IOF
+1 WRITE !,"WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING",*7,*7,*7,!!,"The next procedure will allow you to COMPLETELY delete ALL Registers from"
+2 WRITE !,"the Case Management System. The register, including all patients and all",!,"information on all patients will be deleted WITH NO POSSIBILITY of recovering"
+3 WRITE !,"any of the data. Be absolutely certain this is what you want before proceding."
+4 SET DIR(0)="YO"
SET DIR("A")="Shall I make you an authorized user for all registers"
SET DIR("B")="NO"
+5 WRITE !
+6 DO ^DIR
KILL DIR
+7 IF Y=""!(Y["^")
QUIT
IF Y=1
SET Y=DUZ
DO SUSR0
+8 DO SAVE
IF $DATA(ACMQ)
QUIT
+9 SET DIR(0)="YO"
SET DIR("A")="Delete all other registers and data"
SET DIR("B")="NO"
+10 WRITE !
+11 DO ^DIR
KILL DIR
+12 IF Y'=1
QUIT
+13 WRITE !!,"First I will remove unreferenced pointers..."
DO FRESH
+14 WRITE !,"...Finished...Starting Deletions..."
+15 SET ACMCTR=0
FOR
SET ACMCTR=$ORDER(^ACM(41.1,"B",ACMCTR))
IF ACMCTR=""
QUIT
DO DELETE
+16 WRITE !!,"...Deleting all REGISTERS completed",!
+17 QUIT
DELETE ;
+1 SET ACMRG=0
SET ACMRG=$ORDER(^ACM(41.1,"B",ACMCTR,ACMRG))
SET ACMRGNA=$PIECE(^ACM(41.1,ACMRG,0),U,1)
+2 IF $DATA(^TMP("ACM",$JOB,ACMRGNA))
WRITE !!,"...Saving Register: ",ACMRGNA,!!
QUIT
+3 WRITE !!,"...Deleting all PATIENT related data...for register: ",ACMRGNA
+4 FOR ACMI=42,43,44,45,46,47,48,51,53,54
SET ACMGREF="^ACM("_ACMI_")"
SET DA=0
FOR
SET DA=$ORDER(@ACMGREF@("F",ACMRGNA,DA))
IF 'DA
QUIT
WRITE "."
SET DIK="^ACM("_ACMI_","
DO ^DIK
+5 KILL DIK,DIC,DA
+6 WRITE !,"...Deleting all REGISTER related list entries...for register: ",ACMRGNA
+7 FOR ACMI=42.1,43.1,44.1,45.1,47.1,48,50,51.1,53.1,54.1
SET ACMGREF="^ACM("_ACMI_")"
SET DA(1)=0
FOR
SET DA(1)=$ORDER(@ACMGREF@("RG",ACMRG,DA(1)))
IF 'DA(1)
QUIT
Begin DoDot:1
+8 SET DA=0
+9 FOR
SET DA=$ORDER(@ACMGREF@("RG",ACMRG,DA(1),DA))
IF 'DA
QUIT
WRITE "."
SET DIK="^ACM("_ACMI_","_DA(1)_",""RG"","
DO ^DIK
DO DELLST
End DoDot:1
+10 KILL DIK,DIC,DA
+11 WRITE !,"...Deleting all PATIENTS from the register...",ACMRGNA
+12 SET DIK="^ACM(41,"
SET DA=0
+13 FOR
SET DA=$ORDER(^ACM(41,"B",ACMRG,DA))
IF 'DA
QUIT
WRITE "."
DO ^DIK
+14 KILL DIK,DIC,DA
+15 WRITE !,"...Deleting the register...",ACMRGNA
+16 SET DIK="^ACM(41.1,"
SET DA=ACMRG
DO ^DIK
+17 KILL DIK,DIC,DA
+18 WRITE !,"The ",ACMRGNA," and all related data have been deleted.",!!
HANG 3
+19 QUIT
DELLST SET DA=DA(1)
SET ACMCTR2=0
SET ACMCTR2=$ORDER(@ACMGREF@(DA,"RG",ACMCTR2))
IF ACMCTR2'=""
QUIT
WRITE "."
SET DIK="^ACM("_ACMI_","
DO ^DIK
+1 QUIT
FRESH FOR ACMI=42.1,43.1,44.1,45.1,47.1,48,50,51.1,53.1,54.1
DO FRESH1
+1 QUIT
FRESH1 ;
+1 SET ACZ=0
FOR
SET ACZ=$ORDER(^ACM(ACMI,ACZ))
IF +ACZ=0
QUIT
DO FRESH2
+2 QUIT
FRESH2 ;
+1 SET X=0
SET X=$ORDER(^ACM(ACMI,ACZ,"RG",X))
IF X'=""
QUIT
+2 SET DIK="^ACM("_ACMI_","
SET DA=ACZ
DO ^DIK
WRITE "."
+3 QUIT
SAVE ;ALLOWS USER TO SAVE EXISTING REGISTERS FROM DELETION
+1 KILL ACMQ,^TMP("ACM",$JOB)
+2 SET DIR(0)="YO"
SET DIR("A")="Save an existing register(s)"
SET DIR("B")="NO"
+3 WRITE !
+4 DO ^DIR
KILL DIR
+5 IF Y["^"
SET ACMQ=1
IF Y'=1
QUIT
SAVE1 SET (ACMRGTP,ACMDELRG)=""
DO RGTPX^ACMGTPZ
+1 IF '$DATA(ACMRG)
WRITE !,"FINISHED..."
DO DSPSAV
HANG 2
QUIT
+2 SET ACMRGNA=$PIECE(^ACM(41.1,ACMRG,0),U,1)
SET ^TMP("ACM",$JOB,ACMRGNA)=""
WRITE !,"Saving ",ACMRGNA
GOTO SAVE1
+3 ;
DSPSAV ;DISPLAYS SAVED REGISTERS
+1 WRITE !!!,"Saved Registers include: "
SET X=0
FOR
SET X=$ORDER(^TMP("ACM",$JOB,X))
IF X=""
QUIT
WRITE !,"Register: ",X
+2 WRITE !!
QUIT
SUSR SET DIC="^VA(200,"
SET DIC(0)="AQEM"
DO ^DIC
IF +Y<1
QUIT
SUSR0 SET ACMX=0
SET ACMY=+Y
FOR
SET ACMX=$ORDER(^ACM(41.1,ACMX))
IF +ACMX=0
QUIT
DO SUSR1
+1 WRITE !,"User is now authorized for ALL registers...",!!
+2 QUIT
SUSR1 ;
+1 IF '$DATA(^ACM(41.1,ACMX,"AU",0))
SET ^ACM(41.1,ACMX,"UA",0)="^9002241.12P^0^0"
+2 SET DIE="^ACM(41.1,ACMX,""AU"","
SET DA(1)=ACMX
SET DA=ACMY
SET DR=".01///^S X=DA"
SET DIC(0)="LX"
DO ^DIE
QUIT
