PRCSUT41 ;WISC/KMB/BGJ-UTILITY TO CREATE NEW DISTRIBUTION SCHEDULE ;7/6/89 13:17
V ;;5.1;IFCAP;**5**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;PRCHSY=NEW 410 IRN,PRCHJ=NEW 410 ITEM MULTIPLE IRN
;PRCHS=OLD 410 IRN,PRCHX=OLD 410 ITEM MULTIPLE IRN
Q:'$D(PRCHSY)!('$D(PRCHS)) Q:'$D(PRCHJ)!('$D(PRCHX)) Q:'$D(^PRCS(410,PRCHSY,0))!('$D(^PRCS(410,PRCHS,0))) Q:'$D(^PRCS(410,PRCHSY,"IT",PRCHJ,0))!('$D(^PRCS(410,PRCHS,"IT",PRCHX,0)))
S PRCSI=0 F PRCSJ=1:1 S PRCSI=$O(^PRCS(410,PRCHS,"IT",PRCHX,2,PRCSI)) Q:PRCSI'>0 S PRCSDS=^(PRCSI,0) Q:$P(PRCSDS,U,2)'>0 Q:'$D(^PRCS(410.6,+$P(PRCSDS,U,2),0)) S PRCSDSD=^(0) D STF
K PRCSDS,PRCSDSD,PRCSI,PRCSJ,DLAYGO
Q
STF S X=PRCSDSD,$P(X,U)=$P(^PRCS(410,PRCHSY,0),U)_"-"_PRCHJ_"-"_PRCSI
S DLAYGO=410.6,DIC="^PRCS(410.6,",DIC(0)="LOXZ" D FILE^DICN K DIC Q:Y<0 S $P(^PRCS(410.6,+Y,0),U,2,7)=$P(PRCSDSD,U,2,7)
S:'$D(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0)) ^(0)="^410.212I^^"
S ^PRCS(410,PRCHSY,"IT",PRCHJ,2,PRCSI,0)=PRCSI_U_(+Y),^PRCS(410,PRCHSY,"IT",PRCHJ,2,"B",PRCSI,PRCSI)="" S $P(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,3,4)=PRCSI_U_($P(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,4)+1)
Q
USEROUT ; remove user terminated by Kernel from IFCAP
N CPT,ST,XDA,XDA1
Q:'DA S (CPT,ST)=0,XDA=DA
;remove user from supply
K ^VA(200,XDA,400)
; remove user from all cps
I $D(^PRC(420,"C",XDA)) D
.F S ST=$O(^PRC(420,"C",XDA,ST)) Q:'ST D
..S CPT=0 F S CPT=$O(^PRC(420,"C",XDA,ST,CPT)) Q:'CPT D
...S DA(2)=ST,DA(1)=CPT,DA=XDA,DIK="^PRC(420,"_DA(2)_",1,"_DA(1)_",1," D ^DIK K DIK
; put users on a 'don't use' array
S ST=0 F S ST=$O(^PRC(420,"B",ST)) Q:ST="" D
.S DA(1)=ST,DA=XDA,DIK="^PRC(411,"_DA(1)_",6," D ^DIK K DIK
.Q:$D(^PRC(411,ST,8,XDA))
.S:'$D(^PRC(411,ST,8,0)) ^(0)="^411.045PA^^"
.L +^PRC(411,ST):15 Q:'$T
.S DA(1)=ST,DIC="^PRC(411,"_DA(1)_",8,",(DA,X)=XDA,DIC(0)="X",DINUM=X D FILE^DICN
.L -^PRC(411,ST)
K DIC
;remove user from inventory system
S X="PRCPXTRM" X ^%ZOSF("TEST") D:$T=1 TERMUSER^PRCPXTRM(DA)
K DA Q
USERIN ;restore terminated user to IFCAP
N X,Y,YY,DIR,DIRUT,DUOUT,ENTRY,STA,OK
S (ENTRY,STA,OK)=0 W !!
S DIR(0)="P^200:EMZ",DIR("A")="Enter username",DIR("?")="Enter name in the format lastname,firstname"
D ^DIR K DIR Q:$D(DIRUT) W !!,"You have selected ",$P(Y,"^",2) S YY=+Y
;
S DIR("A")="Do you wish to reinstate this user",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR Q:$D(DIRUT) I Y=0 W !,"No action taken." G USERIN
;
F S STA=$O(^PRC(420,"B",STA)) Q:STA="" I $D(^PRC(411,STA,8,"B",YY,YY)) S ENTRY=YY D
.S DA(1)=STA,DA=ENTRY L +^PRC(411,STA,8):3 E W $C(7),!,"User is being edited by someone else and was not reinstated as an IFCAP user for station ",STA,"." Q
.S DIK="^PRC(411,"_DA(1)_",8," D ^DIK K DIK,DIR
.W !,"This user was reinstated as an IFCAP user for station ",STA,"."
.S OK=1
.L -^PRC(411,STA,8)
I ENTRY=0 W !,"This user was never terminated from IFCAP." G USERIN
I 'OK G USERIN
;
S DIR("A")="Is this user an A&MM employee",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR Q:$D(DIRUT) I Y=1 D
.S DIE="^VA(200,",DR="400;.135",DA=YY L +^VA(200,DA):3 E W $C(7),!,"User is being edited by someone else and was not added as an A&MM employee." Q
.D ^DIE K DIE
.L -^VA(200,YY) W !?5,"To edit the Signature Block printed name or title, use TBOX"
W !! G USERIN
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSUT41 3347 printed Oct 16, 2024@18:19:56 Page 2
PRCSUT41 ;WISC/KMB/BGJ-UTILITY TO CREATE NEW DISTRIBUTION SCHEDULE ;7/6/89 13:17
V ;;5.1;IFCAP;**5**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;PRCHSY=NEW 410 IRN,PRCHJ=NEW 410 ITEM MULTIPLE IRN
+3 ;PRCHS=OLD 410 IRN,PRCHX=OLD 410 ITEM MULTIPLE IRN
+4 if '$DATA(PRCHSY)!('$DATA(PRCHS))
QUIT
if '$DATA(PRCHJ)!('$DATA(PRCHX))
QUIT
if '$DATA(^PRCS(410,PRCHSY,0))!('$DATA(^PRCS(410,PRCHS,0)))
QUIT
if '$DATA(^PRCS(410,PRCHSY,"IT",PRCHJ,0))!('$DATA(^PRCS(410,PRCHS,"IT",PRCHX,0)))
QUIT
+5 SET PRCSI=0
FOR PRCSJ=1:1
SET PRCSI=$ORDER(^PRCS(410,PRCHS,"IT",PRCHX,2,PRCSI))
if PRCSI'>0
QUIT
SET PRCSDS=^(PRCSI,0)
if $PIECE(PRCSDS,U,2)'>0
QUIT
if '$DATA(^PRCS(410.6,+$PIECE(PRCSDS,U,2),0))
QUIT
SET PRCSDSD=^(0)
DO STF
+6 KILL PRCSDS,PRCSDSD,PRCSI,PRCSJ,DLAYGO
+7 QUIT
STF SET X=PRCSDSD
SET $PIECE(X,U)=$PIECE(^PRCS(410,PRCHSY,0),U)_"-"_PRCHJ_"-"_PRCSI
+1 SET DLAYGO=410.6
SET DIC="^PRCS(410.6,"
SET DIC(0)="LOXZ"
DO FILE^DICN
KILL DIC
if Y<0
QUIT
SET $PIECE(^PRCS(410.6,+Y,0),U,2,7)=$PIECE(PRCSDSD,U,2,7)
+2 if '$DATA(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0))
SET ^(0)="^410.212I^^"
+3 SET ^PRCS(410,PRCHSY,"IT",PRCHJ,2,PRCSI,0)=PRCSI_U_(+Y)
SET ^PRCS(410,PRCHSY,"IT",PRCHJ,2,"B",PRCSI,PRCSI)=""
SET $PIECE(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,3,4)=PRCSI_U_($PIECE(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,4)+1)
+4 QUIT
USEROUT ; remove user terminated by Kernel from IFCAP
+1 NEW CPT,ST,XDA,XDA1
+2 if 'DA
QUIT
SET (CPT,ST)=0
SET XDA=DA
+3 ;remove user from supply
+4 KILL ^VA(200,XDA,400)
+5 ; remove user from all cps
+6 IF $DATA(^PRC(420,"C",XDA))
Begin DoDot:1
+7 FOR
SET ST=$ORDER(^PRC(420,"C",XDA,ST))
if 'ST
QUIT
Begin DoDot:2
+8 SET CPT=0
FOR
SET CPT=$ORDER(^PRC(420,"C",XDA,ST,CPT))
if 'CPT
QUIT
Begin DoDot:3
+9 SET DA(2)=ST
SET DA(1)=CPT
SET DA=XDA
SET DIK="^PRC(420,"_DA(2)_",1,"_DA(1)_",1,"
DO ^DIK
KILL DIK
End DoDot:3
End DoDot:2
End DoDot:1
+10 ; put users on a 'don't use' array
+11 SET ST=0
FOR
SET ST=$ORDER(^PRC(420,"B",ST))
if ST=""
QUIT
Begin DoDot:1
+12 SET DA(1)=ST
SET DA=XDA
SET DIK="^PRC(411,"_DA(1)_",6,"
DO ^DIK
KILL DIK
+13 if $DATA(^PRC(411,ST,8,XDA))
QUIT
+14 if '$DATA(^PRC(411,ST,8,0))
SET ^(0)="^411.045PA^^"
+15 LOCK +^PRC(411,ST):15
if '$TEST
QUIT
+16 SET DA(1)=ST
SET DIC="^PRC(411,"_DA(1)_",8,"
SET (DA,X)=XDA
SET DIC(0)="X"
SET DINUM=X
DO FILE^DICN
+17 LOCK -^PRC(411,ST)
End DoDot:1
+18 KILL DIC
+19 ;remove user from inventory system
+20 SET X="PRCPXTRM"
XECUTE ^%ZOSF("TEST")
if $TEST=1
DO TERMUSER^PRCPXTRM(DA)
+21 KILL DA
QUIT
USERIN ;restore terminated user to IFCAP
+1 NEW X,Y,YY,DIR,DIRUT,DUOUT,ENTRY,STA,OK
+2 SET (ENTRY,STA,OK)=0
WRITE !!
+3 SET DIR(0)="P^200:EMZ"
SET DIR("A")="Enter username"
SET DIR("?")="Enter name in the format lastname,firstname"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
WRITE !!,"You have selected ",$PIECE(Y,"^",2)
SET YY=+Y
+5 ;
+6 SET DIR("A")="Do you wish to reinstate this user"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
IF Y=0
WRITE !,"No action taken."
GOTO USERIN
+7 ;
+8 FOR
SET STA=$ORDER(^PRC(420,"B",STA))
if STA=""
QUIT
IF $DATA(^PRC(411,STA,8,"B",YY,YY))
SET ENTRY=YY
Begin DoDot:1
+9 SET DA(1)=STA
SET DA=ENTRY
LOCK +^PRC(411,STA,8):3
IF '$TEST
WRITE $CHAR(7),!,"User is being edited by someone else and was not reinstated as an IFCAP user for station ",STA,"."
QUIT
+10 SET DIK="^PRC(411,"_DA(1)_",8,"
DO ^DIK
KILL DIK,DIR
+11 WRITE !,"This user was reinstated as an IFCAP user for station ",STA,"."
+12 SET OK=1
+13 LOCK -^PRC(411,STA,8)
End DoDot:1
+14 IF ENTRY=0
WRITE !,"This user was never terminated from IFCAP."
GOTO USERIN
+15 IF 'OK
GOTO USERIN
+16 ;
+17 SET DIR("A")="Is this user an A&MM employee"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
IF Y=1
Begin DoDot:1
+18 SET DIE="^VA(200,"
SET DR="400;.135"
SET DA=YY
LOCK +^VA(200,DA):3
IF '$TEST
WRITE $CHAR(7),!,"User is being edited by someone else and was not added as an A&MM employee."
QUIT
+19 DO ^DIE
KILL DIE
+20 LOCK -^VA(200,YY)
WRITE !?5,"To edit the Signature Block printed name or title, use TBOX"
End DoDot:1
+21 WRITE !!
GOTO USERIN
+22 QUIT
