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

AMHGT.m

Go to the documentation of this file. 
  1. AMHGT ; IHS/CMI/MAW - AMH Behavioral Health GUI Tables 9/30/2008 10:31:41 AM ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**2,4,9**;JUN 02, 2010;Build 11
  1.  ;
  1.  ;
  1.  ;
  1. DEBUG(RETVAL,AMHSTR) ;-- debug entry point
  1.  D DEBUG^%Serenji("SEARCH^AMHGT(.RETVAL,.AMHSTR)")
  1.  Q
  1.  ;
  1.  ;
  1.  ;
  1. HS(RETVAL) ;-- get all health summary types
  1.  S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
  1.  K ^AMHTMP($J)
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  N AMHERRR,AMHI,AMHHS
  1.  S AMHI=0
  1.  S AMHERRR=""
  1.  S @RETVAL@(AMHI)="T00080HealthSummary"_$C(30)
  1.  S AMHHS=0 F  S AMHHS=$O(^APCHSCTL("B",AMHHS)) Q:AMHHS=""  D
  1.  . S AMHI=AMHI+1
  1.  . S @RETVAL@(AMHI)=AMHHS_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. FILES(RETVAL) ;-- get all files in the system for searching later on
  1.  N AMHDA,AMHI
  1.  S AMHI=0
  1.  D ADO^AMHGU
  1.  S @RETVAL@(0)="T00050FileName^T00010NumberOfRecords"_$C(30)
  1.  S AMHDA=0 F  S AMHDA=$O(^DIC(AMHDA)) Q:'AMHDA  D
  1.  . N AMHFL,AMHGB,AMHREC
  1.  . S AMHFL=$P($G(^DIC(AMHDA,0)),U)
  1.  . S AMHGB=$G(^DIC(AMHDA,0,"GL"))_"0)"
  1.  . Q:AMHGB'[U
  1.  . S AMHREC=$P($G(@AMHGB),U,4)
  1.  . S AMHI=AMHI+1
  1.  . S @RETVAL@(AMHI)=AMHFL_U_AMHREC_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. SEARCHO(RETVAL,AMHSTR) ;-- return search results to frmSearchSingle and frmSearchMultiple
  1.  N AMHDA,AMHI,P,AMHFL,AMHIDX,AMHGB,AMHS,AMHSZ,AMHL
  1.  S P="|"
  1.  S AMHI=0
  1.  D ADO^AMHGU
  1.  S AMHFL=$P(AMHSTR,P)
  1.  S AMHIDX=$P(AMHSTR,P,2)
  1.  S AMHS=$P(AMHSTR,P,3)
  1.  S AMHFLD1=$P(AMHSTR,P,4)
  1.  S AMHFLD2=$P(AMHSTR,P,5)
  1.  I AMHFLD1["." S AMHFLD1=+AMHFLD1
  1.  I AMHFLD2["." S AMHFLD2=+AMHFLD2
  1.  S AMHL=$L(AMHS)  ;length of string
  1.  I AMHS]"",AMHS'?.N D
  1.  . S AMHDA=AMHS
  1.  . S AMHSZ=AMHS_"Z"
  1.  I AMHS]"",AMHS?.N  D
  1.  . S AMHDA=AMHS
  1.  . S AMHSZ=AMHS_"99999999"
  1.  I $G(AMHDA)="" S AMHDA=0
  1.  S @RETVAL@(0)="T00010BMXIEN^T00050Value1^T00080Value2"_$C(30)
  1.  S AMHGB=$G(^DIC(AMHFL,0,"GL"))_""""_AMHIDX_""""_")"
  1.  F  S AMHDA=$O(@AMHGB@(AMHDA)) Q:AMHDA=""!($E(AMHDA,1,AMHL)'=AMHS)  D
  1.  . N AMHIEN
  1.  . S AMHIEN=0 F  S AMHIEN=$O(@AMHGB@(AMHDA,AMHIEN)) Q:'AMHIEN  D
  1.  .. N AMHVAL1,AMHVAL2
  1.  .. S AMHVAL1=$$GET1^DIQ(AMHFL,AMHIEN,AMHFLD1)
  1.  .. I $G(AMHFLD2)]"" S AMHVAL2=$$GET1^DIQ(AMHFL,AMHIEN,AMHFLD2)
  1.  .. S AMHI=AMHI+1
  1.  .. S @RETVAL@(AMHI)=AMHIEN_U_AMHVAL1_U_$G(AMHVAL2)_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1.  N AMHDA,AMHI,P,AMHFL,AMHIDX,AMHGB,AMHS,AMHSZ,AMHL,AMHTGT,AMHFLDS,AMHSCR,AMHPR,AMHFLD1,AMHFLD2,AMHDT,AMHECD
  1.  S P="|"
  1.  S AMHI=0
  1.  D ADO^AMHGU
  1.  K ^AMHTMPD($J)
  1.  S AMHTGT="^AMHTMPD("_$J_")"  ;target for find^dic lookup
  1.  S AMHFL=$P(AMHSTR,P)
  1.  S AMHIDX=$P(AMHSTR,P,2)
  1.  I AMHIDX]"" S AMHIDX=$TR(AMHIDX,"*","^")
  1.  S AMHS=$P(AMHSTR,P,3)
  1.  I AMHFL=9999999.64 D HF(AMHS,"F") I $P($G(@RETVAL@(1)),U,2)]"" Q
  1.  I AMHFL=9999999.64,$P($G(@RETVAL@(1)),U,2)']"" D HF(AMHS,"B") Q
  1.  I AMHFL=9002012.2,AMHS="" S AMHIDX="BA"
  1.  S AMHFLD1=$P(AMHSTR,P,4)
  1.  S AMHFLD2=$P(AMHSTR,P,5)
  1.  S AMHSCR=$P(AMHSTR,P,6)
  1.  I AMHSCR="E" D  ;this is for e codes
  1.  . I $E(AMHS,1,1)'="E" S AMHS="E"_AMHS  ;add the e code to e code lookup
  1.  . S AMHECD=1
  1.  . S AMHSCR=""  ;if screen is E code set this up
  1.  S AMHDT=$P(AMHSTR,P,8)
  1.  I $G(AMHSCR)["" S AMHSCR=$TR(AMHSCR,"*","^")
  1.  S AMHPR=$P(AMHSTR,P,7)
  1.  S AMHDT=$P(AMHSTR,P,8)
  1.  I AMHFLD1["." S AMHFLD1=+AMHFLD1
  1.  I AMHFLD2["." S AMHFLD2=+AMHFLD2
  1.  I AMHFLD2=0 S AMHFLD2=""
  1.  S AMHFLDS=$S(AMHFLD2]"":AMHFLD1_";"_AMHFLD2,1:AMHFLD1)
  1.  I AMHS="" D
  1.  . D LIST^DIC(AMHFL,"",AMHFLDS,"","","",AMHS,AMHIDX,AMHSCR,"",AMHTGT,"AMHERRR(1)")
  1.  I AMHS]"" D
  1.  . S X=AMHS X ^%ZOSF("UPPERCASE") S AMHS=Y  ;cmi/maw 03/05/2014 p4 change all to uppercase
  1.  . D FIND^DIC(AMHFL,"",AMHFLDS,"",AMHS,"",AMHIDX,AMHSCR,"",AMHTGT,"AMHERRR(1)")
  1.  S @RETVAL@(0)="T00010BMXIEN^T00050Value1^T00080Value2"_$C(30)
  1.  S AMHDA=0  F  S AMHDA=$O(@AMHTGT@("DILIST","ID",AMHDA)) Q:'AMHDA  D
  1.  . N AMHIEN,AMHBMX
  1.  . S AMHIEN=0 F  S AMHIEN=$O(@AMHTGT@("DILIST","ID",AMHDA,AMHIEN)) Q:'AMHIEN  D
  1.  .. S AMHBMX=$G(@AMHTGT@("DILIST",2,AMHDA))
  1.  .. ;I AMHFL=9002012.2,'$$CHKD^AMHUTIL1(AMHBMX,AMHDT) K AMHBMX Q
  1.  .. I AMHFL=9002012.2,'$$POVICD9^AMHUTIL1(AMHBMX,AMHDT) K AMHBMX Q  ;maw v4.0p9
  1.  .. I AMHFL=81,'$$CHKCPT^AMHUTIL1(AMHBMX,AMHDT) K AMHBMX Q
  1.  .. I AMHFL=80,'$G(AMHECD),'$$CHK^AUPNSICD(AMHBMX) K AMHBMX Q  ;for ecodes
  1.  .. I AMHFL=80,$G(AMHECD),'$$CHKE1^AUPNSICD(AMHBMX) K AMHBMX Q  ;for ecodes
  1.  .. S AMHFLD(AMHIEN)=$G(@AMHTGT@("DILIST","ID",AMHDA,AMHIEN))
  1.  . Q:'$G(AMHBMX)
  1.  . S AMHI=AMHI+1
  1.  . S @RETVAL@(AMHI)=AMHBMX_U_AMHFLD(AMHFLD1)_U_$S($G(AMHFLD2):$G(AMHFLD(AMHFLD2)),1:"")_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. ACTSCR(SIEN) ;-- activity code screen patient
  1.  ;I '$P($G(^(0)),U,6),'$P($G(^(0)),U,9)
  1.  Q 0
  1.  ;
  1. HF(AMHVAL,AMHIDX) ;-- health factor
  1.  N AMHI,P,AMHL
  1.  S AMHI=0
  1.  S P="|"
  1.  S AMHL=$L(AMHVAL)
  1.  I AMHL=1 S AMHIDX="B"
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  S @RETVAL@(AMHI)="T00010BMXIEN^T00050Value1^T00080Value2"_$C(30)
  1.  N AMHDA
  1.  S AMHDA=0 F  S AMHDA=$O(^AUTTHF(AMHIDX,AMHDA)) Q:AMHDA=""  D
  1.  . Q:$E(AMHDA,1,AMHL)'=AMHVAL
  1.  . N AMHIEN
  1.  . S AMHIEN=0 F  S AMHIEN=$O(^AUTTHF(AMHIDX,AMHDA,AMHIEN)) Q:'AMHIEN  D
  1.  .. Q:$P($G(^AUTTHF(AMHIEN,0)),U,13)
  1.  .. Q:$P($G(^AUTTHF(AMHIEN,0)),U,10)="C"
  1.  .. N AMH01,AMH01
  1.  .. S AMH01=$$GET1^DIQ(9999999.64,AMHIEN,.01)
  1.  .. S AMH02=$$GET1^DIQ(9999999.64,AMHIEN,.03)
  1.  .. S AMHI=AMHI+1
  1.  .. S @RETVAL@(AMHI)=AMHIEN_U_AMH01_U_AMH02_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. SC(RETVAL,AMHSTR) ;-- return a set of codes based upon input
  1.  S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
  1.  K ^AMHTMP($J)
  1.  S RETVAL="^AMHTMP("_$J_")"
  1.  N AMHERRR,AMHI,AMHFL,AMHFLD,AMHGB,AMHSC,P,AMHSCI,AMHSCR,AMHNO
  1.  S P="|"
  1.  S AMHI=0
  1.  S AMHERRR=""
  1.  S AMHFL=$P(AMHSTR,P)
  1.  S AMHFLD=$P(AMHSTR,P,2)
  1.  S @RETVAL@(AMHI)="T00030SetOfCodes"_$C(30)
  1.  S AMHGB="^DD("_AMHFL_","_AMHFLD_")"
  1.  S AMHSC=$P(@AMHGB@(0),U,3)
  1.  S AMHSCR=$G(@AMHGB@(12.1))
  1.  N I
  1.  F I=1:1 D  Q:$P(AMHSC,";",I)=""
  1.  . N AMHSCE
  1.  . S AMHSCI=$P(AMHSC,";",I)
  1.  . Q:AMHSCI=""
  1.  . I $G(AMHSCR)]"" D  Q:$G(AMHNO)
  1.  .. S AMHNO=0
  1.  .. N AMHSCIN
  1.  .. S AMHSCIN=$P(AMHSCI,":",1)
  1.  .. I AMHSCR'[AMHSCIN S AMHNO=1 Q
  1.  . S AMHSCE=$P(AMHSCI,":",2)
  1.  . S AMHI=AMHI+1
  1.  . S @RETVAL@(AMHI)=AMHSCE_$C(30)
  1.  S @RETVAL@(AMHI+1)=$C(31)
  1.  Q
  1.  ;
  1. SCI(FL,FLD,VAL) ;EP -- get the internal value of a set of codes based on external passed in
  1.  N RET
  1.  I VAL="" Q ""
  1.  N AMHGB,AMHSCI,AMHSCD,AMHSC
  1.  S AMHGB="^DD("_FL_","_FLD_")"
  1.  S AMHSC=$P(@AMHGB@(0),U,3)
  1.  N I
  1.  F I=1:1 D  Q:$P(AMHSC,";",I)=""!($G(RET)]"")
  1.  . N AMHSCE,AMHSCI
  1.  . S AMHSCD=$P(AMHSC,";",I)
  1.  . S AMHSCI=$P(AMHSCD,":",1)
  1.  . S AMHSCE=$P(AMHSCD,":",2)
  1.  . I AMHSCE=VAL S RET=AMHSCI Q
  1.  Q $G(RET)
  1.  ;
  1. SCE(FL,FLD,VAL) ;EP -- get the external value of a set of codes based on internal passed in
  1.  I VAL="" Q ""
  1.  N AMHGB,AMHSCI,AMHSCD,AMHSC
  1.  S AMHGB="^DD("_FL_","_FLD_")"
  1.  S AMHSC=$P(@AMHGB@(0),U,3)
  1.  N I
  1.  F I=1:1 D  Q:$P(AMHSCD,";",I)=""!($G(RET)]"")
  1.  . N AMHSCE,AMHSCI
  1.  . S AMHSCD=$P(AMHSC,";",I)
  1.  . S AMHSCI=$P(AMHSCD,":",1)
  1.  . S AMHSCE=$P(AMHSCD,":",2)
  1.  . I AMHSCI=VAL S RET=AMHSCE Q
  1.  Q $G(RET)
  1.  ;