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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMYA 7696 printed Apr 09, 2024@21:20:50 Page 2
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
+1 ;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
+1 ;ARE THE SAME REMOVE THE 'CHANGES' ENTRY.
+2 ;'PRCHPO' IS THE RECORD IN FILE 443.6 THAT WAS JUST OBLIGATED.
+3 ;'PRCHAM' IS THE AMENDMENT ,IN 'PRCHPO', THAT WAS JUST OBLIGATED.
+4 ;'FLAG' IS AN ERROR FLAG. FOR NOW 'FLAG' WILL ONLY RETURN 1.
+5 NEW 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
+6 KILL PRCHNORE
+7 SET PRCI=0
SET DIQ(0)="I"
SET VALFLG=0
+8 ;LEAVE 'CHANGES' ENTRY 1 (THE ORGINAL VALUE OF THE 'NET AMOUNT' FIELD) ALONE.
+9 ;THIS ENTRY MUST STAY IN THE 'CHANGES' MULTIPLE BECAUSE IT IS NEEDED
+10 ;TO BE ABLE TO UPDATE THE FUND CONTROL POINT BALANCE AFTER THIS
+11 ;AMENDMENT IS OBLIGATED/SIGNED OFF.
+12 FOR
SET PRCI=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI))
if PRCI'>0
GOTO COPY
SET DA=PRCHPO
SET DIC=443.6
if PRCI>1
Begin DoDot:1
+13 SET PRCJ=$GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0))
+14 SET J1=$PIECE(PRCJ,U,3)
+15 SET J2=$PIECE(J1,":",2)
SET J3=$PIECE($PIECE(J1,";",2),":")
SET J4=$PIECE(J1,";")
+16 if $PIECE(J3,".")=442
QUIT
+17 KILL DR
+18 IF J2>0
SET DR=J2
SET DR(J3)=J4
SET DA(J3)=$PIECE(PRCJ,U,4)
+19 IF J2=""
SET DR=J4
+20 IF $PIECE(PRCJ,U,7)>0
SET DIC=J3
SET DA=$PIECE(PRCJ,U,7)
+21 SET DIQ="FIELD"
DO EN^DIQ1
+22 IF J2=40
IF J4=1
KILL ^UTILITY($JOB,"W"),^TMP($JOB,"W")
SET EXIT=0
SET VAL1=0
SET DIWL=1
SET DIWR=80
SET DIWF="C80|"
SET PRCJ1=$PIECE(PRCJ,U,4)
SET PRCJ1(PRCJ1)=""
Begin DoDot:2
+23 FOR
SET VAL1=$ORDER(FIELD(443.61,PRCJ1,1,VAL1))
if VAL1'>0
QUIT
SET X=$GET(FIELD(443.61,PRCJ1,1,VAL1))
DO ^DIWP
+24 SET %X="^UTILITY($J,""W"","
SET %Y="^TMP($J,""W"","
DO %XY^%RCR
+25 SET VAL1=0
KILL ^UTILITY($JOB,"W")
+26 FOR
SET VAL1=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,VAL1))
if VAL1'>0
QUIT
SET X=(^(VAL1,0))
DO ^DIWP
+27 IF ^TMP($JOB,"W",1)'=^UTILITY($JOB,"W",1)
SET EXIT=1
QUIT
+28 SET VAL1=0
FOR
SET VAL1=$ORDER(^TMP($JOB,"W",1,VAL1))
if VAL1'>0
QUIT
IF $GET(^TMP($JOB,"W",1,VAL1,0))'=$GET(^UTILITY($JOB,"W",1,VAL1,0))
SET EXIT=1
QUIT
+29 QUIT
End DoDot:2
if EXIT=1
GOTO FIX
GOTO REMOVE
+30 SET VAL=$GET(FIELD($SELECT(J3>0:J3,1:443.6),$SELECT(J3["443.6":$PIECE(PRCJ,U,4),J3["441.7":$PIECE(PRCJ,U,7),1:PRCHPO),J4,"I"))
+31 SET CHECK=^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,1,0)
+32 IF CHECK'=VAL
IF VAL'=""
Begin DoDot:2
+33 ;
+34 ;Update contract changes (See MEM-0596-70183)
+35 ;
IF $PIECE($PIECE(PRCJ,U,2,3),":")="23^4;443.61"
Begin DoDot:3
+36 KILL ^PRC(442,PRCHPO,2,"AC",CHECK,$PIECE(PRCJ,U,4))
+37 SET ^PRC(442,PRCHPO,2,"AC",VAL,$PIECE(PRCJ,U,4))=""
End DoDot:3
End DoDot:2
GOTO FIX
+38 ;
+39 IF CHECK'=VAL
IF VAL=""
SET TYPAM=$PIECE($GET(PRCJ),U,2)
+40 SET VALFLG=0
+41 SET PPFLG=0
+42 IF $GET(TYPAM)=28
IF (VAL="")
SET VALFLG=1
+43 IF $GET(TYPAM)=33
IF (VAL="")
SET PPFLG=1
+44 IF $GET(TYPAM)
IF TYPAM=28!(TYPAM=29)!(TYPAM=37)
GOTO FIX
REMOVE SET DR=".01///@"
SET DIE="^PRC(443.6,"_PRCHPO_",6,"_PRCHAM_",3,"
SET DA(2)=PRCHPO
SET DA(1)=PRCHAM
SET DA=PRCI
DO ^DIE
QUIT
FIX SET J3=$SELECT(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:"")
+1 SET FX=J4_";"_J3_":"_J2
SET $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0),U,3)=FX
End DoDot:1
COPY ;THIS STEP WILL COPY THE P.O. FROM 443.6 BACK TO 442.
+1 ;FIRST GET THE PRESENT 'TOTAL AMOUNT' FIELD, #91.
+2 ;THIS VALUE IS NEEDED TO CALCULATE THE AMOUNT CHANGED. THIS CHANGE
+3 ;WILL BE ENTERED INTO THE 'AMOUNT CHANGED' FIELD, FIELD 50 - SUBFIELD
+4 ;2, FOR THIS AMENDMENT.
+5 ;LATER ON, WITHIN THESE ROUTINES, THE 'TOTAL AMOUNT' FIELD WILL BE
+6 ;UPDATED. THUS, SAVING IT HERE.
+7 SET PRCHTOTQ=$PIECE(^PRC(442,PRCHPO,0),U,15)
+8 KILL PRCHXXXX
SET %X="^PRC(443.6,"_PRCHPO_","
SET %Y="^PRC(442,"_PRCHPO_","
C2 ;ENTER HERE TO COPY NEW P.O. BACK INTO 442. BOTH %X AND %Y NEED TO
+1 ;BE SET WHEN USING THIS ENTRY POINT. 'PRCHPO' NEEDS TO BE SET TO THE
+2 ;RECORD THAT IS TO BE COPIED.
+3 IF $GET(VALFLG)
KILL ^PRC(442,PRCHPO,15)
SET VALFLG=0
+4 IF $GET(PPFLG)
KILL ^PRC(442,PRCHPO,5)
SET PPFLG=0
+5 ;
+6 ;Delete current PO item description in file 442, so that it is
+7 ;properly updated with an amended item description from file 443.6
+8 ;See NOIS CTX-0296-70401
+9 ;
IF J2=40
IF J4=1
Begin DoDot:1
+10 SET ITEM1=""
+11 ;
FOR
SET ITEM1=$ORDER(PRCJ1(ITEM1))
if 'ITEM1
QUIT
Begin DoDot:2
+12 ;
SET LINE=0
FOR
SET LINE=$ORDER(^PRC(442,PRCHPO,2,ITEM1,1,LINE))
if 'LINE
QUIT
Begin DoDot:3
+13 ;
IF $DATA(^PRC(442,PRCHPO,2,ITEM1,1,LINE,0))
Begin DoDot:4
+14 KILL ^PRC(442,PRCHPO,2,ITEM1,1,LINE,0)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 SET HOLD=$GET(^PRC(442,PRCHPO,6,0))
DO %XY^%RCR
+17 ;
+18 ;The copy from 443.6 to 442 is done. If an item does not have a
+19 ;contract number, but it has an AC cross reference then remove it.
+20 ;See NOIS: MEM-0596-70183
+21 ;
IF $DATA(^PRC(442,PRCHPO,2,"AC"))
Begin DoDot:1
+22 NEW CONTRACT
+23 SET CONTRACT=""
+24 FOR
SET CONTRACT=$ORDER(^PRC(442,PRCHPO,2,"AC",CONTRACT))
if CONTRACT=""
QUIT
Begin DoDot:2
+25 IF '$DATA(^PRC(443.6,PRCHPO,2,"AC",CONTRACT))
Begin DoDot:3
+26 KILL ^PRC(442,PRCHPO,2,"AC",CONTRACT)
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ;There has been a change in vendor. Update the files.
+29 ;See NOIS FGH-1202-32075
+30 NEW NEWVEN,OLDVEN,NODE,AMEND
+31 SET NEWVEN=$GET(FIELD(443.6,PRCHPO,5,"I"))
+32 ;
IF NEWVEN
Begin DoDot:1
+33 SET AMEND=$PIECE(^PRC(443.6,PRCHPO,6,0),U,3)
+34 SET NODE=$ORDER(^PRC(443.6,PRCHPO,6,AMEND,3,"AC",31,5,""))
+35 SET OLDVEN=^PRC(443.6,PRCHPO,6,AMEND,3,NODE,1,1,0)
+36 IF OLDVEN
KILL ^PRC(442,"D",OLDVEN,PRCHPO)
+37 SET DA=PRCHPO
SET DR="5////"_NEWVEN
SET DIE="^PRC(442,"
+38 DO ^DIE
End DoDot:1
+39 ;
+40 ;There has been a change in Purchase Order number.
+41 ;See NOIS LOM-0302-62930
+42 ;
IF $PIECE(PRCJ,U,2)=32
Begin DoDot:1
+43 NEW CP,NEWPO,VENDOR
+44 SET NEWPO=$PIECE($GET(^PRC(443.6,PRCHPO,23)),U,4)
+45 if NEWPO=""
QUIT
+46 SET VENDOR=$PIECE($GET(^PRC(443.6,PRCHPO,1)),U)
+47 ;Control point
SET CP=$PIECE(PRC("CP")," ")
+48 ;Set up "D" X-ref for PO display
SET ^PRC(442,"D",VENDOR,NEWPO)=""
+49 ;Set up "E" X-ref for PO display
SET ^PRC(442,"E",CP,NEWPO)=""
+50 ;Station & control point
SET CP=PRC("SITE")_CP
+51 ;
+52 ;Get items from PO to setup item master file history
+53 NEW CNT,ITEM,ITEMNUM
+54 SET ITEMNUM=0
+55 FOR
SET ITEMNUM=$ORDER(^PRC(443.6,PRCHPO,2,ITEMNUM))
if 'ITEMNUM
QUIT
Begin DoDot:2
+56 SET ITEM=$PIECE(^PRC(443.6,PRCHPO,2,ITEMNUM,0),U,5)
+57 if ITEM=""
QUIT
+58 SET ^PRC(441,ITEM,4,CP,1,NEWPO,0)=NEWPO
+59 SET ^PRC(441,ITEM,4,CP,1,"AC",9999999-PRC("PODT"),NEWPO)=""
+60 SET $PIECE(^PRC(441,ITEM,4,CP,1,0),U,3)=NEWPO
+61 SET CNT=$PIECE(^PRC(441,ITEM,4,CP,1,0),U,4)
+62 SET $PIECE(^PRC(441,ITEM,4,CP,1,0),U,4)=CNT+1
End DoDot:2
End DoDot:1
+63 ;
+64 IF HOLD]""
SET $PIECE(HOLD,U,3)=PRCHAM
SET $PIECE(HOLD,U,4)=$PIECE(HOLD,U,4)+1
SET $PIECE(HOLD,U,2)=$PIECE(^DD(442,50,0),U,2)
SET ^PRC(442,PRCHPO,6,0)=HOLD
+65 SET NEW=$GET(^PRC(443.6,PRCHPO,23))
+66 SET PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES5(^PRC(442,PRCHPO,0),^PRC(442,PRCHPO,1),^PRC(442,PRCHPO,12)))
+67 SET PRCSIG=""
DO RECODE^PRCHES5(PRCHPO,PRCSUM,.PRCSIG)
SET ROUTINE="PRCHAMYA"
+68 if PRCSIG<1
GOTO QQ
KILL PRCSUM
+69 ;AFTER MOVING INTO 442 NOW UPDATE ANY ZERO NODE OF A MULTIPLE FIELD
+70 ;FROM THE 'DD'
+71 SET ITEM=$GET(^PRC(442,PRCHPO,2,0))
SET $PIECE(ITEM,U,2)=$PIECE(^DD(442,40,0),U,2)
SET ^PRC(442,PRCHPO,2,0)=ITEM
+72 SET DISCNT=$GET(^PRC(442,PRCHPO,3,0))
IF DISCNT]""
SET $PIECE(DISCNT,U,2)=$PIECE(^DD(442,14,0),U,2)
SET ^PRC(442,PRCHPO,3,0)=DISCNT
+73 SET PROMPT=$GET(^PRC(442,PRCHPO,5,0))
IF PROMPT]""
SET $PIECE(PROMPT,U,2)=$PIECE(^DD(442,9.2,0),U,2)
SET ^PRC(442,PRCHPO,5,0)=PROMPT
+74 SET CHANGS=$GET(^PRC(442,PRCHPO,6,0))
IF CHANGS]""
SET $PIECE(CHANGS,U,2)=$PIECE(^DD(442,50,0),U,2)
SET ^PRC(442,PRCHPO,6,0)=CHANGS
+75 SET CHANGS=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,0))
IF CHANGS]""
SET $PIECE(CHANGS,U,2)=$PIECE(^DD(442.07,14,0),U,2)
SET ^PRC(442,PRCHPO,6,PRCHAM,3,0)=CHANGS
+76 SET CERT=$GET(^PRC(442,PRCHPO,15,0))
IF CERT]""
SET $PIECE(CERT,U,2)=$PIECE(^DD(442,24,0),U,2)
SET ^PRC(442,PRCHPO,15,0)=CERT
+77 IF NEW]""&($PIECE(NEW,U,4)>0)&($PIECE(NEW,U,4)'=PRCHPO)
SET PRCHXXXX=PRCHPO
SET PRCHPO=$PIECE(NEW,U,4)
SET %X="^PRC(443.6,"_PRCHPO_","
SET %Y="^PRC(442,"_PRCHPO_","
GOTO C2
+78 SET PRCHPO=$SELECT($DATA(PRCHXXXX):PRCHXXXX,1:PRCHPO)
+79 SET DA(1)=PRCHPO
SET N=0
SET DIK(1)=".01^C"
FOR
SET N=$ORDER(^PRC(442,DA(1),2,N))
if 'N
QUIT
Begin DoDot:1
+80 SET DA=N
SET DIK="^PRC(442,"_DA(1)_",2,"
DO EN^DIK
End DoDot:1
+81 KILL DA,DIK,N
+82 GOTO ^PRCHAMYB
QQ WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
if PRCSIG=0!(PRCSIG=-3)
WRITE !,"Notify Application Coordinator!"
SET DIR(0)="EAO"
SET DIR("A")="Press <Return> to continue "
DO ^DIR
SET FLAG=1
QUIT
