- 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 Jan 18, 2025@03:13 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 ;