AMHUTIL3 ; IHS/CMI/LAB - provider functions ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,3,4,6**;JUN 02, 2010;Build 10
;IHS/CMI/LAB - added stage as output parameter
;
;IHS/TUCSON/LAB - patch 1 05/19/97 - fixed setting of array
RACESF(PAT) ;
NEW Y,Z,X,I
K Z
S X=""
D LIST^DIC(2.02,","_PAT_",","@;.01E","P",,,,,,,"Z")
S Y=0 F S Y=$O(Z("DILIST",Y)) Q:Y="" D
.S I=$P($G(^DIC(10,+$P(Z("DILIST",Y,0),U,1),.02)),U,1)
.Q:I
.S Z=$P(^DIC(10,+$P(Z("DILIST",Y,0),U,1),0),U,3)
.;I Z="" S Z=$P(^DIC(10,+$P(Z("DILIST",Y,0),U,1),0),U,2)
.Q:Z=""
.S X=X_Z_U
Q X
ETHN(P) ;EP
I '$G(P) Q ""
I $G(F)="" S F="E"
I '$D(^DPT(P,0)) Q ""
NEW Z,E,I
S (E,I)=""
S Z=0 F S Z=$O(^DPT(P,.06,Z)) Q:Z'=+Z!(E]"") D
.S I=$P($G(^DPT(P,.06,Z,0)),U,1)
.Q:I=""
.S E=$P($G(^DIC(10.2,I,0)),U,2)
.Q
Q E
ASUFACLD(R) ;EP - get asufac of logged in facility suicide form
I '$G(R) Q ""
I '$D(^AMHPSUIC(R,0)) Q ""
NEW Z
S Z=$$VALI^XBDIQ1(9002011.65,R,.28)
I 'Z Q ""
Q $$VAL^XBDIQ1(9999999.06,Z,.12)
DLM(V) ;EP date last modified
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
NEW R
S R=""
S R=$S($P($G(^AMHREC(V,11)),U,14)]"":$$DATE^AMHUTIL($P(^AMHREC(V,11),U,14)),1:$$DATE^AMHUTIL($P(^AMHREC(V,0),U,21)))
Q R
TLM(V) ;EP
NEW R
S R=$P($G(^AMHREC(V,11)),U,14)
I R="" Q ""
S R=$$FMTE^XLFDT(R,"2P")
Q $$UP^XLFSTR($P($P(R," ",2),":",1,2))_$$UP^XLFSTR($P(R," ",3))
;
UID(P) ;EP
I '$D(^AUPNPAT(P,0)) Q ""
I '$L($T(UID^BDWAID)) G UIDO
S X=$$UID^BDWAID(P) Q X
UIDO ;
Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(P))_P
;
VTIME(V) ;
NEW R
S R=$P($G(^AMHREC(V,0)),U,1)
I R="" Q ""
S R=$$FMTE^XLFDT(R,"2P")
Q $$UP^XLFSTR($P($P(R," ",2),":",1,2))_$$UP^XLFSTR($P(R," ",3))
;
DLMSF(V) ;EP date last modified
I 'V Q ""
I '$D(^AMHPSUIC(V)) Q ""
NEW R
S R=""
S R=$S($P($G(^AMHPSUIC(V,0)),U,27)]"":$$DATE^AMHUTIL($P(^AMHPSUIC(V,0),U,27)),1:$$DATE^AMHUTIL($P(^AMHPSUIC(V,0),U,21)))
Q R
TLMSF(V) ;
NEW R
S R=$P($G(^AMHPSUIC(V,0)),U,27)
I R="" Q ""
S R=$$FMTE^XLFDT(R,"2P")
Q $$UP^XLFSTR($P($P(R," ",2),":",1,2))_$$UP^XLFSTR($P(R," ",3))
;
MSR6(V) ;EP - return first 6 measurements and values
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
NEW Y,R,C,F,S
S R="",(Y,C)=0,F=1,S=2
F S Y=$O(^AMHRMSR("AD",V,Y)) Q:Y'=+Y!(C>5) S C=C+1,$P(R,U,F)=$$VAL^XBDIQ1(9002011.12,Y,.01),$P(R,U,S)=$P(^AMHRMSR(Y,0),U,4) S F=F+2,S=S+2
Q R
PED(V,N) ;EP - return nth v patient ed on this visit
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
I '$G(N) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0 F S Y=$O(^AMHREDU("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AMHREDU(Y,0),"^"),Z=Y
I 'P Q P
I '$D(^AUTTEDT(P)) Q ""
S R=$P(^AUTTEDT(P,0),U,2)
S %="" D S R=R_U_%
.S P=$P(^AMHREDU(Z,0),U,4) I %="" Q
.NEW A D A^AMHUTIL Q:%="" S A=% NEW D D D^AMHUTIL Q:%="" S D=%,%="" D C^AMHUTIL1 Q:%="" S %=A_D_% Q
S R=R_U_$P(^AMHREDU(Z,0),U,5)_U_$P(^AMHREDU(Z,0),U,6)_U_$$VAL^XBDIQ1(9002011.05,Z,.07)_U_$P(^AMHREDU(Z,0),U,8)_U_$$VAL^XBDIQ1(9002011.05,Z,1102)
Q R
;
HF(V,N) ;EP
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
I '$G(N) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0 F S Y=$O(^AMHRHF("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AMHRHF(Y,0),"^"),Z=Y
I 'P Q P
I '$D(^AUTTHF(P)) Q ""
S R=$P(^AUTTHF(P,0),U,1)
S %="" D S R=R_U_%
.S P=$P(^AMHRHF(Z,0),U,5) I %="" Q
.NEW A D A^AMHUTIL Q:%="" S A=% NEW D D D^AMHUTIL Q:%="" S D=%,%="" D C^AMHUTIL1 Q:%="" S %=A_D_% Q
S R=R_U_$P(^AMHRHF(Z,0),U,4)_U_$P(^AMHRHF(Z,0),U,6)
Q R
;
PRIMPA(V,F) ;EP - primary provider in many different formats
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=$O(^AMHRPA("AD",V,0)) I Y S P=$P(^AMHRPA(Y,0),U),Z=Y
I 'P Q P
I '$D(^AMHTPA(P)) Q ""
I $G(F)="" S F="C"
S %="" D @F
Q %
;
SECPA(V,N,F) ;EP
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
I '$G(N) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0,C=-1 F S Y=$O(^AMHRPA("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AMHRPA(Y,0),U),Z=Y
I 'P Q P
I '$D(^AMHTPA(P)) Q ""
I $G(F)="" S F="C"
S %="" D @F
Q %
;
PA ;EP
NEW Z,C,%,S,I,J
S (C,Y)=0 F S Y=$O(^AMHRPA("AD",V,Y)) Q:Y'=+Y S C=C+1 S APCLV(C)="",P=$P(^AMHRPA(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 ""
I '$D(^AMHREC(V)) Q ""
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(^AMHTPA(P)) Q ""
I $G(F)="" S F="C"
S %="" D @F
Q %
;
OTHMETH ;EP - called from screenman
I $G(X)=$G(DDSOLD) Q ;no change
I Y=-1 Q ;no change
I X'=8 D PUT^DDSVAL(DIE,.DA,.02,"",,"I") Q
;I X=8 D REQ^DDSUTL(2,1,1.4,1)
Q
I ;
S %=P Q
E ;
S %=$P(^AMHTPA(P,0),U,3) Q
C ;
S %=$P(^AMHTPA(P,0),U,2) Q
D ;
S %=$P(^AMHRPA(Z,0),U,7) Q
J ;
S %=$P(^AMHRPA(Z,0),U,9) I % S %=$P(^AMHTPA(%,0),U) Q
Q
P ;
S %=$P(^AMHRPA(Z,0),U,11) Q
N ;
S %=$P(^AMHRPA(Z,0),U,4)
Q
S ;stage
S %=$P(^AMHRPA(Z,0),U,5) Q
A ;
NEW I,H,R,L,E,D
S I=$P(^AMHTPA(P,0),U)
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(^AMHRPA(Y,0),U,3),"I")
Q
2 ;
S %=$$VD^APCLV($P(^AMHRPA(Y,0),U,3),"S")
Q
3 ;
S %=$P(^AMHRPA(Y,0),U,2)
Q
4 ;
S %=$$PATIENT^APCLV($P(^AMHRPA(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(^AMHRPA(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
AMHUTIL3 ; IHS/CMI/LAB - provider functions ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,3,4,6**;JUN 02, 2010;Build 10
+2 ;IHS/CMI/LAB - added stage as output parameter
+3 ;
+4 ;IHS/TUCSON/LAB - patch 1 05/19/97 - fixed setting of array
RACESF(PAT) ;
+1 NEW Y,Z,X,I
+2 KILL Z
+3 SET X=""
+4 DO LIST^DIC(2.02,","_PAT_",","@;.01E","P",,,,,,,"Z")
+5 SET Y=0
FOR
SET Y=$ORDER(Z("DILIST",Y))
IF Y=""
QUIT
Begin DoDot:1
+6 SET I=$PIECE($GET(^DIC(10,+$PIECE(Z("DILIST",Y,0),U,1),.02)),U,1)
+7 IF I
QUIT
+8 SET Z=$PIECE(^DIC(10,+$PIECE(Z("DILIST",Y,0),U,1),0),U,3)
+9 ;I Z="" S Z=$P">P(^DIC(10,+$P">P(Z("DILIST",Y,0),U,1),0),U,2)
+10 IF Z=""
QUIT
+11 SET X=X_Z_U
End DoDot:1
+12 QUIT X
ETHN(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 IF '$DATA(^DPT(P,0))
QUIT ""
+4 NEW Z,E,I
+5 SET (E,I)=""
+6 SET Z=0
FOR
SET Z=$ORDER(^DPT(P,.06,Z))
IF Z'=+Z!(E]"")
QUIT
Begin DoDot:1
+7 SET I=$PIECE($GET(^DPT(P,.06,Z,0)),U,1)
+8 IF I=""
QUIT
+9 SET E=$PIECE($GET(^DIC(10.2,I,0)),U,2)
+10 QUIT
End DoDot:1
+11 QUIT E
ASUFACLD(R) ;EP - get asufac of logged in facility suicide form
+1 IF '$GET(R)
QUIT ""
+2 IF '$DATA(^AMHPSUIC(R,0))
QUIT ""
+3 NEW Z
+4 SET Z=$$VALI^XBDIQ1(9002011.65,R,.28)
+5 IF 'Z
QUIT ""
+6 QUIT $$VAL^XBDIQ1(9999999.06,Z,.12)
DLM(V) ;EP date last modified
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 NEW R
+4 SET R=""
+5 SET R=$SELECT($PIECE($GET(^AMHREC(V,11)),U,14)]"":$$DATE^AMHUTIL($PIECE(^AMHREC(V,11),U,14)),1:$$DATE^AMHUTIL($PIECE(^AMHREC(V,0),U,21)))
+6 QUIT R
TLM(V) ;EP
+1 NEW R
+2 SET R=$PIECE($GET(^AMHREC(V,11)),U,14)
+3 IF R=""
QUIT ""
+4 SET R=$$FMTE^XLFDT(R,"2P")
+5 QUIT $$UP^XLFSTR($PIECE($PIECE(R," ",2),":",1,2))_$$UP^XLFSTR($PIECE(R," ",3))
+6 ;
UID(P) ;EP
+1 IF '$DATA(^AUPNPAT(P,0))
QUIT ""
+2 IF '$LENGTH($TEXT(UID^BDWAID))
GOTO UIDO
+3 SET X=$$UID^BDWAID(P)
QUIT X
UIDO ;
+1 QUIT $$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_$EXTRACT("0000000000",1,10-$LENGTH(P))_P
+2 ;
VTIME(V) ;
+1 NEW R
+2 SET R=$PIECE($GET(^AMHREC(V,0)),U,1)
+3 IF R=""
QUIT ""
+4 SET R=$$FMTE^XLFDT(R,"2P")
+5 QUIT $$UP^XLFSTR($PIECE($PIECE(R," ",2),":",1,2))_$$UP^XLFSTR($PIECE(R," ",3))
+6 ;
DLMSF(V) ;EP date last modified
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHPSUIC(V))
QUIT ""
+3 NEW R
+4 SET R=""
+5 SET R=$SELECT($PIECE($GET(^AMHPSUIC(V,0)),U,27)]"":$$DATE^AMHUTIL($PIECE(^AMHPSUIC(V,0),U,27)),1:$$DATE^AMHUTIL($PIECE(^AMHPSUIC(V,0),U,21)))
+6 QUIT R
TLMSF(V) ;
+1 NEW R
+2 SET R=$PIECE($GET(^AMHPSUIC(V,0)),U,27)
+3 IF R=""
QUIT ""
+4 SET R=$$FMTE^XLFDT(R,"2P")
+5 QUIT $$UP^XLFSTR($PIECE($PIECE(R," ",2),":",1,2))_$$UP^XLFSTR($PIECE(R," ",3))
+6 ;
MSR6(V) ;EP - return first 6 measurements and values
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 NEW Y,R,C,F,S
+4 SET R=""
SET (Y,C)=0
SET F=1
SET S=2
+5 FOR
SET Y=$ORDER(^AMHRMSR("AD",V,Y))
IF Y'=+Y!(C>5)
QUIT
SET C=C+1
SET $PIECE(R,U,F)=$$VAL^XBDIQ1(9002011.12,Y,.01)
SET $PIECE(R,U,S)=$PIECE(^AMHRMSR(Y,0),U,4)
SET F=F+2
SET S=S+2
+6 QUIT R
PED(V,N) ;EP - return nth v patient ed on this visit
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 IF '$GET(N)
QUIT ""
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
FOR
SET Y=$ORDER(^AMHREDU("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AMHREDU(Y,0),"^")
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^AUTTEDT(P))
QUIT ""
+9 SET R=$PIECE(^AUTTEDT(P,0),U,2)
+10 SET %=""
Begin DoDot:1
+11 SET P=$PIECE(^AMHREDU(Z,0),U,4)
IF %=""
QUIT
+12 NEW A
DO A^AMHUTIL
IF %=""
QUIT
SET A=%
NEW D
DO D^AMHUTIL
IF %=""
QUIT
SET D=%
SET %=""
DO C^AMHUTIL1
IF %=""
QUIT
SET %=A_D_%
QUIT
End DoDot:1
SET R=R_U_%
+13 SET R=R_U_$PIECE(^AMHREDU(Z,0),U,5)_U_$PIECE(^AMHREDU(Z,0),U,6)_U_$$VAL^XBDIQ1(9002011.05,Z,.07)_U_$PIECE(^AMHREDU(Z,0),U,8)_U_$$VAL^XBDIQ1(9002011.05,Z,1102)
+14 QUIT R
+15 ;
HF(V,N) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 IF '$GET(N)
QUIT ""
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
FOR
SET Y=$ORDER(^AMHRHF("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AMHRHF(Y,0),"^")
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^AUTTHF(P))
QUIT ""
+9 SET R=$PIECE(^AUTTHF(P,0),U,1)
+10 SET %=""
Begin DoDot:1
+11 SET P=$PIECE(^AMHRHF(Z,0),U,5)
IF %=""
QUIT
+12 NEW A
DO A^AMHUTIL
IF %=""
QUIT
SET A=%
NEW D
DO D^AMHUTIL
IF %=""
QUIT
SET D=%
SET %=""
DO C^AMHUTIL1
IF %=""
QUIT
SET %=A_D_%
QUIT
End DoDot:1
SET R=R_U_%
+13 SET R=R_U_$PIECE(^AMHRHF(Z,0),U,4)_U_$PIECE(^AMHRHF(Z,0),U,6)
+14 QUIT R
+15 ;
PRIMPA(V,F) ;EP - primary provider in many different formats
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 NEW %,Y,P,C,Z
+4 SET (Z,P)=""
SET (Y,C)=0
+5 SET Y=$ORDER(^AMHRPA("AD",V,0))
IF Y
SET P=$PIECE(^AMHRPA(Y,0),U)
SET Z=Y
+6 IF 'P
QUIT P
+7 IF '$DATA(^AMHTPA(P))
QUIT ""
+8 IF $GET(F)=""
SET F="C"
+9 SET %=""
DO @F
+10 QUIT %
+11 ;
SECPA(V,N,F) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 IF '$GET(N)
QUIT ""
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
SET C=-1
FOR
SET Y=$ORDER(^AMHRPA("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AMHRPA(Y,0),U)
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^AMHTPA(P))
QUIT ""
+9 IF $GET(F)=""
SET F="C"
+10 SET %=""
DO @F
+11 QUIT %
+12 ;
PA ;EP
+1 NEW Z,C,%,S,I,J
+2 SET (C,Y)=0
FOR
SET Y=$ORDER(^AMHRPA("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
SET APCLV(C)=""
SET P=$PIECE(^AMHRPA(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 ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+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(^AMHTPA(P))
QUIT ""
+9 IF $GET(F)=""
SET F="C"
+10 SET %=""
DO @F
+11 QUIT %
+12 ;
OTHMETH ;EP - called from screenman
+1 ;no change
IF $GET(X)=$GET(DDSOLD)
QUIT
+2 ;no change
IF Y=-1
QUIT
+3 IF X'=8
DO PUT^DDSVAL(DIE,.DA,.02,"",,"I")
QUIT
+4 ;I X=8 D REQ^DDSUTL(2,1,1.4,1)
+5 QUIT
I ;
+1 SET %=P
QUIT
E ;
+1 SET %=$PIECE(^AMHTPA(P,0),U,3)
QUIT
C ;
+1 SET %=$PIECE(^AMHTPA(P,0),U,2)
QUIT
D ;
+1 SET %=$PIECE(^AMHRPA(Z,0),U,7)
QUIT
J ;
+1 SET %=$PIECE(^AMHRPA(Z,0),U,9)
IF %
SET %=$PIECE(^AMHTPA(%,0),U)
QUIT
+2 QUIT
P ;
+1 SET %=$PIECE(^AMHRPA(Z,0),U,11)
QUIT
N ;
+1 SET %=$PIECE(^AMHRPA(Z,0),U,4)
+2 QUIT
S ;stage
+1 SET %=$PIECE(^AMHRPA(Z,0),U,5)
QUIT
A ;
+1 NEW I,H,R,L,E,D
+2 SET I=$PIECE(^AMHTPA(P,0),U)
+3 IF $EXTRACT(I)="E"
SET %=999
QUIT
+4 IF $EXTRACT(I)="."
DO CODE10
GOTO HIGH
+5 SET R="09"_($PIECE(I,".")_$PIECE(I,".",2))_" "
+6 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
+7 SET I="09"_I-.000001
+8 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(^AMHRPA(Y,0),U,3),"I")
+2 QUIT
2 ;
+1 SET %=$$VD^APCLV($PIECE(^AMHRPA(Y,0),U,3),"S")
+2 QUIT
3 ;
+1 SET %=$PIECE(^AMHRPA(Y,0),U,2)
+2 QUIT
4 ;
+1 SET %=$$PATIENT^APCLV($PIECE(^AMHRPA(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(^AMHRPA(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
