BDGPOST1.m

BDGPOST1 ; IHS/ANMC/LJF - PIMS POSTINIT ;  [ 01/22/2004  3:56 PM ]

 ;;5.3;PIMS;;APR 26, 2002

 ; post init code called by BDGPOST

 ;

 Q

 ;

PCCLINK ;EP; add primary facility to PCC Master Control file

 D BMES^XPDUTL("Adding PIMS to PCC Master Control file...")

 NEW DIV,FAC,PKG

 S DIV=$P($G(^DG(43,1,"GL")),U,3) Q:'DIV       ;no primary division

 S FAC=$P($G(^DG(40.8,+DIV,0)),U,7) Q:'FAC  ;no facility pointer

 Q:'$D(^APCCCTRL(FAC,0))                    ;not in PCC Master file

 S PKG=$O(^DIC(9.4,"C","PIMS",0)) Q:'PKG    ;no PIMS pkg on file

 Q:$D(^APCCCTRL(FAC,11,PKG,0))              ;already in PCC file

 ;

 NEW DIC,X,DD,DO,DLAYGO,DINUM,Y,DIE,DA,DR

 S DIC="^APCCCTRL("_FAC_",11,",X="PIMS",DINUM=PKG,DIC(0)="L"

 S DLAYGO=9001000.011,DIC("P")="9001000.011PA"

 D FILE^DICN Q:Y<1

 ;

 S DIE="^APCCCTRL("_FAC_",11,",DA=PKG,DA(1)=FAC

 S DR=".02///"_$S($P($G(^DG(43,1,9999999)),U,2)="Y":1,1:0)

 D ^DIE

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

PARAM ;EP; copy ADT parameters from file 43 to 9009020.1

 ; old data to stay until future patch

 ; Copies only if site has parameters set already

 ;

 D BMES^XPDUTL("Copying IHS ADT Parameter fields to new file...")

 ;

 NEW DIV,DATA,I,DIK

 S DIV=$P($G(^DG(43,1,"GL")),U,3) Q:'DIV       ;no primary division

 Q:$D(^BDGPAR(DIV,0))                          ;already set up

 ;

 S ^BDGPAR(DIV,0)=DIV,$P(^BDGPAR(0),U,3)=DIV

 S $P(^BDGPAR(0),U,4)=$P(^BDGPAR(0),U,4)+1

 ;

 S DATA=$G(^DG(43,1,9999999)) I DATA]"" D

 . F I="5;5","6;2" S $P(^BDGPAR(DIV,0),U,$P(I,";",2))=$P(DATA,U,+I)

 ;

 S DATA=$G(^DG(43,1,9999999.01)) I DATA]"" D

 . F I="1;10","2;1","3;2","4;3","5;4","6;6","7;8" D

 .. S $P(^BDGPAR(DIV,1),U,$P(I,";",2))=$P(DATA,U,+I)

 ;

 S DATA=$G(^DG(43,1,9999999.02)) I DATA]"" D

 . F I="1;5;1","2;7;1","3;12;0","4;8;0" D

 .. S $P(^BDGPAR(DIV,$P(I,";",3)),U,$P(I,";",2))=$P(DATA,U,+I)

 ;

 ;IHS/ITSC/LJF 1/9/2004 convert Y/N answers to 1/0 answers

 S DATA=$G(^BDGPAR(DIV,1)) I DATA]"" F I=1:1:14 D  S ^BDGPAR(DIV,1)=DATA

 . I $P(DATA,U,I)="Y" S $P(DATA,U,I)=1

 . I $P(DATA,U,I)="N" S $P(DATA,U,I)=0

 ;

 ;IHS/ITSC/WAR 6/18/03 - Added code to update the 'VERSION' node in

 ;   DG(43,  This uses the 'C' xref in the pkg file.

 S DATA=$$VERSION^XPDUTL("PIMS") I DATA]"" D

 . S ^DG(43,1,"VERSION")=DATA

 ;

 S DIK="^BDGPAR(" D IXALL^DIK

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

 ;IHS/ITSC/WAR 10/17/03 added - updates the ADT ver# in pkg file

 ;IHS/ITSC/LJF 1/16/2004 added more updates

