PRCVRRA.m

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

HEADER ;

 ; 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 ---PRCVRRA   1421     printed  Apr 09, 2024@21:13:56                                                                                                                                                                                                     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 

HEADER    ;

 +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