Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHMA3

PRCHMA3.m

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