AMHLESA2 ; IHS/TUCSON/LAB -VISIT DISPLAY ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
DISP(AMHR) ;EP
NEW AMHARRY
K ^TMP("AMHLESA1",$J)
S AMHARRY="^TMP(""AMHLESA1"",$J)"
Q:'$D(AMHR)
Q:'AMHR
NEW DFN S DFN=$P(^AMHREC(AMHR,0),U,8)
Q:'DFN
Q:'$D(^AMHREC(AMHR,0))
D BUILD
D XIT
Q
;
SET ;set array
S AMHCTR=AMHCTR+1
S @AMHARRY@(AMHCTR,0)=AMHSTR
S AMHSTR=""
Q
BUILD ; build array
NEW AMHAR,AMHSTR,AMHCTR,AMHX,AMHH,AMHV
I $E(IOST)'="P" D TERM^VALM0
S Y=DFN D ^AUPNPAT
S AMHSTR="",AMHCTR=0
S AMHH="Patient Name",AMHV=$E($P(^DPT(DFN,0),U),1,20) D BUILD1
S AMHH="Chart #" S AMHV="",AMHV=$$HRN^AUPNPAT(DFN,DUZ(2)) D BUILD1
S AMHH="Date of Birth" S AMHV=$$DOB^AUPNPAT(DFN,"E") D BUILD1
S AMHH="Sex",AMHV=AUPNSEX D BUILD1
S AMHSTR="" D SET
S AMHH="Tribe",AMHV=$$TRIBE^AUPNPAT(DFN,"E") D BUILD1
SAN ;
S AMHSTR="=============== "_"BH SAN DATA ITEMS"_" ===============",X=(80-$L(AMHSTR)\2) D SET ;$J("",X)_AMHSTR D SET
I AMHVTYPE="U" D SANU Q
1 ;EP
K AMHAR
D ENP^XBDIQ1(9002011,AMHR,"7701;7702;7703;7704;7706;7707;7901","AMHAR(","E")
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
2 ;
K AMHAR
F AMHX=7709,7717,7711,7712 I $D(^DD(9002011,AMHX,0)),$O(^AMHREC(AMHR,AMHX,0)) D
.S AMHSTR=$P(^DD(9002011,AMHX,0),U) D SET
.K AMHAR D ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
.S F=0 F S F=$O(AMHAR(AMHX,F)) Q:F'=+F S AMHSTR=AMHAR(AMHX,F) D SET
.S AMHSTR="" D SET
.Q
3 ;
K AMHAR
D ENP^XBDIQ1(9002011,AMHR,7713,"AMHAR(","E")
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
4 ;
K AMHAR
F AMHX=7715 I $D(^DD(9002011,AMHX,0)),$O(^AMHREC(AMHR,AMHX,0)) D
.S AMHSTR=$P(^DD(9002011,AMHX,0),U) D SET
.K AMHAR D ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
.S F=0 F S F=$O(AMHAR(AMHX,F)) Q:F'=+F S AMHSTR=AMHAR(AMHX,F) D SET
.S AMHSTR="" D SET
5 ;
K AMHAR
D ENP^XBDIQ1(9002011,AMHR,"7902;7719;7721;7722;7903;7904;7905","AMHAR(","E")
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
6 ;
K AMHAR
F AMHX=7724 I $D(^DD(9002011,AMHX,0)),$O(^AMHREC(AMHR,AMHX,0)) D
.S AMHSTR=$P(^DD(9002011,AMHX,0),U) D SET
.K AMHAR D ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
.S F=0 F S F=$O(AMHAR(AMHX,F)) Q:F'=+F S AMHSTR=AMHAR(AMHX,F) D SET
.S AMHSTR="" D SET
.Q
S AMHSTR="" D SET
Q
BUILD1 ;
S AMHSTR=$E(AMHH,1,21)_":",AMHSTR=$$SETSTR^VALM1(AMHV,AMHSTR,24,$L(AMHV))
D SET
Q
SANU ;EP
K AMHAR
F AMHX=7801 I $D(^DD(9002011,AMHX,0)) D
.S AMHSTR=$P(^DD(9002011,AMHX,0),U) D SET
.K AMHAR D ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
.S F=0 F S F=$O(AMHAR(AMHX,F)) Q:F'=+F S AMHSTR=AMHAR(AMHX,F) D SET
.S AMHSTR="" D SET
.Q
78 ;
K AMHAR
D ENP^XBDIQ1(9002011,AMHR,7802,"AMHAR(","E")
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
783 ;
K AMHAR
F AMHX=7803:1:7805 I $D(^DD(9002011,AMHX,0)) D
.S AMHSTR=$P(^DD(9002011,AMHX,0),U) D SET
.K AMHAR D ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
.S F=0 F S F=$O(AMHAR(AMHX,F)) Q:F'=+F S AMHSTR=AMHAR(AMHX,F) D SET
.S AMHSTR="" D SET
.Q
786 ;
K AMHAR
D ENP^XBDIQ1(9002011,AMHR,7806,"AMHAR(","E")
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
787 ;
K AMHAR
F AMHX=7808:1:7809 I $D(^DD(9002011,AMHX,0)) D
.S AMHSTR=$P(^DD(9002011,AMHX,0),U) D SET
.K AMHAR D ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
.S F=0 F S F=$O(AMHAR(AMHX,F)) Q:F'=+F S AMHSTR=AMHAR(AMHX,F) D SET
.S AMHSTR="" D SET
.Q
7811 ;
K AMHAR
D ENP^XBDIQ1(9002011,AMHR,"7811;7812","AMHAR(","E")
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
7813 ;
K AMHAR
F AMHX=7813 I $D(^DD(9002011,AMHX,0)) D
.S AMHSTR=$P(^DD(9002011,AMHX,0),U) D SET
.K AMHAR D ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
.S F=0 F S F=$O(AMHAR(AMHX,F)) Q:F'=+F S AMHSTR=AMHAR(AMHX,F) D SET
.S AMHSTR="" D SET
.Q
XIT ;
Q
AMHLESA2 ; IHS/TUCSON/LAB -VISIT DISPLAY ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
DISP(AMHR) ;EP
+1 NEW AMHARRY
+2 KILL ^TMP("AMHLESA1",$JOB)
+3 SET AMHARRY="^TMP(""AMHLESA1"",$J)"
+4 IF '$DATA(AMHR)
QUIT
+5 IF 'AMHR
QUIT
+6 NEW DFN
SET DFN=$PIECE(^AMHREC(AMHR,0),U,8)
+7 IF 'DFN
QUIT
+8 IF '$DATA(^AMHREC(AMHR,0))
QUIT
+9 DO BUILD
+10 DO XIT
+11 QUIT
+12 ;
SET ;set array
+1 SET AMHCTR=AMHCTR+1
+2 SET @AMHARRY@(AMHCTR,0)=AMHSTR
+3 SET AMHSTR=""
+4 QUIT
BUILD ; build array
+1 NEW AMHAR,AMHSTR,AMHCTR,AMHX,AMHH,AMHV
+2 IF $EXTRACT(IOST)'="P"
DO TERM^VALM0
+3 SET Y=DFN
DO ^AUPNPAT
+4 SET AMHSTR=""
SET AMHCTR=0
+5 SET AMHH="Patient Name"
SET AMHV=$EXTRACT($PIECE(^DPT(DFN,0),U),1,20)
DO BUILD1
+6 SET AMHH="Chart #"
SET AMHV=""
SET AMHV=$$HRN^AUPNPAT(DFN,DUZ(2))
DO BUILD1
+7 SET AMHH="Date of Birth"
SET AMHV=$$DOB^AUPNPAT(DFN,"E")
DO BUILD1
+8 SET AMHH="Sex"
SET AMHV=AUPNSEX
DO BUILD1
+9 SET AMHSTR=""
DO SET
+10 SET AMHH="Tribe"
SET AMHV=$$TRIBE^AUPNPAT(DFN,"E")
DO BUILD1
SAN ;
+1 ;$J("",X)_AMHSTR D SET
SET AMHSTR="=============== "_"BH SAN DATA ITEMS"_" ==============="
SET X=(80-$LENGTH(AMHSTR)\2)
DO SET
+2 IF AMHVTYPE="U"
DO SANU
QUIT
1 ;EP
+1 KILL AMHAR
+2 DO ENP^XBDIQ1(9002011,AMHR,"7701;7702;7703;7704;7706;7707;7901","AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+4 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+5 SET AMHV=AMHAR(F)
+6 DO BUILD1
End DoDot:1
2 ;
+1 KILL AMHAR
+2 FOR AMHX=7709,7717,7711,7712
IF $DATA(^DD(9002011,AMHX,0))
IF $ORDER(^AMHREC(AMHR,AMHX,0))
Begin DoDot:1
+3 SET AMHSTR=$PIECE(^DD(9002011,AMHX,0),U)
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+6 SET AMHSTR=""
DO SET
+7 QUIT
End DoDot:1
3 ;
+1 KILL AMHAR
+2 DO ENP^XBDIQ1(9002011,AMHR,7713,"AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+4 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+5 SET AMHV=AMHAR(F)
+6 DO BUILD1
End DoDot:1
4 ;
+1 KILL AMHAR
+2 FOR AMHX=7715
IF $DATA(^DD(9002011,AMHX,0))
IF $ORDER(^AMHREC(AMHR,AMHX,0))
Begin DoDot:1
+3 SET AMHSTR=$PIECE(^DD(9002011,AMHX,0),U)
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+6 SET AMHSTR=""
DO SET
End DoDot:1
5 ;
+1 KILL AMHAR
+2 DO ENP^XBDIQ1(9002011,AMHR,"7902;7719;7721;7722;7903;7904;7905","AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+4 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+5 SET AMHV=AMHAR(F)
+6 DO BUILD1
End DoDot:1
6 ;
+1 KILL AMHAR
+2 FOR AMHX=7724
IF $DATA(^DD(9002011,AMHX,0))
IF $ORDER(^AMHREC(AMHR,AMHX,0))
Begin DoDot:1
+3 SET AMHSTR=$PIECE(^DD(9002011,AMHX,0),U)
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+6 SET AMHSTR=""
DO SET
+7 QUIT
End DoDot:1
+8 SET AMHSTR=""
DO SET
+9 QUIT
BUILD1 ;
+1 SET AMHSTR=$EXTRACT(AMHH,1,21)_":"
SET AMHSTR=$$SETSTR^VALM1(AMHV,AMHSTR,24,$LENGTH(AMHV))
+2 DO SET
+3 QUIT
SANU ;EP
+1 KILL AMHAR
+2 FOR AMHX=7801
IF $DATA(^DD(9002011,AMHX,0))
Begin DoDot:1
+3 SET AMHSTR=$PIECE(^DD(9002011,AMHX,0),U)
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+6 SET AMHSTR=""
DO SET
+7 QUIT
End DoDot:1
78 ;
+1 KILL AMHAR
+2 DO ENP^XBDIQ1(9002011,AMHR,7802,"AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+4 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+5 SET AMHV=AMHAR(F)
+6 DO BUILD1
End DoDot:1
783 ;
+1 KILL AMHAR
+2 FOR AMHX=7803:1:7805
IF $DATA(^DD(9002011,AMHX,0))
Begin DoDot:1
+3 SET AMHSTR=$PIECE(^DD(9002011,AMHX,0),U)
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+6 SET AMHSTR=""
DO SET
+7 QUIT
End DoDot:1
786 ;
+1 KILL AMHAR
+2 DO ENP^XBDIQ1(9002011,AMHR,7806,"AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+4 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+5 SET AMHV=AMHAR(F)
+6 DO BUILD1
End DoDot:1
787 ;
+1 KILL AMHAR
+2 FOR AMHX=7808:1:7809
IF $DATA(^DD(9002011,AMHX,0))
Begin DoDot:1
+3 SET AMHSTR=$PIECE(^DD(9002011,AMHX,0),U)
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+6 SET AMHSTR=""
DO SET
+7 QUIT
End DoDot:1
7811 ;
+1 KILL AMHAR
+2 DO ENP^XBDIQ1(9002011,AMHR,"7811;7812","AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+4 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+5 SET AMHV=AMHAR(F)
+6 DO BUILD1
End DoDot:1
7813 ;
+1 KILL AMHAR
+2 FOR AMHX=7813
IF $DATA(^DD(9002011,AMHX,0))
Begin DoDot:1
+3 SET AMHSTR=$PIECE(^DD(9002011,AMHX,0),U)
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,AMHX,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+6 SET AMHSTR=""
DO SET
+7 QUIT
End DoDot:1
XIT ;
+1 QUIT
