- PRCPWPP3 ;WISC/RFJ-primary receive issue book (receive) ;20 Jan 94
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- RECEIVE ; receive issue book
- D FULL^VALM1
- S VALMBCK="R"
- I '$O(^TMP($J,"PRCPWPPLPOST",0)) S VALMSG="THERE ARE NO ITEMS TO RECEIVE" Q
- ;
- N %,COSTCNTR,DRUGACCT,IBDATA,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWPP3,QTYPOST,QUANTITY,TOTCOST,TOTLINES,UNITCOST,X
- ;
- I $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)
- ;
- S XP="ARE YOU SURE YOU WANT TO RECEIVE THIS ISSUE BOOK"
- W ! I $$YN^PRCPUYN(1)'=1 Q
- L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q
- D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Issue Book")
- S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
- S TOTLINES=0
- S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPPLPOST",LINEDA)) Q:'LINEDA S QTYPOST=^(LINEDA) I QTYPOST D
- . S IBDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I IBDATA="" Q
- . S ITEMDA=+$P(IBDATA,"^",5)
- . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
- . S UNITCOST=$P(IBDATA,"^",7)
- . S TOTCOST=$J(QTYPOST*UNITCOST,0,2)
- . S TOTLINES=TOTLINES+1
- . ;
- . ; *** primary ***
- . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
- . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" D Q
- . . S COSTCNTR=$P($G(^PRCP(445,PRCPINPT,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
- . S QTYPOST=QTYPOST*$P($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRCPPVNO,1),"^",4)
- . ; update beginning balance
- . I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
- . ; update primary invpt
- . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+QTYPOST
- . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+TOTCOST
- . ; update average cost
- . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)
- . I QUANTITY S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
- . ; update last cost
- . S $P(ITEMDATA,"^",15)=$J(TOTCOST/QTYPOST,0,3),$P(ITEMDATA,"^",3)=DT
- . S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
- . ; remove due-in
- . D OUTST^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA,-QTYPOST)
- . ; receipt history
- . D RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST)
- . ; distribution costs
- . S COSTCNTR=$P(^PRCP(445,PRCPINPT,0),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
- . ; drug accountability
- . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPINPT,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
- . ; transaction register
- . I PRCPPORD D
- . . K PRCPWPP3
- . . S PRCPWPP3("QTY")=QTYPOST,(PRCPWPP3("INVVAL"),PRCPWPP3("SELVAL"))=TOTCOST,PRCPWPP3("2237PO")=PRCPIBNM,PRCPWPP3("OTHERPT")=PRCPWHSE
- . . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",PRCPPORD,.PRCPWPP3)
- ;
- K VALMBCK
- ;
- I $G(DRUGACCT) D EX^PSAGIP
- K X S X(1)="TOTAL LINE ITEMS POSTED: "_TOTLINES D DISPLAY^PRCPUX2(1,40,.X)
- ;
- ; make issue book a final
- I $G(PRCPFINL) D
- . K X S X(1)="This issue book is a final. You have the option to remove all outstanding due-ins for this issue book." D DISPLAY^PRCPUX2(5,75,.X)
- . S XP="Do you want to remove the due-ins for this issue book",XH="Enter YES to remove the due-ins, NO to leave the due-ins."
- . I $$YN^PRCPUYN(1)'=1 Q
- . S LINEDA=0 F S LINEDA=$O(^PRCS(410,PRCPDA,"IT",LINEDA)) Q:'LINEDA S ITEMDA=+$P(^(LINEDA,0),"^",5),QTYOUT=$P(^(0),"^",2)-$P(^(0),"^",13) I QTYOUT>0 D
- . . D KILLTRAN^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA)
- ;
- D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
- L -^PRCP(445,PRCPINPT,1)
- ;
- I TOTLINES=0 Q:$G(PRCPFINL) S VALMSG="NO LINE ITEMS TO POST",VALMBCK="R" Q
- D R^PRCPUREP
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPP3 3980 printed Feb 18, 2025@23:43:10 Page 2
- PRCPWPP3 ;WISC/RFJ-primary receive issue book (receive) ;20 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 ;
- RECEIVE ; receive issue book
- +1 DO FULL^VALM1
- +2 SET VALMBCK="R"
- +3 IF '$ORDER(^TMP($JOB,"PRCPWPPLPOST",0))
- SET VALMSG="THERE ARE NO ITEMS TO RECEIVE"
- QUIT
- +4 ;
- +5 NEW %,COSTCNTR,DRUGACCT,IBDATA,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWPP3,QTYPOST,QUANTITY,TOTCOST,TOTLINES,UNITCOST,X
- +6 ;
- +7 IF $PIECE($GET(^PRCP(445,PRCPINPT,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)
- +8 ;
- +9 SET XP="ARE YOU SURE YOU WANT TO RECEIVE THIS ISSUE BOOK"
- +10 WRITE !
- IF $$YN^PRCPUYN(1)'=1
- QUIT
- +11 LOCK +^PRCP(445,PRCPINPT,1):5
- IF '$TEST
- DO SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0)
- QUIT
- +12 DO ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Issue Book")
- +13 SET PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
- +14 SET TOTLINES=0
- +15 SET LINEDA=0
- FOR
- SET LINEDA=$ORDER(^TMP($JOB,"PRCPWPPLPOST",LINEDA))
- if 'LINEDA
- QUIT
- SET QTYPOST=^(LINEDA)
- IF QTYPOST
- Begin DoDot:1
- +16 SET IBDATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
- IF IBDATA=""
- QUIT
- +17 SET ITEMDA=+$PIECE(IBDATA,"^",5)
- +18 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- IF ITEMDATA=""
- QUIT
- +19 SET UNITCOST=$PIECE(IBDATA,"^",7)
- +20 SET TOTCOST=$JUSTIFY(QTYPOST*UNITCOST,0,2)
- +21 SET TOTLINES=TOTLINES+1
- +22 ;
- +23 ; *** primary ***
- +24 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
- +25 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- IF ITEMDATA=""
- Begin DoDot:2
- +26 SET COSTCNTR=$PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",7)
- IF COSTCNTR
- DO COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
- End DoDot:2
- QUIT
- +27 SET QTYPOST=QTYPOST*$PIECE($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRCPPVNO,1),"^",4)
- +28 ; update beginning balance
- +29 IF '$DATA(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
- DO BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$EXTRACT(DT,1,5))
- +30 ; update primary invpt
- +31 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+QTYPOST
- +32 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+TOTCOST
- +33 ; update average cost
- +34 SET $PIECE(ITEMDATA,"^",22)=0
- SET QUANTITY=$PIECE(ITEMDATA,"^",7)
- +35 IF QUANTITY
- SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
- IF $PIECE(ITEMDATA,"^",22)'>0
- SET $PIECE(ITEMDATA,"^",22)=0
- +36 ; update last cost
- +37 SET $PIECE(ITEMDATA,"^",15)=$JUSTIFY(TOTCOST/QTYPOST,0,3)
- SET $PIECE(ITEMDATA,"^",3)=DT
- +38 SET ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
- +39 ; remove due-in
- +40 DO OUTST^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA,-QTYPOST)
- +41 ; receipt history
- +42 DO RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST)
- +43 ; distribution costs
- +44 SET COSTCNTR=$PIECE(^PRCP(445,PRCPINPT,0),"^",7)
- IF COSTCNTR
- DO COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
- +45 ; drug accountability
- +46 IF $GET(DRUGACCT)
- SET %=+$PIECE(ITEMDATA,"^",29)
- if '%
- SET %=1
- DO EN^PSAGIP(PRCPINPT,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
- +47 ; transaction register
- +48 IF PRCPPORD
- Begin DoDot:2
- +49 KILL PRCPWPP3
- +50 SET PRCPWPP3("QTY")=QTYPOST
- SET (PRCPWPP3("INVVAL"),PRCPWPP3("SELVAL"))=TOTCOST
- SET PRCPWPP3("2237PO")=PRCPIBNM
- SET PRCPWPP3("OTHERPT")=PRCPWHSE
- +51 DO ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",PRCPPORD,.PRCPWPP3)
- End DoDot:2
- End DoDot:1
- +52 ;
- +53 KILL VALMBCK
- +54 ;
- +55 IF $GET(DRUGACCT)
- DO EX^PSAGIP
- +56 KILL X
- SET X(1)="TOTAL LINE ITEMS POSTED: "_TOTLINES
- DO DISPLAY^PRCPUX2(1,40,.X)
- +57 ;
- +58 ; make issue book a final
- +59 IF $GET(PRCPFINL)
- Begin DoDot:1
- +60 KILL X
- SET X(1)="This issue book is a final. You have the option to remove all outstanding due-ins for this issue book."
- DO DISPLAY^PRCPUX2(5,75,.X)
- +61 SET XP="Do you want to remove the due-ins for this issue book"
- SET XH="Enter YES to remove the due-ins, NO to leave the due-ins."
- +62 IF $$YN^PRCPUYN(1)'=1
- QUIT
- +63 SET LINEDA=0
- FOR
- SET LINEDA=$ORDER(^PRCS(410,PRCPDA,"IT",LINEDA))
- if 'LINEDA
- QUIT
- SET ITEMDA=+$PIECE(^(LINEDA,0),"^",5)
- SET QTYOUT=$PIECE(^(0),"^",2)-$PIECE(^(0),"^",13)
- IF QTYOUT>0
- Begin DoDot:2
- +64 DO KILLTRAN^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA)
- End DoDot:2
- End DoDot:1
- +65 ;
- +66 DO CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
- +67 LOCK -^PRCP(445,PRCPINPT,1)
- +68 ;
- +69 IF TOTLINES=0
- if $GET(PRCPFINL)
- QUIT
- SET VALMSG="NO LINE ITEMS TO POST"
- SET VALMBCK="R"
- QUIT
- +70 DO R^PRCPUREP
- +71 QUIT