- 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 Jan 18, 2025@03:09:52 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