AMHVD ; IHS/CMI/LAB - BROWSE VISITS ;
;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
;
;
START ;
NEW AMHX,AMHY,AMHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED
NEW D,R
K AMHV
W:$D(IOF) @IOF
W $$CTR("Browse Behavioral Health Visits",80)
D DBHUSR^AMHUTIL
PAT ;
S DFN=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Patient Selected." Q
S DFN=+Y
I '$$ALLOWP^AMHUTIL(DUZ,DFN) D NALLOWP^AMHUTIL S DFN="" G PAT
S Y=DFN D ^AUPNPAT
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
WHICH ;
S AMHQUIT=0
S AMHW=""
S DIR(0)="S^L:Patient's Last Visit;N:Patient's Last N Visits;D:Visits in a Date Range;A:All of this Patient's Visits;P:Visits to one Program"
S DIR("A")="Browse which subset of visits for "_$P(^DPT(DFN,0),U),DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S AMHW=Y
I AMHW="S" S AMHW="SAN"
D @AMHW Q:AMHQUIT
;
BROWSE ;
K ^TMP("AMHVD",$J)
D GATHER
D EN^VALM("AMH BROWSE VISITS")
K ^TMP("AMHVD",$J)
D CLEAR^VALM1
D FULL^VALM1
END ;
K AMHP,AMHQUIT,AMHW
Q
;
EP(DFN) ;EP to list for one patient
NEW AMHX,AMHY,AMHR0,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED
D FULL^VALM1
NEW D,R
K AMHV
I '$G(DFN) D PAT Q
W:$D(IOF) @IOF
W $$CTR("Browse Behavioral Health Visits",80)
I $D(^AMHBHUSR(DUZ)),$O(^AMHBHUSR(DUZ,11,0)) D
.W !!,$G(IORVON),"Please note:",$G(IORVOFF)," Only visits to the following locations will"
.W !?15,"be displayed:"
.S X=0 F S X=$O(^AMHBHUSR(DUZ,11,X)) Q:X'=+X W !?15,$P(^DIC(4,X,0),U)
.W !!
S Y=DFN D ^AUPNPAT
D WHICH
Q
L ;get patients last visit
;AMHV array
;I '$D(^AMHREC("AE",DFN)) W !!,"No visits on file for this patient.",! S AMHQUIT=1 Q
;S D=$O(^AMHREC("AE",DFN,"")),R=$O(^AMHREC("AE",DFN,D,""))
S (C,D)=0 F S D=$O(^AMHREC("AE",DFN,D)) Q:D'=+D!(C>0) S V=0 F S V=$O(^AMHREC("AE",DFN,D,V)) Q:V'=+V!(C>0) I $$ALLOWVI^AMHUTIL(DUZ,V) S C=C+1,AMHV(D,V)=""
;I R S AMHV(D,R)=""
Q
SAN ;san only
S D=0,V=0
F S D=$O(^AMHREC("AE",DFN,D)) Q:D'=+D S V=0 F S V=$O(^AMHREC("AE",DFN,D,V)) Q:V'=+V I $P(^AMHREC(V,0),U,33)="S",$$ALLOWVI^AMHUTIL(DUZ,V) S AMHV(D,V)=""
Q
N ;patients last N visits
S N=""
S DIR(0)="N^1:99:0",DIR("A")="How many visits should be displayed",DIR("B")="5" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S AMHQUIT=1 Q
S N=Y
S (C,D)=0 F S D=$O(^AMHREC("AE",DFN,D)) Q:D'=+D!(C=N) S V=0 F S V=$O(^AMHREC("AE",DFN,D,V)) Q:V'=+V!(C=N) I $$ALLOWVI^AMHUTIL(DUZ,V) S C=C+1,AMHV(D,V)=""
Q
P ;on program
S N=""
S DIR(0)="9002011,.02",DIR("A")="Visits to Which Program",DIR("B")="M" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S AMHQUIT=1 Q
S N=Y
S D=0 F S D=$O(^AMHREC("AE",DFN,D)) Q:D'=+D S V=0 F S V=$O(^AMHREC("AE",DFN,D,V)) Q:V'=+V I $P(^AMHREC(V,0),U,2)=N,$$ALLOWVI^AMHUTIL(DUZ,V) S AMHV(D,V)=""
Q
A ;all visits
S D=0,V=0
F S D=$O(^AMHREC("AE",DFN,D)) Q:D'=+D S V=0 F S V=$O(^AMHREC("AE",DFN,D,V)) Q:V'=+V I $$ALLOWVI^AMHUTIL(DUZ,V) S AMHV(D,V)=""
Q
D ;date range
K AMHED,AMHBD
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date of Visit"
D ^DIR S:Y<1 AMHQUIT=1 Q:Y<1 S AMHBD=Y
K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Date of Visit"
D ^DIR S:Y<1 AMHQUIT=1 Q:Y<1 S AMHED=Y
;
I AMHED<AMHBD D G D
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
S E=9999999-AMHBD,D=9999999-AMHED-1_".99" F S D=$O(^AMHREC("AE",DFN,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",DFN,D,V)) Q:V'=+V I $$ALLOWVI^AMHUTIL(DUZ,V) S AMHV(D,V)=""
Q
PRINT ;EP - called from xbdbque
S AMHQUIT=0
;gather up all visit records in ^TMP("AMHVD",$J
D GATHER
D PRINT1
K ^TMP("AMHVD",$J)
Q
;
PRINT1 ;
W:$D(IOF) @IOF
NEW AMHX
S AMHX=0 F S AMHX=$O(^TMP("AMHVD",$J,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
.I $Y>(IOSL-5) D FF Q:AMHQUIT
.W !,^TMP("AMHVD",$J,AMHX,0)
.Q
Q
GATHER ;
K ^TMP("AMHVD",$J)
NEW AMHX,AMHI,AMHJ,AMHY,AMHZ,AMHC,AMHD
S AMHC=0
S X="Patient Name: "_$P(^DPT(DFN,0),U),$E(X,45)="DOB: "_$$FMTE^XLFDT($P(^DPT(DFN,0),U,3)) D S(X)
S X="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2)) D S(X)
I $O(^AMHPSUIC("AC",DFN,0)) D
.S X="****** Suicide Forms on File ******" D S(X,2)
.S AMHD=0 F S AMHD=$O(^AMHPSUIC("AA",DFN,AMHD)) Q:AMHD'=+AMHD S AMHY=0 F S AMHY=$O(^AMHPSUIC("AA",DFN,AMHD,AMHY)) Q:AMHY'=+AMHY D
..S X="Date of Act: "_$$VAL^XBDIQ1(9002011.65,AMHY,.06),$E(X,40)="Suicidal Behavior: "_$$VAL^XBDIQ1(9002011.65,AMHY,.13) D S(X)
..S X="Previous Attempts: "_$$VAL^XBDIQ1(9002011.65,AMHY,.14),$E(X,40)="Method: "
..S Y="",Z=0 F S Z=$O(^AMHPSUIC(AMHY,11,Z)) Q:Z'=+Z S Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$P(^AMHPSUIC(AMHY,11,Z,0),U))_" "
..S X=X_Y D S(X)
S X=$TR($J("",80)," ","*") D S(X)
S AMHV=0,AMHD=0
F S AMHD=$O(AMHV(AMHD)) Q:AMHD'=+AMHD S AMHV=0 F S AMHV=$O(AMHV(AMHD,AMHV)) Q:AMHV'=+AMHV D
.S AMHR0=^AMHREC(AMHV,0)
.S X="Visit Date: "_$$FMTE^XLFDT($P(AMHR0,U)),$E(X,45)="Provider: "_$$PPNAME^AMHUTIL(AMHV) D S(X,1)
.;I $P($P(AMHR0,U),".")<$$DATE^AMHESIG() S X="Type of Visit: "_$$VAL^XBDIQ1(9002011,AMHV,.33) D S(X)
.S X="Activity Type: "_$S($P(AMHR0,U,6)]"":$E($P(^AMHTACT($P(AMHR0,U,6),0),U,2),1,28),1:""),$E(X,45)="Type of Contact: "_$$VAL^XBDIQ1(9002011,AMHV,.07) D S(X)
.S X="Location of Encounter: "_$$VAL^XBDIQ1(9002011,AMHV,.04) D S(X)
.I $P(AMHR0,U,17)]"" S X="Placement Disposition: "_$$VAL^XBDIQ1(9002011,AMHV,.17) D S(X)
.I $P(AMHR0,U,18)]"" S X="Referred To: "_$$VAL^XBDIQ1(9002011,AMHV,.18) D S(X)
.S X="Chief Complaint/Presenting Problem: "_$P($G(^AMHREC(AMHV,21)),U) D S(X)
.S X="POV's:" D S(X)
.S AMHP=0 F S AMHP=$O(^AMHRPRO("AD",AMHV,AMHP)) Q:AMHP'=+AMHP D
..S X="",$E(X,3)=$$VAL^XBDIQ1(9002011.01,AMHP,.01),$E(X,12)=$E($$VAL^XBDIQ1(9002011.01,AMHP,.04),1,65) D S(X)
..Q
.;SUB/OBJ
.I '$O(^AMHREC(AMHV,54,0)) G SUB
.S X="" D S(X) D S("TIU DOCUMENTS") D S("-------------")
.S AMHDOC=0 F S AMHDOC=$O(^AMHREC(AMHV,54,"B",AMHDOC)) Q:AMHDOC'=+AMHDOC D
..K AMHTIU,AMHERR
..K ^TMP("AMHOENPS",$J)
..D TIUDSP
..K ^TMP("AMHEONPS",$J)
..K AMHTIU
..Q
.G SAN1
SUB .;
.S X="",$E(X,3)="SUBJECTIVE/OBJECTIVE: " D S(X,1)
.S AMHX=0 F S AMHX=$O(^AMHREC(AMHV,31,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
..S X="",$E(X,3)=^AMHREC(AMHV,31,AMHX,0) D S(X)
..Q
SAN1 .;SAN
.D SAN^AMHVD1
.;INTAKE
.;D INTAKE^AMHVD1
COM .;
.S X="",$E(X,3)="COMMENT/NEXT APPOINTMENT: " D S(X,1)
.S AMHX=0 F S AMHX=$O(^AMHREC(AMHV,81,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
..S X="",$E(X,3)=^AMHREC(AMHV,81,AMHX,0) D S(X)
..Q
NFT .;
.I $O(^AMHREC(AMHV,52,0)) S X="",$E(X,3)="NOTE FORWARDED TO: " D S(X,1) D
..S AMHX=0 F S AMHX=$O(^AMHREC(AMHV,52,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
...S X=$P(^VA(200,$P(^AMHREC(AMHV,52,AMHX,0),U),0),U) D S(X)
..Q
.S X="Medications Prescribed: " D S(X,1)
.S AMHX=0 F S AMHX=$O(^AMHREC(AMHV,41,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
..S X="",$E(X,3)=^AMHREC(AMHV,41,AMHX,0) D S(X)
..Q
.S X=$TR($J("",80)," ","*") D S(X)
Q
TIUDSP ;
S AMHSTR="" D S(AMHSTR)
I '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ) Q ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D S(AMHSTR) 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 S(AMHSTR)
S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D S(AMHSTR)
S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E") D S(AMHSTR)
S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D S(AMHSTR)
F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX S AMHSTR=AMHTIU("TEXT",AMHX,0) D S(AMHSTR)
I $L($G(AMHTIU(1501,"E"))) D
.S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D S(AMHSTR)
.S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D S(AMHSTR)
;NOW GET ADDENDA USING "DAD" XREF
I $O(^TIU(8925,"DAD",AMHDOC,0)) S AMHSTR="" D S(AMHSTR) ;S AMHSTR="This document has addenda." D S(AMHSTR)
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 S(AMHSTR) 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 S(AMHSTR)
.S AMHSTR=AMHTIU(.01,"E") D S(AMHSTR)
.S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D S(AMHSTR)
.S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E") D S(AMHSTR)
.S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D S(AMHSTR)
.F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX S AMHSTR=AMHTIU("TEXT",AMHX,0) D S(AMHSTR)
.I $L($G(AMHTIU(1501,"E"))) D
..S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D S(AMHSTR)
..S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D S(AMHSTR)
;
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
FF ;EP
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT=1 Q
I $E(IOST)'="C" Q:'$P(AMHR0,U,8) W !!,$TR($J(" ",79)," ","*"),!,$P(^DPT($P(AMHR0,U,8),0),U),?32,"HRN: " D
.S H=$P($G(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2),0)),U,2)
.W H,?46,"DOB: ",$$FMTE^XLFDT($P(^DPT($P(AMHR0,U,8),0),U,3),"2D"),?59,"SSN: ",$$SSN^AMHUTIL($P(AMHR0,U,8)),!
W:$D(IOF) @IOF
Q
HDR ; -- header code
Q
;
S(Y,F,C,T) ;EP - set up array
I '$G(F) S F=0
I '$G(T) S T=0
;blank lines
F F=1:1:F S X="" D S1
S X=$TR(Y,$C(10),"")
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S AMHC=AMHC+1
S ^TMP("AMHVD",$J,AMHC,0)=X
Q
INIT ; -- init variables and list array
S VALMCNT=$O(^TMP("AMHVD",$J,""),-1)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
TEST ;
D EXTRACT^TIULQ(3,"^TMP(""AMHLQ"",$J)",.TIUERR,"2","",1)
Q
AMHVD ; IHS/CMI/LAB - BROWSE VISITS ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
+2 ;
+3 ;
START ;
+1 NEW AMHX,AMHY,AMHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED
+2 NEW D,R
+3 KILL AMHV
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE $$CTR("Browse Behavioral Health Visits",80)
+6 DO DBHUSR^AMHUTIL
PAT ;
+1 SET DFN=""
+2 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+3 IF Y<0
WRITE !,"No Patient Selected."
QUIT
+4 SET DFN=+Y
+5 IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
DO NALLOWP^AMHUTIL
SET DFN=""
GOTO PAT
+6 SET Y=DFN
DO ^AUPNPAT
+7 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$DT_source.html#FMTE">FMTE^XLFDT(AUPNDOD),!!
HANG 2
WHICH ;
+1 SET AMHQUIT=0
+2 SET AMHW=""
+3 SET DIR(0)="S^L:Patient's Last Visit;N:Patient's Last N Visits;D:Visits in a Date Range;A:All of this Patient's Visits;P:Visits to one Program"
+4 SET DIR("A")="Browse which subset of visits for "_$PIECE(^DPT(DFN,0),U)
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 SET AMHW=Y
+7 IF AMHW="S"
SET AMHW="SAN"
+8 DO @AMHW
IF AMHQUIT
QUIT
+9 ;
BROWSE ;
+1 KILL ^TMP("AMHVD",$JOB)
+2 DO GATHER
+3 DO EN^VALM("AMH BROWSE VISITS")
+4 KILL ^TMP("AMHVD",$JOB)
+5 DO CLEAR^VALM1
+6 DO FULL^VALM1
END ;
+1 KILL AMHP,AMHQUIT,AMHW
+2 QUIT
+3 ;
EP(DFN) ;EP to list for one patient
+1 NEW AMHX,AMHY,AMHR0,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED
+2 DO FULL^VALM1
+3 NEW D,R
+4 KILL AMHV
+5 IF '$GET(DFN)
DO PAT
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 WRITE $$CTR("Browse Behavioral Health Visits",80)
+8 IF $DATA(^AMHBHUSR(DUZ))
IF $ORDER(^AMHBHUSR(DUZ,11,0))
Begin DoDot:1
+9 WRITE !!,$GET(IORVON),"Please note:",$GET(IORVOFF)," Only visits to the following locations will"
+10 WRITE !?15,"be displayed:"
+11 SET X=0
FOR
SET X=$ORDER(^AMHBHUSR(DUZ,11,X))
IF X'=+X
QUIT
WRITE !?15,$PIECE(^DIC(4,X,0),U)
+12 WRITE !!
End DoDot:1
+13 SET Y=DFN
DO ^AUPNPAT
+14 DO WHICH
+15 QUIT
L ;get patients last visit
+1 ;AMHV array
+2 ;I '$D(^AMHREC("AE",DFN)) W !!,"No visits on file for this patient.",! S AMHQUIT=1 Q
+3 ;S D=$O(^AMHREC("AE",DFN,"")),R=$O(^AMHREC("AE",DFN,D,""))
+4 SET (C,D)=0
FOR
SET D=$ORDER(^AMHREC("AE",DFN,D))
IF D'=+D!(C>0)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",DFN,D,V))
IF V'=+V!(C>0)
QUIT
IF $$ALLOWVI^AMHUTIL(DUZ,V)
SET C=C+1
SET AMHV(D,V)=""
+5 ;I R S AMHV(D,R)=""
+6 QUIT
SAN ;san only
+1 SET D=0
SET V=0
+2 FOR
SET D=$ORDER(^AMHREC("AE",DFN,D))
IF D'=+D
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",DFN,D,V))
IF V'=+V
QUIT
IF $PIECE(^AMHREC(V,0),U,33)="S"
IF $$ALLOWVI^AMHUTIL(DUZ,V)
SET AMHV(D,V)=""
+3 QUIT
N ;patients last N visits
+1 SET N=""
+2 SET DIR(0)="N^1:99:0"
SET DIR("A")="How many visits should be displayed"
SET DIR("B")="5"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET AMHQUIT=1
QUIT
+4 SET N=Y
+5 SET (C,D)=0
FOR
SET D=$ORDER(^AMHREC("AE",DFN,D))
IF D'=+D!(C=N)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",DFN,D,V))
IF V'=+V!(C=N)
QUIT
IF $$ALLOWVI^AMHUTIL(DUZ,V)
SET C=C+1
SET AMHV(D,V)=""
+6 QUIT
P ;on program
+1 SET N=""
+2 SET DIR(0)="9002011,.02"
SET DIR("A")="Visits to Which Program"
SET DIR("B")="M"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET AMHQUIT=1
QUIT
+4 SET N=Y
+5 SET D=0
FOR
SET D=$ORDER(^AMHREC("AE",DFN,D))
IF D'=+D
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",DFN,D,V))
IF V'=+V
QUIT
IF $PIECE(^AMHREC(V,0),U,2)=N
IF $$ALLOWVI^AMHUTIL(DUZ,V)
SET AMHV(D,V)=""
+6 QUIT
A ;all visits
+1 SET D=0
SET V=0
+2 FOR
SET D=$ORDER(^AMHREC("AE",DFN,D))
IF D'=+D
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",DFN,D,V))
IF V'=+V
QUIT
IF $$ALLOWVI^AMHUTIL(DUZ,V)
SET AMHV(D,V)=""
+3 QUIT
D ;date range
+1 KILL AMHED,AMHBD
+2 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date of Visit"
+3 DO ^DIR
IF Y<1
SET AMHQUIT=1
IF Y<1
QUIT
SET AMHBD=Y
+4 KILL DIR
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Ending Date of Visit"
+5 DO ^DIR
IF Y<1
SET AMHQUIT=1
IF Y<1
QUIT
SET AMHED=Y
+6 ;
+7 IF AMHED<AMHBD
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO D
+9 SET E=9999999-AMHBD
SET D=9999999-AMHED-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",DFN,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",DFN,D,V))
IF V'=+V
QUIT
IF $$ALLOWVI^AMHUTIL(DUZ,V)
SET AMHV(D,V)=""
+10 QUIT
PRINT ;EP - called from xbdbque
+1 SET AMHQUIT=0
+2 ;gather up all visit records in ^TMP("AMHVD",$J
+3 DO GATHER
+4 DO PRINT1
+5 KILL ^TMP("AMHVD",$JOB)
+6 QUIT
+7 ;
PRINT1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 NEW AMHX
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^TMP("AMHVD",$JOB,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-5)
DO FF
IF AMHQUIT
QUIT
+5 WRITE !,^TMP("AMHVD",$JOB,AMHX,0)
+6 QUIT
End DoDot:1
+7 QUIT
GATHER ;
+1 KILL ^TMP("AMHVD",$JOB)
+2 NEW AMHX,AMHI,AMHJ,AMHY,AMHZ,AMHC,AMHD
+3 SET AMHC=0
+4 SET X="Patient Name: "_$PIECE(^DPT(DFN,0),U)
SET $EXTRACT(X,45)="DOB: "_$$FMTE^XLFDT($PIECE(^DPT(DFN,0),U,3))
DO S(X)
+5 SET X="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))
DO S(X)
+6 IF $ORDER(^AMHPSUIC("AC",DFN,0))
Begin DoDot:1
+7 SET X="****** Suicide Forms on File ******"
DO S(X,2)
+8 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPSUIC("AA",DFN,AMHD))
IF AMHD'=+AMHD
QUIT
SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHPSUIC("AA",DFN,AMHD,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+9 SET X="Date of Act: "_$$VAL^XBDIQ1(9002011.65,AMHY,.06)
SET $EXTRACT(X,40)="Suicidal Behavior: "_$$VAL^XBDIQ1(9002011.65,AMHY,.13)
DO S(X)
+10 SET X="Previous Attempts: "_$$VAL^XBDIQ1(9002011.65,AMHY,.14)
SET $EXTRACT(X,40)="Method: "
+11 SET Y=""
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(AMHY,11,Z))
IF Z'=+Z
QUIT
SET Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$PIECE(^AMHPSUIC(AMHY,11,Z,0),U))_" "
+12 SET X=X_Y
DO S(X)
End DoDot:2
End DoDot:1
+13 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
DO S(X)
+14 SET AMHV=0
SET AMHD=0
+15 FOR
SET AMHD=$ORDER(AMHV(AMHD))
IF AMHD'=+AMHD
QUIT
SET AMHV=0
FOR
SET AMHV=$ORDER(AMHV(AMHD,AMHV))
IF AMHV'=+AMHV
QUIT
Begin DoDot:1
+16 SET AMHR0=^AMHREC(AMHV,0)
+17 SET X="Visit Date: "_$$FMTE^XLFDT($PIECE(AMHR0,U))
SET $EXTRACT(X,45)="Provider: "_$$PPNAME^AMHUTIL(AMHV)
DO S(X,1)
+18 ;I $P($P(AMHR0,U),".")<$$DATE^AMHESIG() S X="Type of Visit: "_$$VAL^XBDIQ1(9002011,AMHV,.33) D S(X)
+19 SET X="Activity Type: "_$SELECT($PIECE(AMHR0,U,6)]"":$EXTRACT($PIECE(^AMHTACT($PIECE(AMHR0,U,6),0),U,2),1,28),1:"")
SET $EXTRACT(X,45)="Type of Contact: "_$$VAL^XBDIQ1(9002011,AMHV,.07)
DO S(X)
+20 SET X="Location of Encounter: "_$$VAL^XBDIQ1(9002011,AMHV,.04)
DO S(X)
+21 IF $PIECE(AMHR0,U,17)]""
SET X="Placement Disposition: "_$$VAL^XBDIQ1(9002011,AMHV,.17)
DO S(X)
+22 IF $PIECE(AMHR0,U,18)]""
SET X="Referred To: "_$$VAL^XBDIQ1(9002011,AMHV,.18)
DO S(X)
+23 SET X="Chief Complaint/Presenting Problem: "_$PIECE($GET(^AMHREC(AMHV,21)),U)
DO S(X)
+24 SET X="POV's:"
DO S(X)
+25 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHRPRO("AD",AMHV,AMHP))
IF AMHP'=+AMHP
QUIT
Begin DoDot:2
+26 SET X=""
SET $EXTRACT(X,3)=$$VAL^XBDIQ1(9002011.01,AMHP,.01)
SET $EXTRACT(X,12)=$EXTRACT($$VAL^XBDIQ1(9002011.01,AMHP,.04),1,65)
DO S(X)
+27 QUIT
End DoDot:2
+28 ;SUB/OBJ
+29 IF '$ORDER(^AMHREC(AMHV,54,0))
GOTO SUB
+30 SET X=""
DO S(X)
DO S("TIU DOCUMENTS")
DO S("-------------")
+31 SET AMHDOC=0
FOR
SET AMHDOC=$ORDER(^AMHREC(AMHV,54,"B",AMHDOC))
IF AMHDOC'=+AMHDOC
QUIT
Begin DoDot:2
+32 KILL AMHTIU,AMHERR
+33 KILL ^TMP("AMHOENPS",$JOB)
+34 DO TIUDSP
+35 KILL ^TMP("AMHEONPS",$JOB)
+36 KILL AMHTIU
+37 QUIT
End DoDot:2
+38 GOTO SAN1
SUB ;
+1 SET X=""
SET $EXTRACT(X,3)="SUBJECTIVE/OBJECTIVE: "
DO S(X,1)
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHV,31,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:2
+3 SET X=""
SET $EXTRACT(X,3)=^AMHREC(AMHV,31,AMHX,0)
DO S(X)
+4 QUIT
End DoDot:2
SAN1 ;SAN
+1 DO SAN^AMHVD1
+2 ;INTAKE
+3 ;D INTAKE^AMHVD1
COM ;
+1 SET X=""
SET $EXTRACT(X,3)="COMMENT/NEXT APPOINTMENT: "
DO S(X,1)
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHV,81,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:2
+3 SET X=""
SET $EXTRACT(X,3)=^AMHREC(AMHV,81,AMHX,0)
DO S(X)
+4 QUIT
End DoDot:2
NFT ;
+1 IF $ORDER(^AMHREC(AMHV,52,0))
SET X=""
SET $EXTRACT(X,3)="NOTE FORWARDED TO: "
DO S(X,1)
Begin DoDot:2
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHV,52,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:3
+3 SET X=$PIECE(^VA(200,$PIECE(^AMHREC(AMHV,52,AMHX,0),U),0),U)
DO S(X)
End DoDot:3
+4 QUIT
End DoDot:2
+5 SET X="Medications Prescribed: "
DO S(X,1)
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHV,41,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:2
+7 SET X=""
SET $EXTRACT(X,3)=^AMHREC(AMHV,41,AMHX,0)
DO S(X)
+8 QUIT
End DoDot:2
+9 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
DO S(X)
End DoDot:1
+10 QUIT
TIUDSP ;
+1 SET AMHSTR=""
DO S(AMHSTR)
+2 ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D S(AMHSTR) 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 S(AMHSTR)
+10 SET AMHSTR="AUTHOR: "_AMHTIU(1202,"E")
DO S(AMHSTR)
+11 SET AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E")
DO S(AMHSTR)
+12 SET AMHSTR="LOCATION: "_AMHTIU(1205,"E")
DO S(AMHSTR)
+13 FOR AMHX=0:0
SET AMHX=$ORDER(AMHTIU("TEXT",AMHX))
IF 'AMHX
QUIT
SET AMHSTR=AMHTIU("TEXT",AMHX,0)
DO S(AMHSTR)
+14 IF $LENGTH($GET(AMHTIU(1501,"E")))
Begin DoDot:1
+15 SET AMHSTR="/es/ "_$GET(AMHTIU(1503,"E"))
DO S(AMHSTR)
+16 SET AMHSTR="Signed: "_$GET(AMHTIU(1501,"E"))
DO S(AMHSTR)
End DoDot:1
+17 ;NOW GET ADDENDA USING "DAD" XREF
+18 ;S AMHSTR="This document has addenda." D S(AMHSTR)
IF $ORDER(^TIU(8925,"DAD",AMHDOC,0))
SET AMHSTR=""
DO S(AMHSTR)
+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 S(AMHSTR) 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 S(AMHSTR)
+28 SET AMHSTR=AMHTIU(.01,"E")
DO S(AMHSTR)
+29 SET AMHSTR="AUTHOR: "_AMHTIU(1202,"E")
DO S(AMHSTR)
+30 SET AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_" STATUS: "_AMHTIU(.05,"E")
DO S(AMHSTR)
+31 SET AMHSTR="LOCATION: "_AMHTIU(1205,"E")
DO S(AMHSTR)
+32 FOR AMHX=0:0
SET AMHX=$ORDER(AMHTIU("TEXT",AMHX))
IF 'AMHX
QUIT
SET AMHSTR=AMHTIU("TEXT",AMHX,0)
DO S(AMHSTR)
+33 IF $LENGTH($GET(AMHTIU(1501,"E")))
Begin DoDot:2
+34 SET AMHSTR="/es/ "_$GET(AMHTIU(1503,"E"))
DO S(AMHSTR)
+35 SET AMHSTR="Signed: "_$GET(AMHTIU(1501,"E"))
DO S(AMHSTR)
End DoDot:2
End DoDot:1
+36 ;
+37 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
FF ;EP
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET AMHQUIT=1
QUIT
+2 IF $EXTRACT(IOST)'="C"
IF '$PIECE(AMHR0,U,8)
QUIT
WRITE !!,$TRANSLATE($JUSTIFY(" ",79)," ","*"),!,$PIECE(^DPT($PIECE(AMHR0,U,8),0),U),?32,"HRN: "
Begin DoDot:1
+3 SET H=$PIECE($GET(^AUPNPAT($PIECE(AMHR0,U,8),41,DUZ(2),0)),U,2)
+4 WRITE H,?46,"DOB: ",$$FMTE^XLFDT($PIECE(^DPT($PIECE(AMHR0,U,8),0),U,3),"2D"),?59,"SSN: ",$$SSN^AMHUTIL($PIECE(AMHR0,U,8)),!
End DoDot:1
+5 IF $DATA(IOF)
WRITE @IOF
+6 QUIT
HDR ; -- header code
+1 QUIT
+2 ;
S(Y,F,C,T) ;EP - set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 ;blank lines
+4 FOR F=1:1:F
SET X=""
DO S1
+5 SET X=$TRANSLATE(Y,$CHAR(10),"")
+6 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+7 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+8 FOR %=1:1:T
SET X=" "_Y
+9 DO S1
+10 QUIT
S1 ;
+1 SET AMHC=AMHC+1
+2 SET ^TMP("AMHVD",$JOB,AMHC,0)=X
+3 QUIT
INIT ; -- init variables and list array
+1 SET VALMCNT=$ORDER(^TMP("AMHVD",$JOB,""),-1)
+2 QUIT
+3 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
TEST ;
+1 DO EXTRACT^TIULQ(3,"^TMP(""AMHLQ"",$J)",.TIUERR,"2","",1)
+2 QUIT
