PRCVRRA ;WOIFO/AS-SEND RECEIVING REPORT ADJUSTMENT TO DYNAMED ; 01/24/05
;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; PO amendment
; Input: PRCVPO (PO number)
; PRCVADJ (Adjustment number from PRCHAV)
; Called from PRCHAM
;
Q
ENT(PRCVPO,PRCVADJ) ;
N PRCV1,PRCV,PRCVCHG,PRCVFLD,PRCVNPO,PRCVAMD,PRCVNXT,PRCVALL,PRCVEXT
N PRCVP,PRCVERR
; Get partial header information to PRCVEXT
S PRCV1=0
D GETS^DIQ(442,PRCVPO_",",".07;7;62","IE","PRCVP")
S PRCVEXT=PRCVP(442,PRCVPO_",",62,"E")
I PRCVEXT']"" S PRCVEXT=PRCVP(442,PRCVPO_",",.07,"E")
S $P(PRCVEXT,"^",2)=PRCVP(442,PRCVPO_",",7,"I") ; delivery date
;
D HEADER
F S PRCV1=$O(^PRC(442,PRCVPO,2,PRCV1)) Q:'PRCV1 D
. Q:'$D(^PRC(442,PRCVPO,2,PRCV1,3,PRCVADJ,0))
. D ITEM^PRCV442A(PRCVPO,PRCV1,PRCVEXT,.PRCVERR)
. I 'PRCVERR D
.. D RR^PRCV442A(PRCVPO,PRCV1,PRCVADJ,.PRCVERR,1)
.. I $D(^TMP("PRCV442A",$J,PRCVPO,PRCV1)) S $P(^(PRCV1),"^",14)=1
D SEND
K ^TMP("PRCV442A",$J)
Q
; Get PO header information
D PO^PRCV442A(PRCVPO)
; Change transaction type to RR Adjustment
S $P(^TMP("PRCV442A",$J,PRCVPO),"^",2)=4
Q
SEND ;
; Do not send if no item collected
Q:'$O(^TMP("PRCV442A",$J,PRCVPO,0))
; Adjustment signed date
S $P(^TMP("PRCV442A",$J,PRCVPO),"^",7)=$P($G(^PRC(442,PRCVPO,6,PRCHAM,1)),"^",3)
D EN^PRCVPOSD(PRCVPO)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVRRA 1421 printed Dec 13, 2024@02:20:18 Page 2
PRCVRRA ;WOIFO/AS-SEND RECEIVING REPORT ADJUSTMENT TO DYNAMED ; 01/24/05
+1 ;;5.1;IFCAP;**81**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; PO amendment
+5 ; Input: PRCVPO (PO number)
+6 ; PRCVADJ (Adjustment number from PRCHAV)
+7 ; Called from PRCHAM
+8 ;
+9 QUIT
ENT(PRCVPO,PRCVADJ) ;
+1 NEW PRCV1,PRCV,PRCVCHG,PRCVFLD,PRCVNPO,PRCVAMD,PRCVNXT,PRCVALL,PRCVEXT
+2 NEW PRCVP,PRCVERR
+3 ; Get partial header information to PRCVEXT
+4 SET PRCV1=0
+5 DO GETS^DIQ(442,PRCVPO_",",".07;7;62","IE","PRCVP")
+6 SET PRCVEXT=PRCVP(442,PRCVPO_",",62,"E")
+7 IF PRCVEXT']""
SET PRCVEXT=PRCVP(442,PRCVPO_",",.07,"E")
+8 ; delivery date
SET $PIECE(PRCVEXT,"^",2)=PRCVP(442,PRCVPO_",",7,"I")
+9 ;
+10 DO HEADER
+11 FOR
SET PRCV1=$ORDER(^PRC(442,PRCVPO,2,PRCV1))
if 'PRCV1
QUIT
Begin DoDot:1
+12 if '$DATA(^PRC(442,PRCVPO,2,PRCV1,3,PRCVADJ,0))
QUIT
+13 DO ITEM^PRCV442A(PRCVPO,PRCV1,PRCVEXT,.PRCVERR)
+14 IF 'PRCVERR
Begin DoDot:2
+15 DO RR^PRCV442A(PRCVPO,PRCV1,PRCVADJ,.PRCVERR,1)
+16 IF $DATA(^TMP("PRCV442A",$JOB,PRCVPO,PRCV1))
SET $PIECE(^(PRCV1),"^",14)=1
End DoDot:2
End DoDot:1
+17 DO SEND
+18 KILL ^TMP("PRCV442A",$JOB)
+19 QUIT
+1 ; Get PO header information
+2 DO PO^PRCV442A(PRCVPO)
+3 ; Change transaction type to RR Adjustment
+4 SET $PIECE(^TMP("PRCV442A",$JOB,PRCVPO),"^",2)=4
+5 QUIT
SEND ;
+1 ; Do not send if no item collected
+2 if '$ORDER(^TMP("PRCV442A",$JOB,PRCVPO,0))
QUIT
+3 ; Adjustment signed date
+4 SET $PIECE(^TMP("PRCV442A",$JOB,PRCVPO),"^",7)=$PIECE($GET(^PRC(442,PRCVPO,6,PRCHAM,1)),"^",3)
+5 DO EN^PRCVPOSD(PRCVPO)
+6 QUIT
