source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHID.m@ 1158

PRCHID ;WISC/DJM/BGJ-VENDOR IDENTIFIER DATA ;5/3/99 1:11pm
V ;;5.1;IFCAP;**7**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, 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
 ;
 ; 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.
 ;
 I $P(LN3,U,2)="Y" D EN^DDIOL("EDI","","?49")
 S PHONE="PH:"
 S PH=$P(LN0,U,10)
 D PHONE
 S PHONE=PHONE_PH
 D EN^DDIOL(PHONE,"","?54")
 ;
 ;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