LRAPFIX.m

LRAPFIX ; IHS/DIR/AAB -FIX ACCESSION X-REF 10:28 ; [ 5/31/96 ]

 ;;5.2;LR;**1002**;JUN 01, 1998

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

 ;

 I $D(^LRO(68,"VR")) D BMES^XPDUTL("Looks like you've already run the AP Accession Number conversion") W $C(7),!!

 I $D(^LRO(68,"VR")) D BMES^XPDUTL("Looks like we're done with the Post Install routines") W !!!

 Q:$D(^LRO(68,"VR"))  D G Q:Y=-1

 S LRDFN=0 F  S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN  D

 . S I="" F  S I=$O(^LR(LRDFN,"AU",I)) Q:I=""  K ^(I)

 S LRDFN=0 F  S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN  F LRSS="SP","CY","EM","AU" D @LRSS

 S ^LRO(68,"VR")=5.2 D BMES^XPDUTL("Your AP Accession Numbers have been converted to their new format") D BMES^XPDUTL("WHEW!!!, What a job!!!") W $C(7),!!!

 Q

SP S LRI=0 F  S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI  S Y=^(LRI,0),YR=$E($P(Y,"^",10),1,3),LRAN=$P(Y,"^",6) Q:LRAN[" "  I YR>0,LRAN>0 D

 . I $D(^LR("A"_LRSS_"A",YR,LRAN,LRDFN,LRI)) K ^LR("A"_LRSS_"A",YR,LRAN,LRDFN,LRI)

 .  S $P(^LR(LRDFN,LRSS,LRI,0),"^",6)=LRABV(LRSS)_" "_$E(YR,2,3)_" "_LRAN,^LR("A"_LRSS_"A",YR,LRABV(LRSS),LRAN,LRDFN,LRI)=""

 Q

CY D SP Q

 ;

EM D SP Q

 ;

AU Q:'$D(^LR(LRDFN,"AU"))  S Y=$G(^("AU")),YR=$E(Y,1,3),LRAN=$P(Y,"^",6) I LRAN'>0,YR'>0 Q

 Q:LRAN[" "  K:$D(^LR("AAUA",YR,LRAN,LRDFN)) ^(0) I YR,LRAN S $P(^LR(LRDFN,"AU"),"^",6)=LRABV(LRSS)_" "_$E(YR,2,3)_" "_LRAN,^LR("AAUA",YR,LRABV(LRSS),LRAN,LRDFN)=""

 Q

G K DIC S DIC=68,DIC(0)="Z" F X="SURGICAL PATHOLOGY","CYTOPATHOLOGY","EM","AUTOPSY" D A

 K DIC Q

A D ^DIC S LRSS=$P(Y(0),U,2),LRABV=$P(Y(0),U,11) I LRABV=""!(LRSS="") W $C(7),!!,"Must have a lab section and an abbreviation for ",$P(Y,U) S Y=-1 Q

 S LRABV(LRSS)=LRABV Q

LRAPFIX   ; IHS/DIR/AAB -FIX ACCESSION X-REF 10:28 ; [ 5/31/96 ]

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3       ;

 +4        IF $DATA(^LRO(68,"VR"))

               DO BMES^XPDUTL("Looks like you've already run the AP Accession Number conversion")

               WRITE $CHAR(7),!!

 +5        IF $DATA(^LRO(68,"VR"))

               DO BMES^XPDUTL("Looks like we're done with the Post Install routines")

               WRITE !!!

 +6        IF $DATA(^LRO(68,"VR"))

               QUIT 

           DO G

           IF Y=-1

               QUIT 

 +7        SET LRDFN=0

           FOR 

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

               IF 'LRDFN

                   QUIT 

               Begin DoDot:1

 +8                SET I=""

                   FOR 

                       SET I=$ORDER(^LR(LRDFN,"AU",I))

                       IF I=""

                           QUIT 

                       KILL ^(I)

               End DoDot:1

 +9        SET LRDFN=0

           FOR 

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

               IF 'LRDFN

                   QUIT 

               FOR LRSS="SP","CY","EM","AU"

                   DO @LRSS

 +10       SET ^LRO(68,"VR")=5.2

           DO BMES^XPDUTL("Your AP Accession Numbers have been converted to their new format")

           DO BMES^XPDUTL("WHEW!!!, What a job!!!")

           WRITE $CHAR(7),!!!

 +11       QUIT 

SP         SET LRI=0

           FOR 

               SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))

               IF 'LRI

                   QUIT 

               SET Y=^(LRI,0)

               SET YR=$EXTRACT($PIECE(Y,"^",10),1,3)

               SET LRAN=$PIECE(Y,"^",6)

               IF LRAN[" "

                   QUIT 

               IF YR>0

                   IF LRAN>0

                       Begin DoDot:1

 +1                        IF $DATA(^LR("A"_LRSS_"A",YR,LRAN,LRDFN,LRI))

                               KILL ^LR("A"_LRSS_"A",YR,LRAN,LRDFN,LRI)

 +2                        SET $PIECE(^LR(LRDFN,LRSS,LRI,0),"^",6)=LRABV(LRSS)_" "_$EXTRACT(YR,2,3)_" "_LRAN

                           SET ^LR("A"_LRSS_"A",YR,LRABV(LRSS),LRAN,LRDFN,LRI)=""

                       End DoDot:1

 +3        QUIT 

CY         DO SP

           QUIT 

 +1       ;

EM         DO SP

           QUIT 

 +1       ;

AU         IF '$DATA(^LR(LRDFN,"AU"))

               QUIT 

           SET Y=$GET(^("AU"))

           SET YR=$EXTRACT(Y,1,3)

           SET LRAN=$PIECE(Y,"^",6)

           IF LRAN'>0

               IF YR'>0

                   QUIT 

 +1        IF LRAN[" "

               QUIT 

           IF $DATA(^LR("AAUA",YR,LRAN,LRDFN))

               KILL ^(0)

           IF YR

               IF LRAN

                   SET $PIECE(^LR(LRDFN,"AU"),"^",6)=LRABV(LRSS)_" "_$EXTRACT(YR,2,3)_" "_LRAN

                   SET ^LR("AAUA",YR,LRABV(LRSS),LRAN,LRDFN)=""

 +2        QUIT 

G          KILL DIC

           SET DIC=68

           SET DIC(0)="Z"

           FOR X="SURGICAL PATHOLOGY","CYTOPATHOLOGY","EM","AUTOPSY"

               DO A

 +1        KILL DIC

           QUIT 

A          DO ^DIC

           SET LRSS=$PIECE(Y(0),U,2)

           SET LRABV=$PIECE(Y(0),U,11)

           IF LRABV=""!(LRSS="")

               WRITE $CHAR(7),!!,"Must have a lab section and an abbreviation for ",$PIECE(Y,U)

               SET Y=-1

               QUIT 

 +1        SET LRABV(LRSS)=LRABV

           QUIT