- ICD1831W ;;ALB/EG/JAT - FY 2008 UPDATE; 6/19/05 4:08pm ; 11/14/07 5:22pm
- ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
- ;
- Q
- ;
- PRO ;-update operation/procedure codes
- ;
- D BMES^XPDUTL(">>>Modifying op/pro codes - file 80.1")
- N LINE,ICDPROC,ICDPROCS,PATT,TAG,TOT,ENTRY,MDC,MDCNM,IENS,IENS2,ICDIEN,VALUE,DRG,FDA,X,II,J,JJ,K,KK
- ;MDC names
- S J=0 F S J=$O(^ICM(J)) Q:'J S MDCNM(J)=$P(^ICM(J,0),U)
- ;
- ;PATTERN 1
- K MDC S PATT=1,TOT=0,MDC(22)="927^928^929",MDC(24)="957^958^959"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- ;PATTERN2
- K MDC S PATT=2,TOT=0,MDC(5)="252^253^254",MDC(24)="957^958^959"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- ;PATTERN3
- K MDC S PATT=3,TOT=0,MDC(5)="252^253^254"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- ;PATTERN4
- K MDC S PATT=4,TOT=0,MDC(5)="264"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- ;PATTERN5
- K MDC S PATT=5,TOT=0,MDC(1)="040^041^042",MDC(24)="957^958^959"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- ;PATTERN6
- K MDC S PATT=6,TOT=0,MDC(1)="028^029^030",MDC(21)="907^908^909",MDC(24)="957^958^959"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- ;PATTERN9
- K MDC S PATT=9,TOT=0,MDC(24)="957^958^959"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- ;PATTERN10
- K MDC S PATT=10,TOT=0,MDC(22)="927^928^929"
- D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
- ;
- Q
- ;
- UPDATE(PATT,MDC,MDCNM,TOT) ;
- S TAG="PATT"_PATT
- F LINE=1:1 S ICDPROCS=$T(@TAG+LINE^ICD1831W) S ICDPROCS=$P(ICDPROCS,";;",2) Q:ICDPROCS="END" D
- .F J=1:1 S ICDPROC=$P(ICDPROCS,U,J) Q:ICDPROC="" D
- ..S ENTRY=+$O(^ICD0("BA",ICDPROC_" ",0))
- ..S K=$O(^ICD0(ENTRY,2,"B",3071001,0))
- ..;quit if no fy08 data
- ..Q:'K
- ..S IENS=","_K_","_ENTRY_","
- ..S JJ=0 F S JJ=$O(MDC(JJ)) Q:'JJ D
- ...S VALUE=$G(MDCNM(JJ))
- ...;quit if MDC already there
- ...Q:($$FIND1^DIC(80.1711,IENS,"",VALUE))
- ...;otherwise setup MDC subrecord
- ...K ICDIEN
- ...S FDA(801,80.1711,"+1"_IENS,.01)=VALUE
- ...D UPDATE^DIE("E","FDA(801)","ICDIEN") K FDA(801)
- ...;quit if not successful
- ...S II=$O(ICDIEN(0))
- ...Q:'II
- ...S TOT=TOT+1
- ...S IENS2=ICDIEN(II)_IENS
- ...F KK=1:1 S DRG=+$P(MDC(JJ),U,KK) Q:'DRG S DRG="DRG"_DRG D
- ....S FDA(801,80.17111,"+"_KK_","_IENS2,.01)=DRG
- ....D UPDATE^DIE("E","FDA(801)") K FDA(801)
- Q
- ;
- PATT1 ;MDC22 & MDC24
- ;;85.82^85.83^85.84^86.61^86.62^86.63^86.65^
- ;;86.66^86.69^86.70^86.71^86.73^86.74^86.75^86.93^
- ;;END
- ;
- PATT2 ;MDC5 & MDC24
- ;;38.32^38.33^38.38^38.42^38.43^38.48^
- ;;38.62^38.63^38.66^38.68^38.7^38.82^38.86^38.88^39.29^39.31^39.41^
- ;;39.42^39.49^39.56^39.57^39.58^39.59^39.91^39.99^
- ;;04.92^38.00^38.10^38.30^38.40^38.60^38.80^39.30^
- ;;END
- ;
- PATT3 ;MDC5
- ;;38.02^38.03^38.08^38.12^38.13^38.18^
- ;;38.21^38.29^38.57^39.55^39.8^39.94^
- ;;END
- ;
- PATT4 ;MDC5
- ;;05.24^
- ;;END
- ;
- PATT5 ;MDC1 & MDC24
- ;;84.12^84.13^84.14^84.16^84.17^
- ;;END
- ;
- PATT6 ;MDC1 & MDC21 & MDC24
- ;;81.01^81.02^81.03^81.04^81.05^81.06^81.07^81.08^
- ;;81.31^81.21^81.33^81.34^81.35^81.36^81.37^81.38^
- ;;END
- ;
- PATT9 ;MDC24
- ;;16.31^16.39^16.41^16.42^16.49^16.51^16.52^16.59^16.61^16.62^
- ;;16.63^16.64^16.65^16.66^16.69.16.71^16.72^
- ;;16.81^16.82^16.89^16.92^16.93^16.98^16.99^18.39^18.6^18.71^18.72^
- ;;18.79^18.9^21.21^21.4^21.83^21.84^21.85^21.86^21.87^21.89^21.99^
- ;;25.59^27.49^27.53^27.55^27.56^27.57^27.59^31.69^31.72^31.74^31.75^
- ;;31.79^31.92^32.9^33.42^33.48^33.49^34.51^34.59^34.73^34.79^
- ;;42.09^42.11^42.12^42.19^42.21^42.41^42.42^42.51^42.52^42.53^42.54^
- ;;42.55^42.56^42.58^42.59^42.61^42.62^42.63^42.64^42.65^42.66^42.68^
- ;;42.69^42.83^42.84^42.85^42.86^42.87^42.89^43.5^43.6^43.7^43.81^
- ;;43.89^43.91^43.99^44.11^44.5^44.63^44.65^44.69^44.99^53.61^54.11^
- ;;54.12^54.19^54.21^54.61^54.62^54.63^38.02^38.03^38.08^38.12^38.13^38.18^
- ;;62.3^62.41^62.42^62.69^62.99^64.3^64.43^64.44^64.45^64.49^
- ;;84.01^84.02^84.03^84.04^84.05^84.06^84.07^84.08^84.09^84.15^84.18^
- ;;84.19^84.21^84.22^84.23^84.24^84.25^84.29^84.3^84.44^84.48^84.91^
- ;;86.22^86.4^86.84^86.89^86.91^04.93^08.20^08.22^08.23^08.24^08.25^
- ;;08.38^08.41^08.43^08.49^08.51^08.59^08.61^08.62^08.63^08.64^08.69^
- ;;08.70^08.71^08.71^08.73^08.74^08.99^09.71^42.10^42.40^43.0^54.0^
- ;;84.00^84.10^84.40^86.60^32.41^86.06^
- ;;END
- ;
- PATT10 ;MDC22
- ;;86.72^
- ;;END
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1831W 4459 printed Jan 18, 2025@02:49:52 Page 2
- ICD1831W ;;ALB/EG/JAT - FY 2008 UPDATE; 6/19/05 4:08pm ; 11/14/07 5:22pm
- +1 ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
- +2 ;
- +3 QUIT
- +4 ;
- PRO ;-update operation/procedure codes
- +1 ;
- +2 DO BMES^XPDUTL(">>>Modifying op/pro codes - file 80.1")
- +3 NEW LINE,ICDPROC,ICDPROCS,PATT,TAG,TOT,ENTRY,MDC,MDCNM,IENS,IENS2,ICDIEN,VALUE,DRG,FDA,X,II,J,JJ,K,KK
- +4 ;MDC names
- +5 SET J=0
- FOR
- SET J=$ORDER(^ICM(J))
- if 'J
- QUIT
- SET MDCNM(J)=$PIECE(^ICM(J,0),U)
- +6 ;
- +7 ;PATTERN 1
- +8 KILL MDC
- SET PATT=1
- SET TOT=0
- SET MDC(22)="927^928^929"
- SET MDC(24)="957^958^959"
- +9 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +10 ;
- +11 ;PATTERN2
- +12 KILL MDC
- SET PATT=2
- SET TOT=0
- SET MDC(5)="252^253^254"
- SET MDC(24)="957^958^959"
- +13 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +14 ;
- +15 ;PATTERN3
- +16 KILL MDC
- SET PATT=3
- SET TOT=0
- SET MDC(5)="252^253^254"
- +17 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +18 ;
- +19 ;PATTERN4
- +20 KILL MDC
- SET PATT=4
- SET TOT=0
- SET MDC(5)="264"
- +21 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +22 ;
- +23 ;PATTERN5
- +24 KILL MDC
- SET PATT=5
- SET TOT=0
- SET MDC(1)="040^041^042"
- SET MDC(24)="957^958^959"
- +25 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +26 ;
- +27 ;PATTERN6
- +28 KILL MDC
- SET PATT=6
- SET TOT=0
- SET MDC(1)="028^029^030"
- SET MDC(21)="907^908^909"
- SET MDC(24)="957^958^959"
- +29 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +30 ;
- +31 ;PATTERN9
- +32 KILL MDC
- SET PATT=9
- SET TOT=0
- SET MDC(24)="957^958^959"
- +33 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +34 ;
- +35 ;PATTERN10
- +36 KILL MDC
- SET PATT=10
- SET TOT=0
- SET MDC(22)="927^928^929"
- +37 DO UPDATE(PATT,.MDC,.MDCNM,.TOT)
- SET ^TMP($JOB,"ICD1831W",PATT)=TOT
- +38 ;
- +39 QUIT
- +40 ;
- UPDATE(PATT,MDC,MDCNM,TOT) ;
- +1 SET TAG="PATT"_PATT
- +2 FOR LINE=1:1
- SET ICDPROCS=$TEXT(@TAG+LINE^ICD1831W)
- SET ICDPROCS=$PIECE(ICDPROCS,";;",2)
- if ICDPROCS="END"
- QUIT
- Begin DoDot:1
- +3 FOR J=1:1
- SET ICDPROC=$PIECE(ICDPROCS,U,J)
- if ICDPROC=""
- QUIT
- Begin DoDot:2
- +4 SET ENTRY=+$ORDER(^ICD0("BA",ICDPROC_" ",0))
- +5 SET K=$ORDER(^ICD0(ENTRY,2,"B",3071001,0))
- +6 ;quit if no fy08 data
- +7 if 'K
- QUIT
- +8 SET IENS=","_K_","_ENTRY_","
- +9 SET JJ=0
- FOR
- SET JJ=$ORDER(MDC(JJ))
- if 'JJ
- QUIT
- Begin DoDot:3
- +10 SET VALUE=$GET(MDCNM(JJ))
- +11 ;quit if MDC already there
- +12 if ($$FIND1^DIC(80.1711,IENS,"",VALUE))
- QUIT
- +13 ;otherwise setup MDC subrecord
- +14 KILL ICDIEN
- +15 SET FDA(801,80.1711,"+1"_IENS,.01)=VALUE
- +16 DO UPDATE^DIE("E","FDA(801)","ICDIEN")
- KILL FDA(801)
- +17 ;quit if not successful
- +18 SET II=$ORDER(ICDIEN(0))
- +19 if 'II
- QUIT
- +20 SET TOT=TOT+1
- +21 SET IENS2=ICDIEN(II)_IENS
- +22 FOR KK=1:1
- SET DRG=+$PIECE(MDC(JJ),U,KK)
- if 'DRG
- QUIT
- SET DRG="DRG"_DRG
- Begin DoDot:4
- +23 SET FDA(801,80.17111,"+"_KK_","_IENS2,.01)=DRG
- +24 DO UPDATE^DIE("E","FDA(801)")
- KILL FDA(801)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +25 QUIT
- +26 ;
- PATT1 ;MDC22 & MDC24
- +1 ;;85.82^85.83^85.84^86.61^86.62^86.63^86.65^
- +2 ;;86.66^86.69^86.70^86.71^86.73^86.74^86.75^86.93^
- +3 ;;END
- +4 ;
- PATT2 ;MDC5 & MDC24
- +1 ;;38.32^38.33^38.38^38.42^38.43^38.48^
- +2 ;;38.62^38.63^38.66^38.68^38.7^38.82^38.86^38.88^39.29^39.31^39.41^
- +3 ;;39.42^39.49^39.56^39.57^39.58^39.59^39.91^39.99^
- +4 ;;04.92^38.00^38.10^38.30^38.40^38.60^38.80^39.30^
- +5 ;;END
- +6 ;
- PATT3 ;MDC5
- +1 ;;38.02^38.03^38.08^38.12^38.13^38.18^
- +2 ;;38.21^38.29^38.57^39.55^39.8^39.94^
- +3 ;;END
- +4 ;
- PATT4 ;MDC5
- +1 ;;05.24^
- +2 ;;END
- +3 ;
- PATT5 ;MDC1 & MDC24
- +1 ;;84.12^84.13^84.14^84.16^84.17^
- +2 ;;END
- +3 ;
- PATT6 ;MDC1 & MDC21 & MDC24
- +1 ;;81.01^81.02^81.03^81.04^81.05^81.06^81.07^81.08^
- +2 ;;81.31^81.21^81.33^81.34^81.35^81.36^81.37^81.38^
- +3 ;;END
- +4 ;
- PATT9 ;MDC24
- +1 ;;16.31^16.39^16.41^16.42^16.49^16.51^16.52^16.59^16.61^16.62^
- +2 ;;16.63^16.64^16.65^16.66^16.69.16.71^16.72^
- +3 ;;16.81^16.82^16.89^16.92^16.93^16.98^16.99^18.39^18.6^18.71^18.72^
- +4 ;;18.79^18.9^21.21^21.4^21.83^21.84^21.85^21.86^21.87^21.89^21.99^
- +5 ;;25.59^27.49^27.53^27.55^27.56^27.57^27.59^31.69^31.72^31.74^31.75^
- +6 ;;31.79^31.92^32.9^33.42^33.48^33.49^34.51^34.59^34.73^34.79^
- +7 ;;42.09^42.11^42.12^42.19^42.21^42.41^42.42^42.51^42.52^42.53^42.54^
- +8 ;;42.55^42.56^42.58^42.59^42.61^42.62^42.63^42.64^42.65^42.66^42.68^
- +9 ;;42.69^42.83^42.84^42.85^42.86^42.87^42.89^43.5^43.6^43.7^43.81^
- +10 ;;43.89^43.91^43.99^44.11^44.5^44.63^44.65^44.69^44.99^53.61^54.11^
- +11 ;;54.12^54.19^54.21^54.61^54.62^54.63^38.02^38.03^38.08^38.12^38.13^38.18^
- +12 ;;62.3^62.41^62.42^62.69^62.99^64.3^64.43^64.44^64.45^64.49^
- +13 ;;84.01^84.02^84.03^84.04^84.05^84.06^84.07^84.08^84.09^84.15^84.18^
- +14 ;;84.19^84.21^84.22^84.23^84.24^84.25^84.29^84.3^84.44^84.48^84.91^
- +15 ;;86.22^86.4^86.84^86.89^86.91^04.93^08.20^08.22^08.23^08.24^08.25^
- +16 ;;08.38^08.41^08.43^08.49^08.51^08.59^08.61^08.62^08.63^08.64^08.69^
- +17 ;;08.70^08.71^08.71^08.73^08.74^08.99^09.71^42.10^42.40^43.0^54.0^
- +18 ;;84.00^84.10^84.40^86.60^32.41^86.06^
- +19 ;;END
- +20 ;
- PATT10 ;MDC22
- +1 ;;86.72^
- +2 ;;END