ACPTCXR.m

ACPTCXR ; IHS/ASDST/DMJ,SDR - CROSS REF FILE 81 FIELD 50 (DESC) ;    [ 12/31/2003  1:54 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!(DA<4848504884&DA>999999)  D

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

 .D ONE

 K ACPTEX,ACPTLINE

 Q

ONE ;X-REF ONE ENTRY

 Q:DA<4848504884&DA>999999

 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

ACPTCXR   ; IHS/ASDST/DMJ,SDR - CROSS REF FILE 81 FIELD 50 (DESC) ;    [ 12/31/2003  1:54 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

 +4        FOR 

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

               IF 'DA!(DA<4848504884&DA>999999)

                   QUIT 

               Begin DoDot:1

 +5                IF '(DA#100)

                       WRITE "."

 +6                DO ONE

               End DoDot:1

 +7        KILL ACPTEX,ACPTLINE

 +8        QUIT 

ONE       ;X-REF ONE ENTRY

 +1        IF DA<4848504884&DA>999999

               QUIT 

 +2        SET ACPTLINE=0

           FOR 

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

               IF 'ACPTLINE

                   QUIT 

               Begin DoDot:1

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

 +4                XECUTE ACPTEX

               End DoDot:1

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

 +6        XECUTE ACPTEX

 +7        QUIT