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