- 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 Feb 18, 2025@23:34:20 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