MCPOS01D.m

MCPOS01D ;HIRMFO/WAA - Kill all cross reference in a file - ;5/31/96  08:08

 ;;2.3;Medicine;;09/13/1996

 ;;

F695 ; FILE 695

 K ^MCAR(695,"B") ; "B" Cross

 K ^MCAR(695,"C") ; Medical Package Use

 D EN1^MCPOS01(695)

F695P1 ; FILE 695.1

 K ^MCAR(695.1,"B") ; "B" Cross

 D EN1^MCPOS01(695.1)

F695P3 ; FILE 695.3

 K ^MCAR(695.3,"B") ; "B" Cross

 D EN1^MCPOS01(695.3)

F695P4 ; FILE 695.4

 K ^MCAR(695.4,"B") ; "B" Cross

 D EN1^MCPOS01(695.4)

F695P5 ; FILE 695.5

 K ^MCAR(695.5,"B") ; "B" Cross

 K ^MCAR(695.5,"BA") ; "BA" Cross

 K ^MCAR(695.5,"C") ; Medical Use

 D EN1^MCPOS01(695.5)

F695P6 ; FILE 695.6

 K ^MCAR(695.6,"B") ; "B" Cross

 D EN1^MCPOS01(695.6)

F695P8 ; FILE 695.8

 K ^MCAR(695.8,"B") ; "B" Cross

 K ^MCAR(695.8,"AC") ; Medical Package Used

 D EN1^MCPOS01(695.8)

F695P9 ; FILE 695.9

 K ^MCAR(695.9,"B") ; "B" Cross

 D EN1^MCPOS01(695.9)

F696 ; FILE 696

 K ^MCAR(696,"B") ; "B" Cross

 D EN1^MCPOS01(696)

F696P1 ; FILE 696.1

 K ^MCAR(696.1,"B") ; "B" Cross

 D EN1^MCPOS01(696.1)

F696P2 ; FILE 696.2

 K ^MCAR(696.2,"B") ; "B" Cross

 D EN1^MCPOS01(696.2)

F696P3 ; FILE 696.3

 K ^MCAR(696.3,"B") ; "B" Cross

 D EN1^MCPOS01(696.3)

F696P4 ; FILE 696.4

 K ^MCAR(696.4,"B") ; "B" Cross

 D EN1^MCPOS01(696.4)

F696P5 ; FILE 696.5

 K ^MCAR(696.5,"B") ; "B" Cross

 K ^MCAR(696.5,"D") ; Display Code

 D EN1^MCPOS01(696.5)

F696P7 ; FILE 696.7

 K ^MCAR(696.7,"B") ; "B" Cross

 D EN1^MCPOS01(696.7)

F696P9 ; FILE 696.9

 K ^MCAR(696.9,"B") ; "B" Cross

 K ^MCAR(696.9,"C") ; Medical Package Use

 D EN1^MCPOS01(696.9)

F697 ; FILE 697

 K ^MCAR(697,"B") ; "B" Cross

 K ^MCAR(697,"C") ; Procedure

 K ^MCAR(697,"D") ; Procedure Name

 D

 .N MCI

 .S MCI=0

 .F  S MCI=$O(^MCAR(697,MCI)) Q:MCI<1  D

 ..K ^MCAR(697,MCI,1,"B") ; "B" Cross

 ..K ^MCAR(697,MCI,2,"B") ; "B" Cross

 ..Q

 .Q

 D EN1^MCPOS01(697)

F697P1 ; FILE 697.1

 K ^MCAR(697.1,"B") ; "B" Cross

 D EN1^MCPOS01(697.1)

F697P2 ; FILE 697.2

 K ^MCAR(697.2,"B") ; "B" Cross

 K ^MCAR(697.2,"C") ; Global Location

 K ^MCAR(697.2,"D") ; Type of Procedure

 D EN1^MCPOS01(697.2)

F697P3 ; FILE 697.3

 K ^MCAR(697.3,"B") ; "B" Cross

 K ^MCAR(697.3,"C") ; Description

 D

 .N MCI

 .S MCI=0

 .F  S MCI=$O(^MCAR(697.3,MCI)) Q:MCI<1  D

 ..K ^MCAR(697.3,MCI,1,"B") ; "B" Cross

 ..K ^MCAR(697.3,MCI,1,"A") ; Entry Num

 ..Q

 .Q

 D EN1^MCPOS01(697.3)

