- 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 Jan 18, 2025@03:18:53 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