PKGFILE ;EP

 NEW VER,BDGV,BDGN,X,DA,DIC,Y,DIE,DR

 I $D(XPDNM) S VER=$$VER^XPDUTL(XPDNM)

 I $G(VER)]"" D

 .; update current version field

 .S BDGN=$O(^DIC(9.4,"C","DG",0)) Q:'BDGN

 .S ^DIC(9.4,BDGN,"VERSION")=VER

 .;

 .; clean up old 5.3 test versions

 .S BDGV=0 F  S BDGV=$O(^DIC(9.4,BDGN,22,"B",BDGV)) Q:BDGV=""  D

 ..I BDGV["5.3",BDGV'=5.3 D

 ...S DIE="^DIC(9.4,"_BDGN_",22,",DA(1)=BDGN,DR=".01///@"

 ...S DA=$O(^DIC(9.4,BDGN,22,"B",BDGV,0)) Q:'DA

 ...D ^DIE

 .;

 .; now add version multiple without test version #

 .S DIC="^DIC(9.4,"_BDGN_",22,",DIC(0)="L",X=5.3

 .S DIC("P")=$P(^DD(9.4,22,0),U,2)

 .S DIC("DR")="2///"_DT_";3///`"_DUZ,DA(1)=BDGN

 .D ^DIC

 ;

 D PATCHES^BDGPOST5   ;add patch history

 Q

CHRTDEF ;EP; copy chart deficiency items to new file   

 ; ^ADGCD( -> ^BDGCD(  will keep old data until future patch

 ;

 Q:$O(^BDGCD(0))               ;already has data

 ;

 D BMES^XPDUTL("Copying Chart Deficiency entries to new file...")

 NEW IEN,DIK

 S IEN=0 F  S IEN=$O(^ADGCD(IEN)) Q:'IEN  D

 . Q:$G(^ADGCD(IEN,0))=""     ;bad entry

 . S ^BDGCD(IEN,0)=^ADGCD(IEN,0)

 ;

 ; set zero node of file

 S $P(^BDGCD(0),U,3,4)=$P(^ADGCD(0),U,3,4)

 ; index file

 S DIK="^BDGCD(" D IXALL^DIK

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

OLDFILES ;EP; change name of old files where new file uses same name

 D BMES^XPDUTL("Changing name of obsolete files...")

 NEW DIE,DA,DR,X

 S DIE="^DIC("

 F DA=9009011,9009011.5,9009013,9009013.1,9009013.5,9009015 D

 . S X=$P($G(^DIC(DA,0)),U) Q:X=""  Q:X["-OLD"

 . S DR=".01///"_X_"-OLD"

 . D ^DIE

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

ADTTMPL ;EP; edit ADT Template entries that could not pass via KIDS

 D BMES^XPDUTL("Fixing ADT Template entries...")

 NEW DGEDIT,DA,DIE,DR

 S DGEDIT="",DIE=43.7

 S DA=2,DR="6///DG SI LIST" D ^DIE

 S DA=3,DR="6///DG FEMALE INPATIENTS" D ^DIE

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

FACMOV ;EP; add new facility movement type (WARD TRANSFER ONLY)

 ; used when adding ward transfers non-interactively

 Q:$D(^DG(405.1,"B","WARD TRANSFER ONLY"))

 D BMES^XPDUTL("Adding WARD TRANSFER ONLY to file 405.1...")

 NEW DIC,DD,DO,X,DLAYGO,DA,Y

 S DIC="^DG(405.1,",X="WARD TRANSFER ONLY",DIC(0)="L",DLAYGO=405.1

 S DIC("DR")=".02///2;.03///INTERWARD TRANSFER;.04///1;.05///0"

 D FILE^DICN K DIC

 I Y<1 K X S X=$$REPEAT^XLFSTR(" ",10)_"Error adding to file 405.1." D MES^XPDUTL(.X) Q

 ;

 S DIC="^DG(405.1,"_(+Y)_",""F"",",DA(1)=+Y,DIC(0)="L",DLAYGO=405.11

 S DIC("P")="405.11PA"

 F BDG=1:1:8 S X=$P($T(MOV+BDG),";;",2) D ^DIC

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

MOV ;;

 ;;DIRECT;;

 ;;TRANS-NON IHS HOSPITAL;;

 ;;TRANS-IHS HOSPITAL;;

 ;;REFERRED FROM IHS CLINIC;;

 ;;OTHER;;

 ;;PROVIDER/SPECIALTY CHANGE;;

 ;;INTERWARD TRANSFER;;

 ;;WARD TRANSFER ONLY;;

 ;

 ;

TRSPEC ;EP; add treating specialty entries

 ;  1. add inpatient ones if not in file

 ;  2. add observation ones

 D BMES^XPDUTL("Adding Observation Treating Specialties...")

 NEW IEN,CODE

 S (DIC,DLAYGO)=45.7,DIC(0)="L"

 F BDGI=1:1:41 S CODE=$P($T(TS+BDGI),";;",2) D

 . I $O(^DIC(45.7,"CIHS",CODE,0)) Q    ;already has service

 . K DD,DO S X=$P($T(TS+BDGI),";;",3),ABBRV=$P($T(TS+BDGI),";;",4)

 . S DIC("DR")="9999999.01///"_CODE_";99///"_ABBRV D FILE^DICN

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

TS ;; Inpatient Treating Specialties

 ;;01;;DENTAL;;DEN;;

 ;;02;;OTOLARYNGOLOGY;;ENT;;

 ;;03;;GENERAL MEDICINE;;GMED;;

 ;;04;;GENERAL SURGERY;;SUR;;

 ;;05;;GYNECOLOGY;;GYN;;

 ;;06;;INTERNAL MEDICINE;;IMED;;

 ;;07;;NEWBORN;;NEW;;

 ;;08;;OBSTETRICS;;OB;;

 ;;09;;OPHTHALMOLOGY;;EYE;;

 ;;10;;ORTHOPEDICS;;ORTHO;;

 ;;11;;PEDIATRICS;;PEDS;;

 ;;12;;PSYCHIATRIC MENTAL HEALTH;;PSYCH;;

 ;;13;;TUBERCULOSIS;;TB;;

 ;;14;;OTHER;;OTHER;;

 ;;15;;ALCOHOL/SUBSTANCE ABUSE;;ALCOH;;

 ;;16;;PLASTIC SURGERY;;PSUR;;

 ;;17;;FAMILY PRACTICE;;FAMP;;

 ;;18;;UROLOGY;;URO;;

 ;;19;;PODIATRY;;POD;;

 ;;20;;NEUROLOGY;;NEURO;;

 ;;21;;SWING BED;;SWING;;

 ;;22;;NURSE-MIDWIFERY SERVICE;;NRSMW;;

 ;;01O;;DENTAL OBSERVATION;;DENO;;

 ;;02O;;ENT OBSERVATION;;ENTO;;

 ;;03O;;MEDICINE OBSERVATION;;MEDO;;

 ;;04O;;SURGERY OBSERVATION;;SURO;;

 ;;05O;;GYN OBSERVATION;;GYNO;;

 ;;06O;;INTERNAL MED OBSERVATION;;IMEDO;;

 ;;08O;;OBSTETRICS OBSERVATION;;OBO;;

 ;;09O;;OPHTHALMOLOGY OBSERVATION;;EYEO;;

 ;;10O;;ORTHOPEDICS OBSERVATION;;ORTO;;

 ;;11O;;PEDIATRICS OBSERVATION;;PEDO;;

 ;;12O;;MENTAL HEALTH OBSERVATION;;MHO;;

 ;;13O;;TUBERCULOSIS OBSERVATION;;TBO;;

 ;;15O;;SUBSTANCE ABUSE OBSERVATION;;ALCOO;;

 ;;16O;;PLASTIC SURGERY OBSERVATION;;PSURO;;

 ;;17O;;FAMILY PRACTICE OBSERVATION;;FAMPO;;

 ;;18O;;UROLOGY OBSERVATION;;UROO;;

 ;;19O;;PODIATRY OBSERVATION;;PODO;;

 ;;20O;;NEUROLOGY OBSERVATION;;NEUOB;;

 ;;22O;;NURSE-MIDWIFERY OBSERVATION;;NRSOB;;

BDGPOST1  ; IHS/ANMC/LJF - PIMS POSTINIT ;  [ 01/22/2004  3:56 PM ]

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ; post init code called by BDGPOST

 +3       ;

 +4        QUIT 

 +5       ;

PCCLINK   ;EP; add primary facility to PCC Master Control file

 +1        DO BMES^XPDUTL("Adding PIMS to PCC Master Control file...")

 +2        NEW DIV,FAC,PKG

 +3       ;no primary division

           SET DIV=$PIECE($GET(^DG(43,1,"GL")),U,3)

           IF 'DIV

               QUIT 

 +4       ;no facility pointer

           SET FAC=$PIECE($GET(^DG(40.8,+DIV,0)),U,7)

           IF 'FAC

               QUIT 

 +5       ;not in PCC Master file

           IF '$DATA(^APCCCTRL(FAC,0))

               QUIT 

 +6       ;no PIMS pkg on file

           SET PKG=$ORDER(^DIC(9.4,"C","PIMS",0))

           IF 'PKG

               QUIT 

 +7       ;already in PCC file

           IF $DATA(^APCCCTRL(FAC,11,PKG,0))

               QUIT 

 +8       ;

 +9        NEW DIC,X,DD,DO,DLAYGO,DINUM,Y,DIE,DA,DR

 +10       SET DIC="^APCCCTRL("_FAC_",11,"

           SET X="PIMS"

           SET DINUM=PKG

           SET DIC(0)="L"

 +11       SET DLAYGO=9001000.011

           SET DIC("P")="9001000.011PA"

 +12       DO FILE^DICN

           IF Y<1

               QUIT 

 +13      ;

 +14       SET DIE="^APCCCTRL("_FAC_",11,"

           SET DA=PKG

           SET DA(1)=FAC

 +15       SET DR=".02///"_$SELECT($PIECE($GET(^DG(43,1,9999999)),U,2)="Y":1,1:0)

 +16       DO ^DIE

 +17       KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +18       QUIT 

 +19      ;

PARAM     ;EP; copy ADT parameters from file 43 to 9009020.1

 +1       ; old data to stay until future patch

 +2       ; Copies only if site has parameters set already

 +3       ;

 +4        DO BMES^XPDUTL("Copying IHS ADT Parameter fields to new file...")

 +5       ;

 +6        NEW DIV,DATA,I,DIK

 +7       ;no primary division

           SET DIV=$PIECE($GET(^DG(43,1,"GL")),U,3)

           IF 'DIV

               QUIT 

 +8       ;already set up

           IF $DATA(^BDGPAR(DIV,0))

               QUIT 

 +9       ;

 +10       SET ^BDGPAR(DIV,0)=DIV

           SET $PIECE(^BDGPAR(0),U,3)=DIV

 +11       SET $PIECE(^BDGPAR(0),U,4)=$PIECE(^BDGPAR(0),U,4)+1

 +12      ;

 +13       SET DATA=$GET(^DG(43,1,9999999))

           IF DATA]""

               Begin DoDot:1

 +14               FOR I="5;5","6;2"

                       SET $PIECE(^BDGPAR(DIV,0),U,$PIECE(I,";",2))=$PIECE(DATA,U,+I)

               End DoDot:1

 +15      ;

 +16       SET DATA=$GET(^DG(43,1,9999999.01))

           IF DATA]""

               Begin DoDot:1

 +17               FOR I="1;10","2;1","3;2","4;3","5;4","6;6","7;8"

                       Begin DoDot:2

 +18                       SET $PIECE(^BDGPAR(DIV,1),U,$PIECE(I,";",2))=$PIECE(DATA,U,+I)

                       End DoDot:2

               End DoDot:1

 +19      ;

 +20       SET DATA=$GET(^DG(43,1,9999999.02))

           IF DATA]""

               Begin DoDot:1

 +21               FOR I="1;5;1","2;7;1","3;12;0","4;8;0"

                       Begin DoDot:2

 +22                       SET $PIECE(^BDGPAR(DIV,$PIECE(I,";",3)),U,$PIECE(I,";",2))=$PIECE(DATA,U,+I)

                       End DoDot:2

               End DoDot:1

 +23      ;

 +24      ;IHS/ITSC/LJF 1/9/2004 convert Y/N answers to 1/0 answers

 +25       SET DATA=$GET(^BDGPAR(DIV,1))

           IF DATA]""

               FOR I=1:1:14

                   Begin DoDot:1

 +26                   IF $PIECE(DATA,U,I)="Y"

                           SET $PIECE(DATA,U,I)=1

 +27                   IF $PIECE(DATA,U,I)="N"

                           SET $PIECE(DATA,U,I)=0

                   End DoDot:1

                   SET ^BDGPAR(DIV,1)=DATA

 +28      ;

 +29      ;IHS/ITSC/WAR 6/18/03 - Added code to update the 'VERSION' node in

 +30      ;   DG(43,  This uses the 'C' xref in the pkg file.

 +31       SET DATA=$$VERSION^XPDUTL("PIMS")

           IF DATA]""

               Begin DoDot:1

 +32               SET ^DG(43,1,"VERSION")=DATA

               End DoDot:1

 +33      ;

 +34       SET DIK="^BDGPAR("

           DO IXALL^DIK

 +35       KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +36       QUIT 

 +37      ;

 +38      ;IHS/ITSC/WAR 10/17/03 added - updates the ADT ver# in pkg file

 +39      ;IHS/ITSC/LJF 1/16/2004 added more updates

