IBCEP8 ;ALB/TMP/OIFO-BP/RBN - Functions for NON-VA PROVIDER ;11-07-00
;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377,391,400,436,432,476,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point
N IBNPRV
K IBFASTXT
D FULL^VALM1
D EN^VALM("IBCE PRVNVA MAINT")
Q
;
HDR ; -- header code
K VALMHDR
Q
;
INIT ; Initialization
N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
K ^TMP("IBCE_PRVNVA_MAINT",$J)
;
; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1
;
S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
S IBIF=Y
;
INIT1 ;
;
; Begin IB*2.0*436 - RBN
;
;I IBIF="F" D
;. S VALM("TITLE")="Non-VA Lab or Facility Info"
;. K VALM("PROTOCOL")
;. S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
;. I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
;
; End IB*2.0*436 - RBN
;
S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1)
S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
D ^DIC K DIC,DLAYGO
I Y'>0 S VALMQUIT=1 G INITQ
S IBNPRV=+Y
;
; *** Begin IB*2.0*436 - RBN
;
N NEWENTRY
S IBNPRV=+Y,NEWENTRY=$P($G(Y),U,3),IBFLPFLP=0
I 'NEWENTRY D
. N DA,X,Y,DIE,DR
. ;D EN^DDIOL(" ")
. ;D EN^DDIOL("If you do NOT want to edit the provider name or the provider type,","","!")
. ;D EN^DDIOL("then press return at the following NAME prompt. Otherwise,")
. ;D EN^DDIOL("retype the name as you want it entered into the system.")
. ;D EN^DDIOL(" ")
. ;S DA=IBNPRV
. ;S DIE="^IBA(355.93,"
. ;S DR=".01"
. ;D ^DIE
. D SCREEN(IBNPRV)
. I $D(Y) S VALMQUIT=1 G INITQ
. I $G(IBFLPFLP) S IBIF=$S(IBIF="F":"I",1:"F")
;
; *** End IB*2.0*436 - rbn
;
I IBIF="F" D
. S VALM("TITLE")="Non-VA Lab or Facility Info"
. K VALM("PROTOCOL")
. S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
. I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
D BLD^IBCEP8B(IBNPRV)
INITQ Q
;
EXPND ;
Q
;
HELP ;
Q
;
EXIT ;
K ^TMP("IBCE_PRVNVA_MAINT",$J)
D CLEAN^VALM10
K IBFASTXT
Q
;
EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics
; IBNPRV = ien of entry in file 355.93
; IBNOLM = 1 if not called from list manager
;
N DA,X,Y,DIE,DR,IBP
I '$G(IBNOLM) D FULL^VALM1
I IBNPRV D
. I '$G(IBNOLM) D CLEAR^VALM1
. S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
. ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
. ; Begin IB*2.0*436 - RBN
. ;S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
. ;S DR=$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
. ; End IB*2.0*436 - RBN
. ;IB*2.0*432 - add contact phone and name
. S DR=$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;1.01;I X="""" S Y=""@2"";1.02R;S Y=""@3"";@2;1.02;@3;1.03;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")
. D ^DIE
. I 'IBP D
. . S DR=".17" D ^DIE
. . I X="Y" D ;If sole proprietor, prompt for pointer to #355.93
. . . S DR=".18" D ^DIE
. . . N NPIDEF S NPIDEF=$P($G(^IBA(355.93,IBNPRV,0)),U,14)
. . I X="N" D ;If not sole proprietor, clear sole proprietor pointer to #355.93
. . . S DR=".18////@" D ^DIE
. ;IB*2.0*476 - Add FEE BASIS allow multiple value
. S DR="D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"");D FBTGLSET^IBCEP8C1(IBNPRV)"
. D ^DIE
. Q:$G(IBNOLM)
. D BLD^IBCEP8B(IBNPRV)
I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
Q
;
EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids
; This entry point is called by 4 action protocols.
; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
; IBSLEV = 1 for facility/provider own ID's
; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
;
Q:'$G(IBNPRV)
Q:'$G(IBSLEV)
N IBPRV,IBIF
D FULL^VALM1 ; set full scrolling region
D CLEAR^VALM1 ; clear screen
S IBPRV=IBNPRV
;
K IBFASTXT
S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") ; 1=facility/group 2=individual
D EN^VALM("IBCE PRVPRV MAINT")
;
K VALMQUIT
S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
Q
;
NVAFAC ; Enter/edit Non-VA facility information
; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
N X,Y,DA,DIC,IBNPRV,DLAYGO
S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
D ^DIC K DIC,DLAYGO
I Y'>0 S VALMQUIT=1 G NVAFACQ
S IBNPRV=+Y
D EDIT1(IBNPRV,1)
;
NVAFACQ Q
;
GETFAC(IB,IBFILE,IBELE,CSZLEN) ; Returns facility name, address lines or city-state-zip
; IB = ien of entry in file
; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
; If IBELE = 0, returns name
; = 1, returns address line 1
; = 2, returns address line 2
; = 12, returns address lines 1 and 2 together
; = 3, returns city, state zip
; = "3C", returns city = "3S", state = "3Z", zip
; CSZLEN = max length allowed for city,st,zip string - Only applies when IBELE=3
;
N Z,IBX,IC,IS,IZ,DIFF
S IBX=""
;
S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
;
I +IBELE=3 D
. I 'IBFILE S IC=$P(Z,U,3),IS=$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)),IZ=$P(Z,U,4)
. I IBFILE S IC=$P(Z,U,6),IS=$$STATE^IBCEFG1($P(Z,U,7)),IZ=$P(Z,U,8)
. ;
. I IBELE="3C" S IBX=IC Q
. I IBELE="3S" S IBX=IS Q
. I IBELE="3Z" S IBX=IZ Q
. ;
. S IBX=$$CSZ(IC,IS,IZ,+$G(CSZLEN)) ; build the city, st zip string since IBELE=3 here
. Q
;
GETFACX ;
Q IBX
;
CSZ(IC,IS,IZ,CSZLEN) ; build city, state, zip string
; IC - city
; IS - state abbreviation
; IZ - zip
; CSZLEN - max length allowed for city, st zip string
;
NEW IBX,DIFF
;
; build the full city, st zip string
S IBX=IC_$S(IC'="":", ",1:"")_IS_" "_IZ
;
I '$G(CSZLEN) G CSZX ; no max length to worry about
I $L(IBX)'>CSZLEN G CSZX ; length is OK so get out
;
; string is too long so try to shorten the zip if it has a dash
I IZ["-" S IZ=$P(IZ,"-",1),IBX=IC_$S(IC'="":", ",1:"")_IS_" "_IZ I $L(IBX)'>CSZLEN G CSZX
;
; string is still too long so truncate the city name until it fits
S DIFF=$L(IBX)-CSZLEN
S IC=$E(IC,1,$L(IC)-DIFF)
S IBX=IC_$S(IC'="":", ",1:"")_IS_" "_IZ
CSZX ;
Q IBX
;
ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
; for all provider id types or for id type in IBPTYP
; IBPRV = vp ien of provider
; IBPTYP = ien of provider id type to return or "" for all
; IBZ = array returned with internal data:
; IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
N Z,Z0
K IBZ
G:'$G(IBPRV) ALLIDQ
S IBPTYP=$G(IBPTYP)
S Z=0 F S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z S Z0=$G(^IBA(355.9,Z,0)) D
. I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3)
;
ALLIDQ Q
;
CLIA() ; Returns ien of CLIA # provider id type
N Z,IBZ
S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q
Q IBZ
;
STLIC() ; Returns ien of STLIC# provider id type
N Z,IBZ
S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,3) S IBZ=Z Q
Q IBZ
;
TAXID() ; Returns ien of Fed tax id provider id type
N Z,IBZ
S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,4) S IBZ=Z Q
Q IBZ
;
CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN
N IBCLIA,IBZ,IBNVA,Z
S IBCLIA="",IBZ=$$CLIA()
I IBZ D
. S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
. S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
Q IBCLIA
;
VALFAC(X) ; Function returns 1 if format is valid for X12 facility name
; Alpha/numeric/certain punctuation valid. Must start with an Alpha
N OK,VAL
S OK=1
S VAL("A")="",VAL("N")="",VAL=",.- "
I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
Q OK
;
VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not
; X = data to be examined
; VAL = a 'string' of valid characters AND/OR (passed by reference)
; if VAL("A") defined ==> Alpha
; if VAL("A") defined ==> Numeric valid
; if VAL("A") defined ==> Punctuation valid
; any other character included in the string is checked individually
N Z
I $D(VAL("A")) D
. N Z0
. F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
. S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
I $D(VAL("N")) D
. N Z0
. F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
. S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
I $D(VAL("P")) D
. N Z0
. F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
. S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
I $G(VAL)'="" S X=$TR(X,VAL,"")
Q (X="")
;
PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
;
Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
;
; Pass in the Internal Entry number to File 355.93
; Return the Primary ID and Qualifier (ID Type) from 355.9
PRIMID(IEN35593) ; Return External Primary ID and ID Quailier
N INDXVAL,LIST,MSG,IDCODE
S INDXVAL=IEN35593_";IBA(355.93,"
N SCREEN S SCREEN="I $P(^(0),U,8)"
D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
I '+$G(LIST("DILIST",0)) Q "" ; No Primary ID
I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***" ; Bad. More than one.
; Found just one
S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E"))
;
; Begin IB*2.0*436 - RBN
;
PRVFMT ; called only by the INPUT TRANSFORM of #355.93,.01
; no other calls are allowed to this tag
;
; DSS/SCR 032812 PATCH 476 : Modified to support FB PAID TO IB background job
;
; DESCRIPTION : Sets the NAME (.01) and the ENTITY TYPE (.02) fields
; of file 355.93. Allows the user to change the ENTITY
; TYPE and forces reentry of the provider data so
; that it matches the ENTITY TYPE,if changes are being
; made through IB menues. Also formats the
; NAME to correspond to the ENTITY TYPE. Disallows
; changing of the NAME field from ANYWHERE other than
; PROVIDER ID MAINTENANCE or IB EDIT BILLING INFO
; (billing screens) or FB AUTO INTERFACE TO IB.
; Adding new entries directly from FileMan is no longer permitted.
;
; INPUTS : Variables set by user selected option, screen actions
; and user input:
; X - Provider name passed in by .01 field input
; transform.
; XQY0 - IB option selected by the user OR "FB PAID TO IB"
; DA - IEN of the record selected by the user or provided
; by the OPTION: FB PAID TO IB
; IBNVPMIF - ENTITY TYPE flag passed in from ListManager or provided
; by the OPTION: FB PAID TO IB
; (F=Facility,I=Individual).
; IBSCNN - IB variable indication of the actions/submenu:
; #3, #4, and #7 found on bill screen #8 OR "" for FB PAID TO IB
;
; OUTPUTS : IBFLPFLP - Indicate that the user is changing the
; ENTITY TYPE (flip flop). Possible states:
;
; IBFLPFLP = 0 - The type was not changed.
; = 1 - The type changed to facility type.
; = 2 - The type changed to individual type.
;
;
; GLOBALS : ^IBA(355.93 - IB NON/OTHER VA BILLING PROVIDER file
;
;
;
N OKRTN,IBNAM,IBCEPDA,IBTYPE
S (IBFLPFLP,OKRTN)=0,IBNAM=X,IBCEPDA=$G(DA)
;
; Prevent modification of NAME (#.01) in file #355.93 from anywhere
; but the PROVIDER ID MAINTENANCE or IB EDIT BILLING INFO screens.
;
I $P($G(XQY0),U,1)="IB EDIT BILLING INFO" D PRVINIT,PRVMANT S OKRTN=1
I $P($G(XQY0),U,1)="IBCE PROVIDER MAINT" D PRVINIT,PRVMANT S OKRTN=1
;
I $P($G(XQY0),U,1)="IB AUTO INTERFACE FROM FB" D EPTRANS^IBCEP8C() S OKRTN=1 ;IB*2.0*476
;
I 'OKRTN K X
Q
;==========================
PRVINIT ; initialization
;
; If arriving from the billing screens (IBSCNN is 3 or 4) the
; variable DA is the ien of the bill (file #399) - need to find the ien
; of 355.93 of the provider that the user entered/selected
;
; *** Begin IB*2.0*436 -RBN ***
;I $G(IBSCNN)=3!($G(IBSCNN)=4) S IBCEPDA=$O(^IBA(355.93,"B",IBNAM,"")),IBTYPE=$S(IBSCNN=3:2,1:1)
I $G(IBDR20),'$G(IBCEP6FL) S IBCEPDA=$O(^IBA(355.93,"B",IBNAM,"")),IBTYPE=$S(IBDR20=84:1,IBDR20=104:1,1:2)
; *** End IB*2.0*436 -RBN ***
;
; If arriving from the Provider ID Maintenance call (billing screen or
; direct call to the option) & the user entered a brand new record, the
; IBNVPMIF variable is set to indicate if the user was entering a
; Non-VA facility ("F") or a Non-VA Provider (ie. individual) ("I")
I '$G(IBCEPDA)&$D(IBNVPMIF) S IBTYPE=$S(IBNVPMIF="F":1,1:2)
;
; If arriving from the Provider ID Maintenance call (billing screen or
; direct call to the option) & the user selected an existing record
I $G(IBCEPDA) S IBTYPE=$P($G(^IBA(355.93,IBCEPDA,0)),U,2)
Q
;----------------------------
PRVMANT ; is the user flipping the provider type (for existing records only)
N TXT,TXT2,%
;
; IBTYPE - based on the current value of provider type (#355.93,.02)
; where "1" = Facility/Group & "2" = Individual
;
I '$G(IBTYPE) Q ; one of the calls that triggers this routine needs
; ; this check when creating a new record in file #355.93
;
; If record is not brand new (IBCEPDA exists) - give the user the
; opportunity to change the provider type field (#355.93,.02)
I IBTYPE,$G(IBCEPDA) D
. ;
. S %=2 ; Default answer is no
. ;
. I IBTYPE=1 S TXT="Facility",TXT2="Individual/Provider"
. I IBTYPE=2 S TXT="Individual/Provider",TXT2="Facility"
. ;
. D EN^DDIOL("This provider name exists and is a "_TXT_".","","!")
. D EN^DDIOL("Do you want to change this record to be a "_TXT2)
. ;
. D YN^DICN
. ;
. I %=1 D
. . ;
. . S IBTYPE=$S(IBTYPE=1:2,1:1),IBFLPFLP=IBTYPE
;
I IBTYPE=2 D STDNAME^XLFNAME(.IBNAM,"GP") S X=IBNAM
I IBTYPE=1,('$$VALFAC^IBCEP8(IBNAM)) K X
Q
;
; DESCRIPTION: This routine inputs a provider name and formats it appropriately as an
; individual or a facility name.
;
; INPUTS : name
;
; OUTPUTS : formatted name and provider type
;
; VARIABLES :
;
; GLOBALS :
;
; FUNCTIONS : None
;
; SUBROUTINES :
;
; HISTORY : Original version - 21 September 2010
;
SCREEN(IBNPRV) ;
N IBNPRVN,IBNAME,DR,DIR,DA,DIRUT,X,DTOUT,DUOUT
S IBNPRVN=""
D EN^DDIOL(" ")
D EN^DDIOL("If you do NOT want to edit the provider name or the provider type,","","!")
D EN^DDIOL("then press return at the following NAME prompt. Otherwise,")
D EN^DDIOL("retype the name as you want it entered into the system.")
D EN^DDIOL(" ")
;
; Get the current provider name
;
S IBNAME=$P(^IBA(355.93,IBNPRV,0),U,1)
;
; Get the user's input
;
INPUT ;
S DIR(0)="FOUr^3:30"
S DIR("A")="NAME: "_IBNAME_"//"
;
S DIR("?")=" "
S DIR("?",1)="Press <ENTER> to accept the displayed provider name"
S DIR("?",2)="or enter the name as you would like it displayed."
;
S DIR("??")="IB PROV ID MAINT^"
;
D ^DIR
;
Q:$D(DTOUT)!$D(DUOUT)
I X["?" G INPUT
S:'$D(DIRUT) IBNPRVN=X
; The user entered something else
;
S DIE="^IBA(355.93,"
S DA=IBNPRV
S DR=".01///"_IBNPRVN
D ^DIE
Q
;
; End IB*2.0*436 - RBN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP8 16879 printed Oct 16, 2024@18:12:28 Page 2
IBCEP8 ;ALB/TMP/OIFO-BP/RBN - Functions for NON-VA PROVIDER ;11-07-00
+1 ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377,391,400,436,432,476,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point
+1 NEW IBNPRV
+2 KILL IBFASTXT
+3 DO FULL^VALM1
+4 DO EN^VALM("IBCE PRVNVA MAINT")
+5 QUIT
+6 ;
HDR ; -- header code
+1 KILL VALMHDR
+2 QUIT
+3 ;
INIT ; Initialization
+1 NEW DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
+2 KILL ^TMP("IBCE_PRVNVA_MAINT",$JOB)
+3 ;
+4 ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
+5 IF $GET(IBNVPMIF)'=""
SET IBIF=IBNVPMIF
GOTO INIT1
+6 ;
+7 SET DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: "
SET DIR(0)="SA^I:INDIVIDUAL;F:FACILITY"
DO ^DIR
KILL DIR
+8 IF $DATA(DUOUT)!$DATA(DTOUT)
SET VALMQUIT=1
GOTO INITQ
+9 SET IBIF=Y
+10 ;
INIT1 ;
+1 ;
+2 ; Begin IB*2.0*436 - RBN
+3 ;
+4 ;I IBIF="F" D
+5 ;. S VALM("TITLE")="Non-VA Lab or Facility Info"
+6 ;. K VALM("PROTOCOL")
+7 ;. S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
+8 ;. I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
+9 ;
+10 ; End IB*2.0*436 - RBN
+11 ;
+12 SET DIC="^IBA(355.93,"
SET DIC("DR")=".02///"_$SELECT(IBIF'="F":2,1:1)
+13 SET DIC("S")="I $P(^(0),U,2)="_$SELECT(IBIF'="F":2,1:1)
+14 SET DLAYGO=355.93
SET DIC(0)="AELMQ"
SET DIC("A")="Select a NON"_$SELECT(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
+15 DO ^DIC
KILL DIC,DLAYGO
+16 IF Y'>0
SET VALMQUIT=1
GOTO INITQ
+17 SET IBNPRV=+Y
+18 ;
+19 ; *** Begin IB*2.0*436 - RBN
+20 ;
+21 NEW NEWENTRY
+22 SET IBNPRV=+Y
SET NEWENTRY=$PIECE($GET(Y),U,3)
SET IBFLPFLP=0
+23 IF 'NEWENTRY
Begin DoDot:1
+24 NEW DA,X,Y,DIE,DR
+25 ;D EN^DDIOL(" ")
+26 ;D EN^DDIOL("If you do NOT want to edit the provider name or the provider type,","","!")
+27 ;D EN^DDIOL("then press return at the following NAME prompt. Otherwise,")
+28 ;D EN^DDIOL("retype the name as you want it entered into the system.")
+29 ;D EN^DDIOL(" ")
+30 ;S DA=IBNPRV
+31 ;S DIE="^IBA(355.93,"
+32 ;S DR=".01"
+33 ;D ^DIE
+34 DO SCREEN(IBNPRV)
+35 IF $DATA(Y)
SET VALMQUIT=1
GOTO INITQ
+36 IF $GET(IBFLPFLP)
SET IBIF=$SELECT(IBIF="F":"I",1:"F")
End DoDot:1
+37 ;
+38 ; *** End IB*2.0*436 - rbn
+39 ;
+40 IF IBIF="F"
Begin DoDot:1
+41 SET VALM("TITLE")="Non-VA Lab or Facility Info"
+42 KILL VALM("PROTOCOL")
+43 SET Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
+44 IF Y
SET VALM("PROTOCOL")=+Y_";ORD(101,"
End DoDot:1
+45 DO BLD^IBCEP8B(IBNPRV)
INITQ QUIT
+1 ;
EXPND ;
+1 QUIT
+2 ;
HELP ;
+1 QUIT
+2 ;
EXIT ;
+1 KILL ^TMP("IBCE_PRVNVA_MAINT",$JOB)
+2 DO CLEAN^VALM10
+3 KILL IBFASTXT
+4 QUIT
+5 ;
EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics
+1 ; IBNPRV = ien of entry in file 355.93
+2 ; IBNOLM = 1 if not called from list manager
+3 ;
+4 NEW DA,X,Y,DIE,DR,IBP
+5 IF '$GET(IBNOLM)
DO FULL^VALM1
+6 IF IBNPRV
Begin DoDot:1
+7 IF '$GET(IBNOLM)
DO CLEAR^VALM1
+8 SET DIE="^IBA(355.93,"
SET DA=IBNPRV
SET IBP=($PIECE($GET(^IBA(355.93,IBNPRV,0)),U,2)=2)
+9 ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
+10 ; Begin IB*2.0*436 - RBN
+11 ;S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
+12 ;S DR=$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
+13 ; End IB*2.0*436 - RBN
+14 ;IB*2.0*432 - add contact phone and name
+15 SET DR=$SELECT(IBP:".03;.04",1:".05;.1;.06;.07;.08;1.01;I X="""" S Y=""@2"";1.02R;S Y=""@3"";@2;1.02;@3;1.03;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")
+16 DO ^DIE
+17 IF 'IBP
Begin DoDot:2
+18 SET DR=".17"
DO ^DIE
+19 ;If sole proprietor, prompt for pointer to #355.93
IF X="Y"
Begin DoDot:3
+20 SET DR=".18"
DO ^DIE
+21 NEW NPIDEF
SET NPIDEF=$PIECE($GET(^IBA(355.93,IBNPRV,0)),U,14)
End DoDot:3
+22 ;If not sole proprietor, clear sole proprietor pointer to #355.93
IF X="N"
Begin DoDot:3
+23 SET DR=".18////@"
DO ^DIE
End DoDot:3
End DoDot:2
+24 ;IB*2.0*476 - Add FEE BASIS allow multiple value
+25 SET DR="D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"");D FBTGLSET^IBCEP8C1(IBNPRV)"
+26 DO ^DIE
+27 if $GET(IBNOLM)
QUIT
+28 DO BLD^IBCEP8B(IBNPRV)
End DoDot:1
+29 IF '$GET(IBNOLM)
KILL VALMBCK
SET VALMBCK="R"
+30 QUIT
+31 ;
EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids
+1 ; This entry point is called by 4 action protocols.
+2 ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
+3 ; IBSLEV = 1 for facility/provider own ID's
+4 ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
+5 ;
+6 if '$GET(IBNPRV)
QUIT
+7 if '$GET(IBSLEV)
QUIT
+8 NEW IBPRV,IBIF
+9 ; set full scrolling region
DO FULL^VALM1
+10 ; clear screen
DO CLEAR^VALM1
+11 SET IBPRV=IBNPRV
+12 ;
+13 KILL IBFASTXT
+14 ; 1=facility/group 2=individual
SET IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")
+15 DO EN^VALM("IBCE PRVPRV MAINT")
+16 ;
+17 KILL VALMQUIT
+18 SET VALMBCK=$SELECT($GET(IBFASTXT)'="":"Q",1:"R")
+19 QUIT
+20 ;
NVAFAC ; Enter/edit Non-VA facility information
+1 ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
+2 NEW X,Y,DA,DIC,IBNPRV,DLAYGO
+3 SET DIC="^IBA(355.93,"
SET DIC("S")="I $P(^(0),U,2)=1"
SET DIC("DR")=".02///1"
+4 SET DLAYGO=355.93
SET DIC(0)="AELMQ"
SET DIC("A")="Select a NON/Other VA FACILITY: "
+5 DO ^DIC
KILL DIC,DLAYGO
+6 IF Y'>0
SET VALMQUIT=1
GOTO NVAFACQ
+7 SET IBNPRV=+Y
+8 DO EDIT1(IBNPRV,1)
+9 ;
NVAFACQ QUIT
+1 ;
GETFAC(IB,IBFILE,IBELE,CSZLEN) ; Returns facility name, address lines or city-state-zip
+1 ; IB = ien of entry in file
+2 ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
+3 ; If IBELE = 0, returns name
+4 ; = 1, returns address line 1
+5 ; = 2, returns address line 2
+6 ; = 12, returns address lines 1 and 2 together
+7 ; = 3, returns city, state zip
+8 ; = "3C", returns city = "3S", state = "3Z", zip
+9 ; CSZLEN = max length allowed for city,st,zip string - Only applies when IBELE=3
+10 ;
+11 NEW Z,IBX,IC,IS,IZ,DIFF
+12 SET IBX=""
+13 ;
+14 SET Z=$SELECT('IBFILE:$GET(^DIC(4,+IB,1)),1:$GET(^IBA(355.93,+IB,0)))
+15 IF +IBELE=0
SET IBX=$SELECT('IBFILE:$PIECE($GET(^DIC(4,+IB,0)),U),1:$PIECE($GET(^IBA(355.93,+IB,0)),U))
+16 IF IBELE=1!(IBELE=12)
SET IBX=$SELECT('IBFILE:$PIECE(Z,U),1:$PIECE(Z,U,5))
+17 IF IBELE=2!(IBELE=12)
SET IBX=$SELECT(IBELE=12:IBX_" ",1:"")_$SELECT('IBFILE:$PIECE(Z,U,2),1:$PIECE(Z,U,10))
+18 ;
+19 IF +IBELE=3
Begin DoDot:1
+20 IF 'IBFILE
SET IC=$PIECE(Z,U,3)
SET IS=$$STATE^IBCEFG1($PIECE($GET(^DIC(4,+IB,0)),U,2))
SET IZ=$PIECE(Z,U,4)
+21 IF IBFILE
SET IC=$PIECE(Z,U,6)
SET IS=$$STATE^IBCEFG1($PIECE(Z,U,7))
SET IZ=$PIECE(Z,U,8)
+22 ;
+23 IF IBELE="3C"
SET IBX=IC
QUIT
+24 IF IBELE="3S"
SET IBX=IS
QUIT
+25 IF IBELE="3Z"
SET IBX=IZ
QUIT
+26 ;
+27 ; build the city, st zip string since IBELE=3 here
SET IBX=$$CSZ(IC,IS,IZ,+$GET(CSZLEN))
+28 QUIT
End DoDot:1
+29 ;
GETFACX ;
+1 QUIT IBX
+2 ;
CSZ(IC,IS,IZ,CSZLEN) ; build city, state, zip string
+1 ; IC - city
+2 ; IS - state abbreviation
+3 ; IZ - zip
+4 ; CSZLEN - max length allowed for city, st zip string
+5 ;
+6 NEW IBX,DIFF
+7 ;
+8 ; build the full city, st zip string
+9 SET IBX=IC_$SELECT(IC'="":", ",1:"")_IS_" "_IZ
+10 ;
+11 ; no max length to worry about
IF '$GET(CSZLEN)
GOTO CSZX
+12 ; length is OK so get out
IF $LENGTH(IBX)'>CSZLEN
GOTO CSZX
+13 ;
+14 ; string is too long so try to shorten the zip if it has a dash
+15 IF IZ["-"
SET IZ=$PIECE(IZ,"-",1)
SET IBX=IC_$SELECT(IC'="":", ",1:"")_IS_" "_IZ
IF $LENGTH(IBX)'>CSZLEN
GOTO CSZX
+16 ;
+17 ; string is still too long so truncate the city name until it fits
+18 SET DIFF=$LENGTH(IBX)-CSZLEN
+19 SET IC=$EXTRACT(IC,1,$LENGTH(IC)-DIFF)
+20 SET IBX=IC_$SELECT(IC'="":", ",1:"")_IS_" "_IZ
CSZX ;
+1 QUIT IBX
+2 ;
ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
+1 ; for all provider id types or for id type in IBPTYP
+2 ; IBPRV = vp ien of provider
+3 ; IBPTYP = ien of provider id type to return or "" for all
+4 ; IBZ = array returned with internal data:
+5 ; IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
+6 NEW Z,Z0
+7 KILL IBZ
+8 if '$GET(IBPRV)
GOTO ALLIDQ
+9 SET IBPTYP=$GET(IBPTYP)
+10 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.9,"B",IBPRV,Z))
if 'Z
QUIT
SET Z0=$GET(^IBA(355.9,Z,0))
Begin DoDot:1
+11 IF $SELECT(IBPTYP="":1,1:($PIECE(Z0,U,6)=IBPTYP))
SET IBZ(Z)=($PIECE(Z0,U,6)_U_$PIECE(Z0,U,7)_U_$PIECE(Z0,U,2)_U_$PIECE(Z0,U,4)_U_$PIECE(Z0,U,5)_U_$PIECE(Z0,U,3))_U_$PIECE($GET(^IBE(355.97,+$PIECE(Z0,U,6),0)),U,3)
End DoDot:1
+12 ;
ALLIDQ QUIT
+1 ;
CLIA() ; Returns ien of CLIA # provider id type
+1 NEW Z,IBZ
+2 SET (IBZ,Z)=0
FOR
SET Z=$ORDER(^IBE(355.97,Z))
if 'Z
QUIT
IF $PIECE($GET(^(Z,0)),U,3)="X4"
IF $PIECE(^(0),U)["CLIA"
SET IBZ=Z
QUIT
+3 QUIT IBZ
+4 ;
STLIC() ; Returns ien of STLIC# provider id type
+1 NEW Z,IBZ
+2 SET (IBZ,Z)=0
FOR
SET Z=$ORDER(^IBE(355.97,Z))
if 'Z
QUIT
IF $PIECE($GET(^(Z,1)),U,3)
SET IBZ=Z
QUIT
+3 QUIT IBZ
+4 ;
TAXID() ; Returns ien of Fed tax id provider id type
+1 NEW Z,IBZ
+2 SET (IBZ,Z)=0
FOR
SET Z=$ORDER(^IBE(355.97,Z))
if 'Z
QUIT
IF $PIECE($GET(^(Z,1)),U,4)
SET IBZ=Z
QUIT
+3 QUIT IBZ
+4 ;
CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN
+1 NEW IBCLIA,IBZ,IBNVA,Z
+2 SET IBCLIA=""
SET IBZ=$$CLIA()
+3 IF IBZ
Begin DoDot:1
+4 SET IBNVA=$PIECE($GET(^DGCR(399,IBIFN,"U2")),U,10)
if 'IBNVA
QUIT
+5 SET IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
End DoDot:1
+6 QUIT IBCLIA
+7 ;
VALFAC(X) ; Function returns 1 if format is valid for X12 facility name
+1 ; Alpha/numeric/certain punctuation valid. Must start with an Alpha
+2 NEW OK,VAL
+3 SET OK=1
+4 SET VAL("A")=""
SET VAL("N")=""
SET VAL=",.- "
+5 IF $EXTRACT(X)'?1A!'$$VALFMT(X,.VAL)
SET OK=0
+6 QUIT OK
+7 ;
VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not
+1 ; X = data to be examined
+2 ; VAL = a 'string' of valid characters AND/OR (passed by reference)
+3 ; if VAL("A") defined ==> Alpha
+4 ; if VAL("A") defined ==> Numeric valid
+5 ; if VAL("A") defined ==> Punctuation valid
+6 ; any other character included in the string is checked individually
+7 NEW Z
+8 IF $DATA(VAL("A"))
Begin DoDot:1
+9 NEW Z0
+10 FOR Z=1:1:$LENGTH(X)
IF $EXTRACT(X,Z)?1A
SET Z0(Z)=""
+11 SET Z0=""
FOR
SET Z0=$ORDER(Z0(Z0),-1)
if 'Z0
QUIT
SET $EXTRACT(X,Z0)=""
End DoDot:1
+12 IF $DATA(VAL("N"))
Begin DoDot:1
+13 NEW Z0
+14 FOR Z=1:1:$LENGTH(X)
IF $EXTRACT(X,Z)?1N
SET Z0(Z)=""
+15 SET Z0=""
FOR
SET Z0=$ORDER(Z0(Z0),-1)
if 'Z0
QUIT
SET $EXTRACT(X,Z0)=""
End DoDot:1
+16 IF $DATA(VAL("P"))
Begin DoDot:1
+17 NEW Z0
+18 FOR Z=1:1:$LENGTH(X)
IF $EXTRACT(X,Z)?1P
SET Z0(Z)=""
+19 SET Z0=""
FOR
SET Z0=$ORDER(Z0(Z0),-1)
if 'Z0
QUIT
SET $EXTRACT(X,Z0)=""
End DoDot:1
+20 IF $GET(VAL)'=""
SET X=$TRANSLATE(X,VAL,"")
+21 QUIT (X="")
+22 ;
PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
+1 ;
+2 QUIT $SELECT($GET(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
+3 ;
+4 ; Pass in the Internal Entry number to File 355.93
+5 ; Return the Primary ID and Qualifier (ID Type) from 355.9
PRIMID(IEN35593) ; Return External Primary ID and ID Quailier
+1 NEW INDXVAL,LIST,MSG,IDCODE
+2 SET INDXVAL=IEN35593_";IBA(355.93,"
+3 NEW SCREEN
SET SCREEN="I $P(^(0),U,8)"
+4 DO FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
+5 ; No Primary ID
IF '+$GET(LIST("DILIST",0))
QUIT ""
+6 ; Bad. More than one.
IF +$GET(LIST("DILIST",0))>1
QUIT "***ERROR***^***ERROR***"
+7 ; Found just one
+8 SET IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
+9 QUIT $GET(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$GET(LIST("DILIST","ID",1,.06,"E"))
+10 ;
+11 ; Begin IB*2.0*436 - RBN
+12 ;
PRVFMT ; called only by the INPUT TRANSFORM of #355.93,.01
+1 ; no other calls are allowed to this tag
+2 ;
+3 ; DSS/SCR 032812 PATCH 476 : Modified to support FB PAID TO IB background job
+4 ;
+5 ; DESCRIPTION : Sets the NAME (.01) and the ENTITY TYPE (.02) fields
+6 ; of file 355.93. Allows the user to change the ENTITY
+7 ; TYPE and forces reentry of the provider data so
+8 ; that it matches the ENTITY TYPE,if changes are being
+9 ; made through IB menues. Also formats the
+10 ; NAME to correspond to the ENTITY TYPE. Disallows
+11 ; changing of the NAME field from ANYWHERE other than
+12 ; PROVIDER ID MAINTENANCE or IB EDIT BILLING INFO
+13 ; (billing screens) or FB AUTO INTERFACE TO IB.
+14 ; Adding new entries directly from FileMan is no longer permitted.
+15 ;
+16 ; INPUTS : Variables set by user selected option, screen actions
+17 ; and user input:
+18 ; X - Provider name passed in by .01 field input
+19 ; transform.
+20 ; XQY0 - IB option selected by the user OR "FB PAID TO IB"
+21 ; DA - IEN of the record selected by the user or provided
+22 ; by the OPTION: FB PAID TO IB
+23 ; IBNVPMIF - ENTITY TYPE flag passed in from ListManager or provided
+24 ; by the OPTION: FB PAID TO IB
+25 ; (F=Facility,I=Individual).
+26 ; IBSCNN - IB variable indication of the actions/submenu:
+27 ; #3, #4, and #7 found on bill screen #8 OR "" for FB PAID TO IB
+28 ;
+29 ; OUTPUTS : IBFLPFLP - Indicate that the user is changing the
+30 ; ENTITY TYPE (flip flop). Possible states:
+31 ;
+32 ; IBFLPFLP = 0 - The type was not changed.
+33 ; = 1 - The type changed to facility type.
+34 ; = 2 - The type changed to individual type.
+35 ;
+36 ;
+37 ; GLOBALS : ^IBA(355.93 - IB NON/OTHER VA BILLING PROVIDER file
+38 ;
+39 ;
+40 ;
+41 NEW OKRTN,IBNAM,IBCEPDA,IBTYPE
+42 SET (IBFLPFLP,OKRTN)=0
SET IBNAM=X
SET IBCEPDA=$GET(DA)
+43 ;
+44 ; Prevent modification of NAME (#.01) in file #355.93 from anywhere
+45 ; but the PROVIDER ID MAINTENANCE or IB EDIT BILLING INFO screens.
+46 ;
+47 IF $PIECE($GET(XQY0),U,1)="IB EDIT BILLING INFO"
DO PRVINIT
DO PRVMANT
SET OKRTN=1
+48 IF $PIECE($GET(XQY0),U,1)="IBCE PROVIDER MAINT"
DO PRVINIT
DO PRVMANT
SET OKRTN=1
+49 ;
+50 ;IB*2.0*476
IF $PIECE($GET(XQY0),U,1)="IB AUTO INTERFACE FROM FB"
DO EPTRANS^IBCEP8C()
SET OKRTN=1
+51 ;
+52 IF 'OKRTN
KILL X
+53 QUIT
+54 ;==========================
PRVINIT ; initialization
+1 ;
+2 ; If arriving from the billing screens (IBSCNN is 3 or 4) the
+3 ; variable DA is the ien of the bill (file #399) - need to find the ien
+4 ; of 355.93 of the provider that the user entered/selected
+5 ;
+6 ; *** Begin IB*2.0*436 -RBN ***
+7 ;I $G(IBSCNN)=3!($G(IBSCNN)=4) S IBCEPDA=$O(^IBA(355.93,"B",IBNAM,"")),IBTYPE=$S(IBSCNN=3:2,1:1)
+8 IF $GET(IBDR20)
IF '$GET(IBCEP6FL)
SET IBCEPDA=$ORDER(^IBA(355.93,"B",IBNAM,""))
SET IBTYPE=$SELECT(IBDR20=84:1,IBDR20=104:1,1:2)
+9 ; *** End IB*2.0*436 -RBN ***
+10 ;
+11 ; If arriving from the Provider ID Maintenance call (billing screen or
+12 ; direct call to the option) & the user entered a brand new record, the
+13 ; IBNVPMIF variable is set to indicate if the user was entering a
+14 ; Non-VA facility ("F") or a Non-VA Provider (ie. individual) ("I")
+15 IF '$GET(IBCEPDA)&$DATA(IBNVPMIF)
SET IBTYPE=$SELECT(IBNVPMIF="F":1,1:2)
+16 ;
+17 ; If arriving from the Provider ID Maintenance call (billing screen or
+18 ; direct call to the option) & the user selected an existing record
+19 IF $GET(IBCEPDA)
SET IBTYPE=$PIECE($GET(^IBA(355.93,IBCEPDA,0)),U,2)
+20 QUIT
+21 ;----------------------------
PRVMANT ; is the user flipping the provider type (for existing records only)
+1 NEW TXT,TXT2,%
+2 ;
+3 ; IBTYPE - based on the current value of provider type (#355.93,.02)
+4 ; where "1" = Facility/Group & "2" = Individual
+5 ;
+6 ; one of the calls that triggers this routine needs
IF '$GET(IBTYPE)
QUIT
+7 ; ; this check when creating a new record in file #355.93
+8 ;
+9 ; If record is not brand new (IBCEPDA exists) - give the user the
+10 ; opportunity to change the provider type field (#355.93,.02)
+11 IF IBTYPE
IF $GET(IBCEPDA)
Begin DoDot:1
+12 ;
+13 ; Default answer is no
SET %=2
+14 ;
+15 IF IBTYPE=1
SET TXT="Facility"
SET TXT2="Individual/Provider"
+16 IF IBTYPE=2
SET TXT="Individual/Provider"
SET TXT2="Facility"
+17 ;
+18 DO EN^DDIOL("This provider name exists and is a "_TXT_".","","!")
+19 DO EN^DDIOL("Do you want to change this record to be a "_TXT2)
+20 ;
+21 DO YN^DICN
+22 ;
+23 IF %=1
Begin DoDot:2
+24 ;
+25 SET IBTYPE=$SELECT(IBTYPE=1:2,1:1)
SET IBFLPFLP=IBTYPE
End DoDot:2
End DoDot:1
+26 ;
+27 IF IBTYPE=2
DO STDNAME^XLFNAME(.IBNAM,"GP")
SET X=IBNAM
+28 IF IBTYPE=1
IF ('$$VALFAC^IBCEP8(IBNAM))
KILL X
+29 QUIT
+30 ;
+31 ; DESCRIPTION: This routine inputs a provider name and formats it appropriately as an
+32 ; individual or a facility name.
+33 ;
+34 ; INPUTS : name
+35 ;
+36 ; OUTPUTS : formatted name and provider type
+37 ;
+38 ; VARIABLES :
+39 ;
+40 ; GLOBALS :
+41 ;
+42 ; FUNCTIONS : None
+43 ;
+44 ; SUBROUTINES :
+45 ;
+46 ; HISTORY : Original version - 21 September 2010
+47 ;
SCREEN(IBNPRV) ;
+1 NEW IBNPRVN,IBNAME,DR,DIR,DA,DIRUT,X,DTOUT,DUOUT
+2 SET IBNPRVN=""
+3 DO EN^DDIOL(" ")
+4 DO EN^DDIOL("If you do NOT want to edit the provider name or the provider type,","","!")
+5 DO EN^DDIOL("then press return at the following NAME prompt. Otherwise,")
+6 DO EN^DDIOL("retype the name as you want it entered into the system.")
+7 DO EN^DDIOL(" ")
+8 ;
+9 ; Get the current provider name
+10 ;
+11 SET IBNAME=$PIECE(^IBA(355.93,IBNPRV,0),U,1)
+12 ;
+13 ; Get the user's input
+14 ;
INPUT ;
+1 SET DIR(0)="FOUr^3:30"
+2 SET DIR("A")="NAME: "_IBNAME_"//"
+3 ;
+4 SET DIR("?")=" "
+5 SET DIR("?",1)="Press <ENTER> to accept the displayed provider name"
+6 SET DIR("?",2)="or enter the name as you would like it displayed."
+7 ;
+8 SET DIR("??")="IB PROV ID MAINT^"
+9 ;
+10 DO ^DIR
+11 ;
+12 if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+13 IF X["?"
GOTO INPUT
+14 if '$DATA(DIRUT)
SET IBNPRVN=X
+15 ; The user entered something else
+16 ;
+17 SET DIE="^IBA(355.93,"
+18 SET DA=IBNPRV
+19 SET DR=".01///"_IBNPRVN
+20 DO ^DIE
+21 QUIT
+22 ;
+23 ; End IB*2.0*436 - RBN
+24 ;
