source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHUSER.m@ 1800

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

initial load of WorldVistAEHR

File size: 1.9 KB
RevLine 
[613]1PRCHUSER ;WISC/AKS-Add/Edit purchase card user ;9/12/00 22:52
2 ;;5.1;IFCAP;**8**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N DIC,DA,Y,DIE,DR,PRCF,%,PRCHORIG,PRCRI
5 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
6MORE S DIC="^PRC(440.5,",DIC(0)="AELQM",DLAYGO=440.5
7 S DIC("S")="I $D(PRC(""SITE"")),$P($G(^PRC(440.5,+Y,2)),""^"",3)=PRC(""SITE"")"
8 D ^DIC Q:Y'>0 S DA=+Y,PRCRI(440.5)=DA
9 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
10 S DIE="^PRC(440.5,",DR="[PRCH PURCHASE CARD]" D ^DIE ;Q:$D(Y)
11 D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"70////P;71////"_DT)
12 K PRCHHLDR,PRCHAPP,PRCHALT,PRCHSING,PRCHMNTH
13 I '$G(DA) G Q
14 S DA(1)=DA S PRCHUSER=$P(^PRC(440.5,DA,0),U,8)
15 I $G(PRCHUSER),$G(PRCHORIG),PRCHUSER'=PRCHORIG D
16 . S DIK="^PRC(440.5,"_DA(1)_",1,",DA=PRCHORIG D ^DIK K Y,DIK
17 I $G(PRCHUSER),'$D(^PRC(440.5,DA,1,PRCHUSER)) D
18 . I '$G(^PRC(440.5,DA(1),1,0)) D
19 . . S $P(^PRC(440.5,DA(1),1,0),U,2)=$P(^DD(440.5,12,0),U,2)
20 . S DIE="^PRC(440.5,"_DA(1)_",1,",DA=PRCHUSER,DR=".01////^S X=PRCHUSER"
21 . D ^DIE
22 . S $P(^PRC(440.5,DA(1),1,0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1
23 . K DIE,DR,PRCHUSER
24MORES S:'$D(DA(1)) DA(1)=DA S DIC="^PRC(440.5,"_DA(1)_",1,",DIC(0)="AELQ"
25 S DIC("S")="I +Y'=$P(^PRC(440.5,DA(1),0),U,8)" D ^DIC G Q:Y'>0 S DA=+Y
26 I $P(Y,U,3)'=1 D
27 . W !!?5,"Would you like to delete this surrogate user" S %=2 D YN^DICN
28 . Q:%<1!(%=2)
29 . S DA=+Y,DIK="^PRC(440.5,"_DA(1)_",1,"
30 . D ^DIK K Y,DIK
31 G MORES
32Q W !!?5,"Would you like to register another purchase card" S %=2 D YN^DICN
33 W ! G:%=1 MORE I %=0 W !!,"Please answer 'Yes' or 'No'"
34 K DLAYGO,DA
35 QUIT
36INPUT1 ;Input transform for File #440.5, Field #1
37 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
38 Q:'$D(X) S X=$P(Y(0),U)
39 Q
Note: See TracBrowser for help on using the repository browser.