Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCVPOU

PRCVPOU.m

Go to the documentation of this file. 
  1. PRCVPOU ;WOIFO/AS-SEND PO AMENDMENT TO DYNAMED ; 01/24/05
  1.  ;;5.1;IFCAP;**81**;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ; PO amendment
  1.  ; Input: PRCHPO (PO number)
  1.  ;        PRCHAM (amendment number)
  1.  ; Called from PRCHAM (Amendment to Purchase Order/Card)
  1.  ;             PRCFFMOM (Amendment Processing)
  1.  ;
  1.  Q
  1. ENT(PRCHPO,PRCHAM) ;
  1.  N AMEND,PRCV,CHG,FLD,ITM,NPO,NXT,ALL,EXT,AMD,PRCVP,DIQ,DIC,DA,DR,DONE
  1.  S AMEND=0,DIQ="PRCVP",DIQ(0)="IE",DIC=442,DA=PRCHPO,DR=".07;7;62"
  1.  D EN^DIQ1
  1.  S EXT=PRCVP(442,PRCHPO,62,"E"),DONE=0
  1.  I EXT']"" S EXT=PRCVP(442,PRCHPO,.07,"E")
  1.  S $P(EXT,"^",2)=PRCVP(442,PRCHPO,7,"I") ; delivery date
  1.  F  S AMEND=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND)) Q:AMEND'>0  D
  1.  . S NXT="E"_+AMEND
  1.  . I $T(@NXT)'="" D @NXT
  1.  Q
  1. E22 ;Line Item Delete
  1.  S FLD=0 K PRCV("DEL"),^TMP("PRCV442A",$J,PRCHPO)
  1.  F  S FLD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD)) Q:FLD'>0  D
  1.  . S CHG=0
  1.  . F  S CHG=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FLD,CHG)) Q:CHG'>0  D
  1.  .. S ITM=+$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
  1.  .. S PRCV("DEL",ITM)=""
  1.  .. ; only item with DM document ID will be passed back
  1.  .. D ITEM
  1.  .. ; Insert Amendment Type of "Line Item Delete"
  1.  .. S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=2
  1.  ;    create header only if item exist
  1.  I $D(^TMP("PRCV442A",$J,PRCHPO)) D 
  1.  . D HEADER
  1.  . ;    If there is no Line Item Edit, send out this message
  1.  . I '$D(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23)) D SEND
  1.  Q
  1. E23 ;Line Item Edit
  1.  ;  If delivery date changed, send all items, Quit
  1.  I PRCFA("DLVDATE")'=$P(EXT,"^",2) S ALL=1 D ALLITEM Q
  1.  ;
  1.  S FLD=0 K PRCV("EDT")
  1.  ;    remove duplicated line item
  1.  F  S FLD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD)) Q:'FLD  D
  1.  . S CHG=0
  1.  . F  S CHG=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FLD,CHG)) Q:'CHG  D
  1.  .. S ITM=+$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,CHG,0)),"^",4)
  1.  .. ;   no transmission if item already deleted
  1.  .. S:'$D(PRCV("DEL",ITM)) PRCV("EDT",ITM)=""
  1.  ;
  1.  ; Process edited line items after duplicated lines removed
  1.  S ITM=0
  1.  F  S ITM=$O(PRCV("EDT",ITM)) Q:'ITM  D
  1.  . D ITEM
  1.  . ; Insert Amendment Type of "Line Item Edit"
  1.  . S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=1
  1.  ;
  1.  ;    create header only if item exist
  1.  I $D(^TMP("PRCV442A",$J,PRCHPO)) D HEADER,SEND S DONE=1
  1.  Q
  1. E31 ; Change Vendor
  1.  ;    Send new vendor only
  1.  ;       New vendor already in 442
  1.  ;          No need to find it elsewhere
  1.  S ALL=3
  1.  D ALLITEM S DONE=1
  1.  Q
  1. E32 ; Replace PO Number
  1.  ;    Send new PO number information including DynaMed Doc ID
  1.  S NPO=$P($G(^PRC(442,PRCHPO,23)),"^",4)
  1.  Q:'NPO
  1.  S PRCHPO=NPO
  1.  S ALL=4
  1.  D ALLITEM
  1.  Q
  1. E34 ; Authority Edit
  1.  Q:DONE    ; if Change Vendor and Line Edit already done.
  1.  ;  If change to delivery date only without any other amendment
  1.  ;  Authority Edit became No Charge Amendment
  1.  I $P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5,PRCFA("DLVDATE")'=$P(EXT,"^",2) D
  1.  . S ALL=1 D ALLITEM
  1.  ;    Send PO Cancelled only
  1.  Q:$P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),"^",4)'=5
  1.  ; change amendment type to Cancel
  1.  S ALL=5
  1.  D ALLITEM
  1.  Q
  1.  ;
  1.  ; Get PO header information
  1.  D PO^PRCV442A(PRCHPO)
  1.  ;   Change transaction type to PO Amendment
  1.  S $P(^TMP("PRCV442A",$J,PRCHPO),"^",2)=2
  1.  ;   Amendment signed date
  1.  S $P(^TMP("PRCV442A",$J,PRCHPO),"^",7)=$P($G(^PRC(442,PRCHPO,6,PRCHAM,1)),"^",3)
  1.  Q
  1. ITEM ;
  1.  D ITEM^PRCV442A(PRCHPO,ITM,EXT)
  1.  Q
  1. ALLITEM ;
  1.  ; If header level amendment, send all items to DynaMed
  1.  ;     1.   Collect all deleted item
  1.  K ^TMP("PRCV442A",$J,PRCHPO),PRCV("DEL")
  1.  S AMD=0 F  S AMD=$O(^PRC(442,PRCHPO,6,AMD)) Q:'AMD  D
  1.  . S FLD=0
  1.  . F  S FLD=$O(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD)) Q:'FLD  D
  1.  .. S CHG=0
  1.  .. F  S CHG=$O(^PRC(442,PRCHPO,6,AMD,3,"AC",22,FLD,CHG)) Q:'CHG  D
  1.  ... S ITM=+$P($G(^PRC(442,PRCHPO,6,AMD,3,CHG,0)),"^",4)
  1.  ... S PRCV("DEL",ITM)=""
  1.  ;     2.   pickup all items to DynaMed except deleted items
  1.  S ITM=0 F  S ITM=$O(^PRC(442,PRCHPO,2,ITM)) Q:'ITM  D
  1.  . I '$D(PRCV("DEL",ITM)) D ITEM
  1.  . S:$D(^TMP("PRCV442A",$J,PRCHPO,ITM)) $P(^(ITM),"^",14)=ALL
  1.  ;    create header and send only if item exist
  1.  I $D(^TMP("PRCV442A",$J,PRCHPO)) D HEADER,SEND
  1.  Q
  1. SEND ;
  1.  ;  Do not send if no item collected
  1.  Q:'$O(^TMP("PRCV442A",$J,PRCHPO,0))
  1.  M ^TMP("ASU442A",$J)=^TMP("PRCV442A",$J)
  1.  D EN^PRCVPOSD(PRCHPO)
  1.  Q