F697P5 ; FILE 697.5

 K ^MCAR(697.5,"B") ; "B" Cross

 K ^MCAR(697.5,"C") ; .01 KWIC

 K ^MCAR(697.5,"D") ; Procedures

 D  ; Diagnosis Code

 .N MCI

 .S MCI="A."

 .F  S MCI=$O(^MCAR(697.5,MCI)) Q:$P(MCI,".")'="A"  D

 ..K ^MCAR(697.5,MCI)

 ..Q

 .Q

 D

 .N MCI

 .S MCI=0

 .F  S MCI=$O(^MCAR(697.5,MCI)) Q:MCI<1  D

 ..K ^MCAR(697.5,MCI,2,"B") ; "B" Cross

 ..K ^MCAR(697.5,MCI,1,"B") ; "B" Cross

 ..K ^MCAR(697.5,MCI,4,"B") ; "B" Cross

 ..Q

 .Q

 D EN1^MCPOS01(697.5)

 G F698^MCPOS01E

MCPOS01D  ;HIRMFO/WAA - Kill all cross reference in a file - ;5/31/96  08:08

 +1       ;;2.3;Medicine;;09/13/1996

 +2       ;;

F695      ; FILE 695

 +1       ; "B" Cross

           KILL ^MCAR(695,"B")

 +2       ; Medical Package Use

           KILL ^MCAR(695,"C")

 +3        DO EN1^MCPOS01(695)

F695P1    ; FILE 695.1

 +1       ; "B" Cross

           KILL ^MCAR(695.1,"B")

 +2        DO EN1^MCPOS01(695.1)

F695P3    ; FILE 695.3

 +1       ; "B" Cross

           KILL ^MCAR(695.3,"B")

 +2        DO EN1^MCPOS01(695.3)

F695P4    ; FILE 695.4

 +1       ; "B" Cross

           KILL ^MCAR(695.4,"B")

 +2        DO EN1^MCPOS01(695.4)

F695P5    ; FILE 695.5

 +1       ; "B" Cross

           KILL ^MCAR(695.5,"B")

 +2       ; "BA" Cross

           KILL ^MCAR(695.5,"BA")

 +3       ; Medical Use

           KILL ^MCAR(695.5,"C")

 +4        DO EN1^MCPOS01(695.5)

F695P6    ; FILE 695.6

 +1       ; "B" Cross

           KILL ^MCAR(695.6,"B")

 +2        DO EN1^MCPOS01(695.6)

F695P8    ; FILE 695.8

 +1       ; "B" Cross

           KILL ^MCAR(695.8,"B")

 +2       ; Medical Package Used

           KILL ^MCAR(695.8,"AC")

 +3        DO EN1^MCPOS01(695.8)

F695P9    ; FILE 695.9

 +1       ; "B" Cross

           KILL ^MCAR(695.9,"B")

 +2        DO EN1^MCPOS01(695.9)

F696      ; FILE 696

 +1       ; "B" Cross

           KILL ^MCAR(696,"B")

 +2        DO EN1^MCPOS01(696)

F696P1    ; FILE 696.1

 +1       ; "B" Cross

           KILL ^MCAR(696.1,"B")

 +2        DO EN1^MCPOS01(696.1)

F696P2    ; FILE 696.2

 +1       ; "B" Cross

           KILL ^MCAR(696.2,"B")

 +2        DO EN1^MCPOS01(696.2)

F696P3    ; FILE 696.3

 +1       ; "B" Cross

           KILL ^MCAR(696.3,"B")

 +2        DO EN1^MCPOS01(696.3)

F696P4    ; FILE 696.4

 +1       ; "B" Cross

           KILL ^MCAR(696.4,"B")

 +2        DO EN1^MCPOS01(696.4)

F696P5    ; FILE 696.5

 +1       ; "B" Cross

           KILL ^MCAR(696.5,"B")

 +2       ; Display Code

           KILL ^MCAR(696.5,"D")

 +3        DO EN1^MCPOS01(696.5)

