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")
Q
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
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
S AMHDELTV=1
Q
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
Q
;
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
Q
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
Q
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)
Q
;
XIT ;
K DIADD,DLAYGO
K AMHTX,AMHTY,AMHNARR,AMHLEPT,AMHNUM,AMHPOV,AMHPOVP,AMHPOVR,AMHRPRO,AMHDT,AMHLOOK
Q
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
