AMHEHR ; IHS/CMI/LAB - ADD NEW MHSS ACTIVITY RECORDS 13 Aug 2007 4:21 PM 03 Jun 2009 10:50 AM ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,2,4,6,8**;JUN 02, 2010;Build 7
;
EN ;PEP - ADD NEW OR EDIT EXISTING BH RECORD CREATED BY EHR
S AMHVSIT=AUPNVSIT
S AMHEHR=1
S AMHR=$O(^AMHREC("AVISIT",AUPNVSIT,0))
I AMHR,$P($G(^AMHREC(AMHR,11)),U,11) Q
I AMHR D EDITREC Q
Q:$P($G(^AMHSITE(DUZ(2),18)),U,5)
S AMHDATE=$P(^AUPNVSIT(AMHVSIT,0),U)
S (AMHPAT,DFN)=$P(^AUPNVSIT(AMHVSIT,0),U,5)
;create record
K DIC S DIC(0)="EL",DIC="^AMHREC(",DLAYGO=9002011,DIADD=1,X=AMHDATE
S DIC("DR")=".03///^S X=DT;.08////"_DFN_";.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21////"_DT_";.16////"_AMHVSIT_";1110////1"
K DD,DO,D0 D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 Q
S AMHR=+Y
D EV
D RFILES
D EXIT
Q
ALERT ;
I $P(^AMHREC(AMHR,0),U,12)=""!($P(^AMHREC(AMHR,0),U,12)=0) D
.;send alert to user only if one never sent
.S (G,X)=0 F S X=$O(^AMHREC(AMHR,97,X)) Q:X'=+X!(G) D
..Q:$P(^AMHREC(AMHR,97,X,0),U,1)'=DT
..Q:$P(^AMHREC(AMHR,97,X,0),U,2)'=DUZ
..S G=1
.Q:G
.NEW %,P
.S %=0 F S %=$O(^AMHRPROV("AD",AMHR,%)) Q:%'=+% S P=$P($G(^AMHRPROV(%,0)),U)
.S XQA(P)=""
.S XQAOPT=""
.S XQAROU=""
.S XQAFLG="D"
.S AMHTEXT(1)=" "
.S AMHTEXT(2)=" "
.S AMHTEXT(3)="This Behavioral Health visit is missing an activity time. The activity"
.S AMHTEXT(4)="time can be entered through EHR or with PCC data entry using the AT"
.S AMHTEXT(5)="mnemonic."
.S XQATEXT="AMHTEXT"
.S XQAMSG="HRN: "_$$HRN^AUPNPAT($P(^AUPNVSIT(AUPNVSIT,0),U,5),DUZ(2))_" Date: "_$$VAL^XBDIQ1(9000010,AUPNVSIT,.01)_" is missing an activity time."
.S XQAID="OR,"_$P(^AMHREC(AMHR,0),U,8)_",46"
.D SETUP^XQALERT
.S (G,X)=0 F S X=$O(^AMHREC(AMHR,97,X)) Q:X'=+X S G=X
.S G=G+1
.S ^AMHREC(AMHR,97,G,0)=DT_"^"_DUZ,^AMHREC(AMHR,97,"B",DT,G)=""
.S ^AMHREC(AMHR,97,0)="^9002011.97DA^"_G_"^"_G
Q
EV ;
;now update other fields
S AMHCLN=$$CLINIC^APCLV(AMHVSIT,"C")
S AMH02=$S(AMHCLN="14":"M",AMHCLN=48:"S",AMHCLN="43":"C",AMHCLN="C4":"O",1:"O")
;location
S AMH04=$P(^AUPNVSIT(AMHVSIT,0),U,6)
;community
S AMH05=$P($G(^AMHSITE(DUZ(2),18)),U,4)
I AMH05="" S AMH05=$P($G(^AMHSITE(DUZ(2),0)),U,6)
I AMH05="" S AMH05=$P($G(^AMHSITE(DUZ(2),0)),U,21)
I AMH05="" S AMH05=$P($G(^AMHSITE(DUZ(2),0)),U,29)
;activity code
S AMH06=$P(^AMHREC(AMHR,0),U,6)
I AMH06="" S AMH06=$O(^AMHTACT("B",99,0))
;TOC
S AMH07=$$TOC($P(^AUPNVSIT(AMHVSIT,0),U,7))
;#SERVED
S AMH09=1
;appt/walkin
S AMH11=$P(^AUPNVSIT(AMHVSIT,0),U,16) I AMH11="" D
.I $P(^AUPNVSIT(AMHVSIT,0),U,26)]"" S AMH11="A" Q
.S AMH11="U"
.Q
;activity time
S AMH12=$$TIME(AMHVSIT)
;
S AMH25=$P(^AUPNVSIT(AMHVSIT,0),U,8)
S AMH26=$P($G(^AUPNVSIT(AMHVSIT,21)),U)
;SCREENS
S (AMH1401,AMH1402,AMH1403,AMH1404,AMH1405,AMH1406,AMH1407,AMH1408,AMH1501,AMH1601,AMH1701,AMH1901)=""
S AMHX=0 F S AMHX=$O(^AUPNVXAM("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S X=$P($G(^AUPNVXAM(AMHX,0)),U)
.Q:'X
.S X=$P($G(^AUTTEXAM(X,0)),U,2)
.I X=34 D Q
..S R=$P(^AUPNVXAM(AMHX,0),U,4)
..Q:R=""
..S AMH1401=R
..S AMH1402=$P($G(^AUPNVXAM(AMHX,12)),U,4)
..I AMH1402="" S AMH1402=$$PRIMPROV^APCLV(AMHVSIT,"I")
..S AMH1501=$P($G(^AUPNVXAM(AMHX,811)),U)
.I X=35 D Q
..S R=$P(^AUPNVXAM(AMHX,0),U,4)
..Q:R=""
..S AMH1403=R S:R="PO" AMH1403="P"
..S AMH1404=$P($G(^AUPNVXAM(AMHX,12)),U,4)
..I AMH1404="" S AMH1404=$$PRIMPROV^APCLV(AMHVSIT,"I")
..S AMH1601=$P($G(^AUPNVXAM(AMHX,811)),U)
.I X=36 D Q
..S R=$P(^AUPNVXAM(AMHX,0),U,4)
..Q:R=""
..S AMH1405=R S:R="PO" AMH1405="P"
..S AMH1406=$P($G(^AUPNVXAM(AMHX,12)),U,4)
..I AMH1406="" S AMH1406=$$PRIMPROV^APCLV(AMHVSIT,"I")
..S AMH1701=$P($G(^AUPNVXAM(AMHX,811)),U)
.I X=43 D Q
..S R=$P(^AUPNVXAM(AMHX,0),U,4)
..Q:R=""
..S AMH1407=R
..S AMH1408=$P($G(^AUPNVXAM(AMHX,12)),U,4)
..I AMH1408="" S AMH1408=$$PRIMPROV^APCLV(AMHVSIT,"I")
..S AMH1901=$P($G(^AUPNVXAM(AMHX,811)),U)
S AMH1108="" S AMHX=$O(^AUPNVNOT("AD",AMHVSIT,0)) I AMHX S AMH1108=$P(^AUPNVNOT(AMHX,0),U)
S AMH1117=$P(^AUPNVSIT(AMHVSIT,0),U,22) ;PATCH 8 CMI/LAB - HOSP LOC
FILE ;
D SETARRAY^AMHEHR1
D FILE^DIE("K","AMHFDA","AMHERR(1)")
I $G(AMHERR(1)) D Q
.S AMHERROR="Could not create a MHSS Record entry.",AMHVFILE="9002011-MHSS RECORD"
.D LBULL
.Q
;
;update user last update/date edited
S DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR
;update TIU
TIUN ;
;
;get rid of all in multiple and rebuild
K ^AMHREC(AMHR,54)
S AMHX=0 F S AMHX=$O(^AUPNVNOT("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S AMHDOC=$P($G(^AUPNVNOT(AMHX,0)),U)
.I 'AMHDOC Q
.I '$D(^TIU(8925,AMHDOC)) Q
.S DIE="^AMHREC(",DA=AMHR,DR="5400///`"_AMHDOC D ^DIE K DIE,DA,DR
;
Q
EDITREC ;
S (DFN,AMHPAT)=$P(^AMHREC(AMHR,0),U,8)
S DIE="^AMHREC(",DA=AMHR,DR=".21////"_DT_";.28////"_DUZ D ^DIE
D EV
;now delete all v files
S AMHX=0 F S AMHX=$O(^AMHRPRO("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.S DA=AMHX,DIK="^AMHRPRO(" D ^DIK
S AMHX=0 F S AMHX=$O(^AMHRPROV("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.S DA=AMHX,DIK="^AMHRPROV(" D ^DIK
S AMHX=0 F S AMHX=$O(^AMHRPROC("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.S DA=AMHX,DIK="^AMHRPROC(" D ^DIK
S AMHX=0 F S AMHX=$O(^AMHREDU("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.S DA=AMHX,DIK="^AMHREDU(" D ^DIK
S AMHX=0 F S AMHX=$O(^AMHRHF("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.S DA=AMHX,DIK="^AMHRHF(" D ^DIK
S AMHX=0 F S AMHX=$O(^AMHRMSR("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.S DA=AMHX,DIK="^AMHRMSR(" D ^DIK
D ^XBFMK
D RFILES
D EXIT
Q
;
GETDSM ;
D GETDSM^AMHEHR1
Q
RFILES ;
VPOV ;
S AMHX=0 F S AMHX=$O(^AUPNVPOV("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S AMHCIEN=$P($G(^AUPNVPOV(AMHX,0)),U)
.Q:AMHCIEN=""
.S AMHCODE=$$VAL^XBDIQ1(9000010.07,AMHX,.01)
.Q:AMHCODE=""
.S AMHIMP=$$CS^AMHUTIL2(AMHCIEN) ;what is the coding system? 1=ICD9, 30=ICD10
.S AMH45=$$DSMCS^AMHUTIL1(DUZ(2),$P($P(^AMHREC(AMHR,0),U),"."))
.;S AMHDSM=$O(^AMHPROB("B",AMHCODE,0))
.S AMHDSM="" D GETDSM
.I AMHDSM="" D ;LAYGO INTO AMHPROB
..D ^XBFMK
..K AMHICNA
..S AMHPC=$O(^AMHPROBC("B",99.9,0))
..S X=AMHCODE,DLAYGO=9001012.2,DIADD=1,DIC="^AMHPROB("
..I AMHIMP=1 S AMHICNA=$$ICDD^ICDCODE(AMHCODE,"AMHICNA")
..I AMHIMP=30 S AMHICNA(1)=$P($$ICDDX^ICDEX(AMHCODE,$$VD^APCLV(AMHVSIT)),U,4)
..S DIC(0)="L",DIC("DR")=".02////"_$E($G(AMHICNA(1)),1,160)_";.03////"_AMHPC_";.1///"_$S(AMHIMP=1:9,1:0)_$S(AMHIMP=1:";.05////",1:";.17////")_AMHCODE
..K DD,D0,DO D FILE^DICN K DIADD,DLAYGO,DD,DIC,D0,DO
..I Y=-1 S AMHERROR="Could not Create POV: "_AMHCODE,AMHVFILE="MHSS RECORD PROBLEMS" D LBULL Q
..S AMHDSM=+Y
.I AMHDSM="" S AMHERROR="Could not Create POV: "_AMHCODE,AMHVFILE="MHSS RECORD PROBLEMS" D LBULL Q
.S AMH04=$P(^AUPNVPOV(AMHX,0),U,4)
.D ^XBFMK
.S X=AMHDSM,DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04////"_AMH04
.S DIC="^AMHRPRO(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.01 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 S AMHERROR="Could not Create POV: "_AMHCODE,AMHVFILE="MHSS RECORD PROBLEMS" D LBULL Q
.Q
VPROV ;
S AMHX=0 F S AMHX=$O(^AUPNVPRV("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S AMHPROV=$P($G(^AUPNVPRV(AMHX,0)),U)
.Q:AMHPROV=""
.S AMHPS=$P(^AUPNVPRV(AMHX,0),U,4)
.I AMHPS="" S AMHPS="S"
.S DIC="^AMHRPROV(",X=AMHPROV,DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04////"_AMHPS,DIC="^AMHRPROV("
.S DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.02 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 S AMHERROR="Could not Create PROVIDER: "_$P(^VA(200,AMHPROV,0),U),AMHVFILE="MHSS RECORD PROVIDERS" D LBULL Q ;D SENDBUL
.Q
VCPT ;
S AMHX=0 F S AMHX=$O(^AUPNVCPT("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S AMHCPT=$P($G(^AUPNVCPT(AMHX,0)),U)
.Q:AMHCPT=""
.S X=AMHCPT,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.08////"_$P(^AUPNVCPT(AMHX,0),U,8)_";.09////"_$P(^AUPNVCPT(AMHX,0),U,9)_";.16////"_$P(^AUPNVCPT(AMHX,0),U,16)
.S DIC="^AMHRPROC(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.04 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 S AMHERROR="Could not Create CPT: "_$P(^ICPT(AMHCPT,0),U),AMHVFILE="MHSS RECORD PROCEDURES" D LBULL Q
.Q
VPED ;
S AMHX=0 F S AMHX=$O(^AUPNVPED("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S AMHPED=$P($G(^AUPNVPED(AMHX,0)),U)
.Q:AMHPED=""
.S AMHP0=^AUPNVPED(AMHX,0)
.S X=AMHPED
.S DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04////"_$P(AMHP0,U,5)_";.05////"_$P(AMHP0,U,7)_";.06////"_$P(AMHP0,U,8)_";.07////"_$P(AMHP0,U,9)
.S DIC("DR")=DIC("DR")_";.08////"_$P(AMHP0,U,6)_";.11////"_$P(AMHP0,U,13)_";1102////"_$P($G(^AUPNVPED(AMHX,11)),U,2)
.S DIC="^AMHREDU(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.05 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 S AMHERROR="Could not Create EDUCATION: "_$P(^AUTTEDT(AMHPED,0),U),AMHVFILE="MHSS RECORD PATIENT EDUCATION" D LBULL Q ;D SENDBUL
.I $P(AMHP0,U,11)]"" S $P(^AMHREDU(+Y,11),U)=$P(AMHP0,U,11) ;directly set due to ;
.I $P(AMHP0,U,14)]"" S $P(^AMHREDU(+Y,0),U,9)=$P(AMHP0,U,14) ;due to ;
.Q
VHF ;
S AMHX=0 F S AMHX=$O(^AUPNVHF("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S AMHHF=$P($G(^AUPNVHF(AMHX,0)),U)
.Q:AMHHF=""
.S AMHP0=^AUPNVHF(AMHX,0)
.S X=AMHHF,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04////"_$P(AMHP0,U,4)_";.05////"_$P(AMHP0,U,5)_";.06////"_$P(AMHP0,U,6)
.S DIC="^AMHRHF(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.08 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 S AMHERROR="Could not Create Health Factor: "_$P(^AUTTHF(AMHHF,0),U),AMHVFILE="MHSS RECORD HEALTH FACTORS" D LBULL Q ;D SENDBUL
.I $P($G(^AUPNVHF(AMHX,811)),U,1)]"" S $P(^AMHRHF(+Y,811),U)=$P(^AUPNVHF(AMHX,811),U) ;directly set due to ;
.Q
;
VMSR ;
S AMHX=0 F S AMHX=$O(^AUPNVMSR("AD",AMHVSIT,AMHX)) Q:AMHX'=+AMHX D
.S AMHMSR=$P($G(^AUPNVMSR(AMHX,0)),U)
.Q:AMHMSR=""
.Q:$P($G(^AUPNVMSR(AMHX,2)),U,1) ;entered in error
.S AMHP0=^AUPNVMSR(AMHX,0)
.S X=AMHMSR,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04////"_$P(AMHP0,U,4)
.S DIC="^AMHRMSR(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.12 K DD,DO,D0 D FILE^DICN
.K DIC,DA,DO,D0,DD,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 S AMHERROR="Could not Create MEASUREMENT: "_AMHCODE,AMHVFILE="MHSS RECORD MEASUREMENTS" D LBULL Q ;D SENDBUL
;D ALERT
SCRREF ;are there any screening refusals?
D SCRREF^AMHEHR1
Q
EXIT ;
D EN^XBVK("AMH")
D ^XBFMK
Q
TIME(V) ;
NEW X,T
S X=0,T=""
F S X=$O(^AUPNVTM("AD",V,X)) Q:X'=+X S T=T+$P(^AUPNVTM(X,0),U)
I T Q T
Q ""
;
TOC(S) ;
I S="A" Q 2
I S="C" Q 7
I S="H" Q 3
I S="I" Q 10
I S="N" Q 4
I S="R" Q 4
I S="T" Q 8
Q 2
;
EDITEHR ;EP - called from option
W !!,"This option is used to edit the BH related fields of a visit"
W !,"that was entered via EHR.",!
EEHR1 ;
D EDITEHRX
F S AMHPAT="" D GETPAT Q:AMHPAT="" D EDIT
Q
D GETPAT
I AMHPAT="" D EDITEHRX Q
D GETDATE
I AMHDATE="" D EDITEHRX Q
D EDIT
Q
;
EDIT ;
D GETDATE
Q:AMHDATE=""
;display all EHR visits and allow user to select one
I '$D(^AMHREC("AF",AMHPAT,AMHDATE)) W !!,"There are no EHR created visits for ",$P(^DPT(AMHPAT,0),U)," on ",$$FMTE^XLFDT(AMHDATE) Q
S (AMHV,AMHC)=0
F S AMHV=$O(^AMHREC("AF",AMHPAT,AMHDATE,AMHV)) Q:AMHV'=+AMHV D
.I '$P($G(^AMHREC(AMHV,11)),U,10) Q
.Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHV)
.S AMHC=AMHC+1,AMHV(AMHC)=AMHV
.Q
I AMHC=0 W !!,"There are no EHR created visits for ",$P(^DPT(AMHPAT,0),U)," on ",$$FMTE^XLFDT(AMHDATE) Q
I AMHC=1 S AMHR=AMHV(1) G SCR
S AMHC=0 F S AMHC=$O(AMHV(AMHC)) Q:AMHC'=+AMHC D
.S AMHX=^AMHREC(AMHV(AMHC),0)
.W !,AMHC,") TIME: ",$P($$FMTE^XLFDT($P(AMHX,U),"2P")," ",2,3)," TOC: ",$E($$VAL^XBDIQ1(9002011,AMHV(AMHC),.07),1,12)," CLINIC: ",$E($$VAL^XBDIQ1(9002011,AMHV(AMHC),.25),1,15)
.W !?3,"Provider on Visit: ",$$PPNAME^AMHUTIL(AMHV(AMHC))
.W !?3,"Primary POV: ",$$PRIMPOV^AMHUTIL1(AMHV(AMHC),"C")," ",$E($$PRIMPOV^AMHUTIL1(AMHV(AMHC),"N"),1,50)
.Q
K DIR
S DIR(0)="N^1:"_AMHC,DIR("A")="Select" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S AMHR=AMHV(+Y)
;
SCR ;EP
S DA=AMHR,DDSFILE=9002011,DR=$S($$DSMCS^AMHUTIL1(DUZ(2),$P($P(^AMHREC(AMHR,0),U),"."))=4:"[AMH EHR EDIT RECORD]",1:"[AMHEH EHR EDIT RECORD") D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" D PAUSE^AMHLEA K DIMSG Q
Q
GETPAT ;
D EDITEHRX
S AMHPAT=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 Q
S AMHPAT=+Y
S X=AMHPAT D ^AMHPEDIT I '$D(X) G GETPAT
W !?25,"Ok" S %=1 D YN^DICN I %'=1 S AMHPAT="" K AMHC Q
I AMHPAT,'$$ALLOWP^AMHUTIL(DUZ,AMHPAT) D NALLOWP^AMHUTIL D PAUSE^AMHLEA G GETPAT
Q
;
GETDATE ;EP - GET DATE OF ENCOUNTER
W !!
S AMHDATE="",DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter ENCOUNTER DATE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
S AMHDATE=Y
Q
EDITEHRX ;
D EN^XBVK("AMH")
D KILL^AUPNPAT
D ^XBFMK
Q
;
TIU ;EP
NEW AMHSTR,AMHC,AMHTIUD,AMHTIU,AMHGBL,AMHHLF,AMHX,AMHX1
I '$O(^AMHREC(AMHR,54,0)) W !!,"There is no TIU document associated with this visit." D PAUSE^AMHLEA K AMHTIU Q
;D BROWS1^TIURA2("TIU BROWSE FOR READ ONLY",AMHTIU)
D TIUDISP
K AMHTIU
Q
TIUDISP ;
K AMHTIUD S AMHC=0
S X="" D S(X) D S("TIU DOCUMENTS") D S("-------------")
S AMHDOC=0 F S AMHDOC=$O(^AMHREC(AMHR,54,"B",AMHDOC)) Q:AMHDOC'=+AMHDOC D
.K AMHTIU,AMHERR
.K ^TMP("AMHOENPS",$J)
.D TIUDSP
.K ^TMP("AMHEONPS",$J)
.K AMHTIU
.Q
D ARRAY^XBLM("AMHTIUD(","TIU Document Display")
Q
TIUDSP ;
D TIUDSP^AMHEHR1
Q
;
S(Y,F,C,T) ;EP - set up array
I '$G(F) S F=0
I '$G(T) S T=0
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S AMHC=AMHC+1
S AMHTIUD(AMHC,0)=X
Q
EHRE ;EP
W !,"This visit was created through EHR. Certain data fields can be edited using",!,"the EH action on the PDE screen. All other fields must be edited"
W !,"through EHR.",!
Q
;
LBULL ;
K XMB
S XMDUZ="EHR TO BH"
S XMB(1)=AMHVSIT,XMB(2)=$P(^DPT(AMHPAT,0),U)_" (DFN "_AMHPAT_")",Y=$P($P(^AUPNVSIT(AMHVSIT,0),U),".") D DD^%DT S XMB(3)=Y,XMB(4)="EHR TO PCC LINK FAILURE: "_AMHERROR,XMB(5)=$G(AMHVFILE),XMB="AMH EHR-PCC LINK FAIL " ;,AMHDUZ=DUZ,DUZ=.5
D ^XMB K XMB,AMHERROR,AMHBN,AMHVFILE,XMDUZ
Q
AMHEHR ; IHS/CMI/LAB - ADD NEW MHSS ACTIVITY RECORDS 13 Aug 2007 4:21 PM 03 Jun 2009 10:50 AM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,2,4,6,8**;JUN 02, 2010;Build 7
+2 ;
EN ;PEP - ADD NEW OR EDIT EXISTING BH RECORD CREATED BY EHR
+1 SET AMHVSIT=AUPNVSIT
+2 SET AMHEHR=1
+3 SET AMHR=$ORDER(^AMHREC("AVISIT",AUPNVSIT,0))
+4 IF AMHR
IF $PIECE($GET(^AMHREC(AMHR,11)),U,11)
QUIT
+5 IF AMHR
DO EDITREC
QUIT
+6 IF $PIECE($GET(^AMHSITE(DUZ(2),18)),U,5)
QUIT
+7 SET AMHDATE=$PIECE(^AUPNVSIT(AMHVSIT,0),U)
+8 SET (AMHPAT,DFN)=$PIECE(^AUPNVSIT(AMHVSIT,0),U,5)
+9 ;create record
+10 KILL DIC
SET DIC(0)="EL"
SET DIC="^AMHREC("
SET DLAYGO=9002011
SET DIADD=1
SET X=AMHDATE
+11 SET DIC("DR")=".03///^S X=DT;.08////"_DFN_";.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21////"_DT_";.16////"_AMHVSIT_";1110////1"
+12 KILL DD,DO,D0
DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+13 IF Y=-1
QUIT
+14 SET AMHR=+Y
+15 DO EV
+16 DO RFILES
+17 DO EXIT
+18 QUIT
ALERT ;
+1 IF $PIECE(^AMHREC(AMHR,0),U,12)=""!($PIECE(^AMHREC(AMHR,0),U,12)=0)
Begin DoDot:1
+2 ;send alert to user only if one never sent
+3 SET (G,X)=0
FOR
SET X=$ORDER(^AMHREC(AMHR,97,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+4 IF $PIECE(^AMHREC(AMHR,97,X,0),U,1)'=DT
QUIT
+5 IF $PIECE(^AMHREC(AMHR,97,X,0),U,2)'=DUZ
QUIT
+6 SET G=1
End DoDot:2
+7 IF G
QUIT
+8 NEW %,P
+9 SET %=0
FOR
SET %=$ORDER(^AMHRPROV("AD",AMHR,%))
IF %'=+%
QUIT
SET P=$PIECE($GET(^AMHRPROV(%,0)),U)
+10 SET XQA(P)=""
+11 SET XQAOPT=""
+12 SET XQAROU=""
+13 SET XQAFLG="D"
+14 SET AMHTEXT(1)=" "
+15 SET AMHTEXT(2)=" "
+16 SET AMHTEXT(3)="This Behavioral Health visit is missing an activity time. The activity"
+17 SET AMHTEXT(4)="time can be entered through EHR or with PCC data entry using the AT"
+18 SET AMHTEXT(5)="mnemonic."
+19 SET XQATEXT="AMHTEXT"
+20 SET XQAMSG="HRN: "_$$HRN^AUPNPAT($PIECE(^AUPNVSIT(AUPNVSIT,0),U,5),DUZ(2))_" Date: "_$$VAL^XBDIQ1(9000010,AUPNVSIT,.01)_" is missing an activity time."
+21 SET XQAID="OR,"_$PIECE(^AMHREC(AMHR,0),U,8)_",46"
+22 DO SETUP^XQALERT
+23 SET (G,X)=0
FOR
SET X=$ORDER(^AMHREC(AMHR,97,X))
IF X'=+X
QUIT
SET G=X
+24 SET G=G+1
+25 SET ^AMHREC(AMHR,97,G,0)=DT_"^"_DUZ
SET ^AMHREC(AMHR,97,"B",DT,G)=""
+26 SET ^AMHREC(AMHR,97,0)="^9002011.97DA^"_G_"^"_G
End DoDot:1
+27 QUIT
EV ;
+1 ;now update other fields
+2 SET AMHCLN=$$CLINIC^APCLV(AMHVSIT,"C")
+3 SET AMH02=$SELECT(AMHCLN="14":"M",AMHCLN=48:"S",AMHCLN="43":"C",AMHCLN="C4":"O",1:"O")
+4 ;location
+5 SET AMH04=$PIECE(^AUPNVSIT(AMHVSIT,0),U,6)
+6 ;community
+7 SET AMH05=$PIECE($GET(^AMHSITE(DUZ(2),18)),U,4)
+8 IF AMH05=""
SET AMH05=$PIECE($GET(^AMHSITE(DUZ(2),0)),U,6)
+9 IF AMH05=""
SET AMH05=$PIECE($GET(^AMHSITE(DUZ(2),0)),U,21)
+10 IF AMH05=""
SET AMH05=$PIECE($GET(^AMHSITE(DUZ(2),0)),U,29)
+11 ;activity code
+12 SET AMH06=$PIECE(^AMHREC(AMHR,0),U,6)
+13 IF AMH06=""
SET AMH06=$ORDER(^AMHTACT("B",99,0))
+14 ;TOC
+15 SET AMH07=$$TOC($PIECE(^AUPNVSIT(AMHVSIT,0),U,7))
+16 ;#SERVED
+17 SET AMH09=1
+18 ;appt/walkin
+19 SET AMH11=$PIECE(^AUPNVSIT(AMHVSIT,0),U,16)
IF AMH11=""
Begin DoDot:1
+20 IF $PIECE(^AUPNVSIT(AMHVSIT,0),U,26)]""
SET AMH11="A"
QUIT
+21 SET AMH11="U"
+22 QUIT
End DoDot:1
+23 ;activity time
+24 SET AMH12=$$TIME(AMHVSIT)
+25 ;
+26 SET AMH25=$PIECE(^AUPNVSIT(AMHVSIT,0),U,8)
+27 SET AMH26=$PIECE($GET(^AUPNVSIT(AMHVSIT,21)),U)
+28 ;SCREENS
+29 SET (AMH1401,AMH1402,AMH1403,AMH1404,AMH1405,AMH1406,AMH1407,AMH1408,AMH1501,AMH1601,AMH1701,AMH1901)=""
+30 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVXAM("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+31 SET X=$PIECE($GET(^AUPNVXAM(AMHX,0)),U)
+32 IF 'X
QUIT
+33 SET X=$PIECE($GET(^AUTTEXAM(X,0)),U,2)
+34 IF X=34
Begin DoDot:2
+35 SET R=$PIECE(^AUPNVXAM(AMHX,0),U,4)
+36 IF R=""
QUIT
+37 SET AMH1401=R
+38 SET AMH1402=$PIECE($GET(^AUPNVXAM(AMHX,12)),U,4)
+39 IF AMH1402=""
SET AMH1402=$$PRIMPROV^APCLV(AMHVSIT,"I")
+40 SET AMH1501=$PIECE($GET(^AUPNVXAM(AMHX,811)),U)
End DoDot:2
QUIT
+41 IF X=35
Begin DoDot:2
+42 SET R=$PIECE(^AUPNVXAM(AMHX,0),U,4)
+43 IF R=""
QUIT
+44 SET AMH1403=R
IF R="PO"
SET AMH1403="P"
+45 SET AMH1404=$PIECE($GET(^AUPNVXAM(AMHX,12)),U,4)
+46 IF AMH1404=""
SET AMH1404=$$PRIMPROV^APCLV(AMHVSIT,"I")
+47 SET AMH1601=$PIECE($GET(^AUPNVXAM(AMHX,811)),U)
End DoDot:2
QUIT
+48 IF X=36
Begin DoDot:2
+49 SET R=$PIECE(^AUPNVXAM(AMHX,0),U,4)
+50 IF R=""
QUIT
+51 SET AMH1405=R
IF R="PO"
SET AMH1405="P"
+52 SET AMH1406=$PIECE($GET(^AUPNVXAM(AMHX,12)),U,4)
+53 IF AMH1406=""
SET AMH1406=$$PRIMPROV^APCLV(AMHVSIT,"I")
+54 SET AMH1701=$PIECE($GET(^AUPNVXAM(AMHX,811)),U)
End DoDot:2
QUIT
+55 IF X=43
Begin DoDot:2
+56 SET R=$PIECE(^AUPNVXAM(AMHX,0),U,4)
+57 IF R=""
QUIT
+58 SET AMH1407=R
+59 SET AMH1408=$PIECE($GET(^AUPNVXAM(AMHX,12)),U,4)
+60 IF AMH1408=""
SET AMH1408=$$PRIMPROV^APCLV(AMHVSIT,"I")
+61 SET AMH1901=$PIECE($GET(^AUPNVXAM(AMHX,811)),U)
End DoDot:2
QUIT
End DoDot:1
+62 SET AMH1108=""
SET AMHX=$ORDER(^AUPNVNOT("AD",AMHVSIT,0))
IF AMHX
SET AMH1108=$PIECE(^AUPNVNOT(AMHX,0),U)
+63 ;PATCH 8 CMI/LAB - HOSP LOC
SET AMH1117=$PIECE(^AUPNVSIT(AMHVSIT,0),U,22)
FILE ;
+1 DO SETARRAY^AMHEHR1
+2 DO FILE^DIE("K","AMHFDA","AMHERR(1)")
+3 IF $GET(AMHERR(1))
Begin DoDot:1
+4 SET AMHERROR="Could not create a MHSS Record entry."
SET AMHVFILE="9002011-MHSS RECORD"
+5 DO LBULL
+6 QUIT
End DoDot:1
QUIT
+7 ;
+8 ;update user last update/date edited
+9 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
+10 ;update TIU
TIUN ;
+1 ;
+2 ;get rid of all in multiple and rebuild
+3 KILL ^AMHREC(AMHR,54)
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVNOT("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+5 SET AMHDOC=$PIECE($GET(^AUPNVNOT(AMHX,0)),U)
+6 IF 'AMHDOC
QUIT
+7 IF '$DATA(^TIU(8925,AMHDOC))
QUIT
+8 SET DIE="^AMHREC("
SET DA=AMHR
SET DR="5400///`"_AMHDOC
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+9 ;
+10 QUIT
EDITREC ;
+1 SET (DFN,AMHPAT)=$PIECE(^AMHREC(AMHR,0),U,8)
+2 SET DIE="^AMHREC("
SET DA=AMHR
SET DR=".21////"_DT_";.28////"_DUZ
DO ^DIE
+3 DO EV
+4 ;now delete all v files
+5 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRPRO("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+6 SET DA=AMHX
SET DIK="^AMHRPRO("
DO ^DIK
End DoDot:1
+7 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRPROV("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+8 SET DA=AMHX
SET DIK="^AMHRPROV("
DO ^DIK
End DoDot:1
+9 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRPROC("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+10 SET DA=AMHX
SET DIK="^AMHRPROC("
DO ^DIK
End DoDot:1
+11 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREDU("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+12 SET DA=AMHX
SET DIK="^AMHREDU("
DO ^DIK
End DoDot:1
+13 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRHF("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+14 SET DA=AMHX
SET DIK="^AMHRHF("
DO ^DIK
End DoDot:1
+15 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRMSR("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+16 SET DA=AMHX
SET DIK="^AMHRMSR("
DO ^DIK
End DoDot:1
+17 DO ^XBFMK
+18 DO RFILES
+19 DO EXIT
+20 QUIT
+21 ;
GETDSM ;
+1 DO GETDSM^AMHEHR1
+2 QUIT
RFILES ;
VPOV ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVPOV("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 SET AMHCIEN=$PIECE($GET(^AUPNVPOV(AMHX,0)),U)
+3 IF AMHCIEN=""
QUIT
+4 SET AMHCODE=$$VAL^XBDIQ1(9000010.07,AMHX,.01)
+5 IF AMHCODE=""
QUIT
+6 ;what is the coding system? 1=ICD9, 30=ICD10
SET AMHIMP=$$CS^AMHUTIL2(AMHCIEN)
+7 SET AMH45=$$DSMCS^AMHUTIL1(DUZ(2),$PIECE($PIECE(^AMHREC(AMHR,0),U),"."))
+8 ;S AMHDSM=$O(^AMHPROB("B",AMHCODE,0))
+9 SET AMHDSM=""
DO GETDSM
+10 ;LAYGO INTO AMHPROB
IF AMHDSM=""
Begin DoDot:2
+11 DO ^XBFMK
+12 KILL AMHICNA
+13 SET AMHPC=$ORDER(^AMHPROBC("B",99.9,0))
+14 SET X=AMHCODE
SET DLAYGO=9001012.2
SET DIADD=1
SET DIC="^AMHPROB("
+15 IF AMHIMP=1
SET AMHICNA=$$ICDD^ICDCODE(AMHCODE,"AMHICNA")
+16 IF AMHIMP=30
SET AMHICNA(1)=$PIECE($$ICDDX^ICDEX(AMHCODE,$$VD^APCLV(AMHVSIT)),U,4)
+17 SET DIC(0)="L"
SET DIC("DR")=".02////"_$EXTRACT($GET(AMHICNA(1)),1,160)_";.03////"_AMHPC_";.1///"_$SELECT(AMHIMP=1:9,1:0)_$SELECT(AMHIMP=1:";.05////",1:";.17////")_AMHCODE
+18 KILL DD,D0,DO
DO FILE^DICN
KILL DIADD,DLAYGO,DD,DIC,D0,DO
+19 IF Y=-1
SET AMHERROR="Could not Create POV: "_AMHCODE
SET AMHVFILE="MHSS RECORD PROBLEMS"
DO LBULL
QUIT
+20 SET AMHDSM=+Y
End DoDot:2
+21 IF AMHDSM=""
SET AMHERROR="Could not Create POV: "_AMHCODE
SET AMHVFILE="MHSS RECORD PROBLEMS"
DO LBULL
QUIT
+22 SET AMH04=$PIECE(^AUPNVPOV(AMHX,0),U,4)
+23 DO ^XBFMK
+24 SET X=AMHDSM
SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04////"_AMH04
+25 SET DIC="^AMHRPRO("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.01
KILL DD,DO
DO FILE^DICN
+26 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+27 IF Y=-1
SET AMHERROR="Could not Create POV: "_AMHCODE
SET AMHVFILE="MHSS RECORD PROBLEMS"
DO LBULL
QUIT
+28 QUIT
End DoDot:1
VPROV ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVPRV("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 SET AMHPROV=$PIECE($GET(^AUPNVPRV(AMHX,0)),U)
+3 IF AMHPROV=""
QUIT
+4 SET AMHPS=$PIECE(^AUPNVPRV(AMHX,0),U,4)
+5 IF AMHPS=""
SET AMHPS="S"
+6 SET DIC="^AMHRPROV("
SET X=AMHPROV
SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04////"_AMHPS
SET DIC="^AMHRPROV("
+7 SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.02
KILL DD,DO
DO FILE^DICN
+8 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+9 ;D SENDBUL
IF Y=-1
SET AMHERROR="Could not Create PROVIDER: "_$PIECE(^VA(200,AMHPROV,0),U)
SET AMHVFILE="MHSS RECORD PROVIDERS"
DO LBULL
QUIT
+10 QUIT
End DoDot:1
VCPT ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVCPT("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 SET AMHCPT=$PIECE($GET(^AUPNVCPT(AMHX,0)),U)
+3 IF AMHCPT=""
QUIT
+4 SET X=AMHCPT
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.08////"_$PIECE(^AUPNVCPT(AMHX,0),U,8)_";.09////"_$PIECE(^AUPNVCPT(AMHX,0),U,9)_";.16////"_$PIECE(^AUPNVCPT(AMHX,0),U,16)
+5 SET DIC="^AMHRPROC("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.04
KILL DD,DO
DO FILE^DICN
+6 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+7 IF Y=-1
SET AMHERROR="Could not Create CPT: "_$PIECE(^ICPT(AMHCPT,0),U)
SET AMHVFILE="MHSS RECORD PROCEDURES"
DO LBULL
QUIT
+8 QUIT
End DoDot:1
VPED ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVPED("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 SET AMHPED=$PIECE($GET(^AUPNVPED(AMHX,0)),U)
+3 IF AMHPED=""
QUIT
+4 SET AMHP0=^AUPNVPED(AMHX,0)
+5 SET X=AMHPED
+6 SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04////"_$PIECE(AMHP0,U,5)_";.05////"_$PIECE(AMHP0,U,7)_";.06////"_$PIECE(AMHP0,U,8)_";.07////"_$PIECE(AMHP0,U,9)
+7 SET DIC("DR")=DIC("DR")_";.08////"_$PIECE(AMHP0,U,6)_";.11////"_$PIECE(AMHP0,U,13)_";1102////"_$PIECE($GET(^AUPNVPED(AMHX,11)),U,2)
+8 SET DIC="^AMHREDU("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.05
KILL DD,DO
DO FILE^DICN
+9 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+10 ;D SENDBUL
IF Y=-1
SET AMHERROR="Could not Create EDUCATION: "_$PIECE(^AUTTEDT(AMHPED,0),U)
SET AMHVFILE="MHSS RECORD PATIENT EDUCATION"
DO LBULL
QUIT
+11 ;directly set due to ;
IF $PIECE(AMHP0,U,11)]""
SET $PIECE(^AMHREDU(+Y,11),U)=$PIECE(AMHP0,U,11)
+12 ;due to ;
IF $PIECE(AMHP0,U,14)]""
SET $PIECE(^AMHREDU(+Y,0),U,9)=$PIECE(AMHP0,U,14)
+13 QUIT
End DoDot:1
VHF ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVHF("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 SET AMHHF=$PIECE($GET(^AUPNVHF(AMHX,0)),U)
+3 IF AMHHF=""
QUIT
+4 SET AMHP0=^AUPNVHF(AMHX,0)
+5 SET X=AMHHF
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04////"_$PIECE(AMHP0,U,4)_";.05////"_$PIECE(AMHP0,U,5)_";.06////"_$PIECE(AMHP0,U,6)
+6 SET DIC="^AMHRHF("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.08
KILL DD,DO
DO FILE^DICN
+7 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+8 ;D SENDBUL
IF Y=-1
SET AMHERROR="Could not Create Health Factor: "_$PIECE(^AUTTHF(AMHHF,0),U)
SET AMHVFILE="MHSS RECORD HEALTH FACTORS"
DO LBULL
QUIT
+9 ;directly set due to ;
IF $PIECE($GET(^AUPNVHF(AMHX,811)),U,1)]""
SET $PIECE(^AMHRHF(+Y,811),U)=$PIECE(^AUPNVHF(AMHX,811),U)
+10 QUIT
End DoDot:1
+11 ;
VMSR ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVMSR("AD",AMHVSIT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 SET AMHMSR=$PIECE($GET(^AUPNVMSR(AMHX,0)),U)
+3 IF AMHMSR=""
QUIT
+4 ;entered in error
IF $PIECE($GET(^AUPNVMSR(AMHX,2)),U,1)
QUIT
+5 SET AMHP0=^AUPNVMSR(AMHX,0)
+6 SET X=AMHMSR
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04////"_$PIECE(AMHP0,U,4)
+7 SET DIC="^AMHRMSR("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.12
KILL DD,DO,D0
DO FILE^DICN
+8 KILL DIC,DA,DO,D0,DD,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+9 ;D SENDBUL
IF Y=-1
SET AMHERROR="Could not Create MEASUREMENT: "_AMHCODE
SET AMHVFILE="MHSS RECORD MEASUREMENTS"
DO LBULL
QUIT
End DoDot:1
+10 ;D ALERT
SCRREF ;are there any screening refusals?
+1 DO SCRREF^AMHEHR1
+2 QUIT
EXIT ;
+1 DO EN^XBVK("AMH")
+2 DO ^XBFMK
+3 QUIT
TIME(V) ;
+1 NEW X,T
+2 SET X=0
SET T=""
+3 FOR
SET X=$ORDER(^AUPNVTM("AD",V,X))
IF X'=+X
QUIT
SET T=T+$PIECE(^AUPNVTM(X,0),U)
+4 IF T
QUIT T
+5 QUIT ""
+6 ;
TOC(S) ;
+1 IF S="A"
QUIT 2
+2 IF S="C"
QUIT 7
+3 IF S="H"
QUIT 3
+4 IF S="I"
QUIT 10
+5 IF S="N"
QUIT 4
+6 IF S="R"
QUIT 4
+7 IF S="T"
QUIT 8
+8 QUIT 2
+9 ;
EDITEHR ;EP - called from option
+1 WRITE !!,"This option is used to edit the BH related fields of a visit"
+2 WRITE !,"that was entered via EHR.",!
EEHR1 ;
+1 DO EDITEHRX
+2 FOR
SET AMHPAT=""
DO GETPAT
IF AMHPAT=""
QUIT
DO EDIT
+3 QUIT
+4 DO GETPAT
+5 IF AMHPAT=""
DO EDITEHRX
QUIT
+6 DO GETDATE
+7 IF AMHDATE=""
DO EDITEHRX
QUIT
+8 DO EDIT
+9 QUIT
+10 ;
EDIT ;
+1 DO GETDATE
+2 IF AMHDATE=""
QUIT
+3 ;display all EHR visits and allow user to select one
+4 IF '$DATA(^AMHREC("AF",AMHPAT,AMHDATE))
WRITE !!,"There are no EHR created visits for ",$PIECE(^DPT(AMHPAT,0),U)," on ",$$FMTE^XLFDT(AMHDATE)
QUIT
+5 SET (AMHV,AMHC)=0
+6 FOR
SET AMHV=$ORDER(^AMHREC("AF",AMHPAT,AMHDATE,AMHV))
IF AMHV'=+AMHV
QUIT
Begin DoDot:1
+7 IF '$PIECE($GET(^AMHREC(AMHV,11)),U,10)
QUIT
+8 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHV)
QUIT
+9 SET AMHC=AMHC+1
SET AMHV(AMHC)=AMHV
+10 QUIT
End DoDot:1
+11 IF AMHC=0
WRITE !!,"There are no EHR created visits for ",$PIECE(^DPT(AMHPAT,0),U)," on ",$$FMTE^XLFDT(AMHDATE)
QUIT
+12 IF AMHC=1
SET AMHR=AMHV(1)
GOTO SCR
+13 SET AMHC=0
FOR
SET AMHC=$ORDER(AMHV(AMHC))
IF AMHC'=+AMHC
QUIT
Begin DoDot:1
+14 SET AMHX=^AMHREC(AMHV(AMHC),0)
+15 WRITE !,AMHC,") TIME: ",$PIECE($$FMTE^XLFDT($PIECE(AMHX,U),"2P")," ",2,3)," TOC: ",$EXTRACT($$VAL^XBDIQ1(9002011,AMHV(AMHC),.07),1,12)," CLINIC: ",$EXTRACT($$VAL^XBDIQ1(9002011,AMHV(AMHC),.25),1,15)
+16 WRITE !?3,"Provider on Visit: ",$$PPNAME^AMHUTIL(AMHV(AMHC))
+17 WRITE !?3,"Primary POV: ",$$PRIMPOV^AMHUTIL1(AMHV(AMHC),"C")," ",$EXTRACT($$PRIMPOV^AMHUTIL1(AMHV(AMHC),"N"),1,50)
+18 QUIT
End DoDot:1
+19 KILL DIR
+20 SET DIR(0)="N^1:"_AMHC
SET DIR("A")="Select"
KILL DA
DO ^DIR
KILL DIR
+21 IF $DATA(DIRUT)
QUIT
+22 SET AMHR=AMHV(+Y)
+23 ;
SCR ;EP
+1 SET DA=AMHR
SET DDSFILE=9002011
SET DR=$SELECT($$DSMCS^AMHUTIL1(DUZ(2),$PIECE($PIECE(^AMHREC(AMHR,0),U),"."))=4:"[AMH EHR EDIT RECORD]",1:"[AMHEH EHR EDIT RECORD")
DO ^DDS
+2 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
DO PAUSE^AMHLEA
KILL DIMSG
QUIT
+3 QUIT
GETPAT ;
+1 DO EDITEHRX
+2 SET AMHPAT=""
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+4 IF Y<0
QUIT
+5 SET AMHPAT=+Y
+6 SET X=AMHPAT
DO ^AMHPEDIT
IF '$DATA(X)
GOTO GETPAT
+7 WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
SET AMHPAT=""
KILL AMHC
QUIT
+8 IF AMHPAT
IF '$$ALLOWP^AMHUTIL(DUZ,AMHPAT)
DO NALLOWP^AMHUTIL
DO PAUSE^AMHLEA
GOTO GETPAT
+9 QUIT
+10 ;
GETDATE ;EP - GET DATE OF ENCOUNTER
+1 WRITE !!
+2 SET AMHDATE=""
SET DIR(0)="DO^:"_DT_":EPTX"
SET DIR("A")="Enter ENCOUNTER DATE"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 SET AMHDATE=Y
+5 QUIT
EDITEHRX ;
+1 DO EN^XBVK("AMH")
+2 DO KILL^AUPNPAT
+3 DO ^XBFMK
+4 QUIT
+5 ;
TIU ;EP
+1 NEW AMHSTR,AMHC,AMHTIUD,AMHTIU,AMHGBL,AMHHLF,AMHX,AMHX1
+2 IF '$ORDER(^AMHREC(AMHR,54,0))
WRITE !!,"There is no TIU document associated with this visit."
DO PAUSE^AMHLEA
KILL AMHTIU
QUIT
+3 ;D BROWS1^TIURA2("TIU BROWSE FOR READ ONLY",AMHTIU)
+4 DO TIUDISP
+5 KILL AMHTIU
+6 QUIT
TIUDISP ;
+1 KILL AMHTIUD
SET AMHC=0
+2 SET X=""
DO S(X)
DO S("TIU DOCUMENTS")
DO S("-------------")
+3 SET AMHDOC=0
FOR
SET AMHDOC=$ORDER(^AMHREC(AMHR,54,"B",AMHDOC))
IF AMHDOC'=+AMHDOC
QUIT
Begin DoDot:1
+4 KILL AMHTIU,AMHERR
+5 KILL ^TMP("AMHOENPS",$JOB)
+6 DO TIUDSP
+7 KILL ^TMP("AMHEONPS",$JOB)
+8 KILL AMHTIU
+9 QUIT
End DoDot:1
+10 DO ARRAY^XBLM("AMHTIUD(","TIU Document Display")
+11 QUIT
TIUDSP ;
+1 DO TIUDSP^AMHEHR1
+2 QUIT
+3 ;
S(Y,F,C,T) ;EP - set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 ;blank lines
+4 FOR F=1:1:F
SET X=""
DO S1
+5 SET X=Y
+6 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+7 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+8 FOR %=1:1:T
SET X=" "_Y
+9 DO S1
+10 QUIT
S1 ;
+1 SET AMHC=AMHC+1
+2 SET AMHTIUD(AMHC,0)=X
+3 QUIT
EHRE ;EP
+1 WRITE !,"This visit was created through EHR. Certain data fields can be edited using",!,"the EH action on the PDE screen. All other fields must be edited"
+2 WRITE !,"through EHR.",!
+3 QUIT
+4 ;
LBULL ;
+1 KILL XMB
+2 SET XMDUZ="EHR TO BH"
+3 ;,AMHDUZ=DUZ,DUZ=.5
SET XMB(1)=AMHVSIT
SET XMB(2)=$PIECE(^DPT(AMHPAT,0),U)_" (DFN "_AMHPAT_")"
SET Y=$PIECE($PIECE(^AUPNVSIT(AMHVSIT,0),U),".")
DO DD^%DT
SET XMB(3)=Y
SET XMB(4)="EHR TO PCC LINK FAILURE: "_AMHERROR
SET XMB(5)=$GET(AMHVFILE)
SET XMB="AMH EHR-PCC LINK FAIL "
+4 DO ^XMB
KILL XMB,AMHERROR,AMHBN,AMHVFILE,XMDUZ
+5 QUIT
