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

ICDZCOST.m

Go to the documentation of this file.
  1. ICDZCOST ; IHS/ANMC/MWR - CONTRACT CARE COST ESTIMATOR ; AUGUST 14, 1992
  1. ;; VERSION 8.0;DRG GROUPER;;AUG 14, 1992
  1. ; ADAPTED FROM GIS/OHPRD/IHS;CONTRACT CARE COST ESTIMATOR;
  1. S U="^"
  1. ;
  1. CHECK ;
  1. I '$D(ICDDRGN) D G EXIT
  1. .W !!,"The variable, ICDDRGN (the DRG number), is not defined."
  1. I '$D(^ICD(ICDDRGN,0)) D G EXIT
  1. .W !!,"No entry for ",ICDDRGN," in the DRG file."
  1. I '$D(^ICD(ICDDRGN,9999999)) D G EXIT
  1. .W !!,"No HCFA/IHS WEIGHT data stored for this entry in the DRG file."
  1. I '$D(^AMER("2.1",0)) D G EXIT
  1. .W !!,"(There is no ER CONTRACT COST ESTIMATOR FILE.)"
  1. ;
  1. WEIGHT ; GET HCFA/IHS WEIGHT FROM DRG FILE.
  1. S ICDDRGW=+^ICD(ICDDRGN,9999999)
  1. ;
  1. COSTS ; BUILD ARRAY OF ESTIMATED COSTS
  1. K ICDTEMP
  1. S ICDN=0 F S ICDN=$O(^AMER(2.1,ICDN)) Q:'ICDN S ICDOK="" D
  1. .S ICDX=^AMER(2.1,ICDN,0)
  1. .S ICDNAME=$P(ICDX,U,4)
  1. .S ICDCOST=(ICDDRGW*$P(ICDX,U,2))+$P(ICDX,U,3)
  1. .I ICDCOST>0 S ICDOK1=""
  1. .S ICDCOST=+$J(ICDCOST,1,2)
  1. .S ICDTEMP(ICDCOST)=ICDNAME
  1. ;
  1. I '$D(ICDOK) D G EXIT
  1. .W !!,"(There are no entries in the ER CONTRACT COST ESTIMATOR FILE.)"
  1. I '$D(ICDOK1) D G EXIT
  1. .W !!,"(The entries in the ER CONTRACT COST ESTIMATOR FILE contain"
  1. .W " no cost data.)"
  1. ;
  1. OUTPUT ;
  1. W !!,"ESTIMATED COSTS FOR DRG = ",ICDDRGN
  1. W !!,"Remember, costs do not include physician fees!",!
  1. ;
  1. S ICDCOST=0 F ICDI=1:1 S ICDCOST=$O(ICDTEMP(ICDCOST)) Q:'ICDCOST D
  1. .S ICDX=ICDTEMP(ICDCOST)
  1. .S ICDX=$E(ICDX,1,30)
  1. .S ICDY=$E("..............................",1,30-$L(ICDX))
  1. .W !,ICDI,") ",?4,ICDX,ICDY,?37
  1. .S X=ICDCOST,X2="2$" D COMMA^%DTC W X
  1. .K ICDX,ICDY,X,X2
  1. ;
  1. EXIT ;
  1. K DIR,ICDCOST,ICDDRGN,ICDDRGW,ICDDRG,ICDI,ICDOK,ICDOK1,ICDX,ICDY
  1. Q