PRCHUTL ;SF/TKW/ID/RSD-UTILITY ROUTINES FOR SUPPLY SYSTEM ; 5/10/99 10:58am
;;5.1;IFCAP;**15**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN2 ;CALLED FROM FILE 441 FIELD .01, INPUT X="NEW", OUTPUT X=NEXT INTERNAL NUMBER
S PRCHU=$P(^PRC(441,0),U,3) F I=1:1 S PRCHU=PRCHU+1 I '$D(^PRC(441,PRCHU)) L ^PRC(441,PRCHU) I S (X,DIX)=PRCHU K PRCHU Q
Q
;
ENPO ;ENTER NEW PO IN FILE 442
K PRCHPO,PRCHNEW,DA,DIC,DLAYGO,L Q:'$D(PRC("SITE"))
I '$D(DT) S X="T" D ^%DT S DT=Y
W !!,"ENTER A NEW "_$S($G(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER NUMBER OR A COMMON NUMBERING SERIES"
W !?3,$S($G(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER: " R X:DTIME
G:X=""!(X=U) ENPOQ
D:'$D(DIC("S"))
. S DIC="^PRC(442.6,",DIC(0)="QEMZ"
. I $G(PRCHPC) S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=6"
. E I $G(PRCHDELV) S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=7"
. E S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6))"
I $L(X)<4!($E(X,1)="?") S D="C" D IX^DIC G ENPO:Y<0,NUM:$L(X)<4
I '$O(^PRC(442.6,"B",PRC("SITE")_"-"_$E(X,1,2),0)) W " ??? Not part of an existing Common Numbering Series." G ENPO
I $E(X,1,2)["B" W $C(7),!! W "'B' numbers are normally used for Acquisitions from Federal Sources." S %A=" ARE YOU SURE ",%B="This number should only be used for Federal Source Acquisitions",%=2 D ^PRCFYN G:%=-1 ENPOQ G:%'=1 ENPO
S X=PRC("SITE")_"-"_X I $D(^PRC(442,"B",X)) W !?3,"P.O. ",X," already exist, use edit option to modify." G ENPO
;
ENPO1 K DIC("S") S PRCHNEW="",DIC="^PRC(442,",DLAYGO=442,DIC(0)="L" D ^DIC L G ENPO:Y<0,W3:'+$P(Y,U,3)
S (DA,PRCHPO)=+Y,%DT="T",X="NOW" D ^%DT S $P(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
S (X,Y)=1,DA=PRCHPO D UPD^PRCHSTAT
S $P(^PRC(442,PRCHPO,1),U,10)=DUZ
D DOCID
G ENPOQ
;
NUM L ^PRC(442.6,+Y,0):1 G:'$T W1 S X=$P(Y,U,2),Z=$S(+$P(Y(0),U,4)<$P(Y(0),U,2):+$P(Y(0),U,2),1:+$P(Y(0),U,4)),L=$L(X)#2-3
;
Z G:Z>$P(Y(0),U,3) W2 S Z="000"_Z,Z=$E(Z,$L(Z)+L,$L(Z)),X=X_Z I $D(^PRC(442,"B",X)) S Z=Z+1,X=$P(Y,U,2) G Z
W $C(7) S %A=" Are you adding '"_X_"' as a new Purchase Order number ",%B="",%="" D ^PRCFYN I %'=1 L G ENPO
S $P(^PRC(442.6,+Y,0),U,4)=+Z
G ENPO1
;
DOCID S Z=$P($P(^PRC(442,PRCHPO,0),U,1),"-",2) Q:$L(Z)'=6 F I=1:1:6 S X=$E(Z,I,I) Q:+X=X
I +X=X S $P(^PRC(442,PRCHPO,18),"^",3)=$S(I=1:$E(Z,2,6),1:$E(Z,1,I-1)_$E(Z,I+1,6))
Q
;
W1 L W !?3," Common numbering series is being edited by another user, try later",$C(7)
G ENPO
;
W2 L W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(Y,U,2),$C(7)
G ENPO
;
W3 W " Purchase Order number already exist, please try again ",$C(7)
G ENPO
;
ENPOQ K DIC,DLAYGO,%DT,PRCHNEW,L
Q
;several old linetags that encoded/decoded esigs were removed from here
;
WORD ; PRCH=GLOBAL,WX=LINE TO INSERT
I '$D(@(PRCH_"0)")) S @(PRCH_"0)")="^^0^0^"_DT
S WI=0 F WJ=1:1 S WI=$O(@(PRCH_WI_")")) Q:'WI I $D(^(WI,0)) S WY=^(0),^(0)=WX,WX=WY
S $P(@(PRCH_"0)"),U,3,4)=WJ_U_WJ,^(WJ,0)=WX K WI,WJ,WX,WY
Q
;
SWITCH N X K PRCHLOG,PRCHISMS S X=$$ISMSFLAG^PRCPUX2(PRC("SITE")) S:X#2 PRCHLOG="" S:X\2 PRCHISMS="",PRCHTYP="I"
Q
;
EDISTAT(D0,D1,LINECNT) ;DISPLAY P.O.'S EDI STATUS & QUANTITY
;REQUIRES INTERNAL RECORD NUMBER AS D0
; INTERNAL SUBRECORD NUMBER AS D1
; RETURNS THE NUMBER OF LINES PRINTED AS LINECNT
;NOTE: THE NAKED REFERENCE WILL BE ^DD(442.01,12 or 13,0) WHEN
; THIS MODULE FINISHES.
N X,Y,C
S:'$D(LINECNT) LINECNT=0
I $D(^PRC(442,D0,2,D1,2)) S X=$P(^(2),"^",9,12) D
.I $P(X,"^",1)=""&($P(X,"^",3)="") Q
.W !," E D I S T A T U S : ",?26
.I $P(X,"^",1)]"" S Y=$P(X,"^",1),C=$P(^DD(442.01,12,0),"^",2) D Y^DIQ W "#1: ",Y," QTY: ",$P(X,"^",2),!,?26 S LINECNT=LINECNT+1
.I $P(X,"^",3)]"" S Y=$P(X,"^",3),C=$P(^DD(442.01,13,0),"^",2) D Y^DIQ W "#2: ",Y," QTY: ",$P(X,"^",4) S LINECNT=LINECNT+1
.W ! S LINECNT=LINECNT+1
.Q
Q
;
;
;
VEN(A) ; Entry point to get FMS Vendor ID_ Alt.Address Indicator from the vendor file. -- Used by AR (Only)
; A = internal entry number to vendor file (#440)
;
N T S T=$G(^PRC(440,+A,3))
I $L($P(T,U,4))'=9 Q ""
Q $P(T,U,4)_$P(T,U,5)
;
VENSEL() ; VENSEL = VENdor SELection
; EXTRINSIC FUNCTION THAT ALLOWS A USER TO SELECT AN IFCAP VENDOR.
; THIS FUNCTION WILL BE USED BY ACCOUNTS RECEIVABLE USERS.
;
; THIS EXTRINSIC FUNCTION WILL RETURN A STRING.
; CONDITION STRING VALUE ^DIC VALUE
; LOOKUP FAILED -1 Y=-1
; TIMED-OUT -2 DTOUT
; UP-ARROW -3 DUOUT
; SUCCESSFUL DA^.01 FIELD Y=N^S
; SUCCESSFUL & NEW DA^.01 FIELD^1 Y=N^S^1
;
; THE DEFINITIONS OF THE ^DIC VALUEs MAY BE FOUND IN VA FileMan
; V.21.0 Programmer Manual ON PAGES 56-57. THIS IS THE RETURNED
; STRING OF THIS FUNCTION.
;
; FIRST, ASK THE USER FOR THEIR "SITE".
;
S PRCF("X")="S"
D ^PRCFSITE
;
; NOW THAT WE HAVE THE SITE, CONTINUE ON.
;
S DIC="^PRC(440,"
S DIC(0)="AEMO"
S DIC("A")="Select the DEBTOR from the VENDOR list: "
K DTOUT,DUOUT
D ^DIC
S:$D(DTOUT) Y=-2
S:$D(DUOUT) Y=-3
K DIC,DTOUT,DUOUT
S PRCOY=Y
I +PRCOY<0 Q PRCOY
;
; NOW LETS SEE IF THIS VENDOR RECORD IS PROPERLY SET UP.
;
S DA=+Y
K ^PRC(440.3,DA)
S %X="^PRC(440,DA,"
S %Y="^PRC(440.3,DA,"
D %XY^%RCR
S FLAG=1
S FISCAL=$G(^PRC(411,PRC("SITE"),9))
S FISCAL=$P(FISCAL,U,3)
S SAVE=$$CHECK^PRCOVTST(DA,PRC("SITE"),FLAG)
I FISCAL="Y",SAVE=0 D
. S DIE="^PRC(440.3,"
. S DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
. D ^DIE
. Q
I FISCAL'="Y",SAVE=0 S PRCZDA=DA D VRQ^PRCOVTST(DA,PRC("SITE")) S DA=PRCZDA K PRCZDA
I SAVE=1 D
. S AR=449
. S DIE="^PRC(440.3,"
. S DR="50///^S X=FLAG;51///^S X=DA;52///^S X=PRC(""SITE"")"
. D ^DIE
. K AR
. Q
Q PRCOY
;
AF ; CALLED BY "AF" X-REF IN FIELD 52 (SITE AR) IN FILE 440.3.
N PRCX,DIC,DLAYGO,Y
Q:$G(AR)'=449
S PRCX=$O(^PRCF(422.2,"B","AR-EDIT-01",0)) D:PRCX=""
. ; NEED TO SET UP ENTRY IN COUNTER FILE.
. K DD,DO
. S DIC="^PRCF(422.2,"
. S DIC(0)="L"
. S X="AR-EDIT-01"
. S DELAYGO=422.2
. D FILE^DICN
. S PRCX=+Y
. Q
S $P(^PRCF(422.2,PRCX,0),U,2)=+$P(^PRCF(422.2,PRCX,0),U,2)+1
Q
;
VENEDITF ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
; BEFORE THEY CAN BE ENTERED INTO A VRQ.
;
; SEE IF FISCAL CAN ADD A VENDOR. IF SO, TELL THE USER THERE
; RECORDS TO EDIT.
;
N COUNT,STN411,SHOWIT
Q:'$D(DUZ) ; YOU ARE UNDEFINED.
;
; SEE IF FISCAL CAN ADD VENDORS.
;
D FIND
Q:STN411'=1
;
S SHOWIT=0
;
; I STN411=1 THEN FISCAL CAN ADD VENDORS.
; SEE IF THE USER IS A FISCAL USER.
;
I $D(^XUSEC("PRCFA VENDOR EDIT",DUZ))=1 S SHOWIT=1
Q:SHOWIT'=1
G COUNT
;
VENEDITS ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
; BEFORE THEY CAN BE ENTERED INTO A VRQ.
;
; SEE IF FISCAL CAN ADD A VENDOR. IF NOT, HAVE SUPPLY EDIT THE
; VENDOR RECORDS.
;
N COUNT,STN411,SHOWIT
Q:'$D(DUZ) ; YOU ARE UNDEFINED.
;
; SEE IF FISCAL CAN ADD VENDORS.
;
D FIND
Q:STN411=1
;
S SHOWIT=0
;
; SEE IF THE USER IS A PURCHASING AGENT OR A MANAGER.
;
I +$P($G(^VA(200,DUZ,400)),U)>2 S SHOWIT=1
Q:SHOWIT'=1
;
COUNT ; NOW SHOW MESSAGE, IF ANY
;
S COUNT=$O(^PRCF(422.2,"B","AR-EDIT-01",0)) Q:COUNT'>0
S COUNT=$P($G(^PRCF(422.2,COUNT,0)),U,2) Q:COUNT'>0
W !!,"There are Vendor Records that AR is using to be edited."
Q
;
FIND ; SEE IF FISCAL CAN ADD A VENDOR.
;
N STATION,STNIEN
S STATION=0
S STN411=""
F S STATION=$O(^PRC(411,"B",STATION)) Q:STATION']"" D Q:STN411=1
. S STNIEN=$O(^PRC(411,"B",STATION,0)) Q:STNIEN'>0
. S STN411=$P($G(^PRC(411,STNIEN,0)),U,20)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHUTL 8001 printed Dec 13, 2024@02:11:26 Page 2
PRCHUTL ;SF/TKW/ID/RSD-UTILITY ROUTINES FOR SUPPLY SYSTEM ; 5/10/99 10:58am
+1 ;;5.1;IFCAP;**15**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN2 ;CALLED FROM FILE 441 FIELD .01, INPUT X="NEW", OUTPUT X=NEXT INTERNAL NUMBER
+1 SET PRCHU=$PIECE(^PRC(441,0),U,3)
FOR I=1:1
SET PRCHU=PRCHU+1
IF '$DATA(^PRC(441,PRCHU))
LOCK ^PRC(441,PRCHU)
IF $TEST
SET (X,DIX)=PRCHU
KILL PRCHU
QUIT
+2 QUIT
+3 ;
ENPO ;ENTER NEW PO IN FILE 442
+1 KILL PRCHPO,PRCHNEW,DA,DIC,DLAYGO,L
if '$DATA(PRC("SITE"))
QUIT
+2 IF '$DATA(DT)
SET X="T"
DO ^%DT
SET DT=Y
+3 WRITE !!,"ENTER A NEW "_$SELECT($GET(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER NUMBER OR A COMMON NUMBERING SERIES"
+4 WRITE !?3,$SELECT($GET(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER: "
READ X:DTIME
+5 if X=""!(X=U)
GOTO ENPOQ
+6 if '$DATA(DIC("S"))
Begin DoDot:1
+7 SET DIC="^PRC(442.6,"
SET DIC(0)="QEMZ"
+8 IF $GET(PRCHPC)
SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=6"
+9 IF '$TEST
IF $GET(PRCHDELV)
SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=7"
+10 IF '$TEST
SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6))"
End DoDot:1
+11 IF $LENGTH(X)<4!($EXTRACT(X,1)="?")
SET D="C"
DO IX^DIC
if Y<0
GOTO ENPO
if $LENGTH(X)<4
GOTO NUM
+12 IF '$ORDER(^PRC(442.6,"B",PRC("SITE")_"-"_$EXTRACT(X,1,2),0))
WRITE " ??? Not part of an existing Common Numbering Series."
GOTO ENPO
+13 IF $EXTRACT(X,1,2)["B"
WRITE $CHAR(7),!!
WRITE "'B' numbers are normally used for Acquisitions from Federal Sources."
SET %A=" ARE YOU SURE "
SET %B="This number should only be used for Federal Source Acquisitions"
SET %=2
DO ^PRCFYN
if %=-1
GOTO ENPOQ
if %'=1
GOTO ENPO
+14 SET X=PRC("SITE")_"-"_X
IF $DATA(^PRC(442,"B",X))
WRITE !?3,"P.O. ",X," already exist, use edit option to modify."
GOTO ENPO
+15 ;
ENPO1 KILL DIC("S")
SET PRCHNEW=""
SET DIC="^PRC(442,"
SET DLAYGO=442
SET DIC(0)="L"
DO ^DIC
LOCK
if Y<0
GOTO ENPO
if '+$PIECE(Y,U,3)
GOTO W3
+1 SET (DA,PRCHPO)=+Y
SET %DT="T"
SET X="NOW"
DO ^%DT
SET $PIECE(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
+2 SET (X,Y)=1
SET DA=PRCHPO
DO UPD^PRCHSTAT
+3 SET $PIECE(^PRC(442,PRCHPO,1),U,10)=DUZ
+4 DO DOCID
+5 GOTO ENPOQ
+6 ;
NUM LOCK ^PRC(442.6,+Y,0):1
if '$TEST
GOTO W1
SET X=$PIECE(Y,U,2)
SET Z=$SELECT(+$PIECE(Y(0),U,4)<$PIECE(Y(0),U,2):+$PIECE(Y(0),U,2),1:+$PIECE(Y(0),U,4))
SET L=$LENGTH(X)#2-3
+1 ;
Z if Z>$PIECE(Y(0),U,3)
GOTO W2
SET Z="000"_Z
SET Z=$EXTRACT(Z,$LENGTH(Z)+L,$LENGTH(Z))
SET X=X_Z
IF $DATA(^PRC(442,"B",X))
SET Z=Z+1
SET X=$PIECE(Y,U,2)
GOTO Z
+1 WRITE $CHAR(7)
SET %A=" Are you adding '"_X_"' as a new Purchase Order number "
SET %B=""
SET %=""
DO ^PRCFYN
IF %'=1
LOCK
GOTO ENPO
+2 SET $PIECE(^PRC(442.6,+Y,0),U,4)=+Z
+3 GOTO ENPO1
+4 ;
DOCID SET Z=$PIECE($PIECE(^PRC(442,PRCHPO,0),U,1),"-",2)
if $LENGTH(Z)'=6
QUIT
FOR I=1:1:6
SET X=$EXTRACT(Z,I,I)
if +X=X
QUIT
+1 IF +X=X
SET $PIECE(^PRC(442,PRCHPO,18),"^",3)=$SELECT(I=1:$EXTRACT(Z,2,6),1:$EXTRACT(Z,1,I-1)_$EXTRACT(Z,I+1,6))
+2 QUIT
+3 ;
W1 LOCK
WRITE !?3," Common numbering series is being edited by another user, try later",$CHAR(7)
+1 GOTO ENPO
+2 ;
W2 LOCK
WRITE !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$PIECE(Y,U,2),$CHAR(7)
+1 GOTO ENPO
+2 ;
W3 WRITE " Purchase Order number already exist, please try again ",$CHAR(7)
+1 GOTO ENPO
+2 ;
ENPOQ KILL DIC,DLAYGO,%DT,PRCHNEW,L
+1 QUIT
+2 ;several old linetags that encoded/decoded esigs were removed from here
+3 ;
WORD ; PRCH=GLOBAL,WX=LINE TO INSERT
+1 IF '$DATA(@(PRCH_"0)"))
SET @(PRCH_"0)")="^^0^0^"_DT
+2 SET WI=0
FOR WJ=1:1
SET WI=$ORDER(@(PRCH_WI_")"))
if 'WI
QUIT
IF $DATA(^(WI,0))
SET WY=^(0)
SET ^(0)=WX
SET WX=WY
+3 SET $PIECE(@(PRCH_"0)"),U,3,4)=WJ_U_WJ
SET ^(WJ,0)=WX
KILL WI,WJ,WX,WY
+4 QUIT
+5 ;
SWITCH NEW X
KILL PRCHLOG,PRCHISMS
SET X=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
if X#2
SET PRCHLOG=""
if X\2
SET PRCHISMS=""
SET PRCHTYP="I"
+1 QUIT
+2 ;
EDISTAT(D0,D1,LINECNT) ;DISPLAY P.O.'S EDI STATUS & QUANTITY
+1 ;REQUIRES INTERNAL RECORD NUMBER AS D0
+2 ; INTERNAL SUBRECORD NUMBER AS D1
+3 ; RETURNS THE NUMBER OF LINES PRINTED AS LINECNT
+4 ;NOTE: THE NAKED REFERENCE WILL BE ^DD(442.01,12 or 13,0) WHEN
+5 ; THIS MODULE FINISHES.
+6 NEW X,Y,C
+7 if '$DATA(LINECNT)
SET LINECNT=0
+8 IF $DATA(^PRC(442,D0,2,D1,2))
SET X=$PIECE(^(2),"^",9,12)
Begin DoDot:1
+9 IF $PIECE(X,"^",1)=""&($PIECE(X,"^",3)="")
QUIT
+10 WRITE !," E D I S T A T U S : ",?26
+11 IF $PIECE(X,"^",1)]""
SET Y=$PIECE(X,"^",1)
SET C=$PIECE(^DD(442.01,12,0),"^",2)
DO Y^DIQ
WRITE "#1: ",Y," QTY: ",$PIECE(X,"^",2),!,?26
SET LINECNT=LINECNT+1
+12 IF $PIECE(X,"^",3)]""
SET Y=$PIECE(X,"^",3)
SET C=$PIECE(^DD(442.01,13,0),"^",2)
DO Y^DIQ
WRITE "#2: ",Y," QTY: ",$PIECE(X,"^",4)
SET LINECNT=LINECNT+1
+13 WRITE !
SET LINECNT=LINECNT+1
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
+17 ;
+18 ;
VEN(A) ; Entry point to get FMS Vendor ID_ Alt.Address Indicator from the vendor file. -- Used by AR (Only)
+1 ; A = internal entry number to vendor file (#440)
+2 ;
+3 NEW T
SET T=$GET(^PRC(440,+A,3))
+4 IF $LENGTH($PIECE(T,U,4))'=9
QUIT ""
+5 QUIT $PIECE(T,U,4)_$PIECE(T,U,5)
+6 ;
VENSEL() ; VENSEL = VENdor SELection
+1 ; EXTRINSIC FUNCTION THAT ALLOWS A USER TO SELECT AN IFCAP VENDOR.
+2 ; THIS FUNCTION WILL BE USED BY ACCOUNTS RECEIVABLE USERS.
+3 ;
+4 ; THIS EXTRINSIC FUNCTION WILL RETURN A STRING.
+5 ; CONDITION STRING VALUE ^DIC VALUE
+6 ; LOOKUP FAILED -1 Y=-1
+7 ; TIMED-OUT -2 DTOUT
+8 ; UP-ARROW -3 DUOUT
+9 ; SUCCESSFUL DA^.01 FIELD Y=N^S
+10 ; SUCCESSFUL & NEW DA^.01 FIELD^1 Y=N^S^1
+11 ;
+12 ; THE DEFINITIONS OF THE ^DIC VALUEs MAY BE FOUND IN VA FileMan
+13 ; V.21.0 Programmer Manual ON PAGES 56-57. THIS IS THE RETURNED
+14 ; STRING OF THIS FUNCTION.
+15 ;
+16 ; FIRST, ASK THE USER FOR THEIR "SITE".
+17 ;
+18 SET PRCF("X")="S"
+19 DO ^PRCFSITE
+20 ;
+21 ; NOW THAT WE HAVE THE SITE, CONTINUE ON.
+22 ;
+23 SET DIC="^PRC(440,"
+24 SET DIC(0)="AEMO"
+25 SET DIC("A")="Select the DEBTOR from the VENDOR list: "
+26 KILL DTOUT,DUOUT
+27 DO ^DIC
+28 if $DATA(DTOUT)
SET Y=-2
+29 if $DATA(DUOUT)
SET Y=-3
+30 KILL DIC,DTOUT,DUOUT
+31 SET PRCOY=Y
+32 IF +PRCOY<0
QUIT PRCOY
+33 ;
+34 ; NOW LETS SEE IF THIS VENDOR RECORD IS PROPERLY SET UP.
+35 ;
+36 SET DA=+Y
+37 KILL ^PRC(440.3,DA)
+38 SET %X="^PRC(440,DA,"
+39 SET %Y="^PRC(440.3,DA,"
+40 DO %XY^%RCR
+41 SET FLAG=1
+42 SET FISCAL=$GET(^PRC(411,PRC("SITE"),9))
+43 SET FISCAL=$PIECE(FISCAL,U,3)
+44 SET SAVE=$$CHECK^PRCOVTST(DA,PRC("SITE"),FLAG)
+45 IF FISCAL="Y"
IF SAVE=0
Begin DoDot:1
+46 SET DIE="^PRC(440.3,"
+47 SET DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
+48 DO ^DIE
+49 QUIT
End DoDot:1
+50 IF FISCAL'="Y"
IF SAVE=0
SET PRCZDA=DA
DO VRQ^PRCOVTST(DA,PRC("SITE"))
SET DA=PRCZDA
KILL PRCZDA
+51 IF SAVE=1
Begin DoDot:1
+52 SET AR=449
+53 SET DIE="^PRC(440.3,"
+54 SET DR="50///^S X=FLAG;51///^S X=DA;52///^S X=PRC(""SITE"")"
+55 DO ^DIE
+56 KILL AR
+57 QUIT
End DoDot:1
+58 QUIT PRCOY
+59 ;
AF ; CALLED BY "AF" X-REF IN FIELD 52 (SITE AR) IN FILE 440.3.
+1 NEW PRCX,DIC,DLAYGO,Y
+2 if $GET(AR)'=449
QUIT
+3 SET PRCX=$ORDER(^PRCF(422.2,"B","AR-EDIT-01",0))
if PRCX=""
Begin DoDot:1
+4 ; NEED TO SET UP ENTRY IN COUNTER FILE.
+5 KILL DD,DO
+6 SET DIC="^PRCF(422.2,"
+7 SET DIC(0)="L"
+8 SET X="AR-EDIT-01"
+9 SET DELAYGO=422.2
+10 DO FILE^DICN
+11 SET PRCX=+Y
+12 QUIT
End DoDot:1
+13 SET $PIECE(^PRCF(422.2,PRCX,0),U,2)=+$PIECE(^PRCF(422.2,PRCX,0),U,2)+1
+14 QUIT
+15 ;
VENEDITF ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
+1 ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
+2 ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
+3 ;
+4 ; SEE IF FISCAL CAN ADD A VENDOR. IF SO, TELL THE USER THERE
+5 ; RECORDS TO EDIT.
+6 ;
+7 NEW COUNT,STN411,SHOWIT
+8 ; YOU ARE UNDEFINED.
if '$DATA(DUZ)
QUIT
+9 ;
+10 ; SEE IF FISCAL CAN ADD VENDORS.
+11 ;
+12 DO FIND
+13 if STN411'=1
QUIT
+14 ;
+15 SET SHOWIT=0
+16 ;
+17 ; I STN411=1 THEN FISCAL CAN ADD VENDORS.
+18 ; SEE IF THE USER IS A FISCAL USER.
+19 ;
+20 IF $DATA(^XUSEC("PRCFA VENDOR EDIT",DUZ))=1
SET SHOWIT=1
+21 if SHOWIT'=1
QUIT
+22 GOTO COUNT
+23 ;
VENEDITS ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
+1 ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
+2 ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
+3 ;
+4 ; SEE IF FISCAL CAN ADD A VENDOR. IF NOT, HAVE SUPPLY EDIT THE
+5 ; VENDOR RECORDS.
+6 ;
+7 NEW COUNT,STN411,SHOWIT
+8 ; YOU ARE UNDEFINED.
if '$DATA(DUZ)
QUIT
+9 ;
+10 ; SEE IF FISCAL CAN ADD VENDORS.
+11 ;
+12 DO FIND
+13 if STN411=1
QUIT
+14 ;
+15 SET SHOWIT=0
+16 ;
+17 ; SEE IF THE USER IS A PURCHASING AGENT OR A MANAGER.
+18 ;
+19 IF +$PIECE($GET(^VA(200,DUZ,400)),U)>2
SET SHOWIT=1
+20 if SHOWIT'=1
QUIT
+21 ;
COUNT ; NOW SHOW MESSAGE, IF ANY
+1 ;
+2 SET COUNT=$ORDER(^PRCF(422.2,"B","AR-EDIT-01",0))
if COUNT'>0
QUIT
+3 SET COUNT=$PIECE($GET(^PRCF(422.2,COUNT,0)),U,2)
if COUNT'>0
QUIT
+4 WRITE !!,"There are Vendor Records that AR is using to be edited."
+5 QUIT
+6 ;
FIND ; SEE IF FISCAL CAN ADD A VENDOR.
+1 ;
+2 NEW STATION,STNIEN
+3 SET STATION=0
+4 SET STN411=""
+5 FOR
SET STATION=$ORDER(^PRC(411,"B",STATION))
if STATION']""
QUIT
Begin DoDot:1
+6 SET STNIEN=$ORDER(^PRC(411,"B",STATION,0))
if STNIEN'>0
QUIT
+7 SET STN411=$PIECE($GET(^PRC(411,STNIEN,0)),U,20)
+8 QUIT
End DoDot:1
if STN411=1
QUIT
+9 QUIT
