Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHMA

PRCHMA.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;PRC*5.1*183 Audit all discount nodes in order to insure the item
  1. ; referred to is still defined. Also, check each item
  1. ; array defined in the discounts nodes (piece 1) to
  1. ; determine if each item still has the same contract
  1. ; if contract noted in the discount info.
  1. ;
  1. REQ N PRCHREQ
  1. S PRCHREQ=1
  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
  1. N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
  1. N PRCFL,MSG,PRCDCERR ;PRC*5.1*183
  1. LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,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
  1. S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
  1. ; 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
  1. ; the process(AMENDNO) of amending the record we must have var PRCHPO.
  1. S PRCFL=0
  1. W !! D GETPO^PRCHAMU
  1. ; If no record is selected or time-out or up-arrow out then exit without unlocking a record.
  1. I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1
  1. I PRCFL=1 G LOOP
  1. I '$G(PRCHPO)!$D(FIS) G EXIT
  1. I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT
  1. D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT
  1. S PRCHAMT=0,FL=0
  1. D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT
  1. S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB
  1. I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX
  1. I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
  1. I PRCHNEW=111&($G(CAN)=0) D REV
  1. 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
  1. ASK K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU
  1. G:$D(REPONUM)=1 CAN1
  1. I ER=0 D G:'$D(REPO)&($G(CAN)=0) ASK
  1. . D @ROU
  1. . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q
  1. . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q
  1. I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
  1. I $D(DTOUT)!($D(DUOUT)) G EXIT
  1. I $G(NOCAN)=1 G ASK
  1. G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT
  1. CAN1 S BFLAG=0
  1. S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)'=6 BFLAG=1
  1. I $P($G(^PRC(443.6,PRCHPO,1)),U,7)=6 D
  1. .S THISHLD=0
  1. .F S THISHLD=$O(^PRC(443.6,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D
  1. ..S:$P($G(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
  1. .Q:BFLAG=1
  1. .S THISHLD=0
  1. .F S THISHLD=$O(^PRC(442,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D
  1. ..S:$P($G(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
  1. W:BFLAG=0 !,"This is now a contract order. You must add a contract to this orders item(s)",!,"before approving the amendment.",!
  1. G:BFLAG=0 EXIT
  1. S PRCDCERR=0 D CHKDISC G:PRCDCERR ASK ;PRC*5.1*183
  1. D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT
  1. CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT
  1. I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D
  1. .S POSTAT=+$G(^PRC(443.6,PRCHPO,7))
  1. .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)
  1. .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U)
  1. .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT"
  1. .D ^DIE K DIE,AMSTAT,POSTAT
  1. 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=""
  1. I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D G:$D(PRCHER) ERR
  1. .N END S END=IOSL-3
  1. .S PRCH=0 F S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D
  1. ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D Q
  1. ...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
  1. ...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
  1. ...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
  1. ...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
  1. ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered
  1. ...D PCD^PRCHMA1
  1. ...Q
  1. ..Q
  1. .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1
  1. .Q
  1. D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT
  1. 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=""
  1. I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1
  1. I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER)
  1. 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
  1. .D ^PRCHSF3
  1. .D ADJ1^PRCHCD0
  1. .D LIMIT^PRCHCD0
  1. ;
  1. 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
  1. .N DIR S DIR(0)="E" D ^DIR
  1. .Q
  1. D REV:'$G(PRCPROST),APP G:%'=1 EXIT
  1. S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT
  1. S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN)
  1. G:RETURN'=1 EXIT
  1. S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE
  1. D ^PRCHSF3
  1. I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
  1. I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D
  1. . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
  1. . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH
  1. . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q
  1. . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q
  1. I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT
  1. .S MTOPDA=1
  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 !!
  1. .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)
  1. .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0
  1. .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0
  1. .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT
  1. .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")
  1. .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C")
  1. .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE
  1. .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
  1. .; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either
  1. .; 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
  1. .; previous month and year. DT is the current date, system-supplied.
  1. .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8)
  1. .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3)
  1. .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3)
  1. .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2)
  1. .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D
  1. ..I $G(PPAMT)<0 Q
  1. ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG)
  1. ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
  1. .;
  1. .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D
  1. ..I $G(PPTEMP)<0 Q
  1. ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP)
  1. ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
  1. .;
  1. .; Update file #440.5 only if the amendment is for non-cancellation
  1. .; of an order from a previous month regardless of the year.
  1. .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D
  1. ..I $G(PPAMT)<0 Q
  1. ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT)
  1. .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410
  1. S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1
  1. I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
  1. D SOURCE^PRCHAMU:$G(SCE)
  1. G EXIT
  1. ENC S ER=0
  1. D CAN^PRCHMA3
  1. ;PRC*5.1*157 insures that if the user does not use Amendment to Purchase Card option
  1. ; an order using a credit card (MOP=25) will also be checked for any recon charges
  1. ; still attached to order attempting to be cancelled
  1. I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q
  1. 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
  1. . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7)
  1. S %="",%A=" SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN
  1. I %'=1 W ?40," <NOTHING CANCELLED>" D Q
  1. .I $D(PRCHAU) D
  1. ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
  1. ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)=""
  1. .S NOCAN=1
  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))"
  1. D ^DIE K DIE,DA,DR S CAN=1
  1. S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W !
  1. QUIT
  1. APP S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN
  1. Q
  1. REV N PRCH
  1. 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
  1. S %=1,%B="",%A=" Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN
  1. I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM
  1. Q
  1. EXIT L -^PRC(442,PRCENTRY)
  1. EXIT1 K ERROR,FIS,REPO,DEL
  1. QUIT:$G(PRCPROST)
  1. I $G(OUT)'=1 G LOOP
  1. QUIT
  1. FLAG I $G(FLAG)=1 K FLAG Q
  1. Q
  1. NOSIGN S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
  1. NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@"
  1. D ^DIE K DIE,DA,DR
  1. Q
  1. TOP ;PAUSE AT BOTTOM OF SCREEN
  1. N DIR S DIR(0)="E"
  1. D ^DIR
  1. S LCNT=1
  1. Q
  1. CHKDISC ;CHECK DISCOUNTS MATCH ITEMS ;PRC*5.1*183
  1. N PRCHDSC,PRCRDIS,PRCRITEM,PRCRCONT,PRCDERRS,PRCTT,PRCRERR,PRCRTYP,PRCRITM,PRCITEM,PRCIT,PRCII,PRCJJ
  1. S PRCHDSC=0,PRCTT=0
  1. D1 F S PRCHDSC=$O(^PRC(443.6,PRCHPO,3,PRCHDSC)) Q:'PRCHDSC D
  1. . S PRCRDIS=$G(^PRC(443.6,PRCHPO,3,PRCHDSC,0)) Q:PRCRDIS=""
  1. . S PRCRITEM=$P(PRCRDIS,U),PRCRCONT=$P(PRCRDIS,U,5)
  1. . I PRCRITEM[":" D
  1. .. F PRCII=$P(PRCRITEM,":"):1:$P(PRCRITEM,":",2) D
  1. ... S PRCIT=0 I $D(^PRC(443.6,PRCHPO,2,"B",PRCII)) S PRCIT=$O(^PRC(443.6,PRCHPO,2,"B",PRCII,0))
  1. ... I 'PRCIT S PRCTT=PRCTT+1,PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";UNDF;"_PRCRDIS Q
  1. ... 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
  1. . I PRCRITEM'[":" D
  1. .. F PRCJJ=1:1 S PRCII=$P(PRCRITEM,",",PRCJJ) Q:'PRCII D
  1. ... S PRCIT=0 I $D(^PRC(443.6,PRCHPO,2,"B",PRCII)) S PRCIT=$O(^PRC(443.6,PRCHPO,2,"B",PRCII,0))
  1. ... I 'PRCIT S PRCTT=PRCTT+1,PRCDERRS(PRCHDSC,PRCII,PRCTT)=PRCIT_";UNDF;"_PRCRDIS Q
  1. ... 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
  1. . Q
  1. ;
  1. D2 ;LIST ANY DISCOUNT ERRORS FOUND IN RELATION TO ITEMS
  1. Q:PRCTT=0 S PRCDCERR=1
  1. W !!,"Discounts/Items discrepancies found... MUST fix either item or discount listed"
  1. W !!,"DC-IT ITEM(s) %/AMT DISC/ITEM CONTRACT# REASON",!
  1. S PRCHDSC=0
  1. F S PRCHDSC=$O(PRCDERRS(PRCHDSC)) Q:'PRCHDSC D
  1. . S PRCRITM=0
  1. . F S PRCRITM=$O(PRCDERRS(PRCHDSC,PRCRITM)) Q:'PRCRITM D
  1. .. S PRCRERR=0
  1. .. F S PRCRERR=$O(PRCDERRS(PRCHDSC,PRCRITM,PRCRERR)) Q:'PRCRERR D
  1. ... S PRCRITEM=PRCDERRS(PRCHDSC,PRCRITM,PRCRERR),PRCIT=$P(PRCRITEM,";"),PRCRTYP=$P(PRCRITEM,";",2),PRCRITEM=$P(PRCRITEM,";",3)
  1. ... S PRCITEM=$G(^PRC(443.6,PRCHPO,2,PRCIT,2))
  1. ... 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")
  1. ... W ?44,$S(PRCRTYP="UNDF":"Tampering, item has been removed",PRCRTYP="CONT":"Item/Disc contract numbers mismatch",1:"")
  1. ... Q
  1. ;
  1. 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
  1. Q