source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPFIX.m@ 1489

Last change on this file since 1489 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.6 KB
Line 
1LRAPFIX ;AVAMC/REG/CYM -FIX ACCESSION X-REF ;5/31/96 10:28
2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
3 ;
4 I $D(^LRO(68,"VR")) D BMES^XPDUTL("Looks like you've already run the AP Accession Number conversion") W $C(7),!!
5 I $D(^LRO(68,"VR")) D BMES^XPDUTL("Looks like we're done with the Post Install routines") W !!!
6 Q:$D(^LRO(68,"VR")) D G Q:Y=-1
7 S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN D
8 . S I="" F S I=$O(^LR(LRDFN,"AU",I)) Q:I="" K ^(I)
9 S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN F LRSS="SP","CY","EM","AU" D @LRSS
10 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),!!!
11 Q
12SP 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
13 . I $D(^LR("A"_LRSS_"A",YR,LRAN,LRDFN,LRI)) K ^LR("A"_LRSS_"A",YR,LRAN,LRDFN,LRI)
14 . 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)=""
15 Q
16CY D SP Q
17 ;
18EM D SP Q
19 ;
20AU Q:'$D(^LR(LRDFN,"AU")) S Y=$G(^("AU")),YR=$E(Y,1,3),LRAN=$P(Y,"^",6) I LRAN'>0,YR'>0 Q
21 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)=""
22 Q
23G K DIC S DIC=68,DIC(0)="Z" F X="SURGICAL PATHOLOGY","CYTOPATHOLOGY","EM","AUTOPSY" D A
24 K DIC Q
25A 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
26 S LRABV(LRSS)=LRABV Q
Note: See TracBrowser for help on using the repository browser.