XU8P497.m

XU8P497 ;BP/BT - UPDATE PERSON CLASS FILE; 10/23/08

 ;;8.0;KERNEL;**497**;July 10, 1995;Build 5

 ;;"Per VHA Directive 2004-038, this routine should not be modified."

 ;

 Q

POST ; entry point of Post-Initi Routine

 D LOOP,INACTIVE

 Q

LOOP ; loop through New Person file. And map new Person Classes for users

 N XUIEN,XUPC,XUEFDATE,XUEXDATE

 K ^TMP("XU8P497")

 S XUIEN=0 F  S XUIEN=$O(^VA(200,XUIEN)) Q:XUIEN'>0  D

 . I $P($$ACTIVE^XUSER(XUIEN),"^",2)="TERMINATED" Q

 . S XUPC=$$GETPC(XUIEN)

 . I +XUPC>522 Q

 . I +XUPC<187 Q

 . S XUEFDATE=$P(XUPC,"^",2) I XUEFDATE<$$DT^XLFDT S XUEFDATE=$$DT^XLFDT

 . S XUEXDATE=$P(XUPC,"^",3)

 . I +XUPC=187 D REPOINT(XUIEN,181,XUEFDATE,XUEXDATE),PRINT(XUIEN,181) Q

 . I +XUPC=247 D REPOINT(XUIEN,1135,XUEFDATE,XUEXDATE),PRINT(XUIEN,1135) Q

 . I +XUPC=353 D REPOINT(XUIEN,675,XUEFDATE,XUEXDATE),PRINT(XUIEN,675) Q

 . I +XUPC=515 D REPOINT(XUIEN,352,XUEFDATE,XUEXDATE),PRINT(XUIEN,352) Q

 . I +XUPC=517 D REPOINT(XUIEN,352,XUEFDATE,XUEXDATE),PRINT(XUIEN,352) Q

 . I +XUPC=519 D REPOINT(XUIEN,354,XUEFDATE,XUEXDATE),PRINT(XUIEN,354) Q

 . I +XUPC=522 D REPOINT(XUIEN,352,XUEFDATE,XUEXDATE),PRINT(XUIEN,352) Q

 Q

 ;

REPOINT(USERIEN,NEWPC,EFDATE,EXDATE) ;Use FM so to fire X-ref's

 N RX1,RX2,DA1

 S DA1=USERIEN

 I $G(EFDATE)="" S EFDATE=$$DT^XLFDT

 S RX1(200.05,"+1,"_DA1_",",.01)=NEWPC

 S RX1(200.05,"+1,"_DA1_",",2)=$G(EFDATE)

 S RX1(200.05,"+1,"_DA1_",",3)=$G(EXDATE)

 L +^VA(200,DA1,"USC1"):2 I '$T D  Q

 .S XUA(1)="",XUA(2)=">>>User # "_DA1_" is locked at this time." D MES^XPDUTL(.XUA)

 D UPDATE^DIE("S","RX1","RX2")

 L -^VA(200,DA1,"USC1")

 Q

 ;

INACTIVE ; inactivate Person Class entries

 N XUI

 F XUI=187,247,353,515,517,519,522 D INAC(XUI)

 Q

 ;

INAC(PCIEN) ; inactivate single Person Class entry

 I +$G(PCIEN)'=$G(PCIEN) Q

 I $G(PCIEN)'>0 Q

 N XUA,XUDT S XUDT=$$DT^XLFDT

 L +^USC(8932.1,PCIEN,0):10 I '$T D  Q

 .S XUA(1)="",XUA(2)=">>>Record # "_PCIEN_" locked at time of patch installation. Could not inactivate." D MES^XPDUTL(.XUA)

 N DR,DIE,DA S DR="3////i",DIE="^USC(8932.1,",DA=PCIEN D ^DIE

 N DR,DIE,DA S DR="4///^S X=XUDT",DIE="^USC(8932.1,",DA=PCIEN D ^DIE

 L -^USC(8932.1,PCIEN,0)

 Q

 ;

