- 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 Feb 19, 2025@00:08:53 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 ;;