- 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 Feb 18, 2025@23:42:48 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