source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD1831W.m@ 1754

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