Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICD1831W

ICD1831W.m

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