| [613] | 1 | LRAPMV ;AVAMC/REG/CYM - MOVE AP ACCESSION ;4/1/98 11:53 ;
|
|---|
| 2 | ;;5.2;LAB SERVICE;**72,231,259**;Sep 27, 1994
|
|---|
| 3 | W !!?17,"Move an accession from one patient to another"
|
|---|
| 4 | ;Add Quit to ensure this option does not execute
|
|---|
| 5 | W !!?18,"*** THIS OPTION IS NO LONGER AVAILABLE ***"
|
|---|
| 6 | Q
|
|---|
| 7 | S LRDICS="SPCYEM" D ^LRAP G:'$D(Y) END D XR^LRU
|
|---|
| 8 | W !!,"Accession Year: ",LRH(0)," " S %=1 D YN^LRU G:%<1 END I %=2 S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT G:Y<1 END S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
|
|---|
| 9 | I '$O(^LRO(68,LRAA,1,LRAD,1,0)) W $C(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!! Q
|
|---|
| 10 | W K X,Y,LR("CK") R !!,"Move Accession Number: ",LRAN:DTIME G:LRAN=""!(LRAN[U) END I LRAN'?1N.N!($E(LRAN)=0) W $C(7),!,"Enter a number, no leading zero's" G W
|
|---|
| 11 | D REST G W
|
|---|
| 12 | REST W " for ",LRH(0) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,LRO(68)," Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!! Q
|
|---|
| 13 | S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRDFN=+X Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
|
|---|
| 14 | W !,LRP," ID: ",SSN,!,"File: ",$P($G(^DIC(+P("F"),0)),U)
|
|---|
| 15 | S LRI=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5) I '$D(^LR(LRDFN,LRSS,LRI,0)) W $C(7),!,"Inverse date missing or incorrect in Accession Area file for",!,LRAA(1)," Year: ",$E(LRAD,2,3)," Accession: ",LRAN Q
|
|---|
| 16 | S DIE="^LR(LRDFN,LRSS,",DA=LRI D CK^LRU Q:$D(LR("CK")) S LRO=LRDFN
|
|---|
| 17 | W !,"Move accession to " D ^LRDPA
|
|---|
| 18 | I Y=-1 D FRE^LRU Q
|
|---|
| 19 | W !,"File: ",$P($G(^DIC(+LRDPF,0)),U)
|
|---|
| 20 | I LRO=LRDFN W $C(7),!,"No need to move accession to the same patient" D FRE^LRU Q
|
|---|
| 21 | I $D(^LR(LRDFN,LRSS,LRI)) W $C(7),!,LRP,"already has an accession with the same internal file number." D FRE^LRU Q
|
|---|
| 22 | K DIR W $C(7),! S DIR(0)="YO",DIR("A")=" OK TO MOVE YES/NO// ",DIR("B")="NO"
|
|---|
| 23 | S DIR("?")="Answer YES if this accession is to be moved to a new patient"
|
|---|
| 24 | D ^DIR I Y'=1 D FRE^LRU K DIR Q
|
|---|
| 25 | S:'$D(^LR(LRDFN,LRSS,0)) ^(0)="^"_LRSF_"DA^^"
|
|---|
| 26 | S %X="^LR(LRO,LRSS,LRI,",%Y="^LR(LRDFN,LRSS,LRI," D %XY^%RCR S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^")=LRDFN
|
|---|
| 27 | ; The following line send notification to WHP that an accession has been moved. ; cym 4/5/1999
|
|---|
| 28 | I "SPCY"[LRSS D MOVE^LRWOMEN
|
|---|
| 29 | K ^LR(LRO,LRSS,LRI) S X=^LR(LRO,LRSS,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
|
|---|
| 30 | S X=^LR(LRDFN,LRSS,0),^(0)=$P(X,"^",1,2)_"^"_LRI_"^"_($P(X,"^",4)+1),X=+$P(^LR(LRDFN,LRSS,LRI,0),"^",10),^LR(LRXR,X,LRDFN,LRI)="",^LR(LRXREF,$E(LRAD,1,3),LRABV,LRAN,LRDFN,LRI)=""
|
|---|
| 31 | K ^LR(LRXR,X,LRO,LRI),^LR(LRXREF,$E(LRAD,1,3),LRABV,LRAN,LRO,LRI)
|
|---|
| 32 | ; Following code updates the AP report queue
|
|---|
| 33 | S (LRFINAL,LRNODE)=""
|
|---|
| 34 | I "SPEMCY"[LRSS D
|
|---|
| 35 | . S LRNODE=^LR(LRDFN,LRSS,LRI,0)
|
|---|
| 36 | . Q:LRNODE']"" I $P(LRNODE,U,3)]"" S LRFINAL=1
|
|---|
| 37 | I LRFINAL=1 D
|
|---|
| 38 | . Q:$P($G(^LRO(69.2,LRAA,2,LRAN,0)),U)=LRDFN
|
|---|
| 39 | . I $P($G(^LRO(69.2,LRAA,2,LRAN,0)),U)=LRO D
|
|---|
| 40 | .. S DIK="^LRO(69.2,LRAA,2,",DA=LRAN D ^DIK
|
|---|
| 41 | . S FDAIEN(1)=LRAN
|
|---|
| 42 | . S FDA(1,69.23,"+1,"_+LRAA_",",.01)=LRDFN
|
|---|
| 43 | . S FDA(1,69.23,"+1,"_+LRAA_",",1)=LRI
|
|---|
| 44 | . D UPDATE^DIE("","FDA(1)","FDAIEN")
|
|---|
| 45 | I LRFINAL="" D
|
|---|
| 46 | . Q:$P($G(^LRO(69.2,LRAA,1,LRAN,0)),U)=LRDFN
|
|---|
| 47 | . I $P($G(^LRO(69.2,LRAA,1,LRAN,0)),U)=LRO D
|
|---|
| 48 | .. S DIK="^LRO(69.2,LRAA,1,",DA=LRAN D ^DIK
|
|---|
| 49 | . S FDAIEN(1)=LRAN
|
|---|
| 50 | . S FDA(1,69.21,"+1,"_+LRAA_",",.01)=LRDFN
|
|---|
| 51 | . S FDA(1,69.21,"+1,"_+LRAA_",",1)=LRI
|
|---|
| 52 | . D UPDATE^DIE("","FDA(1)","FDAIEN")
|
|---|
| 53 | D FRE^LRU Q
|
|---|
| 54 | ;
|
|---|
| 55 | END K FDAIEN,FDA,LRFINAL,LRNODE D V^LRU Q
|
|---|
