PRCSES1 ;WISC/SAW/LJP/TKW-SUB-MODULES CALLED BY FIELDS IN CPA FILE CON'T ; [12/11/98 2:25pm]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
ITEM ;PR/DISP ITEM HIST
Q:'$D(PRC("SITE")) Q:'$D(PRC("CP")) I $D(^PRCS(410,DA(1),3)),$P(^(3),"^",4),$D(^(2)),$P(^(2),"^")'="" S PRCSV=$P(^(3),"^",4)
G ITEMH:'$D(PRCSV)
S DIC="^PRC(441,",DIC(0)="EMNQZ",DIC("S")="I $D(^PRC(441,+Y,2,PRCSV))" D ^DIC I +Y'>0 K DIC,X Q
S X=+Y I $D(^PRC(441,X,3)),$P(^PRC(441,X,3),"^")=1 W !,"This item is inactive!" K DIC,X Q
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",12)=2 G ITS
S X=+Y,%=$P(^PRC(441,X,0),"^",8) I %,%'=PRCSV,$D(^PRC(440,%,0)) W !,"Sorry, this item has a mandatory source.",!,"You must order this item from ",$P(^PRC(440,%,0),"^"),".",! K %,X,PRCSV Q
ITS W !,X,! S X=+Y,Z=^PRC(441,+Y,2,PRCSV,0),$P(^PRCS(410,DA(1),"IT",DA,0),"^",3)=$P(Z,"^",7),$P(^(0),"^",6)=$P(Z,"^",4),$P(^(0),"^",7)=$P(Z,"^",2),^(1,0)="^^1^1^"_$S($D(DT):DT,1:"")_"^^",^(1,0)=$P(Y(0),"^",2)
S PRCSSUB=$S($D(^PRCD(420.1,+$S($D(^PRCS(410,DA(1),3)):$P(^(3),U,3),1:""),1,+$S($D(^PRC(441,+$S($D(^PRCS(410,DA(1),"IT",DA,0)):$P(^(0),U,5),1:""),0)):$P(^(0),U,10),1:""),0)):$P(^(0),U),1:"")
I PRCSSUB S $P(^PRCS(410,DA(1),"IT",DA,0),U,4)=PRCSSUB
IT Q:'$D(^PRCS(410,DA(1),0)) I $P(^(0),U,4)=5 G EXIT
W !,"Would you like to see the procurement history for this item" S %=2 D YN^DICN G EXIT:%=2!(%<0),IT:%=0
ITEM0 Q:'$D(Y(0)) S W1=0,W=$P(Y(0),U,2),W(1)=PRC("SITE")_$P(PRC("CP")," "),W(2)="",W(3)=0,PRCSX=X
I $D(^PRC(441,X,4,W(1),1,"AC")) F I=0:1 S W(3)=$O(^PRC(441,X,4,W(1),1,"AC",W(3))) Q:W(3)'>0!(I=5) S W(4)="" F J=0:1 S W(4)=$O(^PRC(441,X,4,W(1),1,"AC",W(3),W(4))) Q:'W(4) S W(2)=W(2)_W(4)_U
NONE I W(2)="" W !,"A history for this item does not yet exist." G EXIT
F K=1:1:5 S W(6)=$P(W(2),U,K) Q:W(6)="" S W(5)=0,W(5)=$O(^PRC(442,W(6),2,"AE",X,W(5))) I W(5)'="" S W1=W1+1 D ITEM1
I 'W1 S W(2)="" G NONE
EXIT I $D(PRCSV),$D(Z),$P(Z,"^",12) W $C(7),!,"NOTE: This item has a minimum order quantity of ",$P(Z,"^",12)
I $D(PRCSV),$D(Z),$P(Z,"^",11) W $C(7),!,"NOTE: This item must be ordered in multiples of ",$P(Z,"^",11)
I $D(PRCSV),$D(Z),$P(Z,"^",8) S Z(1)=$P(Z,"^",7),Z(1)=$S($D(^PRCD(420.5,+Z(1),0)):$P(^(0),"^",1),1:"") I Z(1)'="" W $C(7),!,"NOTE: This item has a packaging multiple/unit of purchase of ",$P(Z,"^",8)_"/"_Z(1)
W ! K %,L,W,W1,DIC,PRCSV Q
ITEM1 I W1=1 W !,?34,"ITEM HISTORY"
I W1=1 D NOW^%DTC S Y=$J(%,7,4) D DD^%DT W !,Y,?23,"Site: ",PRC("SITE"),?36,"Control point: ",PRC("CP") S X=PRCSX
I W1=1 W !,"Item Number: ",X,?23,"Description: ",W,!!,?26,"Quantity",!,?26,"Previously",?38,"Unit of",?71,"Quantity"
I W1=1 W !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase",?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",! S L="",$P(L,"_",IOM)="_" W L S L=""
W ! I $D(^PRC(442,W(6),1)),$P(^(1),U,15)'="" S Y=$P(^(1),U,15) D DD^%DT W Y
W ?15,$P(^PRC(442,W(6),0),U)
I $D(^PRC(442,W(6),2,W(5),2)) S W(7)=^(2) W ?26,$J(+$P(^(2),U,8),8)
I $D(^PRC(442,W(6),2,W(5),0)) S W(8)=^(0) W:+$P(W(8),U,3) ?38,$S($D(^PRCD(420.5,+$P(W(8),U,3),0)):$P(^(0),U),1:"")
W:$D(W(8)) ?48,$J($P(W(8),U,9),9,2) W:$D(W(7)) ?59,$J($P(W(7),U),10,2) W:$D(W(8)) ?71,$J($P(W(8),U,2),8)
I $P(^PRC(442,W(6),1),U) S W(8)=$P(^(1),U),W(8)=$S($D(^PRC(440,W(8),0)):$P(^(0),U),1:"") I W(8)'="" W !,"Vendor: ",W(8)
K W(7),W(8) Q
ITEMH ;ITEM FLD HELP PMPT
I $D(^PRCS(410,DA(1),3)),$P(^(3),"^",4),$D(^(2)),$P(^(2),"^")'="" S PRCSV=$P(^(3),"^",4)
I '$D(PRCSV) W !,"You must select a vendor before you may enter Procurement (UIR) Card items.",$C(7) Q
S:$D(D) ZD=D S X="?",DIC="^PRC(441,",DIC(0)="EM",DIC("S")="I $D(^PRC(441,+Y,2,PRCSV))" D ^DIC S DIC=DIE S:$D(ZD) D=ZD
K PRCSV,DIC(0),DIC("S"),ZD Q
OBL ;COMPUTE FLDS FOR 1358 ADJ
G OBL^PRCSES2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSES1 3805 printed Sep 23, 2025@19:53:46 Page 2
PRCSES1 ;WISC/SAW/LJP/TKW-SUB-MODULES CALLED BY FIELDS IN CPA FILE CON'T ; [12/11/98 2:25pm]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
ITEM ;PR/DISP ITEM HIST
+1 if '$DATA(PRC("SITE"))
QUIT
if '$DATA(PRC("CP"))
QUIT
IF $DATA(^PRCS(410,DA(1),3))
IF $PIECE(^(3),"^",4)
IF $DATA(^(2))
IF $PIECE(^(2),"^")'=""
SET PRCSV=$PIECE(^(3),"^",4)
+2 if '$DATA(PRCSV)
GOTO ITEMH
+3 SET DIC="^PRC(441,"
SET DIC(0)="EMNQZ"
SET DIC("S")="I $D(^PRC(441,+Y,2,PRCSV))"
DO ^DIC
IF +Y'>0
KILL DIC,X
QUIT
+4 SET X=+Y
IF $DATA(^PRC(441,X,3))
IF $PIECE(^PRC(441,X,3),"^")=1
WRITE !,"This item is inactive!"
KILL DIC,X
QUIT
+5 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
IF $PIECE(^(0),"^",12)=2
GOTO ITS
+6 SET X=+Y
SET %=$PIECE(^PRC(441,X,0),"^",8)
IF %
IF %'=PRCSV
IF $DATA(^PRC(440,%,0))
WRITE !,"Sorry, this item has a mandatory source.",!,"You must order this item from ",$PIECE(^PRC(440,%,0),"^"),".",!
KILL %,X,PRCSV
QUIT
ITS WRITE !,X,!
SET X=+Y
SET Z=^PRC(441,+Y,2,PRCSV,0)
SET $PIECE(^PRCS(410,DA(1),"IT",DA,0),"^",3)=$PIECE(Z,"^",7)
SET $PIECE(^(0),"^",6)=$PIECE(Z,"^",4)
SET $PIECE(^(0),"^",7)=$PIECE(Z,"^",2)
SET ^(1,0)="^^1^1^"_$SELECT($DATA(DT):DT,1:"")_"^^"
SET ^(1,0)=$PIECE(Y(0),"^",2)
+1 SET PRCSSUB=$SELECT($DATA(^PRCD(420.1,+$SELECT($DATA(^PRCS(410,DA(1),3)):$PIECE(^(3),U,3),1:""),1,+$SELECT($DATA(^PRC(441,+$SELECT($DATA(^PRCS(410,DA(1),"IT",DA,0)):$PIECE(^(0),U,5),1:""),0)):$PIECE(^(0),U,10),1:""),0)):$PIECE(^(0),U),1:"")
+2 IF PRCSSUB
SET $PIECE(^PRCS(410,DA(1),"IT",DA,0),U,4)=PRCSSUB
IT if '$DATA(^PRCS(410,DA(1),0))
QUIT
IF $PIECE(^(0),U,4)=5
GOTO EXIT
+1 WRITE !,"Would you like to see the procurement history for this item"
SET %=2
DO YN^DICN
if %=2!(%<0)
GOTO EXIT
if %=0
GOTO IT
ITEM0 if '$DATA(Y(0))
QUIT
SET W1=0
SET W=$PIECE(Y(0),U,2)
SET W(1)=PRC("SITE")_$PIECE(PRC("CP")," ")
SET W(2)=""
SET W(3)=0
SET PRCSX=X
+1 IF $DATA(^PRC(441,X,4,W(1),1,"AC"))
FOR I=0:1
SET W(3)=$ORDER(^PRC(441,X,4,W(1),1,"AC",W(3)))
if W(3)'>0!(I=5)
QUIT
SET W(4)=""
FOR J=0:1
SET W(4)=$ORDER(^PRC(441,X,4,W(1),1,"AC",W(3),W(4)))
if 'W(4)
QUIT
SET W(2)=W(2)_W(4)_U
NONE IF W(2)=""
WRITE !,"A history for this item does not yet exist."
GOTO EXIT
+1 FOR K=1:1:5
SET W(6)=$PIECE(W(2),U,K)
if W(6)=""
QUIT
SET W(5)=0
SET W(5)=$ORDER(^PRC(442,W(6),2,"AE",X,W(5)))
IF W(5)'=""
SET W1=W1+1
DO ITEM1
+2 IF 'W1
SET W(2)=""
GOTO NONE
EXIT IF $DATA(PRCSV)
IF $DATA(Z)
IF $PIECE(Z,"^",12)
WRITE $CHAR(7),!,"NOTE: This item has a minimum order quantity of ",$PIECE(Z,"^",12)
+1 IF $DATA(PRCSV)
IF $DATA(Z)
IF $PIECE(Z,"^",11)
WRITE $CHAR(7),!,"NOTE: This item must be ordered in multiples of ",$PIECE(Z,"^",11)
+2 IF $DATA(PRCSV)
IF $DATA(Z)
IF $PIECE(Z,"^",8)
SET Z(1)=$PIECE(Z,"^",7)
SET Z(1)=$SELECT($DATA(^PRCD(420.5,+Z(1),0)):$PIECE(^(0),"^",1),1:"")
IF Z(1)'=""
WRITE $CHAR(7),!,"NOTE: This item has a packaging multiple/unit of purchase of ",$PIECE(Z,"^",8)_"/"_Z(1)
+3 WRITE !
KILL %,L,W,W1,DIC,PRCSV
QUIT
ITEM1 IF W1=1
WRITE !,?34,"ITEM HISTORY"
+1 IF W1=1
DO NOW^%DTC
SET Y=$JUSTIFY(%,7,4)
DO DD^%DT
WRITE !,Y,?23,"Site: ",PRC("SITE"),?36,"Control point: ",PRC("CP")
SET X=PRCSX
+2 IF W1=1
WRITE !,"Item Number: ",X,?23,"Description: ",W,!!,?26,"Quantity",!,?26,"Previously",?38,"Unit of",?71,"Quantity"
+3 IF W1=1
WRITE !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase",?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",!
SET L=""
SET $PIECE(L,"_",IOM)="_"
WRITE L
SET L=""
+4 WRITE !
IF $DATA(^PRC(442,W(6),1))
IF $PIECE(^(1),U,15)'=""
SET Y=$PIECE(^(1),U,15)
DO DD^%DT
WRITE Y
+5 WRITE ?15,$PIECE(^PRC(442,W(6),0),U)
+6 IF $DATA(^PRC(442,W(6),2,W(5),2))
SET W(7)=^(2)
WRITE ?26,$JUSTIFY(+$PIECE(^(2),U,8),8)
+7 IF $DATA(^PRC(442,W(6),2,W(5),0))
SET W(8)=^(0)
if +$PIECE(W(8),U,3)
WRITE ?38,$SELECT($DATA(^PRCD(420.5,+$PIECE(W(8),U,3),0)):$PIECE(^(0),U),1:"")
+8 if $DATA(W(8))
WRITE ?48,$JUSTIFY($PIECE(W(8),U,9),9,2)
if $DATA(W(7))
WRITE ?59,$JUSTIFY($PIECE(W(7),U),10,2)
if $DATA(W(8))
WRITE ?71,$JUSTIFY($PIECE(W(8),U,2),8)
+9 IF $PIECE(^PRC(442,W(6),1),U)
SET W(8)=$PIECE(^(1),U)
SET W(8)=$SELECT($DATA(^PRC(440,W(8),0)):$PIECE(^(0),U),1:"")
IF W(8)'=""
WRITE !,"Vendor: ",W(8)
+10 KILL W(7),W(8)
QUIT
ITEMH ;ITEM FLD HELP PMPT
+1 IF $DATA(^PRCS(410,DA(1),3))
IF $PIECE(^(3),"^",4)
IF $DATA(^(2))
IF $PIECE(^(2),"^")'=""
SET PRCSV=$PIECE(^(3),"^",4)
+2 IF '$DATA(PRCSV)
WRITE !,"You must select a vendor before you may enter Procurement (UIR) Card items.",$CHAR(7)
QUIT
+3 if $DATA(D)
SET ZD=D
SET X="?"
SET DIC="^PRC(441,"
SET DIC(0)="EM"
SET DIC("S")="I $D(^PRC(441,+Y,2,PRCSV))"
DO ^DIC
SET DIC=DIE
if $DATA(ZD)
SET D=ZD
+4 KILL PRCSV,DIC(0),DIC("S"),ZD
QUIT
OBL ;COMPUTE FLDS FOR 1358 ADJ
+1 GOTO OBL^PRCSES2
