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