source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHFPDE.m@ 1464

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

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1PRCHFPDE ;SF-ISC/TKW-EDIT FPDS DATA ON P.O. AFTER SIGNED BY P.A. ;12-6-90/15:48
2V ;;5.1;IFCAP;**79,100**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN1 ;EDIT FPDS DATA ON P.O. AFTER BEING SIGNED BY P.A.
6 I $D(PRCHAM) S PRCHFLG=""
7 N PRCHER,PRCHAM,PRCHAMDA,PRCHAMT,PRCHDUZ ;Newing variables for amends
8 I $D(PRCHPO) S PRCHPOO=PRCHPO N PRCHPO S PRCHPO=PRCHPOO K PRCHPOO
9 D:'$D(PRCHPO) ST^PRCHE Q:'$D(PRC("SITE"))
10EN10 D:'$D(PRCHPO)!'$D(PRCHFLG) LOOK G:'$D(PRCHPO) Q D LCK1^PRCHE G:'$D(DA) EN10 S PRCHEST=$P(^PRC(442,PRCHPO,0),U,13)
11 S X=$G(^PRC(442,PRCHPO,1)),PRCHV=+X,PRCHDT=$S($P(X,U,15)<2881001:0,$P(X,U,15)>2880930:1,1:""),PRCHSC="" I $D(^PRCD(420.8,+$P(X,U,7),0)) S PRCHSC=$P(^(0),U,1)
12 ;
13 ;PRC*5.1*79 - check for canceled orders or ineligible orders, i.e. RMPR
14 I $P(^PRC(442,PRCHPO,7),U,2)=45!($G(PRCHSC)="") D OUT G EN10
15 I $P(^PRC(442,PRCHPO,7),U,2)'>10 D EN^DDIOL("This Purchase Order has not been properly completed.") G EN10
16 I "0139"[PRCHSC D OUT G EN10
17 ;End check for PRC*5.1*79
18 I PRCHDT="" D EN^DDIOL("Purchase Order has no date. ","","!") G EN10
19 I 'PRCHDT W $C(7),!,"This option only available for P.O.'s beyond FY 1988!" G EN10
20 S 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))
21 S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHN("MP")=$P($G(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)),U,3) I 'PRCHN("MP") W !,$C(7),"Method of Processing not entered!" G Q
22 S PRCHBO=$S(PRCHDT:1.1,1:1) K PRCHB
23 G:PRCHDT&("013"[PRCHSC) ASK I $O(^PRC(440,PRCHV,PRCHBO,0)) S PRCHB(0)="^442.16PA^"_$P(^(0),U,3,4) F I=0:0 S I=$O(^PRC(440,PRCHV,PRCHBO,I)) Q:'I S PRCHB(I)=I
24 I PRCHDT,'$D(PRCHB) D ER3^PRCHNPO6 G EN10
25 ;
26ASK W !!,$C(7),"ARE YOU SURE YOU WANT TO RE-ENTER THE FPDS CODES " D YN^DICN Q:($D(PRCHFLG)>0)&(%=-1) G:($D(PRCHFLG)=0)&(%=-1) EN10
27 D:%=0 W G:%=0 ASK Q:($D(PRCHFLG)>0)&(%'=1) G:($D(PRCHFLG)=0)&(%'=1) EN10
28 I 'PRCHDT!("013"'[PRCHSC) D EN6^PRCHNPO2 G EN10:'$D(PRCHPO)
29 K PRCH S PRCHEC=0 F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I I $D(^(I,0)) S X=^(0),Y=$G(^(2)) D TBL
30 ;
31 ;Clear node 25 of any FPDS data, PRC*5.1*79
32 K ^PRC(442,PRCHPO,9),^PRC(442,PRCHPO,25) S ^(9,0)="^442.1A^^",$P(^PRC(442,PRCHPO,0),U,15)=0
33 W $C(7),!!,"PREVIOUS FPDS CODES HAVE BEEN DELETED!",!!
34 S PRCHY=0 I PRCHEST>0,PRCHEC>0 S PRCHY=PRCHEST/PRCHEC,Y=$P(PRCHY,".",2) I $L(Y)>2 S PRCHY=$P(PRCHY,".",1)+$J("."_Y,2,2)
35 S DIE="^PRC(442,",DR="[PRCHAMT89]",DA=PRCHPO
36 I PRCHDT D FPDS^PRCHFPD2 Q:$D(PRCHFLG)>0&(%=-1) G:'PRCHFPDS EN10
37 S PRCH="" F PRCHI=1:1 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH="" D TYPE^PRCHNPO1 S PRCHAMT=+PRCH("AM",PRCH),PRCHCN=$S(PRCH=".OM":"",1:PRCH) W ?40,"AMOUNT: ",PRCHAMT S PRCHAMT=""""_PRCHAMT_"""",DIE("NO^")="NO" D ^DIE
38 ;PRC*5.1*79 - call new input templates for FPDS data.
39 ;Check a regular PO from a Purchasing Agent.
40 ;PRC*5.1*100 - if the user times out and does not complete the input
41 ;template for the new FPDS, don't allow electronic sig. Check the last
42 ;field required for the PO, based on the source code.
43 ;
44 I ("25"[PRCHSC),$D(^PRC(442,PRCHPO,14)) D G:$G(PRCHER)=1 Q
45 . S DR="[PRCH NEW PO FPDS]" D ^DIE
46 . I '$D(^PRC(442,PRCHPO,25)) D STOP Q
47 . I $P(^PRC(442,PRCHPO,25),U,6)="" D STOP Q
48 . ;Fund agency code & fund agency office code can be empty in pairs only.
49 . I +$P(^PRC(442,PRCHPO,25),U,7)>0,$P(^PRC(442,PRCHPO,25),U,8)="" D STOP Q
50 ;End of changes for PRC*5.1*100.
51 ;
52 ;For FPDS purposes, consider any PO with any of the following source
53 ;codes as a delivery order:
54 ;PRC*5.1*100 - if the user times out, don't allow electronic sig.
55 I ("467B"[PRCHSC)&($D(^PRC(442,PRCHPO,14))) D G:$G(PRCHER)=1 Q
56 . S DR="[PRCH NEW PO FPDS]" D ^DIE
57 . I '$D(^PRC(442,PRCHPO,25)) D STOP Q
58 . I $P(^PRC(442,PRCHPO,25),U,15)="" D STOP Q
59 . E D POP^PRCHNPO1
60 ;
61 ;Quit if type code, pref, program, etc., are not defined.
62 I '$D(^PRC(442,PRCHPO,9)) D STOP G Q
63 D EN^DDIOL("Ok, let me save your changes.....done!","","!!?3") D ^PRCHSF
64 ;End of changes for PRC*5.1*100.
65 ;
66 ;Send HL7 message to the AAC
67 I $P($G(^PRC(442,PRCHPO,25)),U,17)="YES",$P(^PRC(442,PRCHPO,0),U,15)>0 D EN^DDIOL("...now generating the FPDS message for the AAC","","!") D AAC^PRCHAAC
68 ;End changes for PRC*5.1*79
69 K DIE F I=0:0 Q:'$D(PRCHPO) S I=$O(^PRC(442,PRCHPO,9,I)) Q:'I D ER2^PRCHNPO6:$P(^(I,0),U,2)="",ER3^PRCHNPO6:'$O(^(1,0))
70 L I $D(PRCHFLG) K PRCHFLG Q
71 G EN10
72 ;
73OUT ;Tell the user that the PO is not eligible for FPDS
74 D EN^DDIOL("This PO is not required for FPDS.","","!!?10")
75 Q
76 ;
77STOP ;PRC*5.1*100 - quit if all the FPDS info was not entered.
78 D EN^DDIOL("WARNING: YOU HAVE NOT ENTERED ALL THE FPDS DATA - NO MESSAGE GENERATED.","","!!?5") S PRCHER=1
79 Q
80 ;End of changes for PRC*5.1*100.
81 ;
82TBL ;TABLE LINE/ITEM AMOUNTS MINUS DISCOUNTS BY CONTRACT NO.
83 S PRCHCN=$S($P(Y,U,2)'="":$P(Y,U,2),1:".OM") S:'$D(PRCH("AM",PRCHCN)) PRCH("AM",PRCHCN)="",PRCHEC=PRCHEC+1
84 S PRCH("AM",PRCHCN)=($P(PRCH("AM",PRCHCN),U,1)+1)_"^"_($P(PRCH("AM",PRCHCN),U,2)+Y-$P(Y,U,6))_"^"_($P(PRCH("AM",PRCHCN),U,3))_+X_"," Q:$L(PRCH("AM",PRCHCN))<240
85 ;
86CNDNS N X,Y,I,J,C S C=",",X=$P(PRCH("AM",PRCHCN),U,3)
87 F I=1:1:999 Q:$P(X,C,I)="" I $P(X,C,I)?.N,$P(X,C,I+1)=($P(X,C,I)+1) F J=I+1:1:999 I ($P(X,C,J+1)'?1N.N)!(($P(X,C,J)+1)'=$P(X,C,J+1)) S Y=C_$P(X,C,I+1,J-1)_C,$P(PRCH("AM",PRCHCN),U,3)=$P(X,Y,1)_":1:"_$P(X,Y,2),I=999,J=999
88 Q
89 ;
90LOOK ;K PRCHPO,PRCHNEW,DA,DIC,D0,DQ S DIC("S")="I +^(0)=PRC(""SITE"") S PRCHX=$S($D(^(7)):+^(7),1:0) I $D(^PRCD(442.3,PRCHX,0)),$P(^(0),U,2)>9"
91 K PRCHPO,PRCHNEW,DA,DIC,D0,DQ S DIC("S")="I +^(0)=PRC(""SITE"") S PRCHX=+$G(^(7)) I $D(^PRCD(442.3,PRCHX,0)),$P(^(0),U,2)>9"
92 S DIC="^PRC(442,",DIC(0)="QEAMZ",D="C",DIC("A")="PURCHASE ORDER: " S:'$D(DIC("S")) DIC("S")="I +$P(^(0),U,1)=PRC(""SITE"")"
93 W !! D IX^DIC K DIC S X="" Q:+Y<0 S (PRCHPO,DA)=+Y
94 Q
95 ;
96ER W !,$S('PRCHDT:" Breakout Code is undefined.",1:" Socioeconomic Group (FY89) not defined in Vendor file."),$C(7) K PRCHPO
97 Q
98 ;
99W W !!,?10," Enter either Yes/No or enter ""^"" to exit."
100 W !!,"This option will delete all FPDS codes that were previously entered",!,"for this Purchase Order, then allow you to re-enter them."
101 Q
102 ;
103 ;
104Q L K PRC,PRCHI,PRCHFLG G Q^PRCHNPO4
Note: See TracBrowser for help on using the repository browser.