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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYMTRT 3938 printed Dec 13, 2024@03:00:24 Page 2
DGYMTRT ;ALB/CAW/LD - Add new treating specialties ; 9/8/94
+1 ;;5.3;Registration;**39**;Aug 13, 1993
EN ;
+1 DO ADD
+2 DO EN^DGYMTRT1
+3 QUIT
ADD ; Add new treating specialty to Specialty file (#42.4).
+1 NEW DGX,DGXX
+2 WRITE !!,">>>Starting update of Specialty (#42.4) and Facility Treating Specialty (#45.7)",!?3,"files...",!
+3 FOR DGX=1:1
SET DGXX=$PIECE($TEXT(TRTS+DGX),";;",2)
if DGXX="QUIT"!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
Begin DoDot:1
+4 SET DIC="^DIC(42.4,"
SET DIC(0)="LZ"
SET DLAYGO=42.4
SET X=$PIECE(DGXX,U,2)
SET (DINUM,DGNUM)=$PIECE(DGXX,U)
+5 KILL DD,DO
DO FILE^DICN
KILL DIC,DINUM,DLAYGO,X
+6 WRITE !,$SELECT((+Y=-1)&(("^33^72^73^74^")'[("^"_DGNUM_"^")):"...Overwriting ",(+Y=-1)&(("^33^72^73^74^")[("^"_DGNUM_"^")):"...Editing ",+Y>0:"...Adding "),+DGXX," ",$PIECE($GET(^DIC(42.4,+DGXX,0)),U)," in file #42.4."
+7 SET DIE="^DIC(42.4,"
SET DA=DGNUM
+8 SET DR="1///"_$PIECE(DGXX,U,3)_";3///"_$PIECE(DGXX,U,4)_";5///"_$PIECE(DGXX,U,6)_";6///"_$PIECE(DGXX,U,7)
+9 if (("^33^72^73^74^")[("^"_DGNUM_"^"))
SET DR=".01///"_$PIECE(DGXX,U,2)_";"_DR
SET DGTRNAM=$PIECE($GET(^DIC(42.4,DA,0)),U)
+10 DO ^DIE
KILL DA,DIE,DR
+11 ;Edit only...don't add to file #45.7
IF (("^33^72^73^74^")[("^"_DGNUM_"^"))
Begin DoDot:2
+12 WRITE !?3,"Old: ",$GET(DGTRNAM),?42,"New: ",$PIECE(DGXX,U,2)
End DoDot:2
KILL DGNUM,DGTRNAM
QUIT
+13 ; Add specialty to Facility Treating Specialty file (#45.7)
+14 KILL DGTRIEN,DGTRNODE,DGNOFAC
+15 SET DGTRIEN=""
SET DGTRIEN=$ORDER(^DIC(45.7,"B",$PIECE(DGXX,U,2),DGTRIEN))
+16 SET DGTRNODE=$GET(^DIC(45.7,+DGTRIEN,0))
+17 IF $GET(DGTRNODE)']""
Begin DoDot:2
+18 SET DIR(0)="Y"
SET DIR("A")="...Add specialty to Facility Treating Specialty (#45.7) file"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)!($GET(Y)'>0)
WRITE !
SET DGNOFAC=1
QUIT
+19 SET DIC="^DIC(45.7,"
SET DIC(0)="L"
SET DLAYGO=45.7
SET X=$PIECE(DGXX,U,2)
KILL DD,DO
DO FILE^DICN
SET DGTRIEN=+Y
KILL DIC,DLAYGO,X,Y
End DoDot:2
if $GET(DGNOFAC)
QUIT
+20 IF $GET(DGTRNODE)]""
Begin DoDot:2
+21 WRITE !!,"...Specialty ",$PIECE($GET(^DIC(45.7,+DGTRIEN,0)),U)," already exists in file #45.7."
+22 SET DIR(0)="Y"
SET DIR("A")="...O.K. to overwrite"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)!($GET(Y)'>0)
QUIT
IF $GET(Y)>0
SET DGTRW="Overwriting "
End DoDot:2
IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)!($GET(Y)'>0)
WRITE !
KILL DIRUT,Y
QUIT
+23 SET DIC="^DIC(49,"
SET DIC(0)="M"
SET X=$PIECE(DGXX,U,8)
DO ^DIC
KILL DIC,X
SET DGSER=+Y
+24 IF DGSER=-1
WRITE !!,"...Service ",$PIECE(DGXX,U,8)," was not found in the SERVICE/SECTION",!?3,"file (#49). File #45.7 not updated.",!
SET DA=DGTRIEN
SET DIK="^DIC(45.7,"
DO ^DIK
KILL DA,DGSER,DIK
QUIT
+25 SET DIE="^DIC(45.7,"
SET DA=+DGTRIEN
SET DR="1///"_+DGXX_";2///"_$PIECE($GET(^DIC(49,DGSER,0)),U)
DO ^DIE
KILL DA,DIE,DR
+26 WRITE !,"...",$SELECT($GET(DGTRW)]"":DGTRW,1:"Adding "),$PIECE($GET(^DIC(45.7,+DGTRIEN,0)),U)," in file #45.7.",!
+27 KILL DGNUM,DGSER,DGTRW,Y
End DoDot:1
+28 KILL DGNOFAC,DGNUM,DGTRIEN,DGTRNODE,DGTRW,DTOUT,DUOUT
+29 QUIT
TRTS ; Specialties
+1 ;;93^HIGH INTENSITY GEN PSYCH INPAT^HI INTENS PSYCH^P^^PSYCHIATRIC CARE^1310^PSYCHIATRY
+2 ;;79^SIPU (SPEC INPT PTSD UNIT)^SIPU^P^^PSYCHIATRIC CARE^1314^PSYCHIATRY
+3 ;;91^EVAL/BRF TRMT PTSD UNIT(EBTPU)^EBTPU^P^^PSYCHIATRIC CARE^1315^PSYCHIATRY
+4 ;;92^GEN INTERMEDIATE PSYCH^INTERMED PSYCH^P^^PSYCHIATRIC CARE^1311^PSYCHIATRY
+5 ;;84^SUBSTANCE ABUSE INTERMED CARE^SA-INTERMED^P^^ALCOHOL AND DRUG TREATMENT^1312^PSYCHIATRY
+6 ;;89^STAR I, II & III^STAR^P^^PSYCHIATRIC CARE^1316^PSYCHIATRY
+7 ;;90^SUBST ABUSE STAR I, II & III^SA-STAR^P^^ALCOHOL AND DRUG TREATMENT^1317^PSYCHIATRY
+8 ;;88^DOMICILIARY PTSD^DOM PTSD^D^^PSYCHIATRIC CARE^1512^PSYCHIATRY
+9 ;;25^PSYCH RESID REHAB TRMT PROG^PRRTP^P^^PSYCHIATRIC CARE^1711^PSYCHIATRY
+10 ;;26^PTSD RESIDENTIAL REHAB PROG^PRRP-PTSD^P^^PSYCHIATRIC CARE^1712^PSYCHIATRY
+11 ;;27^SUBSTANCE ABUSE RES TRMT PROG^SARRTP^P^^ALCOHOL AND DRUG TREATMENT^1713^PSYCHIATRY
+12 ;;28^HOMELESS CWT/TRANS RESID^HCMI CWT/TR^P^^PSYCHIATRIC CARE^1714^PSYCHIATRY
+13 ;;29^SUBST ABUSE CWT/TRANS RESID^SA CWT/TR^P^^PSYCHIATRIC CARE^1715^PSYCHIATRY
+14 ;;33^GEM PSYCHIATRIC BEDS^GEM PSYCHIATRY^P^^PSYCHIATRIC CARE^1320^PSYCHIATRY
+15 ;;72^ALCOHOL DEPENDENCE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
+16 ;;73^DRUG DEPENDENCE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
+17 ;;74^SUBSTANCE ABUSE TRMT UNIT^^P^^ALCOHOL AND DRUG TREATMENT^1313^PSYCHIATRY
+18 ;;QUIT
