XUINP313.m

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 ---XUINP313   2501     printed  Mar 13, 2025@21:14:39                                                                                                                                                                                                    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)