source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPMV.m@ 619

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

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1LRAPMV ;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
10W 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
12REST 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 ;
55END K FDAIEN,FDA,LRFINAL,LRNODE D V^LRU Q
Note: See TracBrowser for help on using the repository browser.