| 1 | PRCPPOL1 ;WISC/RFJ-receive purchase order (list manager) ; 6/18/01 1:21pm
|
|---|
| 2 | ;;5.1;IFCAP;**34**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | RECEIVE ; start receiving po into inventory point
|
|---|
| 8 | D FULL^VALM1
|
|---|
| 9 | S VALMBCK="R"
|
|---|
| 10 | N X
|
|---|
| 11 | I $G(PRCPFLAG) D Q
|
|---|
| 12 | . K X S X(1)="You must FIX all errors before receiving this purchase order into your inventory point. Failure to correctly fix the errors may lead to incorrect values in your inventory point."
|
|---|
| 13 | . D DISPLAY^PRCPUX2(5,75,.X)
|
|---|
| 14 | . D R^PRCPUREP
|
|---|
| 15 | ;
|
|---|
| 16 | I $G(PRCPFCOS) D
|
|---|
| 17 | . K X S X(1)="This is a friendly WARNING. There are items on this purchase order which are either not stored in your inventory point OR have not been costed to a distribution point."
|
|---|
| 18 | . S X(2)="If you continue receiving this purcase order, these items will NOT be received or costed to any inventory point."
|
|---|
| 19 | . D DISPLAY^PRCPUX2(5,75,.X)
|
|---|
| 20 | ;
|
|---|
| 21 | N %,DATA,DRUGACCT,ISMSFLAG,ITEMDA,ITEMDATA,LINEDA,ORDERNO,PONO,PRCPPOL1,QTYRECVE,QUANTITY,REFDA,TOTCOST,TRANDA,TRANID,Y
|
|---|
| 22 | I PRCPTYPE="P",$P($G(^PRCP(445,PRCPINPT,0)),"^",20)="D" S X="PSAGIP" I $D(^%ZOSF("TEST")) X ^("TEST") I $T S DRUGACCT=1 K X S X(1)="NOTE: This is a DRUG ACCOUNTABILITY inventory point." D DISPLAY^PRCPUX2(1,79,.X)
|
|---|
| 23 | ;
|
|---|
| 24 | S XP="ARE YOU SURE YOU WANT TO RECEIVE THIS PURCHASE ORDER"
|
|---|
| 25 | W ! I $$YN^PRCPUYN(1)'=1 Q
|
|---|
| 26 | ;
|
|---|
| 27 | CHKFINAL ;This block of the code will check and flag any incomplete Partial
|
|---|
| 28 | ;receipt for selected Final PO. NOIS=LIT-0800-72295.
|
|---|
| 29 | G:'$D(^PRC(442,PRCPORDR,11,0)) OKFINAL
|
|---|
| 30 | N LOOPCNT,PARTMSG,PARTNUM,PARTCNT,NODATA
|
|---|
| 31 | S LOOPCNT=1,(CHKDATA,PARTMSG,PARTCNT,NODATA)=0
|
|---|
| 32 | S PARTNUM=""
|
|---|
| 33 | S PARTCNT=$P($G(^PRC(442,PRCPORDR,11,0)),"^",4)
|
|---|
| 34 | I PARTCNT'="" G:PARTCNT'=PRCPPART OKFINAL
|
|---|
| 35 | I (PARTCNT'=""),(PARTCNT>0) S PARTCNT=PARTCNT-1
|
|---|
| 36 | F LOOPCNT=1:1:PARTCNT D
|
|---|
| 37 | .S CHKDATA=$G(^PRC(442,PRCPORDR,11,LOOPCNT,0))
|
|---|
| 38 | .I CHKDATA="" S NODATA=1
|
|---|
| 39 | .I $P(CHKDATA,"^",16)="" S PARTMSG=1,PARTNUM=PARTNUM_LOOPCNT_","
|
|---|
| 40 | G:'PARTMSG OKFINAL
|
|---|
| 41 | I PARTMSG D Q
|
|---|
| 42 | . S WRD1="number: " S:$L(PARTNUM)>2 WRD1="numbers: "
|
|---|
| 43 | . S WRD2="is" S:$L(PARTNUM)>2 WRD2="are"
|
|---|
| 44 | . S PARTNUM=$E(PARTNUM,1,$L(PARTNUM)-1)
|
|---|
| 45 | . K X S X(1)=" WARNING: There is more than one partial pending receipt for this purchase order."
|
|---|
| 46 | . S X(2)="Please make sure that receipts are posted in sequence order to prevent any problem."
|
|---|
| 47 | . S X(3)="Partial "_WRD1_PARTNUM_" "_WRD2_" missing for this purchase order."
|
|---|
| 48 | . D DISPLAY^PRCPUX2(5,75,.X)
|
|---|
| 49 | . D R^PRCPUREP
|
|---|
| 50 | . K LOOPCNT,CHKDATA,PARTMSG,PARTNUM,NODATA,WRD1,WRD2
|
|---|
| 51 | ;
|
|---|
| 52 | OKFINAL ;
|
|---|
| 53 | L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0),R^PRCPUREP Q
|
|---|
| 54 | D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Purchase Order")
|
|---|
| 55 | ;
|
|---|
| 56 | S ORDERNO=$$ORDERNO^PRCPUTRX(PRCPINPT)
|
|---|
| 57 | S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPPOLMREC",LINEDA)) Q:'LINEDA S DATA=^(LINEDA) D
|
|---|
| 58 | . S ITEMDA=$P(DATA,"^"),QTYRECVE=$P(DATA,"^",2),TOTCOST=$P(DATA,"^",3),TRANDA=$P(DATA,"^",4)
|
|---|
| 59 | . I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) S %=$G(^TMP($J,"PRCPPOLMCOS",LINEDA)) D:$P(%,"^",2) COSTCNTR^PRCPUCC($P(%,"^",2),PRCPINPT,$P(%,"^",3),TOTCOST) Q
|
|---|
| 60 | . ;
|
|---|
| 61 | . ; for items stored in the inventory point
|
|---|
| 62 | . ; update beginning balance
|
|---|
| 63 | . I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
|
|---|
| 64 | . ;
|
|---|
| 65 | . ; update inventory point
|
|---|
| 66 | . S ITEMDATA=^PRCP(445,PRCPINPT,1,ITEMDA,0)
|
|---|
| 67 | . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+QTYRECVE
|
|---|
| 68 | . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+TOTCOST
|
|---|
| 69 | . ; update average cost
|
|---|
| 70 | . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
|
|---|
| 71 | . I QUANTITY>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
|
|---|
| 72 | . ; update last cost in invpt
|
|---|
| 73 | . S $P(ITEMDATA,"^",15)=$J(TOTCOST/QTYRECVE,0,3),$P(ITEMDATA,"^",3)=DT
|
|---|
| 74 | . S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
|
|---|
| 75 | . ;
|
|---|
| 76 | . ; update last cost for supply whse vendor in IM file
|
|---|
| 77 | . I PRCPTYPE="W",$D(^PRC(441,ITEMDA,2,+$O(^PRC(440,"AC","S",0)),0)) S $P(^(0),"^",2)=$S($P(ITEMDATA,"^",15)>$P(ITEMDATA,"^",22):$P(ITEMDATA,"^",15),1:$P(ITEMDATA,"^",22))
|
|---|
| 78 | . ; update due-in
|
|---|
| 79 | . D OUTST^PRCPUTRA(PRCPINPT,ITEMDA,TRANDA,-QTYRECVE)
|
|---|
| 80 | . ; update receipt history
|
|---|
| 81 | . D RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYRECVE)
|
|---|
| 82 | . ; update drug accountability
|
|---|
| 83 | . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPINPT,ITEMDA,QTYRECVE*%,TRANDA,PRCPORDN,"RC"_ORDERNO,TOTCOST)
|
|---|
| 84 | . ; transaction register
|
|---|
| 85 | . I ORDERNO D
|
|---|
| 86 | . . K PRCPPOL1
|
|---|
| 87 | . . S PRCPPOL1("QTY")=QTYRECVE,(PRCPPOL1("INVVAL"),PRCPPOL1("SELVAL"))=TOTCOST,PRCPPOL1("PKG")=$P(DATA,"^",5),PRCPPOL1("2237PO")=PRCPORDN,PRCPPOL1("REF")=$E($P(PRCPORDN,"-",2))_$E($P(PRCPORDN,"-",2),3,6)
|
|---|
| 88 | . . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",ORDERNO,.PRCPPOL1)
|
|---|
| 89 | ;
|
|---|
| 90 | I $G(DRUGACCT) D EX^PSAGIP
|
|---|
| 91 | ; enter receiving information for partial
|
|---|
| 92 | S Y="" D ENCODE^PRCHES2(PRCPORDR,PRCPPART,+DUZ,.Y) I Y>0 D NOW^%DTC S $P(^PRC(442,PRCPORDR,11,PRCPPART,0),"^",17,18)=%_"^"_+DUZ
|
|---|
| 93 | ; clean up outstanding transactions
|
|---|
| 94 | I $P(^PRC(442,PRCPORDR,11,PRCPPART,0),"^",9)="F" D
|
|---|
| 95 | . S REFDA=0 F S REFDA=$O(^PRC(442,PRCPORDR,13,REFDA)) Q:'REFDA S TRANDA=$P(^(REFDA,0),"^"),LINEDA=0 F S LINEDA=$O(^PRCS(410,TRANDA,"IT",LINEDA)) Q:'LINEDA D KILLTRAN^PRCPUTRA(PRCPINPT,+$P(^(LINEDA,0),"^",5),TRANDA)
|
|---|
| 96 | K X S X(1)="***** RECEIVING HAS BEEN POSTED *****" D DISPLAY^PRCPUX2(2,40,.X)
|
|---|
| 97 | D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
|
|---|
| 98 | L -^PRCP(445,PRCPINPT,1)
|
|---|
| 99 | K VALMBCK
|
|---|
| 100 | I PRCPTYPE'="W" D R^PRCPUREP Q
|
|---|
| 101 | ;
|
|---|
| 102 | ; create code sheets
|
|---|
| 103 | K X S X(1)="The program will automatically create and transmit the code sheets to Austin. Please verify the accuracy of the data and submit adjustment code sheets if necessary."
|
|---|
| 104 | D DISPLAY^PRCPUX2(2,75,.X)
|
|---|
| 105 | S PRCPFLAG=0,PONO=PRCPORDN,TRANID="RC"_ORDERNO
|
|---|
| 106 | S ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE")) I ISMSFLAG'=2 D DQ^PRCPSLOR
|
|---|
| 107 | I ISMSFLAG=2 D DQ^PRCPSMPR
|
|---|
| 108 | D R^PRCPUREP
|
|---|
| 109 | Q
|
|---|
