- 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
