GMRCYP9 ; SLC/PKS-KR Remove Terminated Users ; [2/18/00 3:17pm]
;;3.0;CONSULT/REQUEST TRACKING;**9**;Dec 27, 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
; GMRCMSG Array for Bulletin Message
; GMRCCNT Counter Variable
; XMvars Set for Bulletin Message
;
D POST ; Rebuild x-refs for REQUEST SERVICES file.
;
N USR,TAG,FILENUM,FIELDNUM,LCNT,NOW,GTOT,RTS,DIFROM,GMRCMSG,GMRCCNT,XMDUZ,XMY,XMTEXT,XMSUB
S LCNT=0,GTOT=0,GMRCCNT=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 GMRC*3*9 Post-Init Notice"
S XMTEXT="GMRCMSG("
S GMRCMSG(GMRCCNT+1,0)=""
S GMRCMSG(GMRCCNT+2,0)="Upon successful completion of installation "
S GMRCMSG(GMRCCNT+3,0)="of this patch, be sure to delete routines: "
S GMRCMSG(GMRCCNT+4,0)=" GMRCYP9"
S GMRCMSG(GMRCCNT+5,0)=" GMRCYP9B"
S GMRCMSG(GMRCCNT+6,0)=""
S GMRCMSG(GMRCCNT+7,0)="NOTE: Data for deleted pointers can be "
S GMRCMSG(GMRCCNT+8,0)="found in the ""Install File Print"" record."
S GMRCMSG(GMRCCNT+9,0)="The record can be accessed by using the KIDS "
S GMRCMSG(GMRCCNT+10,0)="""Utility"" menu ""Install File Print"" option."
S GMRCMSG(GMRCCNT+11,0)=""
D ^XMD
;
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^GMRCYP9B(FILENUM,FIELDNUM,.RTS) Q:'$D(RTS)
D:$D(RTS) REMOVE
Q
;
FILE(X) ; Get File Number
S TAG="DATC" ; For CONSULTS.
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="DATC" ; For CONSULTS.
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 GMRCCNT=GMRCCNT+1
. S:TOT>0 GMRCMSG(GMRCCNT,0)=" "_FILENUM_","_FIELDNUM_": "_TOT_" pointers to terminated users"_" deleted from this field."
. S:TOT'>0 GMRCMSG(GMRCCNT,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
;
; GMRCERR 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
; GMRCUSRP Pointer Holder
;
N GMRCERR,CDA,LDA,NODE,NODEDAT,NODELOC,NODESUB,GBLLOC,USRP,USRNAME,USRITD,USRETD,USRSTA,USRACT,GMRCUSRP
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 GMRCUSRP=USRP
K GMRCERR S USRNAME=$$GET1^DIQ(200,GMRCUSRP,.01,"E",,.GMRCERR) Q:$D(GMRCERR)
K GMRCERR S USRITD=$$GET1^DIQ(200,GMRCUSRP,9.2,"I",,.GMRCERR) Q:$D(GMRCERR)
S USRSTA=$$TERM^GMRCYP9B(+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
;
Q:'$D(DIC) Q:'$D(DA) Q:+($G(RTS("FILE")))=0 Q:+($G(RTS("FIELD")))=0
;
N I,LN,UDA
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="@"
L +@LN:0
D ^DIE
L -@LN
D MES^XPDUTL("Pointer to "_USRNAME_"/"_+USRP_" deleted from file "_FILENUM_", field "_FIELDNUM_".") ; Installation message to run under Taskman.
;
Q
;
DATC ; Data (FILE/FIELDS) for pointer removal (Consults)
;;123.5;123.5;ISC-SLC/PKS
;;123.5;123.08;ISC-SLC/PKS
;;123.54;1;ISC-SLC/PKS
;;123.55;.01;ISC-SLC/PKS
;;123.555;.01;ISC-SLC/PKS
;;
;
Q
;
POST ; Further post-install action for patch GMRC*3*9.
;
; Set variables for Taskman:
S ZTRTN="RBLDIXS^GMRCYP9"
S ZTDTH=$H
S ZTDESC="Consults GMRC*3*9 post-install file ^GMR(123.5 indices rebuild."
S ZTIO=""
;
; Call Taskman to run the post-install indices rebuild:
D ^%ZTLOAD
Q
;
RBLDIXS ; Rebuild indices for ^GMR(123.5 file.
;
N ROOT,IEN,DIK,DA
S ROOT="^GMR(123.5," ; Common file root for x-refs.
;
S IEN=0
F S IEN=$O(^GMR(123.5,IEN)) Q:'IEN D ; Each Consults service.
.S DA(1)=IEN,DIK=ROOT_DA(1)_",123.1,",DIK(1)=.01
.D ENALL^DIK ; Rebuild "AST" x-ref.
.;
.S DA(1)=IEN,DIK=ROOT_DA(1)_",123.2,",DIK(1)=2
.D ENALL^DIK ; Rebuild "ANT" x-ref.
.;
.S DA(1)=IEN,DIK=ROOT_DA(1)_",123.31,",DIK(1)=.01
.D ENALL^DIK ; Rebuild "AUT" x-ref.
.;
.S DA(1)=IEN,DIK=ROOT_DA(1)_",123.34,",DIK(1)=.01
.D ENALL^DIK ; Rebuild "AAT" x-ref.
;
Q
;
GMRCYP9 ; SLC/PKS-KR Remove Terminated Users ; [2/18/00 3:17pm]
+1 ;;3.0;CONSULT/REQUEST TRACKING;**9**;Dec 27, 1997
+2 QUIT
+3 ;
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 ; GMRCMSG Array for Bulletin Message
+8 ; GMRCCNT Counter Variable
+9 ; XMvars Set for Bulletin Message
+10 ;
+11 ; Rebuild x-refs for REQUEST SERVICES file.
DO POST
+12 ;
+13 NEW USR,TAG,FILENUM,FIELDNUM,LCNT,NOW,GTOT,RTS,DIFROM,GMRCMSG,GMRCCNT,XMDUZ,XMY,XMTEXT,XMSUB
+14 SET LCNT=0
SET GTOT=0
SET GMRCCNT=0
SET NOW=DT
+15 FOR LCNT=1:1
DO CHECK
IF FILENUM=""!(FIELDNUM="")
QUIT
+16 ;
+17 ; Send a bulletin to the user with information on terminations:
+18 SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMSUB=" Patch GMRC*3*9 Post-Init Notice"
+19 SET XMTEXT="GMRCMSG("
+20 SET GMRCMSG(GMRCCNT+1,0)=""
+21 SET GMRCMSG(GMRCCNT+2,0)="Upon successful completion of installation "
+22 SET GMRCMSG(GMRCCNT+3,0)="of this patch, be sure to delete routines: "
+23 SET GMRCMSG(GMRCCNT+4,0)=" GMRCYP9"
+24 SET GMRCMSG(GMRCCNT+5,0)=" GMRCYP9B"
+25 SET GMRCMSG(GMRCCNT+6,0)=""
+26 SET GMRCMSG(GMRCCNT+7,0)="NOTE: Data for deleted pointers can be "
+27 SET GMRCMSG(GMRCCNT+8,0)="found in the ""Install File Print"" record."
+28 SET GMRCMSG(GMRCCNT+9,0)="The record can be accessed by using the KIDS "
+29 SET GMRCMSG(GMRCCNT+10,0)="""Utility"" menu ""Install File Print"" option."
+30 SET GMRCMSG(GMRCCNT+11,0)=""
+31 DO ^XMD
+32 ;
+33 QUIT
+34 ;
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^GMRCYP9B(FILENUM,FIELDNUM,.RTS)
IF '$DATA(RTS)
QUIT
+11 IF $DATA(RTS)
DO REMOVE
+12 QUIT
+13 ;
FILE(X) ; Get File Number
+1 ; For CONSULTS.
SET TAG="DATC"
+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 CONSULTS.
SET TAG="DATC"
+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
DO REMDAT
+11 SET TOT=+($GET(TOT))+($GET(TERM))
SET GTOT=+($GET(GTOT))+($GET(TOT))
+12 IF +($GET(USR))=0
Begin DoDot:1
+13 SET GMRCCNT=GMRCCNT+1
+14 IF TOT>0
SET GMRCMSG(GMRCCNT,0)=" "_FILENUM_","_FIELDNUM_": "_TOT_" pointers to terminated users"_" deleted from this field."
+15 IF TOT'>0
SET GMRCMSG(GMRCCNT,0)=" "_FILENUM_","_FIELDNUM_": No pointers to terminated users found in this field."
End DoDot:1
+16 QUIT
+17 ;
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))
DO GETDAT
+6 QUIT
+7 ;
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
NEW IEN,LVL,DIC,DICP
SET LVL=OLDLVL
SET DIC=OLDDIC
DO REMDAT
+20 QUIT
+21 ;
EXTDAT ; Extract Data
+1 ;
+2 ; GMRCERR 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 ; GMRCUSRP Pointer Holder
+19 ;
+20 NEW GMRCERR,CDA,LDA,NODE,NODEDAT,NODELOC,NODESUB,GBLLOC,USRP,USRNAME,USRITD,USRETD,USRSTA,USRACT,GMRCUSRP
+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 GMRCUSRP=USRP
+30 KILL GMRCERR
SET USRNAME=$$GET1^DIQ(200,GMRCUSRP,.01,"E",,.GMRCERR)
IF $DATA(GMRCERR)
QUIT
+31 KILL GMRCERR
SET USRITD=$$GET1^DIQ(200,GMRCUSRP,9.2,"I",,.GMRCERR)
IF $DATA(GMRCERR)
QUIT
+32 SET USRSTA=$$TERM^GMRCYP9B(+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 ;
+27 IF '$DATA(DIC)
QUIT
IF '$DATA(DA)
QUIT
IF +($GET(RTS("FILE")))=0
QUIT
IF +($GET(RTS("FIELD")))=0
QUIT
+28 ;
+29 NEW I,LN,UDA
+30 SET OLDDA=DA
SET I=0
FOR
SET I=$ORDER(DA(I))
IF +I=0
QUIT
SET OLDDA(I)=DA(I)
+31 NEW DA
SET DA=OLDDA
SET I=0
FOR
SET I=$ORDER(OLDDA(I))
IF +I=0
QUIT
SET DA(I)=OLDDA(I)
+32 ;
+33 NEW DIK,DIE,DR,DLAYGO,DTOUT,DUOUT,X,Y,OLDDIC,OLDDUZ,VAR,GL
+34 IF $DATA(DUZ(0))
SET OLDDUZ=$GET(DUZ(0))
+35 SET OLDDIC=$GET(DIC)
+36 NEW DIC
SET (DIK,DIE,DIC)=$GET(OLDDIC)
SET GL=$GET(RTS("DIC",1))
IF '$DATA(@(GL_"0)"))
QUIT
+37 SET UDA=DA
IF $DATA(DA(1))&(+($ORDER(DA(" "),-1))>0)
SET UDA=DA(+($ORDER(DA(" "),-1)))
+38 IF +UDA=0
QUIT
SET LN=(GL_UDA_")")
+39 ;
+40 IF $DATA(RTS("DIC",2))&($LENGTH($GET(DICP)))
SET DIC("P")=$GET(DICP)
+41 SET DIC(0)=$GET(DIC(0))
IF DIC(0)'["L"
SET DIC(0)=DIC(0)_"L"
+42 SET DLAYGO=+($GET(RTS("FILE")))
+43 SET (DR,DIC("DR"))=+($GET(RTS("FIELD")))_"///^S X=VAR"
SET VAR="@"
+44 LOCK +@LN:0
+45 DO ^DIE
+46 LOCK -@LN
+47 ; Installation message to run under Taskman.
DO MES^XPDUTL("Pointer to "_USRNAME_"/"_+USRP_" deleted from file "_FILENUM_", field "_FIELDNUM_".")
+48 ;
+49 QUIT
+50 ;
DATC ; Data (FILE/FIELDS) for pointer removal (Consults)
+1 ;;123.5;123.5;ISC-SLC/PKS
+2 ;;123.5;123.08;ISC-SLC/PKS
+3 ;;123.54;1;ISC-SLC/PKS
+4 ;;123.55;.01;ISC-SLC/PKS
+5 ;;123.555;.01;ISC-SLC/PKS
+6 ;;
+7 ;
+8 QUIT
+9 ;
POST ; Further post-install action for patch GMRC*3*9.
+1 ;
+2 ; Set variables for Taskman:
+3 SET ZTRTN="RBLDIXS^GMRCYP9"
+4 SET ZTDTH=$HOROLOG
+5 SET ZTDESC="Consults GMRC*3*9 post-install file ^GMR(123.5 indices rebuild."
+6 SET ZTIO=""
+7 ;
+8 ; Call Taskman to run the post-install indices rebuild:
+9 DO ^%ZTLOAD
+10 QUIT
+11 ;
RBLDIXS ; Rebuild indices for ^GMR(123.5 file.
+1 ;
+2 NEW ROOT,IEN,DIK,DA
+3 ; Common file root for x-refs.
SET ROOT="^GMR(123.5,"
+4 ;
+5 SET IEN=0
+6 ; Each Consults service.
FOR
SET IEN=$ORDER(^GMR(123.5,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 SET DA(1)=IEN
SET DIK=ROOT_DA(1)_",123.1,"
SET DIK(1)=.01
+8 ; Rebuild "AST" x-ref.
DO ENALL^DIK
+9 ;
+10 SET DA(1)=IEN
SET DIK=ROOT_DA(1)_",123.2,"
SET DIK(1)=2
+11 ; Rebuild "ANT" x-ref.
DO ENALL^DIK
+12 ;
+13 SET DA(1)=IEN
SET DIK=ROOT_DA(1)_",123.31,"
SET DIK(1)=.01
+14 ; Rebuild "AUT" x-ref.
DO ENALL^DIK
+15 ;
+16 SET DA(1)=IEN
SET DIK=ROOT_DA(1)_",123.34,"
SET DIK(1)=.01
+17 ; Rebuild "AAT" x-ref.
DO ENALL^DIK
End DoDot:1
+18 ;
+19 QUIT
+20 ;
