AMHEGS ; IHS/CMI/LAB - REVIEW SF BY DATE 05 Feb 2010 2:57 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
;
;
START ;
W:$D(IOF) @IOF
D DONE
;
D EN,FULL^VALM1
D DONE
Q
DONE ;
K AMHX,AMHC,AMHLINE,AMHY,AMHG,AMHR,DFN
D ^XBFMK
D KILL^AUPNPAT
Q
EN ;
K ^TMP($J,"AMHEGS")
D GATHER
D EN^VALM("AMH GROUP PTS")
D CLEAR^VALM1
Q
GATHER ;
K ^TMP($J,"AMHEGS")
S (AMHC,AMHX,AMHLINE)=0
F S AMHX=$O(^AMHGROUP(AMHNG,51,AMHX)) Q:AMHX'=+AMHX D
.S DFN=$P(^AMHGROUP(AMHNG,51,AMHX,0),U)
.S AMHY="",AMHLINE=AMHLINE+1
.S AMHY=AMHLINE_") "
.S $E(AMHY,6)=$P(^DPT(DFN,0),U)
.S $E(AMHY,40)=$P(^DPT(DFN,0),U,2)
.S $E(AMHY,43)=$$AGE^AUPNPAT(DFN,DT)
.S $E(AMHY,48)=$$DATE($P(^DPT(DFN,0),U,3))
.S $E(AMHY,60)=$$HRN^AUPNPAT(DFN,DUZ(2))
.S Y=$$REC(DFN,AMHNG) S $E(AMHY,70)=$S(Y:"yes",1:"no")
.S ^TMP($J,"AMHEGS",AMHLINE,0)=AMHY,^TMP($J,"AMHEGS","IDX",AMHLINE,AMHLINE)=AMHX
Q
REC(P,G) ;does this patient have a record in MHSS for this group
NEW X,Y,Z
S X=0,Y=0 F S X=$O(^AMHGROUP(G,61,X)) Q:X'=+X!(Y) D
.S Z=$P(^AMHGROUP(G,61,X,0),U)
.Q:'$D(^AMHREC(Z,0))
.I $P(^AMHREC(Z,0),U,8)=P S Y=Z
.Q
Q Y
DATE(D) ;
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
HDR ; -- header code
S VALMHDR(1)="Group Entry"
S X="",$E(X,6)="Patient Name",$E(X,39)="Sex",$E(X,43)="Age",$E(X,50)="DOB",$E(X,60)="HRN",$E(X,66)="Record Added"
S VALMHDR(2)=X
Q
;
INIT ; -- init variables and list array
D GATHER
S VALMCNT=AMHLINE
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXPND ; -- expand code
Q
EDITREC ;
D FULL^VALM1 K DIR
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
S AMHX=0 S AMHX=^TMP($J,"AMHEGS","IDX",R,R)
I '$D(^AMHGROUP(AMHNG,51,AMHX,0)) W !,"Not a valid GROUP." K AMHRDEL,R,AMHG,R1 D PAUSE D EXIT Q
S DFN=$P(^AMHGROUP(AMHNG,51,AMHX,0),U)
S AMHR=$$REC(DFN,AMHNG)
I 'AMHR D D EXIT Q
.W !!,"There is no visit on file for ",$P(^DPT(DFN,0),U)," for this group activity."
.S DIR(0)="Y",DIR("A")="Do you want to add a visit",DIR("B")="Y" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) D PAUSE Q
.I 'Y D PAUSE Q
.S AMHNGX=AMHX D ADDREC1^AMHEGR
.Q
I '$D(^AMHREC(AMHR,0)) W !,"Not a valid BH RECORD." K AMHRDEL,AMHR D PAUSE^AMHLEA D EXIT Q
D FULL^VALM1
S AMHPAT=DFN
DGSECE ;
K AMHRESU
D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
I '$G(AMHRESU(1)) G EDITREC1
I $G(AMHRESU(1))=3!($G(AMHRESU(1))=4)!($G(AMHRESU(1))=5) D DISPDG^AMHLE,PAUSE^AMHLEA,EXIT Q
D DISPDG^AMHLE
W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue to edit this record",DIR("B")="N" KILL DA D ^DIR KILL DIR
I 'Y D EXIT Q
K AMHRESU
D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
EDITREC1 ;
S AMHVTYPE=$P(^AMHREC(AMHR,0),U,33)
I AMHVTYPE="" S AMHVTYPE="R"
S AMHDATE=$P(^AMHREC(AMHR,0),U)
S AMHPTYPE=$P(^AMHREC(AMHR,0),U,2)
S AMHACTN=2
S DIADD=1,DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR K DIADD
I '$P($G(^AMHREC(AMHR,11)),U,12) S DR="[AMH EDIT RECORD]",DA=AMHR,DDSFILE=9002011 D ^DDS
I $P($G(^AMHREC(AMHR,11)),U,12) S DR="[AMHSV EDIT RECORD]",DA=AMHR,DDSFILE=9002011 D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ** NOTIFY PROGRAMMER **" S AMHQUIT=1 K DIMSG Q
S DIE="^AMHREC(",DA=AMHR,DR="1117////"_$$HL^AMHUTIL2($$VALI^XBDIQ1(9002011,AMHR,.02)) D ^DIE K DIE,DA,DR ;IHS/CMI/LAB PATCH 8 HOSP LOC
S AMHERROR=0 D RECCHECK^AMHLE2 I AMHERROR D PAUSE
D PCCLINK^AMHLEA
D EXIT
Q
ADDPT ;
;add a new patient to the group
;update 51 multiple
D FULL^VALM1
;get patient
D ^XBFMK
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC
I Y=-1 W !!,"No patient selected." D PAUSE,EXIT Q
S (AMHPAT,DFN)=+Y
I AMHPAT,'$$ALLOWP^AMHUTIL(DUZ,AMHPAT) D NALLOWP^AMHUTIL D PAUSE G ADDPT
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
D ^XBFMK
S DA(1)=AMHNG,DIC="^AMHGROUP("_AMHNG_",51,",DIC(0)="AELQ",DIC("P")=$P(^DD(9002011.67,5101,0),U,2)
D ^DIC
I Y=-1 W !!,"adding patient to group failed." D PAUSE,EXIT Q
D ADDREC^AMHEGR
;D UPDACT ;update activity time on all records to new activity time based on new patient added and call pcc link
D EXIT
Q
DISP ;EP - called from protocol
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
S AMHX=0 S AMHX=^TMP($J,"AMHEGS","IDX",R,R)
I '$D(^AMHGROUP(AMHNG,51,AMHX,0)) W !,"Not a valid GROUP." K AMHRDEL,R,AMHG,R1 D PAUSE D EXIT Q
D FULL^VALM1
S DFN=$P(^AMHGROUP(AMHNG,51,AMHX,0),U)
S AMHR=$$REC(DFN,AMHNG)
I 'AMHR W !!,"There is no record/visit on file yet for this patient." K AMHR,DFN,AMHG D PAUSE,EXIT Q
DGSECD ;
I '$P(^AMHREC(AMHR,0),U,8) G DISP9
S AMHPAT=$P(^AMHREC(AMHR,0),U,8)
D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
I '$G(AMHRESU(1)) G DISP9
I $G(AMHRESU(1))=3!($G(AMHRESU(1))=4)!($G(AMHRESU(1))=5) D DISPDG^AMHLE,PAUSE^AMHLEA,EXIT Q
D DISPDG^AMHLE
W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue to display this record",DIR("B")="N" KILL DA D ^DIR KILL DIR
I 'Y D EXIT Q
K AMHRESU
D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
DISP9 ;
D ^AMHDVD
D EXIT
Q
DEL ;EP - called from protocol
;add code to not allow delete unless they have the key
I '$D(^XUSEC("AMHZ DELETE RECORD",DUZ)) W !!,"You do not have the security access to delete a VISIT.",!,"Please see your supervisor or program manager.",! D PAUSE,EXIT Q
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
S AMHG=0 S AMHG=^TMP($J,"AMHEGS","IDX",R,R)
I '$D(^AMHGROUP(AMHNG,51,AMHG,0)) W !,"Not a valid patient." K AMHRDEL,R,AMHG,R1 D PAUSE D EXIT Q
D FULL^VALM1
S DFN=$P(^AMHGROUP(AMHNG,51,AMHG,0),U)
S AMHR=$$REC(DFN,AMHNG)
I 'AMHR W !!,"There is no record/visit on file yet for this patient." K AMHR,DFN,AMHG D PAUSE,EXIT Q
I '$D(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ)),$P($G(^AMHREC(AMHR,11)),U,12)]"" D D PAUSE,EXIT Q
.W !!,$$VAL^XBDIQ1(9002011,AMHR,.01),?20,$$VAL^XBDIQ1(9002011,AMHR,.08)
.W !!,"The progress note associated with this visit has been signed. You cannot"
.W !,"delete this visit. Please see your supervisor or program manager.",!
DGSECX ;
I '$P(^AMHREC(AMHR,0),U,8) G DGSECXX
S AMHPAT=$P(^AMHREC(AMHR,0),U,8)
D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
I '$G(AMHRESU(1)) G DGSECXX
I $G(AMHRESU(1))=3!($G(AMHRESU(1))=4)!($G(AMHRESU(1))=5) D DISPDG^AMHLE,PAUSE^AMHLEA,EXIT Q
D DISPDG^AMHLE
W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue to display this record",DIR("B")="N" KILL DA D ^DIR KILL DIR
I 'Y D EXIT Q
K AMHRESU
D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
DGSECXX ;
S AMHACTN=4
D EN^AMHRDSP
W !
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this Patient's Visit",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D PAUSE,EXIT Q
I 'Y D EXIT Q
;D ^AMHLEIN
S AMHPAT=DFN
D DEL^AMHLEA
D PCCLINK^AMHLEA
;D UPDACT
D EXIT
Q
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
EXIT ; -- exit code
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=AMHLINE
D HDR
K X,Y,Z,I
K AMHRESU
Q
DISPDG ;EP
W !!,"One of the patients in the group is a sensitive patient:",!
W !?5,$P(^DPT(AMHPAT,0),U,1),?40,"DOB: ",$$FMTE^XLFDT($$DOB^AUPNPAT(AMHPAT)),?65,"HRN: ",$$HRN^AUPNPAT(AMHPAT,DUZ(2))
S X=1 F S X=$O(AMHRESU(X)) Q:X'=+X W !,$$CTR^AMHLEIN(AMHRESU(X))
Q
ADDNS ;EP
S APCDOVRR=""
D FULL^VALM1
S AMHADPTV=1
S AMHQUIT=0,AMHACTN=1
W !,"Creating new record..." K DD,D0,DO,DINUM,DIC,DA,DR
S DIC(0)="EL",DIC="^AMHREC(",DLAYGO=9002011,DIADD=1,X=AMHDATE,DIC("DR")=".08////^S X=$G(AMHPAT);.02///"_AMHPTYPE_";.03///^S X=DT;.19////"_DUZ_";.33////"_AMHVTYPE_";.28////"_DUZ_";.22///A;.21///^S X=DT"_";1111////1"
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
;update multiple of user last update/date edited
S AMHR=+Y
S DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR
S DA=AMHR,DIE="^AMHREC(",DR=".02///"_AMHPTYPE_$S($P(^AMHGROUP(AMHG,0),U,5):";.04///`"_$P(^AMHGROUP(AMHG,0),U,5),1:"")_$S($P(^AMHGROUP(AMHG,0),U,6):";.05///`"_$P(^AMHGROUP(AMHG,0),U,6),1:"")
S DR=DR_$S($P(^AMHGROUP(AMHG,0),U,14):";.25///`"_$P(^AMHGROUP(AMHG,0),U,14),1:"")
S DR=DR_";.11///"_$$GETAWI^AMHLEIN(DUZ(2))_$S($P(^AMHGROUP(AMHG,0),U,8):";.07///`"_$P(^AMHGROUP(AMHG,0),U,8),1:"")
D ^DIE I $D(Y) W !!,"Error updating record......" H 5
K DR,DA,DIE
D GETPROV^AMHLEP2 I '$$PPINT^AMHUTIL(AMHR) W !,"No PRIMARY PROVIDER entered!! - Required element" D DEL,EXIT Q
;
ADD1 ;
S DA=AMHR,DDSFILE=9002011,DR="[AMH ADD RECORD]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
;CHECK RECORD
CHK ;
D CHECK^AMHLEA
I AMHZDEL Q
I AMHZED G ADD1
I AMHVTYPE="R" D REGULAR^AMHLEP2
I $G(AMHNAVR) Q
D SUIC^AMHLEA,OTHER^AMHLEP2
D PCCLINK^AMHLEP2
Q
AMHEGS ; IHS/CMI/LAB - REVIEW SF BY DATE 05 Feb 2010 2:57 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
+2 ;
+3 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 DO DONE
+3 ;
+4 DO EN
DO FULL^VALM1
+5 DO DONE
+6 QUIT
DONE ;
+1 KILL AMHX,AMHC,AMHLINE,AMHY,AMHG,AMHR,DFN
+2 DO ^XBFMK
+3 DO KILL^AUPNPAT
+4 QUIT
EN ;
+1 KILL ^TMP($JOB,"AMHEGS")
+2 DO GATHER
+3 DO EN^VALM("AMH GROUP PTS")
+4 DO CLEAR^VALM1
+5 QUIT
GATHER ;
+1 KILL ^TMP($JOB,"AMHEGS")
+2 SET (AMHC,AMHX,AMHLINE)=0
+3 FOR
SET AMHX=$ORDER(^AMHGROUP(AMHNG,51,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 SET DFN=$PIECE(^AMHGROUP(AMHNG,51,AMHX,0),U)
+5 SET AMHY=""
SET AMHLINE=AMHLINE+1
+6 SET AMHY=AMHLINE_") "
+7 SET $EXTRACT(AMHY,6)=$PIECE(^DPT(DFN,0),U)
+8 SET $EXTRACT(AMHY,40)=$PIECE(^DPT(DFN,0),U,2)
+9 SET $EXTRACT(AMHY,43)=$$AGE^AUPNPAT(DFN,DT)
+10 SET $EXTRACT(AMHY,48)=$$DATE($PIECE(^DPT(DFN,0),U,3))
+11 SET $EXTRACT(AMHY,60)=$$HRN^AUPNPAT(DFN,DUZ(2))
+12 SET Y=$$REC(DFN,AMHNG)
SET $EXTRACT(AMHY,70)=$SELECT(Y:"yes",1:"no")
+13 SET ^TMP($JOB,"AMHEGS",AMHLINE,0)=AMHY
SET ^TMP($JOB,"AMHEGS","IDX",AMHLINE,AMHLINE)=AMHX
End DoDot:1
+14 QUIT
REC(P,G) ;does this patient have a record in MHSS for this group
+1 NEW X,Y,Z
+2 SET X=0
SET Y=0
FOR
SET X=$ORDER(^AMHGROUP(G,61,X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+3 SET Z=$PIECE(^AMHGROUP(G,61,X,0),U)
+4 IF '$DATA(^AMHREC(Z,0))
QUIT
+5 IF $PIECE(^AMHREC(Z,0),U,8)=P
SET Y=Z
+6 QUIT
End DoDot:1
+7 QUIT Y
DATE(D) ;
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
HDR ; -- header code
+1 SET VALMHDR(1)="Group Entry"
+2 SET X=""
SET $EXTRACT(X,6)="Patient Name"
SET $EXTRACT(X,39)="Sex"
SET $EXTRACT(X,43)="Age"
SET $EXTRACT(X,50)="DOB"
SET $EXTRACT(X,60)="HRN"
SET $EXTRACT(X,66)="Record Added"
+3 SET VALMHDR(2)=X
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 DO GATHER
+2 SET VALMCNT=AMHLINE
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
EDITREC ;
+1 DO FULL^VALM1
KILL DIR
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT
QUIT
+4 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT
QUIT
+5 SET AMHX=0
SET AMHX=^TMP($JOB,"AMHEGS","IDX",R,R)
+6 IF '$DATA(^AMHGROUP(AMHNG,51,AMHX,0))
WRITE !,"Not a valid GROUP."
KILL AMHRDEL,R,AMHG,R1
DO PAUSE
DO EXIT
QUIT
+7 SET DFN=$PIECE(^AMHGROUP(AMHNG,51,AMHX,0),U)
+8 SET AMHR=$$REC(DFN,AMHNG)
+9 IF 'AMHR
Begin DoDot:1
+10 WRITE !!,"There is no visit on file for ",$PIECE(^DPT(DFN,0),U)," for this group activity."
+11 SET DIR(0)="Y"
SET DIR("A")="Do you want to add a visit"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
DO PAUSE
QUIT
+13 IF 'Y
DO PAUSE
QUIT
+14 SET AMHNGX=AMHX
DO ADDREC1^AMHEGR
+15 QUIT
End DoDot:1
DO EXIT
QUIT
+16 IF '$DATA(^AMHREC(AMHR,0))
WRITE !,"Not a valid BH RECORD."
KILL AMHRDEL,AMHR
DO PAUSE^AMHLEA
DO EXIT
QUIT
+17 DO FULL^VALM1
+18 SET AMHPAT=DFN
DGSECE ;
+1 KILL AMHRESU
+2 DO PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
+3 IF '$GET(AMHRESU(1))
GOTO EDITREC1
+4 IF $GET(AMHRESU(1))=3!($GET(AMHRESU(1))=4)!($GET(AMHRESU(1))=5)
DO DISPDG^AMHLE
DO PAUSE^AMHLEA
DO EXIT
QUIT
+5 DO DISPDG^AMHLE
+6 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue to edit this record"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+7 IF 'Y
DO EXIT
QUIT
+8 KILL AMHRESU
+9 DO NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
EDITREC1 ;
+1 SET AMHVTYPE=$PIECE(^AMHREC(AMHR,0),U,33)
+2 IF AMHVTYPE=""
SET AMHVTYPE="R"
+3 SET AMHDATE=$PIECE(^AMHREC(AMHR,0),U)
+4 SET AMHPTYPE=$PIECE(^AMHREC(AMHR,0),U,2)
+5 SET AMHACTN=2
+6 SET DIADD=1
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
KILL DIADD
+7 IF '$PIECE($GET(^AMHREC(AMHR,11)),U,12)
SET DR="[AMH EDIT RECORD]"
SET DA=AMHR
SET DDSFILE=9002011
DO ^DDS
+8 IF $PIECE($GET(^AMHREC(AMHR,11)),U,12)
SET DR="[AMHSV EDIT RECORD]"
SET DA=AMHR
SET DDSFILE=9002011
DO ^DDS
+9 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ** NOTIFY PROGRAMMER **"
SET AMHQUIT=1
KILL DIMSG
QUIT
+10 ;IHS/CMI/LAB PATCH 8 HOSP LOC
SET DIE="^AMHREC("
SET DA=AMHR
SET DR="1117////"_$$HL^AMHUTIL2($$VALI^XBDIQ1(9002011,AMHR,.02))
DO ^DIE
KILL DIE,DA,DR
+11 SET AMHERROR=0
DO RECCHECK^AMHLE2
IF AMHERROR
DO PAUSE
+12 DO PCCLINK^AMHLEA
+13 DO EXIT
+14 QUIT
ADDPT ;
+1 ;add a new patient to the group
+2 ;update 51 multiple
+3 DO FULL^VALM1
+4 ;get patient
+5 DO ^XBFMK
+6 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
+7 IF Y=-1
WRITE !!,"No patient selected."
DO PAUSE
DO EXIT
QUIT
+8 SET (AMHPAT,DFN)=+Y
+9 IF AMHPAT
IF '$$ALLOWP^AMHUTIL(DUZ,AMHPAT)
DO NALLOWP^AMHUTIL
DO PAUSE
GOTO ADDPT
+10 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!!
HANG 2
+11 DO ^XBFMK
+12 SET DA(1)=AMHNG
SET DIC="^AMHGROUP("_AMHNG_",51,"
SET DIC(0)="AELQ"
SET DIC("P")=$PIECE(^DD(9002011.67,5101,0),U,2)
+13 DO ^DIC
+14 IF Y=-1
WRITE !!,"adding patient to group failed."
DO PAUSE
DO EXIT
QUIT
+15 DO ADDREC^AMHEGR
+16 ;D UPDACT ;update activity time on all records to new activity time based on new patient added and call pcc link
+17 DO EXIT
+18 QUIT
DISP ;EP - called from protocol
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT
QUIT
+4 SET AMHX=0
SET AMHX=^TMP($JOB,"AMHEGS","IDX",R,R)
+5 IF '$DATA(^AMHGROUP(AMHNG,51,AMHX,0))
WRITE !,"Not a valid GROUP."
KILL AMHRDEL,R,AMHG,R1
DO PAUSE
DO EXIT
QUIT
+6 DO FULL^VALM1
+7 SET DFN=$PIECE(^AMHGROUP(AMHNG,51,AMHX,0),U)
+8 SET AMHR=$$REC(DFN,AMHNG)
+9 IF 'AMHR
WRITE !!,"There is no record/visit on file yet for this patient."
KILL AMHR,DFN,AMHG
DO PAUSE
DO EXIT
QUIT
DGSECD ;
+1 IF '$PIECE(^AMHREC(AMHR,0),U,8)
GOTO DISP9
+2 SET AMHPAT=$PIECE(^AMHREC(AMHR,0),U,8)
+3 DO PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
+4 IF '$GET(AMHRESU(1))
GOTO DISP9
+5 IF $GET(AMHRESU(1))=3!($GET(AMHRESU(1))=4)!($GET(AMHRESU(1))=5)
DO DISPDG^AMHLE
DO PAUSE^AMHLEA
DO EXIT
QUIT
+6 DO DISPDG^AMHLE
+7 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue to display this record"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+8 IF 'Y
DO EXIT
QUIT
+9 KILL AMHRESU
+10 DO NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
DISP9 ;
+1 DO ^AMHDVD
+2 DO EXIT
+3 QUIT
DEL ;EP - called from protocol
+1 ;add code to not allow delete unless they have the key
+2 IF '$DATA(^XUSEC("AMHZ DELETE RECORD",DUZ))
WRITE !!,"You do not have the security access to delete a VISIT.",!,"Please see your supervisor or program manager.",!
DO PAUSE
DO EXIT
QUIT
+3 DO EN^VALM2(XQORNOD(0),"OS")
+4 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT
QUIT
+5 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT
QUIT
+6 SET AMHG=0
SET AMHG=^TMP($JOB,"AMHEGS","IDX",R,R)
+7 IF '$DATA(^AMHGROUP(AMHNG,51,AMHG,0))
WRITE !,"Not a valid patient."
KILL AMHRDEL,R,AMHG,R1
DO PAUSE
DO EXIT
QUIT
+8 DO FULL^VALM1
+9 SET DFN=$PIECE(^AMHGROUP(AMHNG,51,AMHG,0),U)
+10 SET AMHR=$$REC(DFN,AMHNG)
+11 IF 'AMHR
WRITE !!,"There is no record/visit on file yet for this patient."
KILL AMHR,DFN,AMHG
DO PAUSE
DO EXIT
QUIT
+12 IF '$DATA(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ))
IF $PIECE($GET(^AMHREC(AMHR,11)),U,12)]""
Begin DoDot:1
+13 WRITE !!,$$VAL^XBDIQ1(9002011,AMHR,.01),?20,$$VAL^XBDIQ1(9002011,AMHR,.08)
+14 WRITE !!,"The progress note associated with this visit has been signed. You cannot"
+15 WRITE !,"delete this visit. Please see your supervisor or program manager.",!
End DoDot:1
DO PAUSE
DO EXIT
QUIT
DGSECX ;
+1 IF '$PIECE(^AMHREC(AMHR,0),U,8)
GOTO DGSECXX
+2 SET AMHPAT=$PIECE(^AMHREC(AMHR,0),U,8)
+3 DO PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
+4 IF '$GET(AMHRESU(1))
GOTO DGSECXX
+5 IF $GET(AMHRESU(1))=3!($GET(AMHRESU(1))=4)!($GET(AMHRESU(1))=5)
DO DISPDG^AMHLE
DO PAUSE^AMHLEA
DO EXIT
QUIT
+6 DO DISPDG^AMHLE
+7 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue to display this record"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+8 IF 'Y
DO EXIT
QUIT
+9 KILL AMHRESU
+10 DO NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
DGSECXX ;
+1 SET AMHACTN=4
+2 DO EN^AMHRDSP
+3 WRITE !
+4 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this Patient's Visit"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
DO PAUSE
DO EXIT
QUIT
+6 IF 'Y
DO EXIT
QUIT
+7 ;D ^AMHLEIN
+8 SET AMHPAT=DFN
+9 DO DEL^AMHLEA
+10 DO PCCLINK^AMHLEA
+11 ;D UPDACT
+12 DO EXIT
+13 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
EXIT ; -- exit code
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER
+4 SET VALMCNT=AMHLINE
+5 DO HDR
+6 KILL X,Y,Z,I
+7 KILL AMHRESU
+8 QUIT
DISPDG ;EP
+1 WRITE !!,"One of the patients in the group is a sensitive patient:",!
+2 WRITE !?5,$PIECE(^DPT(AMHPAT,0),U,1),?40,"DOB: ",$$FMTE^XLFDT($$DOB^AUPNPAT(AMHPAT)),?65,"HRN: ",$$HRN^AUPNPAT(AMHPAT,DUZ(2))
+3 SET X=1
FOR
SET X=$ORDER(AMHRESU(X))
IF X'=+X
QUIT
WRITE !,$$CTR^AMHLEIN(AMHRESU(X))
+4 QUIT
ADDNS ;EP
+1 SET APCDOVRR=""
+2 DO FULL^VALM1
+3 SET AMHADPTV=1
+4 SET AMHQUIT=0
SET AMHACTN=1
+5 WRITE !,"Creating new record..."
KILL DD,D0,DO,DINUM,DIC,DA,DR
+6 SET DIC(0)="EL"
SET DIC="^AMHREC("
SET DLAYGO=9002011
SET DIADD=1
SET X=AMHDATE
SET DIC("DR")=".08////^S X=$G(AMHPAT);.02///"_AMHPTYPE_";.03///^S X=DT;.19////"_DUZ_";.33////"_AMHVTYPE_";.28////"_DUZ_";.22///A;.21///^S X=DT"_";1111////1"
+7 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+8 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health Record is NOT complete!! Deleting Record.",!
DO PAUSE
QUIT
+9 ;update multiple of user last update/date edited
+10 SET AMHR=+Y
+11 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
+12 SET DA=AMHR
SET DIE="^AMHREC("
SET DR=".02///"_AMHPTYPE_$SELECT($PIECE(^AMHGROUP(AMHG,0),U,5):";.04///`"_$PIECE(^AMHGROUP(AMHG,0),U,5),1:"")_$SELECT($PIECE(^AMHGROUP(AMHG,0),U,6):";.05///`"_$PIECE(^AMHGROUP(AMHG,0),U,6),1:"")
+13 SET DR=DR_$SELECT($PIECE(^AMHGROUP(AMHG,0),U,14):";.25///`"_$PIECE(^AMHGROUP(AMHG,0),U,14),1:"")
+14 SET DR=DR_";.11///"_$$GETAWI^AMHLEIN(DUZ(2))_$SELECT($PIECE(^AMHGROUP(AMHG,0),U,8):";.07///`"_$PIECE(^AMHGROUP(AMHG,0),U,8),1:"")
+15 DO ^DIE
IF $DATA(Y)
WRITE !!,"Error updating record......"
HANG 5
+16 KILL DR,DA,DIE
+17 DO GETPROV^AMHLEP2
IF '$$PPINT^AMHUTIL(AMHR)
WRITE !,"No PRIMARY PROVIDER entered!! - Required element"
DO DEL
DO EXIT
QUIT
+18 ;
ADD1 ;
+1 SET DA=AMHR
SET DDSFILE=9002011
SET DR="[AMH ADD RECORD]"
DO ^DDS
+2 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+3 ;CHECK RECORD
CHK ;
+1 DO CHECK^AMHLEA
+2 IF AMHZDEL
QUIT
+3 IF AMHZED
GOTO ADD1
+4 IF AMHVTYPE="R"
DO REGULAR^AMHLEP2
+5 IF $GET(AMHNAVR)
QUIT
+6 DO SUIC^AMHLEA
DO OTHER^AMHLEP2
+7 DO PCCLINK^AMHLEP2
+8 QUIT
