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

ICD1853P.m

Go to the documentation of this file.
ICD1853P ;ALB/MJB -DRG UPDATES;8/9/2010
 ;;18.0;DRG Grouper;**53**;Oct 13, 2000;Build 6
 ;
 Q
ICDPX ;UPDATE PX
 N X,DA,DIE,IDENT,DR
 D BMES^XPDUTL(">>> UPDATING PX IDENTIFIER...")
 S DA=4419
 S DIE="^ICD0("
 S IDENT="OM"
 S DR="2////^S X=IDENT"
 D ^DIE
DRG ;
 D BMES^XPDUTL(">>> UPDATING DRG WEIGHTS...")
 N ICDRTN,ICDI,ICDSUB,ICDEDIT,ICDTMP,ICDTOT
 S ICDEDIT=0
 S ICDTOT=$G(ICDTOT) I ICDTOT']"" S ICDTOT=0
 S ICDTMP=$G(ICDTMP)
 I ICDTMP']"" S ICDTMP=$NA(^TMP("DRGWTS",$J)) D
 . K @ICDTMP
 . S @ICDTMP@(0)="WEIGHTS^"_$$NOW^XLFDT
 S ICDSUB="PA"
 F ICDI=1:1:2 S ICDRTN="^ICD1853"_$E(ICDSUB,ICDI) D
  .Q:($T(@ICDRTN)="")
  .N ICDLN,ICDLINE,ICDTAG,ICDDRG,ICDTEXT
  .F ICDLN=1:1 S ICDTAG="MSDRG+"_ICDLN_ICDRTN,ICDTEXT=$T(@ICDTAG) S ICDLINE=$P(ICDTEXT,";;",2) Q:ICDLINE="EXIT"  D
  .. N X,Y,DA,DIE,DR,ICDDRG,ICDFDA,ICDFY,ICDERR,ICDREF
  .. S ICDDRG=+$P(ICDLINE,U)
  .. I '$D(^ICD(ICDDRG,0)) D  Q
  ... S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
  .. I $G(ICDLINE)'[""!($G(ICDTMP)'["") Q
  .. N ICDDRG,ICDWT,ICDLOS,ICDSTR,ICDX,ICDJ,ICDFYR,ICDLOW,ICDHIGH
  .. S ICDFYR=3110000,ICDLOW=1,ICDHIGH=99
  .. S ICDDRG=+$P(ICDLINE,U)
  .. I '$D(^ICD(ICDDRG,0)) D  Q
  ... S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
  .. I ICDDRG=998!(ICDDRG=999) S (ICDLOW,ICDHIGH)=0
  .. S ICDWT=$P(ICDLINE,U,2),ICDLOS=$P(ICDLINE,U,3)
  .. I ICDLOS["*" S ICDLOS=0
  .. S $P(ICDSTR,U)=ICDFYR,$P(ICDSTR,U,2)=ICDWT,$P(ICDSTR,U,3)=ICDLOW,$P(ICDSTR,U,4)=ICDHIGH,$P(ICDSTR,U,9)=ICDLOS
  .. S ^ICD(ICDDRG,"FY",ICDFYR,0)=ICDSTR
  .. I '$D(^ICD(ICDDRG,"FY",0)) S ^ICD(ICDDRG,"FY",0)="^80.22D^"_ICDFYR_"^1" Q
  .. E  D
  ... S ICDX=0 F ICDJ=0:1 S ICDX=$O(^ICD(ICDDRG,"FY",ICDX)) Q:ICDX=""
  ... S $P(^ICD(ICDDRG,"FY",0),"^",3,4)=ICDFYR_"^"_ICDJ
  .. S ICDTOT=ICDTOT+1,ICDEDIT=ICDEDIT+1
  I '$D(@ICDTMP@("ERROR")) D
  . D MES^XPDUTL(">>> Updates Completed...")
  . D MES^XPDUTL("    ...Total Codes Edited: "_ICDEDIT)
  . D MES^XPDUTL("")
 Q
MSDRG ;;MS-DRG ^Weights^Geometric mean LOS^Arithmetic mean LOS
 ;;1^26.3441^31.6^41.9
 ;;2^13.6127^17.6^22.6
 ;;3^18.1239^30.1^36.6
 ;;4^11.2403^22.2^27.1
 ;;5^10.1771^14.9^19.9
 ;;6^4.8353^8.3^9.3
 ;;7^9.335^15.4^18.6
 ;;8^4.9632^10.1^11.7
 ;;10^3.7831^8.6^9.7
 ;;11^4.7666^12.3^15.5
 ;;12^3.1311^8.5^10.1
 ;;13^1.9505^5.7^6.8
 ;;14^11.5947^21.1^28.2
 ;;15^5.9504^16.7^19.3
 ;;20^8.2479^14.1^17.3
 ;;21^6.2886^12.1^13.9
 ;;22^4.1581^6.7^8.4
 ;;23^5.0883^8.2^11.8
 ;;24^3.4952^5.7^8.1
 ;;25^4.7575^8.8^11.5
 ;;26^2.9825^5.8^7.3
 ;;27^2.1307^3^3.9
 ;;28^5.3549^10.1^13.1
 ;;29^2.8741^4.7^6.6
 ;;30^1.6433^2.5^3.3
 ;;31^4.1261^8.6^12.3
 ;;32^1.922^3.6^5.3
 ;;33^1.3626^2.1^2.6
 ;;34^3.5242^4.7^7
 ;;35^2.1437^2.2^3.2
 ;;36^1.639^1.3^1.5
 ;;37^3.1543^5.7^8.4
 ;;38^1.5462^2.4^3.5
 ;;39^1.0185^1.4^1.7
 ;;40^3.9353^9^12.1
 ;;41^2.143^5^6.7
 ;;42^1.6905^2.4^3.2
 ;;52^1.6109^4.5^6.7
 ;;53^0.8441^2.9^3.6
 ;;54^1.4863^4.6^6.3
 ;;55^1.0649^3.5^4.6
 ;;56^1.6748^5.5^7.1
 ;;57^0.935^3.7^4.8
 ;;58^1.5856^5.4^7.2
 ;;59^0.9811^4.1^4.9
 ;;60^0.7578^3.2^3.8
 ;;61^2.9568^6.4^8.4
 ;;62^1.9479^4.8^5.6
 ;;63^1.5251^3.4^3.9
 ;;64^1.8674^5.1^6.9
 ;;65^1.1667^4^4.8
 ;;66^0.8198^2.7^3.3
 ;;67^1.4231^4.2^5.5
 ;;68^0.8751^2.7^3.3
 ;;69^0.7311^2.3^2.8
 ;;70^1.8417^5.6^7.3
 ;;71^1.1054^4.1^5.1
 ;;72^0.7499^2.5^3.1
 ;;73^1.2907^4.2^5.6
 ;;74^0.8606^3.2^4.1
 ;;75^1.6567^5.5^7
 ;;76^0.905^3.3^3.9
 ;;77^1.7376^5.1^6.4
 ;;78^1.0154^3.5^4.4
 ;;79^0.7533^2.6^3.1
 ;;80^1.1909^3.6^4.9
 ;;81^0.7392^2.7^3.4
 ;;82^2.013^3.5^6.1
 ;;83^1.3264^3.4^4.7
 ;;84^0.8959^2.2^2.8
 ;;85^2.1423^5.2^7.2
 ;;86^1.2051^3.7^4.6
 ;;87^0.7929^2.3^2.9
 ;;88^1.4872^4.2^5.5
 ;;89^0.9667^2.9^3.7
 ;;90^0.6927^1.9^2.3
 ;;91^1.6318^4.4^6.2
 ;;92^0.9404^3.3^4.2
 ;;93^0.6827^2.4^2.9
 ;;94^3.6769^8.9^11.7
 ;;95^2.3977^6.6^8.4
 ;;96^1.9247^4.6^5.6
 ;;97^3.2191^9^11.6
 ;;98^1.9106^6.4^7.9
 ;;99^1.2084^4.1^5.2
 ;;100^1.5107^4.5^6
 ;;101^0.7619^2.8^3.4
 ;;102^1.0288^3.1^4.3
 ;;103^0.6701^2.4^3
 ;;113^1.8311^3.9^5.6
 ;;114^0.8989^2^2.6
 ;;115^1.2084^3.5^4.6
 ;;116^1.2675^3^4.4
 ;;117^0.7305^1.6^2
 ;;121^0.9104^4.1^5.1
 ;;122^0.6522^3.3^4
 ;;123^0.7144^2.2^2.7
 ;;124^1.1903^3.8^5.3
 ;;125^0.6859^2.7^3.4
 ;;129^2.2349^3.7^5.2
 ;;130^1.2299^2.3^2.9
 ;;131^2.0915^4.1^5.6
 ;;132^1.2447^2.1^2.7
 ;;133^1.7^3.6^5.4
 ;;134^0.8514^1.7^2.1
 ;;135^1.9082^4.3^6.4
 ;;136^0.9751^1.7^2.3
 ;;137^1.3007^3.6^5
 ;;138^0.7841^1.9^2.5
 ;;139^0.8756^1.4^1.8
 ;;146^2.1886^6.5^9.1
 ;;147^1.2413^4.1^5.7
 ;;148^0.8066^2.4^3.3
 ;;149^0.6389^2.2^2.6
 ;;150^1.2808^3.7^5
 ;;151^0.6393^2.3^2.9
 ;;152^0.9584^3.3^4.3
 ;;153^0.629^2.5^3.1
 ;;154^1.3965^4.3^5.8
 ;;155^0.9017^3.3^4.2
 ;;156^0.6226^2.4^2.9
 ;;157^1.5794^4.8^6.7
 ;;158^0.9027^3.4^4.4
 ;;159^0.5897^2.2^2.7
 ;;163^5.0828^11.5^14
 ;;164^2.6236^6.2^7.4
 ;;165^1.7758^3.7^4.4
 ;;166^3.7383^9.5^11.9
 ;;167^2.0567^5.8^7.4
 ;;168^1.3008^3.3^4.3
 ;;175^1.6096^5.7^6.8
 ;;176^1.0706^4.2^4.9
 ;;177^2.0667^6.8^8.5
 ;;178^1.4887^5.6^6.8
 ;;179^0.9861^4.1^5
 ;;180^1.7361^5.7^7.5
 ;;181^1.2182^4.2^5.4
 ;;182^0.8096^2.8^3.7
 ;;183^1.4942^5.2^6.5
 ;;184^0.9755^3.6^4.3
 ;;185^0.6803^2.6^3
 ;;186^1.5637^5.3^6.7
 ;;187^1.1027^3.9^4.9
 ;;188^0.7678^2.8^3.5
 ;;189^1.2809^4.3^5.5
 ;;190^1.1924^4.5^5.5
 ;;191^0.9735^3.8^4.6
 ;;192^0.722^3.1^3.7
 ;;193^1.4796^5.3^6.5
 ;;194^1.0152^4.2^5
 ;;195^0.7096^3.1^3.7
 ;;196^1.6062^5.6^6.9
 ;;197^1.1176^4.2^5.1
 ;;198^0.8203^3.1^3.8
 ;;199^1.7895^6.3^8
 ;;200^1.0252^3.7^4.8
 ;;201^0.721^2.8^3.6
 ;;202^0.8424^3.4^4.1
 ;;203^0.6081^2.6^3.2
 ;;204^0.6714^2.1^2.7
 ;;205^1.2972^3.9^5.3
 ;;206^0.7575^2.6^3.3
 ;;207^5.2068^12.6^14.7
 ;;208^2.263^5.1^7
 ;;215^12.6086^6.9^12.2
 ;;216^10.0238^14.6^17
 ;;217^6.8038^9.8^10.9
 ;;218^5.3293^7.2^8
 ;;219^8.0831^10.8^13.1
 ;;220^5.3787^7.2^8
 ;;221^4.4801^5.6^6
 ;;222^8.523^9.4^11.8
 ;;223^6.425^4.5^6.2
 ;;224^7.5819^7.7^9.7
 ;;225^6.0202^4.2^5.3
 ;;226^6.451^5^7.7
 ;;227^5.1936^2^3.1
 ;;228^7.5881^11.8^14.2
 ;;229^4.7745^7.2^8.3
 ;;230^3.5451^4.6^5.5
 ;;231^7.8582^10.9^12.9
 ;;232^5.8183^8.5^9.4
 ;;233^7.2081^12.1^13.7
 ;;234^4.8281^8.2^8.9
 ;;235^5.853^9.3^10.8
 ;;236^3.7707^6^6.5
 ;;237^5.1903^7.1^10.1
 ;;238^3.083^2.9^4.2
 ;;239^4.5544^11.2^14.3
 ;;240^2.6589^7.8^9.6
 ;;241^1.4631^5^6
 ;;242^3.7277^6.3^8.1
 ;;243^2.6508^3.9^4.9
 ;;244^2.0398^2.2^2.8
 ;;245^4.2486^2.5^3.8
 ;;246^3.1802^3.5^5
 ;;247^1.9691^1.8^2.3
 ;;248^2.9248^4.4^6
 ;;249^1.7732^2.2^2.8
 ;;250^2.8836^5^7
 ;;251^1.7992^2.2^3
 ;;252^2.9754^5.2^7.9
 ;;253^2.4014^4.4^6
 ;;254^1.6152^2^2.7
 ;;255^2.5043^7^9.2
 ;;256^1.5969^5.6^7
 ;;257^0.975^3.4^4.3
 ;;258^2.888^5.2^7
 ;;259^1.8334^2.4^3.2
 ;;260^3.55^7.7^10.7
 ;;261^1.6469^3.2^4.5
 ;;262^1.1246^2^2.6
 ;;263^1.7565^3.5^5.6
 ;;264^2.5305^5.5^8.2
 ;;265^2.3157^2.3^3.4
 ;;280^1.8503^5.2^6.6
 ;;281^1.1912^3.6^4.4
 ;;282^0.8064^2.2^2.8
 ;;283^1.7151^3.2^5.1
 ;;284^0.8888^2.1^3
 ;;285^0.5712^1.4^1.8
 ;;286^2.0014^4.8^6.5
 ;;287^1.0879^2.5^3.2
 ;;288^2.9397^8.6^10.8
 ;;289^1.8492^6.4^7.8
 ;;290^1.2959^4.4^5.6
 ;;291^1.4943^4.8^6.2
 ;;292^1.0302^4^4.9
 ;;293^0.6853^2.8^3.3
 ;;294^1.0373^4.4^5.4
 ;;295^0.6403^3.4^4
 ;;296^1.1692^1.8^2.8
 ;;297^0.6792^1.4^1.7
 ;;298^0.4497^1.1^1.2
 ;;299^1.4072^4.7^6.1
 ;;300^0.9776^3.9^4.9
 ;;301^0.6615^2.8^3.5
 ;;302^0.9755^3^4
 ;;303^0.583^2^2.4
 ;;304^1.0263^3.5^4.6
 ;;305^0.6138^2.2^2.8
 ;;306^1.4667^4.4^5.9
 ;;307^0.7974^2.7^3.4
 ;;308^1.2339^4^5.2
 ;;309^0.8387^3^3.7
 ;;310^0.5709^2.1^2.5
 ;;311^0.507^1.8^2.2
 ;;312^0.7172^2.4^2.9
 ;;313^0.5499^1.7^2.1
 ;;314^1.8145^5^6.8
 ;;315^0.9681^3.3^4.2
 ;;316^0.6147^2.1^2.6
 ;;326^5.8142^12.6^16.2
 ;;327^2.7231^6.9^8.8
 ;;328^1.4298^2.9^3.8
 ;;329^5.2807^12.5^15.4
 ;;330^2.583^7.8^9.1
 ;;331^1.6267^4.8^5.3
 ;;332^4.8635^11.8^14.2
 ;;333^2.496^7.1^8.1
 ;;334^1.5979^4.2^4.9
 ;;335^4.2777^11.4^13.7
 ;;336^2.3456^7.2^8.8
 ;;337^1.4789^4^5.1
 ;;338^3.2115^8.3^10
 ;;339^1.8659^5.6^6.5
 ;;340^1.2393^3.2^3.7
 ;;341^2.2643^4.9^6.6
 ;;342^1.3246^3^3.8
 ;;343^0.9568^1.7^2
 ;;344^3.1586^8.9^11.2
 ;;345^1.7035^6^7
 ;;346^1.1883^4.2^4.6
 ;;347^2.4183^6.3^8.8
 ;;348^1.3705^4.1^5.4
 ;;349^0.7981^2.3^2.9
 ;;350^2.4877^5.6^7.9
 ;;351^1.3539^3.5^4.5
 ;;352^0.8628^1.9^2.4
 ;;353^2.751^6.3^8.4
 ;;354^1.5523^4^5
 ;;355^1.0329^2.3^2.8
 ;;356^4.0293^9.2^12.7
 ;;357^2.1466^5.7^7.4
 ;;358^1.301^3^4
 ;;368^1.7578^5.1^6.7
 ;;369^1.0772^3.7^4.5
 ;;370^0.7546^2.6^3.1
 ;;371^2.0986^6.8^8.8
 ;;372^1.2935^5.3^6.5
 ;;373^0.8599^3.9^4.6
 ;;374^2.0674^6.3^8.4
 ;;375^1.2801^4.4^5.8
 ;;376^0.8478^2.8^3.6
 ;;377^1.7541^5^6.4
 ;;378^1.0274^3.5^4.2
 ;;379^0.7146^2.6^3
 ;;380^1.9656^5.8^7.6
 ;;381^1.1207^3.9^4.8
 ;;382^0.813^2.9^3.5
 ;;383^1.1982^4.2^5.3
 ;;384^0.8326^3^3.6
 ;;385^1.9102^6.3^8.4
 ;;386^1.0435^4.2^5.3
 ;;387^0.7813^3.2^3.9
 ;;388^1.6457^5.5^7.2
 ;;389^0.9344^3.9^4.8
 ;;390^0.6369^2.8^3.3
 ;;391^1.155^3.9^5.1
 ;;392^0.7173^2.8^3.4
 ;;393^1.6593^4.9^6.8
 ;;394^0.9939^3.7^4.7
 ;;395^0.6749^2.5^3.1
 ;;405^5.5743^12^15.8
 ;;406^2.7791^6.5^8.4
 ;;407^1.8665^4.2^5.2
 ;;408^3.9368^11^13.5
 ;;409^2.4875^7.4^8.9
 ;;410^1.6114^4.9^5.8
 ;;411^3.6818^9.9^11.8
 ;;412^2.4912^7^8.3
 ;;413^1.718^4.5^5.4
 ;;414^3.6675^9.3^11.4
 ;;415^2.0897^6.2^7.3
 ;;416^1.308^3.7^4.4
 ;;417^2.5029^6.2^7.8
 ;;418^1.6996^4.4^5.4
 ;;419^1.1698^2.4^3
 ;;420^3.6443^9.2^13
 ;;421^1.891^5.1^7
 ;;422^1.2742^3^4.1
 ;;423^4.4577^10.9^14.4
 ;;424^2.4335^7.1^9.1
 ;;425^1.6273^4.4^5.7
 ;;432^1.7001^5^6.5
 ;;433^0.9548^3.6^4.6
 ;;434^0.6152^2.5^3.2
 ;;435^1.8018^5.6^7.4
 ;;436^1.2215^4.2^5.5
 ;;437^0.9004^2.8^3.7
 ;;438^1.8342^5.4^7.5
 ;;439^1.0089^4^5
 ;;440^0.689^2.9^3.5
 ;;441^1.8242^5.1^7.1
 ;;442^0.9857^3.7^4.8
 ;;443^0.6615^2.7^3.3
 ;;444^1.5586^4.8^6.2
 ;;445^1.0688^3.6^4.5
 ;;446^0.7411^2.5^3.1
 ;;EXIT