source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNRQ.m@ 810

Last change on this file since 810 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1PRCHNRQ ;ID/RSD-ENTER/EDIT REQUISITIONS ;3/10/98 11:43 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N POCARD
5 I $P($G(^PRC(442,PRCHPO,0)),U,2)=25 S POCARD=1
6 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))
7 S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19)
8 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
9 I 'PRCHN("MP") W !?5,"Method of Processing is undefined !",$C(7) G INC
10 K ^PRC(442,PRCHPO,9) S $P(^PRC(442,PRCHPO,0),U,15,16)="0^0"
11 I '$G(PRCHPC),'$G(PRCHDELV),PRCHDT D FPDS^PRCHFPD2
12 ;
13EST G INC:'$D(PRCHPO) I 'PRCHEST,PRCHESTL S $P(^PRC(442,PRCHPO,0),U,18)=""
14 I PRCHEST D EST^PRCHNPO6
15 S PRCHTYP="A" S:$D(PRCHISMS) PRCHTYP="I" K PRCHNM
16 D EN2A^PRCHNPO7
17 ;
18 ; FIX FOR NOIS SDH-1196-N0212
19 ;
20 S (D0,DA)=PRCHPO
21 D ^PRCHSF
22 ;
23 ; END OF FIX
24 ;
25 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
26 S VAR2="" I $G(PRCHPC)'=1 D NEW^PRCOEDC(PRCHPO,.VAR2) I $G(VAR2)]"" W !,VAR2 K VAR2 G INC
27 I $G(POCARD)=1 S FILE=442 D LIMIT^PRCHCD0 I $G(ERROR) K FILE,ERROR G INC
28 G:$$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 SIG
29 I '$D(PRCHLOG) G SIG ; LOG BYPASS SWITCH
30 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
31 I $D(^PRC(442,PRCHPO,1)),$P(^(1),U,18)="N" D W2 G SIG
32 I $G(POCARD) G SIG
33 W !!!! S %B="",%A=" Create LOG code sheets ",%=2 D ^PRCFYN G:%=-1 INC G:%'=1 SIG
34 S PRCHENT="PRCHNRQ" D EN11^PRCHEC G:'$D(PRCHPO) INC
35 ;
36SIG 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
37 I '$G(POCARD),$D(PRCHISMS),(PRCHSC=9!(PRCHSC=1)) I $P($G(^PRC(442,PRCHPO,12)),"^",10)="" D G:%=1 ISMS G INC
38 .W !! S %A=" Do you want to send code sheet to Austin? " S %=2 D ^PRCFYN Q
39 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."
40 S %=2 D ^PRCFYN G:%'=1 INC
41 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
42 ;
43PRT ;SET STATUS TO 'ORDERED (NO FISCAL ACTION REQUIRED' IF SUPPLY FUND, 'PENDING FISCAL ACTION' OTHERWISE
44 S FILE=442 D:$D(PRCHPO) CHECK^PRCHSWCH K FILE
45 S (PRCHSTAT,X)=$S(PRCHN("SFC")=2!$G(POCARD)!$G(PRCHOBL)=1:22,1:10),DA=PRCHPO D ENS^PRCHSTAT
46 S (D0,DA)=PRCHPO D ^PRCHSF
47 S PRCSIG="" D ENCODE^PRCHES5(PRCHPO,DUZ,.PRCSIG) S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
48 I $G(PRCHPC)!$G(PRCHDELV) D
49 . I $P($G(^PRC(442,PRCHPO,23)),U,8)]"" D
50 . . S PRCHCD=$P(^PRC(442,PRCHPO,23),U,8)
51 . . S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15)
52 . . S $P(^(2),U)=+$P($G(^PRC(440.5,PRCHCD,2)),U)+PRCHPOMT
53 . S PODA=DA,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
54 I PRCHN("MP")=25 D S $P(^PRC(442,PRCHPO,24),U)=1 G INV
55 . I $G(PRCHPC)'=1 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
56 . I '$P($G(^PRC(442,PRCHPO,23)),U,11) D
57 . . I '$P(^PRC(442,PRCHPO,0),U,12) S DA=PRCHPO D START^PRCH410 D Q
58 . . . S PODA=PRCHPO,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
59 . . . ;Update file #440.5
60 . . . S PRCHCD=+$P(^PRC(442,PRCHPO,23),U,8)
61 . . . S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15)
62 . . . S $P(^PRC(440.5,PRCHCD,2),U,1)=$P(^PRC(440.5,PRCHCD,2),U,1)+PRCHPOMT
63 . . I $P(^PRC(442,PRCHPO,0),U,12) D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10))
64 ;
65 I $G(PRCHSTAT)'="",PRCHSTAT'=10 D S:$P(^PRC(442,PRCHPO,0),U,2)=26 $P(^PRC(442,PRCHPO,24),U)=1 G INV
66 . N PRCOPODA S PRCOPODA=PRCHPO D ^PRCOEDI,SUPP^PRCFFMO
67 I $G(PRCHOBL)=2 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
68 ;S PRCOPODA=PRCHPO I PRCHN("SFC")=2!$G(POCARD) D
69 ;. D:'$G(POCARD) OBL D:$G(PRCHPC)'=1 ^PRCOEDI
70 ;. I $G(POCARD)&($P(^PRC(442,PRCHPO,0),U,12)]"") D
71 ;. . D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10)) Q
72 ;. I $G(PRCHN("SFC"))=2 D SUPP^PRCFFMO W VAR2 H 2
73INV S DA=PRCHPO D UPDATE^PRCPWIU
74 ;I $G(PRCH("SFC"))'=2,'$G(POCARD) D
75 ;. I $G(PRCHOBL)=1 D:$G(PRCHPC)'=1 ^PRCOEDI D SUPP^PRCFFMO W VAR2 H 2
76 ;. I $G(PRCHOBL)=2 D:$G(PRCHPC)'=1 ^PRCOEDI
77 I $D(PRCHNRQ) S:PRCHNRQ="" PRCHNRQ=1
78 I '$G(POCARD) S PRCHQ("DEST")="F",D0=PRCHPO,PRCHQ="^PRCHFPNT" D ^PRCHQUE
79 I $G(PRCHN("SFC"))=2!$G(POCARD) S:'$G(POCARD) PRCHQ("DEST")="S" S D0=PRCHPO,PRCHQ="^PRCHFPNT" D ^PRCHQUE
80 G Q
81 ;
82QQ 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
83 Q
84 ;
85Q L D Q^PRCHNPO4 K PRCF,PRCFA,PRCHENT,PRCHLOG,PRCHN,PRCHTYP,ROUTINE
86 Q
87 ;
88ISMS ;CHECK ISMS SWITCH AND CREATE ISMS COD
89 I $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 S PRCHTRAN="" D
90 .I PRCHSC=1 S PRCHTRAN=$S($P(^PRC(442,PRCHPO,0),U,19)=2:"TO1",1:"SO1") D EN11^PRCHEI(PRCHTRAN)
91 .I PRCHSC=9 S PRCHTRAN="PO1" D EN11^PRCHEI(PRCHTRAN)
92 G Q
93 ;
94INC D Q G ERR^PRCHNPO
95 ;
96OBL ;UPDATE CONTROL POINT OBLIGATED BALANCE
97 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
98 I $D(PRCHN("SFC")),PRCHN("SFC")=2 S $P(^PRC(442,PRCHPO,18),U,12)=1
99 S DA=+$P(^PRC(442,PRCHPO,0),U,12) G:'DA ERR G:'$D(^PRCS(410,DA,0)) ERR
100 I $D(PRC("PER")) S PRCSIG="" D ENCODE^PRCSC2(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
101 S X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES
102 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
103 Q
104 ;
105ERR W $C(7),!!,"Control Point Balances NOT updated!!"
106 Q
107 ;
108W Q:'$D(PRCHLOG) W $C(7),!!,"WARNING--LOG code sheets have NOT been created!!"
109 Q
110 ;
111W2 W !!,$C(7),"LOG code sheets for non-expendable good not yet programmed.",!,"Use FALCON or KEYPUNCH A CODESHEET option to create these.",!!
112 Q
Note: See TracBrowser for help on using the repository browser.