AMHGT ; IHS/CMI/MAW - AMH Behavioral Health GUI Tables 9/30/2008 10:31:41 AM ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,4,9**;JUN 02, 2010;Build 11
;
;
;
DEBUG(RETVAL,AMHSTR) ;-- debug entry point
D DEBUG^%Serenji("SEARCH^AMHGT(.RETVAL,.AMHSTR)")
Q
;
;
;
HS(RETVAL) ;-- get all health summary types
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
N AMHERRR,AMHI,AMHHS
S AMHI=0
S AMHERRR=""
S @RETVAL@(AMHI)="T00080HealthSummary"_$C(30)
S AMHHS=0 F S AMHHS=$O(^APCHSCTL("B",AMHHS)) Q:AMHHS="" D
. S AMHI=AMHI+1
. S @RETVAL@(AMHI)=AMHHS_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
FILES(RETVAL) ;-- get all files in the system for searching later on
N AMHDA,AMHI
S AMHI=0
D ADO^AMHGU
S @RETVAL@(0)="T00050FileName^T00010NumberOfRecords"_$C(30)
S AMHDA=0 F S AMHDA=$O(^DIC(AMHDA)) Q:'AMHDA D
. N AMHFL,AMHGB,AMHREC
. S AMHFL=$P($G(^DIC(AMHDA,0)),U)
. S AMHGB=$G(^DIC(AMHDA,0,"GL"))_"0)"
. Q:AMHGB'[U
. S AMHREC=$P($G(@AMHGB),U,4)
. S AMHI=AMHI+1
. S @RETVAL@(AMHI)=AMHFL_U_AMHREC_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
SEARCHO(RETVAL,AMHSTR) ;-- return search results to frmSearchSingle and frmSearchMultiple
N AMHDA,AMHI,P,AMHFL,AMHIDX,AMHGB,AMHS,AMHSZ,AMHL
S P="|"
S AMHI=0
D ADO^AMHGU
S AMHFL=$P(AMHSTR,P)
S AMHIDX=$P(AMHSTR,P,2)
S AMHS=$P(AMHSTR,P,3)
S AMHFLD1=$P(AMHSTR,P,4)
S AMHFLD2=$P(AMHSTR,P,5)
I AMHFLD1["." S AMHFLD1=+AMHFLD1
I AMHFLD2["." S AMHFLD2=+AMHFLD2
S AMHL=$L(AMHS) ;length of string
I AMHS]"",AMHS'?.N D
. S AMHDA=AMHS
. S AMHSZ=AMHS_"Z"
I AMHS]"",AMHS?.N D
. S AMHDA=AMHS
. S AMHSZ=AMHS_"99999999"
I $G(AMHDA)="" S AMHDA=0
S @RETVAL@(0)="T00010BMXIEN^T00050Value1^T00080Value2"_$C(30)
S AMHGB=$G(^DIC(AMHFL,0,"GL"))_""""_AMHIDX_""""_")"
F S AMHDA=$O(@AMHGB@(AMHDA)) Q:AMHDA=""!($E(AMHDA,1,AMHL)'=AMHS) D
. N AMHIEN
. S AMHIEN=0 F S AMHIEN=$O(@AMHGB@(AMHDA,AMHIEN)) Q:'AMHIEN D
.. N AMHVAL1,AMHVAL2
.. S AMHVAL1=$$GET1^DIQ(AMHFL,AMHIEN,AMHFLD1)
.. I $G(AMHFLD2)]"" S AMHVAL2=$$GET1^DIQ(AMHFL,AMHIEN,AMHFLD2)
.. S AMHI=AMHI+1
.. S @RETVAL@(AMHI)=AMHIEN_U_AMHVAL1_U_$G(AMHVAL2)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
SEARCH(RETVAL,AMHSTR) ;-- return search results to frmSearchSingle and frmSearchMultiple
N AMHDA,AMHI,P,AMHFL,AMHIDX,AMHGB,AMHS,AMHSZ,AMHL,AMHTGT,AMHFLDS,AMHSCR,AMHPR,AMHFLD1,AMHFLD2,AMHDT,AMHECD
S P="|"
S AMHI=0
D ADO^AMHGU
K ^AMHTMPD($J)
S AMHTGT="^AMHTMPD("_$J_")" ;target for find^dic lookup
S AMHFL=$P(AMHSTR,P)
S AMHIDX=$P(AMHSTR,P,2)
I AMHIDX]"" S AMHIDX=$TR(AMHIDX,"*","^")
S AMHS=$P(AMHSTR,P,3)
I AMHFL=9999999.64 D HF(AMHS,"F") I $P($G(@RETVAL@(1)),U,2)]"" Q
I AMHFL=9999999.64,$P($G(@RETVAL@(1)),U,2)']"" D HF(AMHS,"B") Q
I AMHFL=9002012.2,AMHS="" S AMHIDX="BA"
S AMHFLD1=$P(AMHSTR,P,4)
S AMHFLD2=$P(AMHSTR,P,5)
S AMHSCR=$P(AMHSTR,P,6)
I AMHSCR="E" D ;this is for e codes
. I $E(AMHS,1,1)'="E" S AMHS="E"_AMHS ;add the e code to e code lookup
. S AMHECD=1
. S AMHSCR="" ;if screen is E code set this up
S AMHDT=$P(AMHSTR,P,8)
I $G(AMHSCR)["" S AMHSCR=$TR(AMHSCR,"*","^")
S AMHPR=$P(AMHSTR,P,7)
S AMHDT=$P(AMHSTR,P,8)
I AMHFLD1["." S AMHFLD1=+AMHFLD1
I AMHFLD2["." S AMHFLD2=+AMHFLD2
I AMHFLD2=0 S AMHFLD2=""
S AMHFLDS=$S(AMHFLD2]"":AMHFLD1_";"_AMHFLD2,1:AMHFLD1)
I AMHS="" D
. D LIST^DIC(AMHFL,"",AMHFLDS,"","","",AMHS,AMHIDX,AMHSCR,"",AMHTGT,"AMHERRR(1)")
I AMHS]"" D
. S X=AMHS X ^%ZOSF("UPPERCASE") S AMHS=Y ;cmi/maw 03/05/2014 p4 change all to uppercase
. D FIND^DIC(AMHFL,"",AMHFLDS,"",AMHS,"",AMHIDX,AMHSCR,"",AMHTGT,"AMHERRR(1)")
S @RETVAL@(0)="T00010BMXIEN^T00050Value1^T00080Value2"_$C(30)
S AMHDA=0 F S AMHDA=$O(@AMHTGT@("DILIST","ID",AMHDA)) Q:'AMHDA D
. N AMHIEN,AMHBMX
. S AMHIEN=0 F S AMHIEN=$O(@AMHTGT@("DILIST","ID",AMHDA,AMHIEN)) Q:'AMHIEN D
.. S AMHBMX=$G(@AMHTGT@("DILIST",2,AMHDA))
.. ;I AMHFL=9002012.2,'$$CHKD^AMHUTIL1(AMHBMX,AMHDT) K AMHBMX Q
.. I AMHFL=9002012.2,'$$POVICD9^AMHUTIL1(AMHBMX,AMHDT) K AMHBMX Q ;maw v4.0p9
.. I AMHFL=81,'$$CHKCPT^AMHUTIL1(AMHBMX,AMHDT) K AMHBMX Q
.. I AMHFL=80,'$G(AMHECD),'$$CHK^AUPNSICD(AMHBMX) K AMHBMX Q ;for ecodes
.. I AMHFL=80,$G(AMHECD),'$$CHKE1^AUPNSICD(AMHBMX) K AMHBMX Q ;for ecodes
.. S AMHFLD(AMHIEN)=$G(@AMHTGT@("DILIST","ID",AMHDA,AMHIEN))
. Q:'$G(AMHBMX)
. S AMHI=AMHI+1
. S @RETVAL@(AMHI)=AMHBMX_U_AMHFLD(AMHFLD1)_U_$S($G(AMHFLD2):$G(AMHFLD(AMHFLD2)),1:"")_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
ACTSCR(SIEN) ;-- activity code screen patient
;I '$P($G(^(0)),U,6),'$P($G(^(0)),U,9)
Q 0
;
HF(AMHVAL,AMHIDX) ;-- health factor
N AMHI,P,AMHL
S AMHI=0
S P="|"
S AMHL=$L(AMHVAL)
I AMHL=1 S AMHIDX="B"
S RETVAL="^AMHTMP("_$J_")"
S @RETVAL@(AMHI)="T00010BMXIEN^T00050Value1^T00080Value2"_$C(30)
N AMHDA
S AMHDA=0 F S AMHDA=$O(^AUTTHF(AMHIDX,AMHDA)) Q:AMHDA="" D
. Q:$E(AMHDA,1,AMHL)'=AMHVAL
. N AMHIEN
. S AMHIEN=0 F S AMHIEN=$O(^AUTTHF(AMHIDX,AMHDA,AMHIEN)) Q:'AMHIEN D
.. Q:$P($G(^AUTTHF(AMHIEN,0)),U,13)
.. Q:$P($G(^AUTTHF(AMHIEN,0)),U,10)="C"
.. N AMH01,AMH01
.. S AMH01=$$GET1^DIQ(9999999.64,AMHIEN,.01)
.. S AMH02=$$GET1^DIQ(9999999.64,AMHIEN,.03)
.. S AMHI=AMHI+1
.. S @RETVAL@(AMHI)=AMHIEN_U_AMH01_U_AMH02_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
SC(RETVAL,AMHSTR) ;-- return a set of codes based upon input
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
N AMHERRR,AMHI,AMHFL,AMHFLD,AMHGB,AMHSC,P,AMHSCI,AMHSCR,AMHNO
S P="|"
S AMHI=0
S AMHERRR=""
S AMHFL=$P(AMHSTR,P)
S AMHFLD=$P(AMHSTR,P,2)
S @RETVAL@(AMHI)="T00030SetOfCodes"_$C(30)
S AMHGB="^DD("_AMHFL_","_AMHFLD_")"
S AMHSC=$P(@AMHGB@(0),U,3)
S AMHSCR=$G(@AMHGB@(12.1))
N I
F I=1:1 D Q:$P(AMHSC,";",I)=""
. N AMHSCE
. S AMHSCI=$P(AMHSC,";",I)
. Q:AMHSCI=""
. I $G(AMHSCR)]"" D Q:$G(AMHNO)
.. S AMHNO=0
.. N AMHSCIN
.. S AMHSCIN=$P(AMHSCI,":",1)
.. I AMHSCR'[AMHSCIN S AMHNO=1 Q
. S AMHSCE=$P(AMHSCI,":",2)
. S AMHI=AMHI+1
. S @RETVAL@(AMHI)=AMHSCE_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
SCI(FL,FLD,VAL) ;EP -- get the internal value of a set of codes based on external passed in
N RET
I VAL="" Q ""
N AMHGB,AMHSCI,AMHSCD,AMHSC
S AMHGB="^DD("_FL_","_FLD_")"
S AMHSC=$P(@AMHGB@(0),U,3)
N I
F I=1:1 D Q:$P(AMHSC,";",I)=""!($G(RET)]"")
. N AMHSCE,AMHSCI
. S AMHSCD=$P(AMHSC,";",I)
. S AMHSCI=$P(AMHSCD,":",1)
. S AMHSCE=$P(AMHSCD,":",2)
. I AMHSCE=VAL S RET=AMHSCI Q
Q $G(RET)
;
SCE(FL,FLD,VAL) ;EP -- get the external value of a set of codes based on internal passed in
I VAL="" Q ""
N AMHGB,AMHSCI,AMHSCD,AMHSC
S AMHGB="^DD("_FL_","_FLD_")"
S AMHSC=$P(@AMHGB@(0),U,3)
N I
F I=1:1 D Q:$P(AMHSCD,";",I)=""!($G(RET)]"")
. N AMHSCE,AMHSCI
. S AMHSCD=$P(AMHSC,";",I)
. S AMHSCI=$P(AMHSCD,":",1)
. S AMHSCE=$P(AMHSCD,":",2)
. I AMHSCI=VAL S RET=AMHSCE Q
Q $G(RET)
;
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
+2 ;
+3 ;
+4 ;
DEBUG(RETVAL,AMHSTR) ;-- debug entry point
+1 DO DEBUG^%Serenji("SEARCH^AMHGT(.RETVAL,.AMHSTR)")
+2 QUIT
+3 ;
+4 ;
+5 ;
HS(RETVAL) ;-- get all health summary types
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 KILL ^AMHTMP($JOB)
+3 SET RETVAL="^AMHTMP("_$JOB_")"
+4 NEW AMHERRR,AMHI,AMHHS
+5 SET AMHI=0
+6 SET AMHERRR=""
+7 SET @RETVAL@(AMHI)="T00080HealthSummary"_$CHAR(30)
+8 SET AMHHS=0
FOR
SET AMHHS=$ORDER(^APCHSCTL("B",AMHHS))
IF AMHHS=""
QUIT
Begin DoDot:1
+9 SET AMHI=AMHI+1
+10 SET @RETVAL@(AMHI)=AMHHS_$CHAR(30)
End DoDot:1
+11 SET @RETVAL@(AMHI+1)=$CHAR(31)
+12 QUIT
+13 ;
FILES(RETVAL) ;-- get all files in the system for searching later on
+1 NEW AMHDA,AMHI
+2 SET AMHI=0
+3 DO ADO^AMHGU
+4 SET @RETVAL@(0)="T00050FileName^T00010NumberOfRecords"_$CHAR(30)
+5 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^DIC(AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+6 NEW AMHFL,AMHGB,AMHREC
+7 SET AMHFL=$PIECE($GET(^DIC(AMHDA,0)),U)
+8 SET AMHGB=$GET(^DIC(AMHDA,0,"GL"))_"0)"
+9 IF AMHGB'[U
QUIT
+10 SET AMHREC=$PIECE($GET(@AMHGB),U,4)
+11 SET AMHI=AMHI+1
+12 SET @RETVAL@(AMHI)=AMHFL_U_AMHREC_$CHAR(30)
End DoDot:1
+13 SET @RETVAL@(AMHI+1)=$CHAR(31)
+14 QUIT
+15 ;
SEARCHO(RETVAL,AMHSTR) ;-- return search results to frmSearchSingle and frmSearchMultiple
+1 NEW AMHDA,AMHI,P,AMHFL,AMHIDX,AMHGB,AMHS,AMHSZ,AMHL
+2 SET P="|"
+3 SET AMHI=0
+4 DO ADO^AMHGU
+5 SET AMHFL=$PIECE(AMHSTR,P)
+6 SET AMHIDX=$PIECE(AMHSTR,P,2)
+7 SET AMHS=$PIECE(AMHSTR,P,3)
+8 SET AMHFLD1=$PIECE(AMHSTR,P,4)
+9 SET AMHFLD2=$PIECE(AMHSTR,P,5)
+10 IF AMHFLD1["."
SET AMHFLD1=+AMHFLD1
+11 IF AMHFLD2["."
SET AMHFLD2=+AMHFLD2
+12 ;length of string
SET AMHL=$LENGTH(AMHS)
+13 IF AMHS]""
IF AMHS'?.N
Begin DoDot:1
+14 SET AMHDA=AMHS
+15 SET AMHSZ=AMHS_"Z"
End DoDot:1
+16 IF AMHS]""
IF AMHS?.N
Begin DoDot:1
+17 SET AMHDA=AMHS
+18 SET AMHSZ=AMHS_"99999999"
End DoDot:1
+19 IF $GET(AMHDA)=""
SET AMHDA=0
+20 SET @RETVAL@(0)="T00010BMXIEN^T00050Value1^T00080Value2"_$CHAR(30)
+21 SET AMHGB=$GET(^DIC(AMHFL,0,"GL"))_""""_AMHIDX_""""_")"
+22 FOR
SET AMHDA=$ORDER(@AMHGB@(AMHDA))
IF AMHDA=""!($EXTRACT(AMHDA,1,AMHL)'=AMHS)
QUIT
Begin DoDot:1
+23 NEW AMHIEN
+24 SET AMHIEN=0
FOR
SET AMHIEN=$ORDER(@AMHGB@(AMHDA,AMHIEN))
IF 'AMHIEN
QUIT
Begin DoDot:2
+25 NEW AMHVAL1,AMHVAL2
+26 SET AMHVAL1=$$GET1^DIQ(AMHFL,AMHIEN,AMHFLD1)
+27 IF $GET(AMHFLD2)]""
SET AMHVAL2=$$GET1^DIQ(AMHFL,AMHIEN,AMHFLD2)
+28 SET AMHI=AMHI+1
+29 SET @RETVAL@(AMHI)=AMHIEN_U_AMHVAL1_U_$GET(AMHVAL2)_$CHAR(30)
End DoDot:2
End DoDot:1
+30 SET @RETVAL@(AMHI+1)=$CHAR(31)
+31 QUIT
+32 ;
SEARCH(RETVAL,AMHSTR) ;-- return search results to frmSearchSingle and frmSearchMultiple
+1 NEW AMHDA,AMHI,P,AMHFL,AMHIDX,AMHGB,AMHS,AMHSZ,AMHL,AMHTGT,AMHFLDS,AMHSCR,AMHPR,AMHFLD1,AMHFLD2,AMHDT,AMHECD
+2 SET P="|"
+3 SET AMHI=0
+4 DO ADO^AMHGU
+5 KILL ^AMHTMPD($JOB)
+6 ;target for find^dic lookup
SET AMHTGT="^AMHTMPD("_$JOB_")"
+7 SET AMHFL=$PIECE(AMHSTR,P)
+8 SET AMHIDX=$PIECE(AMHSTR,P,2)
+9 IF AMHIDX]""
SET AMHIDX=$TRANSLATE(AMHIDX,"*","^")
+10 SET AMHS=$PIECE(AMHSTR,P,3)
+11 IF AMHFL=9999999.64
DO HF(AMHS,"F")
IF $PIECE($GET(@RETVAL@(1)),U,2)]""
QUIT
+12 IF AMHFL=9999999.64
IF $PIECE($GET(@RETVAL@(1)),U,2)']""
DO HF(AMHS,"B")
QUIT
+13 IF AMHFL=9002012.2
IF AMHS=""
SET AMHIDX="BA"
+14 SET AMHFLD1=$PIECE(AMHSTR,P,4)
+15 SET AMHFLD2=$PIECE(AMHSTR,P,5)
+16 SET AMHSCR=$PIECE(AMHSTR,P,6)
+17 ;this is for e codes
IF AMHSCR="E"
Begin DoDot:1
+18 ;add the e code to e code lookup
IF $EXTRACT(AMHS,1,1)'="E"
SET AMHS="E"_AMHS
+19 SET AMHECD=1
+20 ;if screen is E code set this up
SET AMHSCR=""
End DoDot:1
+21 SET AMHDT=$PIECE(AMHSTR,P,8)
+22 IF $GET(AMHSCR)[""
SET AMHSCR=$TRANSLATE(AMHSCR,"*","^")
+23 SET AMHPR=$PIECE(AMHSTR,P,7)
+24 SET AMHDT=$PIECE(AMHSTR,P,8)
+25 IF AMHFLD1["."
SET AMHFLD1=+AMHFLD1
+26 IF AMHFLD2["."
SET AMHFLD2=+AMHFLD2
+27 IF AMHFLD2=0
SET AMHFLD2=""
+28 SET AMHFLDS=$SELECT(AMHFLD2]"":AMHFLD1_";"_AMHFLD2,1:AMHFLD1)
+29 IF AMHS=""
Begin DoDot:1
+30 DO LIST^DIC(AMHFL,"",AMHFLDS,"","","",AMHS,AMHIDX,AMHSCR,"",AMHTGT,"AMHERRR(1)")
End DoDot:1
+31 IF AMHS]""
Begin DoDot:1
+32 ;cmi/maw 03/05/2014 p4 change all to uppercase
SET X=AMHS
XECUTE ^%ZOSF("UPPERCASE")
SET AMHS=Y
+33 DO FIND^DIC(AMHFL,"",AMHFLDS,"",AMHS,"",AMHIDX,AMHSCR,"",AMHTGT,"AMHERRR(1)")
End DoDot:1
+34 SET @RETVAL@(0)="T00010BMXIEN^T00050Value1^T00080Value2"_$CHAR(30)
+35 SET AMHDA=0
FOR
SET AMHDA=$ORDER(@AMHTGT@("DILIST","ID",AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+36 NEW AMHIEN,AMHBMX
+37 SET AMHIEN=0
FOR
SET AMHIEN=$ORDER(@AMHTGT@("DILIST","ID",AMHDA,AMHIEN))
IF 'AMHIEN
QUIT
Begin DoDot:2
+38 SET AMHBMX=$GET(@AMHTGT@("DILIST",2,AMHDA))
+39 ;I AMHFL=9002012.2,'$$CHKD^AMHUTIL1(AMHBMX,AMHDT) K AMHBMX Q
+40 ;maw v4.0p9
IF AMHFL=9002012.2
IF '$$POVICD9^AMHUTIL1(AMHBMX,AMHDT)
KILL AMHBMX
QUIT
+41 IF AMHFL=81
IF '$$CHKCPT^AMHUTIL1(AMHBMX,AMHDT)
KILL AMHBMX
QUIT
+42 ;for ecodes
IF AMHFL=80
IF '$GET(AMHECD)
IF '$$CHK^AUPNSICD(AMHBMX)
KILL AMHBMX
QUIT
+43 ;for ecodes
IF AMHFL=80
IF $GET(AMHECD)
IF '$$CHKE1^AUPNSICD(AMHBMX)
KILL AMHBMX
QUIT
+44 SET AMHFLD(AMHIEN)=$GET(@AMHTGT@("DILIST","ID",AMHDA,AMHIEN))
End DoDot:2
+45 IF '$GET(AMHBMX)
QUIT
+46 SET AMHI=AMHI+1
+47 SET @RETVAL@(AMHI)=AMHBMX_U_AMHFLD(AMHFLD1)_U_$SELECT($GET(AMHFLD2):$GET(AMHFLD(AMHFLD2)),1:"")_$CHAR(30)
End DoDot:1
+48 SET @RETVAL@(AMHI+1)=$CHAR(31)
+49 QUIT
+50 ;
ACTSCR(SIEN) ;-- activity code screen patient
+1 ;I '$P($G(^(0)),U,6),'$P($G(^(0)),U,9)
+2 QUIT 0
+3 ;
HF(AMHVAL,AMHIDX) ;-- health factor
+1 NEW AMHI,P,AMHL
+2 SET AMHI=0
+3 SET P="|"
+4 SET AMHL=$LENGTH(AMHVAL)
+5 IF AMHL=1
SET AMHIDX="B"
+6 SET RETVAL="^AMHTMP("_$JOB_")"
+7 SET @RETVAL@(AMHI)="T00010BMXIEN^T00050Value1^T00080Value2"_$CHAR(30)
+8 NEW AMHDA
+9 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AUTTHF(AMHIDX,AMHDA))
IF AMHDA=""
QUIT
Begin DoDot:1
+10 IF $EXTRACT(AMHDA,1,AMHL)'=AMHVAL
QUIT
+11 NEW AMHIEN
+12 SET AMHIEN=0
FOR
SET AMHIEN=$ORDER(^AUTTHF(AMHIDX,AMHDA,AMHIEN))
IF 'AMHIEN
QUIT
Begin DoDot:2
+13 IF $PIECE($GET(^AUTTHF(AMHIEN,0)),U,13)
QUIT
+14 IF $PIECE($GET(^AUTTHF(AMHIEN,0)),U,10)="C"
QUIT
+15 NEW AMH01,AMH01
+16 SET AMH01=$$GET1^DIQ(9999999.64,AMHIEN,.01)
+17 SET AMH02=$$GET1^DIQ(9999999.64,AMHIEN,.03)
+18 SET AMHI=AMHI+1
+19 SET @RETVAL@(AMHI)=AMHIEN_U_AMH01_U_AMH02_$CHAR(30)
End DoDot:2
End DoDot:1
+20 SET @RETVAL@(AMHI+1)=$CHAR(31)
+21 QUIT
+22 ;
SC(RETVAL,AMHSTR) ;-- return a set of codes based upon input
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 KILL ^AMHTMP($JOB)
+3 SET RETVAL="^AMHTMP("_$JOB_")"
+4 NEW AMHERRR,AMHI,AMHFL,AMHFLD,AMHGB,AMHSC,P,AMHSCI,AMHSCR,AMHNO
+5 SET P="|"
+6 SET AMHI=0
+7 SET AMHERRR=""
+8 SET AMHFL=$PIECE(AMHSTR,P)
+9 SET AMHFLD=$PIECE(AMHSTR,P,2)
+10 SET @RETVAL@(AMHI)="T00030SetOfCodes"_$CHAR(30)
+11 SET AMHGB="^DD("_AMHFL_","_AMHFLD_")"
+12 SET AMHSC=$PIECE(@AMHGB@(0),U,3)
+13 SET AMHSCR=$GET(@AMHGB@(12.1))
+14 NEW I
+15 FOR I=1:1
Begin DoDot:1
+16 NEW AMHSCE
+17 SET AMHSCI=$PIECE(AMHSC,";",I)
+18 IF AMHSCI=""
QUIT
+19 IF $GET(AMHSCR)]""
Begin DoDot:2
+20 SET AMHNO=0
+21 NEW AMHSCIN
+22 SET AMHSCIN=$PIECE(AMHSCI,":",1)
+23 IF AMHSCR'[AMHSCIN
SET AMHNO=1
QUIT
End DoDot:2
IF $GET(AMHNO)
QUIT
+24 SET AMHSCE=$PIECE(AMHSCI,":",2)
+25 SET AMHI=AMHI+1
+26 SET @RETVAL@(AMHI)=AMHSCE_$CHAR(30)
End DoDot:1
IF $PIECE(AMHSC,";",I)=""
QUIT
+27 SET @RETVAL@(AMHI+1)=$CHAR(31)
+28 QUIT
+29 ;
SCI(FL,FLD,VAL) ;EP -- get the internal value of a set of codes based on external passed in
+1 NEW RET
+2 IF VAL=""
QUIT ""
+3 NEW AMHGB,AMHSCI,AMHSCD,AMHSC
+4 SET AMHGB="^DD("_FL_","_FLD_")"
+5 SET AMHSC=$PIECE(@AMHGB@(0),U,3)
+6 NEW I
+7 FOR I=1:1
Begin DoDot:1
+8 NEW AMHSCE,AMHSCI
+9 SET AMHSCD=$PIECE(AMHSC,";",I)
+10 SET AMHSCI=$PIECE(AMHSCD,":",1)
+11 SET AMHSCE=$PIECE(AMHSCD,":",2)
+12 IF AMHSCE=VAL
SET RET=AMHSCI
QUIT
End DoDot:1
IF $PIECE(AMHSC,";",I)=""!($GET(RET)]"")
QUIT
+13 QUIT $GET(RET)
+14 ;
SCE(FL,FLD,VAL) ;EP -- get the external value of a set of codes based on internal passed in
+1 IF VAL=""
QUIT ""
+2 NEW AMHGB,AMHSCI,AMHSCD,AMHSC
+3 SET AMHGB="^DD("_FL_","_FLD_")"
+4 SET AMHSC=$PIECE(@AMHGB@(0),U,3)
+5 NEW I
+6 FOR I=1:1
Begin DoDot:1
+7 NEW AMHSCE,AMHSCI
+8 SET AMHSCD=$PIECE(AMHSC,";",I)
+9 SET AMHSCI=$PIECE(AMHSCD,":",1)
+10 SET AMHSCE=$PIECE(AMHSCD,":",2)
+11 IF AMHSCI=VAL
SET RET=AMHSCE
QUIT
End DoDot:1
IF $PIECE(AMHSCD,";",I)=""!($GET(RET)]"")
QUIT
+12 QUIT $GET(RET)
+13 ;
