AMHLESAN.m

AMHLESAN ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;

 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 ;

 ;

 ;

 ;; ;

EN ; EP -- main entry point for AMH UPDATE ACTIVITY RECORDS

 S VALMCC=1

 D EN^VALM("AMH SAN UPDATE")

 D CLEAR^VALM1

 Q

 ;

EP1(DFN,AMHR) ;EP CALLED FROM PROTOCOL

 Q:'$G(AMHR)

 Q:'$D(^AMHREC(AMHR))

 I $G(AMHVTYPE)="" S AMHVTYPE=$P(^AMHREC(AMHR,0),U,33)

 ;get intake document or create new one

 D EN

 D FULL^VALM1

 K VALMHDR

 K X,Y

 Q

BACK ;go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

 Q

SELECT ;

 W ! S DIR(0)="LO^1:"_$S(AMHVTYPE="S":21,1:8),DIR("A")="Which item(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !,"No items selected." G BACK

 I $D(DIRUT) W !,"No items selected." G BACK

 S AMHY=Y

 D FULL^VALM1 W:$D(IOF) @IOF

 S AMHC="" F AMHI=1:1 S AMHC=$P(AMHY,",",AMHI) Q:AMHC=""  D

 .I AMHVTYPE="S" S AMHX=$T(@AMHC)

 .I AMHVTYPE="U" S Y=AMHC+70 S AMHX=$T(@Y)

 .S AMHX1=$P(AMHX,";;",3),AMHX2=$P(AMHX,";;",4)

 .D @AMHX1 Q

 .Q

 D BACK

 Q

D ;

 W !

 D ^XBFMK S DA=AMHR,DIE="^AMHREC(",DR=AMHX2 D ^DIE D ^XBFMK

 Q

GATHER ;EP - called from AMHUAR

 K AMHQUIT,AMHLESAN S AMHRCNT=0,AMHLINE=0

 I AMHVTYPE="U" D GATHER1 Q

 F AMHE=1:1:21 D

 .S X=$T(@AMHE)

 .S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,AMHLESAN(AMHLINE,0)=$P(X,";;",1)_"   "_$P(X,";;",2),AMHLESAN("IDX",AMHRCNT,AMHLINE)=AMHLINE

 .Q

 Q

HDR ;EP -- header code

 S VALMHDR(1)="Patient Name:  "_$P(^DPT(DFN,0),U)_"     DOB:  "_$$FTIME^VALM1($P(^DPT(DFN,0),U,3))_"   Sex:  "_$P(^DPT(DFN,0),U,2)

 Q

 ;

GATHER1 ;

 F AMHE=71:1:78 D

 .S X=$T(@AMHE)

 .S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,AMHLESAN(AMHLINE,0)=$P(X,";;",1)-70_"   "_$P(X,";;",2),AMHLESAN("IDX",AMHRCNT,AMHLINE)=AMHLINE

 .Q

 Q

INIT ;EP -- init variables and list array

 D GATHER ;gather up all records for display

 S VALMCNT=AMHLINE

 Q

 ;

HELP ;EP -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

DISP ;

 D EN^AMHLESA1(AMHR)

 D BACK

 Q

EXIT ; -- exit code

 K AMHRCNT,AMHPTP,AMHE,AMHLINE,AMHLEL,AMHLETXT,AMHGNUM,AMHTPN,AMHCOL

 K VALMCC,VALMHDR

 Q

 ;

EXPND ; -- expand code

 Q

1 ;;Parents;;D;;7701

2 ;;Guardians;;D;;7702

3 ;;Lives With;;D;;7703

4 ;;Spouse/Partner Info;;D;;7704

5 ;;Person Referring Info;;D;;7706

6 ;;Relation To Victim;;D;;7707

7 ;;Suspected Perpetrator Info;;D;;7901

8 ;;History;;D;;7709

9 ;;Prior Incidents Noted;;D;;7717

10 ;;Assessment:  Problems Identified;;D;;7711

11 ;;Assessment:  Strengths Identified;;D;;7712

12 ;;Risk for Recurrence;;D;;7713

13 ;;Services Provided/Treatment Plan;;D;;7715

14 ;;Examining Physician;;D;;7902

15 ;;Date of Examination;;D;;7719

16 ;;Police Contacted: Y/N;;D;;7721

17 ;;Date/Time Complaint Filed;;D;;7722

18 ;;Complaint #;;D;;7903

19 ;;Officer Name and Agency;;D;;7904

20 ;;Referral(s) Made to;;D;;7905

21 ;;Other Comments;;D;;7724

 ;

 ;

71 ;;Reasons for Review;;D;;7801

72 ;;Outcome;;D;;7802

73 ;;Outcome Reasons;;D;;7803

74 ;;Assessment: Problems Identified;;D;;7804

75 ;;Assessment: Strengths Identified;;D;;7805

76 ;;Risk;;D;;7806

77 ;;Services Provided up to time of review;;D;;7808

78 ;;Recommendations/Comments;;D;;7809

AMHLESAN  ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 +2       ;

 +3       ;

 +4       ;

 +5       ;; ;

EN        ; EP -- main entry point for AMH UPDATE ACTIVITY RECORDS

 +1        SET VALMCC=1

 +2        DO EN^VALM("AMH SAN UPDATE")

 +3        DO CLEAR^VALM1

 +4        QUIT 

 +5       ;

EP1(DFN,AMHR) ;EP CALLED FROM PROTOCOL

 +1        IF '$GET(AMHR)

               QUIT 

 +2        IF '$DATA(^AMHREC(AMHR))

               QUIT 

 +3        IF $GET(AMHVTYPE)=""

               SET AMHVTYPE=$PIECE(^AMHREC(AMHR,0),U,33)

 +4       ;get intake document or create new one

 +5        DO EN

 +6        DO FULL^VALM1

 +7        KILL VALMHDR

 +8        KILL X,Y

 +9        QUIT 

