EDPFLEX ;SLC/KCM - Lexicon Utilities ;2/28/12 08:33am
;;2.0;EMERGENCY DEPARTMENT;**2**;Feb 24, 2012;Build 23
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; $$DIAGSRCH^LEX10CS ICR 5681
;....CONFIG^LEXSET...........ICR...1609
;....LOOK^LEXA...............ICR...2950
;
ICD(TEXT) ; Return Lexicon hits for TEXT
; Begin EDP*2.0*2 changes drp 04052012
N LEX,X,Y,I,ICD,CPT,NAME,IEN,EDPCSYS,EDPRTN,EDPDOI,EDPMSG,EDPLMT
S EDPDOI=$P(REQ("inTS",1),"."),EDPLMT='($G(REQ("ignoreThreshold",1),0)),EDPMSG=0
S EDPCSYS=$$CSYS^EDPLEX(EDPDOI),EDPICDVER=$$VER^EDPLEX(EDPCSYS) ;drp
; Add validation for ICDVER after the set.
D CONFIG^LEXSET("ICD","ICD",EDPDOI)
I EDPCSYS="ICD" D LOOK^LEXA(TEXT,"ICD",999,"",EDPDOI) D ICD9(.LEX)
I EDPCSYS="10D" D
. S EDPMSG=$$TOOHI^EDPLEX(TEXT,EDPCSYS,EDPLMT)
. I EDPLMT,+EDPMSG S LEX(1,"MSG")=$P(EDPMSG,U,2)
. I '+EDPMSG S EDPRTN=$$DIAGSRCH^LEX10CS(TEXT,.LEX,EDPDOI,999) D
. . S:+EDPRTN=-1 LEX(1,"MSG")=$S($P($G(EDPRTN),"^",2):$P($G(EDPRTN),"^",2),1:"NO MATCH FOUND")
. .Q
. S LEX(1,"2HI")=+EDPMSG
. D ICD10(.LEX)
.Q
K EDPICDVER
Q
;
ICD9(LEX) ; BUILD ICD 9 SEARCH ARRAY
; this tag was renamed, but is essentially the old code with one change.
N I,ITEM
D XML^EDPX("<items>")
S I=0 F S I=$O(LEX("LIST",I)) Q:I<1 D
. K ITEM
. S IEN=$P(LEX("LIST",I),U),X=$P(LEX("LIST",I),U,2),CPT=""
. ;replaced line below with one that follows
. ;S ICD=$P($P(X,"ICD-9-CM ",2),")") I $L(ICD) S NAME=X
. S ICD=$P($P(X,EDPICDVER_" ",2),")") I $L(ICD) S NAME=X ;$P(X,"ICD-9-CM ",2) removed hardcoded ref drp
. E S CPT=$P($P(X,"CPT-4 ",2),")"),NAME=X ;$P(X," (CPT-4")
. I '$L(ICD),'$L(CPT) Q
. S:$E(NAME,$L(NAME))="*" NAME=$E(NAME,1,$L(NAME)-2)
. S ITEM("text")=NAME,ITEM("ien")=IEN,ITEM("icdType")=EDPICDVER
. I $L(ICD) S ITEM("code")=ICD,ITEM("type")="POV",ITEM("icd")=ICD
. I $L(CPT) S ITEM("code")=CPT,ITEM("type")="CPT",ITEM("cpt")=CPT
. S Y=$$XMLA^EDPX("item",.ITEM) D XML^EDPX(Y)
D XML^EDPX("</items>")
Q
ICD10(LEX) ; BUILD ICD 10 SEARCH ARRAY THERE ARE NO CPT'S
;tag added 04052012 drp EDP*2.0*2
N I,ITEM
D XML^EDPX("<items>")
S I=0 F S I=$O(LEX(I)) Q:I<1 D
. K ITEM S X=""
. S ITEM("thresholdReached")=$G(LEX(1,"2HI"),-1) ; Value should be 0 or 1, -1 denotes error state
. S:$D(LEX(I,"MSG")) ITEM("userMessage")=LEX(I,"MSG")
. S:$D(LEX(I,"IDS",1)) IEN=$P(LEX(I,"IDS",1),U),X=LEX(I,"IDS"),ITEM("childrenCount")=0
. S:$D(LEX(I,"CAT")) IEN="",X=LEX(I,"MENU"),ITEM("childrenCount")=$P(LEX(I,0),U,3)
. S ICD=$P($G(LEX(I,0),$G(LEX(I,"MSG"))),U) I $L(ICD),$L(X) S NAME=X_" ("_$G(EDPICDVER)_" "_ICD_")"
. I '$L(ICD) Q
. I $G(NAME)'="" S:$E(NAME,$L(NAME))="*" NAME=$E(NAME,1,$L(NAME)-2)
. S ITEM("text")=$G(NAME),ITEM("icdType")=EDPICDVER
. S:$G(IEN)'="" ITEM("ien")=IEN
. I $L(ICD) S ITEM("code")=ICD,ITEM("type")="POV",ITEM("icd")=ICD
. ;M ITEM(I)=LEX(I)
. S Y=$$XMLQA^EDPX("item",.ITEM) D XML^EDPX(Y)
.Q
D XML^EDPX("</items>")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPFLEX 2995 printed Apr 09, 2024@20:57:03 Page 2
EDPFLEX ;SLC/KCM - Lexicon Utilities ;2/28/12 08:33am
+1 ;;2.0;EMERGENCY DEPARTMENT;**2**;Feb 24, 2012;Build 23
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; $$DIAGSRCH^LEX10CS ICR 5681
+5 ;....CONFIG^LEXSET...........ICR...1609
+6 ;....LOOK^LEXA...............ICR...2950
+7 ;
ICD(TEXT) ; Return Lexicon hits for TEXT
+1 ; Begin EDP*2.0*2 changes drp 04052012
+2 NEW LEX,X,Y,I,ICD,CPT,NAME,IEN,EDPCSYS,EDPRTN,EDPDOI,EDPMSG,EDPLMT
+3 SET EDPDOI=$PIECE(REQ("inTS",1),".")
SET EDPLMT='($GET(REQ("ignoreThreshold",1),0))
SET EDPMSG=0
+4 ;drp
SET EDPCSYS=$$CSYS^EDPLEX(EDPDOI)
SET EDPICDVER=$$VER^EDPLEX(EDPCSYS)
+5 ; Add validation for ICDVER after the set.
+6 DO CONFIG^LEXSET("ICD","ICD",EDPDOI)
+7 IF EDPCSYS="ICD"
DO LOOK^LEXA(TEXT,"ICD",999,"",EDPDOI)
DO ICD9(.LEX)
+8 IF EDPCSYS="10D"
Begin DoDot:1
+9 SET EDPMSG=$$TOOHI^EDPLEX(TEXT,EDPCSYS,EDPLMT)
+10 IF EDPLMT
IF +EDPMSG
SET LEX(1,"MSG")=$PIECE(EDPMSG,U,2)
+11 IF '+EDPMSG
SET EDPRTN=$$DIAGSRCH^LEX10CS(TEXT,.LEX,EDPDOI,999)
Begin DoDot:2
+12 if +EDPRTN=-1
SET LEX(1,"MSG")=$SELECT($PIECE($GET(EDPRTN),"^",2):$PIECE($GET(EDPRTN),"^",2),1:"NO MATCH FOUND")
+13 QUIT
End DoDot:2
+14 SET LEX(1,"2HI")=+EDPMSG
+15 DO ICD10(.LEX)
+16 QUIT
End DoDot:1
+17 KILL EDPICDVER
+18 QUIT
+19 ;
ICD9(LEX) ; BUILD ICD 9 SEARCH ARRAY
+1 ; this tag was renamed, but is essentially the old code with one change.
+2 NEW I,ITEM
+3 DO XML^EDPX("<items>")
+4 SET I=0
FOR
SET I=$ORDER(LEX("LIST",I))
if I<1
QUIT
Begin DoDot:1
+5 KILL ITEM
+6 SET IEN=$PIECE(LEX("LIST",I),U)
SET X=$PIECE(LEX("LIST",I),U,2)
SET CPT=""
+7 ;replaced line below with one that follows
+8 ;S ICD=$P($P(X,"ICD-9-CM ",2),")") I $L(ICD) S NAME=X
+9 ;$P(X,"ICD-9-CM ",2) removed hardcoded ref drp
SET ICD=$PIECE($PIECE(X,EDPICDVER_" ",2),")")
IF $LENGTH(ICD)
SET NAME=X
+10 ;$P(X," (CPT-4")
IF '$TEST
SET CPT=$PIECE($PIECE(X,"CPT-4 ",2),")")
SET NAME=X
+11 IF '$LENGTH(ICD)
IF '$LENGTH(CPT)
QUIT
+12 if $EXTRACT(NAME,$LENGTH(NAME))="*"
SET NAME=$EXTRACT(NAME,1,$LENGTH(NAME)-2)
+13 SET ITEM("text")=NAME
SET ITEM("ien")=IEN
SET ITEM("icdType")=EDPICDVER
+14 IF $LENGTH(ICD)
SET ITEM("code")=ICD
SET ITEM("type")="POV"
SET ITEM("icd")=ICD
+15 IF $LENGTH(CPT)
SET ITEM("code")=CPT
SET ITEM("type")="CPT"
SET ITEM("cpt")=CPT
+16 SET Y=$$XMLA^EDPX("item",.ITEM)
DO XML^EDPX(Y)
End DoDot:1
+17 DO XML^EDPX("</items>")
+18 QUIT
ICD10(LEX) ; BUILD ICD 10 SEARCH ARRAY THERE ARE NO CPT'S
+1 ;tag added 04052012 drp EDP*2.0*2
+2 NEW I,ITEM
+3 DO XML^EDPX("<items>")
+4 SET I=0
FOR
SET I=$ORDER(LEX(I))
if I<1
QUIT
Begin DoDot:1
+5 KILL ITEM
SET X=""
+6 ; Value should be 0 or 1, -1 denotes error state
SET ITEM("thresholdReached")=$GET(LEX(1,"2HI"),-1)
+7 if $DATA(LEX(I,"MSG"))
SET ITEM("userMessage")=LEX(I,"MSG")
+8 if $DATA(LEX(I,"IDS",1))
SET IEN=$PIECE(LEX(I,"IDS",1),U)
SET X=LEX(I,"IDS")
SET ITEM("childrenCount")=0
+9 if $DATA(LEX(I,"CAT"))
SET IEN=""
SET X=LEX(I,"MENU")
SET ITEM("childrenCount")=$PIECE(LEX(I,0),U,3)
+10 SET ICD=$PIECE($GET(LEX(I,0),$GET(LEX(I,"MSG"))),U)
IF $LENGTH(ICD)
IF $LENGTH(X)
SET NAME=X_" ("_$GET(EDPICDVER)_" "_ICD_")"
+11 IF '$LENGTH(ICD)
QUIT
+12 IF $GET(NAME)'=""
if $EXTRACT(NAME,$LENGTH(NAME))="*"
SET NAME=$EXTRACT(NAME,1,$LENGTH(NAME)-2)
+13 SET ITEM("text")=$GET(NAME)
SET ITEM("icdType")=EDPICDVER
+14 if $GET(IEN)'=""
SET ITEM("ien")=IEN
+15 IF $LENGTH(ICD)
SET ITEM("code")=ICD
SET ITEM("type")="POV"
SET ITEM("icd")=ICD
+16 ;M ITEM(I)=LEX(I)
+17 SET Y=$$XMLQA^EDPX("item",.ITEM)
DO XML^EDPX(Y)
+18 QUIT
End DoDot:1
+19 DO XML^EDPX("</items>")
+20 QUIT
