source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVPOU.m@ 1141

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1PRCVPOU ;WOIFO/AS-SEND PO AMENDMENT TO DYNAMED ; 01/24/05
2 ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; PO amendment
6 ; Input: PRCHPO (PO number)
7 ; PRCHAM (amendment number)
8 ; Called from PRCHAM (Amendment to Purchase Order/Card)
9 ; PRCFFMOM (Amendment Processing)
10 ;
11 Q
12ENT(PRCHPO,PRCHAM) ;
13 N AMEND,PRCV,CHG,FLD,ITM,NPO,NXT,ALL,EXT,AMD,PRCVP,DIQ,DIC,DA,DR,DONE
14 S AMEND=0,DIQ="PRCVP",DIQ(0)="IE",DIC=442,DA=PRCHPO,DR=".07;7;62"
15 D EN^DIQ1
16 S EXT=PRCVP(442,PRCHPO,62,"E"),DONE=0
17 I EXT']"" S EXT=PRCVP(442,PRCHPO,.07,"E")
18 S $P(EXT,"^",2)=PRCVP(442,PRCHPO,7,"I") ; delivery date
19 F S AMEND=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND)) Q:AMEND'>0 D
20 . S NXT="E"_+AMEND
21 . I $T(@NXT)'="" D @NXT
22 Q
23E22 ;Line Item Delete
24 S FLD=0 K PRCV("DEL"),^TMP("PRCV442A",$J,PRCHPO)
25 F S FLD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD)) Q:FLD'>0 D
26 . S CHG=0
27 . F S CHG=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD,CHG)) Q:CHG'>0 D
28 .. S ITM=+$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
29 .. S PRCV("DEL",ITM)=""
30 .. ; only item with DM document ID will be passed back
31 .. D ITEM
32 .. ; Insert Amendment Type of "Line Item Delete"
33 .. S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=2
34 ; create header only if item exist
35 I $D(^TMP("PRCV442A",$J,PRCHPO)) D
36 . D HEADER
37 . ; If there is no Line Item Edit, send out this message
38 . I '$D(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23)) D SEND
39 Q
40E23 ;Line Item Edit
41 ; If delivery date changed, send all items, Quit
42 I PRCFA("DLVDATE")'=$P(EXT,"^",2) S ALL=1 D ALLITEM Q
43 ;
44 S FLD=0 K PRCV("EDT")
45 ; remove duplicated line item
46 F S FLD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD)) Q:'FLD D
47 . S CHG=0
48 . F S CHG=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD,CHG)) Q:'CHG D
49 .. S ITM=+$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
50 .. ; no transmission if item already deleted
51 .. S:'$D(PRCV("DEL",ITM)) PRCV("EDT",ITM)=""
52 ;
53 ; Process edited line items after duplicated lines removed
54 S ITM=0
55 F S ITM=$O(PRCV("EDT",ITM)) Q:'ITM D
56 . D ITEM
57 . ; Insert Amendment Type of "Line Item Edit"
58 . S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=1
59 ;
60 ; create header only if item exist
61 I $D(^TMP("PRCV442A",$J,PRCHPO)) D HEADER,SEND S DONE=1
62 Q
63E31 ; Change Vendor
64 ; Send new vendor only
65 ; New vendor already in 442
66 ; No need to find it elsewhere
67 S ALL=3
68 D ALLITEM S DONE=1
69 Q
70E32 ; Replace PO Number
71 ; Send new PO number information including DynaMed Doc ID
72 S NPO=$P($G(^PRC(442,PRCHPO,23)),"^",4)
73 Q:'NPO
74 S PRCHPO=NPO
75 S ALL=4
76 D ALLITEM
77 Q
78E34 ; Authority Edit
79 Q:DONE ; if Change Vendor and Line Edit already done.
80 ; If change to delivery date only without any other amendment
81 ; Authority Edit became No Charge Amendment
82 I $P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5,PRCFA("DLVDATE")'=$P(EXT,"^",2) D
83 . S ALL=1 D ALLITEM
84 ; Send PO Cancelled only
85 Q:$P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5
86 ; change amendment type to Cancel
87 S ALL=5
88 D ALLITEM
89 Q
90 ;
91HEADER ;
92 ; Get PO header information
93 D PO^PRCV442A(PRCHPO)
94 ; Change transaction type to PO Amendment
95 S $P(^TMP("PRCV442A",$J,PRCHPO),"^",2)=2
96 ; Amendment signed date
97 S $P(^TMP("PRCV442A",$J,PRCHPO),"^",7)=$P($G(^PRC(442,PRCHPO,6,PRCHAM,1)),"^",3)
98 Q
99ITEM ;
100 D ITEM^PRCV442A(PRCHPO,ITM,EXT)
101 Q
102ALLITEM ;
103 ; If header level amendment, send all items to DynaMed
104 ; 1. Collect all deleted item
105 K ^TMP("PRCV442A",$J,PRCHPO),PRCV("DEL")
106 S AMD=0 F S AMD=$O(^PRC(442,PRCHPO,6,AMD)) Q:'AMD D
107 . S FLD=0
108 . F S FLD=$O(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD)) Q:'FLD D
109 .. S CHG=0
110 .. F S CHG=$O(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD,CHG)) Q:'CHG D
111 ... S ITM=+$P($G(^PRC(442,PRCHPO,6,AMD,3,CHG,0)),"^",4)
112 ... S PRCV("DEL",ITM)=""
113 ; 2. pickup all items to DynaMed except deleted items
114 S ITM=0 F S ITM=$O(^PRC(442,PRCHPO,2,ITM)) Q:'ITM D
115 . I '$D(PRCV("DEL",ITM)) D ITEM
116 . S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=ALL
117 ; create header and send only if item exist
118 I $D(^TMP("PRCV442A",$J,PRCHPO)) D HEADER,SEND
119 Q
120SEND ;
121 ; Do not send if no item collected
122 Q:'$O(^TMP("PRCV442A",$J,PRCHPO,0))
123 M ^TMP("ASU442A",$J)=^TMP("PRCV442A",$J)
124 D EN^PRCVPOSD(PRCHPO)
125 Q
Note: See TracBrowser for help on using the repository browser.