PRINT(USERIEN,PCNEW) ; print a user who is assigned the replacement Person Class

 N XUA,XUY

 S XUY=+$O(^TMP("XU8P497",$J,"A"),-1)

 S XUA(1)=">>> The user "_$P($G(^VA(200,USERIEN,0)),"^")_" is assigned to the Person Class IEN: "_PCNEW

 S XUA(2)=""

 S ^TMP("XU8P497",$J,XUY+1)=XUA(1)

 D MES^XPDUTL(.XUA)

 Q

 ;

GETPC(XUIEN) ;Get Person Class for a single user

 N XUEXDA,XUPCIEN

 I +$G(XUIEN)'>0 Q ""

 I '$D(^VA(200,XUIEN,"USC1")) Q ""

 S XUPCIEN=$O(^VA(200,XUIEN,"USC1","A"),-1)

 I $G(XUPCIEN)'>0 Q ""

 S XUEXDA=$P($G(^VA(200,XUIEN,"USC1",XUPCIEN,0)),"^",3)

 I XUEXDA'="",(XUEXDA<$$DT^XLFDT) Q ""

 Q $G(^VA(200,XUIEN,"USC1",XUPCIEN,0))

 ;

SETDATE(USERIEN,PCIEN,XUEFDA,XUEXDA) ;set eff and exp date for the privious Person Class entry.

 I +$G(XUEFDA)>$$DT^XLFDT D SETEFDA(USERIEN,PCIEN,$$DT^XLFDT)

 I +$G(XUEXDA)>$$DT^XLFDT D SETEXDA(USERIEN,PCIEN,$$DT^XLFDT)

 Q

 ;

SETEXDA(USERIEN,PCIEN,EXDATE) ; set exp date

 N DIE,DA,DR

 S DA(1)=USERIEN ;

 S DA=PCIEN ; entry number in subfile

 S DIE="^VA(200,"_DA(1)_","_"""USC1"""_"," ; global root of subfile

 S DR="3///^S X=EXDATE" ; fields in subfile to edit

 L +^VA(200,USERIEN,"USC1"):2 I '$T D  Q

 .S XUA(1)="",XUA(2)=">>>User # "_DA1_" is locked at this time." D MES^XPDUTL(.XUA)

 D ^DIE

 L -^VA(200,USERIEN,"USC1")

 Q

SETEFDA(USERIEN,PCIEN,EFDATE) ; set eff date

 N DIE,DA,DR

 S DA(1)=USERIEN ;

 S DA=PCIEN ; entry number in subfile

 S DIE="^VA(200,"_DA(1)_","_"""USC1"""_"," ; global root of subfile

 S DR="2///^S X=EFDATE" ; fields in subfile to edit

 L +^VA(200,USERIEN,"USC1"):2 I '$T D  Q

 .S XUA(1)="",XUA(2)=">>>User # "_DA1_" is locked at this time." D MES^XPDUTL(.XUA)

 D ^DIE

 L -^VA(200,USERIEN,"USC1")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XU8P497   3897     printed  Feb 18, 2025@23:34:20                                                                                                                                                                                                     Page 2

XU8P497   ;BP/BT - UPDATE PERSON CLASS FILE; 10/23/08

 +1       ;;8.0;KERNEL;**497**;July 10, 1995;Build 5

 +2       ;;"Per VHA Directive 2004-038, this routine should not be modified."

 +3       ;

 +4        QUIT 

POST      ; entry point of Post-Initi Routine

 +1        DO LOOP

           DO INACTIVE

 +2        QUIT 

