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

PRCHNPO6.m

Go to the documentation of this file.
  1. PRCHNPO6 ;WISC/RHD-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 442 ;6/22/94 3:19 PM
  1. V ;;5.1;IFCAP;**129,173**;Oct 20, 2000;Build 9
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. EN1 ;INPUT TRANSFORM FOR FILE 442, P.O.DATE #.1
  1. Q:'$D(^PRC(442,DA,0)) Q:'$P(^(0),U,3) S PRCHSAVX=X,PRC("FY")=X S:'$D(PRC("SITE")) PRC("SITE")=+^(0) S X=$P(^(0),U,3)
  1. D EN1^PRCHNPO5 S:$D(X) $P(^PRC(442,DA,0),U,4)=PRC("APP")
  1. S X=PRCHSAVX K PRCHSAVX
  1. Q
  1. ;
  1. EN2 ;SCREEN--P.O.#['X' (FRESH FOOD) OR 'Z' (CASCA)--INVOICE ADDRESS="FISCAL", P.O.#['C' (CERT.INV.)--MOP='CERT.INV.', INV.ADDR.="FISCAL", IMPREST FUNDS--INV.ADDR.="".
  1. ;PRC*5.1*129 modifies INVOICE ADDRESS default from 'FMS' to 'VA FSC'
  1. S Z1=$E($P(^PRC(442,DA,0),"-",2),1,2),PRCHN("INV")="VA FSC",Z2=+$P(^(0),U,2) I $D(^PRCD(442.5,Z2,0)) S PRCHN("MP")=$P(^(0),U,3) I PRCHN("MP")=12 S Z1="IF",PRCHN("INV")="" G EN20
  1. I (Z1["X")!(Z1["Z") S PRCHN("INV")="FISCAL" K Z1,Z2 Q
  1. I Z1'["C" K Z1,Z2 Q
  1. S PRCHN("MP")=2,$P(^PRC(442,DA,0),U,2)=2,^PRC(442,"F",2,DA)="",Z2=2,PRCHN("INV")="FISCAL"
  1. EN20 W !,"Method of Processing="_$P(^PRCD(442.5,Z2,0),U,1) K Z1,Z2
  1. Q
  1. ;
  1. EN3 ;SCREEN FCP--CALLED FROM PRCHNPO3
  1. G:'$D(PRCHPO) FALSE S Z0=$E($P(^PRC(442,PRCHPO,0),"-",2),1,2),Z1=+$P(^PRCS(410,Y,0),"-",4)
  1. ;
  1. EN4 ;SCREEN FCP FOR SPECIAL P.O.NUMBERS--Z0=1ST 2 DIGITS OF P.O.NO.,Z1=FCP
  1. G:(Z0["H")&('$D(^PRC(420,"AD",1,PRC("SITE"),Z1))) FALSE
  1. I Z0["G",$D(^PRC(411,+PRC("SITE"),0)),$D(^PRC(411.2,+$P(^(0),U,7),0)),"^DEPOT^VACO^DDC^"[("^"_$P(^(0),U,1)_"^") G TRUE
  1. G:(Z0["G")&('$D(^PRC(420,"AD",2,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",4,PRC("SITE"),Z1))) FALSE
  1. G:(Z0["Z")&('$D(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",4,PRC("SITE"),Z1))) FALSE
  1. I $G(PRCHPC)!$G(PRCHDELV) I '$D(^PRC(420,"C",DUZ,PRC("SITE"),Z1)) G FALSE
  1. ;
  1. TRUE I 1 Q
  1. ;
  1. FALSE I 0
  1. Q
  1. ;
  1. EN5 ;FILE #442, FIELD #1 (FCP) ONLINE HELP
  1. S Z1=Y D EN4 ;S FLAG=1
  1. Q
  1. ;
  1. EST ;Find Line Item # for Field #13.1
  1. S N="" F PRCHESTA=1:1 S N=$O(^PRC(442,PRCHPO,2,"B",N)) Q:'N
  1. S N=0 F PRCHDIS=1:1 S N=$O(^PRC(442,PRCHPO,3,N)) Q:'N
  1. S PRCHDIS=PRCHDIS+PRCHESTA-1,$P(^PRC(442,PRCHPO,0),U,18)=PRCHDIS,$P(^(0),U,14)=PRCHDIS
  1. K N,PRCHESTA,PRCHDIS
  1. Q
  1. ;
  1. EN7 ;FILE 442, PKG.MULT. #3.1
  1. D VEN^PRCHNPO5 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
  1. S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN7^PRCHCRD1
  1. Q
  1. ;
  1. EN8 ;FILE 442, P.O.NO. .01 CALLED BY THE SCREEN ON THE .01 FIELD
  1. ;PRC*5.1*173 Will insure that the next IEN used is not below 20,000,000
  1. ; Start back at closest ien to last realistic ien using for
  1. ; loop check to look for last used ien.
  1. Q:'$D(X) Q:$D(PRCHNEW)&$D(^PRC(442,"B",X))
  1. N PRCEN442
  1. ;PRC*5.1*129 modifies SACC lock violations
  1. L +^PRC(442,0):$S($G(DILOCKTM)>5:DILOCKTM,1:5) I '$T W $C(7),"ANOTHER USER IS IS EDITING FILE 442 CONTROL NODE! Please retry in a minute." K X Q
  1. S PRCEN442=$P(^PRC(442,0),"^",3)-2
  1. I PRCEN442<20000000 D S:PRCEN442=20000000 PRCEN442=99999999
  1. . F I=90000000:-10000000:20000000 I $O(^PRC(442,I))-I>1000 S PRCEN442=$O(^PRC(442,I)) Q
  1. F PRCEN442=PRCEN442:-2 I '$D(^PRC(442,PRCEN442)) L +^PRC(442,PRCEN442):$S($D(DILOCKTM):DILOCKTM,1:3) Q:$T
  1. L -^PRC(442,0)
  1. I PRCEN442'>0 K X
  1. E S DINUM=PRCEN442
  1. L -^PRC(442,PRCEN442)
  1. Q
  1. ;
  1. EN9 ;FILE 442, MAX.ORD.QTY.#9.6
  1. D VEN^PRCHNPO5 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
  1. S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN9^PRCHCRD1
  1. Q
  1. ;
  1. ; ER-ER3 ARE CALLED FROM PRCHNPO1
  1. ER W !," ** Error in Discount ",PRCH,", item ",PRCHN," has a unit cost of zero ",$C(7) S PRCHER=""
  1. Q
  1. ;
  1. ER1 W !," ** Error in Discount ",PRCH,", item ",PRCHN," has been changed. Discount will be deleted",!?4,"and must be re-edited!",$C(7) S PRCHER="",DR="14///^S X=PRCH",DR(2,442.03)=".01///@" D ^DIE K DR
  1. Q
  1. ;
  1. ER2 W !," Type Code is undefined.",$C(7) K PRCHPO
  1. Q
  1. ;
  1. ER3 W !,$S('PRCHDT:"Breakout Code is undefined.",1:"Socioeconomic Group (FY89) not defined in Vendor file."),$C(7) K PRCHPO
  1. Q
  1. ;
  1. SPRMK ;FORMAT & DISPLAY REMARKS FROM REQUEST TO PO
  1. Q:'$D(^PRCS(410,PRCHSY,"RM")) K ^UTILITY($J,"W")
  1. W !,"2237 Special Remarks: " S U="^",PRCHZZ=0,DIWL=1,DIWR=78,DIWF="W"
  1. F PRCHJJ=0:0 S PRCHZZ=$O(^PRCS(410,PRCHSY,"RM",PRCHZZ)) Q:'PRCHZZ I $D(^(PRCHZZ,0)) S X=^(0) D DIWP^PRCUTL($G(DA)),^DIWW
  1. ;
  1. SP1 K PRCHJJ W !,"Would you like to transfer the Special Remarks to the New P.O. Comments" S %=1 D YN^DICN
  1. I %=0 W !,"Enter 'Y' to have the Special Remarks added to the end of the P.O. Comments.",! G SP1
  1. G END:%'=1 S:'$D(^PRC(442,D0,4,0)) ^(0)="^^0^0^"_DT S PRCHNN=$P(^(0),U,3),PRCHX=0
  1. F I=0:0 S PRCHX=$O(^PRCS(410,PRCHSY,"RM",PRCHX)) Q:'PRCHX I $D(^(PRCHX,0)) S PRCHNN=PRCHNN+1,^PRC(442,D0,4,PRCHNN,0)=^(0)
  1. S ^PRC(442,D0,4,0)="^^"_PRCHNN_U_PRCHNN_U_DT
  1. ;
  1. END K PRCHNN,PRCHX,PRCHZZ,DIWL,DIWR,DISF,I,%
  1. Q