Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCSUT41

PRCSUT41.m

Go to the documentation of this file.
  1. PRCSUT41 ;WISC/KMB/BGJ-UTILITY TO CREATE NEW DISTRIBUTION SCHEDULE ;7/6/89 13:17
  1. V ;;5.1;IFCAP;**5**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;PRCHSY=NEW 410 IRN,PRCHJ=NEW 410 ITEM MULTIPLE IRN
  1. ;PRCHS=OLD 410 IRN,PRCHX=OLD 410 ITEM MULTIPLE IRN
  1. 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)))
  1. 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
  1. K PRCSDS,PRCSDSD,PRCSI,PRCSJ,DLAYGO
  1. Q
  1. STF S X=PRCSDSD,$P(X,U)=$P(^PRCS(410,PRCHSY,0),U)_"-"_PRCHJ_"-"_PRCSI
  1. 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)
  1. S:'$D(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0)) ^(0)="^410.212I^^"
  1. 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)
  1. Q
  1. USEROUT ; remove user terminated by Kernel from IFCAP
  1. N CPT,ST,XDA,XDA1
  1. Q:'DA S (CPT,ST)=0,XDA=DA
  1. ;remove user from supply
  1. K ^VA(200,XDA,400)
  1. ; remove user from all cps
  1. I $D(^PRC(420,"C",XDA)) D
  1. .F S ST=$O(^PRC(420,"C",XDA,ST)) Q:'ST D
  1. ..S CPT=0 F S CPT=$O(^PRC(420,"C",XDA,ST,CPT)) Q:'CPT D
  1. ...S DA(2)=ST,DA(1)=CPT,DA=XDA,DIK="^PRC(420,"_DA(2)_",1,"_DA(1)_",1," D ^DIK K DIK
  1. ; put users on a 'don't use' array
  1. S ST=0 F S ST=$O(^PRC(420,"B",ST)) Q:ST="" D
  1. .S DA(1)=ST,DA=XDA,DIK="^PRC(411,"_DA(1)_",6," D ^DIK K DIK
  1. .Q:$D(^PRC(411,ST,8,XDA))
  1. .S:'$D(^PRC(411,ST,8,0)) ^(0)="^411.045PA^^"
  1. .L +^PRC(411,ST):15 Q:'$T
  1. .S DA(1)=ST,DIC="^PRC(411,"_DA(1)_",8,",(DA,X)=XDA,DIC(0)="X",DINUM=X D FILE^DICN
  1. .L -^PRC(411,ST)
  1. K DIC
  1. ;remove user from inventory system
  1. S X="PRCPXTRM" X ^%ZOSF("TEST") D:$T=1 TERMUSER^PRCPXTRM(DA)
  1. K DA Q
  1. USERIN ;restore terminated user to IFCAP
  1. N X,Y,YY,DIR,DIRUT,DUOUT,ENTRY,STA,OK
  1. S (ENTRY,STA,OK)=0 W !!
  1. S DIR(0)="P^200:EMZ",DIR("A")="Enter username",DIR("?")="Enter name in the format lastname,firstname"
  1. D ^DIR K DIR Q:$D(DIRUT) W !!,"You have selected ",$P(Y,"^",2) S YY=+Y
  1. ;
  1. 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
  1. ;
  1. F S STA=$O(^PRC(420,"B",STA)) Q:STA="" I $D(^PRC(411,STA,8,"B",YY,YY)) S ENTRY=YY D
  1. .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
  1. .S DIK="^PRC(411,"_DA(1)_",8," D ^DIK K DIK,DIR
  1. .W !,"This user was reinstated as an IFCAP user for station ",STA,"."
  1. .S OK=1
  1. .L -^PRC(411,STA,8)
  1. I ENTRY=0 W !,"This user was never terminated from IFCAP." G USERIN
  1. I 'OK G USERIN
  1. ;
  1. 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
  1. .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
  1. .D ^DIE K DIE
  1. .L -^VA(200,YY) W !?5,"To edit the Signature Block printed name or title, use TBOX"
  1. W !! G USERIN
  1. QUIT