LRAPM ;AVAMC/REG/WTY - ANATOMIC PATH MODIFY MICRO/DX ;10/23/04 22:55
;;5.2;LAB SERVICE;**1002,1030,1031**;NOV 01, 1997
;
;;VA LR Patch(s): 72,91,130,231,248,295
;
;Reference to ^%DT supported by IA #10003
;Reference to %XY^%RCR supported by IA #10022
;Reference to ^DIE supported by IA #10018
;Reference to EN^DDIOL supported by IA #10142
;
D A^LRAPD Q:'$D(Y)
I LRCAPA D @(LRSS_"^LRAPSWK")
D @LRSS
S LRB(1)="GROSS DESCRIPTION",LRB(2)="MICROSCOPIC DESCRIPTION"
S LRB(3)="DIAGNOSIS",LRB(4)="FROZEN SECTION"
S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^^"
AK W !!,"Modify data for ",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 '$D(^LRO(68,LRAA,1,LRAD,0)) W $C(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!! G END
W K X,Y R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
G:LRAN=""!(LRAN[U) END
I LRAN'?1N.N D PNAME^LRAPDA G:LRAN<1 W D DIE G W
D REST G W
REST W " for ",LRH(0) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!! Q
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
; W !,LRP," ID: ",SSN
W !,LRP," ID: ",HRCN ; IHS/ANMC/CLS 08/18/96 -- LR*5.2*1030
S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
W:$O(^LR(LRDFN,LRSS,LRI,.1,0)) !,"Specimen(s):" F X=0:0 S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X W !,$P($G(^(X,0)),U)
DIE S X=^LR(LRDFN,LRSS,LRI,0)
I '$P(X,"^",11),'$P(X,"^",15) W $C(7),!!,"Report not verified. Do not need to use this option !" Q
ASK D:LRCAPA C^LRAPSWK
W !?14,"1. MODIFY GROSS DESCRIPTION",!?14,"2. MODIFY MICROSCOPIC DESCRIPTION",!?14,"3. MODIFY DIAGNOSIS" S LRB=3 I LRSS="SP" W !?14,"4. MODIFY FROZEN SECTION" S LRB=4
W !,"CHOOSE (1-",LRB,"): " R X:DTIME Q:X[U!(X="")
I X'=+X!(X<1)!(X>LRB) W $C(7),!,"Choose from 1 to ",LRB G ASK
S LRB=X,LRF=$S(X=1:"1^7",X=2:"1.1^4",X=3:"1.4^5",1:"1.3^6"),LRE=$P(LRF,U,2),LRF=$P(LRF,U)
I '$D(^LR(LRDFN,LRSS,LRI,LRF)) W $C(7),!!,"There is no ",LRB(LRB)," text to modify !",!,"The report was released before entering text.",!,"Do you still want to continue " S %=2 D YN^LRU Q:%'=1 G A
W !!,"Are you sure you want to modify ",LRB(LRB)," text " S %=2 D YN^LRU Q:%'=1
A S:'$D(^LR(LRDFN,LRSS,LRI,LRE,0)) ^(0)=LRQ(LRB) S LRT(1)=^(0),(B,C)=0
F A=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,LRE,B)) Q:'B S C=B
S C=C+1
S ^LR(LRDFN,LRSS,LRI,LRE,0)=$P(LRT(1),"^",1,2)_"^"_C_"^"_($P(LRT(1),"^",4)+1),LRDTMOD=C
S X="N",%DT="T" D ^%DT
S ^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,0)=Y_"^"_DUZ
S %X="^LR(LRDFN,LRSS,LRI,LRF,",%Y="^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,1,"
D %XY^%RCR
W ! S DR=LRF,DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN
I LRF=1 D
.S DR=".012;1"
.S:LRSS="SP" DR(2,63.812)=".01"
.S:LRSS="CY" DR(2,63.902)=".01;.02"
.S:LRSS="EM" DR(2,63.202)=".01"
L +^LR(LRDFN,LRSS,DA):5 I '$T D Q
.S MSG="This record is locked by another user. "
.S MSG=MSG_"Please try again later."
.D EN^DDIOL(MSG,"","!!") K MSG
D ^DIE S X=^LR(LRDFN,LRSS,LRI,0),LRRC=$P(X,"^",10) K X
L -^LR(LRDFN,LRSS,DA)
D:LRCAPA C1^LRAPSWK
S LRC=1 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,LRF,A)) Q:'A S X=^(A,0) S:'$D(^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,1,A,0)) LRC=0 Q:'LRC I X'=^(0) S LRC=0 Q
I LRC F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,1,A)) Q:'A S X=^(A,0) I '$D(^LR(LRDFN,LRSS,LRI,LRF,A,0)) S LRC=0 Q
I LRC D Q
. W $C(7),!!,"No changes were made to ",LRB(LRB)
. K ^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD)
. S X=^LR(LRDFN,LRSS,LRI,LRE,0),A=$P(X,"^",4),Y=$O(^(0))
. S ^LR(LRDFN,LRSS,LRI,LRE,0)=$P(X,"^",1,2)_"^"_Y_"^"_$S(A:A-1,1:0)
S X=^LR(LRDFN,LRSS,LRI,0),Y=$P(X,"^",15),$P(^(0),"^",11)="" S:'Y $P(^(0),"^",15)=$P(X,"^",11)
I $G(SEX)["F","SPCY"[LRSS D DEL^LRWOMEN ;This sends notificatin to WHP
;that a previously verified report has been modified. ;cym 2/20/1999
; D UPDATE^LRPXRM(LRDFN,LRSS,LRI) ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
I $$PATCH^BLRUTIL4("PXRM*1.5*12") D UPDATE^LRPXRM(LRDFN,LRSS,+$G(LRI)) ; IHS/MSC/MKK - LR*5.2*1031
I '$D(^LRO(69.2,LRAA,2,LRAN,0)) D
.L +^LRO(69.2,LRAA,2):5 I '$T D Q
..S MSG(1)="The final reports queue is in use by another person. "
..S MSG(1,"F")="!!"
..S MSG(2)="You will need to add this accession to the queue later."
..D EN^DDIOL(.MSG) K MSG
.S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
.S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
.L -^LRO(69.2,LRAA,2)
Q
SP S LRQ(1)="^63.087DA^^",LRQ(2)="^63.84DA^^",LRQ(3)="^63.085DA^^",LRQ(4)="^63.086DA^^" Q
CY S LRQ(1)="^63.097D^^",LRQ(2)="^63.94DA^^",LRQ(3)="^63.095DA^^" Q
EM S LRQ(1)="^63.0272DA^^",LRQ(2)="^63.242DA^^",LRQ(3)="^63.025DA^^" Q
;
END D V^LRU K LRDTMOD Q
LRAPM ;AVAMC/REG/WTY - ANATOMIC PATH MODIFY MICRO/DX ;10/23/04 22:55
+1 ;;5.2;LAB SERVICE;**1002,1030,1031**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patch(s): 72,91,130,231,248,295
+4 ;
+5 ;Reference to ^%DT supported by IA #10003
+6 ;Reference to %XY^%RCR supported by IA #10022
+7 ;Reference to ^DIE supported by IA #10018
+8 ;Reference to EN^DDIOL supported by IA #10142
+9 ;
+10 DO A^LRAPD
IF '$DATA(Y)
QUIT
+11 IF LRCAPA
DO @(LRSS_"^LRAPSWK")
+12 DO @LRSS
+13 SET LRB(1)="GROSS DESCRIPTION"
SET LRB(2)="MICROSCOPIC DESCRIPTION"
+14 SET LRB(3)="DIAGNOSIS"
SET LRB(4)="FROZEN SECTION"
+15 IF '$DATA(^LRO(69.2,LRAA,2,0))
SET ^(0)="^69.23A^^"
AK WRITE !!,"Modify data for ",LRH(0)," "
+1 SET %=1
DO YN^LRU
IF %<1
GOTO END
+2 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
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,0))
WRITE $CHAR(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!!
GOTO END
W KILL X,Y
READ !!,"Select Accession Number/Pt name: ",LRAN:DTIME
+1 IF LRAN=""!(LRAN[U)
GOTO END
+2 IF LRAN'?1N.N
DO PNAME^LRAPDA
IF LRAN<1
GOTO W
DO DIE
GOTO W
+3 DO REST
GOTO W
REST WRITE " for ",LRH(0)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!!
QUIT
+1 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRLLOC=$PIECE(X,"^",7)
SET LRDFN=+X
+2 IF '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
DO ^LRUP
+3 ; W !,LRP," ID: ",SSN
+4 ; IHS/ANMC/CLS 08/18/96 -- LR*5.2*1030
WRITE !,LRP," ID: ",HRCN
+5 SET LRI=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
+6 IF $ORDER(^LR(LRDFN,LRSS,LRI,.1,0))
WRITE !,"Specimen(s):"
FOR X=0:0
SET X=$ORDER(^LR(LRDFN,LRSS,LRI,.1,X))
IF 'X
QUIT
WRITE !,$PIECE($GET(^(X,0)),U)
DIE SET X=^LR(LRDFN,LRSS,LRI,0)
+1 IF '$PIECE(X,"^",11)
IF '$PIECE(X,"^",15)
WRITE $CHAR(7),!!,"Report not verified. Do not need to use this option !"
QUIT
ASK IF LRCAPA
DO C^LRAPSWK
+1 WRITE !?14,"1. MODIFY GROSS DESCRIPTION",!?14,"2. MODIFY MICROSCOPIC DESCRIPTION",!?14,"3. MODIFY DIAGNOSIS"
SET LRB=3
IF LRSS="SP"
WRITE !?14,"4. MODIFY FROZEN SECTION"
SET LRB=4
+2 WRITE !,"CHOOSE (1-",LRB,"): "
READ X:DTIME
IF X[U!(X="")
QUIT
+3 IF X'=+X!(X<1)!(X>LRB)
WRITE $CHAR(7),!,"Choose from 1 to ",LRB
GOTO ASK
+4 SET LRB=X
SET LRF=$SELECT(X=1:"1^7",X=2:"1.1^4",X=3:"1.4^5",1:"1.3^6")
SET LRE=$PIECE(LRF,U,2)
SET LRF=$PIECE(LRF,U)
+5 IF '$DATA(^LR(LRDFN,LRSS,LRI,LRF))
WRITE $CHAR(7),!!,"There is no ",LRB(LRB)," text to modify !",!,"The report was released before entering text.",!,"Do you still want to continue "
SET %=2
DO YN^LRU
IF %'=1
QUIT
GOTO A
+6 WRITE !!,"Are you sure you want to modify ",LRB(LRB)," text "
SET %=2
DO YN^LRU
IF %'=1
QUIT
A IF '$DATA(^LR(LRDFN,LRSS,LRI,LRE,0))
SET ^(0)=LRQ(LRB)
SET LRT(1)=^(0)
SET (B,C)=0
+1 FOR A=0:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,LRE,B))
IF 'B
QUIT
SET C=B
+2 SET C=C+1
+3 SET ^LR(LRDFN,LRSS,LRI,LRE,0)=$PIECE(LRT(1),"^",1,2)_"^"_C_"^"_($PIECE(LRT(1),"^",4)+1)
SET LRDTMOD=C
+4 SET X="N"
SET %DT="T"
DO ^%DT
+5 SET ^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,0)=Y_"^"_DUZ
+6 SET %X="^LR(LRDFN,LRSS,LRI,LRF,"
SET %Y="^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,1,"
+7 DO %XY^%RCR
+8 WRITE !
SET DR=LRF
SET DIE="^LR(LRDFN,LRSS,"
SET DA=LRI
SET DA(1)=LRDFN
+9 IF LRF=1
Begin DoDot:1
+10 SET DR=".012;1"
+11 IF LRSS="SP"
SET DR(2,63.812)=".01"
+12 IF LRSS="CY"
SET DR(2,63.902)=".01;.02"
+13 IF LRSS="EM"
SET DR(2,63.202)=".01"
End DoDot:1
+14 LOCK +^LR(LRDFN,LRSS,DA):5
IF '$TEST
Begin DoDot:1
+15 SET MSG="This record is locked by another user. "
+16 SET MSG=MSG_"Please try again later."
+17 DO EN^DDIOL(MSG,"","!!")
KILL MSG
End DoDot:1
QUIT
+18 DO ^DIE
SET X=^LR(LRDFN,LRSS,LRI,0)
SET LRRC=$PIECE(X,"^",10)
KILL X
+19 LOCK -^LR(LRDFN,LRSS,DA)
+20 IF LRCAPA
DO C1^LRAPSWK
+21 SET LRC=1
FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRF,A))
IF 'A
QUIT
SET X=^(A,0)
IF '$DATA(^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,1,A,0))
SET LRC=0
IF 'LRC
QUIT
IF X'=^(0)
SET LRC=0
QUIT
+22 IF LRC
FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD,1,A))
IF 'A
QUIT
SET X=^(A,0)
IF '$DATA(^LR(LRDFN,LRSS,LRI,LRF,A,0))
SET LRC=0
QUIT
+23 IF LRC
Begin DoDot:1
+24 WRITE $CHAR(7),!!,"No changes were made to ",LRB(LRB)
+25 KILL ^LR(LRDFN,LRSS,LRI,LRE,LRDTMOD)
+26 SET X=^LR(LRDFN,LRSS,LRI,LRE,0)
SET A=$PIECE(X,"^",4)
SET Y=$ORDER(^(0))
+27 SET ^LR(LRDFN,LRSS,LRI,LRE,0)=$PIECE(X,"^",1,2)_"^"_Y_"^"_$SELECT(A:A-1,1:0)
End DoDot:1
QUIT
+28 SET X=^LR(LRDFN,LRSS,LRI,0)
SET Y=$PIECE(X,"^",15)
SET $PIECE(^(0),"^",11)=""
IF 'Y
SET $PIECE(^(0),"^",15)=$PIECE(X,"^",11)
+29 ;This sends notificatin to WHP
IF $GET(SEX)["F"
IF "SPCY"[LRSS
DO DEL^LRWOMEN
+30 ;that a previously verified report has been modified. ;cym 2/20/1999
+31 ; D UPDATE^LRPXRM(LRDFN,LRSS,LRI) ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
+32 ; IHS/MSC/MKK - LR*5.2*1031
IF $$PATCH^BLRUTIL4("PXRM*1.5*12")
DO UPDATE^LRPXRM(LRDFN,LRSS,+$GET(LRI))
+33 IF '$DATA(^LRO(69.2,LRAA,2,LRAN,0))
Begin DoDot:1
+34 LOCK +^LRO(69.2,LRAA,2):5
IF '$TEST
Begin DoDot:2
+35 SET MSG(1)="The final reports queue is in use by another person. "
+36 SET MSG(1,"F")="!!"
+37 SET MSG(2)="You will need to add this accession to the queue later."
+38 DO EN^DDIOL(.MSG)
KILL MSG
End DoDot:2
QUIT
+39 SET ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+40 SET X=^LRO(69.2,LRAA,2,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+41 LOCK -^LRO(69.2,LRAA,2)
End DoDot:1
+42 QUIT
SP SET LRQ(1)="^63.087DA^^"
SET LRQ(2)="^63.84DA^^"
SET LRQ(3)="^63.085DA^^"
SET LRQ(4)="^63.086DA^^"
QUIT
CY SET LRQ(1)="^63.097D^^"
SET LRQ(2)="^63.94DA^^"
SET LRQ(3)="^63.095DA^^"
QUIT
EM SET LRQ(1)="^63.0272DA^^"
SET LRQ(2)="^63.242DA^^"
SET LRQ(3)="^63.025DA^^"
QUIT
+1 ;
END DO V^LRU
KILL LRDTMOD
QUIT
