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

AMHEGS.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1. START ;
  1.  W:$D(IOF) @IOF
  1.  D DONE
  1.  ;
  1.  D EN,FULL^VALM1
  1.  D DONE
  1.  Q
  1. DONE ;
  1.  K AMHX,AMHC,AMHLINE,AMHY,AMHG,AMHR,DFN
  1.  D ^XBFMK
  1.  D KILL^AUPNPAT
  1.  Q
  1. EN ;
  1.  K ^TMP($J,"AMHEGS")
  1.  D GATHER
  1.  D EN^VALM("AMH GROUP PTS")
  1.  D CLEAR^VALM1
  1.  Q
  1. GATHER ;
  1.  K ^TMP($J,"AMHEGS")
  1.  S (AMHC,AMHX,AMHLINE)=0
  1.  F  S AMHX=$O(^AMHGROUP(AMHNG,51,AMHX)) Q:AMHX'=+AMHX  D
  1.  .S DFN=$P(^AMHGROUP(AMHNG,51,AMHX,0),U)
  1.  .S AMHY="",AMHLINE=AMHLINE+1
  1.  .S AMHY=AMHLINE_") "
  1.  .S $E(AMHY,6)=$P(^DPT(DFN,0),U)
  1.  .S $E(AMHY,40)=$P(^DPT(DFN,0),U,2)
  1.  .S $E(AMHY,43)=$$AGE^AUPNPAT(DFN,DT)
  1.  .S $E(AMHY,48)=$$DATE($P(^DPT(DFN,0),U,3))
  1.  .S $E(AMHY,60)=$$HRN^AUPNPAT(DFN,DUZ(2))
  1.  .S Y=$$REC(DFN,AMHNG) S $E(AMHY,70)=$S(Y:"yes",1:"no")
  1.  .S ^TMP($J,"AMHEGS",AMHLINE,0)=AMHY,^TMP($J,"AMHEGS","IDX",AMHLINE,AMHLINE)=AMHX
  1.  Q
  1. REC(P,G) ;does this patient have a record in MHSS for this group
  1.  NEW X,Y,Z
  1.  S X=0,Y=0 F  S X=$O(^AMHGROUP(G,61,X)) Q:X'=+X!(Y)  D
  1.  .S Z=$P(^AMHGROUP(G,61,X,0),U)
  1.  .Q:'$D(^AMHREC(Z,0))
  1.  .I $P(^AMHREC(Z,0),U,8)=P S Y=Z
  1.  .Q
  1.  Q Y
  1. DATE(D) ;
  1.  I $G(D)="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. HDR ; -- header code
  1.  S VALMHDR(1)="Group Entry"
  1.  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"
  1.  S VALMHDR(2)=X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  D GATHER
  1.  S VALMCNT=AMHLINE
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1. EDITREC ;
  1.  D FULL^VALM1 K DIR
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." D EXIT Q
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
  1.  S AMHX=0 S AMHX=^TMP($J,"AMHEGS","IDX",R,R)
  1.  I '$D(^AMHGROUP(AMHNG,51,AMHX,0)) W !,"Not a valid GROUP." K AMHRDEL,R,AMHG,R1 D PAUSE D EXIT Q
  1.  S DFN=$P(^AMHGROUP(AMHNG,51,AMHX,0),U)
  1.  S AMHR=$$REC(DFN,AMHNG)
  1.  I 'AMHR D  D EXIT Q
  1.  .W !!,"There is no visit on file for ",$P(^DPT(DFN,0),U)," for this group activity."
  1.  .S DIR(0)="Y",DIR("A")="Do you want to add a visit",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) D PAUSE Q
  1.  .I 'Y D PAUSE Q
  1.  .S AMHNGX=AMHX D ADDREC1^AMHEGR
  1.  .Q
  1.  I '$D(^AMHREC(AMHR,0)) W !,"Not a valid BH RECORD." K AMHRDEL,AMHR D PAUSE^AMHLEA D EXIT Q
  1.  D FULL^VALM1
  1.  S AMHPAT=DFN
  1. DGSECE ;
  1.  K AMHRESU
  1.  D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
  1.  I '$G(AMHRESU(1)) G EDITREC1
  1.  I $G(AMHRESU(1))=3!($G(AMHRESU(1))=4)!($G(AMHRESU(1))=5) D DISPDG^AMHLE,PAUSE^AMHLEA,EXIT Q
  1.  D DISPDG^AMHLE
  1.  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
  1.  I 'Y D EXIT Q
  1.  K AMHRESU
  1.  D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
  1. EDITREC1 ;
  1.  S AMHVTYPE=$P(^AMHREC(AMHR,0),U,33)
  1.  I AMHVTYPE="" S AMHVTYPE="R"
  1.  S AMHDATE=$P(^AMHREC(AMHR,0),U)
  1.  S AMHPTYPE=$P(^AMHREC(AMHR,0),U,2)
  1.  S AMHACTN=2
  1.  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
  1.  I '$P($G(^AMHREC(AMHR,11)),U,12) S DR="[AMH EDIT RECORD]",DA=AMHR,DDSFILE=9002011 D ^DDS
  1.  I $P($G(^AMHREC(AMHR,11)),U,12) S DR="[AMHSV EDIT RECORD]",DA=AMHR,DDSFILE=9002011 D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ** NOTIFY PROGRAMMER **" S AMHQUIT=1 K DIMSG Q
  1.  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
  1.  S AMHERROR=0 D RECCHECK^AMHLE2 I AMHERROR D PAUSE
  1.  D PCCLINK^AMHLEA
  1.  D EXIT
  1.  Q
  1. ADDPT ;
  1.  ;add a new patient to the group
  1.  ;update 51 multiple
  1.  D FULL^VALM1
  1.  ;get patient
  1.  D ^XBFMK
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC
  1.  I Y=-1 W !!,"No patient selected." D PAUSE,EXIT Q
  1.  S (AMHPAT,DFN)=+Y
  1.  I AMHPAT,'$$ALLOWP^AMHUTIL(DUZ,AMHPAT) D NALLOWP^AMHUTIL D PAUSE G ADDPT
  1.  I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
  1.  D ^XBFMK
  1.  S DA(1)=AMHNG,DIC="^AMHGROUP("_AMHNG_",51,",DIC(0)="AELQ",DIC("P")=$P(^DD(9002011.67,5101,0),U,2)
  1.  D ^DIC
  1.  I Y=-1 W !!,"adding patient to group failed." D PAUSE,EXIT Q
  1.  D ADDREC^AMHEGR
  1.  ;D UPDACT  ;update activity time on all records to new activity time based on new patient added and call pcc link
  1.  D EXIT
  1.  Q
  1. DISP ;EP - called from protocol
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." D EXIT Q
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
  1.  S AMHX=0 S AMHX=^TMP($J,"AMHEGS","IDX",R,R)
  1.  I '$D(^AMHGROUP(AMHNG,51,AMHX,0)) W !,"Not a valid GROUP." K AMHRDEL,R,AMHG,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1.  S DFN=$P(^AMHGROUP(AMHNG,51,AMHX,0),U)
  1.  S AMHR=$$REC(DFN,AMHNG)
  1.  I 'AMHR W !!,"There is no record/visit on file yet for this patient." K AMHR,DFN,AMHG D PAUSE,EXIT Q
  1. DGSECD ;
  1.  I '$P(^AMHREC(AMHR,0),U,8) G DISP9
  1.  S AMHPAT=$P(^AMHREC(AMHR,0),U,8)
  1.  D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
  1.  I '$G(AMHRESU(1)) G DISP9
  1.  I $G(AMHRESU(1))=3!($G(AMHRESU(1))=4)!($G(AMHRESU(1))=5) D DISPDG^AMHLE,PAUSE^AMHLEA,EXIT Q
  1.  D DISPDG^AMHLE
  1.  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
  1.  I 'Y D EXIT Q
  1.  K AMHRESU
  1.  D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
  1. DISP9 ;
  1.  D ^AMHDVD
  1.  D EXIT
  1.  Q
  1. DEL ;EP - called from protocol
  1.  ;add code to not allow delete unless they have the key
  1.  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
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." D EXIT Q
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
  1.  S AMHG=0 S AMHG=^TMP($J,"AMHEGS","IDX",R,R)
  1.  I '$D(^AMHGROUP(AMHNG,51,AMHG,0)) W !,"Not a valid patient." K AMHRDEL,R,AMHG,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1.  S DFN=$P(^AMHGROUP(AMHNG,51,AMHG,0),U)
  1.  S AMHR=$$REC(DFN,AMHNG)
  1.  I 'AMHR W !!,"There is no record/visit on file yet for this patient." K AMHR,DFN,AMHG D PAUSE,EXIT Q
  1.  I '$D(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ)),$P($G(^AMHREC(AMHR,11)),U,12)]"" D  D PAUSE,EXIT Q
  1.  .W !!,$$VAL^XBDIQ1(9002011,AMHR,.01),?20,$$VAL^XBDIQ1(9002011,AMHR,.08)
  1.  .W !!,"The progress note associated with this visit has been signed.  You cannot"
  1.  .W !,"delete this visit.  Please see your supervisor or program manager.",!
  1. DGSECX ;
  1.  I '$P(^AMHREC(AMHR,0),U,8) G DGSECXX
  1.  S AMHPAT=$P(^AMHREC(AMHR,0),U,8)
  1.  D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
  1.  I '$G(AMHRESU(1)) G DGSECXX
  1.  I $G(AMHRESU(1))=3!($G(AMHRESU(1))=4)!($G(AMHRESU(1))=5) D DISPDG^AMHLE,PAUSE^AMHLEA,EXIT Q
  1.  D DISPDG^AMHLE
  1.  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
  1.  I 'Y D EXIT Q
  1.  K AMHRESU
  1.  D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
  1. DGSECXX ;
  1.  S AMHACTN=4
  1.  D EN^AMHRDSP
  1.  W !
  1.  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
  1.  I $D(DIRUT) D PAUSE,EXIT Q
  1.  I 'Y D EXIT Q
  1.  ;D ^AMHLEIN
  1.  S AMHPAT=DFN
  1.  D DEL^AMHLEA
  1.  D PCCLINK^AMHLEA
  1.  ;D UPDACT
  1.  D EXIT
  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. EXIT ; -- exit code
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D GATHER
  1.  S VALMCNT=AMHLINE
  1.  D HDR
  1.  K X,Y,Z,I
  1.  K AMHRESU
  1.  Q
  1. DISPDG ;EP
  1.  W !!,"One of the patients in the group is a sensitive patient:",!
  1.  W !?5,$P(^DPT(AMHPAT,0),U,1),?40,"DOB: ",$$FMTE^XLFDT($$DOB^AUPNPAT(AMHPAT)),?65,"HRN: ",$$HRN^AUPNPAT(AMHPAT,DUZ(2))
  1.  S X=1 F  S X=$O(AMHRESU(X)) Q:X'=+X  W !,$$CTR^AMHLEIN(AMHRESU(X))
  1.  Q
  1. ADDNS ;EP
  1.  S APCDOVRR=""
  1.  D FULL^VALM1
  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(",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:"")
  1.  S DR=DR_$S($P(^AMHGROUP(AMHG,0),U,14):";.25///`"_$P(^AMHGROUP(AMHG,0),U,14),1:"")
  1.  S DR=DR_";.11///"_$$GETAWI^AMHLEIN(DUZ(2))_$S($P(^AMHGROUP(AMHG,0),U,8):";.07///`"_$P(^AMHGROUP(AMHG,0),U,8),1:"")
  1.  D ^DIE I $D(Y) W !!,"Error updating record......" H 5
  1.  K DR,DA,DIE
  1.  D GETPROV^AMHLEP2 I '$$PPINT^AMHUTIL(AMHR) W !,"No PRIMARY PROVIDER entered!! - Required element" D DEL,EXIT Q
  1.  ;
  1. ADD1 ;
  1.  S DA=AMHR,DDSFILE=9002011,DR="[AMH ADD RECORD]" D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
  1.  ;CHECK RECORD
  1. CHK ;  
  1.  D CHECK^AMHLEA
  1.  I AMHZDEL Q
  1.  I AMHZED G ADD1
  1.  I AMHVTYPE="R" D REGULAR^AMHLEP2
  1.  I $G(AMHNAVR) Q
  1.  D SUIC^AMHLEA,OTHER^AMHLEP2
  1.  D PCCLINK^AMHLEP2
  1.  Q