PRCV442B ;WOIFO/CC-GET DATA WHEN ITEM DELETED, SET UP AUDIT FILE;1/29/05
V ;;5.1;IFCAP;**81,86**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
RRAUD(POIEN,PRCV,PRCVCR,PRCVDAT) ; add deleted Receiving Report to audit file
;
; POIEN = the ien of the purchase order from which the receiving
; report is being deleted.
; PRCV = the string of info about the item (from PRCV442A)
; DM DOC ID ^ Item ien ^ line item # ^ 2237 ien ^ UOP ^
; qty ordered ^ unit price ^ NIF ^ pkg mult ^ qty rec'd
; ^ total item cost ^ total discount ^ delivery date
; PRCVCR = the date/time the receiving report was created
; PRCVDAT = The date/time of deletion processing
;
N PRCVRA,PRCVRN,PRCVIEN,PRCVY
S PRCVID=$P(PRCV,"^",1) Q:PRCVID']"" ; DM DOC ID
S PRCVRN=$O(^PRCV(414.02,"B",PRCVID,0)) ; find DM DOC ID record
I +PRCVRN'>0 D MAIL("X1",POIEN,PRCVID,$P(PRCV,"^",2)) Q ; notify users that DM DOC ID record not in audit file
S PRCVIEN="+1,"_PRCVRN_","
S PRCVRA(414.021,PRCVIEN,.01)=PRCVDAT ; D/T RR deleted
S PRCVRA(414.021,PRCVIEN,1)=DUZ ; user deleting RR
S PRCVRA(414.021,PRCVIEN,2)=PRCVCR ; RR create D/T
S PRCVRA(414.021,PRCVIEN,3)=0-$P(PRCV,"^",10) ; Qty
S PRCVRA(414.021,PRCVIEN,4)=0-$P(PRCV,"^",11) ; total cost
S PRCVRA(414.021,PRCVIEN,5)=0-$P(PRCV,"^",12) ; discount
D UPDATE^DIE("","PRCVRA","PRCVY")
I $D(^TMP("DIERR",$J)) D MAIL("X5",POIEN,PRCVID,$P(PRCV,"^",2)) ; tell users that Audit file could not be updated
S $P(^TMP("PRCV442A",$J,POIEN),"^",7)=PRCVDAT
Q
;
DELAUD(PRCVID,PRCVDATE,PRCVDUZ,POIEN,PRCVITEM,PRCVIT) ; UPDATE AUDIT FILE FOR DELETED ITEMS
;
; PRCVID = the DM Doc ID of the item being deleted
; PRCVDATE = the date/time the item is deleted or PO is cancelled
; PRCVDUZ = the user deleting the item or canceling the PO
; POIEN = the ien of the purchase order from which the receiving
; report is being deleted.
; PRCVITEM = the item number
; PRCVIT = set to 1 if deleted at line item level, else PC cancel
;
N PRCVD,PRCVDA,PRCVIEN,PRCVY
S PRCVY="C" I PRCVIT=1 S PRCVY="D"
S PRCVDA=$O(^PRCV(414.02,"B",PRCVID,0)) ; find DM DOC ID record
I PRCVDA']"" D MAIL(PRCVY_1,POIEN,PRCVID,PRCVITEM) Q ; DM DOC ID not in audit file
S PRCVD(414.02,PRCVDA_",",8)=PRCVDATE
S PRCVD(414.02,PRCVDA_",",9)=PRCVDUZ
D UPDATE^DIE("","PRCVD")
I $D(^TMP("DIERR",$J)) D MAIL(PRCVY_5,POIEN,PRCVID,PRCVITEM) ; tell user audit file not updated
Q
;
;
DELITEM(POIEN) ; delete line item, get key info for DYNAMED
; called from "AK" cross ref in DD - .01 of file 442.01 (Item multiple)
;
; POIEN = the ien of the purchase order (file 442)
;
N PRCV,PRCVP
S PRCVP=""
D OP^XQCHK I $P(XQOPT,"^",1)="PRCHPC PO REMOVE 2237" Q ; this option does not cancel item out of IFCAP
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 Q ; DM interface not active
D GETS^DIQ(442,POIEN_",",".01;.02;.07;5;7;62","IE","PRCVP") ; get PO data
S $P(PRCV,"^",7)=POIEN,POIEN=POIEN_","
I $D(^TMP("DIERR",$J)) G DELITEM1 ; PO data not on file,send to DM anyway
S $P(PRCV,"^",8)=PRCVP(442,POIEN,.02,"I") ; MOP (#.02 - n0,p2)
S $P(PRCV,"^",1)=PRCVP(442,POIEN,.01,"E") ; PO# (#.01 n0,p1)
S $P(PRCV,"^",4)=PRCVP(442,POIEN,5,"I") ; vendor IEN (#5 n1 p1)
S $P(PRCV,"^",5)=PRCVP(442,POIEN,62,"E") ; for PC orders MOP=25, 2237 is in #62 N23,P23
S $P(PRCV,"^",6)=PRCVP(442,POIEN,.07,"E") ; for inv/rec MOP=1, 2237 is in #.07 - n0,p12
S $P(PRCV,"^",2)=PRCVP(442,POIEN,7,"I") ; delivery date (#7 n0p10)
DELITEM1 S $P(PRCV,"^",10)=$$NOW^XLFDT
S $P(PRCV,"^",11)=DA
;
; get DUZ
S $P(PRCV,"^",3)=DUZ
;
; X1 is the array of variables set in the execution of the 'AK' cross reference
S X1(999999)=PRCV ; save PO data to variables passed to background job
;
D OPKG^XUHUI("","PRCV 442 ITEM DELETE","K","AK") ; invoke background job
K X1(999999) ; not to go back DD
Q
;
DELJOB ; send deleted item's info to DynaMed (collected by DELITEM subroutine)
; called from protocol PRCV 442 ITEM DELETE and jobbed by TaskMan
; builds
; PRCVI (string for each item)
; DM DOC ID ^ Item ien ^ line item # ^ 2237 ien ^ UOP ^ qty ordered
; ^ unit price ^ NIF ^ pkg mult ^ qty rec'd ^ total item cost ^
; total discount ^ delivery date
; PRCV (header) variable -
; PO# ^ txn type ^ DUZ ^ vendor IEN ^ FMS vendor # ^Alt add ind ^
; txn D/T ^ Station# ^ Purchasing Station
;
N POIEN,PRCV,PRCVERR,PRCVI,PRCVP,PRCVV,PRCV2237
; QUIT IF mop'1 AND '=25
S PRCVP=XUHUIX1(999999) I $P(PRCVP,"^",8)'=1,$P(PRCVP,"^",8)'=25 Q
S POIEN=$P(PRCVP,"^",7)
K ^TMP("PRCV442A",$J,POIEN)
S PRCV=$P(PRCVP,"^",1,4),$P(PRCV,"^",7)=$P(PRCVP,"^",10)
; get FMS vendor ID & alt addr code from file 440, #34# - n3 p4&5
I $P(PRCV,"^",4)]"" D GETS^DIQ(440,$P(PRCV,"^",4)_",","34:35","E","PRCVV")
I $D(^TMP("DIERR",$J)) G DELJOB1 ; vendor data not on file
S $P(PRCV,"^",2)=5 ; DELETE
S $P(PRCV,"^",5)=PRCVV(440,$P(PRCV,"^",4)_",",34,"E") ; FMS vendor ID
S $P(PRCV,"^",6)=PRCVV(440,$P(PRCV,"^",4)_",",35,"E") ; FMA alt add ind
; get Station Number
DELJOB1 S $P(PRCV,"^",8)=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S ^TMP("PRCV442A",$J,POIEN)=PRCV
S PRCVI=XUHUIX1(2)_"^"_XUHUIX1(3)_"^"_XUHUIX1(1)_"^^^"_XUHUIX1(4)_"^"_XUHUIX1(7)_"^^"_XUHUIX1(6)
S $P(PRCVI,"^",5)=$$GET1^DIQ(420.5,XUHUIX1(5),.01,"E") ; UOP
S $P(PRCVI,"^",8)=$$GET1^DIQ(441,XUHUIX1(3),51) ; NIF
S $P(PRCVI,"^",13)=$P(PRCVP,"^",2) ; DELIVERY DATE FOR PO
S PRCV2237=XUHUIX1(8)
I PRCV2237]"" S PRCV2237=$$GET1^DIQ(410,PRCV2237,.01,"E")
I PRCV2237']"" S PRCV2237=$P(PRCVP,"^",6)
I PRCV2237']"" S PRCV2237=$P(PRCVP,"^",5)
S $P(PRCVI,"^",4)=PRCV2237
D DELAUD($P(PRCVI,"^",1),$P(PRCV,"^",7),$P(PRCV,"^",3),POIEN,$P(PRCVI,"^",2),1)
S ^TMP("PRCV442A",$J,POIEN,$P(PRCVP,"^",11))=PRCVI
I $O(^TMP("PRCV442A",$J,POIEN,""))']"" S PRCVERR=1 D Q Q ; no DynaMed items
D EN^PRCVPOSD(POIEN)
Q
;
MAIL(PRCVCODE,PRCVPIEN,PRCVID,PRCVITEM) ; PREPARE VALUES FOR MESSAGE TO USERS
;
; $E(PRCVCODE,1) = U if the error occurred approving a PO
; = C if the error occurred canceling a PO
; = D if error occurred while deleting a line item
; = R if the error occurred signing a Receipt Report
; = X if the error occurred deleting a Receipt Report
; $E(PRCVCODE,2) = DM Doc ID not in Audit File
; = 2 if the PO data could not be found
; = 3 if the item data could not be found
; = 4 if the receiving report info for item was not found
; = 5 if data could not be saved in audit file
;
; PRCVPIEN IEN of selected purchase order
; PRCVID DM Doc ID of affected item
; PRCVITEM ien of item (item#)
;
N PRCVSITE,PRCVFCP,PRCVPO,XMB
K ^TMP($J,"PRCV442B")
S XMB(1)=$S($E(PRCVCODE,1)="C":"cancelling a PC order",$E(PRCVCODE,1)="D":"deleting a line item from a purchase order",1:"deleting a receiving report")
S XMB(2)=PRCVID
S XMB(3)=" "_PRCVID_" is not in file 414.02 - can't add related data"
I $E(PRCVCODE,2)=5 D
. S XMB(3)="System can't update Audit File (414.02) for "_PRCVID
. D TMPERR
S PRCVPO=$P($G(^PRC(442,PRCVPIEN,0)),"^",1)
S ^TMP($J,"PRCV442B",1)="Purchase Order# "_PRCVPO
S ^TMP($J,"PRCV442B",2)="ITEM# "_PRCVITEM
S ^TMP($J,"PRCV442B")=2
S PRCVSITE=PRCVPO+0 I PRCVSITE=0 S PRCVSITE=PRC("SITE")
S PRCVFCP=$P($G(^PRC(442,PRCVPIEN,0)),"^",3)
S PRCVFCP=$P(PRCVFCP," ",1)
D DMERXMB^PRCVLIC("PRCV442B",PRCVSITE,PRCVFCP)
K ^TMP($J,"PRCV442B")
Q
;
TMPERR ;
;
;
N PRCJ,PRCK S PRCK=$G(^TMP($J,"PRCV442B")),PRCJ=0
F S PRCJ=$O(^TMP("DIERR",$J,PRCJ)) Q:PRCJ'?1.N D
. I $D(^TMP("DIERR",$J,PRCJ,"TEXT",1)) D
. . S PRCK=PRCK+1,^TMP($J,"PRCV442B",PRCK)="Reason: "_^TMP("DIERR",$J,PRCJ,"TEXT",1)
. . S:$D(^TMP("DIERR",$J,PRCJ,"PARAM","IENS")) ^TMP($J,"PRCV442B",PRCK)=$E(^TMP($J,"PRCV442B",PRCK),1,220)_"-IENS: "_^TMP("DIERR",$J,PRCJ,"PARAM","IENS")
S:PRCK>0 ^TMP($J,"PRCV442B")=PRCK
K ^TMP("DIERR",$J)
Q
;
FCP(PRCVPO) ; return FCP for PO#
;
; PRCVPO = the external purchase order number
; returns -1 if the PO or its FCP cannot be found
;
N PRCVF,PRCVI
S PRCVF=-1
S PRCVI=$O(^PRC(442,"B",PRCVPO,0))
I PRCVI]"" D
. S PRCVI=$$GET1^DIQ(442,PRCVI_",",1,"E")
. I PRCVI]"" S PRCVF=$P(PRCVI," ",1)
Q PRCVF
;
Q I PRCVERR K ^TMP("PRCV442A",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCV442B 8475 printed Apr 09, 2024@21:00:32 Page 2
PRCV442B ;WOIFO/CC-GET DATA WHEN ITEM DELETED, SET UP AUDIT FILE;1/29/05
V ;;5.1;IFCAP;**81,86**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
RRAUD(POIEN,PRCV,PRCVCR,PRCVDAT) ; add deleted Receiving Report to audit file
+1 ;
+2 ; POIEN = the ien of the purchase order from which the receiving
+3 ; report is being deleted.
+4 ; PRCV = the string of info about the item (from PRCV442A)
+5 ; DM DOC ID ^ Item ien ^ line item # ^ 2237 ien ^ UOP ^
+6 ; qty ordered ^ unit price ^ NIF ^ pkg mult ^ qty rec'd
+7 ; ^ total item cost ^ total discount ^ delivery date
+8 ; PRCVCR = the date/time the receiving report was created
+9 ; PRCVDAT = The date/time of deletion processing
+10 ;
+11 NEW PRCVRA,PRCVRN,PRCVIEN,PRCVY
+12 ; DM DOC ID
SET PRCVID=$PIECE(PRCV,"^",1)
if PRCVID']""
QUIT
+13 ; find DM DOC ID record
SET PRCVRN=$ORDER(^PRCV(414.02,"B",PRCVID,0))
+14 ; notify users that DM DOC ID record not in audit file
IF +PRCVRN'>0
DO MAIL("X1",POIEN,PRCVID,$PIECE(PRCV,"^",2))
QUIT
+15 SET PRCVIEN="+1,"_PRCVRN_","
+16 ; D/T RR deleted
SET PRCVRA(414.021,PRCVIEN,.01)=PRCVDAT
+17 ; user deleting RR
SET PRCVRA(414.021,PRCVIEN,1)=DUZ
+18 ; RR create D/T
SET PRCVRA(414.021,PRCVIEN,2)=PRCVCR
+19 ; Qty
SET PRCVRA(414.021,PRCVIEN,3)=0-$PIECE(PRCV,"^",10)
+20 ; total cost
SET PRCVRA(414.021,PRCVIEN,4)=0-$PIECE(PRCV,"^",11)
+21 ; discount
SET PRCVRA(414.021,PRCVIEN,5)=0-$PIECE(PRCV,"^",12)
+22 DO UPDATE^DIE("","PRCVRA","PRCVY")
+23 ; tell users that Audit file could not be updated
IF $DATA(^TMP("DIERR",$JOB))
DO MAIL("X5",POIEN,PRCVID,$PIECE(PRCV,"^",2))
+24 SET $PIECE(^TMP("PRCV442A",$JOB,POIEN),"^",7)=PRCVDAT
+25 QUIT
+26 ;
DELAUD(PRCVID,PRCVDATE,PRCVDUZ,POIEN,PRCVITEM,PRCVIT) ; UPDATE AUDIT FILE FOR DELETED ITEMS
+1 ;
+2 ; PRCVID = the DM Doc ID of the item being deleted
+3 ; PRCVDATE = the date/time the item is deleted or PO is cancelled
+4 ; PRCVDUZ = the user deleting the item or canceling the PO
+5 ; POIEN = the ien of the purchase order from which the receiving
+6 ; report is being deleted.
+7 ; PRCVITEM = the item number
+8 ; PRCVIT = set to 1 if deleted at line item level, else PC cancel
+9 ;
+10 NEW PRCVD,PRCVDA,PRCVIEN,PRCVY
+11 SET PRCVY="C"
IF PRCVIT=1
SET PRCVY="D"
+12 ; find DM DOC ID record
SET PRCVDA=$ORDER(^PRCV(414.02,"B",PRCVID,0))
+13 ; DM DOC ID not in audit file
IF PRCVDA']""
DO MAIL(PRCVY_1,POIEN,PRCVID,PRCVITEM)
QUIT
+14 SET PRCVD(414.02,PRCVDA_",",8)=PRCVDATE
+15 SET PRCVD(414.02,PRCVDA_",",9)=PRCVDUZ
+16 DO UPDATE^DIE("","PRCVD")
+17 ; tell user audit file not updated
IF $DATA(^TMP("DIERR",$JOB))
DO MAIL(PRCVY_5,POIEN,PRCVID,PRCVITEM)
+18 QUIT
+19 ;
+20 ;
DELITEM(POIEN) ; delete line item, get key info for DYNAMED
+1 ; called from "AK" cross ref in DD - .01 of file 442.01 (Item multiple)
+2 ;
+3 ; POIEN = the ien of the purchase order (file 442)
+4 ;
+5 NEW PRCV,PRCVP
+6 SET PRCVP=""
+7 ; this option does not cancel item out of IFCAP
DO OP^XQCHK
IF $PIECE(XQOPT,"^",1)="PRCHPC PO REMOVE 2237"
QUIT
+8 ; DM interface not active
IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
QUIT
+9 ; get PO data
DO GETS^DIQ(442,POIEN_",",".01;.02;.07;5;7;62","IE","PRCVP")
+10 SET $PIECE(PRCV,"^",7)=POIEN
SET POIEN=POIEN_","
+11 ; PO data not on file,send to DM anyway
IF $DATA(^TMP("DIERR",$JOB))
GOTO DELITEM1
+12 ; MOP (#.02 - n0,p2)
SET $PIECE(PRCV,"^",8)=PRCVP(442,POIEN,.02,"I")
+13 ; PO# (#.01 n0,p1)
SET $PIECE(PRCV,"^",1)=PRCVP(442,POIEN,.01,"E")
+14 ; vendor IEN (#5 n1 p1)
SET $PIECE(PRCV,"^",4)=PRCVP(442,POIEN,5,"I")
+15 ; for PC orders MOP=25, 2237 is in #62 N23,P23
SET $PIECE(PRCV,"^",5)=PRCVP(442,POIEN,62,"E")
+16 ; for inv/rec MOP=1, 2237 is in #.07 - n0,p12
SET $PIECE(PRCV,"^",6)=PRCVP(442,POIEN,.07,"E")
+17 ; delivery date (#7 n0p10)
SET $PIECE(PRCV,"^",2)=PRCVP(442,POIEN,7,"I")
DELITEM1 SET $PIECE(PRCV,"^",10)=$$NOW^XLFDT
+1 SET $PIECE(PRCV,"^",11)=DA
+2 ;
+3 ; get DUZ
+4 SET $PIECE(PRCV,"^",3)=DUZ
+5 ;
+6 ; X1 is the array of variables set in the execution of the 'AK' cross reference
+7 ; save PO data to variables passed to background job
SET X1(999999)=PRCV
+8 ;
+9 ; invoke background job
DO OPKG^XUHUI("","PRCV 442 ITEM DELETE","K","AK")
+10 ; not to go back DD
KILL X1(999999)
+11 QUIT
+12 ;
DELJOB ; send deleted item's info to DynaMed (collected by DELITEM subroutine)
+1 ; called from protocol PRCV 442 ITEM DELETE and jobbed by TaskMan
+2 ; builds
+3 ; PRCVI (string for each item)
+4 ; DM DOC ID ^ Item ien ^ line item # ^ 2237 ien ^ UOP ^ qty ordered
+5 ; ^ unit price ^ NIF ^ pkg mult ^ qty rec'd ^ total item cost ^
+6 ; total discount ^ delivery date
+7 ; PRCV (header) variable -
+8 ; PO# ^ txn type ^ DUZ ^ vendor IEN ^ FMS vendor # ^Alt add ind ^
+9 ; txn D/T ^ Station# ^ Purchasing Station
+10 ;
+11 NEW POIEN,PRCV,PRCVERR,PRCVI,PRCVP,PRCVV,PRCV2237
+12 ; QUIT IF mop'1 AND '=25
+13 SET PRCVP=XUHUIX1(999999)
IF $PIECE(PRCVP,"^",8)'=1
IF $PIECE(PRCVP,"^",8)'=25
QUIT
+14 SET POIEN=$PIECE(PRCVP,"^",7)
+15 KILL ^TMP("PRCV442A",$JOB,POIEN)
+16 SET PRCV=$PIECE(PRCVP,"^",1,4)
SET $PIECE(PRCV,"^",7)=$PIECE(PRCVP,"^",10)
+17 ; get FMS vendor ID & alt addr code from file 440, #34# - n3 p4&5
+18 IF $PIECE(PRCV,"^",4)]""
DO GETS^DIQ(440,$PIECE(PRCV,"^",4)_",","34:35","E","PRCVV")
+19 ; vendor data not on file
IF $DATA(^TMP("DIERR",$JOB))
GOTO DELJOB1
+20 ; DELETE
SET $PIECE(PRCV,"^",2)=5
+21 ; FMS vendor ID
SET $PIECE(PRCV,"^",5)=PRCVV(440,$PIECE(PRCV,"^",4)_",",34,"E")
+22 ; FMA alt add ind
SET $PIECE(PRCV,"^",6)=PRCVV(440,$PIECE(PRCV,"^",4)_",",35,"E")
+23 ; get Station Number
DELJOB1 SET $PIECE(PRCV,"^",8)=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+1 SET ^TMP("PRCV442A",$JOB,POIEN)=PRCV
+2 SET PRCVI=XUHUIX1(2)_"^"_XUHUIX1(3)_"^"_XUHUIX1(1)_"^^^"_XUHUIX1(4)_"^"_XUHUIX1(7)_"^^"_XUHUIX1(6)
+3 ; UOP
SET $PIECE(PRCVI,"^",5)=$$GET1^DIQ(420.5,XUHUIX1(5),.01,"E")
+4 ; NIF
SET $PIECE(PRCVI,"^",8)=$$GET1^DIQ(441,XUHUIX1(3),51)
+5 ; DELIVERY DATE FOR PO
SET $PIECE(PRCVI,"^",13)=$PIECE(PRCVP,"^",2)
+6 SET PRCV2237=XUHUIX1(8)
+7 IF PRCV2237]""
SET PRCV2237=$$GET1^DIQ(410,PRCV2237,.01,"E")
+8 IF PRCV2237']""
SET PRCV2237=$PIECE(PRCVP,"^",6)
+9 IF PRCV2237']""
SET PRCV2237=$PIECE(PRCVP,"^",5)
+10 SET $PIECE(PRCVI,"^",4)=PRCV2237
+11 DO DELAUD($PIECE(PRCVI,"^",1),$PIECE(PRCV,"^",7),$PIECE(PRCV,"^",3),POIEN,$PIECE(PRCVI,"^",2),1)
+12 SET ^TMP("PRCV442A",$JOB,POIEN,$PIECE(PRCVP,"^",11))=PRCVI
+13 ; no DynaMed items
IF $ORDER(^TMP("PRCV442A",$JOB,POIEN,""))']""
SET PRCVERR=1
DO Q
QUIT
+14 DO EN^PRCVPOSD(POIEN)
+15 QUIT
+16 ;
MAIL(PRCVCODE,PRCVPIEN,PRCVID,PRCVITEM) ; PREPARE VALUES FOR MESSAGE TO USERS
+1 ;
+2 ; $E(PRCVCODE,1) = U if the error occurred approving a PO
+3 ; = C if the error occurred canceling a PO
+4 ; = D if error occurred while deleting a line item
+5 ; = R if the error occurred signing a Receipt Report
+6 ; = X if the error occurred deleting a Receipt Report
+7 ; $E(PRCVCODE,2) = DM Doc ID not in Audit File
+8 ; = 2 if the PO data could not be found
+9 ; = 3 if the item data could not be found
+10 ; = 4 if the receiving report info for item was not found
+11 ; = 5 if data could not be saved in audit file
+12 ;
+13 ; PRCVPIEN IEN of selected purchase order
+14 ; PRCVID DM Doc ID of affected item
+15 ; PRCVITEM ien of item (item#)
+16 ;
+17 NEW PRCVSITE,PRCVFCP,PRCVPO,XMB
+18 KILL ^TMP($JOB,"PRCV442B")
+19 SET XMB(1)=$SELECT($EXTRACT(PRCVCODE,1)="C":"cancelling a PC order",$EXTRACT(PRCVCODE,1)="D":"deleting a line item from a purchase order",1:"deleting a receiving report")
+20 SET XMB(2)=PRCVID
+21 SET XMB(3)=" "_PRCVID_" is not in file 414.02 - can't add related data"
+22 IF $EXTRACT(PRCVCODE,2)=5
Begin DoDot:1
+23 SET XMB(3)="System can't update Audit File (414.02) for "_PRCVID
+24 DO TMPERR
End DoDot:1
+25 SET PRCVPO=$PIECE($GET(^PRC(442,PRCVPIEN,0)),"^",1)
+26 SET ^TMP($JOB,"PRCV442B",1)="Purchase Order# "_PRCVPO
+27 SET ^TMP($JOB,"PRCV442B",2)="ITEM# "_PRCVITEM
+28 SET ^TMP($JOB,"PRCV442B")=2
+29 SET PRCVSITE=PRCVPO+0
IF PRCVSITE=0
SET PRCVSITE=PRC("SITE")
+30 SET PRCVFCP=$PIECE($GET(^PRC(442,PRCVPIEN,0)),"^",3)
+31 SET PRCVFCP=$PIECE(PRCVFCP," ",1)
+32 DO DMERXMB^PRCVLIC("PRCV442B",PRCVSITE,PRCVFCP)
+33 KILL ^TMP($JOB,"PRCV442B")
+34 QUIT
+35 ;
TMPERR ;
+1 ;
+2 ;
+3 NEW PRCJ,PRCK
SET PRCK=$GET(^TMP($JOB,"PRCV442B"))
SET PRCJ=0
+4 FOR
SET PRCJ=$ORDER(^TMP("DIERR",$JOB,PRCJ))
if PRCJ'?1.N
QUIT
Begin DoDot:1
+5 IF $DATA(^TMP("DIERR",$JOB,PRCJ,"TEXT",1))
Begin DoDot:2
+6 SET PRCK=PRCK+1
SET ^TMP($JOB,"PRCV442B",PRCK)="Reason: "_^TMP("DIERR",$JOB,PRCJ,"TEXT",1)
+7 if $DATA(^TMP("DIERR",$JOB,PRCJ,"PARAM","IENS"))
SET ^TMP($JOB,"PRCV442B",PRCK)=$EXTRACT(^TMP($JOB,"PRCV442B",PRCK),1,220)_"-IENS: "_^TMP("DIERR",$JOB,PRCJ,"PARAM","IENS")
End DoDot:2
End DoDot:1
+8 if PRCK>0
SET ^TMP($JOB,"PRCV442B")=PRCK
+9 KILL ^TMP("DIERR",$JOB)
+10 QUIT
+11 ;
FCP(PRCVPO) ; return FCP for PO#
+1 ;
+2 ; PRCVPO = the external purchase order number
+3 ; returns -1 if the PO or its FCP cannot be found
+4 ;
+5 NEW PRCVF,PRCVI
+6 SET PRCVF=-1
+7 SET PRCVI=$ORDER(^PRC(442,"B",PRCVPO,0))
+8 IF PRCVI]""
Begin DoDot:1
+9 SET PRCVI=$$GET1^DIQ(442,PRCVI_",",1,"E")
+10 IF PRCVI]""
SET PRCVF=$PIECE(PRCVI," ",1)
End DoDot:1
+11 QUIT PRCVF
+12 ;
Q IF PRCVERR
KILL ^TMP("PRCV442A",$JOB)
+1 QUIT
