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

PRCHAMYA ;WISC/DJM-MOVING AMENDMENT INFO FROM 443.6 TO 442 ;3/23/95  2:01 PM

V ;;5.1;IFCAP;**6,21,59,74**;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

CHECK(PRCHPO,PRCHAM,FLAG) ;CHECK OUT EACH 'CHANGES' ENTRY.  IF THE OLD DATA AND THE NEW DATA

 ;ARE THE SAME REMOVE THE 'CHANGES' ENTRY.

 ;'PRCHPO' IS THE RECORD IN FILE 443.6 THAT WAS JUST OBLIGATED.

 ;'PRCHAM' IS THE AMENDMENT ,IN 'PRCHPO', THAT WAS JUST OBLIGATED.

 ;'FLAG' IS AN ERROR FLAG.  FOR NOW 'FLAG' WILL ONLY RETURN 1.

 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

 K PRCHNORE

 S PRCI=0,DIQ(0)="I",VALFLG=0

 ;LEAVE 'CHANGES' ENTRY 1 (THE ORGINAL VALUE OF THE 'NET AMOUNT' FIELD) ALONE.

 ;THIS ENTRY MUST STAY IN THE 'CHANGES' MULTIPLE BECAUSE IT IS NEEDED

 ;TO BE ABLE TO UPDATE THE FUND CONTROL POINT BALANCE AFTER THIS

 ;AMENDMENT IS OBLIGATED/SIGNED OFF.

 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

 .S PRCJ=$G(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0))

 .S J1=$P(PRCJ,U,3)

 .S J2=$P(J1,":",2),J3=$P($P(J1,";",2),":"),J4=$P(J1,";")

 .Q:$P(J3,".")=442

 .K DR

 .I J2>0 S DR=J2,DR(J3)=J4,DA(J3)=$P(PRCJ,U,4)

 .I J2="" S DR=J4

 .I $P(PRCJ,U,7)>0 S DIC=J3,DA=$P(PRCJ,U,7)

 .S DIQ="FIELD" D EN^DIQ1

 .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

 ..F  S VAL1=$O(FIELD(443.61,PRCJ1,1,VAL1)) Q:VAL1'>0  S X=$G(FIELD(443.61,PRCJ1,1,VAL1)) D ^DIWP

 ..S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR

 ..S VAL1=0 K ^UTILITY($J,"W")

 ..F  S VAL1=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,VAL1)) Q:VAL1'>0  S X=(^(VAL1,0)) D ^DIWP

 ..I ^TMP($J,"W",1)'=^UTILITY($J,"W",1) S EXIT=1 Q

 ..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

 ..Q

 .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"))

 .S CHECK=^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,1,0)

 .I CHECK'=VAL,VAL'="" D  G FIX

 ..;

 ..;Update contract changes (See MEM-0596-70183)

 ..I $P($P(PRCJ,U,2,3),":")="23^4;443.61" D  ;

 ...KILL ^PRC(442,PRCHPO,2,"AC",CHECK,$P(PRCJ,U,4))

 ...S ^PRC(442,PRCHPO,2,"AC",VAL,$P(PRCJ,U,4))=""

 .;

 .I CHECK'=VAL,VAL="" S TYPAM=$P($G(PRCJ),U,2)

 .S VALFLG=0

 .S PPFLG=0

 .I $G(TYPAM)=28,(VAL="") S VALFLG=1

 .I $G(TYPAM)=33,(VAL="") S PPFLG=1

 .I $G(TYPAM) I TYPAM=28!(TYPAM=29)!(TYPAM=37) G FIX

REMOVE .S DR=".01///@",DIE="^PRC(443.6,"_PRCHPO_",6,"_PRCHAM_",3,",DA(2)=PRCHPO,DA(1)=PRCHAM,DA=PRCI D ^DIE Q

FIX .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:"")

 .S FX=J4_";"_J3_":"_J2,$P(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0),U,3)=FX

COPY ;THIS STEP WILL COPY THE P.O. FROM 443.6 BACK TO 442.

 ;FIRST GET THE PRESENT 'TOTAL AMOUNT' FIELD, #91.

 ;THIS VALUE IS NEEDED TO CALCULATE THE AMOUNT CHANGED.  THIS CHANGE

 ;WILL BE ENTERED INTO THE 'AMOUNT CHANGED' FIELD, FIELD 50 - SUBFIELD

 ;2, FOR THIS AMENDMENT.

 ;LATER ON, WITHIN THESE ROUTINES, THE 'TOTAL AMOUNT' FIELD WILL BE

 ;UPDATED.  THUS, SAVING IT HERE.

 S PRCHTOTQ=$P(^PRC(442,PRCHPO,0),U,15)

 K PRCHXXXX S %X="^PRC(443.6,"_PRCHPO_",",%Y="^PRC(442,"_PRCHPO_","

