LRAPPF1 ;DALOI/STAFF - ANAT PATH FILE PRINT BY PT ;11/17/11 10:59
;;5.2;LAB SERVICE;**72,173,201,259,362,392,350**;Sep 27, 1994;Build 230
;
;Reference to ^DIC supported by IA #916
;
I $G(LRSF515)="" N LRSF515 S LRSF515=0
;
S F=0
F S F=$O(^TMP($J,F)) Q:'F!(LR("Q")) D
. S F(1)=$P(^DIC(F,0),"^"),F(2)=^DIC(F,0,"GL")
. K LR("F") D H S LR("F")=1 D W
Q:LR("Q")
D ^LRAPPF2
Q
;
;
W ;
S W=0
F LRB=0:0 S W=$O(^TMP($J,F,W)) Q:W=""!(LR("Q")) D LR
Q
;
;
LR ;
S LRDFN=0
F S LRDFN=$O(^TMP($J,F,W,LRDFN)) Q:'LRDFN!(LR("Q")) D NM
Q
;
;
NM ;
S X=^LR(LRDFN,0),LRDPF=$P(X,U,2),N=$P(X,"^",3),N=@(F(2)_N_",0)")
S LRP=$P(N,"^"),SSN=$P(N,"^",9),Y=$P(N,"^",3)
D D^LRU,SSN^LRU S DOB=$S(Y'[1700:Y,1:"")
;
I $Y>(IOSL-4) D H Q:LR("Q")
;
W !!,LRP,?31,SSN W:DOB'="" ?51,"BORN: ",DOB
S LRI=0
F S LRI=$O(^TMP($J,F,W,LRDFN,LRI)) Q:'LRI!(LR("Q")) D
. D @($S("CYEMSP"[LRSS:"EN",1:"AUT"))
Q
;
;
AUT S LRSF515=+$G(LRSF515)
D:$Y>(IOSL-12) H1 Q:LR("Q")
S X=^LR(LRDFN,"AU"),N=$P(X,"^",6),Y=+X D D^LRU S LRH(3)=Y,DA=LRDFN
D D^LRAUAW S Y=LR(63,12) D D^LRU S E=Y,H(2)=$E(H(1),1,3)
W !,"AUTOPSY #: ",N," AUTOPSY DATE: ",LRH(3),?51,"DIED: ",E
D EN^LRAPT2
S X=0 F S X=$O(^LR(LRDFN,"AY",X)) Q:'X!(LR("Q")) D
. S Y=+^LR(LRDFN,"AY",X,0),Y=$S($D(^LAB(61,Y,0)):$P(^(0),"^"),1:Y)
. W !,Y D AM
Q
;
;
AM S M=0 F S M=$O(^LR(LRDFN,"AY",X,2,M)) Q:'M!(LR("Q")) D
. S Y=+^LR(LRDFN,"AY",X,2,M,0)
. S Y=$S($D(^LAB(61.1,Y,0)):$P(^(0),"^"),1:Y)
. W !?5,Y
Q
;
;
EN ; from LRAPT1,LRAPQACN
S LRSF515=+$G(LRSF515) ;Indicates that this is generating an SF515
S X=$G(^LR(LRDFN,S,LRI,0)) Q:X="" S LR("PATH")=$P(X,U,2),N=$P(X,U,6)
S N(11)=$P(X,U,11),X=$P(X,U,10),X=$P(X,"."),LRH(3)=$$Y2K^LRX(X)
S H(2)=$E(X,1,3)
I LR("PATH")]"" S LR("PATH")=$$EXTERNAL^DILFD(LRSF,.02,"",LR("PATH"),LR("PATH"))
S:N="" N="?" S:'H(2) H(2)="?"
I LRSF515,($Y>(IOSL-11)) D H1 Q:LR("Q")
I 'LRSF515,($Y>(IOSL-4)) D H1 Q:LR("Q")
;
W !?2,"Organ/tissue:",?17,"Date rec'd: ",LRH(3),?43,"Acc #:",N
W ?64,$E(LR("PATH"),1,12)
I 'N(11) W !?5,"Report not verified." Q
; SNOMED codes
I '+$G(LR("SPSM")) D Q:LR("Q")
. S O=0
. F S O=$O(^LR(LRDFN,S,LRI,2,O)) Q:'O!(LR("Q")) D
. . I LRSF515,($Y>(IOSL-11)) D H2 Q:LR("Q")
. . I 'LRSF515,($Y>(IOSL-4)) D H2 Q:LR("Q")
. . S X=^LR(LRDFN,S,LRI,2,O,0),W(3)=$P(X,"^",3)
. . S O(6)=$P(^LAB(61,+X,0),"^")
. . W !?5,O(6) W:W(3) " ",W(3)," gm"
. . D L
; Comments
I $D(LRQ(3)) D
. S B=0 F S B=$O(^LR(LRDFN,S,LRI,99,B)) Q:'B!(LR("Q")) D
. . W !?5,$E(^LR(LRDFN,S,LRI,99,B,0),1,74)
. . I LRSF515,($Y>(IOSL-11)) D H2 Q:LR("Q")
. . I 'LRSF515,($Y>(IOSL-4)) D H2 Q:LR("Q")
Q
;
;
DES ; Print Microscopic Description
Q:$G(LR("Q"))
; If printing SF515 then only print main entry (LRAP="LRDFN^LRIDT") or entry on print queue
I $G(LRSF515),LRAPX=3,$G(LRAP),(LRSS'=S!(LRI'=$P(LRAP,"^",2))) Q
I $G(LRSF515),LRAPX=4,$G(LRPRE),(LRSS'=S!(LRI'=$P(^LRO(69.2,LRAA,1,LRAN,0),"^",2))) Q
Q:'$O(^LR(LRDFN,S,LRI,1.1,0))
W !!,"Microscopic Description/Diagnosis:"
N X,LRL,LRVAL
S LRL=0
F S LRL=$O(^LR(LRDFN,S,LRI,1.1,LRL)) Q:LRL<1!$G(LR("Q")) I ($D(^(LRL,0))#2) S LRVAL=$G(^(0)) D
. I $Y>(IOSL-13) D H2 Q:$G(LR("Q")) W !!,"Microscopic Description/Diagnosis:"
. W !?5,LRVAL
W !
Q
;
;
L ;
S B=0
F S B=$O(^LR(LRDFN,S,LRI,2,O,3,B)) Q:'B!(LR("Q")) D
. S B(1)=+^LR(LRDFN,S,LRI,2,O,3,B,0)
. I LRSF515,($Y>(IOSL-11)) D H3 Q:LR("Q")
. I 'LRSF515,($Y>(IOSL-4)) D H3 Q:LR("Q")
. W !?10,$P(^LAB(61.3,B(1),0),"^")
S B=0
F S B=$O(^LR(LRDFN,S,LRI,2,O,4,B)) Q:'B!(LR("Q")) D
. S X=^LR(LRDFN,S,LRI,2,O,4,B,0),B(1)=+X,B(2)=$P(X,"^",2)
. I LRSF515,($Y>(IOSL-11)) D H3 Q:LR("Q")
. I 'LRSF515,($Y>(IOSL-4)) D H3 Q:LR("Q")
. W !?10,$P(^LAB(61.5,B(1),0),"^")
. W:B(2)]"" " (",$S(B(2)=0:"Negative",B(2)=1:"Positive",1:"?"),")"
S B=0
F S B=$O(^LR(LRDFN,S,LRI,2,O,1,B)) Q:'B!(LR("Q")) D
. S B(1)=+^LR(LRDFN,S,LRI,2,O,1,B,0)
. I LRSF515,($Y>(IOSL-11)) D H3 Q:LR("Q")
. I 'LRSF515,($Y>(IOSL-4)) D H3 Q:LR("Q")
. W !?10,$P(^LAB(61.4,B(1),0),"^")
S M=0
F S M=$O(^LR(LRDFN,S,LRI,2,O,2,M)) Q:'M!(LR("Q")) D
. S M(1)=+^LR(LRDFN,S,LRI,2,O,2,M,0)
. I LRSF515,($Y>(IOSL-11)) D H3 Q:LR("Q")
. I 'LRSF515,($Y>(IOSL-4)) D H3 Q:LR("Q")
. W !?10,$P(^LAB(61.1,M(1),0),"^") D E
S E=0
F S E=$O(^LR(LRDFN,S,LRI,2,O,5,E)) Q:'E!(LR("Q")) D
. S E(1)=^LR(LRDFN,S,LRI,2,O,5,E,0) D A
Q
;
;
A ;
S Y=$P(E(1),"^",2),E(3)=$P(E(1),"^",3),E(4)=$P(E(1),"^")_":"
S E(4)=$P($P(LR(S),E(4),2),";") D D^LRU S E(2)=Y D D^LRU
I LRSF515,($Y>(IOSL-11)) D H3 Q:LR("Q")
I 'LRSF515,($Y>(IOSL-4)) D H3 Q:LR("Q")
W !?5,E(4)," ",E(3)," Date: ",E(2)
Q
;
;
E ;
S E=0
F S E=$O(^LR(LRDFN,S,LRI,2,O,2,M,1,E)) Q:'E!(LR("Q")) W !?12,$P(^LAB(61.2,+^LR(LRDFN,S,LRI,2,O,2,M,1,E,0),0),"^")
Q
;
;
H ;
;
I LRSF515 D F^LRAPF,^LRAPF Q
I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
I $D(LRQ(2)) D H^LRSPT Q
I $D(LRQ(9)) D H^LRAPT1 Q
D F^LRU W !,LRO(68)," "
W:F(2)'="^DPT(" !,"Demographic data in ",F(1)," file."
W !,"Entries listed by PATIENT (From: ",LRSTR," to: ",LRLST,")"
W !,"Name",?31,"Identifier"
W !,LR("%")
Q
;
;
H1 ;
D H
I '$D(LRQ(9)) W !,LRP,?30,SSN,?42,DOB
Q
;
;
H2 ;
D H1
W !?5,"Organ/tissue:",?25,"Date received: ",LRH(3),?51,"Acc #:",N
Q
;
;
H3 ;
D H2
W !?5,O(6) W:W(3) " ",W(3)," gm"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPPF1 5404 printed Nov 22, 2024@17:17:55 Page 2
LRAPPF1 ;DALOI/STAFF - ANAT PATH FILE PRINT BY PT ;11/17/11 10:59
+1 ;;5.2;LAB SERVICE;**72,173,201,259,362,392,350**;Sep 27, 1994;Build 230
+2 ;
+3 ;Reference to ^DIC supported by IA #916
+4 ;
+5 IF $GET(LRSF515)=""
NEW LRSF515
SET LRSF515=0
+6 ;
+7 SET F=0
+8 FOR
SET F=$ORDER(^TMP($JOB,F))
if 'F!(LR("Q"))
QUIT
Begin DoDot:1
+9 SET F(1)=$PIECE(^DIC(F,0),"^")
SET F(2)=^DIC(F,0,"GL")
+10 KILL LR("F")
DO H
SET LR("F")=1
DO W
End DoDot:1
+11 if LR("Q")
QUIT
+12 DO ^LRAPPF2
+13 QUIT
+14 ;
+15 ;
W ;
+1 SET W=0
+2 FOR LRB=0:0
SET W=$ORDER(^TMP($JOB,F,W))
if W=""!(LR("Q"))
QUIT
DO LR
+3 QUIT
+4 ;
+5 ;
LR ;
+1 SET LRDFN=0
+2 FOR
SET LRDFN=$ORDER(^TMP($JOB,F,W,LRDFN))
if 'LRDFN!(LR("Q"))
QUIT
DO NM
+3 QUIT
+4 ;
+5 ;
NM ;
+1 SET X=^LR(LRDFN,0)
SET LRDPF=$PIECE(X,U,2)
SET N=$PIECE(X,"^",3)
SET N=@(F(2)_N_",0)")
+2 SET LRP=$PIECE(N,"^")
SET SSN=$PIECE(N,"^",9)
SET Y=$PIECE(N,"^",3)
+3 DO D^LRU
DO SSN^LRU
SET DOB=$SELECT(Y'[1700:Y,1:"")
+4 ;
+5 IF $Y>(IOSL-4)
DO H
if LR("Q")
QUIT
+6 ;
+7 WRITE !!,LRP,?31,SSN
if DOB'=""
WRITE ?51,"BORN: ",DOB
+8 SET LRI=0
+9 FOR
SET LRI=$ORDER(^TMP($JOB,F,W,LRDFN,LRI))
if 'LRI!(LR("Q"))
QUIT
Begin DoDot:1
+10 DO @($SELECT("CYEMSP"[LRSS:"EN",1:"AUT"))
End DoDot:1
+11 QUIT
+12 ;
+13 ;
AUT SET LRSF515=+$GET(LRSF515)
+1 if $Y>(IOSL-12)
DO H1
if LR("Q")
QUIT
+2 SET X=^LR(LRDFN,"AU")
SET N=$PIECE(X,"^",6)
SET Y=+X
DO D^LRU
SET LRH(3)=Y
SET DA=LRDFN
+3 DO D^LRAUAW
SET Y=LR(63,12)
DO D^LRU
SET E=Y
SET H(2)=$EXTRACT(H(1),1,3)
+4 WRITE !,"AUTOPSY #: ",N," AUTOPSY DATE: ",LRH(3),?51,"DIED: ",E
+5 DO EN^LRAPT2
+6 SET X=0
FOR
SET X=$ORDER(^LR(LRDFN,"AY",X))
if 'X!(LR("Q"))
QUIT
Begin DoDot:1
+7 SET Y=+^LR(LRDFN,"AY",X,0)
SET Y=$SELECT($DATA(^LAB(61,Y,0)):$PIECE(^(0),"^"),1:Y)
+8 WRITE !,Y
DO AM
End DoDot:1
+9 QUIT
+10 ;
+11 ;
AM SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,"AY",X,2,M))
if 'M!(LR("Q"))
QUIT
Begin DoDot:1
+1 SET Y=+^LR(LRDFN,"AY",X,2,M,0)
+2 SET Y=$SELECT($DATA(^LAB(61.1,Y,0)):$PIECE(^(0),"^"),1:Y)
+3 WRITE !?5,Y
End DoDot:1
+4 QUIT
+5 ;
+6 ;
EN ; from LRAPT1,LRAPQACN
+1 ;Indicates that this is generating an SF515
SET LRSF515=+$GET(LRSF515)
+2 SET X=$GET(^LR(LRDFN,S,LRI,0))
if X=""
QUIT
SET LR("PATH")=$PIECE(X,U,2)
SET N=$PIECE(X,U,6)
+3 SET N(11)=$PIECE(X,U,11)
SET X=$PIECE(X,U,10)
SET X=$PIECE(X,".")
SET LRH(3)=$$Y2K^LRX(X)
+4 SET H(2)=$EXTRACT(X,1,3)
+5 IF LR("PATH")]""
SET LR("PATH")=$$EXTERNAL^DILFD(LRSF,.02,"",LR("PATH"),LR("PATH"))
+6 if N=""
SET N="?"
if 'H(2)
SET H(2)="?"
+7 IF LRSF515
IF ($Y>(IOSL-11))
DO H1
if LR("Q")
QUIT
+8 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H1
if LR("Q")
QUIT
+9 ;
+10 WRITE !?2,"Organ/tissue:",?17,"Date rec'd: ",LRH(3),?43,"Acc #:",N
+11 WRITE ?64,$EXTRACT(LR("PATH"),1,12)
+12 IF 'N(11)
WRITE !?5,"Report not verified."
QUIT
+13 ; SNOMED codes
+14 IF '+$GET(LR("SPSM"))
Begin DoDot:1
+15 SET O=0
+16 FOR
SET O=$ORDER(^LR(LRDFN,S,LRI,2,O))
if 'O!(LR("Q"))
QUIT
Begin DoDot:2
+17 IF LRSF515
IF ($Y>(IOSL-11))
DO H2
if LR("Q")
QUIT
+18 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H2
if LR("Q")
QUIT
+19 SET X=^LR(LRDFN,S,LRI,2,O,0)
SET W(3)=$PIECE(X,"^",3)
+20 SET O(6)=$PIECE(^LAB(61,+X,0),"^")
+21 WRITE !?5,O(6)
if W(3)
WRITE " ",W(3)," gm"
+22 DO L
End DoDot:2
End DoDot:1
if LR("Q")
QUIT
+23 ; Comments
+24 IF $DATA(LRQ(3))
Begin DoDot:1
+25 SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,99,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:2
+26 WRITE !?5,$EXTRACT(^LR(LRDFN,S,LRI,99,B,0),1,74)
+27 IF LRSF515
IF ($Y>(IOSL-11))
DO H2
if LR("Q")
QUIT
+28 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H2
if LR("Q")
QUIT
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
+31 ;
DES ; Print Microscopic Description
+1 if $GET(LR("Q"))
QUIT
+2 ; If printing SF515 then only print main entry (LRAP="LRDFN^LRIDT") or entry on print queue
+3 IF $GET(LRSF515)
IF LRAPX=3
IF $GET(LRAP)
IF (LRSS'=S!(LRI'=$PIECE(LRAP,"^",2)))
QUIT
+4 IF $GET(LRSF515)
IF LRAPX=4
IF $GET(LRPRE)
IF (LRSS'=S!(LRI'=$PIECE(^LRO(69.2,LRAA,1,LRAN,0),"^",2)))
QUIT
+5 if '$ORDER(^LR(LRDFN,S,LRI,1.1,0))
QUIT
+6 WRITE !!,"Microscopic Description/Diagnosis:"
+7 NEW X,LRL,LRVAL
+8 SET LRL=0
+9 FOR
SET LRL=$ORDER(^LR(LRDFN,S,LRI,1.1,LRL))
if LRL<1!$GET(LR("Q"))
QUIT
IF ($DATA(^(LRL,0))#2)
SET LRVAL=$GET(^(0))
Begin DoDot:1
+10 IF $Y>(IOSL-13)
DO H2
if $GET(LR("Q"))
QUIT
WRITE !!,"Microscopic Description/Diagnosis:"
+11 WRITE !?5,LRVAL
End DoDot:1
+12 WRITE !
+13 QUIT
+14 ;
+15 ;
L ;
+1 SET B=0
+2 FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,2,O,3,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET B(1)=+^LR(LRDFN,S,LRI,2,O,3,B,0)
+4 IF LRSF515
IF ($Y>(IOSL-11))
DO H3
if LR("Q")
QUIT
+5 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H3
if LR("Q")
QUIT
+6 WRITE !?10,$PIECE(^LAB(61.3,B(1),0),"^")
End DoDot:1
+7 SET B=0
+8 FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,2,O,4,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+9 SET X=^LR(LRDFN,S,LRI,2,O,4,B,0)
SET B(1)=+X
SET B(2)=$PIECE(X,"^",2)
+10 IF LRSF515
IF ($Y>(IOSL-11))
DO H3
if LR("Q")
QUIT
+11 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H3
if LR("Q")
QUIT
+12 WRITE !?10,$PIECE(^LAB(61.5,B(1),0),"^")
+13 if B(2)]""
WRITE " (",$SELECT(B(2)=0:"Negative",B(2)=1:"Positive",1:"?"),")"
End DoDot:1
+14 SET B=0
+15 FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,2,O,1,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+16 SET B(1)=+^LR(LRDFN,S,LRI,2,O,1,B,0)
+17 IF LRSF515
IF ($Y>(IOSL-11))
DO H3
if LR("Q")
QUIT
+18 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H3
if LR("Q")
QUIT
+19 WRITE !?10,$PIECE(^LAB(61.4,B(1),0),"^")
End DoDot:1
+20 SET M=0
+21 FOR
SET M=$ORDER(^LR(LRDFN,S,LRI,2,O,2,M))
if 'M!(LR("Q"))
QUIT
Begin DoDot:1
+22 SET M(1)=+^LR(LRDFN,S,LRI,2,O,2,M,0)
+23 IF LRSF515
IF ($Y>(IOSL-11))
DO H3
if LR("Q")
QUIT
+24 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H3
if LR("Q")
QUIT
+25 WRITE !?10,$PIECE(^LAB(61.1,M(1),0),"^")
DO E
End DoDot:1
+26 SET E=0
+27 FOR
SET E=$ORDER(^LR(LRDFN,S,LRI,2,O,5,E))
if 'E!(LR("Q"))
QUIT
Begin DoDot:1
+28 SET E(1)=^LR(LRDFN,S,LRI,2,O,5,E,0)
DO A
End DoDot:1
+29 QUIT
+30 ;
+31 ;
A ;
+1 SET Y=$PIECE(E(1),"^",2)
SET E(3)=$PIECE(E(1),"^",3)
SET E(4)=$PIECE(E(1),"^")_":"
+2 SET E(4)=$PIECE($PIECE(LR(S),E(4),2),";")
DO D^LRU
SET E(2)=Y
DO D^LRU
+3 IF LRSF515
IF ($Y>(IOSL-11))
DO H3
if LR("Q")
QUIT
+4 IF 'LRSF515
IF ($Y>(IOSL-4))
DO H3
if LR("Q")
QUIT
+5 WRITE !?5,E(4)," ",E(3)," Date: ",E(2)
+6 QUIT
+7 ;
+8 ;
E ;
+1 SET E=0
+2 FOR
SET E=$ORDER(^LR(LRDFN,S,LRI,2,O,2,M,1,E))
if 'E!(LR("Q"))
QUIT
WRITE !?12,$PIECE(^LAB(61.2,+^LR(LRDFN,S,LRI,2,O,2,M,1,E,0),0),"^")
+3 QUIT
+4 ;
+5 ;
H ;
+1 ;
+2 IF LRSF515
DO F^LRAPF
DO ^LRAPF
QUIT
+3 IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+4 IF $DATA(LRQ(2))
DO H^LRSPT
QUIT
+5 IF $DATA(LRQ(9))
DO H^LRAPT1
QUIT
+6 DO F^LRU
WRITE !,LRO(68)," "
+7 if F(2)'="^DPT("
WRITE !,"Demographic data in ",F(1)," file."
+8 WRITE !,"Entries listed by PATIENT (From: ",LRSTR," to: ",LRLST,")"
+9 WRITE !,"Name",?31,"Identifier"
+10 WRITE !,LR("%")
+11 QUIT
+12 ;
+13 ;
H1 ;
+1 DO H
+2 IF '$DATA(LRQ(9))
WRITE !,LRP,?30,SSN,?42,DOB
+3 QUIT
+4 ;
+5 ;
H2 ;
+1 DO H1
+2 WRITE !?5,"Organ/tissue:",?25,"Date received: ",LRH(3),?51,"Acc #:",N
+3 QUIT
+4 ;
+5 ;
H3 ;
+1 DO H2
+2 WRITE !?5,O(6)
if W(3)
WRITE " ",W(3)," gm"
+3 QUIT
