- 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
