Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCYP9

GMRCYP9.m

Go to the documentation of this file. 
  1. GMRCYP9 ; SLC/PKS-KR Remove Terminated Users ; [2/18/00 3:17pm]
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**9**;Dec 27, 1997
  1.  Q
  1.  ;           
  1. BF ; Remove Entries for all Terminated Users (By File)
  1.  ;              
  1.  ;     FILENUM   File #
  1.  ;     FIELDNUM  Field #
  1.  ;     LCNT      Line Counter
  1.  ;     RTS(      Array of Global Roots
  1.  ;     GTOT      Grand Total Terminated Users
  1.  ;     GMRCMSG   Array for Bulletin Message
  1.  ;     GMRCCNT   Counter Variable
  1.  ;     XMvars    Set for Bulletin Message
  1.  ;            
  1.  D POST ; Rebuild x-refs for REQUEST SERVICES file.
  1.  ;
  1.  N USR,TAG,FILENUM,FIELDNUM,LCNT,NOW,GTOT,RTS,DIFROM,GMRCMSG,GMRCCNT,XMDUZ,XMY,XMTEXT,XMSUB
  1.  S LCNT=0,GTOT=0,GMRCCNT=0,NOW=DT
  1.  F LCNT=1:1 D CHECK  Q:FILENUM=""!(FIELDNUM="")
  1.  ;
  1.  ; Send a bulletin to the user with information on terminations:
  1.  S XMDUZ=.5,XMY(DUZ)="",XMSUB="  Patch GMRC*3*9 Post-Init Notice"
  1.  S XMTEXT="GMRCMSG("
  1.  S GMRCMSG(GMRCCNT+1,0)=""
  1.  S GMRCMSG(GMRCCNT+2,0)="Upon successful completion of installation "
  1.  S GMRCMSG(GMRCCNT+3,0)="of this patch, be sure to delete routines: "
  1.  S GMRCMSG(GMRCCNT+4,0)="     GMRCYP9"
  1.  S GMRCMSG(GMRCCNT+5,0)="     GMRCYP9B"
  1.  S GMRCMSG(GMRCCNT+6,0)=""
  1.  S GMRCMSG(GMRCCNT+7,0)="NOTE: Data for deleted pointers can be "
  1.  S GMRCMSG(GMRCCNT+8,0)="found in the ""Install File Print"" record."
  1.  S GMRCMSG(GMRCCNT+9,0)="The record can be accessed by using the KIDS "
  1.  S GMRCMSG(GMRCCNT+10,0)="""Utility"" menu ""Install File Print"" option."
  1.  S GMRCMSG(GMRCCNT+11,0)=""
  1.  D ^XMD
  1.  ;
  1.  Q
  1.  ;
  1. CHECK ; Check users in <FILE> and <FIELD>
  1.  ;          
  1.  ;     FILENUM   File #
  1.  ;     FIELDNUM  Field #
  1.  ;     LCNT      Line Counter
  1.  ;     RTS(      Array of Global Roots
  1.  ;            
  1.  S FILENUM=$$FILE(LCNT) Q:FILENUM=""
  1.  S FIELDNUM=$$FIELD(LCNT) Q:FIELDNUM=""
  1.  K RTS
  1.  D INFO^GMRCYP9B(FILENUM,FIELDNUM,.RTS) Q:'$D(RTS)
  1.  D:$D(RTS) REMOVE
  1.  Q
  1.  ;
  1. FILE(X) ; Get File Number
  1.  S TAG="DATC" ; For CONSULTS.
  1.  S X=+($G(X)) Q:X="" "" S X=$P($T(@TAG+X),";;",2) Q:X="" ""
  1.  S X=$P(X,";",1) Q X
  1.  ;           
  1. FIELD(X) ; Get Field Number
  1.  S TAG="DATC" ; For CONSULTS.
  1.  S X=+($G(X)) Q:X="" "" S X=$P($T(@TAG+X),";;",2) Q:X="" ""
  1.  S X=$P(X,";",2) Q X
  1.  ;           
  1. REMOVE ; Remove Terminated User
  1.  ;               
  1.  ;     DA        Current DA Array
  1.  ;     DIC       Current Global Root
  1.  ;     LVL       Current Level
  1.  ;     IND       Indentation (for write statements)
  1.  ;     TERM      Terminated Entries Found in File
  1.  ;     TOT       Total Terminated Entries Found
  1.  ;
  1.  N DA,IEN,DIC,LVL,IND,TOT,TERM
  1.  S (TERM,LVL,TOT)=0,IND=2 D REMDAT
  1.  S TOT=+($G(TOT))+($G(TERM)),GTOT=+($G(GTOT))+($G(TOT))
  1.  I +($G(USR))=0 D
  1.  . S GMRCCNT=GMRCCNT+1
  1.  . S:TOT>0 GMRCMSG(GMRCCNT,0)="     "_FILENUM_","_FIELDNUM_": "_TOT_" pointers to terminated users"_" deleted from this field."
  1.  . S:TOT'>0 GMRCMSG(GMRCCNT,0)="     "_FILENUM_","_FIELDNUM_": No pointers to terminated users found in this field."
  1.  Q
  1.  ;
  1. REMDAT ; Get Removal Data (Name and Termination Date)
  1.  ;               
  1.  ;     LVL       Current Level
  1.  ;     RTS(      Array of Global Roots
  1.  ;                    
  1.  S LVL=$O(RTS("DIC",LVL)) D GETDAT
  1.  Q
  1.  ;
  1. GETDAT ; Get Data
  1.  ;               
  1.  ;     DA        Current DA Array
  1.  ;     DIC       Current Global Root
  1.  ;     DICP      Current Global Specifier
  1.  ;     LVL       Current Level
  1.  ;     IEN       Current Internal Entry Number
  1.  ;     RTS(      Array of Global Roots
  1.  ;                    
  1.  S DIC=$G(RTS("DIC",LVL)) Q:'$L(DIC)
  1.  S:$L($G(RTS("DIC",LVL,"P"))) DICP=RTS("DIC",LVL,"P")
  1.  S IEN=0 F  S IEN=$O(@(DIC_IEN_")")) Q:+IEN=0  D  Q:+IEN=0
  1.  . Q:+IEN=0  S DA=IEN
  1.  . D NEXTDAT:+($O(RTS("DIC",LVL)))>0,EXTDAT:+($O(RTS("DIC",LVL)))'>0
  1.  Q
  1.  ;
  1. NEXTDAT ; Next Data (for subfiles)
  1.  ;            
  1.  ;     DA        Current DA Array
  1.  ;     DIC       Current Global Root
  1.  ;     DICP      Current Global Specifier
  1.  ;     LVL       Current Level
  1.  ;     IEN       Current Internal Entry Number
  1.  ;     OLDDA     Previous DA Array
  1.  ;     OLDDIC    Previous Global Root
  1.  ;     OLDLVL    Previous Level
  1.  ;     CNT       Counter
  1.  ;            
  1.  N CNT,OLDDA,OLDLVL,OLDDIC,OLDDICP
  1.  S OLDDA=DA,OLDLVL=LVL,OLDDIC=DIC,OLDDICP=$G(DICP)
  1.  F CNT=1:1:$O(DA(" "),-1) D
  1.  . S:$D(DA(CNT)) OLDDA(CNT)=DA(CNT)
  1.  N DA
  1.  F CNT=1:1:$O(OLDDA(" "),-1) D
  1.  . S:$D(OLDDA(CNT)) DA(CNT+1)=OLDDA(CNT)
  1.  S DA(1)=OLDDA N IEN,LVL,DIC,DICP S LVL=OLDLVL,DIC=OLDDIC D REMDAT
  1.  Q
  1.  ;
  1. EXTDAT ; Extract Data
  1.  ;          
  1.  ;     GMRCERR   Error Message Array
  1.  ;     CDA       DA Counter
  1.  ;     LDA       Last DA
  1.  ;     NODE      Fully Specified Global Node
  1.  ;     NODEDAT   Data Stored at Global Node
  1.  ;     NODESUB   Node Subscript #
  1.  ;     NODELOC   Node Location ($PIECE # of Node)
  1.  ;     GBLLOC    Global Subscript Location  (#;#)
  1.  ;     DIC       Fully Specified Global Root
  1.  ;     DICP      Global Specifier
  1.  ;     USRP      Pointer to New Person File
  1.  ;     USRNAME   User's Name
  1.  ;     USRITD    Internal form of User's Termination Date
  1.  ;     USRETD    External form of User's Termination Date
  1.  ;     USRSTA    User Status
  1.  ;     USRACT    User Action
  1.  ;     GMRCUSRP  Pointer Holder
  1.  ;          
  1.  N GMRCERR,CDA,LDA,NODE,NODEDAT,NODELOC,NODESUB,GBLLOC,USRP,USRNAME,USRITD,USRETD,USRSTA,USRACT,GMRCUSRP
  1.  S GBLLOC=$G(RTS("LOC")) Q:$L($G(GBLLOC),";")'=2
  1.  S NODESUB=$P($G(GBLLOC),";",1),NODELOC=+($P($G(GBLLOC),";",2))
  1.  Q:'$L(NODESUB)  Q:+(NODELOC)'>0  Q:'$L($G(DIC))  Q:+($G(DA))'>0
  1.  Q:'$L($G(NODESUB))  Q:+($G(NODELOC))'>0  Q:DIC["DA("&(+($G(DA(1)))=0)
  1.  Q:'$L($G(DICP))
  1.  S NODE=DIC_DA_","_NODESUB_")" Q:'$D(@NODE)  S NODEDAT=@NODE
  1.  S USRP=+($P(NODEDAT,"^",NODELOC)) Q:USRP=0
  1.  I +($G(USR))>0,$D(^VA(200,+($G(USR)),0)),$L($P($G(^VA(200,+($G(USR)),0)),"^",1)),+($G(USR))'=USRP Q
  1.  S GMRCUSRP=USRP
  1.  K GMRCERR S USRNAME=$$GET1^DIQ(200,GMRCUSRP,.01,"E",,.GMRCERR) Q:$D(GMRCERR)
  1.  K GMRCERR S USRITD=$$GET1^DIQ(200,GMRCUSRP,9.2,"I",,.GMRCERR) Q:$D(GMRCERR)
  1.  S USRSTA=$$TERM^GMRCYP9B(+USRP),USRACT=$P(USRSTA,"^",1),USRSTA=$S(USRACT=2:"Terminated",USRACT=1:"Future Termination",USRACT=0:"Active User",1:"Undetermined")
  1.  S USRETD=$$FMTE^XLFDT(USRITD,1) Q:USRACT'=2  S:USRACT=2 TERM=TERM+1 D:USRACT=2 DEL
  1.  I +($G(USR))>0,$D(^VA(200,+($G(USR)),0)),$L($P($G(^VA(200,+($G(USR)),0)),"^",1)) Q
  1.  S LDA=+($O(DA(" "),-1))
  1.  Q
  1.  ;
  1. DEL ; Delete Entry
  1.  ;          
  1.  ;     DIC       Current Global Root
  1.  ;     OLDDIC    Former DIC (Global Root)
  1.  ;     DIC(0)    Lookup Parameters
  1.  ;     DIC("P")  Subfile Specifiers
  1.  ;     DIC("DR") Data Field String
  1.  ;     OLDDA     Former DA Array
  1.  ;     DA        Current DA Array
  1.  ;                     
  1.  ;     DIE       Global Root
  1.  ;     DIK       Global Root
  1.  ;     DR        Data Field String
  1.  ;     DTOUT     Timeout Flag
  1.  ;     DUOUT     Up-Arrow Out Flag
  1.  ;     DLAYGO    "Learn As You Go" Flag
  1.  ;     OLDDUZ    Former User
  1.  ;     DUZ       Current User
  1.  ;     DUZ(0)    Current User Access
  1.  ;     GL        Fileman Global Location
  1.  ;     UDA       Uppermost DA
  1.  ;     LN        Node to Lock
  1.  ;     VAR       Field Value
  1.  ;     X         Input Data
  1.  ;     Y         Output Data
  1.  ;     I         Counter
  1.  ;          
  1.  Q:'$D(DIC)  Q:'$D(DA)  Q:+($G(RTS("FILE")))=0  Q:+($G(RTS("FIELD")))=0
  1.  ;
  1.  N I,LN,UDA
  1.  S OLDDA=DA,I=0 F  S I=$O(DA(I)) Q:+I=0  S OLDDA(I)=DA(I)
  1.  N DA S DA=OLDDA,I=0 F  S I=$O(OLDDA(I)) Q:+I=0  S DA(I)=OLDDA(I)
  1.  ;
  1.  N DIK,DIE,DR,DLAYGO,DTOUT,DUOUT,X,Y,OLDDIC,OLDDUZ,VAR,GL
  1.  S:$D(DUZ(0)) OLDDUZ=$G(DUZ(0))
  1.  S OLDDIC=$G(DIC)
  1.  N DIC S (DIK,DIE,DIC)=$G(OLDDIC),GL=$G(RTS("DIC",1)) Q:'$D(@(GL_"0)"))
  1.  S UDA=DA S:$D(DA(1))&(+($O(DA(" "),-1))>0) UDA=DA(+($O(DA(" "),-1)))
  1.  Q:+UDA=0  S LN=(GL_UDA_")")
  1.  ;
  1.  S:$D(RTS("DIC",2))&($L($G(DICP))) DIC("P")=$G(DICP)
  1.  S DIC(0)=$G(DIC(0)) S:DIC(0)'["L" DIC(0)=DIC(0)_"L"
  1.  S DLAYGO=+($G(RTS("FILE")))
  1.  S (DR,DIC("DR"))=+($G(RTS("FIELD")))_"///^S X=VAR",VAR="@"
  1.  L +@LN:0
  1.  D ^DIE
  1.  L -@LN
  1.  D MES^XPDUTL("Pointer to "_USRNAME_"/"_+USRP_" deleted from file "_FILENUM_", field "_FIELDNUM_".") ; Installation message to run under Taskman.
  1.  ;
  1.  Q
  1.  ;
  1. DATC ; Data (FILE/FIELDS) for pointer removal (Consults)
  1.  ;;123.5;123.5;ISC-SLC/PKS
  1.  ;;123.5;123.08;ISC-SLC/PKS
  1.  ;;123.54;1;ISC-SLC/PKS
  1.  ;;123.55;.01;ISC-SLC/PKS
  1.  ;;123.555;.01;ISC-SLC/PKS
  1.  ;;
  1.  ;
  1.  Q
  1.  ;
  1. POST ; Further post-install action for patch GMRC*3*9.
  1.  ;
  1.  ; Set variables for Taskman:
  1.  S ZTRTN="RBLDIXS^GMRCYP9"
  1.  S ZTDTH=$H
  1.  S ZTDESC="Consults GMRC*3*9 post-install file ^GMR(123.5 indices rebuild."
  1.  S ZTIO=""
  1.  ;
  1.  ; Call Taskman to run the post-install indices rebuild:
  1.  D ^%ZTLOAD
  1.  Q
  1.  ;
  1. RBLDIXS ; Rebuild indices for ^GMR(123.5 file.
  1.  ;
  1.  N ROOT,IEN,DIK,DA
  1.  S ROOT="^GMR(123.5," ; Common file root for x-refs.
  1.  ;
  1.  S IEN=0
  1.  F  S IEN=$O(^GMR(123.5,IEN)) Q:'IEN  D  ; Each Consults service.
  1.  .S DA(1)=IEN,DIK=ROOT_DA(1)_",123.1,",DIK(1)=.01
  1.  .D ENALL^DIK         ; Rebuild "AST" x-ref.
  1.  .;
  1.  .S DA(1)=IEN,DIK=ROOT_DA(1)_",123.2,",DIK(1)=2
  1.  .D ENALL^DIK         ; Rebuild "ANT" x-ref.
  1.  .;
  1.  .S DA(1)=IEN,DIK=ROOT_DA(1)_",123.31,",DIK(1)=.01
  1.  .D ENALL^DIK         ; Rebuild "AUT" x-ref.
  1.  .;
  1.  .S DA(1)=IEN,DIK=ROOT_DA(1)_",123.34,",DIK(1)=.01
  1.  .D ENALL^DIK         ; Rebuild "AAT" x-ref.
  1.  ;
  1.  Q
  1.  ;