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 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