PRCSCK ;SF-ISC/KSS/TKW/SC-CP INPUT TEMPLATE CHECK RTN ;7/9/13 16:00
V ;;5.1;IFCAP;**81,174**;Oct 20, 2000;Build 23
;Per VHA Directive 10-93-142, this routine should not be modified.
;
;PRC*5.1*81-SC-Adding a display of DM date needed by data, only if
;the trx. originated from DynaMed.
;
;PRCSF-(FLAG) SET IF ENTERING AT TOP OF ROUTINE
;
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
I $D(PRCSERR),PRCSERR G EX
D SCP0^PRCSCK1
EX K PRCSI,PRCSF,PRCSQT,PRCSDA,PRCSDA1,PRCSDA2,PRCS Q
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
Q
2 ;ENTRY POINT WITHIN SUB-FIELD - (DA & DA(1)) DEFINED, OR
;SUBROUTINE OF ABOVE (PRCSI AND DA) DEFINED.PRCSF (FLAG) SET
Q:'$D(DA) I '$D(PRCSF) Q:'$D(DA(1))
N SPEC,PRCSIDA,PRCSBOC S SPEC=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",12)
S PRCSERR=0,PRCSJ=DA S:'$D(PRCSF) PRCSI=DA,PRCSJ=DA(1)
S:$D(^PRCS(410,PRCSJ,"IT",PRCSI,0)) PRCSVAR=^(0)
;if a NON-REPETITIVE (2237) ORDER or REPETITIVE AND NON-REP ORDER check for missing line item description (PRC*5.1*174)
I (PRCSDR="[PRCSEN2237B]")!(PRCSDR="[PRCSENR&NR]") D
. I $D(PRCSVAR)&('$$ITDES^PRCHJUTL($G(PRCSJ),$G(PRCSI))) S PRCSERR=11
I 'PRCSERR D @$S(PRCSDR["2237":9,PRCSDR["IB":8,PRCSDR["NPR":8,1:7)
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",PRCSERR=11:"DESCRIPTION",1:"ESTIMATED ITEM UNIT COST")
I PRCSERR W !,?3,$C(7),"ITEM # "_$P(^PRCS(410,PRCSJ,"IT",PRCSI,0),U,1)_" "_PRCSL_" MISSING!" S Y="@1"
K PRCSJ,PRCSL,PRCSVAR K:'$D(PRCSF) PRCSI Q
3 I $D(PRCSVAR) S PRCSERR=$S($P(PRCSVAR,U,2)="":2,$P(PRCSVAR,U,3)="":3,$P(PRCSVAR,U,7)="":7,1:0)
Q
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
S PRCSIDA=+$P(^PRCS(410,PRCSJ,"IT",PRCSI,0),"^",5)
Q
5 I $D(PRCSVAR),$P(PRCSVAR,U,2)="" S PRCSERR=2
Q
6 I $D(PRCSVAR),$P(PRCSVAR,U,11)="",$D(^PRC(411,PRC("SITE"),0)),$P(^(0),U,18)="Y" S PRCSERR=10
Q
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
E D 3 Q:PRCSERR D 4
Q:PRCSERR D:PRCSDR["NR]" 6
Q
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
Q
9 D 3 Q:PRCSERR D 4 Q:PRCSERR D:PRCSDR["B" 6
Q
RB S PRCST=$S($D(^PRCS(410,DA,4)):$P(^(4),U,8),1:"")
W !,?50,"TRANSACTION BEG BAL: ",$S(PRCST:$J(PRCST,0,2),1:"0.00") G EXIT
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)
D RB3
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"
E D RB4
G EXIT
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
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
EX1 K PRCSQT,PRCSDA,PRCSDA1,PRCSDA2 Q
EXIT K PRCSII,PRCSJJ,PRCS,PRCST Q
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:"")
W !?50,"QTY BEG BAL: ",PRCSQT
;********************************************************************
;if DM system param. is set & Item Mult node 4 exists then display
;Date Needed By for DM trxs only - Patch PRC*5.1*81
;********************************************************************
N PRCVDT,PRCVDN
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
G EXIT
QRB1 S PRCSDA=DA,PRCSDA1=DA(1),PRCSDA2=DA(2) Q
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)
I '$D(PRCSF) W ?55,"QTY RUN BAL: ",PRCS(1)
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
Q
ISSUPFCP(STA,FCP) ;RETURN 1 IF THIS IS A SUPPLY FUND FCP, 0 IF IT ISN'T
Q ($P($G(^PRC(420,+STA,1,+FCP,0)),"^",12)=2)
;
SUPPLYCC() ;RETURN DEFAULT CC FOR SUPPLY FUND FCPS
Q "615300 Inventory and Di"
;
SUPPLBOC() ;RETURN DEFAULT BOC FOR SUPPLY FUND FCPS
Q 2696
;
SETY ;SETS BRANCHING LOGIC FOR INPUT TEMPLATE 'PRCPIB' AND 'PRCSENIB' (INPUT TEMPLATES FOR ISSUE BOOK REQUESTS)
Q:'$D(PRCSERR)
S Y=$S(PRCSERR=2:2,PRCSERR=4:4,PRCSERR=5:5,1:".01")
Q
;
CHGCCBOC(CXLTXN,RPLTXN,OFCP,MUSTCHG) ;
;cxltxn = transaction # of cancelled transaction
;rpltxn = transaction# of replacement transaction
;ofcp =old fund control point if this was a temp transaction
;mustchg=user must change (currently not ever called with this set)
;returns 0 if no change required, 1 if change made,-1 if user must edit
;First get FCPs. If unchanged, quit
N CXLCC,CXLFCP,CXLDA,CXLSTA,RPLCC,RPLFCP,RPLDA,RPLSTA,CCCNT,DONE,RV
N RPLBOC,I,J,DA,DR,DIE,RPLFTYPE
S CXLFCP=$$GETTXNCP(CXLTXN,.CXLDA,.CXLSTA)
S RPLFCP=$$GETTXNCP(RPLTXN,.RPLDA,.RPLSTA)
I (+CXLFCP'=+OFCP) S CXLFCP=OFCP
I +CXLFCP=+RPLFCP Q 0
S RPLFTYPE=$P($G(^PRCS(410,RPLDA,0)),U,4)
;Set CC. Stuff if there's only one good one. Otherwise ask.
S CCCNT=$$GETCCCNT^PRCSECP(RPLSTA,RPLFCP)
I (+CCCNT=1) S RPLCC=$P(CCCNT,U,2),$P(^PRCS(410,RPLDA,3),U,3)=RPLCC W !!,"Cost Center updated to ",RPLCC,!
E D
. S DA=RPLDA,DIE=410,DR="15.5R~Enter a Valid Cost Center"
. S DIC("S")="S PRCSCC=$P(^(3),U,3) I $$VALIDCC^PRCSECP(RPLSTA,RPLFCP,+PRCSCC)"
. D ^DIE
. S RPLCC=$P(^PRCS(410,RPLDA,3),U,3)
;
;OK--time to deal with the BOCs now. Is there only one good one?
S RV=1,NEWBOC=$$GETBOCNT^PRCSECP(RPLSTA,RPLFCP,+RPLCC)
I +NEWBOC=1 S RPLBOC=$P(NEWBOC,U,2),DONE=1,RV=0 D
. W !!,"BOC updated to ",RPLBOC," for the new document.",!!
. I RPLFTYPE>1 D
.. S I=0 F S I=$O(^PRCS(410,RPLDA,"IT",I)) Q:I="" D
... S $P(^PRCS(410,RPLDA,"IT",I,0),U,4)=RPLBOC
. I RPLFTYPE=1 S $P(^PRCS(410,RPLDA,3),U,6)=RPLBOC
I '$G(DONE) D
. I RPLFTYPE>1 D
.. S I=0 F S I=$O(^PRCS(410,RPLDA,"IT",I)) Q:'(I?1N.N) D
... S RPLBOC=$P(^PRCS(410,RPLDA,"IT",I,0),U,4)
... I RPLBOC]"" S RPLBOC(RPLBOC)=$G(RPLBOC(RPLBOC))_I_";"
.. S I=""
.. W !!," This document refers to the following BOC(s):",!
.. I $O(RPLBOC(""))="" W " [NONE]",!!
.. F S I=$O(RPLBOC(I)) Q:I="" D
... W " BOC: ",I,":"
... I '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,I) W " ** INVALID **" S RV=-1
... W !," BOC ",+I," ITEM(S): ",$E(RPLBOC(I),1,$L(RPLBOC(I))-1)
... W !!
. I RPLFTYPE=1 D
.. S RPLBOC=$P($G(^PRCS(410,RPLDA,3)),U,6)
.. W !!,"This document uses BOC ",RPLBOC
.. I '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,RPLBOC) W " ** INVALID **" S RV=-1
. I RV<0,MUSTCHG W !,"You must edit this document to correct the BOC entries now.",!
Q RV
;
OKCCBOC(TRANSXN) ;TRANSXN = transaction# of transaction to check
;returns 1 if no change required, 0 if user must edit
;First get FCP, Form type, Station, IEN and CC
N A,CC,FCP,DA,STA,CCCNT,DONE,RV,GOODCC
N BOC,BOCC,I,J,DR,DIE,FTYPE
S FCP=$$GETTXNCP(TRANSXN,.DA,.STA)
I 'DA!'STA Q 0
S FTYPE=$P($G(^PRCS(410,DA,0)),U,4)
S CC=+$P($G(^PRCS(410,DA,3)),U,3) I 'CC Q 0
S GOODCC=$$VALIDCC^PRCSECP(STA,FCP,CC)
I 'GOODCC D Q 0
. S A(1,"F")="!!?10",A(1)="An invalid Cost Center ("_+CC_") was entered."
. S A(2,"F")="!?10",A(2)="You must re-edit this document before it can be approved."
. S A(3)=$C(7)
. D EN^DDIOL(.A)
;
;OK--time to deal with the BOCs now. For 1358s, check the single BOC
;
S BOCC=$$GETBOCNT^PRCSECP(STA,FCP,CC)
S RV=1
I FTYPE=1 D Q RV
. S BOC=$P($G(^PRCS(410,DA,3)),U,6)
. I '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC) D Q
.. S A(1,"F")="!!?10",A(1)="An invalid BOC ("_+BOC_") was entered."
.. 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)
.. I (+BOCC'=1) S A(2)="You must re-edit this document before it can be approved."
.. S A(2,"F")="!?10"
.. S A(3)=$C(7)
.. D EN^DDIOL(.A)
.. S RV=0
;
;For the other form types, check all BOCs
;
S (I,J)=0
F S I=$O(^PRCS(410,DA,"IT",I)) Q:'(I?1N.N) D
. S BOC=$P(^PRCS(410,DA,"IT",I,0),U,4)
. I '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC) D
.. S J=J+1,A(J)="An invalid BOC ("_+BOC_") was entered for item "_I_"."
.. S A(J,"F")="!?10" I J=1 S A(J,"F")="!"_A(J,"F")
.. I (+BOCC=1) S $P(^PRCS(410,DA,"IT",I,0),U,4)=$P(BOCC,U,2)
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)
Q RV
GETTXNCP(TRANSID,OUTIEN,OUTSTA) ;GET IEN AND CONTROL POINT # FOR TRANSACTION
S OUTIEN=+$O(^PRCS(410,"B",TRANSID,""))
S OUTSTA=$P($G(^PRCS(410,OUTIEN,0)),U,5)
Q $P($G(^PRCS(410,OUTIEN,3)),U,1)
;
;
CHKITDES(PRCDA) ;2237 input template - check all line items for a description
;This procedure checks all line items on a 2237 to make sure they have a
;description. Sets branching logic for input template if any line item
;descriptions are not populated.
;
; Called from input templates:
; - PRCSEN2237B
; - PRCSENR&NR
;
; Input:
; PRCDA - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
;
; Output: None (sets branching logic for input template)
;
S PRCDA=+$G(PRCDA)
Q:'$G(PRCDA)
N PRCHJFT S PRCHJFT=$P(^PRCS(410,PRCDA,0),"^",4) ;Form Type
;quit if not a 2237 transaction (Form Type IEN 2,3,or 4)
Q:$G(PRCHJFT)<2!($G(PRCHJFT)>4)
;check if 2237 has any line items missing a description
N PRCWARN
I '$$ITDESALL^PRCHJUTL(PRCDA,.PRCWARN) D
. N PRCIDX S PRCIDX=0
. F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D
. . W !?3,$$UP^XLFSTR($G(PRCWARN(PRCIDX)))
;
;if any line items missing a description set input template branch
I $D(PRCWARN) S Y="@1"
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSCK 10456 printed Oct 16, 2024@18:18:01 Page 2
PRCSCK ;SF-ISC/KSS/TKW/SC-CP INPUT TEMPLATE CHECK RTN ;7/9/13 16:00
V ;;5.1;IFCAP;**81,174**;Oct 20, 2000;Build 23
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*81-SC-Adding a display of DM date needed by data, only if
+4 ;the trx. originated from DynaMed.
+5 ;
+6 ;PRCSF-(FLAG) SET IF ENTERING AT TOP OF ROUTINE
+7 ;
+8 SET (PRCSF,PRCSERR)=0
FOR PRCSI=0:0
SET PRCSI=$ORDER(^PRCS(410,DA,"IT",PRCSI))
if 'PRCSI
QUIT
DO 2
if PRCSERR
QUIT
SET PRCSERR=0
DO 1
if PRCSERR
QUIT
DO ^PRCSCK1
+9 IF $DATA(PRCSERR)
IF PRCSERR
GOTO EX
+10 DO SCP0^PRCSCK1
EX KILL PRCSI,PRCSF,PRCSQT,PRCSDA,PRCSDA1,PRCSDA2,PRCS
QUIT
1 IF $DATA(PRCSF)
SET PRCSDA2=DA
SET PRCSDA1=PRCSI
SET PRCSQT=$SELECT($DATA(^PRCS(410,PRCSDA2,"IT",PRCSDA1,0)):$PIECE(^(0),U,2),1:"")
IF PRCSQT
DO QRB2
+1 QUIT
2 ;ENTRY POINT WITHIN SUB-FIELD - (DA & DA(1)) DEFINED, OR
+1 ;SUBROUTINE OF ABOVE (PRCSI AND DA) DEFINED.PRCSF (FLAG) SET
+2 if '$DATA(DA)
QUIT
IF '$DATA(PRCSF)
if '$DATA(DA(1))
QUIT
+3 NEW SPEC,PRCSIDA,PRCSBOC
SET SPEC=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",12)
+4 SET PRCSERR=0
SET PRCSJ=DA
if '$DATA(PRCSF)
SET PRCSI=DA
SET PRCSJ=DA(1)
+5 if $DATA(^PRCS(410,PRCSJ,"IT",PRCSI,0))
SET PRCSVAR=^(0)
+6 ;if a NON-REPETITIVE (2237) ORDER or REPETITIVE AND NON-REP ORDER check for missing line item description (PRC*5.1*174)
+7 IF (PRCSDR="[PRCSEN2237B]")!(PRCSDR="[PRCSENR&NR]")
Begin DoDot:1
+8 IF $DATA(PRCSVAR)&('$$ITDES^PRCHJUTL($GET(PRCSJ),$GET(PRCSI)))
SET PRCSERR=11
End DoDot:1
+9 IF 'PRCSERR
DO @$SELECT(PRCSDR["2237":9,PRCSDR["IB":8,PRCSDR["NPR":8,1:7)
+10 IF PRCSERR
SET PRCSL=$SELECT(PRCSERR=2:"QUANTITY",PRCSERR=3:"UNIT OF PURCHASE",PRCSERR=4:"BOC",PRCSERR=5:"ITEM MASTER FILE NO.",PRCSERR=10:"INTERMEDIATE PRODUCT CODE",PRCSERR=11:"DESCRIPTION",1:"ESTIMATED ITEM UNIT COST")
+11 IF PRCSERR
WRITE !,?3,$CHAR(7),"ITEM # "_$PIECE(^PRCS(410,PRCSJ,"IT",PRCSI,0),U,1)_" "_PRCSL_" MISSING!"
SET Y="@1"
+12 KILL PRCSJ,PRCSL,PRCSVAR
if '$DATA(PRCSF)
KILL PRCSI
QUIT
3 IF $DATA(PRCSVAR)
SET PRCSERR=$SELECT($PIECE(PRCSVAR,U,2)="":2,$PIECE(PRCSVAR,U,3)="":3,$PIECE(PRCSVAR,U,7)="":7,1:0)
+1 QUIT
4 IF $DATA(PRCSVAR)
IF $PIECE(PRCSVAR,U,4)=""
IF ($DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)))&($PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)'>1)!'$DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
SET PRCSERR=4
+1 SET PRCSIDA=+$PIECE(^PRCS(410,PRCSJ,"IT",PRCSI,0),"^",5)
+2 QUIT
5 IF $DATA(PRCSVAR)
IF $PIECE(PRCSVAR,U,2)=""
SET PRCSERR=2
+1 QUIT
6 IF $DATA(PRCSVAR)
IF $PIECE(PRCSVAR,U,11)=""
IF $DATA(^PRC(411,PRC("SITE"),0))
IF $PIECE(^(0),U,18)="Y"
SET PRCSERR=10
+1 QUIT
7 IF $DATA(^PRCS(410,PRCSJ,3))
IF $PIECE(^(3),U,4)
IF $DATA(^(2))
IF $PIECE(^(2),U,1)'=""
IF $DATA(PRCSVAR)&($PIECE(PRCSVAR,U,5)'="")
DO 5
if PRCSERR
QUIT
DO 4
+1 IF '$TEST
DO 3
if PRCSERR
QUIT
DO 4
+2 if PRCSERR
QUIT
if PRCSDR["NR]"
DO 6
+3 QUIT
8 IF $DATA(^PRCS(410,PRCSJ,3))
IF $PIECE(^(3),U,4)
IF $DATA(^(2))
IF $PIECE(^(2),U,1)'=""
IF $DATA(PRCSVAR)
SET PRCSERR=$SELECT($PIECE(PRCSVAR,U,5)="":5,$PIECE(PRCSVAR,U,2)="":2,1:0)
if PRCSERR
QUIT
DO 4
if PRCSERR
QUIT
IF PRCSDR["IB]"!(PRCSDR["NPR]")
DO 6
+1 QUIT
9 DO 3
if PRCSERR
QUIT
DO 4
if PRCSERR
QUIT
if PRCSDR["B"
DO 6
+1 QUIT
RB SET PRCST=$SELECT($DATA(^PRCS(410,DA,4)):$PIECE(^(4),U,8),1:"")
+1 WRITE !,?50,"TRANSACTION BEG BAL: ",$SELECT(PRCST:$JUSTIFY(PRCST,0,2),1:"0.00")
GOTO EXIT
RB1 SET (PRCS,PRCS(1))=0
FOR PRCSII=0:0
SET PRCS=$ORDER(^PRCS(410,DA(1),12,PRCS))
if PRCS'>0
QUIT
SET PRCS(1)=PRCS(1)+$PIECE(^(PRCS,0),U,2)
+1 DO RB3
+2 IF PRCS(2)>PRCST(1)
SET PRCS(3)=PRCS(2)-PRCST(1)
WRITE $CHAR(7),!,"This is $ ",$JUSTIFY(PRCS(3),0,2)," more than the total available.",!,"Please re-edit your entries!"
SET Y=".01"
+3 IF '$TEST
DO RB4
+4 GOTO EXIT
RB3 SET (PRCST(1),PRCS(2))=0
SET PRCST=$SELECT($DATA(^PRCS(410,DA(1),4)):$PIECE(^(4),U,8),1:"")
SET PRCS(2)=PRCS(1)
SET PRCST(1)=PRCST
if PRCS(1)["-"&(PRCST(1)["-")
SET PRCS(2)=-PRCS(1)
SET PRCST(1)=-PRCST
QUIT
RB4 WRITE ?29,"RUNNING TOTAL: ",$SELECT(PRCS(2):$JUSTIFY(PRCS(2),0,2),1:"0.00"),?64,"BAL: ",$SELECT(PRCST(1)-PRCS(2):$JUSTIFY(PRCST(1)-PRCS(2),0,2),1:"0.00")
QUIT
EX1 KILL PRCSQT,PRCSDA,PRCSDA1,PRCSDA2
QUIT
EXIT KILL PRCSII,PRCSJJ,PRCS,PRCST
QUIT
QRB SET PRCSQT=$SELECT($DATA(^PRCS(410,DA(1),"IT",DA,0)):$PIECE(^(0),U,2),1:"")
SET PRCSCST=$SELECT($DATA(^PRCS(410,DA(1),"IT",DA,0)):$PIECE(^(0),U,7),1:"")
+1 WRITE !?50,"QTY BEG BAL: ",PRCSQT
+2 ;********************************************************************
+3 ;if DM system param. is set & Item Mult node 4 exists then display
+4 ;Date Needed By for DM trxs only - Patch PRC*5.1*81
+5 ;********************************************************************
+6 NEW PRCVDT,PRCVDN
+7 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
IF $DATA(^PRCS(410,DA(1),"IT",DA,4))
SET PRCVDT=$PIECE($GET(^(4)),"^",2)
SET PRCVDN=$$FMTE^XLFDT(PRCVDT,1)
WRITE !?37,"DynaMed's DATE NEEDED BY: "_PRCVDN
+8 GOTO EXIT
QRB1 SET PRCSDA=DA
SET PRCSDA1=DA(1)
SET PRCSDA2=DA(2)
QUIT
QRB2 if '$DATA(PRCSQT)
QUIT
if 'PRCSQT
QUIT
SET PRCS=0
SET PRCS(1)=PRCSQT
FOR PRCSJJ=1:1
SET PRCS=$ORDER(^PRCS(410,PRCSDA2,"IT",PRCSDA1,2,PRCS))
if PRCS'>0
QUIT
SET PRCS(2)=$SELECT($DATA(^PRCS(410.6,+$PIECE(^(PRCS,0),U,2),0)):$PIECE(^(0),U,4),1:"")
SET PRCS(1)=PRCS(1)-PRCS(2)
+1 IF '$DATA(PRCSF)
WRITE ?55,"QTY RUN BAL: ",PRCS(1)
+2 if PRCS(1)=0
SET PRCSERR=""
IF PRCS(1)<0
WRITE !,$CHAR(7),?15,"Total delivery schedule quantity exceeds item quantity by "_-(PRCS(1))_"."
SET PRCSERR=12
IF '$DATA(PRCSF)
SET Y=3
+3 QUIT
ISSUPFCP(STA,FCP) ;RETURN 1 IF THIS IS A SUPPLY FUND FCP, 0 IF IT ISN'T
+1 QUIT ($PIECE($GET(^PRC(420,+STA,1,+FCP,0)),"^",12)=2)
+2 ;
SUPPLYCC() ;RETURN DEFAULT CC FOR SUPPLY FUND FCPS
+1 QUIT "615300 Inventory and Di"
+2 ;
SUPPLBOC() ;RETURN DEFAULT BOC FOR SUPPLY FUND FCPS
+1 QUIT 2696
+2 ;
SETY ;SETS BRANCHING LOGIC FOR INPUT TEMPLATE 'PRCPIB' AND 'PRCSENIB' (INPUT TEMPLATES FOR ISSUE BOOK REQUESTS)
+1 if '$DATA(PRCSERR)
QUIT
+2 SET Y=$SELECT(PRCSERR=2:2,PRCSERR=4:4,PRCSERR=5:5,1:".01")
+3 QUIT
+4 ;
CHGCCBOC(CXLTXN,RPLTXN,OFCP,MUSTCHG) ;
+1 ;cxltxn = transaction # of cancelled transaction
+2 ;rpltxn = transaction# of replacement transaction
+3 ;ofcp =old fund control point if this was a temp transaction
+4 ;mustchg=user must change (currently not ever called with this set)
+5 ;returns 0 if no change required, 1 if change made,-1 if user must edit
+6 ;First get FCPs. If unchanged, quit
+7 NEW CXLCC,CXLFCP,CXLDA,CXLSTA,RPLCC,RPLFCP,RPLDA,RPLSTA,CCCNT,DONE,RV
+8 NEW RPLBOC,I,J,DA,DR,DIE,RPLFTYPE
+9 SET CXLFCP=$$GETTXNCP(CXLTXN,.CXLDA,.CXLSTA)
+10 SET RPLFCP=$$GETTXNCP(RPLTXN,.RPLDA,.RPLSTA)
+11 IF (+CXLFCP'=+OFCP)
SET CXLFCP=OFCP
+12 IF +CXLFCP=+RPLFCP
QUIT 0
+13 SET RPLFTYPE=$PIECE($GET(^PRCS(410,RPLDA,0)),U,4)
+14 ;Set CC. Stuff if there's only one good one. Otherwise ask.
+15 SET CCCNT=$$GETCCCNT^PRCSECP(RPLSTA,RPLFCP)
+16 IF (+CCCNT=1)
SET RPLCC=$PIECE(CCCNT,U,2)
SET $PIECE(^PRCS(410,RPLDA,3),U,3)=RPLCC
WRITE !!,"Cost Center updated to ",RPLCC,!
+17 IF '$TEST
Begin DoDot:1
+18 SET DA=RPLDA
SET DIE=410
SET DR="15.5R~Enter a Valid Cost Center"
+19 SET DIC("S")="S PRCSCC=$P(^(3),U,3) I $$VALIDCC^PRCSECP(RPLSTA,RPLFCP,+PRCSCC)"
+20 DO ^DIE
+21 SET RPLCC=$PIECE(^PRCS(410,RPLDA,3),U,3)
End DoDot:1
+22 ;
+23 ;OK--time to deal with the BOCs now. Is there only one good one?
+24 SET RV=1
SET NEWBOC=$$GETBOCNT^PRCSECP(RPLSTA,RPLFCP,+RPLCC)
+25 IF +NEWBOC=1
SET RPLBOC=$PIECE(NEWBOC,U,2)
SET DONE=1
SET RV=0
Begin DoDot:1
+26 WRITE !!,"BOC updated to ",RPLBOC," for the new document.",!!
+27 IF RPLFTYPE>1
Begin DoDot:2
+28 SET I=0
FOR
SET I=$ORDER(^PRCS(410,RPLDA,"IT",I))
if I=""
QUIT
Begin DoDot:3
+29 SET $PIECE(^PRCS(410,RPLDA,"IT",I,0),U,4)=RPLBOC
End DoDot:3
End DoDot:2
+30 IF RPLFTYPE=1
SET $PIECE(^PRCS(410,RPLDA,3),U,6)=RPLBOC
End DoDot:1
+31 IF '$GET(DONE)
Begin DoDot:1
+32 IF RPLFTYPE>1
Begin DoDot:2
+33 SET I=0
FOR
SET I=$ORDER(^PRCS(410,RPLDA,"IT",I))
if '(I?1N.N)
QUIT
Begin DoDot:3
+34 SET RPLBOC=$PIECE(^PRCS(410,RPLDA,"IT",I,0),U,4)
+35 IF RPLBOC]""
SET RPLBOC(RPLBOC)=$GET(RPLBOC(RPLBOC))_I_";"
End DoDot:3
+36 SET I=""
+37 WRITE !!," This document refers to the following BOC(s):",!
+38 IF $ORDER(RPLBOC(""))=""
WRITE " [NONE]",!!
+39 FOR
SET I=$ORDER(RPLBOC(I))
if I=""
QUIT
Begin DoDot:3
+40 WRITE " BOC: ",I,":"
+41 IF '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,I)
WRITE " ** INVALID **"
SET RV=-1
+42 WRITE !," BOC ",+I," ITEM(S): ",$EXTRACT(RPLBOC(I),1,$LENGTH(RPLBOC(I))-1)
+43 WRITE !!
End DoDot:3
End DoDot:2
+44 IF RPLFTYPE=1
Begin DoDot:2
+45 SET RPLBOC=$PIECE($GET(^PRCS(410,RPLDA,3)),U,6)
+46 WRITE !!,"This document uses BOC ",RPLBOC
+47 IF '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,RPLBOC)
WRITE " ** INVALID **"
SET RV=-1
End DoDot:2
+48 IF RV<0
IF MUSTCHG
WRITE !,"You must edit this document to correct the BOC entries now.",!
End DoDot:1
+49 QUIT RV
+50 ;
OKCCBOC(TRANSXN) ;TRANSXN = transaction# of transaction to check
+1 ;returns 1 if no change required, 0 if user must edit
+2 ;First get FCP, Form type, Station, IEN and CC
+3 NEW A,CC,FCP,DA,STA,CCCNT,DONE,RV,GOODCC
+4 NEW BOC,BOCC,I,J,DR,DIE,FTYPE
+5 SET FCP=$$GETTXNCP(TRANSXN,.DA,.STA)
+6 IF 'DA!'STA
QUIT 0
+7 SET FTYPE=$PIECE($GET(^PRCS(410,DA,0)),U,4)
+8 SET CC=+$PIECE($GET(^PRCS(410,DA,3)),U,3)
IF 'CC
QUIT 0
+9 SET GOODCC=$$VALIDCC^PRCSECP(STA,FCP,CC)
+10 IF 'GOODCC
Begin DoDot:1
+11 SET A(1,"F")="!!?10"
SET A(1)="An invalid Cost Center ("_+CC_") was entered."
+12 SET A(2,"F")="!?10"
SET A(2)="You must re-edit this document before it can be approved."
+13 SET A(3)=$CHAR(7)
+14 DO EN^DDIOL(.A)
End DoDot:1
QUIT 0
+15 ;
+16 ;OK--time to deal with the BOCs now. For 1358s, check the single BOC
+17 ;
+18 SET BOCC=$$GETBOCNT^PRCSECP(STA,FCP,CC)
+19 SET RV=1
+20 IF FTYPE=1
Begin DoDot:1
+21 SET BOC=$PIECE($GET(^PRCS(410,DA,3)),U,6)
+22 IF '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC)
Begin DoDot:2
+23 SET A(1,"F")="!!?10"
SET A(1)="An invalid BOC ("_+BOC_") was entered."
+24 IF (+BOCC=1)
SET $PIECE(PRCS(410,DA,3),U,6)=$PIECE(BOCC,U,2)
SET A(2)="It has been changed to "_+$PIECE(BOCC,U,2)
+25 IF (+BOCC'=1)
SET A(2)="You must re-edit this document before it can be approved."
+26 SET A(2,"F")="!?10"
+27 SET A(3)=$CHAR(7)
+28 DO EN^DDIOL(.A)
+29 SET RV=0
End DoDot:2
QUIT
End DoDot:1
QUIT RV
+30 ;
+31 ;For the other form types, check all BOCs
+32 ;
+33 SET (I,J)=0
+34 FOR
SET I=$ORDER(^PRCS(410,DA,"IT",I))
if '(I?1N.N)
QUIT
Begin DoDot:1
+35 SET BOC=$PIECE(^PRCS(410,DA,"IT",I,0),U,4)
+36 IF '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC)
Begin DoDot:2
+37 SET J=J+1
SET A(J)="An invalid BOC ("_+BOC_") was entered for item "_I_"."
+38 SET A(J,"F")="!?10"
IF J=1
SET A(J,"F")="!"_A(J,"F")
+39 IF (+BOCC=1)
SET $PIECE(^PRCS(410,DA,"IT",I,0),U,4)=$PIECE(BOCC,U,2)
End DoDot:2
End DoDot:1
+40 IF J
SET RV=0
SET J=J+1
SET A(J,"F")="!?10"
SET A(J)=$SELECT((+BOCC'=1):"You must re-edit this document before it can be approved.",1:"BOC(s) replaced with "_+$PIECE(BOCC,U,2))
SET A(J+1)=$CHAR(7)
DO EN^DDIOL(.A)
+41 QUIT RV
GETTXNCP(TRANSID,OUTIEN,OUTSTA) ;GET IEN AND CONTROL POINT # FOR TRANSACTION
+1 SET OUTIEN=+$ORDER(^PRCS(410,"B",TRANSID,""))
+2 SET OUTSTA=$PIECE($GET(^PRCS(410,OUTIEN,0)),U,5)
+3 QUIT $PIECE($GET(^PRCS(410,OUTIEN,3)),U,1)
+4 ;
+5 ;
CHKITDES(PRCDA) ;2237 input template - check all line items for a description
+1 ;This procedure checks all line items on a 2237 to make sure they have a
+2 ;description. Sets branching logic for input template if any line item
+3 ;descriptions are not populated.
+4 ;
+5 ; Called from input templates:
+6 ; - PRCSEN2237B
+7 ; - PRCSENR&NR
+8 ;
+9 ; Input:
+10 ; PRCDA - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+11 ;
+12 ; Output: None (sets branching logic for input template)
+13 ;
+14 SET PRCDA=+$GET(PRCDA)
+15 if '$GET(PRCDA)
QUIT
+16 ;Form Type
NEW PRCHJFT
SET PRCHJFT=$PIECE(^PRCS(410,PRCDA,0),"^",4)
+17 ;quit if not a 2237 transaction (Form Type IEN 2,3,or 4)
+18 if $GET(PRCHJFT)<2!($GET(PRCHJFT)>4)
QUIT
+19 ;check if 2237 has any line items missing a description
+20 NEW PRCWARN
+21 IF '$$ITDESALL^PRCHJUTL(PRCDA,.PRCWARN)
Begin DoDot:1
+22 NEW PRCIDX
SET PRCIDX=0
+23 FOR
SET PRCIDX=$ORDER(PRCWARN(PRCIDX))
if 'PRCIDX
QUIT
Begin DoDot:2
+24 WRITE !?3,$$UP^XLFSTR($GET(PRCWARN(PRCIDX)))
End DoDot:2
End DoDot:1
+25 ;
+26 ;if any line items missing a description set input template branch
+27 IF $DATA(PRCWARN)
SET Y="@1"
+28 ;
+29 QUIT
