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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMA3 4978 printed Sep 02, 2024@18:53:58 Page 2
PRCHMA3 ;WISC/AKS-Amends to po and req ;6/8/96 14:14
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN15 ;Auth edit
+1 NEW DA,DIE,DA,DR
+2 KILL CAN
+3 SET PRCHO=$PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)
+4 SET DA(1)=PRCHPO
SET DIE="^PRC(443.6,"_DA(1)_",6,"
+5 SET DA=PRCHAM
SET DR="3//^S X=""D"""
DO ^DIE
WRITE !
+6 IF $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($PIECE(^(0),U,4)=15)
Begin DoDot:1
+7 DO ONLY^PRCHMA0
IF '$GET(PRCHON)
SET DR="3///^S X=PRCHO"
DO ^DIE
SET NOCAN=1
QUIT
+8 DO ENC^PRCHMA
+9 IF $GET(ER)!$GET(NOCAN)
SET DR="3///^S X=PRCHO"
DO ^DIE
SET NOCAN=1
QUIT
+10 SET CAN=1
End DoDot:1
+11 IF +$GET(PRCHO)=5!(+$GET(PRCHO)=15)
IF PRCHO'=$PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)
DO NOSIGN1^PRCHMA
+12 SET DA(1)=PRCHPO
SET DA=PRCHAM
SET PRCHX=X
SET X=PRCHO
Begin DoDot:1
+13 if X=""
SET X=4
DO EN8^PRCHAMXB
SET X=PRCHX
KILL PRCHX
End DoDot:1
+14 QUIT
EN16 ;F.O.B. Edit
+1 NEW X,I,PRCHSBOC,%,%A,%B,PRCH0,PRCH12,PRCHGNO,PRCHGPO,PRCHGSHP,PRCHN
+2 NEW PRCHSHP
+3 SET (I,ER)=0
SET X=""
+4 DO CAN^PRCHMA3
+5 IF $GET(NOCAN)=1
WRITE !?5,$SELECT($DATA(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE F.O.B. EDIT!",$CHAR(7)
QUIT
+6 SET PRCH0=$GET(^PRC(443.6,PRCHPO,0))
+7 SET PRCHO=$PIECE(PRCH0,U,13)
SET PRCHOO=$PIECE($GET(^PRC(443.6,PRCHPO,23)),U)
+8 SET PRCH12=$GET(^PRC(443.6,PRCHPO,12))
IF PRCH12]""
Begin DoDot:1
+9 SET PRCHGNO=$PIECE(PRCH12,U,7)
SET PRCHGPO=$PIECE(PRCH12,U,8)
SET PRCHGSHP=$PIECE(PRCH12,U,9)
End DoDot:1
+10 SET DR="6.4;S:X'=""O"" Y="""";13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05"
+11 IF $PIECE(^PRC(442,PRCHPO,0),U,19)=2
Begin DoDot:1
+12 SET PRCHSBOC=$PIECE($GET(^PRCD(420.2,2299,0)),U)
+13 SET DR="6.4;S:X'=""O"" Y="""";13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05////^S X=PRCHSBOC"
End DoDot:1
+14 SET DIE="^PRC(443.6,"
SET DA=PRCHPO
DO ^DIE
+15 SET PRCHN("FOB")=$PIECE($GET(^PRC(443.6,PRCHPO,1)),U,6)
SET PRCHSHP=+$PIECE(^(0),U,13)
+16 IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,13)]""
Begin DoDot:1
+17 IF $GET(PRCHAUTH)'=1
IF (PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0)))
SET DR="13.2;13.4;13.3"
DO ^DIE
KILL DIE
End DoDot:1
+18 IF $PIECE($GET(^PRC(443.6,PRCHPO,1)),U,6)="D"
Begin DoDot:1
+19 IF $PIECE(^PRC(443.6,PRCHPO,0),U,13)]""
Begin DoDot:2
+20 SET %=""
SET %A=" This purchase order has shipping charges, Would you like to delete? "
SET %B=""
DO ^PRCFYN
+21 IF %=1
Begin DoDot:3
+22 SET DIE="^PRC(443.6,"
SET DA=PRCHPO
SET DR="13///@;13.2///@;13.4///@;13.3///@"
DO ^DIE
KILL DIE,DA,DR
+23 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=$PIECE(PRCH0,U,14)-1
+24 SET $PIECE(^PRC(443.6,PRCHPO,0),U,18)=""
End DoDot:3
+25 IF %'=1
DO GBL^PRCHMA2
End DoDot:2
End DoDot:1
+26 IF $PIECE($GET(^PRC(443.6,PRCHPO,1)),U,6)="O"&(PRCHSHP=""!(PRCHSHP'>250&(PRCHSHP'=0)))
DO GBL^PRCHMA2
+27 IF $PIECE($GET(^PRC(443.6,PRCHPO,1)),U,6)="O"
SET PRCHN=$PIECE(^PRC(443.6,PRCHPO,0),U,13)
Begin DoDot:1
+28 IF PRCHO=""&(PRCHN]"")
Begin DoDot:2
+29 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=$PIECE(PRCH0,U,14)+1
+30 SET $PIECE(^PRC(443.6,PRCHPO,0),U,18)=$PIECE(PRCH0,U,14)+1
End DoDot:2
+31 IF PRCHO]""&(PRCHN="")
Begin DoDot:2
+32 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=$PIECE(PRCH0,U,14)-1
SET $PIECE(^(0),U,18)=""
+33 SET $PIECE(^PRC(443.6,PRCHPO,23),U)=""
End DoDot:2
End DoDot:1
+34 SET DA=PRCHPO
SET PRCHX=X
SET X=$SELECT(PRCHO]"":PRCHO,1:0)
IF PRCHO'=$PIECE(^PRC(443.6,PRCHPO,0),U,13)
SET PRCHAMDA=29
DO EN4^PRCHAMXC
+35 SET X=$SELECT(PRCHOO]"":PRCHOO,1:0)
IF PRCHOO'=$PIECE($GET(^PRC(443.6,PRCHPO,23)),U)
SET PRCHAMDA=29
DO EN11^PRCHAMXC
+36 IF PRCHGNO'=$PIECE($GET(^PRC(443.6,PRCHPO,12)),U,7)
SET X=$SELECT(PRCHGNO]"":PRCHGNO,1:0)
DO EN12^PRCHAMXC
+37 IF PRCHGPO'=$PIECE($GET(^PRC(443.6,PRCHPO,12)),U,8)
SET X=$SELECT(PRCHGPO]"":PRCHGPO,1:0)
DO EN14^PRCHAMXC
+38 IF PRCHGSHP'=$PIECE($GET(^PRC(443.6,PRCHPO,12)),U,9)
SET X=$SELECT(PRCHGSHP]"":PRCHGSHP,1:0)
DO EN13^PRCHAMXC
+39 SET X=PRCHX
KILL PRCHO,PRCHOO
QUIT
+40 SET DELIVER=1
WRITE !
+41 QUIT
EN17 ;ITEM DISC Add/Edit
+1 NEW DIE,DR,X,Y,N
+2 DO MV^PRCHMA0
DO MVDIS
DO ^PRCHDIS2
+3 SET DIE="^PRC(443.6,"
SET DR="[PRCHAMDISCOUNT]"
SET DA=PRCHPO
DO ^DIE
+4 SET (I,N)=0
FOR
SET N=$ORDER(^PRC(443.6,PRCHPO,2,N))
if 'N
QUIT
SET I=I+1
+5 SET N=0
FOR
SET N=$ORDER(^PRC(443.6,PRCHPO,3,N))
if 'N
QUIT
SET I=I+1
SET $PIECE(^(N,0),U,6)=I
+6 IF $PIECE(^PRC(443.6,PRCHPO,0),U,13)]""
Begin DoDot:1
+7 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=I+1
SET $PIECE(^(0),U,18)=I+1
End DoDot:1
+8 QUIT
EN18 ;ITEM DISC Delete
+1 NEW PRCHD,ID442,PRCHOLD,DIC,DIE,DR,DA,ID,Y
+2 DO MV^PRCHMA0
DO MVDIS
+3 SET DA(1)=PRCHPO
SET DIC="^PRC(443.6,"_DA(1)_",3,"
SET DIC(0)="QAEMZ"
DO ^DIC
+4 if Y<0
QUIT
SET PRCHD=+Y
+5 SET %=2
SET %A=" SURE YOU WANT TO DELETE "
SET %B=""
DO ^PRCFYN
+6 IF %'=1
WRITE ?40,"<NOTHING DELETED>"
QUIT
+7 SET ID442=$GET(^PRC(442,DA(1),3,PRCHD,0))
IF ID442=""
Begin DoDot:1
+8 KILL ^PRC(443.6,DA(1),3,PRCHD)
+9 SET ID=$GET(^PRC(443.6,PRCHPO,3,0))
if ID=""
QUIT
SET $PIECE(ID,U,4)=$PIECE(ID,U,4)-1
SET ^PRC(443.6,PRCHPO,3,0)=ID
+10 SET (I,N)=0
FOR
SET N=$ORDER(^PRC(443.6,PRCHPO,2,N))
if 'N
QUIT
SET I=I+1
+11 SET N=0
FOR
SET N=$ORDER(^PRC(443.6,PRCHPO,3,N))
if 'N
QUIT
SET I=I+1
SET $PIECE(^(N,0),U,6)=I
+12 IF $PIECE(^PRC(443.6,PRCHPO,0),U,13)]""
Begin DoDot:2
+13 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=I+1
SET $PIECE(^(0),U,18)=I+1
End DoDot:2
End DoDot:1
QUIT
+14 SET PRCHOLD=$PIECE($GET(^PRC(443.6,DA(1),3,PRCHD,0)),U,2)
+15 SET DIE="^PRC(443.6,"_DA(1)_",3,"
SET DA=PRCHD
SET DR="1////0"
DO ^DIE
KILL DIE
+16 SET X=PRCHOLD
DO EN10^PRCHAMXC
+17 QUIT
+18 ;
MVDIS ;MOVE DISC ITEM INFO
+1 if $DATA(^PRC(443.6,PRCHPO,3,0))
QUIT
DO MV^PRCHMA0
+2 NEW %X,%Y
+3 SET %X="^PRC(442,PRCHPO,3,"
SET %Y="^PRC(443.6,PRCHPO,3,"
DO %XY^%RCR
+4 SET $PIECE(^PRC(443.6,PRCHPO,3,0),U,2)=$PIECE(^DD(443.6,14,0),U,2)
+5 QUIT
CAN ;CANCEL ALLOWED?
+1 NEW M
+2 SET NOCAN=0
if '$DATA(^PRC(442,PRCHPO,11))
QUIT
+3 SET M=0
FOR
SET M=$ORDER(^PRC(442,PRCHPO,2,M))
if 'M
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PRC(442,PRCHPO,2,M,2)),U,8)
SET NOCAN=1
End DoDot:1
if NOCAN
QUIT
+5 IF NOCAN=0
IF $PIECE($GET(^PRC(442,PRCHPO,0)),U,2)'=25
SET M=0
FOR
SET M=$ORDER(^PRC(442,PRCHPO,11,M))
if 'M
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^PRC(442,PRCHPO,11,M,0)),U,6)=""
SET NOCAN=1
End DoDot:1
if NOCAN
QUIT
+7 QUIT
