Routine: AMHEGRPV

AMHEGRPV ; IHS/CMI/LAB - NEW PROGRAM ;

 ;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5**;JUN 02, 2010;Build 18

 ;GET POVS, ADD TO PROBLEM LIST, ADD TO PCC PROBLEM LIST

 ;CALLED IN RECORD ADD

EP2 ;EP

 S APCDOVRR=""

 S AMHDELTV=0

 D EN^XBNEW("EP^AMHEGRPV","AMHR;AMHPAT;AMHLOC;AMHDATE;APCDOVRR;AMHGROUP;AMHDELTV")

EP ;EP  -  ask for POV and file each

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

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

 S APCDOVRR=""

 S AMHDONE="" F  S AMHPOV="" D POV Q:AMHDONE=1

 D CHK

 D XIT

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

 S AMHDELTV=1

POV ;

 D HPOV1^AMHLESM

 S AMHDT=$P(AMHDATE,".")

 W !!?3,"Purpose of Visits currently recorded on this visit:"

 I '$D(^AMHRPRO("AD",AMHR)) S AMHC=0 W "  None recorded" G FM12

 ;D EN^DDIOL("P","","!?3"),EN^DDIOL("Start Date","","?43"),EN^DDIOL("End Date","","?63")

 D EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?3")

 K AMHCM S X=0,AMHC=0 F  S X=$O(^AMHRPRO("AD",AMHR,X)) Q:X'=+X  D

 .S AMHC=AMHC+1,AMHCM(AMHC)=X

 .W !?2,AMHC,")  ",$$VAL^XBDIQ1(9002011.01,X,.01),?16,$$VAL^XBDIQ1(9002011.01,X,.04)

FM12 ;

 D EN^DDIOL("","","!!")

 K DIR

 S DIR(0)="S^A:Add a POV"_$S(AMHC:";E:Edit an Existing POV;D:Delete an Existing POV",1:"")_";N:No Change"

 S DIR("A")="Which action",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G FM13

 I Y="N" S AMHDONE=1 G FM13

 S Y="FM"_Y

 D @Y

 G POV

FM13 ;

K Y

