AMHGU ; IHS/CMI/MAW - AMH Behavioral Health GUI Utilities 9/8/2008 2:00:25 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;
;
DEBUG(RETVAL,AMHSTR) ;replace tag below to allow Serenji debug of GUI
D DEBUG^%Serenji("GETPAT^AMHGU(.RETVAL,.AMHSTR)")
Q
;
ADO ;EP -- setup the ADO string for each call
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
Q
;
CATSTR(AMHSRET,STR) ;EP -- concatenate a long string in
N AMHDA
S AMHSRET=""
S AMHDA=0 F S AMHDA=$O(STR(AMHDA)) Q:'AMHDA D
. S AMHSRET=AMHSRET_$G(STR(AMHDA))
Q
;
ARRAY(AMHRET,STR) ;EP -- turn a string from .Net into an array
N A
S A="*"
N I,AMHCNT
S AMHCNT=0
F I=1:1 D Q:$P(STR,A,I)=""
. Q:$P(STR,A,I)=""
. S AMHCNT=AMHCNT+1
. S AMHRET(AMHCNT)=$TR($P(STR,A,I),"^"," ")
I $G(AMHRET(1))="" S AMHRET=""
Q
;
ARRAYD(AMHRET,STR,DNUM) ;EP -- turn a string from .Net into an array
N A
S A="*"
N I,AMHCNT
S AMHCNT=0
F I=1:1 D Q:$P(STR,A,I)=""
. Q:$P(STR,A,I)=""
. ;S AMHCNT=AMHCNT+1
. S AMHRET(DNUM)=$TR($P(STR,A,I),"^"," ")
I $G(AMHRET(1))="" S AMHRET=""
Q
;
ARRAYTO(AMHRET,STR) ;EP -- break a long wp field into pieces for filing into a WP field
K AMHRET
N I,LN,CN,SCN,TCN,ST
S CN=0
S SCN=1
S TCN=0
S ST=1
S STR=$TR(STR,"^"," ")
S LN=$L(STR)
I STR[$C(10) D Q
. S LN=$L(STR,$C(10))
. F I=1:1 D Q:(CN+1)>LN ;Q:$P(STR,$C(10),I)=""
.. ;Q:$P(STR,$C(10),I)=""
.. Q:(CN+1)>LN
.. N CH
.. S CH=$P(STR,$C(10),I)
.. S CN=CN+1
.. S AMHRET(SCN)=CH_$C(10)
.. S SCN=SCN+1
F I=1:1 D Q:I>LN
. N CH
. S CH=$E(STR,I,I)
. S CN=CN+1
. S TCN=TCN+1
. I TCN>65,CH=" " D
.. S AMHRET(SCN)=$E(STR,ST,CN)
.. S ST=CN+1
.. S SCN=SCN+1
.. S TCN=0
S AMHRET(SCN)=$E(STR,ST,CN)
Q
;
ARRAYT(AMHRET,STR) ;EP -- break a long wp field into pieces for filing into a WP field
K AMHRET
N I,CN,SCN,TCN,ST
N LN
S CN=0
S SCN=1
S TCN=0
S ST=1
S STR=$TR(STR,"^"," ")
S LN=$L(STR)
I LN=0 S AMHRET="" Q ;4.0p1 so multiple doesnt get created
F I=1:1:LN D Q:I>LN
. N CHAR
. S CHAR=$E(STR,I,I)
. S CN=CN+1
. S TCN=TCN+1
. I CHAR=$C(10) D Q
.. S AMHRET(SCN)=$E(STR,ST,CN) ;_$C(10)
.. S ST=CN+1
.. S SCN=SCN+1
.. S TCN=0
. I TCN>65,CHAR=" " D Q
.. S AMHRET(SCN)=$E(STR,ST,CN)
.. S ST=CN+1
.. S SCN=SCN+1
.. S TCN=0
I $E(STR,ST,CN)'="" S AMHRET(SCN)=$E(STR,ST,CN)
I $G(AMHRET(SCN))="" K AMHRET(SCN)
Q
;
MERR ; MUMPS ERROR TRAP
N AMHX
X ("S AMHX=$"_"ZE")
S AMHX="MUMPS error: """_AMHX_""""
D ^%ZTER
D ERR(AMHX)
Q
;
ERR(ERR) ; BMX ADO SCHEMA ERROR PROCESSOR
N AMHXA
S AMHXA="M ERROR|"_ERR_$C(30)
S @RETVAL@(1)=AMHXA
Q
;
KEYS(RETVAL,AMHSTR) ;EP -- return keys for user
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHDA,AMHNS,P,AMHDATA,AMHKEYI,AMHKEY,AMHI
S AMHI=0
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
S ^AMHTMP($J,AMHI)="T00030KEYS"_$C(30)
S P="|"
S AMHNS=$P(AMHSTR,P)
S AMHDA=0 F S AMHDA=$O(^VA(200,DUZ,51,AMHDA)) Q:'AMHDA D
. S AMHDATA=$G(^VA(200,DUZ,51,AMHDA,0))
. S AMHKEYI=$P(AMHDATA,U)
. S AMHKEY=$P($G(^DIC(19.1,AMHKEYI,0)),U)
. I AMHNS'="*" Q:$E(AMHKEY,1,$L(AMHNS))'[AMHNS
. S AMHI=AMHI+1
. S ^AMHTMP($J,AMHI)=AMHKEY_$C(30)
S ^AMHTMP($J,AMHI+1)=$C(31)
Q
;
LVDT(PDT) ;EP - return date for list view format
I PDT="" Q ""
Q $E(PDT,4,5)_"/"_$E(PDT,6,7)_"/"_($E(PDT,1,3)+1700)
;
TIME(TM) ;EP -- return time in .Net format
N DOTNETTM
S DOTNETTM=$S(($E(TM,1,2)>12):$E(TM,1,2)_":"_$E(TM,3,4)_" PM",1:$E(TM,1,2)_":"_$E(TM,3,4)_" AM")
Q $G(DOTNETTM)
RC(RETVAL,AMHSTR) ;EP -- return record counts for a file for the BH GUI Search Form (frmSearchSingle, frmSearchMultiple)
N AMHGB
S AMHGB=$G(^DIC(AMHSTR,0,"GL"))_"0)"
I AMHGB'[U S RETVAL=0
S RETVAL=$P($G(@AMHGB),U,4)
I RETVAL="" S RETVAL=0
Q
;
MRUP(RETVAL,AMHSTR) ;EP -- retrieve data from AMHG MOST RECENTLY SELECTED PATIENT file
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,AMHERRR,P,AMHIEN,AMHFL,AMHFIEN,AMHTXT,AMHDT,P
S P="|"
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
S AMHIEN=$P(AMHSTR,P)
S AMHFL=$P(AMHSTR,P,2)
S AMHDT=$P(AMHSTR,P,4)
S @RETVAL@(AMHI)="T00010BMXIEN^T00030Value1^T00050Value2"_$C(30)
I $G(AMHFL)=9002012.2 D POV^AMHGUA(RETVAL,AMHIEN,AMHDT) Q
I '$O(^AMHGMRUP("B",AMHIEN,0)) D Q
. S @RETVAL@(AMHI+1)=$C(31)
I '$D(^AMHGMRUP(AMHIEN,1,AMHFL)) D Q
. S @RETVAL@(AMHI+1)=$C(31)
N AMHDA
S AMHDA=0 F S AMHDA=$O(^AMHGMRUP(AMHIEN,1,AMHFL,1,AMHDA)) Q:'AMHDA D
. I $G(AMHFL)=9002012.2,'$$CHKD^AMHUTIL1(AMHDA,AMHDT) Q
. I $G(AMHFL)=81,'$$CHKCPT^AMHUTIL1(AMHDA,AMHDT) Q
. I $G(AMHFL)=9999999.09 Q:$$ACT(AMHFL,AMHDA,.03) ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
. I $G(AMHFL)=9999999.64 Q:$$ACT(AMHFL,AMHDA,.13) ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
. N AMHVAL1,AMHVAL2
. S AMHVAL1=$$GET1^DIQ(AMHFL,AMHDA,.01)
. S AMHVAL2=$P($G(^AMHGMRUP(AMHIEN,1,AMHFL,1,AMHDA,0)),U,3)
. S AMHI=AMHI+1
. S @RETVAL@(AMHI)=AMHDA_U_AMHVAL1_U_AMHVAL2_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
MRUU(RETVAL,AMHSTR) ;EP -- retrieve data from AMHG MOST RECENTLY SELECTED USER file
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,AMHERRR,P,AMHIEN,AMHFL,AMHFIEN,AMHTXT,AMHDT,P
S P="|"
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
S AMHIEN=$P(AMHSTR,P)
S AMHFL=$P(AMHSTR,P,2)
S AMHDT=$P(AMHSTR,P,4)
S @RETVAL@(AMHI)="T00010BMXIEN^T00030Value1^T00050Value2"_$C(30)
I '$O(^AMHGMRUU("B",AMHIEN,0)) D Q
. S @RETVAL@(AMHI+1)=$C(31)
I '$D(^AMHGMRUU(AMHIEN,1,AMHFL)) D Q
. S @RETVAL@(AMHI+1)=$C(31)
N AMHDA
S AMHDA=0 F S AMHDA=$O(^AMHGMRUU(AMHIEN,1,AMHFL,1,AMHDA)) Q:'AMHDA D
. I $G(AMHFL)=9002012.2,'$$CHKD^AMHUTIL1(AMHDA,AMHDT) Q
. I $G(AMHFL)=81,'$$CHKCPT^AMHUTIL1(AMHDA,AMHDT) Q
. I $G(AMHFL)=9999999.09 Q:$$ACT(AMHFL,AMHDA,.03) ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
. I $G(AMHFL)=9999999.64 Q:$$ACT(AMHFL,AMHDA,.13) ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
. N AMHVAL1,AMHVAL2
. S AMHVAL1=$$GET1^DIQ(AMHFL,AMHDA,.01)
. S AMHVAL2=$P($G(^AMHGMRUU(AMHIEN,1,AMHFL,1,AMHDA,0)),U,3)
. S AMHI=AMHI+1
. S @RETVAL@(AMHI)=AMHDA_U_AMHVAL1_U_AMHVAL2_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
ACT(FL,ADA,FLD) ;-- check to see if the entry is inactive
I $$GET1^DIQ(FL,ADA,FLD,"I") Q 1
Q 0
;
SITE(RETVAL,AMHSTR) ;EP -- get site parameters
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,AMHERRR,P,AMHIEN,R
S P="|",R="~"
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
S AMHIEN=$P(AMHSTR,P)
S @RETVAL@(AMHI)="T00010BMXIEN^T00030TypeofVisit^T00030TypeofHS^T00030DefMHLoc^T00030DefMHComm^T00030DefMHClinic^T00030DefTypeofContact^T00001AskInterpreter^T00001AllowPCCPrbUp^T00030DefSSLoc^T00030DefSSComm^T00030DefSSClinic^T00030DefCDLoc"
S @RETVAL@(AMHI)=@RETVAL@(AMHI)_"^T00030DefCDComm^T00030DefCDClinic^T00030DefOthLoc^T00030DefOthComm^T00030DefOthClinic^T00030DefEHRComm^T00001InteractivePCCLink^T00030DefAppt^T00005Lockout^T00001DeleteOverride"_$C(30)
N AMHTOVI,AMHTOV,AMHTOVS,AMHHSI,AMHHS,AMHHSS,AMHDMLI,AMHDML,AMHDMLS,AMHDMCI,AMHDMC,AMHDMCS,AMHDTOCI,AMHDTOC,AMHDTOCS,AMHAI,AMHDMCLI,AMHDMCL,AMHDMCLS
N AMHAPC,AMHDSLI,AMHDSL,AMHDSLS,AMHDSCI,AMHDSC,AMHDSCS,AMHDSCLI,AMHDSCL,AMHDSCLS,AMHDDLI,AMHDDL,AMHDDLS,AMHDDCI,AMHDDC,AMHDDCS,AMHDDCLI,AMHDDCL,AMHDDCLS
N AMHDOLI,AMHDOL,AMHDOLS,AMHDOCI,AMHDOC,AMHDOCS,AMHDOCLI,AMHDOCL,AMHDOCLS,AMHDECI,AMHDEC,AMHDECS,AMHIPC,AMHAPPT,AMHLOCK,AMHDEL
S AMHTOVI=$$GET1^DIQ(9002013,AMHIEN,.02,"I")
S AMHTOV=$$GET1^DIQ(9002013,AMHIEN,.02)
S AMHTOVS=$S(AMHTOVI:AMHTOVI_R_AMHTOV,1:"")
S AMHHSI=$$GET1^DIQ(9002013,AMHIEN,.04,"I")
S AMHHS=$$GET1^DIQ(9002013,AMHIEN,.04)
S AMHHSS=$S(AMHHSI:AMHHSI_R_AMHHS,1:"")
S AMHDMLI=$$GET1^DIQ(9002013,AMHIEN,.05,"I")
S AMHDML=$$GET1^DIQ(9002013,AMHIEN,.05)
S AMHDMLS=$S(AMHDMLI:AMHDMLI_R_AMHDML,1:"")
S AMHDMCI=$$GET1^DIQ(9002013,AMHIEN,.06,"I")
S AMHDMC=$$GET1^DIQ(9002013,AMHIEN,.06)
S AMHDMCS=$S(AMHDMCI:AMHDMCI_R_AMHDMC,1:"")
S AMHDTOCI=$$GET1^DIQ(9002013,AMHIEN,.09,"I")
S AMHDTOC=$$GET1^DIQ(9002013,AMHIEN,.09)
S AMHDTOCS=$S(AMHDTOCI:AMHDTOCI_R_AMHDTOC,1:"")
S AMHAI=$$GET1^DIQ(9002013,AMHIEN,.11,"I")
S AMHDMCLI=$$GET1^DIQ(9002013,AMHIEN,.17,"I")
S AMHDMCL=$$GET1^DIQ(9002013,AMHIEN,.17)
S AMHDMCLS=$S(AMHDMCLI:AMHDMCLI_R_AMHDMCL,1:"")
S AMHAPC=$$GET1^DIQ(9002013,AMHIEN,.18,"I")
S AMHDSLI=$$GET1^DIQ(9002013,AMHIEN,.19,"I")
S AMHDSL=$$GET1^DIQ(9002013,AMHIEN,.19)
S AMHDSLS=$S(AMHDSLI:AMHDSLI_R_AMHDSL,1:"")
S AMHDSCI=$$GET1^DIQ(9002013,AMHIEN,.21,"I")
S AMHDSC=$$GET1^DIQ(9002013,AMHIEN,.21)
S AMHDSCS=$S(AMHDSCI:AMHDSCI_R_AMHDSC,1:"")
S AMHDSCLI=$$GET1^DIQ(9002013,AMHIEN,.22,"I")
S AMHDSCL=$$GET1^DIQ(9002013,AMHIEN,.22)
S AMHDSCLS=$S(AMHDSCLI:AMHDSCLI_R_AMHDSCL,1:"")
S AMHDDLI=$$GET1^DIQ(9002013,AMHIEN,.28,"I")
S AMHDDL=$$GET1^DIQ(9002013,AMHIEN,.28)
S AMHDDLS=$S(AMHDDLI:AMHDDLI_R_AMHDDL,1:"")
S AMHDDCI=$$GET1^DIQ(9002013,AMHIEN,.29,"I")
S AMHDDC=$$GET1^DIQ(9002013,AMHIEN,.29)
S AMHDDCS=$S(AMHDDCI:AMHDDCI_R_AMHDDC,1:"")
S AMHDDCLI=$$GET1^DIQ(9002013,AMHIEN,.31,"I")
S AMHDDCL=$$GET1^DIQ(9002013,AMHIEN,.31)
S AMHDDCLS=$S(AMHDDCLI:AMHDDCLI_R_AMHDDCL,1:"")
S AMHDOLI=$$GET1^DIQ(9002013,AMHIEN,1801,"I")
S AMHDOL=$$GET1^DIQ(9002013,AMHIEN,1801)
S AMHDOLS=$S(AMHDOLI:AMHDOLI_R_AMHDOL,1:"")
S AMHDOCI=$$GET1^DIQ(9002013,AMHIEN,1802,"I")
S AMHDOC=$$GET1^DIQ(9002013,AMHIEN,1802)
S AMHDOCS=$S(AMHDOCI:AMHDOCI_R_AMHDOC,1:"")
S AMHDOCLI=$$GET1^DIQ(9002013,AMHIEN,1803,"I")
S AMHDOCL=$$GET1^DIQ(9002013,AMHIEN,1803)
S AMHDOCLS=$S(AMHDOCLI:AMHDOCLI_R_AMHDOCL,1:"")
S AMHDECI=$$GET1^DIQ(9002013,AMHIEN,1804,"I")
S AMHDEC=$$GET1^DIQ(9002013,AMHIEN,1804)
S AMHDECS=$S(AMHDECI:AMHDECI_R_AMHDEC,1:"")
S AMHIPC=$S($$GET1^DIQ(9002013,AMHIEN,.33,"I"):"1",1:"0")
S AMHAPPT=$$GET1^DIQ(9002013,AMHIEN,.24)
S AMHLOCK=$S($$GET1^DIQ(9002013,AMHIEN,1809):$$GET1^DIQ(9002013,AMHIEN,1809),$$GET1^DIQ(200,DUZ,200.1):$$GET1^DIQ(200,DUZ,200.1),$$GET1^DIQ(8989.3,1,210):$$GET1^DIQ(8989.3,1,210),1:300)
S AMHDEL=$S($O(^AMHSITE(AMHIEN,21,"B",DUZ,0)):1,1:0) ;get delete override boolean
S AMHI=AMHI+1
S @RETVAL@(AMHI)=AMHIEN_U_AMHTOVS_U_AMHHSS_U_AMHDMLS_U_AMHDMCS_U_AMHDMCLS_U_AMHDTOCS_U_AMHAI_U_AMHAPC_U_AMHDSLS_U_AMHDSCS_U_AMHDSCLS_U_AMHDDLS_U_AMHDDCS_U_AMHDDCLS_U_AMHDOLS_U_AMHDOCS_U_AMHDOCLS_U_AMHDECS_U_AMHIPC_U_AMHAPPT_U_AMHLOCK
S @RETVAL@(AMHI)=@RETVAL@(AMHI)_U_AMHDEL_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
TM(TIME) ;EP -- return time in fileman format
I $L(TIME)=4 D
. I $E(TIME,4,4)=0 S TIME=$E(TIME,1,3)
I $L(TIME)=3 D
. I $E(TIME,3,3)=0 S TIME=$E(TIME,1,2)
I $L(TIME)=2 D
. I $E(TIME,2,2)=0 S TIME=$E(TIME,1,1)
Q $G(TIME)
;
VCDT(VALUE) ;EP -- return date/time into a C# DateTime constructor
N TDT,ETDT,YR,MO,DY,HR,MN,C
S C=","
S TDT=$P(VALUE,".")
S YR=($E(TDT,1,3)+1700)
S MO=$E(TDT,4,5)
S DY=$E(TDT,6,7)
S ETDT=$$FMTE^XLFDT(VALUE)
S TTM=$TR($P(ETDT,"@",2),":")
I $G(TTM) D
. S HR=$E(TTM,1,2)
. S MN=$E(TTM,3,4)
I '$G(TTM) D
. S HR="12"
. S MN="00"
S TM=YR_C_MO_C_DY_C_+$G(HR)_C_+$G(MN)
Q TM
;
FNDNARR(NARR,FLG) ;EP -- find the provider narrative based on input
S APCDOVRR=1
S X=NARR
S DIC="^AUTNPOV(",DIC(0)="L",DLAYGO=9999999.27 D ^DIC
K DLAYGO
Q $S($G(Y)>0:+Y,1:"")
;
GETPRV(IEN,PS) ;EP -- get provider based on ien and type for MHSS RECORD
N DA,PRVI
S DA=0 F S DA=$O(^AMHRPROV("AD",IEN,DA)) Q:'DA D
. Q:$P($G(^AMHRPROV(DA,0)),U,4)'=PS
. S PRVI=$P($G(^AMHRPROV(DA,0)),U)
Q $G(PRVI)
;
FNDPRV(IEN,PS,PIEN) ;EP -- return the ien of the provider entry based upon what is passed in
N DA,PRVI
S DA=0 F S DA=$O(^AMHRPROV("AD",IEN,DA)) Q:'DA D
. Q:$P($G(^AMHRPROV(DA,0)),U,4)'=PS
. I PS="P" D
.. I $P(^AMHRPROV(DA,0),U)'=PIEN D CHNGPP(DA,PIEN)
.. S PRVI=DA
. I PS="S",+$G(^AMHRPROV(DA,0))=PIEN S PRVI=DA
Q $G(PRVI)
;
CHNGPP(D,PI) ;EP -- change the primary provider
N FDA,FIEN,FERR
S FIEN=D_","
S FDA(9002011.02,FIEN,.01)=PI
D FILE^DIE("K","FDA","FERR(1)")
Q
;
FNDCPT(IEN,CIEN) ;EP -- return a 1 if cpt already exists
N DA,CPTI,MAT
S MAT=0
S DA=0 F S DA=$O(^AMHRPROC("AD",IEN,DA)) Q:'DA!($G(MAT)) D
. I $P(^AMHRPROC(DA,0),U)=CIEN S MAT=1 Q
Q $G(MAT)
;
FNDPA(IEN,PIEN) ;EP -- return a 1 if prevention activity already exists
N DA,PTI,MAT
S MAT=0
S DA=0 F S DA=$O(^AMHRPA("AD",IEN,DA)) Q:'DA!($G(MAT)) D
. I $P(^AMHRPA(DA,0),U)=PIEN S MAT=1 Q
Q $G(MAT)
;
FNDPH(IEN,PIEN) ;EP -- return a 1 if persona; history already exists
N DA,PHI,MAT
S MAT=0
S DA=0 F S DA=$O(^AMHPPHX("AA",IEN,DA)) Q:'DA!($G(MAT)) D
. I DA=PIEN S MAT=1 Q
Q $G(MAT)
;
FNDEDU(IEN,EIEN) ;EP -- return ien of education topic
N DA,EDUI
S DA=0 F S DA=$O(^AMHREDU("AD",IEN,DA)) Q:'DA!($G(EDUI)) D
. I $P(^AMHREDU(DA,0),U)=EIEN S EDUI=DA Q
Q $G(EDUI)
;
FNDHF(IEN,HIEN) ;EP -- return ien of health factor
N DA,HFI
S DA=0 F S DA=$O(^AMHRHF("AD",IEN,DA)) Q:'DA!($G(HFI)) D
. I $P(^AMHRHF(DA,0),U)=HIEN S HFI=DA Q
Q $G(HFI)
;
FNDMSR(IEN,MSRIEN) ;EP -- return ien of measurement
N DA,MSRI
S DA=0 F S DA=$O(^AMHRMSR("AD",IEN,DA)) Q:'DA!($G(MSRI)) D
. I $P(^AMHRMSR(DA,0),U)=MSRIEN S MSRI=DA Q
Q $G(MSRI)
;
FNDPOV(IEN,R) ;EP -- find POV based on ien of pov and amhrec ptr
N DA,POV
S POV=0
S DA=0 F S DA=$O(^AMHRPRO("AD",R,DA)) Q:'DA!($G(POV)) D
. N AMHPOV
. S AMHPOV=$P($G(^AMHRPRO(DA,0)),U)
. I AMHPOV=IEN S POV=DA Q
Q $G(POV)
;
PRV(IEN,PRVI) ;EP -- return 1 if the provider was part of the encounter, 0 if not, used to determine records on record selector screen
N DA,PRV
S PRV=0
S DA=0 F S DA=$O(^AMHRPROV("AD",IEN,DA)) Q:'DA D
. I $P($G(^AMHRPROV(DA,0)),U)=PRVI S PRV=1
Q $G(PRV)
;
PRVG(IEN,PRVI) ;EP -- return 1 if the provider was part of the encounter, 0 if not, used to determine records on record selector screen
N DA,PRV
S PRV=0
S DA=0 F S DA=$O(^AMHGROUP(IEN,11,DA)) Q:'DA D
. I $P($G(^AMHGROUP(IEN,11,DA,0)),U)=PRVI S PRV=1
Q $G(PRV)
;
GETPRVG(IEN,PS) ;EP -- get the primary provider for the group
N DA,PRV
S PRV=0
S DA=0 F S DA=$O(^AMHGROUP(IEN,11,DA)) Q:'DA D
. I $P($G(^AMHGROUP(IEN,11,DA,0)),U,2)=PS S PRV=$P($G(^AMHGROUP(IEN,11,DA,0)),U)
Q $G(PRV)
;Q $G(PRV)
;
WP(AMHERRR,AMHFL,AMHIENS,AMHFLD,AMHWP) ;EP - WP
D WP^DIE(AMHFL,AMHIENS,AMHFLD,,"AMHWP","AMHERRR")
Q
;
ACTCODE(IEN) ;EP -- return 1 if admin activity code
N CODE
S CODE=$$GET1^DIQ(9002011,IEN,.06)
I CODE=32 Q 1
I (CODE>49)&(CODE<61) Q 1
I CODE=66 Q 1
Q 0
;
GETREC(PAT,IEN) ;EP -- get the group amhrec entry based on the patient and ien passed in
N DA,RECIEN
S DA=0 F S DA=$O(^AMHGROUP(IEN,61,DA)) Q:'DA D
. N REC
. S REC=$G(^AMHGROUP(IEN,61,DA,0))
. I $P($G(^AMHREC(REC,0)),U,8)=PAT S RECIEN=REC
Q $G(RECIEN)
;
AMHGU ; IHS/CMI/MAW - AMH Behavioral Health GUI Utilities 9/8/2008 2:00:25 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;
+3 ;
DEBUG(RETVAL,AMHSTR) ;replace tag below to allow Serenji debug of GUI
+1 DO DEBUG^%Serenji("GETPAT^AMHGU(.RETVAL,.AMHSTR)")
+2 QUIT
+3 ;
ADO ;EP -- setup the ADO string for each call
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 KILL ^AMHTMP($JOB)
+3 SET RETVAL="^AMHTMP("_$JOB_")"
+4 QUIT
+5 ;
CATSTR(AMHSRET,STR) ;EP -- concatenate a long string in
+1 NEW AMHDA
+2 SET AMHSRET=""
+3 SET AMHDA=0
FOR
SET AMHDA=$ORDER(STR(AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+4 SET AMHSRET=AMHSRET_$GET(STR(AMHDA))
End DoDot:1
+5 QUIT
+6 ;
ARRAY(AMHRET,STR) ;EP -- turn a string from .Net into an array
+1 NEW A
+2 SET A="*"
+3 NEW I,AMHCNT
+4 SET AMHCNT=0
+5 FOR I=1:1
Begin DoDot:1
+6 IF $PIECE(STR,A,I)=""
QUIT
+7 SET AMHCNT=AMHCNT+1
+8 SET AMHRET(AMHCNT)=$TRANSLATE($PIECE(STR,A,I),"^"," ")
End DoDot:1
IF $PIECE(STR,A,I)=""
QUIT
+9 IF $GET(AMHRET(1))=""
SET AMHRET=""
+10 QUIT
+11 ;
ARRAYD(AMHRET,STR,DNUM) ;EP -- turn a string from .Net into an array
+1 NEW A
+2 SET A="*"
+3 NEW I,AMHCNT
+4 SET AMHCNT=0
+5 FOR I=1:1
Begin DoDot:1
+6 IF $PIECE(STR,A,I)=""
QUIT
+7 ;S AMHCNT=AMHCNT+1
+8 SET AMHRET(DNUM)=$TRANSLATE($PIECE(STR,A,I),"^"," ")
End DoDot:1
IF $PIECE(STR,A,I)=""
QUIT
+9 IF $GET(AMHRET(1))=""
SET AMHRET=""
+10 QUIT
+11 ;
ARRAYTO(AMHRET,STR) ;EP -- break a long wp field into pieces for filing into a WP field
+1 KILL AMHRET
+2 NEW I,LN,CN,SCN,TCN,ST
+3 SET CN=0
+4 SET SCN=1
+5 SET TCN=0
+6 SET ST=1
+7 SET STR=$TRANSLATE(STR,"^"," ")
+8 SET LN=$LENGTH(STR)
+9 IF STR[$CHAR(10)
Begin DoDot:1
+10 SET LN=$LENGTH(STR,$CHAR(10))
+11 ;Q:$P(STR,$C(10),I)=""
FOR I=1:1
Begin DoDot:2
+12 ;Q:$P(STR,$C(10),I)=""
+13 IF (CN+1)>LN
QUIT
+14 NEW CH
+15 SET CH=$PIECE(STR,$CHAR(10),I)
+16 SET CN=CN+1
+17 SET AMHRET(SCN)=CH_$CHAR(10)
+18 SET SCN=SCN+1
End DoDot:2
IF (CN+1)>LN
QUIT
End DoDot:1
QUIT
+19 FOR I=1:1
Begin DoDot:1
+20 NEW CH
+21 SET CH=$EXTRACT(STR,I,I)
+22 SET CN=CN+1
+23 SET TCN=TCN+1
+24 IF TCN>65
IF CH=" "
Begin DoDot:2
+25 SET AMHRET(SCN)=$EXTRACT(STR,ST,CN)
+26 SET ST=CN+1
+27 SET SCN=SCN+1
+28 SET TCN=0
End DoDot:2
End DoDot:1
IF I>LN
QUIT
+29 SET AMHRET(SCN)=$EXTRACT(STR,ST,CN)
+30 QUIT
+31 ;
ARRAYT(AMHRET,STR) ;EP -- break a long wp field into pieces for filing into a WP field
+1 KILL AMHRET
+2 NEW I,CN,SCN,TCN,ST
+3 NEW LN
+4 SET CN=0
+5 SET SCN=1
+6 SET TCN=0
+7 SET ST=1
+8 SET STR=$TRANSLATE(STR,"^"," ")
+9 SET LN=$LENGTH(STR)
+10 ;4.0p1 so multiple doesnt get created
IF LN=0
SET AMHRET=""
QUIT
+11 FOR I=1:1:LN
Begin DoDot:1
+12 NEW CHAR
+13 SET CHAR=$EXTRACT(STR,I,I)
+14 SET CN=CN+1
+15 SET TCN=TCN+1
+16 IF CHAR=$CHAR(10)
Begin DoDot:2
+17 ;_$C(10)
SET AMHRET(SCN)=$EXTRACT(STR,ST,CN)
+18 SET ST=CN+1
+19 SET SCN=SCN+1
+20 SET TCN=0
End DoDot:2
QUIT
+21 IF TCN>65
IF CHAR=" "
Begin DoDot:2
+22 SET AMHRET(SCN)=$EXTRACT(STR,ST,CN)
+23 SET ST=CN+1
+24 SET SCN=SCN+1
+25 SET TCN=0
End DoDot:2
QUIT
End DoDot:1
IF I>LN
QUIT
+26 IF $EXTRACT(STR,ST,CN)'=""
SET AMHRET(SCN)=$EXTRACT(STR,ST,CN)
+27 IF $GET(AMHRET(SCN))=""
KILL AMHRET(SCN)
+28 QUIT
+29 ;
MERR ; MUMPS ERROR TRAP
+1 NEW AMHX
+2 XECUTE ("S AMHX=$"_"ZE")
+3 SET AMHX="MUMPS error: """_AMHX_""""
+4 DO ^%ZTER
+5 DO ERR(AMHX)
+6 QUIT
+7 ;
ERR(ERR) ; BMX ADO SCHEMA ERROR PROCESSOR
+1 NEW AMHXA
+2 SET AMHXA="M ERROR|"_ERR_$CHAR(30)
+3 SET @RETVAL@(1)=AMHXA
+4 QUIT
+5 ;
KEYS(RETVAL,AMHSTR) ;EP -- return keys for user
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHDA,AMHNS,P,AMHDATA,AMHKEYI,AMHKEY,AMHI
+3 SET AMHI=0
+4 KILL ^AMHTMP($JOB)
+5 SET RETVAL="^AMHTMP("_$JOB_")"
+6 SET ^AMHTMP($JOB,AMHI)="T00030KEYS"_$CHAR(30)
+7 SET P="|"
+8 SET AMHNS=$PIECE(AMHSTR,P)
+9 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^VA(200,DUZ,51,AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+10 SET AMHDATA=$GET(^VA(200,DUZ,51,AMHDA,0))
+11 SET AMHKEYI=$PIECE(AMHDATA,U)
+12 SET AMHKEY=$PIECE($GET(^DIC(19.1,AMHKEYI,0)),U)
+13 IF AMHNS'="*"
IF $EXTRACT(AMHKEY,1,$LENGTH(AMHNS))'[AMHNS
QUIT
+14 SET AMHI=AMHI+1
+15 SET ^AMHTMP($JOB,AMHI)=AMHKEY_$CHAR(30)
End DoDot:1
+16 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
+17 QUIT
+18 ;
LVDT(PDT) ;EP - return date for list view format
+1 IF PDT=""
QUIT ""
+2 QUIT $EXTRACT(PDT,4,5)_"/"_$EXTRACT(PDT,6,7)_"/"_($EXTRACT(PDT,1,3)+1700)
+3 ;
TIME(TM) ;EP -- return time in .Net format
+1 NEW DOTNETTM
+2 SET DOTNETTM=$SELECT(($EXTRACT(TM,1,2)>12):$EXTRACT(TM,1,2)_":"_$EXTRACT(TM,3,4)_" PM",1:$EXTRACT(TM,1,2)_":"_$EXTRACT(TM,3,4)_" AM")
+3 QUIT $GET(DOTNETTM)
RC(RETVAL,AMHSTR) ;EP -- return record counts for a file for the BH GUI Search Form (frmSearchSingle, frmSearchMultiple)
+1 NEW AMHGB
+2 SET AMHGB=$GET(^DIC(AMHSTR,0,"GL"))_"0)"
+3 IF AMHGB'[U
SET RETVAL=0
+4 SET RETVAL=$PIECE($GET(@AMHGB),U,4)
+5 IF RETVAL=""
SET RETVAL=0
+6 QUIT
+7 ;
MRUP(RETVAL,AMHSTR) ;EP -- retrieve data from AMHG MOST RECENTLY SELECTED PATIENT file
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,AMHERRR,P,AMHIEN,AMHFL,AMHFIEN,AMHTXT,AMHDT,P
+3 SET P="|"
+4 KILL ^AMHTMP($JOB)
+5 SET RETVAL="^AMHTMP("_$JOB_")"
+6 SET AMHI=0
+7 SET AMHIEN=$PIECE(AMHSTR,P)
+8 SET AMHFL=$PIECE(AMHSTR,P,2)
+9 SET AMHDT=$PIECE(AMHSTR,P,4)
+10 SET @RETVAL@(AMHI)="T00010BMXIEN^T00030Value1^T00050Value2"_$CHAR(30)
+11 IF $GET(AMHFL)=9002012.2
DO POV^AMHGUA(RETVAL,AMHIEN,AMHDT)
QUIT
+12 IF '$ORDER(^AMHGMRUP("B",AMHIEN,0))
Begin DoDot:1
+13 SET @RETVAL@(AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+14 IF '$DATA(^AMHGMRUP(AMHIEN,1,AMHFL))
Begin DoDot:1
+15 SET @RETVAL@(AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+16 NEW AMHDA
+17 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AMHGMRUP(AMHIEN,1,AMHFL,1,AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+18 IF $GET(AMHFL)=9002012.2
IF '$$CHKD^AMHUTIL1(AMHDA,AMHDT)
QUIT
+19 IF $GET(AMHFL)=81
IF '$$CHKCPT^AMHUTIL1(AMHDA,AMHDT)
QUIT
+20 ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
IF $GET(AMHFL)=9999999.09
IF $$ACT(AMHFL,AMHDA,.03)
QUIT
+21 ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
IF $GET(AMHFL)=9999999.64
IF $$ACT(AMHFL,AMHDA,.13)
QUIT
+22 NEW AMHVAL1,AMHVAL2
+23 SET AMHVAL1=$$GET1^DIQ(AMHFL,AMHDA,.01)
+24 SET AMHVAL2=$PIECE($GET(^AMHGMRUP(AMHIEN,1,AMHFL,1,AMHDA,0)),U,3)
+25 SET AMHI=AMHI+1
+26 SET @RETVAL@(AMHI)=AMHDA_U_AMHVAL1_U_AMHVAL2_$CHAR(30)
End DoDot:1
+27 SET @RETVAL@(AMHI+1)=$CHAR(31)
+28 QUIT
+29 ;
MRUU(RETVAL,AMHSTR) ;EP -- retrieve data from AMHG MOST RECENTLY SELECTED USER file
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,AMHERRR,P,AMHIEN,AMHFL,AMHFIEN,AMHTXT,AMHDT,P
+3 SET P="|"
+4 KILL ^AMHTMP($JOB)
+5 SET RETVAL="^AMHTMP("_$JOB_")"
+6 SET AMHI=0
+7 SET AMHIEN=$PIECE(AMHSTR,P)
+8 SET AMHFL=$PIECE(AMHSTR,P,2)
+9 SET AMHDT=$PIECE(AMHSTR,P,4)
+10 SET @RETVAL@(AMHI)="T00010BMXIEN^T00030Value1^T00050Value2"_$CHAR(30)
+11 IF '$ORDER(^AMHGMRUU("B",AMHIEN,0))
Begin DoDot:1
+12 SET @RETVAL@(AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+13 IF '$DATA(^AMHGMRUU(AMHIEN,1,AMHFL))
Begin DoDot:1
+14 SET @RETVAL@(AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+15 NEW AMHDA
+16 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AMHGMRUU(AMHIEN,1,AMHFL,1,AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+17 IF $GET(AMHFL)=9002012.2
IF '$$CHKD^AMHUTIL1(AMHDA,AMHDT)
QUIT
+18 IF $GET(AMHFL)=81
IF '$$CHKCPT^AMHUTIL1(AMHDA,AMHDT)
QUIT
+19 ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
IF $GET(AMHFL)=9999999.09
IF $$ACT(AMHFL,AMHDA,.03)
QUIT
+20 ;ihs/cmi/maw 12/21/2010 v4.0p1 check inactivity
IF $GET(AMHFL)=9999999.64
IF $$ACT(AMHFL,AMHDA,.13)
QUIT
+21 NEW AMHVAL1,AMHVAL2
+22 SET AMHVAL1=$$GET1^DIQ(AMHFL,AMHDA,.01)
+23 SET AMHVAL2=$PIECE($GET(^AMHGMRUU(AMHIEN,1,AMHFL,1,AMHDA,0)),U,3)
+24 SET AMHI=AMHI+1
+25 SET @RETVAL@(AMHI)=AMHDA_U_AMHVAL1_U_AMHVAL2_$CHAR(30)
End DoDot:1
+26 SET @RETVAL@(AMHI+1)=$CHAR(31)
+27 QUIT
+28 ;
ACT(FL,ADA,FLD) ;-- check to see if the entry is inactive
+1 IF $$GET1^DIQ(FL,ADA,FLD,"I")
QUIT 1
+2 QUIT 0
+3 ;
SITE(RETVAL,AMHSTR) ;EP -- get site parameters
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,AMHERRR,P,AMHIEN,R
+3 SET P="|"
SET R="~"
+4 KILL ^AMHTMP($JOB)
+5 SET RETVAL="^AMHTMP("_$JOB_")"
+6 SET AMHI=0
+7 SET AMHIEN=$PIECE(AMHSTR,P)
+8 SET @RETVAL@(AMHI)="T00010BMXIEN^T00030TypeofVisit^T00030TypeofHS^T00030DefMHLoc^T00030DefMHComm^T00030DefMHClinic^T00030DefTypeofContact^T00001AskInterpreter^T00001AllowPCCPrbUp^T00030DefSSLoc^T00030DefSSComm^T00030DefSSClinic^T00030DefCDLoc"
+9 SET @RETVAL@(AMHI)=@RETVAL@(AMHI)_"^T00030DefCDComm^T00030DefCDClinic^T00030DefOthLoc^T00030DefOthComm^T00030DefOthClinic^T00030DefEHRComm^T00001InteractivePCCLink^T00030DefAppt^T00005Lockout^T00001DeleteOverride"_$CHAR(30)
+10 NEW AMHTOVI,AMHTOV,AMHTOVS,AMHHSI,AMHHS,AMHHSS,AMHDMLI,AMHDML,AMHDMLS,AMHDMCI,AMHDMC,AMHDMCS,AMHDTOCI,AMHDTOC,AMHDTOCS,AMHAI,AMHDMCLI,AMHDMCL,AMHDMCLS
+11 NEW AMHAPC,AMHDSLI,AMHDSL,AMHDSLS,AMHDSCI,AMHDSC,AMHDSCS,AMHDSCLI,AMHDSCL,AMHDSCLS,AMHDDLI,AMHDDL,AMHDDLS,AMHDDCI,AMHDDC,AMHDDCS,AMHDDCLI,AMHDDCL,AMHDDCLS
+12 NEW AMHDOLI,AMHDOL,AMHDOLS,AMHDOCI,AMHDOC,AMHDOCS,AMHDOCLI,AMHDOCL,AMHDOCLS,AMHDECI,AMHDEC,AMHDECS,AMHIPC,AMHAPPT,AMHLOCK,AMHDEL
+13 SET AMHTOVI=$$GET1^DIQ(9002013,AMHIEN,.02,"I")
+14 SET AMHTOV=$$GET1^DIQ(9002013,AMHIEN,.02)
+15 SET AMHTOVS=$SELECT(AMHTOVI:AMHTOVI_R_AMHTOV,1:"")
+16 SET AMHHSI=$$GET1^DIQ(9002013,AMHIEN,.04,"I")
+17 SET AMHHS=$$GET1^DIQ(9002013,AMHIEN,.04)
+18 SET AMHHSS=$SELECT(AMHHSI:AMHHSI_R_AMHHS,1:"")
+19 SET AMHDMLI=$$GET1^DIQ(9002013,AMHIEN,.05,"I")
+20 SET AMHDML=$$GET1^DIQ(9002013,AMHIEN,.05)
+21 SET AMHDMLS=$SELECT(AMHDMLI:AMHDMLI_R_AMHDML,1:"")
+22 SET AMHDMCI=$$GET1^DIQ(9002013,AMHIEN,.06,"I")
+23 SET AMHDMC=$$GET1^DIQ(9002013,AMHIEN,.06)
+24 SET AMHDMCS=$SELECT(AMHDMCI:AMHDMCI_R_AMHDMC,1:"")
+25 SET AMHDTOCI=$$GET1^DIQ(9002013,AMHIEN,.09,"I")
+26 SET AMHDTOC=$$GET1^DIQ(9002013,AMHIEN,.09)
+27 SET AMHDTOCS=$SELECT(AMHDTOCI:AMHDTOCI_R_AMHDTOC,1:"")
+28 SET AMHAI=$$GET1^DIQ(9002013,AMHIEN,.11,"I")
+29 SET AMHDMCLI=$$GET1^DIQ(9002013,AMHIEN,.17,"I")
+30 SET AMHDMCL=$$GET1^DIQ(9002013,AMHIEN,.17)
+31 SET AMHDMCLS=$SELECT(AMHDMCLI:AMHDMCLI_R_AMHDMCL,1:"")
+32 SET AMHAPC=$$GET1^DIQ(9002013,AMHIEN,.18,"I")
+33 SET AMHDSLI=$$GET1^DIQ(9002013,AMHIEN,.19,"I")
+34 SET AMHDSL=$$GET1^DIQ(9002013,AMHIEN,.19)
+35 SET AMHDSLS=$SELECT(AMHDSLI:AMHDSLI_R_AMHDSL,1:"")
+36 SET AMHDSCI=$$GET1^DIQ(9002013,AMHIEN,.21,"I")
+37 SET AMHDSC=$$GET1^DIQ(9002013,AMHIEN,.21)
+38 SET AMHDSCS=$SELECT(AMHDSCI:AMHDSCI_R_AMHDSC,1:"")
+39 SET AMHDSCLI=$$GET1^DIQ(9002013,AMHIEN,.22,"I")
+40 SET AMHDSCL=$$GET1^DIQ(9002013,AMHIEN,.22)
+41 SET AMHDSCLS=$SELECT(AMHDSCLI:AMHDSCLI_R_AMHDSCL,1:"")
+42 SET AMHDDLI=$$GET1^DIQ(9002013,AMHIEN,.28,"I")
+43 SET AMHDDL=$$GET1^DIQ(9002013,AMHIEN,.28)
+44 SET AMHDDLS=$SELECT(AMHDDLI:AMHDDLI_R_AMHDDL,1:"")
+45 SET AMHDDCI=$$GET1^DIQ(9002013,AMHIEN,.29,"I")
+46 SET AMHDDC=$$GET1^DIQ(9002013,AMHIEN,.29)
+47 SET AMHDDCS=$SELECT(AMHDDCI:AMHDDCI_R_AMHDDC,1:"")
+48 SET AMHDDCLI=$$GET1^DIQ(9002013,AMHIEN,.31,"I")
+49 SET AMHDDCL=$$GET1^DIQ(9002013,AMHIEN,.31)
+50 SET AMHDDCLS=$SELECT(AMHDDCLI:AMHDDCLI_R_AMHDDCL,1:"")
+51 SET AMHDOLI=$$GET1^DIQ(9002013,AMHIEN,1801,"I")
+52 SET AMHDOL=$$GET1^DIQ(9002013,AMHIEN,1801)
+53 SET AMHDOLS=$SELECT(AMHDOLI:AMHDOLI_R_AMHDOL,1:"")
+54 SET AMHDOCI=$$GET1^DIQ(9002013,AMHIEN,1802,"I")
+55 SET AMHDOC=$$GET1^DIQ(9002013,AMHIEN,1802)
+56 SET AMHDOCS=$SELECT(AMHDOCI:AMHDOCI_R_AMHDOC,1:"")
+57 SET AMHDOCLI=$$GET1^DIQ(9002013,AMHIEN,1803,"I")
+58 SET AMHDOCL=$$GET1^DIQ(9002013,AMHIEN,1803)
+59 SET AMHDOCLS=$SELECT(AMHDOCLI:AMHDOCLI_R_AMHDOCL,1:"")
+60 SET AMHDECI=$$GET1^DIQ(9002013,AMHIEN,1804,"I")
+61 SET AMHDEC=$$GET1^DIQ(9002013,AMHIEN,1804)
+62 SET AMHDECS=$SELECT(AMHDECI:AMHDECI_R_AMHDEC,1:"")
+63 SET AMHIPC=$SELECT($$GET1^DIQ(9002013,AMHIEN,.33,"I"):"1",1:"0")
+64 SET AMHAPPT=$$GET1^DIQ(9002013,AMHIEN,.24)
+65 SET AMHLOCK=$SELECT($$GET1^DIQ(9002013,AMHIEN,1809):$$GET1^DIQ(9002013,AMHIEN,1809),$$GET1^DIQ(200,DUZ,200.1):$$GET1^DIQ(200,DUZ,200.1),$$GET1^DIQ(8989.3,1,210):$$GET1^DIQ(8989.3,1,210),1:300)
+66 ;get delete override boolean
SET AMHDEL=$SELECT($ORDER(^AMHSITE(AMHIEN,21,"B",DUZ,0)):1,1:0)
+67 SET AMHI=AMHI+1
+68 SET @RETVAL@(AMHI)=AMHIEN_U_AMHTOVS_U_AMHHSS_U_AMHDMLS_U_AMHDMCS_U_AMHDMCLS_U_AMHDTOCS_U_AMHAI_U_AMHAPC_U_AMHDSLS_U_AMHDSCS_U_AMHDSCLS_U_AMHDDLS_U_AMHDDCS_U_AMHDDCLS_U_AMHDOLS_U_AMHDOCS_U_AMHDOCLS_U_AMHDECS_U_AMHIPC_U_AMHAPPT_U_AMHLOCK
+69 SET @RETVAL@(AMHI)=@RETVAL@(AMHI)_U_AMHDEL_$CHAR(30)
+70 SET @RETVAL@(AMHI+1)=$CHAR(31)
+71 QUIT
+72 ;
TM(TIME) ;EP -- return time in fileman format
+1 IF $LENGTH(TIME)=4
Begin DoDot:1
+2 IF $EXTRACT(TIME,4,4)=0
SET TIME=$EXTRACT(TIME,1,3)
End DoDot:1
+3 IF $LENGTH(TIME)=3
Begin DoDot:1
+4 IF $EXTRACT(TIME,3,3)=0
SET TIME=$EXTRACT(TIME,1,2)
End DoDot:1
+5 IF $LENGTH(TIME)=2
Begin DoDot:1
+6 IF $EXTRACT(TIME,2,2)=0
SET TIME=$EXTRACT(TIME,1,1)
End DoDot:1
+7 QUIT $GET(TIME)
+8 ;
VCDT(VALUE) ;EP -- return date/time into a C# DateTime constructor
+1 NEW TDT,ETDT,YR,MO,DY,HR,MN,C
+2 SET C=","
+3 SET TDT=$PIECE(VALUE,".")
+4 SET YR=($EXTRACT(TDT,1,3)+1700)
+5 SET MO=$EXTRACT(TDT,4,5)
+6 SET DY=$EXTRACT(TDT,6,7)
+7 SET ETDT=$$FMTE^XLFDT(VALUE)
+8 SET TTM=$TRANSLATE($PIECE(ETDT,"@",2),":")
+9 IF $GET(TTM)
Begin DoDot:1
+10 SET HR=$EXTRACT(TTM,1,2)
+11 SET MN=$EXTRACT(TTM,3,4)
End DoDot:1
+12 IF '$GET(TTM)
Begin DoDot:1
+13 SET HR="12"
+14 SET MN="00"
End DoDot:1
+15 SET TM=YR_C_MO_C_DY_C_+$GET(HR)_C_+$GET(MN)
+16 QUIT TM
+17 ;
FNDNARR(NARR,FLG) ;EP -- find the provider narrative based on input
+1 SET APCDOVRR=1
+2 SET X=NARR
+3 SET DIC="^AUTNPOV("
SET DIC(0)="L"
SET DLAYGO=9999999.27
DO ^DIC
+4 KILL DLAYGO
+5 QUIT $SELECT($GET(Y)>0:+Y,1:"")
+6 ;
GETPRV(IEN,PS) ;EP -- get provider based on ien and type for MHSS RECORD
+1 NEW DA,PRVI
+2 SET DA=0
FOR
SET DA=$ORDER(^AMHRPROV("AD",IEN,DA))
IF 'DA
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AMHRPROV(DA,0)),U,4)'=PS
QUIT
+4 SET PRVI=$PIECE($GET(^AMHRPROV(DA,0)),U)
End DoDot:1
+5 QUIT $GET(PRVI)
+6 ;
FNDPRV(IEN,PS,PIEN) ;EP -- return the ien of the provider entry based upon what is passed in
+1 NEW DA,PRVI
+2 SET DA=0
FOR
SET DA=$ORDER(^AMHRPROV("AD",IEN,DA))
IF 'DA
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AMHRPROV(DA,0)),U,4)'=PS
QUIT
+4 IF PS="P"
Begin DoDot:2
+5 IF $PIECE(^AMHRPROV(DA,0),U)'=PIEN
DO CHNGPP(DA,PIEN)
+6 SET PRVI=DA
End DoDot:2
+7 IF PS="S"
IF +$GET(^AMHRPROV(DA,0))=PIEN
SET PRVI=DA
End DoDot:1
+8 QUIT $GET(PRVI)
+9 ;
CHNGPP(D,PI) ;EP -- change the primary provider
+1 NEW FDA,FIEN,FERR
+2 SET FIEN=D_","
+3 SET FDA(9002011.02,FIEN,.01)=PI
+4 DO FILE^DIE("K","FDA","FERR(1)")
+5 QUIT
+6 ;
FNDCPT(IEN,CIEN) ;EP -- return a 1 if cpt already exists
+1 NEW DA,CPTI,MAT
+2 SET MAT=0
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHRPROC("AD",IEN,DA))
IF 'DA!($GET(MAT))
QUIT
Begin DoDot:1
+4 IF $PIECE(^AMHRPROC(DA,0),U)=CIEN
SET MAT=1
QUIT
End DoDot:1
+5 QUIT $GET(MAT)
+6 ;
FNDPA(IEN,PIEN) ;EP -- return a 1 if prevention activity already exists
+1 NEW DA,PTI,MAT
+2 SET MAT=0
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHRPA("AD",IEN,DA))
IF 'DA!($GET(MAT))
QUIT
Begin DoDot:1
+4 IF $PIECE(^AMHRPA(DA,0),U)=PIEN
SET MAT=1
QUIT
End DoDot:1
+5 QUIT $GET(MAT)
+6 ;
FNDPH(IEN,PIEN) ;EP -- return a 1 if persona; history already exists
+1 NEW DA,PHI,MAT
+2 SET MAT=0
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHPPHX("AA",IEN,DA))
IF 'DA!($GET(MAT))
QUIT
Begin DoDot:1
+4 IF DA=PIEN
SET MAT=1
QUIT
End DoDot:1
+5 QUIT $GET(MAT)
+6 ;
FNDEDU(IEN,EIEN) ;EP -- return ien of education topic
+1 NEW DA,EDUI
+2 SET DA=0
FOR
SET DA=$ORDER(^AMHREDU("AD",IEN,DA))
IF 'DA!($GET(EDUI))
QUIT
Begin DoDot:1
+3 IF $PIECE(^AMHREDU(DA,0),U)=EIEN
SET EDUI=DA
QUIT
End DoDot:1
+4 QUIT $GET(EDUI)
+5 ;
FNDHF(IEN,HIEN) ;EP -- return ien of health factor
+1 NEW DA,HFI
+2 SET DA=0
FOR
SET DA=$ORDER(^AMHRHF("AD",IEN,DA))
IF 'DA!($GET(HFI))
QUIT
Begin DoDot:1
+3 IF $PIECE(^AMHRHF(DA,0),U)=HIEN
SET HFI=DA
QUIT
End DoDot:1
+4 QUIT $GET(HFI)
+5 ;
FNDMSR(IEN,MSRIEN) ;EP -- return ien of measurement
+1 NEW DA,MSRI
+2 SET DA=0
FOR
SET DA=$ORDER(^AMHRMSR("AD",IEN,DA))
IF 'DA!($GET(MSRI))
QUIT
Begin DoDot:1
+3 IF $PIECE(^AMHRMSR(DA,0),U)=MSRIEN
SET MSRI=DA
QUIT
End DoDot:1
+4 QUIT $GET(MSRI)
+5 ;
FNDPOV(IEN,R) ;EP -- find POV based on ien of pov and amhrec ptr
+1 NEW DA,POV
+2 SET POV=0
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHRPRO("AD",R,DA))
IF 'DA!($GET(POV))
QUIT
Begin DoDot:1
+4 NEW AMHPOV
+5 SET AMHPOV=$PIECE($GET(^AMHRPRO(DA,0)),U)
+6 IF AMHPOV=IEN
SET POV=DA
QUIT
End DoDot:1
+7 QUIT $GET(POV)
+8 ;
PRV(IEN,PRVI) ;EP -- return 1 if the provider was part of the encounter, 0 if not, used to determine records on record selector screen
+1 NEW DA,PRV
+2 SET PRV=0
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHRPROV("AD",IEN,DA))
IF 'DA
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AMHRPROV(DA,0)),U)=PRVI
SET PRV=1
End DoDot:1
+5 QUIT $GET(PRV)
+6 ;
PRVG(IEN,PRVI) ;EP -- return 1 if the provider was part of the encounter, 0 if not, used to determine records on record selector screen
+1 NEW DA,PRV
+2 SET PRV=0
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHGROUP(IEN,11,DA))
IF 'DA
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AMHGROUP(IEN,11,DA,0)),U)=PRVI
SET PRV=1
End DoDot:1
+5 QUIT $GET(PRV)
+6 ;
GETPRVG(IEN,PS) ;EP -- get the primary provider for the group
+1 NEW DA,PRV
+2 SET PRV=0
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHGROUP(IEN,11,DA))
IF 'DA
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AMHGROUP(IEN,11,DA,0)),U,2)=PS
SET PRV=$PIECE($GET(^AMHGROUP(IEN,11,DA,0)),U)
End DoDot:1
+5 QUIT $GET(PRV)
+6 ;Q $G(PRV)
+7 ;
WP(AMHERRR,AMHFL,AMHIENS,AMHFLD,AMHWP) ;EP - WP
+1 DO WP^DIE(AMHFL,AMHIENS,AMHFLD,,"AMHWP","AMHERRR")
+2 QUIT
+3 ;
ACTCODE(IEN) ;EP -- return 1 if admin activity code
+1 NEW CODE
+2 SET CODE=$$GET1^DIQ(9002011,IEN,.06)
+3 IF CODE=32
QUIT 1
+4 IF (CODE>49)&(CODE<61)
QUIT 1
+5 IF CODE=66
QUIT 1
+6 QUIT 0
+7 ;
GETREC(PAT,IEN) ;EP -- get the group amhrec entry based on the patient and ien passed in
+1 NEW DA,RECIEN
+2 SET DA=0
FOR
SET DA=$ORDER(^AMHGROUP(IEN,61,DA))
IF 'DA
QUIT
Begin DoDot:1
+3 NEW REC
+4 SET REC=$GET(^AMHGROUP(IEN,61,DA,0))
+5 IF $PIECE($GET(^AMHREC(REC,0)),U,8)=PAT
SET RECIEN=REC
End DoDot:1
+6 QUIT $GET(RECIEN)
+7 ;
