XU8P541.m

XU8P541 ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 4/28/10

 ;;8.0;KERNEL;**541**; July 10, 1995;Build 8

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

 Q

 ;

POST ;

 D ADDOP ;add a new option under the XUSER menu option

 D UPDPSC ;update the Person Class file

 D DELXU8P ;delete the routine XU8P541A

 Q

 ;

ADDOP ; Add a new option under the XUSER menu option.

 N XUA,XUB,XUC

 S XUA="XUSER"

 S XUB="XU-INACTIVE PERSON CLASS USERS"

 IF $$FIND1^DIC(19,,"X",XUA,,,),$$FIND1^DIC(19,,"X",XUB,,,) S XUC=$$ADD^XPDMENU(XUA,XUB,,)

 Q

 ;

UPDPSC ;

 D DEL ;clean entry 1161 if existed

 D ADD ;add entry 1161 in the file

 D DEF^XU8P541A ;update definition for entries

 Q

 ;

DELXU8P ;Delete the routine XU8P541A

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

 Q

 ;

ADD ;add the entry 1161 and 1162

 N XUDATA S XUDATA="1161^Transportation Services^Air Carrier^^^344800000X^^N"

 D ADD1(XUDATA)

 N XUDATA S XUDATA="1162^Technologists, Technicians & Other Technical Service^Perfusionist^^V151002^242T00000X^^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 entry

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

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

 Q

 ;

XU8P541   ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 4/28/10

 +1       ;;8.0;KERNEL;**541**; July 10, 1995;Build 8

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

 +3        QUIT 

 +4       ;

POST      ;

 +1       ;add a new option under the XUSER menu option

           DO ADDOP

 +2       ;update the Person Class file

           DO UPDPSC

 +3       ;delete the routine XU8P541A

           DO DELXU8P

 +4        QUIT 

 +5       ;

ADDOP     ; Add a new option under the XUSER menu option.

 +1        NEW XUA,XUB,XUC

 +2        SET XUA="XUSER"

 +3        SET XUB="XU-INACTIVE PERSON CLASS USERS"

 +4        IF $$FIND1^DIC(19,,"X",XUA,,,)

               IF $$FIND1^DIC(19,,"X",XUB,,,)

                   SET XUC=$$ADD^XPDMENU(XUA,XUB,,)

 +5        QUIT 

 +6       ;

UPDPSC    ;

 +1       ;clean entry 1161 if existed

           DO DEL

 +2       ;add entry 1161 in the file

           DO ADD

 +3       ;update definition for entries

           DO DEF^XU8P541A

 +4        QUIT 

 +5       ;

DELXU8P   ;Delete the routine XU8P541A

 +1        NEW X

           SET X="XU8P541A"

           XECUTE ^%ZOSF("DEL")

 +2        QUIT 

 +3       ;

ADD       ;add the entry 1161 and 1162

 +1        NEW XUDATA

           SET XUDATA="1161^Transportation Services^Air Carrier^^^344800000X^^N"

 +2        DO ADD1(XUDATA)

 +3        NEW XUDATA

           SET XUDATA="1162^Technologists, Technicians & Other Technical Service^Perfusionist^^V151002^242T00000X^^I"

 +4        DO ADD1(XUDATA)

 +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 DIK,DA

           SET DIK="^USC(8932.1,"

           SET DA=1161

           DO ^DIK

 +2        NEW DIK,DA

           SET DIK="^USC(8932.1,"

           SET DA=1162

           DO ^DIK

 +3        QUIT 

 +4       ;