PRCPAGPR ;WISC/RFJ/DXH - autogen primary or whse order (rep item list) ;9.28.99
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
GETRIL() ; get repetitive item list
; returns repetitive item list number
N %,CONTPT,COSTCNTR,COUNT,PRCPFLAG,PRCPREPN,PRCSFYT,PRCSQTT,X,Y
S COSTCNTR=$P($G(^PRCP(445,PRCP("I"),0)),"^",7) I 'COSTCNTR,PRCP("DPTYPE")="W" S COSTCNTR=+$$SUPPLYCC^PRCSCK()
I 'COSTCNTR W !!,"COST CENTER IS MISSING FOR THIS INVENTORY POINT." Q ""
W !!,"COST CENTER: ",COSTCNTR
; get control points
S CONTPT=$$CONTPT(PRC("SITE"),PRCP("I"),COSTCNTR) I 'CONTPT Q ""
S PRC("CP")=$P($P($G(^PRC(420,PRC("SITE"),1,CONTPT,0)),"^")," ")
K PRC("FY") D FY^PRCSUT I PRC("FY")["^" Q ""
K PRC("QTR") D QT^PRCSUT I PRC("QTR")["^" Q ""
S PRCPREPN=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")_"-"_COSTCNTR W !!,"I will generate requests for: ",PRCPREPN
S IOP="HOME" D ^%ZIS K IOP,^TMP($J,"PRCPAGPR")
S COUNT=1,X=PRCPREPN F S X=$O(^PRCS(410.3,"B",X)) Q:X=""!($P(X,"-",1,5)'=PRCPREPN)!($G(PRCPFLAG)) S Y=0 F S Y=$O(^PRCS(410.3,"B",X,Y)) Q:'Y!($G(PRCPFLAG)) D
. S %=$G(^PRCS(410.3,Y,0)) I %="" Q
. I $P(%,"^",3)'=PRCP("I") Q
. I COUNT=1 W !!,"You currently have the following repetitive item lists on file:"
. S COUNT=COUNT+1,^TMP($J,"PRCPAGPR",Y)=""
. W !?5,X,?35,"created: ",$E($P(%,"^",4),4,5),"-",$E($P(%,"^",4),6,7),"-",$E($P(%,"^",4),2,3),?60,"item count: ",+$P($G(^PRCS(410.3,Y,1,0)),"^",4)
. I COUNT#(IOSL-4)=0 D P^PRCPUREP
I $G(PRCPFLAG) K ^TMP($J,"PRCPAGPR") Q ""
I $O(^TMP($J,"PRCPAGPR",0)) D I $G(PRCPFLAG) K ^TMP($J,"PRCPAGPR") Q ""
. S XP="Do you want to DELETE all the repetitive item lists on file",XH="Enter 'YES' to delete ALL the repetitive item lists displayed above, 'NO' to",XH(1)="NOT delete them, '^' to exit."
. W ! S %=$$YN^PRCPUYN(2)
. I %=2 Q
. I %'=1 S PRCPFLAG=1 Q
. ; delete repetitive item lists on file
. W !," deleting repetitive item lists..."
. S COUNT=0 F S COUNT=$O(^TMP($J,"PRCPAGPR",COUNT)) Q:'COUNT D DELRIL(COUNT)
K ^TMP($J,"PRCPAGPR")
Q PRCPREPN
;
;
CONTPT(V1,V2,V3) ; get control point tied to invpt
; v1=station number
; v2=inventory point da
; v3=costcenter
N CONTPT,COUNT,DA,DIC,PRCPCC,PRCPINPT,PRCPSTAT,X,Y,Y1
S PRCPSTAT=+V1,PRCPINPT=+V2,PRCPCC=+V3
S PRCPINPT("E")=$$GET1^DIQ(445,PRCPINPT,.01)
S DIC("S")="I $D(^PRC(420,""C"",DUZ,PRCPSTAT,+Y)),$D(^PRC(420,""AE"",PRCPSTAT,PRCPINPT,+Y)),$S($P(^PRC(420,PRCPSTAT,1,+Y,0),U,12)=2:1,1:$D(^PRC(420,PRCPSTAT,1,+Y,2,PRCPCC,0)))"
; look for control points that user has access to
S (COUNT,CONTPT,Y,Y1)=0 F S Y=$O(^PRC(420,"AE",PRCPSTAT,PRCPINPT,Y)) Q:'Y D
. S Y1=Y1+1,COUNT("PRCP",Y1)=$P(^PRC(420,PRCPSTAT,1,+Y,0),U)
. I $D(^PRC(420,"C",DUZ,PRCPSTAT,+Y)) S $P(COUNT("PRCP",Y1),U,2)=1
. I ($P(^PRC(420,PRCPSTAT,1,+Y,0),U,12)=2)!($D(^PRC(420,PRCPSTAT,1,+Y,2,PRCPCC,0))) S $P(COUNT("PRCP",Y1),U,3)=1
. Q:'$P(COUNT("PRCP",Y1),U,2)!('$P(COUNT("PRCP",Y1),U,3))
. S CONTPT=Y,COUNT=COUNT+1
I 'COUNT D Q ""
. I 'Y1 W !!,"No FUND CONTROL POINTS tied to INVENTORY POINT '"_PRCPINPT("E")_"'." Q
. I Y1=1 D Q
.. W !!,"FUND CONTROL POINT '"_$P(COUNT("PRCP",Y1),U)_"' is tied to INVENTORY POINT"
.. W !,"'"_PRCPINPT("E")_"', but "
.. I '$P(COUNT("PRCP",Y1),U,3) W "it does not include COST CENTER "_PRCPCC W $S('$P(COUNT("PRCP",Y1),U,2):" and",1:".") W:'$P(COUNT("PRCP",Y1),U,2) !
.. W:'$P(COUNT("PRCP",Y1),U,2) "you lack control point access." W " Can't proceed."
. W !!,"These FUND CONTROL PTS are tied to INVENTORY POINT '"_PRCPINPT("E")_"':"
. S Y1=0 F S Y1=$O(COUNT("PRCP",Y1)) Q:'Y1 W !,?2,$E($P(COUNT("PRCP",Y1),U),1,20),?25 W:'$P(COUNT("PRCP",Y1),U,2) "You lack access. " W:'$P(COUNT("PRCP",Y1),U,3) "COST CENTER "_PRCPCC_" is not included."
. W !,"Indicated deficiencies must be corrected before we can proceed."
I COUNT=1,CONTPT S Y=$P($G(^PRC(420,PRCPSTAT,1,CONTPT,0)),"^") I Y'="" W !!,"FUND CONTROL POINT: ",Y Q CONTPT
S DIC="^PRC(420,"_PRCPSTAT_",1,",DIC(0)="QEAM",DA=PRCPSTAT W ! D ^DIC
Q $S(Y'>0:0,1:+Y)
;
;
DELRIL(V1) ; delete repetitive item list da=v1
I '$D(^PRCS(410.3,+V1,0)) Q
N DA,DIC,DIK
S DIK="^PRCS(410.3,",DA=+V1 D ^DIK Q
;
;
NEWRIL(V1,V2) ; add a new repetitve item list
; v1=invpt da
; v2=number to add
; returns da of entry added
N %,%DT,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,INVPT,X,Y
S INVPT=V1,(PRCPREPN,X)=V2
D EN1^PRCUTL1(.X) I X="" Q ""
S DIC="^PRCS(410.3,",DIC(0)="L",DLAYGO=410.3,DIC("DR")="3////"_INVPT_";4///NOW" K DD,D0 D FILE^DICN
Q $S(Y'>0:0,1:Y)
;
;
ADDITEM(V1,V2,V3,V4,V5) ; add items to repetitive item list
; v1=repetitive item list da
; v2=item master number
; v3=qty
; v4=vendor da
; v5=cost
; returns entry number
I '$D(^PRCS(410.3,+V1,0)) Q ""
I '$D(^PRCS(410.3,+V1,1,0)) S ^(0)="^410.31IPA^^"
I '$D(^PRC(441,+V2,0)) Q ""
I '$D(^PRC(441,+V2,2,0)) S ^(0)="^441.01IP^^"
N %,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,VENDOR,X,Y
S VENDOR=$P($G(^PRC(440,+V4,0)),"^")
S (DIC,DIE)="^PRCS(410.3,"_+V1_",1,",DIC(0)="L",DLAYGO=410.3,DA(1)=+V1,X=+V2,DIC("DR")="1////"_+V3_";2////"_VENDOR_";3////"_+V5_";4////"_+V4
D FILE^DICN
Q $S(Y'>0:0,1:+Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAGPR 5247 printed Oct 16, 2024@18:13:19 Page 2
PRCPAGPR ;WISC/RFJ/DXH - autogen primary or whse order (rep item list) ;9.28.99
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
GETRIL() ; get repetitive item list
+1 ; returns repetitive item list number
+2 NEW %,CONTPT,COSTCNTR,COUNT,PRCPFLAG,PRCPREPN,PRCSFYT,PRCSQTT,X,Y
+3 SET COSTCNTR=$PIECE($GET(^PRCP(445,PRCP("I"),0)),"^",7)
IF 'COSTCNTR
IF PRCP("DPTYPE")="W"
SET COSTCNTR=+$$SUPPLYCC^PRCSCK()
+4 IF 'COSTCNTR
WRITE !!,"COST CENTER IS MISSING FOR THIS INVENTORY POINT."
QUIT ""
+5 WRITE !!,"COST CENTER: ",COSTCNTR
+6 ; get control points
+7 SET CONTPT=$$CONTPT(PRC("SITE"),PRCP("I"),COSTCNTR)
IF 'CONTPT
QUIT ""
+8 SET PRC("CP")=$PIECE($PIECE($GET(^PRC(420,PRC("SITE"),1,CONTPT,0)),"^")," ")
+9 KILL PRC("FY")
DO FY^PRCSUT
IF PRC("FY")["^"
QUIT ""
+10 KILL PRC("QTR")
DO QT^PRCSUT
IF PRC("QTR")["^"
QUIT ""
+11 SET PRCPREPN=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")_"-"_COSTCNTR
WRITE !!,"I will generate requests for: ",PRCPREPN
+12 SET IOP="HOME"
DO ^%ZIS
KILL IOP,^TMP($JOB,"PRCPAGPR")
+13 SET COUNT=1
SET X=PRCPREPN
FOR
SET X=$ORDER(^PRCS(410.3,"B",X))
if X=""!($PIECE(X,"-",1,5)'=PRCPREPN)!($GET(PRCPFLAG))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^PRCS(410.3,"B",X,Y))
if 'Y!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+14 SET %=$GET(^PRCS(410.3,Y,0))
IF %=""
QUIT
+15 IF $PIECE(%,"^",3)'=PRCP("I")
QUIT
+16 IF COUNT=1
WRITE !!,"You currently have the following repetitive item lists on file:"
+17 SET COUNT=COUNT+1
SET ^TMP($JOB,"PRCPAGPR",Y)=""
+18 WRITE !?5,X,?35,"created: ",$EXTRACT($PIECE(%,"^",4),4,5),"-",$EXTRACT($PIECE(%,"^",4),6,7),"-",$EXTRACT($PIECE(%,"^",4),2,3),?60,"item count: ",+$PIECE($GET(^PRCS(410.3,Y,1,0)),"^",4)
+19 IF COUNT#(IOSL-4)=0
DO P^PRCPUREP
End DoDot:1
+20 IF $GET(PRCPFLAG)
KILL ^TMP($JOB,"PRCPAGPR")
QUIT ""
+21 IF $ORDER(^TMP($JOB,"PRCPAGPR",0))
Begin DoDot:1
+22 SET XP="Do you want to DELETE all the repetitive item lists on file"
SET XH="Enter 'YES' to delete ALL the repetitive item lists displayed above, 'NO' to"
SET XH(1)="NOT delete them, '^' to exit."
+23 WRITE !
SET %=$$YN^PRCPUYN(2)
+24 IF %=2
QUIT
+25 IF %'=1
SET PRCPFLAG=1
QUIT
+26 ; delete repetitive item lists on file
+27 WRITE !," deleting repetitive item lists..."
+28 SET COUNT=0
FOR
SET COUNT=$ORDER(^TMP($JOB,"PRCPAGPR",COUNT))
if 'COUNT
QUIT
DO DELRIL(COUNT)
End DoDot:1
IF $GET(PRCPFLAG)
KILL ^TMP($JOB,"PRCPAGPR")
QUIT ""
+29 KILL ^TMP($JOB,"PRCPAGPR")
+30 QUIT PRCPREPN
+31 ;
+32 ;
CONTPT(V1,V2,V3) ; get control point tied to invpt
+1 ; v1=station number
+2 ; v2=inventory point da
+3 ; v3=costcenter
+4 NEW CONTPT,COUNT,DA,DIC,PRCPCC,PRCPINPT,PRCPSTAT,X,Y,Y1
+5 SET PRCPSTAT=+V1
SET PRCPINPT=+V2
SET PRCPCC=+V3
+6 SET PRCPINPT("E")=$$GET1^DIQ(445,PRCPINPT,.01)
+7 SET DIC("S")="I $D(^PRC(420,""C"",DUZ,PRCPSTAT,+Y)),$D(^PRC(420,""AE"",PRCPSTAT,PRCPINPT,+Y)),$S($P(^PRC(420,PRCPSTAT,1,+Y,0),U,12)=2:1,1:$D(^PRC(420,PRCPSTAT,1,+Y,2,PRCPCC,0)))"
+8 ; look for control points that user has access to
+9 SET (COUNT,CONTPT,Y,Y1)=0
FOR
SET Y=$ORDER(^PRC(420,"AE",PRCPSTAT,PRCPINPT,Y))
if 'Y
QUIT
Begin DoDot:1
+10 SET Y1=Y1+1
SET COUNT("PRCP",Y1)=$PIECE(^PRC(420,PRCPSTAT,1,+Y,0),U)
+11 IF $DATA(^PRC(420,"C",DUZ,PRCPSTAT,+Y))
SET $PIECE(COUNT("PRCP",Y1),U,2)=1
+12 IF ($PIECE(^PRC(420,PRCPSTAT,1,+Y,0),U,12)=2)!($DATA(^PRC(420,PRCPSTAT,1,+Y,2,PRCPCC,0)))
SET $PIECE(COUNT("PRCP",Y1),U,3)=1
+13 if '$PIECE(COUNT("PRCP",Y1),U,2)!('$PIECE(COUNT("PRCP",Y1),U,3))
QUIT
+14 SET CONTPT=Y
SET COUNT=COUNT+1
End DoDot:1
+15 IF 'COUNT
Begin DoDot:1
+16 IF 'Y1
WRITE !!,"No FUND CONTROL POINTS tied to INVENTORY POINT '"_PRCPINPT("E")_"'."
QUIT
+17 IF Y1=1
Begin DoDot:2
+18 WRITE !!,"FUND CONTROL POINT '"_$PIECE(COUNT("PRCP",Y1),U)_"' is tied to INVENTORY POINT"
+19 WRITE !,"'"_PRCPINPT("E")_"', but "
+20 IF '$PIECE(COUNT("PRCP",Y1),U,3)
WRITE "it does not include COST CENTER "_PRCPCC
WRITE $SELECT('$PIECE(COUNT("PRCP",Y1),U,2):" and",1:".")
if '$PIECE(COUNT("PRCP",Y1),U,2)
WRITE !
+21 if '$PIECE(COUNT("PRCP",Y1),U,2)
WRITE "you lack control point access."
WRITE " Can't proceed."
End DoDot:2
QUIT
+22 WRITE !!,"These FUND CONTROL PTS are tied to INVENTORY POINT '"_PRCPINPT("E")_"':"
+23 SET Y1=0
FOR
SET Y1=$ORDER(COUNT("PRCP",Y1))
if 'Y1
QUIT
WRITE !,?2,$EXTRACT($PIECE(COUNT("PRCP",Y1),U),1,20),?25
if '$PIECE(COUNT("PRCP",Y1),U,2)
WRITE "You lack access. "
if '$PIECE(COUNT("PRCP",Y1),U,3)
WRITE "COST CENTER "_PRCPCC_" is not included."
+24 WRITE !,"Indicated deficiencies must be corrected before we can proceed."
End DoDot:1
QUIT ""
+25 IF COUNT=1
IF CONTPT
SET Y=$PIECE($GET(^PRC(420,PRCPSTAT,1,CONTPT,0)),"^")
IF Y'=""
WRITE !!,"FUND CONTROL POINT: ",Y
QUIT CONTPT
+26 SET DIC="^PRC(420,"_PRCPSTAT_",1,"
SET DIC(0)="QEAM"
SET DA=PRCPSTAT
WRITE !
DO ^DIC
+27 QUIT $SELECT(Y'>0:0,1:+Y)
+28 ;
+29 ;
DELRIL(V1) ; delete repetitive item list da=v1
+1 IF '$DATA(^PRCS(410.3,+V1,0))
QUIT
+2 NEW DA,DIC,DIK
+3 SET DIK="^PRCS(410.3,"
SET DA=+V1
DO ^DIK
QUIT
+4 ;
+5 ;
NEWRIL(V1,V2) ; add a new repetitve item list
+1 ; v1=invpt da
+2 ; v2=number to add
+3 ; returns da of entry added
+4 NEW %,%DT,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,INVPT,X,Y
+5 SET INVPT=V1
SET (PRCPREPN,X)=V2
+6 DO EN1^PRCUTL1(.X)
IF X=""
QUIT ""
+7 SET DIC="^PRCS(410.3,"
SET DIC(0)="L"
SET DLAYGO=410.3
SET DIC("DR")="3////"_INVPT_";4///NOW"
KILL DD,D0
DO FILE^DICN
+8 QUIT $SELECT(Y'>0:0,1:Y)
+9 ;
+10 ;
ADDITEM(V1,V2,V3,V4,V5) ; add items to repetitive item list
+1 ; v1=repetitive item list da
+2 ; v2=item master number
+3 ; v3=qty
+4 ; v4=vendor da
+5 ; v5=cost
+6 ; returns entry number
+7 IF '$DATA(^PRCS(410.3,+V1,0))
QUIT ""
+8 IF '$DATA(^PRCS(410.3,+V1,1,0))
SET ^(0)="^410.31IPA^^"
+9 IF '$DATA(^PRC(441,+V2,0))
QUIT ""
+10 IF '$DATA(^PRC(441,+V2,2,0))
SET ^(0)="^441.01IP^^"
+11 NEW %,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,VENDOR,X,Y
+12 SET VENDOR=$PIECE($GET(^PRC(440,+V4,0)),"^")
+13 SET (DIC,DIE)="^PRCS(410.3,"_+V1_",1,"
SET DIC(0)="L"
SET DLAYGO=410.3
SET DA(1)=+V1
SET X=+V2
SET DIC("DR")="1////"_+V3_";2////"_VENDOR_";3////"_+V5_";4////"_+V4
+14 DO FILE^DICN
+15 QUIT $SELECT(Y'>0:0,1:+Y)
