| 1 | PRCPWPL3 ;WISC/RFJ-whse post issue book (post) ;13 Jan 94
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | POST ; post issue book
|
|---|
| 8 | D FULL^VALM1
|
|---|
| 9 | S VALMBCK="R"
|
|---|
| 10 | I '$O(^TMP($J,"PRCPWPLMPOST",0)) S VALMSG="THERE ARE NO ITEMS TO POST" D Q
|
|---|
| 11 | . W !!!!?5,$G(PRCP("RV1")),"WARNING: ",VALMSG,$G(PRCP("RV0")),!
|
|---|
| 12 | . I $G(PRCPFINL) D FINAL^PRCPWPL5 K VALMBCK Q
|
|---|
| 13 | . I $D(PRCPFINL) Q
|
|---|
| 14 | . I $$FINALASK^PRCPWPL2=1 D FINAL^PRCPWPL5 K VALMBCK
|
|---|
| 15 | ;
|
|---|
| 16 | I $G(PRCPFERR) S VALMSG="ALL ERRORS MUST BE FIXED BEFORE POSTING" Q
|
|---|
| 17 | ;
|
|---|
| 18 | N %,CANTEEN,COSTCNTR,DRUGACCT,IBDATA,INVCOST,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWORD,PRCPWPL3,QTYPOST,QUANTITY,TOTALINV,TOTALSAL,TOTCOST,TOTLINES,UNITCOST,X
|
|---|
| 19 | N PRCPPBFY,PRCPPFCP,PRCPPSTA,PRCPWBFY,PRCPWFCP,PRCPWSTA
|
|---|
| 20 | ; get whse and primary fcp data for fms code sheets
|
|---|
| 21 | ; variables will be passed to prcpsfiv routine
|
|---|
| 22 | D IVDATA^PRCPSFIU(PRCPDA,PRCPINPT)
|
|---|
| 23 | ;
|
|---|
| 24 | ; primary updated by whse posting
|
|---|
| 25 | I PRCPFPRI D
|
|---|
| 26 | . I $P($G(^PRCP(445,PRCPPRIM,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)
|
|---|
| 27 | ;
|
|---|
| 28 | RETRY ; come back to this label if reference voucher number not found
|
|---|
| 29 | S XP="ARE YOU SURE YOU WANT TO POST THIS ISSUE BOOK"
|
|---|
| 30 | W ! I $$YN^PRCPUYN(1)'=1 Q
|
|---|
| 31 | ;
|
|---|
| 32 | I '$$LOCK Q
|
|---|
| 33 | ;
|
|---|
| 34 | ; get reference number if it does not exist
|
|---|
| 35 | I $G(PRCPORD)="" D I PRCPORD="" D UNLOCK G RETRY
|
|---|
| 36 | . S PRCPORD=$$IBCNS^PRCPWPU1(PRC("SITE")_"-I"_$E(PRC("FY"),2))
|
|---|
| 37 | . I PRCPORD="" Q
|
|---|
| 38 | . S $P(^PRCS(410,PRCPDA,445),"^")=PRCPORD
|
|---|
| 39 | ;
|
|---|
| 40 | S PRCPWORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
|
|---|
| 41 | I PRCPFPRI S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPPRIM)
|
|---|
| 42 | W !!?4,"REFERENCE VOUCHER NUMBER : ",PRCPORD
|
|---|
| 43 | W !?4,"WHSE TRANSACTION REGISTER ID: R",PRCPWORD
|
|---|
| 44 | I $P($G(^PRC(420,PRCPPSTA,1,PRCPPFCP,0)),"^",12)=4 S CANTEEN=1
|
|---|
| 45 | D POST^PRCPWPL4
|
|---|
| 46 | Q
|
|---|
| 47 | ;
|
|---|
| 48 | ;
|
|---|
| 49 | LOCK() ; lock whse and primary invpts
|
|---|
| 50 | ; return 1 for success
|
|---|
| 51 | L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q 0
|
|---|
| 52 | I PRCPFPRI L +^PRCP(445,PRCPPRIM,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPPRIM_"-1",0) L -^PRCP(445,PRCPINPT,1) Q 0
|
|---|
| 53 | D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Post Issue Book")
|
|---|
| 54 | I PRCPFPRI D ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"Post Issue Book")
|
|---|
| 55 | Q 1
|
|---|
| 56 | ;
|
|---|
| 57 | ;
|
|---|
| 58 | UNLOCK ; unlock whse and primary invpts
|
|---|
| 59 | D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
|
|---|
| 60 | L -^PRCP(445,PRCPINPT,1)
|
|---|
| 61 | I PRCPFPRI D CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0) L -^PRCP(445,PRCPPRIM,1)
|
|---|
| 62 | Q
|
|---|
