XU8P509.m

XU8P509 ; BP/BDT - POST ROUTINE; 9/8/08

 ;;8.0;KERNEL;**509**;Jul 10, 1995;Build 10

 ;;"Per VHA Directive 2004-038, this routine should not be modified".

 Q

POST ; Post routine for XU*8*509

 D DEL ;delete entries 1137-1152 if they exist

 D ADD ;add entries 1137-1152

 D DEF^XU8P509A,DEF^XU8P509B ;modify definition texts

 D DEF^XU8P509C,DEF^XU8P509D ;add definition texts

 D DELXU8P ; delete routines XU8P509A,B,C,D

 Q

DELXU8P ;

 ;Delete the routine XU8P509A,B,C,D:

 N X F X="XU8P509A","XU8P509B","XU8P509C","XU8P509D" X ^%ZOSF("DEL")

 Q

 ;

ADD ; Add new entries from 1137-1152

 N XUI,XUDATA

 F XUI=1:1:16 S XUDATA=$T(DATA+XUI) Q:XUDATA=" ;;END"  D

 . S XUDATA=$P(XUDATA,";;",2) Q:XUDATA="END"

 . D ADD1(XUDATA)

 Q

 ;

ADD1(XUDATA) ; add single entry

 N FDA,FDAIEN,XUD

 S XUD=$G(XUDATA)

 S FDAIEN(1)=$P(XUD,"^")

 S FDA(8932.1,"+1,",.01)=$P(XUD,"^",2)

 S FDA(8932.1,"+1,",1)=$P(XUD,"^",3)

 S FDA(8932.1,"+1,",2)=$P(XUD,"^",4)

 S FDA(8932.1,"+1,",3)="a"

 S FDA(8932.1,"+1,",5)=$P(XUD,"^",5)

 S FDA(8932.1,"+1,",6)=$P(XUD,"^",6)

 S FDA(8932.1,"+1,",8)=$P(XUD,"^",7)

 S FDA(8932.1,"+1,",90002)=$P(XUD,"^",8)

 D UPDATE^DIE("","FDA","FDAIEN","ERR")

 Q

 ;

DEL ; Delete entry

 N XUI F XUI=1137:1:1152 D

 . N DIK,DA S DIK="^USC(8932.1,",DA=XUI D ^DIK

 Q

 ;

GET ;Get information of entries from the Person Class file

 N XUI

 F XUI=1137:1:1152 D GET1(XUI)

 Q

 ;

GET1(XUIEN) ; Get information of given entry from Person Class file.

 N XUI

 S XUI=$G(^USC(8932.1,XUIEN,0))

 S XUI=" ;;"_XUIEN_"^"_$P(XUI,"^",1,3)_"^"_$P(XUI,"^",6,9) W !,XUI

 Q

 ;

DATA ; information of entries from 1137-1152

 ;;1137^Allopathic & Osteopathic Physicians^Family Medicine^Sleep Medicine^V180707^207QS1201X^08

 ;;1138^Behavioral Health & Social Service Providers^Behavioral Analyst^^V010700^103K00000X

 ;;1139^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Gerontology^V130110^225XG0600X^67

 ;;1140^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Mental Health^V130111^225XM0800X^67

 ;;1141^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Physical Rehabilitation^V130112^225XP0019X^67

 ;;1142^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Environmental Modification^V130113^225XE0001X^67

 ;;1143^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Feeding, Eating & Swallowing^V130114^225XF0002X^67

 ;;1144^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Low Vision^V130115^225XL0004X^67

 ;;1145^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Feeding, Eating & Swallowing^V130116^224ZF0002X^67

 ;;1146^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Low Vision^V130117^224ZL0004X^67

 ;;1147^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Driving & Community Mobility^V130118^224ZR0403X^67

 ;;1148^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Environmental Modification^V130119^224ZE0001X^67

 ;;1149^Technologists, Technicians & Other Technical Service Providers^Radiology Practitioner Assistant^^V153000^243U00000X^

 ;;1150^Agencies^In Home Supportive Care^^^253Z00000X^^N

 ;;1151^Behavioral Health & Social Service Providers^Psychologist^Health Psychologist^V010422^103TH0004X^68

 ;;1152^Allopathic & Osteopathic Physicians^Physical Medicine & Rehabilitation^Hospice and Palliative Medicine^V182605^2081H0002X^25

 ;;END

XU8P509   ; BP/BDT - POST ROUTINE; 9/8/08

 +1       ;;8.0;KERNEL;**509**;Jul 10, 1995;Build 10

 +2       ;;"Per VHA Directive 2004-038, this routine should not be modified".

 +3        QUIT 

POST      ; Post routine for XU*8*509

 +1       ;delete entries 1137-1152 if they exist

           DO DEL

 +2       ;add entries 1137-1152

           DO ADD

 +3       ;modify definition texts

           DO DEF^XU8P509A

           DO DEF^XU8P509B

 +4       ;add definition texts

           DO DEF^XU8P509C

           DO DEF^XU8P509D

 +5       ; delete routines XU8P509A,B,C,D

           DO DELXU8P

 +6        QUIT 

