- PRCPWPL4 ;WISC/RFJ-whse post issue book (post cont) ;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
- S TOTLINES=0
- S (TOTLINES,TOTALINV,TOTALSAL)=0
- S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPLMPOST",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
- . ; do not post qty < 0
- . I QTYPOST>$P(ITEMDATA,"^",7) S QTYPOST=+$P(ITEMDATA,"^",7)
- . I 'QTYPOST Q
- . S UNITCOST=$P(ITEMDATA,"^",22) S:$P(ITEMDATA,"^",15)>UNITCOST UNITCOST=$P(ITEMDATA,"^",15) S:$P(IBDATA,"^",7)>UNITCOST UNITCOST=$P(IBDATA,"^",7)
- . S TOTCOST=$J(QTYPOST*UNITCOST,0,2),INVCOST=$J(QTYPOST*$P(ITEMDATA,"^",22),0,2)
- . S TOTALSAL=TOTALSAL+TOTCOST,TOTALINV=TOTALINV+INVCOST
- . S TOTLINES=TOTLINES+1
- . ;
- . ; *** whse ***
- . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)+QTYPOST
- . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",7)=UNITCOST
- . ; update totals posted
- . S %=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
- . S $P(%,"^",3)=$P(%,"^",3)+QTYPOST,$P(%,"^",4)=$P(%,"^",4)+INVCOST,$P(%,"^",5)=$P(%,"^",5)+TOTCOST
- . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$P(%,"^",3,5)
- . ; 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 whse invpt
- . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)-QTYPOST
- . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)-INVCOST
- . ; update average cost
- . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
- . I QUANTITY>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
- . S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
- . D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYPOST)
- . ; usage
- . D ADDUSAG^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST,INVCOST)
- . ; transaction register
- . K PRCPWPL3,Y
- . S PRCPWPL3("QTY")=-QTYPOST,PRCPWPL3("INVVAL")=-INVCOST,PRCPWPL3("SELVAL")=-TOTCOST,PRCPWPL3("2237PO")=PRCPIBNM,PRCPWPL3("REF")=PRCPORD,PRCPWPL3("OTHERPT")=PRCPPRIM
- . I $G(CANTEEN) S PRCPWPL3("REASON")="0:2:ISSUE to CANTEEN"
- . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"R",PRCPWORD,.PRCPWPL3)
- . ; set line number in transaction register
- . I $D(^PRCP(445.2,+$G(Y),0)) S $P(^(0),"^",24)=LINEDA
- . ;
- . ;
- . ; *** primary ***
- . I 'PRCPFPRI Q
- . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
- . S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)) I ITEMDATA="" D Q
- . . S COSTCNTR=$P($G(^PRCP(445,PRCPPRIM,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
- . S QTYPOST=QTYPOST*$P($$GETVEN^PRCPUVEN(PRCPPRIM,ITEMDA,PRCPPVNO,1),"^",4)
- . ; update beginning balance
- . I '$D(^PRCP(445.1,PRCPPRIM,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPPRIM,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,PRCPPRIM,1,ITEMDA,0)=ITEMDATA
- . ; remove due-in
- . D OUTST^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA,-QTYPOST)
- . ; receipt history
- . D RECEIPTS^PRCPUSAG(PRCPPRIM,ITEMDA,QTYPOST)
- . ; distribution costs
- . S COSTCNTR=$P(^PRCP(445,PRCPPRIM,0),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
- . ; drug accountability
- . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPPRIM,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
- . ; transaction register
- . I PRCPPORD D
- . . K PRCPWPL3
- . . S PRCPWPL3("QTY")=QTYPOST,(PRCPWPL3("INVVAL"),PRCPWPL3("SELVAL"))=TOTCOST,PRCPWPL3("2237PO")=PRCPIBNM,PRCPWPL3("REF")=PRCPORD,PRCPWPL3("OTHERPT")=PRCPINPT
- . . D ADDTRAN^PRCPUTRX(PRCPPRIM,ITEMDA,"RC",PRCPPORD,.PRCPWPL3)
- ;
- D ENDPOST^PRCPWPL5
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPL4 4419 printed Dec 13, 2024@02:16:43 Page 2
- PRCPWPL4 ;WISC/RFJ-whse post issue book (post cont) ;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 SET TOTLINES=0
- +2 SET (TOTLINES,TOTALINV,TOTALSAL)=0
- +3 SET LINEDA=0
- FOR
- SET LINEDA=$ORDER(^TMP($JOB,"PRCPWPLMPOST",LINEDA))
- if 'LINEDA
- QUIT
- SET QTYPOST=^(LINEDA)
- IF QTYPOST
- Begin DoDot:1
- +4 SET IBDATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
- IF IBDATA=""
- QUIT
- +5 SET ITEMDA=+$PIECE(IBDATA,"^",5)
- +6 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- IF ITEMDATA=""
- QUIT
- +7 ; do not post qty < 0
- +8 IF QTYPOST>$PIECE(ITEMDATA,"^",7)
- SET QTYPOST=+$PIECE(ITEMDATA,"^",7)
- +9 IF 'QTYPOST
- QUIT
- +10 SET UNITCOST=$PIECE(ITEMDATA,"^",22)
- if $PIECE(ITEMDATA,"^",15)>UNITCOST
- SET UNITCOST=$PIECE(ITEMDATA,"^",15)
- if $PIECE(IBDATA,"^",7)>UNITCOST
- SET UNITCOST=$PIECE(IBDATA,"^",7)
- +11 SET TOTCOST=$JUSTIFY(QTYPOST*UNITCOST,0,2)
- SET INVCOST=$JUSTIFY(QTYPOST*$PIECE(ITEMDATA,"^",22),0,2)
- +12 SET TOTALSAL=TOTALSAL+TOTCOST
- SET TOTALINV=TOTALINV+INVCOST
- +13 SET TOTLINES=TOTLINES+1
- +14 ;
- +15 ; *** whse ***
- +16 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)=$PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)+QTYPOST
- +17 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",7)=UNITCOST
- +18 ; update totals posted
- +19 SET %=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,445))
- +20 SET $PIECE(%,"^",3)=$PIECE(%,"^",3)+QTYPOST
- SET $PIECE(%,"^",4)=$PIECE(%,"^",4)+INVCOST
- SET $PIECE(%,"^",5)=$PIECE(%,"^",5)+TOTCOST
- +21 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$PIECE(%,"^",3,5)
- +22 ; update beginning balance
- +23 IF '$DATA(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
- DO BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$EXTRACT(DT,1,5))
- +24 ; update whse invpt
- +25 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)-QTYPOST
- +26 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)-INVCOST
- +27 ; update average cost
- +28 SET $PIECE(ITEMDATA,"^",22)=0
- SET QUANTITY=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
- +29 IF QUANTITY>0
- SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
- IF $PIECE(ITEMDATA,"^",22)'>0
- SET $PIECE(ITEMDATA,"^",22)=0
- +30 SET ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
- +31 DO SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYPOST)
- +32 ; usage
- +33 DO ADDUSAG^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST,INVCOST)
- +34 ; transaction register
- +35 KILL PRCPWPL3,Y
- +36 SET PRCPWPL3("QTY")=-QTYPOST
- SET PRCPWPL3("INVVAL")=-INVCOST
- SET PRCPWPL3("SELVAL")=-TOTCOST
- SET PRCPWPL3("2237PO")=PRCPIBNM
- SET PRCPWPL3("REF")=PRCPORD
- SET PRCPWPL3("OTHERPT")=PRCPPRIM
- +37 IF $GET(CANTEEN)
- SET PRCPWPL3("REASON")="0:2:ISSUE to CANTEEN"
- +38 DO ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"R",PRCPWORD,.PRCPWPL3)
- +39 ; set line number in transaction register
- +40 IF $DATA(^PRCP(445.2,+$GET(Y),0))
- SET $PIECE(^(0),"^",24)=LINEDA
- +41 ;
- +42 ;
- +43 ; *** primary ***
- +44 IF 'PRCPFPRI
- QUIT
- +45 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
- +46 SET ITEMDATA=$GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
- IF ITEMDATA=""
- Begin DoDot:2
- +47 SET COSTCNTR=$PIECE($GET(^PRCP(445,PRCPPRIM,0)),"^",7)
- IF COSTCNTR
- DO COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
- End DoDot:2
- QUIT
- +48 SET QTYPOST=QTYPOST*$PIECE($$GETVEN^PRCPUVEN(PRCPPRIM,ITEMDA,PRCPPVNO,1),"^",4)
- +49 ; update beginning balance
- +50 IF '$DATA(^PRCP(445.1,PRCPPRIM,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
- DO BALANCE^PRCPUBAL(PRCPPRIM,ITEMDA,$EXTRACT(DT,1,5))
- +51 ; update primary invpt
- +52 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+QTYPOST
- +53 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+TOTCOST
- +54 ; update average cost
- +55 SET $PIECE(ITEMDATA,"^",22)=0
- SET QUANTITY=$PIECE(ITEMDATA,"^",7)
- +56 IF QUANTITY
- SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
- IF $PIECE(ITEMDATA,"^",22)'>0
- SET $PIECE(ITEMDATA,"^",22)=0
- +57 ; update last cost
- +58 SET $PIECE(ITEMDATA,"^",15)=$JUSTIFY(TOTCOST/QTYPOST,0,3)
- SET $PIECE(ITEMDATA,"^",3)=DT
- +59 SET ^PRCP(445,PRCPPRIM,1,ITEMDA,0)=ITEMDATA
- +60 ; remove due-in
- +61 DO OUTST^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA,-QTYPOST)
- +62 ; receipt history
- +63 DO RECEIPTS^PRCPUSAG(PRCPPRIM,ITEMDA,QTYPOST)
- +64 ; distribution costs
- +65 SET COSTCNTR=$PIECE(^PRCP(445,PRCPPRIM,0),"^",7)
- IF COSTCNTR
- DO COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
- +66 ; drug accountability
- +67 IF $GET(DRUGACCT)
- SET %=+$PIECE(ITEMDATA,"^",29)
- if '%
- SET %=1
- DO EN^PSAGIP(PRCPPRIM,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
- +68 ; transaction register
- +69 IF PRCPPORD
- Begin DoDot:2
- +70 KILL PRCPWPL3
- +71 SET PRCPWPL3("QTY")=QTYPOST
- SET (PRCPWPL3("INVVAL"),PRCPWPL3("SELVAL"))=TOTCOST
- SET PRCPWPL3("2237PO")=PRCPIBNM
- SET PRCPWPL3("REF")=PRCPORD
- SET PRCPWPL3("OTHERPT")=PRCPINPT
- +72 DO ADDTRAN^PRCPUTRX(PRCPPRIM,ITEMDA,"RC",PRCPPORD,.PRCPWPL3)
- End DoDot:2
- End DoDot:1
- +73 ;
- +74 DO ENDPOST^PRCPWPL5
- +75 QUIT