- 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 Feb 18, 2025@23:29:59 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