source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAM.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.6 KB
Line 
1PRCHAM ;WOIFO/ID/RSD,SF-ISC/TKW/BGJ/AS-AMENDMENTS TO P.O. ;3/8/05
2V ;;5.1;IFCAP;**14,38,81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ENAV 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
5 I $D(^PRC(442,PRCHPO,6)) F I=0:0 S I=$O(^PRC(442,PRCHPO,6,I)) Q:'I S PRCHAN=I
6 S PRCHAN=PRCHAN+1 W !?5,"Adjustment number: ",PRCHAN S %=1,%A=" Do you wish to continue",%B="" D ^PRCFYN G:%'=1 Q
7 S:'$D(PRCHAM) PRCHAM=PRCHAN
8 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]"
9 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
10 S PRCHLC=$P(PRCH(0),U,14) Q:$D(PRCHAV) G ^PRCHAM1
11EN S X=PRCHL1_PRCHO_PRCHL2_PRCHN,J=0,PRCHCHK=1 S:'$D(^PRC(443.6,PRCHPO,6,PRCHAN,2,0)) ^(0)="^^^^"_DT
12 F I=0:0 S I=$O(^PRC(443.6,PRCHPO,6,PRCHAN,2,I)) Q:'I S J=J+1
13 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
14EN1 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
15 S ^PRC(443.6,PRCHPO,6,PRCHAN,2,0)="^^"_J_U_J_DT,^(J+1,0)=" " K ^TMP("PRCHW",$J) Q
16CHK 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
17 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
18 I PRCHDL D UPDT^PRCHAM3
19EN2 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
20 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
21 I $P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^(0),U,2)=26) S NOFISCAL=1
22 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
23 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
24 I P'=DUZ D ESIG^PRCHAM44
25 S DA=PRCHPO S PRCSIG="" D ESIG^PRCUESIG(P,.PRCSIG) I PRCSIG<1 S ROUTINE="PRCUESIG" G QQ
26 S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES5(^PRC(442,PRCHPO,0),^PRC(442,PRCHPO,1),^PRC(442,PRCHPO,12)))
27 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
28 S PRCSIG="" D RECODE^PRCHES12(PRCHPO,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM
29 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)
30 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)
31 D WAIT^DICD
32 ;
33 ;Check for any Adjustment for PO. If any, save the Adjustment Number
34 ;at Partial node and save the Partial Number at Adjustment Node.
35 ;If no Adjustment on PO then skip it. Patch PRC*5.1*38
36 ;
37ADJESIG G:'$D(^PRC(443.6,PRCHPO,6,0)) SKIPIT
38 S ADJDATA=$G(^PRC(443.6,PRCHPO,6,PRCHAN,0))
39 I $P(ADJDATA,U,8)'="Y" G SKIPIT
40 S PRTDATA=$G(^PRC(443.6,PRCHPO,11,PRCHAV,0))
41 S $P(PRTDATA,U,21)=PRCHAN
42 S ^PRC(443.6,PRCHPO,11,PRCHAV,0)=PRTDATA
43 S $P(ADJDATA,U,13)=PRCHAV
44 S ^PRC(443.6,PRCHPO,6,PRCHAN,0)=ADJDATA
45 K ADJDATA,PRTDATA
46 ;
47SKIPIT 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)
48 I $D(^PRC(442,PRCHPO,6,0)) D
49 . S $P(^PRC(442,PRCHPO,6,PRCHAN,0),U,12)=""
50 I '$D(PRCHAV) G JMP
51 S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES1(^PRC(442,PRCHPO,11,PRCHAV,0)))
52 S PRCSIG="" D RECODE^PRCHES1(PRCHPO,PRCHAV,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM
53 ; Transmit RR Adj info to DynaMed **81**
54 D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ENT^PRCVRRA(PRCHPO,PRCHAV)
55 ;
56 I $P(^PRC(442,PRCHPO,11,PRCHAV,0),U,16)="" G JMP
57 S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES2(^PRC(442,PRCHPO,11,PRCHAV,0),^PRC(442,PRCHPO,11,PRCHAV,1)))
58 S PRCSIG="" D RECODE^PRCHES2(PRCHPO,PRCHAV,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM,PRCHNFLG
59JMP D SETC^PRCHAM4
60 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)=""
61 S DA(1)=PRCHPO,N=0,DIK(1)=".01^C" F S N=$O(^PRC(442,DA(1),2,N)) Q:'N D
62 .S DA=N,DIK="^PRC(442,"_DA(1)_",2," D EN^DIK
63 K DA,DIK,N
64 I '$D(DT) D NOW^%DTC S DT=$P(%,".",1)
65 S PRCHCV=$S($D(^PRC(442,PRCHPO,1)):+^(1),1:0) ;I PRCHCV D ENUI^PRCHAM5
66 S DA=PRCHPO D UPDATE^PRCPWIU
67 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAN D ^PRCHSF S D0=PRCHPO,D1=PRCHAN D ^PRCHQUE K ZTSK
68 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
69 G Q
70QQ S:'$D(ROUTINE) ROUTINE=$T(+0)
71 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
72Q 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
73 D KILL^PRCHAM44 K PRCHAVLD,PRCHCHK,PRCHII,PRCHITR,PRCHITSB,PRCHQTY,PRCHRPTN,PRCHRPTO,PRCHSAM1,PRCHSAM2,PRCHJJ,PRCHMM,PRCHSHIP,PRCHXX1,NOFISCAL L Q
Note: See TracBrowser for help on using the repository browser.