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

PRCHNPO1.m

Go to the documentation of this file.
  1. PRCHNPO1 ;SF-ISC/RSD/RHD-CONT. OF NEW PO ;6/9/96 19:48
  1. V ;;5.1;IFCAP;**16,79,100,108,191**;Oct 20, 2000;Build 4
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;PRC*5.1*191 Modify Prompt Pay % handling during Edit Order to
  1. ; insure ONLY one PP entry is allowed and only able
  1. ; to allow/edit one entry in what is defined as a
  1. ; multiple field. Prompt Pay processing is NO
  1. ; longer part of the order/del order templates,
  1. ; but called as new routine PRCHNPOC.
  1. ;
  1. I ('$G(PRCHPC)!($G(PRCHPC)=2)),'$G(PRCHPHAM) D
  1. .S PRCH=0,DIE="^PRC(442,",DR="[PRCHDISCNT]",(D0,DA,DA(1))=PRCHPO D ^DIE ;PRC*5.1*191
  1. . D PPEDIT^PRCHNPOC ;PRC*5.1*191
  1. F I=1:1 S PRCH=$O(^PRC(442,PRCHPO,3,PRCH)) Q:PRCH=""!(PRCH'>0) S PRCHCN=$S($P(^(PRCH,0),U,5)]"":$P(^(0),U,5),1:".OM"),PRCHAC=$P(^(0),U,1),PRCHACT=$P(^(0),U,4),PRCHP=$P(^(0),U,2) D SET Q:'$D(PRCHPO)
  1. G ERR^PRCHNPO:'$D(PRCHPO) S $P(^PRC(442,PRCHPO,0),U,14)=$P(^PRC(442,PRCHPO,0),U,14)+I-1,PRCHLCNT=$P(^(0),U,14),Y=$G(^PRC(440,PRCHV,2)),PRCHN("LSA")=$P(Y,U,5),PRCHN("MB")=$S(PRCHDT:$P(Y,U,3),1:$P(Y,U,6))
  1. S PRCHBO=$S(PRCHDT:1.1,1:1) K PRCHB
  1. S X="",PRCH="" F I=0:0 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH="" S X=X+$P(PRCH("AM",PRCH),U,2)
  1. ;Comment line below for PRC*5.1*79, new FPDS report for Austin
  1. ;G:($G(PRCHPC)!$G(PRCHDELV)) EST
  1. I $G(PRCHPC)=1 G EST ;skip for Simplified PC orders, PRC*5.1*79
  1. I PRCHDT I (X+PRCHEST>25000&("467B"'[PRCHSC))!("013"[PRCHSC)!(PRCHN("MP")=12)!(PRCHN("MP")=5)!(PRCHN("SFC")=1) G E2
  1. I $O(^PRC(440,PRCHV,PRCHBO,0)) S PRCHB(0)="^442.16PA^"_$P(^(0),U,3,4) F I=0:0 S I=$O(^PRC(440,PRCHV,PRCHBO,I)) Q:'I S:$P(^PRCD(420.6,+I,0),"^",5)'="N" PRCHB(I)=I
  1. I PRCHDT,'$D(PRCHB) D ER3^PRCHNPO6 G ERR^PRCHNPO
  1. D EN6^PRCHNPO2 G ERR^PRCHNPO:'$D(PRCHPO)
  1. ;
  1. ;Clean up node 25 to place new FPDS data, PRC*5.1*79.
  1. E2 S DR=$S($G(PRCHPC)=2:"[PRCHAMT89 NEW]",$D(PRCHDELV):"[PRCHAMT89 NEW]",$D(PRCHPHAM):"[PRCHAMT89 NEW]",PRCHDT:"[PRCHAMT89]",1:"[PRCHAMT]")
  1. K ^PRC(442,PRCHPO,9),^PRC(442,PRCHPO,25) S $P(^PRC(442,PRCHPO,0),U,15,16)="0^0"
  1. ;
  1. I PRCHDT D FPDS^PRCHFPD2 G:'PRCHFPDS EST
  1. S PRCHY=0 I PRCHEST>0,PRCHEC>0 S PRCHY=PRCHEST/PRCHEC,Y=$P(PRCHY,".",2) I $L(Y)>2 S PRCHY=$P(PRCHY,".",1)+$J("."_Y,2,2)
  1. S PRCH=0 F PRCHI=1:1 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH="" D TYPE S PRCHAMT=PRCH("AM",PRCH),PRCHCN=$S(PRCH=".OM":"",1:PRCH),DIE("NO^")="NO" W ?40,"AMOUNT: ",PRCHAMT S PRCHAMT=""""_PRCHAMT_"""" D ^DIE
  1. ;New tasks for FPDS data collection, PRC*5.1*79.
  1. ;Look at the entry actions for POs created by a Purchasing Agent, a PC
  1. ;user and a Delivery Orders user and call the required input template.
  1. ;PRC*5.1*100 - If the user times out and does not complete the input
  1. ;template for the new FPDS, don't allow electronic sig. Check the last
  1. ;field required for the PO, based on the source code and menu.
  1. I '$D(PRCHPC)&("25"[PRCHSC) D G:$G(PRCHER)=1 ERR^PRCHNPO
  1. . S DR="[PRCH NEW PO FPDS]" D ^DIE
  1. . I '$D(^PRC(442,PRCHPO,25)) S PRCHER=1 Q
  1. . I $P(^PRC(442,PRCHPO,25),U,6)="" S PRCHER=1 Q
  1. . ;Fund agency code & fund agency office code can be empty in pairs only.
  1. . I +$P(^PRC(442,PRCHPO,25),U,7)>0,$P(^PRC(442,PRCHPO,25),U,8)="" S PRCHER=1 Q
  1. ;
  1. ;For FPDS purposes, consider any PO with any of the following source
  1. ;codes as a delivery order (including direct delivery POs)from a PA:
  1. ;If the user times out, don't allow electronic sig., PRC*5.1*100.
  1. I ("467B"[PRCHSC)&($D(^PRC(442,PRCHPO,14)))!($G(PRCHPC)=3) D G:$G(PRCHER)=1 ERR^PRCHNPO
  1. . S DR="[PRCH NEW PO FPDS]" D ^DIE
  1. . I '$D(^PRC(442,PRCHPO,25)) S PRCHER=1 Q
  1. . I $P(^PRC(442,PRCHPO,25),U,15)'="" D POP Q
  1. . E S PRCHER=1
  1. ;
  1. ;Get eligible Detailed purchase card orders. If the user times out,
  1. ;don't allow electronic signature, PRC*5.1*100.
  1. I $G(PRCHPC)=2 D G:$G(PRCHER)=1 ERR^PRCHNPO
  1. . S DR="[PRCH NEW PC FPDS]" D ^DIE
  1. . I '$D(^PRC(442,PRCHPO,25)) S PRCHER=1 Q
  1. . S PRCHSC=$P(^PRCD(420.8,+PRCHSC,0),U,1)
  1. . I ("2"[PRCHSC)&($P(^PRC(442,PRCHPO,25),U,6)="") S PRCHER=1 Q
  1. . ;Fund agency code & fund agency office code can be empty in pairs only.
  1. . I ("2"[PRCHSC)&(+$P(^PRC(442,PRCHPO,25),U,7)>0),$P(^PRC(442,PRCHPO,25),U,8)="" S PRCHER=1 Q
  1. . I ("6B"[PRCHSC)&($P(^PRC(442,PRCHPO,25),U,13)="") S PRCHER=1 Q
  1. ;
  1. ;Get delivery orders from the separate Delivery Orders menu. If the
  1. ;user times out, don't allow electronic sig.; PRC*5.1*100.
  1. I $G(PRCHDELV)=1!($G(PRCHPHAM)=1) D G:$G(PRCHER)=1 ERR^PRCHNPO
  1. . S DR="[PRCH NEW DEL FPDS]" D ^DIE
  1. . I '$D(^PRC(442,PRCHPO,25)) S PRCHER=1 Q
  1. . I $P(^PRC(442,PRCHPO,25),U,15)'="" D POP Q
  1. . E S PRCHER=1
  1. ;
  1. ;End of changes for PRC*5.1*79.
  1. K DIE F I=0:0 Q:'$D(PRCHPO) S I=$O(^PRC(442,PRCHPO,9,I)) Q:'I D ER2^PRCHNPO6:$P(^(I,0),"^",2)="",ER3^PRCHNPO6:'$O(^(1,0))
  1. ;PRC*5.1*100 - Quit if user fails to populate any required field in
  1. ;node 9 (amount, type code, pref. program, etc.) or just times out.
  1. ;
  1. N J,K,L S K=+$P(^PRC(442,PRCHPO,9,0),U,3)
  1. F L=1:1:K D G:$G(PRCHER)=1 ERR^PRCHNPO
  1. . F J=1,2,4,5 D
  1. .. I $P(^PRC(442,PRCHPO,9,L,0),"^",J)="" S PRCHER=1
  1. ;End of changes for PRC*5.1*100.
  1. ;
  1. EST G ERR^PRCHNPO:'$D(PRCHPO) I 'PRCHEST,PRCHESTL S $P(^PRC(442,PRCHPO,0),U,18)=""
  1. D EN2^PRCHNPO7 I PRCHEST D EST^PRCHNPO6
  1. I $P($G(^PRC(442,PRCHPO,23)),U,11)="",PRCHSTAT'=22 S (X,Y)=5,DA=PRCHPO D UPD^PRCHSTAT
  1. I $G(PRCHPC)=2!$G(PRCHDELV) S (D0,DA)=PRCHPO D ^PRCHSF
  1. I '$G(PRCPROST) S %=1,%B="",%A=" Review "_$S($G(PRCHPC):"Purchase Card",$G(PRCHDELV):"Delivery",1:"Purchase")_" Order " D ^PRCFYN I %=1 S D0=PRCHPO D ^PRCHDP1
  1. I PRCHSTAT=22 S (D0,DA)=PRCHPO D ^PRCHSF G Q^PRCHNPO4
  1. G ^PRCHNPO4
  1. ;
  1. SET G:PRCHAC="Q" PCTQ
  1. I PRCHAC[":" S PRCHAC=$P(PRCHAC,":",1)_":1:"_$P(PRCHAC,":",2)
  1. ;
  1. PCT S PRCHAMT=0,Y="F J="_PRCHAC_" S PRCHN=J D PCT1 G:$D(PRCHER) Q" X Y Q:'$D(PRCHPO)
  1. S PRCHAMT=PRCHAMT*100+.5\1/100,$P(PRCH("AM",PRCHCN),U,2)=$P(PRCH("AM",PRCHCN),U,2)-PRCHAMT
  1. S $P(^PRC(442,PRCHPO,3,PRCH,0),U,3)=PRCHAMT,$P(^(0),U,6)=I+PRCHLCNT
  1. Q
  1. ;
  1. PCT1 I $D(^PRC(442,PRCHPO,2,"B",PRCHN)) S GTFLAG="" D G:GTFLAG=1 ER^PRCHNPO6 G:GTFLAG=2 ER1^PRCHNPO6
  1. .S PRCHN=$O(^PRC(442,PRCHPO,2,"B",PRCHN,0)),PRCHD=+$P($G(^PRC(442,PRCHPO,2,PRCHN,2)),U,1) I PRCHD'>0 S GTFLAG=1 Q
  1. .I $S(PRCHCN=".OM"&($P(^(2),U,2)=""):0,PRCHCN=$P(^(2),U,2):0,1:1) S GTFLAG=2 Q
  1. .S PRCHDA=0
  1. .I $E(PRCHP,1)="$" S PRCHDA=$P(PRCHP,"$",2)/PRCHACT
  1. .E S PRCHDA=$J(PRCHD*(PRCHP/100),0,2)
  1. .S PRCHAMT=PRCHAMT+PRCHDA,$P(^PRC(442,PRCHPO,2,PRCHN,2),U,6)=PRCHDA
  1. Q
  1. ;
  1. PCTQ S (PRCHAMT,PRCHCN,PRCHX)=0,PRCHACT=PRCHLCNT F K=0:0 S PRCHCN=$O(PRCH("AM",PRCHCN)) Q:PRCHCN="" S PRCHAC=$E($P(PRCH("AM",PRCHCN),U,3),1,$L($P(PRCH("AM",PRCHCN),U,3))-1) D PCT Q:'$D(PRCHPO) S PRCHX=PRCHX+PRCHAMT
  1. Q:'$D(PRCHPO) S $P(^PRC(442,PRCHPO,3,PRCH,0),U,3)=PRCHX
  1. Q
  1. ;
  1. POP ;Set up place of performance for PRC*5.1*79, new FPDS. If station is the
  1. ;place of perf. for PO, send the state abbrev. and zip code, otherwise
  1. ;send the vendor's state and zip code. Applies to all Delivery POs.
  1. ;For Guaranteed Delivery orders, we have to choose the VAMC since users
  1. ;are not asked for a SHIP TO location - PRC*5.1*100.
  1. N PRCST,PRCSTL,PRCSZP,PRCPOP,PRCLOC,PRCROOT,PRCVAMC
  1. I $P(^PRC(442,PRCHPO,25),"^",15)="Y" D
  1. . I $P(^PRC(442,PRCHPO,0),"^",2)=4 D POP1 Q
  1. . S PRCLOC=$P(^PRC(442,PRCHPO,1),U,3) ;ship to location
  1. . S PRCST=$P(^PRC(411,PRC("SITE"),1,PRCLOC,0),"^",6) ;station's state
  1. . S PRCSTL=$P(^DIC(5,PRCST,0),"^",2)
  1. . S PRCSZP=$P(^PRC(411,PRC("SITE"),1,PRCLOC,0),"^",7) ;station's zip
  1. . S PRCPOP=PRCSTL_PRCSZP,$P(^PRC(442,PRCHPO,25),"^",16)=PRCPOP
  1. . Q
  1. I $P(^PRC(442,PRCHPO,25),"^",15)="N" D
  1. . S PRCST=$P(^PRC(440,PRCHV,0),"^",7) ;vendor's state
  1. . S PRCSTL=$P(^DIC(5,PRCST,0),"^",2)
  1. . S PRCSZP=$E($P(^PRC(440,PRCHV,0),"^",8),1,5) ;vendor's zip
  1. . S PRCPOP=PRCSTL_PRCSZP,$P(^PRC(442,PRCHPO,25),"^",16)=PRCPOP
  1. Q
  1. ;
  1. POP1 ;Set up for Guaranteed Delivery orders - users are not asked for a SHIP
  1. ;TO location during PO creation - PRC*5.1*100.
  1. S PRCROOT=$G(^PRC(411,PRC("SITE"),0)),PRCVAMC=$G(^(3)) ; local VAMC
  1. S PRCST=$P(PRCVAMC,"^",4)
  1. S PRCSTL=$P(^DIC(5,PRCST,0),"^",2) ;station's state
  1. S PRCSZP=$E($P(PRCVAMC,"^",5),1,5) ;station's zip
  1. S PRCPOP=PRCSTL_PRCSZP,$P(^PRC(442,PRCHPO,25),"^",16)=PRCPOP
  1. Q
  1. ;End of changes for new FPDS
  1. ;
  1. TYPE I PRCHI=PRCHEC,PRCHEST'=(PRCHY*PRCHEC) S PRCHY=PRCHY+(PRCHEST-(PRCHY*PRCHEC))
  1. I PRCHY>0 S PRCH("AM",PRCH)=$P(PRCH("AM",PRCH),U,1)_U_($P(PRCH("AM",PRCH),U,2)+PRCHY)_U_$P(PRCH("AM",PRCH),U,3)
  1. ;When Source Code is not 5 then display a list of Possible Type Codes
  1. I PRCHSC'=5 D
  1. . W !,$S(PRCH'=".OM":"CONTRACT/BOA: "_PRCH,1:"")," Possible ",$S(PRCHDT:"Method/Type Codes: ",1:"Type Codes: ")
  1. . I 'PRCHDT S I=0 F Y=0:0 S Y=$O(^PRCD(420.6,Y)) S:Y>100 Y="" Q:'Y D EN7^PRCHNPO2 I $T W:I "," W $P(^PRCD(420.6,Y,0),"^",1) S I=I+1
  1. . I PRCHDT S I=0 F Y=100:0 S Y=$O(^PRCD(420.6,Y)) S:Y>120 Y="" Q:'Y D PROC^PRCHFPDS I $T W:I "," W $P(^PRCD(420.6,Y,0),U,1) S I=I+1
  1. . Q
  1. ;
  1. S PRCHX=$P(PRCH("AM",PRCH),U,3),K=0
  1. I PRCHX]"" W !?1,"ITEM: " W:PRCHX'[":1:" PRCHX I PRCHX[":1:" F J=0:0 S PRCHX=$P(PRCHX,":1:",1)_":"_$P(PRCHX,":1:",2,99) I PRCHX'[":1:" W PRCHX Q
  1. S:$P(PRCH("AM",PRCH),U,2)]"" PRCH("AM",PRCH)=$P(PRCH("AM",PRCH),U,2)
  1. Q
  1. ;
  1. Q L K PRCH,PRCHAC,PRCHACT,PRCHAM,PRCHAMT,PRCHB,PRCHBO,PRCHCN,PRCHCNT,PRCHD,PRCHDA,PRCHDT,PRCHEC,PRCHER,PRCHES,PRCHEST,PRCHFPDS,PRCHI,PRCHL0,PRCHL1,PRCHL2,PRCHL3,PRCHLCNT,PRCHLI
  1. K PRCHN,PRCHP,PRCHPO,PRCHSC,PRCHV,PRCHX,PRCHY,DIC,DIE,DR,D0,DA,X,Y
  1. Q