LRAPFIX ;AVAMC/REG/CYM -FIX ACCESSION X-REF ;5/31/96 10:28
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPFIX 1615 printed Nov 22, 2024@17:17:30 Page 2
LRAPFIX ;AVAMC/REG/CYM -FIX ACCESSION X-REF ;5/31/96 10:28
+1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+2 ;
+3 IF $DATA(^LRO(68,"VR"))
DO BMES^XPDUTL("Looks like you've already run the AP Accession Number conversion")
WRITE $CHAR(7),!!
+4 IF $DATA(^LRO(68,"VR"))
DO BMES^XPDUTL("Looks like we're done with the Post Install routines")
WRITE !!!
+5 if $DATA(^LRO(68,"VR"))
QUIT
DO G
if Y=-1
QUIT
+6 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if 'LRDFN
QUIT
Begin DoDot:1
+7 SET I=""
FOR
SET I=$ORDER(^LR(LRDFN,"AU",I))
if I=""
QUIT
KILL ^(I)
End DoDot:1
+8 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if 'LRDFN
QUIT
FOR LRSS="SP","CY","EM","AU"
DO @LRSS
+9 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),!!!
+10 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
