SDPURG1 ;ALB/TMP - Purge-Print Routine ; 12/24/85
;;5.3;Scheduling;**132,478**;Aug 13, 1993
START U IO S (SDCT,POP)=0 W @IOF,!,"*** SCHEDULING PURGE IN PROCESS ***",! D NOW^%DTC
G:'SD44 SD2 W !,"Begin purge of Hospital Location File nodes " S Y=% D DT^DIQ S SDCT=0
F A=0:0 S A=$O(^SC(A)) D:'A ENDA Q:'A I $D(^(A,0)),$P(^(0),"^",3)="C" D A F B=0:0 S B=$O(^SC(A,"S",B)) Q:'B!(B'<SDLIM1) S DA(1)=A,DA=B,DIK="^SC("_DA(1)_",""S"",",X=DIK_B_")" D PRTS,^DIK K DIK W:'(SDCT#100)&('SDPR) "."
S SDCT=0 G 1010
A F B="C","OST","ST" F C=0:0 S C=$O(^SC(A,B,C)) Q:'C!(C'<SDLIM1) D MORE,DOT
Q
1010 F A=0:0 S A=$O(^SC("AAS",A)) W:'A !,SDCT," 10/10 AND UNSCHEDULED XREFS PURGED",!!,"End of Hospital Location purge" Q:'A F B=0:0 S B=$O(^SC("AAS",A,B)) Q:'B!(B'<SDLIM1) D MORE3 S X="^SC(""AAS"","_A_","_B_")" K @X D DOT
SD2 G:'SD2 END D NOW^%DTC S SDCT=0 G ^SDPURG2
DOT W:'(SDCT#100)&('SDPR) "." Q
SETA S $P(^SC(A,"S",0),"^",4)="",POP=1 Q
ENDA W !,SDCT," APPTS AND MISCELLANEOUS HOSPITAL LOCATION NODES DELETED" Q
PRTS S:'$D(^SC(A,"S",0)) ^(0)="^44.001DA^^" S:'$D(^SC(A,"S",B,1,0)) ^(0)="^44.003PA^^"
W:$D(^SC(A,"S",B,0))&(SDPR) !,$P(X,")")_",0) = ",^(0) F C=0:0 S C=$O(^SC(A,"S",B,1,C)) Q:'C W:SDPR !,$P(X,")")_",1,"_C_",0) = ",^(C,0) S SDCT=SDCT+1
Q
D ;K ^SC(A,"S",B) Q ;original line
S DA(1)=A,DA=B,DIK="^SC("_DA(1)_",""S""," D ^DIK Q
MORE S J=-1
I B["ST" F I=0:0 S J=$O(^SC(A,B,C,J)) Q:J="" S:'$D(^SC(A,B,0)) ^(0)="^"_$S(B="ST":"44.005",1:"44.002")_"DA^^" S X="^SC("_A_","""_B_""","_C_","_$S(+J=J:J,1:""""_J_"""")_")",POP=1 D KILL,CT S:B="OST"&('$D(^SC(A,"OST",C,0))) ^(0)=C
I B'["ST" S X="^SC("_A_","""_B_""","_C_",0)",POP=1 D KILL,CT F I=0:0 S I=$O(^SC(A,B,C,1,I)) Q:'I S X="^SC("_A_","""_B_""","_C_",1,"_I_",0)",POP=1 D KILL,CT
S DA(1)=A,DA=C,DIK="^SC("_DA(1)_","""_B_""",",X=DIK_C_")" D ^DIK K DIK Q
MORE3 F I=0:0 S I=$O(^SC("AAS",A,B,I)) Q:'I S POP=1,X="^SC(""AAS"","_A_","_B_","_I_")" D KILL,CT
Q
KILL I SDPR W:$S(($D(@X)#2):1,1:0) !,X," = ",@X
I POP S POP=0 Q
Q
CT S SDCT=SDCT+1 Q
D ^DIK Q
END W !!,"*** SCHEDULING PURGE COMPLETED *** " D NOW^%DTC S Y=% D DT^DIQ
I SD44!(SD2) W ! W:SD44 "Hospital Location " W:SD44&(SD2) "and " W:SD2 "Patient " W "file nodes have been purged through: " S X1=SDLIM1,X2=-1 D C^%DTC S Y=X D DT^DIQ
Q K A,B,C,D,E,F,I,J,SD44,SD2,SDC,SDLIM,SDLIM1,SDCT,SDPR,X,X1,X2,Y,POP,%,%Y D CLOSE^DGUTQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDPURG1 2369 printed Sep 23, 2025@20:36:48 Page 2
SDPURG1 ;ALB/TMP - Purge-Print Routine ; 12/24/85
+1 ;;5.3;Scheduling;**132,478**;Aug 13, 1993
START USE IO
SET (SDCT,POP)=0
WRITE @IOF,!,"*** SCHEDULING PURGE IN PROCESS ***",!
DO NOW^%DTC
+1 if 'SD44
GOTO SD2
WRITE !,"Begin purge of Hospital Location File nodes "
SET Y=%
DO DT^DIQ
SET SDCT=0
+2 FOR A=0:0
SET A=$ORDER(^SC(A))
if 'A
DO ENDA
if 'A
QUIT
IF $DATA(^(A,0))
IF $PIECE(^(0),"^",3)="C"
DO A
FOR B=0:0
SET B=$ORDER(^SC(A,"S",B))
if 'B!(B'<SDLIM1)
QUIT
SET DA(1)=A
SET DA=B
SET DIK="^SC("_DA(1)_",""S"","
SET X=DIK_B_")"
DO PRTS
DO ^DIK
KILL DIK
if '(SDCT#100)&('SDPR)
WRITE "."
+3 SET SDCT=0
GOTO 1010
A FOR B="C","OST","ST"
FOR C=0:0
SET C=$ORDER(^SC(A,B,C))
if 'C!(C'<SDLIM1)
QUIT
DO MORE
DO DOT
+1 QUIT
1010 FOR A=0:0
SET A=$ORDER(^SC("AAS",A))
if 'A
WRITE !,SDCT," 10/10 AND UNSCHEDULED XREFS PURGED",!!,"End of Hospital Location purge"
if 'A
QUIT
FOR B=0:0
SET B=$ORDER(^SC("AAS",A,B))
if 'B!(B'<SDLIM1)
QUIT
DO MORE3
SET X="^SC(""AAS"","_A_","_B_")"
KILL @X
DO DOT
SD2 if 'SD2
GOTO END
DO NOW^%DTC
SET SDCT=0
GOTO ^SDPURG2
DOT if '(SDCT#100)&('SDPR)
WRITE "."
QUIT
SETA SET $PIECE(^SC(A,"S",0),"^",4)=""
SET POP=1
QUIT
ENDA WRITE !,SDCT," APPTS AND MISCELLANEOUS HOSPITAL LOCATION NODES DELETED"
QUIT
PRTS if '$DATA(^SC(A,"S",0))
SET ^(0)="^44.001DA^^"
if '$DATA(^SC(A,"S",B,1,0))
SET ^(0)="^44.003PA^^"
+1 if $DATA(^SC(A,"S",B,0))&(SDPR)
WRITE !,$PIECE(X,")")_",0) = ",^(0)
FOR C=0:0
SET C=$ORDER(^SC(A,"S",B,1,C))
if 'C
QUIT
if SDPR
WRITE !,$PIECE(X,")")_",1,"_C_",0) = ",^(C,0)
SET SDCT=SDCT+1
+2 QUIT
D ;K ^SC(A,"S",B) Q ;original line
+1 SET DA(1)=A
SET DA=B
SET DIK="^SC("_DA(1)_",""S"","
DO ^DIK
QUIT
MORE SET J=-1
+1 IF B["ST"
FOR I=0:0
SET J=$ORDER(^SC(A,B,C,J))
if J=""
QUIT
if '$DATA(^SC(A,B,0))
SET ^(0)="^"_$SELECT(B="ST":"44.005",1:"44.002")_"DA^^"
SET X="^SC("_A_","""_B_""","_C_","_$SELECT(+J=J:J,1:""""_J_"""")_")"
SET POP=1
DO KILL
DO CT
if B="OST"&('$DATA(^SC(A,"OST",C,0)))
SET ^(0)=C
+2 IF B'["ST"
SET X="^SC("_A_","""_B_""","_C_",0)"
SET POP=1
DO KILL
DO CT
FOR I=0:0
SET I=$ORDER(^SC(A,B,C,1,I))
if 'I
QUIT
SET X="^SC("_A_","""_B_""","_C_",1,"_I_",0)"
SET POP=1
DO KILL
DO CT
+3 SET DA(1)=A
SET DA=C
SET DIK="^SC("_DA(1)_","""_B_""","
SET X=DIK_C_")"
DO ^DIK
KILL DIK
QUIT
MORE3 FOR I=0:0
SET I=$ORDER(^SC("AAS",A,B,I))
if 'I
QUIT
SET POP=1
SET X="^SC(""AAS"","_A_","_B_","_I_")"
DO KILL
DO CT
+1 QUIT
KILL IF SDPR
if $SELECT(($DATA(@X)#2)
WRITE !,X," = ",@X
+1 IF POP
SET POP=0
QUIT
+2 QUIT
CT SET SDCT=SDCT+1
QUIT
+1 DO ^DIK
QUIT
END WRITE !!,"*** SCHEDULING PURGE COMPLETED *** "
DO NOW^%DTC
SET Y=%
DO DT^DIQ
+1 IF SD44!(SD2)
WRITE !
if SD44
WRITE "Hospital Location "
if SD44&(SD2)
WRITE "and "
if SD2
WRITE "Patient "
WRITE "file nodes have been purged through: "
SET X1=SDLIM1
SET X2=-1
DO C^%DTC
SET Y=X
DO DT^DIQ
Q KILL A,B,C,D,E,F,I,J,SD44,SD2,SDC,SDLIM,SDLIM1,SDCT,SDPR,X,X1,X2,Y,POP,%,%Y
DO CLOSE^DGUTQ
QUIT
