AMHUTIL2 ; IHS/CMI/LAB - provider functions ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,4,5,8**;JUN 02, 2010;Build 7
;
PNPV(N,AMHDA) ;PEP - OUTPUT TX PROVIDER NARRATIVE
S AMHDA=$G(AMHDA)
S N=$G(N)
I N="" Q ""
Q $$SNOMED^AUPNVUTL(N)
NEW R,D
S (R,D)=""
I AMHDA S R=$P($G(^AMHRPRO(AMHDA,0)),U,3)
I AMHDA S D=$P($G(^AMHRPRO(AMHDA,0)),U,1)
I N="" Q "<No Provider Narrative>"
I R,$P($G(^AMHREC(R,11)),U,10) G EHR ;if EHR created do EHR stuff
Q $P(^AUTNPOV(N,0),U) ;IF NOT AN EHR CREATED VISIT JUST DISPLAY THE NARRATIVE LIKE WE ALWAYS DID
EHR ;
S N=$P($G(^AUTNPOV(N,0)),U,1)
I N'["|" Q $$GET1^DIQ(9002012.2,D,.02)_" | "_N ; no vertical equals no snomed desc id so use problem narrative
I N["| " Q $$GET1^DIQ(9002012.2,D,.02)_" | "_N ;prenatal v1.0
I $T(DESC^BSTSAPI)="" Q $$GET1^DIQ(9002012.2,D,.02)_" | "_N ;no snomed stuff installed
NEW SDI,SDIT
S SDI=$P(N,"|",2) ;snomed descriptive id is in piece 2
S SDIT=$P($$DESC^BSTSAPI(SDI_"^^1"),U,2)
I SDIT="" Q $$GET1^DIQ(9002012.2,D,.02)_" | "_$P(N,"|",1) ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
Q SDIT_" | "_$P(N,"|",1)
HL(H) ;EP - called to return internal of file 44 for hospital location based on program H
I $G(H)="" Q ""
I '$D(^AMHSITE(DUZ(2))) Q "" ;NO SITE ENTRY
NEW I
I H="M" S I=$$VALI^XBDIQ1(9002013,DUZ(2),1812) I I Q $S($D(^SC(I,0)):I,1:"")
I H="S" S I=$$VALI^XBDIQ1(9002013,DUZ(2),1813) I I Q $S($D(^SC(I,0)):I,1:"")
I H="C" S I=$$VALI^XBDIQ1(9002013,DUZ(2),1814) I I Q $S($D(^SC(I,0)):I,1:"")
I H="O" S I=$$VALI^XBDIQ1(9002013,DUZ(2),1815) I I Q $S($D(^SC(I,0)):I,1:"")
Q ""
CS(I) ;EP - called to determine coding system of ien I
;are the icd10 routines in place?, if so, use them
I $T(ICDDX^ICDEX)]"" Q $P($$ICDDX^ICDEX(I),U,20) ;return 1 or 30
Q 1 ;if no icdex then assume site is only on icd9
IMP(D) ;EP - which coding system should be used:
;RETURN IEN of entry in ^ICDS
;1 = ICD9
;30 = ICD10
;will need to add subroutines for ICD11 when we have that.
I $G(D)="" S D=DT
NEW X,Y,Z
S Y=""
I '$O(^ICDS(0)) Q 1 ;icd 10 not installed yet
S X=0 F S X=$O(^ICDS("F",80,X)) Q:X'=+X D
.I $P(^ICDS(X,0),U,4)="" Q ;NO IMPLEMENTATION DATE?? SKIP IT
.S Z($P(^ICDS(X,0),U,4))=X
;now go through and get the last one before it imp date is greater than the visit date
S X=0 F S X=$O(Z(X)) Q:X="" D
.I D<X Q
.I D=X S Y=Z(X) Q
.I D>X S Y=Z(X) Q
I Y="" S Y=$O(Z(0)) Q Z(Y)
Q Y
PRIMCPT(V,F) ;EP - primaryCPT in many different formats
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=$O(^AMHRPROC("AD",V,0)) I Y S P=$P(^AMHRPROC(Y,0),U),Z=Y
I 'P Q P
I '$D(^ICPT(P)) Q ""
I $G(F)="" S F="C"
S %="" D @F
Q %
;
SECCPT(V,N,F) ;EP
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
I '$G(N) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0,C=-1 F S Y=$O(^AMHRPROC("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AMHRPROC(Y,0),U),Z=Y
I 'P Q P
I '$D(^ICPT(P)) Q ""
I $G(F)="" S F="C"
S %="" D @F
Q %
;
CPT ;EP
NEW Z,C,%,S,I,J
S (C,Y)=0 F S Y=$O(^AMHRPROC("AD",V,Y)) Q:Y'=+Y S C=C+1 S APCLV(C)="",P=$P(^AMHRPROC(Y,0),U),Z=Y D
.I F=99 D Q
..F I=1:1 S S=$T(@I) Q:S="" S %="" D @I S $P(APCLV(C),U,I)=%
.I F[";" D Q
..F J=1:1 S I=$P(F,";",J) Q:I="" I I'=99 S %="" D @I S $P(APCLV(C),U,I)=% ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J
.S %="",I=F D @I S $P(APCLV(C),U)=%
.Q
Q
;
I ;
S %=P Q
E ;CATEGORY
S %=$$CPT^ICPTCOD(P,$P($P($G(^AMHREC(V,0)),U),"."),U,4) Q
C ;CODE
S %=$$CPT^ICPTCOD(P,$P($P($G(^AMHREC(V,0)),U),"."),U,2) Q
;
N ;NARRATIVE - SHORT NAME
S %=$$CPT^ICPTCOD(P,$P($P($G(^AMHREC(V,0)),U),"."),U,3) Q
;
PTSEC(RESULT,DFN,MSG,OPT) ;EP - RPC/API entry point for patient sensitive & record access checks
;Output array (Required)
; RESULT(1)= -1-RPC/API failed
; Required variable not defined
; 0-No display/action required
; Not accessing own, employee, or sensitive record
; 1-Display warning message
; Sensitive and DG SENSITIVITY key holder
; or Employee and DG SECURITY OFFICER key holder
; 2-Display warning message/require OK to continue
; Sensitive and not a DG SENSITIVITY key holder
; Employee and not a DG SECURITY OFFICER key holder
; 3-Access to record denied
; Accessing own record
; 4-Access to Patient (#2) file records denied
; SSN not defined
; 5-Access to Patient for this User is denied ;IHS/OIT/LJF 08/31/2007 PATCH 1008
;
; RESULT(2-8) = error or display messages
;
;Input parameters: DFN = Patient file entry (Required)
; MSG = If 1, generate message (optional)
; OPT = Option name^Menu text (Optional)
;
K RESULT
I $G(DFN)="" D Q
.S RESULT(1)=-1
.S RESULT(2)="Required variable missing."
;
;IHS/OIT/LJF 08/31/2007 PATCH 1008
;S DGMSG=$G(DGMSG)
S MSG=$G(MSG,1)
I $$STATUS^BDGSPT2(DUZ,DFN,1)["RESTRICTED ACCESS" D Q
.S RESULT(1)=5 Q:MSG'=1
.S RESULT(2)="Sorry, you are restricted from accessing this patient's record."
.S RESULT(3)="If you have questions, please contact your HIM department."
;end of PATCH 1008 code
;
D OWNREC^DGSEC4(.RESULT,DFN,$G(DUZ),MSG)
I RESULT(1)=1 S RESULT(1)=3 Q
I RESULT(1)=2 S RESULT(1)=4 Q
K RESULT
D SENS^DGSEC4(.RESULT,DFN,$G(DUZ))
;
;IHS/OIT/LJF 01/06/2006 PATCH 1005 account for tracking all patients
;I RESULT(1)=1 D
I (RESULT(1)=1)!(RESULT(1)=0) D
.I (RESULT(1)=0)&($$GET1^DIQ(43,1,9999999.01)'="YES")&('$P($G(^DGSL(38.1,+DFN,0)),U,2)) Q ;cmi/maw 1/26/2010 PATCH 1011
.;
.I $G(DUZ)="" D Q
..;DUZ must be defined to access sensitive record & update DG Security log
..S RESULT(1)=-1
..S RESULT(2)="Your user code is undefined. This must be defined to access a restricted patient record."
.D SETLOG1^DGSEC(DFN,DUZ,,$G(DGOPT)) ;ihs/cmi/maw 12/15/2010 added set of log
Q
ANY25(AMHX) ;EP
NEW F,X,G
S X="",G=0 F S X=$O(^TMP("DDS",$J,+DDS,"F9002013.01101",X)) Q:X="" D
.I $G(^TMP("DDS",$J,+DDS,"F9002013.01101",X,.02,"D"))=2 S G=1
.I $G(^TMP("DDS",$J,+DDS,"F9002013.01101",X,.02,"D"))=5 S G=1
.Q
Q G
ICD9 ;EP - CALLED FROM INPUT TX ON SITE PARAMETERS FIELD .13
I $$CHK(Y)
Q:$D(^ICD9(Y))
Q
;
CHK(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
NEW A,I,D,%
I $T(ICDDX^ICDEX)]"" S %=$$ICDDX^ICDEX(Y) I $P(%,U,20)'=1 Q 0
I $T(ICDDX^ICDEX)="" S %=$$ICDDX^ICDCODE(Y)
;I $P(%,U,20)'=1 Q 0 ;not correct coding system
I $E($P(%,U,2),1)="E" Q 0 ;no E codes
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
Q 1
ICD10 ;EP CALLED FROM INPUT TX ON SITE PARAMETERS FIELD 1204
;
I $$CHK1(Y)
Q:$D(^ICD9(Y))
Q
;
CHK1(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
NEW A,I,D,%
I $T(ICDDX^ICDEX)]"" S %=$$ICDDX^ICDEX(Y) I $P(%,U,20)'=30 Q 0
I $T(ICDDX^ICDEX)="" S %=$$ICDDX^ICDCODE(Y)
;I $P(%,U,20)'=30 Q 0 ;not correct coding system
I $E($P(%,U,2),1)="V" Q 0 ;no codes V00-Y99 per Leslie Racine.
I $E($P(%,U,2),1)="W" Q 0
I $E($P(%,U,2),1)="X" Q 0
I $E($P(%,U,2),1)="Y" Q 0
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
Q 1
AMHUTIL2 ; IHS/CMI/LAB - provider functions ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,4,5,8**;JUN 02, 2010;Build 7
+2 ;
PNPV(N,AMHDA) ;PEP - OUTPUT TX PROVIDER NARRATIVE
+1 SET AMHDA=$GET(AMHDA)
+2 SET N=$GET(N)
+3 IF N=""
QUIT ""
+4 QUIT $$SNOMED^AUPNVUTL(N)
+5 NEW R,D
+6 SET (R,D)=""
+7 IF AMHDA
SET R=$PIECE($GET(^AMHRPRO(AMHDA,0)),U,3)
+8 IF AMHDA
SET D=$PIECE($GET(^AMHRPRO(AMHDA,0)),U,1)
+9 IF N=""
QUIT "<No Provider Narrative>"
+10 ;if EHR created do EHR stuff
IF R
IF $PIECE($GET(^AMHREC(R,11)),U,10)
GOTO EHR
+11 ;IF NOT AN EHR CREATED VISIT JUST DISPLAY THE NARRATIVE LIKE WE ALWAYS DID
QUIT $PIECE(^AUTNPOV(N,0),U)
EHR ;
+1 SET N=$PIECE($GET(^AUTNPOV(N,0)),U,1)
+2 ; no vertical equals no snomed desc id so use problem narrative
IF N'["|"
QUIT $$GET1^DIQ(9002012.2,D,.02)_" | "_N
+3 ;prenatal v1.0
IF N["| "
QUIT $$GET1^DIQ(9002012.2,D,.02)_" | "_N
+4 ;no snomed stuff installed
IF $TEXT(DESC^BSTSAPI)=""
QUIT $$GET1^DIQ(9002012.2,D,.02)_" | "_N
+5 NEW SDI,SDIT
+6 ;snomed descriptive id is in piece 2
SET SDI=$PIECE(N,"|",2)
+7 SET SDIT=$PIECE($$DESC^BSTSAPI(SDI_"^^1"),U,2)
+8 ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
IF SDIT=""
QUIT $$GET1^DIQ(9002012.2,D,.02)_" | "_$PIECE(N,"|",1)
+9 QUIT SDIT_" | "_$PIECE(N,"|",1)
HL(H) ;EP - called to return internal of file 44 for hospital location based on program H
+1 IF $GET(H)=""
QUIT ""
+2 ;NO SITE ENTRY
IF '$DATA(^AMHSITE(DUZ(2)))
QUIT ""
+3 NEW I
+4 IF H="M"
SET I=$$VALI^XBDIQ1(9002013,DUZ(2),1812)
IF I
QUIT $SELECT($DATA(^SC(I,0)):I,1:"")
+5 IF H="S"
SET I=$$VALI^XBDIQ1(9002013,DUZ(2),1813)
IF I
QUIT $SELECT($DATA(^SC(I,0)):I,1:"")
+6 IF H="C"
SET I=$$VALI^XBDIQ1(9002013,DUZ(2),1814)
IF I
QUIT $SELECT($DATA(^SC(I,0)):I,1:"")
+7 IF H="O"
SET I=$$VALI^XBDIQ1(9002013,DUZ(2),1815)
IF I
QUIT $SELECT($DATA(^SC(I,0)):I,1:"")
+8 QUIT ""
CS(I) ;EP - called to determine coding system of ien I
+1 ;are the icd10 routines in place?, if so, use them
+2 ;return 1 or 30
IF $TEXT(ICDDX^ICDEX)]""
QUIT $PIECE($$ICDDX^ICDEX(I),U,20)
+3 ;if no icdex then assume site is only on icd9
QUIT 1
IMP(D) ;EP - which coding system should be used:
+1 ;RETURN IEN of entry in ^ICDS
+2 ;1 = ICD9
+3 ;30 = ICD10
+4 ;will need to add subroutines for ICD11 when we have that.
+5 IF $GET(D)=""
SET D=DT
+6 NEW X,Y,Z
+7 SET Y=""
+8 ;icd 10 not installed yet
IF '$ORDER(^ICDS(0))
QUIT 1
+9 SET X=0
FOR
SET X=$ORDER(^ICDS("F",80,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 ;NO IMPLEMENTATION DATE?? SKIP IT
IF $PIECE(^ICDS(X,0),U,4)=""
QUIT
+11 SET Z($PIECE(^ICDS(X,0),U,4))=X
End DoDot:1
+12 ;now go through and get the last one before it imp date is greater than the visit date
+13 SET X=0
FOR
SET X=$ORDER(Z(X))
IF X=""
QUIT
Begin DoDot:1
+14 IF D<X
QUIT
+15 IF D=X
SET Y=Z(X)
QUIT
+16 IF D>X
SET Y=Z(X)
QUIT
End DoDot:1
+17 IF Y=""
SET Y=$ORDER(Z(0))
QUIT Z(Y)
+18 QUIT Y
PRIMCPT(V,F) ;EP - primaryCPT in many different formats
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 NEW %,Y,P,C,Z
+4 SET (Z,P)=""
SET (Y,C)=0
+5 SET Y=$ORDER(^AMHRPROC("AD",V,0))
IF Y
SET P=$PIECE(^AMHRPROC(Y,0),U)
SET Z=Y
+6 IF 'P
QUIT P
+7 IF '$DATA(^ICPT(P))
QUIT ""
+8 IF $GET(F)=""
SET F="C"
+9 SET %=""
DO @F
+10 QUIT %
+11 ;
SECCPT(V,N,F) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 IF '$GET(N)
QUIT ""
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
SET C=-1
FOR
SET Y=$ORDER(^AMHRPROC("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AMHRPROC(Y,0),U)
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^ICPT(P))
QUIT ""
+9 IF $GET(F)=""
SET F="C"
+10 SET %=""
DO @F
+11 QUIT %
+12 ;
CPT ;EP
+1 NEW Z,C,%,S,I,J
+2 SET (C,Y)=0
FOR
SET Y=$ORDER(^AMHRPROC("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
SET APCLV(C)=""
SET P=$PIECE(^AMHRPROC(Y,0),U)
SET Z=Y
Begin DoDot:1
+3 IF F=99
Begin DoDot:2
+4 FOR I=1:1
SET S=$TEXT(@I)
IF S=""
QUIT
SET %=""
DO @I
SET $PIECE(APCLV(C),U,I)=%
End DoDot:2
QUIT
+5 IF F[";"
Begin DoDot:2
+6 ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J
FOR J=1:1
SET I=$PIECE(F,";",J)
IF I=""
QUIT
IF I'=99
SET %=""
DO @I
SET $PIECE(APCLV(C),U,I)=%
End DoDot:2
QUIT
+7 SET %=""
SET I=F
DO @I
SET $PIECE(APCLV(C),U)=%
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
I ;
+1 SET %=P
QUIT
E ;CATEGORY
+1 SET %=$$CPT^ICPTCOD(P,$PIECE($PIECE($GET(^AMHREC(V,0)),U),"."),U,4)
QUIT
C ;CODE
+1 SET %=$$CPT^ICPTCOD(P,$PIECE($PIECE($GET(^AMHREC(V,0)),U),"."),U,2)
QUIT
+2 ;
N ;NARRATIVE - SHORT NAME
+1 SET %=$$CPT^ICPTCOD(P,$PIECE($PIECE($GET(^AMHREC(V,0)),U),"."),U,3)
QUIT
+2 ;
PTSEC(RESULT,DFN,MSG,OPT) ;EP - RPC/API entry point for patient sensitive & record access checks
+1 ;Output array (Required)
+2 ; RESULT(1)= -1-RPC/API failed
+3 ; Required variable not defined
+4 ; 0-No display/action required
+5 ; Not accessing own, employee, or sensitive record
+6 ; 1-Display warning message
+7 ; Sensitive and DG SENSITIVITY key holder
+8 ; or Employee and DG SECURITY OFFICER key holder
+9 ; 2-Display warning message/require OK to continue
+10 ; Sensitive and not a DG SENSITIVITY key holder
+11 ; Employee and not a DG SECURITY OFFICER key holder
+12 ; 3-Access to record denied
+13 ; Accessing own record
+14 ; 4-Access to Patient (#2) file records denied
+15 ; SSN not defined
+16 ; 5-Access to Patient for this User is denied ;IHS/OIT/LJF 08/31/2007 PATCH 1008
+17 ;
+18 ; RESULT(2-8) = error or display messages
+19 ;
+20 ;Input parameters: DFN = Patient file entry (Required)
+21 ; MSG = If 1, generate message (optional)
+22 ; OPT = Option name^Menu text (Optional)
+23 ;
+24 KILL RESULT
+25 IF $GET(DFN)=""
Begin DoDot:1
+26 SET RESULT(1)=-1
+27 SET RESULT(2)="Required variable missing."
End DoDot:1
QUIT
+28 ;
+29 ;IHS/OIT/LJF 08/31/2007 PATCH 1008
+30 ;S DGMSG=$G(DGMSG)
+31 SET MSG=$GET(MSG,1)
+32 IF $$STATUS^BDGSPT2(DUZ,DFN,1)["RESTRICTED ACCESS"
Begin DoDot:1
+33 SET RESULT(1)=5
IF MSG'=1
QUIT
+34 SET RESULT(2)="Sorry, you are restricted from accessing this patient's record."
+35 SET RESULT(3)="If you have questions, please contact your HIM department."
End DoDot:1
QUIT
+36 ;end of PATCH 1008 code
+37 ;
+38 DO OWNREC^DGSEC4(.RESULT,DFN,$GET(DUZ),MSG)
+39 IF RESULT(1)=1
SET RESULT(1)=3
QUIT
+40 IF RESULT(1)=2
SET RESULT(1)=4
QUIT
+41 KILL RESULT
+42 DO SENS^DGSEC4(.RESULT,DFN,$GET(DUZ))
+43 ;
+44 ;IHS/OIT/LJF 01/06/2006 PATCH 1005 account for tracking all patients
+45 ;I RESULT(1)=1 D
+46 IF (RESULT(1)=1)!(RESULT(1)=0)
Begin DoDot:1
+47 ;cmi/maw 1/26/2010 PATCH 1011
IF (RESULT(1)=0)&($$GET1^DIQ(43,1,9999999.01)'="YES")&('$PIECE($GET(^DGSL(38.1,+DFN,0)),U,2))
QUIT
+48 ;
+49 IF $GET(DUZ)=""
Begin DoDot:2
+50 ;DUZ must be defined to access sensitive record & update DG Security log
+51 SET RESULT(1)=-1
+52 SET RESULT(2)="Your user code is undefined. This must be defined to access a restricted patient record."
End DoDot:2
QUIT
+53 ;ihs/cmi/maw 12/15/2010 added set of log
DO SETLOG1^DGSEC(DFN,DUZ,,$GET(DGOPT))
End DoDot:1
+54 QUIT
ANY25(AMHX) ;EP
+1 NEW F,X,G
+2 SET X=""
SET G=0
FOR
SET X=$ORDER(^TMP("DDS",$JOB,+DDS,"F9002013.01101",X))
IF X=""
QUIT
Begin DoDot:1
+3 IF $GET(^TMP("DDS",$JOB,+DDS,"F9002013.01101",X,.02,"D"))=2
SET G=1
+4 IF $GET(^TMP("DDS",$JOB,+DDS,"F9002013.01101",X,.02,"D"))=5
SET G=1
+5 QUIT
End DoDot:1
+6 QUIT G
ICD9 ;EP - CALLED FROM INPUT TX ON SITE PARAMETERS FIELD .13
+1 IF $$CHK(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
+4 ;
CHK(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
+1 NEW A,I,D,%
+2 IF $TEXT(ICDDX^ICDEX)]""
SET %=$$ICDDX^ICDEX(Y)
IF $PIECE(%,U,20)'=1
QUIT 0
+3 IF $TEXT(ICDDX^ICDEX)=""
SET %=$$ICDDX^ICDCODE(Y)
+4 ;I $P(%,U,20)'=1 Q 0 ;not correct coding system
+5 ;no E codes
IF $EXTRACT($PIECE(%,U,2),1)="E"
QUIT 0
+6 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+7 QUIT 1
ICD10 ;EP CALLED FROM INPUT TX ON SITE PARAMETERS FIELD 1204
+1 ;
+2 IF $$CHK1(Y)
+3 IF $DATA(^ICD9(Y))
QUIT
+4 QUIT
+5 ;
CHK1(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
+1 NEW A,I,D,%
+2 IF $TEXT(ICDDX^ICDEX)]""
SET %=$$ICDDX^ICDEX(Y)
IF $PIECE(%,U,20)'=30
QUIT 0
+3 IF $TEXT(ICDDX^ICDEX)=""
SET %=$$ICDDX^ICDCODE(Y)
+4 ;I $P(%,U,20)'=30 Q 0 ;not correct coding system
+5 ;no codes V00-Y99 per Leslie Racine.
IF $EXTRACT($PIECE(%,U,2),1)="V"
QUIT 0
+6 IF $EXTRACT($PIECE(%,U,2),1)="W"
QUIT 0
+7 IF $EXTRACT($PIECE(%,U,2),1)="X"
QUIT 0
+8 IF $EXTRACT($PIECE(%,U,2),1)="Y"
QUIT 0
+9 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+10 QUIT 1
