PRCHNPO4 ;WOIFO/RSD/RHD-CONT. OF NEW PO--COMPLETE PROCESSING IN SUPPLY ;4/22/98 06:21
V ;;5.1;IFCAP;**51,56,81,79,196,220**;Oct 20, 2000;Build 23
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*196 Modified check for only PCard orders to insure ALL
; orders have FCP monies available for the order,
; and, if not, the FCP Overcommit switch set to ON.
;PRC*5.1*220 Comment out the check, message and call for FPDS messaging
;
PHA S ERROR="" I $G(PRCHPC)'=1 D NEW^PRCOEDC(PRCHPO,.ERROR) I ERROR'="" W !!?5,"Procurement History transaction error " G ERR^PRCHNPO
N RBD,RBDT,RBQT,RBFY,CCHK,FCHK,REFMOP S REFMOP=$P($G(^PRC(442,PRCHPO,0)),U,2)
S RBDT=$$DATE^PRC0C($P($G(^PRC(442,PRCHPO,1)),U,15),"I"),RBFY=$E(RBDT,3,4),RBQT=$P(RBDT,"^",2),RBD=$$QTRDATE^PRC0D(RBFY,RBQT),RBD=$P(RBD,"^",7) ;PRC*5.1*196
S PRC("CP")=$P($G(^PRC(442,PRCHPO,0)),"^",3)
S CCHK=$P($G(^PRC(442,PRCHPO,0)),U,15)
I $G(PRCHPC)="",CCHK'="" N BRCHK,BRCOST S BRCHK=$P($G(^PRC(442,PRCHPO,0)),"^",12),BRCOST=$P($G(^PRCS(410,+BRCHK,4)),"^") S:BRCOST'="" CCHK=CCHK-BRCOST
S FCHK=$$OVCOM^PRCS0A(PRC("SITE")_"^"_PRC("CP")_"^"_$P($$DATE^PRC0C(RBD,"I"),"^",1,2),CCHK,2) I FCHK'=0 W !,"Insufficient funds for this request." H 2 G ERR^PRCHNPO ;PRC*5.1*196
I $P($G(^PRC(442,PRCHPO,0)),U,2)=25 S FILE=442 D LIMIT^PRCHCD0 I $G(ERROR) K FILE,ERROR G ERR^PRCHNPO
;I $G(PRCHPC)=2 S $P(^PRC(442,PRCHPO,0),U,15)=PRCHTAMT
I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" D G:$G(ERROR)=1 ERR^PRCHNPO
. S PRCHITM=0 F S PRCHITM=$O(^PRC(442,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(442,PRCHPO,2,PRCHITM,2)),U,2)="" W !!,?5,"One or more of the items on this delivery order",!,?5,"does not contain contract number." S ERROR=1
;
; New check for FPDS, PRC*5.1*79
; Check Detailed PC orders with source code 6 and contract items only
I $P($G(^PRC(442,PRCHPO,23)),U,11)="P"&($P($G(^PRC(442,PRCHPO,1)),U,7)=6) D G:$G(ERROR)=1 ERR^PRCHNPO
. S PRCHITM=0 F S PRCHITM=$O(^PRC(442,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(442,PRCHPO,2,PRCHITM,2)),U,2)="" W !!,?5,"Line item "_PRCHITM_" on this purchase card order",!,?5,"does not contain a required contract number." S ERROR=1
D EN105^PRCHNPO7 G:$G(ERROR)=1 ERR^PRCHNPO
; End of new check for FPDS
;
FS S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19)
; SET STATUS TO 'Ordered (no Fiscal Action Required)' IF IMPREST FUNDS METHOD OF PROCESSING, OR IF SPECIAL CONTROL POINT FOR SUPPLY FUND (POSTED).
; SET STATUS TO 'Transaction Complete' FOR CERTIFIED INVOICES ORDERED FOR SUPPLY FUND.
; SET STATUS TO 'Pending Fiscal Action' OTHERWISE.
S PRCHSTAT=10,%A="Send to Fiscal Service"
I PRCHN("SFC")=2!(PRCHN("MP")=25) S PRCHSTAT=22,%A="Print Purchase Order"
S FILE=442 D:$D(PRCHPO) CHECK^PRCHSWCH
I $G(PRCHOBL)=1 S PRCHSTAT=22,%A="Print Purchase Order "
I PRCHN("MP")=2,PRCHN("SFC")=2 S PRCHSTAT=40
;
ASK I '$G(PRCHPC),'$G(PRCHDELV) D G Q:%=2&(PRCHN("MP")'=25)!(%<0),FS:%=0
. W ! S %A=" "_%A,%B="",%=1 D ^PRCFYN
. S NOPRINT="" I %=2 S NOPRINT=1
S P=+$P($G(^PRC(442,PRCHPO,1)),U,10),DA=PRCHPO
I 'P W !!,"P.O. is missing the Purchasing Agent and must be re-edited !",$C(7) G Q
I P'=DUZ W !!,"You must be the Purchasing Agent listed on P.O. to sign it.",$C(7) S DIR(0)="EAO",DIR("A")="Press <Return> to continue " D ^DIR K DIR(0),DIR("A") G Q
I $G(PRCHPHAM),$P(^PRC(442,PRCHPO,0),U,15)=0 D G:%'=1 ERR^PRCHNPO
. W !!,?5,"This pharmacy order is a no charge order." S %A=" Would you like to sign this order",%B="",%=2 D ^PRCFYN
S X=$P($G(^PRC(442,PRCHPO,1)),U)
;
; Begin modifications for PRC*5.1*56
I X]"",$P($G(^PRC(440,X,3)),U,2)="Y",";P;S;"[(";"_$P($G(^PRC(442,PRCHPO,23)),U,11)_";") D
. S MSG1=" This order will not be sent via EDI."
. S MSG2="To place a Purchase Card order via EDI please use the Purchasing Agent Menu."
. W !!!," ***** TAKE NOTE *****"
. W !!,?2,MSG1,!!,MSG2,!!
. K MSG1,MSG2
. Q
; End modifications for PRC*5.1*56
I X]"",$P($G(^PRC(440,X,3)),U,2)="Y",";P;S;"'[(";"_$P($G(^PRC(442,PRCHPO,23)),U,11)_";") D G:$G(X)="ABORT" Q I $D(DTOUT)!$D(Y) W $C(7),!!,"The 'Do You Want to Send This EDI?' question was bypassed - You must reedit PO" K DTOUT G Q
. N PRCY S PRCY=""
. I $P($G(^PRC(442,PRCHPO,0)),U,2)=25 D
. . N PRCX
. . S PRCX=$P($G(^PRC(442,PRCHPO,23)),U,8)
. . S:PRCX'="" PRCX=$P($G(^PRC(440.5,PRCX,2)),U,4)
. . D NOW^%DTC
. . I ($E(PRCX,6,7)>0&(X>PRCX))!(+$E(PRCX,6,7)=0&(X\100>(PRCX\100))) D
. . . W !!,"In File #440.5, the Expiration Date for this card is blank or this card has"
. . . W !,?5,"expired! An EDI order will reject. Please contact your Purchase"
. . . W !,?5,"Card Coordinator." S PRCY="NO"
. N DIE,DR,DA
. S DIE=442,DR="116///@;S Y=""@1"";@1;116Do You Want to Send This EDI?~R",DA=PRCHPO D ^DIE
. Q:$D(DTOUT)!$D(Y)
. I $P($G(^PRC(442,PRCHPO,12)),U,16)="y",PRCY="NO" D
. . S X="ABORT"
. . W !,"As you have elected to send this order EDI, please ask the Purchase Card"
. . W !,"Coordinator to update the Card's Expiration Date before completing this"
. . W !,"Purchase Order. - You must reedit this PO."
; UPDATE STATUS, P.A.SIGNATURE & BOC DATA, IN P.O.
S PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" I PRCSIG<1 D QQ G Q
;Following line added in P194: go create new txn # if PC order modified
;to new FCP
D CHECKFCP^PRCHNPOA(PRCHPO)
;I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P(^PRC(442,PRCHPO,0),U,2)=26 S $P(^PRC(442,PRCHPO,24),U)=1
I $G(PRCHPC)!$G(PRCHDELV) D G Q:%<0,FS:%=0
. I $G(PRCPROST) S PRCPROST=3.9,NOPRINT=1,%=2 QUIT
. S %A=$S($G(PRCHPC):"Print Purchase Card Order ",1:"Print Delivery Order")
. W ! S %A=" "_%A,%B="",%=1 D ^PRCFYN
. S NOPRINT="" I %=2 S NOPRINT=1
;
S X=$S($G(PRCHPHAM)'="":30,1:PRCHSTAT),DA=PRCHPO D ENS^PRCHSTAT
S (D0,DA)=PRCHPO D ^PRCHSF ;CALLS ROUTINE FOR FMS PROCESSING
S %DT="T",X="NOW" D ^%DT S PRCSIG="" D ENCODE^PRCHES5(DA,DUZ,.PRCSIG)
S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
S D0=PRCHPO K D1 S:'$D(DT) DT=$P(Y,".",1)
;
I $G(PRCHPC)!$G(PRCHDELV) D
. I $P($G(^PRC(442,PRCHPO,23)),U,8)]"" D
. . S PRCHCD=$P(^PRC(442,PRCHPO,23),U,8)
. . S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15)
. S PODA=DA,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
; IF SUPPLY FUND, NOT CERTIFIED INVOICE, SET FLAG NOTIFYING PPM TO CREATE LOG CODE SHEETS
S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15),PRCHCD=$P(^PRC(442,PRCHPO,23),U,8)
I $P($G(^PRC(442,PRCHPO,0)),U,2)=25,$G(PRCHCD)'="" S $P(^PRC(440.5,PRCHCD,2),U)=+$P($G(^PRC(440.5,PRCHCD,2)),U)+PRCHPOMT
I PRCHN("SFC")=2 S $P(^PRC(442,PRCHPO,18),U,12)=1
I PRCHN("SFC")=2,PRCHN("MP")'=2 S $P(^PRC(442,PRCHPO,18),U,11)="N",^PRC(442,"AE","N",PRCHPO)=""
; IF SUPPLY FUND, CERTIFIED INVOICE, UPDATE CONTROL POINT OBLIGATED BALANCE.
;
ISMS ;I PRCHSC=9 ;;I $D(PRCHISMS) ;CHECK ISMS SWITCH AND IF TRUE CREATE ISMS TRANSACTION
;I PRCHSC=1 D:0 EN11^PRCHEI
;I PRCHSC=9 S PRCHTRAN="PO1" D EN11^PRCHEI(PRCHTRAN)
;
; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D UPD^PRCV442A(PRCHPO)
;
EDI ;CHECK TO SEE IF IT IS AN EDI PO AND SEND TO AUSTIN
;I $G(PRCHSTAT)'="",PRCHSTAT'=10 N PRCOPODA S PRCOPODA=PRCHPO D ^PRCOEDI
I PRCHN("MP")=25 D S $P(^PRC(442,PRCHPO,24),U)=1 G INV
. I $G(PRCHPC)'=1 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
. I '$P($G(^PRC(442,PRCHPO,23)),U,11) D
. . I '$P(^PRC(442,PRCHPO,0),U,12) S DA=PRCHPO D START^PRCH410 D Q
. . . S PODA=PRCHPO,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
. . I $P(^PRC(442,PRCHPO,0),U,12) D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10))
I $G(PRCHSTAT)'="",PRCHSTAT'=10 D S:$P(^PRC(442,PRCHPO,0),U,2)=26 $P(^PRC(442,PRCHPO,24),U)=1 G INV
. Q:$P(^PRC(442,PRCHPO,0),U,2)=2
. N PRCOPODA S PRCOPODA=PRCHPO D ^PRCOEDI,SUPP^PRCFFMO
I $G(PRCHOBL)=2 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
;
;update due-ins at the inventory point
INV G:$P($G(^PRC(442,PRCHPO,23)),U,11)="S" PRT
G:$G(PRCHPHAM) PRT
S FLG=0 I $P(^PRC(442,PRCHPO,0),U,2)=2 D
.S N=0 F S N=$O(^PRC(442,PRCHPO,2,N)) Q:'N!(FLG) I $P(^(N,0),U,5)]"" S FLG=1
.K N
I $P($G(^PRC(442,PRCHPO,23)),U,11)'="S" I '$G(PRCHPHAM) D
. I $P(^PRC(442,PRCHPO,0),U,2)'=2 S DA=PRCHPO D UPDATE^PRCPWIU
. I ($P(^PRC(442,PRCHPO,0),U,2)=2)&(FLG) S DA=PRCHPO D UPDATE^PRCPWIU
K FLG
;S DA=PRCHPO D UPDATE^PRCPWIU
;
PRT ;IF IMPREST FUND PO, PRINT A COPY ON BOTH IMPREST FUND & FISCAL PRINTER.
;IF SUPPLY FUND PO, PRINT A COPY IN P&C AND ONE IN FISCAL.
; OTHERWISE, PRINT A COPY IN FISCAL
;IF SUPPLY FUND PAYMENT IN ADVANCE, PRINT 2 MORE COPIES IN FISCAL.
K PRCHQ S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT"
;
I PRCHN("MP")=12 S PRCHQ("DEST2")="IFP" D ^PRCHQUE
I '$G(NOPRINT) I PRCHN("SFC")=2!(PRCHN("MP")=25) S:PRCHN("MP")'=25 PRCHQ("DEST")="S8" D ^PRCHQUE S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT"
;
K PRCHQ S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT"
I PRCHN("MP")'=25 S PRCHQ("DEST")="F" D ^PRCHQUE
I PRCHN("SFC")=2,PRCHN("MP")=3 F PRCHI=1,2 S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT",PRCHQ("DEST")="F" D ^PRCHQUE
G Q
;
QQ N:'$D(ROUTINE) ROUTINE S:$G(ROUTINE)="" ROUTINE=$T(+0) N DIR
W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7)
S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR K PRCSIG
Q
;
Q N PRCHDA
I +$G(PRCHPO) L -^PRC(442,PRCHPO) ;PRC*5.1*220
S PRCHDA=+$G(DA) I +$G(PRCHDA),PRCHDA'=+$G(PRCHPO),$D(^PRC(442,PRCHDA)) L -^PRC(442,PRCHDA) ;PRC*5.1*220
K PRCH,PRCHAC,PRCHACT,PRCHAM,PRCHAMT,PRCHB,PRCHBO,PRCHCN,PRCHCNT,PRCHD,PRCHDA,PRCHDT,PRCHEC,PRCHEDI,PRCHER,PRCHES,PRCHEST,PRCHESTL,PRCHFPDS
K PRCHI,PRCHL0,PRCHL1,PRCHL2,PRCHL3,PRCHLCNT,PRCHLI,PRCSIG,ROUTINE
K PRCHN,PRCHNM,PRCHNRQ,PRCHP,PRCHPO,PRCHPONO,PRCHQ,PRCHS,PRCHSC,PRCHSTAT,PRCHTTT,PRCHV,PRCHVAR,PRCHX,PRCHY,DIC,DIE,DR,D0,DA,X,Y,Z,I,J,K,P,ZTSK
K ERROR,ITEMCNT,M,M0,PRCHFCP,PRCHLOG,PRCHSTN,ZTDESC,ZTRTN,ZTUCI,A,B,C,V3,PRCHXXD0,F1,I1,POP,PRCHLN,SUBACC,ERROR1,NOPRINT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO4 10133 printed Oct 16, 2024@18:09:41 Page 2
PRCHNPO4 ;WOIFO/RSD/RHD-CONT. OF NEW PO--COMPLETE PROCESSING IN SUPPLY ;4/22/98 06:21
V ;;5.1;IFCAP;**51,56,81,79,196,220**;Oct 20, 2000;Build 23
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*196 Modified check for only PCard orders to insure ALL
+4 ; orders have FCP monies available for the order,
+5 ; and, if not, the FCP Overcommit switch set to ON.
+6 ;PRC*5.1*220 Comment out the check, message and call for FPDS messaging
+7 ;
PHA SET ERROR=""
IF $GET(PRCHPC)'=1
DO NEW^PRCOEDC(PRCHPO,.ERROR)
IF ERROR'=""
WRITE !!?5,"Procurement History transaction error "
GOTO ERR^PRCHNPO
+1 NEW RBD,RBDT,RBQT,RBFY,CCHK,FCHK,REFMOP
SET REFMOP=$PIECE($GET(^PRC(442,PRCHPO,0)),U,2)
+2 ;PRC*5.1*196
SET RBDT=$$DATE^PRC0C($PIECE($GET(^PRC(442,PRCHPO,1)),U,15),"I")
SET RBFY=$EXTRACT(RBDT,3,4)
SET RBQT=$PIECE(RBDT,"^",2)
SET RBD=$$QTRDATE^PRC0D(RBFY,RBQT)
SET RBD=$PIECE(RBD,"^",7)
+3 SET PRC("CP")=$PIECE($GET(^PRC(442,PRCHPO,0)),"^",3)
+4 SET CCHK=$PIECE($GET(^PRC(442,PRCHPO,0)),U,15)
+5 IF $GET(PRCHPC)=""
IF CCHK'=""
NEW BRCHK,BRCOST
SET BRCHK=$PIECE($GET(^PRC(442,PRCHPO,0)),"^",12)
SET BRCOST=$PIECE($GET(^PRCS(410,+BRCHK,4)),"^")
if BRCOST'=""
SET CCHK=CCHK-BRCOST
+6 ;PRC*5.1*196
SET FCHK=$$OVCOM^PRCS0A(PRC("SITE")_"^"_PRC("CP")_"^"_$PIECE($$DATE^PRC0C(RBD,"I"),"^",1,2),CCHK,2)
IF FCHK'=0
WRITE !,"Insufficient funds for this request."
HANG 2
GOTO ERR^PRCHNPO
+7 IF $PIECE($GET(^PRC(442,PRCHPO,0)),U,2)=25
SET FILE=442
DO LIMIT^PRCHCD0
IF $GET(ERROR)
KILL FILE,ERROR
GOTO ERR^PRCHNPO
+8 ;I $G(PRCHPC)=2 S $P(^PRC(442,PRCHPO,0),U,15)=PRCHTAMT
+9 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"
Begin DoDot:1
+10 SET PRCHITM=0
FOR
SET PRCHITM=$ORDER(^PRC(442,PRCHPO,2,PRCHITM))
if 'PRCHITM
QUIT
IF $PIECE($GET(^PRC(442,PRCHPO,2,PRCHITM,2)),U,2)=""
WRITE !!,?5,"One or more of the items on this delivery order",!,?5,"does not contain contract number."
SET ERROR=1
End DoDot:1
if $GET(ERROR)=1
GOTO ERR^PRCHNPO
+11 ;
+12 ; New check for FPDS, PRC*5.1*79
+13 ; Check Detailed PC orders with source code 6 and contract items only
+14 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="P"&($PIECE($GET(^PRC(442,PRCHPO,1)),U,7)=6)
Begin DoDot:1
+15 SET PRCHITM=0
FOR
SET PRCHITM=$ORDER(^PRC(442,PRCHPO,2,PRCHITM))
if 'PRCHITM
QUIT
IF $PIECE($GET(^PRC(442,PRCHPO,2,PRCHITM,2)),U,2)=""
WRITE !!,?5,"Line item "_PRCHITM_" on this purchase card order",!,?5,"does not contain a required contract number."
SET ERROR=1
End DoDot:1
if $GET(ERROR)=1
GOTO ERR^PRCHNPO
+16 DO EN105^PRCHNPO7
if $GET(ERROR)=1
GOTO ERR^PRCHNPO
+17 ; End of new check for FPDS
+18 ;
FS SET PRCHN("SFC")=$PIECE(^PRC(442,PRCHPO,0),U,19)
+1 ; SET STATUS TO 'Ordered (no Fiscal Action Required)' IF IMPREST FUNDS METHOD OF PROCESSING, OR IF SPECIAL CONTROL POINT FOR SUPPLY FUND (POSTED).
+2 ; SET STATUS TO 'Transaction Complete' FOR CERTIFIED INVOICES ORDERED FOR SUPPLY FUND.
+3 ; SET STATUS TO 'Pending Fiscal Action' OTHERWISE.
+4 SET PRCHSTAT=10
SET %A="Send to Fiscal Service"
+5 IF PRCHN("SFC")=2!(PRCHN("MP")=25)
SET PRCHSTAT=22
SET %A="Print Purchase Order"
+6 SET FILE=442
if $DATA(PRCHPO)
DO CHECK^PRCHSWCH
+7 IF $GET(PRCHOBL)=1
SET PRCHSTAT=22
SET %A="Print Purchase Order "
+8 IF PRCHN("MP")=2
IF PRCHN("SFC")=2
SET PRCHSTAT=40
+9 ;
ASK IF '$GET(PRCHPC)
IF '$GET(PRCHDELV)
Begin DoDot:1
+1 WRITE !
SET %A=" "_%A
SET %B=""
SET %=1
DO ^PRCFYN
+2 SET NOPRINT=""
IF %=2
SET NOPRINT=1
End DoDot:1
if %=2&(PRCHN("MP")'=25)!(%<0)
GOTO Q
if %=0
GOTO FS
+3 SET P=+$PIECE($GET(^PRC(442,PRCHPO,1)),U,10)
SET DA=PRCHPO
+4 IF 'P
WRITE !!,"P.O. is missing the Purchasing Agent and must be re-edited !",$CHAR(7)
GOTO Q
+5 IF P'=DUZ
WRITE !!,"You must be the Purchasing Agent listed on P.O. to sign it.",$CHAR(7)
SET DIR(0)="EAO"
SET DIR("A")="Press <Return> to continue "
DO ^DIR
KILL DIR(0),DIR("A")
GOTO Q
+6 IF $GET(PRCHPHAM)
IF $PIECE(^PRC(442,PRCHPO,0),U,15)=0
Begin DoDot:1
+7 WRITE !!,?5,"This pharmacy order is a no charge order."
SET %A=" Would you like to sign this order"
SET %B=""
SET %=2
DO ^PRCFYN
End DoDot:1
if %'=1
GOTO ERR^PRCHNPO
+8 SET X=$PIECE($GET(^PRC(442,PRCHPO,1)),U)
+9 ;
+10 ; Begin modifications for PRC*5.1*56
+11 IF X]""
IF $PIECE($GET(^PRC(440,X,3)),U,2)="Y"
IF ";P;S;"[(";"_$PIECE($GET(^PRC(442,PRCHPO,23)),U,11)_";")
Begin DoDot:1
+12 SET MSG1=" This order will not be sent via EDI."
+13 SET MSG2="To place a Purchase Card order via EDI please use the Purchasing Agent Menu."
+14 WRITE !!!," ***** TAKE NOTE *****"
+15 WRITE !!,?2,MSG1,!!,MSG2,!!
+16 KILL MSG1,MSG2
+17 QUIT
End DoDot:1
+18 ; End modifications for PRC*5.1*56
+19 IF X]""
IF $PIECE($GET(^PRC(440,X,3)),U,2)="Y"
IF ";P;S;"'[(";"_$PIECE($GET(^PRC(442,PRCHPO,23)),U,11)_";")
Begin DoDot:1
+20 NEW PRCY
SET PRCY=""
+21 IF $PIECE($GET(^PRC(442,PRCHPO,0)),U,2)=25
Begin DoDot:2
+22 NEW PRCX
+23 SET PRCX=$PIECE($GET(^PRC(442,PRCHPO,23)),U,8)
+24 if PRCX'=""
SET PRCX=$PIECE($GET(^PRC(440.5,PRCX,2)),U,4)
+25 DO NOW^%DTC
+26 IF ($EXTRACT(PRCX,6,7)>0&(X>PRCX))!(+$EXTRACT(PRCX,6,7)=0&(X\100>(PRCX\100)))
Begin DoDot:3
+27 WRITE !!,"In File #440.5, the Expiration Date for this card is blank or this card has"
+28 WRITE !,?5,"expired! An EDI order will reject. Please contact your Purchase"
+29 WRITE !,?5,"Card Coordinator."
SET PRCY="NO"
End DoDot:3
End DoDot:2
+30 NEW DIE,DR,DA
+31 SET DIE=442
SET DR="116///@;S Y=""@1"";@1;116Do You Want to Send This EDI?~R"
SET DA=PRCHPO
DO ^DIE
+32 if $DATA(DTOUT)!$DATA(Y)
QUIT
+33 IF $PIECE($GET(^PRC(442,PRCHPO,12)),U,16)="y"
IF PRCY="NO"
Begin DoDot:2
+34 SET X="ABORT"
+35 WRITE !,"As you have elected to send this order EDI, please ask the Purchase Card"
+36 WRITE !,"Coordinator to update the Card's Expiration Date before completing this"
+37 WRITE !,"Purchase Order. - You must reedit this PO."
End DoDot:2
End DoDot:1
if $GET(X)="ABORT"
GOTO Q
IF $DATA(DTOUT)!$DATA(Y)
WRITE $CHAR(7),!!,"The 'Do You Want to Send This EDI?' question was bypassed - You must reedit PO"
KILL DTOUT
GOTO Q
+38 ; UPDATE STATUS, P.A.SIGNATURE & BOC DATA, IN P.O.
+39 SET PRCSIG=""
DO ESIG^PRCUESIG(DUZ,.PRCSIG)
SET ROUTINE="PRCUESIG"
IF PRCSIG<1
DO QQ
GOTO Q
+40 ;Following line added in P194: go create new txn # if PC order modified
+41 ;to new FCP
+42 DO CHECKFCP^PRCHNPOA(PRCHPO)
+43 ;I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P(^PRC(442,PRCHPO,0),U,2)=26 S $P(^PRC(442,PRCHPO,24),U)=1
+44 IF $GET(PRCHPC)!$GET(PRCHDELV)
Begin DoDot:1
+45 IF $GET(PRCPROST)
SET PRCPROST=3.9
SET NOPRINT=1
SET %=2
QUIT
+46 SET %A=$SELECT($GET(PRCHPC):"Print Purchase Card Order ",1:"Print Delivery Order")
+47 WRITE !
SET %A=" "_%A
SET %B=""
SET %=1
DO ^PRCFYN
+48 SET NOPRINT=""
IF %=2
SET NOPRINT=1
End DoDot:1
if %<0
GOTO Q
if %=0
GOTO FS
+49 ;
+50 SET X=$SELECT($GET(PRCHPHAM)'="":30,1:PRCHSTAT)
SET DA=PRCHPO
DO ENS^PRCHSTAT
+51 ;CALLS ROUTINE FOR FMS PROCESSING
SET (D0,DA)=PRCHPO
DO ^PRCHSF
+52 SET %DT="T"
SET X="NOW"
DO ^%DT
SET PRCSIG=""
DO ENCODE^PRCHES5(DA,DUZ,.PRCSIG)
+53 SET ROUTINE=$TEXT(+0)
IF PRCSIG<1
DO QQ
GOTO Q
+54 SET D0=PRCHPO
KILL D1
if '$DATA(DT)
SET DT=$PIECE(Y,".",1)
+55 ;
+56 IF $GET(PRCHPC)!$GET(PRCHDELV)
Begin DoDot:1
+57 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,8)]""
Begin DoDot:2
+58 SET PRCHCD=$PIECE(^PRC(442,PRCHPO,23),U,8)
+59 SET PRCHPOMT=$PIECE(^PRC(442,PRCHPO,0),U,15)
End DoDot:2
+60 SET PODA=DA
SET DA=CDA
SET X=$PIECE(^PRC(442,PRCHPO,0),U,15)
DO ESIG^PRCH410
SET DA=PODA
KILL PODA
End DoDot:1
+61 ; IF SUPPLY FUND, NOT CERTIFIED INVOICE, SET FLAG NOTIFYING PPM TO CREATE LOG CODE SHEETS
+62 SET PRCHPOMT=$PIECE(^PRC(442,PRCHPO,0),U,15)
SET PRCHCD=$PIECE(^PRC(442,PRCHPO,23),U,8)
+63 IF $PIECE($GET(^PRC(442,PRCHPO,0)),U,2)=25
IF $GET(PRCHCD)'=""
SET $PIECE(^PRC(440.5,PRCHCD,2),U)=+$PIECE($GET(^PRC(440.5,PRCHCD,2)),U)+PRCHPOMT
+64 IF PRCHN("SFC")=2
SET $PIECE(^PRC(442,PRCHPO,18),U,12)=1
+65 IF PRCHN("SFC")=2
IF PRCHN("MP")'=2
SET $PIECE(^PRC(442,PRCHPO,18),U,11)="N"
SET ^PRC(442,"AE","N",PRCHPO)=""
+66 ; IF SUPPLY FUND, CERTIFIED INVOICE, UPDATE CONTROL POINT OBLIGATED BALANCE.
+67 ;
ISMS ;I PRCHSC=9 ;;I $D(PRCHISMS) ;CHECK ISMS SWITCH AND IF TRUE CREATE ISMS TRANSACTION
+1 ;I PRCHSC=1 D:0 EN11^PRCHEI
+2 ;I PRCHSC=9 S PRCHTRAN="PO1" D EN11^PRCHEI(PRCHTRAN)
+3 ;
+4 ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
+5 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
DO UPD^PRCV442A(PRCHPO)
+6 ;
EDI ;CHECK TO SEE IF IT IS AN EDI PO AND SEND TO AUSTIN
+1 ;I $G(PRCHSTAT)'="",PRCHSTAT'=10 N PRCOPODA S PRCOPODA=PRCHPO D ^PRCOEDI
+2 IF PRCHN("MP")=25
Begin DoDot:1
+3 IF $GET(PRCHPC)'=1
NEW PRCOPODA
SET PRCOPODA=PRCHPO
WRITE !!,"...now generating the PHA transaction"
DO ^PRCOEDI
+4 IF '$PIECE($GET(^PRC(442,PRCHPO,23)),U,11)
Begin DoDot:2
+5 IF '$PIECE(^PRC(442,PRCHPO,0),U,12)
SET DA=PRCHPO
DO START^PRCH410
Begin DoDot:3
+6 SET PODA=PRCHPO
SET DA=CDA
SET X=$PIECE(^PRC(442,PRCHPO,0),U,15)
DO ESIG^PRCH410
SET DA=PODA
KILL PODA
End DoDot:3
QUIT
+7 IF $PIECE(^PRC(442,PRCHPO,0),U,12)
DO COMM^PRCSPC(PRCHPO,$PIECE(^PRC(442,PRCHPO,0),U,10))
End DoDot:2
End DoDot:1
SET $PIECE(^PRC(442,PRCHPO,24),U)=1
GOTO INV
+8 IF $GET(PRCHSTAT)'=""
IF PRCHSTAT'=10
Begin DoDot:1
+9 if $PIECE(^PRC(442,PRCHPO,0),U,2)=2
QUIT
+10 NEW PRCOPODA
SET PRCOPODA=PRCHPO
DO ^PRCOEDI
DO SUPP^PRCFFMO
End DoDot:1
if $PIECE(^PRC(442,PRCHPO,0),U,2)=26
SET $PIECE(^PRC(442,PRCHPO,24),U)=1
GOTO INV
+11 IF $GET(PRCHOBL)=2
NEW PRCOPODA
SET PRCOPODA=PRCHPO
WRITE !!,"...now generating the PHA transaction"
DO ^PRCOEDI
+12 ;
+13 ;update due-ins at the inventory point
INV if $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="S"
GOTO PRT
+1 if $GET(PRCHPHAM)
GOTO PRT
+2 SET FLG=0
IF $PIECE(^PRC(442,PRCHPO,0),U,2)=2
Begin DoDot:1
+3 SET N=0
FOR
SET N=$ORDER(^PRC(442,PRCHPO,2,N))
if 'N!(FLG)
QUIT
IF $PIECE(^(N,0),U,5)]""
SET FLG=1
+4 KILL N
End DoDot:1
+5 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)'="S"
IF '$GET(PRCHPHAM)
Begin DoDot:1
+6 IF $PIECE(^PRC(442,PRCHPO,0),U,2)'=2
SET DA=PRCHPO
DO UPDATE^PRCPWIU
+7 IF ($PIECE(^PRC(442,PRCHPO,0),U,2)=2)&(FLG)
SET DA=PRCHPO
DO UPDATE^PRCPWIU
End DoDot:1
+8 KILL FLG
+9 ;S DA=PRCHPO D UPDATE^PRCPWIU
+10 ;
PRT ;IF IMPREST FUND PO, PRINT A COPY ON BOTH IMPREST FUND & FISCAL PRINTER.
+1 ;IF SUPPLY FUND PO, PRINT A COPY IN P&C AND ONE IN FISCAL.
+2 ; OTHERWISE, PRINT A COPY IN FISCAL
+3 ;IF SUPPLY FUND PAYMENT IN ADVANCE, PRINT 2 MORE COPIES IN FISCAL.
+4 KILL PRCHQ
SET (D0,DA)=PRCHPO
SET PRCHQ="^PRCHFPNT"
+5 ;
+6 IF PRCHN("MP")=12
SET PRCHQ("DEST2")="IFP"
DO ^PRCHQUE
+7 IF '$GET(NOPRINT)
IF PRCHN("SFC")=2!(PRCHN("MP")=25)
if PRCHN("MP")'=25
SET PRCHQ("DEST")="S8"
DO ^PRCHQUE
SET (D0,DA)=PRCHPO
SET PRCHQ="^PRCHFPNT"
+8 ;
+9 KILL PRCHQ
SET (D0,DA)=PRCHPO
SET PRCHQ="^PRCHFPNT"
+10 IF PRCHN("MP")'=25
SET PRCHQ("DEST")="F"
DO ^PRCHQUE
+11 IF PRCHN("SFC")=2
IF PRCHN("MP")=3
FOR PRCHI=1,2
SET (D0,DA)=PRCHPO
SET PRCHQ="^PRCHFPNT"
SET PRCHQ("DEST")="F"
DO ^PRCHQUE
+12 GOTO Q
+13 ;
QQ if '$DATA(ROUTINE)
NEW ROUTINE
if $GET(ROUTINE)=""
SET ROUTINE=$TEXT(+0)
NEW DIR
+1 WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
if PRCSIG=0!(PRCSIG=-3)
WRITE !,"Notify Application Coordinator!",$CHAR(7)
+2 SET DIR(0)="EAO"
SET DIR("A")="Press <return> to continue"
DO ^DIR
KILL PRCSIG
+3 QUIT
+4 ;
Q NEW PRCHDA
+1 ;PRC*5.1*220
IF +$GET(PRCHPO)
LOCK -^PRC(442,PRCHPO)
+2 ;PRC*5.1*220
SET PRCHDA=+$GET(DA)
IF +$GET(PRCHDA)
IF PRCHDA'=+$GET(PRCHPO)
IF $DATA(^PRC(442,PRCHDA))
LOCK -^PRC(442,PRCHDA)
+3 KILL PRCH,PRCHAC,PRCHACT,PRCHAM,PRCHAMT,PRCHB,PRCHBO,PRCHCN,PRCHCNT,PRCHD,PRCHDA,PRCHDT,PRCHEC,PRCHEDI,PRCHER,PRCHES,PRCHEST,PRCHESTL,PRCHFPDS
+4 KILL PRCHI,PRCHL0,PRCHL1,PRCHL2,PRCHL3,PRCHLCNT,PRCHLI,PRCSIG,ROUTINE
+5 KILL PRCHN,PRCHNM,PRCHNRQ,PRCHP,PRCHPO,PRCHPONO,PRCHQ,PRCHS,PRCHSC,PRCHSTAT,PRCHTTT,PRCHV,PRCHVAR,PRCHX,PRCHY,DIC,DIE,DR,D0,DA,X,Y,Z,I,J,K,P,ZTSK
+6 KILL ERROR,ITEMCNT,M,M0,PRCHFCP,PRCHLOG,PRCHSTN,ZTDESC,ZTRTN,ZTUCI,A,B,C,V3,PRCHXXD0,F1,I1,POP,PRCHLN,SUBACC,ERROR1,NOPRINT
+7 QUIT
