XU8P545.m

XU8P545 ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 8/12/10

 ;;8.0;KERNEL;**545**; July 10, 1995;Build 9

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

 Q

POST ;

 D UPDPSC ;update the Person Class file

 D SET741("N",741) ;update 741 to Non_individual taxonomy

 D DELXU8P ;delete the routine XU8P545A

 Q

 ;

UPDPSC ;

 D DEL ;clean entry 1163-1166 if existed

 D ADD ;add entry 1161 in the file

 D DEF^XU8P545A ;update definition for entries

 Q

 ;

DELXU8P ;Delete the routine XU8P545A

 N X S X="XU8P545A" X ^%ZOSF("DEL")

 Q

 ;

SET741(XUPRO,XUIEN) ;set/add Individual field by IEN

 I $G(XUPRO)="" Q

 I $G(XUIEN)'=+$G(XUIEN) Q

 N DR,DIE,DA S DR="90002///^S X=XUPRO",DIE="^USC(8932.1,",DA=XUIEN D ^DIE

 Q

ADD ;add the entry 1163 and 1166

 N XUDATA S XUDATA="1163^Respiratory, Rehabilitative and Restorative Service Provider^Mastectomy Fitter^^V130216^224900000X^^I"

 D ADD1(XUDATA)

 N XUDATA S XUDATA="1164^Respiratory, Rehabilitative and Restorative Service Providers^Pedorthist^^V130313^224L00000X^^I"

 D ADD1(XUDATA)

 N XUDATA S XUDATA="1165^Other Service Providers^Meals^^^174200000X^^N"

 D ADD1(XUDATA)

 N XUDATA S XUDATA="1166^Allopathic & Osteopathic Physicians^Orthopaedic Surgery^Pediatric Orthopaedic Surgery^V182107^207XP3100X^^I"

 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 entries

 N XU545,DIK,DA F XU545=1163:1:1166 S DIK="^USC(8932.1,",DA=XU545 D ^DIK

 Q

 ;

GET ;

 N XU545

 F XU545=1163:1:1166 D GET1(XU545)

 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

 ;

GETDATA ; get definitions

 N XUI,XUY

 F XUI=609,610,408,410,1095,1116,1163,1164,1165,1166 D

 . S XUY=$G(^USC(8932.1,XUI,11,0)),XUY=$P(XUY,"^",3)

 . I XUY>0 D GETDES(XUI,XUY)

 Q

 ;

GETDES(XUI,XUY) ; get single entry definition

 N XUA,XUB

 W !,XUI," ;"

 F XUA=1:1:XUY W !," ;;",$G(^USC(8932.1,XUI,11,XUA,0))

 W !," ;;END"

 Q

DEF ; Update definitions

 N XUI

 F XUI=609,610,408,410,1095,1116,1163,1164,1165,1166 D

 . D DEF1(XUI)

 Q

 ;

DEF1(XUI) ; Update definition for single entry XUI

 N XUI1,XUDATA,XUY

 K ^TMP($J,"XUBA")

 F XUY=1:1:100 S XUDATA=$T(@XUI+XUY) Q:XUDATA=" ;;END"  D 

 . S ^TMP($J,"XUBA",XUI,XUY,0)=$P(XUDATA,";;",2)

 S XUI1=XUI_","

 D WP^DIE(8932.1,XUI1,11,"K","^TMP($J,""XUBA"",XUI)")

 K ^TMP($J,"XUBA")

 Q

XU8P545   ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 8/12/10

 +1       ;;8.0;KERNEL;**545**; July 10, 1995;Build 9

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

 +3        QUIT 

POST      ;

 +1       ;update the Person Class file

           DO UPDPSC

 +2       ;update 741 to Non_individual taxonomy

           DO SET741("N",741)

 +3       ;delete the routine XU8P545A

           DO DELXU8P

 +4        QUIT 

 +5       ;

UPDPSC    ;

 +1       ;clean entry 1163-1166 if existed

           DO DEL

 +2       ;add entry 1161 in the file

           DO ADD

 +3       ;update definition for entries

           DO DEF^XU8P545A

 +4        QUIT 

 +5       ;

