AMHNAVRP ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
;
;
D PRINT1(AMHREF)
Q
S(Y,F,C,T) ;set up array
NEW %
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=Y
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 %=$P(^TMP("AMHREF",$J,"DCS",0),U)+1,$P(^TMP("AMHREF",$J,"DCS",0),U)=%
S ^TMP("AMHREF",$J,"DCS",%)=X
Q
PRINT1(AMHREF) ;EP - CALLED FROM LAST VISIT DISPLAY
NEW C,AMHX,H,AMHR0,AMHSTOP,AMHTC,AMHTDLT,AMHTDOO,AMHTF,AMHTICL,AMHTILN,AMHTNRQ,AMHTQ,AMHTTXT,F,AMHPAGE
S AMHPAGE=1
D EP2(AMHREF) ;set array up
S AMHSTOP=0,AMHQUIT=0
W ;write out array
NEW AMHX
W !!
S AMHX=0 F S AMHX=$O(^TMP("AMHREF",$J,"DCS",AMHX)) Q:AMHX'=+AMHX!(AMHSTOP)!(AMHQUIT) D
.I $Y>(IOSL-5) D FF Q:AMHQUIT
.W !,^TMP("AMHREF",$J,"DCS",AMHX)
.Q
W !
K ^TMP("AMHREF",$J,"DCS")
Q
EP2(AMHREF) ;EP ; up array in ^TMP
;
K ^TMP("AMHREF",$J,"DCS")
S ^TMP("AMHREF",$J,"DCS",0)=0
S X="********** CONFIDENTIAL PATIENT INFORMATION **********" D S(X,0,1)
S X="PSYCHIATRIC HOSPITALIZATION" D S(X,1,1)
S X="REFERRAL FORM" D S(X,0,1)
S X="BEHAVIORAL HEALTH COUNSELING SERVICES" D S(X,0,1)
S X="Phone: (505) 722-1571" D S(X,0,1)
;
S DFN=$P(^AMHRNRF(AMHREF,0),U,2)
S AMHRIEN=$P(^AMHRNRF(AMHREF,0),U,3)
S AMHR22=$G(^AMHRNRF(AMHREF,22))
S AMHR0=^AMHRNRF(AMHREF,0)
S AMHRDATE=$P(^AMHRNRF(AMHREF,0),U)
S X="PATIENT NAME: "_$P(^DPT(DFN,0),U),$E(X,50)="GIMC Chart #: "_$$HRN^AUPNPAT(DFN,DUZ(2)) D S(X,2)
S X="DOB: "_$$DOB^AUPNPAT(DFN,"E"),$E(X,25)="AGE: "_$$AGE^AUPNPAT(DFN,AMHRDATE),$E(X,50)="GENDER: "_$$VAL^XBDIQ1(2,DFN,.02) D S(X,1)
S X="NOK: "_$$VAL^XBDIQ1(2,DFN,.211),$E(X,35)="RELATIONSHIP: "_$$VAL^XBDIQ1(9000001,DFN,2802)_" Phone #: "_$$VAL^XBDIQ1(2,DFN,.219) D S(X,1)
S X="ACCEPTING FACILITY: "_$E($P(^AMHRNRF(AMHREF,0),U,4),1,39),$E(X,60)="Phone: "_$P($G(^AMHRNRF(AMHREF,22)),U,30) D S(X,1)
S X="ACCEPTING PHYSICIAN: "_$P(^AMHRNRF(AMHREF,0),U,5) D S(X,1)
S X="CONTRACT CARE APPROVED BY: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.06),$E(X,60)="CATEGORY: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.08) D S(X,1)
S X="TRANSPORTAION TO FACILITY BY: "_$P(^AMHRNRF(AMHREF,0),U,7) D S(X,1)
S X="REFERRING PROVIDER: "_$$PPNAME^AMHUTIL(AMHRIEN) D S(X,1)
S X="CPT CODE: " D S(X,1)
S Y=0 F S Y=$O(^AMHRPROC("AD",AMHRIEN,Y)) Q:Y'=+Y S P=$P(^AMHRPROC(Y,0),U) S X=$P($$CPT^ICPTCOD(P,$P($P(^AMHREC(AMHRIEN,0),U),".")),U,2)_" "_$P($$CPT^ICPTCOD(P,$P($P(^AMHREC(AMHRIEN,0),U),".")),U,3) D S(X) ;CSV
POV ;
S X="PURPOSE OF VISIT CODES: " D S(X,1)
S (AMHX,C)=0 F S AMHX=$O(^AMHRPRO("AD",AMHRIEN,AMHX)) Q:AMHX'=+AMHX D
.S AMHTNRQ="",$E(AMHTNRQ,1)=$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U),$E(AMHTNRQ,16)=$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,2),AMHTICL=8,AMHTTXT="" D PRTTXT
.S AMHTNRQ=$$GET1^DIQ(9002011.01,AMHX,.04),AMHTICL=23,AMHTTXT="" D
..I AMHTNRQ=$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,2) Q
..D PRTTXT
.S C=C+2
.Q
;F I=C:1:3 S X="" D S(X)
S X="* * * * * * * * * * * * *" D S(X,1)
S X="REASON FOR REFERRAL: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.09) D S(X,1)
T ;
S X="HISTORY OF PRESENT PROBLEM:" D S(X,1)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,81,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,81,AMHX,0) D S(X)
.Q
CM ;
S X="CURRENT MEDICATIONS:" D S(X,1)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,82,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,82,AMHX,0) D S(X)
.Q
S X="PATIENT'S/FAMILY'S PSYCHIATRIC HISTORY:" D S(X,1)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,83,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,83,AMHX,0) D S(X)
.Q
S X="PATIENT HAS BEEN MEDICALLY CLEARED: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.11) D S(X,1)
S X="CURRENT MEDICAL PROBLEMS:" D S(X,1)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,84,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,84,AMHX,0) D S(X)
.Q
MSE ;mental status exam
S X="MENTAL STATUS EXAM:" D S(X,1)
S X="",$E(X,3)="APPEARANCE: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2201) D S(X)
S X="",$E(X,3)="ATTITUDE TOWARDS EXAMINER:"
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,41,AMHX)) Q:AMHX'=+AMHX S Y=$P(^AMHRNRF(AMHREF,41,AMHX,0),U),X=X_" "_$$EXTSET^XBFUNC(9002011.1141,.01,Y)
D S(X)
S X="",$E(X,3)="EYE CONTACT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2203) D S(X)
S X="",$E(X,3)="ORIENTATION - TIME: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2204) D S(X)
S X="",$E(X,3)="ORIENTATION - PLACE: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2205) D S(X)
S X="",$E(X,3)="ORIENTATION - PERSON: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2206) D S(X)
S X="",$E(X,3)="ORIENTATION - SITUATION: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2207) D S(X)
S X="",$E(X,3)="CONCENTRATION: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2208) D S(X)
MA S X="",$E(X,3)="MOTOR ACTIVITY:"
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,42,AMHX)) Q:AMHX'=+AMHX S Y=$P(^AMHRNRF(AMHREF,42,AMHX,0),U),X=X_" "_$$EXTSET^XBFUNC(9002011.1142,.01,Y)
D S(X)
S X="",$E(X,3)="SPEECH:"
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,43,AMHX)) Q:AMHX'=+AMHX S Y=$P(^AMHRNRF(AMHREF,43,AMHX,0),U),X=X_" "_$$EXTSET^XBFUNC(9002011.1143,.01,Y)
D S(X)
S X="",$E(X,3)="AFFECT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2211) D S(X)
S X="",$E(X,3)="MOOD:"
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,44,AMHX)) Q:AMHX'=+AMHX S Y=$P(^AMHRNRF(AMHREF,44,AMHX,0),U),X=X_" "_$$EXTSET^XBFUNC(9002011.1144,.01,Y)
D S(X)
S X="",$E(X,3)="THOUGHT PROCESS: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2201) D S(X)
S X="",$E(X,3)="CONTENT:" S AMHC=0
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,45,AMHX)) Q:AMHX'=+AMHX!(AMHC>2) S X=X_" "_$P(^AMHTREFC($P(^AMHRNRF(AMHREF,45,AMHX,0),U,1),0),U) S AMHC=AMHC+1
D S(X)
S X="" I $O(^AMHRNRF(AMHREF,45,AMHX)) D
.S X="",$E(X,5)=" " F S AMHX=$O(^AMHRNRF(AMHREF,45,AMHX)) Q:AMHX'=+AMHX S X=X_" "_$P(^AMHTREFC($P(^AMHRNRF(AMHREF,45,AMHX,0),U,1),0),U)
.S X=" "_X D S(X)
S X="",$E(X,3)="PERCEPTION: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2201) D S(X)
S X="",$E(X,3)="MEMORY - RECENT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2214) D S(X)
S X="",$E(X,3)="MEMORY - REMOTE: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2215) D S(X)
S X="",$E(X,3)="JUDGMENT "_$$VAL^XBDIQ1(9002011.11,AMHREF,2216) D S(X)
S X="",$E(X,3)="INSIGHT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2217) D S(X)
S X="",$E(X,3)="IMPULSE CONTROL: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2218) D S(X)
F AMHF=2219:1:2226 S X="",$E(X,3)=$P(^DD(9002011.11,AMHF,0),U)_": "_$$VAL^XBDIQ1(9002011.11,AMHREF,AMHF) D S(X)
DS ;
S X="DIAGNOSTIC SUMMARY:" D S(X,1)
S X="AXIS I" D S(X,1)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,85,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,85,AMHX,0) D S(X,1)
S X="AXIS II" D S(X,1)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,86,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,86,AMHX,0) D S(X,1)
S X="AXIS III" D S(X,1)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,87,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,87,AMHX,0) D S(X,1)
A4 ;AXIS IV/V
I $O(^AMHREC(AMHRIEN,61,0))!($P(^AMHREC(AMHRIEN,0),U,14)]"") D
.S X="",$E(X,3)="AXIS IV: " S Y=0 F S Y=$O(^AMHREC(AMHRIEN,61,Y)) Q:Y'=+Y S I=$P(^AMHREC(AMHRIEN,61,Y,0),U) S $E(X,14)=$P(^AMHTAXIV(I,0),U)_" - "_$P(^AMHTAXIV(I,0),U,2) D S(X) S X=""
.S X="",$E(X,3)="AXIS V: "_$P(^AMHREC(AMHRIEN,0),U,14) D S(X)
.Q
S X="TREATMENT REQUESTS/RECOMMENDATIONS:" D S(X,2)
S AMHX=0 F S AMHX=$O(^AMHRNRF(AMHREF,88,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,2)=^AMHRNRF(AMHREF,88,AMHX,0) D S(X)
S X="REFERRING PROVIDER'S SIGNATURE: __________________________________________" D S(X,5)
S X=" DATE: ___________________________" D S(X,2)
Q
PRTTXT ; GENERALIZED TEXT PRINTER
S AMHTDLT=1,AMHTILN=80-AMHTICL-1
F AMHTQ=0:0 S:AMHTNRQ]""&(($L(AMHTNRQ)+$L(AMHTTXT)+2)<255) AMHTTXT=$S(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ,AMHTNRQ="" Q:AMHTTXT="" D PRTTXT2
K AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
Q
PRTTXT2 D GETFRAG S X="",$E(X,AMHTICL)=AMHTF D S(X) S AMHTICL=AMHTICL+AMHTDLT,AMHTILN=AMHTILN-AMHTDLT,AMHTDLT=0
Q
GETFRAG I $L(AMHTTXT)<AMHTILN S AMHTF=AMHTTXT,AMHTTXT="" Q
F AMHTC=AMHTILN:-1:1 Q:$E(AMHTTXT,AMHTC)=" "
S AMHTF=$E(AMHTTXT,1,AMHTC-1),AMHTTXT=$E(AMHTTXT,AMHTC+1,255)
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:'DFN W !!,$TR($J(" ",79)," ","*"),!,$E($P(^DPT(DFN,0),U),1,25),?27,"HRN: " D
;.S H=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
;.W H,?38,"DOB: ",$$FMTE^XLFDT($P(^DPT(DFN,0),U,3),"2D"),?52,"SSN: ",$P(^DPT(DFN,0),U,9),?67,$$FMTE^XLFDT($P($P(AMHR0,U),"."))
W:$D(IOF) @IOF W !! S AMHPAGE=AMHPAGE+1 W ?48,$$FMTE^XLFDT($P(AMHR0,U)),?72,"Page "_AMHPAGE,!
W $$CTR("PSYCHIATRIC HOSPITALIZATION REFERRAL FORM",80),!
W $$CTR("BEHAVIORAL HEALTH COUNSELING SERVICES",80),!
W $$CTR("Phone: (505) 722-1571",80),!
Q
AMHNAVRP ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
+2 ;
+3 ;
+4 DO PRINT1(AMHREF)
+5 QUIT
S(Y,F,C,T) ;set up array
+1 NEW %
+2 IF '$GET(F)
SET F=0
+3 IF '$GET(T)
SET T=0
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("AMHREF",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("AMHREF",$JOB,"DCS",0),U)=%
+2 SET ^TMP("AMHREF",$JOB,"DCS",%)=X
+3 QUIT
PRINT1(AMHREF) ;EP - CALLED FROM LAST VISIT DISPLAY
+1 NEW C,AMHX,H,AMHR0,AMHSTOP,AMHTC,AMHTDLT,AMHTDOO,AMHTF,AMHTICL,AMHTILN,AMHTNRQ,AMHTQ,AMHTTXT,F,AMHPAGE
+2 SET AMHPAGE=1
+3 ;set array up
DO EP2(AMHREF)
+4 SET AMHSTOP=0
SET AMHQUIT=0
W ;write out array
+1 NEW AMHX
+2 WRITE !!
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^TMP("AMHREF",$JOB,"DCS",AMHX))
IF AMHX'=+AMHX!(AMHSTOP)!(AMHQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-5)
DO FF
IF AMHQUIT
QUIT
+5 WRITE !,^TMP("AMHREF",$JOB,"DCS",AMHX)
+6 QUIT
End DoDot:1
+7 WRITE !
+8 KILL ^TMP("AMHREF",$JOB,"DCS")
+9 QUIT
EP2(AMHREF) ;EP ; up array in ^TMP
+1 ;
+2 KILL ^TMP("AMHREF",$JOB,"DCS")
+3 SET ^TMP("AMHREF",$JOB,"DCS",0)=0
+4 SET X="********** CONFIDENTIAL PATIENT INFORMATION **********"
DO S(X,0,1)
+5 SET X="PSYCHIATRIC HOSPITALIZATION"
DO S(X,1,1)
+6 SET X="REFERRAL FORM"
DO S(X,0,1)
+7 SET X="BEHAVIORAL HEALTH COUNSELING SERVICES"
DO S(X,0,1)
+8 SET X="Phone: (505) 722-1571"
DO S(X,0,1)
+9 ;
+10 SET DFN=$PIECE(^AMHRNRF(AMHREF,0),U,2)
+11 SET AMHRIEN=$PIECE(^AMHRNRF(AMHREF,0),U,3)
+12 SET AMHR22=$GET(^AMHRNRF(AMHREF,22))
+13 SET AMHR0=^AMHRNRF(AMHREF,0)
+14 SET AMHRDATE=$PIECE(^AMHRNRF(AMHREF,0),U)
+15 SET X="PATIENT NAME: "_$PIECE(^DPT(DFN,0),U)
SET $EXTRACT(X,50)="GIMC Chart #: "_$$HRN^AUPNPAT(DFN,DUZ(2))
DO S(X,2)
+16 SET X="DOB: "_$$DOB^AUPNPAT(DFN,"E")
SET $EXTRACT(X,25)="AGE: "_$$AGE^AUPNPAT(DFN,AMHRDATE)
SET $EXTRACT(X,50)="GENDER: "_$$VAL^XBDIQ1(2,DFN,.02)
DO S(X,1)
+17 SET X="NOK: "_$$VAL^XBDIQ1(2,DFN,.211)
SET $EXTRACT(X,35)="RELATIONSHIP: "_$$VAL^XBDIQ1(9000001,DFN,2802)_" Phone #: "_$$VAL^XBDIQ1(2,DFN,.219)
DO S(X,1)
+18 SET X="ACCEPTING FACILITY: "_$EXTRACT($PIECE(^AMHRNRF(AMHREF,0),U,4),1,39)
SET $EXTRACT(X,60)="Phone: "_$PIECE($GET(^AMHRNRF(AMHREF,22)),U,30)
DO S(X,1)
+19 SET X="ACCEPTING PHYSICIAN: "_$PIECE(^AMHRNRF(AMHREF,0),U,5)
DO S(X,1)
+20 SET X="CONTRACT CARE APPROVED BY: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.06)
SET $EXTRACT(X,60)="CATEGORY: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.08)
DO S(X,1)
+21 SET X="TRANSPORTAION TO FACILITY BY: "_$PIECE(^AMHRNRF(AMHREF,0),U,7)
DO S(X,1)
+22 SET X="REFERRING PROVIDER: "_$$PPNAME^AMHUTIL(AMHRIEN)
DO S(X,1)
+23 SET X="CPT CODE: "
DO S(X,1)
+24 ;CSV
SET Y=0
FOR
SET Y=$ORDER(^AMHRPROC("AD",AMHRIEN,Y))
IF Y'=+Y
QUIT
SET P=$PIECE(^AMHRPROC(Y,0),U)
SET X=$PIECE($$CPT^ICPTCOD(P,$PIECE($PIECE(^AMHREC(AMHRIEN,0),U),".")),U,2)_" "_$PIECE($$CPT^ICPTCOD(P,$PIECE($PIECE(^AMHREC(AMHRIEN,0),U),".")),U,3)
DO S(X)
POV ;
+1 SET X="PURPOSE OF VISIT CODES: "
DO S(X,1)
+2 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHRPRO("AD",AMHRIEN,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 SET AMHTNRQ=""
SET $EXTRACT(AMHTNRQ,1)=$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)
SET $EXTRACT(AMHTNRQ,16)=$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U,2)
SET AMHTICL=8
SET AMHTTXT=""
DO PRTTXT
+4 SET AMHTNRQ=$$GET1^DIQ(9002011.01,AMHX,.04)
SET AMHTICL=23
SET AMHTTXT=""
Begin DoDot:2
+5 IF AMHTNRQ=$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U,2)
QUIT
+6 DO PRTTXT
End DoDot:2
+7 SET C=C+2
+8 QUIT
End DoDot:1
+9 ;F I=C:1:3 S X="" D S(X)
+10 SET X="* * * * * * * * * * * * *"
DO S(X,1)
+11 SET X="REASON FOR REFERRAL: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.09)
DO S(X,1)
T ;
+1 SET X="HISTORY OF PRESENT PROBLEM:"
DO S(X,1)
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,81,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,81,AMHX,0)
DO S(X)
+4 QUIT
End DoDot:1
CM ;
+1 SET X="CURRENT MEDICATIONS:"
DO S(X,1)
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,82,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,82,AMHX,0)
DO S(X)
+4 QUIT
End DoDot:1
+5 SET X="PATIENT'S/FAMILY'S PSYCHIATRIC HISTORY:"
DO S(X,1)
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,83,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+7 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,83,AMHX,0)
DO S(X)
+8 QUIT
End DoDot:1
+9 SET X="PATIENT HAS BEEN MEDICALLY CLEARED: "_$$VAL^XBDIQ1(9002011.11,AMHREF,.11)
DO S(X,1)
+10 SET X="CURRENT MEDICAL PROBLEMS:"
DO S(X,1)
+11 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,84,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+12 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,84,AMHX,0)
DO S(X)
+13 QUIT
End DoDot:1
MSE ;mental status exam
+1 SET X="MENTAL STATUS EXAM:"
DO S(X,1)
+2 SET X=""
SET $EXTRACT(X,3)="APPEARANCE: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2201)
DO S(X)
+3 SET X=""
SET $EXTRACT(X,3)="ATTITUDE TOWARDS EXAMINER:"
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,41,AMHX))
IF AMHX'=+AMHX
QUIT
SET Y=$PIECE(^AMHRNRF(AMHREF,41,AMHX,0),U)
SET X=X_" "_$$EXTSET^XBFUNC(9002011.1141,.01,Y)
+5 DO S(X)
+6 SET X=""
SET $EXTRACT(X,3)="EYE CONTACT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2203)
DO S(X)
+7 SET X=""
SET $EXTRACT(X,3)="ORIENTATION - TIME: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2204)
DO S(X)
+8 SET X=""
SET $EXTRACT(X,3)="ORIENTATION - PLACE: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2205)
DO S(X)
+9 SET X=""
SET $EXTRACT(X,3)="ORIENTATION - PERSON: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2206)
DO S(X)
+10 SET X=""
SET $EXTRACT(X,3)="ORIENTATION - SITUATION: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2207)
DO S(X)
+11 SET X=""
SET $EXTRACT(X,3)="CONCENTRATION: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2208)
DO S(X)
MA SET X=""
SET $EXTRACT(X,3)="MOTOR ACTIVITY:"
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,42,AMHX))
IF AMHX'=+AMHX
QUIT
SET Y=$PIECE(^AMHRNRF(AMHREF,42,AMHX,0),U)
SET X=X_" "_$$EXTSET^XBFUNC(9002011.1142,.01,Y)
+2 DO S(X)
+3 SET X=""
SET $EXTRACT(X,3)="SPEECH:"
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,43,AMHX))
IF AMHX'=+AMHX
QUIT
SET Y=$PIECE(^AMHRNRF(AMHREF,43,AMHX,0),U)
SET X=X_" "_$$EXTSET^XBFUNC(9002011.1143,.01,Y)
+5 DO S(X)
+6 SET X=""
SET $EXTRACT(X,3)="AFFECT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2211)
DO S(X)
+7 SET X=""
SET $EXTRACT(X,3)="MOOD:"
+8 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,44,AMHX))
IF AMHX'=+AMHX
QUIT
SET Y=$PIECE(^AMHRNRF(AMHREF,44,AMHX,0),U)
SET X=X_" "_$$EXTSET^XBFUNC(9002011.1144,.01,Y)
+9 DO S(X)
+10 SET X=""
SET $EXTRACT(X,3)="THOUGHT PROCESS: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2201)
DO S(X)
+11 SET X=""
SET $EXTRACT(X,3)="CONTENT:"
SET AMHC=0
+12 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,45,AMHX))
IF AMHX'=+AMHX!(AMHC>2)
QUIT
SET X=X_" "_$PIECE(^AMHTREFC($PIECE(^AMHRNRF(AMHREF,45,AMHX,0),U,1),0),U)
SET AMHC=AMHC+1
+13 DO S(X)
+14 SET X=""
IF $ORDER(^AMHRNRF(AMHREF,45,AMHX))
Begin DoDot:1
+15 SET X=""
SET $EXTRACT(X,5)=" "
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,45,AMHX))
IF AMHX'=+AMHX
QUIT
SET X=X_" "_$PIECE(^AMHTREFC($PIECE(^AMHRNRF(AMHREF,45,AMHX,0),U,1),0),U)
+16 SET X=" "_X
DO S(X)
End DoDot:1
+17 SET X=""
SET $EXTRACT(X,3)="PERCEPTION: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2201)
DO S(X)
+18 SET X=""
SET $EXTRACT(X,3)="MEMORY - RECENT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2214)
DO S(X)
+19 SET X=""
SET $EXTRACT(X,3)="MEMORY - REMOTE: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2215)
DO S(X)
+20 SET X=""
SET $EXTRACT(X,3)="JUDGMENT "_$$VAL^XBDIQ1(9002011.11,AMHREF,2216)
DO S(X)
+21 SET X=""
SET $EXTRACT(X,3)="INSIGHT: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2217)
DO S(X)
+22 SET X=""
SET $EXTRACT(X,3)="IMPULSE CONTROL: "_$$VAL^XBDIQ1(9002011.11,AMHREF,2218)
DO S(X)
+23 FOR AMHF=2219:1:2226
SET X=""
SET $EXTRACT(X,3)=$PIECE(^DD(9002011.11,AMHF,0),U)_": "_$$VAL^XBDIQ1(9002011.11,AMHREF,AMHF)
DO S(X)
DS ;
+1 SET X="DIAGNOSTIC SUMMARY:"
DO S(X,1)
+2 SET X="AXIS I"
DO S(X,1)
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,85,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,85,AMHX,0)
DO S(X,1)
End DoDot:1
+5 SET X="AXIS II"
DO S(X,1)
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,86,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+7 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,86,AMHX,0)
DO S(X,1)
End DoDot:1
+8 SET X="AXIS III"
DO S(X,1)
+9 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,87,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+10 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,87,AMHX,0)
DO S(X,1)
End DoDot:1
A4 ;AXIS IV/V
+1 IF $ORDER(^AMHREC(AMHRIEN,61,0))!($PIECE(^AMHREC(AMHRIEN,0),U,14)]"")
Begin DoDot:1
+2 SET X=""
SET $EXTRACT(X,3)="AXIS IV: "
SET Y=0
FOR
SET Y=$ORDER(^AMHREC(AMHRIEN,61,Y))
IF Y'=+Y
QUIT
SET I=$PIECE(^AMHREC(AMHRIEN,61,Y,0),U)
SET $EXTRACT(X,14)=$PIECE(^AMHTAXIV(I,0),U)_" - "_$PIECE(^AMHTAXIV(I,0),U,2)
DO S(X)
SET X=""
+3 SET X=""
SET $EXTRACT(X,3)="AXIS V: "_$PIECE(^AMHREC(AMHRIEN,0),U,14)
DO S(X)
+4 QUIT
End DoDot:1
+5 SET X="TREATMENT REQUESTS/RECOMMENDATIONS:"
DO S(X,2)
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRNRF(AMHREF,88,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+7 SET X=""
SET $EXTRACT(X,2)=^AMHRNRF(AMHREF,88,AMHX,0)
DO S(X)
End DoDot:1
+8 SET X="REFERRING PROVIDER'S SIGNATURE: __________________________________________"
DO S(X,5)
+9 SET X=" DATE: ___________________________"
DO S(X,2)
+10 QUIT
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET AMHTDLT=1
SET AMHTILN=80-AMHTICL-1
+2 FOR AMHTQ=0:0
IF AMHTNRQ]""&(($LENGTH(AMHTNRQ)+$LENGTH(AMHTTXT)+2)<255)
SET AMHTTXT=$SELECT(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ
SET AMHTNRQ=""
IF AMHTTXT=""
QUIT
DO PRTTXT2
+3 KILL AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
+4 QUIT
PRTTXT2 DO GETFRAG
SET X=""
SET $EXTRACT(X,AMHTICL)=AMHTF
DO S(X)
SET AMHTICL=AMHTICL+AMHTDLT
SET AMHTILN=AMHTILN-AMHTDLT
SET AMHTDLT=0
+1 QUIT
GETFRAG IF $LENGTH(AMHTTXT)<AMHTILN
SET AMHTF=AMHTTXT
SET AMHTTXT=""
QUIT
+1 FOR AMHTC=AMHTILN:-1:1
IF $EXTRACT(AMHTTXT,AMHTC)=" "
QUIT
+2 SET AMHTF=$EXTRACT(AMHTTXT,1,AMHTC-1)
SET AMHTTXT=$EXTRACT(AMHTTXT,AMHTC+1,255)
+3 QUIT
+4 ;
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 ;I $E(IOST)'="C" Q:'DFN W !!,$TR($J(" ",79)," ","*"),!,$E($P(^DPT(DFN,0),U),1,25),?27,"HRN: " D
+3 ;.S H=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+4 ;.W H,?38,"DOB: ",$$FMTE^XLFDT($P(^DPT(DFN,0),U,3),"2D"),?52,"SSN: ",$P(^DPT(DFN,0),U,9),?67,$$FMTE^XLFDT($P($P(AMHR0,U),"."))
+5 IF $DATA(IOF)
WRITE @IOF
WRITE !!
SET AMHPAGE=AMHPAGE+1
WRITE ?48,$$FMTE^XLFDT($PIECE(AMHR0,U)),?72,"Page "_AMHPAGE,!
+6 WRITE $$CTR("PSYCHIATRIC HOSPITALIZATION REFERRAL FORM",80),!
+7 WRITE $$CTR("BEHAVIORAL HEALTH COUNSELING SERVICES",80),!
+8 WRITE $$CTR("Phone: (505) 722-1571",80),!
+9 QUIT
