AMHLEA1.m

AMHLEA1 ; IHS/CMI/LAB - ADD NEW CHR ACTIVITY RECORDS ;

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

 ;

 ;add new records

 ;get all items for a record, check record, file record

 ;if not complete record, issue warning and delete record

BEGIN ;add adm record

 D GETTYPE

 I AMHPTYPE="" D EXIT Q

 D GETDATE

 I AMHDATE="" D EXIT Q

 D CREATE

 D EXIT

 Q

GETTYPE ;EP

 S AMHPTYPE=""

 S DIR(0)="S^M:MENTAL HEALTH DEFAULTS;S:SOCIAL SERVICES DEFAULTS;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER",DIR("A")="Which set of defaults do you want to use in Data Entry" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 S AMHPTYPE=Y

 Q

GETDATE ;EP - GET DATE OF ENCOUNTER

 W !!

 S AMHDATE="",DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter ENCOUNTER DATE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 S AMHDATE=Y

 Q

CREATE ;EP

 S AMHACTN=1

 S APCDOVRR=""

 K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHREC(",DLAYGO=9002011,DIADD=1,X=AMHDATE D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0

 I Y=-1 W !!,$C(7),$C(7),"Behavioral Health Record is NOT complete!!  Deleting Record.",! D PAUSE Q

 S AMHR=+Y,DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR

 D GETPROV

 S DA=AMHR,DIE="^AMHREC(",DR="[AMH ADD ADM RECORD]" D CALLDIE^AMHLEIN

 I $D(Y)!('$D(^AMHRPROV("AD",AMHR))) W !!,"Incomplete record!! Deleting record!!" D DEL G EXIT

 D GETPOV

 I '$D(^AMHRPRO("AD",AMHR))!('$D(^AMHRPROV("AD",AMHR))) W !!,"Incomplete record!! Deleting record!!" D DEL G EXIT

 S AMHOKAY=0 D RECCHECK^AMHLE2 I AMHOKAY W !,"Incomplete record!! Deleting record!!"  D DEL G EXIT

 W ! S DIE="^AMHREC(",DR="8101",DA=AMHR D CALLDIE^AMHLEIN

 ;S X=$$ESIG^AMHESIG(AMHR)

 ;I X D ESIGGFI^AMHESIG

 D EXIT

 Q

EXIT ;

 D ^XBFMK

 D EN^XBVK("AMH")

 Q

DEL ;EP

 I $$IINTAKE^AMHLEDEL(AMHR) W !!,"This visit has an Initial Intake with Updates, it can not be deleted",!,"until the update documents have been deleted." D PAUSE Q

 S AMHVDLT=$P(^AMHREC(AMHR,0),U,16)

 S AMHRDEL=AMHR

 D EN^AMHLEDEL

 W !,"Record deleted." D PAUSE

 Q

PAUSE ;EP

 S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q

GETPROV ;get providers

 K DIR,DIC,DA,DTOUT,DIRUT,DUOUT,DIC,X,Y S DIR("B")=$P(^VA(200,DUZ,0),U),DIR(0)="9002011.02,.01O",DIR("A")="Enter PRIMARY PROVIDER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 Q:Y=""

 S X=+Y,DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04///PRIMARY",DIC="^AMHRPROV(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.02 K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO

 I Y=-1 W !!,"Creating Primary Provider entry failed!!!",$C(7),$C(7) H 2

 Q

GETPOV ;

 D EN^XBNEW("EP^AMHLEA1","AMH*")

 Q

EP ;EP  -  ask for POV and file each

 I 'AMHR W !!,"NO RECORD DEFINED!!"  Q

 I '$D(^AMHREC(AMHR)) W !!,"NO RECORD!!"  Q

 S APCDOVRR=""

 D POV

 D CHK

 Q

CHK ;

 Q:$D(^AMHRPRO("AD",AMHR))

 W !!,$C(7),$C(7),"At least ONE POV is REQUIRED!!"

 S DIR(0)="Y",DIR("A")="Do you wish to exit and delete this record",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $G(Y)=0 G EP

 Q

POV ;

 S DIC("A")=$S($G(AMHGROUP):"Enter another Problem (POV): ",'$D(^AMHRPRO("AD",AMHR)):"Enter PRIMARY Problem-POV: ",1:"Enter ANOTHER Problem-POV: "),DIC("S")="I '$P(^(0),U,13)",DIC="^AMHPROB(",DIC(0)="AEMQ",DIC("B")=99

 W ! D ^DIC

 I Y=-1 D ^XBFMK Q

 S AMHPOV=$P(Y,U,2),AMHPOVP=+Y

 ;call FILE^DICN to file this POV

FILE ;

 D ^XBFMK

 K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHRPRO(",DLAYGO=9002011.01,DIADD=1,X=AMHPOVP,DIC("DR")="" D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0

 I Y=-1 D ^XBFMK W !!,$C(7),$C(7),"Behavioral Health POV failed!!  Notify Site Manager." Q

 S AMHRPRO=+Y,AMHPOVR=^AMHRPRO(AMHRPRO,0)

 D ^XBFMK

 S DIE("NO^")="",DA=AMHRPRO,DIE="^AMHRPRO(",DR=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04  Provider Narrative.....:" S DIE("NO^")="" D CALLDIE^AMHLEIN

 S AMHPOVR=^AMHRPRO(AMHRPRO,0)

 I $P(AMHPOVR,U,4)="" S X=$E($P(^AMHPROB($P(AMHPOVR,U),0),U,2),1,79),X=$TR(X,";"," "),DIE="^AMHRPRO(",DR=".04///"_X,DA=AMHRPRO S DIE("NO^")="" D CALLDIE^AMHLEIN

 I $D(Y) D ^XBFMK W !!,$C(7),$C(7),"DIE failed when updating POV" D PAUSE^AMHLEA Q

 Q

AMHLEA1   ; IHS/CMI/LAB - ADD NEW CHR ACTIVITY RECORDS ;

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

 +2       ;

 +3       ;add new records

 +4       ;get all items for a record, check record, file record

 +5       ;if not complete record, issue warning and delete record

BEGIN     ;add adm record

 +1        DO GETTYPE

 +2        IF AMHPTYPE=""

               DO EXIT

               QUIT 

 +3        DO GETDATE

 +4        IF AMHDATE=""

               DO EXIT

               QUIT 

 +5        DO CREATE

 +6        DO EXIT

 +7        QUIT 

GETTYPE   ;EP

 +1        SET AMHPTYPE=""

 +2        SET DIR(0)="S^M:MENTAL HEALTH DEFAULTS;S:SOCIAL SERVICES DEFAULTS;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER"

           SET DIR("A")="Which set of defaults do you want to use in Data Entry"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        SET AMHPTYPE=Y

 +5        QUIT 

GETDATE   ;EP - GET DATE OF ENCOUNTER

 +1        WRITE !!

 +2        SET AMHDATE=""

           SET DIR(0)="DO^:"_DT_":EPTX"

           SET DIR("A")="Enter ENCOUNTER DATE"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        SET AMHDATE=Y

 +5        QUIT 

CREATE    ;EP

 +1        SET AMHACTN=1

 +2        SET APCDOVRR=""

 +3        KILL DD,D0,DO,DINUM,DIC,DA,DR

           SET DIC(0)="EL"

           SET DIC="^AMHREC("

           SET DLAYGO=9002011

           SET DIADD=1

           SET X=AMHDATE

           DO FILE^DICN

           KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0

 +4        IF Y=-1

               WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health Record is NOT complete!!  Deleting Record.",!

               DO PAUSE

               QUIT 

 +5        SET AMHR=+Y

           SET DIE="^AMHREC("

           SET DA=AMHR

           SET DR="5100///NOW"

           SET DR(2,9002011.5101)=".02////^S X=DUZ"

           DO ^DIE

           KILL DIE,DA,DR

 +6        DO GETPROV

 +7        SET DA=AMHR

           SET DIE="^AMHREC("

           SET DR="[AMH ADD ADM RECORD]"

           DO CALLDIE^AMHLEIN

 +8        IF $DATA(Y)!('$DATA(^AMHRPROV("AD",AMHR)))

               WRITE !!,"Incomplete record!! Deleting record!!"

               DO DEL

               GOTO EXIT

 +9        DO GETPOV

 +10       IF '$DATA(^AMHRPRO("AD",AMHR))!('$DATA(^AMHRPROV("AD",AMHR)))

               WRITE !!,"Incomplete record!! Deleting record!!"

               DO DEL

               GOTO EXIT

 +11       SET AMHOKAY=0

           DO RECCHECK^AMHLE2

           IF AMHOKAY

               WRITE !,"Incomplete record!! Deleting record!!"

               DO DEL

               GOTO EXIT

 +12       WRITE !

           SET DIE="^AMHREC("

           SET DR="8101"

           SET DA=AMHR

           DO CALLDIE^AMHLEIN

 +13      ;S X=$$ESIG^AMHESIG(AMHR)

 +14      ;I X D ESIGGFI^AMHESIG

 +15       DO EXIT

 +16       QUIT 

EXIT      ;

 +1        DO ^XBFMK

 +2        DO EN^XBVK("AMH")

 +3        QUIT 

DEL       ;EP

 +1        IF $$IINTAKE^AMHLEDEL(AMHR)

               WRITE !!,"This visit has an Initial Intake with Updates, it can not be deleted",!,"until the update documents have been deleted."

               DO PAUSE

               QUIT 

 +2        SET AMHVDLT=$PIECE(^AMHREC(AMHR,0),U,16)

 +3        SET AMHRDEL=AMHR

 +4        DO EN^AMHLEDEL

 +5        WRITE !,"Record deleted."

           DO PAUSE

 +6        QUIT 

PAUSE     ;EP

 +1        SET DIR(0)="EO"

           SET DIR("A")="Press enter to continue...."

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        QUIT 

GETPROV   ;get providers

 +1        KILL DIR,DIC,DA,DTOUT,DIRUT,DUOUT,DIC,X,Y

           SET DIR("B")=$PIECE(^VA(200,DUZ,0),U)

           SET DIR(0)="9002011.02,.01O"

           SET DIR("A")="Enter PRIMARY PROVIDER"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               QUIT 

 +3        IF Y=""

               QUIT 

 +4        SET X=+Y

           SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04///PRIMARY"

           SET DIC="^AMHRPROV("

           SET DIC(0)="MLQ"

           SET DIADD=1

           SET DLAYGO=9002011.02

           KILL DD,DO

           DO FILE^DICN

           KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO

 +5        IF Y=-1

               WRITE !!,"Creating Primary Provider entry failed!!!",$CHAR(7),$CHAR(7)

               HANG 2

 +6        QUIT 

GETPOV    ;

 +1        DO EN^XBNEW("EP^AMHLEA1","AMH*")

 +2        QUIT 

EP        ;EP  -  ask for POV and file each

 +1        IF 'AMHR

               WRITE !!,"NO RECORD DEFINED!!"

               QUIT 

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

               WRITE !!,"NO RECORD!!"

               QUIT 

 +3        SET APCDOVRR=""

 +4        DO POV

 +5        DO CHK

 +6        QUIT 

CHK       ;

 +1        IF $DATA(^AMHRPRO("AD",AMHR))

               QUIT 

 +2        WRITE !!,$CHAR(7),$CHAR(7),"At least ONE POV is REQUIRED!!"

 +3        SET DIR(0)="Y"

           SET DIR("A")="Do you wish to exit and delete this record"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $GET(Y)=0

               GOTO EP

 +5        QUIT 

POV       ;

 +1        SET DIC("A")=$SELECT($GET(AMHGROUP):"Enter another Problem (POV): ",'$DATA(^AMHRPRO("AD",AMHR)):"Enter PRIMARY Problem-POV: ",1:"Enter ANOTHER Problem-POV: ")

           SET DIC("S")="I '$P(^(0),U,13)"

           SET DIC="^AMHPROB("

           SET DIC(0)="AEMQ"

           SET DIC("B")=99

 +2        WRITE !

           DO ^DIC

 +3        IF Y=-1

               DO ^XBFMK

               QUIT 

 +4        SET AMHPOV=$PIECE(Y,U,2)

           SET AMHPOVP=+Y

 +5       ;call FILE^DICN to file this POV

FILE      ;

 +1        DO ^XBFMK

 +2        KILL DD,D0,DO,DINUM,DIC,DA,DR

           SET DIC(0)="EL"

           SET DIC="^AMHRPRO("

           SET DLAYGO=9002011.01

           SET DIADD=1

           SET X=AMHPOVP

           SET DIC("DR")=""

           DO FILE^DICN

           KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0

 +3        IF Y=-1

               DO ^XBFMK

               WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health POV failed!!  Notify Site Manager."

               QUIT 

 +4        SET AMHRPRO=+Y

           SET AMHPOVR=^AMHRPRO(AMHRPRO,0)

 +5        DO ^XBFMK

 +6        SET DIE("NO^")=""

           SET DA=AMHRPRO

           SET DIE="^AMHRPRO("

           SET DR=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04  Provider Narrative.....:"

           SET DIE("NO^")=""

           DO CALLDIE^AMHLEIN

 +7        SET AMHPOVR=^AMHRPRO(AMHRPRO,0)

 +8        IF $PIECE(AMHPOVR,U,4)=""

               SET X=$EXTRACT($PIECE(^AMHPROB($PIECE(AMHPOVR,U),0),U,2),1,79)

               SET X=$TRANSLATE(X,";"," ")

               SET DIE="^AMHRPRO("

               SET DR=".04///"_X

               SET DA=AMHRPRO

               SET DIE("NO^")=""

               DO CALLDIE^AMHLEIN

 +9        IF $DATA(Y)

               DO ^XBFMK

               WRITE !!,$CHAR(7),$CHAR(7),"DIE failed when updating POV"

               DO PAUSE^AMHLEA

               QUIT 

 +10       QUIT