- 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 Feb 18, 2025@23:38:57 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)