source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRRA.m@ 1710

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

initial load of WorldVistAEHR

File size: 1.3 KB
RevLine 
[613]1PRCVRRA ;WOIFO/AS-SEND RECEIVING REPORT ADJUSTMENT 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: PRCVPO (PO number)
7 ; PRCVADJ (Adjustment number from PRCHAV)
8 ; Called from PRCHAM
9 ;
10 Q
11ENT(PRCVPO,PRCVADJ) ;
12 N PRCV1,PRCV,PRCVCHG,PRCVFLD,PRCVNPO,PRCVAMD,PRCVNXT,PRCVALL,PRCVEXT
13 N PRCVP,PRCVERR
14 ; Get partial header information to PRCVEXT
15 S PRCV1=0
16 D GETS^DIQ(442,PRCVPO_",",".07;7;62","IE","PRCVP")
17 S PRCVEXT=PRCVP(442,PRCVPO_",",62,"E")
18 I PRCVEXT']"" S PRCVEXT=PRCVP(442,PRCVPO_",",.07,"E")
19 S $P(PRCVEXT,"^",2)=PRCVP(442,PRCVPO_",",7,"I") ; delivery date
20 ;
21 D HEADER
22 F S PRCV1=$O(^PRC(442,PRCVPO,2,PRCV1)) Q:'PRCV1 D
23 . Q:'$D(^PRC(442,PRCVPO,2,PRCV1,3,PRCVADJ,0))
24 . D ITEM^PRCV442A(PRCVPO,PRCV1,PRCVEXT,.PRCVERR)
25 . I 'PRCVERR D
26 .. D RR^PRCV442A(PRCVPO,PRCV1,PRCVADJ,.PRCVERR,1)
27 .. I $D(^TMP("PRCV442A",$J,PRCVPO,PRCV1)) S $P(^(PRCV1),"^",14)=1
28 D SEND
29 K ^TMP("PRCV442A",$J)
30 Q
31HEADER ;
32 ; Get PO header information
33 D PO^PRCV442A(PRCVPO)
34 ; Change transaction type to RR Adjustment
35 S $P(^TMP("PRCV442A",$J,PRCVPO),"^",2)=4
36 Q
37SEND ;
38 ; Do not send if no item collected
39 Q:'$O(^TMP("PRCV442A",$J,PRCVPO,0))
40 ; Adjustment signed date
41 S $P(^TMP("PRCV442A",$J,PRCVPO),"^",7)=$P($G(^PRC(442,PRCVPO,6,PRCHAM,1)),"^",3)
42 D EN^PRCVPOSD(PRCVPO)
43 Q
Note: See TracBrowser for help on using the repository browser.