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

Last change on this file since 1569 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1DGYMTRT ;ALB/CAW/LD - Add new treating specialties ; 9/8/94
2 ;;5.3;Registration;**39**;Aug 13, 1993
3EN ;
4 D ADD
5 D EN^DGYMTRT1
6 Q
7ADD ; Add new treating specialty to Specialty file (#42.4).
8 N DGX,DGXX
9 W !!,">>>Starting update of Specialty (#42.4) and Facility Treating Specialty (#45.7)",!?3,"files...",!
10 F DGX=1:1 S DGXX=$P($T(TRTS+DGX),";;",2) Q:DGXX="QUIT"!$D(DTOUT)!$D(DUOUT) D
11 .S DIC="^DIC(42.4,",DIC(0)="LZ",DLAYGO=42.4,X=$P(DGXX,U,2),(DINUM,DGNUM)=$P(DGXX,U)
12 .K DD,DO D FILE^DICN K DIC,DINUM,DLAYGO,X
13 .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."
14 .S DIE="^DIC(42.4,",DA=DGNUM
15 .S DR="1///"_$P(DGXX,U,3)_";3///"_$P(DGXX,U,4)_";5///"_$P(DGXX,U,6)_";6///"_$P(DGXX,U,7)
16 .S:(("^33^72^73^74^")[("^"_DGNUM_"^")) DR=".01///"_$P(DGXX,U,2)_";"_DR,DGTRNAM=$P($G(^DIC(42.4,DA,0)),U)
17 .D ^DIE K DA,DIE,DR
18 .I (("^33^72^73^74^")[("^"_DGNUM_"^")) D K DGNUM,DGTRNAM Q ;Edit only...don't add to file #45.7
19 ..W !?3,"Old: ",$G(DGTRNAM),?42,"New: ",$P(DGXX,U,2)
20 .; Add specialty to Facility Treating Specialty file (#45.7)
21 .K DGTRIEN,DGTRNODE,DGNOFAC
22 .S DGTRIEN="",DGTRIEN=$O(^DIC(45.7,"B",$P(DGXX,U,2),DGTRIEN))
23 .S DGTRNODE=$G(^DIC(45.7,+DGTRIEN,0))
24 .I $G(DGTRNODE)']"" D Q:$G(DGNOFAC)
25 ..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
26 ..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
27 .I $G(DGTRNODE)]"" D I $D(DIRUT)!$D(DUOUT)!$D(DTOUT)!($G(Y)'>0) W ! K DIRUT,Y Q
28 ..W !!,"...Specialty ",$P($G(^DIC(45.7,+DGTRIEN,0)),U)," already exists in file #45.7."
29 ..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 "
30 .S DIC="^DIC(49,",DIC(0)="M",X=$P(DGXX,U,8) D ^DIC K DIC,X S DGSER=+Y
31 .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
32 .S DIE="^DIC(45.7,",DA=+DGTRIEN,DR="1///"_+DGXX_";2///"_$P($G(^DIC(49,DGSER,0)),U) D ^DIE K DA,DIE,DR
33 .W !,"...",$S($G(DGTRW)]"":DGTRW,1:"Adding "),$P($G(^DIC(45.7,+DGTRIEN,0)),U)," in file #45.7.",!
34 .K DGNUM,DGSER,DGTRW,Y
35 K DGNOFAC,DGNUM,DGTRIEN,DGTRNODE,DGTRW,DTOUT,DUOUT
36 Q
37TRTS ; Specialties
38 ;;93^HIGH INTENSITY GEN PSYCH INPAT^HI INTENS PSYCH^P^^PSYCHIATRIC CARE^1310^PSYCHIATRY
39 ;;79^SIPU (SPEC INPT PTSD UNIT)^SIPU^P^^PSYCHIATRIC CARE^1314^PSYCHIATRY
40 ;;91^EVAL/BRF TRMT PTSD UNIT(EBTPU)^EBTPU^P^^PSYCHIATRIC CARE^1315^PSYCHIATRY
41 ;;92^GEN INTERMEDIATE PSYCH^INTERMED PSYCH^P^^PSYCHIATRIC CARE^1311^PSYCHIATRY
42 ;;84^SUBSTANCE ABUSE INTERMED CARE^SA-INTERMED^P^^ALCOHOL AND DRUG TREATMENT^1312^PSYCHIATRY
43 ;;89^STAR I, II & III^STAR^P^^PSYCHIATRIC CARE^1316^PSYCHIATRY
44 ;;90^SUBST ABUSE STAR I, II & III^SA-STAR^P^^ALCOHOL AND DRUG TREATMENT^1317^PSYCHIATRY
45 ;;88^DOMICILIARY PTSD^DOM PTSD^D^^PSYCHIATRIC CARE^1512^PSYCHIATRY
46 ;;25^PSYCH RESID REHAB TRMT PROG^PRRTP^P^^PSYCHIATRIC CARE^1711^PSYCHIATRY
47 ;;26^PTSD RESIDENTIAL REHAB PROG^PRRP-PTSD^P^^PSYCHIATRIC CARE^1712^PSYCHIATRY
48 ;;27^SUBSTANCE ABUSE RES TRMT PROG^SARRTP^P^^ALCOHOL AND DRUG TREATMENT^1713^PSYCHIATRY
49 ;;28^HOMELESS CWT/TRANS RESID^HCMI CWT/TR^P^^PSYCHIATRIC CARE^1714^PSYCHIATRY
50 ;;29^SUBST ABUSE CWT/TRANS RESID^SA CWT/TR^P^^PSYCHIATRIC CARE^1715^PSYCHIATRY
51 ;;33^GEM PSYCHIATRIC BEDS^GEM PSYCHIATRY^P^^PSYCHIATRIC CARE^1320^PSYCHIATRY
52 ;;72^ALCOHOL DEPENDENCE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
53 ;;73^DRUG DEPENDENCE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
54 ;;74^SUBSTANCE ABUSE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
55 ;;QUIT
Note: See TracBrowser for help on using the repository browser.