- ICDRGAPI ;ALB/JAM - DRG GROUPER APIS ;05/29/12 2:39pm
- ;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103
- ;
- ICDID(FILE,ID,CODE) ; Returns value indicating if identifier exist.
- ;
- ; Input:
- ; FILE File to look-up for identifier (required)
- ; 80 = File #80
- ; 80.1 = File #80.1
- ; ID Diagnosis/Procedure code identifier (required)
- ; CODE DX IEN or PX IEN (required)
- ;
- ; Output: Returns an 1, 0 or -1
- ; 1 if identifier was found
- ; 0 if identifier was not found
- ; -1 error^error message
- ;
- N ICDIDIEN,ICDGBL
- I '+$G(FILE) Q "-1^Invalid File"
- I $G(ID)="" Q "-1^Missing identifier"
- I '+$G(CODE) Q "-1^Invalid IEN"
- ;S GBL=$$ROOT^ICDEX(FILE)
- ;I "^^ICD9(^^ICD0(^"'["^"_GBL_"^" Q "-1^Invalid Global"
- S ICDGBL=$S(FILE=80:"^ICD9(",1:"^ICD0(")
- S ICDIDIEN=$$IDIEN(FILE,ID) I '+ICDIDIEN Q "-1^Invalid identifier"
- I $D(@(ICDGBL_CODE_",73,""B"","_ICDIDIEN_")")) Q 1
- Q 0
- ;
- IDIEN(FILE,ID) ;get IEN for identifier
- I FILE=80 Q $O(^ICDID("B",ID,""))
- E Q $O(^ICDIP("B",ID,""))
- Q
- ;
- ICDIDS(FILE,CODE,ARY) ; Returns an array of identifiers.
- ;
- ; Input:
- ; FILE File to look-up for identifier (required)
- ; 80 = File #80
- ; 80.1 = File #80.1
- ; CODE DX IEN or PX IEN (required)
- ; ARY Array Name passed by reference (required)
- ;
- ; Output: Return S an 1, 0 or -1
- ; 1 if identifier was found
- ; 0 if identifier was not found
- ; -1 error^error message
- ;
- N ICDGBL,ICDX,ICDC,ICDID,ICDGBLT,ICDGBLID
- I '+$G(FILE) Q "-1^Invalid File"
- I '+$G(CODE) Q "-1^Invalid IEN"
- S ICDGBL=$P($$ROOT^ICDEX(FILE),"(",1)
- I "^^ICD9^^ICD0^"'["^"_ICDGBL_"^" Q "-1^Invalid Global"
- S ICDGBLT=$S(FILE=80:"^ICD9",1:"^ICD0"),ICDGBLID=$S(FILE=80:"^ICDID",1:"^ICDIP")
- S ICDC=0,ICDX=0 F S ICDX=$O(@ICDGBLT@(CODE,73,"B",ICDX)) Q:ICDX="" S ARY($P(@ICDGBLID@(ICDX,0),U,1))=1,ICDC=ICDC+1
- Q ICDC
- ;
- CHGIEN(FILE,CODE) ;
- N ICDC
- I FILE=80 S ICDC=$G(^ICD9(CODE,0)) Q:ICDC="" "" Q $O(^ICD9("B",ICDC,""))
- I FILE=80.1 S ICDC=$G(^ICD0(CODE,0)) Q:ICDC="" "" Q $O(^ICD0("B",ICDC,""))
- Q ""
- ;
- ICDIDF(ID,ARY) ; Returns value indicating if identifier(s) exist in an array.
- ;
- ; Input:
- ; ID Diagnosis/Procedure code identifier(s) (required)
- ; ARY Array Name passed by reference (required)
- ;
- ; Output: Returns an 1, 0 or -1
- ; 1 if all identifier(s) were found in array
- ; 0 if all identifiers were not found
- ; -1 error^error message
- ;
- N ICDI,ICDFND,ICDIDV
- I $G(ID)="" Q "-1^Missing identifier"
- I $O(ARY(""))="" Q "-1^Missing array elements"
- S ICDFND=1
- F ICDI=1:1:$L(ID,"^") D Q:'ICDFND
- .S ICDIDV=$P(ID,"^",ICDI) Q:ICDIDV=""
- .I '$D(ARY(ICDIDV)) S ICDFND=0
- Q ICDFND
- ;
- ICDIDC(FILE,ID,ARY,RESULTS) ; Returns value indicating if identifier(s) exist in a cluster.
- ;
- ; Input:
- ; FILE File to look-up for identifier (required)
- ; 82.11 = File #82.11
- ; 82.12 = File #82.12
- ; ID Diagnosis/Procedure code identifier(s) (required)
- ; ARY Array Name passed by reference (required)
- ;
- ; Output:
- ; RESULTS array subscripted by MDC and DRG (ex, RESULTS(MDC,DRG)=""
- ; Returns an 1, 0 or -1
- ; 1 if all identifier(s) were found in array
- ; 0 if all identifiers were not found
- ; -1 error^error message
- ;
- ;
- N ICDGBL,ICDIEN,ICDX,ICDDA,ICDI1,ICDI2,ICDI3,ICDI4,ICDJ,ICDDRGDX,ICDCX,ICDFND,ICDARR,ICDMDC,ICDDRG,ICDDRGDX,ICDSUB
- I '+$G(FILE) Q "-1^Invalid File"
- I $G(ID)="" Q "-1^Missing identifier"
- I $O(ARY(""))="" Q "-1^Missing array elements"
- S ICDGBL=$P($$ROOT^DILFD(FILE),"(",1)
- I "^^ICDIDP(^^ICDIDD(^"'["^"_ICDGBL_"^" Q "-1^Invalid Global"
- ;create temp array ARR subscripted by IEN
- S ICDX=0 F S ICDX=$O(ARY(ICDX)) Q:'ICDX S ICDCX=ARY(ICDX) I ICDCX'="" S ICDARR(ICDCX)=ICDX
- S ICDFND=0
- ;get ID from "B" x-ref
- ;S IEN=$$GET1^DIQ($S(FILE=82.11:82.1,1:82),ID,.01,"I")
- I FILE=82.11 S ICDIEN=$O(^ICDIP("B",ID,""))
- I FILE=82.12 S ICDIEN=$O(^ICDID("B",ID,""))
- ;S IEN=$$FIND1^DIC(82,"","BX",ID) Q "-1^Invalid identifier"
- ;get all the entries for the ID
- ;F S X=$O(@(GBL_CODE_",73,""B"",X)"))
- ;S DA=0 F S DA=$O(@(GBL_"""B"","_IEN_","_DA_")")) Q:'DA D I FND Q
- ;S DA=0 F S DA=$O(@(GBL_"""B"",IEN,DA)")) Q:'DA D I FND Q
- S ICDDA=0 F S ICDDA=$O(@ICDGBL@("B",ICDIEN,ICDDA)) Q:'ICDDA D I ICDFND Q
- .I '$D(@ICDGBL@(ICDDA,0)) Q
- .S ICDI1=0 F S ICDI1=$O(@ICDGBL@(ICDDA,"BL",ICDI1)) Q:'ICDI1 D I ICDFND Q
- ..F ICDJ=1:1:5 S ICDI2=0,ICDSUB=$P("ONE/WITH1/WITH2/WITH3/WITH4/","/",ICDJ) F S ICDI2=$O(@ICDGBL@(ICDDA,"BL",ICDI1,ICDSUB,ICDI2)) Q:'ICDI2 D
- ...S ICDCX=$G(@ICDGBL@(ICDDA,"BL",ICDI1,ICDSUB,ICDI2,0))
- ...S ICDDRGDX(ICDJ,ICDCX)=""
- ..;check if DX/PX codes are in cluster
- ..S ICDFND=$$BLKCHK()
- ..Q:'ICDFND
- ..;get MDC and DRG
- ..S ICDI3=0 F S ICDI3=$O(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3)) Q:'ICDI3 D
- ...S ICDMDC=$G(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3,0))
- ...S ICDI4=0 F S ICDI4=$O(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3,"DRG",ICDI4)) Q:'ICDI4 D
- ....S ICDDRG=$G(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3,"DRG",ICDI4,0))
- ....S RESULTS(ICDMDC,ICDDRG)=""
- Q ICDFND
- ;
- BLKCHK() ;check if DX/PX code is in cluster
- N ICDJ,ICDX1,ICDC,ICDFND
- S (ICDFND,ICDC)=0
- S ICDJ=0 F S ICDJ=$O(ICDDRGDX(ICDJ)) Q:'ICDJ D
- .S ICDC=ICDC+1
- .S ICDX1=0 F S ICDX1=$O(ICDDRGDX(ICDJ,ICDX1)) Q:'ICDX1 I $D(ICDARR(ICDX1)) S ICDFND=ICDFND+1 Q
- S ICDFND=$S('ICDC:0,ICDFND=ICDC:1,1:0)
- Q ICDFND
- ;
- ISOWNCC(IEN,CDT,FMT) ; If DX is Own CC, return the CC value else zero
- ;
- ; Input:
- ;
- ; IEN IEN in 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 (FMT=0)
- ; Complication/Comorbidity^Effective Date (FMT=1)
- ;
- N ICDCCDAT,ICDCCIEN,ICDCCOUT,ICDCCX,ICDCCOWN
- S FMT=+($G(FMT)) S:FMT'=1 FMT=0 S:CDT="" CDT=DT S ICDCCDAT=$O(^ICD9(IEN,69,"B",CDT+.0001),-1) Q:'$L(ICDCCDAT) 0
- S ICDCCIEN=$O(^ICD9(IEN,69,"B",ICDCCDAT,""),-1)
- S ICDCCX=^ICD9(IEN,69,ICDCCIEN,0),ICDCCOWN=$P(ICDCCX,U,3) I 'ICDCCOWN Q 0
- S ICDCCOUT=$P(ICDCCX,U,2) S:FMT>0 ICDCCOUT=ICDCCOUT_"^"_$P(^ICD9(IEN,69,ICDCCIEN,0),U,1)
- Q ICDCCOUT
- ;
- ICDMRG(ARY1,ARY2) ; Merge ARY2 with ARY1 and increment the counter
- ;
- N ICD10I,ICD10CNT
- S ICD10I=""
- F ICD10CNT=0:0 S ICD10I=$O(ARY2(ICD10I)) Q:ICD10I="" D
- . I $D(ARY1(ICD10I)) S ARY1(ICD10I)=ARY1(ICD10I)+1
- . E S ARY1(ICD10I)=1
- Q
- ;
- CLUSTERS ; Load Cluster Identifier Codes into ICD10SD, ICD10OR
- N ICDIEN,ICDID,ICDX,ICD10SDT,ICD10ORT,ICDTMP,ICD10PCT,ICDIDC
- S ICDID=0 F S ICDID=$O(^ICDIDD(ICDID)) Q:'ICDID S ICDIEN=$G(^ICDIDD(ICDID,0)) I ICDIEN D
- . S ICDIDC=$P(^ICDID(ICDIEN,0),U,1)
- . S ICDX=$$ICDIDC^ICDRGAPI(82.12,ICDIDC,.ICDDX,.ICDTMP)
- . I $P(ICDX,U,1)>0 D
- . . S ICD10SD(ICDIDC)=$G(ICD10SD(ICDIDC))+1
- . . D LDMDDRGD ; Load DRG and Check MDC for Diagnosis Clusters
- I $D(ICDPRC) S ICDID=0 F S ICDID=$O(^ICDIDP(ICDID)) Q:'ICDID S ICDIEN=$G(^ICDIDP(ICDID,0)) I ICDIEN D
- . S ICDIDC=$P(^ICDIP(ICDIEN,0),U,1)
- . S ICDX=$$ICDIDC^ICDRGAPI(82.11,ICDIDC,.ICDPRC,.ICD10PCT)
- . I $P(ICDX,U,1)>0 D
- . . S ICD10OR(ICDIDC)=$G(ICD10OR(ICDIDC))+1
- . . D LDMDDRGP ; Load DRG and Check MDC for Procedure Clusters
- Q
- ;
- LDMDDRGD ; Load DRG and Check MDC for Diagnosis Clusters
- N ICDMDCT,ICDDRGT
- S ICDMDCT="" F S ICDMDCT=$O(ICDTMP(ICDMDCT)) Q:'ICDMDCT D
- . S ICDDRGT="" F S ICDDRGT=$O(ICDTMP(ICDMDCT,ICDDRGT)) Q:'ICDDRGT D
- . . S ICDSDRG(ICDDRGT)=""
- Q
- ;
- LDMDDRGP ; Load DRG and Check MDC for Procedure Clusters
- N ICDMDCT,ICDDRGT
- S ICDMDCT="" F S ICDMDCT=$O(ICD10PCT(ICDMDCT)) Q:'ICDMDCT D
- . I (ICDMDC=ICDMDCT)!(($D(ICDMDC(12))!($D(ICDMDC(13)))>0)&$D(ICDMDC(ICDMDCT))) S ICDONR=ICDONR+1
- . S ICDDRGT="" F S ICDDRGT=$O(ICD10PCT(ICDMDCT,ICDDRGT)) Q:'ICDDRGT D
- . . S ICDODRG(ICDDRGT)=ICDDRGT
- Q
- ;
- ICDRGCC(DRG,CDT) ;Get CC/MCC flag from DRG (Temporary hard-code of ^ICD pending API)
- N ICDCC,ICDIEN,ICDDA,ICDAIEN
- S ICDCC=-1,ICDIEN=$O(^ICD("B","DRG"_DRG,"")) I ICDIEN D
- . S ICDDA=$O(^ICD(ICDIEN,2,"B",(CDT_".1")),-1) I ICDDA D
- . . S ICDAIEN=$O(^ICD(ICDIEN,2,"B",ICDDA,"")) I ICDAIEN D
- . . . S ICDCC=$P(^ICD(ICDIEN,2,ICDAIEN,0),U,4)
- Q ICDCC
- ;
- ISACCEX(IEN1,IEN2) ; Is Code 2 an Excluded code of Code 1 so MCC/CC=0
- ;
- ; Input:
- ;
- ; IEN1 This is the internal entry number (IEN) of a
- ; code in file 80 used as a Secondary diagnosis
- ; with IEN2 which is the Principal diagnosis
- ;
- ; Output:
- ;
- ; $$ISACCEX Boolean value
- ;
- ; 1 Yes - IEN2 is an excluded PDX of IEN1 for MCC/CC
- ; 0 No - IEN2 is NOT an excluded PDX of IEN1 for MCC/CC
- ;
- N ICD1,ICD2,ICDPDX,ICDXIEN
- S ICD1=$G(IEN1),ICD2=$G(IEN2)
- S ICDPDX=$$GET1^DIQ(80,ICD1,1.11,1) I ICDPDX="" Q 0
- S ICDXIEN=$O(^ICDCCEX("B",ICDPDX,"")) I ICDXIEN="" Q 0
- Q $S($D(^ICDCCEX(ICDXIEN,1,"B",ICD2)):1,1:0)
- ;
- ICDXEXPT(DXIEN,LIST) ;
- ; Checks if the DX code indicated by the DXIEN matches any code in LIST
- ;
- ; Input:
- ; DXIEN is IEN in file 80 Ex: ICDDX(1) in ICDDRG
- ; LIST is a list of DX codes in this format ^code^code^code^
- ;
- ; Output:
- ; 1 The DX Code indicated by DXIEN is present in LIST
- ; 0 The DX Code indicated by DXIEN is NOT present in LIST
- ;
- N ICDCODE
- S ICDCODE=U_$$GET1^DIQ(80,DXIEN,.01,"E")_U
- Q $S(LIST[ICDCODE:1,1:0)
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDRGAPI 9388 printed Feb 18, 2025@23:17:23 Page 2
- ICDRGAPI ;ALB/JAM - DRG GROUPER APIS ;05/29/12 2:39pm
- +1 ;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103
- +2 ;
- ICDID(FILE,ID,CODE) ; Returns value indicating if identifier exist.
- +1 ;
- +2 ; Input:
- +3 ; FILE File to look-up for identifier (required)
- +4 ; 80 = File #80
- +5 ; 80.1 = File #80.1
- +6 ; ID Diagnosis/Procedure code identifier (required)
- +7 ; CODE DX IEN or PX IEN (required)
- +8 ;
- +9 ; Output: Returns an 1, 0 or -1
- +10 ; 1 if identifier was found
- +11 ; 0 if identifier was not found
- +12 ; -1 error^error message
- +13 ;
- +14 NEW ICDIDIEN,ICDGBL
- +15 IF '+$GET(FILE)
- QUIT "-1^Invalid File"
- +16 IF $GET(ID)=""
- QUIT "-1^Missing identifier"
- +17 IF '+$GET(CODE)
- QUIT "-1^Invalid IEN"
- +18 ;S GBL=$$ROOT^ICDEX(FILE)
- +19 ;I "^^ICD9(^^ICD0(^"'["^"_GBL_"^" Q "-1^Invalid Global"
- +20 SET ICDGBL=$SELECT(FILE=80:"^ICD9(",1:"^ICD0(")
- +21 SET ICDIDIEN=$$IDIEN(FILE,ID)
- IF '+ICDIDIEN
- QUIT "-1^Invalid identifier"
- +22 IF $DATA(@(ICDGBL_CODE_",73,""B"","_ICDIDIEN_")"))
- QUIT 1
- +23 QUIT 0
- +24 ;
- IDIEN(FILE,ID) ;get IEN for identifier
- +1 IF FILE=80
- QUIT $ORDER(^ICDID("B",ID,""))
- +2 IF '$TEST
- QUIT $ORDER(^ICDIP("B",ID,""))
- +3 QUIT
- +4 ;
- ICDIDS(FILE,CODE,ARY) ; Returns an array of identifiers.
- +1 ;
- +2 ; Input:
- +3 ; FILE File to look-up for identifier (required)
- +4 ; 80 = File #80
- +5 ; 80.1 = File #80.1
- +6 ; CODE DX IEN or PX IEN (required)
- +7 ; ARY Array Name passed by reference (required)
- +8 ;
- +9 ; Output: Return S an 1, 0 or -1
- +10 ; 1 if identifier was found
- +11 ; 0 if identifier was not found
- +12 ; -1 error^error message
- +13 ;
- +14 NEW ICDGBL,ICDX,ICDC,ICDID,ICDGBLT,ICDGBLID
- +15 IF '+$GET(FILE)
- QUIT "-1^Invalid File"
- +16 IF '+$GET(CODE)
- QUIT "-1^Invalid IEN"
- +17 SET ICDGBL=$PIECE($$ROOT^ICDEX(FILE),"(",1)
- +18 IF "^^ICD9^^ICD0^"'["^"_ICDGBL_"^"
- QUIT "-1^Invalid Global"
- +19 SET ICDGBLT=$SELECT(FILE=80:"^ICD9",1:"^ICD0")
- SET ICDGBLID=$SELECT(FILE=80:"^ICDID",1:"^ICDIP")
- +20 SET ICDC=0
- SET ICDX=0
- FOR
- SET ICDX=$ORDER(@ICDGBLT@(CODE,73,"B",ICDX))
- if ICDX=""
- QUIT
- SET ARY($PIECE(@ICDGBLID@(ICDX,0),U,1))=1
- SET ICDC=ICDC+1
- +21 QUIT ICDC
- +22 ;
- CHGIEN(FILE,CODE) ;
- +1 NEW ICDC
- +2 IF FILE=80
- SET ICDC=$GET(^ICD9(CODE,0))
- if ICDC=""
- QUIT ""
- QUIT $ORDER(^ICD9("B",ICDC,""))
- +3 IF FILE=80.1
- SET ICDC=$GET(^ICD0(CODE,0))
- if ICDC=""
- QUIT ""
- QUIT $ORDER(^ICD0("B",ICDC,""))
- +4 QUIT ""
- +5 ;
- ICDIDF(ID,ARY) ; Returns value indicating if identifier(s) exist in an array.
- +1 ;
- +2 ; Input:
- +3 ; ID Diagnosis/Procedure code identifier(s) (required)
- +4 ; ARY Array Name passed by reference (required)
- +5 ;
- +6 ; Output: Returns an 1, 0 or -1
- +7 ; 1 if all identifier(s) were found in array
- +8 ; 0 if all identifiers were not found
- +9 ; -1 error^error message
- +10 ;
- +11 NEW ICDI,ICDFND,ICDIDV
- +12 IF $GET(ID)=""
- QUIT "-1^Missing identifier"
- +13 IF $ORDER(ARY(""))=""
- QUIT "-1^Missing array elements"
- +14 SET ICDFND=1
- +15 FOR ICDI=1:1:$LENGTH(ID,"^")
- Begin DoDot:1
- +16 SET ICDIDV=$PIECE(ID,"^",ICDI)
- if ICDIDV=""
- QUIT
- +17 IF '$DATA(ARY(ICDIDV))
- SET ICDFND=0
- End DoDot:1
- if 'ICDFND
- QUIT
- +18 QUIT ICDFND
- +19 ;
- ICDIDC(FILE,ID,ARY,RESULTS) ; Returns value indicating if identifier(s) exist in a cluster.
- +1 ;
- +2 ; Input:
- +3 ; FILE File to look-up for identifier (required)
- +4 ; 82.11 = File #82.11
- +5 ; 82.12 = File #82.12
- +6 ; ID Diagnosis/Procedure code identifier(s) (required)
- +7 ; ARY Array Name passed by reference (required)
- +8 ;
- +9 ; Output:
- +10 ; RESULTS array subscripted by MDC and DRG (ex, RESULTS(MDC,DRG)=""
- +11 ; Returns an 1, 0 or -1
- +12 ; 1 if all identifier(s) were found in array
- +13 ; 0 if all identifiers were not found
- +14 ; -1 error^error message
- +15 ;
- +16 ;
- +17 NEW ICDGBL,ICDIEN,ICDX,ICDDA,ICDI1,ICDI2,ICDI3,ICDI4,ICDJ,ICDDRGDX,ICDCX,ICDFND,ICDARR,ICDMDC,ICDDRG,ICDDRGDX,ICDSUB
- +18 IF '+$GET(FILE)
- QUIT "-1^Invalid File"
- +19 IF $GET(ID)=""
- QUIT "-1^Missing identifier"
- +20 IF $ORDER(ARY(""))=""
- QUIT "-1^Missing array elements"
- +21 SET ICDGBL=$PIECE($$ROOT^DILFD(FILE),"(",1)
- +22 IF "^^ICDIDP(^^ICDIDD(^"'["^"_ICDGBL_"^"
- QUIT "-1^Invalid Global"
- +23 ;create temp array ARR subscripted by IEN
- +24 SET ICDX=0
- FOR
- SET ICDX=$ORDER(ARY(ICDX))
- if 'ICDX
- QUIT
- SET ICDCX=ARY(ICDX)
- IF ICDCX'=""
- SET ICDARR(ICDCX)=ICDX
- +25 SET ICDFND=0
- +26 ;get ID from "B" x-ref
- +27 ;S IEN=$$GET1^DIQ($S(FILE=82.11:82.1,1:82),ID,.01,"I")
- +28 IF FILE=82.11
- SET ICDIEN=$ORDER(^ICDIP("B",ID,""))
- +29 IF FILE=82.12
- SET ICDIEN=$ORDER(^ICDID("B",ID,""))
- +30 ;S IEN=$$FIND1^DIC(82,"","BX",ID) Q "-1^Invalid identifier"
- +31 ;get all the entries for the ID
- +32 ;F S X=$O(@(GBL_CODE_",73,""B"",X)"))
- +33 ;S DA=0 F S DA=$O(@(GBL_"""B"","_IEN_","_DA_")")) Q:'DA D I FND Q
- +34 ;S DA=0 F S DA=$O(@(GBL_"""B"",IEN,DA)")) Q:'DA D I FND Q
- +35 SET ICDDA=0
- FOR
- SET ICDDA=$ORDER(@ICDGBL@("B",ICDIEN,ICDDA))
- if 'ICDDA
- QUIT
- Begin DoDot:1
- +36 IF '$DATA(@ICDGBL@(ICDDA,0))
- QUIT
- +37 SET ICDI1=0
- FOR
- SET ICDI1=$ORDER(@ICDGBL@(ICDDA,"BL",ICDI1))
- if 'ICDI1
- QUIT
- Begin DoDot:2
- +38 FOR ICDJ=1:1:5
- SET ICDI2=0
- SET ICDSUB=$PIECE("ONE/WITH1/WITH2/WITH3/WITH4/","/",ICDJ)
- FOR
- SET ICDI2=$ORDER(@ICDGBL@(ICDDA,"BL",ICDI1,ICDSUB,ICDI2))
- if 'ICDI2
- QUIT
- Begin DoDot:3
- +39 SET ICDCX=$GET(@ICDGBL@(ICDDA,"BL",ICDI1,ICDSUB,ICDI2,0))
- +40 SET ICDDRGDX(ICDJ,ICDCX)=""
- End DoDot:3
- +41 ;check if DX/PX codes are in cluster
- +42 SET ICDFND=$$BLKCHK()
- +43 if 'ICDFND
- QUIT
- +44 ;get MDC and DRG
- +45 SET ICDI3=0
- FOR
- SET ICDI3=$ORDER(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3))
- if 'ICDI3
- QUIT
- Begin DoDot:3
- +46 SET ICDMDC=$GET(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3,0))
- +47 SET ICDI4=0
- FOR
- SET ICDI4=$ORDER(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3,"DRG",ICDI4))
- if 'ICDI4
- QUIT
- Begin DoDot:4
- +48 SET ICDDRG=$GET(@ICDGBL@(ICDDA,"BL",ICDI1,"MDC",ICDI3,"DRG",ICDI4,0))
- +49 SET RESULTS(ICDMDC,ICDDRG)=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- IF ICDFND
- QUIT
- End DoDot:1
- IF ICDFND
- QUIT
- +50 QUIT ICDFND
- +51 ;
- BLKCHK() ;check if DX/PX code is in cluster
- +1 NEW ICDJ,ICDX1,ICDC,ICDFND
- +2 SET (ICDFND,ICDC)=0
- +3 SET ICDJ=0
- FOR
- SET ICDJ=$ORDER(ICDDRGDX(ICDJ))
- if 'ICDJ
- QUIT
- Begin DoDot:1
- +4 SET ICDC=ICDC+1
- +5 SET ICDX1=0
- FOR
- SET ICDX1=$ORDER(ICDDRGDX(ICDJ,ICDX1))
- if 'ICDX1
- QUIT
- IF $DATA(ICDARR(ICDX1))
- SET ICDFND=ICDFND+1
- QUIT
- End DoDot:1
- +6 SET ICDFND=$SELECT('ICDC:0,ICDFND=ICDC:1,1:0)
- +7 QUIT ICDFND
- +8 ;
- ISOWNCC(IEN,CDT,FMT) ; If DX is Own CC, return the CC value else zero
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; IEN IEN in 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 ;
- +10 ; Output:
- +11 ;
- +12 ; $$ISOWNCC Complication/Comorbidity (FMT=0)
- +13 ; Complication/Comorbidity^Effective Date (FMT=1)
- +14 ;
- +15 NEW ICDCCDAT,ICDCCIEN,ICDCCOUT,ICDCCX,ICDCCOWN
- +16 SET FMT=+($GET(FMT))
- if FMT'=1
- SET FMT=0
- if CDT=""
- SET CDT=DT
- SET ICDCCDAT=$ORDER(^ICD9(IEN,69,"B",CDT+.0001),-1)
- if '$LENGTH(ICDCCDAT)
- QUIT 0
- +17 SET ICDCCIEN=$ORDER(^ICD9(IEN,69,"B",ICDCCDAT,""),-1)
- +18 SET ICDCCX=^ICD9(IEN,69,ICDCCIEN,0)
- SET ICDCCOWN=$PIECE(ICDCCX,U,3)
- IF 'ICDCCOWN
- QUIT 0
- +19 SET ICDCCOUT=$PIECE(ICDCCX,U,2)
- if FMT>0
- SET ICDCCOUT=ICDCCOUT_"^"_$PIECE(^ICD9(IEN,69,ICDCCIEN,0),U,1)
- +20 QUIT ICDCCOUT
- +21 ;
- ICDMRG(ARY1,ARY2) ; Merge ARY2 with ARY1 and increment the counter
- +1 ;
- +2 NEW ICD10I,ICD10CNT
- +3 SET ICD10I=""
- +4 FOR ICD10CNT=0:0
- SET ICD10I=$ORDER(ARY2(ICD10I))
- if ICD10I=""
- QUIT
- Begin DoDot:1
- +5 IF $DATA(ARY1(ICD10I))
- SET ARY1(ICD10I)=ARY1(ICD10I)+1
- +6 IF '$TEST
- SET ARY1(ICD10I)=1
- End DoDot:1
- +7 QUIT
- +8 ;
- CLUSTERS ; Load Cluster Identifier Codes into ICD10SD, ICD10OR
- +1 NEW ICDIEN,ICDID,ICDX,ICD10SDT,ICD10ORT,ICDTMP,ICD10PCT,ICDIDC
- +2 SET ICDID=0
- FOR
- SET ICDID=$ORDER(^ICDIDD(ICDID))
- if 'ICDID
- QUIT
- SET ICDIEN=$GET(^ICDIDD(ICDID,0))
- IF ICDIEN
- Begin DoDot:1
- +3 SET ICDIDC=$PIECE(^ICDID(ICDIEN,0),U,1)
- +4 SET ICDX=$$ICDIDC^ICDRGAPI(82.12,ICDIDC,.ICDDX,.ICDTMP)
- +5 IF $PIECE(ICDX,U,1)>0
- Begin DoDot:2
- +6 SET ICD10SD(ICDIDC)=$GET(ICD10SD(ICDIDC))+1
- +7 ; Load DRG and Check MDC for Diagnosis Clusters
- DO LDMDDRGD
- End DoDot:2
- End DoDot:1
- +8 IF $DATA(ICDPRC)
- SET ICDID=0
- FOR
- SET ICDID=$ORDER(^ICDIDP(ICDID))
- if 'ICDID
- QUIT
- SET ICDIEN=$GET(^ICDIDP(ICDID,0))
- IF ICDIEN
- Begin DoDot:1
- +9 SET ICDIDC=$PIECE(^ICDIP(ICDIEN,0),U,1)
- +10 SET ICDX=$$ICDIDC^ICDRGAPI(82.11,ICDIDC,.ICDPRC,.ICD10PCT)
- +11 IF $PIECE(ICDX,U,1)>0
- Begin DoDot:2
- +12 SET ICD10OR(ICDIDC)=$GET(ICD10OR(ICDIDC))+1
- +13 ; Load DRG and Check MDC for Procedure Clusters
- DO LDMDDRGP
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- LDMDDRGD ; Load DRG and Check MDC for Diagnosis Clusters
- +1 NEW ICDMDCT,ICDDRGT
- +2 SET ICDMDCT=""
- FOR
- SET ICDMDCT=$ORDER(ICDTMP(ICDMDCT))
- if 'ICDMDCT
- QUIT
- Begin DoDot:1
- +3 SET ICDDRGT=""
- FOR
- SET ICDDRGT=$ORDER(ICDTMP(ICDMDCT,ICDDRGT))
- if 'ICDDRGT
- QUIT
- Begin DoDot:2
- +4 SET ICDSDRG(ICDDRGT)=""
- End DoDot:2
- End DoDot:1
- +5 QUIT
- +6 ;
- LDMDDRGP ; Load DRG and Check MDC for Procedure Clusters
- +1 NEW ICDMDCT,ICDDRGT
- +2 SET ICDMDCT=""
- FOR
- SET ICDMDCT=$ORDER(ICD10PCT(ICDMDCT))
- if 'ICDMDCT
- QUIT
- Begin DoDot:1
- +3 IF (ICDMDC=ICDMDCT)!(($DATA(ICDMDC(12))!($DATA(ICDMDC(13)))>0)&$DATA(ICDMDC(ICDMDCT)))
- SET ICDONR=ICDONR+1
- +4 SET ICDDRGT=""
- FOR
- SET ICDDRGT=$ORDER(ICD10PCT(ICDMDCT,ICDDRGT))
- if 'ICDDRGT
- QUIT
- Begin DoDot:2
- +5 SET ICDODRG(ICDDRGT)=ICDDRGT
- End DoDot:2
- End DoDot:1
- +6 QUIT
- +7 ;
- ICDRGCC(DRG,CDT) ;Get CC/MCC flag from DRG (Temporary hard-code of ^ICD pending API)
- +1 NEW ICDCC,ICDIEN,ICDDA,ICDAIEN
- +2 SET ICDCC=-1
- SET ICDIEN=$ORDER(^ICD("B","DRG"_DRG,""))
- IF ICDIEN
- Begin DoDot:1
- +3 SET ICDDA=$ORDER(^ICD(ICDIEN,2,"B",(CDT_".1")),-1)
- IF ICDDA
- Begin DoDot:2
- +4 SET ICDAIEN=$ORDER(^ICD(ICDIEN,2,"B",ICDDA,""))
- IF ICDAIEN
- Begin DoDot:3
- +5 SET ICDCC=$PIECE(^ICD(ICDIEN,2,ICDAIEN,0),U,4)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +6 QUIT ICDCC
- +7 ;
- ISACCEX(IEN1,IEN2) ; Is Code 2 an Excluded code of Code 1 so MCC/CC=0
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; IEN1 This is the internal entry number (IEN) of a
- +5 ; code in file 80 used as a Secondary diagnosis
- +6 ; with IEN2 which is the Principal diagnosis
- +7 ;
- +8 ; Output:
- +9 ;
- +10 ; $$ISACCEX Boolean value
- +11 ;
- +12 ; 1 Yes - IEN2 is an excluded PDX of IEN1 for MCC/CC
- +13 ; 0 No - IEN2 is NOT an excluded PDX of IEN1 for MCC/CC
- +14 ;
- +15 NEW ICD1,ICD2,ICDPDX,ICDXIEN
- +16 SET ICD1=$GET(IEN1)
- SET ICD2=$GET(IEN2)
- +17 SET ICDPDX=$$GET1^DIQ(80,ICD1,1.11,1)
- IF ICDPDX=""
- QUIT 0
- +18 SET ICDXIEN=$ORDER(^ICDCCEX("B",ICDPDX,""))
- IF ICDXIEN=""
- QUIT 0
- +19 QUIT $SELECT($DATA(^ICDCCEX(ICDXIEN,1,"B",ICD2)):1,1:0)
- +20 ;
- ICDXEXPT(DXIEN,LIST) ;
- +1 ; Checks if the DX code indicated by the DXIEN matches any code in LIST
- +2 ;
- +3 ; Input:
- +4 ; DXIEN is IEN in file 80 Ex: ICDDX(1) in ICDDRG
- +5 ; LIST is a list of DX codes in this format ^code^code^code^
- +6 ;
- +7 ; Output:
- +8 ; 1 The DX Code indicated by DXIEN is present in LIST
- +9 ; 0 The DX Code indicated by DXIEN is NOT present in LIST
- +10 ;
- +11 NEW ICDCODE
- +12 SET ICDCODE=U_$$GET1^DIQ(80,DXIEN,.01,"E")_U
- +13 QUIT $SELECT(LIST[ICDCODE:1,1:0)
- +14 ;