PRCHQ15 ;(WASH IRMFO)/LKG-Create Initial #442 entry from 2237 ;9/30/96 14:59
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
POBLD(PRCHSY,PRCRFQDA,PRCQUOTE,PRCFOB) ;Given 2237 IEN build its PO
N PRC410,PRCCOUNT,PRC,DIE,DR,PRCDSCNT,PRCHPO,PRCHSP,PRCHSX,PRCI,PRCIEN
N PRCLN,PRCX,PRCY,PRCZ,X,Y,PRCDA410,PRCHHM,PRCHPONO,PRCCOST,PRCH,PRCHN,PRCHS
N PRCHCC,PRCHITM,PRCHZ,PRCHZ1,PRCHZ2,PRCHZ3
G:'$D(^PRCS(410,PRCHSY)) EX
S PRC410(0)=$G(^PRCS(410,PRCHSY,0)) G:PRC410(0)="" EX
S PRC("SITE")=$P(PRC410(0),U,5)
I '$D(PRC("PER")) D
. I $D(DUZ)#2,+DUZ>0 S PRC("PER")=+DUZ
. S X=$S('$D(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
. S $P(PRC("PER"),U,2,4)=$P(X,U,2)_U_$P(X,U,3)_U_$S($D(^VA(200,+PRC("PER"),.13)):$P(^(.13),U,2),1:"")
S:PRC("SITE")]"" PRC("PARAM")=$G(^PRC(411,PRC("SITE"),0))
S PRCHSX=$P(PRC410(0),U),PRC("FY")=$P(PRCHSX,"-",2),PRC("QTR")=$P(PRCHSX,"-",3)
S PRCI=0
GETNUM D ENPO^PRCHUTL
I '$D(PRCHPO) D G GETNUM:Y=1,EX
. N DIR S DIR(0)="YA",DIR("A")="No PO Number was entered, do you want to try again? "
. S DIR("B")="YES",DIR("?")="Answer 'YES' to return to prompt for PO Number"
. D ^DIR
S PRCI=PRCI+1
L +^PRC(442,DA):5 E W !,"Another user is editing this entry!" K DA G:PRCI<10 GETNUM W !,"Lock Table Problem - Please contact IRM!" S PRCHPO="" G EX
S DIE=442,DA=PRCHPO,DR="42///^S X=$P(^PRC(444,PRCRFQDA,0),U)"
N PONUM S PONUM=$P($P($G(^PRC(442,PRCHPO,0)),"^"),"-",2)
D ^DIE
;If an order is Certified then INV Address should be FISCAL,
;otherwise it will be FMS. <<<< nois DUB-0597-31814 <<<<
I $E(PONUM,1)'="C" D
. S DR=".02////1;.08////N;.04///FMS;.1///TODAY" D ^DIE
. Q
I $E(PONUM,1)="C" D
. S DR=".02////2;.08////N;.04///FISCAL;.1///TODAY" D ^DIE
. Q
S PRCY=$P(PRC410(0),U,10) I PRCY]"" S DR="31////^S X=PRCY" D ^DIE
S PRCY=$P($G(^PRCS(410,PRCHSY,3)),U,4) I PRCY]"" S DR="5////^S X=PRCY" D ^DIE
S X=$P(^PRCS(410,PRCHSY,3),U),$P(^PRC(442,PRCHPO,0),U,3)=X,^PRC(442,"E",$P(X," "),PRCHPO)="",PRC("CP")=X
S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11)
S $P(^PRC(442,PRCHPO,0),U,4)=PRC("APP")
S PRCY=$P($G(^PRC(420,PRC("SITE"),1,$P(PRCHSX,"-",4),0)),U,12)
I PRCY]"" S DR=".03////^S X=PRCY" D ^DIE
S PRCHN("MP")=$S($D(^PRCD(442.5,+$P(^PRC(442,DA,0),U,2),0)):$P(^(0),U,3),1:"")
S PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19)
D EN2^PRCHNPO3
S PRCY=$P($G(^PRCS(410,PRCHSY,3)),U,3) I PRCY]"" S DR="2///^S X=PRCY" D ^DIE
S PRCY=$P($G(^PRCS(410,PRCHSY,3)),U,5) I PRCY]"" S DR="5.2////^S X=PRCY" D ^DIE
S PRCY=$P($G(^PRC(444,PRCRFQDA,1)),U,3) I PRCY]"" S DR="5.4////^S X=PRCY" D ^DIE
S PRCY=$P($G(^PRCS(410,PRCHSY,9)),U) I PRCY]"" S DR="5.6///^S X=PRCY" D ^DIE
S DR="6.4////^S X=PRCFOB" D ^DIE
S PRCY=$P($G(^PRCS(410,PRCHSY,1)),U,4) I PRCY]"" S DR="7////^S X=PRCY" D ^DIE
S PRCY=$P($G(^PRCS(410,PRCHSY,9)),U,4) I PRCY>0 S $P(^PRC(442,PRCHPO,0),U,13)=PRCY
S DR="16////^S X=DUZ" D ^DIE
S DR="26///^S X=PRC(""BBFY"")" D ^DIE
S PRCHSY(0)=^PRC(443,PRCHSY,0)
S PRCHS="" D ^PRCHSP1
S PRCHSP="",PRCH="",PRCDA410=PRCHSY D LST1^PRCHNPO2 S PRCHSY=PRCDA410 K PRCHSY(0)
S PRCX=0,PRCCOUNT=0
F S PRCX=$O(^PRC(442,PRCHPO,2,PRCX)) Q:+PRCX'=PRCX S PRCCOUNT=PRCCOUNT+1
S PRCIEN=0
F S PRCIEN=$O(^PRCS(410,PRCHSY,"IT",PRCIEN)) Q:+PRCIEN'=PRCIEN D
. S PRCZ=^PRCS(410,PRCHSY,"IT",PRCIEN,0)
. S PRCX=$P(PRCZ,U,3) S:PRCX]"" $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,3)=PRCX
. S PRCX=$P(PRCZ,U,6) S:PRCX]"" $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,6)=PRCX
. I $P($G(^PRCS(410,PRCHSY,"IT",PRCIEN,1,0)),U,4)>0 D
. . N IENS S IENS=PRCIEN_","_PRCHPO_"," K ^TMP("DIERR",$J)
. . D WP^DIE(442.01,IENS,1,"","^PRCS(410,PRCHSY,""IT"",PRCIEN,1)")
. . K ^TMP("DIERR",$J)
. S PRCX=0
. F S PRCX=$O(^PRC(444,"AE",PRCHSY,PRCRFQDA,PRCX)) Q:PRCX="" Q:$P($G(^PRC(444,PRCRFQDA,2,PRCX,3)),U,7)=PRCIEN
. Q:PRCX=""
. S PRCLN=$P($G(^PRC(444,PRCRFQDA,2,PRCX,0)),U)
. S PRCY=$O(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,"B",PRCLN,"")) Q:PRCY=""
. S $P(^PRC(442,PRCHPO,2,PRCIEN,2),U,14)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,11)
. S $P(^PRC(442,PRCHPO,2,PRCIEN,4),U,17)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U)
. S $P(^PRC(442,PRCHPO,2,PRCIEN,4),U,18)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,2)
. S:$P($G(^PRC(442,PRCHPO,2,PRCIEN,0)),U,13)="" $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,13)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,6)
. S:$P($G(^PRC(442,PRCHPO,2,PRCIEN,2)),U,3)="" $P(^PRC(442,PRCHPO,2,PRCIEN,2),U,3)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,5)
. S X=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,6)
. S:X="" X=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,0)),U,7)
. I X]"" D
. . S Y=$P($G(^PRC(442,PRCHPO,1)),U) I Y="" K X Q
. . I '$D(^PRC(440,Y,4,"B",$E(X,1,30))) K X Q
. . S $P(^PRC(442,PRCHPO,2,PRCIEN,2),U,2)=X
. . S ^PRC(442,PRCHPO,2,"AC",$E(X,1,30),PRCIEN)=""
. S PRCCOST=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,3,5)
. S PRCDSCNT=$P(PRCCOST,U,2,3),PRCCOST=$FN($P(PRCCOST,U),"",4)
. S $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,9)=PRCCOST
. S $P(^PRC(442,PRCHPO,2,PRCIEN,2),U)=$FN(PRCCOST*$P(^PRC(442,PRCHPO,2,PRCIEN,0),U,2),"",4)
. I $P(PRCDSCNT,U)'>0,$P(PRCDSCNT,U,2)'>0 Q
. K DA,DIC,DD,DO S DA(1)=PRCHPO,DIC="^PRC(442,DA(1),3,",X=PRCIEN,DIC(0)="LX"
. S DLAYGO=442.03,DIC("P")=$P(^DD(442,14,0),U,2) D FILE^DICN K DIC,DLAYGO
. Q:+Y<1 S DA=+Y
. S PRCX=$S($P(PRCDSCNT,U)>0:$P(PRCDSCNT,U),1:"$"_$P(PRCDSCNT,U,2))
. S DIE="^PRC(442,DA(1),3,",DR="1////^S X=PRCX" D ^DIE
. S PRCZ=$G(^PRCS(410,PRCHSY,"IT",PRCIEN,0))
. S PRCX=$S($P(PRCDSCNT,U)>0:PRCDSCNT/100*$P(PRCZ,U,2)*$P(PRCZ,U,7),1:$P(PRCDSCNT,U,2))
. S PRCX=$FN(PRCX,"",2),$P(^PRC(442,PRCHPO,2,PRCIEN,2),U,6)=PRCX
. S DR="2///^S X=PRCX;3///1" D ^DIE
. S PRCCOUNT=PRCCOUNT+1,DR="5///^S X=PRCCOUNT" D ^DIE
S PRCCOUNT=PRCCOUNT+1
K DA,DIE S DIE=442,DA=PRCHPO,DR="15///^S X=PRCCOUNT" D ^DIE
S PRCX=0
F S PRCX=$O(^PRC(444,PRCRFQDA,8,PRCQUOTE,2,PRCX)) Q:+PRCX'=PRCX D
. S PRCY=$G(^PRC(444,PRCRFQDA,8,PRCQUOTE,2,PRCX,0)) Q:PRCY=""
. S X=$P(PRCY,U)
. K DA,DIC S DA(1)=PRCHPO,DIC="^PRC(442,DA(1),5,",DIC(0)="LX"
. S DIC("P")=$P(^DD(442,9.2,0),U,2),DLAYGO=442.06 D ^DIC K DIC,DLAYGO
. Q:+Y<1
. S DA=+Y,DIE="^PRC(442,DA(1),5,",PRCY=$P(PRCY,U,2)
. S DR="1///^S X=PRCY" D ^DIE
S PRCX=0,PRCY=0
F S PRCX=$O(^PRC(442,PRCHPO,2,PRCX)) Q:+PRCX'=PRCX D
. S PRCZ=$G(^PRC(442,PRCHPO,2,PRCX,2)) Q:PRCZ=""
. S PRCY=$P(PRCZ,U)-$P(PRCZ,U,6)+PRCY
S ^PRC(442,PRCHPO,9,0)="^"_$P(^DD(442,35,0),U,2)_"^1^1"
S PRCY=$FN(PRCY,"",2)
S $P(^PRC(442,PRCHPO,9,1,0),U)=PRCY,$P(^PRC(442,PRCHPO,0),U,15)=PRCY
S $P(^PRC(442,PRCHPO,1),U,8)=$P(^PRC(444,PRCRFQDA,8,PRCQUOTE,0),U,2)
I PRCFOB="O" W !!,"As FOB is Origin, you will now be prompted for the Shipping BOC.",! S DIE=442,DA=PRCHPO,DR="13.05R" D ^DIE
S PRCX=$P(^PRC(442,PRCHPO,1),U)
I PRCX'="",$P($G(^PRC(440,PRCX,3)),U,2)="Y" D
. W !,"As this PO has an EDI Vendor, you will be asked about Special Handling."
. S DIE=442,DR="18.6//NO;S:X'=""Y"" Y=0;18.7",DA=PRCHPO
. D ^DIE K DIE,DR
EX L:$G(PRCHPO)>0 -^PRC(442,PRCHPO)
Q $S($G(PRCHPO)>0:$P($G(^PRC(442,PRCHPO,0)),U),1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ15 7217 printed Apr 09, 2024@21:03:47 Page 2
PRCHQ15 ;(WASH IRMFO)/LKG-Create Initial #442 entry from 2237 ;9/30/96 14:59
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
POBLD(PRCHSY,PRCRFQDA,PRCQUOTE,PRCFOB) ;Given 2237 IEN build its PO
+1 NEW PRC410,PRCCOUNT,PRC,DIE,DR,PRCDSCNT,PRCHPO,PRCHSP,PRCHSX,PRCI,PRCIEN
+2 NEW PRCLN,PRCX,PRCY,PRCZ,X,Y,PRCDA410,PRCHHM,PRCHPONO,PRCCOST,PRCH,PRCHN,PRCHS
+3 NEW PRCHCC,PRCHITM,PRCHZ,PRCHZ1,PRCHZ2,PRCHZ3
+4 if '$DATA(^PRCS(410,PRCHSY))
GOTO EX
+5 SET PRC410(0)=$GET(^PRCS(410,PRCHSY,0))
if PRC410(0)=""
GOTO EX
+6 SET PRC("SITE")=$PIECE(PRC410(0),U,5)
+7 IF '$DATA(PRC("PER"))
Begin DoDot:1
+8 IF $DATA(DUZ)#2
IF +DUZ>0
SET PRC("PER")=+DUZ
+9 SET X=$SELECT('$DATA(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
+10 SET $PIECE(PRC("PER"),U,2,4)=$PIECE(X,U,2)_U_$PIECE(X,U,3)_U_$SELECT($DATA(^VA(200,+PRC("PER"),.13)):$PIECE(^(.13),U,2),1:"")
End DoDot:1
+11 if PRC("SITE")]""
SET PRC("PARAM")=$GET(^PRC(411,PRC("SITE"),0))
+12 SET PRCHSX=$PIECE(PRC410(0),U)
SET PRC("FY")=$PIECE(PRCHSX,"-",2)
SET PRC("QTR")=$PIECE(PRCHSX,"-",3)
+13 SET PRCI=0
GETNUM DO ENPO^PRCHUTL
+1 IF '$DATA(PRCHPO)
Begin DoDot:1
+2 NEW DIR
SET DIR(0)="YA"
SET DIR("A")="No PO Number was entered, do you want to try again? "
+3 SET DIR("B")="YES"
SET DIR("?")="Answer 'YES' to return to prompt for PO Number"
+4 DO ^DIR
End DoDot:1
if Y=1
GOTO GETNUM
GOTO EX
+5 SET PRCI=PRCI+1
+6 LOCK +^PRC(442,DA):5
IF '$TEST
WRITE !,"Another user is editing this entry!"
KILL DA
if PRCI<10
GOTO GETNUM
WRITE !,"Lock Table Problem - Please contact IRM!"
SET PRCHPO=""
GOTO EX
+7 SET DIE=442
SET DA=PRCHPO
SET DR="42///^S X=$P(^PRC(444,PRCRFQDA,0),U)"
+8 NEW PONUM
SET PONUM=$PIECE($PIECE($GET(^PRC(442,PRCHPO,0)),"^"),"-",2)
+9 DO ^DIE
+10 ;If an order is Certified then INV Address should be FISCAL,
+11 ;otherwise it will be FMS. <<<< nois DUB-0597-31814 <<<<
+12 IF $EXTRACT(PONUM,1)'="C"
Begin DoDot:1
+13 SET DR=".02////1;.08////N;.04///FMS;.1///TODAY"
DO ^DIE
+14 QUIT
End DoDot:1
+15 IF $EXTRACT(PONUM,1)="C"
Begin DoDot:1
+16 SET DR=".02////2;.08////N;.04///FISCAL;.1///TODAY"
DO ^DIE
+17 QUIT
End DoDot:1
+18 SET PRCY=$PIECE(PRC410(0),U,10)
IF PRCY]""
SET DR="31////^S X=PRCY"
DO ^DIE
+19 SET PRCY=$PIECE($GET(^PRCS(410,PRCHSY,3)),U,4)
IF PRCY]""
SET DR="5////^S X=PRCY"
DO ^DIE
+20 SET X=$PIECE(^PRCS(410,PRCHSY,3),U)
SET $PIECE(^PRC(442,PRCHPO,0),U,3)=X
SET ^PRC(442,"E",$PIECE(X," "),PRCHPO)=""
SET PRC("CP")=X
+21 SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
+22 SET PRC("APP")=$PIECE($$ACC^PRC0C(PRC("SITE"),+PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11)
+23 SET $PIECE(^PRC(442,PRCHPO,0),U,4)=PRC("APP")
+24 SET PRCY=$PIECE($GET(^PRC(420,PRC("SITE"),1,$PIECE(PRCHSX,"-",4),0)),U,12)
+25 IF PRCY]""
SET DR=".03////^S X=PRCY"
DO ^DIE
+26 SET PRCHN("MP")=$SELECT($DATA(^PRCD(442.5,+$PIECE(^PRC(442,DA,0),U,2),0)):$PIECE(^(0),U,3),1:"")
+27 SET PRCHN("SFC")=+$PIECE(^PRC(442,DA,0),U,19)
+28 DO EN2^PRCHNPO3
+29 SET PRCY=$PIECE($GET(^PRCS(410,PRCHSY,3)),U,3)
IF PRCY]""
SET DR="2///^S X=PRCY"
DO ^DIE
+30 SET PRCY=$PIECE($GET(^PRCS(410,PRCHSY,3)),U,5)
IF PRCY]""
SET DR="5.2////^S X=PRCY"
DO ^DIE
+31 SET PRCY=$PIECE($GET(^PRC(444,PRCRFQDA,1)),U,3)
IF PRCY]""
SET DR="5.4////^S X=PRCY"
DO ^DIE
+32 SET PRCY=$PIECE($GET(^PRCS(410,PRCHSY,9)),U)
IF PRCY]""
SET DR="5.6///^S X=PRCY"
DO ^DIE
+33 SET DR="6.4////^S X=PRCFOB"
DO ^DIE
+34 SET PRCY=$PIECE($GET(^PRCS(410,PRCHSY,1)),U,4)
IF PRCY]""
SET DR="7////^S X=PRCY"
DO ^DIE
+35 SET PRCY=$PIECE($GET(^PRCS(410,PRCHSY,9)),U,4)
IF PRCY>0
SET $PIECE(^PRC(442,PRCHPO,0),U,13)=PRCY
+36 SET DR="16////^S X=DUZ"
DO ^DIE
+37 SET DR="26///^S X=PRC(""BBFY"")"
DO ^DIE
+38 SET PRCHSY(0)=^PRC(443,PRCHSY,0)
+39 SET PRCHS=""
DO ^PRCHSP1
+40 SET PRCHSP=""
SET PRCH=""
SET PRCDA410=PRCHSY
DO LST1^PRCHNPO2
SET PRCHSY=PRCDA410
KILL PRCHSY(0)
+41 SET PRCX=0
SET PRCCOUNT=0
+42 FOR
SET PRCX=$ORDER(^PRC(442,PRCHPO,2,PRCX))
if +PRCX'=PRCX
QUIT
SET PRCCOUNT=PRCCOUNT+1
+43 SET PRCIEN=0
+44 FOR
SET PRCIEN=$ORDER(^PRCS(410,PRCHSY,"IT",PRCIEN))
if +PRCIEN'=PRCIEN
QUIT
Begin DoDot:1
+45 SET PRCZ=^PRCS(410,PRCHSY,"IT",PRCIEN,0)
+46 SET PRCX=$PIECE(PRCZ,U,3)
if PRCX]""
SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,0),U,3)=PRCX
+47 SET PRCX=$PIECE(PRCZ,U,6)
if PRCX]""
SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,0),U,6)=PRCX
+48 IF $PIECE($GET(^PRCS(410,PRCHSY,"IT",PRCIEN,1,0)),U,4)>0
Begin DoDot:2
+49 NEW IENS
SET IENS=PRCIEN_","_PRCHPO_","
KILL ^TMP("DIERR",$JOB)
+50 DO WP^DIE(442.01,IENS,1,"","^PRCS(410,PRCHSY,""IT"",PRCIEN,1)")
+51 KILL ^TMP("DIERR",$JOB)
End DoDot:2
+52 SET PRCX=0
+53 FOR
SET PRCX=$ORDER(^PRC(444,"AE",PRCHSY,PRCRFQDA,PRCX))
if PRCX=""
QUIT
if $PIECE($GET(^PRC(444,PRCRFQDA,2,PRCX,3)),U,7)=PRCIEN
QUIT
+54 if PRCX=""
QUIT
+55 SET PRCLN=$PIECE($GET(^PRC(444,PRCRFQDA,2,PRCX,0)),U)
+56 SET PRCY=$ORDER(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,"B",PRCLN,""))
if PRCY=""
QUIT
+57 SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,2),U,14)=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,11)
+58 SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,4),U,17)=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U)
+59 SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,4),U,18)=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,2)
+60 if $PIECE($GET(^PRC(442,PRCHPO,2,PRCIEN,0)),U,13)=""
SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,0),U,13)=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,6)
+61 if $PIECE($GET(^PRC(442,PRCHPO,2,PRCIEN,2)),U,3)=""
SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,2),U,3)=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,5)
+62 SET X=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,6)
+63 if X=""
SET X=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,0)),U,7)
+64 IF X]""
Begin DoDot:2
+65 SET Y=$PIECE($GET(^PRC(442,PRCHPO,1)),U)
IF Y=""
KILL X
QUIT
+66 IF '$DATA(^PRC(440,Y,4,"B",$EXTRACT(X,1,30)))
KILL X
QUIT
+67 SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,2),U,2)=X
+68 SET ^PRC(442,PRCHPO,2,"AC",$EXTRACT(X,1,30),PRCIEN)=""
End DoDot:2
+69 SET PRCCOST=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,3,5)
+70 SET PRCDSCNT=$PIECE(PRCCOST,U,2,3)
SET PRCCOST=$FNUMBER($PIECE(PRCCOST,U),"",4)
+71 SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,0),U,9)=PRCCOST
+72 SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,2),U)=$FNUMBER(PRCCOST*$PIECE(^PRC(442,PRCHPO,2,PRCIEN,0),U,2),"",4)
+73 IF $PIECE(PRCDSCNT,U)'>0
IF $PIECE(PRCDSCNT,U,2)'>0
QUIT
+74 KILL DA,DIC,DD,DO
SET DA(1)=PRCHPO
SET DIC="^PRC(442,DA(1),3,"
SET X=PRCIEN
SET DIC(0)="LX"
+75 SET DLAYGO=442.03
SET DIC("P")=$PIECE(^DD(442,14,0),U,2)
DO FILE^DICN
KILL DIC,DLAYGO
+76 if +Y<1
QUIT
SET DA=+Y
+77 SET PRCX=$SELECT($PIECE(PRCDSCNT,U)>0:$PIECE(PRCDSCNT,U),1:"$"_$PIECE(PRCDSCNT,U,2))
+78 SET DIE="^PRC(442,DA(1),3,"
SET DR="1////^S X=PRCX"
DO ^DIE
+79 SET PRCZ=$GET(^PRCS(410,PRCHSY,"IT",PRCIEN,0))
+80 SET PRCX=$SELECT($PIECE(PRCDSCNT,U)>0:PRCDSCNT/100*$PIECE(PRCZ,U,2)*$PIECE(PRCZ,U,7),1:$PIECE(PRCDSCNT,U,2))
+81 SET PRCX=$FNUMBER(PRCX,"",2)
SET $PIECE(^PRC(442,PRCHPO,2,PRCIEN,2),U,6)=PRCX
+82 SET DR="2///^S X=PRCX;3///1"
DO ^DIE
+83 SET PRCCOUNT=PRCCOUNT+1
SET DR="5///^S X=PRCCOUNT"
DO ^DIE
End DoDot:1
+84 SET PRCCOUNT=PRCCOUNT+1
+85 KILL DA,DIE
SET DIE=442
SET DA=PRCHPO
SET DR="15///^S X=PRCCOUNT"
DO ^DIE
+86 SET PRCX=0
+87 FOR
SET PRCX=$ORDER(^PRC(444,PRCRFQDA,8,PRCQUOTE,2,PRCX))
if +PRCX'=PRCX
QUIT
Begin DoDot:1
+88 SET PRCY=$GET(^PRC(444,PRCRFQDA,8,PRCQUOTE,2,PRCX,0))
if PRCY=""
QUIT
+89 SET X=$PIECE(PRCY,U)
+90 KILL DA,DIC
SET DA(1)=PRCHPO
SET DIC="^PRC(442,DA(1),5,"
SET DIC(0)="LX"
+91 SET DIC("P")=$PIECE(^DD(442,9.2,0),U,2)
SET DLAYGO=442.06
DO ^DIC
KILL DIC,DLAYGO
+92 if +Y<1
QUIT
+93 SET DA=+Y
SET DIE="^PRC(442,DA(1),5,"
SET PRCY=$PIECE(PRCY,U,2)
+94 SET DR="1///^S X=PRCY"
DO ^DIE
End DoDot:1
+95 SET PRCX=0
SET PRCY=0
+96 FOR
SET PRCX=$ORDER(^PRC(442,PRCHPO,2,PRCX))
if +PRCX'=PRCX
QUIT
Begin DoDot:1
+97 SET PRCZ=$GET(^PRC(442,PRCHPO,2,PRCX,2))
if PRCZ=""
QUIT
+98 SET PRCY=$PIECE(PRCZ,U)-$PIECE(PRCZ,U,6)+PRCY
End DoDot:1
+99 SET ^PRC(442,PRCHPO,9,0)="^"_$PIECE(^DD(442,35,0),U,2)_"^1^1"
+100 SET PRCY=$FNUMBER(PRCY,"",2)
+101 SET $PIECE(^PRC(442,PRCHPO,9,1,0),U)=PRCY
SET $PIECE(^PRC(442,PRCHPO,0),U,15)=PRCY
+102 SET $PIECE(^PRC(442,PRCHPO,1),U,8)=$PIECE(^PRC(444,PRCRFQDA,8,PRCQUOTE,0),U,2)
+103 IF PRCFOB="O"
WRITE !!,"As FOB is Origin, you will now be prompted for the Shipping BOC.",!
SET DIE=442
SET DA=PRCHPO
SET DR="13.05R"
DO ^DIE
+104 SET PRCX=$PIECE(^PRC(442,PRCHPO,1),U)
+105 IF PRCX'=""
IF $PIECE($GET(^PRC(440,PRCX,3)),U,2)="Y"
Begin DoDot:1
+106 WRITE !,"As this PO has an EDI Vendor, you will be asked about Special Handling."
+107 SET DIE=442
SET DR="18.6//NO;S:X'=""Y"" Y=0;18.7"
SET DA=PRCHPO
+108 DO ^DIE
KILL DIE,DR
End DoDot:1
EX if $GET(PRCHPO)>0
LOCK -^PRC(442,PRCHPO)
+1 QUIT $SELECT($GET(PRCHPO)>0:$PIECE($GET(^PRC(442,PRCHPO,0)),U),1:"")