F696P7    ; FILE 696.7

 +1       ; "B" Cross

           KILL ^MCAR(696.7,"B")

 +2        DO EN1^MCPOS01(696.7)

F696P9    ; FILE 696.9

 +1       ; "B" Cross

           KILL ^MCAR(696.9,"B")

 +2       ; Medical Package Use

           KILL ^MCAR(696.9,"C")

 +3        DO EN1^MCPOS01(696.9)

F697      ; FILE 697

 +1       ; "B" Cross

           KILL ^MCAR(697,"B")

 +2       ; Procedure

           KILL ^MCAR(697,"C")

 +3       ; Procedure Name

           KILL ^MCAR(697,"D")

 +4        Begin DoDot:1

 +5            NEW MCI

 +6            SET MCI=0

 +7            FOR 

                   SET MCI=$ORDER(^MCAR(697,MCI))

                   IF MCI<1

                       QUIT 

                   Begin DoDot:2

 +8       ; "B" Cross

                       KILL ^MCAR(697,MCI,1,"B")

 +9       ; "B" Cross

                       KILL ^MCAR(697,MCI,2,"B")

 +10                   QUIT 

                   End DoDot:2

 +11           QUIT 

           End DoDot:1

 +12       DO EN1^MCPOS01(697)

F697P1    ; FILE 697.1

 +1       ; "B" Cross

           KILL ^MCAR(697.1,"B")

 +2        DO EN1^MCPOS01(697.1)

F697P2    ; FILE 697.2

 +1       ; "B" Cross

           KILL ^MCAR(697.2,"B")

 +2       ; Global Location

           KILL ^MCAR(697.2,"C")

 +3       ; Type of Procedure

           KILL ^MCAR(697.2,"D")

 +4        DO EN1^MCPOS01(697.2)

F697P3    ; FILE 697.3

 +1       ; "B" Cross

           KILL ^MCAR(697.3,"B")

 +2       ; Description

           KILL ^MCAR(697.3,"C")

 +3        Begin DoDot:1

 +4            NEW MCI

 +5            SET MCI=0

 +6            FOR 

                   SET MCI=$ORDER(^MCAR(697.3,MCI))

                   IF MCI<1

                       QUIT 

                   Begin DoDot:2

 +7       ; "B" Cross

                       KILL ^MCAR(697.3,MCI,1,"B")

 +8       ; Entry Num

                       KILL ^MCAR(697.3,MCI,1,"A")

 +9                    QUIT 

                   End DoDot:2

 +10           QUIT 

           End DoDot:1

 +11       DO EN1^MCPOS01(697.3)

F697P5    ; FILE 697.5

 +1       ; "B" Cross

           KILL ^MCAR(697.5,"B")

 +2       ; .01 KWIC

           KILL ^MCAR(697.5,"C")

 +3       ; Procedures

           KILL ^MCAR(697.5,"D")

 +4       ; Diagnosis Code

           Begin DoDot:1

 +5            NEW MCI

 +6            SET MCI="A."

 +7            FOR 

                   SET MCI=$ORDER(^MCAR(697.5,MCI))

                   IF $PIECE(MCI,".")'="A"

                       QUIT 

                   Begin DoDot:2

 +8                    KILL ^MCAR(697.5,MCI)

 +9                    QUIT 

                   End DoDot:2

 +10           QUIT 

           End DoDot:1

 +11       Begin DoDot:1

 +12           NEW MCI

 +13           SET MCI=0

 +14           FOR 

                   SET MCI=$ORDER(^MCAR(697.5,MCI))

                   IF MCI<1

                       QUIT 

                   Begin DoDot:2

 +15      ; "B" Cross

                       KILL ^MCAR(697.5,MCI,2,"B")

 +16      ; "B" Cross

                       KILL ^MCAR(697.5,MCI,1,"B")

 +17      ; "B" Cross

                       KILL ^MCAR(697.5,MCI,4,"B")

 +18                   QUIT 

                   End DoDot:2

 +19           QUIT 

           End DoDot:1

 +20       DO EN1^MCPOS01(697.5)

 +21       GOTO F698^MCPOS01E