AMHGBDSP ; IHS/CMI/LAB -VISIT DISPLAY NO REVERSE VIDEO FOR GUI ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
EN(AMHARRY,AMHR) ;EP
I $G(AMHARRY)="" S AMHARRY="^TMP(""AMHVDSG"",$J)"
Q:'$D(AMHR)
Q:'AMHR
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
K X
K AMHAR
S AMHVREC=^AMHREC(AMHR,0)
S Y=$P(AMHVREC,U,8) D:Y ^AUPNPAT
S AMHSTR="",AMHCTR=0
I $P(AMHVREC,U,8) D
.S AMHH="Patient Name",AMHV=$E($P(^DPT($P(AMHVREC,U,8),0),U),1,20) D BUILD1
.S AMHH="Chart #" S AMHV="" S:$P(AMHVREC,U,8) AMHV=$S($D(^AUPNPAT($P(AMHVREC,U,8),41,DUZ(2),0)):$P(^(0),U,2),1:"None") D BUILD1
.S AMHH="Date of Birth" S Y=AUPNDOB D DD^%DT S AMHV=Y D BUILD1
.S AMHH="Sex",AMHV=AUPNSEX D BUILD1
.I $P($G(^AMHPATR($P(AMHVREC,U,8),0)),U,9)]"" S AMHH="Patient Flag",AMHV=$P(^AMHPATR($P(AMHVREC,U,8),0),U,9) D BUILD1
.I $P($G(^AMHPATR($P(AMHVREC,U,8),0)),U,11)]"" S AMHH="Flag Narrative",AMHV=$P(^AMHPATR($P(AMHVREC,U,8),0),U,11) D BUILD1
.S AMHSTR="" D SET
RECORD ;
S AMHSTR="=============== BH RECORD FILE ===============",X=(80-$L(AMHSTR)\2) D SET ;$J("",X)_AMHSTR D SET
D ENP^XBDIQ1(9002011,AMHR,".01:.33;1401:1701;","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
S AMHSTR="" D SET
AXIS4 ;
;S AMHSTR="AXIS IV:" D SET
;K AMHAR S Y=0 F S Y=$O(^AMHREC(AMHR,61,Y)) Q:Y'=+Y D
;.S %=$P(^AMHREC(AMHR,61,Y,0),U),AMHSTR=%_" - "_$P(^AMHTAXIV(%,0),U,2) D SET
;S AMHSTR="" D SET
TIUN ;
;I '$P($G(^AMHREC(AMHR,11)),U,8) G 1
;S AMHDOC=$P(^AMHREC(AMHR,11),U,8)
;K AMHTIU,AMHERRR
;I '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ) Q ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D SET G 1
; Extract specified note
;S AMHGBL=$NA(^TMP("AMHOENPS",$J)),AMHHLF=IOM\2
;K @AMHGBL
;D EXTRACT^TIULQ(AMHDOC,AMHGBL,.AMHERRR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
;M AMHTIU=^TMP("AMHOENPS",$J,AMHDOC)
;K ^TMP("AMHOENPS",$J)
;S AMHSTR=AMHTIU(.01,"E") D SET
;S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D SET
;S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E") D SET
;S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D SET
;F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX S AMHSTR=AMHTIU("TEXT",AMHX,0) D SET
;I $L($G(AMHTIU(1501,"E"))) D
;.S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D SET
;.S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D SET
;
;
1 ;
;S AMHSTR="SUBJECTIVE/OBJECTIVE:" D SET
;K AMHAR D ENP^XBDIQ1(9002011,AMHR,3101,"AMHAR(","E")
;S F=0 F S F=$O(AMHAR(3101,F)) Q:F'=+F S AMHSTR=AMHAR(3101,F) D SET
;S AMHSTR="" D SET
4 ;
;S AMHSTR="COMMENT/NEXT APPOINTMENT:" D SET
;K AMHAR D ENP^XBDIQ1(9002011,AMHR,8101,"AMHAR(","E")
;S F=0 F S F=$O(AMHAR(8101,F)) Q:F'=+F S AMHSTR=AMHAR(8101,F) D SET
;S AMHSTR="" D SET
NFT ;
;S AMHSTR="NOTE FORWARDED TO:" D SET
;K AMHAR S Y=0 F S Y=$O(^AMHREC(AMHR,52,Y)) Q:Y'=+Y D
;.S %=$P(^AMHREC(AMHR,52,Y,0),U),AMHSTR=$P(^VA(200,%,0),U) D SET
;S AMHSTR="" D SET
2 ;
;S AMHSTR="MEDICATIONS PRESCRIBED:" D SET
;K AMHAR D ENP^XBDIQ1(9002011,AMHR,4101,"AMHAR(","E")
;S F=0 F S F=$O(AMHAR(4101,F)) Q:F'=+F S AMHSTR=AMHAR(4101,F) D SET
;S AMHSTR="" D SET
SAN ;
;I $P(^AMHREC(AMHR,0),U,33)="S" D 1^AMHLESA2
;I $P(^AMHREC(AMHR,0),U,33)="U" D SANU^AMHLESA2
INTAKE ;
G VFILES
Q
I $P(^AMHREC(AMHR,0),U,33)="I"!($P(^AMHREC(AMHR,0),U,33)="P") D
.S AMHSTR="--------------Intake Data Items-------------" D SET
.S AMHSTR="",AMHH=$P(^DD(9002011.07,.07,0),U),AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.07) D BUILD1
.S AMHSTR="",AMHH=$P(^DD(9002011.07,.03,0),U),AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.03) D BUILD1
.S AMHSTR="",AMHH=$P(^DD(9002011.07,.02,0),U),AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.02) D BUILD1
.S AMHSTR="" D SET
.F AMHX=1000,4100 D
..S AMHSTR=$P(^DD(9002011.07,AMHX,0),U)_":" D SET
..K AMHAR D ENP^XBDIQ1(9002011.07,DFN,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
VFILES ;set up array of all v file entries
NEW DA,D0,DIC,DIQ,DR,DI
F AMHVFLE=9002011.05,9002011.08 D VF2
D XIT
Q
;
VF2 ;
S AMHVNM=$P(^DIC(AMHVFLE,0),U),AMHVDG=^DIC(AMHVFLE,0,"GL"),AMHVIGR=AMHVDG_"""AD"",AMHR,AMHVDFN)",AMHVDFN=""
I AMHVFLE=9002011.06 S AMHVNM=$P(^DIC(AMHVFLE,0),U),AMHVDG=^DIC(AMHVFLE,0,"GL"),AMHVIGR=AMHVDG_"""B"",AMHR,AMHVDFN)",AMHVDFN=""
F AMHVI=1:1 S AMHVDFN=$O(@AMHVIGR) Q:AMHVDFN="" D VF3
Q
;
VF3 ;
I AMHVI<2 S AMHSTR="" D SET S AMHSTR="=============== "_AMHVNM_" ===============",X=(80-$L(AMHSTR)\2) D SET ;$J("",X)_AMHSTR D SET
K AMHAR D ENP^XBDIQ1(AMHVFLE,AMHVDFN,".01:.019999;.04:999999","AMHAR(","E")
I AMHVI>1 S AMHSTR="" D SET
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(AMHVFLE,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
Q
BUILD1 ;
S AMHSTR=$E(AMHH,1,21)_":",AMHSTR=$$SETSTR^VALM1(AMHV,AMHSTR,24,$L(AMHV))
D SET
Q
I $L(AMHSTR)>39 D SET
S AMHV=" "_AMHV_" ",X=AMHH_": "_AMHV
I $L(AMHSTR),$L(X)>40 D SET
I $L(AMHSTR) S AMHSTR=$$SETSTR^VALM1(X,AMHSTR,40,$L(X))
I '$L(AMHSTR) S AMHSTR=X
K AMHV,AMHH,X
Q
XIT ;
K AMHAR,AMHARRY,AMHCTR,AMHH,AMHSTR,AMHV,AMHVDFN,AMHVDG,AMHVFLE,AMHVI,AMHR,AMHVIGR,AMHFL,AMHVNM,AMHVREC,AMHH,AMHV,AMHVI
K DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z
Q
AMHGBDSP ; IHS/CMI/LAB -VISIT DISPLAY NO REVERSE VIDEO FOR GUI ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
EN(AMHARRY,AMHR) ;EP
+1 IF $GET(AMHARRY)=""
SET AMHARRY="^TMP(""AMHVDSG"",$J)"
+2 IF '$DATA(AMHR)
QUIT
+3 IF 'AMHR
QUIT
+4 IF '$DATA(^AMHREC(AMHR,0))
QUIT
+5 DO BUILD
+6 DO XIT
+7 QUIT
+8 ;
SET ;set array
+1 SET AMHCTR=AMHCTR+1
+2 SET @AMHARRY@(AMHCTR,0)=AMHSTR
+3 SET AMHSTR=""
+4 QUIT
BUILD ; build array
+1 KILL X
+2 KILL AMHAR
+3 SET AMHVREC=^AMHREC(AMHR,0)
+4 SET Y=$PIECE(AMHVREC,U,8)
IF Y
DO ^AUPNPAT
+5 SET AMHSTR=""
SET AMHCTR=0
+6 IF $PIECE(AMHVREC,U,8)
Begin DoDot:1
+7 SET AMHH="Patient Name"
SET AMHV=$EXTRACT($PIECE(^DPT($PIECE(AMHVREC,U,8),0),U),1,20)
DO BUILD1
+8 SET AMHH="Chart #"
SET AMHV=""
IF $PIECE(AMHVREC,U,8)
SET AMHV=$SELECT($DATA(^AUPNPAT($PIECE(AMHVREC,U,8),41,DUZ(2),0)):$PIECE(^(0),U,2),1:"None")
DO BUILD1
+9 SET AMHH="Date of Birth"
SET Y=AUPNDOB
DO DD^%DT
SET AMHV=Y
DO BUILD1
+10 SET AMHH="Sex"
SET AMHV=AUPNSEX
DO BUILD1
+11 IF $PIECE($GET(^AMHPATR($PIECE(AMHVREC,U,8),0)),U,9)]""
SET AMHH="Patient Flag"
SET AMHV=$PIECE(^AMHPATR($PIECE(AMHVREC,U,8),0),U,9)
DO BUILD1
+12 IF $PIECE($GET(^AMHPATR($PIECE(AMHVREC,U,8),0)),U,11)]""
SET AMHH="Flag Narrative"
SET AMHV=$PIECE(^AMHPATR($PIECE(AMHVREC,U,8),0),U,11)
DO BUILD1
+13 SET AMHSTR=""
DO SET
End DoDot:1
RECORD ;
+1 ;$J("",X)_AMHSTR D SET
SET AMHSTR="=============== BH RECORD FILE ==============="
SET X=(80-$LENGTH(AMHSTR)\2)
DO SET
+2 DO ENP^XBDIQ1(9002011,AMHR,".01:.33;1401:1701;","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
+7 SET AMHSTR=""
DO SET
AXIS4 ;
+1 ;S AMHSTR="AXIS IV:" D SET
+2 ;K AMHAR S Y=0 F S Y=$O(^AMHREC(AMHR,61,Y)) Q:Y'=+Y D
+3 ;.S %=$P(^AMHREC(AMHR,61,Y,0),U),AMHSTR=%_" - "_$P(^AMHTAXIV(%,0),U,2) D SET
+4 ;S AMHSTR="" D SET
TIUN ;
+1 ;I '$P($G(^AMHREC(AMHR,11)),U,8) G 1
+2 ;S AMHDOC=$P(^AMHREC(AMHR,11),U,8)
+3 ;K AMHTIU,AMHERRR
+4 ;I '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ) Q ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D SET G 1
+5 ; Extract specified note
+6 ;S AMHGBL=$NA(^TMP("AMHOENPS",$J)),AMHHLF=IOM\2
+7 ;K @AMHGBL
+8 ;D EXTRACT^TIULQ(AMHDOC,AMHGBL,.AMHERRR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
+9 ;M AMHTIU=^TMP("AMHOENPS",$J,AMHDOC)
+10 ;K ^TMP("AMHOENPS",$J)
+11 ;S AMHSTR=AMHTIU(.01,"E") D SET
+12 ;S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D SET
+13 ;S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E") D SET
+14 ;S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D SET
+15 ;F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX S AMHSTR=AMHTIU("TEXT",AMHX,0) D SET
+16 ;I $L($G(AMHTIU(1501,"E"))) D
+17 ;.S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D SET
+18 ;.S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D SET
+19 ;
+20 ;
1 ;
+1 ;S AMHSTR="SUBJECTIVE/OBJECTIVE:" D SET
+2 ;K AMHAR D ENP^XBDIQ1(9002011,AMHR,3101,"AMHAR(","E")
+3 ;S F=0 F S F=$O(AMHAR(3101,F)) Q:F'=+F S AMHSTR=AMHAR(3101,F) D SET
+4 ;S AMHSTR="" D SET
4 ;
+1 ;S AMHSTR="COMMENT/NEXT APPOINTMENT:" D SET
+2 ;K AMHAR D ENP^XBDIQ1(9002011,AMHR,8101,"AMHAR(","E")
+3 ;S F=0 F S F=$O(AMHAR(8101,F)) Q:F'=+F S AMHSTR=AMHAR(8101,F) D SET
+4 ;S AMHSTR="" D SET
NFT ;
+1 ;S AMHSTR="NOTE FORWARDED TO:" D SET
+2 ;K AMHAR S Y=0 F S Y=$O(^AMHREC(AMHR,52,Y)) Q:Y'=+Y D
+3 ;.S %=$P(^AMHREC(AMHR,52,Y,0),U),AMHSTR=$P(^VA(200,%,0),U) D SET
+4 ;S AMHSTR="" D SET
2 ;
+1 ;S AMHSTR="MEDICATIONS PRESCRIBED:" D SET
+2 ;K AMHAR D ENP^XBDIQ1(9002011,AMHR,4101,"AMHAR(","E")
+3 ;S F=0 F S F=$O(AMHAR(4101,F)) Q:F'=+F S AMHSTR=AMHAR(4101,F) D SET
+4 ;S AMHSTR="" D SET
SAN ;
+1 ;I $P(^AMHREC(AMHR,0),U,33)="S" D 1^AMHLESA2
+2 ;I $P(^AMHREC(AMHR,0),U,33)="U" D SANU^AMHLESA2
INTAKE ;
+1 GOTO VFILES
+2 QUIT
+3 IF $PIECE(^AMHREC(AMHR,0),U,33)="I"!($PIECE(^AMHREC(AMHR,0),U,33)="P")
Begin DoDot:1
+4 SET AMHSTR="--------------Intake Data Items-------------"
DO SET
+5 SET AMHSTR=""
SET AMHH=$PIECE(^DD(9002011.07,.07,0),U)
SET AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.07)
DO BUILD1
+6 SET AMHSTR=""
SET AMHH=$PIECE(^DD(9002011.07,.03,0),U)
SET AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.03)
DO BUILD1
+7 SET AMHSTR=""
SET AMHH=$PIECE(^DD(9002011.07,.02,0),U)
SET AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.02)
DO BUILD1
+8 SET AMHSTR=""
DO SET
+9 FOR AMHX=1000,4100
Begin DoDot:2
+10 SET AMHSTR=$PIECE(^DD(9002011.07,AMHX,0),U)_":"
DO SET
+11 KILL AMHAR
DO ENP^XBDIQ1(9002011.07,DFN,AMHX,"AMHAR(","E")
+12 SET F=0
FOR
SET F=$ORDER(AMHAR(AMHX,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(AMHX,F)
DO SET
+13 SET AMHSTR=""
DO SET
+14 QUIT
End DoDot:2
End DoDot:1
VFILES ;set up array of all v file entries
+1 NEW DA,D0,DIC,DIQ,DR,DI
+2 FOR AMHVFLE=9002011.05,9002011.08
DO VF2
+3 DO XIT
+4 QUIT
+5 ;
VF2 ;
+1 SET AMHVNM=$PIECE(^DIC(AMHVFLE,0),U)
SET AMHVDG=^DIC(AMHVFLE,0,"GL")
SET AMHVIGR=AMHVDG_"""AD"",AMHR,AMHVDFN)"
SET AMHVDFN=""
+2 IF AMHVFLE=9002011.06
SET AMHVNM=$PIECE(^DIC(AMHVFLE,0),U)
SET AMHVDG=^DIC(AMHVFLE,0,"GL")
SET AMHVIGR=AMHVDG_"""B"",AMHR,AMHVDFN)"
SET AMHVDFN=""
+3 FOR AMHVI=1:1
SET AMHVDFN=$ORDER(@AMHVIGR)
IF AMHVDFN=""
QUIT
DO VF3
+4 QUIT
+5 ;
VF3 ;
+1 ;$J("",X)_AMHSTR D SET
IF AMHVI<2
SET AMHSTR=""
DO SET
SET AMHSTR="=============== "_AMHVNM_" ==============="
SET X=(80-$LENGTH(AMHSTR)\2)
DO SET
+2 KILL AMHAR
DO ENP^XBDIQ1(AMHVFLE,AMHVDFN,".01:.019999;.04:999999","AMHAR(","E")
+3 IF AMHVI>1
SET AMHSTR=""
DO SET
+4 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+5 SET AMHH=$PIECE(^DD(AMHVFLE,F,0),U)
+6 SET AMHV=AMHAR(F)
+7 DO BUILD1
End DoDot:1
+8 QUIT
BUILD1 ;
+1 SET AMHSTR=$EXTRACT(AMHH,1,21)_":"
SET AMHSTR=$$SETSTR^VALM1(AMHV,AMHSTR,24,$LENGTH(AMHV))
+2 DO SET
+3 QUIT
+4 IF $LENGTH(AMHSTR)>39
DO SET
+5 SET AMHV=" "_AMHV_" "
SET X=AMHH_": "_AMHV
+6 IF $LENGTH(AMHSTR)
IF $LENGTH(X)>40
DO SET
+7 IF $LENGTH(AMHSTR)
SET AMHSTR=$$SETSTR^VALM1(X,AMHSTR,40,$LENGTH(X))
+8 IF '$LENGTH(AMHSTR)
SET AMHSTR=X
+9 KILL AMHV,AMHH,X
+10 QUIT
XIT ;
+1 KILL AMHAR,AMHARRY,AMHCTR,AMHH,AMHSTR,AMHV,AMHVDFN,AMHVDG,AMHVFLE,AMHVI,AMHR,AMHVIGR,AMHFL,AMHVNM,AMHVREC,AMHH,AMHV,AMHVI
+2 KILL DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z
+3 QUIT
