PRCPXTRM ;WISC/RFJ-user termination, add, build array, utilities ; 11/6/06 8:46am
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
TERMUSER(USERDUZ) ; remove user as inventory user from all inventory pts
; called internally (not by prcp options)
; 'Do' block modified by PRC*5.1*98 to add ODI cleanup
I '$D(^VA(200,+USERDUZ,0)) Q
N INVPT
S INVPT=0 F S INVPT=$O(^PRCP(445,INVPT)) Q:'INVPT D
. I $D(^PRCP(445,INVPT,4,USERDUZ)) D KILLUSER(INVPT,USERDUZ)
. I $D(^PRCP(445,INVPT,9,USERDUZ)) D DEL^PRCPAODI(INVPT,USERDUZ)
Q
;
;
KILLUSER(INVPT,USERDUZ) ; remove user (userduz) from invpt
I '$D(^PRCP(445,+INVPT,4,+USERDUZ)) Q
N %,DA,DIC,DIK,X,Y
S DIK="^PRCP(445,"_+INVPT_",4,",DA(1)=+INVPT,DA=+USERDUZ D ^DIK
I '$O(^PRCP(445,INVPT,4,0)) D NOUSER(INVPT)
Q
;
;
NOUSER(INVPT) ; send mailmsg to g.irm if invpt has no users
N INVNAME,PRCPTEXT,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,XMZ ; XMSUB,XMTEXT added with PRC*5.1*98
S XMDUZ=.5,XMY("G.IRM")=""
S INVNAME=$$INVNAME^PRCPUX1(INVPT)
K PRCPTEXT
S PRCPTEXT(1,0)="TO: G.IRM"
S PRCPTEXT(2,0)="The inventory point "_INVNAME_" (#"_INVPT_") has NO authorized users"
S PRCPTEXT(3,0)="(field #6 in file #445)."
S PRCPTEXT(4,0)=" "
S PRCPTEXT(5,0)="You can use the following mumps call to add users:"
S PRCPTEXT(6,0)=" D ADDUSER^PRCPXTRM(INVPT,USERDUZ)"
S PRCPTEXT(7,0)=" where INVPT is the internal inventory point number;"
S PRCPTEXT(8,0)=" USERDUZ is the users DUZ."
S PRCPTEXT(9,0)=" "
S PRCPTEXT(10,0)="For example: D ADDUSER^PRCPXTRM("_INVPT_",100) would add user 100 to the"
S PRCPTEXT(11,0)=INVNAME_" (#"_INVPT_") inventory point listed above."
S PRCPTEXT(12,0)=" "
S PRCPTEXT(13,0)="Once an inventory user is added, the inventory point may be inactivated"
S PRCPTEXT(14,0)="if no longer used."
S XMSUB="INVENTORY POINT HAS NO AUTHORIZED USERS",XMTEXT="PRCPTEXT(" D ^XMD
Q
;
;
ADDUSER(INVPT,USERDUZ) ; add authorized users to invpt
I '$D(^VA(200,+USERDUZ,0)) Q
I '$D(^PRCP(445,+INVPT,0)) Q
I $D(^PRCP(445,+INVPT,4,+USERDUZ,0)) Q
N %,D0,DA,DD,DIC,DINUM,DLAYGO,PRCPPRIV,X,Y ; DINUM added PRC*5.1*98
I '$D(^PRCP(445,+INVPT,4,0)) S ^PRCP(445,+INVPT,4,0)="^445.04P^^"
S DIC="^PRCP(445,"_+INVPT_",4,",DIC(0)="L",DLAYGO=445,DA(1)=+INVPT,(X,DINUM)=+USERDUZ,PRCPPRIV=1
D FILE^DICN
Q
;
;
GETUSER(INVPT) ; build prcpxmy array of users
; if user is manager, set prcpxmy(duz)=1 otherwise 0
N %,X
K PRCPXMY
I '$D(^PRCP(445,+INVPT,4)) Q
S %=$P(^PRCP(445,INVPT,0),"^",3),%="PRCP"_$TR(%,"WSP","W2")_" MGRKEY"
S X=0 F S X=$O(^PRCP(445,INVPT,4,X)) Q:'X S PRCPXMY(X)=$S($$KEY^PRCPUREP(%,X):1,1:0)
Q
;
;
INSTALL(SUBJECT,LINE2,TEXT) ; send install message to forum
; text = text to be included from line 10 and up
N DIC,XCNP,XMDUZ,XMSUB,XMTEXT,XMZ
S TEXT(1,0)=" ",TEXT(2,0)="Installation of IFCAP "_LINE2_" information message:",TEXT(3,0)="",TEXT(4,0)=" site: "_$G(^DD("SITE"))
X ^%ZOSF("UCI") S TEXT(5,0)=" op sys: "_$P($G(^%ZOSF("OS")),"^"),TEXT(6,0)=" uci: "_Y,TEXT(7,0)=" user: "_$P($G(^VA(200,+DUZ,0)),"^")
D NOW^%DTC S Y=% D DD^%DT S TEXT(8,0)=" date@time: "_Y,TEXT(9,0)=" "
S XMDUZ=.5,XMY("G.IFCAP INSTALL@DOMAIN.EXT")="",XMTEXT="TEXT(",XMSUB=SUBJECT
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPXTRM 3400 printed Sep 23, 2025@19:53 Page 2
PRCPXTRM ;WISC/RFJ-user termination, add, build array, utilities ; 11/6/06 8:46am
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
TERMUSER(USERDUZ) ; remove user as inventory user from all inventory pts
+1 ; called internally (not by prcp options)
+2 ; 'Do' block modified by PRC*5.1*98 to add ODI cleanup
+3 IF '$DATA(^VA(200,+USERDUZ,0))
QUIT
+4 NEW INVPT
+5 SET INVPT=0
FOR
SET INVPT=$ORDER(^PRCP(445,INVPT))
if 'INVPT
QUIT
Begin DoDot:1
+6 IF $DATA(^PRCP(445,INVPT,4,USERDUZ))
DO KILLUSER(INVPT,USERDUZ)
+7 IF $DATA(^PRCP(445,INVPT,9,USERDUZ))
DO DEL^PRCPAODI(INVPT,USERDUZ)
End DoDot:1
+8 QUIT
+9 ;
+10 ;
KILLUSER(INVPT,USERDUZ) ; remove user (userduz) from invpt
+1 IF '$DATA(^PRCP(445,+INVPT,4,+USERDUZ))
QUIT
+2 NEW %,DA,DIC,DIK,X,Y
+3 SET DIK="^PRCP(445,"_+INVPT_",4,"
SET DA(1)=+INVPT
SET DA=+USERDUZ
DO ^DIK
+4 IF '$ORDER(^PRCP(445,INVPT,4,0))
DO NOUSER(INVPT)
+5 QUIT
+6 ;
+7 ;
NOUSER(INVPT) ; send mailmsg to g.irm if invpt has no users
+1 ; XMSUB,XMTEXT added with PRC*5.1*98
NEW INVNAME,PRCPTEXT,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
+2 SET XMDUZ=.5
SET XMY("G.IRM")=""
+3 SET INVNAME=$$INVNAME^PRCPUX1(INVPT)
+4 KILL PRCPTEXT
+5 SET PRCPTEXT(1,0)="TO: G.IRM"
+6 SET PRCPTEXT(2,0)="The inventory point "_INVNAME_" (#"_INVPT_") has NO authorized users"
+7 SET PRCPTEXT(3,0)="(field #6 in file #445)."
+8 SET PRCPTEXT(4,0)=" "
+9 SET PRCPTEXT(5,0)="You can use the following mumps call to add users:"
+10 SET PRCPTEXT(6,0)=" D ADDUSER^PRCPXTRM(INVPT,USERDUZ)"
+11 SET PRCPTEXT(7,0)=" where INVPT is the internal inventory point number;"
+12 SET PRCPTEXT(8,0)=" USERDUZ is the users DUZ."
+13 SET PRCPTEXT(9,0)=" "
+14 SET PRCPTEXT(10,0)="For example: D ADDUSER^PRCPXTRM("_INVPT_",100) would add user 100 to the"
+15 SET PRCPTEXT(11,0)=INVNAME_" (#"_INVPT_") inventory point listed above."
+16 SET PRCPTEXT(12,0)=" "
+17 SET PRCPTEXT(13,0)="Once an inventory user is added, the inventory point may be inactivated"
+18 SET PRCPTEXT(14,0)="if no longer used."
+19 SET XMSUB="INVENTORY POINT HAS NO AUTHORIZED USERS"
SET XMTEXT="PRCPTEXT("
DO ^XMD
+20 QUIT
+21 ;
+22 ;
ADDUSER(INVPT,USERDUZ) ; add authorized users to invpt
+1 IF '$DATA(^VA(200,+USERDUZ,0))
QUIT
+2 IF '$DATA(^PRCP(445,+INVPT,0))
QUIT
+3 IF $DATA(^PRCP(445,+INVPT,4,+USERDUZ,0))
QUIT
+4 ; DINUM added PRC*5.1*98
NEW %,D0,DA,DD,DIC,DINUM,DLAYGO,PRCPPRIV,X,Y
+5 IF '$DATA(^PRCP(445,+INVPT,4,0))
SET ^PRCP(445,+INVPT,4,0)="^445.04P^^"
+6 SET DIC="^PRCP(445,"_+INVPT_",4,"
SET DIC(0)="L"
SET DLAYGO=445
SET DA(1)=+INVPT
SET (X,DINUM)=+USERDUZ
SET PRCPPRIV=1
+7 DO FILE^DICN
+8 QUIT
+9 ;
+10 ;
GETUSER(INVPT) ; build prcpxmy array of users
+1 ; if user is manager, set prcpxmy(duz)=1 otherwise 0
+2 NEW %,X
+3 KILL PRCPXMY
+4 IF '$DATA(^PRCP(445,+INVPT,4))
QUIT
+5 SET %=$PIECE(^PRCP(445,INVPT,0),"^",3)
SET %="PRCP"_$TRANSLATE(%,"WSP","W2")_" MGRKEY"
+6 SET X=0
FOR
SET X=$ORDER(^PRCP(445,INVPT,4,X))
if 'X
QUIT
SET PRCPXMY(X)=$SELECT($$KEY^PRCPUREP(%,X):1,1:0)
+7 QUIT
+8 ;
+9 ;
INSTALL(SUBJECT,LINE2,TEXT) ; send install message to forum
+1 ; text = text to be included from line 10 and up
+2 NEW DIC,XCNP,XMDUZ,XMSUB,XMTEXT,XMZ
+3 SET TEXT(1,0)=" "
SET TEXT(2,0)="Installation of IFCAP "_LINE2_" information message:"
SET TEXT(3,0)=""
SET TEXT(4,0)=" site: "_$GET(^DD("SITE"))
+4 XECUTE ^%ZOSF("UCI")
SET TEXT(5,0)=" op sys: "_$PIECE($GET(^%ZOSF("OS")),"^")
SET TEXT(6,0)=" uci: "_Y
SET TEXT(7,0)=" user: "_$PIECE($GET(^VA(200,+DUZ,0)),"^")
+5 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TEXT(8,0)=" date@time: "_Y
SET TEXT(9,0)=" "
+6 SET XMDUZ=.5
SET XMY("G.IFCAP INSTALL@DOMAIN.EXT")=""
SET XMTEXT="TEXT("
SET XMSUB=SUBJECT
+7 DO ^XMD
+8 QUIT
