- 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 Jan 18, 2025@03:10:08 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