Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHLEP2

AMHLEP2.m

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