XPDIA2 ;SFISC/RSD - Delete Options and cleanup pointers ;11/03/99 12:58
;;8.0;KERNEL;**68,131**;Jul 10, 1995
Q
OPT ;options
N XPDI,XPDJ,XPDK,XPDM,XPDX,X
;XPDM=ien of the XMUSER option
S X=$O(^DIC(19,"B","XMUSER",0)),XPDM=$S(X:X,1:"@"),XPDX=0
;loop thru all the options that are to be deleted
F S XPDX=$O(^TMP($J,"XPDEL",XPDX)) Q:'XPDX D
.;check that the following might reference this option, XPDX
.;file 19, menu item, 10
.S XPDI=0 F S XPDI=$O(^DIC(19,"AD",XPDX,XPDI)) Q:'XPDI D
..S XPDJ=0 F S XPDJ=$O(^DIC(19,"AD",XPDX,XPDI,XPDJ)) Q:'XPDJ D
...N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
...D DIK("^DIC(19,"_XPDI_",10,",.XPDA,DUZ)
.;file 19.081, field .01
.S XPDI=0 F S XPDI=$O(^XUSEC(19,"B",XPDX,XPDI)) Q:'XPDI D DIK("^XUSEC(19,",XPDI,DUZ)
.;file 19.2, field .01
.S XPDI=0 F S XPDI=$O(^DIC(19.2,"B",XPDX,XPDI)) Q:'XPDI D DIK("^DIC(19.2,",XPDI,DUZ)
.;file 200, secondary menu item, 203
.S XPDI=0 F S XPDI=$O(^VA(200,"AD",XPDX,XPDI)) Q:'XPDI D
..S XPDJ=0 F S XPDJ=$O(^VA(200,"AD",XPDX,XPDI,XPDJ)) Q:'XPDJ D
...N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
...D DIK("^VA(200,"_XPDI_",203,",.XPDA,DUZ)
.Q
;
;loop thru New Person file
S XPDI=0 F S XPDI=$O(^VA(200,XPDI)) Q:'XPDI D
.K XPDK S X="XPDK(200,"""_XPDI_","")"
.I $D(^VA(200,XPDI,201)) S XPDX=^(201) D
..;check primary option field 201
..S:$D(^TMP($J,"XPDEL",+XPDX)) @X@(201)=XPDM
..;check primary window field 201.1
..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,2))) @X@(201.1)="@"
.;check last option accessed field 202.1
.I $D(^VA(200,XPDI,202.1)),$D(^TMP($J,"XPDEL",+^(202.1))) S @X@(202.1)="@"
.D:$D(XPDK) DIE(.XPDK,DUZ)
.;loop thru delegated options field 19.5, this multiple is dinumed
.S XPDJ=0 F S XPDJ=$O(^VA(200,XPDI,19.5,XPDJ)) Q:'XPDJ D:$D(^TMP($J,"XPDEL",XPDJ))
..N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
..D DIK("^VA(200,"_XPDI_",19.5,",.XPDA,DUZ)
.Q
;
;loop thru Kernel Site Parameter file
S XPDI=0 F S XPDI=$O(^XTV(8989.3,XPDI)) Q:'XPDI D
.;loop thru alpha/beta test options field 33, node ABOPT, multiple is dinumed
.S XPDJ=0 F S XPDJ=$O(^XTV(8989.3,XPDI,"ABOPT",XPDJ)) Q:'XPDJ D:$D(^TMP($J,"XPDEL",XPDJ))
..N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
..D DIK("^XTV(8989.3,"_XPDI_",""ABOPT"",",.XPDA,DUZ)
.;loop thru option to audit field 19.1, node 19.1
.S XPDJ=0 F S XPDJ=$O(^XTV(8989.3,XPDI,19.1,"B",XPDJ)) Q:'XPDJ D:$D(^TMP($J,"XPDEL",XPDJ))
..N XPDA S XPDK=$O(^XTV(8989.3,XPDI,19.1,"B",XPDJ,0)),XPDA=XPDK,XPDA(1)=XPDI
..D DIK("^XTV(8989.3,"_XPDI_",19.1,",.XPDA,DUZ)
.Q
;
;loop thru Device File and check primary option field 201
S XPDI=0 F S XPDI=$O(^%ZIS(1,XPDI)) Q:'XPDI D:$D(^TMP($J,"XPDEL",+$G(^(XPDI,201))))
.K XPDK S XPDK(3.5,XPDI_",",201)="@" D DIE(.XPDK,DUZ)
Q
;
PRO ;protocols
N XPDI,XPDJ,XPDK,XPDX,X
S XPDX=0
;loop thru all the protocols that are to be deleted
F S XPDX=$O(^TMP($J,"XPDEL",XPDX)) Q:'XPDX D
.;check that the following might reference this protocol, XPDX
.;file 101, menu item, 10
.S XPDI=0 F S XPDI=$O(^ORD(101,"AD",XPDX,XPDI)) Q:'XPDI D
..S XPDJ=0 F S XPDJ=$O(^ORD(101,"AD",XPDX,XPDI,XPDJ)) Q:'XPDJ D
...N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
...D DIK("^ORD(101,"_XPDI_",10,",.XPDA,DUZ)
.;file 101, subscriber, 775
.S XPDI=0 F S XPDI=$O(^ORD(101,"AB",XPDX,XPDI)) Q:'XPDI D
..S XPDJ=0 F S XPDJ=$O(^ORD(101,"AB",XPDX,XPDI,XPDJ)) Q:'XPDJ D
...N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
...D DIK("^ORD(101,"_XPDI_",775,",.XPDA,DUZ)
.;file 123.1, REQUEST ACTION TYPE, field 2
.S XPDI=0 F S XPDI=$O(^GMR(123.1,"C",XPDX,XPDI)) Q:'XPDI D
..S X=$G(^GMR(123.1,XPDI,0)) Q:X=""
..K XPDK S XPDK(123.1,XPDI_",",2)="@"
..D DIE(.XPDK,DUZ)
.Q
;
;loop thru New Person file
S XPDI=0 F S XPDI=$O(^VA(200,XPDI)) Q:'XPDI D
.K XPDK S X="XPDK(200,"""_XPDI_","")"
.I $D(^VA(200,XPDI,100.1)) S XPDX=^(100.1) D
..;check PRIMARY OE/RR MENU, field 100.11
..S:$D(^TMP($J,"XPDEL",+XPDX)) @X@(100.11)="@"
..;check PRIMARY ORDER MENU, field 100.12
..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,2))) @X@(100.12)="@"
.I $D(^VA(200,XPDI,100.2)) S XPDX=^(100.2) D
..;check DEFAULT RESULT REPORTING MENU, field 100.23
..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,3))) @X@(100.23)="@"
..;check PRIMARY PROFILE MENU, field 100.24
..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,4))) @X@(100.24)="@"
.D:$D(XPDK) DIE(.XPDK,DUZ)
Q
;
DIK(DIK,DA,DUZ) ;delete
S DUZ(0)="@" D ^DIK
Q
DIE(XPD,DUZ) ;
;XPD(file,DA_",",field)=XMUSER option or '@' to delete
S DUZ(0)="@"
D FILE^DIE("","XPD")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIA2 4486 printed Dec 13, 2024@02:03:33 Page 2
XPDIA2 ;SFISC/RSD - Delete Options and cleanup pointers ;11/03/99 12:58
+1 ;;8.0;KERNEL;**68,131**;Jul 10, 1995
+2 QUIT
OPT ;options
+1 NEW XPDI,XPDJ,XPDK,XPDM,XPDX,X
+2 ;XPDM=ien of the XMUSER option
+3 SET X=$ORDER(^DIC(19,"B","XMUSER",0))
SET XPDM=$SELECT(X:X,1:"@")
SET XPDX=0
+4 ;loop thru all the options that are to be deleted
+5 FOR
SET XPDX=$ORDER(^TMP($JOB,"XPDEL",XPDX))
if 'XPDX
QUIT
Begin DoDot:1
+6 ;check that the following might reference this option, XPDX
+7 ;file 19, menu item, 10
+8 SET XPDI=0
FOR
SET XPDI=$ORDER(^DIC(19,"AD",XPDX,XPDI))
if 'XPDI
QUIT
Begin DoDot:2
+9 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^DIC(19,"AD",XPDX,XPDI,XPDJ))
if 'XPDJ
QUIT
Begin DoDot:3
+10 NEW XPDA
SET XPDA=XPDJ
SET XPDA(1)=XPDI
+11 DO DIK("^DIC(19,"_XPDI_",10,",.XPDA,DUZ)
End DoDot:3
End DoDot:2
+12 ;file 19.081, field .01
+13 SET XPDI=0
FOR
SET XPDI=$ORDER(^XUSEC(19,"B",XPDX,XPDI))
if 'XPDI
QUIT
DO DIK("^XUSEC(19,",XPDI,DUZ)
+14 ;file 19.2, field .01
+15 SET XPDI=0
FOR
SET XPDI=$ORDER(^DIC(19.2,"B",XPDX,XPDI))
if 'XPDI
QUIT
DO DIK("^DIC(19.2,",XPDI,DUZ)
+16 ;file 200, secondary menu item, 203
+17 SET XPDI=0
FOR
SET XPDI=$ORDER(^VA(200,"AD",XPDX,XPDI))
if 'XPDI
QUIT
Begin DoDot:2
+18 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^VA(200,"AD",XPDX,XPDI,XPDJ))
if 'XPDJ
QUIT
Begin DoDot:3
+19 NEW XPDA
SET XPDA=XPDJ
SET XPDA(1)=XPDI
+20 DO DIK("^VA(200,"_XPDI_",203,",.XPDA,DUZ)
End DoDot:3
End DoDot:2
+21 QUIT
End DoDot:1
+22 ;
+23 ;loop thru New Person file
+24 SET XPDI=0
FOR
SET XPDI=$ORDER(^VA(200,XPDI))
if 'XPDI
QUIT
Begin DoDot:1
+25 KILL XPDK
SET X="XPDK(200,"""_XPDI_","")"
+26 IF $DATA(^VA(200,XPDI,201))
SET XPDX=^(201)
Begin DoDot:2
+27 ;check primary option field 201
+28 if $DATA(^TMP($JOB,"XPDEL",+XPDX))
SET @X@(201)=XPDM
+29 ;check primary window field 201.1
+30 if $DATA(^TMP($JOB,"XPDEL",+$PIECE(XPDX,U,2)))
SET @X@(201.1)="@"
End DoDot:2
+31 ;check last option accessed field 202.1
+32 IF $DATA(^VA(200,XPDI,202.1))
IF $DATA(^TMP($JOB,"XPDEL",+^(202.1)))
SET @X@(202.1)="@"
+33 if $DATA(XPDK)
DO DIE(.XPDK,DUZ)
+34 ;loop thru delegated options field 19.5, this multiple is dinumed
+35 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^VA(200,XPDI,19.5,XPDJ))
if 'XPDJ
QUIT
if $DATA(^TMP($JOB,"XPDEL",XPDJ))
Begin DoDot:2
+36 NEW XPDA
SET XPDA=XPDJ
SET XPDA(1)=XPDI
+37 DO DIK("^VA(200,"_XPDI_",19.5,",.XPDA,DUZ)
End DoDot:2
+38 QUIT
End DoDot:1
+39 ;
+40 ;loop thru Kernel Site Parameter file
+41 SET XPDI=0
FOR
SET XPDI=$ORDER(^XTV(8989.3,XPDI))
if 'XPDI
QUIT
Begin DoDot:1
+42 ;loop thru alpha/beta test options field 33, node ABOPT, multiple is dinumed
+43 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^XTV(8989.3,XPDI,"ABOPT",XPDJ))
if 'XPDJ
QUIT
if $DATA(^TMP($JOB,"XPDEL",XPDJ))
Begin DoDot:2
+44 NEW XPDA
SET XPDA=XPDJ
SET XPDA(1)=XPDI
+45 DO DIK("^XTV(8989.3,"_XPDI_",""ABOPT"",",.XPDA,DUZ)
End DoDot:2
+46 ;loop thru option to audit field 19.1, node 19.1
+47 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^XTV(8989.3,XPDI,19.1,"B",XPDJ))
if 'XPDJ
QUIT
if $DATA(^TMP($JOB,"XPDEL",XPDJ))
Begin DoDot:2
+48 NEW XPDA
SET XPDK=$ORDER(^XTV(8989.3,XPDI,19.1,"B",XPDJ,0))
SET XPDA=XPDK
SET XPDA(1)=XPDI
+49 DO DIK("^XTV(8989.3,"_XPDI_",19.1,",.XPDA,DUZ)
End DoDot:2
+50 QUIT
End DoDot:1
+51 ;
+52 ;loop thru Device File and check primary option field 201
+53 SET XPDI=0
FOR
SET XPDI=$ORDER(^%ZIS(1,XPDI))
if 'XPDI
QUIT
if $DATA(^TMP($JOB,"XPDEL",+$GET(^(XPDI,201))))
Begin DoDot:1
+54 KILL XPDK
SET XPDK(3.5,XPDI_",",201)="@"
DO DIE(.XPDK,DUZ)
End DoDot:1
+55 QUIT
+56 ;
PRO ;protocols
+1 NEW XPDI,XPDJ,XPDK,XPDX,X
+2 SET XPDX=0
+3 ;loop thru all the protocols that are to be deleted
+4 FOR
SET XPDX=$ORDER(^TMP($JOB,"XPDEL",XPDX))
if 'XPDX
QUIT
Begin DoDot:1
+5 ;check that the following might reference this protocol, XPDX
+6 ;file 101, menu item, 10
+7 SET XPDI=0
FOR
SET XPDI=$ORDER(^ORD(101,"AD",XPDX,XPDI))
if 'XPDI
QUIT
Begin DoDot:2
+8 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^ORD(101,"AD",XPDX,XPDI,XPDJ))
if 'XPDJ
QUIT
Begin DoDot:3
+9 NEW XPDA
SET XPDA=XPDJ
SET XPDA(1)=XPDI
+10 DO DIK("^ORD(101,"_XPDI_",10,",.XPDA,DUZ)
End DoDot:3
End DoDot:2
+11 ;file 101, subscriber, 775
+12 SET XPDI=0
FOR
SET XPDI=$ORDER(^ORD(101,"AB",XPDX,XPDI))
if 'XPDI
QUIT
Begin DoDot:2
+13 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^ORD(101,"AB",XPDX,XPDI,XPDJ))
if 'XPDJ
QUIT
Begin DoDot:3
+14 NEW XPDA
SET XPDA=XPDJ
SET XPDA(1)=XPDI
+15 DO DIK("^ORD(101,"_XPDI_",775,",.XPDA,DUZ)
End DoDot:3
End DoDot:2
+16 ;file 123.1, REQUEST ACTION TYPE, field 2
+17 SET XPDI=0
FOR
SET XPDI=$ORDER(^GMR(123.1,"C",XPDX,XPDI))
if 'XPDI
QUIT
Begin DoDot:2
+18 SET X=$GET(^GMR(123.1,XPDI,0))
if X=""
QUIT
+19 KILL XPDK
SET XPDK(123.1,XPDI_",",2)="@"
+20 DO DIE(.XPDK,DUZ)
End DoDot:2
+21 QUIT
End DoDot:1
+22 ;
+23 ;loop thru New Person file
+24 SET XPDI=0
FOR
SET XPDI=$ORDER(^VA(200,XPDI))
if 'XPDI
QUIT
Begin DoDot:1
+25 KILL XPDK
SET X="XPDK(200,"""_XPDI_","")"
+26 IF $DATA(^VA(200,XPDI,100.1))
SET XPDX=^(100.1)
Begin DoDot:2
+27 ;check PRIMARY OE/RR MENU, field 100.11
+28 if $DATA(^TMP($JOB,"XPDEL",+XPDX))
SET @X@(100.11)="@"
+29 ;check PRIMARY ORDER MENU, field 100.12
+30 if $DATA(^TMP($JOB,"XPDEL",+$PIECE(XPDX,U,2)))
SET @X@(100.12)="@"
End DoDot:2
+31 IF $DATA(^VA(200,XPDI,100.2))
SET XPDX=^(100.2)
Begin DoDot:2
+32 ;check DEFAULT RESULT REPORTING MENU, field 100.23
+33 if $DATA(^TMP($JOB,"XPDEL",+$PIECE(XPDX,U,3)))
SET @X@(100.23)="@"
+34 ;check PRIMARY PROFILE MENU, field 100.24
+35 if $DATA(^TMP($JOB,"XPDEL",+$PIECE(XPDX,U,4)))
SET @X@(100.24)="@"
End DoDot:2
+36 if $DATA(XPDK)
DO DIE(.XPDK,DUZ)
End DoDot:1
+37 QUIT
+38 ;
DIK(DIK,DA,DUZ) ;delete
+1 SET DUZ(0)="@"
DO ^DIK
+2 QUIT
DIE(XPD,DUZ) ;
+1 ;XPD(file,DA_",",field)=XMUSER option or '@' to delete
+2 SET DUZ(0)="@"
+3 DO FILE^DIE("","XPD")
+4 QUIT
