- PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96 14:07
- ;;5.1;IFCAP;**21,79,100,113,157,183**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;PRC*5.1*183 Audit all discount nodes in order to insure the item
- ; referred to is still defined. Also, check each item
- ; array defined in the discounts nodes (piece 1) to
- ; determine if each item still has the same contract
- ; if contract noted in the discount info.
- ;
- REQ N PRCHREQ
- S PRCHREQ=1
- PO N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
- N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
- N PRCFL,MSG,PRCDCERR ;PRC*5.1*183
- LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0
- ; See routine PRCHAMXA for information on variable PRCHNORE and undefined DIK, var PRCHPO is the basic premise of locks applied to amendments
- S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
- ; Lock simultaneous entry of users in amend. module for the same record. Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start
- ; the process(AMENDNO) of amending the record we must have var PRCHPO.
- S PRCFL=0
- W !! D GETPO^PRCHAMU
- ; If no record is selected or time-out or up-arrow out then exit without unlocking a record.
- I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1
- I PRCFL=1 G LOOP
- I '$G(PRCHPO)!$D(FIS) G EXIT
- I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT
- D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT
- S PRCHAMT=0,FL=0
- D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT
- S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB
- I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX
- I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
- I PRCHNEW=111&($G(CAN)=0) D REV
- I $G(CAN)>0 D ENC G:ER EXIT I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX G CAN1
- ASK K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU
- G:$D(REPONUM)=1 CAN1
- I ER=0 D G:'$D(REPO)&($G(CAN)=0) ASK
- . D @ROU
- . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q
- . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q
- I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
- I $D(DTOUT)!($D(DUOUT)) G EXIT
- I $G(NOCAN)=1 G ASK
- G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT
- CAN1 S BFLAG=0
- S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)'=6 BFLAG=1
- I $P($G(^PRC(443.6,PRCHPO,1)),U,7)=6 D
- .S THISHLD=0
- .F S THISHLD=$O(^PRC(443.6,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D
- ..S:$P($G(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
- .Q:BFLAG=1
- .S THISHLD=0
- .F S THISHLD=$O(^PRC(442,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D
- ..S:$P($G(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
- W:BFLAG=0 !,"This is now a contract order. You must add a contract to this orders item(s)",!,"before approving the amendment.",!
- G:BFLAG=0 EXIT
- S PRCDCERR=0 D CHKDISC G:PRCDCERR ASK ;PRC*5.1*183
- D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT
- CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT
- I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D
- .S POSTAT=+$G(^PRC(443.6,PRCHPO,7))
- .S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT)
- .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U)
- .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT"
- .D ^DIE K DIE,AMSTAT,POSTAT
- K PRCHER S LCNT=1 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status.",! S PRCHER=""
- I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D G:$D(PRCHER) ERR
- .N END S END=IOSL-3
- .S PRCH=0 F S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D
- ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D Q
- ...I $P(PRCHLN,U,4)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing BOC !",$C(7) S PRCHER="",LCNT=LCNT+2
- ...I $G(PRCHAUTH)'=1,$G(PRCHREQ) I $P(PRCHLN,U,13)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing NSN!",$C(7) S PRCHER="",LCNT=LCNT+2
- ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2
- ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2
- ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered
- ...D PCD^PRCHMA1
- ...Q
- ..Q
- .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1
- .Q
- D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT
- I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER=""
- I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1
- I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER)
- I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D I $G(ERROR) S PRCHER="" K ERROR,FILE
- .D ^PRCHSF3
- .D ADJ1^PRCHCD0
- .D LIMIT^PRCHCD0
- ;
- ERR I $D(PRCHER) W !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days." D:LCNT>20 G EXIT
- .N DIR S DIR(0)="E" D ^DIR
- .Q
- D REV:'$G(PRCPROST),APP G:%'=1 EXIT
- S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT
- S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN)
- G:RETURN'=1 EXIT
- S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE
- D ^PRCHSF3
- I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
- I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D
- . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
- . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH
- . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q
- . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q
- I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT
- .S MTOPDA=1
- .D SUPP^PRCFFM2M ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !!
- .S PPTEMP=0,PP410=$P($G(^PRC(442,PRCHPO,0)),"^",12),PPAMT=$P($G(^PRC(442,PRCHPO,0)),"^",16) I PP410'="" S PPTEMP=$P($G(^PRCS(410,PP410,4)),"^",8),PPTEMP=-(PPAMT-PPTEMP)
- .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0
- .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0
- .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT
- .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2),$P(PRCOAMT,"^",5)=PPTEMP D EBAL^PRCSEZ(PRCOAMT,"O")
- .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C")
- .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE
- .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
- .; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either
- .; cancels the order or enters other type of amendment that changes the final amount of the order. No credit is given for orders from a
- .; previous month and year. DT is the current date, system-supplied.
- .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8)
- .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3)
- .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3)
- .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2)
- .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D
- ..I $G(PPAMT)<0 Q
- ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG)
- ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
- .;
- .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D
- ..I $G(PPTEMP)<0 Q
- ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP)
- ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
- .;
- .; Update file #440.5 only if the amendment is for non-cancellation
- .; of an order from a previous month regardless of the year.
- .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D
- ..I $G(PPAMT)<0 Q
- ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT)
- .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410
- S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1
- I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
- D SOURCE^PRCHAMU:$G(SCE)
- G EXIT
- ENC S ER=0
- D CAN^PRCHMA3
- ;PRC*5.1*157 insures that if the user does not use Amendment to Purchase Card option
- ; an order using a credit card (MOP=25) will also be checked for any recon charges
- ; still attached to order attempting to be cancelled
- I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q
- I $G(PRCHAUTH)=1!($P(^PRC(442,PRCHPO,0),U,2)=25) D PAID^PRCHINQ I $G(PAID)=1 D S ER=1 K PAID Q
- . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7)
- S %="",%A=" SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN
- I %'=1 W ?40," <NOTHING CANCELLED>" D Q
- .I $D(PRCHAU) D
- ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
- ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)=""
- .S NOCAN=1
- S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
- D ^DIE K DIE,DA,DR S CAN=1
- S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W !
- QUIT
- APP S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN
- Q
- REV N PRCH
- S PRCDCERR=0 D CHKDISC Q:PRCDCERR ;** PRC*5.1*183 Skip disc calc call to prevent item/disc sync errors due to erroneous previous amendment
- S %=1,%B="",%A=" Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN
- I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM
- Q
- EXIT L -^PRC(442,PRCENTRY)
- EXIT1 K ERROR,FIS,REPO,DEL
- QUIT:$G(PRCPROST)
- I $G(OUT)'=1 G LOOP
- QUIT
- FLAG I $G(FLAG)=1 K FLAG Q
- Q
- NOSIGN S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
- NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@"
- D ^DIE K DIE,DA,DR
- Q
- TOP ;PAUSE AT BOTTOM OF SCREEN
- N DIR S DIR(0)="E"
- D ^DIR
- S LCNT=1
- Q
- CHKDISC ;CHECK DISCOUNTS MATCH ITEMS ;PRC*5.1*183
- N PRCHDSC,PRCRDIS,PRCRITEM,PRCRCONT,PRCDERRS,PRCTT,PRCRERR,PRCRTYP,PRCRITM,PRCITEM,PRCIT,PRCII,PRCJJ
- S PRCHDSC=0,PRCTT=0
- D1 F S PRCHDSC=$O(^PRC(443.6,PRCHPO,3,PRCHDSC)) Q:'PRCHDSC D
- . S PRCRDIS=$G(^PRC(443.6,PRCHPO,3,PRCHDSC,0)) Q:PRCRDIS=""
- . S PRCRITEM=$P(PRCRDIS,U),PRCRCONT=$P(PRCRDIS,U,5)
- . I PRCRITEM[":" D
- .. F PRCII=$P(PRCRITEM,":"):1:$P(PRCRITEM,":",2) D
- ... S PRCIT=0 I $D(^PRC(443.6,PRCHPO,2,"B",PRCII)) S PRCIT=$O(^PRC(443.6,PRCHPO,2,"B",PRCII,0))
- ... I 'PRCIT S PRCTT=PRCTT+1,PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";UNDF;"_PRCRDIS Q
- ... I $P(^PRC(443.6,PRCHPO,2,PRCIT,2),U,2)'=$P(PRCRDIS,U,5) S PRCTT=PRCTT+1,PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";CONT;"_PRCRDIS
- . I PRCRITEM'[":" D
- .. F PRCJJ=1:1 S PRCII=$P(PRCRITEM,",",PRCJJ) Q:'PRCII D
- ... S PRCIT=0 I $D(^PRC(443.6,PRCHPO,2,"B",PRCII)) S PRCIT=$O(^PRC(443.6,PRCHPO,2,"B",PRCII,0))
- ... I 'PRCIT S PRCTT=PRCTT+1,PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";UNDF;"_PRCRDIS Q
- ... I $P(^PRC(443.6,PRCHPO,2,PRCIT,2),U,2)'=$P(PRCRDIS,U,5) S PRCTT=PRCTT+1,PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";CONT;"_PRCRDIS
- . Q
- ;
- D2 ;LIST ANY DISCOUNT ERRORS FOUND IN RELATION TO ITEMS
- Q:PRCTT=0 S PRCDCERR=1
- W !!,"Discounts/Items discrepancies found... MUST fix either item or discount listed"
- W !!,"DC-IT ITEM(s) %/AMT DISC/ITEM CONTRACT# REASON",!
- S PRCHDSC=0
- F S PRCHDSC=$O(PRCDERRS(PRCHDSC)) Q:'PRCHDSC D
- . S PRCRITM=0
- . F S PRCRITM=$O(PRCDERRS(PRCHDSC,PRCRITM)) Q:'PRCRITM D
- .. S PRCRERR=0
- .. F S PRCRERR=$O(PRCDERRS(PRCHDSC,PRCRITM,PRCRERR)) Q:'PRCRERR D
- ... S PRCRITEM=PRCDERRS(PRCHDSC,PRCRITM,PRCRERR),PRCIT=$P(PRCRITEM,";"),PRCRTYP=$P(PRCRITEM,";",2),PRCRITEM=$P(PRCRITEM,";",3)
- ... S PRCITEM=$G(^PRC(443.6,PRCHPO,2,PRCIT,2))
- ... W !,PRCHDSC,"-",PRCRITM,?6,$P(PRCRITEM,U),?15,$P(PRCRITEM,U,2),?20,$S($P(PRCRITEM,U,5)'="":$P(PRCRITEM,U,5),1:"NONE"),"/",$S($P(PRCITEM,U,2)'="":$P(PRCITEM,U,2),1:"NONE")
- ... W ?44,$S(PRCRTYP="UNDF":"Tampering, item has been removed",PRCRTYP="CONT":"Item/Disc contract numbers mismatch",1:"")
- ... Q
- ;
- W !!,"Error(s) MUST be fixed to approve/review the amendment.....",! S DIR(0)="EAO",DIR("A")="Press <Enter> to return to Amendment Processing..." D ^DIR K DIR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMA 13055 printed Jan 18, 2025@03:09:48 Page 2
- PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96 14:07
- +1 ;;5.1;IFCAP;**21,79,100,113,157,183**;Oct 20, 2000;Build 4
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;PRC*5.1*183 Audit all discount nodes in order to insure the item
- +5 ; referred to is still defined. Also, check each item
- +6 ; array defined in the discounts nodes (piece 1) to
- +7 ; determine if each item still has the same contract
- +8 ; if contract noted in the discount info.
- +9 ;
- REQ NEW PRCHREQ
- +1 SET PRCHREQ=1
- PO NEW PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
- +1 NEW PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
- +2 ;PRC*5.1*183
- NEW PRCFL,MSG,PRCDCERR
- LOOP DO KILL^PRCHMA1
- SET PRCHNEW=""
- SET PRCHNORE=1
- SET CAN=0
- +1 ; See routine PRCHAMXA for information on variable PRCHNORE and undefined DIK, var PRCHPO is the basic premise of locks applied to amendments
- +2 SET PRCF("X")="S"
- DO ^PRCFSITE
- if '$DATA(PRC("SITE"))
- QUIT
- +3 ; Lock simultaneous entry of users in amend. module for the same record. Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start
- +4 ; the process(AMENDNO) of amending the record we must have var PRCHPO.
- +5 SET PRCFL=0
- +6 WRITE !!
- DO GETPO^PRCHAMU
- +7 ; If no record is selected or time-out or up-arrow out then exit without unlocking a record.
- +8 IF $DATA(DTOUT)!$DATA(DUOUT)!$GET(OUT)=1
- GOTO EXIT1
- +9 IF PRCFL=1
- GOTO LOOP
- +10 IF '$GET(PRCHPO)!$DATA(FIS)
- GOTO EXIT
- +11 IF '$$VERIFY^PRCHES5(PRCHPO)
- WRITE !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",!
- GOTO EXIT
- +12 DO AMENDNO^PRCHAMU
- if '$GET(PRCHAM)
- GOTO EXIT
- +13 SET PRCHAMT=0
- SET FL=0
- +14 DO INFO^PRCHAMU
- if $DATA(PRCHAV)!ER
- GOTO EXIT
- +15 SET X=$PIECE($GET(^PRC(443.6,PRCHPO,0)),U,16)
- DO EN2^PRCHAMXB
- +16 IF PRCHNEW=""
- SET DA(1)=PRCHPO
- SET DA=PRCHAM
- SET PRCHX=X
- SET X=0
- SET PRCHAMDA=34
- DO EN8^PRCHAMXB
- SET X=PRCHX
- +17 IF $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($PIECE(^(0),U,4)=15)
- SET CAN=1
- +18 IF PRCHNEW=111&($GET(CAN)=0)
- DO REV
- +19 IF $GET(CAN)>0
- DO ENC
- if ER
- GOTO EXIT
- IF $GET(NOCAN)=0
- SET DA(1)=PRCHPO
- SET DA=PRCHAM
- SET PRCHAMDA=34
- SET PRCHX=X
- SET X=0
- DO EN8^PRCHAMXB
- SET X=PRCHX
- GOTO CAN1
- ASK KILL NOCAN,DTOUT,DUOUT,REPONUM
- DO ASK^PRCHAMU
- +1 if $DATA(REPONUM)=1
- GOTO CAN1
- +2 IF ER=0
- Begin DoDot:1
- +3 DO @ROU
- +4 IF $GET(PRCHAMDA)=31
- DO MSG^PRCHAMU
- QUIT
- +5 IF $GET(PRCHAMDA)=24
- IF $GET(X)=2
- DO MSG1^PRCHAMU
- SET SCE=1
- QUIT
- End DoDot:1
- if '$DATA(REPO)&($GET(CAN)=0)
- GOTO ASK
- +6 IF $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($PIECE(^(0),U,4)=15)
- SET CAN=1
- +7 IF $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXIT
- +8 IF $GET(NOCAN)=1
- GOTO ASK
- +9 if $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1
- GOTO EXIT
- CAN1 SET BFLAG=0
- +1 if $PIECE($GET(^PRC(443.6,PRCHPO,1)),U,7)'=6
- SET BFLAG=1
- +2 IF $PIECE($GET(^PRC(443.6,PRCHPO,1)),U,7)=6
- Begin DoDot:1
- +3 SET THISHLD=0
- +4 FOR
- SET THISHLD=$ORDER(^PRC(443.6,PRCHPO,2,THISHLD))
- if 'THISHLD!(BFLAG=1)
- QUIT
- Begin DoDot:2
- +5 if $PIECE($GET(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'=""
- SET BFLAG=1
- End DoDot:2
- +6 if BFLAG=1
- QUIT
- +7 SET THISHLD=0
- +8 FOR
- SET THISHLD=$ORDER(^PRC(442,PRCHPO,2,THISHLD))
- if 'THISHLD!(BFLAG=1)
- QUIT
- Begin DoDot:2
- +9 if $PIECE($GET(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'=""
- SET BFLAG=1
- End DoDot:2
- End DoDot:1
- +10 if BFLAG=0
- WRITE !,"This is now a contract order. You must add a contract to this orders item(s)",!,"before approving the amendment.",!
- +11 if BFLAG=0
- GOTO EXIT
- +12 ;PRC*5.1*183
- SET PRCDCERR=0
- DO CHKDISC
- if PRCDCERR
- GOTO ASK
- +13 if BFLAG=1
- DO UPDATE^PRCHAMU
- if $DATA(Y)
- GOTO EXIT
- CHK IF '$$VERIFY^PRCHES5(PRCHPO)
- WRITE !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR."
- GOTO EXIT
- +1 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']""
- WRITE !!,?5,"There is no Amendment Status."
- Begin DoDot:1
- +2 SET POSTAT=+$GET(^PRC(443.6,PRCHPO,7))
- +3 SET AMSTAT=$SELECT(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT)
- +4 SET AMSTAT=$PIECE(^PRCD(442.3,AMSTAT,0),U)
- +5 SET DIE="^PRC(443.6,PRCHPO,6,"
- SET DA(1)=PRCHPO
- SET DA=PRCHAM
- SET DR="9//^S X=AMSTAT"
- +6 DO ^DIE
- KILL DIE,AMSTAT,POSTAT
- End DoDot:1
- +7 KILL PRCHER
- SET LCNT=1
- IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']""
- WRITE !!,?5,"There is no Amendment Status.",!
- SET PRCHER=""
- +8 IF $PIECE($GET(^PRC(443.6,PRCHPO,2,0)),U,4)>0
- Begin DoDot:1
- +9 NEW END
- SET END=IOSL-3
- +10 SET PRCH=0
- FOR
- SET PRCH=$ORDER(^PRC(443.6,PRCHPO,2,PRCH))
- if PRCH=""!(PRCH'>0)
- QUIT
- Begin DoDot:2
- +11 SET PRCHLN=$GET(^PRC(443.6,PRCHPO,2,PRCH,0))
- Begin DoDot:3
- +12 IF $PIECE(PRCHLN,U,4)=""
- if LCNT>END
- DO TOP
- WRITE !!,?5,"Line item ",+$PIECE(PRCHLN,U)," is missing BOC !",$CHAR(7)
- SET PRCHER=""
- SET LCNT=LCNT+2
- +13 IF $GET(PRCHAUTH)'=1
- IF $GET(PRCHREQ)
- IF $PIECE(PRCHLN,U,13)=""
- if LCNT>END
- DO TOP
- WRITE !!,?5,"Line item ",+$PIECE(PRCHLN,U)," is missing NSN!",$CHAR(7)
- SET PRCHER=""
- SET LCNT=LCNT+2
- +14 SET J=0
- SET J=$ORDER(^PRC(443.6,PRCHPO,2,PRCH,1,J))
- IF J'>0
- if LCNT>END
- DO TOP
- WRITE !!,?5,"Line item ",+$PIECE(PRCHLN,U)," is missing its description!",$CHAR(7)
- SET PRCHER=""
- SET LCNT=LCNT+2
- +15 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"
- IF $PIECE($GET(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)=""
- if LCNT>END
- DO TOP
- WRITE !!,?5,"Line item ",+$PIECE(PRCHLN,U)," is missing contract number.",$CHAR(7)
- SET PRCHER=""
- SET LCNT=LCNT+2
- +16 ; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered
- +17 DO PCD^PRCHMA1
- +18 QUIT
- End DoDot:3
- QUIT
- +19 QUIT
- End DoDot:2
- +20 IF $DATA(PRCHER)
- IF LCNT>END
- NEW DIR
- SET DIR(0)="E"
- DO ^DIR
- SET LCNT=1
- +21 QUIT
- End DoDot:1
- if $DATA(PRCHER)
- GOTO ERR
- +22 DO EN106^PRCHNPO7
- IF $GET(ERROR)=1
- GOTO EXIT
- +23 IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,13)>0
- IF $PIECE($GET(^PRC(443.6,PRCHPO,23)),U)=""
- WRITE !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC."
- SET PRCHER=""
- +24 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($PIECE($GET(^(0)),U,4)=15)
- SET CAN=1
- +25 IF $GET(CAN)'=1
- DO CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER)
- +26 IF $GET(PRCHAUTH)=1!($PIECE($GET(^PRC(443.6,PRCHPO,0)),U,2)=25)
- SET FILE=443.6
- Begin DoDot:1
- +27 DO ^PRCHSF3
- +28 DO ADJ1^PRCHCD0
- +29 DO LIMIT^PRCHCD0
- End DoDot:1
- IF $GET(ERROR)
- SET PRCHER=""
- KILL ERROR,FILE
- +30 ;
- ERR IF $DATA(PRCHER)
- WRITE !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days."
- if LCNT>20
- Begin DoDot:1
- +1 NEW DIR
- SET DIR(0)="E"
- DO ^DIR
- +2 QUIT
- End DoDot:1
- GOTO EXIT
- +3 if '$GET(PRCPROST)
- DO REV
- DO APP
- if %'=1
- GOTO EXIT
- +4 SET PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM)
- if PRCHRET'=1
- GOTO EXIT
- +5 SET RETURN=""
- DO COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN)
- +6 if RETURN'=1
- GOTO EXIT
- +7 SET DIE="^PRC(443.6,"_PRCHPO_",6,"
- SET DA=PRCHAM
- SET DR="15///TODAY+4"
- DO ^DIE
- +8 DO ^PRCHSF3
- +9 IF $PIECE(^PRC(443.6,PRCHPO,0),U,2)'=25
- SET PRCHQ="^PRCHPAM8"
- SET PRCHQ("DEST")="F"
- SET D0=PRCHPO
- SET D1=PRCHAM
- DO ^PRCHQUE
- +10 IF '($PIECE(^PRC(443.6,PRCHPO,0),U,2)=25!($PIECE(^PRC(443.6,PRCHPO,0),U,19)=2))
- Begin DoDot:1
- +11 WRITE !?3,"SEND TO SUPPLY "
- SET PRCHQ="^PRCHPAM8"
- SET D0=PRCHPO
- SET D1=PRCHAM
- DO ^PRCHQUE
- +12 SET FILE=443.6
- if $DATA(PRCHPO)
- DO CHECK^PRCHSWCH
- +13 IF $GET(PRCHOBL)=1
- DO SUPP^PRCFFM2M
- KILL FILE
- QUIT
- +14 IF $GET(PRCHOBL)=2
- SET PRCOPODA=PRCHPO
- DO ^PRCOEDI
- KILL FILE,PRCOPODA
- QUIT
- End DoDot:1
- +15 IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,2)=25
- Begin DoDot:1
- +16 SET MTOPDA=1
- +17 ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !!
- DO SUPP^PRCFFM2M
- +18 SET PPTEMP=0
- SET PP410=$PIECE($GET(^PRC(442,PRCHPO,0)),"^",12)
- SET PPAMT=$PIECE($GET(^PRC(442,PRCHPO,0)),"^",16)
- IF PP410'=""
- SET PPTEMP=$PIECE($GET(^PRCS(410,PP410,4)),"^",8)
- SET PPTEMP=-(PPAMT-PPTEMP)
- +19 IF $PIECE($GET(^PRC(442,PRCHPO,7)),"^",2)=45
- SET PPTEMP=PPAMT
- SET PPAMT=0
- +20 IF PP410'=""
- SET $PIECE(^PRCS(410,PP410,4),"^",3)=0
- +21 IF PP410'=""
- SET $PIECE(^PRCS(410,PP410,4),"^",8)=PPAMT
- +22 SET A=$$DATE^PRC0C($PIECE(PRCOAMT,"^",3),"I")
- SET $PIECE(PRCOAMT,"^",3,4)=$EXTRACT(A,3,4)_"^"_$PIECE(A,"^",2)
- SET $PIECE(PRCOAMT,"^",5)=PPTEMP
- DO EBAL^PRCSEZ(PRCOAMT,"O")
- +23 IF PP410'=""
- IF $PIECE($GET(^PRC(442,PRCHPO,7)),"^",2)=45
- SET $PIECE(^PRCS(410,PP410,0),"^",2)="CA"
- DO ERS410^PRC0G(PP410_"^C")
- +24 DO REMOVE^PRCSC2(PP410)
- DO ENCODE^PRCSC2(PP410,DUZ,.MESSAGE)
- KILL MESSAGE
- +25 IF '$GET(PRCPROST)
- WRITE !?3,"SEND TO SUPPLY "
- SET PRCHQ="^PRCHPAM"
- SET D0=PRCHPO
- SET D1=PRCHAM
- DO ^PRCHQUE
- +26 ; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either
- +27 ; cancels the order or enters other type of amendment that changes the final amount of the order. No credit is given for orders from a
- +28 ; previous month and year. DT is the current date, system-supplied.
- +29 SET PRCHCD=$PIECE($GET(^PRC(442,PRCHPO,23)),U,8)
- +30 SET PRCNODE=$GET(^PRC(442,PRCHPO,6,0))
- SET PRCAMD=$PIECE(PRCNODE,U,3)
- +31 SET PRCCHG=$PIECE($GET(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3)
- +32 SET POSTAT=$PIECE($GET(^PRC(442,PRCHPO,7)),"^",2)
- +33 IF $EXTRACT($PIECE(^PRC(442,PRCHPO,1),U,15),1,5)=$EXTRACT(DT,1,5)
- IF POSTAT'=45
- Begin DoDot:2
- +34 IF $GET(PPAMT)<0
- QUIT
- +35 SET $PIECE(^PRC(440.5,PRCHCD,2),U)=$PIECE($GET(^PRC(440.5,PRCHCD,2)),U)+$GET(PRCCHG)
- +36 IF $PIECE($GET(^PRC(440.5,PRCHCD,2)),U)<0
- SET $PIECE(^PRC(440.5,PRCHCD,2),U)=0
- End DoDot:2
- +37 ;
- +38 IF $EXTRACT($PIECE(^PRC(442,PRCHPO,1),U,15),1,5)=$EXTRACT(DT,1,5)
- IF POSTAT=45
- Begin DoDot:2
- +39 IF $GET(PPTEMP)<0
- QUIT
- +40 SET $PIECE(^PRC(440.5,PRCHCD,2),U)=$PIECE($GET(^PRC(440.5,PRCHCD,2)),U)-$GET(PPTEMP)
- +41 IF $PIECE($GET(^PRC(440.5,PRCHCD,2)),U)<0
- SET $PIECE(^PRC(440.5,PRCHCD,2),U)=0
- End DoDot:2
- +42 ;
- +43 ; Update file #440.5 only if the amendment is for non-cancellation
- +44 ; of an order from a previous month regardless of the year.
- +45 IF $EXTRACT($PIECE(^PRC(442,PRCHPO,1),U,15),1,5)'=$EXTRACT(DT,1,5)
- IF POSTAT'=45
- Begin DoDot:2
- +46 IF $GET(PPAMT)<0
- QUIT
- +47 SET $PIECE(^PRC(440.5,PRCHCD,2),U)=$PIECE($GET(^PRC(440.5,PRCHCD,2)),U)+$GET(PPAMT)
- End DoDot:2
- +48 KILL DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410
- End DoDot:1
- if $GET(PRCPROST)
- SET PRCPROST=PRCPROST+0.9
- GOTO EXIT
- +49 SET SFUND=""
- IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,19)=2
- DO SUPP^PRCFFM2M
- SET SFUND=1
- +50 IF SFUND=1
- WRITE !?3,"SEND TO SUPPLY "
- SET PRCHQ="^PRCHPAM"
- SET D0=PRCHPO
- SET D1=PRCHAM
- DO ^PRCHQUE
- +51 if $GET(SCE)
- DO SOURCE^PRCHAMU
- +52 GOTO EXIT
- ENC SET ER=0
- +1 DO CAN^PRCHMA3
- +2 ;PRC*5.1*157 insures that if the user does not use Amendment to Purchase Card option
- +3 ; an order using a credit card (MOP=25) will also be checked for any recon charges
- +4 ; still attached to order attempting to be cancelled
- +5 IF $GET(NOCAN)=1
- WRITE !?5,$SELECT($DATA(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$CHAR(7)
- SET ER=1
- QUIT
- +6 IF $GET(PRCHAUTH)=1!($PIECE(^PRC(442,PRCHPO,0),U,2)=25)
- DO PAID^PRCHINQ
- IF $GET(PAID)=1
- Begin DoDot:1
- +7 WRITE !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$CHAR(7)
- End DoDot:1
- SET ER=1
- KILL PAID
- QUIT
- +8 SET %=""
- SET %A=" SURE YOU WANT TO CANCEL THIS ORDER "
- SET %B=""
- DO ^PRCFYN
- +9 IF %'=1
- WRITE ?40," <NOTHING CANCELLED>"
- Begin DoDot:1
- +10 IF $DATA(PRCHAU)
- Begin DoDot:2
- +11 SET $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
- +12 SET $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)=""
- End DoDot:2
- +13 SET NOCAN=1
- End DoDot:1
- QUIT
- +14 SET DA(1)=PRCHPO
- SET DIE="^PRC(443.6,"_DA(1)_",6,"
- SET DA=PRCHAM
- SET DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
- +15 DO ^DIE
- KILL DIE,DA,DR
- SET CAN=1
- +16 SET PRCHAMT=-$PIECE(^PRC(443.6,PRCHPO,0),U,15)
- WRITE !
- +17 QUIT
- APP SET %A=" Approve Amendment number "_PRCHAM_": "
- SET %B=""
- SET %=$SELECT($GET(PRCPROST):1,1:2)
- DO ^PRCFYN
- +1 QUIT
- REV NEW PRCH
- +1 ;** PRC*5.1*183 Skip disc calc call to prevent item/disc sync errors due to erroneous previous amendment
- SET PRCDCERR=0
- DO CHKDISC
- if PRCDCERR
- QUIT
- +2 SET %=1
- SET %B=""
- SET %A=" Review Amendment "
- DO ^PRCHSF3
- WRITE !
- DO ^PRCFYN
- +3 IF %=1
- SET D0=PRCHPO
- SET D1=PRCHAM
- SET PRCH="^PRC(443.6,"
- DO ^PRCHDAM
- +4 QUIT
- EXIT LOCK -^PRC(442,PRCENTRY)
- EXIT1 KILL ERROR,FIS,REPO,DEL
- +1 if $GET(PRCPROST)
- QUIT
- +2 IF $GET(OUT)'=1
- GOTO LOOP
- +3 QUIT
- FLAG IF $GET(FLAG)=1
- KILL FLAG
- QUIT
- +1 QUIT
- NOSIGN SET $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
- NOSIGN1 SET DA(1)=PRCHPO
- SET DIE="^PRC(443.6,"_DA(1)_",6,"
- SET DA=PRCHAM
- SET DR="9///@"
- +1 DO ^DIE
- KILL DIE,DA,DR
- +2 QUIT
- TOP ;PAUSE AT BOTTOM OF SCREEN
- +1 NEW DIR
- SET DIR(0)="E"
- +2 DO ^DIR
- +3 SET LCNT=1
- +4 QUIT
- CHKDISC ;CHECK DISCOUNTS MATCH ITEMS ;PRC*5.1*183
- +1 NEW PRCHDSC,PRCRDIS,PRCRITEM,PRCRCONT,PRCDERRS,PRCTT,PRCRERR,PRCRTYP,PRCRITM,PRCITEM,PRCIT,PRCII,PRCJJ
- +2 SET PRCHDSC=0
- SET PRCTT=0
- D1 FOR
- SET PRCHDSC=$ORDER(^PRC(443.6,PRCHPO,3,PRCHDSC))
- if 'PRCHDSC
- QUIT
- Begin DoDot:1
- +1 SET PRCRDIS=$GET(^PRC(443.6,PRCHPO,3,PRCHDSC,0))
- if PRCRDIS=""
- QUIT
- +2 SET PRCRITEM=$PIECE(PRCRDIS,U)
- SET PRCRCONT=$PIECE(PRCRDIS,U,5)
- +3 IF PRCRITEM[":"
- Begin DoDot:2
- +4 FOR PRCII=$PIECE(PRCRITEM,":"):1:$PIECE(PRCRITEM,":",2)
- Begin DoDot:3
- +5 SET PRCIT=0
- IF $DATA(^PRC(443.6,PRCHPO,2,"B",PRCII))
- SET PRCIT=$ORDER(^PRC(443.6,PRCHPO,2,"B",PRCII,0))
- +6 IF 'PRCIT
- SET PRCTT=PRCTT+1
- SET PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";UNDF;"_PRCRDIS
- QUIT
- +7 IF $PIECE(^PRC(443.6,PRCHPO,2,PRCIT,2),U,2)'=$PIECE(PRCRDIS,U,5)
- SET PRCTT=PRCTT+1
- SET PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";CONT;"_PRCRDIS
- End DoDot:3
- End DoDot:2
- +8 IF PRCRITEM'[":"
- Begin DoDot:2
- +9 FOR PRCJJ=1:1
- SET PRCII=$PIECE(PRCRITEM,",",PRCJJ)
- if 'PRCII
- QUIT
- Begin DoDot:3
- +10 SET PRCIT=0
- IF $DATA(^PRC(443.6,PRCHPO,2,"B",PRCII))
- SET PRCIT=$ORDER(^PRC(443.6,PRCHPO,2,"B",PRCII,0))
- +11 IF 'PRCIT
- SET PRCTT=PRCTT+1
- SET PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";UNDF;"_PRCRDIS
- QUIT
- +12 IF $PIECE(^PRC(443.6,PRCHPO,2,PRCIT,2),U,2)'=$PIECE(PRCRDIS,U,5)
- SET PRCTT=PRCTT+1
- SET PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";CONT;"_PRCRDIS
- End DoDot:3
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 ;
- D2 ;LIST ANY DISCOUNT ERRORS FOUND IN RELATION TO ITEMS
- +1 if PRCTT=0
- QUIT
- SET PRCDCERR=1
- +2 WRITE !!,"Discounts/Items discrepancies found... MUST fix either item or discount listed"
- +3 WRITE !!,"DC-IT ITEM(s) %/AMT DISC/ITEM CONTRACT# REASON",!
- +4 SET PRCHDSC=0
- +5 FOR
- SET PRCHDSC=$ORDER(PRCDERRS(PRCHDSC))
- if 'PRCHDSC
- QUIT
- Begin DoDot:1
- +6 SET PRCRITM=0
- +7 FOR
- SET PRCRITM=$ORDER(PRCDERRS(PRCHDSC,PRCRITM))
- if 'PRCRITM
- QUIT
- Begin DoDot:2
- +8 SET PRCRERR=0
- +9 FOR
- SET PRCRERR=$ORDER(PRCDERRS(PRCHDSC,PRCRITM,PRCRERR))
- if 'PRCRERR
- QUIT
- Begin DoDot:3
- +10 SET PRCRITEM=PRCDERRS(PRCHDSC,PRCRITM,PRCRERR)
- SET PRCIT=$PIECE(PRCRITEM,";")
- SET PRCRTYP=$PIECE(PRCRITEM,";",2)
- SET PRCRITEM=$PIECE(PRCRITEM,";",3)
- +11 SET PRCITEM=$GET(^PRC(443.6,PRCHPO,2,PRCIT,2))
- +12 WRITE !,PRCHDSC,"-",PRCRITM,?6,$PIECE(PRCRITEM,U),?15,$PIECE(PRCRITEM,U,2),?20,$SELECT($PIECE(PRCRITEM,U,5)'="":$PIECE(PRCRITEM,U,5),1:"NONE"),"/",$SELECT($PIECE(PRCITEM,U,2)'="":$PIECE(PRCITEM,U,2),1:"NONE")
- +13 WRITE ?44,$SELECT(PRCRTYP="UNDF":"Tampering, item has been removed",PRCRTYP="CONT":"Item/Disc contract numbers mismatch",1:"")
- +14 QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 ;
- +16 WRITE !!,"Error(s) MUST be fixed to approve/review the amendment.....",!
- SET DIR(0)="EAO"
- SET DIR("A")="Press <Enter> to return to Amendment Processing..."
- DO ^DIR
- KILL DIR
- +17 QUIT