74 lines
5.6 KiB
Mathematica
74 lines
5.6 KiB
Mathematica
PRCHAM ;WOIFO/ID/RSD,SF-ISC/TKW/BGJ/AS-AMENDMENTS TO P.O. ;3/8/05
|
|
V ;;5.1;IFCAP;**14,38,81**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
ENAV D LCK^PRCHAM3 G:$T Q S PRCH(0)=Y(0),PRCH(1)=^PRC(442,PRCHPO,1),PRCH(7)=^(7),PRCH(12)=^(12),(PRCHAMT,PRCHAN,PRCHDL,PRCHAREC,PRCHCHK)=0
|
|
I $D(^PRC(442,PRCHPO,6)) F I=0:0 S I=$O(^PRC(442,PRCHPO,6,I)) Q:'I S PRCHAN=I
|
|
S PRCHAN=PRCHAN+1 W !?5,"Adjustment number: ",PRCHAN S %=1,%A=" Do you wish to continue",%B="" D ^PRCFYN G:%'=1 Q
|
|
S:'$D(PRCHAM) PRCHAM=PRCHAN
|
|
S ^PRC(443.6,PRCHPO,0)=PRCH(0),^(1)=PRCH(1),^(7)=PRCH(7),^(12)=PRCH(12),DIE="^PRC(443.6,",DR="[PRCHAMEND]" S:$D(PRCHAV) DR="[PRCHAMENDAV]"
|
|
D ^DIE G:$D(Y) Q I '$D(^PRC(443.6,PRCHPO,6,PRCHAN,1)) W !?5,"Can't continue without a Purchasing Agent !" G Q
|
|
S PRCHLC=$P(PRCH(0),U,14) Q:$D(PRCHAV) G ^PRCHAM1
|
|
EN S X=PRCHL1_PRCHO_PRCHL2_PRCHN,J=0,PRCHCHK=1 S:'$D(^PRC(443.6,PRCHPO,6,PRCHAN,2,0)) ^(0)="^^^^"_DT
|
|
F I=0:0 S I=$O(^PRC(443.6,PRCHPO,6,PRCHAN,2,I)) Q:'I S J=J+1
|
|
G:PRCHL1="*" EN1 S ^PRC(443.6,PRCHPO,6,PRCHAN,2,0)="^^"_($P(^PRC(443.6,PRCHPO,6,PRCHAN,2,0),U,3)+1)_U_($P(^(0),U,4)+1)_U_DT,^PRC(443.6,PRCHPO,6,PRCHAN,2,J+1,0)=" "_X I '$D(^TMP("PRCHW",$J)) S ^PRC(443.6,PRCHPO,6,PRCHAN,2,J+2,0)=" " Q
|
|
EN1 F I=0:0 S I=$O(^TMP("PRCHW",$J,I)) Q:'I S X=^TMP("PRCHW",$J,I),J=J+1 S:($L(X)+1)'>255 X=" "_X S ^PRC(443.6,PRCHPO,6,PRCHAN,2,J,0)=X
|
|
S ^PRC(443.6,PRCHPO,6,PRCHAN,2,0)="^^"_J_U_J_DT,^(J+1,0)=" " K ^TMP("PRCHW",$J) Q
|
|
CHK G:PRCHCHK=0 Q I PRCHAREC W !?3,"Recalculating Discounts ..." D RECAL^PRCHAM3 I $D(^TMP("PRCHW",$J)) S PRCHL1="*",(PRCHN,PRCHO,PRCHL2)="" D EN
|
|
S:PRCHAMT $P(^PRC(443.6,PRCHPO,6,PRCHAN,0),U,3)=PRCHAMT,$P(^(0),U,15)=$P(^PRC(443.6,PRCHPO,0),U,15)+PRCHAMT
|
|
I PRCHDL D UPDT^PRCHAM3
|
|
EN2 S $P(^PRC(443.6,PRCHPO,0),U,14)=PRCHLC,%=1,%B="",%A=" Review Adjustment " W ! D ^PRCFYN I %=1 S D0=PRCHPO,D1=PRCHAN,PRCH="^PRC(443.6," D ^PRCHDAM
|
|
S %A=" Edit Description ",%=2,%B="Enter 'YES' to edit the Adjustment Description or 'NO' to continue." D ^PRCFYN I %=1 S DIE="^PRC(443.6,",DA=PRCHPO,DR="[PRCHAMDESC]" D ^DIE
|
|
I $P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^(0),U,2)=26) S NOFISCAL=1
|
|
S %A=" Approve and print"_$S('$G(NOFISCAL):" (in FISCAL and SUPPLY)",1:"")_" Adjustment no.: "_PRCHAN,%B="",%=2 D ^PRCFYN I %'=1 W !?10,"Adjustment Deleted !",$C(7) G Q
|
|
S P=+$S($D(^PRC(443.6,PRCHPO,6,PRCHAN,1)):^(1),1:"") I P="" W !?5,"Purchasing Agent Field is undefined !",$C(7) G Q
|
|
I P'=DUZ D ESIG^PRCHAM44
|
|
S DA=PRCHPO S PRCSIG="" D ESIG^PRCUESIG(P,.PRCSIG) I PRCSIG<1 S ROUTINE="PRCUESIG" G QQ
|
|
S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES5(^PRC(442,PRCHPO,0),^PRC(442,PRCHPO,1),^PRC(442,PRCHPO,12)))
|
|
S PRCSIG="" D ENCODE^PRCHES10(PRCHPO,PRCHAN,P,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ S X=$P(^PRC(443.6,PRCHPO,6,PRCHAN,1),U,4) S:X]"" $P(^PRC(443.6,PRCHPO,7),U,1)=X
|
|
S PRCSIG="" D RECODE^PRCHES12(PRCHPO,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM
|
|
F I=2,3,5,6 I $D(^PRC(443.6,PRCHPO,I,0))#2 S $P(^(0),U,2)=$P(",442.01IA,442.03A,,442.06A,442.07",",",I)
|
|
I $D(^PRC(443.6,PRCHPO,7)) S X=+^(7),Y=X I X S DA=PRCHPO D UPD^PRCHSTAT S ^PRC(443.6,PRCHPO,7)=^PRC(442,PRCHPO,7)
|
|
D WAIT^DICD
|
|
;
|
|
;Check for any Adjustment for PO. If any, save the Adjustment Number
|
|
;at Partial node and save the Partial Number at Adjustment Node.
|
|
;If no Adjustment on PO then skip it. Patch PRC*5.1*38
|
|
;
|
|
ADJESIG G:'$D(^PRC(443.6,PRCHPO,6,0)) SKIPIT
|
|
S ADJDATA=$G(^PRC(443.6,PRCHPO,6,PRCHAN,0))
|
|
I $P(ADJDATA,U,8)'="Y" G SKIPIT
|
|
S PRTDATA=$G(^PRC(443.6,PRCHPO,11,PRCHAV,0))
|
|
S $P(PRTDATA,U,21)=PRCHAN
|
|
S ^PRC(443.6,PRCHPO,11,PRCHAV,0)=PRTDATA
|
|
S $P(ADJDATA,U,13)=PRCHAV
|
|
S ^PRC(443.6,PRCHPO,6,PRCHAN,0)=ADJDATA
|
|
K ADJDATA,PRTDATA
|
|
;
|
|
SKIPIT D WAIT^DICD S %X="^PRC(443.6,PRCHPO,",%Y="^PRC(442,PRCHPO," D %XY^%RCR I $D(PRCHNPO) S $P(^PRC(442,PRCHNPO,0),U,1)=PRCHNPO(0)
|
|
I $D(^PRC(442,PRCHPO,6,0)) D
|
|
. S $P(^PRC(442,PRCHPO,6,PRCHAN,0),U,12)=""
|
|
I '$D(PRCHAV) G JMP
|
|
S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES1(^PRC(442,PRCHPO,11,PRCHAV,0)))
|
|
S PRCSIG="" D RECODE^PRCHES1(PRCHPO,PRCHAV,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM
|
|
; Transmit RR Adj info to DynaMed **81**
|
|
D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ENT^PRCVRRA(PRCHPO,PRCHAV)
|
|
;
|
|
I $P(^PRC(442,PRCHPO,11,PRCHAV,0),U,16)="" G JMP
|
|
S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES2(^PRC(442,PRCHPO,11,PRCHAV,0),^PRC(442,PRCHPO,11,PRCHAV,1)))
|
|
S PRCSIG="" D RECODE^PRCHES2(PRCHPO,PRCHAV,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM,PRCHNFLG
|
|
JMP D SETC^PRCHAM4
|
|
I $D(PRCHX) S I=0 F J=1:1 S I=$O(PRCHX(I)) Q:I="" S Z=I,Y=$O(PRCHX(Z,0)) I Z]"",Y]"" S X=Z K @PRCHX(Z,Y) S:Y'="@" X=Y,@PRCHX(Z,Y)=""
|
|
S DA(1)=PRCHPO,N=0,DIK(1)=".01^C" F S N=$O(^PRC(442,DA(1),2,N)) Q:'N D
|
|
.S DA=N,DIK="^PRC(442,"_DA(1)_",2," D EN^DIK
|
|
K DA,DIK,N
|
|
I '$D(DT) D NOW^%DTC S DT=$P(%,".",1)
|
|
S PRCHCV=$S($D(^PRC(442,PRCHPO,1)):+^(1),1:0) ;I PRCHCV D ENUI^PRCHAM5
|
|
S DA=PRCHPO D UPDATE^PRCPWIU
|
|
W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAN D ^PRCHSF S D0=PRCHPO,D1=PRCHAN D ^PRCHQUE K ZTSK
|
|
I $D(PRC("PARAM")),$P(PRC("PARAM"),U,4)="Y",'$G(NOFISCAL) W !?3,"SEND TO FISCAL ",! S PRCHQ="^PRCHPAM",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAN D ^PRCHQUE
|
|
G Q
|
|
QQ S:'$D(ROUTINE) ROUTINE=$T(+0)
|
|
W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!" W !," ADJUSTMENT VOUCHER DELETED",$C(7) S DIR(0)="EAO",DIR("A")="Press <Return> to continue " D ^DIR
|
|
Q K ^PRC(443.6,PRCHPO),AMT,I,J,K,X,Y,Z,X1,X2,PRCH,PRCHCV,PRCHPO,PRCHAMT,PRCHAN,PRCHA,PRCHAV,PRCHAREC,PRCHL1,PRCHL2,PRCHLC,PRCHO,PRCHN,PRCHNPO,PRCHD0,PRCHP0,PRCHAC,PRCHACT,PRCHDA,PRCHDT,ROUTINE
|
|
D KILL^PRCHAM44 K PRCHAVLD,PRCHCHK,PRCHII,PRCHITR,PRCHITSB,PRCHQTY,PRCHRPTN,PRCHRPTO,PRCHSAM1,PRCHSAM2,PRCHJJ,PRCHMM,PRCHSHIP,PRCHXX1,NOFISCAL L Q
|