LRAP ;DALOI/STAFF - ANATOMIC PATH UTILITY ;02/10/17 09:41
;;5.2;LAB SERVICE;**72,248,259,350,462,479**;Sep 27, 1994;Build 8
;
; Called by many routines in AP package
D END,CK G:Y=-1 END D LRDICS G:Y B
S DIC=68,DIC(0)="AEOQMZ"
S DIC("A")="Select ANATOMIC PATHOLOGY SECTION: "
;
;
S DIC("S")="I LRDICS[$P(^(0),U,2),$P(^(0),U,2)]"""",$D(^(3,""B"",DUZ(2)))"
;
D ^DIC
K DIC,LRDICS
G:Y<1 END
;
B ;
S X=$P(Y,U,2) D ^LRUTL G:Y=-1 END
Q
;
;
AU ; log-in autopsy
Q ;see routine LRAUAW
;
;
CY ; log-in cytopath
S (LRMD,LRSIT)=""
;
D GETDEF
;
S DR=".08///"_$S(LRLLOC["?":"UNKNOWN",1:LRLLOC)
S DR=DR_";.07;D:X P^LRUA;.011//^S X=LRPRAC(1);.012;.1//NOW"
S DR=DR_";S LRRC=X;.02;.99;S LRC(5)=X;1"
S DR(2,63.902)=".01;S LR(63.902)=X;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
S DR(2,63.902)=DR(2,63.902)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U);S:'LRCAPA Y=""@2"";.02;@2"
Q
;
;
EM ; log-in electron microscopy
S (LRMD,LRSIT)=""
;
D GETDEF
;
S DR=".08///"_$S(LRLLOC["?":"UNKNOWN",1:LRLLOC)
S DR=DR_";.07;D:X P^LRUA;.011//^S X=LRPRAC(1);.012;.1//NOW;S LRRC=X"
S DR=DR_";.02;.021;.99;S LRC(5)=X"
S DR(2,63.202)=".01;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
S DR(2,63.202)=DR(2,63.202)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U)"
Q
;
;
SP ; log-in surg path
S (LRMD,LRSIT)=""
S LR("FS")=+$G(^LAB(69.9,1,11))
;
D GETDEF
;
S DR=".08///"_$S(LRLLOC["?":"UNKNOWN",1:LRLLOC)
S DR=DR_";.07//^S X=LR(.07);D:X P^LRUA;.011//^S X=LRPRAC(1);.012;.1//NOW"
S DR=DR_";S LRRC=X;.02;.99;S LRC(5)=X;S:'LR(""FS"") Y=""@1"";1.3;@1"
S DR(2,63.812)=".01;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
S DR(2,63.812)=DR(2,63.812)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U)"
;
S:LRABV'["SP" LR("FS")=""
Q
;
;
M ; edit path report parameters
W !
S DIC="^LRO(69.2,",DIC(0)="AEOQM"
S DIC("S")="I ""AUCYEMSP""[$P(^(0),U,2)&($P(^(0),U,2)]"""")"
D ^DIC K DIC G:Y<1 END S DA=+Y
L +^LRO(69.2,DA):5 I '$T D G M
. S MSG="This entry is locked by another user. Please try again later."
. D EN^DDIOL(MSG,"","!!") K MSG,DIE,DR,DA
. D END
S DR="[LRAPHDR]",DIE="^LRO(69.2,"
D ^DIE
L -^LRO(69.2,DA)
K DIE,DR,DA
G M
;
;
D ; Edit path descriptions
W ! S DIC="^LAB(62.5,",DIC(0)="AEQLM"
S DLAYGO=62.5,DIC("S")="I ""ESCI""[$P(^(0),U,4)"
D ^DIC K DIC,DLAYGO G:X=""!(X[U) END S DA=+Y
S DIE("NO^")="",DIE="^LAB(62.5,"
L +^LAB(62.5,DA):5 I '$T D G D
. S MSG="This entry is locked by another user. Please try again later."
. D EN^DDIOL(MSG,"","!!") K MSG,DIE,DR,DA
. D END
S DR=".01;1;5;I ""ESCI""'[X W $C(7),!,""Enter E, S, C, or I"" S Y=5;10"
D ^DIE
L -^LAB(62.5,DA)
K DIE,DR,DA
G D
;
;
V ; input transform DD(63.08,.11,0)
I $D(LRH(2)),LRH(2)'=$E(X,1,3) K X W !,"Year received must be same as log-in year (",LRH(2)+1700,") "
Q
;
;
CK ;
S Y=1
I '$D(DUZ(2)) D Q
. W !,$C(7)," Something is wrong..."
. W !!,"I can't tell if you're really here..."
. W !!,"Ask your IRM why you don't have a DUZ(2) variable defined!",!
. S Y=-1
;
S LRAA(4)=$P($G(^DIC(4,+DUZ(2),0)),U)
I LRAA(4)="" D Q
. W $C(7),!!,"I can't tell what DIVISION you are from. Contact your IRM "
. S Y=-1
Q
;
;
LRDICS ;
S Y=0,X=$G(LRDICS)
I $L(X)=2,"SPCYEMAU"[X D C I Y K LRDICS Q
S LRDICS=$S($L($G(LRDICS)):LRDICS,1:"SPCYEMAU")
Q
;
;
C ;
I $D(LRDICS(2)) G CC
S (A,B)=0
F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)=LRDICS,$G(^(3,DUZ(2),0)) S B=B+1,B(B)=A
I B=1 S Y=B(1)_U_$P(^LRO(68,B(1),0),U) K A,B Q
I B>1,$D(LRDICS(1)) S Y=B(1)_U_$P(^LRO(68,B(1),0),U) K A,B
Q
;
;
CC ;
S (A,B)=0
F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)=LRDICS S B=B+1,B(B)=A Q
I B=1 S Y=B(1)_U_$P(^LRO(68,B(1),0),U) K A,B
Q
;
;
END ;
D V^LRU
Q
;
;
GETDEF ; Get defaults for specimen login
;
; Default values for collection sample/specimen and lab test
;
N X
;
; Default value for collection sample
S X=$$GET^XPAR("USR^DIV^PKG","LR ACCESSION DEFAULT COL SAMP","`"_LRAA,"B")
S LRSAMP=$P(X,"^"),LRSAMP(0)=$P(X,"^",2)
;
; Default value for specimen(topography)
S X=$$GET^XPAR("USR^DIV^PKG","LR ACCESSION DEFAULT SPECIMEN","`"_LRAA,"B")
S LRSPTOP=$P(X,"^"),LRSPTOP(0)=$P(X,"^",2)
;
; Default value for laboratory test
S X=$$GET^XPAR("USR^DIV^PKG","LR ACCESSION DEFAULT LAB TEST","`"_LRAA,"B")
S LRTST=$P(X,"^"),LRTST(0)=$P(X,"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAP 4607 printed Jan 18, 2025@03:07:31 Page 2
LRAP ;DALOI/STAFF - ANATOMIC PATH UTILITY ;02/10/17 09:41
+1 ;;5.2;LAB SERVICE;**72,248,259,350,462,479**;Sep 27, 1994;Build 8
+2 ;
+3 ; Called by many routines in AP package
+4 DO END
DO CK
if Y=-1
GOTO END
DO LRDICS
if Y
GOTO B
+5 SET DIC=68
SET DIC(0)="AEOQMZ"
+6 SET DIC("A")="Select ANATOMIC PATHOLOGY SECTION: "
+7 ;
+8 ;
+9 SET DIC("S")="I LRDICS[$P(^(0),U,2),$P(^(0),U,2)]"""",$D(^(3,""B"",DUZ(2)))"
+10 ;
+11 DO ^DIC
+12 KILL DIC,LRDICS
+13 if Y<1
GOTO END
+14 ;
B ;
+1 SET X=$PIECE(Y,U,2)
DO ^LRUTL
if Y=-1
GOTO END
+2 QUIT
+3 ;
+4 ;
AU ; log-in autopsy
+1 ;see routine LRAUAW
QUIT
+2 ;
+3 ;
CY ; log-in cytopath
+1 SET (LRMD,LRSIT)=""
+2 ;
+3 DO GETDEF
+4 ;
+5 SET DR=".08///"_$SELECT(LRLLOC["?":"UNKNOWN",1:LRLLOC)
+6 SET DR=DR_";.07;D:X P^LRUA;.011//^S X=LRPRAC(1);.012;.1//NOW"
+7 SET DR=DR_";S LRRC=X;.02;.99;S LRC(5)=X;1"
+8 SET DR(2,63.902)=".01;S LR(63.902)=X;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
+9 SET DR(2,63.902)=DR(2,63.902)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U);S:'LRCAPA Y=""@2"";.02;@2"
+10 QUIT
+11 ;
+12 ;
EM ; log-in electron microscopy
+1 SET (LRMD,LRSIT)=""
+2 ;
+3 DO GETDEF
+4 ;
+5 SET DR=".08///"_$SELECT(LRLLOC["?":"UNKNOWN",1:LRLLOC)
+6 SET DR=DR_";.07;D:X P^LRUA;.011//^S X=LRPRAC(1);.012;.1//NOW;S LRRC=X"
+7 SET DR=DR_";.02;.021;.99;S LRC(5)=X"
+8 SET DR(2,63.202)=".01;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
+9 SET DR(2,63.202)=DR(2,63.202)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U)"
+10 QUIT
+11 ;
+12 ;
SP ; log-in surg path
+1 SET (LRMD,LRSIT)=""
+2 SET LR("FS")=+$GET(^LAB(69.9,1,11))
+3 ;
+4 DO GETDEF
+5 ;
+6 SET DR=".08///"_$SELECT(LRLLOC["?":"UNKNOWN",1:LRLLOC)
+7 SET DR=DR_";.07//^S X=LR(.07);D:X P^LRUA;.011//^S X=LRPRAC(1);.012;.1//NOW"
+8 SET DR=DR_";S LRRC=X;.02;.99;S LRC(5)=X;S:'LR(""FS"") Y=""@1"";1.3;@1"
+9 SET DR(2,63.812)=".01;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
+10 SET DR(2,63.812)=DR(2,63.812)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U)"
+11 ;
+12 if LRABV'["SP"
SET LR("FS")=""
+13 QUIT
+14 ;
+15 ;
M ; edit path report parameters
+1 WRITE !
+2 SET DIC="^LRO(69.2,"
SET DIC(0)="AEOQM"
+3 SET DIC("S")="I ""AUCYEMSP""[$P(^(0),U,2)&($P(^(0),U,2)]"""")"
+4 DO ^DIC
KILL DIC
if Y<1
GOTO END
SET DA=+Y
+5 LOCK +^LRO(69.2,DA):5
IF '$TEST
Begin DoDot:1
+6 SET MSG="This entry is locked by another user. Please try again later."
+7 DO EN^DDIOL(MSG,"","!!")
KILL MSG,DIE,DR,DA
+8 DO END
End DoDot:1
GOTO M
+9 SET DR="[LRAPHDR]"
SET DIE="^LRO(69.2,"
+10 DO ^DIE
+11 LOCK -^LRO(69.2,DA)
+12 KILL DIE,DR,DA
+13 GOTO M
+14 ;
+15 ;
D ; Edit path descriptions
+1 WRITE !
SET DIC="^LAB(62.5,"
SET DIC(0)="AEQLM"
+2 SET DLAYGO=62.5
SET DIC("S")="I ""ESCI""[$P(^(0),U,4)"
+3 DO ^DIC
KILL DIC,DLAYGO
if X=""!(X[U)
GOTO END
SET DA=+Y
+4 SET DIE("NO^")=""
SET DIE="^LAB(62.5,"
+5 LOCK +^LAB(62.5,DA):5
IF '$TEST
Begin DoDot:1
+6 SET MSG="This entry is locked by another user. Please try again later."
+7 DO EN^DDIOL(MSG,"","!!")
KILL MSG,DIE,DR,DA
+8 DO END
End DoDot:1
GOTO D
+9 SET DR=".01;1;5;I ""ESCI""'[X W $C(7),!,""Enter E, S, C, or I"" S Y=5;10"
+10 DO ^DIE
+11 LOCK -^LAB(62.5,DA)
+12 KILL DIE,DR,DA
+13 GOTO D
+14 ;
+15 ;
V ; input transform DD(63.08,.11,0)
+1 IF $DATA(LRH(2))
IF LRH(2)'=$EXTRACT(X,1,3)
KILL X
WRITE !,"Year received must be same as log-in year (",LRH(2)+1700,") "
+2 QUIT
+3 ;
+4 ;
CK ;
+1 SET Y=1
+2 IF '$DATA(DUZ(2))
Begin DoDot:1
+3 WRITE !,$CHAR(7)," Something is wrong..."
+4 WRITE !!,"I can't tell if you're really here..."
+5 WRITE !!,"Ask your IRM why you don't have a DUZ(2) variable defined!",!
+6 SET Y=-1
End DoDot:1
QUIT
+7 ;
+8 SET LRAA(4)=$PIECE($GET(^DIC(4,+DUZ(2),0)),U)
+9 IF LRAA(4)=""
Begin DoDot:1
+10 WRITE $CHAR(7),!!,"I can't tell what DIVISION you are from. Contact your IRM "
+11 SET Y=-1
End DoDot:1
QUIT
+12 QUIT
+13 ;
+14 ;
LRDICS ;
+1 SET Y=0
SET X=$GET(LRDICS)
+2 IF $LENGTH(X)=2
IF "SPCYEMAU"[X
DO C
IF Y
KILL LRDICS
QUIT
+3 SET LRDICS=$SELECT($LENGTH($GET(LRDICS)):LRDICS,1:"SPCYEMAU")
+4 QUIT
+5 ;
+6 ;
C ;
+1 IF $DATA(LRDICS(2))
GOTO CC
+2 SET (A,B)=0
+3 FOR
SET A=$ORDER(^LRO(68,A))
if 'A
QUIT
IF $PIECE($GET(^LRO(68,A,0)),"^",2)=LRDICS
IF $GET(^(3,DUZ(2),0))
SET B=B+1
SET B(B)=A
+4 IF B=1
SET Y=B(1)_U_$PIECE(^LRO(68,B(1),0),U)
KILL A,B
QUIT
+5 IF B>1
IF $DATA(LRDICS(1))
SET Y=B(1)_U_$PIECE(^LRO(68,B(1),0),U)
KILL A,B
+6 QUIT
+7 ;
+8 ;
CC ;
+1 SET (A,B)=0
+2 FOR
SET A=$ORDER(^LRO(68,A))
if 'A
QUIT
IF $PIECE($GET(^LRO(68,A,0)),"^",2)=LRDICS
SET B=B+1
SET B(B)=A
QUIT
+3 IF B=1
SET Y=B(1)_U_$PIECE(^LRO(68,B(1),0),U)
KILL A,B
+4 QUIT
+5 ;
+6 ;
END ;
+1 DO V^LRU
+2 QUIT
+3 ;
+4 ;
GETDEF ; Get defaults for specimen login
+1 ;
+2 ; Default values for collection sample/specimen and lab test
+3 ;
+4 NEW X
+5 ;
+6 ; Default value for collection sample
+7 SET X=$$GET^XPAR("USR^DIV^PKG","LR ACCESSION DEFAULT COL SAMP","`"_LRAA,"B")
+8 SET LRSAMP=$PIECE(X,"^")
SET LRSAMP(0)=$PIECE(X,"^",2)
+9 ;
+10 ; Default value for specimen(topography)
+11 SET X=$$GET^XPAR("USR^DIV^PKG","LR ACCESSION DEFAULT SPECIMEN","`"_LRAA,"B")
+12 SET LRSPTOP=$PIECE(X,"^")
SET LRSPTOP(0)=$PIECE(X,"^",2)
+13 ;
+14 ; Default value for laboratory test
+15 SET X=$$GET^XPAR("USR^DIV^PKG","LR ACCESSION DEFAULT LAB TEST","`"_LRAA,"B")
+16 SET LRTST=$PIECE(X,"^")
SET LRTST(0)=$PIECE(X,"^",2)
+17 QUIT
