Routine: AMHLEI

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

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

 ;; ;

EP1(DFN,AMHREC) ;EP CALLED FROM PROTOCOL

 S AMHREC=$G(AMHREC)

 I AMHREC,'$D(^AMHREC(AMHREC,0)) S AMHREC=""

 Q:'$G(DFN)

 Q:'$D(^DPT(DFN))

 ;get intake document or create new one

 D GETINT

 D FULL^VALM1

 I '$G(AMHINT) W !!,"Error creating intake document." Q

 D EN

 ;D FULL^VALM1

 K VALMHDR

 K X,Y

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

 S VALMCC=1

 D EN^VALM("AMH INTAKE LIST/EDIT")

 D CLEAR^VALM1

GETINT ;

 S AMHINT=$O(^AMHPINTK("B",DFN,0))

 Q:AMHINT

 D ^XBFMK

 S (DINUM,X)=DFN,DIC(0)="L",DIC="^AMHPINTK(",DLAYGO=9002011.07,DIADD=1,DIC("DR")=".06////^S X=DT" K DD,DO D FILE^DICN K DLAYGO,DIADD,DINUM

 I Y=-1 W !!,"Adding new Intake Document failed!!!" H 4 D ^XBFMK Q

 S AMHINT=+Y

 D ^XBFMK

 S DA=AMHINT,DIE="^AMHPINTK("

 S DR=".07//"_$S(AMHREC:$$FMTE^XLFDT($P($P(^AMHREC(AMHREC,0),U),".")),1:$$FMTE^XLFDT(DT))_";.08//^S X=$P(^VA(200,DUZ,0),U)"

 S DR=DR_";.02//"_$S(AMHREC:$$FMTE^XLFDT($P($P(^AMHREC(AMHREC,0),U),".")),1:$$FMTE^XLFDT(DT))_";.03//^S X=$P(^VA(200,DUZ,0),U)"

 D ^DIE,^XBFMK

BACK ;EP - go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

D ;

W !

 D ^XBFMK S DA=AMHINT,DIE="^AMHPINTK(",DR=AMHX2 D ^DIE D ^XBFMK

RB ;EP

 D FULL^VALM1

 W !!!

 D ^XBFMK S DA=DFN,DIE="^AMHPINTK(",DR=1000 D ^DIE D ^XBFMK

 D BACK

ED ;EP

 D FULL^VALM1

 W !!!

 D ^XBFMK

 S DA=DFN,DIE="^AMHPINTK("

 S DR=".02//"_$S(AMHREC:$$FMTE^XLFDT($P($P(^AMHREC(AMHREC,0),U),".")),1:$$FMTE^XLFDT(DT))_";.03//^S X=$P(^VA(200,DUZ,0),U)"_";4100"

 D ^DIE K DIE,DR,DA,DIU,DIV,DIW

 D ^XBFMK

 D BACK

DP ;update designated provider

 S (AMHPAT,AMHPATH)=DFN D 1^AMHLEA S (DFN,AMHPAT)=AMHPATH K AMHPATH

 D BACK

GATHER ;EP - called from AMHUAR

 K ^TMP("AMHLEI1",$J)

 D DISP^AMHLEI2(DFN)

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)

INIT ;EP -- init variables and list array

 D GATHER ;gather up all records for display

 S VALMCNT=AMHCTR

HELP ;EP -- help code

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

DISP ;

 D EN^AMHLEI1(DFN)

 D BACK

EXIT ; -- exit code

 K AMHRCNT,AMHPTP,AMHE,AMHCTR,AMHLEL,AMHLETXT,AMHGNUM,AMHTPN,AMHCOL,AMHLEI,AMHINT

 K VALMCC,VALMHDR

EXPND ; -- expand code

DEL ;EP - called from protocol

 I '$D(^XUSEC("AMHZ DELETE RECORD",DUZ)) W !!,"You do not have the security access to delete a Intake Document.",!,"Please see your supervisor or program manager.",! D PAUSE^AMHLEA,BACK Q

 D FULL^VALM1

 ;are you sure??

 S DIR(0)="Y",DIR("A")="Are you sure you want to delete this INTAKE DOCUMENT",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I 'Y W !!,"Intake document not deleted." D PAUSE^AMHLEA,BACK Q

 W !!!

 D ^XBFMK S DA=DFN,DIK="^AMHPINTK(" D ^DIK D ^XBFMK

 W !!,"Intake document deleted." D PAUSE^AMHLEA

 D BACK

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

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

 +2       ;

 +3       ;

 +4       ;

 +5       ;; ;

EP1(DFN,AMHREC) ;EP CALLED FROM PROTOCOL

 +1        SET AMHREC=$GET(AMHREC)

 +2        IF AMHREC

               IF '$DATA(^AMHREC(AMHREC,0))

                   SET AMHREC=""

 +3        IF '$GET(DFN)

               QUIT

 +4        IF '$DATA(^DPT(DFN))

               QUIT

 +5       ;get intake document or create new one

 +6        DO GETINT

 +7        DO FULL^VALM1

 +8        IF '$GET(AMHINT)

               WRITE !!,"Error creating intake document."

               QUIT

 +9        DO EN

 +10      ;D FULL^VALM1

 +11       KILL VALMHDR

 +12       KILL X,Y

 +13       QUIT

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

 +1        SET VALMCC=1

 +2        DO EN^VALM("AMH INTAKE LIST/EDIT")

 +3        DO CLEAR^VALM1

 +4        QUIT

 +5       ;