LOOP      ; loop through New Person file. And map new Person Classes for users

 +1        NEW XUIEN,XUPC,XUEFDATE,XUEXDATE

 +2        KILL ^TMP("XU8P497")

 +3        SET XUIEN=0

           FOR 

               SET XUIEN=$ORDER(^VA(200,XUIEN))

               if XUIEN'>0

                   QUIT 

               Begin DoDot:1

 +4                IF $PIECE($$ACTIVE^XUSER(XUIEN),"^",2)="TERMINATED"

                       QUIT 

 +5                SET XUPC=$$GETPC(XUIEN)

 +6                IF +XUPC>522

                       QUIT 

 +7                IF +XUPC<187

                       QUIT 

 +8                SET XUEFDATE=$PIECE(XUPC,"^",2)

                   IF XUEFDATE<$$DT^XLFDT

                       SET XUEFDATE=$$DT^XLFDT

 +9                SET XUEXDATE=$PIECE(XUPC,"^",3)

 +10               IF +XUPC=187

                       DO REPOINT(XUIEN,181,XUEFDATE,XUEXDATE)

                       DO PRINT(XUIEN,181)

                       QUIT 

 +11               IF +XUPC=247

                       DO REPOINT(XUIEN,1135,XUEFDATE,XUEXDATE)

                       DO PRINT(XUIEN,1135)

                       QUIT 

 +12               IF +XUPC=353

                       DO REPOINT(XUIEN,675,XUEFDATE,XUEXDATE)

                       DO PRINT(XUIEN,675)

                       QUIT 

 +13               IF +XUPC=515

                       DO REPOINT(XUIEN,352,XUEFDATE,XUEXDATE)

                       DO PRINT(XUIEN,352)

                       QUIT 

 +14               IF +XUPC=517

                       DO REPOINT(XUIEN,352,XUEFDATE,XUEXDATE)

                       DO PRINT(XUIEN,352)

                       QUIT 

 +15               IF +XUPC=519

                       DO REPOINT(XUIEN,354,XUEFDATE,XUEXDATE)

                       DO PRINT(XUIEN,354)

                       QUIT 

 +16               IF +XUPC=522

                       DO REPOINT(XUIEN,352,XUEFDATE,XUEXDATE)

                       DO PRINT(XUIEN,352)

                       QUIT 

               End DoDot:1

 +17       QUIT 

 +18      ;

REPOINT(USERIEN,NEWPC,EFDATE,EXDATE) ;Use FM so to fire X-ref's

 +1        NEW RX1,RX2,DA1

 +2        SET DA1=USERIEN

 +3        IF $GET(EFDATE)=""

               SET EFDATE=$$DT^XLFDT

 +4        SET RX1(200.05,"+1,"_DA1_",",.01)=NEWPC

 +5        SET RX1(200.05,"+1,"_DA1_",",2)=$GET(EFDATE)

 +6        SET RX1(200.05,"+1,"_DA1_",",3)=$GET(EXDATE)

 +7        LOCK +^VA(200,DA1,"USC1"):2

           IF '$TEST

               Begin DoDot:1

 +8                SET XUA(1)=""

                   SET XUA(2)=">>>User # "_DA1_" is locked at this time."

                   DO MES^XPDUTL(.XUA)

               End DoDot:1

               QUIT 

 +9        DO UPDATE^DIE("S","RX1","RX2")

 +10       LOCK -^VA(200,DA1,"USC1")

 +11       QUIT 

 +12      ;

INACTIVE  ; inactivate Person Class entries

 +1        NEW XUI

 +2        FOR XUI=187,247,353,515,517,519,522

               DO INAC(XUI)

 +3        QUIT 

 +4       ;

INAC(PCIEN) ; inactivate single Person Class entry

 +1        IF +$GET(PCIEN)'=$GET(PCIEN)

               QUIT 

 +2        IF $GET(PCIEN)'>0

               QUIT 

 +3        NEW XUA,XUDT

           SET XUDT=$$DT^XLFDT

 +4        LOCK +^USC(8932.1,PCIEN,0):10

           IF '$TEST

               Begin DoDot:1

 +5                SET XUA(1)=""

                   SET XUA(2)=">>>Record # "_PCIEN_" locked at time of patch installation. Could not inactivate."

                   DO MES^XPDUTL(.XUA)

               End DoDot:1

               QUIT 

 +6        NEW DR,DIE,DA

           SET DR="3////i"

           SET DIE="^USC(8932.1,"

           SET DA=PCIEN

           DO ^DIE

 +7        NEW DR,DIE,DA

           SET DR="4///^S X=XUDT"

           SET DIE="^USC(8932.1,"

           SET DA=PCIEN

           DO ^DIE

 +8        LOCK -^USC(8932.1,PCIEN,0)

 +9        QUIT 

 +10      ;

