40 lines
1.9 KiB
Mathematica
40 lines
1.9 KiB
Mathematica
PRCHUSER ;WISC/AKS-Add/Edit purchase card user ;9/12/00 22:52
|
|
;;5.1;IFCAP;**8**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
N DIC,DA,Y,DIE,DR,PRCF,%,PRCHORIG,PRCRI
|
|
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
|
|
MORE S DIC="^PRC(440.5,",DIC(0)="AELQM",DLAYGO=440.5
|
|
S DIC("S")="I $D(PRC(""SITE"")),$P($G(^PRC(440.5,+Y,2)),""^"",3)=PRC(""SITE"")"
|
|
D ^DIC Q:Y'>0 S DA=+Y,PRCRI(440.5)=DA
|
|
N SITECHK S SITECHK=$P($G(^PRC(440.5,DA,2)),U,3) I +SITECHK'=0,SITECHK'=PRC("SITE") W !!,"This card is not entered for this station." H 3 G MORE
|
|
S DIE="^PRC(440.5,",DR="[PRCH PURCHASE CARD]" D ^DIE ;Q:$D(Y)
|
|
D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"70////P;71////"_DT)
|
|
K PRCHHLDR,PRCHAPP,PRCHALT,PRCHSING,PRCHMNTH
|
|
I '$G(DA) G Q
|
|
S DA(1)=DA S PRCHUSER=$P(^PRC(440.5,DA,0),U,8)
|
|
I $G(PRCHUSER),$G(PRCHORIG),PRCHUSER'=PRCHORIG D
|
|
. S DIK="^PRC(440.5,"_DA(1)_",1,",DA=PRCHORIG D ^DIK K Y,DIK
|
|
I $G(PRCHUSER),'$D(^PRC(440.5,DA,1,PRCHUSER)) D
|
|
. I '$G(^PRC(440.5,DA(1),1,0)) D
|
|
. . S $P(^PRC(440.5,DA(1),1,0),U,2)=$P(^DD(440.5,12,0),U,2)
|
|
. S DIE="^PRC(440.5,"_DA(1)_",1,",DA=PRCHUSER,DR=".01////^S X=PRCHUSER"
|
|
. D ^DIE
|
|
. S $P(^PRC(440.5,DA(1),1,0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1
|
|
. K DIE,DR,PRCHUSER
|
|
MORES S:'$D(DA(1)) DA(1)=DA S DIC="^PRC(440.5,"_DA(1)_",1,",DIC(0)="AELQ"
|
|
S DIC("S")="I +Y'=$P(^PRC(440.5,DA(1),0),U,8)" D ^DIC G Q:Y'>0 S DA=+Y
|
|
I $P(Y,U,3)'=1 D
|
|
. W !!?5,"Would you like to delete this surrogate user" S %=2 D YN^DICN
|
|
. Q:%<1!(%=2)
|
|
. S DA=+Y,DIK="^PRC(440.5,"_DA(1)_",1,"
|
|
. D ^DIK K Y,DIK
|
|
G MORES
|
|
Q W !!?5,"Would you like to register another purchase card" S %=2 D YN^DICN
|
|
W ! G:%=1 MORE I %=0 W !!,"Please answer 'Yes' or 'No'"
|
|
K DLAYGO,DA
|
|
QUIT
|
|
INPUT1 ;Input transform for File #440.5, Field #1
|
|
S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ" S DIC("S")="I $D(^PRC(420,""C"",PRCHHLDR,PRC(""SITE""),+Y))",D="B^C" D MIX^DIC1 K:Y<0 X K DIC
|
|
Q:'$D(X) S X=$P(Y(0),U)
|
|
Q
|