GETINT    ;

 +1        SET AMHINT=$ORDER(^AMHPINTK("B",DFN,0))

 +2        IF AMHINT

               QUIT

 +3        DO ^XBFMK

 +4        SET (DINUM,X)=DFN

           SET DIC(0)="L"

           SET DIC="^AMHPINTK("

           SET DLAYGO=9002011.07

           SET DIADD=1

           SET DIC("DR")=".06////^S X=DT"

           KILL DD,DO

           DO FILE^DICN

           KILL DLAYGO,DIADD,DINUM

 +5        IF Y=-1

               WRITE !!,"Adding new Intake Document failed!!!"

               HANG 4

               DO ^XBFMK

               QUIT

 +6        SET AMHINT=+Y

 +7        DO ^XBFMK

 +8        SET DA=AMHINT

           SET DIE="^AMHPINTK("

 +9        SET DR=".07//"_$SELECT(AMHREC:$$FMTE^XLFDT($PIECE($PIECE(^AMHREC(AMHREC,0),U),".")),1:$$FMTE^XLFDT(DT))_";.08//^S X=$P(^VA(200,DUZ,0),U)"

 +10       SET DR=DR_";.02//"_$SELECT(AMHREC:$$FMTE^XLFDT($PIECE($PIECE(^AMHREC(AMHREC,0),U),".")),1:$$FMTE^XLFDT(DT))_";.03//^S X=$P(^VA(200,DUZ,0),U)"

 +11       DO ^DIE

           DO ^XBFMK

 +12       QUIT

BACK      ;EP - 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

D         ;

 +1        WRITE !

 +2        DO ^XBFMK

           SET DA=AMHINT

           SET DIE="^AMHPINTK("

           SET DR=AMHX2

           DO ^DIE

           DO ^XBFMK

 +3        QUIT

RB        ;EP

 +1        DO FULL^VALM1

 +2        WRITE !!!

 +3        DO ^XBFMK

           SET DA=DFN

           SET DIE="^AMHPINTK("

           SET DR=1000

           DO ^DIE

           DO ^XBFMK

 +4        DO BACK

 +5        QUIT

ED        ;EP

 +1        DO FULL^VALM1

 +2        WRITE !!!

 +3        DO ^XBFMK

 +4        SET DA=DFN

           SET DIE="^AMHPINTK("

 +5        SET DR=".02//"_$SELECT(AMHREC:$$FMTE^XLFDT($PIECE($PIECE(^AMHREC(AMHREC,0),U),".")),1:$$FMTE^XLFDT(DT))_";.03//^S X=$P(^VA(200,DUZ,0),U)"_";4100"

 +6        DO ^DIE

           KILL DIE,DR,DA,DIU,DIV,DIW

 +7        DO ^XBFMK

 +8        DO BACK

 +9        QUIT

DP        ;update designated provider

 +1        SET (AMHPAT,AMHPATH)=DFN

           DO 1^AMHLEA

           SET (DFN,AMHPAT)=AMHPATH

           KILL AMHPATH

 +2        DO BACK

 +3        QUIT

GATHER    ;EP - called from AMHUAR

 +1        KILL ^TMP("AMHLEI1",$JOB)

 +2        DO DISP^AMHLEI2(DFN)

 +3        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       ;

INIT      ;EP -- init variables and list array

 +1       ;gather up all records for display

           DO GATHER

 +2        SET VALMCNT=AMHCTR

 +3        QUIT

 +4       ;

HELP      ;EP -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT

 +3       ;

DISP      ;

 +1        DO EN^AMHLEI1(DFN)

 +2        DO BACK

 +3        QUIT

EXIT      ; -- exit code

 +1        KILL AMHRCNT,AMHPTP,AMHE,AMHCTR,AMHLEL,AMHLETXT,AMHGNUM,AMHTPN,AMHCOL,AMHLEI,AMHINT

 +2        KILL VALMCC,VALMHDR

 +3        QUIT

 +4       ;

EXPND     ; -- expand code

 +1        QUIT

 +2       ;

 +3       ;

DEL       ;EP - called from protocol

 +1        IF '$DATA(^XUSEC("AMHZ DELETE RECORD",DUZ))

               WRITE !!,"You do not have the security access to delete a Intake Document.",!,"Please see your supervisor or program manager.",!

               DO PAUSE^AMHLEA

               DO BACK

               QUIT

 +2        DO FULL^VALM1

 +3       ;are you sure??

 +4        SET DIR(0)="Y"

           SET DIR("A")="Are you sure you want to delete this INTAKE DOCUMENT"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +5        IF 'Y

               WRITE !!,"Intake document not deleted."

               DO PAUSE^AMHLEA

               DO BACK

               QUIT

 +6        WRITE !!!

 +7        DO ^XBFMK

           SET DA=DFN

           SET DIK="^AMHPINTK("

           DO ^DIK

           DO ^XBFMK

 +8        WRITE !!,"Intake document deleted."

           DO PAUSE^AMHLEA

 +9        DO BACK

 +10       QUIT

AMHLEI.m