- 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 Mar 13, 2025@21:10:47 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
