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 Dec 13, 2024@01:48:39 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
