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 ---[H[J[2J[HXU8P497 3897 printed Dec 13, 2024@02:07:55 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
