XU8P541 ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 4/28/10
;;8.0;KERNEL;**541**; July 10, 1995;Build 6
;;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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8P541 1633 printed Dec 13, 2024@02:08:06 Page 2
XU8P541 ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 4/28/10
+1 ;;8.0;KERNEL;**541**; July 10, 1995;Build 6
+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 ;
