source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGYMTRT.m@ 1704

DGYMTRT ;ALB/CAW/LD - Add new treating specialties ; 9/8/94
 ;;5.3;Registration;**39**;Aug 13, 1993
EN ;
 D ADD
 D EN^DGYMTRT1
 Q
ADD ; Add new treating specialty to Specialty file (#42.4).
 N DGX,DGXX
 W !!,">>>Starting update of Specialty (#42.4) and Facility Treating Specialty (#45.7)",!?3,"files...",!
 F DGX=1:1 S DGXX=$P($T(TRTS+DGX),";;",2) Q:DGXX="QUIT"!$D(DTOUT)!$D(DUOUT)  D
 .S DIC="^DIC(42.4,",DIC(0)="LZ",DLAYGO=42.4,X=$P(DGXX,U,2),(DINUM,DGNUM)=$P(DGXX,U)
 .K DD,DO D FILE^DICN K DIC,DINUM,DLAYGO,X
 .W !,$S((+Y=-1)&(("^33^72^73^74^")'[("^"_DGNUM_"^")):"...Overwriting ",(+Y=-1)&(("^33^72^73^74^")[("^"_DGNUM_"^")):"...Editing ",+Y>0:"...Adding "),+DGXX,"  ",$P($G(^DIC(42.4,+DGXX,0)),U)," in file #42.4."
 .S DIE="^DIC(42.4,",DA=DGNUM
 .S DR="1///"_$P(DGXX,U,3)_";3///"_$P(DGXX,U,4)_";5///"_$P(DGXX,U,6)_";6///"_$P(DGXX,U,7)
 .S:(("^33^72^73^74^")[("^"_DGNUM_"^")) DR=".01///"_$P(DGXX,U,2)_";"_DR,DGTRNAM=$P($G(^DIC(42.4,DA,0)),U)
 .D ^DIE K DA,DIE,DR
 .I (("^33^72^73^74^")[("^"_DGNUM_"^")) D  K DGNUM,DGTRNAM Q  ;Edit only...don't add to file #45.7
 ..W !?3,"Old: ",$G(DGTRNAM),?42,"New: ",$P(DGXX,U,2)
 .; Add specialty to Facility Treating Specialty file (#45.7)
 .K DGTRIEN,DGTRNODE,DGNOFAC
 .S DGTRIEN="",DGTRIEN=$O(^DIC(45.7,"B",$P(DGXX,U,2),DGTRIEN))
 .S DGTRNODE=$G(^DIC(45.7,+DGTRIEN,0))
 .I $G(DGTRNODE)']"" D  Q:$G(DGNOFAC)
 ..S DIR(0)="Y",DIR("A")="...Add specialty to Facility Treating Specialty (#45.7) file",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT)!$D(DUOUT)!$D(DTOUT)!($G(Y)'>0) W ! S DGNOFAC=1 Q
 ..S DIC="^DIC(45.7,",DIC(0)="L",DLAYGO=45.7,X=$P(DGXX,U,2) K DD,DO D FILE^DICN S DGTRIEN=+Y K DIC,DLAYGO,X,Y
 .I $G(DGTRNODE)]"" D  I $D(DIRUT)!$D(DUOUT)!$D(DTOUT)!($G(Y)'>0) W ! K DIRUT,Y Q
 ..W !!,"...Specialty ",$P($G(^DIC(45.7,+DGTRIEN,0)),U)," already exists in file #45.7."
 ..S DIR(0)="Y",DIR("A")="...O.K. to overwrite",DIR("B")="NO" D ^DIR K DIR Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)!($G(Y)'>0)  I $G(Y)>0 S DGTRW="Overwriting "
 .S DIC="^DIC(49,",DIC(0)="M",X=$P(DGXX,U,8) D ^DIC K DIC,X S DGSER=+Y
 .I DGSER=-1 W !!,"...Service ",$P(DGXX,U,8)," was not found in the SERVICE/SECTION",!?3,"file (#49).  File #45.7 not updated.",! S DA=DGTRIEN,DIK="^DIC(45.7," D ^DIK K DA,DGSER,DIK Q
 .S DIE="^DIC(45.7,",DA=+DGTRIEN,DR="1///"_+DGXX_";2///"_$P($G(^DIC(49,DGSER,0)),U) D ^DIE K DA,DIE,DR
 .W !,"...",$S($G(DGTRW)]"":DGTRW,1:"Adding "),$P($G(^DIC(45.7,+DGTRIEN,0)),U)," in file #45.7.",!
 .K DGNUM,DGSER,DGTRW,Y
 K DGNOFAC,DGNUM,DGTRIEN,DGTRNODE,DGTRW,DTOUT,DUOUT
 Q
TRTS ; Specialties
 ;;93^HIGH INTENSITY GEN PSYCH INPAT^HI INTENS PSYCH^P^^PSYCHIATRIC CARE^1310^PSYCHIATRY
 ;;79^SIPU (SPEC INPT PTSD UNIT)^SIPU^P^^PSYCHIATRIC CARE^1314^PSYCHIATRY
 ;;91^EVAL/BRF TRMT PTSD UNIT(EBTPU)^EBTPU^P^^PSYCHIATRIC CARE^1315^PSYCHIATRY
 ;;92^GEN INTERMEDIATE PSYCH^INTERMED PSYCH^P^^PSYCHIATRIC CARE^1311^PSYCHIATRY
 ;;84^SUBSTANCE ABUSE INTERMED CARE^SA-INTERMED^P^^ALCOHOL AND DRUG TREATMENT^1312^PSYCHIATRY
 ;;89^STAR I, II & III^STAR^P^^PSYCHIATRIC CARE^1316^PSYCHIATRY
 ;;90^SUBST ABUSE STAR I, II & III^SA-STAR^P^^ALCOHOL AND DRUG TREATMENT^1317^PSYCHIATRY
 ;;88^DOMICILIARY PTSD^DOM PTSD^D^^PSYCHIATRIC CARE^1512^PSYCHIATRY
 ;;25^PSYCH RESID REHAB TRMT PROG^PRRTP^P^^PSYCHIATRIC CARE^1711^PSYCHIATRY
 ;;26^PTSD RESIDENTIAL REHAB PROG^PRRP-PTSD^P^^PSYCHIATRIC CARE^1712^PSYCHIATRY
 ;;27^SUBSTANCE ABUSE RES TRMT PROG^SARRTP^P^^ALCOHOL AND DRUG TREATMENT^1713^PSYCHIATRY
 ;;28^HOMELESS CWT/TRANS RESID^HCMI CWT/TR^P^^PSYCHIATRIC CARE^1714^PSYCHIATRY
 ;;29^SUBST ABUSE CWT/TRANS RESID^SA CWT/TR^P^^PSYCHIATRIC CARE^1715^PSYCHIATRY
 ;;33^GEM PSYCHIATRIC BEDS^GEM PSYCHIATRY^P^^PSYCHIATRIC CARE^1320^PSYCHIATRY
 ;;72^ALCOHOL DEPENDENCE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
 ;;73^DRUG DEPENDENCE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
 ;;74^SUBSTANCE ABUSE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
 ;;QUIT