ORY44 ; SLC/PKS-KR Remove Terminated Users ; [3/13/00 12:42pm]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**44**;Dec 17, 1997
;
Q
;
BF ; Remove Entries for all Terminated Users (By File)
;
; FILENUM File #
; FIELDNUM Field #
; LCNT Line Counter
; RTS( Array of Global Roots
; GTOT Grand Total Terminated Users
; ORYMSG Array for Bulletin Message
; ORYCNT Counter Variable
; XMvars Set for Bulletin Message
;
N USR,TAG,FILENUM,FIELDNUM,LCNT,NOW,GTOT,RTS,DIFROM,ORYMSG,ORYCNT,XMDUZ,XMY,XMTEXT,XMSUB
S LCNT=0,GTOT=0,ORYCNT=0,NOW=DT
F LCNT=1:1 D CHECK Q:FILENUM=""!(FIELDNUM="")
;
; Send a bulletin to the user with information on terminations:
S XMDUZ=.5,XMY(DUZ)="",XMSUB=" Patch OR*3*44 Post-Init Notice"
S XMTEXT="ORYMSG("
S ORYMSG(ORYCNT+1,0)=""
S ORYMSG(ORYCNT+2,0)="Upon successful completion of installation "
S ORYMSG(ORYCNT+3,0)="of this patch, be sure to delete routines: "
S ORYMSG(ORYCNT+4,0)=" ORY44"
S ORYMSG(ORYCNT+5,0)=" ORY44B"
S ORYMSG(ORYCNT+6,0)=" ORY44C"
S ORYMSG(ORYCNT+7,0)=""
S ORYMSG(ORYCNT+8,0)="NOTE: Data for deleted pointers (and any "
S ORYMSG(ORYCNT+9,0)="deleted ""Personal"" type Team Lists) can be "
S ORYMSG(ORYCNT+10,0)="found in the ""Install File Print"" record."
S ORYMSG(ORYCNT+11,0)="The record can be accessed by using the KIDS "
S ORYMSG(ORYCNT+12,0)="""Utility"" menu ""Install File Print"" option."
S ORYMSG(ORYCNT+13,0)=""
D ^XMD
;
; Call code to remove old Team Lists of "Personal" type with
; no users or when the only user is a terminated user:
D EN^ORY44C
;
Q
;
CHECK ; Check users in <FILE> and <FIELD>
;
; FILENUM File #
; FIELDNUM Field #
; LCNT Line Counter
; RTS( Array of Global Roots
;
S FILENUM=$$FILE(LCNT) Q:FILENUM=""
S FIELDNUM=$$FIELD(LCNT) Q:FIELDNUM=""
K RTS
D INFO^ORY44B(FILENUM,FIELDNUM,.RTS) Q:'$D(RTS)
D:$D(RTS) REMOVE
Q
;
FILE(X) ; Get File Number
S TAG="DATO" ; For OE/RR.
S X=+($G(X)) Q:X="" "" S X=$P($T(@TAG+X),";;",2) Q:X="" ""
S X=$P(X,";",1) Q X
;
FIELD(X) ; Get Field Number
S TAG="DATO" ; For OE/RR.
S X=+($G(X)) Q:X="" "" S X=$P($T(@TAG+X),";;",2) Q:X="" ""
S X=$P(X,";",2) Q X
;
REMOVE ; Remove Terminated User
;
; DA Current DA Array
; DIC Current Global Root
; LVL Current Level
; IND Indentation (for write statements)
; TERM Terminated Entries Found in File
; TOT Total Terminated Entries Found
;
N DA,IEN,DIC,LVL,IND,TOT,TERM
S (TERM,LVL,TOT)=0,IND=2
D REMDAT
S TOT=+($G(TOT))+($G(TERM)),GTOT=+($G(GTOT))+($G(TOT))
I +($G(USR))=0 D
. S ORYCNT=ORYCNT+1
. S:TOT>0 ORYMSG(ORYCNT,0)=" "_FILENUM_","_FIELDNUM_": "_TOT_" pointers to terminated users"_" deleted from this field."
. S:TOT'>0 ORYMSG(ORYCNT,0)=" "_FILENUM_","_FIELDNUM_": No pointers to terminated users found in this field."
Q
;
REMDAT ; Get Removal Data (Name and Termination Date)
;
; LVL Current Level
; RTS( Array of Global Roots
;
S LVL=$O(RTS("DIC",LVL))
D GETDAT
Q
;
GETDAT ; Get Data
;
; DA Current DA Array
; DIC Current Global Root
; DICP Current Global Specifier
; LVL Current Level
; IEN Current Internal Entry Number
; RTS( Array of Global Roots
;
S DIC=$G(RTS("DIC",LVL)) Q:'$L(DIC)
S:$L($G(RTS("DIC",LVL,"P"))) DICP=RTS("DIC",LVL,"P")
S IEN=0 F S IEN=$O(@(DIC_IEN_")")) Q:+IEN=0 D Q:+IEN=0
. Q:+IEN=0 S DA=IEN
. D NEXTDAT:+($O(RTS("DIC",LVL)))>0,EXTDAT:+($O(RTS("DIC",LVL)))'>0
Q
;
NEXTDAT ; Next Data (for subfiles)
;
; DA Current DA Array
; DIC Current Global Root
; DICP Current Global Specifier
; LVL Current Level
; IEN Current Internal Entry Number
; OLDDA Previous DA Array
; OLDDIC Previous Global Root
; OLDLVL Previous Level
; CNT Counter
;
N CNT,OLDDA,OLDLVL,OLDDIC,OLDDICP
S OLDDA=DA,OLDLVL=LVL,OLDDIC=DIC,OLDDICP=$G(DICP)
F CNT=1:1:$O(DA(" "),-1) D
. S:$D(DA(CNT)) OLDDA(CNT)=DA(CNT)
N DA
F CNT=1:1:$O(OLDDA(" "),-1) D
. S:$D(OLDDA(CNT)) DA(CNT+1)=OLDDA(CNT)
S DA(1)=OLDDA
N IEN,LVL,DIC,DICP
S LVL=OLDLVL,DIC=OLDDIC
D REMDAT
Q
;
EXTDAT ; Extract Data
;
; ORLPERR Error Message Array
; CDA DA Counter
; LDA Last DA
; NODE Fully Specified Global Node
; NODEDAT Data Stored at Global Node
; NODESUB Node Subscript #
; NODELOC Node Location ($PIECE # of Node)
; GBLLOC Global Subscript Location (#;#)
; DIC Fully Specified Global Root
; DICP Global Specifier
; USRP Pointer to New Person File
; USRNAME User's Name
; USRITD Internal form of User's Termination Date
; USRETD External form of User's Termination Date
; USRSTA User Status
; USRACT User Action
; ORLPUSRP Pointer Holder
;
N ORLPERR,CDA,LDA,NODE,NODEDAT,NODELOC,NODESUB,GBLLOC,USRP,USRNAME,USRITD,USRETD,USRSTA,USRACT,ORLPUSRP
S GBLLOC=$G(RTS("LOC")) Q:$L($G(GBLLOC),";")'=2
S NODESUB=$P($G(GBLLOC),";",1),NODELOC=+($P($G(GBLLOC),";",2))
Q:'$L(NODESUB) Q:+(NODELOC)'>0 Q:'$L($G(DIC)) Q:+($G(DA))'>0
Q:'$L($G(NODESUB)) Q:+($G(NODELOC))'>0 Q:DIC["DA("&(+($G(DA(1)))=0)
Q:'$L($G(DICP))
S NODE=DIC_DA_","_NODESUB_")" Q:'$D(@NODE) S NODEDAT=@NODE
S USRP=+($P(NODEDAT,"^",NODELOC)) Q:USRP=0
I +($G(USR))>0,$D(^VA(200,+($G(USR)),0)),$L($P($G(^VA(200,+($G(USR)),0)),"^",1)),+($G(USR))'=USRP Q
S ORLPUSRP=USRP
K ORLPERR S USRNAME=$$GET1^DIQ(200,ORLPUSRP,.01,"E",,.ORLPERR) Q:$D(ORLPERR)
K ORLPERR S USRITD=$$GET1^DIQ(200,ORLPUSRP,9.2,"I",,.ORLPERR) Q:$D(ORLPERR)
S USRSTA=$$TERM^ORY44B(+USRP),USRACT=$P(USRSTA,"^",1),USRSTA=$S(USRACT=2:"Terminated",USRACT=1:"Future Termination",USRACT=0:"Active User",1:"Undetermined")
S USRETD=$$FMTE^XLFDT(USRITD,1) Q:USRACT'=2 S:USRACT=2 TERM=TERM+1 D:USRACT=2 DEL
I +($G(USR))>0,$D(^VA(200,+($G(USR)),0)),$L($P($G(^VA(200,+($G(USR)),0)),"^",1)) Q
S LDA=+($O(DA(" "),-1))
Q
;
DEL ; Delete Entry
;
; DIC Current Global Root
; OLDDIC Former DIC (Global Root)
; DIC(0) Lookup Parameters
; DIC("P") Subfile Specifiers
; DIC("DR") Data Field String
; OLDDA Former DA Array
; DA Current DA Array
;
; DIE Global Root
; DIK Global Root
; DR Data Field String
; DTOUT Timeout Flag
; DUOUT Up-Arrow Out Flag
; DLAYGO "Learn As You Go" Flag
; OLDDUZ Former User
; DUZ Current User
; DUZ(0) Current User Access
; GL Fileman Global Location
; UDA Uppermost DA
; LN Node to Lock
; VAR Field Value
; X Input Data
; Y Output Data
; I Counter
; ORYTEAM Team IEN for Message
; ORYDAT Data File String Holder
;
Q:'$D(DIC) Q:'$D(DA) Q:+($G(RTS("FILE")))=0 Q:+($G(RTS("FIELD")))=0
;
N I,LN,UDA,ORYTEAM,ORYDAT
S OLDDA=DA,I=0 F S I=$O(DA(I)) Q:+I=0 S OLDDA(I)=DA(I)
N DA S DA=OLDDA,I=0 F S I=$O(OLDDA(I)) Q:+I=0 S DA(I)=OLDDA(I)
;
N DIK,DIE,DR,DLAYGO,DTOUT,DUOUT,X,Y,OLDDIC,OLDDUZ,VAR,GL
S:$D(DUZ(0)) OLDDUZ=$G(DUZ(0))
S OLDDIC=$G(DIC)
N DIC S (DIK,DIE,DIC)=$G(OLDDIC),GL=$G(RTS("DIC",1)) Q:'$D(@(GL_"0)"))
S UDA=DA S:$D(DA(1))&(+($O(DA(" "),-1))>0) UDA=DA(+($O(DA(" "),-1)))
Q:+UDA=0 S LN=(GL_UDA_")")
;
S:$D(RTS("DIC",2))&($L($G(DICP))) DIC("P")=$G(DICP)
S DIC(0)=$G(DIC(0)) S:DIC(0)'["L" DIC(0)=DIC(0)_"L"
S DLAYGO=+($G(RTS("FILE")))
S (DR,DIC("DR"))=+($G(RTS("FIELD")))_"///^S X=VAR",VAR="@"
S ORYTEAM=DA(1)
;
; Deal with variable pointers in 100.213:
S ORYDAT=GL_DA(1)_",2,"_DA_",0)" I FILENUM="100.213",$G(@ORYDAT)'["VA" Q
;
L +@LN:1
D ^DIE
L -@LN
D MES^XPDUTL("Pointer to "_USRNAME_"/"_+USRP_" deleted from file "_FILENUM_", field "_FIELDNUM_" - team IEN "_ORYTEAM_".") ; Installation message to run under Taskman.
;
Q
;
; NOTE: Next section does NOT work for variable pointer fields!
DATO ; Data (FILE/FIELDS) for pointer removal (OERR)
;;100.212;.01;ISC-SLC/PKS
;;100.213;.01;ISC-SLC/PKS
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY44 8664 printed Apr 09, 2024@21:29:21 Page 2
ORY44 ; SLC/PKS-KR Remove Terminated Users ; [3/13/00 12:42pm]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**44**;Dec 17, 1997
+2 ;
+3 QUIT
+4 ;
BF ; Remove Entries for all Terminated Users (By File)
+1 ;
+2 ; FILENUM File #
+3 ; FIELDNUM Field #
+4 ; LCNT Line Counter
+5 ; RTS( Array of Global Roots
+6 ; GTOT Grand Total Terminated Users
+7 ; ORYMSG Array for Bulletin Message
+8 ; ORYCNT Counter Variable
+9 ; XMvars Set for Bulletin Message
+10 ;
+11 NEW USR,TAG,FILENUM,FIELDNUM,LCNT,NOW,GTOT,RTS,DIFROM,ORYMSG,ORYCNT,XMDUZ,XMY,XMTEXT,XMSUB
+12 SET LCNT=0
SET GTOT=0
SET ORYCNT=0
SET NOW=DT
+13 FOR LCNT=1:1
DO CHECK
if FILENUM=""!(FIELDNUM="")
QUIT
+14 ;
+15 ; Send a bulletin to the user with information on terminations:
+16 SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMSUB=" Patch OR*3*44 Post-Init Notice"
+17 SET XMTEXT="ORYMSG("
+18 SET ORYMSG(ORYCNT+1,0)=""
+19 SET ORYMSG(ORYCNT+2,0)="Upon successful completion of installation "
+20 SET ORYMSG(ORYCNT+3,0)="of this patch, be sure to delete routines: "
+21 SET ORYMSG(ORYCNT+4,0)=" ORY44"
+22 SET ORYMSG(ORYCNT+5,0)=" ORY44B"
+23 SET ORYMSG(ORYCNT+6,0)=" ORY44C"
+24 SET ORYMSG(ORYCNT+7,0)=""
+25 SET ORYMSG(ORYCNT+8,0)="NOTE: Data for deleted pointers (and any "
+26 SET ORYMSG(ORYCNT+9,0)="deleted ""Personal"" type Team Lists) can be "
+27 SET ORYMSG(ORYCNT+10,0)="found in the ""Install File Print"" record."
+28 SET ORYMSG(ORYCNT+11,0)="The record can be accessed by using the KIDS "
+29 SET ORYMSG(ORYCNT+12,0)="""Utility"" menu ""Install File Print"" option."
+30 SET ORYMSG(ORYCNT+13,0)=""
+31 DO ^XMD
+32 ;
+33 ; Call code to remove old Team Lists of "Personal" type with
+34 ; no users or when the only user is a terminated user:
+35 DO EN^ORY44C
+36 ;
+37 QUIT
+38 ;
CHECK ; Check users in <FILE> and <FIELD>
+1 ;
+2 ; FILENUM File #
+3 ; FIELDNUM Field #
+4 ; LCNT Line Counter
+5 ; RTS( Array of Global Roots
+6 ;
+7 SET FILENUM=$$FILE(LCNT)
if FILENUM=""
QUIT
+8 SET FIELDNUM=$$FIELD(LCNT)
if FIELDNUM=""
QUIT
+9 KILL RTS
+10 DO INFO^ORY44B(FILENUM,FIELDNUM,.RTS)
if '$DATA(RTS)
QUIT
+11 if $DATA(RTS)
DO REMOVE
+12 QUIT
+13 ;
FILE(X) ; Get File Number
+1 ; For OE/RR.
SET TAG="DATO"
+2 SET X=+($GET(X))
if X=""
QUIT ""
SET X=$PIECE($TEXT(@TAG+X),";;",2)
if X=""
QUIT ""
+3 SET X=$PIECE(X,";",1)
QUIT X
+4 ;
FIELD(X) ; Get Field Number
+1 ; For OE/RR.
SET TAG="DATO"
+2 SET X=+($GET(X))
if X=""
QUIT ""
SET X=$PIECE($TEXT(@TAG+X),";;",2)
if X=""
QUIT ""
+3 SET X=$PIECE(X,";",2)
QUIT X
+4 ;
REMOVE ; Remove Terminated User
+1 ;
+2 ; DA Current DA Array
+3 ; DIC Current Global Root
+4 ; LVL Current Level
+5 ; IND Indentation (for write statements)
+6 ; TERM Terminated Entries Found in File
+7 ; TOT Total Terminated Entries Found
+8 ;
+9 NEW DA,IEN,DIC,LVL,IND,TOT,TERM
+10 SET (TERM,LVL,TOT)=0
SET IND=2
+11 DO REMDAT
+12 SET TOT=+($GET(TOT))+($GET(TERM))
SET GTOT=+($GET(GTOT))+($GET(TOT))
+13 IF +($GET(USR))=0
Begin DoDot:1
+14 SET ORYCNT=ORYCNT+1
+15 if TOT>0
SET ORYMSG(ORYCNT,0)=" "_FILENUM_","_FIELDNUM_": "_TOT_" pointers to terminated users"_" deleted from this field."
+16 if TOT'>0
SET ORYMSG(ORYCNT,0)=" "_FILENUM_","_FIELDNUM_": No pointers to terminated users found in this field."
End DoDot:1
+17 QUIT
+18 ;
REMDAT ; Get Removal Data (Name and Termination Date)
+1 ;
+2 ; LVL Current Level
+3 ; RTS( Array of Global Roots
+4 ;
+5 SET LVL=$ORDER(RTS("DIC",LVL))
+6 DO GETDAT
+7 QUIT
+8 ;
GETDAT ; Get Data
+1 ;
+2 ; DA Current DA Array
+3 ; DIC Current Global Root
+4 ; DICP Current Global Specifier
+5 ; LVL Current Level
+6 ; IEN Current Internal Entry Number
+7 ; RTS( Array of Global Roots
+8 ;
+9 SET DIC=$GET(RTS("DIC",LVL))
if '$LENGTH(DIC)
QUIT
+10 if $LENGTH($GET(RTS("DIC",LVL,"P")))
SET DICP=RTS("DIC",LVL,"P")
+11 SET IEN=0
FOR
SET IEN=$ORDER(@(DIC_IEN_")"))
if +IEN=0
QUIT
Begin DoDot:1
+12 if +IEN=0
QUIT
SET DA=IEN
+13 if +($ORDER(RTS("DIC",LVL)))>0
DO NEXTDAT
if +($ORDER(RTS("DIC",LVL)))'>0
DO EXTDAT
End DoDot:1
if +IEN=0
QUIT
+14 QUIT
+15 ;
NEXTDAT ; Next Data (for subfiles)
+1 ;
+2 ; DA Current DA Array
+3 ; DIC Current Global Root
+4 ; DICP Current Global Specifier
+5 ; LVL Current Level
+6 ; IEN Current Internal Entry Number
+7 ; OLDDA Previous DA Array
+8 ; OLDDIC Previous Global Root
+9 ; OLDLVL Previous Level
+10 ; CNT Counter
+11 ;
+12 NEW CNT,OLDDA,OLDLVL,OLDDIC,OLDDICP
+13 SET OLDDA=DA
SET OLDLVL=LVL
SET OLDDIC=DIC
SET OLDDICP=$GET(DICP)
+14 FOR CNT=1:1:$ORDER(DA(" "),-1)
Begin DoDot:1
+15 if $DATA(DA(CNT))
SET OLDDA(CNT)=DA(CNT)
End DoDot:1
+16 NEW DA
+17 FOR CNT=1:1:$ORDER(OLDDA(" "),-1)
Begin DoDot:1
+18 if $DATA(OLDDA(CNT))
SET DA(CNT+1)=OLDDA(CNT)
End DoDot:1
+19 SET DA(1)=OLDDA
+20 NEW IEN,LVL,DIC,DICP
+21 SET LVL=OLDLVL
SET DIC=OLDDIC
+22 DO REMDAT
+23 QUIT
+24 ;
EXTDAT ; Extract Data
+1 ;
+2 ; ORLPERR Error Message Array
+3 ; CDA DA Counter
+4 ; LDA Last DA
+5 ; NODE Fully Specified Global Node
+6 ; NODEDAT Data Stored at Global Node
+7 ; NODESUB Node Subscript #
+8 ; NODELOC Node Location ($PIECE # of Node)
+9 ; GBLLOC Global Subscript Location (#;#)
+10 ; DIC Fully Specified Global Root
+11 ; DICP Global Specifier
+12 ; USRP Pointer to New Person File
+13 ; USRNAME User's Name
+14 ; USRITD Internal form of User's Termination Date
+15 ; USRETD External form of User's Termination Date
+16 ; USRSTA User Status
+17 ; USRACT User Action
+18 ; ORLPUSRP Pointer Holder
+19 ;
+20 NEW ORLPERR,CDA,LDA,NODE,NODEDAT,NODELOC,NODESUB,GBLLOC,USRP,USRNAME,USRITD,USRETD,USRSTA,USRACT,ORLPUSRP
+21 SET GBLLOC=$GET(RTS("LOC"))
if $LENGTH($GET(GBLLOC),";")'=2
QUIT
+22 SET NODESUB=$PIECE($GET(GBLLOC),";",1)
SET NODELOC=+($PIECE($GET(GBLLOC),";",2))
+23 if '$LENGTH(NODESUB)
QUIT
if +(NODELOC)'>0
QUIT
if '$LENGTH($GET(DIC))
QUIT
if +($GET(DA))'>0
QUIT
+24 if '$LENGTH($GET(NODESUB))
QUIT
if +($GET(NODELOC))'>0
QUIT
if DIC["DA("&(+($GET(DA(1)))=0)
QUIT
+25 if '$LENGTH($GET(DICP))
QUIT
+26 SET NODE=DIC_DA_","_NODESUB_")"
if '$DATA(@NODE)
QUIT
SET NODEDAT=@NODE
+27 SET USRP=+($PIECE(NODEDAT,"^",NODELOC))
if USRP=0
QUIT
+28 IF +($GET(USR))>0
IF $DATA(^VA(200,+($GET(USR)),0))
IF $LENGTH($PIECE($GET(^VA(200,+($GET(USR)),0)),"^",1))
IF +($GET(USR))'=USRP
QUIT
+29 SET ORLPUSRP=USRP
+30 KILL ORLPERR
SET USRNAME=$$GET1^DIQ(200,ORLPUSRP,.01,"E",,.ORLPERR)
if $DATA(ORLPERR)
QUIT
+31 KILL ORLPERR
SET USRITD=$$GET1^DIQ(200,ORLPUSRP,9.2,"I",,.ORLPERR)
if $DATA(ORLPERR)
QUIT
+32 SET USRSTA=$$TERM^ORY44B(+USRP)
SET USRACT=$PIECE(USRSTA,"^",1)
SET USRSTA=$SELECT(USRACT=2:"Terminated",USRACT=1:"Future Termination",USRACT=0:"Active User",1:"Undetermined")
+33 SET USRETD=$$FMTE^XLFDT(USRITD,1)
if USRACT'=2
QUIT
if USRACT=2
SET TERM=TERM+1
if USRACT=2
DO DEL
+34 IF +($GET(USR))>0
IF $DATA(^VA(200,+($GET(USR)),0))
IF $LENGTH($PIECE($GET(^VA(200,+($GET(USR)),0)),"^",1))
QUIT
+35 SET LDA=+($ORDER(DA(" "),-1))
+36 QUIT
+37 ;
DEL ; Delete Entry
+1 ;
+2 ; DIC Current Global Root
+3 ; OLDDIC Former DIC (Global Root)
+4 ; DIC(0) Lookup Parameters
+5 ; DIC("P") Subfile Specifiers
+6 ; DIC("DR") Data Field String
+7 ; OLDDA Former DA Array
+8 ; DA Current DA Array
+9 ;
+10 ; DIE Global Root
+11 ; DIK Global Root
+12 ; DR Data Field String
+13 ; DTOUT Timeout Flag
+14 ; DUOUT Up-Arrow Out Flag
+15 ; DLAYGO "Learn As You Go" Flag
+16 ; OLDDUZ Former User
+17 ; DUZ Current User
+18 ; DUZ(0) Current User Access
+19 ; GL Fileman Global Location
+20 ; UDA Uppermost DA
+21 ; LN Node to Lock
+22 ; VAR Field Value
+23 ; X Input Data
+24 ; Y Output Data
+25 ; I Counter
+26 ; ORYTEAM Team IEN for Message
+27 ; ORYDAT Data File String Holder
+28 ;
+29 if '$DATA(DIC)
QUIT
if '$DATA(DA)
QUIT
if +($GET(RTS("FILE")))=0
QUIT
if +($GET(RTS("FIELD")))=0
QUIT
+30 ;
+31 NEW I,LN,UDA,ORYTEAM,ORYDAT
+32 SET OLDDA=DA
SET I=0
FOR
SET I=$ORDER(DA(I))
if +I=0
QUIT
SET OLDDA(I)=DA(I)
+33 NEW DA
SET DA=OLDDA
SET I=0
FOR
SET I=$ORDER(OLDDA(I))
if +I=0
QUIT
SET DA(I)=OLDDA(I)
+34 ;
+35 NEW DIK,DIE,DR,DLAYGO,DTOUT,DUOUT,X,Y,OLDDIC,OLDDUZ,VAR,GL
+36 if $DATA(DUZ(0))
SET OLDDUZ=$GET(DUZ(0))
+37 SET OLDDIC=$GET(DIC)
+38 NEW DIC
SET (DIK,DIE,DIC)=$GET(OLDDIC)
SET GL=$GET(RTS("DIC",1))
if '$DATA(@(GL_"0)"))
QUIT
+39 SET UDA=DA
if $DATA(DA(1))&(+($ORDER(DA(" "),-1))>0)
SET UDA=DA(+($ORDER(DA(" "),-1)))
+40 if +UDA=0
QUIT
SET LN=(GL_UDA_")")
+41 ;
+42 if $DATA(RTS("DIC",2))&($LENGTH($GET(DICP)))
SET DIC("P")=$GET(DICP)
+43 SET DIC(0)=$GET(DIC(0))
if DIC(0)'["L"
SET DIC(0)=DIC(0)_"L"
+44 SET DLAYGO=+($GET(RTS("FILE")))
+45 SET (DR,DIC("DR"))=+($GET(RTS("FIELD")))_"///^S X=VAR"
SET VAR="@"
+46 SET ORYTEAM=DA(1)
+47 ;
+48 ; Deal with variable pointers in 100.213:
+49 SET ORYDAT=GL_DA(1)_",2,"_DA_",0)"
IF FILENUM="100.213"
IF $GET(@ORYDAT)'["VA"
QUIT
+50 ;
+51 LOCK +@LN:1
+52 DO ^DIE
+53 LOCK -@LN
+54 ; Installation message to run under Taskman.
DO MES^XPDUTL("Pointer to "_USRNAME_"/"_+USRP_" deleted from file "_FILENUM_", field "_FIELDNUM_" - team IEN "_ORYTEAM_".")
+55 ;
+56 QUIT
+57 ;
+58 ; NOTE: Next section does NOT work for variable pointer fields!
DATO ; Data (FILE/FIELDS) for pointer removal (OERR)
+1 ;;100.212;.01;ISC-SLC/PKS
+2 ;;100.213;.01;ISC-SLC/PKS
+3 ;;
