Routine: LRBLFIX

LRBLFIX ; IHS/DIR/FJE - FIX DISPOSITION X-REF 12:54 ; [ 8/14/92 ]

 ;;5.2;LR;;NOV 01, 1997

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 S DA=0 F  S DA=$O(^LRD(65,DA)) Q:'DA  I $P($G(^LRD(65,DA,4)),"^")]"" S A=^(0),B=$P(A,"^",4),C=$P(A,"^",6) K:B]""&(C]"") ^LRD(65,"AE",B,C,DA),^LRD(65,"AI",B,$P(A,"^"),C,DA) W "#"

AUFIX ;SET autopsy verification dates on old cases

 ;RELEASE AUTOPSY REPORTS

 W !!?10,"Releasing old Autopsy Reports ",!

 F LRDFN=0:0 S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN  S Y=$P($G(^LR(LRDFN,"AU")),"^",3) I Y S $P(^("AU"),"^",15)=Y W "."

 ;If there is a disposition entered then the "AE" & "AI" x-references

 ;should be deleted.  Disposition is the 1st piece of subscript 4

 ; which is: $P(^LRD(65,DA,4),U,1)

LRBLFIX   ; IHS/DIR/FJE - FIX DISPOSITION X-REF 12:54 ; [ 8/14/92 ]

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        SET DA=0

FOR

               SET DA=$ORDER(^LRD(65,DA))

               IF 'DA

                   QUIT

               IF $PIECE($GET(^LRD(65,DA,4)),"^")]""

                   SET A=^(0)

                   SET B=$PIECE(A,"^",4)

                   SET C=$PIECE(A,"^",6)

                   IF B]""&(C]"")

                       KILL ^LRD(65,"AE",B,C,DA),^LRD(65,"AI",B,$PIECE(A,"^"),C,DA)

                   WRITE "#"

AUFIX     ;SET autopsy verification dates on old cases

 +1       ;RELEASE AUTOPSY REPORTS

 +2        WRITE !!?10,"Releasing old Autopsy Reports ",!

 +3        FOR LRDFN=0:0

               SET LRDFN=$ORDER(^LR(LRDFN))

               IF 'LRDFN

                   QUIT

               SET Y=$PIECE($GET(^LR(LRDFN,"AU")),"^",3)

               IF Y

                   SET $PIECE(^("AU"),"^",15)=Y

                   WRITE "."

 +4        QUIT

 +5       ;If there is a disposition entered then the "AE" & "AI" x-references

 +6       ;should be deleted.  Disposition is the 1st piece of subscript 4

 +7       ; which is: $P(^LRD(65,DA,4),U,1)

LRBLFIX.m