PRCHID ;WISC/DJM/BGJ-VENDOR IDENTIFIER DATA ;2/1/22 13:32
V ;;5.1;IFCAP;**7,227**;Oct 20, 2000;Build 1
;Per VHA Directive 6402, this routine should not be modified.
START ;DISPLAY IDENTIFYING DATA FROM RECORD IN FILE 440
N LN0,LN2,LN3,LN7,LN9,LN10,PHONE,PH,A,T,T1,NO,ADDR1,FMS,CITY,STATE
N ZIP,ADDR2,CODE,FAX,FX,RV,IVCK,PRCFD,BTMSG,RVX,IEN,LOOP,NAME,PRCFLAG
;
; FIND OUT WHAT OPTION USER IS IN NOW. IF OPTION BEGINS WITH 'PRCF'
; RECORD FACT THAT OPTION IS A 'FISCAL' OPTION.
;
D OP^XQCHK
I XQOPT'=-1,($E(XQOPT,1,4)="PRCF") S PRCFD("PAY")=1
;
;GET CURRENT RECORD NODES NEEDED TO DISPLAY IDENTIFIERS
;
S IEN=+Y
S LN0=$G(^PRC(440,IEN,0))
S LN2=$G(^PRC(440,IEN,2))
S LN3=$G(^PRC(440,IEN,3))
S LN7=$G(^PRC(440,IEN,7))
S LN9=$G(^PRC(440,IEN,9))
S LN10=$G(^PRC(440,IEN,10))
S PRCFLAG=""
;
;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
;IS INACTIVATED.
;
I $P(LN10,U,5)=1 G IEN
;
;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
;IS NOT INACTIVATED.
;
D:$P(LN3,U,16)'="" EN^DDIOL("UEI:"_$P(LN3,U,16),"","?33")
I $P(LN3,U,2)="Y" D EN^DDIOL("EDI","","?50")
S PHONE="PH:"
S PH=$P(LN0,U,10)
D PHONE
S PHONE=PHONE_PH
D EN^DDIOL(PHONE,"","?55")
;
;COME HERE TO DISPLAY THE RECORD'S INTERNAL ENTRY NUMBER
;
IEN S NO=" "_IEN
S NO="NO:"_$E(NO,$L(NO)-5,99)
D EN^DDIOL(NO,"","?71")
;
;NOW DISPLAY ORDERING ADDRESS DATA IN IDENTIFIERS
;
I '$D(PRCFD("PAY")) D
. ;
. ;FIRST ORDERING ADDRESS LINE
. ;
. S ADDR1="ORD ADD:"_$P(LN0,U,2)
. D EN^DDIOL(ADDR1,"","!")
. S FMS="FMS:"_$P(LN3,U,7)
. D EN^DDIOL(FMS,"","?46")
. ;
. ;SECOND ORDERING ADDRESS LINE
. ;
. S CITY=$P(LN0,U,6)
. S STATE=$P(LN0,U,7)
. I STATE>0 D
. . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
. S ZIP=$P(LN0,U,8)
. I ZIP?9N S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
. S ADDR2=""
. I CITY]"",STATE]"" S ADDR2=ADDR2_CITY_", "_STATE
. I CITY="",STATE]"" S ADDR2=ADDR2_STATE
. I CITY]"",STATE="" S ADDR2=ADDR2_CITY
. S:ADDR2]"" ADDR2=ADDR2_" "_ZIP
. S:ADDR2="" ADDR2=ADDR2_ZIP
. D EN^DDIOL(ADDR2,"","!?8")
. S CODE="CODE:"_$P(LN3,U,4)_$P(LN3,U,5)
. D EN^DDIOL(CODE,"","?46")
. S FAX="FAX:"
. K PH
. S PH=$P(LN10,U,6)
. D PHONE
. S FAX=FAX_PH
. D EN^DDIOL(FAX,"","?64")
;
;END OF ORDERING ADDRESS LINES
;
;SHOW PAYMENT ADDRESS LINES
;
I $D(PRCFD("PAY")) D
. ;
. ;FIRST PAYMENT ADDRESS LINE
. ;
. S ADDR1="PAY ADD:"_$P(LN7,U,3)
. D EN^DDIOL(ADDR1,"","!")
. S FMS="FMS:"_$P(LN3,U,7)
. D EN^DDIOL(FMS,"","?46")
. ;
. ;SECOND PAYMENT ADDRESS LINE
. ;
. S CITY=$P(LN7,U,7)
. S STATE=$P(LN7,U,8)
. I STATE>0 D
. . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
. S ZIP=$P(LN7,U,9)
. I ZIP?9N S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
. S ADDR2=""
. I CITY]"",STATE]"" S ADDR2=ADDR2_CITY_", "_STATE
. I CITY="",STATE]"" S ADDR2=ADDR2_STATE
. I CITY]"",STATE="" S ADDR2=ADDR2_CITY
. S:ADDR2]"" ADDR2=ADDR2_" "_ZIP
. S:ADDR2="" ADDR2=ADDR2_ZIP
. D EN^DDIOL(ADDR2,"","!?8")
. S CODE="CODE:"_$P(LN3,U,4)_$P(LN3,U,5)
. D EN^DDIOL(CODE,"","?46")
. S FAX="FAX:"
. K PH
. S PH=$P(LN10,U,6)
. D PHONE
. S FAX=FAX_PH
. D EN^DDIOL(FAX,"","?64")
. Q
;
;END OF PAYMENT ADDRESS LINES
;
;LETS INFORM USER IF THIS VENDOR IS INACTIVATED
;
D EN^DDIOL("","","!")
I $P(LN10,U,5)=1 D
. D EN^DDIOL("****THIS VENDOR IS INACTIVE","","?0")
. ;
. ;NOW SEE IF WE CAN FIND A SUBSTITUTE VENDOR
. ;
. ;RV = REPLACEMENT VENDOR INTERNAL ENTRY NUMBER
. ;IVCK = INACTIVATED VENDOR CHECK
. ;
. S LOOP=""
. S RV=+LN9
. I RV=0&($E(LN0,1,2)["**") D
. . D EN^DDIOL(", NO REPLACEMENT VENDOR *****","","?27")
. . S PRCFLAG=1 W !,?5," PLEASE CHOOSE ANOTHER VENDOR " Q
. ;
. ;STOP IF A REPLACEMENT VENDOR POINTS TO ITSELF
. ;
. I RV=IEN S RV=0
. F Q:RV=0 S IVCK=$P($G(^PRC(440,RV,10)),U,5) Q:IVCK="" D Q:LOOP=1
. . S RVX=+$G(^PRC(440,RV,9))
. . I RVX'>0 S LOOP=1 Q
. . I RV=RVX S LOOP=1 Q
. . S RV=RVX
. . I RV=0!(LOOP=1) D EN^DDIOL("****","","?27") Q
. I RV>0 D
. . S RVX=RV
. . S RV=" "_RV
. . S RV=$E(RV,$L(RV)-5,99)
. . D EN^DDIOL(", USE VENDOR NO:"_RV_"****","","?27")
. . S PRCFLAG=1,LN0=$G(^PRC(440,RVX,0)),NAME=$P(LN0,U,1)
. . W !,?5," VENDOR NAME "_NAME Q
. ;
. Q
;
;ONLY IF VENDER IS ACTIVE & THIS VENDOR LOOKUP IS NOT COMING FROM
;A FISCAL OPTION DISPLAY 'BUSINESS TYPE' SETUP
;
I $P(LN10,U,5)="",'$D(PRCFD("PAY")) D
. D SETBTMSG
. I $P(LN0,U,11)]"" Q
. I LN2="" D EN^DDIOL(.BTMSG) Q
. I $P(LN2,U,2)]"" Q
. I $P(LN2,U,3)']"" D EN^DDIOL(.BTMSG) Q
;
;IF VENDOR IS INACTIVE DISPLAY 'EDI VENDOR'
;
I $P(LN10,U,5)=1 D
. I $P(LN3,U,2)="Y" D EN^DDIOL("EDI VENDOR","","?56") Q
EXIT Q
;
PHONE ; PHONE/FAX FORMATTING
;
S PH=$TR(PH,"abcdefghijklmnoprstuvwxy","222333444555666777888999")
S PH=$TR(PH,"ABCDEFGHIJKLMNOPRSTUVWXY","222333444555666777888999")
I PH]"" D
. I PH'?.N D Q
. . S A=1
. . F S T=$E(PH,1) D:T?1N S:T'?1N PH=$E(PH,2,99) Q:PH=""
. . . S PH(A)=""
. . . F S T1=$E(PH,1) Q:T1'?1N S PH(A)=PH(A)_T1,PH=$E(PH,2,99) Q:PH=""
. . . Q:PH=""
. . . S A=A+1
. . . Q
. . I $G(PH(1))="011" S PH="INTERN'L" Q
. . I $L($G(PH(1)))=1,$L($G(PH(2)))=3,$L($G(PH(3)))=3,$L($G(PH(4)))=4 S PH=PH(2)_"-"_PH(3)_"-"_PH(4) Q
. . I $L($G(PH(1)))=3,$L($G(PH(2)))=3,$L($G(PH(3)))=4 S PH=PH(1)_" "_PH(2)_"-"_PH(3) Q
. . I $L($G(PH(1)))=3,$L($G(PH(2)))=4 S PH=" "_PH(1)_"-"_PH(2) Q
. . Q
. I $L(PH)>9 S PH=$E(PH,1,3)_" "_$E(PH,4,6)_"-"_$E(PH,7,10) Q
. I $L(PH)>6 S PH=" "_$E(PH,1,3)_"-"_$E(PH,4,7) Q
. Q
Q
SETBTMSG ;SET ARRAY TO HOLD VENDOR BUSINESS TYPE FIELD MESSAGE
S BTMSG(1)="*** BUSINESS TYPE UNDEFINED ***"
S BTMSG(1,"F")="$C(7),!"
;
;IF NOT ENTERING A PURCHASE ORDER, DON'T DISPLAY REMAINDER OF MSG
;
I '$D(PRCHPO) S BTMSG(2)="",BTMSG(2,"F")="!" Q
S BTMSG(2)="You will not be able to complete this Purchase Order"
S BTMSG(2,"F")="!"
S BTMSG(3)="with this vendor until the BUSINESS TYPE is defined"
S BTMSG(3,"F")="$C(7),!"
S BTMSG(4)=""
S BTMSG(4,"F")="!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHID 6217 printed Sep 23, 2025@19:44:02 Page 2
PRCHID ;WISC/DJM/BGJ-VENDOR IDENTIFIER DATA ;2/1/22 13:32
V ;;5.1;IFCAP;**7,227**;Oct 20, 2000;Build 1
+1 ;Per VHA Directive 6402, this routine should not be modified.
START ;DISPLAY IDENTIFYING DATA FROM RECORD IN FILE 440
+1 NEW LN0,LN2,LN3,LN7,LN9,LN10,PHONE,PH,A,T,T1,NO,ADDR1,FMS,CITY,STATE
+2 NEW ZIP,ADDR2,CODE,FAX,FX,RV,IVCK,PRCFD,BTMSG,RVX,IEN,LOOP,NAME,PRCFLAG
+3 ;
+4 ; FIND OUT WHAT OPTION USER IS IN NOW. IF OPTION BEGINS WITH 'PRCF'
+5 ; RECORD FACT THAT OPTION IS A 'FISCAL' OPTION.
+6 ;
+7 DO OP^XQCHK
+8 IF XQOPT'=-1
IF ($EXTRACT(XQOPT,1,4)="PRCF")
SET PRCFD("PAY")=1
+9 ;
+10 ;GET CURRENT RECORD NODES NEEDED TO DISPLAY IDENTIFIERS
+11 ;
+12 SET IEN=+Y
+13 SET LN0=$GET(^PRC(440,IEN,0))
+14 SET LN2=$GET(^PRC(440,IEN,2))
+15 SET LN3=$GET(^PRC(440,IEN,3))
+16 SET LN7=$GET(^PRC(440,IEN,7))
+17 SET LN9=$GET(^PRC(440,IEN,9))
+18 SET LN10=$GET(^PRC(440,IEN,10))
+19 SET PRCFLAG=""
+20 ;
+21 ;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
+22 ;IS INACTIVATED.
+23 ;
+24 IF $PIECE(LN10,U,5)=1
GOTO IEN
+25 ;
+26 ;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
+27 ;IS NOT INACTIVATED.
+28 ;
+29 if $PIECE(LN3,U,16)'=""
DO EN^DDIOL("UEI:"_$PIECE(LN3,U,16),"","?33")
+30 IF $PIECE(LN3,U,2)="Y"
DO EN^DDIOL("EDI","","?50")
+31 SET PHONE="PH:"
+32 SET PH=$PIECE(LN0,U,10)
+33 DO PHONE
+34 SET PHONE=PHONE_PH
+35 DO EN^DDIOL(PHONE,"","?55")
+36 ;
+37 ;COME HERE TO DISPLAY THE RECORD'S INTERNAL ENTRY NUMBER
+38 ;
IEN SET NO=" "_IEN
+1 SET NO="NO:"_$EXTRACT(NO,$LENGTH(NO)-5,99)
+2 DO EN^DDIOL(NO,"","?71")
+3 ;
+4 ;NOW DISPLAY ORDERING ADDRESS DATA IN IDENTIFIERS
+5 ;
+6 IF '$DATA(PRCFD("PAY"))
Begin DoDot:1
+7 ;
+8 ;FIRST ORDERING ADDRESS LINE
+9 ;
+10 SET ADDR1="ORD ADD:"_$PIECE(LN0,U,2)
+11 DO EN^DDIOL(ADDR1,"","!")
+12 SET FMS="FMS:"_$PIECE(LN3,U,7)
+13 DO EN^DDIOL(FMS,"","?46")
+14 ;
+15 ;SECOND ORDERING ADDRESS LINE
+16 ;
+17 SET CITY=$PIECE(LN0,U,6)
+18 SET STATE=$PIECE(LN0,U,7)
+19 IF STATE>0
Begin DoDot:2
+20 SET STATE=$PIECE($GET(^DIC(5,STATE,0)),U,2)
End DoDot:2
+21 SET ZIP=$PIECE(LN0,U,8)
+22 IF ZIP?9N
SET ZIP=$EXTRACT(ZIP,1,5)_"-"_$EXTRACT(ZIP,6,9)
+23 SET ADDR2=""
+24 IF CITY]""
IF STATE]""
SET ADDR2=ADDR2_CITY_", "_STATE
+25 IF CITY=""
IF STATE]""
SET ADDR2=ADDR2_STATE
+26 IF CITY]""
IF STATE=""
SET ADDR2=ADDR2_CITY
+27 if ADDR2]""
SET ADDR2=ADDR2_" "_ZIP
+28 if ADDR2=""
SET ADDR2=ADDR2_ZIP
+29 DO EN^DDIOL(ADDR2,"","!?8")
+30 SET CODE="CODE:"_$PIECE(LN3,U,4)_$PIECE(LN3,U,5)
+31 DO EN^DDIOL(CODE,"","?46")
+32 SET FAX="FAX:"
+33 KILL PH
+34 SET PH=$PIECE(LN10,U,6)
+35 DO PHONE
+36 SET FAX=FAX_PH
+37 DO EN^DDIOL(FAX,"","?64")
End DoDot:1
+38 ;
+39 ;END OF ORDERING ADDRESS LINES
+40 ;
+41 ;SHOW PAYMENT ADDRESS LINES
+42 ;
+43 IF $DATA(PRCFD("PAY"))
Begin DoDot:1
+44 ;
+45 ;FIRST PAYMENT ADDRESS LINE
+46 ;
+47 SET ADDR1="PAY ADD:"_$PIECE(LN7,U,3)
+48 DO EN^DDIOL(ADDR1,"","!")
+49 SET FMS="FMS:"_$PIECE(LN3,U,7)
+50 DO EN^DDIOL(FMS,"","?46")
+51 ;
+52 ;SECOND PAYMENT ADDRESS LINE
+53 ;
+54 SET CITY=$PIECE(LN7,U,7)
+55 SET STATE=$PIECE(LN7,U,8)
+56 IF STATE>0
Begin DoDot:2
+57 SET STATE=$PIECE($GET(^DIC(5,STATE,0)),U,2)
End DoDot:2
+58 SET ZIP=$PIECE(LN7,U,9)
+59 IF ZIP?9N
SET ZIP=$EXTRACT(ZIP,1,5)_"-"_$EXTRACT(ZIP,6,9)
+60 SET ADDR2=""
+61 IF CITY]""
IF STATE]""
SET ADDR2=ADDR2_CITY_", "_STATE
+62 IF CITY=""
IF STATE]""
SET ADDR2=ADDR2_STATE
+63 IF CITY]""
IF STATE=""
SET ADDR2=ADDR2_CITY
+64 if ADDR2]""
SET ADDR2=ADDR2_" "_ZIP
+65 if ADDR2=""
SET ADDR2=ADDR2_ZIP
+66 DO EN^DDIOL(ADDR2,"","!?8")
+67 SET CODE="CODE:"_$PIECE(LN3,U,4)_$PIECE(LN3,U,5)
+68 DO EN^DDIOL(CODE,"","?46")
+69 SET FAX="FAX:"
+70 KILL PH
+71 SET PH=$PIECE(LN10,U,6)
+72 DO PHONE
+73 SET FAX=FAX_PH
+74 DO EN^DDIOL(FAX,"","?64")
+75 QUIT
End DoDot:1
+76 ;
+77 ;END OF PAYMENT ADDRESS LINES
+78 ;
+79 ;LETS INFORM USER IF THIS VENDOR IS INACTIVATED
+80 ;
+81 DO EN^DDIOL("","","!")
+82 IF $PIECE(LN10,U,5)=1
Begin DoDot:1
+83 DO EN^DDIOL("****THIS VENDOR IS INACTIVE","","?0")
+84 ;
+85 ;NOW SEE IF WE CAN FIND A SUBSTITUTE VENDOR
+86 ;
+87 ;RV = REPLACEMENT VENDOR INTERNAL ENTRY NUMBER
+88 ;IVCK = INACTIVATED VENDOR CHECK
+89 ;
+90 SET LOOP=""
+91 SET RV=+LN9
+92 IF RV=0&($EXTRACT(LN0,1,2)["**")
Begin DoDot:2
+93 DO EN^DDIOL(", NO REPLACEMENT VENDOR *****","","?27")
+94 SET PRCFLAG=1
WRITE !,?5," PLEASE CHOOSE ANOTHER VENDOR "
QUIT
End DoDot:2
+95 ;
+96 ;STOP IF A REPLACEMENT VENDOR POINTS TO ITSELF
+97 ;
+98 IF RV=IEN
SET RV=0
+99 FOR
if RV=0
QUIT
SET IVCK=$PIECE($GET(^PRC(440,RV,10)),U,5)
if IVCK=""
QUIT
Begin DoDot:2
+100 SET RVX=+$GET(^PRC(440,RV,9))
+101 IF RVX'>0
SET LOOP=1
QUIT
+102 IF RV=RVX
SET LOOP=1
QUIT
+103 SET RV=RVX
+104 IF RV=0!(LOOP=1)
DO EN^DDIOL("****","","?27")
QUIT
End DoDot:2
if LOOP=1
QUIT
+105 IF RV>0
Begin DoDot:2
+106 SET RVX=RV
+107 SET RV=" "_RV
+108 SET RV=$EXTRACT(RV,$LENGTH(RV)-5,99)
+109 DO EN^DDIOL(", USE VENDOR NO:"_RV_"****","","?27")
+110 SET PRCFLAG=1
SET LN0=$GET(^PRC(440,RVX,0))
SET NAME=$PIECE(LN0,U,1)
+111 WRITE !,?5," VENDOR NAME "_NAME
QUIT
End DoDot:2
+112 ;
+113 QUIT
End DoDot:1
+114 ;
+115 ;ONLY IF VENDER IS ACTIVE & THIS VENDOR LOOKUP IS NOT COMING FROM
+116 ;A FISCAL OPTION DISPLAY 'BUSINESS TYPE' SETUP
+117 ;
+118 IF $PIECE(LN10,U,5)=""
IF '$DATA(PRCFD("PAY"))
Begin DoDot:1
+119 DO SETBTMSG
+120 IF $PIECE(LN0,U,11)]""
QUIT
+121 IF LN2=""
DO EN^DDIOL(.BTMSG)
QUIT
+122 IF $PIECE(LN2,U,2)]""
QUIT
+123 IF $PIECE(LN2,U,3)']""
DO EN^DDIOL(.BTMSG)
QUIT
End DoDot:1
+124 ;
+125 ;IF VENDOR IS INACTIVE DISPLAY 'EDI VENDOR'
+126 ;
+127 IF $PIECE(LN10,U,5)=1
Begin DoDot:1
+128 IF $PIECE(LN3,U,2)="Y"
DO EN^DDIOL("EDI VENDOR","","?56")
QUIT
End DoDot:1
EXIT QUIT
+1 ;
PHONE ; PHONE/FAX FORMATTING
+1 ;
+2 SET PH=$TRANSLATE(PH,"abcdefghijklmnoprstuvwxy","222333444555666777888999")
+3 SET PH=$TRANSLATE(PH,"ABCDEFGHIJKLMNOPRSTUVWXY","222333444555666777888999")
+4 IF PH]""
Begin DoDot:1
+5 IF PH'?.N
Begin DoDot:2
+6 SET A=1
+7 FOR
SET T=$EXTRACT(PH,1)
if T?1N
Begin DoDot:3
+8 SET PH(A)=""
+9 FOR
SET T1=$EXTRACT(PH,1)
if T1'?1N
QUIT
SET PH(A)=PH(A)_T1
SET PH=$EXTRACT(PH,2,99)
if PH=""
QUIT
+10 if PH=""
QUIT
+11 SET A=A+1
+12 QUIT
End DoDot:3
if T'?1N
SET PH=$EXTRACT(PH,2,99)
if PH=""
QUIT
+13 IF $GET(PH(1))="011"
SET PH="INTERN'L"
QUIT
+14 IF $LENGTH($GET(PH(1)))=1
IF $LENGTH($GET(PH(2)))=3
IF $LENGTH($GET(PH(3)))=3
IF $LENGTH($GET(PH(4)))=4
SET PH=PH(2)_"-"_PH(3)_"-"_PH(4)
QUIT
+15 IF $LENGTH($GET(PH(1)))=3
IF $LENGTH($GET(PH(2)))=3
IF $LENGTH($GET(PH(3)))=4
SET PH=PH(1)_" "_PH(2)_"-"_PH(3)
QUIT
+16 IF $LENGTH($GET(PH(1)))=3
IF $LENGTH($GET(PH(2)))=4
SET PH=" "_PH(1)_"-"_PH(2)
QUIT
+17 QUIT
End DoDot:2
QUIT
+18 IF $LENGTH(PH)>9
SET PH=$EXTRACT(PH,1,3)_" "_$EXTRACT(PH,4,6)_"-"_$EXTRACT(PH,7,10)
QUIT
+19 IF $LENGTH(PH)>6
SET PH=" "_$EXTRACT(PH,1,3)_"-"_$EXTRACT(PH,4,7)
QUIT
+20 QUIT
End DoDot:1
+21 QUIT
SETBTMSG ;SET ARRAY TO HOLD VENDOR BUSINESS TYPE FIELD MESSAGE
+1 SET BTMSG(1)="*** BUSINESS TYPE UNDEFINED ***"
+2 SET BTMSG(1,"F")="$C(7),!"
+3 ;
+4 ;IF NOT ENTERING A PURCHASE ORDER, DON'T DISPLAY REMAINDER OF MSG
+5 ;
+6 IF '$DATA(PRCHPO)
SET BTMSG(2)=""
SET BTMSG(2,"F")="!"
QUIT
+7 SET BTMSG(2)="You will not be able to complete this Purchase Order"
+8 SET BTMSG(2,"F")="!"
+9 SET BTMSG(3)="with this vendor until the BUSINESS TYPE is defined"
+10 SET BTMSG(3,"F")="$C(7),!"
+11 SET BTMSG(4)=""
+12 SET BTMSG(4,"F")="!"
+13 QUIT
