source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSUT41.m@ 1322

Last change on this file since 1322 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 3.2 KB
RevLine 
[613]1PRCSUT41 ;WISC/KMB/BGJ-UTILITY TO CREATE NEW DISTRIBUTION SCHEDULE ;7/6/89 13:17
2V ;;5.1;IFCAP;**5**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;PRCHSY=NEW 410 IRN,PRCHJ=NEW 410 ITEM MULTIPLE IRN
5 ;PRCHS=OLD 410 IRN,PRCHX=OLD 410 ITEM MULTIPLE IRN
6 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)))
7 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
8 K PRCSDS,PRCSDSD,PRCSI,PRCSJ,DLAYGO
9 Q
10STF S X=PRCSDSD,$P(X,U)=$P(^PRCS(410,PRCHSY,0),U)_"-"_PRCHJ_"-"_PRCSI
11 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)
12 S:'$D(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0)) ^(0)="^410.212I^^"
13 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)
14 Q
15USEROUT ; remove user terminated by Kernel from IFCAP
16 N CPT,ST,XDA,XDA1
17 Q:'DA S (CPT,ST)=0,XDA=DA
18 ;remove user from supply
19 K ^VA(200,XDA,400)
20 ; remove user from all cps
21 I $D(^PRC(420,"C",XDA)) D
22 .F S ST=$O(^PRC(420,"C",XDA,ST)) Q:'ST D
23 ..S CPT=0 F S CPT=$O(^PRC(420,"C",XDA,ST,CPT)) Q:'CPT D
24 ...S DA(2)=ST,DA(1)=CPT,DA=XDA,DIK="^PRC(420,"_DA(2)_",1,"_DA(1)_",1," D ^DIK K DIK
25 ; put users on a 'don't use' array
26 S ST=0 F S ST=$O(^PRC(420,"B",ST)) Q:ST="" D
27 .S DA(1)=ST,DA=XDA,DIK="^PRC(411,"_DA(1)_",6," D ^DIK K DIK
28 .Q:$D(^PRC(411,ST,8,XDA))
29 .S:'$D(^PRC(411,ST,8,0)) ^(0)="^411.045PA^^"
30 .L +^PRC(411,ST):15 Q:'$T
31 .S DA(1)=ST,DIC="^PRC(411,"_DA(1)_",8,",(DA,X)=XDA,DIC(0)="X",DINUM=X D FILE^DICN
32 .L -^PRC(411,ST)
33 K DIC
34 ;remove user from inventory system
35 S X="PRCPXTRM" X ^%ZOSF("TEST") D:$T=1 TERMUSER^PRCPXTRM(DA)
36 K DA Q
37USERIN ;restore terminated user to IFCAP
38 N X,Y,YY,DIR,DIRUT,DUOUT,ENTRY,STA,OK
39 S (ENTRY,STA,OK)=0 W !!
40 S DIR(0)="P^200:EMZ",DIR("A")="Enter username",DIR("?")="Enter name in the format lastname,firstname"
41 D ^DIR K DIR Q:$D(DIRUT) W !!,"You have selected ",$P(Y,"^",2) S YY=+Y
42 ;
43 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
44 ;
45 F S STA=$O(^PRC(420,"B",STA)) Q:STA="" I $D(^PRC(411,STA,8,"B",YY,YY)) S ENTRY=YY D
46 .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
47 .S DIK="^PRC(411,"_DA(1)_",8," D ^DIK K DIK,DIR
48 .W !,"This user was reinstated as an IFCAP user for station ",STA,"."
49 .S OK=1
50 .L -^PRC(411,STA,8)
51 I ENTRY=0 W !,"This user was never terminated from IFCAP." G USERIN
52 I 'OK G USERIN
53 ;
54 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
55 .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
56 .D ^DIE K DIE
57 .L -^VA(200,YY) W !?5,"To edit the Signature Block printed name or title, use TBOX"
58 W !! G USERIN
59 QUIT
Note: See TracBrowser for help on using the repository browser.