PRCHMA3 ;WISC/AKS-Amends to po and req ;6/8/96  14:14
 ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN15 ;Auth edit
 N DA,DIE,DA,DR
 K CAN
 S PRCHO=$P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)
 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,"
 S DA=PRCHAM,DR="3//^S X=""D""" D ^DIE W !
 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) D
 .D ONLY^PRCHMA0 I '$G(PRCHON) S DR="3///^S X=PRCHO" D ^DIE S NOCAN=1 Q
 .D ENC^PRCHMA
 .I $G(ER)!$G(NOCAN) S DR="3///^S X=PRCHO" D ^DIE S NOCAN=1 Q
 .S CAN=1
 I +$G(PRCHO)=5!(+$G(PRCHO)=15) I PRCHO'=$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4) D NOSIGN1^PRCHMA
 S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=PRCHO D
 .S:X="" X=4 D EN8^PRCHAMXB S X=PRCHX K PRCHX
 QUIT
EN16 ;F.O.B. Edit
 N X,I,PRCHSBOC,%,%A,%B,PRCH0,PRCH12,PRCHGNO,PRCHGPO,PRCHGSHP,PRCHN
 N PRCHSHP
 S (I,ER)=0,X=""
 D CAN^PRCHMA3
 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE F.O.B. EDIT!",$C(7) Q
 S PRCH0=$G(^PRC(443.6,PRCHPO,0))
 S PRCHO=$P(PRCH0,U,13),PRCHOO=$P($G(^PRC(443.6,PRCHPO,23)),U)
 S PRCH12=$G(^PRC(443.6,PRCHPO,12)) I PRCH12]"" D
 .S PRCHGNO=$P(PRCH12,U,7),PRCHGPO=$P(PRCH12,U,8),PRCHGSHP=$P(PRCH12,U,9)
 S DR="6.4;S:X'=""O"" Y="""";13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05"
 I $P(^PRC(442,PRCHPO,0),U,19)=2 D
 .S PRCHSBOC=$P($G(^PRCD(420.2,2299,0)),U)
 .S DR="6.4;S:X'=""O"" Y="""";13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05////^S X=PRCHSBOC"
 S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE
 S PRCHN("FOB")=$P($G(^PRC(443.6,PRCHPO,1)),U,6),PRCHSHP=+$P(^(0),U,13)
 I $P($G(^PRC(443.6,PRCHPO,0)),U,13)]"" D
 .I $G(PRCHAUTH)'=1 I (PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0))) S DR="13.2;13.4;13.3" D ^DIE K DIE
 I $P($G(^PRC(443.6,PRCHPO,1)),U,6)="D" D
 .I $P(^PRC(443.6,PRCHPO,0),U,13)]"" D
 ..S %="",%A=" This purchase order has shipping charges, Would you like to delete? ",%B="" D ^PRCFYN
 ..I %=1 D
 ...S DIE="^PRC(443.6,",DA=PRCHPO,DR="13///@;13.2///@;13.4///@;13.3///@" D ^DIE K DIE,DA,DR
 ...S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)-1
 ...S $P(^PRC(443.6,PRCHPO,0),U,18)=""
 ..I %'=1 D GBL^PRCHMA2
 I $P($G(^PRC(443.6,PRCHPO,1)),U,6)="O"&(PRCHSHP=""!(PRCHSHP'>250&(PRCHSHP'=0))) D GBL^PRCHMA2
 I $P($G(^PRC(443.6,PRCHPO,1)),U,6)="O" S PRCHN=$P(^PRC(443.6,PRCHPO,0),U,13) D
 .I PRCHO=""&(PRCHN]"") D
 ..S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)+1
 ..S $P(^PRC(443.6,PRCHPO,0),U,18)=$P(PRCH0,U,14)+1
 .I PRCHO]""&(PRCHN="") D
 ..S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)-1,$P(^(0),U,18)=""
 ..S $P(^PRC(443.6,PRCHPO,23),U)=""
 S DA=PRCHPO,PRCHX=X,X=$S(PRCHO]"":PRCHO,1:0) I PRCHO'=$P(^PRC(443.6,PRCHPO,0),U,13) S PRCHAMDA=29 D EN4^PRCHAMXC
 S X=$S(PRCHOO]"":PRCHOO,1:0) I PRCHOO'=$P($G(^PRC(443.6,PRCHPO,23)),U) S PRCHAMDA=29 D EN11^PRCHAMXC
 I PRCHGNO'=$P($G(^PRC(443.6,PRCHPO,12)),U,7) S X=$S(PRCHGNO]"":PRCHGNO,1:0) D EN12^PRCHAMXC
 I PRCHGPO'=$P($G(^PRC(443.6,PRCHPO,12)),U,8) S X=$S(PRCHGPO]"":PRCHGPO,1:0) D EN14^PRCHAMXC
 I PRCHGSHP'=$P($G(^PRC(443.6,PRCHPO,12)),U,9) S X=$S(PRCHGSHP]"":PRCHGSHP,1:0) D EN13^PRCHAMXC
 S X=PRCHX K PRCHO,PRCHOO Q
 S DELIVER=1 W !
 QUIT
