Changeset 636 for FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m (modified) (7 diffs)

FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m

@@ -1 +1 @@
 PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96  14:07
- ;;5.1;IFCAP;**21,79,100,113**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
-REQ N PRCHREQ
+ ;;5.1;IFCAP;**21,79,100**;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
+REQ ;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
+PO ;PO
+ N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON
+ N 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
+ N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
  N PRCFL,MSG
 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
+ ;
+ ; See routine PRCHAMXA for information on variable PRCHNORE and for
+ ; incidence of undefined DIK variable errors.
+ ; The var PRCHPO is the basic premise of locks applied to amendments.
+ ; Anytime amend module is accessed add +lock & save po# in PRCENTRY.
+ ;
  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
+ ;
+ ; 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.
+ ; 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
@@ -33 +46 @@
  . 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
- D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT
+CAN1 D 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
@@ -66 +68 @@
  ...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
+ ...; 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
@@ -72 +75 @@
  .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1
  .Q
+ ;PRC*5.1*100: check line items without an FSC or PSC
  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)
+ ; 
+ ; Change below to allow checks for monthly limits in file #440.5 before
+ ; completion of the amendment.
+ ;
  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
@@ -107 +115 @@
  .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
+ .;
+ .; 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)
@@ -132 +144 @@
  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
+ ;
+ENC ;Can
+ S ER=0
  D CAN^PRCHMA3
  I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q
@@ -149 +164 @@
  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
+APP ;App,pr
+ S %A="   Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN
  Q
-REV N PRCH
+REV ;Rev
+ N PRCH
  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)
+EXIT ;Ex
+ 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
+ ;
+FLAG ;
+ I $G(FLAG)=1 K FLAG Q
  Q
-NOSIGN S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
+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