- PRCHAM1 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;3/29/93 10:03
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ASK K ^TMP("PRCHW",$J) S DIC="^PRCD(442.2,",DIC("S")="I Y>19,($P(^(0),U,3)]"""")" S:$D(PRCHNRQ) DIC("S")=DIC("S")_",(""25;26;28;35;36""'[Y)" S DIC(0)="QEAZ"
- D ^DIC G:Y<0 CHK^PRCHAM K DIC I '$D(^PRCD(442.2,+Y,1)) W !!?5,"Amendment Lines in file 442.2 not defined " G ASK
- S ROU=$P(Y(0),U,3),PRCHL1=$P(^PRCD(442.2,+Y,1),U,1),PRCHL2=$P(^(1),U,2) I $L($T(@ROU))<2 W !!?5,"Routine line not defined " G ASK
- S PRCHT=1 D @ROU G ASK:PRCHT D EN^PRCHAM G ASK
- ;S PRCHT=1 D @ROU S:'$D(PRCHT) PRCHT=1 G ASK:PRCHT D EN^PRCHAM G ASK
- DIE S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE Q
- EN1 ;P.O. CANCEL
- S X=0 F I=0:0 S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,12) Q:X
- I X W !?5,"PURCHASE ORDER HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) Q
- S %="",%A=" SURE YOU WANT TO CANCEL PURCHASE ORDER ",%B="" D ^PRCFYN I %'=1 W ?40,"<NOTHING CANCELLED>" Q
- S $P(^PRC(443.6,PRCHPO,6,PRCHAN,1),U,4)=$O(^PRCD(442.3,"C",45,0)),PRCHO=$P($P(PRCH(0),U,1),"-",2),PRCHN=".",PRCHCHK=1,PRCHT=0,PRCHAMT=-$P(PRCH(0),U,15) Q
- EN2 ;VENDOR EDIT
- S PRCHO=+PRCH(1),DR=5 D DIE S PRCHN=+^PRC(443.6,PRCHPO,1) Q:PRCHO=PRCHN
- S PRCHX(PRCHO,PRCHN)="^PRC(442,""D"",X,PRCHPO)",PRCHO=$S($D(^PRC(440,PRCHO,0)):$P(^(0),U,1),1:""),PRCHN=$S($D(^PRC(440,PRCHN,0)):$P(^(0),U,1),1:"")
- S PRCHT=0,PRCHDL=1
- Q
- EN3 ;REPLACE P.O. # THIS OPTION DOESN'T SEEM TO WORK CORRECTLY.
- S PRCHO=$P(PRCH(0),U,1),PRCH=PRCHPO D PONO^PRCHAM5
- I '$D(PRCHPO) S PRCHPO=PRCH Q
- S X=45,DA=PRCHPO D ENS^PRCHSTAT
- S PRCHN=$P(^PRC(442,PRCHPO,0),U,1),PRCHNPO=PRCHPO,PRCHPO=PRCH,PRCHNPO(0)=PRCHO,^(4,0)="^^1^1^"_DT,^(1,0)="This Purchase Order has been changed to "_PRCHN
- S PRCHX(PRCHO,PRCHN)="^PRC(442,""B"",X,PRCHPO)",PRCHX($P(PRCHO,"-",2),$P(PRCHN,"-",2))="^PRC(442,""C"",X,PRCHPO)",PRCHX(PRCHN,PRCHO)="^PRC(442,""B"",X,PRCHNPO)",PRCHX($P(PRCHN,"-",2),$P(PRCHO,"-",2))="^PRC(442,""C"",X,PRCHNPO)"
- S $P(^PRC(443.6,PRCHPO,0),U,1)=PRCHN,PRCHT=0,PRCHDL=1 D DOCID^PRCHAM5
- Q
- EN4 ;F.C.P. EDIT
- W $C(7),!!!,"NOTE:",!,"Please notify the service to make any necessary adjustments to both the",!,"previous and new Fund Control Points on this order, to make sure their",!,"balances are correct!!",!!
- S PRCHAMND="",PRCHO=$P(PRCH(0),U,3),DR="S PRCHN(""CC"")="""";1;2//^S X=PRCHN(""CC"");5.2" D DIE K PRCHAMND S PRCHN=$P(^PRC(443.6,PRCHPO,0),U,3) Q:PRCHO=PRCHN
- S PRCHX($P(PRCHO," ",1),$P(PRCHN," ",1))="^PRC(442,""E"",X,PRCHPO)"
- S PRCHT=0,^TMP("PRCHW",$J,1)="Appropriation "_$P(PRCH(0),U,4)_"-"_$P(PRCHO," ",1)_" has been changed to "_$P(^PRC(443.6,PRCHPO,0),U,4)_"-"_$P($P(^(0),U,3)," ",1) Q
- EN5 ;SHIP TO EDIT
- S:$P(PRCH(0),U,2)'=4 PRCHO=+$P(PRCH(1),U,3),DR=5.4 S:$P(PRCH(0),U,2)=4 PRCHO=+$P(PRCH(1),U,12),DR=5.3 D DIE
- S PRCHN=$S($P(^PRC(443.6,PRCHPO,0),U,2)'=4:+$P(^(1),U,3),1:+$P(^(1),U,12)) Q:PRCHO=PRCHN
- I $P(PRCH(0),U,2)'=4 S PRCHO=$S($D(^PRC(411,$E(PRCH(0),1,3),1,PRCHO,0)):$P(^(0),U,1),1:""),PRCHN=$S($D(^PRC(411,$E(PRCH(0),1,3),1,PRCHN,0)):$P(^(0),U,1),1:"")
- E S PRCHO=$S($D(^PRC(440.2,PRCHO,0))&($D(^DPT(PRCHO,0))):$P(^(0),U,1),1:""),PRCHN=$S($D(^PRC(440.2,PRCHN,0))&($D(^DPT(PRCHN,0))):$P(^(0),U,1),1:"")
- S PRCHT=0,PRCHDL=1 K DIC("DR") Q
- EN6 ;F.O.B. EDIT
- S PRCHO=$P(PRCH(1),U,6),DR=6.4 D DIE S PRCHN=$P(^PRC(443.6,PRCHPO,1),U,6) Q:PRCHO=PRCHN
- S PRCHT=0,PRCHDL=1,PRCHO=$S(PRCHO="O":"ORIGIN",1:"DESTINATION"),PRCHN=$S(PRCHN="O":"ORIGIN",1:"DESTINATION") Q
- EN7 ;PROMPT PAYMENT EDIT
- G EN7^PRCHAM5
- EN8 ;EST. SHIPPING EDIT
- G EN8^PRCHAM3
- EN9 ;DESCRIPTION
- S DIE="^PRC(443.6,",DA=PRCHPO,DR="[PRCHAMDESC]" D ^DIE
- S PRCHT=1,PRCHCHK=1 Q
- EN10 ;LINE ITEM ADD
- S (PRCHN,PRCHO)="" G EN10^PRCHAM2
- EN11 ;LINE ITEM DELETE
- S (PRCHN,PRCHO)="" G EN11^PRCHAM2
- EN12 ;LINE ITEM EDIT
- S (PRCHN,PRCHO)="" G EN12^PRCHAM2
- EN13 ;SOURCE CODE EDIT
- S PRCHO=$P(PRCH(1),U,7),DR=8 D DIE S PRCHN=$P(^PRC(443.6,PRCHPO,1),U,7) Q:PRCHO=PRCHN
- S PRCHT=0,X=PRCHO D TP S PRCHO=X,X=PRCHN D TP S PRCHN=X Q
- EN14 ;ITEM DISCOUNT ADD
- G EN14^PRCHAM3
- EN15 ;ITEM DISCOUNT DELETE
- G EN15^PRCHAM3
- EN16 ;ITEM DISCOUNT EDIT
- G EN16^PRCHAM3
- TP S X=$S($D(^PRCD(420.8,X,0)):$P(^(0),U,1),1:"") S:X="B" X="Combination of 2,4,6" Q
- QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <Return> to continue " D ^DIR K PRCSIG,ROUTINE S PRCHT=1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM1 4478 printed Mar 13, 2025@21:10:24 Page 2
- PRCHAM1 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;3/29/93 10:03
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- ASK KILL ^TMP("PRCHW",$JOB)
- SET DIC="^PRCD(442.2,"
- SET DIC("S")="I Y>19,($P(^(0),U,3)]"""")"
- if $DATA(PRCHNRQ)
- SET DIC("S")=DIC("S")_",(""25;26;28;35;36""'[Y)"
- SET DIC(0)="QEAZ"
- +1 DO ^DIC
- if Y<0
- GOTO CHK^PRCHAM
- KILL DIC
- IF '$DATA(^PRCD(442.2,+Y,1))
- WRITE !!?5,"Amendment Lines in file 442.2 not defined "
- GOTO ASK
- +2 SET ROU=$PIECE(Y(0),U,3)
- SET PRCHL1=$PIECE(^PRCD(442.2,+Y,1),U,1)
- SET PRCHL2=$PIECE(^(1),U,2)
- IF $LENGTH($TEXT(@ROU))<2
- WRITE !!?5,"Routine line not defined "
- GOTO ASK
- +3 SET PRCHT=1
- DO @ROU
- if PRCHT
- GOTO ASK
- DO EN^PRCHAM
- GOTO ASK
- +4 ;S PRCHT=1 D @ROU S:'$D(PRCHT) PRCHT=1 G ASK:PRCHT D EN^PRCHAM G ASK
- DIE SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- DO ^DIE
- KILL DIE
- QUIT
- EN1 ;P.O. CANCEL
- +1 SET X=0
- FOR I=0:0
- SET I=$ORDER(^PRC(442,PRCHPO,11,I))
- if 'I
- QUIT
- IF $DATA(^(I,0))
- SET X=$PIECE(^(0),U,12)
- if X
- QUIT
- +2 IF X
- WRITE !?5,"PURCHASE ORDER HAS BEEN RECEIVED, CANNOT CANCEL !",$CHAR(7)
- QUIT
- +3 SET %=""
- SET %A=" SURE YOU WANT TO CANCEL PURCHASE ORDER "
- SET %B=""
- DO ^PRCFYN
- IF %'=1
- WRITE ?40,"<NOTHING CANCELLED>"
- QUIT
- +4 SET $PIECE(^PRC(443.6,PRCHPO,6,PRCHAN,1),U,4)=$ORDER(^PRCD(442.3,"C",45,0))
- SET PRCHO=$PIECE($PIECE(PRCH(0),U,1),"-",2)
- SET PRCHN="."
- SET PRCHCHK=1
- SET PRCHT=0
- SET PRCHAMT=-$PIECE(PRCH(0),U,15)
- QUIT
- EN2 ;VENDOR EDIT
- +1 SET PRCHO=+PRCH(1)
- SET DR=5
- DO DIE
- SET PRCHN=+^PRC(443.6,PRCHPO,1)
- if PRCHO=PRCHN
- QUIT
- +2 SET PRCHX(PRCHO,PRCHN)="^PRC(442,""D"",X,PRCHPO)"
- SET PRCHO=$SELECT($DATA(^PRC(440,PRCHO,0)):$PIECE(^(0),U,1),1:"")
- SET PRCHN=$SELECT($DATA(^PRC(440,PRCHN,0)):$PIECE(^(0),U,1),1:"")
- +3 SET PRCHT=0
- SET PRCHDL=1
- +4 QUIT
- EN3 ;REPLACE P.O. # THIS OPTION DOESN'T SEEM TO WORK CORRECTLY.
- +1 SET PRCHO=$PIECE(PRCH(0),U,1)
- SET PRCH=PRCHPO
- DO PONO^PRCHAM5
- +2 IF '$DATA(PRCHPO)
- SET PRCHPO=PRCH
- QUIT
- +3 SET X=45
- SET DA=PRCHPO
- DO ENS^PRCHSTAT
- +4 SET PRCHN=$PIECE(^PRC(442,PRCHPO,0),U,1)
- SET PRCHNPO=PRCHPO
- SET PRCHPO=PRCH
- SET PRCHNPO(0)=PRCHO
- SET ^(4,0)="^^1^1^"_DT
- SET ^(1,0)="This Purchase Order has been changed to "_PRCHN
- +5 SET PRCHX(PRCHO,PRCHN)="^PRC(442,""B"",X,PRCHPO)"
- SET PRCHX($PIECE(PRCHO,"-",2),$PIECE(PRCHN,"-",2))="^PRC(442,""C"",X,PRCHPO)"
- SET PRCHX(PRCHN,PRCHO)="^PRC(442,""B"",X,PRCHNPO)"
- SET PRCHX($PIECE(PRCHN,"-",2),$PIECE(PRCHO,"-",2))="^PRC(442,""C"",X,PRCHNPO)"
- +6 SET $PIECE(^PRC(443.6,PRCHPO,0),U,1)=PRCHN
- SET PRCHT=0
- SET PRCHDL=1
- DO DOCID^PRCHAM5
- +7 QUIT
- EN4 ;F.C.P. EDIT
- +1 WRITE $CHAR(7),!!!,"NOTE:",!,"Please notify the service to make any necessary adjustments to both the",!,"previous and new Fund Control Points on this order, to make sure their",!,"balances are correct!!",!!
- +2 SET PRCHAMND=""
- SET PRCHO=$PIECE(PRCH(0),U,3)
- SET DR="S PRCHN(""CC"")="""";1;2//^S X=PRCHN(""CC"");5.2"
- DO DIE
- KILL PRCHAMND
- SET PRCHN=$PIECE(^PRC(443.6,PRCHPO,0),U,3)
- if PRCHO=PRCHN
- QUIT
- +3 SET PRCHX($PIECE(PRCHO," ",1),$PIECE(PRCHN," ",1))="^PRC(442,""E"",X,PRCHPO)"
- +4 SET PRCHT=0
- SET ^TMP("PRCHW",$JOB,1)="Appropriation "_$PIECE(PRCH(0),U,4)_"-"_$PIECE(PRCHO," ",1)_" has been changed to "_$PIECE(^PRC(443.6,PRCHPO,0),U,4)_"-"_$PIECE($PIECE(^(0),U,3)," ",1)
- QUIT
- EN5 ;SHIP TO EDIT
- +1 if $PIECE(PRCH(0),U,2)'=4
- SET PRCHO=+$PIECE(PRCH(1),U,3)
- SET DR=5.4
- if $PIECE(PRCH(0),U,2)=4
- SET PRCHO=+$PIECE(PRCH(1),U,12)
- SET DR=5.3
- DO DIE
- +2 SET PRCHN=$SELECT($PIECE(^PRC(443.6,PRCHPO,0),U,2)'=4:+$PIECE(^(1),U,3),1:+$PIECE(^(1),U,12))
- if PRCHO=PRCHN
- QUIT
- +3 IF $PIECE(PRCH(0),U,2)'=4
- SET PRCHO=$SELECT($DATA(^PRC(411,$EXTRACT(PRCH(0),1,3),1,PRCHO,0)):$PIECE(^(0),U,1),1:"")
- SET PRCHN=$SELECT($DATA(^PRC(411,$EXTRACT(PRCH(0),1,3),1,PRCHN,0)):$PIECE(^(0),U,1),1:"")
- +4 IF '$TEST
- SET PRCHO=$SELECT($DATA(^PRC(440.2,PRCHO,0))&($DATA(^DPT(PRCHO,0))):$PIECE(^(0),U,1),1:"")
- SET PRCHN=$SELECT($DATA(^PRC(440.2,PRCHN,0))&($DATA(^DPT(PRCHN,0))):$PIECE(^(0),U,1),1:"")
- +5 SET PRCHT=0
- SET PRCHDL=1
- KILL DIC("DR")
- QUIT
- EN6 ;F.O.B. EDIT
- +1 SET PRCHO=$PIECE(PRCH(1),U,6)
- SET DR=6.4
- DO DIE
- SET PRCHN=$PIECE(^PRC(443.6,PRCHPO,1),U,6)
- if PRCHO=PRCHN
- QUIT
- +2 SET PRCHT=0
- SET PRCHDL=1
- SET PRCHO=$SELECT(PRCHO="O":"ORIGIN",1:"DESTINATION")
- SET PRCHN=$SELECT(PRCHN="O":"ORIGIN",1:"DESTINATION")
- QUIT
- EN7 ;PROMPT PAYMENT EDIT
- +1 GOTO EN7^PRCHAM5
- EN8 ;EST. SHIPPING EDIT
- +1 GOTO EN8^PRCHAM3
- EN9 ;DESCRIPTION
- +1 SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- SET DR="[PRCHAMDESC]"
- DO ^DIE
- +2 SET PRCHT=1
- SET PRCHCHK=1
- QUIT
- EN10 ;LINE ITEM ADD
- +1 SET (PRCHN,PRCHO)=""
- GOTO EN10^PRCHAM2
- EN11 ;LINE ITEM DELETE
- +1 SET (PRCHN,PRCHO)=""
- GOTO EN11^PRCHAM2
- EN12 ;LINE ITEM EDIT
- +1 SET (PRCHN,PRCHO)=""
- GOTO EN12^PRCHAM2
- EN13 ;SOURCE CODE EDIT
- +1 SET PRCHO=$PIECE(PRCH(1),U,7)
- SET DR=8
- DO DIE
- SET PRCHN=$PIECE(^PRC(443.6,PRCHPO,1),U,7)
- if PRCHO=PRCHN
- QUIT
- +2 SET PRCHT=0
- SET X=PRCHO
- DO TP
- SET PRCHO=X
- SET X=PRCHN
- DO TP
- SET PRCHN=X
- QUIT
- EN14 ;ITEM DISCOUNT ADD
- +1 GOTO EN14^PRCHAM3
- EN15 ;ITEM DISCOUNT DELETE
- +1 GOTO EN15^PRCHAM3
- EN16 ;ITEM DISCOUNT EDIT
- +1 GOTO EN16^PRCHAM3
- TP SET X=$SELECT($DATA(^PRCD(420.8,X,0)):$PIECE(^(0),U,1),1:"")
- if X="B"
- SET X="Combination of 2,4,6"
- QUIT
- QQ if '$DATA(ROUTINE)
- SET ROUTINE=$TEXT(+0)
- WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
- if PRCSIG=0!(PRCSIG=-3)
- WRITE !,"Notify Application Coordinator!",$CHAR(7)
- SET DIR(0)="EAO"
- SET DIR("A")="Press <Return> to continue "
- DO ^DIR
- KILL PRCSIG,ROUTINE
- SET PRCHT=1
- QUIT
