PRCHNRQ ;ID/RSD-ENTER/EDIT REQUISITIONS ;3/10/98  11:43 AM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N POCARD
 I $P($G(^PRC(442,PRCHPO,0)),U,2)=25 S POCARD=1
 S PRCHN("PO")=$P($P(^PRC(442,PRCHPO,0),"-",2),U,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 PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19)
 S X="",PRCHN("ID")=PRCHN("PO") F I=1:1 S X=$E(PRCHN("PO"),I) Q:X=""  I X=+X S PRCHN("ID")=$E(PRCHN("PO"),1,I-1)_$E(PRCHN("PO"),I+1,6) Q
 I 'PRCHN("MP") W !?5,"Method of Processing is undefined !",$C(7) G INC
 K ^PRC(442,PRCHPO,9) S $P(^PRC(442,PRCHPO,0),U,15,16)="0^0"
 I '$G(PRCHPC),'$G(PRCHDELV),PRCHDT D FPDS^PRCHFPD2
 ;
EST G INC:'$D(PRCHPO) I 'PRCHEST,PRCHESTL S $P(^PRC(442,PRCHPO,0),U,18)=""
 I PRCHEST D EST^PRCHNPO6
 S PRCHTYP="A" S:$D(PRCHISMS) PRCHTYP="I" K PRCHNM
 D EN2A^PRCHNPO7
 ;
 ; FIX FOR NOIS SDH-1196-N0212
 ;
 S (D0,DA)=PRCHPO
 D ^PRCHSF
 ;
 ; END OF FIX
 ;
 S (X,Y)=4,DA=PRCHPO D UPD^PRCHSTAT S %=1,%B="",%A="     Review Requisition " D ^PRCFYN G:%=-1 INC I %=1 S D0=PRCHPO D ^PRCHDP1
 S VAR2="" I $G(PRCHPC)'=1 D NEW^PRCOEDC(PRCHPO,.VAR2) I $G(VAR2)]"" W !,VAR2 K VAR2 G INC
 I $G(POCARD)=1 S FILE=442 D LIMIT^PRCHCD0 I $G(ERROR) K FILE,ERROR G INC
 G:$$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 SIG
 I '$D(PRCHLOG) G SIG ; LOG BYPASS SWITCH
 K PRCHNM G:PRCHSC=9 SIG I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)]"" W !!,$C(7),"LOG code sheets have already been created.",!! G SIG
 I $D(^PRC(442,PRCHPO,1)),$P(^(1),U,18)="N" D W2 G SIG
 I $G(POCARD) G SIG
 W !!!! S %B="",%A="     Create LOG code sheets ",%=2 D ^PRCFYN G:%=-1 INC G:%'=1 SIG
 S PRCHENT="PRCHNRQ" D EN11^PRCHEC G:'$D(PRCHPO) INC
 ;
SIG I PRCHSC'=9,$D(PRCHLOG) D:'$D(^PRC(442,PRCHPO,18)) W I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)']"",'$G(POCARD) D W
 I '$G(POCARD),$D(PRCHISMS),(PRCHSC=9!(PRCHSC=1)) I $P($G(^PRC(442,PRCHPO,12)),"^",10)="" D  G:%=1 ISMS G INC
  .W !! S %A="  Do you want to send code sheet to Austin? " S %=2 D ^PRCFYN Q
 W !! S %A="  Affix signature to Requisition and Print ",%B="If you answer 'Y' (YES), you can no longer edit this Order except by Amendment.",%B(1)="You must answer YES before you can receive items on this Order."
 S %=2 D ^PRCFYN G:%'=1 INC
 I '$D(PRCHNM) S DA=PRCHPO,P=+PRC("PER") S PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" I PRCSIG<1 D QQ G INC
 ;
