source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMYA.m@ 1240

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

initial load of WorldVistAEHR
File size: 7.4 KB
Line 
1PRCHAMYA ;WISC/DJM-MOVING AMENDMENT INFO FROM 443.6 TO 442 ;3/23/95 2:01 PM
2V ;;5.1;IFCAP;**6,21,59,74**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4CHECK(PRCHPO,PRCHAM,FLAG) ;CHECK OUT EACH 'CHANGES' ENTRY. IF THE OLD DATA AND THE NEW DATA
5 ;ARE THE SAME REMOVE THE 'CHANGES' ENTRY.
6 ;'PRCHPO' IS THE RECORD IN FILE 443.6 THAT WAS JUST OBLIGATED.
7 ;'PRCHAM' IS THE AMENDMENT ,IN 'PRCHPO', THAT WAS JUST OBLIGATED.
8 ;'FLAG' IS AN ERROR FLAG. FOR NOW 'FLAG' WILL ONLY RETURN 1.
9 N PRCI,CERT,CHANGS,PRCI,DIQ,DIC,PRCJ,J1,J2,J3,J4,DR,VAL,DIE,FX,PRCHTOTQ,PRCHXXXX,%X,%Y,HOLD,NEW,PRCSUM,PRCSIG,ROUTINE,ITEM,DISCNT,PROMPT,DIR,CHECK,DA,FIELD,FLAG,PRCJ1,PRCJ2,VAL1,EXIT,DIWL,DIWR,DIWF,TYPAM,VALFLG,PPFLG,LINE,ITEM1
10 K PRCHNORE
11 S PRCI=0,DIQ(0)="I",VALFLG=0
12 ;LEAVE 'CHANGES' ENTRY 1 (THE ORGINAL VALUE OF THE 'NET AMOUNT' FIELD) ALONE.
13 ;THIS ENTRY MUST STAY IN THE 'CHANGES' MULTIPLE BECAUSE IT IS NEEDED
14 ;TO BE ABLE TO UPDATE THE FUND CONTROL POINT BALANCE AFTER THIS
15 ;AMENDMENT IS OBLIGATED/SIGNED OFF.
16 F S PRCI=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI)) G:PRCI'>0 COPY S DA=PRCHPO,DIC=443.6 D:PRCI>1
17 .S PRCJ=$G(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0))
18 .S J1=$P(PRCJ,U,3)
19 .S J2=$P(J1,":",2),J3=$P($P(J1,";",2),":"),J4=$P(J1,";")
20 .Q:$P(J3,".")=442
21 .K DR
22 .I J2>0 S DR=J2,DR(J3)=J4,DA(J3)=$P(PRCJ,U,4)
23 .I J2="" S DR=J4
24 .I $P(PRCJ,U,7)>0 S DIC=J3,DA=$P(PRCJ,U,7)
25 .S DIQ="FIELD" D EN^DIQ1
26 .I J2=40,J4=1 K ^UTILITY($J,"W"),^TMP($J,"W") S EXIT=0,VAL1=0,DIWL=1,DIWR=80,DIWF="C80|",PRCJ1=$P(PRCJ,U,4),PRCJ1(PRCJ1)="" D G FIX:EXIT=1,REMOVE
27 ..F S VAL1=$O(FIELD(443.61,PRCJ1,1,VAL1)) Q:VAL1'>0 S X=$G(FIELD(443.61,PRCJ1,1,VAL1)) D ^DIWP
28 ..S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
29 ..S VAL1=0 K ^UTILITY($J,"W")
30 ..F S VAL1=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,VAL1)) Q:VAL1'>0 S X=(^(VAL1,0)) D ^DIWP
31 ..I ^TMP($J,"W",1)'=^UTILITY($J,"W",1) S EXIT=1 Q
32 ..S VAL1=0 F S VAL1=$O(^TMP($J,"W",1,VAL1)) Q:VAL1'>0 I $G(^TMP($J,"W",1,VAL1,0))'=$G(^UTILITY($J,"W",1,VAL1,0)) S EXIT=1 Q
33 ..Q
34 .S VAL=$G(FIELD($S(J3>0:J3,1:443.6),$S(J3["443.6":$P(PRCJ,U,4),J3["441.7":$P(PRCJ,U,7),1:PRCHPO),J4,"I"))
35 .S CHECK=^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,1,0)
36 .I CHECK'=VAL,VAL'="" D G FIX
37 ..;
38 ..;Update contract changes (See MEM-0596-70183)
39 ..I $P($P(PRCJ,U,2,3),":")="23^4;443.61" D ;
40 ...KILL ^PRC(442,PRCHPO,2,"AC",CHECK,$P(PRCJ,U,4))
41 ...S ^PRC(442,PRCHPO,2,"AC",VAL,$P(PRCJ,U,4))=""
42 .;
43 .I CHECK'=VAL,VAL="" S TYPAM=$P($G(PRCJ),U,2)
44 .S VALFLG=0
45 .S PPFLG=0
46 .I $G(TYPAM)=28,(VAL="") S VALFLG=1
47 .I $G(TYPAM)=33,(VAL="") S PPFLG=1
48 .I $G(TYPAM) I TYPAM=28!(TYPAM=29)!(TYPAM=37) G FIX
49REMOVE .S DR=".01///@",DIE="^PRC(443.6,"_PRCHPO_",6,"_PRCHAM_",3,",DA(2)=PRCHPO,DA(1)=PRCHAM,DA=PRCI D ^DIE Q
50FIX .S J3=$S(J3=443.61:442.01,J3=443.66:442.06,J3=443.67:442.07,J3=443.624:442.15,J3=443.63:442.03,J3=441.7:442.8,1:"")
51 .S FX=J4_";"_J3_":"_J2,$P(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0),U,3)=FX
52COPY ;THIS STEP WILL COPY THE P.O. FROM 443.6 BACK TO 442.
53 ;FIRST GET THE PRESENT 'TOTAL AMOUNT' FIELD, #91.
54 ;THIS VALUE IS NEEDED TO CALCULATE THE AMOUNT CHANGED. THIS CHANGE
55 ;WILL BE ENTERED INTO THE 'AMOUNT CHANGED' FIELD, FIELD 50 - SUBFIELD
56 ;2, FOR THIS AMENDMENT.
57 ;LATER ON, WITHIN THESE ROUTINES, THE 'TOTAL AMOUNT' FIELD WILL BE
58 ;UPDATED. THUS, SAVING IT HERE.
59 S PRCHTOTQ=$P(^PRC(442,PRCHPO,0),U,15)
60 K PRCHXXXX S %X="^PRC(443.6,"_PRCHPO_",",%Y="^PRC(442,"_PRCHPO_","
61C2 ;ENTER HERE TO COPY NEW P.O. BACK INTO 442. BOTH %X AND %Y NEED TO
62 ;BE SET WHEN USING THIS ENTRY POINT. 'PRCHPO' NEEDS TO BE SET TO THE
63 ;RECORD THAT IS TO BE COPIED.
64 I $G(VALFLG) K ^PRC(442,PRCHPO,15) S VALFLG=0
65 I $G(PPFLG) K ^PRC(442,PRCHPO,5) S PPFLG=0
66 ;
67 ;Delete current PO item description in file 442, so that it is
68 ;properly updated with an amended item description from file 443.6
69 ;See NOIS CTX-0296-70401
70 I J2=40,J4=1 D ;
71 . S ITEM1=""
72 . F S ITEM1=$O(PRCJ1(ITEM1)) Q:'ITEM1 D ;
73 . . S LINE=0 F S LINE=$O(^PRC(442,PRCHPO,2,ITEM1,1,LINE)) Q:'LINE D ;
74 . . . I $D(^PRC(442,PRCHPO,2,ITEM1,1,LINE,0)) D ;
75 . . . . KILL ^PRC(442,PRCHPO,2,ITEM1,1,LINE,0)
76 ;
77 S HOLD=$G(^PRC(442,PRCHPO,6,0)) D %XY^%RCR
78 ;
79 ;The copy from 443.6 to 442 is done. If an item does not have a
80 ;contract number, but it has an AC cross reference then remove it.
81 ;See NOIS: MEM-0596-70183
82 I $D(^PRC(442,PRCHPO,2,"AC")) D ;
83 . NEW CONTRACT
84 . S CONTRACT=""
85 . F S CONTRACT=$O(^PRC(442,PRCHPO,2,"AC",CONTRACT)) Q:CONTRACT="" D
86 . . I '$D(^PRC(443.6,PRCHPO,2,"AC",CONTRACT)) D
87 . . . KILL ^PRC(442,PRCHPO,2,"AC",CONTRACT)
88 ;
89 ;There has been a change in vendor. Update the files.
90 ;See NOIS FGH-1202-32075
91 N NEWVEN,OLDVEN,NODE,AMEND
92 S NEWVEN=$G(FIELD(443.6,PRCHPO,5,"I"))
93 I NEWVEN D ;
94 . S AMEND=$P(^PRC(443.6,PRCHPO,6,0),U,3)
95 . S NODE=$O(^PRC(443.6,PRCHPO,6,AMEND,3,"AC",31,5,""))
96 . S OLDVEN=^PRC(443.6,PRCHPO,6,AMEND,3,NODE,1,1,0)
97 . I OLDVEN KILL ^PRC(442,"D",OLDVEN,PRCHPO)
98 . S DA=PRCHPO,DR="5////"_NEWVEN,DIE="^PRC(442,"
99 . D ^DIE
100 ;
101 ;There has been a change in Purchase Order number.
102 ;See NOIS LOM-0302-62930
103 I $P(PRCJ,U,2)=32 D ;
104 . NEW CP,NEWPO,VENDOR
105 . S NEWPO=$P($G(^PRC(443.6,PRCHPO,23)),U,4)
106 . Q:NEWPO=""
107 . S VENDOR=$P($G(^PRC(443.6,PRCHPO,1)),U)
108 . S CP=$P(PRC("CP")," ") ;Control point
109 . S ^PRC(442,"D",VENDOR,NEWPO)="" ;Set up "D" X-ref for PO display
110 . S ^PRC(442,"E",CP,NEWPO)="" ;Set up "E" X-ref for PO display
111 . S CP=PRC("SITE")_CP ;Station & control point
112 . ;
113 . ;Get items from PO to setup item master file history
114 . NEW CNT,ITEM,ITEMNUM
115 . S ITEMNUM=0
116 . F S ITEMNUM=$O(^PRC(443.6,PRCHPO,2,ITEMNUM)) Q:'ITEMNUM D
117 . . S ITEM=$P(^PRC(443.6,PRCHPO,2,ITEMNUM,0),U,5)
118 . . QUIT:ITEM=""
119 . . S ^PRC(441,ITEM,4,CP,1,NEWPO,0)=NEWPO
120 . . S ^PRC(441,ITEM,4,CP,1,"AC",9999999-PRC("PODT"),NEWPO)=""
121 . . S $P(^PRC(441,ITEM,4,CP,1,0),U,3)=NEWPO
122 . . S CNT=$P(^PRC(441,ITEM,4,CP,1,0),U,4)
123 . . S $P(^PRC(441,ITEM,4,CP,1,0),U,4)=CNT+1
124 ;
125 I HOLD]"" S $P(HOLD,U,3)=PRCHAM,$P(HOLD,U,4)=$P(HOLD,U,4)+1,$P(HOLD,U,2)=$P(^DD(442,50,0),U,2),^PRC(442,PRCHPO,6,0)=HOLD
126 S NEW=$G(^PRC(443.6,PRCHPO,23))
127 S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES5(^PRC(442,PRCHPO,0),^PRC(442,PRCHPO,1),^PRC(442,PRCHPO,12)))
128 S PRCSIG="" D RECODE^PRCHES5(PRCHPO,PRCSUM,.PRCSIG) S ROUTINE="PRCHAMYA"
129 G:PRCSIG<1 QQ K PRCSUM
130 ;AFTER MOVING INTO 442 NOW UPDATE ANY ZERO NODE OF A MULTIPLE FIELD
131 ;FROM THE 'DD'
132 S ITEM=$G(^PRC(442,PRCHPO,2,0)),$P(ITEM,U,2)=$P(^DD(442,40,0),U,2),^PRC(442,PRCHPO,2,0)=ITEM
133 S DISCNT=$G(^PRC(442,PRCHPO,3,0)) I DISCNT]"" S $P(DISCNT,U,2)=$P(^DD(442,14,0),U,2),^PRC(442,PRCHPO,3,0)=DISCNT
134 S PROMPT=$G(^PRC(442,PRCHPO,5,0)) I PROMPT]"" S $P(PROMPT,U,2)=$P(^DD(442,9.2,0),U,2),^PRC(442,PRCHPO,5,0)=PROMPT
135 S CHANGS=$G(^PRC(442,PRCHPO,6,0)) I CHANGS]"" S $P(CHANGS,U,2)=$P(^DD(442,50,0),U,2),^PRC(442,PRCHPO,6,0)=CHANGS
136 S CHANGS=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)) I CHANGS]"" S $P(CHANGS,U,2)=$P(^DD(442.07,14,0),U,2),^PRC(442,PRCHPO,6,PRCHAM,3,0)=CHANGS
137 S CERT=$G(^PRC(442,PRCHPO,15,0)) I CERT]"" S $P(CERT,U,2)=$P(^DD(442,24,0),U,2),^PRC(442,PRCHPO,15,0)=CERT
138 I NEW]""&($P(NEW,U,4)>0)&($P(NEW,U,4)'=PRCHPO) S PRCHXXXX=PRCHPO,PRCHPO=$P(NEW,U,4),%X="^PRC(443.6,"_PRCHPO_",",%Y="^PRC(442,"_PRCHPO_"," G C2
139 S PRCHPO=$S($D(PRCHXXXX):PRCHXXXX,1:PRCHPO)
140 S DA(1)=PRCHPO,N=0,DIK(1)=".01^C" F S N=$O(^PRC(442,DA(1),2,N)) Q:'N D
141 .S DA=N,DIK="^PRC(442,"_DA(1)_",2," D EN^DIK
142 K DA,DIK,N
143 G ^PRCHAMYB
144QQ W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!" S DIR(0)="EAO",DIR("A")="Press <Return> to continue " D ^DIR S FLAG=1 Q
Note: See TracBrowser for help on using the repository browser.