PRINT(USERIEN,PCNEW) ; print a user who is assigned the replacement Person Class

 +1        NEW XUA,XUY

 +2        SET XUY=+$ORDER(^TMP("XU8P497",$JOB,"A"),-1)

 +3        SET XUA(1)=">>> The user "_$PIECE($GET(^VA(200,USERIEN,0)),"^")_" is assigned to the Person Class IEN: "_PCNEW

 +4        SET XUA(2)=""

 +5        SET ^TMP("XU8P497",$JOB,XUY+1)=XUA(1)

 +6        DO MES^XPDUTL(.XUA)

 +7        QUIT 

 +8       ;

GETPC(XUIEN) ;Get Person Class for a single user

 +1        NEW XUEXDA,XUPCIEN

 +2        IF +$GET(XUIEN)'>0

               QUIT ""

 +3        IF '$DATA(^VA(200,XUIEN,"USC1"))

               QUIT ""

 +4        SET XUPCIEN=$ORDER(^VA(200,XUIEN,"USC1","A"),-1)

 +5        IF $GET(XUPCIEN)'>0

               QUIT ""

 +6        SET XUEXDA=$PIECE($GET(^VA(200,XUIEN,"USC1",XUPCIEN,0)),"^",3)

 +7        IF XUEXDA'=""

               IF (XUEXDA<$$DT^XLFDT)

                   QUIT ""

 +8        QUIT $GET(^VA(200,XUIEN,"USC1",XUPCIEN,0))

 +9       ;

SETDATE(USERIEN,PCIEN,XUEFDA,XUEXDA) ;set eff and exp date for the privious Person Class entry.

 +1        IF +$GET(XUEFDA)>$$DT^XLFDT

               DO SETEFDA(USERIEN,PCIEN,$$DT^XLFDT)

 +2        IF +$GET(XUEXDA)>$$DT^XLFDT

               DO SETEXDA(USERIEN,PCIEN,$$DT^XLFDT)

 +3        QUIT 

 +4       ;

SETEXDA(USERIEN,PCIEN,EXDATE) ; set exp date

 +1        NEW DIE,DA,DR

 +2       ;

           SET DA(1)=USERIEN

 +3       ; entry number in subfile

           SET DA=PCIEN

 +4       ; global root of subfile

           SET DIE="^VA(200,"_DA(1)_","_"""USC1"""_","

 +5       ; fields in subfile to edit

           SET DR="3///^S X=EXDATE"

 +6        LOCK +^VA(200,USERIEN,"USC1"):2

           IF '$TEST

               Begin DoDot:1

 +7                SET XUA(1)=""

                   SET XUA(2)=">>>User # "_DA1_" is locked at this time."

                   DO MES^XPDUTL(.XUA)

               End DoDot:1

               QUIT 

 +8        DO ^DIE

 +9        LOCK -^VA(200,USERIEN,"USC1")

 +10       QUIT 

SETEFDA(USERIEN,PCIEN,EFDATE) ; set eff date

 +1        NEW DIE,DA,DR

 +2       ;

           SET DA(1)=USERIEN

 +3       ; entry number in subfile

           SET DA=PCIEN

 +4       ; global root of subfile

           SET DIE="^VA(200,"_DA(1)_","_"""USC1"""_","

 +5       ; fields in subfile to edit

           SET DR="2///^S X=EFDATE"

 +6        LOCK +^VA(200,USERIEN,"USC1"):2

           IF '$TEST

               Begin DoDot:1

 +7                SET XUA(1)=""

                   SET XUA(2)=">>>User # "_DA1_" is locked at this time."

                   DO MES^XPDUTL(.XUA)

               End DoDot:1

               QUIT 

 +8        DO ^DIE

 +9        LOCK -^VA(200,USERIEN,"USC1")

 +10       QUIT