BACK      ;go back to listman

 +1        DO TERM^VALM0

 +2        SET VALMBCK="R"

 +3        DO INIT

 +4        DO HDR

 +5        KILL DIR

 +6        KILL X,Y,Z,I

 +7        QUIT 

SELECT    ;

 +1        WRITE !

           SET DIR(0)="LO^1:"_$SELECT(AMHVTYPE="S":21,1:8)

           SET DIR("A")="Which item(s)"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF Y=""

               WRITE !,"No items selected."

               GOTO BACK

 +3        IF $DATA(DIRUT)

               WRITE !,"No items selected."

               GOTO BACK

 +4        SET AMHY=Y

 +5        DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

 +6        SET AMHC=""

           FOR AMHI=1:1

               SET AMHC=$PIECE(AMHY,",",AMHI)

               IF AMHC=""

                   QUIT 

               Begin DoDot:1

 +7                IF AMHVTYPE="S"

                       SET AMHX=$TEXT(@AMHC)

 +8                IF AMHVTYPE="U"

                       SET Y=AMHC+70

                       SET AMHX=$TEXT(@Y)

 +9                SET AMHX1=$PIECE(AMHX,";;",3)

                   SET AMHX2=$PIECE(AMHX,";;",4)

 +10               DO @AMHX1

                   QUIT 

 +11               QUIT 

               End DoDot:1

 +12       DO BACK

 +13       QUIT 

D         ;

 +1        WRITE !

 +2        DO ^XBFMK

           SET DA=AMHR

           SET DIE="^AMHREC("

           SET DR=AMHX2

           DO ^DIE

           DO ^XBFMK

 +3        QUIT 

GATHER    ;EP - called from AMHUAR

 +1        KILL AMHQUIT,AMHLESAN

           SET AMHRCNT=0

           SET AMHLINE=0

 +2        IF AMHVTYPE="U"

               DO GATHER1

               QUIT 

 +3        FOR AMHE=1:1:21

               Begin DoDot:1

 +4                SET X=$TEXT(@AMHE)

 +5                SET AMHRCNT=AMHRCNT+1

                   SET AMHLINE=AMHLINE+1

                   SET AMHLESAN(AMHLINE,0)=$PIECE(X,";;",1)_"   "_$PIECE(X,";;",2)

                   SET AMHLESAN("IDX",AMHRCNT,AMHLINE)=AMHLINE

 +6                QUIT 

               End DoDot:1

 +7        QUIT 

HDR       ;EP -- header code

 +1        SET VALMHDR(1)="Patient Name:  "_$PIECE(^DPT(DFN,0),U)_"     DOB:  "_$$FTIME^VALM1($PIECE(^DPT(DFN,0),U,3))_"   Sex:  "_$PIECE(^DPT(DFN,0),U,2)

 +2        QUIT 

 +3       ;

GATHER1   ;

 +1        FOR AMHE=71:1:78

               Begin DoDot:1

 +2                SET X=$TEXT(@AMHE)

 +3                SET AMHRCNT=AMHRCNT+1

                   SET AMHLINE=AMHLINE+1

                   SET AMHLESAN(AMHLINE,0)=$PIECE(X,";;",1)-70_"   "_$PIECE(X,";;",2)

                   SET AMHLESAN("IDX",AMHRCNT,AMHLINE)=AMHLINE

 +4                QUIT 

               End DoDot:1

 +5        QUIT 

INIT      ;EP -- init variables and list array

 +1       ;gather up all records for display

           DO GATHER

 +2        SET VALMCNT=AMHLINE

 +3        QUIT 

 +4       ;

HELP      ;EP -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

DISP      ;

 +1        DO EN^AMHLESA1(AMHR)

 +2        DO BACK

 +3        QUIT 

EXIT      ; -- exit code

 +1        KILL AMHRCNT,AMHPTP,AMHE,AMHLINE,AMHLEL,AMHLETXT,AMHGNUM,AMHTPN,AMHCOL

 +2        KILL VALMCC,VALMHDR

 +3        QUIT 

 +4       ;

EXPND     ; -- expand code

 +1        QUIT 

1         ;;Parents;;D;;7701

2         ;;Guardians;;D;;7702

3         ;;Lives With;;D;;7703

4         ;;Spouse/Partner Info;;D;;7704

5         ;;Person Referring Info;;D;;7706

6         ;;Relation To Victim;;D;;7707

7         ;;Suspected Perpetrator Info;;D;;7901

8         ;;History;;D;;7709

9         ;;Prior Incidents Noted;;D;;7717

10        ;;Assessment:  Problems Identified;;D;;7711

11        ;;Assessment:  Strengths Identified;;D;;7712

12        ;;Risk for Recurrence;;D;;7713

13        ;;Services Provided/Treatment Plan;;D;;7715

14        ;;Examining Physician;;D;;7902

15        ;;Date of Examination;;D;;7719

16        ;;Police Contacted: Y/N;;D;;7721

17        ;;Date/Time Complaint Filed;;D;;7722

18        ;;Complaint #;;D;;7903

19        ;;Officer Name and Agency;;D;;7904

20        ;;Referral(s) Made to;;D;;7905

21        ;;Other Comments;;D;;7724

 +1       ;

 +2       ;

71        ;;Reasons for Review;;D;;7801

72        ;;Outcome;;D;;7802

73        ;;Outcome Reasons;;D;;7803

74        ;;Assessment: Problems Identified;;D;;7804

75        ;;Assessment: Strengths Identified;;D;;7805

76        ;;Risk;;D;;7806

77        ;;Services Provided up to time of review;;D;;7808

78        ;;Recommendations/Comments;;D;;7809