AMHLE2 ; IHS/CMI/LAB - DE CONT. ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,4**;JUN 18, 2010;Build 28
;
;
RECCHECK ;EP - check record for completeness
I '$D(^AMHREC(AMHR,0)) Q
S AMHREC=$G(^AMHREC(AMHR,0))
S (AMHERROR,AMHOKAY)=0
I $P(AMHREC,U,4)="" W !,"Location of Encounter Missing!" S (AMHOKAY,AMHERROR)=1
I $P(AMHREC,U,5)="" W !,"Community of Service Missing!" S (AMHOKAY,AMHERROR)=1
I $P(AMHREC,U,6)="" W !,"Activity Type Missing!" S (AMHOKAY,AMHERROR)=1
I $P(AMHREC,U,7)="" W !,"Type of Contact Missing!" S (AMHOKAY,AMHERROR)=1
S (X,Y)=0 F S X=$O(^AMHRPROV("AD",AMHR,X)) Q:X'=+X I $P(^AMHRPROV(X,0),U,4)="P" S Y=Y+1
I Y=0 W !,"No primary Provider!" S (AMHOKAY,AMHERROR)=1 ;,$C(7),$C(7) S AMHERROR=1 H 2
I Y>1 W !,"Multiple Primary Providers!" S (AMHOKAY,AMHERROR)=1 ;,$C(7),$C(7) W:'$G(AMHERROR) " PLEASE EDIT THIS RECORD" H 2
I '$D(^AMHRPRO("AD",AMHR)) W !,"No POV entered!!" S (AMHOKAY,AMHERROR)=1 ;,$C(7) W:'$G(AMHERROR) " PLEASE EDIT THIS RECORD" H 2 Q
;IF PAT ACTIVITY AND PATIENT MISSING - ERROR
I $P(AMHREC,U,12)="" W !,"Activity Time Missing!" S (AMHOKAY,AMHERROR)=1 ;W $C(7) S AMHERROR=1 H 2
I $G(AMHERROR) W !!,"Please EDIT this record." D PAUSE^AMHLEA
I AMHACTN=2&($P(^AMHREC(AMHR,0),U,8)="") D DELPT
Q
DELPT ;delete .02 field of all record entries if not patient related
S AMHVFLE=9002011 F AMHVL=0:0 S AMHVFLE=$O(^DIC(AMHVFLE)) Q:AMHVFLE>9002011.49 D
.S AMHVDG=^DIC(AMHVFLE,0,"GL"),AMHVIGR=AMHVDG_"""AD"",AMHR,AMHVDFN)"
.S AMHVDFN="" F AMHVI=1:1 S AMHVDFN=$O(@AMHVIGR) Q:AMHVDFN="" S AMHVIGL=AMHVDG_AMHVDFN_",0)" W:'$D(ZTQUEUED) "." I $P((@AMHVIGL),U,2)]"" S DA=AMHVDFN,DITC="",DR=".02///@",DIE=AMHVDG D CALLDIE^AMHLEIN
Q
EP1(AMHPAT) ;EP called from protocol
D FULL^VALM1
W:$D(IOF) @IOF
S AMHDATE=DT
S AMHLOC=DUZ(2)
;D EN^XBNEW("MHPL^AMHLE2","AMH*")
D MHPL^AMHLE2
Q
EP ;EP = CALLED FROM SCREENMAN
W:$D(IOF) @IOF
D EN^XBNEW("MHPL^AMHLE2","AMH*")
Q
MHPL ;EP - update mh/ss problem list
S APCDOVRR=""
K AMHX,AMHJ,AMHTEXT
I $G(AMHLOC)="" S AMHLOC=DUZ(2)
W !!,"Behavioral Health Patient Diagnosis List Update Menu",!
F AMHJ=1:1:11 S AMHX=$P($T(PROBMENU+AMHJ),";;",2) W !?11,AMHJ,") ",AMHX
K AMHX,AMHJ,AMHTEXT
S DIR(0)="N^1:11:0",DIR("A")="Choose One",DIR("B")="11" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=11
S AMHPLC=Y
I '$G(AMHAUTH),$G(AMHR) S AMHAUTH=$$PPNAME^AMHUTIL(AMHR)
I '$G(AMHAUTH) S AMHAUTH=$P(^VA(200,DUZ,0),U)
I AMHPLC=10 S DFN=AMHPAT D EN1^AMHPL Q
S DIE="^AUPNPAT(",DR="["_$P($T(PROBMENU+AMHPLC),";;",3)_"]",DA=AMHPAT,DIE("NO^")="" D CALLDIE^AMHLEIN K DR,DA,DIE
I $D(Y) W !!,"Error encountered in updating BH Diagnosis List for ",$P(^DPT(AMHPAT,0),U)
K Y,X,DIU,DIV
G MHPL
PCCLINK ;EP - PCCLINK
K X
I AMHACTN=4 G PCCLINK2
I '$D(^AMHREC(AMHR,0)) G PCCLINK2
I $G(AMHVDLT) G PCCLINK2
Q:'$P(^AMHREC(AMHR,0),U,8) ;no pcc if not a patient encounter
S X=$$ESIG^AMHESIG(AMHR)
I '$P(X,U,2),AMHLPCC W !!,"No PCC Link...Note not signed." D PAUSE^AMHLEA Q
PCCLINK1 ;
I 'AMHLPCC Q:'$$PRVLINK($$PPINT^AMHUTIL(AMHR)) ;quit if no pcc link
PCCLINK2 ;
I $G(AMHVDLT)="",AMHACTN=4 Q
I $G(AMHVDLT),AMHACTN=4 D TASK Q
D VISIT
I 'AMHVISIT,$P(^AMHREC(AMHR,0),U,16)]"" D Q
.S APCDVDLT=$P(^AMHREC(AMHR,0),U,16) D ^APCDVDLT
.S DIE="^AMHREC(",DA=AMHR,DR=".16///@" D CALLDIE^AMHLEIN
Q:AMHVISIT
Q
PRVLINK(P) ;EP
I '$G(P) Q 0
I '$D(^AMHSITE(DUZ(2),11,"B",P)) Q 0
NEW A
S A=$O(^AMHSITE(DUZ(2),11,"B",P,0))
I 'A Q 0
I $P(^AMHSITE(DUZ(2),11,A,0),U,1)=1 Q 0
Q 1
;
VISIT ;
K AMHDNKA
S AMHVISIT=0
Q:'$G(AMHR)
Q:'$P(^AMHREC(AMHR,0),U,8) ;no pcc if not a patient encounter
;do not pass residential type of visits to pcc
I $$VAL^XBDIQ1(9002011,AMHR,.07)="RESIDENTIAL" Q ;if one record a day, don't want in PCC
;do not pass visits with dnka problem code
;check for at least one pov that is icd9 codable
S (AMHX,AMHGOT,AMHDNKA)=0 F S AMHX=$O(^AMHRPRO("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8 S AMHDNKA=1 Q ;do not pass dnka
.I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.1 S AMHDNKA=1 Q ;do not pass dnka
.I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.11 S AMHDNKA=1 Q ;do not pass dnka
.I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.2 S AMHDNKA=1 Q ;do not pass dnka
.I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.21 S AMHDNKA=1 Q ;do not pass dnka
.I $P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)=8.3 S AMHDNKA=1 Q ;do not pass dnka
.S AMHIMP=$$IMP^AMHUTIL2($P($P(^AMHREC(AMHR,0),U,1),".",1))
.I AMHIMP=1,$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,5)]"" S AMHGOT=1
.I AMHIMP=30,$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,17)]"" S AMHGOT=1
.Q
Q:AMHDNKA
Q:$P(^AMHREC(AMHR,0),U,6)=""
Q:'AMHGOT
Q:'$P(^AMHTACT($P(^AMHREC(AMHR,0),U,6),0),U,4) ;quit if not an activity that gets passed to PCC
TASK ;
;*****************************
I AMHACTN=4 G TASK1
I '$G(AMHIAIG),$$ESIG^AMHESIG(AMHR),$P($G(^AMHREC(AMHR,11)),U,12)="" D Q ;no esig
.W !!,"There is no electronic signature, this visit will not be passed to PCC." D PAUSE^AMHLEA
TASK1 ;
D START^AMHPCCL S AMHVISIT=1 Q ;************ FOR TESTING IN FOREGROUND
Q
;
;;Add a Problem to BH Diagnosis List;;AMH ADD PROBLEM
;;Modify a Problem on BH Diagnosis List;;AMH MODIFY PROBLEM
;;Remove a Problem from BH Diagnosis List;;AMH REMOVE PROBLEM
;;Inactivate an Active Problem on BH Diagnosis List;;AMH INACTIVATE PROBLEM
;;Activate an Inactive Problem on BH Diagnosis List;;AMH ACTIVATE PROBLEM
;;Add a Treatment Note to a BH Problem;;AMH ADD NOTE
;;Modify a Treatment Note of BH Problem;;AMH MODIFY NOTE
;;Remove a Treatment Note to BH Problem;;AMH REMOVE NOTE
;;Display Patient's BH Diagnosis List;;AMH DISPLAY PROBLEM LIST
;;Update the Patient's PCC Problem List
;;Quit
AMHLE2 ; IHS/CMI/LAB - DE CONT. ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,4**;JUN 18, 2010;Build 28
+2 ;
+3 ;
RECCHECK ;EP - check record for completeness
+1 IF '$DATA(^AMHREC(AMHR,0))
QUIT
+2 SET AMHREC=$GET(^AMHREC(AMHR,0))
+3 SET (AMHERROR,AMHOKAY)=0
+4 IF $PIECE(AMHREC,U,4)=""
WRITE !,"Location of Encounter Missing!"
SET (AMHOKAY,AMHERROR)=1
+5 IF $PIECE(AMHREC,U,5)=""
WRITE !,"Community of Service Missing!"
SET (AMHOKAY,AMHERROR)=1
+6 IF $PIECE(AMHREC,U,6)=""
WRITE !,"Activity Type Missing!"
SET (AMHOKAY,AMHERROR)=1
+7 IF $PIECE(AMHREC,U,7)=""
WRITE !,"Type of Contact Missing!"
SET (AMHOKAY,AMHERROR)=1
+8 SET (X,Y)=0
FOR
SET X=$ORDER(^AMHRPROV("AD",AMHR,X))
IF X'=+X
QUIT
IF $PIECE(^AMHRPROV(X,0),U,4)="P"
SET Y=Y+1
+9 ;,$C(7),$C(7) S AMHERROR=1 H 2
IF Y=0
WRITE !,"No primary Provider!"
SET (AMHOKAY,AMHERROR)=1
+10 ;,$C(7),$C(7) W:'$G(AMHERROR) " PLEASE EDIT THIS RECORD" H 2
IF Y>1
WRITE !,"Multiple Primary Providers!"
SET (AMHOKAY,AMHERROR)=1
+11 ;,$C(7) W:'$G(AMHERROR) " PLEASE EDIT THIS RECORD" H 2 Q
IF '$DATA(^AMHRPRO("AD",AMHR))
WRITE !,"No POV entered!!"
SET (AMHOKAY,AMHERROR)=1
+12 ;IF PAT ACTIVITY AND PATIENT MISSING - ERROR
+13 ;W $C(7) S AMHERROR=1 H 2
IF $PIECE(AMHREC,U,12)=""
WRITE !,"Activity Time Missing!"
SET (AMHOKAY,AMHERROR)=1
+14 IF $GET(AMHERROR)
WRITE !!,"Please EDIT this record."
DO PAUSE^AMHLEA
+15 IF AMHACTN=2&($PIECE(^AMHREC(AMHR,0),U,8)="")
DO DELPT
+16 QUIT
DELPT ;delete .02 field of all record entries if not patient related
+1 SET AMHVFLE=9002011
FOR AMHVL=0:0
SET AMHVFLE=$ORDER(^DIC(AMHVFLE))
IF AMHVFLE>9002011.49
QUIT
Begin DoDot:1
+2 SET AMHVDG=^DIC(AMHVFLE,0,"GL")
SET AMHVIGR=AMHVDG_"""AD"",AMHR,AMHVDFN)"
+3 SET AMHVDFN=""
FOR AMHVI=1:1
SET AMHVDFN=$ORDER(@AMHVIGR)
IF AMHVDFN=""
QUIT
SET AMHVIGL=AMHVDG_AMHVDFN_",0)"
IF '$DATA(ZTQUEUED)
WRITE "."
IF $PIECE((@AMHVIGL),U,2)]""
SET DA=AMHVDFN
SET DITC=""
SET DR=".02///@"
SET DIE=AMHVDG
DO CALLDIE^AMHLEIN
End DoDot:1
+4 QUIT
EP1(AMHPAT) ;EP called from protocol
+1 DO FULL^VALM1
+2 IF $DATA(IOF)
WRITE @IOF
+3 SET AMHDATE=DT
+4 SET AMHLOC=DUZ(2)
+5 ;D EN^XBNEW("MHPL^AMHLE2","AMH*")
+6 DO MHPL^AMHLE2
+7 QUIT
EP ;EP = CALLED FROM SCREENMAN
+1 IF $DATA(IOF)
WRITE @IOF
+2 DO EN^XBNEW("MHPL^AMHLE2","AMH*")
+3 QUIT
MHPL ;EP - update mh/ss problem list
+1 SET APCDOVRR=""
+2 KILL AMHX,AMHJ,AMHTEXT
+3 IF $GET(AMHLOC)=""
SET AMHLOC=DUZ(2)
+4 WRITE !!,"Behavioral Health Patient Diagnosis List Update Menu",!
+5 FOR AMHJ=1:1:11
SET AMHX=$PIECE($TEXT(PROBMENU+AMHJ),";;",2)
WRITE !?11,AMHJ,") ",AMHX
+6 KILL AMHX,AMHJ,AMHTEXT
+7 SET DIR(0)="N^1:11:0"
SET DIR("A")="Choose One"
SET DIR("B")="11"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+8 IF $DATA(DIRUT)
QUIT
+9 IF Y=11
QUIT
+10 SET AMHPLC=Y
+11 IF '$GET(AMHAUTH)
IF $GET(AMHR)
SET AMHAUTH=$$PPNAME^AMHUTIL(AMHR)
+12 IF '$GET(AMHAUTH)
SET AMHAUTH=$PIECE(^VA(200,DUZ,0),U)
+13 IF AMHPLC=10
SET DFN=AMHPAT
DO EN1^AMHPL
QUIT
+14 SET DIE="^AUPNPAT("
SET DR="["_$PIECE($TEXT(PROBMENU+AMHPLC),";;",3)_"]"
SET DA=AMHPAT
SET DIE("NO^")=""
DO CALLDIE^AMHLEIN
KILL DR,DA,DIE
+15 IF $DATA(Y)
WRITE !!,"Error encountered in updating BH Diagnosis List for ",$PIECE(^DPT(AMHPAT,0),U)
+16 KILL Y,X,DIU,DIV
+17 GOTO MHPL
PCCLINK ;EP - PCCLINK
+1 KILL X
+2 IF AMHACTN=4
GOTO PCCLINK2
+3 IF '$DATA(^AMHREC(AMHR,0))
GOTO PCCLINK2
+4 IF $GET(AMHVDLT)
GOTO PCCLINK2
+5 ;no pcc if not a patient encounter
IF '$PIECE(^AMHREC(AMHR,0),U,8)
QUIT
+6 SET X=$$ESIG^AMHESIG(AMHR)
+7 IF '$PIECE(X,U,2)
IF AMHLPCC
WRITE !!,"No PCC Link...Note not signed."
DO PAUSE^AMHLEA
QUIT
PCCLINK1 ;
+1 ;quit if no pcc link
IF 'AMHLPCC
IF '$$PRVLINK($$PPINT^AMHUTIL(AMHR))
QUIT
PCCLINK2 ;
+1 IF $GET(AMHVDLT)=""
IF AMHACTN=4
QUIT
+2 IF $GET(AMHVDLT)
IF AMHACTN=4
DO TASK
QUIT
+3 DO VISIT
+4 IF 'AMHVISIT
IF $PIECE(^AMHREC(AMHR,0),U,16)]""
Begin DoDot:1
+5 SET APCDVDLT=$PIECE(^AMHREC(AMHR,0),U,16)
DO ^APCDVDLT
+6 SET DIE="^AMHREC("
SET DA=AMHR
SET DR=".16///@"
DO CALLDIE^AMHLEIN
End DoDot:1
QUIT
+7 IF AMHVISIT
QUIT
+8 QUIT
PRVLINK(P) ;EP
+1 IF '$GET(P)
QUIT 0
+2 IF '$DATA(^AMHSITE(DUZ(2),11,"B",P))
QUIT 0
+3 NEW A
+4 SET A=$ORDER(^AMHSITE(DUZ(2),11,"B",P,0))
+5 IF 'A
QUIT 0
+6 IF $PIECE(^AMHSITE(DUZ(2),11,A,0),U,1)=1
QUIT 0
+7 QUIT 1
+8 ;
VISIT ;
+1 KILL AMHDNKA
+2 SET AMHVISIT=0
+3 IF '$GET(AMHR)
QUIT
+4 ;no pcc if not a patient encounter
IF '$PIECE(^AMHREC(AMHR,0),U,8)
QUIT
+5 ;do not pass residential type of visits to pcc
+6 ;if one record a day, don't want in PCC
IF $$VAL^XBDIQ1(9002011,AMHR,.07)="RESIDENTIAL"
QUIT
+7 ;do not pass visits with dnka problem code
+8 ;check for at least one pov that is icd9 codable
+9 SET (AMHX,AMHGOT,AMHDNKA)=0
FOR
SET AMHX=$ORDER(^AMHRPRO("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+10 ;do not pass dnka
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8
SET AMHDNKA=1
QUIT
+11 ;do not pass dnka
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.1
SET AMHDNKA=1
QUIT
+12 ;do not pass dnka
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.11
SET AMHDNKA=1
QUIT
+13 ;do not pass dnka
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.2
SET AMHDNKA=1
QUIT
+14 ;do not pass dnka
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.21
SET AMHDNKA=1
QUIT
+15 ;do not pass dnka
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)=8.3
SET AMHDNKA=1
QUIT
+16 SET AMHIMP=$$IMP^AMHUTIL2($PIECE($PIECE(^AMHREC(AMHR,0),U,1),".",1))
+17 IF AMHIMP=1
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U,5)]""
SET AMHGOT=1
+18 IF AMHIMP=30
IF $PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U,17)]""
SET AMHGOT=1
+19 QUIT
End DoDot:1
+20 IF AMHDNKA
QUIT
+21 IF $PIECE(^AMHREC(AMHR,0),U,6)=""
QUIT
+22 IF 'AMHGOT
QUIT
+23 ;quit if not an activity that gets passed to PCC
IF '$PIECE(^AMHTACT($PIECE(^AMHREC(AMHR,0),U,6),0),U,4)
QUIT
TASK ;
+1 ;*****************************
+2 IF AMHACTN=4
GOTO TASK1
+3 ;no esig
IF '$GET(AMHIAIG)
IF $$ESIG^AMHESIG(AMHR)
IF $PIECE($GET(^AMHREC(AMHR,11)),U,12)=""
Begin DoDot:1
+4 WRITE !!,"There is no electronic signature, this visit will not be passed to PCC."
DO PAUSE^AMHLEA
End DoDot:1
QUIT
TASK1 ;
+1 ;************ FOR TESTING IN FOREGROUND
DO START^AMHPCCL
SET AMHVISIT=1
QUIT
+2 QUIT
+3 ;
+1 ;;Add a Problem to BH Diagnosis List;;AMH ADD PROBLEM
+2 ;;Modify a Problem on BH Diagnosis List;;AMH MODIFY PROBLEM
+3 ;;Remove a Problem from BH Diagnosis List;;AMH REMOVE PROBLEM
+4 ;;Inactivate an Active Problem on BH Diagnosis List;;AMH INACTIVATE PROBLEM
+5 ;;Activate an Inactive Problem on BH Diagnosis List;;AMH ACTIVATE PROBLEM
+6 ;;Add a Treatment Note to a BH Problem;;AMH ADD NOTE
+7 ;;Modify a Treatment Note of BH Problem;;AMH MODIFY NOTE
+8 ;;Remove a Treatment Note to BH Problem;;AMH REMOVE NOTE
+9 ;;Display Patient's BH Diagnosis List;;AMH DISPLAY PROBLEM LIST
+10 ;;Update the Patient's PCC Problem List
+11 ;;Quit
