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