EN17 ;ITEM DISC Add/Edit
 N DIE,DR,X,Y,N
 D MV^PRCHMA0,MVDIS,^PRCHDIS2
 S DIE="^PRC(443.6,",DR="[PRCHAMDISCOUNT]",DA=PRCHPO D ^DIE
 S (I,N)=0 F  S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N  S I=I+1
 S N=0 F  S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N  S I=I+1,$P(^(N,0),U,6)=I
 I $P(^PRC(443.6,PRCHPO,0),U,13)]"" D
 .S $P(^PRC(443.6,PRCHPO,0),U,14)=I+1,$P(^(0),U,18)=I+1
 QUIT
EN18 ;ITEM DISC Delete
 N PRCHD,ID442,PRCHOLD,DIC,DIE,DR,DA,ID,Y
 D MV^PRCHMA0,MVDIS
 S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",3,",DIC(0)="QAEMZ" D ^DIC
 Q:Y<0  S PRCHD=+Y
 S %=2,%A="     SURE YOU WANT TO DELETE ",%B="" D ^PRCFYN
 I %'=1 W ?40,"<NOTHING DELETED>" Q
 S ID442=$G(^PRC(442,DA(1),3,PRCHD,0)) I ID442="" D  Q
 .K ^PRC(443.6,DA(1),3,PRCHD)
 .S ID=$G(^PRC(443.6,PRCHPO,3,0)) Q:ID=""  S $P(ID,U,4)=$P(ID,U,4)-1,^PRC(443.6,PRCHPO,3,0)=ID
 .S (I,N)=0 F  S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N  S I=I+1
 .S N=0 F  S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N  S I=I+1,$P(^(N,0),U,6)=I
 .I $P(^PRC(443.6,PRCHPO,0),U,13)]"" D
 ..S $P(^PRC(443.6,PRCHPO,0),U,14)=I+1,$P(^(0),U,18)=I+1
 S PRCHOLD=$P($G(^PRC(443.6,DA(1),3,PRCHD,0)),U,2)
 S DIE="^PRC(443.6,"_DA(1)_",3,",DA=PRCHD,DR="1////0" D ^DIE K DIE
 S X=PRCHOLD D EN10^PRCHAMXC
 QUIT
 ;
MVDIS ;MOVE DISC ITEM INFO
 Q:$D(^PRC(443.6,PRCHPO,3,0))  D MV^PRCHMA0
 N %X,%Y
 S %X="^PRC(442,PRCHPO,3,",%Y="^PRC(443.6,PRCHPO,3," D %XY^%RCR
 S $P(^PRC(443.6,PRCHPO,3,0),U,2)=$P(^DD(443.6,14,0),U,2)
 QUIT
CAN ;CANCEL ALLOWED?
 N M
 S NOCAN=0 Q:'$D(^PRC(442,PRCHPO,11))
 S M=0 F  S M=$O(^PRC(442,PRCHPO,2,M)) Q:'M  D  Q:NOCAN
 .I $P($G(^PRC(442,PRCHPO,2,M,2)),U,8) S NOCAN=1
 I NOCAN=0,$P($G(^PRC(442,PRCHPO,0)),U,2)'=25 S M=0 F  S M=$O(^PRC(442,PRCHPO,11,M)) Q:'M  D  Q:NOCAN
 .I $P($G(^PRC(442,PRCHPO,11,M,0)),U,6)="" S NOCAN=1
 QUIT