MCPOS01F ;HIRMFO/WAA - Kill all cross reference in a file - ;4/29/96 14:53
;;2.3;Medicine;;09/13/1996
;;
F699 ; FILE 699
K ^MCAR(699,"B") ; "B" Cross
K ^MCAR(699,"C") ; Medical patient
K ^MCAR(699,"D") ; Procedure
K ^MCAR(699,"AC") ; Endoscopist
K ^MCAR(699,"ACE") ; Endoscopist
K ^MCAR(699,"AD") ; Where performed
K ^MCAR(699,"PCC") ; PCC Pointer
K ^MCAR(699,"ES") ; Release code
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(699,MCI)) Q:MCI<1 D
..K ^MCAR(699,MCI,1,"B") ; "B" Cross
..K ^MCAR(699,MCI,3,"B") ; "B" Cross
..K ^MCAR(699,MCI,28,"B") ; "B" Cross
..K ^MCAR(699,MCI,25,"B") ; "B" Cross
..K ^MCAR(699,MCI,27,"B") ; "B" Cross
..K ^MCAR(699,MCI,30,"B") ; "B" Cross
..D
...N MCII
...S MCII=0
...F S MCII=$O(^MCAR(699,MCI,30,MCII)) Q:MCII<1 D
....K ^MCAR(699,MCI,30,MCII,1,"B") ; "B" Cross
....K ^MCAR(699,MCI,30,MCII,2,"B") ; "B" Cross
....K ^MCAR(699,MCI,30,MCII,3,"B") ; "B" Cross
....Q
...Q
..K ^MCAR(699,MCI,10,"B") ; "B" Cross
..K ^MCAR(699,MCI,11,"B") ; "B" Cross
..K ^MCAR(699,MCI,"IDC","B") ; "B" Cross
..K ^MCAR(699,MCI,2005,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(699)
F699P48 ; FILE 699.48
K ^MCAR(699.48,"B") ; "B" Cross
K ^MCAR(699.48,"C") ; Medical package use
D EN1^MCPOS01(699.48)
F699P5 ; FILE 699.5
K ^MCAR(699.5,"B") ; "B" Cross
K ^MCAR(699.5,"C") ; Medical Patient
K ^MCAR(699.5,"D") ; Subspecialty
K ^MCAR(699.5,"PCC") ; PCC Pointer
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(699.5,MCI)) Q:MCI<1 D
..K ^MCAR(699.5,MCI,4,"B") ; "B" Cross
..K ^MCAR(699.5,MCI,2,"B") ; "B" Cross
..K ^MCAR(699.5,MCI,3,"B") ; "B" Cross
..K ^MCAR(699.5,MCI,"ICD","B") ; "B" Cross
..K ^MCAR(699.5,MCI,2005,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(699.5)
F699P55 ; FILE 699.55
K ^MCAR(699.55,"B") ; "B" Cross
K ^MCAR(699.55,"C") ; Procedure
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(699.55,MCI)) Q:MCI<1 D
..K ^MCAR(699.55,MCI,1,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(699.55)
F699P57 ; FILE 699.57
K ^MCAR(699.57,"B") ; "B" Cross
K ^MCAR(699.57,"C") ; Procedure
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(699.57,MCI)) Q:MCI<1 D
..K ^MCAR(699.57,MCI,1,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(699.57)
F699P6 ; FILE 699.6
K ^MCAR(699.6,"B") ; "B" Cross
K ^MCAR(699.6,"BA") ; KWIC
K ^MCAR(699.6,"C") ; Procedure
K ^MCAR(699.6,"E") ; Procedure Name
K ^MCAR(699.6,"D") ; Cath surgical risk procedure
D
.N MCI
.S MCI=0
.F S MCI=$O(^MCAR(699.6,MCI)) Q:MCI<1 D
..K ^MCAR(699.6,MCI,1,"B") ; "B" Cross
..K ^MCAR(699.6,MCI,2,"B") ; "B" Cross
..Q
.Q
D EN1^MCPOS01(699.6)
F699P7 ; FILE 699.7
K ^MCAR(699.7,"B") ; "B" Cross
K ^MCAR(699.7,"C") ; Type
D EN1^MCPOS01(699.7)
F699P81 ; FILE 699.81
K ^MCAR(699.81,"B") ; "B" Cross
K ^MCAR(699.81,"D") ; KWIC
K ^MCAR(699.81,"C") ; Medical Package Use
D EN1^MCPOS01(699.81)
F699P82 ; FILE 699.82
K ^MCAR(699.82,"B") ; "B" Cross
K ^MCAR(699.82,"C") ; KWIC
D EN1^MCPOS01(699.82)
F699P83 ; FILE 699.83
K ^MCAR(699.83,"B") ; "B" Cross
K ^MCAR(699.83,"C") ; Medical Use
D EN1^MCPOS01(699.83)
F699P84 ; FILE 699.84
K ^MCAR(699.84,"B") ; "B" Cross
K ^MCAR(699.84,"C") ; KWIC
D EN1^MCPOS01(699.84)
F699P85 ; FILE 699.85
K ^MCAR(699.85,"B") ; "B" Cross
K ^MCAR(699.85,"C") ; KWIC
K ^MCAR(699.85,"D") ; Medical Package Use
D EN1^MCPOS01(699.85)
F699P86 ; FILE 699.86
K ^MCAR(699.86,"B") ; "B" Cross
K ^MCAR(699.86,"C") ; KWIC
D EN1^MCPOS01(699.86)
F699P88 ; FILE 699.88
K ^MCAR(699.88,"B") ; "B" Cross
K ^MCAR(699.88,"C") ; KWIC
D EN1^MCPOS01(699.88)
G F700^MCPOS01G
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS01F 3611 printed Apr 09, 2024@21:14:55 Page 2
MCPOS01F ;HIRMFO/WAA - Kill all cross reference in a file - ;4/29/96 14:53
+1 ;;2.3;Medicine;;09/13/1996
+2 ;;
F699 ; FILE 699
+1 ; "B" Cross
KILL ^MCAR(699,"B")
+2 ; Medical patient
KILL ^MCAR(699,"C")
+3 ; Procedure
KILL ^MCAR(699,"D")
+4 ; Endoscopist
KILL ^MCAR(699,"AC")
+5 ; Endoscopist
KILL ^MCAR(699,"ACE")
+6 ; Where performed
KILL ^MCAR(699,"AD")
+7 ; PCC Pointer
KILL ^MCAR(699,"PCC")
+8 ; Release code
KILL ^MCAR(699,"ES")
+9 Begin DoDot:1
+10 NEW MCI
+11 SET MCI=0
+12 FOR
SET MCI=$ORDER(^MCAR(699,MCI))
if MCI<1
QUIT
Begin DoDot:2
+13 ; "B" Cross
KILL ^MCAR(699,MCI,1,"B")
+14 ; "B" Cross
KILL ^MCAR(699,MCI,3,"B")
+15 ; "B" Cross
KILL ^MCAR(699,MCI,28,"B")
+16 ; "B" Cross
KILL ^MCAR(699,MCI,25,"B")
+17 ; "B" Cross
KILL ^MCAR(699,MCI,27,"B")
+18 ; "B" Cross
KILL ^MCAR(699,MCI,30,"B")
+19 Begin DoDot:3
+20 NEW MCII
+21 SET MCII=0
+22 FOR
SET MCII=$ORDER(^MCAR(699,MCI,30,MCII))
if MCII<1
QUIT
Begin DoDot:4
+23 ; "B" Cross
KILL ^MCAR(699,MCI,30,MCII,1,"B")
+24 ; "B" Cross
KILL ^MCAR(699,MCI,30,MCII,2,"B")
+25 ; "B" Cross
KILL ^MCAR(699,MCI,30,MCII,3,"B")
+26 QUIT
End DoDot:4
+27 QUIT
End DoDot:3
+28 ; "B" Cross
KILL ^MCAR(699,MCI,10,"B")
+29 ; "B" Cross
KILL ^MCAR(699,MCI,11,"B")
+30 ; "B" Cross
KILL ^MCAR(699,MCI,"IDC","B")
+31 ; "B" Cross
KILL ^MCAR(699,MCI,2005,"B")
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 DO EN1^MCPOS01(699)
F699P48 ; FILE 699.48
+1 ; "B" Cross
KILL ^MCAR(699.48,"B")
+2 ; Medical package use
KILL ^MCAR(699.48,"C")
+3 DO EN1^MCPOS01(699.48)
F699P5 ; FILE 699.5
+1 ; "B" Cross
KILL ^MCAR(699.5,"B")
+2 ; Medical Patient
KILL ^MCAR(699.5,"C")
+3 ; Subspecialty
KILL ^MCAR(699.5,"D")
+4 ; PCC Pointer
KILL ^MCAR(699.5,"PCC")
+5 Begin DoDot:1
+6 NEW MCI
+7 SET MCI=0
+8 FOR
SET MCI=$ORDER(^MCAR(699.5,MCI))
if MCI<1
QUIT
Begin DoDot:2
+9 ; "B" Cross
KILL ^MCAR(699.5,MCI,4,"B")
+10 ; "B" Cross
KILL ^MCAR(699.5,MCI,2,"B")
+11 ; "B" Cross
KILL ^MCAR(699.5,MCI,3,"B")
+12 ; "B" Cross
KILL ^MCAR(699.5,MCI,"ICD","B")
+13 ; "B" Cross
KILL ^MCAR(699.5,MCI,2005,"B")
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 DO EN1^MCPOS01(699.5)
F699P55 ; FILE 699.55
+1 ; "B" Cross
KILL ^MCAR(699.55,"B")
+2 ; Procedure
KILL ^MCAR(699.55,"C")
+3 Begin DoDot:1
+4 NEW MCI
+5 SET MCI=0
+6 FOR
SET MCI=$ORDER(^MCAR(699.55,MCI))
if MCI<1
QUIT
Begin DoDot:2
+7 ; "B" Cross
KILL ^MCAR(699.55,MCI,1,"B")
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 DO EN1^MCPOS01(699.55)
F699P57 ; FILE 699.57
+1 ; "B" Cross
KILL ^MCAR(699.57,"B")
+2 ; Procedure
KILL ^MCAR(699.57,"C")
+3 Begin DoDot:1
+4 NEW MCI
+5 SET MCI=0
+6 FOR
SET MCI=$ORDER(^MCAR(699.57,MCI))
if MCI<1
QUIT
Begin DoDot:2
+7 ; "B" Cross
KILL ^MCAR(699.57,MCI,1,"B")
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 DO EN1^MCPOS01(699.57)
F699P6 ; FILE 699.6
+1 ; "B" Cross
KILL ^MCAR(699.6,"B")
+2 ; KWIC
KILL ^MCAR(699.6,"BA")
+3 ; Procedure
KILL ^MCAR(699.6,"C")
+4 ; Procedure Name
KILL ^MCAR(699.6,"E")
+5 ; Cath surgical risk procedure
KILL ^MCAR(699.6,"D")
+6 Begin DoDot:1
+7 NEW MCI
+8 SET MCI=0
+9 FOR
SET MCI=$ORDER(^MCAR(699.6,MCI))
if MCI<1
QUIT
Begin DoDot:2
+10 ; "B" Cross
KILL ^MCAR(699.6,MCI,1,"B")
+11 ; "B" Cross
KILL ^MCAR(699.6,MCI,2,"B")
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 DO EN1^MCPOS01(699.6)
F699P7 ; FILE 699.7
+1 ; "B" Cross
KILL ^MCAR(699.7,"B")
+2 ; Type
KILL ^MCAR(699.7,"C")
+3 DO EN1^MCPOS01(699.7)
F699P81 ; FILE 699.81
+1 ; "B" Cross
KILL ^MCAR(699.81,"B")
+2 ; KWIC
KILL ^MCAR(699.81,"D")
+3 ; Medical Package Use
KILL ^MCAR(699.81,"C")
+4 DO EN1^MCPOS01(699.81)
F699P82 ; FILE 699.82
+1 ; "B" Cross
KILL ^MCAR(699.82,"B")
+2 ; KWIC
KILL ^MCAR(699.82,"C")
+3 DO EN1^MCPOS01(699.82)
F699P83 ; FILE 699.83
+1 ; "B" Cross
KILL ^MCAR(699.83,"B")
+2 ; Medical Use
KILL ^MCAR(699.83,"C")
+3 DO EN1^MCPOS01(699.83)
F699P84 ; FILE 699.84
+1 ; "B" Cross
KILL ^MCAR(699.84,"B")
+2 ; KWIC
KILL ^MCAR(699.84,"C")
+3 DO EN1^MCPOS01(699.84)
F699P85 ; FILE 699.85
+1 ; "B" Cross
KILL ^MCAR(699.85,"B")
+2 ; KWIC
KILL ^MCAR(699.85,"C")
+3 ; Medical Package Use
KILL ^MCAR(699.85,"D")
+4 DO EN1^MCPOS01(699.85)
F699P86 ; FILE 699.86
+1 ; "B" Cross
KILL ^MCAR(699.86,"B")
+2 ; KWIC
KILL ^MCAR(699.86,"C")
+3 DO EN1^MCPOS01(699.86)
F699P88 ; FILE 699.88
+1 ; "B" Cross
KILL ^MCAR(699.88,"B")
+2 ; KWIC
KILL ^MCAR(699.88,"C")
+3 DO EN1^MCPOS01(699.88)
+4 GOTO F700^MCPOS01G