DELXU8P   ;

 +1       ;Delete the routine XU8P509A,B,C,D:

 +2        NEW X

           FOR X="XU8P509A","XU8P509B","XU8P509C","XU8P509D"

               XECUTE ^%ZOSF("DEL")

 +3        QUIT 

 +4       ;

ADD       ; Add new entries from 1137-1152

 +1        NEW XUI,XUDATA

 +2        FOR XUI=1:1:16

               SET XUDATA=$TEXT(DATA+XUI)

               IF XUDATA=" ;;END"

                   QUIT 

               Begin DoDot:1

 +3                SET XUDATA=$PIECE(XUDATA,";;",2)

                   IF XUDATA="END"

                       QUIT 

 +4                DO ADD1(XUDATA)

               End DoDot:1

 +5        QUIT 

 +6       ;

ADD1(XUDATA) ; add single entry

 +1        NEW FDA,FDAIEN,XUD

 +2        SET XUD=$GET(XUDATA)

 +3        SET FDAIEN(1)=$PIECE(XUD,"^")

 +4        SET FDA(8932.1,"+1,",.01)=$PIECE(XUD,"^",2)

 +5        SET FDA(8932.1,"+1,",1)=$PIECE(XUD,"^",3)

 +6        SET FDA(8932.1,"+1,",2)=$PIECE(XUD,"^",4)

 +7        SET FDA(8932.1,"+1,",3)="a"

 +8        SET FDA(8932.1,"+1,",5)=$PIECE(XUD,"^",5)

 +9        SET FDA(8932.1,"+1,",6)=$PIECE(XUD,"^",6)

 +10       SET FDA(8932.1,"+1,",8)=$PIECE(XUD,"^",7)

 +11       SET FDA(8932.1,"+1,",90002)=$PIECE(XUD,"^",8)

 +12       DO UPDATE^DIE("","FDA","FDAIEN","ERR")

 +13       QUIT 

 +14      ;

DEL       ; Delete entry

 +1        NEW XUI

           FOR XUI=1137:1:1152

               Begin DoDot:1

 +2                NEW DIK,DA

                   SET DIK="^USC(8932.1,"

                   SET DA=XUI

                   DO ^DIK

               End DoDot:1

 +3        QUIT 

 +4       ;

GET       ;Get information of entries from the Person Class file

 +1        NEW XUI

 +2        FOR XUI=1137:1:1152

               DO GET1(XUI)

 +3        QUIT 

 +4       ;

GET1(XUIEN) ; Get information of given entry from Person Class file.

 +1        NEW XUI

 +2        SET XUI=$GET(^USC(8932.1,XUIEN,0))

 +3        SET XUI=" ;;"_XUIEN_"^"_$PIECE(XUI,"^",1,3)_"^"_$PIECE(XUI,"^",6,9)

           WRITE !,XUI

 +4        QUIT 

 +5       ;

DATA      ; information of entries from 1137-1152

 +1       ;;1137^Allopathic & Osteopathic Physicians^Family Medicine^Sleep Medicine^V180707^207QS1201X^08

 +2       ;;1138^Behavioral Health & Social Service Providers^Behavioral Analyst^^V010700^103K00000X

 +3       ;;1139^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Gerontology^V130110^225XG0600X^67

 +4       ;;1140^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Mental Health^V130111^225XM0800X^67

 +5       ;;1141^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Physical Rehabilitation^V130112^225XP0019X^67

 +6       ;;1142^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Environmental Modification^V130113^225XE0001X^67

 +7       ;;1143^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Feeding, Eating & Swallowing^V130114^225XF0002X^67

 +8       ;;1144^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapist^Low Vision^V130115^225XL0004X^67

 +9       ;;1145^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Feeding, Eating & Swallowing^V130116^224ZF0002X^67

 +10      ;;1146^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Low Vision^V130117^224ZL0004X^67

 +11      ;;1147^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Driving & Community Mobility^V130118^224ZR0403X^67

 +12      ;;1148^Respiratory, Rehabilitative and Restorative Service Providers^Occupational Therapy Assistant^Environmental Modification^V130119^224ZE0001X^67

 +13      ;;1149^Technologists, Technicians & Other Technical Service Providers^Radiology Practitioner Assistant^^V153000^243U00000X^

 +14      ;;1150^Agencies^In Home Supportive Care^^^253Z00000X^^N

 +15      ;;1151^Behavioral Health & Social Service Providers^Psychologist^Health Psychologist^V010422^103TH0004X^68

 +16      ;;1152^Allopathic & Osteopathic Physicians^Physical Medicine & Rehabilitation^Hospice and Palliative Medicine^V182605^2081H0002X^25

 +17      ;;END