Changeset 636 for FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 49 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
DRG_GROUPER-ICD--ICPT/ICD0IDX.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICD187PT.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICD18PR.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICD18PT.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICD9IDX.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDAPIU.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDCOD.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDCODE.m (modified) (11 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG.m (modified) (7 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG0.m (modified) (5 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG1.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG10.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG11.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG12.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG13.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG14.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDDRG17.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG2.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG3.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG5.m (modified) (3 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG6.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG7.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG8.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRG9.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDDRGM.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDDRGX.m (modified) (4 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDGTDRG.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDHLPO.m (modified) (2 diffs)
-
DRG_GROUPER-ICD--ICPT/ICDID.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDREF.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDSUPT.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB1.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB1A.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB1B.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB2.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB2A.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB2B.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB3.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB3A.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB4.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB4A.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB4B.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB5.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB5A.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB5B.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB6.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB61.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB6A.m (modified) (1 diff)
-
DRG_GROUPER-ICD--ICPT/ICDTLB6B.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD0IDX.m
r628 r636 1 1 ICD0IDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003 2 ;;18.0;DRG Grouper;**6**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**6**;Oct 20, 2000;Build 1 3 3 ; 4 4 ; ICDCOD ICD Code from Global -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD187PT.m
r628 r636 1 1 ICD187PT ; ALB/ADL - GROUPER DRIVER ; 04/11/03 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1 3 3 ;;**routine to build the new DRG global levels required for the CSV project 4 4 ;;**taken from routine created by DEK to add new "66" levels to ICD0 and ICD9 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD18PR.m
r628 r636 1 1 ICD18PR ;ALB/ESD - DRG GROUPER 16 PRE-INSTALL ; 10/23/00 11:56am 2 ;;18.0;DRG Grouper;;Oct 20, 2000 2 ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1 3 3 ; 4 4 ; This routine kills the ICD9 and ICD0 globals -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD18PT.m
r628 r636 1 1 ICD18PT ;ALB/ESD - DRG V16 POST-INSTALL ; 10/23/00 11:57am 2 ;;18.0;DRG Grouper;;Oct 20, 2000 2 ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1 3 3 ; 4 4 ; -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD9IDX.m
r628 r636 1 1 ICD9IDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003 2 ;;18.0;DRG Grouper;**6**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**6**;Oct 20, 2000;Build 1 3 3 ; 4 4 ; ICDCOD ICD Code from Global -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDAPIU.m
r628 r636 1 1 ICDAPIU ;DLS/DEK/KER - ICD UTILITIES FOR APIS ; 04/18/2004 2 ;;18.0;DRG Grouper;**6,11,12,15**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**6,11,12,15**;Oct 20, 2000;Build 1 3 3 ; 4 4 ; External References -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDCOD.m
r628 r636 1 1 ICDCOD ;ALB/ABR/ADL - INQUIRE TO ICD CODES ; 10/23/00 11:36am 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1 3 3 ;;ADL;Update for CSV project - 03/20/03 4 4 ; -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDCODE.m
r628 r636 1 ICDCODE ;DLS/DEK/KER /FJF - ICD CODE APIS ; 09/20/078:54am2 ;;18.0;DRG Grouper;**6,12,14 ,29**;Oct 20, 2000;Build 181 ICDCODE ;DLS/DEK/KER - ICD CODE APIS ; 10/20/04 8:54am 2 ;;18.0;DRG Grouper;**6,12,14**;Oct 20, 2000;Build 1 3 3 ; 4 4 ; External References … … 6 6 ; 7 7 ICDDX(CODE,CDT,DFN,SRC) ; Return ICD Dx Code Info 8 ;Input: 9 ; CODE Code/IEN (required) 10 ; CDT Date (default = TODAY) 11 ; DFN Not in use 12 ; SRC Source 13 ; 0 = exclude local codes 14 ; 1 = include local codes 15 ; 16 ;Output: 17 ; Returns an 19 piece string delimited by ^ 18 ; 1 IEN of code in ^ICD9( 19 ; 2 ICD-9 Dx Code (#.01) 20 ; 3 Id (#2) 21 ; 4 Versioned Dx (67 multiple) 22 ; 5 Unacceptable as Principal Dx (#101) 23 ; 6 Major Dx Cat (#5) 24 ; 7 MDC13 (5.5) 25 ; 8 Compl/Comorb (#70) 26 ; 9 ICD Expanded (#8) 1:Yes 0:No 27 ; 10 Status (66 multiple) 28 ; 11 Sex (#9.5) 29 ; 12 Inactive Date (66 multiple) 30 ; 13 MDC24 (#5.7) 31 ; 14 MDC25 (#5.9) 32 ; 15 Age Low (#14) 33 ; 16 Age High (#15) 34 ; 17 Activation Date (.01 of 66 multiple) 35 ; 18 Message 36 ; 19 Versioned Complication/Comorbidity (#103) 37 ; 38 ; or 39 ; 40 ; -1^Error Description 8 ;Input: CODE Code/IEN (required) 9 ; CDT Date (default = TODAY) 10 ; DFN Not in use 11 ; SRC Source 12 ; 0 = exclude local codes 13 ; 1 = include local codes 14 ; 15 ;Output: Returns an 18 piece string delimited by ^ 16 ; 1 IEN of code in ^ICD9( 17 ; 2 ICD-9 Dx Code (#.01) 18 ; 3 Id (#2) 19 ; 4 Versioned Dx (67 multiple) 20 ; 5 Unacceptable as Principal Dx (#101) 21 ; 6 Major Dx Cat (#5) 22 ; 7 MDC13 (5.5) 23 ; 8 Compl/Comorb (#70) 24 ; 9 ICD Expanded (#8) 1:Yes 0:No 25 ; 10 Status (66 multiple) 26 ; 11 Sex (#9.5) 27 ; 12 Inactive Date (66 multiple) 28 ; 13 MDC24 (#5.7) 29 ; 14 MDC25 (#5.9) 30 ; 15 Age Low (#14) 31 ; 16 Age High (#15) 32 ; 17 Activation Date (.01 of 66 multiple) 33 ; 18 Message 34 ; 35 ; or 36 ; 37 ; -1^Error Description 41 38 ; 42 39 N DATA,EFF,INV,MDC,DRGFY … … 45 42 I CODE<1 Q INV 46 43 I '$D(^ICD9(CODE)) Q INV 47 I '$G(SRC),$P(^ICD9(CODE,0), U,8) Q "-1^VA LOCAL CODE SELECTED"44 I '$G(SRC),$P(^ICD9(CODE,0),"^",8) Q "-1^VA LOCAL CODE SELECTED" 48 45 S DATA=$G(^ICD9(CODE,0)) I '$L(DATA) Q "-1^NO DATA" 49 46 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT)) 50 47 S EFF=$$EFF^ICDSUPT(80,CODE,CDT) 51 S $P(DATA,U,6)=$$VMDC^ICDREF(CODE) 52 S $P(DATA,U,9)=$S(EFF<1:0,1:$P(EFF,U)) 53 S $P(DATA,U,11)=$P(EFF,U,2),$P(DATA,U,16)=$P(EFF,U,3) 54 S $P(DATA,U,3)=$$VSTD(CODE,CDT) 55 S $P(DATA,U,17)=$$MSG^ICDAPIU(CDT) 56 S $P(DATA,U,18)=$S($$COMCOM(CODE,CDT)'=-1:$$COMCOM(CODE,CDT),1:"") 57 Q CODE_U_DATA 58 ; 48 S $P(DATA,"^",6)=$$VMDC^ICDREF(CODE) 49 S $P(DATA,"^",9)=$S(EFF<1:0,1:$P(EFF,"^")) 50 S $P(DATA,"^",11)=$P(EFF,"^",2),$P(DATA,"^",16)=$P(EFF,"^",3) 51 S $P(DATA,"^",3)=$$VSTD(CODE,CDT) 52 Q CODE_"^"_DATA_"^"_$$MSG^ICDAPIU(CDT) 53 ; 59 54 ICDOP(CODE,CDT,DFN,SRC) ; Return ICD Operation/Procedure Code Info 60 ;Input: 61 ; CODE ICD code or IEN format, (required) 62 ; CDT Date (default = TODAY) 63 ; DFN Not in use 64 ; SRC Source 65 ; 0 = exclude local codes 66 ; 1 = include local codes 67 ; 68 ;Output: 69 ; Returns an 14 piece string delimited by ^ 70 ; 1 IEN of code in ^ICD9( 71 ; 2 ICD-9 code (#.01) 72 ; 3 Id (#2) 73 ; 4 MDC24 (#5) 74 ; 5 Versioned Oper/Proc (67 multiple) 75 ; 6 <null> 76 ; 7 <null> 77 ; 8 <null> 78 ; 9 ICD Expanded (#8) 1:Yes 0:No 79 ; 10 Status (66 multiple) 80 ; 11 Use with Sex (#9.5) 81 ; 12 Inactive Date (66 multiple) 82 ; 13 Activation Date (66 multiple) 83 ; 14 Message 84 ; 85 ; or 86 ; 87 ; -1^Error Description 55 ; Input: CODE ICD code or IEN format, (required) 56 ; CDT Date (default = TODAY) 57 ; DFN Not in use 58 ; SRC Source 59 ; 0 = exclude local codes 60 ; 1 = include local codes 61 ; 62 ; Output: Returns an 14 piece string delimited by ^ 63 ; 1 IEN of code in ^ICD9( 64 ; 2 ICD-9 code (#.01) 65 ; 3 Id (#2) 66 ; 4 MDC24 (#5) 67 ; 5 Versioned Oper/Proc (67 multiple) 68 ; 6 <null> 69 ; 7 <null> 70 ; 8 <null> 71 ; 9 ICD Expanded (#8) 1:Yes 0:No 72 ; 10 Status (66 multiple) 73 ; 11 Use with Sex (#9.5) 74 ; 12 Inactive Date (66 multiple) 75 ; 13 Activation Date (66 multiple) 76 ; 14 Message 77 ; 78 ; -or- 79 ; 80 ; -1^Error Description 88 81 ; 89 82 N DATA,EFF,STR,INV … … 92 85 I CODE<1 Q INV 93 86 I '$D(^ICD0(CODE)) Q INV 94 I '$G(SRC),$P(^ICD0(CODE,0), U,8) Q "-1^VA LOCAL CODE SELECTED"87 I '$G(SRC),$P(^ICD0(CODE,0),"^",8) Q "-1^VA LOCAL CODE SELECTED" 95 88 S DATA=$G(^ICD0(CODE,0)) I '$L(DATA) Q "-1^NO DATA" 96 89 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT)) 97 90 S EFF=$$EFF^ICDSUPT(80.1,CODE,CDT) 98 S $P(DATA, U,9)=$S(EFF<1:0,1:$P(EFF,U))99 S $P(DATA, U,11,12)=$P(EFF,U,2,3)100 S $P(DATA, U,4)=$$VSTP(CODE,CDT)101 Q CODE_ U_DATA_U_$$MSG^ICDAPIU(CDT)91 S $P(DATA,"^",9)=$S(EFF<1:0,1:$P(EFF,"^")) 92 S $P(DATA,"^",11,12)=$P(EFF,"^",2,3) 93 S $P(DATA,"^",4)=$$VSTP(CODE,CDT) 94 Q CODE_"^"_DATA_"^"_$$MSG^ICDAPIU(CDT) 102 95 ; 103 96 ICDD(CODE,OUTARR,CDT) ; returns ICD description in array 104 ;Input: 105 ; CODE ICD Code or IEN (required) 106 ; ARY Array Name for description 107 ; e.g. "ABC" or "ABC("TEST")" 108 ; Default = ^TMP("ICDD",$J) 109 ; CDT Date (default = TODAY) 110 ; 111 ;Output: 112 ; # Number of lines in array 113 ; 114 ; @ARY(1:n) - Versioned Description (68 multiple) 115 ; @ARY(n+1) - blank 116 ; @ARY(n+1) - message: CODE TEXT MAY BE INACCURATE 117 ; 118 ; or 119 ; 120 ; -1^Error Description 121 ; 97 ; Input: CODE ICD Code or IEN (required) 98 ; ARY Array Name for description 99 ; e.g. "ABC" or "ABC("TEST")" 100 ; Default = ^TMP("ICDD",$J) 101 ; CDT Date (default = TODAY) 102 ; 103 ; Output: # Number of lines in array 104 ; 105 ; @ARY(1:n) - Versioned Description (68 multiple) 106 ; @ARY(n+1) - blank 107 ; @ARY(n+1) - message: CODE TEXT MAY BE INACCURATE 108 ; 109 ; or 110 ; 111 ; -1^Error Description 112 ; 122 113 ; ** NOTE - USER MUST INITIALIZE ^TMP("ICDD",$J), IF USED ** 123 114 ; … … 137 128 I OUTARR="^TMP(""ICDD"",$J," K ^TMP("ICDD",$J) 138 129 S I=0,N=0,CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT)) 130 ;S N=N+1,ARR=OUTARR_N_")",@ARR=$G(@(GLOB_CODE_",1)")) 139 131 S N=N+1,ARR=OUTARR_N_")",@ARR=$$VLT(CODE,CDT,GLOB) 140 132 S N=N+1,ARR=OUTARR_N_")",@ARR=" " … … 143 135 ; 144 136 CODEN(CODE,FILE) ; return ien of ICD code 145 ; Input:146 ; CODE - ICD code (required)147 ; FILE - File Number to search for code148 ; 80 = ICD Dx file149 ; 80.1 = ICD Oper/Procfile150 ; 151 ; Output:152 ; ien~global root137 ; 138 ; Input: 139 ; CODE - ICD code (required) 140 ; FILE - File Number to search for code 141 ; 80 = ICD Dx file 142 ; 80.1 = ICD Oper/Proc file 143 ; 144 ; Output: ien~global root 153 145 ; where global root is: 154 ; "^ICD9(" - File 80155 ; "^ICD0(" - File 80.1156 ; or157 ; -1~error message146 ; "^ICD9(" - File 80 147 ; "^ICD0(" - File 80.1 148 ; -or- 149 ; -1~error message 158 150 ; 159 151 I $G(CODE)="" Q "-1~NO CODE SELECTED" … … 162 154 ;use FILE if passed 163 155 I $G(FILE) D Q Y_"~"_GLOB 164 . S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:INV_"FILE")165 . I $E(GLOB)'=US Y=-1,GLOB=INV_"FILE" Q166 . S Y=$S(CODE?1.9N:$$CODEZ(CODE,GLOB),1:$$CODEBA(CODE,GLOB))156 . S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:INV_"FILE") 157 . I $E(GLOB)'="^" S Y=-1,GLOB=INV_"FILE" Q 158 . S Y=$S(CODE?1.9N:$$CODEZ(CODE,GLOB),1:$$CODEBA(CODE,GLOB)) 167 159 ;FILE not passed - report where found 168 160 I CODE?1.9N S GLOB="^ICD9(",Y=$$CODEZ(CODE,GLOB) D G CODENQ 169 . I Y<1 S GLOB="^ICD0(",Y=$$CODEZ(CODE,GLOB)161 . I Y<1 S GLOB="^ICD0(",Y=$$CODEZ(CODE,GLOB) 170 162 S GLOB=$S(CODE?2N1"."1.3N:"^ICD0(",CODE?3N1".".3N!(CODE?1U2.3N1".".2N):"^ICD9(",1:-1) 171 163 S Y=$S('GLOB:$$CODEBA(CODE,GLOB),1:-1) … … 174 166 ; 175 167 CODEC(CODE,FILE) ;return the ICD code of an ien 176 ; Input:177 ; CODE - IEN of ICD code REQUIRED178 ; FILE - File Number to search for code179 ; 80 = ICD Dx file180 ; 80.1 = ICD Oper/Proc file181 ; 182 ; Output: ICD code, -1 if not found168 ; Input: 169 ; CODE - IEN of ICD code REQUIRED 170 ; FILE - File Number to search for code 171 ; 80 = ICD Dx file 172 ; 80.1 = ICD Oper/Proc file 173 ; 174 ; Output: ICD code, -1 if not found 183 175 ; 184 176 S CODE=$G(CODE) Q:CODE'?1.9N -1 185 177 N Y,GLOB 186 178 I $G(FILE) D Q Y 187 . S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:-1)188 . S Y=$S(GLOB<0:-1,1:$$CODEZ(CODE,GLOB))179 . S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:-1) 180 . S Y=$S(GLOB<0:-1,1:$$CODEZ(CODE,GLOB)) 189 181 ;FILE not passed - Search for 1st match 190 182 S Y=$$CODEZ(CODE,"^ICD9(",1) … … 193 185 CODEZ(CODE,ROOT,FLG) ; Based on IEN/root: 194 186 N Y,ICDL ; if 'FLG return code existence, else zero node - piece 1 195 S Y=$P($G(@(ROOT_CODE_",0)")), U),ICDL=$L(Y) I ICDL,'$G(FLG) Q CODE187 S Y=$P($G(@(ROOT_CODE_",0)")),"^"),ICDL=$L(Y) I ICDL,'$G(FLG) Q CODE 196 188 Q $S('ICDL:-1,1:Y) 189 ; 197 190 CODEBA(CODE,ROOT) ; Return IEN based on code/root 198 191 N IEN 199 192 S IEN=$O(@(ROOT_"""BA"","""_CODE_" "","""")"),-1) 200 193 Q $S('IEN:-1,1:IEN) 201 ;202 COMCOM(IEN,VDT) ; Return versioned complication/comorbidity203 ;returns a code for complication/comorbidity204 ; 0 - non-CC205 ; 1 - CC206 ; 2 - MCC207 ; -1 - versioned CC not on file for date208 N CCDATE,CCIEN209 S CCDATE=$O(^ICD9(IEN,69,"B",VDT+.0001),-1)210 I CCDATE="" Q -1211 S CCIEN=$O(^ICD9(IEN,69,"B",CCDATE,""),-1)212 Q $P(^ICD9(IEN,69,CCIEN,0),U,2)213 194 ; 214 195 VST(IEN,VDT,TYPE) ; Versioned Short Text … … 218 199 VSTD(IEN,VDT) ; Versioned Short Text (Dx) 219 200 N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD9(+ICDI)) "" 220 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0, U,1) Q:'$L(ICDC) ""201 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) "" 221 202 S STD=$O(^ICD9("AST",(ICDC_" "),(ICDT+.000001)),-1) 222 203 I +STD>0 D Q:$L($G(TXT)) $G(TXT) 223 . S STI=$O(^ICD9("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),U,2))204 . S STI=$O(^ICD9("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),"^",2)) 224 205 S STD=$O(^ICD9(+ICDI,67,"B",0)) I +STD>0 D Q:$L($G(TXT)) $G(TXT) 225 . S STI=$O(^ICD9(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),U,2))226 Q $$TRIM($P(ICD0, U,3))206 . S STI=$O(^ICD9(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),"^",2)) 207 Q $$TRIM($P(ICD0,"^",3)) 227 208 VSTP(IEN,VDT) ; Versioned Short Text (Proc) 228 209 N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD0(+ICDI)) "" 229 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0, U,1) Q:'$L(ICDC) ""210 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) "" 230 211 S STD=$O(^ICD0("AST",(ICDC_" "),(ICDT+.000001)),-1) 231 212 I +STD>0 D Q:$L($G(TXT)) $G(TXT) 232 . S STI=$O(^ICD0("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),U,2))213 . S STI=$O(^ICD0("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),"^",2)) 233 214 S STD=$O(^ICD0(+ICDI,67,"B",0)) I +STD>0 D Q:$L($G(TXT)) $G(TXT) 234 . S STI=$O(^ICD0(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),U,2))235 Q $$TRIM($P(ICD0, U,4))215 . S STI=$O(^ICD0(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),"^",2)) 216 Q $$TRIM($P(ICD0,"^",4)) 236 217 VLT(IEN,VDT,TYPE) ; Version Description - Long Text 237 218 Q:TYPE["ICD9(" $$VLTD($G(IEN),$G(VDT)) … … 242 223 S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD9(+ICDI)) "" 243 224 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" 244 S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0, U,1) Q:'$L(ICDC) ""225 S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) "" 245 226 S STD=$O(^ICD9("ADS",(ICDC_" "),(ICDT+.000001)),-1) 246 227 I +STD>0 D Q:$L($G(TXT)) $G(TXT) 247 . S STI=$O(^ICD9("ADS",(ICDC_" "),STD,+ICDI," "),-1)248 . S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),U,1))228 . S STI=$O(^ICD9("ADS",(ICDC_" "),STD,+ICDI," "),-1) 229 . S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),"^",1)) 249 230 S STD=$O(^ICD9(+ICDI,68,"B",0)) 250 231 I +STD>0 D Q:$L($G(TXT)) $G(TXT) 251 . S STI=$O(^ICD9(+ICDI,68,"B",STD,0))252 . S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),U,1))232 . S STI=$O(^ICD9(+ICDI,68,"B",STD,0)) 233 . S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),"^",1)) 253 234 S TXT=$$TRIM($G(^ICD9(+ICDI,1))) Q:$L($G(TXT)) $G(TXT) 254 Q $$TRIM($P(ICD0, U,3))235 Q $$TRIM($P(ICD0,"^",3)) 255 236 VLTP(IEN,VDT) ; Versioned Description - Long Text (Proc) 256 237 N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT 257 238 S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD0(+ICDI)) "" 258 239 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" 259 S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0, U,1) Q:'$L(ICDC) ""240 S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) "" 260 241 S STD=$O(^ICD0("ADS",(ICDC_" "),(ICDT+.000001)),-1) 261 242 I +STD>0 D Q:$L($G(TXT)) $G(TXT) 262 . S STI=$O(^ICD0("ADS",(ICDC_" "),STD,+ICDI," "),-1)263 . S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),U,1))243 . S STI=$O(^ICD0("ADS",(ICDC_" "),STD,+ICDI," "),-1) 244 . S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),"^",1)) 264 245 S STD=$O(^ICD0(+ICDI,68,"B",0)) 265 246 I +STD>0 D Q:$L($G(TXT)) $G(TXT) 266 . S STI=$O(^ICD0(+ICDI,68,"B",STD,0))267 . S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),U,1))247 . S STI=$O(^ICD0(+ICDI,68,"B",STD,0)) 248 . S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),"^",1)) 268 249 S TXT=$$TRIM($G(^ICD0(+ICDI,1))) Q:$L($G(TXT)) $G(TXT) 269 Q $$TRIM($P(ICD0, U,4))250 Q $$TRIM($P(ICD0,"^",4)) 270 251 TRIM(X) ; Trim Spaces 271 252 S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X)) -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG.m
r628 r636 1 ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 11/13/07 4:07pm2 ;;18.0;DRG Grouper;**2,7,10,14,20 ,31**;Oct 20, 2000;Build 71 ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 5/19/05 12:52pm 2 ;;18.0;DRG Grouper;**2,7,10,14,20**;Oct 20, 2000;Build 1 3 3 ;ADL - UPDATED FOR CSV;3/10/03 4 4 TOP S (ICDDRG,ICDMDC,ICDRTC)="" … … 19 19 I ICDTMP<0 S ICDRTC=1 G ERR 20 20 S ICDY(0)=$P(ICDTMP,U,2,99) I $P(ICDY(0),"^",4)=1!($P(ICDY(0),"^",9)=0) S ICDRTC=1 G ERR ;flag has changed from inactive flag to status flag 21 S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0 I 'ICDMDC S ICD RTC=1 G ERR21 S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0 I 'ICDMDC S ICDDRG=469,ICDRTC=1 G ERR 22 22 D MDCG 23 23 I $D(ICDMDC(12))!($D(ICDMDC(13))) S ICDMDC=$S(SEX="F":13,1:12) I SEX="" S ICDRTC=4 G ERR … … 30 30 ;FOLLOWING ESTABLISHES SECONDARY DIAGNOSIS VARIABLES 31 31 ; 32 S (ICDCCT,ICD MCCT,ICDSD)="",ICDCC=0,ICDMCC=0,ICDI=132 S (ICDCCT,ICDSD)="",ICDCC=0,ICDI=1 33 33 F ICDIZ=0:0 S ICDI=$O(ICDDX(ICDI)) Q:ICDI'>0 D G:ICDRTC]"" ERR 34 34 . S ICDTMP=$$ICDDX^ICDCODE(ICDDX(ICDI),ICDDATE) I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=8 Q … … 37 37 . D SEC,SEX9 G:ICDRTC]"" ERR 38 38 S:$D(ICDCCT(1)) ICDCC=1 K ICDCCT 39 S:$D(ICDMCCT(1)) ICDMCC=1 S:$D(ICDMCCT(2)) ICDMCC=2 K ICDMCCT40 39 ;******************************************************** 41 40 ;FOLLOWING ESTABLISHES OPERATION/PROCEDURE VARIABLES … … 47 46 K ICDO24("N") G:ICDRTC]"" ERR 48 47 G ^ICDDRG0 49 SEC I ICDDATE>3070930.9 D 50 .S ICDMCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",18)=2:2,($P(ICDY(0),"^",18)=1)&(ICDMCC'=2):1,1:ICDMCC),ICDMCCT(ICDMCC)="" 51 E D 52 .S ICDCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)="" 48 SEC S ICDCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)="" 53 49 ;Group ICD identifiers in one variable 54 50 S ICDSD=ICDSD_$P(ICDY(0),"^",2) … … 79 75 ;translate specific identifiers into common symbol, check for symbol 80 76 S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($TR($P(ICDY(0),"^",2),"lqtrB","\\\\")["\":1,1:0))="" Q 81 ERR S ICDDRG= $S(ICDDATE>3070930.9:999,1:470)77 ERR S ICDDRG=470 82 78 Q ;ERR 83 79 SEX9 ;get sex for dx or proc … … 105 101 Q 1 106 102 KILL K ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX 107 K ICDSDRG,ICDODRG,ICDCC,ICD MCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD103 K ICDSDRG,ICDODRG,ICDCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD 108 104 K ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT 109 105 K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF,ICDS25 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG0.m
r628 r636 1 ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 11/13/07 4:06pm2 ;;18.0;DRG Grouper;**1,2,7,10,14,17,20,24,27,30 ,31,32**;Oct 20, 2000;Build 91 ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 5/16/05 9:05pm 2 ;;18.0;DRG Grouper;**1,2,7,10,14,17,20,24,27,30**;Oct 20, 2000;Build 5 3 3 ;GROUPING PROCESS BEGINS 4 4 ; 5 5 GROUP ; 6 I $D(ICDSEX(1))&($D(ICDSEX(2))) S ICDRTC=4,ICDDRG=$S(ICDDATE>3070930.9:999,1:470) G KILL^ICDDRG 7 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15 D:ICDOPCT<2 I ((ICDDATE'>3070930.9)&("468^476^477"[ICDRG))!((ICDDATE>3070930.9)&("983^986^989"[ICDRG)) G END 6 I $D(ICDSEX(1))&($D(ICDSEX(2))) S ICDRTC=4,ICDDRG=470 G KILL^ICDDRG 7 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15 D:ICDOPCT<2 I "468^476^477"[ICDRG G END 8 . ;I ICDPD["M",ICDOR'["a" S ICDPDRG(344)="",ICDOPCT=0 8 9 . I $D(ICDF) Q 9 10 . I ICDPD["M",ICDOR'["y" S ICDOPCT=0 Q 10 . I ICDDATE>3070930.9 D 11 . . I ICDORNI["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(769)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):983,ICDORNI["y":986,ICDORNI["z":989,1:983) Q 12 . . I ICDOPNR S ICDRG=$S(ICDORNI["y":986,1:983),ICDOPNR=0 Q 13 . E D 14 . . I ICDORNI["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(377)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):468,ICDORNI["y":476,ICDORNI["z":477,1:468) Q 15 . . I ICDOPNR S ICDRG=$S(ICDORNI["y":476,1:468),ICDOPNR=0 Q 11 .I ICDORNI["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(377)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):468,ICDORNI["y":476,ICDORNI["z":477,1:468) Q 12 .I ICDOPNR S ICDRG=$S(ICDORNI["y":476,1:468),ICDOPNR=0 Q 16 13 ; 17 14 ;if number of non-extensive ORs eqs # OR, 477 18 15 ; 19 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI'["y"&(ICDORNI'="")&(ICDORNI["z") D I ((ICDDATE'>3070930.9)&(ICDRG=477))!((ICDDATE>3070930.9)&(ICDRG=989))G END16 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI'["y"&(ICDORNI'="")&(ICDORNI["z") D I ICDRG=477 G END 20 17 . I $D(ICDF) Q 21 . NEW K S K=$$ORNI(ICDORNI) I K=ICDOPCT S ICDRG= $S(ICDDATE>3070930.9:989,1:477)Q18 . NEW K S K=$$ORNI(ICDORNI) I K=ICDOPCT S ICDRG=477 Q 22 19 ; 23 20 ;if number of non-extensive ORs+prostatics eqs # OR, 476 24 21 ; 25 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI["y"&(ICDORNI'="") D I ((ICDDATE'>3070930.9)&(ICDRG=476))!((ICDDATE>3070930.9)&(ICDRG=986))G END26 .N K S K=$$ORNI(ICDORNI) I K=ICDOPCT&(ICDNOR=ICDONR) S ICDRG= $S(ICDDATE>3070930.9:986,1:476)Q27 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDNOR=ICDONR&(ICDOPCT>0) S ICDRG= $S(ICDDATE>3070930.9:983,1:468)G END28 I ICDMDC=5,ICDOR'["O" S ICDRTC=$S(ICDEXP="":5,1:"") S:ICDRTC'="" ICDRG= $S(ICDDATE>3070930.9:999,1:470)D:ICDRTC="" MI G END22 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI["y"&(ICDORNI'="") D I ICDRG=476 G END 23 .N K S K=$$ORNI(ICDORNI) I K=ICDOPCT&(ICDNOR=ICDONR) S ICDRG=476 Q 24 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDNOR=ICDONR&(ICDOPCT>0) S ICDRG=468 G END 25 I ICDMDC=5,ICDOR'["O" S ICDRTC=$S(ICDEXP="":5,1:"") S:ICDRTC'="" ICDRG=470 D:ICDRTC="" MI G END 29 26 ;I ICDMDC=18,ICDOR["O"!(ICDORNI["O") S ICDRG=415 G END ;;disabled by ICD*18*24 and new DRGs 578/579 - see ICDTLB6C 30 I ICDMDC=19,ICDOCNT>0,ICDOR["O" S (ICDRG,HICDRG)= $S(ICDDATE>3070930.9:876,1:424)D CKDRG31 I ICDMDC=23,ICDOR["O"!(ICDORNI["O") S ICDRG= $S(ICDDATE>3070930.9:941,1:461)G END27 I ICDMDC=19,ICDOCNT>0,ICDOR["O" S (ICDRG,HICDRG)=424 D CKDRG 28 I ICDMDC=23,ICDOR["O"!(ICDORNI["O") S ICDRG=461 G END 32 29 I ICDMDC=14 D ^ICDDRG14 I ICDRG]"" G END 33 I ICDMDC=20 S ICDRTC=$S(ICDDMS="":7,1:"") I ICDDMS'=0 D G END 34 . I ICDDATE>3070930.9 S ICDRG=$S(ICDDMS="":999,1:894) Q 35 . S ICDRG=$S(ICDDMS="":470,1:433) 36 I ICDMDC=22 S ICDRTC=$S(ICDTRS="":6,1:"") S:ICDRTC'="" ICDRG=$S(ICDDATE>3070930.9:999,1:470) D:ICDRTC="" CKBURN G END 37 I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 D G END 38 . I ICDDATE>3070930.9 S ICDRG=$S(ICDRTC'="":999,1:789) Q 39 . S ICDRG=$S(ICDRTC'="":470,1:385) 40 NEONATE I 'ICDNOR!('$D(ICDODRG)) S ICDRG=$O(ICDPDRG(0)) X "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG D NEONATF^ICDDRG0" D D DODRG G GETMOR:ICDRG="",END 30 I ICDMDC=20 S ICDRTC=$S(ICDDMS="":7,1:"") I ICDDMS'=0 S ICDRG=$S(ICDDMS="":470,1:433) G END 31 I ICDMDC=22 S ICDRTC=$S(ICDTRS="":6,1:"") S:ICDRTC'="" ICDRG=470 D:ICDRTC="" CKBURN G END 32 I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 S ICDRG=$S(ICDRTC'="":470,1:385) G END 33 NEONATE I 'ICDNOR!('$D(ICDODRG)) S ICDRG=$O(ICDPDRG(0)) X "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))" D D DODRG G GETMOR:ICDRG="",END 41 34 . N X,X1,X2,% 42 35 . S X1=$S($G(DGADM):$G(DGADM),1:DT),X2=$G(DOB) I X1,X2 D ^%DTC I X<29 D NBCOMP Q 43 . I ICDDATE'>3070930.9 I ICDRG<385!(ICDRG>391) Q 44 . I ICDDATE>3070930.9 I ICDRG<789!(ICDRG>795) Q 36 . I ICDRG<385!(ICDRG>391) Q 45 37 .; I "^11917^11918^11921^"[("^"_ICDDX(1)_"^") S ICDRG=395 Q 46 . I ICDDATE'>3070930.9 I $O(ICDRG(391)) S ICDRG=$O(ICDRG(391)) Q 47 . I ICDDATE>3070930.9 I $O(ICDRG(795)) S ICDRG=$O(ICDRG(795)) Q 48 . I 'ICDRG S ICDRG=$S(ICDDATE>3070930.9:999,1:470),ICDRTC=8 49 I AGE="",ICDMDC=3 S ICDRTC=3 S ICDRG=$S(ICDDATE>3070930.9:999,1:470) G END 38 . I $O(ICDRG(391)) S ICDRG=$O(ICDRG(391)) Q 39 . I 'ICDRG S ICDRG=470,ICDRTC=8 40 I AGE="",ICDMDC=3 S ICDRTC=3,ICDRG=470 G END 50 41 D ^ICDDRG1:ICDMDC=1,^ICDDRG2:ICDMDC=2,^ICDDRG3:ICDMDC=3,^ICDDRG5:ICDMDC=5,^ICDDRG6:ICDMDC=6,^ICDDRG7:ICDMDC=7,^ICDDRG8:ICDMDC=8,^ICDDRG9:ICDMDC=9,^ICDDRG10:ICDMDC=10,^ICDDRG11:ICDMDC=11,^ICDDRG12:ICDMDC=12,^ICDDRG13:ICDMDC=13 51 42 D ^ICDDRG17:ICDMDC=17 … … 53 44 D DODRG 54 45 G:ICDRG'>0 LOOK8:ICDMDC=8,AGAIN G END 55 ENTER I 'ICDNOR,ICDORNR'=0,ICDMDC'=20,ICDMDC'=15 S ICDRG= $S(ICDDATE>3070930.9:983,1:468)G END56 GETMOR S (ICDRG,HICDRG)=$O(ICDPDRG(0)) S:ICDRG'>0 (ICDRG,HICDRG)= $S(ICDDATE>3070930.9:998,1:469)46 ENTER I 'ICDNOR,ICDORNR'=0,ICDMDC'=20,ICDMDC'=15 S ICDRG=468 G END 47 GETMOR S (ICDRG,HICDRG)=$O(ICDPDRG(0)) S:ICDRG'>0 (ICDRG,HICDRG)=469 ;I ICDMDC=15,'$D(ICDODRG),$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG S (ICDRG,HICDRG)=$O(ICDSDRG(0)) 57 48 CKDRG D DODRG 58 49 I ICDRG="" K ICDPDRG(HICDRG) G GETMOR … … 61 52 N DRGFY,ICDREF S (DRGFY,ICDREF)="" 62 53 I ICDRG S DRGFY=$O(^ICD(ICDRG,2,"B",$P(+$G(ICDDATE),".")_.01),-1) 63 I 'DRGFY S DRGFY=30 71001 ;default to current fiscal year54 I 'DRGFY S DRGFY=3061001 ;default to current fiscal year 64 55 S ICDREF=$O(^ICD(+ICDRG,2,"B",+DRGFY,ICDREF)) 65 56 I ICDREF'="" D … … 75 66 D:ICDP24'=""!($D(ICDS24)) CKMST^ICDDRGX S ICDDRG=ICDRG 76 67 ;ICD*18*24 check for higher numbered DRG (such as new DRG 561) before checking for 489 in CKHIV^ICDDRGX 77 I ICDDATE<3071001 I ICDRG=489!(ICDRG=490)!(ICDRG=543&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=543 S ICDRG=561 78 I ICDDATE'<3071001 I ICDRG=976!(ICDRG=977)!(ICDRG=24&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=24 S ICDRG=99 68 I ICDRG=489!(ICDRG=490)!(ICDRG=543&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=543 S ICDRG=561 79 69 D:$G(ICDP25)=1!(($G(ICDP25)>1)&($D(ICDS25(1)))) CKHIV^ICDDRGX S ICDDRG=ICDRG 80 70 ; this will effectively make DRG 103 into a pre-MDC (ICD*18*1) 81 I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5"))!(ICDDATE>3030930.9&($D(ICDOP(" 37.51"))!$D(ICDOP(" 37.66")))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG 82 I (ICDDATE>3050930.9)&($D(ICDOP(" 37.64")))&($D(ICDOP(" 37.65"))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG 83 I (ICDDATE>3060930.9)&($D(ICDOP(" 37.63")))&($D(ICDOP(" 37.64"))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG 84 I $D(ICDOP(" 39.65")) S ICDRG=$S(ICDDATE>3070930.9:3,1:541),ICDNMDC(1)="" 85 I (ICDDATE>3070930.9)&($D(ICDOP(" 46.97"))) S ICDRG=5,ICDNMDC(1)="" 71 I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5"))!(ICDDATE>3030930.9&($D(ICDOP(" 37.51"))!$D(ICDOP(" 37.66")))) S ICDRG=103,ICDNMDC(1)="" 72 I (ICDDATE>3050930.9)&($D(ICDOP(" 37.64")))&($D(ICDOP(" 37.65"))) S ICDRG=103,ICDNMDC(1)="" 73 I (ICDDATE>3060930.9)&($D(ICDOP(" 37.63")))&($D(ICDOP(" 37.64"))) S ICDRG=103,ICDNMDC(1)="" 74 I $D(ICDOP(" 39.65")) S ICDRG=541,ICDNMDC(1)="" 86 75 ; this will create DRGs 512/513 as pre-MDC 87 I $D(ICDOP(" 52.80"))!$D(ICDOP(" 52.82")) S ICDRG=$S(ICDDATE>3070930.9:10,1:513),ICDNMDC(1)="" 88 I (ICDDATE>3070930.9) D 89 . I ICDRG=10 I $D(ICDOP(" 55.69")) S ICDRG=8 90 E I ICDRG=513 I $D(ICDOP(" 55.69")) S ICDRG=512 76 I $D(ICDOP(" 52.80"))!$D(ICDOP(" 52.82")) S ICDRG=513,ICDNMDC(1)="" 77 I ICDRG=513 I $D(ICDOP(" 55.69")) S ICDRG=512 91 78 ; this will create DRG 481 as pre-MDC - loops thru 41.00 thru .09 92 N X S X=0 F S X=$O(ICDOP(X)) Q:X="" I X["41.0" S ICDRG= $S(ICDDATE>3070930.9:9,1:481),ICDNMDC(1)=""79 N X S X=0 F S X=$O(ICDOP(X)) Q:X="" I X["41.0" S ICDRG=481,ICDNMDC(1)="" 93 80 I $D(ICDNMDC(1)) I ICDNMDC(1)="" D CKNMDC^ICDDRGX S ICDDRG=ICDRG K ICDNMDC 94 I ICDDATE>3070930.9 D 95 . I ICDRG=983 D CHKMDC4^ICDDRGX 96 . D DODRG S ICDDRG=ICDRG ;check for MCC/CC 97 E I ICDRG=468 D CHKMDC4^ICDDRGX D DODRG S ICDDRG=ICDRG 81 I ICDRG=468 D CHKMDC4^ICDDRGX D DODRG S ICDDRG=ICDRG 98 82 S:ICDRTC="" ICDRTC=0 99 S ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE) I '$P(ICDTMP,U,14) S ICDDRG= $S(ICDDATE>3070930.9:999,1:470)83 S ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE) I '$P(ICDTMP,U,14) S ICDDRG=470 100 84 G KILL^ICDDRG 101 85 MI ; 102 86 ; if PTCA and not a bypass 103 I ICDOR["1"!($D(ICDOP(" 37.90"))) I ICDOR'["b"&(ICDOR'["6") D Q 104 . I ICDDATE>3070930.9 D CMS516^ICDTBL2 Q 105 . E D DRG516^ICDTLB6B 87 I ICDOR["1"!($D(ICDOP(" 37.90"))) I ICDOR'["b"&(ICDOR'["6") I ICDDATE>3050930.9 D DRG516^ICDTLB6B Q 106 88 I ICDPD["A" D EN1^ICDDRG5 I ICDCC3 S ICDRG=$O(ICDODRG(0)) D DODRG Q 107 89 I ICDPD["AI"!(ICDSD["AI") D Q 108 . I ICDDATE>3070930.9 D 109 . . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):285,ICDPD["V"!(ICDSD["V"):280,1:282) 110 . E D 111 . . I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=526 Q 112 . . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):123,ICDPD["V"!(ICDSD["V"):121,1:122) 113 I $D(ICDOP(" 37.26"))&($D(ICDOP(" 39.61"))) S ICDRG=$S(ICDDATE>3070930.9:230,1:108) Q 90 . I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=526 Q 91 . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):123,ICDPD["V"!(ICDSD["V"):121,1:122) 92 I $D(ICDOP(" 37.26"))&($D(ICDOP(" 39.61"))) S ICDRG=108 Q 114 93 ;I $D(ICDOP(" 37.26")) S ICDRG=112 Q 115 I ICDDATE<3071001 I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=527 Q 116 I ICDDATE<3071001 I $D(ICDOP(" 36.06")) I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=517 Q 117 I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=$S(ICDDATE>3070930.9:251,1:518) Q 118 I ICDOR["H" D Q 119 . I ICDDATE>3070930.9 S ICDRG=$S(ICDPD["X"!(ICDSD["X"):286,1:287) Q 120 . E S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q 121 I ICDDATE>3070930.9 K ICDPDRG(286),ICDPDRG(287) 122 E K ICDPDRG(124) 94 I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=527 Q 95 I $D(ICDOP(" 36.06")) I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=517 Q 96 I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=518 Q 97 I ICDOR["H" S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q 98 K ICDPDRG(124) 123 99 I ICDOR["p" S ICDRG=$O(ICDODRG(0)) D DODRG Q 124 100 I ICDOR["F" S ICDRG=$O(ICDODRG(0)) D DODRG Q 125 E D Q 126 . I ICDDATE>3070930.9 K ICDPDRG(280),ICDPDRG(281),ICDPDRG(282) S ICDRG=$O(ICDPDRG(0)) D DODRG Q 127 . E K ICDPDRG(121) S ICDRG=$O(ICDPDRG(0)) D DODRG Q 101 E K ICDPDRG(121) S ICDRG=$O(ICDPDRG(0)) D DODRG Q 128 102 ; 129 103 CKBURN ; MDC22 - Burns (extensive, full thickness, or non-extensive) 130 104 D 131 . I ICDPD["*"!(ICDSD["*") D Q 132 . . I ICDDATE>3070930.9 S ICDRG=$S(ICDOR["k":927,1:933) Q 133 . . E S ICDRG=$S(ICDOR["k":504,1:505) Q 105 . I ICDPD["*"!(ICDSD["*") S ICDRG=$S(ICDOR["k":504,1:505) Q 134 106 . I ICDPD["b"!(ICDSD["b") D FTBURN Q 135 . I ICDDATE>3070930.9 S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):935,1:935) 136 . E S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):510,1:511) 107 . S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):510,1:511) 137 108 Q 138 109 ; … … 151 122 N ICDSDXCK 152 123 S ICDSDXCK=$O(ICDSDRG(0)) 153 I ICDDATE>3070930.9 D 154 . I ICDSDXCK<ICDRG,ICDSDXCK>788,ICDSDXCK<796 D 155 .. S ICDRG=$S($D(ICDPDRG(795)):795,$D(ICDPDRG(791)):791,1:$O(ICDSDRG(0))) 156 E D 157 . I ICDSDXCK<ICDRG,ICDSDXCK>384,ICDSDXCK<392 D 158 .. S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0))) 124 I ICDSDXCK<ICDRG,ICDSDXCK>384,ICDSDXCK<392 D 125 . S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0))) 159 126 Q 160 127 ; 161 128 FTBURN ; full thickness burn check 162 129 I ICDSD["j"!(ICDOR["k") D 163 . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG= $S(ICDDATE>3070930.9:928,1:506)164 . E S ICDRG= $S(ICDDATE>3070930.9:929,1:507)130 . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=506 131 . E S ICDRG=507 165 132 E D 166 . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG= $S(ICDDATE>3070930.9:934,1:508)167 . E S ICDRG= $S(ICDDATE>3070930.9:934,1:509)133 . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=508 134 . E S ICDRG=509 168 135 Q 169 ;170 NEONATF ;NEONATE - Continuation of xecute line171 I ICDDATE>3070930.9 S ICDRG=$S($D(ICDPDRG(795)):795,$D(ICDPDRG(791)):791,1:$O(ICDSDRG(0))) Q172 S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))173 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG1.m
r628 r636 1 ICDDRG1 ;ALB/MRY - FIX SURGERY HIERARCHY ; 11/14/07 5:30pm2 ;;18.0;DRG Grouper;**10,17,24 ,31**;Oct 20, 2000;Build 71 ICDDRG1 ;ALB/MRY - FIX SURGERY HIERARCHY ; 6/15/05 7:07pm 2 ;;18.0;DRG Grouper;**10,17,24**;Oct 20, 2000;Build 5 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D 4 . I ICDDATE<3061001 D F Q 5 . E I ICDDATE<3071001 D FY2007 Q 6 . E D FY2008 4 .I ICDDATE<3061001 D F 5 .E D FY2007 7 6 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q 8 7 F I ICDJ=3 S ICDJ(1)=ICDJ Q … … 86 85 I ICDJ=35 S ICDJ(39)=ICDJ Q 87 86 Q 88 FY2008 ;MS-DRG89 I ICDJ=27 S ICDJ(1)=ICDJ Q90 I ICDJ=22 S ICDJ(2)=ICDJ Q91 I ICDJ=24 S ICDJ(3)=ICDJ Q92 ;I ICDJ=27 S ICDJ(3)=ICDJ Q93 I ICDJ=30 S ICDJ(4)=ICDJ Q94 I ICDJ=33 S ICDJ(5)=ICDJ Q95 I ICDJ=36 S ICDJ(6)=ICDJ Q96 I ICDJ=39 S ICDJ(7)=ICDJ Q97 I ICDJ=42 S ICDJ(8)=ICDJ Q98 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG10.m
r628 r636 1 1 ICDDRG10 ;ALB/GRR - FIX SURGERY HIERARCHY ; 11/6/00 2:03pm 2 ;;18.0;DRG Grouper;**24 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D 4 . I ICDDATE<3061001 D F Q 5 . E I ICDDATE<3071001 D FY2007 Q 6 . E D FY2008 4 . I ICDDATE<3061001 D F 5 . E D FY2007 7 6 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q 8 7 F I ICDJ=286 S ICDJ(1)=ICDJ Q … … 15 14 I ICDJ=288 S ICDJ(3)=ICDJ 16 15 Q 17 FY2008 ;MS-DRG18 I ICDJ=615 S ICDJ(1)=ICDJ Q19 I ICDJ=618 S ICDJ(2)=ICDJ Q20 I ICDJ=621 S ICDJ(3)=ICDJ Q21 I ICDJ=624 S ICDJ(4)=ICDJ Q22 I ICDJ=627 S ICDJ(5)=ICDJ Q23 I ICDJ=630 S ICDJ(6)=ICDJ24 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG11.m
r628 r636 1 1 ICDDRG11 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:42am 2 ;;18.0;DRG Grouper;**24,31**;Oct 20, 2000;Build 7 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D 4 . I ICDDATE<3071001 D F Q 5 . E D FY2008 2 ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D F 6 4 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q 7 5 F I ICDJ=302 S ICDJ(1)=ICDJ Q … … 9 7 I ICDJ=303 S ICDJ(3)=ICDJ Q 10 8 Q 11 FY2008 ;MS-DRG12 I ICDJ=652 S ICDJ(1)=ICDJ Q13 I ICDJ=655 S ICDJ(2)=ICDJ Q14 I ICDJ=658 S ICDJ(3)=ICDJ Q15 I ICDJ=661 S ICDJ(4)=ICDJ Q16 I ICDJ=667 S ICDJ(5)=ICDJ Q17 I ICDJ=670 S ICDJ(6)=ICDJ Q18 I ICDJ=672 S ICDJ(7)=ICDJ Q19 I ICDJ=675 S ICDJ(8)=ICDJ20 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG12.m
r628 r636 1 1 ICDDRG12 ;ALB/GRR - FIX SURGERY HIERARCHY ; 10/23/00 11:37am 2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D 4 . I ICDDATE<3071001 D F Q 5 . E D FY2008 2 ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D F 6 4 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q 7 5 F I ICDJ=334 S ICDJ(1)=ICDJ Q … … 13 11 I ICDJ=344 S ICDJ(7)=ICDJ 14 12 Q 15 FY2008 ;MS-DRG16 I ICDJ=708 S ICDJ(1)=ICDJ Q17 I ICDJ=710 S ICDJ(2)=ICDJ Q18 I ICDJ=712 S ICDJ(3)=ICDJ Q19 I ICDJ=714 S ICDJ(4)=ICDJ Q20 I ICDJ=718 S ICDJ(5)=ICDJ Q21 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG13.m
r628 r636 1 1 ICDDRG13 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:38am 2 ;;18.0;DRG Grouper;**24 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D 4 . I ICDDATE<3061001 D F Q 5 . E I ICDDATE<3071001 D FY2007 Q 6 . E D FY2008 4 . I ICDDATE<3061001 D F 5 . E D FY2007 7 6 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q 8 7 F I ICDJ=353 S ICDJ(1)=ICDJ Q … … 35 34 I ICDJ=365 S ICDJ(13)=ICDJ 36 35 Q 37 FY2008 ;38 I ICDJ=735 S ICDJ(1)=ICDJ Q39 I ICDJ=738 S ICDJ(2)=ICDJ Q40 I ICDJ=741 S ICDJ(3)=ICDJ Q41 I ICDJ=743 S ICDJ(4)=ICDJ Q42 I ICDJ=745 S ICDJ(5)=ICDJ Q43 I ICDJ=747 S ICDJ(6)=ICDJ Q44 I ICDJ=748 S ICDJ(7)=ICDJ Q45 I ICDJ=750 S ICDJ(8)=ICDJ46 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG14.m
r628 r636 1 1 ICDDRG14 ;ALB/GRR - FIX SURGERY HIERARCHY ; 9/29/04 3:48pm 2 ;;18.0;DRG Grouper;**14 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1 3 3 ; 4 G POST:ICDPD'["D" I ICDOR["c" D Q 5 . I ICDDATE>3070930.9 S ICDRG=766 6 . E S ICDRG=$S(ICDCC:370,1:371) 7 NOV I ICDOR["s"!(ICDOR["g") D Q 8 . I ICDDATE>3070930.9 S ICDRG=$S(ICDOR["s":767,1:768) 9 . E S ICDRG=$S(ICDOR["s":374,1:375) 4 G POST:ICDPD'["D" I ICDOR["c" S ICDRG=$S(ICDCC:370,1:371) Q 5 NOV I ICDOR["s"!(ICDOR["g") S ICDRG=$S(ICDOR["s":374,1:375) Q 10 6 ; 11 I ICDDATE>3070930.9 S ICDRG=$S(ICDSD["n"!(ICDPD["n"):774,1:775) Q 12 E S ICDRG=$S(ICDSD["n"!(ICDPD["n"):372,1:373) Q 7 S ICDRG=$S(ICDSD["n"!(ICDPD["n"):372,1:373) Q 13 8 ; 14 9 POST N DRGFY,ICDREF -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG17.m
r628 r636 1 1 ICDDRG17 ;ALB/EG - FIX SURGERY HIERARCHY ; 10/9/03 11:41am 2 ;;18.0;DRG Grouper;**10,31**;Oct 20, 2000;Build 7 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D 4 . I ICDDATE<3071001 D F Q 5 . E D FY2008 2 ;;18.0;DRG Grouper;**10**;Oct 20, 2000;Build 1 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D F 6 4 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q 7 5 F I ICDJ=539 S ICDJ(1)=ICDJ Q … … 24 22 I ICDJ=414 S ICDJ(18)=ICDJ Q 25 23 Q 26 FY2008 ;27 I ICDJ=822 S ICDJ(1)=ICDJ Q28 I ICDJ=825 S ICDJ(2)=ICDJ Q29 I ICDJ=828 S ICDJ(3)=ICDJ Q30 I ICDJ=830 S ICDJ(4)=ICDJ31 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG2.m
r628 r636 1 1 ICDDRG2 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:39am 2 ;;18.0;DRG Grouper;**24 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D 4 .I ICDDATE<3061001 D F Q 5 .E I ICDDATE<3071001 D FY2007 Q 6 .E D FY2008 4 .I ICDDATE<3061001 D F 5 .E D FY2007 7 6 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q 8 7 F I ICDJ=37 S ICDJ(1)=ICDJ Q … … 21 20 I ICDJ=38 S ICDJ(6)=ICDJ Q 22 21 Q 23 FY2008 ;24 I ICDJ=114 S ICDJ(1)=ICDJ Q25 I ICDJ=115 S ICDJ(2)=ICDJ Q26 I ICDJ=117 S ICDJ(3)=ICDJ Q27 Q28 22 VER S ICDF="",ICDL39=0 F ICDFZ=1:1 S ICDF=$O(ICDOP(ICDF)) Q:ICDF="" S ICD=$P(ICDF," ",2) I "12.91^12.92^14.71^14.72^14.73^14.74^14.75^14.79"'[ICD S ICDL39=1 Q 29 23 S ICDRG=$S(ICDL39:39,1:42) -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG3.m
r628 r636 1 1 ICDDRG3 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:39am 2 ;;18.0;DRG Grouper;**24 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D 4 .I ICDDATE<3061001 D F Q 5 .E I ICDDATE<3071001 D FY2007 Q 6 .E D FY2008 4 .I ICDDATE<3061001 D F 5 .E D FY2007 7 6 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q 8 7 F I ICDJ=49 S ICDJ(1)=ICDJ Q … … 43 42 I ICDJ=63 S ICDJ(17)=ICDJ Q 44 43 Q 45 FY2008 ;MS-DRG46 I ICDJ=130 S ICDJ(1)=ICDJ Q47 I ICDJ=132 S ICDJ(2)=ICDJ Q48 I ICDJ=134 S ICDJ(3)=ICDJ Q49 I ICDJ=136 S ICDJ(4)=ICDJ Q50 I ICDJ=138 S ICDJ(5)=ICDJ Q51 I ICDJ=139 S ICDJ(6)=ICDJ Q52 Q53 44 EN1 ; 54 45 I $D(ICDOP(" 28.2"))!($D(ICDOP(" 28.3")))!($D(ICDOP(" 28.6"))) S ICDRG=$S(ICDOCNT>1:$S(AGE>17:57,1:58),1:ICDRG) -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG5.m
r628 r636 1 1 ICDDRG5 ;ALB/GRR/EG/MRY/ADL - FIX SURGERY HIERARCHY ; 3/20/03 10:36am 2 ;;18.0;DRG Grouper;**2,5,7,10,20,22 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**2,5,7,10,20,22**;Oct 20, 2000;Build 1 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D 4 .I ICDDATE<3051001 D F Q 5 .E I ICDDATE<3071001 D FY2007 Q 6 .E D FY2008 4 .I ICDDATE<3051001 D F 5 .E D FY2006 7 6 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q 8 7 F I ICDJ=103 S ICDJ(1)=ICDJ Q … … 33 32 I ICDJ=120 S ICDJ(25)=ICDJ 34 33 Q 35 FY200 7;34 FY2006 ; 36 35 I ICDJ=103 S ICDJ(1)=ICDJ Q 37 36 I ICDJ=525 S ICDJ(2)=ICDJ Q … … 66 65 I ICDJ=120 S ICDJ(31)=ICDJ 67 66 Q 68 FY2008 ;69 I ICDJ=215 S ICDJ(1)=ICDJ Q70 I ICDJ=221 S ICDJ(2)=ICDJ Q71 I ICDJ=223 S ICDJ(3)=ICDJ Q72 I ICDJ=225 S ICDJ(4)=ICDJ Q73 I ICDJ=227 S ICDJ(5)=ICDJ Q74 I ICDJ=230 S ICDJ(6)=ICDJ Q75 I ICDJ=232 S ICDJ(7)=ICDJ Q76 I ICDJ=234 S ICDJ(8)=ICDJ Q77 I ICDJ=236 S ICDJ(9)=ICDJ Q78 I ICDJ=238 S ICDJ(10)=ICDJ Q79 I ICDJ=241 S ICDJ(11)=ICDJ Q80 I ICDJ=244 S ICDJ(12)=ICDJ Q81 I ICDJ=245 S ICDJ(13)=ICDJ Q82 I ICDJ=247 S ICDJ(14)=ICDJ Q83 I ICDJ=249 S ICDJ(15)=ICDJ Q84 I ICDJ=251 S ICDJ(16)=ICDJ Q85 I ICDJ=254 S ICDJ(17)=ICDJ Q86 I ICDJ=257 S ICDJ(18)=ICDJ Q87 I ICDJ=259 S ICDJ(19)=ICDJ Q88 I ICDJ=262 S ICDJ(20)=ICDJ Q89 I ICDJ=263 S ICDJ(21)=ICDJ Q90 I ICDJ=264 S ICDJ(22)=ICDJ Q91 Q92 67 EN1 S (ICDCC3,ICDCC2)=0 93 68 I $D(ICDOP(" 00.50")) S ICDCC3=1 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG6.m
r628 r636 1 1 ICDDRG6 ;ALB/GRR - FIX SURGERY HIERARCHY ; 10/23/00 11:40am 2 ;;18.0;DRG Grouper;**24,27 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**24,27**;Oct 20, 2000;Build 2 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D 4 .I ICDDATE<3061001 D F Q 5 .E I ICDDATE<3071001 D FY2007 Q 6 .E D FY2008 4 .I ICDDATE<3061001 D F 5 .E D FY2007 7 6 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q 8 7 F I ICDJ=154 S ICDJ(1)=ICDJ Q … … 40 39 I ICDJ=170 S ICDJ(19)=ICDJ 41 40 Q 42 FY2008 ;43 I ICDJ=328 S ICDJ(1)=ICDJ Q44 I ICDJ=331 S ICDJ(2)=ICDJ Q45 I ICDJ=334 S ICDJ(3)=ICDJ Q46 I ICDJ=337 S ICDJ(4)=ICDJ Q47 I ICDJ=340 S ICDJ(5)=ICDJ Q48 I ICDJ=343 S ICDJ(6)=ICDJ Q49 I ICDJ=346 S ICDJ(7)=ICDJ Q50 I ICDJ=349 S ICDJ(8)=ICDJ Q51 I ICDJ=352 S ICDJ(9)=ICDJ Q52 I ICDJ=355 S ICDJ(10)=ICDJ Q53 I ICDJ=358 S ICDJ(11)=ICDJ Q54 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG7.m
r628 r636 1 1 ICDDRG7 ;ALB/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:41am 2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D 4 .I ICDDATE<3071001 D F Q 5 .E D FY2008 2 ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1 3 Q:$O(ICDODRG(0))'>0 K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 D F 6 4 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q 7 5 F I ICDJ=191 S ICDJ(1)=ICDJ Q … … 19 17 I ICDJ=201 S ICDJ(13)=ICDJ 20 18 Q 21 FY2008 ;22 I ICDJ=407 S ICDJ(1)=ICDJ Q23 I ICDJ=410 S ICDJ(2)=ICDJ Q24 I ICDJ=413 S ICDJ(3)=ICDJ Q25 I ICDJ=416 S ICDJ(4)=ICDJ Q26 I ICDJ=419 S ICDJ(5)=ICDJ Q27 I ICDJ=422 S ICDJ(6)=ICDJ Q28 I ICDJ=423 S ICDJ(7)=ICDJ Q29 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG8.m
r628 r636 1 1 ICDDRG8 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 7/18/01 10:40am 2 ;;18.0;DRG Grouper;**1,2,10,20,24 ,31**;Oct 20, 2000;Build 72 ;;18.0;DRG Grouper;**1,2,10,20,24**;Oct 20, 2000;Build 5 3 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D 4 .I ICDDATE<3051001 D F Q 5 .E I ICDDATE<3061001 D FY2006 Q 6 .E I ICDDATE<3071001 D FY2007 Q 7 .E D FY2008 4 .I ICDDATE<3051001 D F 5 .E I ICDDATE<3061001 D FY2006 6 .E D FY2007 8 7 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q 9 8 F I ICDJ=471 S ICDJ(1)=ICDJ Q … … 111 110 I ICDJ=234 S ICDJ(37)=ICDJ Q 112 111 Q 113 FY2008 ;114 I ICDJ=455 S ICDJ(1)=ICDJ Q115 I ICDJ=458 S ICDJ(2)=ICDJ Q116 I ICDJ=460 S ICDJ(3)=ICDJ Q117 I ICDJ=462 S ICDJ(4)=ICDJ Q118 I ICDJ=465 S ICDJ(5)=ICDJ Q119 I ICDJ=468 S ICDJ(6)=ICDJ Q120 I ICDJ=470 S ICDJ(7)=ICDJ Q121 I ICDJ=473 S ICDJ(8)=ICDJ Q122 I ICDJ=476 S ICDJ(9)=ICDJ Q123 I ICDJ=479 S ICDJ(10)=ICDJ Q124 I ICDJ=482 S ICDJ(11)=ICDJ Q125 I ICDJ=484 S ICDJ(12)=ICDJ Q126 I ICDJ=487 S ICDJ(13)=ICDJ Q127 I ICDJ=489 S ICDJ(14)=ICDJ Q128 I ICDJ=491 S ICDJ(15)=ICDJ Q129 I ICDJ=494 S ICDJ(16)=ICDJ Q130 I ICDJ=497 S ICDJ(17)=ICDJ Q131 I ICDJ=499 S ICDJ(18)=ICDJ Q132 I ICDJ=502 S ICDJ(19)=ICDJ Q133 I ICDJ=505 S ICDJ(20)=ICDJ Q134 I ICDJ=506 S ICDJ(21)=ICDJ Q135 I ICDJ=508 S ICDJ(22)=ICDJ Q136 I ICDJ=509 S ICDJ(23)=ICDJ Q137 I ICDJ=512 S ICDJ(24)=ICDJ Q138 I ICDJ=514 S ICDJ(25)=ICDJ Q139 I ICDJ=517 S ICDJ(26)=ICDJ Q140 Q141 112 EN1 ; paired spinal fusion codes 142 113 S ICDCC3=0 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG9.m
r628 r636 1 1 ICDDRG9 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:42am 2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D 4 . I ICDDATE<3071001 D F Q 5 .E D FY2008 2 ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1 3 Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D F 6 4 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q 7 5 F I ICDJ=263 S ICDJ(1)=ICDJ Q … … 20 18 I ICDJ=270 S ICDJ(14)=ICDJ 21 19 Q 22 FY2008 ;23 I ICDJ=575 S ICDJ(1)=ICDJ Q24 I ICDJ=578 S ICDJ(2)=ICDJ Q25 I ICDJ=581 S ICDJ(3)=ICDJ Q26 I ICDJ=583 S ICDJ(4)=ICDJ Q27 I ICDJ=585 S ICDJ(5)=ICDJ Q28 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRGM.m
r628 r636 1 1 ICDDRGM ;ALB/GRR/EG/ADL - GROUPER DRIVER ; 10/23/00 11:45am 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1 3 3 ;;ADL;Add Date prompt and passing of effective date for DRG CSV project 4 4 ;;ADL;Update DIC("S") code to screen using new function calls -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRGX.m
r628 r636 1 ICDDRGX ;ALB/EG/MRY/ADL - GROUPER PROCESS ; 11/13/07 3:44pm2 ;;18.0;DRG Grouper;**1,2,5,7,10,14,20,24,27 ,31**;Oct 20, 2000;Build 71 ICDDRGX ;ALB/EG/MRY/ADL - GROUPER PROCESS ; 3/14/05 1:38pm 2 ;;18.0;DRG Grouper;**1,2,5,7,10,14,20,24,27**;Oct 20, 2000;Build 2 3 3 CKHIV ;MDC25 grouping 4 I ICDDATE>3070930.9 G CKHIV^ICDDRGXM ;MS-DRG5 4 ;Q:ICDP25="" 6 5 I ICDPD'["h"&(ICDSD'["h") Q … … 26 25 S:(ICDRG=488)!(ICDRG=489)!(ICDRG=490) ICDRTC=0 27 26 K ICDGH,ICDP25,ICDS25,ICDORNA Q 28 CKMST ;MDC24 grouping ; MS-DRG additions27 CKMST ;MDC24 grouping 29 28 S ICDAJ=0 F ICDS24K=1:1 S ICDAJ=$O(ICDS24(ICDAJ)) Q:ICDAJ="" 30 29 S ICDS24K=ICDS24K-1,ICDS24L=0 F ICDI=1:1:8 S:$D(ICDS24(ICDI))&(ICDI'=ICDP24) ICDS24L=$S($D(ICDS24(ICDI)):1,1:0) 31 30 I ICDOR["u" S ICDS24K=ICDS24K+1 32 31 G:((ICDP24=0)&(ICDS24K<2))!((ICDP24>0)&('ICDS24L)) CKMSTE 33 N CKMST S CKMST=0 34 I ICDDATE>3070930.9 D Q:CKMST ;MS-DRG 35 . S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):955,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):955,1:ICDRG) I ICDRG=955 D CKMSTE S CKMST=1 Q 36 . S:ICDRG'=955 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):956,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):956,1:ICDRG) I ICDRG=956 D CKMSTE S CKMST=1 Q 37 . S:ICDRG'=956 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):959,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):959,1:ICDRG) I ICDRG=959 D CKMSTE S CKMST=1 Q 38 . S ICDRG=$S(ICDP24=0&(ICDS24K>1):965,ICDP24>0&ICDS24L:965,1:ICDRG) 39 . S:(ICDRG>954)&(ICDRG<966) ICDRTC=0 40 E D Q:CKMST ;CMS-DRG 41 . S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):484,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):484,1:ICDRG) I ICDRG=484 D CKMSTE S CKMST=1 Q 42 . S:ICDRG'=484 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):485,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):485,1:ICDRG) I ICDRG=485 D CKMSTE S CKMST=1 Q 43 . S:ICDRG'=485 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):486,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):486,1:ICDRG) I ICDRG=486 D CKMSTE S CKMST=1 Q 44 . S ICDRG=$S(ICDP24=0&(ICDS24K>1):487,ICDP24>0&ICDS24L:487,1:ICDRG) 45 . S:(ICDRG>483)&(ICDRG<488) ICDRTC=0 32 S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):484,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):484,1:ICDRG) I ICDRG=484 D CKMSTE Q 33 S:ICDRG'=484 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):485,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):485,1:ICDRG) I ICDRG=485 D CKMSTE Q 34 S:ICDRG'=485 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):486,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):486,1:ICDRG) I ICDRG=486 D CKMSTE Q 35 S ICDRG=$S(ICDP24=0&(ICDS24K>1):487,ICDP24>0&ICDS24L:487,1:ICDRG) 36 S:(ICDRG>483)&(ICDRG<488) ICDRTC=0 46 37 CKMSTE K ICDAJ,ICDP24,ICDS24,ICDO24,ICDS24K,ICDO24,ICDS24L 47 38 Q 48 39 CKNMDC ;non MDC drg's 49 I ICDDATE>3070930.9 G CKNMDC^ICDDRGXM ;MS-DRG50 40 S:(ICDRG>479)&(ICDRG<484) ICDRG=470 51 41 ; ICD*18*1 - reorder drg 103 higher than all Pre-MDCs 480-83 & 495 … … 65 55 S ICDRG=$S(ICDOR["r":495,1:ICDRG) I ICDRG=495 S ICDRTC=0 Q ;check for lung tx 66 56 S ICDRG=$S(ICDOR["q":103,1:ICDRG) I ICDRG=103 S ICDRTC=0 Q ;check for heart tx 67 S ICDRG=$S(ICDOR["B":481,1:ICD RG) I ICDRG=481 S ICDRTC=0 Q57 S ICDRG=$S(ICDOR["B":481,1:ICDDRG) I ICDRG=481 S ICDRTC=0 Q 68 58 S ICDRG=$S($D(ICDOP(" 30.3"))!$D(ICDOP(" 30.4")):482,1:ICDRG) I ICDRG=482 S ICDRTC=0 Q 69 59 S ICDRG=$S(ICDOR["t"&($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["Y"):482,1:ICDRG) I ICDRG=482 S ICDRTC=0 Q … … 72 62 ; 73 63 CHKMDC4 ;MDC 4 drg's 74 I ICDDATE>3070930.9 D ;MS-DRG 75 . I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=168 76 . I ICDDRG=983,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=264 77 . I ICDDRG=983,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=264 ;ICD*18*5 78 E D ;CMS-DRG 79 . I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=76 80 . I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=120 81 . I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=120 ;ICD*18*5 64 I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=76 65 I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=120 66 I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=120 ;ICD*18*5 82 67 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDGTDRG.m
r628 r636 1 1 ICDGTDRG ;ALB/ADL/KER - COLLECTION OF DRG APIS ; 04/18/2004 2 ;;18.0;DRG Grouper;**7,12,14,17**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**7,12,14,17**;Oct 20, 2000;Build 1 3 3 ; Collection of API's for accessing new "DRG" level 4 4 ; of files #80, #80.1, and #80.2. These new levels -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDHLPO.m
r628 r636 1 ICDHLPO ;ALB/GRR/EG-HELP DISPLAY FOR OPERATION IDENTIFIERS ; 11/9/07 12:52pm2 ;;18.0;DRG Grouper;**10,14 ,31**;Oct 20, 2000;Build 71 ICDHLPO ;ALB/GRR/EG-HELP DISPLAY FOR OPERATION IDENTIFIERS ; 9/22/04 9:38am 2 ;;18.0;DRG Grouper;**10,14**;Oct 20, 2000;Build 1 3 3 EN ;revised 12/94 abr 4 4 N ICDID,I,J,ID … … 57 57 ;;Q=Craniotomy 58 58 ;;I=injectable/infusion (injection or infusion of drugs) 59 ;;J=Inguinal and femoral hernia procedures60 59 ;;EXIT 61 60 Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDID.m
r628 r636 1 1 ICDID ;SLC/KER - ICD IDENTIFIERS ; 04/18/2004 2 ;;18.0;DRG Grouper;**12,15**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**12,15**;Oct 20, 2000;Build 1 3 3 ; 4 4 ; -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDREF.m
r628 r636 1 1 ICDREF ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 5/20/05 8:35pm 2 ;;18.0;DRG Grouper;** 14,17 **;Oct 20, 2000 2 ;;18.0;DRG Grouper;** 14,17 **;Oct 20, 2000;Build 1 3 3 RTABLE(ICDRG,ICDDATE) ; Return Reference Table 4 4 ; Input: ICDRG - DRG entry -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDSUPT.m
r628 r636 1 1 ICDSUPT ;DLS/DEK - ICD SUPPORT FOR APIS ; 04/28/2003 2 ;;18.0;DRG Grouper;**6**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**6**;Oct 20, 2000;Build 1 3 3 ; 4 4 ; External References -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1.m
r628 r636 1 1 ICDTLB1 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/29/03 11:47am 2 ;;18.0;DRG Grouper;**10**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**10**;Oct 20, 2000;Build 1 3 3 DRG1 D DRG528 D:ICDRG'=528 DRG529 4 4 S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=529:529,ICDRG=530:530,ICDCC:1,1:2) I AGE="" S ICDRTC=3,ICDRG=470 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1A.m
r628 r636 1 1 ICDTLB1A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 8/19/04 3:19pm ; 6/15/05 6:35pm 2 ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000;Build 1 3 3 DRG1 D DRG528 D:ICDRG'=528 DRG543^ICDTLB6A D:ICDRG'=543 DRG529 4 4 S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=543:543,ICDRG=529:529,ICDRG=530:530,ICDCC:1,1:2) I AGE="" S ICDRTC=3,ICDRG=470 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1B.m
r628 r636 1 1 ICDTLB1B ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2006; 8/19/04 3:19pm ; 6/28/05 4:01pm 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1 3 3 DRG1 D DRG528 D:ICDRG'=528 DRG543^ICDTLB6B D:ICDRG'=543 DRG529 4 4 S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=543:543,ICDRG=529:529,ICDRG=530:530,ICDCC:1,1:2) I AGE="" S ICDRTC=3,ICDRG=470 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2.m
r628 r636 1 1 ICDTLB2 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/19/03 1:09pm 2 ;;18.0;DRG Grouper;**2,10**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**2,10**;Oct 20, 2000;Build 1 3 3 DRG95 S ICDRG=$S(ICDCC:94,1:95) Q 4 4 DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2A.m
r628 r636 1 1 ICDTLB2A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 9/19/03 1:09pm ; 11/19/04 10:13am 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1 3 3 DRG95 S ICDRG=$S(ICDCC:94,1:95) Q 4 4 DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2B.m
r628 r636 1 1 ICDTLB2B ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2006; 9/19/03 1:09pm ; 6/28/05 4:02pm 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1 3 3 DRG95 S ICDRG=$S(ICDCC:94,1:95) Q 4 4 DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB3.m
r628 r636 1 1 ICDTLB3 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/29/04 3:38pm 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1 3 3 DRG164 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q 4 4 DRG165 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB3A.m
r628 r636 1 1 ICDTLB3A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 10/23/00 11:48am ; 4/1/05 11:05am 2 ;;18.0;DRG Grouper;**14,16**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**14,16**;Oct 20, 2000;Build 1 3 3 DRG164 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q 4 4 DRG165 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4.m
r628 r636 1 1 ICDTLB4 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:48am 2 ;;18.0;DRG Grouper;;Oct 20, 2000 2 ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1 3 3 DRG263 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q 4 4 DRG264 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4A.m
r628 r636 1 1 ICDTLB4A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 10/23/00 11:48am ; 10/4/04 10:23am 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1 3 3 DRG263 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q 4 4 DRG264 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4B.m
r628 r636 1 1 ICDTLB4B ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2006; 10/23/00 11:48am ; 6/28/05 4:04pm 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1 3 3 DRG263 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q 4 4 DRG264 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5.m
r628 r636 1 1 ICDTLB5 ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:49am 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1 3 3 ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003 4 4 DRG334 S ICDRG=$S(ICDCC:334,1:335) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5A.m
r628 r636 1 1 ICDTLB5A ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS FY 2005; 10/23/00 11:49am ; 8/23/04 11:31am 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1 3 3 ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003 4 4 DRG334 S ICDRG=$S(ICDCC:334,1:335) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5B.m
r628 r636 1 1 ICDTLB5B ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS FY 2006; 10/23/00 11:49am ; 6/28/05 4:05pm 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1 3 3 ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003 4 4 DRG334 S ICDRG=$S(ICDCC:334,1:335) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6.m
r628 r636 1 1 ICDTLB6 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 9/29/03 2:47pm 2 ;;18.0;DRG Grouper;**2,5,10**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**2,5,10**;Oct 20, 2000;Build 1 3 3 DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q 4 4 DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB61.m
r628 r636 1 1 ICDTLB61 ;SSI/ALA-GROUPER UTILITY FUNCTIONS [ 10/9/03 6:28 PM ] ; 10/23/00 11:50am 2 ;;18.0;DRG Grouper;**10,22**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**10,22**;Oct 20, 2000;Build 1 3 3 DRG412 ; 4 4 I $D(ICDDX(1))&(ICDOPCT=0) D Q:ICDRG=409 -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6A.m
r628 r636 1 1 ICDTLB6A ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS FY 2005; 9/29/03 2:47pm ; 6/16/05 1:31pm 2 ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000;Build 1 3 3 DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q 4 4 DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q -
FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6B.m
r628 r636 1 1 ICDTLB6B ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS FY 2006; 9/29/03 2:47pm ; 6/28/05 4:06pm 2 ;;18.0;DRG Grouper;**20,22**;Oct 20, 2000 2 ;;18.0;DRG Grouper;**20,22**;Oct 20, 2000;Build 1 3 3 DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q 4 4 DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
Note:
See TracChangeset
for help on using the changeset viewer.
