XU8P545 ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 8/12/10
;;8.0;KERNEL;**545**; July 10, 1995;Build 5
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8P545 2866 printed Dec 13, 2024@02:08:08 Page 2
XU8P545 ; BA/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 8/12/10
+1 ;;8.0;KERNEL;**545**; July 10, 1995;Build 5
+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
