AFJXPPED ;FJ/CWS;NETWORK HEALTH EXCHANGE ONE-TIME PSUEDO,ZZ's,EMPLOYEE PURGE;11/8/95 ;2/22/96 13:58
;;5.1;Network Health Exchange;;Jan 23, 1996
START S U="^"
S ZTSAVE("*")="",ZTIO="",ZTRTN="ONE^AFJXPPED",ZTDESC="ONE-TIME PURGE PSUEDO,ZZs,EMPLOYEE-537010" D ^%ZTLOAD
Q
ONE ; Purge psuedos,employees,zz's
D THREE,FIVE ;CFB/SF/TUSC TO SPEED UP
Q
TWO S SS="" F S SS=$O(^AFJ(537010,"B",SS)),INT="" Q:SS="" F S INT=$O(^AFJ(537010,"B",SS,INT)) Q:INT="" D PSU
Q
PSU I SS["P"!(SS?5"0"4N) S DIK="^AFJ(537010,",DA=INT D ^DIK ;CFB/SF/TUSC INPLEMENT VHA DIR 96-0006
Q
THREE S SS="" F S SS=$O(^AFJ(537010,"B",SS)),INT="" Q:SS="" F S INT=$O(^AFJ(537010,"B",SS,INT)) Q:INT="" S NAM=$P($G(^AFJ(537010,INT,0)),U,3) D EMP,PSU,ZZZ,CHAR ;CFB/SF/TUSC TO SPEED UP
Q
EMP Q:$E(NAM,1,3)'="EEE"
S DIK="^AFJ(537010,",DA=INT D ^DIK
Q
FOUR S SS="" F S SS=$O(^AFJ(537010,"B",SS)),INT="" Q:SS="" F S INT=$O(^AFJ(537010,"B",SS,INT)) Q:INT="" S NAM=$P($G(^AFJ(537010,INT,0)),U,3) D ZZZ
Q
ZZZ Q:$E(NAM,1,2)'="ZZ"
S DIK="^AFJ(537010,",DA=INT D ^DIK
Q
FIVE S SS="" F S SS=$O(^AFJ(537010,"B",SS)),INT="" Q:SS="" S INT=$O(^AFJ(537010,"B",SS,INT)) Q:INT="" S INT1=INT F J=1:1 S INT1=$O(^AFJ(537010,"B",SS,INT1)) Q:INT1="" Q:J<1 D DUP
Q
DUP S DIK="^AFJ(537010,",DA=INT1 D ^DIK
Q
SIX S SS="" F S SS=$O(^AFJ(537010,"B",SS)),INT="" Q:SS="" F S INT=$O(^AFJ(537010,"B",SS,INT)) Q:INT="" D CHAR
Q
CHAR Q:SS?9N
S DIK="^AFJ(537010,",DA=INT D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HAFJXPPED 1471 printed Apr 09, 2024@21:20:53 Page 2
AFJXPPED ;FJ/CWS;NETWORK HEALTH EXCHANGE ONE-TIME PSUEDO,ZZ's,EMPLOYEE PURGE;11/8/95 ;2/22/96 13:58
+1 ;;5.1;Network Health Exchange;;Jan 23, 1996
START SET U="^"
+1 SET ZTSAVE("*")=""
SET ZTIO=""
SET ZTRTN="ONE^AFJXPPED"
SET ZTDESC="ONE-TIME PURGE PSUEDO,ZZs,EMPLOYEE-537010"
DO ^%ZTLOAD
+2 QUIT
ONE ; Purge psuedos,employees,zz's
+1 ;CFB/SF/TUSC TO SPEED UP
DO THREE
DO FIVE
+2 QUIT
TWO SET SS=""
FOR
SET SS=$ORDER(^AFJ(537010,"B",SS))
SET INT=""
if SS=""
QUIT
FOR
SET INT=$ORDER(^AFJ(537010,"B",SS,INT))
if INT=""
QUIT
DO PSU
+1 QUIT
PSU ;CFB/SF/TUSC INPLEMENT VHA DIR 96-0006
IF SS["P"!(SS?5"0"4N)
SET DIK="^AFJ(537010,"
SET DA=INT
DO ^DIK
+1 QUIT
THREE ;CFB/SF/TUSC TO SPEED UP
SET SS=""
FOR
SET SS=$ORDER(^AFJ(537010,"B",SS))
SET INT=""
if SS=""
QUIT
FOR
SET INT=$ORDER(^AFJ(537010,"B",SS,INT))
if INT=""
QUIT
SET NAM=$PIECE($GET(^AFJ(537010,INT,0)),U,3)
DO EMP
DO PSU
DO ZZZ
DO CHAR
+1 QUIT
EMP if $EXTRACT(NAM,1,3)'="EEE"
QUIT
+1 SET DIK="^AFJ(537010,"
SET DA=INT
DO ^DIK
+2 QUIT
FOUR SET SS=""
FOR
SET SS=$ORDER(^AFJ(537010,"B",SS))
SET INT=""
if SS=""
QUIT
FOR
SET INT=$ORDER(^AFJ(537010,"B",SS,INT))
if INT=""
QUIT
SET NAM=$PIECE($GET(^AFJ(537010,INT,0)),U,3)
DO ZZZ
+1 QUIT
ZZZ if $EXTRACT(NAM,1,2)'="ZZ"
QUIT
+1 SET DIK="^AFJ(537010,"
SET DA=INT
DO ^DIK
+2 QUIT
FIVE SET SS=""
FOR
SET SS=$ORDER(^AFJ(537010,"B",SS))
SET INT=""
if SS=""
QUIT
SET INT=$ORDER(^AFJ(537010,"B",SS,INT))
if INT=""
QUIT
SET INT1=INT
FOR J=1:1
SET INT1=$ORDER(^AFJ(537010,"B",SS,INT1))
if INT1=""
QUIT
if J<1
QUIT
DO DUP
+1 QUIT
DUP SET DIK="^AFJ(537010,"
SET DA=INT1
DO ^DIK
+1 QUIT
SIX SET SS=""
FOR
SET SS=$ORDER(^AFJ(537010,"B",SS))
SET INT=""
if SS=""
QUIT
FOR
SET INT=$ORDER(^AFJ(537010,"B",SS,INT))
if INT=""
QUIT
DO CHAR
+1 QUIT
CHAR if SS?9N
QUIT
+1 SET DIK="^AFJ(537010,"
SET DA=INT
DO ^DIK
+2 QUIT
