AMHNAVRP.m

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)