ACPTCXR2.m

ACPTCXR2 ; IHS/ASDST/DMJ,SDR - CROSS REF FILE 81 FIELD 50 (DESC) ;    [ 12/31/2003  1:55 PM ]

 ;;2.09;CPT FILES;;JAN 2, 2009

START ;START

 K ^ICPT("C")

 S ACPTEX=^DD(81,2,1,1,1)

 S DA=0 F  S DA=$O(^ICPT(DA)) Q:'DA  D

 .I '(DA#100) W "."

 .D ONE

 K ACPTEX,ACPTLINE

 Q

ONE ;X-REF ONE ENTRY

 S ACPTLINE=0 F  S ACPTLINE=$O(^ICPT(DA,"D",ACPTLINE)) Q:'ACPTLINE  D

 .S X=^ICPT(DA,"D",ACPTLINE,0)

 .X ACPTEX

 S X=$P(^ICPT(DA,0),"^",2)

 X ACPTEX

 Q

ACPTCXR2  ; IHS/ASDST/DMJ,SDR - CROSS REF FILE 81 FIELD 50 (DESC) ;    [ 12/31/2003  1:55 PM ]

 +1       ;;2.09;CPT FILES;;JAN 2, 2009

START     ;START

 +1        KILL ^ICPT("C")

 +2        SET ACPTEX=^DD(81,2,1,1,1)

 +3        SET DA=0

           FOR 

               SET DA=$ORDER(^ICPT(DA))

               IF 'DA

                   QUIT 

               Begin DoDot:1

 +4                IF '(DA#100)

                       WRITE "."

 +5                DO ONE

               End DoDot:1

 +6        KILL ACPTEX,ACPTLINE

 +7        QUIT 

ONE       ;X-REF ONE ENTRY

 +1        SET ACPTLINE=0

           FOR 

               SET ACPTLINE=$ORDER(^ICPT(DA,"D",ACPTLINE))

               IF 'ACPTLINE

                   QUIT 

               Begin DoDot:1

 +2                SET X=^ICPT(DA,"D",ACPTLINE,0)

 +3                XECUTE ACPTEX

               End DoDot:1

 +4        SET X=$PIECE(^ICPT(DA,0),"^",2)

 +5        XECUTE ACPTEX

 +6        QUIT