ICDEXD4 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
;
; Global Variables
; ^ICD("B") N/A
; ^ICD9("BA") N/A
; ^ICDID("B") N/A
; ^ICDIP("B") N/A
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; ^DIC ICR 10006
;
Q
ICDID(FILE,ID,CODE) ; Check if ICD identifier exist
;
; Input:
;
; FILE File Number or root (required)
; 80 or ^ICD9 = File #80
; 80.1 or ^ICD0 = File #80.1
; ID Diagnosis/Procedure code identifier (required)
; CODE Diagnosis/Procedure code IEN (required)
;
; Output:
;
; $$ICDID Boolean value
; 1 if identifier was found
; 0 if identifier was not found
;
; or upon error -1^error message
;
N ICDC,ICDF,ICDI,ICDID,ICDIDI,ICDRT S ICDF=$$FILE^ICDEX($G(FILE))
I "^80^80.1^"'[("^"_ICDF_"^") Q "-1^Invalid File"
S ICDID=$G(ID),(ICDI,ICDC)=$G(CODE)
I ICDID="" Q "-1^Missing identifier"
S ICDRT=$$ROOT^ICDEX(ICDF)
I "^ICD9(^ICD0(^"'[("^"_$E(ICDRT,2,$L(ICDRT))_"^") Q "-1^Invalid Global"
I '$D(@(ICDRT_+ICDI_")")),$D(@(ICDRT_"""BA"","""_($G(ICDC)_" ")_""")")) D
. S ICDI=$O(@(ICDRT_"""BA"","""_($G(ICDC)_" ")_""",0)"))
Q:+ICDI'>0!('$D(@(ICDRT_+ICDI_")"))) "-1^Invalid IEN"
S ICDRT=$$ROOT^ICDEX(ICDF)
S ICDIDI=$$IDIEN(ICDF,ID) I +ICDIDI'>0 Q "-1^Invalid identifier"
I $D(@(ICDRT_ICDI_",73,""B"","_ICDIDI_")")) Q 1
Q 0
IDIEN(FILE,ID) ; Get IEN for identifier
N ICDF,ICDID S ICDF=$$FILE^ICDEX($G(FILE))
I "^80^80.1^"'[("^"_FILE_"^") Q ""
S ICDID=$G(ID) Q:'$L($G(ICDID)) ""
Q:ICDF=80 $O(^ICDID("B",ICDID,""))
Q:ICDF=80.1 $O(^ICDIP("B",ICDID,""))
Q ""
IDSTR(FILE,IEN) ; Return ICD identifier string (legacy)
;
; Input:
;
; FILE File Number or root (required)
; 80 or ^ICD9 = File #80
; 80.1 or ^ICD0 = File #80.1
; IEN Diagnosis/Procedure code IEN (required)
;
; Output:
;
; $$IDSTR String of Identifiers delimited by a semi-colon
;
; ID;ID;ID
;
N ICDA,ICDT,ICDS,ICDI S ICDT=$$ICDIDS($G(FILE),$G(IEN),.ICDA),ICDS=""
S ICDI="" F S ICDI=$O(ICDA(ICDI)) Q:'$L(ICDI) S ICDS=ICDS_";"_ICDI
F Q:$E(ICDS,1)'=";" S ICDS=$E(ICDS,2,$L(ICDS))
Q ICDS
ICDIDS(FILE,IEN,ARY) ; Return array of ICD identifiers
;
; Input:
;
; FILE File Number or root (required)
; 80 or ^ICD9 = File #80
; 80.1 or ^ICD0 = File #80.1
; IEN Diagnosis/Procedure code IEN (required)
; ARY Array Name passed by reference (required)
;
; Output:
;
; $$ICDIDS Number of Identifiers found
; 0 (zero) if no identifiers found
;
; or upon error -1^error message
;
; ARY Array of identifiers found
; ARY(<identifier>)=""
;
K ARY N ICDC,ICDF,ICDI,ICDID,ICDIDI,ICDRT,ICDRTI,ICDSTR,ICDX,ICDP,ICDCS
S ICDF=$$FILE^ICDEX($G(FILE)),(ICDI,ICDC)=$G(IEN)
I "^80^80.1^"'[("^"_ICDF_"^") Q "-1^Invalid File"
S ICDRT=$$ROOT^ICDEX(ICDF),ICDRTI=$S(ICDF=80:"^ICDID(",1:"^ICDIP(")
I "^ICD9(^ICD0(^"'[("^"_$E(ICDRT,2,$L(ICDRT))_"^") Q "-1^Invalid Global"
I '$D(@(ICDRT_+ICDI_")")),$D(@(ICDRT_"""BA"","""_($G(ICDC)_" ")_""")")) D
. S ICDI=$O(@(ICDRT_"""BA"","""_($G(ICDC)_" ")_""",0)"))
Q:+ICDI'>0!('$D(@(ICDRT_+ICDI_")"))) "-1^Invalid IEN"
S ICDCS=+($P($G(@(ICDRT_+ICDI_",1)")),"^",1))
S (ICDC,ICDIDI)=0 F S ICDIDI=$O(@((ICDRT_+ICDI_",73,"_+ICDIDI_")"))) Q:+ICDIDI'>0 D
. S ICDID=$G(@((ICDRT_+ICDI_",73,"_+ICDIDI_",0)")))
. S ICDID=$P($G(@((ICDRTI_+ICDID_",0)"))),"^",1) Q:'$L(ICDID)
. I '$D(ARY(ICDID)) S ARY(ICDID)="",ICDC=ICDC+1
I ICDC'>0,ICDCS>0,ICDCS'>2 D
. N ICDV I ICDF=80 D
. . S ICDV="^H^V^p^F^J^T^A^P^d^Y^t^r^l^E^K^R^O^I^G^D^m^S^u^X^a^B^"
. . S ICDV=ICDV_"b^z^M^U^L^v^k^h^i^j^Q^W^Z^c^s^g^1^2^3^4^5^6^*^"
. I ICDF=80.1 D
. . S ICDV="^H^N^E^g^a^K^S^T^O^L^I^c^n^s^d^z^y^e^D^R^P^o^l^b^t^B^"
. . S ICDV=ICDV_"h^p^m^M^q^r^u^x^F^k^f^V^C^Q^I^J^1^2^3^4^6^7^"
. S ICDSTR=$P($G(@(ICDRT_+ICDI_",1)")),"^",2) I $L(ICDSTR) D
. . N ICDX,ICDP F ICDP=1:1 S ICDX=$E(ICDSTR,ICDP) Q:'$L(ICDX) D
. . . I $L(ICDX),$L(ICDRTI),$D(@(ICDRTI_"""B"")")) D Q
. . . . I $D(@(ICDRTI_"""B"","""_$G(ICDX)_""")")) D
. . . . . S ARY(ICDX)="",ICDC=ICDC+1
. . . I ICDV[("^"_ICDX_"^") D Q
. . . . I '$D(ARY(ICDX)) S ARY(ICDX)="",ICDC=ICDC+1
Q ICDC
ISOWNCC(IEN,CDT,FMT) ; Return CC if DX is Own CC
;
; Input:
;
; IEN Internal Entry Number for file 80 (required)
; CDT Date to use to extract CC (default TODAY)
; FMT Output Format
; 0 = CC only (default)
; 1 = CC ^ Effective Date
; Output:
;
; $$ISOWNCC Complication/Comorbidity (CC)
;
; DX is Own CC Format Output
; ------------ ------ -------------------------
; Yes 0 CC Value
; Yes 1 CC Value ^ Effective Date
; No N/A 0 (zero)
;
; or upon error -1^error message
;
N ICDC,ICDCC,ICDCCI,ICDD,ICDFMT,ICDI,ICDN,ICDOWN,ICDRT
S (ICDI,ICDC)=$G(IEN),ICDRT=$$ROOT^ICDEX(80)
I '$D(^ICD9(+ICDI,0)),$D(^ICD9("BA",(ICDC_" "))) D
. S ICDI=$O(^ICD9("BA",(ICDC_" "),0))
Q:+ICDI'>0!('$D(^ICD9(+ICDI,0))) "-1^Invalid IEN"
S ICDD=$P($G(CDT),".",1) S:ICDD'?7N ICDD=$$DT^XLFDT
S ICDFMT=+($G(FMT)) S:ICDFMT'=1 ICDFMT=0
S ICDD=$O(^ICD9(+ICDI,69,"B",CDT+.0001),-1) Q:'$L(ICDD) 0
S ICDCCI=$O(^ICD9(+ICDI,69,"B",ICDD,""),-1)
S ICDN=^ICD9(+ICDI,69,+ICDCCI,0),ICDOWN=$P(ICDN,U,3)
Q:'ICDOWN 0 S ICDCC=$P(ICDN,U,2)
S:ICDFMT>0 ICDCC=ICDCC_"^"_$P(^ICD9(+ICDI,69,+ICDCCI,0),U,1)
Q ICDCC
ICDRGCC(DRG,CDT) ; Get CC/MCC flag from DRG
;
; Input:
;
; DRG Internal Entry Number for file 80.2 (required)
; CDT Date to use to extract CC/MCC flag (default TODAY)
;
; Output:
;
; $$ICDRGCC Complication/Comorbidity/Major CC flag
;
; 0 No CC or MCC
; 1 CC present
; 2 MCC present
; 3 CC or MCC present
;
; or upon error -1^error message
;
N ICDAI,ICDCC,ICDD,ICDDA,ICDDE,ICDRG,ICDI
S ICDRG=$G(DRG),ICDD=$P($G(CDT),".",1) S:ICDD'?7N ICDD=$$DT^XLFDT
S ICDDE=$$FMTE^XLFDT($P(ICDD,".",1),"5Z"),ICDCC="-1^DRG not found"
S ICDI=$O(^ICD("B","DRG"_ICDRG,"")) I ICDI D
. S ICDCC="-1^No DRG for date"_$S($L($G(ICDDE)):(" "_$G(ICDDE)),1:"")
. S ICDDA=$O(^ICD(ICDI,2,"B",(ICDD_".1")),-1) I ICDDA D
. . S ICDAI=$O(^ICD(ICDI,2,"B",ICDDA,"")) I ICDAI D
. . . S ICDCC=$P(^ICD(ICDI,2,ICDAI,0),U,4)
Q ICDCC
INQ ; Inquire to ICD codes (interactive)
;
; User will be prompted for:
;
; Effective Date
; File
; Code
;
; Displays Code
; Short Text
; Description
; Description Warnings (if any)
; Text may be inaccurate, Effective Date
; Predates Code Set Versioning
; Predates Coding System Implementation
; Predates Initial Activation Date
; Activation Warnings (if any)
; Code is Inactive
; Code is pending (activated in the future)
;
N DIC,DIROUT,DIRUT,DTOUT,DUOUT,ICDA,ICDACT,ICDC,ICDCOM,ICDCS
N ICDCSI,ICDDAT,ICDDT,ICDEFF,ICDF,ICDFMT,ICDI,ICDIA,ICDIEN
N ICDIMP,ICDINA,ICDLT,ICDMSG,ICDR,ICDSO,ICDST,ICDSTA,ICDT,Y
INQ2 ; Inquire to ICD codes (recursive)
S ICDDT=$$EFD^ICDEX,ICDEFF=$P(ICDDT,"^",1) I ICDEFF'?7N W !!," Effective Date not specified" Q
W ! S ICDCS=$$CS^ICDEX(,,ICDEFF) I +ICDCS'>0 W !!," File not specified" Q
S ICDCSI=$$SINFO^ICDEX(+ICDCS),ICDF=$P(ICDCSI,"^",4),(DIC,ICDR)=$$ROOT^ICDEX(ICDF),DIC(0)="AEQMZ"
S DIC("A")=" Select "_$P($P(ICDCSI,"^",2)," ",1)_" "_$P(ICDCSI,"^",6)_" Code: ",ICDFMT=2
W ! D ^DIC W:$D(DTOUT) !!," Try again later" Q:$D(DTOUT) Q:$D(DUOUT)!($D(DIRUT))!($D(DIROUT))
W:+($G(Y))'>0 !!," Code not selected" Q:+($G(Y))'>0 S ICDIEN=+($G(Y)),ICDCS=$$CSI^ICDEX(ICDF,+ICDIEN)
S ICDCSI=$$SINFO^ICDEX(+ICDCS) S:ICDF=80 ICDDAT=$$ICDDX^ICDEX(+ICDIEN,ICDEFF,,"I")
S:ICDF=80.1 ICDDAT=$$ICDOP^ICDEX(+ICDIEN,ICDEFF,,"I") S ICDSO=$G(Y(0,0))
S:ICDF="80" ICDST=$P(ICDDAT,"^",4) S:ICDF="80.1" ICDST=$P(ICDDAT,"^",5)
S ICDLT=$G(Y(0,2)) K ICDA S ICDC=$$LD^ICDEX(ICDF,ICDIEN,ICDEFF,.ICDA,64) I $P(ICDC,"^",1)="-1" D
. N ICDCOM,ICDT S ICDCOM="" I $P(ICDLT,"^",1)="-1",$L($P(ICDLT,"^",2)) D
. . S ICDCOM="No description available for "_$$FMTE^XLFDT(ICDEFF)
. K ICDA S ICDC=$$LD^ICDEX(ICDF,ICDIEN,9990101,.ICDA,64)
S ICDSTA=$P(ICDDAT,"^",10),ICDINA=$P(ICDDAT,"^",12)
S:ICDF="80" ICDACT=$P(ICDDAT,"^",17) S:ICDF="80.1" ICDACT=$P(ICDDAT,"^",13)
S ICDMSG(1)=$$MSG^ICDEX(ICDEFF,+($G(ICDCS)))
S:$L(ICDMSG(1)) ICDMSG(1)="Descriptive text may be inaccurate, predates Code Set Versioning"
S ICDIMP=$$IMP^ICDEX(+($G(ICDCS))),ICDIA=$$IA^ICDEX(ICDF,+ICDIEN)
I ICDIMP?7N,ICDEFF?7N,ICDEFF<ICDIMP D
. N ICDT S ICDT=$P($P($G(ICDCSI),"^",2)," ",1)
. S ICDMSG(1)="Descriptive text may be inaccurate, predates implementation date"
. S:$L(ICDT) ICDMSG(1)="Descriptive text may be inaccurate, user input predates "
. S:$L(ICDT) ICDMSG(1)=ICDMSG(1)_ICDT_" implementation date of "_$$FMTE^XLFDT(ICDIMP,"5Z")
I ICDIA?7N,ICDEFF?7N,ICDEFF<ICDIA D
. N ICDT S ICDT=$P($P($G(ICDCSI),"^",2)," ",1)
. S ICDMSG(1)="Descriptive text may be inaccurate, predates the initial activation date"
. S:$L(ICDT) ICDMSG(1)="Descriptive text may be inaccurate, user input predates "
. S:$L(ICDT) ICDMSG(1)=ICDMSG(1)_" the code's initial activation date of "
. S:$L(ICDT) ICDMSG(1)=ICDMSG(1)_$$FMTE^XLFDT(ICDIA,"5Z")
D:$L($G(ICDMSG(1))) PAR^ICDEX(.ICDMSG,64)
W !!," ",ICDSO,?15,ICDST S (ICDC,ICDI)=0 F S ICDI=$O(ICDA(ICDI)) Q:+ICDI'>0 D
. Q:'$L($G(ICDA(ICDI))) S ICDC=ICDC+1
. W ! W:ICDC=1 !," Description" W ?15,$G(ICDA(ICDI))
W:$L($G(ICDMSG(1))) ! F ICDI=1:1:3 W:$L($G(ICDMSG(ICDI))) !,?15,$G(ICDMSG(ICDI))
I +($G(ICDSTA))'>0,$G(ICDINA)?7N D
. W !!,?15," ** CODE INACTIVE AS OF: ",$$FMTE^XLFDT(ICDINA,"5Z")," **",!
I +ICDSTA>0,ICDACT>ICDEFF D
. W !!,?15," ** PENDING ACTIVATION ON: ",$$FMTE^XLFDT(ICDACT,"5Z")," **",!
G INQ2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXD4 10591 printed Sep 23, 2025@19:26:41 Page 2
ICDEXD4 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^ICD("B") N/A
+5 ; ^ICD9("BA") N/A
+6 ; ^ICDID("B") N/A
+7 ; ^ICDIP("B") N/A
+8 ;
+9 ; External References
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMTE^XLFDT ICR 10103
+12 ; ^DIC ICR 10006
+13 ;
+14 QUIT
ICDID(FILE,ID,CODE) ; Check if ICD identifier exist
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File Number or root (required)
+5 ; 80 or ^ICD9 = File #80
+6 ; 80.1 or ^ICD0 = File #80.1
+7 ; ID Diagnosis/Procedure code identifier (required)
+8 ; CODE Diagnosis/Procedure code IEN (required)
+9 ;
+10 ; Output:
+11 ;
+12 ; $$ICDID Boolean value
+13 ; 1 if identifier was found
+14 ; 0 if identifier was not found
+15 ;
+16 ; or upon error -1^error message
+17 ;
+18 NEW ICDC,ICDF,ICDI,ICDID,ICDIDI,ICDRT
SET ICDF=$$FILE^ICDEX($GET(FILE))
+19 IF "^80^80.1^"'[("^"_ICDF_"^")
QUIT "-1^Invalid File"
+20 SET ICDID=$GET(ID)
SET (ICDI,ICDC)=$GET(CODE)
+21 IF ICDID=""
QUIT "-1^Missing identifier"
+22 SET ICDRT=$$ROOT^ICDEX(ICDF)
+23 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ICDRT,2,$LENGTH(ICDRT))_"^")
QUIT "-1^Invalid Global"
+24 IF '$DATA(@(ICDRT_+ICDI_")"))
IF $DATA(@(ICDRT_"""BA"","""_($GET(ICDC)_" ")_""")"))
Begin DoDot:1
+25 SET ICDI=$ORDER(@(ICDRT_"""BA"","""_($GET(ICDC)_" ")_""",0)"))
End DoDot:1
+26 if +ICDI'>0!('$DATA(@(ICDRT_+ICDI_")")))
QUIT "-1^Invalid IEN"
+27 SET ICDRT=$$ROOT^ICDEX(ICDF)
+28 SET ICDIDI=$$IDIEN(ICDF,ID)
IF +ICDIDI'>0
QUIT "-1^Invalid identifier"
+29 IF $DATA(@(ICDRT_ICDI_",73,""B"","_ICDIDI_")"))
QUIT 1
+30 QUIT 0
IDIEN(FILE,ID) ; Get IEN for identifier
+1 NEW ICDF,ICDID
SET ICDF=$$FILE^ICDEX($GET(FILE))
+2 IF "^80^80.1^"'[("^"_FILE_"^")
QUIT ""
+3 SET ICDID=$GET(ID)
if '$LENGTH($GET(ICDID))
QUIT ""
+4 if ICDF=80
QUIT $ORDER(^ICDID("B",ICDID,""))
+5 if ICDF=80.1
QUIT $ORDER(^ICDIP("B",ICDID,""))
+6 QUIT ""
IDSTR(FILE,IEN) ; Return ICD identifier string (legacy)
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File Number or root (required)
+5 ; 80 or ^ICD9 = File #80
+6 ; 80.1 or ^ICD0 = File #80.1
+7 ; IEN Diagnosis/Procedure code IEN (required)
+8 ;
+9 ; Output:
+10 ;
+11 ; $$IDSTR String of Identifiers delimited by a semi-colon
+12 ;
+13 ; ID;ID;ID
+14 ;
+15 NEW ICDA,ICDT,ICDS,ICDI
SET ICDT=$$ICDIDS($GET(FILE),$GET(IEN),.ICDA)
SET ICDS=""
+16 SET ICDI=""
FOR
SET ICDI=$ORDER(ICDA(ICDI))
if '$LENGTH(ICDI)
QUIT
SET ICDS=ICDS_";"_ICDI
+17 FOR
if $EXTRACT(ICDS,1)'=";"
QUIT
SET ICDS=$EXTRACT(ICDS,2,$LENGTH(ICDS))
+18 QUIT ICDS
ICDIDS(FILE,IEN,ARY) ; Return array of ICD identifiers
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File Number or root (required)
+5 ; 80 or ^ICD9 = File #80
+6 ; 80.1 or ^ICD0 = File #80.1
+7 ; IEN Diagnosis/Procedure code IEN (required)
+8 ; ARY Array Name passed by reference (required)
+9 ;
+10 ; Output:
+11 ;
+12 ; $$ICDIDS Number of Identifiers found
+13 ; 0 (zero) if no identifiers found
+14 ;
+15 ; or upon error -1^error message
+16 ;
+17 ; ARY Array of identifiers found
+18 ; ARY(<identifier>)=""
+19 ;
+20 KILL ARY
NEW ICDC,ICDF,ICDI,ICDID,ICDIDI,ICDRT,ICDRTI,ICDSTR,ICDX,ICDP,ICDCS
+21 SET ICDF=$$FILE^ICDEX($GET(FILE))
SET (ICDI,ICDC)=$GET(IEN)
+22 IF "^80^80.1^"'[("^"_ICDF_"^")
QUIT "-1^Invalid File"
+23 SET ICDRT=$$ROOT^ICDEX(ICDF)
SET ICDRTI=$SELECT(ICDF=80:"^ICDID(",1:"^ICDIP(")
+24 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ICDRT,2,$LENGTH(ICDRT))_"^")
QUIT "-1^Invalid Global"
+25 IF '$DATA(@(ICDRT_+ICDI_")"))
IF $DATA(@(ICDRT_"""BA"","""_($GET(ICDC)_" ")_""")"))
Begin DoDot:1
+26 SET ICDI=$ORDER(@(ICDRT_"""BA"","""_($GET(ICDC)_" ")_""",0)"))
End DoDot:1
+27 if +ICDI'>0!('$DATA(@(ICDRT_+ICDI_")")))
QUIT "-1^Invalid IEN"
+28 SET ICDCS=+($PIECE($GET(@(ICDRT_+ICDI_",1)")),"^",1))
+29 SET (ICDC,ICDIDI)=0
FOR
SET ICDIDI=$ORDER(@((ICDRT_+ICDI_",73,"_+ICDIDI_")")))
if +ICDIDI'>0
QUIT
Begin DoDot:1
+30 SET ICDID=$GET(@((ICDRT_+ICDI_",73,"_+ICDIDI_",0)")))
+31 SET ICDID=$PIECE($GET(@((ICDRTI_+ICDID_",0)"))),"^",1)
if '$LENGTH(ICDID)
QUIT
+32 IF '$DATA(ARY(ICDID))
SET ARY(ICDID)=""
SET ICDC=ICDC+1
End DoDot:1
+33 IF ICDC'>0
IF ICDCS>0
IF ICDCS'>2
Begin DoDot:1
+34 NEW ICDV
IF ICDF=80
Begin DoDot:2
+35 SET ICDV="^H^V^p^F^J^T^A^P^d^Y^t^r^l^E^K^R^O^I^G^D^m^S^u^X^a^B^"
+36 SET ICDV=ICDV_"b^z^M^U^L^v^k^h^i^j^Q^W^Z^c^s^g^1^2^3^4^5^6^*^"
End DoDot:2
+37 IF ICDF=80.1
Begin DoDot:2
+38 SET ICDV="^H^N^E^g^a^K^S^T^O^L^I^c^n^s^d^z^y^e^D^R^P^o^l^b^t^B^"
+39 SET ICDV=ICDV_"h^p^m^M^q^r^u^x^F^k^f^V^C^Q^I^J^1^2^3^4^6^7^"
End DoDot:2
+40 SET ICDSTR=$PIECE($GET(@(ICDRT_+ICDI_",1)")),"^",2)
IF $LENGTH(ICDSTR)
Begin DoDot:2
+41 NEW ICDX,ICDP
FOR ICDP=1:1
SET ICDX=$EXTRACT(ICDSTR,ICDP)
if '$LENGTH(ICDX)
QUIT
Begin DoDot:3
+42 IF $LENGTH(ICDX)
IF $LENGTH(ICDRTI)
IF $DATA(@(ICDRTI_"""B"")"))
Begin DoDot:4
+43 IF $DATA(@(ICDRTI_"""B"","""_$GET(ICDX)_""")"))
Begin DoDot:5
+44 SET ARY(ICDX)=""
SET ICDC=ICDC+1
End DoDot:5
End DoDot:4
QUIT
+45 IF ICDV[("^"_ICDX_"^")
Begin DoDot:4
+46 IF '$DATA(ARY(ICDX))
SET ARY(ICDX)=""
SET ICDC=ICDC+1
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT ICDC
ISOWNCC(IEN,CDT,FMT) ; Return CC if DX is Own CC
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80 (required)
+5 ; CDT Date to use to extract CC (default TODAY)
+6 ; FMT Output Format
+7 ; 0 = CC only (default)
+8 ; 1 = CC ^ Effective Date
+9 ; Output:
+10 ;
+11 ; $$ISOWNCC Complication/Comorbidity (CC)
+12 ;
+13 ; DX is Own CC Format Output
+14 ; ------------ ------ -------------------------
+15 ; Yes 0 CC Value
+16 ; Yes 1 CC Value ^ Effective Date
+17 ; No N/A 0 (zero)
+18 ;
+19 ; or upon error -1^error message
+20 ;
+21 NEW ICDC,ICDCC,ICDCCI,ICDD,ICDFMT,ICDI,ICDN,ICDOWN,ICDRT
+22 SET (ICDI,ICDC)=$GET(IEN)
SET ICDRT=$$ROOT^ICDEX(80)
+23 IF '$DATA(^ICD9(+ICDI,0))
IF $DATA(^ICD9("BA",(ICDC_" ")))
Begin DoDot:1
+24 SET ICDI=$ORDER(^ICD9("BA",(ICDC_" "),0))
End DoDot:1
+25 if +ICDI'>0!('$DATA(^ICD9(+ICDI,0)))
QUIT "-1^Invalid IEN"
+26 SET ICDD=$PIECE($GET(CDT),".",1)
if ICDD'?7N
SET ICDD=$$DT^XLFDT
+27 SET ICDFMT=+($GET(FMT))
if ICDFMT'=1
SET ICDFMT=0
+28 SET ICDD=$ORDER(^ICD9(+ICDI,69,"B",CDT+.0001),-1)
if '$LENGTH(ICDD)
QUIT 0
+29 SET ICDCCI=$ORDER(^ICD9(+ICDI,69,"B",ICDD,""),-1)
+30 SET ICDN=^ICD9(+ICDI,69,+ICDCCI,0)
SET ICDOWN=$PIECE(ICDN,U,3)
+31 if 'ICDOWN
QUIT 0
SET ICDCC=$PIECE(ICDN,U,2)
+32 if ICDFMT>0
SET ICDCC=ICDCC_"^"_$PIECE(^ICD9(+ICDI,69,+ICDCCI,0),U,1)
+33 QUIT ICDCC
ICDRGCC(DRG,CDT) ; Get CC/MCC flag from DRG
+1 ;
+2 ; Input:
+3 ;
+4 ; DRG Internal Entry Number for file 80.2 (required)
+5 ; CDT Date to use to extract CC/MCC flag (default TODAY)
+6 ;
+7 ; Output:
+8 ;
+9 ; $$ICDRGCC Complication/Comorbidity/Major CC flag
+10 ;
+11 ; 0 No CC or MCC
+12 ; 1 CC present
+13 ; 2 MCC present
+14 ; 3 CC or MCC present
+15 ;
+16 ; or upon error -1^error message
+17 ;
+18 NEW ICDAI,ICDCC,ICDD,ICDDA,ICDDE,ICDRG,ICDI
+19 SET ICDRG=$GET(DRG)
SET ICDD=$PIECE($GET(CDT),".",1)
if ICDD'?7N
SET ICDD=$$DT^XLFDT
+20 SET ICDDE=$$FMTE^XLFDT($PIECE(ICDD,".",1),"5Z")
SET ICDCC="-1^DRG not found"
+21 SET ICDI=$ORDER(^ICD("B","DRG"_ICDRG,""))
IF ICDI
Begin DoDot:1
+22 SET ICDCC="-1^No DRG for date"_$SELECT($LENGTH($GET(ICDDE)):(" "_$GET(ICDDE)),1:"")
+23 SET ICDDA=$ORDER(^ICD(ICDI,2,"B",(ICDD_".1")),-1)
IF ICDDA
Begin DoDot:2
+24 SET ICDAI=$ORDER(^ICD(ICDI,2,"B",ICDDA,""))
IF ICDAI
Begin DoDot:3
+25 SET ICDCC=$PIECE(^ICD(ICDI,2,ICDAI,0),U,4)
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT ICDCC
INQ ; Inquire to ICD codes (interactive)
+1 ;
+2 ; User will be prompted for:
+3 ;
+4 ; Effective Date
+5 ; File
+6 ; Code
+7 ;
+8 ; Displays Code
+9 ; Short Text
+10 ; Description
+11 ; Description Warnings (if any)
+12 ; Text may be inaccurate, Effective Date
+13 ; Predates Code Set Versioning
+14 ; Predates Coding System Implementation
+15 ; Predates Initial Activation Date
+16 ; Activation Warnings (if any)
+17 ; Code is Inactive
+18 ; Code is pending (activated in the future)
+19 ;
+20 NEW DIC,DIROUT,DIRUT,DTOUT,DUOUT,ICDA,ICDACT,ICDC,ICDCOM,ICDCS
+21 NEW ICDCSI,ICDDAT,ICDDT,ICDEFF,ICDF,ICDFMT,ICDI,ICDIA,ICDIEN
+22 NEW ICDIMP,ICDINA,ICDLT,ICDMSG,ICDR,ICDSO,ICDST,ICDSTA,ICDT,Y
INQ2 ; Inquire to ICD codes (recursive)
+1 SET ICDDT=$$EFD^ICDEX
SET ICDEFF=$PIECE(ICDDT,"^",1)
IF ICDEFF'?7N
WRITE !!," Effective Date not specified"
QUIT
+2 WRITE !
SET ICDCS=$$CS^ICDEX(,,ICDEFF)
IF +ICDCS'>0
WRITE !!," File not specified"
QUIT
+3 SET ICDCSI=$$SINFO^ICDEX(+ICDCS)
SET ICDF=$PIECE(ICDCSI,"^",4)
SET (DIC,ICDR)=$$ROOT^ICDEX(ICDF)
SET DIC(0)="AEQMZ"
+4 SET DIC("A")=" Select "_$PIECE($PIECE(ICDCSI,"^",2)," ",1)_" "_$PIECE(ICDCSI,"^",6)_" Code: "
SET ICDFMT=2
+5 WRITE !
DO ^DIC
if $DATA(DTOUT)
WRITE !!," Try again later"
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+6 if +($GET(Y))'>0
WRITE !!," Code not selected"
if +($GET(Y))'>0
QUIT
SET ICDIEN=+($GET(Y))
SET ICDCS=$$CSI^ICDEX(ICDF,+ICDIEN)
+7 SET ICDCSI=$$SINFO^ICDEX(+ICDCS)
if ICDF=80
SET ICDDAT=$$ICDDX^ICDEX(+ICDIEN,ICDEFF,,"I")
+8 if ICDF=80.1
SET ICDDAT=$$ICDOP^ICDEX(+ICDIEN,ICDEFF,,"I")
SET ICDSO=$GET(Y(0,0))
+9 if ICDF="80"
SET ICDST=$PIECE(ICDDAT,"^",4)
if ICDF="80.1"
SET ICDST=$PIECE(ICDDAT,"^",5)
+10 SET ICDLT=$GET(Y(0,2))
KILL ICDA
SET ICDC=$$LD^ICDEX(ICDF,ICDIEN,ICDEFF,.ICDA,64)
IF $PIECE(ICDC,"^",1)="-1"
Begin DoDot:1
+11 NEW ICDCOM,ICDT
SET ICDCOM=""
IF $PIECE(ICDLT,"^",1)="-1"
IF $LENGTH($PIECE(ICDLT,"^",2))
Begin DoDot:2
+12 SET ICDCOM="No description available for "_$$FMTE^XLFDT(ICDEFF)
End DoDot:2
+13 KILL ICDA
SET ICDC=$$LD^ICDEX(ICDF,ICDIEN,9990101,.ICDA,64)
End DoDot:1
+14 SET ICDSTA=$PIECE(ICDDAT,"^",10)
SET ICDINA=$PIECE(ICDDAT,"^",12)
+15 if ICDF="80"
SET ICDACT=$PIECE(ICDDAT,"^",17)
if ICDF="80.1"
SET ICDACT=$PIECE(ICDDAT,"^",13)
+16 SET ICDMSG(1)=$$MSG^ICDEX(ICDEFF,+($GET(ICDCS)))
+17 if $LENGTH(ICDMSG(1))
SET ICDMSG(1)="Descriptive text may be inaccurate, predates Code Set Versioning"
+18 SET ICDIMP=$$IMP^ICDEX(+($GET(ICDCS)))
SET ICDIA=$$IA^ICDEX(ICDF,+ICDIEN)
+19 IF ICDIMP?7N
IF ICDEFF?7N
IF ICDEFF<ICDIMP
Begin DoDot:1
+20 NEW ICDT
SET ICDT=$PIECE($PIECE($GET(ICDCSI),"^",2)," ",1)
+21 SET ICDMSG(1)="Descriptive text may be inaccurate, predates implementation date"
+22 if $LENGTH(ICDT)
SET ICDMSG(1)="Descriptive text may be inaccurate, user input predates "
+23 if $LENGTH(ICDT)
SET ICDMSG(1)=ICDMSG(1)_ICDT_" implementation date of "_$$FMTE^XLFDT(ICDIMP,"5Z")
End DoDot:1
+24 IF ICDIA?7N
IF ICDEFF?7N
IF ICDEFF<ICDIA
Begin DoDot:1
+25 NEW ICDT
SET ICDT=$PIECE($PIECE($GET(ICDCSI),"^",2)," ",1)
+26 SET ICDMSG(1)="Descriptive text may be inaccurate, predates the initial activation date"
+27 if $LENGTH(ICDT)
SET ICDMSG(1)="Descriptive text may be inaccurate, user input predates "
+28 if $LENGTH(ICDT)
SET ICDMSG(1)=ICDMSG(1)_" the code's initial activation date of "
+29 if $LENGTH(ICDT)
SET ICDMSG(1)=ICDMSG(1)_$$FMTE^XLFDT(ICDIA,"5Z")
End DoDot:1
+30 if $LENGTH($GET(ICDMSG(1)))
DO PAR^ICDEX(.ICDMSG,64)
+31 WRITE !!," ",ICDSO,?15,ICDST
SET (ICDC,ICDI)=0
FOR
SET ICDI=$ORDER(ICDA(ICDI))
if +ICDI'>0
QUIT
Begin DoDot:1
+32 if '$LENGTH($GET(ICDA(ICDI)))
QUIT
SET ICDC=ICDC+1
+33 WRITE !
if ICDC=1
WRITE !," Description"
WRITE ?15,$GET(ICDA(ICDI))
End DoDot:1
+34 if $LENGTH($GET(ICDMSG(1)))
WRITE !
FOR ICDI=1:1:3
if $LENGTH($GET(ICDMSG(ICDI)))
WRITE !,?15,$GET(ICDMSG(ICDI))
+35 IF +($GET(ICDSTA))'>0
IF $GET(ICDINA)?7N
Begin DoDot:1
+36 WRITE !!,?15," ** CODE INACTIVE AS OF: ",$$FMTE^XLFDT(ICDINA,"5Z")," **",!
End DoDot:1
+37 IF +ICDSTA>0
IF ICDACT>ICDEFF
Begin DoDot:1
+38 WRITE !!,?15," ** PENDING ACTIVATION ON: ",$$FMTE^XLFDT(ICDACT,"5Z")," **",!
End DoDot:1
+39 GOTO INQ2
+40 QUIT
