PRCHNPO6 ;WISC/RHD-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 442 ;6/22/94 3:19 PM
V ;;5.1;IFCAP;**129,173**;Oct 20, 2000;Build 9
;Per VHA Directive 2004-038, this routine should not be modified.
;
EN1 ;INPUT TRANSFORM FOR FILE 442, P.O.DATE #.1
Q:'$D(^PRC(442,DA,0)) Q:'$P(^(0),U,3) S PRCHSAVX=X,PRC("FY")=X S:'$D(PRC("SITE")) PRC("SITE")=+^(0) S X=$P(^(0),U,3)
D EN1^PRCHNPO5 S:$D(X) $P(^PRC(442,DA,0),U,4)=PRC("APP")
S X=PRCHSAVX K PRCHSAVX
Q
;
EN2 ;SCREEN--P.O.#['X' (FRESH FOOD) OR 'Z' (CASCA)--INVOICE ADDRESS="FISCAL", P.O.#['C' (CERT.INV.)--MOP='CERT.INV.', INV.ADDR.="FISCAL", IMPREST FUNDS--INV.ADDR.="".
;PRC*5.1*129 modifies INVOICE ADDRESS default from 'FMS' to 'VA FSC'
S Z1=$E($P(^PRC(442,DA,0),"-",2),1,2),PRCHN("INV")="VA FSC",Z2=+$P(^(0),U,2) I $D(^PRCD(442.5,Z2,0)) S PRCHN("MP")=$P(^(0),U,3) I PRCHN("MP")=12 S Z1="IF",PRCHN("INV")="" G EN20
I (Z1["X")!(Z1["Z") S PRCHN("INV")="FISCAL" K Z1,Z2 Q
I Z1'["C" K Z1,Z2 Q
S PRCHN("MP")=2,$P(^PRC(442,DA,0),U,2)=2,^PRC(442,"F",2,DA)="",Z2=2,PRCHN("INV")="FISCAL"
EN20 W !,"Method of Processing="_$P(^PRCD(442.5,Z2,0),U,1) K Z1,Z2
Q
;
EN3 ;SCREEN FCP--CALLED FROM PRCHNPO3
G:'$D(PRCHPO) FALSE S Z0=$E($P(^PRC(442,PRCHPO,0),"-",2),1,2),Z1=+$P(^PRCS(410,Y,0),"-",4)
;
EN4 ;SCREEN FCP FOR SPECIAL P.O.NUMBERS--Z0=1ST 2 DIGITS OF P.O.NO.,Z1=FCP
G:(Z0["H")&('$D(^PRC(420,"AD",1,PRC("SITE"),Z1))) FALSE
I Z0["G",$D(^PRC(411,+PRC("SITE"),0)),$D(^PRC(411.2,+$P(^(0),U,7),0)),"^DEPOT^VACO^DDC^"[("^"_$P(^(0),U,1)_"^") G TRUE
G:(Z0["G")&('$D(^PRC(420,"AD",2,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",4,PRC("SITE"),Z1))) FALSE
G:(Z0["Z")&('$D(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",4,PRC("SITE"),Z1))) FALSE
I $G(PRCHPC)!$G(PRCHDELV) I '$D(^PRC(420,"C",DUZ,PRC("SITE"),Z1)) G FALSE
;
TRUE I 1 Q
;
FALSE I 0
Q
;
EN5 ;FILE #442, FIELD #1 (FCP) ONLINE HELP
S Z1=Y D EN4 ;S FLAG=1
Q
;
EST ;Find Line Item # for Field #13.1
S N="" F PRCHESTA=1:1 S N=$O(^PRC(442,PRCHPO,2,"B",N)) Q:'N
S N=0 F PRCHDIS=1:1 S N=$O(^PRC(442,PRCHPO,3,N)) Q:'N
S PRCHDIS=PRCHDIS+PRCHESTA-1,$P(^PRC(442,PRCHPO,0),U,18)=PRCHDIS,$P(^(0),U,14)=PRCHDIS
K N,PRCHESTA,PRCHDIS
Q
;
EN7 ;FILE 442, PKG.MULT. #3.1
D VEN^PRCHNPO5 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN7^PRCHCRD1
Q
;
EN8 ;FILE 442, P.O.NO. .01 CALLED BY THE SCREEN ON THE .01 FIELD
;PRC*5.1*173 Will insure that the next IEN used is not below 20,000,000
; Start back at closest ien to last realistic ien using for
; loop check to look for last used ien.
Q:'$D(X) Q:$D(PRCHNEW)&$D(^PRC(442,"B",X))
N PRCEN442
;PRC*5.1*129 modifies SACC lock violations
L +^PRC(442,0):$S($G(DILOCKTM)>5:DILOCKTM,1:5) I '$T W $C(7),"ANOTHER USER IS IS EDITING FILE 442 CONTROL NODE! Please retry in a minute." K X Q
S PRCEN442=$P(^PRC(442,0),"^",3)-2
I PRCEN442<20000000 D S:PRCEN442=20000000 PRCEN442=99999999
. F I=90000000:-10000000:20000000 I $O(^PRC(442,I))-I>1000 S PRCEN442=$O(^PRC(442,I)) Q
F PRCEN442=PRCEN442:-2 I '$D(^PRC(442,PRCEN442)) L +^PRC(442,PRCEN442):$S($D(DILOCKTM):DILOCKTM,1:3) Q:$T
L -^PRC(442,0)
I PRCEN442'>0 K X
E S DINUM=PRCEN442
L -^PRC(442,PRCEN442)
Q
;
EN9 ;FILE 442, MAX.ORD.QTY.#9.6
D VEN^PRCHNPO5 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN9^PRCHCRD1
Q
;
; ER-ER3 ARE CALLED FROM PRCHNPO1
ER W !," ** Error in Discount ",PRCH,", item ",PRCHN," has a unit cost of zero ",$C(7) S PRCHER=""
Q
;
ER1 W !," ** Error in Discount ",PRCH,", item ",PRCHN," has been changed. Discount will be deleted",!?4,"and must be re-edited!",$C(7) S PRCHER="",DR="14///^S X=PRCH",DR(2,442.03)=".01///@" D ^DIE K DR
Q
;
ER2 W !," Type Code is undefined.",$C(7) K PRCHPO
Q
;
ER3 W !,$S('PRCHDT:"Breakout Code is undefined.",1:"Socioeconomic Group (FY89) not defined in Vendor file."),$C(7) K PRCHPO
Q
;
SPRMK ;FORMAT & DISPLAY REMARKS FROM REQUEST TO PO
Q:'$D(^PRCS(410,PRCHSY,"RM")) K ^UTILITY($J,"W")
W !,"2237 Special Remarks: " S U="^",PRCHZZ=0,DIWL=1,DIWR=78,DIWF="W"
F PRCHJJ=0:0 S PRCHZZ=$O(^PRCS(410,PRCHSY,"RM",PRCHZZ)) Q:'PRCHZZ I $D(^(PRCHZZ,0)) S X=^(0) D DIWP^PRCUTL($G(DA)),^DIWW
;
SP1 K PRCHJJ W !,"Would you like to transfer the Special Remarks to the New P.O. Comments" S %=1 D YN^DICN
I %=0 W !,"Enter 'Y' to have the Special Remarks added to the end of the P.O. Comments.",! G SP1
G END:%'=1 S:'$D(^PRC(442,D0,4,0)) ^(0)="^^0^0^"_DT S PRCHNN=$P(^(0),U,3),PRCHX=0
F I=0:0 S PRCHX=$O(^PRCS(410,PRCHSY,"RM",PRCHX)) Q:'PRCHX I $D(^(PRCHX,0)) S PRCHNN=PRCHNN+1,^PRC(442,D0,4,PRCHNN,0)=^(0)
S ^PRC(442,D0,4,0)="^^"_PRCHNN_U_PRCHNN_U_DT
;
END K PRCHNN,PRCHX,PRCHZZ,DIWL,DIWR,DISF,I,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO6 4990 printed Oct 16, 2024@18:09:43 Page 2
PRCHNPO6 ;WISC/RHD-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 442 ;6/22/94 3:19 PM
V ;;5.1;IFCAP;**129,173**;Oct 20, 2000;Build 9
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
EN1 ;INPUT TRANSFORM FOR FILE 442, P.O.DATE #.1
+1 if '$DATA(^PRC(442,DA,0))
QUIT
if '$PIECE(^(0),U,3)
QUIT
SET PRCHSAVX=X
SET PRC("FY")=X
if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^(0)
SET X=$PIECE(^(0),U,3)
+2 DO EN1^PRCHNPO5
if $DATA(X)
SET $PIECE(^PRC(442,DA,0),U,4)=PRC("APP")
+3 SET X=PRCHSAVX
KILL PRCHSAVX
+4 QUIT
+5 ;
EN2 ;SCREEN--P.O.#['X' (FRESH FOOD) OR 'Z' (CASCA)--INVOICE ADDRESS="FISCAL", P.O.#['C' (CERT.INV.)--MOP='CERT.INV.', INV.ADDR.="FISCAL", IMPREST FUNDS--INV.ADDR.="".
+1 ;PRC*5.1*129 modifies INVOICE ADDRESS default from 'FMS' to 'VA FSC'
+2 SET Z1=$EXTRACT($PIECE(^PRC(442,DA,0),"-",2),1,2)
SET PRCHN("INV")="VA FSC"
SET Z2=+$PIECE(^(0),U,2)
IF $DATA(^PRCD(442.5,Z2,0))
SET PRCHN("MP")=$PIECE(^(0),U,3)
IF PRCHN("MP")=12
SET Z1="IF"
SET PRCHN("INV")=""
GOTO EN20
+3 IF (Z1["X")!(Z1["Z")
SET PRCHN("INV")="FISCAL"
KILL Z1,Z2
QUIT
+4 IF Z1'["C"
KILL Z1,Z2
QUIT
+5 SET PRCHN("MP")=2
SET $PIECE(^PRC(442,DA,0),U,2)=2
SET ^PRC(442,"F",2,DA)=""
SET Z2=2
SET PRCHN("INV")="FISCAL"
EN20 WRITE !,"Method of Processing="_$PIECE(^PRCD(442.5,Z2,0),U,1)
KILL Z1,Z2
+1 QUIT
+2 ;
EN3 ;SCREEN FCP--CALLED FROM PRCHNPO3
+1 if '$DATA(PRCHPO)
GOTO FALSE
SET Z0=$EXTRACT($PIECE(^PRC(442,PRCHPO,0),"-",2),1,2)
SET Z1=+$PIECE(^PRCS(410,Y,0),"-",4)
+2 ;
EN4 ;SCREEN FCP FOR SPECIAL P.O.NUMBERS--Z0=1ST 2 DIGITS OF P.O.NO.,Z1=FCP
+1 if (Z0["H")&('$DATA(^PRC(420,"AD",1,PRC("SITE"),Z1)))
GOTO FALSE
+2 IF Z0["G"
IF $DATA(^PRC(411,+PRC("SITE"),0))
IF $DATA(^PRC(411.2,+$PIECE(^(0),U,7),0))
IF "^DEPOT^VACO^DDC^"[("^"_$PIECE(^(0),U,1)_"^")
GOTO TRUE
+3 if (Z0["G")&('$DATA(^PRC(420,"AD",2,PRC("SITE"),Z1)))&('$DATA(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$DATA(^PRC(420,"AD",4,PRC("SITE"),Z1)))
GOTO FALSE
+4 if (Z0["Z")&('$DATA(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$DATA(^PRC(420,"AD",4,PRC("SITE"),Z1)))
GOTO FALSE
+5 IF $GET(PRCHPC)!$GET(PRCHDELV)
IF '$DATA(^PRC(420,"C",DUZ,PRC("SITE"),Z1))
GOTO FALSE
+6 ;
TRUE IF 1
QUIT
+1 ;
FALSE IF 0
+1 QUIT
+2 ;
EN5 ;FILE #442, FIELD #1 (FCP) ONLINE HELP
+1 ;S FLAG=1
SET Z1=Y
DO EN4
+2 QUIT
+3 ;
EST ;Find Line Item # for Field #13.1
+1 SET N=""
FOR PRCHESTA=1:1
SET N=$ORDER(^PRC(442,PRCHPO,2,"B",N))
if 'N
QUIT
+2 SET N=0
FOR PRCHDIS=1:1
SET N=$ORDER(^PRC(442,PRCHPO,3,N))
if 'N
QUIT
+3 SET PRCHDIS=PRCHDIS+PRCHESTA-1
SET $PIECE(^PRC(442,PRCHPO,0),U,18)=PRCHDIS
SET $PIECE(^(0),U,14)=PRCHDIS
+4 KILL N,PRCHESTA,PRCHDIS
+5 QUIT
+6 ;
EN7 ;FILE 442, PKG.MULT. #3.1
+1 DO VEN^PRCHNPO5
if '$DATA(X)!($PIECE(^PRC(442,DA(1),2,DA,0),U,5)="")
QUIT
+2 if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^PRC(442,DA(1),0)
SET PRCHCV=+$PIECE(^PRC(442,DA(1),1),U,1)
SET PRCHCI=+$PIECE(^(2,DA,0),U,5)
SET PRCHCPO=DA(1)
DO EN7^PRCHCRD1
+3 QUIT
+4 ;
EN8 ;FILE 442, P.O.NO. .01 CALLED BY THE SCREEN ON THE .01 FIELD
+1 ;PRC*5.1*173 Will insure that the next IEN used is not below 20,000,000
+2 ; Start back at closest ien to last realistic ien using for
+3 ; loop check to look for last used ien.
+4 if '$DATA(X)
QUIT
if $DATA(PRCHNEW)&$DATA(^PRC(442,"B",X))
QUIT
+5 NEW PRCEN442
+6 ;PRC*5.1*129 modifies SACC lock violations
+7 LOCK +^PRC(442,0):$SELECT($GET(DILOCKTM)>5:DILOCKTM,1:5)
IF '$TEST
WRITE $CHAR(7),"ANOTHER USER IS IS EDITING FILE 442 CONTROL NODE! Please retry in a minute."
KILL X
QUIT
+8 SET PRCEN442=$PIECE(^PRC(442,0),"^",3)-2
+9 IF PRCEN442<20000000
Begin DoDot:1
+10 FOR I=90000000:-10000000:20000000
IF $ORDER(^PRC(442,I))-I>1000
SET PRCEN442=$ORDER(^PRC(442,I))
QUIT
End DoDot:1
if PRCEN442=20000000
SET PRCEN442=99999999
+11 FOR PRCEN442=PRCEN442:-2
IF '$DATA(^PRC(442,PRCEN442))
LOCK +^PRC(442,PRCEN442):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if $TEST
QUIT
+12 LOCK -^PRC(442,0)
+13 IF PRCEN442'>0
KILL X
+14 IF '$TEST
SET DINUM=PRCEN442
+15 LOCK -^PRC(442,PRCEN442)
+16 QUIT
+17 ;
EN9 ;FILE 442, MAX.ORD.QTY.#9.6
+1 DO VEN^PRCHNPO5
if '$DATA(X)!($PIECE(^PRC(442,DA(1),2,DA,0),U,5)="")
QUIT
+2 if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^PRC(442,DA(1),0)
SET PRCHCV=+$PIECE(^PRC(442,DA(1),1),U,1)
SET PRCHCI=+$PIECE(^(2,DA,0),U,5)
SET PRCHCPO=DA(1)
DO EN9^PRCHCRD1
+3 QUIT
+4 ;
+5 ; ER-ER3 ARE CALLED FROM PRCHNPO1
ER WRITE !," ** Error in Discount ",PRCH,", item ",PRCHN," has a unit cost of zero ",$CHAR(7)
SET PRCHER=""
+1 QUIT
+2 ;
ER1 WRITE !," ** Error in Discount ",PRCH,", item ",PRCHN," has been changed. Discount will be deleted",!?4,"and must be re-edited!",$CHAR(7)
SET PRCHER=""
SET DR="14///^S X=PRCH"
SET DR(2,442.03)=".01///@"
DO ^DIE
KILL DR
+1 QUIT
+2 ;
ER2 WRITE !," Type Code is undefined.",$CHAR(7)
KILL PRCHPO
+1 QUIT
+2 ;
ER3 WRITE !,$SELECT('PRCHDT:"Breakout Code is undefined.",1:"Socioeconomic Group (FY89) not defined in Vendor file."),$CHAR(7)
KILL PRCHPO
+1 QUIT
+2 ;
SPRMK ;FORMAT & DISPLAY REMARKS FROM REQUEST TO PO
+1 if '$DATA(^PRCS(410,PRCHSY,"RM"))
QUIT
KILL ^UTILITY($JOB,"W")
+2 WRITE !,"2237 Special Remarks: "
SET U="^"
SET PRCHZZ=0
SET DIWL=1
SET DIWR=78
SET DIWF="W"
+3 FOR PRCHJJ=0:0
SET PRCHZZ=$ORDER(^PRCS(410,PRCHSY,"RM",PRCHZZ))
if 'PRCHZZ
QUIT
IF $DATA(^(PRCHZZ,0))
SET X=^(0)
DO DIWP^PRCUTL($GET(DA))
DO ^DIWW
+4 ;
SP1 KILL PRCHJJ
WRITE !,"Would you like to transfer the Special Remarks to the New P.O. Comments"
SET %=1
DO YN^DICN
+1 IF %=0
WRITE !,"Enter 'Y' to have the Special Remarks added to the end of the P.O. Comments.",!
GOTO SP1
+2 if %'=1
GOTO END
if '$DATA(^PRC(442,D0,4,0))
SET ^(0)="^^0^0^"_DT
SET PRCHNN=$PIECE(^(0),U,3)
SET PRCHX=0
+3 FOR I=0:0
SET PRCHX=$ORDER(^PRCS(410,PRCHSY,"RM",PRCHX))
if 'PRCHX
QUIT
IF $DATA(^(PRCHX,0))
SET PRCHNN=PRCHNN+1
SET ^PRC(442,D0,4,PRCHNN,0)=^(0)
+4 SET ^PRC(442,D0,4,0)="^^"_PRCHNN_U_PRCHNN_U_DT
+5 ;
END KILL PRCHNN,PRCHX,PRCHZZ,DIWL,DIWR,DISF,I,%
+1 QUIT
