AMHVDSG1 ; IHS/CMI/LAB -VISIT DISPLAY NO REVERSE VIDEO FOR GUI ;
;;4.0;IHS BEHAVIORAL HEALTH;**3,4**;JUN 18, 2010;Build 28
;
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:3100","AMHAR(","E")
F F=.01,.02,.04,.26,.05,.06,.069,.07,.08,.081,.25,.09,.11,.12,.14,.15,.16,.17,.18,.03,.19,.21,.28,1114 D
.;S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.Q:AMHAR(F)=""
.S AMHDONE(F)=""
.I F=.081,$P(^AMHREC(AMHR,0),U,8)="" Q
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
S AMHSTR="EDIT HISTORY: " D SET
S F=0 F S F=$O(^AMHREC(AMHR,51,F)) Q:F'=+F D
.Q:'$D(^AMHREC(AMHR,51,F,0))
.Q:$P(^AMHREC(AMHR,51,F,0),U)=""
.Q:$P(^AMHREC(AMHR,51,F,0),U,2)=""
.S AMHSTR=" "_$$FMTE^XLFDT($P(^AMHREC(AMHR,51,F,0),U),"1P"),$E(AMHSTR,30)=$P($G(^VA(200,$P(^AMHREC(AMHR,51,F,0),U,2),0)),U) D SET
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"",'$D(AMHDONE(F)) D
.I F=.081,$P(^AMHREC(AMHR,0),U,8)="" Q
.Q:F=.33 ;I F=.33,$$DATE^AMHESIG()<$P($P(^AMHREC(AMHR,0),U),".") Q
.Q:F=1108
.S AMHH=$P(^DD(9002011,F,0),U)
.S AMHV=AMHAR(F)
.D BUILD1
S AMHSTR="" D SET
AXIS3 ;
I $$DSMCS^AMHUTIL1(DUZ(2),$P($P(^AMHREC(AMHR,0),U),"."))'=4 G TIUN
S AMHSTR="AXIS III:" D SET
K AMHAR D ENP^XBDIQ1(9002011,AMHR,5301,"AMHAR(","E")
S F=0 F S F=$O(AMHAR(5301,F)) Q:F'=+F S AMHSTR=AMHAR(5301,F) D SET
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 '$O(^AMHREC(AMHR,54,0)) G 1
S AMHSTR="" D SET S AMHSTR="TIU DOCUMENTS" D SET S AMHSTR="-------------" D SET
S AMHDOC=0 F S AMHDOC=$O(^AMHREC(AMHR,54,"B",AMHDOC)) Q:AMHDOC'=+AMHDOC D
.K AMHTIU,AMHERR
.K ^TMP("AMHOENPS",$J)
.D TIUDSP
.Q
;
1 ;
I $P($G(^AMHREC(AMHR,11)),U,10) G 4 ;ehr visit no subj/obj per BJ
S AMHSTR="" D SET
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
INTAKEX ;
VFILES ;set up array of all v file entries
NEW DA,D0,DIC,DIQ,DR,DI
S AMHVFLE=9002011 F S AMHVFLE=$O(^DIC(AMHVFLE)) Q:AMHVFLE>9002011.50!(AMHVFLE'=+AMHVFLE) D VF2
D XIT
Q
;
TIUDSP ;
S AMHSTR="" D SET
I '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ) Q ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D SET Q
; Extract specified note
S AMHGBL=$NA(^TMP("AMHOENPS",$J)),AMHHLF=IOM\2
K @AMHGBL
D EXTRACT^TIULQ(AMHDOC,AMHGBL,.AMHERR,".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="TIU DOCUMENT: "_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
;NOW GET ADDENDA USING "DAD" XREF
I $O(^TIU(8925,"DAD",AMHDOC,0)) S AMHSTR="" D SET ;S AMHSTR="This document has addenda." D SET
S AMHX1=0 F S AMHX1=$O(^TIU(8925,"DAD",AMHDOC,AMHX1)) Q:AMHX1'=+AMHX1 D
.I '+$$CANDO^TIULP(AMHX1,"PRINT RECORD",DUZ) Q ;S AMHSTR="You do not have security clearance to display the addendum." D SET Q
.S AMHGBL=$NA(^TMP("AMHOENPS",$J))
.K @AMHGBL
.K AMHTIU
.D EXTRACT^TIULQ(AMHX1,AMHGBL,.AMHERR,".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,AMHX1)
.K ^TMP("AMHOENPS",$J)
.S AMHSTR="" D SET
.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
;
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
K DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z
Q
AMHVDSG1 ; IHS/CMI/LAB -VISIT DISPLAY NO REVERSE VIDEO FOR GUI ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**3,4**;JUN 18, 2010;Build 28
+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:3100","AMHAR(","E")
+3 FOR F=.01,.02,.04,.26,.05,.06,.069,.07,.08,.081,.25,.09,.11,.12,.14,.15,.16,.17,.18,.03,.19,.21,.28,1114
Begin DoDot:1
+4 ;S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
+5 IF AMHAR(F)=""
QUIT
+6 SET AMHDONE(F)=""
+7 IF F=.081
IF $PIECE(^AMHREC(AMHR,0),U,8)=""
QUIT
+8 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+9 SET AMHV=AMHAR(F)
+10 DO BUILD1
End DoDot:1
+11 SET AMHSTR="EDIT HISTORY: "
DO SET
+12 SET F=0
FOR
SET F=$ORDER(^AMHREC(AMHR,51,F))
IF F'=+F
QUIT
Begin DoDot:1
+13 IF '$DATA(^AMHREC(AMHR,51,F,0))
QUIT
+14 IF $PIECE(^AMHREC(AMHR,51,F,0),U)=""
QUIT
+15 IF $PIECE(^AMHREC(AMHR,51,F,0),U,2)=""
QUIT
+16 SET AMHSTR=" "_$$FMTE^XLFDT($PIECE(^AMHREC(AMHR,51,F,0),U),"1P")
SET $EXTRACT(AMHSTR,30)=$PIECE($GET(^VA(200,$PIECE(^AMHREC(AMHR,51,F,0),U,2),0)),U)
DO SET
End DoDot:1
+17 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
IF '$DATA(AMHDONE(F))
Begin DoDot:1
+18 IF F=.081
IF $PIECE(^AMHREC(AMHR,0),U,8)=""
QUIT
+19 ;I F=.33,$$DATE^AMHESIG()<$P($P(^AMHREC(AMHR,0),U),".") Q
IF F=.33
QUIT
+20 IF F=1108
QUIT
+21 SET AMHH=$PIECE(^DD(9002011,F,0),U)
+22 SET AMHV=AMHAR(F)
+23 DO BUILD1
End DoDot:1
+24 SET AMHSTR=""
DO SET
AXIS3 ;
+1 IF $$DSMCS^AMHUTIL1(DUZ(2),$PIECE($PIECE(^AMHREC(AMHR,0),U),"."))'=4
GOTO TIUN
+2 SET AMHSTR="AXIS III:"
DO SET
+3 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,5301,"AMHAR(","E")
+4 SET F=0
FOR
SET F=$ORDER(AMHAR(5301,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(5301,F)
DO SET
+5 SET AMHSTR=""
DO SET
AXIS4 ;
+1 SET AMHSTR="AXIS IV:"
DO SET
+2 KILL AMHAR
SET Y=0
FOR
SET Y=$ORDER(^AMHREC(AMHR,61,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+3 SET %=$PIECE(^AMHREC(AMHR,61,Y,0),U)
SET AMHSTR=%_" - "_$PIECE(^AMHTAXIV(%,0),U,2)
DO SET
End DoDot:1
+4 SET AMHSTR=""
DO SET
+5 ;
TIUN ;
+1 IF '$ORDER(^AMHREC(AMHR,54,0))
GOTO 1
+2 SET AMHSTR=""
DO SET
SET AMHSTR="TIU DOCUMENTS"
DO SET
SET AMHSTR="-------------"
DO SET
+3 SET AMHDOC=0
FOR
SET AMHDOC=$ORDER(^AMHREC(AMHR,54,"B",AMHDOC))
IF AMHDOC'=+AMHDOC
QUIT
Begin DoDot:1
+4 KILL AMHTIU,AMHERR
+5 KILL ^TMP("AMHOENPS",$JOB)
+6 DO TIUDSP
+7 QUIT
End DoDot:1
+8 ;
1 ;
+1 ;ehr visit no subj/obj per BJ
IF $PIECE($GET(^AMHREC(AMHR,11)),U,10)
GOTO 4
+2 SET AMHSTR=""
DO SET
+3 SET AMHSTR="SUBJECTIVE/OBJECTIVE:"
DO SET
+4 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,3101,"AMHAR(","E")
+5 SET F=0
FOR
SET F=$ORDER(AMHAR(3101,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(3101,F)
DO SET
+6 SET AMHSTR=""
DO SET
4 ;
+1 SET AMHSTR="COMMENT/NEXT APPOINTMENT:"
DO SET
+2 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,8101,"AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(8101,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(8101,F)
DO SET
+4 SET AMHSTR=""
DO SET
NFT ;
+1 SET AMHSTR="NOTE FORWARDED TO:"
DO SET
+2 KILL AMHAR
SET Y=0
FOR
SET Y=$ORDER(^AMHREC(AMHR,52,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+3 SET %=$PIECE(^AMHREC(AMHR,52,Y,0),U)
SET AMHSTR=$PIECE(^VA(200,%,0),U)
DO SET
End DoDot:1
+4 SET AMHSTR=""
DO SET
2 ;
+1 SET AMHSTR="MEDICATIONS PRESCRIBED:"
DO SET
+2 KILL AMHAR
DO ENP^XBDIQ1(9002011,AMHR,4101,"AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(4101,F))
IF F'=+F
QUIT
SET AMHSTR=AMHAR(4101,F)
DO SET
+4 SET AMHSTR=""
DO SET
SAN ;
+1 IF $PIECE(^AMHREC(AMHR,0),U,33)="S"
DO 1^AMHLESA2
+2 IF $PIECE(^AMHREC(AMHR,0),U,33)="U"
DO SANU^AMHLESA2
INTAKEX ;
VFILES ;set up array of all v file entries
+1 NEW DA,D0,DIC,DIQ,DR,DI
+2 SET AMHVFLE=9002011
FOR
SET AMHVFLE=$ORDER(^DIC(AMHVFLE))
IF AMHVFLE>9002011.50!(AMHVFLE'=+AMHVFLE)
QUIT
DO VF2
+3 DO XIT
+4 QUIT
+5 ;
TIUDSP ;
+1 SET AMHSTR=""
DO SET
+2 ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D SET Q
IF '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ)
QUIT
+3 ; Extract specified note
+4 SET AMHGBL=$NAME(^TMP("AMHOENPS",$JOB))
SET AMHHLF=IOM\2
+5 KILL @AMHGBL
+6 DO EXTRACT^TIULQ(AMHDOC,AMHGBL,.AMHERR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
+7 MERGE AMHTIU=^TMP("AMHOENPS",$JOB,AMHDOC)
+8 KILL ^TMP("AMHOENPS",$JOB)
+9 SET AMHSTR="TIU DOCUMENT: "_AMHTIU(.01,"E")
DO SET
+10 SET AMHSTR="AUTHOR: "_AMHTIU(1202,"E")
DO SET
+11 SET AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E")
DO SET
+12 SET AMHSTR="LOCATION: "_AMHTIU(1205,"E")
DO SET
+13 FOR AMHX=0:0
SET AMHX=$ORDER(AMHTIU("TEXT",AMHX))
IF 'AMHX
QUIT
SET AMHSTR=AMHTIU("TEXT",AMHX,0)
DO SET
+14 IF $LENGTH($GET(AMHTIU(1501,"E")))
Begin DoDot:1
+15 SET AMHSTR="/es/ "_$GET(AMHTIU(1503,"E"))
DO SET
+16 SET AMHSTR="Signed: "_$GET(AMHTIU(1501,"E"))
DO SET
End DoDot:1
+17 ;NOW GET ADDENDA USING "DAD" XREF
+18 ;S AMHSTR="This document has addenda." D SET
IF $ORDER(^TIU(8925,"DAD",AMHDOC,0))
SET AMHSTR=""
DO SET
+19 SET AMHX1=0
FOR
SET AMHX1=$ORDER(^TIU(8925,"DAD",AMHDOC,AMHX1))
IF AMHX1'=+AMHX1
QUIT
Begin DoDot:1
+20 ;S AMHSTR="You do not have security clearance to display the addendum." D SET Q
IF '+$$CANDO^TIULP(AMHX1,"PRINT RECORD",DUZ)
QUIT
+21 SET AMHGBL=$NAME(^TMP("AMHOENPS",$JOB))
+22 KILL @AMHGBL
+23 KILL AMHTIU
+24 DO EXTRACT^TIULQ(AMHX1,AMHGBL,.AMHERR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
+25 MERGE AMHTIU=^TMP("AMHOENPS",$JOB,AMHX1)
+26 KILL ^TMP("AMHOENPS",$JOB)
+27 SET AMHSTR=""
DO SET
+28 SET AMHSTR=AMHTIU(.01,"E")
DO SET
+29 SET AMHSTR="AUTHOR: "_AMHTIU(1202,"E")
DO SET
+30 SET AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E")
DO SET
+31 SET AMHSTR="LOCATION: "_AMHTIU(1205,"E")
DO SET
+32 FOR AMHX=0:0
SET AMHX=$ORDER(AMHTIU("TEXT",AMHX))
IF 'AMHX
QUIT
SET AMHSTR=AMHTIU("TEXT",AMHX,0)
DO SET
+33 IF $LENGTH($GET(AMHTIU(1501,"E")))
Begin DoDot:2
+34 SET AMHSTR="/es/ "_$GET(AMHTIU(1503,"E"))
DO SET
+35 SET AMHSTR="Signed: "_$GET(AMHTIU(1501,"E"))
DO SET
End DoDot:2
End DoDot:1
+36 ;
+37 QUIT
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
+2 KILL DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z
+3 QUIT
