PRC168P ;VMP/RB - PRCFA SUPERVISOR key setting/audit ;03/01/12
;;5.1;IFCAP;**168**;Oct 20, 2000;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
Q
START ;
; Post install to set key PRCFA SUPERVISOR terminate setting
; to 'NO" and audit to look for terminated employees having
; PRCFA SUPERVISOR key.
;
Q:$D(^XTMP("PRC168P"))
SETUP D NOW^%DTC S RMSTART=%,(T1,T2,T3)=0
S ^XTMP("PRC168P","START COMPILE")=RMSTART
S ^XTMP("PRC168P","END COMPILE")="RUNNING"
S ^XTMP("PRC168P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
SET S CPOKEY=$O(^DIC(19.1,"B","PRCFA SUPERVISOR",0)) D:CPOKEY I 'CPOKEY W !!,"** NO PRCFA SUPERVISOR KEY DEFINED AS IFCAP SECURITY KEY **" G EXIT
. S R0=^DIC(19.1,CPOKEY,0)
. S ^XTMP("PRC168P","KEY",0)=$P(R0,U,4)_U_"n"
. S DA=CPOKEY,DIE="^DIC(19.1,",DR=".04///n" D ^DIE
AUDIT ;FIND EMPLOYEES IN ^VA(200) W/ KEY PRCFA SUPERVISOR
S IEN=0,U="^"
1 S IEN=$O(^VA(200,IEN)) G EXIT:IEN=""!(IEN]"@")
S R0=$G(^VA(200,IEN,0)) I R0="" S STS="X",T3=T3+1 D 3 G 1
2 S VAKEY=$O(^VA(200,IEN,51,"B",CPOKEY,0)) G 1:VAKEY=""!(VAKEY]"@") D
. S KR0=$G(^VA(200,IEN,51,VAKEY,0)) Q:$P(KR0,U)'=VAKEY
. I $P(R0,U,11) S STS="T",T1=T1+1 D D 3 Q
.. S DA=VAKEY,DA(1)=IEN,DIK="^VA(200,"_DA(1)_",51," D ^DIK
. S STS="A",T2=T2+1 D 3
G 1
3 S ^XTMP("PRC168P",STS,IEN,0)=$P(R0,U)_U_$P(R0,U,11)
Q
EXIT ;
D NOW^%DTC S RMEND=%
S ^XTMP("PRC168P","END COMPILE")=RMEND_U_T1_U_T2_U_T3
W !!,"Number of TERMINATED employees with key PRCFA SUPERVISOR still assigned: ",T1
W !!,"Number of ACTIVE employees with key PRCFA SUPERVISOR still assigned: ",T2
W !!,"Number of employees with *NO* node 0 information: ",T3
K RMEND,RMSTART,%,DR,DA,DIE,DIK,IEN,IENKEY,VAKEY,CPOKEY,T1,T2,T3,STS,R0,KR0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC168P 1764 printed Sep 23, 2025@19:35:28 Page 2
PRC168P ;VMP/RB - PRCFA SUPERVISOR key setting/audit ;03/01/12
+1 ;;5.1;IFCAP;**168**;Oct 20, 2000;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
+4 QUIT
START ;
+1 ; Post install to set key PRCFA SUPERVISOR terminate setting
+2 ; to 'NO" and audit to look for terminated employees having
+3 ; PRCFA SUPERVISOR key.
+4 ;
+5 if $DATA(^XTMP("PRC168P"))
QUIT
SETUP DO NOW^%DTC
SET RMSTART=%
SET (T1,T2,T3)=0
+1 SET ^XTMP("PRC168P","START COMPILE")=RMSTART
+2 SET ^XTMP("PRC168P","END COMPILE")="RUNNING"
+3 SET ^XTMP("PRC168P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
SET SET CPOKEY=$ORDER(^DIC(19.1,"B","PRCFA SUPERVISOR",0))
if CPOKEY
Begin DoDot:1
+1 SET R0=^DIC(19.1,CPOKEY,0)
+2 SET ^XTMP("PRC168P","KEY",0)=$PIECE(R0,U,4)_U_"n"
+3 SET DA=CPOKEY
SET DIE="^DIC(19.1,"
SET DR=".04///n"
DO ^DIE
End DoDot:1
IF 'CPOKEY
WRITE !!,"** NO PRCFA SUPERVISOR KEY DEFINED AS IFCAP SECURITY KEY **"
GOTO EXIT
AUDIT ;FIND EMPLOYEES IN ^VA(200) W/ KEY PRCFA SUPERVISOR
+1 SET IEN=0
SET U="^"
1 SET IEN=$ORDER(^VA(200,IEN))
if IEN=""!(IEN]"@")
GOTO EXIT
+1 SET R0=$GET(^VA(200,IEN,0))
IF R0=""
SET STS="X"
SET T3=T3+1
DO 3
GOTO 1
2 SET VAKEY=$ORDER(^VA(200,IEN,51,"B",CPOKEY,0))
if VAKEY=""!(VAKEY]"@")
GOTO 1
Begin DoDot:1
+1 SET KR0=$GET(^VA(200,IEN,51,VAKEY,0))
if $PIECE(KR0,U)'=VAKEY
QUIT
+2 IF $PIECE(R0,U,11)
SET STS="T"
SET T1=T1+1
Begin DoDot:2
+3 SET DA=VAKEY
SET DA(1)=IEN
SET DIK="^VA(200,"_DA(1)_",51,"
DO ^DIK
End DoDot:2
DO 3
QUIT
+4 SET STS="A"
SET T2=T2+1
DO 3
End DoDot:1
+5 GOTO 1
3 SET ^XTMP("PRC168P",STS,IEN,0)=$PIECE(R0,U)_U_$PIECE(R0,U,11)
+1 QUIT
EXIT ;
+1 DO NOW^%DTC
SET RMEND=%
+2 SET ^XTMP("PRC168P","END COMPILE")=RMEND_U_T1_U_T2_U_T3
+3 WRITE !!,"Number of TERMINATED employees with key PRCFA SUPERVISOR still assigned: ",T1
+4 WRITE !!,"Number of ACTIVE employees with key PRCFA SUPERVISOR still assigned: ",T2
+5 WRITE !!,"Number of employees with *NO* node 0 information: ",T3
+6 KILL RMEND,RMSTART,%,DR,DA,DIE,DIK,IEN,IENKEY,VAKEY,CPOKEY,T1,T2,T3,STS,R0,KR0
+7 QUIT
