AMHLEP2 ; IHS/CMI/LAB - ADD NEW BH ACTIVITY RECORDS 06 Nov 2009 9:21 AM ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,2,8**;JUN 02, 2010;Build 7
;
ADD ;EP
S APCDOVRR=""
D FULL^VALM1
I '$D(AMHDATE) W !!,"Date not entered." H 5 Q
I '$G(AMHPAT) W !!,"No patient identified." H 5 Q
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("
S DR=".02///"_AMHPTYPE_$S($$GETLOC^AMHLEIN(DUZ(2),AMHPTYPE):";.04///`"_$$GETLOC^AMHLEIN(DUZ(2),AMHPTYPE),1:"")_$S($$GETCOMM^AMHLEIN(DUZ(2),AMHPTYPE):";.05///`"_$$GETCOMM^AMHLEIN(DUZ(2),AMHPTYPE),1:"")_";1117////"_$$HL^AMHUTIL2(AMHPTYPE)
;IHS/CMI/LAB - PATCH 8 Hosp location
S DR=DR_$S($$GETCLN^AMHLEIN(DUZ(2),AMHPTYPE):";.25///`"_$$GETCLN^AMHLEIN(DUZ(2),AMHPTYPE),1:"")
S DR=DR_";.11///"_$$GETAWI^AMHLEIN(DUZ(2))_$S($$GETTOC^AMHLEIN(DUZ(2)):";.07///`"_$$GETTOC^AMHLEIN(DUZ(2)),1:"")
D ^DIE I $D(Y) W !!,"Error updating record......" H 5
K DR,DA,DIE
D GETPROV I '$$PPINT^AMHUTIL(AMHR) W !,"No PRIMARY PROVIDER entered!! - Required element" D DEL,EXIT Q
;I AMHVTYPE="S"!(AMHVTYPE="U") D SAN^AMHLEP3 G CHK
;I AMHVTYPE="I"!(AMHVTYPE="P") D INTAKE^AMHLEP4,EXIT Q
;
ADD1 ;
I AMHVTYPE="R" S DA=AMHR,DDSFILE=9002011,DR="[AMH ADD RECORD]" D ^DDS
;I AMHVTYPE="B" S AMHVTYPE="R",DA=AMHR,DDSFILE=9002011,DR="[AMHB ADD RECORD]" D ^DDS
;I AMHVTYPE="N" S DA=AMHR,DDSFILE=9002011,DR="[AMHNS ADD RECORD]" D ^DDS
;I AMHVTYPE="C" S DA=AMHR,DDSFILE=9002011,DR="[AMH ADD CASE TRACKING REC]" D ^DDS
;I AMHVTYPE="A" S DA=AMHR,DDSFILE=9002011,DR="[AMHASA ADD RECORD]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
;STUFF 1117 PER .02 OF RECORD
S DA=AMHR,DIE="^AMHREC(",DR="1117////"_$$HL^AMHUTIL2($$VALI^XBDIQ1(9002011,AMHR,.02)) D ^DIE K DA,DR,DIE ;IHS/CMI/LAB - PATCH 8 Hosp location
;CHECK RECORD
;I AMHVTYPE="N" D GENPOV^AMHLENS
CHK ; S AMHOKAY=0 D RECCHECK^AMHLE2 I AMHOKAY W !!,"Incomplete record!! Deleting record!!" D DEL,EXIT Q
D CHECK^AMHLEA
I AMHZDEL D EXIT Q
I AMHZED G ADD1
;I $G(AMHERROR) W !!,$C(7),$C(7),"PLEASE EDIT THIS RECORD!!",!!
;I $P(^AMHREC(AMHR,0),U,2)="C"!($P($G(^AMHREC(AMHR,91)),U)="Y") D CDST
I AMHVTYPE="R" D REGULAR
;I AMHVTYPE="S" D REGULAR
;I AMHVTYPE="C" D REGULAR
;I AMHVTYPE="N" D REGULAR
;I AMHVTYPE="A" D REGULAR
I $G(AMHNAVR) Q
;D CLEAR^VALM1
D SUIC^AMHLEA,OTHER
D PCCLINK
D EXIT
Q
;
REGULAR ;EP
;D TERM^VALM0,FULL^VALM1
I '$D(^AMHSITE(DUZ(2),13,"B",DUZ)) Q ;no access
S DIR(0)="Y",DIR("A")="Do you want to share this visit information with other providers",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I 'Y Q
K XMY D GETLIST
I '$D(XMY) G REGULAR
W !!,"Message will be sent to:" S X=0 F S X=$O(XMY(X)) Q:X'=+X W ?28,$P(^VA(200,X,0),U),!
S DIR(0)="Y",DIR("A")="Do you want to attach a note to this mail message",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G REGULAR
W !,"Enter the text of your note.",!
I Y=1 D D ^XBFMK
.L +^AMHREC(AMHR):60 S DIE="^AMHREC(",DA=AMHR,DR="9800" D ^DIE L -^AMHREC(AMHR)
S DIR(0)="Y",DIR("A")="Ready to send mail message",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) K XMY,XMTEXT,XMDUZ,XMZ,XMSUB,AMHEFT Q
I 'Y K XMY,XMTEXT,XMDUZ,XMZ,XMSUB G REGULAR
FS ;
S AMHEFT=""
S DIR(0)="SB^F:FULL;S:SUPPRESSED",DIR("A")="Send Full or Suppressed Form",DIR("B")="S" KILL DA D ^DIR KILL DIR
I $D(DIRUT) K XMY,XMTEXT,XMDUZ,XMZ,XMSUB,AMHEFT Q
S AMHEFT=Y
D MAILMSG
Q
GETLIST ;
K XMY
GETLIST1 ;
K DIC,DR,DD,D0,DO S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Send to: " D ^DIC
I Y=-1 Q
S XMY(+Y)=""
G GETLIST1
;
CASE(P,R,T) ;return 1 if case already opened
S U="^"
I '$G(P) Q ""
I '$G(R) Q ""
I $G(T)="" Q ""
NEW X,H S (X,H)=0 F S X=$O(^AMHPCASE("AA",P,9999999-$P($P(^AMHREC(R,0),U),"."),X)) Q:X'=+X I $P(^AMHPCASE(X,0),U,2)=T,$P(^AMHPCASE(X,0),U,8)=$$PPINT^AMHUTIL(R) S H=1
Q H
MAILMSG ;
K ^TMP("AMHS",$J),^TMP("AMHMSG",$J)
D ^XBFMK
S AMHX=0 F S AMHX=$O(XMY(AMHX)) Q:AMHX'=+AMHX D
.I '$D(^AMHREC(AMHR,52,"B",AMHX)) S DA=AMHR,DIE="^AMHREC(",DR="5200///`"_AMHX D ^DIE,^XBFMK
D EP2^AMHLEFP2(AMHR,1)
S (C,X)=0 F S X=$O(^TMP("AMHS",$J,"DCS",X)) Q:X'=+X S C=C+1
S C=C+1,^TMP("AMHS",$J,"DCS",C)="THIS FORM CONTAINS CONFIDENTIAL PATIENT INFORMATION. UNAUTHORIZED"
S C=C+1,^TMP("AMHS",$J,"DCS",C)="REPRODUCTION OF THIS FORM MAY VIOLATE PRIVACY ACT STATUTES AND BE"
S C=C+1,^TMP("AMHS",$J,"DCS",C)="PUNISHABLE BY LAW."
S C=C+1,^TMP("AMHS",$J,"DCS",C)="*********** PLEASE DELETE IMMEDIATELY AFTER REVIEW. ***********"
S AMHC=0 ;put message into new global with header
S H=$$HRN^AUPNPAT(AMHPAT,DUZ(2),2)
S:H="" H="<?????>"
S (%,C)=0 F S %=$O(^AUPNPAT(AMHPAT,41,%)) Q:%'=+%!(C>4) I %'=DUZ(2) S H=H_" "_$$HRN^AUPNPAT(AMHPAT,%,2) S C=C+1
S AMHC=1,^TMP("AMHMSG",$J,AMHC)="NAME: "_$P(^DPT(AMHPAT,0),U)_" "_H
S AMHC=AMHC+1,^TMP("AMHMSG",$J,AMHC)="SEX: "_$$VAL^XBDIQ1(2,AMHPAT,.02)_" DOB: "_$$VAL^XBDIQ1(2,AMHPAT,.03)_" RESIDENCE: "_$$VAL^XBDIQ1(9000001,AMHPAT,1118),AMHC=AMHC+1,^TMP("AMHMSG",$J,AMHC)=""
S X=0 F S X=$O(^AMHREC(AMHR,98,X)) Q:X'=+X S AMHC=AMHC+1,^TMP("AMHMSG",$J,AMHC)=^AMHREC(AMHR,98,X,0)
S AMHC=AMHC+1,^TMP("AMHMSG",$J,AMHC)="",X=0 F S X=$O(^TMP("AMHS",$J,"DCS",X)) Q:X'=+X S AMHC=AMHC+1,^TMP("AMHMSG",$J,AMHC)=^TMP("AMHS",$J,"DCS",X)
S XMSUB="Patient Encounter in Behavioral Health - CONFIDENTIAL"
S XMDUZ=$P(^VA(200,DUZ,0),U)
D XMZ^XMA2
S AMHXMZ=XMZ
S XMDUZ=$P(^VA(200,DUZ,0),U)
S XMTEXT="^TMP(""AMHMSG"",$J,"
W !,"Sending Mailman message to distribution list"
D ENL^XMD
S XMZ=AMHXMZ
S DA=XMZ,DIE=3.9,DR="1.95///Y;1.96///Y" D ^DIE K DIE,DR,DA
D ENT1^XMD
KILL ^TMP("AMHS",$J)
;set multiple imn record file
;kill vars
K XMZ,DA,DIE,DR,XMDUZ,AMHXMZ,AMHEFT,XMSUB,AMHX,XMY
W !,"Message Sent "
D PAUSE
Q
;
PRIMPROB(R) ;
I '$G(R) Q ""
NEW X S X=$O(^AMHRPRO("AD",R,0))
I 'X Q ""
Q $P(^AMHRPRO(X,0),U)
CDST ;EP
;create record in CDMIS Staging file
I $P($G(^AMHREC(AMHR,91)),U)'="Y" Q
I $D(^AMHRCDST("B",AMHR)) W !!,"There is already a initial/discharge entry for this visit.",!,"Editing existing data...." H 2 S AMHCDR=$O(^AMHRCDST("B",AMHR,0)) G CDST1
W !!,"Creating Initial Chemical Dependency data record..." H 1
D ^XBFMK S DIC="^AMHRCDST(",DIC(0)="AEMQ",DIADD=1,DLAYGO=9002011.06,X=AMHR K DD,DO D FILE^DICN K DIADD,DLAYGO,DD,DO,DIC
I Y=-1 W !!,$C(7),$C(7),"Notify supervisor....error in creating Initial Staging record.." D PAUSE Q
S AMHCDR=+Y
CDST1 K DIADD,DLAYGO D ^XBFMK
S DA=AMHCDR,DIE="^AMHRCDST(",DR=".02////"_AMHPAT_";.03////"_$$PRIMPROB(AMHR)_";.04////"_DT_";.05////"_DUZ_";.19////"_$P(^AMHREC(AMHR,0),U,32) D ^DIE
I $D(Y) W !!,$C(7),$C(7),"Notify supervisor....error in creating Initial Staging record.." D PAUSE Q
S DA=AMHCDR,DDSFILE=9002011.06,DR="[AMH ENTER/EDIT STAGING TOOL]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
Q
CDSTDEL ;
W !!,"There is a staging tool entry for this visit and this visit",!,"is not an INITIAL, REOPEN, TRAN/DISC/CLOSE or FOLLOW UP.",!
S DIR(0)="Y",DIR("A")="Do you want to delete this staging tool entry",DIR("B")="N" KILL DA D ^DIR KILL DIR
Q:$D(DIRUT)
Q:'Y
S DA=$O(^AMHRCDST("B",AMHR,0)),DIK="^AMHRCDST(" D ^DIK
Q
OTHER ;EP - collect other data if patient related
I $G(AMHZDO) G OTHERX
S AMHXX=$$ESIG^AMHESIG(AMHR)
I '$G(AMHXX) D I $P(AMHXX,U,4),AMHANS G OTHER
.W !!,$P(AMHXX,U,3),!
.I '$P(AMHXX,U,4) D PAUSE Q
.S DIR(0)="Y",DIR("A")="Do you wish to enter a SOAP/Progress Note",DIR("B")="Y" KILL DA D ^DIR KILL DIR
.Q:$D(DIRUT)
.S AMHANS=Y Q:'Y
.S DIE="^AMHREC(",DR=3101,DA=AMHR D ^DIE K DA,DIE,DR
I AMHXX D ESIGGFI^AMHESIG(AMHR)
OTHERX D FULL^VALM1
W @IOF,!!!?20,"******* OTHER INFORMATION *******",!!
D RMENU
S DIR("B")=10,DIR(0)="NO^1:10",DIR("A")="Choose one of the above" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=10
S AMHSELE=+Y D OTHER1
G OTHER
OTHER1 ;
I '$G(AMHPAT) W $C(7),"You MUST Identify the Patient first!!" S AMHPAT="" D GETPAT Q:'AMHPAT
W !
D @AMHSELE
Q
GETPROV ;EP - 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",DLAYGO=9002011.02,DIADD=1 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
GETPAT ;EP
D ^XBFMK
S AMHC=0
GETPAT1 I $G(AMHDET)="S" W:$D(IOF)&(AMHC=0) @IOF W !!!!!!!!?20,"TYPE THE PATIENT'S HRN, NAME, SSN OR DOB" S DIC("A")=" Patient: "
S AMHPAT=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 K AMHC Q
S AMHPAT=+Y
S X=AMHPAT D ^AMHPEDIT I '$D(X) S AMHC=AMHC+1 G GETPAT1
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
W !?25,"Ok" S %=1 D YN^DICN I %'=1 S AMHPAT="" K AMHC Q
K AMHC
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
W:$G(AMHACTN)'=1 !
W !,"Update, add or append any of the following data"
W !!,?5,"1). Update any of the following information:"
W !,?10,"Designated Providers, Patient Flag"
W !,?5,"2). Patient Case Open/Admit/Closed Data"
W !,?5,"3). Personal History Information"
W !?5,"4). Appointments (Scheduling System)"
W !?5,"5). Treatment Plan Update"
W !?5,"6). Print an Encounter Form"
W !?5,"7). Add/Update/Print Intake Document"
W !?5,"8). Add/Update Suicide Forms"
W !?5,"9). Problem List Update"
W !,?5,"10). None of the Above (Quit)"
Q
W:$D(IOF) @IOF
W !,AMHDASH
W !,"Date of Service: ",$$FTIME^VALM1(AMHDATE),!,AMHDASH
Q
PCCLINK ;EP -PCC LINK
D PCCLINK^AMHLE2
Q
;
EXIT ;CLEAN UP AND EXIT
;D TERM^VALM0
S VALMBCK="R"
;D GATHER^AMHLEL
;S VALMCNT=AMHRCNT
;D HDR^AMHLE
K AMHV,AMHF,AMHDR,AMHR,AMHQUIT,AMHRDEL,AMHV,AMHVDLT,AMHNAME,AMHPTSV,AMHX,AMHERROR,AMHR0,APCDPKG,APCDV,AMHNONE,AMHOKAY,AMHOTH,AMHSHIGH
K X,Y,Z,I
Q
1 ;
I '$D(^AMHPATR(AMHPAT)) S DIC="^AMHPATR(",DIC(0)="L",DLAYGO=9002011.55,X="`"_AMHPAT D ^DIC I Y=-1 D ^XBFMK W !!,"FAILED TO ADD PATIENT TO BH PATIENT DATA FILE" Q
S DA=AMHPAT,DDSFILE=9002011.55,DR="[AMH PATIENT RELATED DATA]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
Q
2 ;
D EP^AMHLCD
D FULL^VALM1
Q
3 ;
D PHX^AMHLE3
Q
6 ;print encounter form
I $G(AMHR),$G(AMHPAT) S %=AMHR,%1=AMHPAT D EN^XBNEW("PEF^AMHLE3","%;%1") Q
D ^AMHLEFP
;clean up
Q
4 ;scheduling system
D APPT^AMHVRL2(AMHPAT)
;D RESET^AMHVRL
Q
5 ;treatment Plan
D EP1^AMHLETP(AMHPAT)
Q
7 ;intake
I $G(AMHR) D EP1^AMHLEIV(AMHR,AMHPAT) Q
Q
8 ;suicide forms
I $G(AMHR) D EN^AMHLESF
Q
9 ;
I '$G(AMHR) W !!,"Visit not identified." Q
D START^AMHBPL(AMHR)
Q
PL ;EP - called from PDE Problem list protocol
D FULL^VALM1
W !,"Problem List updates must be attached to a visit. If you are updating the "
W !,"Problem List in the context of a patient visit select the appropriate existing"
W !,"visit and then update the Problem List. If you are updating the Problem List "
W !,"outside of the context of a patient visit, first create a chart review visit "
W !,"and then update the Problem List."
D ^AMHLEIN
S AMHPATCE=1
D GETDATE^AMHLE
I $G(AMHDATE)="" D EXIT Q
S AMHPAT=DFN,AMHLOC=""
D EN^AMHRLKUP
I '$G(AMHR) W !!,"No visits to select on that date." D PAUSE,EXIT Q
D START^AMHBPL(AMHR)
D EXIT
Q
AMHLEP2 ; IHS/CMI/LAB - ADD NEW BH ACTIVITY RECORDS 06 Nov 2009 9:21 AM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,2,8**;JUN 02, 2010;Build 7
+2 ;
ADD ;EP
+1 SET APCDOVRR=""
+2 DO FULL^VALM1
+3 IF '$DATA(AMHDATE)
WRITE !!,"Date not entered."
HANG 5
QUIT
+4 IF '$GET(AMHPAT)
WRITE !!,"No patient identified."
HANG 5
QUIT
+5 SET AMHADPTV=1
+6 SET AMHQUIT=0
SET AMHACTN=1
+7 WRITE !,"Creating new record..."
KILL DD,D0,DO,DINUM,DIC,DA,DR
+8 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"
+9 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+10 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health Record is NOT complete!! Deleting Record.",!
DO PAUSE
QUIT
+11 ;update multiple of user last update/date edited
+12 SET AMHR=+Y
+13 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
+14 SET DA=AMHR
SET DIE="^AMHREC("
+15 SET DR=".02///"_AMHPTYPE_$SELECT($$GETLOC^AMHLEIN(DUZ(2),AMHPTYPE):";.04///`"_$$GETLOC^AMHLEIN(DUZ(2),AMHPTYPE),1:"")_$SELECT($$GETCOMM^AMHLEIN(DUZ(2),AMHPTYPE):";.05///`"_$$GETCOMM^AMHLEIN(DUZ(2),AMHPTYPE),1:"")_";1117////"_$$HL^AMHUTIL2(AMHPT
YPE)
+16 ;IHS/CMI/LAB - PATCH 8 Hosp location
+17 SET DR=DR_$SELECT($$GETCLN^AMHLEIN(DUZ(2),AMHPTYPE):";.25///`"_$$GETCLN^AMHLEIN(DUZ(2),AMHPTYPE),1:"")
+18 SET DR=DR_";.11///"_$$GETAWI^AMHLEIN(DUZ(2))_$SELECT($$GETTOC^AMHLEIN(DUZ(2)):";.07///`"_$$GETTOC^AMHLEIN(DUZ(2)),1:"")
+19 DO ^DIE
IF $DATA(Y)
WRITE !!,"Error updating record......"
HANG 5
+20 KILL DR,DA,DIE
+21 DO GETPROV
IF '$$PPINT^AMHUTIL(AMHR)
WRITE !,"No PRIMARY PROVIDER entered!! - Required element"
DO DEL
DO EXIT
QUIT
+22 ;I AMHVTYPE="S"!(AMHVTYPE="U") D SAN^AMHLEP3 G CHK
+23 ;I AMHVTYPE="I"!(AMHVTYPE="P") D INTAKE^AMHLEP4,EXIT Q
+24 ;
ADD1 ;
+1 IF AMHVTYPE="R"
SET DA=AMHR
SET DDSFILE=9002011
SET DR="[AMH ADD RECORD]"
DO ^DDS
+2 ;I AMHVTYPE="B" S AMHVTYPE="R",DA=AMHR,DDSFILE=9002011,DR="[AMHB ADD RECORD]" D ^DDS
+3 ;I AMHVTYPE="N" S DA=AMHR,DDSFILE=9002011,DR="[AMHNS ADD RECORD]" D ^DDS
+4 ;I AMHVTYPE="C" S DA=AMHR,DDSFILE=9002011,DR="[AMH ADD CASE TRACKING REC]" D ^DDS
+5 ;I AMHVTYPE="A" S DA=AMHR,DDSFILE=9002011,DR="[AMHASA ADD RECORD]" D ^DDS
+6 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+7 ;STUFF 1117 PER .02 OF RECORD
+8 ;IHS/CMI/LAB - PATCH 8 Hosp location
SET DA=AMHR
SET DIE="^AMHREC("
SET DR="1117////"_$$HL^AMHUTIL2($$VALI^XBDIQ1(9002011,AMHR,.02))
DO ^DIE
KILL DA,DR,DIE
+9 ;CHECK RECORD
+10 ;I AMHVTYPE="N" D GENPOV^AMHLENS
CHK ; S AMHOKAY=0 D RECCHECK^AMHLE2 I AMHOKAY W !!,"Incomplete record!! Deleting record!!" D DEL,EXIT Q
+1 DO CHECK^AMHLEA
+2 IF AMHZDEL
DO EXIT
QUIT
+3 IF AMHZED
GOTO ADD1
+4 ;I $G(AMHERROR) W !!,$C(7),$C(7),"PLEASE EDIT THIS RECORD!!",!!
+5 ;I $P(^AMHREC(AMHR,0),U,2)="C"!($P($G(^AMHREC(AMHR,91)),U)="Y") D CDST
+6 IF AMHVTYPE="R"
DO REGULAR
+7 ;I AMHVTYPE="S" D REGULAR
+8 ;I AMHVTYPE="C" D REGULAR
+9 ;I AMHVTYPE="N" D REGULAR
+10 ;I AMHVTYPE="A" D REGULAR
+11 IF $GET(AMHNAVR)
QUIT
+12 ;D CLEAR^VALM1
+13 DO SUIC^AMHLEA
DO OTHER
+14 DO PCCLINK
+15 DO EXIT
+16 QUIT
+17 ;
REGULAR ;EP
+1 ;D TERM^VALM0,FULL^VALM1
+2 ;no access
IF '$DATA(^AMHSITE(DUZ(2),13,"B",DUZ))
QUIT
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to share this visit information with other providers"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 IF 'Y
QUIT
+6 KILL XMY
DO GETLIST
+7 IF '$DATA(XMY)
GOTO REGULAR
+8 WRITE !!,"Message will be sent to:"
SET X=0
FOR
SET X=$ORDER(XMY(X))
IF X'=+X
QUIT
WRITE ?28,$PIECE(^VA(200,X,0),U),!
+9 SET DIR(0)="Y"
SET DIR("A")="Do you want to attach a note to this mail message"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
GOTO REGULAR
+11 WRITE !,"Enter the text of your note.",!
+12 IF Y=1
Begin DoDot:1
+13 LOCK +^AMHREC(AMHR):60
SET DIE="^AMHREC("
SET DA=AMHR
SET DR="9800"
DO ^DIE
LOCK -^AMHREC(AMHR)
End DoDot:1
DO ^XBFMK
+14 SET DIR(0)="Y"
SET DIR("A")="Ready to send mail message"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+15 IF $DATA(DIRUT)
KILL XMY,XMTEXT,XMDUZ,XMZ,XMSUB,AMHEFT
QUIT
+16 IF 'Y
KILL XMY,XMTEXT,XMDUZ,XMZ,XMSUB
GOTO REGULAR
FS ;
+1 SET AMHEFT=""
+2 SET DIR(0)="SB^F:FULL;S:SUPPRESSED"
SET DIR("A")="Send Full or Suppressed Form"
SET DIR("B")="S"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
KILL XMY,XMTEXT,XMDUZ,XMZ,XMSUB,AMHEFT
QUIT
+4 SET AMHEFT=Y
+5 DO MAILMSG
+6 QUIT
GETLIST ;
+1 KILL XMY
GETLIST1 ;
+1 KILL DIC,DR,DD,D0,DO
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("A")="Send to: "
DO ^DIC
+2 IF Y=-1
QUIT
+3 SET XMY(+Y)=""
+4 GOTO GETLIST1
+5 ;
CASE(P,R,T) ;return 1 if case already opened
+1 SET U="^"
+2 IF '$GET(P)
QUIT ""
+3 IF '$GET(R)
QUIT ""
+4 IF $GET(T)=""
QUIT ""
+5 NEW X,H
SET (X,H)=0
FOR
SET X=$ORDER(^AMHPCASE("AA",P,9999999-$PIECE($PIECE(^AMHREC(R,0),U),"."),X))
IF X'=+X
QUIT
IF $PIECE(^AMHPCASE(X,0),U,2)=T
IF $PIECE(^AMHPCASE(X,0),U,8)=$$PPINT^AMHUTIL(R)
SET H=1
+6 QUIT H
MAILMSG ;
+1 KILL ^TMP("AMHS",$JOB),^TMP("AMHMSG",$JOB)
+2 DO ^XBFMK
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(XMY(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 IF '$DATA(^AMHREC(AMHR,52,"B",AMHX))
SET DA=AMHR
SET DIE="^AMHREC("
SET DR="5200///`"_AMHX
DO ^DIE
DO ^XBFMK
End DoDot:1
+5 DO EP2^AMHLEFP2(AMHR,1)
+6 SET (C,X)=0
FOR
SET X=$ORDER(^TMP("AMHS",$JOB,"DCS",X))
IF X'=+X
QUIT
SET C=C+1
+7 SET C=C+1
SET ^TMP("AMHS",$JOB,"DCS",C)="THIS FORM CONTAINS CONFIDENTIAL PATIENT INFORMATION. UNAUTHORIZED"
+8 SET C=C+1
SET ^TMP("AMHS",$JOB,"DCS",C)="REPRODUCTION OF THIS FORM MAY VIOLATE PRIVACY ACT STATUTES AND BE"
+9 SET C=C+1
SET ^TMP("AMHS",$JOB,"DCS",C)="PUNISHABLE BY LAW."
+10 SET C=C+1
SET ^TMP("AMHS",$JOB,"DCS",C)="*********** PLEASE DELETE IMMEDIATELY AFTER REVIEW. ***********"
+11 ;put message into new global with header
SET AMHC=0
+12 SET H=$$HRN^AUPNPAT(AMHPAT,DUZ(2),2)
+13 IF H=""
SET H="<?????>"
+14 SET (%,C)=0
FOR
SET %=$ORDER(^AUPNPAT(AMHPAT,41,%))
IF %'=+%!(C>4)
QUIT
IF %'=DUZ(2)
SET H=H_" "_$$HRN^AUPNPAT(AMHPAT,%,2)
SET C=C+1
+15 SET AMHC=1
SET ^TMP("AMHMSG",$JOB,AMHC)="NAME: "_$PIECE(^DPT(AMHPAT,0),U)_" "_H
+16 SET AMHC=AMHC+1
SET ^TMP("AMHMSG",$JOB,AMHC)="SEX: "_$$VAL^XBDIQ1(2,AMHPAT,.02)_" DOB: "_$$VAL^XBDIQ1(2,AMHPAT,.03)_" RESIDENCE: "_$$VAL^XBDIQ1(9000001,AMHPAT,1118)
SET AMHC=AMHC+1
SET ^TMP("AMHMSG",$JOB,AMHC)=""
+17 SET X=0
FOR
SET X=$ORDER(^AMHREC(AMHR,98,X))
IF X'=+X
QUIT
SET AMHC=AMHC+1
SET ^TMP("AMHMSG",$JOB,AMHC)=^AMHREC(AMHR,98,X,0)
+18 SET AMHC=AMHC+1
SET ^TMP("AMHMSG",$JOB,AMHC)=""
SET X=0
FOR
SET X=$ORDER(^TMP("AMHS",$JOB,"DCS",X))
IF X'=+X
QUIT
SET AMHC=AMHC+1
SET ^TMP("AMHMSG",$JOB,AMHC)=^TMP("AMHS",$JOB,"DCS",X)
+19 SET XMSUB="Patient Encounter in Behavioral Health - CONFIDENTIAL"
+20 SET XMDUZ=$PIECE(^VA(200,DUZ,0),U)
+21 DO XMZ^XMA2
+22 SET AMHXMZ=XMZ
+23 SET XMDUZ=$PIECE(^VA(200,DUZ,0),U)
+24 SET XMTEXT="^TMP(""AMHMSG"",$J,"
+25 WRITE !,"Sending Mailman message to distribution list"
+26 DO ENL^XMD
+27 SET XMZ=AMHXMZ
+28 SET DA=XMZ
SET DIE=3.9
SET DR="1.95///Y;1.96///Y"
DO ^DIE
KILL DIE,DR,DA
+29 DO ENT1^XMD
+30 KILL ^TMP("AMHS",$JOB)
+31 ;set multiple imn record file
+32 ;kill vars
+33 KILL XMZ,DA,DIE,DR,XMDUZ,AMHXMZ,AMHEFT,XMSUB,AMHX,XMY
+34 WRITE !,"Message Sent "
+35 DO PAUSE
+36 QUIT
+37 ;
PRIMPROB(R) ;
+1 IF '$GET(R)
QUIT ""
+2 NEW X
SET X=$ORDER(^AMHRPRO("AD",R,0))
+3 IF 'X
QUIT ""
+4 QUIT $PIECE(^AMHRPRO(X,0),U)
CDST ;EP
+1 ;create record in CDMIS Staging file
+2 IF $PIECE($GET(^AMHREC(AMHR,91)),U)'="Y"
QUIT
+3 IF $DATA(^AMHRCDST("B",AMHR))
WRITE !!,"There is already a initial/discharge entry for this visit.",!,"Editing existing data...."
HANG 2
SET AMHCDR=$ORDER(^AMHRCDST("B",AMHR,0))
GOTO CDST1
+4 WRITE !!,"Creating Initial Chemical Dependency data record..."
HANG 1
+5 DO ^XBFMK
SET DIC="^AMHRCDST("
SET DIC(0)="AEMQ"
SET DIADD=1
SET DLAYGO=9002011.06
SET X=AMHR
KILL DD,DO
DO FILE^DICN
KILL DIADD,DLAYGO,DD,DO,DIC
+6 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Notify supervisor....error in creating Initial Staging record.."
DO PAUSE
QUIT
+7 SET AMHCDR=+Y
CDST1 KILL DIADD,DLAYGO
DO ^XBFMK
+1 SET DA=AMHCDR
SET DIE="^AMHRCDST("
SET DR=".02////"_AMHPAT_";.03////"_$$PRIMPROB(AMHR)_";.04////"_DT_";.05////"_DUZ_";.19////"_$PIECE(^AMHREC(AMHR,0),U,32)
DO ^DIE
+2 IF $DATA(Y)
WRITE !!,$CHAR(7),$CHAR(7),"Notify supervisor....error in creating Initial Staging record.."
DO PAUSE
QUIT
+3 SET DA=AMHCDR
SET DDSFILE=9002011.06
SET DR="[AMH ENTER/EDIT STAGING TOOL]"
DO ^DDS
+4 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+5 QUIT
CDSTDEL ;
+1 WRITE !!,"There is a staging tool entry for this visit and this visit",!,"is not an INITIAL, REOPEN, TRAN/DISC/CLOSE or FOLLOW UP.",!
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to delete this staging tool entry"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 IF 'Y
QUIT
+5 SET DA=$ORDER(^AMHRCDST("B",AMHR,0))
SET DIK="^AMHRCDST("
DO ^DIK
+6 QUIT
OTHER ;EP - collect other data if patient related
+1 IF $GET(AMHZDO)
GOTO OTHERX
+2 SET AMHXX=$$ESIG^AMHESIG(AMHR)
+3 IF '$GET(AMHXX)
Begin DoDot:1
+4 WRITE !!,$PIECE(AMHXX,U,3),!
+5 IF '$PIECE(AMHXX,U,4)
DO PAUSE
QUIT
+6 SET DIR(0)="Y"
SET DIR("A")="Do you wish to enter a SOAP/Progress Note"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
QUIT
+8 SET AMHANS=Y
IF 'Y
QUIT
+9 SET DIE="^AMHREC("
SET DR=3101
SET DA=AMHR
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
IF $PIECE(AMHXX,U,4)
IF AMHANS
GOTO OTHER
+10 IF AMHXX
DO ESIGGFI^AMHESIG(AMHR)
OTHERX DO FULL^VALM1
+1 WRITE @IOF,!!!?20,"******* OTHER INFORMATION *******",!!
+2 DO RMENU
+3 SET DIR("B")=10
SET DIR(0)="NO^1:10"
SET DIR("A")="Choose one of the above"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DIRUT)
QUIT
+5 IF Y=10
QUIT
+6 SET AMHSELE=+Y
DO OTHER1
+7 GOTO OTHER
OTHER1 ;
+1 IF '$GET(AMHPAT)
WRITE $CHAR(7),"You MUST Identify the Patient first!!"
SET AMHPAT=""
DO GETPAT
IF 'AMHPAT
QUIT
+2 WRITE !
+3 DO @AMHSELE
+4 QUIT
GETPROV ;EP - 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 DLAYGO=9002011.02
SET DIADD=1
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
GETPAT ;EP
+1 DO ^XBFMK
+2 SET AMHC=0
GETPAT1 IF $GET(AMHDET)="S"
IF $DATA(IOF)&(AMHC=0)
WRITE @IOF
WRITE !!!!!!!!?20,"TYPE THE PATIENT'S HRN, NAME, SSN OR DOB"
SET DIC("A")=" Patient: "
+1 SET AMHPAT=""
+2 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+3 IF Y<0
KILL AMHC
QUIT
+4 SET AMHPAT=+Y
+5 SET X=AMHPAT
DO ^AMHPEDIT
IF '$DATA(X)
SET AMHC=AMHC+1
GOTO GETPAT1
+6 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!!
HANG 2
+7 WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
SET AMHPAT=""
KILL AMHC
QUIT
+8 KILL AMHC
+9 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
+1 IF $GET(AMHACTN)'=1
WRITE !
+2 WRITE !,"Update, add or append any of the following data"
+3 WRITE !!,?5,"1). Update any of the following information:"
+4 WRITE !,?10,"Designated Providers, Patient Flag"
+5 WRITE !,?5,"2). Patient Case Open/Admit/Closed Data"
+6 WRITE !,?5,"3). Personal History Information"
+7 WRITE !?5,"4). Appointments (Scheduling System)"
+8 WRITE !?5,"5). Treatment Plan Update"
+9 WRITE !?5,"6). Print an Encounter Form"
+10 WRITE !?5,"7). Add/Update/Print Intake Document"
+11 WRITE !?5,"8). Add/Update Suicide Forms"
+12 WRITE !?5,"9). Problem List Update"
+13 WRITE !,?5,"10). None of the Above (Quit)"
+14 QUIT
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,AMHDASH
+3 WRITE !,"Date of Service: ",$$FTIME^VALM1(AMHDATE),!,AMHDASH
+4 QUIT
PCCLINK ;EP -PCC LINK
+1 DO PCCLINK^AMHLE2
+2 QUIT
+3 ;
EXIT ;CLEAN UP AND EXIT
+1 ;D TERM^VALM0
+2 SET VALMBCK="R"
+3 ;D GATHER^AMHLEL
+4 ;S VALMCNT=AMHRCNT
+5 ;D HDR^AMHLE
+6 KILL AMHV,AMHF,AMHDR,AMHR,AMHQUIT,AMHRDEL,AMHV,AMHVDLT,AMHNAME,AMHPTSV,AMHX,AMHERROR,AMHR0,APCDPKG,APCDV,AMHNONE,AMHOKAY,AMHOTH,AMHSHIGH
+7 KILL X,Y,Z,I
+8 QUIT
1 ;
+1 IF '$DATA(^AMHPATR(AMHPAT))
SET DIC="^AMHPATR("
SET DIC(0)="L"
SET DLAYGO=9002011.55
SET X="`"_AMHPAT
DO ^DIC
IF Y=-1
DO ^XBFMK
WRITE !!,"FAILED TO ADD PATIENT TO BH PATIENT DATA FILE"
QUIT
+2 SET DA=AMHPAT
SET DDSFILE=9002011.55
SET DR="[AMH PATIENT RELATED DATA]"
DO ^DDS
+3 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+4 QUIT
2 ;
+1 DO EP^AMHLCD
+2 DO FULL^VALM1
+3 QUIT
3 ;
+1 DO PHX^AMHLE3
+2 QUIT
6 ;print encounter form
+1 IF $GET(AMHR)
IF $GET(AMHPAT)
SET %=AMHR
SET %1=AMHPAT
DO EN^XBNEW("PEF^AMHLE3","%;%1")
QUIT
+2 DO ^AMHLEFP
+3 ;clean up
+4 QUIT
4 ;scheduling system
+1 DO APPT^AMHVRL2(AMHPAT)
+2 ;D RESET^AMHVRL
+3 QUIT
5 ;treatment Plan
+1 DO EP1^AMHLETP(AMHPAT)
+2 QUIT
7 ;intake
+1 IF $GET(AMHR)
DO EP1^AMHLEIV(AMHR,AMHPAT)
QUIT
+2 QUIT
8 ;suicide forms
+1 IF $GET(AMHR)
DO EN^AMHLESF
+2 QUIT
9 ;
+1 IF '$GET(AMHR)
WRITE !!,"Visit not identified."
QUIT
+2 DO START^AMHBPL(AMHR)
+3 QUIT
PL ;EP - called from PDE Problem list protocol
+1 DO FULL^VALM1
+2 WRITE !,"Problem List updates must be attached to a visit. If you are updating the "
+3 WRITE !,"Problem List in the context of a patient visit select the appropriate existing"
+4 WRITE !,"visit and then update the Problem List. If you are updating the Problem List "
+5 WRITE !,"outside of the context of a patient visit, first create a chart review visit "
+6 WRITE !,"and then update the Problem List."
+7 DO ^AMHLEIN
+8 SET AMHPATCE=1
+9 DO GETDATE^AMHLE
+10 IF $GET(AMHDATE)=""
DO EXIT
QUIT
+11 SET AMHPAT=DFN
SET AMHLOC=""
+12 DO EN^AMHRLKUP
+13 IF '$GET(AMHR)
WRITE !!,"No visits to select on that date."
DO PAUSE
DO EXIT
QUIT
+14 DO START^AMHBPL(AMHR)
+15 DO EXIT
+16 QUIT