PRT ;SET STATUS TO 'ORDERED (NO FISCAL ACTION REQUIRED' IF SUPPLY FUND, 'PENDING FISCAL ACTION' OTHERWISE
 S FILE=442 D:$D(PRCHPO) CHECK^PRCHSWCH K FILE
 S (PRCHSTAT,X)=$S(PRCHN("SFC")=2!$G(POCARD)!$G(PRCHOBL)=1:22,1:10),DA=PRCHPO D ENS^PRCHSTAT
 S (D0,DA)=PRCHPO D ^PRCHSF
 S PRCSIG="" D ENCODE^PRCHES5(PRCHPO,DUZ,.PRCSIG) S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
 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 $P(^(2),U)=+$P($G(^PRC(440.5,PRCHCD,2)),U)+PRCHPOMT
 . S PODA=DA,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
 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
 . . . ;Update file #440.5
 . . . S PRCHCD=+$P(^PRC(442,PRCHPO,23),U,8)
 . . . S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15)
 . . . S $P(^PRC(440.5,PRCHCD,2),U,1)=$P(^PRC(440.5,PRCHCD,2),U,1)+PRCHPOMT
 . . 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
 . 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
 ;S PRCOPODA=PRCHPO I PRCHN("SFC")=2!$G(POCARD) D
 ;. D:'$G(POCARD) OBL D:$G(PRCHPC)'=1 ^PRCOEDI
 ;. I $G(POCARD)&($P(^PRC(442,PRCHPO,0),U,12)]"") D
 ;. . D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10)) Q
 ;. I $G(PRCHN("SFC"))=2 D SUPP^PRCFFMO W VAR2 H 2
INV S DA=PRCHPO D UPDATE^PRCPWIU
 ;I $G(PRCH("SFC"))'=2,'$G(POCARD) D
 ;. I $G(PRCHOBL)=1 D:$G(PRCHPC)'=1 ^PRCOEDI D SUPP^PRCFFMO W VAR2 H 2
 ;. I $G(PRCHOBL)=2 D:$G(PRCHPC)'=1 ^PRCOEDI
 I $D(PRCHNRQ) S:PRCHNRQ="" PRCHNRQ=1
 I '$G(POCARD) S PRCHQ("DEST")="F",D0=PRCHPO,PRCHQ="^PRCHFPNT" D ^PRCHQUE
 I $G(PRCHN("SFC"))=2!$G(POCARD) S:'$G(POCARD) PRCHQ("DEST")="S" S D0=PRCHPO,PRCHQ="^PRCHFPNT" D ^PRCHQUE
 G Q
 ;
QQ S:'$D(ROUTINE) ROUTINE=$T(+0) 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,ROUTINE
 Q
 ;
Q L  D Q^PRCHNPO4 K PRCF,PRCFA,PRCHENT,PRCHLOG,PRCHN,PRCHTYP,ROUTINE
 Q
 ;
ISMS ;CHECK ISMS SWITCH AND CREATE ISMS COD
 I $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 S PRCHTRAN="" D
  .I PRCHSC=1 S PRCHTRAN=$S($P(^PRC(442,PRCHPO,0),U,19)=2:"TO1",1:"SO1") D EN11^PRCHEI(PRCHTRAN)
  .I PRCHSC=9 S PRCHTRAN="PO1" D EN11^PRCHEI(PRCHTRAN)
 G Q
 ;
INC D Q G ERR^PRCHNPO
 ;
OBL ;UPDATE CONTROL POINT OBLIGATED BALANCE
 I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,12) W $C(7),!,"This Supply Fund order has already updated the Control Point",!,"Obligated Balance.",!! Q
 I $D(PRCHN("SFC")),PRCHN("SFC")=2 S $P(^PRC(442,PRCHPO,18),U,12)=1
 S DA=+$P(^PRC(442,PRCHPO,0),U,12) G:'DA ERR G:'$D(^PRCS(410,DA,0)) ERR
 I $D(PRC("PER")) S PRCSIG="" D ENCODE^PRCSC2(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
 S X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES
 S X=$P(^PRC(442,PRCHPO,0),U,16),Y=$P(^(0),U,10),$P(^PRCS(410,DA,4),"^",4)=DT,$P(^(9),"^",2)=Y,$P(^(4),"^",3)=X,$P(^(4),"^",8)=X D TRANS^PRCSES,TRANS1^PRCSES
 Q
 ;
ERR W $C(7),!!,"Control Point Balances NOT updated!!"
 Q
 ;
W Q:'$D(PRCHLOG)  W $C(7),!!,"WARNING--LOG code sheets have NOT been created!!"
 Q
 ;
W2 W !!,$C(7),"LOG code sheets for non-expendable good not yet programmed.",!,"Use FALCON or KEYPUNCH A CODESHEET option to create these.",!!
 Q