ACRFVLK ;IHS/OIRM/DSD/AEF - VENDOR FILE LOOKUP ; [ 03/28/2007 10:56 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**21,22**;NOV 5, 2001
;
; New routine ACR*2.1*20.14
; Copied from AUTTVLK. Vendor Add/Edit with additional mods
; mods to accomidate vendor screen changes
; Routine heavily modified for UFMS requirements ACR*2.1*22 UFMS
Q
; ********************************************************************
;
ADD ; EP - Add or Edit Vendor data.
D ^XBKVAR
N ACRVND,ACRVAUTH,ACRDIC
S ACRQUIT=0 ; Initialize quit flags
S ACRVAUTH=$$EDITAUTH(DUZ) ; Get ARMS User Vendor Edit Authority
F D Q:+ACRQUIT
. D ASKVND ; Add/Lookup Vendor
. Q:+ACRQUIT ; Add/Lookup failed or user opted out
. I +$P(ACRVND,U,3) D ; New vendor, edit all data
. . S DR="[ACR VENDOR EDIT]"
. . D SCREEN(ACRVND,DR)
. I '+$P(ACRVND,U,3) D Q:+ACRQUIT ; Existing vendor, checks then edit
. . D DISP ; display current vendor data
. . D CHKACTV ; Check if vendor active
. . D DUNSCHK
. . Q:+ACRQUIT
. . I ",A,C,F,"'[(","_ACRVAUTH_",") D MSG ; Check Vendor authority
. . Q:+ACRQUIT
. F D EDIT Q:+ACRQUIT ; Edit Vendor Data
Q
; ********************************************************************
;
EDITAUTH(X) ; EP; Check user's Vendor Edit Authority in ARMS USER File
I '+X Q ""
S Y=$$GET1^DIQ(9002185.3,X,17,"I")
Q Y
; ********************************************************************
;
ASKVND ; Ask / Lookup Vendor
; Only allow Vendor addition if Vendor Edit Authority is F, C, or A.
W:$D(IOF) @IOF
K DD,DO,X,Y,DIC,DA,DR,DINUM,D,DLAYGO
S DIC="^AUTTVNDR("
S DIC(0)="AEMQZ"
S DIC("A")="Edit which Vendor? "
I ",A,C,F,"[(","_ACRVAUTH_",") D
. S DIC(0)=DIC(0)_"L"
. S DIC("A")="Add/Edit which Vendor? "
. S DLAYGO=9999999.11
D ^DIC
I +Y<1 S ACRQUIT=1 Q
S ACRVND=Y
S ACRVND(0)=Y(0)
Q
; ********************************************************************
;
DISP ;EP - If not new entry, display Current Vendor data.
S DR="[ACR VENDOR DISPLAY]"
D SCREEN(ACRVND,DR)
Q
; ********************************************************************
;
CHKACTV ; Check to see if Vendor has been inactivated
S ACRQUIT=0
S ACRACTV=$$GET1^DIQ(9999999.11,+ACRVND,.05,"E")
I ACRACTV'="" D ; Inactive Vendor
. S ACRQUIT=1
. S DR="[ACR VENDOR DISPLAY-INACTIVE]"
. D SCREEN(ACRVND,DR)
Q
; ********************************************************************
;
MSG ;EP - Message edit authority denied
S ACRQUIT=1
S DR="[ACR VENDOR DISPLAY-AUTHORITY]"
D SCREEN(ACRVND,DR)
Q
; ********************************************************************
;
EDIT ; Edit which vendor data
K DA,X,Y,DR,DIR
D ^XBFMK
S DIR(0)="SO^1:ALL Vendor Data;"
S DIR(0)=DIR(0)_"2:Mailing Address;"
S DIR(0)=DIR(0)_"3:Billing Address;"
S DIR(0)=DIR(0)_"4:Remit To Address;"
S DIR(0)=DIR(0)_"5:1099 Payment Data;"
S DIR(0)=DIR(0)_"6:ARMS/CIS;"
S DIR(0)=DIR(0)_"7:SMALL PURCHASE INFORMATION Data"
S DIR("A")="Edit which data"
S DIR("?")="Enter the code from the list to indicate the type of data you want to edit."
W !
D ^DIR
I (Y<1!(Y>7)) S ACRQUIT=1 Q
I ",F,A,"'[(","_ACRVAUTH_",")&(Y=5) D Q ; A or F auth req for Pay data
. S DR="[ACR VENDOR DISPLAY-AUTHORITY]"
. D SCREEN(ACRVND,DR)
I ",C,A,"'[(","_ACRVAUTH_",")&((Y=6)!(Y=7)) D Q ; A or C auth req for CIS/SP data
. S DR="[ACR VENDOR DISPLAY-AUTHORITY]"
. D SCREEN(ACRVND,DR)
S:Y DR="]"
S:Y=2 DR="-MAIL]"
S:Y=3 DR="-BILL]"
S:Y=4 DR="-REMIT]"
S:Y=5 DR="-PAY]"
S:Y=6 DR="-CIS]"
S:Y=7 DR="-SPIS]"
S DR="[ACR VENDOR EDIT"_DR
D SCREEN(ACRVND,DR)
Q
; ********************************************************************
;
SCREEN(ACRVND,DR) ; EP; call screen man
; pass in DR
; pass in ACRVND
W:$D(IOF) @IOF
K DDSFILE,DA,X,Y
S DA=+ACRVND
S DDSFILE="^AUTTVNDR("
D ^DDS
K DDSFILE,DA,DR,X,Y
W:$D(IOF) @IOF
Q
; ********************************************************************
;
DUNS(X) ; EP;----- RETURNS DUNN AND BRADSTREET NUMBER
;
; X = VENDOR IEN
;
N Y
S Y=""
I X S Y=$P($G(^AUTTVNDR(X,0)),U,7) ;FREE TEXT
Q Y
; ********************************************************************
;
CHKVNDR ; EP - Check if vendor is inactive, DUNS exists, and DUNS is 9-13 long
K ACRACTV,ACRVNDR,ACRDUNS,ACRINACT,ACRNODUN,ACRSIZE,ACRVERR
K ACRDERR
S ACRVNAME=$$GET1^DIQ(9999999.11,+ACRVND,.01,"E")
D ACT
D DUNSCHK
D:ACRWARN'="WARN" @ACRWARN ;ACR*2.1*22.04 IM22759
K ACRACTV,ACRVNDR,ACRDUNS
Q
; ********************************************************************
;
ACT ; EP - Check to see if Vendor has been inactivated
S ACRVNAME=$$GET1^DIQ(9999999.11,+ACRVND,.01,"E")
S ACRACTV=$$GET1^DIQ(9999999.11,+ACRVND,.05,"E")
I ACRACTV'="" D ;INACTIVE VENDOR
.W *7
.S ACRVERR=ACRVNAME_" is INACTIVE"
.D:$D(DDSREFT) HLP^DDSUTL(ACRVERR)
Q
; ********************************************************************
;
DUNSCHK ; EP - Check to see if there is a DUNS #
S ACRWARN="WARN2"
S:$D(DDSREFT) ACRWARN="WARN" ;IF CALLED FROM SCREENMAN DO OTHER WARNING
K ACRDERR
S ACRDUNS=$$DUNS^ACRFVLK(+ACRVND)
S ACRVNAME=$$GET1^DIQ(9999999.11,+ACRVND,.01,"E")
I ACRDUNS="" D ;NO DUNS
.W *7
.S ACRDERR=ACRVNAME_" MUST have a DUNS number entered"
.D:$D(DDSREFT) HLP^DDSUTL(ACRDERR)
;Check to see if the DUNS # is 9 - 13 chars long
I ACRDUNS'="" D
.I $L(ACRDUNS)<9!($L(ACRDUNS)>13)!(ACRDUNS[11111)!(ACRDUNS[99999) D ;DUNS WRONG LENGTH
..W *7
..S ACRDERR=ACRVNAME_" MUST have a 9-13 digit DUNS number entered and cannot be all one number"
..D:$D(DDSREFT) HLP^DDSUTL(ACRDERR)
Q
;
WARN ;EP; IN SM WARNING THAT VENDOR IS INACTIVE, DUNS IS MISSING OR BAD
I $D(ACRDERR)!($D(ACRVERR)) D
.W !!,$G(ACRDERR)
.W:$G(ACRDERR)]"" ! W $G(ACRVERR)
.S (ACRQUIT,ACROUT)=1
Q
;
WARN2 ;EP; WARNING THAT VENDOR IS INACTIVE, DUNS IS MISSING OR BAD
I $D(ACRDERR)!($D(ACRVERR)) D
.D WARNING^ACRFWARN
.W !!,$G(ACRDERR)
.W:$G(ACRDERR)]"" ! W $G(ACRVERR)
.W !!,"A Purchase Order or Request for Credit Card cannot be sent"
.W !,"for approval until the reported problem has been resolved"
.D PAUSE^ACRFWARN
.S (ACRQUIT,ACROUT)=1
Q
AI ;EP - INVOKE SCREEN TO ALLOW ACTIVATION/INACTIVATION OF VENDOR
S ACRVAUTH=$$EDITAUTH(DUZ)
D ASKVND
Q:$D(ACRQUIT)
I ",A,C,F,"'[(","_ACRVAUTH_",") D MSG Q
S DR="[ACR VENDOR EDIT-ACT/INACT]"
D SCREEN(ACRVND,DR)
Q
EINCHK ;CHECK FOR VENDORS WITH THE SAME EIN NO ACR*2.1*21.03 IM22241
S (ACRVEIN,ACRVIEN,ACRVDUP)=""
F S ACRVEIN=$O(^AUTTVNDR("E",ACRVEIN)) Q:'ACRVEIN D
.Q:$E(ACRVEIN,1,10)'=X
.F S ACRVIEN=$O(^AUTTVNDR("E",ACRVEIN,ACRVIEN)) Q:'ACRVIEN D
.. S ACRVDUP=$$GET1^DIQ(9999999.11,ACRVIEN,.01)_" "_$$GET1^DIQ(9999999.11,ACRVIEN,1101)
..W *7
..D HLP^DDSUTL(ACRVDUP_" ALREADY EXISTS")
..D HLP^DDSUTL("Make sure this is the correct EIN number and change if necessary")
..D HLP^DDSUTL("$$EOP")
..S DDSBR=6
K ACRVEIN,ACRVDUP
Q
SUFCHK ;CHECK EIN SUFFIX ACR*2.1*21.03 IM22241
K ACRSUFF
I '$D(ACREINNW) S ACREIN=$E($$GET1^DIQ(9999999.11,DA,1101))
I $D(ACREINNW) S ACREIN=$E(ACREINNW)
;I ACREIN=1,X=""!($L(X)'=2)!(X'?2UN) D ;BAD SUFFIX ;ACR*2.1*22.11l
I X=""!($L(X)'=2)!(X'?2UN) D ;BAD SUFFIX ;ACR*2.1*22.11l
.S ACRSUFF=""
.W *7
.;D HLP^DDSUTL("Organizations MUST HAVE a SUFFIX, SUFFIX MUST BE 2 characters long, and SUFFIX MUST BE a combination of uppercase letters and numbers") ;ACR*2.1*22.11l
.D HLP^DDSUTL("ALL VENDORS MUST HAVE a SUFFIX, MUST BE 2 characters long, and MUST BE a combination of uppercase letters and numbers") ;ACR*2.1*22.11l
.D HLP^DDSUTL("$$EOP")
Q:X=""
S (ACRVIEN,ACRVEIN,ACRVDUP)=""
I '$D(ACREINNW) S ACRVEIN=$$GET1^DIQ(9999999.11,DA,1101)_X
I $D(ACREINNW) S ACRVEIN=ACREINNW_X
F S ACRVIEN=$O(^AUTTVNDR("E",ACRVEIN,ACRVIEN)) Q:'ACRVIEN D
.Q:ACRVIEN=DA ;ACR*2.1*22.11h IM22761
.S ACRVDUP=$$GET1^DIQ(9999999.11,ACRVIEN,.01)_" "_$$GET1^DIQ(9999999.11,ACRVIEN,1102.01)
.W *7
.D HLP^DDSUTL(ACRVDUP_" Already Exists")
.D HLP^DDSUTL("You CANNOT have vendors with the same EIN NUMBER and SUFFIX")
.D HLP^DDSUTL("Correct the EIN NUMBER or SUFFIX accordingly")
.D HLP^DDSUTL("$$EOP")
.S DDSBR=6
K ACRVIEN,ACRVEIN,ACRVDUP
Q
ACRFVLK ;IHS/OIRM/DSD/AEF - VENDOR FILE LOOKUP ; [ 03/28/2007 10:56 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**21,22**;NOV 5, 2001
+2 ;
+3 ; New routine ACR*2.1*20.14
+4 ; Copied from AUTTVLK. Vendor Add/Edit with additional mods
+5 ; mods to accomidate vendor screen changes
+6 ; Routine heavily modified for UFMS requirements ACR*2.1*22 UFMS
+7 QUIT
+8 ; ********************************************************************
+9 ;
ADD ; EP - Add or Edit Vendor data.
+1 DO ^XBKVAR
+2 NEW ACRVND,ACRVAUTH,ACRDIC
+3 ; Initialize quit flags
SET ACRQUIT=0
+4 ; Get ARMS User Vendor Edit Authority
SET ACRVAUTH=$$EDITAUTH(DUZ)
+5 FOR
Begin DoDot:1
+6 ; Add/Lookup Vendor
DO ASKVND
+7 ; Add/Lookup failed or user opted out
IF +ACRQUIT
QUIT
+8 ; New vendor, edit all data
IF +$PIECE(ACRVND,U,3)
Begin DoDot:2
+9 SET DR="[ACR VENDOR EDIT]"
+10 DO SCREEN(ACRVND,DR)
End DoDot:2
+11 ; Existing vendor, checks then edit
IF '+$PIECE(ACRVND,U,3)
Begin DoDot:2
+12 ; display current vendor data
DO DISP
+13 ; Check if vendor active
DO CHKACTV
+14 DO DUNSCHK
+15 IF +ACRQUIT
QUIT
+16 ; Check Vendor authority
IF ",A,C,F,"'[(","_ACRVAUTH_",")
DO MSG
+17 IF +ACRQUIT
QUIT
End DoDot:2
IF +ACRQUIT
QUIT
+18 ; Edit Vendor Data
FOR
DO EDIT
IF +ACRQUIT
QUIT
End DoDot:1
IF +ACRQUIT
QUIT
+19 QUIT
+20 ; ********************************************************************
+21 ;
EDITAUTH(X) ; EP; Check user's Vendor Edit Authority in ARMS USER File
+1 IF '+X
QUIT ""
+2 SET Y=$$GET1^DIQ(9002185.3,X,17,"I")
+3 QUIT Y
+4 ; ********************************************************************
+5 ;
ASKVND ; Ask / Lookup Vendor
+1 ; Only allow Vendor addition if Vendor Edit Authority is F, C, or A.
+2 IF $DATA(IOF)
WRITE @IOF
+3 KILL DD,DO,X,Y,DIC,DA,DR,DINUM,D,DLAYGO
+4 SET DIC="^AUTTVNDR("
+5 SET DIC(0)="AEMQZ"
+6 SET DIC("A")="Edit which Vendor? "
+7 IF ",A,C,F,"[(","_ACRVAUTH_",")
Begin DoDot:1
+8 SET DIC(0)=DIC(0)_"L"
+9 SET DIC("A")="Add/Edit which Vendor? "
+10 SET DLAYGO=9999999.11
End DoDot:1
+11 DO ^DIC
+12 IF +Y<1
SET ACRQUIT=1
QUIT
+13 SET ACRVND=Y
+14 SET ACRVND(0)=Y(0)
+15 QUIT
+16 ; ********************************************************************
+17 ;
DISP ;EP - If not new entry, display Current Vendor data.
+1 SET DR="[ACR VENDOR DISPLAY]"
+2 DO SCREEN(ACRVND,DR)
+3 QUIT
+4 ; ********************************************************************
+5 ;
CHKACTV ; Check to see if Vendor has been inactivated
+1 SET ACRQUIT=0
+2 SET ACRACTV=$$GET1^DIQ(9999999.11,+ACRVND,.05,"E")
+3 ; Inactive Vendor
IF ACRACTV'=""
Begin DoDot:1
+4 SET ACRQUIT=1
+5 SET DR="[ACR VENDOR DISPLAY-INACTIVE]"
+6 DO SCREEN(ACRVND,DR)
End DoDot:1
+7 QUIT
+8 ; ********************************************************************
+9 ;
MSG ;EP - Message edit authority denied
+1 SET ACRQUIT=1
+2 SET DR="[ACR VENDOR DISPLAY-AUTHORITY]"
+3 DO SCREEN(ACRVND,DR)
+4 QUIT
+5 ; ********************************************************************
+6 ;
EDIT ; Edit which vendor data
+1 KILL DA,X,Y,DR,DIR
+2 DO ^XBFMK
+3 SET DIR(0)="SO^1:ALL Vendor Data;"
+4 SET DIR(0)=DIR(0)_"2:Mailing Address;"
+5 SET DIR(0)=DIR(0)_"3:Billing Address;"
+6 SET DIR(0)=DIR(0)_"4:Remit To Address;"
+7 SET DIR(0)=DIR(0)_"5:1099 Payment Data;"
+8 SET DIR(0)=DIR(0)_"6:ARMS/CIS;"
+9 SET DIR(0)=DIR(0)_"7:SMALL PURCHASE INFORMATION Data"
+10 SET DIR("A")="Edit which data"
+11 SET DIR("?")="Enter the code from the list to indicate the type of data you want to edit."
+12 WRITE !
+13 DO ^DIR
+14 IF (Y<1!(Y>7))
SET ACRQUIT=1
QUIT
+15 ; A or F auth req for Pay data
IF ",F,A,"'[(","_ACRVAUTH_",")&(Y=5)
Begin DoDot:1
+16 SET DR="[ACR VENDOR DISPLAY-AUTHORITY]"
+17 DO SCREEN(ACRVND,DR)
End DoDot:1
QUIT
+18 ; A or C auth req for CIS/SP data
IF ",C,A,"'[(","_ACRVAUTH_",")&((Y=6)!(Y=7))
Begin DoDot:1
+19 SET DR="[ACR VENDOR DISPLAY-AUTHORITY]"
+20 DO SCREEN(ACRVND,DR)
End DoDot:1
QUIT
+21 IF Y
SET DR="]"
+22 IF Y=2
SET DR="-MAIL]"
+23 IF Y=3
SET DR="-BILL]"
+24 IF Y=4
SET DR="-REMIT]"
+25 IF Y=5
SET DR="-PAY]"
+26 IF Y=6
SET DR="-CIS]"
+27 IF Y=7
SET DR="-SPIS]"
+28 SET DR="[ACR VENDOR EDIT"_DR
+29 DO SCREEN(ACRVND,DR)
+30 QUIT
+31 ; ********************************************************************
+32 ;
SCREEN(ACRVND,DR) ; EP; call screen man
+1 ; pass in DR
+2 ; pass in ACRVND
+3 IF $DATA(IOF)
WRITE @IOF
+4 KILL DDSFILE,DA,X,Y
+5 SET DA=+ACRVND
+6 SET DDSFILE="^AUTTVNDR("
+7 DO ^DDS
+8 KILL DDSFILE,DA,DR,X,Y
+9 IF $DATA(IOF)
WRITE @IOF
+10 QUIT
+11 ; ********************************************************************
+12 ;
DUNS(X) ; EP;----- RETURNS DUNN AND BRADSTREET NUMBER
+1 ;
+2 ; X = VENDOR IEN
+3 ;
+4 NEW Y
+5 SET Y=""
+6 ;FREE TEXT
IF X
SET Y=$PIECE($GET(^AUTTVNDR(X,0)),U,7)
+7 QUIT Y
+8 ; ********************************************************************
+9 ;
CHKVNDR ; EP - Check if vendor is inactive, DUNS exists, and DUNS is 9-13 long
+1 KILL ACRACTV,ACRVNDR,ACRDUNS,ACRINACT,ACRNODUN,ACRSIZE,ACRVERR
+2 KILL ACRDERR
+3 SET ACRVNAME=$$GET1^DIQ(9999999.11,+ACRVND,.01,"E")
+4 DO ACT
+5 DO DUNSCHK
+6 ;ACR*2.1*22.04 IM22759
IF ACRWARN'="WARN"
DO @ACRWARN
+7 KILL ACRACTV,ACRVNDR,ACRDUNS
+8 QUIT
+9 ; ********************************************************************
+10 ;
ACT ; EP - Check to see if Vendor has been inactivated
+1 SET ACRVNAME=$$GET1^DIQ(9999999.11,+ACRVND,.01,"E")
+2 SET ACRACTV=$$GET1^DIQ(9999999.11,+ACRVND,.05,"E")
+3 ;INACTIVE VENDOR
IF ACRACTV'=""
Begin DoDot:1
+4 WRITE *7
+5 SET ACRVERR=ACRVNAME_" is INACTIVE"
+6 IF $DATA(DDSREFT)
DO HLP^DDSUTL(ACRVERR)
End DoDot:1
+7 QUIT
+8 ; ********************************************************************
+9 ;
DUNSCHK ; EP - Check to see if there is a DUNS #
+1 SET ACRWARN="WARN2"
+2 ;IF CALLED FROM SCREENMAN DO OTHER WARNING
IF $DATA(DDSREFT)
SET ACRWARN="WARN"
+3 KILL ACRDERR
+4 SET ACRDUNS=$$DUNS^ACRFVLK(+ACRVND)
+5 SET ACRVNAME=$$GET1^DIQ(9999999.11,+ACRVND,.01,"E")
+6 ;NO DUNS
IF ACRDUNS=""
Begin DoDot:1
+7 WRITE *7
+8 SET ACRDERR=ACRVNAME_" MUST have a DUNS number entered"
+9 IF $DATA(DDSREFT)
DO HLP^DDSUTL(ACRDERR)
End DoDot:1
+10 ;Check to see if the DUNS # is 9 - 13 chars long
+11 IF ACRDUNS'=""
Begin DoDot:1
+12 ;DUNS WRONG LENGTH
IF $LENGTH(ACRDUNS)<9!($LENGTH(ACRDUNS)>13)!(ACRDUNS[11111)!(ACRDUNS[99999)
Begin DoDot:2
+13 WRITE *7
+14 SET ACRDERR=ACRVNAME_" MUST have a 9-13 digit DUNS number entered and cannot be all one number"
+15 IF $DATA(DDSREFT)
DO HLP^DDSUTL(ACRDERR)
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
WARN ;EP; IN SM WARNING THAT VENDOR IS INACTIVE, DUNS IS MISSING OR BAD
+1 IF $DATA(ACRDERR)!($DATA(ACRVERR))
Begin DoDot:1
+2 WRITE !!,$GET(ACRDERR)
+3 IF $GET(ACRDERR)]""
WRITE !
WRITE $GET(ACRVERR)
+4 SET (ACRQUIT,ACROUT)=1
End DoDot:1
+5 QUIT
+6 ;
WARN2 ;EP; WARNING THAT VENDOR IS INACTIVE, DUNS IS MISSING OR BAD
+1 IF $DATA(ACRDERR)!($DATA(ACRVERR))
Begin DoDot:1
+2 DO WARNING^ACRFWARN
+3 WRITE !!,$GET(ACRDERR)
+4 IF $GET(ACRDERR)]""
WRITE !
WRITE $GET(ACRVERR)
+5 WRITE !!,"A Purchase Order or Request for Credit Card cannot be sent"
+6 WRITE !,"for approval until the reported problem has been resolved"
+7 DO PAUSE^ACRFWARN
+8 SET (ACRQUIT,ACROUT)=1
End DoDot:1
+9 QUIT
AI ;EP - INVOKE SCREEN TO ALLOW ACTIVATION/INACTIVATION OF VENDOR
+1 SET ACRVAUTH=$$EDITAUTH(DUZ)
+2 DO ASKVND
+3 IF $DATA(ACRQUIT)
QUIT
+4 IF ",A,C,F,"'[(","_ACRVAUTH_",")
DO MSG
QUIT
+5 SET DR="[ACR VENDOR EDIT-ACT/INACT]"
+6 DO SCREEN(ACRVND,DR)
+7 QUIT
EINCHK ;CHECK FOR VENDORS WITH THE SAME EIN NO ACR*2.1*21.03 IM22241
+1 SET (ACRVEIN,ACRVIEN,ACRVDUP)=""
+2 FOR
SET ACRVEIN=$ORDER(^AUTTVNDR("E",ACRVEIN))
IF 'ACRVEIN
QUIT
Begin DoDot:1
+3 IF $EXTRACT(ACRVEIN,1,10)'=X
QUIT
+4 FOR
SET ACRVIEN=$ORDER(^AUTTVNDR("E",ACRVEIN,ACRVIEN))
IF 'ACRVIEN
QUIT
Begin DoDot:2
+5 SET ACRVDUP=$$GET1^DIQ(9999999.11,ACRVIEN,.01)_" "_$$GET1^DIQ(9999999.11,ACRVIEN,1101)
+6 WRITE *7
+7 DO HLP^DDSUTL(ACRVDUP_" ALREADY EXISTS")
+8 DO HLP^DDSUTL("Make sure this is the correct EIN number and change if necessary")
+9 DO HLP^DDSUTL("$$EOP")
+10 SET DDSBR=6
End DoDot:2
End DoDot:1
+11 KILL ACRVEIN,ACRVDUP
+12 QUIT
SUFCHK ;CHECK EIN SUFFIX ACR*2.1*21.03 IM22241
+1 KILL ACRSUFF
+2 IF '$DATA(ACREINNW)
SET ACREIN=$EXTRACT($$GET1^DIQ(9999999.11,DA,1101))
+3 IF $DATA(ACREINNW)
SET ACREIN=$EXTRACT(ACREINNW)
+4 ;I ACREIN=1,X=""!($L(X)'=2)!(X'?2UN) D ;BAD SUFFIX ;ACR*2.1*22.11l
+5 ;BAD SUFFIX ;ACR*2.1*22.11l
IF X=""!($LENGTH(X)'=2)!(X'?2UN)
Begin DoDot:1
+6 SET ACRSUFF=""
+7 WRITE *7
+8 ;D HLP^DDSUTL("Organizations MUST HAVE a SUFFIX, SUFFIX MUST BE 2 characters long, and SUFFIX MUST BE a combination of uppercase letters and numbers") ;ACR*2.1*22.11l
+9 ;ACR*2.1*22.11l
DO HLP^DDSUTL("ALL VENDORS MUST HAVE a SUFFIX, MUST BE 2 characters long, and MUST BE a combination of uppercase letters and numbers")
+10 DO HLP^DDSUTL("$$EOP")
End DoDot:1
+11 IF X=""
QUIT
+12 SET (ACRVIEN,ACRVEIN,ACRVDUP)=""
+13 IF '$DATA(ACREINNW)
SET ACRVEIN=$$GET1^DIQ(9999999.11,DA,1101)_X
+14 IF $DATA(ACREINNW)
SET ACRVEIN=ACREINNW_X
+15 FOR
SET ACRVIEN=$ORDER(^AUTTVNDR("E",ACRVEIN,ACRVIEN))
IF 'ACRVIEN
QUIT
Begin DoDot:1
+16 ;ACR*2.1*22.11h IM22761
IF ACRVIEN=DA
QUIT
+17 SET ACRVDUP=$$GET1^DIQ(9999999.11,ACRVIEN,.01)_" "_$$GET1^DIQ(9999999.11,ACRVIEN,1102.01)
+18 WRITE *7
+19 DO HLP^DDSUTL(ACRVDUP_" Already Exists")
+20 DO HLP^DDSUTL("You CANNOT have vendors with the same EIN NUMBER and SUFFIX")
+21 DO HLP^DDSUTL("Correct the EIN NUMBER or SUFFIX accordingly")
+22 DO HLP^DDSUTL("$$EOP")
+23 SET DDSBR=6
End DoDot:1
+24 KILL ACRVIEN,ACRVEIN,ACRVDUP
+25 QUIT
