XUINP313 ;ISF/RWF - Post-init for patch XU*8*313 ;07/14/2003 14:41
;;8.0;KERNEL;**313**;Jul 10, 1995
;
POST ;Run Terminate event for users after 6/10/2003
N Y,DATE,DT
S Y=$G(XPDQUES("POS001")) Q:Y'=1
S DT=$$DT^XLFDT
S DATE=$G(XPDQUES("POS002")) Q:DATE'>3030101
D PROC
Q
;
TEST ;Test Terminate event
N Y,DIR,DUOUT,DTOUT,DATE
S DIR(0)="Y",DIR("A")="Run Terminate events",DIR("B")="NO"
S DIR("A",1)="If you installed patch XU*8*290 you should answer Yes"
S DIR("A",2)="(If you installed XU*8*313 V3, this has already been done)"
S DIR("A",3)=""
S DIR("A",4)="A Yes answer will cause all users Terminated after a date you"
S DIR("A",5)="choose to have the XU USER TERMINATE protocol run on them."
D ^DIR
Q:Y'=1
K DIR
S DIR(0)="D^3030101:3030701"
S DIR("A")="Date of patch XU*8*290 install",DIR("B")="06/10/2003"
D ^DIR
S DATE=Y Q:DATE'>3030101
S DT=$$DT^XLFDT
D PROC
Q
;
PROC ;Process
N XUDA,XUIEN,XUIFN,D
S XUDA=.5
F S XUDA=$O(^VA(200,XUDA)) Q:XUDA'>0 S X=$G(^VA(200,XUDA,0)),D=$P(X,"^",11) I D>DATE,D<DT D
. D DEQUE^XUSERP(XUDA,3)
. Q
Q
;
LK(X) ;Lookup Option Name
Q $O(^DIC(19,"B",X,0))
;
PRETEST ;Test the pre-init
N DIR
S DIR(0)="Y",DIR("A")="Add national items to the XU USER TERMINATE option",DIR("B")="Yes"
D ^DIR Q:Y'=1
S XPDQUES("PRE001")=Y
D PRE
Q
PRE ;Check if OK for pre-init to add national items back
N OPT,I,X,LIST,MENU,MSG
Q:'$G(XPDQUES("PRE001")) ;Check Pre-init answer
S LIST="USR USER TERMINATE^GMRC TERMINATE CLEANUP^OR TERMINATE CLEANUP^PRCS TERMINATE^TIU TEMPLATE USER DELETE"
S MENU=$$LK("XU USER TERMINATE")
F I=1:1:5 S OPT=$P(LIST,"^",I) S MSG=OPT D D MES^XPDUTL(MSG)
. S X=$$LK(OPT) I X'>0 S MSG=MSG_" not on system" Q
. I $D(^DIC(19,MENU,10,"B",X)) S MSG=MSG_" already on menu." Q
. S X=$$ADD("XU USER TERMINATE",OPT) S MSG=MSG_" "_$S(X>0:"",1:"NOT ")_"Added"
Q
;
ADD(MENU,OPT,SYN,ORD) ;EF. Add options to a menu
Q:$G(MENU)']"" 0 Q:$G(OPT)']"" 0
N X,XPD1,XPD2,XPD3,DIC,DA,D0,DR,DLAYGO
S XPD1=$$LK(MENU) Q:XPD1'>0 -1
;quit if type is not extended action
I $$TYPE(XPD1)'["X" Q -2
S XPD2=$$LK(OPT) Q:XPD2'>0 -3
;if OPTion is not in menu, add it
I '$D(^DIC(19,XPD1,10,"B",XPD2)) D
.S X=XPD2,(D0,DA(1))=XPD1,DIC(0)="MLF",DIC("P")=$P(^DD(19,10,0),"^",2),DLAYGO=19,DIC="^DIC(19,"_XPD1_",10,"
.D FILE^DICN
S XPD3=$O(^DIC(19,XPD1,10,"B",XPD2,0))
Q XPD3>0
;
TYPE(X) ;EF. Return option type, Pass IFN.
Q:X'>0 "" Q $P($G(^DIC(19,X,0)),"^",4)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUINP313 2501 printed Sep 23, 2025@19:45:58 Page 2
XUINP313 ;ISF/RWF - Post-init for patch XU*8*313 ;07/14/2003 14:41
+1 ;;8.0;KERNEL;**313**;Jul 10, 1995
+2 ;
POST ;Run Terminate event for users after 6/10/2003
+1 NEW Y,DATE,DT
+2 SET Y=$GET(XPDQUES("POS001"))
if Y'=1
QUIT
+3 SET DT=$$DT^XLFDT
+4 SET DATE=$GET(XPDQUES("POS002"))
if DATE'>3030101
QUIT
+5 DO PROC
+6 QUIT
+7 ;
TEST ;Test Terminate event
+1 NEW Y,DIR,DUOUT,DTOUT,DATE
+2 SET DIR(0)="Y"
SET DIR("A")="Run Terminate events"
SET DIR("B")="NO"
+3 SET DIR("A",1)="If you installed patch XU*8*290 you should answer Yes"
+4 SET DIR("A",2)="(If you installed XU*8*313 V3, this has already been done)"
+5 SET DIR("A",3)=""
+6 SET DIR("A",4)="A Yes answer will cause all users Terminated after a date you"
+7 SET DIR("A",5)="choose to have the XU USER TERMINATE protocol run on them."
+8 DO ^DIR
+9 if Y'=1
QUIT
+10 KILL DIR
+11 SET DIR(0)="D^3030101:3030701"
+12 SET DIR("A")="Date of patch XU*8*290 install"
SET DIR("B")="06/10/2003"
+13 DO ^DIR
+14 SET DATE=Y
if DATE'>3030101
QUIT
+15 SET DT=$$DT^XLFDT
+16 DO PROC
+17 QUIT
+18 ;
PROC ;Process
+1 NEW XUDA,XUIEN,XUIFN,D
+2 SET XUDA=.5
+3 FOR
SET XUDA=$ORDER(^VA(200,XUDA))
if XUDA'>0
QUIT
SET X=$GET(^VA(200,XUDA,0))
SET D=$PIECE(X,"^",11)
IF D>DATE
IF D<DT
Begin DoDot:1
+4 DO DEQUE^XUSERP(XUDA,3)
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
LK(X) ;Lookup Option Name
+1 QUIT $ORDER(^DIC(19,"B",X,0))
+2 ;
PRETEST ;Test the pre-init
+1 NEW DIR
+2 SET DIR(0)="Y"
SET DIR("A")="Add national items to the XU USER TERMINATE option"
SET DIR("B")="Yes"
+3 DO ^DIR
if Y'=1
QUIT
+4 SET XPDQUES("PRE001")=Y
+5 DO PRE
+6 QUIT
PRE ;Check if OK for pre-init to add national items back
+1 NEW OPT,I,X,LIST,MENU,MSG
+2 ;Check Pre-init answer
if '$GET(XPDQUES("PRE001"))
QUIT
+3 SET LIST="USR USER TERMINATE^GMRC TERMINATE CLEANUP^OR TERMINATE CLEANUP^PRCS TERMINATE^TIU TEMPLATE USER DELETE"
+4 SET MENU=$$LK("XU USER TERMINATE")
+5 FOR I=1:1:5
SET OPT=$PIECE(LIST,"^",I)
SET MSG=OPT
Begin DoDot:1
+6 SET X=$$LK(OPT)
IF X'>0
SET MSG=MSG_" not on system"
QUIT
+7 IF $DATA(^DIC(19,MENU,10,"B",X))
SET MSG=MSG_" already on menu."
QUIT
+8 SET X=$$ADD("XU USER TERMINATE",OPT)
SET MSG=MSG_" "_$SELECT(X>0:"",1:"NOT ")_"Added"
End DoDot:1
DO MES^XPDUTL(MSG)
+9 QUIT
+10 ;
ADD(MENU,OPT,SYN,ORD) ;EF. Add options to a menu
+1 if $GET(MENU)']""
QUIT 0
if $GET(OPT)']""
QUIT 0
+2 NEW X,XPD1,XPD2,XPD3,DIC,DA,D0,DR,DLAYGO
+3 SET XPD1=$$LK(MENU)
if XPD1'>0
QUIT -1
+4 ;quit if type is not extended action
+5 IF $$TYPE(XPD1)'["X"
QUIT -2
+6 SET XPD2=$$LK(OPT)
if XPD2'>0
QUIT -3
+7 ;if OPTion is not in menu, add it
+8 IF '$DATA(^DIC(19,XPD1,10,"B",XPD2))
Begin DoDot:1
+9 SET X=XPD2
SET (D0,DA(1))=XPD1
SET DIC(0)="MLF"
SET DIC("P")=$PIECE(^DD(19,10,0),"^",2)
SET DLAYGO=19
SET DIC="^DIC(19,"_XPD1_",10,"
+10 DO FILE^DICN
End DoDot:1
+11 SET XPD3=$ORDER(^DIC(19,XPD1,10,"B",XPD2,0))
+12 QUIT XPD3>0
+13 ;
TYPE(X) ;EF. Return option type, Pass IFN.
+1 if X'>0
QUIT ""
QUIT $PIECE($GET(^DIC(19,X,0)),"^",4)
