ICDEXC4 ;SLC/KER - ICD Extractor - Code APIs (cont) ;12/19/2014
;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
;
; Global Variables
; None
;
; External References
; None
;
Q
SDH(FILE,IEN,ARY) ; Short Description History
;
; Input:
;
; FILE File Number (Required)
; IEN Internal Entry Number (Required)
; .ARY Array Passed by Reference (Optional)
;
; Output:
;
; $$SDH This is a three piece "^" delimited
; string containing:
;
; 1 Number of short descriptions found
; 2 The earliest date found
; 3 The latest date found
;
; OR -1 ^ Error Message
;
; ARY Short Descriptions by date
;
; ARY(0)= # ^ Earliest Date ^ Latest Date
; ARY(DATE)=Long Description
;
K ARY N EFF,TXT,HIS,ROOT,CNT,FD,LD,BEG,END S IEN=+($G(IEN)),LD=0,FD=9999999
S FILE=$$FILE^ICDEX($G(FILE)) Q:"^80^80.1^"'[("^"_FILE_"^") "-1^File not found"
S ROOT=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:"")
Q:'$L(ROOT) "-1^File not found" S CNT=0
S HIS=0 F S HIS=$O(@(ROOT_+IEN_",67,"_+HIS_")")) Q:+HIS'>0 D
. N NOD,EFF,TXT S NOD=$G(@(ROOT_+IEN_",67,"_+HIS_",0)"))
. S EFF=$P(NOD,"^",1),TXT=$P(NOD,"^",2) Q:EFF'?7N Q:'$L(TXT)
. S:EFF<FD FD=EFF S:EFF>LD LD=EFF
. S CNT=CNT+1,ARY(0)=CNT,ARY(EFF)=TXT
S (BEG,END)="" S:FD?7N&(FD'=9999999)&(FD'>LD) BEG=FD S:LD?7N&(LD'<FD) END=LD
S:BEG?7N&(END?7N)&(CNT>0) ARY(0)=CNT_"^"_BEG_"^"_END S CNT=ARY(0)
I +CNT'>0 D Q ERR
. N TYP S TYP=$S(FILE=80:"Diagnosis",FILE=80.1:"Operation/Procedure",1:"")
. S:$L(TYP) ERR="-1^No "_TYP_" Short Descriptions found"
. S:'$L(TYP) ERR="-1^No Short Descriptions found"
Q CNT
LDH(FILE,IEN,ARY) ; Long Description History
;
; Input:
;
; FILE File Number (Required)
; IEN Internal Entry Number (Required)
; .ARY Array Passed by Reference (Optional)
;
; Output:
;
; $$LDH This is a three piece "^" delimited
; string containing:
;
; 1 Number of long descriptions found
; 2 The earliest date found
; 3 The latest date found
;
; OR -1 ^ Error Message
;
; ARY Long Descriptions by date
;
; ARY(0)= # ^ Earliest Date ^ Latest Date
; ARY(DATE)=Long Description
;
K ARY N EFF,TXT,HIS,ROOT,CNT,FD,LD,BEG,END S IEN=+($G(IEN)),LD=0,FD=9999999
S FILE=$$FILE^ICDEX($G(FILE)) Q:"^80^80.1^"'[("^"_FILE_"^") "-1^File not found"
S ROOT=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:"")
Q:'$L(ROOT) "-1^File not found" S CNT=0
S HIS=0 F S HIS=$O(@(ROOT_+IEN_",68,"_+HIS_")")) Q:+HIS'>0 D
. N NOD,EFF,TXT S EFF=$P($G(@(ROOT_+IEN_",68,"_+HIS_",0)")),"^",1)
. S TXT=$P($G(@(ROOT_+IEN_",68,"_+HIS_",1)")),"^",1)
. Q:EFF'?7N Q:'$L(TXT)
. S:EFF<FD FD=EFF S:EFF>LD LD=EFF
. S CNT=CNT+1,ARY(0)=CNT,ARY(EFF)=TXT
S (BEG,END)="" S:FD?7N&(FD'=9999999)&(FD'>LD) BEG=FD S:LD?7N&(LD'<FD) END=LD
S:BEG?7N&(END?7N)&(CNT>0) ARY(0)=CNT_"^"_BEG_"^"_END S CNT=ARY(0)
I +CNT'>0 D Q ERR
. N TYP S TYP=$S(FILE=80:"Diagnosis",FILE=80.1:"Operation/Procedure",1:"")
. S:$L(TYP) ERR="-1^No "_TYP_" Long Descriptions found"
. S:'$L(TYP) ERR="-1^No Long Descriptions found"
Q CNT
RDX(CODE,CDT) ; Resolve Diagnosis Code Fragment
;
; Input
;
; X Code or Code Fragment (Required)
; CDT Versioning Date (Optional, Default TODAY)
;
; Output
;
; $$RDX Code if resolved
; -1 ^ error message if not resolved
;
; Example:
;
; Fragment Oct 1, 2014 Oct 1, 2015
; E8310 E831.0 E83.10
; 311 311. 311.
; A870 A87.0 A87.0
; A0201 -1^Could not resolve code fragment
;
N ICD1,ICD2,ICDC,ICDCD,ICDID,ICDIN,ICDND,ICDNX,ICDO,ICDON,ICDOP,ICDPR,ICDR,ICDS,ICDT,ICDX
S (ICDO,ICDX)=$$UP^XLFSTR(CODE),ICDC=$E(ICDO,1),ICDR="^ICD9(" Q:'$L(ICDX) "-1^Invalid input" S ICDCD=$P($G(CDT),".",1)
S:'$L(ICDCD) ICDCD=$$DT^XLFDT S ICDID=$$IMP^ICDEX(30) S ICDS="" S:ICDCD?7N ICDS=$S((ICDCD+.001)>ICDID:30,1:1)
S:ICDS=1&("ABCDFGHIJKLMNOPQRSTUWXYZ"[ICDC) ICDS=30 S:ICDS=30&(ICDC?1N) ICDS=1
Q:'$L(ICDS)!(ICDS'?1N.N) "-1^Invalid system" I $D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")")) S CODE=ICDX Q CODE
F ICDT=".",".0",".00","0","00" D
. S:$E(ICDX,1)?1N&($D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
. S:$E(ICDX,1)="E"&($E(ICDX,2,4)?3N)&($D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
. S:$E(ICDX,1)?1U&($E(ICDX,2,3)?2N)&($D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
I ICDX'=ICDO,$D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")")) S CODE=ICDX Q CODE
I ICDX=ICDO,ICDX'["." D
. N ICD1,ICD2 S ICD1=$E(ICDX,1,3),ICD2=$E(ICDX,4,$L(ICDX)) S:$E(ICDX,1)="E"&(ICDS=1) ICD1=$E(ICDX,1,4),ICD2=$E(ICDX,5,$L(ICDX))
. S:$E(ICDX,1)="E"&(ICDS=30) ICD1=$E(ICDX,1,3),ICD2=$E(ICDX,4,$L(ICDX)) Q:$E(ICDX,1)="E"&(ICDS=1)&($L(ICD1)'=4)
. Q:$E(ICDX,1)="E"&(ICDS=30)&($L(ICD1)'=3) Q:$E(ICDX,1)'="E"&($L(ICD1)'=3) S ICDX=ICD1_"."_ICD2
I ICDX'=ICDO,$D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")")) S CODE=ICDX Q CODE
I ICDX=ICDO D
. F ICDT=".",".0",".00","0","00" D
. . S:$E(ICDX,1)?1N&($D(@(ICDR_"""BA"","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
. . S:$E(ICDX,1)="E"&($E(ICDX,2,4)?3N)&($D(@(ICDR_"""BA"","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
. . S:$E(ICDX,1)?1U&($E(ICDX,2,3)?2N)&($D(@(ICDR_"""BA"","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
S CODE="-1^Could not resolve code fragment" S:$D(@(ICDR_"""BA"","""_ICDX_" "")")) CODE=ICDX
Q CODE
TRIM(X,Y) ; Trim Character
;
; Input:
;
; X Input String
; Y Character to Trim (default " ")
;
; Output:
;
; X String without Leading/Trailing character Y
;
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXC4 6176 printed Apr 09, 2024@20:57:02 Page 2
ICDEXC4 ;SLC/KER - ICD Extractor - Code APIs (cont) ;12/19/2014
+1 ;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; None
+8 ;
+9 QUIT
SDH(FILE,IEN,ARY) ; Short Description History
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File Number (Required)
+5 ; IEN Internal Entry Number (Required)
+6 ; .ARY Array Passed by Reference (Optional)
+7 ;
+8 ; Output:
+9 ;
+10 ; $$SDH This is a three piece "^" delimited
+11 ; string containing:
+12 ;
+13 ; 1 Number of short descriptions found
+14 ; 2 The earliest date found
+15 ; 3 The latest date found
+16 ;
+17 ; OR -1 ^ Error Message
+18 ;
+19 ; ARY Short Descriptions by date
+20 ;
+21 ; ARY(0)= # ^ Earliest Date ^ Latest Date
+22 ; ARY(DATE)=Long Description
+23 ;
+24 KILL ARY
NEW EFF,TXT,HIS,ROOT,CNT,FD,LD,BEG,END
SET IEN=+($GET(IEN))
SET LD=0
SET FD=9999999
+25 SET FILE=$$FILE^ICDEX($GET(FILE))
if "^80^80.1^"'[("^"_FILE_"^")
QUIT "-1^File not found"
+26 SET ROOT=$SELECT(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:"")
+27 if '$LENGTH(ROOT)
QUIT "-1^File not found"
SET CNT=0
+28 SET HIS=0
FOR
SET HIS=$ORDER(@(ROOT_+IEN_",67,"_+HIS_")"))
if +HIS'>0
QUIT
Begin DoDot:1
+29 NEW NOD,EFF,TXT
SET NOD=$GET(@(ROOT_+IEN_",67,"_+HIS_",0)"))
+30 SET EFF=$PIECE(NOD,"^",1)
SET TXT=$PIECE(NOD,"^",2)
if EFF'?7N
QUIT
if '$LENGTH(TXT)
QUIT
+31 if EFF<FD
SET FD=EFF
if EFF>LD
SET LD=EFF
+32 SET CNT=CNT+1
SET ARY(0)=CNT
SET ARY(EFF)=TXT
End DoDot:1
+33 SET (BEG,END)=""
if FD?7N&(FD'=9999999)&(FD'>LD)
SET BEG=FD
if LD?7N&(LD'<FD)
SET END=LD
+34 if BEG?7N&(END?7N)&(CNT>0)
SET ARY(0)=CNT_"^"_BEG_"^"_END
SET CNT=ARY(0)
+35 IF +CNT'>0
Begin DoDot:1
+36 NEW TYP
SET TYP=$SELECT(FILE=80:"Diagnosis",FILE=80.1:"Operation/Procedure",1:"")
+37 if $LENGTH(TYP)
SET ERR="-1^No "_TYP_" Short Descriptions found"
+38 if '$LENGTH(TYP)
SET ERR="-1^No Short Descriptions found"
End DoDot:1
QUIT ERR
+39 QUIT CNT
LDH(FILE,IEN,ARY) ; Long Description History
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File Number (Required)
+5 ; IEN Internal Entry Number (Required)
+6 ; .ARY Array Passed by Reference (Optional)
+7 ;
+8 ; Output:
+9 ;
+10 ; $$LDH This is a three piece "^" delimited
+11 ; string containing:
+12 ;
+13 ; 1 Number of long descriptions found
+14 ; 2 The earliest date found
+15 ; 3 The latest date found
+16 ;
+17 ; OR -1 ^ Error Message
+18 ;
+19 ; ARY Long Descriptions by date
+20 ;
+21 ; ARY(0)= # ^ Earliest Date ^ Latest Date
+22 ; ARY(DATE)=Long Description
+23 ;
+24 KILL ARY
NEW EFF,TXT,HIS,ROOT,CNT,FD,LD,BEG,END
SET IEN=+($GET(IEN))
SET LD=0
SET FD=9999999
+25 SET FILE=$$FILE^ICDEX($GET(FILE))
if "^80^80.1^"'[("^"_FILE_"^")
QUIT "-1^File not found"
+26 SET ROOT=$SELECT(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:"")
+27 if '$LENGTH(ROOT)
QUIT "-1^File not found"
SET CNT=0
+28 SET HIS=0
FOR
SET HIS=$ORDER(@(ROOT_+IEN_",68,"_+HIS_")"))
if +HIS'>0
QUIT
Begin DoDot:1
+29 NEW NOD,EFF,TXT
SET EFF=$PIECE($GET(@(ROOT_+IEN_",68,"_+HIS_",0)")),"^",1)
+30 SET TXT=$PIECE($GET(@(ROOT_+IEN_",68,"_+HIS_",1)")),"^",1)
+31 if EFF'?7N
QUIT
if '$LENGTH(TXT)
QUIT
+32 if EFF<FD
SET FD=EFF
if EFF>LD
SET LD=EFF
+33 SET CNT=CNT+1
SET ARY(0)=CNT
SET ARY(EFF)=TXT
End DoDot:1
+34 SET (BEG,END)=""
if FD?7N&(FD'=9999999)&(FD'>LD)
SET BEG=FD
if LD?7N&(LD'<FD)
SET END=LD
+35 if BEG?7N&(END?7N)&(CNT>0)
SET ARY(0)=CNT_"^"_BEG_"^"_END
SET CNT=ARY(0)
+36 IF +CNT'>0
Begin DoDot:1
+37 NEW TYP
SET TYP=$SELECT(FILE=80:"Diagnosis",FILE=80.1:"Operation/Procedure",1:"")
+38 if $LENGTH(TYP)
SET ERR="-1^No "_TYP_" Long Descriptions found"
+39 if '$LENGTH(TYP)
SET ERR="-1^No Long Descriptions found"
End DoDot:1
QUIT ERR
+40 QUIT CNT
RDX(CODE,CDT) ; Resolve Diagnosis Code Fragment
+1 ;
+2 ; Input
+3 ;
+4 ; X Code or Code Fragment (Required)
+5 ; CDT Versioning Date (Optional, Default TODAY)
+6 ;
+7 ; Output
+8 ;
+9 ; $$RDX Code if resolved
+10 ; -1 ^ error message if not resolved
+11 ;
+12 ; Example:
+13 ;
+14 ; Fragment Oct 1, 2014 Oct 1, 2015
+15 ; E8310 E831.0 E83.10
+16 ; 311 311. 311.
+17 ; A870 A87.0 A87.0
+18 ; A0201 -1^Could not resolve code fragment
+19 ;
+20 NEW ICD1,ICD2,ICDC,ICDCD,ICDID,ICDIN,ICDND,ICDNX,ICDO,ICDON,ICDOP,ICDPR,ICDR,ICDS,ICDT,ICDX
+21 SET (ICDO,ICDX)=$$UP^XLFSTR(CODE)
SET ICDC=$EXTRACT(ICDO,1)
SET ICDR="^ICD9("
if '$LENGTH(ICDX)
QUIT "-1^Invalid input"
SET ICDCD=$PIECE($GET(CDT),".",1)
+22 if '$LENGTH(ICDCD)
SET ICDCD=$$DT^XLFDT
SET ICDID=$$IMP^ICDEX(30)
SET ICDS=""
if ICDCD?7N
SET ICDS=$SELECT((ICDCD+.001)>ICDID:30,1:1)
+23 if ICDS=1&("ABCDFGHIJKLMNOPQRSTUWXYZ"[ICDC)
SET ICDS=30
if ICDS=30&(ICDC?1N)
SET ICDS=1
+24 if '$LENGTH(ICDS)!(ICDS'?1N.N)
QUIT "-1^Invalid system"
IF $DATA(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")"))
SET CODE=ICDX
QUIT CODE
+25 FOR ICDT=".",".0",".00","0","00"
Begin DoDot:1
+26 if $EXTRACT(ICDX,1)?1N&($DATA(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")")))
SET ICDX=ICDX_ICDT
+27 if $EXTRACT(ICDX,1)="E"&($EXTRACT(ICDX,2,4)?3N)&($DATA(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")")))
SET ICDX=ICDX_ICDT
+28 if $EXTRACT(ICDX,1)?1U&($EXTRACT(ICDX,2,3)?2N)&($DATA(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")")))
SET ICDX=ICDX_ICDT
End DoDot:1
+29 IF ICDX'=ICDO
IF $DATA(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")"))
SET CODE=ICDX
QUIT CODE
+30 IF ICDX=ICDO
IF ICDX'["."
Begin DoDot:1
+31 NEW ICD1,ICD2
SET ICD1=$EXTRACT(ICDX,1,3)
SET ICD2=$EXTRACT(ICDX,4,$LENGTH(ICDX))
if $EXTRACT(ICDX,1)="E"&(ICDS=1)
SET ICD1=$EXTRACT(ICDX,1,4)
SET ICD2=$EXTRACT(ICDX,5,$LENGTH(ICDX))
+32 if $EXTRACT(ICDX,1)="E"&(ICDS=30)
SET ICD1=$EXTRACT(ICDX,1,3)
SET ICD2=$EXTRACT(ICDX,4,$LENGTH(ICDX))
if $EXTRACT(ICDX,1)="E"&(ICDS=1)&($LENGTH(ICD1)'=4)
QUIT
+33 if $EXTRACT(ICDX,1)="E"&(ICDS=30)&($LENGTH(ICD1)'=3)
QUIT
if $EXTRACT(ICDX,1)'="E"&($LENGTH(ICD1)'=3)
QUIT
SET ICDX=ICD1_"."_ICD2
End DoDot:1
+34 IF ICDX'=ICDO
IF $DATA(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")"))
SET CODE=ICDX
QUIT CODE
+35 IF ICDX=ICDO
Begin DoDot:1
+36 FOR ICDT=".",".0",".00","0","00"
Begin DoDot:2
+37 if $EXTRACT(ICDX,1)?1N&($DATA(@(ICDR_"""BA"","""_ICDX_ICDT_" "")")))
SET ICDX=ICDX_ICDT
+38 if $EXTRACT(ICDX,1)="E"&($EXTRACT(ICDX,2,4)?3N)&($DATA(@(ICDR_"""BA"","""_ICDX_ICDT_" "")")))
SET ICDX=ICDX_ICDT
+39 if $EXTRACT(ICDX,1)?1U&($EXTRACT(ICDX,2,3)?2N)&($DATA(@(ICDR_"""BA"","""_ICDX_ICDT_" "")")))
SET ICDX=ICDX_ICDT
End DoDot:2
End DoDot:1
+40 SET CODE="-1^Could not resolve code fragment"
if $DATA(@(ICDR_"""BA"","""_ICDX_" "")"))
SET CODE=ICDX
+41 QUIT CODE
TRIM(X,Y) ; Trim Character
+1 ;
+2 ; Input:
+3 ;
+4 ; X Input String
+5 ; Y Character to Trim (default " ")
+6 ;
+7 ; Output:
+8 ;
+9 ; X String without Leading/Trailing character Y
+10 ;
+11 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+12 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+13 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+14 QUIT X
