PRCPWPL3 ;WISC/RFJ-whse post issue book (post) ;13 Jan 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
POST ; post issue book
D FULL^VALM1
S VALMBCK="R"
I '$O(^TMP($J,"PRCPWPLMPOST",0)) S VALMSG="THERE ARE NO ITEMS TO POST" D Q
. W !!!!?5,$G(PRCP("RV1")),"WARNING: ",VALMSG,$G(PRCP("RV0")),!
. I $G(PRCPFINL) D FINAL^PRCPWPL5 K VALMBCK Q
. I $D(PRCPFINL) Q
. I $$FINALASK^PRCPWPL2=1 D FINAL^PRCPWPL5 K VALMBCK
;
I $G(PRCPFERR) S VALMSG="ALL ERRORS MUST BE FIXED BEFORE POSTING" Q
;
N %,CANTEEN,COSTCNTR,DRUGACCT,IBDATA,INVCOST,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWORD,PRCPWPL3,QTYPOST,QUANTITY,TOTALINV,TOTALSAL,TOTCOST,TOTLINES,UNITCOST,X
N PRCPPBFY,PRCPPFCP,PRCPPSTA,PRCPWBFY,PRCPWFCP,PRCPWSTA
; get whse and primary fcp data for fms code sheets
; variables will be passed to prcpsfiv routine
D IVDATA^PRCPSFIU(PRCPDA,PRCPINPT)
;
; primary updated by whse posting
I PRCPFPRI D
. 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)
;
RETRY ; come back to this label if reference voucher number not found
S XP="ARE YOU SURE YOU WANT TO POST THIS ISSUE BOOK"
W ! I $$YN^PRCPUYN(1)'=1 Q
;
I '$$LOCK Q
;
; get reference number if it does not exist
I $G(PRCPORD)="" D I PRCPORD="" D UNLOCK G RETRY
. S PRCPORD=$$IBCNS^PRCPWPU1(PRC("SITE")_"-I"_$E(PRC("FY"),2))
. I PRCPORD="" Q
. S $P(^PRCS(410,PRCPDA,445),"^")=PRCPORD
;
S PRCPWORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
I PRCPFPRI S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPPRIM)
W !!?4,"REFERENCE VOUCHER NUMBER : ",PRCPORD
W !?4,"WHSE TRANSACTION REGISTER ID: R",PRCPWORD
I $P($G(^PRC(420,PRCPPSTA,1,PRCPPFCP,0)),"^",12)=4 S CANTEEN=1
D POST^PRCPWPL4
Q
;
;
LOCK() ; lock whse and primary invpts
; return 1 for success
L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q 0
I PRCPFPRI L +^PRCP(445,PRCPPRIM,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPPRIM_"-1",0) L -^PRCP(445,PRCPINPT,1) Q 0
D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Post Issue Book")
I PRCPFPRI D ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"Post Issue Book")
Q 1
;
;
UNLOCK ; unlock whse and primary invpts
D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
L -^PRCP(445,PRCPINPT,1)
I PRCPFPRI D CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0) L -^PRCP(445,PRCPPRIM,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPL3 2526 printed Sep 23, 2025@19:52:46 Page 2
PRCPWPL3 ;WISC/RFJ-whse post issue book (post) ;13 Jan 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
POST ; post issue book
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 IF '$ORDER(^TMP($JOB,"PRCPWPLMPOST",0))
SET VALMSG="THERE ARE NO ITEMS TO POST"
Begin DoDot:1
+4 WRITE !!!!?5,$GET(PRCP("RV1")),"WARNING: ",VALMSG,$GET(PRCP("RV0")),!
+5 IF $GET(PRCPFINL)
DO FINAL^PRCPWPL5
KILL VALMBCK
QUIT
+6 IF $DATA(PRCPFINL)
QUIT
+7 IF $$FINALASK^PRCPWPL2=1
DO FINAL^PRCPWPL5
KILL VALMBCK
End DoDot:1
QUIT
+8 ;
+9 IF $GET(PRCPFERR)
SET VALMSG="ALL ERRORS MUST BE FIXED BEFORE POSTING"
QUIT
+10 ;
+11 NEW %,CANTEEN,COSTCNTR,DRUGACCT,IBDATA,INVCOST,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWORD,PRCPWPL3,QTYPOST,QUANTITY,TOTALINV,TOTALSAL,TOTCOST,TOTLINES,UNITCOST,X
+12 NEW PRCPPBFY,PRCPPFCP,PRCPPSTA,PRCPWBFY,PRCPWFCP,PRCPWSTA
+13 ; get whse and primary fcp data for fms code sheets
+14 ; variables will be passed to prcpsfiv routine
+15 DO IVDATA^PRCPSFIU(PRCPDA,PRCPINPT)
+16 ;
+17 ; primary updated by whse posting
+18 IF PRCPFPRI
Begin DoDot:1
+19 IF $PIECE($GET(^PRCP(445,PRCPPRIM,0)),"^",20)="D"
SET X="PSAGIP"
IF $DATA(^%ZOSF("TEST"))
XECUTE ^("TEST")
IF $TEST
SET DRUGACCT=1
KILL X
SET X(1)="NOTE: This is a DRUG ACCOUNTABILITY inventory point."
DO DISPLAY^PRCPUX2(1,79,.X)
End DoDot:1
+20 ;
RETRY ; come back to this label if reference voucher number not found
+1 SET XP="ARE YOU SURE YOU WANT TO POST THIS ISSUE BOOK"
+2 WRITE !
IF $$YN^PRCPUYN(1)'=1
QUIT
+3 ;
+4 IF '$$LOCK
QUIT
+5 ;
+6 ; get reference number if it does not exist
+7 IF $GET(PRCPORD)=""
Begin DoDot:1
+8 SET PRCPORD=$$IBCNS^PRCPWPU1(PRC("SITE")_"-I"_$EXTRACT(PRC("FY"),2))
+9 IF PRCPORD=""
QUIT
+10 SET $PIECE(^PRCS(410,PRCPDA,445),"^")=PRCPORD
End DoDot:1
IF PRCPORD=""
DO UNLOCK
GOTO RETRY
+11 ;
+12 SET PRCPWORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
+13 IF PRCPFPRI
SET PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPPRIM)
+14 WRITE !!?4,"REFERENCE VOUCHER NUMBER : ",PRCPORD
+15 WRITE !?4,"WHSE TRANSACTION REGISTER ID: R",PRCPWORD
+16 IF $PIECE($GET(^PRC(420,PRCPPSTA,1,PRCPPFCP,0)),"^",12)=4
SET CANTEEN=1
+17 DO POST^PRCPWPL4
+18 QUIT
+19 ;
+20 ;
LOCK() ; lock whse and primary invpts
+1 ; return 1 for success
+2 LOCK +^PRCP(445,PRCPINPT,1):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0)
QUIT 0
+3 IF PRCPFPRI
LOCK +^PRCP(445,PRCPPRIM,1):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCPPRIM_"-1",0)
LOCK -^PRCP(445,PRCPINPT,1)
QUIT 0
+4 DO ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Post Issue Book")
+5 IF PRCPFPRI
DO ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"Post Issue Book")
+6 QUIT 1
+7 ;
+8 ;
UNLOCK ; unlock whse and primary invpts
+1 DO CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
+2 LOCK -^PRCP(445,PRCPINPT,1)
+3 IF PRCPFPRI
DO CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0)
LOCK -^PRCP(445,PRCPPRIM,1)
+4 QUIT