C2 ;ENTER HERE TO COPY NEW P.O. BACK INTO 442.  BOTH %X AND %Y NEED TO

 ;BE SET WHEN USING THIS ENTRY POINT.  'PRCHPO' NEEDS TO BE SET TO THE

 ;RECORD THAT IS TO BE COPIED.

 I $G(VALFLG) K ^PRC(442,PRCHPO,15) S VALFLG=0

 I $G(PPFLG) K ^PRC(442,PRCHPO,5) S PPFLG=0

 ;

 ;Delete current PO item description in file 442, so that it is

 ;properly updated with an amended item description from file 443.6

 ;See NOIS CTX-0296-70401 

 I J2=40,J4=1 D  ;

 . S ITEM1=""

 . F  S ITEM1=$O(PRCJ1(ITEM1)) Q:'ITEM1  D  ;

 . . S LINE=0 F  S LINE=$O(^PRC(442,PRCHPO,2,ITEM1,1,LINE)) Q:'LINE  D  ;

 . . . I $D(^PRC(442,PRCHPO,2,ITEM1,1,LINE,0)) D  ;  

 . . . . KILL ^PRC(442,PRCHPO,2,ITEM1,1,LINE,0)

 ;

 S HOLD=$G(^PRC(442,PRCHPO,6,0)) D %XY^%RCR

 ;

 ;The copy from 443.6 to 442 is done.  If an item does not have a

 ;contract number, but it has an AC cross reference then remove it.

 ;See NOIS: MEM-0596-70183

 I $D(^PRC(442,PRCHPO,2,"AC")) D  ;

 . NEW CONTRACT

 . S CONTRACT=""

 . F  S CONTRACT=$O(^PRC(442,PRCHPO,2,"AC",CONTRACT)) Q:CONTRACT=""  D

 . . I '$D(^PRC(443.6,PRCHPO,2,"AC",CONTRACT)) D

 . . . KILL ^PRC(442,PRCHPO,2,"AC",CONTRACT)

 ;

 ;There has been a change in vendor.  Update the files.

 ;See NOIS FGH-1202-32075

 N NEWVEN,OLDVEN,NODE,AMEND

 S NEWVEN=$G(FIELD(443.6,PRCHPO,5,"I"))

 I NEWVEN D  ;

 . S AMEND=$P(^PRC(443.6,PRCHPO,6,0),U,3)

 . S NODE=$O(^PRC(443.6,PRCHPO,6,AMEND,3,"AC",31,5,""))

 . S OLDVEN=^PRC(443.6,PRCHPO,6,AMEND,3,NODE,1,1,0)

 . I OLDVEN KILL ^PRC(442,"D",OLDVEN,PRCHPO)

 . S DA=PRCHPO,DR="5////"_NEWVEN,DIE="^PRC(442,"

 . D ^DIE

 ;

 ;There has been a change in Purchase Order number.

 ;See NOIS LOM-0302-62930

 I $P(PRCJ,U,2)=32 D  ;

 . NEW CP,NEWPO,VENDOR

 . S NEWPO=$P($G(^PRC(443.6,PRCHPO,23)),U,4)

 . Q:NEWPO=""

 . S VENDOR=$P($G(^PRC(443.6,PRCHPO,1)),U)

 . S CP=$P(PRC("CP")," ")          ;Control point

 . S ^PRC(442,"D",VENDOR,NEWPO)="" ;Set up "D" X-ref for PO display

 . S ^PRC(442,"E",CP,NEWPO)=""     ;Set up "E" X-ref for PO display

 . S CP=PRC("SITE")_CP             ;Station & control point

 . ;

 . ;Get items from PO to setup item master file history

 . NEW CNT,ITEM,ITEMNUM

 . S ITEMNUM=0

 . F  S ITEMNUM=$O(^PRC(443.6,PRCHPO,2,ITEMNUM)) Q:'ITEMNUM  D

 . . S ITEM=$P(^PRC(443.6,PRCHPO,2,ITEMNUM,0),U,5)

 . . QUIT:ITEM=""

 . . S ^PRC(441,ITEM,4,CP,1,NEWPO,0)=NEWPO

 . . S ^PRC(441,ITEM,4,CP,1,"AC",9999999-PRC("PODT"),NEWPO)=""

 . . S $P(^PRC(441,ITEM,4,CP,1,0),U,3)=NEWPO

 . . S CNT=$P(^PRC(441,ITEM,4,CP,1,0),U,4)

 . . S $P(^PRC(441,ITEM,4,CP,1,0),U,4)=CNT+1

 ;

 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

 S NEW=$G(^PRC(443.6,PRCHPO,23))

 S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES5(^PRC(442,PRCHPO,0),^PRC(442,PRCHPO,1),^PRC(442,PRCHPO,12)))

 S PRCSIG="" D RECODE^PRCHES5(PRCHPO,PRCSUM,.PRCSIG) S ROUTINE="PRCHAMYA"

 G:PRCSIG<1 QQ K PRCSUM

 ;AFTER MOVING INTO 442 NOW UPDATE ANY ZERO NODE OF A MULTIPLE FIELD

 ;FROM THE 'DD'

 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

 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

 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

 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

 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

 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

 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

 S PRCHPO=$S($D(PRCHXXXX):PRCHXXXX,1:PRCHPO)

 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

 G ^PRCHAMYB

QQ 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