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

BHLPRV.m

Go to the documentation of this file. 
  1. BHLPRV ;cmi/sitka/maw  - HL7 provider functions ;  
  1.  ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
  1.  ;
  1.  ;
  1.  ;this routine will return various components of a provider
  1.  ;
  1.  ;F is defined as:
  1.  ;I - returns ien of provider in file 200 or 6
  1.  ;T - returns provider' initials
  1.  ;A - returns internal set of affiliation (e.g. 1)
  1.  ;B - returns external of affiliation (e.g. IHS)
  1.  ;C - returns provider's code
  1.  ;D - returns provider's discipline code (E.G. 01)
  1.  ;E - returns provider's discipline in external format (PHYSICIAN)
  1.  ;F - returns ien of provider's discipline (22)
  1.  ;H - returns provider's dea #
  1.  ;N - returns provider's name in hl7 format
  1.  ;O - returns provider's affl_disc  (e.g. 101 for IHS nurse)
  1.  ;P - returns provider's affl_disc_code (e.g. 101LAB for nurse Lori Ann
  1.  Q
  1.  ;
  1. PROV(P,F) ;EP - provider in many different formats
  1.  NEW %,Y,Z ;IHS/TUCSON/LAB - added ,Z patch 1 5/19/97
  1.  I 'P Q P
  1.  I $P(^AUTTSITE(1,0),U,22),'$D(^VA(200,P)) Q -1
  1.  I '$P(^AUTTSITE(1,0),U,22),'$D(^DIC(6,P)) Q -1
  1.  I $G(F)="" S F="N"
  1.  I F=99 D  Q
  1.  .F I=1:1 S S=$T(@I) Q:S=""  S %="" D @I S $P(BHLV(P),U,I)=%
  1.  I F[";" D  Q
  1.  .F J=1:1 S I=$P(F,";",J) Q:I=""  I I'=99 S %="" D @I S $P(BHLV(P),U,J)=%
  1.  S %="",I=F D @I S $P(BHLV(P),U)=%
  1.  Q %
  1.  ;
  1. I ;EP
  1.  S %=P Q
  1. T ;EP
  1.  S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,1)),U,2),1:$P(^DIC(6,P,0),U,2)) Q
  1. A ;EP
  1.  S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,9999999)),U),1:$P($G(^DIC(6,P,9999999)),U)) Q
  1. B ;EP
  1.  S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,9999999)),U),1:$P($G(^DIC(6,P,9999999)),U))
  1.  Q:%=""
  1.  S %=$$EXTSET^XBFUNC(200,9999999.01,%)
  1.  Q
  1. D ;EP
  1.  D F
  1.  Q:%=""
  1.  S %=$P($G(^DIC(7,%,9999999)),U)
  1.  Q
  1.  ;
  1. E ;EP
  1.  S %=$$VAL^XBDIQ1($S($P(^AUTTSITE(1,0),U,22):200,1:6),P,$S($P(^AUTTSITE(1,0),U,22):53.5,1:2))
  1.  Q
  1. F ;EP
  1.  S %=$$VALI^XBDIQ1($S($P(^AUTTSITE(1,0),U,22):200,1:6),P,$S($P(^AUTTSITE(1,0),U,22):53.5,1:2))
  1.  Q
  1. H ;EP
  1.  S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,"PS")),U,2),1:$P($G(^DIC(6,P,0)),U,3)) Q
  1. C ;EP
  1.  S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,9999999)),U,2),1:$P($G(^DIC(6,P,9999999)),U,2)) Q
  1. N ;EP
  1.  S %=$S($P(^AUTTSITE(1,0),U,22):$$PN^INHUT($P($G(^VA(200,P,0)),U)),1:$$PN^INHUT($P($G(^DIC(16,P,0)),U))) Q
  1. O ;EP
  1.  NEW A D A Q:%=""  S A=%,%="" D D Q:%=""  S %=A_% Q
  1. P ;EP
  1.  NEW A D A Q:%=""  S A=% NEW D D D Q:%=""  S D=%,%="" D C Q:%=""  S %=A_D_% Q
  1. 6 D T Q
  1. 7 D A Q
  1. 8 D B Q
  1. 9 D C Q
  1. 10 D D Q
  1. 11 D E Q
  1. 12 D F Q
  1. 13 D N Q
  1. 14 D O Q
  1. 15 D P Q
  1.  ;