| [613] | 1 | PRCSCK ;SF-ISC/KSS/TKW/SC-CP INPUT TEMPLATE CHECK RTN ; 3/31/05 3:12pm
|
|---|
| 2 | V ;;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
|
|---|
| 13 | EX K PRCSI,PRCSF,PRCSQT,PRCSDA,PRCSDA1,PRCSDA2,PRCS Q
|
|---|
| 14 | 1 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
|
|---|
| 16 | 2 ;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
|
|---|
| 26 | 3 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
|
|---|
| 28 | 4 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
|
|---|
| 31 | 5 I $D(PRCSVAR),$P(PRCSVAR,U,2)="" S PRCSERR=2
|
|---|
| 32 | Q
|
|---|
| 33 | 6 I $D(PRCSVAR),$P(PRCSVAR,U,11)="",$D(^PRC(411,PRC("SITE"),0)),$P(^(0),U,18)="Y" S PRCSERR=10
|
|---|
| 34 | Q
|
|---|
| 35 | 7 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
|
|---|
| 39 | 8 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
|
|---|
| 41 | 9 D 3 Q:PRCSERR D 4 Q:PRCSERR D:PRCSDR["B" 6
|
|---|
| 42 | Q
|
|---|
| 43 | RB 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
|
|---|
| 45 | RB1 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
|
|---|
| 50 | RB3 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
|
|---|
| 51 | RB4 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
|
|---|
| 52 | EX1 K PRCSQT,PRCSDA,PRCSDA1,PRCSDA2 Q
|
|---|
| 53 | EXIT K PRCSII,PRCSJJ,PRCS,PRCST Q
|
|---|
| 54 | QRB 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
|
|---|
| 63 | QRB1 S PRCSDA=DA,PRCSDA1=DA(1),PRCSDA2=DA(2) Q
|
|---|
| 64 | QRB2 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
|
|---|
| 68 | ISSUPFCP(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 | ;
|
|---|
| 71 | SUPPLYCC() ;RETURN DEFAULT CC FOR SUPPLY FUND FCPS
|
|---|
| 72 | Q "615300 Inventory and Di"
|
|---|
| 73 | ;
|
|---|
| 74 | SUPPLBOC() ;RETURN DEFAULT BOC FOR SUPPLY FUND FCPS
|
|---|
| 75 | Q 2696
|
|---|
| 76 | ;
|
|---|
| 77 | SETY ;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 | ;
|
|---|
| 82 | CHGCCBOC(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 | ;
|
|---|
| 133 | OKCCBOC(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
|
|---|
| 175 | GETTXNCP(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)
|
|---|
