AMHGU.m

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)