DELXU8P   ;Delete the routine XU8P545A

 +1        NEW X

           SET X="XU8P545A"

           XECUTE ^%ZOSF("DEL")

 +2        QUIT 

 +3       ;

SET741(XUPRO,XUIEN) ;set/add Individual field by IEN

 +1        IF $GET(XUPRO)=""

               QUIT 

 +2        IF $GET(XUIEN)'=+$GET(XUIEN)

               QUIT 

 +3        NEW DR,DIE,DA

           SET DR="90002///^S X=XUPRO"

           SET DIE="^USC(8932.1,"

           SET DA=XUIEN

           DO ^DIE

 +4        QUIT 

ADD       ;add the entry 1163 and 1166

 +1        NEW XUDATA

           SET XUDATA="1163^Respiratory, Rehabilitative and Restorative Service Provider^Mastectomy Fitter^^V130216^224900000X^^I"

 +2        DO ADD1(XUDATA)

 +3        NEW XUDATA

           SET XUDATA="1164^Respiratory, Rehabilitative and Restorative Service Providers^Pedorthist^^V130313^224L00000X^^I"

 +4        DO ADD1(XUDATA)

 +5        NEW XUDATA

           SET XUDATA="1165^Other Service Providers^Meals^^^174200000X^^N"

 +6        DO ADD1(XUDATA)

 +7        NEW XUDATA

           SET XUDATA="1166^Allopathic & Osteopathic Physicians^Orthopaedic Surgery^Pediatric Orthopaedic Surgery^V182107^207XP3100X^^I"

 +8        DO ADD1(XUDATA)

 +9        QUIT 

 +10      ;

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 entries

 +1        NEW XU545,DIK,DA

           FOR XU545=1163:1:1166

               SET DIK="^USC(8932.1,"

               SET DA=XU545

               DO ^DIK

 +2        QUIT 

 +3       ;

GET       ;

 +1        NEW XU545

 +2        FOR XU545=1163:1:1166

               DO GET1(XU545)

 +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       ;

GETDATA   ; get definitions

 +1        NEW XUI,XUY

 +2        FOR XUI=609,610,408,410,1095,1116,1163,1164,1165,1166

               Begin DoDot:1

 +3                SET XUY=$GET(^USC(8932.1,XUI,11,0))

                   SET XUY=$PIECE(XUY,"^",3)

 +4                IF XUY>0

                       DO GETDES(XUI,XUY)

               End DoDot:1

 +5        QUIT 

 +6       ;

GETDES(XUI,XUY) ; get single entry definition

 +1        NEW XUA,XUB

 +2        WRITE !,XUI," ;"

 +3        FOR XUA=1:1:XUY

               WRITE !," ;;",$GET(^USC(8932.1,XUI,11,XUA,0))

 +4        WRITE !," ;;END"

 +5        QUIT 

DEF       ; Update definitions

 +1        NEW XUI

 +2        FOR XUI=609,610,408,410,1095,1116,1163,1164,1165,1166

               Begin DoDot:1

 +3                DO DEF1(XUI)

               End DoDot:1

 +4        QUIT 

 +5       ;

DEF1(XUI) ; Update definition for single entry XUI

 +1        NEW XUI1,XUDATA,XUY

 +2        KILL ^TMP($JOB,"XUBA")

 +3        FOR XUY=1:1:100

               SET XUDATA=$TEXT(@XUI+XUY)

               IF XUDATA=" ;;END"

                   QUIT 

               Begin DoDot:1

 +4                SET ^TMP($JOB,"XUBA",XUI,XUY,0)=$PIECE(XUDATA,";;",2)

               End DoDot:1

 +5        SET XUI1=XUI_","

 +6        DO WP^DIE(8932.1,XUI1,11,"K","^TMP($J,""XUBA"",XUI)")

 +7        KILL ^TMP($JOB,"XUBA")

 +8        QUIT