- LRAPMV ;AVAMC/REG/CYM - MOVE AP ACCESSION ;4/1/98 11:53 ;
- ;;5.2;LAB SERVICE;**1002,1018,1030,1031**;NOV 01, 1997
- ;
- ;;VA LR Patch(s): 72,231,259
- ;
- 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)
- W !,LRP," ID: ",HRCN,!,"File: ",$P($G(^DIC(+P("F"),0)),U) ; IHS/MSC/MKK - LR*5.2*1031
- 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
- LRAPMV ;AVAMC/REG/CYM - MOVE AP ACCESSION ;4/1/98 11:53 ;
- +1 ;;5.2;LAB SERVICE;**1002,1018,1030,1031**;NOV 01, 1997
- +2 ;
- +3 ;;VA LR Patch(s): 72,231,259
- +4 ;
- +5 WRITE !!?17,"Move an accession from one patient to another"
- +6 ;Add Quit to ensure this option does not execute
- +7 WRITE !!?18,"*** THIS OPTION IS NO LONGER AVAILABLE ***"
- +8 QUIT
- +9 SET LRDICS="SPCYEM"
- DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- DO XR^LRU
- +10 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
- +11 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 ; W !,LRP," ID: ",SSN,!,"File: ",$P($G(^DIC(+P("F"),0)),U)
- +3 ; IHS/MSC/MKK - LR*5.2*1031
- WRITE !,LRP," ID: ",HRCN,!,"File: ",$PIECE($GET(^DIC(+P("F"),0)),U)
- +4 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
- +5 SET DIE="^LR(LRDFN,LRSS,"
- SET DA=LRI
- DO CK^LRU
- IF $DATA(LR("CK"))
- QUIT
- SET LRO=LRDFN
- +6 WRITE !,"Move accession to "
- DO ^LRDPA
- +7 IF Y=-1
- DO FRE^LRU
- QUIT
- +8 WRITE !,"File: ",$PIECE($GET(^DIC(+LRDPF,0)),U)
- +9 IF LRO=LRDFN
- WRITE $CHAR(7),!,"No need to move accession to the same patient"
- DO FRE^LRU
- QUIT
- +10 IF $DATA(^LR(LRDFN,LRSS,LRI))
- WRITE $CHAR(7),!,LRP,"already has an accession with the same internal file number."
- DO FRE^LRU
- QUIT
- +11 KILL DIR
- WRITE $CHAR(7),!
- SET DIR(0)="YO"
- SET DIR("A")=" OK TO MOVE YES/NO// "
- SET DIR("B")="NO"
- +12 SET DIR("?")="Answer YES if this accession is to be moved to a new patient"
- +13 DO ^DIR
- IF Y'=1
- DO FRE^LRU
- KILL DIR
- QUIT
- +14 IF '$DATA(^LR(LRDFN,LRSS,0))
- SET ^(0)="^"_LRSF_"DA^^"
- +15 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
- +16 ; The following line send notification to WHP that an accession has been moved. ; cym 4/5/1999
- +17 IF "SPCY"[LRSS
- DO MOVE^LRWOMEN
- +18 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)
- +19 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)=""
- +20 KILL ^LR(LRXR,X,LRO,LRI),^LR(LRXREF,$EXTRACT(LRAD,1,3),LRABV,LRAN,LRO,LRI)
- +21 ; Following code updates the AP report queue
- +22 SET (LRFINAL,LRNODE)=""
- +23 IF "SPEMCY"[LRSS
- Begin DoDot:1
- +24 SET LRNODE=^LR(LRDFN,LRSS,LRI,0)
- +25 IF LRNODE']""
- QUIT
- IF $PIECE(LRNODE,U,3)]""
- SET LRFINAL=1
- End DoDot:1
- +26 IF LRFINAL=1
- Begin DoDot:1
- +27 IF $PIECE($GET(^LRO(69.2,LRAA,2,LRAN,0)),U)=LRDFN
- QUIT
- +28 IF $PIECE($GET(^LRO(69.2,LRAA,2,LRAN,0)),U)=LRO
- Begin DoDot:2
- +29 SET DIK="^LRO(69.2,LRAA,2,"
- SET DA=LRAN
- DO ^DIK
- End DoDot:2
- +30 SET FDAIEN(1)=LRAN
- +31 SET FDA(1,69.23,"+1,"_+LRAA_",",.01)=LRDFN
- +32 SET FDA(1,69.23,"+1,"_+LRAA_",",1)=LRI
- +33 DO UPDATE^DIE("","FDA(1)","FDAIEN")
- End DoDot:1
- +34 IF LRFINAL=""
- Begin DoDot:1
- +35 IF $PIECE($GET(^LRO(69.2,LRAA,1,LRAN,0)),U)=LRDFN
- QUIT
- +36 IF $PIECE($GET(^LRO(69.2,LRAA,1,LRAN,0)),U)=LRO
- Begin DoDot:2
- +37 SET DIK="^LRO(69.2,LRAA,1,"
- SET DA=LRAN
- DO ^DIK
- End DoDot:2
- +38 SET FDAIEN(1)=LRAN
- +39 SET FDA(1,69.21,"+1,"_+LRAA_",",.01)=LRDFN
- +40 SET FDA(1,69.21,"+1,"_+LRAA_",",1)=LRI
- +41 DO UPDATE^DIE("","FDA(1)","FDAIEN")
- End DoDot:1
- +42 DO FRE^LRU
- QUIT
- +43 ;
- END KILL FDAIEN,FDA,LRFINAL,LRNODE
- DO V^LRU
- QUIT
