source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCNV.m@ 846

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

initial load of WorldVistAEHR
File size: 2.8 KB
Line 
1PRCHCNV ; Covert purchase card orders to delivery orders and vice versa ;7/24/00 23:29
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 QUIT
6PCDO ;Convert a purchase card order to a delivery order
7 ;
8 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
9 N DIC,I,N,PRCHA,PRCHCARD,PRCHHLDR,PRCHNPO,PRCHDELV,PRCHPO,Y
10 S DIC="^PRC(442,",DIC(0)="AEQM"
11 S DIC("S")="I $P($G(^PRC(442,+Y,23)),U,11)=""P"",$P(^PRC(442,+Y,7),U,2)<9,$P(^PRC(442,+Y,1),U,10)=DUZ"
12 S DIC("A")="Select PURCHASE CARD ORDER NUMBER: "
13 D ^DIC Q:Y'>0 S PRCHOLD=+Y
14 S PRCHDELV=1 D ENPO^PRCHUTL Q:'$D(PRCHPO) S (DA,PRCHNEW)=PRCHPO
15 S PRCHNPO=$P(^PRC(442,PRCHNEW,0),U)
16 S %X="^PRC(442,PRCHOLD,",%Y="^PRC(442,PRCHNEW," D %XY^%RCR K %X,%Y
17 S DIE="^PRC(442,"
18 S DR=".01///^S X=PRCHNPO;48///^S X=""D"";.02///^S X=1;27///^S X=PRCHOLD"
19 D ^DIE K DIE,DA,DR
20 F I=8,15,16,17,20,21,22 S $P(^PRC(442,PRCHNEW,23),U,I)=""
21 S PRCHCARD=$P(^PRC(442,PRCHOLD,23),U,8),PRCHHLDR=$P(^(23),U,22)
22 K:$G(PRCHCARD) ^PRC(442,"M",PRCHCARD,PRCHOLD)
23 K:$G(PRCHHLDR) ^PRC(442,"MCH",PRCHHLDR_"~",PRCHOLD)
24 S DIE="^PRC(442,",DA=PRCHOLD
25 S DR=".5///^S X=45;28///^S X=PRCHNEW"
26 D ^DIE K DIE,DA,DR
27 S DA=PRCHOLD D C2237^PRCH442A
28 W !!,"This purchase card order has now been converted to a delivery order."
29 W !!,?5,"The Purchase Card Order No: "_$P($P(^PRC(442,PRCHOLD,0),U),"-",2)_" has been converted",!,?5,"to Delivery Order No: "_$P($P(^PRC(442,PRCHNEW,0),U),"-",2)
30 S PRCHA=""
31 S N=0 F S N=$O(^PRC(442,PRCHNEW,2,N)) Q:'N I $P($G(^(N,2)),U,2)="" S PRCHA=PRCHA_N_","
32 I PRCHA]"" D
33 . W !!,?5,"The following line items on the new delivery order",!,?5," do not have a contract number: ",!,?5,PRCHA,!
34 W !!,?5,"This delivery order must be edited."
35 K PRCF,PRCHOLD,PRCHNEW,PRCHDELV
36 N DIR S DIR(0)="E" W !!! D ^DIR
37 QUIT
38 ;
39DOPC ;Convert a delivery order to a purchase card order
40 ;
41 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
42 N DIC,PRCHNPO,PRCHPC,PRCHPO,Y
43 S DIC="^PRC(442,",DIC(0)="AEQM"
44 S DIC("S")="I $P($G(^(23)),U,11)=""D"",$P(^(7),U,2)<9"
45 S DIC("A")="Select DELIVERY ORDER NUMBER: "
46 D ^DIC Q:Y'>0 S PRCHOLD=+Y
47 S PRCHPC=2 D ENPO^PRCHUTL Q:'$D(PRCHPO) S (DA,PRCHNEW)=PRCHPO
48 S PRCHNPO=$P(^PRC(442,PRCHNEW,0),U)
49 S %X="^PRC(442,PRCHOLD,",%Y="^PRC(442,PRCHNEW," D %XY^%RCR
50 S DIE="^PRC(442,",DR=".01///^S X=PRCHNPO;48///^S X=""P"";.02///^S X=25;27///^S X=PRCHOLD;.04///^S X=""@"""
51 D ^DIE K DIE,DA,DR
52 K ^PRC(442,PRCHNEW,5)
53 S DIE="^PRC(442,",DA=PRCHOLD,DR=".5///^S X=45;28///^S X=PRCHNEW"
54 D ^DIE K DIE,DA,DR
55 S DA=PRCHOLD D C2237^PRCH442A
56 W !!,"This delivery order is now converted to a purchase card order"
57 W !!,?5,"The Deliver Order No: "_$P($P(^PRC(442,PRCHOLD,0),U),"-",2)_" has been converted",!,?5,"to Purchase Card Order No: "_$P($P(^PRC(442,PRCHNEW,0),U),"-",2)
58 W !!,?5,"This purchase card order must be edited."
59 K PRCF,PRCHOLD,PRCHNEW
60 N DIR S DIR(0)="E" W !!! D ^DIR
61 QUIT
Note: See TracBrowser for help on using the repository browser.