source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSCK.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1PRCSCK ;SF-ISC/KSS/TKW/SC-CP INPUT TEMPLATE CHECK RTN ; 3/31/05 3:12pm
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;PRC*5.1*81-SC-Adding a display of DM date needed by data, only if
6 ;the trx. originated from DynaMed.
7 ;
8 ;PRCSF-(FLAG) SET IF ENTERING AT TOP OF ROUTINE
9 ;
10 S (PRCSF,PRCSERR)=0 F PRCSI=0:0 S PRCSI=$O(^PRCS(410,DA,"IT",PRCSI)) Q:'PRCSI D 2 Q:PRCSERR S PRCSERR=0 D 1 Q:PRCSERR D ^PRCSCK1
11 I $D(PRCSERR),PRCSERR G EX
12 D SCP0^PRCSCK1
13EX K PRCSI,PRCSF,PRCSQT,PRCSDA,PRCSDA1,PRCSDA2,PRCS Q
141 I $D(PRCSF) S PRCSDA2=DA,PRCSDA1=PRCSI,PRCSQT=$S($D(^PRCS(410,PRCSDA2,"IT",PRCSDA1,0)):$P(^(0),U,2),1:"") I PRCSQT D QRB2
15 Q
162 ;ENTRY POINT WITHIN SUB-FIELD - (DA & DA(1)) DEFINED, OR
17 ;SUBROUTINE OF ABOVE (PRCSI AND DA) DEFINED.PRCSF (FLAG) SET
18 Q:'$D(DA) I '$D(PRCSF) Q:'$D(DA(1))
19 N SPEC,PRCSIDA,PRCSBOC S SPEC=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",12)
20 S PRCSERR=0,PRCSJ=DA S:'$D(PRCSF) PRCSI=DA,PRCSJ=DA(1)
21 S:$D(^PRCS(410,PRCSJ,"IT",PRCSI,0)) PRCSVAR=^(0)
22 D @$S(PRCSDR["2237":9,PRCSDR["IB":8,PRCSDR["NPR":8,1:7)
23 I PRCSERR S PRCSL=$S(PRCSERR=2:"QUANTITY",PRCSERR=3:"UNIT OF PURCHASE",PRCSERR=4:"BOC",PRCSERR=5:"ITEM MASTER FILE NO.",PRCSERR=10:"INTERMEDIATE PRODUCT CODE",1:"ESTIMATED ITEM UNIT COST")
24 I PRCSERR W !,?3,$C(7),"ITEM # "_$P(^PRCS(410,PRCSJ,"IT",PRCSI,0),U,1)_" "_PRCSL_" MISSING!" S Y="@1"
25 K PRCSJ,PRCSL,PRCSVAR K:'$D(PRCSF) PRCSI Q
263 I $D(PRCSVAR) S PRCSERR=$S($P(PRCSVAR,U,2)="":2,$P(PRCSVAR,U,3)="":3,$P(PRCSVAR,U,7)="":7,1:0)
27 Q
284 I $D(PRCSVAR),$P(PRCSVAR,U,4)="",($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)))&($P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)'>1)!'$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S PRCSERR=4
29 S PRCSIDA=+$P(^PRCS(410,PRCSJ,"IT",PRCSI,0),"^",5)
30 Q
315 I $D(PRCSVAR),$P(PRCSVAR,U,2)="" S PRCSERR=2
32 Q
336 I $D(PRCSVAR),$P(PRCSVAR,U,11)="",$D(^PRC(411,PRC("SITE"),0)),$P(^(0),U,18)="Y" S PRCSERR=10
34 Q
357 I $D(^PRCS(410,PRCSJ,3)),$P(^(3),U,4),$D(^(2)),$P(^(2),U,1)'="",$D(PRCSVAR)&($P(PRCSVAR,U,5)'="") D 5 Q:PRCSERR D 4
36 E D 3 Q:PRCSERR D 4
37 Q:PRCSERR D:PRCSDR["NR]" 6
38 Q
398 I $D(^PRCS(410,PRCSJ,3)),$P(^(3),U,4),$D(^(2)),$P(^(2),U,1)'="",$D(PRCSVAR) S PRCSERR=$S($P(PRCSVAR,U,5)="":5,$P(PRCSVAR,U,2)="":2,1:0) Q:PRCSERR D 4 Q:PRCSERR I PRCSDR["IB]"!(PRCSDR["NPR]") D 6
40 Q
419 D 3 Q:PRCSERR D 4 Q:PRCSERR D:PRCSDR["B" 6
42 Q
43RB S PRCST=$S($D(^PRCS(410,DA,4)):$P(^(4),U,8),1:"")
44 W !,?50,"TRANSACTION BEG BAL: ",$S(PRCST:$J(PRCST,0,2),1:"0.00") G EXIT
45RB1 S (PRCS,PRCS(1))=0 F PRCSII=0:0 S PRCS=$O(^PRCS(410,DA(1),12,PRCS)) Q:PRCS'>0 S PRCS(1)=PRCS(1)+$P(^(PRCS,0),U,2)
46 D RB3
47 I PRCS(2)>PRCST(1) S PRCS(3)=PRCS(2)-PRCST(1) W $C(7),!,"This is $ ",$J(PRCS(3),0,2)," more than the total available.",!,"Please re-edit your entries!" S Y=".01"
48 E D RB4
49 G EXIT
50RB3 S (PRCST(1),PRCS(2))=0,PRCST=$S($D(^PRCS(410,DA(1),4)):$P(^(4),U,8),1:""),PRCS(2)=PRCS(1),PRCST(1)=PRCST S:PRCS(1)["-"&(PRCST(1)["-") PRCS(2)=-PRCS(1),PRCST(1)=-PRCST Q
51RB4 W ?29,"RUNNING TOTAL: ",$S(PRCS(2):$J(PRCS(2),0,2),1:"0.00"),?64,"BAL: ",$S(PRCST(1)-PRCS(2):$J(PRCST(1)-PRCS(2),0,2),1:"0.00") Q
52EX1 K PRCSQT,PRCSDA,PRCSDA1,PRCSDA2 Q
53EXIT K PRCSII,PRCSJJ,PRCS,PRCST Q
54QRB S PRCSQT=$S($D(^PRCS(410,DA(1),"IT",DA,0)):$P(^(0),U,2),1:""),PRCSCST=$S($D(^PRCS(410,DA(1),"IT",DA,0)):$P(^(0),U,7),1:"")
55 W !?50,"QTY BEG BAL: ",PRCSQT
56 ;********************************************************************
57 ;if DM system param. is set & Item Mult node 4 exists then display
58 ;Date Needed By for DM trxs only - Patch PRC*5.1*81
59 ;********************************************************************
60 N PRCVDT,PRCVDN
61 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1,$D(^PRCS(410,DA(1),"IT",DA,4)) S PRCVDT=$P($G(^(4)),"^",2) S PRCVDN=$$FMTE^XLFDT(PRCVDT,1) W !?37,"DynaMed's DATE NEEDED BY: "_PRCVDN
62 G EXIT
63QRB1 S PRCSDA=DA,PRCSDA1=DA(1),PRCSDA2=DA(2) Q
64QRB2 Q:'$D(PRCSQT) Q:'PRCSQT S PRCS=0,PRCS(1)=PRCSQT F PRCSJJ=1:1 S PRCS=$O(^PRCS(410,PRCSDA2,"IT",PRCSDA1,2,PRCS)) Q:PRCS'>0 S PRCS(2)=$S($D(^PRCS(410.6,+$P(^(PRCS,0),U,2),0)):$P(^(0),U,4),1:""),PRCS(1)=PRCS(1)-PRCS(2)
65 I '$D(PRCSF) W ?55,"QTY RUN BAL: ",PRCS(1)
66 S:PRCS(1)=0 PRCSERR="" I PRCS(1)<0 W !,$C(7),?15,"Total delivery schedule quantity exceeds item quantity by "_-(PRCS(1))_"." S PRCSERR=12 I '$D(PRCSF) S Y=3
67 Q
68ISSUPFCP(STA,FCP) ;RETURN 1 IF THIS IS A SUPPLY FUND FCP, 0 IF IT ISN'T
69 Q ($P($G(^PRC(420,+STA,1,+FCP,0)),"^",12)=2)
70 ;
71SUPPLYCC() ;RETURN DEFAULT CC FOR SUPPLY FUND FCPS
72 Q "615300 Inventory and Di"
73 ;
74SUPPLBOC() ;RETURN DEFAULT BOC FOR SUPPLY FUND FCPS
75 Q 2696
76 ;
77SETY ;SETS BRANCHING LOGIC FOR INPUT TEMPLATE 'PRCPIB' AND 'PRCSENIB' (INPUT TEMPLATES FOR ISSUE BOOK REQUESTS)
78 Q:'$D(PRCSERR)
79 S Y=$S(PRCSERR=2:2,PRCSERR=4:4,PRCSERR=5:5,1:".01")
80 Q
81 ;
82CHGCCBOC(CXLTXN,RPLTXN,OFCP,MUSTCHG) ;
83 ;cxltxn = transaction # of cancelled transaction
84 ;rpltxn = transaction# of replacement transaction
85 ;ofcp =old fund control point if this was a temp transaction
86 ;mustchg=user must change (currently not ever called with this set)
87 ;returns 0 if no change required, 1 if change made,-1 if user must edit
88 ;First get FCPs. If unchanged, quit
89 N CXLCC,CXLFCP,CXLDA,CXLSTA,RPLCC,RPLFCP,RPLDA,RPLSTA,CCCNT,DONE,RV
90 N RPLBOC,I,J,DA,DR,DIE,RPLFTYPE
91 S CXLFCP=$$GETTXNCP(CXLTXN,.CXLDA,.CXLSTA)
92 S RPLFCP=$$GETTXNCP(RPLTXN,.RPLDA,.RPLSTA)
93 I (+CXLFCP'=+OFCP) S CXLFCP=OFCP
94 I +CXLFCP=+RPLFCP Q 0
95 S RPLFTYPE=$P($G(^PRCS(410,RPLDA,0)),U,4)
96 ;Set CC. Stuff if there's only one good one. Otherwise ask.
97 S CCCNT=$$GETCCCNT^PRCSECP(RPLSTA,RPLFCP)
98 I (+CCCNT=1) S RPLCC=$P(CCCNT,U,2),$P(^PRCS(410,RPLDA,3),U,3)=RPLCC W !!,"Cost Center updated to ",RPLCC,!
99 E D
100 . S DA=RPLDA,DIE=410,DR="15.5R~Enter a Valid Cost Center"
101 . S DIC("S")="S PRCSCC=$P(^(3),U,3) I $$VALIDCC^PRCSECP(RPLSTA,RPLFCP,+PRCSCC)"
102 . D ^DIE
103 . S RPLCC=$P(^PRCS(410,RPLDA,3),U,3)
104 ;
105 ;OK--time to deal with the BOCs now. Is there only one good one?
106 S RV=1,NEWBOC=$$GETBOCNT^PRCSECP(RPLSTA,RPLFCP,+RPLCC)
107 I +NEWBOC=1 S RPLBOC=$P(NEWBOC,U,2),DONE=1,RV=0 D
108 . W !!,"BOC updated to ",RPLBOC," for the new document.",!!
109 . I RPLFTYPE>1 D
110 .. S I=0 F S I=$O(^PRCS(410,RPLDA,"IT",I)) Q:I="" D
111 ... S $P(^PRCS(410,RPLDA,"IT",I,0),U,4)=RPLBOC
112 . I RPLFTYPE=1 S $P(^PRCS(410,RPLDA,3),U,6)=RPLBOC
113 I '$G(DONE) D
114 . I RPLFTYPE>1 D
115 .. S I=0 F S I=$O(^PRCS(410,RPLDA,"IT",I)) Q:'(I?1N.N) D
116 ... S RPLBOC=$P(^PRCS(410,RPLDA,"IT",I,0),U,4)
117 ... I RPLBOC]"" S RPLBOC(RPLBOC)=$G(RPLBOC(RPLBOC))_I_";"
118 .. S I=""
119 .. W !!," This document refers to the following BOC(s):",!
120 .. I $O(RPLBOC(""))="" W " [NONE]",!!
121 .. F S I=$O(RPLBOC(I)) Q:I="" D
122 ... W " BOC: ",I,":"
123 ... I '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,I) W " ** INVALID **" S RV=-1
124 ... W !," BOC ",+I," ITEM(S): ",$E(RPLBOC(I),1,$L(RPLBOC(I))-1)
125 ... W !!
126 . I RPLFTYPE=1 D
127 .. S RPLBOC=$P($G(^PRCS(410,RPLDA,3)),U,6)
128 .. W !!,"This document uses BOC ",RPLBOC
129 .. I '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,RPLBOC) W " ** INVALID **" S RV=-1
130 . I RV<0,MUSTCHG W !,"You must edit this document to correct the BOC entries now.",!
131 Q RV
132 ;
133OKCCBOC(TRANSXN) ;TRANSXN = transaction# of transaction to check
134 ;returns 1 if no change required, 0 if user must edit
135 ;First get FCP, Form type, Station, IEN and CC
136 N A,CC,FCP,DA,STA,CCCNT,DONE,RV,GOODCC
137 N BOC,BOCC,I,J,DR,DIE,FTYPE
138 S FCP=$$GETTXNCP(TRANSXN,.DA,.STA)
139 I 'DA!'STA Q 0
140 S FTYPE=$P($G(^PRCS(410,DA,0)),U,4)
141 S CC=+$P($G(^PRCS(410,DA,3)),U,3) I 'CC Q 0
142 S GOODCC=$$VALIDCC^PRCSECP(STA,FCP,CC)
143 I 'GOODCC D Q 0
144 . S A(1,"F")="!!?10",A(1)="An invalid Cost Center ("_+CC_") was entered."
145 . S A(2,"F")="!?10",A(2)="You must re-edit this document before it can be approved."
146 . S A(3)=$C(7)
147 . D EN^DDIOL(.A)
148 ;
149 ;OK--time to deal with the BOCs now. For 1358s, check the single BOC
150 ;
151 S BOCC=$$GETBOCNT^PRCSECP(STA,FCP,CC)
152 S RV=1
153 I FTYPE=1 D Q RV
154 . S BOC=$P($G(^PRCS(410,DA,3)),U,6)
155 . I '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC) D Q
156 .. S A(1,"F")="!!?10",A(1)="An invalid BOC ("_+BOC_") was entered."
157 .. I (+BOCC=1) S $P(PRCS(410,DA,3),U,6)=$P(BOCC,U,2),A(2)="It has been changed to "_+$P(BOCC,U,2)
158 .. I (+BOCC'=1) S A(2)="You must re-edit this document before it can be approved."
159 .. S A(2,"F")="!?10"
160 .. S A(3)=$C(7)
161 .. D EN^DDIOL(.A)
162 .. S RV=0
163 ;
164 ;For the other form types, check all BOCs
165 ;
166 S (I,J)=0
167 F S I=$O(^PRCS(410,DA,"IT",I)) Q:'(I?1N.N) D
168 . S BOC=$P(^PRCS(410,DA,"IT",I,0),U,4)
169 . I '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC) D
170 .. S J=J+1,A(J)="An invalid BOC ("_+BOC_") was entered for item "_I_"."
171 .. S A(J,"F")="!?10" I J=1 S A(J,"F")="!"_A(J,"F")
172 .. I (+BOCC=1) S $P(^PRCS(410,DA,"IT",I,0),U,4)=$P(BOCC,U,2)
173 I J S RV=0,J=J+1,A(J,"F")="!?10",A(J)=$S((+BOCC'=1):"You must re-edit this document before it can be approved.",1:"BOC(s) replaced with "_+$P(BOCC,U,2)),A(J+1)=$C(7) D EN^DDIOL(.A)
174 Q RV
175GETTXNCP(TRANSID,OUTIEN,OUTSTA) ;GET IEN AND CONTROL POINT # FOR TRANSACTION
176 S OUTIEN=+$O(^PRCS(410,"B",TRANSID,""))
177 S OUTSTA=$P($G(^PRCS(410,OUTIEN,0)),U,5)
178 Q $P($G(^PRCS(410,OUTIEN,3)),U,1)
Note: See TracBrowser for help on using the repository browser.