PKGFILE   ;EP

 +1        NEW VER,BDGV,BDGN,X,DA,DIC,Y,DIE,DR

 +2        IF $DATA(XPDNM)

               SET VER=$$VER^XPDUTL(XPDNM)

 +3        IF $GET(VER)]""

               Begin DoDot:1

 +4       ; update current version field

 +5                SET BDGN=$ORDER(^DIC(9.4,"C","DG",0))

                   IF 'BDGN

                       QUIT 

 +6                SET ^DIC(9.4,BDGN,"VERSION")=VER

 +7       ;

 +8       ; clean up old 5.3 test versions

 +9                SET BDGV=0

                   FOR 

                       SET BDGV=$ORDER(^DIC(9.4,BDGN,22,"B",BDGV))

                       IF BDGV=""

                           QUIT 

                       Begin DoDot:2

 +10                       IF BDGV["5.3"

                               IF BDGV'=5.3

                                   Begin DoDot:3

 +11                                   SET DIE="^DIC(9.4,"_BDGN_",22,"

                                       SET DA(1)=BDGN

                                       SET DR=".01///@"

 +12                                   SET DA=$ORDER(^DIC(9.4,BDGN,22,"B",BDGV,0))

                                       IF 'DA

                                           QUIT 

 +13                                   DO ^DIE

                                   End DoDot:3

                       End DoDot:2

 +14      ;

 +15      ; now add version multiple without test version #

 +16               SET DIC="^DIC(9.4,"_BDGN_",22,"

                   SET DIC(0)="L"

                   SET X=5.3

 +17               SET DIC("P")=$PIECE(^DD(9.4,22,0),U,2)

 +18               SET DIC("DR")="2///"_DT_";3///`"_DUZ

                   SET DA(1)=BDGN

 +19               DO ^DIC

               End DoDot:1

 +20      ;

 +21      ;add patch history

           DO PATCHES^BDGPOST5

 +22       QUIT 

CHRTDEF   ;EP; copy chart deficiency items to new file   

 +1       ; ^ADGCD( -> ^BDGCD(  will keep old data until future patch

 +2       ;

 +3       ;already has data

           IF $ORDER(^BDGCD(0))

               QUIT 

 +4       ;

 +5        DO BMES^XPDUTL("Copying Chart Deficiency entries to new file...")

 +6        NEW IEN,DIK

 +7        SET IEN=0

           FOR 

               SET IEN=$ORDER(^ADGCD(IEN))

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +8       ;bad entry

                   IF $GET(^ADGCD(IEN,0))=""

                       QUIT 

 +9                SET ^BDGCD(IEN,0)=^ADGCD(IEN,0)

               End DoDot:1

 +10      ;

 +11      ; set zero node of file

 +12       SET $PIECE(^BDGCD(0),U,3,4)=$PIECE(^ADGCD(0),U,3,4)

 +13      ; index file

 +14       SET DIK="^BDGCD("

           DO IXALL^DIK

 +15       KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +16       QUIT 

 +17      ;

OLDFILES  ;EP; change name of old files where new file uses same name

 +1        DO BMES^XPDUTL("Changing name of obsolete files...")

 +2        NEW DIE,DA,DR,X

 +3        SET DIE="^DIC("

 +4        FOR DA=9009011,9009011.5,9009013,9009013.1,9009013.5,9009015

               Begin DoDot:1

 +5                SET X=$PIECE($GET(^DIC(DA,0)),U)

                   IF X=""

                       QUIT 

                   IF X["-OLD"

                       QUIT 

 +6                SET DR=".01///"_X_"-OLD"

 +7                DO ^DIE

               End DoDot:1

 +8        KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +9        QUIT 

 +10      ;

ADTTMPL   ;EP; edit ADT Template entries that could not pass via KIDS

 +1        DO BMES^XPDUTL("Fixing ADT Template entries...")

 +2        NEW DGEDIT,DA,DIE,DR

 +3        SET DGEDIT=""

           SET DIE=43.7

 +4        SET DA=2

           SET DR="6///DG SI LIST"

           DO ^DIE

 +5        SET DA=3

           SET DR="6///DG FEMALE INPATIENTS"

           DO ^DIE

 +6        KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +7        QUIT 

 +8       ;

FACMOV    ;EP; add new facility movement type (WARD TRANSFER ONLY)

 +1       ; used when adding ward transfers non-interactively

 +2        IF $DATA(^DG(405.1,"B","WARD TRANSFER ONLY"))

               QUIT 

 +3        DO BMES^XPDUTL("Adding WARD TRANSFER ONLY to file 405.1...")

 +4        NEW DIC,DD,DO,X,DLAYGO,DA,Y

 +5        SET DIC="^DG(405.1,"

           SET X="WARD TRANSFER ONLY"

           SET DIC(0)="L"

           SET DLAYGO=405.1

 +6        SET DIC("DR")=".02///2;.03///INTERWARD TRANSFER;.04///1;.05///0"

 +7        DO FILE^DICN

           KILL DIC

 +8        IF Y<1

               KILL X

               SET X=$$REPEAT^XLFSTR(" ",10)_"Error adding to file 405.1."

               DO MES^XPDUTL(.X)

               QUIT 

 +9       ;

 +10       SET DIC="^DG(405.1,"_(+Y)_",""F"","

           SET DA(1)=+Y

           SET DIC(0)="L"

           SET DLAYGO=405.11

 +11       SET DIC("P")="405.11PA"

 +12       FOR BDG=1:1:8

               SET X=$PIECE($TEXT(MOV+BDG),";;",2)

               DO ^DIC

 +13       KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +14       QUIT 

 +15      ;

MOV       ;;

 +1       ;;DIRECT;;

 +2       ;;TRANS-NON IHS HOSPITAL;;

 +3       ;;TRANS-IHS HOSPITAL;;

 +4       ;;REFERRED FROM IHS CLINIC;;

 +5       ;;OTHER;;

 +6       ;;PROVIDER/SPECIALTY CHANGE;;

 +7       ;;INTERWARD TRANSFER;;

 +8       ;;WARD TRANSFER ONLY;;

 +9       ;

 +10      ;

TRSPEC    ;EP; add treating specialty entries

 +1       ;  1. add inpatient ones if not in file

 +2       ;  2. add observation ones

 +3        DO BMES^XPDUTL("Adding Observation Treating Specialties...")

 +4        NEW IEN,CODE

 +5        SET (DIC,DLAYGO)=45.7

           SET DIC(0)="L"

 +6        FOR BDGI=1:1:41

               SET CODE=$PIECE($TEXT(TS+BDGI),";;",2)

               Begin DoDot:1

 +7       ;already has service

                   IF $ORDER(^DIC(45.7,"CIHS",CODE,0))

                       QUIT 

 +8                KILL DD,DO

                   SET X=$PIECE($TEXT(TS+BDGI),";;",3)

                   SET ABBRV=$PIECE($TEXT(TS+BDGI),";;",4)

 +9                SET DIC("DR")="9999999.01///"_CODE_";99///"_ABBRV

                   DO FILE^DICN

               End DoDot:1

 +10       KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +11       QUIT 

 +12      ;

TS        ;; Inpatient Treating Specialties

 +1       ;;01;;DENTAL;;DEN;;

 +2       ;;02;;OTOLARYNGOLOGY;;ENT;;

 +3       ;;03;;GENERAL MEDICINE;;GMED;;

 +4       ;;04;;GENERAL SURGERY;;SUR;;

 +5       ;;05;;GYNECOLOGY;;GYN;;

 +6       ;;06;;INTERNAL MEDICINE;;IMED;;

 +7       ;;07;;NEWBORN;;NEW;;

 +8       ;;08;;OBSTETRICS;;OB;;

 +9       ;;09;;OPHTHALMOLOGY;;EYE;;

 +10      ;;10;;ORTHOPEDICS;;ORTHO;;

 +11      ;;11;;PEDIATRICS;;PEDS;;

 +12      ;;12;;PSYCHIATRIC MENTAL HEALTH;;PSYCH;;

 +13      ;;13;;TUBERCULOSIS;;TB;;

 +14      ;;14;;OTHER;;OTHER;;

 +15      ;;15;;ALCOHOL/SUBSTANCE ABUSE;;ALCOH;;

 +16      ;;16;;PLASTIC SURGERY;;PSUR;;

 +17      ;;17;;FAMILY PRACTICE;;FAMP;;

 +18      ;;18;;UROLOGY;;URO;;

 +19      ;;19;;PODIATRY;;POD;;

 +20      ;;20;;NEUROLOGY;;NEURO;;

 +21      ;;21;;SWING BED;;SWING;;

 +22      ;;22;;NURSE-MIDWIFERY SERVICE;;NRSMW;;

 +23      ;;01O;;DENTAL OBSERVATION;;DENO;;

 +24      ;;02O;;ENT OBSERVATION;;ENTO;;

 +25      ;;03O;;MEDICINE OBSERVATION;;MEDO;;

 +26      ;;04O;;SURGERY OBSERVATION;;SURO;;

 +27      ;;05O;;GYN OBSERVATION;;GYNO;;

 +28      ;;06O;;INTERNAL MED OBSERVATION;;IMEDO;;

 +29      ;;08O;;OBSTETRICS OBSERVATION;;OBO;;

 +30      ;;09O;;OPHTHALMOLOGY OBSERVATION;;EYEO;;

 +31      ;;10O;;ORTHOPEDICS OBSERVATION;;ORTO;;

 +32      ;;11O;;PEDIATRICS OBSERVATION;;PEDO;;

 +33      ;;12O;;MENTAL HEALTH OBSERVATION;;MHO;;

 +34      ;;13O;;TUBERCULOSIS OBSERVATION;;TBO;;

 +35      ;;15O;;SUBSTANCE ABUSE OBSERVATION;;ALCOO;;

 +36      ;;16O;;PLASTIC SURGERY OBSERVATION;;PSURO;;

 +37      ;;17O;;FAMILY PRACTICE OBSERVATION;;FAMPO;;

 +38      ;;18O;;UROLOGY OBSERVATION;;UROO;;

 +39      ;;19O;;PODIATRY OBSERVATION;;PODO;;

 +40      ;;20O;;NEUROLOGY OBSERVATION;;NEUOB;;

 +41      ;;22O;;NURSE-MIDWIFERY OBSERVATION;;NRSOB;;