PRCVPOU ;WOIFO/AS-SEND PO AMENDMENT 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: PRCHPO (PO number)
; PRCHAM (amendment number)
; Called from PRCHAM (Amendment to Purchase Order/Card)
; PRCFFMOM (Amendment Processing)
;
Q
ENT(PRCHPO,PRCHAM) ;
N AMEND,PRCV,CHG,FLD,ITM,NPO,NXT,ALL,EXT,AMD,PRCVP,DIQ,DIC,DA,DR,DONE
S AMEND=0,DIQ="PRCVP",DIQ(0)="IE",DIC=442,DA=PRCHPO,DR=".07;7;62"
D EN^DIQ1
S EXT=PRCVP(442,PRCHPO,62,"E"),DONE=0
I EXT']"" S EXT=PRCVP(442,PRCHPO,.07,"E")
S $P(EXT,"^",2)=PRCVP(442,PRCHPO,7,"I") ; delivery date
F S AMEND=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND)) Q:AMEND'>0 D
. S NXT="E"_+AMEND
. I $T(@NXT)'="" D @NXT
Q
E22 ;Line Item Delete
S FLD=0 K PRCV("DEL"),^TMP("PRCV442A",$J,PRCHPO)
F S FLD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD)) Q:FLD'>0 D
. S CHG=0
. F S CHG=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD,CHG)) Q:CHG'>0 D
.. S ITM=+$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
.. S PRCV("DEL",ITM)=""
.. ; only item with DM document ID will be passed back
.. D ITEM
.. ; Insert Amendment Type of "Line Item Delete"
.. S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=2
; create header only if item exist
I $D(^TMP("PRCV442A",$J,PRCHPO)) D
. D HEADER
. ; If there is no Line Item Edit, send out this message
. I '$D(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23)) D SEND
Q
E23 ;Line Item Edit
; If delivery date changed, send all items, Quit
I PRCFA("DLVDATE")'=$P(EXT,"^",2) S ALL=1 D ALLITEM Q
;
S FLD=0 K PRCV("EDT")
; remove duplicated line item
F S FLD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD)) Q:'FLD D
. S CHG=0
. F S CHG=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD,CHG)) Q:'CHG D
.. S ITM=+$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
.. ; no transmission if item already deleted
.. S:'$D(PRCV("DEL",ITM)) PRCV("EDT",ITM)=""
;
; Process edited line items after duplicated lines removed
S ITM=0
F S ITM=$O(PRCV("EDT",ITM)) Q:'ITM D
. D ITEM
. ; Insert Amendment Type of "Line Item Edit"
. S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=1
;
; create header only if item exist
I $D(^TMP("PRCV442A",$J,PRCHPO)) D HEADER,SEND S DONE=1
Q
E31 ; Change Vendor
; Send new vendor only
; New vendor already in 442
; No need to find it elsewhere
S ALL=3
D ALLITEM S DONE=1
Q
E32 ; Replace PO Number
; Send new PO number information including DynaMed Doc ID
S NPO=$P($G(^PRC(442,PRCHPO,23)),"^",4)
Q:'NPO
S PRCHPO=NPO
S ALL=4
D ALLITEM
Q
E34 ; Authority Edit
Q:DONE ; if Change Vendor and Line Edit already done.
; If change to delivery date only without any other amendment
; Authority Edit became No Charge Amendment
I $P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5,PRCFA("DLVDATE")'=$P(EXT,"^",2) D
. S ALL=1 D ALLITEM
; Send PO Cancelled only
Q:$P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5
; change amendment type to Cancel
S ALL=5
D ALLITEM
Q
;
; Get PO header information
D PO^PRCV442A(PRCHPO)
; Change transaction type to PO Amendment
S $P(^TMP("PRCV442A",$J,PRCHPO),"^",2)=2
; Amendment signed date
S $P(^TMP("PRCV442A",$J,PRCHPO),"^",7)=$P($G(^PRC(442,PRCHPO,6,PRCHAM,1)),"^",3)
Q
ITEM ;
D ITEM^PRCV442A(PRCHPO,ITM,EXT)
Q
ALLITEM ;
; If header level amendment, send all items to DynaMed
; 1. Collect all deleted item
K ^TMP("PRCV442A",$J,PRCHPO),PRCV("DEL")
S AMD=0 F S AMD=$O(^PRC(442,PRCHPO,6,AMD)) Q:'AMD D
. S FLD=0
. F S FLD=$O(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD)) Q:'FLD D
.. S CHG=0
.. F S CHG=$O(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD,CHG)) Q:'CHG D
... S ITM=+$P($G(^PRC(442,PRCHPO,6,AMD,3,CHG,0)),"^",4)
... S PRCV("DEL",ITM)=""
; 2. pickup all items to DynaMed except deleted items
S ITM=0 F S ITM=$O(^PRC(442,PRCHPO,2,ITM)) Q:'ITM D
. I '$D(PRCV("DEL",ITM)) D ITEM
. S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=ALL
; create header and send only if item exist
I $D(^TMP("PRCV442A",$J,PRCHPO)) D HEADER,SEND
Q
SEND ;
; Do not send if no item collected
Q:'$O(^TMP("PRCV442A",$J,PRCHPO,0))
M ^TMP("ASU442A",$J)=^TMP("PRCV442A",$J)
D EN^PRCVPOSD(PRCHPO)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVPOU 4363 printed Oct 16, 2024@18:20:54 Page 2
PRCVPOU ;WOIFO/AS-SEND PO AMENDMENT 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: PRCHPO (PO number)
+6 ; PRCHAM (amendment number)
+7 ; Called from PRCHAM (Amendment to Purchase Order/Card)
+8 ; PRCFFMOM (Amendment Processing)
+9 ;
+10 QUIT
ENT(PRCHPO,PRCHAM) ;
+1 NEW AMEND,PRCV,CHG,FLD,ITM,NPO,NXT,ALL,EXT,AMD,PRCVP,DIQ,DIC,DA,DR,DONE
+2 SET AMEND=0
SET DIQ="PRCVP"
SET DIQ(0)="IE"
SET DIC=442
SET DA=PRCHPO
SET DR=".07;7;62"
+3 DO EN^DIQ1
+4 SET EXT=PRCVP(442,PRCHPO,62,"E")
SET DONE=0
+5 IF EXT']""
SET EXT=PRCVP(442,PRCHPO,.07,"E")
+6 ; delivery date
SET $PIECE(EXT,"^",2)=PRCVP(442,PRCHPO,7,"I")
+7 FOR
SET AMEND=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND))
if AMEND'>0
QUIT
Begin DoDot:1
+8 SET NXT="E"_+AMEND
+9 IF $TEXT(@NXT)'=""
DO @NXT
End DoDot:1
+10 QUIT
E22 ;Line Item Delete
+1 SET FLD=0
KILL PRCV("DEL"),^TMP("PRCV442A",$JOB,PRCHPO)
+2 FOR
SET FLD=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD))
if FLD'>0
QUIT
Begin DoDot:1
+3 SET CHG=0
+4 FOR
SET CHG=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD,CHG))
if CHG'>0
QUIT
Begin DoDot:2
+5 SET ITM=+$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
+6 SET PRCV("DEL",ITM)=""
+7 ; only item with DM document ID will be passed back
+8 DO ITEM
+9 ; Insert Amendment Type of "Line Item Delete"
+10 if $DATA(^TMP("PRCV442A",$JOB,PRCHPO,ITM))
SET $PIECE(^(ITM),"^",14)=2
End DoDot:2
End DoDot:1
+11 ; create header only if item exist
+12 IF $DATA(^TMP("PRCV442A",$JOB,PRCHPO))
Begin DoDot:1
+13 DO HEADER
+14 ; If there is no Line Item Edit, send out this message
+15 IF '$DATA(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23))
DO SEND
End DoDot:1
+16 QUIT
E23 ;Line Item Edit
+1 ; If delivery date changed, send all items, Quit
+2 IF PRCFA("DLVDATE")'=$PIECE(EXT,"^",2)
SET ALL=1
DO ALLITEM
QUIT
+3 ;
+4 SET FLD=0
KILL PRCV("EDT")
+5 ; remove duplicated line item
+6 FOR
SET FLD=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD))
if 'FLD
QUIT
Begin DoDot:1
+7 SET CHG=0
+8 FOR
SET CHG=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD,CHG))
if 'CHG
QUIT
Begin DoDot:2
+9 SET ITM=+$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
+10 ; no transmission if item already deleted
+11 if '$DATA(PRCV("DEL",ITM))
SET PRCV("EDT",ITM)=""
End DoDot:2
End DoDot:1
+12 ;
+13 ; Process edited line items after duplicated lines removed
+14 SET ITM=0
+15 FOR
SET ITM=$ORDER(PRCV("EDT",ITM))
if 'ITM
QUIT
Begin DoDot:1
+16 DO ITEM
+17 ; Insert Amendment Type of "Line Item Edit"
+18 if $DATA(^TMP("PRCV442A",$JOB,PRCHPO,ITM))
SET $PIECE(^(ITM),"^",14)=1
End DoDot:1
+19 ;
+20 ; create header only if item exist
+21 IF $DATA(^TMP("PRCV442A",$JOB,PRCHPO))
DO HEADER
DO SEND
SET DONE=1
+22 QUIT
E31 ; Change Vendor
+1 ; Send new vendor only
+2 ; New vendor already in 442
+3 ; No need to find it elsewhere
+4 SET ALL=3
+5 DO ALLITEM
SET DONE=1
+6 QUIT
E32 ; Replace PO Number
+1 ; Send new PO number information including DynaMed Doc ID
+2 SET NPO=$PIECE($GET(^PRC(442,PRCHPO,23)),"^",4)
+3 if 'NPO
QUIT
+4 SET PRCHPO=NPO
+5 SET ALL=4
+6 DO ALLITEM
+7 QUIT
E34 ; Authority Edit
+1 ; if Change Vendor and Line Edit already done.
if DONE
QUIT
+2 ; If change to delivery date only without any other amendment
+3 ; Authority Edit became No Charge Amendment
+4 IF $PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5
IF PRCFA("DLVDATE")'=$PIECE(EXT,"^",2)
Begin DoDot:1
+5 SET ALL=1
DO ALLITEM
End DoDot:1
+6 ; Send PO Cancelled only
+7 if $PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5
QUIT
+8 ; change amendment type to Cancel
+9 SET ALL=5
+10 DO ALLITEM
+11 QUIT
+12 ;
+1 ; Get PO header information
+2 DO PO^PRCV442A(PRCHPO)
+3 ; Change transaction type to PO Amendment
+4 SET $PIECE(^TMP("PRCV442A",$JOB,PRCHPO),"^",2)=2
+5 ; Amendment signed date
+6 SET $PIECE(^TMP("PRCV442A",$JOB,PRCHPO),"^",7)=$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,1)),"^",3)
+7 QUIT
ITEM ;
+1 DO ITEM^PRCV442A(PRCHPO,ITM,EXT)
+2 QUIT
ALLITEM ;
+1 ; If header level amendment, send all items to DynaMed
+2 ; 1. Collect all deleted item
+3 KILL ^TMP("PRCV442A",$JOB,PRCHPO),PRCV("DEL")
+4 SET AMD=0
FOR
SET AMD=$ORDER(^PRC(442,PRCHPO,6,AMD))
if 'AMD
QUIT
Begin DoDot:1
+5 SET FLD=0
+6 FOR
SET FLD=$ORDER(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD))
if 'FLD
QUIT
Begin DoDot:2
+7 SET CHG=0
+8 FOR
SET CHG=$ORDER(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD,CHG))
if 'CHG
QUIT
Begin DoDot:3
+9 SET ITM=+$PIECE($GET(^PRC(442,PRCHPO,6,AMD,3,CHG,0)),"^",4)
+10 SET PRCV("DEL",ITM)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 ; 2. pickup all items to DynaMed except deleted items
+12 SET ITM=0
FOR
SET ITM=$ORDER(^PRC(442,PRCHPO,2,ITM))
if 'ITM
QUIT
Begin DoDot:1
+13 IF '$DATA(PRCV("DEL",ITM))
DO ITEM
+14 if $DATA(^TMP("PRCV442A",$JOB,PRCHPO,ITM))
SET $PIECE(^(ITM),"^",14)=ALL
End DoDot:1
+15 ; create header and send only if item exist
+16 IF $DATA(^TMP("PRCV442A",$JOB,PRCHPO))
DO HEADER
DO SEND
+17 QUIT
SEND ;
+1 ; Do not send if no item collected
+2 if '$ORDER(^TMP("PRCV442A",$JOB,PRCHPO,0))
QUIT
+3 MERGE ^TMP("ASU442A",$JOB)=^TMP("PRCV442A",$JOB)
+4 DO EN^PRCVPOSD(PRCHPO)
+5 QUIT
