- PRCPPOL1 ;WISC/RFJ-receive purchase order (list manager) ; 6/18/01 1:21pm
- ;;5.1;IFCAP;**34**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- RECEIVE ; start receiving po into inventory point
- D FULL^VALM1
- S VALMBCK="R"
- N X
- I $G(PRCPFLAG) D Q
- . 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."
- . D DISPLAY^PRCPUX2(5,75,.X)
- . D R^PRCPUREP
- ;
- I $G(PRCPFCOS) D
- . 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."
- . S X(2)="If you continue receiving this purcase order, these items will NOT be received or costed to any inventory point."
- . D DISPLAY^PRCPUX2(5,75,.X)
- ;
- N %,DATA,DRUGACCT,ISMSFLAG,ITEMDA,ITEMDATA,LINEDA,ORDERNO,PONO,PRCPPOL1,QTYRECVE,QUANTITY,REFDA,TOTCOST,TRANDA,TRANID,Y
- 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)
- ;
- S XP="ARE YOU SURE YOU WANT TO RECEIVE THIS PURCHASE ORDER"
- W ! I $$YN^PRCPUYN(1)'=1 Q
- ;
- CHKFINAL ;This block of the code will check and flag any incomplete Partial
- ;receipt for selected Final PO. NOIS=LIT-0800-72295.
- G:'$D(^PRC(442,PRCPORDR,11,0)) OKFINAL
- N LOOPCNT,PARTMSG,PARTNUM,PARTCNT,NODATA
- S LOOPCNT=1,(CHKDATA,PARTMSG,PARTCNT,NODATA)=0
- S PARTNUM=""
- S PARTCNT=$P($G(^PRC(442,PRCPORDR,11,0)),"^",4)
- I PARTCNT'="" G:PARTCNT'=PRCPPART OKFINAL
- I (PARTCNT'=""),(PARTCNT>0) S PARTCNT=PARTCNT-1
- F LOOPCNT=1:1:PARTCNT D
- .S CHKDATA=$G(^PRC(442,PRCPORDR,11,LOOPCNT,0))
- .I CHKDATA="" S NODATA=1
- .I $P(CHKDATA,"^",16)="" S PARTMSG=1,PARTNUM=PARTNUM_LOOPCNT_","
- G:'PARTMSG OKFINAL
- I PARTMSG D Q
- . S WRD1="number: " S:$L(PARTNUM)>2 WRD1="numbers: "
- . S WRD2="is" S:$L(PARTNUM)>2 WRD2="are"
- . S PARTNUM=$E(PARTNUM,1,$L(PARTNUM)-1)
- . K X S X(1)=" WARNING: There is more than one partial pending receipt for this purchase order."
- . S X(2)="Please make sure that receipts are posted in sequence order to prevent any problem."
- . S X(3)="Partial "_WRD1_PARTNUM_" "_WRD2_" missing for this purchase order."
- . D DISPLAY^PRCPUX2(5,75,.X)
- . D R^PRCPUREP
- . K LOOPCNT,CHKDATA,PARTMSG,PARTNUM,NODATA,WRD1,WRD2
- ;
- OKFINAL ;
- L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0),R^PRCPUREP Q
- D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Purchase Order")
- ;
- S ORDERNO=$$ORDERNO^PRCPUTRX(PRCPINPT)
- S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPPOLMREC",LINEDA)) Q:'LINEDA S DATA=^(LINEDA) D
- . S ITEMDA=$P(DATA,"^"),QTYRECVE=$P(DATA,"^",2),TOTCOST=$P(DATA,"^",3),TRANDA=$P(DATA,"^",4)
- . 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
- . ;
- . ; for items stored in the inventory point
- . ; 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 inventory point
- . S ITEMDATA=^PRCP(445,PRCPINPT,1,ITEMDA,0)
- . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+QTYRECVE
- . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+TOTCOST
- . ; 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
- . ; update last cost in invpt
- . S $P(ITEMDATA,"^",15)=$J(TOTCOST/QTYRECVE,0,3),$P(ITEMDATA,"^",3)=DT
- . S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
- . ;
- . ; update last cost for supply whse vendor in IM file
- . 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))
- . ; update due-in
- . D OUTST^PRCPUTRA(PRCPINPT,ITEMDA,TRANDA,-QTYRECVE)
- . ; update receipt history
- . D RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYRECVE)
- . ; update drug accountability
- . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPINPT,ITEMDA,QTYRECVE*%,TRANDA,PRCPORDN,"RC"_ORDERNO,TOTCOST)
- . ; transaction register
- . I ORDERNO D
- . . K PRCPPOL1
- . . 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)
- . . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",ORDERNO,.PRCPPOL1)
- ;
- I $G(DRUGACCT) D EX^PSAGIP
- ; enter receiving information for partial
- 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
- ; clean up outstanding transactions
- I $P(^PRC(442,PRCPORDR,11,PRCPPART,0),"^",9)="F" D
- . 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)
- K X S X(1)="***** RECEIVING HAS BEEN POSTED *****" D DISPLAY^PRCPUX2(2,40,.X)
- D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
- L -^PRCP(445,PRCPINPT,1)
- K VALMBCK
- I PRCPTYPE'="W" D R^PRCPUREP Q
- ;
- ; create code sheets
- 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."
- D DISPLAY^PRCPUX2(2,75,.X)
- S PRCPFLAG=0,PONO=PRCPORDN,TRANID="RC"_ORDERNO
- S ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE")) I ISMSFLAG'=2 D DQ^PRCPSLOR
- I ISMSFLAG=2 D DQ^PRCPSMPR
- D R^PRCPUREP
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPPOL1 5915 printed Feb 18, 2025@23:40:48 Page 2
- PRCPPOL1 ;WISC/RFJ-receive purchase order (list manager) ; 6/18/01 1:21pm
- +1 ;;5.1;IFCAP;**34**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- RECEIVE ; start receiving po into inventory point
- +1 DO FULL^VALM1
- +2 SET VALMBCK="R"
- +3 NEW X
- +4 IF $GET(PRCPFLAG)
- Begin DoDot:1
- +5 KILL X
- SET 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."
- +6 DO DISPLAY^PRCPUX2(5,75,.X)
- +7 DO R^PRCPUREP
- End DoDot:1
- QUIT
- +8 ;
- +9 IF $GET(PRCPFCOS)
- Begin DoDot:1
- +10 KILL X
- SET 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."
- +11 SET X(2)="If you continue receiving this purcase order, these items will NOT be received or costed to any inventory point."
- +12 DO DISPLAY^PRCPUX2(5,75,.X)
- End DoDot:1
- +13 ;
- +14 NEW %,DATA,DRUGACCT,ISMSFLAG,ITEMDA,ITEMDATA,LINEDA,ORDERNO,PONO,PRCPPOL1,QTYRECVE,QUANTITY,REFDA,TOTCOST,TRANDA,TRANID,Y
- +15 IF PRCPTYPE="P"
- 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)
- +16 ;
- +17 SET XP="ARE YOU SURE YOU WANT TO RECEIVE THIS PURCHASE ORDER"
- +18 WRITE !
- IF $$YN^PRCPUYN(1)'=1
- QUIT
- +19 ;
- CHKFINAL ;This block of the code will check and flag any incomplete Partial
- +1 ;receipt for selected Final PO. NOIS=LIT-0800-72295.
- +2 if '$DATA(^PRC(442,PRCPORDR,11,0))
- GOTO OKFINAL
- +3 NEW LOOPCNT,PARTMSG,PARTNUM,PARTCNT,NODATA
- +4 SET LOOPCNT=1
- SET (CHKDATA,PARTMSG,PARTCNT,NODATA)=0
- +5 SET PARTNUM=""
- +6 SET PARTCNT=$PIECE($GET(^PRC(442,PRCPORDR,11,0)),"^",4)
- +7 IF PARTCNT'=""
- if PARTCNT'=PRCPPART
- GOTO OKFINAL
- +8 IF (PARTCNT'="")
- IF (PARTCNT>0)
- SET PARTCNT=PARTCNT-1
- +9 FOR LOOPCNT=1:1:PARTCNT
- Begin DoDot:1
- +10 SET CHKDATA=$GET(^PRC(442,PRCPORDR,11,LOOPCNT,0))
- +11 IF CHKDATA=""
- SET NODATA=1
- +12 IF $PIECE(CHKDATA,"^",16)=""
- SET PARTMSG=1
- SET PARTNUM=PARTNUM_LOOPCNT_","
- End DoDot:1
- +13 if 'PARTMSG
- GOTO OKFINAL
- +14 IF PARTMSG
- Begin DoDot:1
- +15 SET WRD1="number: "
- if $LENGTH(PARTNUM)>2
- SET WRD1="numbers: "
- +16 SET WRD2="is"
- if $LENGTH(PARTNUM)>2
- SET WRD2="are"
- +17 SET PARTNUM=$EXTRACT(PARTNUM,1,$LENGTH(PARTNUM)-1)
- +18 KILL X
- SET X(1)=" WARNING: There is more than one partial pending receipt for this purchase order."
- +19 SET X(2)="Please make sure that receipts are posted in sequence order to prevent any problem."
- +20 SET X(3)="Partial "_WRD1_PARTNUM_" "_WRD2_" missing for this purchase order."
- +21 DO DISPLAY^PRCPUX2(5,75,.X)
- +22 DO R^PRCPUREP
- +23 KILL LOOPCNT,CHKDATA,PARTMSG,PARTNUM,NODATA,WRD1,WRD2
- End DoDot:1
- QUIT
- +24 ;
- OKFINAL ;
- +1 LOCK +^PRCP(445,PRCPINPT,1):5
- IF '$TEST
- DO SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0)
- DO R^PRCPUREP
- QUIT
- +2 DO ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Purchase Order")
- +3 ;
- +4 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCPINPT)
- +5 SET LINEDA=0
- FOR
- SET LINEDA=$ORDER(^TMP($JOB,"PRCPPOLMREC",LINEDA))
- if 'LINEDA
- QUIT
- SET DATA=^(LINEDA)
- Begin DoDot:1
- +6 SET ITEMDA=$PIECE(DATA,"^")
- SET QTYRECVE=$PIECE(DATA,"^",2)
- SET TOTCOST=$PIECE(DATA,"^",3)
- SET TRANDA=$PIECE(DATA,"^",4)
- +7 IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- SET %=$GET(^TMP($JOB,"PRCPPOLMCOS",LINEDA))
- if $PIECE(%,"^",2)
- DO COSTCNTR^PRCPUCC($PIECE(%,"^",2),PRCPINPT,$PIECE(%,"^",3),TOTCOST)
- QUIT
- +8 ;
- +9 ; for items stored in the inventory point
- +10 ; update beginning balance
- +11 IF '$DATA(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
- DO BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$EXTRACT(DT,1,5))
- +12 ;
- +13 ; update inventory point
- +14 SET ITEMDATA=^PRCP(445,PRCPINPT,1,ITEMDA,0)
- +15 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+QTYRECVE
- +16 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+TOTCOST
- +17 ; update average cost
- +18 SET $PIECE(ITEMDATA,"^",22)=0
- SET QUANTITY=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
- +19 IF QUANTITY>0
- SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
- IF $PIECE(ITEMDATA,"^",22)'>0
- SET $PIECE(ITEMDATA,"^",22)=0
- +20 ; update last cost in invpt
- +21 SET $PIECE(ITEMDATA,"^",15)=$JUSTIFY(TOTCOST/QTYRECVE,0,3)
- SET $PIECE(ITEMDATA,"^",3)=DT
- +22 SET ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
- +23 ;
- +24 ; update last cost for supply whse vendor in IM file
- +25 IF PRCPTYPE="W"
- IF $DATA(^PRC(441,ITEMDA,2,+$ORDER(^PRC(440,"AC","S",0)),0))
- SET $PIECE(^(0),"^",2)=$SELECT($PIECE(ITEMDATA,"^",15)>$PIECE(ITEMDATA,"^",22):$PIECE(ITEMDATA,"^",15),1:$PIECE(ITEMDATA,"^",22))
- +26 ; update due-in
- +27 DO OUTST^PRCPUTRA(PRCPINPT,ITEMDA,TRANDA,-QTYRECVE)
- +28 ; update receipt history
- +29 DO RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYRECVE)
- +30 ; update drug accountability
- +31 IF $GET(DRUGACCT)
- SET %=+$PIECE(ITEMDATA,"^",29)
- if '%
- SET %=1
- DO EN^PSAGIP(PRCPINPT,ITEMDA,QTYRECVE*%,TRANDA,PRCPORDN,"RC"_ORDERNO,TOTCOST)
- +32 ; transaction register
- +33 IF ORDERNO
- Begin DoDot:2
- +34 KILL PRCPPOL1
- +35 SET PRCPPOL1("QTY")=QTYRECVE
- SET (PRCPPOL1("INVVAL"),PRCPPOL1("SELVAL"))=TOTCOST
- SET PRCPPOL1("PKG")=$PIECE(DATA,"^",5)
- SET PRCPPOL1("2237PO")=PRCPORDN
- SET PRCPPOL1("REF")=$EXTRACT($PIECE(PRCPORDN,"-",2))_$EXTRACT($PIECE(PRCPORDN,"-",2),3,6)
- +36 DO ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",ORDERNO,.PRCPPOL1)
- End DoDot:2
- End DoDot:1
- +37 ;
- +38 IF $GET(DRUGACCT)
- DO EX^PSAGIP
- +39 ; enter receiving information for partial
- +40 SET Y=""
- DO ENCODE^PRCHES2(PRCPORDR,PRCPPART,+DUZ,.Y)
- IF Y>0
- DO NOW^%DTC
- SET $PIECE(^PRC(442,PRCPORDR,11,PRCPPART,0),"^",17,18)=%_"^"_+DUZ
- +41 ; clean up outstanding transactions
- +42 IF $PIECE(^PRC(442,PRCPORDR,11,PRCPPART,0),"^",9)="F"
- Begin DoDot:1
- +43 SET REFDA=0
- FOR
- SET REFDA=$ORDER(^PRC(442,PRCPORDR,13,REFDA))
- if 'REFDA
- QUIT
- SET TRANDA=$PIECE(^(REFDA,0),"^")
- SET LINEDA=0
- FOR
- SET LINEDA=$ORDER(^PRCS(410,TRANDA,"IT",LINEDA))
- if 'LINEDA
- QUIT
- DO KILLTRAN^PRCPUTRA(PRCPINPT,+$PIECE(^(LINEDA,0),"^",5),TRANDA)
- End DoDot:1
- +44 KILL X
- SET X(1)="***** RECEIVING HAS BEEN POSTED *****"
- DO DISPLAY^PRCPUX2(2,40,.X)
- +45 DO CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
- +46 LOCK -^PRCP(445,PRCPINPT,1)
- +47 KILL VALMBCK
- +48 IF PRCPTYPE'="W"
- DO R^PRCPUREP
- QUIT
- +49 ;
- +50 ; create code sheets
- +51 KILL X
- SET 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."
- +52 DO DISPLAY^PRCPUX2(2,75,.X)
- +53 SET PRCPFLAG=0
- SET PONO=PRCPORDN
- SET TRANID="RC"_ORDERNO
- +54 SET ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
- IF ISMSFLAG'=2
- DO DQ^PRCPSLOR
- +55 IF ISMSFLAG=2
- DO DQ^PRCPSMPR
- +56 DO R^PRCPUREP
- +57 QUIT