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