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

ACHSSTL2.m

Go to the documentation of this file. 
  1. ACHSSTL2 ; IHS/ITSC/PMF - INSTALL NEW SITE'S SERVICE CLASSES ;    [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  I $D(^ACHS(3,ACHSDUZ2)) Q
  1.  ;
  1. EN ;
  1.  Q:'$D(ACHSDUZ2)
  1.  D HOME^%ZIS
  1.  S ACHSSITE=$P(^DIC(4,ACHSDUZ2,0),U)
  1.  K DIE,DA,DR
  1.  W *7,!!!,"I will now set up the CHS SERVICE CLASSIFICATION FILE for '",ACHSSITE,"'.",!!
  1.  D WAIT^DICD
  1.  W !!
  1.  S ^ACHS(3,0)="CHS SERVICE CLASSIFICATION^9002063",^ACHS(3,ACHSDUZ2,0)=ACHSDUZ2,^ACHS(3,ACHSDUZ2,1,0)="^9002063.02"
  1. SETOBJ ;
  1.  F ACHSO=1:1 S ACHSZ=$S($D(ACHS638):$T(@"OBJ638"+ACHSO),1:$T(@"OBJCLS"+ACHSO)) Q:ACHSZ=" ;;"  D
  1.  . S DIC="^ACHS(3,ACHSDUZ2,1,",DIC(0)="L",X=$E(ACHSZ,4,7),(DA,DA(1))=ACHSDUZ2,DLAYGO=9002063
  1.  . D ^DIC
  1.  . S ACHSK=$P(^ACHS(3,ACHSDUZ2,1,0),U,4),DIE="^ACHS(3,ACHSDUZ2,1,",DA=ACHSK,DR="1///^S X=$P(ACHSZ,U,2);1.05///^S X=$P(ACHSZ,U,3)"
  1.  . D ^DIE,SETDCR
  1.  .Q
  1.  W !!,"Done!!",!!
  1.  S DIK="^ACHS(3,"
  1.  D IXALL^DIK
  1. END ;
  1.  K ACHSI,ACHSK,ACHSZ,ACHSO,DIE,DR,DA,DIK,ACHS638
  1.  Q
  1.  ;
  1. OBJCLS ;;
  1.  ;;2185^PATIENT & ESCORT TRAVEL^I^526^4
  1.  ;;252A^MED LAB SRV OUTP NON-IHS^I^574^2
  1.  ;;252D^DENTAL LAB SERVICES^F^568^5
  1.  ;;252G^NON-FEDERAL HOSPITALIZATION^F^573^1^533^1
  1.  ;;252H^X-RAY SRV OUTP NON-IHS^I^574^2
  1.  ;;252K^CAT SCAN INPATIENT^I^573^1
  1.  ;;252L^HOSPITAL OUTPATIENT VISIT^F^574^2
  1.  ;;252M^EXTD CARE FAC (NURSING HOME)^F^575^3
  1.  ;;252Q^E.R. SERVICES^F^574^2
  1.  ;;252R^RENAL DIALYSIS (HOSP INP)^I^573^1
  1.  ;;252S^PHYSICAL THERAPY SERV.^I^574^2
  1.  ;;254A^PHYS SVCS IN IHS FACILITY^I^240^2
  1.  ;;254B^PHYS INP NON-IHS^F^573^1^533^1
  1.  ;;254D^PHYS OUTP NON-IHS^F^574^4^533^4
  1.  ;;254E^DENTIST (DENTAL CARE)^F^568^5
  1.  ;;254J^FEE SPEC. NON MD NON-IHS FAC^I^573^1^574^2^575^3
  1.  ;;254L^REFRACTIONS ON-IHS^F^574^2
  1.  ;;254M^RENAL DIALYSIS - PHYS OUTP^I^574^2
  1.  ;;254P^RENAL DIALYSIS - PHYS INP^I^573^1
  1.  ;;254V^FEDERAL HOSPITAL (OUTPATIENT)^I^574^2
  1.  ;;2611^DRUGS MEDICINES & VAC.^I^574^2
  1.  ;;2618^BLOOD & BLOOD PRODUCTS^I^573^1
  1.  ;;263A^MEDICAL AND SURGICAL SUPPLIES^I^574^2
  1.  ;;263G^PROSTHETIC & ORTHO. DEVICES^I^574^2
  1.  ;;
  1. OBJ638 ;;
  1.  ;;2185^PATIENT & ESCORT TRAVEL^I^573^1
  1.  ;;252A^MED LAB SRV OUTP NON-IHS^I^573^1
  1.  ;;252D^DENTAL LAB SERVICES^I^573^1
  1.  ;;252G^NON-FEDERAL HOSPITALIZATION^I^573^1
  1.  ;;252H^X-RAY SRV OUTP NON-IHS^I^573^1
  1.  ;;252K^CAT SCAN INPATIENT^I^573^1
  1.  ;;252L^HOSPITAL OUTPATIENT VISIT^I^573^1
  1.  ;;252M^EXTD CARE FAC (NURSING HOME)^I^573^1
  1.  ;;252Q^E.R. SERVICES^I^573^1
  1.  ;;252R^RENAL DIALYSIS (HOSP INP)^I^573^1
  1.  ;;252S^PHYSICAL THERAPY SERV.^I^573^1
  1.  ;;254A^PHYS SVCS IN IHS FACILITY^I^573^1
  1.  ;;254B^PHYS INP NON-IHS^I^573^1
  1.  ;;254D^PHYS OUTP NON-IHS^I^573^1
  1.  ;;254E^DENTIST (DENTAL CARE)^I^573^1
  1.  ;;254J^FEE SPEC. NON MD NON-IHS FAC^I^573^1
  1.  ;;254L^REFRACTIONS ON-IHS^I^573^1
  1.  ;;254M^RENAL DIALYSIS - PHYS OUTP^I^573^1
  1.  ;;254P^RENAL DIALYSIS - PHYS INP^I^573^1
  1.  ;;254V^FEDERAL HOSPITAL (OUTPATIENT)^I^573^1
  1.  ;;2611^DRUGS MEDICINES & VAC.^I^573^1
  1.  ;;2618^BLOOD & BLOOD PRODUCTS^I^573^1
  1.  ;;263A^MEDICAL AND SURGICAL SUPPLIES^I^573^1
  1.  ;;263G^PROSTHETIC & ORTHO. DEVICES^I^573^1
  1.  ;;
  1. SETDCR ;(below)
  1.  F ACHSI=4:2:999 Q:ACHSI=""  D
  1.  . S:'$D(^ACHS(3,ACHSDUZ2,1,ACHSK,"CC",0)) ^(0)="^9002063.03P"
  1.  . S DIC="^ACHS(3,ACHSDUZ2,1,ACHSK,""CC"",",X=$P(ACHSZ,U,ACHSI),DIC("DR")="1////"_$P(ACHSZ,U,ACHSI+1),DIC(0)="L",DA(2)=ACHSDUZ2,DA(1)=ACHSK
  1.  . D ^DIC
  1.  . W "."
  1.  .Q
  1.  Q
  1.  ;