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

IBCEP8.m

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