FME ;

 D EN^DDIOL("","","!")

 K DIR

 S DIR(0)="N^1:"_AMHC_":0",DIR("A")="Edit Which One" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 K DIC,DA,DR

 S DA=AMHCM(Y),DR=".01" ;.04"

 S DIE="^AMHRPRO("

 D ^DIE

 S X=$$VALI^XBDIQ1(9002011.01,DA,.01)  ;IEN OF CODE

 ;S X=$E(X,1,$S($P(^DD(9999999.27,.01,0),U,5)[">160":159,1:79))

 ;S X=$TR(X,";",",")

 S X=$E($P(^AMHPROB(X,0),U,2),1,159)

 S DR=".04///"_X

 D ^DIE

 S DR=".04"

 D ^DIE

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

FMD ;

 D EN^DDIOL("","","!")

 K DIR

 S DIR(0)="N^1:"_AMHC_":0",DIR("A")="Delete Which One" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 K DIC,DA,DR

 S DA=AMHCM(Y),DIK="^AMHRPRO(" D ^DIK K DA,DIK

FMA ;

 S DIC("A")="Problem (POV) for this patient: ",DIC("S")="D CHKICD^AMHUTIL1(Y,$G(AMHDATE),$G(AMHR),,)",DIC="^AMHPROB(",DIC(0)="AEMQ"

 W ! D ^DIC

 I Y=-1 D ^XBFMK Q

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

 ;call FILE^DICN to file this POV

 D ^XBFMK

 K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHRPRO(",DLAYGO=9002011.01,DIADD=1

 S Z=$$VAL^XBDIQ1(9002012.2,AMHPOVP,.02)

 S Z=$E(Z,1,$S($P(^DD(9999999.27,.01,0),U,5)[">160":159,1:79))

 S Z=$TR(Z,";",",")

 S X=AMHPOVP,DIC("DR")=".04///"_Z

 D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0

 I Y=-1 D ^XBFMK,XIT 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,159),X=$TR(X,";"," "),DIE="^AMHRPRO(",DR=".04///"_X,DA=AMHRPRO S DIE("NO^")="" D CALLDIE^AMHLEIN

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

 S AMHPOVR=^AMHRPRO(AMHRPRO,0)

 S AMHNARR=$$GET1^DIQ(9002011.01,AMHRPRO,.04)

XIT ;

 K DIADD,DLAYGO

 K AMHTX,AMHTY,AMHNARR,AMHLEPT,AMHNUM,AMHPOV,AMHPOVP,AMHPOVR,AMHRPRO,AMHDT,AMHLOOK

AMHEGRPV  ; IHS/CMI/LAB - NEW PROGRAM ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5**;JUN 02, 2010;Build 18

 +2       ;

 +3       ;

 +4       ;GET POVS, ADD TO PROBLEM LIST, ADD TO PCC PROBLEM LIST

 +5       ;CALLED IN RECORD ADD

EP2       ;EP

 +1        SET APCDOVRR=""

 +2        SET AMHDELTV=0

 +3        DO EN^XBNEW("EP^AMHEGRPV","AMHR;AMHPAT;AMHLOC;AMHDATE;APCDOVRR;AMHGROUP;AMHDELTV")

 +4        QUIT

EP        ;EP  -  ask for POV and file each

 +1        IF 'AMHR

               WRITE !!,"NO RECORD DEFINED!!"

               DO XIT

               QUIT

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

               WRITE !!,"NO RECORD!!"

               DO XIT

               QUIT

 +3        SET APCDOVRR=""

 +4        SET AMHDONE=""

FOR

               SET AMHPOV=""

               DO POV

               IF AMHDONE=1

                   QUIT

 +5        DO CHK

 +6        DO XIT

 +7        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        SET AMHDELTV=1

 +6        QUIT

POV       ;

 +1        DO HPOV1^AMHLESM

 +2        SET AMHDT=$PIECE(AMHDATE,".")

 +3        WRITE !!?3,"Purpose of Visits currently recorded on this visit:"

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

               SET AMHC=0

               WRITE "  None recorded"

               GOTO FM12

 +5       ;D EN^DDIOL("P","","!?3"),EN^DDIOL("Start Date","","?43"),EN^DDIOL("End Date","","?63")

 +6        DO EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?3")

 +7        KILL AMHCM

           SET X=0

           SET AMHC=0

FOR

               SET X=$ORDER(^AMHRPRO("AD",AMHR,X))

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +8                SET AMHC=AMHC+1

                   SET AMHCM(AMHC)=X

 +9                WRITE !?2,AMHC,")  ",$$VAL^XBDIQ1(9002011.01,X,.01),?16,$$VAL^XBDIQ1(9002011.01,X,.04)

               End DoDot:1

FM12      ;

 +1        DO EN^DDIOL("","","!!")

 +2        KILL DIR

 +3        SET DIR(0)="S^A:Add a POV"_$SELECT(AMHC:";E:Edit an Existing POV;D:Delete an Existing POV",1:"")_";N:No Change"

 +4        SET DIR("A")="Which action"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               GOTO FM13

 +6        IF Y="N"

               SET AMHDONE=1

               GOTO FM13

 +7        SET Y="FM"_Y

 +8        DO @Y

 +9        GOTO POV

FM13      ;

 +1        KILL Y

 +2        QUIT

 +3       ;

FME       ;

 +1        DO EN^DDIOL("","","!")

 +2        KILL DIR

 +3        SET DIR(0)="N^1:"_AMHC_":0"

           SET DIR("A")="Edit Which One"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               QUIT

 +5        KILL DIC,DA,DR

 +6       ;.04"

           SET DA=AMHCM(Y)

           SET DR=".01"

 +7        SET DIE="^AMHRPRO("

 +8        DO ^DIE

 +9       ;IEN OF CODE

           SET X=$$VALI^XBDIQ1(9002011.01,DA,.01)

 +10      ;S X=$E(X,1,$S($P(^DD(9999999.27,.01,0),U,5)[">160":159,1:79))

 +11      ;S X=$TR(X,";",",")

 +12       SET X=$EXTRACT($PIECE(^AMHPROB(X,0),U,2),1,159)

 +13      ;

 +14       SET DR=".04///"_X

 +15       DO ^DIE

 +16       SET DR=".04"

 +17       DO ^DIE

 +18       IF $PIECE(^AMHRPRO(DA,0),U,4)=""

               SET X=$EXTRACT($PIECE(^AMHPROB($PIECE(^AMHRPRO(DA,0),U),0),U,2),1,159)

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

               SET DIE="^AMHRPRO("

               SET DR=".04///"_X

               DO CALLDIE^AMHLEIN

 +19       QUIT

FMD       ;

 +1        DO EN^DDIOL("","","!")

 +2        KILL DIR

 +3        SET DIR(0)="N^1:"_AMHC_":0"

           SET DIR("A")="Delete Which One"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               QUIT

 +5        KILL DIC,DA,DR

 +6        SET DA=AMHCM(Y)

           SET DIK="^AMHRPRO("

           DO ^DIK

           KILL DA,DIK

 +7        QUIT

FMA       ;

 +1        SET DIC("A")="Problem (POV) for this patient: "

           SET DIC("S")="D CHKICD^AMHUTIL1(Y,$G(AMHDATE),$G(AMHR),,)"

           SET DIC="^AMHPROB("

           SET DIC(0)="AEMQ"

 +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

 +6       ;

 +7        DO ^XBFMK

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

           SET DIC(0)="EL"

           SET DIC="^AMHRPRO("

           SET DLAYGO=9002011.01

           SET DIADD=1

 +9        SET Z=$$VAL^XBDIQ1(9002012.2,AMHPOVP,.02)

 +10       SET Z=$EXTRACT(Z,1,$SELECT($PIECE(^DD(9999999.27,.01,0),U,5)[">160":159,1:79))

 +11       SET Z=$TRANSLATE(Z,";",",")

 +12       SET X=AMHPOVP

           SET DIC("DR")=".04///"_Z

 +13       DO FILE^DICN

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

 +14       IF Y=-1

               DO ^XBFMK

               DO XIT

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

               QUIT

 +15       SET AMHRPRO=+Y

           SET AMHPOVR=^AMHRPRO(AMHRPRO,0)

 +16       DO ^XBFMK

 +17       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

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

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

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

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

               SET DIE="^AMHRPRO("

               SET DR=".04///"_X

               SET DA=AMHRPRO

               SET DIE("NO^")=""

               DO CALLDIE^AMHLEIN

 +20       IF $DATA(Y)

               DO ^XBFMK

               DO XIT

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

               DO PAUSE^AMHLEA

               QUIT

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

 +22       SET AMHNARR=$$GET1^DIQ(9002011.01,AMHRPRO,.04)

 +23       QUIT

 +24      ;

XIT       ;

 +1        KILL DIADD,DLAYGO

 +2        KILL AMHTX,AMHTY,AMHNARR,AMHLEPT,AMHNUM,AMHPOV,AMHPOVP,AMHPOVR,AMHRPRO,AMHDT,AMHLOOK

 +3        QUIT

AMHEGRPV.m