LRAPBK ;DALOI/STAFF - AP LOG BOOK ;02/21/13 08:08
;;5.2;LAB SERVICE;**51,72,201,274,350,427**;Sep 27, 1994;Build 33
;
; Reference to PXAPIOE supported by ICR #1541
;
; The code for functionality of LR*5.2*51 has changed with patch 72.
; The functionality that came with LR*5.2*51 remains the same.
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
N DIR,DIRUT,DTOUT,DUOUT,LRB
D ^LRAP G:'$D(Y) END D XR^LRU
W !!?20,LRO(68)," LOG BOOK"
;
S DIR(0)="SO^0:No;1:Yes;2:Only Topography and Morphology Codes",DIR("A")="Print SNOMED codes",DIR("B")="No"
D ^DIR
I $D(DIRUT) D END Q
S LRB=Y
;
K DIR
S DIR(0)="Y",DIR("A")="Print Single Accession",DIR("B")="NO"
D ^DIR
I $D(DIRUT) Q
I Y=1 D ACC Q
;
S LRH(2)=$E(DT,1,3),LRH(0)=$$FMTE^XLFDT(LRH(2)_"0000","D")
;
K DIR
S DIR(0)="DO^::AEP^",DIR("A")="Select Log Book Year",DIR("B")=LRH(0)
F D Q:$D(DIRUT)!($G(LRH(0)))
. D ^DIR
. I $D(DIRUT) Q
. S LRH(2)=$E(Y,1,3),LRH(0)=$$FMTE^XLFDT(LRH(2)_"0000","D")
. I '$D(^LR(LRXREF,LRH(2),LRABV)) W $C(7)," No entries for ",LRH(0) K LRH(0) Q
I $D(DIRUT) D END Q
;
;
N1 R !,"Start with Acc #: ",X:DTIME G:X=""!(X[U) END I X'?1N.N W $C(7),!!,"NUMBERS ONLY !!" G N1
S LRN(1)=X
;
;
N2 R !,"Go to Acc #: LAST // ",X:DTIME G:X='$T!(X[U) END S:X="" X=999999 I X'?1N.N W $C(7),!!,"NUMBERS ONLY !!",!! G N2
;
S LRN(2)=X,ZTRTN="QUE^LRAPBK",ZTDESC="Anatomic Path Log Book",ZTSAVE("LR*")="" D BEG^LRUTL G:POP!($D(ZTSK)) END
;
;
QUE ; Print the log book
N LRPSNM
; Flag to indicate which SNOMED system to print
S LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
I LRPSNM<1 S LRPSNM=2
;
U IO D L^LRU,S^LRU S P(9)="",LRW=LRH(2)_"0000" D H S LR("F")=1
S LRAN=LRN(1)-1
F S LRAN=$O(^LR(LRXREF,LRH(2),LRABV,LRAN)) Q:'LRAN!(LRAN>LRN(2))!(LR("Q")) D SH
W:IOST'?1"C".E @IOF
D END^LRUTL,END
Q
;
;
ACC ; Print log book entry for a single accession
; Called from above.
N DFN,LR,LRAA,LRABV,LRACC,LRAD,LRAN,LRAX,LRBSAV,LRCAPA,LRDFN,LRDPAF,LRDPF,LREND,LRH,LRIDIV,LRIDT,LRO,LRSCR,LRSF,LRT,LRU,LRVBY,LRWHO,X,Y
;
S LRSCR=LRSS,LRBSAV=LRB
F D Q:LREND!LRSTOP
. S LRACC="",(LREND,LRSTOP,LRVBY)=0,LRB=LRBSAV
. D ENA^LRWU4(LRSCR)
. I LRAN<1 S LREND=1 Q
. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." Q
. K LRDFN,LRDPF,LRIDT,LRSS
. S LRSS=$P(^LRO(68,LRAA,0),"^",2),LRDFN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^"),LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
. I LRSS=""!(LRIDT<1)!(LRDFN<1) W !,"Incomplete accession - unable to identify results." Q
. I LRSS'?1(1"SP",1"CY",1"EM",1"AU") W !,"This option only supports SP, CY, EM and AU subscripted accessions." Q
. D ACCB
;
D END^LRUTL,END
Q
;
;
ACCB ; Build variables for printing.
;
N LREND,LRSINGLE,LRSTOP,LRX
S LRX=^LRO(68,LRAA,0)
S (LRO(68),LRAA(1))=$P(LRX,U),LRAA(2)=LRSS,LRABV=$P(LRX,U,11)
S LRACC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
;
S X=^DIC(4,DUZ(2),0),LRAA(4)=$P(X,"^"),LRAA(5)=$E($P($G(^(1)),"^",3),1,30),X=+$P(X,"^",2),LRAA(6)=$P($G(^DIC(5,X,0)),"^",2)
;
S LRH(2)=$E(LRAD,1,3),LRH(0)=LRH(2)+1700
S (LRN(1),LRN(2))=LRAN
D XR^LRU
;
S (LREND,LRSTOP)=0,LRSINGLE=1
S %ZIS="Q",ZTSAVE("DFN")="",ZTSAVE("LR*")="",ZTRTN="QUE^LRAPBK"
D IO^LRWU
Q
;
;
SH ;
N LRX
S P(13)="",LRDFN=$O(^LR(LRXREF,LRH(2),LRABV,LRAN,0)) Q:'LRDFN!(LR("Q")) I "SPCYEM"[LRSS S LRI=$O(^(LRDFN,0)) Q:'LRI
D:$Y>(IOSL-6) H Q:LR("Q")
K LRDPF,LRLLOC
D PT^LRX
I $G(LREND) K LREND Q
;
S LRP=PNM,P(0)=$S(LRDPF=2:"PATIENT",1:"OTHER")
;
I "SPCYEM"[LRSS Q:'$D(^LR(LRDFN,LRSS,LRI,0)) D
. S (LRX(0),X)=^LR(LRDFN,LRSS,LRI,0),LRX("ORU")=$G(^LR(LRDFN,LRSS,LRI,"ORU"))
. S LRLLOC=$P(X,U,8),Y=$P(X,U,7) D S
. S P(2)=Y,Y=$P(X,U,2) D S
. S P(1)=$E(Y,1,12),Y=$P(X,U,13) D S
. S P(13)=Y,LRSPDT=$$FMTE^XLFDT(($P(X,U,1)),"1M"),X=$P(X,U,10)
;
I LRSS="AU" Q:'$D(^LR(LRDFN,"AU")) D
. S (LRX(0),X)=^LR(LRDFN,"AU"),LRX("ORU")=$G(^LR(LRDFN,"AU","ORU"))
. S LRLLOC=$P(X,U,5),Y=$P(X,U,12) D S
. S P(2)=Y,Y=$P(X,U,7) D S
. S P(9)=$E(Y,1,15),Y=$P(X,U,2) D S
. S LR("ASST")=Y,Y=$P(X,U,10) D S
. S P(1)=$E(Y,1,12),X=+X
;
S T=$$FMTE^XLFDT(X,"1P") S T=$P(T,",",1) S T=$TR(T," ","/")
W !,$J(T,6),?7,$J(LRAN,5),?14 W:P(0)'="PATIENT" "#"
W $E(LRP,1,18),?34,SSN(1),?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1),!?5,"Patient ID: ",SSN
S LRLLOC("TY")=$P($G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,0)),U,11)
S LRLLOC("TY")=$S(LRLLOC("TY")="":"InPatient","WI"[LRLLOC("TY"):"InPatient",1:"OutPatient")
W !?5,LRLLOC("TY")
;
W ?29,"Accession [UID]: "_$P(LRX(0),"^",6)_" ["_$P(LRX("ORU"),"^")_"]"
;
I $G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,"PCE")) D
. N IEN,LRENC,LRSTR,LRX,LRY,X,Y
. S LRSTR=^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,"PCE")
. F IEN=1:1 S LRX=$P(LRSTR,";",IEN) Q:'LRX D
. . K LRY
. . D GETCPT^PXAPIOE(LRX,"LRY","ERR")
. . S LRY=0
. . F S LRY=$O(LRY(LRY)) Q:'LRY S LRENC(LRX_"."_LRY)=LRY(LRY)
. I '$O(LRENC(0)) Q
. W !,"CPT Code: "
. S IEN=0
. F S IEN=$O(LRENC(IEN)) Q:'IEN W $P(LRENC(IEN),U)_"X"_$P(LRENC(IEN),U,16)_" " W:$X>70 !
;
I "SPCYEM"[LRSS D
. W !,"Date specimen taken: ",LRSPDT
. S Y=$P($G(^LRO(68,LRAA,1,LRW,1,LRAN,0)),"^",10)
. I Y,$D(^VA(200,Y,0)) W ?39," Entered by: ",$P(^(0),"^")
;
I P(13)'="" W !?39,"Released by: ",P(13)
S Y=+$G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,.4)) I Y,Y'=DUZ(2) W !,$P($G(^DIC(4,Y,0)),U)
;
I LRSS="AU" D
. S DA=LRDFN D D^LRAUAW
. S Y=LR(63,12) D D^LRU
. W !?14,"Date died: ",Y,?49,"Path resident:",?64,P(9)
. D AS
;
; Print specimens and any surgery case source references
I LRSS?1(1"SP",1"CY",1"EM") D
. N Z
. S Z=0
. F S Z=$O(^LR(LRDFN,LRSS,LRI,.1,Z)) Q:'Z D Q:LR("Q")
. . I $Y>(IOSL-6) D H1 Q:LR("Q")
. . S Z(1)=$P(^LR(LRDFN,LRSS,LRI,.1,Z,0),"^")
. . W !,?$S($L(Z(1))<61:14,1:2),Z(1)
. I LR("Q") Q
. D SRCASE
;
Q:LR("Q")
;
; Print SNOMED codes
I LRB,LRSS?1(1"SP",1"CY",1"EM"),$D(^LR(LRDFN,LRSS,LRI,2,0)) D Q:LR("Q")
. I $Y>(IOSL-6) D H1 Q:LR("Q")
. W !?14,"SNOMED codes:"
. D ^LRAPBK1
;
I LRB,LRSS="AU",$O(^LR(LRDFN,"AY",0)) D Q:LR("Q")
. I $Y>(IOSL-6) D H1 Q:LR("Q")
. W !?14,"SNOMED codes:"
. D AU^LRAPBK1
;
I LRSS'="AU" D D Q:LR("Q")
;
Q:LR("Q")
W !,LR("%")
Q
;
;
D ;
F Z(1)=99,97 Q:LR("Q") D
. S Z=0
. F S Z=$O(^LR(LRDFN,LRSS,LRI,Z(1),Z)) Q:'Z D:$Y>(IOSL-6) H1 Q:LR("Q") W !?4,^LR(LRDFN,LRSS,LRI,Z(1),Z,0)
Q
;
;
H ;
I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU
I $G(LRSINGLE) W !,"LOG BOOK entry for accession ",LRACC,!
E W !,LRO(68)," (",LRABV,") LOG BOOK for ",LRH(0),!
W "# =Demographic data in file other than PATIENT file"
W !,"Date",?8,"Num",?14,"Patient",?35,"ID",?40,"LOC",?49,"PHYSICIAN",?67,"PATHOLOGIST",!,LR("%")
Q
;
;
H1 ;
D H Q:LR("Q")
W !,$J(T,5),?7,$J(LRAN,5),?14
W:P(0)'="PATIENT" "#"
W $E(LRP,1,18),?34,SSN(1),?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1)
Q
;
;
S ;
S Y=$P($G(^VA(200,+Y,0)),U)
Q
;
;
AS I $D(^LRO(68,LRAA,1,LRW,1,LRAN,0)) S Y=$P(^(0),"^",10) D S W ! W:Y]"" ?14,"Entered by: ",Y W:LR("ASST")]"" ?49,"Autopsy Asst: ",LR("ASST")
Q
;
;
END ;
K LRSPDT D V^LRU
Q
;
;
SRCASE ; Print related surgery case info
;
N LRDATA,LRFIELDNAME,LRFIELDNUM,LRIENS,LRJ,LRK,LRREF,LRSRTN,LRSUBFILE,LRTAB,LRX,LRY
;
;ZEXCEPT: IOM,IOSL,LRDFN,LRI,LRSS
;
; Print related surgical case #
S LRIENS=LRDFN_","_LRSS_","_LRI_",0"
I $D(^LR(LRDFN,"EPR","AD",LRIENS,1)) D
. S LRJ=$O(^LR(LRDFN,"EPR","AD",LRIENS,1,0)),LRREF=LRJ_","_LRDFN_","
. D GETDATA^LRUEPR(.LRDATA,LRREF)
. S LRSRTN=LRDATA(63.00013,LRREF,1,"I")
. I $P(LRSRTN,";",3)="" W !,"Related Surgery Case #"_$P(LRSRTN,";")
. E W !,$P(LRSRTN,";",3)
;
I '$$GET^XPAR("DIV^PKG","LR AP SURGERY REFERENCE",1,"Q") Q
;
; Print source of surgical case info copied to Lab package.
F LRJ=.2,.3,.4,.5 D Q:LR("Q")
. S LRIENS=LRDFN_","_LRSS_","_LRI_","_LRJ_",0"
. I '$D(^LR(LRDFN,"EPR","AD",LRIENS,1)) Q
. I $Y>(IOSL-6) D H1 Q:LR("Q")
. S LRK=$O(^LR(LRDFN,"EPR","AD",LRIENS,1,0)),LRREF=LRK_","_LRDFN_","
. K LRDATA
. D GETDATA^LRUEPR(.LRDATA,LRREF)
. S LRSUBFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
. S LRFIELDNUM=((LRJ*10)+11)/1000
. S LRFIELDNAME=$$GET1^DID(LRSUBFILE,LRFIELDNUM,"","LABEL")
. S LRX=$P(LRDATA(63.00013,LRREF,1,"I"),";",3)
. W !,LRFIELDNAME_": " S LRTAB=$X
. I IOM'<($L(LRX)+LRTAB) W LRX Q
. F LRK=1:1:$L(LRX," ") D
. . S LRY=$P(LRX," ",LRK)
. . I $X>LRTAB,($X+$L(LRY)+1)>IOM W !,?LRTAB,LRY Q
. . W:$X>LRTAB " " W LRY
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBK 8648 printed Apr 09, 2024@21:24:39 Page 2
LRAPBK ;DALOI/STAFF - AP LOG BOOK ;02/21/13 08:08
+1 ;;5.2;LAB SERVICE;**51,72,201,274,350,427**;Sep 27, 1994;Build 33
+2 ;
+3 ; Reference to PXAPIOE supported by ICR #1541
+4 ;
+5 ; The code for functionality of LR*5.2*51 has changed with patch 72.
+6 ; The functionality that came with LR*5.2*51 remains the same.
+7 ;
+8 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+9 ; used in conjunction with Eclipse M-editor.
+10 ;
+11 NEW DIR,DIRUT,DTOUT,DUOUT,LRB
+12 DO ^LRAP
if '$DATA(Y)
GOTO END
DO XR^LRU
+13 WRITE !!?20,LRO(68)," LOG BOOK"
+14 ;
+15 SET DIR(0)="SO^0:No;1:Yes;2:Only Topography and Morphology Codes"
SET DIR("A")="Print SNOMED codes"
SET DIR("B")="No"
+16 DO ^DIR
+17 IF $DATA(DIRUT)
DO END
QUIT
+18 SET LRB=Y
+19 ;
+20 KILL DIR
+21 SET DIR(0)="Y"
SET DIR("A")="Print Single Accession"
SET DIR("B")="NO"
+22 DO ^DIR
+23 IF $DATA(DIRUT)
QUIT
+24 IF Y=1
DO ACC
QUIT
+25 ;
+26 SET LRH(2)=$EXTRACT(DT,1,3)
SET LRH(0)=$$FMTE^XLFDT(LRH(2)_"0000","D")
+27 ;
+28 KILL DIR
+29 SET DIR(0)="DO^::AEP^"
SET DIR("A")="Select Log Book Year"
SET DIR("B")=LRH(0)
+30 FOR
Begin DoDot:1
+31 DO ^DIR
+32 IF $DATA(DIRUT)
QUIT
+33 SET LRH(2)=$EXTRACT(Y,1,3)
SET LRH(0)=$$FMTE^XLFDT(LRH(2)_"0000","D")
+34 IF '$DATA(^LR(LRXREF,LRH(2),LRABV))
WRITE $CHAR(7)," No entries for ",LRH(0)
KILL LRH(0)
QUIT
End DoDot:1
if $DATA(DIRUT)!($GET(LRH(0)))
QUIT
+35 IF $DATA(DIRUT)
DO END
QUIT
+36 ;
+37 ;
N1 READ !,"Start with Acc #: ",X:DTIME
if X=""!(X[U)
GOTO END
IF X'?1N.N
WRITE $CHAR(7),!!,"NUMBERS ONLY !!"
GOTO N1
+1 SET LRN(1)=X
+2 ;
+3 ;
N2 READ !,"Go to Acc #: LAST // ",X:DTIME
if X='$TEST!(X[U)
GOTO END
if X=""
SET X=999999
IF X'?1N.N
WRITE $CHAR(7),!!,"NUMBERS ONLY !!",!!
GOTO N2
+1 ;
+2 SET LRN(2)=X
SET ZTRTN="QUE^LRAPBK"
SET ZTDESC="Anatomic Path Log Book"
SET ZTSAVE("LR*")=""
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
+3 ;
+4 ;
QUE ; Print the log book
+1 NEW LRPSNM
+2 ; Flag to indicate which SNOMED system to print
+3 SET LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
+4 IF LRPSNM<1
SET LRPSNM=2
+5 ;
+6 USE IO
DO L^LRU
DO S^LRU
SET P(9)=""
SET LRW=LRH(2)_"0000"
DO H
SET LR("F")=1
+7 SET LRAN=LRN(1)-1
+8 FOR
SET LRAN=$ORDER(^LR(LRXREF,LRH(2),LRABV,LRAN))
if 'LRAN!(LRAN>LRN(2))!(LR("Q"))
QUIT
DO SH
+9 if IOST'?1"C".E
WRITE @IOF
+10 DO END^LRUTL
DO END
+11 QUIT
+12 ;
+13 ;
ACC ; Print log book entry for a single accession
+1 ; Called from above.
+2 NEW DFN,LR,LRAA,LRABV,LRACC,LRAD,LRAN,LRAX,LRBSAV,LRCAPA,LRDFN,LRDPAF,LRDPF,LREND,LRH,LRIDIV,LRIDT,LRO,LRSCR,LRSF,LRT,LRU,LRVBY,LRWHO,X,Y
+3 ;
+4 SET LRSCR=LRSS
SET LRBSAV=LRB
+5 FOR
Begin DoDot:1
+6 SET LRACC=""
SET (LREND,LRSTOP,LRVBY)=0
SET LRB=LRBSAV
+7 DO ENA^LRWU4(LRSCR)
+8 IF LRAN<1
SET LREND=1
QUIT
+9 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
QUIT
+10 KILL LRDFN,LRDPF,LRIDT,LRSS
+11 SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^")
SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+12 IF LRSS=""!(LRIDT<1)!(LRDFN<1)
WRITE !,"Incomplete accession - unable to identify results."
QUIT
+13 IF LRSS'?1(1"SP",1"CY",1"EM",1"AU")
WRITE !,"This option only supports SP, CY, EM and AU subscripted accessions."
QUIT
+14 DO ACCB
End DoDot:1
if LREND!LRSTOP
QUIT
+15 ;
+16 DO END^LRUTL
DO END
+17 QUIT
+18 ;
+19 ;
ACCB ; Build variables for printing.
+1 ;
+2 NEW LREND,LRSINGLE,LRSTOP,LRX
+3 SET LRX=^LRO(68,LRAA,0)
+4 SET (LRO(68),LRAA(1))=$PIECE(LRX,U)
SET LRAA(2)=LRSS
SET LRABV=$PIECE(LRX,U,11)
+5 SET LRACC=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
+6 ;
+7 SET X=^DIC(4,DUZ(2),0)
SET LRAA(4)=$PIECE(X,"^")
SET LRAA(5)=$EXTRACT($PIECE($GET(^(1)),"^",3),1,30)
SET X=+$PIECE(X,"^",2)
SET LRAA(6)=$PIECE($GET(^DIC(5,X,0)),"^",2)
+8 ;
+9 SET LRH(2)=$EXTRACT(LRAD,1,3)
SET LRH(0)=LRH(2)+1700
+10 SET (LRN(1),LRN(2))=LRAN
+11 DO XR^LRU
+12 ;
+13 SET (LREND,LRSTOP)=0
SET LRSINGLE=1
+14 SET %ZIS="Q"
SET ZTSAVE("DFN")=""
SET ZTSAVE("LR*")=""
SET ZTRTN="QUE^LRAPBK"
+15 DO IO^LRWU
+16 QUIT
+17 ;
+18 ;
SH ;
+1 NEW LRX
+2 SET P(13)=""
SET LRDFN=$ORDER(^LR(LRXREF,LRH(2),LRABV,LRAN,0))
if 'LRDFN!(LR("Q"))
QUIT
IF "SPCYEM"[LRSS
SET LRI=$ORDER(^(LRDFN,0))
if 'LRI
QUIT
+3 if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
+4 KILL LRDPF,LRLLOC
+5 DO PT^LRX
+6 IF $GET(LREND)
KILL LREND
QUIT
+7 ;
+8 SET LRP=PNM
SET P(0)=$SELECT(LRDPF=2:"PATIENT",1:"OTHER")
+9 ;
+10 IF "SPCYEM"[LRSS
if '$DATA(^LR(LRDFN,LRSS,LRI,0))
QUIT
Begin DoDot:1
+11 SET (LRX(0),X)=^LR(LRDFN,LRSS,LRI,0)
SET LRX("ORU")=$GET(^LR(LRDFN,LRSS,LRI,"ORU"))
+12 SET LRLLOC=$PIECE(X,U,8)
SET Y=$PIECE(X,U,7)
DO S
+13 SET P(2)=Y
SET Y=$PIECE(X,U,2)
DO S
+14 SET P(1)=$EXTRACT(Y,1,12)
SET Y=$PIECE(X,U,13)
DO S
+15 SET P(13)=Y
SET LRSPDT=$$FMTE^XLFDT(($PIECE(X,U,1)),"1M")
SET X=$PIECE(X,U,10)
End DoDot:1
+16 ;
+17 IF LRSS="AU"
if '$DATA(^LR(LRDFN,"AU"))
QUIT
Begin DoDot:1
+18 SET (LRX(0),X)=^LR(LRDFN,"AU")
SET LRX("ORU")=$GET(^LR(LRDFN,"AU","ORU"))
+19 SET LRLLOC=$PIECE(X,U,5)
SET Y=$PIECE(X,U,12)
DO S
+20 SET P(2)=Y
SET Y=$PIECE(X,U,7)
DO S
+21 SET P(9)=$EXTRACT(Y,1,15)
SET Y=$PIECE(X,U,2)
DO S
+22 SET LR("ASST")=Y
SET Y=$PIECE(X,U,10)
DO S
+23 SET P(1)=$EXTRACT(Y,1,12)
SET X=+X
End DoDot:1
+24 ;
+25 SET T=$$FMTE^XLFDT(X,"1P")
SET T=$PIECE(T,",",1)
SET T=$TRANSLATE(T," ","/")
+26 WRITE !,$JUSTIFY(T,6),?7,$JUSTIFY(LRAN,5),?14
if P(0)'="PATIENT"
WRITE "#"
+27 WRITE $EXTRACT(LRP,1,18),?34,SSN(1),?40,$EXTRACT(LRLLOC,1,8),?49,$EXTRACT(P(2),1,16),?67,P(1),!?5,"Patient ID: ",SSN
+28 SET LRLLOC("TY")=$PIECE($GET(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,0)),U,11)
+29 SET LRLLOC("TY")=$SELECT(LRLLOC("TY")="":"InPatient","WI"[LRLLOC("TY"):"InPatient",1:"OutPatient")
+30 WRITE !?5,LRLLOC("TY")
+31 ;
+32 WRITE ?29,"Accession [UID]: "_$PIECE(LRX(0),"^",6)_" ["_$PIECE(LRX("ORU"),"^")_"]"
+33 ;
+34 IF $GET(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,"PCE"))
Begin DoDot:1
+35 NEW IEN,LRENC,LRSTR,LRX,LRY,X,Y
+36 SET LRSTR=^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,"PCE")
+37 FOR IEN=1:1
SET LRX=$PIECE(LRSTR,";",IEN)
if 'LRX
QUIT
Begin DoDot:2
+38 KILL LRY
+39 DO GETCPT^PXAPIOE(LRX,"LRY","ERR")
+40 SET LRY=0
+41 FOR
SET LRY=$ORDER(LRY(LRY))
if 'LRY
QUIT
SET LRENC(LRX_"."_LRY)=LRY(LRY)
End DoDot:2
+42 IF '$ORDER(LRENC(0))
QUIT
+43 WRITE !,"CPT Code: "
+44 SET IEN=0
+45 FOR
SET IEN=$ORDER(LRENC(IEN))
if 'IEN
QUIT
WRITE $PIECE(LRENC(IEN),U)_"X"_$PIECE(LRENC(IEN),U,16)_" "
if $X>70
WRITE !
End DoDot:1
+46 ;
+47 IF "SPCYEM"[LRSS
Begin DoDot:1
+48 WRITE !,"Date specimen taken: ",LRSPDT
+49 SET Y=$PIECE($GET(^LRO(68,LRAA,1,LRW,1,LRAN,0)),"^",10)
+50 IF Y
IF $DATA(^VA(200,Y,0))
WRITE ?39," Entered by: ",$PIECE(^(0),"^")
End DoDot:1
+51 ;
+52 IF P(13)'=""
WRITE !?39,"Released by: ",P(13)
+53 SET Y=+$GET(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,.4))
IF Y
IF Y'=DUZ(2)
WRITE !,$PIECE($GET(^DIC(4,Y,0)),U)
+54 ;
+55 IF LRSS="AU"
Begin DoDot:1
+56 SET DA=LRDFN
DO D^LRAUAW
+57 SET Y=LR(63,12)
DO D^LRU
+58 WRITE !?14,"Date died: ",Y,?49,"Path resident:",?64,P(9)
+59 DO AS
End DoDot:1
+60 ;
+61 ; Print specimens and any surgery case source references
+62 IF LRSS?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+63 NEW Z
+64 SET Z=0
+65 FOR
SET Z=$ORDER(^LR(LRDFN,LRSS,LRI,.1,Z))
if 'Z
QUIT
Begin DoDot:2
+66 IF $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
+67 SET Z(1)=$PIECE(^LR(LRDFN,LRSS,LRI,.1,Z,0),"^")
+68 WRITE !,?$SELECT($LENGTH(Z(1))<61:14,1:2),Z(1)
End DoDot:2
if LR("Q")
QUIT
+69 IF LR("Q")
QUIT
+70 DO SRCASE
End DoDot:1
+71 ;
+72 if LR("Q")
QUIT
+73 ;
+74 ; Print SNOMED codes
+75 IF LRB
IF LRSS?1(1"SP",1"CY",1"EM")
IF $DATA(^LR(LRDFN,LRSS,LRI,2,0))
Begin DoDot:1
+76 IF $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
+77 WRITE !?14,"SNOMED codes:"
+78 DO ^LRAPBK1
End DoDot:1
if LR("Q")
QUIT
+79 ;
+80 IF LRB
IF LRSS="AU"
IF $ORDER(^LR(LRDFN,"AY",0))
Begin DoDot:1
+81 IF $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
+82 WRITE !?14,"SNOMED codes:"
+83 DO AU^LRAPBK1
End DoDot:1
if LR("Q")
QUIT
+84 ;
+85 IF LRSS'="AU"
DO D
if LR("Q")
QUIT
+86 ;
+87 if LR("Q")
QUIT
+88 WRITE !,LR("%")
+89 QUIT
+90 ;
+91 ;
D ;
+1 FOR Z(1)=99,97
if LR("Q")
QUIT
Begin DoDot:1
+2 SET Z=0
+3 FOR
SET Z=$ORDER(^LR(LRDFN,LRSS,LRI,Z(1),Z))
if 'Z
QUIT
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
WRITE !?4,^LR(LRDFN,LRSS,LRI,Z(1),Z,0)
End DoDot:1
+4 QUIT
+5 ;
+6 ;
H ;
+1 IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+2 DO F^LRU
+3 IF $GET(LRSINGLE)
WRITE !,"LOG BOOK entry for accession ",LRACC,!
+4 IF '$TEST
WRITE !,LRO(68)," (",LRABV,") LOG BOOK for ",LRH(0),!
+5 WRITE "# =Demographic data in file other than PATIENT file"
+6 WRITE !,"Date",?8,"Num",?14,"Patient",?35,"ID",?40,"LOC",?49,"PHYSICIAN",?67,"PATHOLOGIST",!,LR("%")
+7 QUIT
+8 ;
+9 ;
H1 ;
+1 DO H
if LR("Q")
QUIT
+2 WRITE !,$JUSTIFY(T,5),?7,$JUSTIFY(LRAN,5),?14
+3 if P(0)'="PATIENT"
WRITE "#"
+4 WRITE $EXTRACT(LRP,1,18),?34,SSN(1),?40,$EXTRACT(LRLLOC,1,8),?49,$EXTRACT(P(2),1,16),?67,P(1)
+5 QUIT
+6 ;
+7 ;
S ;
+1 SET Y=$PIECE($GET(^VA(200,+Y,0)),U)
+2 QUIT
+3 ;
+4 ;
AS IF $DATA(^LRO(68,LRAA,1,LRW,1,LRAN,0))
SET Y=$PIECE(^(0),"^",10)
DO S
WRITE !
if Y]""
WRITE ?14,"Entered by: ",Y
if LR("ASST")]""
WRITE ?49,"Autopsy Asst: ",LR("ASST")
+1 QUIT
+2 ;
+3 ;
END ;
+1 KILL LRSPDT
DO V^LRU
+2 QUIT
+3 ;
+4 ;
SRCASE ; Print related surgery case info
+1 ;
+2 NEW LRDATA,LRFIELDNAME,LRFIELDNUM,LRIENS,LRJ,LRK,LRREF,LRSRTN,LRSUBFILE,LRTAB,LRX,LRY
+3 ;
+4 ;ZEXCEPT: IOM,IOSL,LRDFN,LRI,LRSS
+5 ;
+6 ; Print related surgical case #
+7 SET LRIENS=LRDFN_","_LRSS_","_LRI_",0"
+8 IF $DATA(^LR(LRDFN,"EPR","AD",LRIENS,1))
Begin DoDot:1
+9 SET LRJ=$ORDER(^LR(LRDFN,"EPR","AD",LRIENS,1,0))
SET LRREF=LRJ_","_LRDFN_","
+10 DO GETDATA^LRUEPR(.LRDATA,LRREF)
+11 SET LRSRTN=LRDATA(63.00013,LRREF,1,"I")
+12 IF $PIECE(LRSRTN,";",3)=""
WRITE !,"Related Surgery Case #"_$PIECE(LRSRTN,";")
+13 IF '$TEST
WRITE !,$PIECE(LRSRTN,";",3)
End DoDot:1
+14 ;
+15 IF '$$GET^XPAR("DIV^PKG","LR AP SURGERY REFERENCE",1,"Q")
QUIT
+16 ;
+17 ; Print source of surgical case info copied to Lab package.
+18 FOR LRJ=.2,.3,.4,.5
Begin DoDot:1
+19 SET LRIENS=LRDFN_","_LRSS_","_LRI_","_LRJ_",0"
+20 IF '$DATA(^LR(LRDFN,"EPR","AD",LRIENS,1))
QUIT
+21 IF $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
+22 SET LRK=$ORDER(^LR(LRDFN,"EPR","AD",LRIENS,1,0))
SET LRREF=LRK_","_LRDFN_","
+23 KILL LRDATA
+24 DO GETDATA^LRUEPR(.LRDATA,LRREF)
+25 SET LRSUBFILE=$SELECT(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
+26 SET LRFIELDNUM=((LRJ*10)+11)/1000
+27 SET LRFIELDNAME=$$GET1^DID(LRSUBFILE,LRFIELDNUM,"","LABEL")
+28 SET LRX=$PIECE(LRDATA(63.00013,LRREF,1,"I"),";",3)
+29 WRITE !,LRFIELDNAME_": "
SET LRTAB=$X
+30 IF IOM'<($LENGTH(LRX)+LRTAB)
WRITE LRX
QUIT
+31 FOR LRK=1:1:$LENGTH(LRX," ")
Begin DoDot:2
+32 SET LRY=$PIECE(LRX," ",LRK)
+33 IF $X>LRTAB
IF ($X+$LENGTH(LRY)+1)>IOM
WRITE !,?LRTAB,LRY
QUIT
+34 if $X>LRTAB
WRITE " "
WRITE LRY
End DoDot:2
End DoDot:1
if LR("Q")
QUIT
+35 ;
+36 QUIT
