MCPOS01C ;HIRMFO/WAA - Kill all cross reference in a file - ;4/29/96 11:05
;;2.3;Medicine;;09/13/1996
;;
F692 ; FILE 692
K ^MCAR(692,"B") ; "B" Cross
K ^MCAR(692,"C") ; EP Record
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(692,MCI)) Q:MCI<1 D
..D
...N MCII
...S MCII=0
...F S MCII=$O(^MCAR(692,MCI,6,MCII)) Q:MCII<1 D
....K ^MCAR(692,MCI,6,MCII,1,"B") ; "B" Cross
....Q
...Q
..Q
.Q
D EN1^MCPOS01(692)
F693 ; FILE 693
K ^MCAR(693,"B") ; "B" Cross
K ^MCAR(693,"C") ; SYNONYM
D EN1^MCPOS01(693)
F693P2 ; FILE 693.2
K ^MCAR(693.2,"B") ; "B" Cross
D EN1^MCPOS01(693.2)
F693P3 ; FILE 693.3
K ^MCAR(693.3,"B") ; "B" Cross
K ^MCAR(693.3,"C") ; Code Number
D EN1^MCPOS01(693.3)
F693P5 ; FILE 693.5
K ^MCAR(693.5,"B") ; "B" Cross
D EN1^MCPOS01(693.5)
F693P6 ; FILE 693.6
K ^MCAR(693.6,"B") ; "B" Cross
D EN1^MCPOS01(693.6)
F694 ; FILE 694
K ^MCAR(694,"B") ; "B" Cross
K ^MCAR(694,"C") ; Medical patient
K ^MCAR(694,"PCC") ; PCC Pointer
K ^MCAR(694,"ES") ; Release Code
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(694,MCI)) Q:MCI<1 D
..K ^MCAR(694,MCI,8,"B") ; "B" Cross
..K ^MCAR(694,MCI,10,"B") ; "B" Cross
..K ^MCAR(694,MCI,5,"B") ; "B" Cross
..K ^MCAR(694,MCI,2,"B") ; "B" Cross
..K ^MCAR(694,MCI,"ICD","B") ; "B" Cross
..K ^MCAR(694,MCI,2005,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(694)
F694P1 ; FILE 694.1
K ^MCAR(694.1,"B") ; "B" Cross
K ^MCAR(694.1,"C") ; Medical Type
D EN1^MCPOS01(694.1)
F694P5 ; FILE 694.5
K ^MCAR(694.5,"B") ; "B" Cross
K ^MCAR(694.5,"C") ; Patient
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(694.5,MCI)) Q:MCI<1 D
..K ^MCAR(694.5,MCI,11,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(694.5)
F694P9 ; FILE 694.8
K ^MCAR(694.8,"B") ; "B" Cross
K ^MCAR(694.8,"C") ; SYNONYM
K ^MCAR(694.8,"PAR") ; PARENT
K ^MCAR(684.8,"PS") ;Procedure/Subspecialty
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(694.8,MCI)) Q:MCI<1 D
..K ^MCAR(694.8,MCI,1,"B") ; "B" Cross
..K ^MCAR(694.8,MCI,3,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(694.8)
G F695^MCPOS01D
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS01C 2079 printed Nov 22, 2024@17:26:19 Page 2
MCPOS01C ;HIRMFO/WAA - Kill all cross reference in a file - ;4/29/96 11:05
+1 ;;2.3;Medicine;;09/13/1996
+2 ;;
F692 ; FILE 692
+1 ; "B" Cross
KILL ^MCAR(692,"B")
+2 ; EP Record
KILL ^MCAR(692,"C")
+3 Begin DoDot:1
+4 NEW MCI
+5 SET MCI=0
+6 FOR
SET MCI=$ORDER(^MCAR(692,MCI))
if MCI<1
QUIT
Begin DoDot:2
+7 Begin DoDot:3
+8 NEW MCII
+9 SET MCII=0
+10 FOR
SET MCII=$ORDER(^MCAR(692,MCI,6,MCII))
if MCII<1
QUIT
Begin DoDot:4
+11 ; "B" Cross
KILL ^MCAR(692,MCI,6,MCII,1,"B")
+12 QUIT
End DoDot:4
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 DO EN1^MCPOS01(692)
F693 ; FILE 693
+1 ; "B" Cross
KILL ^MCAR(693,"B")
+2 ; SYNONYM
KILL ^MCAR(693,"C")
+3 DO EN1^MCPOS01(693)
F693P2 ; FILE 693.2
+1 ; "B" Cross
KILL ^MCAR(693.2,"B")
+2 DO EN1^MCPOS01(693.2)
F693P3 ; FILE 693.3
+1 ; "B" Cross
KILL ^MCAR(693.3,"B")
+2 ; Code Number
KILL ^MCAR(693.3,"C")
+3 DO EN1^MCPOS01(693.3)
F693P5 ; FILE 693.5
+1 ; "B" Cross
KILL ^MCAR(693.5,"B")
+2 DO EN1^MCPOS01(693.5)
F693P6 ; FILE 693.6
+1 ; "B" Cross
KILL ^MCAR(693.6,"B")
+2 DO EN1^MCPOS01(693.6)
F694 ; FILE 694
+1 ; "B" Cross
KILL ^MCAR(694,"B")
+2 ; Medical patient
KILL ^MCAR(694,"C")
+3 ; PCC Pointer
KILL ^MCAR(694,"PCC")
+4 ; Release Code
KILL ^MCAR(694,"ES")
+5 Begin DoDot:1
+6 NEW MCI
+7 SET MCI=0
+8 FOR
SET MCI=$ORDER(^MCAR(694,MCI))
if MCI<1
QUIT
Begin DoDot:2
+9 ; "B" Cross
KILL ^MCAR(694,MCI,8,"B")
+10 ; "B" Cross
KILL ^MCAR(694,MCI,10,"B")
+11 ; "B" Cross
KILL ^MCAR(694,MCI,5,"B")
+12 ; "B" Cross
KILL ^MCAR(694,MCI,2,"B")
+13 ; "B" Cross
KILL ^MCAR(694,MCI,"ICD","B")
+14 ; "B" Cross
KILL ^MCAR(694,MCI,2005,"B")
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 DO EN1^MCPOS01(694)
F694P1 ; FILE 694.1
+1 ; "B" Cross
KILL ^MCAR(694.1,"B")
+2 ; Medical Type
KILL ^MCAR(694.1,"C")
+3 DO EN1^MCPOS01(694.1)
F694P5 ; FILE 694.5
+1 ; "B" Cross
KILL ^MCAR(694.5,"B")
+2 ; Patient
KILL ^MCAR(694.5,"C")
+3 Begin DoDot:1
+4 NEW MCI
+5 SET MCI=0
+6 FOR
SET MCI=$ORDER(^MCAR(694.5,MCI))
if MCI<1
QUIT
Begin DoDot:2
+7 ; "B" Cross
KILL ^MCAR(694.5,MCI,11,"B")
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 DO EN1^MCPOS01(694.5)
F694P9 ; FILE 694.8
+1 ; "B" Cross
KILL ^MCAR(694.8,"B")
+2 ; SYNONYM
KILL ^MCAR(694.8,"C")
+3 ; PARENT
KILL ^MCAR(694.8,"PAR")
+4 ;Procedure/Subspecialty
KILL ^MCAR(684.8,"PS")
+5 Begin DoDot:1
+6 NEW MCI
+7 SET MCI=0
+8 FOR
SET MCI=$ORDER(^MCAR(694.8,MCI))
if MCI<1
QUIT
Begin DoDot:2
+9 ; "B" Cross
KILL ^MCAR(694.8,MCI,1,"B")
+10 ; "B" Cross
KILL ^MCAR(694.8,MCI,3,"B")
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 DO EN1^MCPOS01(694.8)
+14 GOTO F695^MCPOS01D
