APCLV07 ; IHS/CMI/LAB - provider functions ;
;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
;
PRIMPOV ;EP - primary provider in many different formats
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
I $P(^AUPNVSIT(V,0),U,7)="H" F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPOV(Y,0),U,12)="P" S P=$P(^AUPNVPOV(Y,0),U),Z=Y
I $P(^AUPNVSIT(V,0),U,7)'="H" S Y=$O(^AUPNVPOV("AD",V,0)) I Y S P=$P($G(^AUPNVPOV(Y,0)),U),Z=Y
I 'P Q P
I '$D(^ICD9(P)) Q -1
I $G(F)="" S F="C"
S %="" D @F
Q %
;
SECPOV ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
I '$G(N) Q -1
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
I $P(^AUPNVSIT(V,0),U,7)="H" F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPOV(Y,0),U,12)'="P" S C=C+1 I C=N S P=$P(^AUPNVPOV(Y,0),U),Z=Y
I $P(^AUPNVSIT(V,0),U,7)'="H" S Y=0,C=-1 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AUPNVPOV(Y,0),U),Z=Y
I 'P Q P
I '$D(^ICD9(P)) Q -1
I $G(F)="" S F="C"
S %="" D @F
Q %
;
POV ;EP
NEW Z,C,%,S,I,J
S (C,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y S C=C+1 S APCLV(C)="",P=$P(^AUPNVPOV(Y,0),U),Z=Y D
.I F=99 D Q
..F I=1:1 S S=$T(@I) Q:S="" S %="" D @I S $P(APCLV(C),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(APCLV(C),U,I)=% ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J
.S %="",I=F D @I S $P(APCLV(C),U)=%
.Q
Q
ADMDX ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
S P=$P(^AUPNVINP(Z,0),U,12)
I 'P Q P
I '$D(^ICD9(P)) Q -1
I $G(F)="" S F="C"
S %="" D @F
Q %
;
I ;
S %=P Q
E ;
;S %=$P(^ICD9(P,0),U,3) Q ;cmi/anch/maw 9/12/2007 orig line
S %=$P($$ICDDX^ICDEX(P,,,"I"),U,4) Q ;cmi/anch/maw 9/12/2007 csv
C ;
;S %=$P(^ICD9(P,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
S %=$P($$ICDDX^ICDEX(P,,,"I"),U,2) Q ;cmi/anch/maw 9/12/2007 csv
D ;
S %=$P(^AUPNVPOV(Z,0),U,7) Q
J ;
;S %=$P(^AUPNVPOV(Z,0),U,9) I % S %=$P(^ICD9(%,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
S %=$P(^AUPNVPOV(Z,0),U,9) I % S %=$P($$ICDDX^ICDEX(%),U,2) Q ;cmi/anch/maw 9/12/2007 csc
Q
P ;
S %=$P(^AUPNVPOV(Z,0),U,11) Q
N ;
S %=$$VAL^XBDIQ1(9000010.07,Z,.04)
;S %=$P(^AUPNVPOV(Z,0),U,4) I %,$D(^AUTNPOV(%,0)) S %=$P(^AUTNPOV(%,0),U)
Q
S ;stage
S %=$P(^AUPNVPOV(Z,0),U,5) Q
A ;
NEW I,H,R,L,E,D
;S I=$P(^ICD9(P,0),U) ;cmi/anch/maw 9/12/2007 orig line
S I=$P($$ICDDX^ICDEX(P),U,2) ;cmi/anch/maw 9/12/2007 csv
I $E(I)="E" S %=999 Q
I $E(I)="." D CODE10 G HIGH
S R="09"_($P(I,".")_$P(I,".",2))_" "
I $E(I)="V" S I=9_$E(I,2,9999),I=I-.000001,I="09V"_$E(I,2,9999),I=$P(I,".")_$P(I,".",2)_" " G HIGH
S I="09"_I-.000001
S %="",I="0"_($P(I,".")_$P(I,".",2))_" "
HIGH S H=$O(^AUTTRCD("AH",I)) I H="" S %=999 Q
S D=$O(^AUTTRCD("AH",H,"")) I D="" S %="" Q
S E=$O(^AUTTRCD("AH",H,D,""))
S L=$P(^AUTTRCD(D,11,E,0),U)_" "
I L]R S %=999 Q
S %=$P(^AUTTRCD(D,0),U)
Q
CODE10 ;
S R="10"_$P(I,".",2)_" "
S I="10"_I,I=I-.000001,I=$P(I,".")_$P(I,".",2)_" "
Q
;
1 ;
S %=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3),"I")
Q
2 ;
S %=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3),"S")
Q
3 ;
S %=$P(^AUPNVPOV(Y,0),U,2)
Q
4 ;
S %=$$PATIENT^APCLV($P(^AUPNVPOV(Y,0),U,3),"E")
Q
5 ;
S %=Y
Q
6 D E Q
7 D C Q
8 D A Q
9 D D Q
10 S %=$$VAL^XBDIQ1(9000010.07,Y,.07) Q
11 D J Q
12 D P Q
13 S %=$$VAL^XBDIQ1(9000010.07,Y,.11) Q
14 D N Q
15 S %=$P(^AUPNVPOV(Y,0),U,12) Q
16 S %=$$VAL^XBDIQ1(9000010.07,Y,.12) Q
17 S %=$$VAL^XBDIQ1(9000010.07,Y,.13) Q
18 S %=$$VAL^XBDIQ1(9000010.07,Y,.05) Q
19 S %=$$VALI^XBDIQ1(9000010.07,Y,.06) Q
20 S %=$$VAL^XBDIQ1(9000010.07,Y,.06) Q
APCLV07 ; IHS/CMI/LAB - provider functions ;
+1 ;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
+2 ;
PRIMPOV ;EP - primary provider in many different formats
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,P,C,Z
+4 SET (Z,P)=""
SET (Y,C)=0
+5 IF $PIECE(^AUPNVSIT(V,0),U,7)="H"
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
IF $PIECE(^AUPNVPOV(Y,0),U,12)="P"
SET P=$PIECE(^AUPNVPOV(Y,0),U)
SET Z=Y
+6 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
SET Y=$ORDER(^AUPNVPOV("AD",V,0))
IF Y
SET P=$PIECE($GET(^AUPNVPOV(Y,0)),U)
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^ICD9(P))
QUIT -1
+9 IF $GET(F)=""
SET F="C"
+10 SET %=""
DO @F
+11 QUIT %
+12 ;
SECPOV ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 IF '$GET(N)
QUIT -1
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 IF $PIECE(^AUPNVSIT(V,0),U,7)="H"
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
IF $PIECE(^AUPNVPOV(Y,0),U,12)'="P"
SET C=C+1
IF C=N
SET P=$PIECE(^AUPNVPOV(Y,0),U)
SET Z=Y
+7 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
SET Y=0
SET C=-1
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AUPNVPOV(Y,0),U)
SET Z=Y
+8 IF 'P
QUIT P
+9 IF '$DATA(^ICD9(P))
QUIT -1
+10 IF $GET(F)=""
SET F="C"
+11 SET %=""
DO @F
+12 QUIT %
+13 ;
POV ;EP
+1 NEW Z,C,%,S,I,J
+2 SET (C,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
SET APCLV(C)=""
SET P=$PIECE(^AUPNVPOV(Y,0),U)
SET Z=Y
Begin DoDot:1
+3 IF F=99
Begin DoDot:2
+4 FOR I=1:1
SET S=$TEXT(@I)
IF S=""
QUIT
SET %=""
DO @I
SET $PIECE(APCLV(C),U,I)=%
End DoDot:2
QUIT
+5 IF F[";"
Begin DoDot:2
+6 ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J
FOR J=1:1
SET I=$PIECE(F,";",J)
IF I=""
QUIT
IF I'=99
SET %=""
DO @I
SET $PIECE(APCLV(C),U,I)=%
End DoDot:2
QUIT
+7 SET %=""
SET I=F
DO @I
SET $PIECE(APCLV(C),U)=%
+8 QUIT
End DoDot:1
+9 QUIT
ADMDX ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 SET P=$PIECE(^AUPNVINP(Z,0),U,12)
+7 IF 'P
QUIT P
+8 IF '$DATA(^ICD9(P))
QUIT -1
+9 IF $GET(F)=""
SET F="C"
+10 SET %=""
DO @F
+11 QUIT %
+12 ;
I ;
+1 SET %=P
QUIT
E ;
+1 ;S %=$P(^ICD9(P,0),U,3) Q ;cmi/anch/maw 9/12/2007 orig line
+2 ;cmi/anch/maw 9/12/2007 csv
SET %=$PIECE($$ICDDX^ICDEX(P,,,"I"),U,4)
QUIT
C ;
+1 ;S %=$P(^ICD9(P,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
+2 ;cmi/anch/maw 9/12/2007 csv
SET %=$PIECE($$ICDDX^ICDEX(P,,,"I"),U,2)
QUIT
D ;
+1 SET %=$PIECE(^AUPNVPOV(Z,0),U,7)
QUIT
J ;
+1 ;S %=$PCLV07_source.html#xP">P(^AUPCLV07_source.html#xP">PNVPCLV07_source.html#xP">POV(Z,0),U,9) I % S %=$PCLV07_source.html#xP">P(^ICD9(%,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
+2 ;cmi/anch/maw 9/12/2007 csc
SET %=$PIECE(^AUPNVPOV(Z,0),U,9)
IF %
SET %=$PIECE($$ICDDX^ICDEX(%),U,2)
QUIT
+3 QUIT
P ;
+1 SET %=$PIECE(^AUPNVPOV(Z,0),U,11)
QUIT
N ;
+1 SET %=$$VAL^XBDIQ1(9000010.07,Z,.04)
+2 ;S %=$PCLV07_source.html#xP">P(^AUPCLV07_source.html#xP">PNVPCLV07_source.html#xP">POV(Z,0),U,4) I %,$PCLV07_source.html#xD">D(^AUTNPCLV07_source.html#xP">POV(%,0)) S %=$PCLV07_source.html#xP">P(^AUTNPCLV07_source.html#xP">POV(%,0),U)
+3 QUIT
S ;stage
+1 SET %=$PIECE(^AUPNVPOV(Z,0),U,5)
QUIT
A ;
+1 NEW I,H,R,L,E,D
+2 ;S I=$P(^ICD9(P,0),U) ;cmi/anch/maw 9/12/2007 orig line
+3 ;cmi/anch/maw 9/12/2007 csv
SET I=$PIECE($$ICDDX^ICDEX(P),U,2)
+4 IF $EXTRACT(I)="E"
SET %=999
QUIT
+5 IF $EXTRACT(I)="."
DO CODE10
GOTO HIGH
+6 SET R="09"_($PIECE(I,".")_$PIECE(I,".",2))_" "
+7 IF $EXTRACT(I)="V"
SET I=9_$EXTRACT(I,2,9999)
SET I=I-.000001
SET I="09V"_$EXTRACT(I,2,9999)
SET I=$PIECE(I,".")_$PIECE(I,".",2)_" "
GOTO HIGH
+8 SET I="09"_I-.000001
+9 SET %=""
SET I="0"_($PIECE(I,".")_$PIECE(I,".",2))_" "
HIGH SET H=$ORDER(^AUTTRCD("AH",I))
IF H=""
SET %=999
QUIT
+1 SET D=$ORDER(^AUTTRCD("AH",H,""))
IF D=""
SET %=""
QUIT
+2 SET E=$ORDER(^AUTTRCD("AH",H,D,""))
+3 SET L=$PIECE(^AUTTRCD(D,11,E,0),U)_" "
+4 IF L]R
SET %=999
QUIT
+5 SET %=$PIECE(^AUTTRCD(D,0),U)
+6 QUIT
CODE10 ;
+1 SET R="10"_$PIECE(I,".",2)_" "
+2 SET I="10"_I
SET I=I-.000001
SET I=$PIECE(I,".")_$PIECE(I,".",2)_" "
+3 QUIT
+4 ;
1 ;
+1 SET %=$$VD^APCLV($PIECE(^AUPNVPOV(Y,0),U,3),"I")
+2 QUIT
2 ;
+1 SET %=$$VD^APCLV($PIECE(^AUPNVPOV(Y,0),U,3),"S")
+2 QUIT
3 ;
+1 SET %=$PIECE(^AUPNVPOV(Y,0),U,2)
+2 QUIT
4 ;
+1 SET %=$$PATIENT^APCLV($PIECE(^AUPNVPOV(Y,0),U,3),"E")
+2 QUIT
5 ;
+1 SET %=Y
+2 QUIT
6 DO E
QUIT
7 DO C
QUIT
8 DO A
QUIT
9 DO D
QUIT
10 SET %=$$VAL^XBDIQ1(9000010.07,Y,.07)
QUIT
11 DO J
QUIT
12 DO P
QUIT
13 SET %=$$VAL^XBDIQ1(9000010.07,Y,.11)
QUIT
14 DO N
QUIT
15 SET %=$PIECE(^AUPNVPOV(Y,0),U,12)
QUIT
16 SET %=$$VAL^XBDIQ1(9000010.07,Y,.12)
QUIT
17 SET %=$$VAL^XBDIQ1(9000010.07,Y,.13)
QUIT
18 SET %=$$VAL^XBDIQ1(9000010.07,Y,.05)
QUIT
19 SET %=$$VALI^XBDIQ1(9000010.07,Y,.06)
QUIT
20 SET %=$$VAL^XBDIQ1(9000010.07,Y,.06)
QUIT
