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