PXRMLREX ;SLC/PJH - Delete rule components ;07/03/2002
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;=====================================================================
;
;Yes/No Prompts
;--------------
ASK(YESNO,TEXT,HELP) ;
W !
N DIR,X,Y
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
M DIR("A")=TEXT
S DIR("B")="Y"
S DIR("?")="Enter Y or N. For detailed help type ??"
S DIR("??")=U_"D HLP^PXRMLREX(HELP)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
S YESNO=$E(Y(0))
Q
;
;Give option to delete all descendents
;-------------------------------------
DELETE(COMP) ;
N ANS,HLP,LRIEN,LRNAM,LRTYP,IC,TEXT
;Parent name and type
S LRNAM=$P(COMP(0),U)
;Prompt information
S TEXT(1)="List Rule Set "_LRNAM_" had unused components."
S TEXT="Delete all these component rules:"
;List component names
S IC=2,LRIEN=0,TEXT(2)="",HLP=1
F S LRIEN=$O(COMP(LRIEN)) Q:'LRIEN D Q:IC>15
.S IC=IC+1 I IC>15 S TEXT(IC)="<<more>>" Q
.N LRTYP
.S LRTYP=$P(COMP(LRIEN),U,2)
.S LRTYP=$S(LRTYP=1:"list rule",LRTYP=2:"reminder rule",1:"output rule")
.S TEXT(IC)=$P(COMP(LRIEN),U)_$J("",5)_LRTYP
S TEXT(IC+1)=""
;Ask Delete Y/N?
D ASK(.ANS,.TEXT,HLP) Q:$G(ANS)'="Y"
;Use DIK to remove all unused components
N DA,DIK
S LRIEN=0
;Scan list of unused components
F S LRIEN=$O(COMP(LRIEN)) Q:'LRIEN D
.;Delete component dialog
.S DA=LRIEN,DIK="^PXRM(810.4," D ^DIK
Q
;
;Build list of components
;------------------------
COMP(IEN,COMP) ;
;Build list of components
D COMPR(IEN,.COMP) Q:'$D(COMP)
;Get reminder dialog, group or element name and type
N DATA
S DATA=$G(^PXRM(810.4,IEN,0))
;Save for future use
S COMP(0)=$P(DATA,U)_U_$P(DATA,U,4)
Q
;
;Recursive call
;--------------
COMPR(IEN,COMP) ;
N DATA,LRIEN,LRNAME,LRTYP,PARENT,SUB
S LRIEN=0,PARENT="LOCAL"
;Check if parent is national
I $P($G(^PXRM(810.4,IEN,100)),U)="N" S PARENT="NATIONAL"
;
F S LRIEN=$O(^PXRM(810.4,IEN,30,"D",LRIEN)) Q:'LRIEN D
.;Ignore national components
.I $P($G(^PXRM(810.4,LRIEN,100)),U)="N",PARENT'="NATIONAL" Q
.;Ignore if in use
.I $$USED(LRIEN,IEN) Q
.;Save component dialog type and name
.S DATA=$G(^PXRM(810.4,LRIEN,0)),LRNAME=$P(DATA,U),LRTYP=$P(DATA,U,3)
.S COMP(LRIEN)=LRNAME_U_LRTYP
.;For groups and element check sub-components
.I (LRTYP="G")!(LRTYP="E") D COMPR(LRIEN,.COMP)
Q
;
;Check if in use
;---------------
USED(LRIEN,IEN) ;
N SUB,DINUSE
S SUB=0,DINUSE=0
F S SUB=$O(^PXRM(810.4,"AD",LRIEN,SUB)) Q:'SUB D Q:DINUSE
.;In use by other than parent
.I SUB'=IEN S DINUSE=1
Q DINUSE
;
;General help text routine.
;--------------------------
HLP(CALL) ;
N HTEXT
N DIWF,DIWL,DIWR,IC
S DIWF="C75",DIWL=0,DIWR=75
;
I CALL=1 D
.S HTEXT(1)="Enter 'Yes' to DELETE all sub-components listed above"
.S HTEXT(2)="or enter 'No' to quit."
;
D HELP^PXRMEUT(.HTEXT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLREX 2932 printed Oct 16, 2024@17:47:29 Page 2
PXRMLREX ;SLC/PJH - Delete rule components ;07/03/2002
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
+3 ;=====================================================================
+4 ;
+5 ;Yes/No Prompts
+6 ;--------------
ASK(YESNO,TEXT,HELP) ;
+1 WRITE !
+2 NEW DIR,X,Y
+3 KILL DIROUT,DIRUT,DTOUT,DUOUT
+4 SET DIR(0)="YA0"
+5 MERGE DIR("A")=TEXT
+6 SET DIR("B")="Y"
+7 SET DIR("?")="Enter Y or N. For detailed help type ??"
+8 SET DIR("??")=U_"D HLP^PXRMLREX(HELP)"
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIROUT)
SET DTOUT=1
+11 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 SET YESNO=$EXTRACT(Y(0))
+13 QUIT
+14 ;
+15 ;Give option to delete all descendents
+16 ;-------------------------------------
DELETE(COMP) ;
+1 NEW ANS,HLP,LRIEN,LRNAM,LRTYP,IC,TEXT
+2 ;Parent name and type
+3 SET LRNAM=$PIECE(COMP(0),U)
+4 ;Prompt information
+5 SET TEXT(1)="List Rule Set "_LRNAM_" had unused components."
+6 SET TEXT="Delete all these component rules:"
+7 ;List component names
+8 SET IC=2
SET LRIEN=0
SET TEXT(2)=""
SET HLP=1
+9 FOR
SET LRIEN=$ORDER(COMP(LRIEN))
if 'LRIEN
QUIT
Begin DoDot:1
+10 SET IC=IC+1
IF IC>15
SET TEXT(IC)="<<more>>"
QUIT
+11 NEW LRTYP
+12 SET LRTYP=$PIECE(COMP(LRIEN),U,2)
+13 SET LRTYP=$SELECT(LRTYP=1:"list rule",LRTYP=2:"reminder rule",1:"output rule")
+14 SET TEXT(IC)=$PIECE(COMP(LRIEN),U)_$JUSTIFY("",5)_LRTYP
End DoDot:1
if IC>15
QUIT
+15 SET TEXT(IC+1)=""
+16 ;Ask Delete Y/N?
+17 DO ASK(.ANS,.TEXT,HLP)
if $GET(ANS)'="Y"
QUIT
+18 ;Use DIK to remove all unused components
+19 NEW DA,DIK
+20 SET LRIEN=0
+21 ;Scan list of unused components
+22 FOR
SET LRIEN=$ORDER(COMP(LRIEN))
if 'LRIEN
QUIT
Begin DoDot:1
+23 ;Delete component dialog
+24 SET DA=LRIEN
SET DIK="^PXRM(810.4,"
DO ^DIK
End DoDot:1
+25 QUIT
+26 ;
+27 ;Build list of components
+28 ;------------------------
COMP(IEN,COMP) ;
+1 ;Build list of components
+2 DO COMPR(IEN,.COMP)
if '$DATA(COMP)
QUIT
+3 ;Get reminder dialog, group or element name and type
+4 NEW DATA
+5 SET DATA=$GET(^PXRM(810.4,IEN,0))
+6 ;Save for future use
+7 SET COMP(0)=$PIECE(DATA,U)_U_$PIECE(DATA,U,4)
+8 QUIT
+9 ;
+10 ;Recursive call
+11 ;--------------
COMPR(IEN,COMP) ;
+1 NEW DATA,LRIEN,LRNAME,LRTYP,PARENT,SUB
+2 SET LRIEN=0
SET PARENT="LOCAL"
+3 ;Check if parent is national
+4 IF $PIECE($GET(^PXRM(810.4,IEN,100)),U)="N"
SET PARENT="NATIONAL"
+5 ;
+6 FOR
SET LRIEN=$ORDER(^PXRM(810.4,IEN,30,"D",LRIEN))
if 'LRIEN
QUIT
Begin DoDot:1
+7 ;Ignore national components
+8 IF $PIECE($GET(^PXRM(810.4,LRIEN,100)),U)="N"
IF PARENT'="NATIONAL"
QUIT
+9 ;Ignore if in use
+10 IF $$USED(LRIEN,IEN)
QUIT
+11 ;Save component dialog type and name
+12 SET DATA=$GET(^PXRM(810.4,LRIEN,0))
SET LRNAME=$PIECE(DATA,U)
SET LRTYP=$PIECE(DATA,U,3)
+13 SET COMP(LRIEN)=LRNAME_U_LRTYP
+14 ;For groups and element check sub-components
+15 IF (LRTYP="G")!(LRTYP="E")
DO COMPR(LRIEN,.COMP)
End DoDot:1
+16 QUIT
+17 ;
+18 ;Check if in use
+19 ;---------------
USED(LRIEN,IEN) ;
+1 NEW SUB,DINUSE
+2 SET SUB=0
SET DINUSE=0
+3 FOR
SET SUB=$ORDER(^PXRM(810.4,"AD",LRIEN,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 ;In use by other than parent
+5 IF SUB'=IEN
SET DINUSE=1
End DoDot:1
if DINUSE
QUIT
+6 QUIT DINUSE
+7 ;
+8 ;General help text routine.
+9 ;--------------------------
HLP(CALL) ;
+1 NEW HTEXT
+2 NEW DIWF,DIWL,DIWR,IC
+3 SET DIWF="C75"
SET DIWL=0
SET DIWR=75
+4 ;
+5 IF CALL=1
Begin DoDot:1
+6 SET HTEXT(1)="Enter 'Yes' to DELETE all sub-components listed above"
+7 SET HTEXT(2)="or enter 'No' to quit."
End DoDot:1
+8 ;
+9 DO HELP^PXRMEUT(.HTEXT)
+10 QUIT
