- DGYMTRT ;ALB/CAW/LD - Add new treating specialties ; 9/8/94
- ;;5.3;Registration;**39,1015**;Aug 13, 1993;Build 21
- 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
- DGYMTRT ;ALB/CAW/LD - Add new treating specialties ; 9/8/94
- +1 ;;5.3;Registration;**39,1015**;Aug 13, 1993;Build 21
- 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
