- 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 Feb 19, 2025@00:26:28 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
