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

ORY44.m

Go to the documentation of this file.
  1. ORY44 ; SLC/PKS-KR Remove Terminated Users ; [3/13/00 12:42pm]
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**44**;Dec 17, 1997
  1. ;
  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. ; ORYMSG Array for Bulletin Message
  1. ; ORYCNT Counter Variable
  1. ; XMvars Set for Bulletin Message
  1. ;
  1. N USR,TAG,FILENUM,FIELDNUM,LCNT,NOW,GTOT,RTS,DIFROM,ORYMSG,ORYCNT,XMDUZ,XMY,XMTEXT,XMSUB
  1. S LCNT=0,GTOT=0,ORYCNT=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 OR*3*44 Post-Init Notice"
  1. S XMTEXT="ORYMSG("
  1. S ORYMSG(ORYCNT+1,0)=""
  1. S ORYMSG(ORYCNT+2,0)="Upon successful completion of installation "
  1. S ORYMSG(ORYCNT+3,0)="of this patch, be sure to delete routines: "
  1. S ORYMSG(ORYCNT+4,0)=" ORY44"
  1. S ORYMSG(ORYCNT+5,0)=" ORY44B"
  1. S ORYMSG(ORYCNT+6,0)=" ORY44C"
  1. S ORYMSG(ORYCNT+7,0)=""
  1. S ORYMSG(ORYCNT+8,0)="NOTE: Data for deleted pointers (and any "
  1. S ORYMSG(ORYCNT+9,0)="deleted ""Personal"" type Team Lists) can be "
  1. S ORYMSG(ORYCNT+10,0)="found in the ""Install File Print"" record."
  1. S ORYMSG(ORYCNT+11,0)="The record can be accessed by using the KIDS "
  1. S ORYMSG(ORYCNT+12,0)="""Utility"" menu ""Install File Print"" option."
  1. S ORYMSG(ORYCNT+13,0)=""
  1. D ^XMD
  1. ;
  1. ; Call code to remove old Team Lists of "Personal" type with
  1. ; no users or when the only user is a terminated user:
  1. D EN^ORY44C
  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^ORY44B(FILENUM,FIELDNUM,.RTS) Q:'$D(RTS)
  1. D:$D(RTS) REMOVE
  1. Q
  1. ;
  1. FILE(X) ; Get File Number
  1. S TAG="DATO" ; For OE/RR.
  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="DATO" ; For OE/RR.
  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
  1. D REMDAT
  1. S TOT=+($G(TOT))+($G(TERM)),GTOT=+($G(GTOT))+($G(TOT))
  1. I +($G(USR))=0 D
  1. . S ORYCNT=ORYCNT+1
  1. . S:TOT>0 ORYMSG(ORYCNT,0)=" "_FILENUM_","_FIELDNUM_": "_TOT_" pointers to terminated users"_" deleted from this field."
  1. . S:TOT'>0 ORYMSG(ORYCNT,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))
  1. 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
  1. N IEN,LVL,DIC,DICP
  1. S LVL=OLDLVL,DIC=OLDDIC
  1. D REMDAT
  1. Q
  1. ;
  1. EXTDAT ; Extract Data
  1. ;
  1. ; ORLPERR 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. ; ORLPUSRP Pointer Holder
  1. ;
  1. N ORLPERR,CDA,LDA,NODE,NODEDAT,NODELOC,NODESUB,GBLLOC,USRP,USRNAME,USRITD,USRETD,USRSTA,USRACT,ORLPUSRP
  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 ORLPUSRP=USRP
  1. K ORLPERR S USRNAME=$$GET1^DIQ(200,ORLPUSRP,.01,"E",,.ORLPERR) Q:$D(ORLPERR)
  1. K ORLPERR S USRITD=$$GET1^DIQ(200,ORLPUSRP,9.2,"I",,.ORLPERR) Q:$D(ORLPERR)
  1. S USRSTA=$$TERM^ORY44B(+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. ; ORYTEAM Team IEN for Message
  1. ; ORYDAT Data File String Holder
  1. ;
  1. Q:'$D(DIC) Q:'$D(DA) Q:+($G(RTS("FILE")))=0 Q:+($G(RTS("FIELD")))=0
  1. ;
  1. N I,LN,UDA,ORYTEAM,ORYDAT
  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. S ORYTEAM=DA(1)
  1. ;
  1. ; Deal with variable pointers in 100.213:
  1. S ORYDAT=GL_DA(1)_",2,"_DA_",0)" I FILENUM="100.213",$G(@ORYDAT)'["VA" Q
  1. ;
  1. L +@LN:1
  1. D ^DIE
  1. L -@LN
  1. D MES^XPDUTL("Pointer to "_USRNAME_"/"_+USRP_" deleted from file "_FILENUM_", field "_FIELDNUM_" - team IEN "_ORYTEAM_".") ; Installation message to run under Taskman.
  1. ;
  1. Q
  1. ;
  1. ; NOTE: Next section does NOT work for variable pointer fields!
  1. DATO ; Data (FILE/FIELDS) for pointer removal (OERR)
  1. ;;100.212;.01;ISC-SLC/PKS
  1. ;;100.213;.01;ISC-SLC/PKS
  1. ;;