Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHID

PRCHID.m

Go to the documentation of this file.
  1. PRCHID ;WISC/DJM/BGJ-VENDOR IDENTIFIER DATA ;2/1/22 13:32
  1. V ;;5.1;IFCAP;**7,227**;Oct 20, 2000;Build 1
  1. ;Per VHA Directive 6402, this routine should not be modified.
  1. START ;DISPLAY IDENTIFYING DATA FROM RECORD IN FILE 440
  1. N LN0,LN2,LN3,LN7,LN9,LN10,PHONE,PH,A,T,T1,NO,ADDR1,FMS,CITY,STATE
  1. N ZIP,ADDR2,CODE,FAX,FX,RV,IVCK,PRCFD,BTMSG,RVX,IEN,LOOP,NAME,PRCFLAG
  1. ;
  1. ; FIND OUT WHAT OPTION USER IS IN NOW. IF OPTION BEGINS WITH 'PRCF'
  1. ; RECORD FACT THAT OPTION IS A 'FISCAL' OPTION.
  1. ;
  1. D OP^XQCHK
  1. I XQOPT'=-1,($E(XQOPT,1,4)="PRCF") S PRCFD("PAY")=1
  1. ;
  1. ;GET CURRENT RECORD NODES NEEDED TO DISPLAY IDENTIFIERS
  1. ;
  1. S IEN=+Y
  1. S LN0=$G(^PRC(440,IEN,0))
  1. S LN2=$G(^PRC(440,IEN,2))
  1. S LN3=$G(^PRC(440,IEN,3))
  1. S LN7=$G(^PRC(440,IEN,7))
  1. S LN9=$G(^PRC(440,IEN,9))
  1. S LN10=$G(^PRC(440,IEN,10))
  1. S PRCFLAG=""
  1. ;
  1. ;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
  1. ;IS INACTIVATED.
  1. ;
  1. I $P(LN10,U,5)=1 G IEN
  1. ;
  1. ;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
  1. ;IS NOT INACTIVATED.
  1. ;
  1. D:$P(LN3,U,16)'="" EN^DDIOL("UEI:"_$P(LN3,U,16),"","?33")
  1. I $P(LN3,U,2)="Y" D EN^DDIOL("EDI","","?50")
  1. S PHONE="PH:"
  1. S PH=$P(LN0,U,10)
  1. D PHONE
  1. S PHONE=PHONE_PH
  1. D EN^DDIOL(PHONE,"","?55")
  1. ;
  1. ;COME HERE TO DISPLAY THE RECORD'S INTERNAL ENTRY NUMBER
  1. ;
  1. IEN S NO=" "_IEN
  1. S NO="NO:"_$E(NO,$L(NO)-5,99)
  1. D EN^DDIOL(NO,"","?71")
  1. ;
  1. ;NOW DISPLAY ORDERING ADDRESS DATA IN IDENTIFIERS
  1. ;
  1. I '$D(PRCFD("PAY")) D
  1. . ;
  1. . ;FIRST ORDERING ADDRESS LINE
  1. . ;
  1. . S ADDR1="ORD ADD:"_$P(LN0,U,2)
  1. . D EN^DDIOL(ADDR1,"","!")
  1. . S FMS="FMS:"_$P(LN3,U,7)
  1. . D EN^DDIOL(FMS,"","?46")
  1. . ;
  1. . ;SECOND ORDERING ADDRESS LINE
  1. . ;
  1. . S CITY=$P(LN0,U,6)
  1. . S STATE=$P(LN0,U,7)
  1. . I STATE>0 D
  1. . . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
  1. . S ZIP=$P(LN0,U,8)
  1. . I ZIP?9N S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
  1. . S ADDR2=""
  1. . I CITY]"",STATE]"" S ADDR2=ADDR2_CITY_", "_STATE
  1. . I CITY="",STATE]"" S ADDR2=ADDR2_STATE
  1. . I CITY]"",STATE="" S ADDR2=ADDR2_CITY
  1. . S:ADDR2]"" ADDR2=ADDR2_" "_ZIP
  1. . S:ADDR2="" ADDR2=ADDR2_ZIP
  1. . D EN^DDIOL(ADDR2,"","!?8")
  1. . S CODE="CODE:"_$P(LN3,U,4)_$P(LN3,U,5)
  1. . D EN^DDIOL(CODE,"","?46")
  1. . S FAX="FAX:"
  1. . K PH
  1. . S PH=$P(LN10,U,6)
  1. . D PHONE
  1. . S FAX=FAX_PH
  1. . D EN^DDIOL(FAX,"","?64")
  1. ;
  1. ;END OF ORDERING ADDRESS LINES
  1. ;
  1. ;SHOW PAYMENT ADDRESS LINES
  1. ;
  1. I $D(PRCFD("PAY")) D
  1. . ;
  1. . ;FIRST PAYMENT ADDRESS LINE
  1. . ;
  1. . S ADDR1="PAY ADD:"_$P(LN7,U,3)
  1. . D EN^DDIOL(ADDR1,"","!")
  1. . S FMS="FMS:"_$P(LN3,U,7)
  1. . D EN^DDIOL(FMS,"","?46")
  1. . ;
  1. . ;SECOND PAYMENT ADDRESS LINE
  1. . ;
  1. . S CITY=$P(LN7,U,7)
  1. . S STATE=$P(LN7,U,8)
  1. . I STATE>0 D
  1. . . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
  1. . S ZIP=$P(LN7,U,9)
  1. . I ZIP?9N S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
  1. . S ADDR2=""
  1. . I CITY]"",STATE]"" S ADDR2=ADDR2_CITY_", "_STATE
  1. . I CITY="",STATE]"" S ADDR2=ADDR2_STATE
  1. . I CITY]"",STATE="" S ADDR2=ADDR2_CITY
  1. . S:ADDR2]"" ADDR2=ADDR2_" "_ZIP
  1. . S:ADDR2="" ADDR2=ADDR2_ZIP
  1. . D EN^DDIOL(ADDR2,"","!?8")
  1. . S CODE="CODE:"_$P(LN3,U,4)_$P(LN3,U,5)
  1. . D EN^DDIOL(CODE,"","?46")
  1. . S FAX="FAX:"
  1. . K PH
  1. . S PH=$P(LN10,U,6)
  1. . D PHONE
  1. . S FAX=FAX_PH
  1. . D EN^DDIOL(FAX,"","?64")
  1. . Q
  1. ;
  1. ;END OF PAYMENT ADDRESS LINES
  1. ;
  1. ;LETS INFORM USER IF THIS VENDOR IS INACTIVATED
  1. ;
  1. D EN^DDIOL("","","!")
  1. I $P(LN10,U,5)=1 D
  1. . D EN^DDIOL("****THIS VENDOR IS INACTIVE","","?0")
  1. . ;
  1. . ;NOW SEE IF WE CAN FIND A SUBSTITUTE VENDOR
  1. . ;
  1. . ;RV = REPLACEMENT VENDOR INTERNAL ENTRY NUMBER
  1. . ;IVCK = INACTIVATED VENDOR CHECK
  1. . ;
  1. . S LOOP=""
  1. . S RV=+LN9
  1. . I RV=0&($E(LN0,1,2)["**") D
  1. . . D EN^DDIOL(", NO REPLACEMENT VENDOR *****","","?27")
  1. . . S PRCFLAG=1 W !,?5," PLEASE CHOOSE ANOTHER VENDOR " Q
  1. . ;
  1. . ;STOP IF A REPLACEMENT VENDOR POINTS TO ITSELF
  1. . ;
  1. . I RV=IEN S RV=0
  1. . F Q:RV=0 S IVCK=$P($G(^PRC(440,RV,10)),U,5) Q:IVCK="" D Q:LOOP=1
  1. . . S RVX=+$G(^PRC(440,RV,9))
  1. . . I RVX'>0 S LOOP=1 Q
  1. . . I RV=RVX S LOOP=1 Q
  1. . . S RV=RVX
  1. . . I RV=0!(LOOP=1) D EN^DDIOL("****","","?27") Q
  1. . I RV>0 D
  1. . . S RVX=RV
  1. . . S RV=" "_RV
  1. . . S RV=$E(RV,$L(RV)-5,99)
  1. . . D EN^DDIOL(", USE VENDOR NO:"_RV_"****","","?27")
  1. . . S PRCFLAG=1,LN0=$G(^PRC(440,RVX,0)),NAME=$P(LN0,U,1)
  1. . . W !,?5," VENDOR NAME "_NAME Q
  1. . ;
  1. . Q
  1. ;
  1. ;ONLY IF VENDER IS ACTIVE & THIS VENDOR LOOKUP IS NOT COMING FROM
  1. ;A FISCAL OPTION DISPLAY 'BUSINESS TYPE' SETUP
  1. ;
  1. I $P(LN10,U,5)="",'$D(PRCFD("PAY")) D
  1. . D SETBTMSG
  1. . I $P(LN0,U,11)]"" Q
  1. . I LN2="" D EN^DDIOL(.BTMSG) Q
  1. . I $P(LN2,U,2)]"" Q
  1. . I $P(LN2,U,3)']"" D EN^DDIOL(.BTMSG) Q
  1. ;
  1. ;IF VENDOR IS INACTIVE DISPLAY 'EDI VENDOR'
  1. ;
  1. I $P(LN10,U,5)=1 D
  1. . I $P(LN3,U,2)="Y" D EN^DDIOL("EDI VENDOR","","?56") Q
  1. EXIT Q
  1. ;
  1. PHONE ; PHONE/FAX FORMATTING
  1. ;
  1. S PH=$TR(PH,"abcdefghijklmnoprstuvwxy","222333444555666777888999")
  1. S PH=$TR(PH,"ABCDEFGHIJKLMNOPRSTUVWXY","222333444555666777888999")
  1. I PH]"" D
  1. . I PH'?.N D Q
  1. . . S A=1
  1. . . F S T=$E(PH,1) D:T?1N S:T'?1N PH=$E(PH,2,99) Q:PH=""
  1. . . . S PH(A)=""
  1. . . . F S T1=$E(PH,1) Q:T1'?1N S PH(A)=PH(A)_T1,PH=$E(PH,2,99) Q:PH=""
  1. . . . Q:PH=""
  1. . . . S A=A+1
  1. . . . Q
  1. . . I $G(PH(1))="011" S PH="INTERN'L" Q
  1. . . 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
  1. . . 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
  1. . . I $L($G(PH(1)))=3,$L($G(PH(2)))=4 S PH=" "_PH(1)_"-"_PH(2) Q
  1. . . Q
  1. . I $L(PH)>9 S PH=$E(PH,1,3)_" "_$E(PH,4,6)_"-"_$E(PH,7,10) Q
  1. . I $L(PH)>6 S PH=" "_$E(PH,1,3)_"-"_$E(PH,4,7) Q
  1. . Q
  1. Q
  1. SETBTMSG ;SET ARRAY TO HOLD VENDOR BUSINESS TYPE FIELD MESSAGE
  1. S BTMSG(1)="*** BUSINESS TYPE UNDEFINED ***"
  1. S BTMSG(1,"F")="$C(7),!"
  1. ;
  1. ;IF NOT ENTERING A PURCHASE ORDER, DON'T DISPLAY REMAINDER OF MSG
  1. ;
  1. I '$D(PRCHPO) S BTMSG(2)="",BTMSG(2,"F")="!" Q
  1. S BTMSG(2)="You will not be able to complete this Purchase Order"
  1. S BTMSG(2,"F")="!"
  1. S BTMSG(3)="with this vendor until the BUSINESS TYPE is defined"
  1. S BTMSG(3,"F")="$C(7),!"
  1. S BTMSG(4)=""
  1. S BTMSG(4,"F")="!"
  1. Q